1YLIST executing with Files / Options 1 PAM 11 /tmp/ylist22377.pam OPT - 3 PRINT 3 garfield-7.lis VERSION PATCHY 4.15 /1 911211 12.02 .RJP, TODAY: 1020207 1828 OPTIONS .................R............ RESUME 'PAM ' 0 GARFIELD ================================================== P=*TITLE* D= 1 ============================ 1 - GARFIELD 7.04 /00 010203 00.00 2 - * 3 - * GARFIELD, A drift-chamber simulation program. 4 - * 5 - * This is Garfield version 7.04, updated until 2/ 3/01. Comments and 6 - * reports are most welcome. A copy of any note, thesis or publication 7 - * for which Garfield has been used, will be highly appreciated. 8 - * 9 - * Garfield is available free of charge to any interested party, in the 10 - * understanding that the program shall not be sold nor resold and that 11 - * the program shall be used exclusively for scientific purposes. 12 - * 13 - * The author can not be held responsible for any error in this program, 14 - * in any of the associated files, nor in the documentation. 15 - * 16 - * Documentation relative to this program, as well as recent copies of 17 - * the program files can be obtained at the URLs: 18 - * 19 - * CNL articles: http://cern.ch/garfield/cnl 20 - * Some examples: http://cern.ch/garfield/examples 21 - * Files: http://cern.ch/garfield/files 22 - * Command format: http://cern.ch/garfield/help 23 - * 24 - * Author: Rob Veenhof Rob Veenhof 25 - * CERN EP division 2, Rue du Reculet 26 - * CH-1211 Geneve 23 or F 01630 St Genis Pouilly 27 - * Switzerland / Suisse France 28 - * tel: + 41 22 7671156 tel: + 33 4 50421784 29 - * Fax: + 41 22 7678350 30 - * email: Rob.Veenhof@cern.ch 31 - * 32 - * Contributions: 33 - * 34 - * G.A. Erskine (retired, DD division CERN). 35 - * Carlo Mekenkamp (Rijks Universiteit Leiden). 36 - * 37 - * CERN program library reference: W5050 38 - * 39 - * Copyright: Rob Veenhof, 2001. 1 GARFIELD ================================================== P=*APOLLO D= 1 ============================ 0 + +PATCH,*APOLLO. Pilot patch for Apollo SR10 1 + +IMI,APOLLO. 2 + +IMI,SAVE. 3 + +IMI,GTSGRAL. 2 GARFIELD ================================================== P=*IBMVM D= 1 ============================ 0 + +PATCH,*IBMVM. Pilot patch for VM/CMS (Miguel) 1 + +USE,*CMS. 3 GARFIELD ================================================== P=*CMS D= 1 ============================ 0 + +PATCH,*CMS. Pilot patch for VM/CMS systems 1 + +IMI,CMS. 2 + +IMI,NAG,IF=CERN,IF=-HIGZ. 3 + +IMI,GTSGRAL. 4 + +IMI,ESSL. 4 GARFIELD ================================================== P=*CRAY D= 1 ============================ 0 + +PATCH,*CRAY. Pilot patch for Cray UNICOS 1 + +IMI,CRAY. 2 + +IMI,GTSGRAL. 3 + +IMI,VECTOR. 4 + +IMI,UNIX. 5 + +IMI,SAVE. 5 GARFIELD ================================================== P=*ALLIANT D= 1 ============================ 0 + +PATCH,*ALLIANT. Various Unix selection patches. 1 + +USE,*UNIX. 2 + +IMI,ALLIANT. 6 GARFIELD ================================================== P=*CONVEX D= 1 ============================ 0 + +PATCH,*CONVEX. 1 + +USE,*UNIX. 2 + +IMI,CONVEX. 7 GARFIELD ================================================== P=*IBMAIX D= 1 ============================ 0 + +PATCH,*IBMAIX. 1 + +USE,*UNIX. 2 + +IMI,IBMAIX. 8 GARFIELD ================================================== P=*UNISYS D= 1 ============================ 0 + +PATCH,*UNISYS. 1 + +USE,*UNIX. 2 + +IMI,UNISYS. 1 9 GARFIELD ================================================== P=*DECS D= 1 =================== PAGE 1 0 + +PATCH,*DECS. 1 + +USE,*UNIX. 2 + +IMI,DECS. 10 GARFIELD ================================================== P=*GOULD D= 1 ============================ 0 + +PATCH,*GOULD. 1 + +USE,*UNIX. 2 + +IMI,GOULD. 11 GARFIELD ================================================== P=*HPUX D= 1 ============================ 0 + +PATCH,*HPUX. 1 + +USE,*UNIX. 2 + +IMI,HPUX. 12 GARFIELD ================================================== P=*IBMRT D= 1 ============================ 0 + +PATCH,*IBMRT. IBM RT, also used for SP2. 1 + +USE,*UNIX. 2 + +IMI,ESSL. 3 + +IMI,IBMRT. 13 GARFIELD ================================================== P=*MACMPW D= 1 ============================ 0 + +PATCH,*MACMPW. 1 + +USE,*UNIX. 2 + +IMI,MACMPW. 14 GARFIELD ================================================== P=*MIPS D= 1 ============================ 0 + +PATCH,*MIPS. 1 + +USE,*UNIX. 2 + +IMI,MIPS. 15 GARFIELD ================================================== P=*SGI D= 1 ============================ 0 + +PATCH,*SGI. 1 + +USE,*UNIX. 2 + +IMI,SGI. 16 GARFIELD ================================================== P=*SUN D= 1 ============================ 0 + +PATCH,*SUN. 1 + +USE,*UNIX. 2 + +IMI,SUN. 17 GARFIELD ================================================== P=*NEXT D= 1 ============================ 0 + +PATCH,*NEXT. 1 + +USE,*UNIX. 2 + +IMI,NEXT. 18 GARFIELD ================================================== P=*QMVAOS D= 1 ============================ 0 + +PATCH,*QMVAOS. 1 + +USE,*UNIX. 2 + +IMI,QMVAOS. 19 GARFIELD ================================================== P=*UNIX D= 1 ============================ 0 + +PATCH,*UNIX. Pilot patch for Unix 1 + +IMI,UNIX. 2 + +IMI,SAVE. 3 + +IMI,HIGZ. 20 GARFIELD ================================================== P=*LINUX D= 1 ============================ 0 + +PATCH,*LINUX. Pilot patch for IBM PC 1 + +IMI,LINUX. 2 + +IMI,UNIX. 3 + +IMI,SAVE. 4 + +IMI,HIGZ. 5 + +IMI,QF2C. 21 GARFIELD ================================================== P=*MVS D= 1 ============================ 0 + +PATCH,*MVS. Pilot patch for IBM MVS systems 1 + +IMI,MVS. 2 + +IMI,GTSGRAL. 22 GARFIELD ================================================== P=*VAX D= 1 ============================ 0 + +PATCH,*VAX. Pilot patch for Vax VMS 1 + +IMI,VAX. 2 + +IMI,NAG,IF=CERN. 3 + +IMI,AST,IF=-QMALPH. 4 + +IMI,GTSGRAL. 5 + +IMI,SAVE. 23 GARFIELD ================================================== P=*INTERFA D= 1 ============================ 0 + +PATCH,*INTERFACE. Isolate user interface 1 + +USE,P=COMMONS. 2 + +USE,P=GRAPHICS. 3 + +USE,P=GKSHIGZ,IF=HIGZ. 4 + +USE,P=PROJECTION. 5 + +USE,P=INPUT. 6 + +USE,P=DATASET. 7 + +USE,P=ALGEBRA. 8 + +USE,P=HELP,T=INHIBIT. 9 + +USE,P=HISTOGRAM. 10 + +USE,P=MATRIX. 11 + +USE,P=ROUTINES. 12 + +USE,P=ROUTINES,D=VMCMS,T=INHIBIT. 1 23 P=*INTERFA D= 2 PAGE 2 13 + +USE,P=ROUTINES,D=SUBSET,T=INHIBIT. 24 GARFIELD ================================================== P=*PATCHES D= 1 ============================ 0 + +PATCH,*PATCHES. For backwards compatibility. 1 + +USE,*GARFIELD. 25 GARFIELD ================================================== P=*GARFIEL D= 1 ============================ 0 + +PATCH,*GARFIELD. Main routine selection patch. 1 + +USE,P=COMMONS. 2 + +USE,P=MAIN. 3 + +USE,P=GRAPHICS. 4 + +USE,P=GKSHIGZ,IF=HIGZ. 5 + +USE,P=PROJECTION. 6 + +USE,P=INPUT. 7 + +USE,P=DATASET. 8 + +USE,P=ALGEBRA. 9 + +USE,P=ROUTINES. 10 + +USE,P=ROUTINES,D=VMCMS,T=INHIBIT. 11 + +USE,P=ROUTINES,D=SUBSET,T=INHIBIT. 12 + +USE,P=VAXAST,IF=VAX,IF=AST. 13 + +USE,P=HISTOGRAM. 14 + +USE,P=MATRIX. 15 + +USE,P=HELP. 16 + +USE,P=CELL. 17 + +USE,P=GAS. 18 + +USE,P=OPTIMISE,IF=CELL. 19 + +USE,P=FIELD,IF=CELL. 20 + +USE,P=FIELDCAL,IF=CELL,FIELD,OPTIMISE,DRIFT,SIGNAL. 21 + +USE,P=ZERO,IF=FIELD. 22 + +USE,P=DRIFT,IF=CELL,IF=GAS. 23 + +USE,P=SIGNAL,IF=CELL,IF=GAS. 24 + +USE,P=DRIFTCAL,IF=DRIFT,SIGNAL. 25 + +USE,P=AUXILIARY,D=CLD,IF=VAX. 26 + +USE,P=AUXILIARY,D=MAINHELP. 26 GARFIELD ================================================== P=*GARFRUN D= 1 ============================ 0 + +PATCH,*GARFRUN. Front end program. 1 + +USE,P=FRONTEND. 2 + +USE,P=AUXILIARY,D=CLD,IF=VAX. 3 + +USE,P=AUXILIARY,D=LSE,IF=VAX. 4 + +USE,P=AUXILIARY,D=GARFRUNMSG,IF=VAX. 5 + +USE,P=AUXILIARY,D=HELPVAX,IF=VAX. 6 + +USE,P=AUXILIARY,D=HELPCMS,IF=CMS. 7 + +USE,P=AUXILIARY,D=MANPAGE,IF=UNIX. 8 + +USE,P=AUXILIARY,D=PANEL,IF=CMS. 9 + +USE,P=AUXILIARY,D=MINIEXEC,IF=CMS. 27 GARFIELD ================================================== P=COMMONS D= 1 ============================ 0 + +PATCH,COMMONS. 0 1 + +KEEP,XDIMENSIONS,IF=NEVER. 2 . *----------------------------------------------------------------------- 3 . * Parameter block containing the dimensions of the arrays. 4 . * Changing the parameters in this block influences the entire 5 . * program, but it should be used to save space on the one 6 . * hand and to accomodate many wires on the other hand. 7 . * PARAMETER : MXWIRE : Maximum number of wires that can be stored. 8 . * MXSW : Maximum number of sense wires. 9 . * MXPSTR : Maximum number of strips per plane. 10 . * MXMATT : Maximum number of x and y dielectrica. 11 . * MX3D : Maximum number of 3 dimensional charges. 12 . * MXPOLE : Maximum number of multipole terms. 13 . * MXLIST : Maximum number of points in lists eg in the 14 . * gas tables or on the drift lines etc. 15 . * MXGRID : Maximum number of grid points. 16 . * MXNAME : Maximum number of characters in dsnames. 17 . * MXLUN : Highest input LUN allowed to be open. 18 . * MXCLUS : Maximum number of clusters along the track. 19 . * MXPAIR : Maximum number of ion pairs in one cluster 20 . * MXLINE : Maximum number of drift lines (equal time). 21 . * MXEQUT : Maximum number of equal time contours. 22 . * MXFOUR : Maximum number of Fourier terms (ion tail). 23 . * MXRECL : Maximum lrecl of a direct access file. 24 . * MXINCH : Maximum number of characters / input line. 25 . * MXWORD : Maximum number of words a line may contain. 26 . * MXCHAR : Maximum number of characters in each word. 27 . * MXINS : Maximum number of instructions in a list. 28 . * MXREG : Maximum number of varying numbers. 29 . * MXCONS : Maximum number of constants. 30 . * MXVAR : Maximum number of variables to be passed. 31 . * MXZERO : Maximum number of zeros to be handled. 32 . * MXCHA : Maximum number of channels in a histogram. 33 . * MXPART : Maximum number of particles on a track. 34 . * MXSTCK : Maximum stack level for integrations. 35 . * MXFPAR : Maximum number of fitting parameters. 36 . * MXFPNT : Maximum number of fitting data-points. 37 . * MXWKLS : Maximum number of active workstations. 38 . * MXHLRL : Record length for the help file. 39 . * MXSUBT : Maximum sublevel depth during help. 40 . * MXHLEV : Maximum number of levels in the help file. 41 . * MXFRAC : Maximum number of gas components. 42 . * MXBANG : Maximum number of E-B angles in tables. 43 . * MXBTAB : Maximum number of B fields in the tables. 44 . * MXORIA : Maximum number of ion origin angles. 45 . * MXMAT : Maximum number of matrices. 46 . * MXEMAT : Total matrix storage area. 47 . * MXMDIM : Maximum number of matrix dimensions. 48 . * MXEPS : Maximum number of media in a field map. 49 . * MXMAP : Maximum number of triangles in a field map. 50 . * MXWMAP : Maximum number of weighting field maps. 51 . * MXSOLI : Maximum number of conductors. 52 . * MXPLAN : Maximum number of planes in buffer. 1 27 P=COMMONS D= 2 PAGE 3 53 . * MXPOIN : Maximum number of points in buffer. 54 . * MXEDGE : Maximum number of edges per polygon. 55 . * MXMCA : Maximum avalanche size 56 . * (Last changed on 6/ 1/01.) 57 . *----------------------------------------------------------------------- 0 58 + +KEEP,DIMWIRE,IF=MANYWIRE. 59 . PARAMETER (MXWIRE= 2000,MXSW = 100) 0 60 + +KEEP,DIMWIRE,IF=-MANYWIRE. 61 . PARAMETER (MXWIRE= 300,MXSW = 50) 0 62 + +KEEP,DIMLIST,IF=LONGLIST. 63 . PARAMETER (MXLIST= 1000) 0 64 + +KEEP,DIMLIST,IF=-LONGLIST. 65 . PARAMETER (MXLIST= 200) 0 66 + +KEEP,DIMMAP,IF=HUGEMAP. 67 . PARAMETER (MXMAP = 50000,MXEPS = 10) 0 68 + +KEEP,DIMMAP,IF=BIGMAP. 69 . PARAMETER (MXMAP = 30000,MXEPS = 10) 0 70 + +KEEP,DIMMAP,IF=-BIGMAP,IF=-HUGEMAP. 71 . PARAMETER (MXMAP = 5000,MXEPS = 10) 0 72 + +KEEP,DIMENSIONS. 73 . INTEGER MXWIRE,MXSW,MXLIST,MXCHA,MXGRID,MXMATT,MXPOLE,MX3D, 74 . - MXPSTR, 75 . - MXPAIR,MXPART,MXFOUR,MXCLUS, 76 . - MXLINE,MXEQUT, 77 . - MXRECL,MXINCH,MXWORD,MXCHAR,MXNAME,MXLUN, 78 . - MXINS,MXREG,MXARG,MXCONS,MXVAR,MXALGE, 79 . - MXZERO,MXSTCK,MXFPNT,MXFPAR,MXWKLS, 80 . - MXHLEV,MXHLRL,MXSUBT, 81 . - MXDLVL,MXILVL,MXDLIN, 82 . - MXHIST,MXFRAC,MXBANG,MXBTAB, 83 . - MXORIA, 84 . - MXMAT,MXEMAT,MXMDIM, 85 . - MXSHOT,MXZPAR, 86 . - MXMAP,MXEPS,MXWMAP,MXSOLI,MXSBUF, 87 . - MXPLAN,MXPOIN,MXEDGE, 88 . - MXMCA 89.. +SEQ,DIMWIRE. 90 . PARAMETER (MXMATT= 10) 91 . PARAMETER (MX3D = 100) 92 . PARAMETER (MXPOLE= 10) 93 . PARAMETER (MXPSTR= 10) 94.. +SEQ,DIMLIST. 95 . PARAMETER (MXHIST= 200,MXCHA =MXLIST/2) 96 . PARAMETER (MXGRID= 50) 97 . PARAMETER (MXNAME= 200,MXLUN = 30) 98 . PARAMETER (MXCLUS= 500,MXPAIR= 2000,MXPART=10000) 99 . PARAMETER (MXLINE= 150,MXEQUT= 50) 100 . PARAMETER (MXFOUR= 16) 101 . PARAMETER (MXRECL= 10000) 102 . PARAMETER (MXINCH= 2000,MXWORD= 50,MXCHAR=MXINCH) 103 . PARAMETER (MXINS = 1000,MXREG = 500,MXCONS= -500,MXVAR = 500, 104 . - MXALGE= 500,MXARG = 100) 105 . PARAMETER (MXMAT = 500,MXEMAT=50000,MXMDIM= 10) 106 . PARAMETER (MXZERO=MXWIRE) 107 . PARAMETER (MXSTCK= 5) 108 . PARAMETER (MXFPNT= 200,MXFPAR= 10) 109 . PARAMETER (MXWKLS= 10) 110 . PARAMETER (MXHLEV= 9,MXSUBT= 180,MXHLRL=768) 111 . PARAMETER (MXDLVL= 10,MXILVL= 20,MXDLIN=500) 112 . PARAMETER (MXFRAC= 13) 113 . PARAMETER (MXBANG= 10,MXBTAB= 10) 114 . PARAMETER (MXORIA= 1000) 115 . PARAMETER (MXSHOT= 10,MXZPAR=4*MXSHOT+2) 116.. +SEQ,DIMMAP. 117 . PARAMETER (MXWMAP= 4) 118 . PARAMETER (MXSOLI= 500) 119 . PARAMETER (MXPLAN= 5000,MXPOIN=20000,MXEDGE=100) 120 . PARAMETER (MXSBUF= 10000) 121 . PARAMETER (MXMCA = 10000) 0 122 + +KEEP,XPARAMETERS,IF=NEVER. 123 . *----------------------------------------------------------------------- 124 . * PARMS - Common block containing quantities of interest for plotting 125 . * and numerical calculations. 126 . * VARIABLES : NGRIDX, Y : Number of x resp y devisions of a grid. 127 . * NLINED : Number of tracks starting at each edge of 128 . * of the drift area or at each wire. 129 . * NINORD : Drift line interpolation order. 130 . * LINCAL : Compute lines which can't be interpolated. 131 . * PXMIN,PXMAX: x-range of field plot area. 132 . * PYMIN,PYMAX: y-range of field plot area. 133 . * PZMIN,PZMAX: z-range of field plot area. 134 . * GXMIN,GXMAX: x-range of graphics plot area. 135 . * GYMIN,GYMAX: y-range of graphics plot area. 136 . * GZMIN,GZMAX: z-range of graphics plot area. 137 . * G[X/Y/Z]BOX: Enclosing area box in screen coordinates. 138 . * NGBOX : Entries in G[X/Y/Z]BOX. 139 . * FPROJ : Viewing plane for field plots. 140 . * FPRMAT : Matrix used for projections. 141 . * IPRMAT : Row interchanges for solving FPRMAT. 142 . * EPSG[X/Y/Z]: Tolerances for point comparisons. 143 . * LEPSG : Tolerances set or not. 144 . * PXLAB : x-Axis label, length is NCXLAB 145 . * PYLAB : y-Axis label, length is NCYLAB 146 . * PROLAB : Projection label, length is NCFPRO 147 . * PROROT : Axis rotation. 148 . * PRVIEW : Projection type. 149 . * PRFREF : Sharing Reflected vs Diffuse scattering 1 27 P=COMMONS D= 3 PAGE 4 150 . * PRFABS : Visible vs Absorbed light fraction 151 . * PRFMIN/MAX : Light shading range in use 152 . * NPRCOL : Number of shades of each colour 153 . * ICOLBX : Start of box and tickmarks colour table. 154 . * ICOLPL : Start of plans and tube colour table. 155 . * ICOLST : Start of strips colour table. 156 . * ICOLW1 : Start of conductor 1 colour table. 157 . * ICOLW2 : Start of conductor 2 colour table. 158 . * ICOLW3 : Start of conductor 3 colour table. 159 . * ICOLD1 : Start of dielectricum 1 colour table. 160 . * ICOLD2 : Start of dielectricum 2 colour table. 161 . * ICOLD3 : Start of dielectricum 3 colour table. 162 . * XT0,YT0,...: Defines a track (always in Cart. coord.) 163 . * LTRMS : Take multiple scattering into account. 164 . * LTRDEL : Generate delta electrons. 165 . * LTRINT : Use track interpolation to save time. 166 . * LTREXB : Request tracing through E and B fields 167 . * ITRTYP : Type of track generation requested: 168 . * 1 = fixed number of lines over track, 169 . * 2 = equal cluster spacing, d=1/n_mean, 170 . * 3 = exponential cluster spacing, 171 . * 4 = HEED cluster generation. 172 . * 5 = weighted distribution 173 . * 6 = single cluster 174 . * 7 = equal flux intervals 175 . * 8 = constant flux intervals 176 . * NTRLIN : Number of lines for ITRTYP=1. 177 . * TRFLAG : Track status flags: 178 . * 1 = geometry set 179 . * 2 = energy, mass and charge set 180 . * 3 = number of points set 181 . * 4 = weighting function set 182 . * 5 = number of samples set 183 . * 6 = number of flux lines set 184 . * NTRFLX : Number of flux lines (model 7) 185 . * TRFLUX : Flux interval in V (model 8) 186 . * TRTH,TRPHI : Track orientation 187 . * WGT : Weighting distribution 188 . * FCNTRW : Weighting function 189 . * LGSTEP : Display one panel at the time (debug) 190 . * (Last changed on 30/11/00.) 191 . *----------------------------------------------------------------------- 0 192 + +KEEP,PARAMETERS. 193 . DOUBLE PRECISION WGT,FPRMAT, 194 . - FPROJ,FPROJA,FPROJB,FPROJC,FPROJD,FPROJN, 195 . - EPSGX,EPSGY,EPSGZ, 196 . - GXMIN,GYMIN,GZMIN,GXMAX,GYMAX,GZMAX, 197 . - GXBOX,GYBOX,GZBOX 198 . REAL PXMIN,PYMIN,PZMIN,PXMAX,PYMAX,PZMAX, 199 . - PRTHL,PRPHIL,PRAL,PRBL,PRCL,PROROT, 200 . - PRFABS,PRFREF,PRFMIN,PRFMAX,PRFCAL, 201 . - XT0,YT0,ZT0,XT1,YT1,ZT1, 202 . - TRMASS,TRENER,TRCHAR,TRXDIR,TRYDIR,TRZDIR,TRTH,TRPHI,TRDIST, 203 . - TRFLUX 204 . INTEGER NLINED,NGRIDX,NGRIDY,ITRTYP,NTRLIN,NTRSAM,INDPOS,NCTRW, 205 . - NTRFLX,NINORD, 206 . - NCPNAM,NCXLAB,NCYLAB,NCFPRO,IPRMAT, 207 . - NPRCOL,ICOL0,ICOLBX,ICOLPL,ICOLST,ICOLW1,ICOLW2,ICOLW3, 208 . - ICOLD1,ICOLD2,ICOLD3,NGBOX 209 . LOGICAL LTRMS,LTRDEL,LTRINT,LTREXB,TRFLAG,LINCAL, 210 . - LFULLB,LFULLP,LFULLT,LSPLIT,LSORT,LOUTL,LEPSG,LGSTEP 211 . COMMON /PARMS / WGT(MXLIST),FPRMAT(3,3), 212 . - FPROJ(3,3),FPROJA,FPROJB,FPROJC,FPROJD,FPROJN, 213 . - EPSGX,EPSGY,EPSGZ, 214 . - GXMIN,GYMIN,GZMIN,GXMAX,GYMAX,GZMAX, 215 . - GXBOX(12),GYBOX(12),GZBOX(12), 216 . - PXMIN,PYMIN,PZMIN,PXMAX,PYMAX,PZMAX, 217 . - PRTHL,PRPHIL,PRAL,PRBL,PRCL,PROROT, 218 . - PRFABS,PRFREF,PRFMIN,PRFMAX,PRFCAL, 219 . - XT0,YT0,ZT0,XT1,YT1,ZT1, 220 . - TRMASS,TRENER,TRCHAR,TRXDIR,TRYDIR,TRZDIR,TRTH,TRPHI,TRDIST, 221 . - TRFLUX, 222 . - INDPOS(1000),IPRMAT(3),NCTRW,NCPNAM, 223 . - ITRTYP,NTRLIN,NTRSAM,NTRFLX,NLINED,NINORD,NGRIDX,NGRIDY, 224 . - NCXLAB,NCYLAB,NCFPRO, 225 . - NPRCOL,ICOL0,ICOLBX,ICOLPL,ICOLST,ICOLW1,ICOLW2,ICOLW3, 226 . - ICOLD1,ICOLD2,ICOLD3,NGBOX, 227 . - LTRMS,LTRDEL,LTRINT,LTREXB,TRFLAG(10),LINCAL, 228 . - LFULLB,LFULLP,LFULLT,LSPLIT,LSORT,LOUTL,LEPSG,LGSTEP 229 . CHARACTER*80 PARTID,PXLAB,PYLAB,PROLAB 230 . CHARACTER*10 PNAME 231 . CHARACTER*5 PRVIEW 232 . CHARACTER*(MXCHAR) FCNTRW 233 . COMMON /PARCHR/ PARTID,FCNTRW,PNAME,PXLAB,PYLAB,PROLAB,PRVIEW 0 234 + +KEEP,XCONSTANTS,IF=NEVER. 235 . *----------------------------------------------------------------------- 236 . * CONSTANTS - Parameter block containing some common constants. 237 . * PARAMETERS: PI : 3.141592653589793238 238 . * CLOG2 : Log(2) [Natural logarithm of course !] 239 . * ICONS : ICONS**2=-1. 240 . * EPS0 : Vacuum dielectric constant [F/cm]. 241 . * ECHARG : Charge of the electron [C]. 242 . * EMASS : Mass of the electron [kg]. 243 . * GRAV : Gravitational constant [m/sec**2]. 244 . * BOLTZ : Boltzmann constant [J/K]. 245 . * CLIGHT : Speed of light [cm/microsec]. 246 . * (Last changed on 10/ 2/97.) 247 . *----------------------------------------------------------------------- 0 248 + +KEEP,CONSTANTS. 249 . COMPLEX ICONS 250 . REAL PI,CLOG2,EPS0,ECHARG,EMASS,CLIGHT,BOLTZ,GRAV 251 . PARAMETER (PI=3.141592653589793238, 252 . - CLOG2=0.693147180559945309417, 1 27 P=COMMONS D= 4 PAGE 5 253 . - ICONS=(0.0,1.0), 254 . - EPS0=8.854187817E-14, 255 . - ECHARG=1.60217733E-19, 256 . - EMASS=9.1093897E-31, 257 . - GRAV=9.80665, 258 . - CLIGHT=2.99792458E4, 259 . - BOLTZ=1.380658E-23) 0 260 + +KEEP,XPRINTPLOT,IF=NEVER. 261 . *----------------------------------------------------------------------- 262 . * PRTPLT - Common block specifying what should and what should not be 263 . * printed/plotted. It also contains the debug options. 264 . * VARIABLES : LINPUT : yes/no printing of the input, 265 . * LDEBUG : yes/no debuging output, 266 . * LIDENT : yes/no routine identification, 267 . * LKEYPL : yes/no plotting of contour keys (NAG), 268 . * LCELPR : yes/no printing of cell data, 269 . * LCELPL : yes/no plotting of cell layout, 270 . * LDRPLT : yes/no drift lines plotted, 271 . * LDRPRT : yes/no printing of drift line data, 272 . * LCLPRT : yes/no printing of cluster history, 273 . * LCLPLT : yes/no printing of plotting of cluster etc, 274 . * LPROPR : yes/no printing of progress. 275 . * LPROF : yes/no reading of profile 276 . * LMAPCH : yes/no check of field map indexing 277 . * LSYNCH : Synchronisation prompt format. 278 . * LUNOUT : unit to be used for output. 279 . * JFAIL : Action in case of an error (1=carry on with 280 . * defaults, 2=skip the line, 3=stop program). 281 . * JEXMEM : Action in case a member already exists 282 . * (1=delete old copy, 2=write+warn, 3=warn) 283 . * LGSTOP : Dump and stop after graphics fault (debug) 284 . * LGSIG : Signal top dump and stop. 285 . * (Last changed on 15/12/98.) 286 . *----------------------------------------------------------------------- 0 287 + +KEEP,PRINTPLOT. 288 . LOGICAL LINPUT,LCELPR,LCELPL,LWRMRK,LISOCL,LCHGCH, 289 . - LDRPLT,LDRPRT,LCLPRT,LCLPLT,LMAPCH,LCNTAM, 290 . - LDEBUG,LIDENT,LKEYPL,LRNDMI,LPROPR,LPROF,LGSTOP,LGSIG, 291 . - LSYNCH 292 . INTEGER LUNOUT,JFAIL,JEXMEM 293 . COMMON /PRTPLT/ LINPUT,LCELPR,LCELPL,LWRMRK,LISOCL,LCHGCH, 294 . - LDRPLT,LDRPRT,LCLPRT,LCLPLT,LMAPCH,LCNTAM, 295 . - LDEBUG,LIDENT,LKEYPL,LRNDMI,LPROPR,LPROF,LGSTOP,LGSIG, 296 . - LSYNCH,LUNOUT,JFAIL,JEXMEM 0 297 + +KEEP,XCELLDATA,IF=NEVER. 298 . *----------------------------------------------------------------------- 299 . * CELDAT - Common block containing all information on the cell, such 300 . * CELCHR as the wire data, planes, constants etc. 301 . * VARIABLES : X(I),Y(I) : Position of wire I [cm]. 302 . * WMAP(I) : Mapped wire positions [cm]. 303 . * D(I) : Diameter of wire I [cm]. 304 . * E(I),V(I) : Charge on wire i, potential of wire I. 305 . * W(I) : Stretching weight of the wire [grams]. 306 . * U(I) : Length of the wire [cm]. 307 . * DENS(I) : Density of the wire [g/cm3]. 308 . * WIRTYP(I) : Type of wire of wire I. 309 . * NWIRE : Number of wires present in the cell. 310 . * N3D : Number of three-dimensional charges. 311 . * X3D,Y3D,Z3D: Positions of the three-dimensional charges. 312 . * E3D : Charge of the three-dimensional charges. 313 . * NTERMB/D : Number of terms for 3D B2 potentials. 314 . * XMIN, XMAX : x-range of the cell comsidered [cm]. 315 . * YMIN, YMAX : y-range of the cell considered [cm]. 316 . * ZMIN, ZMAX : z-range of the cell considered [cm]. 317 . * YNPLAN(I) : Plane I exist if .TRUE. 318 . * COPLAN(I) : Relevant coordinate of plane I 319 . * VTPLAN(I) : Potential of plane I. 320 . * PLATYP(I) : Label of plane I. 321 . * YNPLAX,YNPLAY: Yes/no plane in x or y (reduce CPU time). 322 . * COPLAX,COPLAY: Coordinates of planes (reduce CPU time). 323 . * INDPLA : Conductor group number for plane I, 324 . * the tube has number 5. 325 . * PLSTR1(I,J,K): x/y-strip J for plane I, K=1: lower 326 . * limit, K=2: upper limit, K=3: gap. 327 . * PLSTR2(I,J,K): z-strip J for plane I, K=1: lower limit, 328 . * K=2: upper limit, K=3: gap. 329 . * PSLAB1/2 : Labels of strips. 330 . * NPSTR1/2(I): Number of x/y and z strips in plane I. 331 . * INDST1/2 : Conductor group numbers for strips. 332 . * XMATT(I,.) : x-start, x-end, eps of x-dielectricum I. 333 . * YMATT(I,.) : y-start, y-end, eps of y-dielectricum I. 334 . * NXMATT : Number of x-dielectrica. 335 . * NYMATT : Number of y-dielectrica. 336 . * V0 : Voltage added to obtain: sum charges =0. 337 . * PERX/Y/Z : Yes/no x, y, z periodicity. 338 . * PERMX/Y/Z : Yes/no x, y, z mirror periodicity. 339 . * PERAX/Y/Z : Yes/no x, y, z axial periodicity. 340 . * PERRX/Y/Z : Yes/no x, y, z rotation symmetry 341 . * TYPE : Cell type. 342 . * ICTYPE : Integer cell type (is more efficient). 343 . * SX, SY, SZ : Periodicity in x, y, z (if relevant). 344 . * INDSW(I) : Gives the sense wire number for wire I. 345 . * NSW : Number of sense wires. 346 . * YNMATX,YNMATY: Yes/no dielectricum in x or y (idem). 347 . * COMATX,COMATY: Coordinates of dielectricum (idem). 348 . * B2SIN : Vector of sinuses for B2 (reduce CPU time). 349 . * CORVTA,B,C : CORVTA*X + CORVTB*Y + CORVTC = 350 . * potential due to the planes only. 351 . * VMIN,VNAX : Range of voltages in the cell. 352 . * DOWN : Chamber orientation 353 . * POLAR : The cell has cylindrical/polar symmetry. 354 . * TUBE : Geometry with wires inside a tube. 355 . * VTTUBE : Voltage of the tube. 1 27 P=COMMONS D= 5 PAGE 6 356 . * COTUBE : Radius of the tube. 357 . * NTUBE : Number of edges of the tube. 358 . * MTUBE : Periodicity in the tube. 359 . * KAPPA : Constant used for mappings. 360 . * CNALSO : Flag to select only mirror images of a wire 361 . * IENBGF : Entry for the background field. 362 . * LBGFMP : Background field uses field map. 363 . * (Last changed on 5/12/00.) 364 . *----------------------------------------------------------------------- 0 365 + +KEEP,CELLDATA. 366 . CHARACTER*80 CELLID 367 . CHARACTER*3 TYPE 368 . CHARACTER WIRTYP(MXWIRE),PLATYP(5), 369 . - PSLAB1(5,MXPSTR),PSLAB2(5,MXPSTR) 370 . LOGICAL YNPLAN(4),PERX,PERY,PERZ,YNPLAX,YNPLAY,YNMATX,YNMATY, 371 . - POLAR,TUBE,PERMX,PERMY,PERMZ,PERAX,PERAY,PERAZ, 372 . - PERRX,PERRY,PERRZ,CNALSO(MXWIRE),LBGFMP,CELSET 373 . INTEGER INDSW(MXWIRE),NWIRE,NSW,ICTYPE,MODE,NTUBE,MTUBE, 374 . - NXMATT,NYMATT,N3D,NTERMB,NTERMP,IENBGF, 375 . - INDPLA(5),NPSTR1(5),NPSTR2(5), 376 . - INDST1(5,MXPSTR),INDST2(5,MXPSTR) 377 . REAL X(MXWIRE),Y(MXWIRE),V(MXWIRE),E(MXWIRE),D(MXWIRE),W(MXWIRE), 378 . - U(MXWIRE),DENS(MXWIRE), 379 . - COPLAN(4),VTPLAN(4),XMATT(MXMATT,5),YMATT(MXMATT,5), 380 . - X3D(MX3D),Y3D(MX3D),Z3D(MX3D),E3D(MX3D), 381 . - DOWN(3),PLSTR1(5,MXPSTR,3),PLSTR2(5,MXPSTR,3), 382 . - COTUBE,VTTUBE,B2SIN(MXWIRE),P1,P2,C1, 383 . - XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX,VMIN,VMAX, 384 . - COPLAX,COPLAY,COMATX,COMATY, 385 . - CORVTA,CORVTB,CORVTC,V0,SX,SY,SZ, 386 . - KAPPA 387 . COMPLEX ZMULT,WMAP(MXWIRE) 388 . COMMON /CELDAT/ ZMULT,WMAP,X,Y,V,E,D,W,U,DENS, 389 . - B2SIN,COPLAN,VTPLAN,XMATT,YMATT,X3D,Y3D,Z3D,E3D,DOWN, 390 . - PLSTR1,PLSTR2, 391 . - XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX,VMIN,VMAX, 392 . - COPLAX,COPLAY,COMATX,COMATY,COTUBE,VTTUBE, 393 . - CORVTA,CORVTB,CORVTC,V0,SX,SY,SZ,P1,P2,C1,KAPPA, 394 . - INDSW,NWIRE,NSW,ICTYPE,MODE,NXMATT,NYMATT,NTUBE,MTUBE, 395 . - N3D,NTERMB,NTERMP,IENBGF, 396 . - INDPLA,NPSTR1,NPSTR2,INDST1,INDST2, 397 . - YNPLAN,YNPLAX,YNPLAY,YNMATX,YNMATY,PERX,PERY,PERZ, 398 . - POLAR,TUBE,PERMX,PERMY,PERMZ,PERAX,PERAY,PERAZ,CNALSO, 399 . - PERRX,PERRY,PERRZ,LBGFMP,CELSET 400 . COMMON /CELCHR/ CELLID,WIRTYP,PLATYP,TYPE,PSLAB1,PSLAB2 0 401 + +KEEP,XSOLIDS,IF=NEVER. 402 . *----------------------------------------------------------------------- 403 . * SOLIDS - Contains the solids present in the field map, with 404 . * reference information for making plots. 405 . * PARAMETER : CBUF : Volume descriptions 406 . * NSOLID : Number of solids 407 . * ISOLTP : Types of solids 408 . * ISOLMT : Material of the solid 409 . * ICCURR : Location in CBUF to add new elements 410 . * IQ, NQ : Lookup information for plot panels 411 . * (Last changed on 27/ 3/98.) 412 . *----------------------------------------------------------------------- 0 413 + +KEEP,SOLIDS. 414 . DOUBLE PRECISION CBUF(MXSBUF) 415 . CHARACTER SOLTYP(MXSOLI) 416 . INTEGER NSOLID,ISTART(MXSOLI),ISOLTP(MXSOLI),INDSOL(MXSOLI), 417 . - ICCURR,IQ(MXPLAN),NQ,ISOLMT(MXSOLI) 418 . COMMON /SOLIDS/ CBUF,ISTART,INDSOL,ISOLTP,NSOLID,ICCURR, 419 . - IQ,NQ,ISOLMT 420 . COMMON /SOLCHR/ SOLTYP 0 421 + +KEEP,XFIELDMAP,IF=NEVER. 422 . *----------------------------------------------------------------------- 423 . * FLDMAP - Contains field maps produced by finite element programs 424 . * and interpolated in Garfield. 425 . * PARAMETER : (XYZ)MAP : Triangles (flag 1) 426 . * E(XYZ)MAP : Electric field (flags 2, 3, 4) 427 . * VMAP : Potential (flag 5) 428 . * B(XYZ)MAP : Magnetic field (flags 6, 7, 8) 429 . * MATMAP : Material index (flag 9) 430 . * EW(XYZ)MAP : Weighting field (flags 11+, 12+, 13+) 431 . * MAPFLG : Availability of the above, 10 = D 432 . * ..MIN/MAX : Coordinate range seen in grid 433 . * NMAP : Number of elements. 434 . * EPSMAT : Dielectric constants 435 . * EPSSUR : Surface/volume covered by the medium 436 . * NEPS : Number of dielectric constants. 437 . * MAPTYP : Element type: 438 . * 0 = not yet known 439 . * 1 = triangle 1st order 440 . * 2 = triangle 2nd order 441 . * 3 = triangle 3rd order 442 . * 4 = parallelogram 1st order 443 . * 5 = parallelogram 2nd order 444 . * 6 = parallelogram 3rd order 445 . * 7 = tetragon 1st order 446 . * 8 = tetragon 2nd order 447 . * 9 = tetragon 3rd order 448 . * 11 = tetrahedron 1st order 449 . * 12 = tetrahedron 2nd order 450 . * 13 = tetrahedron 3rd order 451 . * 14 = parallelepiped 1st order 452 . * 15 = parallelepiped 2nd order 453 . * 16 = parallelepiped 3rd order 454 . * 17 = arbitrary hexahedron 1st order 455 . * 18 = arbitrary hexahedron 2nd order 456 . * 19 = arbitrary hexahedron 3rd order 457 . * MAPORD : Field map interpolation order. 1 27 P=COMMONS D= 6 PAGE 7 458 . * IDRMAT : Drift medium, index into EPSMAT. 459 . * NWMAP : Current number of weighting maps. 460 . * INDEWS : Conductor group number for the field map. 461 . * MATSRC : Origin of the material properties. 462 . * (Last changed on 29/11/99.) 463 . *----------------------------------------------------------------------- 0 464 + +KEEP,FIELDMAP. 465 . REAL EXMAP,EYMAP,EZMAP,EWXMAP,EWYMAP,EWZMAP,BXMAP,BYMAP,BZMAP, 466 . - VMAP,XMAP,YMAP,ZMAP,XMMIN,XMMAX,YMMIN,YMMAX,ZMMIN,ZMMAX, 467 . - XAMIN,XAMAX,YAMIN,YAMAX,ZAMIN,ZAMAX, 468 . - VMMIN,VMMAX,EPSMAT,EPSSUR 469 . INTEGER MATMAP,NMAP,NEPS,MAPORD,MAPTYP,IDRMAT,INDEWS(MXWMAP), 470 . - NWMAP 471 . LOGICAL MAPFLG,LMAPPL,SETAX,SETAY,SETAZ 472 . CHARACTER EWSTYP(MXWMAP) 473 . CHARACTER*10 MATSRC 474 . COMMON /FLDMAP/ VMAP(MXMAP,10), 475 . - EXMAP(MXMAP,10),EYMAP(MXMAP,10),EZMAP(MXMAP,10), 476 . - EWXMAP(MXMAP,10,MXWMAP),EWYMAP(MXMAP,10,MXWMAP), 477 . - EWZMAP(MXMAP,10,MXWMAP), 478 . - BXMAP(MXMAP,10),BYMAP(MXMAP,10),BZMAP(MXMAP,10), 479 . - XMAP(MXMAP,4),YMAP(MXMAP,4),ZMAP(MXMAP,4), 480 . - XMMIN,XMMAX,YMMIN,YMMAX,ZMMIN,ZMMAX, 481 . - XAMIN,XAMAX,YAMIN,YAMAX,ZAMIN,ZAMAX,VMMIN,VMMAX, 482 . - EPSMAT(MXEPS),EPSSUR(MXEPS),MATMAP(MXMAP), 483 . - MAPFLG(10+3*MXWMAP), 484 . - NMAP,NEPS,MAPORD,MAPTYP,IDRMAT,INDEWS,NWMAP, 485 . - LMAPPL,SETAX,SETAY,SETAZ 486 . COMMON /FLDCHR/ EWSTYP,MATSRC 0 487 + +KEEP,XGASDATA,IF=NEVER. 488 . *----------------------------------------------------------------------- 489 . * GASDAT - Common block containing information on the drift speed 490 . * GASCHR in the gas.. 491 . * VARIABLES : EGAS : E/p values [V/cm.torr]. 492 . * VGAS : Drift velocity || E [cm/microsec]. 493 . * XGAS : Drift velocity || ExB [cm/microsec]. 494 . * YGAS : Drift velocity || Btrans [cm/microsec]. 495 . * DGAS : Diffusion corresponding to E/P [cm2/sec]. 496 . * AGAS : Townsend coefficient, 497 . * BGAS : attachment coefficient, 498 . * MGAS : ion mobility 499 . * WGAS : Lorentz angle 500 . * CVGAS : Spline coefficients belonging to VGAS. 501 . * CXGAS : Spline coefficients belonging to XGAS. 502 . * CYGAS : Spline coefficients belonging to YGAS. 503 . * CDGAS : Spline coefficients belonging to DGAS. 504 . * CAGAS : Spline coefficients belonging to AGAS. 505 . * CBGAS : Spline coefficients belonging to BGAS. 506 . * CMGAS : Spline coefficients belonging to MGAS. 507 . * CWGAS : Spline coefficients belonging to WGAS. 508 . * NGAS : Number of points in EGAS, VGAS etc. 509 . * PGAS : Pressure of the gas [torr]. 510 . * TGAS : Temperature of the gas [K]. 511 . * Z : 'Nuclear' charge of the gas. 512 . * A : 'Atomic' number of the gas. 513 . * RHO : Specific weight of the gas. 514 . * CMEAN : Average number of clusters per cm. 515 . * EMPROB : Most probable energy loss / cm in the gas. 516 . * EPAIR : Energy needed to form one ion pair in the 517 . * cluster. 518 . * GASOK(I) : .TRUE. if present 519 . * (1) electron drift velocity || E 520 . * (2) ion mobility, 521 . * (3) longitudinal diffusion || E 522 . * (4) Townsend coefficient, 523 . * (5) cluster size distribution. 524 . * (6) attachment coefficient, 525 . * (7) Lorentz angle, 526 . * (8) transverse diffusion || Bt 527 . * (9) electron drift velocity || Bt 528 . * (10) electron drift velocity || ExB 529 . * (11) transverse diffusion || ExB 530 . * (12) diffusion correlation(E,Bt) 531 . * (13) diffusion correlation(E,ExB) 532 . * (14) diffusion correlation(Bt,ExB) 533 . * CLSTYP : Cluster size distribution origin. 534 . * function, 2 from a table, 3 from A, Z etc. 535 . * VEXTR1...4 : Used for drift velocity extrapolation. 536 . * XEXTR1...4 : Used for drift velocity extrapolation. 537 . * YEXTR1...4 : Used for drift velocity extrapolation. 538 . * DEXTR1...4 : Used for diffusion extrapolation. 539 . * AEXTR1...4 : Used for Townsend extrapolation. 540 . * BEXTR1...4 : Used for attachment coeff. extrapolation. 541 . * MEXTR1...4 : Used for mobility coeff. extrapolation. 542 . * WEXTR1...4 : Used for Lorentz angle extrapolation. 543 . * OEXTR1...4 : Used for transv. diff. extrapolation. 544 . * I/JVEXTR : Extrapolate V 0: const, 1: linear, 2:exp. 545 . * I/JXEXTR : Extrapolate V 0: const, 1: linear, 2:exp. 546 . * I/JYEXTR : Extrapolate V 0: const, 1: linear, 2:exp. 547 . * I/JDEXTR : Ex. diffusion 0: const, 1: linear, 2:exp. 548 . * I/JAEXTR : Ex. Townsend 0: const, 1: linear, 2:exp. 549 . * I/JBEXTR : Ex. attachm. 0: const, 1: linear, 2:exp. 550 . * I/JMEXTR : Ex. mobility 0: const, 1: linear, 2:exp. 551 . * I/JWEXTR : Lorentz angle 0: const, 1: linear, 2:exp. 552 . * I/JOEXTR : Transv. diff. 0: const, 1: linear, 2:exp. 553 . * I(V/D/A/B/M/W/O)METH : Interpolation method: 0 = spline, 554 . * higher: DIVDIF with order I(V/D/A/B/M)METH 555 . * HEEDOK : Tells whether HEED has been run. 556 . * GASDEN : Density of the gas in g/l for HEED. 557 . * (Last changed on 12/ 2/00.) 558 . *----------------------------------------------------------------------- 1 27 P=COMMONS D= 7 PAGE 8 559 + +KEEP,GASDATA. 560 . DOUBLE PRECISION CLSDIS,CLSAVE 561 . REAL EGAS,VGAS,XGAS,YGAS,DGAS,AGAS,BGAS,MGAS,WGAS,OGAS, 562 . - CVGAS,CXGAS,CYGAS,CDGAS,CAGAS,CBGAS,CMGAS,CWGAS,COGAS, 563 . - VGAS2,XGAS2,YGAS2,DGAS2,AGAS2,BGAS2,MGAS2,WGAS2,OGAS2, 564 . - BANG,BTAB, 565 . - VEXTR1,VEXTR2,VEXTR3,VEXTR4, 566 . - XEXTR1,XEXTR2,XEXTR3,XEXTR4, 567 . - YEXTR1,YEXTR2,YEXTR3,YEXTR4, 568 . - DEXTR1,DEXTR2,DEXTR3,DEXTR4, 569 . - AEXTR1,AEXTR2,AEXTR3,AEXTR4, 570 . - BEXTR1,BEXTR2,BEXTR3,BEXTR4, 571 . - MEXTR1,MEXTR2,MEXTR3,MEXTR4, 572 . - WEXTR1,WEXTR2,WEXTR3,WEXTR4, 573 . - OEXTR1,OEXTR2,OEXTR3,OEXTR4, 574 . - GASRNG, 575 . - Z,A,RHO,CMEAN,EMPROB,EPAIR,PGAS,TGAS,GASDEN, 576 . - DTION,DLION 577 . LOGICAL GASOK,TAB2D,GASOPT,HEEDOK,GASSET 578 . INTEGER NGAS,NCLS,NBANG,NBTAB,NFTAB,NFCLS, 579 . - IVMETH,IXMETH,IYMETH,IDMETH,IAMETH,IBMETH,IMMETH, 580 . - IWMETH,IOMETH, 581 . - IVEXTR,IXEXTR,IYEXTR,IDEXTR,IAEXTR,IBEXTR,IMEXTR, 582 . - IWEXTR,IOEXTR, 583 . - JVEXTR,JXEXTR,JYEXTR,JDEXTR,JAEXTR,JBEXTR,JMEXTR, 584 . - JWEXTR,JOEXTR, 585 . - IATHR,IBTHR 586 . CHARACTER*80 GASID 587 . CHARACTER*(MXCHAR) FCNTAB,FCNCLS 588 . CHARACTER*10 CLSTYP 589 . COMMON /GASDAT/ CLSDIS(MXPAIR),CLSAVE, 590 . - EGAS(MXLIST), 591 . - VGAS(MXLIST),XGAS(MXLIST),YGAS(MXLIST),WGAS(MXLIST), 592 . - DGAS(MXLIST),OGAS(MXLIST),AGAS(MXLIST),BGAS(MXLIST), 593 . - MGAS(MXLIST), 594 . - CVGAS(MXLIST),CXGAS(MXLIST),CYGAS(MXLIST),CWGAS(MXLIST), 595 . - CDGAS(MXLIST),COGAS(MXLIST),CAGAS(MXLIST),CBGAS(MXLIST), 596 . - CMGAS(MXLIST), 597 . - VGAS2(MXLIST,MXBANG,MXBTAB),WGAS2(MXLIST,MXBANG,MXBTAB), 598 . - XGAS2(MXLIST,MXBANG,MXBTAB),YGAS2(MXLIST,MXBANG,MXBTAB), 599 . - AGAS2(MXLIST,MXBANG,MXBTAB),BGAS2(MXLIST,MXBANG,MXBTAB), 600 . - DGAS2(MXLIST,MXBANG,MXBTAB),OGAS2(MXLIST,MXBANG,MXBTAB), 601 . - MGAS2(MXLIST,MXBANG,MXBTAB), 602 . - BANG(MXBANG),BTAB(MXBTAB), 603 . - GASRNG(8,2), 604 . - Z,A,RHO,CMEAN,EMPROB,EPAIR,PGAS,TGAS,GASDEN, 605 . - DTION,DLION, 606 . - VEXTR1,VEXTR2,VEXTR3,VEXTR4, 607 . - XEXTR1,XEXTR2,XEXTR3,XEXTR4, 608 . - YEXTR1,YEXTR2,YEXTR3,YEXTR4, 609 . - DEXTR1,DEXTR2,DEXTR3,DEXTR4, 610 . - AEXTR1,AEXTR2,AEXTR3,AEXTR4, 611 . - BEXTR1,BEXTR2,BEXTR3,BEXTR4, 612 . - MEXTR1,MEXTR2,MEXTR3,MEXTR4, 613 . - WEXTR1,WEXTR2,WEXTR3,WEXTR4, 614 . - OEXTR1,OEXTR2,OEXTR3,OEXTR4, 615 . - IVMETH,IXMETH,IYMETH,IDMETH,IAMETH,IBMETH,IMMETH, 616 . - IWMETH,IOMETH, 617 . - IVEXTR,IXEXTR,IYEXTR,IDEXTR,IAEXTR,IBEXTR,IMEXTR, 618 . - IWEXTR,IOEXTR, 619 . - JVEXTR,JXEXTR,JYEXTR,JDEXTR,JAEXTR,JBEXTR,JMEXTR, 620 . - JWEXTR,JOEXTR, 621 . - NGAS,NCLS,NBANG,NBTAB,NFTAB,NFCLS, 622 . - IATHR,IBTHR, 623 . - GASOK(14),GASOPT(14,4), 624 . - TAB2D,HEEDOK,GASSET 625 . COMMON /GASCHR/ FCNTAB,FCNCLS,CLSTYP,GASID 0 626 + +KEEP,GASMIXDATA. 627 . *----------------------------------------------------------------------- 628 . * GMXDAT - Common block for gas mixing. 629 . * (Last changed on 20/ 2/97.) 630 . *----------------------------------------------------------------------- 631 . REAL BREAK,FRAC,XLOSCH,EFLD,ESTEP,ECRIT 632 . INTEGER NBREAK 633 . COMMON /GMXDAT/ BREAK(MXLIST),FRAC(MXFRAC),XLOSCH, 634 . - EFLD,ESTEP,ECRIT,NBREAK 0 635 + +KEEP,XCAPACMATRIX,IF=NEVER. 636 . *----------------------------------------------------------------------- 637 . * MATRIX - Common block storing various large double precision arrays 638 . * such as the capacitance matrices, a drift time tabel etc. 639 . * VARIABLES : A : The elements I=1,NWIRE J=1,NWIRE form the 640 . * capacitance matrix, the row and colom at 641 . * NWIRE+1 are used to make sure the total 642 . * charge is zero, the last colom is working 643 . * space for routine DEQINV. (Valid for the 644 . * capacitance matrices only). 645 . *----------------------------------------------------------------------- 0 646 + +KEEP,CAPACMATRIX. 647 . DOUBLE PRECISION A 648 . COMMON /MATRIX/ A(MXWIRE+1,MXWIRE+3) 0 649 + +KEEP,XBFIELD,IF=NEVER. 650 . *----------------------------------------------------------------------- 651 . * MAGDAT - Common block storing the information on the magnetic field. 652 . * VARIABLES : SUSWIR : Magn. permeability of wire material. 653 . * SUSGAS : " " " gas. 654 . * ALFA : (SUSWIR-SUSGAS)/(SUSWIR+SUSGAS). 655 . * B0X,B0Y,B0Z: Magnetic field components. 656 . * MAGOK : Indicates that a magnetic field is present. 657 . * MAGSRC : 0 = no field, 1 = above, 2 = field map 658 . * IB[XYZ]TYP : 0 = not set, 1 = fixed value, 2 = formula, 659 . * 3 = matrix interpolation. 660 . * (Last changed on 29/ 2/00.) 1 27 P=COMMONS D= 8 PAGE 9 661 . *----------------------------------------------------------------------- 0 662 + +KEEP,BFIELD. 663 . LOGICAL MAGOK 664 . REAL ALFA,B0X,B0Y,B0Z,SUSWIR,SUSGAS,BSCALE,BFMIN,BFMAX, 665 . - BFXMIN,BFYMIN,BFZMIN,BFXMAX,BFYMAX,BFZMAX 666 . INTEGER MAGSRC, 667 . - IBXTYP,IBYTYP,IBZTYP, 668 . - IRB0X,IRB0Y,IRB0Z,IRV0X,IRV0Y,IRV0Z, 669 . - IENB0X,IENB0Y,IENB0Z,IBXDIR,IBYDIR,IBZDIR, 670 . - NCB0X,NCB0Y,NCB0Z 671 . CHARACTER*(MXCHAR) FUNB0X,FUNB0Y,FUNB0Z 672 . COMMON /MAGDAT/ ALFA,SUSWIR,SUSGAS, 673 . - B0X,B0Y,B0Z,BSCALE,BFMIN,BFMAX, 674 . - BFXMIN,BFYMIN,BFZMIN,BFXMAX,BFYMAX,BFZMAX, 675 . - MAGSRC,IBXTYP,IBYTYP,IBZTYP, 676 . - IRB0X,IRB0Y,IRB0Z,IRV0X,IRV0Y,IRV0Z, 677 . - IENB0X,IENB0Y,IENB0Z,IBXDIR,IBYDIR,IBZDIR, 678 . - NCB0X,NCB0Y,NCB0Z, 679 . - MAGOK 680 . COMMON /MAGCHR/ FUNB0X,FUNB0Y,FUNB0Z 0 681 + +KEEP,XDRIFTLINE,IF=NEVER. 682 . *----------------------------------------------------------------------- 683 . * DRFDAT - Common block giving full information on one drift line 684 . * this common block is used for the communication between the 685 . * routine calculating drift lines (DLCALC) and others needing 686 . * this information (such as : DRFWIR, DRFEDG, DRFTRA etc). 687 . * VARIABLES : XU : x-coordinates of the drift line 688 . * YU : y-coordinates of the drift line 689 . * TU : t-coordinates of the drift line 690 . * NU : number of points on the drift line 691 . * ISTAT : way the particle ends its life: 692 . * ISTAT= 0 calculation still in progress 693 . * -1 left the drift area 694 . * -2 needed more than MXLIST steps 695 . * -3 stopped, returned, abandonned etc. 696 . * -4 hit a plane 697 . * n ( 0MXWIRE ) hit replica wire n 699 . * ISTAT1-6 : ISTAT's for leaving via various edges 700 . * IPTYPE : Particle type 0=unknown, 1=electron, 2=ion 701 . * IPTECH : Technique 0=unknown, 1=RKF, 2=MC, 3=vacuum 702 . * QPCHAR : Particle charge 703 . * DXMIN,DXMAX: x-range of drift area, 704 . * DYMIN,DYMAX: y-range of drift area. 705 . * MXDIFS, MXTWNS, MXATTS: Maximum stack depths. 706 . * LREPSK : Check only attracting wires. 707 . * RDF2 : Distance to switch L+T diff integration 708 . * MDF2 : L+T integration method when reaching wire 709 . * MDF2 = 0 no special treatment 710 . * = 1 full integration of the cloud 711 . * = 2 integration with constant velocity 712 . * = 3 project longitudinal dimension 713 . * = 4 project largest dimension 714 . * TMC : MC drift line step time. 715 . * DMC : MC drift line step distance. 716 . * NMC : Number of collisions to be skipped. 717 . * MCMETH : MC integration method, 718 . * = 0 constant time steps 719 . * = 1 constant distance steps 720 . * = 2 collision time based steps 721 . * EPSDIF : Maximum error made while solving diff. eq. 722 . * RTRAP : A particle found within RTRAP wire radii 723 . * is considered to be trapped. 724 . * STMAX : Maximum step length. 725 . * EPSDFI : Accuracy diffusion integration. 726 . * MXDIFS : Maximum stack depth diffusion integration. 727 . * EPSTWI : Accuracy Townsend integration. 728 . * MXTWNS : Maximum stack depth Townsend integration. 729 . * LAVPRO : Avalanche over projected drift path. 730 . * EPSATI : Accuracy attachment integration. 731 . * MXATTS : Maximum stack depth attachment integration. 732 . * EQTTHR : Maximum relative distance between equal 733 . * time contour points to be joined. 734 . * EQTASP : Aspect ratio threshold to classify an 735 . * isochrone as circle or straight line 736 . * EQTCLS : Maximum relative distance for an isochrone 737 . * to be closed 738 . * LEQSRT : Sort isochrones 739 . * LEQCRS : Check for drift line - isochrone crossings 740 . * LEQMRK : Mark rather than draw isochrones 741 . * (Last changed on 7/11/00.) 742 . *----------------------------------------------------------------------- 0 743 + +KEEP,DRIFTLINE. 744 . DOUBLE PRECISION XU,YU,ZU,TU,XTARG,YTARG,TMC,DMC 745 . REAL DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX,DTARG,EPSDFI,EPSTWI, 746 . - EPSATI,RDF2, 747 . - DDXMIN,DDXMAX,DDYMIN,DDYMAX,DDZMIN,DDZMAX,EPSDIF,RTRAP, 748 . - STMAX,EQTTHR,EQTASP,EQTCLS,QPCHAR 749 . INTEGER NU,ISTAT,ITARG,MXDIFS,MXTWNS,MXATTS,MDF2, 750 . - ISTAT1,ISTAT2,ISTAT3,ISTAT4,ISTAT5,ISTAT6,NMC,MCMETH, 751 . - IPTYPE,IPTECH 752 . LOGICAL LREPSK,LKINK,LSTMAX,LEQSRT,LEQCRS,LEQMRK,LAVPRO 753 . COMMON /DRFDAT/ XU(MXLIST),YU(MXLIST),ZU(MXLIST),TU(MXLIST), 754 . - XTARG,YTARG,TMC,DMC,DTARG, 755 . - DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX, 756 . - DDXMIN,DDXMAX,DDYMIN,DDYMAX,DDZMIN,DDZMAX, 757 . - EQTTHR,EQTASP,EQTCLS,QPCHAR, 758 . - RTRAP,STMAX,EPSDIF,EPSDFI,EPSTWI,EPSATI,RDF2,MDF2, 759 . - MXDIFS,MXTWNS,MXATTS, 760 . - NU,ISTAT,ITARG, 761 . - ISTAT1,ISTAT2,ISTAT3,ISTAT4,ISTAT5,ISTAT6,NMC,MCMETH,IPTYPE, 762 . - IPTECH,LREPSK,LKINK,LSTMAX,LEQSRT,LEQCRS,LEQMRK,LAVPRO 1 27 P=COMMONS D= 9 PAGE 10 763 + +KEEP,XSIGNALDATA,IF=NEVER. 764 . *----------------------------------------------------------------------- 765 . * SIGDAT - Common block containing details on the track of the charged 766 . * SIGCHR particle through the chamber as well as on the clusters it 767 . * produced. It stores the signal induced on the sense wires. 768 . * VARIABLES : TPAIR : Arrival time of an electron in a cluster. 769 . * QPAIR : Multiplication caused by an electron. 770 . * IPAIR(I) : First electron from cluster I 771 . * ICLUST(I) : ISTAT code for cluster I 772 . * TSTART : First time in signal simulation 773 . * TDEV : Time resolution in signal simulation 774 . * NTIME : Number of signal time points 775 . * NORIA : Number of ion angles 776 . * AVALAN : Multiplication factor for avalanches and 777 . * its relative standard deviation 778 . * AVATYP : Avalanche model. 779 . * SIGNAL(I,J,K):Signal at TSTART+I*TDEV on sense wire J 780 . * (direct if K=1, indirect if K=2) 781 . * FPERX : yes/no x-convolution for ion tails 782 . * FPERY : yes/no y-convolution for ion tails 783 . * FCELTP : type of the cell stripped of periodicity 784 . * MFEXP,NFOUR: 2**MFEXP = NFOUR (# Fourier terms) 785 . * MXMIN,MXMAX: Lowest, highest Fourier term in x 786 . * MYMIN,MYMAX: Lowest, highest Fourier term in y 787 . * LCROSS : .TRUE. if cross induced signals are present 788 . * LITAIL : Simple ion tail (angular sampling) 789 . * LRTAIL : Simple ion tail (no angular sampling) 790 . * LDTAIL : Detailed ion tail 791 . * LEPULS : Electron pulse 792 . * SIGSET : Ready for signal calculations. 793 . * RESSET : Time resolution has been set. 794 . * (Last changed on 16/ 1/00.) 795 . *----------------------------------------------------------------------- 0 796 + +KEEP,SIGNALDATA. 797 . LOGICAL FPERX,FPERY,LCROSS,TRASET,TRAFLG,LITAIL,LDTAIL,LRTAIL, 798 . - LEPULS,SIGSET,RESSET 799 . INTEGER NPAIR,ICLUST,NFOUR,MFEXP,MXMIN,MXMAX, 800 . - MYMIN,MYMAX,NTRBNK,ITRMAJ,NTIME,NORIA, 801 . - NASIMP,NISIMP,NCANG,JIORD,IENANG 802 . REAL TIMSIG,SIGNAL,TCLUST,SCLUST,ACLUST,BCLUST,FCLUST, 803 . - AVALAN,TSTART,TDEV,PRSTHR, 804 . - TRABNK,TRAVEC 805 . CHARACTER*(MXCHAR) FCNANG 806 . CHARACTER*12 AVATYP 807 . CHARACTER*3 FCELTP 808 . COMMON /SIGDAT/ TIMSIG(MXLIST),SIGNAL(MXLIST,MXSW,2), 809 . - AVALAN(2),TRAVEC(MXLIST), 810 . - TRABNK(MXLIST,9),TSTART,TDEV,PRSTHR, 811 . - TCLUST,SCLUST,ACLUST,BCLUST,FCLUST,ICLUST,NPAIR, 812 . - NFOUR,ITRMAJ,JIORD,IENANG,NTIME,NORIA, 813 . - MFEXP,MXMIN,MXMAX,MYMIN,MYMAX,NTRBNK,NASIMP,NISIMP,NCANG, 814 . - TRASET,TRAFLG(9),FPERX,FPERY,LCROSS,LITAIL,LDTAIL,LRTAIL, 815 . - LEPULS,SIGSET,RESSET 816 . COMMON /SIGCHR/ FCELTP,AVATYP,FCNANG 0 817 + +KEEP,XSIGNALMATRIX,IF=NEVER. 818 . *----------------------------------------------------------------------- 819 . * MATRIX - Signal matrix + working arrays (stored on the same place as 820 . * the capacitance matrix - similar structure). 821 . * VARIABLES : SIGMAT : A layer of wire signal matrices. 822 . * QPLANE : A layer of plane signal matrices. 823 . * WORK : Working space for matrix inversions. 824 . * DUMMY : Fills the common block. 825 . * (Last changed on 13/ 4/99.) 826 . *----------------------------------------------------------------------- 0 827 + +KEEP,SIGNALMATRIX. 828 . COMPLEX SIGMAT 829 . REAL QPLANE,EWXCOR,EWYCOR 830 . INTEGER IWORK,DUMMY 831 . COMMON /MATRIX/ SIGMAT(MXWIRE,MXWIRE),QPLANE(5,MXWIRE), 832 . - IWORK(MXWIRE),DUMMY(2*MXWIRE+6) 833 . COMMON /SPLDAT/ EWXCOR(5),EWYCOR(5) 0 834 + +KEEP,XSHAPEDATA,IF=NEVER. 835 . *----------------------------------------------------------------------- 836 . * SHPDAT - Common blocks used by the wire sag routines. 837 . * VARIABLES : FX, FY : Force as function of wire displacement 838 . * XSCAN, YSCAN: Wire displacements (abscissa of FX, FY) 839 . * NSCANX/Y : Number of points in FX, FY, XSCAN, YSCAN 840 . * JSORD : Force table interpolation order 841 . * NITMAX : Maximum # of zero search iterations 842 . * EPS : Used for building differential matrices 843 . * EPSX : Positional convergence criterion 844 . * EPSF : Function value convergence criterion 845 . * STEP : Step size used by DRKNYS 846 . * NSHOT : Number of shots 847 . * NSTEP : Number of steps per shot 848 . * IW : Wire currently studied 849 . * LFWARN : Point found outside scanning grid 850 . * LFEXTR : Permission to extrapolate force table 851 . * LFELEC : Include or not electrostatics 852 . * LFGRAV : Include or not gravity 853 . * LZROPR : Print zero search progress 854 . * LFITER : Iterate over all wires 855 . * NFITER : Maximum number of all wire iterations 856 . * (XORIG,YORIG) Nominal wire positions 857 . * (XOFF,YOFF) : Wire position offsets 858 . * (XWIRE,YWIRE) Nominal position of the current wire 859 . * (Last changed on 3/ 7/96.) 860 . *----------------------------------------------------------------------- 1 27 P=COMMONS D= 10 PAGE 11 861 + +KEEP,SHAPEDATA. 862 . DOUBLE PRECISION FX(MXGRID,MXGRID),FY(MXGRID,MXGRID), 863 . - XSCAN(MXGRID),YSCAN(MXGRID),EPS,EPSX,EPSF,STEP 864 . REAL XORIG(MXWIRE),YORIG(MXWIRE),XOFF(MXWIRE),YOFF(MXWIRE) 865 . INTEGER NITMAX,NSHOT,NSTEP,IW,NSCANX,NSCANY,JSORD,NFITER 866 . LOGICAL LFGRAV,LFELEC,LFEXTR,LFWARN,LZROPR,LFITER 867 . COMMON /SHPDAT/ FX,FY,XSCAN,YSCAN,EPS,EPSX,EPSF,STEP, 868 . - XORIG,YORIG,XOFF,YOFF, 869 . - NITMAX,NSHOT,NSTEP,IW,NSCANX,NSCANY,JSORD,NFITER, 870 . - LFGRAV,LFELEC,LFEXTR,LFWARN,LZROPR,LFITER 0 871 + +KEEP,XINPUT,IF=NEVER. 872 . *----------------------------------------------------------------------- 873 . * INPCOM - Common blocks used by the input routines to store the input 874 . * INPCHR line and some related information. 875 . * VARIABLES : NCHAR(I) : Number of characters in word I. 876 . * INDWRD(I) : Index in string of word I. 877 . * ERRCDE(I) : Error code for word I. 878 . * NWORD : Number of words not > MXWORD. 879 . * STRING : The input line. 880 . * PROMPT : Prompt string (printed if LPROM is .TRUE.) 881 . * LUN : Logical unit from which input is read. 882 . * ICHSET : 0: character set ?, 1: ASCII, 2: EBCDIC 883 . * LINREC : Input recording on/off. 884 . * ARGSTR : String with input file arguments. 885 . * EOFSTR : EOF marker string. 886 . * LUNSTR : Input reference, 1=file, 2=EOF, 3=args 887 . * (Last changed on 7/11/00.) 888 . *----------------------------------------------------------------------- 0 889 + +KEEP,INPUT. 890 . CHARACTER*(MXINCH+1) STRING 891 . CHARACTER*(MXINCH) ARGSTR 892 . CHARACTER*30 ERRCDE(MXWORD) 893 . CHARACTER*(MXCHAR) WORD(MXWORD) 894 . CHARACTER*80 PROMPT,EOFSTR,SHELL 895 . CHARACTER ESCAPE 896 . INTEGER NCHAR(MXWORD),INDWRD(MXWORD),ICHSET,LUNSTR(5:MXLUN,3), 897 . - NWORD,LUN,NCPROM,NCEOF,NCSH,NCARG 898 . LOGICAL ERRPRT(MXWORD),LPROM,DOEXEC,DOREAD,LINREC 899 . COMMON /INPCOM/ NCHAR,INDWRD,LUNSTR,NWORD,LUN,ICHSET,NCPROM, 900 . - ERRPRT,LPROM,DOEXEC,DOREAD,NCEOF,LINREC,NCSH,NCARG 901 . COMMON /INPCHR/ ERRCDE,STRING,WORD,PROMPT,EOFSTR,ESCAPE,SHELL, 902 . - ARGSTR 0 903 + +KEEP,XALGDATA,IF=NEVER. 904 . *----------------------------------------------------------------------- 905 . * ALGDAT - Common block containing the executable statements for the 906 . * evaluation of symbolic expressions. 907 . * VARIABLES : INS(I, . ) : List of instructions, the first element is 908 . * a register address (in case of a normal 909 . * operation) or a function descriptor, the 910 . * second is the operator, the third an addres 911 . * and the fourth the address of the result. 912 . * NINS : Number of instructions in INS. 913 . * REG(I) : Contents of register I, REG(0)=0, REG(-1)=1 914 . * and REG(-2)=2, REG(-3)=pi. 915 . * NREG : Number of registers in use. 916 . * EXEC(I) : .TRUE. if instruction I is to be executed. 917 . * NERR : Number of errors since last call to ALGPRE. 918 . * NAERR : Individual error counts. 919 . * NRES : Number of independent results. 920 . * ALGENT(I,.): Instruction list entry refernce table. 921 . * 1: reference no, 2: in use 0/1, 3: can be 922 . * executed 0/1, 4: sequential 0/1, 5: first 923 . * instruction, 6: no of instructions, 7: no 924 . * of variables, 8: first constant, 9: no of 925 . * constants, 10: no of results. 926 . * ARGREF(I,1): Modification flag for arguments, 927 . * 0: modifiable global variable, 928 . * 1: modifiable non-global variable, 929 . * 2: non-modifiable global variable, 930 . * 3: non-modifiable non-global variable. 931 . * ARGREF(I,2): Origin of each argument. 932 . * NALGE : Number of entries in use in ALGENT. 933 . * ISYNCH : 0: no check, 1: algebra, 2: procedure 934 . * LIGUND : Ignore exponential underflow 935 . * (Last changed on 3/ 6/97.) 936 . *----------------------------------------------------------------------- 0 937 + +KEEP,ALGDATA. 938 . INTEGER INS(MXINS,4),ALGENT(MXALGE,10),MODREG(MXCONS:MXREG), 939 . - ISYNCH,IINS0,ICONS0,ARGREF(MXARG,2),MODARG(MXARG), 940 . - NREG,NCONS,NINS,NERR,NRES,NALGE,IENTRL,NAERR(100) 941 . REAL REG(MXCONS:MXREG),ARG(MXARG) 942 . LOGICAL EXEC(MXINS),LIGUND 943 . COMMON /ALGDAT/ REG,ARG,MODARG,ARGREF,INS,MODREG,ALGENT, 944 . - NREG,NCONS,NINS,NERR,NAERR, 945 . - NRES,NALGE,IENTRL,ISYNCH,IINS0,ICONS0,EXEC,LIGUND 0 946 + +KEEP,XZERODATA,IF=NEVER. 947 . *----------------------------------------------------------------------- 948 . * ZRODAT - Common block containing the information about the zeros. 949 . * VARIABLES : XZ(I),YZ(I) : Location of the zeros 950 . * PZ(I) : Orientation angle (in radians) of zero I 951 . * NZ : Number of zeros 952 . * NFC : Number of function calls needed. 953 . * DAMIN, DAMAX: 954 . * DPMIN, DPMAX: 955 . * (Last changed on 8/ 9/98.) 956 . *----------------------------------------------------------------------- 1 27 P=COMMONS D= 11 PAGE 12 957 + +KEEP,ZERODATA. 958 . LOGICAL ZROSET 959 . REAL XZ,YZ,PZ,DPMIN,DPMAX,DAMIN,DAMAX,EMIN 960 . INTEGER NZ,NFC 961 . COMMON /ZRODAT/ XZ(MXZERO),YZ(MXZERO),PZ(MXZERO),NZ,NFC, 962 . - DPMIN,DPMAX,DAMIN,DAMAX,EMIN,ZROSET 0 963 + +KEEP,XOPTDATA,IF=NEVER. 964 . *----------------------------------------------------------------------- 965 . * OPTDAT - Common blocks storing some optimisation data, mainly 966 . * OPTCHR shared in view of the minimisation itself. 967 . * (Last changed on 20/10/99.) 968 . *----------------------------------------------------------------------- 0 969 + +KEEP,OPTDATA. 970 . CHARACTER*(MXCHAR) FUNFLD,FUNPOS,FUNWGT 971 . CHARACTER*10 VALTYP,PNTTYP 972 . REAL VST(MXWIRE),VPLST(5) 973 . LOGICAL EVALT,EVALD,EVALA 974 . INTEGER NPOINT,NSWIRE,IOPT,NFLD,NPOS,NWGT,IENFLD,IENPOS,IENWGT 975 . COMMON /OPTDAT/ VST,VPLST,NPOINT,NSWIRE,IOPT,NFLD,NPOS,NWGT, 976 . - IENFLD,IENPOS,IENWGT,EVALT,EVALD,EVALA 977 . COMMON /OPTCHR/ FUNFLD,FUNPOS,FUNWGT,VALTYP,PNTTYP 0 978 + +KEEP,XTHRESHDATA,IF=NEVER. 979 . *----------------------------------------------------------------------- 980 . * THRDAT - Common block storing some threshold data. 981 . * VARIABLES : NCSMAX : Maximum cluster size. 982 . * NCMIN, NCMAX: Minimum resp maximum number of clusters. 983 . * CMIK(I,K) : The probability that the M'th electron is 984 . * the I'th electron from cluster K. 985 . * YTHMIN, MAX : y-Range from where particles reach a wire. 986 . * XTHR : Starting point of the drift lines. 987 . * PRCLUS(N) : Probability of having N clusters in all. 988 . * PRSIZE(N) : Probability a cluster consists of N pairs. 989 . * TMIN,TMAX : Time range of the arrivals. 990 . *----------------------------------------------------------------------- 0 991 + +KEEP,THRESHDATA,IF=NEVER. 992 . REAL CMIK(MXPAIR,MXCLUS),PRCLUS(0:MXCLUS),PRSIZE(0:MXPAIR) 993 . COMMON /THRDAT/ CMIK,PRCLUS,PRSIZE,YTHMIN,YTHMAX,XTHR,TMIN,TMAX, 994 . - NCMIN,NCMAX,NCSMAX 0 995 + +KEEP,XASTCOM,IF=NEVER. 996 . *----------------------------------------------------------------------- 997 . * ASTCOM - Stores various quantities being used for control_C 998 . * interception on a Vax. (For information, contact 999 . * Carlo Mekenkamp, MEKENKAM@HLERUL5.) 1000 . *----------------------------------------------------------------------- 0 1001 + +KEEP,ASTCOM. 1002 . IMPLICIT NONE 1003 . COMMON /ASTCOM/ CHAN, ASTIP, ASTCS 1004 . VOLATILE CHAN, ASTIP, ASTCS 1005 . INTEGER*4 CHAN 1006 . LOGICAL*4 ASTIP,ASTCS 0 1007 + +KEEP,XGRAPHICS,IF=NEVER. 1008 . *----------------------------------------------------------------------- 1009 . * GRADAT - Common block storing some data relevant for graphics. 1010 . * VARIABLES : LGRID : Plot grid lines. 1011 . * LOGX : Plot x-axis on logarithmic scale. 1012 . * LOGY : Plot y-axis on logarithmic scale. 1013 . * STAMP : Stamp placed on plots when complete. 1014 . * LSTAMP : Put a time stamp on the plots. 1015 . * LWAITB : Wait before a plot is made. 1016 . * LWAITA : Wait after a plot has been made. 1017 . * LGCLRB : Clear graphics window before a plot. 1018 . * LGCLRA : Clear graphics window after a plot. 1019 . * LXCCH : Execute control characters. 1020 . * WKNAME : Name of the workstations. 1021 . * WKATTR : Attributes - not yet used. 1022 . * WKLUN : Logical unit associated with a workstation 1023 . * WKFREF : Pointer for file name used by STRBUF. 1024 . * WKCON : Connection identifier of a workstation. 1025 . * WKID : Workstation type of a workstation. 1026 . * WKSTAT : Workstation state: 0 - not known 1027 . * 1 - defined, 2 - open, 3 - active. 1028 . * USERXn/Yn : WC of the whole plot 1029 . * FRX/YMINMAX : WC of the box 1030 . * GPXN : Distance between x-axis and numbers 1031 . * GPXN10 : Distance between x-axis and powers of 10 1032 . * GPYN : Distance between y-axis and numbers 1033 . * GPYN10 : Distance between y-axis and powers of 10 1034 . * GPXL : Distance between x-frame and label 1035 . * GPYL : Distance between y-frame and label 1036 . * GPXT : Distance between x-frame and title 1037 . * DISPX0 : (Like .X1, .Y0 and .Y1) display area. 1038 . * (Last changed on 9/ 9/99.) 1039 . *----------------------------------------------------------------------- 0 1040 + +KEEP,GRAPHICS. 1041 . REAL USERX0,USERX1,USERY0,USERY1,FRXMIN,FRXMAX,FRYMIN,FRYMAX, 1042 . - ARRANG,ARRLEN,DISPX0,DISPX1,DISPY0,DISPY1, 1043 . - GPXN,GPXN10,GPYN,GPYN10,GPXL,GPYL,GPXT 1044 . LOGICAL LGRID,LOGX,LOGY,LSTAMP,LGCLRB,LGCLRA,LWAITA,LWAITB,LXCCH 1045 . INTEGER NWK,WKID(MXWKLS),WKCON(MXWKLS),WKFREF(MXWKLS), 1046 . - WKLUN(MXWKLS),WKSTAT(MXWKLS),NCWKNM(MXWKLS),NCSTMP 1047 . CHARACTER*20 WKNAME(MXWKLS),WKATTR(MXWKLS) 1048 . CHARACTER*80 STAMP 1049 . COMMON /GRADAT/ USERX0,USERX1,USERY0,USERY1,ARRANG,ARRLEN, 1050 . - FRXMIN,FRXMAX,FRYMIN,FRYMAX,DISPX0,DISPX1,DISPY0,DISPY1, 1051 . - GPXN,GPXN10,GPYN,GPYN10,GPXL,GPYL,GPXT, 1052 . - LGRID,LOGX,LOGY,LSTAMP,LGCLRB,LGCLRA,LWAITA,LWAITB,LXCCH, 1053 . - NWK,WKID,WKCON,WKFREF,WKLUN,WKSTAT,NCWKNM,NCSTMP 1054 . COMMON /GRACHR/ WKNAME,WKATTR,STAMP 1 27 P=COMMONS D= 12 PAGE 13 1055 + +KEEP,XCONTDATA,IF=NEVER. 1056 . *----------------------------------------------------------------------- 1057 . * CONDAT - Common block for the contour routines. 1058 . * Variables : XDONE, YDONE: Keeps track of grid crossings 1059 . * TRANS : Yes/no conformal mapping 1060 . * CLAB : Yes/no labeling of contours 1061 . * GRID : Array of contour heights on the grid 1062 . * EPSTRA : Epsilon for tracking a contour 1063 . * EPSGRA : Epsilon for computing gradients 1064 . * D(XY)GRA : Step size for computing gradients 1065 . * C(XY)M(INAX): Area for which the contours are made 1066 . * STINIT : 1067 . * DNTHR : Grid crossing tolerance 1068 . * NFC : Number of funtion calls used for contours 1069 . * (Last changed on 19/ 6/98.) 1070 . *----------------------------------------------------------------------- 0 1071 + +KEEP,CONTDATA. 1072 . LOGICAL XDONE(0:MXGRID,0:MXGRID),YDONE(0:MXGRID,0:MXGRID), 1073 . - TRANS,CLAB 1074 . REAL GRID(0:MXGRID,0:MXGRID),EPSTRA,EPSGRA,CXMIN,CXMAX,CYMIN, 1075 . - CYMAX,STINIT,DNTHR,DXGRA,DYGRA 1076 . INTEGER ILOCGR(0:MXGRID,0:MXGRID),NBITER,NNITER,NFC,NGCMAX 1077 . COMMON /CONDAT/ GRID,XDONE,YDONE,ILOCGR, 1078 . - NBITER,NNITER,EPSTRA,EPSGRA,DXGRA,DYGRA, 1079 . - STINIT,DNTHR,CXMIN,CXMAX,CYMIN,CYMAX,NFC,NGCMAX,TRANS,CLAB 0 1080 + +KEEP,XGLOBALS,IF=NEVER. 1081 . *----------------------------------------------------------------------- 1082 . * GLBDAT - Common blocks storing the names and values of the global 1083 . * GLBCHR variables. 1084 . * VARIABLES : GLBVAR : Names of the global variables. 1085 . * GLBVAL : Values of the global variables. 1086 . * GLBMOD : Type: 0 undefined, 1 string, 2 number, 1087 . * 3 logical, 4 histogram, 5 matrix. 1088 . * NGLB : Number of global variables. 1089 . *----------------------------------------------------------------------- 0 1090 + +KEEP,GLOBALS. 1091 . REAL GLBVAL(MXVAR) 1092 . INTEGER NGLB,GLBMOD(MXVAR) 1093 . CHARACTER*10 GLBVAR(MXVAR) 1094 . COMMON /GLBDAT/ GLBVAL,GLBMOD,NGLB 1095 . COMMON /GLBCHR/ GLBVAR 0 1096 + +KEEP,XDOLOOP,IF=NEVER. 1097 . *----------------------------------------------------------------------- 1098 . * DODAT - Common block storing the pointers for DO loop execution. 1099 . * (Last changed on 20/ 2/97.) 1100 . *----------------------------------------------------------------------- 0 1101 + +KEEP,DOLOOP. 1102 . INTEGER DOREF,IFREF,LINREF,CURLIN,CDOLVL,CIFLVL,TRACDO,TRACIF, 1103 . - ISTATE,NDOLIN,NLOOP,NIF 1104 . COMMON /DODAT/ LINREF(MXDLIN,8),DOREF(MXDLVL,10),IFREF(MXILVL,5), 1105 . - TRACDO(0:MXDLVL),TRACIF(0:MXILVL),CURLIN,CDOLVL,CIFLVL, 1106 . - NDOLIN,NLOOP,NIF,ISTATE 0 1107 + +KEEP,XHISTDATA,IF=NEVER. 1108 . *----------------------------------------------------------------------- 1109 . * HISDAT - Common block storing histograms. 1110 . * (Last changed on 20/ 3/97.) 1111 . *----------------------------------------------------------------------- 0 1112 + +KEEP,HISTDATA. 1113 . REAL CONTEN(MXHIST,0:MXCHA+1),XMIN(MXHIST),XMAX(MXHIST) 1114 . DOUBLE PRECISION SX0(MXHIST),SX1(MXHIST),SX2(MXHIST) 1115 . INTEGER NCHA(MXHIST),NENTRY(MXHIST) 1116 . LOGICAL SET(MXHIST),HISUSE(MXHIST),HISLIN(MXHIST) 1117 . COMMON /HISDAT/ SX0,SX1,SX2,CONTEN,XMIN,XMAX,HISUSE,HISLIN,NCHA, 1118 . - NENTRY,SET 0 1119 + +KEEP,XMATDATA,IF=NEVER. 1120 . *----------------------------------------------------------------------- 1121 . * MATDAT - Common block storing matrices. 1122 . * VARIABLES : MSIZ(I,J) : Length of dimension J of matrix I 1123 . * MDIM(I) : Number of dimensions of matrix I 1124 . * MREF(I) : Reference for matrix I 1125 . * MMOD(I) : Type of variables stored in matrix I 1126 . * MORG(I) : Points in MVEC before 1st element 1127 . * MLEN(I) : Length of matrix I (=product of MSIZ) 1128 . * NREFL : Last reference number assigned 1129 . * (Last changed on 8/11/95.) 1130 . *----------------------------------------------------------------------- 0 1131 + +KEEP,MATDATA. 1132 . REAL MVEC(MXEMAT) 1133 . INTEGER MSIZ(MXMAT,MXMDIM),MDIM(MXMAT),MREF(MXMAT+1),MMOD(MXMAT), 1134 . - MORG(MXMAT+1),MLEN(MXMAT+1),NREFL 1135 . COMMON /MATDAT/ MVEC,MSIZ,MDIM,MMOD,MORG,MLEN,MREF,NREFL 28 GARFIELD ================================================== P=MAIN D= 1 ============================ 0 + +PATCH,MAIN. 29 GARFIELD ================================================== P=MAIN D=MAIN 1 ============================ 0 + +DECK,MAIN. 0 1-+ +SELF,IF=-CDC. 2 - PROGRAM MAIN 1 29 P=MAIN D=MAIN 2 PAGE 14 3-+ +SELF,IF=CDC. 4 - PROGRAM MAIN(INPUT=65,OUTPUT=65,TAPE5=INPUT,TAPE6=OUTPUT) 0 5-+ +SELF. 6 - *----------------------------------------------------------------------- 7 - * MAIN - This program reads headers from the input file and calls 8 - * the appropriate routines to carry out the requested action. 9 - * VARIABLE : STRING : serves for identifying the header. 10 - * (Last changed on 13/ 2/00.) 11 - *----------------------------------------------------------------------- 12 - implicit none 13.- +SEQ,DIMENSIONS. 14.- +SEQ,PRINTPLOT. 15.- +SEQ,CELLDATA. 16.- +SEQ,GASDATA. 17.- +SEQ,BFIELD. 18 - LOGICAL STDSTR 19 - INTEGER NC,IFAIL,NWORD,INPCMP 20 - CHARACTER*(MXCHAR) STRING 21 - EXTERNAL STDSTR,INPCMP 0 22-+ +SELF,IF=AST. 23 - EXTERNAL ASTCCH 24 - *** Set up ASTCCH as the condition handler and disable. 25 - CALL ASTINT 26 - CALL LIB$ESTABLISH(ASTCCH) 27 - CALL ASTDCC 0 28-+ +SELF,IF=CMS,IF=HIGZ. 29 - *** Initialise C calls for X windows. 30 - CALL INITC 0 31-+ +SELF,IF=CMS. 32 - *** Disable printing messages about direct access file opening. 33 - CALL ERRSET(151,0, -1,2,1) 0 34-+ +SELF. 35 - *** Initialise variables, graphics, input and algebra. 36 - CALL INIT 0 37-+ +SELF,IF=AST. 38 - *** After initialisation, reenable AST trapping. 39 - CALL ASTECC 0 40-+ +SELF. 41 - *** Print the news. 42 - PRINT *,' ------------------------------------------------------' 43 - PRINT *,' News, including some old but important items. ' 44 - PRINT *,' ......................................................' 45 - PRINT *,' 28/09/92: Gas mixing a la G. Schultz & J. Gresser. ' 46 - PRINT *,' 19/02/94: Polygons (triangle - octagon) available. ' 47 - PRINT *,' 20/05/94: Magboltz gas mixing interface added. ' 48 - PRINT *,' 04/01/97: Monte Carlo drift line integration added. ' 49 - PRINT *,' 27/01/97: Heed clustering interface introduced. ' 50 - PRINT *,' 06/02/97: Transverse diffusion reduced in Magboltz. ' 51 - PRINT *,' 21/05/97: Reading Maxwell 2D field maps. ' 52 - PRINT *,' 28/10/97: Reading Maxwell 3D field maps. ' 53 - PRINT *,' 08/10/98: Isochrones in field maps enabled. ' 54 - PRINT *,' 31/01/99: Reading Tosca parallelepipedic field maps. ' 55 - PRINT *,' 30/04/99: Signals in other electrodes than wires. ' 56 - PRINT *,' 21/05/99: New arrival time distribution format. ' 57 - PRINT *,' 04/02/00: Magboltz 2 introduced. ' 58 - PRINT *,' 24/09/00: Heed interface corrected for cluster losses.' 59 - PRINT *,' ......................................................' 60 - PRINT *,' Garfield and Heed documentation is available via WWW ' 61 - PRINT *,' at http://consult.cern.ch/writeup/garfield ' 62 - PRINT *,' and http://consult.cern.ch/writeup/heed ' 63 - PRINT *,' ------------------------------------------------------' 64 - PRINT *,' ' 65 - PRINT *,' ' 66 - PRINT *,' Welcome, this is Garfield - version 7.04,'// 67 - - ' updated until 6/1/2001.' 68 - PRINT *,' ' 69 - *** Print a message when ready to start in interactive mode. 70 - IF(STDSTR('INPUT'))THEN 71 - PRINT *,' ================================================' 72 - PRINT *,' ========== Ready - Enter a header ==========' 73 - PRINT *,' ================================================' 74 - PRINT *,' ' 75 - ENDIF 76 - *** Start an input loop that stops at the EOF or at the STOP command. 77 - IFAIL=0 78 - CALL INPPRM('Main','NEW-PRINT') 79 - CALL INPWRD(NWORD) 80 - *** Otherwise the line should start with an & symbol. 81 - 10 CONTINUE 82 - CALL INPNUM(NWORD) 83 - * Skip blank lines. 84 - IF(NWORD.EQ.0)THEN 85 - CALL INPWRD(NWORD) 86 - GOTO 10 87 - ENDIF 88 - * Stay in main if requested. 89 - IF(INPCMP(1,'&MAIN')+INPCMP(2,'MAIN').NE.0)THEN 90 - CALL INPWRD(NWORD) 91 - GOTO 10 92 - ENDIF 93 - * Make sure it starts with an ampersand. 94 - CALL INPSTR(1,1,STRING,NC) 95 - IF(STRING(1:1).NE.'&')THEN 96 - PRINT *,' !!!!!! MAIN WARNING : Please enter a section'// 97 - - ' header, a control statement or a global command.' 98 - CALL INPWRD(NWORD) 99 - GOTO 10 100 - ELSEIF(NC.EQ.1.AND.NWORD.EQ.1)THEN 101 - PRINT *,' !!!!!! MAIN WARNING : A section name should'// 1 29 P=MAIN D=MAIN 3 PAGE 15 102 - - ' be appended to the &; try again.' 103 - CALL INPWRD(NWORD) 104 - GOTO 10 105 - ENDIF 106 - IF((NWORD.GT.2.AND.NC.EQ.1).OR.(NWORD.GT.1.AND.NC.GT.1)) 107 - - PRINT *,' !!!!!! MAIN WARNING : Keywords on the header'// 108 - - ' line are ignored in this version of the program.' 109 - IF(NC.EQ.1)CALL INPSTR(2,2,STRING,NC) 0 110-+ +SELF,IF=CDC. 111 - *** Send message to the console, if the job is running in batch. 112 - CALL BTEXT(STRING) 0 113-+ +SELF. 114 - *** Stop if STOP is the keyword. 115 - IF(INPCMP(1,'&ST#OP')+INPCMP(2,'ST#OP')+ 116 - - INPCMP(1,'&Q#UIT')+INPCMP(2,'Q#UIT')+ 117 - - INPCMP(1,'&EX#IT')+INPCMP(2,'EX#IT').NE.0)THEN 118 - CALL QUIT 119 - STOP 0 120-+ +SELF,IF=TEST. 121 - *** Call the user test routine UTEST. 122 - ELSEIF(INPCMP(1,'&T#EST')+INPCMP(2,'T#EST').NE.0)THEN 123 - CALL UTEST 124 - CALL INPPRM('Main','NEW-PRINT') 125 - CALL INPWRD(NWORD) 0 126-+ +SELF,IF=CELL. 127 - *** Call CELDEF if CELL is a keyword, 128 - ELSEIF(INPCMP(1,'&C#ELL')+INPCMP(2,'C#ELL').NE.0)THEN 129 - * Call cell reading routine. 130 - CALL CELDEF(IFAIL) 131 - IF(IFAIL.EQ.1)PRINT *,' !!!!!! MAIN WARNING : The cell'// 132 - - ' section failed ; various sections can not be'// 133 - - ' entered.' 134 - *** Call MAGINP if MAGNETIC is a keyword. 135 - ELSEIF(INPCMP(1,'&M#AGNETIC-#FIELD')+ 136 - - INPCMP(2,'M#AGNETIC-#FIELD').NE.0)THEN 137 - CALL MAGINP 138 - IF(GASSET)THEN 139 - IF((BTAB(1)-BFMIN*BSCALE)* 140 - - (BFMIN*BSCALE-BTAB(NBTAB)).LT.0.OR. 141 - - (BTAB(1)-BFMAX*BSCALE)* 142 - - (BFMAX*BSCALE-BTAB(NBTAB)).LT.0)THEN 143 - PRINT *,' ------ MAIN MESSAGE : Previous gas'// 144 - - ' data deleted.' 145 - GASSET=.FALSE. 146 - ENDIF 147 - ENDIF 0 148-+ +SELF,IF=-CELL. 149 - *** Warn if the cell section has not been compiled. 150 - ELSEIF(INPCMP(1,'&C#ELL')+INPCMP(2,'C#ELL')+ 151 - - INPCMP(1,'&M#AGNETIC-#FIELD')+ 152 - - INPCMP(2,'M#AGNETIC-#FIELD').NE.0)THEN 153 - PRINT *,' !!!!!! MAIN WARNING : The &CELL and &MAGNETIC'// 154 - - ' sections are absent in this compilation.' 155 - CALL SKIP 0 156-+ +SELF,IF=GAS. 157 - *** Read gas data if GAS is the first keyword, 158 - ELSEIF(INPCMP(1,'&G#AS')+INPCMP(2,'G#AS').NE.0)THEN 159 - * Call the gas data reading routine. 160 - CALL GASDEF(IFAIL) 161 - IF(IFAIL.NE.0.AND.JFAIL.EQ.1)THEN 162 - PRINT *,' !!!!!! MAIN WARNING : Gas section failed'// 163 - - ' ; CO2 will be used for the time being.' 164 - CALL XXXGAS(IFAIL) 165 - IF(IFAIL.NE.0)PRINT *,' ###### MAIN ERROR : CO2'// 166 - - ' data are not correct ; no gas data.' 167 - ELSEIF(IFAIL.NE.0)THEN 168 - PRINT *,' !!!!!! MAIN WARNING : The gas section'// 169 - - ' failed ; various sections can not be entered.' 170 - ENDIF 0 171-+ +SELF,IF=-GAS. 172 - *** Warn if the gas section has not been compiled. 173 - ELSEIF(INPCMP(1,'&G#AS')+INPCMP(2,'G#AS').NE.0)THEN 174 - PRINT *,' !!!!!! MAIN WARNING : The &GAS'// 175 - - ' section is absent in this compilation.' 176 - CALL SKIP 0 177-+ +SELF,IF=FIELD. 178 - *** Call FLDINP if FIELD is a keyword. 179 - ELSEIF(INPCMP(1,'&F#IELD')+INPCMP(2,'F#IELD').NE.0)THEN 180 - IF(CELSET)THEN 181 - CALL FLDINP 182 - ELSE 183 - PRINT *,' !!!!!! MAIN WARNING : No cell available'// 184 - - ' to do field calculations in ; skipped.' 185 - CALL SKIP 186 - ENDIF 0 187-+ +SELF,IF=-FIELD. 188 - *** Warn if the field section has not been compiled. 189 - ELSEIF(INPCMP(1,'&F#IELD')+INPCMP(2,'F#IELD').NE.0)THEN 190 - PRINT *,' !!!!!! MAIN WARNING : The &FIELD'// 191 - - ' section is absent in this compilation.' 192 - CALL SKIP 0 193-+ +SELF,IF=OPTIMISE. 194 - *** Call OPTINP if OPTIMISE is a keyword. 195 - ELSEIF(INPCMP(1,'&O#PTIMISE')+INPCMP(2,'O#PTIMISE').NE.0)THEN 196 - IF(CELSET)THEN 197 - CALL OPTINP 1 29 P=MAIN D=MAIN 4 PAGE 16 198 - ELSE 199 - PRINT *,' !!!!!! MAIN WARNING : No cell available'// 200 - - ' to optimise ; the section is skipped.' 201 - CALL SKIP 202 - ENDIF 0 203-+ +SELF,IF=-OPTIMISE. 204 - *** Warn if the optimisation section has not been compiled. 205 - ELSEIF(INPCMP(1,'&O#PTIMISE')+INPCMP(2,'O#PTIMISE').NE.0)THEN 206 - PRINT *,' !!!!!! MAIN WARNING : The &OPTIMISE'// 207 - - ' section is absent in this compilation.' 208 - CALL SKIP 0 209-+ +SELF,IF=DRIFT. 210 - *** Call DRFINP if DRIFT is the keyword. 211 - ELSEIF(INPCMP(1,'&D#RIFT')+INPCMP(2,'D#RIFT').NE.0)THEN 212 - IF((.NOT.GASSET).AND.JFAIL.EQ.1)THEN 213 - PRINT *,' !!!!!! MAIN WARNING : No gas data found'// 214 - - ' so far ; CO2 will be used for the time being.' 215 - CALL XXXGAS(IFAIL) 216 - IF(IFAIL.NE.0)THEN 217 - PRINT *,' ###### MAIN ERROR : The CO2 data'// 218 - - ' are not correct ; no gas data.' 219 - CALL SKIP 220 - GOTO 10 221 - ENDIF 222 - ELSEIF(.NOT.GASSET)THEN 223 - PRINT *,' !!!!!! MAIN WARNING : No valid gas data'// 224 - - ' found so far ; drift section not executed.' 225 - CALL SKIP 226 - GOTO 10 227 - ENDIF 228 - IF(CELSET)THEN 229 - CALL DRFINP 230 - ELSE 231 - PRINT *,' !!!!!! MAIN WARNING : No valid cell data'// 232 - - ' found so far ; drift section not executed.' 233 - CALL SKIP 234 - ENDIF 0 235-+ +SELF,IF=-DRIFT. 236 - *** Warn if the drift section has not been compiled. 237 - ELSEIF(INPCMP(1,'&D#RIFT')+INPCMP(2,'D#RIFT').NE.0)THEN 238 - PRINT *,' !!!!!! MAIN WARNING : The &DRIFT'// 239 - - ' section is absent in this compilation.' 240 - CALL SKIP 0 241-+ +SELF,IF=SIGNAL. 242 - *** Call SIGINP if SIGNAL is the keyword. 243 - ELSEIF(INPCMP(1,'&SI#GNAL')+INPCMP(2,'SI#GNAL').NE.0)THEN 244 - IF((.NOT.GASSET).AND.JFAIL.EQ.1)THEN 245 - PRINT *,' !!!!!! MAIN WARNING : No gas data found'// 246 - - ' so far ; CO2 will be used for the time being.' 247 - CALL XXXGAS(IFAIL) 248 - IF(IFAIL.NE.0)THEN 249 - PRINT *,' ###### MAIN ERROR : The CO2 data'// 250 - - ' are not correct ; no gas data.' 251 - CALL SKIP 252 - GOTO 10 253 - ENDIF 254 - ELSEIF(.NOT.GASSET)THEN 255 - PRINT *,' !!!!!! MAIN WARNING : No valid gas data'// 256 - - ' found so far ; signal section not executed.' 257 - CALL SKIP 258 - GOTO 10 259 - ENDIF 260 - IF(CELSET)THEN 261 - CALL SIGINP 262 - ELSE 263 - PRINT *,' !!!!!! MAIN WARNING : No valid cell data'// 264 - - ' found so far ; signal section not executed.' 265 - CALL SKIP 266 - ENDIF 0 267-+ +SELF,IF=-SIGNAL. 268 - *** Warn if the signal section has not been compiled. 269 - ELSEIF(INPCMP(1,'&SI#GNAL')+INPCMP(2,'SI#GNAL').NE.0)THEN 270 - PRINT *,' !!!!!! MAIN WARNING : The &SIGNAL'// 271 - - ' section is absent in this compilation.' 272 - CALL SKIP 0 273-+ +SELF. 274 - *** Header is recognised. 275 - ELSE 276 - PRINT *,' !!!!!! MAIN WARNING : ',STRING(1:NC),' is'// 277 - - ' not a valid header.' 278 - CALL SKIP 279 - ENDIF 280 - *** Read a new header. 281 - CALL INPPRM('Main','NEW-PRINT') 282 - GOTO 10 283 - END 30 GARFIELD ================================================== P=MAIN D=INIT 1 ============================ 0 + +DECK,INIT. 1 - SUBROUTINE INIT 2 - *----------------------------------------------------------------------- 3 - * INIT - Subroutine initialising most common blocks. 4 - * (Last changed on 28/11/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9.- +SEQ,CONSTANTS. 1 30 P=MAIN D=INIT 2 PAGE 17 10.- +SEQ,CELLDATA. 11.- +SEQ,PRINTPLOT. 12.- +SEQ,INPUT. 13.- +SEQ,GASDATA. 14.- +SEQ,GASMIXDATA. 15.- +SEQ,DRIFTLINE. 16.- +SEQ,BFIELD. 17.- +SEQ,OPTDATA,IF=OPTIMISE. 18.- +SEQ,SIGNALDATA,IF=SIGNAL. 19.- +SEQ,CONTDATA. 20.- +SEQ,GLOBALS. 21.- +SEQ,DOLOOP. 22.- +SEQ,SOLIDS. 23 - EXTERNAL STDSTR,RNDM,RANFL 24 - LOGICAL STDSTR 25 - REAL RVEC(1),RNDM,RANFL,DUMMY 26 - DOUBLE PRECISION DVEC(1) 27 - CHARACTER*8 DATE,TIME 28 - INTEGER IFAIL,I,J,IREF,IRNDM,JRNDM,KRNDM 0 29-+ +SELF,IF=VAX. 30 - external cli$present,cli$_present,cli$_absent,cli$_negated, 31 - - cli$_defaulted,lib$get_foreign,garfcld,lib$get_input 32 - character*256 comlin 33 - integer cli$present,status,lib$get_foreign,cli$dcl_parse, 34 - - lib$get_input,nccom 35 - include '($fordef)' 36 - include '($ssdef)' 0 37-+ +SELF,IF=APOLLO. 38 - %include '/sys/ins/base.ins.ftn' 39 - %include '/sys/ins/pgm.ins.ftn' 40 - integer*2 iarg,nargs,arg_length 41 - integer pointer(128),inpcmx,inext,istat 42 - character*128 args 43 - external inpcmx 0 44-+ +SELF,IF=UNIX. 45 - integer inpcmx,arg_length,iarg,nargs,iargc,inext 46 - character*128 args 47 - external inpcmx,iargc 0 48-+ +SELF,IF=CMS. 49 - INTEGER IRC 50 - CHARACTER*80 OPTFLG 0 51-+ +SELF,IF=CMS,IF=VECTOR. 52 - DOUBLE PRECISION VDUMMY(4) 0 53-+ +SELF. 54 - *** Output unit. 55 - LUNOUT =6 56 - *** Write a record to the log file of the program. 0 57-+ +SELF,IF=VECTOR. 58 - CALL JOBLOG('Version V7.04, C=6/1/01 Avalanche signals.') 0 59-+ +SELF,IF=-VECTOR. 60 - CALL JOBLOG('Version S7.04, C=6/1/01 Avalanche signals.') 0 61-+ +SELF. 0 62-+ +SELF,IF=VAX. 63 - *** Decode the command line. 64 - status=lib$get_foreign(comlin,,nccom,) 65 - if(.not.status)then 66 - print *,' ###### INIT ERROR : Unable to fetch the'// 67 - - ' command line ; Vax reason follows, program quit.' 68 - call lib$signal(%val(status)) 69 - call quit 70 - endif 71 - status=cli$dcl_parse('garfield '//comlin(1:max(1,nccom)), 72 - - garfcld,lib$get_input) 73 - if(.not.status)then 74 - print *,' !!!!!! INIT WARNING : Unable to decode the'// 75 - - ' command line, see above; program quit.' 76 - call quit 77 - endif 0 78-+ +SELF. 0 79-+ +SELF,IF=CMS. 80 - *** Start the clock, set the time limit very high. 81 - CALL TIMEST(1.0E10) 0 82-+ +SELF,IF=-CMS,-VECTOR. 83 - CALL TIMED(DUMMY) 0 84-+ +SELF,IF=CMS,IF=VECTOR. 85 - CALL VCLOC(VDUMMY) 0 86-+ +SELF. 87 - *** Initial data for the /PARMS/ common block. 88 - NLINED=20 89 - NINORD=2 90 - LINCAL=.TRUE. 91 - NGRIDX=25 92 - NGRIDY=25 93 - LEPSG=.FALSE. 94 - EPSGX=0 95 - EPSGY=0 96 - EPSGZ=0 97 - CALL PLAINT 98 - *** Track initialisation. 99 - CALL TRAINT 100 - *** Parameters for contour plotting in /CONDAT/. 1 30 P=MAIN D=INIT 3 PAGE 18 101 - NBITER=10 102 - NNITER=10 103 - EPSTRA=1.0E-3 104 - EPSGRA=1.0E-3 105 - STINIT=0.174123 106 - DNTHR=0.1 107 - NGCMAX=500 108 - *** Initial data for the /DRIFTL/ common block. 109 - MXDIFS =MIN(2,MXSTCK) 110 - MXTWNS =MIN(2,MXSTCK) 111 - MXATTS =MIN(2,MXSTCK) 112 - LREPSK =.TRUE. 113 - LKINK =.TRUE. 114 - EPSDFI =1.0E-4 115 - EPSTWI =1.0E-4 116 - EPSATI =1.0E-4 117 - RDF2 =5 118 - MDF2 =2 119 - TMC =0.00002 120 - DMC =0.001 121 - NMC =100 122 - MCMETH =0 123 - RTRAP =2.0 124 - EPSDIF =1.0E-8 125 - STMAX =0.0 126 - LSTMAX =.FALSE. 127 - IPTYPE =0 128 - IPTECH =0 129 - QPCHAR =0.0 130 - NU =0 131 - EQTTHR =0.2 132 - EQTASP =3 133 - EQTCLS =0.2 134 - LEQSRT =.TRUE. 135 - LEQCRS =.TRUE. 136 - LEQMRK =.FALSE. 137 - LAVPRO =.FALSE. 138 - *** Initial data for the /CELDAT/ common block. 139 - CALL CELINT 140 - * Memory allocation. 141 - CALL BOOK('INITIALISE','MATRIX',' ',IFAIL) 142 - IF(IFAIL.NE.0)THEN 143 - PRINT *,' ###### INIT ERROR : Unable to declare the'// 144 - - ' capacitance matrix; cell computations may fail.' 145 - ENDIF 146 - *** Background field. 147 - IENBGF =0 148 - LBGFMP =.FALSE. 149 - *** Initialise the field map. 150 - CALL MAPINT 151 - *** Solids. 152 - NSOLID =0 153 - ICCURR =0 154 - *** Initial data statements for the /PRTPLT/ common block. 155 - JFAIL=1 156 - JEXMEM=2 157 - LINPUT =.NOT.STDSTR('INPUT') 158 - LCELPR =.FALSE. 159 - LCELPL =.FALSE. 160 - LWRMRK =.FALSE. 161 - LISOCL =.FALSE. 162 - LCHGCH =.FALSE. 163 - LDRPLT =.FALSE. 164 - LDRPRT =.FALSE. 165 - LCLPRT =.TRUE. 166 - LCLPLT =.TRUE. 167 - LIDENT =.FALSE. 168 - LDEBUG =.FALSE. 169 - LRNDMI =.TRUE. 170 - LPROPR =.TRUE. 171 - LPROF =.TRUE. 172 - LMAPCH =.FALSE. 173 - LCNTAM =.TRUE. 174 - LINREC =STDSTR('INPUT') 175 - LGSTOP =.FALSE. 176 - LSYNCH =.FALSE. 177 - *** Read the command line options, first preset the optional arguments. 178 - NCARG=1 179 - ARGSTR=' ' 0 180-+ +SELF,IF=VAX. 181 - * Check the command line for the /DEBUG qualifier on Vax computers. 182 - IF(CLI$PRESENT('DEBUG').EQ.%loc(CLI$_PRESENT).OR. 183 - - CLI$PRESENT('DEBUG').EQ.%loc(CLI$_DEFAULTED))THEN 184 - LDEBUG=.TRUE. 185 - ELSEIF(CLI$PRESENT('DEBUG').EQ.%loc(CLI$_ABSENT).OR. 186 - - CLI$PRESENT('DEBUG').EQ.%loc(CLI$_NEGATED))THEN 187 - LDEBUG=.FALSE. 188 - ENDIF 189 - * Check the command line for the /IDENT qualifier on Vax computers. 190 - IF(CLI$PRESENT('IDENTIFICATION').EQ.%loc(CLI$_PRESENT).OR. 191 - - CLI$PRESENT('IDENTIFICATION').EQ.%loc(CLI$_DEFAULTED))THEN 192 - LIDENT=.TRUE. 193 - ELSEIF(CLI$PRESENT('IDENTIFICATION').EQ.%loc(CLI$_ABSENT).OR. 194 - - CLI$PRESENT('IDENTIFICATION').EQ.%loc(CLI$_NEGATED))THEN 195 - LIDENT=.FALSE. 196 - ENDIF 197 - * Check the command line for the /INPUT qualifier on Vax computers. 198 - IF(CLI$PRESENT('INPUT_LISTING').EQ.%loc(CLI$_PRESENT).OR. 199 - - CLI$PRESENT('INPUT_LISTING').EQ.%loc(CLI$_DEFAULTED))THEN 200 - LINPUT=.TRUE. 201 - ELSEIF(CLI$PRESENT('INPUT_LISTING').EQ.%loc(CLI$_ABSENT).OR. 202 - - CLI$PRESENT('INPUT_LISTING').EQ.%loc(CLI$_NEGATED))THEN 203 - LINPUT=.FALSE. 204 - ENDIF 205 - * Check the command line for the /RNDM_INIT qualifier on Vax computers. 1 30 P=MAIN D=INIT 4 PAGE 19 206 - IF(CLI$PRESENT('RNDM_INITIALISATION').EQ.%loc(CLI$_PRESENT).OR. 207 - - CLI$PRESENT('RNDM_INITIALISATION').EQ. 208 - - %loc(CLI$_DEFAULTED))THEN 209 - LRNDMI=.TRUE. 210 - ELSEIF(CLI$PRESENT('RNDM_INITIALISATION').EQ. 211 - - %loc(CLI$_ABSENT).OR. 212 - - CLI$PRESENT('RNDM_INITIALISATION').EQ. 213 - - %loc(CLI$_NEGATED))THEN 214 - LRNDMI=.FALSE. 215 - ENDIF 216 - * Check the command line for the /PROGRESS_PRINT qualifier on Vax. 217 - IF(CLI$PRESENT('PROGRESS_PRINT').EQ.%loc(CLI$_PRESENT).OR. 218 - - CLI$PRESENT('PROGRESS_PRINT').EQ. 219 - - %loc(CLI$_DEFAULTED))THEN 220 - LPROPR=.TRUE. 221 - ELSEIF(CLI$PRESENT('PROGRESS_PRINT').EQ. 222 - - %loc(CLI$_ABSENT).OR. 223 - - CLI$PRESENT('PROGRESS_PRINT').EQ. 224 - - %loc(CLI$_NEGATED))THEN 225 - LPROPR=.FALSE. 226 - ENDIF 227 - * Check the command line for the /RECORDING qualifier on Vax. 228 - IF(.NOT.STDSTR('INPUT'))THEN 229 - LINREC=.FALSE. 230 - ELSEIF(CLI$PRESENT('RECORDING').EQ.%loc(CLI$_PRESENT).OR. 231 - - CLI$PRESENT('RECORDING').EQ.%loc(CLI$_DEFAULTED))THEN 232 - LINREC=.TRUE. 233 - ELSEIF(CLI$PRESENT('RECORDING').EQ.%loc(CLI$_ABSENT).OR. 234 - - CLI$PRESENT('RECORDING').EQ.%loc(CLI$_NEGATED))THEN 235 - LINREC=.FALSE. 236 - ENDIF 237 - * Check the command line for the /PROFILE qualifier on Vax. 238 - IF(CLI$PRESENT('PROFILE').EQ.%loc(CLI$_PRESENT).OR. 239 - - CLI$PRESENT('PROFILE').EQ.%loc(CLI$_DEFAULTED))THEN 240 - LPROF=.TRUE. 241 - ELSEIF(CLI$PRESENT('PROFILE').EQ.%loc(CLI$_ABSENT).OR. 242 - - CLI$PRESENT('PROFILE').EQ.%loc(CLI$_NEGATED))THEN 243 - LPROF=.FALSE. 244 - ENDIF 245 - * Check the command line for the /SYNCHRONISE qualifier on Vax. 246 - IF(CLI$PRESENT('SYNCHRONISE').EQ.%loc(CLI$_PRESENT).OR. 247 - - CLI$PRESENT('SYNCHRONISE').EQ.%loc(CLI$_DEFAULTED))THEN 248 - LSYNCH=.TRUE. 249 - ELSEIF(CLI$PRESENT('SYNCHRONISE').EQ.%loc(CLI$_ABSENT).OR. 250 - - CLI$PRESENT('SYNCHRONISE').EQ.%loc(CLI$_NEGATED))THEN 251 - LSYNCH=.FALSE. 252 - ENDIF 0 253-+ +SELF,IF=CMS. 254 - * Check the command line for the DEBUG option under VM/CMS. 255 - CALL VMREXX('F','DEBUG',OPTFLG,IRC) 256 - IF(IRC.NE.0)THEN 257 - PRINT *,' !!!!!! INIT WARNING : Unable to read the value', 258 - - ' of the DEBUG option via VMREXX; set to .FALSE.' 259 - * Enable or disable printing of error messages. 260 - ELSEIF(OPTFLG.EQ.'YES')THEN 261 - LDEBUG=.TRUE. 262 - CALL ERRSET(207,0,256,2,1) 263 - CALL ERRSET(208,0,256,2,1) 264 - CALL ERRSET(209,0,256,2,1) 265 - CALL ERRSET(213,0,256,2,1) 266 - ELSEIF(OPTFLG.EQ.'NO')THEN 267 - LDEBUG=.FALSE. 268 - CALL ERRSET(207,0, -1,2,1) 269 - CALL ERRSET(208,0, -1,2,1) 270 - CALL ERRSET(209,0, -1,2,1) 271 - CALL ERRSET(213,0, -1,2,1) 272 - ELSE 273 - PRINT *,' !!!!!! INIT WARNING : Invalid DEBUG option'// 274 - - ' received from VMREXX: ',OPTFLG 275 - ENDIF 276 - * Check the command line for the IDENT option under VM/CMS. 277 - CALL VMREXX('F','IDENTIFICATION',OPTFLG,IRC) 278 - IF(IRC.NE.0)THEN 279 - PRINT *,' !!!!!! INIT WARNING : Unable to read the value', 280 - - ' of the IDENT option via VMREXX; set to .FALSE.' 281 - ELSEIF(OPTFLG.EQ.'YES')THEN 282 - LIDENT=.TRUE. 283 - ELSEIF(OPTFLG.EQ.'NO')THEN 284 - LIDENT=.FALSE. 285 - ELSE 286 - PRINT *,' !!!!!! INIT WARNING : Invalid IDENT option'// 287 - - ' received from VMREXX: ',OPTFLG 288 - ENDIF 289 - * Check the command line for the INPUT option under VM/CMS. 290 - CALL VMREXX('F','INPUT_LISTING',OPTFLG,IRC) 291 - IF(IRC.NE.0)THEN 292 - PRINT *,' !!!!!! INIT WARNING : Unable to read the value', 293 - - ' of the INPUT option via VMREXX; set to .FALSE.' 294 - ELSEIF(OPTFLG.EQ.'YES')THEN 295 - LINPUT=.TRUE. 296 - ELSEIF(OPTFLG.EQ.'NO')THEN 297 - LINPUT=.FALSE. 298 - ELSEIF(OPTFLG.NE.'*')THEN 299 - PRINT *,' !!!!!! INIT WARNING : Invalid INPUT option'// 300 - - ' received from VMREXX: ',OPTFLG 301 - ENDIF 302 - * Check the command line for the RNDM_INIT option under VM/CMS. 303 - CALL VMREXX('F','RNDM_INITIALISATION',OPTFLG,IRC) 304 - IF(IRC.NE.0)THEN 305 - PRINT *,' !!!!!! INIT WARNING : Unable to read the value', 306 - - ' of the RNDM_INIT option via VMREXX; set to .TRUE.' 307 - ELSEIF(OPTFLG.EQ.'YES')THEN 308 - LRNDMI=.TRUE. 309 - ELSEIF(OPTFLG.EQ.'NO')THEN 310 - LRNDMI=.FALSE. 1 30 P=MAIN D=INIT 5 PAGE 20 311 - ELSE 312 - PRINT *,' !!!!!! INIT WARNING : Invalid RNDM_INIT'// 313 - - ' option received from VMREXX: ',OPTFLG 314 - ENDIF 315 - * Check the command line for the PROGRESS_PRINT option under VM/CMS. 316 - CALL VMREXX('F','PROGRESS_PRINT',OPTFLG,IRC) 317 - IF(IRC.NE.0)THEN 318 - PRINT *,' !!!!!! INIT WARNING : Unable to read the value', 319 - - ' of the PROGRESS option via VMREXX; set to .TRUE.' 320 - ELSEIF(OPTFLG.EQ.'YES')THEN 321 - LPROPR=.TRUE. 322 - ELSEIF(OPTFLG.EQ.'NO')THEN 323 - LPROPR=.FALSE. 324 - ELSE 325 - PRINT *,' !!!!!! INIT WARNING : Invalid PROGRESS_PRINT'// 326 - - ' option received from VMREXX: ',OPTFLG 327 - ENDIF 328 - * Check the command line for the RECORDING option under VM/CMS. 329 - CALL VMREXX('F','RECORDING',OPTFLG,IRC) 330 - IF(IRC.NE.0)THEN 331 - PRINT *,' !!!!!! INIT WARNING : Unable to read the value', 332 - - ' of the RECORDING option via VMREXX; set to .TRUE.' 333 - ELSEIF(.NOT.STDSTR('INPUT'))THEN 334 - LINREC=.FALSE. 335 - ELSEIF(OPTFLG.EQ.'YES')THEN 336 - LINREC=.TRUE. 337 - ELSEIF(OPTFLG.EQ.'NO')THEN 338 - LINREC=.FALSE. 339 - ELSE 340 - PRINT *,' !!!!!! INIT WARNING : Invalid RECORDING'// 341 - - ' option received from VMREXX: ',OPTFLG 342 - ENDIF 343 - * Check the command line for the PROFILE option under VM/CMS. 344 - CALL VMREXX('F','PROFILE',OPTFLG,IRC) 345 - IF(IRC.NE.0)THEN 346 - PRINT *,' !!!!!! INIT WARNING : Unable to read the value', 347 - - ' of the PROFILE option via VMREXX; set to .TRUE.' 348 - ELSEIF(OPTFLG.EQ.'YES')THEN 349 - LPROF=.TRUE. 350 - ELSEIF(OPTFLG.EQ.'NO')THEN 351 - LPROF=.FALSE. 352 - ELSE 353 - PRINT *,' !!!!!! INIT WARNING : Invalid PROFILE'// 354 - - ' option received from VMREXX: ',OPTFLG 355 - ENDIF 356 - * Check the command line for the SYNCHRONISE option under VM/CMS. 357 - CALL VMREXX('F','SYNCHRONISE',OPTFLG,IRC) 358 - IF(IRC.NE.0)THEN 359 - PRINT *,' !!!!!! INIT WARNING : Unable to read the value', 360 - - ' of the PROFILE option via VMREXX; set to .TRUE.' 361 - ELSEIF(OPTFLG.EQ.'YES')THEN 362 - LSYNCH=.TRUE. 363 - ELSEIF(OPTFLG.EQ.'NO')THEN 364 - LSYNCH=.FALSE. 365 - ELSE 366 - PRINT *,' !!!!!! INIT WARNING : Invalid SYNCHRONISE'// 367 - - ' option received from VMREXX: ',OPTFLG 368 - ENDIF 0 369-+ +SELF,IF=APOLLO. 370 - * Count the number of arguments, pointer vector will not be used. 371 - call pgm_$get_args(nargs,pointer) 372 - * Loop over arguments, deleting those we recognise. 373 - inext=1 374 - do 30 iarg=1,nargs-1 375 - if(iarg.lt.inext)goto 30 376 - arg_length=pgm_$get_arg(iarg,args,istat) 377 - if(istat.ne.status_$ok)print *,' !!!!!! INIT WARNING : Error'// 378 - - ' fetching an argument.' 379 - istat=status_$ok 380 - * Debugging options. 381 - if(inpcmx(args(1:arg_length),'-deb#ug').ne.0)then 382 - ldebug=.true. 383 - elseif(inpcmx(args(1:arg_length),'-nodeb#ug').ne.0)then 384 - ldebug=.false. 385 - * Tracing options. 386 - elseif(inpcmx(args(1:arg_length),'-id#entification').ne.0)then 387 - lident=.true. 388 - elseif(inpcmx(args(1:arg_length),'-noid#entification').ne.0)then 389 - lident=.false. 390 - * Input listing. 391 - elseif(inpcmx(args(1:arg_length),'-in#put_listing').ne.0)then 392 - linput=.true. 393 - elseif(inpcmx(args(1:arg_length),'-noin#put_listing').ne.0)then 394 - linput=.false. 395 - * Random number initialisation. 396 - elseif(inpcmx(args(1:arg_length), 397 - - '-RNDM#_initialisation').ne.0)then 398 - lrndmi=.true. 399 - elseif(inpcmx(args(1:arg_length), 400 - - '-noRNDM#_initialisation').ne.0)then 401 - lrndmi=.false. 402 - * Progress printing. 403 - elseif(inpcmx(args(1:arg_length),'-pro#gress_print').ne.0)then 404 - lpropr=.true. 405 - elseif(inpcmx(args(1:arg_length),'-nopro#gress_print').ne.0)then 406 - lpropr=.false. 407 - * Input recording. 408 - elseif(inpcmx(args(1:arg_length),'-rec#ording').ne.0)then 409 - if(stdstr('INPUT'))then 410 - linrec=.true. 411 - else 412 - PRINT *,' !!!!!! INIT WARNING : The -recording'// 413 - - ' option is for interactive use only; ignored.' 414 - endif 415 - elseif(inpcmx(args(1:arg_length),'-norec#ording').ne.0)then 1 30 P=MAIN D=INIT 6 PAGE 21 416 - linrec=.false. 417 - * Reading of profile file. 418 - elseif(inpcmx(args(1:arg_length),'-pr#ofile').ne.0)then 419 - lprof=.true. 420 - elseif(inpcmx(args(1:arg_length),'-nopr#ofile').ne.0)then 421 - lprof=.false. 422 - * Synchronisation prompt. 423 - elseif(inpcmx(args(1:arg_length),'-synch#ronise').ne.0)then 424 - lsynch=.true. 425 - elseif(inpcmx(args(1:arg_length),'-nosynch#ronise').ne.0)then 426 - lsynch=.false. 427 - * Terminal and metafile type. 428 - elseif(inpcmx(args(1:arg_length),'-term#inal')+ 429 - - inpcmx(args(1:arg_length),'-meta#file').ne.0)then 430 - do 50 j=iarg+1,nargs 431 - arg_length=pgm_$get_arg(j,args,istat) 432 - if(istat.ne.status_$ok)print *,' !!!!!! INIT WARNING :'// 433 - - ' Error fetching an argument.' 434 - istat=status_$ok 435 - if(args(1:1).eq.'-'.and.arg_length.gt.1)then 436 - inext=j 437 - goto 30 438 - endif 439 - 50 continue 440 - inext=nargs+1 441 - * Anything else is not valid. 442 - elseif(inpcmx(args(1:arg_length),'-noterm#inal')+ 443 - - inpcmx(args(1:arg_length),'-nometa#file')+ 444 - - inpcmx(args(1:arg_length),'-interact#ive')+ 445 - - inpcmx(args(1:arg_length),'-batch').eq.0)then 446 - print *,' !!!!!! INIT WARNING : Unrecognised option "'// 447 - - args(1:arg_length)//'" found on the command line.' 448 - endif 449 - 30 continue 0 450-+ +SELF,IF=UNIX. 451 - * Count the number of arguments, pointer vector will not be used. 452 - nargs=iargc() 453 - * Loop over arguments, deleting those we recognise. 454 - inext=1 455 - do 30 iarg=1,nargs 456 - if(iarg.lt.inext)goto 30 457 - call argget(iarg,args,arg_length) 458 - * Debugging options. 459 - if(inpcmx(args(1:arg_length),'-deb#ug').ne.0)then 460 - ldebug=.true. 461 - elseif(inpcmx(args(1:arg_length),'-nodeb#ug').ne.0)then 462 - ldebug=.false. 463 - * Tracing options. 464 - elseif(inpcmx(args(1:arg_length),'-id#entification').ne.0)then 465 - lident=.true. 466 - elseif(inpcmx(args(1:arg_length),'-noid#entification').ne.0)then 467 - lident=.false. 468 - * Input listing. 469 - elseif(inpcmx(args(1:arg_length),'-in#put_listing').ne.0)then 470 - linput=.true. 471 - elseif(inpcmx(args(1:arg_length),'-noin#put_listing').ne.0)then 472 - linput=.false. 473 - * Random number initialisation. 474 - elseif(inpcmx(args(1:arg_length), 475 - - '-RNDM#_initialisation').ne.0)then 476 - lrndmi=.true. 477 - elseif(inpcmx(args(1:arg_length), 478 - - '-noRNDM#_initialisation').ne.0)then 479 - lrndmi=.false. 480 - * Progress printing. 481 - elseif(inpcmx(args(1:arg_length),'-pro#gress_print').ne.0)then 482 - lpropr=.true. 483 - elseif(inpcmx(args(1:arg_length),'-nopro#gress_print').ne.0)then 484 - lpropr=.false. 485 - * Input recording. 486 - elseif(inpcmx(args(1:arg_length),'-rec#ording').ne.0)then 487 - if(STDSTR('INPUT'))linrec=.true. 488 - elseif(inpcmx(args(1:arg_length),'-norec#ording').ne.0)then 489 - linrec=.false. 490 - * Reading of profile file. 491 - elseif(inpcmx(args(1:arg_length),'-pr#ofile').ne.0)then 492 - lprof=.true. 493 - elseif(inpcmx(args(1:arg_length),'-nopr#ofile').ne.0)then 494 - lprof=.false. 495 - * Synchronisation prompt. 496 - elseif(inpcmx(args(1:arg_length),'-synch#ronise').ne.0)then 497 - lsynch=.true. 498 - elseif(inpcmx(args(1:arg_length),'-nosynch#ronise').ne.0)then 499 - lsynch=.false. 500 - * Terminal and metafile type. 501 - elseif(inpcmx(args(1:arg_length),'-term#inal')+ 502 - - inpcmx(args(1:arg_length),'-meta#file')+ 503 - - inpcmx(args(1:arg_length),'-interact#ive')+ 504 - - inpcmx(args(1:arg_length),'-batch').ne.0)then 505 - do 50 j=iarg+1,nargs 506 - call argget(j,args,arg_length) 507 - if(args(1:1).eq.'-'.and.arg_length.gt.1)then 508 - inext=j 509 - goto 30 510 - endif 511 - 50 continue 512 - inext=nargs+1 513 - * Command line arguments. 514 - elseif(inpcmx(args(1:arg_length),'-arg#uments').ne.0)then 515 - ncarg=0 516 - do 60 j=iarg+1,nargs 517 - call argget(j,args,arg_length) 518 - if(inpcmx(args(1:arg_length),'-batch')+ 519 - - inpcmx(args(1:arg_length),'-interact#ive')+ 520 - - inpcmx(args(1:arg_length),'-deb#ug')+ 1 30 P=MAIN D=INIT 7 PAGE 22 521 - - inpcmx(args(1:arg_length),'-nodeb#ug')+ 522 - - inpcmx(args(1:arg_length),'-id#entification')+ 523 - - inpcmx(args(1:arg_length),'-noid#entification')+ 524 - - inpcmx(args(1:arg_length),'-in#put_listing')+ 525 - - inpcmx(args(1:arg_length),'-noin#put_listing')+ 526 - - inpcmx(args(1:arg_length),'-meta#file')+ 527 - - inpcmx(args(1:arg_length),'-nometa#file')+ 528 - - inpcmx(args(1:arg_length),'-pr#ofile')+ 529 - - inpcmx(args(1:arg_length),'-nopr#ofile')+ 530 - - inpcmx(args(1:arg_length),'-pro#gress_print')+ 531 - - inpcmx(args(1:arg_length),'-nopro#gress_print')+ 532 - - inpcmx(args(1:arg_length),'-rec#ording')+ 533 - - inpcmx(args(1:arg_length),'-norec#ording')+ 534 - - inpcmx(args(1:arg_length), 535 - - '-RNDM#_initialisation')+ 536 - - inpcmx(args(1:arg_length), 537 - - '-noRNDM#_initialisation')+ 538 - - inpcmx(args(1:arg_length),'-synch#ronise')+ 539 - - inpcmx(args(1:arg_length),'-nosynch#ronise')+ 540 - - inpcmx(args(1:arg_length),'-term#inal')+ 541 - - inpcmx(args(1:arg_length),'-noterm#inal').eq.0)then 542 - if(ncarg+1.le.len(argstr))then 543 - argstr(ncarg+1:)=args(1:arg_length)//' ' 544 - ncarg=min(len(argstr),ncarg+arg_length+1) 545 - else 546 - print *,' !!!!!! INIT WARNING : Command'// 547 - - ' line arguments too long; truncated.' 548 - endif 549 - inext=j+1 550 - else 551 - goto 70 552 - endif 553 - 60 continue 554 - 70 continue 555 - if(ncarg.gt.1)ncarg=ncarg-1 556 - if(ncarg.lt.1)then 557 - argstr=' ' 558 - ncarg=1 559 - endif 560 - * Anything else is not valid. 561 - elseif(inpcmx(args(1:arg_length),'-noterm#inal')+ 562 - - inpcmx(args(1:arg_length),'-nometa#file').eq.0)then 563 - print *,' !!!!!! INIT WARNING : Unrecognised option "'// 564 - - args(1:arg_length)//'" found on the command line.' 565 - endif 566 - 30 continue 0 567-+ +SELF. 568 - *** Global variable initialisation. 569 - GLBVAR(1)='TIME_LEFT ' 570 - GLBMOD(1)=2 571 - CALL TIMEL(GLBVAL(1)) 572 - GLBVAR(2)='MACHINE ' 573 - IREF=-1 0 574-+ +SELF,IF=APOLLO. 575 - CALL STRBUF('STORE',IREF,'Apollo',6,IFAIL) 0 576-+ +SELF,IF=CMS. 577 - CALL STRBUF('STORE',IREF,'CMS',3,IFAIL) 0 578-+ +SELF,IF=CRAY. 579 - CALL STRBUF('STORE',IREF,'Cray',4,IFAIL) 0 580-+ +SELF,IF=MVS. 581 - CALL STRBUF('STORE',IREF,'MVS',3,IFAIL) 0 582-+ +SELF,IF=VAX. 583 - CALL STRBUF('STORE',IREF,'Vax',3,IFAIL) 0 584-+ +SELF,IF=UNIX. 585 - CALL STRBUF('STORE',IREF,'Unix',4,IFAIL) 0 586-+ +SELF. 587 - IF(IREF.LT.0) 588 - - CALL STRBUF('STORE',IREF,'< not known >',13,IFAIL) 589 - GLBMOD(2)=1 590 - GLBVAL(2)=IREF 591 - GLBVAR(3)='INTERACT ' 592 - GLBVAR(4)='BATCH ' 593 - GLBMOD(3)=3 594 - GLBMOD(4)=3 595 - IF(STDSTR('INPUT'))THEN 596 - GLBVAL(3)=1 597 - GLBVAL(4)=0 598 - ELSE 599 - GLBVAL(3)=0 600 - GLBVAL(4)=1 601 - ENDIF 602 - GLBVAR(5)='OK ' 603 - GLBMOD(5)=3 604 - GLBVAL(5)=1 605 - GLBVAR(7)='OUTPUT ' 606 - CALL STRBUF('STORE',IREF,'Standard output',15,IFAIL) 607 - GLBMOD(7)=1 608 - GLBVAL(7)=IREF 609 - GLBVAR(8)='X ' 610 - GLBMOD(8)=2 611 - GLBVAL(8)=0 612 - NGLB=8 613 - *** Plotting options for contours. 614 - LKEYPL =.FALSE. 1 30 P=MAIN D=INIT 8 PAGE 23 615-+ +SELF,IF=NAG,IF=PLOT10GKS,GTSGRAL,DECGKS. 616 - LKEYPL =.TRUE. 0 617-+ +SELF. 618 - *** Initial data for the /MAGDAT/ common block. 619 - CALL MAGINT 620 - *** Initial data for the /GASDAT/ common block. 621 - CALL GASINT 0 622-+ +SELF,IF=SIGNAL. 623 - *** Initial data for the /SIGDAT/ common block. 624 - TSTART =0.0 625 - TDEV =0.01 626 - NTIME =MXLIST 627 - RESSET =.FALSE. 628 - PRSTHR =0.0 629 - AVALAN(1)=100000.0 630 - AVALAN(2)=0.001 631 - AVATYP ='NOT SET' 632 - NFOUR =1 633 - LCROSS =.TRUE. 634 - TRASET =.FALSE. 635 - JIORD =1 636 - NISIMP =2 637 - NASIMP =2 638 - NORIA =MIN(50,MXORIA) 639 - FCNANG =' ' 640 - NCANG =0 641 - LITAIL =.TRUE. 642 - LDTAIL =.FALSE. 643 - LRTAIL =.FALSE. 644 - LEPULS =.FALSE. 645 - SIGSET =.FALSE. 646 - * Memory allocation. 647 - CALL BOOK('INITIALISE','MCAMAT',' ',IFAIL) 648 - IF(IFAIL.NE.0)THEN 649 - PRINT *,' ###### INIT ERROR : Unable to declare the'// 650 - - ' avalanche buffer; avalanche calculations may fail.' 651 - ENDIF 0 652-+ +SELF,IF=OPTIMISE. 653 - *** Data for the /OPTDAT/ common block. 654 - NPOINT=20 655 - FUNFLD='V' 656 - NFLD=1 657 - FUNPOS='0' 658 - NPOS=1 659 - FUNWGT='1' 660 - NWGT=1 661 - VALTYP='AVERAGE' 662 - PNTTYP='GRID' 0 663-+ +SELF. 664 - *** Random number initialisation. 665 - IF(LRNDMI)THEN 666 - CALL DATTIM(DATE,TIME) 667 - READ(TIME,'(I2,1X,I2,1X,I2)') IRNDM,JRNDM,KRNDM 668 - DUMMY=0 669 - DO 10 I=1,IRNDM+JRNDM+KRNDM 670 - CALL RANLUX(RVEC,1) 671 - DUMMY=DUMMY+RANFL() 672 - CALL RM48(DVEC,1) 673 - DUMMY=DUMMY+RNDM(I)+RVEC(1) 674 - 10 CONTINUE 675 - IF(LDEBUG)PRINT *,' ++++++ INIT DEBUG : Number of'// 676 - - ' RNDM initialisation calls: ',IRNDM+JRNDM+KRNDM 677 - ELSEIF(LDEBUG)THEN 678 - PRINT *,' ++++++ INIT DEBUG : No random initialisation.' 679 - ENDIF 680 - *** DO loop initialisation. 681 - ISTATE=-2 682 - *** Take care of algebra, graphics, histogram and matrix initialisation. 683 - CALL ALGINT 684 - CALL GRINIT 685 - CALL HISINT 686 - CALL MATINT 687 - *** Command line reading routines initialisation. 688 - CALL INPINT 689 - *** Output the dimensions for front-end programs. 690 - IF(LSYNCH)WRITE(6,'('' >>>>>> set MX3D '',I10/ 691 - - '' >>>>>> set MXALGE '',I10/'' >>>>>> set MXARG '',I10/ 692 - - '' >>>>>> set MXBANG '',I10/'' >>>>>> set MXCHA '',I10/ 693 - - '' >>>>>> set MXCHAR '',I10/'' >>>>>> set MXCLUS '',I10/ 694 - - '' >>>>>> set MXCONS '',I10/'' >>>>>> set MXDLIN '',I10/ 695 - - '' >>>>>> set MXDLVL '',I10/'' >>>>>> set MXEDGE '',I10/ 696 - - '' >>>>>> set MXEMAT '',I10/'' >>>>>> set MXEPS '',I10/ 697 - - '' >>>>>> set MXEPS '',I10/'' >>>>>> set MXEQUT '',I10/ 698 - - '' >>>>>> set MXFOUR '',I10/'' >>>>>> set MXFPAR '',I10/ 699 - - '' >>>>>> set MXFPNT '',I10/'' >>>>>> set MXFRAC '',I10/ 700 - - '' >>>>>> set MXGRID '',I10/'' >>>>>> set MXHIST '',I10/ 701 - - '' >>>>>> set MXHLEV '',I10/'' >>>>>> set MXHLRL '',I10/ 702 - - '' >>>>>> set MXILVL '',I10/'' >>>>>> set MXINCH '',I10/ 703 - - '' >>>>>> set MXINS '',I10/'' >>>>>> set MXLINE '',I10/ 704 - - '' >>>>>> set MXLIST '',I10/'' >>>>>> set MXLIST '',I10/ 705 - - '' >>>>>> set MXLUN '',I10/'' >>>>>> set MXMAP '',I10/ 706 - - '' >>>>>> set MXMAP '',I10/'' >>>>>> set MXMAT '',I10/ 707 - - '' >>>>>> set MXMATT '',I10/'' >>>>>> set MXMATT '',I10/ 708 - - '' >>>>>> set MXMDIM '',I10/'' >>>>>> set MXNAME '',I10/ 709 - - '' >>>>>> set MXORIA '',I10/'' >>>>>> set MXPAIR '',I10/ 710 - - '' >>>>>> set MXPART '',I10/'' >>>>>> set MXPLAN '',I10/ 711 - - '' >>>>>> set MXPOIN '',I10/'' >>>>>> set MXPOLE '',I10/ 712 - - '' >>>>>> set MXRECL '',I10/'' >>>>>> set MXREG '',I10/ 713 - - '' >>>>>> set MXSBUF '',I10/'' >>>>>> set MXSHOT '',I10/ 714 - - '' >>>>>> set MXSOLI '',I10/'' >>>>>> set MXSTCK '',I10/ 715 - - '' >>>>>> set MXSUBT '',I10/'' >>>>>> set MXSW '',I10/ 716 - - '' >>>>>> set MXSW '',I10/'' >>>>>> set MXVAR '',I10/ 1 30 P=MAIN D=INIT 9 PAGE 24 717 - - '' >>>>>> set MXWIRE '',I10/'' >>>>>> set MXWIRE '',I10/ 718 - - '' >>>>>> set MXWKLS '',I10/'' >>>>>> set MXWORD '',I10/ 719 - - '' >>>>>> set MXZERO '',I10/'' >>>>>> set MXZPAR '',I10)') 720 - - MX3D ,MXALGE,MXARG ,MXBANG,MXCHA ,MXCHAR,MXCLUS,MXCONS, 721 - - MXDLIN,MXDLVL,MXEDGE,MXEMAT,MXEPS ,MXEPS ,MXEQUT,MXFOUR, 722 - - MXFPAR,MXFPNT,MXFRAC,MXGRID,MXHIST,MXHLEV,MXHLRL,MXILVL, 723 - - MXINCH,MXINS ,MXLINE,MXLIST,MXLIST,MXLUN ,MXMAP ,MXMAP , 724 - - MXMAT ,MXMATT,MXMATT,MXMDIM,MXNAME,MXORIA,MXPAIR,MXPART, 725 - - MXPLAN,MXPOIN,MXPOLE,MXRECL,MXREG ,MXSBUF,MXSHOT,MXSOLI, 726 - - MXSTCK,MXSUBT,MXSW ,MXSW ,MXVAR ,MXWIRE,MXWIRE,MXWKLS, 727 - - MXWORD,MXZERO,MXZPAR 728 - *** Record the CPU time usage for initialisation. 729 - CALL TIMLOG('Initialisation:') 730 - END 31 GARFIELD ================================================== P=MAIN D=JOBLOGUX 1 ============================ 0 + +DECK,JOBLOGUX,IF=UNIX. 1 - SUBROUTINE JOBLOG(TEXT) 2 - *----------------------------------------------------------------------- 3 - * JOBLOG - This routine writes a log file entry (userid, date & time) 4 - * in /afs/cern.ch/user/r/rjd/Garfield/Log/garfield.log. 5 - * (Last changed on 3/ 7/97.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,PRINTPLOT. 8 - CHARACTER*(*) TEXT 9 - CHARACTER*32 HOST 10 - CHARACTER*8 DATE,TIME,NAME 11 - LOGICAL EXIST 12 - *** Check total length of the string. 13 - IF(LEN(TEXT)+34.GT.132)THEN 14 - PRINT *,' !!!!!! JOBLOG WARNING : Job log information'// 15 - - ' string too long; no entry written.' 16 - RETURN 17 - ENDIF 18 - *** Find out about current date and time + the user name. 19 - CALL DATTIM(DATE,TIME) 0 20-+ +SELF,IF=-IBMRT,IF=-HPUX,IF=-SUN,IF=-LINUX,IF=-DECS. 21 - CALL JOBNAM(NAME) 22 - HOST='Unknown' 0 23-+ +SELF,IF=IBMRT,HPUX,SUN,DECS. 24 - irc=getlog(name) 25 - irc=hostnm(host) 0 26-+ +SELF,IF=LINUX. 27 - NAME='Unknown' 28 - HOST='Linux' 0 29-+ +SELF. 30 - *** Find the length of the strings. 31 - DO 10 I=LEN(NAME),1,-1 32 - IF(NAME(I:I).NE.' ')THEN 33 - NCNAME=I 34 - GOTO 20 35 - ENDIF 36 - 10 CONTINUE 37 - NCNAME=1 38 - 20 CONTINUE 39 - DO 30 I=LEN(HOST),1,-1 40 - IF(HOST(I:I).NE.' ')THEN 41 - NCHOST=I 42 - GOTO 40 43 - ENDIF 44 - 30 CONTINUE 45 - NCHOST=1 46 - 40 CONTINUE 47 - *** Open the log file. 48 - INQUIRE(EXIST=EXIST, 49 - - FILE='/afs/cern.ch/user/r/rjd/Garfield/Log/garfield.log') 50 - OPEN(UNIT=12,STATUS='UNKNOWN',ACCESS='SEQUENTIAL', 51 - - FILE='/afs/cern.ch/user/r/rjd/Garfield/Log/garfield.log', 52 - - IOSTAT=IOS,ERR=2020) 53 - *** Skip to the end of the file if the file is not new. 54 - IF(EXIST)THEN 55 - 100 CONTINUE 56 - READ(12,'(A1)',END=110,IOSTAT=IOS,ERR=2010) STRING 57 - GOTO 100 58 - 110 CONTINUE 59 - BACKSPACE(UNIT=12,IOSTAT=IOS,ERR=2040) 60 - ENDIF 61 - *** Open a file and write the entry in it. 62 - WRITE(12,'(A,'' on '',A8,'' at '',A8,2X,A)',ERR=2010) 63 - - NAME(1:NCNAME)//'@'//HOST(1:NCHOST),DATE,TIME,TEXT 64 - CLOSE(UNIT=12,ERR=2030) 65 - *** Log its usage so the user can in principle know what happened. 66 - CALL DSNLOG('garfield.log','Log file ','Sequential', 67 - - 'Append ') 68 - *** Normal end of this routine. 69 - RETURN 70 - *** I/O error handling. 71 - 2010 CONTINUE 72 - IF(LDEBUG)WRITE(LUNOUT,'(1X,A)') ' ++++++ JOBLOG DEBUG :'// 73 - - ' I/O error occurred while reading or writing the log file.' 74 - IF(LDEBUG)CALL INPIOS(IOS) 75 - CLOSE(UNIT=12,ERR=2030,IOSTAT=IOS) 76 - RETURN 77 - 2020 CONTINUE 78 - IF(LDEBUG)WRITE(LUNOUT,'(1X,A)') ' ++++++ JOBLOG DEBUG :'// 79 - - ' An error occurred while opening the log file.' 80 - IF(LDEBUG)CALL INPIOS(IOS) 81 - RETURN 82 - 2030 CONTINUE 83 - IF(LDEBUG)WRITE(LUNOUT,'(1X,A)') ' ++++++ JOBLOG DEBUG :'// 84 - - ' An error occurred while closing the log file.' 1 31 P=MAIN D=JOBLOGUX 2 PAGE 25 85 - IF(LDEBUG)CALL INPIOS(IOS) 86 - 2040 CONTINUE 87 - END 32 GARFIELD ================================================== P=MAIN D=JOBLOGCD 1 ============================ 0 + +DECK,JOBLOGCD,IF=CDC. 1 - SUBROUTINE JOBLOG(TEXT) 2 - *----------------------------------------------------------------------- 3 - * JOBLOG - This routine writes an entry in a log file (userid, time). 4 - *----------------------------------------------------------------------- 5 - CHARACTER*(*) TEXT 6 - END 33 GARFIELD ================================================== P=MAIN D=JOBLOGVM 1 ============================ 0 + +DECK,JOBLOGVM,IF=CMS. 1 - SUBROUTINE JOBLOG(TEXT) 2 - *----------------------------------------------------------------------- 3 - * JOBLOG - This routine send a log file entry (userid, date and time) 4 - * to RJD@CERNVM. Routine to be used in debugging periods. 5 - *----------------------------------------------------------------------- 6 - CHARACTER*(*) TEXT 7 - CHARACTER*8 DATE,TIME,NAME 8 - *** Check total length of the string. 9 - IF(LEN(TEXT)+34.GT.132)THEN 10 - PRINT *,' !!!!!! JOBLOG WARNING : Job log information'// 11 - - ' string too long; no entry written.' 12 - RETURN 13 - ENDIF 14 - *** Find out about current date and time + the user name. 15 - CALL DATTIM(DATE,TIME) 16 - CALL JOBNAM(NAME) 17 - *** Open a file and write the entry in it. 18 - CALL VMCMS('FILEDEF JOBLOG DISK GARFIELD JOBLOG (LRECL 132',IRC) 19 - OPEN(UNIT=12,FILE='JOBLOG') 20 - WRITE(12,'(A8,'' on '',A8,'' at '',A8,2X,A)') NAME,DATE,TIME,TEXT 21 - CLOSE(UNIT=12) 22 - *** Send the file off and then destroy it. 23 - CALL VMCMS('EXEC SENDFILE GARFIELD JOBLOG A TO RJD AT CERNVM'// 24 - - ' (NOTYPE NOLOG NOACK',IRC) 25 - CALL VMCMS('ERASE GARFIELD JOBLOG A',IRC) 26 - *** Log its usage so the user can in principle know what happened. 27 - CALL DSNLOG('GARFIELD JOBLOG A','Log file ','Sequential', 28 - - 'C/R/W/S/D ') 29 - END 34 GARFIELD ================================================== P=MAIN D=JOBLOGMV 1 ============================ 0 + +DECK,JOBLOGMV,IF=MVS. 1 - SUBROUTINE JOBLOG(TEXT) 2 - *----------------------------------------------------------------------- 3 - * JOBLOG - This routine writes an entry in a log file (userid, time). 4 - *----------------------------------------------------------------------- 5 - CHARACTER*(*) TEXT 6 - CHARACTER*8 DATE,TIME,NAME 7 - LOGICAL EXIS 8 - *** Check that the file exists, if not create one implicitly. 9 - INQUIRE(FILE='V8.RJD.DRIFTLOG',EXIST=EXIS) 10 - OPEN(UNIT=12,FILE='V8.RJD.DRIFTLOG',STATUS='UNKNOWN') 11 - IF(.NOT.EXIS)GOTO 30 12 - *** Skipt to the EOF, backspace once to position the pointer correctly. 13 - 10 CONTINUE 14 - READ(12,'()',END=20) 15 - GOTO 10 16 - 20 CONTINUE 17 - BACKSPACE(UNIT=12) 18 - *** Ask userid, date and time and write the new entry. 19 - 30 CONTINUE 20 - CALL JOBNAM(NAME) 21 - CALL DATTIM(DATE,TIME) 22 - WRITE(12,'(A8,'' on '',A8,'' at '',A8,2X,A)') NAME,DATE,TIME,TEXT 23 - CLOSE(UNIT=12) 24 - END 35 GARFIELD ================================================== P=MAIN D=JOBLOGVX 1 ============================ 0 + +DECK,JOBLOGVX,IF=VAX. 1 - SUBROUTINE JOBLOG(TEXT) 2 - *----------------------------------------------------------------------- 3 - * JOBLOG - This routine writes an entry in a log file (userid, time). 4 - *----------------------------------------------------------------------- 5.- +SEQ,PRINTPLOT. 6 - CHARACTER*(*) TEXT 7 - CHARACTER*8 DATE,TIME 8 - CHARACTER*32 NAME 9 - *** Pick up the Job Process Information definition file. 10 - INCLUDE '($JPIDEF)' 11 - *** Open the file with APPEND access. 12 - OPEN(UNIT=12,FILE='DISK$GARFIELD:GARFIELD.LOG',STATUS='UNKNOWN', 13 - - ACCESS='APPEND',ERR=2020,IOSTAT=IOS) 14 - *** Ask userid, date and time and write the new entry. 15 - ISTAT=LIB$GETJPI(%REF(JPI$_USERNAME),,,,NAME,LENGTH) 16 - IF(ISTAT.EQ.2*NINT(ISTAT/2.0))THEN 17 - NAME='?' 18 - LENGTH=1 19 - ELSE 20 - DO I=LENGTH,1,-1 21 - IF(NAME(I:I).NE.' ')THEN 22 - N=I 23 - GOTO 10 24 - ENDIF 25 - N=1 26 - ENDDO 27 - 10 CONTINUE 28 - LENGTH=N 1 35 P=MAIN D=JOBLOGVX 2 PAGE 26 29 - ENDIF 30 - CALL DATTIM(DATE,TIME) 31 - WRITE(12,'(A,'' on '',A8,'' at '',A8,2X,A)',ERR=2010,IOSTAT=IOS) 32 - - NAME(1:LENGTH),DATE,TIME,TEXT 33 - CLOSE(UNIT=12,ERR=2030,IOSTAT=IOS) 34 - RETURN 35 - *** I/O errors, ignore unless debugging mode is on. 36 - 2010 CONTINUE 37 - IF(LDEBUG)WRITE(LUNOUT,'(1X,A)') ' ++++++ JOBLOG DEBUG :'// 38 - - ' An I/O error occurred while writing the log entry.' 39 - IF(LDEBUG)CALL INPIOS(IOS) 40 - CLOSE(UNIT=12,ERR=2030,IOSTAT=IOS) 41 - RETURN 42 - 2020 CONTINUE 43 - IF(LDEBUG)WRITE(LUNOUT,'(1X,A)') ' ++++++ JOBLOG DEBUG :'// 44 - - ' An error occurred while opening the log file.' 45 - IF(LDEBUG)CALL INPIOS(IOS) 46 - RETURN 47 - 2030 CONTINUE 48 - IF(LDEBUG)WRITE(LUNOUT,'(1X,A)') ' ++++++ JOBLOG DEBUG :'// 49 - - ' An error occurred while closing the log file.' 50 - IF(LDEBUG)CALL INPIOS(IOS) 51 - END 36 GARFIELD ================================================== P=MAIN D=QUIT 1 ============================ 0 + +DECK,QUIT. 1 - SUBROUTINE QUIT 2 - *----------------------------------------------------------------------- 3 - * QUIT - This routines calls some routines that print information 4 - * collected during the run and closes in batch mode the 5 - * display file. 6 - * (Last changed on 9/ 1/97.) 7 - *----------------------------------------------------------------------- 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,GRAPHICS. 11 - LOGICAL OPEN 12 - CHARACTER*20 OPSTR 13 - *** Switch to graphics mode. 14 - CALL GRGRAF(.TRUE.) 15 - *** Keep track of statistics, inquiry errors. 16 - IERSUM=0 17 - NOP=0 18 - NOP0=0 19 - NACT=0 20 - NACT0=0 21 - *** Determine Operating State value. 22 - CALL GQOPS(IOPSTA) 23 - *** Close current segment if open. 24 - IF(IOPSTA.EQ.4)CALL GCLSG 25 - *** Deactivate all active workstations, if appropriate. 26 - IF(IOPSTA.GE.3)THEN 27 - * Get number of open workstations. 28 - CALL GQACWK(0,IERR,NACT,IWK) 29 - IF(IERR.NE.0)IERSUM=IERSUM+1 30 - * Loop over the open workstations. 31 - DO 10 I=NACT,1,-1 32 - CALL GQACWK(I,IERR,IDUM,IWK) 33 - IF(IERR.NE.0)IERSUM=IERSUM+1 34 - CALL GDAWK(IWK) 35 - WKSTAT(IWK)=2 0 36-+ +SELF,IF=HIGZ. 37 - CALL SGFLAG 0 38-+ +SELF. 39 - 10 CONTINUE 40 - * Count the number of still active workstations. 41 - NACT0=NACT 42 - CALL GQACWK(0,IERR,NACT,IWK) 43 - IF(IERR.NE.0)IERSUM=IERSUM+1 44 - ENDIF 45 - *** Close all open workstations. 46 - IF(IOPSTA.GE.2)THEN 47 - * Get number of active workstations. 48 - CALL GQOPWK(0,IERR,NOP,IWK) 49 - IF(IERR.NE.0)IERSUM=IERSUM+1 50 - * Loop over the active workstations. 51 - DO 20 I=NOP,1,-1 52 - * Get workstation identifier. 53 - CALL GQOPWK(I,IERR,IDUM,IWK) 54 - IF(IERR.NE.0)IERSUM=IERSUM+1 55 - * Close the workstation. 56 - CALL GCLWK(IWK) 57 - WKSTAT(IWK)=1 58 - * Check whether there is a file. 59 - IF(WKLUN(IWK).GT.0)THEN 60 - CLOSE(UNIT=WKLUN(IWK),STATUS='KEEP', 61 - - ERR=2034,IOSTAT=IOS) 62 - GOTO 90 63 - 2034 CONTINUE 64 - CALL INPIOS(IOS) 65 - PRINT *,' !!!!!! QUIT WARNING : Error closing'// 66 - - ' file associated to workstation ',IWK,'.' 67 - 90 CONTINUE 68 - ENDIF 69 - 20 CONTINUE 70 - * Count the number of still active workstations. 71 - NOP0=NOP 72 - CALL GQOPWK(0,IERR,NOP,IWK) 73 - IF(IERR.NE.0)IERSUM=IERSUM+1 74 - ENDIF 75 - *** And print error messages if any. 76 - IF(NACT.NE.0)PRINT *,' !!!!!! QUIT WARNING : Unable to'// 77 - - ' deactivate all workstations.' 1 36 P=MAIN D=QUIT 2 PAGE 27 78 - IF(NOP.NE.0)PRINT *,' !!!!!! QUIT WARNING : Unable to'// 79 - - ' close all workstations.' 80 - IF(IERSUM.NE.0)PRINT *,' !!!!!! QUIT WARNING : Number of'// 81 - - ' inquiry errors during GKS close-down: ',IERSUM 82 - *** Print statistics if requested. 83 - IF(LDEBUG)THEN 84 - OPSTR='< unknown code >' 85 - IF(IOPSTA.EQ.0)OPSTR='GKS closed' 86 - IF(IOPSTA.EQ.1)OPSTR='GKS open' 87 - IF(IOPSTA.EQ.2)OPSTR='workstation open' 88 - IF(IOPSTA.EQ.3)OPSTR='workstation active' 89 - IF(IOPSTA.EQ.4)OPSTR='segment open' 90 - WRITE(LUNOUT,'(2X,''++++++ QUIT DEBUG : '', 91 - - ''GKS state was '',A20/26X, 92 - - ''Active workstations: '',I3,'' (was '',I3,'')''/26X, 93 - - ''Open workstations: '',I3,'' (was '',I3,'')''/26X, 94 - - ''Inquiry errors: '',I3)') 95 - - OPSTR,NACT,NACT0,NOP,NOP0,IERSUM 96 - ENDIF 0 97-+ +SELF,IF=HIGZ. 98 - *** Close HIGZ. 99 - CALL IGTERM 100 - CALL IGEND 0 101-+ +SELF,IF=-HIGZ. 102 - *** Close GKS itself. 103 - IF(IOPSTA.GE.1)CALL GCLKS 0 104-+ +SELF. 105 - *** Close the GKS log file. 106 - INQUIRE(UNIT=10,OPENED=OPEN) 107 - IF(OPEN)CLOSE(UNIT=10,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 108 - GOTO 50 109 - * Error handling. 110 - 2030 CONTINUE 111 - CALL INPIOS(IOS) 112 - PRINT *,' !!!!!! QUIT WARNING : Error closing the'// 113 - - ' GKS error logging file during program termination.' 114 - 50 CONTINUE 115 - *** Close the main metafiles. 116 - INQUIRE(UNIT=11,OPENED=OPEN) 117 - IF(OPEN)THEN 118 - PRINT *,' !!!!!! QUIT WARNING : Found a metafile'// 119 - - ' left open on unit 11; closing the file.' 120 - CLOSE(UNIT=11,STATUS='KEEP',ERR=2031,IOSTAT=IOS) 121 - ENDIF 122 - GOTO 60 123 - * Error handling. 124 - 2031 CONTINUE 125 - CALL INPIOS(IOS) 126 - PRINT *,' !!!!!! QUIT WARNING : Error closing a'// 127 - - ' graphics metafile during program termination.' 128 - 60 CONTINUE 129 - *** Close additional metafiles, there shouldn't be any. 130 - DO 30 I=40,49 131 - INQUIRE(UNIT=I,OPENED=OPEN) 132 - IF(OPEN)THEN 133 - PRINT *,' !!!!!! QUIT WARNING : Found a metafile'// 134 - - ' left open on unit ',I,'; closing the file.' 135 - CLOSE(UNIT=I,STATUS='KEEP',ERR=2032,IOSTAT=IOS) 136 - ENDIF 137 - GOTO 30 138 - * Error handling. 139 - 2032 CONTINUE 140 - CALL INPIOS(IOS) 141 - PRINT *,' !!!!!! QUIT WARNING : Error closing a'// 142 - - ' graphics metafile during program termination.' 143 - 30 CONTINUE 144 - *** Close the recording file. 145 - INQUIRE(UNIT=18,OPENED=OPEN) 146 - IF(OPEN)CLOSE(UNIT=18,STATUS='KEEP',ERR=2033,IOSTAT=IOS) 147 - GOTO 70 148 - * Error handling. 149 - 2033 CONTINUE 150 - CALL INPIOS(IOS) 151 - PRINT *,' !!!!!! QUIT WARNING : Error closing the'// 152 - - ' input recording file during program termination.' 153 - 70 CONTINUE 154 - *** Print the graphics, dataset and timing log. 155 - CALL GRAPRT 156 - CALL DSNPRT 157 - CALL TIMLOG(' ') 158 - *** List objects still in memory. 159 - IF(LDEBUG)THEN 160 - PRINT *,' ++++++ QUIT DEBUG : Histograms ...' 161 - CALL HISADM('LIST',IREF,0,0.0,0.0,.TRUE.,IFAIL) 162 - PRINT *,' ++++++ QUIT DEBUG : Matrices ...' 163 - CALL MATADM('LIST',IDUM,NDUM,NDUM,NDUM,IFAIL1) 164 - PRINT *,' ++++++ QUIT DEBUG : Booked objects ...' 165 - CALL BOOK('LIST',' ',' ',IFAIL) 166 - PRINT *,' ++++++ QUIT DEBUG : Strings ...' 167 - CALL STRBUF('DUMP',IREF,' ',1,IFAIL) 168 - ENDIF 0 169-+ +SELF,IF=AST. 170 - *** Stop AST handling 171 - CALL ASTXIT 0 172-+ +SELF. 173 - *** Inform synchronisation. 174 - IF(LSYNCH)WRITE(6,'('' >>>>>> quit'')') 175 - *** And stop program execution. 176 - STOP 177 - END 1 37 GARFIELD ================================================== P=MAIN D=SKIP 1 =================== PAGE 28 0 + +DECK,SKIP. 1 - SUBROUTINE SKIP 2 - *----------------------------------------------------------------------- 3 - * SKIP - This routine places the pointer of the input file at the 4 - * next header. 5 - * (Last changed on 29/10/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*(MXINCH) STRING 11 - INTEGER NC,NWORD 12 - LOGICAL STDSTR 13 - EXTERNAL STDSTR 14 - *** Set the prompt string. 15 - CALL INPPRM('Main','NEW-PRINT') 16 - *** The program is running in batch. 17 - IF(.NOT.STDSTR('INPUT'))THEN 18 - PRINT *,' ------ SKIP MESSAGE : The following section'// 19 - - ' is skipped.' 20 - * Print the current line if the INPUT option is off. 21 - IF(.NOT.LINPUT)THEN 22 - CALL INPNUM(NWORD) 23 - CALL INPSTR(1,NWORD,STRING,NC) 24 - PRINT *,' ====== SKIP INPUT : '// 25 - - STRING(1:MAX(1,NC)) 26 - ENDIF 27 - * Read a new input line, skip until a new header is found. 28 - 10 CONTINUE 29 - CALL INPWRD(NWORD) 30 - IF(NWORD.EQ.0)GOTO 10 31 - CALL INPSTR(1,NWORD,STRING,NC) 32 - IF(STRING(1:1).NE.'&')THEN 33 - IF(.NOT.LINPUT)PRINT *,' ====== SKIP INPUT : '// 34 - - STRING(1:MAX(1,NC)) 35 - GOTO 10 36 - ENDIF 37 - * The pointer should now be at the right position. 38 - PRINT *,' ------ SKIP MESSAGE : End of skipped input.' 39 - *** The program is running in an interactive environment. 40 - ELSE 41 - PRINT *,' !!!!!! SKIP WARNING : The section header'// 42 - - ' was rejected ; please try again.' 43 - 20 CONTINUE 44 - CALL INPWRD(NWORD) 45 - IF(NWORD.EQ.0)GOTO 20 46 - CALL INPSTR(1,NWORD,STRING,NC) 47 - IF(STRING(1:1).NE.'&')THEN 48 - IF(.NOT.LINPUT)PRINT *,' ====== SKIP INPUT : '// 49 - - STRING(1:MAX(1,NC)) 50 - PRINT *,' !!!!!! SKIP WARNING : Please enter'// 51 - - ' a section header or a global command.' 52 - GOTO 20 53 - ENDIF 54 - ENDIF 55 - END 38 GARFIELD ================================================== P=INPUT D= 1 ============================ 0 + +PATCH,INPUT. 39 GARFIELD ================================================== P=INPUT D=INPCAL 1 ============================ 0 + +DECK,INPCAL. 1 - SUBROUTINE INPCAL(MODE,IENTRY,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * INPCAL - Handles CALL statements in normal input. 4 - * (Last changed on 5/ 1/01.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GLOBALS. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,INPUT. 11.- +SEQ,ALGDATA. 12 - CHARACTER*(*) MODE 13 - LOGICAL USE(MXVAR),SQUOTE,DQUOTE,RQUOTE 14 - REAL RES(1) 15 - INTEGER MODRES(1),IENTRY,IFAIL,IFAIL1,ICALL,I,J,II,JJ,NLEV, 16 - - ISTART,IEND,I0,I1,I2,KARG,NNRES,IPROC,IENTNO,IFIRST,ILAST 17 - *** First few returns are all on IFAIL=1. 18 - IFAIL=1 19 - *** Don't do anything if there is just 1 word. 20 - IF(NWORD.LE.1)THEN 21 - PRINT *,' !!!!!! INPCAL WARNING : CALL must be followed'// 22 - - ' by at least a routine name; ignored.' 23 - RETURN 24 - ENDIF 25 - *** Search for delimiters, initial values. 26 - ISTART=0 27 - IEND=0 28 - * Opening parenthesis. 29 - ICALL=INDEX(STRING,'CALL') 30 - DO 10 I=ICALL+4,MXINCH 31 - IF(STRING(I:I).EQ.'(')THEN 32 - ISTART=I+1 33 - SQUOTE=.FALSE. 34 - DQUOTE=.FALSE. 35 - RQUOTE=.FALSE. 36 - NLEV=1 37 - * Closing parenthesis. 38 - DO 30 J=ISTART,MXINCH 39 - IF(STRING(J:J).EQ.'(')THEN 40 - IF(.NOT.(SQUOTE.OR.DQUOTE.OR.RQUOTE))NLEV=NLEV+1 41 - ELSEIF(STRING(J:J).EQ.')')THEN 42 - IF(.NOT.(SQUOTE.OR.DQUOTE.OR.RQUOTE))NLEV=NLEV-1 1 39 P=INPUT D=INPCAL 2 PAGE 29 43 - ELSEIF(STRING(J:J).EQ.'''')THEN 44 - SQUOTE=.NOT.SQUOTE 45 - ELSEIF(STRING(J:J).EQ.'"')THEN 46 - DQUOTE=.NOT.DQUOTE 47 - ELSEIF(STRING(J:J).EQ.'`')THEN 48 - RQUOTE=.NOT.RQUOTE 49 - ENDIF 50 - IF(NLEV.EQ.0)THEN 51 - IEND=J-1 52 - IF(STRING(J:).NE.')')PRINT *,' !!!!!! INPCAL WARNING'// 53 - - ' : Extra characters after the closing'// 54 - - ' parenthesis are ignored.' 55 - GOTO 20 56 - ENDIF 57 - 30 CONTINUE 58 - GOTO 20 59 - ENDIF 60 - 10 CONTINUE 61 - 20 CONTINUE 62 - * Check syntax. 63 - IF((ISTART.EQ.0.AND.IEND.NE.0).OR. 64 - - (IEND.EQ.0.AND.ISTART.NE.0))THEN 65 - PRINT *,' !!!!!! INPCAL WARNING : The arguments of the'// 66 - - ' CALL statement are not' 67 - PRINT *,' properly delimited'// 68 - - ' ; statement is ignored.' 69 - RETURN 70 - ELSEIF(ISTART.EQ.0.AND.IEND.EQ.0.OR.ISTART.GT.IEND)THEN 71 - ISTART=0 72 - IEND=0 73 - GOTO 130 74 - ELSEIF(STRING(ISTART:IEND).EQ.' ')THEN 75 - ISTART=0 76 - IEND=0 77 - GOTO 130 78 - ENDIF 79 - *** Locate undeclared global variable arguments. 80 - I0=ISTART-1 81 - KARG=0 82 - * Find the beginning of the word. 83 - 100 CONTINUE 84 - I0=I0+1 85 - IF(I0.GT.IEND)THEN 86 - PRINT *,' !!!!!! INPCAL WARNING : No argument found after'// 87 - - ' last delimiter.' 88 - GOTO 130 89 - ENDIF 90 - IF(STRING(I0:I0).EQ.' ')GOTO 100 91 - * First non-blank character a , ? 92 - IF(STRING(I0:I0).EQ.',')THEN 93 - PRINT *,' !!!!!! INPCAL WARNING : No argument found'// 94 - - ' between 2 delimiters.' 95 - GOTO 100 96 - ENDIF 97 - * Find the end of the word. 98 - I2=I0-1 99 - 110 CONTINUE 100 - I2=I2+1 101 - IF(STRING(I2:I2).EQ.',')THEN 102 - I2=I2-1 103 - ELSEIF(I2.LT.IEND)THEN 104 - GOTO 110 105 - ENDIF 106 - * And remove trailing blanks. 107 - I1=I2+1 108 - 120 CONTINUE 109 - I1=I1-1 110 - IF(I1.LT.I0)THEN 111 - PRINT *,' !!!!!! INPCAL WARNING : Argument string ',KARG+1, 112 - - ' is entirely blank.' 113 - ELSEIF(STRING(I1:I1).EQ.' ')THEN 114 - GOTO 120 115 - ENDIF 116 - * See whether this is a valid variable name. 117 - IF(I1.GE.I0)THEN 118 - KARG=KARG+1 119 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPCAL DEBUG :'', 120 - - '' Argument '',I3,'': '',A)') KARG,STRING(I0:I1) 121 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ', 122 - - STRING(I0:I0)).EQ.0.OR. 123 - - STRING(I0:I1).EQ.'PI'.OR. 124 - - STRING(I0:I1).EQ.'FALSE'.OR. 125 - - STRING(I0:I1).EQ.'TRUE'.OR. 126 - - STRING(I0:I1).EQ.'RND_UNIFORM'.OR. 127 - - STRING(I0:I1).EQ.'RND_GAUSS'.OR. 128 - - STRING(I0:I1).EQ.'RND_NORMAL'.OR. 129 - - STRING(I0:I1).EQ.'RND_EXP'.OR. 130 - - STRING(I0:I1).EQ.'RND_EXPONENTIAL'.OR. 131 - - STRING(I0:I1).EQ.'RND_POISSON'.OR. 132 - - STRING(I0:I1).EQ.'RND_POLYA'.OR. 133 - - STRING(I0:I1).EQ.'RND_LANDAU'.OR. 134 - - STRING(I0:I1).EQ.'RND_FUNCTION')GOTO 150 135 - DO 140 II=I0+1,I1 136 - IF(INDEX('+-*/&|<=#>^ ,.:;([{)]}''"`',STRING(II:II)).NE.0) 137 - - GOTO 150 138 - 140 CONTINUE 139 - DO 160 JJ=1,NGLB 140 - IF(GLBVAR(JJ).EQ.STRING(I0:I1))GOTO 150 141 - 160 CONTINUE 142 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Is an undeclared global.'')') 143 - IF(NGLB.LT.MXVAR)THEN 144 - NGLB=NGLB+1 145 - GLBVAR(NGLB)=STRING(I0:I1) 146 - GLBVAL(NGLB)=0 147 - GLBMOD(NGLB)=0 148 - IF(I1-I0+1.GT.LEN(GLBVAR(NGLB)))THEN 1 39 P=INPUT D=INPCAL 3 PAGE 30 149 - PRINT *,' !!!!!! INPCAL WARNING : '// 150 - - STRING(I0:I1)//' is too long for a'// 151 - - ' variable name; has been truncated.' 152 - ELSE 153 - WRITE(LUNOUT,'('' ------ INPCAL MESSAGE : '',A, 154 - - '' declared as a global variable.'')') 155 - - STRING(I0:I1) 156 - ENDIF 157 - ELSE 158 - PRINT *,' !!!!!! INPCAL WARNING : No room left to', 159 - - ' store ',STRING(I0:I1),' as a global variable.' 160 - RETURN 161 - ENDIF 162 - 150 CONTINUE 163 - ENDIF 164 - * Next element. 165 - I0=I2+1 166 - IF(I0.LE.IEND)GOTO 100 167 - * Finished. 168 - 130 CONTINUE 169 - *** Pass the argument on to ALGPRE to build an instruction list. 170 - IF(ISTART.EQ.0.AND.IEND.EQ.0)THEN 171 - CALL ALGPRE('1',1,GLBVAR,NGLB,NNRES,USE,IENTRY,IFAIL1) 172 - ELSE 173 - CALL ALGPRE(STRING(ISTART:IEND),IEND-ISTART+1, 174 - - GLBVAR,NGLB,NNRES,USE,IENTRY,IFAIL1) 175 - ENDIF 176 - IF(IFAIL1.NE.0)THEN 177 - PRINT *,' !!!!!! INPCAL WARNING : The arguments of the'// 178 - - ' CALL statement can' 179 - PRINT *,' not be translated ;'// 180 - - ' statement is ignored.' 181 - IF(MODE.EQ.'EXECUTE')CALL ALGCLR(IENTRY) 182 - RETURN 183 - ENDIF 184 - * Locate the entry point number. 185 - IENTNO=0 186 - DO 80 I=1,NALGE 187 - IF(ALGENT(I,1).EQ.IENTRY)IENTNO=I 188 - 80 CONTINUE 189 - IF(IENTNO.EQ.0)THEN 190 - PRINT *,' !!!!!! INPCAL WARNING : Unable to find the'// 191 - - ' entry point; program bug.' 192 - IF(MODE.EQ.'EXECUTE')CALL ALGCLR(IENTRY) 193 - RETURN 194 - ENDIF 195 - *** Scan the instruction list, change RESULT into ARGUMENT. 196 - DO 50 I=ALGENT(IENTNO,5),ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 197 - IF(INS(I,2).NE.0)GOTO 50 198 - IF(INS(I,3).LE.NGLB.AND.INS(I,3).GT.0)THEN 199 - INS(I,1)=0 200 - ELSE 201 - INS(I,1)=2 202 - ENDIF 203 - INS(I,2)=8 204 - 50 CONTINUE 205 - *** Locate the routine name, first isolate the name. 206 - IFIRST=0 207 - ILAST=NCHAR(2) 208 - DO 60 I=1,NCHAR(2) 209 - IF(IFIRST.EQ.0.AND.WORD(2)(I:I).NE.' ')IFIRST=I 210 - IF(WORD(2)(I:I).EQ.' '.OR.WORD(2)(I:I).EQ.'(')THEN 211 - ILAST=I-1 212 - GOTO 70 213 - ENDIF 214 - 60 CONTINUE 215 - 70 CONTINUE 216 - *** Check it is not blank. 217 - IF(IFIRST.EQ.0.OR.ILAST.LT.IFIRST)THEN 218 - PRINT *,' !!!!!! INPCAL WARNING : The routine name is'// 219 - - ' blank or null; CALL ignored.' 220 - IF(MODE.EQ.'EXECUTE')CALL ALGCLR(IENTRY) 221 - RETURN 222 - ENDIF 223 - *** Identify, first general purpose printing. 224 - IF(WORD(2)(IFIRST:ILAST).EQ.'PRINT')THEN 225 - IPROC=-1 226 - * Cell related calls. 227 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_CELL_DATA')THEN 228 - IPROC=-11 229 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_CELL_SIZE')THEN 230 - IPROC=-12 231 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_WIRE'.OR. 232 - - WORD(2)(IFIRST:ILAST).EQ.'GET_WIRE_DATA')THEN 233 - IPROC=-13 234 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_X_PLANES')THEN 235 - IPROC=-14 236 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_Y_PLANES')THEN 237 - IPROC=-15 238 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_PERIODS')THEN 239 - IPROC=-16 240 - * String manipulation. 241 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_INDEX')THEN 242 - IPROC=-901 243 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_PORTION')THEN 244 - IPROC=-902 245 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_DELETE')THEN 246 - IPROC=-903 247 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_LOWER')THEN 248 - IPROC=-904 249 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_UPPER')THEN 250 - IPROC=-905 251 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_WORDS')THEN 252 - IPROC=-906 253 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_WORD')THEN 254 - IPROC=-907 1 39 P=INPUT D=INPCAL 4 PAGE 31 255 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_MATCH')THEN 256 - IPROC=-908 257 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_REPLACE')THEN 258 - IPROC=-909 259 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_LISTING'.OR. 260 - - WORD(2)(IFIRST:ILAST).EQ.'STRING_LIST'.OR. 261 - - WORD(2)(IFIRST:ILAST).EQ.'LIST_STRINGS'.OR. 262 - - WORD(2)(IFIRST:ILAST).EQ.'LIST_STRING'.OR. 263 - - WORD(2)(IFIRST:ILAST).EQ.'SLIST')THEN 264 - IPROC=-910 265 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_LENGTH')THEN 266 - IPROC=-911 267 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DELETE_STRING'.OR. 268 - - WORD(2)(IFIRST:ILAST).EQ.'DELETE_STRINGS')THEN 269 - IPROC=-912 270 - * File handling. 271 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INQUIRE_TYPE'.OR. 272 - - WORD(2)(IFIRST:ILAST).EQ.'QTYPE')THEN 273 - IPROC=-50 274 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INQUIRE_FILE'.OR. 275 - - WORD(2)(IFIRST:ILAST).EQ.'QFILE')THEN 276 - IPROC=-51 277 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INQUIRE_MEMBER'.OR. 278 - - WORD(2)(IFIRST:ILAST).EQ.'QMEMBER')THEN 279 - IPROC=-52 280 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'OBJECT_LISTING'.OR. 281 - - WORD(2)(IFIRST:ILAST).EQ.'LIST_OBJECTS'.OR. 282 - - WORD(2)(IFIRST:ILAST).EQ.'LIST_OBJECT'.OR. 283 - - WORD(2)(IFIRST:ILAST).EQ.'OLIST')THEN 284 - IPROC=-53 285 - * Fitting. 286 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'FIT_GAUSSIAN')THEN 287 - IPROC=-60 288 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'FIT_POLYNOMIAL')THEN 289 - IPROC=-61 290 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'FIT_EXPONENTIAL')THEN 291 - IPROC=-62 292 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'FIT_POLYA')THEN 293 - IPROC=-63 294 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'FIT_FUNCTION')THEN 295 - IPROC=-64 296 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'FIT_MATHIESON')THEN 297 - IPROC=-65 298 - * Signal related calls. 299 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'THRESHOLD_CROSSING')THEN 300 - IPROC=-70 301 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_SIGNAL')THEN 302 - IPROC=-71 303 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STORE_SIGNAL')THEN 304 - IPROC=-72 305 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_RAW_SIGNAL')THEN 306 - IPROC=-73 307 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'LIST_RAW_SIGNALS')THEN 308 - IPROC=-74 309 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'SIGNAL_FIELD'.OR. 310 - - WORD(2)(IFIRST:ILAST).EQ.'WEIGHTING_FIELD')THEN 311 - IPROC=-75 312 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'SIGNAL_FIELD_3'.OR. 313 - - WORD(2)(IFIRST:ILAST).EQ.'WEIGHTING_FIELD_3')THEN 314 - IPROC=-76 315 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INDUCED_CHARGE'.OR. 316 - - WORD(2)(IFIRST:ILAST).EQ.'QIN')THEN 317 - IPROC=-77 318 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ADD_SIGNAL'.OR. 319 - - WORD(2)(IFIRST:ILAST).EQ.'ADD_SIGNALS')THEN 320 - IPROC=-78 321 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'AVALANCHE_SIGNAL')THEN 322 - IPROC=-79 323 - * Matrix procedures. 324 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'EXTRACT_SUBMATRIX')THEN 325 - IPROC=-80 326 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STORE_SUBMATRIX')THEN 327 - IPROC=-81 328 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PRINT_MATRIX'.OR. 329 - - WORD(2)(IFIRST:ILAST).EQ.'PRINT_MATRICES'.OR. 330 - - WORD(2)(IFIRST:ILAST).EQ.'MPRINT')THEN 331 - IPROC=-82 332 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'BOOK_MATRIX'.OR. 333 - - WORD(2)(IFIRST:ILAST).EQ.'MBOOK')THEN 334 - IPROC=-83 335 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'RESHAPE_MATRIX')THEN 336 - IPROC=-84 337 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ADJUST_MATRIX')THEN 338 - IPROC=-85 339 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DELETE_MATRIX'.OR. 340 - - WORD(2)(IFIRST:ILAST).EQ.'DELETE_MATRICES'.OR. 341 - - WORD(2)(IFIRST:ILAST).EQ.'MDELETE')THEN 342 - IPROC=-86 343 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'LIST_MATRIX'.OR. 344 - - WORD(2)(IFIRST:ILAST).EQ.'LIST_MATRICES'.OR. 345 - - WORD(2)(IFIRST:ILAST).EQ.'MLIST')THEN 346 - IPROC=-87 347 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'WRITE_MATRIX'.OR. 348 - - WORD(2)(IFIRST:ILAST).EQ.'MWRITE')THEN 349 - IPROC=-88 350 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_MATRIX'.OR. 351 - - WORD(2)(IFIRST:ILAST).EQ.'MGET')THEN 352 - IPROC=-89 353 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'MULTIPLY_MATRICES')THEN 354 - IPROC=-90 355 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'SOLVE_EQUATION')THEN 356 - IPROC=-91 357 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DIMENSIONS'.OR. 358 - - WORD(2)(IFIRST:ILAST).EQ.'DIMENSION')THEN 359 - IPROC=-92 360 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTERPOLATE')THEN 1 39 P=INPUT D=INPCAL 5 PAGE 32 361 - IPROC=-93 362 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_SURFACE')THEN 363 - IPROC=-94 364 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DERIVATIVE')THEN 365 - IPROC=-95 366 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTERPOLATE_1')THEN 367 - IPROC=-96 368 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTERPOLATE_2')THEN 369 - IPROC=-97 370 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTERPOLATE_3')THEN 371 - IPROC=-98 372 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTERPOLATE_4')THEN 373 - IPROC=-99 374 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_CONTOUR'.OR. 375 - - WORD(2)(IFIRST:ILAST).EQ.'PLOT_CONTOURS')THEN 376 - IPROC=-100 377 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_ERROR_BAND'.OR. 378 - - WORD(2)(IFIRST:ILAST).EQ.'ERROR_BAND')THEN 379 - IPROC=-101 380 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ZERO'.OR. 381 - - WORD(2)(IFIRST:ILAST).EQ.'ZEROES')THEN 382 - IPROC=-102 383 - * Gas related procedures. 384 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GAS_AVAILABILITY')THEN 385 - IPROC=-201 386 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_GAS_DATA')THEN 387 - IPROC=-202 388 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_VELOCITY_E'.OR. 389 - - WORD(2)(IFIRST:ILAST).EQ.'VELOCITY_E')THEN 390 - IPROC=-203 391 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ION_MOBILITY')THEN 392 - IPROC=-204 393 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'LONGITUDINAL_DIFFUSION'.OR. 394 - - WORD(2)(IFIRST:ILAST).EQ.'SIGMA_L')THEN 395 - IPROC=-205 396 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'TOWNSEND')THEN 397 - IPROC=-206 398 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ATTACHMENT')THEN 399 - IPROC=-207 400 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'LORENTZ_ANGLES'.OR. 401 - - WORD(2)(IFIRST:ILAST).EQ.'LORENTZ_ANGLE'.OR. 402 - - WORD(2)(IFIRST:ILAST).EQ.'VE_ANGLES'.OR. 403 - - WORD(2)(IFIRST:ILAST).EQ.'VE_ANGLE')THEN 404 - IPROC=-208 405 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'TRANSVERSE_DIFFUSION'.OR. 406 - - WORD(2)(IFIRST:ILAST).EQ.'SIGMA_T')THEN 407 - IPROC=-209 408 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_VELOCITY'.OR. 409 - - WORD(2)(IFIRST:ILAST).EQ.'VELOCITY')THEN 410 - IPROC=-210 411 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_VELOCITY_BTRANSVERSE'.OR. 412 - - WORD(2)(IFIRST:ILAST).EQ.'VELOCITY_BTRANSVERSE'.OR. 413 - - WORD(2)(IFIRST:ILAST).EQ.'DRIFT_VELOCITY_BTRANSVERSAL'.OR. 414 - - WORD(2)(IFIRST:ILAST).EQ.'VELOCITY_BTRANSVERSAL'.OR. 415 - - WORD(2)(IFIRST:ILAST).EQ.'DRIFT_VELOCITY_BTRANS'.OR. 416 - - WORD(2)(IFIRST:ILAST).EQ.'VELOCITY_BTRANS'.OR. 417 - - WORD(2)(IFIRST:ILAST).EQ.'DRIFT_VELOCITY_B'.OR. 418 - - WORD(2)(IFIRST:ILAST).EQ.'VELOCITY_B')THEN 419 - IPROC=-211 420 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_VELOCITY_EXB'.OR. 421 - - WORD(2)(IFIRST:ILAST).EQ.'VELOCITY_EXB')THEN 422 - IPROC=-212 423 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_E/P_TABLE')THEN 424 - IPROC=-213 425 - * Electric and magnetic field. 426 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ELECTRIC_FIELD'.OR. 427 - - WORD(2)(IFIRST:ILAST).EQ.'EFIELD'.OR. 428 - - WORD(2)(IFIRST:ILAST).EQ.'ELECTRIC_FIELD_2'.OR. 429 - - WORD(2)(IFIRST:ILAST).EQ.'EFIELD2')THEN 430 - IPROC=-301 431 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ELECTRIC_FIELD_3'.OR. 432 - - WORD(2)(IFIRST:ILAST).EQ.'EFIELD3')THEN 433 - IPROC=-302 434 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'FORCE_FIELD')THEN 435 - IPROC=-303 436 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'MAGNETIC_FIELD'.OR. 437 - - WORD(2)(IFIRST:ILAST).EQ.'BFIELD')THEN 438 - IPROC=-304 439 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'MAGNETIC_FIELD_3'.OR. 440 - - WORD(2)(IFIRST:ILAST).EQ.'BFIELD3')THEN 441 - IPROC=-305 442 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTEGRATE_CHARGE'.OR. 443 - - WORD(2)(IFIRST:ILAST).EQ.'CHARGE')THEN 444 - IPROC=-306 445 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTEGRATE_FLUX'.OR. 446 - - WORD(2)(IFIRST:ILAST).EQ.'FLUX')THEN 447 - IPROC=-307 448 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'MAP_INDEX')THEN 449 - IPROC=-310 450 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'MAP_ELEMENT')THEN 451 - IPROC=-311 452 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'MAP_MATERIAL')THEN 453 - IPROC=-312 454 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_FIELD_AREA')THEN 455 - IPROC=-320 456 - * Timing, progress logging. 457 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'TIME_LOG'.OR. 458 - - WORD(2)(IFIRST:ILAST).EQ.'TIME_LOGGING')THEN 459 - IPROC=-401 460 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PROGRESS_SET')THEN 461 - IPROC=-402 462 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PROGRESS_PRINT')THEN 463 - IPROC=-403 464 - * Drifting. 465 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'NEW_TRACK')THEN 466 - IPROC=-501 1 39 P=INPUT D=INPCAL 6 PAGE 33 467 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_CLUSTER')THEN 468 - IPROC=-502 469 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_ELECTRON')THEN 470 - IPROC=-503 471 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_ION')THEN 472 - IPROC=-504 473 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_ELECTRON_3')THEN 474 - IPROC=-505 475 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_ION_3')THEN 476 - IPROC=-506 477 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_DRIFT_LINE')THEN 478 - IPROC=-507 479 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_MC_ELECTRON'.OR. 480 - - WORD(2)(IFIRST:ILAST).EQ.'DRIFT_ELECTRON_MC')THEN 481 - IPROC=-508 482 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_MC_ION'.OR. 483 - - WORD(2)(IFIRST:ILAST).EQ.'DRIFT_ION_MC')THEN 484 - IPROC=-509 485 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_DRIFT_LINE')THEN 486 - IPROC=-510 487 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_TRACK')THEN 488 - IPROC=-511 489 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'AVALANCHE')THEN 490 - IPROC=-512 491 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_DRIFT_AREA')THEN 492 - IPROC=-513 493 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_NEGATIVE_ION')THEN 494 - IPROC=-514 495 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_NEGATIVE_ION_3')THEN 496 - IPROC=-515 497 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_MC_NEGATIVE_ION')THEN 498 - IPROC=-516 499 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_VACUUM_ELECTRON')THEN 500 - IPROC=-517 501 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_INFORMATION'.OR. 502 - - WORD(2)(IFIRST:ILAST).EQ.'DRIFT_INFO')THEN 503 - IPROC=-520 504 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_POSITRON')THEN 505 - IPROC=-521 506 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_POSITRON_3')THEN 507 - IPROC=-522 508 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_MC_POSITRON')THEN 509 - IPROC=-523 510 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTERPOLATE_TRACK')THEN 511 - IPROC=-524 512 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'RND_MULTIPLICATION')THEN 513 - IPROC=-525 514 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ELECTRON_VELOCITY')THEN 515 - IPROC=-526 516 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ION_VELOCITY')THEN 517 - IPROC=-527 518 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PRINT_DRIFT_LINE')THEN 519 - IPROC=-528 520 - * Histograms. 521 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'BOOK_HISTOGRAM'.OR. 522 - - WORD(2)(IFIRST:ILAST).EQ.'HBOOK')THEN 523 - IPROC=-602 524 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'FILL_HISTOGRAM'.OR. 525 - - WORD(2)(IFIRST:ILAST).EQ.'HFILL')THEN 526 - IPROC=-603 527 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_HISTOGRAM'.OR. 528 - - WORD(2)(IFIRST:ILAST).EQ.'HPLOT')THEN 529 - IPROC=-604 530 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PRINT_HISTOGRAM'.OR. 531 - - WORD(2)(IFIRST:ILAST).EQ.'HPRINT')THEN 532 - IPROC=-605 533 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DELETE_HISTOGRAM'.OR. 534 - - WORD(2)(IFIRST:ILAST).EQ.'DELETE_HISTOGRAMS'.OR. 535 - - WORD(2)(IFIRST:ILAST).EQ.'HDELETE')THEN 536 - IPROC=-606 537 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'LIST_HISTOGRAMS'.OR. 538 - - WORD(2)(IFIRST:ILAST).EQ.'HLIST')THEN 539 - IPROC=-607 540 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'WRITE_HISTOGRAM'.OR. 541 - - WORD(2)(IFIRST:ILAST).EQ.'HWRITE')THEN 542 - IPROC=-608 543 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_HISTOGRAM'.OR. 544 - - WORD(2)(IFIRST:ILAST).EQ.'HGET')THEN 545 - IPROC=-609 546 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INQUIRE_HISTOGRAM'.OR. 547 - - WORD(2)(IFIRST:ILAST).EQ.'QHIST')THEN 548 - IPROC=-610 549 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'CONVOLUTE')THEN 550 - IPROC=-611 551 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'BARYCENTRE'.OR. 552 - - WORD(2)(IFIRST:ILAST).EQ.'BARYCENTER')THEN 553 - IPROC=-612 554 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'HISTOGRAM_TO_MATRIX')THEN 555 - IPROC=-613 556 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'MATRIX_TO_HISTOGRAM')THEN 557 - IPROC=-614 558 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'WRITE_HISTOGRAM_RZ'.OR. 559 - - WORD(2)(IFIRST:ILAST).EQ.'WRITE_HISTOGRAMS_RZ'.OR. 560 - - WORD(2)(IFIRST:ILAST).EQ.'HROUT')THEN 561 - IPROC=-615 562 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'CUT_HISTOGRAM'.OR. 563 - - WORD(2)(IFIRST:ILAST).EQ.'HCUT')THEN 564 - IPROC=-616 565 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'REBIN_HISTOGRAM'.OR. 566 - - WORD(2)(IFIRST:ILAST).EQ.'HREBIN')THEN 567 - IPROC=-617 568 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'RESET_HISTOGRAM'.OR. 569 - - WORD(2)(IFIRST:ILAST).EQ.'HRESET')THEN 570 - IPROC=-618 571 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'CUMULATE_HISTOGRAM'.OR. 572 - - WORD(2)(IFIRST:ILAST).EQ.'HCUMUL')THEN 1 39 P=INPUT D=INPCAL 7 PAGE 34 573 - IPROC=-619 574 - * Utility routines. 575 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'CARTESIAN_TO_POLAR'.OR. 576 - - WORD(2)(IFIRST:ILAST).EQ.'CTP')THEN 577 - IPROC=-701 578 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'CARTESIAN_TO_INTERNAL'.OR. 579 - - WORD(2)(IFIRST:ILAST).EQ.'CTR')THEN 580 - IPROC=-702 581 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'POLAR_TO_CARTESIAN'.OR. 582 - - WORD(2)(IFIRST:ILAST).EQ.'PTC')THEN 583 - IPROC=-703 584 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'POLAR_TO_INTERNAL'.OR. 585 - - WORD(2)(IFIRST:ILAST).EQ.'PTR')THEN 586 - IPROC=-704 587 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTERNAL_TO_CARTESIAN'.OR. 588 - - WORD(2)(IFIRST:ILAST).EQ.'RTC')THEN 589 - IPROC=-705 590 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTERNAL_TO_POLAR'.OR. 591 - - WORD(2)(IFIRST:ILAST).EQ.'RTP')THEN 592 - IPROC=-706 593 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PREPARE_RND_FUNCTION')THEN 594 - IPROC=-710 595 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'EXTREMUM')THEN 596 - IPROC=-711 597 - * Plotting. 598 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_FRAME')THEN 599 - IPROC=-801 600 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_END')THEN 601 - IPROC=-802 602 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_MARKER'.OR. 603 - - WORD(2)(IFIRST:ILAST).EQ.'PLOT_MARKERS')THEN 604 - IPROC=-803 605 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_LINE'.OR. 606 - - WORD(2)(IFIRST:ILAST).EQ.'PLOT_VECTOR'.OR. 607 - - WORD(2)(IFIRST:ILAST).EQ.'PLOT_VECTORS')THEN 608 - IPROC=-804 609 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_TEXT')THEN 610 - IPROC=-805 611 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_COMMENT')THEN 612 - IPROC=-806 613 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_AREA')THEN 614 - IPROC=-807 615 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_GRAPH')THEN 616 - IPROC=-808 617 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_ERROR_BAR'.OR. 618 - - WORD(2)(IFIRST:ILAST).EQ.'PLOT_ERROR_BARS'.OR. 619 - - WORD(2)(IFIRST:ILAST).EQ.'ERROR_BAR'.OR. 620 - - WORD(2)(IFIRST:ILAST).EQ.'ERROR_BARS')THEN 621 - IPROC=-809 622 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PROJECT_LINE')THEN 623 - IPROC=-810 624 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PROJECT_MARKER'.OR. 625 - - WORD(2)(IFIRST:ILAST).EQ.'PROJECT_MARKERS')THEN 626 - IPROC=-811 627 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_START')THEN 628 - IPROC=-812 629 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_WINDOW'.OR. 630 - - WORD(2)(IFIRST:ILAST).EQ.'GSWN')THEN 631 - IPROC=-813 632 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_VIEWPORT'.OR. 633 - - WORD(2)(IFIRST:ILAST).EQ.'GSVP')THEN 634 - IPROC=-814 635 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_SELECT_NT'.OR. 636 - - WORD(2)(IFIRST:ILAST).EQ.'GSELNT')THEN 637 - IPROC=-815 638 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_POLYLINE')THEN 639 - IPROC=-816 640 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_POLYMARKER')THEN 641 - IPROC=-817 642 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'SET_POLYLINE_ATTRIBUTES'.OR. 643 - - WORD(2)(IFIRST:ILAST).EQ.'SET_LINE_ATTRIBUTES')THEN 644 - IPROC=-818 645 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'SET_POLYMARKER_ATTRIBUTES'.OR. 646 - - WORD(2)(IFIRST:ILAST).EQ.'SET_MARKER_ATTRIBUTES')THEN 647 - IPROC=-819 648 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'SET_TEXT_ATTRIBUTES')THEN 649 - IPROC=-820 650 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'SET_AREA_ATTRIBUTES')THEN 651 - IPROC=-821 652 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_TEXT')THEN 653 - IPROC=-822 654 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_AREA')THEN 655 - IPROC=-823 656 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_SET_TEXT_ALIGNMENT'.OR. 657 - - WORD(2)(IFIRST:ILAST).EQ.'GSTXAL')THEN 658 - IPROC=-824 659 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_SET_TEXT_COLOUR'.OR. 660 - - WORD(2)(IFIRST:ILAST).EQ.'GSTXCI')THEN 661 - IPROC=-825 662 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_SET_CHARACTER_HEIGHT'.OR. 663 - - WORD(2)(IFIRST:ILAST).EQ.'GSCHH')THEN 664 - IPROC=-826 665 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_SET_CHARACTER_EXPANSION'.OR. 666 - - WORD(2)(IFIRST:ILAST).EQ.'GSCHXP')THEN 667 - IPROC=-827 668 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_SET_CHARACTER_SPACING'.OR. 669 - - WORD(2)(IFIRST:ILAST).EQ.'GSCHSP')THEN 670 - IPROC=-828 671 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_SET_CHARACTER_UP_VECTOR'.OR. 672 - - WORD(2)(IFIRST:ILAST).EQ.'GSCHUP')THEN 673 - IPROC=-829 674 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_SET_TEXT_FONT_PRECISION'.OR. 675 - - WORD(2)(IFIRST:ILAST).EQ.'GSTXFP')THEN 676 - IPROC=-830 677 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_ARROW')THEN 678 - IPROC=-850 1 39 P=INPUT D=INPCAL 8 PAGE 35 679 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_TITLE')THEN 680 - IPROC=-851 681 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_X_LABEL')THEN 682 - IPROC=-852 683 - ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_Y_LABEL')THEN 684 - IPROC=-853 685 - * Rest is not known. 686 - ELSE 687 - PRINT *,' !!!!!! INPCAL WARNING : Procedure '// 688 - - WORD(2)(IFIRST:ILAST)//' is not known; not called.' 689 - IF(MODE.EQ.'EXECUTE')CALL ALGCLR(IENTRY) 690 - RETURN 691 - ENDIF 692 - *** Add the CALL statement to the instruction list. 693 - IF(NINS.GE.MXINS)THEN 694 - PRINT *,' !!!!!! INPCAL WARNING : Instruction list buffer'// 695 - - ' is full; CALL statement not processed.' 696 - IF(MODE.EQ.'EXECUTE')CALL ALGCLR(IENTRY) 697 - RETURN 698 - ENDIF 699 - IF(ISTART.EQ.0.AND.IEND.EQ.0)THEN 700 - INS(NINS-1,1)=IPROC 701 - INS(NINS-1,2)=9 702 - INS(NINS-1,3)=0 703 - INS(NINS-1,4)=0 704 - ALGENT(IENTNO,6)=2 705 - ALGENT(IENTNO,10)=0 706 - ELSE 707 - INS(NINS+1,1)=INS(NINS,1) 708 - INS(NINS+1,2)=INS(NINS,2) 709 - INS(NINS+1,3)=INS(NINS,3) 710 - INS(NINS+1,4)=INS(NINS,4) 711 - INS(NINS,1)=IPROC 712 - INS(NINS,2)=9 713 - INS(NINS,3)=NNRES 714 - INS(NINS,4)=0 715 - NINS=NINS+1 716 - ALGENT(IENTNO,6)=ALGENT(IENTNO,6)+1 717 - ALGENT(IENTNO,10)=0 718 - ENDIF 719 - *** In debug mode, print the list. 720 - IF(LDEBUG)THEN 721 - WRITE(LUNOUT,'('' ++++++ INPCAL DEBUG : Instruction'', 722 - - '' list after processing for CALL statement:'')') 723 - CALL ALGPRT(ALGENT(IENTNO,5),ALGENT(IENTNO,5)+ 724 - - ALGENT(IENTNO,6)-1) 725 - ENDIF 726 - *** Execute and clear the instruction list, if requested. 727 - IF(MODE.EQ.'EXECUTE')THEN 728 - CALL TIMEL(GLBVAL(1)) 729 - CALL ALGEXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,0,IFAIL1) 730 - CALL ALGERR 731 - CALL ALGCLR(IENTRY) 732 - ENDIF 733 - *** Things seem to have worked. 734 - IFAIL=0 735 - END 40 GARFIELD ================================================== P=INPUT D=INPCDO 1 ============================ 0 + +DECK,INPCDO. 1 - SUBROUTINE INPCDO 2 - *----------------------------------------------------------------------- 3 - * INPCDO - Cleans up the current DO loop. 4 - * (Last changed on 25/ 6/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,DOLOOP. 9.- +SEQ,GLOBALS. 10 - INTEGER I,J,NC,IFAIL 11 - CHARACTER STRING 12 - *** Clean up entry points. 13 - DO 10 I=1,NLOOP 14 - IF(DOREF(I,9).GT.0)THEN 15 - DO 20 J=1,5 16 - IF(DOREF(I,J).GT.0)CALL ALGCLR(DOREF(I,J)) 17 - 20 CONTINUE 18 - ELSE 19 - DO 30 J=3,4 20 - IF(DOREF(I,J).GT.0)CALL ALGCLR(DOREF(I,J)) 21 - 30 CONTINUE 22 - ENDIF 23 - 10 CONTINUE 24 - *** Remove the lines from the string buffer and entries for IF's. 25 - DO 40 I=1,NDOLIN 26 - * Global statements. 27 - IF(LINREF(I,1).EQ.21.AND.LINREF(I,8).GT.0) 28 - - CALL ALGCLR(LINREF(I,8)) 29 - * Call statements. 30 - IF(LINREF(I,1).EQ.22.AND.LINREF(I,8).GT.0) 31 - - CALL ALGCLR(LINREF(I,8)) 32 - * Leading IF ... THEN ... parts. 33 - IF(LINREF(I,4).GT.0)CALL ALGCLR(LINREF(I,4)) 34 - * Strings associated with instructions. 35 - CALL STRBUF('DELETE',LINREF(I,2),STRING,NC,IFAIL) 36 - IF(IFAIL.NE.0)PRINT *,' !!!!!! INPCDO WARNING : Unable to'// 37 - - ' delete a line from the string buffer; bug - no problem.' 38 - 40 CONTINUE 39 - *** Reset the number of DO lines to disallow reexecution. 40 - NDOLIN=-1 41 - NLOOP=-1 42 - ISTATE=-1 43 - END 1 41 GARFIELD ================================================== P=INPUT D=INPCHK 1 =================== PAGE 36 0 + +DECK,INPCHK. 1 - SUBROUTINE INPCHK(IWRD,IFMT,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * INPCHK - Routine checking the validity of numeric input and applying 4 - * corrections if necessary, before the Fortran input routines 5 - * are called. 6 - * VARIABLES : IFMT : Expected type 0=char,1=int,2=real,3=hex 7 - * IEXP : 0 If no exponent ('E') notation has been 8 - * come across yet, 1 if this is the case. 9 - * IDOT,ISIGN : Similar to IEXP. 10 - * INUM : 0 And 1 see IEXP, 2 a blank has been seen 11 - * after a number. 12 - * (Last changed on 1/ 7/98.) 13 - *----------------------------------------------------------------------- 14 - implicit none 15.- +SEQ,DIMENSIONS. 16.- +SEQ,INPUT. 17.- +SEQ,PRINTPLOT. 18 - CHARACTER*(MXCHAR) AUX 19 - CHARACTER CHAR 20 - LOGICAL NUMBER,HEX 21 - INTEGER IWRD,IFMT,IFAIL,INUM,IDOT,IEXP,ISIGN,IDELET,ICONV,I, 22 - - ILAST,NUMEXP 23 - *** Define 2 statement functions to be used to identify symbols. 24 - NUMBER(CHAR)=INDEX('0123456789',CHAR).NE.0 25 - HEX(CHAR)=INDEX('0123456789ABCDEF',CHAR).NE.0 26 - *** Identify the subroutine, if requested. 27 - IF(LIDENT)PRINT *,' /// ROUTINE INPCHK ///' 28 - *** Preset IFAIL to 0, ie OK. 29 - IFAIL=0 30 - *** Return without checking if IWRD is out of range. 31 - IF(IWRD.LE.0.OR.IWRD.GT.NWORD)RETURN 32 - *** Initialise ERRCDE(IWRD) and ERRPRT(IWRD). 33 - ERRCDE(IWRD)=' ' 34 - ERRPRT(IWRD)=.FALSE. 35 - *** Handle format 0 and word='*': no checks. 36 - IF(IFMT.EQ.0.OR.WORD(IWRD).EQ.'*'.OR.WORD(IWRD).EQ.' ')RETURN 37 - *** Initialise the counting variables (0=not yet seen, 1=seen, 2=end). 38 - INUM=0 39 - IDOT=0 40 - IEXP=0 41 - ISIGN=0 42 - IDELET=0 43 - ICONV=0 44 - *** Return immediately if the field is too long. 45 - IF(NCHAR(IWRD).GT.25)THEN 46 - ERRCDE(IWRD)='Word is longer than 25 chars. ' 47 - GOTO 100 48 - ENDIF 49 - *** Hexadecimal numbers. 50 - IF(IFMT.EQ.3)THEN 51 - IF(NCHAR(IWRD).GT.4)THEN 52 - ERRCDE(IWRD)='Hex number longer than 4 byte.' 53 - GOTO 100 54 - ELSE 55 - DO 30 I=1,NCHAR(IWRD) 56 - IF(.NOT.HEX(WORD(IWRD)(I:I)))THEN 57 - ERRCDE(IWRD)='Illegal characters seen. ' 58 - GOTO 100 59 - ENDIF 60 - 30 CONTINUE 61 - ENDIF 62 - RETURN 63 - ENDIF 64 - *** Handle the normal formats: integer(=1) and real (=2). 65 - I=0 66 - 20 CONTINUE 67 - I=I+1 68 - CHAR=WORD(IWRD)(I:I) 69 - * Remove character if IDELET is 1. 70 - IF(CHAR.EQ.'E'.AND.IDELET.EQ.1.AND.ICONV.EQ.1)IDELET=0 71 - IF(IDELET.EQ.1)THEN 72 - IF(CHAR.NE.' '.AND.ERRCDE(IWRD).EQ.' ')THEN 73 - ERRPRT(IWRD)=.TRUE. 74 - ERRCDE(IWRD)='The second number is removed. ' 75 - ENDIF 76 - WORD(IWRD)(I:I)=' ' 77 - * Set INUM to 1 if at least one number is seen, delete after a blank. 78 - ELSEIF(NUMBER(CHAR))THEN 79 - INUM=1 80 - * Delete from the first blank onwards. 81 - ELSEIF(CHAR.EQ.' ')THEN 82 - IF(WORD(IWRD)(:I).NE.' ')IDELET=1 83 - * Only one '.' is allowed, only for reals and only before the E. 84 - ELSEIF(CHAR.EQ.'.')THEN 85 - IF(IDOT.EQ.1.OR.IEXP.EQ.1)THEN 86 - ERRCDE(IWRD)='Illegal use of a decimal dot. ' 87 - GOTO 100 88 - ELSEIF(IFMT.EQ.1)THEN 89 - WORD(IWRD)(I:I)=' ' 90 - ERRCDE(IWRD)='Decimal not allowed in integer' 91 - IDELET=1 92 - ICONV=1 93 - ERRPRT(IWRD)=.TRUE. 94 - ENDIF 95 - IDOT=1 96 - * Only one E is allowed (after a number), no '.' allowed anymore. 97 - ELSEIF(CHAR.EQ.'E')THEN 98 - IF(IEXP.EQ.1)THEN 99 - ERRCDE(IWRD)='E has been used at least twice' 100 - GOTO 100 101 - ELSEIF(INUM.EQ.0)THEN 102 - IF(IFMT.EQ.1.AND.WORD(IWRD)(MXCHAR:MXCHAR).EQ.' ')THEN 103 - IF(I.GT.1)THEN 104 - AUX=WORD(IWRD)(1:I-1)//'0'// 105 - - WORD(IWRD)(I:MXCHAR-1) 1 41 P=INPUT D=INPCHK 2 PAGE 37 106 - ELSE 107 - AUX='0'//WORD(IWRD)(I:MXCHAR-1) 108 - ENDIF 109 - WORD(IWRD)=AUX 110 - I=I+1 111 - ERRCDE(IWRD)='0 is required before the E. ' 112 - ELSEIF(IFMT.EQ.2.AND. 113 - - WORD(IWRD)(MXCHAR-1:MXCHAR).EQ.' ')THEN 114 - IF(I.GT.1)THEN 115 - AUX=WORD(IWRD)(1:I-1)//'0.'// 116 - - WORD(IWRD)(I:MXCHAR-2) 117 - ELSE 118 - AUX='0.'//WORD(IWRD)(I:MXCHAR-2) 119 - ENDIF 120 - WORD(IWRD)=AUX 121 - I=I+2 122 - ERRCDE(IWRD)='0. is required before the E. ' 123 - ELSE 124 - ERRCDE(IWRD)='E is not preceded by a number.' 125 - GOTO 100 126 - ENDIF 127 - ELSEIF(IFMT.EQ.2.AND.IDOT.EQ.0)THEN 128 - IF(WORD(IWRD)(MXCHAR:MXCHAR).EQ.' ' 129 - - .AND.I.GE.2.AND.I.LT.MXCHAR)THEN 130 - IF(I.GT.1)THEN 131 - AUX=WORD(IWRD)(1:I-1)//'.'// 132 - - WORD(IWRD)(I:MXCHAR-1) 133 - ELSE 134 - AUX='.'//WORD(IWRD)(I:MXCHAR-1) 135 - ENDIF 136 - WORD(IWRD)=AUX 137 - ERRCDE(IWRD)='Decimal dot required for reals' 138 - I=I+1 139 - ELSE 140 - ERRCDE(IWRD)='Unable to insert a dot. ' 141 - GOTO 100 142 - ENDIF 143 - ENDIF 144 - IEXP=1 145 - IDOT=1 146 - ISIGN=0 147 - INUM=0 148 - * Accept only one sign before and one after E and before numbers. 149 - ELSEIF(CHAR.EQ.'+'.OR.CHAR.EQ.'-')THEN 150 - IF(INUM.EQ.1.OR.ISIGN.EQ.1.OR.(IDOT.EQ.1.AND.IEXP.EQ.0))THEN 151 - ERRCDE(IWRD)='Illegal use of a + or - sign. ' 152 - GOTO 100 153 - ENDIF 154 - ISIGN=1 155 - * Check that character is legal, remove if not. 156 - ELSE 157 - IF(IEXP.EQ.0.AND.INUM.EQ.0.AND.IDOT.EQ.0.AND.ISIGN.EQ.0)THEN 158 - WORD(IWRD)(I:I)=' ' 159 - ERRCDE(IWRD)='Illegal character(s) removed. ' 160 - ERRPRT(IWRD)=.TRUE. 161 - ELSE 162 - ERRCDE(IWRD)='Illegal character "'//CHAR//'" found. ' 163 - GOTO 100 164 - ENDIF 165 - ENDIF 166 - IF(I.LT.MXCHAR)GOTO 20 167 - *** Stop if line is blank after correction. 168 - IF(WORD(IWRD).EQ.' ')GOTO 100 169 - *** Make some additional checks on numbers with an E. 170 - IF(IEXP.EQ.1.AND.INUM.EQ.0)THEN 171 - WORD(IWRD)(INDEX(WORD(IWRD),'E'):)=' ' 172 - ERRCDE(IWRD)='No exponential sign is needed.' 173 - IEXP=0 174 - ISIGN=0 175 - * In case there is an E, make sure the exponent is not too large. 176 - ELSEIF(IEXP.EQ.1)THEN 177 - AUX=WORD(IWRD)(INDEX(WORD(IWRD),'E'):) 178 - AUX(1:1)=' ' 179 - READ(AUX,'(BN,I10)') NUMEXP 180 - IF(ABS(NUMEXP).GT.30)THEN 181 - ERRCDE(IWRD)='Exponent is out of range. ' 182 - GOTO 100 183 - ENDIF 184 - ENDIF 185 - *** Add zeros in numbers with a sign without number. 186 - IF(IEXP.EQ.0.AND.ISIGN.EQ.1.AND.INUM.EQ.0)THEN 187 - IF(IFMT.EQ.1)WORD(IWRD)='0' 188 - IF(IFMT.EQ.2)WORD(IWRD)='0.0' 189 - ERRCDE(IWRD)='Only a + or a - sign was found. ' 190 - *** Supplement a dot (if not yet present) to a real without an E. 191 - ELSEIF(IFMT.EQ.2.AND.IEXP.EQ.0.AND.IDOT.EQ.0)THEN 192 - ILAST=0 193 - INUM=0 194 - DO 40 I=1,MXCHAR 195 - IF(NUMBER(WORD(IWRD)(I:I)))THEN 196 - IF(INUM.EQ.0)INUM=1 197 - ELSE 198 - IF(INUM.EQ.1)THEN 199 - INUM=2 200 - ILAST=I 201 - ENDIF 202 - ENDIF 203 - 40 CONTINUE 204 - IF(INUM.NE.2)THEN 205 - ERRCDE(IWRD)='Unable to insert a dot (no E).' 206 - GOTO 100 207 - ELSE 208 - WORD(IWRD)(ILAST:ILAST)='.' 209 - ERRCDE(IWRD)='Decimal dot required for reals' 210 - ENDIF 211 - ENDIF 1 41 P=INPUT D=INPCHK 3 PAGE 38 212 - GOTO 110 213 - *** Case of irrepairable syntax errors. 214 - 100 CONTINUE 215 - ERRPRT(IWRD)=.TRUE. 216 - WORD(IWRD)='*' 217 - NCHAR(IWRD)=1 218 - IFAIL=1 219 - *** Remove blanks and count the number of characters again. 220 - 110 CONTINUE 221 - NCHAR(IWRD)=0 222 - DO 120 I=1,MXCHAR 223 - IF(WORD(IWRD)(I:I).NE.' ')THEN 224 - NCHAR(IWRD)=NCHAR(IWRD)+1 225 - WORD(IWRD)(NCHAR(IWRD):NCHAR(IWRD))=WORD(IWRD)(I:I) 226 - ENDIF 227 - 120 CONTINUE 228 - IF(NCHAR(IWRD).LT.MXCHAR)WORD(IWRD)(NCHAR(IWRD)+1:)=' ' 229 - END 42 GARFIELD ================================================== P=INPUT D=INPCMP 1 ============================ 0 + +DECK,INPCMP. 1 - INTEGER FUNCTION INPCMP(IWRD,REF) 2 - *----------------------------------------------------------------------- 3 - * INPCMP - Integer function returning 1 if word IWRD matches with 4 - * REF in all segments (delimited by - signs). 5 - * VARIABLES : REF : Reference string, the hash (#) signs 6 - * indicate the abbreviation points. 7 - * IWRD : The word to be matched with REF. 8 - * NMIN : Minimum of characters required to match. 9 - * (Last changed on 20/ 2/91.) 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,INPUT. 13 - CHARACTER*(*) REF 14 - CHARACTER*80 REFSTR 15 - *** Initialise some parameters. 16 - INPCMP=0 17 - IFREF=1 18 - IFCMP=1 19 - *** Return right away if the string to be compared with does not exist. 20 - IF(IWRD.LE.0.OR.IWRD.GT.NWORD)RETURN 21 - IF(NCHAR(IWRD).EQ.0)RETURN 22 - *** Return to this point if further segments are to be searched for. 23 - 10 CONTINUE 24 - *** Find the next part of the reference string. 25 - ILREF=INDEX(REF(IFREF:LEN(REF)),'-') 26 - IF(ILREF.EQ.0)THEN 27 - ILREF=LEN(REF) 28 - ELSE 29 - ILREF=IFREF+ILREF-2 30 - ENDIF 31 - * Remove the # sign from the string and store NMIN. 32 - REFSTR=' ' 33 - IF(ILREF.LT.IFREF)THEN 34 - REFSTR=' ' 35 - NMIN=0 36 - NCREF=0 37 - ELSE 38 - IHASH=INDEX(REF(IFREF:ILREF),'#') 39 - IF(IHASH.EQ.0)THEN 40 - REFSTR(1:ILREF-IFREF+1)=REF(IFREF:ILREF) 41 - NMIN=ILREF-IFREF+1 42 - NCREF=ILREF-IFREF+1 43 - ELSE 44 - IF(IHASH.GE.2) 45 - - REFSTR(1:IHASH-1)=REF(IFREF:IFREF+IHASH-2) 46 - IF(IHASH.LT.ILREF-IFREF+1)REFSTR(IHASH:ILREF-IFREF)= 47 - - REF(IFREF+IHASH:ILREF) 48 - NMIN=IHASH-1 49 - NCREF=ILREF-IFREF 50 - ENDIF 51 - ENDIF 52 - ** Do similar things with the string to be compared. 53 - ILCMP=INDEX(WORD(IWRD)(IFCMP:NCHAR(IWRD)),'-') 54 - IF(ILCMP.EQ.0)THEN 55 - ILCMP=NCHAR(IWRD) 56 - ELSE 57 - ILCMP=IFCMP+ILCMP-2 58 - ENDIF 59 - ** And compare the two strings. 60 - IF(NCREF.LT.ILCMP-IFCMP+1)RETURN 61 - NCOMP=MIN(NCREF,MAX(NMIN,ILCMP-IFCMP+1)) 62 - IF(NCOMP.GT.0)THEN 63 - IF(REFSTR(1:NCOMP).NE.WORD(IWRD)(IFCMP:IFCMP+NCOMP-1))RETURN 64 - ENDIF 65 - *** Return for a further cycle if there is more to compare. 66 - IFREF=ILREF+2 67 - IFCMP=ILCMP+2 68 - IF(IFREF.GT.LEN(REF))THEN 69 - IF(IFCMP.GT.NCHAR(IWRD))INPCMP=1 70 - RETURN 71 - ELSEIF(IFCMP.GT.NCHAR(IWRD))THEN 72 - IF(REF(IFREF:IFREF).EQ.'#')INPCMP=1 73 - RETURN 74 - ENDIF 75 - GOTO 10 76 - END 43 GARFIELD ================================================== P=INPUT D=INPCMX 1 ============================ 0 + +DECK,INPCMX. 1 - INTEGER FUNCTION INPCMX(STR1,STR2) 2 - *----------------------------------------------------------------------- 3 - * INPCMX - Compares strings STR1 and STR2 where STR1 is the word and 4 - * STR2 the pattern string. 1 43 P=INPUT D=INPCMX 2 PAGE 39 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,INPUT. 8 - CHARACTER*(*) STR1,STR2 9 - CHARACTER*(MXWORD) WRDRES 10 - CHARACTER*30 ECDRES 11 - LOGICAL ERRRES 12 - INTEGER INPCMP 13 - EXTERNAL INPCMP 14 - *** First store all data on word 1 and remember the number of words. 15 - WRDRES=WORD(1) 16 - ECDRES=ERRCDE(1) 17 - ERRRES=ERRPRT(1) 18 - NCHRES=NCHAR(1) 19 - NWRRES=NWORD 20 - *** Store the word to be checked in word 1 and check it. 21 - NWORD=1 22 - IF(LEN(STR1).GT.MXWORD)THEN 23 - INPCMX=0 24 - ELSE 25 - WORD(1)=STR1 26 - NCHAR(1)=LEN(STR1) 27 - INPCMX=INPCMP(1,STR2) 28 - ENDIF 29 - *** Restore the old word 1 in its place. 30 - WORD(1) =WRDRES 31 - ERRCDE(1)=ECDRES 32 - ERRPRT(1)=ERRRES 33 - NCHAR(1) =NCHRES 34 - NWORD =NWRRES 35 - END 44 GARFIELD ================================================== P=INPUT D=INPDEL 1 ============================ 0 + +DECK,INPDEL. 1 - SUBROUTINE INPDEL(IWRD) 2 - *----------------------------------------------------------------------- 3 - * INPDEL - Deletes a word from the list of words. 4 - * (Last changed on 20/ 5/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,INPUT. 9.- +SEQ,PRINTPLOT. 10 - INTEGER IWRD,I 11 - *** Return in case the word is out of range. 12 - IF(IWRD.LE.0.OR.IWRD.GT.NWORD)RETURN 13 - *** Blank the word to be deleted also from the main string. 14 - C IF(NCHAR(IWRD).GE.1) 15 - C - STRING(INDWRD(IWRD):INDWRD(IWRD)+NCHAR(IWRD)-1)=' ' 16 - *** Shift all words from IWRD onwards one place. 17 - DO 10 I=IWRD,NWORD-1 18 - WORD(I)=WORD(I+1) 19 - NCHAR(I)=NCHAR(I+1) 20 - INDWRD(I)=INDWRD(I+1) 21 - ERRCDE(I)=ERRCDE(I+1) 22 - ERRPRT(I)=ERRPRT(I+1) 23 - 10 CONTINUE 24 - *** The number of words is one less by now. 25 - NWORD=NWORD-1 26 - END 45 GARFIELD ================================================== P=INPUT D=INPERR 1 ============================ 0 + +DECK,INPERR. 1 - SUBROUTINE INPERR 2 - *----------------------------------------------------------------------- 3 - * INPERR - Prints the errors detected by INPCHK in a compact manner. 4 - * (Last changed on 20/ 5/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,INPUT. 9.- +SEQ,PRINTPLOT. 10 - LOGICAL OK 11 - CHARACTER*(MXINCH+1) MARK 12 - INTEGER LASTCH(MXWORD),I,J,IORIG,IPART,JSTART 13 - IF(LIDENT)PRINT *,' /// ROUTINE INPERR ///' 14 - *** Find out whether something is wrong or not and preset the mark line. 15 - MARK=' ' 16 - OK=.TRUE. 17 - DO 10 I=1,NWORD 18 - IF(ERRPRT(I))OK=.FALSE. 19 - IF(ERRCDE(I).NE.' ')THEN 20 - IF(ERRPRT(I))MARK(INDWRD(I):INDWRD(I))='#' 21 - IF(.NOT.ERRPRT(I))MARK(INDWRD(I):INDWRD(I))='!' 22 - ENDIF 23 - 10 CONTINUE 24 - *** Return at this point if there are no error messages. 25 - IF(OK)RETURN 26 - * Otherwise print a heading for the messages. 27 - PRINT *,' !!!!!! INPERR WARNING : The words marked # and !'// 28 - - ' have been changed:' 29 - *** Find out where each string ends. 30 - DO 20 I=1,NWORD 31 - * Starting point of the search. 32 - IF(I.EQ.NWORD)THEN 33 - JSTART=MXCHAR 34 - ELSE 35 - JSTART=INDWRD(I+1)-1 36 - ENDIF 37 - * Search for last non-blank character of the string. 38 - DO 30 J=JSTART,INDWRD(I),-1 39 - IF(STRING(J:J).NE.' ')THEN 40 - LASTCH(I)=J 41 - GOTO 40 1 45 P=INPUT D=INPERR 2 PAGE 40 42 - ENDIF 43 - 30 CONTINUE 44 - LASTCH(I)=INDWRD(I) 45 - 40 CONTINUE 46 - 20 CONTINUE 47 - * Add as many words as will fit without spilling to next line. 48 - IORIG=1 49 - IPART=0 50 - DO 50 I=1,NWORD 51 - IF(I.NE.NWORD)THEN 52 - IF(LASTCH(I+1)-INDWRD(IORIG)+25.LE.75)GOTO 50 53 - ENDIF 54 - IF(IORIG.EQ.1.AND.I.EQ.NWORD)THEN 55 - PRINT *,' Original input : '// 56 - - STRING(INDWRD(IORIG):LASTCH(I)) 57 - ELSE 58 - IPART=IPART+1 59 - WRITE(*,'(/'' Input part '',I3,'' : '',A)') IPART, 60 - - STRING(INDWRD(IORIG):LASTCH(I)) 61 - ENDIF 62 - PRINT *,' Modified words : '// 63 - - MARK(INDWRD(IORIG):LASTCH(I)) 64 - DO 60 J=IORIG,I 65 - IF(ERRCDE(J).NE.' '.AND.WORD(J)(1:NCHAR(J)).EQ.'*DELETED*')THEN 66 - PRINT *,' Deleted, reason: '//ERRCDE(J) 67 - ELSEIF(ERRCDE(J).NE.' ')THEN 68 - PRINT *,' Changed into "'//WORD(J)(1:NCHAR(J))// 69 - - '", reason: '//ERRCDE(J) 70 - ENDIF 71 - 60 CONTINUE 72 - IORIG=I+1 73 - 50 CONTINUE 74 - *** End of the printout. 75 - PRINT *,' ' 76 - END 46 GARFIELD ================================================== P=INPUT D=INPESC 1 ============================ 0 + +DECK,INPESC. 1 - SUBROUTINE INPESC(STR,NCSTR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * INPESC - Removes escape characters from the string. 4 - * (Last changed on 4/ 6/92.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,INPUT. 8 - CHARACTER*(*) STR 9 - *** Scan the string for backslashes. 10 - NCOUT=0 11 - DO 10 I=1,NCSTR 12 - IF(STR(I:I).NE.ESCAPE)THEN 13 - NCOUT=NCOUT+1 14 - STR(NCOUT:NCOUT)=STR(I:I) 15 - ENDIF 16 - 10 CONTINUE 17 - *** Blank remainder of string. 18 - IF(NCSTR.GT.NCOUT)STR(NCOUT+1:NCSTR)=' ' 19 - *** Set new number of characters. 20 - NCSTR=NCOUT 21 - *** Routine always works. 22 - IFAIL=0 23 - END 47 GARFIELD ================================================== P=INPUT D=INPFIX 1 ============================ 0 + +DECK,INPFIX. 1 - SUBROUTINE INPFIX(STRIN,STROUT,NC) 2 - *----------------------------------------------------------------------- 3 - * INPFIX - Converts a comparison string into a more legible format. 4 - *----------------------------------------------------------------------- 5.- +SEQ,DIMENSIONS. 6.- +SEQ,INPUT. 7 - CHARACTER*(*) STRIN,STROUT 8 - LOGICAL TRANS 9 - INTEGER NC 10 - *** Initial values. 11 - TRANS=.FALSE. 12 - NC=0 13 - *** Loop over the input string. 14 - DO 10 I=1,LEN(STRIN) 15 - *** Check whether there is room for further characters in the output. 16 - IF(NC.GE.LEN(STROUT))THEN 17 - PRINT *,' !!!!!! INPFIX WARNING : Receiving string is too'// 18 - - ' short ; output has been truncated.' 19 - NC=LEN(STROUT) 20 - RETURN 21 - ENDIF 22 - *** Skip blanks and hatches. 23 - IF(STRIN(I:I).EQ.' '.OR.STRIN(I:I).EQ.'#')THEN 24 - GOTO 10 25 - *** Copy dashes as-is but leave the next upper case character untouched. 26 - ELSEIF(STRIN(I:I).EQ.'-')THEN 27 - NC=NC+1 28 - STROUT(NC:NC)='-' 29 - TRANS=.FALSE. 30 - *** Convert the character to lower case if it's alphabetic. 31 - ELSEIF(TRANS)THEN 32 - NC=NC+1 33 - IC=ICHAR(STRIN(I:I)) 34 - * ASCII: all letters are contiguous and located between 97 and 122. 35 - IF(ICHSET.EQ.1.AND.IC.LE.90.AND.IC.GE.65)THEN 36 - STROUT(NC:NC)=CHAR(IC+32) 37 - * EBCDIC: there are 2 gaps in the set (idea from IBM of course). 38 - ELSEIF(ICHSET.EQ.2.AND.((IC.GE.193.AND.IC.LE.201).OR. 39 - - (IC.GE.209.AND.IC.LE.217).OR. 40 - - (IC.GE.226.AND.IC.LE.233)))THEN 1 47 P=INPUT D=INPFIX 2 PAGE 41 41 - STROUT(NC:NC)=CHAR(IC-64) 42 - * Anything else: no translation. 43 - ELSE 44 - STROUT(NC:NC)=STRIN(I:I) 45 - ENDIF 46 - *** Leave the first upper case character in each segment as it is. 47 - ELSE 48 - NC=NC+1 49 - STROUT(NC:NC)=STRIN(I:I) 50 - TRANS=.TRUE. 51 - ENDIF 52 - 10 CONTINUE 53 - END 48 GARFIELD ================================================== P=INPUT D=INPGET 1 ============================ 0 + +DECK,INPGET. 1 - SUBROUTINE INPGET 2 - *----------------------------------------------------------------------- 3 - * INPGET - This routine reads a line from unit LUN (without checking 4 - * that it is opened). It isolates the words. 5 - * VARIABLES : SQUOTE : Becomes TRUE when a single quote has been 6 - * met (separators are ignored inside quotes) 7 - * DQUOTE : Similar to SQUOTE, but for double quotes 8 - * BQUOTE : Similar to SQUOTE, but for reverse quotes 9 - * (Last changed on 7/11/00.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,INPUT. 14.- +SEQ,PRINTPLOT. 15.- +SEQ,GLOBALS. 16 - CHARACTER*(MXNAME) FILE 17 - INTEGER I,I0,I1,I0STR,NCSTR,IFLAG,IFIRST,IOS,IFAIL,NC,IC 18 - LOGICAL SQUOTE,DQUOTE,BQUOTE,BRACK,DQINBR,BQINBR,KPCASE, 19 - - STDSTR,REREAD,ACT1,ACT2 20 - EXTERNAL STDSTR 21 - *** Identify the routine 22 - IF(LIDENT)PRINT *,' /// ROUTINE INPGET ///' 23 - *** Initialise the number of words, the quote logicals, the error codes 24 - 30 CONTINUE 25 - NWORD=0 26 - DO 50 I=1,MXWORD 27 - ERRPRT(I)=.FALSE. 28 - ERRCDE(I)=' ' 29 - WORD(I)=' ' 30 - NCHAR(I)=1 31 - 50 CONTINUE 32 - *** Read a line from the DO buffer, if available. 33 - IF(DOEXEC)THEN 34 - * Fetch the line. 35 - CALL INPXDO(STRING,NCSTR,IFLAG) 36 - * Error in the DO loop execution routine. 37 - IF(IFLAG.LT.0)THEN 38 - PRINT *,' ------ INPGET MESSAGE : Resuming input'// 39 - - ' from normal stream after DO execution error.' 40 - DOEXEC=.FALSE. 41 - * End of loop reached without error. 42 - ELSEIF(IFLAG.EQ.+2)THEN 43 - DOEXEC=.FALSE. 44 - ENDIF 45 - * Line didn't come from the buffer. 46 - ELSE 47 - IFLAG=0 48 - ENDIF 49 - *** Read a line from normal input, disable condition handling. 50 - IF(.NOT.DOEXEC)THEN 0 51-+ +SELF,IF=AST. 52 - CALL ASTDCC 0 53-+ +SELF. 54 - * Initial settings. 55 - STRING=' ' 56 - IFIRST=1 57 - * Return here for more string portions. 58 - 110 CONTINUE 59 - * Adjust prompt for multiple sections. 60 - IF(IFIRST.NE.1)CALL INPPRM('More ...','ADD') 61 - * Synchronisation prompt. 62 - IF(LSYNCH.AND.LUN.EQ.5.AND.STDSTR('INPUT').AND. 63 - - NCPROM.GE.1)THEN 64 - WRITE(6,'('' >>>>>> input '',A)') PROMPT(1:NCPROM) 0 65-+ +SELF,IF=VAX. 66 - * Display the prompt in underlined, fat mode (VT100 escape sequence). 67 - ELSEIF(LUN.EQ.5.AND.STDSTR('INPUT').AND.NCPROM.GE.1)THEN 68 - WRITE(6,'(''$ '',A,'': '')') 69 - - CHAR(27)//CHAR(91)//CHAR(49)//CHAR(109)// 70 - - CHAR(27)//CHAR(91)//CHAR(52)//CHAR(109)// 71 - - PROMPT(1:NCPROM)//CHAR(27)//CHAR(91)//CHAR(109) 0 72-+ +SELF,IF=IBMRT. 73 - * Display the prompt in underlined, fat mode (VT100 escape sequence). 74 - ELSEIF(LUN.EQ.5.AND.STDSTR('INPUT').AND.NCPROM.GE.1)THEN 75 - WRITE(6,'('' '',A,'': '')',ADVANCE='NO') 76 - - CHAR(27)//CHAR(91)//CHAR(49)//CHAR(109)// 77 - - CHAR(27)//CHAR(91)//CHAR(52)//CHAR(109)// 78 - - PROMPT(1:NCPROM)//CHAR(27)//CHAR(91)//CHAR(109) 0 79-+ +SELF,IF=SUN,HPUX,LINUX,DECS. 80 - * Display the prompt in underlined, fat mode (VT100 escape sequence). 81 - ELSEIF(LUN.EQ.5.AND.STDSTR('INPUT').AND.NCPROM.GE.1)THEN 82 - WRITE(6,'('' '',A,'': '',$)') 83 - - CHAR(27)//CHAR(91)//CHAR(49)//CHAR(109)// 84 - - CHAR(27)//CHAR(91)//CHAR(52)//CHAR(109)// 1 48 P=INPUT D=INPGET 2 PAGE 42 85 - - PROMPT(1:NCPROM)//CHAR(27)//CHAR(91)//CHAR(109) 0 86-+ +SELF,IF=APOLLO. 87 - * Display the prompt normal way. 88 - ELSEIF(LUN.EQ.5.AND.STDSTR('INPUT').AND.NCPROM.GE.1)THEN 89 - WRITE(6,'('' '',A,'': '',$)') PROMPT(1:NCPROM) 0 90-+ +SELF,IF=-VAX,IF=-APOLLO,IF=-IBMRT,IF=-SUN,IF=-HPUX,IF=-LINUX,IF=-DECS. 91 - * Display the prompt by appending it to the READY string. 92 - ELSEIF((LUN.EQ.5).AND.STDSTR('INPUT').AND. 93 - - (NCPROM.GE.1).AND.LPROM)THEN 94 - WRITE(6,'('' Ready ('',A,'')'')') PROMPT(1:NCPROM) 0 95-+ +SELF. 96 - ENDIF 97 - * Restablish the prompt. 98 - IF(IFIRST.NE.1)CALL INPPRM(' ','BACK') 99 - * Read a portion of the line. 100 - IF(IFIRST.GE.MXINCH)THEN 101 - PRINT *,' !!!!!! INPGET WARNING : No room for more'// 102 - - ' input characters.' 103 - GOTO 130 104 - ELSE 0 105-+ +SELF,IF=-CMS. 106 - READ(LUN,'(A)',END=2000,IOSTAT=IOS,ERR=2010) 107 - - STRING(IFIRST:MXINCH) 0 108-+ +SELF,IF=CMS. 109 - READ(LUN,END=2000,IOSTAT=IOS,ERR=2010,NUM=NBYTE) 110 - - STRING(IFIRST:MXINCH) 0 111-+ +SELF. 112 - * Input translation. 113 - CALL INPTRA(STRING(IFIRST:MXINCH),MXINCH-IFIRST+1) 114 - * Write out to the recording file if requested and appropriate. 115 - IF(LUN.EQ.5.AND.LINREC)THEN 116 - DO 150 I=MXINCH,IFIRST,-1 117 - IF(STRING(I:I).NE.' ')THEN 118 - WRITE(18,'(A)',IOSTAT=IOS,ERR=2020) 119 - - STRING(IFIRST:MIN(132+IFIRST,I)) 120 - GOTO 160 121 - ENDIF 122 - 150 CONTINUE 123 - WRITE(18,'('' '')',IOSTAT=IOS,ERR=2020) 124 - 160 CONTINUE 125 - ENDIF 126 - ENDIF 127 - * Print the string if requested and determine whether to continue. 128 - DO 120 I=MXINCH-2,IFIRST,-1 129 - IF(STRING(I:I+2).EQ.'...')THEN 130 - IF(LINPUT)PRINT *,' ====== INPGET INPUT : '// 131 - - STRING(IFIRST:I+2) 132 - IFIRST=I 133 - GOTO 110 134 - ELSEIF(STRING(I:I+2).NE.' '.AND.STRING(I:I+2).NE.'. ' 135 - - .AND.STRING(I:I+2).NE.'.. ')THEN 136 - IF(LINPUT)PRINT *,' ====== INPGET INPUT : '// 137 - - STRING(IFIRST:I+2) 138 - GOTO 130 139 - ENDIF 140 - 120 CONTINUE 141 - 130 CONTINUE 0 142-+ +SELF,IF=AST. 143 - * Reenable condition handling. 144 - CALL ASTECC 0 145-+ +SELF. 146 - * Check the EOF label. 147 - IF(STRING.EQ.EOFSTR.AND.EOFSTR.NE.'EOF')GOTO 2000 148 - ENDIF 149 - * Determine the length of the string. 150 - NCSTR=1 151 - I0STR=1 152 - DO 140 I=MXINCH,1,-1 153 - IF(STRING(I:I).NE.' ')THEN 154 - IF(NCSTR.EQ.1)NCSTR=I 155 - I0STR=I 156 - ENDIF 157 - 140 CONTINUE 158 - *** Change lower case characters to upper case, except for $ lines. 0 159-+ +SELF,IF=CMS. 160 - KPCASE=.FALSE. 0 161-+ +SELF,IF=-CMS. 162 - IF(INDEX('$><',STRING(I0STR:I0STR)).NE.0)THEN 163 - KPCASE=.TRUE. 164 - ELSE 165 - KPCASE=.FALSE. 166 - ENDIF 0 167-+ +SELF. 168 - DQUOTE=.FALSE. 169 - BQUOTE=.FALSE. 170 - BRACK=.FALSE. 171 - DQINBR=.FALSE. 172 - BQINBR=.FALSE. 173 - DO 40 I=1,NCSTR 174 - * Keep track of double quotes and curly brackets. 175 - IF(I.EQ.1.OR.STRING(MAX(1,I-1):MAX(1,I-1)).NE.ESCAPE)THEN 176 - IF(STRING(I:I).EQ.'"')DQUOTE=.NOT.DQUOTE 177 - IF(STRING(I:I).EQ.'`')BQUOTE=.NOT.BQUOTE 178 - IF(BRACK.AND.STRING(I:I).EQ.'"')DQINBR=.NOT.DQINBR 179 - IF(BRACK.AND.STRING(I:I).EQ.'`')BQINBR=.NOT.BQINBR 1 48 P=INPUT D=INPGET 3 PAGE 43 180 - IF(STRING(I:I).EQ.'{')BRACK=.TRUE. 181 - IF(STRING(I:I).EQ.'{')DQINBR=.FALSE. 182 - IF(STRING(I:I).EQ.'{')BQINBR=.FALSE. 183 - IF(STRING(I:I).EQ.'}')BRACK=.FALSE. 184 - IF(STRING(I:I).EQ.'}')DQINBR=.FALSE. 185 - IF(STRING(I:I).EQ.'}')BQINBR=.FALSE. 186 - ENDIF 187 - * Do not change case inside quotes but change inside brackets but ... 188 - IF(DQUOTE.AND.(((.NOT.BRACK).AND.(.NOT.DQINBR)).OR. 189 - - (BRACK.AND.DQINBR)))GOTO 40 190 - IF(BQUOTE.AND.(((.NOT.BRACK).AND.(.NOT.BQINBR)).OR. 191 - - (BRACK.AND.BQINBR)))GOTO 40 192 - * Do not change special commands, except in brackets and quotes. 193 - IF(KPCASE.AND..NOT.(BRACK.OR.BQINBR.OR.DQINBR))GOTO 40 194 - * Loop up character sequence number. 195 - IC=ICHAR(STRING(I:I)) 196 - * ASCII: all letters are contiguous and located between 97 and 122. 197 - IF(ICHSET.EQ.1.AND.IC.LE.122.AND.IC.GE.97)THEN 198 - STRING(I:I)=CHAR(IC-32) 199 - * EBCDIC: there are 2 gaps in the set (idea from IBM of course). 200 - ELSEIF(ICHSET.EQ.2.AND.((IC.GE.129.AND.IC.LE.137).OR. 201 - - (IC.GE.145.AND.IC.LE.153).OR.(IC.GE.162.AND.IC.LE.169)))THEN 202 - STRING(I:I)=CHAR(IC+64) 203 - ENDIF 204 - 40 CONTINUE 205 - * Continue here if no conversion has been done. 206 - 70 CONTINUE 207 - *** Perform substitutions. 208 - IF((.NOT.DOREAD).AND.(STRING(I0STR:I0STR).NE.'*'))THEN 209 - CALL INPIFQ(ACT1,ACT2) 210 - IF(ACT2.OR.(ACT1.AND. 211 - - STRING(I0STR:MIN(I0STR+6,NCSTR)).EQ.'ELSEIF ')) 212 - - CALL INPSUB(STRING,NCSTR,IFAIL) 213 - ENDIF 214 - *** Get rid of escape characters. 215 - CALL INPESC(STRING,NCSTR,IFAIL) 216 - *** Split the string in pieces. 217 - SQUOTE=.FALSE. 218 - DQUOTE=.FALSE. 219 - BQUOTE=.FALSE. 220 - * Locate start of next word. 221 - I0=0 222 - 10 CONTINUE 223 - I0=I0+1 224 - IF(I0.GT.NCSTR)GOTO 100 225 - * If first character is a quote, set flags accordingly. 226 - IF(STRING(I0:I0).EQ.'''')THEN 227 - SQUOTE=.TRUE. 228 - ELSE 229 - SQUOTE=.FALSE. 230 - ENDIF 231 - IF(STRING(I0:I0).EQ.'"')THEN 232 - DQUOTE=.TRUE. 233 - ELSE 234 - DQUOTE=.FALSE. 235 - ENDIF 236 - IF(STRING(I0:I0).EQ.'`')THEN 237 - BQUOTE=.TRUE. 238 - ELSE 239 - BQUOTE=.FALSE. 240 - ENDIF 241 - * Proceed with next character if STRING(I0:I0) is a separator. 242 - IF(INDEX(' ,=',STRING(I0:I0)).NE.0)GOTO 10 243 - * Scan for the end of the word 244 - DO 20 I1=I0+1,NCSTR+1 245 - IF(I1.NE.NCSTR+1.AND. 246 - - (INDEX('''"` ,=:',STRING(I1:I1)).EQ.0.OR. 247 - - ((DQUOTE.OR.SQUOTE.OR.BQUOTE).AND. 248 - - INDEX(' ,=:',STRING(I1:I1)).NE.0).OR. 249 - - (STRING(I1:I1).EQ.''''.AND.(DQUOTE.OR.BQUOTE)).OR. 250 - - (STRING(I1:I1).EQ.'`'.AND.(DQUOTE.OR.SQUOTE)).OR. 251 - - (STRING(I1:I1).EQ.'"'.AND.(SQUOTE.OR.BQUOTE))))GOTO 20 252 - * Check that the string ends on a quote 253 - IF((SQUOTE.AND.STRING(I1:I1).NE.'''').OR. 254 - - (DQUOTE.AND.STRING(I1:I1).NE.'"').OR. 255 - - (BQUOTE.AND.STRING(I1:I1).NE.'`')) 256 - - PRINT *,' !!!!!! INPGET WARNING : A quote is missing in'// 257 - - ' the line ; assuming one at the end.' 258 - * Make sure that the maximum number of words is not exceeded 259 - IF(NWORD+1.GT.MXWORD)THEN 260 - PRINT *,' !!!!!! INPGET WARNING : The number of keywords'// 261 - - ' exceeds MXWORD (=',MXWORD,') ; rest is ignored.' 262 - GOTO 100 263 - ENDIF 264 - NWORD=NWORD+1 265 - * Store word together with its length and the index of first character 266 - IF(INDEX('''"',STRING(I0:I0)).NE.0)THEN 267 - IF(I0.EQ.I1-1)THEN 268 - WORD(NWORD)=' ' 269 - NCHAR(NWORD)=0 270 - ELSE 271 - WORD(NWORD)=STRING(I0+1:I1-1) 272 - NCHAR(NWORD)=MIN(MXCHAR,I1-I0-1) 273 - ENDIF 274 - INDWRD(NWORD)=I0+1 275 - IF(I1-I0-1.GT.MXCHAR)PRINT *,' !!!!!! INPGET WARNING : "'// 276 - - STRING(I0+1:I1-1)//'" is truncated to "'// 277 - - WORD(NWORD)//'" (MXCHAR characters).' 278 - ELSEIF(STRING(I0:I0).EQ.'`')THEN 279 - WORD(NWORD)=STRING(I0:I1) 280 - NCHAR(NWORD)=MIN(MXCHAR,I1-I0+1) 281 - IF(I1-I0+1.GT.MXCHAR)PRINT *,' !!!!!! INPGET WARNING : "'// 282 - - STRING(I0:I1)//'" is truncated to "'// 283 - - WORD(NWORD)//'" (MXCHAR characters).' 284 - INDWRD(NWORD)=I0 285 - ELSE 1 48 P=INPUT D=INPGET 4 PAGE 44 286 - WORD(NWORD)=STRING(I0:I1-1) 287 - NCHAR(NWORD)=MIN(MXCHAR,I1-I0) 288 - IF(I1-I0.GT.MXCHAR)PRINT *,' !!!!!! INPGET WARNING : "'// 289 - - STRING(I0:I1-1)//'" is truncated to "'// 290 - - WORD(NWORD)//'" (MXCHAR characters).' 291 - INDWRD(NWORD)=I0 292 - ENDIF 293 - * Continue with the next word. 294 - IF((STRING(I1:I1).EQ.''''.AND..NOT.SQUOTE).OR. 295 - - (STRING(I1:I1).EQ.'"'.AND..NOT.DQUOTE).OR. 296 - - (STRING(I1:I1).EQ.'`'.AND..NOT.BQUOTE))THEN 297 - I0=I1-1 298 - ELSE 299 - I0=I1 300 - ENDIF 301 - GOTO 10 302 - 20 CONTINUE 303 - 100 CONTINUE 304 - * Care for the empty string case. 305 - IF(NWORD.EQ.0)THEN 306 - WORD(1)=' ' 307 - NCHAR(1)=1 308 - ENDIF 309 - *** Print the list of words if the debug option is on. 310 - IF(LDEBUG)THEN 311 - IF(NWORD.EQ.0)THEN 312 - WRITE(LUNOUT,'(1X,A)') 313 - - ' ++++++ INPGET DEBUG : Empty input string.' 314 - ELSE 315 - WRITE(LUNOUT,'(1X,A)') ' ++++++ INPGET DEBUG :'// 316 - - ' Word Length Start Text' 317 - DO 200 I=1,NWORD 318 - WRITE(LUNOUT,'(26X,3I7,2X,A)') 319 - - I,NCHAR(I),INDWRD(I),WORD(I)(1:MAX(1,NCHAR(I))) 320 - 200 CONTINUE 321 - WRITE(LUNOUT,'('' '')') 322 - ENDIF 323 - ENDIF 324 - *** Input line started with an IF clause. 325 - IF(IFLAG.EQ.+1)THEN 326 - CALL INPDEL(3) 327 - CALL INPDEL(2) 328 - CALL INPDEL(1) 329 - ENDIF 330 - *** Check the IF condition outside the DO loops. 331 - IF((.NOT.DOREAD).AND.(.NOT.DOEXEC))THEN 332 - CALL INPIFT(REREAD,IFAIL) 333 - IF(REREAD)THEN 334 - IF(LDEBUG)WRITE(LUNOUT,'(1X,A)') 335 - - ' ++++++ INPGET DEBUG : Line is skipped.' 336 - GOTO 30 337 - ENDIF 338 - ENDIF 339 - *** Normal end of this routine. 340 - RETURN 341 - *** Handle I/O problems, first EOF on standard input. 342 - 2000 CONTINUE 343 - IF(LUN.EQ.5)THEN 0 344-+ +SELF,IF=-CMS. 345 - PRINT *,' ------ INPGET MESSAGE : EOF on standard'// 346 - - ' input ; end of program execution.' 347 - CALL QUIT 0 348-+ +SELF,IF=CMS. 349 - IF(LINREC)WRITE(18,'('' '')',IOSTAT=IOS,ERR=2020) 350 - IF(STDSTR('INPUT'))THEN 351 - NWORD=0 352 - REWIND(UNIT=5) 353 - RETURN 354 - ELSE 355 - PRINT *,' ------ INPGET MESSAGE : EOF on standard', 356 - - ' input ; end of program execution.' 357 - CALL QUIT 358 - ENDIF 0 359-+ +SELF. 360 - * Next, EOF on switched input. 361 - ELSEIF(LUN.EQ.12)THEN 362 - NWORD=0 363 - RETURN 364 - * And finally EOF on alternate input. 365 - ELSE 366 - CALL STRBUF('READ',LUNSTR(LUN,1),FILE,NC,IFAIL) 367 - PRINT *,' ------ INPGET MESSAGE : End of file reached on '// 368 - - FILE(1:NC)//',' 369 - CLOSE(UNIT=LUN,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 370 - CALL STRBUF('DELETE',LUNSTR(LUN,1),FILE,NC,IFAIL) 371 - CALL STRBUF('DELETE',LUNSTR(LUN,2),EOFSTR,NCEOF,IFAIL) 372 - CALL STRBUF('DELETE',LUNSTR(LUN,3),ARGSTR,NCARG,IFAIL) 373 - IF(LUN.EQ.20)LUN=5 374 - IF(LUN.GT.20)LUN=LUN-1 375 - CALL STRBUF('READ',LUNSTR(LUN,1),FILE,NC,IFAIL) 376 - CALL STRBUF('READ',LUNSTR(LUN,2),EOFSTR,NCEOF,IFAIL) 377 - CALL STRBUF('READ',LUNSTR(LUN,3),ARGSTR,NCARG,IFAIL) 378 - PRINT *,' input will continue'// 379 - - ' from '//FILE(1:NC)//' until '//EOFSTR(1:NCEOF)//'.' 380 - GLBVAL(6)=LUNSTR(LUN,1) 381 - GOTO 30 382 - ENDIF 383 - *** I/O error reading the input, stop if on unit 5, else close. 384 - 2010 CONTINUE 385 - CALL STRBUF('READ',LUNSTR(LUN,1),FILE,NC,IFAIL) 386 - PRINT *,' ###### INPGET ERROR : I/O error detected on '// 387 - - FILE(1:NC)//',' 388 - CALL INPIOS(IOS) 1 48 P=INPUT D=INPGET 5 PAGE 45 389 - IF(LUN.NE.5)THEN 390 - CALL STRBUF('DELETE',LUNSTR(LUN,1),FILE,NC,IFAIL) 391 - CALL STRBUF('DELETE',LUNSTR(LUN,2),EOFSTR,NCEOF,IFAIL) 392 - CALL STRBUF('DELETE',LUNSTR(LUN,3),ARGSTR,NCARG,IFAIL) 393 - CLOSE(UNIT=LUN,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 394 - IF(LUN.EQ.20)LUN=5 395 - IF(LUN.GT.20)LUN=LUN-1 396 - CALL STRBUF('READ',LUNSTR(LUN,1),FILE,NC,IFAIL) 397 - CALL STRBUF('READ',LUNSTR(LUN,2),EOFSTR,NCEOF,IFAIL) 398 - CALL STRBUF('READ',LUNSTR(LUN,3),ARGSTR,NCARG,IFAIL) 399 - PRINT *,' file closed, reading'// 400 - - ' from '//FILE(1:NC)//' until '//EOFSTR(1:NCEOF)//'.' 401 - GLBVAL(6)=LUNSTR(LUN,1) 402 - GOTO 30 403 - ELSE 404 - PRINT *,' end of program execution.' 405 - CALL QUIT 406 - ENDIF 407 - *** Recording errors. 408 - 2020 CONTINUE 409 - PRINT *,' ###### INPGET ERROR : Error while recording input'// 410 - - ' statements; recording stopped.' 411 - LINREC=.FALSE. 412 - CALL INPIOS(IOS) 413 - GOTO 30 414 - *** Error closing an alternate input file. 415 - 2030 CONTINUE 416 - CALL STRBUF('READ',LUNSTR(LUN,1),FILE,NC,IFAIL) 417 - PRINT *,' ###### INPGET ERROR : Unable to close '//FILE(1:NC)// 418 - - ' ; further alternative input may cause problems.' 419 - CALL STRBUF('DELETE',LUNSTR(LUN,1),FILE,NC,IFAIL) 420 - CALL STRBUF('DELETE',LUNSTR(LUN,2),EOFSTR,NCEOF,IFAIL) 421 - CALL STRBUF('DELETE',LUNSTR(LUN,3),ARGSTR,NCARG,IFAIL) 422 - CALL INPIOS(IOS) 423 - IF(LUN.EQ.20)LUN=5 424 - IF(LUN.GT.20)LUN=LUN-1 425 - GLBVAL(6)=LUNSTR(LUN,1) 426 - GOTO 30 427 - END 49 GARFIELD ================================================== P=INPUT D=INPGLB 1 ============================ 0 + +DECK,INPGLB. 1 - SUBROUTINE INPGLB 2 - *----------------------------------------------------------------------- 3 - * INPGLB - Updates the table of global variables. 4 - * (Last changed on 29/ 3/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,ALGDATA. 9.- +SEQ,GLOBALS. 10.- +SEQ,PRINTPLOT. 11 - CHARACTER*(MXINCH) STRING,INDSTR 12 - CHARACTER*40 VALUE 13 - CHARACTER*10 MODE 14 - LOGICAL USE(MXVAR) 15 - INTEGER MODRES(1),NCIND,NCSTR,NC,NWORD,I,IGLB,IENTNO,IENTRY, 16 - - ILAST,IFAIL,IEXTR,NNRES,ITEMP,ISIZ(1) 17 - REAL RES(1) 18 - *** Check number of arguments. 19 - CALL INPNUM(NWORD) 20 - * No arguments, listing required. 21 - IF(NWORD.EQ.1)THEN 22 - WRITE(LUNOUT,'(/2X,''GLOBAL VARIABLES CURRENTLY DEFINED''// 23 - - 2X,'' No Name Mode Value''/)') 24 - DO 40 I=1,NGLB 25 - IF(GLBMOD(I).EQ.1)THEN 26 - MODE='String' 27 - ELSEIF(GLBMOD(I).EQ.2)THEN 28 - MODE='Number' 29 - ELSEIF(GLBMOD(I).EQ.3)THEN 30 - MODE='Logical' 31 - ELSEIF(GLBMOD(I).EQ.4)THEN 32 - MODE='Histogram' 33 - ELSEIF(GLBMOD(I).EQ.5)THEN 34 - MODE='Matrix' 35 - ELSEIF(GLBMOD(I).EQ.0)THEN 36 - MODE='Undefined' 37 - ELSE 38 - MODE='# Unknown' 39 - ENDIF 40 - CALL OUTFMT(GLBVAL(I),GLBMOD(I),VALUE,NC,'LEFT') 41 - WRITE(LUNOUT,'(2X,I3,5X,A10,5X,A10,5X,A)') 42 - - I,GLBVAR(I),MODE,VALUE(1:NC) 43 - 40 CONTINUE 44 - WRITE(LUNOUT,'(/2X,''Note: Variables 1 through 4 are'', 45 - - '' system defined.''/)') 46 - RETURN 47 - ENDIF 48 - *** Pick up the name of the variable. 49 - CALL INPSTR(2,2,STRING,NC) 50 - * Find out whether this is a matrix indexing expression. 51 - IF(INDEX(STRING(1:NC),'[').GT.1.AND.STRING(NC:NC).EQ.']')THEN 52 - NCSTR=INDEX(STRING(1:NC),'[')-1 53 - INDSTR=STRING(NCSTR+1:NC) 54 - NCIND=NC-NCSTR 55 - ELSE 56 - NCSTR=NC 57 - INDSTR=' ' 58 - NCIND=0 59 - ENDIF 60 - * Check the name starts with a character. 61 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',STRING(1:1)).EQ.0)THEN 62 - PRINT *,' !!!!!! INPGLB WARNING : The variable name does'// 63 - - ' not start with a character.' 1 49 P=INPUT D=INPGLB 2 PAGE 46 64 - RETURN 65 - ENDIF 66 - * Check for illegal characters. 67 - DO 30 I=1,NCSTR 68 - IF(INDEX('+-*/&|<=#>^ ,.:;([{)]}''"`',STRING(I:I)).NE.0)THEN 69 - PRINT *,' !!!!!! INPGLB WARNING : The variable name'// 70 - - ' contains at least 1 illegal character; ignored.' 71 - RETURN 72 - ENDIF 73 - 30 CONTINUE 74 - * Make sure the name is not empty. 75 - IF(STRING.EQ.' '.OR.NCSTR.LT.1)THEN 76 - PRINT *,' !!!!!! INPGLB WARNING : The variable name'// 77 - - ' is empty; definition is ignored.' 78 - RETURN 79 - ENDIF 80 - * Warn if the name is longer than 10 characters. 81 - IF(NCSTR.GT.10)PRINT *,' !!!!!! INPGLB WARNING : The variable'// 82 - - ' name is truncated to the first 10 characters.' 83 - *** Scan the table, add an entry if needed. 84 - DO 10 I=1,NGLB 85 - IF(GLBVAR(I).EQ.STRING(1:MAX(1,MIN(10,NCSTR))))THEN 86 - IF(NCIND.NE.0.AND.GLBMOD(I).NE.5)THEN 87 - PRINT *,' !!!!!! INPGLB WARNING : '//STRING(1:NCSTR)// 88 - - ' is not of type Matrix; indexing not permitted.' 89 - RETURN 90 - ENDIF 91 - IGLB=I 92 - GOTO 20 93 - ENDIF 94 - 10 CONTINUE 95 - * If a submatrix, the variables must have been defined before. 96 - IF(NCIND.NE.0)THEN 97 - PRINT *,' !!!!!! INPGLB WARNING : '//STRING(1:NCSTR)// 98 - - ' is not a declared Matrix; indexing not permitted.' 99 - RETURN 100 - ELSEIF(NGLB.GE.MXVAR)THEN 101 - PRINT *,' !!!!!! INPGLB WARNING : No room to add another'// 102 - - ' global variable; definition ignored.' 103 - RETURN 104 - ENDIF 105 - NGLB=NGLB+1 106 - IGLB=NGLB 107 - GLBVAR(NGLB)=STRING(1:MAX(1,MIN(10,NCSTR))) 108 - GLBMOD(NGLB)=0 109 - * Ensure that this variable is not a system variable. 110 - 20 CONTINUE 111 - IF(IGLB.LE.4)THEN 112 - PRINT *,' !!!!!! INPGLB WARNING : This variable may'// 113 - - ' not be user redefined.' 114 - RETURN 115 - ENDIF 116 - *** Only 2 arguments: reset. 117 - IF(NWORD.EQ.2)THEN 118 - IF(NCIND.EQ.0)THEN 119 - GLBMOD(IGLB)=0 120 - GLBVAL(IGLB)=0 121 - ELSE 122 - PRINT *,' !!!!!! INPGLB WARNING : Partial reset of'// 123 - - ' matrices is not permitted ; ignored.' 124 - ENDIF 125 - RETURN 126 - ENDIF 127 - *** Translation of the expression, fetch the string. 128 - CALL INPSTR(3,NWORD,STRING,NC) 129 - ** Translate for the case with indexing. 130 - IF(NCIND.NE.0)THEN 131 - * Translate expression. 132 - CALL ALGPRE('('//STRING(1:NC)//')'//INDSTR(1:NCIND), 133 - - NC+NCIND+2,GLBVAR,NGLB,NNRES,USE,IENTRY,IFAIL) 134 - * Check validity. 135 - IF(IFAIL.NE.0)THEN 136 - PRINT *,' !!!!!! INPGLB WARNING : Unable to process'// 137 - - ' the indexing expression; global not assigned.' 138 - CALL ALGCLR(IENTRY) 139 - RETURN 140 - ELSEIF(NNRES.NE.1)THEN 141 - PRINT *,' !!!!!! INPGLB WARNING : Indexing doesn''t'// 142 - - ' lead to 1 result; global not assigned.' 143 - CALL ALGCLR(IENTRY) 144 - RETURN 145 - ENDIF 146 - * Locate the entry point number. 147 - IENTNO=0 148 - DO 50 I=1,NALGE 149 - IF(ALGENT(I,1).EQ.IENTRY.AND.ALGENT(I,3).EQ.1)IENTNO=I 150 - 50 CONTINUE 151 - IF(IENTNO.EQ.0)THEN 152 - PRINT *,' !!!!!! INPGLB WARNING : No valid indexing'// 153 - - ' entry point found; global not assigned.' 154 - CALL ALGCLR(IENTRY) 155 - RETURN 156 - ENDIF 157 - * Locate the final EXTRACT_SUBMATRIX call. 158 - DO 60 I=ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1, 159 - - ALGENT(IENTNO,5)+2,-1 160 - IF(INS(I,1).EQ.-80.AND.INS(I,2).EQ.9.AND. 161 - - INS(I-1,2).EQ.8.AND.INS(I-2,2).EQ.8)THEN 162 - IEXTR=I 163 - GOTO 70 164 - ENDIF 165 - 60 CONTINUE 166 - PRINT *,' !!!!!! INPGLB WARNING : Instruction list'// 167 - - ' tail not as expected.' 168 - CALL ALGCLR(IENTRY) 169 - RETURN 1 49 P=INPUT D=INPGLB 3 PAGE 47 170 - 70 CONTINUE 171 - * Store the location of the last instruction. 172 - ILAST=ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 173 - * Store reference to temporary matrix. 174 - ITEMP=INS(IEXTR-2,3) 175 - * Replace result and return by DELETE_MATRIX on temporary matrix. 176 - INS(ILAST-1,1)= 0 177 - INS(ILAST-1,2)= 8 178 - INS(ILAST-1,3)=ITEMP 179 - INS(ILAST-1,4)= 1 180 - INS(ILAST ,1)=-86 181 - INS(ILAST ,2)= 9 182 - INS(ILAST ,3)= 1 183 - INS(ILAST ,4)= 0 184 - * Replace EXTRACT_SUBMATRIX by STORE_SUBMATRIX. 185 - INS(IEXTR ,1)=-81 186 - * Exchange the in/out matrices, assign to global, fix protections. 187 - INS(IEXTR-1,1)= 3 188 - INS(IEXTR-1,3)=INS(IEXTR-2,3) 189 - INS(IEXTR-2,1)= 0 190 - INS(IEXTR-2,3)=IGLB 191 - *** In debug mode, print the list. 192 - IF(LDEBUG)THEN 193 - WRITE(LUNOUT,'('' ++++++ INPGLB DEBUG : List'', 194 - - '' after processing indexing calls:'')') 195 - CALL ALGPRT(ALGENT(IENTNO,5),ALGENT(IENTNO,5)+ 196 - - ALGENT(IENTNO,6)-1) 197 - ENDIF 198 - ** Translate for the case without indexing. 199 - ELSE 200 - CALL ALGPRE(STRING(1:NC),NC, 201 - - GLBVAR,NGLB,NNRES,USE,IENTRY,IFAIL) 202 - * Check validity. 203 - IF(IFAIL.NE.0)THEN 204 - PRINT *,' !!!!!! INPGLB WARNING : Unable to process'// 205 - - ' the expression; global not assigned.' 206 - CALL ALGCLR(IENTRY) 207 - RETURN 208 - ELSEIF(NNRES.NE.1)THEN 209 - PRINT *,' !!!!!! INPGLB WARNING : Formula doesn''t'// 210 - - ' lead to 1 result; global not assigned.' 211 - CALL ALGCLR(IENTRY) 212 - RETURN 213 - ENDIF 214 - * No temporary matrix. 215 - ITEMP=0 216 - ENDIF 217 - *** Evaluate. 218 - CALL TIMEL(GLBVAL(1)) 219 - CALL ALGEXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,1,IFAIL) 220 - * Error messages ? 221 - CALL ALGERR 222 - * If failed, return. 223 - IF(IFAIL.NE.0)THEN 224 - PRINT *,' !!!!!! INPGLB WARNING : Unable to evaluate'// 225 - - ' the expression; definition ignored.' 226 - ISIZ(1)=1 227 - IF(NCIND.NE.0)CALL MATADM('DELETE',NINT(REG(ITEMP)), 228 - - 1,ISIZ,2,IFAIL) 229 - CALL ALGCLR(IENTRY) 230 - RETURN 231 - ENDIF 232 - * Store the reference or the value itself. 233 - IF(NCIND.EQ.0)THEN 234 - IF((MODRES(1).EQ.1.OR.MODRES(1).EQ.4.OR.MODRES(1).EQ.5).AND. 235 - - MODRES(1).EQ.GLBMOD(IGLB).AND. 236 - - NINT(GLBVAL(IGLB)).EQ.NINT(RES(1)))THEN 237 - GLBVAL(IGLB)=RES(1) 238 - GLBMOD(IGLB)=MODRES(1) 239 - ELSE 240 - CALL ALGREU(NINT(GLBVAL(IGLB)),GLBMOD(IGLB),0) 241 - GLBVAL(IGLB)=RES(1) 242 - GLBMOD(IGLB)=MODRES(1) 243 - ENDIF 244 - ENDIF 245 - * Remove the entry point. 246 - CALL ALGCLR(IENTRY) 247 - END 50 GARFIELD ================================================== P=INPUT D=INPIFT 1 ============================ 0 + +DECK,INPIFT. 1 - SUBROUTINE INPIFT(REREAD,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * INPIFT - Checks IF structures outside a DO loop. 4 - * INPIFQ - Tells the status of the current level and one level below. 5 - * (Last changed on 14/ 4/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,GLOBALS. 10.- +SEQ,PRINTPLOT. 11 - INTEGER TRACIF(0:MXILVL,2),INPCMP,CIFLVL,I,IFAIL,NWORD,IENTRY,NC, 12 - - MODRES(1),NRES,NCPRM,ITHEN 13 - LOGICAL USE(MXVAR),ACTIVE(0:MXILVL),REREAD,IFCOND,ACT1,ACT2 14 - CHARACTER*(MXINCH) STRING 15 - CHARACTER*13 PROMPT 16 - REAL RES(1) 17 - EXTERNAL INPCMP 0 18-+ +SELF,IF=SAVE. 19 - SAVE TRACIF,CIFLVL,ACTIVE 1 50 P=INPUT D=INPIFT 2 PAGE 48 20-+ +SELF. 21 - *** Initial state. 22 - DATA CIFLVL /0/, ACTIVE(0) /.TRUE./ 23 - DATA (TRACIF(0,I),I=1,2) /0,0/ 24 - *** Number of words is needed frequently. 25 - CALL INPNUM(NWORD) 26 - * Locate the THEN, if there is one. 27 - DO 10 I=1,NWORD 28 - IF(INPCMP(I,'THEN').NE.0)THEN 29 - ITHEN=I 30 - GOTO 20 31 - ENDIF 32 - 10 CONTINUE 33 - ITHEN=0 34 - 20 CONTINUE 35 - * Would usually work. 36 - IFAIL=0 37 - REREAD=.FALSE. 38 - *** This routine should not touch a start of DO loop. 39 - IF(INPCMP(1,'IF').NE.0.AND.ITHEN.NE.0.AND. 40 - - INPCMP(NWORD,'DO').NE.0.AND.NWORD.GT.ITHEN)THEN 41 - RETURN 42 - *** Ensure that THEN does not follow IF immediately. 43 - ELSEIF((INPCMP(1,'IF').NE.0.OR.INPCMP(1,'ELSEIF').NE.0).AND. 44 - - ITHEN.LE.2)THEN 45 - PRINT *,' !!!!!! INPIFT WARNING : Empty clause in an IF'// 46 - - ' or ELSEIF line; line ignored.' 47 - IFAIL=1 48 - *** Check whether this is an IF-line. 49 - ELSEIF(NWORD.GT.ITHEN.AND.INPCMP(1,'IF').NE.0.AND.ITHEN.NE.0)THEN 50 - * Active area, see what the condition looks like. 51 - IF(ACTIVE(CIFLVL))THEN 52 - CALL INPSTR(2,ITHEN-1,STRING,NC) 53 - CALL ALGPRE(STRING(1:NC),NC,GLBVAR,NGLB,NRES, 54 - - USE,IENTRY,IFAIL) 55 - IF(IFAIL.NE.0.OR.NRES.NE.1)THEN 56 - PRINT *,' !!!!!! INPIFT WARNING : Failed to'// 57 - - ' translate condition of IF-line;'// 58 - - ' assumed not to hold.' 59 - IFCOND=.FALSE. 60 - ELSE 61 - CALL TIMEL(GLBVAL(1)) 62 - CALL ALGEXE(IENTRY,GLBVAL,GLBMOD,NGLB, 63 - - RES,MODRES,NRES,IFAIL) 64 - IF(IFAIL.EQ.0.AND.MODRES(1).NE.3)THEN 65 - PRINT *,' !!!!!! INPIFT WARNING : '// 66 - - STRING(1:NC)//' does not evaluate'// 67 - - ' to a logical; assumed not to hold.' 68 - ELSEIF(IFAIL.EQ.0.AND.ABS(RES(1)).LT.1.0E-5)THEN 69 - IFCOND=.FALSE. 70 - ELSEIF(IFAIL.EQ.0.AND.ABS(RES(1)-1).LT.1.0E-5)THEN 71 - IFCOND=.TRUE. 72 - ELSE 73 - PRINT *,' !!!!!! INPIFT WARNING : Failed'// 74 - - ' to evaluate '//STRING(1:NC)// 75 - - ' ; assumed not to hold.' 76 - IFCOND=.FALSE. 77 - ENDIF 78 - ENDIF 79 - CALL ALGCLR(IENTRY) 80 - * If the condition holds, delete the first words and have executed. 81 - IF(IFCOND)THEN 82 - DO 30 I=ITHEN,1,-1 83 - CALL INPDEL(I) 84 - 30 CONTINUE 85 - NWORD=NWORD-ITHEN 86 - REREAD=.FALSE. 87 - * If not, just read the new line. 88 - ELSE 89 - REREAD=.TRUE. 90 - ENDIF 91 - * Inactive area, also read a new line no matter the condition. 92 - ELSE 93 - REREAD=.TRUE. 94 - ENDIF 95 - *** Check whether this is an IF block piece. 96 - ELSEIF(INPCMP(1,'IF').NE.0.AND.ITHEN.NE.0)THEN 97 - * Check whether we may still increase the IF level. 98 - IF(CIFLVL.GE.MXILVL)THEN 99 - PRINT *,' !!!!!! INPIFT WARNING : The IF blocks'// 100 - - ' are nested too deep; IF ignored.' 101 - IFAIL=1 102 - ELSE 103 - * Check whether this is the first IF, if so add prompt. 104 - IF(CIFLVL.EQ.0)CALL INPPRM('If','ADD') 105 - * Increment level counter. 106 - CIFLVL=CIFLVL+1 107 - * Add the new block to the trace. 108 - TRACIF(CIFLVL,1)=1 109 - TRACIF(CIFLVL,2)=0 110 - * The activity starts out the same as at the previous level. 111 - ACTIVE(CIFLVL)=ACTIVE(CIFLVL-1) 112 - * If we are inside an accepted region, evaluate and execute. 113 - IF(ACTIVE(CIFLVL))THEN 114 - CALL INPSTR(2,ITHEN-1,STRING,NC) 115 - CALL ALGPRE(STRING(1:NC),NC,GLBVAR,NGLB,NRES, 116 - - USE,IENTRY,IFAIL) 117 - IF(IFAIL.NE.0.OR.NRES.NE.1)THEN 118 - PRINT *,' !!!!!! INPIFT WARNING : Failed'// 119 - - ' to translate condition of IF-block;'// 120 - - ' assumed not to hold.' 121 - IFCOND=.FALSE. 122 - ELSE 123 - CALL TIMEL(GLBVAL(1)) 124 - CALL ALGEXE(IENTRY,GLBVAL,GLBMOD,NGLB, 125 - - RES,MODRES,NRES,IFAIL) 1 50 P=INPUT D=INPIFT 3 PAGE 49 126 - IF(IFAIL.EQ.0.AND.MODRES(1).NE.3)THEN 127 - PRINT *,' !!!!!! INPIFT WARNING : '// 128 - - STRING(1:NC)//' does not'// 129 - - ' evaluate to a logical;'// 130 - - ' assumed not to hold.' 131 - ELSEIF(IFAIL.EQ.0.AND. 132 - - ABS(RES(1)).LT.1.0E-5)THEN 133 - IFCOND=.FALSE. 134 - ELSEIF(IFAIL.EQ.0.AND. 135 - - ABS(RES(1)-1).LT.1.0E-5)THEN 136 - IFCOND=.TRUE. 137 - ELSE 138 - PRINT *,' !!!!!! INPIFT WARNING :'// 139 - - ' Failed to evaluate '// 140 - - STRING(1:NC)//'; assumed not'// 141 - - ' to hold.' 142 - IFCOND=.FALSE. 143 - ENDIF 144 - ENDIF 145 - CALL ALGCLR(IENTRY) 146 - * If the condition holds, mark block as executed. 147 - IF(IFCOND)THEN 148 - TRACIF(CIFLVL,2)=1 149 - * Otherwise mark this area is inactive. 150 - ELSE 151 - ACTIVE(CIFLVL)=.FALSE. 152 - ENDIF 153 - ENDIF 154 - ENDIF 155 - * Whatever happened, read a new line. 156 - REREAD=.TRUE. 157 - *** Ensure this is not an attempt at an ELSEIF ... THEN command. 158 - ELSEIF(NWORD.GT.ITHEN.AND.INPCMP(1,'ELSEIF').NE.0.AND. 159 - - ITHEN.NE.0)THEN 160 - PRINT *,' !!!!!! INPIFT WARNING : An ELSEIF line can not'// 161 - - ' have a command on it; line ignored.' 162 - IFAIL=1 163 - *** Check whether this is an ELSEIF branch. 164 - ELSEIF(INPCMP(1,'ELSEIF').NE.0.AND.ITHEN.NE.0)THEN 165 - * Check whether we are really inside an IF block. 166 - IF(CIFLVL.LE.0)THEN 167 - PRINT *,' !!!!!! INPIFT WARNING : An ELSEIF may only'// 168 - - ' occur inside an IF-block; ignored.' 169 - IFAIL=1 170 - * Check this ELSEIF was not preceded by an ELSE. 171 - ELSEIF(TRACIF(CIFLVL,1).GE.3)THEN 172 - PRINT *,' !!!!!! INPIFT WARNING : An ELSEIF may not'// 173 - - ' follow an ELSE in the same IF-block; ignored.' 174 - IFAIL=1 175 - * Already executed IF block. 176 - ELSEIF(TRACIF(CIFLVL,2).EQ.1)THEN 177 - ACTIVE(CIFLVL)=.FALSE. 178 - * Check condition if embedding block is active and block not yet ex. 179 - ELSEIF(ACTIVE(CIFLVL-1).AND.TRACIF(CIFLVL,2).EQ.0)THEN 180 - CALL INPSTR(2,ITHEN-1,STRING,NC) 181 - CALL ALGPRE(STRING(1:NC),NC,GLBVAR,NGLB,NRES, 182 - - USE,IENTRY,IFAIL) 183 - IF(IFAIL.NE.0.OR.NRES.NE.1)THEN 184 - PRINT *,' !!!!!! INPIFT WARNING : Failed to'// 185 - - ' translate condition of an ELSEIF'// 186 - - ' line; assumed not to hold.' 187 - IFCOND=.FALSE. 188 - ELSE 189 - CALL TIMEL(GLBVAL(1)) 190 - CALL ALGEXE(IENTRY,GLBVAL,GLBMOD,NGLB, 191 - - RES,MODRES,NRES,IFAIL) 192 - IF(IFAIL.EQ.0.AND.MODRES(1).NE.3)THEN 193 - PRINT *,' !!!!!! INPIFT WARNING : '// 194 - - STRING(1:NC)//' does not evaluate'// 195 - - ' to a logical; assumed not to hold.' 196 - ELSEIF(IFAIL.EQ.0.AND.ABS(RES(1)).LT.1.0E-5)THEN 197 - IFCOND=.FALSE. 198 - ELSEIF(IFAIL.EQ.0.AND.ABS(RES(1)-1).LT.1.0E-5)THEN 199 - IFCOND=.TRUE. 200 - ELSE 201 - PRINT *,' !!!!!! INPIFT WARNING : Failed'// 202 - - ' to evaluate '//STRING(1:NC)// 203 - - ' ; assumed not to hold.' 204 - IFCOND=.FALSE. 205 - ENDIF 206 - ENDIF 207 - CALL ALGCLR(IENTRY) 208 - * If the condition holds, make active and mark block as executed. 209 - IF(IFCOND)THEN 210 - TRACIF(CIFLVL,2)=1 211 - ACTIVE(CIFLVL)=.TRUE. 212 - * Otherwise mark area as inactive. 213 - ELSE 214 - ACTIVE(CIFLVL)=.FALSE. 215 - ENDIF 216 - ENDIF 217 - * Remember we saw an ELSEIF line but don't overrule an ELSE. 218 - TRACIF(CIFLVL,1)=MAX(2,TRACIF(CIFLVL,1)) 219 - * Always read a new line. 220 - REREAD=.TRUE. 221 - *** Warn for an ELSE outside an IF block. 222 - ELSEIF(INPCMP(1,'ELSE').NE.0.AND.CIFLVL.LE.0)THEN 223 - PRINT *,' !!!!!! INPIFT WARNING : An ELSE may only occur'// 224 - - ' inside an IF-block; line ignored.' 225 - IFAIL=1 226 - *** Warn for an ELSE with additional words. 227 - ELSEIF(INPCMP(1,'ELSE').NE.0.AND.NWORD.GT.1)THEN 228 - PRINT *,' !!!!!! INPIFT WARNING : An ELSE line may not'// 229 - - ' have a command on it; line ignored.' 230 - IFAIL=1 231 - *** An ELSE part of an IF block. 1 50 P=INPUT D=INPIFT 4 PAGE 50 232 - ELSEIF(INPCMP(1,'ELSE').NE.0)THEN 233 - * Check this ELSEIF was not preceded by an ELSE. 234 - IF(TRACIF(CIFLVL,1).GE.3)THEN 235 - PRINT *,' !!!!!! INPIFT WARNING : There may not be'// 236 - - ' two ELSE parts in the same IF-block; ignored.' 237 - IFAIL=1 238 - * Already executed IF block. 239 - ELSEIF(TRACIF(CIFLVL,2).EQ.1)THEN 240 - ACTIVE(CIFLVL)=.FALSE. 241 - * Execute active area of not yet executed IF block. 242 - ELSEIF(ACTIVE(CIFLVL-1).AND.TRACIF(CIFLVL,2).EQ.0)THEN 243 - TRACIF(CIFLVL,2)=1 244 - ACTIVE(CIFLVL)=.TRUE. 245 - ENDIF 246 - * Remember we saw an ELSE line but don't overrule an ENDIF. 247 - TRACIF(CIFLVL,1)=MAX(3,TRACIF(CIFLVL,1)) 248 - * Always read a new line. 249 - REREAD=.TRUE. 250 - *** Warn for an ENDIF line outside an IF block. 251 - ELSEIF(INPCMP(1,'ENDIF').NE.0.AND.CIFLVL.LE.0)THEN 252 - PRINT *,' !!!!!! INPIFT WARNING : An ENDIF may only occur'// 253 - - ' inside an IF-block; line ignored.' 254 - IFAIL=1 255 - *** Warn for an attempt of an ENDIF with additional words. 256 - ELSEIF(INPCMP(1,'ENDIF').NE.0.AND.NWORD.GT.1)THEN 257 - PRINT *,' !!!!!! INPIFT WARNING : An ENDIF line may not'// 258 - - ' have a command on it; line ignored.' 259 - IFAIL=1 260 - *** The ENDIF part of a block. 261 - ELSEIF(INPCMP(1,'ENDIF').NE.0)THEN 262 - * Check whether we are really inside an IF block. 263 - IF(CIFLVL.LE.0)THEN 264 - PRINT *,' !!!!!! INPIFT WARNING : An ENDIF may only'// 265 - - ' occur at the end of an IF-block; ignored.' 266 - IFAIL=1 267 - * In other cases, just go back by one level. 268 - ELSE 269 - TRACIF(CIFLVL,1)=4 270 - CIFLVL=CIFLVL-1 271 - CALL INPPRM(' ','BACK') 272 - ENDIF 273 - * Reread always. 274 - REREAD=.TRUE. 275 - *** Any other line. 276 - ELSE 277 - REREAD=.NOT.ACTIVE(CIFLVL) 278 - ENDIF 279 - *** Update the prompt. 280 - PROMPT=' ' 281 - IF(CIFLVL.GT.0)THEN 282 - WRITE(PROMPT,'(''If_'',I10)') CIFLVL 283 - NCPRM=0 284 - DO 400 I=1,13 285 - IF(PROMPT(I:I).NE.' ')THEN 286 - NCPRM=NCPRM+1 287 - PROMPT(NCPRM:NCPRM)=PROMPT(I:I) 288 - ENDIF 289 - 400 CONTINUE 290 - CALL INPPRM(' ','BACK') 291 - CALL INPPRM(PROMPT(1:MAX(1,NCPRM)),'ADD') 292 - ENDIF 293 - *** Normal end of this routine. 294 - RETURN 295 - *** Entry for quick check whether substitution must be carried out. 296 - ENTRY INPIFQ(ACT1,ACT2) 297 - ACT1=ACTIVE(MAX(0,CIFLVL-1)) 298 - ACT2=ACTIVE(CIFLVL) 299 - END 51 GARFIELD ================================================== P=INPUT D=INPINT 1 ============================ 0 + +DECK,INPINT. 1 - SUBROUTINE INPINT 2 - *----------------------------------------------------------------------- 3 - * INPINT - Initialises the input routines. Determines the character 4 - * set being used (courtesy Carlo Mekenkamp, Leiden). 5 - * (Last changed on 7/11/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,INPUT. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,GLOBALS. 12 - LOGICAL EXIST 13 - INTEGER NCFILE,IFAIL 14 - CHARACTER*100 INFILE 0 15-+ +SELF,IF=UNIX. 16 - INTEGER I,NCHOME 17 - CHARACTER*80 HOME 0 18-+ +SELF. 19 - *** Initial input logical unit, first input file. 20 - LUN=5 21 - CALL STRBUF('STORE',LUNSTR(5,1),'Standard input',14,IFAIL) 22 - GLBVAR(6)='INPUT ' 23 - GLBMOD(6)=1 24 - GLBVAL(6)=LUNSTR(LUN,1) 25 - * EOF string. 26 - EOFSTR='EOF' 27 - NCEOF=3 28 - CALL STRBUF('STORE',LUNSTR(5,2),EOFSTR(1:NCEOF),NCEOF,IFAIL) 29 - * Input arguments have been set inside INIT. 30 - CALL STRBUF('STORE',LUNSTR(5,3),ARGSTR(1:NCARG),NCARG,IFAIL) 31 - *** Look for initialisation file. 1 51 P=INPUT D=INPINT 2 PAGE 51 32-+ +SELF,IF=CMS. 33 - INFILE='GARFINIT INPUT' 34 - NCFILE=14 35 - CALL DSNINQ(INFILE,NCFILE,EXIST) 0 36-+ +SELF,IF=VAX. 37 - INFILE='GARFINIT.DAT' 38 - NCFILE=12 39 - CALL DSNINQ(INFILE,NCFILE,EXIST) 40 - * If it is not found in the current directory, look at home. 41 - IF(.NOT.EXIST)THEN 42 - INFILE='SYS$LOGIN:GARFINIT.DAT' 43 - NCFILE=22 44 - CALL DSNINQ(INFILE,NCFILE,EXIST) 45 - ENDIF 0 46-+ +SELF,IF=UNIX. 47 - CALL GETENV('HOME',HOME) 48 - DO 10 I=LEN(HOME),1,-1 49 - IF(HOME(I:I).NE.' ')THEN 50 - NCHOME=I 51 - GOTO 20 52 - ENDIF 53 - 10 CONTINUE 54 - NCHOME=1 55 - 20 CONTINUE 56 - INFILE='garfinit' 57 - NCFILE=8 58 - CALL DSNINQ(INFILE,NCFILE,EXIST) 59 - IF(.NOT.EXIST)THEN 60 - INFILE=HOME(1:NCHOME)//'/garfinit' 61 - NCFILE=MIN(LEN(INFILE),NCHOME+9) 62 - CALL DSNINQ(INFILE,NCFILE,EXIST) 63 - ENDIF 64 - IF(.NOT.EXIST)THEN 65 - INFILE=HOME(1:NCHOME)//'/.garfinit' 66 - NCFILE=MIN(LEN(INFILE),NCHOME+10) 67 - CALL DSNINQ(INFILE,NCFILE,EXIST) 68 - ENDIF 69 - IF(.NOT.EXIST)THEN 70 - INFILE=HOME(1:NCHOME)//'/Garfield/Files/garfinit' 71 - NCFILE=MIN(LEN(INFILE),NCHOME+24) 72 - CALL DSNINQ(INFILE,NCFILE,EXIST) 73 - ENDIF 74 - IF(.NOT.EXIST)THEN 75 - INFILE=HOME(1:NCHOME)//'/Garfield/Files/.garfinit' 76 - NCFILE=MIN(LEN(INFILE),NCHOME+25) 77 - CALL DSNINQ(INFILE,NCFILE,EXIST) 78 - ENDIF 0 79-+ +SELF,IF=-CMS,IF=-VAX,IF=-UNIX. 80 - INFILE=' ' 81 - NCFILE=1 82 - EXIST=.FALSE. 0 83-+ +SELF. 84 - IF(EXIST.AND.LPROF)THEN 85 - LUN=20 86 - CALL DSNOPN(INFILE,NCFILE,LUN,'READ-FILE',IFAIL) 87 - IF(IFAIL.NE.0)THEN 88 - PRINT *,' !!!!!! INPINT WARNING : Opening '// 89 - - INFILE(1:NCFILE)//' failed; initialisation'// 90 - - 'not performed.' 91 - LUN=5 92 - ELSE 93 - CALL STRBUF('STORE',LUNSTR(20,1),INFILE,NCFILE,IFAIL) 94 - GLBVAL(6)=LUNSTR(LUN,1) 95 - EOFSTR='EOF' 96 - NCEOF=3 97 - CALL STRBUF('STORE',LUNSTR(20,2),EOFSTR(1:NCEOF),NCEOF, 98 - - IFAIL) 99 - ARGSTR=' ' 100 - NCARG=1 101 - CALL STRBUF('STORE',LUNSTR(20,3),ARGSTR(1:NCARG),NCARG, 102 - - IFAIL) 103 - CALL DSNLOG(INFILE(1:NCFILE),'Profile ', 104 - - 'Sequential','Read only ') 105 - ENDIF 106 - ENDIF 107 - *** Determine the character set being used by the computer: 0 108-+ +SELF,IF=APOLLO,UNIX,VAX. 109 - ICHSET=1 0 110-+ +SELF,IF=CMS,MVS. 111 - ICHSET=2 0 112-+ +SELF,IF=CDC. 113 - ICHSET=0 0 114-+ +SELF,IF=-APOLLO,IF=-CDC,IF=-CMS,IF=-MVS,IF=-UNIX,IF=-VAX. 115 - * in ASCII the codes for A and Z differ by 25, 116 - IF(ICHAR('Z')-ICHAR('A').EQ.25)THEN 117 - ICHSET=1 118 - IF(LDEBUG)PRINT *,' ++++++ INPINT DEBUG : Character', 119 - - ' is assumed to be ASCII.' 120 - * in EBCDIC the codes for A and Z differ by 40, 121 - ELSEIF(ICHAR('Z')-ICHAR('A').EQ.40)THEN 122 - ICHSET=2 123 - IF(LDEBUG)PRINT *,' ++++++ INPINT DEBUG : Character', 124 - - ' is assumed to be EBCDIC.' 125 - * otherwise do not change the case. 126 - ELSE 127 - PRINT *,' !!!!!! INPINT WARNING : Character set not known'// 128 - - ' recognised; lower case will not be translated.' 129 - ICHSET=0 1 51 P=INPUT D=INPINT 3 PAGE 52 130 - ENDIF 0 131-+ +SELF. 132 - *** Translation table initialisation. 133 - CALL INPTRI 0 134-+ +SELF,IF=UNIX. 135 - *** Default shell. 136 - CALL GETENV('SHELL',HOME) 137 - IF(HOME.EQ.' ')CALL GETENV('shell',HOME) 138 - DO 30 I=LEN(HOME),1,-1 139 - IF(HOME(I:I).NE.' ')THEN 140 - SHELL=HOME(1:I) 141 - NCSH=I 142 - GOTO 40 143 - ENDIF 144 - 30 CONTINUE 145 - SHELL='tcsh' 146 - NCSH=4 147 - 40 CONTINUE 0 148-+ +SELF,IF=-UNIX. 149 - SHELL='* No default shell *' 150 - NCSH=20 0 151-+ +SELF. 152 - *** Escape character (double because \ is a Unix escape). 153 - ESCAPE='\\' 154 - *** Initialise the prompt. 155 - PROMPT='Main' 156 - LPROM=.TRUE. 157 - NCPROM=4 158 - *** Start reading normal input and allow substitution. 159 - DOEXEC=.FALSE. 160 - DOREAD=.FALSE. 161 - *** Input recording. 162 - IF(LINREC)THEN 0 163-+ +SELF,IF=CMS. 164 - CALL DSNOPN('GARFLAST INPUT A',16,18,'WRITE-FILE',IFAIL) 165 - CALL DSNLOG('GARFLAST INPUT','Recording ', 166 - - 'Sequential','Write ') 0 167-+ +SELF,IF=VAX. 168 - CALL DSNOPN('GARFLAST.DAT',12,18,'WRITE-FILE',IFAIL) 169 - CALL DSNLOG('GARFLAST.DAT','Recording ', 170 - - 'Sequential','Write ') 0 171-+ +SELF,IF=UNIX. 172 - CALL DSNOPN('garflast.dat',12,18,'WRITE-FILE',IFAIL) 173 - CALL DSNLOG('garflast.dat','Recording ', 174 - - 'Sequential','Write ') 0 175-+ +SELF,IF=-CMS,IF=-VAX,IF=-UNIX. 176 - CALL DSNOPN('GARFLAST',8,18,'WRITE-FILE',IFAIL) 177 - CALL DSNLOG('GARFLAST','Recording ', 178 - - 'Sequential','Write ') 0 179-+ +SELF. 180 - IF(IFAIL.NE.0)THEN 181 - PRINT *,' !!!!!! INPINT WARNING : Opening the'// 182 - - ' recording file failed; recording cancelled.' 183 - LINREC=.FALSE. 184 - ELSEIF(LDEBUG)THEN 185 - PRINT *,' ++++++ INPINT DEBUG :'// 186 - - ' Recording has been enabled.' 187 - ENDIF 188 - ELSE 189 - IF(LDEBUG)PRINT *,' ++++++ INPINT DEBUG : Recording'// 190 - - ' has been disabled.' 191 - ENDIF 192 - END 52 GARFIELD ================================================== P=INPUT D=INPIOSOT 1 ============================ 0 + +DECK,INPIOSOT,IF=-VAX,IF=-APOLLO,IF=-IBMRT. 1 - SUBROUTINE INPIOS(IOS) 2 - *----------------------------------------------------------------------- 3 - * INPIOS - Prints details about the most recent Fortran error message. 4 - * Still to be provided for most non-Vax computers. 5 - *----------------------------------------------------------------------- 6.- +SEQ,PRINTPLOT. 7 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPIOS DEBUG : IOSTAT'', 8 - - '' return code:'',I8)') IOS 9 - END 53 GARFIELD ================================================== P=INPUT D=INPIOSAP 1 ============================ 0 + +DECK,INPIOSAP,IF=APOLLO. 1 - SUBROUTINE INPIOS(IOS) 2 - *----------------------------------------------------------------------- 3 - * INPIOS - Prints details about the most recent Fortran error message. 4 - * Version for Apollo computers. 5 - *----------------------------------------------------------------------- 6 - INTEGER*4 IOS 7 - %include '/sys/ins/fio.ins.ftn' 8 - CALL ERROR_$PRINT(IOS) 9 - END 54 GARFIELD ================================================== P=INPUT D=INPIOSVX 1 ============================ 0 + +DECK,INPIOSVX,IF=VAX. 1 - SUBROUTINE INPIOS(IOS) 2 - *----------------------------------------------------------------------- 3 - * INPIOS - Prints details about the most recent Fortran error message. 4 - * Version for Vax computers. 1 54 P=INPUT D=INPIOSVX 2 PAGE 53 5 - * (Last changed on 14/11/93.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,PRINTPLOT. 8 - character*256 message 9 - *** Fetch the error description. 10 - CALL ERRSNS(IERR,IRMS,ISTV,IUNIT,ICOND) 11 - call lib$sys_getmsg(irms,nc,message) 12 - *** Dump the data in DEBUG mode. 13 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPIOS DEBUG : Most'', 14 - - '' recent error:'',I3,'','',/, 15 - - 26X,''RMS completion status code (STS): '',I6,'','',/, 16 - - 26X,''RMS status value (STV): '',I6,'','',/,26X, 17 - - ''Logical unit on which the error occurred: '',I2,'','',/, 18 - - 26X,''VAX-11 condition value: '',I8,''.'')') 19 - - IERR,IRMS,ISTV,IUNIT,ICOND 20 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPIOS DEBUG : IOSTAT'', 21 - - '' error code received is '',I8)') IOS 22 - *** Interpret the error message. 23 - WRITE(LUNOUT,'('' ------ INPIOS MESSAGE : The RMS explanation'', 24 - - '' of the above error is:''/26X,A,''.'')') 25 - - message(INDEX(message,' ')+1:NC) 26 - END 55 GARFIELD ================================================== P=INPUT D=INPIOSIR 1 ============================ 0 + +DECK,INPIOSIR,IF=IBMRT. 1 - SUBROUTINE INPIOS(IOS) 2 - *----------------------------------------------------------------------- 3 - * INPIOS - Prints details about the most recent Fortran error message. 4 - * Version for IBM RT and SP2 computers, error messages from 5 - * XL Fortran for AIX Language Reference Version 3 Release 2. 6 - * (Last changed on 12/ 9/95.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*60 MESS 11 - INTEGER IOS 12 - *** Print an message according to the IOS value. 13 - IF(IOS.EQ.-4)THEN 14 - MESS='(EOR) End of record encountered, external READ.' 15 - ELSEIF(IOS.EQ.-2)THEN 16 - MESS='(EOF) End of file encountered for an internal READ.' 17 - ELSEIF(IOS.EQ.-1)THEN 18 - MESS='(EOF) End of file encountered during external READ.' 19 - ELSEIF(IOS.EQ.0)THEN 20 - MESS='(OK) I/O operation successfully completed.' 21 - ELSEIF(IOS.EQ.1)THEN 22 - MESS='(S) Non-existing record specified for a direct READ.' 23 - ELSEIF(IOS.EQ.2)THEN 24 - MESS='(S) End of file encountered during external WRITE.' 25 - ELSEIF(IOS.EQ.3)THEN 26 - MESS='(CNV) End of record on an unformatted file.' 27 - ELSEIF(IOS.EQ.4)THEN 28 - MESS='(CNV) End of record on a formatted external file.' 29 - ELSEIF(IOS.EQ.5)THEN 30 - MESS='(CNV) End of record on an internal file.' 31 - ELSEIF(IOS.EQ.6)THEN 32 - MESS='(S) OPEN with STATUS=OLD, but file not found.' 33 - ELSEIF(IOS.EQ.7)THEN 34 - MESS='(CNV) Format error in external list-directed input.' 35 - ELSEIF(IOS.EQ.8)THEN 36 - MESS='(CNV) Format error in internal list-directed input.' 37 - ELSEIF(IOS.EQ.9)THEN 38 - MESS='(CNV) List-directed or NAMELIST item too long.' 39 - ELSEIF(IOS.EQ.10)THEN 40 - MESS='(S) READ error on a direct access file.' 41 - ELSEIF(IOS.EQ.11)THEN 42 - MESS='(S) WRITE error on a direct access file.' 43 - ELSEIF(IOS.EQ.12)THEN 44 - MESS='(S) READ error on a sequential access file.' 45 - ELSEIF(IOS.EQ.13)THEN 46 - MESS='(S) WRITE error on a sequential access file.' 47 - ELSEIF(IOS.EQ.14)THEN 48 - MESS='(S) Error opening a file.' 49 - ELSEIF(IOS.EQ.15)THEN 50 - MESS='(S) Permanent I/O error encountered on a file.' 51 - ELSEIF(IOS.EQ.16)THEN 52 - MESS='(E) Invalid record specified for a direct I/O.' 53 - ELSEIF(IOS.EQ.17)THEN 54 - MESS='(E) I/O statement not allowed on direct file.' 55 - ELSEIF(IOS.EQ.18)THEN 56 - MESS='(E) Direct I/O attempted on an unconnected unit.' 57 - ELSEIF(IOS.EQ.19)THEN 58 - MESS='(E) Unformatted I/O attempted on a formatted file.' 59 - ELSEIF(IOS.EQ.20)THEN 60 - MESS='(E) Formatted I/O attempted on an unformatted file.' 61 - ELSEIF(IOS.EQ.21)THEN 62 - MESS='(E) Sequential I/O attempted on a direct file.' 63 - ELSEIF(IOS.EQ.22)THEN 64 - MESS='(E) Direct I/O attempted on a sequential file.' 65 - ELSEIF(IOS.EQ.23)THEN 66 - MESS='(E) Attempt to connect an already connected file.' 67 - ELSEIF(IOS.EQ.24)THEN 68 - MESS='(E) Specifiers of OPEN do not match file attributes.' 69 - ELSEIF(IOS.EQ.25)THEN 70 - MESS='(E) RECL specifier missing on OPEN for a direct file.' 71 - ELSEIF(IOS.EQ.26)THEN 72 - MESS='(E) RECL specified on an OPEN is negative.' 73 - ELSEIF(IOS.EQ.27)THEN 74 - MESS='(E) ACCESS specifier on an OPEN statement is invalid.' 75 - ELSEIF(IOS.EQ.28)THEN 76 - MESS='(E) FORM specifier on an OPEN statement is invalid.' 77 - ELSEIF(IOS.EQ.29)THEN 78 - MESS='(E) STATUS specifier on an OPEN statement is invalid.' 79 - ELSEIF(IOS.EQ.30)THEN 80 - MESS='(E) BLANK specifier on an OPEN statement is invalid.' 1 55 P=INPUT D=INPIOSIR 2 PAGE 54 81 - ELSEIF(IOS.EQ.31)THEN 82 - MESS='(E) FILE specifier on an OPEN or INQUIRE is invalid.' 83 - ELSEIF(IOS.EQ.32)THEN 84 - MESS='(E) STATUS=SCRATCH and file name specified on OPEN.' 85 - ELSEIF(IOS.EQ.33)THEN 86 - MESS='(E) STATUS=KEEP on CLOSE for a scratch file.' 87 - ELSEIF(IOS.EQ.34)THEN 88 - MESS='(E) Value of STATUS not valid on CLOSE.' 89 - ELSEIF(IOS.EQ.36)THEN 90 - MESS='(E) Invalid unit number specified in I/O statement.' 91 - ELSEIF(IOS.EQ.37)THEN 92 - MESS='(S) Dynamic memory allocation failure.' 93 - ELSEIF(IOS.EQ.38)THEN 94 - MESS='(S) REWIND error.' 95 - ELSEIF(IOS.EQ.39)THEN 96 - MESS='(S) ENDFILE error.' 97 - ELSEIF(IOS.EQ.40)THEN 98 - MESS='(S) BACKSPACE error.' 99 - ELSEIF(IOS.EQ.41)THEN 100 - MESS='(CNV) Valid logical input not found in external file.' 101 - ELSEIF(IOS.EQ.42)THEN 102 - MESS='(CNV) Valid logical input not found in internal file.' 103 - ELSEIF(IOS.EQ.43)THEN 104 - MESS='(CNV) Complex value not found in external READ.' 105 - ELSEIF(IOS.EQ.44)THEN 106 - MESS='(CNV) Complex value not found in internal READ.' 107 - ELSEIF(IOS.EQ.45)THEN 108 - MESS='(CNV) NAMELIST item of unknown or invalid type.' 109 - ELSEIF(IOS.EQ.46)THEN 110 - MESS='(CNV) NAMELIST item with invalid substring range.' 111 - ELSEIF(IOS.EQ.47)THEN 112 - MESS='(E) NAMELIST input has items of non-zero rank.' 113 - ELSEIF(IOS.EQ.48)THEN 114 - MESS='(E) NAMELIST input item with zero-sized array.' 115 - ELSEIF(IOS.EQ.49)THEN 116 - MESS='(CNV) Invalid delimited character string in input.' 117 - ELSEIF(IOS.EQ.53)THEN 118 - MESS='(F90) Mismatch between edit descriptor and item.' 119 - ELSEIF(IOS.EQ.56)THEN 120 - MESS='(CNV) Invalid digit in B, O or Z format input.' 121 - ELSEIF(IOS.EQ.58)THEN 122 - MESS='(E/F90) Format specification error.' 123 - ELSEIF(IOS.EQ.84)THEN 124 - MESS='(CNV) NAMELIST group header not found, external file.' 125 - ELSEIF(IOS.EQ.85)THEN 126 - MESS='(CNV) NAMELIST group header not found, internal file.' 127 - ELSEIF(IOS.EQ.86)THEN 128 - MESS='(CNV) Invalid NAMELIST input found in external file.' 129 - ELSEIF(IOS.EQ.87)THEN 130 - MESS='(CNV) Invalid NAMELIST input found in internal file.' 131 - ELSEIF(IOS.EQ.88)THEN 132 - MESS='(CNV) Invalid name found in NAMELIST input.' 133 - ELSEIF(IOS.EQ.90)THEN 134 - MESS='(CNV) Invalid character in NAMELIST group or item.' 135 - ELSEIF(IOS.EQ.91)THEN 136 - MESS='(CNV) Invalid NAMELIST input syntax.' 137 - ELSEIF(IOS.EQ.92)THEN 138 - MESS='(CNV) Invalid subscript list for NAMELIST input item.' 139 - ELSEIF(IOS.EQ.93)THEN 140 - MESS='(E) I/O statement not allowed on the error unit (0).' 141 - ELSEIF(IOS.EQ.94)THEN 142 - MESS='(CNV) Invalid repeat counter found in external input.' 143 - ELSEIF(IOS.EQ.95)THEN 144 - MESS='(CNV) Invalid repeat counter found in internal input.' 145 - ELSEIF(IOS.EQ.96)THEN 146 - MESS='(CNV) Integer overflow in input.' 147 - ELSEIF(IOS.EQ.97)THEN 148 - MESS='(CNV) Invalid decimal digit found in input.' 149 - ELSEIF(IOS.EQ.98)THEN 150 - MESS='(CNV) Input too long for B, Z or O formats.' 151 - ELSEIF(IOS.EQ.107)THEN 152 - MESS='(S) OPEN with STATUS=NEW and file exists already.' 153 - ELSEIF(IOS.EQ.110)THEN 154 - MESS='(E) Illegal edit descriptor in formatted I/O' 155 - ELSEIF(IOS.EQ.119)THEN 156 - MESS='(S) BACKSPACE attempted on a tape device.' 157 - ELSEIF(IOS.EQ.120)THEN 158 - MESS='(E) The NLWIDTH setting exceeds the record length.' 159 - ELSEIF(IOS.EQ.121)THEN 160 - MESS='(CNV) Output length of NAMELIST too long.' 161 - ELSEIF(IOS.EQ.122)THEN 162 - MESS='(S) Incomplete record encountered during direct READ.' 163 - ELSEIF(IOS.EQ.125)THEN 164 - MESS='(E) BLANK given on an OPEN for an unformatted file.' 165 - ELSEIF(IOS.EQ.127)THEN 166 - MESS='(E) POSITION given on an OPEN for a direct file.' 167 - ELSEIF(IOS.EQ.128)THEN 168 - MESS='(E) POSITION value given on an OPEN is not valid.' 169 - ELSEIF(IOS.EQ.129)THEN 170 - MESS='(E) ACTION value given on an OPEN is not valid.' 171 - ELSEIF(IOS.EQ.130)THEN 172 - MESS='(S) ACTION=READWRITE for an OPEN on a pipe.' 173 - ELSEIF(IOS.EQ.131)THEN 174 - MESS='(E) DELIM given on an OPEN for an unformatted file.' 175 - ELSEIF(IOS.EQ.132)THEN 176 - MESS='(E) DELIM value given on an OPEN is not valid.' 177 - ELSEIF(IOS.EQ.133)THEN 178 - MESS='(E) PAD given on an OPEN for an unformatted file.' 179 - ELSEIF(IOS.EQ.134)THEN 180 - MESS='(E) PAD value given on an OPEN is not valid.' 181 - ELSEIF(IOS.EQ.135)THEN 182 - MESS='(S) Call to an unsupported version of the XLF RTL.' 183 - ELSEIF(IOS.EQ.136)THEN 184 - MESS='(E) ADVANCE value given on a READ is not valid.' 185 - ELSEIF(IOS.EQ.137)THEN 186 - MESS='(E) SIZE present but ADVANCE=NO missing in a READ.' 1 55 P=INPUT D=INPIOSIR 3 PAGE 55 187 - ELSEIF(IOS.EQ.138)THEN 188 - MESS='(E) EOR present but ADVANCE=NO missing in a READ.' 189 - ELSEIF(IOS.EQ.139)THEN 190 - MESS='(S) Operation not compatible with ACTION specifier.' 191 - ELSEIF(IOS.EQ.140)THEN 192 - MESS='(F90) I/O attempted for an unconnected unit.' 193 - ELSEIF(IOS.EQ.141)THEN 194 - MESS='(F90) Two consecutive ENDFILEs.' 195 - ELSEIF(IOS.EQ.142)THEN 196 - MESS='(S) CLOSE error.' 197 - ELSEIF(IOS.EQ.144)THEN 198 - MESS='(S) INQUIRE error.' 199 - ELSEIF(IOS.EQ.145)THEN 200 - MESS='(E) READ or WRITE attempted after the end-of-file.' 201 - ELSEIF(IOS.EQ.151)THEN 202 - MESS='(F90) FILE missing nor STATUS=SCRATCH in OPEN.' 203 - ELSEIF(IOS.EQ.152)THEN 204 - MESS='(S) OPEN with ACCESS=DIRECT for a sequential file.' 205 - ELSEIF(IOS.EQ.153)THEN 206 - MESS='(S) REWIND or APPEND on an OPEN for a pipe.' 207 - ELSEIF(IOS.EQ.156)THEN 208 - MESS='(S) Invalid record length on an OPEN statement.' 209 - ELSEIF(IOS.EQ.159)THEN 210 - MESS='(S) External input not flushed - seek not possible.' 211 - ELSE 212 - MESS='(?) Error message with unknown IOSTAT code.' 213 - ENDIF 214 - *** Dump the data in DEBUG mode. 215 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPIOS DEBUG : IOSTAT'', 216 - - '' error code received is '',I8)') IOS 217 - *** Interpret the error message. 218 - WRITE(LUNOUT,'('' ------ INPIOS MESSAGE : Supplementary data'', 219 - - '' for the above error message:''/26X,A)') MESS 220 - END 56 GARFIELD ================================================== P=INPUT D=INPLUN 1 ============================ 0 + +DECK,INPLUN. 1 - SUBROUTINE INPLUN(LUNIN) 2 - *----------------------------------------------------------------------- 3 - * INPLUN - Returns the current input logical unit number. 4 - * (Last changed on 10/12/90.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,INPUT. 9 - INTEGER LUNIN 10 - *** Return the unit number. 11 - LUNIN=LUN 12 - END 57 GARFIELD ================================================== P=INPUT D=INPMSG 1 ============================ 0 + +DECK,INPMSG. 1 - SUBROUTINE INPMSG(IWRD,MSG) 2 - *----------------------------------------------------------------------- 3 - * INPMSG - Registers the error message MSG for word IWRD. 4 - *----------------------------------------------------------------------- 5 - implicit none 6.- +SEQ,DIMENSIONS. 7.- +SEQ,INPUT. 8 - CHARACTER*(*) MSG 9 - INTEGER IWRD 10 - *** Assign error message and set print flag. 11 - ERRPRT(IWRD)=.TRUE. 12 - ERRCDE(IWRD)=MSG 13 - *** Replace the word. 14 - WORD(IWRD)='*DELETED*' 15 - NCHAR(IWRD)=9 16 - END 58 GARFIELD ================================================== P=INPUT D=INPNUM 1 ============================ 0 + +DECK,INPNUM. 1 - SUBROUTINE INPNUM(NNWORD) 2 - *----------------------------------------------------------------------- 3 - * INPNUM - Returns the current number of words. 4 - *----------------------------------------------------------------------- 5 - implicit none 6.- +SEQ,DIMENSIONS. 7.- +SEQ,INPUT. 8 - INTEGER NNWORD 9 - NNWORD=NWORD 10 - END 59 GARFIELD ================================================== P=INPUT D=INPPAR 1 ============================ 0 + +DECK,INPPAR. 1 - SUBROUTINE INPPAR(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * INPPAR - Imitates the Parse instruction from REXX by assigning bits 4 - * of a string to global variables. 5 - * (Last changed on 9/11/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,GLOBALS. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,INPUT. 12 - EXTERNAL INPCMP 13 - INTEGER INPCMP,IFAIL,NCFMT,NCLINE,NCVAR,MODRES(MXVAR),IGLB, 14 - - IFAIL1,NRES,IENTRY,I,ITYPE 15 - CHARACTER*10 VARNAM 16 - CHARACTER*(MXINCH) FORMAT,LINE 17 - LOGICAL USE(MXVAR),EXEC 18 - REAL RES(1) 1 59 P=INPUT D=INPPAR 2 PAGE 56 19 - *** Identify the routine for tracing purposes. 20 - IF(LIDENT)PRINT *,' /// ROUTINE INPPAR ///' 21 - *** Assume that things will work out correctly. 22 - IFAIL=0 23 - *** Assume we are in non-execution mode. 24 - EXEC=.FALSE. 25 - *** Check for the EVALUATE and LITERAL options. 26 - IF(INPCMP(2,'EVAL#UATE')+INPCMP(2,'EXEC#UTE').NE.0)THEN 27 - EXEC=.TRUE. 28 - ITYPE=3 29 - ELSEIF(INPCMP(2,'LIT#ERALLY')+INPCMP(2,'NOEVAL#UATE')+ 30 - - INPCMP(2,'NOEXEC#UTE').NE.0)THEN 31 - EXEC=.FALSE. 32 - ITYPE=3 33 - ELSE 34 - ITYPE=2 35 - ENDIF 36 - *** Get the number of words. 37 - IF(NWORD.LT.ITYPE)RETURN 38 - *** Input is a global variable. 39 - IF(INPCMP(ITYPE,'GL#OBAL').NE.0)THEN 40 - * Check that there are enough arguments. 41 - IF(NWORD.LT.ITYPE+2)THEN 42 - PRINT *,' !!!!!! INPPAR WARNING : Parse Global needs'// 43 - - ' at least a global name and a template; ignored.' 44 - IFAIL=1 45 - RETURN 46 - ENDIF 47 - * Locate the global variable. 48 - CALL INPSTR(ITYPE+1,ITYPE+1,VARNAM,NCVAR) 49 - IGLB=0 50 - DO 10 I=1,NGLB 51 - IF(VARNAM(1:NCVAR).EQ.GLBVAR(I))IGLB=I 52 - 10 CONTINUE 53 - IF(IGLB.EQ.0)THEN 54 - PRINT *,' !!!!!! INPPAR WARNING : The global'// 55 - - ' variable '//VARNAM(1:NCVAR)//' is not'// 56 - - ' known; Parse Global ignored.' 57 - IFAIL=1 58 - RETURN 59 - ENDIF 60 - * Get the global variable. 61 - CALL OUTFMT(GLBVAL(IGLB),GLBMOD(IGLB),LINE,NCLINE,'LEFT') 62 - * And get the template. 63 - CALL INPSTR(ITYPE+2,NWORD,FORMAT,NCFMT) 64 - * Assign the globals. 65 - CALL INPTMP(LINE,NCLINE,FORMAT,NCFMT,EXEC,IFAIL1) 66 - IF(IFAIL1.NE.0)THEN 67 - PRINT *,' !!!!!! INPPAR WARNING : Error detected'// 68 - - ' in Parse Global for '//VARNAM(1:NCVAR)//'.' 69 - IFAIL=1 70 - RETURN 71 - ENDIF 72 - *** Input is from regular input. 73 - ELSEIF(INPCMP(ITYPE,'IN#PUT').NE.0)THEN 74 - * Check that there are enough arguments. 75 - IF(NWORD.LT.ITYPE+1)THEN 76 - PRINT *,' !!!!!! INPPAR WARNING : Parse Input needs'// 77 - - ' at least a template; ignored.' 78 - IFAIL=1 79 - RETURN 80 - ENDIF 81 - * And get the template. 82 - CALL INPSTR(ITYPE+1,NWORD,FORMAT,NCFMT) 83 - * Set a prompt. 84 - CALL INPPRM('Input','ADD-PRINT') 85 - * Get an input line. 86 - CALL INPGET 87 - CALL INPSTR(1,NWORD,LINE,NCLINE) 88 - * Remove prompt. 89 - CALL INPPRM(' ','BACK-PRINT') 90 - * Assign the globals. 91 - CALL INPTMP(LINE,NCLINE,FORMAT,NCFMT,EXEC,IFAIL1) 92 - IF(IFAIL1.NE.0)THEN 93 - PRINT *,' !!!!!! INPPAR WARNING : Error detected'// 94 - - ' in Parse Input.' 95 - IFAIL=1 96 - RETURN 97 - ENDIF 98 - *** Input file argument. 99 - ELSEIF(INPCMP(ITYPE,'ARG#UMENT').NE.0)THEN 100 - * Check that there are enough arguments. 101 - IF(NWORD.LT.ITYPE+1)THEN 102 - PRINT *,' !!!!!! INPPAR WARNING : Parse Argument'// 103 - - ' needs at least a template; ignored.' 104 - IFAIL=1 105 - RETURN 106 - ENDIF 107 - * And get the template. 108 - CALL INPSTR(ITYPE+1,NWORD,FORMAT,NCFMT) 109 - * Assign the globals. 110 - CALL INPTMP(ARGSTR,NCARG,FORMAT,NCFMT,EXEC,IFAIL1) 111 - IF(IFAIL1.NE.0)THEN 112 - PRINT *,' !!!!!! INPPAR WARNING : Error detected'// 113 - - ' in Parse Argument.' 114 - IFAIL=1 115 - RETURN 116 - ENDIF 117 - *** Input is from terminal input. 118 - ELSEIF(INPCMP(ITYPE,'TERM#INAL').NE.0)THEN 119 - * Check that there are enough arguments. 120 - IF(NWORD.LT.ITYPE+1)THEN 121 - PRINT *,' !!!!!! INPPAR WARNING : Parse Terminal'// 122 - - ' needs at least a template; ignored.' 123 - IFAIL=1 124 - RETURN 1 59 P=INPUT D=INPPAR 3 PAGE 57 125 - ENDIF 126 - * And get the template. 127 - CALL INPSTR(ITYPE+1,NWORD,FORMAT,NCFMT) 128 - * Switch to terminal input. 129 - CALL INPSWI('TERMINAL') 130 - * Set a prompt. 131 - CALL INPPRM('Input','ADD-PRINT') 132 - * Get an input line. 133 - CALL INPGET 134 - CALL INPSTR(1,NWORD,LINE,NCLINE) 135 - * Remove prompt. 136 - CALL INPPRM(' ','BACK-PRINT') 137 - * Return to regular input. 138 - CALL INPSWI('RESTORE') 139 - * Assign the globals. 140 - CALL INPTMP(LINE,NCLINE,FORMAT,NCFMT,EXEC,IFAIL1) 141 - IF(IFAIL1.NE.0)THEN 142 - PRINT *,' !!!!!! INPPAR WARNING : Error detected'// 143 - - ' in Parse Terminal.' 144 - IFAIL=1 145 - RETURN 146 - ENDIF 147 - *** Input from the result of some calculation. 148 - ELSEIF(INPCMP(ITYPE,'VAL#UE').NE.0)THEN 149 - * Check that there are enough arguments. 150 - IF(NWORD.LT.ITYPE+2)THEN 151 - PRINT *,' !!!!!! INPPAR WARNING : Parse Value needs'// 152 - - ' at least a global name and a template; ignored.' 153 - IFAIL=1 154 - RETURN 155 - ENDIF 156 - * Get the expression. 157 - CALL INPSTR(ITYPE+1,ITYPE+1,LINE,NCLINE) 158 - * Translate the expression. 159 - CALL ALGPRE(LINE(1:NCLINE),NCLINE, 160 - - GLBVAR,NGLB,NRES,USE,IENTRY,IFAIL1) 161 - * Make sure that the formula was OK. 162 - IF(IFAIL1.NE.0)THEN 163 - PRINT *,' !!!!!! INPPAR WARNING : Translation'// 164 - - ' of expression '//LINE(1:NCLINE)// 165 - - ' failed; Parse Value ignored.' 166 - IFAIL=1 167 - CALL ALGCLR(IENTRY) 168 - RETURN 169 - * Verify that we get indeed only one result. 170 - ELSEIF(NRES.NE.1)THEN 171 - PRINT *,' !!!!!! INPPAR WARNING : Translation'// 172 - - ' of expression '//LINE(1:NCLINE)// 173 - - ' does not yield 1 result; Parse Value ignored.' 174 - CALL ALGCLR(IENTRY) 175 - IFAIL=1 176 - RETURN 177 - ENDIF 178 - * Set the execution time. 179 - CALL TIMEL(GLBVAL(1)) 180 - * Evaluate the formula. 181 - CALL ALGEXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,1,IFAIL1) 182 - * Check the return code of the evaluation. 183 - IF(IFAIL1.NE.0)THEN 184 - PRINT *,' !!!!!! INPTMP WARNING : Evaluation of'// 185 - - ' expression '//LINE(1:NCLINE)// 186 - - ' failed; Parse Value ignored.' 187 - CALL ALGCLR(IENTRY) 188 - IFAIL=1 189 - RETURN 190 - ENDIF 191 - * Print any evaluation errors. 192 - CALL ALGERR 193 - * Remove the entry point of the formula. 194 - CALL ALGCLR(IENTRY) 195 - * Assign the result to the string. 196 - CALL OUTFMT(RES(1),MODRES(1),LINE,NCLINE,'LEFT') 197 - * And get the template. 198 - CALL INPSTR(ITYPE+2,NWORD,FORMAT,NCFMT) 199 - * Assign the globals. 200 - CALL INPTMP(LINE,NCLINE,FORMAT,NCFMT,EXEC,IFAIL1) 201 - IF(IFAIL1.NE.0)THEN 202 - PRINT *,' !!!!!! INPPAR WARNING : Error detected'// 203 - - ' in Parse Value.' 204 - IFAIL=1 205 - RETURN 206 - ENDIF 207 - *** Other sources. 208 - ELSE 209 - CALL INPSTR(ITYPE,ITYPE,LINE,NCLINE) 210 - PRINT *,' !!!!!! INPPAR WARNING : '//LINE(1:NCLINE)// 211 - - ' is not a known source for Parse; ignored.' 212 - IFAIL=1 213 - RETURN 214 - ENDIF 215 - END 60 GARFIELD ================================================== P=INPUT D=INPPRM 1 ============================ 0 + +DECK,INPPRM. 1 - SUBROUTINE INPPRM(TEXT,MODE) 2 - *----------------------------------------------------------------------- 3 - * INPPRM - Sets or expands the prompt string, the prompt string is 4 - * ignored on some computers. 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,INPUT. 9 - CHARACTER*(*) TEXT,MODE 10 - INTEGER I,ILAST 11 - *** Check for the NEW/ADD options. 1 60 P=INPUT D=INPPRM 2 PAGE 58 12 - IF(INDEX(MODE,'NEW').NE.0)THEN 13 - PROMPT=TEXT(1:LEN(TEXT)) 14 - NCPROM=LEN(TEXT) 15 - ELSEIF(INDEX(MODE,'ADD').NE.0.AND.NCPROM.LT.80)THEN 16 - PROMPT(NCPROM+1:MIN(80,NCPROM+1+LEN(TEXT)))= 17 - - '-'//TEXT(1:LEN(TEXT)) 18 - NCPROM=MIN(80,NCPROM+1+LEN(TEXT)) 19 - ELSEIF(INDEX(MODE,'BACK').NE.0)THEN 20 - ILAST=NCPROM 21 - DO 10 I=ILAST,1,-1 22 - IF(PROMPT(I:I).EQ.'-')THEN 23 - NCPROM=I-1 24 - GOTO 20 25 - ENDIF 26 - 10 CONTINUE 27 - 20 CONTINUE 28 - ENDIF 29 - *** Check for the PRINT/NOPRINT options. 30 - IF(INDEX(MODE,'NOPRINT').NE.0)THEN 31 - LPROM=.FALSE. 32 - ELSEIF(INDEX(MODE,'PRINT').NE.0)THEN 33 - LPROM=.TRUE. 34 - ENDIF 35 - END 61 GARFIELD ================================================== P=INPUT D=INPRAW 1 ============================ 0 + +DECK,INPRAW. 1 - SUBROUTINE INPRAW(OUT) 2 - *----------------------------------------------------------------------- 3 - * INPRAW - Return the raw input string. 4 - * (Last changed on 23/ 4/90.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,INPUT. 9 - CHARACTER*(*) OUT 10 - OUT=STRING 11 - END 62 GARFIELD ================================================== P=INPUT D=INPRDH 1 ============================ 0 + +DECK,INPRDH. 1 - SUBROUTINE INPRDH(IWRD,IVAL,IDEF) 2 - *----------------------------------------------------------------------- 3 - * INPRDH - Reads word IWRD into IVAL, using the default IDEF if the 4 - * word is empty and if it contains a *. 5 - * (Last changed on 23/ 5/90.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,INPUT. 10 - CHARACTER CHAR 11 - INTEGER HEX,IWRD,IVAL,IDEF,I 12 - *** Statement function used for decoding Hex numbers. 13 - HEX(CHAR)=INDEX('0123456789ABCDEF',CHAR)-1 14 - *** Word out of range or blank or default. 15 - IF(IWRD.LE.0.OR.IWRD.GT.NWORD.OR. 16 - - WORD(IWRD).EQ.' '.OR.WORD(IWRD).EQ.'*')THEN 17 - IVAL=IDEF 18 - RETURN 19 - ENDIF 20 - *** Read the hexadecimal constant, avoiding overflow. 21 - IF(NCHAR(IWRD).LE.0.OR.NCHAR(IWRD).GT.4)THEN 22 - IVAL=IDEF 23 - RETURN 24 - ENDIF 25 - * Character by character. 26 - IVAL=0 27 - DO 10 I=NCHAR(IWRD),1,-1 28 - IVAL=IVAL+16**(NCHAR(IWRD)-I)*HEX(WORD(IWRD)(I:I)) 29 - 10 CONTINUE 30 - END 63 GARFIELD ================================================== P=INPUT D=INPRDI 1 ============================ 0 + +DECK,INPRDI. 1 - SUBROUTINE INPRDI(IWRD,IVAL,IDEF) 2 - *----------------------------------------------------------------------- 3 - * INPRDI - Reads word IWRD into IVAL, using the default IDEF if the 4 - * word is empty and if it contains a *. 5 - * (Last changed on 1/ 7/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,INPUT. 10 - INTEGER IWRD,IVAL,IDEF 11 - CHARACTER*25 AUX 12 - *** Out of range ? 13 - IF(IWRD.LE.0.OR.IWRD.GT.NWORD.OR. 14 - - WORD(IWRD).EQ.' '.OR.WORD(IWRD).EQ.'*')THEN 15 - IVAL=IDEF 16 - RETURN 17 - ENDIF 18 - *** Read the value. 19 - AUX=WORD(IWRD)(1:NCHAR(IWRD)) 20 - READ(AUX,'(BN,I25)') IVAL 21 - END 64 GARFIELD ================================================== P=INPUT D=INPRDO 1 ============================ 0 + +DECK,INPRDO. 1 - SUBROUTINE INPRDO(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * INPRDO - Reads a DO loop, stores the lines and prepares entries. 4 - * (Last changed on 29/ 3/00.) 1 64 P=INPUT D=INPRDO 2 PAGE 59 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,DOLOOP. 9.- +SEQ,GLOBALS. 10.- +SEQ,ALGDATA. 11.- +SEQ,PRINTPLOT. 12 - CHARACTER*(MXCHAR) BLANK,FROM,STEP,WHILE,UNTIL,TO 13 - CHARACTER*13 PROMPT 14 - CHARACTER*10 FOR 15 - CHARACTER*8 TYPE 16 - CHARACTER*(MXINCH) STRING,INDSTR 17 - INTEGER INPCMP,NCSTR,NCIND,IENTNO,IEXTR,ILAST,MAXDOL,MAXIFL,NC, 18 - - NNRES,IFAIL,NWORD,NCFOR,NCFROM,NCSTEP,NCWHIL,NCUNTL,NCTO, 19 - - I,J,I0,I1,IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5,NRES1,NRES2, 20 - - NRES3,NRES4,NRES5,ILLCHR,IGLB,NCPRM 21 - LOGICAL OK,USE(MXVAR) 22 - EXTERNAL INPCMP 23 - *** Initialise the various level and line counters. 24 - NDOLIN=0 25 - CDOLVL=0 26 - TRACDO(0)=0 27 - CIFLVL=0 28 - TRACIF(0)=0 29 - MAXDOL=0 30 - MAXIFL=0 31 - NLOOP=0 32 - NIF=0 33 - OK=.TRUE. 34 - *** Update the prompt. 35 - CALL INPPRM('Loop','ADD') 36 - *** Carry on with the next line (passed on or read at end of loop). 37 - 10 CONTINUE 38 - *** Increment the line counter. 39 - NDOLIN=NDOLIN+1 40 - IF(NDOLIN.GT.MXDLIN)THEN 41 - PRINT *,' !!!!!! INPRDO WARNING : DO loop contains too'// 42 - - ' lines; increase MXDLIN.' 43 - OK=.FALSE. 44 - NDOLIN=MXDLIN 45 - ENDIF 46 - *** Usually no global variable definition. 47 - LINREF(NDOLIN,7)=0 48 - LINREF(NDOLIN,8)=0 49 - *** Check whether the line is of the type IF cond THEN expr. 50 - CALL INPNUM(NWORD) 51 - IF(INPCMP(1,'IF')+INPCMP(1,'ELSEIF').NE.0.AND. 52 - - INPCMP(3,'THEN').NE.0)THEN 53 - * Check an IF block does not begin here. 54 - IF(INPCMP(4,'IF')+INPCMP(4,'ELSE')+INPCMP(4,'ELSEIF')+ 55 - - INPCMP(4,'ENDIF').NE.0)THEN 56 - PRINT *,' !!!!!! INPRDO WARNING : Parts of an IF'// 57 - - ' block may not start on an IF line; use & (and).' 58 - OK=.FALSE. 59 - ENDIF 60 - * Check this is not an ENDDO. 61 - IF(INPCMP(4,'ENDDO').NE.0)THEN 62 - PRINT *,' !!!!!! INPRDO WARNING : A DO block may'// 63 - - ' not end on an IF line.' 64 - OK=.FALSE. 65 - ENDIF 66 - * Pick up the condition, translate and store the entry. 67 - CALL INPSTR(2,2,STRING,NC) 68 - CALL ALGPRE(STRING(1:NC),NC,GLBVAR,NGLB,NNRES,USE, 69 - - LINREF(NDOLIN,4),IFAIL) 70 - IF(IFAIL.NE.0.OR.NNRES.NE.1)THEN 71 - PRINT *,' !!!!!! INPRDO WARNING : Unable to'// 72 - - ' translate the condition.' 73 - OK=.FALSE. 74 - ENDIF 75 - * Get rid of the IF clause before carrying on. 76 - IF(NWORD.GE.4)THEN 77 - CALL INPDEL(3) 78 - CALL INPDEL(2) 79 - CALL INPDEL(1) 80 - NWORD=NWORD-3 81 - ENDIF 82 - * Does not start with an IF condition. 83 - ELSE 84 - LINREF(NDOLIN,4)=0 85 - ENDIF 86 - * Branching by default not used. 87 - LINREF(NDOLIN,5)=0 88 - *** Start of a new DO loop. 89 - IF(INPCMP(NWORD,'DO').NE.0.AND.INPCMP(1,'FOR')+ 90 - - INPCMP(1,'WHILE')+INPCMP(1,'UNTIL')+ 91 - - INPCMP(1,'STEP')+INPCMP(1,'DO').NE.0)THEN 92 - * Increment loop number, level counter and update calling tree. 93 - IF(NLOOP.GE.MXDLVL)THEN 94 - PRINT *,' !!!!!! INPRDO WARNING : Number of DO loops'// 95 - - ' exceeds storage capacity.' 96 - OK=.FALSE. 97 - ELSE 98 - NLOOP=NLOOP+1 99 - ENDIF 100 - MAXDOL=MAX(MAXDOL,CDOLVL+1) 101 - IF(CDOLVL.GE.MXDLVL)THEN 102 - PRINT *,' !!!!!! INPRDO WARNING : DO nesting deeper'// 103 - - ' than length of loop trace.' 104 - OK=.FALSE. 105 - ELSE 106 - CDOLVL=CDOLVL+1 107 - ENDIF 108 - TRACDO(CDOLVL)=NLOOP 109 - * Store the type of this line with the loop reference number. 110 - LINREF(NDOLIN,1)=1 1 64 P=INPUT D=INPRDO 3 PAGE 60 111 - LINREF(NDOLIN,3)=TRACDO(CDOLVL) 112 - LINREF(NDOLIN,6)=TRACIF(CIFLVL) 113 - * Save the information also in the DO loop control block. 114 - DOREF(NLOOP,6)=NDOLIN 115 - DOREF(NLOOP,7)=0 116 - DOREF(NLOOP,8)=CDOLVL 117 - DOREF(NLOOP,10)=CIFLVL 118 - * Initial values for the loop control words. 119 - FOR=' ' 120 - NCFOR=1 121 - FROM=' ' 122 - NCFROM=1 123 - STEP='1' 124 - NCSTEP=1 125 - WHILE='TRUE' 126 - NCWHIL=4 127 - UNTIL='FALSE' 128 - NCUNTL=5 129 - TO=' ' 130 - NCTO=1 131 - * Pick up the DO loop control words: FOR, FROM, STEP, WHILE, UNTIL. 132 - IF(NWORD.NE.1.AND.(NWORD-1).NE. 133 - - 2*INT(0.1+REAL(NWORD-1)/2.0))THEN 134 - PRINT *,' !!!!!! INPRDO WARNING : The number of'// 135 - - ' words on the DO line is incorrect.' 136 - OK=.FALSE. 137 - ENDIF 138 - DO 20 I=1,NWORD-2,2 139 - * Read the loop variable name. 140 - IF(INPCMP(I,'FOR').NE.0)THEN 141 - CALL INPSTR(I+1,I+1,STRING,NC) 142 - * Check for illegal characters. 143 - ILLCHR=0 144 - DO 30 J=1,NC 145 - IF(INDEX('+-*/&|<=#>^ ,.:;([{)]}''"`', 146 - - STRING(J:J)).NE.0)THEN 147 - ILLCHR=ILLCHR+1 148 - OK=.FALSE. 149 - ENDIF 150 - 30 CONTINUE 151 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ', 152 - - STRING(1:1)).EQ.0)THEN 153 - CALL INPMSG(I+1,'Does not start with a letter. ') 154 - OK=.FALSE. 155 - ELSEIF(ILLCHR.EQ.1)THEN 156 - CALL INPMSG(I+1,'Contains an illegal character.') 157 - ELSEIF(ILLCHR.GT.1)THEN 158 - CALL INPMSG(I+1,'Contains illegal characters. ') 159 - * Check the name is not more than 10 characters long. 160 - ELSEIF(NC.GT.LEN(FOR))THEN 161 - CALL INPMSG(I+1,'Name longer than 10 characters') 162 - OK=.FALSE. 163 - * Check the name is not empty. 164 - ELSEIF(NC.LE.0)THEN 165 - CALL INPMSG(I+1,'Empty names are not permitted.') 166 - OK=.FALSE. 167 - * Store the name. 168 - ELSE 169 - FOR=STRING(1:NC) 170 - NCFOR=NC 171 - ENDIF 172 - * Starting value. 173 - ELSEIF(INPCMP(I,'FROM').NE.0)THEN 174 - CALL INPSTR(I+1,I+1,STRING,NC) 175 - IF(NC.GT.80)THEN 176 - CALL INPMSG(I+1,'Expression longer than 80 char') 177 - OK=.FALSE. 178 - ELSEIF(NC.LE.0)THEN 179 - CALL INPMSG(I+1,'Empty expression not permitted') 180 - OK=.FALSE. 181 - ELSE 182 - FROM=' ' 183 - FROM=STRING(1:NC) 184 - NCFROM=NC 185 - ENDIF 186 - * Step size for the loop. 187 - ELSEIF(INPCMP(I,'STEP').NE.0)THEN 188 - CALL INPSTR(I+1,I+1,STRING,NC) 189 - IF(NC.GT.80)THEN 190 - CALL INPMSG(I+1,'Expression longer than 80 char') 191 - OK=.FALSE. 192 - ELSEIF(NC.LE.0)THEN 193 - CALL INPMSG(I+1,'Empty expression not permitted') 194 - OK=.FALSE. 195 - ELSE 196 - STEP=' ' 197 - STEP=STRING(1:NC) 198 - NCSTEP=NC 199 - ENDIF 200 - * Condition to be satisfied, check at start of loop. 201 - ELSEIF(INPCMP(I,'WHILE').NE.0)THEN 202 - CALL INPSTR(I+1,I+1,STRING,NC) 203 - IF(NC.GT.80)THEN 204 - CALL INPMSG(I+1,'Expression longer than 80 char') 205 - OK=.FALSE. 206 - ELSEIF(NC.LE.0)THEN 207 - CALL INPMSG(I+1,'Empty expression not permitted') 208 - OK=.FALSE. 209 - ELSE 210 - WHILE=' ' 211 - WHILE=STRING(1:NC) 212 - NCWHIL=NC 213 - ENDIF 214 - * Condition not to be satisfied, check at end of loop. 215 - ELSEIF(INPCMP(I,'UNTIL').NE.0)THEN 216 - CALL INPSTR(I+1,I+1,STRING,NC) 1 64 P=INPUT D=INPRDO 4 PAGE 61 217 - IF(NC.GT.80)THEN 218 - CALL INPMSG(I+1,'Expression longer than 80 char') 219 - OK=.FALSE. 220 - ELSEIF(NC.LE.0)THEN 221 - CALL INPMSG(I+1,'Empty expression not permitted') 222 - OK=.FALSE. 223 - ELSE 224 - UNTIL=' ' 225 - UNTIL=STRING(1:NC) 226 - NCUNTL=NC 227 - ENDIF 228 - * Final value of the loop variable. 229 - ELSEIF(INPCMP(I,'TO').NE.0)THEN 230 - CALL INPSTR(I+1,I+1,STRING,NC) 231 - IF(NC.GT.80)THEN 232 - CALL INPMSG(I+1,'Expression longer than 80 char') 233 - OK=.FALSE. 234 - ELSEIF(NC.LE.0)THEN 235 - CALL INPMSG(I+1,'Empty expression not permitted') 236 - OK=.FALSE. 237 - ELSE 238 - TO=' ' 239 - TO=STRING(1:NC) 240 - NCTO=NC 241 - ENDIF 242 - * Anything else, not valid. 243 - ELSE 244 - CALL INPMSG(I,'Not a known DO control word. ') 245 - CALL INPMSG(I+1,'See preceding message. ') 246 - ENDIF 247 - 20 CONTINUE 248 - ** Take care of the DO loop variable name. 249 - IF(FOR.NE.' ')THEN 250 - * Locate the loop variable in the table. 251 - DO 40 I=1,NGLB 252 - IF(GLBVAR(I).EQ.FOR(1:NCFOR))THEN 253 - DOREF(NLOOP,9)=I 254 - GOTO 50 255 - ENDIF 256 - 40 CONTINUE 257 - IF(NGLB.GE.MXVAR)THEN 258 - PRINT *,' !!!!!! INPRDO WARNING : Ran out of'// 259 - - ' storage space for global variables.' 260 - PRINT *,' Increase'// 261 - - ' MXVAR and recompile the program.' 262 - DOREF(NLOOP,9)=0 263 - OK=.FALSE. 264 - ELSE 265 - NGLB=NGLB+1 266 - GLBVAR(NGLB)=FOR(1:NCFOR) 267 - GLBMOD(NGLB)=0 268 - DOREF(NLOOP,9)=NGLB 269 - ENDIF 270 - 50 CONTINUE 271 - * Make sure the loop variable was not used before. 272 - DO 60 I=1,NLOOP-1 273 - IF(DOREF(I,9).LE.0.OR.DOREF(NLOOP,9).EQ.0)GOTO 60 274 - IF(DOREF(I,6).LE.NDOLIN.AND. 275 - - (DOREF(I,7).EQ.0.OR.DOREF(I,7).GT.NDOLIN).AND. 276 - - GLBVAR(DOREF(I,9)).EQ.GLBVAR(DOREF(NLOOP,9)))THEN 277 - PRINT *,' !!!!!! INPRDO WARNING : The DO loop'// 278 - - ' variable '//FOR(1:NCFOR)//' is already'// 279 - - ' used for an enclosing loop.' 280 - OK=.FALSE. 281 - ENDIF 282 - 60 CONTINUE 283 - * Assign to the loop variable. 284 - IF(DOREF(NLOOP,9).GT.0)THEN 285 - GLBVAL(DOREF(NLOOP,9))=0 286 - GLBMOD(DOREF(NLOOP,9))=0 287 - ENDIF 288 - * No name specified, assign the dummy variable 0 to this loop. 289 - ELSE 290 - DOREF(NLOOP,9)=0 291 - ENDIF 292 - ** Translate the various expressions. 293 - IF(DOREF(NLOOP,9).NE.0)THEN 294 - IF(STEP.EQ.' ')THEN 295 - PRINT *,' ------ INPRDO MESSAGE : Default'// 296 - - ' step size 1 used for the loop of the'// 297 - - ' variable "'//GLBVAR(DOREF(NLOOP,9))//'"' 298 - STEP='1' 299 - NCSTEP=1 300 - ENDIF 301 - CALL ALGPRE(STEP,NCSTEP,GLBVAR,NGLB,NRES2,USE, 302 - - DOREF(NLOOP,2),IFAIL2) 303 - IF(FROM.EQ.' '.OR.TO.EQ.' ')THEN 304 - PRINT *,' !!!!!! INPRDO WARNING : The DO loop'// 305 - - ' with variable "'//GLBVAR(DOREF(NLOOP,9))// 306 - - '" misses a FROM or a TO.' 307 - OK=.FALSE. 308 - NRES1=1 309 - IFAIL1=0 310 - DOREF(NLOOP,1)=0 311 - NRES5=1 312 - IFAIL5=0 313 - DOREF(NLOOP,5)=0 314 - ELSE 315 - CALL ALGPRE(FROM,NCFROM,GLBVAR,NGLB,NRES1,USE, 316 - - DOREF(NLOOP,1),IFAIL1) 317 - CALL ALGPRE(TO,NCTO,GLBVAR,NGLB,NRES5,USE, 318 - - DOREF(NLOOP,5),IFAIL5) 319 - ENDIF 320 - ELSE 321 - IFAIL1=0 322 - IFAIL2=0 1 64 P=INPUT D=INPRDO 5 PAGE 62 323 - IFAIL5=0 324 - NRES1=1 325 - NRES2=1 326 - NRES5=1 327 - ENDIF 328 - IF(WHILE.EQ.' ')THEN 329 - WHILE='TRUE' 330 - NCWHIL=4 331 - ENDIF 332 - IF(UNTIL.EQ.' ')THEN 333 - UNTIL='FALSE' 334 - NCUNTL=5 335 - ENDIF 336 - CALL ALGPRE(WHILE,NCWHIL,GLBVAR,NGLB,NRES3,USE, 337 - - DOREF(NLOOP,3),IFAIL3) 338 - CALL ALGPRE(UNTIL,NCUNTL,GLBVAR,NGLB,NRES4,USE, 339 - - DOREF(NLOOP,4),IFAIL4) 340 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. 341 - - IFAIL4.NE.0.OR.IFAIL5.NE.0)THEN 342 - PRINT *,' !!!!!! INPRDO WARNING : One or more of the'// 343 - - ' loop control expressions can''t be translated'// 344 - - ' into an algebra list.' 345 - OK=.FALSE. 346 - ENDIF 347 - IF(NRES1.NE.1.OR.NRES2.NE.1.OR.NRES3.NE.1.OR.NRES4.NE.1.OR. 348 - - NRES5.NE.1)THEN 349 - PRINT *,' !!!!!! INPRDO WARNING : Incorrect number'// 350 - - ' of results returned by loop control expression.' 351 - OK=.FALSE. 352 - ENDIF 353 - *** Go for another iteration cycle. 354 - ELSEIF(INPCMP(1,'ITERATE').NE.0)THEN 355 - LINREF(NDOLIN,1)=2 356 - * First assign an invalid loop reference number to the statement. 357 - LINREF(NDOLIN,3)=0 358 - * The IF block number is known. 359 - LINREF(NDOLIN,6)=TRACIF(CIFLVL) 360 - * Mark unused words. 361 - IF(NWORD.GT.2)THEN 362 - DO 130 I=3,NWORD 363 - CALL INPMSG(I,'Superfluous argument (ignored)') 364 - 130 CONTINUE 365 - OK=.FALSE. 366 - ENDIF 367 - * Figure out which loop we have to carry out again. 368 - IF(NWORD.GE.2)THEN 369 - CALL INPSTR(2,2,STRING,NC) 370 - DO 140 I=1,NLOOP 371 - IF(DOREF(I,9).EQ.0)GOTO 140 372 - IF(GLBVAR(DOREF(I,9)).EQ. 373 - - STRING(1:MAX(1,MIN(10,NC))))LINREF(NDOLIN,3)=I 374 - 140 CONTINUE 375 - IF(LINREF(NDOLIN,3).EQ.0)THEN 376 - CALL INPMSG(2,'Unidentified loop variable. ') 377 - OK=.FALSE. 378 - ENDIF 379 - * No loop specified: carry out inner loop again. 380 - ELSE 381 - LINREF(NDOLIN,3)=TRACDO(CDOLVL) 382 - ENDIF 383 - * Check this loop is part of the calling trace. 384 - DO 180 I=1,CDOLVL 385 - IF(LINREF(NDOLIN,3).EQ.TRACDO(I))GOTO 190 386 - 180 CONTINUE 387 - PRINT *,' !!!!!! INPRDO WARNING : The loop to be'// 388 - - ' iterated is not part of the trace.' 389 - OK=.FALSE. 390 - 190 CONTINUE 391 - *** Leave the loop earlier. 392 - ELSEIF(INPCMP(1,'LEAVE').NE.0)THEN 393 - LINREF(NDOLIN,1)=3 394 - * First assign an invalid loop reference number to the statement. 395 - LINREF(NDOLIN,3)=0 396 - * The IF block is known. 397 - LINREF(NDOLIN,6)=TRACIF(CIFLVL) 398 - * Mark unused words. 399 - IF(NWORD.GT.2)THEN 400 - DO 110 I=3,NWORD 401 - CALL INPMSG(I,'Superfluous argument (ignored)') 402 - 110 CONTINUE 403 - OK=.FALSE. 404 - ENDIF 405 - * Figure out which loop we have to leave. 406 - IF(NWORD.GE.2)THEN 407 - CALL INPSTR(2,2,STRING,NC) 408 - DO 120 I=1,NLOOP 409 - IF(DOREF(I,9).EQ.0)GOTO 120 410 - IF(GLBVAR(DOREF(I,9)).EQ. 411 - - STRING(1:MAX(1,MIN(10,NC))))LINREF(NDOLIN,3)=I 412 - 120 CONTINUE 413 - IF(LINREF(NDOLIN,3).EQ.0)THEN 414 - CALL INPMSG(2,'Unidentified loop variable. ') 415 - OK=.FALSE. 416 - ENDIF 417 - * No loop specified: leave inner loop. 418 - ELSE 419 - LINREF(NDOLIN,3)=TRACDO(CDOLVL) 420 - ENDIF 421 - * Check this loop is part of the calling trace. 422 - DO 170 I=1,CDOLVL 423 - IF(LINREF(NDOLIN,3).EQ.TRACDO(I))GOTO 175 424 - 170 CONTINUE 425 - PRINT *,' !!!!!! INPRDO WARNING : The loop to be left'// 426 - - ' is not part of the trace.' 427 - OK=.FALSE. 428 - 175 CONTINUE 1 64 P=INPUT D=INPRDO 6 PAGE 63 429 - *** End of the DO loop. 430 - ELSEIF(INPCMP(1,'ENDDO').NE.0)THEN 431 - * Check there is a DO loop open. 432 - IF(CDOLVL.LE.0)THEN 433 - PRINT *,' !!!!!! INPRDO WARNING : There is no open'// 434 - - ' DO loop, ENDDO invalid.' 435 - OK=.FALSE. 436 - * Check the IF levels. 437 - ELSEIF(CIFLVL.NE.DOREF(TRACDO(CDOLVL),10))THEN 438 - PRINT *,' !!!!!! INPRDO WARNING : Incorrect nesting'// 439 - - ' of an IF block and a DO loop.' 440 - OK=.FALSE. 441 - * OK. 442 - ELSE 443 - LINREF(NDOLIN,1)=4 444 - LINREF(NDOLIN,3)=TRACDO(CDOLVL) 445 - LINREF(NDOLIN,6)=TRACIF(CIFLVL) 446 - DOREF(TRACDO(CDOLVL),7)=NDOLIN 447 - CDOLVL=CDOLVL-1 448 - ENDIF 449 - *** Start of an IF block. 450 - ELSEIF(NWORD.EQ.3.AND.INPCMP(1,'IF').NE.0.AND. 451 - - INPCMP(3,'THEN').NE.0)THEN 452 - * Store the information about the input line. 453 - LINREF(NDOLIN,1)=11 454 - LINREF(NDOLIN,3)=TRACDO(CDOLVL) 455 - * Check whether we can still increment the IF nesting. 456 - IF(NIF.GE.MXILVL)THEN 457 - PRINT *,' !!!!!! INPRDO WARNING : Number of IF'// 458 - - ' blocks exceeds storage capacity.' 459 - OK=.FALSE. 460 - ELSE 461 - NIF=NIF+1 462 - ENDIF 463 - * Check whether we can keep track of this IF block in the trace. 464 - MAXIFL=MAX(MAXIFL,CIFLVL+1) 465 - IF(CIFLVL.GE.MXILVL)THEN 466 - PRINT *,' !!!!!! INPRDO WARNING : IF nesting deeper'// 467 - - ' than length of the trace.' 468 - OK=.FALSE. 469 - ELSE 470 - CIFLVL=CIFLVL+1 471 - ENDIF 472 - * Store part of the IF block reference information. 473 - IFREF(NIF,1)=1 474 - IFREF(NIF,2)=0 475 - IFREF(NIF,3)=NDOLIN 476 - IFREF(NIF,4)=CDOLVL 477 - IFREF(NIF,5)=CIFLVL 478 - * Keep track of the IF trace. 479 - TRACIF(CIFLVL)=NIF 480 - LINREF(NDOLIN,6)=TRACIF(CIFLVL) 481 - *** Branch of the ELSEIF type. 482 - ELSEIF(NWORD.EQ.3.AND.INPCMP(1,'ELSEIF').NE.0.AND. 483 - - INPCMP(3,'THEN').NE.0)THEN 484 - * Check that the usage of the IF structure is correct. 485 - IF(CIFLVL.EQ.0)THEN 486 - PRINT *,' !!!!!! INPRDO WARNING : No open IF block,'// 487 - - ' use of ELSEIF is not valid.' 488 - OK=.FALSE. 489 - ELSEIF(IFREF(TRACIF(CIFLVL),1).GE.3)THEN 490 - PRINT *,' !!!!!! INPRDO WARNING : An ELSEIF may not'// 491 - - ' be preceded by an ELSE in the same block.' 492 - OK=.FALSE. 493 - ELSEIF(CDOLVL.NE.IFREF(TRACIF(CIFLVL),4))THEN 494 - PRINT *,' !!!!!! INPRDO WARNING : Invalid nesting'// 495 - - ' of a DO loop and an IF block.' 496 - OK=.FALSE. 497 - ELSE 498 - * Line reference information. 499 - LINREF(NDOLIN,1)=12 500 - LINREF(NDOLIN,3)=TRACDO(CDOLVL) 501 - LINREF(NDOLIN,6)=TRACIF(CIFLVL) 502 - * Update the jump part for the previous branch. 503 - LINREF(IFREF(TRACIF(CIFLVL),3),5)=NDOLIN 504 - * Prepare the next jump. 505 - IFREF(TRACIF(CIFLVL),3)=NDOLIN 506 - * And remember we saw an ENDIF. 507 - IFREF(TRACIF(CIFLVL),1)=2 508 - ENDIF 509 - *** Branch of the ELSE type. 510 - ELSEIF(NWORD.EQ.1.AND.INPCMP(1,'ELSE').NE.0)THEN 511 - * Check that the usage of the IF structure is correct. 512 - IF(CIFLVL.EQ.0)THEN 513 - PRINT *,' !!!!!! INPRDO WARNING : No open IF block,'// 514 - - ' use of ELSE is not valid.' 515 - OK=.FALSE. 516 - ELSEIF(IFREF(TRACIF(CIFLVL),1).GE.3)THEN 517 - PRINT *,' !!!!!! INPRDO WARNING : Two ELSE parts'// 518 - - ' in the same block not allowed.' 519 - OK=.FALSE. 520 - ELSEIF(CDOLVL.NE.IFREF(TRACIF(CIFLVL),4))THEN 521 - PRINT *,' !!!!!! INPRDO WARNING : Invalid nesting'// 522 - - ' of a DO loop and an IF block.' 523 - OK=.FALSE. 524 - ELSE 525 - * Line reference information. 526 - LINREF(NDOLIN,1)=13 527 - LINREF(NDOLIN,3)=TRACDO(CDOLVL) 528 - LINREF(NDOLIN,6)=TRACIF(CIFLVL) 529 - * Update the jump part for the previous branch. 530 - LINREF(IFREF(TRACIF(CIFLVL),3),5)=NDOLIN 531 - * Prepare the next jump. 532 - IFREF(TRACIF(CIFLVL),3)=NDOLIN 533 - * And remember we saw an ELSE. 534 - IFREF(TRACIF(CIFLVL),1)=3 1 64 P=INPUT D=INPRDO 7 PAGE 64 535 - ENDIF 536 - *** End of an IF block. 537 - ELSEIF(NWORD.EQ.1.AND.INPCMP(1,'ENDIF').NE.0)THEN 538 - * Check that the usage of the IF structure is correct. 539 - IF(CIFLVL.EQ.0)THEN 540 - PRINT *,' !!!!!! INPRDO WARNING : No open IF block,'// 541 - - ' use of ENDIF is not valid.' 542 - OK=.FALSE. 543 - ELSEIF(CDOLVL.NE.IFREF(TRACIF(CIFLVL),4))THEN 544 - PRINT *,' !!!!!! INPRDO WARNING : Invalid nesting'// 545 - - ' of a DO loop and an IF block.' 546 - OK=.FALSE. 547 - ELSE 548 - * Line reference information. 549 - LINREF(NDOLIN,1)=14 550 - LINREF(NDOLIN,3)=TRACDO(CDOLVL) 551 - LINREF(NDOLIN,6)=TRACIF(CIFLVL) 552 - * Update the jump part for the previous branch. 553 - LINREF(IFREF(TRACIF(CIFLVL),3),5)=NDOLIN 554 - * Store the line of the ENDIF in the IF reference block. 555 - IFREF(TRACIF(CIFLVL),2)=NDOLIN 556 - * And remember we saw an ENDIF. 557 - IFREF(TRACIF(CIFLVL),1)=4 558 - * Go back one step in the IF trace. 559 - CIFLVL=CIFLVL-1 560 - ENDIF 561 - *** An ordinary line. 562 - ELSE 563 - * Reference information. 564 - LINREF(NDOLIN,1)=0 565 - LINREF(NDOLIN,3)=TRACDO(CDOLVL) 566 - LINREF(NDOLIN,6)=TRACIF(CIFLVL) 567 - ENDIF 568 - *** Check also for global variables. 569 - IF(INPCMP(1,'GL#OBALS').NE.0.AND.NWORD.GE.2)THEN 570 - * Ensure that there is no evaluation in the statement anywhere. 571 - CALL INPSTR(2,NWORD,STRING,NC) 572 - IF(INDEX(STRING(1:NC),'{')+INDEX(STRING(1:NC),'}').NE.0) 573 - - GOTO 186 574 - * Assign the line type. 575 - LINREF(NDOLIN,1)=21 576 - ** Fetch the name of the variable. 577 - IGLB=0 578 - CALL INPSTR(2,2,STRING,NC) 579 - * Find out whether this is a matrix indexing expression. 580 - IF(INDEX(STRING(1:NC),'[').GT.1.AND. 581 - - STRING(NC:NC).EQ.']')THEN 582 - NCSTR=INDEX(STRING(1:NC),'[')-1 583 - INDSTR=STRING(NCSTR+1:NC) 584 - NCIND=NC-NCSTR 585 - ELSE 586 - NCSTR=NC 587 - INDSTR=' ' 588 - NCIND=0 589 - ENDIF 590 - * Check for illegal characters. 591 - ILLCHR=0 592 - DO 185 J=1,NCSTR 593 - IF(INDEX('+-*/&|<=#>^ ,.:;([{)]}''"`',STRING(J:J)).NE.0)THEN 594 - ILLCHR=ILLCHR+1 595 - OK=.FALSE. 596 - ENDIF 597 - 185 CONTINUE 598 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',STRING(1:1)).EQ.0)THEN 599 - CALL INPMSG(2,'Does not start with a letter. ') 600 - OK=.FALSE. 601 - ELSEIF(ILLCHR.EQ.1)THEN 602 - CALL INPMSG(2,'Contains an illegal character.') 603 - ELSEIF(ILLCHR.GT.1)THEN 604 - CALL INPMSG(2,'Contains illegal characters. ') 605 - * Check the name is not more than 10 characters long. 606 - ELSEIF(NCSTR.GT.10)THEN 607 - CALL INPMSG(2,'Name longer than 10 characters') 608 - OK=.FALSE. 609 - * Check the name is not empty. 610 - ELSEIF(NCSTR.LE.0)THEN 611 - CALL INPMSG(2,'Empty names are not permitted.') 612 - OK=.FALSE. 613 - ELSE 614 - * Figure out which variable to redefine. 615 - DO 150 I=1,NGLB 616 - IF(GLBVAR(I).EQ.STRING(1:NCSTR))THEN 617 - IGLB=I 618 - GOTO 160 619 - ENDIF 620 - 150 CONTINUE 621 - * See whether there still is space to store a new global. 622 - IF(NGLB.GE.MXVAR)THEN 623 - PRINT *,' !!!!!! INPRDO WARNING : Unable to'// 624 - - ' store global variable "'//STRING(1:NCSTR)// 625 - - '"; increase MXVAR and recompile.' 626 - OK=.FALSE. 627 - GOTO 186 628 - * Add the new global. 629 - ELSE 630 - NGLB=NGLB+1 631 - GLBVAR(NGLB)=STRING(1:NCSTR) 632 - GLBMOD(NGLB)=0 633 - ENDIF 634 - IGLB=NGLB 635 - 160 CONTINUE 636 - * Ensure that this variable is not a system variable. 637 - IF(IGLB.LE.4)THEN 638 - PRINT *,' !!!!!! INPRDO WARNING : '// 639 - - STRING(1:NCSTR)//' may not be redefined;'// 640 - - ' definition ignored.' 1 64 P=INPUT D=INPRDO 8 PAGE 65 641 - OK=.FALSE. 642 - GOTO 186 643 - ENDIF 644 - ENDIF 645 - * Store the reference, -1 for indexed assignments (list takes care). 646 - IF(NCIND.EQ.0)THEN 647 - LINREF(NDOLIN,7)=IGLB 648 - ELSE 649 - LINREF(NDOLIN,7)=-1 650 - ENDIF 651 - ** Fetch the expression. 652 - IF(NWORD.GE.3)THEN 653 - CALL INPSTR(3,NWORD,STRING,NC) 654 - ELSE 655 - STRING='NILL' 656 - NC=4 657 - ENDIF 658 - ** Translate the expression, first with indexing. 659 - IF(NCIND.NE.0)THEN 660 - CALL ALGPRE('('//STRING(1:NC)//')'//INDSTR(1:NCIND), 661 - - NC+NCIND+2,GLBVAR,NGLB,NNRES,USE,LINREF(NDOLIN,8), 662 - - IFAIL) 663 - * Check validity. 664 - IF(IFAIL.NE.0)THEN 665 - PRINT *,' !!!!!! INPRDO WARNING : Unable to'// 666 - - ' process the indexing expression; global'// 667 - - ' not assigned.' 668 - OK=.FALSE. 669 - GOTO 186 670 - ELSEIF(NNRES.NE.1)THEN 671 - PRINT *,' !!!!!! INPRDO WARNING : Formula'// 672 - - ' doesn''t lead to 1 result; global not'// 673 - - ' assigned.' 674 - OK=.FALSE. 675 - GOTO 186 676 - ENDIF 677 - * Locate the entry point number. 678 - IENTNO=0 679 - DO 70 I=1,NALGE 680 - IF(ALGENT(I,1).EQ.LINREF(NDOLIN,8).AND. 681 - - ALGENT(I,3).EQ.1)IENTNO=I 682 - 70 CONTINUE 683 - IF(IENTNO.EQ.0)THEN 684 - PRINT *,' !!!!!! INPRDO WARNING : No valid'// 685 - - ' indexing entry point found; global'// 686 - - ' not assigned.' 687 - OK=.FALSE. 688 - GOTO 186 689 - ENDIF 690 - * Locate the final EXTRACT_SUBMATRIX call. 691 - DO 80 I=ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1, 692 - - ALGENT(IENTNO,5)+2,-1 693 - IF(INS(I,1).EQ.-80.AND.INS(I,2).EQ.9.AND. 694 - - INS(I-1,2).EQ.8.AND.INS(I-2,2).EQ.8)THEN 695 - IEXTR=I 696 - GOTO 90 697 - ENDIF 698 - 80 CONTINUE 699 - PRINT *,' !!!!!! INPRDO WARNING : Instruction list'// 700 - - ' tail not as expected.' 701 - OK=.FALSE. 702 - GOTO 186 703 - 90 CONTINUE 704 - * Store the location of the last instruction. 705 - ILAST=ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 706 - * Replace result and return by DELETE_MATRIX on temporary matrix. 707 - INS(ILAST-1,1)= 0 708 - INS(ILAST-1,2)= 8 709 - INS(ILAST-1,3)=INS(IEXTR-2,3) 710 - INS(ILAST-1,4)= 1 711 - INS(ILAST ,1)=-86 712 - INS(ILAST ,2)= 9 713 - INS(ILAST ,3)= 1 714 - INS(ILAST ,4)= 0 715 - * Replace EXTRACT_SUBMATRIX by STORE_SUBMATRIX. 716 - INS(IEXTR ,1)=-81 717 - * Exchange the in/out matrices, assign to global, fix protections. 718 - INS(IEXTR-1,1)= 3 719 - INS(IEXTR-1,3)=INS(IEXTR-2,3) 720 - INS(IEXTR-2,1)= 0 721 - INS(IEXTR-2,3)=IGLB 722 - *** In debug mode, print the list. 723 - IF(LDEBUG)THEN 724 - WRITE(LUNOUT,'('' ++++++ INPRDO DEBUG : List'', 725 - - '' after processing indexing calls:'')') 726 - CALL ALGPRT(ALGENT(IENTNO,5),ALGENT(IENTNO,5)+ 727 - - ALGENT(IENTNO,6)-1) 728 - ENDIF 729 - ** Translate for the case without indexing. 730 - ELSE 731 - CALL ALGPRE(STRING(1:NC),NC, 732 - - GLBVAR,NGLB,NNRES,USE,LINREF(NDOLIN,8),IFAIL) 733 - * Check validity. 734 - IF(IFAIL.NE.0)THEN 735 - PRINT *,' !!!!!! INPRDO WARNING : Unable to'// 736 - - ' process the indexing expression; global'// 737 - - ' not assigned.' 738 - OK=.FALSE. 739 - ELSEIF(NNRES.NE.1)THEN 740 - PRINT *,' !!!!!! INPRDO WARNING : Formula'// 741 - - ' doesn''t lead to 1 result; global not'// 742 - - ' assigned.' 743 - OK=.FALSE. 744 - ENDIF 745 - ENDIF 746 - ** Resume here for non-translatable GLOBALs. 1 64 P=INPUT D=INPRDO 9 PAGE 66 747 - 186 CONTINUE 748 - *** Declare variables used in VECTOR statements. 749 - ELSEIF(INPCMP(1,'VECTOR')+INPCMP(1,'R#EAD-VECT#OR').NE.0)THEN 750 - * Ensure that there is no evaluation in the statement anywhere. 751 - CALL INPSTR(2,NWORD,STRING,NC) 752 - IF(INDEX(STRING(1:NC),'{')+INDEX(STRING(1:NC),'}').NE.0) 753 - - GOTO 188 754 - ** Loop over the vector names. 755 - DO 230 I=2,NWORD 756 - * Skip dummy fields. 757 - IF(INPCMP(I,'DUMMY').NE.0)GOTO 230 758 - * Fetch the variable name. 759 - CALL INPSTR(I,I,STRING,NCSTR) 760 - * Check for illegal characters. 761 - ILLCHR=0 762 - DO 240 J=1,NCSTR 763 - IF(INDEX('+-*/&|<=#>^ ,.:;([{)]}''"`',STRING(J:J)).NE.0)THEN 764 - ILLCHR=ILLCHR+1 765 - OK=.FALSE. 766 - ENDIF 767 - 240 CONTINUE 768 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',STRING(1:1)).EQ.0)THEN 769 - CALL INPMSG(I,'Does not start with a letter. ') 770 - OK=.FALSE. 771 - ELSEIF(ILLCHR.EQ.1)THEN 772 - CALL INPMSG(I,'Contains an illegal character.') 773 - ELSEIF(ILLCHR.GT.1)THEN 774 - CALL INPMSG(I,'Contains illegal characters. ') 775 - * Check the name is not more than 10 characters long. 776 - ELSEIF(NCSTR.GT.10)THEN 777 - CALL INPMSG(I,'Name longer than 10 characters') 778 - OK=.FALSE. 779 - * Check the name is not empty. 780 - ELSEIF(NCSTR.LE.0)THEN 781 - CALL INPMSG(I,'Empty names are not permitted.') 782 - OK=.FALSE. 783 - ELSE 784 - * Figure out whether this variable already exists. 785 - IGLB=0 786 - DO 250 J=1,NGLB 787 - IF(GLBVAR(J).EQ.STRING(1:NCSTR))THEN 788 - IGLB=J 789 - GOTO 260 790 - ENDIF 791 - 250 CONTINUE 792 - * See whether there still is space to store a new global. 793 - IF(NGLB.GE.MXVAR)THEN 794 - PRINT *,' !!!!!! INPRDO WARNING : Unable to'// 795 - - ' store global variable "'//STRING(1:NCSTR)// 796 - - '"; increase MXVAR and recompile.' 797 - OK=.FALSE. 798 - GOTO 230 799 - * Add the new global. 800 - ELSE 801 - NGLB=NGLB+1 802 - GLBVAR(NGLB)=STRING(1:NCSTR) 803 - GLBMOD(NGLB)=0 804 - WRITE(LUNOUT,'('' ------ INPRDO MESSAGE : '',A, 805 - - '' declared as a global variable.'')') 806 - - STRING(1:NCSTR) 807 - ENDIF 808 - IGLB=NGLB 809 - 260 CONTINUE 810 - * Ensure that this variable is not a system variable. 811 - IF(IGLB.LE.4)THEN 812 - PRINT *,' !!!!!! INPRDO WARNING : '// 813 - - STRING(1:NCSTR)//' may not be redefined;'// 814 - - ' definition ignored.' 815 - OK=.FALSE. 816 - GOTO 230 817 - ENDIF 818 - ENDIF 819 - * Next vector. 820 - 230 CONTINUE 821 - * Skip if there are { }. 822 - 188 CONTINUE 823 - *** And for procedure calls. 824 - ELSEIF(INPCMP(1,'CALL').NE.0.AND.NWORD.GE.2)THEN 825 - * Ensure that there is no evaluation in the statement anywhere. 826 - CALL INPSTR(2,NWORD,STRING,NC) 827 - IF(INDEX(STRING(1:NC),'{')+INDEX(STRING(1:NC),'}').NE.0) 828 - - GOTO 187 829 - * Assign the line type. 830 - LINREF(NDOLIN,1)=22 831 - * Generate an entry point. 832 - CALL INPCAL('STORE',LINREF(NDOLIN,8),IFAIL1) 833 - IF(IFAIL1.NE.0)THEN 834 - PRINT *,' !!!!!! INPRDO WARNING : CALL statement'// 835 - - ' could not be processed.' 836 - OK=.FALSE. 837 - ENDIF 838 - * Resume here for non-translatable CALLs. 839 - 187 CONTINUE 840 - ENDIF 841 - *** Ensure there is no input-redirect 842 - CALL INPSTR(1,1,STRING,NC) 843 - IF(STRING(1:1).EQ.'<')THEN 844 - PRINT *,' !!!!!! INPRDO WARNING : Input redirection is'// 845 - - ' not permitted inside a loop; loop rejected.' 846 - OK=.FALSE. 847 - ENDIF 848 - *** Store the line in the buffer, no matter the contents. 849 - CALL INPRAW(STRING) 850 - DO 300 I=MXINCH,1,-1 851 - IF(STRING(I:I).NE.' ')THEN 852 - I1=I 1 64 P=INPUT D=INPRDO 10 PAGE 67 853 - GOTO 310 854 - ENDIF 855 - 300 CONTINUE 856 - I1=1 857 - 310 CONTINUE 858 - DO 320 I=1,I1 859 - IF(STRING(I:I).NE.' ')THEN 860 - I0=I 861 - GOTO 330 862 - ENDIF 863 - 320 CONTINUE 864 - I0=1 865 - 330 CONTINUE 866 - CALL STRBUF('STORE',LINREF(NDOLIN,2),STRING(I0:I1),I1-I0+1,IFAIL) 867 - IF(IFAIL.NE.0)THEN 868 - PRINT *,' !!!!!! INPRDO WARNING : Unable to store an'// 869 - - ' input line.' 870 - OK=.FALSE. 871 - ENDIF 872 - *** Dump the error messages. 873 - CALL INPERR 874 - *** And read the next line, if we're still in the loop nest. 875 - IF(CDOLVL.GT.0)THEN 876 - * Format the prompt. 877 - PROMPT=' ' 878 - IF(CIFLVL.GT.0.AND.CDOLVL.GT.0)THEN 879 - WRITE(PROMPT,'(''Do_'',I3,''_If_'',I3)') CDOLVL,CIFLVL 880 - ELSEIF(CDOLVL.GT.0)THEN 881 - WRITE(PROMPT,'(''Do_'',I3)') CDOLVL 882 - ELSEIF(CIFLVL.GT.0)THEN 883 - WRITE(PROMPT,'(''If_'',I3)') CIFLVL 884 - ELSE 885 - PROMPT='Loop' 886 - ENDIF 887 - NCPRM=0 888 - DO 400 I=1,13 889 - IF(PROMPT(I:I).NE.' ')THEN 890 - NCPRM=NCPRM+1 891 - PROMPT(NCPRM:NCPRM)=PROMPT(I:I) 892 - ENDIF 893 - 400 CONTINUE 894 - CALL INPPRM(' ','BACK') 895 - CALL INPPRM(PROMPT(1:MAX(1,NCPRM)),'ADD') 896 - * Read the new line. 897 - CALL INPGET 898 - GOTO 10 899 - ENDIF 900 - *** End of the loop nest has been reached, debugging output. 901 - IF(LDEBUG)THEN 902 - * Header. 903 - WRITE(LUNOUT,'(/2X,''OVERVIEW OF THE DO LOOP NEST''// 904 - - 2X,''Number of input lines: '',I3/ 905 - - 2X,''Deepest nesting level: '',I3,'' / '',I3//, 906 - - 2X,''Line Type Loop Cond Jump'', 907 - - '' If Glb Entr Contents'')') 908 - - NDOLIN,MAXDOL,MAXIFL 909 - * Listing. 910 - BLANK=' ' 911 - CIFLVL=0 912 - CDOLVL=0 913 - DO 200 I=1,NDOLIN 914 - CALL STRBUF('READ',LINREF(I,2),STRING,NC,IFAIL) 915 - IF(LINREF(I,1).EQ.4)CDOLVL=CDOLVL-1 916 - IF(LINREF(I,1).EQ.12.OR.LINREF(I,1).EQ.13.OR. 917 - - LINREF(I,1).EQ.14)CIFLVL=CIFLVL-1 918 - IF(LINREF(I,1).EQ.0)THEN 919 - TYPE=' ' 920 - ELSEIF(LINREF(I,1).EQ.1)THEN 921 - TYPE='Do-block' 922 - ELSEIF(LINREF(I,1).EQ.2)THEN 923 - TYPE='Iterate ' 924 - ELSEIF(LINREF(I,1).EQ.3)THEN 925 - TYPE='Leave ' 926 - ELSEIF(LINREF(I,1).EQ.4)THEN 927 - TYPE='Enddo ' 928 - ELSEIF(LINREF(I,1).EQ.11)THEN 929 - TYPE='If-block' 930 - ELSEIF(LINREF(I,1).EQ.12)THEN 931 - TYPE='Elseif ' 932 - ELSEIF(LINREF(I,1).EQ.13)THEN 933 - TYPE='Else ' 934 - ELSEIF(LINREF(I,1).EQ.14)THEN 935 - TYPE='Endif ' 936 - ELSEIF(LINREF(I,1).EQ.21)THEN 937 - TYPE='Global ' 938 - ELSEIF(LINREF(I,1).EQ.22)THEN 939 - TYPE='Call ' 940 - ELSE 941 - TYPE='Unknown ' 942 - ENDIF 943 - IF(IFAIL.EQ.0)THEN 944 - WRITE(LUNOUT,'(1X,I5,1X,A8,6I5,5X,A)') 945 - - I,TYPE,(LINREF(I,J),J=3,8), 946 - - BLANK(1:MIN(80,MAX(1,1+3*(CDOLVL+CIFLVL))))// 947 - - STRING(1:NC) 948 - ELSE 949 - WRITE(LUNOUT,'(1X,I5,1X,A8,6I5,5X, 950 - - ''# Unable to retrieve'')') 951 - - I,TYPE,(LINREF(I,J),J=3,8) 952 - ENDIF 953 - IF(LINREF(I,1).EQ.1)CDOLVL=CDOLVL+1 954 - IF(LINREF(I,1).EQ.11.OR.LINREF(I,1).EQ.12.OR. 955 - - LINREF(I,1).EQ.13)CIFLVL=CIFLVL+1 956 - 200 CONTINUE 957 - * DO loops. 958 - IF(NLOOP.GE.1)THEN 1 64 P=INPUT D=INPRDO 11 PAGE 68 959 - WRITE(LUNOUT,'(/2X,''DO LOOP INDEX''//2X, 960 - - '' No Variable Init Step While Until To'', 961 - - '' First Last Level If''/)') 962 - DO 210 I=1,NLOOP 963 - IF(DOREF(I,9).GT.0)THEN 964 - WRITE(LUNOUT,'(2X,I3,1X,A10,9I6)') I, 965 - - GLBVAR(DOREF(I,9)),(DOREF(I,J),J=1,8), 966 - - DOREF(I,10) 967 - ELSE 968 - WRITE(LUNOUT,'(2X,I3,1X,A10,12X,2I6,6X,4I6)') I, 969 - - ' < none > ',(DOREF(I,J),J=3,4), 970 - - (DOREF(I,J),J=6,8),DOREF(I,10) 971 - ENDIF 972 - 210 CONTINUE 973 - ELSE 974 - WRITE(LUNOUT,'(/2X,''NO DO LOOPS''/)') 975 - ENDIF 976 - * IF blocks. 977 - IF(NIF.GE.1)THEN 978 - WRITE(LUNOUT,'(/2X,''IF BLOCK INDEX''//2X, 979 - - '' No State Last Do lvl If lvl'' 980 - - /)') 981 - DO 220 I=1,NIF 982 - WRITE(LUNOUT,'(2X,I3,5I10)') I,IFREF(I,1),IFREF(I,2), 983 - - IFREF(I,4),IFREF(I,5) 984 - 220 CONTINUE 985 - ELSE 986 - WRITE(LUNOUT,'(/2X,''NO IF BLOCKS''/)') 987 - ENDIF 988 - ENDIF 989 - *** Normal end of the routine. 990 - IF(OK)THEN 991 - IFAIL=0 992 - ISTATE=0 993 - ELSE 994 - PRINT *,' !!!!!! INPRDO WARNING : The DO loop nest is not'// 995 - - ' executable as a result of the above errors.' 996 - IFAIL=1 997 - ISTATE=-1 998 - CALL INPCDO 999 - ENDIF 1000 - * Reset the prompt. 1001 - CALL INPPRM(' ','BACK') 1002 - END 65 GARFIELD ================================================== P=INPUT D=INPRDR 1 ============================ 0 + +DECK,INPRDR. 1 - SUBROUTINE INPRDR(IWRD,VAL,DEF) 2 - *----------------------------------------------------------------------- 3 - * INPRDR - Reads word IWRD into VAL, using the default DEF if the 4 - * word is empty and if it contains a *. 5 - * (Last changed on 1/ 7/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,INPUT. 10 - CHARACTER*25 AUX 11 - INTEGER IWRD 12 - REAL VAL,DEF 13 - *** Out of range ? 14 - IF(IWRD.LE.0.OR.IWRD.GT.NWORD.OR. 15 - - WORD(IWRD).EQ.' '.OR.WORD(IWRD).EQ.'*')THEN 16 - VAL=DEF 17 - RETURN 18 - ENDIF 19 - *** Read the value. 20 - AUX=WORD(IWRD)(1:NCHAR(IWRD)) 21 - READ(AUX,'(BN,F25.13)') VAL 22 - END 66 GARFIELD ================================================== P=INPUT D=INPRIC 1 ============================ 0 + +DECK,INPRIC. 1 - SUBROUTINE INPRIC(INSTR,IVAL,IDEF,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * INPRIC - Checks that INSTR contains one integer, reads it into IVAL 4 - * taking IDEF instead if necessary and returns IFAIL=1 5 - * if serious errors were detected by INPCHK. 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,INPUT. 9 - CHARACTER*(*) INSTR 10 - CHARACTER*(MXWORD) WRDRES 11 - CHARACTER*30 ECDRES 12 - LOGICAL ERRRES 13 - INTEGER IVAL,IDEF,IFAIL 14 - *** First store all data on word 1 and remember the number of words. 15 - WRDRES=WORD(1) 16 - ECDRES=ERRCDE(1) 17 - ERRRES=ERRPRT(1) 18 - NCHRES=NCHAR(1) 19 - NWRRES=NWORD 20 - *** Store the word to be checked in word 1 and check it. 21 - NWORD=1 22 - WORD(1)=INSTR 23 - CALL INPCHK(1,1,IFAIL) 24 - CALL INPRDI(1,IVAL,IDEF) 25 - *** Print the error message, if any. 26 - IF(ERRPRT(1))THEN 27 - PRINT *,' !!!!!! INPRIC WARNING : ',INSTR, 28 - - ' was changed into '//WORD(1)(1:NCHAR(1)) 29 - PRINT *,' Reason: '//ERRCDE(1) 30 - PRINT *,' Value assigned : ',IVAL 31 - ENDIF 32 - *** Restore the old word 1 in its place. 1 66 P=INPUT D=INPRIC 2 PAGE 69 33 - WORD(1) =WRDRES 34 - ERRCDE(1)=ECDRES 35 - ERRPRT(1)=ERRRES 36 - NCHAR(1) =NCHRES 37 - NWORD =NWRRES 38 - END 67 GARFIELD ================================================== P=INPUT D=INPRRC 1 ============================ 0 + +DECK,INPRRC. 1 - SUBROUTINE INPRRC(INSTR,VAL,DEF,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * INPRRC - Checks that INSTR contains one real, reads it into VAL 4 - * taking DEF instead if necessary and returns IFAIL=1 5 - * if serious errors were detected by INPCHK. 6 - * (Last changed on 23/ 8/95.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,INPUT. 11 - CHARACTER*(*) INSTR 12 - CHARACTER*(MXWORD) WRDRES 13 - CHARACTER*30 ECDRES 14 - LOGICAL ERRRES 15 - REAL VAL,DEF 16 - INTEGER IFAIL,NCHRES,NWRRES 17 - *** First store all data on word 1 and remember the number of words. 18 - WRDRES=WORD(1) 19 - ECDRES=ERRCDE(1) 20 - ERRRES=ERRPRT(1) 21 - NCHRES=NCHAR(1) 22 - NWRRES=NWORD 23 - *** Store the word to be checked in word 1. 24 - NWORD=1 25 - WORD(1)=INSTR 26 - ERRPRT(1)=.FALSE. 27 - ERRCDE(1)=' ' 28 - NCHAR(1)=LEN(INSTR) 29 - *** Check the word and read it. 30 - CALL INPCHK(1,2,IFAIL) 31 - CALL INPRDR(1,VAL,DEF) 32 - *** Print the error message, if any. 33 - IF(ERRPRT(1))THEN 34 - PRINT *,' !!!!!! INPRRC WARNING : ',INSTR, 35 - - ' was changed into '//WORD(1)(1:NCHAR(1)) 36 - PRINT *,' Reason: '//ERRCDE(1) 37 - PRINT *,' Value assigned : ',VAL 38 - ENDIF 39 - *** Restore the old word 1 in its place. 40 - WORD(1) =WRDRES 41 - ERRCDE(1)=ECDRES 42 - ERRPRT(1)=ERRRES 43 - NCHAR(1) =NCHRES 44 - NWORD =NWRRES 45 - END 68 GARFIELD ================================================== P=INPUT D=INPSTR 1 ============================ 0 + +DECK,INPSTR. 1 - SUBROUTINE INPSTR(IWRD1,IWRD2,OUT,NC) 2 - *----------------------------------------------------------------------- 3 - * INPSTR - Returns in OUT the words IWRD1 through IWRD2 + total length 4 - * (Last changed on 24/ 5/90.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,INPUT. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*(*) OUT 11 - INTEGER IWRD1,IWRD2,NC,I1,I2,LENOUT 12 - *** Store length of output string. 13 - LENOUT=LEN(OUT) 14 - OUT=' ' 15 - NC=0 16 - *** Return with an empty string if the arguments are clearly wrong. 17 - IF(IWRD1.GT.NWORD.OR.IWRD1.GT.MXWORD.OR.IWRD2.LT.1.OR. 18 - - IWRD1.GT.IWRD2)RETURN 19 - *** Find index of first word to be returned. 20 - IF(IWRD1.LT.1)THEN 21 - I1=INDWRD(1) 22 - ELSE 23 - I1=INDWRD(IWRD1) 24 - ENDIF 25 - *** Find index of last word to be returned. 26 - IF(IWRD2.LE.NWORD.AND.IWRD2.LE.MXWORD)THEN 27 - I2=INDWRD(IWRD2)+NCHAR(IWRD2)-1 28 - ELSE 29 - I2=INDWRD(NWORD)+NCHAR(NWORD)-1 30 - ENDIF 31 - *** Check the setting of I1, I2. 32 - IF(I1.LT.1.OR.I2.LT.1.OR.I2-I1+1.GT.LENOUT.OR.I2.LT.I1)THEN 33 - PRINT *,' !!!!!! INPSTR WARNING : Input string is longer'// 34 - - ' than calling routine thought; string truncated.' 35 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''I1='',I3,'', I2='',I3, 36 - - '', LEN(OUT)='',I3)') I1,I2,LENOUT 37 - IF(I1.LT.1)I1=1 38 - IF(I2-I1+1.GT.LENOUT)I2=I1+LENOUT-1 39 - IF(I2.LT.1)I2=1 40 - IF(I2.LT.I1)I2=I1 41 - ENDIF 42 - *** Set the output string and the number of characters. 43 - NC=MIN(I2-I1+1,LENOUT) 44 - OUT(1:NC)=STRING(I1:I2) 45 - END 1 69 GARFIELD ================================================== P=INPUT D=INPSUB 1 =================== PAGE 70 0 + +DECK,INPSUB. 1 - SUBROUTINE INPSUB(STR,NC,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * INPSUB - Evaluates global variables and substitutes them. 4 - * (Last changed on 20/ 3/01.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,INPUT. 9.- +SEQ,GLOBALS. 10.- +SEQ,PRINTPLOT. 11 - CHARACTER*(*) STR 12 - CHARACTER*(MXINCH) OUT,AUX 13 - LOGICAL USE(MXVAR) 14 - REAL RES(100) 15 - INTEGER MODRES(100),I,J,K,NCOUT,NC,IFAIL,INEXT,IENTRY,NRES,NCRES 16 - *** Identify the routine if requested. 17 - IF(LIDENT)PRINT *,' /// ROUTINE INPSUB ///' 18 - *** Initial values. 19 - INEXT=1 20 - NCOUT=0 21 - OUT=' ' 22 - IFAIL=0 23 - *** Scan the string. 24 - DO 10 I=1,NC 25 - IF(I.LT.INEXT.OR.STR(I:I).NE.'{'.OR. 26 - - (I.GT.1.AND.STR(MAX(1,I-1):I).EQ.ESCAPE//'{'))GOTO 10 27 - *** Copy the string up to the bracket. 28 - IF(I-1.GE.INEXT)THEN 29 - IF(NCOUT+I-INEXT.GT.LEN(STR).OR. 30 - - NCOUT+I-INEXT.GT.LEN(OUT))GOTO 3000 31 - OUT(NCOUT+1:NCOUT+I-INEXT)=STR(INEXT:I-1) 32 - NCOUT=NCOUT+I-INEXT 33 - ENDIF 34 - *** Scan for the closing bracket. 35 - DO 20 J=I+1,NC 36 - * Make sure we don't see a new open before this one is closed. 37 - IF(STR(J:J).EQ.'{'.AND. 38 - - (J.GT.1.AND.STR(MAX(1,J-1):J).NE.ESCAPE//'{'))THEN 39 - PRINT *,' !!!!!! INPSUB WARNING : No nesting of'// 40 - - ' substitution brackets allowed; no substitution.' 41 - IFAIL=1 42 - RETURN 43 - ENDIF 44 - * Skip until the closing bracket is seen. 45 - IF(STR(J:J).NE.'}'.OR. 46 - - (J.GT.1.AND.STR(MAX(1,J-1):J).EQ.ESCAPE//'}'))GOTO 20 47 - INEXT=J+1 48 - * String is empty. 49 - IF(J.LE.I+1)GOTO 10 50 - * String is not empty, translate. 51 - CALL ALGPRE(STR(I+1:J-1),J-I-1,GLBVAR,NGLB,NRES,USE,IENTRY, 52 - - IFAIL) 53 - IF(IFAIL.NE.0.OR.NRES.GT.100)THEN 54 - PRINT *,' !!!!!! INPSUB WARNING : The string "', 55 - - STR(I+1:J-1),'" can not be translated'// 56 - - ' or produces too many results.' 57 - IF(NCOUT+1.GT.LEN(STR).OR.NCOUT+1.GT.LEN(OUT))GOTO 3000 58 - OUT(NCOUT+1:NCOUT+1)='?' 59 - NCOUT=NCOUT+1 60 - CALL ALGCLR(IENTRY) 61 - GOTO 10 62 - ENDIF 63 - * Execute. 64 - CALL TIMEL(GLBVAL(1)) 65 - CALL AL2EXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,NRES,IFAIL) 66 - CALL ALGERR 67 - IF(IFAIL.NE.0)THEN 68 - PRINT *,' !!!!!! INPSUB WARNING : The expression "', 69 - - STR(I+1:J-1),'" is syntax-wise correct'// 70 - - ' but can not be evaluated.' 71 - CALL ALGCLR(IENTRY) 72 - DO 40 K=1,NRES 73 - CALL ALGREU(NINT(RES(K)),MODRES(K),1) 74 - 40 CONTINUE 75 - IF(NCOUT+1.GT.LEN(STR).OR.NCOUT+1.GT.LEN(OUT))GOTO 3000 76 - OUT(NCOUT+1:NCOUT+1)='?' 77 - NCOUT=NCOUT+1 78 - GOTO 10 79 - ENDIF 80 - * Remove the entry point. 81 - CALL ALGCLR(IENTRY) 82 - * Format each of the resulting numbers. 83 - DO 30 K=1,NRES 84 - CALL OUTFMT(RES(K),MODRES(K),AUX,NCRES,'LEFT') 85 - CALL ALGREU(NINT(RES(K)),MODRES(K),1) 86 - IF(NCOUT+NCRES.GT.LEN(STR).OR. 87 - - NCOUT+NCRES.GT.LEN(OUT))GOTO 3000 88 - OUT(NCOUT+1:NCOUT+NCRES)=AUX(1:NCRES) 89 - NCOUT=NCOUT+NCRES 90 - IF(K.NE.NRES.AND.NRES.GT.1)THEN 91 - IF(NCOUT+2.GT.LEN(STR).OR.NCOUT+2.GT.LEN(OUT))GOTO 3000 92 - OUT(NCOUT+1:NCOUT+2)=', ' 93 - NCOUT=NCOUT+2 94 - ENDIF 95 - 30 CONTINUE 96 - *** Next component. 97 - GOTO 10 98 - 20 CONTINUE 99 - *** Arrive here if the bracket is not closed. 100 - PRINT *,' !!!!!! INPSUB WARNING : Substitution bracket is not'// 101 - - ' closed ; no substitution.' 102 - IFAIL=1 103 - RETURN 104 - 10 CONTINUE 105 - *** Copy the remainder. 1 69 P=INPUT D=INPSUB 2 PAGE 71 106 - IF(NC.GE.INEXT)THEN 107 - IF(NCOUT+NC-INEXT+1.GT.LEN(STR).OR. 108 - - NCOUT+NC-INEXT+1.GT.LEN(OUT))GOTO 3000 109 - OUT(NCOUT+1:NCOUT+NC-INEXT+1)=STR(INEXT:NC) 110 - NCOUT=NCOUT+NC-INEXT+1 111 - ENDIF 112 - *** Debugging output. 113 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPSUB DEBUG : In ="'',A, 114 - - ''"''/26X,''Out="'',A,''"'')') 115 - - STR(1:MIN(100,MAX(1,NC))),OUT(1:MIN(100,MAX(1,NCOUT))) 116 - *** Send the string back. 117 - NC=NCOUT 118 - STR=OUT(1:MAX(1,MIN(MXINCH,LEN(STR),LEN(OUT),NCOUT))) 119 - IFAIL=0 120 - RETURN 121 - *** Error because the resulting string is too long. 122 - 3000 CONTINUE 123 - PRINT *,' !!!!!! INPSUB WARNING : Substitution results in a'// 124 - - ' string that is too long; no substitution.' 125 - IFAIL=1 126 - END 70 GARFIELD ================================================== P=INPUT D=INPSWI 1 ============================ 0 + +DECK,INPSWI. 1 - SUBROUTINE INPSWI(STREAM) 2 - *----------------------------------------------------------------------- 3 - * INPSWI - Switches input stream. 4 - * (Last changed on 31/ 8/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,INPUT. 9.- +SEQ,GLOBALS. 10 - CHARACTER*(*) STREAM 11 - LOGICAL DOXRES,RES,LINRES 12 - INTEGER LUNRES 0 13-+ +SELF,IF=SAVE. 14 - SAVE LUNRES,DOXRES,RES 0 15-+ +SELF. 16 - DATA LUNRES/5/, DOXRES/.FALSE./, RES/.FALSE./ 17 - *** Switch to terminal input. 18 - IF(STREAM.EQ.'TERMINAL')THEN 19 - LUNRES=LUN 20 - LUN=5 21 - GLBVAL(6)=LUNSTR(LUN,1) 22 - DOXRES=DOEXEC 23 - DOEXEC=.FALSE. 24 - LINRES=LINREC 25 - LINREC=.FALSE. 26 - RES=.TRUE. 27 - *** Switch to data file on unit 12. 28 - ELSEIF(STREAM.EQ.'UNIT12')THEN 29 - LUNRES=LUN 30 - LUN=12 31 - GLBVAL(6)=LUNSTR(LUN,1) 32 - DOXRES=DOEXEC 33 - DOEXEC=.FALSE. 34 - LINRES=LINREC 35 - LINREC=.FALSE. 36 - RES=.TRUE. 37 - *** Restore the previous state. 38 - ELSEIF(STREAM.EQ.'RESTORE')THEN 39 - IF(RES)THEN 40 - LUN=LUNRES 41 - GLBVAL(6)=LUNSTR(LUN,1) 42 - DOEXEC=DOXRES 43 - LINREC=LINRES 44 - RES=.FALSE. 45 - ELSE 46 - PRINT *,' !!!!!! INPSWI WARNING : No state stored'// 47 - - ' to be restored (program bug - please report).' 48 - ENDIF 49 - *** Other parameters are not valid. 50 - ELSE 51 - PRINT *,' !!!!!! INPSWI WARNING : Invalid stream ',STREAM, 52 - - ' value received (program bug - please report).' 53 - ENDIF 54 - END 71 GARFIELD ================================================== P=INPUT D=INPTMP 1 ============================ 0 + +DECK,INPTMP. 1 - SUBROUTINE INPTMP(STRING,NCSTR,FORMAT,NCFMT,EXEC,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * INPTMP - Studies the template and the input string to assign the 4 - * global variables for the Parse instruction. 5 - * (Last changed on 10/11/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,GLOBALS. 10.- +SEQ,PRINTPLOT. 11 - CHARACTER*(*) STRING,FORMAT 12 - CHARACTER*5 AUXSTR 13 - INTEGER MXELEM 14 - PARAMETER(MXELEM=100) 15 - REAL RES(1) 16 - INTEGER NCSTR,NCFMT,LIST(MXELEM,3),MODRES(1),IFAIL,NELEM,I0,I,I1, 17 - - ILAST,INEXT,IOK,J,JSTART,JEND,JNEXT,NRES,IFAIL1,IENTRY,K, 18 - - IGLB,IREF,IMODE 19 - LOGICAL USE(MXVAR),EXEC 20 - *** Identify the routine for tracing purposes. 21 - IF(LIDENT)PRINT *,' /// ROUTINE INPTMP ///' 1 71 P=INPUT D=INPTMP 2 PAGE 72 22 - *** Initial debugging output. 23 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPTMP DEBUG : String: "'', 24 - - A,''",''/26X,''Format: "'',A,''".'')') 25 - - STRING(1:NCSTR),FORMAT(1:NCFMT) 26 - *** Initialise. 27 - NELEM=0 28 - IFAIL=0 29 - *** Read the fragments of the format. 30 - INEXT=1 31 - DO 10 I0=1,NCFMT 32 - ** Skip if we have read further already. 33 - IF(I0.LT.INEXT)GOTO 10 34 - ** Skip blanks. 35 - IF(FORMAT(I0:I0).EQ.' ')THEN 36 - GOTO 10 37 - ** Full stop. 38 - ELSEIF(FORMAT(I0:I0).EQ.'.')THEN 39 - NELEM=NELEM+1 40 - IF(NELEM.GE.MXELEM)GOTO 3010 41 - LIST(NELEM,1)=3 42 - LIST(NELEM,2)=I0 43 - LIST(NELEM,3)=I0 44 - INEXT=I0+1 45 - ** Start of a quoted portion. 46 - ELSEIF(FORMAT(I0:I0).EQ.''''.OR. 47 - - FORMAT(I0:I0).EQ.'"'.OR. 48 - - FORMAT(I0:I0).EQ.'`')THEN 49 - * Locate the end of the string. 50 - DO 20 I=I0+1,NCFMT 51 - IF(FORMAT(I:I).EQ.FORMAT(I0:I0))THEN 52 - I1=I 53 - INEXT=I1+1 54 - GOTO 30 55 - ENDIF 56 - 20 CONTINUE 57 - INEXT=NCFMT+1 58 - I1=NCFMT+1 59 - 30 CONTINUE 60 - * Make sure that the quoted portion is not empty. 61 - IF(I0+1.GT.I1-1)GOTO 10 62 - * Store the string. 63 - NELEM=NELEM+1 64 - IF(NELEM.GE.MXELEM)GOTO 3010 65 - LIST(NELEM,1)=2 66 - LIST(NELEM,2)=I0+1 67 - LIST(NELEM,3)=I1-1 68 - ** Start of a variable name. 69 - ELSE 70 - DO 40 I1=I0+1,NCFMT 71 - IF(INDEX(' .''"`',FORMAT(I1:I1)).NE.0)THEN 72 - ILAST=I1-1 73 - INEXT=I1 74 - GOTO 50 75 - ENDIF 76 - 40 CONTINUE 77 - ILAST=NCFMT 78 - INEXT=NCFMT+1 79 - 50 CONTINUE 80 - * Check validity of the name. 81 - IOK=1 82 - * Check the name starts with a character. 83 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ', 84 - - FORMAT(I0:I0)).EQ.0)THEN 85 - PRINT *,' !!!!!! INPTMP WARNING : The variable name '// 86 - - '"',FORMAT(I0:ILAST),'" does not start with'// 87 - - ' an uppercase letter.' 88 - IFAIL=1 89 - IOK=0 90 - ENDIF 91 - * Check for illegal characters. 92 - DO 60 I=I0,ILAST 93 - IF(INDEX('+-*/&|<=#>^ ,.:;([{)]}''"`',FORMAT(I:I)).NE.0)THEN 94 - PRINT *,' !!!!!! INPTMP WARNING : The variable name '// 95 - - '"',FORMAT(I0:ILAST),'" contains the illegal'// 96 - - ' character "',FORMAT(I:I),'".' 97 - IFAIL=1 98 - IOK=0 99 - ENDIF 100 - 60 CONTINUE 101 - * Make sure the name is not empty. 102 - IF(FORMAT(I0:ILAST).EQ.' '.OR.ILAST.LT.I0)THEN 103 - PRINT *,' !!!!!! INPTMP WARNING : A variable name'// 104 - - ' is empty.' 105 - IFAIL=1 106 - IOK=0 107 - ENDIF 108 - * Warn if the name is longer than 10 characters. 109 - IF(ILAST-I0+1.GT.10)PRINT *,' !!!!!! INPTMP WARNING :'// 110 - - ' The variable name "',FORMAT(I0:ILAST),'" is'// 111 - - ' truncated to the first 10 characters.' 112 - * Store the string. 113 - IF(IOK.EQ.1)THEN 114 - NELEM=NELEM+1 115 - IF(NELEM.GE.MXELEM)GOTO 3010 116 - LIST(NELEM,1)=1 117 - LIST(NELEM,2)=I0 118 - LIST(NELEM,3)=ILAST 119 - ELSE 120 - PRINT *,' !!!!!! INPTMP WARNING : Variable "', 121 - - FORMAT(I0:ILAST),'" won''t be assigned a value.' 122 - NELEM=NELEM+1 123 - IF(NELEM.GE.MXELEM)GOTO 3010 124 - LIST(NELEM,1)=3 125 - LIST(NELEM,2)=I0 126 - LIST(NELEM,3)=ILAST 127 - ENDIF 1 71 P=INPUT D=INPTMP 3 PAGE 73 128 - ENDIF 129 - ** Next character. 130 - 10 CONTINUE 131 - *** End of loop over the format. 132 - 100 CONTINUE 133 - *** Add an end-of-list marker just past the end of the list. 134 - LIST(MIN(NELEM+1,MXELEM),1)=4 135 - LIST(MIN(NELEM+1,MXELEM),2)=1 136 - LIST(MIN(NELEM+1,MXELEM),3)=NCFMT 137 - *** Print the structure of the string. 138 - IF(LDEBUG)THEN 139 - WRITE(LUNOUT,'('' ++++++ INPTMP DEBUG : Structure of'', 140 - - '' the format |'',A,''|: '')') FORMAT(1:NCFMT) 141 - DO 170 I=1,NELEM 142 - IF(LIST(I,1).EQ.1)THEN 143 - WRITE(LUNOUT,'(9X,''Variable: |'',A,''|'')') 144 - - FORMAT(LIST(I,2):LIST(I,3)) 145 - ELSEIF(LIST(I,1).EQ.2)THEN 146 - WRITE(LUNOUT,'(9X,''String: |'',A,''|'')') 147 - - FORMAT(LIST(I,2):LIST(I,3)) 148 - ELSEIF(LIST(I,1).EQ.3)THEN 149 - WRITE(LUNOUT,'(9X,''Ignore: |'',A,''|'')') 150 - - FORMAT(LIST(I,2):LIST(I,3)) 151 - ELSE 152 - WRITE(LUNOUT,'(9X,''# Unknown: |'',A,''| #'')') 153 - - FORMAT(LIST(I,2):LIST(I,3)) 154 - IFAIL=1 155 - ENDIF 156 - 170 CONTINUE 157 - ENDIF 158 - *** Find the start of the input string. 159 - DO 210 J=1,NCSTR 160 - IF(STRING(J:J).NE.' ')THEN 161 - JNEXT=J 162 - GOTO 220 163 - ENDIF 164 - 210 CONTINUE 165 - JNEXT=NCSTR+1 166 - 220 CONTINUE 167 - *** Loop over the elements to be assigned. 168 - DO 110 I=1,NELEM 169 - ** Make sure we're not yet past the end of the string. 170 - IF(JNEXT.GT.NCSTR)THEN 171 - DO 160 J=I,NELEM 172 - IF(LIST(J,1).EQ.1)THEN 173 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPTMP DEBUG :'', 174 - - '' Variable '',A,'' not assigned.'')') 175 - - FORMAT(LIST(J,2):LIST(J,3)) 176 - * Locate the global variable and clear it if it is in use. 177 - DO 230 K=1,NGLB 178 - IF(GLBVAR(K).EQ.FORMAT(LIST(J,2):LIST(J,3)))THEN 179 - IGLB=K 180 - CALL ALGREU(NINT(GLBVAL(IGLB)),GLBMOD(IGLB),0) 181 - GOTO 240 182 - ENDIF 183 - 230 CONTINUE 184 - IF(NGLB.GE.MXVAR)THEN 185 - PRINT *,' !!!!!! INPTMP WARNING : No room for'// 186 - - ' a new global variable; definition of', 187 - - FORMAT(LIST(J,2):LIST(J,3)),' ignored.' 188 - IFAIL=1 189 - GOTO 160 190 - ENDIF 191 - NGLB=NGLB+1 192 - IGLB=NGLB 193 - GLBVAR(NGLB)=FORMAT(LIST(J,2):LIST(J,3)) 194 - GLBMOD(NGLB)=0 195 - * Ensure that this variable is not a system variable. 196 - 240 CONTINUE 197 - IF(IGLB.LE.7)THEN 198 - PRINT *,' !!!!!! INPTMP WARNING : Variable ', 199 - - FORMAT(LIST(J,2):LIST(J,3)),' may not be'// 200 - - ' modified by the user.' 201 - IFAIL=1 202 - GOTO 160 203 - ENDIF 204 - * Assign to the global variable. 205 - GLBVAL(IGLB)=0 206 - GLBMOD(IGLB)=0 207 - ENDIF 208 - 160 CONTINUE 209 - GOTO 200 210 - ENDIF 211 - ** Element is a variable name or a dot. 212 - IF(LIST(I,1).EQ.1.OR.LIST(I,1).EQ.3)THEN 213 - * Case 1: the variable is followed by a string. 214 - IF(LIST(I+1,1).EQ.2)THEN 215 - * Locate the string. 216 - JEND=INDEX(STRING(JNEXT:NCSTR), 217 - - FORMAT(LIST(I+1,2):LIST(I+1,3))) 218 - IF(JEND.EQ.0)THEN 219 - JEND=NCSTR 220 - ELSE 221 - JEND=JEND+JNEXT-2 222 - ENDIF 223 - * Case 2: the variable is followed by another variable or a dot. 224 - ELSEIF(LIST(I+1,1).EQ.1.OR.LIST(I+1,1).EQ.3)THEN 225 - * Locate the blank separating the two variables. 226 - JEND=INDEX(STRING(JNEXT:NCSTR),' ') 227 - IF(JEND.EQ.0)THEN 228 - JEND=NCSTR 229 - ELSE 230 - JEND=JEND+JNEXT-2 231 - ENDIF 232 - * Case 3: the variable is not followed by anything. 233 - ELSEIF(LIST(I+1,1).EQ.4)THEN 1 71 P=INPUT D=INPTMP 4 PAGE 74 234 - * Take all that remains. 235 - JEND=NCSTR 236 - * Other cases: should not occur. 237 - ELSE 238 - PRINT *,' !!!!!! INPTMP WARNING : Unrecognised'// 239 - - ' format code received.' 240 - JEND=NCSTR 241 - IFAIL=1 242 - ENDIF 243 - * Evaluate the expression. 244 - IF((LIST(I+1,1).GE.1.AND.LIST(I+1,1).LE.4).AND. 245 - - LIST(I,1).EQ.1)THEN 246 - * Start with debugging output. 247 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPTMP DEBUG :'', 248 - - '' Evaluating '',A,'' for assignment to '',A, 249 - - ''.'')') STRING(JNEXT:JEND), 250 - - FORMAT(LIST(I,2):LIST(I,3)) 251 - ** In execution mode, evaluate the input expression. 252 - IF(EXEC)THEN 253 - * Translation step. 254 - CALL ALGPRE(STRING(JNEXT:JEND),JEND-JNEXT+1, 255 - - GLBVAR,NGLB,NRES,USE,IENTRY,IFAIL1) 256 - * Make sure that the formula was OK. 257 - IF(IFAIL1.NE.0)THEN 258 - PRINT *,' !!!!!! INPTMP WARNING :'// 259 - - ' Translating ',STRING(JNEXT:JEND), 260 - - ' failed; ',FORMAT(LIST(I,2):LIST(I,3)), 261 - - ' not assigned.' 262 - IFAIL=1 263 - CALL ALGCLR(IENTRY) 264 - GOTO 300 265 - * Verify that we get indeed only one result. 266 - ELSEIF(NRES.NE.1)THEN 267 - PRINT *,' !!!!!! INPTMP WARNING :'// 268 - - ' Translating ',STRING(JNEXT:JEND), 269 - - ' does not yield 1 result;', 270 - - FORMAT(LIST(I,2):LIST(I,3)), 271 - - ' not assigned.' 272 - CALL ALGCLR(IENTRY) 273 - IFAIL=1 274 - GOTO 300 275 - ENDIF 276 - * Set the execution time. 277 - CALL TIMEL(GLBVAL(1)) 278 - * Evaluate the formula. 279 - CALL ALGEXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES, 280 - - MODRES,1,IFAIL1) 281 - * Check the return code of the evaluation. 282 - IF(IFAIL1.NE.0)THEN 283 - PRINT *,' !!!!!! INPTMP WARNING :'// 284 - - ' Evaluation of'// 285 - - ' expression ',STRING(JNEXT:JEND), 286 - - ' failed; ',FORMAT(LIST(I,2):LIST(I,3)), 287 - - ' not assigned.' 288 - CALL ALGCLR(IENTRY) 289 - IFAIL=1 290 - GOTO 300 291 - ENDIF 292 - * Print any evaluation errors. 293 - CALL ALGERR 294 - * Remove the entry point of the formula. 295 - CALL ALGCLR(IENTRY) 296 - ** In non-execution mode, store the result according to type. 297 - ELSE 298 - * Determine the type. 299 - CALL ALGTYP(STRING(JNEXT:JEND),IMODE) 300 - * Take care of Undefined. 301 - IF(IMODE.EQ.0)THEN 302 - RES(1)=0.0 303 - * Take care of strings. 304 - ELSEIF(IMODE.EQ.1)THEN 305 - CALL STRBUF('STORE',IREF,STRING(JNEXT:JEND), 306 - - JEND-JNEXT+1,IFAIL1) 307 - RES(1)=REAL(IREF) 308 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! INPTMP'// 309 - - ' WARNING : Unable to store the', 310 - - ' String ',STRING(JNEXT:JEND),'.' 311 - * Take care of numbers. 312 - ELSEIF(IMODE.EQ.2)THEN 313 - CALL INPRRC(STRING(JNEXT:JEND),RES(1),0.0, 314 - - IFAIL1) 315 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! INPTMP'// 316 - - ' WARNING : ',STRING(JNEXT:JEND), 317 - - ' is not a valid Number.' 318 - * Take care of logicals. 319 - ELSEIF(IMODE.EQ.3)THEN 320 - AUXSTR=STRING(JNEXT:JEND) 321 - CALL CLTOU(AUXSTR) 322 - IF(AUXSTR.EQ.'TRUE ')THEN 323 - RES(1)=1.0 324 - ELSEIF(AUXSTR.EQ.'FALSE')THEN 325 - RES(1)=0.0 326 - ELSE 327 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! INPTMP'// 328 - - ' WARNING : ',STRING(JNEXT:JEND), 329 - - ' is not a valid Logical.' 330 - RES(1)=-6 331 - IMODE=0 332 - ENDIF 333 - * All the rest, we assign as Undefined. 334 - ELSE 335 - RES(1)=-6 336 - IMODE=0 337 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! INPTMP'// 338 - - ' WARNING : ',STRING(JNEXT:JEND), 339 - - ' is not of a type valid with Parse.' 1 71 P=INPUT D=INPTMP 5 PAGE 75 340 - ENDIF 341 - MODRES(1)=IMODE 342 - ENDIF 343 - ** Locate the global variable and clear it if it is in use. 344 - DO 180 K=1,NGLB 345 - IF(GLBVAR(K).EQ.FORMAT(LIST(I,2):LIST(I,3)))THEN 346 - IGLB=K 347 - CALL ALGREU(NINT(GLBVAL(IGLB)),GLBMOD(IGLB),0) 348 - GOTO 190 349 - ENDIF 350 - 180 CONTINUE 351 - IF(NGLB.GE.MXVAR)THEN 352 - PRINT *,' !!!!!! INPTMP WARNING : No room for'// 353 - - ' a new global variable; definition of', 354 - - FORMAT(LIST(I,2):LIST(I,3)),' ignored.' 355 - IFAIL=1 356 - GOTO 300 357 - ENDIF 358 - NGLB=NGLB+1 359 - IGLB=NGLB 360 - GLBVAR(NGLB)=FORMAT(LIST(I,2):LIST(I,3)) 361 - GLBMOD(NGLB)=0 362 - * Ensure that this variable is not a system variable. 363 - 190 CONTINUE 364 - IF(IGLB.LE.7)THEN 365 - PRINT *,' !!!!!! INPTMP WARNING : Variable ', 366 - - FORMAT(LIST(I,2):LIST(I,3)),' may not be'// 367 - - ' modified by the user.' 368 - IFAIL=1 369 - GOTO 300 370 - ENDIF 371 - * Assign to the global variable. 372 - GLBVAL(IGLB)=RES(1) 373 - GLBMOD(IGLB)=MODRES(1) 374 - ELSE 375 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPTMP DEBUG :'', 376 - - '' Ignoring '',A,''.'')') STRING(JNEXT:JEND) 377 - ENDIF 378 - * Update the pointer. 379 - 300 CONTINUE 380 - DO 140 J=JEND+1,NCSTR 381 - IF(STRING(J:J).NE.' ')THEN 382 - JNEXT=J 383 - GOTO 150 384 - ENDIF 385 - 140 CONTINUE 386 - JNEXT=NCSTR+1 387 - 150 CONTINUE 388 - ** Element is a string. 389 - ELSEIF(LIST(I,1).EQ.2)THEN 390 - * Locate the string. 391 - JSTART=INDEX(STRING(JNEXT:NCSTR), 392 - - FORMAT(LIST(I,2):LIST(I,3))) 393 - IF(JSTART.EQ.0)THEN 394 - JSTART=NCSTR 395 - ELSE 396 - JSTART=JSTART+JNEXT-2 397 - ENDIF 398 - * Update pointer. 399 - DO 120 J=JSTART+LIST(I,3)-LIST(I,2)+2,NCSTR 400 - IF(STRING(J:J).NE.' ')THEN 401 - JNEXT=J 402 - GOTO 130 403 - ENDIF 404 - 120 CONTINUE 405 - JNEXT=NCSTR+1 406 - 130 CONTINUE 407 - ** Anything else is not valid. 408 - ELSE 409 - PRINT *,' !!!!!! INPTMP WARNING : Invalid format code'// 410 - - ' received.' 411 - IFAIL=1 412 - ENDIF 413 - 110 CONTINUE 414 - *** End of the loop over the format elements. 415 - 200 CONTINUE 416 - *** Normally the end of the routine. 417 - RETURN 418 - *** Handle table overflow. 419 - 3010 CONTINUE 420 - * Print error message. 421 - PRINT *,' !!!!!! INPTMP WARNING : Too many elements in the'// 422 - - ' format; excess ignored.' 423 - * Remember that something went wrong. 424 - IFAIL=1 425 - * Reduce element counter by 1. 426 - NELEM=MXELEM-1 427 - * Place an end-of-list marker in element MXELEM 428 - LIST(MXELEM,1)=4 429 - LIST(MXELEM,2)=1 430 - LIST(MXELEM,3)=NCFMT 431 - * With this truncated list, identify the words. 432 - GOTO 100 433 - END 72 GARFIELD ================================================== P=INPUT D=INPTRA 1 ============================ 0 + +DECK,INPTRA. 1 - SUBROUTINE INPTRA(STR,NC) 2 - *----------------------------------------------------------------------- 3 - * INPTRA - Translation of an input string. 4 - * INPTRG - Reads a translation table from a dataset. 5 - * INPTRR - Reads new translation entries. 6 - * INPTRW - Writes a table to a dataset. 7 - * (Last changed on 3/10/98.) 8 - *----------------------------------------------------------------------- 1 72 P=INPUT D=INPTRA 2 PAGE 76 9 - implicit none 10.- +SEQ,DIMENSIONS. 11.- +SEQ,INPUT. 12.- +SEQ,PRINTPLOT. 13 - INTEGER TABLE(0:255),CHRIN,CHROUT,INPCMP,NCYCLE,ICYC,NCYCR, 14 - - NCFILE,NCMEMB,NCREM,IFAIL,IFAIL1,IKEY,IOS,INEXT,INIT,NMOD, 15 - - NCAUX,NC,I,J 16 - CHARACTER*(*) STR 17 - CHARACTER*(MXNAME) FILE 18 - CHARACTER*80 HEADER,AUX 19 - CHARACTER*29 REMARK 20 - CHARACTER*8 DATE,TIME,MEMBER 21 - CHARACTER*3 IN,OUT 22 - LOGICAL DSNCMP,EXIS,EXMEMB 23 - EXTERNAL INPCMP,DSNCMP 0 24-+ +SELF,IF=SAVE. 25 - SAVE INIT,TABLE,NCYCLE 0 26-+ +SELF. 27 - DATA NCYCLE /1/ 28 - *** Carry out a translation. 29 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPTRA DEBUG : In ="'',A, 30 - - ''"'')') STR(1:MIN(NC,100)) 31 - DO 80 ICYC=1,NCYCLE 32 - DO 50 I=1,NC 33 - IF(I.GT.1.AND.STR(MAX(1,I-1):MAX(1,I-1)).EQ.ESCAPE)GOTO 50 34 - STR(I:I)=CHAR(TABLE(ICHAR(STR(I:I)))) 35 - 50 CONTINUE 36 - 80 CONTINUE 37 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Out="'',A,''"'')') 38 - - STR(1:MIN(NC,100)) 39 - RETURN 40 - *** Read the translation table to a file. 41 - ENTRY INPTRG(IFAIL) 42 - * Initial values. 43 - FILE=' ' 44 - NCFILE=8 45 - MEMBER='*' 46 - NCMEMB=1 47 - IFAIL=1 48 - IKEY=1 49 - ** First decode the argument string: only one argument: file name. 50 - IF(NWORD.GE.IKEY+1) 51 - - CALL INPSTR(IKEY+1,IKEY+1,FILE,NCFILE) 52 - * If there's a second argument, it is the member name. 53 - IF(NWORD.GE.IKEY+2) 54 - - CALL INPSTR(IKEY+2,IKEY+2,MEMBER,NCMEMB) 55 - * Check the various lengths. 56 - IF(NCFILE.GT.MXNAME)THEN 57 - PRINT *,' !!!!!! INPTRG WARNING : The file name is'// 58 - - ' truncated to MXNAME (=',MXNAME,') characters.' 59 - NCFILE=MIN(NCFILE,MXNAME) 60 - ENDIF 61 - IF(NCMEMB.GT.8)THEN 62 - PRINT *,' !!!!!! INPTRG WARNING : The member name is'// 63 - - ' shortened to '//MEMBER//', first 8 characters.' 64 - NCMEMB=MIN(NCMEMB,8) 65 - ELSEIF(NCMEMB.LE.0)THEN 66 - PRINT *,' !!!!!! INPTRG WARNING : The member'// 67 - - ' name has zero length, replaced by "*".' 68 - MEMBER='*' 69 - NCMEMB=1 70 - ENDIF 71 - * Reject the empty file name case. 72 - IF(FILE.EQ.' '.OR.NWORD.EQ.1)THEN 73 - PRINT *,' !!!!!! INPTRG WARNING : GET must be at least'// 74 - - ' followed by a dataset name ; no table is read.' 75 - RETURN 76 - ENDIF 77 - * If there are even more args, warn they are ignored. 78 - IF(NWORD.GT.IKEY+2)PRINT *,' !!!!!! INPTRG WARNING : GET takes'// 79 - - ' at most two arguments (dataset and member); rest ignored.' 80 - ** Open the dataset and inform DSNLOG. 81 - CALL DSNOPN(FILE,NCFILE,12,'READ-LIBRARY',IFAIL1) 82 - IF(IFAIL1.NE.0)THEN 83 - PRINT *,' !!!!!! INPTRG WARNING : Opening ',FILE(1:NCFILE), 84 - - ' failed ; translation table not read.' 85 - RETURN 86 - ENDIF 87 - CALL DSNLOG(FILE,'Translate ','Sequential','Read only ') 88 - IF(LDEBUG)PRINT *,' ++++++ INPTRG DEBUG : Dataset', 89 - - FILE(1:NCFILE),' opened on unit 12 for seq read.' 90 - * Locate the pointer on the header of the requested member. 91 - CALL DSNLOC(MEMBER,NCMEMB,'TRANSLAT',12,EXIS,'RESPECT') 92 - IF(.NOT.EXIS)THEN 93 - CALL DSNLOC(MEMBER,NCMEMB,'TRANSLAT',12,EXIS,'IGNORE') 94 - IF(EXIS)THEN 95 - PRINT *,' ###### INPTRG ERROR : The translation'// 96 - - ' table '//MEMBER(1:NCMEMB)//' has been deleted'// 97 - - ' from '//FILE(1:NCFILE),'; not read.' 98 - ELSE 99 - PRINT *,' ###### INPTRG ERROR : Translation table'// 100 - - MEMBER(1:NCMEMB)//' not found on '// 101 - - FILE(1:NCFILE)//'.' 102 - ENDIF 103 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 104 - RETURN 105 - ENDIF 106 - ** Check that the member is acceptable date wise. 107 - READ(12,'(A80)',END=2000,IOSTAT=IOS,ERR=2010) HEADER 108 - IF(LDEBUG)THEN 109 - PRINT *,' ++++++ INPTRG DEBUG : Dataset header'// 110 - - ' record follows:' 111 - PRINT *,HEADER 112 - ENDIF 1 72 P=INPUT D=INPTRA 3 PAGE 77 113 - IF(DSNCMP('06-06-90',HEADER(11:18)))THEN 114 - PRINT *,' !!!!!! INPTRG WARNING : Member '//HEADER(32:39)// 115 - - ' can not be read because of a change in format.' 116 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 117 - RETURN 118 - ENDIF 119 - WRITE(LUNOUT,'('' Member '',A8,'' was created on '',A8, 120 - - '' at '',A8/'' Remarks: '',A29)') 121 - - HEADER(32:39),HEADER(11:18),HEADER(23:30),HEADER(51:79) 122 - * Read the actual data. 123 - READ(12,'(8X,BN,I3)',END=2000,ERR=2010,IOSTAT=IOS) NCYCLE 124 - DO 60 I=1,8 125 - READ(12,'(1X,32I4)',END=2000,ERR=2010,IOSTAT=IOS) 126 - - (TABLE(32*I+J-32),J=0,31) 127 - 60 CONTINUE 128 - ** Close the file after the operation. 129 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 130 - CALL TIMLOG('Reading an input translation table: ') 131 - IFAIL=0 132 - RETURN 133 - *** Initial table. 134 - ENTRY INPTRI 135 - DATA INIT/0/ 136 - IF(INIT.EQ.0)THEN 137 - * Original table is 1 to 1 on most machines. 138 - DO 10 I=0,255 139 - TABLE(I)=I 140 - 10 CONTINUE 0 141-+ +SELF,IF=UNIX,VAX. 142 - * On Vax, tabs should become blanks. 143 - TABLE(9)=32 144 - TABLE(13)=32 0 145-+ +SELF. 146 - * Number of cycles. 147 - NCYCLE=1 148 - * Remember we set the table. 149 - INIT=1 150 - ENDIF 151 - RETURN 152 - *** Change table entries. 153 - ENTRY INPTRR 154 - CALL INPNUM(NWORD) 155 - * Display current settings if arguments are absent. 156 - IF(NWORD.EQ.1)THEN 157 - WRITE(LUNOUT,'('' INPUT TRANSLATION TABLE:''/)') 158 - NMOD=0 159 - DO 40 I=0,255 160 - IF(TABLE(I).NE.I)THEN 161 - IN=' '//CHAR(I)//' ' 162 - OUT=' '//CHAR(TABLE(I))//' ' 163 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ'// 164 - - 'abcdefghijklmnopqrstuvwxyz'// 165 - - '0123456789~!@#$%^&*()_-+={[}]:;"''|\\,.?/><', 166 - - CHAR(I)).EQ.0)IN='---' 167 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ'// 168 - - 'abcdefghijklmnopqrstuvwxyz'// 169 - - '0123456789~!@#$%^&*()_-+={[}]:;"''|\\,.?/><', 170 - - CHAR(TABLE(I))).EQ.0)OUT='---' 171 - WRITE(LUNOUT,'(2X,I3,'' ('',A3,'') --> '',I3,'' ('',A3, 172 - - '')'')') I,IN,TABLE(I),OUT 173 - NMOD=NMOD+1 174 - ENDIF 175 - 40 CONTINUE 176 - IF(NMOD.EQ.0) 177 - - WRITE(LUNOUT,'('' All characters unchanged.'')') 178 - WRITE(LUNOUT,'(/'' Number of cycles: '',I3,''.''/)') NCYCLE 179 - RETURN 180 - ENDIF 181 - * Loop over the input words. 182 - INEXT=1 183 - DO 20 I=2,NWORD 184 - IF(I.LT.INEXT)GOTO 20 185 - * Number of cycles. 186 - IF(INPCMP(I,'CYC#LES').NE.0)THEN 187 - IF(I+1.GT.NWORD)THEN 188 - CALL INPMSG(I,'Number of cycles is missing. ') 189 - GOTO 30 190 - ENDIF 191 - CALL INPCHK(I+1,1,IFAIL1) 192 - CALL INPRDI(I+1,NCYCR,NCYCLE) 193 - IF(IFAIL1.EQ.0.AND.(NCYCR.LT.0.OR.NCYCR.GT.256))THEN 194 - CALL INPMSG(I+1,'Invalid number of cycles. ') 195 - ELSE 196 - NCYCLE=NCYCR 197 - ENDIF 198 - INEXT=I+2 199 - GOTO 20 200 - ENDIF 201 - * Pick up the character to be translated. 202 - CHRIN=-1 203 - IF(INPCMP(I,'INT#EGER').NE.0)THEN 204 - IF(I+1.GT.NWORD)THEN 205 - CALL INPMSG(I,'Character code is missing. ') 206 - GOTO 30 207 - ENDIF 208 - CALL INPCHK(I+1,1,IFAIL1) 209 - CALL INPRDI(I+1,CHRIN,-1) 210 - IF(IFAIL1.EQ.0.AND.(CHRIN.LT.0.OR.CHRIN.GT.255))THEN 211 - CALL INPMSG(I+1,'Character not within range. ') 212 - CHRIN=-1 213 - ENDIF 214 - INEXT=I+2 215 - ELSEIF(INPCMP(I,'HEX#ADECIMAL').NE.0)THEN 216 - IF(I+1.GT.NWORD)THEN 1 72 P=INPUT D=INPTRA 4 PAGE 78 217 - CALL INPMSG(I,'Character code is missing. ') 218 - GOTO 30 219 - ENDIF 220 - CALL INPCHK(I+1,3,IFAIL1) 221 - CALL INPRDH(I+1,CHRIN,-1) 222 - IF(IFAIL1.EQ.0.AND.(CHRIN.LT.0.OR.CHRIN.GT.255))THEN 223 - CALL INPMSG(I+1,'Character not within range. ') 224 - CHRIN=-1 225 - ENDIF 226 - INEXT=I+2 227 - ELSE 228 - CALL INPSTR(I,I,AUX,NCAUX) 229 - IF(NCAUX.GT.1)THEN 230 - CALL INPMSG(I,'Specify only one character. ') 231 - CHRIN=-1 232 - ELSE 233 - CHRIN=ICHAR(AUX(1:1)) 234 - ENDIF 235 - INEXT=I+1 236 - ENDIF 237 - * Ensure there is an output specification. 238 - IF(INEXT.GT.NWORD)THEN 239 - CALL INPMSG(I,'Output character is missing. ') 240 - GOTO 30 241 - ENDIF 242 - * Pick up the output character. 243 - CHROUT=-1 244 - IF(INPCMP(INEXT,'INT#EGER').NE.0)THEN 245 - IF(INEXT+1.GT.NWORD)THEN 246 - CALL INPMSG(INEXT,'Character code is missing. ') 247 - GOTO 30 248 - ENDIF 249 - CALL INPCHK(INEXT+1,1,IFAIL1) 250 - CALL INPRDI(INEXT+1,CHROUT,-1) 251 - IF(IFAIL1.EQ.0.AND.(CHROUT.LT.0.OR.CHROUT.GT.255))THEN 252 - CALL INPMSG(INEXT+1,'Character not within range. ') 253 - CHROUT=-1 254 - ENDIF 255 - INEXT=INEXT+2 256 - ELSEIF(INPCMP(INEXT,'HEX#ADECIMAL').NE.0)THEN 257 - IF(INEXT+1.GT.NWORD)THEN 258 - CALL INPMSG(INEXT,'Character code is missing. ') 259 - GOTO 30 260 - ENDIF 261 - CALL INPCHK(INEXT+1,3,IFAIL1) 262 - CALL INPRDH(INEXT+1,CHROUT,-1) 263 - IF(IFAIL1.EQ.0.AND.(CHROUT.LT.0.OR.CHROUT.GT.255))THEN 264 - CALL INPMSG(INEXT+1,'Character not within range. ') 265 - CHROUT=-1 266 - ENDIF 267 - INEXT=INEXT+2 268 - ELSE 269 - CALL INPSTR(INEXT,INEXT,AUX,NCAUX) 270 - IF(NCAUX.GT.1)THEN 271 - CALL INPMSG(INEXT,'Specify only one character. ') 272 - CHROUT=-1 273 - ELSE 274 - CHROUT=ICHAR(AUX(1:1)) 275 - ENDIF 276 - INEXT=INEXT+1 277 - ENDIF 278 - * Update the translation table. 279 - IF(CHRIN.GE.0.AND.CHROUT.GE.0.AND. 280 - - CHRIN.LE.255.AND.CHROUT.LE.255)TABLE(CHRIN)=CHROUT 281 - 20 CONTINUE 282 - 30 CONTINUE 283 - * Dump error messages. 284 - CALL INPERR 285 - RETURN 286 - *** Write the translation table to a file. 287 - ENTRY INPTRW(IFAIL) 288 - * Initial settings. 289 - FILE=' ' 290 - NCFILE=1 291 - MEMBER='< none >' 292 - NCMEMB=8 293 - REMARK='none' 294 - NCREM=4 295 - IFAIL=1 296 - IKEY=1 297 - * First decode the argument string. 298 - CALL INPNUM(NWORD) 299 - * Make sure there is at least one argument. 300 - IF(NWORD.EQ.IKEY)THEN 301 - PRINT *,' !!!!!! INPTRW WARNING : WRITE takes at least one', 302 - - ' argument (a dataset name); data will not be written.' 303 - RETURN 304 - * Check whether keywords have been used. 305 - ELSEIF(INPCMP(IKEY+1,'D#ATASET')+ 306 - - INPCMP(IKEY+1,'R#EMARK').NE.0)THEN 307 - INEXT=IKEY+1 308 - DO 410 I=IKEY+1,NWORD 309 - IF(I.LT.INEXT)GOTO 410 310 - IF(INPCMP(I,'DATA#SET').NE.0)THEN 311 - IF(INPCMP(I+1,'REM#ARK').NE.0.OR.I+1.GT.NWORD)THEN 312 - CALL INPMSG(I,'The dataset name is missing. ') 313 - INEXT=I+1 314 - ELSE 315 - CALL INPSTR(I+1,I+1,FILE,NCFILE) 316 - INEXT=I+2 317 - IF(INPCMP(I+2,'R#EMARK').EQ.0.AND. 318 - - I+2.LE.NWORD)THEN 319 - CALL INPSTR(I+2,I+2,MEMBER,NCMEMB) 320 - INEXT=I+3 321 - ENDIF 322 - ENDIF 1 72 P=INPUT D=INPTRA 5 PAGE 79 323 - ELSEIF(INPCMP(I,'REM#ARK').NE.0)THEN 324 - IF(INPCMP(I+1,'D#ATASET').NE.0.OR.I+1.GT.NWORD)THEN 325 - CALL INPMSG(I,'The remark is missing. ') 326 - INEXT=I+1 327 - ELSE 328 - CALL INPSTR(I+1,I+1,REMARK,NCREM) 329 - INEXT=I+2 330 - ENDIF 331 - ELSE 332 - CALL INPMSG(I,'The parameter is not known. ') 333 - ENDIF 334 - 410 CONTINUE 335 - * Otherwise the string is interpreted as a file name (+ member name). 336 - ELSE 337 - CALL INPSTR(IKEY+1,IKEY+1,FILE,NCFILE) 338 - IF(NWORD.GE.IKEY+2) 339 - - CALL INPSTR(IKEY+2,IKEY+2,MEMBER,NCMEMB) 340 - IF(NWORD.GE.IKEY+3) 341 - - CALL INPSTR(IKEY+3,NWORD,REMARK,NCREM) 342 - ENDIF 343 - * Print error messages. 344 - CALL INPERR 345 - IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! INPTRW WARNING : The file', 346 - - ' name is truncated to MXNAME (=',MXNAME,') characters.' 347 - IF(NCMEMB.GT.8)PRINT *,' !!!!!! INPTRW WARNING : The member', 348 - - ' name is shortened to ',MEMBER,', first 8 characters.' 349 - IF(NCREM.GT.29)PRINT *,' !!!!!! INPTRW WARNING : The remark', 350 - - ' shortened to ',REMARK,', first 29 characters.' 351 - NCFILE=MIN(NCFILE,MXNAME) 352 - NCMEMB=MIN(NCMEMB,8) 353 - NCREM=MIN(NCREM,29) 354 - * Check whether the member already exists. 355 - CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'TRANSLAT',EXMEMB) 356 - IF(JEXMEM.EQ.2.AND.EXMEMB)THEN 357 - PRINT *,' ------ INPTRW MESSAGE : A copy of the member'// 358 - - ' exists; new member will be appended.' 359 - ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN 360 - PRINT *,' !!!!!! INPTRW WARNING : A copy of the member'// 361 - - ' exists already; member will not be written.' 362 - RETURN 363 - ENDIF 364 - * Print some debugging output if requested. 365 - IF(LDEBUG)THEN 366 - PRINT *,' ++++++ INPTRW DEBUG : File= '//FILE(1:NCFILE)// 367 - - ', member= '//MEMBER(1:NCMEMB) 368 - PRINT *,' Remark= '//REMARK(1:NCREM) 369 - ENDIF 370 - ** Open the dataset for sequential write and inform DSNLOG. 371 - CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) 372 - IF(IFAIL.NE.0)THEN 373 - PRINT *,' !!!!!! INPTRW WARNING : Opening '//FILE(1:NCFILE), 374 - - ' failed ; the translation table is not written.' 375 - RETURN 376 - ENDIF 377 - CALL DSNLOG(FILE,'Translate ','Sequential','Write ') 378 - IF(LDEBUG)PRINT *,' ++++++ INPTRW DEBUG : Dataset ', 379 - - FILE(1:NCFILE),' opened on unit 12 for seq write.' 380 - * Now write a heading record to the file. 381 - CALL DATTIM(DATE,TIME) 382 - WRITE(HEADER,'(''% Created '',A8,'' At '',A8,1X,A8,'' TRANSLAT'', 383 - - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK 384 - WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) HEADER 385 - IF(LDEBUG)THEN 386 - PRINT *,' ++++++ INPTRW DEBUG : Dataset heading record:' 387 - PRINT *,HEADER 388 - ENDIF 389 - * Write the translation table. 390 - WRITE(12,'(''Cycles: '',I3)',ERR=2010,IOSTAT=IOS) NCYCLE 391 - DO 70 I=1,8 392 - WRITE(12,'(1X,32I4)',ERR=2010,IOSTAT=IOS) 393 - - (TABLE(32*I+J-32),J=0,31) 394 - 70 CONTINUE 395 - * Close the file after the operation. 396 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 397 - CALL TIMLOG('Writing out a translation table: ') 398 - IFAIL=0 399 - RETURN 400 - *** I/O error handling. 401 - 2000 CONTINUE 402 - PRINT *,' ###### INPTRG ERROR : Premature EOF ecountered on '// 403 - - FILE(1:NCFILE)//' read via unit 12 ; no valid data read.' 404 - CALL INPIOS(IOS) 405 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 406 - RETURN 407 - 2010 CONTINUE 408 - PRINT *,' ###### INPTRA ERROR : I/O error accessing '// 409 - - FILE(1:NCFILE)//' via unit 12 ; no data read or written.' 410 - CALL INPIOS(IOS) 411 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 412 - RETURN 413 - 2030 CONTINUE 414 - PRINT *,' ###### INPTRA ERROR : Dataset '//FILE(1:NCFILE)// 415 - - ' unit 12 cannot be closed ; results not predictable' 416 - CALL INPIOS(IOS) 417 - END 73 GARFIELD ================================================== P=INPUT D=INPTYP 1 ============================ 0 + +DECK,INPTYP. 1 - INTEGER FUNCTION INPTYP(IW) 2 - *----------------------------------------------------------------------- 3 - * INPTYP - Determines the type of word IW, 0=character string, 4 - * 1=integer, 2=real, 3=hex, 4=asterisk, -1=invalid argument. 5 - * (Last changed on 24/ 2/91.) 6 - *----------------------------------------------------------------------- 7 - implicit none 1 73 P=INPUT D=INPTYP 2 PAGE 80 8.- +SEQ,DIMENSIONS. 9.- +SEQ,INPUT. 10 - INTEGER IW,IINTEG,IREAL,IHEX,I 11 - *** First handle the case of incorrect arguments. 12 - IF(IW.LT.1.OR.IW.GT.NWORD)THEN 13 - INPTYP=-1 14 - RETURN 15 - ENDIF 16 - *** Handle case of asterisk. 17 - IF(WORD(IW).EQ.'*')THEN 18 - INPTYP=4 19 - RETURN 20 - ENDIF 21 - *** Initiliase the flag which are 1 for integers, reals and hex. 22 - IINTEG=1 23 - IREAL=1 24 - IHEX=1 25 - *** Loop over the word. 26 - DO 10 I=1,NCHAR(IW) 27 - IF(INDEX('0123456789ABCDEF',WORD(IW)(I:I)).EQ.0)IHEX=0 28 - IF(INDEX('.E',WORD(IW)(I:I)).NE.0)THEN 29 - IINTEG=0 30 - ELSEIF(INDEX('01234567890+- ',WORD(IW)(I:I)).EQ.0)THEN 31 - IINTEG=0 32 - IREAL=0 33 - ENDIF 34 - 10 CONTINUE 35 - *** Determine the type from the value of the flags. 36 - IF(IINTEG.EQ.0.AND.IREAL.EQ.1)THEN 37 - INPTYP=2 38 - ELSEIF(IINTEG.EQ.1)THEN 39 - INPTYP=1 40 - ELSEIF(IHEX.EQ.1)THEN 41 - INPTYP=3 42 - ELSE 43 - INPTYP=0 44 - ENDIF 45 - END 74 GARFIELD ================================================== P=INPUT D=INPWRD 1 ============================ 0 + +DECK,INPWRD. 1 - SUBROUTINE INPWRD(NNWORD) 2 - *----------------------------------------------------------------------- 3 - * INPWRD - Asks INPGET to read a record, checks whether it contains 4 - * any special characters, takes appropriate action if 5 - * required and returns otherwise. 6 - * VARIABLES : NNWORD : =NWORD 7 - * (Last changed on 7/11/00.) 8 - *----------------------------------------------------------------------- 9 - implicit none 10.- +SEQ,DIMENSIONS. 11.- +SEQ,INPUT. 12.- +SEQ,PRINTPLOT. 13.- +SEQ,GLOBALS. 14 - CHARACTER*(MXINCH) FILE,LINE 15 - CHARACTER*(MXNAME) AUX 16 - CHARACTER*29 REMARK 17 - CHARACTER*8 DATE,TIME,MEMBER 18 - CHARACTER ESCAUX 19 - LOGICAL USE(MXVAR) 20 - C LOGICAL EXMEMB 21 - INTEGER NCMEMB,NCREM,NCFILE,NC,IFILE,LUNTRY,IEOF,NCAUX,IFAIL, 22 - - IKEY,I,IOS,IDOLLR,NNWORD,INPCMP,IDUMMY,NCESC,IENTRY,NREXP 23 - EXTERNAL INPCMP 0 24-+ +SELF,IF=UNIX. 25 - integer systemf,ierr 26 - external systemf 0 27-+ +SELF,IF=VAX. 28 - INTEGER LIB$SPAWN,IERR 29 - EXTERNAL LIB$SPAWN 0 30-+ +SELF,IF=CMS. 31 - INTEGER IRC 0 32-+ +SELF,IF=APOLLO. 33 - character*256 args 34 - integer*2 iargs(128),connection(3) 35 - equivalence(args,iargs) 36 - integer pointer(2) 37 - %include '/sys/ins/base.ins.ftn' 38 - %include '/sys/ins/pgm.ins.ftn' 0 39-+ +SELF. 40 - *** Identify the routine if requested. 41 - IF(LIDENT)PRINT *,' /// ROUTINE INPWRD ///' 42 - *** Return here if the command has been recognised as global. 43 - 1000 CONTINUE 44 - *** Next read a line from the input. 45 - CALL INPGET 46 - *** Pick up the first word to see whether there is an escape character. 47 - CALL INPSTR(1,1,LINE,NC) 48 - *** Open a unit if input is to continue from an external file. 49 - IF(NWORD.GE.1.AND.LINE(1:1).EQ.'<'.AND.NC.GE.1)THEN 50 - IF(LDEBUG)PRINT *,' ++++++ INPWRD DEBUG : Statement is'// 51 - - ' an alternate input request.' 52 - * Decode the file name. 53 - IF(NC.EQ.1.AND.NWORD.EQ.1)THEN 54 - PRINT *,' !!!!!! INPWRD WARNING : A file name must'// 55 - - ' be specified on a "<" line; no file opened.' 56 - GOTO 1000 57 - ELSEIF(NC.EQ.1)THEN 58 - IFILE=2 59 - CALL INPSTR(2,2,FILE,NCFILE) 1 74 P=INPUT D=INPWRD 2 PAGE 81 60 - ELSE 61 - IFILE=1 62 - FILE=LINE(2:) 63 - NCFILE=NC-1 64 - ENDIF 65 - * Check whether there is perhaps also an EOF string. 66 - IF(IFILE.LT.NWORD)CALL INPSTR(IFILE+1,IFILE+1,LINE,NC) 67 - IF(LINE(1:2).EQ.'<<'.AND.NWORD.GT.IFILE.AND.NC.GE.2)THEN 68 - IF(NC.GT.2)THEN 69 - EOFSTR=LINE(3:) 70 - NCEOF=NC-2 71 - IEOF=IFILE+1 72 - ELSEIF(NWORD.GE.IFILE+2)THEN 73 - CALL INPSTR(IFILE+2,IFILE+2,EOFSTR,NCEOF) 74 - IEOF=IFILE+2 75 - ELSE 76 - PRINT *,' INPWRD WARNING : The "<<" sign must'// 77 - - ' be followed by a label; no file opened.' 78 - GOTO 1000 79 - ENDIF 80 - ELSE 81 - EOFSTR='EOF' 82 - NCEOF=3 83 - IEOF=IFILE 84 - ENDIF 85 - * All remaining arguments should go to the arguments string. 86 - IF(NWORD.GT.IEOF)THEN 87 - CALL INPSTR(IEOF+1,NWORD,ARGSTR,NCARG) 88 - ELSE 89 - ARGSTR=' ' 90 - NCARG=1 91 - ENDIF 92 - * Fetch old file name for printing error messages, 93 - CALL STRBUF('READ',LUNSTR(LUN,1),AUX,NCAUX,IFAIL) 94 - * Increment the LUN by one. 95 - IF(LUN.GE.20)LUNTRY=LUN+1 96 - IF(LUN.EQ.5 )LUNTRY=20 97 - IF(LUNTRY.GT.MXLUN)THEN 98 - PRINT *,' !!!!!! INPWRD WARNING : Maximum number of'// 99 - - ' open I/O units reached ; input resumed from'// 100 - - AUX(1:NCAUX)//'.' 101 - GOTO 1000 102 - ENDIF 103 - * Open the file and register the opening with DSNLOG. 104 - CALL DSNOPN(FILE,NCFILE,LUNTRY,'READ-FILE',IFAIL) 105 - IF(IFAIL.NE.0)THEN 106 - PRINT *,' !!!!!! INPWRD WARNING : Opening '// 107 - - FILE(1:NCFILE)//' failed; input resumed'// 108 - - ' from '//AUX(1:NCAUX)//'.' 109 - GOTO 1000 110 - ENDIF 111 - CALL DSNLOG(FILE,'Input ','Sequential','Read only ') 112 - IF(LDEBUG)PRINT *,' ++++++ INPWRD DEBUG : '// 113 - - FILE(1:NCFILE)//' opened on unit ',LUNTRY 114 - * Store the logical unit. 115 - LUN=LUNTRY 116 - * Store file name, EOF label and arguments for reference purposes. 117 - CALL STRBUF('STORE',LUNSTR(LUN,1),FILE(1:NCFILE), 118 - - NCFILE,IFAIL) 119 - CALL STRBUF('STORE',LUNSTR(LUN,2),EOFSTR(1:NCEOF), 120 - - NCEOF,IFAIL) 121 - GLBVAL(6)=LUNSTR(LUN,1) 122 - CALL STRBUF('STORE',LUNSTR(LUN,3),ARGSTR(1:NCARG), 123 - - NCARG,IFAIL) 124 - *** Recording requests. 125 - ELSEIF(NWORD.GE.1.AND.LINE(1:2).EQ.'>>')THEN 126 - IF(LDEBUG)PRINT *,' ++++++ INPWRD DEBUG : Statement is'// 127 - - ' a recording request.' 128 - * First of all close the present recording file. 129 - IF(LINREC)CLOSE(UNIT=18,STATUS='KEEP', 130 - - IOSTAT=IOS,ERR=2030) 131 - * Next find the new file name. 132 - CALL INPSTR(1,1,LINE,NC) 133 - IF(NWORD.EQ.1.AND.NC.GT.2)THEN 134 - FILE=LINE(3:)//' ' 135 - IKEY=1 136 - NCFILE=NC-2 137 - ELSEIF(NWORD.EQ.1.AND.NC.EQ.2)THEN 138 - IF(.NOT.LINREC)PRINT *,' !!!!!! INPWRD WARNING :'// 139 - - ' Input recording was not active.' 140 - LINREC=.FALSE. 141 - GOTO 1000 142 - ELSEIF(NWORD.GT.1.AND.NC.EQ.2)THEN 143 - CALL INPSTR(2,2,FILE,NCFILE) 144 - IKEY=2 145 - ENDIF 146 - * Open a file on unit 18 for recording. 147 - CALL DSNOPN(FILE,NCFILE,18,'WRITE-FILE',IFAIL) 148 - IF(IFAIL.NE.0)THEN 149 - PRINT *,' !!!!!! INPWRD WARNING : Recording on '// 150 - - FILE(1:NCFILE)//' cancelled because of an'// 151 - - ' error while opening the file.' 152 - LINREC=.FALSE. 153 - GOTO 1000 154 - ENDIF 155 - CALL DSNLOG(FILE,'Recording ','Sequential','Write ') 156 - * And set the recording flag to active. 157 - LINREC=.TRUE. 158 - *** Redirect output if requested. 159 - ELSEIF(NWORD.GE.1.AND.LINE(1:1).EQ.'>')THEN 160 - IF(LDEBUG)PRINT *,' ++++++ INPWRD DEBUG : Statement is'// 161 - - ' an alternate output request.' 162 - * First of all close the present output file, if connected to unit 8. 163 - IF(LUNOUT.EQ.8)CLOSE(UNIT=8,STATUS='KEEP', 164 - - IOSTAT=IOS,ERR=2030) 165 - * Next find the new file name. 1 74 P=INPUT D=INPWRD 3 PAGE 82 166 - CALL INPSTR(1,1,LINE,NC) 167 - IF(NWORD.EQ.1.AND.NC.GT.1)THEN 168 - FILE=LINE(2:)//' ' 169 - IKEY=1 170 - NCFILE=NC-1 171 - ELSEIF(NWORD.EQ.1.AND.NC.EQ.1)THEN 172 - IF(LUNOUT.EQ.6)PRINT *,' !!!!!! INPWRD WARNING : No'// 173 - - ' output rerouting was in effect.' 174 - CALL STRSAV('Standard output','OUTPUT',IFAIL) 175 - LUNOUT=6 176 - GOTO 1000 177 - ELSEIF(NWORD.GT.1.AND.NC.EQ.1)THEN 178 - CALL INPSTR(2,2,FILE,NCFILE) 179 - IKEY=2 180 - ENDIF 181 - * And find the member name, if present. 182 - IF(NWORD.GE.IKEY+1)THEN 183 - CALL INPSTR(IKEY+1,IKEY+1,LINE,NCMEMB) 184 - MEMBER=LINE(1:8) 185 - ELSE 186 - MEMBER='< none >' 187 - NCMEMB=8 188 - ENDIF 189 - * All that remains, is taken to be the remark. 190 - IF(NWORD.GE.IKEY+2)THEN 191 - CALL INPSTR(IKEY+2,NWORD,LINE,NCREM) 192 - REMARK=LINE(1:29) 193 - ELSE 194 - REMARK='Printed output' 195 - NCREM=14 196 - ENDIF 197 - * Print warnings for too long member names and remarks. 198 - IF(NCMEMB.GT.8)THEN 199 - PRINT *,' !!!!!! INPWRD WARNING : The member name is'// 200 - - ' truncated to '//MEMBER//', first 8 characters.' 201 - NCMEMB=8 202 - ENDIF 203 - IF(NCREM.GT.29)THEN 204 - PRINT *,' !!!!!! INPWRD WARNING : The remark is'// 205 - - ' truncated to "'//REMARK//'" (29 characters).' 206 - NCREM=29 207 - ENDIF 208 - * Check whether the member already exists. 209 - C CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'OUTPUT',EXMEMB) 210 - C IF(JEXMEM.EQ.2.AND.EXMEMB)THEN 211 - C PRINT *,' ------ INPWRD MESSAGE : A copy of the'// 212 - C - ' member exists; output will be appended.' 213 - C ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN 214 - C PRINT *,' !!!!!! INPWRD WARNING : A copy of the'// 215 - C - ' member exists already; output not redirected.' 216 - C GOTO 1000 217 - C ENDIF 218 - * Open a file on unit 8 for the output. 219 - CALL DSNOPN(FILE,NCFILE,8,'WRITE-LIBRARY',IFAIL) 220 - IF(IFAIL.NE.0)THEN 221 - PRINT *,' !!!!!! INPWRD WARNING : The output can not'// 222 - - ' be rerouted to '//FILE(1:NCFILE)//' due to an'// 223 - - ' error while opening the file.' 224 - GOTO 1000 225 - ENDIF 226 - CALL DSNLOG(FILE,'Output ','Sequential','Write ') 227 - * Now write a heading record to the file ... 228 - CALL DATTIM(DATE,TIME) 229 - WRITE(LINE,'(''% Created '',A8,'' At '',A8,1X,A8,1X, 230 - - ''OUTPUT '',1X,''"'',A29,''"'')') DATE,TIME,MEMBER, 231 - - REMARK 232 - WRITE(8,'(A80)',IOSTAT=IOS,ERR=2010) LINE 233 - * and set the new output logical file number. 234 - LUNOUT=8 235 - * Set the name of the output stream. 236 - CALL STRSAV(FILE(1:NCFILE),'OUTPUT',IFAIL) 237 - *** Algebra debugging. 238 - ELSEIF(LINE(1:1).EQ.'@')THEN 239 - NREXP=0 240 - CALL ALGEDT(GLBVAR,NGLB,IENTRY,USE,NREXP) 241 - CALL ALGCLR(IENTRY) 242 - *** String buffer dump. 243 - ELSEIF(INPCMP(1,'DUMP-ST#RING-#BUFFER').NE.0)THEN 244 - CALL STRBUF('DUMP',0,' ',1,IFAIL) 245 - *** Pass command to the environment if the line starts with a $. 246 - ELSEIF(NWORD.GE.1.AND.LINE(1:1).EQ.'$')THEN 247 - CALL INPSTR(1,NWORD,LINE,NC) 248 - IDOLLR=INDEX(LINE,'$') 249 - IF(IDOLLR.NE.0)LINE(IDOLLR:IDOLLR)=' ' 0 250-+ +SELF,IF=APOLLO. 251 - * Set up the I/O stream connection - assuming SR10.x. 252 - connection(1)=ios_$stdin 253 - connection(2)=ios_$stdout 254 - connection(3)=ios_$stderr 255 - * Prepare the arguments. 256 - iargs(1)=2 257 - args(3:5)='sh' 258 - pointer(1)=iaddr(args(1:1)) 259 - * If arguments are absent, put the user in an Aegis shell. 260 - if(nc.eq.1)then 261 - print *,' ------ INPWRD MESSAGE : You enter a'// 262 - - ' sub-shell, type RETURN to get back.' 263 - call pgm_$invoke('/com/sh',int2(7),int2(1), 264 - - pointer,int2(3),connection,pgm_$wait, 265 - - ihandle,istat) 266 - print *,' ------ INPWRD MESSAGE : You are back'// 267 - - ' inside Garfield.' 268 - * If arguments are present, execute the command in Aegis. 269 - else 270 - iargs(3)=min(250,nc) 1 74 P=INPUT D=INPWRD 4 PAGE 83 271 - args(7:)=line(:iargs(3)) 272 - pointer(2)=iaddr(args(5:5)) 273 - call pgm_$invoke('/com/sh',int2(7),int2(2), 274 - - pointer,int2(3),connection,pgm_$wait, 275 - - ihandle,istat) 276 - endif 277 - * Check the shell return code. 278 - if(istat.ne.status_$ok)then 279 - print *,' !!!!!! INPWRD WARNING : The shell command'// 280 - - ' did not complete successfully; details follow.' 281 - call error_$print(istat) 282 - endif 0 283-+ +SELF,IF=CDC. 284 - PRINT *,' !!!!!! INPWRD WARNING : Not yet available.' 0 285-+ +SELF,IF=CMS. 286 - IF(NC.EQ.1.AND.NWORD.EQ.1)THEN 287 - PRINT *,' ------ INPWRD MESSAGE : You enter CMS'// 288 - - ' SUBSET mode, type RETURN to get back.' 289 - CALL VMCMS('SUBSET',IRC) 290 - PRINT *,' ------ INPWRD MESSAGE : You are back'// 291 - - ' inside Garfield.' 292 - ELSE 293 - CALL VMCMS(LINE,IRC) 294 - IF(IRC.EQ.0)THEN 295 - PRINT *,' Command successfully executed.' 296 - ELSEIF(IRC.EQ.-1)THEN 297 - PRINT *,' Your command is not known to CP.' 298 - ELSEIF(IRC.EQ.-2)THEN 299 - PRINT *,' Your command can not be run in SUBSET.' 300 - ELSEIF(IRC.EQ.-3)THEN 301 - PRINT *,' Your command is not known to CMS.' 302 - ELSEIF(IRC.EQ.4)THEN 303 - PRINT *,' Warning issued during execution.' 304 - ELSEIF(IRC.EQ.8)THEN 305 - PRINT *,' Error issued during execution.' 306 - ELSEIF(IRC.EQ.20)THEN 307 - PRINT *,' File identifier incorrectly spelled.' 308 - ELSEIF(IRC.EQ.24)THEN 309 - PRINT *,' Error in the command line.' 310 - ELSEIF(IRC.EQ.28)THEN 311 - PRINT *,' File not found, not accessible etc.' 312 - ELSEIF(IRC.EQ.36)THEN 313 - PRINT *,' Disk not correctly accessed.' 314 - ELSEIF(IRC.EQ.41)THEN 315 - PRINT *,' Not enough storage.' 316 - ELSEIF(IRC.EQ.801)THEN 317 - PRINT *,' EXEC file not found.' 318 - ELSE 319 - PRINT *,' CMS return code for the command: ',IRC 320 - ENDIF 321 - ENDIF 0 322-+ +SELF,IF=MVS. 323 - PRINT *,' !!!!!! INPWRD WARNING : Routing of commands'// 324 - - ' to the internal reader is not yet available.' 0 325-+ +SELF,IF=UNIX. 326 - *** Unix version courtesy Francois Marabelle. 327 - IF(NC.EQ.1.AND.NWORD.EQ.1)THEN 328 - PRINT *,' ------ INPWRD MESSAGE : You enter a'// 329 - - ' subprocess, type exit to get back.' 330 - IERR=SYSTEMF(SHELL(1:NCSH)) 331 - IF(IERR.NE.0)PRINT *,' !!!!!! INPWRD'// 332 - - ' WARNING : The subprocess did not complete'// 333 - - ' successfully.' 334 - PRINT *,' ------ INPWRD MESSAGE : You are back'// 335 - - ' inside Garfield.' 336 - ELSE 337 - IF(LDEBUG)PRINT *,' ++++++ INPWRD DEBUG : Spawn "'// 338 - - LINE(1:NC)//'".' 339 - IERR=SYSTEMF(SHELL(1:NCSH)//' -c "'//LINE(1:NC)//'"') 340 - IF(IERR.NE.0)PRINT *,' !!!!!! INPWRD'// 341 - - ' WARNING : The '//SHELL(1:NCSH)//' command did'// 342 - - ' not complete successfully.' 343 - ENDIF 0 344-+ +SELF,IF=VAX. 345 - IF(NC.EQ.1.AND.NWORD.EQ.1)THEN 346 - PRINT *,' ------ INPWRD MESSAGE : You enter a'// 347 - - ' subprocess, type LOGOUT to get back.' 348 - IERR=LIB$SPAWN() 349 - IF(IERR.EQ.2*INT(IERR/2.0))PRINT *,' !!!!!! INPWRD'// 350 - - ' WARNING : The subprocess did not complete'// 351 - - ' successfully.' 352 - PRINT *,' ------ INPWRD MESSAGE : You are back'// 353 - - ' inside Garfield.' 354 - ELSE 355 - IF(LDEBUG)PRINT *,' ++++++ INPWRD DEBUG : Spawn "'// 356 - - LINE(1:NC)//'".' 357 - IERR=LIB$SPAWN(LINE(1:NC)) 358 - IF(IERR.EQ.2*INT(IERR/2.0))PRINT *,' !!!!!! INPWRD'// 359 - - ' WARNING : The DCL command did not complete'// 360 - - ' successfully.' 361 - ENDIF 0 362-+ +SELF. 363 - *** Skip comment lines, starting with a '*'. 364 - ELSEIF(NWORD.GE.1.AND.LINE(1:1).EQ.'*')THEN 365 - GOTO 1000 366 - *** Check for help lines, starting with ?. 367 - ELSEIF(NWORD.GE.1.AND.(LINE(1:1).EQ.'?'.OR.INPCMP(1,'HELP')+ 368 - - INPCMP(1,'INFO#RMATION').NE.0))THEN 1 74 P=INPUT D=INPWRD 5 PAGE 84 369-+ +SELF,IF=HELP. 370 - CALL HLPINP 0 371-+ +SELF,IF=-HELP. 372 - PRINT *,' !!!!!! INPWRD WARNING : The help subsection'// 373 - - ' has not been compiled; no help available.' 0 374-+ +SELF. 375 - *** Graphics options are lines starting with a !. 376 - ELSEIF(NWORD.GE.1.AND.LINE(1:1).EQ.'!')THEN 377 - CALL GRAINP 378 - *** Dataset commands are lines starting with a %. 379 - ELSEIF(NWORD.GE.1.AND.LINE(1:1).EQ.'%')THEN 380 - CALL DSNINP 381 - *** List current options. 382 - ELSEIF(INPCMP(1,'OPT#IONS').NE.0.AND.NWORD.EQ.1)THEN 383 - WRITE(LUNOUT,'( 384 - - '' GLOBAL OPTIONS CURRENTLY IN EFFECT:''// 385 - - '' Routine identifiers printed (IDENTIFICATION): '', 386 - - L1/ 387 - - '' Debugging output is generated (DEBUG): '', 388 - - L1/ 389 - - '' Echoing of the input lines (INPUT-LISTING): '', 390 - - L1/ 391 - - '' Record input from terminal (RECORDING): '', 392 - - L1/ 393 - - '' Inform about progress (PROGRESS-PRINT): '', 394 - - L1)') LIDENT,LDEBUG,LINPUT,LINREC,LPROPR 395 - IF(JFAIL.EQ.1)WRITE(LUNOUT,'( 396 - - '' Action to be taken in case of input errors: '', 397 - - ''carry on with defaults.'')') 398 - IF(JFAIL.EQ.2)WRITE(LUNOUT,'( 399 - - '' Action to be taken in case of input errors: '', 400 - - ''skip the instruction.'')') 401 - IF(JFAIL.EQ.3)WRITE(LUNOUT,'( 402 - - '' Action to be taken in case of input errors: '', 403 - - ''terminate execution.'')') 404 - IF(JEXMEM.EQ.1)WRITE(LUNOUT,'( 405 - - '' If a member to be written exists already: '', 406 - - ''mark existing member for deletion.'')') 407 - IF(JEXMEM.EQ.2)WRITE(LUNOUT,'( 408 - - '' If a member to be written exists already: '', 409 - - ''issue a warning, and append new member.'')') 410 - IF(JEXMEM.EQ.3)WRITE(LUNOUT,'( 411 - - '' If a member to be written exists already: '', 412 - - ''issue a warning, do not write new member.'')') 413 - IF(LGSTOP)THEN 414 - WRITE(LUNOUT,'( 415 - - '' In case of a graphics error: '', 416 - - '' dump data and quit.'')') 417 - ELSE 418 - WRITE(LUNOUT,'( 419 - - '' In case of a graphics error: '', 420 - - '' print a warning.'')') 421 - ENDIF 422 - NNWORD=1 423 - RETURN 424 - * Update options. 425 - ELSEIF(INPCMP(1,'OPT#IONS').NE.0)THEN 426 - I=2 427 - NNWORD=NWORD 428 - 10 CONTINUE 429 - * Trace routine calls or not. 430 - IF(INPCMP(I,'ID#ENTIFICATION').NE.0)THEN 431 - LIDENT=.TRUE. 432 - CALL INPDEL(I) 433 - GOTO 10 434 - ELSEIF(INPCMP(I,'NOID#ENTIFICATION').NE.0)THEN 435 - LIDENT=.FALSE. 436 - CALL INPDEL(I) 437 - GOTO 10 438 - * Debug output. 439 - ELSEIF(INPCMP(I,'DEB#UGGING').NE.0)THEN 440 - LDEBUG=.TRUE. 441 - CALL INPDEL(I) 442 - GOTO 10 443 - ELSEIF(INPCMP(I,'NODEB#UGGING').NE.0)THEN 444 - LDEBUG=.FALSE. 445 - CALL INPDEL(I) 446 - GOTO 10 447 - * Input echoing. 448 - ELSEIF(INPCMP(I,'IN#PUT-#LISTING').NE.0)THEN 449 - LINPUT=.TRUE. 450 - CALL INPDEL(I) 451 - GOTO 10 452 - ELSEIF(INPCMP(I,'NOIN#PUT-#LISTING').NE.0)THEN 453 - LINPUT=.FALSE. 454 - CALL INPDEL(I) 455 - GOTO 10 456 - * Synchronisation output. 457 - ELSEIF(INPCMP(I,'SYN#CHRONISE').NE.0)THEN 458 - LSYNCH=.TRUE. 459 - CALL INPDEL(I) 460 - GOTO 10 461 - ELSEIF(INPCMP(I,'NOSYN#CHRONISE').NE.0)THEN 462 - LSYNCH=.FALSE. 463 - CALL INPDEL(I) 464 - GOTO 10 465 - * Record terminal input. 466 - ELSEIF(INPCMP(I,'REC#ORDING').NE.0)THEN 467 - * First of all close the present recording file. 468 - IF(LINREC)CLOSE(UNIT=18,STATUS='KEEP', 469 - - IOSTAT=IOS,ERR=2030) 470 - * Next set the new file name. 1 74 P=INPUT D=INPWRD 6 PAGE 85 471-+ +SELF,IF=UNIX. 472 - FILE='garflast.dat' 473 - NCFILE=12 0 474-+ +SELF,IF=CMS. 475 - FILE='GARFLAST.INPUT' 476 - NCFILE=14 0 477-+ +SELF,IF=-UNIX,IF=-CMS. 478 - FILE='GARFLAST.DAT' 479 - NCFILE=12 0 480-+ +SELF. 481 - * Open a file on unit 18 for recording. 482 - CALL DSNOPN(FILE,NCFILE,18,'WRITE-FILE',IFAIL) 483 - IF(IFAIL.NE.0)THEN 484 - PRINT *,' !!!!!! INPWRD WARNING : Recording on '// 485 - - FILE(1:NCFILE)//' cancelled because of an'// 486 - - ' error while opening the file.' 487 - LINREC=.FALSE. 488 - GOTO 10 489 - ENDIF 490 - CALL DSNLOG(FILE,'Recording ','Sequential', 491 - - 'Write ') 492 - * And set the recording flag to active. 493 - LINREC=.TRUE. 494 - CALL INPDEL(I) 495 - GOTO 10 496 - ELSEIF(INPCMP(I,'NOREC#ORDING').NE.0)THEN 497 - LINREC=.FALSE. 498 - CALL INPDEL(I) 499 - GOTO 10 500 - * Keep informed about progress. 501 - ELSEIF(INPCMP(I,'PRO#GRESS-#PRINT').NE.0)THEN 502 - LPROPR=.TRUE. 503 - CALL INPDEL(I) 504 - GOTO 10 505 - ELSEIF(INPCMP(I,'NOPRO#GRESS-#PRINT').NE.0)THEN 506 - LPROPR=.FALSE. 507 - CALL INPDEL(I) 508 - GOTO 10 509 - * Handling of errors. 510 - ELSEIF(INPCMP(I,'ON-E#RROR-C#ONTINUE').NE.0)THEN 511 - JFAIL=1 512 - CALL INPDEL(I) 513 - GOTO 10 514 - ELSEIF(INPCMP(I,'ON-E#RROR-S#KIP').NE.0)THEN 515 - JFAIL=2 516 - CALL INPDEL(I) 517 - GOTO 10 518 - ELSEIF(INPCMP(I,'ON-E#RROR-T#ERMINATE').NE.0)THEN 519 - JFAIL=3 520 - CALL INPDEL(I) 521 - GOTO 10 522 - * Graphics error handling. 523 - ELSEIF(INPCMP(I,'DUMP-ON-GR#APHICS-#ERROR').NE.0)THEN 524 - LGSTOP=.TRUE. 525 - CALL INPDEL(I) 526 - GOTO 10 527 - ELSEIF(INPCMP(I,'NODUMP-ON-GR#APHICS-#ERROR').NE.0)THEN 528 - LGSTOP=.FALSE. 529 - CALL INPDEL(I) 530 - GOTO 10 531 - * Handling of existing members. 532 - ELSEIF(INPCMP(I,'DEL#ETE-OLD-MEM#BER').NE.0)THEN 533 - JEXMEM=1 534 - CALL INPDEL(I) 535 - GOTO 10 536 - ELSEIF(INPCMP(I,'WARN-BUT-WR#ITE')+ 537 - - INPCMP(I,'WR#ITE-BUT-WARN').NE.0)THEN 538 - JEXMEM=2 539 - CALL INPDEL(I) 540 - GOTO 10 541 - ELSEIF(INPCMP(I,'WARN-AND-NOWR#ITE')+ 542 - - INPCMP(I,'NOWR#ITE-AND-WARN').NE.0)THEN 543 - JEXMEM=3 544 - CALL INPDEL(I) 545 - GOTO 10 546 - ENDIF 547 - I=I+1 548 - IF(I.LE.NWORD)GOTO 10 549 - IF(NNWORD.GT.1.AND.NWORD.EQ.1)GOTO 1000 550 - NNWORD=NWORD 551 - RETURN 552 - *** Escape character handling. 553 - ELSEIF(INPCMP(1,'ESC#APE').NE.0)THEN 554 - IF(NWORD.EQ.1)THEN 555 - WRITE(LUNOUT,'(/'' Current escape character is '', 556 - - A1,'' ('',I3,'').''/)') ESCAPE,ICHAR(ESCAPE) 557 - ELSE 558 - CALL INPSTR(2,2,ESCAUX,NCESC) 559 - IF(INDEX('''"` ,=',ESCAUX).NE.0)THEN 560 - PRINT *,' !!!!!! INPWRD WARNING : The escape'// 561 - - ' character can not be an accent or a'// 562 - - ' word separator ; not redefined.' 563 - ELSEIF(INDEX('!%&#<>$*?@',ESCAUX).NE.0)THEN 564 - PRINT *,' !!!!!! INPWRD WARNING : The escape'// 565 - - ' character can not be a (sub-)section'// 566 - - ' header ; not redefined.' 567 - ELSEIF(INDEX('{}[]()',ESCAUX).NE.0)THEN 568 - PRINT *,' !!!!!! INPWRD WARNING : The escape'// 569 - - ' character can not be a parenthesis ;'// 570 - - ' not redefined.' 571 - ELSEIF(NCESC.LE.0)THEN 572 - PRINT *,' !!!!!! INPWRD WARNING : The escape'// 573 - - ' character can not be a null string ;'// 1 74 P=INPUT D=INPWRD 7 PAGE 86 574 - - ' not redefined.' 575 - ELSE 576 - IF(NCESC.GT.1)PRINT *,' ------ INPWRD MESSAGE :'// 577 - - ' Only first character of escape used.' 578 - ESCAPE=ESCAUX 579 - ENDIF 580 - ENDIF 0 581-+ +SELF,IF=UNIX. 582 - *** Shell. 583 - ELSEIF(INPCMP(1,'SH#ELL').NE.0)THEN 584 - IF(NWORD.EQ.1)THEN 585 - WRITE(LUNOUT,'(/'' Current shell is '', 586 - - A,''.''/)') SHELL(1:NCSH) 587 - ELSE 588 - CALL INPSTR(2,2,SHELL,NCSH) 589 - ENDIF 0 590-+ +SELF. 591 - *** Input translation commands. 592 - ELSEIF(INPCMP(1,'TRAN#SLATE').NE.0)THEN 593 - CALL INPTRR 594 - ELSEIF(INPCMP(1,'GET-TRAN#SLATION-#TABLE').NE.0)THEN 595 - CALL INPTRG(IFAIL) 596 - ELSEIF(INPCMP(1,'WR#ITE-TRAN#SLATION-#TABLE').NE.0)THEN 597 - CALL INPTRW(IFAIL) 598 - *** CERN library error messages. 599 - ELSEIF(INPCMP(1,'ERR#OR-#HANDLING').NE.0)THEN 600 - CALL CRNERR 601 - *** Read some vectors. 602 - ELSEIF(INPCMP(1,'R#EAD-VEC#TORS')+ 603 - - INPCMP(1,'VEC#TORS-#READ').NE.0)THEN 604 - CALL MATVCR(IFAIL) 605 - *** Start of a DO loop. 606 - ELSEIF(INPCMP(1,'FOR')+INPCMP(1,'WHILE')+INPCMP(1,'UNTIL')+ 607 - - INPCMP(1,'DO')+INPCMP(1,'IF')+INPCMP(1,'STEP').NE.0.AND. 608 - - INPCMP(NWORD,'DO').NE.0)THEN 609 - DOREAD=.TRUE. 610 - CALL INPRDO(IFAIL) 611 - DOREAD=.FALSE. 612 - IF(IFAIL.EQ.0)THEN 613 - DOEXEC=.TRUE. 614 - ELSE 615 - PRINT *,' !!!!!! INPWRD WARNING : Reading the DO'// 616 - - ' loop failed; normal input resumed.' 617 - ENDIF 618 - *** Global variables. 619 - ELSEIF(INPCMP(1,'GL#OBALS').NE.0)THEN 620 - CALL INPGLB 621 - *** Read a line. 622 - ELSEIF(INPCMP(1,'PARSE').NE.0)THEN 623 - CALL INPPAR(IFAIL) 624 - *** Echo a line. 625 - ELSEIF(INPCMP(1,'SAY').NE.0)THEN 626 - CALL INPSTR(2,NWORD,LINE,NC) 627 - WRITE(LUNOUT,'(2X,A)') LINE(1:NC) 628 - *** Procedure calls. 629 - ELSEIF(INPCMP(1,'CALL').NE.0)THEN 630 - CALL INPCAL('EXECUTE',IDUMMY,IFAIL) 631 - *** Return because it's apparently not a special command. 632 - ELSE 633 - NNWORD=NWORD 634 - RETURN 635 - ENDIF 636 - GOTO 1000 637 - *** Handle I/O problems. 638 - 2010 CONTINUE 639 - PRINT *,' !!!!!! INPWRD WARNING : Error writing the'// 640 - - ' heading record ; output not rerouted.' 641 - CALL INPIOS(IOS) 642 - CLOSE(UNIT=8,IOSTAT=IOS,ERR=2030) 643 - GOTO 1000 644 - 2030 CONTINUE 645 - PRINT *,' !!!!!! INPWRD WARNING : Closing the unit failed,'// 646 - - ' rerouting the output will no longer be possible.' 647 - CALL INPIOS(IOS) 648 - GOTO 1000 649 - END 75 GARFIELD ================================================== P=INPUT D=INPXDO 1 ============================ 0 + +DECK,INPXDO. 1 - SUBROUTINE INPXDO(STRING,NC,IFLAG) 2 - *----------------------------------------------------------------------- 3 - * INPXDO - Executes a DO loop and returns commands. 4 - * (Last changed on 27/ 6/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,DOLOOP. 9.- +SEQ,GLOBALS. 10.- +SEQ,PRINTPLOT. 11 - CHARACTER*(*) STRING 12 - REAL RES(5) 13 - INTEGER NC,IFLAG,OLDLVL,MODRES(5),ILOOP,IFAIL1,IFAIL2,IFAIL3, 14 - - IFAIL4,IFAIL5,IFAIL,IBLOCK,I 15 - LOGICAL IFCOND 16 - *** Be sure this routine is entered legally. 17 - IF(NDOLIN.LE.0.OR.NLOOP.LE.0.OR.ISTATE.LT.0)THEN 18 - PRINT *,' ###### INPXDO ERROR : No valid DO loop'// 19 - - ' stored; routine should not have been called.' 20 - IFLAG=-1 21 - RETURN 22 - ENDIF 23 - *** Initial settings. 24 - IF(ISTATE.EQ.0)THEN 1 75 P=INPUT D=INPXDO 2 PAGE 87 25 - CURLIN=0 26 - CDOLVL=0 27 - ISTATE=1 28 - ENDIF 29 - *** Return at this point if a new line has to be read. 30 - 10 CONTINUE 31 - *** Increment line counter. 32 - CURLIN=CURLIN+1 33 - * Check we're still in the loop. 34 - IF(CURLIN.GT.NDOLIN)THEN 35 - PRINT *,' ------ INPXDO MESSAGE : End of loop reached.' 36 - CALL ALGERR 37 - IFLAG=+2 38 - IF(CDOLVL.NE.0)THEN 39 - PRINT *,' ###### INPXDO ERROR : The loop is left'// 40 - - ' at a non-zero level: ',CDOLVL,'.' 41 - PRINT *,' Program bug -'// 42 - - ' please report; all loops ended.' 43 - IFLAG=-1 44 - ENDIF 45 - GOTO 3000 46 - ENDIF 47 - * Evaluate the IF condition, if present. 48 - IF(LINREF(CURLIN,4).GT.0)THEN 49 - CALL TIMEL(GLBVAL(1)) 50 - CALL ALGEXE(LINREF(CURLIN,4),GLBVAL,GLBMOD,NGLB, 51 - - RES,MODRES,1,IFAIL) 52 - IF(IFAIL.NE.0)THEN 53 - PRINT *,' !!!!!! INPXDO WARNING : Failure to'// 54 - - ' figure out the value of the IF condition.' 55 - IFCOND=.TRUE. 56 - ELSEIF(ABS(RES(1)).LT.1.0E-5)THEN 57 - IFCOND=.FALSE. 58 - ELSEIF(ABS(1.0-RES(1)).LT.1.0E-5)THEN 59 - IFCOND=.TRUE. 60 - ELSE 61 - PRINT *,' !!!!!! INPXDO WARNING : The IF'// 62 - - ' condition does not evaluate to a logical.' 63 - IFCOND=.TRUE. 64 - ENDIF 65 - ELSE 66 - IFCOND=.TRUE. 67 - ENDIF 68 - * Make sure the line number is not negative. 69 - IF(CURLIN.LE.0)THEN 70 - PRINT *,' ###### INPXDO ERROR : Negative line number'// 71 - - ' encountered: ',CURLIN,'.' 72 - PRINT *,' Program bug -'// 73 - - ' please report; all loops ended.' 74 - IFLAG=-1 75 - GOTO 3000 76 - ENDIF 77 - *** Ordinary line, return to have it executed. 78 - IF(LINREF(CURLIN,1).EQ.0.AND.IFCOND)THEN 79 - CALL STRBUF('READ',LINREF(CURLIN,2),STRING,NC,IFAIL) 80 - IF(IFAIL.NE.0)THEN 81 - PRINT *,' ###### INPXDO ERROR : Error retrieving'// 82 - - ' a line of the DO loop nest; all loops ended.' 83 - IFLAG=-1 84 - GOTO 3000 85 - ENDIF 86 - IF(LINREF(CURLIN,4).EQ.0)THEN 87 - IFLAG=0 88 - ELSE 89 - IFLAG=+1 90 - ENDIF 91 - RETURN 92 - *** Ordinary line, not to be executed. 93 - ELSEIF(LINREF(CURLIN,1).EQ.0)THEN 94 - GOTO 10 95 - *** Start of a DO loop. 96 - ELSEIF(LINREF(CURLIN,1).EQ.1)THEN 97 - * Pick up the index of this DO loop. 98 - ILOOP=LINREF(CURLIN,3) 99 - * Maybe the whole DO loop shouldn't be executed. 100 - IF(.NOT.IFCOND)THEN 101 - CURLIN=DOREF(ILOOP,7) 102 - GOTO 10 103 - ENDIF 104 - * We will almost certainly need the time left. 105 - CALL TIMEL(GLBVAL(1)) 106 - * In case of a loop with variable, handle initial value. 107 - IF(DOREF(ILOOP,9).GT.0)THEN 108 - * Evaluate initial value, step size and final value. 109 - CALL ALGEXE(DOREF(ILOOP,1),GLBVAL,GLBMOD,NGLB, 110 - - RES(1),MODRES(1),1,IFAIL1) 111 - CALL ALGEXE(DOREF(ILOOP,2),GLBVAL,GLBMOD,NGLB, 112 - - RES(2),MODRES(2),1,IFAIL2) 113 - CALL ALGEXE(DOREF(ILOOP,5),GLBVAL,GLBMOD,NGLB, 114 - - RES(5),MODRES(5),1,IFAIL5) 115 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL5.NE.0)THEN 116 - PRINT *,' ###### INPXDO ERROR : Error'// 117 - - ' evaluating From, Step and To;'// 118 - - ' all loops ended.' 119 - IFLAG=-1 120 - GOTO 3000 121 - ELSEIF(MODRES(1).NE.2.OR.MODRES(2).NE.2.OR. 122 - - MODRES(5).NE.2)THEN 123 - PRINT *,' ###### INPXDO ERROR : From, Step'// 124 - - ' or To does not evaluate to a number;'// 125 - - ' all loops ended.' 126 - IFLAG=-1 127 - GOTO 3000 128 - ENDIF 129 - * Store initial value. 130 - GLBVAL(DOREF(ILOOP,9))=RES(1) 1 75 P=INPUT D=INPXDO 3 PAGE 88 131 - GLBMOD(DOREF(ILOOP,9))=MODRES(1) 132 - * Check that we are between From and To. 133 - IF((GLBVAL(DOREF(ILOOP,9)).GT.RES(5).AND. 134 - - RES(2).GT.0.0).OR. 135 - - (GLBVAL(DOREF(ILOOP,9)).LT.RES(5).AND. 136 - - RES(2).LT.0.0))THEN 137 - CURLIN=DOREF(ILOOP,7) 138 - GOTO 10 139 - ENDIF 140 - ENDIF 141 - * Evaluate the WHILE condition. 142 - CALL ALGEXE(DOREF(ILOOP,3),GLBVAL,GLBMOD,NGLB, 143 - - RES(3),MODRES(3),1,IFAIL3) 144 - IF(IFAIL3.NE.0)THEN 145 - PRINT *,' ###### INPXDO ERROR : Error evaluating'// 146 - - ' While; all loops ended.' 147 - IFLAG=-1 148 - GOTO 3000 149 - ELSEIF(MODRES(3).NE.3)THEN 150 - PRINT *,' ###### INPXDO ERROR : While condition'// 151 - - ' does not evaluate to a logical; loops ended.' 152 - IFLAG=-1 153 - GOTO 3000 154 - ENDIF 155 - * Check WHILE is still satisfied. 156 - IF(ABS(RES(3)).LT.1.0E-3)THEN 157 - CURLIN=DOREF(ILOOP,7) 158 - GOTO 10 159 - ENDIF 160 - * Increment the level counter and keep the trace. 161 - CDOLVL=CDOLVL+1 162 - TRACDO(CDOLVL)=LINREF(CURLIN,3) 163 - * Read the first line of the loop. 164 - GOTO 10 165 - *** LEAVE the loop altogether and condition satisfied. 166 - ELSEIF(LINREF(CURLIN,1).EQ.3.AND.IFCOND)THEN 167 - * Decrease the level counter. 168 - OLDLVL=CDOLVL 169 - DO 20 I=OLDLVL,1,-1 170 - IF(TRACDO(I).NE.LINREF(CURLIN,3))THEN 171 - CDOLVL=CDOLVL-1 172 - ELSE 173 - GOTO 30 174 - ENDIF 175 - 20 CONTINUE 176 - PRINT *,' !!!!!! INPXDO WARNING : LEAVE fails, the'// 177 - - ' loop to be left is not in the stack.' 178 - IFLAG=-1 179 - GOTO 3000 180 - 30 CONTINUE 181 - CDOLVL=CDOLVL-1 182 - * Also set the new IF level. 183 - CIFLVL=DOREF(LINREF(CURLIN,3),10) 184 - * Next line to be read is just after the ENDDO. 185 - CURLIN=DOREF(LINREF(CURLIN,3),7) 186 - * Read that line. 187 - GOTO 10 188 - *** LEAVE but IF condition not satisfied. 189 - ELSEIF(LINREF(CURLIN,1).EQ.3)THEN 190 - GOTO 10 191 - *** Next iteration, either via an ITERATE or an ENDDO. 192 - ELSEIF((LINREF(CURLIN,1).EQ.2.AND.IFCOND).OR. 193 - - LINREF(CURLIN,1).EQ.4)THEN 194 - * Decrease the level counter in case of an ITERATE. 195 - IF(LINREF(CURLIN,1).EQ.2)THEN 196 - OLDLVL=CDOLVL 197 - DO 40 I=OLDLVL,1,-1 198 - IF(TRACDO(I).NE.LINREF(CURLIN,3))THEN 199 - CDOLVL=CDOLVL-1 200 - ELSE 201 - GOTO 50 202 - ENDIF 203 - 40 CONTINUE 204 - PRINT *,' !!!!!! INPXDO WARNING : ITERATE fails,'// 205 - - ' loop to be returned to is not in the stack.' 206 - IFLAG=-1 207 - GOTO 3000 208 - 50 CONTINUE 209 - ENDIF 210 - * Pick up the target loop index. 211 - ILOOP=LINREF(CURLIN,3) 212 - * Also set the new IF level. 213 - CIFLVL=DOREF(ILOOP,10) 214 - * We will almost certainly need the time left. 215 - CALL TIMEL(GLBVAL(1)) 216 - * Loop with variable: handle the loop variable. 217 - IF(DOREF(ILOOP,9).GT.0)THEN 218 - * Additionally evaluate increment and final value. 219 - CALL ALGEXE(DOREF(ILOOP,2),GLBVAL,GLBMOD,NGLB, 220 - - RES(2),MODRES(2),1,IFAIL2) 221 - CALL ALGEXE(DOREF(ILOOP,5),GLBVAL,GLBMOD,NGLB, 222 - - RES(5),MODRES(5),1,IFAIL5) 223 - IF(IFAIL2.NE.0.OR.IFAIL5.NE.0)THEN 224 - PRINT *,' ###### INPXDO ERROR : Error'// 225 - - ' evaluating Step and To; all loops ended.' 226 - IFLAG=-1 227 - GOTO 3000 228 - ELSEIF(MODRES(2).NE.2.OR.MODRES(5).NE.2)THEN 229 - PRINT *,' ###### INPXDO ERROR : Step'// 230 - - ' or To does not evaluate to a number;'// 231 - - ' all loops ended.' 232 - IFLAG=-1 233 - GOTO 3000 234 - ENDIF 235 - * Increment the loop variable. 236 - GLBVAL(DOREF(ILOOP,9))=GLBVAL(DOREF(ILOOP,9))+RES(2) 1 75 P=INPUT D=INPXDO 4 PAGE 89 237 - * Check the final value is not yet exceeded. 238 - IF((GLBVAL(DOREF(ILOOP,9)).GT.RES(5).AND. 239 - - RES(2).GT.0.0).OR. 240 - - (GLBVAL(DOREF(ILOOP,9)).LT.RES(5).AND. 241 - - RES(2).LT.0.0))THEN 242 - CURLIN=DOREF(ILOOP,7) 243 - CDOLVL=CDOLVL-1 244 - GOTO 10 245 - ENDIF 246 - ENDIF 247 - * Evaluate the WHILE and UNTIL portions, which are always needed. 248 - CALL ALGEXE(DOREF(ILOOP,3),GLBVAL,GLBMOD,NGLB, 249 - - RES(3),MODRES(3),1,IFAIL3) 250 - CALL ALGEXE(DOREF(ILOOP,4),GLBVAL,GLBMOD,NGLB, 251 - - RES(4),MODRES(4),1,IFAIL4) 252 - IF(IFAIL3.NE.0.OR.IFAIL4.NE.0)THEN 253 - PRINT *,' ###### INPXDO ERROR : Error evaluating'// 254 - - ' While and Until; all loops ended.' 255 - IFLAG=-1 256 - GOTO 3000 257 - ELSEIF(MODRES(3).NE.3.OR.MODRES(4).NE.3)THEN 258 - PRINT *,' ###### INPXDO ERROR : While or Until'// 259 - - ' does not evaluate to a logical; loops ended.' 260 - IFLAG=-1 261 - GOTO 3000 262 - ENDIF 263 - * Check the WHILE and UNTIL control expressions. 264 - IF(ABS(RES(3)).LT.1.0E-3.OR.ABS(RES(4)-1.0).LT.1.0E-3)THEN 265 - CURLIN=DOREF(ILOOP,7) 266 - CDOLVL=CDOLVL-1 267 - GOTO 10 268 - ENDIF 269 - * Return to the first line of the loop if all else fails. 270 - CURLIN=DOREF(ILOOP,6) 271 - GOTO 10 272 - *** ITERATE but condition not satisfied. 273 - ELSEIF(LINREF(CURLIN,1).EQ.2.AND..NOT.IFCOND)THEN 274 - GOTO 10 275 - *** Start of an IF block. 276 - ELSEIF(LINREF(CURLIN,1).EQ.11)THEN 277 - * Pick up the block number for easier reference. 278 - IBLOCK=LINREF(CURLIN,6) 279 - * Set the new line depending on the value of the IF condition. 280 - IF(IFCOND)THEN 281 - IFREF(IBLOCK,3)=1 282 - ELSE 283 - IFREF(IBLOCK,3)=0 284 - CURLIN=LINREF(CURLIN,5)-1 285 - ENDIF 286 - * We always go up by one level in the IF tree. 287 - CIFLVL=CIFLVL+1 288 - TRACIF(CIFLVL)=IBLOCK 289 - GOTO 10 290 - *** An ELSEIF branch. 291 - ELSEIF(LINREF(CURLIN,1).EQ.12)THEN 292 - * Pick up the block number for easier reference. 293 - IBLOCK=LINREF(CURLIN,6) 294 - * Check whether we have already done one branch. 295 - IF(IFREF(IBLOCK,3).EQ.1)THEN 296 - CURLIN=IFREF(IBLOCK,2)-1 297 - GOTO 10 298 - ENDIF 299 - * Set the new line depending on the value of the IF condition. 300 - IF(IFCOND)THEN 301 - IFREF(IBLOCK,3)=1 302 - ELSE 303 - IFREF(IBLOCK,3)=0 304 - CURLIN=LINREF(CURLIN,5)-1 305 - ENDIF 306 - GOTO 10 307 - *** An ELSE branch. 308 - ELSEIF(LINREF(CURLIN,1).EQ.13)THEN 309 - * Pick up the block number for easier reference. 310 - IBLOCK=LINREF(CURLIN,6) 311 - * Check whether we have already done one branch. 312 - IF(IFREF(IBLOCK,3).EQ.1)THEN 313 - CURLIN=IFREF(IBLOCK,2)-1 314 - GOTO 10 315 - ENDIF 316 - * The next part should be executed anyhow. 317 - IFREF(IBLOCK,3)=1 318 - GOTO 10 319 - *** The ENDIF part of the IF block, just decrement. 320 - ELSEIF(LINREF(CURLIN,1).EQ.14)THEN 321 - CIFLVL=CIFLVL-1 322 - GOTO 10 323 - *** A GLOBAL variable is redefined. 324 - ELSEIF(LINREF(CURLIN,1).EQ.21)THEN 325 - * Check IF condition. 326 - IF(.NOT.IFCOND)GOTO 10 327 - * If satisfied, evaluate the Global. 328 - CALL TIMEL(GLBVAL(1)) 329 - CALL ALGEXE(LINREF(CURLIN,8),GLBVAL,GLBMOD,NGLB, 330 - - RES,MODRES,1,IFAIL) 331 - IF(LINREF(CURLIN,7).LE.0)THEN 332 - IF(IFAIL.NE.0)PRINT *,' !!!!!! INPXDO WARNING :'// 333 - - ' Sub-matrix assignment in Global statement'// 334 - - ' has failed.' 335 - ELSEIF(IFAIL.NE.0)THEN 336 - PRINT *,' !!!!!! INPXDO WARNING : Error evaluating'// 337 - - ' a GLOBAL expression; set to Undefined.' 338 - CALL ALGREU(NINT(GLBVAL(LINREF(CURLIN,7))), 339 - - GLBMOD(LINREF(CURLIN,7)),0) 340 - GLBVAL(LINREF(CURLIN,7))=0 341 - GLBMOD(LINREF(CURLIN,7))=0 342 - ELSE 1 75 P=INPUT D=INPXDO 5 PAGE 90 343 - CALL ALGREU(NINT(GLBVAL(LINREF(CURLIN,7))), 344 - - GLBMOD(LINREF(CURLIN,7)),0) 345 - GLBVAL(LINREF(CURLIN,7))=RES(1) 346 - GLBMOD(LINREF(CURLIN,7))=MODRES(1) 347 - ENDIF 348 - GOTO 10 349 - *** A CALL statement. 350 - ELSEIF(LINREF(CURLIN,1).EQ.22)THEN 351 - * Check IF condition. 352 - IF(.NOT.IFCOND)GOTO 10 353 - * If satisfied, execute the Call. 354 - CALL TIMEL(GLBVAL(1)) 355 - CALL ALGEXE(LINREF(CURLIN,8),GLBVAL,GLBMOD,NGLB, 356 - - RES,MODRES,1,IFAIL) 357 - IF(IFAIL.NE.0)PRINT *,' !!!!!! INPXDO WARNING : Error'// 358 - - ' executing a CALL statement.' 359 - GOTO 10 360 - *** Unrecognised instruction. 361 - ELSE 362 - PRINT *,' !!!!!! INPXDO WARNING : Unrecognised line'// 363 - - ' type seen; loop is left.' 364 - IFLAG=-1 365 - GOTO 3000 366 - ENDIF 367 - *** End of loop cleanup. 368 - 3000 CONTINUE 369 - CALL INPCDO 370 - END 76 GARFIELD ================================================== P=DATASET D= 1 ============================ 0 + +PATCH,DATASET. 77 GARFIELD ================================================== P=DATASET D=DSNCMP 1 ============================ 0 + +DECK,DSNCMP. 1 - LOGICAL FUNCTION DSNCMP(DATE1,DATE2) 2 - *----------------------------------------------------------------------- 3 - * DSNCMP - Returns .TRUE. if the date DATE2 precedes DATE1. 4 - * (Last changed on 25/ 5/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - CHARACTER*8 DATE1,DATE2 8 - INTEGER IDAY1,IDAY2,IMON1,IMON2,IYEAR1,IYEAR2 9 - *** Decode the date strings. 10 - READ(DATE1,'(BN,I2,1X,I2,1X,I2)') IDAY1,IMON1,IYEAR1 11 - IF(IYEAR1.LT.84)IYEAR1=IYEAR1+100 12 - READ(DATE2,'(BN,I2,1X,I2,1X,I2)') IDAY2,IMON2,IYEAR2 13 - IF(IYEAR2.LT.84)IYEAR2=IYEAR2+100 14 - *** Compare. 15 - DSNCMP=.TRUE. 16 - IF(IYEAR1.GT.IYEAR2)RETURN 17 - IF(IYEAR1.EQ.IYEAR2.AND.IMON1.GT.IMON2)RETURN 18 - IF(IYEAR1.EQ.IYEAR2.AND.IMON1.EQ.IMON2.AND.IDAY1.GT.IDAY2)RETURN 19 - DSNCMP=.FALSE. 20 - END 78 GARFIELD ================================================== P=DATASET D=DSNFMTUX 1 ============================ 0 + +DECK,DSNFMTUX,IF=UNIX. 1 - SUBROUTINE DSNFMT(F_IN,NC_IN,F_OUT,NC_OUT,ACCESS,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * DSNFMT - Searches for the full file name specification, taking the 4 - * environment variables into account. 5 - * (Last changed on 7/12/95.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*(MXNAME) F_OUT 11 - CHARACTER*80 AUX 12 - CHARACTER*(*) F_IN,ACCESS 13 - INTEGER INPCMP,NC_IN,NC_OUT,IFAIL,I,J,INEXT,IEND,ICASE 14 - EXTERNAL INPCMP 15 - *** Identify the routine if requested. 16 - IF(LIDENT)PRINT *,' /// ROUTINE DSNFMT (Unix) ///' 17 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DSNFMT DEBUG : Input'', 18 - - '' file name: '',A,'' (length='',I3,'').'')') 19 - - F_IN(1:MAX(1,NC_IN)),NC_IN 20 - *** Initialisation. 21 - F_OUT=' ' 22 - NC_OUT=0 23 - IFAIL=0 24 - *** Loop over the input string. 25 - INEXT=1 26 - DO 10 I=1,NC_IN 27 - ** Skip parts already processed. 28 - IF(I.LT.INEXT)THEN 29 - GOTO 10 30 - ** Skip blanks. 31 - ELSEIF(F_IN(I:I).EQ.' ')THEN 32 - GOTO 10 33 - ** Look for back slashes (copy the next character literally). 34 - ELSEIF(F_IN(I:I).EQ.'\\')THEN 35 - IF(I+1.LT.NC_IN)THEN 36 - F_OUT(NC_OUT+1:NC_OUT+1)=F_IN(I+1:I+1) 37 - NC_OUT=NC_OUT+1 38 - INEXT=I+2 39 - ENDIF 40 - ** Look for an initial tilde. 41 - ELSEIF(F_IN(I:I).EQ.'~'.AND.NC_OUT.EQ.0)THEN 42 - * Get hold of the HOME environment variable. 43 - CALL GETENV('HOME',AUX) 44 - * Determine how the tilde should be interpreted. 45 - IF(I.GE.NC_IN)THEN 46 - ICASE=1 1 78 P=DATASET D=DSNFMTUX 2 PAGE 91 47 - ELSEIF(F_IN(I+1:I+1).NE.'/')THEN 48 - ICASE=2 49 - ELSE 50 - ICASE=1 51 - ENDIF 52 - * Get rid of blanks and copy the relevant part. 53 - DO 20 J=LEN(AUX),1,-1 54 - IF(AUX(J:J).NE.' ')THEN 55 - IF((ICASE.EQ.1.AND.NC_OUT+J.GT.LEN(F_OUT)).OR. 56 - - (ICASE.EQ.2.AND.NC_OUT+J+9.GT.LEN(F_OUT)))THEN 57 - PRINT *,' !!!!!! DSNFMT WARNING : Receiving'// 58 - - ' string to short for substitutions.' 59 - IFAIL=1 60 - RETURN 61 - ELSEIF(ICASE.EQ.1)THEN 62 - F_OUT=AUX(1:J) 63 - NC_OUT=J 64 - GOTO 10 65 - ELSE 66 - F_OUT=AUX(1:J)//'/../../'//F_IN(I+1:I+1)//'/' 67 - NC_OUT=J+9 68 - GOTO 10 69 - ENDIF 70 - ENDIF 71 - 20 CONTINUE 72 - * Warn if HOME is empty. 73 - PRINT *,' !!!!!! DSNFMT WARNING : The HOME environment'// 74 - - ' variable is blank or absent; tilde not substituted.' 75 - IFAIL=1 76 - ** Look for dollars. 77 - ELSEIF(F_IN(I:I).EQ.'$')THEN 78 - * Search for the end of the environment variable. 79 - DO 30 J=I+1,NC_IN 80 - IF(INDEX('/$ ',F_IN(J:J)).NE.0)THEN 81 - IF(J.LE.I+1)THEN 82 - PRINT *,' !!!!!! DSNFMT WARNING : No name found'// 83 - - ' between $ and delimiter ; no substitution.' 84 - IFAIL=1 85 - INEXT=J 86 - GOTO 10 87 - ELSE 88 - IEND=J-1 89 - INEXT=J 90 - GOTO 40 91 - ENDIF 92 - ENDIF 93 - 30 CONTINUE 94 - * If no end found, take until end of string. 95 - IF(NC_IN.LT.I+1)THEN 96 - PRINT *,' !!!!!! DSNFMT WARNING : No name found'// 97 - - ' between $ and end-of-string ; no substitution.' 98 - IFAIL=1 99 - INEXT=NC_IN+1 100 - GOTO 10 101 - ELSE 102 - IEND=NC_IN 103 - INEXT=NC_IN+1 104 - ENDIF 105 - * Retrieve the environment variable. 106 - 40 CONTINUE 107 - CALL GETENV(F_IN(I+1:IEND),AUX) 108 - * Get rid of blanks and copy the relevant bit. 109 - DO 50 J=LEN(AUX),1,-1 110 - IF(AUX(J:J).NE.' ')THEN 111 - IF(NC_OUT+J.GT.LEN(F_OUT))THEN 112 - PRINT *,' !!!!!! DSNFMT WARNING : Receiving'// 113 - - ' string too short for substitutions.' 114 - IFAIL=1 115 - RETURN 116 - ELSE 117 - F_OUT(NC_OUT+1:NC_OUT+J)=AUX(1:J) 118 - NC_OUT=NC_OUT+J 119 - GOTO 10 120 - ENDIF 121 - ENDIF 122 - 50 CONTINUE 123 - * Warn if the variable is empty or not known. 124 - PRINT *,' !!!!!! DSNFMT WARNING : The ', 125 - - F_IN(I+1:IEND),' environment variable is'// 126 - - ' blank or absent; not substituted.' 127 - IFAIL=1 128 - ** Anything else should simply be copied. 129 - ELSE 130 - IF(NC_OUT+1.GT.LEN(F_OUT))THEN 131 - PRINT *,' !!!!!! DSNFMT WARNING : Receiving'// 132 - - ' string to short to receive file name.' 133 - IFAIL=1 134 - RETURN 135 - ELSE 136 - F_OUT(NC_OUT+1:NC_OUT+1)=F_IN(I:I) 137 - NC_OUT=NC_OUT+1 138 - INEXT=I+1 139 - GOTO 10 140 - ENDIF 141 - ENDIF 142 - ** Next character. 143 - 10 CONTINUE 144 - *** Debugging output. 145 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DSNFMT DEBUG : Output'', 146 - - '' file name: '',A,'' (length='',I3,'').'')') 147 - - F_OUT(1:MAX(1,NC_OUT)),NC_OUT 148 - END 1 79 GARFIELD ================================================== P=DATASET D=DSNFMTVX 1 =================== PAGE 92 0 + +DECK,DSNFMTVX,IF=VAX. 1 - SUBROUTINE DSNFMT(F_IN,NC_IN,F_OUT,NC_OUT,ACCESS,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * DSNFMT - Searches for the full file name specification, taking the 4 - * default string into account. Checks whether two files match 5 - * the same wildcard. 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9 - CHARACTER*(MXNAME) F_OUT,F_DEFAULT 10 - CHARACTER*(*) F_IN,ACCESS 11 - INTEGER INPCMP 12 - EXTERNAL INPCMP 0 13-+ +SELF,IF=SAVE. 14 - SAVE F_DEFAULT,ITERMAX,NC_DEF 0 15-+ +SELF. 16 - DATA F_DEFAULT /'.DAT'/, ITERMAX /500/, NC_DEF /4/ 17 - *** Identify the routine if requested. 18 - IF(LIDENT)PRINT *,' /// ROUTINE DSNFMT (Vax) ///' 19 - *** Preset the IFAIL flag to 0, i.e. OK. 20 - IFAIL=0 21 - *** Make sure the response is always at least meaningful. 22 - F_OUT=F_IN 23 - NC_OUT=NC_IN 24 - *** Count how many files match. 25 - NFOUND=0 26 - CONTEXT=0 27 - 10 CONTINUE 28 - * Check status code searching for the next. 29 - IST=LIB$FIND_FILE(F_IN(1:NC_IN),F_OUT,CONTEXT, 30 - - F_DEFAULT(1:NC_DEF),,,) 31 - * If odd, file found. 32 - IF(IST.NE.2*INT(REAL(IST)/2.0))THEN 33 - NFOUND=NFOUND+1 34 - IF(NFOUND.GT.ITERMAX)THEN 35 - PRINT *,' !!!!!! DSNFMT WARNING : Number of'// 36 - - ' candidate files exceeds maximum; check'// 37 - - ' default file specification.' 38 - IFAIL=1 39 - RETURN 40 - ELSE 41 - GOTO 10 42 - ENDIF 43 - ENDIF 44 - * If even, last file seen: clear the buffer used to list the files. 45 - IST=LIB$FIND_FILE_END(CONTEXT) 46 - *** Check that there is precisely one file matching. 47 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DSNFMT DEBUG : Number of'', 48 - - '' files matching the wildcard: '',I3,''.'')') NFOUND 49 - IF(NFOUND.LE.1)THEN 50 - IFAIL=0 51 - DO 20 I=MXNAME,1,-1 52 - IF(F_OUT(I:I).NE.' ')THEN 53 - NC_OUT=I 54 - GOTO 100 55 - ENDIF 56 - 20 CONTINUE 57 - NC_OUT=1 58 - ELSEIF(NFOUND.GT.1)THEN 59 - WRITE(*,'(1X,A,I3,A/26X,A,A)') ' !!!!!! DSNFMT WARNING : ', 60 - - NFOUND,' files match the specification ',F_IN(1:NC_IN), 61 - - ' ; The file is marked as non-existing.' 62 - IFAIL=1 63 - F_OUT=' ' 64 - NC_OUT=1 65 - ENDIF 66 - *** End of this part. 67 - 100 CONTINUE 68 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DSNFMT DEBUG : Expanded'', 69 - - '' file name = '',A,'', failure flag = '',I2,''.'')') 70 - - F_OUT(1:NC_OUT),IFAIL 71 - RETURN 72 - *** Update of the default file specification. 73 - ENTRY DSNFMD 74 - * Figure out where the key is located. 75 - CALL INPNUM(NWORD) 76 - IF(INPCMP(1,'%').NE.0)THEN 77 - IKEY=2 78 - ELSE 79 - IKEY=1 80 - ENDIF 81 - * See whether this is an inquiry or an update. 82 - IF(IKEY.EQ.NWORD)THEN 83 - WRITE(LUNOUT,'(/1X,A/)') ' The current default file'// 84 - - ' specification is "'//F_DEFAULT(1:NC_DEF)//'".' 85 - ELSE 86 - CALL INPSTR(IKEY+1,IKEY+1,F_DEFAULT,NC_DEF) 87 - IF(NC_DEF.LE.0)THEN 88 - PRINT *,' !!!!!! DSNFMD WARNING : Null string not'// 89 - - ' acceptable as default; set to .DAT' 90 - F_DEFAULT='.DAT' 91 - NC_DEF=4 92 - ENDIF 93 - IF(LDEBUG)WRITE(LUNOUT,*) ' ++++++ DSNFMD DEBUG : New'// 94 - - ' default: '//F_DEFAULT(1:NC_DEF) 95 - ENDIF 96 - END 80 GARFIELD ================================================== P=DATASET D=DSNINP 1 ============================ 0 + +DECK,DSNINP. 1 - SUBROUTINE DSNINP 2 - *----------------------------------------------------------------------- 3 - * DSNINP - Handles dataset information requests like INDEX, LIST, 1 80 P=DATASET D=DSNINP 2 PAGE 93 4 - * DELETE etc. 5 - * VARIABLES : STRING : Used for various character manipulations. 6 - * FILE, MEMBER: Obvious. 7 - * EXFILE, EXMEMB: Indicate whether file resp memb exist. 8 - * LOOP : .TRUE. if one should remain in here. 9 - * (Last changed on 3/ 6/97.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,PRINTPLOT. 14 - CHARACTER*133 LINE 15 - CHARACTER*20 AUX1,AUX2 16 - CHARACTER*(MXCHAR) STRING,FILE 17 - CHARACTER*8 MEMBER,DELETE,TYPE 18 - CHARACTER CHAR 19 - LOGICAL EXMEMB,LOOP,LIST,MATMEM,MATTYP 20 - INTEGER NWORD,NC,IFAIL,IKEY,NCFILE,NCMEMB,NCTYPE,NMEMB,NMALL, 21 - - NPURGE,I,IOS,NC1,NC2,INPCMP 22 - EXTERNAL INPCMP 0 23-+ +SELF,IF=AST. 24 - EXTERNAL ASTCCH 0 25-+ +SELF. 26 - *** Identify the subroutine if requested. 27 - IF(LIDENT)PRINT *,' /// ROUTINE DSNINP ///' 28 - *** First pick up the number of words and the first word. 29 - CALL INPNUM(NWORD) 30 - CALL INPSTR(1,1,STRING,NC) 31 - *** Check it is a dataset command. 32 - IF(STRING(1:1).NE.'%')RETURN 33 - *** Determine whether it is a single command or not. 34 - IF(NWORD.EQ.1.AND.NC.EQ.1)THEN 35 - LOOP=.TRUE. 36 - PRINT *,' ' 37 - PRINT *,' ------------------------------------------------' 38 - PRINT *,' ---------- Dataset subsection ----------' 39 - PRINT *,' ------------------------------------------------' 40 - PRINT *,' ' 41 - CALL INPPRM('Dataset','ADD-PRINT') 42 - ELSE 43 - LOOP=.FALSE. 44 - ENDIF 45 - *** Return here if LOOP is .TRUE. 46 - 1000 CONTINUE 47 - IF(LOOP)THEN 48 - CALL INPGET 49 - CALL INPNUM(NWORD) 0 50-+ +SELF,IF=AST. 51 - *** Set up ASTCCH as the condition handler. 52 - CALL LIB$ESTABLISH(ASTCCH) 0 53-+ +SELF. 54 - ENDIF 55 - CALL INPSTR(1,1,STRING,NC) 56 - *** Skip blank lines and warn for section headers. 57 - IF(STRING(1:1).EQ.'&')THEN 58 - PRINT *,' !!!!!! DSNINP WARNING : The section cannot be'// 59 - - ' left at this point; first type EXIT.' 60 - GOTO 1000 61 - ELSEIF(INDEX('$!?><',STRING(1:1)).NE.0)THEN 62 - PRINT *,' !!!!!! DSNINP WARNING : This command cannot be'// 63 - - ' executed at the present level; first type EXIT.' 64 - GOTO 1000 65 - ELSEIF(STRING(1:1).EQ.'*')THEN 66 - GOTO 1000 67 - ENDIF 68 - IF(LOOP.AND.(NWORD.EQ.0.OR.(NWORD.EQ.1.AND.NC.EQ.1.AND. 69 - - STRING(1:1).EQ.'%')))GOTO 1000 70 - IF(.NOT.LOOP.AND.NC.EQ.1.AND.NWORD.EQ.1)RETURN 0 71-+ +SELF,IF=CMS,VAX. 72 - ** Look for file DEFAULTs. 73 - IF(INPCMP(1,'%DEF#AULT')+INPCMP(2,'DEF#AULT').NE.0)THEN 74 - CALL DSNFMD 75 - GOTO 1020 76 - ENDIF 0 77-+ +SELF. 78 - *** Prepare a help file if the command is PACK-HELP-FILE. 79 - IF(INPCMP(1,'%PAC#K-H#ELP-#FILE')+INPCMP(2,'PAC#K-H#ELP-#FILE') 80 - - .NE.0)THEN 0 81-+ +SELF,IF=APOLLO,CMS,UNIX,IF=HELP. 82 - CALL HLPPAC(IFAIL) 83 - IF(IFAIL.NE.0)PRINT *,' !!!!!! DSNINP WARNING : Packed'// 84 - - ' help file not produced.' 0 85-+ +SELF,IF=-HELP. 86 - PRINT *,' !!!!!! DSNINP WARNING : The help section has'// 87 - - ' not been compiled; command ignored.' 0 88-+ +SELF. 89 - GOTO 1020 90 - ENDIF 91 - *** Dump the help file if the command is DUMP-HELP-FILE. 92 - IF(INPCMP(1,'%DUMP-H#ELP-#FILE')+INPCMP(2,'DUMP-H#ELP-#FILE') 93 - - .NE.0)THEN 0 94-+ +SELF,IF=APOLLO,CMS,UNIX,IF=HELP. 95 - CALL HLPDEB 1 80 P=DATASET D=DSNINP 3 PAGE 94 96-+ +SELF,IF=VAX. 97 - PRINT *,' !!!!!! DSNINP WARNING : This command should'// 98 - - ' not be used on a Vax; command ignored.' 0 99-+ +SELF,IF=-HELP. 100 - PRINT *,' !!!!!! DSNINP WARNING : The help section has'// 101 - - ' not been compiled; command ignored.' 0 102-+ +SELF. 103 - GOTO 1020 104 - ENDIF 105 - *** Set the position of the command. 106 - IF(NC.EQ.1.AND.STRING(1:1).EQ.'%')THEN 107 - IKEY=2 108 - ELSE 109 - IKEY=1 110 - ENDIF 111 - *** Find the dataset and the member name. 112 - FILE=' ' 113 - MEMBER=' ' 114 - * Start with the dataset name, check it has been specified. 115 - IF(INPCMP(IKEY,'EX#IT')+INPCMP(IKEY,'%EX#IT').NE.0)THEN 116 - PRINT *,' ' 117 - PRINT *,' ------------------------------------------------' 118 - PRINT *,' ---------- Dataset subsection end ----------' 119 - PRINT *,' ------------------------------------------------' 120 - PRINT *,' ' 121 - CALL INPPRM(' ','BACK-PRINT') 122 - RETURN 123 - ELSEIF(IKEY+1.LE.NWORD)THEN 124 - CALL INPSTR(IKEY+1,IKEY+1,STRING,NC) 125 - FILE=STRING 126 - NCFILE=NC 127 - ELSE 128 - PRINT *,' !!!!!! DSNINP WARNING : All dataset commands'// 129 - - ' have a dataset name as first argument; ignored.' 130 - GOTO 1020 131 - ENDIF 132 - * Return immediately if the file does not exist or is corrupt. 133 - CALL DSNOPN(FILE,NCFILE,12,'RW-LIBRARY',IFAIL) 134 - IF(IFAIL.NE.0)THEN 135 - PRINT *,' !!!!!! DSNINP WARNING : '//FILE(1:NCFILE)// 136 - - ' could not be opened; no action.' 137 - GOTO 1020 138 - ENDIF 139 - * Next the member name, no checks except for length. 140 - IF(NWORD.GE.IKEY+2)THEN 141 - CALL INPSTR(IKEY+2,IKEY+2,STRING,NCMEMB) 142 - MEMBER=STRING 143 - IF(NCMEMB.GT.LEN(MEMBER))THEN 144 - PRINT *,' !!!!!! DSNINP WARNING : The member name '// 145 - - STRING(1:NCMEMB)//' is too long; truncated.' 146 - NCMEMB=LEN(MEMBER) 147 - ENDIF 148 - ELSE 149 - MEMBER='*' 150 - NCMEMB=1 151 - ENDIF 152 - * Finally the TYPE argument. 153 - IF(NWORD.GE.IKEY+3)THEN 154 - CALL INPSTR(IKEY+3,IKEY+3,STRING,NCTYPE) 155 - TYPE=STRING(1:NCTYPE) 156 - ELSE 157 - TYPE='*' 158 - NCTYPE=1 159 - ENDIF 160 - *** Identify the instruction, start with DELETE. 161 - IF(INPCMP(IKEY,'%DEL#ETE')+INPCMP(IKEY,'DEL#ETE')+ 162 - - INPCMP(IKEY,'%SCR#ATCH')+INPCMP(IKEY,'SCR#ATCH').NE.0)THEN 163 - IF(IKEY+2.GT.NWORD)THEN 164 - PRINT *,' !!!!!! DSNINP WARNING : A member must be'// 165 - - ' specified on a DELETE command.' 166 - GOTO 1010 167 - ENDIF 168 - * Read through the dataset and mark, then copy to scratch. 169 - EXMEMB=.FALSE. 0 170-+ +SELF,IF=CMS. 171 - CALL VMCMS('FILEDEF FT09F001 DISK GARFTEMP COPYFILE'// 172 - - ' (RECFM F LRECL 133',IRC) 0 173-+ +SELF. 174 - OPEN(UNIT=9,STATUS='SCRATCH',IOSTAT=IOS,ERR=2025) 175 - READ(12,'(A133)',IOSTAT=IOS,ERR=2010,END=110) LINE 176 - 100 CONTINUE 177 - READ(12,'(A133)',IOSTAT=IOS,ERR=2010,END=110) LINE 178 - IF(LINE(1:1).EQ.'%')THEN 179 - CALL WLDCRD(LINE(32:39),MEMBER(1:NCMEMB),.FALSE., 180 - - MATMEM) 181 - CALL WLDCRD(LINE(41:48),TYPE(1:NCTYPE),.FALSE., 182 - - MATTYP) 183 - ELSE 184 - MATMEM=.FALSE. 185 - MATTYP=.FALSE. 186 - ENDIF 187 - IF(LINE(1:1).EQ.'%'.AND.LINE(2:2).NE.'X'.AND. 188 - - MATMEM.AND.MATTYP)THEN 189 - EXMEMB=.TRUE. 190 - LINE(2:2)='X' 191 - PRINT *,' Member '//MEMBER(1:NCMEMB)//' of type '// 192 - - LINE(41:48)//' marked for deletion.' 193 - ENDIF 194 - WRITE(9,'(A133)',IOSTAT=IOS,ERR=2015) LINE 195 - GOTO 100 196 - 110 CONTINUE 197 - * Print an error message if the member has not been found. 1 80 P=DATASET D=DSNINP 4 PAGE 95 198 - IF(.NOT.EXMEMB)THEN 199 - PRINT *,' !!!!!! DSNINP WARNING : '//MEMBER(1:NCMEMB)// 200 - - ' does not exist or has already been deleted.' 201 - CALL DSNLOG(FILE,'% Search ','Sequential', 202 - - 'Read only ') 203 - ELSE 204 - * Close the file on unit 12, deleting it at the same time. 205 - CLOSE(UNIT=12,STATUS='DELETE',IOSTAT=IOS,ERR=2030) 206 - * Create a new file with the same name. 207 - CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) 208 - IF(IFAIL.EQ.1)THEN 209 - PRINT *,' ###### DSNINP ERROR : Unable to'// 210 - - ' create the file again ; dataset lost.' 0 211-+ +SELF,IF=CMS. 212 - PRINT *,' The data may'// 213 - - ' still be stored in GARFTEMP COPYFILE A.' 0 214-+ +SELF. 215 - CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) 216 - CALL DSNLOG(FILE,'% Delete ','Sequential', 217 - - 'Deleted !!') 218 - CALL DSNLOG('< intermediate file for copying >', 219 - - 'Dataset ','Sequential','Read/Write') 220 - GOTO 1020 221 - ENDIF 222 - * And copy the whole file back to the original file. 223 - REWIND(UNIT=9,IOSTAT=IOS,ERR=2055) 224 - 120 CONTINUE 225 - READ(9,'(A133)',IOSTAT=IOS,ERR=2015,END=130) LINE 226 - WRITE(12,'(A133)',IOSTAT=IOS,ERR=2010) LINE 227 - GOTO 120 228 - 130 CONTINUE 229 - CALL DSNLOG(FILE,'% Delete ','Sequential', 230 - - 'Read/Write') 231 - ENDIF 232 - * Close the scratch file and log its use. 233 - CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) 234 - CALL DSNLOG('< intermediate file for copying >', 235 - - 'Dataset ','Sequential','Read/Write') 236 - ** Look for the keyword DIRECTORY. 237 - ELSEIF(INPCMP(IKEY,'%DIR#ECTORY')+INPCMP(IKEY,'DIR#ECTORY')+ 238 - - INPCMP(IKEY,'%IND#EX')+INPCMP(IKEY,'IND#EX').NE.0)THEN 239 - * Print a heading for the table. 240 - WRITE(LUNOUT,'(/'' Index for '',A,//,'' Member '', 241 - - ''Type Date Time Deleted Remarks''/)') 242 - - FILE(1:NCFILE) 243 - * Read it record by record, printing if it's a header. 244 - NMEMB=0 245 - NMALL=0 246 - 10 CONTINUE 247 - READ(12,'(A1)',END=20,IOSTAT=IOS,ERR=2010) CHAR 248 - IF(CHAR.EQ.'%')THEN 249 - NMALL=NMALL+1 250 - BACKSPACE(UNIT=12,IOSTAT=IOS,ERR=2040) 251 - READ(12,'(A80)',END=20,IOSTAT=IOS,ERR=2010) STRING 252 - CALL WLDCRD(STRING(32:39),MEMBER(1:NCMEMB),.FALSE., 253 - - MATMEM) 254 - CALL WLDCRD(STRING(41:48),TYPE(1:NCTYPE),.FALSE., 255 - - MATTYP) 256 - IF(.NOT.(MATMEM.AND.MATTYP))GOTO 10 257 - NMEMB=NMEMB+1 258 - IF(STRING(2:2).EQ.'X')THEN 259 - DELETE='Yes ' 260 - ELSE 261 - DELETE='No ' 262 - ENDIF 263 - WRITE(LUNOUT,'(1X,5(1X,A8),1X,A29)') STRING(32:39), 264 - - STRING(41:48),STRING(11:18),STRING(23:30),DELETE, 265 - - STRING(51:79) 266 - ENDIF 267 - GOTO 10 268 - * Finished, close the unit, log access and print number of members. 269 - 20 CONTINUE 270 - CALL OUTFMT(REAL(NMALL),2,AUX1,NC1,'LEFT') 271 - CALL OUTFMT(REAL(NMEMB),2,AUX2,NC2,'LEFT') 272 - WRITE(LUNOUT,'(/'' Out of the '',A,'' members in the'', 273 - - '' file, '',A,'' match.'')') AUX1(1:NC1),AUX2(1:NC2) 274 - CALL DSNLOG(FILE,'% Index ','Sequential','Read only ') 275 - ** Look for the keyword LIST. 276 - ELSEIF(INPCMP(IKEY,'%L#IST')+INPCMP(IKEY,'L#IST')+ 277 - - INPCMP(IKEY,'%T#YPE')+INPCMP(IKEY,'T#YPE').NE.0)THEN 278 - * Read through the dataset, listing if LIST is on. 279 - EXMEMB=.FALSE. 280 - LIST=.FALSE. 281 - 200 CONTINUE 282 - READ(12,'(A133)',IOSTAT=IOS,ERR=2010,END=210) LINE 283 - IF(LIST)THEN 284 - IF(LINE(1:1).EQ.'%')GOTO 230 285 - DO 220 I=133,1,-1 286 - IF(LINE(I:I).NE.' ')THEN 287 - WRITE(LUNOUT,'(1X,A)') LINE(1:I) 288 - GOTO 230 289 - ENDIF 290 - 220 CONTINUE 291 - WRITE(LUNOUT,'('' '')') 292 - 230 CONTINUE 293 - ENDIF 294 - * Switch LIST on and off depending on the header records. 295 - IF(LINE(1:1).EQ.'%')THEN 296 - CALL WLDCRD(LINE(32:39),MEMBER(1:NCMEMB),.FALSE., 297 - - MATMEM) 298 - CALL WLDCRD(LINE(41:48),TYPE(1:NCTYPE),.FALSE., 299 - - MATTYP) 300 - ELSE 301 - MATMEM=.FALSE. 1 80 P=DATASET D=DSNINP 5 PAGE 96 302 - MATTYP=.FALSE. 303 - ENDIF 304 - IF(LINE(1:2).EQ.'% '.AND.MATMEM.AND.MATTYP)THEN 305 - EXMEMB=.TRUE. 306 - LIST=.TRUE. 307 - WRITE(LUNOUT,'('' Listing of member '',A8, 308 - - '' of type '',A8,'', created on '',A8, 309 - - '' at '',A8)') LINE(32:39),LINE(41:48), 310 - - LINE(11:18),LINE(23:30) 311 - IF(LINE(51:79).NE.' ')WRITE(LUNOUT,'('' Remarks: '', 312 - - A29)') LINE(51:79) 313 - WRITE(LUNOUT,'('' '')') 314 - ELSEIF(LINE(1:1).EQ.'%'.AND..NOT.MATMEM)THEN 315 - LIST=.FALSE. 316 - ENDIF 317 - GOTO 200 318 - 210 CONTINUE 319 - * Print an error message if the member has not been found. 320 - IF(.NOT.EXMEMB)THEN 321 - PRINT *,' !!!!!! DSNINP WARNING : '//MEMBER(1:NCMEMB)// 322 - - ' either does not exist or has been deleted.' 323 - CALL DSNLOG(FILE,'% Search ','Sequential', 324 - - 'Read only ') 325 - ELSE 326 - CALL DSNLOG(FILE,'% List ','Sequential', 327 - - 'Read only ') 328 - ENDIF 329 - ** Look for the keyword PURGE. 330 - ELSEIF(INPCMP(IKEY,'%PUR#GE')+INPCMP(IKEY,'PUR#GE')+INPCMP 331 - - (IKEY,'%COND#ENSE')+INPCMP(IKEY,'COND#ENSE').NE.0)THEN 332 - IF(NWORD.GT.IKEY+1)THEN 333 - PRINT *,' !!!!!! DSNINP WARNING : No member must be'// 334 - - ' specified on a PURGE command; do not mix up' 335 - PRINT *,' with DELETE, this'// 336 - - ' statement hurts ! (not executed).' 337 - GOTO 1010 338 - ENDIF 339 - * Read through the dataset copying the non-marked members. 0 340-+ +SELF,IF=CMS. 341 - CALL VMCMS('FILEDEF FT09F001 DISK GARFTEMP COPYFILE'// 342 - - ' (RECFM F LRECL 133',IRC) 0 343-+ +SELF. 344 - OPEN(UNIT=9,STATUS='SCRATCH',IOSTAT=IOS,ERR=2025) 345 - LIST=.TRUE. 346 - NPURGE=0 347 - READ(12,'(A133)',IOSTAT=IOS,ERR=2010,END=410) LINE 348 - 400 CONTINUE 349 - READ(12,'(A133)',IOSTAT=IOS,ERR=2010,END=410) LINE 350 - IF(LINE(1:1).EQ.'%'.AND.LINE(2:2).EQ.'X')THEN 351 - LIST=.FALSE. 352 - NPURGE=NPURGE+1 353 - PRINT *,' Removing member '//LINE(32:39)//' (type '// 354 - - LINE(41:48)//'),' 355 - PRINT *,' created on '//LINE(11:18)//' at '// 356 - - LINE(23:30)//', remarks: '//LINE(51:79) 357 - PRINT *,' ' 358 - ELSEIF(LINE(1:1).EQ.'%')THEN 359 - LIST=.TRUE. 360 - ENDIF 361 - IF(LIST)WRITE(9,'(A133)',IOSTAT=IOS,ERR=2015) LINE 362 - GOTO 400 363 - 410 CONTINUE 364 - IF(NPURGE.GT.0)THEN 365 - PRINT *,' A total of ',NPURGE,' members were removed.' 366 - ELSE 367 - PRINT *,' No members were marked for deletion.' 368 - ENDIF 369 - * Close the file on unit 12, deleting it at the same time. 370 - CLOSE(UNIT=12,STATUS='DELETE',IOSTAT=IOS,ERR=2030) 371 - * Create a new file with the same name. 372 - CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) 373 - IF(IFAIL.EQ.1)THEN 374 - PRINT *,' ###### DSNINP ERROR : Unable to'// 375 - - ' create the file again ; dataset lost.' 0 376-+ +SELF,IF=CMS. 377 - PRINT *,' The data might'// 378 - - ' still be stored in GARFTEMP COPYFILE A.' 0 379-+ +SELF. 380 - CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) 381 - CALL DSNLOG(FILE,'% Purge ','Sequential', 382 - - 'Deleted !!') 383 - CALL DSNLOG('< intermediate file for copying >', 384 - - 'Dataset ','Sequential','Read/Write') 385 - GOTO 1020 386 - ENDIF 387 - * And copy the whole file back to the original file. 388 - REWIND(UNIT=9,IOSTAT=IOS,ERR=2055) 389 - 420 CONTINUE 390 - READ(9,'(A133)',IOSTAT=IOS,ERR=2015,END=430) LINE 391 - WRITE(12,'(A133)',IOSTAT=IOS,ERR=2010) LINE 392 - GOTO 420 393 - 430 CONTINUE 394 - * Close the scratch file and log its use. 395 - CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) 396 - CALL DSNLOG('< intermediate file for copying >', 397 - - 'Dataset ','Sequential','Read/Write') 398 - CALL DSNLOG(FILE,'% Purge ','Sequential', 399 - - 'Read/Write') 400 - ** Look for the keyword RECOVER. 401 - ELSEIF(INPCMP(IKEY,'%REC#OVER')+INPCMP(IKEY,'REC#OVER')+ 402 - - INPCMP(IKEY,'%RES#CUE')+INPCMP(IKEY,'RES#CUE').NE.0)THEN 403 - IF(IKEY+2.GT.NWORD)THEN 1 80 P=DATASET D=DSNINP 6 PAGE 97 404 - PRINT *,' !!!!!! DSNINP WARNING : A member must be'// 405 - - ' specified on a RECOVER command.' 406 - GOTO 1010 407 - ENDIF 408 - * Read through the dataset and mark, then copy to scratch. 409 - EXMEMB=.FALSE. 0 410-+ +SELF,IF=CMS. 411 - CALL VMCMS('FILEDEF FT09F001 DISK GARFTEMP COPYFILE'// 412 - - ' (RECFM F LRECL 133',IRC) 0 413-+ +SELF. 414 - OPEN(UNIT=9,STATUS='SCRATCH',IOSTAT=IOS,ERR=2025) 415 - 300 CONTINUE 416 - READ(12,'(A133)',IOSTAT=IOS,ERR=2010,END=310) LINE 417 - IF(LINE(1:2).EQ.'%X')THEN 418 - CALL WLDCRD(LINE(32:39),MEMBER(1:NCMEMB),.FALSE., 419 - - MATMEM) 420 - CALL WLDCRD(LINE(41:48),TYPE(1:NCTYPE),.FALSE., 421 - - MATTYP) 422 - ELSE 423 - MATMEM=.FALSE. 424 - MATTYP=.FALSE. 425 - ENDIF 426 - IF(LINE(1:2).EQ.'%X'.AND.MATMEM.AND.MATTYP)THEN 427 - EXMEMB=.TRUE. 428 - LINE(2:2)=' ' 429 - PRINT *,' Member '//MEMBER(1:NCMEMB)//' of type '// 430 - - LINE(41:48)//' recovered.' 431 - ENDIF 432 - WRITE(9,'(A133)',IOSTAT=IOS,ERR=2015) LINE 433 - GOTO 300 434 - 310 CONTINUE 435 - * Print an error message if the member has not been found. 436 - IF(.NOT.EXMEMB)THEN 437 - PRINT *,' !!!!!! DSNINP WARNING : '//MEMBER(1:NCMEMB)// 438 - - ' does not exist or has already been recovered.' 439 - CALL DSNLOG(FILE,'% Search ','Sequential', 440 - - 'Read only ') 441 - ELSE 442 - * Close the file on unit 12, deleting it at the same time. 443 - CLOSE(UNIT=12,STATUS='DELETE',IOSTAT=IOS,ERR=2030) 444 - * Create a new file with the same name. 445 - CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) 446 - IF(IFAIL.EQ.1)THEN 447 - PRINT *,' ###### DSNINP ERROR : Unable to'// 448 - - ' create the file again ; dataset lost.' 0 449-+ +SELF,IF=CMS. 450 - PRINT *,' The data may'// 451 - - ' still be stored in GARFTEMP COPYFILE A.' 0 452-+ +SELF. 453 - CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) 454 - CALL DSNLOG(FILE,'% Recover ','Sequential', 455 - - 'Delete !!!') 456 - CALL DSNLOG('< intermediate file for copying >', 457 - - 'Dataset ','Sequential','Read/Write') 458 - GOTO 1020 459 - ENDIF 460 - * And copy the whole file back to the original file. 461 - REWIND(UNIT=9,IOSTAT=IOS,ERR=2055) 462 - 320 CONTINUE 463 - READ(9,'(A133)',IOSTAT=IOS,ERR=2015,END=330) LINE 464 - WRITE(12,'(A133)',IOSTAT=IOS,ERR=2010) LINE 465 - GOTO 320 466 - 330 CONTINUE 467 - CALL DSNLOG(FILE,'% Recover ','Sequential', 468 - - 'Read/Write') 469 - ENDIF 470 - * Close the scratch file and log its use. 471 - CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) 472 - CALL DSNLOG('< intermediate file for copying >', 473 - - 'Dataset ','Sequential','Read/Write') 474 - ** Keyword not known. 475 - ELSE 476 - CALL INPSTR(IKEY,IKEY,STRING,NC) 477 - PRINT *,' !!!!!! DSNINP WARNING : The instruction '// 478 - - STRING(1:NC)//' is not valid; ignored.' 479 - CALL DSNLOG(FILE,'% Illegal ','Open/Close','None ') 480 - ENDIF 481 - *** Close the I/O unit. 482 - 1010 CONTINUE 483 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 484 - 1020 CONTINUE 485 - IF(LOOP)GOTO 1000 486 - RETURN 487 - *** Handle error conditions. 488 - 2010 CONTINUE 489 - PRINT *,' ###### DSNINP ERROR : I/O error reading dataset'// 490 - - ' "'//FILE(1:NCFILE)//'" via LUN 12 ; attempt to close.' 491 - CALL INPIOS(IOS) 492 - GOTO 1010 493 - 2015 CONTINUE 494 - PRINT *,' !!!!!! DSNINP WARNING : I/O error to a temporary'// 495 - - ' file on LUN 9; operation not completed, attempt to close.' 496 - CALL INPIOS(IOS) 497 - CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) 498 - GOTO 1010 499 - 2025 CONTINUE 500 - PRINT *,' !!!!!! DSNINP WARNING : Error opening a temporary'// 501 - - ' file on LUN 12 ; operation not started.' 502 - CALL INPIOS(IOS) 503 - GOTO 1020 504 - 2030 CONTINUE 505 - PRINT *,' ###### DSNINP ERROR : Error closing '// 1 80 P=DATASET D=DSNINP 7 PAGE 98 506 - - FILE(1:NCFILE)//' on LUN 12 ; results unpredictable.' 507 - CALL INPIOS(IOS) 508 - GOTO 1020 509 - 2035 CONTINUE 510 - PRINT *,' !!!!!! DSNINP WARNING : Error closing a temporary'// 511 - - ' file on LUN 12 ; results unpredictable.' 512 - CALL INPIOS(IOS) 513 - GOTO 1020 514 - 2040 CONTINUE 515 - PRINT *,' ###### DSNINP ERROR : Error during backspace on '// 516 - - FILE(1:NCFILE)//', via LUN 12 ; attempt to close.' 517 - CALL INPIOS(IOS) 518 - GOTO 1010 519 - 2055 CONTINUE 520 - PRINT *,' !!!!!! DSNINP WARNING : Error during a rewind of a'// 521 - - ' temporary file on LUN 12 ; attempt to close.' 522 - CALL INPIOS(IOS) 523 - CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) 524 - GOTO 1010 525 - END 81 GARFIELD ================================================== P=DATASET D=DSNINQVM 1 ============================ 0 + +DECK,DSNINQVM,IF=CMS. 1 - SUBROUTINE DSNINQ(FILE,NC,EXIST) 2 - *----------------------------------------------------------------------- 3 - * DSNINQ - Determines on VM/CMS systems whether a file exists. 4 - * VARIABLES : FILE : The name of the file to be opened. 5 - * NC : Number of characters in FILE. 6 - * EXIST : .TRUE. if the file exists 7 - * (Last changed on 25/ 4/95.) 8 - *----------------------------------------------------------------------- 9 - CHARACTER*(*) FILE 10 - CHARACTER*1191 EXEC 11 - INTEGER NC 12 - LOGICAL EXIST 13 - *** Create the exec file. 14 - EXEC( 1: 550)= 15 - - '/* Origin: DSNINQ EXEC */Signal on Syntax;Signal on Nov'// 16 - - 'alue;Signal on Halt;Address Command;Arg file;fileout=""'// 17 - - ';last=".";ndot=0;Do i=1 To "LENGTH"(file);char="SUBSTR"'// 18 - - '(file,i,1);If char=" " Then Do;If last^="." Then last="'// 19 - - 'B";End;Else If char="." Then Do;fileout=fileout||".";nd'// 20 - - 'ot=ndot+1;last=".";End;Else Do;If last="B" Then Do;file'// 21 - - 'out=fileout||"."||char;ndot=ndot+1;End;Else;fileout=fil'// 22 - - 'eout||char;last="C";End;End;Parse var fileout fn"."ft".'// 23 - - '"fm"."junk;If ndot>2 Then;Say " !!!!!! DSNINQ EXECWRN :'// 24 - - ' Too many components in the file name; ignoring """junk' 25 - EXEC( 551:1100)= 26 - - '""".";If fn='''' | ft='''' Then Do;Say " !!!!!! DSNINQ '// 27 - - 'EXECWRN : Please specify at least file name and type; n'// 28 - - 'o inquiry done.";Exit 1;End;If fm='''' Then fm=''*'';"S'// 29 - - 'ET CMSTYPE HT";"MAKEBUF";n_old = "QUEUED"();"LISTFILE" '// 30 - - 'fn ft fm "(STACK FIFO ALL";rclist = rc;"SET CMSTYPE RT"'// 31 - - ';n_new = "QUEUED"();''DROPBUF'';If rclist = 24 Then Do;'// 32 - - 'Say " !!!!!! DSNINQ EXECWRN : Your file specification" '// 33 - - 'fn ft fm "contains an invalid character.";Exit 1;End;El'// 34 - - 'se If rclist = 36 Then Do;Say " !!!!!! DSNINQ EXECWRN :'// 35 - - ' No disk has been accessed under mode letter" "LEFT"(fm' 36 - EXEC(1101:1191)= 37 - - ',1)".";Exit 1;End;Else If rclist = 28 Then Do;Exit 1;En'// 38 - - 'd;Else;n_files = n_new-n_old;Exit 0;' 39 - *** Execute an EXEC file to do most of the job. 40 - CALL DSNVMX(EXEC,FILE(1:NC),IRC,IFAIL) 41 - *** Handle error conditions. 42 - IF(IFAIL.NE.0)THEN 43 - PRINT *,' !!!!!! DSNINQ WARNING : Failure to have the'// 44 - - ' REXX exec executed that checks VM files.' 45 - RETURN 46 - ENDIF 47 - *** Return code of EXEC is 0 for exist, 1 for non-existent. 48 - IF(IRC.NE.0)THEN 49 - EXIST=.FALSE. 50 - ELSE 51 - EXIST=.TRUE. 52 - ENDIF 53 - END 82 GARFIELD ================================================== P=DATASET D=DSNINQUX 1 ============================ 0 + +DECK,DSNINQUX,IF=UNIX. 1 - SUBROUTINE DSNINQ(FILE,NC,EXIST) 2 - *----------------------------------------------------------------------- 3 - * DSNINQ - Determines on Unix whether a file exists. 4 - * (Last changed on 18/ 4/96.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,PRINTPLOT. 8 - CHARACTER*(*) FILE 9 - CHARACTER*(MXNAME) F_OUT 10 - LOGICAL EXIST 11 - *** Identify the routine, if required. 12 - IF(LIDENT)PRINT *,' /// ROUTINE DSNINQ (Unix) ///' 13 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DSNINQ DEBUG : Input'', 14 - - '' file name: '',A,'' (length='',I3,'').'')') 15 - - FILE(1:MAX(1,NC)),NC 16 - *** Expand the file name. 17 - CALL DSNFMT(FILE,NC,F_OUT,NC_OUT,'ANY',IFAIL) 18 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DSNINQ DEBUG : Expanded'', 19 - - '' name: '',A,'' (length='',I3,'').'')') 20 - - F_OUT(1:MAX(1,NC_OUT)),NC_OUT 21 - IF(IFAIL.NE.0)THEN 22 - PRINT *,' !!!!!! DSNINQ WARNING : File name expansion'// 23 - - ' failed ; file declared non-existing.' 24 - EXIST=.FALSE. 25 - RETURN 1 82 P=DATASET D=DSNINQUX 2 PAGE 99 26 - ENDIF 27 - *** Now check existence. 28 - INQUIRE(FILE=F_OUT(1:NC_OUT),EXIST=EXIST) 29 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DSNINQ DEBUG : Exist='', 30 - - L1)') EXIST 31 - END 83 GARFIELD ================================================== P=DATASET D=DSNINQVX 1 ============================ 0 + +DECK,DSNINQVX,IF=VAX. 1 - SUBROUTINE DSNINQ(FILE,NC,EXIST) 2 - *----------------------------------------------------------------------- 3 - * DSNINQ - Determines on a Vax whether a file exists. 4 - * (Last changed on 25/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - CHARACTER*(*) FILE 7 - CHARACTER*255 F_OUT 8 - LOGICAL EXIST 9 - *** Count how many files match. 10 - NFOUND=0 11 - CONTEXT=0 12 - 10 CONTINUE 13 - * Check status code searching for the next. 14 - IST=LIB$FIND_FILE(FILE(1:NC),F_OUT,CONTEXT,,,,) 15 - * If odd, file found. 16 - IF(IST.NE.2*INT(REAL(IST)/2.0))THEN 17 - NFOUND=NFOUND+1 18 - GOTO 10 19 - ENDIF 20 - * If even, last file seen: clear the buffer used to list the files. 21 - IST=LIB$FIND_FILE_END(CONTEXT) 22 - *** Check that there is at least one file matching. 23 - IF(NFOUND.GT.0)THEN 24 - EXIST=.TRUE. 25 - ELSE 26 - EXIST=.FALSE. 27 - ENDIF 28 - END 84 GARFIELD ================================================== P=DATASET D=DSNINQOT 1 ============================ 0 + +DECK,DSNINQOT,IF=-CMS,IF=-UNIX,IF=-VAX. 1 - SUBROUTINE DSNINQ(FILE,NC,EXIST) 2 - *----------------------------------------------------------------------- 3 - * DSNINQ - Determines whether a file exists. 4 - * (Last changed on 25/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - CHARACTER*(*) FILE 7 - LOGICAL EXIST 8 - *** Issue an INQUIRE to find out whether the file exists. 9 - INQUIRE(FILE=FILE(1:NC),EXIST=EXIST) 10 - END 85 GARFIELD ================================================== P=DATASET D=DSNLOC 1 ============================ 0 + +DECK,DSNLOC. 1 - SUBROUTINE DSNLOC(MEMBER,NC,TYPE,LUN,EXIS,OPER) 2 - *----------------------------------------------------------------------- 3 - * DSNLOC - Places the pointer in a Garfield file on the header record 4 - * of the requested member. 5 - *----------------------------------------------------------------------- 6.- +SEQ,PRINTPLOT. 7 - CHARACTER*80 STRING 8 - CHARACTER CHAR 9 - CHARACTER*8 MEMBER,TYPE 10 - CHARACTER*(*) OPER 11 - LOGICAL EXIS,OPEN,MATCH 12 - *** Print some debugging information. 13 - IF(LIDENT)PRINT *,' /// ROUTINE DSNLOC ///' 14 - IF(LDEBUG)PRINT *,' ++++++ DSNLOC DEBUG : Request to locate ', 15 - - MEMBER(1:NC),' on unit ',LUN,' in mode ',OPER,'.' 16 - *** First set EXIS to .FALSE. ie not yet found. 17 - EXIS=.FALSE. 18 - *** Check that unit LUN is indeed open. 19 - INQUIRE(UNIT=LUN,OPENED=OPEN) 20 - IF(.NOT.OPEN)THEN 21 - PRINT *,' ###### DSNLOC ERROR : Unit ',LUN,' should be'// 22 - - ' open but is not; program bug, member not located.' 23 - RETURN 24 - ENDIF 25 - *** Rewind the file. 26 - REWIND(UNIT=LUN,ERR=2050,IOSTAT=IOS) 27 - *** Loop until EOF or until the member has been located. 28 - 10 CONTINUE 29 - READ(LUN,'(A1)',END=20,IOSTAT=IOS,ERR=2010) CHAR 30 - IF(CHAR.EQ.'%')THEN 31 - BACKSPACE(UNIT=LUN,IOSTAT=IOS,ERR=2040) 32 - READ(LUN,'(A80)',END=20,IOSTAT=IOS,ERR=2010) STRING 33 - IF(LDEBUG)PRINT *,' ++++++ DSNLOC DEBUG : Found member '// 34 - - STRING(32:39)//', type '//STRING(41:48)// 35 - - ', delete flag "'//STRING(2:2)//'".' 36 - * Skip members of the wrong type and deleted members unless IGNORE. 37 - IF((OPER.NE.'IGNORE'.AND.STRING(2:2).EQ.'X').OR. 38 - - STRING(41:48).NE.TYPE)GOTO 10 39 - * Wildcard check for the actual member name. 40 - CALL WLDCRD(STRING(32:39),MEMBER(1:NC),.FALSE.,MATCH) 41 - * Member found, make sure the next read sees the header and return. 42 - IF(MATCH)THEN 43 - EXIS=.TRUE. 44 - BACKSPACE(UNIT=LUN,IOSTAT=IOS,ERR=2040) 45 - RETURN 46 - ENDIF 47 - ENDIF 48 - * Next line. 49 - GOTO 10 50 - *** EOF seen on the dataset, member apparently not found. 1 85 P=DATASET D=DSNLOC 2 PAGE 100 51 - 20 CONTINUE 52 - REWIND(UNIT=LUN,IOSTAT=IOS,ERR=2050) 53 - RETURN 54 - *** Handle error conditions. 55 - 2010 CONTINUE 56 - PRINT *,' ###### DSNLOC ERROR : I/O error reading a dataset'// 57 - - ' for dataset manipulation via LUN ',LUN,'; no action.' 58 - CALL INPIOS(IOS) 59 - RETURN 60 - 2040 CONTINUE 61 - PRINT *,' ###### DSNLOC ERROR : Error during backspace on'// 62 - - ' a dataset connected to LUN ',LUN,' ; no action.' 63 - CALL INPIOS(IOS) 64 - RETURN 65 - 2050 CONTINUE 66 - PRINT *,' ###### DSNLOC ERROR : Error during rewind on'// 67 - - ' a dataset connected to LUN ',LUN,' ; no action.' 68 - CALL INPIOS(IOS) 69 - END 86 GARFIELD ================================================== P=DATASET D=DSNLOG 1 ============================ 0 + +DECK,DSNLOG. 1 - SUBROUTINE DSNLOG(DSNAME,TYPNAM,ACCESS,OPER) 2 - *----------------------------------------------------------------------- 3 - * DSNLOG - Routine accumulating data on dataset use (eg sceptre data- 4 - * sets) with an entry to print the data (DSNPRT). 5 - * VARIABLES : NAME : Line with information on the dataset. 6 - * LIST : List of the above descriptions. 7 - * ICOUNT : Counts the number of names entered. 8 - * ACCESS : Type of access, set by calling routine. 9 - * TYPNAM : Type of data, set by calling routine. 10 - * OPER : Type of operation carried out. 11 - * (Last changed on 17/ 3/92.) 12 - *----------------------------------------------------------------------- 13.- +SEQ,DIMENSIONS. 14 - CHARACTER*40 DSN 15 - CHARACTER*76 LIST(100) 16 - CHARACTER*(*) DSNAME 17 - CHARACTER*10 ACCESS,OPER,TYPNAM 0 18-+ +SELF,IF=SAVE. 19 - SAVE LIST,ICOUNT 0 20-+ +SELF. 21 - *** Initialise ICOUNT to 0. 22 - DATA ICOUNT/0/ 23 - *** Store the information, if there is still room for them. 24 - IF(ICOUNT.LT.100)THEN 25 - DSN=' ' 26 - DSN=DSNAME 27 - ICOUNT=ICOUNT+1 28 - LIST(ICOUNT)=DSN//' '//TYPNAM//' '//ACCESS//' '//OPER 29 - ENDIF 30 - *** Issue a warning if 100 datasets have been accessed 31 - IF(ICOUNT.EQ.100)THEN 32 - ICOUNT=101 33 - PRINT *,' !!!!!! DSNLOG WARNING : 100 Datasets have been'// 34 - - ' used ; further dataset information not stored.' 35 - ENDIF 36 - RETURN 37 - *** Print the list. 38 - ENTRY DSNPRT 39 - WRITE(*,'(''1'')') 40 - IF(ICOUNT.EQ.0)THEN 41 - PRINT *,' No data sets have been accessed.' 42 - RETURN 43 - ENDIF 44 - PRINT *,' The following datasets have been accessed:' 45 - PRINT *,' ==========================================' 46 - PRINT *,' ' 47 - PRINT *,' Dataset name Type ', 48 - - ' Access Operation ' 49 - PRINT *,' ' 50 - DO 10 J=1,MIN(ICOUNT,100) 51 - PRINT *,' ',LIST(J) 52 - 10 CONTINUE 53 - PRINT *,' ' 54 - PRINT *,' ' 55 - END 87 GARFIELD ================================================== P=DATASET D=DSNOPNVM 1 ============================ 0 + +DECK,DSNOPNVM,IF=CMS. 1 - SUBROUTINE DSNOPN(FILE,NC,LUNDSN,ACCESS,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * DSNOPN - Opens a file, version for VM/CMS systems. Uses REXX and 4 - * several HEPVM and CERN additional functions. 5 - * VARIABLES : FILE : The name of the file to be opened. 6 - * NC : Number of characters in FILE. 7 - * LUNDSN : The logical file number to open the file. 8 - * ACCESS : The type of access to the file. 9 - * (Last changed on 23/ 5/95.) 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,PRINTPLOT. 13 - CHARACTER*(*) FILE,ACCESS 14 - CHARACTER*6543 EXEC 15 - CHARACTER*80 ARG 16 - CHARACTER*(MXNAME) DSNDEF 17 - CHARACTER*9 ACTION 18 - INTEGER NC,LUNDSN,IFAIL 1 87 P=DATASET D=DSNOPNVM 2 PAGE 101 19-+ +SELF,IF=SAVE. 20 - SAVE DSNDEF,NCDEF 0 21-+ +SELF. 22 - DATA DSNDEF/'= INPUT ='/,NCDEF/9/ 23 - *** Create the exec file. 24 - EXEC( 1: 550)= 25 - - '/* Origin: DSNOPN EXEC */Signal on Syntax;Signal on Nov'// 26 - - 'alue;Signal on Halt;Address Command;"ID (LIFO";Pull acc'// 27 - - 'ount . node .;userid = "XNAME"("USERID");Arg file"/"fil'// 28 - - 'edef"/"lun"/"rw;fileout="";last=".";ndot=0;Do i=1 To "L'// 29 - - 'ENGTH"(file);char="SUBSTR"(file,i,1);If char=" " Then D'// 30 - - 'o;If last^="." Then last="B";End;Else If char="." Then '// 31 - - 'Do;fileout=fileout||".";ndot=ndot+1;last=".";End;Else D'// 32 - - 'o;If last="B" Then Do;fileout=fileout||"."||char;ndot=n'// 33 - - 'dot+1;End;Else;fileout=fileout||char;last="C";End;End;f'// 34 - - 'ile=fileout;fileout="";last=".";ndotdef=0;Do i=1 To "LE' 35 - EXEC( 551:1100)= 36 - - 'NGTH"(filedef);char="SUBSTR"(filedef,i,1);If char=" " T'// 37 - - 'hen Do;If last^="." Then last="B";End;Else If char="." '// 38 - - 'Then Do;fileout=fileout||".";ndotdef=ndotdef+1;last="."'// 39 - - ';End;Else Do;If last="B" Then Do;fileout=fileout||"."||'// 40 - - 'char;ndotdef=ndotdef+1;End;Else;fileout=fileout||char;l'// 41 - - 'ast="C";End;End;filedef=fileout;Parse var file fn"."ft"'// 42 - - '."fm"."junk;Parse var filedef fndef"."ftdef"."fmdef"."j'// 43 - - 'unkdef;If ndot>2 Then;Say " !!!!!! DSNOPN EXECWRN : Too'// 44 - - ' many components in the file name; ignoring """junk""".'// 45 - - '";If ndotdef>2 Then;Say " !!!!!! DSNOPN EXECWRN : Too m' 46 - EXEC(1101:1650)= 47 - - 'any components in the default file; ignoring """junkdef'// 48 - - '""".";lun = "STRIP"(lun,"B"); rw = "STRIP"(rw,"B");If r'// 49 - - 'w^="READ-FILE" & rw^="WRITE-FILE" & rw^="RW-FILE" & rw^'// 50 - - '="READ-LIBRARY" & rw^="WRITE-LIBRARY" & rw^="RW-LIBRARY'// 51 - - '" Then Do;Say " !!!!!! DSNOPN EXECWRN : Unknown access '// 52 - - 'description" rw "received.";Exit 1;End;If "DATATYPE"(lu'// 53 - - 'n)^= "NUM" | lun<0 | lun>99 Then Do;Say " !!!!!! DSNOPN'// 54 - - ' EXECWRN : Incorrect logical unit" lun "received.";Exit'// 55 - - ' 1;End;lun = "RIGHT"(lun,2,"0");If fn="" | fn="=" Then '// 56 - - 'fn=fndef;If ft="" | ft="=" Then ft=ftdef;If fm="" | fm=' 57 - EXEC(1651:2200)= 58 - - '"=" Then fm=fmdef;If fn="" | fn="=" Then fn="*";If ft="'// 59 - - '" | ft="=" Then ft="*";If fm="" | fm="=" Then Do;If "LE'// 60 - - 'FT"(rw,5)="WRITE" | "LEFT"(rw,2)="RW" Then;fm = "QDISK"'// 61 - - '("RW","MODE");Else;fm = "*";End;If "INDEX"(fn ft fm,"*"'// 62 - - ')+"INDEX"(fn ft fm,"%")>0 Then;wildcard = 1;Else;wildca'// 63 - - 'rd = 0;n_old = "QUEUED"();"SET CMSTYPE HT";"MAKEBUF";"L'// 64 - - 'ISTFILE" fn ft fm "(STACK FIFO ALL";rclist = rc;"SET CM'// 65 - - 'STYPE RT";n_new = "QUEUED"();If rclist = 24 Then Do;Say'// 66 - - ' " !!!!!! DSNOPN EXECWRN : Your file specification" fn '// 67 - - 'ft fm "contains an invalid character.";"DROPBUF";Exit 1' 68 - EXEC(2201:2750)= 69 - - ';End;Else If rclist = 36 Then Do;Say " !!!!!! DSNOPN EX'// 70 - - 'ECWRN : No disk has been accessed under mode letter" "L'// 71 - - 'EFT"(fm,1)".";"DROPBUF";Exit 1;End;Else If rclist = 28 '// 72 - - '& wildcard Then Do;Say " !!!!!! DSNOPN EXECWRN : No fil'// 73 - - 'e found that matches" fn ft fm"; no file opened.";"DROP'// 74 - - 'BUF";Exit 1;End;Else If rclist = 28 Then;n_files = 0;El'// 75 - - 'se;n_files = n_new-n_old;If n_files>1 Then;Say " ------'// 76 - - ' DSNOPN EXECMSG :" n_files "files match your wildcard" '// 77 - - 'fn ft fm".";found = 0;n_OK = 0;Do i=1 To n_files;Pull f'// 78 - - 'nr ftr fmr recfm lrecl .;If (lrecl>500 & rw="READ-FILE"' 79 - EXEC(2751:3300)= 80 - - ') | ((recfm^="F" | lrecl<133) & "RIGHT"(rw,7)="LIBRARY"'// 81 - - ') Then Do;Say " ------ DSNOPN EXECMSG : File" fnr ftr f'// 82 - - 'mr "does not have the right format.";Iterate;End;If ("L'// 83 - - 'EFT"(rw,5)="WRITE" | "LEFT"(rw,2)="RW") & "QDISK"(fmr,"'// 84 - - 'ACCESS")^="RW" Then Do;Say " ------ DSNOPN EXECMSG : Yo'// 85 - - 'u do not have write access to" fnr ftr fmr".";Iterate;E'// 86 - - 'nd;If ^found Then Do;fn = fnr;ft = ftr;fm = fmr;found ='// 87 - - ' 1;End;n_OK = n_OK + 1;End;"DROPBUF";If n_OK=0 & n_file'// 88 - - 's>0 Then Do;Say " !!!!!! DSNOPN EXECWRN : At least one '// 89 - - 'file matches but no useable file found; no file opened.' 90 - EXEC(3301:3850)= 91 - - '";Exit 1;End;Else If n_OK=0 & "LEFT"(rw,4)="READ" Then '// 92 - - 'Do;Say " !!!!!! DSNOPN EXECWRN : The file" fn ft fm "ha'// 93 - - 's not been found; not opened for read access.";Exit 1;E'// 94 - - 'nd;Else If n_OK=0 & ("LEFT"(rw,5)="WRITE" | "LEFT"(rw,2'// 95 - - ')="RW") & "QDISK"(fm,"ACCESS")^="RW" Then Do;Say " !!!!'// 96 - - '!! DSNOPN EXECWRN : You do not have write access to you'// 97 - - 'r" "LEFT"(fm,1) "disk; no file opened.";Exit 1;End;If w'// 98 - - 'ildcard Then Do;If n_files=1 & n_OK=1 Then;Say " ------'// 99 - - ' DSNOPN EXECMSG : Only" fn ft fm "matches your wildcard'// 100 - - '.";Else If n_files>1 & n_OK=1 Then;Say " ------ DSNOPN ' 101 - EXEC(3851:4400)= 102 - - 'EXECMSG : The only suitable file matching your wildcard'// 103 - - ' is" fn ft fm".";Else If n_files=n_OK Then;Say " ------'// 104 - - ' DSNOPN EXECMSG : All" n_files "are suitable, selecting'// 105 - - '" fn ft fm".";Else;Say " ------ DSNOPN EXECMSG : Only" '// 106 - - 'n_OK "are suitable, selecting" fn ft fm".";End;If "FEXI'// 107 - - 'ST"(fn ft fm) Then Do;filestat = "QFILE"(fn ft fm,"STAT'// 108 - - 'US");If filestat^="N" Then Do;If filestat="R" Then;Say '// 109 - - '" ------ DSNOPN EXECMSG : File" fn ft fm "is currently '// 110 - - 'being read; not opened.";Else If filestat="W" Then;Say '// 111 - - '" ------ DSNOPN EXECMSG : File" fn ft fm "is currently ' 112 - EXEC(4401:4950)= 113 - - 'being written; not opened.";Else;Say " ------ DSNOPN EX'// 114 - - 'ECMSG : File" fn ft fm "is currently being accessed ("f'// 115 - - 'ilestat"); not opened.";Exit 1;End;End;If "QDISK"(fm,"M'// 116 - - 'ODIFIED") Then Do;"SET CMSTYPE HT";address="QDISK"(fm,"'// 117 - - 'ADDRESS");"EXEC RELEASE" "LEFT"(fm,1);"ACCESS" address '// 118 - - '"LEFT"(fm,1);"SET CMSTYPE RT";Say " ------ DSNOPN EXECM'// 119 - - 'SG : Your" "LEFT"(fm,1) "disk has been reaccessed becau'// 120 - - 'se the disk has been modified.";End;If n_OK=0 & (rw="WR'// 121 - - 'ITE-LIBRARY" | rw="RW-LIBRARY") Then Do;aux = "* This G'// 122 - - 'arfield library has been created by user" userid"@"node' 123 - EXEC(4951:5500)= 1 87 P=DATASET D=DSNOPNVM 3 PAGE 102 124 - - ' "on" "DATE"("E") "at" "TIME"()".";Push "LEFT"(aux,132,'// 125 - - '" ")||"*";"EXECIO 1 DISKW" fn ft fm "1 F 133 (FINIS";If'// 126 - - ' rc=0 Then;Say " ------ DSNOPN EXECMSG : Library" fn ft'// 127 - - ' fm "has been created.";Else Do;Say " !!!!!! DSNOPN EXE'// 128 - - 'CWRN : Error writing a header record for library" fn ft'// 129 - - ' fm".";Exit 1;End;End;If n_OK=0 & rw="RW-FILE" Then Do;'// 130 - - 'aux = "* This file has been created by user" userid"@"n'// 131 - - 'ode "on" "DATE"("E") "at" "TIME"()".";Push "LEFT"(aux,1'// 132 - - '32," ")||"*";"EXECIO 1 DISKW" fn ft fm "1 V (FINIS";If '// 133 - - 'rc^=0 Then Do;Say " !!!!!! DSNOPN EXECWRN : Error writi' 134 - EXEC(5501:6050)= 135 - - 'ng a header record for file" fn ft fm".";Exit 1;End;End'// 136 - - ';If rw="WRITE-FILE" Then Do;If n_OK>0 Then Do;If "FEXIS'// 137 - - 'T"(fn "LEFT"("OLD"||ft,8) fm) Then "ERASE" fn "LEFT"("O'// 138 - - 'LD"||ft,8) fm;"RENAME" fn ft fm fn "LEFT"("OLD"||ft,8) '// 139 - - 'fm;End;aux = "* This file has been created by user" use'// 140 - - 'rid"@"node "on" "DATE"("E") "at" "TIME"()".";Push "LEFT'// 141 - - '"(aux,132," ")||"*";"EXECIO 1 DISKW" fn ft fm "1 V (FIN'// 142 - - 'IS";If rc^=0 Then Do;Say " !!!!!! DSNOPN EXECWRN : Erro'// 143 - - 'r writing a header record for file" fn ft fm".";Exit 1;'// 144 - - 'End;End;If rw="WRITE-FILE" | rw="RW-FILE" Then Do;"FILE' 145 - EXEC(6051:6543)= 146 - - 'DEF FT"lun"F001 CLEAR";"FILEDEF FT"lun"F001 DISK" fn ft'// 147 - - ' fm "(RECFM V";End;Else Do;"FILEDEF FT"lun"F001 CLEAR";'// 148 - - '"FILEDEF FT"lun"F001 DISK" fn ft fm;End;Exit;SYNTAX:;Sa'// 149 - - 'y " ###### DSNOPN EXECERR : Syntax error at line" sigl '// 150 - - '"; program bug, please report.";Exit 1;NOVALUE:;Say " #'// 151 - - '##### DSNOPN EXECERR : Unitialised variable at line" si'// 152 - - 'gl "; program bug, please report.";Exit 1;HALT:;Say " -'// 153 - - '----- DSNOPN EXECMSG : You have interrupted the executi'// 154 - - 'on of the file opening exec, no file opened.";Exit 1;' 155 - *** Write the argument string for the exec. 156 - WRITE(ARG,'(A,''/'',A,''/'',I3,''/'',A)') FILE(1:NC), 157 - - DSNDEF(1:NCDEF),LUNDSN,ACCESS 158 - *** Execute an EXEC file to do most of the job. 159 - CALL DSNVMX(EXEC,ARG,IRC,IFAIL) 160 - *** Handle error conditions. 161 - IF(IFAIL.NE.0)THEN 162 - PRINT *,' !!!!!! DSNOPN WARNING : Failure to have the'// 163 - - ' REXX exec executed that opens VM files.' 164 - RETURN 165 - ENDIF 166 - *** Make an ACTION string. 167 - IF(ACCESS(1:2).EQ.'RW'.OR.ACCESS(1:5).EQ.'WRITE')THEN 168 - ACTION='READWRITE' 169 - ELSEIF(ACCESS(1:4).EQ.'READ')THEN 170 - ACTION='READ' 171 - ELSE 172 - PRINT *,' !!!!!! DSNOPN WARNING : Invalid access type'// 173 - - ' received '//ACCESS//'; program bug.' 174 - RETURN 175 - ENDIF 176 - *** FILEDEF has already been issued, now also open the file. 177 - IF(IRC.EQ.0.AND.ACCESS.EQ.'READ-FILE')THEN 178 - OPEN(UNIT=LUNDSN,ERR=2020,FORM='UNFORMATTED',ACTION=ACTION) 179 - IF(LDEBUG)PRINT *,' ++++++ DSNOPN DEBUG : Unit ',LUNDSN, 180 - - ' opened for unformatted ',ACTION 181 - ELSEIF(IRC.EQ.0)THEN 182 - OPEN(UNIT=LUNDSN,ERR=2020,ACTION=ACTION) 183 - IF(LDEBUG)PRINT *,' ++++++ DSNOPN DEBUG : Unit ',LUNDSN, 184 - - ' opened for formatted ',ACTION 185 - ENDIF 186 - *** Move to the end of the file is library output is to be performed. 187 - IF(IRC.EQ.0.AND.(ACCESS.EQ.'WRITE-LIBRARY'.OR. 188 - - ACCESS.EQ.'WRITE-FILE'.OR.ACCESS.EQ.'RW-FILE'))THEN 189 - 100 CONTINUE 190 - READ(LUNDSN,'()',END=110,ERR=2010,IOSTAT=IOS) 191 - GOTO 100 192 - 110 CONTINUE 193 - BACKSPACE(LUNDSN,ERR=2040,IOSTAT=IOS) 194 - ENDIF 195 - *** Pass a non-zero exec rc on to the calling routine as an error. 196 - IF(IRC.NE.0)THEN 197 - IFAIL=1 198 - ELSE 199 - IFAIL=0 200 - ENDIF 201 - *** Normal end of the routine. 202 - RETURN 203 - *** Entry point for default handling. 204 - ENTRY DSNFMD 205 - * Figure out where the key is located. 206 - CALL INPNUM(NWORD) 207 - IF(INPCMP(1,'%').NE.0)THEN 208 - IKEY=2 209 - ELSE 210 - IKEY=1 211 - ENDIF 212 - * See whether this is an inquiry or an update. 213 - IF(NWORD.GT.IKEY+3)PRINT *,' !!!!!! DSNFMD WARNING : Too'// 214 - - ' many arguments; excess ignored.' 215 - IF(IKEY.EQ.NWORD)THEN 216 - WRITE(LUNOUT,'(/1X,A/)') ' The current default file'// 217 - - ' specification is '//DSNDEF(1:NCDEF)//'.' 218 - ELSE 219 - CALL INPSTR(IKEY+1,NWORD,DSNDEF,NCDEF) 220 - IF(LDEBUG)WRITE(LUNOUT,*) ' ++++++ DSNFMD DEBUG : New'// 221 - - ' default: '//DSNDEF(1:NCDEF)//'.' 222 - ENDIF 223 - RETURN 224 - *** Error handling. 225 - 2010 CONTINUE 226 - PRINT *,' !!!!!! DSNOPN WARNING : Reading error while'// 227 - - ' attempting to skip to the end of file.' 228 - CALL INPIOS(IOS) 229 - IFAIL=1 1 87 P=DATASET D=DSNOPNVM 4 PAGE 103 230 - RETURN 231 - 2020 CONTINUE 232 - PRINT *,' !!!!!! DSNOPN WARNING : Error while opening'// 233 - - ' your file.' 234 - CALL INPIOS(IOS) 235 - IFAIL=1 236 - RETURN 237 - 2040 CONTINUE 238 - PRINT *,' !!!!!! DSNOPN WARNING : Backspace error while'// 239 - - ' attempting to skip to the end of file.' 240 - CALL INPIOS(IOS) 241 - IFAIL=1 242 - END 88 GARFIELD ================================================== P=DATASET D=DSNOPNUX 1 ============================ 0 + +DECK,DSNOPNUX,IF=UNIX. 1 - SUBROUTINE DSNOPN(DSNAME,NCDSN,LUNDSN,ACCESS,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * DSNOPN - Opens a file. 4 - * VARIABLES : FILE/DSNAME : The name of the file to be opened. 5 - * NC/NCDSN : Number of characters in FILE. 6 - * LUNDSN : The logical file number to open the file. 7 - * ACCESS : The type of access to the file. 8 - * (Last changed on 6/ 3/00.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,PRINTPLOT. 13 - CHARACTER*(*) DSNAME,ACCESS 14 - CHARACTER*1 STRING 15 - LOGICAL EXBACK 16 - LOGICAL OPEN,EXIS 17 - CHARACTER*(MXNAME) FILE 18 - INTEGER NC,NCDSN,LUNDSN,IFAIL,IOS 19 - *** Identify the routine if requested. 20 - IF(LIDENT)PRINT *,' /// ROUTINE DSNOPN (Unix) ///' 21 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DSNOPN DEBUG : Request'', 22 - - '' to open '',A/26X,''on unit '',I2,'' with access '',A)') 23 - - DSNAME(1:NCDSN),LUNDSN,ACCESS 24 - *** Initialise IFAIL to 1. 25 - IFAIL=1 26 - *** Check that the unit is closed. 27 - INQUIRE(UNIT=LUNDSN,OPENED=OPEN) 28 - IF(OPEN)THEN 29 - PRINT *,' !!!!!! DSNOPN WARNING : Unit ',LUNDSN,' is'// 30 - - ' found to be open ; attempt to close it.' 31 - CLOSE(UNIT=LUNDSN,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 32 - ENDIF 33 - *** Perform subsitutions of environment variables. 34 - CALL DSNFMT(DSNAME,NCDSN,FILE,NC,'ANY',IFAIL) 35 - IF(IFAIL.NE.0)THEN 36 - PRINT *,' !!!!!! DSNOPN WARNING : The file is not opened'// 37 - - ' because of the above error.' 38 - RETURN 39 - ENDIF 40 - *** Store the file existence flag. 41 - INQUIRE(FILE=FILE(1:NC),EXIST=EXIS) 42 - IF((.NOT.EXIS).AND. 43 - - (ACCESS(1:4).EQ.'READ'.OR.ACCESS(1:2).EQ.'RW'))THEN 44 - PRINT *,' !!!!!! DSNOPN WARNING : The file '//FILE(1:NC)// 45 - - ' has not been found; not opened.' 46 - IFAIL=1 47 - RETURN 48 - ENDIF 49 - *** Check that the file is not open. 50 - INQUIRE(FILE=FILE(1:NC),OPENED=OPEN) 51 - IF(OPEN)THEN 52 - PRINT *,' !!!!!! DSNOPN WARNING : The file '//FILE(1:NC)// 53 - - ' is already open; no access given.' 54 - IFAIL=1 55 - RETURN 56 - ENDIF 57 - *** Open the dataset. 58 - IF(INDEX(ACCESS,'WRITE').NE.0)THEN 59 - * If an output file, shift previous copies. 60 - IF(INDEX(ACCESS,'FILE').NE.0.AND.EXIS)THEN 61 - INQUIRE(FILE=FILE(1:NC)//'.bak',EXIST=EXBACK) 62 - IF(EXBACK)CALL system('rm '//FILE(1:NC)//'.bak') 63 - CALL system('mv '//FILE(1:NC)//' '//FILE(1:NC)//'.bak') 64 - OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='NEW', 65 - - ACCESS='SEQUENTIAL',FORM='FORMATTED', 66 - - IOSTAT=IOS,ERR=2020) 67 - EXIS=.FALSE. 68 - * If a binary output file, shift previous copies. 69 - ELSEIF(INDEX(ACCESS,'BINARY').NE.0.AND.EXIS)THEN 70 - INQUIRE(FILE=FILE(1:NC)//'.bak',EXIST=EXBACK) 71 - IF(EXBACK)CALL system('rm '//FILE(1:NC)//'.bak') 72 - CALL system('mv '//FILE(1:NC)//' '//FILE(1:NC)//'.bak') 73 - OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='NEW', 74 - - ACCESS='SEQUENTIAL',FORM='UNFORMATTED', 75 - - IOSTAT=IOS,ERR=2020) 76 - EXIS=.FALSE. 77 - * Otherwise skip to the end of the file if it exist. 78 - ELSEIF(EXIS)THEN 79 - OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='OLD', 80 - - ACCESS='SEQUENTIAL',IOSTAT=IOS,ERR=2020) 81 - 100 CONTINUE 82 - READ(LUNDSN,'(A1)',END=110,IOSTAT=IOS,ERR=2010) STRING 83 - GOTO 100 84 - 110 CONTINUE 85 - BACKSPACE(UNIT=LUNDSN,IOSTAT=IOS,ERR=2040) 86 - * Or open a new file if it didn't yet exist. 87 - ELSEIF(INDEX(ACCESS,'BINARY').NE.0)THEN 88 - OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='NEW', 89 - - ACCESS='SEQUENTIAL',FORM='UNFORMATTED', 1 88 P=DATASET D=DSNOPNUX 2 PAGE 104 90 - - IOSTAT=IOS,ERR=2020) 91 - ELSE 92 - OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='NEW', 93 - - ACCESS='SEQUENTIAL',FORM='FORMATTED', 94 - - IOSTAT=IOS,ERR=2020) 95 - ENDIF 96 - * Open for non-binary read or read/write access. 97 - ELSEIF(INDEX(ACCESS,'BINARY').EQ.0)THEN 98 - OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='UNKNOWN', 99 - - ACCESS='SEQUENTIAL',FORM='FORMATTED', 100 - - IOSTAT=IOS,ERR=2020) 101 - * Open for binary read or read/write access. 102 - ELSE 103 - OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='UNKNOWN', 104 - - ACCESS='SEQUENTIAL',FORM='UNFORMATTED', 105 - - IOSTAT=IOS,ERR=2020) 106 - ENDIF 107 - *** Write a first record on the dataset if it is new. 108 - IF((.NOT.EXIS).AND. 109 - - INDEX(ACCESS,'BINARY').EQ.0.AND. 110 - - INDEX(ACCESS,'FILE').EQ.0.AND. 111 - - INDEX(ACCESS,'WRITE')+INDEX(ACCESS,'RW').NE.0) 112 - - WRITE(LUNDSN,'(''*----.----1----.----2----.----3'', 113 - - ''----.----4----.----5----.----6----.----7----.----8----.'', 114 - - ''----9----.---10----.---11----.---12----.---13--'')', 115 - - IOSTAT=IOS,ERR=2015) 116 - IF(LDEBUG)PRINT *,' ++++++ DSNOPN DEBUG : Dataset '// 117 - - FILE(1:NC)//' opened on unit ',LUNDSN,'.' 118 - *** Everything looks all right, set IFAIL to 0 (OK) and return. 119 - IFAIL=0 120 - RETURN 121 - *** Handle I/O problems. 122 - 2010 CONTINUE 123 - PRINT *,' ###### DSNOPN ERROR : Error while skipping to'// 124 - - ' the end of the file '//FILE(1:NC)//'.' 125 - CALL INPIOS(IOS) 126 - IFAIL=1 127 - RETURN 128 - 2015 CONTINUE 129 - PRINT *,' ###### DSNOPN ERROR : Failure to write a heading'// 130 - - ' record to the new file '//FILE(1:NC)//'.' 131 - CALL INPIOS(IOS) 132 - IFAIL=1 133 - RETURN 134 - 2020 CONTINUE 135 - PRINT *,' ###### DSNOPN ERROR : Failure to open '//FILE(1:NC)// 136 - - ' on unit ',LUNDSN 137 - CALL INPIOS(IOS) 138 - IFAIL=1 139 - RETURN 140 - 2030 CONTINUE 141 - PRINT *,' !!!!!! DSNOPN WARNING : I/O problem when closing'// 142 - - ' an unknown file on unit ',LUNDSN 143 - CALL INPIOS(IOS) 144 - IFAIL=1 145 - RETURN 146 - 2040 CONTINUE 147 - PRINT *,' ###### DSNOPN ERROR : Backspace at the end of the'// 148 - - ' file '//FILE(1:NC)//' failed.' 149 - CALL INPIOS(IOS) 150 - IFAIL=1 151 - END 89 GARFIELD ================================================== P=DATASET D=DSNOPNOT 1 ============================ 0 + +DECK,DSNOPNOT,IF=APOLLO,MVS,VAX. 1 - SUBROUTINE DSNOPN(DSNAME,NCDSN,LUNDSN,ACCESS,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * DSNOPN - Opens a file. 4 - * VARIABLES : FILE/DSNAME : The name of the file to be opened. 5 - * NC/NCDSN : Number of characters in FILE. 6 - * LUNDSN : The logical file number to open the file. 7 - * ACCESS : The type of access to the file. 8 - * (Last changed on 2/ 3/00.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,PRINTPLOT. 13 - CHARACTER*(*) DSNAME,ACCESS 0 14-+ +SELF,IF=APOLLO. 15 - CHARACTER*1 STRING 0 16-+ +SELF. 17 - LOGICAL OPEN,EXIS 18 - CHARACTER*(MXNAME) FILE 19 - INTEGER NC,NCDSN,LUNDSN,IFAIL,IOS 20 - *** Identify the routine if requested. 21 - IF(LIDENT)PRINT *,' /// ROUTINE DSNOPN ///' 22 - *** Initialise IFAIL to 1. 23 - IFAIL=1 24 - *** Check that the unit is closed. 25 - INQUIRE(UNIT=LUNDSN,OPENED=OPEN) 26 - IF(OPEN)THEN 27 - PRINT *,' !!!!!! DSNOPN WARNING : Unit ',LUNDSN,' is'// 28 - - ' found to be open ; attempt to close it.' 29 - CLOSE(UNIT=LUNDSN,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 30 - ENDIF 0 31-+ +SELF,IF=VAX. 32 - *** Get the complete Vax file name. 33 - CALL DSNFMT(DSNAME,NCDSN,FILE,NC,'ANY',IFAIL) 34 - IF(IFAIL.NE.0)THEN 35 - PRINT *,' !!!!!! DSNOPN WARNING : The file is not opened'// 36 - - ' because of the above error.' 37 - RETURN 1 89 P=DATASET D=DSNOPNOT 2 PAGE 105 38 - ENDIF 0 39-+ +SELF,IF=-VAX. 40 - *** Simply copy. 41 - FILE=DSNAME 42 - NC=NCDSN 0 43-+ +SELF. 44 - *** Store the file existence flag. 45 - INQUIRE(FILE=FILE(1:NC),EXIST=EXIS) 46 - IF((.NOT.EXIS).AND. 47 - - (ACCESS(1:4).EQ.'READ'.OR.ACCESS(1:2).EQ.'RW'))THEN 48 - PRINT *,' !!!!!! DSNOPN WARNING : The file '//FILE(1:NC)// 49 - - ' has not been found; not opened.' 50 - IFAIL=1 51 - RETURN 52 - ENDIF 53 - *** Check that the file is not open. 54 - INQUIRE(FILE=FILE(1:NC),OPENED=OPEN) 55 - IF(OPEN)THEN 56 - PRINT *,' !!!!!! DSNOPN WARNING : The file '//FILE(1:NC)// 57 - - ' is already open; no access given.' 58 - IFAIL=1 59 - RETURN 60 - ENDIF 61 - *** Open the dataset. 62 - IF(ACCESS(1:5).EQ.'WRITE')THEN 0 63-+ +SELF,IF=VAX. 64 - IF(ACCESS(7:10).EQ.'FILE')THEN 65 - IF(INDEX(FILE(1:NC),';').GE.2) 66 - - NC=INDEX(FILE(1:NC),';')-1 67 - OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='NEW', 68 - - ACCESS='SEQUENTIAL',IOSTAT=IOS,ERR=2020) 69 - ELSE 70 - OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='UNKNOWN', 71 - - ACCESS='APPEND',IOSTAT=IOS,ERR=2020) 72 - ENDIF 0 73-+ +SELF,IF=APOLLO. 74 - OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='UNKNOWN', 75 - - ACCESS='SEQUENTIAL',IOSTAT=IOS,ERR=2020) 76 - IF(EXIS)THEN 77 - 100 CONTINUE 78 - READ(LUNDSN,'(A1)',END=110,IOSTAT=IOS,ERR=2010) STRING 79 - GOTO 100 80 - 110 CONTINUE 81 - ENDIF 0 82-+ +SELF,IF=VAX. 83 - ELSEIF(ACCESS(1:4).EQ.'READ')THEN 84 - OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='UNKNOWN', 85 - - ACCESS='SEQUENTIAL',READONLY,IOSTAT=IOS,ERR=2020) 0 86-+ +SELF. 87 - ELSE 88 - OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='UNKNOWN', 89 - - ACCESS='SEQUENTIAL',IOSTAT=IOS,ERR=2020) 90 - ENDIF 91 - *** Write a first record on the dataset if it is new. 92 - IF((.NOT.EXIS).AND. 93 - - (ACCESS(1:5).EQ.'WRITE'.OR.ACCESS(1:2).EQ.'RW')) 94 - - WRITE(LUNDSN,'(''*----.----1----.----2----.----3'', 95 - - ''----.----4----.----5----.----6----.----7----.----8----.'', 96 - - ''----9----.---10----.---11----.---12----.---13--'')', 97 - - IOSTAT=IOS,ERR=2015) 98 - IF(LDEBUG)PRINT *,' ++++++ DSNOPN DEBUG : Dataset '// 99 - - FILE(1:NC)//' opened on unit ',LUNDSN,'.' 100 - *** Everything looks all right, set IFAIL to 0 (OK) and return. 101 - IFAIL=0 102 - RETURN 103 - *** Handle I/O problems. 0 104-+ +SELF,IF=-VAX. 105 - 2010 CONTINUE 106 - PRINT *,' ###### DSNOPN ERROR : Error while skipping to'// 107 - - ' the end of the file '//FILE(1:NC)//'.' 108 - CALL INPIOS(IOS) 109 - IFAIL=1 110 - RETURN 0 111-+ +SELF. 112 - 2015 CONTINUE 113 - PRINT *,' ###### DSNOPN ERROR : Failure to write a heading'// 114 - - ' record to the new file '//FILE(1:NC)//'.' 115 - CALL INPIOS(IOS) 116 - IFAIL=1 117 - RETURN 118 - 2020 CONTINUE 119 - PRINT *,' ###### DSNOPN ERROR : Failure to open '//FILE(1:NC)// 120 - - ' on unit ',LUNDSN 121 - CALL INPIOS(IOS) 122 - IFAIL=1 123 - RETURN 124 - 2030 CONTINUE 125 - PRINT *,' !!!!!! DSNOPN WARNING : I/O problem when closing'// 126 - - ' an unknown file on unit ',LUNDSN 127 - CALL INPIOS(IOS) 128 - IFAIL=1 129 - RETURN 0 130-+ +SELF,IF=-APOLLO,IF=-VAX. 131 - 2040 CONTINUE 132 - PRINT *,' ###### DSNOPN ERROR : Backspace at the end of the'// 133 - - ' file '//FILE(1:NC)//' failed.' 134 - CALL INPIOS(IOS) 1 89 P=DATASET D=DSNOPNOT 3 PAGE 106 135 - IFAIL=1 0 136-+ +SELF. 137 - END 90 GARFIELD ================================================== P=DATASET D=DSNREM 1 ============================ 0 + +DECK,DSNREM. 1 - SUBROUTINE DSNREM(FILE,MEMBER,TYPE,EXMEMB) 2 - *----------------------------------------------------------------------- 3 - * DSNREM - Checks whether a member already exists when writing a new 4 - * one and marks the old member for deletion if required. 5 - * VARIABLES : FILE : File name 6 - * MEMBER : Member name 7 - * TYPE : Member type 8 - * (Last changed on 30/ 8/97.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,PRINTPLOT. 13 - CHARACTER*(*) FILE,MEMBER,TYPE 14 - CHARACTER*133 LINE 15 - INTEGER NCFILE,NCMEMB,NCTYPE,IFAIL,IOS 16 - LOGICAL EXIST,MATMEM,MATTYP,EXMEMB 17 - *** Assume that the member does not exist. 18 - EXMEMB=.FALSE. 19 - *** Establish the lengths of the various strings. 20 - NCFILE=LEN(FILE) 21 - NCMEMB=LEN(MEMBER) 22 - NCTYPE=LEN(TYPE) 23 - *** See whether the file exists. 24 - CALL DSNINQ(FILE,NCFILE,EXIST) 25 - * If the file doesn't exist, don't do anything else. 26 - IF(.NOT.EXIST)RETURN 27 - *** Open the file. 28 - CALL DSNOPN(FILE,NCFILE,12,'READ-LIBRARY',IFAIL) 29 - IF(IFAIL.NE.0)THEN 30 - PRINT *,' !!!!!! DSNREM WARNING : Unable to open ', 31 - - FILE(1:NCFILE),'; not checked for existing members.' 32 - RETURN 33 - ENDIF 34 - *** Open a temporary file if "delete old copy" has been selected. 35 - IF(JEXMEM.EQ.1)THEN 0 36-+ +SELF,IF=CMS. 37 - CALL VMCMS('FILEDEF FT09F001 DISK GARFTEMP COPYFILE'// 38 - - ' (RECFM F LRECL 133',IRC) 0 39-+ +SELF. 40 - OPEN(UNIT=9,STATUS='SCRATCH',IOSTAT=IOS,ERR=2020) 41 - ENDIF 42 - *** Read through the dataset and mark, then copy to scratch. 43 - READ(12,'(A133)',IOSTAT=IOS,ERR=2010,END=110) LINE 44 - 100 CONTINUE 45 - READ(12,'(A133)',IOSTAT=IOS,ERR=2010,END=110) LINE 46 - IF(LINE(1:1).EQ.'%')THEN 47 - CALL WLDCRD(LINE(32:39),MEMBER(1:NCMEMB),.FALSE., 48 - - MATMEM) 49 - CALL WLDCRD(LINE(41:48),TYPE(1:NCTYPE),.FALSE., 50 - - MATTYP) 51 - ELSE 52 - MATMEM=.FALSE. 53 - MATTYP=.FALSE. 54 - ENDIF 55 - IF(LINE(1:1).EQ.'%'.AND.LINE(2:2).NE.'X'.AND. 56 - - MATMEM.AND.MATTYP.AND.JEXMEM.EQ.1)THEN 57 - LINE(2:2)='X' 58 - EXMEMB=.TRUE. 59 - PRINT *,' Member ',MEMBER(1:NCMEMB),' written on '// 60 - - LINE(11:18)//' at '//LINE(23:30)//' has been'// 61 - - ' marked for deletion.' 62 - ELSEIF(LINE(1:1).EQ.'%'.AND.LINE(2:2).NE.'X'.AND. 63 - - MATMEM.AND.MATTYP.AND.(JEXMEM.EQ.2.OR.JEXMEM.EQ.3))THEN 64 - EXMEMB=.TRUE. 65 - PRINT *,' !!!!!! DSNREM WARNING : A member called ', 66 - - MEMBER(1:NCMEMB),' was already written on '// 67 - - LINE(11:18)//' at '//LINE(23:30)//'.' 68 - ENDIF 69 - IF(JEXMEM.EQ.1)WRITE(9,'(A133)',IOSTAT=IOS,ERR=2015) LINE 70 - GOTO 100 71 - 110 CONTINUE 72 - *** Copy the file from unit 9 to unit 12, after deleting old copy. 73 - IF(JEXMEM.EQ.1)THEN 74 - CLOSE(UNIT=12,STATUS='DELETE',IOSTAT=IOS,ERR=2030) 75 - * Create a new file with the same name. 76 - CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) 77 - IF(IFAIL.EQ.1)THEN 78 - PRINT *,' ###### DSNREM ERROR : Unable to'// 79 - - ' create the file again ; dataset lost.' 0 80-+ +SELF,IF=CMS. 81 - PRINT *,' The data may'// 82 - - ' still be stored in GARFTEMP COPYFILE A.' 0 83-+ +SELF. 84 - CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) 85 - CALL DSNLOG(FILE,'Cleanup ','Sequential', 86 - - 'File lost') 87 - CALL DSNLOG('< intermediate file for copying >', 88 - - 'Cleanup ','Sequential','Read/Write') 89 - RETURN 90 - ENDIF 91 - * And copy the whole file back to the original file. 92 - REWIND(UNIT=9,IOSTAT=IOS,ERR=2055) 93 - 120 CONTINUE 94 - READ(9,'(A133)',IOSTAT=IOS,ERR=2015,END=130) LINE 1 90 P=DATASET D=DSNREM 2 PAGE 107 95 - WRITE(12,'(A133)',IOSTAT=IOS,ERR=2010) LINE 96 - GOTO 120 97 - 130 CONTINUE 98 - * Close the main file. 99 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 100 - CALL DSNLOG(FILE,'Cleanup ','Sequential', 101 - - 'Read/Write') 102 - * Close the scratch file and log its use. 103 - CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) 104 - CALL DSNLOG('< intermediate file for copying >', 105 - - 'Cleanup ','Sequential','Read/Write') 106 - *** Or simply close the file. 107 - ELSE 108 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 109 - CALL DSNLOG(FILE,'Check ','Sequential', 110 - - 'Read/Write') 111 - ENDIF 112 - RETURN 113 - *** Handle I/O errors. 114 - 2010 CONTINUE 115 - PRINT *,' !!!!!! DSNREM WARNING : Read/write error on ', 116 - - FILE(1:NCFILE),'; no check for existing members.' 117 - CALL INPIOS(IOS) 118 - CLOSE(12,IOSTAT=IOS,ERR=2030) 119 - RETURN 120 - 2015 CONTINUE 121 - PRINT *,' !!!!!! DSNREM WARNING : Read/write error on a'// 122 - - ' temporary file ; no check for existing members.' 123 - CALL INPIOS(IOS) 124 - CLOSE(9,IOSTAT=IOS,ERR=2035) 125 - RETURN 126 - 2020 CONTINUE 127 - PRINT *,' !!!!!! DSNREM WARNING : Error opening a temporary'// 128 - - ' file for copying; no check for existing members.' 129 - CALL INPIOS(IOS) 130 - RETURN 131 - 2030 CONTINUE 132 - PRINT *,' !!!!!! DSNREM WARNING : File closing error on ', 133 - - FILE(1:NCFILE),'; no check for existing members.' 134 - CALL INPIOS(IOS) 135 - RETURN 136 - 2035 CONTINUE 137 - PRINT *,' !!!!!! DSNREM WARNING : File closing error on a', 138 - - ' temporary file; no check for existing members.' 139 - CALL INPIOS(IOS) 140 - RETURN 141 - 2055 CONTINUE 142 - PRINT *,' !!!!!! DSNREM WARNING : Rewind error on a', 143 - - ' temporary file; no check for existing members.' 144 - CLOSE(9,IOSTAT=IOS,ERR=2035) 145 - CALL INPIOS(IOS) 146 - RETURN 147 - END 91 GARFIELD ================================================== P=DATASET D=DSNVMX 1 ============================ 0 + +DECK,DSNVMX,IF=CMS. 1 - SUBROUTINE DSNVMX(EXEC,ARG,IRC,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * DSNVMX - Executes a REXX exec file. 4 - *----------------------------------------------------------------------- 5 - LOGICAL OPEN 6 - CHARACTER*(*) EXEC,ARG 7 - CHARACTER*80 FILDEF 8 - *** Assume for now that the routine will fail. 9 - IFAIL=1 10 - *** Check unit 12 is closed. 11 - INQUIRE(UNIT=12,OPENED=OPEN) 12 - IF(OPEN)THEN 13 - PRINT *,' !!!!!! DSNVMX WARNING : Unit 12 found to be'// 14 - - ' open, trying to close.' 15 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 16 - ENDIF 17 - *** Check existence of previous versions of GARFTEMP EXEC. 18 - CALL VMCMS('STATE GARFTEMP EXEC A',IRC) 19 - IF(IRC.NE.28)CALL VMCMS('ERASE GARFTEMP EXEC A',IRC) 20 - *** Write the EXEC to disk. 21 - CALL VMCMS('FILEDEF 12 CLEAR',IRC) 22 - WRITE(FILDEF,'(''FILEDEF 12 DISK GARFTEMP EXEC (RECFM F'', 23 - - '' LRECL '',I4)') LEN(EXEC) 24 - CALL VMCMS(FILDEF,IRC) 25 - IF(IRC.NE.0)THEN 26 - PRINT *,' !!!!!! DSNVMX WARNING : Non-zero return code'// 27 - - ' for the EXEC writing FILEDEF; no file opened.' 28 - RETURN 29 - ENDIF 30 - OPEN(UNIT=12,ERR=2020,IOSTAT=IOS) 31 - WRITE(12,'(A)',ERR=2010,IOSTAT=IOS) EXEC 32 - CLOSE(UNIT=12,ERR=2030,IOSTAT=IOS) 33 - *** Execute the EXEC. 34 - CALL VMCMS('EXEC GARFTEMP '//ARG(1:LEN(ARG)),IRC) 35 - *** Erase the EXEC. 36 - CALL VMCMS('ERASE GARFTEMP EXEC A',JRC) 37 - *** Successfull completion. 38 - IFAIL=0 39 - RETURN 40 - *** Error handling. 41 - 2010 CONTINUE 42 - PRINT *,' !!!!!! DSNVMX WARNING : I/O error writing a'// 43 - - ' temporary exec to disk.' 44 - CALL INPIOS(IOS) 45 - RETURN 46 - 2020 CONTINUE 47 - PRINT *,' !!!!!! DSNVMX WARNING : I/O error opening a'// 48 - - ' temporary exec.' 49 - CALL INPIOS(IOS) 1 91 P=DATASET D=DSNVMX 2 PAGE 108 50 - RETURN 51 - 2030 CONTINUE 52 - PRINT *,' !!!!!! DSNVMX WARNING : I/O error closing a'// 53 - - ' temporary exec.' 54 - CALL INPIOS(IOS) 55 - END 92 GARFIELD ================================================== P=ALGEBRA D= 1 ============================ 0 + +PATCH,ALGEBRA. 93 GARFIELD ================================================== P=ALGEBRA D=ALGCAL 1 ============================ 0 + +DECK,ALGCAL. 1 - SUBROUTINE ALGCAL(INSTR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * ALGCAL - Handles external CALL statements in instruction lists. 4 - * (Last changed on 21/ 1/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,ALGDATA. 10.- +SEQ,CONSTANTS. 11.- +SEQ,MATDATA. 12.- +SEQ,GLOBALS. 13 - CHARACTER*(MXINCH) STRING 14 - CHARACTER*80 TITLE,FILE 15 - CHARACTER*29 REMARK 16 - CHARACTER*8 MEMBER,TYPE,DATE,TIME 17 - REAL PAR(MXFPAR),EPAR(MXFPAR),K3 18 - LOGICAL EXIST 19 - INTEGER INSTR,IFAIL,IFAIL1,IFAIL2,IFAIL3,I,IAUX,NARG,IPROC,NC, 20 - - NC1,NCFILE,NCTYPE,NCREM,NCMEMB,MATSLT,ISY,IREY,ISEY, 21 - - ISIZ(1),IOS,NPAR,IA(MXVAR),IE(MXVAR) 22 - EXTERNAL MATSLT 23 - *** Assume the CALL will fail. 24 - IFAIL=1 25 - *** Ensure the statement is a legitimate CALL. 26 - IF(INS(INSTR,2).NE.9.OR. 27 - - INS(INSTR,3).LT.0.OR.INS(INSTR,3).GT.MXARG)THEN 28 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGCAL DEBUG : '', 29 - - '' Syntax of CALL statement '',I3,'' not valid'')') 30 - - INSTR 31 - RETURN 32 - ENDIF 33 - *** Some easy reference variables. 34 - NARG=INS(INSTR,3) 35 - IPROC=INS(INSTR,1) 36 - *** Execute the statements, first PRINT. 37 - IF(IPROC.EQ.-1)THEN 38 - WRITE(LUNOUT,'(/'' PRINT: ''/)') 39 - DO 10 I=1,NARG 40 - CALL OUTFMT(ARG(I),MODARG(I),STRING,NC,'LEFT') 41 - WRITE(LUNOUT,'('' Arg '',I3,'': '',A)') I,STRING(1:NC) 42 - 10 CONTINUE 43 - IF(NARG.EQ.0)WRITE(LUNOUT,'('' No arguments.'')') 44 - *** Cell procedures. 45 - ELSEIF(IPROC.LE.-11.AND.IPROC.GT.-20)THEN 46 - CALL CELCAL(INSTR,IFAIL1) 47 - IF(IFAIL1.NE.0)THEN 48 - PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// 49 - - ' a cell procedure call.' 50 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 51 - RETURN 52 - ELSE 53 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 54 - ENDIF 55 - *** Gas procedures. 56 - ELSEIF(IPROC.LE.-201.AND.IPROC.GT.-300)THEN 57 - CALL GASCAL(INSTR,IFAIL1) 58 - IF(IFAIL1.NE.0)THEN 59 - PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// 60 - - ' a gas procedure call.' 61 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 62 - RETURN 63 - ELSE 64 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 65 - ENDIF 66 - *** Electric field procedures. 67 - ELSEIF(IPROC.LE.-301.AND.IPROC.GE.-400)THEN 68 - CALL EFCCAL(INSTR,IFAIL1) 69 - IF(IFAIL1.NE.0)THEN 70 - PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// 71 - - ' a field procedure call.' 72 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 73 - RETURN 74 - ELSE 75 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 76 - ENDIF 77 - *** Time and progress logging. 78 - ELSEIF(IPROC.EQ.-401)THEN 79 - IF(NARG.NE.1.OR.MODARG(1).NE.1)THEN 80 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect'// 81 - - ' argument for TIME_LOGGING.' 82 - ELSE 83 - CALL STRBUF('READ',NINT(ARG(1)),STRING,NC1,IFAIL1) 84 - CALL TIMLOG(STRING(1:NC1)) 85 - ENDIF 86 - *** Drift line procedures. 87 - ELSEIF(IPROC.LE.-501.AND.IPROC.GE.-600)THEN 88 - CALL DLCCAL(INSTR,IFAIL1) 89 - IF(IFAIL1.NE.0)THEN 90 - PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// 91 - - ' a drift line procedure call.' 92 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 1 93 P=ALGEBRA D=ALGCAL 2 PAGE 109 93 - RETURN 94 - ELSE 95 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 96 - ENDIF 97 - *** Histogram procedures. 98 - ELSEIF(IPROC.LE.-601.AND.IPROC.GT.-700)THEN 99 - CALL HISCAL(INSTR,IFAIL1) 100 - IF(IFAIL1.NE.0)THEN 101 - PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// 102 - - ' a histogram procedure call.' 103 - RETURN 104 - ENDIF 105 - *** Utility procedures. 106 - ELSEIF(IPROC.LE.-701.AND.IPROC.GT.-800)THEN 107 - CALL ROUCAL(INSTR,IFAIL1) 108 - IF(IFAIL1.NE.0)THEN 109 - PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// 110 - - ' a procedure call.' 111 - RETURN 112 - ENDIF 113 - *** Plotting calls. 114 - ELSEIF(IPROC.LE.-801.AND.IPROC.GE.-900)THEN 115 - CALL GRACAL(INSTR,IFAIL1) 116 - IF(IFAIL1.NE.0)THEN 117 - PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// 118 - - ' a graphics procedure call.' 119 - RETURN 120 - ENDIF 121 - *** String calls. 122 - ELSEIF(IPROC.LE.-901.AND.IPROC.GE.-1000)THEN 123 - CALL STRCAL(INSTR,IFAIL1) 124 - IF(IFAIL1.NE.0)THEN 125 - PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// 126 - - ' a string procedure call.' 127 - RETURN 128 - ENDIF 129 - *** Determine type of a variable. 130 - ELSEIF(IPROC.EQ.-50)THEN 131 - * Check arguments. 132 - IF(NARG.NE.2.OR.ARGREF(2,1).GE.2)THEN 133 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect set'// 134 - - ' of arguments for INQUIRE_TYPE.' 135 - RETURN 136 - ENDIF 137 - * Set string depending on the argument type. 138 - IF(MODARG(1).EQ.1)THEN 139 - STRING='String' 140 - NC=6 141 - ELSEIF(MODARG(1).EQ.2)THEN 142 - STRING='Number' 143 - NC=6 144 - ELSEIF(MODARG(1).EQ.3)THEN 145 - STRING='Logical' 146 - NC=7 147 - ELSEIF(MODARG(1).EQ.4)THEN 148 - STRING='Histogram' 149 - NC=9 150 - ELSEIF(MODARG(1).EQ.5)THEN 151 - STRING='Matrix' 152 - NC=6 153 - ELSEIF(MODARG(1).EQ.0)THEN 154 - STRING='Undefined' 155 - NC=9 156 - ELSE 157 - STRING='# Invalid' 158 - NC=9 159 - ENDIF 160 - * Store the string. 161 - CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) 162 - CALL STRBUF('STORE',IAUX,STRING(1:NC),NC,IFAIL1) 163 - ARG(2)=REAL(IAUX) 164 - MODARG(2)=1 165 - * Error processing. 166 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! ALGCAL WARNING : Unable'// 167 - - ' to store the variable type.' 168 - *** Determine whether a file exists. 169 - ELSEIF(IPROC.EQ.-51)THEN 170 - * Check arguments. 171 - IF(NARG.NE.2.OR.ARGREF(2,1).GE.2.OR.MODARG(1).NE.1)THEN 172 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect set'// 173 - - ' of arguments for INQUIRE_FILE.' 174 - RETURN 175 - ENDIF 176 - * Fetch the file name. 177 - CALL STRBUF('READ',NINT(ARG(1)),FILE,NCFILE,IFAIL1) 178 - * Determine whether the file exists. 179 - IF(IFAIL1.EQ.0)THEN 180 - CALL DSNINQ(FILE,NCFILE,EXIST) 181 - ELSE 182 - PRINT *,' !!!!!! ALGCAL WARNING : Unable'// 183 - - ' to fetch the file name.' 184 - EXIST=.FALSE. 185 - ENDIF 186 - * Clear the storage space previously occupied by Arg 2. 187 - CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) 188 - * Set the result. 189 - IF(EXIST)THEN 190 - ARG(2)=1 191 - ELSE 192 - ARG(2)=0 193 - ENDIF 194 - MODARG(2)=3 195 - *** Determine whether a member exists. 196 - ELSEIF(IPROC.EQ.-52)THEN 197 - * Check arguments. 198 - IF(NARG.LT.4.OR.NARG.GT.7.OR. 1 93 P=ALGEBRA D=ALGCAL 3 PAGE 110 199 - - MODARG(1).NE.1.OR.MODARG(2).NE.1.OR.MODARG(3).NE.1.OR. 200 - - ARGREF(4,1).GE.2.OR. 201 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. 202 - - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. 203 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2))THEN 204 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect set'// 205 - - ' of arguments for INQUIRE_MEMBER.' 206 - RETURN 207 - ENDIF 208 - * Fetch the file, member and type. 209 - CALL STRBUF('READ',NINT(ARG(1)),FILE,NCFILE,IFAIL1) 210 - CALL STRBUF('READ',NINT(ARG(2)),MEMBER,NCMEMB,IFAIL2) 211 - CALL STRBUF('READ',NINT(ARG(3)),TYPE,NCTYPE,IFAIL3) 212 - CALL CLTOU(TYPE) 213 - * Preset the remark, date and time. 214 - REMARK='< none >' 215 - NCREM=8 216 - DATE='Unknown' 217 - TIME='Unknown' 218 - * Determine whether the file exists. 219 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN 220 - CALL DSNINQ(FILE,NCFILE,EXIST) 221 - ELSE 222 - PRINT *,' !!!!!! ALGCAL WARNING : Unable to fetch'// 223 - - ' file, member or type; declared not to exist.' 224 - EXIST=.FALSE. 225 - ENDIF 226 - * Open the file and see whether the member exists. 227 - IF(EXIST)THEN 228 - CALL DSNOPN(FILE,NCFILE,12,'READ-LIBRARY',IFAIL1) 229 - IF(IFAIL1.NE.0)THEN 230 - PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// 231 - - ' open the file; declared not to exist.' 232 - EXIST=.FALSE. 233 - ELSE 234 - CALL DSNLOC(MEMBER,NCMEMB,TYPE,12,EXIST,'RESPECT') 235 - IF(EXIST)THEN 236 - READ(12,'(10X,A8,4X,A8,1X,A8,11X,A29,1X)', 237 - - END=2000,ERR=2010,IOSTAT=IOS) 238 - - DATE,TIME,MEMBER,REMARK 239 - DO 20 I=LEN(REMARK),1,-1 240 - IF(REMARK(I:I).NE.' ')THEN 241 - NCREM=I 242 - GOTO 30 243 - ENDIF 244 - 20 CONTINUE 245 - NCREM=1 246 - 30 CONTINUE 247 - DO 40 I=LEN(MEMBER),1,-1 248 - IF(MEMBER(I:I).NE.' ')THEN 249 - NCMEMB=I 250 - GOTO 50 251 - ENDIF 252 - 40 CONTINUE 253 - NCMEMB=1 254 - 50 CONTINUE 255 - ENDIF 256 - ENDIF 257 - CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 258 - ENDIF 259 - * Clear the storage space. 260 - CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 261 - IF(EXIST)THEN 262 - IF(ARGREF(2,1).LE.1) 263 - - CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) 264 - IF(NARG.GE.5) 265 - - CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) 266 - IF(NARG.GE.6) 267 - - CALL ALGREU(NINT(ARG(6)),MODARG(6),ARGREF(6,1)) 268 - IF(NARG.GE.7) 269 - - CALL ALGREU(NINT(ARG(7)),MODARG(7),ARGREF(7,1)) 270 - ENDIF 271 - * Set the result, first the updated member name. 272 - IF(EXIST.AND.ARGREF(2,1).LE.1)THEN 273 - CALL STRBUF('STORE',IAUX,MEMBER(1:NCMEMB),NCMEMB, 274 - - IFAIL1) 275 - ARG(2)=REAL(IAUX) 276 - MODARG(2)=1 277 - ENDIF 278 - * The existence flag. 279 - IF(EXIST)THEN 280 - ARG(4)=1 281 - ELSE 282 - ARG(4)=0 283 - ENDIF 284 - MODARG(4)=3 285 - * The remark. 286 - IF(EXIST.AND.NARG.GE.5)THEN 287 - CALL STRBUF('STORE',IAUX,REMARK(1:NCREM),NCREM,IFAIL1) 288 - ARG(5)=REAL(IAUX) 289 - MODARG(5)=1 290 - ENDIF 291 - * Date and time. 292 - IF(EXIST.AND.NARG.GE.6)THEN 293 - CALL STRBUF('STORE',IAUX,DATE,8,IFAIL1) 294 - ARG(6)=REAL(IAUX) 295 - MODARG(6)=1 296 - ENDIF 297 - IF(EXIST.AND.NARG.GE.7)THEN 298 - CALL STRBUF('STORE',IAUX,TIME,8,IFAIL1) 299 - ARG(7)=REAL(IAUX) 300 - MODARG(7)=1 301 - ENDIF 302 - *** List objects. 303 - ELSEIF(IPROC.EQ.-53)THEN 304 - IF(NARG.NE.0)PRINT *,' !!!!!! ALGCAL WARNING : The'// 1 93 P=ALGEBRA D=ALGCAL 4 PAGE 111 305 - - ' LIST_OBJECTS procedure has no arguments; ignored.' 306 - CALL BOOK('LIST',' ',' ',IFAIL) 307 - *** Fit a Gaussian to a histogram. 308 - ELSEIF(IPROC.EQ.-60.AND.MODARG(1).EQ.4)THEN 309 - * Check number and type of arguments. 310 - IF(ARGREF(2,1).GE.2.OR. 311 - - ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2.OR. 312 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. 313 - - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. 314 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. 315 - - (NARG.GE.8.AND.MODARG(8).NE.1).OR. 316 - - NARG.LT.4.OR.NARG.GT.8)THEN 317 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// 318 - - ' list provided for FIT_GAUSSIAN.' 319 - RETURN 320 - ENDIF 321 - * Fetch the option string. 322 - IF(NARG.GE.8)THEN 323 - CALL STRBUF('READ',NINT(ARG(8)),TITLE,NC,IFAIL1) 324 - CALL CLTOU(TITLE(1:NC)) 325 - ELSE 326 - TITLE=' ' 327 - NC=1 328 - ENDIF 329 - * Clear previous use of storage for the results. 330 - CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) 331 - CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) 332 - CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 333 - IF(NARG.GE.5)CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) 334 - IF(NARG.GE.6)CALL ALGREU(NINT(ARG(6)),MODARG(6),ARGREF(6,1)) 335 - IF(NARG.GE.7)CALL ALGREU(NINT(ARG(7)),MODARG(7),ARGREF(7,1)) 336 - * Perform the fit. 337 - CALL HISFNR(NINT(ARG(1)),TITLE(1:NC), 338 - - ARG(2),ARG(3),ARG(4),ARG(5),ARG(6),ARG(7),IFAIL1) 339 - IF(IFAIL1.EQ.0)THEN 340 - MODARG(2)=2 341 - MODARG(3)=2 342 - MODARG(4)=2 343 - MODARG(5)=2 344 - MODARG(6)=2 345 - MODARG(7)=2 346 - ELSE 347 - MODARG(2)=0 348 - MODARG(3)=0 349 - MODARG(4)=0 350 - MODARG(5)=0 351 - MODARG(6)=0 352 - MODARG(7)=0 353 - ENDIF 354 - * Check the error flag. 355 - IF(IFAIL1.NE.0)THEN 356 - PRINT *,' !!!!!! ALGCAL WARNING : The fit'// 357 - - ' was not successful.' 358 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 359 - RETURN 360 - ELSE 361 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 362 - ENDIF 363 - *** Fit a Gaussian to a set of matrices. 364 - ELSEIF(IPROC.EQ.-60.AND.MODARG(1).EQ.5)THEN 365 - * Check number and type of arguments. 366 - IF(NARG.LT.6.OR.NARG.GT.10.OR. 367 - - MODARG(2).NE.5.OR. 368 - - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. 369 - - ARGREF(4,1).GE.2.OR. 370 - - ARGREF(5,1).GE.2.OR.ARGREF(6,1).GE.2.OR. 371 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. 372 - - (NARG.GE.8.AND.ARGREF(8,1).GE.2).OR. 373 - - (NARG.GE.9.AND.ARGREF(9,1).GE.2).OR. 374 - - (NARG.GE.10.AND.MODARG(10).NE.1))THEN 375 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// 376 - - ' list provided for FIT_GAUSSIAN.' 377 - RETURN 378 - ENDIF 379 - * Fetch the option string, if present. 380 - IF(NARG.GE.10)THEN 381 - CALL STRBUF('READ',NINT(ARG(10)),TITLE,NC,IFAIL1) 382 - CALL CLTOU(TITLE(1:NC)) 383 - ELSE 384 - TITLE=' ' 385 - NC=1 386 - ENDIF 387 - * Clear previous use of storage for the results. 388 - CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 389 - CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) 390 - CALL ALGREU(NINT(ARG(6)),MODARG(6),ARGREF(6,1)) 391 - IF(NARG.GE.7)CALL ALGREU(NINT(ARG(7)),MODARG(7),ARGREF(7,1)) 392 - IF(NARG.GE.8)CALL ALGREU(NINT(ARG(8)),MODARG(8),ARGREF(8,1)) 393 - IF(NARG.GE.9)CALL ALGREU(NINT(ARG(9)),MODARG(9),ARGREF(9,1)) 394 - * Expand the error, if required, taking dimensions from the Y vector. 395 - IF(MODARG(3).EQ.2)THEN 396 - ISY=MATSLT(NINT(ARG(2))) 397 - IF(ISY.GE.0)THEN 398 - ISIZ(1)=MLEN(ISY) 399 - ELSE 400 - ISIZ(1)=1 401 - ENDIF 402 - CALL MATADM('ALLOCATE',IREY,1,ISIZ,MODARG(3),IFAIL1) 403 - IF(IFAIL1.NE.0)THEN 404 - PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// 405 - - ' allocate an error array; no fit.' 406 - RETURN 407 - ENDIF 408 - ISEY=MATSLT(IREY) 409 - IF(ISEY.LE.0)THEN 410 - PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// 1 93 P=ALGEBRA D=ALGCAL 5 PAGE 112 411 - - ' locate an error array; no fit.' 412 - RETURN 413 - ENDIF 414 - DO 67 I=1,ISIZ(1) 415 - MVEC(MORG(ISEY)+I)=ARG(3) 416 - 67 CONTINUE 417 - ELSE 418 - IREY=NINT(ARG(3)) 419 - ENDIF 420 - * Perform the fit. 421 - CALL MATFNR(NINT(ARG(1)),NINT(ARG(2)),IREY, 422 - - TITLE(1:NC),ARG(4),ARG(5),ARG(6),ARG(7),ARG(8),ARG(9), 423 - - IFAIL1) 424 - IF(IFAIL1.EQ.0)THEN 425 - MODARG(4)=2 426 - MODARG(5)=2 427 - MODARG(6)=2 428 - MODARG(7)=2 429 - MODARG(8)=2 430 - MODARG(9)=2 431 - ELSE 432 - MODARG(4)=0 433 - MODARG(5)=0 434 - MODARG(6)=0 435 - MODARG(7)=0 436 - MODARG(8)=0 437 - MODARG(9)=0 438 - ENDIF 439 - * Delete the error array after use. 440 - IF(MODARG(3).EQ.2) 441 - - CALL MATADM('DELETE',IREY,1,ISIZ,MODARG(3),IFAIL2) 442 - * Check the error flag. 443 - IF(IFAIL1.NE.0)THEN 444 - PRINT *,' !!!!!! ALGCAL WARNING : The fit'// 445 - - ' was not successful.' 446 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 447 - RETURN 448 - ELSE 449 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 450 - ENDIF 451 - *** Attempt to fit a Gaussian to something else. 452 - ELSEIF(IPROC.EQ.-60)THEN 453 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect data type for'// 454 - - ' a Gaussian fit ; no fit.' 455 - RETURN 456 - *** Fit a polynomial to a histogram. 457 - ELSEIF(IPROC.EQ.-61.AND.MODARG(1).EQ.4)THEN 458 - * Check number and type of arguments. 459 - IF(NARG.LT.3.OR. 460 - - (MODARG(NARG).EQ.1.AND.NARG.NE.2*(NARG/2)).OR. 461 - - (MODARG(NARG).NE.1.AND.NARG.EQ.2*(NARG/2)))THEN 462 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// 463 - - ' list provided for FIT_POLYNOMIAL.' 464 - RETURN 465 - ENDIF 466 - * Establish number of parameters. 467 - IF(MODARG(NARG).EQ.1)THEN 468 - NPAR=NARG/2-1 469 - ELSE 470 - NPAR=(NARG-1)/2 471 - ENDIF 472 - IF(NPAR.GT.MXFPAR.OR.NPAR.LT.1)THEN 473 - PRINT *,' !!!!!! ALGCAL WARNING : Number of fit'// 474 - - ' parameters out of range; no fit.' 475 - RETURN 476 - ENDIF 477 - * Fetch the option string, if present. 478 - IF(MODARG(NARG).EQ.1)THEN 479 - CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) 480 - CALL CLTOU(TITLE(1:NC)) 481 - ELSE 482 - TITLE=' ' 483 - NC=1 484 - ENDIF 485 - * Clear previous use of storage for the results. 486 - DO 60 I=2,1+2*NPAR 487 - IF(ARGREF(I,1).GE.2)THEN 488 - PRINT *,' !!!!!! ALGCAL WARNING : An output argument'// 489 - - ' of FIT_POLYNOMIAL can not be modified; no fit.' 490 - RETURN 491 - ENDIF 492 - CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 493 - 60 CONTINUE 494 - * Perform the fit. 495 - CALL HISFPL(NINT(ARG(1)),TITLE(1:NC),PAR,EPAR,NPAR,IFAIL1) 496 - * Return the results. 497 - DO 70 I=1,NPAR 498 - IF(IFAIL1.EQ.0)THEN 499 - ARG(1+I)=PAR(I) 500 - MODARG(1+I)=2 501 - ARG(NPAR+1+I)=EPAR(I) 502 - MODARG(NPAR+1+I)=2 503 - ELSE 504 - ARG(1+I)=0 505 - MODARG(1+I)=0 506 - ARG(NPAR+1+I)=0 507 - MODARG(NPAR+1+I)=0 508 - ENDIF 509 - 70 CONTINUE 510 - * Check the error flag. 511 - IF(IFAIL1.NE.0)THEN 512 - PRINT *,' !!!!!! ALGCAL WARNING : The fit'// 513 - - ' was not successful.' 514 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 515 - RETURN 516 - ELSE 1 93 P=ALGEBRA D=ALGCAL 6 PAGE 113 517 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 518 - ENDIF 519 - *** Fit a polynomial to a set of matrices. 520 - ELSEIF(IPROC.EQ.-61.AND.MODARG(1).EQ.5)THEN 521 - * Check number and type of arguments. 522 - IF(NARG.LT.5.OR. 523 - - MODARG(2).NE.5.OR. 524 - - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. 525 - - (MODARG(NARG).EQ.1.AND.NARG.NE.2*(NARG/2)).OR. 526 - - (MODARG(NARG).NE.1.AND.NARG.EQ.2*(NARG/2)))THEN 527 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// 528 - - ' list provided for FIT_POLYNOMIAL.' 529 - RETURN 530 - ENDIF 531 - * Establish number of parameters. 532 - IF(MODARG(NARG).EQ.1)THEN 533 - NPAR=NARG/2-2 534 - ELSE 535 - NPAR=(NARG-1)/2-1 536 - ENDIF 537 - IF(NPAR.GT.MXFPAR.OR.NPAR.LT.1)THEN 538 - PRINT *,' !!!!!! ALGCAL WARNING : Number of fit'// 539 - - ' parameters out of range; no fit.' 540 - RETURN 541 - ENDIF 542 - * Fetch the option string, if present. 543 - IF(MODARG(NARG).EQ.1)THEN 544 - CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) 545 - CALL CLTOU(TITLE(1:NC)) 546 - ELSE 547 - TITLE=' ' 548 - NC=1 549 - ENDIF 550 - * Clear previous use of storage for the results. 551 - DO 65 I=4,3+2*NPAR 552 - IF(ARGREF(I,1).GE.2)THEN 553 - PRINT *,' !!!!!! ALGCAL WARNING : An output argument'// 554 - - ' of FIT_POLYNOMIAL can not be modified; no fit.' 555 - RETURN 556 - ENDIF 557 - CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 558 - 65 CONTINUE 559 - * Expand the error, if required, taking dimensions from the Y vector. 560 - IF(MODARG(3).EQ.2)THEN 561 - ISY=MATSLT(NINT(ARG(2))) 562 - IF(ISY.GE.0)THEN 563 - ISIZ(1)=MLEN(ISY) 564 - ELSE 565 - ISIZ(1)=1 566 - ENDIF 567 - CALL MATADM('ALLOCATE',IREY,1,ISIZ,MODARG(3),IFAIL1) 568 - IF(IFAIL1.NE.0)THEN 569 - PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// 570 - - ' allocate an error array; no fit.' 571 - RETURN 572 - ENDIF 573 - ISEY=MATSLT(IREY) 574 - IF(ISEY.LE.0)THEN 575 - PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// 576 - - ' locate an error array; no fit.' 577 - RETURN 578 - ENDIF 579 - DO 66 I=1,ISIZ(1) 580 - MVEC(MORG(ISEY)+I)=ARG(3) 581 - 66 CONTINUE 582 - ELSE 583 - IREY=NINT(ARG(3)) 584 - ENDIF 585 - * Perform the fit. 586 - CALL MATFPL(NINT(ARG(1)),NINT(ARG(2)),IREY, 587 - - TITLE(1:NC),PAR,EPAR,NPAR,IFAIL1) 588 - * Return the results. 589 - DO 75 I=1,NPAR 590 - IF(IFAIL1.EQ.0)THEN 591 - ARG(3+I)=PAR(I) 592 - MODARG(3+I)=2 593 - ARG(NPAR+3+I)=EPAR(I) 594 - MODARG(NPAR+3+I)=2 595 - ELSE 596 - ARG(3+I)=0 597 - MODARG(3+I)=0 598 - ARG(NPAR+3+I)=0 599 - MODARG(NPAR+3+I)=0 600 - ENDIF 601 - 75 CONTINUE 602 - * Delete the error array after use. 603 - IF(MODARG(3).EQ.2) 604 - - CALL MATADM('DELETE',IREY,1,ISIZ,MODARG(3),IFAIL2) 605 - * Check the error flag. 606 - IF(IFAIL1.NE.0)THEN 607 - PRINT *,' !!!!!! ALGCAL WARNING : The fit'// 608 - - ' was not successful.' 609 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 610 - RETURN 611 - ELSE 612 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 613 - ENDIF 614 - *** Attempt to fit a polynomial to something else. 615 - ELSEIF(IPROC.EQ.-61)THEN 616 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect data type for'// 617 - - ' a polynomial fit ; no fit.' 618 - RETURN 619 - *** Fit an exponential of a polynomial to a histogram. 620 - ELSEIF(IPROC.EQ.-62.AND.MODARG(1).EQ.4)THEN 621 - * Check number and type of arguments. 622 - IF(NARG.LT.3.OR. 1 93 P=ALGEBRA D=ALGCAL 7 PAGE 114 623 - - (MODARG(NARG).EQ.1.AND.NARG.NE.2*(NARG/2)).OR. 624 - - (MODARG(NARG).NE.1.AND.NARG.EQ.2*(NARG/2)))THEN 625 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// 626 - - ' list provided for FIT_EXPONENTIAL.' 627 - RETURN 628 - ENDIF 629 - * Establish number of parameters. 630 - IF(MODARG(NARG).EQ.1)THEN 631 - NPAR=NARG/2-1 632 - ELSE 633 - NPAR=(NARG-1)/2 634 - ENDIF 635 - IF(NPAR.GT.MXFPAR.OR.NPAR.LT.1)THEN 636 - PRINT *,' !!!!!! ALGCAL WARNING : Number of fit'// 637 - - ' parameters out of range; no fit.' 638 - RETURN 639 - ENDIF 640 - * Fetch the option string, if present. 641 - IF(MODARG(NARG).EQ.1)THEN 642 - CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) 643 - CALL CLTOU(TITLE(1:NC)) 644 - ELSE 645 - TITLE=' ' 646 - NC=1 647 - ENDIF 648 - * Clear previous use of storage for the results. 649 - DO 260 I=2,1+2*NPAR 650 - IF(ARGREF(I,1).GE.2)THEN 651 - PRINT *,' !!!!!! ALGCAL WARNING : An output argument'// 652 - - ' of FIT_EXPONENTIAL can not be modified; no fit.' 653 - RETURN 654 - ENDIF 655 - CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 656 - 260 CONTINUE 657 - * Perform the fit. 658 - CALL HISFEX(NINT(ARG(1)),TITLE(1:NC),PAR,EPAR,NPAR,IFAIL1) 659 - * Return the results. 660 - DO 270 I=1,NPAR 661 - IF(IFAIL1.EQ.0)THEN 662 - ARG(1+I)=PAR(I) 663 - MODARG(1+I)=2 664 - ARG(NPAR+1+I)=EPAR(I) 665 - MODARG(NPAR+1+I)=2 666 - ELSE 667 - ARG(1+I)=0 668 - MODARG(1+I)=0 669 - ARG(NPAR+1+I)=0 670 - MODARG(NPAR+1+I)=0 671 - ENDIF 672 - 270 CONTINUE 673 - * Check the error flag. 674 - IF(IFAIL1.NE.0)THEN 675 - PRINT *,' !!!!!! ALGCAL WARNING : The fit'// 676 - - ' was not successful.' 677 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 678 - RETURN 679 - ELSE 680 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 681 - ENDIF 682 - *** Fit an exponential of a polynomial to a set of matrices. 683 - ELSEIF(IPROC.EQ.-62.AND.MODARG(1).EQ.5)THEN 684 - * Check number and type of arguments. 685 - IF(NARG.LT.5.OR. 686 - - MODARG(2).NE.5.OR. 687 - - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. 688 - - (MODARG(NARG).EQ.1.AND.NARG.NE.2*(NARG/2)).OR. 689 - - (MODARG(NARG).NE.1.AND.NARG.EQ.2*(NARG/2)))THEN 690 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// 691 - - ' list provided for FIT_EXPONENTIAL.' 692 - RETURN 693 - ENDIF 694 - * Establish number of parameters. 695 - IF(MODARG(NARG).EQ.1)THEN 696 - NPAR=NARG/2-2 697 - ELSE 698 - NPAR=(NARG-1)/2-1 699 - ENDIF 700 - IF(NPAR.GT.MXFPAR.OR.NPAR.LT.1)THEN 701 - PRINT *,' !!!!!! ALGCAL WARNING : Number of fit'// 702 - - ' parameters out of range; no fit.' 703 - RETURN 704 - ENDIF 705 - * Fetch the option string, if present. 706 - IF(MODARG(NARG).EQ.1)THEN 707 - CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) 708 - CALL CLTOU(TITLE(1:NC)) 709 - ELSE 710 - TITLE=' ' 711 - NC=1 712 - ENDIF 713 - * Clear previous use of storage for the results. 714 - DO 265 I=4,3+2*NPAR 715 - IF(ARGREF(I,1).GE.2)THEN 716 - PRINT *,' !!!!!! ALGCAL WARNING : An output argument'// 717 - - ' of FIT_EXPONENTIAL can not be modified; no fit.' 718 - RETURN 719 - ENDIF 720 - CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 721 - 265 CONTINUE 722 - * Expand the error, if required, taking dimensions from the Y vector. 723 - IF(MODARG(3).EQ.2)THEN 724 - ISY=MATSLT(NINT(ARG(2))) 725 - IF(ISY.GE.0)THEN 726 - ISIZ(1)=MLEN(ISY) 727 - ELSE 728 - ISIZ(1)=1 1 93 P=ALGEBRA D=ALGCAL 8 PAGE 115 729 - ENDIF 730 - CALL MATADM('ALLOCATE',IREY,1,ISIZ,MODARG(3),IFAIL1) 731 - IF(IFAIL1.NE.0)THEN 732 - PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// 733 - - ' allocate an error array; no fit.' 734 - RETURN 735 - ENDIF 736 - ISEY=MATSLT(IREY) 737 - IF(ISEY.LE.0)THEN 738 - PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// 739 - - ' locate an error array; no fit.' 740 - RETURN 741 - ENDIF 742 - DO 266 I=1,ISIZ(1) 743 - MVEC(MORG(ISEY)+I)=ARG(3) 744 - 266 CONTINUE 745 - ELSE 746 - IREY=NINT(ARG(3)) 747 - ENDIF 748 - * Perform the fit. 749 - CALL MATFEX(NINT(ARG(1)),NINT(ARG(2)),IREY, 750 - - TITLE(1:NC),PAR,EPAR,NPAR,IFAIL1) 751 - * Return the results. 752 - DO 275 I=1,NPAR 753 - IF(IFAIL1.EQ.0)THEN 754 - ARG(3+I)=PAR(I) 755 - MODARG(3+I)=2 756 - ARG(NPAR+3+I)=EPAR(I) 757 - MODARG(NPAR+3+I)=2 758 - ELSE 759 - ARG(3+I)=0 760 - MODARG(3+I)=0 761 - ARG(NPAR+3+I)=0 762 - MODARG(NPAR+3+I)=0 763 - ENDIF 764 - 275 CONTINUE 765 - * Delete the error array after use. 766 - IF(MODARG(3).EQ.2) 767 - - CALL MATADM('DELETE',IREY,1,ISIZ,MODARG(3),IFAIL2) 768 - * Check the error flag. 769 - IF(IFAIL1.NE.0)THEN 770 - PRINT *,' !!!!!! ALGCAL WARNING : The fit'// 771 - - ' was not successful.' 772 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 773 - RETURN 774 - ELSE 775 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 776 - ENDIF 777 - *** Attempt to fit an exponential of a polynomial to something else. 778 - ELSEIF(IPROC.EQ.-62)THEN 779 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect data type for'// 780 - - ' an exponential polynomial fit ; no fit.' 781 - RETURN 782 - *** Fit a Polya distribution to a histogram. 783 - ELSEIF(IPROC.EQ.-63.AND.MODARG(1).EQ.4)THEN 784 - * Check number and type of arguments. 785 - IF(NARG.LT.9.OR.NARG.GT.10.AND. 786 - - (NARG.GE.2.AND.ARGREF(2,1).GE.2).OR. 787 - - (NARG.GE.3.AND.ARGREF(3,1).GE.2).OR. 788 - - (NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. 789 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. 790 - - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. 791 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. 792 - - (NARG.GE.8.AND.ARGREF(8,1).GE.2).OR. 793 - - (NARG.GE.9.AND.ARGREF(9,1).GE.2).OR. 794 - - (NARG.EQ.10.AND.MODARG(NARG).NE.1))THEN 795 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// 796 - - ' list provided for FIT_POLYA.' 797 - RETURN 798 - ENDIF 799 - * Fetch the option string, if present. 800 - IF(MODARG(NARG).EQ.1)THEN 801 - CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) 802 - CALL CLTOU(TITLE(1:NC)) 803 - ELSE 804 - TITLE=' ' 805 - NC=1 806 - ENDIF 807 - * Clear previous use of storage for the results. 808 - DO 261 I=2,9 809 - CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 810 - 261 CONTINUE 811 - * Perform the fit. 812 - CALL HISFPR(NINT(ARG(1)),TITLE(1:NC),ARG(2),ARG(3),ARG(4), 813 - - ARG(5),ARG(6),ARG(7),ARG(8),ARG(9),IFAIL1) 814 - IF(IFAIL1.EQ.0)THEN 815 - MODARG(2)=2 816 - MODARG(3)=2 817 - MODARG(4)=2 818 - MODARG(5)=2 819 - MODARG(6)=2 820 - MODARG(7)=2 821 - MODARG(8)=2 822 - MODARG(9)=2 823 - ELSE 824 - MODARG(2)=0 825 - MODARG(3)=0 826 - MODARG(4)=0 827 - MODARG(5)=0 828 - MODARG(6)=0 829 - MODARG(7)=0 830 - MODARG(8)=0 831 - MODARG(9)=0 832 - ENDIF 833 - * Check the error flag. 834 - IF(IFAIL1.NE.0)THEN 1 93 P=ALGEBRA D=ALGCAL 9 PAGE 116 835 - PRINT *,' !!!!!! ALGCAL WARNING : The fit'// 836 - - ' was not successful.' 837 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 838 - RETURN 839 - ELSE 840 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 841 - ENDIF 842 - *** Fit a Polya distribution to a set of matrices. 843 - ELSEIF(IPROC.EQ.-63.AND.MODARG(1).EQ.5)THEN 844 - * Check number and type of arguments. 845 - IF(NARG.LT.11.OR.NARG.GT.12.AND. 846 - - MODARG(2).NE.5.OR. 847 - - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. 848 - - (NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. 849 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. 850 - - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. 851 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. 852 - - (NARG.GE.8.AND.ARGREF(8,1).GE.2).OR. 853 - - (NARG.GE.9.AND.ARGREF(9,1).GE.2).OR. 854 - - (NARG.GE.10.AND.ARGREF(10,1).GE.2).OR. 855 - - (NARG.GE.11.AND.ARGREF(11,1).GE.2).OR. 856 - - (NARG.EQ.12.AND.MODARG(NARG).NE.1))THEN 857 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// 858 - - ' list provided for FIT_POLYA.' 859 - RETURN 860 - ENDIF 861 - * Fetch the option string, if present. 862 - IF(MODARG(NARG).EQ.1)THEN 863 - CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) 864 - CALL CLTOU(TITLE(1:NC)) 865 - ELSE 866 - TITLE=' ' 867 - NC=1 868 - ENDIF 869 - * Clear previous use of storage for the results. 870 - DO 267 I=4,11 871 - CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 872 - 267 CONTINUE 873 - * Expand the error, if required, taking dimensions from the Y vector. 874 - IF(MODARG(3).EQ.2)THEN 875 - ISY=MATSLT(NINT(ARG(2))) 876 - IF(ISY.GE.0)THEN 877 - ISIZ(1)=MLEN(ISY) 878 - ELSE 879 - ISIZ(1)=1 880 - ENDIF 881 - CALL MATADM('ALLOCATE',IREY,1,ISIZ,MODARG(3),IFAIL1) 882 - IF(IFAIL1.NE.0)THEN 883 - PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// 884 - - ' allocate an error array; no fit.' 885 - RETURN 886 - ENDIF 887 - ISEY=MATSLT(IREY) 888 - IF(ISEY.LE.0)THEN 889 - PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// 890 - - ' locate an error array; no fit.' 891 - RETURN 892 - ENDIF 893 - DO 268 I=1,ISIZ(1) 894 - MVEC(MORG(ISEY)+I)=ARG(3) 895 - 268 CONTINUE 896 - ELSE 897 - IREY=NINT(ARG(3)) 898 - ENDIF 899 - * Perform the fit. 900 - CALL MATFPR(NINT(ARG(1)),NINT(ARG(2)),IREY,TITLE(1:NC), 901 - - ARG(4),ARG(5),ARG(6),ARG(7), 902 - - ARG(8),ARG(9),ARG(10),ARG(11),IFAIL1) 903 - IF(IFAIL1.EQ.0)THEN 904 - MODARG(4)=2 905 - MODARG(5)=2 906 - MODARG(6)=2 907 - MODARG(7)=2 908 - MODARG(8)=2 909 - MODARG(9)=2 910 - MODARG(10)=2 911 - MODARG(11)=2 912 - ELSE 913 - MODARG(4)=0 914 - MODARG(5)=0 915 - MODARG(6)=0 916 - MODARG(7)=0 917 - MODARG(8)=0 918 - MODARG(9)=0 919 - MODARG(10)=0 920 - MODARG(11)=0 921 - ENDIF 922 - * Delete the error array after use. 923 - IF(MODARG(3).EQ.2) 924 - - CALL MATADM('DELETE',IREY,1,ISIZ,MODARG(3),IFAIL2) 925 - * Check the error flag. 926 - IF(IFAIL1.NE.0)THEN 927 - PRINT *,' !!!!!! ALGCAL WARNING : The fit'// 928 - - ' was not successful.' 929 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 930 - RETURN 931 - ELSE 932 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 933 - ENDIF 934 - *** Attempt to fit an exponential of a polynomial to something else. 935 - ELSEIF(IPROC.EQ.-63)THEN 936 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect data type for'// 937 - - ' a Polya fit ; no fit.' 938 - RETURN 939 - *** Fit a function to an histogram. 940 - ELSEIF(IPROC.EQ.-64.AND.MODARG(1).EQ.4)THEN 1 93 P=ALGEBRA D=ALGCAL 10 PAGE 117 941 - * Check number and type of arguments. 942 - IF(NARG.LT.4.OR.MODARG(2).NE.1.OR. 943 - - (MODARG(NARG).EQ.1.AND.NARG.EQ.2*(NARG/2)).OR. 944 - - (MODARG(NARG).NE.1.AND.NARG.NE.2*(NARG/2)))THEN 945 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// 946 - - ' list provided for FIT_FUNCTION.' 947 - RETURN 948 - ENDIF 949 - * Establish number of parameters. 950 - IF(MODARG(NARG).EQ.1)THEN 951 - NPAR=(NARG-3)/2 952 - ELSE 953 - NPAR=(NARG-2)/2 954 - ENDIF 955 - IF(NPAR.GT.MXFPAR.OR.NPAR.LT.1)THEN 956 - PRINT *,' !!!!!! ALGCAL WARNING : Number of fit'// 957 - - ' parameters out of range; no fit.' 958 - RETURN 959 - ENDIF 960 - * Fetch the function string. 961 - CALL STRBUF('READ',NINT(ARG(2)),FILE,NCFILE,IFAIL1) 962 - IF(NCFILE.LE.0)THEN 963 - PRINT *,' !!!!!! ALGCAL WARNING : Null string not'// 964 - - ' suitable as function; no fit.' 965 - RETURN 966 - ENDIF 967 - CALL CLTOU(FILE(1:NCFILE)) 968 - * Fetch the option string, if present. 969 - IF(MODARG(NARG).EQ.1)THEN 970 - CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) 971 - CALL CLTOU(TITLE(1:NC)) 972 - ELSE 973 - TITLE=' ' 974 - NC=1 975 - ENDIF 976 - * Determine the origin of the variables. 977 - DO 310 I=1,NPAR 978 - IF(ARGREF(2+I,1).GE.2.OR.ARGREF(2+NPAR+I,1).GE.2)THEN 979 - PRINT *,' !!!!!! ALGCAL WARNING : An output argument'// 980 - - ' of FIT_FUNCTION can not be modified; no fit.' 981 - RETURN 982 - ENDIF 983 - IA(I)=ARGREF(2+I,2) 984 - IE(I)=ARGREF(2+NPAR+I,2) 985 - CALL ALGREU(NINT(ARG(2+NPAR+I)),MODARG(2+NPAR+I), 986 - - ARGREF(2+NPAR+I,1)) 987 - 310 CONTINUE 988 - * Perform the fit. 989 - CALL HISFFU(NINT(ARG(1)),FILE(1:NCFILE),TITLE(1:NC), 990 - - IA,IE,NPAR,IFAIL1) 991 - * And ensure that the argument vector matches the globals list. 992 - DO 320 I=3,2+2*NPAR 993 - IF(IFAIL1.EQ.0)THEN 994 - ARG(I)=GLBVAL(ARGREF(I,2)) 995 - MODARG(I)=2 996 - ELSE 997 - ARG(I)=0 998 - MODARG(I)=0 999 - ENDIF 1000 - 320 CONTINUE 1001 - * Check the error flag. 1002 - IF(IFAIL1.NE.0)THEN 1003 - PRINT *,' !!!!!! ALGCAL WARNING : The fit'// 1004 - - ' was not successful.' 1005 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 1006 - RETURN 1007 - ELSE 1008 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 1009 - ENDIF 1010 - *** Fit a function to a set of matrices. 1011 - ELSEIF(IPROC.EQ.-64.AND.MODARG(1).EQ.5)THEN 1012 - * Check number and type of arguments. 1013 - IF(NARG.LT.6.OR.MODARG(4).NE.1.OR. 1014 - - MODARG(2).NE.5.OR. 1015 - - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. 1016 - - (MODARG(NARG).NE.1.AND.NARG.NE.2*(NARG/2)).OR. 1017 - - (MODARG(NARG).EQ.1.AND.NARG.EQ.2*(NARG/2)))THEN 1018 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// 1019 - - ' list provided for FIT_EXPONENTIAL.' 1020 - RETURN 1021 - ENDIF 1022 - * Establish number of parameters. 1023 - IF(MODARG(NARG).EQ.1)THEN 1024 - NPAR=(NARG-5)/2 1025 - ELSE 1026 - NPAR=(NARG-4)/2 1027 - ENDIF 1028 - IF(NPAR.GT.MXFPAR.OR.NPAR.LT.1)THEN 1029 - PRINT *,' !!!!!! ALGCAL WARNING : Number of fit'// 1030 - - ' parameters out of range; no fit.' 1031 - RETURN 1032 - ENDIF 1033 - * Fetch the function string. 1034 - CALL STRBUF('READ',NINT(ARG(4)),FILE,NCFILE,IFAIL1) 1035 - IF(NCFILE.LE.0)THEN 1036 - PRINT *,' !!!!!! ALGCAL WARNING : Null string not'// 1037 - - ' suitable as function; no fit.' 1038 - RETURN 1039 - ENDIF 1040 - CALL CLTOU(FILE(1:NCFILE)) 1041 - * Fetch the option string, if present. 1042 - IF(MODARG(NARG).EQ.1)THEN 1043 - CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) 1044 - CALL CLTOU(TITLE(1:NC)) 1045 - ELSE 1046 - TITLE=' ' 1 93 P=ALGEBRA D=ALGCAL 11 PAGE 118 1047 - NC=1 1048 - ENDIF 1049 - * Determine the origin of the variables. 1050 - DO 330 I=1,NPAR 1051 - IF(ARGREF(4+I,1).GE.2.OR.ARGREF(4+NPAR+I,1).GE.2)THEN 1052 - PRINT *,' !!!!!! ALGCAL WARNING : An output argument'// 1053 - - ' of FIT_FUNCTION can not be modified; no fit.' 1054 - RETURN 1055 - ENDIF 1056 - IA(I)=ARGREF(4+I,2) 1057 - IE(I)=ARGREF(4+NPAR+I,2) 1058 - CALL ALGREU(NINT(ARG(4+NPAR+I)),MODARG(4+NPAR+I), 1059 - - ARGREF(4+NPAR+I,1)) 1060 - 330 CONTINUE 1061 - * Expand the error, if required, taking dimensions from the Y vector. 1062 - IF(MODARG(3).EQ.2)THEN 1063 - ISY=MATSLT(NINT(ARG(2))) 1064 - IF(ISY.GE.0)THEN 1065 - ISIZ(1)=MLEN(ISY) 1066 - ELSE 1067 - ISIZ(1)=1 1068 - ENDIF 1069 - CALL MATADM('ALLOCATE',IREY,1,ISIZ,MODARG(3),IFAIL1) 1070 - IF(IFAIL1.NE.0)THEN 1071 - PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// 1072 - - ' allocate an error array; no fit.' 1073 - RETURN 1074 - ENDIF 1075 - ISEY=MATSLT(IREY) 1076 - IF(ISEY.LE.0)THEN 1077 - PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// 1078 - - ' locate an error array; no fit.' 1079 - RETURN 1080 - ENDIF 1081 - DO 350 I=1,ISIZ(1) 1082 - MVEC(MORG(ISEY)+I)=ARG(3) 1083 - 350 CONTINUE 1084 - ELSE 1085 - IREY=NINT(ARG(3)) 1086 - ENDIF 1087 - * Perform the fit. 1088 - CALL MATFFU(NINT(ARG(1)),NINT(ARG(2)),IREY,FILE(1:NCFILE), 1089 - - TITLE(1:NC),IA,IE,NPAR,IFAIL1) 1090 - * And ensure that the argument vector matches the globals list. 1091 - DO 340 I=5,4+2*NPAR 1092 - IF(IFAIL1.EQ.0)THEN 1093 - ARG(I)=GLBVAL(ARGREF(I,2)) 1094 - MODARG(I)=2 1095 - ELSE 1096 - ARG(I)=0 1097 - MODARG(I)=0 1098 - ENDIF 1099 - 340 CONTINUE 1100 - * Delete the error array after use. 1101 - IF(MODARG(3).EQ.2) 1102 - - CALL MATADM('DELETE',IREY,1,ISIZ,MODARG(3),IFAIL2) 1103 - * Check the error flag. 1104 - IF(IFAIL1.NE.0)THEN 1105 - PRINT *,' !!!!!! ALGCAL WARNING : The fit'// 1106 - - ' was not successful.' 1107 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 1108 - RETURN 1109 - ELSE 1110 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 1111 - ENDIF 1112 - *** Attempt to fit a function to something else. 1113 - ELSEIF(IPROC.EQ.-64)THEN 1114 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect data type for'// 1115 - - ' a function fit ; no fit.' 1116 - RETURN 1117 - *** Fit a Mathieson distribution to an histogram. 1118 - ELSEIF(IPROC.EQ.-65.AND.MODARG(1).EQ.4)THEN 1119 - * Check number and type of arguments. 1120 - IF((MODARG(NARG).EQ.1.AND.NARG.NE.9).OR. 1121 - - (MODARG(NARG).NE.1.AND.NARG.NE.8).OR. 1122 - - NARG.LT.8.OR.NARG.GT.9.OR. 1123 - - MODARG(2).NE.2.OR. 1124 - - (NARG.GE.3.AND.ARGREF(3,1).GE.2).OR. 1125 - - (NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. 1126 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. 1127 - - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. 1128 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. 1129 - - (NARG.GE.8.AND.ARGREF(8,1).GE.2))THEN 1130 - PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// 1131 - - ' list provided for FIT_MATHIESON.' 1132 - RETURN 1133 - ENDIF 1134 - * Fetch the option string, if present. 1135 - IF(MODARG(NARG).EQ.1)THEN 1136 - CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) 1137 - CALL CLTOU(TITLE(1:NC)) 1138 - IF(INDEX(TITLE(1:NC),'NOFITK3').NE.0.AND. 1139 - - MODARG(5).NE.2)THEN 1140 - PRINT *,' !!!!!! ALGCAL WARNING : The K3'// 1141 - - ' parameter is fixed but not numeric ;'// 1142 - - ' fit not performed.' 1143 - RETURN 1144 - ENDIF 1145 - ELSE 1146 - TITLE=' ' 1147 - NC=1 1148 - ENDIF 1149 - * Initial setting of K3. 1150 - IF(MODARG(5).EQ.2)THEN 1151 - K3=ARG(5) 1152 - ELSE 1 93 P=ALGEBRA D=ALGCAL 12 PAGE 119 1153 - K3=0.5 1154 - ENDIF 1155 - * Clear up memory associated with modifiable variables. 1156 - DO 269 I=3,8 1157 - CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 1158 - 269 CONTINUE 1159 - * Perform the fit. 1160 - CALL HISFMS(NINT(ARG(1)),TITLE(1:NC),ARG(2), 1161 - - ARG(4),ARG(3),K3,ARG(7),ARG(6),ARG(8),IFAIL1) 1162 - * Check the error flag. 1163 - IF(IFAIL1.NE.0)THEN 1164 - PRINT *,' !!!!!! ALGCAL WARNING : The fit'// 1165 - - ' was not successful.' 1166 - MODARG(3)=0 1167 - MODARG(4)=0 1168 - MODARG(5)=0 1169 - MODARG(6)=0 1170 - MODARG(7)=0 1171 - MODARG(8)=0 1172 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 1173 - RETURN 1174 - ELSE 1175 - MODARG(3)=2 1176 - MODARG(4)=2 1177 - ARG(5)=K3 1178 - MODARG(5)=2 1179 - MODARG(6)=2 1180 - MODARG(7)=2 1181 - MODARG(8)=2 1182 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 1183 - ENDIF 1184 - *** Mathieson fit on other data types. 1185 - ELSEIF(IPROC.EQ.-65)THEN 1186 - PRINT *,' !!!!!! ALGCAL WARNING : Mathieson fits are'// 1187 - - ' only available for histograms; no fit.' 1188 - RETURN 1189 - *** Signal procedures. 1190 - ELSEIF(IPROC.LE.-70.AND.IPROC.GT.-80)THEN 1191 - CALL SIGCAL(INSTR,IFAIL1) 1192 - IF(IFAIL1.NE.0)THEN 1193 - PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// 1194 - - ' a signal procedure call.' 1195 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 1196 - RETURN 1197 - ELSE 1198 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 1199 - ENDIF 1200 - *** Matrix procedures. 1201 - ELSEIF(IPROC.LE.-80.AND.IPROC.GT.-110)THEN 1202 - CALL MATCAL(INSTR,IFAIL1) 1203 - IF(IFAIL1.NE.0)THEN 1204 - PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// 1205 - - ' a matrix procedure call.' 1206 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 1207 - RETURN 1208 - ELSE 1209 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 1210 - ENDIF 1211 - *** Other procedures are not known. 1212 - ELSE 1213 - PRINT *,' !!!!!! ALGCAL WARNING : Unknown procedure code'// 1214 - - ' received.' 1215 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 1216 - RETURN 1217 - ENDIF 1218 - *** Things worked fine. 1219 - IFAIL=0 1220 - RETURN 1221 - *** I/O error handling. 1222 - 2000 CONTINUE 1223 - PRINT *,' !!!!!! ALGCAL WARNING : Unexpected EOF seen.' 1224 - CALL INPIOS(IOS) 1225 - RETURN 1226 - 2010 CONTINUE 1227 - PRINT *,' !!!!!! ALGCAL WARNING : I/O error encountered.' 1228 - CALL INPIOS(IOS) 1229 - RETURN 1230 - 2030 CONTINUE 1231 - PRINT *,' !!!!!! ALGCAL WARNING : Error closing a file.' 1232 - CALL INPIOS(IOS) 1233 - END 94 GARFIELD ================================================== P=ALGEBRA D=ALGCLR 1 ============================ 0 + +DECK,ALGCLR. 1 - SUBROUTINE ALGCLR(IENTRY) 2 - *----------------------------------------------------------------------- 3 - * ALGCLR - Clears an entry point, marking the storage space it 4 - * occupied as available - only effective after a gbc. 5 - * (Last changed on 1/ 2/01.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,ALGDATA. 10.- +SEQ,PRINTPLOT. 11 - LOGICAL FOUND 12 - INTEGER I,IENTRY 13 - *** Scan the entry point table to find the entry. 14 - FOUND=.FALSE. 15 - DO 10 I=1,NALGE 16 - IF(ALGENT(I,1).EQ.IENTRY)THEN 17 - FOUND=.TRUE. 18 - IF(ALGENT(I,2).EQ.0.AND.LDEBUG)THEN 19 - WRITE(LUNOUT,'('' ++++++ ALGCLR DEBUG : Entry'', 20 - - '' point '',I4,'' was already cleared.'')') IENTRY 21 - ELSEIF(LDEBUG)THEN 1 94 P=ALGEBRA D=ALGCLR 2 PAGE 120 22 - WRITE(LUNOUT,'('' ++++++ ALGCLR DEBUG : Entry'', 23 - - '' point '',I4,'' cleared.'')') IENTRY 24 - ENDIF 25 - ALGENT(I,2)=0 26 - ENDIF 27 - 10 CONTINUE 28 - *** Make sure the entry was indeed found. 29 - IF(.NOT.FOUND)PRINT *,' !!!!!! ALGCLR WARNING : The entry'// 30 - - ' point to be cleared does not exist; program bug.' 31 - END 95 GARFIELD ================================================== P=ALGEBRA D=ALGEDT 1 ============================ 0 + +DECK,ALGEDT. 1 - SUBROUTINE ALGEDT(VARLIS,NVAR,IENTRY,USE,NREXP) 2 - *----------------------------------------------------------------------- 3 - * ALGEDT - Reads instructions relating to formula manipulation. It 4 - * serves as a section but will rarely be used as such by the 5 - * normal user. 6 - * (Last changed on 6/11/99.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,ALGDATA. 11.- +SEQ,PRINTPLOT. 12 - INTEGER IBUF(4),INPCMP,INPTYP,MODVAR(MXVAR),MODRES(10),ILIST1, 13 - - ILIST,ILIST2,IFAIL,IFAIL1,IFAIL2,IFAIL3,IFAIL4,IENT,IENUPD, 14 - - IDEL,ICOPY,IENCLR,IEXEC,I,J,I1,I2,NCPRT,NC,NWORD,IENTRR, 15 - - IENDSP,NVAR,NREXP,IENTRY,INS0,INSC,IPRINT,NNRES,IENTNO 16 - CHARACTER*10 VARLIS(MXVAR) 17 - CHARACTER*(MXINCH) STRING 18 - LOGICAL USE(MXVAR) 19 - REAL RES(10),VAR(MXVAR) 20 - EXTERNAL INPCMP,INPTYP 0 21-+ +SELF,IF=AST. 22 - EXTERNAL ASTCCH 0 23-+ +SELF. 24 - *** Define some output formats. 25 - 1010 FORMAT(' ',25X,'Reg(',I3,')=',E15.8:'; Reg(',I3,')=',E15.8) 26 - *** Print a header for this section. 27 - WRITE(*,'(''1'')') 28 - PRINT *,' ------------------------------------------------' 29 - PRINT *,' ---------- Algebra subsection ----------' 30 - PRINT *,' ------------------------------------------------' 31 - PRINT *,' ' 32 - *** Assign an entry point to the instruction list. 33 - IENTRY=IENTRL+1 34 - IENTRL=IENTRL+1 35 - IINS0=NINS+1 36 - ICONS0=NCONS-1 37 - * Check storage, perform a garbage collect if necessary. 38 - IF(NALGE+1.GT.MXALGE)THEN 39 - CALL ALGGBC 40 - IF(NALGE+1.GT.MXALGE)THEN 41 - PRINT *,' !!!!!! ALGEDT WARNING : Unable to allocate'// 42 - - ' an entry point to the instruction list.' 43 - PRINT *,' Increase MXALGE'// 44 - - ' and recompile the program.' 45 - IFAIL=1 46 - IENTRY=-1 47 - RETURN 48 - ENDIF 49 - ENDIF 50 - NALGE=NALGE+1 51 - * Initialise the entry point record. 52 - ALGENT(NALGE,1)=IENTRY 53 - ALGENT(NALGE,2)=1 54 - ALGENT(NALGE,3)=0 55 - ALGENT(NALGE,4)=0 56 - ALGENT(NALGE,5)=IINS0 57 - ALGENT(NALGE,6)=0 58 - ALGENT(NALGE,7)=NVAR 59 - ALGENT(NALGE,8)=ICONS0 60 - ALGENT(NALGE,9)=0 61 - ALGENT(NALGE,10)=0 62 - *** Read instructions and make some simple checks. 63 - CALL INPPRM('Algebra','ADD-PRINT') 64 - 10 CONTINUE 65 - CALL INPGET 66 - CALL INPNUM(NWORD) 0 67-+ +SELF,IF=AST. 68 - *** Set up ASTCCH as the condition handler. 69 - CALL LIB$ESTABLISH(ASTCCH) 0 70-+ +SELF. 71 - CALL INPSTR(1,1,STRING,NC) 72 - IF(NWORD.EQ.0)GOTO 10 73 - *** Avoid that this routine is left using '&'. 74 - IF(STRING(1:1).EQ.'&')THEN 75 - PRINT *,' !!!!!! ALGEDT WARNING : The section cannot be'// 76 - - ' left at this point; first type EXIT.' 77 - GOTO 10 78 - ELSEIF(INDEX('$%?><',STRING(1:1)).NE.0)THEN 79 - PRINT *,' !!!!!! ALGEDT WARNING : This command cannot be'// 80 - - ' executed at the present level; first type EXIT.' 81 - GOTO 10 82 - ELSEIF(STRING(1:1).EQ.'*')THEN 83 - GOTO 10 84 - *** Add an entry point. 85 - ELSEIF(INPCMP(1,'ADD-EN#TRY-#POINT').NE.0)THEN 86 - * Update the record for the current entry point. 87 - ALGENT(NALGE,3)=1 88 - ALGENT(NALGE,4)=1 1 95 P=ALGEBRA D=ALGEDT 2 PAGE 121 89 - ALGENT(NALGE,6)=NINS-IINS0+1 90 - ALGENT(NALGE,10)=0 91 - DO 80 I=ALGENT(NALGE,5),ALGENT(NALGE,5)+ALGENT(NALGE,6)-1 92 - IF(INS(I,2).EQ.0)ALGENT(NALGE,10)=ALGENT(NALGE,10)+1 93 - IF(INS(I,2).EQ.7.OR.ABS(INS(I,2)).EQ.9)ALGENT(NALGE,4)=0 94 - IF(INS(I,2).NE.0.AND.INS(I,2).NE.6.AND.INS(I,2).NE.8.AND. 95 - - INS(I,2).NE.9)NCONS=MIN(NCONS,INS(I,1)) 96 - IF(ABS(INS(I,2)).NE.9)NCONS=MIN(NCONS,INS(I,3)) 97 - 80 CONTINUE 98 - ALGENT(NALGE,9)=ICONS0-NCONS+1 99 - NREXP=ALGENT(NALGE,10) 100 - * Increment counters. 101 - IENTRY=IENTRL+1 102 - IENTRL=IENTRL+1 103 - IINS0=NINS+1 104 - ICONS0=NCONS-1 105 - * Check storage, perform a garbage collect if necessary. 106 - IF(NALGE+1.GT.MXALGE)THEN 107 - PRINT *,' !!!!!! ALGEDT WARNING : No room for a new'// 108 - - ' entry point; try a garbage collect.' 109 - GOTO 10 110 - ENDIF 111 - NALGE=NALGE+1 112 - * Initialise the entry point record. 113 - ALGENT(NALGE,1)=IENTRY 114 - ALGENT(NALGE,2)=1 115 - ALGENT(NALGE,3)=0 116 - ALGENT(NALGE,4)=0 117 - ALGENT(NALGE,5)=IINS0 118 - ALGENT(NALGE,6)=0 119 - ALGENT(NALGE,7)=NVAR 120 - ALGENT(NALGE,8)=ICONS0 121 - ALGENT(NALGE,9)=0 122 - ALGENT(NALGE,10)=0 123 - * Tell the user which entry point was added. 124 - WRITE(LUNOUT,'(/'' New entry point has reference '',I4,/ 125 - - '' and starts at line '',I4,''.'',/)') IENTRY,IINS0 126 - *** Remove an entry point. 127 - ELSEIF(INPCMP(1,'CL#EAR-EN#TRY-#POINT').NE.0)THEN 128 - IF(NWORD.EQ.1)THEN 129 - IENCLR=IENTRY 130 - ELSEIF(NWORD.EQ.2)THEN 131 - IF(INPTYP(2).NE.1)THEN 132 - CALL INPMSG(2,'Entry point is not an integer.') 133 - IENCLR=0 134 - ELSE 135 - CALL INPCHK(2,1,IFAIL1) 136 - CALL INPRDI(2,IENCLR,0) 137 - ENDIF 138 - ELSE 139 - PRINT *,' !!!!!! ALGEDT WARNING : CLEAR-ENTRY-POINT'// 140 - - ' has either 1 or no argument; nothing cleared.' 141 - IENCLR=0 142 - ENDIF 143 - CALL ALGCLR(IENCLR) 144 - *** Print the number of instructions. 145 - ELSEIF(0.NE.INPCMP(1,'C#OUNT'))THEN 146 - WRITE(LUNOUT,'(/'' Current number of instructions:'',I4, 147 - - ''.''/)') NINS 148 - *** Set or display the entry point. 149 - ELSEIF(0.NE.INPCMP(1,'D#ISPLAY-EN#TRY-#POINT'))THEN 150 - * Read the optional argument (entry point reference number). 151 - IENDSP=0 152 - IF(NWORD.EQ.1)THEN 153 - IENDSP=IENTRY 154 - ELSEIF(NWORD.EQ.2)THEN 155 - IF(INPTYP(2).NE.1)THEN 156 - CALL INPMSG(2,'Entry point is not an integer.') 157 - ELSE 158 - CALL INPCHK(2,1,IFAIL1) 159 - CALL INPRDI(2,IENTRR,0) 160 - IENTNO=0 161 - DO 50 I=1,NALGE 162 - IF(ALGENT(I,1).EQ.IENTRR)IENTNO=I 163 - 50 CONTINUE 164 - IF(IENTNO.EQ.0)THEN 165 - CALL INPMSG(2, 166 - - 'Entry point does not exist. ') 167 - ELSE 168 - IENDSP=IENTRR 169 - ENDIF 170 - ENDIF 171 - ELSE 172 - PRINT *,' !!!!!! ALGEDT WARNING : DISPLAY-ENTRY-'// 173 - - 'POINT has 1 or no arguments; statement ignored.' 174 - IENDSP=0 175 - ENDIF 176 - * Attempt to locate the entry point in the table. 177 - IENTNO=0 178 - DO 40 I=1,NALGE 179 - IF(ALGENT(I,1).EQ.IENDSP)IENTNO=I 180 - 40 CONTINUE 181 - * Display the data if found. 182 - IF(IENTNO.NE.0)THEN 183 - WRITE(LUNOUT,'(/'' ENTRY POINT DESCRIPTION:''// 184 - - 5X,''Reference number: '',I4/ 185 - - 5X,''In use (1) or not (0): '',I4/ 186 - - 5X,''Correct (1) or not (0): '',I4/ 187 - - 5X,''Sequential (1) or not (0): '',I4/ 188 - - 5X,''First instruction at line: '',I4/ 189 - - 5X,''Number of instructions: '',I4/ 190 - - 5X,''Number of registers used: '',I4/ 191 - - 5X,''First local constant at: '',I4/ 192 - - 5X,''Number of local constants: '',I4/ 193 - - 5X,''Number of results produced: '',I4/)') 194 - - (ALGENT(IENTNO,I),I=1,10) 1 95 P=ALGEBRA D=ALGEDT 3 PAGE 122 195 - * Display an error message if the entry point was not found. 196 - ELSEIF(IENDSP.NE.0)THEN 197 - PRINT *,' !!!!!! ALGEDT WARNING : Unable to find'// 198 - - ' the entry point; make sure it is still defined.' 199 - ENDIF 200 - *** Check whether routine execution can be finished. 201 - ELSEIF(0.NE.INPCMP(1,'EX#IT'))THEN 202 - * Find out which variables are effectively used. 203 - DO 20 I1=1,NVAR 204 - USE(I1)=.FALSE. 205 - DO 30 I2=1,NINS 206 - IF((INS(I2,1).EQ.I1.AND.INS(I2,2).NE.0.AND.INS(I2,2).NE.6) 207 - - .OR.INS(I2,3).EQ.I1)USE(I1)=.TRUE. 208 - 30 CONTINUE 209 - 20 CONTINUE 210 - * Update the entry point record. 211 - IF(NALGE.GT.0.AND.NALGE.LT.MXALGE)THEN 212 - ALGENT(NALGE,3)=1 213 - ALGENT(NALGE,4)=1 214 - ALGENT(NALGE,6)=NINS-IINS0+1 215 - ALGENT(NALGE,10)=0 216 - DO 70 I=ALGENT(NALGE,5), 217 - - ALGENT(NALGE,5)+ALGENT(NALGE,6)-1 218 - IF(INS(I,2).EQ.0)ALGENT(NALGE,10)=ALGENT(NALGE,10)+1 219 - IF(INS(I,2).EQ.7.OR.ABS(INS(I,2)).EQ.9) 220 - - ALGENT(NALGE,4)=0 221 - IF(INS(I,2).NE.0.AND.INS(I,2).NE.6.AND. 222 - - INS(I,2).NE.8.AND.INS(I,2).NE.9) 223 - - NCONS=MIN(NCONS,INS(I,1)) 224 - IF(ABS(INS(I,2)).NE.9)NCONS=MIN(NCONS,INS(I,3)) 225 - 70 CONTINUE 226 - ALGENT(NALGE,9)=ICONS0-NCONS+1 227 - NREXP=ALGENT(NALGE,10) 228 - ELSE 229 - PRINT *,' !!!!!! ALGEDT WARNING : No instructions'// 230 - - ' left on EXIT.' 231 - NREXP=0 232 - ENDIF 233 - PRINT *,' ' 234 - PRINT *,' ------------------------------------------------' 235 - PRINT *,' ---------- Algebra subsection end ----------' 236 - PRINT *,' ------------------------------------------------' 237 - PRINT *,' ' 238 - * Reset the prompt. 239 - CALL INPPRM(' ','BACK-PRINT') 240 - RETURN 241 - *** Provide a means to enter a function directly. 242 - ELSEIF(0.NE.INPCMP(1,'F#UNCTION'))THEN 243 - IF(NWORD.LE.1)THEN 244 - PRINT *,' !!!!!! ALGEDT WARNING : No function'// 245 - - ' provided; nothing done.' 246 - ELSE 247 - CALL INPSTR(2,MXWORD,STRING,NC) 248 - IENTRY=IENTRY-1 249 - IENTRL=IENTRL-1 250 - IINS0=ALGENT(NALGE,5) 251 - ICONS0=ALGENT(NALGE,8) 252 - NINS=IINS0-1 253 - NCONS=ICONS0+1 254 - NALGE=NALGE-1 255 - CALL ALGPRE(STRING,NC,VARLIS,NVAR,NNRES,USE,IENTRY, 256 - - IFAIL) 257 - PRINT *,' ' 258 - IF(IFAIL.EQ.0)THEN 259 - PRINT *,' Translation succeeded, ',NNRES, 260 - - ' results are produced.' 261 - ELSE 262 - PRINT *,' Translation did NOT succeed.' 263 - ENDIF 264 - PRINT *,' ' 265 - IF(NNRES.NE.NREXP.AND.NREXP.NE.0)PRINT *,' Note: the'// 266 - - ' calling section expects ',NREXP,' results.' 267 - ENDIF 268 - *** Garbage collect. 269 - ELSEIF(INPCMP(1,'GARB#AGE-#COLLECT').NE.0)THEN 270 - CALL ALGGBC 271 - *** Insertion of instructions. 272 - ELSEIF(INPCMP(1,'I#NSERT').NE.0)THEN 273 - IF(NWORD.GT.2)THEN 274 - PRINT *,' !!!!!! ALGEDT WARNING : INSERT needs 1'// 275 - - ' argument ; the instruction is ignored.' 276 - GOTO 10 277 - ELSEIF(NWORD.EQ.1)THEN 278 - INS0=NINS+1 279 - IFAIL=0 280 - ELSE 281 - CALL INPCHK(2,1,IFAIL) 282 - CALL INPRDI(2,INS0,NINS+1) 283 - IF(INS0.LT.1.OR.INS0.GT.NINS+1) 284 - - CALL INPMSG(2,'Argument out of range. ') 285 - CALL INPERR 286 - ENDIF 287 - IF(INS0.LT.1.OR.INS0.GT.NINS+1.OR.IFAIL.EQ.1)THEN 288 - PRINT *,' !!!!!! ALGEDT WARNING : Incorrect syntax'// 289 - - ' or value of argument for INSERT; line ignored.' 290 - GOTO 10 291 - ENDIF 292 - * Make sure there is room to insert lines. 293 - IF(NINS.GE.MXINS)THEN 294 - PRINT *,' !!!!!! ALGEDT WARNING : No room to insert'// 295 - - ' new lines ; delete some or increase MXINS.' 296 - GOTO 10 297 - ENDIF 298 - * Ask for the new lines, initialise the insert counter: INSC. 299 - INSC=NINS 300 - PRINT *,' ====== ALGEDT INPUT : Please enter new'// 1 95 P=ALGEBRA D=ALGEDT 4 PAGE 123 301 - - ' lines, terminate with a blank line.' 302 - CALL INPPRM('Ins','ADD-NOPRINT') 303 - 200 CONTINUE 304 - * Check that the insert counter can still be incremented. 305 - IF(INSC+1.GT.MXINS)THEN 306 - PRINT *,' !!!!!! ALGEDT WARNING : No further lines'// 307 - - ' can be accepted; delete some or increase MXINS.' 308 - GOTO 210 309 - ENDIF 310 - * Read the line to be inserted, 311 - CALL INPGET 312 - CALL INPNUM(NWORD) 313 - IF(NWORD.EQ.0)GOTO 210 314 - * and check that the types are correct. 315 - CALL INPCHK(1,1,IFAIL1) 316 - CALL INPCHK(2,1,IFAIL2) 317 - CALL INPCHK(3,1,IFAIL3) 318 - CALL INPCHK(4,1,IFAIL4) 319 - CALL INPERR 320 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. 321 - - IFAIL4.NE.0.OR.NWORD.NE.4)THEN 322 - GOTO 200 323 - ENDIF 324 - * Read the contents of the line and check the syntax. 325 - INSC=INSC+1 326 - CALL INPRDI(1,INS(INSC,1),MXREG+1) 327 - CALL INPRDI(2,INS(INSC,2), 10) 328 - CALL INPRDI(3,INS(INSC,3),MXREG+1) 329 - CALL INPRDI(4,INS(INSC,4),MXREG+1) 330 - IF(ISYNCH.EQ.1.AND. 331 - - ((INS(INSC,2).EQ.6.AND.(INS(INSC,1).GT.10.OR. 332 - - INS(INSC,1).LT.-9)).OR. 333 - - (INS(INSC,2).EQ.0.AND.INS(INSC,3).LT.0).OR. 334 - - (INS(INSC,2).LT.0.OR.INS(INSC,2).GT.17.OR. 335 - - (INS(INSC,2).GT.7.AND.INS(INSC,2).LT.10)).OR. 336 - - (((INS(INSC,2).GE.1.AND.INS(INSC,2).LE.5).OR. 337 - - (INS(INSC,2).GE.10.AND.INS(INSC,2).LE.17)).AND. 338 - - (INS(INSC,1).LT.MXCONS.OR.INS(INSC,1).GT.MXREG)).OR. 339 - - INS(INSC,3).LT.MXCONS.OR.INS(INSC,3).GT.MXREG.OR. 340 - - INS(INSC,4).LT.MXCONS.OR.INS(INSC,4).GT.MXREG))THEN 341 - PRINT *,' !!!!!! ALGEDT WARNING : Line is invalid'// 342 - - ' in ALGEBRA mode; ignored.' 343 - INSC=INSC-1 344 - ELSEIF(ISYNCH.EQ.2)THEN 345 - PRINT *,' !!!!!! ALGEDT WARNING : PROCEDURE mode'// 346 - - ' checking is not yet available; to to NONE.' 347 - ISYNCH=0 348 - ENDIF 349 - GOTO 200 350 - * End of the list reached. 351 - 210 CONTINUE 352 - * Reset the prompt. 353 - CALL INPPRM(' ','BACK-PRINT') 354 - * Move the inserted lines to their new position. 355 - DO 230 I=1,INSC-NINS 356 - DO 240 J=1,4 357 - IBUF(J)=INS(NINS+I,J) 358 - INS(NINS+I,J)=INS(INS0+I-1+INSC-NINS,J) 359 - INS(INS0+I-1+INSC-NINS,J)=INS(INS0+I-1,J) 360 - INS(INS0+I-1,J)=IBUF(J) 361 - 240 CONTINUE 362 - 230 CONTINUE 363 - NINS=INSC 364 - *** Handle the range of the instructions needing one. 365 - ELSEIF(INPCMP(1,'L#IST')+INPCMP(1,'PR#INT')+ 366 - - INPCMP(1,'DEL#ETE')+INPCMP(1,'EXEC#UTE').NE.0)THEN 367 - IF(NINS.EQ.0)THEN 368 - PRINT *,' The instruction buffer is empty.' 369 - GOTO 10 370 - ENDIF 371 - CALL INPSTR(1,1,STRING,NC) 372 - IF(NWORD.EQ.1)THEN 373 - ILIST1=1 374 - ILIST2=NINS 375 - ELSEIF(NWORD.EQ.2)THEN 376 - CALL INPCHK(2,1,IFAIL) 377 - CALL INPRDI(2,ILIST1,1) 378 - IF(IFAIL.NE.0)THEN 379 - CALL INPERR 380 - PRINT *,' !!!!!! ALGEDT WARNING : Incorrect'// 381 - - ' argument type for '//STRING(1:NC)//'.' 382 - GOTO 10 383 - ENDIF 384 - IF(ILIST1.LE.0.OR.ILIST1.GT.NINS)THEN 385 - PRINT *,' !!!!!! ALGEDT WARNING : The argument'// 386 - - ' is out of range for '//STRING(1:NC)//'.' 387 - GOTO 10 388 - ENDIF 389 - ILIST2=ILIST1 390 - ELSEIF(NWORD.EQ.3)THEN 391 - CALL INPCHK(2,1,IFAIL1) 392 - CALL INPRDI(2,ILIST1,1) 393 - IF(0.EQ.INPCMP(3,'L#AST'))THEN 394 - CALL INPCHK(3,1,IFAIL2) 395 - CALL INPRDI(3,ILIST2,NINS) 396 - ELSE 397 - IFAIL2=0 398 - ILIST2=NINS 399 - ENDIF 400 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN 401 - CALL INPERR 402 - PRINT *,' !!!!!! ALGEDT WARNING : Incorrect'// 403 - - ' argument type(s) for '//STRING(1:NC)//'.' 404 - GOTO 10 405 - ENDIF 406 - IF(ILIST1.LE.0.OR.ILIST2.GT.NINS.OR.ILIST1.GT.ILIST2) 1 95 P=ALGEBRA D=ALGEDT 5 PAGE 124 407 - - PRINT *,' !!!!!! ALGEDT WARNING : Incorrect'// 408 - - ' argument range for '//STRING(1:NC)// 409 - - '; adjusted to the bounds.' 410 - ILIST1=MIN(NINS,MXINS,MAX(1,ILIST1)) 411 - ILIST2=MAX(ILIST1,MIN(ILIST2,NINS,MXINS)) 412 - ELSE 413 - PRINT *,' !!!!!! ALGEDT WARNING : Number of'// 414 - - ' arguments incorrect for '//STRING(1:NC)//'.' 415 - GOTO 10 416 - ENDIF 417 - * Deleting of instructions, update the entry point also. 418 - IF(INPCMP(1,'DEL#ETE').NE.0)THEN 419 - DO 140 IENT=1,NALGE 420 - IF(ALGENT(IENT,5).LE.ILIST1.AND.(IENT.EQ.NALGE.OR. 421 - - ALGENT(MIN(IENT+1,NALGE),5).GT.ILIST1))THEN 422 - IF(ALGENT(IENT,2).EQ.0)THEN 423 - PRINT *,' !!!!!! ALGEDT WARNING : The'// 424 - - ' lines to be deleted start in'// 425 - - ' a cleared entry point; ignored.' 426 - GOTO 10 427 - ELSEIF(ALGENT(IENT,6).GE.ILIST2-ILIST1+1)THEN 428 - IENUPD=IENT 429 - GOTO 150 430 - ELSE 431 - PRINT *,' !!!!!! ALGEDT WARNING : The'// 432 - - ' range of lines to be deleted spans'// 433 - - ' more than 1 entry point; ignored.' 434 - GOTO 10 435 - ENDIF 436 - ENDIF 437 - 140 CONTINUE 438 - PRINT *,' ###### ALGEDT ERROR : Unable to find the'// 439 - - ' entry point for the delete range; program bug.' 440 - GOTO 10 441 - 150 CONTINUE 442 - DO 110 IDEL=ILIST1,NINS-(ILIST2-ILIST1)-1 443 - DO 120 ICOPY=1,4 444 - INS(IDEL,ICOPY)=INS(IDEL+(ILIST2-ILIST1)+1,ICOPY) 445 - 120 CONTINUE 446 - 110 CONTINUE 447 - IF(ILIST2.LT.IINS0)IINS0=IINS0-ILIST2+ILIST1-1 448 - NINS=NINS-ILIST2+ILIST1-1 449 - ALGENT(IENUPD,6)=ALGENT(IENUPD,6)-ILIST2+ILIST1-1 450 - DO 160 IENT=IENUPD+1,NALGE 451 - ALGENT(IENT,5)=ALGENT(IENT,5)-ILIST2+ILIST1-1 452 - 160 CONTINUE 453 - * Executing instructions. 454 - ELSEIF(INPCMP(1,'EXEC#UTE').NE.0)THEN 455 - DO 130 IEXEC=ILIST1,ILIST2 456 - IF(INS(IEXEC,2).EQ.0.OR.INS(IEXEC,2).EQ.7.OR. 457 - - INS(IEXEC,2).EQ.8.OR.ABS(INS(IEXEC,2)).EQ.9)THEN 458 - PRINT *,' The following instruction is not'// 459 - - ' executed:' 460 - CALL ALGPRT(IEXEC,IEXEC) 461 - GOTO 130 462 - ELSE 463 - CALL ALGEX2(IEXEC,IFAIL) 464 - IF(IFAIL.NE.0)THEN 465 - WRITE(LUNOUT,*) ' ++++++ ALGEDT DEBUG :'// 466 - - ' Arithmetic error while evaluating:' 467 - CALL ALGPRT(IEXEC,IEXEC) 468 - IF(INS(IEXEC,2).EQ.6)WRITE(LUNOUT,1010) 469 - - INS(IEXEC,3),REG(INS(IEXEC,3)) 470 - IF(INS(I,2).NE.6)WRITE(LUNOUT,1010) 471 - - INS(IEXEC,1),REG(INS(IEXEC,1)), 472 - - INS(IEXEC,3),REG(INS(IEXEC,3)) 473 - WRITE(LUNOUT,'('' '')') 474 - ENDIF 475 - ENDIF 476 - 130 CONTINUE 477 - * Listing of instructions. 478 - ELSEIF(INPCMP(1,'L#IST').NE.0)THEN 479 - WRITE(LUNOUT,'('' '')') 480 - DO 100 ILIST=ILIST1,ILIST2 481 - WRITE(LUNOUT,'(1X,I3,'' : '',4I4)') 482 - - ILIST,(INS(ILIST,I),I=1,4) 483 - 100 CONTINUE 484 - WRITE(LUNOUT,'('' '')') 485 - * Printing of the instructions. 486 - ELSEIF(INPCMP(1,'PR#INT').NE.0)THEN 487 - CALL ALGPRT(ILIST1,ILIST2) 488 - ENDIF 489 - *** Show memory occupation. 490 - ELSEIF(INPCMP(1,'MEM#ORY').NE.0)THEN 491 - WRITE(LUNOUT,'(/'' GLOBAL MEMORY USAGE:''// 492 - - 5X,''Number of registers in use: '',I3/ 493 - - 5X,''Number of constants in use: '',I3/ 494 - - 5X,''Number of instructions in use: '',I3/, 495 - - 5X,''Number of entry points in use: '',I3/)') 496 - - NREG,-NCONS,NINS,NALGE 497 - IF(NALGE.GE.1)THEN 498 - WRITE(LUNOUT,'(/'' USAGE PER ENTRY POINT:''// 499 - - '' Refno Instructions Registers'', 500 - - '' Constants Comments'')') 501 - DO 510 I=1,NALGE 502 - NCPRT=0 503 - STRING=' ' 504 - IF(ALGENT(I,2).EQ.0)THEN 505 - STRING(NCPRT+1:NCPRT+9)='Cleared, ' 506 - NCPRT=NCPRT+9 507 - ENDIF 508 - IF(ALGENT(I,3).EQ.0)THEN 509 - STRING(NCPRT+1:NCPRT+13)='Not useable, ' 510 - NCPRT=NCPRT+13 511 - ENDIF 512 - IF(NCPRT.LT.3)NCPRT=3 1 95 P=ALGEBRA D=ALGEDT 6 PAGE 125 513 - WRITE(LUNOUT,'(5X,I5,3I15,2X,A)') ALGENT(I,1), 514 - - ALGENT(I,6),ALGENT(I,7),ALGENT(I,9), 515 - - STRING(1:NCPRT-2) 516 - 510 CONTINUE 517 - WRITE(LUNOUT,'('' '')') 518 - ELSE 519 - WRITE(LUNOUT,'(/'' NO ENTRY POINTS IN USE.''/)') 520 - ENDIF 521 - *** Take care of the options. 522 - ELSEIF(INPCMP(1,'OPT#IONS').NE.0)THEN 523 - IF(NWORD.EQ.1)THEN 524 - WRITE(LUNOUT,'(/'' LOCAL OPTIONS CURRENTLY IN'', 525 - - '' EFFECT:'')') 526 - IF(ISYNCH.EQ.0)THEN 527 - WRITE(LUNOUT,'(/'' Instruction list lines'', 528 - - '' are not checked.'')') 529 - ELSEIF(ISYNCH.EQ.1)THEN 530 - WRITE(LUNOUT,'(/'' Instruction list lines'', 531 - - '' are checked on ALGEBRA syntax.'')') 532 - ELSEIF(ISYNCH.EQ.2)THEN 533 - WRITE(LUNOUT,'(/'' Instruction list lines'', 534 - - '' are checked on PROCEDURE syntax.'')') 535 - ENDIF 536 - IF(LIGUND)THEN 537 - WRITE(LUNOUT,'('' Exponential underflow'', 538 - - '' is ignored.''/)') 539 - ELSE 540 - WRITE(LUNOUT,'('' Exponential underflow'', 541 - - '' is signaled.''/)') 542 - ENDIF 543 - ENDIF 544 - DO 310 I=2,NWORD 545 - IF(INPCMP(I,'NO-SYN#TAX-#CHECK').NE.0)THEN 546 - ISYNCH=0 547 - ELSEIF(INPCMP(I,'ALG#EBRA-SYN#TAX-#CHECK').NE.0)THEN 548 - ISYNCH=1 549 - ELSEIF(INPCMP(I,'PRO#CEDURE-SYN#TAX-#CHECK').NE.0)THEN 550 - ISYNCH=2 551 - ELSEIF(INPCMP(I,'I#GNORE-UND#ERFLOW')+ 552 - - INPCMP(I,'I#GNORE-EXP#ONENTIAL-UND#ERFLOW').NE.0)THEN 553 - LIGUND=.TRUE. 554 - ELSEIF(INPCMP(I,'S#IGNAL-UND#ERFLOW')+ 555 - - INPCMP(I,'S#IGNAL-EXP#ONENTIAL-UND#ERFLOW').NE.0)THEN 556 - LIGUND=.FALSE. 557 - ELSE 558 - CALL INPMSG(I,'The option is not known. ') 559 - ENDIF 560 - 310 CONTINUE 561 - CALL INPERR 562 - *** Set/show register values, if the keyword is REGISTER. 563 - ELSEIF(0.NE.INPCMP(1,'R#EGISTER'))THEN 564 - CALL INPCHK(2,1,IFAIL1) 565 - CALL INPCHK(3,2,IFAIL2) 566 - CALL INPERR 567 - IF(NWORD.LE.1.OR.NWORD.GT.3)THEN 568 - PRINT *,' !!!!!! ALGEDT WARNING : Incorrect number'// 569 - - ' of arguments for the REGISTER instruction.' 570 - ELSEIF(NWORD.EQ.2.AND.IFAIL1.NE.0.OR. 571 - - NWORD.EQ.3.AND.(IFAIL1.NE.0.OR.IFAIL2.NE.0))THEN 572 - PRINT *,' !!!!!! ALGEDT WARNING : Incorrect argument'// 573 - - ' type(s) for the REGISTER instruction.' 574 - ELSE 575 - CALL INPRDI(2,I,1) 576 - IF(I.LT.MXCONS.OR.I.GT.MXREG)THEN 577 - PRINT *,' !!!!!! ALGEDT WARNING : The argument'// 578 - - ' to REGISTER is not a valid array index.' 579 - ELSE 580 - IF(NWORD.EQ.2)WRITE(LUNOUT,'(/'' Current value'', 581 - - '' of register '',I3,'' is '',E15.8,''.''/)') 582 - - I,REG(I) 583 - IF(NWORD.EQ.3)CALL INPRDR(3,REG(I),0.0) 584 - ENDIF 585 - ENDIF 586 - *** Reset the algebra system. 587 - ELSEIF(INPCMP(1,'RESE#T').NE.0)THEN 588 - * Initialise. 589 - CALL ALGINT 590 - * Assign a new entry point. 591 - NALGE=1 592 - IENTRY=IENTRL+1 593 - IENTRL=IENTRL+1 594 - ALGENT(NALGE,1)=IENTRY 595 - ALGENT(NALGE,2)=1 596 - ALGENT(NALGE,3)=0 597 - ALGENT(NALGE,4)=0 598 - ALGENT(NALGE,5)=IINS0 599 - ALGENT(NALGE,6)=0 600 - ALGENT(NALGE,7)=NVAR 601 - ALGENT(NALGE,8)=ICONS0 602 - ALGENT(NALGE,9)=0 603 - ALGENT(NALGE,10)=0 604 - *** Print the number of results the calling section expects. 605 - ELSEIF(INPCMP(1,'RESU#LTS').NE.0)THEN 606 - IF(NREXP.NE.0)THEN 607 - PRINT *,' The calling section expects ',NREXP, 608 - - ' results.' 609 - ELSE 610 - PRINT *,' The calling section did not specify the', 611 - - ' number of expected results.' 612 - ENDIF 613 - *** Simplify the instruction list. 614 - ELSEIF(INPCMP(1,'SIM#PLIFY').NE.0)THEN 615 - NREG=0 616 - NCONS=0 617 - DO 410 I=1,NINS 618 - IF(INS(I,2).NE.0.AND.INS(I,2).NE.6.AND. 1 95 P=ALGEBRA D=ALGEDT 7 PAGE 126 619 - - INS(I,2).NE.8.AND.INS(I,2).NE.9)THEN 620 - IF(NREG.LT.INS(I,1))NREG=INS(I,1) 621 - IF(NCONS.GT.INS(I,1))NCONS=INS(I,1) 622 - ENDIF 623 - IF(ABS(INS(I,2)).NE.9)THEN 624 - IF(NREG.LT.INS(I,3))NREG=INS(I,3) 625 - IF(NCONS.GT.INS(I,3))NCONS=INS(I,3) 626 - ENDIF 627 - 410 CONTINUE 628 - CALL ALGSIM(VARLIS,NVAR,USE,IFAIL) 629 - *** Allow testing of the instruction list. 630 - ELSEIF(0.NE.INPCMP(1,'TEST'))THEN 631 - IF(NWORD.NE.1+NVAR)THEN 632 - PRINT *,' !!!!!! ALGEDT WARNING : Each parameter to'// 633 - - ' the function must be specified when using TEST.' 634 - ELSE 635 - IFAIL=0 636 - DO 320 I=2,NWORD 637 - CALL INPCHK(I,2,IFAIL1) 638 - IF(IFAIL1.NE.0)IFAIL=1 639 - CALL INPRDR(I,VAR(I-1),0.0) 640 - MODVAR(I-1)=2 641 - 320 CONTINUE 642 - CALL INPERR 643 - IF(IFAIL.NE.0)THEN 644 - PRINT *,' !!!!!! ALGEDT WARNING : Syntax errors'// 645 - - ' in the test parameters ; line ignored.' 646 - GOTO 10 647 - ENDIF 648 - DO 330 I=1,10 649 - RES(I)=0.0 650 - 330 CONTINUE 651 - CALL ALGEXE(IENTRY,VAR,MODVAR,NVAR,RES,MODRES,10,IFAIL) 652 - WRITE(LUNOUT,'(/'' Elements in the result array'', 653 - - '' which have been assigned a value.''/ 654 - - '' ============================'', 655 - - ''=================================''/)') 656 - DO 340 I=1,10 657 - IPRINT=0 658 - DO 341 J=1,NINS 659 - IF(INS(J,2).EQ.0.AND.INS(J,4).EQ.I)IPRINT=1 660 - 341 CONTINUE 661 - IF(IPRINT.EQ.1)WRITE(LUNOUT,'('' Result('',I3, 662 - - '') = '',E15.8)') I,RES(I) 663 - 340 CONTINUE 664 - IF(IFAIL.NE.0)THEN 665 - WRITE(LUNOUT,'(/'' Note: an error has'', 666 - - '' been detected.''/)') 667 - ELSE 668 - WRITE(LUNOUT,'(/'' No errors detected.''/)') 669 - ENDIF 670 - ENDIF 671 - *** Show the variable names if VARIABLES is the keyword. 672 - ELSEIF(0.NE.INPCMP(1,'VAR#IABLES'))THEN 673 - WRITE(LUNOUT,'(/'' List of acceptable variable names:''/ 674 - - '' ==================================''/)') 675 - DO 300 I=1,NVAR 676 - WRITE(LUNOUT,'(5X,A10,'' --> Register('',I3,'')'')') 677 - - VARLIS(I),I 678 - 300 CONTINUE 679 - WRITE(LUNOUT,'('' '')') 680 - *** Unknown instruction. 681 - ELSE 682 - CALL INPSTR(1,1,STRING,NC) 683 - PRINT *,' !!!!!! ALGEDT WARNING : '//STRING(1:NC)//' is'// 684 - - ' not a valid instruction; ignored.' 685 - ENDIF 686 - *** Display error messages. 687 - CALL INPERR 688 - GOTO 10 689 - END 96 GARFIELD ================================================== P=ALGEBRA D=ALGERR 1 ============================ 0 + +DECK,ALGERR. 1 - SUBROUTINE ALGERR 2 - *----------------------------------------------------------------------- 3 - * ALGERR - Routine printing the number of arithmetic errors since the 4 - * last call from ALGPRE. 5 - * (Last changed on 3/ 6/97.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,ALGDATA. 10 - CHARACTER*20 AUX 11 - INTEGER I,NC,NATOT 12 - *** Count the errors. 13 - NATOT=0 14 - DO 20 I=1,100 15 - NATOT=NATOT+NAERR(I) 16 - 20 CONTINUE 17 - IF(NERR.LT.NATOT)NERR=NATOT 18 - *** One error. 19 - IF(NERR.EQ.1)THEN 20 - PRINT *,' !!!!!! ALGERR WARNING : One arithmetic error'// 21 - - ' has been detected.' 22 - *** Two errors. 23 - ELSEIF(NERR.EQ.2)THEN 24 - PRINT *,' !!!!!! ALGERR WARNING : Two arithmetic errors'// 25 - - ' have been detected.' 26 - *** More errors, format the number and print. 27 - ELSEIF(NERR.GT.2)THEN 28 - CALL OUTFMT(REAL(NERR),2,AUX,NC,'LEFT') 29 - PRINT *,' !!!!!! ALGERR WARNING : '//AUX(1:NC)// 30 - - ' arithmetic errors have been detected.' 31 - ENDIF 1 96 P=ALGEBRA D=ALGERR 2 PAGE 127 32 - *** Print detailed error messages. 33 - IF(NAERR(1).GT.0)WRITE(*,'(26X, 34 - - ''Division by zero: '',I5)') NAERR(1) 35 - IF(NAERR(2).GT.0)WRITE(*,'(26X, 36 - - ''Exponential overflow: '',I5)') NAERR(2) 37 - IF(NAERR(3).GT.0)WRITE(*,'(26X, 38 - - ''Exponential underflow: '',I5)') NAERR(3) 39 - IF(NAERR(4).GT.0)WRITE(*,'(26X, 40 - - ''Log of a number non-positive number: '',I5)') NAERR(4) 41 - IF(NAERR(5).GT.0)WRITE(*,'(26X, 42 - - ''Arcsin or Arccos of a number > 1: '',I5)') NAERR(5) 43 - IF(NAERR(6).GT.0)WRITE(*,'(26X, 44 - - ''Square root of a negative number: '',I5)') NAERR(6) 45 - IF(NAERR(7).GT.0)WRITE(*,'(26X, 46 - - ''Arccosh of a number < 1: '',I5)') NAERR(7) 47 - IF(NAERR(8).GT.0)WRITE(*,'(26X, 48 - - ''Arctanh of a number outside <-1,1>: '',I5)') NAERR(8) 49 - IF(NAERR(9).GT.0)WRITE(*,'(26X, 50 - - ''Failure to store a string: '',I5)') NAERR(9) 51 - IF(NAERR(10).GT.0)WRITE(*,'(26X, 52 - - ''Unidentified operator code: '',I5)') NAERR(10) 53 - IF(NAERR(11).GT.0)WRITE(*,'(26X, 54 - - ''Undefined power raising: '',I5)') NAERR(11) 55 - *** Whatever happens, reset the error counter. 56 - NERR=0 57 - DO 10 I=1,100 58 - NAERR(I)=0 59 - 10 CONTINUE 60 - END 97 GARFIELD ================================================== P=ALGEBRA D=ALGEXE 1 ============================ 0 + +DECK,ALGEXE. 1 - SUBROUTINE ALGEXE(IENTRY,VAR,MODVAR,NVAR,RES,MODRES,NNRES,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * ALGEXE - Routine executing the instructions produced by ALGPRE. 4 - * (Last changed on 31/10/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,ALGDATA. 9.- +SEQ,GLOBALS. 10.- +SEQ,PRINTPLOT. 11 - REAL VAR(*),RES(*),EPS 12 - INTEGER MODVAR(*),MODRES(*),IENTRY,NVAR,NNRES,IFAIL,I,J,IENTNO, 13 - - INEXT,IDUM,NCDUM,IFAIL1 14 - CHARACTER*1 DUMSTR 15 - PARAMETER(EPS=1.0E-5) 16 - *** Output formats. 17 - 1060 FORMAT(26X,'REG(',I3,')=',E15.7:'; REG(',I3,')=',E15.7) 18 - *** Early returns mean evalution failed. 19 - IFAIL=1 20 - *** Assign zero to all expected results. 21 - DO 40 I=1,NNRES 22 - RES(I)=0.0 23 - MODRES(I)=0 24 - 40 CONTINUE 25 - *** Zero argument buffer. 26 - DO 160 I=1,MXARG 27 - ARG(I)=0.0 28 - MODARG(I)=0 29 - ARGREF(I,1)=0 30 - ARGREF(I,2)=0 31 - 160 CONTINUE 32 - *** Locate the entry point. 33 - IENTNO=0 34 - DO 30 I=1,NALGE 35 - IF(ALGENT(I,1).EQ.IENTRY)IENTNO=I 36 - 30 CONTINUE 37 - IF(IENTNO.EQ.0)THEN 38 - IF(LDEBUG)WRITE(LUNOUT,*) ' ++++++ ALGEXE DEBUG :'// 39 - - ' Requested entry point does not exist.' 40 - RETURN 41 - ENDIF 42 - IF(ALGENT(IENTNO,2).EQ.0.OR.ALGENT(IENTNO,3).EQ.0.OR. 43 - - ALGENT(IENTNO,7).GT.NVAR.OR. 44 - - (ALGENT(IENTNO,10).NE.0.AND.ALGENT(IENTNO,10).GT.NNRES))THEN 45 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEXE DEBUG :'', 46 - - '' List for entry point is not executable.''/ 47 - - 26X,''Serial number='',I4,'', Reference number='',I4/ 48 - - 26X,''In use='',I1,'', List correct='',I1, 49 - - '', Sequential='',I1/ 50 - - 26X,''First instruction='',I4,'', # instructions='',I4/ 51 - - 26X,''# variables expected='',I4,'' (given='',I4,'')''/ 52 - - 26X,''First constant='',I4,'', # constants='',I4/ 53 - - 26X,''# results from list='',I4,'' (expected='',I4, 54 - - '').'')') 55 - - IENTNO,(ALGENT(IENTNO,I),I=1,7),NVAR, 56 - - (ALGENT(IENTNO,I),I=8,10),NNRES 57 - RETURN 58 - ENDIF 59 - *** First assign the values of the variables to REG. 60 - DO 10 I=1,MXREG 61 - IF(I.LE.NVAR.AND.I.LE.ALGENT(IENTNO,7))THEN 62 - REG(I)=VAR(I) 63 - MODREG(I)=MODVAR(I) 64 - ELSE 65 - REG(I)=0 66 - MODREG(I)=0 67 - ENDIF 68 - 10 CONTINUE 69 - IFAIL=0 70 - *** Execute all the instructions. 71 - INEXT=ALGENT(IENTNO,5)-1 72 - 20 CONTINUE 73 - INEXT=INEXT+1 1 97 P=ALGEBRA D=ALGEXE 2 PAGE 128 74 - *** Return at the end of the list and if INEXT has been set to 0. 75 - IF(INEXT.GT.ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1.OR. 76 - - INEXT.EQ.0)GOTO 3000 77 - *** Lines of the result-assignment type. 78 - IF(INS(INEXT,2).EQ.0)THEN 79 - IF(INS(INEXT,4).LT.1.OR.INS(INEXT,4).GT.NNRES)THEN 80 - IFAIL=1 81 - IF(LDEBUG)WRITE(LUNOUT,'(1X,A,I3,A)') 82 - - ' ++++++ ALGEXE DEBUG : No room for result'// 83 - - ' produced at line ',INEXT,' in receiving array.' 84 - GOTO 3000 85 - ELSE 86 - RES(INS(INEXT,4))=REG(INS(INEXT,3)) 87 - MODRES(INS(INEXT,4))=MODREG(INS(INEXT,3)) 88 - ENDIF 89 - *** GOTO statement. 90 - ELSEIF(INS(INEXT,2).EQ.7)THEN 91 - IF(ABS(REG(INS(INEXT,1))-1).LT.EPS)THEN 92 - INEXT=NINT(REG(INS(INEXT,3)))-1 93 - ELSEIF(ABS(REG(INS(INEXT,1))).GT.EPS)THEN 94 - IF(LDEBUG)THEN 95 - WRITE(LUNOUT,'(2X,A)') '++++++ ALGEXE DEBUG :'// 96 - - ' Logical value error at the line:' 97 - CALL ALGPRT(INEXT,INEXT) 98 - WRITE(LUNOUT,'(26X,''Reg('',I3,'')='',E15.7, 99 - - ''; Reg('',I3,'')='',E15.7,/)') 100 - - INS(INEXT,1),REG(INS(INEXT,1)), 101 - - INS(INEXT,3),REG(INS(INEXT,3)) 102 - ENDIF 103 - IFAIL=1 104 - GOTO 3000 105 - ENDIF 106 - *** Arguments. 107 - ELSEIF(INS(INEXT,2).EQ.8)THEN 108 - IF(INS(INEXT,4).LE.0.OR.INS(INEXT,4).GT.MXARG)THEN 109 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEXE DEBUG :'', 110 - - '' Invalid argument # '',I3,'' found in line '', 111 - - I3,'':'')') INS(INEXT,4),INEXT 112 - IF(LDEBUG)CALL ALGPRT(INEXT,INEXT) 113 - IFAIL=1 114 - GOTO 3000 115 - ENDIF 116 - ARG(INS(INEXT,4))=REG(INS(INEXT,3)) 117 - MODARG(INS(INEXT,4))=MODREG(INS(INEXT,3)) 118 - ARGREF(INS(INEXT,4),1)=INS(INEXT,1) 119 - ARGREF(INS(INEXT,4),2)=INS(INEXT,3) 120 - *** Procedure calls. 121 - ELSEIF(INS(INEXT,2).EQ.9)THEN 122 - * Execute the procedure. 123 - CALL ALGCAL(INEXT,IFAIL1) 124 - IF(IFAIL1.NE.0)THEN 125 - NERR=NERR+1 126 - IF(LDEBUG)THEN 127 - WRITE(LUNOUT,'(1X,A)') ' ++++++ ALGEXE'// 128 - - ' DEBUG : Procedure call error in:' 129 - CALL ALGPRT(INEXT,INEXT) 130 - ENDIF 131 - IFAIL=1 132 - GOTO 3000 133 - ENDIF 134 - * Back transfer of arguments to origin registers and variables. 135 - DO 100 I=1,INS(INEXT,3) 136 - IF(ARGREF(I,1).GE.2)GOTO 100 137 - REG(ARGREF(I,2))=ARG(I) 138 - MODREG(ARGREF(I,2))=MODARG(I) 139 - IF(ARGREF(I,2).GE.1.AND. 140 - - ARGREF(I,2).LE.NVAR.AND. 141 - - ARGREF(I,2).LE.ALGENT(IENTNO,7))THEN 142 - C CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 143 - VAR(ARGREF(I,2))=ARG(I) 144 - MODVAR(ARGREF(I,2))=MODARG(I) 145 - ENDIF 146 - 100 CONTINUE 147 - *** RETURN, EXIT and QUIT instruction codes. 148 - ELSEIF(INS(INEXT,2).EQ.-9)THEN 149 - * Condition satisfied. 150 - IF(ABS(REG(INS(INEXT,1))-1).LT.EPS)THEN 151 - IF(INS(INEXT,3).EQ.0.OR.INS(INEXT,3).EQ.1)THEN 152 - INEXT=-1 153 - ELSEIF(INS(INEXT,3).EQ.2)THEN 154 - CALL QUIT 155 - ELSE 156 - IF(LDEBUG)THEN 157 - WRITE(LUNOUT,'(2X,A)') 158 - - '++++++ ALGEXE DEBUG : Unrecognised'// 159 - - ' RETURN option seen in the line:' 160 - CALL ALGPRT(INEXT,INEXT) 161 - WRITE(LUNOUT,'(26X,''Reg('',I3,'')='',E15.7, 162 - - ''; Reg('',I3,'')='',E15.7,/)') 163 - - INS(INEXT,1),REG(INS(INEXT,1)), 164 - - INS(INEXT,3),REG(INS(INEXT,3)) 165 - ENDIF 166 - IFAIL=1 167 - GOTO 3000 168 - ENDIF 169 - * Invalid logical. 170 - ELSEIF(ABS(REG(INS(INEXT,1))).GT.EPS)THEN 171 - IF(LDEBUG)THEN 172 - WRITE(LUNOUT,'(2X,A)') '++++++ ALGEXE DEBUG :'// 173 - - ' Logical value error detected in the line:' 174 - CALL ALGPRT(INEXT,INEXT) 175 - WRITE(LUNOUT,'(26X,''Reg('',I3,'')='',E15.7, 176 - - ''; Reg('',I3,'')='',E15.7,/)') 177 - - INS(INEXT,1),REG(INS(INEXT,1)), 178 - - INS(INEXT,3),REG(INS(INEXT,3)) 179 - ENDIF 1 97 P=ALGEBRA D=ALGEXE 3 PAGE 129 180 - IFAIL=1 181 - GOTO 3000 182 - ENDIF 183 - *** Algebraic instruction. 184 - ELSE 185 - IF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.0).OR. 186 - - (INS(INEXT,2).NE.6.AND.(MODREG(INS(INEXT,1)).EQ.0.OR. 187 - - MODREG(INS(INEXT,3)).EQ.0)))THEN 188 - CALL ALGEX0(INEXT,IFAIL) 189 - ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.2).OR. 190 - - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.2.AND. 191 - - MODREG(INS(INEXT,3)).EQ.2))THEN 192 - CALL ALGEX2(INEXT,IFAIL) 193 - ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.3).OR. 194 - - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.3.AND. 195 - - MODREG(INS(INEXT,3)).EQ.3))THEN 196 - CALL ALGEX3(INEXT,IFAIL) 197 - ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.1).OR. 198 - - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.1.AND. 199 - - MODREG(INS(INEXT,3)).EQ.1))THEN 200 - CALL ALGEX4(INEXT,IFAIL) 201 - ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.4).OR. 202 - - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.4.OR. 203 - - MODREG(INS(INEXT,3)).EQ.4))THEN 204 - CALL ALGEX5(INEXT,IFAIL) 205 - ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.5).OR. 206 - - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.5.OR. 207 - - MODREG(INS(INEXT,3)).EQ.5))THEN 208 - CALL ALGEX6(INEXT,IFAIL) 209 - ELSE 210 - PRINT *,' !!!!!! ALGEXE WARNING : Unable to evaluate'// 211 - - ' a variable because of mode incompatibility.' 212 - IF(LDEBUG)THEN 213 - WRITE(LUNOUT,'(26X,''Error occured in:'')') 214 - CALL ALGPRT(INEXT,INEXT) 215 - IF(INS(INEXT,2).NE.6)WRITE(LUNOUT,'(26X,''Reg '', 216 - - I3,'' = '',E15.7,'', Mode = '',I2,''.'')') 217 - - INS(INEXT,1),REG(INS(INEXT,1)), 218 - - MODREG(INS(INEXT,1)) 219 - WRITE(LUNOUT,'(26X,''Reg '', 220 - - I3,'' = '',E15.7,'', Mode = '',I2,''.'')') 221 - - INS(INEXT,3),REG(INS(INEXT,3)), 222 - - MODREG(INS(INEXT,3)) 223 - ENDIF 224 - GOTO 3000 225 - ENDIF 226 - IF(IFAIL.NE.0)NERR=NERR+1 227 - IF(IFAIL.NE.0.AND.LDEBUG)THEN 228 - WRITE(LUNOUT,'(1X,A)') ' ++++++ ALGEXE DEBUG :'// 229 - - ' Arithmetic error while evaluating:' 230 - CALL ALGPRT(INEXT,INEXT) 231 - IF(INS(INEXT,2).EQ.6)WRITE(LUNOUT,'(26X,''Reg('',I3, 232 - - '')='',E15.7,/)') INS(INEXT,3),REG(INS(INEXT,3)) 233 - IF(INS(INEXT,2).NE.6)WRITE(LUNOUT,'(26X,''Reg('',I3, 234 - - '')='',E15.7,''; Reg('',I3,'')='',E15.7,/)') 235 - - INS(INEXT,1),REG(INS(INEXT,1)), 236 - - INS(INEXT,3),REG(INS(INEXT,3)) 237 - IFAIL=1 238 - GOTO 3000 239 - ENDIF 240 - ENDIF 241 - *** Next instruction. 242 - GOTO 20 243 - *** Clean up temporary strings. 244 - 3000 CONTINUE 245 - * Loop over the instructions. 246 - DO 50 I=ALGENT(IENTNO,5),ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 247 - * Skip results and control statements. 248 - IF(INS(I,2).EQ.0.OR.INS(I,2).EQ.8)GOTO 50 249 - * Select lines that result in string type variables. 250 - IF(MODREG(INS(I,4)).NE.1)GOTO 70 251 - DO 60 J=I+1,ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 252 - IF(INS(J,2).EQ.0.AND.INS(J,3).EQ.INS(I,4))GOTO 70 253 - 60 CONTINUE 254 - DO 150 J=1,NGLB 255 - IF(GLBMOD(J).NE.1)GOTO 150 256 - IF(NINT(GLBVAL(J)).EQ.NINT(REG(INS(I,4))))GOTO 70 257 - 150 CONTINUE 258 - CALL STRBUF('DELETE',NINT(REG(INS(I,4))),DUMSTR,NCDUM,IFAIL1) 259 - 70 CONTINUE 260 - * Select lines that result in histogram type variables. 261 - IF(MODREG(INS(I,4)).NE.4)GOTO 80 262 - DO 90 J=I+1,ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 263 - IF(INS(J,2).EQ.0.AND.INS(J,3).EQ.INS(I,4))GOTO 80 264 - 90 CONTINUE 265 - DO 110 J=1,NGLB 266 - IF(GLBMOD(J).NE.4)GOTO 110 267 - IF(NINT(GLBVAL(J)).EQ.NINT(REG(INS(I,4))))GOTO 80 268 - 110 CONTINUE 269 - CALL HISADM('DELETE',NINT(REG(INS(I,4))),0,0.0,0.0,.FALSE.,IDUM) 270 - 80 CONTINUE 271 - * Select lines that result in matrix type variables. 272 - IF(MODREG(INS(I,4)).NE.5)GOTO 120 273 - DO 130 J=I+1,ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 274 - IF(INS(J,2).EQ.0.AND.INS(J,3).EQ.INS(I,4))GOTO 120 275 - 130 CONTINUE 276 - DO 140 J=1,NGLB 277 - IF(GLBMOD(J).NE.5)GOTO 140 278 - IF(NINT(GLBVAL(J)).EQ.NINT(REG(INS(I,4))))GOTO 120 279 - 140 CONTINUE 280 - CALL MATADM('DELETE',NINT(REG(INS(I,4))),0,IDUM,IDUM,IFAIL1) 281 - 120 CONTINUE 282 - * Next instruction. 283 - 50 CONTINUE 284 - END 1 98 GARFIELD ================================================== P=ALGEBRA D=AL2EXE 1 =================== PAGE 130 0 + +DECK,AL2EXE. 1 - SUBROUTINE AL2EXE(IENTRY,VAR,MODVAR,NVAR,RES,MODRES,NNRES,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * AL2EXE - Copy of ALGEXE, to avoid recursive calls. 4 - * (Last changed on 31/10/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,ALGDATA. 9.- +SEQ,GLOBALS. 10.- +SEQ,PRINTPLOT. 11 - REAL VAR(*),RES(*),EPS 12 - INTEGER MODVAR(*),MODRES(*),IENTRY,NVAR,NNRES,IFAIL,I,J,IENTNO, 13 - - INEXT,IDUM,NCDUM,IFAIL1 14 - CHARACTER*1 DUMSTR 15 - PARAMETER(EPS=1.0E-5) 16 - *** Output formats. 17 - 1060 FORMAT(26X,'REG(',I3,')=',E15.7:'; REG(',I3,')=',E15.7) 18 - *** Early returns mean evalution failed. 19 - IFAIL=1 20 - *** Save the current environment. 21 - CALL ALGSTC 22 - *** Assign zero to all expected results. 23 - DO 40 I=1,NNRES 24 - RES(I)=0.0 25 - MODRES(I)=0 26 - 40 CONTINUE 27 - *** Zero argument buffer. 28 - DO 160 I=1,MXARG 29 - ARG(I)=0.0 30 - MODARG(I)=0 31 - ARGREF(I,1)=0 32 - ARGREF(I,2)=0 33 - 160 CONTINUE 34 - *** Locate the entry point. 35 - IENTNO=0 36 - DO 30 I=1,NALGE 37 - IF(ALGENT(I,1).EQ.IENTRY)IENTNO=I 38 - 30 CONTINUE 39 - IF(IENTNO.EQ.0)THEN 40 - IF(LDEBUG)WRITE(LUNOUT,*) ' ++++++ AL2EXE DEBUG :'// 41 - - ' Requested entry point does not exist.' 42 - CALL ALGUST 43 - RETURN 44 - ENDIF 45 - IF(ALGENT(IENTNO,2).EQ.0.OR.ALGENT(IENTNO,3).EQ.0.OR. 46 - - ALGENT(IENTNO,7).GT.NVAR.OR. 47 - - (ALGENT(IENTNO,10).NE.0.AND.ALGENT(IENTNO,10).GT.NNRES))THEN 48 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ AL2EXE DEBUG :'', 49 - - '' List for entry point is not executable.''/ 50 - - 26X,''Serial number='',I4,'', Reference number='',I4/ 51 - - 26X,''In use='',I1,'', List correct='',I1, 52 - - '', Sequential='',I1/ 53 - - 26X,''First instruction='',I4,'', # instructions='',I4/ 54 - - 26X,''# variables expected='',I4,'' (given='',I4,'')''/ 55 - - 26X,''First constant='',I4,'', # constants='',I4/ 56 - - 26X,''# results from list='',I4,'' (expected='',I4, 57 - - '').'')') 58 - - IENTNO,(ALGENT(IENTNO,I),I=1,7),NVAR, 59 - - (ALGENT(IENTNO,I),I=8,10),NNRES 60 - CALL ALGUST 61 - RETURN 62 - ENDIF 63 - *** First assign the values of the variables to REG. 64 - DO 10 I=1,MXREG 65 - IF(I.LE.NVAR.AND.I.LE.ALGENT(IENTNO,7))THEN 66 - REG(I)=VAR(I) 67 - MODREG(I)=MODVAR(I) 68 - ELSE 69 - REG(I)=0 70 - MODREG(I)=0 71 - ENDIF 72 - 10 CONTINUE 73 - IFAIL=0 74 - *** Execute all the instructions. 75 - INEXT=ALGENT(IENTNO,5)-1 76 - 20 CONTINUE 77 - INEXT=INEXT+1 78 - *** Return at the end of the list and if INEXT has been set to 0. 79 - IF(INEXT.GT.ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1.OR. 80 - - INEXT.EQ.0)GOTO 3000 81 - *** Lines of the result-assignment type. 82 - IF(INS(INEXT,2).EQ.0)THEN 83 - IF(INS(INEXT,4).LT.1.OR.INS(INEXT,4).GT.NNRES)THEN 84 - IFAIL=1 85 - IF(LDEBUG)WRITE(LUNOUT,'(1X,A,I3,A)') 86 - - ' ++++++ AL2EXE DEBUG : No room for result'// 87 - - ' produced at line ',INEXT,' in receiving array.' 88 - GOTO 3000 89 - ELSE 90 - RES(INS(INEXT,4))=REG(INS(INEXT,3)) 91 - MODRES(INS(INEXT,4))=MODREG(INS(INEXT,3)) 92 - ENDIF 93 - *** GOTO statement. 94 - ELSEIF(INS(INEXT,2).EQ.7)THEN 95 - IF(ABS(REG(INS(INEXT,1))-1).LT.EPS)THEN 96 - INEXT=NINT(REG(INS(INEXT,3)))-1 97 - ELSEIF(ABS(REG(INS(INEXT,1))).GT.EPS)THEN 98 - IF(LDEBUG)THEN 99 - WRITE(LUNOUT,'(2X,A)') '++++++ AL2EXE DEBUG :'// 100 - - ' Logical value error at the line:' 101 - CALL ALGPRT(INEXT,INEXT) 102 - WRITE(LUNOUT,'(26X,''Reg('',I3,'')='',E15.7, 103 - - ''; Reg('',I3,'')='',E15.7,/)') 104 - - INS(INEXT,1),REG(INS(INEXT,1)), 105 - - INS(INEXT,3),REG(INS(INEXT,3)) 1 98 P=ALGEBRA D=AL2EXE 2 PAGE 131 106 - ENDIF 107 - IFAIL=1 108 - GOTO 3000 109 - ENDIF 110 - *** Arguments. 111 - ELSEIF(INS(INEXT,2).EQ.8)THEN 112 - IF(INS(INEXT,4).LE.0.OR.INS(INEXT,4).GT.MXARG)THEN 113 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ AL2EXE DEBUG :'', 114 - - '' Invalid argument # '',I3,'' found in line '', 115 - - I3,'':'')') INS(INEXT,4),INEXT 116 - IF(LDEBUG)CALL ALGPRT(INEXT,INEXT) 117 - IFAIL=1 118 - GOTO 3000 119 - ENDIF 120 - ARG(INS(INEXT,4))=REG(INS(INEXT,3)) 121 - MODARG(INS(INEXT,4))=MODREG(INS(INEXT,3)) 122 - ARGREF(INS(INEXT,4),1)=INS(INEXT,1) 123 - ARGREF(INS(INEXT,4),2)=INS(INEXT,3) 124 - *** Procedure calls. 125 - ELSEIF(INS(INEXT,2).EQ.9)THEN 126 - * Execute the procedure. 127 - CALL ALGCAL(INEXT,IFAIL1) 128 - IF(IFAIL1.NE.0)THEN 129 - NERR=NERR+1 130 - IF(LDEBUG)THEN 131 - WRITE(LUNOUT,'(1X,A)') ' ++++++ AL2EXE'// 132 - - ' DEBUG : Procedure call error in:' 133 - CALL ALGPRT(INEXT,INEXT) 134 - ENDIF 135 - IFAIL=1 136 - GOTO 3000 137 - ENDIF 138 - * Back transfer of arguments to origin registers and variables. 139 - DO 100 I=1,INS(INEXT,3) 140 - IF(ARGREF(I,1).GE.2)GOTO 100 141 - REG(ARGREF(I,2))=ARG(I) 142 - MODREG(ARGREF(I,2))=MODARG(I) 143 - IF(ARGREF(I,2).GE.1.AND. 144 - - ARGREF(I,2).LE.NVAR.AND. 145 - - ARGREF(I,2).LE.ALGENT(IENTNO,7))THEN 146 - C CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 147 - VAR(ARGREF(I,2))=ARG(I) 148 - MODVAR(ARGREF(I,2))=MODARG(I) 149 - ENDIF 150 - 100 CONTINUE 151 - *** RETURN, EXIT and QUIT instruction codes. 152 - ELSEIF(INS(INEXT,2).EQ.-9)THEN 153 - * Condition satisfied. 154 - IF(ABS(REG(INS(INEXT,1))-1).LT.EPS)THEN 155 - IF(INS(INEXT,3).EQ.0.OR.INS(INEXT,3).EQ.1)THEN 156 - INEXT=-1 157 - ELSEIF(INS(INEXT,3).EQ.2)THEN 158 - CALL QUIT 159 - ELSE 160 - IF(LDEBUG)THEN 161 - WRITE(LUNOUT,'(2X,A)') 162 - - '++++++ AL2EXE DEBUG : Unrecognised'// 163 - - ' RETURN option seen in the line:' 164 - CALL ALGPRT(INEXT,INEXT) 165 - WRITE(LUNOUT,'(26X,''Reg('',I3,'')='',E15.7, 166 - - ''; Reg('',I3,'')='',E15.7,/)') 167 - - INS(INEXT,1),REG(INS(INEXT,1)), 168 - - INS(INEXT,3),REG(INS(INEXT,3)) 169 - ENDIF 170 - IFAIL=1 171 - GOTO 3000 172 - ENDIF 173 - * Invalid logical. 174 - ELSEIF(ABS(REG(INS(INEXT,1))).GT.EPS)THEN 175 - IF(LDEBUG)THEN 176 - WRITE(LUNOUT,'(2X,A)') '++++++ AL2EXE DEBUG :'// 177 - - ' Logical value error detected in the line:' 178 - CALL ALGPRT(INEXT,INEXT) 179 - WRITE(LUNOUT,'(26X,''Reg('',I3,'')='',E15.7, 180 - - ''; Reg('',I3,'')='',E15.7,/)') 181 - - INS(INEXT,1),REG(INS(INEXT,1)), 182 - - INS(INEXT,3),REG(INS(INEXT,3)) 183 - ENDIF 184 - IFAIL=1 185 - GOTO 3000 186 - ENDIF 187 - *** Algebraic instruction. 188 - ELSE 189 - IF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.0).OR. 190 - - (INS(INEXT,2).NE.6.AND.(MODREG(INS(INEXT,1)).EQ.0.OR. 191 - - MODREG(INS(INEXT,3)).EQ.0)))THEN 192 - CALL ALGEX0(INEXT,IFAIL) 193 - ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.2).OR. 194 - - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.2.AND. 195 - - MODREG(INS(INEXT,3)).EQ.2))THEN 196 - CALL ALGEX2(INEXT,IFAIL) 197 - ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.3).OR. 198 - - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.3.AND. 199 - - MODREG(INS(INEXT,3)).EQ.3))THEN 200 - CALL ALGEX3(INEXT,IFAIL) 201 - ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.1).OR. 202 - - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.1.AND. 203 - - MODREG(INS(INEXT,3)).EQ.1))THEN 204 - CALL ALGEX4(INEXT,IFAIL) 205 - ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.4).OR. 206 - - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.4.OR. 207 - - MODREG(INS(INEXT,3)).EQ.4))THEN 208 - CALL ALGEX5(INEXT,IFAIL) 209 - ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.5).OR. 210 - - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.5.OR. 211 - - MODREG(INS(INEXT,3)).EQ.5))THEN 1 98 P=ALGEBRA D=AL2EXE 3 PAGE 132 212 - CALL ALGEX6(INEXT,IFAIL) 213 - ELSE 214 - PRINT *,' !!!!!! AL2EXE WARNING : Unable to evaluate'// 215 - - ' a variable because of mode incompatibility.' 216 - IF(LDEBUG)THEN 217 - WRITE(LUNOUT,'(26X,''Error occured in:'')') 218 - CALL ALGPRT(INEXT,INEXT) 219 - IF(INS(INEXT,2).NE.6)WRITE(LUNOUT,'(26X,''Reg '', 220 - - I3,'' = '',E15.7,'', Mode = '',I2,''.'')') 221 - - INS(INEXT,1),REG(INS(INEXT,1)), 222 - - MODREG(INS(INEXT,1)) 223 - WRITE(LUNOUT,'(26X,''Reg '', 224 - - I3,'' = '',E15.7,'', Mode = '',I2,''.'')') 225 - - INS(INEXT,3),REG(INS(INEXT,3)), 226 - - MODREG(INS(INEXT,3)) 227 - ENDIF 228 - GOTO 3000 229 - ENDIF 230 - IF(IFAIL.NE.0)NERR=NERR+1 231 - IF(IFAIL.NE.0.AND.LDEBUG)THEN 232 - WRITE(LUNOUT,'(1X,A)') ' ++++++ AL2EXE DEBUG :'// 233 - - ' Arithmetic error while evaluating:' 234 - CALL ALGPRT(INEXT,INEXT) 235 - IF(INS(INEXT,2).EQ.6)WRITE(LUNOUT,'(26X,''Reg('',I3, 236 - - '')='',E15.7,/)') INS(INEXT,3),REG(INS(INEXT,3)) 237 - IF(INS(INEXT,2).NE.6)WRITE(LUNOUT,'(26X,''Reg('',I3, 238 - - '')='',E15.7,''; Reg('',I3,'')='',E15.7,/)') 239 - - INS(INEXT,1),REG(INS(INEXT,1)), 240 - - INS(INEXT,3),REG(INS(INEXT,3)) 241 - IFAIL=1 242 - GOTO 3000 243 - ENDIF 244 - ENDIF 245 - *** Next instruction. 246 - GOTO 20 247 - *** Clean up temporary strings. 248 - 3000 CONTINUE 249 - * Loop over the instructions. 250 - DO 50 I=ALGENT(IENTNO,5),ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 251 - * Skip results and control statements. 252 - IF(INS(I,2).EQ.0.OR.INS(I,2).EQ.8)GOTO 50 253 - * Select lines that result in string type variables. 254 - IF(MODREG(INS(I,4)).NE.1)GOTO 70 255 - DO 60 J=I+1,ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 256 - IF(INS(J,2).EQ.0.AND.INS(J,3).EQ.INS(I,4))GOTO 70 257 - 60 CONTINUE 258 - DO 150 J=1,NGLB 259 - IF(GLBMOD(J).NE.1)GOTO 150 260 - IF(NINT(GLBVAL(J)).EQ.NINT(REG(INS(I,4))))GOTO 70 261 - 150 CONTINUE 262 - CALL STRBUF('DELETE',NINT(REG(INS(I,4))),DUMSTR,NCDUM,IFAIL1) 263 - 70 CONTINUE 264 - * Select lines that result in histogram type variables. 265 - IF(MODREG(INS(I,4)).NE.4)GOTO 80 266 - DO 90 J=I+1,ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 267 - IF(INS(J,2).EQ.0.AND.INS(J,3).EQ.INS(I,4))GOTO 80 268 - 90 CONTINUE 269 - DO 110 J=1,NGLB 270 - IF(GLBMOD(J).NE.4)GOTO 110 271 - IF(NINT(GLBVAL(J)).EQ.NINT(REG(INS(I,4))))GOTO 80 272 - 110 CONTINUE 273 - CALL HISADM('DELETE',NINT(REG(INS(I,4))),0,0.0,0.0,.FALSE.,IDUM) 274 - 80 CONTINUE 275 - * Select lines that result in matrix type variables. 276 - IF(MODREG(INS(I,4)).NE.5)GOTO 120 277 - DO 130 J=I+1,ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 278 - IF(INS(J,2).EQ.0.AND.INS(J,3).EQ.INS(I,4))GOTO 120 279 - 130 CONTINUE 280 - DO 140 J=1,NGLB 281 - IF(GLBMOD(J).NE.5)GOTO 140 282 - IF(NINT(GLBVAL(J)).EQ.NINT(REG(INS(I,4))))GOTO 120 283 - 140 CONTINUE 284 - CALL MATADM('DELETE',NINT(REG(INS(I,4))),0,IDUM,IDUM,IFAIL1) 285 - 120 CONTINUE 286 - * Next instruction. 287 - 50 CONTINUE 288 - *** Restore environment. 289 - CALL ALGUST 290 - END 99 GARFIELD ================================================== P=ALGEBRA D=ALGEX0 1 ============================ 0 + +DECK,ALGEX0. 1 - SUBROUTINE ALGEX0(I,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * ALGEX0 - Routine executing instructions on arguments of 4 - * undefined type. 5 - * (Last changed on 12/ 9/99.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,ALGDATA. 10 - INTEGER I,IFAIL,IREF 11 - *** Assume the routine will fail. 12 - IFAIL=1 13 - *** Function call: type of argument. 14 - IF(INS(I,2).EQ.6.AND.(INS(I,1).EQ.12.OR.INS(I,1).EQ.17))THEN 15 - CALL STRBUF('STORE',IREF,'Undefined',9,IFAIL) 16 - IF(IFAIL.NE.0)RETURN 17 - REG(INS(I,4))=IREF 18 - MODREG(INS(I,4))=1 19 - *** No other functions known. 20 - ELSE 21 - REG(INS(I,4))=0 22 - MODREG(INS(I,4))=0 23 - ENDIF 1 99 P=ALGEBRA D=ALGEX0 2 PAGE 133 24 - *** Reset IFAIL to 0 because the exercise was probably successful. 25 - IFAIL=0 26 - END 100 GARFIELD ================================================== P=ALGEBRA D=ALGEX2 1 ============================ 0 + +DECK,ALGEX2. 1 - SUBROUTINE ALGEX2(I,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * ALGEX2 - Routine executing instruction I (produced by ALGPRE). 4 - * This routine takes care of arithmetic operations between 5 - * reals (and for the time being also of logicals). 6 - * (Last changed on 18/ 3/01.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,ALGDATA. 11.- +SEQ,MATDATA. 12 - EXTERNAL RNDUNI,RANLAN,RNDEXP,RNDNOR,RNDPOL,RNDFUN,DENLAN 13 - REAL RNDUNI,RANLAN,RNDEXP,RNDNOR,RNDPOL,RNDFUN,DENLAN,EPS 14 - INTEGER I,IFAIL,IFAIL1,NPOIS,IERR,NCAUX,IREF,ISIZ(1),ISLOT,MATSLT 15 - CHARACTER*20 AUXSTR 16 - EXTERNAL MATSLT 17 - *** Set IFAIL to 1 and EPS. 18 - IFAIL=1 0 19-+ +SELF,IF=CRAY. 20 - EPS=1.0E-10 0 21-+ +SELF,IF=-CRAY. 22 - EPS=1.0E-5 0 23-+ +SELF. 24 - *** Initial value is zero for any result. 25 - REG(INS(I,4))=0.0 26 - *** Perform the actual calculation: binary numerical operators. 27 - IF(INS(I,2).EQ.1)THEN 28 - REG(INS(I,4))=REG(INS(I,1))+REG(INS(I,3)) 29 - MODREG(INS(I,4))=2 30 - ELSEIF(INS(I,2).EQ.2)THEN 31 - REG(INS(I,4))=REG(INS(I,1))-REG(INS(I,3)) 32 - MODREG(INS(I,4))=2 33 - ELSEIF(INS(I,2).EQ.3)THEN 34 - REG(INS(I,4))=REG(INS(I,1))*REG(INS(I,3)) 35 - MODREG(INS(I,4))=2 36 - ELSEIF(INS(I,2).EQ.4)THEN 37 - MODREG(INS(I,4))=2 38 - IF(REG(INS(I,3)).EQ.0.0)THEN 39 - NAERR(1)=NAERR(1)+1 40 - RETURN 41 - ENDIF 42 - REG(INS(I,4))=REG(INS(I,1))/REG(INS(I,3)) 43 - ELSEIF(INS(I,2).EQ.5)THEN 44 - MODREG(INS(I,4))=2 45 - IF(ABS(REG(INS(I,3))-NINT(REG(INS(I,3)))).LT.EPS)THEN 46 - IF(NINT(REG(INS(I,3))).LE.0.AND.REG(INS(I,1)).EQ.0)THEN 47 - RETURN 48 - ELSEIF(2*(NINT(REG(INS(I,3)))/2).EQ. 49 - - NINT(REG(INS(I,3))))THEN 50 - REG(INS(I,4))=ABS(REG(INS(I,1)))** 51 - - NINT(REG(INS(I,3))) 52 - ELSE 53 - REG(INS(I,4))=SIGN(ABS(REG(INS(I,1)))** 54 - - NINT(REG(INS(I,3))),REG(INS(I,1))) 55 - ENDIF 56 - ELSEIF(REG(INS(I,1)).GT.0)THEN 57 - REG(INS(I,4))=REG(INS(I,1))**REG(INS(I,3)) 58 - ELSE 59 - NAERR(11)=NAERR(11)+1 60 - RETURN 61 - ENDIF 62 - *** Numerical function calls. 63 - ELSEIF(INS(I,2).EQ.6)THEN 64 - * Exponential and log. 65 - MODREG(INS(I,4))=2 66 - IF(INS(I,1).EQ. 1)THEN 67 - IF(REG(INS(I,3)).GT.88.0)THEN 68 - NAERR(2)=NAERR(2)+1 69 - RETURN 70 - ELSEIF(REG(INS(I,3)).LT.-88.0)THEN 71 - IF(LIGUND)THEN 72 - REG(INS(I,4))=0 73 - ELSE 74 - NAERR(3)=NAERR(3)+1 75 - RETURN 76 - ENDIF 77 - ELSE 78 - REG(INS(I,4))=EXP(REG(INS(I,3))) 79 - ENDIF 80 - ELSEIF(INS(I,1).EQ.-1)THEN 81 - IF(REG(INS(I,3)).LE.0.0)THEN 82 - NAERR(4)=NAERR(4)+1 83 - RETURN 84 - ENDIF 85 - REG(INS(I,4))=LOG(REG(INS(I,3))) 86 - * Trigonometric. 87 - ELSEIF(INS(I,1).EQ. 2)THEN 88 - REG(INS(I,4))= SIN(REG(INS(I,3))) 89 - ELSEIF(INS(I,1).EQ.-2)THEN 90 - IF(ABS(REG(INS(I,3))).GT.1.0)THEN 91 - NAERR(5)=NAERR(5)+1 92 - RETURN 93 - ENDIF 94 - REG(INS(I,4))= ASIN(REG(INS(I,3))) 95 - ELSEIF(INS(I,1).EQ. 3)THEN 96 - REG(INS(I,4))= COS(REG(INS(I,3))) 1 100 P=ALGEBRA D=ALGEX2 2 PAGE 134 97 - ELSEIF(INS(I,1).EQ.-3)THEN 98 - IF(ABS(REG(INS(I,3))).GT.1.0)THEN 99 - NAERR(5)=NAERR(5)+1 100 - RETURN 101 - ENDIF 102 - REG(INS(I,4))= ACOS(REG(INS(I,3))) 103 - ELSEIF(INS(I,1).EQ. 4)THEN 104 - REG(INS(I,4))= TAN(REG(INS(I,3))) 105 - ELSEIF(INS(I,1).EQ.-4)THEN 106 - REG(INS(I,4))= ATAN(REG(INS(I,3))) 107 - * Absolute value. 108 - ELSEIF(INS(I,1).EQ. 5)THEN 109 - REG(INS(I,4))= ABS(REG(INS(I,3))) 110 - * Square root. 111 - ELSEIF(INS(I,1).EQ.-5)THEN 112 - IF(REG(INS(I,3)).LT.0.0)THEN 113 - NAERR(6)=NAERR(6)+1 114 - RETURN 115 - ENDIF 116 - REG(INS(I,4))=SQRT(REG(INS(I,3))) 117 - * Assignments and negatives. 118 - ELSEIF(INS(I,1).EQ. 6)THEN 119 - REG(INS(I,4))= REG(INS(I,3)) 120 - ELSEIF(INS(I,1).EQ.-6)THEN 121 - REG(INS(I,4))= -REG(INS(I,3)) 122 - * Hyperbolic trigonometry. 123 - ELSEIF(INS(I,1).EQ. 7)THEN 124 - REG(INS(I,4))= SINH(REG(INS(I,3))) 125 - ELSEIF(INS(I,1).EQ.-7)THEN 126 - REG(INS(I,4))=LOG(REG(INS(I,3))+ 127 - - SQRT(1+REG(INS(I,3))**2)) 128 - ELSEIF(INS(I,1).EQ. 8)THEN 129 - REG(INS(I,4))= COSH(REG(INS(I,3))) 130 - ELSEIF(INS(I,1).EQ.-8)THEN 131 - IF(REG(INS(I,3)).LT.1)THEN 132 - NAERR(7)=NAERR(7)+1 133 - RETURN 134 - ENDIF 135 - REG(INS(I,4))=LOG(REG(INS(I,3))+ 136 - - SQRT(REG(INS(I,3))**2-1)) 137 - ELSEIF(INS(I,1).EQ. 9)THEN 138 - REG(INS(I,4))= TANH(REG(INS(I,3))) 139 - ELSEIF(INS(I,1).EQ.-9)THEN 140 - IF(REG(INS(I,3)).LE.-1.0.OR.REG(INS(I,3)).GE.1.0)THEN 141 - NAERR(8)=NAERR(8)+1 142 - RETURN 143 - ENDIF 144 - REG(INS(I,4))=0.5*LOG((1+REG(INS(I,3)))/ 145 - - (1-REG(INS(I,3)))) 146 - * Landau distribution. 147 - ELSEIF(INS(I,1).EQ.18)THEN 148 - REG(INS(I,4))=DENLAN(REG(INS(I,3))) 149 - * Make a string from a number. 150 - ELSEIF(INS(I,1).EQ.12)THEN 151 - CALL OUTFMT(REG(INS(I,3)),MODREG(INS(I,3)), 152 - - AUXSTR,NCAUX,'LEFT') 153 - CALL STRBUF('STORE',IREF,AUXSTR(1:NCAUX),NCAUX,IFAIL) 154 - IF(IFAIL.NE.0)THEN 155 - NAERR(9)=NAERR(9)+1 156 - RETURN 157 - ENDIF 158 - MODREG(INS(I,4))=1 159 - REG(INS(I,4))=IREF 160 - * Return the type of the argument. 161 - ELSEIF(INS(I,1).EQ.17)THEN 162 - CALL STRBUF('STORE',IREF,'Number',6,IFAIL) 163 - IF(IFAIL.NE.0)THEN 164 - NAERR(9)=NAERR(9)+1 165 - RETURN 166 - ENDIF 167 - REG(INS(I,4))=IREF 168 - MODREG(INS(I,4))=1 169 - * Make a number from a number. 170 - ELSEIF(INS(I,1).EQ.-12)THEN 171 - REG(INS(I,4))=REG(INS(I,3)) 172 - MODREG(INS(I,4))=2 173 - * Truncation of a real number. 174 - ELSEIF(INS(I,1).EQ.11)THEN 175 - REG(INS(I,4))=INT(REG(INS(I,3))) 176 - IF(REG(INS(I,3)).LT.0)REG(INS(I,4))=REG(INS(I,4))-1.0 177 - ELSEIF(INS(I,1).EQ.-11)THEN 178 - REG(INS(I,4))=REG(INS(I,3))-INT(REG(INS(I,3))) 179 - IF(REG(INS(I,3)).LT.0)REG(INS(I,4))=REG(INS(I,4))+1.0 180 - * Return strings by reference. 181 - ELSEIF(INS(I,1).EQ.51)THEN 182 - REG(INS(I,4))=REG(INS(I,3)) 183 - MODREG(INS(I,4))=1 184 - * Return histograms by reference. 185 - ELSEIF(INS(I,1).EQ.54)THEN 186 - REG(INS(I,4))=REG(INS(I,3)) 187 - MODREG(INS(I,4))=4 188 - * Return matrices by reference. 189 - ELSEIF(INS(I,1).EQ.55)THEN 190 - REG(INS(I,4))=REG(INS(I,3)) 191 - MODREG(INS(I,4))=5 192 - * Random number generators. 193 - ELSEIF(INS(I,1).EQ.21)THEN 194 - REG(INS(I,4))=RNDUNI(REG(INS(I,3))) 195 - ELSEIF(INS(I,1).EQ.22)THEN 196 - REG(INS(I,4))=RNDNOR(0.0,1.0) 197 - ELSEIF(INS(I,1).EQ.23)THEN 198 - REG(INS(I,4))=RNDEXP(REG(INS(I,3))) 199 - ELSEIF(INS(I,1).EQ.24)THEN 200 - CALL RNPSSN(REG(INS(I,3)),NPOIS,IERR) 201 - REG(INS(I,4))=REAL(NPOIS) 202 - ELSEIF(INS(I,1).EQ.25)THEN 1 100 P=ALGEBRA D=ALGEX2 3 PAGE 135 203 - REG(INS(I,4))=RANLAN(RNDUNI(1.0)) 204 - ELSEIF(INS(I,1).EQ.26)THEN 205 - REG(INS(I,4))=RNDPOL(REG(INS(I,3))) 206 - ELSEIF(INS(I,1).EQ.27)THEN 207 - REG(INS(I,4))=RNDFUN(REG(INS(I,3))) 208 - * A row of integers. 209 - ELSEIF(INS(I,1).EQ.40)THEN 210 - ISIZ(1)=NINT(REG(INS(I,3))) 211 - CALL MATADM('ALLOCATE',IREF,1,ISIZ,2,IFAIL1) 212 - IF(IFAIL1.NE.0)RETURN 213 - REG(INS(I,4))=REAL(IREF) 214 - MODREG(INS(I,4))=5 215 - * Unidentified. 216 - ELSE 217 - MODREG(INS(I,4))=0 218 - NAERR(10)=NAERR(10)+1 219 - RETURN 220 - ENDIF 221 - *** Binary logical operators between real type arguments. 222 - ELSEIF(INS(I,2).EQ.10)THEN 223 - MODREG(INS(I,4))=3 224 - REG(INS(I,4))=0.0 225 - IF(ABS(REG(INS(I,1))-REG(INS(I,3))).LT.EPS)REG(INS(I,4))=1.0 226 - ELSEIF(INS(I,2).EQ.11)THEN 227 - MODREG(INS(I,4))=3 228 - REG(INS(I,4))=0.0 229 - IF(ABS(REG(INS(I,1))-REG(INS(I,3))).GT.EPS)REG(INS(I,4))=1.0 230 - ELSEIF(INS(I,2).EQ.12)THEN 231 - MODREG(INS(I,4))=3 232 - REG(INS(I,4))=0.0 233 - IF(REG(INS(I,1)).LT.REG(INS(I,3)))REG(INS(I,4))=1.0 234 - ELSEIF(INS(I,2).EQ.13)THEN 235 - MODREG(INS(I,4))=3 236 - REG(INS(I,4))=0.0 237 - IF(REG(INS(I,1)).LE.REG(INS(I,3)))REG(INS(I,4))=1.0 238 - ELSEIF(INS(I,2).EQ.14)THEN 239 - MODREG(INS(I,4))=3 240 - REG(INS(I,4))=0.0 241 - IF(REG(INS(I,1)).GT.REG(INS(I,3)))REG(INS(I,4))=1.0 242 - ELSEIF(INS(I,2).EQ.15)THEN 243 - MODREG(INS(I,4))=3 244 - REG(INS(I,4))=0.0 245 - IF(REG(INS(I,1)).GE.REG(INS(I,3)))REG(INS(I,4))=1.0 246 - *** Concatenate the 2 arguments to form a Matrix. 247 - ELSEIF(INS(I,2).EQ.16)THEN 248 - ISIZ(1)=2 249 - CALL MATADM('ALLOCATE',IREF,1,ISIZ,2,IFAIL1) 250 - IF(IFAIL1.NE.0)RETURN 251 - REG(INS(I,4))=REAL(IREF) 252 - MODREG(INS(I,4))=5 253 - ISLOT=MATSLT(IREF) 254 - MVEC(MORG(ISLOT)+1)=REG(INS(I,1)) 255 - MVEC(MORG(ISLOT)+2)=REG(INS(I,3)) 256 - *** Unidentified operation code. 257 - ELSE 258 - MODREG(INS(I,4))=0 259 - NAERR(10)=NAERR(10)+1 260 - RETURN 261 - ENDIF 262 - *** Reset IFAIL to 0 because the calculations were probably successful. 263 - IFAIL=0 264 - END 101 GARFIELD ================================================== P=ALGEBRA D=ALGEX3 1 ============================ 0 + +DECK,ALGEX3. 1 - SUBROUTINE ALGEX3(I,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * ALGEX3 - Routine executing instruction I (produced by ALGPRE). 4 - * This routine takes care of operations on logicals. 5 - * (Last changed on 4/ 3/94.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,ALGDATA. 10 - INTEGER I,IFAIL,IREF,NCAUX 11 - REAL EPS 12 - CHARACTER*20 AUXSTR 13 - *** Set IFAIL to 1 and EPS to 1.0E-5. 14 - IFAIL=1 15 - EPS=1.0E-5 16 - *** Logical function call. 17 - IF(INS(I,2).EQ.6)THEN 18 - IF(INS(I,1).EQ.10)THEN 19 - IF(ABS(REG(INS(I,3))).GT.EPS.AND. 20 - - ABS(REG(INS(I,3))-1.0).GT.EPS)RETURN 21 - REG(INS(I,4))=1.0-REG(INS(I,3)) 22 - MODREG(INS(I,4))=3 23 - * Make a string from a logical. 24 - ELSEIF(INS(I,1).EQ.12)THEN 25 - CALL OUTFMT(REG(INS(I,3)),MODREG(INS(I,3)), 26 - - AUXSTR,NCAUX,'LEFT') 27 - CALL STRBUF('STORE',IREF,AUXSTR(1:NCAUX),NCAUX,IFAIL) 28 - IF(IFAIL.NE.0)RETURN 29 - MODREG(INS(I,4))=1 30 - REG(INS(I,4))=IREF 31 - * Return the type of the argument. 32 - ELSEIF(INS(I,1).EQ.17)THEN 33 - CALL STRBUF('STORE',IREF,'Logical',7,IFAIL) 34 - IF(IFAIL.NE.0)RETURN 35 - REG(INS(I,4))=IREF 36 - MODREG(INS(I,4))=1 37 - * No other functions are known. 38 - ELSE 39 - RETURN 40 - ENDIF 1 101 P=ALGEBRA D=ALGEX3 2 PAGE 136 41 - *** Binary logical operators between logical type arguments. 42 - ELSEIF((INS(I,2).GE.1.AND.INS(I,2).LE.3).OR. 43 - - (INS(I,2).GE.10.AND.INS(I,2).LE.11).OR. 44 - - (INS(I,2).GE.16.AND.INS(I,2).LE.17))THEN 45 - * Check that the numbers are really logicals. 46 - IF((ABS(REG(INS(I,1))-1.0).GT.EPS.AND. 47 - - ABS(REG(INS(I,1))).GT.EPS).OR. 48 - - (ABS(REG(INS(I,3))-1.0).GT.EPS.AND. 49 - - ABS(REG(INS(I,3))).GT.EPS))RETURN 50 - * Or. 51 - IF(INS(I,2).EQ.17.OR.INS(I,2).EQ.1) 52 - - REG(INS(I,4))=MIN(1.0,REG(INS(I,1))+REG(INS(I,3))) 53 - * Exclusive or. 54 - IF(INS(I,2).EQ.2) 55 - - REG(INS(I,4))=MOD(REG(INS(I,1))+REG(INS(I,3)),2.0) 56 - * And. 57 - IF(INS(I,2).EQ.16.OR.INS(I,2).EQ.3) 58 - - REG(INS(I,4))=REG(INS(I,1))*REG(INS(I,3)) 59 - * Equivalence. 60 - IF(INS(I,2).EQ.10)REG(INS(I,4))= 61 - - REG(INS(I,1))*REG(INS(I,3))+ 62 - - (1-REG(INS(I,1)))*(1-REG(INS(I,3))) 63 - * Non-equivalence. 64 - IF(INS(I,2).EQ.11)REG(INS(I,4))= 65 - - (1-REG(INS(I,1)))*REG(INS(I,3))+ 66 - - REG(INS(I,1))*(1-REG(INS(I,3))) 67 - * Round the result to the nearest whole number. 68 - REG(INS(I,4))=ANINT(REG(INS(I,4))) 69 - * Propagate mode. 70 - MODREG(INS(I,4))=3 71 - *** Unidentified operation code. 72 - ELSE 73 - RETURN 74 - ENDIF 75 - *** Reset IFAIL to 0 because the calculations were probably successful. 76 - IFAIL=0 77 - END 102 GARFIELD ================================================== P=ALGEBRA D=ALGEX4 1 ============================ 0 + +DECK,ALGEX4. 1 - SUBROUTINE ALGEX4(I,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * ALGEX4 - Routine executing instruction I (produced by ALGPRE). 4 - * This routine takes care of operations on characters. 5 - * (Last changed on 18/ 3/01.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,ALGDATA. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,GLOBALS. 12 - INTEGER I,J,IFAIL,IFAIL1,IFAIL2,IFAIL3,NC1,NC2,IREF 13 - CHARACTER*(MXINCH) STR1,STR2 14 - *** Set IFAIL to 1. 15 - IFAIL=1 16 - *** Binary operations, concatenation. 17 - IF(INS(I,2).EQ.1.OR.INS(I,2).EQ.4.OR.INS(I,2).EQ.16)THEN 18 - * Fetch the strings. 19 - CALL STRBUF('READ',NINT(REG(INS(I,1))),STR1,NC1,IFAIL1) 20 - CALL STRBUF('READ',NINT(REG(INS(I,3))),STR2,NC2,IFAIL2) 21 - * Depending on whether one or both have 0 length, concatenate. 22 - IF(NC1.GT.0.AND.NC2.GT.0)THEN 23 - CALL STRBUF('STORE',IREF,STR1(1:NC1)//STR2(1:NC2), 24 - - NC1+NC2,IFAIL3) 25 - ELSEIF(NC1.GT.0)THEN 26 - CALL STRBUF('STORE',IREF,STR1(1:NC1),NC1,IFAIL3) 27 - ELSEIF(NC2.GT.0)THEN 28 - CALL STRBUF('STORE',IREF,STR2(1:NC2),NC2,IFAIL3) 29 - ELSE 30 - CALL STRBUF('STORE',IREF,' ',0,IFAIL3) 31 - ENDIF 32 - * Store the result. 33 - REG(INS(I,4))=IREF 34 - MODREG(INS(I,4))=1 35 - * Check error flag. 36 - IF(IFAIL1+IFAIL2+IFAIL3.NE.0)THEN 37 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEX4 DEBUG :'', 38 - - '' String buffer operation error:'',26X, 39 - - '' Fetch: '',2I2,'' Store: '',I2)') 40 - - IFAIL1,IFAIL2,IFAIL3 41 - RETURN 42 - ENDIF 43 - * Minus 44 - * ELSEIF(INS(I,2).EQ.2)THEN 45 - * Product 46 - * ELSEIF(INS(I,2).EQ.3)THEN 47 - * Exponentiation 48 - * ELSEIF(INS(I,2).EQ.5)THEN 49 - *** Function calls. 50 - ELSEIF(INS(I,2).EQ.6)THEN 51 - * Make a string from a string. 52 - IF(INS(I,1).EQ.12)THEN 53 - REG(INS(I,4))=REG(INS(I,3)) 54 - * Make a number from a string. 55 - ELSEIF(INS(I,1).EQ.-12)THEN 56 - CALL STRBUF('READ',NINT(REG(INS(I,3))),STR1,NC1,IFAIL1) 57 - MODREG(INS(I,4))=2 58 - CALL INPRRC(STR1(1:NC1),REG(INS(I,4)),0.0,IFAIL2) 59 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)RETURN 60 - * Locate a global variable from its name. 61 - ELSEIF(INS(I,1).EQ.16)THEN 62 - CALL STRBUF('READ',NINT(REG(INS(I,3))),STR1,NC1,IFAIL1) 63 - IF(NC1.GT.0)THEN 64 - CALL CLTOU(STR1(1:NC1)) 65 - DO 10 J=1,NGLB 1 102 P=ALGEBRA D=ALGEX4 2 PAGE 137 66 - IF(STR1(1:NC1).EQ.GLBVAR(J))THEN 67 - MODREG(INS(I,4))=GLBMOD(J) 68 - REG(INS(I,4))=GLBVAL(J) 69 - GOTO 20 70 - ENDIF 71 - 10 CONTINUE 72 - ENDIF 73 - MODREG(INS(I,4))=0 74 - REG(INS(I,4))=0 75 - 20 CONTINUE 76 - * Return the type of the argument. 77 - ELSEIF(INS(I,1).EQ.17)THEN 78 - CALL STRBUF('STORE',IREF,'String',6,IFAIL1) 79 - IF(IFAIL1.NE.0)RETURN 80 - REG(INS(I,4))=IREF 81 - MODREG(INS(I,4))=1 82 - * Other functions are not known. 83 - ELSE 84 - RETURN 85 - ENDIF 86 - *** Binary logical operators between character strings. First = 87 - ELSEIF(INS(I,2).EQ.10)THEN 88 - CALL STRBUF('READ',NINT(REG(INS(I,1))),STR1,NC1,IFAIL1) 89 - CALL STRBUF('READ',NINT(REG(INS(I,3))),STR2,NC2,IFAIL2) 90 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)RETURN 91 - IF(NC1.LE.0.AND.NC2.LE.0)THEN 92 - REG(INS(I,4))=1 93 - ELSEIF(NC1.LE.0.OR.NC2.LE.0)THEN 94 - REG(INS(I,4))=0 95 - ELSEIF(STR1(1:NC1).EQ.STR2(1:NC2))THEN 96 - REG(INS(I,4))=1 97 - ELSE 98 - REG(INS(I,4))=0 99 - ENDIF 100 - MODREG(INS(I,4))=3 101 - * Not equal: 102 - ELSEIF(INS(I,2).EQ.11)THEN 103 - CALL STRBUF('READ',NINT(REG(INS(I,1))),STR1,NC1,IFAIL1) 104 - CALL STRBUF('READ',NINT(REG(INS(I,3))),STR2,NC2,IFAIL2) 105 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)RETURN 106 - IF(NC1.LE.0.AND.NC2.LE.0)THEN 107 - REG(INS(I,4))=0 108 - ELSEIF(NC1.LE.0.OR.NC2.LE.0)THEN 109 - REG(INS(I,4))=1 110 - ELSEIF(STR1(1:NC1).NE.STR2(1:NC2))THEN 111 - REG(INS(I,4))=1 112 - ELSE 113 - REG(INS(I,4))=0 114 - ENDIF 115 - MODREG(INS(I,4))=3 116 - * Less: 117 - ELSEIF(INS(I,2).EQ.12)THEN 118 - CALL STRBUF('READ',NINT(REG(INS(I,1))),STR1,NC1,IFAIL1) 119 - CALL STRBUF('READ',NINT(REG(INS(I,3))),STR2,NC2,IFAIL2) 120 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)RETURN 121 - IF(NC1.LE.0.AND.NC2.LE.0)THEN 122 - REG(INS(I,4))=0 123 - ELSEIF(NC1.LE.0)THEN 124 - REG(INS(I,4))=1 125 - ELSEIF(NC2.LE.0)THEN 126 - REG(INS(I,4))=0 127 - ELSEIF(STR1(1:NC1).LT.STR2(1:NC2))THEN 128 - REG(INS(I,4))=1 129 - ELSE 130 - REG(INS(I,4))=0 131 - ENDIF 132 - MODREG(INS(I,4))=3 133 - * Less or equal: 134 - ELSEIF(INS(I,2).EQ.13)THEN 135 - CALL STRBUF('READ',NINT(REG(INS(I,1))),STR1,NC1,IFAIL1) 136 - CALL STRBUF('READ',NINT(REG(INS(I,3))),STR2,NC2,IFAIL2) 137 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)RETURN 138 - IF(NC1.LE.0.AND.NC2.LE.0)THEN 139 - REG(INS(I,4))=1 140 - ELSEIF(NC1.LE.0)THEN 141 - REG(INS(I,4))=1 142 - ELSEIF(NC2.LE.0)THEN 143 - REG(INS(I,4))=0 144 - ELSEIF(STR1(1:NC1).LE.STR2(1:NC2))THEN 145 - REG(INS(I,4))=1 146 - ELSE 147 - REG(INS(I,4))=0 148 - ENDIF 149 - MODREG(INS(I,4))=3 150 - * Greater: 151 - ELSEIF(INS(I,2).EQ.14)THEN 152 - CALL STRBUF('READ',NINT(REG(INS(I,1))),STR1,NC1,IFAIL1) 153 - CALL STRBUF('READ',NINT(REG(INS(I,3))),STR2,NC2,IFAIL2) 154 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)RETURN 155 - IF(NC1.LE.0.AND.NC2.LE.0)THEN 156 - REG(INS(I,4))=0 157 - ELSEIF(NC1.LE.0)THEN 158 - REG(INS(I,4))=0 159 - ELSEIF(NC2.LE.0)THEN 160 - REG(INS(I,4))=1 161 - ELSEIF(STR1(1:NC1).GT.STR2(1:NC2))THEN 162 - REG(INS(I,4))=1 163 - ELSE 164 - REG(INS(I,4))=0 165 - ENDIF 166 - MODREG(INS(I,4))=3 167 - * Greater or equal: 168 - ELSEIF(INS(I,2).EQ.15)THEN 169 - CALL STRBUF('READ',NINT(REG(INS(I,1))),STR1,NC1,IFAIL1) 170 - CALL STRBUF('READ',NINT(REG(INS(I,3))),STR2,NC2,IFAIL2) 171 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)RETURN 1 102 P=ALGEBRA D=ALGEX4 3 PAGE 138 172 - IF(NC1.LE.0.AND.NC2.LE.0)THEN 173 - REG(INS(I,4))=1 174 - ELSEIF(NC1.LE.0)THEN 175 - REG(INS(I,4))=0 176 - ELSEIF(NC2.LE.0)THEN 177 - REG(INS(I,4))=1 178 - ELSEIF(STR1(1:NC1).GE.STR2(1:NC2))THEN 179 - REG(INS(I,4))=1 180 - ELSE 181 - REG(INS(I,4))=0 182 - ENDIF 183 - MODREG(INS(I,4))=3 184 - *** Unrecognised code. 185 - ELSE 186 - RETURN 187 - ENDIF 188 - *** Reset IFAIL to 0 because the calculations were probably successful. 189 - IFAIL=0 190 - END 103 GARFIELD ================================================== P=ALGEBRA D=ALGEX5 1 ============================ 0 + +DECK,ALGEX5. 1 - SUBROUTINE ALGEX5(I,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * ALGEX5 - Routine executing instruction I (produced by ALGPRE). 4 - * This routine takes care of arithmetic operations between 5 - * histograms. 6 - * (Last changed on 6/10/00.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,ALGDATA. 11.- +SEQ,HISTDATA. 12.- +SEQ,GLOBALS. 13.- +SEQ,PRINTPLOT. 14 - CHARACTER*(MXINCH) STR1 15 - REAL RNDUNI,RANLAN,RNDEXP,RNDNOR,RNDPOL,RNDFUN,DENLAN,EPS, 16 - - XXMIN,XXMAX,XX,XAUX,AVER,RMS 17 - INTEGER IFAIL,IFAIL1,IHIST1,IHIST3,IHIST4,NNCHA,I,J,NPOIS,IREF, 18 - - IERR,NC1,NNENTR 19 - LOGICAL HEXIST,HSET 20 - EXTERNAL RNDUNI,RANLAN,RNDEXP,RNDNOR,RNDPOL,RNDFUN,DENLAN 21 - *** Set IFAIL to 1 and EPS. 22 - IFAIL=1 0 23-+ +SELF,IF=CRAY. 24 - EPS=1.0E-10 0 25-+ +SELF,IF=-CRAY. 26 - EPS=1.0E-5 0 27-+ +SELF. 28 - *** For easier reference, define histogram references. 29 - IHIST1=NINT(REG(INS(I,1))) 30 - IHIST3=NINT(REG(INS(I,3))) 31 - IHIST4=NINT(REG(INS(I,4))) 32 - *** Verify that the objects are indeed valid, set histograms. 33 - IF(INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.4.AND. 34 - - MODREG(INS(I,3)).EQ.4)THEN 35 - * Validity of reference number. 36 - IF(IHIST1.LE.0.OR.IHIST3.LE.0.OR. 37 - - IHIST1.GT.MXHIST.OR.IHIST3.GT.MXHIST)THEN 38 - MODREG(INS(I,4))=0 39 - REG(INS(I,4))=0 40 - IF(LDEBUG)PRINT *,' ++++++ ALGEX5 DEBUG : Invalid'// 41 - - ' histogram reference ',IHIST1,IHIST3 42 - RETURN 43 - * Histograms must have been declared. 44 - ELSEIF(.NOT.(HISUSE(IHIST1).AND.HISUSE(IHIST3)))THEN 45 - MODREG(INS(I,4))=0 46 - REG(INS(I,4))=0 47 - IF(LDEBUG)THEN 48 - PRINT *,' ++++++ ALGEX5 DEBUG : Histogram'// 49 - - ' not yet in use' 50 - PRINT *,' Arg 1: ref=', 51 - - IHIST1,' use=',HISUSE(IHIST1), 52 - - ', Arg 3: ref=', 53 - - IHIST3,' use=',HISUSE(IHIST3) 54 - ENDIF 55 - RETURN 56 - * If autoranged, then the range must have been set. 57 - ELSEIF(.NOT.(SET(IHIST1).AND.SET(IHIST3)))THEN 58 - MODREG(INS(I,4))=0 59 - REG(INS(I,4))=0 60 - IF(LDEBUG)THEN 61 - PRINT *,' ++++++ ALGEX5 DEBUG : Histogram'// 62 - - ' not yet autoscaled' 63 - PRINT *,' Arg 1: ref=', 64 - - IHIST1,' set=',SET(IHIST1),', Arg 3: ref=', 65 - - IHIST3,' set=',SET(IHIST3) 66 - ENDIF 67 - RETURN 68 - * The range and the number of bins must agree. 69 - ELSEIF(ABS(XMIN(IHIST1)-XMIN(IHIST3)).GT. 70 - - EPS*(1+ABS(XMIN(IHIST1))+ABS(XMIN(IHIST3))).OR. 71 - - ABS(XMAX(IHIST1)-XMAX(IHIST3)).GT. 72 - - EPS*(1+ABS(XMAX(IHIST1))+ABS(XMAX(IHIST3))).OR. 73 - - NCHA(IHIST1).NE.NCHA(IHIST3))THEN 74 - MODREG(INS(I,4))=0 75 - REG(INS(I,4))=0 76 - IF(LDEBUG)THEN 77 - PRINT *,' ++++++ ALGEX5 DEBUG : Histograms'// 78 - - ' not compatible.' 79 - PRINT *,' Arg 1: ref=', 80 - - IHIST1,' range=',XMIN(IHIST1),XMAX(IHIST1), 1 103 P=ALGEBRA D=ALGEX5 2 PAGE 139 81 - - ' bins=',NCHA(IHIST1) 82 - PRINT *,' Arg 3: ref=', 83 - - IHIST3,' range=',XMIN(IHIST3),XMAX(IHIST3), 84 - - ' bins=',NCHA(IHIST3) 85 - ENDIF 86 - RETURN 87 - ENDIF 88 - ELSEIF(MODREG(INS(I,3)).EQ.4)THEN 89 - * Validity of reference number. 90 - IF(IHIST3.LE.0.OR.IHIST3.GT.MXHIST)THEN 91 - MODREG(INS(I,4))=0 92 - REG(INS(I,4))=0 93 - IF(LDEBUG)PRINT *,' ++++++ ALGEX5 DEBUG : Invalid'// 94 - - ' histogram reference ',IHIST3 95 - RETURN 96 - * Histogram must have been declared. 97 - ELSEIF(.NOT.HISUSE(IHIST3))THEN 98 - MODREG(INS(I,4))=0 99 - REG(INS(I,4))=0 100 - IF(LDEBUG)THEN 101 - PRINT *,' ++++++ ALGEX5 DEBUG : Histogram'// 102 - - ' not yet in use' 103 - PRINT *,' Arg 3: ref=', 104 - - IHIST3,' use=',HISUSE(IHIST3) 105 - ENDIF 106 - RETURN 107 - * If autoranged, then the range must have been set. 108 - ELSEIF(.NOT.SET(IHIST3))THEN 109 - MODREG(INS(I,4))=0 110 - REG(INS(I,4))=0 111 - IF(LDEBUG)THEN 112 - PRINT *,' ++++++ ALGEX5 DEBUG : Histogram'// 113 - - ' not yet autoscaled' 114 - PRINT *,' Arg 3: ref=', 115 - - IHIST3,' set=',SET(IHIST3) 116 - ENDIF 117 - RETURN 118 - ENDIF 119 - * Check nothing else than numbers and histograms appear. 120 - ELSEIF((INS(I,2).EQ.6.AND.MODREG(INS(I,3)).NE.4).OR. 121 - - (INS(I,2).NE.6.AND.((MODREG(INS(I,1)).NE.2.AND. 122 - - MODREG(INS(I,1)).NE.4).OR.(MODREG(INS(I,3)).NE.2.AND. 123 - - MODREG(INS(I,3)).NE.4))))THEN 124 - MODREG(INS(I,4))=0 125 - REG(INS(I,4))=0 126 - IF(LDEBUG)THEN 127 - PRINT *,' ++++++ ALGEX5 DEBUG : Unable to'// 128 - - ' handle received modes' 129 - PRINT *,' Arg 1: ref=', 130 - - IHIST1,' mode=',MODREG(INS(I,1)) 131 - PRINT *,' Arg 3: ref=', 132 - - IHIST3,' mode=',MODREG(INS(I,3)) 133 - ENDIF 134 - RETURN 135 - ENDIF 136 - *** Establish parameters of the resulting histogram. 137 - IF(INS(I,2).EQ.6)THEN 138 - IF(MODREG(INS(I,3)).EQ.4)THEN 139 - XXMIN=XMIN(IHIST3) 140 - XXMAX=XMAX(IHIST3) 141 - NNCHA=NCHA(IHIST3) 142 - ELSE 143 - RETURN 144 - ENDIF 145 - ELSE 146 - IF(MODREG(INS(I,1)).EQ.4)THEN 147 - XXMIN=XMIN(IHIST1) 148 - XXMAX=XMAX(IHIST1) 149 - NNCHA=NCHA(IHIST1) 150 - ELSEIF(MODREG(INS(I,3)).EQ.4)THEN 151 - XXMIN=XMIN(IHIST3) 152 - XXMAX=XMAX(IHIST3) 153 - NNCHA=NCHA(IHIST3) 154 - ELSE 155 - RETURN 156 - ENDIF 157 - ENDIF 158 - *** If one of the arguments is scalar, turn into a histogram. 159 - IF(INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.2)THEN 160 - CALL HISADM('ALLOCATE',IHIST1,NNCHA,XXMIN,XXMAX, 161 - - .FALSE.,IFAIL1) 162 - IF(IFAIL1.NE.0)RETURN 163 - DO 500 J=1,NNCHA 164 - CONTEN(IHIST1,J)=REG(INS(I,1)) 165 - 500 CONTINUE 166 - ENDIF 167 - IF(MODREG(INS(I,3)).EQ.2)THEN 168 - CALL HISADM('ALLOCATE',IHIST3,NNCHA,XXMIN,XXMAX, 169 - - .FALSE.,IFAIL1) 170 - IF(IFAIL1.NE.0)RETURN 171 - DO 510 J=1,NNCHA 172 - CONTEN(IHIST3,J)=REG(INS(I,3)) 173 - 510 CONTINUE 174 - ENDIF 175 - *** Allocate a histogram for the result. 176 - CALL HISADM('ALLOCATE',IHIST4,NNCHA,XXMIN,XXMAX,.FALSE.,IFAIL1) 177 - IF(IFAIL1.NE.0)RETURN 178 - *** Perform the actual calculation: binary numerical operators. 179 - IF(INS(I,2).EQ.1)THEN 180 - DO 10 J=1,NNCHA 181 - CONTEN(IHIST4,J)=CONTEN(IHIST1,J)+CONTEN(IHIST3,J) 182 - 10 CONTINUE 183 - MODREG(INS(I,4))=4 184 - ELSEIF(INS(I,2).EQ.2)THEN 185 - DO 20 J=1,NNCHA 186 - CONTEN(IHIST4,J)=CONTEN(IHIST1,J)-CONTEN(IHIST3,J) 1 103 P=ALGEBRA D=ALGEX5 3 PAGE 140 187 - 20 CONTINUE 188 - MODREG(INS(I,4))=4 189 - ELSEIF(INS(I,2).EQ.3)THEN 190 - DO 30 J=1,NNCHA 191 - CONTEN(IHIST4,J)=CONTEN(IHIST1,J)*CONTEN(IHIST3,J) 192 - 30 CONTINUE 193 - MODREG(INS(I,4))=4 194 - ELSEIF(INS(I,2).EQ.4)THEN 195 - DO 40 J=1,NNCHA 196 - IF(CONTEN(IHIST3,J).NE.0)THEN 197 - CONTEN(IHIST4,J)=CONTEN(IHIST1,J)/CONTEN(IHIST3,J) 198 - ELSE 199 - CONTEN(IHIST4,J)=0.0 200 - ENDIF 201 - 40 CONTINUE 202 - MODREG(INS(I,4))=4 203 - ELSEIF(INS(I,2).EQ.5)THEN 204 - DO 50 J=1,NNCHA 205 - IF(ABS(CONTEN(IHIST3,J)-NINT(CONTEN(IHIST3,J))).LT.EPS)THEN 206 - IF(NINT(CONTEN(IHIST3,J)).LE.0.AND. 207 - - CONTEN(IHIST1,J).EQ.0)THEN 208 - CONTEN(IHIST4,J)=0.0 209 - ELSEIF(2*(NINT(CONTEN(IHIST3,J))/2).EQ. 210 - - NINT(CONTEN(IHIST3,J)))THEN 211 - CONTEN(IHIST4,J)=ABS(CONTEN(IHIST1,J))** 212 - - NINT(CONTEN(IHIST3,J)) 213 - ELSE 214 - CONTEN(IHIST4,J)=SIGN(ABS(CONTEN(IHIST1,J))** 215 - - NINT(CONTEN(IHIST3,J)),CONTEN(IHIST1,J)) 216 - ENDIF 217 - ELSEIF(CONTEN(IHIST1,J).GT.0)THEN 218 - CONTEN(IHIST4,J)=CONTEN(IHIST1,J)**CONTEN(IHIST3,J) 219 - ELSE 220 - CONTEN(IHIST4,J)=0.0 221 - ENDIF 222 - 50 CONTINUE 223 - MODREG(INS(I,4))=4 224 - * Numerical function calls. 225 - ELSEIF(INS(I,2).EQ.6)THEN 226 - MODREG(INS(I,4))=4 227 - DO 60 J=1,NNCHA 228 - IF(INS(I,1).EQ. 1)THEN 229 - IF(ABS(CONTEN(IHIST3,J)).GT.88.0)RETURN 230 - CONTEN(IHIST4,J)=EXP(CONTEN(IHIST3,J)) 231 - ELSEIF(INS(I,1).EQ.-1)THEN 232 - IF(CONTEN(IHIST3,J).LE.0.0)RETURN 233 - CONTEN(IHIST4,J)=LOG(CONTEN(IHIST3,J)) 234 - ENDIF 235 - IF((INS(I,1).EQ.-2.OR.INS(I,1).EQ.-3).AND. 236 - - ABS(CONTEN(IHIST3,J)).GT.1.0)THEN 237 - CONTEN(IHIST4,J)=0.0 238 - ELSE 239 - IF(INS(I,1).EQ.-2)CONTEN(IHIST4,J)= 240 - - ASIN(CONTEN(IHIST3,J)) 241 - IF(INS(I,1).EQ.-3)CONTEN(IHIST4,J)= 242 - - ACOS(CONTEN(IHIST3,J)) 243 - ENDIF 244 - IF(INS(I,1).EQ. 2)CONTEN(IHIST4,J)= SIN(CONTEN(IHIST3,J)) 245 - IF(INS(I,1).EQ. 3)CONTEN(IHIST4,J)= COS(CONTEN(IHIST3,J)) 246 - IF(INS(I,1).EQ. 4)CONTEN(IHIST4,J)= TAN(CONTEN(IHIST3,J)) 247 - IF(INS(I,1).EQ.-4)CONTEN(IHIST4,J)= ATAN(CONTEN(IHIST3,J)) 248 - IF(INS(I,1).EQ. 5)CONTEN(IHIST4,J)= ABS(CONTEN(IHIST3,J)) 249 - IF(INS(I,1).EQ.-5)THEN 250 - IF(CONTEN(IHIST3,J).LT.0.0)THEN 251 - CONTEN(IHIST4,J)=-1.0 252 - ELSE 253 - CONTEN(IHIST4,J)=SQRT(CONTEN(IHIST3,J)) 254 - ENDIF 255 - ENDIF 256 - IF(INS(I,1).EQ. 6)CONTEN(IHIST4,J)= CONTEN(IHIST3,J) 257 - IF(INS(I,1).EQ.-6)CONTEN(IHIST4,J)= -CONTEN(IHIST3,J) 258 - IF(INS(I,1).EQ. 7)CONTEN(IHIST4,J)= SINH(CONTEN(IHIST3,J)) 259 - IF(INS(I,1).EQ.-7)CONTEN(IHIST4,J)=LOG(CONTEN(IHIST3,J)+ 260 - - SQRT(1+CONTEN(IHIST3,J)**2)) 261 - IF(INS(I,1).EQ. 8)CONTEN(IHIST4,J)= COSH(CONTEN(IHIST3,J)) 262 - IF(INS(I,1).EQ.-8)THEN 263 - IF(CONTEN(IHIST3,J).LT.1)THEN 264 - CONTEN(IHIST4,J)=0.0 265 - ELSE 266 - CONTEN(IHIST4,J)=LOG(CONTEN(IHIST3,J)+ 267 - - SQRT(CONTEN(IHIST3,J)**2-1)) 268 - ENDIF 269 - ENDIF 270 - IF(INS(I,1).EQ. 9)CONTEN(IHIST4,J)= TANH(CONTEN(IHIST3,J)) 271 - IF(INS(I,1).EQ.-9)THEN 272 - IF(CONTEN(IHIST3,J).LE.-1.0.OR. 273 - - CONTEN(IHIST3,J).GE.1.0)THEN 274 - CONTEN(IHIST4,J)=0.0 275 - ELSE 276 - CONTEN(IHIST4,J)=0.5*LOG((1+CONTEN(IHIST3,J))/ 277 - - (1-CONTEN(IHIST3,J))) 278 - ENDIF 279 - ENDIF 280 - * Truncation of a real number. 281 - IF(INS(I,1).EQ.11)THEN 282 - CONTEN(IHIST4,J)=INT(CONTEN(IHIST3,J)) 283 - IF(CONTEN(IHIST3,J).LT.0)CONTEN(IHIST4,J)= 284 - - CONTEN(IHIST4,J)-1.0 285 - ELSEIF(INS(I,1).EQ.-11)THEN 286 - CONTEN(IHIST4,J)=CONTEN(IHIST3,J)-INT(CONTEN(IHIST3,J)) 287 - IF(CONTEN(IHIST3,J).LT.0)CONTEN(IHIST4,J)= 288 - - CONTEN(IHIST4,J)+1.0 289 - ENDIF 290 - * Landau density. 291 - IF(INS(I,1).EQ.18)CONTEN(IHIST4,J)=DENLAN(CONTEN(IHIST3,J)) 292 - 60 CONTINUE 1 103 P=ALGEBRA D=ALGEX5 4 PAGE 141 293 - * Make a string from a number. 294 - IF(INS(I,1).EQ.12)THEN 295 - CALL STRBUF('STORE',IREF,'Histogram',9,IFAIL) 296 - IF(IFAIL.NE.0)RETURN 297 - MODREG(INS(I,4))=1 298 - REG(INS(I,4))=IREF 299 - * Sum and product. 300 - ELSEIF(INS(I,1).EQ.13)THEN 301 - REG(INS(I,4))=0 302 - MODREG(INS(I,4))=2 303 - DO 90 J=1,NNCHA 304 - REG(INS(I,4))=REG(INS(I,4))+CONTEN(IHIST3,J) 305 - 90 CONTINUE 306 - ELSEIF(INS(I,1).EQ.14)THEN 307 - REG(INS(I,4))=1 308 - MODREG(INS(I,4))=2 309 - DO 100 J=1,NNCHA 310 - REG(INS(I,4))=REG(INS(I,4))*CONTEN(IHIST3,J) 311 - 100 CONTINUE 312 - * Reference of an histogram. 313 - ELSEIF(INS(I,1).EQ.15)THEN 314 - REG(INS(I,4))=IHIST3 315 - MODREG(INS(I,4))=2 316 - * Maximum and minimum. 317 - ELSEIF(INS(I,1).EQ.19)THEN 318 - REG(INS(I,4))=CONTEN(IHIST3,1) 319 - MODREG(INS(I,4))=2 320 - DO 95 J=2,NNCHA 321 - REG(INS(I,4))=MIN(REG(INS(I,4)),CONTEN(IHIST3,J)) 322 - 95 CONTINUE 323 - ELSEIF(INS(I,1).EQ.20)THEN 324 - REG(INS(I,4))=CONTEN(IHIST3,1) 325 - MODREG(INS(I,4))=2 326 - DO 96 J=2,NNCHA 327 - REG(INS(I,4))=MAX(REG(INS(I,4)),CONTEN(IHIST3,J)) 328 - 96 CONTINUE 329 - * Mean and RMS. 330 - ELSEIF(INS(I,1).EQ.41)THEN 331 - CALL HISINQ(IHIST3,HEXIST,HSET,NNCHA,XXMIN,XXMAX, 332 - - NNENTR,AVER,RMS) 333 - REG(INS(I,4))=AVER 334 - MODREG(INS(I,4))=2 335 - ELSEIF(INS(I,1).EQ.42)THEN 336 - CALL HISINQ(IHIST3,HEXIST,HSET,NNCHA,XXMIN,XXMAX, 337 - - NNENTR,AVER,RMS) 338 - REG(INS(I,4))=RMS 339 - MODREG(INS(I,4))=2 340 - * Locate a global variable from its name. 341 - ELSEIF(INS(I,1).EQ.16)THEN 342 - CALL STRBUF('READ',NINT(REG(INS(I,3))),STR1,NC1,IFAIL1) 343 - DO 101 J=1,NGLB 344 - IF(STR1(1:NC1).EQ.GLBVAR(J))THEN 345 - MODREG(INS(I,4))=GLBMOD(J) 346 - REG(INS(I,4))=GLBVAL(J) 347 - GOTO 102 348 - ENDIF 349 - 101 CONTINUE 350 - MODREG(INS(I,4))=0 351 - REG(INS(I,4))=0 352 - 102 CONTINUE 353 - * Return the type of the argument. 354 - ELSEIF(INS(I,1).EQ.17)THEN 355 - CALL STRBUF('STORE',IREF,'Histogram',9,IFAIL1) 356 - IF(IFAIL1.NE.0)RETURN 357 - REG(INS(I,4))=IREF 358 - MODREG(INS(I,4))=1 359 - * Random number according to a histogram. 360 - ELSEIF(INS(I,1).EQ.28)THEN 361 - CALL RNDHIS(IHIST3,XAUX) 362 - REG(INS(I,4))=XAUX 363 - MODREG(INS(I,4))=2 364 - ENDIF 365 - * Random number generators. 366 - DO 110 J=1,NNCHA 367 - IF(INS(I,1).EQ.21)THEN 368 - CONTEN(IHIST4,J)=RNDUNI(REG(INS(I,3))) 369 - ELSEIF(INS(I,1).EQ.22)THEN 370 - CONTEN(IHIST4,J)=RNDNOR(0.0,1.0) 371 - ELSEIF(INS(I,1).EQ.23)THEN 372 - CONTEN(IHIST4,J)=RNDEXP(CONTEN(IHIST3,J)) 373 - ELSEIF(INS(I,1).EQ.24)THEN 374 - CALL RNPSSN(CONTEN(IHIST3,J),NPOIS,IERR) 375 - CONTEN(IHIST4,J)=REAL(NPOIS) 376 - ELSEIF(INS(I,1).EQ.25)THEN 377 - CONTEN(IHIST4,J)=RANLAN(RNDUNI(1.0)) 378 - ELSEIF(INS(I,1).EQ.26)THEN 379 - CONTEN(IHIST4,J)=RNDPOL(CONTEN(IHIST3,J)) 380 - ELSEIF(INS(I,1).EQ.27)THEN 381 - CONTEN(IHIST4,J)=RNDFUN(CONTEN(IHIST3,J)) 382 - ENDIF 383 - 110 CONTINUE 384 - * Binary logical operators between real type arguments. 385 - ELSEIF(INS(I,2).EQ.10)THEN 386 - MODREG(INS(I,4))=3 387 - REG(INS(I,4))=1.0 388 - DO 120 J=1,NNCHA 389 - IF(ABS(CONTEN(IHIST1,J)-CONTEN(IHIST3,J)).GT.EPS) 390 - - REG(INS(I,4))=0.0 391 - 120 CONTINUE 392 - ELSEIF(INS(I,2).EQ.11)THEN 393 - MODREG(INS(I,4))=3 394 - REG(INS(I,4))=0.0 395 - DO 130 J=1,NNCHA 396 - IF(ABS(CONTEN(IHIST1,J)-CONTEN(IHIST3,J)).GT.EPS) 397 - - REG(INS(I,4))=1.0 398 - 130 CONTINUE 1 103 P=ALGEBRA D=ALGEX5 5 PAGE 142 399 - ELSEIF(INS(I,2).EQ.12)THEN 400 - MODREG(INS(I,4))=3 401 - REG(INS(I,4))=1.0 402 - DO 140 J=1,NNCHA 403 - IF(CONTEN(IHIST1,J).GE.CONTEN(IHIST3,J))REG(INS(I,4))=0.0 404 - 140 CONTINUE 405 - ELSEIF(INS(I,2).EQ.13)THEN 406 - MODREG(INS(I,4))=3 407 - REG(INS(I,4))=1.0 408 - DO 150 J=1,NNCHA 409 - IF(CONTEN(IHIST1,J).GT.CONTEN(IHIST3,J))REG(INS(I,4))=0.0 410 - 150 CONTINUE 411 - ELSEIF(INS(I,2).EQ.14)THEN 412 - MODREG(INS(I,4))=3 413 - REG(INS(I,4))=1.0 414 - DO 160 J=1,NNCHA 415 - IF(CONTEN(IHIST1,J).LE.CONTEN(IHIST3,J))REG(INS(I,4))=0.0 416 - 160 CONTINUE 417 - ELSEIF(INS(I,2).EQ.15)THEN 418 - MODREG(INS(I,4))=3 419 - REG(INS(I,4))=1.0 420 - DO 170 J=1,NNCHA 421 - IF(CONTEN(IHIST1,J).LT.CONTEN(IHIST3,J))REG(INS(I,4))=0.0 422 - 170 CONTINUE 423 - * Unidentified operation code. 424 - ELSE 425 - MODREG(INS(I,4))=0 426 - RETURN 427 - ENDIF 428 - *** Delete auxiliary histograms. 429 - IF(INS(I,2).NE.6)THEN 430 - IF(MODREG(INS(I,1)).EQ.2) 431 - - CALL HISADM('DELETE',IHIST1,NNCHA,XXMIN,XXMAX, 432 - - .FALSE.,IFAIL1) 433 - ENDIF 434 - IF(MODREG(INS(I,3)).EQ.2) 435 - - CALL HISADM('DELETE',IHIST3,NNCHA,XXMIN,XXMAX, 436 - - .FALSE.,IFAIL1) 437 - *** Delete output histogram if not used. 438 - IF(MODREG(INS(I,4)).NE.4)THEN 439 - CALL HISADM('DELETE',IHIST4,NNCHA,XXMIN,XXMAX, 440 - - .FALSE.,IFAIL1) 441 - ELSE 442 - * Make visible if used. 443 - REG(INS(I,4))=IHIST4 444 - * And provide the various sums. 445 - SX0(IHIST4)=0.0 446 - SX1(IHIST4)=0.0 447 - SX2(IHIST4)=0.0 448 - DO 200 J=1,NNCHA 449 - XX=XXMIN+REAL(J-0.5)*(XXMAX-XXMIN)/REAL(NNCHA) 450 - SX0(IHIST4)=SX0(IHIST4)+CONTEN(IHIST4,J) 451 - SX1(IHIST4)=SX1(IHIST4)+CONTEN(IHIST4,J)*XX 452 - SX2(IHIST4)=SX2(IHIST4)+CONTEN(IHIST4,J)*XX**2 453 - 200 CONTINUE 454 - NENTRY(IHIST4)=1 455 - ENDIF 456 - *** Reset IFAIL to 0 because the calculations were probably successful. 457 - IFAIL=0 458 - END 104 GARFIELD ================================================== P=ALGEBRA D=ALGEX6 1 ============================ 0 + +DECK,ALGEX6. 1 - SUBROUTINE ALGEX6(I,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * ALGEX6 - Routine executing instruction I (produced by ALGPRE). 4 - * This routine takes care of arithmetic operations between 5 - * matrices. 6 - * (Last changed on 18/ 3/01.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,ALGDATA. 11.- +SEQ,MATDATA. 12.- +SEQ,GLOBALS. 13.- +SEQ,PRINTPLOT. 14 - REAL DENLAN,RNDUNI,RANLAN,RNDEXP,RNDNOR,RNDPOL,RNDFUN,EPS 15 - DOUBLE PRECISION SX1,SX2 16 - INTEGER IFAIL,IFAIL1,IMAT1,IMAT3,IMAT4,IREF1,IREF3,IREF4,I,J, 17 - - NDIM,IMOD,IDIM(MXMDIM),MATSLT,NPOIS,IREF,IERR,NC1,NCAUX,NOUT 18 - CHARACTER*(MXINCH) STR1,AUXSTR 19 - EXTERNAL RNDUNI,RANLAN,RNDEXP,RNDNOR,RNDPOL,RNDFUN,MATSLT,DENLAN 20 - *** Set IFAIL to 1 and EPS. 21 - IFAIL=1 0 22-+ +SELF,IF=CRAY. 23 - EPS=1.0E-10 0 24-+ +SELF,IF=-CRAY. 25 - EPS=1.0E-5 0 26-+ +SELF. 27 - *** For easier reference, define matrix references. 28 - IREF1=NINT(REG(INS(I,1))) 29 - IREF3=NINT(REG(INS(I,3))) 30 - IREF4=NINT(REG(INS(I,4))) 31 - IMAT1=MATSLT(IREF1) 32 - IMAT3=MATSLT(IREF3) 33 - IMAT4=MATSLT(IREF4) 34 - *** Verify that the objects are indeed valid matrices. 35 - IF(INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.5.AND. 36 - - MODREG(INS(I,3)).EQ.5)THEN 37 - * Check that the matrices do indeed exist. 38 - IF(IMAT1.LE.0.OR.IMAT3.LE.0)THEN 39 - MODREG(INS(I,4))=0 1 104 P=ALGEBRA D=ALGEX6 2 PAGE 143 40 - REG(INS(I,4))=0 41 - IF(LDEBUG)THEN 42 - PRINT *,' ++++++ ALGEX6 DEBUG : Reference to'// 43 - - ' an unbooked matrix.' 44 - PRINT *,' Arg 1: ref=', 45 - - IMAT1,', Arg 3: ref=',IMAT3 46 - ENDIF 47 - RETURN 48 - * The matrices must have the same overall size. 49 - ELSEIF(INS(I,2).NE.16.AND.MLEN(IMAT1).NE.MLEN(IMAT3))THEN 50 - MODREG(INS(I,4))=0 51 - REG(INS(I,4))=0 52 - IF(LDEBUG)THEN 53 - PRINT *,' ++++++ ALGEX6 DEBUG : Matrices'// 54 - - ' have differing length.' 55 - PRINT *,' Arg 1: ref=', 56 - - IMAT1,' length=',MLEN(IMAT1) 57 - PRINT *,' Arg 3: ref=', 58 - - IMAT3,' length=',MLEN(IMAT3) 59 - ENDIF 60 - RETURN 61 - ENDIF 62 - ELSEIF(MODREG(INS(I,3)).EQ.5)THEN 63 - * Validity of reference number. 64 - IF(IMAT3.LE.0)THEN 65 - MODREG(INS(I,4))=0 66 - REG(INS(I,4))=0 67 - IF(LDEBUG)PRINT *,' ++++++ ALGEX6 DEBUG :'// 68 - - ' Refering to unbooked matrix ',IMAT3 69 - RETURN 70 - ENDIF 71 - * Check nothing else than numbers and matrices appear. 72 - ELSEIF((INS(I,2).EQ.6.AND.MODREG(INS(I,3)).NE.5).OR. 73 - - (INS(I,2).NE.6.AND.((MODREG(INS(I,1)).NE.2.AND. 74 - - MODREG(INS(I,1)).NE.5).OR.(MODREG(INS(I,3)).NE.2.AND. 75 - - MODREG(INS(I,3)).NE.5))))THEN 76 - MODREG(INS(I,4))=0 77 - REG(INS(I,4))=0 78 - IF(LDEBUG)THEN 79 - PRINT *,' ++++++ ALGEX6 DEBUG : Unable to'// 80 - - ' handle received modes' 81 - PRINT *,' Arg 1: ref=', 82 - - IMAT1,' mode=',MODREG(INS(I,1)) 83 - PRINT *,' Arg 3: ref=', 84 - - IMAT3,' mode=',MODREG(INS(I,3)) 85 - ENDIF 86 - RETURN 87 - ENDIF 88 - *** Set parameters of resulting matrix: function calls. 89 - IF(INS(I,2).EQ.6)THEN 90 - IF(MODREG(INS(I,3)).EQ.5)THEN 91 - DO 340 J=1,MDIM(IMAT3) 92 - IDIM(J)=MSIZ(IMAT3,J) 93 - 340 CONTINUE 94 - NDIM=MDIM(IMAT3) 95 - IMOD=MMOD(IMAT3) 96 - ELSE 97 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEX6 DEBUG :'', 98 - - '' Unable to get output matrix format.'')') 99 - RETURN 100 - ENDIF 101 - * Concatenation. 102 - ELSEIF(INS(I,2).EQ.16)THEN 103 - IF(MODREG(INS(I,1)).EQ.5.AND.MODREG(INS(I,3)).EQ.5)THEN 104 - NDIM=1 105 - IDIM(1)=MLEN(IMAT1)+MLEN(IMAT3) 106 - IMOD=MMOD(IMAT1) 107 - ELSEIF(MODREG(INS(I,1)).EQ.5)THEN 108 - NDIM=1 109 - IDIM(1)=MLEN(IMAT1)+1 110 - IMOD=MMOD(IMAT1) 111 - ELSEIF(MODREG(INS(I,3)).EQ.5)THEN 112 - NDIM=1 113 - IDIM(1)=MLEN(IMAT3)+1 114 - IMOD=MMOD(IMAT3) 115 - ELSE 116 - NDIM=1 117 - IDIM(1)=2 118 - IMOD=2 119 - ENDIF 120 - * Numeric calls. 121 - ELSE 122 - IF(MODREG(INS(I,1)).EQ.5)THEN 123 - DO 350 J=1,MDIM(IMAT1) 124 - IDIM(J)=MSIZ(IMAT1,J) 125 - 350 CONTINUE 126 - NDIM=MDIM(IMAT1) 127 - IMOD=MMOD(IMAT1) 128 - ELSEIF(MODREG(INS(I,3)).EQ.5)THEN 129 - DO 360 J=1,MDIM(IMAT3) 130 - IDIM(J)=MSIZ(IMAT3,J) 131 - 360 CONTINUE 132 - NDIM=MDIM(IMAT3) 133 - IMOD=MMOD(IMAT3) 134 - ELSE 135 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEX6 DEBUG :'', 136 - - '' Unable to get output matrix format.'')') 137 - RETURN 138 - ENDIF 139 - ENDIF 140 - *** If one of the arguments is scalar, turn into a matrix. 141 - IF(INS(I,2).NE.6.AND.INS(I,2).NE.16.AND. 142 - - MODREG(INS(I,1)).EQ.2)THEN 143 - IF(LDEBUG)PRINT *,' ++++++ ALGEX6 DEBUG : Creating'// 144 - - ' a scalar replacement matrix for INS(I,1).' 145 - CALL MATADM('ALLOCATE',IREF1,NDIM,IDIM,IMOD,IFAIL1) 1 104 P=ALGEBRA D=ALGEX6 3 PAGE 144 146 - IF(IFAIL1.NE.0)RETURN 147 - IMAT1=MATSLT(IREF1) 148 - IF(IMAT1.LE.0)THEN 149 - IF(LDEBUG)PRINT *,' ++++++ ALGEX6 DEBUG : Unable'// 150 - - ' to locate scalar replacement matrix 1.' 151 - RETURN 152 - ENDIF 153 - DO 380 J=1,MLEN(IMAT1) 154 - MVEC(MORG(IMAT1)+J)=REG(INS(I,1)) 155 - 380 CONTINUE 156 - ENDIF 157 - IF(INS(I,2).NE.16.AND.MODREG(INS(I,3)).EQ.2)THEN 158 - IF(LDEBUG)PRINT *,' ++++++ ALGEX6 DEBUG : Creating'// 159 - - ' a scalar replacement matrix for INS(I,3).' 160 - CALL MATADM('ALLOCATE',IREF3,NDIM,IDIM,IMOD,IFAIL1) 161 - IF(IFAIL1.NE.0)RETURN 162 - IMAT3=MATSLT(IREF3) 163 - IF(IMAT3.LE.0)THEN 164 - IF(LDEBUG)PRINT *,' ++++++ ALGEX6 DEBUG : Unable'// 165 - - ' to locate scalar replacement matrix 3.' 166 - RETURN 167 - ENDIF 168 - DO 400 J=1,MLEN(IMAT3) 169 - MVEC(MORG(IMAT3)+J)=REG(INS(I,3)) 170 - 400 CONTINUE 171 - ENDIF 172 - *** Allocate a matrix for the result. 173 - CALL MATADM('ALLOCATE',IREF4,NDIM,IDIM,IMOD,IFAIL1) 174 - IF(IFAIL1.NE.0)RETURN 175 - REG(INS(I,4))=IREF4 176 - MODREG(INS(I,4))=5 177 - *** Establish final locations for the various matrices, first word. 178 - IF(INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.5)THEN 179 - IMAT1=MATSLT(IREF1) 180 - IF(IMAT1.LE.0)THEN 181 - IF(LDEBUG)PRINT *,' ++++++ ALGEX6 DEBUG : Unable'// 182 - - ' to locate matrix 1.' 183 - RETURN 184 - ENDIF 185 - ENDIF 186 - * Third word. 187 - IF(MODREG(INS(I,3)).EQ.5)THEN 188 - IMAT3=MATSLT(IREF3) 189 - IF(IMAT3.LE.0)THEN 190 - IF(LDEBUG)PRINT *,' ++++++ ALGEX6 DEBUG : Unable'// 191 - - ' to locate matrix 3.' 192 - RETURN 193 - ENDIF 194 - ENDIF 195 - * Result. 196 - IMAT4=MATSLT(IREF4) 197 - IF(IMAT4.LE.0)THEN 198 - IF(LDEBUG)PRINT *,' ++++++ ALGEX6 DEBUG : Unable'// 199 - - ' to locate result matrix.' 200 - RETURN 201 - ENDIF 202 - *** Perform the actual calculation: binary numerical operators. 203 - IF(INS(I,2).EQ.1)THEN 204 - DO 10 J=1,MLEN(IMAT4) 205 - MVEC(MORG(IMAT4)+J)=MVEC(MORG(IMAT1)+J)+MVEC(MORG(IMAT3)+J) 206 - 10 CONTINUE 207 - MODREG(INS(I,4))=5 208 - ELSEIF(INS(I,2).EQ.2)THEN 209 - DO 20 J=1,MLEN(IMAT4) 210 - MVEC(MORG(IMAT4)+J)=MVEC(MORG(IMAT1)+J)-MVEC(MORG(IMAT3)+J) 211 - 20 CONTINUE 212 - MODREG(INS(I,4))=5 213 - ELSEIF(INS(I,2).EQ.3)THEN 214 - DO 30 J=1,MLEN(IMAT4) 215 - MVEC(MORG(IMAT4)+J)=MVEC(MORG(IMAT1)+J)*MVEC(MORG(IMAT3)+J) 216 - 30 CONTINUE 217 - MODREG(INS(I,4))=5 218 - ELSEIF(INS(I,2).EQ.4)THEN 219 - DO 40 J=1,MLEN(IMAT4) 220 - IF(MVEC(MORG(IMAT3)+J).NE.0)THEN 221 - MVEC(MORG(IMAT4)+J)=MVEC(MORG(IMAT1)+J)/ 222 - - MVEC(MORG(IMAT3)+J) 223 - ELSE 224 - MVEC(MORG(IMAT4)+J)=0.0 225 - ENDIF 226 - 40 CONTINUE 227 - MODREG(INS(I,4))=5 228 - ELSEIF(INS(I,2).EQ.5)THEN 229 - DO 50 J=1,MLEN(IMAT4) 230 - IF(ABS(MVEC(MORG(IMAT3)+J)- 231 - - NINT(MVEC(MORG(IMAT3)+J))).LT.EPS)THEN 232 - IF(NINT(MVEC(MORG(IMAT3)+J)).LE.0.AND. 233 - - MVEC(MORG(IMAT1)+J).EQ.0)THEN 234 - MVEC(MORG(IMAT4)+J)=0.0 235 - ELSEIF(2*(NINT(MVEC(MORG(IMAT3)+J))/2).EQ. 236 - - NINT(MVEC(MORG(IMAT3)+J)))THEN 237 - MVEC(MORG(IMAT4)+J)=ABS(MVEC(MORG(IMAT1)+J))** 238 - - NINT(MVEC(MORG(IMAT3)+J)) 239 - ELSE 240 - MVEC(MORG(IMAT4)+J)= 241 - - SIGN(ABS(MVEC(MORG(IMAT1)+J))** 242 - - NINT(MVEC(MORG(IMAT3)+J)), 243 - - MVEC(MORG(IMAT1)+J)) 244 - ENDIF 245 - ELSEIF(MVEC(MORG(IMAT1)+J).GT.0)THEN 246 - MVEC(MORG(IMAT4)+J)=MVEC(MORG(IMAT1)+J)** 247 - - MVEC(MORG(IMAT3)+J) 248 - ELSE 249 - MVEC(MORG(IMAT4)+J)=0.0 250 - ENDIF 251 - 50 CONTINUE 1 104 P=ALGEBRA D=ALGEX6 4 PAGE 145 252 - MODREG(INS(I,4))=5 253 - * Numerical function calls. 254 - ELSEIF(INS(I,2).EQ.6)THEN 255 - MODREG(INS(I,4))=5 256 - DO 60 J=1,MLEN(IMAT4) 257 - IF(INS(I,1).EQ. 1)THEN 258 - IF(ABS(MVEC(MORG(IMAT3)+J)).GT.88.0)RETURN 259 - MVEC(MORG(IMAT4)+J)=EXP(MVEC(MORG(IMAT3)+J)) 260 - ELSEIF(INS(I,1).EQ.-1)THEN 261 - IF(MVEC(MORG(IMAT3)+J).LE.0.0)RETURN 262 - MVEC(MORG(IMAT4)+J)=LOG(MVEC(MORG(IMAT3)+J)) 263 - ENDIF 264 - IF((INS(I,1).EQ.-2.OR.INS(I,1).EQ.-3).AND. 265 - - ABS(MVEC(MORG(IMAT3)+J)).GT.1.0)THEN 266 - MVEC(MORG(IMAT4)+J)=0.0 267 - ELSE 268 - IF(INS(I,1).EQ.-2)MVEC(MORG(IMAT4)+J)= 269 - - ASIN(MVEC(MORG(IMAT3)+J)) 270 - IF(INS(I,1).EQ.-3)MVEC(MORG(IMAT4)+J)= 271 - - ACOS(MVEC(MORG(IMAT3)+J)) 272 - ENDIF 273 - IF(INS(I,1).EQ. 2)MVEC(MORG(IMAT4)+J)= 274 - - SIN(MVEC(MORG(IMAT3)+J)) 275 - IF(INS(I,1).EQ. 3)MVEC(MORG(IMAT4)+J)= 276 - - COS(MVEC(MORG(IMAT3)+J)) 277 - IF(INS(I,1).EQ. 4)MVEC(MORG(IMAT4)+J)= 278 - - TAN(MVEC(MORG(IMAT3)+J)) 279 - IF(INS(I,1).EQ.-4)MVEC(MORG(IMAT4)+J)= 280 - - ATAN(MVEC(MORG(IMAT3)+J)) 281 - IF(INS(I,1).EQ. 5)MVEC(MORG(IMAT4)+J)= 282 - - ABS(MVEC(MORG(IMAT3)+J)) 283 - IF(INS(I,1).EQ.-5)THEN 284 - IF(MVEC(MORG(IMAT3)+J).LT.0.0)THEN 285 - MVEC(MORG(IMAT4)+J)=-1.0 286 - ELSE 287 - MVEC(MORG(IMAT4)+J)=SQRT(MVEC(MORG(IMAT3)+J)) 288 - ENDIF 289 - ENDIF 290 - IF(INS(I,1).EQ. 6)MVEC(MORG(IMAT4)+J)= 291 - - MVEC(MORG(IMAT3)+J) 292 - IF(INS(I,1).EQ.-6)MVEC(MORG(IMAT4)+J)= 293 - - -MVEC(MORG(IMAT3)+J) 294 - IF(INS(I,1).EQ. 7)MVEC(MORG(IMAT4)+J)= 295 - - SINH(MVEC(MORG(IMAT3)+J)) 296 - IF(INS(I,1).EQ.-7)MVEC(MORG(IMAT4)+J)= 297 - - LOG(MVEC(MORG(IMAT3)+J)+ 298 - - SQRT(1+MVEC(MORG(IMAT3)+J)**2)) 299 - IF(INS(I,1).EQ. 8)MVEC(MORG(IMAT4)+J)= 300 - - COSH(MVEC(MORG(IMAT3)+J)) 301 - IF(INS(I,1).EQ.-8)THEN 302 - IF(MVEC(MORG(IMAT3)+J).LT.1)THEN 303 - MVEC(MORG(IMAT4)+J)=0.0 304 - ELSE 305 - MVEC(MORG(IMAT4)+J)=LOG(MVEC(MORG(IMAT3)+J)+ 306 - - SQRT(MVEC(MORG(IMAT3)+J)**2-1)) 307 - ENDIF 308 - ENDIF 309 - IF(INS(I,1).EQ. 9)MVEC(MORG(IMAT4)+J)= 310 - - TANH(MVEC(MORG(IMAT3)+J)) 311 - IF(INS(I,1).EQ.-9)THEN 312 - IF(MVEC(MORG(IMAT3)+J).LE.-1.0.OR. 313 - - MVEC(MORG(IMAT3)+J).GE.1.0)THEN 314 - MVEC(MORG(IMAT4)+J)=0.0 315 - ELSE 316 - MVEC(MORG(IMAT4)+J)= 317 - - 0.5*LOG((1+MVEC(MORG(IMAT3)+J))/ 318 - - (1-MVEC(MORG(IMAT3)+J))) 319 - ENDIF 320 - ENDIF 321 - * Truncation of a real number. 322 - IF(INS(I,1).EQ.11)THEN 323 - MVEC(MORG(IMAT4)+J)=INT(MVEC(MORG(IMAT3)+J)) 324 - IF(MVEC(MORG(IMAT3)+J).LT.0)MVEC(MORG(IMAT4)+J)= 325 - - MVEC(MORG(IMAT4)+J)-1.0 326 - ELSEIF(INS(I,1).EQ.-11)THEN 327 - MVEC(MORG(IMAT4)+J)= 328 - - MVEC(MORG(IMAT3)+J)-INT(MVEC(MORG(IMAT3)+J)) 329 - IF(MVEC(MORG(IMAT3)+J).LT.0)MVEC(MORG(IMAT4)+J)= 330 - - MVEC(MORG(IMAT4)+J)+1.0 331 - ENDIF 332 - * Landau density. 333 - IF(INS(I,1).EQ.18)MVEC(MORG(IMAT4)+J)= 334 - - DENLAN(MVEC(MORG(IMAT3)+J)) 335 - 60 CONTINUE 336 - * Make a string from a matrix. 337 - IF(INS(I,1).EQ.12)THEN 338 - CALL OUTFMT(REG(INS(I,3)),MODREG(INS(I,3)), 339 - - AUXSTR,NCAUX,'LEFT') 340 - CALL STRBUF('STORE',IREF,AUXSTR(1:NCAUX),NCAUX,IFAIL) 341 - IF(IFAIL.NE.0)RETURN 342 - MODREG(INS(I,4))=1 343 - REG(INS(I,4))=IREF 344 - * Return the real number of the matrix. 345 - ELSEIF(INS(I,1).EQ.-12)THEN 346 - REG(INS(I,4))=MVEC(MORG(IMAT3)+1) 347 - MODREG(INS(I,4))=2 348 - * Sum and product. 349 - ELSEIF(INS(I,1).EQ.13)THEN 350 - REG(INS(I,4))=0 351 - MODREG(INS(I,4))=2 352 - DO 90 J=1,MLEN(IMAT4) 353 - REG(INS(I,4))=REG(INS(I,4))+MVEC(MORG(IMAT3)+J) 354 - 90 CONTINUE 355 - ELSEIF(INS(I,1).EQ.14)THEN 356 - REG(INS(I,4))=1 357 - MODREG(INS(I,4))=2 1 104 P=ALGEBRA D=ALGEX6 5 PAGE 146 358 - DO 100 J=1,MLEN(IMAT4) 359 - REG(INS(I,4))=REG(INS(I,4))*MVEC(MORG(IMAT3)+J) 360 - 100 CONTINUE 361 - * Maximum and minimum. 362 - ELSEIF(INS(I,1).EQ.19)THEN 363 - REG(INS(I,4))=MVEC(MORG(IMAT3)+1) 364 - MODREG(INS(I,4))=2 365 - DO 180 J=2,MLEN(IMAT3) 366 - REG(INS(I,4))=MIN(REG(INS(I,4)),MVEC(MORG(IMAT3)+J)) 367 - 180 CONTINUE 368 - ELSEIF(INS(I,1).EQ.20)THEN 369 - REG(INS(I,4))=MVEC(MORG(IMAT3)+1) 370 - MODREG(INS(I,4))=2 371 - DO 190 J=2,MLEN(IMAT3) 372 - REG(INS(I,4))=MAX(REG(INS(I,4)),MVEC(MORG(IMAT3)+J)) 373 - 190 CONTINUE 374 - * Mean and RMS. 375 - ELSEIF(INS(I,1).EQ.41.OR.INS(I,1).EQ.42)THEN 376 - SX1=0 377 - SX2=0 378 - DO 200 J=1,MLEN(IMAT3) 379 - SX1=SX1+MVEC(MORG(IMAT3)+J) 380 - SX2=SX2+MVEC(MORG(IMAT3)+J)**2 381 - 200 CONTINUE 382 - IF(MLEN(IMAT3).LT.1)RETURN 383 - IF(INS(I,1).EQ.41)THEN 384 - REG(INS(I,4))=SX1/MLEN(IMAT3) 385 - ELSE 386 - REG(INS(I,4))=SQRT((SX2-SX1**2/MLEN(IMAT3))/ 387 - - MLEN(IMAT3)) 388 - ENDIF 389 - MODREG(INS(I,4))=2 390 - * Return the reference of the matrix. 391 - ELSEIF(INS(I,1).EQ.15)THEN 392 - REG(INS(I,4))=IMAT3 393 - MODREG(INS(I,4))=2 394 - * Locate a global variable from its name. 395 - ELSEIF(INS(I,1).EQ.16)THEN 396 - CALL STRBUF('READ',NINT(REG(INS(I,3))),STR1,NC1,IFAIL1) 397 - DO 70 J=1,NGLB 398 - IF(STR1(1:NC1).EQ.GLBVAR(J))THEN 399 - MODREG(INS(I,4))=GLBMOD(J) 400 - REG(INS(I,4))=GLBVAL(J) 401 - GOTO 75 402 - ENDIF 403 - 70 CONTINUE 404 - MODREG(INS(I,4))=0 405 - REG(INS(I,4))=0 406 - 75 CONTINUE 407 - * Return the type of the argument. 408 - ELSEIF(INS(I,1).EQ.17)THEN 409 - CALL STRBUF('STORE',IREF,'Matrix',6,IFAIL1) 410 - IF(IFAIL1.NE.0)RETURN 411 - REG(INS(I,4))=IREF 412 - MODREG(INS(I,4))=1 413 - ENDIF 414 - * Random number generators. 415 - DO 110 J=1,MLEN(IMAT4) 416 - IF(INS(I,1).EQ.21)THEN 417 - MVEC(MORG(IMAT4)+J)=RNDUNI(REG(INS(I,3))) 418 - ELSEIF(INS(I,1).EQ.22)THEN 419 - MVEC(MORG(IMAT4)+J)=RNDNOR(0.0,1.0) 420 - ELSEIF(INS(I,1).EQ.23)THEN 421 - MVEC(MORG(IMAT4)+J)=RNDEXP(MVEC(MORG(IMAT3)+J)) 422 - ELSEIF(INS(I,1).EQ.24)THEN 423 - CALL RNPSSN(MVEC(MORG(IMAT3)+J),NPOIS,IERR) 424 - MVEC(MORG(IMAT4)+J)=REAL(NPOIS) 425 - ELSEIF(INS(I,1).EQ.25)THEN 426 - MVEC(MORG(IMAT4)+J)=RANLAN(RNDUNI(1.0)) 427 - ELSEIF(INS(I,1).EQ.26)THEN 428 - MVEC(MORG(IMAT4)+J)=RNDPOL(MVEC(MORG(IMAT3)+J)) 429 - ELSEIF(INS(I,1).EQ.27)THEN 430 - MVEC(MORG(IMAT4)+J)=RNDFUN(MVEC(MORG(IMAT3)+J)) 431 - ENDIF 432 - 110 CONTINUE 433 - * Random number generators not to be called. 434 - IF(INS(I,1).EQ.28)THEN 435 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEX6 DEBUG :'', 436 - - '' Generator '',I2,'' does not apply to'', 437 - - '' Matrix.'')') INS(I,1) 438 - RETURN 439 - ENDIF 440 - * Binary logical operators between real type arguments. 441 - ELSEIF(INS(I,2).EQ.10)THEN 442 - MODREG(INS(I,4))=3 443 - REG(INS(I,4))=1.0 444 - DO 120 J=1,MLEN(IMAT4) 445 - IF(ABS(MVEC(MORG(IMAT1)+J)-MVEC(MORG(IMAT3)+J)).GT.EPS) 446 - - REG(INS(I,4))=0.0 447 - 120 CONTINUE 448 - ELSEIF(INS(I,2).EQ.11)THEN 449 - MODREG(INS(I,4))=3 450 - REG(INS(I,4))=0.0 451 - DO 130 J=1,MLEN(IMAT4) 452 - IF(ABS(MVEC(MORG(IMAT1)+J)-MVEC(MORG(IMAT3)+J)).GT.EPS) 453 - - REG(INS(I,4))=1.0 454 - 130 CONTINUE 455 - ELSEIF(INS(I,2).EQ.12)THEN 456 - MODREG(INS(I,4))=3 457 - REG(INS(I,4))=1.0 458 - DO 140 J=1,MLEN(IMAT4) 459 - IF(MVEC(MORG(IMAT1)+J).GE.MVEC(MORG(IMAT3)+J)) 460 - - REG(INS(I,4))=0.0 461 - 140 CONTINUE 462 - ELSEIF(INS(I,2).EQ.13)THEN 463 - MODREG(INS(I,4))=3 1 104 P=ALGEBRA D=ALGEX6 6 PAGE 147 464 - REG(INS(I,4))=1.0 465 - DO 150 J=1,MLEN(IMAT4) 466 - IF(MVEC(MORG(IMAT1)+J).GT.MVEC(MORG(IMAT3)+J)) 467 - - REG(INS(I,4))=0.0 468 - 150 CONTINUE 469 - ELSEIF(INS(I,2).EQ.14)THEN 470 - MODREG(INS(I,4))=3 471 - REG(INS(I,4))=1.0 472 - DO 160 J=1,MLEN(IMAT4) 473 - IF(MVEC(MORG(IMAT1)+J).LE.MVEC(MORG(IMAT3)+J)) 474 - - REG(INS(I,4))=0.0 475 - 160 CONTINUE 476 - ELSEIF(INS(I,2).EQ.15)THEN 477 - MODREG(INS(I,4))=3 478 - REG(INS(I,4))=1.0 479 - DO 170 J=1,MLEN(IMAT4) 480 - IF(MVEC(MORG(IMAT1)+J).LT.MVEC(MORG(IMAT3)+J)) 481 - - REG(INS(I,4))=0.0 482 - 170 CONTINUE 483 - * Concatenation. 484 - ELSEIF(INS(I,2).EQ.16)THEN 485 - NOUT=0 486 - IF(MODREG(INS(I,1)).EQ.2)THEN 487 - NOUT=NOUT+1 488 - MVEC(MORG(IMAT4)+NOUT)=REG(INS(I,1)) 489 - ELSE 490 - DO 210 J=1,MLEN(IMAT1) 491 - NOUT=NOUT+1 492 - MVEC(MORG(IMAT4)+NOUT)=MVEC(MORG(IMAT1)+J) 493 - 210 CONTINUE 494 - ENDIF 495 - IF(MODREG(INS(I,3)).EQ.2)THEN 496 - NOUT=NOUT+1 497 - MVEC(MORG(IMAT4)+NOUT)=REG(INS(I,3)) 498 - ELSE 499 - DO 220 J=1,MLEN(IMAT3) 500 - NOUT=NOUT+1 501 - MVEC(MORG(IMAT4)+NOUT)=MVEC(MORG(IMAT3)+J) 502 - 220 CONTINUE 503 - ENDIF 504 - MODREG(INS(I,4))=5 505 - * Unidentified operation code. 506 - ELSE 507 - MODREG(INS(I,4))=0 508 - RETURN 509 - ENDIF 510 - *** Delete auxiliary matrices. 511 - IF(INS(I,2).NE.6.AND.INS(I,2).NE.16)THEN 512 - IF(MODREG(INS(I,1)).EQ.2) 513 - - CALL MATADM('DELETE',IREF1,NDIM,IDIM,IMOD,IFAIL1) 514 - ENDIF 515 - IF(MODREG(INS(I,3)).EQ.2.AND.INS(I,2).NE.16) 516 - - CALL MATADM('DELETE',IREF3,NDIM,IDIM,IMOD,IFAIL1) 517 - *** Delete output matrix if not used. 518 - IF(MODREG(INS(I,4)).NE.5) 519 - - CALL MATADM('DELETE',IREF4,NDIM,IDIM,IMOD,IFAIL1) 520 - *** Reset IFAIL to 0 because the calculations were probably successful. 521 - IFAIL=0 522 - END 105 GARFIELD ================================================== P=ALGEBRA D=ALGGBC 1 ============================ 0 + +DECK,ALGGBC. 1 - SUBROUTINE ALGGBC 2 - *----------------------------------------------------------------------- 3 - * ALGGBC - Performs a garbage collect in the algebra memory. 4 - * (Last changed on 1/11/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,ALGDATA. 9.- +SEQ,PRINTPLOT. 10 - INTEGER NEOLD,NIOLD,NCOLD,I,J,K 11 - *** Clean up the entry point list. 12 - NEOLD=NALGE 13 - NALGE=0 14 - ICONS0=-7 15 - NCOLD=NCONS 16 - NCONS=-6 17 - NIOLD=NINS 18 - NINS=0 19 - *** Loop over the entry points that are to be kept. 20 - DO 10 I=1,NEOLD 21 - * But kill constant strings associated with dropped entry points. 22 - IF(ALGENT(I,2).EQ.0)THEN 23 - DO 15 J=ALGENT(I,8),ALGENT(I,8)-ALGENT(I,9)+1,-1 24 - CALL ALGREU(NINT(REG(J)),MODREG(J),1) 25 - 15 CONTINUE 26 - GOTO 10 27 - ENDIF 28 - * Shift the constants. 29 - ICONS0=NCONS-1 30 - DO 70 J=ALGENT(I,8),ALGENT(I,8)-ALGENT(I,9)+1,-1 31 - NCONS=NCONS-1 32 - REG(NCONS)=REG(J) 33 - MODREG(NCONS)=MODREG(J) 34 - DO 80 K=ALGENT(I,5),ALGENT(I,5)+ALGENT(I,6)-1 35 - IF(INS(K,1).EQ.J.AND.INS(K,2).NE.0.AND.INS(K,2).NE.6.AND. 36 - - INS(K,2).NE.8.AND.INS(K,2).NE.9)INS(K,1)=NCONS 37 - IF(INS(K,3).EQ.J.AND.ABS(INS(K,2)).NE.9)INS(K,3)=NCONS 38 - 80 CONTINUE 39 - 70 CONTINUE 40 - * Shift the instructions. 41 - IINS0=NINS+1 42 - DO 40 J=ALGENT(I,5),ALGENT(I,5)+ALGENT(I,6)-1 43 - NINS=NINS+1 1 105 P=ALGEBRA D=ALGGBC 2 PAGE 148 44 - DO 50 K=1,4 45 - INS(NINS,K)=INS(J,K) 46 - 50 CONTINUE 47 - EXEC(NINS)=EXEC(J) 48 - 40 CONTINUE 49 - * Update the entry point record. 50 - NALGE=NALGE+1 51 - DO 20 J=1,10 52 - ALGENT(NALGE,J)=ALGENT(I,J) 53 - 20 CONTINUE 54 - ALGENT(NALGE,5)=IINS0 55 - ALGENT(NALGE,8)=ICONS0 56 - 10 CONTINUE 57 - *** Set suitable starting points for additions. 58 - ICONS0=NCONS-1 59 - IINS0=NINS+1 60 - *** Print statistics if requested. 61 - IF(LDEBUG)WRITE(LUNOUT,'(/'' ++++++ ALGGBC DEBUG : Garbage'', 62 - - '' collection statistics:''// 63 - - 26X,''Entry points in use: '',I4,'' (was: '',I4,'')''/ 64 - - 26X,''Instructions in use: '',I4,'' (was: '',I4,'')''/ 65 - - 26X,''Constant registers: '',I4,'' (was: '',I4,'')''/)') 66 - - NALGE,NEOLD,NINS,NIOLD,-5-NCONS,-5-NCOLD 67 - *** Reset unused portion of the instruction and constants storage. 68 - DO 90 I=IINS0,MXINS 69 - EXEC(I)=.TRUE. 70 - INS(I,1)=0 71 - INS(I,2)=0 72 - INS(I,3)=0 73 - INS(I,4)=0 74 - 90 CONTINUE 75 - DO 100 I=ICONS0,MXCONS,-1 76 - REG(I)=0.0 77 - 100 CONTINUE 78 - END 106 GARFIELD ================================================== P=ALGEBRA D=ALGINT 1 ============================ 0 + +DECK,ALGINT. 1 - SUBROUTINE ALGINT 2 - *----------------------------------------------------------------------- 3 - * ALGINT - Subroutine (re)initialising the /ALGDAT/ common block. 4 - * (Last changed on 30/ 8/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,ALGDATA. 9.- +SEQ,CONSTANTS. 10 - INTEGER I,J,IENTRY 11 - REAL CUMRNF(200) 12 - LOGICAL FUNSET 13 - COMMON /RNDFCM/ IENTRY,FUNSET,CUMRNF 14 - *** Initial number of constants, registers, results, errors, instr. 15 - NCONS=-6 16 - ICONS0=-7 17 - NREG=0 18 - NRES=0 19 - NINS=0 20 - IINS0=1 21 - *** Initialise error count. 22 - DO 60 I=1,100 23 - NAERR(I)=0 24 - 60 CONTINUE 25 - NERR=0 26 - *** Initialise the executability and the instructions. 27 - DO 10 I=1,MXINS 28 - EXEC(I)=.TRUE. 29 - INS(I,1)=0 30 - INS(I,2)=0 31 - INS(I,3)=0 32 - INS(I,4)=0 33 - 10 CONTINUE 34 - *** Initialise the values of all registers. 35 - DO 20 I=MXCONS,MXREG 36 - REG(I)=0 37 - 20 CONTINUE 38 - *** Initialise the constants. 39 - REG(0) =0.0 40 - REG(-1)=1.0 41 - REG(-2)=2.0 42 - REG(-3)=PI 43 - REG(-4)=0 44 - REG(-5)=1 45 - REG(-6)=0 46 - MODREG(0) =2 47 - MODREG(-1)=2 48 - MODREG(-2)=2 49 - MODREG(-3)=2 50 - MODREG(-4)=3 51 - MODREG(-5)=3 52 - MODREG(-6)=0 53 - *** Set the checking mode to algebra. 54 - ISYNCH=1 55 - *** Algebra options. 56 - LIGUND=.FALSE. 57 - *** Initialise the entry reference table. 58 - DO 30 I=1,MXALGE 59 - DO 40 J=1,9 60 - ALGENT(I,J)=0 61 - 40 CONTINUE 62 - 30 CONTINUE 63 - NALGE=0 64 - IENTRL=0 65 - *** Initialise the argument list and argument reference table. 66 - DO 50 I=1,MXARG 67 - ARG(I)=0.0 1 106 P=ALGEBRA D=ALGINT 2 PAGE 149 68 - MODARG(I)=0 69 - ARGREF(I,1)=-1 70 - ARGREF(I,2)=MXREG+1 71 - 50 CONTINUE 72 - *** Random number generators. 73 - FUNSET=.FALSE. 74 - END 107 GARFIELD ================================================== P=ALGEBRA D=ALGPRE 1 ============================ 0 + +DECK,ALGPRE. 1 - SUBROUTINE ALGPRE(T,NT,VARLIS,NVAR,NNRES,USE,IENTRY,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * ALGPRE - Subroutine translating the string T into a series of state- 4 - * ments to be executed by ALGEXE. 5 - * VARIABLES : VARLIS : List of acceptable parameter names. 6 - * NVAR : Number of elements in the VARLIS array. 7 - * T : The input string, it has NT elements. 8 - * S : Is T where operators have been replaced by 9 - * O, functions by F, constants and variables 10 - * by R. 11 - * P : Specifies which operation, function, 12 - * register is meant by the code in S. 13 - * USE(I) : .TRUE. if variable I is effectively used. 14 - * NNRES : =NRES, number of results found in T. 15 - * CHAR, NEXT, STRING, AUX: Auxiliary. 16 - * (Last changed on 11/ 3/00.) 17 - *----------------------------------------------------------------------- 18 - implicit none 19.- +SEQ,DIMENSIONS. 20.- +SEQ,ALGDATA. 21.- +SEQ,PRINTPLOT. 22 - CHARACTER CHAR,NEXT 23 - CHARACTER*9 MODFLG 24 - CHARACTER*10 VARLIS(MXVAR) 25 - CHARACTER*(*) T 26 - CHARACTER*(MXINCH) S 27 - INTEGER P(MXINCH),NBRACK,NINDEX,NT,NVAR,NNRES,IENTRY,IFAIL, 28 - - I,J,II,IT,IS,IV,IC,IN,IR,IFAILR,IFAILS,IFAILC,IAUX,LASTOP, 29 - - NDIM,IDIM,IDIM0,IARG,ISEND,JS,LENS,IIS,I1,I2, 30 - - MINREG,MAXREG,ISTART,IEXEC,NPASS 31 - REAL EPS,AUX 32 - LOGICAL OPER,LETTER,NUMBER,CHANGE,USE(MXVAR),REJECT,LOOP,PREC, 33 - - PRECS,RNDUSE,USECON 34 - *** Define some statement function to ease decoding. 35 - OPER (CHAR)=INDEX('+-*/=#<>&|^~',CHAR).NE.0 36 - LETTER(CHAR)=INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',CHAR).NE.0 37 - NUMBER(CHAR)=INDEX('.0123456789',CHAR).NE.0 38 - PREC(I,J)=(J.EQ.0).OR.(I.LE.9.AND.J.LE.9.AND.I.GE.J).OR. 39 - - (I.GE.10.AND.I.LE.15.AND.J.GE.10.AND.J.LE.15.AND.I.GE.J).OR. 40 - - (I.GE.16.AND.I.LE.17.AND.J.GE.16.AND.J.LE.17.AND.I.GE.J).OR. 41 - - (I.LE.9.AND.J.GE.10).OR.(I.LE.15.AND.J.GE.16) 42 - PRECS(I,J)=(J.EQ.0).OR. 43 - - (I.LE.9.AND.J.LE.9.AND.I.GE.J.AND. 44 - - (I.NE.2.OR.J.NE.2).AND.(I.NE.4.OR.J.NE.4).AND. 45 - - (I.NE.5.OR.J.NE.5)).OR. 46 - - (I.GE.10.AND.I.LE.15.AND.J.GE.10.AND.J.LE.15.AND.I.GE.J).OR. 47 - - (I.GE.16.AND.I.LE.17.AND.J.GE.16.AND.J.LE.17.AND.I.GE.J).OR. 48 - - (I.LE.9.AND.J.GE.10).OR.(I.LE.15.AND.J.GE.16) 49 - *** Define a few output formats. 50 - 1010 FORMAT(26X,'Constant ',I4,' = ',E15.7,', type=',I2) 51 - 1030 FORMAT(/,26X,I4,' Instructions are in use (Max =',I5,')', 52 - - /,26X,I4,' Registers are needed (Max =',I5,')', 53 - - /,26X,I4,' Constants have been defined (Max =',I5,')', 54 - - /,26X,I4,' Results are obtained (No maximum)') 55 - 1040 FORMAT(26X,'Variable ',I4,' = "',A10,'"') 56 - 1050 FORMAT(26X,'Variable ',I4,' = "',A10,'" (not used)') 57 - 1060 FORMAT(26X,'REG(',I3,')=',E15.7:'; REG(',I3,')=',E15.7) 58 - *** Identify the subroutine. 59 - IF(LIDENT)PRINT *,' /// ROUTINE ALGPRE ///' 60 - *** Check that NT does not exceed 80 characters. 61 - IF(NT.GT.LEN(T))THEN 62 - PRINT *,' ###### ALGPRE ERROR : Input string length', 63 - - ' specification inconsistent; rejected (program bug).' 64 - RETURN 65 - ENDIF 66 - *** Preset the counter variables etc. 67 - CALL ALGGBC 0 68-+ +SELF,IF=CRAY. 69 - EPS=1.0E-10 0 70-+ +SELF,IF=-CRAY. 71 - EPS=1.0E-5 0 72-+ +SELF. 73 - IFAIL=1 74 - REJECT=.FALSE. 75 - IT=0 76 - IS=1 77 - NBRACK=0 78 - NINDEX=0 79 - NRES=0 80 - NNRES=0 81 - S='$' 82 - DO 2 I=1,LEN(S) 83 - P(I)=0 84 - 2 CONTINUE 85 - *** Assign an entry point to the instruction list. 86 - IENTRY=IENTRL+1 87 - IENTRL=IENTRL+1 88 - IINS0=NINS+1 89 - ICONS0=NCONS-1 90 - * Check storage, perform a garbage collect if necessary. 91 - IF(NALGE+1.GT.MXALGE)THEN 92 - CALL ALGGBC 1 107 P=ALGEBRA D=ALGPRE 2 PAGE 150 93 - IF(NALGE+1.GT.MXALGE)THEN 94 - PRINT *,' !!!!!! ALGPRE WARNING : Unable to allocate'// 95 - - ' an entry point to the instruction list.' 96 - PRINT *,' Increase MXALGE'// 97 - - ' and recompile the program.' 98 - IFAIL=1 99 - IENTRY=-1 100 - RETURN 101 - ENDIF 102 - ENDIF 103 - NALGE=NALGE+1 104 - * Initialise the entry point record. 105 - ALGENT(NALGE,1)=IENTRY 106 - ALGENT(NALGE,2)=1 107 - ALGENT(NALGE,3)=0 108 - ALGENT(NALGE,4)=0 109 - ALGENT(NALGE,5)=IINS0 110 - ALGENT(NALGE,6)=0 111 - ALGENT(NALGE,7)=NVAR 112 - ALGENT(NALGE,8)=ICONS0 113 - ALGENT(NALGE,9)=0 114 - ALGENT(NALGE,10)=0 115 - *** Print the input expression if LDEBUG is on. 116 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGPRE DEBUG : Start of'', 117 - - '' the translation.''//26X,''Input string (length'',I3, 118 - - ''):''/26X,A)') NT,T(1:NT) 119 - *** First translation step: operaters -> O, numbers -> R, funct -> F. 120 - 10 CONTINUE 121 - IT=IT+1 122 - * Check that it does not exceed NT. 123 - IF(IT.GT.NT)THEN 124 - IF(IS.GE.LEN(S))GOTO 3010 125 - S(IS+1:IS+1)='$' 126 - IF(NBRACK.NE.0)THEN 127 - PRINT *,' ###### ALGPRE ERROR : Excess of opening'// 128 - - ' brackets.' 129 - REJECT=.TRUE. 130 - ENDIF 131 - GOTO 150 132 - ENDIF 133 - * Skip blanks. 134 - IF(T(IT:IT).EQ.' ')GOTO 10 135 - * Increment IS and check that IS < LEN(S). 136 - IS=IS+1 137 - IF(IS.GT.LEN(S))GOTO 3010 138 - ** Identify operators. 139 - IF(OPER(T(IT:IT)))THEN 140 - S(IS:IS)='O' 141 - IF(T(IT:IT).EQ.'+')THEN 142 - P(IS)=1 143 - ELSEIF(T(IT:IT).EQ.'-')THEN 144 - P(IS)=2 145 - ELSEIF(T(IT:IT).EQ.'*')THEN 146 - P(IS)=3 147 - IF(IT.LT.NT)THEN 148 - IF(T(IT+1:IT+1).EQ.'*')THEN 149 - P(IS)=5 150 - IT=IT+1 151 - ENDIF 152 - ENDIF 153 - ELSEIF(T(IT:IT).EQ.'/')THEN 154 - P(IS)=4 155 - ELSEIF(T(IT:IT).EQ.'=')THEN 156 - P(IS)=10 157 - IF(IT.LT.NT)THEN 158 - IF(T(IT+1:IT+1).EQ.'<')THEN 159 - P(IS)=13 160 - IT=IT+1 161 - ELSEIF(T(IT+1:IT+1).EQ.'>')THEN 162 - P(IS)=15 163 - IT=IT+1 164 - ENDIF 165 - ENDIF 166 - ELSEIF(T(IT:IT).EQ.'#')THEN 167 - P(IS)=11 168 - ELSEIF(T(IT:IT).EQ.'<')THEN 169 - P(IS)=12 170 - IF(IT.LT.NT)THEN 171 - IF(T(IT+1:IT+1).EQ.'=')THEN 172 - P(IS)=13 173 - IT=IT+1 174 - ELSEIF(T(IT+1:IT+1).EQ.'>')THEN 175 - P(IS)=11 176 - IT=IT+1 177 - ENDIF 178 - ENDIF 179 - ELSEIF(T(IT:IT).EQ.'>')THEN 180 - P(IS)=14 181 - IF(IT.LT.NT)THEN 182 - IF(T(IT+1:IT+1).EQ.'=')THEN 183 - P(IS)=15 184 - IT=IT+1 185 - ELSEIF(T(IT+1:IT+1).EQ.'<')THEN 186 - P(IS)=11 187 - IT=IT+1 188 - ENDIF 189 - ENDIF 190 - ELSEIF(T(IT:IT).EQ.'&')THEN 191 - P(IS)=16 192 - ELSEIF(T(IT:IT).EQ.'|')THEN 193 - P(IS)=17 194 - ELSEIF(T(IT:IT).EQ.'^'.OR.T(IT:IT).EQ.'~')THEN 195 - P(IS)=18 196 - ENDIF 197 - ** Identify variable and function names. 198 - ELSEIF(LETTER(T(IT:IT)))THEN 1 107 P=ALGEBRA D=ALGPRE 3 PAGE 151 199 - IV=IT 200 - 20 CONTINUE 201 - IV=IV+1 202 - IF(IV.GT.NT)GOTO 30 203 - IF((.NOT.OPER(T(IV:IV))).AND. 204 - - INDEX(' ([)],;',T(IV:IV)).EQ.0)GOTO 20 205 - 30 CONTINUE 206 - NEXT=',' 207 - DO 40 IN=IV,NT 208 - IF(T(IN:IN).NE.' ')THEN 209 - NEXT=T(IN:IN) 210 - GOTO 50 211 - ENDIF 212 - 40 CONTINUE 213 - 50 CONTINUE 214 - IF(OPER(NEXT).OR.INDEX(',)[];',NEXT).NE.0)THEN 215 - S(IS:IS)='R' 216 - DO 60 IR=1,NVAR 217 - IF(T(IT:MIN(IT+LEN(VARLIS(IR))-1,IV-1)).EQ. 218 - - VARLIS(IR))THEN 219 - IF(IV-IT.GT.LEN(VARLIS(IR)))PRINT *, 220 - - ' !!!!!! ALGPRE WARNING : ',T(IT:IV-1), 221 - - ' is too long for a variable name; has'// 222 - - ' been matched with '//VARLIS(IR) 223 - P(IS)=IR 224 - GOTO 70 225 - ENDIF 226 - 60 CONTINUE 227 - IF(T(IT:IV-1).EQ.'PI')THEN 228 - P(IS)=-3 229 - ELSEIF(T(IT:IV-1).EQ.'FALSE')THEN 230 - P(IS)=-4 231 - ELSEIF(T(IT:IV-1).EQ.'TRUE')THEN 232 - P(IS)=-5 233 - ELSEIF(T(IT:IV-1).EQ.'NILL')THEN 234 - P(IS)=-6 235 - ELSEIF(T(IT:IV-1).EQ.'RND_UNIFORM')THEN 236 - S(IS:IS)='G' 237 - P(IS)=1 238 - ELSEIF(T(IT:IV-1).EQ.'RND_GAUSS'.OR. 239 - - T(IT:IV-1).EQ.'RND_NORMAL')THEN 240 - S(IS:IS)='G' 241 - P(IS)=2 242 - ELSEIF(T(IT:IV-1).EQ.'RND_EXP'.OR. 243 - - T(IT:IV-1).EQ.'RND_EXPONENTIAL')THEN 244 - S(IS:IS)='G' 245 - P(IS)=3 246 - ELSEIF(T(IT:IV-1).EQ.'RND_POISSON')THEN 247 - S(IS:IS)='G' 248 - P(IS)=4 249 - ELSEIF(T(IT:IV-1).EQ.'RND_LANDAU')THEN 250 - S(IS:IS)='G' 251 - P(IS)=5 252 - ELSEIF(T(IT:IV-1).EQ.'RND_POLYA')THEN 253 - S(IS:IS)='G' 254 - P(IS)=6 255 - ELSEIF(T(IT:IV-1).EQ.'RND_FUNCTION')THEN 256 - S(IS:IS)='G' 257 - P(IS)=7 258 - ELSE 259 - PRINT *,' ###### ALGPRE ERROR : ',T(IT:IV-1), 260 - - ' is not a valid parameter.' 261 - REJECT=.TRUE. 262 - ENDIF 263 - 70 CONTINUE 264 - ELSE 265 - P(IS)=0 266 - IF(T(IT:IV-1).EQ.'EXP') P(IS)= 1 267 - IF(T(IT:IV-1).EQ.'LOG') P(IS)=-1 268 - IF(T(IT:IV-1).EQ.'SIN') P(IS)= 2 269 - IF(T(IT:IV-1).EQ.'COS') P(IS)= 3 270 - IF(T(IT:IV-1).EQ.'TAN') P(IS)= 4 271 - IF(T(IT:IV-1).EQ.'ARCSIN') P(IS)=-2 272 - IF(T(IT:IV-1).EQ.'ARCCOS') P(IS)=-3 273 - IF(T(IT:IV-1).EQ.'ARCTAN') P(IS)=-4 274 - IF(T(IT:IV-1).EQ.'ABS') P(IS)= 5 275 - IF(T(IT:IV-1).EQ.'SQRT') P(IS)=-5 276 - IF(T(IT:IV-1).EQ.'SINH') P(IS)= 7 277 - IF(T(IT:IV-1).EQ.'COSH') P(IS)= 8 278 - IF(T(IT:IV-1).EQ.'TANH') P(IS)= 9 279 - IF(T(IT:IV-1).EQ.'ARCSINH') P(IS)=-7 280 - IF(T(IT:IV-1).EQ.'ARCCOSH') P(IS)=-8 281 - IF(T(IT:IV-1).EQ.'ARCTANH') P(IS)=-9 282 - IF(T(IT:IV-1).EQ.'NOT') P(IS)=10 283 - IF(T(IT:IV-1).EQ.'ENTIER') P(IS)=11 284 - IF(T(IT:IV-1).EQ.'TRAILING')P(IS)=-11 285 - IF(T(IT:IV-1).EQ.'STRING' )P(IS)=12 286 - IF(T(IT:IV-1).EQ.'NUMBER' )P(IS)=-12 287 - IF(T(IT:IV-1).EQ.'SUM' )P(IS)=13 288 - IF(T(IT:IV-1).EQ.'PRODUCT' )P(IS)=14 289 - IF(T(IT:IV-1).EQ.'REFERENCE'.OR. 290 - - T(IT:IV-1).EQ.'REF')P(IS)=15 291 - IF(T(IT:IV-1).EQ.'REF_STRING')P(IS)=51 292 - IF(T(IT:IV-1).EQ.'REF_HISTOGRAM'.OR. 293 - - T(IT:IV-1).EQ.'REF_HIST')P(IS)=54 294 - IF(T(IT:IV-1).EQ.'REF_MATRIX')P(IS)=55 295 - IF(T(IT:IV-1).EQ.'GLOBAL' )P(IS)=16 296 - IF(T(IT:IV-1).EQ.'TYPE' )P(IS)=17 297 - IF(T(IT:IV-1).EQ.'LANDAU' )P(IS)=18 298 - IF(T(IT:IV-1).EQ.'MINIMUM' )P(IS)=19 299 - IF(T(IT:IV-1).EQ.'MAXIMUM' )P(IS)=20 300 - IF(T(IT:IV-1).EQ.'RND_UNIFORM')P(IS)=21 301 - IF(T(IT:IV-1).EQ.'RND_EXP'.OR. 302 - - T(IT:IV-1).EQ.'RND_EXPONENTIAL')P(IS)=23 303 - IF(T(IT:IV-1).EQ.'RND_POISSON')P(IS)=24 304 - IF(T(IT:IV-1).EQ.'RND_POLYA')P(IS)=26 1 107 P=ALGEBRA D=ALGPRE 4 PAGE 152 305 - IF(T(IT:IV-1).EQ.'RND_HISTOGRAM')P(IS)=28 306 - IF(T(IT:IV-1).EQ.'ROW' )P(IS)=40 307 - IF(T(IT:IV-1).EQ.'MEAN' )P(IS)=41 308 - IF(T(IT:IV-1).EQ.'RMS' )P(IS)=42 309 - IF(P(IS).EQ.0)THEN 310 - PRINT *,' ###### ALGPRE ERROR : ',T(IT:IV-1), 311 - - ' is not a valid function.' 312 - REJECT=.TRUE. 313 - ENDIF 314 - S(IS:IS)='F' 315 - ENDIF 316 - IT=IV-1 317 - ** Pick up strings. 318 - ELSEIF(T(IT:IT).EQ.'"'.OR.T(IT:IT).EQ.'`')THEN 319 - IC=IT 320 - 80 CONTINUE 321 - IC=IC+1 322 - * Make sure we did see the terminating quote. 323 - IF(IC.GT.NT)THEN 324 - PRINT *,' !!!!!! ALGPRE WARNING : Strings should be'// 325 - - ' terminated by a double quote; quote assumed.' 326 - GOTO 90 327 - ELSEIF(T(IC:IC).EQ.T(IT:IT))THEN 328 - GOTO 90 329 - ENDIF 330 - GOTO 80 331 - 90 CONTINUE 332 - * Assign the string pointer to the constant list. 333 - S(IS:IS)='R' 334 - NCONS=NCONS-1 335 - IF(NCONS.LT.MXCONS)GOTO 3020 336 - * If the string isn't empty, put it in the string buffer. 337 - IF(IC-1.GE.IT+1)THEN 338 - CALL STRBUF('STORE',IAUX,T(IT+1:IC-1),IC-IT-1,IFAILS) 339 - IF(IFAILS.NE.0)THEN 340 - PRINT *,' !!!!!! ALGPRE WARNING : Unable to'// 341 - - ' store the string "',T(IT+1:IC-1), 342 - - '"; formula rejected.' 343 - REJECT=.TRUE. 344 - REG(NCONS)=0.0 345 - ELSE 346 - REG(NCONS)=REAL(IAUX) 347 - ENDIF 348 - * A null string is stored as a blank string with length zero. 349 - ELSE 350 - CALL STRBUF('STORE',IAUX,' ',0,IFAILS) 351 - IF(IFAILS.NE.0)THEN 352 - PRINT *,' !!!!!! ALGPRE WARNING : Unable to'// 353 - - ' store the null string; formula rejected.' 354 - REJECT=.TRUE. 355 - REG(NCONS)=0.0 356 - ELSE 357 - REG(NCONS)=REAL(IAUX) 358 - ENDIF 359 - ENDIF 360 - * Keep track of the type of the variable. 361 - MODREG(NCONS)=1 362 - P(IS)=NCONS 363 - * Update string pointer. 364 - IT=IC 365 - * Identify numbers (constants) and assign them to a register. 366 - ELSEIF(NUMBER(T(IT:IT)))THEN 367 - IC=IT 368 - 100 CONTINUE 369 - IC=IC+1 370 - IF(IC.GT.NT)GOTO 110 371 - IF(NUMBER(T(IC:IC)))GOTO 100 372 - IF(T(IC:IC).EQ.'E')THEN 373 - IC=IC+1 374 - IF(IC.GT.NT)GOTO 110 375 - IF(T(IC:IC).EQ.'+'.OR.T(IC:IC).EQ.'-')IC=IC+1 376 - GOTO 100 377 - ENDIF 378 - 110 CONTINUE 379 - S(IS:IS)='R' 380 - CALL INPRRC(T(IT:IC-1),AUX,0.0,IFAILR) 381 - IF(IFAILR.NE.0)THEN 382 - PRINT *,' ###### ALGPRE ERROR : ',T(IT:IC-1), 383 - - ' is not acceptable as a number.' 384 - REJECT=.TRUE. 385 - ENDIF 386 - * See whether the number is already known globally or in this list. 387 - DO 120 II=0,NCONS,-1 388 - IF(MODREG(II).EQ.2.AND.(II.GE.-3.OR.II.LE.ICONS0).AND. 389 - - ABS(REG(II)-AUX).LE.EPS*(ABS(REG(II))+ABS(AUX)))THEN 390 - P(IS)=II 391 - GOTO 130 392 - ENDIF 393 - 120 CONTINUE 394 - * If not known, add it to the list. 395 - NCONS=NCONS-1 396 - IF(NCONS.LT.MXCONS)GOTO 3020 397 - REG(NCONS)=AUX 398 - MODREG(NCONS)=2 399 - P(IS)=NCONS 400 - 130 CONTINUE 401 - * Update string pointer. 402 - IT=IC-1 403 - * Count brackets, reject if at any time < 0. 404 - ELSEIF(INDEX(')',T(IT:IT)).NE.0)THEN 405 - NBRACK=NBRACK-1 406 - S(IS:IS)=')' 407 - IF(NBRACK.LT.0)THEN 408 - PRINT *,' ###### ALGPRE ERROR : Excess of closing'// 409 - - ' brackets.' 410 - REJECT=.TRUE. 1 107 P=ALGEBRA D=ALGPRE 5 PAGE 153 411 - ENDIF 412 - ELSEIF(INDEX('(',T(IT:IT)).NE.0)THEN 413 - NBRACK=NBRACK+1 414 - S(IS:IS)='(' 415 - * Matrix indices, check that there is no nesting. 416 - ELSEIF(INDEX(']',T(IT:IT)).NE.0)THEN 417 - NINDEX=NINDEX-1 418 - S(IS:IS)=']' 419 - IF(NINDEX.LT.0)THEN 420 - PRINT *,' ###### ALGPRE ERROR : Incorrect array'// 421 - - ' indexing.' 422 - REJECT=.TRUE. 423 - ENDIF 424 - ELSEIF(INDEX('[',T(IT:IT)).NE.0)THEN 425 - NINDEX=NINDEX+1 426 - S(IS:IS)='[' 427 - C IF(NINDEX.GT.1)THEN 428 - C PRINT *,' ###### ALGPRE ERROR : Index nesting is'// 429 - C - ' not permitted.' 430 - C REJECT=.TRUE. 431 - C ENDIF 432 - ELSEIF(INDEX(';',T(IT:IT)).NE.0)THEN 433 - S(IS:IS)=';' 434 - IF(NINDEX.NE.1)THEN 435 - PRINT *,' ###### ALGPRE ERROR : Semicolons can'// 436 - - ' only be used in indexing expressions' 437 - REJECT=.TRUE. 438 - ENDIF 439 - ELSEIF(INDEX(',',T(IT:IT)).NE.0.AND.NINDEX.EQ.1)THEN 440 - S(IS:IS)=',' 441 - * Expression delimiter, check balance of brackets. 442 - ELSEIF(T(IT:IT).EQ.',')THEN 443 - S(IS:IS)='$' 444 - IF(NBRACK.NE.0)THEN 445 - PRINT *,' ###### ALGPRE ERROR : Excess of opening'// 446 - - ' brackets in a sub expression.' 447 - REJECT=.TRUE. 448 - ENDIF 449 - IF(NINDEX.NE.0)THEN 450 - PRINT *,' ###### ALGPRE ERROR : Index expression'// 451 - - ' not ended before end of formula.' 452 - REJECT=.TRUE. 453 - ENDIF 454 - * Invalid element. 455 - ELSE 456 - PRINT *,' !!!!!! ALGPRE WARNING : Invalid element "', 457 - - T(IT:IT),'" ignored.' 458 - IS=IS-1 459 - ENDIF 460 - * End of loop. 461 - GOTO 10 462 - 150 CONTINUE 463 - * Print the list if LDEBUG is on. 464 - IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Code string:''/26X,A)') 465 - - S(1:MIN(LEN(S),IS+1)) 466 - * Replace $-, (-, O- and F- by functions (-6), $+ etc by F +6. 467 - DO 160 IS=1,LEN(S)-1 468 - IF(INDEX('$(OF',S(IS:IS)).NE.0.AND.S(IS+1:IS+1).EQ.'O'.AND. 469 - - (P(IS+1).EQ.1.OR.P(IS+1).EQ.2.OR.P(IS+1).EQ.18))THEN 470 - S(IS+1:IS+1)='F' 471 - IF(P(IS+1).EQ.1)P(IS+1)=+6 472 - IF(P(IS+1).EQ.2)P(IS+1)=-6 473 - IF(P(IS+1).EQ.18)P(IS+1)=10 474 - ENDIF 475 - IF(S(IS+1:IS+1).EQ.'O'.AND.P(IS+1).EQ.18)THEN 476 - C PRINT *,' ###### ALGPRE ERROR : A "not" symbol (^ or ~)'// 477 - C - ' has been used as a binary operator ; rejected.' 478 - C REJECT=.TRUE. 479 - P(IS+1)=5 480 - ENDIF 481 - 160 CONTINUE 482 - *** Next check syntax: sequence of symbols. 483 - DO 200 IS=1,LEN(S)-1 484 - IF( (S(IS:IS).EQ.'$'.AND.INDEX('RG(F ' ,S(IS+1:IS+1)).EQ.0).OR. 485 - - (S(IS:IS).EQ.'('.AND.INDEX('RGF(' ,S(IS+1:IS+1)).EQ.0).OR. 486 - - (S(IS:IS).EQ.')'.AND.INDEX('O$),;[]',S(IS+1:IS+1)).EQ.0).OR. 487 - - (S(IS:IS).EQ.'['.AND.INDEX('RGF(;]' ,S(IS+1:IS+1)).EQ.0).OR. 488 - - (S(IS:IS).EQ.']'.AND.INDEX('O$),;]' ,S(IS+1:IS+1)).EQ.0).OR. 489 - - (S(IS:IS).EQ.';'.AND.INDEX('R(F];' ,S(IS+1:IS+1)).EQ.0).OR. 490 - - (S(IS:IS).EQ.','.AND.INDEX('R(F' ,S(IS+1:IS+1)).EQ.0).OR. 491 - - (S(IS:IS).EQ.'R'.AND.INDEX(')O$,;[]',S(IS+1:IS+1)).EQ.0).OR. 492 - - (S(IS:IS).EQ.'G'.AND.INDEX(')O$' ,S(IS+1:IS+1)).EQ.0).OR. 493 - - (S(IS:IS).EQ.'O'.AND.INDEX('RGF(' ,S(IS+1:IS+1)).EQ.0).OR. 494 - - (S(IS:IS).EQ.'F'.AND.INDEX('RG(F' ,S(IS+1:IS+1)).EQ.0)) 495 - - THEN 496 - PRINT *,' ###### ALGPRE ERROR : Syntax error (illegal'// 497 - - ' sequence of symbols).' 498 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Error occurs at IS='',I2, 499 - - '' in "'',A2,''".'')') IS,S(IS:IS+1) 500 - REJECT=.TRUE. 501 - ENDIF 502 - 200 CONTINUE 503 - *** Return if syntax errors have been found. 504 - IF(REJECT)THEN 505 - PRINT *,' ###### ALGPRE ERROR : ',T(1:NT), 506 - - ' is rejected because of the above errors.' 507 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGPRE DEBUG : End'', 508 - - '' of the debugging output.'')') 509 - RETURN 510 - ENDIF 511 - * Print the values of the constants if LDEBUG is on. 512 - IF(LDEBUG)THEN 513 - IF(NCONS.LT.ICONS0)THEN 514 - WRITE(LUNOUT,'(/,26X,''Constants used in the'', 515 - - '' expression, apart from 0, 1, 2 and PI:'')') 516 - DO 180 I=ICONS0,NCONS,-1 1 107 P=ALGEBRA D=ALGPRE 6 PAGE 154 517 - WRITE(LUNOUT,1010) I,REG(I),MODREG(I) 518 - 180 CONTINUE 519 - WRITE(LUNOUT,'('' '')') 520 - ELSE 521 - WRITE(LUNOUT,'(/,26X,''Apart from 0, 1, 2 and PI,'', 522 - - '' no constants have been defined.'',/)') 523 - ENDIF 524 - ENDIF 525 - *** Transform into a list of executable instructions. 526 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Instruction list building:''/)') 527 - NREG=NVAR 528 - NPASS=0 529 - RNDUSE=.FALSE. 530 - 210 CONTINUE 531 - NPASS=NPASS+1 532 - CHANGE=.FALSE. 533 - ** Replace 'G' by 'R' 534 - DO 219 IS=2,LEN(S)-1 535 - IF(S(IS:IS).EQ.'G')THEN 536 - RNDUSE=.TRUE. 537 - NINS=NINS+1 538 - IF(NINS.GT.MXINS)GOTO 3040 539 - INS(NINS,1)=20+P(IS) 540 - INS(NINS,2)=6 541 - INS(NINS,3)=-1 542 - NREG=NREG+1 543 - IF(NREG.GT.MXREG)GOTO 3030 544 - P(IS)=NREG 545 - INS(NINS,4)=P(IS) 546 - S(IS:IS)='R' 547 - CHANGE=.TRUE. 548 - ENDIF 549 - 219 CONTINUE 550 - ** Replace 'FR' by a new 'R'. 551 - DO 220 IS=2,LEN(S)-1 552 - IF(S(IS:IS+1).EQ.'FR')THEN 553 - NINS=NINS+1 554 - IF(NINS.GT.MXINS)GOTO 3040 555 - INS(NINS,1)=P(IS) 556 - IF(P(IS).GT.20.AND.P(IS).LE.30)RNDUSE=.TRUE. 557 - INS(NINS,2)=6 558 - INS(NINS,3)=P(IS+1) 559 - IF(P(IS+1).LE.0)THEN 560 - NCONS=NCONS-1 561 - IF(NCONS.LT.MXCONS)GOTO 3020 562 - P(IS)=NCONS 563 - ELSE 564 - NREG=NREG+1 565 - IF(NREG.GT.MXREG)GOTO 3030 566 - P(IS)=NREG 567 - ENDIF 568 - INS(NINS,4)=P(IS) 569 - S(IS:IS+1)='R ' 570 - P(IS+1)=0 571 - CHANGE=.TRUE. 572 - ENDIF 573 - 220 CONTINUE 574 - ** Replace 'ROR' by a new 'R'. 575 - DO 230 IS=2,LEN(S)-3 576 - LASTOP=0 577 - DO 231 IIS=IS-1,1,-1 578 - IF(S(IIS:IIS).EQ.'O')THEN 579 - LASTOP=P(IIS) 580 - ELSEIF(S(IIS:IIS).NE.' ')THEN 581 - GOTO 232 582 - ENDIF 583 - 231 CONTINUE 584 - 232 CONTINUE 585 - IF((S(IS:IS+3).EQ.'ROR)'.OR.S(IS:IS+3).EQ.'ROR$'.OR. 586 - - S(IS:IS+3).EQ.'ROR]'.OR.S(IS:IS+3).EQ.'ROR,'.OR. 587 - - S(IS:IS+3).EQ.'ROR;'.OR. 588 - - (S(IS:IS+3).EQ.'RORO'.AND.PREC(P(IS+1),P(IS+3)))).AND. 589 - - PRECS(P(IS+1),LASTOP))THEN 590 - NINS=NINS+1 591 - IF(NINS.GT.MXINS)GOTO 3040 592 - INS(NINS,1)=P(IS) 593 - INS(NINS,2)=P(IS+1) 594 - INS(NINS,3)=P(IS+2) 595 - IF(P(IS).LE.0.AND.P(IS+2).LE.0)THEN 596 - NCONS=NCONS-1 597 - IF(NCONS.LT.MXCONS)GOTO 3020 598 - P(IS+2)=NCONS 599 - ELSE 600 - NREG=NREG+1 601 - IF(NREG.GT.MXREG)GOTO 3030 602 - P(IS+2)=NREG 603 - ENDIF 604 - S(IS:IS+2)=' R' 605 - P(IS)=0 606 - P(IS+1)=0 607 - INS(NINS,4)=P(IS+2) 608 - CHANGE=.TRUE. 609 - ENDIF 610 - 230 CONTINUE 611 - ** Process indexing expressions. 612 - DO 260 IS=1,LEN(S)-1 613 - * Look for opening 'R[' patterns. 614 - IF(S(IS:IS+1).EQ.'R[')THEN 615 - * If found, scan for the closing ] and quit if expressions remain. 616 - NDIM=1 617 - DO 261 JS=IS+2,LEN(S)-1 618 - IF(S(JS:JS).EQ.']')THEN 619 - ISEND=JS 620 - GOTO 262 621 - ELSEIF(S(JS:JS).EQ.';')THEN 622 - NDIM=NDIM+1 1 107 P=ALGEBRA D=ALGPRE 7 PAGE 155 623 - ELSEIF(INDEX(' ,R',S(JS:JS)).EQ.0)THEN 624 - GOTO 260 625 - ENDIF 626 - 261 CONTINUE 627 - * Closing ] not present, issue warning and quit. 628 - PRINT *,' !!!!!! ALGPRE WARNING : End of index expression'// 629 - - ' not found.' 630 - IFAIL=1 631 - RETURN 632 - * Generate the argument list for the procedure call. 633 - 262 CONTINUE 634 - IARG=0 635 - * Number of dimensions. 636 - NINS=NINS+1 637 - IF(NINS.GT.MXINS)GOTO 3040 638 - NCONS=NCONS-1 639 - IF(NCONS.LT.MXCONS)GOTO 3020 640 - REG(NCONS)=REAL(NDIM) 641 - MODREG(NCONS)=2 642 - INS(NINS,1)=3 643 - INS(NINS,2)=8 644 - INS(NINS,3)=NCONS 645 - IARG=IARG+1 646 - INS(NINS,4)=IARG 647 - * Number of declarations per dimension. 648 - IDIM0=NCONS 649 - DO 263 IDIM=1,NDIM 650 - NINS=NINS+1 651 - IF(NINS.GT.MXINS)GOTO 3040 652 - NCONS=NCONS-1 653 - IF(NCONS.LT.MXCONS)GOTO 3020 654 - REG(IDIM0-IDIM)=0 655 - MODREG(IDIM0-IDIM)=2 656 - IARG=IARG+1 657 - INS(NINS,1)=3 658 - INS(NINS,2)=8 659 - INS(NINS,3)=IDIM0-IDIM 660 - INS(NINS,4)=IARG 661 - 263 CONTINUE 662 - * Each of the dimensions. 663 - IDIM=0 664 - DO 264 JS=IS+1,ISEND-1 665 - IF(S(JS:JS).EQ.' ')THEN 666 - GOTO 264 667 - ELSEIF(S(JS:JS).EQ.'R')THEN 668 - NINS=NINS+1 669 - IF(NINS.GT.MXINS)GOTO 3040 670 - IARG=IARG+1 671 - INS(NINS,1)=3 672 - INS(NINS,2)=8 673 - INS(NINS,3)=P(JS) 674 - INS(NINS,4)=IARG 675 - REG(IDIM0-IDIM)=REG(IDIM0-IDIM)+1 676 - ELSEIF(INDEX(';[',S(JS:JS)).NE.0)THEN 677 - IDIM=IDIM+1 678 - ENDIF 679 - 264 CONTINUE 680 - * Update the string. 681 - S(IS+1:IS+1)='I' 682 - P(IS+1)=IARG 683 - DO 265 JS=IS+2,ISEND 684 - S(JS:JS)=' ' 685 - P(JS)=0 686 - 265 CONTINUE 687 - * Replace 'RI' by 'R', add the input matrix as argument. 688 - NINS=NINS+1 689 - IF(NINS.GT.MXINS)GOTO 3040 690 - INS(NINS,1)=3 691 - INS(NINS,2)=8 692 - INS(NINS,3)=P(IS) 693 - INS(NINS,4)=P(IS+1)+1 694 - * Find the location for the output matrix. 695 - IF(P(IS).LE.0)THEN 696 - NCONS=NCONS-1 697 - IF(NCONS.LT.MXCONS)GOTO 3020 698 - P(IS)=NCONS 699 - ELSE 700 - NREG=NREG+1 701 - IF(NREG.GT.MXREG)GOTO 3030 702 - P(IS)=NREG 703 - ENDIF 704 - * Add the output matrix as argument. 705 - NINS=NINS+1 706 - IF(NINS.GT.MXINS)GOTO 3040 707 - INS(NINS,1)=1 708 - INS(NINS,2)=8 709 - INS(NINS,3)=P(IS) 710 - INS(NINS,4)=P(IS+1)+2 711 - * Generate procedure call. 712 - NINS=NINS+1 713 - IF(NINS.GT.MXINS)GOTO 3040 714 - INS(NINS,1)=-80 715 - INS(NINS,2)=9 716 - INS(NINS,3)=P(IS+1)+2 717 - INS(NINS,4)=0 718 - * Update the string. 719 - S(IS:IS+1)='R ' 720 - P(IS+1)=0 721 - * Remember that we changed something. 722 - CHANGE=.TRUE. 723 - ENDIF 724 - * Next element. 725 - 260 CONTINUE 726 - ** Replace '(R)' by 'R' and remove blanks. 727 - IS=1 728 - DO 240 I=2,LEN(S) 1 107 P=ALGEBRA D=ALGPRE 8 PAGE 156 729 - IF(S(I:I).EQ.' ')GOTO 240 730 - IS=IS+1 731 - S(IS:IS)=S(I:I) 732 - IF(I.NE.IS)S(I:I)=' ' 733 - P(IS)=P(I) 734 - IF(I.NE.IS)P(I)=0 735 - IF(IS.LE.2)GOTO 240 736 - IF(S(IS-2:IS).EQ.'(R)')THEN 737 - S(IS-2:IS)='R ' 738 - P(IS-2)=P(IS-1) 739 - P(IS-1)=0 740 - P(IS)=0 741 - IS=IS-2 742 - CHANGE=.TRUE. 743 - ENDIF 744 - 240 CONTINUE 745 - ** Print the current string. 746 - IF(LDEBUG)THEN 747 - IF(CHANGE)THEN 748 - DO 241 IIS=LEN(S),1,-1 749 - IF(S(IIS:IIS).NE.' ')THEN 750 - LENS=IIS 751 - GOTO 242 752 - ENDIF 753 - 241 CONTINUE 754 - LENS=1 755 - 242 CONTINUE 756 - WRITE(LUNOUT,'(26X,''Pass'',I3,'': '',A)') 757 - - NPASS,S(1:LENS) 758 - ELSE 759 - WRITE(LUNOUT,'(26X,''No further passes.''/)') 760 - ENDIF 761 - ENDIF 762 - * Check whether further cycles are needed. 763 - IF(CHANGE)GOTO 210 764 - ** Generate instructions to delete temporary matrices. 765 - DO 270 I=IINS0+1,NINS 766 - * Select STORE_SUBMATRIX calls. 767 - IF(INS(I,1).NE.-80.OR.INS(I,2).NE.9)GOTO 270 768 - * Make sure the output matrix isn't used as a result. 769 - DO 280 IS=1,LEN(S)-2 770 - IF(S(IS:IS+2).EQ.'$R$'.AND.P(IS+1).EQ.INS(I-1,3))GOTO 270 771 - 280 CONTINUE 772 - * Add the DELETE_MATRIX call to the list. 773 - IF(NINS+2.GT.MXINS)GOTO 3040 774 - NINS=NINS+1 775 - INS(NINS,1)=0 776 - INS(NINS,2)=8 777 - INS(NINS,3)=INS(I-1,3) 778 - INS(NINS,4)=1 779 - NINS=NINS+1 780 - INS(NINS,1)=-86 781 - INS(NINS,2)=9 782 - INS(NINS,3)=1 783 - INS(NINS,4)=0 784 - 270 CONTINUE 785 - ** Find the results. 786 - NRES=0 787 - DO 250 IS=1,LEN(S)-2 788 - IF(S(IS:IS+2).EQ.'$R$')THEN 789 - NRES=NRES+1 790 - IF(NINS.GE.MXINS)GOTO 3040 791 - NINS=NINS+1 792 - INS(NINS,2)=0 793 - INS(NINS,3)=P(IS+1) 794 - INS(NINS,4)=NRES 795 - ENDIF 796 - 250 CONTINUE 797 - * Make sure there is at least one. 798 - IF(NRES.LE.0)THEN 799 - PRINT *,' !!!!!! ALGPRE WARNING : Unable to find a result'// 800 - - ' in the expression;' 801 - RETURN 802 - ENDIF 803 - NNRES=NRES 804 - ** Add a return statement. 805 - IF(NINS.GE.MXINS)GOTO 3040 806 - NINS=NINS+1 807 - INS(NINS,1)=-1 808 - INS(NINS,2)=-9 809 - INS(NINS,3)=0 810 - INS(NINS,4)=0 811 - *** Skip simplications if there are randon number generators. 812 - IF(RNDUSE)THEN 813 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Simplication is skipped'', 814 - - '' because of the use of random number generators.'')') 815 - GOTO 600 816 - ENDIF 817 - *** Start of the ALGSIM entry for simplifications. 818 - ENTRY ALGSIM(VARLIS,NVAR,USE,IFAIL) 819 - * First check whether there are loop structures. 820 - LOOP=.FALSE. 821 - DO 310 I=IINS0,NINS 822 - IF(INS(I,2).EQ.7)LOOP=.TRUE. 823 - 310 CONTINUE 824 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Loop structure flag:'',L2/)') LOOP 825 - * Print the list if LDEBUG is on. 826 - IF(LDEBUG)THEN 827 - WRITE(LUNOUT,'(26X,''Raw instruction list:'')') 828 - CALL ALGPRT(IINS0,NINS) 829 - WRITE(LUNOUT,'(/,26X,''Simplifications (if any):'')') 830 - ENDIF 831 - ** Repeat the simplification step until no further changes occur. 832 - 300 CONTINUE 833 - CHANGE=.FALSE. 834 - MODFLG=' ' 1 107 P=ALGEBRA D=ALGPRE 9 PAGE 157 835 - * First simplify the expressions. 836 - DO 320 I=IINS0,NINS 837 - IF(INS(I,2).EQ.1.AND.(INS(I,1).EQ.0.OR.INS(I,3).EQ.0))THEN 838 - IF(INS(I,3).EQ.0)INS(I,3)=INS(I,1) 839 - INS(I,1)=6 840 - INS(I,2)=6 841 - CHANGE=.TRUE. 842 - MODFLG(1:1)='S' 843 - ENDIF 844 - IF(INS(I,2).EQ.2.AND.INS(I,1).EQ.INS(I,3))THEN 845 - INS(I,1)=6 846 - INS(I,2)=6 847 - INS(I,3)=0 848 - CHANGE=.TRUE. 849 - MODFLG(1:1)='S' 850 - ENDIF 851 - IF(INS(I,2).EQ.2.AND.INS(I,3).EQ.0)THEN 852 - INS(I,3)=INS(I,1) 853 - INS(I,1)=6 854 - INS(I,2)=6 855 - CHANGE=.TRUE. 856 - MODFLG(1:1)='S' 857 - ENDIF 858 - IF(INS(I,2).EQ.2.AND.INS(I,1).EQ.0)THEN 859 - INS(I,1)=-6 860 - INS(I,2)=6 861 - CHANGE=.TRUE. 862 - MODFLG(1:1)='S' 863 - ENDIF 864 - IF(INS(I,2).EQ.3.AND.(INS(I,1).EQ.0.OR.INS(I,3).EQ.0))THEN 865 - INS(I,1)=6 866 - INS(I,2)=6 867 - INS(I,3)=0 868 - CHANGE=.TRUE. 869 - MODFLG(1:1)='S' 870 - ENDIF 871 - IF(INS(I,2).EQ.3.AND.(INS(I,1).EQ.-1.OR.INS(I,3).EQ.-1))THEN 872 - IF(INS(I,3).EQ.-1)INS(I,3)=INS(I,1) 873 - INS(I,1)=6 874 - INS(I,2)=6 875 - CHANGE=.TRUE. 876 - MODFLG(1:1)='S' 877 - ENDIF 878 - IF(INS(I,2).EQ.4.AND.INS(I,1).EQ.INS(I,3))THEN 879 - INS(I,1)=6 880 - INS(I,2)=6 881 - INS(I,3)=-1 882 - CHANGE=.TRUE. 883 - MODFLG(1:1)='S' 884 - ENDIF 885 - IF(INS(I,2).EQ.4.AND.INS(I,3).EQ.0)THEN 886 - PRINT *,' ###### ALGPRE ERROR : Division by 0;'// 887 - - ' expression is rejected.' 888 - RETURN 889 - ENDIF 890 - IF(INS(I,2).EQ.5.AND.INS(I,3).EQ.0)THEN 891 - INS(I,1)=6 892 - INS(I,2)=6 893 - INS(I,3)=-1 894 - CHANGE=.TRUE. 895 - MODFLG(1:1)='S' 896 - ENDIF 897 - IF(INS(I,2).EQ.5.AND.INS(I,3).EQ.-1)THEN 898 - INS(I,3)=INS(I,1) 899 - INS(I,1)=6 900 - INS(I,2)=6 901 - CHANGE=.TRUE. 902 - MODFLG(1:1)='S' 903 - ENDIF 904 - IF(INS(I,2).EQ.5.AND.INS(I,3).EQ.-2)THEN 905 - INS(I,2)=3 906 - INS(I,3)=INS(I,1) 907 - CHANGE=.TRUE. 908 - MODFLG(1:1)='S' 909 - ENDIF 910 - IF(INS(I,2).EQ.16.AND.(INS(I,1).EQ.-4.OR.INS(I,3).EQ.-4))THEN 911 - INS(I,1)=6 912 - INS(I,2)=6 913 - INS(I,3)=-4 914 - CHANGE=.TRUE. 915 - MODFLG(1:1)='S' 916 - ENDIF 917 - IF(INS(I,2).EQ.16.AND.(INS(I,1).EQ.-5.OR.INS(I,3).EQ.-5))THEN 918 - IF(INS(I,3).EQ.-5)INS(I,3)=INS(I,1) 919 - INS(I,1)=6 920 - INS(I,2)=6 921 - CHANGE=.TRUE. 922 - MODFLG(1:1)='S' 923 - ENDIF 924 - IF(INS(I,2).EQ.17.AND.(INS(I,1).EQ.-5.OR.INS(I,3).EQ.-5))THEN 925 - INS(I,1)=6 926 - INS(I,2)=6 927 - INS(I,3)=-5 928 - CHANGE=.TRUE. 929 - MODFLG(1:1)='S' 930 - ENDIF 931 - IF(INS(I,2).EQ.17.AND.(INS(I,1).EQ.-4.OR.INS(I,3).EQ.-4))THEN 932 - IF(INS(I,3).EQ.-4)INS(I,3)=INS(I,1) 933 - INS(I,1)=6 934 - INS(I,2)=6 935 - CHANGE=.TRUE. 936 - MODFLG(1:1)='S' 937 - ENDIF 938 - 320 CONTINUE 939 - * Remove assignments where possible. 940 - IF(.NOT.LOOP)THEN 1 107 P=ALGEBRA D=ALGPRE 10 PAGE 158 941 - DO 330 I1=IINS0,NINS 942 - IF((.NOT.EXEC(I1)).OR.INS(I1,1).NE.6.OR. 943 - - INS(I1,2).NE.6.OR.INS(I1,2).EQ.0)GOTO 330 944 - DO 340 I2=I1+1,NINS 945 - IF(.NOT.EXEC(I2))GOTO 340 946 - IF(INS(I2,4).EQ.INS(I1,4).AND.INS(I2,2).NE.0)GOTO 330 947 - IF(INS(I2,1).EQ.INS(I1,4).AND.INS(I2,2).NE.0.AND. 948 - - INS(I2,2).NE.6.AND.INS(I2,2).NE.8.AND. 949 - - INS(I2,2).NE.9)INS(I2,1)=INS(I1,3) 950 - IF(INS(I2,3).EQ.INS(I1,4).AND.ABS(INS(I2,2)).NE.9) 951 - - INS(I2,3)=INS(I1,3) 952 - EXEC(I1)=.FALSE. 953 - CHANGE=.TRUE. 954 - MODFLG(2:2)='A' 955 - 340 CONTINUE 956 - 330 CONTINUE 957 - ELSE 958 - MODFLG(2:2)='a' 959 - ENDIF 960 - * Evaluate constant expressions, and identify them if possible. 961 - IFAILC=0 962 - DO 350 I=IINS0,NINS 963 - IF((.NOT.EXEC(I)).OR.INS(I,3).GT.0.OR.INS(I,2).EQ.0.OR. 964 - - INS(I,2).EQ.7.OR.INS(I,2).EQ.8.OR.ABS(INS(I,2)).EQ.9.OR. 965 - - (INS(I,1).GT.0.AND.INS(I,2).NE.6).OR. 966 - - (INS(I,1).EQ.6.AND.INS(I,2).EQ.6).OR. 967 - - (INS(I,1).EQ.15.AND.INS(I,2).EQ.6))GOTO 350 968 - IF((INS(I,2).EQ.6.AND.MODREG(INS(I,3)).EQ.0).OR. 969 - - (INS(I,2).NE.6.AND.(MODREG(INS(I,1)).EQ.0.OR. 970 - - MODREG(INS(I,3)).EQ.0)))THEN 971 - CALL ALGEX0(I,IFAILC) 972 - ELSEIF((INS(I,2).EQ.6.AND.MODREG(INS(I,3)).EQ.2).OR. 973 - - (INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.2.AND. 974 - - MODREG(INS(I,3)).EQ.2))THEN 975 - CALL ALGEX2(I,IFAILC) 976 - ELSEIF((INS(I,2).EQ.6.AND.MODREG(INS(I,3)).EQ.3).OR. 977 - - (INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.3.AND. 978 - - MODREG(INS(I,3)).EQ.3))THEN 979 - CALL ALGEX3(I,IFAILC) 980 - ELSEIF((INS(I,2).EQ.6.AND.MODREG(INS(I,3)).EQ.1).OR. 981 - - (INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.1.AND. 982 - - MODREG(INS(I,3)).EQ.1))THEN 983 - CALL ALGEX4(I,IFAILC) 984 - ELSEIF((INS(I,2).EQ.6.AND.MODREG(INS(I,3)).EQ.4).OR. 985 - - (INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.4.OR. 986 - - MODREG(INS(I,3)).EQ.4))THEN 987 - IF(INS(I,2).NE.6.OR.INS(I,1).NE.15)CALL ALGEX5(I,IFAILC) 988 - ELSEIF((INS(I,2).EQ.6.AND.MODREG(INS(I,3)).EQ.5).OR. 989 - - (INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.5.OR. 990 - - MODREG(INS(I,3)).EQ.5))THEN 991 - CALL ALGEX6(I,IFAILC) 992 - ELSE 993 - PRINT *,' ###### ALGPRE ERROR : Unable to evaluate'// 994 - - ' a constant because of mode incompatibility.' 995 - IF(LDEBUG)THEN 996 - WRITE(LUNOUT,'(26X,''Error occured in:'')') 997 - CALL ALGPRT(I,I) 998 - IF(INS(I,2).EQ.6)PRINT 1060,INS(I,3),REG(INS(I,3)) 999 - IF(INS(I,2).NE.6)PRINT 1060,INS(I,1),REG(INS(I,1)), 1000 - - INS(I,3),REG(INS(I,3)) 1001 - ENDIF 1002 - IFAIL=1 1003 - RETURN 1004 - ENDIF 1005 - IF(IFAILC.NE.0)THEN 1006 - CALL ALGERR 1007 - PRINT *,' ###### ALGPRE ERROR : Arithmetic error while'// 1008 - - ' evaluating a constant; expression rejected.' 1009 - IF(LDEBUG)THEN 1010 - WRITE(LUNOUT,'(26X,''Error occured in:'')') 1011 - CALL ALGPRT(I,I) 1012 - IF(INS(I,2).EQ.6)PRINT 1060,INS(I,3),REG(INS(I,3)) 1013 - IF(INS(I,2).NE.6)PRINT 1060,INS(I,1),REG(INS(I,1)), 1014 - - INS(I,3),REG(INS(I,3)) 1015 - ENDIF 1016 - IFAIL=1 1017 - RETURN 1018 - ENDIF 1019 - IFAIL=1 1020 - INS(I,1)=6 1021 - INS(I,2)=6 1022 - DO 351 J=0,NCONS,-1 1023 - IF(J.LT.-5.AND.J.GT.ICONS0)GOTO 351 1024 - IF(ABS(REG(J)-REG(INS(I,4))).LT. 1025 - - EPS*(ABS(REG(J))+ABS(REG(INS(I,4)))).AND. 1026 - - MODREG(J).EQ.MODREG(INS(I,4)))THEN 1027 - INS(I,3)=J 1028 - GOTO 352 1029 - ENDIF 1030 - 351 CONTINUE 1031 - NCONS=NCONS-1 1032 - IF(NCONS.LT.MXCONS)GOTO 3020 1033 - REG(NCONS)=REG(INS(I,4)) 1034 - MODREG(NCONS)=MODREG(INS(I,4)) 1035 - INS(I,3)=NCONS 1036 - 352 CONTINUE 1037 - IF(INS(I,4).LT.0)THEN 1038 - EXEC(I)=.FALSE. 1039 - DO 353 J=I+1,NINS 1040 - IF(INS(J,4).EQ.INS(I,4))GOTO 350 1041 - IF(EXEC(J).AND.INS(J,1).EQ.INS(I,4).AND.INS(J,2).NE.0.AND. 1042 - - INS(J,2).NE.6.AND.INS(J,2).NE.8.AND. 1043 - - INS(J,2).NE.9)INS(J,1)=INS(I,3) 1044 - IF(EXEC(J).AND.INS(J,3).EQ.INS(I,4).AND. 1045 - - ABS(INS(J,2)).NE.9)INS(J,3)=INS(I,3) 1046 - 353 CONTINUE 1 107 P=ALGEBRA D=ALGPRE 11 PAGE 159 1047 - ENDIF 1048 - CHANGE=.TRUE. 1049 - MODFLG(3:3)='C' 1050 - 350 CONTINUE 1051 - C* Rearrange the arguments for +, *, & and |. 1052 - C DO 360 I=IINS0,NINS 1053 - C IF(.NOT.EXEC(I))GOTO 360 1054 - C IF((INS(I,2).EQ.1.OR.INS(I,2).EQ.3.OR.INS(I,2).EQ.16.OR. 1055 - C - INS(I,2).EQ.17).AND.INS(I,1).GT.INS(I,3))THEN 1056 - C IAUX=INS(I,3) 1057 - C INS(I,3)=INS(I,1) 1058 - C INS(I,1)=IAUX 1059 - C CHANGE=.TRUE. 1060 - C MODFLG(4:4)='R' 1061 - C ENDIF 1062 - C360 CONTINUE 1063 - * Identify equal expressions. 1064 - IF(.NOT.LOOP)THEN 1065 - DO 370 I1=IINS0,NINS 1066 - IF((.NOT.EXEC(I1)).OR.INS(I1,2).EQ.0.OR.INS(I1,2).EQ.7.OR. 1067 - - INS(I1,2).EQ.8.OR.ABS(INS(I1,2)).EQ.9)GOTO 370 1068 - DO 380 I2=I1+1,NINS 1069 - IF(EXEC(I2).AND.INS(I2,4).EQ.INS(I1,4))GOTO 370 1070 - IF((.NOT.EXEC(I2)).OR.INS(I2,2).EQ.0.OR.INS(I2,2).EQ.7.OR. 1071 - - INS(I2,2).EQ.8.OR.ABS(INS(I2,2)).EQ.9)GOTO 380 1072 - IF(INS(I1,1).EQ.INS(I2,1).AND.INS(I1,2).EQ.INS(I2,2).AND. 1073 - - INS(I1,3).EQ.INS(I2,3))THEN 1074 - INS(I2,1)=6 1075 - INS(I2,2)=6 1076 - INS(I2,3)=INS(I1,4) 1077 - CHANGE=.TRUE. 1078 - MODFLG(5:5)='E' 1079 - ENDIF 1080 - 380 CONTINUE 1081 - 370 CONTINUE 1082 - * Remove complementary function calls like log(exp(...)). 1083 - DO 390 I1=IINS0,NINS 1084 - IF((.NOT.EXEC(I1)).OR.INS(I1,2).NE.6)GOTO 390 1085 - IF(ABS(INS(I1,1)).EQ.5.OR.INS(I1,1).EQ.6)GOTO 390 1086 - DO 400 I2=I1+1,NINS 1087 - IF(EXEC(I2).AND.INS(I1,4).EQ.INS(I2,4))GOTO 390 1088 - IF((.NOT.EXEC(I2)).OR.INS(I2,2).NE.6.OR. 1089 - - ABS(INS(I2,1)).EQ.5.OR.ABS(INS(I2,1)).EQ.12.OR. 1090 - - INS(I2,1).EQ.6.OR.INS(I2,3).NE.INS(I1,4))GOTO 400 1091 - IF(INS(I1,1).EQ.-INS(I2,1).AND.ABS(INS(I1,1)).EQ.11)THEN 1092 - INS(I2,1)=6 1093 - INS(I2,2)=6 1094 - INS(I2,3)=0 1095 - CHANGE=.TRUE. 1096 - MODFLG(6:6)='F' 1097 - ELSEIF(INS(I1,1).EQ.-INS(I2,1).OR. 1098 - - (INS(I1,1).EQ.-6.AND.INS(I2,1).EQ.-6).OR. 1099 - - (INS(I1,1).EQ.10.AND.INS(I2,1).EQ.10))THEN 1100 - INS(I2,1)=6 1101 - INS(I2,2)=6 1102 - INS(I2,3)=INS(I1,3) 1103 - CHANGE=.TRUE. 1104 - MODFLG(6:6)='F' 1105 - ENDIF 1106 - 400 CONTINUE 1107 - 390 CONTINUE 1108 - * Substitute minus x in the expressions when possible. 1109 - DO 430 I1=IINS0,NINS 1110 - IF(INS(I1,1).NE.-6.OR.INS(I1,2).NE.6)GOTO 430 1111 - DO 440 I2=I1+1,NINS 1112 - IF(INS(I1,4).EQ.INS(I2,4))GOTO 430 1113 - IF(INS(I2,3).EQ.INS(I1,4).AND. 1114 - - (INS(I2,2).EQ.1.OR.INS(I2,2).EQ.2))THEN 1115 - INS(I2,2)=3-INS(I2,2) 1116 - INS(I2,3)=INS(I1,3) 1117 - CHANGE=.TRUE. 1118 - MODFLG(7:7)='M' 1119 - ELSEIF(INS(I2,1).EQ.INS(I1,4).AND.INS(I2,2).EQ.1)THEN 1120 - INS(I2,1)=INS(I2,3) 1121 - INS(I2,2)=2 1122 - INS(I2,3)=INS(I1,3) 1123 - CHANGE=.TRUE. 1124 - MODFLG(7:7)='M' 1125 - ENDIF 1126 - 440 CONTINUE 1127 - 430 CONTINUE 1128 - * Remove complementary operations like x-y -> z, z-x -> w. 1129 - DO 410 I1=IINS0,NINS 1130 - IF(.NOT.EXEC(I1))GOTO 410 1131 - DO 420 I2=I1+1,NINS 1132 - IF(.NOT.EXEC(I2))GOTO 420 1133 - IF(INS(I1,4).EQ.INS(I2,4))GOTO 410 1134 - IF(((INS(I1,2).EQ.1.AND.INS(I2,2).EQ.2).OR. 1135 - - (INS(I1,2).EQ.3.AND.INS(I2,2).EQ.4)).AND. 1136 - - INS(I1,4).EQ.INS(I2,1).AND. 1137 - - (INS(I1,1).EQ.INS(I2,3).OR.INS(I1,3).EQ.INS(I2,3)))THEN 1138 - INS(I2,1)=6 1139 - INS(I2,2)=6 1140 - IF(INS(I1,1).EQ.INS(I2,3))THEN 1141 - INS(I2,3)=INS(I1,3) 1142 - ELSE 1143 - INS(I2,3)=INS(I1,1) 1144 - ENDIF 1145 - CHANGE=.TRUE. 1146 - MODFLG(8:8)='O' 1147 - ENDIF 1148 - IF(((INS(I1,2).EQ.2.AND.INS(I2,2).EQ.1).OR. 1149 - - (INS(I1,2).EQ.4.AND.INS(I2,2).EQ.3)).AND. 1150 - - ((INS(I1,4).EQ.INS(I2,1).AND.INS(I1,3).EQ.INS(I2,3)).OR. 1151 - - (INS(I1,4).EQ.INS(I2,3).AND.INS(I1,3).EQ.INS(I2,1)))) 1152 - - THEN 1 107 P=ALGEBRA D=ALGPRE 12 PAGE 160 1153 - INS(I2,1)=6 1154 - INS(I2,2)=6 1155 - INS(I2,3)=INS(I1,1) 1156 - CHANGE=.TRUE. 1157 - MODFLG(8:8)='O' 1158 - ENDIF 1159 - IF(INS(I1,2).EQ.2.AND.INS(I2,2).EQ.2.AND. 1160 - - INS(I1,1).EQ.INS(I2,3).AND.INS(I1,4).EQ.INS(I2,1))THEN 1161 - INS(I2,1)=-6 1162 - INS(I2,2)=6 1163 - INS(I2,3)=INS(I1,3) 1164 - CHANGE=.TRUE. 1165 - MODFLG(8:8)='O' 1166 - ENDIF 1167 - 420 CONTINUE 1168 - 410 CONTINUE 1169 - ELSE 1170 - MODFLG(5:5)='e' 1171 - MODFLG(6:6)='f' 1172 - MODFLG(7:7)='m' 1173 - MODFLG(8:8)='o' 1174 - ENDIF 1175 - * Mark the instructions whose results are not used as EXEC=F. 1176 - DO 470 I1=NINS,IINS0,-1 1177 - IF(.NOT.EXEC(I1).OR.INS(I1,2).EQ.0.OR.INS(I1,2).EQ.7.OR. 1178 - - INS(I1,2).EQ.8.OR.ABS(INS(I1,2)).EQ.9)GOTO 470 1179 - IF(LOOP)THEN 1180 - ISTART=IINS0 1181 - ELSE 1182 - ISTART=I1+1 1183 - ENDIF 1184 - DO 480 I2=ISTART,NINS 1185 - IF(.NOT.EXEC(I2))GOTO 480 1186 - IF((INS(I2,1).EQ.INS(I1,4).AND.INS(I2,2).NE.0.AND. 1187 - - INS(I2,2).NE.6.AND.INS(I2,2).NE.8.AND.INS(I2,2).NE.9).OR. 1188 - - (INS(I2,3).EQ.INS(I1,4).AND.ABS(INS(I2,2)).NE.9))GOTO 470 1189 - 480 CONTINUE 1190 - CHANGE=.TRUE. 1191 - MODFLG(9:9)='X' 1192 - EXEC(I1)=.FALSE. 1193 - 470 CONTINUE 1194 - * Remove statements marked not to be executed. 1195 - IEXEC=IINS0-1 1196 - DO 490 I=IINS0,NINS 1197 - IF(EXEC(I))THEN 1198 - IEXEC=IEXEC+1 1199 - INS(IEXEC,1)=INS(I,1) 1200 - INS(IEXEC,2)=INS(I,2) 1201 - INS(IEXEC,3)=INS(I,3) 1202 - INS(IEXEC,4)=INS(I,4) 1203 - EXEC(IEXEC)=.TRUE. 1204 - ENDIF 1205 - 490 CONTINUE 1206 - IF(IEXEC.EQ.0)THEN 1207 - PRINT *,' ###### ALGPRE ERROR : No instructions left'// 1208 - - ' (program bug); expression can not be handled.' 1209 - RETURN 1210 - ENDIF 1211 - NINS=IEXEC 1212 - * Check whether any further cycles are needed. 1213 - IF(LDEBUG.AND.CHANGE)THEN 1214 - WRITE(LUNOUT,'(/26X,''Modification flags: '',A9)') MODFLG 1215 - CALL ALGPRT(IINS0,NINS) 1216 - ENDIF 1217 - IF(CHANGE)GOTO 300 1218 - *** Continue here if simplication was skipped. 1219 - 600 CONTINUE 1220 - *** Remove unused registers, first find smallest and largest register. 1221 - MAXREG=0 1222 - MINREG=1 1223 - DO 500 I=IINS0,NINS 1224 - IF(INS(I,2).NE.0.AND.INS(I,2).NE.6.AND.INS(I,2).NE.8.AND. 1225 - - INS(I,2).NE.9)THEN 1226 - MAXREG=MAX(MAXREG,INS(I,1)) 1227 - MINREG=MIN(MINREG,INS(I,1)) 1228 - ENDIF 1229 - IF(ABS(INS(I,2)).NE.9)THEN 1230 - MAXREG=MAX(MAXREG,INS(I,3)) 1231 - MINREG=MIN(MINREG,INS(I,3)) 1232 - ENDIF 1233 - 500 CONTINUE 1234 - * Remove the largest unused registers. 1235 - NREG=NVAR 1236 - DO 510 I1=NVAR+1,MAXREG 1237 - NREG=NREG+1 1238 - CHANGE=.FALSE. 1239 - DO 520 I2=IINS0,NINS 1240 - IF(INS(I2,1).EQ.I1.AND.INS(I2,2).NE.0.AND.INS(I2,2).NE.6.AND. 1241 - - INS(I2,2).NE.8.AND.INS(I2,2).NE.9)THEN 1242 - CHANGE=.TRUE. 1243 - INS(I2,1)=NREG 1244 - ENDIF 1245 - IF(INS(I2,3).EQ.I1.AND.ABS(INS(I2,2)).NE.9)THEN 1246 - CHANGE=.TRUE. 1247 - INS(I2,3)=NREG 1248 - ENDIF 1249 - IF(INS(I2,4).EQ.I1)THEN 1250 - CHANGE=.TRUE. 1251 - INS(I2,4)=NREG 1252 - ENDIF 1253 - 520 CONTINUE 1254 - IF(.NOT.CHANGE)NREG=NREG-1 1255 - 510 CONTINUE 1256 - * Free memory associated with no longer used constants. 1257 - DO 570 I1=ICONS0,MINREG,-1 1258 - USECON=.FALSE. 1 107 P=ALGEBRA D=ALGPRE 13 PAGE 161 1259 - DO 580 I2=IINS0,NINS 1260 - IF((INS(I2,1).EQ.I1.AND.INS(I2,2).NE.0.AND.INS(I2,2).NE.6).OR. 1261 - - INS(I2,3).EQ.I1)USECON=.TRUE. 1262 - 580 CONTINUE 1263 - IF(.NOT.USECON)CALL ALGREU(NINT(REG(I1)),MODREG(I1),0) 1264 - 570 CONTINUE 1265 - * Remove the smallest unused constants. 1266 - NCONS=ICONS0+1 1267 - DO 530 I1=ICONS0,MINREG,-1 1268 - NCONS=NCONS-1 1269 - CHANGE=.FALSE. 1270 - DO 540 I2=IINS0,NINS 1271 - IF(INS(I2,1).EQ.I1.AND.INS(I2,2).NE.0.AND.INS(I2,2).NE.6.AND. 1272 - - INS(I2,2).NE.8.AND.INS(I2,2).NE.9)THEN 1273 - CHANGE=.TRUE. 1274 - REG(NCONS)=REG(INS(I2,1)) 1275 - MODREG(NCONS)=MODREG(INS(I2,1)) 1276 - INS(I2,1)=NCONS 1277 - ENDIF 1278 - IF(INS(I2,3).EQ.I1.AND.ABS(INS(I2,2)).NE.9)THEN 1279 - CHANGE=.TRUE. 1280 - REG(NCONS)=REG(INS(I2,3)) 1281 - MODREG(NCONS)=MODREG(INS(I2,3)) 1282 - INS(I2,3)=NCONS 1283 - ENDIF 1284 - 540 CONTINUE 1285 - IF(.NOT.CHANGE)NCONS=NCONS+1 1286 - 530 CONTINUE 1287 - * Find out which variables are effectively used. 1288 - DO 550 I1=1,NVAR 1289 - USE(I1)=.FALSE. 1290 - DO 560 I2=IINS0,NINS 1291 - IF((INS(I2,1).EQ.I1.AND.INS(I2,2).NE.0.AND.INS(I2,2).NE.6).OR. 1292 - - INS(I2,3).EQ.I1)USE(I1)=.TRUE. 1293 - 560 CONTINUE 1294 - 550 CONTINUE 1295 - *** Update entry point. 1296 - ALGENT(NALGE,3)=1 1297 - IF(LOOP)THEN 1298 - ALGENT(NALGE,4)=0 1299 - ELSE 1300 - ALGENT(NALGE,4)=1 1301 - ENDIF 1302 - ALGENT(NALGE,6)=NINS-IINS0+1 1303 - ALGENT(NALGE,9)=ICONS0-NCONS+1 1304 - ALGENT(NALGE,10)=NRES 1305 - *** Print the final version of the instruction list. 1306 - IF(LDEBUG)THEN 1307 - WRITE(LUNOUT,'(/,26X,''Final instruction list:'')') 1308 - CALL ALGPRT(IINS0,NINS) 1309 - IF(NCONS.LT.ICONS0)THEN 1310 - WRITE(LUNOUT,'(/,26X,''Constants appearing'', 1311 - - '' in the final instruction list:'')') 1312 - DO 700 I=ICONS0,NCONS,-1 1313 - WRITE(LUNOUT,1010) I,REG(I),MODREG(I) 1314 - 700 CONTINUE 1315 - ENDIF 1316 - WRITE(LUNOUT,'(/26X,''Valid variable names:'')') 1317 - DO 710 I=1,NVAR 1318 - IF(USE(I))WRITE(LUNOUT,1040) I,VARLIS(I) 1319 - IF(.NOT.USE(I))WRITE(LUNOUT,1050) I,VARLIS(I) 1320 - 710 CONTINUE 1321 - WRITE(LUNOUT,1030) NINS-IINS0+1,MXINS, 1322 - - NREG,MXREG,ICONS0-NCONS+1,1-MXCONS,NRES 1323 - IF(LDEBUG)WRITE(LUNOUT,'(/26X, 1324 - - ''Entry point '',I4,'' assigned to this list:''/ 1325 - - 26X,''Reference number: '',I4/ 1326 - - 26X,''In use (1) or not (0): '',I4/ 1327 - - 26X,''Correct (1) or not (0): '',I4/ 1328 - - 26X,''Sequential (1) or not (0): '',I4/ 1329 - - 26X,''First instruction at line: '',I4/ 1330 - - 26X,''Number of instructions: '',I4/ 1331 - - 26X,''Number of registers used: '',I4/ 1332 - - 26X,''First local constant at: '',I4/ 1333 - - 26X,''Number of local constants: '',I4/ 1334 - - 26X,''Number of results produced: '',I4/)') 1335 - - NALGE,(ALGENT(NALGE,I),I=1,10) 1336 - WRITE(LUNOUT,'('' ++++++ ALGPRE DEBUG : End of'', 1337 - - '' the debugging output.'')') 1338 - ENDIF 1339 - *** Normal end of this routine. 1340 - IFAIL=0 1341 - RETURN 1342 - *** Handle error conditions due to lack of storage space. 1343 - 3010 CONTINUE 1344 - PRINT *,' ###### ALGPRE ERROR : String resulting from first'// 1345 - - ' translation (see writeup)' 1346 - PRINT *,' is longer than 82 chars;'// 1347 - - ' expression can not be handled.' 1348 - RETURN 1349 - 3020 CONTINUE 1350 - PRINT *,' ###### ALGPRE ERROR : Number of constants used in'// 1351 - - ' the expression is larger than MXCONS;' 1352 - PRINT *,' increase this parameter'// 1353 - - ' and recompile or simplify the expression.' 1354 - RETURN 1355 - 3030 CONTINUE 1356 - PRINT *,' ###### ALGPRE ERROR : Number of registers needed'// 1357 - - ' is larger than MXREG;' 1358 - PRINT *,' increase this parameter'// 1359 - - ' and recompile or simplify the expression.' 1360 - RETURN 1361 - 3040 CONTINUE 1362 - PRINT *,' ###### ALGPRE ERROR : Number of instructions'// 1363 - - ' needed exceeds MXINS;' 1364 - PRINT *,' increase this parameter'// 1 107 P=ALGEBRA D=ALGPRE 14 PAGE 162 1365 - - ' and recompile or simplify the expression.' 1366 - RETURN 1367 - END 108 GARFIELD ================================================== P=ALGEBRA D=ALGPRT 1 ============================ 0 + +DECK,ALGPRT. 1 - SUBROUTINE ALGPRT(ISTART,IEND) 2 - *----------------------------------------------------------------------- 3 - * ALGPRT - Routine printing the instructions produced by ALGPRE in a 4 - * somewhat legible manner. 5 - * (Last changed on 21/ 7/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,ALGDATA. 10.- +SEQ,PRINTPLOT. 11 - CHARACTER*132 AUX 12 - CHARACTER*(MXINCH) OUTPUT 13 - INTEGER ISTART,IEND,NO,NNO,I,J,NCAUX 14 - REAL EPS 15 - *** Identify the routine 16 - IF(LIDENT)PRINT *,' /// ROUTINE ALGPRT ///' 17 - EPS=1.0E-5 18 - *** Loop over the instructions. 19 - DO 10 I=ISTART,IEND 20 - * Write the instruction number to the output string 21 - WRITE(OUTPUT,'(''Ins%'',I4,'':%'')') I 22 - NO=10 23 - * The instruction is a RESULT type statement 24 - IF(INS(I,2).EQ.0)THEN 25 - IF(INS(I,3).GT.0)THEN 26 - WRITE(AUX,'(''Result%'',I4,''%=%R'',I4)') 27 - - INS(I,4),INS(I,3) 28 - OUTPUT(NO+1:NO+19)=AUX(1:19) 29 - NO=NO+19 30 - ELSE 31 - WRITE(AUX,'(''Result%'',I4,''%=%'')') INS(I,4) 32 - OUTPUT(NO+1:NO+14)=AUX(1:14) 33 - NO=NO+14 34 - CALL OUTFMT(REG(INS(I,3)),MODREG(INS(I,3)), 35 - - AUX,NCAUX,'LEFT') 36 - OUTPUT(NO+1:NO+NCAUX)=AUX(1:NCAUX) 37 - NO=NO+NCAUX 38 - ENDIF 39 - * The instruction is a real- or logical-arithmetic expression 40 - ELSEIF((INS(I,2).GE.1.AND.INS(I,2).LE.5).OR. 41 - - (INS(I,2).GE.10.AND.INS(I,2).LE.17))THEN 42 - IF(INS(I,4).GE.0)THEN 43 - WRITE(AUX,'(''R'',I4,''%:=%'')') INS(I,4) 44 - OUTPUT(NO+1:NO+9)=AUX(1:9) 45 - NO=NO+9 46 - ELSE 47 - WRITE(AUX,'(''R('',I4,'')%:=%'')') INS(I,4) 48 - OUTPUT(NO+1:NO+11)=AUX(1:11) 49 - NO=NO+11 50 - ENDIF 51 - IF(INS(I,1).GT.0)THEN 52 - WRITE(AUX,'(''R'',I4,''%'')') INS(I,1) 53 - OUTPUT(NO+1:NO+6)=AUX(1:6) 54 - NO=NO+6 55 - ELSE 56 - CALL OUTFMT(REG(INS(I,1)),MODREG(INS(I,1)), 57 - - AUX,NCAUX,'LEFT') 58 - OUTPUT(NO+1:NO+NCAUX+1)=AUX(1:NCAUX)//'%' 59 - NO=NO+NCAUX+1 60 - ENDIF 61 - IF(INS(I,2).EQ.1) OUTPUT(NO+1:NO+2)='+%' 62 - IF(INS(I,2).EQ.2) OUTPUT(NO+1:NO+2)='-%' 63 - IF(INS(I,2).EQ.3) OUTPUT(NO+1:NO+2)='*%' 64 - IF(INS(I,2).EQ.4) OUTPUT(NO+1:NO+2)='/%' 65 - IF(INS(I,2).EQ.5) OUTPUT(NO+1:NO+3)='**%' 66 - IF(INS(I,2).EQ.10)OUTPUT(NO+1:NO+2)='=%' 67 - IF(INS(I,2).EQ.11)OUTPUT(NO+1:NO+2)='#%' 68 - IF(INS(I,2).EQ.12)OUTPUT(NO+1:NO+2)='<%' 69 - IF(INS(I,2).EQ.13)OUTPUT(NO+1:NO+3)='<=%' 70 - IF(INS(I,2).EQ.14)OUTPUT(NO+1:NO+2)='>%' 71 - IF(INS(I,2).EQ.15)OUTPUT(NO+1:NO+3)='>=%' 72 - IF(INS(I,2).EQ.16)OUTPUT(NO+1:NO+2)='&%' 73 - IF(INS(I,2).EQ.17)OUTPUT(NO+1:NO+2)='|%' 74 - NO=NO+2 75 - IF(INS(I,2).EQ.5.OR.INS(I,2).EQ.13.OR.INS(I,2).EQ.15)NO=NO+1 76 - IF(INS(I,3).GT.0)THEN 77 - WRITE(AUX,'(''R'',I4)') INS(I,3) 78 - OUTPUT(NO+1:NO+5)=AUX(1:5) 79 - NO=NO+5 80 - ELSE 81 - CALL OUTFMT(REG(INS(I,3)),MODREG(INS(I,3)), 82 - - AUX,NCAUX,'LEFT') 83 - OUTPUT(NO+1:NO+NCAUX+1)=AUX(1:NCAUX)//'%' 84 - NO=NO+NCAUX+1 85 - ENDIF 86 - * The instruction is a function 87 - ELSEIF(INS(I,2).EQ.6)THEN 88 - IF(INS(I,4).GE.0)THEN 89 - WRITE(AUX,'(''R'',I4,''%:=%'')') INS(I,4) 90 - OUTPUT(NO+1:NO+9)=AUX(1:9) 91 - NO=NO+9 92 - ELSE 93 - WRITE(AUX,'(''R('',I4,'')%:=%'')') INS(I,4) 94 - OUTPUT(NO+1:NO+11)=AUX(1:11) 95 - NO=NO+11 96 - ENDIF 97 - IF(INS(I,1).EQ.-12)THEN 98 - OUTPUT(NO+1:NO+7)='Number(' 99 - NO=NO+7 1 108 P=ALGEBRA D=ALGPRT 2 PAGE 163 100 - ELSEIF(INS(I,1).EQ.-11)THEN 101 - OUTPUT(NO+1:NO+9)='Trailing(' 102 - NO=NO+9 103 - ELSEIF(INS(I,1).EQ.-9)THEN 104 - OUTPUT(NO+1:NO+8)='arctanh(' 105 - NO=NO+8 106 - ELSEIF(INS(I,1).EQ.-8)THEN 107 - OUTPUT(NO+1:NO+8)='arccosh(' 108 - NO=NO+8 109 - ELSEIF(INS(I,1).EQ.-7)THEN 110 - OUTPUT(NO+1:NO+8)='arcsinh(' 111 - NO=NO+8 112 - ELSEIF(INS(I,1).EQ.-6)THEN 113 - OUTPUT(NO+1:NO+1)='-' 114 - NO=NO+1 115 - ELSEIF(INS(I,1).EQ.-5)THEN 116 - OUTPUT(NO+1:NO+5)='sqrt(' 117 - NO=NO+5 118 - ELSEIF(INS(I,1).EQ.-4)THEN 119 - OUTPUT(NO+1:NO+6)='arctan(' 120 - NO=NO+6 121 - ELSEIF(INS(I,1).EQ.-3)THEN 122 - OUTPUT(NO+1:NO+6)='arccos(' 123 - NO=NO+6 124 - ELSEIF(INS(I,1).EQ.-2)THEN 125 - OUTPUT(NO+1:NO+6)='arcsin(' 126 - NO=NO+6 127 - ELSEIF(INS(I,1).EQ.-1)THEN 128 - OUTPUT(NO+1:NO+4)='log(' 129 - NO=NO+4 130 - ELSEIF(INS(I,1).EQ.+1)THEN 131 - OUTPUT(NO+1:NO+4)='exp(' 132 - NO=NO+4 133 - ELSEIF(INS(I,1).EQ.+2)THEN 134 - OUTPUT(NO+1:NO+4)='sin(' 135 - NO=NO+4 136 - ELSEIF(INS(I,1).EQ.+3)THEN 137 - OUTPUT(NO+1:NO+4)='cos(' 138 - NO=NO+4 139 - ELSEIF(INS(I,1).EQ.+4)THEN 140 - OUTPUT(NO+1:NO+4)='tan(' 141 - NO=NO+4 142 - ELSEIF(INS(I,1).EQ.+5)THEN 143 - OUTPUT(NO+1:NO+1)='|' 144 - NO=NO+1 145 - ELSEIF(INS(I,1).EQ.+6)THEN 146 - OUTPUT(NO+1:NO+1)='+' 147 - NO=NO+1 148 - ELSEIF(INS(I,1).EQ.+7)THEN 149 - OUTPUT(NO+1:NO+5)='sinh(' 150 - NO=NO+5 151 - ELSEIF(INS(I,1).EQ.+8)THEN 152 - OUTPUT(NO+1:NO+5)='cosh(' 153 - NO=NO+5 154 - ELSEIF(INS(I,1).EQ.+9)THEN 155 - OUTPUT(NO+1:NO+5)='tanh(' 156 - NO=NO+5 157 - ELSEIF(INS(I,1).EQ.+10)THEN 158 - OUTPUT(NO+1:NO+4)='not(' 159 - NO=NO+4 160 - ELSEIF(INS(I,1).EQ.+11)THEN 161 - OUTPUT(NO+1:NO+7)='Entier(' 162 - NO=NO+7 163 - ELSEIF(INS(I,1).EQ.+12)THEN 164 - OUTPUT(NO+1:NO+7)='String(' 165 - NO=NO+7 166 - ELSEIF(INS(I,1).EQ.+13)THEN 167 - OUTPUT(NO+1:NO+4)='Sum(' 168 - NO=NO+4 169 - ELSEIF(INS(I,1).EQ.+14)THEN 170 - OUTPUT(NO+1:NO+8)='Product(' 171 - NO=NO+8 172 - ELSEIF(INS(I,1).EQ.+15)THEN 173 - OUTPUT(NO+1:NO+10)='Reference(' 174 - NO=NO+10 175 - ELSEIF(INS(I,1).EQ.+16)THEN 176 - OUTPUT(NO+1:NO+7)='Global(' 177 - NO=NO+7 178 - ELSEIF(INS(I,1).EQ.+17)THEN 179 - OUTPUT(NO+1:NO+5)='Type(' 180 - NO=NO+5 181 - ELSEIF(INS(I,1).EQ.+18)THEN 182 - OUTPUT(NO+1:NO+7)='Landau(' 183 - NO=NO+7 184 - ELSEIF(INS(I,1).EQ.+19)THEN 185 - OUTPUT(NO+1:NO+8)='Minimum(' 186 - NO=NO+8 187 - ELSEIF(INS(I,1).EQ.+20)THEN 188 - OUTPUT(NO+1:NO+8)='Maximum(' 189 - NO=NO+8 190 - ELSEIF(INS(I,1).EQ.+21)THEN 191 - OUTPUT(NO+1:NO+19)='Random_uniform[0,1]' 192 - NO=NO+19 193 - GOTO 30 194 - ELSEIF(INS(I,1).EQ.+22)THEN 195 - OUTPUT(NO+1:NO+20)='Random_Gaussian(0,1)' 196 - NO=NO+20 197 - GOTO 30 198 - ELSEIF(INS(I,1).EQ.+23)THEN 199 - OUTPUT(NO+1:NO+19)='Random_exponential(' 200 - NO=NO+19 201 - ELSEIF(INS(I,1).EQ.+24)THEN 202 - OUTPUT(NO+1:NO+15)='Random_Poisson(' 203 - NO=NO+15 204 - ELSEIF(INS(I,1).EQ.+25)THEN 205 - OUTPUT(NO+1:NO+13)='Random_Landau' 1 108 P=ALGEBRA D=ALGPRT 3 PAGE 164 206 - NO=NO+13 207 - GOTO 30 208 - ELSEIF(INS(I,1).EQ.+26)THEN 209 - OUTPUT(NO+1:NO+13)='Random_Polya(' 210 - NO=NO+13 211 - ELSEIF(INS(I,1).EQ.+27)THEN 212 - OUTPUT(NO+1:NO+15)='Random_function' 213 - NO=NO+15 214 - GOTO 30 215 - ELSEIF(INS(I,1).EQ.+28)THEN 216 - OUTPUT(NO+1:NO+17)='Random_histogram(' 217 - NO=NO+17 218 - ELSEIF(INS(I,1).EQ.+40)THEN 219 - OUTPUT(NO+1:NO+4)='Row(' 220 - NO=NO+4 221 - ELSEIF(INS(I,1).EQ.+41)THEN 222 - OUTPUT(NO+1:NO+5)='Mean(' 223 - NO=NO+5 224 - ELSEIF(INS(I,1).EQ.+42)THEN 225 - OUTPUT(NO+1:NO+4)='RMS(' 226 - NO=NO+4 227 - ELSEIF(INS(I,1).EQ.+51)THEN 228 - OUTPUT(NO+1:NO+17)='String_reference(' 229 - NO=NO+17 230 - ELSEIF(INS(I,1).EQ.+54)THEN 231 - OUTPUT(NO+1:NO+20)='Histogram_reference(' 232 - NO=NO+20 233 - ELSEIF(INS(I,1).EQ.+55)THEN 234 - OUTPUT(NO+1:NO+17)='Matrix_reference(' 235 - NO=NO+17 236 - ELSE 237 - OUTPUT(NO+1:NO+20)='%(' 238 - NO=NO+20 239 - ENDIF 240 - IF(INS(I,3).GT.0)THEN 241 - WRITE(AUX,'(''R'',I4)') INS(I,3) 242 - OUTPUT(NO+1:NO+6)=AUX(1:5) 243 - NO=NO+5 244 - ELSE 245 - CALL OUTFMT(REG(INS(I,3)),MODREG(INS(I,3)), 246 - - AUX,NCAUX,'LEFT') 247 - OUTPUT(NO+1:NO+NCAUX)=AUX(1:NCAUX) 248 - NO=NO+NCAUX 249 - ENDIF 250 - IF(INS(I,1).NE.+5.AND.ABS(INS(I,1)).NE.+6)THEN 251 - OUTPUT(NO+1:NO+1)=')' 252 - NO=NO+1 253 - ELSEIF(INS(I,1).EQ.+5)THEN 254 - OUTPUT(NO+1:NO+1)='|' 255 - NO=NO+1 256 - ENDIF 257 - 30 CONTINUE 258 - * The instruction is an (un)conditional RETURN, EXIT or QUIT. 259 - ELSEIF(INS(I,2).EQ.-9)THEN 260 - IF(INS(I,1).GT.0)THEN 261 - WRITE(AUX,'(''If%R'',I4,''%Then%'')') INS(I,1) 262 - OUTPUT(NO+1:NO+14)=AUX(1:14) 263 - NO=NO+14 264 - ELSEIF(ABS(REG(INS(I,1))).LT.EPS)THEN 265 - OUTPUT(NO+1:NO+6)='Never%' 266 - NO=NO+6 267 - ELSEIF(ABS(REG(INS(I,1))-1.0).LT.EPS)THEN 268 - OUTPUT(NO+1:NO+7)='Always%' 269 - NO=NO+7 270 - ELSE 271 - OUTPUT(NO+1:NO+35)= 272 - - 'If%%Then%' 273 - NO=NO+35 274 - ENDIF 275 - IF(INS(I,3).EQ.0)THEN 276 - OUTPUT(NO+1:NO+6)='Return' 277 - NO=NO+6 278 - ELSEIF(INS(I,3).EQ.1)THEN 279 - OUTPUT(NO+1:NO+4)='Exit' 280 - NO=NO+4 281 - ELSEIF(INS(I,3).EQ.2)THEN 282 - OUTPUT(NO+1:NO+4)='Stop' 283 - NO=NO+4 284 - ELSE 285 - OUTPUT(NO+1:NO+27)='Return%with%invalid%operand' 286 - NO=NO+27 287 - ENDIF 288 - * The instruction is a RETURN by means of a GOTO. 289 - ELSEIF(INS(I,1).EQ.-1.AND.INS(I,2).EQ.7.AND.INS(I,3).EQ.0)THEN 290 - OUTPUT(NO+1:NO+28)='Return%by%out-of-bounds%Goto' 291 - NO=NO+28 292 - * The instruction is an (un)conditional GOTO 293 - ELSEIF(INS(I,2).EQ.7)THEN 294 - IF(INS(I,1).GT.0)THEN 295 - WRITE(AUX,'(''If%R'',I4,''%Then%Goto%Ins%'')') INS(I,1) 296 - OUTPUT(NO+1:NO+23)=AUX(1:23) 297 - NO=NO+23 298 - ELSEIF(ABS(REG(INS(I,1))).LT.EPS)THEN 299 - OUTPUT(NO+1:NO+15)='Never%Goto%Ins%' 300 - NO=NO+15 301 - ELSEIF(ABS(REG(INS(I,1))-1.0).LT.EPS)THEN 302 - OUTPUT(NO+1:NO+16)='Always%Goto%Ins%' 303 - NO=NO+16 304 - ELSE 305 - OUTPUT(NO+1:NO+39)= 306 - - 'If%%Goto%Ins%' 307 - NO=NO+39 308 - ENDIF 309 - IF(INS(I,3).GE.0)THEN 310 - WRITE(AUX,'(''R'',I4)') INS(I,3) 311 - OUTPUT(NO+1:NO+5)=AUX(1:5) 1 108 P=ALGEBRA D=ALGPRT 4 PAGE 165 312 - NO=NO+5 313 - ELSE 314 - WRITE(AUX,'(I4)') NINT(REG(INS(I,3))) 315 - OUTPUT(NO+1:NO+4)=AUX(1:4) 316 - NO=NO+4 317 - ENDIF 318 - * Instruction is an argument building function. 319 - ELSEIF(INS(I,2).EQ.8)THEN 320 - IF(INS(I,3).GT.0)THEN 321 - WRITE(AUX,'(''Arg'',I4,''%:=%R'',I4)') 322 - - INS(I,4),INS(I,3) 323 - OUTPUT(NO+1:NO+16)=AUX(1:16) 324 - NO=NO+16 325 - ELSE 326 - WRITE(AUX,'(''Arg'',I4,''%:=%'')') INS(I,4) 327 - OUTPUT(NO+1:NO+11)=AUX(1:11) 328 - NO=NO+11 329 - CALL OUTFMT(REG(INS(I,3)),MODREG(INS(I,3)), 330 - - AUX,NCAUX,'LEFT') 331 - OUTPUT(NO+1:NO+NCAUX)=AUX(1:NCAUX) 332 - NO=NO+NCAUX 333 - ENDIF 334 - IF(INS(I,1).EQ.0)THEN 335 - OUTPUT(NO+1:NO+21)=',%modifiable,%global.' 336 - NO=NO+21 337 - ELSEIF(INS(I,1).EQ.1)THEN 338 - OUTPUT(NO+1:NO+25)=',%modifiable,%non-global.' 339 - NO=NO+25 340 - ELSEIF(INS(I,1).EQ.2)THEN 341 - OUTPUT(NO+1:NO+25)=',%non-modifiable,%global.' 342 - NO=NO+25 343 - ELSEIF(INS(I,1).EQ.3)THEN 344 - OUTPUT(NO+1:NO+29)=',%non-modifiable,%non-global.' 345 - NO=NO+29 346 - ELSE 347 - OUTPUT(NO+1:NO+28)=',%invalid%modification%flag.' 348 - NO=NO+28 349 - ENDIF 350 - * Instruction is an external function call. 351 - ELSEIF(INS(I,2).EQ.9)THEN 352 - WRITE(AUX,'(''Call%procedure%'',I4,''%with%'',I4, 353 - - ''%arguments.'')') INS(I,1),INS(I,3) 354 - OUTPUT(NO+1:NO+40)=AUX(1:40) 355 - NO=NO+40 356 - * Instruction not identified 357 - ELSE 358 - OUTPUT(NO+1:NO+37)='Unidentified,%unexecutable%statement.' 359 - NO=NO+37 360 - ENDIF 361 - * Remove blanks 362 - NNO=0 363 - DO 20 J=1,NO 364 - IF(OUTPUT(J:J).NE.' ')THEN 365 - NNO=NNO+1 366 - IF(OUTPUT(J:J).EQ.'%')OUTPUT(NNO:NNO)=' ' 367 - IF(OUTPUT(J:J).NE.'%')OUTPUT(NNO:NNO)=OUTPUT(J:J) 368 - ENDIF 369 - 20 CONTINUE 370 - * Add the string '(deleted)' if marked not executable 371 - IF(.NOT.EXEC(I))OUTPUT(56:64)='(deleted)' 372 - * And write the string to the output 373 - WRITE(LUNOUT,'(26X,A)') OUTPUT(1:NNO) 374 - 10 CONTINUE 375 - *** Add a blank line to make the output more legible 376 - WRITE(LUNOUT,'('' '')') 377 - END 109 GARFIELD ================================================== P=ALGEBRA D=ALGREU 1 ============================ 0 + +DECK,ALGREU. 1 - SUBROUTINE ALGREU(IREG,IMOD,IUSAGE) 2 - *----------------------------------------------------------------------- 3 - * ALGREU - Clears storage associated with strings and the like that 4 - * are being reused. 5 - * VARIABLES: IUSAGE : Flag with the same meaning as ARGREF(I,1). 6 - * (Last changed on 20/ 1/00.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,ALGDATA. 11.- +SEQ,GLOBALS. 12.- +SEQ,PRINTPLOT. 13 - INTEGER IUSAGE,NUSEG,NUSEC,IDUM(1),IREG,IMOD,I,IFAIL 14 - *** Identify the routine. 15 - IF(LIDENT)PRINT *,' /// ROUTINE ALGREU ///' 16 - *** Debugging output. 17 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGREU DEBUG : Reuse'', 18 - - '' request for ref='',I5,'', mode='',I2,'' usage='',I2)') 19 - - IREG,IMOD,IUSAGE 20 - *** If not String, Histogram or Matrix, simply return. 21 - IF(IMOD.NE.1.AND.IMOD.NE.4.AND.IMOD.NE.5)THEN 22 - IMOD=0 23 - RETURN 24 - ENDIF 25 - *** Count references from globals. 26 - NUSEG=0 27 - DO 10 I=1,NGLB 28 - IF(GLBMOD(I).EQ.IMOD.AND.NINT(GLBVAL(I)).EQ.IREG)NUSEG=NUSEG+1 29 - 10 CONTINUE 30 - *** Count references from constants in active instruction lists. 31 - NUSEC=0 32 - DO 20 I=-6,NCONS,-1 33 - IF(MODREG(I).EQ.IMOD.AND.NINT(REG(I)).EQ.IREG)NUSEC=NUSEC+1 34 - 20 CONTINUE 35 - *** Delete the String, Histogram or Matrix if not needed anymore. 36 - IF((IUSAGE.EQ.0.AND.NUSEG+NUSEC.LE.1).OR. 1 109 P=ALGEBRA D=ALGREU 2 PAGE 166 37 - - (IUSAGE.EQ.1.AND.NUSEG+NUSEC.LE.0))THEN 38 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGREU DEBUG :'', 39 - - '' Deleting, global ref: '',I5,'' const ref: '',I5)') 40 - - NUSEG,NUSEC 41 - IF(IMOD.EQ.1)THEN 42 - CALL STRBUF('DELETE',IREG,' ',1,IFAIL) 43 - ELSEIF(IMOD.EQ.4)THEN 44 - CALL HISADM('DELETE',IREG,0,0.0,0.0,.FALSE.,IFAIL) 45 - ELSEIF(IMOD.EQ.5)THEN 46 - CALL MATADM('DELETE',IREG,0,IDUM,0,IFAIL) 47 - ENDIF 48 - IMOD=0 49 - ELSEIF(LDEBUG)THEN 50 - WRITE(LUNOUT,'('' ++++++ ALGREU DEBUG : Not'', 51 - - '' deleting, global ref: '',I5,'' const ref: '',I5)') 52 - - NUSEG,NUSEC 53 - ENDIF 54 - END 110 GARFIELD ================================================== P=ALGEBRA D=ALGSTC 1 ============================ 0 + +DECK,ALGSTC. 1 - SUBROUTINE ALGSTC 2 - *----------------------------------------------------------------------- 3 - * ALGSTC - Saves current environment. 4 - * ALGUST - Restores current environment. 5 - * (Last changed on 11/11/99.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,ALGDATA. 10.- +SEQ,PRINTPLOT. 11 - REAL ARGSAV(MXARG),REGSAV(MXCONS:MXREG) 12 - INTEGER MODARS(MXARG),ARGRFS(MXARG,2),MODRGS(MXCONS:MXREG),I 0 13-+ +SELF,IF=SAVE. 14 - SAVE ARGSAV,MODARS,ARGRFS,REGSAV,MODRGS 0 15-+ +SELF. 16 - *** Save the argument block. 17 - DO 10 I=1,MXARG 18 - ARGSAV(I)=ARG(I) 19 - MODARS(I)=MODARG(I) 20 - ARGRFS(I,1)=ARGREF(I,1) 21 - ARGRFS(I,2)=ARGREF(I,2) 22 - 10 CONTINUE 23 - *** Save the registers. 24 - DO 20 I=MXCONS,MXREG 25 - REGSAV(I)=REG(I) 26 - MODRGS(I)=MODREG(I) 27 - 20 CONTINUE 28 - *** End of the saving part. 29 - RETURN 30 - *** Restore. 31 - ENTRY ALGUST 32 - *** Save the argument block. 33 - DO 30 I=1,MXARG 34 - ARG(I)=ARGSAV(I) 35 - MODARG(I)=MODARS(I) 36 - ARGREF(I,1)=ARGRFS(I,1) 37 - ARGREF(I,2)=ARGRFS(I,2) 38 - 30 CONTINUE 39 - *** Save the registers. 40 - DO 40 I=MXCONS,MXREG 41 - REG(I)=REGSAV(I) 42 - MODREG(I)=MODRGS(I) 43 - 40 CONTINUE 44 - END 111 GARFIELD ================================================== P=ALGEBRA D=ALGTYP 1 ============================ 0 + +DECK,ALGTYP. 1 - SUBROUTINE ALGTYP(VARINP,IMODE) 2 - *----------------------------------------------------------------------- 3 - * ALGTYP - Determines the type of the argument string. Return one of 4 - * the following: 0 - Undefined, 1 - String, 2 - Number, 5 - * 3 - Logical, 4 - Histogram or 5 - Matrix. 6 - * (Last changed on 9/11/00.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10 - CHARACTER*(*) VARINP 11 - CHARACTER*(MXINCH) VAR 12 - INTEGER IMODE,I,NC 13 - LOGICAL MANT,POWER,DOT,NUMBER,PASS,END,SIGN 14 - *** Store the length. 15 - NC=LEN(VARINP) 16 - *** Ensure the length is not nill or too large. 17 - IF(NC.LT.1.OR.NC.GT.MXINCH)THEN 18 - PRINT *,' !!!!!! ALGTYP WARNING : Argument string is too'// 19 - - ' long or too short; returning Undefined as type.' 20 - IMODE=0 21 - RETURN 22 - ENDIF 23 - *** Convert to upper case. 24 - VAR=VARINP 25 - CALL CLTOU(VAR) 26 - *** Check for Undefined. 27 - IF(VAR(1:NC).EQ.'NILL')THEN 28 - IMODE=0 29 - *** Check for Logical. 30 - ELSEIF(VAR(1:NC).EQ.'TRUE'.OR.VAR(1:NC).EQ.'FALSE')THEN 31 - IMODE=3 32 - *** Separate numbers and strings. 33 - ELSE 34 - * Preset the state flags. 1 111 P=ALGEBRA D=ALGTYP 2 PAGE 167 35 - MANT=.FALSE. 36 - POWER=.FALSE. 37 - DOT=.FALSE. 38 - END=.FALSE. 39 - NUMBER=.FALSE. 40 - SIGN=.FALSE. 41 - PASS=.TRUE. 42 - END=.FALSE. 43 - * Loop over the string. 44 - DO 10 I=1,NC 45 - * Only leading and trailing blanks. 46 - IF(VAR(I:I).EQ.' ')THEN 47 - IF(MANT.OR.POWER.OR.DOT)END=.TRUE. 48 - * Only only dot and only in the mantissa. 49 - ELSEIF(VAR(I:I).EQ.'.')THEN 50 - IF(END.OR.DOT.OR.POWER)PASS=.FALSE. 51 - DOT=.TRUE. 52 - IF(.NOT.POWER)MANT=.TRUE. 53 - * Only one exponent; switch from mantissa to exponent. 54 - ELSEIF(VAR(I:I).EQ.'E')THEN 55 - IF(END.OR.POWER)PASS=.FALSE. 56 - MANT=.FALSE. 57 - POWER=.TRUE. 58 - NUMBER=.FALSE. 59 - DOT=.FALSE. 60 - SIGN=.FALSE. 61 - * Only one leading sign per mantissa and per exponent. 62 - ELSEIF(INDEX('+-',VAR(I:I)).NE.0)THEN 63 - IF(END.OR.SIGN.OR.NUMBER)PASS=.FALSE. 64 - SIGN=.TRUE. 65 - IF(.NOT.POWER)MANT=.TRUE. 66 - * Numbers anywhere, except after blanks. 67 - ELSEIF(INDEX('0123456789',VAR(I:I)).NE.0)THEN 68 - IF(END)PASS=.FALSE. 69 - NUMBER=.TRUE. 70 - IF(.NOT.POWER)MANT=.TRUE. 71 - * Unknown characters are rejected. 72 - ELSE 73 - PASS=.FALSE. 74 - ENDIF 75 - 10 CONTINUE 76 - * If there is an exponent part, there must be a number. 77 - IF(POWER.AND..NOT.NUMBER)PASS=.FALSE. 78 - * If all tests passed, assign Number, otherwise String. 79 - IF(PASS)THEN 80 - IMODE=2 81 - ELSE 82 - IMODE=1 83 - ENDIF 84 - ENDIF 85 - END 112 GARFIELD ================================================== P=ALGEBRA D=NUMSAV 1 ============================ 0 + +DECK,NUMSAV. 1 - SUBROUTINE NUMSAV(VAL,NAME,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * NUMSAV - Assigns a number to a global variable. 4 - * (Last changed on 24/ 4/96.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GLOBALS. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*(*) NAME 11 - REAL VAL 12 - INTEGER IFAIL,JVAR,I 13 - *** Tracing and debugging output. 14 - IF(LIDENT)PRINT *,' /// ROUTINE NUMSAV ///' 15 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ NUMSAV WARNING : Storing '', 16 - - E15.8,'' as '',A)') VAL,NAME 17 - *** Initial failure flag setting. 18 - IFAIL=1 19 - *** Scan the list of global variables. 20 - JVAR=0 21 - DO 10 I=1,NGLB 22 - IF(GLBVAR(I).EQ.NAME)JVAR=I 23 - 10 CONTINUE 24 - *** If it didn't exist, create a new global ... 25 - IF(JVAR.EQ.0)THEN 26 - * if there still is space, 27 - IF(NGLB.LT.MXVAR)THEN 28 - NGLB=NGLB+1 29 - GLBVAR(NGLB)=NAME 30 - JVAR=NGLB 31 - * otherwise issue a warning. 32 - ELSE 33 - PRINT *,' !!!!!! NUMSAV WARNING : No global variable'// 34 - - ' space left for ',NAME,'; number not saved.' 35 - RETURN 36 - ENDIF 37 - *** Otherwise re-use an existing global. 38 - ELSE 39 - CALL ALGREU(NINT(GLBVAL(JVAR)),GLBMOD(JVAR),0) 40 - ENDIF 41 - *** Assign the number to the global. 42 - GLBVAL(JVAR)=VAL 43 - GLBMOD(JVAR)=2 44 - *** Things seem to have worked. 45 - IFAIL=0 46 - END 1 113 GARFIELD ================================================== P=ALGEBRA D=LOGSAV 1 =================== PAGE 168 0 + +DECK,LOGSAV. 1 - SUBROUTINE LOGSAV(VAL,NAME,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * LOGSAV - Assigns a logical to a global variable. 4 - * (Last changed on 16/ 6/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GLOBALS. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*(*) NAME 11 - LOGICAL VAL 12 - INTEGER IFAIL,JVAR,I 13 - *** Tracing and debugging output. 14 - IF(LIDENT)PRINT *,' /// ROUTINE LOGSAV ///' 15 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ LOGSAV WARNING : Storing '', 16 - - L1,'' as '',A)') VAL,NAME 17 - *** Initial failure flag setting. 18 - IFAIL=1 19 - *** Scan the list of global variables. 20 - JVAR=0 21 - DO 10 I=1,NGLB 22 - IF(GLBVAR(I).EQ.NAME)JVAR=I 23 - 10 CONTINUE 24 - *** If it didn't exist, create a new global ... 25 - IF(JVAR.EQ.0)THEN 26 - * if there still is space, 27 - IF(NGLB.LT.MXVAR)THEN 28 - NGLB=NGLB+1 29 - GLBVAR(NGLB)=NAME 30 - JVAR=NGLB 31 - * otherwise issue a warning. 32 - ELSE 33 - PRINT *,' !!!!!! LOGSAV WARNING : No global variable'// 34 - - ' space left for ',NAME,'; logical not saved.' 35 - RETURN 36 - ENDIF 37 - *** Otherwise re-use an existing global. 38 - ELSE 39 - CALL ALGREU(NINT(GLBVAL(JVAR)),GLBMOD(JVAR),0) 40 - ENDIF 41 - *** Assign the number to the global. 42 - IF(VAL)THEN 43 - GLBVAL(JVAR)=1 44 - ELSE 45 - GLBVAL(JVAR)=0 46 - ENDIF 47 - GLBMOD(JVAR)=3 48 - *** Things seem to have worked. 49 - IFAIL=0 50 - END 114 GARFIELD ================================================== P=GRAPHICS D= 1 ============================ 0 + +PATCH,GRAPHICS. 115 GARFIELD ================================================== P=GRAPHICS D=COLSCL 1 ============================ 0 + +DECK,COLSCL. 1 - REAL FUNCTION COLSCL(COL,FRAC) 2 - *----------------------------------------------------------------------- 3 - * COLSCL - Makes a given colour COL lighter or darker by an amount 4 - * FRAC. FRAC close to 0 is dark, close to 1 is light. 5 - * VARIABLES: EPS1 : Minimum (darkest) colour value returned. 6 - * EPS2 : Maximum (lightest) colour value returned. 7 - * is returned. 8 - * (Last changed on 7/10/98.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,PARAMETERS. 13 - REAL COL,FRAC,EPS1,EPS2,CPEAK,CLOC,A,B,C 14 - PARAMETER(EPS1=0.2,EPS2=0.0) 15 - *** Parabola parameters. 16 - A=(PRFCAL-COL+EPS1-EPS1*PRFCAL-EPS2*PRFCAL)/(PRFCAL-PRFCAL**2) 17 - B=(COL-EPS1-PRFCAL**2+EPS1*PRFCAL**2+EPS2*PRFCAL**2)/ 18 - - (PRFCAL-PRFCAL**2) 19 - C=EPS1 20 - *** Parabolic estimate. 21 - COLSCL=MAX(EPS1,MIN(1-EPS2,A*FRAC**2+B*FRAC+C)) 22 - *** If not a straight conversion, avoid negative sections. 23 - IF(A.NE.0)THEN 24 - CPEAK=C-B**2/(4*A) 25 - IF(CPEAK.LT.EPS1.OR.CPEAK.GT.1-EPS2)THEN 26 - CLOC=-B/(2*A) 27 - IF(CLOC.LE.PRFCAL.AND.FRAC.LE.PRFCAL)THEN 28 - COLSCL=EPS1+FRAC*(MAX(EPS1,MIN(1-EPS2,COLSCL))- 29 - - EPS1)/PRFCAL 30 - ELSEIF(CLOC.GE.PRFCAL.AND.FRAC.GE.PRFCAL)THEN 31 - COLSCL=MAX(EPS1,MIN(1-EPS2,COLSCL))+ 32 - - (FRAC-PRFCAL)*(1-EPS2- 33 - - MAX(EPS1,MIN(1-EPS2,COLSCL)))/(1-PRFCAL) 34 - ENDIF 35 - ENDIF 36 - ENDIF 37 - END 116 GARFIELD ================================================== P=GRAPHICS D=COLSHD 1 ============================ 0 + +DECK,COLSHD. 1 - SUBROUTINE COLSHD(IOFF) 2 - *----------------------------------------------------------------------- 3 - * COLSHD - Generates a set of NPRCOL colours, starting at index IOFF, 4 - * which are gradually lighter versions of the current 5 - * fill area colour. 6 - * (Last changed on 7/10/98.) 1 116 P=GRAPHICS D=COLSHD 2 PAGE 169 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,PARAMETERS. 11.- +SEQ,PRINTPLOT. 12 - INTEGER IOFF,IERR,ICOL,I 13 - REAL RED,GREEN,BLUE,COLSCL,F 14 - EXTERNAL COLSCL 15 - *** Obtain current fill area colour. 16 - CALL GQFACI(IERR,ICOL) 17 - *** Find out what this colour is in RGB. 18 - CALL GRQCR(1,ICOL,1,IERR,RED,GREEN,BLUE) 19 - *** Verify that the number is not zero. 20 - IF(NPRCOL.LE.0)THEN 21 - PRINT *,' !!!!!! COLSHD WARNING : Incorrect number of'// 22 - - ' shades given (program bug, please report).' 23 - RETURN 24 - ENDIF 25 - *** Debugging output. 26 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ COLSHD DEBUG : Creating '', 27 - - I2,'' colours starting at '',I2/ 28 - - 26X,''Calibration point: '',F6.2/ 29 - - 26X,''Scaling range: '',F6.2,'' to '',F6.2/ 30 - - 26X,''Reference:'','' Red '',F6.2,'', Green '',F6.2, 31 - - '', Blue '',F6.2)') NPRCOL,IOFF,PRFCAL,PRFMIN,PRFMAX, 32 - - RED,GREEN,BLUE 33 - *** Generate the colour table. 34 - DO 10 I=1,NPRCOL 35 - F=PRFMIN+(PRFMAX-PRFMIN)*REAL(I-1)/REAL(NPRCOL-1) 36 - CALL GRSCR(1,IOFF+I-1, 37 - - COLSCL(RED,F),COLSCL(GREEN,F),COLSCL(BLUE,F)) 38 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Colour '',I2,'': Red '',F6.2, 39 - - '', Green '',F6.2,'', Blue '',F6.2)') IOFF+I-1, 40 - - COLSCL(RED,F),COLSCL(GREEN,F),COLSCL(BLUE,F) 41 - 10 CONTINUE 42 - END 117 GARFIELD ================================================== P=GRAPHICS D=COLSHM 1 ============================ 0 + +DECK,COLSHM. 1 - SUBROUTINE COLSHM 2 - *----------------------------------------------------------------------- 3 - * COLSHM - Plots a colour map for the shadowing effects. 4 - * (Last changed on 30/11/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9 - REAL XPL(5),YPL(5),XMIN,YMIN,XMAX,YMAX 10 - INTEGER I,J,NC,NTAB 11 - CHARACTER*20 STR 12 - *** Switch to graphics mode. 13 - CALL GRGRAF(.TRUE.) 14 - * Switch to normalised device coordinates. 15 - CALL GSELNT(0) 16 - *** Attributes, start with the solid interior style. 17 - CALL GSFAIS(1) 18 - * Set reasonable character attributes. 19 - CALL GSTXFP(0,2) 20 - CALL GSCHXP(1.0) 21 - CALL GSCHSP(0.0) 22 - CALL GSCHH(0.012) 23 - CALL GSTXAL(2,3) 24 - CALL GSCHUP(0.0,1.0) 25 - CALL GSTXCI(1) 26 - * Set reasonable polyline attributes. 27 - CALL GSPLCI(1) 28 - CALL GSLN(1) 29 - CALL GSLWSC(1.0) 30 - *** Loop over colour tables. 31 - NTAB=9 32 - DO 10 I=1,NTAB 33 - * Make sure this table exists. 34 - IF((I.EQ.1.AND.ICOLBX.LE.0).OR. 35 - - (I.EQ.2.AND.ICOLPL.LE.0).OR. 36 - - (I.EQ.3.AND.ICOLW1.LE.0).OR. 37 - - (I.EQ.4.AND.ICOLW2.LE.0).OR. 38 - - (I.EQ.5.AND.ICOLW3.LE.0).OR. 39 - - (I.EQ.6.AND.ICOLD1.LE.0).OR. 40 - - (I.EQ.7.AND.ICOLD2.LE.0).OR. 41 - - (I.EQ.8.AND.ICOLD3.LE.0).OR. 42 - - (I.EQ.9.AND.ICOLST.LE.0))GOTO 10 43 - * Set the horizontal extent covered by this table. 44 - XMIN=0.05+REAL(I-1)*0.91/REAL(NTAB) 45 - XMAX=0.05+REAL(I )*0.91/REAL(NTAB)-0.01 46 - * Label the tables. 47 - IF(I.EQ.1)THEN 48 - CALL GTX(0.5*(XMIN+XMAX),0.95,'Box') 49 - ELSEIF(I.EQ.2)THEN 50 - CALL GTX(0.5*(XMIN+XMAX),0.95,'Planes') 51 - ELSEIF(I.EQ.3)THEN 52 - CALL GTX(0.5*(XMIN+XMAX),0.95,'Conductor 1') 53 - ELSEIF(I.EQ.4)THEN 54 - CALL GTX(0.5*(XMIN+XMAX),0.95,'Conductor 2') 55 - ELSEIF(I.EQ.5)THEN 56 - CALL GTX(0.5*(XMIN+XMAX),0.95,'Conductor 3') 57 - ELSEIF(I.EQ.6)THEN 58 - CALL GTX(0.5*(XMIN+XMAX),0.95,'Dielectric 1') 59 - ELSEIF(I.EQ.7)THEN 60 - CALL GTX(0.5*(XMIN+XMAX),0.95,'Dielectric 2') 61 - ELSEIF(I.EQ.8)THEN 62 - CALL GTX(0.5*(XMIN+XMAX),0.95,'Dielectric 3') 63 - ELSEIF(I.EQ.9)THEN 64 - CALL GTX(0.5*(XMIN+XMAX),0.95,'Strips') 65 - ELSE 66 - CALL GTX(0.5*(XMIN+XMAX),0.95,'Unknown') 1 117 P=GRAPHICS D=COLSHM 2 PAGE 170 67 - ENDIF 68 - *** Loop over the colours. 69 - DO 20 J=1,NPRCOL 70 - YMIN=0.1+REAL(J-1)*0.8/REAL(NPRCOL) 71 - YMAX=0.1+REAL(J )*0.8/REAL(NPRCOL) 72 - * On first pass, label the colours. 73 - IF(I.EQ.1)THEN 74 - CALL OUTFMT(REAL(J),2,STR,NC,'LEFT') 75 - CALL GTX(0.025,0.5*(YMIN+YMAX),STR(1:NC)) 76 - ENDIF 77 - * Plot a rectangle with the colour. 78 - XPL(1)=XMIN 79 - YPL(1)=YMIN 80 - XPL(2)=XMIN 81 - YPL(2)=YMAX 82 - XPL(3)=XMAX 83 - YPL(3)=YMAX 84 - XPL(4)=XMAX 85 - YPL(4)=YMIN 86 - XPL(5)=XMIN 87 - YPL(5)=YMIN 88 - IF(I.EQ.1)THEN 89 - CALL GSFACI(ICOLBX+J-1) 90 - ELSEIF(I.EQ.2)THEN 91 - CALL GSFACI(ICOLPL+J-1) 92 - ELSEIF(I.EQ.3)THEN 93 - CALL GSFACI(ICOLW1+J-1) 94 - ELSEIF(I.EQ.4)THEN 95 - CALL GSFACI(ICOLW2+J-1) 96 - ELSEIF(I.EQ.5)THEN 97 - CALL GSFACI(ICOLW3+J-1) 98 - ELSEIF(I.EQ.6)THEN 99 - CALL GSFACI(ICOLD1+J-1) 100 - ELSEIF(I.EQ.7)THEN 101 - CALL GSFACI(ICOLD2+J-1) 102 - ELSEIF(I.EQ.8)THEN 103 - CALL GSFACI(ICOLD3+J-1) 104 - ELSEIF(I.EQ.9)THEN 105 - CALL GSFACI(ICOLST+J-1) 106 - ELSE 107 - PRINT *,' !!!!!! COLSHM WARNING : Unknown index.' 108 - CALL GSFACI(0) 109 - ENDIF 110 - CALL GFA(5,XPL,YPL) 111 - * Next shade. 112 - 20 CONTINUE 113 - * Draw an overall box around this table. 114 - XPL(1)=XMIN 115 - YPL(1)=0.1 116 - XPL(2)=XMIN 117 - YPL(2)=0.9 118 - XPL(3)=XMAX 119 - YPL(3)=0.9 120 - XPL(4)=XMAX 121 - YPL(4)=0.1 122 - XPL(5)=XMIN 123 - YPL(5)=0.1 124 - CALL GPL(5,XPL,YPL) 125 - * Next colour table. 126 - 10 CONTINUE 127 - *** Next page. 128 - CALL GRALOG('Colour shading map:') 129 - CALL GRNEXT 130 - *** Keep track of CPU time consumption. 131 - CALL TIMLOG('Producing a colour shading map: ') 132 - END 118 GARFIELD ================================================== P=GRAPHICS D=COLWGT 1 ============================ 0 + +DECK,COLWGT. 1 - SUBROUTINE COLWGT(APLANE,BPLANE,CPLANE,W) 2 - *----------------------------------------------------------------------- 3 - * COLWGT - Computes an illumination index for a plane with parameters 4 - * (APLANE,BPLANE,CPLANE). 5 - * (Last changed on 7/10/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,CONSTANTS. 12 - DOUBLE PRECISION APLANE,BPLANE,CPLANE,AP,BP,CP,W,AV,BV,CV,FNORM, 13 - - WR,WS,PHI,PHIR,PHIS 14 - PARAMETER(PHIR=PI/10,PHIS=PI/3) 15 - *** Compute a normalised viewing vector. 16 - IF(FPROJN.NE.0)THEN 17 - AV=FPROJA/FPROJN 18 - BV=FPROJB/FPROJN 19 - CV=FPROJC/FPROJN 20 - ELSE 21 - AV=0 22 - BV=0 23 - CV=1 24 - PRINT *,' !!!!!! COLWGT WARNING : Zero norm view vector'// 25 - - ' (program bug) ; set to (0,0,1).' 26 - ENDIF 27 - *** Compute a normalised plane vector. 28 - FNORM=SQRT(APLANE**2+BPLANE**2+CPLANE**2) 29 - IF(FNORM.NE.0)THEN 30 - AP=APLANE/FNORM 31 - BP=BPLANE/FNORM 32 - CP=CPLANE/FNORM 33 - ELSE 34 - AP=0 35 - BP=0 36 - CP=1 1 118 P=GRAPHICS D=COLWGT 2 PAGE 171 37 - PRINT *,' !!!!!! COLWGT WARNING : Zero norm plane vector'// 38 - - ' (program bug) ; set to (0,0,1).' 39 - ENDIF 40 - *** Check that the plane is at all visible. 41 - IF(AP*AV+BP*BV+CP*CV.LT.0)THEN 42 - W=-1 43 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ COLWGT DEBUG :'', 44 - - '' Plane '',3F6.2,'' is not visible; W=-1.'')') 45 - - AP,BP,CP 46 - RETURN 47 - ENDIF 48 - *** Reflective component, see whether there is reflection at all. 49 - FNORM=SQRT((AV+PRAL)**2+(BV+PRBL)**2+(CV+PRCL)**2) 50 - IF(FNORM.NE.0)THEN 51 - * Angle between optimal reflection normal and normal of the plane. 52 - PHI=ACOS(((AV+PRAL)*AP+(BV+PRBL)*BP+(CV+PRCL)*CP)/FNORM) 53 - * Weight associated with this angle. 54 - WR=EXP(-0.5*(PHI/PHIR)**2) 55 - * No reflection possible. 56 - ELSE 57 - WR=0 58 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ COLWGT DEBUG :'', 59 - - '' Light and view direction are back to back.'')') 60 - ENDIF 61 - *** Scattered component. 62 - PHI=ACOS(PRAL*AP+PRBL*BP+PRCL*CP) 63 - WS=EXP(-0.5*(PHI/PHIS)**2) 64 - *** Merge the two weights. 65 - W=PRFREF*WR+(1-PRFREF)*(1-PRFABS)*WS 66 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ COLWGT DEBUG : Wrefl='', 67 - - F6.2,'', Wscat='',F6.2,'', W='',F6.2)') WR,WS,W 68 - END 119 GARFIELD ================================================== P=GRAPHICS D=GERHND 1 ============================ 0 + +DECK,GERHND. 1 - SUBROUTINE GERHND(IERR,IFCT,IFIL) 2 - *----------------------------------------------------------------------- 3 - * GERHND - Routine which is supposed to handle error conditions in 4 - * GKS. It outputs an error message to unit 10 and logs. 5 - * (Last changed on 19/ 3/92.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8 - INTEGER IERR,IFCT,IFIL 9 - IF(IERR.GE.1.AND.IERR.LE.8)THEN 10 - WRITE(10,'('' ###### GERHND ERROR : GKS is not in the'', 11 - - '' proper state; please report (No '',I1,'').'')') IERR 12 - ELSEIF(IERR.EQ.21)THEN 13 - WRITE(10,'('' !!!!!! GERHND WARNING : The connection'', 14 - - '' identifier you specified is not valid.'')') 15 - ELSEIF(IERR.EQ.23)THEN 16 - WRITE(10,'('' !!!!!! GERHND WARNING : Workstation type'', 17 - - '' is not known to GKS; try using another.'')') 18 - ELSEIF(IERR.EQ.38)THEN 19 - WRITE(10,'('' !!!!!! GERHND WARNING : Workstation not of'', 20 - - '' type INPUT or OUTIN; please report.'')') 21 - ELSEIF(IERR.EQ.51)THEN 22 - WRITE(10,'('' !!!!!! GERHND WARNING : Rectangle'', 23 - - '' is not valid ; please report.'')') 24 - ELSEIF(IERR.EQ.78)THEN 25 - WRITE(10,'('' ###### GERHND ERROR : Non-positive'', 26 - - '' character height requested ; please report.'')') 27 - ELSEIF(IERR.EQ.92)THEN 28 - WRITE(10,'('' !!!!!! GERHND WARNING : Colour index is'', 29 - - '' less than zero ; program bug - please report.'')') 30 - ELSEIF(IERR.EQ.93)THEN 31 - WRITE(10,'('' !!!!!! GERHND WARNING : Colour index is'', 32 - - '' invalid ; program bug - please report.'')') 33 - ELSEIF(IERR.EQ.94)THEN 34 - WRITE(10,'('' !!!!!! GERHND WARNING : Representation of'', 35 - - '' colour index not defined ; please report.'')') 36 - ELSEIF(IERR.EQ.95)THEN 37 - WRITE(10,'('' ###### GERHND ERROR : Representation of'', 38 - - '' colour index not predefined ; please report.'')') 39 - ELSEIF(IERR.EQ.96)THEN 40 - WRITE(10,'('' !!!!!! GERHND WARNING : Colour intensity'', 41 - - '' RBG invalid ; program bug - please report.'')') 42 - ELSEIF(IERR.EQ.100)THEN 43 - WRITE(10,'('' ###### GERHND ERROR : Invalid number of'', 44 - - '' points in an output primitive; please report.'')') 45 - ELSEIF(IERR.EQ.101)THEN 46 - WRITE(10,'('' !!!!!! GERHND WARNING : Invalid character'', 47 - - '' (perhaps a break) in a string ; please ignore.'')') 48 - ELSEIF(IERR.EQ.120)THEN 49 - WRITE(10,'('' !!!!!! GERHND WARNING : The segment name'', 50 - - '' is not valid (program bug - please report).'')') 51 - ELSEIF(IERR.EQ.121)THEN 52 - WRITE(10,'('' !!!!!! GERHND WARNING : Segment name'', 53 - - '' already in use (program bug - please report).'')') 54 - ELSEIF(IERR.EQ.122)THEN 55 - WRITE(10,'('' !!!!!! GERHND WARNING : The segment does'', 56 - - '' not exist (program bug - please report).'')') 57 - ELSEIF(IERR.EQ.125)THEN 58 - WRITE(10,'('' !!!!!! GERHND WARNING : The segment is'', 59 - - '' still open (program bug - please report).'')') 60 - ELSEIF(IERR.EQ.144)THEN 61 - WRITE(10,'('' !!!!!! GERHND WARNING : The prompt echo'', 62 - - '' type is not supported by the workstation.'')') 63 - ELSEIF(IERR.EQ.147)THEN 64 - WRITE(10,'('' !!!!!! GERHND WARNING : Overflow in the'', 65 - - '' input queue; probably of no importance.'')') 66 - ELSEIF(IERR.EQ.152)THEN 67 - WRITE(10,'('' !!!!!! GERHND WARNING : The initial value'', 68 - - '' is out of range; probably of no importance.'')') 69 - ELSEIF(IERR.EQ.300)THEN 70 - WRITE(10,'('' !!!!!! GERHND WARNING : Unimplemented'', 1 119 P=GRAPHICS D=GERHND 2 PAGE 172 71 - - '' feature used; ignore, normal with mGKS.'')') 72 - ELSE 73 - WRITE(10,'('' !!!!!! GERHND WARNING : GKS error '',I6, 74 - - '' detected; please report.'')') IERR 75 - ENDIF 76 - IF(IFCT.EQ.0)THEN 77 - WRITE(10,'(25X,''Applies to GOPKS (id '',I1,'').'')') IFCT 78 - ELSEIF(IFCT.EQ.1)THEN 79 - WRITE(10,'(25X,''Applies to GCLKS (id '',I1,'').'')') IFCT 80 - ELSEIF(IFCT.EQ.2)THEN 81 - WRITE(10,'(25X,''Applies to GOPWK (id '',I1,'').'')') IFCT 82 - ELSEIF(IFCT.EQ.3)THEN 83 - WRITE(10,'(25X,''Applies to GCLWK (id '',I1,'').'')') IFCT 84 - ELSEIF(IFCT.EQ.4)THEN 85 - WRITE(10,'(25X,''Applies to GACWK (id '',I1,'').'')') IFCT 86 - ELSEIF(IFCT.EQ.5)THEN 87 - WRITE(10,'(25X,''Applies to GDAWK (id '',I1,'').'')') IFCT 88 - ELSEIF(IFCT.EQ.6)THEN 89 - WRITE(10,'(25X,''Applies to GCLRWK (id '',I1,'').'')') IFCT 90 - ELSEIF(IFCT.EQ.8)THEN 91 - WRITE(10,'(25X,''Applies to GUWK (id '',I1,'').'')') IFCT 92 - ELSEIF(IFCT.EQ.12)THEN 93 - WRITE(10,'(25X,''Applies to GPL (id '',I2,'').'')') IFCT 94 - ELSEIF(IFCT.EQ.13)THEN 95 - WRITE(10,'(25X,''Applies to GPM (id '',I2,'').'')') IFCT 96 - ELSEIF(IFCT.EQ.14)THEN 97 - WRITE(10,'(25X,''Applies to GTX (id '',I2,'').'')') IFCT 98 - ELSEIF(IFCT.EQ.15)THEN 99 - WRITE(10,'(25X,''Applies to GFA (id '',I2,'').'')') IFCT 100 - ELSEIF(IFCT.EQ.19)THEN 101 - WRITE(10,'(25X,''Applies to GSLN (id '',I2,'').'')') IFCT 102 - ELSEIF(IFCT.EQ.24)THEN 103 - WRITE(10,'(25X,''Applies to GSMKSC (id '',I2,'').'')') IFCT 104 - ELSEIF(IFCT.EQ.28)THEN 105 - WRITE(10,'(25X,''Applies to GSCHXP (id '',I2,'').'')') IFCT 106 - ELSEIF(IFCT.EQ.29)THEN 107 - WRITE(10,'(25X,''Applies to GSCHSP (id '',I2,'').'')') IFCT 108 - ELSEIF(IFCT.EQ.31)THEN 109 - WRITE(10,'(25X,''Applies to GSCHH (id '',I2,'').'')') IFCT 110 - ELSEIF(IFCT.EQ.33)THEN 111 - WRITE(10,'(25X,''Applies to GSTXP (id '',I2,'').'')') IFCT 112 - ELSEIF(IFCT.EQ.41)THEN 113 - WRITE(10,'(25X,''Applies to GSASF (id '',I2,'').'')') IFCT 114 - ELSEIF(IFCT.EQ.48)THEN 115 - WRITE(10,'(25X,''Applies to GSCR (id '',I2,'').'')') IFCT 116 - ELSEIF(IFCT.EQ.49)THEN 117 - WRITE(10,'(25X,''Applies to GSWN (id '',I2,'').'')') IFCT 118 - ELSEIF(IFCT.EQ.50)THEN 119 - WRITE(10,'(25X,''Applies to GSVP (id '',I2,'').'')') IFCT 120 - ELSEIF(IFCT.EQ.56)THEN 121 - WRITE(10,'(25X,''Applies to GCRSG (id '',I2,'').'')') IFCT 122 - ELSEIF(IFCT.EQ.57)THEN 123 - WRITE(10,'(25X,''Applies to GCLSG (id '',I2,'').'')') IFCT 124 - ELSEIF(IFCT.EQ.59)THEN 125 - WRITE(10,'(25X,''Applies to GDSG (id '',I2,'').'')') IFCT 126 - ELSEIF(IFCT.EQ.69)THEN 127 - WRITE(10,'(25X,''Applies to GINLC (id '',I2,'').'')') IFCT 128 - ELSEIF(IFCT.EQ.70)THEN 129 - WRITE(10,'(25X,''Applies to GINSK (id '',I2,'').'')') IFCT 130 - ELSEIF(IFCT.EQ.71)THEN 131 - WRITE(10,'(25X,''Applies to GINVL (id '',I2,'').'')') IFCT 132 - ELSEIF(IFCT.EQ.72)THEN 133 - WRITE(10,'(25X,''Applies to GINCH (id '',I2,'').'')') IFCT 134 - ELSEIF(IFCT.EQ.73)THEN 135 - WRITE(10,'(25X,''Applies to GINPK (id '',I2,'').'')') IFCT 136 - ELSEIF(IFCT.EQ.74)THEN 137 - WRITE(10,'(25X,''Applies to GINST (id '',I2,'').'')') IFCT 138 - ELSEIF(IFCT.EQ.86)THEN 139 - WRITE(10,'(25X,''Applies to GRQST (id '',I2,'').'')') IFCT 140 - ELSEIF(IFCT.EQ.107)THEN 141 - WRITE(10,'(25X,''Applies to GPREC (id '',I3,'').'')') IFCT 142 - ELSEIF(IFCT.EQ.525)THEN 143 - WRITE(10,'(25X,''Applies to GQCHXP (id '',I3,'').'')') IFCT 144 - ELSE 145 - WRITE(10,'(25X,''Applies to function '',I4,''.'')') IFCT 146 - ENDIF 147 - C CALL GERLOG(IERR,IFCT,IFIL) 148 - END 120 GARFIELD ================================================== P=GRAPHICS D=GRACAL 1 ============================ 0 + +DECK,GRACAL. 1 - SUBROUTINE GRACAL(INSTR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GRACAL - Handles graphics related calls. 4 - * (Last changed on 25/ 3/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,ALGDATA. 10.- +SEQ,GLOBALS. 11.- +SEQ,MATDATA. 12.- +SEQ,CONSTANTS. 13.- +SEQ,GRAPHICS. 14 - CHARACTER*256 XTXT,YTXT,TITLE 15 - REAL XPL(MXARG),YPL(MXARG),SIZE,UPX,UPY, 16 - - CPX,CPY,XBOX(5),YBOX(5),YSHIFT 17 - INTEGER INPCMX,IFAIL,INSTR,IPROC,NARG,IREF(6),ISLOT(6),ISIZ(1), 18 - - IFAIL1,IFAIL2,IFAIL3,NC,ILEN,IFORM,MATSLT,NCXTXT,NCYTXT, 19 - - NCTIT,I,J,IALHOR,IALVER,IUD,ILR,IVERT,IHOR,ICOL,IPREC,IERR, 20 - - IWK 21 - EXTERNAL INPCMX,MATSLT 22 - *** Indentify the routine if requested. 23 - IF(LIDENT)PRINT *,' /// ROUTINE GRACAL ///' 24 - *** Set a workstation for box size inquiries. 1 120 P=GRAPHICS D=GRACAL 2 PAGE 173 25 - IWK=1 26 - *** Assume the CALL will fail. 27 - IFAIL=1 28 - *** Some easy reference variables. 29 - NARG=INS(INSTR,3) 30 - IPROC=INS(INSTR,1) 31 - *** Open a plot frame. 32 - IF(IPROC.EQ.-801)THEN 33 - * Check number of arguments. 34 - IF(NARG.LT.4.OR.NARG.GT.7)THEN 35 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect number'// 36 - - ' of arguments for PLOT_FRAME.' 37 - RETURN 38 - * Check argument mode. 39 - ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 40 - - MODARG(3).NE.2.OR.MODARG(4).NE.2.OR. 41 - - (NARG.GE.5.AND.MODARG(5).NE.1).OR. 42 - - (NARG.GE.6.AND.MODARG(6).NE.1).OR. 43 - - (NARG.GE.7.AND.MODARG(7).NE.1))THEN 44 - PRINT *,' !!!!!! GRACAL WARNING : Some arguments of'// 45 - - ' PLOT_FRAME are of incorrect type.' 46 - RETURN 47 - ENDIF 48 - * Carry out the calculation. 49 - IF(NARG.GE.5)THEN 50 - CALL STRBUF('READ',NINT(ARG(5)),XTXT,NCXTXT,IFAIL1) 51 - IF(NCXTXT.LT.1)THEN 52 - XTXT=' ' 53 - NCXTXT=1 54 - ENDIF 55 - ELSE 56 - XTXT='x' 57 - NCXTXT=1 58 - IFAIL1=0 59 - ENDIF 60 - IF(NARG.GE.6)THEN 61 - CALL STRBUF('READ',NINT(ARG(6)),YTXT,NCYTXT,IFAIL2) 62 - IF(NCYTXT.LT.1)THEN 63 - YTXT=' ' 64 - NCYTXT=1 65 - ENDIF 66 - ELSE 67 - YTXT='y' 68 - NCYTXT=1 69 - IFAIL2=0 70 - ENDIF 71 - IF(NARG.GE.7)THEN 72 - CALL STRBUF('READ',NINT(ARG(7)),TITLE,NCTIT,IFAIL3) 73 - IF(NCTIT.LT.1)THEN 74 - TITLE=' ' 75 - NCTIT=1 76 - ENDIF 77 - ELSE 78 - TITLE=' ' 79 - NCTIT=1 80 - IFAIL3=0 81 - ENDIF 82 - CALL GRCART(ARG(1),ARG(2),ARG(3),ARG(4), 83 - - XTXT(1:NCXTXT),YTXT(1:NCYTXT),TITLE(1:NCTIT)) 84 - * Switch back to normal screen. 85 - CALL GRALPH 86 - * Error processing. 87 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0) 88 - - PRINT *,' !!!!!! GRACAL WARNING : Error'// 89 - - ' retrieving a string for PLOT_FRAME.' 90 - *** Close a plot frame. 91 - ELSEIF(IPROC.EQ.-802)THEN 92 - * Check number of arguments. 93 - IF(NARG.GT.1)THEN 94 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect number'// 95 - - ' of arguments for PLOT_END.' 96 - RETURN 97 - ENDIF 98 - * If the last argument is present, fetch it (log record). 99 - IF(NARG.GE.1)THEN 100 - CALL STRBUF('READ',NINT(ARG(1)),TITLE,NCTIT,IFAIL1) 101 - ELSE 102 - TITLE='< User plot >' 103 - NCTIT=13 104 - ENDIF 105 - * Log the plot. 106 - IF(NCTIT.GE.1)CALL GRALOG(TITLE(1:NCTIT)) 107 - * Switch to graphics. 108 - CALL GRGRAF(.FALSE.) 109 - * Close graphics. 110 - CALL GRNEXT 111 - *** Plot a marker. 112 - ELSEIF(IPROC.EQ.-803)THEN 113 - * Check number of arguments. 114 - IF(NARG.EQ.1.OR. 115 - - (NARG.NE.2*(NARG/2).AND.MODARG(NARG).NE.1))THEN 116 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// 117 - - ' arguments for PLOT_MARKERS.' 118 - RETURN 119 - ENDIF 120 - * Check argument mode. 121 - IF(MODARG(1).NE.5)THEN 122 - DO 45 I=1,2*(NARG/2) 123 - IF(MODARG(I).NE.2)THEN 124 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect'// 125 - - ' argument type in PLOT_MARKERS call.' 126 - RETURN 127 - ENDIF 128 - 45 CONTINUE 129 - ELSEIF(MODARG(2).NE.5)THEN 130 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect'// 1 120 P=GRAPHICS D=GRACAL 3 PAGE 174 131 - - ' argument type in PLOT_MARKERS call.' 132 - RETURN 133 - ENDIF 134 - * Switch to graphics screen. 135 - CALL GRGRAF(.FALSE.) 136 - * If there is a 3rd argument, set the polymarker type. 137 - IF(NARG.NE.2*(NARG/2))THEN 138 - CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NCTIT,IFAIL1) 139 - IF(NCTIT.GE.1)THEN 140 - CALL CLTOU(TITLE(1:NCTIT)) 141 - CALL GRATTS(TITLE(1:NCTIT),'POLYMARKER') 142 - ENDIF 143 - ELSE 144 - CALL GRATTS('CIRCLE','POLYMARKER') 145 - IFAIL1=0 146 - ENDIF 147 - * Plot the markers. 148 - IF(MODARG(1).NE.5)THEN 149 - DO 55 I=1,NARG/2 150 - XPL(I)=ARG(2*I-1) 151 - YPL(I)=ARG(2*I) 152 - 55 CONTINUE 153 - CALL GRMARK(NARG/2,XPL,YPL) 154 - ELSE 155 - CALL MATMRK(NINT(ARG(1)),NINT(ARG(2)),' ') 156 - ENDIF 157 - * Switch back to alphanumeric screen. 158 - CALL GRALPH 159 - * Error processing. 160 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! GRACAL WARNING : Error'// 161 - - ' retrieving a string for PLOT_MARKERS.' 162 - *** Plot a polyline. 163 - ELSEIF(IPROC.EQ.-804)THEN 164 - * Check number of arguments. 165 - IF(NARG.EQ.1.OR. 166 - - (NARG.LE.3.AND.(MODARG(1).NE.5.OR.MODARG(2).NE.5)).OR. 167 - - (NARG.NE.2*(NARG/2).AND.MODARG(NARG).NE.1))THEN 168 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// 169 - - ' arguments for PLOT_LINE.' 170 - RETURN 171 - ENDIF 172 - * Check argument mode. 173 - IF(NARG.GE.4)THEN 174 - DO 40 I=1,2*(NARG/2) 175 - IF(MODARG(I).NE.2)THEN 176 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect'// 177 - - ' argument type in PLOT_LINE call.' 178 - RETURN 179 - ENDIF 180 - 40 CONTINUE 181 - ENDIF 182 - * Switch to graphics screen. 183 - CALL GRGRAF(.FALSE.) 184 - * If there is a 3rd argument, set the polyline type. 185 - IF(NARG.NE.2*(NARG/2))THEN 186 - CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NCTIT,IFAIL1) 187 - IF(NCTIT.LT.1)THEN 188 - TITLE=' ' 189 - NCTIT=1 190 - ENDIF 191 - CALL CLTOU(TITLE(1:NCTIT)) 192 - ELSE 193 - TITLE='SOLID' 194 - NCTIT=5 195 - IFAIL1=0 196 - ENDIF 197 - IF(INDEX(TITLE(1:NCTIT),'SOLID').NE.0)THEN 198 - CALL GRATTS('SOLID','POLYLINE') 199 - ELSEIF(INDEX(TITLE(1:NCTIT),'COMMENT').NE.0)THEN 200 - CALL GRATTS('COMMENT','POLYLINE') 201 - ELSEIF(INDEX(TITLE(1:NCTIT),'DASHED').NE.0)THEN 202 - CALL GRATTS('DASHED','POLYLINE') 203 - ELSEIF(INDEX(TITLE(1:NCTIT),'DOTTED').NE.0)THEN 204 - CALL GRATTS('DOTTED','POLYLINE') 205 - ELSEIF(INDEX(TITLE(1:NCTIT),'DASH-DOTTED').NE.0)THEN 206 - CALL GRATTS('DASH-DOTTED','POLYLINE') 207 - ELSEIF(INDEX(TITLE(1:NCTIT),'FUNCTION-1').NE.0)THEN 208 - CALL GRATTS('FUNCTION-1','POLYLINE') 209 - ELSEIF(INDEX(TITLE(1:NCTIT),'FUNCTION-2').NE.0)THEN 210 - CALL GRATTS('FUNCTION-2','POLYLINE') 211 - ELSEIF(INDEX(TITLE(1:NCTIT),'FUNCTION-3').NE.0)THEN 212 - CALL GRATTS('FUNCTION-3','POLYLINE') 213 - ELSEIF(INDEX(TITLE(1:NCTIT),'FUNCTION-4').NE.0)THEN 214 - CALL GRATTS('FUNCTION-4','POLYLINE') 215 - ELSEIF(INDEX(TITLE(1:NCTIT),'FUNCTION-5').NE.0)THEN 216 - CALL GRATTS('FUNCTION-5','POLYLINE') 217 - ELSEIF(INDEX(TITLE(1:NCTIT),'FUNCTION-6').NE.0)THEN 218 - CALL GRATTS('FUNCTION-6','POLYLINE') 219 - ELSEIF(INDEX(TITLE(1:NCTIT),'FUNCTION-7').NE.0)THEN 220 - CALL GRATTS('FUNCTION-7','POLYLINE') 221 - ELSE 222 - CALL GRATTS('SOLID','POLYLINE') 223 - ENDIF 224 - * Plot the line segment. 225 - IF(NARG.GE.4)THEN 226 - DO 50 I=1,NARG/2 227 - XPL(I)=ARG(2*I-1) 228 - YPL(I)=ARG(2*I) 229 - 50 CONTINUE 230 - IF(INDEX(TITLE(1:NCTIT),'SMOOTH').NE.0.AND. 231 - - INDEX(TITLE(1:NCTIT),'NOSMOOTH').EQ.0)THEN 232 - CALL GRSPLN(NARG/2,XPL,YPL) 233 - ELSE 234 - CALL GRLINE(NARG/2,XPL,YPL) 235 - ENDIF 236 - ELSE 1 120 P=GRAPHICS D=GRACAL 4 PAGE 175 237 - IF(INDEX(TITLE(1:NCTIT),'SMOOTH').NE.0.AND. 238 - - INDEX(TITLE(1:NCTIT),'NOSMOOTH').EQ.0)THEN 239 - CALL MATLIN(NINT(ARG(1)),NINT(ARG(2)),'SMOOTH') 240 - ELSE 241 - CALL MATLIN(NINT(ARG(1)),NINT(ARG(2)),' ') 242 - ENDIF 243 - ENDIF 244 - * Switch back to alphanumeric screen. 245 - CALL GRALPH 246 - * Error processing. 247 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! GRACAL WARNING : Error'// 248 - - ' retrieving a string for PLOT_LINE.' 249 - *** Plot a string. 250 - ELSEIF(IPROC.EQ.-805)THEN 251 - * Check number of arguments. 252 - IF(NARG.LT.3.OR.NARG.GT.6)THEN 253 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect number'// 254 - - ' of arguments for PLOT_TEXT.' 255 - RETURN 256 - * Check argument mode. 257 - ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 258 - - MODARG(3).NE.1.OR. 259 - - (NARG.GE.4.AND.MODARG(4).NE.1).OR. 260 - - (NARG.GE.5.AND.MODARG(5).NE.1).OR. 261 - - (NARG.GE.6.AND.MODARG(6).NE.2))THEN 262 - PRINT *,' !!!!!! GRACAL WARNING : Some arguments of'// 263 - - ' PLOT_TEXT are of incorrect type.' 264 - RETURN 265 - ENDIF 266 - * Switch to graphics screen. 267 - CALL GRGRAF(.FALSE.) 268 - * If there is a 4th argument, set the text type. 269 - IF(NARG.GE.4)THEN 270 - CALL STRBUF('READ',NINT(ARG(4)),TITLE,NCTIT,IFAIL1) 271 - IF(NCTIT.GE.1)THEN 272 - CALL CLTOU(TITLE(1:NCTIT)) 273 - CALL GRATTS(TITLE(1:NCTIT),'TEXT') 274 - ENDIF 275 - ELSE 276 - CALL GRATTS('COMMENT','TEXT') 277 - IFAIL1=0 278 - ENDIF 279 - * If there is a 5th argument, set the text alignment. 280 - IF(NARG.GE.5)THEN 281 - CALL STRBUF('READ',NINT(ARG(5)),TITLE,NCTIT,IFAIL2) 282 - IF(NCTIT.LT.1)THEN 283 - TITLE=' ' 284 - NCTIT=1 285 - ENDIF 286 - CALL CLTOU(TITLE(1:NCTIT)) 287 - IF(INDEX(TITLE(1:NCTIT),'LEFT').NE.0)THEN 288 - IALHOR=1 289 - ELSEIF(INDEX(TITLE(1:NCTIT),'CENTER')+ 290 - - INDEX(TITLE(1:NCTIT),'CENTRE').NE.0)THEN 291 - IALHOR=2 292 - ELSEIF(INDEX(TITLE(1:NCTIT),'RIGHT').NE.0)THEN 293 - IALHOR=3 294 - ELSEIF(INDEX(TITLE(1:NCTIT),'NORMAL').NE.0)THEN 295 - IALHOR=0 296 - ELSE 297 - IALHOR=0 298 - ENDIF 299 - IF(INDEX(TITLE(1:NCTIT),'TOP').NE.0)THEN 300 - IALVER=1 301 - ELSEIF(INDEX(TITLE(1:NCTIT),'CAP').NE.0)THEN 302 - IALVER=2 303 - ELSEIF(INDEX(TITLE(1:NCTIT),'HALF').NE.0)THEN 304 - IALVER=3 305 - ELSEIF(INDEX(TITLE(1:NCTIT),'BASE').NE.0)THEN 306 - IALVER=4 307 - ELSEIF(INDEX(TITLE(1:NCTIT),'BOTTOM').NE.0)THEN 308 - IALVER=5 309 - ELSEIF(INDEX(TITLE(1:NCTIT),'NORMAL').NE.0)THEN 310 - IALVER=0 311 - ELSE 312 - IALVER=0 313 - ENDIF 314 - CALL GSTXAL(IALHOR,IALVER) 315 - ELSE 316 - CALL GSTXAL(0,0) 317 - IFAIL2=0 318 - ENDIF 319 - * If there is a 6th argument, set the text orientation. 320 - IF(NARG.GE.5)THEN 321 - UPX=COS(PI*(ARG(6)+90.0)/180.0) 322 - UPY=SIN(PI*(ARG(6)+90.0)/180.0) 323 - CALL GSCHUP(UPX,UPY) 324 - ELSE 325 - CALL GSCHUP(0.0,1.0) 326 - ENDIF 327 - * Plot the string. 328 - CALL STRBUF('READ',NINT(ARG(3)),TITLE,NCTIT,IFAIL3) 329 - IF(NCTIT.GE.1)CALL GRTEXT(ARG(1),ARG(2),TITLE(1:NCTIT)) 330 - * Switch back to alphanumeric screen. 331 - CALL GRALPH 332 - * Error processing. 333 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0) 334 - - PRINT *,' !!!!!! GRACAL WARNING : Error'// 335 - - ' retrieving a string for PLOT_TEXT.' 336 - *** Plot a comment string. 337 - ELSEIF(IPROC.EQ.-806)THEN 338 - * Check number of arguments and argument type. 339 - IF(NARG.NE.2.OR.MODARG(1).NE.1.OR.MODARG(2).NE.1)THEN 340 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// 341 - - ' arguments for PLOT_COMMENT.' 342 - RETURN 1 120 P=GRAPHICS D=GRACAL 5 PAGE 176 343 - ENDIF 344 - * Figure out where the comment should be placed. 345 - CALL STRBUF('READ',NINT(ARG(1)),TITLE,NCTIT,IFAIL1) 346 - IF(NCTIT.LT.1)THEN 347 - TITLE=' ' 348 - NCTIT=1 349 - ENDIF 350 - CALL CLTOU(TITLE(1:NCTIT)) 351 - IF(INDEX(TITLE(1:NCTIT),'UP')+ 352 - - INDEX(TITLE(1:NCTIT),'HIGH').NE.0)THEN 353 - IUD=1 354 - ELSEIF(INDEX(TITLE(1:NCTIT),'DOWN')+ 355 - - INDEX(TITLE(1:NCTIT),'LOW').NE.0)THEN 356 - IUD=2 357 - ELSE 358 - PRINT *,' !!!!!! GRACAL WARNING : Up/down'// 359 - - ' location missing; comment not plotted.' 360 - RETURN 361 - ENDIF 362 - IF(INDEX(TITLE(1:NCTIT),'LEFT').NE.0)THEN 363 - ILR=0 364 - ELSEIF(INDEX(TITLE(1:NCTIT),'RIGHT').NE.0)THEN 365 - ILR=2 366 - ELSE 367 - PRINT *,' !!!!!! GRACAL WARNING : Left/right'// 368 - - ' location missing; comment not plotted.' 369 - RETURN 370 - ENDIF 371 - * Fetch the string to be plotted. 372 - CALL STRBUF('READ',NINT(ARG(2)),TITLE,NCTIT,IFAIL2) 373 - * Switch to graphics screen. 374 - CALL GRGRAF(.FALSE.) 375 - * Plot the comment. 376 - IF(NCTIT.GE.1)CALL GRCOMM(IUD+ILR,TITLE(1:NCTIT)) 377 - * Switch back to alphanumeric screen. 378 - CALL GRALPH 379 - * Error processing. 380 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0) 381 - - PRINT *,' !!!!!! GRACAL WARNING : Error'// 382 - - ' retrieving a string for PLOT_COMMENT.' 383 - *** Plot a fill area. 384 - ELSEIF(IPROC.EQ.-807)THEN 385 - * Check number of arguments. 386 - IF(NARG.LT.6.OR. 387 - - (NARG.NE.2*(NARG/2).AND.MODARG(NARG).NE.1))THEN 388 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// 389 - - ' arguments for PLOT_AREA.' 390 - RETURN 391 - ENDIF 392 - * Check argument mode. 393 - DO 60 I=1,2*(NARG/2) 394 - IF(MODARG(I).NE.2)THEN 395 - PRINT *,' !!!!!! GRACAL WARNING : Some arguments of'// 396 - - ' PLOT_AREA are of incorrect type.' 397 - RETURN 398 - ENDIF 399 - 60 CONTINUE 400 - * Switch to graphics screen. 401 - CALL GRGRAF(.FALSE.) 402 - * If there is a 3rd argument, set the polyline type. 403 - IF(NARG.NE.2*(NARG/2))THEN 404 - CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NCTIT,IFAIL1) 405 - IF(NCTIT.GE.1)THEN 406 - CALL CLTOU(TITLE(1:NCTIT)) 407 - CALL GRATTS(TITLE(1:NCTIT),'AREA') 408 - ENDIF 409 - ELSE 410 - IFAIL1=0 411 - ENDIF 412 - * Plot the line segment. 413 - DO 70 I=1,NARG/2 414 - XPL(I)=ARG(2*I-1) 415 - YPL(I)=ARG(2*I) 416 - 70 CONTINUE 417 - CALL GRAREA(NARG/2,XPL,YPL) 418 - * Switch back to alphanumeric screen. 419 - CALL GRALPH 420 - * Error processing. 421 - IF(IFAIL1.NE.0) 422 - - PRINT *,' !!!!!! GRACAL WARNING : Error'// 423 - - ' retrieving a string for PLOT_AREA.' 424 - *** Plot a graph. 425 - ELSEIF(IPROC.EQ.-808)THEN 426 - * Check number of arguments. 427 - IF(NARG.LT.2.OR.NARG.GT.5)THEN 428 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect number'// 429 - - ' of arguments for PLOT_GRAPH.' 430 - RETURN 431 - * Check argument mode. 432 - ELSEIF(MODARG(1).NE.5.OR.MODARG(2).NE.5.OR. 433 - - (NARG.GE.3.AND.MODARG(3).NE.1).OR. 434 - - (NARG.GE.4.AND.MODARG(4).NE.1).OR. 435 - - (NARG.GE.5.AND.MODARG(5).NE.1))THEN 436 - PRINT *,' !!!!!! GRACAL WARNING : Some arguments of'// 437 - - ' PLOT_GRAPH are of incorrect type.' 438 - RETURN 439 - ENDIF 440 - * Fetch the x-axis label. 441 - IF(NARG.GE.3)THEN 442 - CALL STRBUF('READ',NINT(ARG(3)),XTXT,NCXTXT,IFAIL1) 443 - IF(NCXTXT.LT.1)THEN 444 - XTXT=' ' 445 - NCXTXT=1 446 - ENDIF 447 - ELSE 448 - DO 71 J=1,NGLB 1 120 P=GRAPHICS D=GRACAL 6 PAGE 177 449 - IF(GLBMOD(J).NE.5)GOTO 71 450 - IF(NINT(GLBVAL(J)).EQ.NINT(ARG(1)))THEN 451 - XTXT=GLBVAR(J) 452 - NCXTXT=10 453 - GOTO 72 454 - ENDIF 455 - 71 CONTINUE 456 - XTXT='x-axis' 457 - NCXTXT=6 458 - 72 CONTINUE 459 - IFAIL1=0 460 - ENDIF 461 - * Fetch the y-axis label. 462 - IF(NARG.GE.4)THEN 463 - CALL STRBUF('READ',NINT(ARG(4)),YTXT,NCYTXT,IFAIL2) 464 - IF(NCYTXT.LT.1)THEN 465 - YTXT=' ' 466 - NCYTXT=1 467 - ENDIF 468 - ELSE 469 - DO 73 J=1,NGLB 470 - IF(GLBMOD(J).NE.5)GOTO 73 471 - IF(NINT(GLBVAL(J)).EQ.NINT(ARG(2)))THEN 472 - YTXT=GLBVAR(J) 473 - NCYTXT=10 474 - GOTO 74 475 - ENDIF 476 - 73 CONTINUE 477 - YTXT='y-axis' 478 - NCYTXT=6 479 - 74 CONTINUE 480 - IFAIL2=0 481 - ENDIF 482 - * Fetch the global title. 483 - IF(NARG.GE.5)THEN 484 - CALL STRBUF('READ',NINT(ARG(5)),TITLE,NCTIT,IFAIL3) 485 - IF(NCTIT.LT.1)THEN 486 - TITLE=' ' 487 - NCTIT=1 488 - ENDIF 489 - ELSE 490 - TITLE=' ' 491 - NCTIT=1 492 - IFAIL3=0 493 - ENDIF 494 - * Plot the graph. 495 - CALL MATGRA(NINT(ARG(1)),NINT(ARG(2)), 496 - - XTXT(1:NCXTXT),YTXT(1:NCYTXT),TITLE(1:NCTIT)) 497 - * Switch back to normal screen. 498 - CALL GRALPH 499 - * Error processing. 500 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0) 501 - - PRINT *,' !!!!!! GRACAL WARNING : Error'// 502 - - ' retrieving a string for PLOT_GRAPH.' 503 - *** Plotting error bars. 504 - ELSEIF(IPROC.EQ.-809)THEN 505 - * Identify provisionally the chosen format. 506 - IF(NARG.GE.7.OR.(NARG.EQ.6.AND.MODARG(5).NE.1))THEN 507 - IFORM=3 508 - ELSEIF(NARG.GE.5.OR.(NARG.EQ.4.AND.MODARG(3).NE.1))THEN 509 - IFORM=2 510 - ELSEIF(NARG.GE.2)THEN 511 - IFORM=1 512 - ELSE 513 - PRINT *,' !!!!!! GRACAL WARNING : Not a recognised'// 514 - - ' format of PLOT_ERROR_BARS; no error bars.' 515 - RETURN 516 - ENDIF 517 - * Verify the types for each format. 518 - IF((MODARG(1).NE.2.AND.MODARG(1).NE.5).OR. 519 - - (MODARG(2).NE.2.AND.MODARG(2).NE.5))THEN 520 - PRINT *,' !!!!!! GRACAL WARNING : PLOT_ERROR_BARS'// 521 - - ' needs at least an (x,y) pair; no error bars.' 522 - RETURN 523 - ELSEIF(IFORM.EQ.1.AND.( 524 - - NARG.GT.4.OR. 525 - - (NARG.GE.3.AND.MODARG(3).NE.1).OR. 526 - - (NARG.GE.4.AND.MODARG(4).NE.2)))THEN 527 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect option'// 528 - - ' list for PLOT_ERROR_BARS; no error bars.' 529 - RETURN 530 - ELSEIF(IFORM.GT.1.AND.( 531 - - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. 532 - - (MODARG(4).NE.2.AND.MODARG(4).NE.5)))THEN 533 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// 534 - - ' (ex-,ey-) in PLOT_ERROR_BARS; no error bars.' 535 - RETURN 536 - ELSEIF(IFORM.EQ.2.AND.( 537 - - NARG.GT.6.OR. 538 - - (NARG.GE.5.AND.MODARG(5).NE.1).OR. 539 - - (NARG.GE.6.AND.MODARG(6).NE.2)))THEN 540 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect option'// 541 - - ' list for PLOT_ERROR_BARS; no error bars.' 542 - RETURN 543 - ELSEIF(IFORM.GT.2.AND.( 544 - - (MODARG(5).NE.2.AND.MODARG(5).NE.5).OR. 545 - - (MODARG(6).NE.2.AND.MODARG(6).NE.5)))THEN 546 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// 547 - - ' (ex+,ey+) in PLOT_ERROR_BARS; no error bars.' 548 - RETURN 549 - ELSEIF(IFORM.EQ.3.AND.( 550 - - NARG.GT.8.OR. 551 - - (NARG.GE.7.AND.MODARG(7).NE.1).OR. 552 - - (NARG.GE.8.AND.MODARG(8).NE.2)))THEN 553 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect option'// 554 - - ' list for PLOT_ERROR_BARS; no error bars.' 1 120 P=GRAPHICS D=GRACAL 7 PAGE 178 555 - RETURN 556 - ENDIF 557 - * Fetch the option string, if present. 558 - IF(IFORM.EQ.1.AND.NARG.GE.3.AND.MODARG(3).EQ.1)THEN 559 - CALL STRBUF('READ',NINT(ARG(3)),TITLE,NC,IFAIL1) 560 - IF(NC.LT.1)THEN 561 - TITLE=' ' 562 - NC=1 563 - ENDIF 564 - CALL CLTOU(TITLE(1:NC)) 565 - ELSEIF(IFORM.EQ.2.AND.NARG.GE.5.AND.MODARG(5).EQ.1)THEN 566 - CALL STRBUF('READ',NINT(ARG(5)),TITLE,NC,IFAIL1) 567 - IF(NC.LT.1)THEN 568 - TITLE=' ' 569 - NC=1 570 - ENDIF 571 - CALL CLTOU(TITLE(1:NC)) 572 - ELSEIF(IFORM.EQ.3.AND.NARG.GE.7.AND.MODARG(7).EQ.1)THEN 573 - CALL STRBUF('READ',NINT(ARG(7)),TITLE,NC,IFAIL1) 574 - IF(NC.LT.1)THEN 575 - TITLE=' ' 576 - NC=1 577 - ENDIF 578 - CALL CLTOU(TITLE(1:NC)) 579 - ELSE 580 - TITLE='CIRCLE' 581 - NC=6 582 - IFAIL1=0 583 - ENDIF 584 - * Fetch the character size if present. 585 - IF(IFORM.EQ.1.AND.NARG.GE.4.AND.MODARG(4).EQ.2)THEN 586 - SIZE=ARG(4) 587 - ELSEIF(IFORM.EQ.2.AND.NARG.GE.6.AND.MODARG(6).EQ.2)THEN 588 - SIZE=ARG(6) 589 - ELSEIF(IFORM.EQ.3.AND.NARG.GE.8.AND.MODARG(8).EQ.2)THEN 590 - SIZE=ARG(8) 591 - ELSE 592 - SIZE=0.01 593 - ENDIF 594 - * Locate the arrays, get hold of and check dimensions. 595 - ILEN=0 596 - DO 301 I=1,NARG 597 - IF(MODARG(I).EQ.5)THEN 598 - IREF(I)=NINT(ARG(I)) 599 - ISLOT(I)=MATSLT(IREF(I)) 600 - IF(ISLOT(I).NE.0)THEN 601 - IF(MDIM(ISLOT(I)).NE.1)PRINT *,' ------ GRACAL'// 602 - - ' MESSAGE : Non 1-dimensional vector'// 603 - - ' found; unraveled.' 604 - IF(ILEN.EQ.0)THEN 605 - ILEN=MLEN(ISLOT(I)) 606 - ELSEIF(ILEN.NE.MLEN(ISLOT(I)))THEN 607 - PRINT *,' !!!!!! GRACAL WARNING : Vectors'// 608 - - ' have different lengths; no error bars.' 609 - RETURN 610 - ENDIF 611 - ELSE 612 - PRINT *,' !!!!!! GRACAL WARNING : Vector'// 613 - - ' not found; no error bars.' 614 - RETURN 615 - ENDIF 616 - ENDIF 617 - 301 CONTINUE 618 - * If none are arrays, then assign a size of 1. 619 - IF(ILEN.EQ.0)THEN 620 - ISIZ(1)=1 621 - ELSE 622 - ISIZ(1)=ILEN 623 - ENDIF 624 - * Expand those numbers that are not matrices. 625 - DO 302 I=1,6 626 - IF((I.EQ.5.OR.I.EQ.6).AND.(IFORM.EQ.1.OR.IFORM.EQ.2))THEN 627 - IREF(I)=IREF(I-2) 628 - ELSEIF((I.EQ.3.OR.I.EQ.4).AND.IFORM.EQ.1)THEN 629 - CALL MATADM('ALLOCATE',IREF(I),1,ISIZ,2,IFAIL2) 630 - IF(IFAIL2.NE.0)THEN 631 - PRINT *,' !!!!!! GRACAL WARNING : Unable to'// 632 - - ' create a null-vector; no error bars.' 633 - RETURN 634 - ENDIF 635 - ISLOT(I)=MATSLT(IREF(I)) 636 - IF(ISLOT(I).LE.0)THEN 637 - PRINT *,' !!!!!! GRACAL WARNING : Unable to'// 638 - - ' locate a null-vector; no error bars.' 639 - RETURN 640 - ENDIF 641 - DO 303 J=1,ISIZ(1) 642 - MVEC(MORG(ISLOT(I))+J)=0 643 - 303 CONTINUE 644 - ELSEIF(MODARG(I).EQ.2)THEN 645 - CALL MATADM('ALLOCATE',IREF(I),1,ISIZ,2,IFAIL2) 646 - IF(IFAIL2.NE.0)THEN 647 - PRINT *,' !!!!!! GRACAL WARNING : Unable to'// 648 - - ' expand a number; no error bars.' 649 - RETURN 650 - ENDIF 651 - ISLOT(I)=MATSLT(IREF(I)) 652 - IF(ISLOT(I).LE.0)THEN 653 - PRINT *,' !!!!!! GRACAL WARNING : Unable to'// 654 - - ' locate an expanded number; no error bars.' 655 - RETURN 656 - ENDIF 657 - DO 305 J=1,ISIZ(1) 658 - MVEC(MORG(ISLOT(I))+J)=ARG(I) 659 - 305 CONTINUE 660 - ENDIF 1 120 P=GRAPHICS D=GRACAL 8 PAGE 179 661 - 302 CONTINUE 662 - * Switch to graphics screen. 663 - CALL GRGRAF(.FALSE.) 664 - * Plot the error bars. 665 - CALL MATERR(IREF(1),IREF(2),IREF(3), 666 - - IREF(4),IREF(5),IREF(6),TITLE(1:NC),SIZE) 667 - * Switch to alpha screen. 668 - CALL GRALPH 669 - * Get rid of temporary arrays. 670 - DO 304 I=1,6 671 - IF((I.EQ.1.OR.I.EQ.2).AND.MODARG(I).EQ.2)THEN 672 - CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL3) 673 - ELSEIF((I.EQ.3.OR.I.EQ.4).AND.( 674 - - IFORM.EQ.1.OR. 675 - - (MODARG(I).EQ.2.AND.IFORM.GT.1)))THEN 676 - CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL3) 677 - ELSEIF((I.EQ.5.OR.I.EQ.6).AND. 678 - - (MODARG(I).EQ.2.AND.IFORM.GT.2))THEN 679 - CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL3) 680 - ENDIF 681 - 304 CONTINUE 682 - *** Project a line. 683 - ELSEIF(IPROC.EQ.-810)THEN 684 - * Check number of arguments. 685 - IF(NARG.LT.1.OR.NARG.GT.4.OR. 686 - - MODARG(1).NE.5.OR.MODARG(2).NE.5.OR.MODARG(2).NE.5.OR. 687 - - (NARG.GE.4.AND.MODARG(4).NE.1))THEN 688 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// 689 - - ' arguments for PROJECT_LINE.' 690 - RETURN 691 - ENDIF 692 - * Switch to graphics screen. 693 - CALL GRGRAF(.FALSE.) 694 - * If there is a 3rd argument, set the polyline type. 695 - IF(NARG.GE.4)THEN 696 - CALL STRBUF('READ',NINT(ARG(4)),TITLE,NCTIT,IFAIL1) 697 - IF(NCTIT.LT.1)THEN 698 - TITLE=' ' 699 - NCTIT=1 700 - ENDIF 701 - CALL CLTOU(TITLE(1:NCTIT)) 702 - ELSE 703 - TITLE='SOLID' 704 - NCTIT=5 705 - IFAIL1=0 706 - ENDIF 707 - CALL GRATTS(TITLE(1:NCTIT),'POLYLINE') 708 - * Plot the line segment. 709 - CALL MATPLN(NINT(ARG(1)),NINT(ARG(2)),NINT(ARG(3))) 710 - * Switch back to alphanumeric screen. 711 - CALL GRALPH 712 - * Error processing. 713 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! GRACAL WARNING : Error'// 714 - - ' retrieving a string for PROJECT_LINE.' 715 - *** Project a set of markers. 716 - ELSEIF(IPROC.EQ.-811)THEN 717 - * Check number of arguments. 718 - IF(NARG.LT.1.OR.NARG.GT.4.OR. 719 - - MODARG(1).NE.5.OR.MODARG(2).NE.5.OR.MODARG(2).NE.5.OR. 720 - - (NARG.GE.4.AND.MODARG(4).NE.1))THEN 721 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// 722 - - ' arguments for PROJECT_MARKERS.' 723 - RETURN 724 - ENDIF 725 - * Switch to graphics screen. 726 - CALL GRGRAF(.FALSE.) 727 - * If there is a 3rd argument, set the polyline type. 728 - IF(NARG.GE.4)THEN 729 - CALL STRBUF('READ',NINT(ARG(4)),TITLE,NCTIT,IFAIL1) 730 - IF(NCTIT.LT.1)THEN 731 - TITLE=' ' 732 - NCTIT=1 733 - ENDIF 734 - CALL CLTOU(TITLE(1:NCTIT)) 735 - ELSE 736 - TITLE='CROSS' 737 - NCTIT=5 738 - IFAIL1=0 739 - ENDIF 740 - CALL GRATTS(TITLE(1:NCTIT),'POLYMARKER') 741 - * Plot the markers. 742 - CALL MATPMK(NINT(ARG(1)),NINT(ARG(2)),NINT(ARG(3))) 743 - * Switch back to alphanumeric screen. 744 - CALL GRALPH 745 - * Error processing. 746 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! GRACAL WARNING : Error'// 747 - - ' retrieving a string for PLOT_MARKERS.' 748 - *** Open a plot, doing nothing else. 749 - ELSEIF(IPROC.EQ.-812)THEN 750 - IF(NARG.NE.0)THEN 751 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect number'// 752 - - ' of arguments for PLOT_START.' 753 - RETURN 754 - ENDIF 755 - CALL GRGRAF(.TRUE.) 756 - *** Set a window. 757 - ELSEIF(IPROC.EQ.-813)THEN 758 - IF(NARG.NE.5.OR. 759 - - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR.MODARG(3).NE.2.OR. 760 - - MODARG(4).NE.2.OR.MODARG(5).NE.2)THEN 761 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// 762 - - ' list for GKS_WINDOW; not executed.' 763 - RETURN 764 - ELSE 765 - CALL GSWN(NINT(ARG(1)),ARG(2),ARG(3),ARG(4),ARG(5)) 766 - ENDIF 1 120 P=GRAPHICS D=GRACAL 9 PAGE 180 767 - *** Set a viewport. 768 - ELSEIF(IPROC.EQ.-814)THEN 769 - IF(NARG.NE.5.OR. 770 - - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR.MODARG(3).NE.2.OR. 771 - - MODARG(4).NE.2.OR.MODARG(5).NE.2)THEN 772 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// 773 - - ' list for GKS_VIEWPORT; not executed.' 774 - RETURN 775 - ELSE 776 - CALL GSVP(NINT(ARG(1)),ARG(2),ARG(3),ARG(4),ARG(5)) 777 - ENDIF 778 - *** Select a normalisation transformation. 779 - ELSEIF(IPROC.EQ.-815)THEN 780 - IF(NARG.NE.1.OR.MODARG(1).NE.2)THEN 781 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// 782 - - ' list for GKS_SELECT_NT; not executed.' 783 - RETURN 784 - ELSE 785 - CALL GSELNT(NINT(ARG(1))) 786 - ENDIF 787 - *** Plot a polyline. 788 - ELSEIF(IPROC.EQ.-816)THEN 789 - * Check number of arguments. 790 - IF(NARG.NE.2.OR.MODARG(1).NE.5.OR.MODARG(2).NE.5)THEN 791 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// 792 - - ' arguments for GKS_POLYLINE.' 793 - RETURN 794 - ENDIF 795 - * Switch to graphics screen. 796 - CALL GRGRAF(.FALSE.) 797 - * Plot the line. 798 - CALL MATLIN(NINT(ARG(1)),NINT(ARG(2)),'GKS') 799 - * Switch back to alphanumeric screen. 800 - CALL GRALPH 801 - *** Plot polymarkers. 802 - ELSEIF(IPROC.EQ.-817)THEN 803 - * Check number of arguments. 804 - IF(NARG.NE.2.OR.MODARG(1).NE.5.OR.MODARG(2).NE.5)THEN 805 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// 806 - - ' arguments for GKS_POLYMARKER.' 807 - RETURN 808 - ENDIF 809 - * Switch to graphics screen. 810 - CALL GRGRAF(.FALSE.) 811 - * Plot the line. 812 - CALL MATMRK(NINT(ARG(1)),NINT(ARG(2)),'GKS') 813 - * Switch back to alphanumeric screen. 814 - CALL GRALPH 815 - *** Set attributes. 816 - ELSEIF(IPROC.EQ.-818.OR.IPROC.EQ.-819.OR. 817 - - IPROC.EQ.-820.OR.IPROC.EQ.-821)THEN 818 - * Check argument types. 819 - IF(NARG.NE.1.OR.MODARG(1).NE.1)THEN 820 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// 821 - - ' received by SET_x_ATTRIBUTES.' 822 - RETURN 823 - ENDIF 824 - * Pick up the representation. 825 - CALL STRBUF('READ',NINT(ARG(1)),TITLE,NCTIT,IFAIL1) 826 - IF(IFAIL1.NE.0.OR.NCTIT.LE.0)THEN 827 - PRINT *,' !!!!!! GRACAL WARNING : Unable to retrieve'// 828 - - ' the representation name.' 829 - RETURN 830 - ENDIF 831 - CALL CLTOU(TITLE(1:NCTIT)) 832 - * Set the representation. 833 - IF(IPROC.EQ.-818)THEN 834 - CALL GRATTS(TITLE(1:NCTIT),'POLYLINE') 835 - ELSEIF(IPROC.EQ.-819)THEN 836 - CALL GRATTS(TITLE(1:NCTIT),'POLYMARKER') 837 - ELSEIF(IPROC.EQ.-820)THEN 838 - CALL GRATTS(TITLE(1:NCTIT),'TEXT') 839 - ELSEIF(IPROC.EQ.-821)THEN 840 - CALL GRATTS(TITLE(1:NCTIT),'AREA') 841 - ENDIF 842 - *** Plot a text string. 843 - ELSEIF(IPROC.EQ.-822)THEN 844 - * Check number of arguments. 845 - IF(NARG.NE.3.OR.MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 846 - - MODARG(3).NE.1)THEN 847 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// 848 - - ' arguments for GKS_TEXT.' 849 - RETURN 850 - ENDIF 851 - * Pick up the representation. 852 - CALL STRBUF('READ',NINT(ARG(3)),TITLE,NCTIT,IFAIL1) 853 - IF(IFAIL1.NE.0.OR.NCTIT.LE.0)THEN 854 - PRINT *,' !!!!!! GRACAL WARNING : Unable to retrieve'// 855 - - ' the text string.' 856 - RETURN 857 - ENDIF 858 - * Switch to graphics screen. 859 - CALL GRGRAF(.FALSE.) 860 - * Plot the text. 861 - CALL GTX(ARG(1),ARG(2),TITLE(1:NCTIT)) 862 - * Switch back to alphanumeric screen. 863 - CALL GRALPH 864 - *** Plot an area. 865 - ELSEIF(IPROC.EQ.-823)THEN 866 - * Check number of arguments. 867 - IF(NARG.NE.2.OR.MODARG(1).NE.5.OR.MODARG(2).NE.5)THEN 868 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// 869 - - ' arguments for GKS_AREA.' 870 - RETURN 871 - ENDIF 872 - * Switch to graphics screen. 1 120 P=GRAPHICS D=GRACAL 10 PAGE 181 873 - CALL GRGRAF(.FALSE.) 874 - * Plot the line. 875 - CALL MATFAR(NINT(ARG(1)),NINT(ARG(2)),'GKS') 876 - * Switch back to alphanumeric screen. 877 - CALL GRALPH 878 - *** Set the text alignment. 879 - ELSEIF(IPROC.EQ.-824)THEN 880 - IF(NARG.NE.2.OR.MODARG(1).NE.1.OR.MODARG(2).NE.1)THEN 881 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// 882 - - ' arguments for GKS_SET_TEXT_ALIGNMENT.' 883 - RETURN 884 - ENDIF 885 - * Fetch the horizontal alignment. 886 - CALL STRBUF('READ',NINT(ARG(1)),TITLE,NCTIT,IFAIL1) 887 - IF(IFAIL1.NE.0.OR.NCTIT.LE.0)THEN 888 - PRINT *,' !!!!!! GRACAL WARNING : Unable to retrieve'// 889 - - ' the horizontal alignment.' 890 - RETURN 891 - ENDIF 892 - CALL CLTOU(TITLE(1:NCTIT)) 893 - IF(TITLE(1:NCTIT).EQ.'NORMAL')THEN 894 - IHOR=0 895 - ELSEIF(TITLE(1:NCTIT).EQ.'LEFT')THEN 896 - IHOR=1 897 - ELSEIF(TITLE(1:NCTIT).EQ.'CENTER'.OR. 898 - - TITLE(1:NCTIT).EQ.'CENTRE')THEN 899 - IHOR=2 900 - ELSEIF(TITLE(1:NCTIT).EQ.'RIGHT')THEN 901 - IHOR=3 902 - ELSE 903 - PRINT *,' !!!!!! GRACAL WARNING : Invalid horizontal'// 904 - - ' alignment; using NORMAL.' 905 - IHOR=0 906 - ENDIF 907 - * Fetch the vertical alignment. 908 - CALL STRBUF('READ',NINT(ARG(2)),TITLE,NCTIT,IFAIL1) 909 - IF(IFAIL1.NE.0.OR.NCTIT.LE.0)THEN 910 - PRINT *,' !!!!!! GRACAL WARNING : Unable to retrieve'// 911 - - ' the vertical alignment.' 912 - RETURN 913 - ENDIF 914 - CALL CLTOU(TITLE(1:NCTIT)) 0 915-+ +SELF,IF=HIGZ. 916 - IF(TITLE(1:NCTIT).EQ.'NORMAL')THEN 917 - IVERT=0 918 - ELSEIF(TITLE(1:NCTIT).EQ.'TOP')THEN 919 - IVERT=1 920 - ELSEIF(TITLE(1:NCTIT).EQ.'CAP')THEN 921 - IVERT=2 922 - ELSEIF(TITLE(1:NCTIT).EQ.'HALF')THEN 923 - IVERT=3 924 - ELSEIF(TITLE(1:NCTIT).EQ.'BASE')THEN 925 - IVERT=0 926 - ELSEIF(TITLE(1:NCTIT).EQ.'BOTTOM')THEN 927 - IVERT=0 928 - ELSE 929 - PRINT *,' !!!!!! GRACAL WARNING : Invalid vertical'// 930 - - ' alignment; using NORMAL.' 931 - IVERT=0 932 - ENDIF 0 933-+ +SELF,IF=-HIGZ. 934 - IF(TITLE(1:NCTIT).EQ.'NORMAL')THEN 935 - IVERT=0 936 - ELSEIF(TITLE(1:NCTIT).EQ.'TOP')THEN 937 - IVERT=1 938 - ELSEIF(TITLE(1:NCTIT).EQ.'CAP')THEN 939 - IVERT=2 940 - ELSEIF(TITLE(1:NCTIT).EQ.'HALF')THEN 941 - IVERT=3 942 - ELSEIF(TITLE(1:NCTIT).EQ.'BASE')THEN 943 - IVERT=4 944 - ELSEIF(TITLE(1:NCTIT).EQ.'BOTTOM')THEN 945 - IVERT=5 946 - ELSE 947 - PRINT *,' !!!!!! GRACAL WARNING : Invalid vertical'// 948 - - ' alignment; using NORMAL.' 949 - IVERT=0 950 - ENDIF 0 951-+ +SELF. 952 - * Issue the GKS call. 953 - CALL GSTXAL(IHOR,IVERT) 954 - *** Text colour. 955 - ELSEIF(IPROC.EQ.-825)THEN 956 - * Check arguments. 957 - IF(NARG.NE.1.OR.MODARG(1).NE.1)THEN 958 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// 959 - - ' list for GKS_SET_TEXT_COLOUR' 960 - RETURN 961 - ENDIF 962 - * Retrieve the colour name. 963 - CALL STRBUF('READ',NINT(ARG(1)),TITLE,NCTIT,IFAIL1) 964 - IF(IFAIL1.NE.0.OR.NCTIT.LT.1)THEN 965 - PRINT *,' !!!!!! GRACAL WARNING : Unable to retrieve'// 966 - - ' the GKS_SET_TEXT_COLOUR colour.' 967 - RETURN 968 - ENDIF 969 - * Locate the colour in the table. 970 - CALL GRCOLQ(1,TITLE(1:NCTIT),ICOL) 971 - IF(ICOL.LT.0)THEN 972 - PRINT *,' !!!!!! GRACAL WARNING : The colour '// 973 - - TITLE(1:NCTIT)//' is not known; not set.' 974 - RETURN 975 - ENDIF 1 120 P=GRAPHICS D=GRACAL 11 PAGE 182 976 - * Set the colour. 977 - CALL GSTXCI(ICOL) 978 - *** Character height. 979 - ELSEIF(IPROC.EQ.-826)THEN 980 - * Check the argument list. 981 - IF(NARG.NE.1.OR.MODARG(1).NE.2)THEN 982 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// 983 - - ' list for GKS_SET_CHARACTER_HEIGHT' 984 - RETURN 985 - ENDIF 986 - * Issue the GKS call. 987 - CALL GSCHH(ARG(1)) 988 - *** Character expansion. 989 - ELSEIF(IPROC.EQ.-827)THEN 990 - * Check the argument list. 991 - IF(NARG.NE.1.OR.MODARG(1).NE.2)THEN 992 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// 993 - - ' list for GKS_SET_CHARACTER_EXPANSION' 994 - RETURN 995 - ENDIF 996 - * Issue the GKS call. 997 - CALL GSCHXP(ARG(1)) 998 - *** Character spacing. 999 - ELSEIF(IPROC.EQ.-828)THEN 1000 - * Check the argument list. 1001 - IF(NARG.NE.1.OR.MODARG(1).NE.2)THEN 1002 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// 1003 - - ' list for GKS_SET_CHARACTER_SPACING' 1004 - RETURN 1005 - ENDIF 1006 - * Issue the GKS call. 1007 - CALL GSCHSP(ARG(1)) 1008 - *** Character up vector. 1009 - ELSEIF(IPROC.EQ.-829)THEN 1010 - * Check the argument list. 1011 - IF(NARG.NE.2.OR.MODARG(1).NE.2.OR.MODARG(2).NE.2)THEN 1012 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// 1013 - - ' list for GKS_SET_CHARACTER_UP_VECTOR' 1014 - RETURN 1015 - ENDIF 1016 - * Issue the GKS call. 1017 - CALL GSCHUP(ARG(1),ARG(2)) 1018 - *** Text font and precision. 1019 - ELSEIF(IPROC.EQ.-830)THEN 1020 - * Check the argument list. 1021 - IF(NARG.NE.2.OR.MODARG(1).NE.2.OR.MODARG(2).NE.1)THEN 1022 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// 1023 - - ' list for GKS_SET_CHARACTER_UP_VECTOR' 1024 - RETURN 1025 - ENDIF 1026 - * Extract the precision. 1027 - CALL STRBUF('READ',NINT(ARG(2)),TITLE,NCTIT,IFAIL1) 1028 - CALL CLTOU(TITLE(1:MIN(1,NCTIT))) 1029 - IF(NCTIT.LT.1.OR.IFAIL1.NE.0)THEN 1030 - PRINT *,' !!!!!! GRACAL WARNING : Invalid character'// 1031 - - ' precision ; font and precision not set.' 1032 - RETURN 1033 - ELSEIF(TITLE(1:NCTIT).EQ.'STROKE')THEN 1034 - IPREC=2 1035 - ELSEIF(TITLE(1:NCTIT).EQ.'CHARACTER')THEN 1036 - IPREC=1 1037 - ELSEIF(TITLE(1:NCTIT).EQ.'STRING')THEN 1038 - IPREC=0 1039 - ELSE 1040 - PRINT *,' !!!!!! GRACAL WARNING : Character'// 1041 - - ' precision '//TITLE(1:NCTIT)// 1042 - - ' is not know; assuming CHARACTER.' 1043 - IPREC=1 1044 - ENDIF 1045 - * Issue the GKS call. 1046 - CALL GSTXFP(NINT(ARG(1)),IPREC) 1047 - *** Plot an arrow. 1048 - ELSEIF(IPROC.EQ.-850)THEN 1049 - * Check number of arguments. 1050 - IF(NARG.LT.4.OR.NARG.GT.5.OR. 1051 - - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 1052 - - MODARG(3).NE.2.OR.MODARG(4).NE.2.OR. 1053 - - (NARG.GE.5.AND.MODARG(5).NE.1))THEN 1054 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// 1055 - - ' arguments for PLOT_ARROW.' 1056 - RETURN 1057 - ENDIF 1058 - * Pick up the representation, if present. 1059 - IF(NARG.GE.5)THEN 1060 - CALL STRBUF('READ',NINT(ARG(5)),TITLE,NCTIT,IFAIL1) 1061 - IF(NCTIT.LT.1)THEN 1062 - TITLE='SOLID' 1063 - NCTIT=5 1064 - ENDIF 1065 - CALL CLTOU(TITLE(1:NCTIT)) 1066 - ELSE 1067 - TITLE='SOLID' 1068 - NCTIT=5 1069 - IFAIL1=0 1070 - ENDIF 1071 - * Switch to graphics screen. 1072 - CALL GRGRAF(.FALSE.) 1073 - * Plot the arrow with the requested representation. 1074 - CALL GRATTS(TITLE(1:NCTIT),'POLYLINE') 1075 - CALL GRARRO(ARG(1),ARG(2),ARG(3),ARG(4)) 1076 - * Switch back to alphanumeric screen. 1077 - CALL GRALPH 1078 - * Print error message. 1079 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! GRACAL WARNING : Unable'// 1080 - - ' to retrieve the arrow representation; set to SOLID.' 1081 - *** Plot a title. 1 120 P=GRAPHICS D=GRACAL 12 PAGE 183 1082 - ELSEIF(IPROC.EQ.-851)THEN 1083 - * Check number of arguments and argument type. 1084 - IF(NARG.NE.1.OR.MODARG(1).NE.1)THEN 1085 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// 1086 - - ' arguments for PLOT_TITLE.' 1087 - RETURN 1088 - ENDIF 1089 - * Retrieve the title string. 1090 - CALL STRBUF('READ',NINT(ARG(1)),TITLE,NCTIT,IFAIL1) 1091 - IF(IFAIL1.NE.0.OR.NCTIT.LE.0)THEN 1092 - PRINT *,' !!!!!! GRACAL WARNING : Unable to retrieve'// 1093 - - ' the title.' 1094 - RETURN 1095 - ENDIF 1096 - * Plot the title. 1097 - CALL GSELNT(0) 1098 - CALL GSCHUP(0.0,1.0) 1099 - CALL GSTXAL(1,1) 1100 - CALL GRATTS('TITLE','TEXT') 1101 - CALL GRTX(0.1,1.0-GPXT,TITLE(1:NCTIT)) 1102 - * Restore. 1103 - CALL GSELNT(1) 1104 - CALL GSTXAL(0,0) 1105 - CALL GSCHUP(0.0,1.0) 1106 - *** Plot an x-label. 1107 - ELSEIF(IPROC.EQ.-852)THEN 1108 - * Check number of arguments and argument type. 1109 - IF(NARG.NE.1.OR.MODARG(1).NE.1)THEN 1110 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// 1111 - - ' arguments for PLOT_X_LABEL.' 1112 - RETURN 1113 - ENDIF 1114 - * Retrieve the title string. 1115 - CALL STRBUF('READ',NINT(ARG(1)),XTXT,NCXTXT,IFAIL1) 1116 - IF(IFAIL1.NE.0.OR.NCXTXT.LE.0)THEN 1117 - PRINT *,' !!!!!! GRACAL WARNING : Unable to retrieve'// 1118 - - ' the x-label.' 1119 - RETURN 1120 - ENDIF 1121 - * Label the x-axis. 1122 - CALL GSELNT(0) 1123 - CALL GSTXAL(3,0) 1124 - CALL GSCHUP(0.0,1.0) 1125 - CALL GRATTS('LABELS','TEXT') 1126 - CALL GQTXX(IWK,0.5,0.5,XTXT(1:NCXTXT),IERR,CPX,CPY, 1127 - - XBOX,YBOX) 1128 - YSHIFT=0.5-MIN(YBOX(1),YBOX(2),YBOX(3),YBOX(4)) 1129 - CALL GRTX(0.9,GPXL+YSHIFT,XTXT(1:NCXTXT)) 1130 - * Restore. 1131 - CALL GSELNT(1) 1132 - CALL GSTXAL(0,0) 1133 - CALL GSCHUP(0.0,1.0) 1134 - *** Plot a y-label. 1135 - ELSEIF(IPROC.EQ.-853)THEN 1136 - * Check number of arguments and argument type. 1137 - IF(NARG.NE.1.OR.MODARG(1).NE.1)THEN 1138 - PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// 1139 - - ' arguments for PLOT_Y_LABEL.' 1140 - RETURN 1141 - ENDIF 1142 - * Retrieve the title string. 1143 - CALL STRBUF('READ',NINT(ARG(1)),YTXT,NCYTXT,IFAIL1) 1144 - IF(IFAIL1.NE.0.OR.NCYTXT.LE.0)THEN 1145 - PRINT *,' !!!!!! GRACAL WARNING : Unable to retrieve'// 1146 - - ' the y-label.' 1147 - RETURN 1148 - ENDIF 1149 - * Label the y-axis. 1150 - CALL GSELNT(0) 1151 - CALL GSTXAL(3,1) 1152 - CALL GSCHUP(-1.0,0.0) 1153 - CALL GRATTS('LABELS','TEXT') 1154 - CALL GRTX(GPYL,0.9,YTXT(1:NCYTXT)) 1155 - * Restore. 1156 - CALL GSELNT(1) 1157 - CALL GSTXAL(0,0) 1158 - CALL GSCHUP(0.0,1.0) 1159 - *** Unknown graphics operation. 1160 - ELSE 1161 - PRINT *,' !!!!!! GRACAL WARNING : Unknown procedure code'// 1162 - - ' received; nothing done.' 1163 - IFAIL=1 1164 - RETURN 1165 - ENDIF 1166 - *** Seems to have worked. 1167 - IFAIL=0 1168 - END 121 GARFIELD ================================================== P=GRAPHICS D=GRACWK 1 ============================ 0 + +DECK,GRACWK. 1 - SUBROUTINE GRACWK(NAME) 2 - *----------------------------------------------------------------------- 3 - * GRACWK - Activates a workstation - GKS version. 4 - * (Last changed on 9/10/95.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,GRAPHICS. 10 - EXTERNAL INPCMX 11 - INTEGER INPCMX,IWK,IFAIL,IERR,ISTATE 12 - CHARACTER*(*) NAME 13 - *** Locate workstation. 14 - CALL GRQIWK(NAME,IWK,IFAIL) 15 - IF(IFAIL.NE.0)RETURN 1 121 P=GRAPHICS D=GRACWK 2 PAGE 184 16 - *** Check the current state of the workstation. 17 - IF(WKSTAT(IWK).LT.2)THEN 18 - PRINT *,' ------ GRACWK MESSAGE : Workstation ',NAME, 19 - - ' is not yet open; trying to open ...' 20 - CALL GROPWK(NAME) 21 - IF(WKSTAT(IWK).EQ.2)THEN 22 - PRINT *,' Opening the'// 23 - - ' workstation was successful.' 24 - ELSE 25 - PRINT *,' !!!!!! GRACWK WARNING : Opening failed'// 26 - - ' ; workstation not activated.' 27 - RETURN 28 - ENDIF 29 - ENDIF 30 - CALL GQWKS(IWK,IERR,ISTATE) 31 - IF(IERR.NE.0)THEN 32 - PRINT *,' !!!!!! GRACWK WARNING : Inquiry error for'// 33 - - ' state of ',NAME,' ; assumed inactive.' 34 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRACWK DEBUG :'', 35 - - '' GQWKS Error code '',I3,'' state '',I1,'' for'', 36 - - '' workstation '',A,''.'')') IERR,ISTATE,NAME 37 - ELSEIF(ISTATE.EQ.1)THEN 38 - PRINT *,' !!!!!! GRACWK WARNING : Workstation ', 39 - - NAME,' is already active.' 40 - WKSTAT(IWK)=3 41 - RETURN 42 - ENDIF 43 - *** And at last activate the workstation. 44 - CALL GACWK(IWK) 45 - WKSTAT(IWK)=3 0 46-+ +SELF,IF=HIGZ. 47 - CALL SGFLAG 48 - IF(WKFREF(IWK).GT.0)CALL IGRNG(19.0,19.0) 0 49-+ +SELF. 50 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRACWK DEBUG :'', 51 - - '' Workstation '',A,'' has been activated.'')') NAME 52 - *** Check that the workstation is really open. 53 - CALL GQWKS(IWK,IERR,ISTATE) 54 - IF(IERR.EQ.7.OR.IERR.EQ.25)THEN 55 - PRINT *,' !!!!!! GRACWK WARNING : Cannot activate ',NAME, 56 - - ' because the workstation is not open.' 57 - WKSTAT(IWK)=1 58 - RETURN 59 - ELSEIF(IERR.EQ.20)THEN 60 - PRINT *,' !!!!!! GRACWK WARNING : Cannot activate ',NAME, 61 - - ' because the workstation identifier is not valid.' 62 - WKSTAT(IWK)=1 63 - RETURN 64 - ELSEIF(ISTATE.NE.1)THEN 65 - PRINT *,' !!!!!! GRACWK WARNING : Workstation ',NAME, 66 - - ' could not be activated.' 67 - WKSTAT(IWK)=1 68 - RETURN 69 - ENDIF 70 - END 122 GARFIELD ================================================== P=GRAPHICS D=GRADWK 1 ============================ 0 + +DECK,GRADWK. 1 - SUBROUTINE GRADWK 2 - *----------------------------------------------------------------------- 3 - * GRADWK - Adds a workstation to the workstation table. 4 - * (Last changed on 21/ 5/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GRAPHICS. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*(MXCHAR) STRING 11 - CHARACTER*(MXNAME) FILE 12 - CHARACTER*20 NAME 13 - LOGICAL KTYPE,KCONID,KOFF,KFILE,KGKSID 14 - INTEGER NC,IKEY,INEXT,NWORD,NCFILE,IOFF,ICO,ICONID,IWKTYP,ICAT,I, 15 - - IFAIL1,INPCMP,NCNAME,IERR 16 - EXTERNAL INPCMP 17 - *** Determine position of keyword. 18 - CALL INPSTR(1,1,STRING,NC) 19 - IF(STRING(1:1).EQ.'!'.AND.NC.EQ.1)THEN 20 - IKEY=2 21 - ELSE 22 - IKEY=1 23 - ENDIF 24 - *** Warn if there are no arguments. 25 - CALL INPNUM(NWORD) 26 - IF(NWORD.EQ.IKEY)THEN 27 - PRINT *,' !!!!!! GRADWK WARNING : ADD-WORKSTATION needs'// 28 - - ' arguments ; nothing done.' 29 - RETURN 30 - ENDIF 31 - *** Initial values. 32 - FILE='GARFIELD.METAFILE' 33 - NCFILE=17 34 - IOFF=0 35 - ICONID=1 36 - IWKTYP=0 37 - ICAT=-1 38 - *** First argument is the name of the workstation. 39 - CALL INPSTR(IKEY+1,IKEY+1,NAME,NCNAME) 40 - * Preset flags. 41 - KFILE=.FALSE. 42 - KGKSID=.FALSE. 43 - KTYPE=.FALSE. 44 - KCONID=.FALSE. 45 - KOFF=.FALSE. 1 122 P=GRAPHICS D=GRADWK 2 PAGE 185 46 - * Match with existing names. 47 - DO 10 I=1,NWK 48 - IF(NAME(1:NCNAME).EQ.WKNAME(I)(1:NCWKNM(I)))THEN 49 - PRINT *,' !!!!!! GRADWK WARNING : '//NAME(1:NCNAME)// 50 - - ' is already defined ; not redefined.' 51 - RETURN 52 - ENDIF 53 - 10 CONTINUE 54 - *** Loop over the rest of the string. 55 - INEXT=1 56 - DO 20 I=IKEY+2,NWORD 57 - IF(I.LT.INEXT)GOTO 20 58 - * Each keyword has 1 argument. 59 - IF(I+1.GT.NWORD)THEN 60 - CALL INPMSG(I,'Argument is missing.') 61 - GOTO 20 62 - ENDIF 63 - * Type specification. 64 - IF(INPCMP(I,'TY#PE').NE.0)THEN 65 - CALL INPSTR(I+1,I+1,STRING,NC) 66 - CALL GRWKID(STRING(1:NC),IWKTYP,ICO,ICAT,IFAIL1) 67 - IF(IFAIL1.EQ.0.AND.ICAT.EQ.2)THEN 68 - ICONID=ICO 69 - ELSEIF(IFAIL1.EQ.0)THEN 70 - IOFF=ICO 71 - ELSE 72 - CALL INPMSG(I+1,'Not a valid workstation type.') 73 - ENDIF 74 - INEXT=I+2 75 - KTYPE=.TRUE. 76 - * GKS identifier. 77 - ELSEIF(INPCMP(I,'GKS-ID#ENTIFIER').NE.0)THEN 78 - CALL INPCHK(I+1,1,IFAIL1) 79 - CALL INPRDI(I+1,IWKTYP,0) 80 - CALL GQWKCA(IWKTYP,IERR,ICAT) 81 - IF(IERR.NE.0)CALL INPMSG(I+1,'GKS inquiry error.') 82 - INEXT=I+2 83 - KGKSID=.TRUE. 84 - * Connection identifier. 85 - ELSEIF(INPCMP(I,'CON#NECTION-ID#ENTIFIER').NE.0)THEN 86 - CALL INPCHK(I+1,1,IFAIL1) 87 - CALL INPRDI(I+1,ICONID,0) 88 - INEXT=I+2 89 - KCONID=.TRUE. 90 - * Logical unit offset. 91 - ELSEIF(INPCMP(I,'OFF#SET').NE.0)THEN 92 - CALL INPCHK(I+1,1,IFAIL1) 93 - CALL INPRDI(I+1,IOFF,0) 94 - INEXT=I+2 95 - KOFF=.TRUE. 96 - * File name. 97 - ELSEIF(INPCMP(I,'F#ILE-NAME')+INPCMP(I,'NAME').NE.0)THEN 98 - CALL INPSTR(I+1,I+1,FILE,NCFILE) 99 - INEXT=I+2 100 - KFILE=.TRUE. 101 - * Anything else is not valid. 102 - ELSE 103 - CALL INPMSG(I,'Not a valid keyword.') 104 - ENDIF 105 - 20 CONTINUE 106 - *** Check for invalid combinations. 107 - IF((ICAT.EQ.2.AND.KFILE).OR. 108 - - ((ICAT.EQ.0.OR.ICAT.EQ.4).AND..NOT.KFILE).OR. 109 - - (KFILE.AND.KCONID).OR. 110 - - (.NOT.KFILE.AND.KOFF).OR. 111 - - (.NOT.KTYPE.AND..NOT.KGKSID))THEN 112 - PRINT *,' !!!!!! GRADWK WARNING : Incomplete'// 113 - - ' specification or, illegal combination of keywords' 114 - PRINT *,' or keywords used that'// 115 - - ' are not appropriate for the workstation; ignored.' 116 - RETURN 117 - ELSEIF(ICAT.EQ.-1)THEN 118 - PRINT *,' !!!!!! GRADWK WARNING : No valid workstation'// 119 - - ' type found; ignored.' 120 - RETURN 121 - ENDIF 0 122-+ +SELF,IF=CMS. 123 - *** Verify the file name. 124 - IF(KFILE)THEN 125 - CALL VMNAME(FILE,NCFILE,IFAIL1) 126 - IF(IFAIL1.NE.0)THEN 127 - PRINT *,' !!!!!! GRADWK WARNING : Metafile file name'// 128 - - ' not valid ; ! ADD ignored.' 129 - RETURN 130 - ENDIF 131 - ENDIF 0 132-+ +SELF. 133 - *** Store the information. 134 - IF(NWK.GE.MXWKLS)THEN 135 - PRINT *,' !!!!!! GRADWK WARNING : No storage left for'// 136 - - ' workstations; ignored.' 137 - RETURN 138 - ENDIF 139 - NWK=NWK+1 140 - WKNAME(NWK)=NAME(1:NCNAME) 141 - NCWKNM(NWK)=NCNAME 142 - WKID(NWK)=IWKTYP 143 - IF(KFILE)THEN 144 - CALL STRBUF('STORE',WKFREF(NWK),FILE,NCFILE,IFAIL1) 145 - WKCON(NWK)=IOFF 146 - ELSE 147 - WKFREF(NWK)=-1 148 - WKCON(NWK)=ICONID 149 - ENDIF 1 122 P=GRAPHICS D=GRADWK 3 PAGE 186 150 - WKSTAT(NWK)=0 151 - END 123 GARFIELD ================================================== P=GRAPHICS D=GRAINP 1 ============================ 0 + +DECK,GRAINP. 1 - SUBROUTINE GRAINP 2 - *----------------------------------------------------------------------- 3 - * GRAINP - Serves as a subsection reading graphics command lines. 4 - * (Last changed on 12/ 9/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9.- +SEQ,GRAPHICS. 10.- +SEQ,CONTDATA. 11.- +SEQ,PRINTPLOT. 12.- +SEQ,CONSTANTS. 13 - LOGICAL LOOP 14 - INTEGER INPCMP,NWORD,INEXT,I,NC,MXOPWK,MXACWK,MXWKAS,INIT,IERR, 15 - - IKEY,IFAIL,IFAIL1,NITERR,NSTEPR,IDEFM,IREGM,IEMPTY,IFRAME, 16 - - LEVEL,ISTA,IDEFD,IUPDD,IDEF,IUPD,IWK,IDUM1,IDUM2,IDUM,NACT 17 - REAL EPSR,DNR,AUX 18 - CHARACTER*(MXCHAR) STRING 19 - EXTERNAL INPCMP 0 20-+ +SELF,IF=AST. 21 - EXTERNAL ASTCCH 0 22-+ +SELF,IF=SAVE. 23 - SAVE INIT,MXOPWK,MXACWK,MXWKAS 0 24-+ +SELF. 25 - *** Identify the subroutine if requested. 26 - IF(LIDENT)PRINT *,' /// ROUTINE GRAINP ///' 27 - *** First call, figure out how many workstations there are. 28 - DATA INIT/0/ 29 - IF(INIT.EQ.0)THEN 30 - CALL GQWKM(IERR,MXOPWK,MXACWK,MXWKAS) 31 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRAINP DEBUG : '', 32 - - '' MXOPWK='',I3,'', MXACWK='',I3,'', MXWKAS='',I3)') 33 - - MXOPWK,MXACWK,MXWKAS 34 - INIT=1 35 - ENDIF 36 - *** First pick up the number of words and the first word. 37 - CALL INPNUM(NWORD) 38 - CALL INPSTR(1,1,STRING,NC) 39 - *** Check it is a graphics command. 40 - IF(STRING(1:1).NE.'!')RETURN 41 - *** Determine whether it is a single command or not. 42 - IF(NWORD.EQ.1.AND.NC.EQ.1)THEN 43 - LOOP=.TRUE. 44 - PRINT *,' ' 45 - PRINT *,' ------------------------------------------------' 46 - PRINT *,' ---------- Graphics subsection ----------' 47 - PRINT *,' ------------------------------------------------' 48 - PRINT *,' ' 49 - CALL INPPRM('Graphics','ADD-PRINT') 50 - ELSE 51 - LOOP=.FALSE. 52 - ENDIF 53 - *** Return here if LOOP is .TRUE. 54 - 10 CONTINUE 55 - IF(LOOP)THEN 56 - CALL INPGET 57 - CALL INPNUM(NWORD) 0 58-+ +SELF,IF=AST. 59 - *** Set up ASTCCH as the condition handler. 60 - CALL LIB$ESTABLISH(ASTCCH) 0 61-+ +SELF. 62 - ENDIF 63 - CALL INPSTR(1,1,STRING,NC) 64 - *** Skip blank lines and warn for section headers. 65 - IF(STRING(1:1).EQ.'&')THEN 66 - PRINT *,' !!!!!! GRAINP WARNING : The section cannot be'// 67 - - ' left at this point; first type EXIT.' 68 - GOTO 1010 69 - ELSEIF(INDEX('$%?><',STRING(1:1)).NE.0)THEN 70 - PRINT *,' !!!!!! GRAINP WARNING : This command cannot be'// 71 - - ' executed at the present level; first type EXIT.' 72 - GOTO 1010 73 - ELSEIF(STRING(1:1).EQ.'*')THEN 74 - GOTO 1010 75 - ENDIF 76 - IF(LOOP.AND.(NWORD.EQ.0.OR.(NWORD.EQ.1.AND.NC.EQ.1.AND. 77 - - STRING(1:1).EQ.'!')))GOTO 1010 78 - IF(.NOT.LOOP.AND.NC.EQ.1.AND.NWORD.EQ.1)RETURN 79 - *** Set the position of the command. 80 - IF(NC.EQ.1.AND.STRING(1:1).EQ.'!')THEN 81 - IKEY=2 82 - ELSE 83 - IKEY=1 84 - ENDIF 85 - *** The ACTIVATE-WORKSTATION command. 86 - IF(INPCMP(IKEY,'!ACT#IVATE-#WORKSTATION')+ 87 - - INPCMP(IKEY,'ACT#IVATE-#WORKSTATION').NE.0)THEN 88 - IF(NWORD.LE.IKEY)THEN 89 - PRINT *,' !!!!!! GRAINP WARNING : You must specify'// 90 - - ' a workstation name with this command.' 91 - * Arguments present ? 92 - ELSE 93 - * Have the workstation(s) activated. 94 - DO 30 I=IKEY+1,NWORD 95 - CALL INPSTR(I,I,STRING,NC) 1 123 P=GRAPHICS D=GRAINP 2 PAGE 187 96 - CALL GRACWK(STRING(1:NC)) 97 - 30 CONTINUE 98 - ENDIF 99 - *** Add a workstation. 100 - ELSEIF(INPCMP(IKEY,'ADD-#WORKSTATION')+ 101 - - INPCMP(IKEY,'!ADD-#WORKSTATION').NE.0)THEN 102 - CALL GRADWK 103 - *** Arrow tip angle. 104 - ELSEIF(INPCMP(IKEY,'ARR#OW-TOP-ANG#LE')+ 105 - - INPCMP(IKEY,'!ARR#OW-TOP-ANG#LE')+ 106 - - INPCMP(IKEY,'ARR#OW-TIP-ANG#LE')+ 107 - - INPCMP(IKEY,'!ARR#OW-TIP-ANG#LE')+ 108 - - INPCMP(IKEY,'ARR#OW-ANG#LE')+ 109 - - INPCMP(IKEY,'!ARR#OW-ANG#LE').NE.0)THEN 110 - IF(NWORD.EQ.IKEY)THEN 111 - WRITE(LUNOUT,'('' Current tip angle: '',F10.3, 112 - - '' degrees.'')') ARRANG*180/PI 113 - ELSE 114 - CALL INPCHK(IKEY+1,2,IFAIL1) 115 - CALL INPRDR(IKEY+1,ARRANG,ARRANG*180/PI) 116 - ARRANG=ARRANG*PI/180 117 - CALL INPERR 118 - ENDIF 119 - *** Arrow tip length. 120 - ELSEIF(INPCMP(IKEY,'ARR#OW-TIP-LEN#GTH')+ 121 - - INPCMP(IKEY,'!ARR#OW-TIP-LEN#GTH')+ 122 - - INPCMP(IKEY,'ARR#OW-LEN#GTH')+ 123 - - INPCMP(IKEY,'!ARR#OW-LEN#GTH').NE.0)THEN 124 - IF(NWORD.EQ.IKEY)THEN 125 - WRITE(LUNOUT,'('' Current tip length: '',F10.3, 126 - - '' x total length.'')') ARRLEN 127 - ELSE 128 - CALL INPCHK(IKEY+1,2,IFAIL1) 129 - CALL INPRDR(IKEY+1,ARRLEN,ARRLEN) 130 - CALL INPERR 131 - ENDIF 132 - *** Clear screen. 133 - ELSEIF(INPCMP(IKEY,'!CLE#AR-#SCREEN')+ 134 - - INPCMP(IKEY,'CLE#AR-#SCREEN').NE.0)THEN 135 - CALL GQACWK(0,IERR,NACT,IWK) 136 - IF(IERR.NE.0)THEN 137 - PRINT *,' !!!!!! GRAINP WARNING : Unable to'// 138 - - ' determine number of active workstations.' 139 - NACT=0 140 - ENDIF 141 - DO 20 I=1,NACT 142 - CALL GQACWK(I,IERR,IDUM,IWK) 143 - CALL GCLRWK(IWK,1) 144 - IF(LDEBUG)WRITE(10,'('' ++++++ GRAINP DEBUG :'', 145 - - '' Clear sent to WS '',I3,''.'')') IWK 146 - 20 CONTINUE 147 - *** Close a workstation. 148 - ELSEIF(INPCMP(IKEY,'CLO#SE-#WORKSTATION')+ 149 - - INPCMP(IKEY,'!CLO#SE-#WORKSTATION').NE.0)THEN 150 - * Argument(s) present ? 151 - IF(NWORD.NE.IKEY+1)THEN 152 - PRINT *,' !!!!!! GRAINP WARNING : You must specify'// 153 - - ' a workstation name with this command.' 154 - ELSE 155 - * Have the workstation closed. 156 - DO 80 I=IKEY+1,NWORD 157 - CALL INPSTR(I,I,STRING,NC) 158 - CALL GRCLWK(STRING(1:NC)) 159 - 80 CONTINUE 160 - ENDIF 161 - *** Colour definition. 162 - ELSEIF(INPCMP(IKEY,'!COL#OUR')+INPCMP(IKEY,'COL#OUR').NE.0)THEN 163 - CALL GRCOLR(IKEY,IFAIL) 164 - IF(IFAIL.NE.0)PRINT *,' !!!!!! GRAINP WARNING : Colour'// 165 - - ' inquiry or update failed.' 166 - *** Contour parameters. 167 - ELSEIF(INPCMP(IKEY,'!CONT#OUR-#PARAMETERS')+ 168 - - INPCMP(IKEY,'CONT#OUR-#PARAMETERS').NE.0)THEN 169 - * Print settings of arguments are missing. 170 - IF(NWORD.EQ.IKEY)THEN 171 - WRITE(LUNOUT,'('' Current contour parameters:''// 172 - - '' Bisection iterations: '',I10/ 173 - - '' Newton iterations: '',I10/ 174 - - '' Epsilon for tracing: '',E10.3/ 175 - - '' Epsilon for gradients: '',E10.3/ 176 - - '' Initial step size: '',E10.3/ 177 - - '' Relative grid tolerance: '',E10.3/ 178 - - '' Maximum number of steps: '',I10)') 179 - - NBITER,NNITER,EPSTRA,EPSGRA,DNTHR,NGCMAX 180 - * Otherwise decode argument list. 181 - ELSE 182 - INEXT=IKEY+1 183 - DO 120 I=IKEY+1,NWORD 184 - IF(I.LT.INEXT)GOTO 120 185 - IF(INPCMP(I,'BIS#ECTION-#ITER#ATIONS').NE.0)THEN 186 - CALL INPCHK(I+1,1,IFAIL1) 187 - CALL INPRDI(I+1,NITERR,NBITER) 188 - IF(NITERR.GT.0)THEN 189 - NBITER=NITERR 190 - ELSE 191 - CALL INPMSG(I+1,'Should be > 0.') 192 - ENDIF 193 - INEXT=I+2 194 - ELSEIF(INPCMP(I,'NEWT#ON-ITER#ATIONS').NE.0)THEN 195 - CALL INPCHK(I+1,1,IFAIL1) 196 - CALL INPRDI(I+1,NITERR,NNITER) 197 - IF(NITERR.GT.0)THEN 198 - NNITER=NITERR 199 - ELSE 200 - CALL INPMSG(I+1,'Should be > 0.') 201 - ENDIF 1 123 P=GRAPHICS D=GRAINP 3 PAGE 188 202 - INEXT=I+2 203 - ELSEIF(INPCMP(I,'ST#EP-MAX#IMUM').NE.0)THEN 204 - CALL INPCHK(I+1,1,IFAIL1) 205 - CALL INPRDI(I+1,NSTEPR,NGCMAX) 206 - IF(NSTEPR.GT.0)THEN 207 - NGCMAX=NSTEPR 208 - ELSE 209 - CALL INPMSG(I+1,'Should be > 0.') 210 - ENDIF 211 - INEXT=I+2 212 - ELSEIF(INPCMP(I,'EPS#ILON-GRA#DIENT').NE.0)THEN 213 - CALL INPCHK(I+1,2,IFAIL1) 214 - CALL INPRDR(I+1,EPSR,EPSGRA) 215 - IF(EPSR.GT.0)THEN 216 - EPSGRA=EPSR 217 - ELSE 218 - CALL INPMSG(I+1,'Should be > 0.') 219 - ENDIF 220 - INEXT=I+2 221 - ELSEIF(INPCMP(I,'EPS#ILON-TRA#CING').NE.0)THEN 222 - CALL INPCHK(I+1,2,IFAIL1) 223 - CALL INPRDR(I+1,EPSR,EPSTRA) 224 - IF(EPSR.GT.0)THEN 225 - EPSTRA=EPSR 226 - ELSE 227 - CALL INPMSG(I+1,'Should be > 0.') 228 - ENDIF 229 - INEXT=I+2 230 - ELSEIF(INPCMP(I,'GR#ID-TOL#ERANCE').NE.0)THEN 231 - CALL INPCHK(I+1,2,IFAIL1) 232 - CALL INPRDR(I+1,DNR,DNTHR) 233 - IF(DNR.GT.0)THEN 234 - DNTHR=DNR 235 - ELSE 236 - CALL INPMSG(I+1,'Should be > 0.') 237 - ENDIF 238 - INEXT=I+2 239 - ELSE 240 - CALL INPMSG(I,'Not a known keyword.') 241 - ENDIF 242 - 120 CONTINUE 243 - * Show error messages. 244 - CALL INPERR 245 - ENDIF 246 - *** The DEACTIVATE-WORKSTATION command. 247 - ELSEIF(INPCMP(IKEY,'!DEACT#IVATE-#WORKSTATION')+ 248 - - INPCMP(IKEY,'DEACT#IVATE-#WORKSTATION').NE.0)THEN 249 - * Arguments present ? 250 - IF(NWORD.LE.IKEY)THEN 251 - PRINT *,' !!!!!! GRAINP WARNING : You must specify'// 252 - - ' a workstation name with this command.' 253 - * Have the workstation deactivated. 254 - ELSE 255 - DO 40 I=IKEY+1,NWORD 256 - CALL INPSTR(I,I,STRING,NC) 257 - CALL GRDAWK(STRING(1:NC)) 258 - 40 CONTINUE 259 - ENDIF 260 - *** Delete a workstation. 261 - ELSEIF(INPCMP(IKEY,'DEL#ETE-#WORKSTATION')+ 262 - - INPCMP(IKEY,'!DEL#ETE-#WORKSTATION').NE.0)THEN 263 - CALL GRDLWK 264 - *** Check for the EXIT command. 265 - ELSEIF(INPCMP(IKEY,'EX#IT')+INPCMP(IKEY,'!EX#IT').NE.0)THEN 266 - PRINT *,' ' 267 - PRINT *,' ------------------------------------------------' 268 - PRINT *,' ---------- Graphics subsection end ----------' 269 - PRINT *,' ------------------------------------------------' 270 - PRINT *,' ' 271 - CALL INPPRM(' ','BACK-PRINT') 272 - RETURN 273 - *** Representation reading from dataset. 274 - ELSEIF(INPCMP(IKEY,'GET-COL#OURS')+ 275 - - INPCMP(IKEY,'!GET-COL#OURS').NE.0)THEN 276 - CALL GRCOLG(IKEY,IFAIL) 277 - IF(IFAIL.NE.0)PRINT *,' !!!!!! GRAINP WARNING : Reading'// 278 - - ' a colour table failed.' 279 - *** Representation reading from dataset. 280 - ELSEIF(INPCMP(IKEY,'GET-REP#RESENTATIONS')+ 281 - - INPCMP(IKEY,'!GET-REP#RESENTATIONS').NE.0)THEN 282 - CALL GRATTG(IKEY,IFAIL) 283 - IF(IFAIL.NE.0)PRINT *,' !!!!!! GRAINP WARNING : Reading'// 284 - - ' a graphics representation member failed.' 285 - *** Various inquire functions. 286 - ELSEIF(INPCMP(IKEY,'!INQ#UIRE-DEF#ERRAL-#UPDATE-#STATE')+ 287 - - INPCMP(IKEY,'INQ#UIRE-DEF#ERRAL-#UPDATE-#STATE').NE.0)THEN 288 - CALL INPSTR(IKEY+1,IKEY+1,STRING,NC) 289 - IF(NWK.LE.0)WRITE(LUNOUT,'(/'' There are currently no'', 290 - - '' workstations defined.''/)') 291 - DO 90 I=1,NWK 292 - IF(WKNAME(I)(1:NCWKNM(I)).EQ.STRING(1:NC).OR. 293 - - STRING.EQ.'*'.OR.IKEY.EQ.NWORD)THEN 294 - CALL GQWKDU(I,IERR,IDEFM,IREGM,IEMPTY,IFRAME) 295 - WRITE(LUNOUT,'('' Workstation '',A,'':'')') 296 - - WKNAME(I)(1:NCWKNM(I)) 297 - IF(IDEFM.EQ.0)WRITE(LUNOUT,'(7X,''Deferral state: '', 298 - - '' As soon as possible;'')') 299 - IF(IDEFM.EQ.1)WRITE(LUNOUT,'(7X,''Deferral state: '', 300 - - '' Before next global interaction;'')') 301 - IF(IDEFM.EQ.2)WRITE(LUNOUT,'(7X,''Deferral state: '', 302 - - '' Before next local interaction;'')') 303 - IF(IDEFM.EQ.3)WRITE(LUNOUT,'(7X,''Deferral state: '', 304 - - '' At some time;'')') 305 - IF(IDEFM.LT.0.OR.IDEFM.GT.3)WRITE(LUNOUT,'(7X, 306 - - ''Deferral state: *** NOT KNOWN ***'')') 307 - IF(IREGM.EQ.0)WRITE(LUNOUT,'(7X,''Regeneration: '', 1 123 P=GRAPHICS D=GRAINP 4 PAGE 189 308 - - '' Suppressed;'')') 309 - IF(IREGM.EQ.1)WRITE(LUNOUT,'(7X,''Regeneration: '', 310 - - '' Allowed;'')') 311 - IF(IREGM.LT.0.OR.IREGM.GT.1)WRITE(LUNOUT,'(7X, 312 - - ''Regeneration: *** NOT KNOWN ***'')') 313 - IF(IEMPTY.EQ.0)WRITE(LUNOUT,'(7X,''Display surface: '', 314 - - '' Not empty anymore;'')') 315 - IF(IEMPTY.EQ.1)WRITE(LUNOUT,'(7X,''Display surface: '', 316 - - '' Currently empty;'')') 317 - IF(IEMPTY.LT.0.OR.IEMPTY.GT.1)WRITE(LUNOUT,'(7X, 318 - - ''Display surface: *** NOT KNOWN ***'')') 319 - IF(IFRAME.EQ.0)WRITE(LUNOUT,'(7X,''For an update: '', 320 - - '' No new frame needed;'')') 321 - IF(IFRAME.EQ.1)WRITE(LUNOUT,'(7X,''For an update: '', 322 - - '' New frame needed;'')') 323 - IF(IFRAME.LT.0.OR.IFRAME.GT.1)WRITE(LUNOUT,'(7X, 324 - - ''For an update: *** NOT KNOWN ***'')') 325 - IF(IERR.NE.0)WRITE(LUNOUT,'(7X,''GKS inquiry error '', 326 - - I4,'' occurred.'')') IERR 327 - WRITE(LUNOUT,'('' '')') 328 - ENDIF 329 - 90 CONTINUE 330 - ELSEIF(INPCMP(IKEY,'!INQ#UIRE-LEV#EL-#GKS')+ 331 - - INPCMP(IKEY,'INQ#UIRE-LEV#EL-#GKS').NE.0)THEN 332 - CALL GQLVKS(IERR,LEVEL) 333 - IF(IERR.NE.0)GOTO 3000 334 - IF(LEVEL.EQ.-3)THEN 335 - WRITE(LUNOUT,'(/'' Running with a level mA GKS.''/)') 336 - ELSEIF(LEVEL.EQ.-2)THEN 337 - WRITE(LUNOUT,'(/'' Running with a level mB GKS.''/)') 338 - ELSEIF(LEVEL.EQ.-1)THEN 339 - WRITE(LUNOUT,'(/'' Running with a level mC GKS.''/)') 340 - ELSEIF(LEVEL.EQ. 0)THEN 341 - WRITE(LUNOUT,'(/'' Running with a level 0A GKS.''/)') 342 - ELSEIF(LEVEL.EQ.+1)THEN 343 - WRITE(LUNOUT,'(/'' Running with a level 0B GKS.''/)') 344 - ELSEIF(LEVEL.EQ.+2)THEN 345 - WRITE(LUNOUT,'(/'' Running with a level 0C GKS.''/)') 346 - ELSEIF(LEVEL.EQ.+3)THEN 347 - WRITE(LUNOUT,'(/'' Running with a level 1A GKS.''/)') 348 - ELSEIF(LEVEL.EQ.+4)THEN 349 - WRITE(LUNOUT,'(/'' Running with a level 1B GKS.''/)') 350 - ELSEIF(LEVEL.EQ.+5)THEN 351 - WRITE(LUNOUT,'(/'' Running with a level 1C GKS.''/)') 352 - ELSEIF(LEVEL.EQ.+6)THEN 353 - WRITE(LUNOUT,'(/'' Running with a level 2A GKS.''/)') 354 - ELSEIF(LEVEL.EQ.+7)THEN 355 - WRITE(LUNOUT,'(/'' Running with a level 2B GKS.''/)') 356 - ELSEIF(LEVEL.EQ.+8)THEN 357 - WRITE(LUNOUT,'(/'' Running with a level 2C GKS.''/)') 358 - ELSE 359 - WRITE(LUNOUT,'(/'' GKS level code is '',I2,'' which'', 360 - - '' is not a standard code.'')') LEVEL 361 - ENDIF 362 - ELSEIF(INPCMP(IKEY,'!INQ#UIRE-OP#ERATING-#STATE')+ 363 - - INPCMP(IKEY,'INQ#UIRE-OP#ERATING-#STATE').NE.0)THEN 364 - CALL GQOPS(ISTA) 365 - IF(ISTA.EQ.0)THEN 366 - WRITE(LUNOUT,'(/'' GKS is closed at the moment.''/)') 367 - ELSEIF(ISTA.EQ.1)THEN 368 - WRITE(LUNOUT,'(/'' GKS is open at the moment.''/)') 369 - ELSEIF(ISTA.EQ.2)THEN 370 - WRITE(LUNOUT,'(/'' A workstation is open.''/)') 371 - ELSEIF(ISTA.EQ.3)THEN 372 - WRITE(LUNOUT,'(/'' A workstation is active.''/)') 373 - ELSEIF(ISTA.EQ.4)THEN 374 - WRITE(LUNOUT,'(/'' A segment is open.''/)') 375 - ELSE 376 - WRITE(LUNOUT,'(/'' GKS state code is'',I3,'', which'', 377 - - '' is not standard.''/)') ISTA 378 - ENDIF 379 - ELSEIF(INPCMP(IKEY,'!INQ#UIRE-W#ORKSTATIONS')+ 380 - - INPCMP(IKEY,'INQ#UIRE-W#ORKSTATIONS').NE.0)THEN 381 - IF(NWK.EQ.0)THEN 382 - WRITE(LUNOUT,'(/'' Not a single workstation'', 383 - - '' known at present.'')') 384 - ELSE 385 - WRITE(LUNOUT,'(/'' LIST OF CURRENTLY KNOWN'', 386 - - '' WORKSTATIONS: ''// 387 - - '' No Workstation name State '', 388 - - '' Type C/O Unit File name''/)') 389 - DO 70 I=1,NWK 390 - WRITE(STRING,'(I3,'': '',A20,9X,3(I5,1X),20X)') 391 - - I,WKNAME(I),WKID(I),WKCON(I),WKLUN(I) 392 - STRING(27:33)='unknown' 393 - IF(WKSTAT(I).LT.2)STRING(27:33)='defined' 394 - IF(WKSTAT(I).EQ.2)STRING(27:33)=' open' 395 - IF(WKSTAT(I).EQ.3)STRING(27:33)=' active' 396 - IF(WKFREF(I).GT.0)THEN 397 - CALL STRBUF('READ',WKFREF(I),STRING(53:80),NC, 398 - - IFAIL1) 399 - ELSE 400 - STRING(47:51)=' -' 401 - STRING(53:80)='not associated with a file' 402 - ENDIF 403 - WRITE(LUNOUT,'(1X,A79)') STRING(1:79) 404 - 70 CONTINUE 405 - WRITE(LUNOUT,'('' '')') 406 - ENDIF 407 - *** Layout of Cartesian plots. 408 - ELSEIF(INPCMP(IKEY,'LAY#OUT')+INPCMP(IKEY,'!LAY#OUT').NE.0)THEN 409 - IF(NWORD.EQ.IKEY)THEN 410 - WRITE(LUNOUT,'('' Current Cartesian layout:''// 411 - - '' Decades to x-axis: '',F10.3/ 412 - - '' Decades to y-axis: '',F10.3/ 413 - - '' Numbers to x-axis: '',F10.3/ 1 123 P=GRAPHICS D=GRAINP 5 PAGE 190 414 - - '' Numbers to y-axis: '',F10.3/ 415 - - '' x-Label to border: '',F10.3/ 416 - - '' y-Label to border: '',F10.3/ 417 - - '' Title to border: '',F10.3)') 418 - - GPXN10,GPYN10,GPXN,GPYN,GPXL,GPYL,GPXT 419 - ELSE 420 - INEXT=IKEY+1 421 - DO 130 I=IKEY+1,NWORD 422 - IF(I.LT.INEXT)GOTO 130 423 - IF(INPCMP(I,'DEC#ADE-X-#DISTANCE')+ 424 - - INPCMP(I,'X-DEC#ADE-#DISTANCE').NE.0)THEN 425 - CALL INPCHK(I+1,2,IFAIL1) 426 - CALL INPRDR(I+1,AUX,GPXN10) 427 - IF(IFAIL1.EQ.0.AND.AUX.GE.0.AND.AUX.LE.0.1)THEN 428 - GPXN10=AUX 429 - ELSEIF(IFAIL1.EQ.0)THEN 430 - CALL INPMSG(I+1,'Not in range [0 , 0.1]') 431 - ENDIF 432 - INEXT=I+2 433 - ELSEIF(INPCMP(I,'DEC#ADE-Y-#DISTANCE')+ 434 - - INPCMP(I,'Y-DEC#ADE-#DISTANCE').NE.0)THEN 435 - CALL INPCHK(I+1,2,IFAIL1) 436 - CALL INPRDR(I+1,AUX,GPYN10) 437 - IF(IFAIL1.EQ.0.AND.AUX.GE.0.AND.AUX.LE.0.1)THEN 438 - GPYN10=AUX 439 - ELSEIF(IFAIL1.EQ.0)THEN 440 - CALL INPMSG(I+1,'Not in range [0 , 0.1]') 441 - ENDIF 442 - INEXT=I+2 443 - ELSEIF(INPCMP(I,'N#UMBER-X-#DISTANCE')+ 444 - - INPCMP(I,'X-N#UMBER-#DISTANCE').NE.0)THEN 445 - CALL INPCHK(I+1,2,IFAIL1) 446 - CALL INPRDR(I+1,AUX,GPXN) 447 - IF(IFAIL1.EQ.0.AND.AUX.GE.0.AND.AUX.LE.0.1)THEN 448 - GPXN=AUX 449 - ELSEIF(IFAIL1.EQ.0)THEN 450 - CALL INPMSG(I+1,'Not in range [0 , 0.1]') 451 - ENDIF 452 - INEXT=I+2 453 - ELSEIF(INPCMP(I,'N#UMBER-Y-#DISTANCE')+ 454 - - INPCMP(I,'Y-N#UMBER-#DISTANCE').NE.0)THEN 455 - CALL INPCHK(I+1,2,IFAIL1) 456 - CALL INPRDR(I+1,AUX,GPYN) 457 - IF(IFAIL1.EQ.0.AND.AUX.GE.0.AND.AUX.LE.0.1)THEN 458 - GPYN=AUX 459 - ELSEIF(IFAIL1.EQ.0)THEN 460 - CALL INPMSG(I+1,'Not in range [0 , 0.1]') 461 - ENDIF 462 - INEXT=I+2 463 - ELSEIF(INPCMP(I,'LAB#EL-X-#DISTANCE')+ 464 - - INPCMP(I,'X-LAB#EL-#DISTANCE').NE.0)THEN 465 - CALL INPCHK(I+1,2,IFAIL1) 466 - CALL INPRDR(I+1,AUX,GPXL) 467 - IF(IFAIL1.EQ.0.AND.AUX.GE.0.AND.AUX.LE.0.1)THEN 468 - GPXL=AUX 469 - ELSEIF(IFAIL1.EQ.0)THEN 470 - CALL INPMSG(I+1,'Not in range [0 , 0.1]') 471 - ENDIF 472 - INEXT=I+2 473 - ELSEIF(INPCMP(I,'LAB#EL-Y-#DISTANCE')+ 474 - - INPCMP(I,'Y-LAB#EL-#DISTANCE').NE.0)THEN 475 - CALL INPCHK(I+1,2,IFAIL1) 476 - CALL INPRDR(I+1,AUX,GPYL) 477 - IF(IFAIL1.EQ.0.AND.AUX.GE.0.AND.AUX.LE.0.1)THEN 478 - GPYL=AUX 479 - ELSEIF(IFAIL1.EQ.0)THEN 480 - CALL INPMSG(I+1,'Not in range [0 , 0.1]') 481 - ENDIF 482 - INEXT=I+2 483 - ELSEIF(INPCMP(I,'TIT#LE-#X-#DISTANCE')+ 484 - - INPCMP(I,'X-TIT#LE-#DISTANCE').NE.0)THEN 485 - CALL INPCHK(I+1,2,IFAIL1) 486 - CALL INPRDR(I+1,AUX,GPXT) 487 - IF(IFAIL1.EQ.0.AND.AUX.GE.0.AND.AUX.LE.0.1)THEN 488 - GPXT=AUX 489 - ELSEIF(IFAIL1.EQ.0)THEN 490 - CALL INPMSG(I+1,'Not in range [0 , 0.1]') 491 - ENDIF 492 - INEXT=I+2 493 - ELSE 494 - CALL INPMSG(I,'Not a known keyword.') 495 - ENDIF 496 - 130 CONTINUE 497 - CALL INPERR 498 - ENDIF 499 - *** Produce a colour map. 500 - ELSEIF(INPCMP(IKEY,'MAP-#COLOURS')+ 501 - - INPCMP(IKEY,'!MAP-#COLOURS').NE.0)THEN 502 - CALL GRCOLM 503 - *** Open a workstation. 504 - ELSEIF(INPCMP(IKEY,'OPEN-#WORKSTATION')+ 505 - - INPCMP(IKEY,'!OPEN-#WORKSTATION').NE.0)THEN 506 - * Argument(s) present ? 507 - IF(NWORD.NE.IKEY+1)THEN 508 - PRINT *,' !!!!!! GRAINP WARNING : You must specify'// 509 - - ' a workstation name with this command.' 510 - ELSE 511 - * Have the workstation opened. 512 - DO 50 I=IKEY+1,NWORD 513 - CALL INPSTR(I,I,STRING,NC) 514 - CALL GROPWK(STRING(1:NC)) 515 - 50 CONTINUE 516 - ENDIF 517 - *** Graphics options. 518 - ELSEIF(INPCMP(IKEY,'OPT#IONS')+ 519 - - INPCMP(IKEY,'!OPT#IONS').NE.0)THEN 1 123 P=GRAPHICS D=GRAINP 6 PAGE 191 520 - IF(NWORD.GT.IKEY)THEN 521 - DO 60 I=IKEY+1,NWORD 522 - IF(INPCMP(I,'LIN#EAR-X').NE.0)THEN 523 - LOGX=.FALSE. 524 - ELSEIF(INPCMP(I,'LOG#ARITHMIC-X').NE.0)THEN 525 - LOGX=.TRUE. 526 - ELSEIF(INPCMP(I,'LIN#EAR-Y').NE.0)THEN 527 - LOGY=.FALSE. 528 - ELSEIF(INPCMP(I,'LOG#ARITHMIC-Y').NE.0)THEN 529 - LOGY=.TRUE. 530 - ELSEIF(INPCMP(I,'LOG#ARITHMIC-Y').NE.0)THEN 531 - LOGY=.FALSE. 532 - ELSEIF(INPCMP(I,'GR#ID-#PLOT').NE.0)THEN 533 - LGRID=.TRUE. 534 - ELSEIF(INPCMP(I,'NOGR#ID-#PLOT').NE.0)THEN 535 - LGRID=.FALSE. 536 - ELSEIF(INPCMP(I,'T#IME-S#TAMP').NE.0)THEN 537 - LSTAMP=.TRUE. 538 - ELSEIF(INPCMP(I,'NOT#IME-S#TAMP').NE.0)THEN 539 - LSTAMP=.FALSE. 540 - ELSEIF(INPCMP(I,'CL#EAR-BEF#ORE-#PLOT').NE.0)THEN 541 - LGCLRB=.TRUE. 542 - ELSEIF(INPCMP(I,'NOCL#EAR-BEF#ORE-#PLOT').NE.0)THEN 543 - LGCLRB=.FALSE. 544 - ELSEIF(INPCMP(I,'CL#EAR-AFT#ER-#PLOT').NE.0)THEN 545 - LGCLRA=.TRUE. 546 - ELSEIF(INPCMP(I,'NOCL#EAR-AFT#ER-#PLOT').NE.0)THEN 547 - LGCLRA=.FALSE. 548 - ELSEIF(INPCMP(I,'WAIT-AFT#ER-#PLOT').NE.0)THEN 549 - LWAITA=.TRUE. 550 - ELSEIF(INPCMP(I,'NOWAIT-AFT#ER-#PLOT').NE.0)THEN 551 - LWAITA=.FALSE. 552 - ELSEIF(INPCMP(I,'WAIT-BEF#ORE-#PLOT').NE.0)THEN 553 - LWAITB=.TRUE. 554 - ELSEIF(INPCMP(I,'NOWAIT-BEF#ORE-#PLOT').NE.0)THEN 555 - LWAITB=.FALSE. 556 - ELSEIF(INPCMP(I,'EX#ECUTE-CONTR#OL-#CHARACTERS').NE. 557 - - 0)THEN 558 - LXCCH=.TRUE. 559 - ELSEIF(INPCMP(I,'DISP#LAY-CONTR#OL-#CHARACTERS').NE. 560 - - 0)THEN 561 - LXCCH=.FALSE. 562 - ELSE 563 - CALL INPMSG(I,'Not a valid option.') 564 - ENDIF 565 - 60 CONTINUE 566 - CALL INPERR 567 - ELSE 568 - WRITE(LUNOUT, 569 - - '(/'' CURRENT GRAPHICS OPTION SETTINGS:''// 570 - - '' Plot a coordinate grid: '',L1/ 571 - - '' Time stamp on metafile: '',L1/ 572 - - '' Logarithmic scale x-axis: '',L1/ 573 - - '' Logarithmic scale y-axis: '',L1/ 574 - - '' Clear screen before plot: '',L1/ 575 - - '' Clear screen after plot: '',L1/ 576 - - '' Wait before plot: '',L1/ 577 - - '' Wait after plot: '',L1/ 578 - - '' Execute control characters: '',L1/)') 579 - - LGRID,LSTAMP,LOGX,LOGY,LGCLRB,LGCLRA, 580 - - LWAITB,LWAITA,LXCCH 581 - ENDIF 582 - *** Set deferral state. 583 - ELSEIF(INPCMP(IKEY,'SET-DEF#ERRAL-#STATE')+ 584 - - INPCMP(IKEY,'!SET-DEF#ERRAL-#STATE').NE.0)THEN 585 - IF(NWORD.NE.IKEY+3)THEN 586 - PRINT *,' !!!!!! GRAINP WARNING : Incorrect number'// 587 - - ' arguments; ignored.' 588 - ELSE 589 - * Locate the workstation. 590 - CALL INPSTR(IKEY+1,IKEY+1,STRING,NC) 591 - DO 100 I=1,NWK 592 - IF(WKNAME(I)(1:NCWKNM(I)).EQ.STRING(1:NC))THEN 593 - IWK=I 594 - GOTO 110 595 - ENDIF 596 - 100 CONTINUE 597 - CALL INPMSG(IKEY+1,'Not a known workstation.') 598 - IWK=-1 599 - 110 CONTINUE 600 - * Find old values. 601 - IF(IWK.GE.1)THEN 602 - CALL GQWKDU(IWK,IERR,IDEFD,IUPDD,IDUM1,IDUM2) 603 - IF(IERR.NE.0)IDEFD=-1 604 - IF(IERR.NE.0)IUPDD=-1 605 - ELSE 606 - IDEFD=-1 607 - IUPDD=-1 608 - ENDIF 609 - * Find the deferral and update states. 610 - IDEF=-1 611 - IUPD=-1 612 - IF(INPCMP(IKEY+2,'AS-#SOON-#AS-#POSSIBLE')+ 613 - - INPCMP(IKEY+2,'ASAP').NE.0)THEN 614 - IDEF=0 615 - ELSEIF(INPCMP(IKEY+2,'BEF#ORE-N#EXT-I#NTERACTION-'// 616 - - 'GL#OBALLY')+INPCMP(IKEY+2,'BNIG').NE.0)THEN 617 - IDEF=1 618 - ELSEIF(INPCMP(IKEY+2,'BEF#ORE-N#EXT-I#NTERACTION-'// 619 - - 'LOC#ALLY')+INPCMP(IKEY+2,'BNIL').NE.0)THEN 620 - IDEF=2 621 - ELSEIF(INPCMP(IKEY+2,'AT-#SOME-#TIME')+ 622 - - INPCMP(IKEY+2,'AST').NE.0)THEN 623 - IDEF=3 624 - ELSEIF(INPCMP(IKEY+2,'*').NE.0.AND.IDEFD.GE.0)THEN 625 - IDEF=IDEFD 1 123 P=GRAPHICS D=GRAINP 7 PAGE 192 626 - ELSE 627 - CALL INPMSG(IKEY+2,'Not a valid deferral mode.') 628 - ENDIF 629 - IF(INPCMP(IKEY+3,'SUP#PRESSED').NE.0)THEN 630 - IUPD=0 631 - ELSEIF(INPCMP(IKEY+3,'ALL#OWED').NE.0)THEN 632 - IUPD=1 633 - ELSEIF(INPCMP(IKEY+3,'*').NE.0.AND.IUPDD.GE.0)THEN 634 - IUPD=IUPDD 635 - ELSE 636 - CALL INPMSG(IKEY+3,'Not a valid update mode.') 637 - ENDIF 638 - * Set the new state. 639 - IF(IDEF.GE.0.AND.IUPD.GE.0.AND.IWK.GE.0) 640 - - CALL GSDS(IWK,IDEF,IUPD) 641 - * Show error messages. 642 - CALL INPERR 643 - ENDIF 644 - *** Show a shading map. 645 - ELSEIF(INPCMP(IKEY,'SH#ADING-#MAP')+ 646 - - INPCMP(IKEY,'SH#ADES-#MAP')+ 647 - - INPCMP(IKEY,'!SH#ADING-#MAP')+ 648 - - INPCMP(IKEY,'!SH#ADES-#MAP').NE.0)THEN 649 - CALL COLSHM 650 - *** Stamp string. 651 - ELSEIF(INPCMP(IKEY,'STAMP')+ 652 - - INPCMP(IKEY,'!STAMP').NE.0)THEN 653 - IF(NWORD.EQ.IKEY)THEN 654 - WRITE(LUNOUT,'(/'' Current stamp string: "'',A, 655 - - ''".'')') STAMP(1:NCSTMP) 656 - ELSE 657 - CALL INPSTR(IKEY+1,IKEY+1,STAMP,NCSTMP) 658 - ENDIF 659 - *** Representation setting and inquiry. 660 - ELSEIF(INPCMP(IKEY,'REP#RESENTATION')+ 661 - - INPCMP(IKEY,'!REP#RESENTATION').NE.0)THEN 662 - CALL GRATTR(IKEY,IFAIL) 663 - IF(IFAIL.NE.0)PRINT *,' !!!!!! GRAINP WARNING : Change or'// 664 - - ' inquiry of the representation failed.' 665 - *** Colour writing to dataset. 666 - ELSEIF(INPCMP(IKEY,'WR#ITE-COL#OURS')+ 667 - - INPCMP(IKEY,'!WR#ITE-COL#OURS').NE.0)THEN 668 - CALL GRCOLW(IKEY,IFAIL) 669 - IF(IFAIL.NE.0)PRINT *,' !!!!!! GRAINP WARNING : Writing'// 670 - - ' a list of colours to a dataset failed.' 671 - *** Representation writing to dataset. 672 - ELSEIF(INPCMP(IKEY,'WR#ITE-REP#RESENTATIONS')+ 673 - - INPCMP(IKEY,'!WR#ITE-REP#RESENTATIONS').NE.0)THEN 674 - CALL GRATTW(IKEY,IFAIL) 675 - IF(IFAIL.NE.0)PRINT *,' !!!!!! GRAINP WARNING : Writing'// 676 - - ' a graphics representation member failed.' 677 - *** Reset the colour table. 678 - ELSEIF(INPCMP(IKEY,'RESET-#COLOURS')+ 679 - - INPCMP(IKEY,'!RESET-#COLOURS').NE.0)THEN 680 - CALL GRCOLS 681 - *** Invalid option. 682 - ELSE 683 - CALL INPSTR(IKEY,IKEY,STRING,NC) 684 - PRINT *,' !!!!!! GRAINP WARNING : '//STRING(1:NC)//' is'// 685 - - ' not a valid command; it is ignored.' 686 - ENDIF 687 - *** Either read a new input line or return to the calling section. 688 - 1010 CONTINUE 689 - *** Next command, if in a sub-section. 690 - IF(LOOP)GOTO 10 691 - RETURN 692 - *** Inquiry failed. 693 - 3000 CONTINUE 694 - PRINT *,' !!!!!! GRAINP WARNING : GKS inquiry function failed;'// 695 - - ' no output returned.' 696 - END 124 GARFIELD ================================================== P=GRAPHICS D=GRALOG 1 ============================ 0 + +DECK,GRALOG. 1 - SUBROUTINE GRALOG(NAME) 2 - *----------------------------------------------------------------------- 3 - * GRALOG - Routine accumulating data on the plots being produced. 4 - * GRAPRT and printing its data when called with an empty name. 5 - * VARIABLES : NAME : Description of the plot just completed 6 - * LIST : List of the above descriptions 7 - * ICOUNT : Counts the number of names entered 8 - * (Last changed on 24/ 5/91.) 9 - *----------------------------------------------------------------------- 10 - CHARACTER*40 LIST(100) 11 - CHARACTER*(*) NAME 0 12-+ +SELF,IF=SAVE. 13 - SAVE LIST,ICOUNT 0 14-+ +SELF. 15 - *** Initialise ICOUNT to 0. 16 - DATA ICOUNT/0/ 17 - *** Store the information in LIST. 18 - IF(ICOUNT.LT.100)THEN 19 - ICOUNT=ICOUNT+1 20 - LIST(ICOUNT)=NAME 21 - RETURN 22 - ENDIF 23 - * Issue a warning if 100 plots have been made. 24 - IF(ICOUNT.EQ.100)THEN 25 - ICOUNT=101 26 - PRINT *,' !!!!!! GRALOG WARNING : 100 Plots have been'// 27 - - ' made ; information on other plots will not be stored' 28 - ENDIF 29 - RETURN 1 124 P=GRAPHICS D=GRALOG 2 PAGE 193 30 - *** Print the data stored during the run. 31 - ENTRY GRAPRT 32 - WRITE(*,'(''1'')') 33 - IF(ICOUNT.EQ.0)THEN 34 - PRINT *,' No plots have been made.' 35 - RETURN 36 - ENDIF 37 - PRINT *,' List of the plots and their frame numbers:' 38 - PRINT *,' ==========================================' 39 - PRINT *,' ' 40 - PRINT *,' Description of the plot Frame number' 41 - PRINT *,' ' 42 - DO 10 J=1,MIN(100,ICOUNT) 43 - PRINT '(2X,A40,I12)',LIST(J),J-1 44 - 10 CONTINUE 45 - PRINT *,' ' 46 - PRINT *,' ' 47 - END 125 GARFIELD ================================================== P=GRAPHICS D=GRALPH 1 ============================ 0 + +DECK,GRALPH. 1 - SUBROUTINE GRALPH 2 - *----------------------------------------------------------------------- 3 - * GRALPH - Switches the screen from graphics to alpha mode. Largely 4 - * copied from GKSPACK (J551) written by Ian McLaren. 5 - * (Last changed on 30/ 8/93.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,PRINTPLOT. 8 - *** Check there is at least one workstation active. 9 - CALL GQOPS(IOPSTA) 10 - IF(IOPSTA.LT.3)THEN 11 - IF(LDEBUG)WRITE(10,'('' ++++++ GRALPH DEBUG :'', 12 - - '' No active workstations.'')') 13 - RETURN 14 - ENDIF 15 - *** Check that there is at least one workstation with input. 16 - CALL GQACWK(0,IERR,NACT,IWK) 17 - IWKREQ=-1 18 - DO 20 I=1,NACT 19 - CALL GQACWK(I,IERR,IDUM,IWK) 20 - * Locate one that has input facilities. 21 - CALL GQWKC(IWK,IERR1,ICONID,IWKTYP) 22 - CALL GQWKCA(IWKTYP,IERR2,IWKCAT) 23 - IF(IWKCAT.EQ.1.OR.IWKCAT.EQ.2)IWKREQ=IWK 24 - 20 CONTINUE 25 - * Return if not found. 26 - IF(IWKREQ.EQ.-1)THEN 27 - IF(LDEBUG)WRITE(10,'('' ++++++ GRALPH DEBUG :'', 28 - - '' No active workstation with input.'')') 29 - RETURN 30 - ENDIF 0 31-+ +SELF,IF=HIGZ. 32 - *** Switch back to alpha mode (HIGZ version). 33 - CALL IGSA(IWKREQ) 0 34-+ +SELF,IF=CMS,VAX,LINUX,IF=GTSGRAL,IF=-HIGZ. 35 - *** Switch back to alpha mode (CMS version with GTS-GRAL/GKS). 36 - CALL GCGTOA(IWKREQ) 0 37-+ +SELF,IF=CMS,IF=-GTSGRAL,IF=-HIGZ. 38 - *** Switch back to alpha mode (CMS version with PLOT-10/GKS). 39 - DATA PGSW/Z18/ 40 - CALL HTIMEO(1000) 41 - CALL HWRAS(1,PGSW) 42 - CALL HTIMEO(100) 0 43-+ +SELF,IF=VAX,IF=ATCGKS,IF=-HIGZ. 44 - *** Switch back to alpha mode (Vax version with ATC GKS). 45 - CALL GUESC001(IWKREQ,0) 0 46-+ +SELF,IF=VAX,IF=-GTSGRAL,IF=-ATCGKS,IF=-HIGZ. 47 - *** Switch back to alpha mode (Vax version, for PG terminals). 48 - DATA PGSW/'18'X/ 49 - RECODE=LIB$WAIT(0.5) 50 - WRITE(*,'(1X,A1)') PGSW 51 - RECODE=LIB$WAIT(0.1) 0 52-+ +SELF. 53 - END 126 GARFIELD ================================================== P=GRAPHICS D=GRAPOL 1 ============================ 0 + +DECK,GRAPOL. 1 - SUBROUTINE GRAPOL(RMIN1,PMIN1,RMAX1,PMAX1,RTXT,PTXT,TITLE) 2 - *---------------------------------------------------------------------- 3 - * GRAPOL - Subroutine plotting axis, annotating them and adding 4 - * tickmarks along them. 5 - * This routine is used for polar coordinate systems. 6 - * VARIABLES : RMIN,RMAX : User minimum and maximum for plots in r 7 - * PMIN,PMAX : User minimum and maximum for plots in phi 8 - * XTXT,YTXT : Title along the x and y axis. 9 - * TITLE : Global title. 10 - * (Last changed on 11/ 5/96.) 11 - *---------------------------------------------------------------------- 12.- +SEQ,DIMENSIONS. 13.- +SEQ,PARAMETERS. 14.- +SEQ,GRAPHICS. 15.- +SEQ,CONSTANTS. 16.- +SEQ,PRINTPLOT. 17 - REAL XPL(101),YPL(101) 18 - CHARACTER*(*) TITLE 19 - CHARACTER*40 RTXT,PTXT 20 - CHARACTER*66 TEXT 21 - CHARACTER*13 TICK 1 126 P=GRAPHICS D=GRAPOL 2 PAGE 194 22 - *** Define some formats 23 - 1010 FORMAT(A40,' Scaling factor= 10**',I2,' ') 24 - 1020 FORMAT(A40,' ') 25 - 1050 FORMAT(F6.1,' ') 26 - 1030 FORMAT(A5,I1,' ') 27 - 1040 FORMAT(A5,I2,' ') 28 - *** Define 2 statement function to convert from user to disp frame. 29 - XUTOD(X)=DISPX0+(DISPX1-DISPX0)*(X-USERX0)/(USERX1-USERX0) 30 - YUTOD(Y)=DISPY0+(DISPY1-DISPY0)*(Y-USERY0)/(USERY1-USERY0) 31 - *** Switch to graphics mode. 32 - CALL GRGRAF(.TRUE.) 33 - *** Define display area of screen. 34 - CALL GSVP(1,DISPX0,DISPX1,DISPY0,DISPY1) 35 - *** Transform input parameters to polar coordinates. 36 - RMIN=EXP(MIN(RMIN1,RMAX1)) 37 - RMAX=EXP(MAX(RMIN1,RMAX1)) 38 - PMIN=MOD(MIN(PMIN1,PMAX1),2.0*PI) 39 - PMAX=MOD(MAX(PMIN1,PMAX1),2.0*PI) 40 - *** Check input data, could cause overflows. 41 - IF(PMIN.EQ.PMAX)THEN 42 - WRITE(10,*) ' !!!!!! GRAPOL WARNING : Phi bounds are'// 43 - - ' equal ; set to -pi, pi.' 44 - PMIN=-PI 45 - PMAX=+PI 46 - ENDIF 47 - IF(RMIN.EQ.RMAX)THEN 48 - WRITE(10,*) ' !!!!!! GRAPOL WARNING : R bounds are'// 49 - - ' equal ; set to 1, 10.' 50 - RMIN=1.0 51 - RMAX=10.0 52 - ENDIF 53 - *** Produce some debugging output 54 - IF(LDEBUG)WRITE(10,'('' ++++++ GRAPOL DEBUG : Polar'', 55 - - '' bounds are ('',E12.5,'','',E12.5,''), ('',E12.5, 56 - - '','',E12.5,'').'')') RMIN,PMIN,RMAX,PMAX 57 - *** Prepare a box around the user area and find the area, 58 - XMIN=RMIN*COS(PMIN) 59 - XMAX=XMIN 60 - YMIN=RMIN*SIN(PMIN) 61 - YMAX=YMIN 62 - DO 10 I=0,49 63 - IF(PMIN.GT.PMAX)THEN 64 - ANGLE=PMIN+I*(PMAX-PMIN+2.0*PI)/49.0 65 - ELSE 66 - ANGLE=PMIN+I*(PMAX-PMIN)/49.0 67 - ENDIF 68 - XPL(I+1)=RMIN*COS(ANGLE) 69 - YPL(I+1)=RMIN*SIN(ANGLE) 70 - XPL(100-I)=RMAX*COS(ANGLE) 71 - YPL(100-I)=RMAX*SIN(ANGLE) 72 - XMIN=MIN(XMIN,XPL(I+1),XPL(100-I)) 73 - XMAX=MAX(XMAX,XPL(I+1),XPL(100-I)) 74 - YMIN=MIN(YMIN,YPL(I+1),YPL(100-I)) 75 - YMAX=MAX(YMAX,YPL(I+1),YPL(100-I)) 76 - 10 CONTINUE 77 - XPL(101)=XPL(1) 78 - YPL(101)=YPL(1) 79 - * make the box squared. 80 - DIFF=YMAX-YMIN-XMAX+XMIN 81 - IF(DIFF.GT.0.0)THEN 82 - XMAX=XMAX+DIFF/2.0 83 - XMIN=XMIN-DIFF/2.0 84 - ELSE 85 - YMAX=YMAX-DIFF/2.0 86 - YMIN=YMIN+DIFF/2.0 87 - ENDIF 88 - *** Store frame size. 89 - FRXMIN=XMIN 90 - FRXMAX=XMAX 91 - FRYMIN=YMIN 92 - FRYMAX=YMAX 93 - *** Define user area in the plot frame. 94 - USERX0=XMIN-0.1*(XMAX-XMIN)/(DISPX1-DISPX0-0.2) 95 - USERX1=XMAX+0.1*(XMAX-XMIN)/(DISPX1-DISPX0-0.2) 96 - USERY0=YMIN-0.1*(YMAX-YMIN)/(DISPY1-DISPY0-0.2) 97 - USERY1=YMAX+0.1*(YMAX-YMIN)/(DISPY1-DISPY0-0.2) 98 - CALL GSWN(1,USERX0,USERX1,USERY0,USERY1) 99 - CALL GSELNT(1) 100 - *** Plot the box. 101 - CALL GRATTS('BOX-TICKMARKS','POLYLINE') 102 - CALL GPL(101,XPL,YPL) 103 - *** Find reasonable scale order-of-magnitude, first in r. 104 - KR=INT(LOG10(RMAX-RMIN)) 105 - KKR=3*INT(LOG10(RMAX-RMIN)/3.0) 106 - IF(LOG10(RMAX-RMIN).LT.0.0)KR=KR-1 107 - IF(RMAX-RMIN.LT.1.0)KKR=KKR-3 108 - DR=(RMAX-RMIN)/10.0**KR 109 - * And also in phi. 110 - IF(PMIN.LT.PMAX)THEN 111 - KP=INT(LOG10(180.0*(PMAX-PMIN)/PI)) 112 - KKP=3*INT(LOG10(180.0*(PMAX-PMIN)/PI)/3.0) 113 - IF(LOG10(180.0*(PMAX-PMIN)/PI).LT.0.0)KP=KP-1 114 - IF(180.0*(PMAX-PMIN)/PI.LT.1.0)KKP=KKP-1 115 - DP=ABS(180.0*(PMAX-PMIN)/PI)/10.0**KP 116 - ELSE 117 - KP=INT(LOG10(ABS(180.0*(PMAX-PMIN+2.0*PI)/PI))) 118 - KKP=3*INT(LOG10(ABS(180.0*(PMAX-PMIN+2.0*PI)/PI))/3.0) 119 - IF(LOG10(ABS(180.0*(PMAX-PMIN+2.0*PI)/PI)).LT.0.0)KP=KP-1 120 - IF(ABS(180.0*(PMAX-PMIN+2.0*PI)/PI).LT.1.0)KKP=KKP-1 121 - DP=ABS(180.0*(PMAX-PMIN+2.0*PI)/PI)/10.0**KP 122 - ENDIF 123 - * Find the distance between 2 tickmarks. 124 - IF(DR.LT.2.0)DR=0.1 125 - IF(DR.GE.2.0.AND.DR.LT.5.0)DR=0.2 126 - IF(DR.GE.5.0)DR=0.5 127 - IF(DP.LT.2.0)DP=0.1 1 126 P=GRAPHICS D=GRAPOL 3 PAGE 195 128 - IF(DP.GE.2.0.AND.DP.LT.5.0)DP=0.2 129 - IF(DP.GE.5.0)DP=0.5 130 - DR=DR*10.0**KR 131 - DP=(PI/180.0)*DP*10.0**KP 132 - *** Plot tickmarks and scale on the arcs, compute number of tick marks. 133 - IF(PMAX.GT.PMIN)THEN 134 - NTICK=(PMAX-PMIN)/DP 135 - ELSE 136 - NTICK=(PMAX-PMIN+2.0*PI)/DP 137 - ENDIF 138 - * Set graphics attributes for the labels. 139 - CALL GRATTS('NUMBERS','TEXT') 140 - * Loop over the tickmarks. 141 - DO 20 I=0,NTICK+1 142 - ANGLE=DP*(I+INT(PMIN/DP)) 143 - IF(PMIN.GT.PMAX.AND.ANGLE.GT.PMAX+2.0*PI)GOTO 20 144 - IF(PMIN.LE.PMAX.AND.(ANGLE.GT.PMAX.OR.ANGLE.LT.PMIN))GOTO 20 145 - * Plot the grid if requested. 146 - IF(LGRID)THEN 147 - XPL(1)=RMIN*COS(ANGLE) 148 - YPL(1)=RMIN*SIN(ANGLE) 149 - XPL(2)=RMAX*COS(ANGLE) 150 - YPL(2)=RMAX*SIN(ANGLE) 151 - CALL GRATTS('GRID','POLYLINE') 152 - CALL GPL(2,XPL,YPL) 153 - CALL GRATTS('BOX-TICKMARKS','POLYLINE') 154 - ENDIF 155 - * Plot tickmarks. 156 - XPL(1)=RMIN*COS(ANGLE) 157 - YPL(1)=RMIN*SIN(ANGLE) 158 - IF(XPL(1)**2+YPL(1)**2.GT.0.0)THEN 159 - XPL(2)=XPL(1)*(1.0+0.01*(XMAX-XMIN)/ 160 - - SQRT(XPL(1)**2+YPL(1)**2)) 161 - YPL(2)=YPL(1)*(1.0+0.01*(XMAX-XMIN)/ 162 - - SQRT(XPL(1)**2+YPL(1)**2)) 163 - CALL GPL(2,XPL,YPL) 164 - ENDIF 165 - XPL(1)=RMAX*COS(ANGLE) 166 - YPL(1)=RMAX*SIN(ANGLE) 167 - IF(XPL(1)**2+YPL(1)**2.GT.0.0)THEN 168 - XPL(2)=XPL(1)*(1.0-0.01*(XMAX-XMIN)/ 169 - - SQRT(XPL(1)**2+YPL(1)**2)) 170 - YPL(2)=YPL(1)*(1.0-0.01*(XMAX-XMIN)/ 171 - - SQRT(XPL(1)**2+YPL(1)**2)) 172 - CALL GPL(2,XPL,YPL) 173 - ENDIF 174 - * Bring the angle in the normal range. 175 - ANGSCL=MOD(180.0*ANGLE/PI,360.0) 176 - IF(ANGSCL.GT.+180.0)ANGSCL=ANGSCL-360.0 177 - IF(ANGSCL.LE.-180.0)ANGSCL=ANGSCL+360.0 178 - * Format the number. 179 - CALL OUTFMT(ANGSCL/10.0**KKP,2,TICK,NC,'LEFT') 180 - * And plot the number. 181 - IF(XPL(1)**2+YPL(1)**2.GT.0.0)THEN 182 - XSC=XUTOD(1.015*RMAX*COS(ANGLE)) 183 - YSC=YUTOD(1.015*RMAX*SIN(ANGLE)) 184 - CALL GSELNT(0) 185 - CALL GSCHUP(YPL(2)-YPL(1),XPL(1)-XPL(2)) 186 - CALL GSTXAL(1,3) 187 - CALL GRTX(XSC,YSC,TICK(1:NC)) 188 - CALL GSELNT(1) 189 - ENDIF 190 - 20 CONTINUE 191 - *** Tickmarks and scale on one of the straight segments. 192 - NTICK=ABS(RMAX-RMIN)/DR 193 - * Loop over the tickmarks. 194 - DO 30 I=0,NTICK+1 195 - RVAL=DR*(I+INT(RMIN/DR)) 196 - IF(RVAL.GT.RMAX.OR.RVAL.LT.RMIN)GOTO 30 197 - * Optional grid. 198 - IF(LGRID)THEN 199 - DO 40 J=1,100 200 - XPL(J)=RVAL*COS(PMIN+REAL(J-1)*(PMAX-PMIN)/99.0) 201 - YPL(J)=RVAL*SIN(PMIN+REAL(J-1)*(PMAX-PMIN)/99.0) 202 - 40 CONTINUE 203 - CALL GRATTS('GRID','POLYLINE') 204 - CALL GPL(100,XPL,YPL) 205 - CALL GRATTS('BOX-TICKMARKS','POLYLINE') 206 - ENDIF 207 - * Plot the tickmarks, plot scale at the same time. 208 - XPL(1)=RVAL*COS(PMIN) 209 - YPL(1)=RVAL*SIN(PMIN) 210 - IF(XPL(1)**2+YPL(1)**2.GT.0.0)THEN 211 - XPL(2)=XPL(1)-YPL(1)*0.01*(XMAX-XMIN)/ 212 - - SQRT(XPL(1)**2+YPL(1)**2) 213 - YPL(2)=YPL(1)+XPL(1)*0.01*(XMAX-XMIN)/ 214 - - SQRT(XPL(1)**2+YPL(1)**2) 215 - CALL GPL(2,XPL,YPL) 216 - IF(SIN(PMIN).LT.SIN(PMAX))THEN 217 - CALL OUTFMT(RVAL/10.0**KKR,2,TICK,NC,'LEFT') 218 - XSC=XUTOD(XPL(1)+YPL(1)*0.015*(XMAX-XMIN)/ 219 - - SQRT(XPL(1)**2+YPL(1)**2)) 220 - YSC=YUTOD(YPL(1)-XPL(1)*0.015*(XMAX-XMIN)/ 221 - - SQRT(XPL(1)**2+YPL(1)**2)) 222 - CALL GSELNT(0) 223 - CALL GSCHUP(YPL(2)-YPL(1),XPL(1)-XPL(2)) 224 - CALL GSTXAL(1,3) 225 - CALL GRTX(XSC,YSC,TICK(1:NC)) 226 - CALL GSELNT(1) 227 - ENDIF 228 - ENDIF 229 - * And tickmarks and perhaps a scale on the other axis. 230 - XPL(1)=RVAL*COS(PMAX) 231 - YPL(1)=RVAL*SIN(PMAX) 232 - IF(XPL(1)**2+YPL(1)**2.GT.0.0)THEN 233 - XPL(2)=XPL(1)+YPL(1)*0.01*(XMAX-XMIN)/ 1 126 P=GRAPHICS D=GRAPOL 4 PAGE 196 234 - - SQRT(XPL(1)**2+YPL(1)**2) 235 - YPL(2)=YPL(1)-XPL(1)*0.01*(XMAX-XMIN)/ 236 - - SQRT(XPL(1)**2+YPL(1)**2) 237 - CALL GPL(2,XPL,YPL) 238 - IF(SIN(PMIN).GE.SIN(PMAX))THEN 239 - CALL OUTFMT(RVAL/10.0**KKR,2,TICK,NC,'LEFT') 240 - XSC=XUTOD(XPL(1)-YPL(1)*0.015*(XMAX-XMIN)/ 241 - - SQRT(XPL(1)**2+YPL(1)**2)) 242 - YSC=YUTOD(YPL(1)+XPL(1)*0.015*(XMAX-XMIN)/ 243 - - SQRT(XPL(1)**2+YPL(1)**2)) 244 - CALL GSELNT(0) 245 - CALL GSCHUP(YPL(1)-YPL(2),XPL(2)-XPL(1)) 246 - CALL GSTXAL(1,3) 247 - CALL GRTX(XSC,YSC,TICK(1:NC)) 248 - CALL GSELNT(1) 249 - ENDIF 250 - ENDIF 251 - 30 CONTINUE 252 - *** Write the titles and the orders of magnitudes at the bottom, 253 - CALL GSELNT(0) 254 - CALL GSCHUP(0.0,1.0) 255 - IF(KKP.NE.0)THEN 256 - WRITE(TEXT,1010) PTXT,KKP 257 - ELSE 258 - WRITE(TEXT,1020) PTXT 259 - ENDIF 260 - CALL GSTXAL(1,0) 261 - CALL GRATTS('LABELS','TEXT') 262 - CALL GRTX(0.1,0.01,TEXT) 263 - IF(KKR.NE.0)THEN 264 - WRITE(TEXT,1010) RTXT,KKR 265 - ELSE 266 - WRITE(TEXT,1020) RTXT 267 - ENDIF 268 - CALL GRTX(0.1,0.04,TEXT) 269 - CALL GRATTS('TITLE','TEXT') 270 - CALL GRTX(0.1,0.97,TITLE) 271 - * reset GKS parameters. 272 - CALL GSELNT(1) 273 - CALL GSTXAL(0,0) 274 - END 127 GARFIELD ================================================== P=GRAPHICS D=GRAREA 1 ============================ 0 + +DECK,GRAREA. 1 - SUBROUTINE GRAREA(NIN,XIN,YIN) 2 - *----------------------------------------------------------------------- 3 - * GRAREA - Draws an area in either log or linear coordinates. 4 - * VARIABLES: NU : Number of points 5 - * (XU,YU) : Vertices of the area 6 - * (Last changed on 22/ 9/98.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,GRAPHICS. 11.- +SEQ,PRINTPLOT. 12.- +SEQ,CONSTANTS. 13.- +SEQ,PARAMETERS. 14 - REAL XIN(*),YIN(*),XU(MXLIST),YU(MXLIST),XPL(MXLIST),YPL(MXLIST), 15 - - XOUT(MXLIST),YOUT(MXLIST),XCUR,YCUR,XLAST,YLAST,X0,Y0,X1,Y1, 16 - - QOUT,QIN,QFIRST,XFIRST,YFIRST,EPSX,EPSY 17 - INTEGER NIN,NU,NPL,NOUT,I,J,II,IFAIL,IMAX,NTOTP,NINP,NTOTM,NINM, 18 - - IOUT,IIN,IFIRST,ISTART 19 - LOGICAL CROSS,ONLINE,CURIN,LASTIN,ALLIN,ADD(4),IN1,IN2,IN3,IN4, 20 - - EDGE1,EDGE2,EDGE3,EDGE4,RESET 21 - EXTERNAL CROSS,ONLINE 22 - *** Verify array length. 23 - IF(NIN.GT.MXLIST)THEN 24 - PRINT *,' !!!!!! GRAREA WARNING : Input array too long;'// 25 - - ' not plotted.' 26 - RETURN 27 - ELSEIF(NIN.LE.2)THEN 28 - RETURN 29 - ENDIF 30 - *** Set precisions. 31 - IF(LEPSG)THEN 32 - EPSX=REAL(EPSGX) 33 - EPSY=REAL(EPSGY) 34 - RESET=.FALSE. 35 - ELSE 36 - EPSX=1E-5*(FRXMAX-FRXMIN) 37 - EPSY=1E-5*(FRYMAX-FRYMIN) 38 - IF(EPSX.LE.0)EPSX=1.0E-5 39 - IF(EPSY.LE.0)EPSY=1.0E-5 40 - CALL EPSSET('SET',DBLE(EPSX),DBLE(EPSY),0.0D0) 41 - RESET=.TRUE. 42 - ENDIF 43 - *** Convert input array to log scales if desired, find starting point. 44 - ISTART=0 45 - ALLIN=.TRUE. 46 - DO 10 I=1,NIN 47 - * Transform x-coordinate if requested. 48 - IF(LOGX)THEN 49 - IF(XIN(I).LE.0.0)THEN 50 - XCUR=FRXMIN-2*ABS(FRXMAX-FRXMIN) 51 - ELSE 52 - XCUR=LOG10(XIN(I)) 53 - ENDIF 54 - ELSE 55 - XCUR=XIN(I) 56 - ENDIF 57 - * Transform y-coordinate if requested. 58 - IF(LOGY)THEN 59 - IF(YIN(I).LE.0.0)THEN 60 - YCUR=FRYMIN-2*ABS(FRYMAX-FRYMIN) 61 - ELSE 1 127 P=GRAPHICS D=GRAREA 2 PAGE 197 62 - YCUR=LOG10(YIN(I)) 63 - ENDIF 64 - ELSE 65 - YCUR=YIN(I) 66 - ENDIF 67 - * See whether all points are in the box. 68 - IF(XCUR.LT.FRXMIN.OR.XCUR.GT.FRXMAX.OR. 69 - - YCUR.LT.FRYMIN.OR.YCUR.GT.FRYMAX)ALLIN=.FALSE. 70 - * Internal points are good starting points. 71 - IF(ISTART.EQ.0.AND. 72 - - XCUR.GE.FRXMIN+EPSX.AND.XCUR.LE.FRXMAX-EPSX.AND. 73 - - YCUR.GE.FRYMIN+EPSY.AND.YCUR.LE.FRYMAX-EPSY)ISTART=I 74 - * Crossings can also be used. 75 - IF(I.GT.1)THEN 76 - X0=XLAST 77 - Y0=YLAST 78 - X1=XCUR 79 - Y1=YCUR 80 - CALL CLIP(X0,Y0,X1,Y1,FRXMIN,FRYMIN,FRXMAX,FRYMAX,IFAIL) 81 - IF(ISTART.EQ.0.AND.IFAIL.EQ.0.AND. 82 - - 0.5*(X0+X1).GT.FRXMIN+EPSX.AND. 83 - - 0.5*(X0+X1).LT.FRXMAX-EPSX.AND. 84 - - 0.5*(Y0+Y1).GT.FRYMIN+EPSY.AND. 85 - - 0.5*(Y0+Y1).LT.FRYMAX-EPSY)ISTART=I 86 - ENDIF 87 - * Store the data. 88 - XU(I)=XCUR 89 - YU(I)=YCUR 90 - * Shift "current" to "last". 91 - XLAST=XCUR 92 - YLAST=YCUR 93 - 10 CONTINUE 94 - * Store number of points again for convenience. 95 - NU=NIN 96 - *** If all points are within the area, simply plot. 97 - IF(ALLIN)THEN 98 - CALL GFA(NU,XU,YU) 99 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRAREA DEBUG : All'', 100 - - '' points in the area ; plotted without clipping.'')') 101 - GOTO 3030 102 - *** No starting point found, check whether box is entirely enclosed. 103 - ELSEIF(ISTART.EQ.0)THEN 104 - CALL INTERN(NU,XU,YU,FRXMIN,FRYMIN,IN1,EDGE1) 105 - CALL INTERN(NU,XU,YU,FRXMAX,FRYMIN,IN2,EDGE2) 106 - CALL INTERN(NU,XU,YU,FRXMAX,FRYMAX,IN3,EDGE3) 107 - CALL INTERN(NU,XU,YU,FRXMIN,FRYMAX,IN4,EDGE4) 108 - IF(IN1.OR.IN2.OR.IN3.OR.IN4.OR. 109 - - (EDGE1.AND.EDGE2.AND.EDGE3.AND.EDGE4))THEN 110 - XPL(1)=FRXMIN 111 - YPL(1)=FRYMIN 112 - XPL(2)=FRXMAX 113 - YPL(2)=FRYMIN 114 - XPL(3)=FRXMAX 115 - YPL(3)=FRYMAX 116 - XPL(4)=FRXMIN 117 - YPL(4)=FRYMAX 118 - XPL(5)=FRXMIN 119 - YPL(5)=FRYMIN 120 - CALL GFA(5,XPL,YPL) 121 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRAREA DEBUG :'', 122 - - '' Plot frame entirely within area.'')') 123 - ENDIF 124 - GOTO 3030 125 - ENDIF 126 - *** Non-trivial cases: loop over the points. 127 - NOUT=0 128 - NPL=0 129 - IFIRST=0 130 - DO 100 II=ISTART-1,ISTART+NU-1 131 - * Reduce II. 132 - I=1+MOD(II+NU-1,NU) 133 - * Store point. 134 - XCUR=XU(I) 135 - YCUR=YU(I) 136 - * See whether this point is in the area. 137 - IF(XCUR.GE.FRXMIN.AND.XCUR.LE.FRXMAX.AND. 138 - - YCUR.GE.FRYMIN.AND.YCUR.LE.FRYMAX)THEN 139 - CURIN=.TRUE. 140 - ELSE 141 - CURIN=.FALSE. 142 - ENDIF 143 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRAREA DEBUG : At point '', 144 - - I3,'' ('',I3,''), (x,y)= '',2E12.5,'', in='',L1)') 145 - - I,II,XCUR,YCUR,CURIN 146 - * For the first point, skip all the rest. 147 - IF(II.LT.ISTART)GOTO 110 148 - ** Clip this section to the size of the box. 149 - X0=XLAST 150 - Y0=YLAST 151 - X1=XCUR 152 - Y1=YCUR 153 - CALL CLIP(X0,Y0,X1,Y1,FRXMIN,FRYMIN,FRXMAX,FRYMAX,IFAIL) 154 - * If this is the first point, at least part should be inside. 155 - IF(II.EQ.ISTART.AND.IFAIL.NE.0)THEN 156 - PRINT *,' !!!!!! GRAREA WARNING : No crossing found'// 157 - - ' while expecting one; polygon not drawn.' 158 - IF(LGSTOP)THEN 159 - OPEN(UNIT=12,FILE='grarea.dat',STATUS='UNKNOWN') 160 - WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG 161 - WRITE(12,*) FRXMIN,FRYMIN,FRXMAX,FRYMAX 162 - WRITE(12,*) NIN 163 - DO 200 J=1,NIN 164 - WRITE(12,*) XIN(J),YIN(J) 165 - 200 CONTINUE 166 - CLOSE(12) 167 - CALL QUIT 1 127 P=GRAPHICS D=GRAREA 3 PAGE 198 168 - ENDIF 169 - GOTO 3030 170 - * Store the first point. 171 - ELSEIF(II.EQ.ISTART)THEN 172 - NPL=1 173 - XPL(NPL)=X0 174 - YPL(NPL)=Y0 175 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 176 - - ''Started "plot" buffer with (x,y)='',2E12.5)') 177 - - X0,Y0 178 - ENDIF 179 - ** Skip processing if the points coincide. 180 - IF(ABS(XCUR-XLAST).LE.EPSX.AND.ABS(YCUR-YLAST).LE.EPSY.AND. 181 - - II.GT.ISTART)THEN 182 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Coincides with previous'', 183 - - '' point, skipped.'')') 184 - GOTO 110 185 - ENDIF 186 - ** If fully outside the box, add to "out" buffer. 187 - IF(IFAIL.NE.0)THEN 188 - * Buffer not yet started if the previous point was on the edge. 189 - IF(NOUT.LE.0)THEN 190 - IF(ONLINE(FRXMIN,FRYMIN,FRXMAX,FRYMIN, 191 - - XLAST,YLAST))THEN 192 - IOUT=1 193 - QOUT=XLAST-FRXMIN 194 - ELSEIF(ONLINE(FRXMAX,FRYMIN,FRXMAX,FRYMAX, 195 - - XLAST,YLAST))THEN 196 - IOUT=2 197 - QOUT=YLAST-FRYMIN 198 - ELSEIF(ONLINE(FRXMAX,FRYMAX,FRXMIN,FRYMAX, 199 - - XLAST,YLAST))THEN 200 - IOUT=3 201 - QOUT=FRXMAX-XLAST 202 - ELSEIF(ONLINE(FRXMIN,FRYMAX,FRXMIN,FRYMIN, 203 - - XLAST,YLAST))THEN 204 - IOUT=4 205 - QOUT=FRYMAX-YLAST 206 - ELSE 207 - PRINT *,' !!!!!! GRAREA WARNING : No leaving'// 208 - - ' edge found ; polygon not drawn.' 209 - GOTO 3030 210 - ENDIF 211 - NOUT=1 212 - XOUT(NOUT)=XLAST 213 - YOUT(NOUT)=YLAST 214 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 215 - - ''Box is left via edge '',I1,'', Q='',E12.5, 216 - - '', "out" list started.'')') IOUT,QOUT 217 - ENDIF 218 - * Add the 2nd point to the "out" buffer. 219 - IF(NOUT.GE.MXLIST)GOTO 3010 220 - NOUT=NOUT+1 221 - XOUT(NOUT)=XCUR 222 - YOUT(NOUT)=YCUR 223 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 224 - - ''Segment fully outside, added as '',I3, 225 - - '' to "out".'')') NOUT 226 - GOTO 110 227 - ** If fully inside the box, add to "plot" buffer. 228 - ELSEIF(LASTIN.AND.CURIN)THEN 229 - IF(NPL.GE.MXLIST)GOTO 3020 230 - NPL=NPL+1 231 - XPL(NPL)=X1 232 - YPL(NPL)=Y1 233 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 234 - - ''Segment fully inside, added as '',I3, 235 - - '' to "plot".'')') NPL 236 - GOTO 110 237 - ENDIF 238 - ** We re-enter the box. 239 - IF(.NOT.LASTIN)THEN 240 - * Determine the re-entrance side and coordinate. 241 - IF(ONLINE(FRXMIN,FRYMIN,FRXMAX,FRYMIN,X0,Y0))THEN 242 - IIN=1 243 - QIN=X0-FRXMIN 244 - ELSEIF(ONLINE(FRXMAX,FRYMIN,FRXMAX,FRYMAX,X0,Y0))THEN 245 - IIN=2 246 - QIN=Y0-FRYMIN 247 - ELSEIF(ONLINE(FRXMAX,FRYMAX,FRXMIN,FRYMAX,X0,Y0))THEN 248 - IIN=3 249 - QIN=FRXMAX-X0 250 - ELSEIF(ONLINE(FRXMIN,FRYMAX,FRXMIN,FRYMIN,X0,Y0))THEN 251 - IIN=4 252 - QIN=FRYMAX-Y0 253 - ELSE 254 - PRINT *,' !!!!!! GRAREA WARNING : No re-entrance'// 255 - - ' edge found ; polygon not drawn.' 256 - GOTO 3030 257 - ENDIF 258 - * Debugging output. 259 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 260 - - ''Box entered via edge '',I1,'', Q='',E12.5)') 261 - - IIN,QIN 262 - * If this is the first segment, simply record it. 263 - IF(II.EQ.ISTART)THEN 264 - IFIRST=IIN 265 - QFIRST=QIN 266 - XFIRST=X0 267 - YFIRST=Y0 268 - * Skip in case we re-enter at the point where we left. 269 - ELSEIF(IIN.NE.IOUT.OR. 270 - - ((IIN.EQ.1.OR.IIN.EQ.3).AND.ABS(QIN-QOUT).GT.EPSX).OR. 271 - - ((IIN.EQ.2.OR.IIN.EQ.4).AND.ABS(QIN-QOUT).GT.EPSY))THEN 272 - * Add the re-entry point and complete the loop with the leaving point. 273 - IF(NOUT.GE.MXLIST)GOTO 3010 1 127 P=GRAPHICS D=GRAREA 4 PAGE 199 274 - NOUT=NOUT+1 275 - XOUT(NOUT)=X0 276 - YOUT(NOUT)=Y0 277 - IF(NOUT.GE.MXLIST)GOTO 3010 278 - NOUT=NOUT+1 279 - XOUT(NOUT)=XOUT(1) 280 - YOUT(NOUT)=YOUT(1) 281 - * Reduce the list of "out" points. 282 - CALL GRARED(NOUT,XOUT,YOUT) 283 - IF(NOUT.LE.2)THEN 284 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Number of "out"'', 285 - - '' points reduced to '',I3,'' - not adding'', 286 - - '' corners.'')') NOUT 287 - IF(NOUT.GE.1)THEN 288 - IF(NPL.GE.MXLIST)GOTO 3020 289 - NPL=NPL+1 290 - XPL(NPL)=XOUT(1) 291 - YPL(NPL)=YOUT(1) 292 - ENDIF 293 - IF(NOUT.GE.2)THEN 294 - IF(NPL.GE.MXLIST)GOTO 3020 295 - NPL=NPL+1 296 - XPL(NPL)=XOUT(2) 297 - YPL(NPL)=YOUT(2) 298 - ENDIF 299 - GOTO 310 300 - ENDIF 301 - * Find the corners that are located inside the curve. 302 - CALL INTERN(NOUT,XOUT,YOUT,FRXMIN,FRYMIN,IN1,EDGE1) 303 - CALL INTERN(NOUT,XOUT,YOUT,FRXMAX,FRYMIN,IN2,EDGE2) 304 - CALL INTERN(NOUT,XOUT,YOUT,FRXMAX,FRYMAX,IN3,EDGE3) 305 - CALL INTERN(NOUT,XOUT,YOUT,FRXMIN,FRYMAX,IN4,EDGE4) 306 - ADD(1)=IN1.OR.EDGE1 307 - ADD(2)=IN2.OR.EDGE2 308 - ADD(3)=IN3.OR.EDGE3 309 - ADD(4)=IN4.OR.EDGE4 310 - * Count corners in the positive direction. 311 - IF(IOUT.LT.IIN.OR.(IOUT.EQ.IIN.AND.QOUT.LE.QIN))THEN 312 - IMAX=IIN 313 - ELSE 314 - IMAX=IIN+4 315 - ENDIF 316 - NTOTP=0 317 - NINP=0 318 - DO 120 J=IOUT+1,IMAX 319 - NTOTP=NTOTP+1 320 - IF(ADD(1+MOD(J-1,4)))NINP=NINP+1 321 - 120 CONTINUE 322 - * Count corners in the negative direction. 323 - IF(IOUT.GT.IIN.OR.(IOUT.EQ.IIN.AND.QOUT.GT.QIN))THEN 324 - IMAX=IOUT 325 - ELSE 326 - IMAX=IOUT+4 327 - ENDIF 328 - NTOTM=0 329 - NINM=0 330 - DO 130 J=IMAX,IIN+1,-1 331 - NTOTM=NTOTM+1 332 - IF(ADD(1+MOD(J-1,4)))NINM=NINM+1 333 - 130 CONTINUE 334 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 335 - - ''"out" Buffer contains '',I3,'' points''/ 336 - - 26X,''In/Edge flags: 1: '',2L1,'', 2: '',2L1, 337 - - '', 3: '',2L1,'', 4: '',2L1/ 338 - - 26X,''Corner counts: +: '',I3,''/'',I3, 339 - - '', -: '',I3,''/'',I3)') 340 - - NOUT,IN1,EDGE1,IN2,EDGE2,IN3,EDGE3,IN4,EDGE4, 341 - - NINP,NTOTP,NINM,NTOTM 342 - * Add the corners that are located inside the curve. 343 - IF(NTOTP+NTOTM.NE.4)THEN 344 - PRINT *,' !!!!!! GRAREA WARNING : Error'// 345 - - ' counting corners ; polygon not drawn.' 346 - IF(LGSTOP)THEN 347 - OPEN(UNIT=12,FILE='grarea.dat', 348 - - STATUS='UNKNOWN') 349 - WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG 350 - WRITE(12,*) FRXMIN,FRYMIN,FRXMAX,FRYMAX 351 - WRITE(12,*) NIN 352 - DO 210 J=1,NIN 353 - WRITE(12,*) XIN(J),YIN(J) 354 - 210 CONTINUE 355 - CLOSE(12) 356 - CALL QUIT 357 - ENDIF 358 - GOTO 3030 359 - ELSEIF(NINP.GT.0.AND.NINP.EQ.NTOTP.AND.NINM.EQ.0)THEN 360 - IF(IOUT.LT.IIN.OR.(IOUT.EQ.IIN.AND. 361 - - QOUT.LE.QIN))THEN 362 - IMAX=IIN 363 - ELSE 364 - IMAX=IIN+4 365 - ENDIF 366 - DO 140 J=IOUT+1,IMAX 367 - IF(1+MOD(J-1,4).EQ.1)THEN 368 - IF(NPL.GE.MXLIST)GOTO 3020 369 - NPL=NPL+1 370 - XPL(NPL)=FRXMIN 371 - YPL(NPL)=FRYMIN 372 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 373 - - ''Added corner 1 in + sense.'')') 374 - ELSEIF(1+MOD(J-1,4).EQ.2)THEN 375 - IF(NPL.GE.MXLIST)GOTO 3020 376 - NPL=NPL+1 377 - XPL(NPL)=FRXMAX 378 - YPL(NPL)=FRYMIN 379 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 1 127 P=GRAPHICS D=GRAREA 5 PAGE 200 380 - - ''Added corner 2 in + sense.'')') 381 - ELSEIF(1+MOD(J-1,4).EQ.3)THEN 382 - IF(NPL.GE.MXLIST)GOTO 3020 383 - NPL=NPL+1 384 - XPL(NPL)=FRXMAX 385 - YPL(NPL)=FRYMAX 386 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 387 - - ''Added corner 3 in + sense.'')') 388 - ELSE 389 - IF(NPL.GE.MXLIST)GOTO 3020 390 - NPL=NPL+1 391 - XPL(NPL)=FRXMIN 392 - YPL(NPL)=FRYMAX 393 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 394 - - ''Added corner 4 in + sense.'')') 395 - ENDIF 396 - 140 CONTINUE 397 - ELSEIF(NINM.GT.0.AND.NINM.EQ.NTOTM.AND.NINP.EQ.0)THEN 398 - IF(IOUT.GT.IIN.OR.(IOUT.EQ.IIN.AND. 399 - - QOUT.GT.QIN))THEN 400 - IMAX=IOUT 401 - ELSE 402 - IMAX=IOUT+4 403 - ENDIF 404 - DO 150 J=IMAX,IIN+1,-1 405 - IF(1+MOD(J-1,4).EQ.1)THEN 406 - IF(NPL.GE.MXLIST)GOTO 3020 407 - NPL=NPL+1 408 - XPL(NPL)=FRXMIN 409 - YPL(NPL)=FRYMIN 410 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 411 - - ''Added corner 1 in - sense.'')') 412 - ELSEIF(1+MOD(J-1,4).EQ.2)THEN 413 - IF(NPL.GE.MXLIST)GOTO 3020 414 - NPL=NPL+1 415 - XPL(NPL)=FRXMAX 416 - YPL(NPL)=FRYMIN 417 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 418 - - ''Added corner 2 in - sense.'')') 419 - ELSEIF(1+MOD(J-1,4).EQ.3)THEN 420 - IF(NPL.GE.MXLIST)GOTO 3020 421 - NPL=NPL+1 422 - XPL(NPL)=FRXMAX 423 - YPL(NPL)=FRYMAX 424 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 425 - - ''Added corner 3 in - sense.'')') 426 - ELSE 427 - IF(NPL.GE.MXLIST)GOTO 3020 428 - NPL=NPL+1 429 - XPL(NPL)=FRXMIN 430 - YPL(NPL)=FRYMAX 431 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 432 - - ''Added corner 4 in - sense.'')') 433 - ENDIF 434 - 150 CONTINUE 435 - ELSEIF(NINM.NE.0.OR.NINP.NE.0)THEN 436 - PRINT *,' !!!!!! GRAREA WARNING : Error'// 437 - - ' deciding direction ; polygon not drawn.' 438 - IF(LGSTOP)THEN 439 - OPEN(UNIT=12,FILE='grarea.dat', 440 - - STATUS='UNKNOWN') 441 - WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG 442 - WRITE(12,*) FRXMIN,FRYMIN,FRXMAX,FRYMAX 443 - WRITE(12,*) NIN 444 - DO 220 J=1,NIN 445 - WRITE(12,*) XIN(J),YIN(J) 446 - 220 CONTINUE 447 - CLOSE(12) 448 - CALL QUIT 449 - ENDIF 450 - GOTO 3030 451 - ENDIF 452 - * Resume here if there was no real loop outside. 453 - 310 CONTINUE 454 - * Reset the out buffer. 455 - NOUT=0 456 - * In other cases, still reset the buffer. 457 - ELSE 458 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Corner search skipped'', 459 - - '', "in" and "out" coincide.'')') 460 - NOUT=0 461 - ENDIF 462 - * Add the re-entrance point to the "plot" buffer. 463 - IF(NPL.GE.MXLIST)GOTO 3020 464 - NPL=NPL+1 465 - XPL(NPL)=X0 466 - YPL(NPL)=Y0 467 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 468 - - ''Added first point to "plot" buffer as '',I3)') NPL 469 - ENDIF 470 - ** Add the end point of the segment to the plot buffer. 471 - IF(NPL.GE.MXLIST)GOTO 3020 472 - NPL=NPL+1 473 - XPL(NPL)=X1 474 - YPL(NPL)=Y1 475 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 476 - - ''Added last point to "plot" buffer as '',I3)') NPL 477 - ** We leave the box. 478 - IF(.NOT.CURIN)THEN 479 - * Determine the leaving side and coordinate. 480 - IF(ONLINE(FRXMIN,FRYMIN,FRXMAX,FRYMIN,X1,Y1))THEN 481 - IOUT=1 482 - QOUT=X1-FRXMIN 483 - ELSEIF(ONLINE(FRXMAX,FRYMIN,FRXMAX,FRYMAX,X1,Y1))THEN 484 - IOUT=2 485 - QOUT=Y1-FRYMIN 1 127 P=GRAPHICS D=GRAREA 6 PAGE 201 486 - ELSEIF(ONLINE(FRXMAX,FRYMAX,FRXMIN,FRYMAX,X1,Y1))THEN 487 - IOUT=3 488 - QOUT=FRXMAX-X1 489 - ELSEIF(ONLINE(FRXMIN,FRYMAX,FRXMIN,FRYMIN,X1,Y1))THEN 490 - IOUT=4 491 - QOUT=FRYMAX-Y1 492 - ELSE 493 - PRINT *,' !!!!!! GRAREA WARNING : No leaving'// 494 - - ' edge found ; polygon not drawn.' 495 - GOTO 3030 496 - ENDIF 497 - * Start a list of "out" points. 498 - NOUT=1 499 - XOUT(NOUT)=X1 500 - YOUT(NOUT)=Y1 501 - * Also add the point located outside. 502 - IF(NOUT.GE.MXLIST)GOTO 3010 503 - NOUT=NOUT+1 504 - XOUT(NOUT)=XCUR 505 - YOUT(NOUT)=YCUR 506 - * Debugging output. 507 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 508 - - ''Box is left via edge '',I1,'', Q='',E12.5, 509 - - '', "out" list started, point added as 2.'')') 510 - - IOUT,QOUT 511 - ENDIF 512 - ** Shift "current" to "last". 513 - 110 CONTINUE 514 - XLAST=XCUR 515 - YLAST=YCUR 516 - LASTIN=CURIN 517 - 100 CONTINUE 518 - *** End of the list of points, check whether the first point was "out". 519 - IF(IFIRST.NE.0.AND. 520 - - (IFIRST.NE.IOUT.OR. 521 - - ((IFIRST.EQ.1.OR.IFIRST.EQ.3).AND. 522 - - ABS(QFIRST-QOUT).GT.EPSX).OR. 523 - - ((IFIRST.EQ.2.OR.IFIRST.EQ.4).AND. 524 - - ABS(QFIRST-QOUT).GT.EPSY)))THEN 525 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Finishing loop, first'', 526 - - '' segment entered over edge '',I2,'' at Q='',E12.5)') 527 - - IFIRST,QFIRST 528 - * Make sure there is an "out" buffer already. 529 - IF(NOUT.EQ.0)THEN 530 - PRINT *,' !!!!!! GRAREA WARNING : "out" Buffer'// 531 - - ' unexpectedly found empty ; not plotted.' 532 - GOTO 3030 533 - ENDIF 534 - * Add the first point to the "out" buffer. 535 - IF(NOUT.GE.MXLIST)GOTO 3010 536 - NOUT=NOUT+1 537 - XOUT(NOUT)=XFIRST 538 - YOUT(NOUT)=YFIRST 539 - * Restore the entrance edge and offset. 540 - IIN=IFIRST 541 - QIN=QFIRST 542 - * Close the loop with the first point. 543 - IF(NOUT.GE.MXLIST)GOTO 3010 544 - NOUT=NOUT+1 545 - XOUT(NOUT)=XOUT(1) 546 - YOUT(NOUT)=YOUT(1) 547 - * Reduce the list of "out" points. 548 - CALL GRARED(NOUT,XOUT,YOUT) 549 - IF(NOUT.LE.2)THEN 550 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Number of "out"'', 551 - - '' points reduced to '',I3,'' - not adding'', 552 - - '' corners.'')') NOUT 553 - IF(NOUT.GE.1)THEN 554 - IF(NPL.GE.MXLIST)GOTO 3020 555 - NPL=NPL+1 556 - XPL(NPL)=XOUT(1) 557 - YPL(NPL)=YOUT(1) 558 - ENDIF 559 - IF(NOUT.GE.2)THEN 560 - IF(NPL.GE.MXLIST)GOTO 3020 561 - NPL=NPL+1 562 - XPL(NPL)=XOUT(2) 563 - YPL(NPL)=YOUT(2) 564 - ENDIF 565 - GOTO 300 566 - ENDIF 567 - * Find the corners that are located inside the curve. 568 - CALL INTERN(NOUT,XOUT,YOUT,FRXMIN,FRYMIN,IN1,EDGE1) 569 - CALL INTERN(NOUT,XOUT,YOUT,FRXMAX,FRYMIN,IN2,EDGE2) 570 - CALL INTERN(NOUT,XOUT,YOUT,FRXMAX,FRYMAX,IN3,EDGE3) 571 - CALL INTERN(NOUT,XOUT,YOUT,FRXMIN,FRYMAX,IN4,EDGE4) 572 - ADD(1)=IN1.OR.EDGE1 573 - ADD(2)=IN2.OR.EDGE2 574 - ADD(3)=IN3.OR.EDGE3 575 - ADD(4)=IN4.OR.EDGE4 576 - * Count corners in the positive direction. 577 - IF(IOUT.LT.IIN.OR.(IOUT.EQ.IIN.AND.QOUT.LE.QIN))THEN 578 - IMAX=IIN 579 - ELSE 580 - IMAX=IIN+4 581 - ENDIF 582 - NTOTP=0 583 - NINP=0 584 - DO 160 J=IOUT+1,IMAX 585 - NTOTP=NTOTP+1 586 - IF(ADD(1+MOD(J-1,4)))NINP=NINP+1 587 - 160 CONTINUE 588 - * Count corners in the negative direction. 589 - IF(IOUT.GT.IIN.OR.(IOUT.EQ.IIN.AND.QOUT.GT.QIN))THEN 590 - IMAX=IOUT 591 - ELSE 1 127 P=GRAPHICS D=GRAREA 7 PAGE 202 592 - IMAX=IOUT+4 593 - ENDIF 594 - NTOTM=0 595 - NINM=0 596 - DO 170 J=IMAX,IIN+1,-1 597 - NTOTM=NTOTM+1 598 - IF(ADD(1+MOD(J-1,4)))NINM=NINM+1 599 - 170 CONTINUE 600 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 601 - - ''"out" Buffer contains '',I3,'' points''/ 602 - - 26X,''In/Edge flags: 1: '',2L1,'', 2: '',2L1, 603 - - '', 3: '',2L1,'', 4: '',2L1/ 604 - - 26X,''Corner counts: +: '',I3,''/'',I3, 605 - - '', -: '',I3,''/'',I3)') 606 - - NOUT,IN1,EDGE1,IN2,EDGE2,IN3,EDGE3,IN4,EDGE4, 607 - - NINP,NTOTP,NINM,NTOTM 608 - * Add the corners that are located inside the curve. 609 - IF(NTOTP+NTOTM.NE.4)THEN 610 - PRINT *,' !!!!!! GRAREA WARNING : Error'// 611 - - ' counting corners ; polygon not drawn.' 612 - GOTO 3030 613 - ELSEIF(NINP.GT.0.AND.NINP.EQ.NTOTP.AND.NINM.EQ.0)THEN 614 - IF(IOUT.LT.IIN.OR.(IOUT.EQ.IIN.AND. 615 - - QOUT.LE.QIN))THEN 616 - IMAX=IIN 617 - ELSE 618 - IMAX=IIN+4 619 - ENDIF 620 - DO 180 J=IOUT+1,IMAX 621 - IF(1+MOD(J-1,4).EQ.1)THEN 622 - IF(NPL.GE.MXLIST)GOTO 3020 623 - NPL=NPL+1 624 - XPL(NPL)=FRXMIN 625 - YPL(NPL)=FRYMIN 626 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 627 - - ''Added corner 1 in + sense.'')') 628 - ELSEIF(1+MOD(J-1,4).EQ.2)THEN 629 - IF(NPL.GE.MXLIST)GOTO 3020 630 - NPL=NPL+1 631 - XPL(NPL)=FRXMAX 632 - YPL(NPL)=FRYMIN 633 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 634 - - ''Added corner 2 in + sense.'')') 635 - ELSEIF(1+MOD(J-1,4).EQ.3)THEN 636 - IF(NPL.GE.MXLIST)GOTO 3020 637 - NPL=NPL+1 638 - XPL(NPL)=FRXMAX 639 - YPL(NPL)=FRYMAX 640 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 641 - - ''Added corner 3 in + sense.'')') 642 - ELSE 643 - IF(NPL.GE.MXLIST)GOTO 3020 644 - NPL=NPL+1 645 - XPL(NPL)=FRXMIN 646 - YPL(NPL)=FRYMAX 647 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 648 - - ''Added corner 4 in + sense.'')') 649 - ENDIF 650 - 180 CONTINUE 651 - ELSEIF(NINM.GT.0.AND.NINM.EQ.NTOTM.AND.NINP.EQ.0)THEN 652 - IF(IOUT.GT.IIN.OR.(IOUT.EQ.IIN.AND. 653 - - QOUT.GT.QIN))THEN 654 - IMAX=IOUT 655 - ELSE 656 - IMAX=IOUT+4 657 - ENDIF 658 - DO 190 J=IMAX,IIN+1,-1 659 - IF(1+MOD(J-1,4).EQ.1)THEN 660 - IF(NPL.GE.MXLIST)GOTO 3020 661 - NPL=NPL+1 662 - XPL(NPL)=FRXMIN 663 - YPL(NPL)=FRYMIN 664 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 665 - - ''Added corner 1 in - sense.'')') 666 - ELSEIF(1+MOD(J-1,4).EQ.2)THEN 667 - IF(NPL.GE.MXLIST)GOTO 3020 668 - NPL=NPL+1 669 - XPL(NPL)=FRXMAX 670 - YPL(NPL)=FRYMIN 671 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 672 - - ''Added corner 2 in - sense.'')') 673 - ELSEIF(1+MOD(J-1,4).EQ.3)THEN 674 - IF(NPL.GE.MXLIST)GOTO 3020 675 - NPL=NPL+1 676 - XPL(NPL)=FRXMAX 677 - YPL(NPL)=FRYMAX 678 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 679 - - ''Added corner 3 in - sense.'')') 680 - ELSE 681 - IF(NPL.GE.MXLIST)GOTO 3020 682 - NPL=NPL+1 683 - XPL(NPL)=FRXMIN 684 - YPL(NPL)=FRYMAX 685 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 686 - - ''Added corner 4 in - sense.'')') 687 - ENDIF 688 - 190 CONTINUE 689 - ELSEIF(NINM.NE.0.OR.NINP.NE.0)THEN 690 - PRINT *,' !!!!!! GRAREA WARNING : Error'// 691 - - ' deciding direction ; polygon not drawn.' 692 - IF(LGSTOP)THEN 693 - OPEN(UNIT=12,FILE='grarea.dat',STATUS='UNKNOWN') 694 - WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG 695 - WRITE(12,*) FRXMIN,FRYMIN,FRXMAX,FRYMAX 696 - WRITE(12,*) NIN 697 - DO 230 J=1,NIN 1 127 P=GRAPHICS D=GRAREA 8 PAGE 203 698 - WRITE(12,*) XIN(J),YIN(J) 699 - 230 CONTINUE 700 - CLOSE(12) 701 - CALL QUIT 702 - ENDIF 703 - GOTO 3030 704 - ENDIF 705 - ENDIF 706 - *** And plot the buffer. 707 - 300 CONTINUE 708 - IF(NPL.GT.2)CALL GFA(NPL,XPL,YPL) 709 - GOTO 3030 710 - *** Buffer overflows. 711 - 3010 CONTINUE 712 - PRINT *,' !!!!!! GRAREA WARNING : Overflow of "out" buffer;'// 713 - - ' polygon not plotted.' 714 - GOTO 3030 715 - 3020 CONTINUE 716 - PRINT *,' !!!!!! GRAREA WARNING : Overflow of "plot" buffer;'// 717 - - ' polygon not plotted.' 718 - GOTO 3030 719 - *** Termination. 720 - 3030 CONTINUE 721 - IF(RESET)CALL EPSSET('RESET',0.0D0,0.0D0,0.0D0) 722 - END 128 GARFIELD ================================================== P=GRAPHICS D=GRARED 1 ============================ 0 + +DECK,GRARED. 1 - SUBROUTINE GRARED(NPL,XPL,YPL) 2 - *----------------------------------------------------------------------- 3 - * GRARED - Removes duplicate branches from a curve. 4 - * (Last changed on 2/ 2/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9 - INTEGER NPL,I,J,NNEW,JCUT 10 - REAL XPL(NPL),YPL(NPL),EPSX,EPSY,XMIN,YMIN,XMAX,YMAX 11 - LOGICAL MARK(MXLIST),ONLINE 12 - EXTERNAL ONLINE 13 - *** Check number of points. 14 - IF(NPL.GT.MXLIST)THEN 15 - PRINT *,' !!!!!! GRARED WARNING : Too many points.' 16 - RETURN 17 - ELSEIF(NPL.LT.3)THEN 18 - RETURN 19 - ENDIF 20 - *** Set tolerances. 21 - IF(LEPSG)THEN 22 - EPSX=EPSGX 23 - EPSY=EPSGY 24 - ELSE 25 - * Compute range. 26 - XMIN=XPL(1) 27 - XMAX=XPL(1) 28 - YMIN=YPL(1) 29 - YMAX=YPL(1) 30 - DO 90 I=2,NPL 31 - XMIN=MIN(XMIN,XPL(I)) 32 - XMAX=MAX(XMAX,XPL(I)) 33 - YMIN=MIN(YMIN,YPL(I)) 34 - YMAX=MAX(YMAX,YPL(I)) 35 - 90 CONTINUE 36 - * Set epsilons accordingly. 37 - EPSX=1.0E-4*ABS(XMAX-XMIN) 38 - EPSY=1.0E-4*ABS(YMAX-YMIN) 39 - IF(EPSX.LE.0)EPSX=1.0E-4 40 - IF(EPSY.LE.0)EPSY=1.0E-4 41 - ENDIF 42 - *** Make a first marker list. 43 - 100 CONTINUE 44 - DO 10 I=1,NPL 45 - MARK(I)=.FALSE. 46 - 10 CONTINUE 47 - *** Find a point that is surrounded on both side by equal points. 48 - DO 20 I=1,NPL 49 - JCUT=0 50 - DO 30 J=1,NPL/2 51 - IF( ABS(XPL(1+MOD(I+J-1 ,NPL))- 52 - - XPL(1+MOD(I-J-1+NPL,NPL))).GT.EPSX.OR. 53 - - ABS(YPL(1+MOD(I+J-1 ,NPL))- 54 - - YPL(1+MOD(I-J-1+NPL,NPL))).GT.EPSY)GOTO 40 55 - JCUT=J 56 - 30 CONTINUE 57 - 40 CONTINUE 58 - * See whether we found one. 59 - IF(JCUT.GT.0)THEN 60 - C print *,' Cutting a tail of ',JCUT,' points.' 61 - DO 70 J=I-JCUT+1,I+JCUT 62 - MARK(1+MOD(J-1+NPL,NPL))=.TRUE. 63 - 70 CONTINUE 64 - GOTO 50 65 - ENDIF 66 - 20 CONTINUE 67 - *** See whether there are partial returns. 68 - DO 80 I=1,NPL 69 - IF(ONLINE( 70 - - XPL(1+MOD(I-1 ,NPL)),YPL(1+MOD(I-1 ,NPL)), 71 - - XPL(1+MOD(I ,NPL)),YPL(1+MOD(I ,NPL)), 72 - - XPL(1+MOD(I-2+NPL,NPL)),YPL(1+MOD(I-2+NPL,NPL))).OR. 73 - - ONLINE( 74 - - XPL(1+MOD(I-1 ,NPL)),YPL(1+MOD(I-1 ,NPL)), 75 - - XPL(1+MOD(I-2+NPL,NPL)),YPL(1+MOD(I-2+NPL,NPL)), 76 - - XPL(1+MOD(I ,NPL)),YPL(1+MOD(I ,NPL))))THEN 77 - MARK(1+MOD(I-1 ,NPL))=.TRUE. 1 128 P=GRAPHICS D=GRARED 2 PAGE 204 78 - C print *,' Cutting a partial return.' 79 - GOTO 50 80 - ENDIF 81 - 80 CONTINUE 82 - RETURN 83 - *** Eliminate the piece. 84 - 50 CONTINUE 85 - NNEW=0 86 - DO 60 I=1,NPL 87 - IF(MARK(I))GOTO 60 88 - NNEW=NNEW+1 89 - XPL(NNEW)=XPL(I) 90 - YPL(NNEW)=YPL(I) 91 - 60 CONTINUE 92 - NPL=NNEW 93 - GOTO 100 94 - END 129 GARFIELD ================================================== P=GRAPHICS D=GRATTR 1 ============================ 0 + +DECK,GRATTR. 1 - SUBROUTINE GRATTR(IKEY,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GRATTR - Updates the attribute list for the various sorts of output. 4 - * (Last changed on 30/11/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GRAPHICS. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*(MXINCH) STRING 11 - CHARACTER*(MXNAME) FILE 12 - CHARACTER*29 REMARK 13 - CHARACTER*8 TIME,DATE,MEMBER 14 - CHARACTER*80 AUX,AUX1,AUX2 15 - CHARACTER*(*) ITEM,TYPE 16 - LOGICAL POLYL,POLYM,TEXT,AREA,EXIS,DSNCMP,EXMEMB 17 - INTEGER INPTYP,INPCMP,INPCMX,IKEY,IFAIL,IFAIL1,IFAIL2,I,IWKID, 18 - - INEXT,NWORD,NCSTR,NITEM,NSEEN,NUPDAT,NC,NCMEMB,NCFILE,NCREM, 19 - - IOS,NC1,NC2 20 - EXTERNAL INPTYP,INPCMP,INPCMX,DSNCMP 21 - *** Buffer declarations, first the sizes. 22 - INTEGER MXPLBU,MXPMBU,MXTXBU,MXFABU 23 - PARAMETER(MXPLBU=40,MXPMBU=40,MXTXBU=40,MXFABU=40) 24 - * PolyLine attributes. 25 - REAL LINWID(MXPLBU),LWR 26 - INTEGER LINTYP(MXPLBU),LINCOL(MXPLBU),LTR,LCR,NLIN 27 - CHARACTER*20 LINNAM(MXPLBU) 28 - * PolyMarker attributes. 29 - REAL MRKSIZ(MXPMBU),MSR 30 - INTEGER MRKTYP(MXPMBU),MRKCOL(MXPMBU),MTR,MCR,NMRK 31 - CHARACTER*20 MRKNAM(MXPMBU) 32 - * Text attributes. 33 - REAL TXTEXP(MXTXBU),TXTSPA(MXTXBU),TXTHGT(MXTXBU),TER,TSR,THR 34 - INTEGER TXTFNT(MXTXBU),TXTPRC(MXTXBU),TXTCOL(MXTXBU),TFR,TPR,TCR, 35 - - NTXT 36 - CHARACTER*20 TXTNAM(MXTXBU) 37 - * Fill Area attributes. 38 - REAL FARPAS(2,MXFABU),FARREF(2,MXFABU),FPXR,FPYR,FRXR,FRYR 39 - INTEGER FARINT(MXFABU),FARSTY(MXFABU),FARCOL(MXFABU),FIR,FSR,FCR, 40 - - NFAR 41 - CHARACTER*20 FARNAM(MXFABU) 0 42-+ +SELF,IF=SAVE. 43 - * Ensure the contents is kept across routine calls. 44 - SAVE NLIN,LINNAM,LINWID,LINTYP,LINCOL, 45 - - NMRK,MRKNAM,MRKSIZ,MRKTYP,MRKCOL, 46 - - NTXT,TXTNAM,TXTEXP,TXTSPA,TXTHGT,TXTFNT,TXTPRC,TXTCOL, 47 - - NFAR,FARNAM,FARPAS,FARREF,FARINT,FARSTY,FARCOL 0 48-+ +SELF. 49 - *** Initial values for the attributes, start with polyline. 50 - DATA NLIN /35/ 51 - DATA (LINNAM(I),LINWID(I),LINTYP(I),LINCOL(I),I=1,35) / 52 - - 'BOX-#TICKMARKS ', 1.00, 1, 1, 53 - - 'COM#MENT ', 1.00, 2, 1, 54 - - 'CON#TOUR-HIGH#LIGHT ', 1.00, 1, 1, 55 - - 'CON#TOUR-NORM#AL ', 1.00, 1, 1, 56 - - 'ISO#CHRONES ', 1.00, 2, 1, 57 - - 'DR#IFT-L#INE ', 1.00, 1, 1, 58 - - 'E-DR#IFT-L#INE ', 1.00, 1, 1, 59 - - 'ION-DR#IFT-L#INE ', 1.00, 1, 1, 60 - - 'F#UNCTION-1 ', 1.00, 1, 1, 61 - - 'F#UNCTION-2 ', 1.00, 2, 1, 62 - - 'F#UNCTION-3 ', 1.00, 3, 1, 63 - - 'F#UNCTION-4 ', 1.00, 4, 1, 64 - - 'F#UNCTION-5 ', 1.00, 1, 1, 65 - - 'F#UNCTION-6 ', 1.00, 2, 1, 66 - - 'F#UNCTION-7 ', 1.00, 3, 1, 67 - - 'GR#ID ', 1.00, 3, 1, 68 - - 'PL#ANES ', 1.00, 1, 1, 69 - - 'STR#IPS ', 3.00, 1, 1, 70 - - 'TUBE ', 1.00, 1, 1, 71 - - 'TR#ACK ', 1.00, 2, 1, 72 - - 'PHOTON ', 1.00, 3, 1, 73 - - 'DELTA-#ELECTRON ', 1.00, 2, 1, 74 - - 'AUGER-#ELECTRON ', 1.00, 2, 1, 75 - - 'SOLID ', 1.00, 1, 1, 76 - - 'FAT2 ', 2.00, 1, 1, 77 - - 'FAT3 ', 3.00, 1, 1, 78 - - 'FAT4 ', 4.00, 1, 1, 79 - - 'FAT5 ', 5.00, 1, 1, 80 - - 'FAT6 ', 6.00, 1, 1, 81 - - 'DASH#ED ', 1.00, 2, 1, 82 - - 'DOT#TED ', 1.00, 3, 1, 83 - - 'DASH-DOT#TED ', 1.00, 4, 1, 1 129 P=GRAPHICS D=GRATTR 2 PAGE 205 84 - - 'ERR#OR-BAR ', 1.00, 1, 1, 85 - - 'ERR#OR-BAND ', 1.00, 1, 1, 86 - - 'OUT#LINE ', 1.00, 1, 1/ 87 - * Next the polymarkers. 88 - DATA NMRK /21/ 89 - DATA (MRKNAM(I),MRKSIZ(I),MRKTYP(I),MRKCOL(I),I=1,21) / 90 - - 'S-WIRE ', 1.00, 4, 1, 91 - - 'P-WIRE ', 1.00, 5, 1, 92 - - 'C-WIRE ', 1.00, 2, 1, 93 - - 'OTH#ER-WIRE ', 1.00, 3, 1, 94 - - 'ISO#CHRONES ', 1.00, 3, 1, 95 - - 'F#UNCTION-1 ', 1.00, 3, 1, 96 - - 'F#UNCTION-2 ', 1.00, 4, 1, 97 - - 'F#UNCTION-3 ', 1.00, 2, 1, 98 - - 'F#UNCTION-4 ', 1.00, 1, 1, 99 - - 'F#UNCTION-5 ', 1.00, 3, 1, 100 - - 'F#UNCTION-6 ', 1.00, 4, 1, 101 - - 'F#UNCTION-7 ', 1.00, 2, 1, 102 - - 'TR#ACK ', 1.00, 3, 1, 103 - - 'PHOTON ', 1.00, 3, 1, 104 - - 'DELTA-#ELECTRON ', 0.25, 4, 1, 105 - - 'AUGER-#ELECTRON ', 0.25, 2, 1, 106 - - 'DOT ', 1.00, 1, 1, 107 - - 'PLUS ', 1.00, 2, 1, 108 - - 'AST#ERISK ', 1.00, 3, 1, 109 - - 'CIRC#LE ', 1.00, 4, 1, 110 - - 'CR#OSS ', 1.00, 5, 1/ 111 - * Next the text. 0 112-+ +SELF,IF=GTSGRAL. 113 - DATA NTXT /22/ 114 - DATA (TXTNAM(I),TXTEXP(I),TXTSPA(I),TXTHGT(I),TXTFNT(I), 115 - - TXTPRC(I),TXTCOL(I),I=1,22) / 116 - - 'COM#MENT ', 1.00, 0.00, 0.013, 1, 1, 1, 117 - - 'CONT#OUR-#LABELS ', 1.00, 0.00, 0.010, 1, 1, 1, 118 - - 'LAB#ELS ', 1.00, 0.00, 0.025, 1, 1, 1, 119 - - 'F#UNCTION-1 ', 1.00, 0.00, 0.025, 1, 1, 1, 120 - - 'F#UNCTION-2 ', 1.00, 0.00, 0.025, 1, 1, 1, 121 - - 'F#UNCTION-3 ', 1.00, 0.00, 0.025, 1, 1, 1, 122 - - 'F#UNCTION-4 ', 1.00, 0.00, 0.025, 1, 1, 1, 123 - - 'F#UNCTION-5 ', 1.00, 0.00, 0.025, 1, 1, 1, 124 - - 'F#UNCTION-6 ', 1.00, 0.00, 0.025, 1, 1, 1, 125 - - 'F#UNCTION-7 ', 1.00, 0.00, 0.025, 1, 1, 1, 126 - - 'MES#SAGE ', 1.00, 0.00, 0.010, 1, 1, 1, 127 - - 'NUM#BERS ', 1.00, 0.00, 0.015, 1, 1, 1, 128 - - 'TIT#LE ', 1.00, 0.00, 0.025, 1, 1, 1, 129 - - 'PR#ESTIGE ', 1.00, 0.00, 0.020, -2, 2, 1, 130 - - 'BIG ', 1.00, 0.00, 0.020, -3, 2, 1, 131 - - 'SM#ALL ', 1.00, 0.00, 0.020, -3, 2, 1, 132 - - 'TIMES-ROM#AN ', 1.00, 0.00, 0.020, -3, 2, 1, 133 - - 'TIMES-IT#ALIC ', 1.00, 0.00, 0.020, -104, 2, 1, 134 - - 'GR#EEK ', 1.00, 0.00, 0.020, -13, 2, 1, 135 - - 'GR#EEK-IT#ALIC ', 1.00, 0.00, 0.020, -113, 2, 1, 136 - - 'GOTH#IC ', 1.00, 0.00, 0.020, -9, 2, 1, 137 - - 'GOTH#IC-IT#ALIC ', 1.00, 0.00, 0.020, -109, 2, 1/ 0 138-+ +SELF,IF=HIGZ. 139 - DATA NTXT /28/ 140 - DATA (TXTNAM(I),TXTEXP(I),TXTSPA(I),TXTHGT(I),TXTFNT(I), 141 - - TXTPRC(I),TXTCOL(I),I=1,28) / 142 - - 'COM#MENT ', 1.00, 0.00, 0.013, 0, 2, 1, 143 - - 'CONT#OUR-#LABELS ', 1.00, 0.00, 0.010, 0, 2, 1, 144 - - 'LAB#ELS ', 1.00, 0.00, 0.025, 0, 2, 1, 145 - - 'F#UNCTION-1 ', 1.00, 0.00, 0.025, 0, 2, 1, 146 - - 'F#UNCTION-2 ', 1.00, 0.00, 0.025, 0, 2, 1, 147 - - 'F#UNCTION-3 ', 1.00, 0.00, 0.025, 0, 2, 1, 148 - - 'F#UNCTION-4 ', 1.00, 0.00, 0.025, 0, 2, 1, 149 - - 'F#UNCTION-5 ', 1.00, 0.00, 0.025, 0, 2, 1, 150 - - 'F#UNCTION-6 ', 1.00, 0.00, 0.025, 0, 2, 1, 151 - - 'F#UNCTION-7 ', 1.00, 0.00, 0.025, 0, 2, 1, 152 - - 'MES#SAGE ', 1.00, 0.00, 0.010, 0, 2, 1, 153 - - 'NUM#BERS ', 1.00, 0.00, 0.015, 0, 2, 1, 154 - - 'TIT#LE ', 1.00, 0.00, 0.025, 0, 2, 1, 155 - - 'HIGZ-#SOFTWARE ', 1.00, 0.00, 0.020, 0, 2, 1, 156 - - 'TIM#ES-RO#MAN ', 1.00, 0.00, 0.020, -13, 2, 1, 157 - - 'TIM#ES-IT#ALIC ', 1.00, 0.00, 0.020, -1, 2, 1, 158 - - 'TIM#ES-BOLD-R#OMAN ', 1.00, 0.00, 0.020, -2, 2, 1, 159 - - 'TIM#ES-BOLD-I#TALIC ', 1.00, 0.00, 0.020, -3, 2, 1, 160 - - 'HELV#ETICA ', 1.00, 0.00, 0.020, -4, 2, 1, 161 - - 'HELV#ETICA-O#BLIQUE ', 1.00, 0.00, 0.020, -5, 2, 1, 162 - - 'HELV#ETICA-B#OLD ', 1.00, 0.00, 0.020, -6, 2, 1, 163 - - 'HELV#ETICA-B#OLD-O#B', 1.00, 0.00, 0.020, -7, 2, 1, 164 - - 'COUR#IER ', 1.00, 0.00, 0.020, -8, 2, 1, 165 - - 'COUR#IER-O#BLIQUE ', 1.00, 0.00, 0.020, -9, 2, 1, 166 - - 'COUR#IER-B#OLD ', 1.00, 0.00, 0.020, -10, 2, 1, 167 - - 'COUR#IER-B#OLD-O#BLI', 1.00, 0.00, 0.020, -11, 2, 1, 168 - - 'SYM#BOL ', 1.00, 0.00, 0.020, -12, 2, 1, 169 - - 'ZAPF#DINGBATS ', 1.00, 0.00, 0.020, -14, 2, 1/ 0 170-+ +SELF,IF=-HIGZ,IF=-GTSGRAL. 171 - DATA NTXT /13/ 172 - DATA (TXTNAM(I),TXTEXP(I),TXTSPA(I),TXTHGT(I),TXTFNT(I), 173 - - TXTPRC(I),TXTCOL(I),I=1,13) / 174 - - 'COM#MENT ', 1.00, 0.00, 0.013, 1, 1, 1, 175 - - 'CONT#OUR-#LABELS ', 1.00, 0.00, 0.010, 1, 1, 1, 176 - - 'LAB#ELS ', 1.00, 0.00, 0.025, 1, 1, 1, 177 - - 'F#UNCTION-1 ', 1.00, 0.00, 0.025, 1, 1, 1, 178 - - 'F#UNCTION-2 ', 1.00, 0.00, 0.025, 1, 1, 1, 179 - - 'F#UNCTION-3 ', 1.00, 0.00, 0.025, 1, 1, 1, 180 - - 'F#UNCTION-4 ', 1.00, 0.00, 0.025, 1, 1, 1, 181 - - 'F#UNCTION-5 ', 1.00, 0.00, 0.025, 1, 1, 1, 182 - - 'F#UNCTION-6 ', 1.00, 0.00, 0.025, 1, 1, 1, 183 - - 'F#UNCTION-7 ', 1.00, 0.00, 0.025, 1, 1, 1, 184 - - 'MES#SAGE ', 1.00, 0.00, 0.010, 1, 1, 1, 185 - - 'NUM#BERS ', 1.00, 0.00, 0.015, 1, 1, 1, 186 - - 'TIT#LE ', 1.00, 0.00, 0.025, 1, 1, 1/ 1 129 P=GRAPHICS D=GRATTR 3 PAGE 206 187-+ +SELF. 188 - * And finally the fill area. 189 - DATA NFAR /27/ 190 - DATA (FARNAM(I),FARPAS(1,I),FARPAS(2,I),FARREF(1,I),FARREF(2,I), 191 - - FARINT(I),FARSTY(I),FARCOL(I),I=1,27) / 0 192-+ +SELF,IF=GTSGRAL. 193 - - 'COND#UCTORS-1 ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, 194 - - 'COND#UCTORS-2 ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, 195 - - 'COND#UCTORS-3 ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, 196 - - 'DIEL#ECTRICA-1 ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, 197 - - 'DIEL#ECTRICA-2 ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, 198 - - 'DIEL#ECTRICA-3 ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, 199 - - 'OUT#SIDE-AREA ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, 200 - - 'PLA#NES ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, 201 - - 'STR#IPS ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, 202 - - 'TUBE ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, 0 203-+ +SELF,IF=HIGZ. 204 - - 'COND#UCTORS-1 ', 1.00, 1.00, 0.00, 0.00, 3, 354, 1, 205 - - 'COND#UCTORS-2 ', 1.00, 1.00, 0.00, 0.00, 3, 354, 1, 206 - - 'COND#UCTORS-3 ', 1.00, 1.00, 0.00, 0.00, 3, 354, 1, 207 - - 'DIEL#ECTRICA-1 ', 1.00, 1.00, 0.00, 0.00, 3, 345, 1, 208 - - 'DIEL#ECTRICA-2 ', 1.00, 1.00, 0.00, 0.00, 3, 345, 1, 209 - - 'DIEL#ECTRICA-3 ', 1.00, 1.00, 0.00, 0.00, 3, 345, 1, 210 - - 'OUT#SIDE-AREA ', 1.00, 1.00, 0.00, 0.00, 3, 305, 1, 211 - - 'PLA#NES ', 1.00, 1.00, 0.00, 0.00, 3, 354, 1, 212 - - 'STR#IPS ', 1.00, 1.00, 0.00, 0.00, 3, 304, 1, 213 - - 'TUBE ', 1.00, 1.00, 0.00, 0.00, 3, 357, 1, 0 214-+ +SELF,IF=-HIGZ,IF=-GTSGRAL. 215 - - 'COND#UCTORS-1 ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, 216 - - 'COND#UCTORS-2 ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, 217 - - 'COND#UCTORS-3 ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, 218 - - 'DIEL#ECTRICA-1 ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, 219 - - 'DIEL#ECTRICA-2 ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, 220 - - 'DIEL#ECTRICA-3 ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, 221 - - 'OUT#SIDE-AREA ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, 222 - - 'PLA#NES ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, 223 - - 'STR#IPS ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, 224 - - 'TUBE ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, 0 225-+ +SELF. 226 - - 'BOX-#TICKMARKS ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, 227 - - 'WIR#ES ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, 228 - - 'ERR#OR-BAR ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, 229 - - 'ERR#OR-BAND ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, 230 - - 'LABEL ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, 231 - - 'MATERIAL-1 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, 232 - - 'MATERIAL-2 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, 233 - - 'MATERIAL-3 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, 234 - - 'MATERIAL-4 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, 235 - - 'MATERIAL-5 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, 236 - - 'FUNCTION-1 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, 237 - - 'FUNCTION-2 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, 238 - - 'FUNCTION-3 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, 239 - - 'FUNCTION-4 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, 240 - - 'FUNCTION-5 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, 241 - - 'FUNCTION-6 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, 242 - - 'FUNCTION-7 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1/ 243 - *** Assume the routine fails. 244 - IFAIL=1 245 - *** Get the number of words. 246 - CALL INPNUM(NWORD) 247 - *** Workstation id. 248 - IWKID=1 249 - *** Starting values. 250 - LWR=-1.0 251 - LTR=0 252 - LCR=-1 253 - MSR=-1.0 254 - MTR=0 255 - MCR=-1 256 - TER=-1.0 257 - TSR=-1.0 258 - THR=-1.0 259 - TFR=12345678 260 - TPR=-1 261 - TCR=-1 262 - FPXR=-1.0 263 - FPYR=-1.0 264 - FRXR=0.0 265 - FRYR=0.0 266 - FIR=-1 267 - FSR=0 268 - FCR=-1 269 - POLYL=.FALSE. 270 - POLYM=.FALSE. 271 - TEXT=.FALSE. 272 - AREA=.FALSE. 273 - *** Decode the parameter list. 274 - INEXT=IKEY+2 275 - DO 10 I=IKEY+2,NWORD 276 - IF(I.LT.INEXT)GOTO 10 277 - * Polyline items. 278 - IF(INPCMP(I,'LINET#YPE')+ 279 - - INPCMP(I,'LINE-T#YPE').NE.0)THEN 280 - POLYL=.TRUE. 281 - IF(I+1.GT.NWORD)THEN 282 - CALL INPMSG(I,'The linetype is not specified.') 283 - ELSEIF(INPCMP(I+1,'SOL#ID').NE.0)THEN 284 - LTR=1 285 - INEXT=I+2 286 - ELSEIF(INPCMP(I+1,'DASH#ED').NE.0)THEN 287 - LTR=2 288 - INEXT=I+2 1 129 P=GRAPHICS D=GRATTR 4 PAGE 207 289 - ELSEIF(INPCMP(I+1,'DOT#TED').NE.0)THEN 290 - LTR=3 291 - INEXT=I+2 292 - ELSEIF(INPCMP(I+1,'DASH-DOT#TED').NE.0)THEN 293 - LTR=4 294 - INEXT=I+2 295 - ELSEIF(INPTYP(I+1).LE.0)THEN 296 - CALL INPMSG(I+1,'Not recognised as a linetype. ') 297 - INEXT=I+2 298 - ELSE 299 - CALL INPCHK(I+1,1,IFAIL1) 300 - CALL INPRDI(I+1,LTR,0) 301 - INEXT=I+2 302 - ENDIF 303 - ELSEIF(INPCMP(I,'LINEW#IDTH-SC#ALE-#FACTOR').NE.0)THEN 304 - POLYL=.TRUE. 305 - IF(INPTYP(I+1).LE.0.OR.I+1.GT.NWORD)THEN 306 - CALL INPMSG(I,'Value missing or not real. ') 307 - ELSE 308 - CALL INPCHK(I+1,2,IFAIL1) 309 - CALL INPRDR(I+1,LWR,-1.0) 310 - INEXT=I+2 311 - ENDIF 312 - ELSEIF(INPCMP(I,'POLYL#INE-COL#OUR').NE.0)THEN 313 - POLYL=.TRUE. 314 - IF(I+1.GT.NWORD)THEN 315 - CALL INPMSG(I,'The colour is not specified. ') 316 - ELSE 317 - CALL INPSTR(I+1,I+1,STRING,NCSTR) 318 - CALL GRCOLQ(IWKID,STRING(1:NCSTR),LCR) 319 - IF(LCR.LT.0) 320 - - CALL INPMSG(I+1,'This colour is not known. ') 321 - INEXT=I+2 322 - ENDIF 323 - * Polymarker items. 324 - ELSEIF(INPCMP(I,'M#ARKER-T#YPE').NE.0)THEN 325 - POLYM=.TRUE. 326 - IF(I+1.GT.NWORD)THEN 327 - CALL INPMSG(I,'The marker is not specified. ') 328 - ELSEIF(INPCMP(I+1,'DOT').NE.0)THEN 329 - MTR=1 330 - INEXT=I+2 331 - ELSEIF(INPCMP(I+1,'PL#US').NE.0)THEN 332 - MTR=2 333 - INEXT=I+2 334 - ELSEIF(INPCMP(I+1,'AST#ERISK').NE.0)THEN 335 - MTR=3 336 - INEXT=I+2 337 - ELSEIF(INPCMP(I+1,'CIRC#LE').NE.0)THEN 338 - MTR=4 339 - INEXT=I+2 340 - ELSEIF(INPCMP(I+1,'CR#OSS').NE.0)THEN 341 - MTR=5 342 - INEXT=I+2 343 - ELSEIF(INPTYP(I+1).LE.0)THEN 344 - CALL INPMSG(I+1,'Not recognised as a marker. ') 345 - INEXT=I+2 346 - ELSE 347 - CALL INPCHK(I+1,1,IFAIL1) 348 - CALL INPRDI(I+1,MTR,0) 349 - INEXT=I+2 350 - ENDIF 351 - ELSEIF(INPCMP(I,'M#ARKER-SIZ#E-#SCALE-#FACTOR').NE.0)THEN 352 - POLYM=.TRUE. 353 - IF(INPTYP(I+1).LE.0.OR.I+1.GT.NWORD)THEN 354 - CALL INPMSG(I,'Value missing or not real. ') 355 - ELSE 356 - CALL INPCHK(I+1,2,IFAIL1) 357 - CALL INPRDR(I+1,MSR,-1.0) 358 - INEXT=I+2 359 - ENDIF 360 - ELSEIF(INPCMP(I,'POLYM#ARKER-COL#OUR').NE.0)THEN 361 - POLYM=.TRUE. 362 - IF(I+1.GT.NWORD)THEN 363 - CALL INPMSG(I,'The colour is not specified. ') 364 - ELSE 365 - CALL INPSTR(I+1,I+1,STRING,NCSTR) 366 - CALL GRCOLQ(IWKID,STRING(1:NCSTR),MCR) 367 - IF(MCR.LT.0) 368 - - CALL INPMSG(I+1,'This colour is not known. ') 369 - INEXT=I+2 370 - ENDIF 371 - * Text items. 372 - ELSEIF(INPCMP(I,'CH#ARACTER-EXP#ANSION-#FACTOR').NE.0)THEN 373 - TEXT=.TRUE. 374 - IF(INPTYP(I+1).LE.0.OR.I+1.GT.NWORD)THEN 375 - CALL INPMSG(I,'Value missing or not real. ') 376 - ELSE 377 - CALL INPCHK(I+1,2,IFAIL1) 378 - CALL INPRDR(I+1,TER,-1.0) 379 - INEXT=I+2 380 - ENDIF 381 - ELSEIF(INPCMP(I,'CH#ARACTER-SP#ACING').NE.0)THEN 382 - TEXT=.TRUE. 383 - IF(INPTYP(I+1).LE.0.OR.I+1.GT.NWORD)THEN 384 - CALL INPMSG(I,'Value missing or not real. ') 385 - ELSE 386 - CALL INPCHK(I+1,2,IFAIL1) 387 - CALL INPRDR(I+1,TSR,-1.0) 388 - INEXT=I+2 389 - ENDIF 390 - ELSEIF(INPCMP(I,'CH#ARACTER-H#EIGHT').NE.0)THEN 391 - TEXT=.TRUE. 392 - IF(INPTYP(I+1).LE.0.OR.I+1.GT.NWORD)THEN 393 - CALL INPMSG(I,'Value missing or not real. ') 394 - ELSE 1 129 P=GRAPHICS D=GRATTR 5 PAGE 208 395 - CALL INPCHK(I+1,2,IFAIL1) 396 - CALL INPRDR(I+1,THR,-1.0) 397 - INEXT=I+2 398 - ENDIF 399 - ELSEIF(INPCMP(I,'T#EXT-F#ONT').NE.0)THEN 400 - TEXT=.TRUE. 0 401-+ +SELF,IF=HIGZ. 402 - IF(I+1.GT.NWORD)THEN 403 - CALL INPMSG(I,'Value missing.') 404 - ELSEIF(INPCMP(I+1,'HIGZ-#SOFTWARE').NE.0)THEN 405 - TFR=0 406 - ELSEIF(INPCMP(I+1,'T#IMES-I#TALIC').NE.0)THEN 407 - TFR=-1 408 - ELSEIF(INPCMP(I+1,'T#IMES-B#OLD').NE.0)THEN 409 - TFR=-2 410 - ELSEIF(INPCMP(I+1,'T#IMES-B#OLD-I#TALIC').NE.0)THEN 411 - TFR=-3 412 - ELSEIF(INPCMP(I+1,'HELV#ETICA').NE.0)THEN 413 - TFR=-4 414 - ELSEIF(INPCMP(I+1,'HELV#ETICA-O#BLIQUE').NE.0)THEN 415 - TFR=-5 416 - ELSEIF(INPCMP(I+1,'HELV#ETICA-B#OLD').NE.0)THEN 417 - TFR=-6 418 - ELSEIF(INPCMP(I+1,'HELV#ETICA-B#OLD-O#BLIQUE').NE.0)THEN 419 - TFR=-7 420 - ELSEIF(INPCMP(I+1,'C#OURIER').NE.0)THEN 421 - TFR=-8 422 - ELSEIF(INPCMP(I+1,'C#OURIER-O#BLIQUE').NE.0)THEN 423 - TFR=-9 424 - ELSEIF(INPCMP(I+1,'C#OURIER-B#OLD').NE.0)THEN 425 - TFR=-10 426 - ELSEIF(INPCMP(I+1,'C#OURIER-B#OLD-O#BLIQUE').NE.0)THEN 427 - TFR=-11 428 - ELSEIF(INPCMP(I+1,'S#YMBOL').NE.0)THEN 429 - TFR=-12 430 - ELSEIF(INPCMP(I+1,'T#IMES-R#OMAN').NE.0)THEN 431 - TFR=-13 432 - ELSEIF(INPCMP(I+1,'ZAPF-#DINGBAT').NE.0)THEN 433 - TFR=-14 434 - ELSEIF(INPCMP(I+1,'HO#LLOW-T#IMES-I#TALIC').NE.0)THEN 435 - TFR=-15 436 - ELSEIF(INPCMP(I+1,'HO#LLOW-T#IMES-B#OLD').NE.0)THEN 437 - TFR=-16 438 - ELSEIF(INPCMP(I+1,'HO#LLOW-T#IMES-B#OLD-I#TALIC').NE.0)THEN 439 - TFR=-17 440 - ELSEIF(INPCMP(I+1,'HO#LLOW-HELV#ETICA').NE.0)THEN 441 - TFR=-18 442 - ELSEIF(INPCMP(I+1,'HO#LLOW-HELV#ETICA-O#BLIQUE').NE.0)THEN 443 - TFR=-19 444 - ELSEIF(INPCMP(I+1,'HO#LLOW-HELV#ETICA-B#OLD').NE.0)THEN 445 - TFR=-20 446 - ELSEIF(INPCMP(I+1,'HO#LLOW-HELV#ETICA-B#OLD-O#BLIQUE').NE. 447 - - 0)THEN 448 - TFR=-21 449 - ELSEIF(INPCMP(I+1,'HO#LLOW-S#YMBOL').NE.0)THEN 450 - TFR=-22 451 - ELSEIF(INPCMP(I+1,'HO#LLOW-T#IMES-R#OMAN').NE.0)THEN 452 - TFR=-23 453 - ELSEIF(INPCMP(I+1,'HO#LLOW-ZAPF-#DINGBAT').NE.0)THEN 454 - TFR=-24 455 - ELSEIF(INPTYP(I+1).LE.0)THEN 456 - CALL INPMSG(I,'Value unknown.') 457 - ELSE 458 - CALL INPCHK(I+1,1,IFAIL1) 459 - CALL INPRDI(I+1,TFR,-1) 460 - ENDIF 461 - INEXT=I+2 0 462-+ +SELF,IF=GTSGRAL. 463 - IF(I+1.GT.NWORD)THEN 464 - CALL INPMSG(I,'Value missing.') 465 - ELSEIF(INPCMP(I+1,'PR#ESTIGE').NE.0)THEN 466 - TFR=-2 467 - ELSEIF(INPCMP(I+1,'T#IMES-R#OMAN').NE.0)THEN 468 - TFR=-3 469 - ELSEIF(INPCMP(I+1,'T#IMES-I#TALIC').NE.0)THEN 470 - TFR=-104 471 - ELSEIF(INPCMP(I+1,'GR#EEK').NE.0)THEN 472 - TFR=-13 473 - ELSEIF(INPCMP(I+1,'GR#EEK-I#TALIC').NE.0)THEN 474 - TFR=-113 475 - ELSEIF(INPCMP(I+1,'GO#THIC').NE.0)THEN 476 - TFR=-9 477 - ELSEIF(INPCMP(I+1,'GO#THIC-I#TALIC').NE.0)THEN 478 - TFR=-109 479 - ELSEIF(INPTYP(I+1).LE.0)THEN 480 - CALL INPMSG(I,'Value unknown.') 481 - ELSE 482 - CALL INPCHK(I+1,1,IFAIL1) 483 - CALL INPRDI(I+1,TFR,-1) 484 - ENDIF 485 - INEXT=I+2 486 - 0 487-+ +SELF,IF=-HIGZ,IF=-GTSGRAL. 488 - IF(INPTYP(I+1).LE.0.OR.I+1.GT.NWORD)THEN 489 - CALL INPMSG(I,'Value missing or not integer. ') 490 - ELSE 491 - CALL INPCHK(I+1,1,IFAIL1) 492 - CALL INPRDI(I+1,TFR,-1) 493 - INEXT=I+2 494 - ENDIF 1 129 P=GRAPHICS D=GRATTR 6 PAGE 209 495-+ +SELF. 496 - ELSEIF(INPCMP(I,'T#EXT-PR#ECISION').NE.0)THEN 497 - TEXT=.TRUE. 498 - IF(I+1.GT.NWORD)THEN 499 - CALL INPMSG(I,'Character quality missing. ') 500 - ELSEIF(INPCMP(I+1,'STRI#NG')+INPCMP(I+1,'LOW').NE.0)THEN 501 - TPR=0 502 - INEXT=I+2 503 - ELSEIF(INPCMP(I+1,'CH#ARACTER')+ 504 - - INPCMP(I+1,'MED#IUM').NE.0)THEN 505 - TPR=1 506 - INEXT=I+2 507 - ELSEIF(INPCMP(I+1,'STRO#KE')+INPCMP(I+1,'HIGH').NE.0)THEN 508 - TPR=2 509 - INEXT=I+2 510 - ELSE 511 - CALL INPMSG(I,'Not in STRING/CHARACTER/STROKE') 512 - ENDIF 513 - ELSEIF(INPCMP(I,'T#EXT-COL#OUR').NE.0)THEN 514 - TEXT=.TRUE. 515 - IF(I+1.GT.NWORD)THEN 516 - CALL INPMSG(I,'The colour is not specified. ') 517 - ELSE 518 - CALL INPSTR(I+1,I+1,STRING,NCSTR) 519 - CALL GRCOLQ(IWKID,STRING(1:NCSTR),TCR) 520 - IF(TCR.LT.0) 521 - - CALL INPMSG(I+1,'This colour is not known. ') 522 - INEXT=I+2 523 - ENDIF 524 - * Fill area items. 525 - ELSEIF(INPCMP(I,'F#ILL-A#REA-INT#ERIOR-#STYLE').NE.0)THEN 526 - AREA=.TRUE. 527 - IF(I+1.GT.NWORD)THEN 528 - CALL INPMSG(I,'Interior style missing. ') 529 - ELSEIF(INPCMP(I+1,'HOLL#OW').NE.0)THEN 530 - FIR=0 531 - INEXT=I+2 532 - ELSEIF(INPCMP(I+1,'SOL#ID').NE.0)THEN 533 - FIR=1 534 - INEXT=I+2 535 - ELSEIF(INPCMP(I+1,'PATT#ERN').NE.0)THEN 536 - FIR=2 537 - INEXT=I+2 538 - ELSEIF(INPCMP(I+1,'HAT#CHED').NE.0)THEN 539 - FIR=3 540 - INEXT=I+2 541 - ELSE 542 - CALL INPMSG(I+1,'Not HOLLOW/SOLID/PATTERN/HATCH') 543 - ENDIF 544 - ELSEIF(INPCMP(I,'F#ILL-A#REA-ST#YLE-#INDEX').NE.0)THEN 545 - AREA=.TRUE. 546 - IF(INPTYP(I+1).LE.0.OR.I+1.GT.NWORD)THEN 547 - CALL INPMSG(I,'Value missing or not integer. ') 548 - ELSE 549 - CALL INPCHK(I+1,1,IFAIL1) 550 - CALL INPRDI(I+1,FSR,0) 551 - INEXT=I+2 552 - ENDIF 553 - ELSEIF(INPCMP(I,'F#ILL-A#REA-COL#OUR').NE.0)THEN 554 - AREA=.TRUE. 555 - IF(I+1.GT.NWORD)THEN 556 - CALL INPMSG(I,'The colour is not specified. ') 557 - ELSE 558 - CALL INPSTR(I+1,I+1,STRING,NCSTR) 559 - CALL GRCOLQ(IWKID,STRING(1:NCSTR),FCR) 560 - IF(FCR.LT.0) 561 - - CALL INPMSG(I+1,'This colour is not known. ') 562 - INEXT=I+2 563 - ENDIF 564 - ELSEIF(INPCMP(I,'PA#TTERN-SIZ#E').NE.0)THEN 565 - AREA=.TRUE. 566 - IF(INPTYP(I+1).LE.0.OR.INPTYP(I+2).LE.0.OR. 567 - - I+2.GT.NWORD)THEN 568 - CALL INPMSG(I,'Values missing or not real. ') 569 - ELSE 570 - CALL INPCHK(I+1,2,IFAIL1) 571 - CALL INPRDR(I+1,FPXR,-1.0) 572 - CALL INPCHK(I+2,2,IFAIL2) 573 - CALL INPRDR(I+2,FPYR,-1.0) 574 - INEXT=I+3 575 - ENDIF 576 - ELSEIF(INPCMP(I,'PA#TTERN-REF#ERENCE-#POINT').NE.0)THEN 577 - AREA=.TRUE. 578 - IF(INPTYP(I+1).LE.0.OR.INPTYP(I+2).LE.0.OR. 579 - - I+2.GT.NWORD)THEN 580 - CALL INPMSG(I,'Values missing or not real. ') 581 - ELSE 582 - CALL INPCHK(I+1,2,IFAIL1) 583 - CALL INPRDR(I+1,FRXR,-1.0) 584 - CALL INPCHK(I+2,2,IFAIL2) 585 - CALL INPRDR(I+2,FRYR,-1.0) 586 - INEXT=I+3 587 - ENDIF 588 - * Unknown item. 589 - ELSE 590 - CALL INPMSG(I,'Not a known item. ') 591 - ENDIF 592 - 10 CONTINUE 593 - *** Dump the error messages. 594 - CALL INPERR 595 - *** Check whether conflicting items were presented. 596 - NITEM=0 597 - IF(POLYL)NITEM=NITEM+1 598 - IF(POLYM)NITEM=NITEM+1 599 - IF(TEXT)NITEM=NITEM+1 600 - IF(AREA)NITEM=NITEM+1 1 129 P=GRAPHICS D=GRATTR 7 PAGE 210 601 - IF(NITEM.GT.1)THEN 602 - PRINT *,' ###### GRATTR ERROR : Items belonging to more'// 603 - - ' than one primitive seen ; command not processed.' 604 - RETURN 605 - ELSEIF(NITEM.EQ.0.AND.IKEY+1.LT.NWORD)THEN 606 - PRINT *,' ###### GRATTR ERROR : Invalid attributes'// 607 - - ' seen ; neither inquiry nor update performed.' 608 - RETURN 609 - ENDIF 610 - *** Loop over the items, start with the polylines. 611 - NUPDAT=0 612 - NSEEN=0 613 - DO 20 I=1,NLIN 614 - IF(IKEY.EQ.NWORD.OR.INPCMP(IKEY+1,LINNAM(I))+ 615 - - INPCMP(IKEY+1,'!'//LINNAM(I)).NE.0)THEN 616 - NSEEN=NSEEN+1 617 - IF(IKEY+1.GE.NWORD)THEN 618 - CALL INPFIX(LINNAM(I),AUX,NC) 619 - WRITE(LUNOUT,'(/'' Current representation of the'', 620 - - '' polyline item '',A,'':''/)') AUX(1:NC) 621 - IF(LINTYP(I).EQ.1)THEN 622 - AUX='Solid (--------)' 623 - ELSEIF(LINTYP(I).EQ.2)THEN 624 - AUX='Dashed (- - - - )' 625 - ELSEIF(LINTYP(I).EQ.3)THEN 626 - AUX='Dotted (........)' 627 - ELSEIF(LINTYP(I).EQ.4)THEN 628 - AUX='Dash-dotted (-.-.-.-.)' 629 - ELSE 630 - WRITE(AUX,'(I10)') LINTYP(I) 631 - ENDIF 632 - WRITE(LUNOUT,'('' Linetype: '',A)') 633 - - AUX(1:25) 634 - CALL OUTFMT(LINWID(I),2,AUX,NC,'LEFT') 635 - WRITE(LUNOUT,'('' Linewidth scale factor: '',A)') 636 - - AUX(1:NC) 637 - CALL GRCOLD(IWKID,LINCOL(I),AUX,NC,'FORMATTED') 638 - WRITE(LUNOUT,'('' Polyline colour: '',A)') 639 - - AUX(1:NC) 640 - WRITE(LUNOUT,'('' '')') 641 - ELSEIF(POLYL)THEN 642 - NUPDAT=NUPDAT+1 643 - IF(LTR.NE.0)LINTYP(I)=LTR 644 - IF(LWR.GT.0.0)LINWID(I)=LWR 645 - IF(LCR.GE.0)LINCOL(I)=LCR 646 - ENDIF 647 - ENDIF 648 - 20 CONTINUE 649 - *** Next the polymarkers. 650 - DO 30 I=1,NMRK 651 - IF(IKEY.EQ.NWORD.OR.INPCMP(IKEY+1,MRKNAM(I))+ 652 - - INPCMP(IKEY+1,'!'//MRKNAM(I)).NE.0)THEN 653 - NSEEN=NSEEN+1 654 - IF(IKEY+1.GE.NWORD)THEN 655 - CALL INPFIX(MRKNAM(I),AUX,NC) 656 - WRITE(LUNOUT,'(/'' Current representation of the'', 657 - - '' polymarker item '',A,'':''/)') AUX(1:NC) 658 - IF(MRKTYP(I).EQ.1)THEN 659 - AUX='Dot (.)' 660 - ELSEIF(MRKTYP(I).EQ.2)THEN 661 - AUX='Plus (+)' 662 - ELSEIF(MRKTYP(I).EQ.3)THEN 663 - AUX='Asterisk (*)' 664 - ELSEIF(MRKTYP(I).EQ.4)THEN 665 - AUX='Circle (o)' 666 - ELSEIF(MRKTYP(I).EQ.5)THEN 667 - AUX='Cross (x)' 668 - ELSE 669 - WRITE(AUX,'(I10)') MRKTYP(I) 670 - ENDIF 671 - WRITE(LUNOUT,'('' Marker type: '',A)') 672 - - AUX(1:20) 673 - CALL OUTFMT(MRKSIZ(I),2,AUX,NC,'LEFT') 674 - WRITE(LUNOUT,'('' Marker size scale factor: '',A)') 675 - - AUX(1:NC) 676 - CALL GRCOLD(IWKID,MRKCOL(I),AUX,NC,'FORMATTED') 677 - WRITE(LUNOUT,'('' Polymarker colour: '',A/)') 678 - - AUX(1:NC) 679 - ELSEIF(POLYM)THEN 680 - NUPDAT=NUPDAT+1 681 - IF(MTR.NE.0)MRKTYP(I)=MTR 682 - IF(MSR.GT.0.0)MRKSIZ(I)=MSR 683 - IF(MCR.GE.0)MRKCOL(I)=MCR 684 - ENDIF 685 - ENDIF 686 - 30 CONTINUE 687 - *** Next the text. 688 - DO 40 I=1,NTXT 689 - IF(IKEY.EQ.NWORD.OR.INPCMP(IKEY+1,TXTNAM(I))+ 690 - - INPCMP(IKEY+1,'!'//TXTNAM(I)).NE.0)THEN 691 - NSEEN=NSEEN+1 692 - IF(IKEY+1.GE.NWORD)THEN 693 - CALL INPFIX(TXTNAM(I),AUX,NC) 694 - WRITE(LUNOUT,'(/'' Current representation of the'', 695 - - '' text item '',A,'':''/)') AUX(1:NC) 696 - CALL OUTFMT(REAL(TXTFNT(I)),2,AUX,NC,'LEFT') 697 - WRITE(LUNOUT,'('' Text font: '',A)') 698 - - AUX(1:NC) 699 - IF(TXTPRC(I).EQ.0)THEN 700 - AUX='String (low quality)' 701 - ELSEIF(TXTPRC(I).EQ.1)THEN 702 - AUX='Character (medium quality)' 703 - ELSEIF(TXTPRC(I).EQ.2)THEN 704 - AUX='Stroke (high quality)' 705 - ELSE 706 - WRITE(AUX,'(''# Invalid: '',I10)') TXTPRC(I) 1 129 P=GRAPHICS D=GRATTR 8 PAGE 211 707 - ENDIF 708 - WRITE(LUNOUT,'('' Text precision: '',A)') 709 - - AUX(1:30) 710 - CALL OUTFMT(TXTEXP(I),2,AUX,NC,'LEFT') 711 - WRITE(LUNOUT,'('' Character expansion: '',A)') 712 - - AUX(1:NC) 713 - CALL OUTFMT(TXTHGT(I),2,AUX,NC,'LEFT') 714 - WRITE(LUNOUT,'('' Character height: '',A)') 715 - - AUX(1:NC) 716 - CALL OUTFMT(TXTSPA(I),2,AUX,NC,'LEFT') 717 - WRITE(LUNOUT,'('' Character spacing: '',A)') 718 - - AUX(1:NC) 719 - CALL GRCOLD(IWKID,TXTCOL(I),AUX,NC,'FORMATTED') 720 - WRITE(LUNOUT,'('' Text colour: '',A/)') 721 - - AUX(1:NC) 722 - ELSEIF(TEXT)THEN 723 - NUPDAT=NUPDAT+1 724 - IF(TER.GT.0.0)TXTEXP(I)=TER 725 - IF(TSR.GE.0.0)TXTSPA(I)=TSR 726 - IF(THR.GT.0.0)TXTHGT(I)=THR 727 - IF(TPR.GE.0)TXTPRC(I)=TPR 728 - IF(TFR.NE.12345678)TXTFNT(I)=TFR 729 - IF(TCR.GE.0)TXTCOL(I)=TCR 730 - ENDIF 731 - ENDIF 732 - 40 CONTINUE 733 - *** Next the fill area. 734 - DO 50 I=1,NFAR 735 - IF(IKEY.EQ.NWORD.OR.INPCMP(IKEY+1,FARNAM(I))+ 736 - - INPCMP(IKEY+1,'!'//FARNAM(I)).NE.0)THEN 737 - NSEEN=NSEEN+1 738 - IF(IKEY+1.GE.NWORD)THEN 739 - CALL INPFIX(FARNAM(I),AUX,NC) 740 - WRITE(LUNOUT,'(/'' Current representation of the'', 741 - - '' fill area item '',A,'':''/)') AUX(1:NC) 742 - IF(FARINT(I).EQ.0)THEN 743 - AUX='Hollow (boundaries only)' 744 - ELSEIF(FARINT(I).EQ.1)THEN 745 - AUX='Solid (area filled with colour)' 746 - ELSEIF(FARINT(I).EQ.2)THEN 747 - AUX='Pattern (area filled with pattern)' 748 - ELSEIF(FARINT(I).EQ.3)THEN 749 - AUX='Hatch (area hatched)' 750 - ELSE 751 - CALL OUTFMT(REAL(FARINT(I)),2,AUX1,NC1,'LEFT') 752 - AUX='# Invalid: '//AUX1(1:NC1) 753 - ENDIF 754 - WRITE(LUNOUT,'('' Fill area interior style: '',A)') 755 - - AUX(1:40) 756 - IF(FARINT(I).EQ.2.OR.FARINT(I).EQ.3)THEN 757 - CALL OUTFMT(REAL(FARSTY(I)),2,AUX,NC,'LEFT') 758 - WRITE(LUNOUT,'('' Fill area style index: '', 759 - - A)') AUX(1:NC) 760 - ENDIF 761 - IF(FARINT(I).EQ.2)THEN 762 - CALL OUTFMT(FARPAS(1,I),2,AUX1,NC1,'LEFT') 763 - CALL OUTFMT(FARPAS(2,I),2,AUX2,NC2,'LEFT') 764 - WRITE(LUNOUT,'('' Fill area pattern sizes: ('', 765 - - A,'','',A,'')'')') AUX1(1:NC1),AUX2(1:NC2) 766 - CALL OUTFMT(FARREF(1,I),2,AUX1,NC1,'LEFT') 767 - CALL OUTFMT(FARREF(2,I),2,AUX2,NC2,'LEFT') 768 - WRITE(LUNOUT,'('' Fill area reference: ('', 769 - - A,'','',A,'')'')') AUX1(1:NC1),AUX2(1:NC2) 770 - ENDIF 771 - CALL GRCOLD(IWKID,FARCOL(I),AUX,NC,'FORMATTED') 772 - WRITE(LUNOUT,'('' Fill area colour: '',A/)') 773 - - AUX(1:NC) 774 - ELSEIF(AREA)THEN 775 - NUPDAT=NUPDAT+1 776 - IF(FPXR.GT.0.0)FARPAS(1,I)=FPXR 777 - IF(FPYR.GT.0.0)FARPAS(2,I)=FPYR 778 - FARREF(1,I)=FRXR 779 - FARREF(2,I)=FRYR 780 - IF(FIR.GE.0)FARINT(I)=FIR 781 - IF(FSR.NE.0)FARSTY(I)=FSR 782 - IF(FCR.GE.0)FARCOL(I)=FCR 783 - ENDIF 784 - ENDIF 785 - 50 CONTINUE 786 - *** Check that an item was found. 787 - CALL INPSTR(IKEY+1,IKEY+1,STRING,NC) 788 - IF(NC.LE.0)THEN 789 - STRING='# Unable to read #' 790 - NC=18 791 - ENDIF 792 - IF(NSEEN.EQ.0)THEN 793 - PRINT *,' !!!!!! GRATTR WARNING : '//STRING(1:NC)//' is'// 794 - - ' not a known item.' 795 - ELSEIF(NITEM.GT.0.AND.NUPDAT.EQ.0)THEN 796 - PRINT *,' !!!!!! GRATTR WARNING : The representation of '// 797 - - STRING(1:NC)//' is left unaltered since' 798 - PRINT *,' the attributes you'// 799 - - ' specified are not of the proper type.' 800 - ELSE 801 - IFAIL=0 802 - ENDIF 803 - RETURN 804 - *** Secondary entry to set the proper attributes. 805 - ENTRY GRATTS(ITEM,TYPE) 806 - NSEEN=0 807 - * Scan the list of polyline items if appropriate. 808 - IF(TYPE.EQ.'POLYLINE')THEN 809 - DO 110 I=1,NLIN 810 - IF(INPCMX(ITEM,LINNAM(I)).EQ.0)GOTO 110 811 - NSEEN=NSEEN+1 812 - CALL GSLN(LINTYP(I)) 1 129 P=GRAPHICS D=GRATTR 9 PAGE 212 813 - CALL GSLWSC(LINWID(I)) 814 - CALL GSPLCI(LINCOL(I)) 815 - 110 CONTINUE 816 - * The list of polymarker items. 817 - ELSEIF(TYPE.EQ.'POLYMARKER')THEN 818 - DO 120 I=1,NMRK 819 - IF(INPCMX(ITEM,MRKNAM(I)).EQ.0)GOTO 120 820 - NSEEN=NSEEN+1 821 - CALL GSMK(MRKTYP(I)) 822 - CALL GSMKSC(MRKSIZ(I)) 823 - CALL GSPMCI(MRKCOL(I)) 824 - 120 CONTINUE 825 - * The list of text items. 826 - ELSEIF(TYPE.EQ.'TEXT')THEN 827 - DO 130 I=1,NTXT 828 - IF(INPCMX(ITEM,TXTNAM(I)).EQ.0)GOTO 130 829 - NSEEN=NSEEN+1 830 - CALL GSTXFP(TXTFNT(I),TXTPRC(I)) 831 - CALL GSCHXP(TXTEXP(I)) 832 - CALL GSCHSP(TXTSPA(I)) 833 - CALL GSCHH(TXTHGT(I)) 834 - CALL GSTXCI(TXTCOL(I)) 835 - 130 CONTINUE 836 - * The list of fill area items. 837 - ELSEIF(TYPE.EQ.'AREA')THEN 838 - DO 140 I=1,NFAR 839 - IF(INPCMX(ITEM,FARNAM(I)).EQ.0)GOTO 140 840 - NSEEN=NSEEN+1 841 - CALL GSFAIS(FARINT(I)) 842 - IF(FARINT(I).EQ.2.OR.FARINT(I).EQ.3) 843 - - CALL GSFASI(FARSTY(I)) 844 - CALL GSPA(FARPAS(1,I),FARPAS(2,I)) 845 - CALL GSPARF(FARREF(1,I),FARREF(2,I)) 846 - CALL GSFACI(FARCOL(I)) 847 - 140 CONTINUE 848 - * Anything else: invalid. 849 - ELSE 850 - WRITE (10,'('' ###### GRATTS ERROR : Invalid primitive'', 851 - - '' type '',A,'' received; program bug.'')') TYPE 852 - RETURN 853 - ENDIF 854 - *** Make sure the item has been found. 855 - IF(NSEEN.EQ.0)THEN 856 - WRITE (10,'('' !!!!!! GRATTS ERROR : Unknown item '',A, 857 - - '' received; no update.'')') ITEM 858 - RETURN 859 - ENDIF 860 - RETURN 861 - *** Write the settings to a file. 862 - ENTRY GRATTW(IKEY,IFAIL) 863 - * Initial settings. 864 - FILE=' ' 865 - NCFILE=1 866 - MEMBER='< none >' 867 - NCMEMB=8 868 - REMARK='none' 869 - NCREM=4 870 - IFAIL=1 871 - IWKID=1 872 - * First decode the argument string. 873 - CALL INPNUM(NWORD) 874 - * Make sure there is at least one argument. 875 - IF(NWORD.EQ.IKEY)THEN 876 - PRINT *,' !!!!!! GRATTW WARNING : WRITE takes at least one', 877 - - ' argument (a dataset name); data will not be written.' 878 - RETURN 879 - * Check whether keywords have been used. 880 - ELSEIF(INPCMP(IKEY+1,'D#ATASET')+ 881 - - INPCMP(IKEY+1,'R#EMARK').NE.0)THEN 882 - INEXT=2 883 - DO 210 I=IKEY+1,NWORD 884 - IF(I.LT.INEXT)GOTO 210 885 - IF(INPCMP(I,'D#ATASET').NE.0)THEN 886 - IF(INPCMP(I+1,'R#EMARK').NE.0.OR.I+1.GT.NWORD)THEN 887 - CALL INPMSG(I,'The dataset name is missing. ') 888 - INEXT=I+1 889 - ELSE 890 - CALL INPSTR(I+1,I+1,STRING,NCFILE) 891 - FILE=STRING 892 - INEXT=I+2 893 - IF(INPCMP(I+2,'R#EMARK').EQ.0.AND. 894 - - I+2.LE.NWORD)THEN 895 - CALL INPSTR(I+2,I+2,STRING,NCMEMB) 896 - MEMBER=STRING 897 - INEXT=I+3 898 - ENDIF 899 - ENDIF 900 - ELSEIF(INPCMP(I,'R#EMARK').NE.0)THEN 901 - IF(INPCMP(I+1,'D#ATASET').NE.0.OR.I+1.GT.NWORD)THEN 902 - CALL INPMSG(I,'The remark is missing. ') 903 - INEXT=I+1 904 - ELSE 905 - CALL INPSTR(I+1,I+1,STRING,NCREM) 906 - REMARK=STRING 907 - INEXT=I+2 908 - ENDIF 909 - ELSE 910 - CALL INPMSG(I,'The parameter is not known. ') 911 - ENDIF 912 - 210 CONTINUE 913 - * Otherwise the string is interpreted as a file name (+ member name). 914 - ELSE 915 - CALL INPSTR(IKEY+1,IKEY+1,STRING,NCFILE) 916 - FILE=STRING 917 - IF(NWORD.GE.IKEY+2)THEN 918 - CALL INPSTR(IKEY+2,IKEY+2,STRING,NCMEMB) 1 129 P=GRAPHICS D=GRATTR 10 PAGE 213 919 - MEMBER=STRING 920 - ENDIF 921 - IF(NWORD.GE.IKEY+3)THEN 922 - CALL INPSTR(IKEY+3,NWORD,STRING,NCREM) 923 - REMARK=STRING 924 - ENDIF 925 - ENDIF 926 - * Print error messages. 927 - CALL INPERR 928 - IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! GRATTW WARNING : The file', 929 - - ' name is truncated to MXNAME (=',MXNAME,') characters.' 930 - IF(NCMEMB.GT.8)PRINT *,' !!!!!! GRATTW WARNING : The member', 931 - - ' name is shortened to ',MEMBER,', first 8 characters.' 932 - IF(NCREM.GT.29)PRINT *,' !!!!!! GRATTW WARNING : The remark', 933 - - ' shortened to ',REMARK,', first 29 characters.' 934 - NCFILE=MIN(NCFILE,MXNAME) 935 - NCMEMB=MIN(NCMEMB,8) 936 - NCREM=MIN(NCREM,29) 937 - * Check whether the member already exists. 938 - CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'GRAPHREP',EXMEMB) 939 - IF(JEXMEM.EQ.2.AND.EXMEMB)THEN 940 - PRINT *,' ------ GRATTW MESSAGE : A copy of the member'// 941 - - ' exists; new member will be appended.' 942 - ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN 943 - PRINT *,' !!!!!! GRATTW WARNING : A copy of the member'// 944 - - ' exists already; member will not be written.' 945 - RETURN 946 - ENDIF 947 - * Print some debugging output if requested. 948 - IF(LDEBUG)THEN 949 - PRINT *,' ++++++ GRATTW DEBUG : File= ',FILE(1:NCFILE), 950 - - ', member= ',MEMBER(1:NCMEMB) 951 - PRINT *,' Remark= ',REMARK(1:NCREM) 952 - ENDIF 953 - ** Open the dataset for sequential write and inform DSNLOG. 954 - CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) 955 - IF(IFAIL.NE.0)THEN 956 - PRINT *,' !!!!!! GRATTW WARNING : Opening ',FILE(1:NCFILE), 957 - - ' failed ; the data will not be written.' 958 - RETURN 959 - ENDIF 960 - CALL DSNLOG(FILE,'Graphics ','Sequential','Write ') 961 - IF(LDEBUG)PRINT *,' ++++++ GRATTW DEBUG : Dataset ', 962 - - FILE(1:NCFILE),' opened on unit 12 for seq write.' 963 - * Now write a heading record to the file. 964 - CALL DATTIM(DATE,TIME) 965 - WRITE(STRING,'(''% Created '',A8,'' At '',A8,1X,A8,'' GRAPHREP'', 966 - - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK 967 - WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING 968 - IF(LDEBUG)THEN 969 - PRINT *,' ++++++ GRATTW DEBUG : Dataset heading record:' 970 - PRINT *,STRING 971 - ENDIF 972 - * Information line about the graphics system beging used. 0 973-+ +SELF,IF=GTSGRAL. 974 - WRITE(12,'('' GKS flavour: GTSGRAL'')',ERR=2010,IOSTAT=IOS) 0 975-+ +SELF,IF=DECGKS. 976 - WRITE(12,'('' GKS flavour: DECGKS'')',ERR=2010,IOSTAT=IOS) 0 977-+ +SELF,IF=PLOT10GKS. 978 - WRITE(12,'('' GKS flavour: PLOT10GKS'')',ERR=2010,IOSTAT=IOS) 0 979-+ +SELF,IF=-GTSGRAL,IF=-DECGKS,IF=-PLOT10GKS. 980 - WRITE(12,'('' GKS flavour: MGKS'')',ERR=2010,IOSTAT=IOS) 0 981-+ +SELF. 982 - * Write the actual data, start with the number of items of each type. 983 - WRITE(12,'('' NLIN='',I3,'', NMRK='',I3,'', NTXT='',I3, 984 - - '', NFAR='',I3)',ERR=2010,IOSTAT=IOS) NLIN,NMRK,NTXT,NFAR 985 - * Next a list of Polyline attributes. 986 - DO 230 I=1,NLIN 987 - CALL GRCOLD(IWKID,LINCOL(I),AUX,NC,'RAW') 988 - WRITE(12,'(A20,I10,E15.8,A20)',ERR=2010,IOSTAT=IOS) 989 - - LINNAM(I),LINTYP(I),LINWID(I),AUX(1:20) 990 - 230 CONTINUE 991 - * Next a list of Polymarker attributes. 992 - DO 240 I=1,NMRK 993 - CALL GRCOLD(IWKID,MRKCOL(I),AUX,NC,'RAW') 994 - WRITE(12,'(A20,I10,E15.8,A20)',ERR=2010,IOSTAT=IOS) 995 - - MRKNAM(I),MRKTYP(I),MRKSIZ(I),AUX(1:20) 996 - 240 CONTINUE 997 - * Next a list of Text attributes. 998 - DO 250 I=1,NTXT 999 - CALL GRCOLD(IWKID,TXTCOL(I),AUX,NC,'RAW') 1000 - WRITE(12,'(A20,2I10,3E15.8,A20)',ERR=2010,IOSTAT=IOS) 1001 - - TXTNAM(I),TXTFNT(I),TXTPRC(I),TXTEXP(I),TXTSPA(I), 1002 - - TXTHGT(I),AUX(1:20) 1003 - 250 CONTINUE 1004 - * Next a list of Fill Area attributes. 1005 - DO 260 I=1,NFAR 1006 - CALL GRCOLD(IWKID,FARCOL(I),AUX,NC,'RAW') 1007 - WRITE(12,'(A20,2I10,4E15.8,A20)',ERR=2010,IOSTAT=IOS) 1008 - - FARNAM(I),FARINT(I),FARSTY(I),FARPAS(1,I),FARPAS(2,I), 1009 - - FARREF(1,I),FARREF(2,I),AUX(1:20) 1010 - 260 CONTINUE 1011 - ** Close the file after the operation. 1012 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 1013 - CALL TIMLOG('Writing out graphics representations: ') 1014 - IFAIL=0 1015 - RETURN 1016 - *** Read the presentation from dataset. 1017 - ENTRY GRATTG(IKEY,IFAIL) 1018 - * Initial values. 1019 - FILE=' ' 1 129 P=GRAPHICS D=GRATTR 11 PAGE 214 1020 - MEMBER='*' 1021 - NCFILE=8 1022 - NCMEMB=1 1023 - IFAIL=1 1024 - IWKID=1 1025 - ** First decode the argument string, setting file name + member name. 1026 - CALL INPNUM(NWORD) 1027 - * If there's only one argument, it's the dataset name. 1028 - IF(NWORD.GE.IKEY+1)THEN 1029 - CALL INPSTR(IKEY+1,IKEY+1,STRING,NCFILE) 1030 - FILE=STRING 1031 - ENDIF 1032 - * If there's a second argument, it is the member name. 1033 - IF(NWORD.GE.IKEY+2)THEN 1034 - CALL INPSTR(IKEY+2,IKEY+2,STRING,NCMEMB) 1035 - MEMBER=STRING 1036 - ENDIF 1037 - * Check the various lengths. 1038 - IF(NCFILE.GT.MXNAME)THEN 1039 - PRINT *,' !!!!!! GRATTG WARNING : The file name is'// 1040 - - ' truncated to MXNAME (=',MXNAME,') characters.' 1041 - NCFILE=MIN(NCFILE,MXNAME) 1042 - ENDIF 1043 - IF(NCMEMB.GT.8)THEN 1044 - PRINT *,' !!!!!! GRATTG WARNING : The member name is'// 1045 - - ' shortened to ',MEMBER,', first 8 characters.' 1046 - NCMEMB=MIN(NCMEMB,8) 1047 - ELSEIF(NCMEMB.LE.0)THEN 1048 - PRINT *,' !!!!!! GRATTG WARNING : The member'// 1049 - - ' name has zero length, replaced by "*".' 1050 - MEMBER='*' 1051 - NCMEMB=1 1052 - ENDIF 1053 - * Reject the empty file name case. 1054 - IF(FILE.EQ.' '.OR.NWORD.EQ.1)THEN 1055 - PRINT *,' !!!!!! GRATTG WARNING : GET must be at least'// 1056 - - ' followed by a dataset name ; no data are read.' 1057 - RETURN 1058 - ENDIF 1059 - * If there are even more args, warn they are ignored. 1060 - IF(NWORD.GT.IKEY+2)PRINT *,' !!!!!! GRATTG WARNING : GET takes'// 1061 - - ' at most two arguments (dataset and member); rest ignored.' 1062 - ** Open the dataset and inform DSNLOG. 1063 - CALL DSNOPN(FILE,NCFILE,12,'READ-LIBRARY',IFAIL1) 1064 - IF(IFAIL1.NE.0)THEN 1065 - PRINT *,' !!!!!! GRATTG WARNING : Opening ',FILE(1:NCFILE), 1066 - - ' failed ; graphics representation data are not read.' 1067 - RETURN 1068 - ENDIF 1069 - CALL DSNLOG(FILE,'Graphics ','Sequential','Read only ') 1070 - IF(LDEBUG)PRINT *,' ++++++ GRATTG DEBUG : Dataset', 1071 - - FILE(1:NCFILE),' opened on unit 12 for seq read.' 1072 - * Locate the pointer on the header of the requested member. 1073 - CALL DSNLOC(MEMBER,NCMEMB,'GRAPHREP',12,EXIS,'RESPECT') 1074 - IF(.NOT.EXIS)THEN 1075 - CALL DSNLOC(MEMBER,NCMEMB,'GRAPHREP',12,EXIS,'IGNORE') 1076 - IF(EXIS)THEN 1077 - PRINT *,' ###### GRATTG ERROR : Graphics data ', 1078 - - MEMBER(1:NCMEMB),' has been deleted from ', 1079 - - FILE(1:NCFILE),'; not read.' 1080 - ELSE 1081 - PRINT *,' ###### GRATTG ERROR : Graphics data ', 1082 - - MEMBER(1:NCMEMB),' not found on ',FILE(1:NCFILE) 1083 - ENDIF 1084 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 1085 - RETURN 1086 - ENDIF 1087 - ** Check that the member is acceptable date wise. 1088 - READ(12,'(A80)',END=2000,IOSTAT=IOS,ERR=2010) STRING 1089 - IF(LDEBUG)THEN 1090 - PRINT *,' ++++++ GRATTG DEBUG : Dataset header', 1091 - - ' record follows:' 1092 - PRINT *,STRING 1093 - ENDIF 1094 - IF(DSNCMP('14-07-89',STRING(11:18)))THEN 1095 - PRINT *,' !!!!!! GRATTG WARNING : Member ',STRING(32:39), 1096 - - ' can not be read because of a change in format.' 1097 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 1098 - RETURN 1099 - ENDIF 1100 - WRITE(LUNOUT,'('' Member '',A8,'' was created on '',A8, 1101 - - '' at '',A8/'' Remarks: '',A29)') 1102 - - STRING(32:39),STRING(11:18),STRING(23:30),STRING(51:79) 1103 - ** Carry out the actual reading, check the GKS flavour. 1104 - READ(12,'(A80)',END=2000,ERR=2010,IOSTAT=IOS) AUX 0 1105-+ +SELF,IF=GTSGRAL. 1106 - IF(AUX(15:30).NE.'GTSGRAL ')PRINT *,' !!!!!! GRATTG'// 1107 - - ' WARNING : This member was created with another GKS than'// 1108 - - ' the one you are running with now.' 0 1109-+ +SELF,IF=DECGKS. 1110 - IF(AUX(15:30).NE.'DECGKS ')PRINT *,' !!!!!! GRATTG'// 1111 - - ' WARNING : This member was created with another GKS than'// 1112 - - ' the one you are running with now.' 0 1113-+ +SELF,IF=PLOT10GKS. 1114 - IF(AUX(15:30).NE.'PLOT10GKS ')PRINT *,' !!!!!! GRATTG'// 1115 - - ' WARNING : This member was created with another GKS than'// 1116 - - ' the one you are running with now.' 0 1117-+ +SELF,IF=-GTSGRAL,IF=-DECGKS,IF=-PLOT10GKS. 1118 - IF(AUX(15:30).NE.'MGKS ')PRINT *,' !!!!!! GRATTG'// 1119 - - ' WARNING : This member was created with another GKS than'// 1120 - - ' the one you are running with now.' 1 129 P=GRAPHICS D=GRATTR 12 PAGE 215 1121-+ +SELF. 1122 - * Read the actual data, start with the number of items of each type. 1123 - READ(12,'(6X,I3,7X,I3,7X,I3,7X,I3)',END=2000,ERR=2010, 1124 - - IOSTAT=IOS) NLIN,NMRK,NTXT,NFAR 1125 - * Make sure none of these exceeds the maximum numbers. 1126 - IF(NLIN.GT.MXPLBU.OR.NMRK.GT.MXPMBU.OR.NTXT.GT.MXTXBU.OR. 1127 - - NFAR.GT.MXFABU)THEN 1128 - PRINT *,' !!!!!! GRATTG WARNING : The number of items'// 1129 - - ' for one or more atributes, exceeds' 1130 - PRINT *,' the compilation maxima;'// 1131 - - ' increase these and recompile.' 1132 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 1133 - RETURN 1134 - ENDIF 1135 - * Next a list of Polyline attributes. 1136 - DO 330 I=1,NLIN 1137 - READ(12,'(A20,I10,E15.8,A20)',END=2000,ERR=2010,IOSTAT=IOS) 1138 - - LINNAM(I),LINTYP(I),LINWID(I),AUX(1:20) 1139 - CALL GRCOLQ(IWKID,AUX(1:20),LCR) 1140 - IF(LCR.GE.0)THEN 1141 - LINCOL(I)=LCR 1142 - ELSE 1143 - PRINT *,' !!!!!! GRATTG WARNING : The member contains a'// 1144 - - ' colour absent in the colour tables: '//AUX(1:20) 1145 - CALL INPFIX(LINNAM(I),AUX,NC) 1146 - PRINT *,' The FOREGROUND colour'// 1147 - - ' will be used to represent item '//AUX(1:NC)//'.' 1148 - LINCOL(I)=1 1149 - ENDIF 1150 - 330 CONTINUE 1151 - * Next a list of Polymarker attributes. 1152 - DO 340 I=1,NMRK 1153 - READ(12,'(A20,I10,E15.8,A20)',END=2000,ERR=2010,IOSTAT=IOS) 1154 - - MRKNAM(I),MRKTYP(I),MRKSIZ(I),AUX(1:20) 1155 - CALL GRCOLQ(IWKID,AUX(1:20),MCR) 1156 - IF(MCR.GE.0)THEN 1157 - MRKCOL(I)=MCR 1158 - ELSE 1159 - PRINT *,' !!!!!! GRATTG WARNING : The member contains a'// 1160 - - ' colour absent in the colour tables: '//AUX(1:20) 1161 - CALL INPFIX(MRKNAM(I),AUX,NC) 1162 - PRINT *,' The FOREGROUND colour'// 1163 - - ' will be used to represent item '//AUX(1:NC)//'.' 1164 - MRKCOL(I)=1 1165 - ENDIF 1166 - 340 CONTINUE 1167 - * Next a list of Text attributes. 1168 - DO 350 I=1,NTXT 1169 - READ(12,'(A20,2I10,3E15.8,A20)',END=2000,ERR=2010,IOSTAT=IOS) 1170 - - TXTNAM(I),TXTFNT(I),TXTPRC(I),TXTEXP(I),TXTSPA(I), 1171 - - TXTHGT(I),AUX(1:20) 1172 - CALL GRCOLQ(IWKID,AUX(1:20),TCR) 1173 - IF(TCR.GE.0)THEN 1174 - TXTCOL(I)=TCR 1175 - ELSE 1176 - PRINT *,' !!!!!! GRATTG WARNING : The member contains a'// 1177 - - ' colour absent in the colour tables: '//AUX(1:20) 1178 - CALL INPFIX(TXTNAM(I),AUX,NC) 1179 - PRINT *,' The FOREGROUND colour'// 1180 - - ' will be used to represent item '//AUX(1:NC)//'.' 1181 - TXTCOL(I)=1 1182 - ENDIF 1183 - 350 CONTINUE 1184 - * Next a list of Fill Area attributes. 1185 - DO 360 I=1,NFAR 1186 - READ(12,'(A20,2I10,4E15.8,A20)',END=2000,ERR=2010,IOSTAT=IOS) 1187 - - FARNAM(I),FARINT(I),FARSTY(I),FARPAS(1,I),FARPAS(2,I), 1188 - - FARREF(1,I),FARREF(2,I),AUX(1:20) 1189 - CALL GRCOLQ(IWKID,AUX(1:20),FCR) 1190 - IF(FCR.GE.0)THEN 1191 - FARCOL(I)=FCR 1192 - ELSE 1193 - PRINT *,' !!!!!! GRATTG WARNING : The member contains a'// 1194 - - ' colour absent in the colour tables: '//AUX(1:20) 1195 - CALL INPFIX(FARNAM(I),AUX,NC) 1196 - PRINT *,' The FOREGROUND colour'// 1197 - - ' will be used to represent item '//AUX(1:NC)//'.' 1198 - FARCOL(I)=1 1199 - ENDIF 1200 - 360 CONTINUE 1201 - ** Close the file after the operation. 1202 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 1203 - CALL TIMLOG('Reading in graphics representations: ') 1204 - IFAIL=0 1205 - RETURN 1206 - *** Handle the error conditions. 1207 - 2000 CONTINUE 1208 - PRINT *,' ###### GRATTG ERROR : Premature EOF ecountered on '// 1209 - - FILE(1:NCFILE)//' read via unit 12 ; no valid data read.' 1210 - CALL INPIOS(IOS) 1211 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 1212 - RETURN 1213 - 2010 CONTINUE 1214 - PRINT *,' ###### GRATTW ERROR : I/O error accessing '// 1215 - - FILE(1:NCFILE)//' via unit 12 ; no data read or written.' 1216 - CALL INPIOS(IOS) 1217 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 1218 - RETURN 1219 - 2030 CONTINUE 1220 - PRINT *,' ###### GRATTW ERROR : Dataset '//FILE(1:NCFILE)// 1221 - - ' unit 12 cannot be closed ; results not predictable' 1222 - CALL INPIOS(IOS) 1223 - END 1 130 GARFIELD ================================================== P=GRAPHICS D=GRASET 1 =================== PAGE 216 0 + +DECK,GRASET. 1 - SUBROUTINE GRASET(QXMIN,QYMIN,QZMIN,QXMAX,QYMAX,QZMAX) 2 - *----------------------------------------------------------------------- 3 - * GRASET - Sets the default area. 4 - * (Last changed on 8/10/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9 - REAL QXMIN,QYMIN,QZMIN,QXMAX,QYMAX,QZMAX 10 - *** Copy the limits in double precision. 11 - GXMIN=DBLE(QXMIN) 12 - GYMIN=DBLE(QYMIN) 13 - GZMIN=DBLE(QZMIN) 14 - GXMAX=DBLE(QXMAX) 15 - GYMAX=DBLE(QYMAX) 16 - GZMAX=DBLE(QZMAX) 17 - END 131 GARFIELD ================================================== P=GRAPHICS D=GRCELL 1 ============================ 0 + +DECK,GRCELL. 1 - SUBROUTINE GRCELL(VXMIN,VYMIN,VXMAX,VYMAX,TITLE) 2 - *----------------------------------------------------------------------- 3 - * GRCELL - Draws the cell within the specified region. 4 - * (Last changed on 12/11/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,FIELDMAP. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,PARAMETERS. 12.- +SEQ,GRAPHICS. 13 - DOUBLE PRECISION VVXMIN,VVYMIN,VVXMAX,VVYMAX 14 - REAL VXMIN,VYMIN,VXMAX,VYMAX 15 - CHARACTER*(*) TITLE 16 - *** R-PHI type view. 17 - IF(POLAR.OR.PRVIEW.EQ.'R-PHI')THEN 18 - CALL GRAPOL(REAL(GXMIN),REAL(GYMIN),REAL(GXMAX),REAL(GYMAX), 19 - - 'Radial distances are in cm ', 20 - - 'Angles are in degrees ',TITLE) 21 - CALL CELLAY(REAL(GXMIN),REAL(GYMIN),REAL(GXMAX),REAL(GYMAX)) 22 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 23 - VXMIN=REAL(GXMIN) 24 - VYMIN=REAL(GYMIN) 25 - VXMAX=REAL(GXMAX) 26 - VYMAX=REAL(GYMAX) 27 - *** X-Y type view. 28 - ELSEIF(PRVIEW.EQ.'X-Y')THEN 29 - CALL GRCART(REAL(GXMIN),REAL(GYMIN),REAL(GXMAX),REAL(GYMAX), 30 - - 'x-Axis [cm]','y-Axis [cm]',TITLE) 31 - CALL CELLAY(REAL(GXMIN),REAL(GYMIN),REAL(GXMAX),REAL(GYMAX)) 32 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 33 - VXMIN=REAL(GXMIN) 34 - VYMIN=REAL(GYMIN) 35 - VXMAX=REAL(GXMAX) 36 - VYMAX=REAL(GYMAX) 37 - *** X-Z type view. 38 - ELSEIF(PRVIEW.EQ.'X-Z')THEN 39 - CALL GRCART(REAL(GXMIN),REAL(GZMIN),REAL(GXMAX),REAL(GZMAX), 40 - - 'x-Axis [cm]','z-Axis [cm]',TITLE) 41 - IF(LMAPPL)CALL MAPPLT(REAL(GXMIN),REAL(GYMIN),REAL(GZMIN), 42 - - REAL(GXMAX),REAL(GYMAX),REAL(GZMAX)) 43 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 44 - VXMIN=REAL(GXMIN) 45 - VYMIN=REAL(GZMIN) 46 - VXMAX=REAL(GXMAX) 47 - VYMAX=REAL(GZMAX) 48 - *** Y-Z type view. 49 - ELSEIF(PRVIEW.EQ.'Y-Z')THEN 50 - CALL GRCART(REAL(GYMIN),REAL(GZMIN),REAL(GYMAX),REAL(GZMAX), 51 - - 'y-Axis [cm]','z-Axis [cm]',TITLE) 52 - IF(LMAPPL)CALL MAPPLT(REAL(GXMIN),REAL(GYMIN),REAL(GZMIN), 53 - - REAL(GXMAX),REAL(GYMAX),REAL(GZMAX)) 54 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 55 - VXMIN=REAL(GYMIN) 56 - VYMIN=REAL(GZMIN) 57 - VXMAX=REAL(GYMAX) 58 - VYMAX=REAL(GZMAX) 59 - *** CUT type view. 60 - ELSEIF(PRVIEW.EQ.'CUT')THEN 61 - CALL GRAXIC(VVXMIN,VVYMIN,VVXMAX,VVYMAX,TITLE,'PLOT') 62 - CALL CELLAC(VVXMIN,VVYMIN,VVXMAX,VVYMAX) 63 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 64 - VXMIN=REAL(VVXMIN) 65 - VYMIN=REAL(VVYMIN) 66 - VXMAX=REAL(VVXMAX) 67 - VYMAX=REAL(VVYMAX) 68 - *** 3D type view. 69 - ELSEIF(PRVIEW.EQ.'3D')THEN 70 - CALL GRAXI3(VVXMIN,VVYMIN,VVXMAX,VVYMAX, 71 - - 'x-Axis','y-Axis','z-Axis',TITLE,'PLOT') 72 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 73 - VXMIN=REAL(VVXMIN) 74 - VYMIN=REAL(VVYMIN) 75 - VXMAX=REAL(VVXMAX) 76 - VYMAX=REAL(VVYMAX) 77 - *** Other projections are not known currently. 78 - ELSE 79 - PRINT *,' !!!!!! GRCELL WARNING : Projection ',PRVIEW, 80 - - ' is not known; using Cartesian projection.' 81 - CALL GRCART(REAL(GXMIN),REAL(GYMIN),REAL(GXMAX),REAL(GYMAX), 82 - - 'x-Axis [cm]','y-Axis [cm]',TITLE) 83 - CALL CELLAY(REAL(GXMIN),REAL(GYMIN),REAL(GXMAX),REAL(GYMAX)) 84 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 1 131 P=GRAPHICS D=GRCELL 2 PAGE 217 85 - VXMIN=REAL(GXMIN) 86 - VYMIN=REAL(GYMIN) 87 - VXMAX=REAL(GXMAX) 88 - VYMAX=REAL(GYMAX) 89 - ENDIF 90 - *** Get the viewport input priorities right. 91 - CALL GSVPIP(1,0,0) 92 - END 132 GARFIELD ================================================== P=GRAPHICS D=GRVIEW 1 ============================ 0 + +DECK,GRVIEW. 1 - SUBROUTINE GRVIEW(VXMIN,VYMIN,VXMAX,VYMAX) 2 - *----------------------------------------------------------------------- 3 - * GRVIEW - Computes the view limits of the current projection. 4 - * (Last changed on 8/10/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,PARAMETERS. 11.- +SEQ,GRAPHICS. 12 - DOUBLE PRECISION VVXMIN,VVYMIN,VVXMAX,VVYMAX 13 - REAL VXMIN,VYMIN,VXMAX,VYMAX 14 - *** R-PHI and X-Y types view. 15 - IF(POLAR.OR.PRVIEW.EQ.'R-PHI'.OR.PRVIEW.EQ.'X-Y')THEN 16 - VXMIN=REAL(GXMIN) 17 - VYMIN=REAL(GYMIN) 18 - VXMAX=REAL(GXMAX) 19 - VYMAX=REAL(GYMAX) 20 - *** X-Z type view. 21 - ELSEIF(PRVIEW.EQ.'X-Z')THEN 22 - VXMIN=REAL(GXMIN) 23 - VYMIN=REAL(GZMIN) 24 - VXMAX=REAL(GXMAX) 25 - VYMAX=REAL(GZMAX) 26 - *** Y-Z type view. 27 - ELSEIF(PRVIEW.EQ.'Y-Z')THEN 28 - VXMIN=REAL(GYMIN) 29 - VYMIN=REAL(GZMIN) 30 - VXMAX=REAL(GYMAX) 31 - VYMAX=REAL(GZMAX) 32 - *** CUT type view. 33 - ELSEIF(PRVIEW.EQ.'CUT')THEN 34 - CALL GRAXIC(VVXMIN,VVYMIN,VVXMAX,VVYMAX,' ','VIEW') 35 - VXMIN=REAL(VVXMIN) 36 - VYMIN=REAL(VVYMIN) 37 - VXMAX=REAL(VVXMAX) 38 - VYMAX=REAL(VVYMAX) 39 - *** 3D type view. 40 - ELSEIF(PRVIEW.EQ.'3D')THEN 41 - CALL GRAXI3(VVXMIN,VVYMIN,VVXMAX,VVYMAX, 42 - - ' ',' ',' ',' ','VIEW') 43 - VXMIN=REAL(VVXMIN) 44 - VYMIN=REAL(VVYMIN) 45 - VXMAX=REAL(VVXMAX) 46 - VYMAX=REAL(VVYMAX) 47 - *** Other projections are not known currently. 48 - ELSE 49 - PRINT *,' !!!!!! GRVIEW WARNING : Projection ',PRVIEW, 50 - - ' is not known; using Cartesian projection.' 51 - VXMIN=REAL(GXMIN) 52 - VYMIN=REAL(GYMIN) 53 - VXMAX=REAL(GXMAX) 54 - VYMAX=REAL(GYMAX) 55 - ENDIF 56 - END 133 GARFIELD ================================================== P=GRAPHICS D=GRAXIC 1 ============================ 0 + +DECK,GRAXIC. 1 - SUBROUTINE GRAXIC(VXMIN,VYMIN,VXMAX,VYMAX,TITLE,OPTION) 2 - *----------------------------------------------------------------------- 3 - * GRAXIC - Draws axis for the cell, using any kind of axis, 4 - * respecting the viewing plane labels. 5 - * Variables : VXMIN etc : Viewing area limits. 6 - * TITLE : Global title. 7 - * OPTION : VIEW (compute view) or PLOT (plot frame) 8 - * (Last changed on 8/10/98.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,PARAMETERS. 13.- +SEQ,CONSTANTS. 14.- +SEQ,GRAPHICS. 15.- +SEQ,CELLDATA. 16 - CHARACTER*(*) TITLE,OPTION 17 - DOUBLE PRECISION XX(8),YY(8),ZZ(8), 18 - - XPL(40),YPL(40),ZPL(40),XCUT,YCUT,VXMIN,VXMAX,VYMIN,VYMAX, 19 - - PHIARR,U4,U1,U2,U3,V4,V1,V2,V3,UUMIN,UUMAX,VVMIN,VVMAX 20 - INTEGER I,J,NPL,II,JJ,IADJAC(8,3),IMARK,ITYPE 21 - LOGICAL IN(8),CROSSD,CUT,PLOTX,PLOTY 22 - EXTERNAL CROSSD 23 - DATA (IADJAC(I,1),I=1,8) /2, 1, 1, 2, 1, 2, 3, 4/ 24 - DATA (IADJAC(I,2),I=1,8) /3, 4, 4, 3, 6, 5, 5, 6/ 25 - DATA (IADJAC(I,3),I=1,8) /5, 6, 7, 8, 7, 8, 8, 7/ 0 26-+ +SELF,IF=SAVE. 27 - SAVE IADJAC 0 28-+ +SELF. 29 - *** Initialise the list of corners. 30 - DO 10 I=1,8 31 - IN(I)=.FALSE. 32 - IF(2*(I/2).EQ.I)THEN 1 133 P=GRAPHICS D=GRAXIC 2 PAGE 218 33 - XX(I)=GXMAX 34 - ELSE 35 - XX(I)=GXMIN 36 - ENDIF 37 - II=(I+1)/2 38 - IF(2*(II/2).EQ.II)THEN 39 - YY(I)=GYMAX 40 - ELSE 41 - YY(I)=GYMIN 42 - ENDIF 43 - II=(II+1)/2 44 - IF(2*(II/2).EQ.II)THEN 45 - ZZ(I)=GZMAX 46 - ELSE 47 - ZZ(I)=GZMIN 48 - ENDIF 49 - 10 CONTINUE 50 - *** Add the corners of the box that are in the viewing plane. 51 - NPL=0 52 - DO 20 I=1,8 53 - IF(ABS(FPROJA*XX(I)+FPROJB*YY(I)+FPROJC*ZZ(I)-FPROJD).LT. 54 - - 1.0D-6*MAX(ABS(XX(I)),ABS(YY(I)),ABS(ZZ(I)), 55 - - ABS(FPROJA),ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))THEN 56 - IN(I)=.TRUE. 57 - CALL PLACOO(XX(I),YY(I),ZZ(I),XCUT,YCUT) 58 - NPL=NPL+1 59 - XPL(NPL)=XCUT 60 - YPL(NPL)=YCUT 61 - ENDIF 62 - 20 CONTINUE 63 - *** Cut the 12 edges with the viewing plane. 64 - DO 30 I=1,8 65 - DO 40 JJ=1,3 66 - J=IADJAC(I,JJ) 67 - IF(J.LT.I)GOTO 40 68 - IF(.NOT.(IN(I).OR.IN(J)))THEN 69 - CALL PLACUT(XX(I),YY(I),ZZ(I),XX(J),YY(J),ZZ(J), 70 - - XCUT,YCUT,CUT) 71 - IF(CUT)THEN 72 - NPL=NPL+1 73 - XPL(NPL)=XCUT 74 - YPL(NPL)=YCUT 75 - ENDIF 76 - ENDIF 77 - 40 CONTINUE 78 - 30 CONTINUE 79 - *** Ensure there is no butterfly. 80 - DO 70 I=1,NPL 81 - ZPL(I)=0 82 - 70 CONTINUE 83 - CALL BUTFLD(NPL,XPL,YPL,ZPL) 84 - *** Determine the minimum Cartesian frame that fits around this. 85 - IF(NPL.EQ.0)THEN 86 - PRINT *,' !!!!!! GRAXIC WARNING : AREA has no point in'// 87 - - ' common with the viewing plane; unit frame.' 88 - VXMIN=-1 89 - VXMAX=+1 90 - VYMIN=-1 91 - VYMAX=+1 92 - IMARK=0 93 - ITYPE=0 94 - ELSEIF(NPL.EQ.1)THEN 95 - PRINT *,' !!!!!! GRAXIC WARNING : AREA has only a point'// 96 - - ' in the viewing plane; unit sized frame.' 97 - VXMIN=XPL(1)-1 98 - VXMAX=XPL(1)+1 99 - VYMIN=YPL(1)-1 100 - VYMAX=YPL(1)+1 101 - IMARK=0 102 - ITYPE=0 103 - ELSEIF(NPL.EQ.2)THEN 104 - PRINT *,' !!!!!! GRAXIC WARNING : AREA has only a line'// 105 - - ' in the viewing plane; frame enlarged.' 106 - VXMIN=MIN(XPL(1),XPL(2))-1 107 - VXMAX=MAX(XPL(1),XPL(2))+1 108 - VYMIN=MIN(YPL(1),YPL(2))-1 109 - VYMAX=MAX(YPL(1),YPL(2))+1 110 - IMARK=0 111 - ITYPE=0 112 - ELSE 113 - IMARK=0 114 - ITYPE=0 115 - VXMIN=XPL(1)+ABS(XPL(1))+1 116 - VXMAX=XPL(1)-ABS(XPL(1))-1 117 - VYMIN=YPL(1)+ABS(YPL(1))+1 118 - VYMAX=YPL(1)-ABS(YPL(1))-1 119 - DO 50 I=1,NPL 120 - IF(VXMIN.GT.XPL(I))THEN 121 - VXMIN=XPL(I) 122 - IMARK=I 123 - ITYPE=2 124 - ENDIF 125 - IF(VXMAX.LT.XPL(I))THEN 126 - VXMAX=XPL(I) 127 - IMARK=I 128 - ITYPE=4 129 - ENDIF 130 - IF(VYMIN.GT.YPL(I))THEN 131 - VYMIN=YPL(I) 132 - IMARK=I 133 - ITYPE=1 134 - ENDIF 135 - IF(VYMAX.LT.YPL(I))THEN 136 - VYMAX=YPL(I) 137 - IMARK=I 138 - ITYPE=3 1 133 P=GRAPHICS D=GRAXIC 3 PAGE 219 139 - ENDIF 140 - 50 CONTINUE 141 - ENDIF 142 - *** Return here unless OPTION has been set to PLOT. 143 - IF(OPTION.NE.'PLOT')RETURN 144 - *** Plot a coordinate frame. 145 - CALL GRCART(REAL(VXMIN),REAL(VYMIN),REAL(VXMAX),REAL(VYMAX), 146 - - PXLAB(1:NCXLAB),PYLAB(1:NCYLAB),TITLE) 147 - IF(PROLAB(1:NCFPRO).NE.'z=0')CALL GRCOMM(5,'Viewing plane: '// 148 - - PROLAB(1:NCFPRO)) 149 - *** Plot the outline that corresponds to the AREA. 150 - IF(NPL.GT.2.AND.NPL+IMARK+5.LT.40.AND.ITYPE.NE.0.AND. 151 - - IMARK.NE.0)THEN 152 - * Mark the area outsize the AREA. 153 - DO 60 I=1,NPL 154 - IF(I.GT.NPL-IMARK+1)THEN 155 - XPL(I+IMARK-1)=XPL(I+IMARK-1-NPL) 156 - YPL(I+IMARK-1)=YPL(I+IMARK-1-NPL) 157 - ENDIF 158 - 60 CONTINUE 159 - XPL(NPL+IMARK)=XPL(IMARK) 160 - YPL(NPL+IMARK)=YPL(IMARK) 161 - IF(ITYPE.EQ.1)THEN 162 - XPL(NPL+IMARK+1)=VXMIN 163 - YPL(NPL+IMARK+1)=VYMIN 164 - XPL(NPL+IMARK+2)=VXMIN 165 - YPL(NPL+IMARK+2)=VYMAX 166 - XPL(NPL+IMARK+3)=VXMAX 167 - YPL(NPL+IMARK+3)=VYMAX 168 - XPL(NPL+IMARK+4)=VXMAX 169 - YPL(NPL+IMARK+4)=VYMIN 170 - XPL(NPL+IMARK+5)=VXMIN 171 - YPL(NPL+IMARK+5)=VYMIN 172 - ELSEIF(ITYPE.EQ.2)THEN 173 - XPL(NPL+IMARK+1)=VXMIN 174 - YPL(NPL+IMARK+1)=VYMAX 175 - XPL(NPL+IMARK+2)=VXMAX 176 - YPL(NPL+IMARK+2)=VYMAX 177 - XPL(NPL+IMARK+3)=VXMAX 178 - YPL(NPL+IMARK+3)=VYMIN 179 - XPL(NPL+IMARK+4)=VXMIN 180 - YPL(NPL+IMARK+4)=VYMIN 181 - XPL(NPL+IMARK+5)=VXMIN 182 - YPL(NPL+IMARK+5)=VYMAX 183 - ELSEIF(ITYPE.EQ.3)THEN 184 - XPL(NPL+IMARK+1)=VXMAX 185 - YPL(NPL+IMARK+1)=VYMAX 186 - XPL(NPL+IMARK+2)=VXMAX 187 - YPL(NPL+IMARK+2)=VYMIN 188 - XPL(NPL+IMARK+3)=VXMIN 189 - YPL(NPL+IMARK+3)=VYMIN 190 - XPL(NPL+IMARK+4)=VXMIN 191 - YPL(NPL+IMARK+4)=VYMAX 192 - XPL(NPL+IMARK+5)=VXMAX 193 - YPL(NPL+IMARK+5)=VYMAX 194 - ELSEIF(ITYPE.EQ.4)THEN 195 - XPL(NPL+IMARK+1)=VXMAX 196 - YPL(NPL+IMARK+1)=VYMIN 197 - XPL(NPL+IMARK+2)=VXMIN 198 - YPL(NPL+IMARK+2)=VYMIN 199 - XPL(NPL+IMARK+3)=VXMIN 200 - YPL(NPL+IMARK+3)=VYMAX 201 - XPL(NPL+IMARK+4)=VXMAX 202 - YPL(NPL+IMARK+4)=VYMAX 203 - XPL(NPL+IMARK+5)=VXMAX 204 - YPL(NPL+IMARK+5)=VYMIN 205 - ENDIF 206 - XPL(NPL+IMARK+6)=XPL(IMARK) 207 - YPL(NPL+IMARK+6)=YPL(IMARK) 208 - * Fill the excluded area. 209 - CALL GRATTS('OUTSIDE-AREA','AREA') 210 - CALL GRARE2(NPL+7,XPL(IMARK),YPL(IMARK)) 211 - * Outline. 212 - CALL GRATTS('BOX-TICKMARKS','POLYLINE') 213 - CALL GRLIN2(NPL+6,XPL(IMARK),YPL(IMARK)) 214 - ENDIF 215 - *** Display the coordinate axes, first compute locations. 216 - IF(PROLAB(1:NCFPRO).NE.'z=0'.OR.PROROT.NE.0)THEN 217 - CALL PLACOO(0.0D0,0.0D0,0.0D0,U4,V4) 218 - CALL PLACOO(1.0D0,0.0D0,0.0D0,U1,V1) 219 - CALL PLACOO(0.0D0,1.0D0,0.0D0,U2,V2) 220 - CALL PLACOO(0.0D0,0.0D0,1.0D0,U3,V3) 221 - UUMIN=MIN(U4,U1,U2,U3) 222 - UUMAX=MAX(U4,U1,U2,U3) 223 - VVMIN=MIN(V4,V1,V2,V3) 224 - VVMAX=MAX(V4,V1,V2,V3) 225 - ENDIF 226 - * Proceed only if this worked and if the frame is not degenerate. 227 - IF(MAX(UUMAX-UUMIN,VVMAX-VVMIN).GT.0.AND. 228 - - (PROLAB(1:NCFPRO).NE.'z=0'.OR.PROROT.NE.0))THEN 229 - U4=0.02+0.06*(U4-UUMIN)/MAX(UUMAX-UUMIN,VVMAX-VVMIN) 230 - U1=0.02+0.06*(U1-UUMIN)/MAX(UUMAX-UUMIN,VVMAX-VVMIN) 231 - U2=0.02+0.06*(U2-UUMIN)/MAX(UUMAX-UUMIN,VVMAX-VVMIN) 232 - U3=0.02+0.06*(U3-UUMIN)/MAX(UUMAX-UUMIN,VVMAX-VVMIN) 233 - V4=0.02+0.06*(V4-VVMIN)/MAX(UUMAX-UUMIN,VVMAX-VVMIN) 234 - V1=0.02+0.06*(V1-VVMIN)/MAX(UUMAX-UUMIN,VVMAX-VVMIN) 235 - V2=0.02+0.06*(V2-VVMIN)/MAX(UUMAX-UUMIN,VVMAX-VVMIN) 236 - V3=0.02+0.06*(V3-VVMIN)/MAX(UUMAX-UUMIN,VVMAX-VVMIN) 237 - * Set representations. 238 - CALL GRATTS('BOX-TICKMARKS','POLYLINE') 239 - CALL GRATTS('NUMBERS','TEXT') 240 - CALL GSTXAL(2,3) 241 - CALL GSCHUP(0.0,1.0) 242 - * Switch to normalisation transformation 0. 243 - CALL GSELNT(0) 244 - * Plot the x-axis. 1 133 P=GRAPHICS D=GRAXIC 4 PAGE 220 245 - IF(ABS(U1-U4).GT.0.001.OR.ABS(V1-V4).GT.0.001)THEN 246 - XPL(1)=U4 247 - XPL(2)=U1 248 - YPL(1)=V4 249 - YPL(2)=V1 250 - CALL GPL2(2,XPL,YPL) 251 - PHIARR=ATAN2(YPL(2)-YPL(1),XPL(2)-XPL(1)) 252 - XPL(1)=U1-SQRT((U1-U4)**2+(V1-V4)**2)* 253 - - 0.2*COS(PHIARR+ARRANG) 254 - YPL(1)=V1-SQRT((U1-U4)**2+(V1-V4)**2)* 255 - - 0.2*SIN(PHIARR+ARRANG) 256 - XPL(2)=U1 257 - YPL(2)=V1 258 - XPL(3)=U1-SQRT((U1-U4)**2+(V1-V4)**2)* 259 - - 0.2*COS(PHIARR-ARRANG) 260 - YPL(3)=V1-SQRT((U1-U4)**2+(V1-V4)**2)* 261 - - 0.2*SIN(PHIARR-ARRANG) 262 - CALL GPL2(3,XPL,YPL) 263 - CALL GTX(REAL(U4+1.2*(U1-U4)), 264 - - REAL(V4+1.2*(V1-V4)),'x') 265 - PLOTX=.TRUE. 266 - ELSE 267 - PLOTX=.FALSE. 268 - ENDIF 269 - * Plot the y-axis, if different from the x-axis. 270 - IF((ABS(U2-U4).GT.0.001.OR.ABS(V2-V4).GT.0.001).AND. 271 - - (ABS(U2-U1).GT.0.001.OR.ABS(V2-V1).GT.0.001.OR. 272 - - .NOT.PLOTX))THEN 273 - XPL(1)=U4 274 - XPL(2)=U2 275 - YPL(1)=V4 276 - YPL(2)=V2 277 - CALL GPL2(2,XPL,YPL) 278 - PHIARR=ATAN2(YPL(2)-YPL(1),XPL(2)-XPL(1)) 279 - XPL(1)=U2-SQRT((U2-U4)**2+(V2-V4)**2)* 280 - - 0.2*COS(PHIARR+ARRANG) 281 - YPL(1)=V2-SQRT((U2-U4)**2+(V2-V4)**2)* 282 - - 0.2*SIN(PHIARR+ARRANG) 283 - XPL(2)=U2 284 - YPL(2)=V2 285 - XPL(3)=U2-SQRT((U2-U4)**2+(V2-V4)**2)* 286 - - 0.2*COS(PHIARR-ARRANG) 287 - YPL(3)=V2-SQRT((U2-U4)**2+(V2-V4)**2)* 288 - - 0.2*SIN(PHIARR-ARRANG) 289 - CALL GPL2(3,XPL,YPL) 290 - CALL GTX(REAL(U4+1.2*(U2-U4)), 291 - - REAL(V4+1.2*(V2-V4)),'y') 292 - PLOTY=.TRUE. 293 - ELSE 294 - PLOTY=.FALSE. 295 - ENDIF 296 - * Plot the z-axis, if different from the x- and y-axes. 297 - IF((ABS(U3-U4).GT.0.001.OR.ABS(V3-V4).GT.0.001).AND. 298 - - (ABS(U3-U1).GT.0.001.OR.ABS(V3-V1).GT.0.001.OR. 299 - - .NOT.PLOTX).AND. 300 - - (ABS(U3-U2).GT.0.001.OR.ABS(V3-V2).GT.0.001.OR. 301 - - .NOT.PLOTY))THEN 302 - XPL(1)=U4 303 - XPL(2)=U3 304 - YPL(1)=V4 305 - YPL(2)=V3 306 - CALL GPL2(2,XPL,YPL) 307 - PHIARR=ATAN2(YPL(2)-YPL(1),XPL(2)-XPL(1)) 308 - XPL(1)=U3-SQRT((U3-U4)**2+(V3-V4)**2)* 309 - - 0.2*COS(PHIARR+ARRANG) 310 - YPL(1)=V3-SQRT((U3-U4)**2+(V3-V4)**2)* 311 - - 0.2*SIN(PHIARR+ARRANG) 312 - XPL(2)=U3 313 - YPL(2)=V3 314 - XPL(3)=U3-SQRT((U3-U4)**2+(V3-V4)**2)* 315 - - 0.2*COS(PHIARR-ARRANG) 316 - YPL(3)=V3-SQRT((U3-U4)**2+(V3-V4)**2)* 317 - - 0.2*SIN(PHIARR-ARRANG) 318 - CALL GPL2(3,XPL,YPL) 319 - CALL GTX(REAL(U4+1.2*(U3-U4)), 320 - - REAL(V4+1.2*(V3-V4)),'z') 321 - ENDIF 322 - * Switch back to normalisation transformation 1. 323 - CALL GSELNT(1) 324 - ENDIF 325 - *** Get the viewport input priorities right. 326 - CALL GSVPIP(1,0,0) 327 - END 134 GARFIELD ================================================== P=GRAPHICS D=GRAXI3 1 ============================ 0 + +DECK,GRAXI3. 1 - SUBROUTINE GRAXI3(VXMIN,VYMIN,VXMAX,VYMAX, 2 - - XTXT,YTXT,ZTXT,TITLE,OPTION) 3 - *---------------------------------------------------------------------- 4 - * GRAXI3 - Plots axes for a 3D view, with tickmarks along them. 5 - * VARIABLES : VXMIN etc : View limits. 6 - * [X/Y/Z]TXT : Labels for the x, y and z axes 7 - * TITLE : Global title. 8 - * OPTION : VIEW (compute view) or PLOT (plot frame). 9 - * (Last changed on 8/10/98.) 10 - *---------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,PARAMETERS. 14.- +SEQ,GRAPHICS. 15.- +SEQ,CONSTANTS. 16.- +SEQ,PRINTPLOT. 17 - DOUBLE PRECISION XU(101),YU(101), 18 - - XUTOD,YUTOD,X,Y,DX,DY,DZ, 19 - - TICKX,TICKY,TICKZ,XVAL,YVAL,ZVAL,XSC,YSC,XAUX,YAUX, 1 134 P=GRAPHICS D=GRAXI3 2 PAGE 221 20 - - X1,X2,X3,X4,X5,X6,X7,X8,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8, 21 - - XLAB,YLAB,ZLAB,QLAB,XSHIFT,YSHIFT,SNORM,XPERP,YPERP, 22 - - WW,ASPECT,VXMIN,VYMIN,VXMAX,VYMAX 23 - INTEGER KX,KKX,KY,KKY,KZ,KKZ,NCTICK,NC,I,ICOL 24 - LOGICAL INVERT,SEEN(12) 25 - CHARACTER*(*) XTXT,YTXT,ZTXT,TITLE,OPTION 26 - CHARACTER*80 STRING 27 - CHARACTER*13 TICK 28 - *** Define 2 statement function to convert from USER to DISP. 29 - XUTOD(X)=DISPX0+(DISPX1-DISPX0)*(X-USERX0)/(USERX1-USERX0) 30 - YUTOD(Y)=DISPY0+(DISPY1-DISPY0)*(Y-USERY0)/(USERY1-USERY0) 31 - *** Output the requested area, if debugging is requested. 32 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRAXI3 DEBUG :'', 33 - - '' Requested area is ''/26X,''('',E10.3,'','',E10.3,'','', 34 - - E10.3,'') to''/26X,''('',E10.3,'','',E10.3,'','',E10.3, 35 - - '')'')') GXMIN,GYMIN,GZMIN,GXMAX,GYMAX,GZMAX 36 - *** Compute dimensions of projected box. 37 - CALL PLACOO(GXMIN,GYMIN,GZMIN,X1,Y1) 38 - CALL PLACOO(GXMIN,GYMIN,GZMAX,X2,Y2) 39 - CALL PLACOO(GXMIN,GYMAX,GZMIN,X3,Y3) 40 - CALL PLACOO(GXMIN,GYMAX,GZMAX,X4,Y4) 41 - CALL PLACOO(GXMAX,GYMIN,GZMIN,X5,Y5) 42 - CALL PLACOO(GXMAX,GYMIN,GZMAX,X6,Y6) 43 - CALL PLACOO(GXMAX,GYMAX,GZMIN,X7,Y7) 44 - CALL PLACOO(GXMAX,GYMAX,GZMAX,X8,Y8) 45 - *** Compute frame size. 46 - VXMIN=MIN(X1,X2,X3,X4,X5,X6,X7,X8) 47 - VXMAX=MAX(X1,X2,X3,X4,X5,X6,X7,X8) 48 - VYMIN=MIN(Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8) 49 - VYMAX=MAX(Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8) 50 - *** Return here unless OPTION has been set to PLOT. 51 - IF(OPTION.NE.'PLOT')RETURN 52 - *** Store frame size. 53 - FRXMIN=VXMIN 54 - FRXMAX=VXMAX 55 - FRYMIN=VYMIN 56 - FRYMAX=VYMAX 57 - IF(FRXMAX.EQ.FRXMIN)THEN 58 - PRINT *,' !!!!!! GRAXI3 WARNING : Frame has zero size in'// 59 - - ' x; enlarged.' 60 - FRXMIN=FRXMIN-2*ABS(FRXMIN)-1 61 - FRXMAX=FRXMAX+2*ABS(FRXMAX)+1 62 - ENDIF 63 - IF(FRYMAX.EQ.FRYMIN)THEN 64 - PRINT *,' !!!!!! GRAXI3 WARNING : Frame has zero size in'// 65 - - ' y; enlarged.' 66 - FRYMIN=FRYMIN-2*ABS(FRYMIN)-1 67 - FRYMAX=FRYMAX+2*ABS(FRYMAX)+1 68 - ENDIF 69 - *** Compute aspect ratio. 70 - IF(FRYMAX.EQ.FRYMIN.OR.FRXMAX.EQ.FRXMIN)THEN 71 - ASPECT=1 72 - PRINT *,' !!!!!! GRAXI3 WARNING : Aspect ratio 0'// 73 - - ' or infinite; set to 1 (program bug)' 74 - ELSE 75 - ASPECT=SQRT(ABS((FRXMAX-FRXMIN)/(FRYMAX-FRYMIN))) 76 - ENDIF 77 - *** Switch to graphics mode. 78 - CALL GRGRAF(.TRUE.) 79 - *** Define display area of frame. 80 - CALL GSVP(1,DISPX0,DISPX1,DISPY0,DISPY1) 81 - *** Define the user area in the plot frame. 82 - USERX0=FRXMIN-0.1*(FRXMAX-FRXMIN)/(DISPX1-DISPX0-0.2) 83 - USERX1=FRXMAX+0.1*(FRXMAX-FRXMIN)/(DISPX1-DISPX0-0.2) 84 - USERY0=FRYMIN-0.1*(FRYMAX-FRYMIN)/(DISPY1-DISPY0-0.2) 85 - USERY1=FRYMAX+0.1*(FRYMAX-FRYMIN)/(DISPY1-DISPY0-0.2) 86 - CALL GSWN(1,USERX0,USERX1,USERY0,USERY1) 87 - CALL GSTXP(0) 88 - *** Shade the planes in which the light shines, set the representation. 89 - CALL GSELNT(1) 90 - CALL GRATTS('BOX-TICKMARKS','AREA') 91 - CALL GRATTS('BOX-TICKMARKS','POLYLINE') 92 - * Generate the colour table. 93 - IF(ICOLBX.EQ.0)THEN 94 - ICOLBX=ICOL0 95 - CALL COLSHD(ICOLBX) 96 - ICOL0=ICOL0+NPRCOL 97 - ENDIF 98 - * Set the SEEN flags for the edges of the box. 99 - DO 100 I=1,12 100 - SEEN(I)=.FALSE. 101 - 100 CONTINUE 102 - * The x=xmin plane. 103 - IF(FPROJA.GT.0)THEN 104 - CALL COLWGT(+1.0D0,0.0D0,0.0D0,WW) 105 - IF(WW.GE.0)THEN 106 - ICOL=ICOLBX+2+MIN(NINT(WW*(NPRCOL-1)),NPRCOL-3) 107 - ELSE 108 - ICOL=ICOLBX 109 - PRINT *,' !!!!!! GRAXI3 WARNING : Request to plot'// 110 - - ' a face seen from the back (program bug).' 111 - ENDIF 112 - CALL GSFACI(ICOL) 113 - XU(1)=X1 114 - YU(1)=Y1 115 - XU(2)=X3 116 - YU(2)=Y3 117 - XU(3)=X4 118 - YU(3)=Y4 119 - XU(4)=X2 120 - YU(4)=Y2 121 - XU(5)=X1 122 - YU(5)=Y1 123 - CALL GFA2(5,XU,YU) 124 - CALL GPL2(5,XU,YU) 125 - SEEN(1)=.TRUE. 1 134 P=GRAPHICS D=GRAXI3 3 PAGE 222 126 - SEEN(2)=.TRUE. 127 - SEEN(3)=.TRUE. 128 - SEEN(4)=.TRUE. 129 - * Or the x=xmax plane. 130 - ELSEIF(FPROJA.LT.0)THEN 131 - CALL COLWGT(-1.0D0,0.0D0,0.0D0,WW) 132 - IF(WW.GE.0)THEN 133 - ICOL=ICOLBX+2+MIN(NINT(WW*(NPRCOL-1)),NPRCOL-3) 134 - ELSE 135 - ICOL=ICOLBX 136 - PRINT *,' !!!!!! GRAXI3 WARNING : Request to plot'// 137 - - ' a face seen from the back (program bug).' 138 - ENDIF 139 - CALL GSFACI(ICOL) 140 - XU(1)=X5 141 - YU(1)=Y5 142 - XU(2)=X7 143 - YU(2)=Y7 144 - XU(3)=X8 145 - YU(3)=Y8 146 - XU(4)=X6 147 - YU(4)=Y6 148 - XU(5)=X5 149 - YU(5)=Y5 150 - CALL GFA2(5,XU,YU) 151 - CALL GPL2(5,XU,YU) 152 - SEEN(5)=.TRUE. 153 - SEEN(6)=.TRUE. 154 - SEEN(7)=.TRUE. 155 - SEEN(8)=.TRUE. 156 - ENDIF 157 - * The y=ymin plane. 158 - IF(FPROJB.GT.0)THEN 159 - CALL COLWGT(0.0D0,+1.0D0,0.0D0,WW) 160 - IF(WW.GE.0)THEN 161 - ICOL=ICOLBX+2+MIN(NINT(WW*(NPRCOL-1)),NPRCOL-3) 162 - ELSE 163 - ICOL=ICOLBX 164 - PRINT *,' !!!!!! GRAXI3 WARNING : Request to plot'// 165 - - ' a face seen from the back (program bug).' 166 - ENDIF 167 - CALL GSFACI(ICOL) 168 - XU(1)=X1 169 - YU(1)=Y1 170 - XU(2)=X2 171 - YU(2)=Y2 172 - XU(3)=X6 173 - YU(3)=Y6 174 - XU(4)=X5 175 - YU(4)=Y5 176 - XU(5)=X1 177 - YU(5)=Y1 178 - CALL GFA2(5,XU,YU) 179 - CALL GPL2(5,XU,YU) 180 - SEEN(1)=.TRUE. 181 - SEEN(5)=.TRUE. 182 - SEEN(9)=.TRUE. 183 - SEEN(12)=.TRUE. 184 - * Or the y=ymax plane. 185 - ELSEIF(FPROJB.LT.0)THEN 186 - CALL COLWGT(0.0D0,-1.0D0,0.0D0,WW) 187 - IF(WW.GE.0)THEN 188 - ICOL=ICOLBX+2+MIN(NINT(WW*(NPRCOL-1)),NPRCOL-3) 189 - ELSE 190 - ICOL=ICOLBX 191 - PRINT *,' !!!!!! GRAXI3 WARNING : Request to plot'// 192 - - ' a face seen from the back (program bug).' 193 - ENDIF 194 - CALL GSFACI(ICOL) 195 - XU(1)=X3 196 - YU(1)=Y3 197 - XU(2)=X4 198 - YU(2)=Y4 199 - XU(3)=X8 200 - YU(3)=Y8 201 - XU(4)=X7 202 - YU(4)=Y7 203 - XU(5)=X3 204 - YU(5)=Y3 205 - CALL GFA2(5,XU,YU) 206 - CALL GPL2(5,XU,YU) 207 - SEEN(3)=.TRUE. 208 - SEEN(7)=.TRUE. 209 - SEEN(10)=.TRUE. 210 - SEEN(11)=.TRUE. 211 - ENDIF 212 - * The z=zmin plane. 213 - IF(FPROJC.GT.0)THEN 214 - CALL COLWGT(0.0D0,0.0D0,+1.0D0,WW) 215 - IF(WW.GE.0)THEN 216 - ICOL=ICOLBX+2+MIN(NINT(WW*(NPRCOL-1)),NPRCOL-3) 217 - ELSE 218 - ICOL=ICOLBX 219 - PRINT *,' !!!!!! GRAXI3 WARNING : Request to plot'// 220 - - ' a face seen from the back (program bug).' 221 - ENDIF 222 - CALL GSFACI(ICOL) 223 - XU(1)=X1 224 - YU(1)=Y1 225 - XU(2)=X3 226 - YU(2)=Y3 227 - XU(3)=X7 228 - YU(3)=Y7 229 - XU(4)=X5 230 - YU(4)=Y5 231 - XU(5)=X1 1 134 P=GRAPHICS D=GRAXI3 4 PAGE 223 232 - YU(5)=Y1 233 - CALL GFA2(5,XU,YU) 234 - CALL GPL2(5,XU,YU) 235 - SEEN(2)=.TRUE. 236 - SEEN(6)=.TRUE. 237 - SEEN(9)=.TRUE. 238 - SEEN(10)=.TRUE. 239 - * Or the z=zmax plane. 240 - ELSEIF(FPROJC.LT.0)THEN 241 - CALL COLWGT(0.0D0,0.0D0,-1.0D0,WW) 242 - IF(WW.GE.0)THEN 243 - ICOL=ICOLBX+2+MIN(NINT(WW*(NPRCOL-1)),NPRCOL-3) 244 - ELSE 245 - ICOL=ICOLBX 246 - PRINT *,' !!!!!! GRAXI3 WARNING : Request to plot'// 247 - - ' a face seen from the back (program bug).' 248 - ENDIF 249 - CALL GSFACI(ICOL) 250 - XU(1)=X2 251 - YU(1)=Y2 252 - XU(2)=X4 253 - YU(2)=Y4 254 - XU(3)=X8 255 - YU(3)=Y8 256 - XU(4)=X6 257 - YU(4)=Y6 258 - XU(5)=X2 259 - YU(5)=Y2 260 - CALL GFA2(5,XU,YU) 261 - CALL GPL2(5,XU,YU) 262 - SEEN(4)=.TRUE. 263 - SEEN(8)=.TRUE. 264 - SEEN(11)=.TRUE. 265 - SEEN(12)=.TRUE. 266 - ENDIF 267 - *** Find a reasonable scale order-of-magnitude in x. 268 - KX=INT(LOG10(GXMAX-GXMIN)) 269 - IF(LOG10(GXMAX-GXMIN).LT.0.0)KX=KX-1 270 - DX=(GXMAX-GXMIN)/10.0**KX 271 - IF(DX.LT.2.0)DX=0.1 272 - IF(DX.GE.2.0.AND.DX.LT.5.0)DX=0.2 273 - IF(DX.GE.5.0)DX=0.5 274 - DX=DX*10.0**KX 275 - IF(KX.GE.0.AND.KX.LE.1)THEN 276 - KKX=0 277 - ELSE 278 - KKX=2+3*INT(LOG10(0.01*(GXMAX-GXMIN))/3.0) 279 - IF(0.01*(GXMAX-GXMIN).LT.0.1)KKX=KKX-3 280 - ENDIF 281 - * And same thing in y. 282 - KY=INT(LOG10(GYMAX-GYMIN)) 283 - IF(LOG10(GYMAX-GYMIN).LT.0.0)KY=KY-1 284 - DY=(GYMAX-GYMIN)/10.0**KY 285 - IF(DY.LT.2.0)DY=0.1 286 - IF(DY.GE.2.0.AND.DY.LT.5.0)DY=0.2 287 - IF(DY.GE.5.0)DY=0.5 288 - DY=DY*10.0**KY 289 - IF(KY.GE.0.AND.KY.LE.1)THEN 290 - KKY=0 291 - ELSE 292 - KKY=2+3*INT(LOG10(0.01*(GYMAX-GYMIN))/3.0) 293 - IF(0.01*(GYMAX-GYMIN).LT.0.1)KKY=KKY-3 294 - ENDIF 295 - * And same thing in z. 296 - KZ=INT(LOG10(GZMAX-GZMIN)) 297 - IF(LOG10(GZMAX-GZMIN).LT.0.0)KZ=KZ-1 298 - DZ=(GZMAX-GZMIN)/10.0**KZ 299 - IF(DZ.LT.2.0)DZ=0.1 300 - IF(DZ.GE.2.0.AND.DZ.LT.5.0)DZ=0.2 301 - IF(DZ.GE.5.0)DZ=0.5 302 - DZ=DZ*10.0**KZ 303 - IF(KZ.GE.0.AND.KZ.LE.1)THEN 304 - KKZ=0 305 - ELSE 306 - KKZ=2+3*INT(LOG10(0.01*(GZMAX-GZMIN))/3.0) 307 - IF(0.01*(GZMAX-GZMIN).LT.0.1)KKZ=KKZ-3 308 - ENDIF 309 - *** Calculate the length of a tick mark. 310 - TICKX=(GXMAX-GXMIN)/100.0 311 - TICKY=(GYMAX-GYMIN)/100.0 312 - TICKZ=(GZMAX-GZMIN)/100.0 313 - IF(LDEBUG)WRITE(10,'('' ++++++ GRAXI3 DEBUG : Tickmark size'', 314 - - '' in x='',E12.5,'' in y='',E12.5,'' in z='',E12.5)') 315 - - TICKX,TICKY,TICKZ 316 - *** x-Axis: tickmarks and scales. 317 - CALL GSTXAL(1,3) 318 - CALL GRATTS('NUMBERS','TEXT') 319 - * Determine optimal side to label. 320 - XPERP=Y6-Y2 321 - YPERP=X2-X6 322 - IF(XPERP+YPERP.GT.0)THEN 323 - XPERP=-XPERP 324 - YPERP=-YPERP 325 - INVERT=.TRUE. 326 - ELSE 327 - INVERT=.FALSE. 328 - ENDIF 329 - YLAB=GYMIN 330 - ZLAB=GZMIN 331 - QLAB=XPERP*X1+YPERP*Y1 332 - IF(XPERP*X2+YPERP*Y2.GT.QLAB)THEN 333 - QLAB=XPERP*X2+YPERP*Y2 334 - YLAB=GYMIN 335 - ZLAB=GZMAX 336 - ENDIF 337 - IF(XPERP*X3+YPERP*Y3.GT.QLAB)THEN 1 134 P=GRAPHICS D=GRAXI3 5 PAGE 224 338 - QLAB=XPERP*X3+YPERP*Y3 339 - YLAB=GYMAX 340 - ZLAB=GZMIN 341 - ENDIF 342 - IF(XPERP*X4+YPERP*Y4.GT.QLAB)THEN 343 - QLAB=XPERP*X2+YPERP*Y2 344 - YLAB=GYMAX 345 - ZLAB=GZMAX 346 - ENDIF 347 - XSHIFT=XUTOD(XPERP)-XUTOD(0.0D0) 348 - YSHIFT=YUTOD(YPERP)-YUTOD(0.0D0) 349 - SNORM=SQRT(XSHIFT**2+YSHIFT**2) 350 - IF(SNORM.GT.0)THEN 351 - XSHIFT=XSHIFT/SNORM 352 - YSHIFT=YSHIFT/SNORM 353 - ENDIF 354 - * Loop over the intervals. 355 - DO 10 I=0,1+INT((GXMAX-GXMIN)/DX) 356 - XVAL=DX*(INT(GXMIN/DX)+I) 357 - IF(GXMIN.GE.XVAL.OR.XVAL.GE.GXMAX.OR. 358 - - (FPROJB.EQ.0.AND.FPROJC.EQ.0))GOTO 10 359 - * Tickmarks. 360 - IF(SEEN(9))THEN 361 - CALL PLACOO(XVAL,GYMIN,GZMIN,XU(1),YU(1)) 362 - CALL PLACOO(XVAL,GYMIN+TICKY,GZMIN+TICKZ,XU(2),YU(2)) 363 - CALL GPL2(2,XU,YU) 364 - ENDIF 365 - IF(SEEN(12))THEN 366 - CALL PLACOO(XVAL,GYMIN,GZMAX,XU(1),YU(1)) 367 - CALL PLACOO(XVAL,GYMIN+TICKY,GZMAX-TICKZ,XU(2),YU(2)) 368 - CALL GPL2(2,XU,YU) 369 - ENDIF 370 - IF(SEEN(10))THEN 371 - CALL PLACOO(XVAL,GYMAX,GZMIN,XU(1),YU(1)) 372 - CALL PLACOO(XVAL,GYMAX-TICKY,GZMIN+TICKZ,XU(2),YU(2)) 373 - CALL GPL2(2,XU,YU) 374 - ENDIF 375 - IF(SEEN(11))THEN 376 - CALL PLACOO(XVAL,GYMAX,GZMAX,XU(1),YU(1)) 377 - CALL PLACOO(XVAL,GYMAX-TICKY,GZMAX-TICKZ,XU(2),YU(2)) 378 - CALL GPL2(2,XU,YU) 379 - ENDIF 380 - * Optional grid. 381 - IF(LGRID)THEN 382 - CALL GRATTS('GRID','POLYLINE') 383 - IF(FPROJB.GT.0)THEN 384 - CALL PLACOO(XVAL,GYMIN,GZMIN+TICKZ,XU(1),YU(1)) 385 - CALL PLACOO(XVAL,GYMIN,GZMAX-TICKZ,XU(2),YU(2)) 386 - CALL GPL2(2,XU,YU) 387 - ELSEIF(FPROJB.LT.0)THEN 388 - CALL PLACOO(XVAL,GYMAX,GZMIN+TICKZ,XU(1),YU(1)) 389 - CALL PLACOO(XVAL,GYMAX,GZMAX-TICKZ,XU(2),YU(2)) 390 - CALL GPL2(2,XU,YU) 391 - ENDIF 392 - IF(FPROJC.GT.0)THEN 393 - CALL PLACOO(XVAL,GYMIN+TICKY,GZMIN,XU(1),YU(1)) 394 - CALL PLACOO(XVAL,GYMAX-TICKY,GZMIN,XU(2),YU(2)) 395 - CALL GPL2(2,XU,YU) 396 - ELSEIF(FPROJC.LT.0)THEN 397 - CALL PLACOO(XVAL,GYMIN+TICKY,GZMAX,XU(1),YU(1)) 398 - CALL PLACOO(XVAL,GYMAX-TICKY,GZMAX,XU(2),YU(2)) 399 - CALL GPL2(2,XU,YU) 400 - ENDIF 401 - CALL GRATTS('BOX-TICKMARKS','POLYLINE') 402 - ENDIF 403 - * Scale. 404 - CALL OUTFMT(REAL(XVAL/10.0**KKX),2,TICK,NCTICK,'LEFT') 405 - IF(XPERP.LT.0)THEN 406 - CALL GSCHUP(REAL(YPERP/ASPECT),REAL(-XPERP*ASPECT)) 407 - CALL GSTXAL(3,3) 408 - ELSE 409 - CALL GSCHUP(REAL(-YPERP/ASPECT),REAL(XPERP*ASPECT)) 410 - CALL GSTXAL(1,3) 411 - ENDIF 412 - CALL PLACOO(XVAL,YLAB,ZLAB,XAUX,YAUX) 413 - XSC=XUTOD(XAUX)+0.01*XSHIFT 414 - YSC=YUTOD(YAUX)+0.01*YSHIFT 415 - CALL GSELNT(0) 416 - CALL GRTX(REAL(XSC),REAL(YSC),TICK(1:NCTICK)) 417 - CALL GSELNT(1) 418 - 10 CONTINUE 419 - * Label the axis. 420 - IF(FPROJB.NE.0.OR.FPROJC.NE.0)THEN 421 - STRING=XTXT 422 - NC=LEN(XTXT) 423 - IF(KKX.EQ.2)THEN 424 - STRING(NC+1:NC+4)=' [m]' 425 - NC=NC+NCTICK+4 426 - ELSEIF(KKX.EQ.0)THEN 427 - STRING(NC+1:NC+5)=' [cm]' 428 - NC=NC+NCTICK+5 429 - ELSEIF(KKX.EQ.-1)THEN 430 - STRING(NC+1:NC+5)=' [mm]' 431 - NC=NC+NCTICK+5 432 - ELSEIF(KKX.EQ.-4)THEN 433 - STRING(NC+1:NC+9)=' [micron]' 434 - NC=NC+NCTICK+9 435 - ELSEIF(KKX.EQ.-7)THEN 436 - STRING(NC+1:NC+5)=' [nm]' 437 - NC=NC+NCTICK+5 438 - ELSE 439 - CALL OUTFMT(REAL(KKX),2,TICK,NCTICK,'LEFT') 440 - STRING(NC+1:NC+NCTICK+10)=' [10**'//TICK(1:NCTICK)// 441 - - ' cm]' 442 - NC=NC+NCTICK+10 443 - ENDIF 1 134 P=GRAPHICS D=GRAXI3 6 PAGE 225 444 - IF(YPERP.LT.0)THEN 445 - CALL GSCHUP(REAL(-XPERP*ASPECT),REAL(-YPERP/ASPECT)) 446 - ELSE 447 - CALL GSCHUP(REAL(XPERP*ASPECT),REAL(YPERP/ASPECT)) 448 - ENDIF 449 - IF(INVERT)THEN 450 - IF(YPERP.LT.0)THEN 451 - CALL GSTXAL(1,0) 452 - ELSE 453 - CALL GSTXAL(3,1) 454 - ENDIF 455 - ELSE 456 - IF(YPERP.LT.0)THEN 457 - CALL GSTXAL(3,0) 458 - ELSE 459 - CALL GSTXAL(1,1) 460 - ENDIF 461 - ENDIF 462 - CALL PLACOO(GXMAX,YLAB,ZLAB,XAUX,YAUX) 463 - XSC=XUTOD(XAUX)+0.09*XSHIFT*ASPECT 464 - YSC=YUTOD(YAUX)+0.09*YSHIFT/ASPECT 465 - CALL GRATTS('LABELS','TEXT') 466 - CALL GSELNT(0) 467 - CALL GRTX(REAL(XSC),REAL(YSC),STRING(1:NC)) 468 - CALL GSELNT(1) 469 - ENDIF 470 - *** y-Axis: tickmarks and scales. 471 - CALL GSTXAL(1,3) 472 - CALL GRATTS('NUMBERS','TEXT') 473 - * Determine optimal side to label. 474 - XPERP=Y4-Y2 475 - YPERP=X2-X4 476 - IF(XPERP+YPERP.GT.0)THEN 477 - XPERP=-XPERP 478 - YPERP=-YPERP 479 - INVERT=.TRUE. 480 - ELSE 481 - INVERT=.FALSE. 482 - ENDIF 483 - XLAB=GXMIN 484 - ZLAB=GZMIN 485 - QLAB=XPERP*X1+YPERP*Y1 486 - IF(XPERP*X2+YPERP*Y2.GT.QLAB)THEN 487 - QLAB=XPERP*X2+YPERP*Y2 488 - XLAB=GXMIN 489 - ZLAB=GZMAX 490 - ENDIF 491 - IF(XPERP*X5+YPERP*Y5.GT.QLAB)THEN 492 - QLAB=XPERP*X5+YPERP*Y5 493 - XLAB=GXMAX 494 - ZLAB=GZMIN 495 - ENDIF 496 - IF(XPERP*X6+YPERP*Y6.GT.QLAB)THEN 497 - QLAB=XPERP*X6+YPERP*Y6 498 - XLAB=GXMAX 499 - ZLAB=GZMAX 500 - ENDIF 501 - XSHIFT=XUTOD(XPERP)-XUTOD(0.0D0) 502 - YSHIFT=YUTOD(YPERP)-YUTOD(0.0D0) 503 - SNORM=SQRT(XSHIFT**2+YSHIFT**2) 504 - IF(SNORM.GT.0)THEN 505 - XSHIFT=XSHIFT/SNORM 506 - YSHIFT=YSHIFT/SNORM 507 - ENDIF 508 - * Loop over the intervals. 509 - DO 20 I=0,1+INT((GYMAX-GYMIN)/DY) 510 - YVAL=DY*(INT(GYMIN/DY)+I) 511 - IF(GYMIN.GE.YVAL.OR.YVAL.GE.GYMAX.OR. 512 - - (FPROJA.EQ.0.AND.FPROJC.EQ.0))GOTO 20 513 - * Tickmarks. 514 - IF(SEEN(2))THEN 515 - CALL PLACOO(GXMIN,YVAL,GZMIN,XU(1),YU(1)) 516 - CALL PLACOO(GXMIN+TICKX,YVAL,GZMIN+TICKZ,XU(2),YU(2)) 517 - CALL GPL2(2,XU,YU) 518 - ENDIF 519 - IF(SEEN(4))THEN 520 - CALL PLACOO(GXMIN,YVAL,GZMAX,XU(1),YU(1)) 521 - CALL PLACOO(GXMIN+TICKX,YVAL,GZMAX-TICKZ,XU(2),YU(2)) 522 - CALL GPL2(2,XU,YU) 523 - ENDIF 524 - IF(SEEN(6))THEN 525 - CALL PLACOO(GXMAX,YVAL,GZMIN,XU(1),YU(1)) 526 - CALL PLACOO(GXMAX-TICKX,YVAL,GZMIN+TICKZ,XU(2),YU(2)) 527 - CALL GPL2(2,XU,YU) 528 - ENDIF 529 - IF(SEEN(8))THEN 530 - CALL PLACOO(GXMAX,YVAL,GZMAX,XU(1),YU(1)) 531 - CALL PLACOO(GXMAX-TICKX,YVAL,GZMAX-TICKZ,XU(2),YU(2)) 532 - CALL GPL2(2,XU,YU) 533 - ENDIF 534 - * Optional grid. 535 - IF(LGRID)THEN 536 - CALL GRATTS('GRID','POLYLINE') 537 - IF(FPROJA.GT.0)THEN 538 - CALL PLACOO(GXMIN,YVAL,GZMIN+TICKZ,XU(1),YU(1)) 539 - CALL PLACOO(GXMIN,YVAL,GZMAX-TICKZ,XU(2),YU(2)) 540 - CALL GPL2(2,XU,YU) 541 - ELSEIF(FPROJA.LT.0)THEN 542 - CALL PLACOO(GXMAX,YVAL,GZMIN+TICKZ,XU(1),YU(1)) 543 - CALL PLACOO(GXMAX,YVAL,GZMAX-TICKZ,XU(2),YU(2)) 544 - CALL GPL2(2,XU,YU) 545 - ENDIF 546 - IF(FPROJC.GT.0)THEN 547 - CALL PLACOO(GXMIN+TICKX,YVAL,GZMIN,XU(1),YU(1)) 548 - CALL PLACOO(GXMAX-TICKX,YVAL,GZMIN,XU(2),YU(2)) 549 - CALL GPL2(2,XU,YU) 1 134 P=GRAPHICS D=GRAXI3 7 PAGE 226 550 - ELSEIF(FPROJC.LT.0)THEN 551 - CALL PLACOO(GXMIN+TICKX,YVAL,GZMAX,XU(1),YU(1)) 552 - CALL PLACOO(GXMAX-TICKX,YVAL,GZMAX,XU(2),YU(2)) 553 - CALL GPL2(2,XU,YU) 554 - ENDIF 555 - CALL GRATTS('BOX-TICKMARKS','POLYLINE') 556 - ENDIF 557 - * Scale. 558 - CALL OUTFMT(REAL(YVAL/10.0**KKY),2,TICK,NCTICK,'LEFT') 559 - IF(XPERP.LT.0)THEN 560 - CALL GSCHUP(REAL(YPERP/ASPECT),REAL(-XPERP*ASPECT)) 561 - CALL GSTXAL(3,3) 562 - ELSE 563 - CALL GSCHUP(REAL(-YPERP/ASPECT),REAL(XPERP*ASPECT)) 564 - CALL GSTXAL(1,3) 565 - ENDIF 566 - CALL PLACOO(XLAB,YVAL,ZLAB,XAUX,YAUX) 567 - XSC=XUTOD(XAUX)+0.01*XSHIFT 568 - YSC=YUTOD(YAUX)+0.01*YSHIFT 569 - CALL GSELNT(0) 570 - CALL GRTX(REAL(XSC),REAL(YSC),TICK(1:NCTICK)) 571 - CALL GSELNT(1) 572 - 20 CONTINUE 573 - * Label the axis. 574 - IF(FPROJA.NE.0.OR.FPROJC.NE.0)THEN 575 - STRING=YTXT 576 - NC=LEN(YTXT) 577 - IF(KKY.EQ.2)THEN 578 - STRING(NC+1:NC+4)=' [m]' 579 - NC=NC+NCTICK+4 580 - ELSEIF(KKY.EQ.0)THEN 581 - STRING(NC+1:NC+5)=' [cm]' 582 - NC=NC+NCTICK+5 583 - ELSEIF(KKY.EQ.-1)THEN 584 - STRING(NC+1:NC+5)=' [mm]' 585 - NC=NC+NCTICK+5 586 - ELSEIF(KKY.EQ.-4)THEN 587 - STRING(NC+1:NC+9)=' [micron]' 588 - NC=NC+NCTICK+9 589 - ELSEIF(KKY.EQ.-7)THEN 590 - STRING(NC+1:NC+5)=' [nm]' 591 - NC=NC+NCTICK+5 592 - ELSE 593 - CALL OUTFMT(REAL(KKY),2,TICK,NCTICK,'LEFT') 594 - STRING(NC+1:NC+NCTICK+10)=' [10**'//TICK(1:NCTICK)// 595 - - ' cm]' 596 - NC=NC+NCTICK+10 597 - ENDIF 598 - IF(YPERP.LT.0)THEN 599 - CALL GSCHUP(REAL(-XPERP*ASPECT),REAL(-YPERP/ASPECT)) 600 - ELSE 601 - CALL GSCHUP(REAL(XPERP*ASPECT),REAL(YPERP/ASPECT)) 602 - ENDIF 603 - IF(INVERT)THEN 604 - IF(YPERP.LT.0)THEN 605 - CALL GSTXAL(1,0) 606 - ELSE 607 - CALL GSTXAL(3,1) 608 - ENDIF 609 - ELSE 610 - IF(YPERP.LT.0)THEN 611 - CALL GSTXAL(3,0) 612 - ELSE 613 - CALL GSTXAL(1,1) 614 - ENDIF 615 - ENDIF 616 - CALL PLACOO(XLAB,GYMAX,ZLAB,XAUX,YAUX) 617 - XSC=XUTOD(XAUX)+0.09*XSHIFT*ASPECT 618 - YSC=YUTOD(YAUX)+0.09*YSHIFT/ASPECT 619 - CALL GRATTS('LABELS','TEXT') 620 - CALL GSELNT(0) 621 - CALL GRTX(REAL(XSC),REAL(YSC),STRING(1:NC)) 622 - CALL GSELNT(1) 623 - ENDIF 624 - *** z-Axis: tickmarks and scales. 625 - CALL GSTXAL(1,3) 626 - CALL GRATTS('NUMBERS','TEXT') 627 - * Determine optimal side to label. 628 - XPERP=Y2-Y1 629 - YPERP=X1-X2 630 - IF(XPERP+YPERP.GT.0)THEN 631 - XPERP=-XPERP 632 - YPERP=-YPERP 633 - INVERT=.TRUE. 634 - ELSE 635 - INVERT=.FALSE. 636 - ENDIF 637 - XLAB=GXMIN 638 - YLAB=GYMIN 639 - QLAB=XPERP*X1+YPERP*Y1 640 - IF(XPERP*X3+YPERP*Y3.GT.QLAB)THEN 641 - QLAB=XPERP*X3+YPERP*Y3 642 - XLAB=GXMIN 643 - YLAB=GYMAX 644 - ENDIF 645 - IF(XPERP*X5+YPERP*Y5.GT.QLAB)THEN 646 - QLAB=XPERP*X5+YPERP*Y5 647 - XLAB=GXMAX 648 - YLAB=GYMIN 649 - ENDIF 650 - IF(XPERP*X7+YPERP*Y7.GT.QLAB)THEN 651 - QLAB=XPERP*X7+YPERP*Y7 652 - XLAB=GXMAX 653 - YLAB=GYMAX 654 - ENDIF 655 - XSHIFT=XUTOD(XPERP)-XUTOD(0.0D0) 1 134 P=GRAPHICS D=GRAXI3 8 PAGE 227 656 - YSHIFT=YUTOD(YPERP)-YUTOD(0.0D0) 657 - SNORM=SQRT(XSHIFT**2+YSHIFT**2) 658 - IF(SNORM.GT.0)THEN 659 - XSHIFT=XSHIFT/SNORM 660 - YSHIFT=YSHIFT/SNORM 661 - ENDIF 662 - * Loop over the intervals. 663 - DO 30 I=0,1+INT((GZMAX-GZMIN)/DZ) 664 - ZVAL=DZ*(INT(GZMIN/DZ)+I) 665 - IF(GZMIN.GE.ZVAL.OR.ZVAL.GE.GZMAX.OR. 666 - - (FPROJA.EQ.0.AND.FPROJB.EQ.0))GOTO 30 667 - * Tickmarks. 668 - IF(SEEN(1))THEN 669 - CALL PLACOO(GXMIN,GYMIN,ZVAL,XU(1),YU(1)) 670 - CALL PLACOO(GXMIN+TICKX,GYMIN+TICKY,ZVAL,XU(2),YU(2)) 671 - CALL GPL2(2,XU,YU) 672 - ENDIF 673 - IF(SEEN(3))THEN 674 - CALL PLACOO(GXMIN,GYMAX,ZVAL,XU(1),YU(1)) 675 - CALL PLACOO(GXMIN+TICKX,GYMAX-TICKY,ZVAL,XU(2),YU(2)) 676 - CALL GPL2(2,XU,YU) 677 - ENDIF 678 - IF(SEEN(5))THEN 679 - CALL PLACOO(GXMAX,GYMIN,ZVAL,XU(1),YU(1)) 680 - CALL PLACOO(GXMAX-TICKX,GYMIN+TICKY,ZVAL,XU(2),YU(2)) 681 - CALL GPL2(2,XU,YU) 682 - ENDIF 683 - IF(SEEN(7))THEN 684 - CALL PLACOO(GXMAX,GYMAX,ZVAL,XU(1),YU(1)) 685 - CALL PLACOO(GXMAX-TICKX,GYMAX-TICKY,ZVAL,XU(2),YU(2)) 686 - CALL GPL2(2,XU,YU) 687 - ENDIF 688 - * Optional grid. 689 - IF(LGRID)THEN 690 - CALL GRATTS('GRID','POLYLINE') 691 - IF(FPROJA.GT.0)THEN 692 - CALL PLACOO(GXMIN,GYMIN+TICKY,ZVAL,XU(1),YU(1)) 693 - CALL PLACOO(GXMIN,GYMAX-TICKY,ZVAL,XU(2),YU(2)) 694 - CALL GPL2(2,XU,YU) 695 - ELSEIF(FPROJA.LT.0)THEN 696 - CALL PLACOO(GXMAX,GYMIN+TICKY,ZVAL,XU(1),YU(1)) 697 - CALL PLACOO(GXMAX,GYMAX-TICKY,ZVAL,XU(2),YU(2)) 698 - CALL GPL2(2,XU,YU) 699 - ENDIF 700 - IF(FPROJB.GT.0)THEN 701 - CALL PLACOO(GXMIN+TICKX,GYMIN,ZVAL,XU(1),YU(1)) 702 - CALL PLACOO(GXMAX-TICKX,GYMIN,ZVAL,XU(2),YU(2)) 703 - CALL GPL2(2,XU,YU) 704 - ELSEIF(FPROJB.LT.0)THEN 705 - CALL PLACOO(GXMIN+TICKX,GYMAX,ZVAL,XU(1),YU(1)) 706 - CALL PLACOO(GXMAX-TICKX,GYMAX,ZVAL,XU(2),YU(2)) 707 - CALL GPL2(2,XU,YU) 708 - ENDIF 709 - CALL GRATTS('BOX-TICKMARKS','POLYLINE') 710 - ENDIF 711 - * Scale. 712 - CALL OUTFMT(REAL(ZVAL/10.0**KKZ),2,TICK,NCTICK,'LEFT') 713 - IF(XPERP.LT.0)THEN 714 - CALL GSCHUP(REAL(YPERP/ASPECT),REAL(-XPERP*ASPECT)) 715 - CALL GSTXAL(3,3) 716 - ELSE 717 - CALL GSCHUP(REAL(-YPERP/ASPECT),REAL(XPERP*ASPECT)) 718 - CALL GSTXAL(1,3) 719 - ENDIF 720 - CALL PLACOO(XLAB,YLAB,ZVAL,XAUX,YAUX) 721 - XSC=XUTOD(XAUX)+0.01*XSHIFT 722 - YSC=YUTOD(YAUX)+0.01*YSHIFT 723 - CALL GSELNT(0) 724 - CALL GRTX(REAL(XSC),REAL(YSC),TICK(1:NCTICK)) 725 - CALL GSELNT(1) 726 - 30 CONTINUE 727 - * Label the axis. 728 - IF(FPROJA.NE.0.OR.FPROJB.NE.0)THEN 729 - STRING=ZTXT 730 - NC=LEN(ZTXT) 731 - IF(KKZ.EQ.2)THEN 732 - STRING(NC+1:NC+4)=' [m]' 733 - NC=NC+NCTICK+4 734 - ELSEIF(KKZ.EQ.0)THEN 735 - STRING(NC+1:NC+5)=' [cm]' 736 - NC=NC+NCTICK+5 737 - ELSEIF(KKZ.EQ.-1)THEN 738 - STRING(NC+1:NC+5)=' [mm]' 739 - NC=NC+NCTICK+5 740 - ELSEIF(KKZ.EQ.-4)THEN 741 - STRING(NC+1:NC+9)=' [micron]' 742 - NC=NC+NCTICK+9 743 - ELSEIF(KKZ.EQ.-7)THEN 744 - STRING(NC+1:NC+5)=' [nm]' 745 - NC=NC+NCTICK+5 746 - ELSE 747 - CALL OUTFMT(REAL(KKZ),2,TICK,NCTICK,'LEFT') 748 - STRING(NC+1:NC+NCTICK+10)=' [10**'//TICK(1:NCTICK)// 749 - - ' cm]' 750 - NC=NC+NCTICK+10 751 - ENDIF 752 - IF(YPERP.LT.0)THEN 753 - CALL GSCHUP(REAL(-XPERP*ASPECT),REAL(-YPERP/ASPECT)) 754 - ELSE 755 - CALL GSCHUP(REAL(XPERP*ASPECT),REAL(YPERP/ASPECT)) 756 - ENDIF 757 - IF(INVERT)THEN 758 - IF(YPERP.LT.0)THEN 759 - CALL GSTXAL(1,0) 760 - ELSE 761 - CALL GSTXAL(3,1) 1 134 P=GRAPHICS D=GRAXI3 9 PAGE 228 762 - ENDIF 763 - ELSE 764 - IF(YPERP.LT.0)THEN 765 - CALL GSTXAL(3,0) 766 - ELSE 767 - CALL GSTXAL(1,1) 768 - ENDIF 769 - ENDIF 770 - CALL PLACOO(XLAB,YLAB,GZMAX,XAUX,YAUX) 771 - XSC=XUTOD(XAUX)+0.09*XSHIFT*ASPECT 772 - YSC=YUTOD(YAUX)+0.09*YSHIFT/ASPECT 773 - CALL GRATTS('LABELS','TEXT') 774 - CALL GSELNT(0) 775 - CALL GRTX(REAL(XSC),REAL(YSC),STRING(1:NC)) 776 - CALL GSELNT(1) 777 - ENDIF 778 - *** Now plot the cell elements. 779 - CALL CELLA3 780 - *** And plot box panels that are seen from the back, attributes. 781 - IF(LFULLB)THEN 782 - CALL GRATTS('BOX-TICKMARKS','POLYLINE') 783 - * The x=xmin plane. 784 - IF(FPROJA.LT.0)THEN 785 - XU(1)=X1 786 - YU(1)=Y1 787 - XU(2)=X3 788 - YU(2)=Y3 789 - XU(3)=X4 790 - YU(3)=Y4 791 - XU(4)=X2 792 - YU(4)=Y2 793 - XU(5)=X1 794 - YU(5)=Y1 795 - CALL GPL2(5,XU,YU) 796 - * Or the x=xmax plane. 797 - ELSEIF(FPROJA.GT.0)THEN 798 - XU(1)=X5 799 - YU(1)=Y5 800 - XU(2)=X7 801 - YU(2)=Y7 802 - XU(3)=X8 803 - YU(3)=Y8 804 - XU(4)=X6 805 - YU(4)=Y6 806 - XU(5)=X5 807 - YU(5)=Y5 808 - CALL GPL2(5,XU,YU) 809 - ENDIF 810 - * The y=ymin plane. 811 - IF(FPROJB.LT.0)THEN 812 - XU(1)=X1 813 - YU(1)=Y1 814 - XU(2)=X2 815 - YU(2)=Y2 816 - XU(3)=X6 817 - YU(3)=Y6 818 - XU(4)=X5 819 - YU(4)=Y5 820 - XU(5)=X1 821 - YU(5)=Y1 822 - CALL GPL2(5,XU,YU) 823 - * Or the y=ymax plane. 824 - ELSEIF(FPROJB.GT.0)THEN 825 - XU(1)=X3 826 - YU(1)=Y3 827 - XU(2)=X4 828 - YU(2)=Y4 829 - XU(3)=X8 830 - YU(3)=Y8 831 - XU(4)=X7 832 - YU(4)=Y7 833 - XU(5)=X3 834 - YU(5)=Y3 835 - CALL GPL2(5,XU,YU) 836 - ENDIF 837 - * The z=zmin plane. 838 - IF(FPROJC.LT.0)THEN 839 - XU(1)=X1 840 - YU(1)=Y1 841 - XU(2)=X3 842 - YU(2)=Y3 843 - XU(3)=X7 844 - YU(3)=Y7 845 - XU(4)=X5 846 - YU(4)=Y5 847 - XU(5)=X1 848 - YU(5)=Y1 849 - CALL GPL2(5,XU,YU) 850 - * Or the z=zmax plane. 851 - ELSEIF(FPROJC.GT.0)THEN 852 - XU(1)=X2 853 - YU(1)=Y2 854 - XU(2)=X4 855 - YU(2)=Y4 856 - XU(3)=X8 857 - YU(3)=Y8 858 - XU(4)=X6 859 - YU(4)=Y6 860 - XU(5)=X2 861 - YU(5)=Y2 862 - CALL GPL2(5,XU,YU) 863 - ENDIF 864 - *** And complete with the tickmarks, loop over the x-axis. 865 - DO 40 I=0,1+INT((GXMAX-GXMIN)/DX) 866 - XVAL=DX*(INT(GXMIN/DX)+I) 867 - IF(GXMIN.GE.XVAL.OR.XVAL.GE.GXMAX)GOTO 40 1 134 P=GRAPHICS D=GRAXI3 10 PAGE 229 868 - IF(.NOT.SEEN(9))THEN 869 - CALL PLACOO(XVAL,GYMIN,GZMIN,XU(1),YU(1)) 870 - CALL PLACOO(XVAL,GYMIN+TICKY,GZMIN+TICKZ,XU(2),YU(2)) 871 - CALL GPL2(2,XU,YU) 872 - ENDIF 873 - IF(.NOT.SEEN(12))THEN 874 - CALL PLACOO(XVAL,GYMIN,GZMAX,XU(1),YU(1)) 875 - CALL PLACOO(XVAL,GYMIN+TICKY,GZMAX-TICKZ,XU(2),YU(2)) 876 - CALL GPL2(2,XU,YU) 877 - ENDIF 878 - IF(.NOT.SEEN(10))THEN 879 - CALL PLACOO(XVAL,GYMAX,GZMIN,XU(1),YU(1)) 880 - CALL PLACOO(XVAL,GYMAX-TICKY,GZMIN+TICKZ,XU(2),YU(2)) 881 - CALL GPL2(2,XU,YU) 882 - ENDIF 883 - IF(.NOT.SEEN(11))THEN 884 - CALL PLACOO(XVAL,GYMAX,GZMAX,XU(1),YU(1)) 885 - CALL PLACOO(XVAL,GYMAX-TICKY,GZMAX-TICKZ,XU(2),YU(2)) 886 - CALL GPL2(2,XU,YU) 887 - ENDIF 888 - 40 CONTINUE 889 - * Over the y-axis. 890 - DO 50 I=0,1+INT((GYMAX-GYMIN)/DY) 891 - YVAL=DY*(INT(GYMIN/DY)+I) 892 - IF(GYMIN.GE.YVAL.OR.YVAL.GE.GYMAX)GOTO 50 893 - IF(.NOT.SEEN(2))THEN 894 - CALL PLACOO(GXMIN,YVAL,GZMIN,XU(1),YU(1)) 895 - CALL PLACOO(GXMIN+TICKX,YVAL,GZMIN+TICKZ,XU(2),YU(2)) 896 - CALL GPL2(2,XU,YU) 897 - ENDIF 898 - IF(.NOT.SEEN(4))THEN 899 - CALL PLACOO(GXMIN,YVAL,GZMAX,XU(1),YU(1)) 900 - CALL PLACOO(GXMIN+TICKX,YVAL,GZMAX-TICKZ,XU(2),YU(2)) 901 - CALL GPL2(2,XU,YU) 902 - ENDIF 903 - IF(.NOT.SEEN(6))THEN 904 - CALL PLACOO(GXMAX,YVAL,GZMIN,XU(1),YU(1)) 905 - CALL PLACOO(GXMAX-TICKX,YVAL,GZMIN+TICKZ,XU(2),YU(2)) 906 - CALL GPL2(2,XU,YU) 907 - ENDIF 908 - IF(.NOT.SEEN(8))THEN 909 - CALL PLACOO(GXMAX,YVAL,GZMAX,XU(1),YU(1)) 910 - CALL PLACOO(GXMAX-TICKX,YVAL,GZMAX-TICKZ,XU(2),YU(2)) 911 - CALL GPL2(2,XU,YU) 912 - ENDIF 913 - 50 CONTINUE 914 - * And the z-axis. 915 - DO 60 I=0,1+INT((GZMAX-GZMIN)/DZ) 916 - ZVAL=DZ*(INT(GZMIN/DZ)+I) 917 - IF(GZMIN.GE.ZVAL.OR.ZVAL.GE.GZMAX)GOTO 60 918 - IF(.NOT.SEEN(1))THEN 919 - CALL PLACOO(GXMIN,GYMIN,ZVAL,XU(1),YU(1)) 920 - CALL PLACOO(GXMIN+TICKX,GYMIN+TICKY,ZVAL,XU(2),YU(2)) 921 - CALL GPL2(2,XU,YU) 922 - ENDIF 923 - IF(.NOT.SEEN(3))THEN 924 - CALL PLACOO(GXMIN,GYMAX,ZVAL,XU(1),YU(1)) 925 - CALL PLACOO(GXMIN+TICKX,GYMAX-TICKY,ZVAL,XU(2),YU(2)) 926 - CALL GPL2(2,XU,YU) 927 - ENDIF 928 - IF(.NOT.SEEN(5))THEN 929 - CALL PLACOO(GXMAX,GYMIN,ZVAL,XU(1),YU(1)) 930 - CALL PLACOO(GXMAX-TICKX,GYMIN+TICKY,ZVAL,XU(2),YU(2)) 931 - CALL GPL2(2,XU,YU) 932 - ENDIF 933 - IF(.NOT.SEEN(7))THEN 934 - CALL PLACOO(GXMAX,GYMAX,ZVAL,XU(1),YU(1)) 935 - CALL PLACOO(GXMAX-TICKX,GYMAX-TICKY,ZVAL,XU(2),YU(2)) 936 - CALL GPL2(2,XU,YU) 937 - ENDIF 938 - 60 CONTINUE 939 - ENDIF 940 - *** Plot the title at the top. 941 - CALL GRATTS('TITLE','TEXT') 942 - CALL GSTXAL(0,0) 943 - CALL GSCHUP(0.0,1.0) 944 - CALL GSELNT(0) 945 - CALL GRTX(0.1,0.95,TITLE) 946 - CALL GSELNT(1) 947 - *** And make a little sketch of the light source. 948 - CALL GSELNT(0) 949 - CALL GRATTS('BOX-TICKMARKS','POLYLINE') 950 - DO 110 I=1,101 951 - XU(I)=0.95+0.04*COS(0.02*I*PI) 952 - YU(I)=0.05+0.04*SIN(0.02*I*PI) 953 - 110 CONTINUE 954 - CALL GPL2(101,XU,YU) 955 - CALL PLACOO(DBLE(PRAL),DBLE(PRBL),DBLE(PRCL),XAUX,YAUX) 956 - XAUX=XAUX*0.04 957 - YAUX=YAUX*0.04 958 - CALL GRATTS('FUNCTION-1','POLYLINE') 959 - XU(1)=0.95+XAUX 960 - YU(1)=0.05+YAUX+0.005 961 - XU(2)=0.95+XAUX 962 - YU(2)=0.05+YAUX-0.005 963 - CALL GPL2(2,XU,YU) 964 - XU(1)=0.95+XAUX+0.005 965 - YU(1)=0.05+YAUX 966 - XU(2)=0.95+XAUX-0.005 967 - YU(2)=0.05+YAUX 968 - CALL GPL2(2,XU,YU) 969 - CALL GSELNT(1) 970 - END 1 135 GARFIELD ================================================== P=GRAPHICS D=GRAXIS 1 =================== PAGE 230 0 + +DECK,GRAXIS. 1 - SUBROUTINE GRAXIS(XXMIN,YYMIN,XXMAX,YYMAX,TITLE) 2 - *----------------------------------------------------------------------- 3 - * GRAXIS - Draws axis for the cell, using any kind of axis. 4 - * (Last changed on 28/10/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9 - REAL XXMIN,XXMAX,YYMIN,YYMAX 10 - CHARACTER*(*) TITLE 11 - *** Frame depending on the coordinate system. 12 - IF(.NOT.POLAR)THEN 13 - CALL GRCART(XXMIN,YYMIN,XXMAX,YYMAX, 14 - - 'x-axis [cm]','y-axis [cm]',TITLE) 15 - ELSE 16 - CALL GRAPOL(XXMIN,YYMIN,XXMAX,YYMAX, 17 - - 'Radial distances are in cm ', 18 - - 'Angles are in degrees ',TITLE) 19 - ENDIF 20 - *** Get the viewport input priorities right. 21 - CALL GSVPIP(1,0,0) 22 - END 136 GARFIELD ================================================== P=GRAPHICS D=GRCART 1 ============================ 0 + +DECK,GRCART. 1 - SUBROUTINE GRCART(XMIN1,YMIN1,XMAX1,YMAX1,XTXT,YTXT,TITLE) 2 - *---------------------------------------------------------------------- 3 - * GRCART - Subroutine plotting axis, annotating them and adding 4 - * tickmarks along them. 5 - * This routine is for cartesian coordinates. 6 - * VARIABLES : XMIN,XMAX : User minimum and maximum for plots in x. 7 - * XTXT,YTXT : Titel along the x and y axis. 8 - * TITLE : Global title. 9 - * (Last changed on 30/10/99.) 10 - *---------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,PARAMETERS. 14.- +SEQ,GRAPHICS. 15.- +SEQ,PRINTPLOT. 16 - REAL XU(5),YU(5),XMIN1,YMIN1,XMAX1,YMAX1,XUTOD,YUTOD,X,Y, 17 - - XMIN,YMIN,XMAX,YMAX,DX,DY,TICKX,TICKY,XVAL,YVAL,XSC,YSC, 18 - - CPX,CPY,XBOX(5),YBOX(5),XPOWER,YPOWER,YSHIFT 19 - INTEGER NDECX,NDECY,NDEC0,NDEC1,KX,KKX,KY,KKY,NC,I,IDEC,IERR, 20 - - IWK 21 - CHARACTER*(*) XTXT,YTXT,TITLE 22 - CHARACTER*13 AUX 23 - CHARACTER*13 TICK 24 - *** Define 2 statement function to convert from USER to DISP. 25 - XUTOD(X)=DISPX0+(DISPX1-DISPX0)*(X-USERX0)/(USERX1-USERX0) 26 - YUTOD(Y)=DISPY0+(DISPY1-DISPY0)*(Y-USERY0)/(USERY1-USERY0) 27 - *** Set a workstation for inquiries of the power-of-10 box size. 28 - IWK=1 29 - *** Output the requested area, if debugging is requested. 30 - IF(LDEBUG)WRITE(LUNOUT,*) ' ++++++ GRCART DEBUG : Requested'// 31 - - ' area (',XMIN1,YMIN1,') to (',XMAX1,YMAX1,')' 32 - *** Check input and define maxima and minima, first order x. 33 - IF(XMAX1.LT.XMIN1)PRINT *,' !!!!!! GRCART WARNING : Maximum'// 34 - - ' for x exceeds the minimum ; reversed.' 35 - XMIN=MIN(XMIN1,XMAX1) 36 - XMAX=MAX(XMIN1,XMAX1) 37 - * Check for very small ranges. 38 - IF(ABS(XMAX-XMIN).LT.1.0E-5*(1.0E-25+ABS(XMIN)+ABS(XMAX)))THEN 39 - IF(LOGX)THEN 40 - XMAX=XMAX*2 41 - XMIN=XMIN/2 42 - PRINT *,' !!!!!! GRCART WARNING : Zero range in x;'// 43 - - ' range enlarged by a factor 2.' 44 - ELSE 45 - XMAX=XMAX+1.0E-4*MAX(1.0,ABS(XMAX)) 46 - XMIN=XMIN-1.0E-4*MAX(1.0,ABS(XMIN)) 47 - PRINT *,' !!!!!! GRCART WARNING : Zero range in x;'// 48 - - ' range scaled up by 1E-4.' 49 - ENDIF 50 - ENDIF 51 - * Order y. 52 - IF(YMAX1.LT.YMIN1)PRINT *,' !!!!!! GRCART WARNING : Maximum'// 53 - - ' for y exceeds the minimum ; reversed.' 54 - YMIN=MIN(YMIN1,YMAX1) 55 - YMAX=MAX(YMIN1,YMAX1) 56 - * Check for very small ranges. 57 - IF(ABS(YMAX-YMIN).LT.1.0E-5*(1.0E-25+ABS(YMIN)+ABS(YMAX)))THEN 58 - IF(LOGY)THEN 59 - YMAX=YMAX*2 60 - YMIN=YMIN/2 61 - PRINT *,' !!!!!! GRCART WARNING : Zero range in y;'// 62 - - ' range enlarged by a factor 2.' 63 - ELSE 64 - YMAX=YMAX+1.0E-4*MAX(1.0,ABS(YMAX)) 65 - YMIN=YMIN-1.0E-4*MAX(1.0,ABS(YMIN)) 66 - PRINT *,' !!!!!! GRCART WARNING : Zero range in y;'// 67 - - ' range scaled up by 1E-4.' 68 - ENDIF 69 - ENDIF 70 - * Avoid negative values on log scales. 71 - IF((LOGX.AND.(XMAX.LE.0.0.OR.XMIN.LE.0.0)).OR. 72 - - (LOGY.AND.(YMAX.LE.0.0.OR.YMIN.LE.0.0)))THEN 73 - PRINT *,' !!!!!! GRCART WARNING : Non-positive bounds'// 74 - - ' found for an axis with log scale; range modified.' 75 - IF(LOGX.AND.XMIN.LE.0.0.OR.XMAX.LE.0.0)THEN 76 - XMIN=MAX(XMIN,1.0E-3) 77 - XMAX=MAX(XMIN,XMAX) 78 - IF(XMIN.GE.XMAX)THEN 79 - XMIN=XMIN/2 1 136 P=GRAPHICS D=GRCART 2 PAGE 231 80 - XMAX=XMAX*2 81 - ENDIF 82 - ENDIF 83 - IF(LOGY.AND.YMIN.LE.0.0.OR.YMAX.LE.0.0)THEN 84 - YMIN=MAX(YMIN,1.0E-3) 85 - YMAX=MAX(YMIN,YMAX) 86 - IF(YMIN.GE.YMAX)THEN 87 - YMIN=YMIN/2 88 - YMAX=YMAX*2 89 - ENDIF 90 - ENDIF 91 - ENDIF 92 - *** Store frame size. 93 - FRXMIN=XMIN 94 - FRXMAX=XMAX 95 - FRYMIN=YMIN 96 - FRYMAX=YMAX 97 - IF(LOGX)THEN 98 - FRXMIN=LOG10(FRXMIN) 99 - FRXMAX=LOG10(FRXMAX) 100 - ENDIF 101 - IF(LOGY)THEN 102 - FRYMIN=LOG10(FRYMIN) 103 - FRYMAX=LOG10(FRYMAX) 104 - ENDIF 105 - *** Switch to graphics mode. 106 - CALL GRGRAF(.TRUE.) 107 - *** Define display area of frame. 108 - CALL GSVP(1,DISPX0,DISPX1,DISPY0,DISPY1) 109 - *** Define the user area in the plot frame. 110 - IF(LOGX)THEN 111 - USERX0=LOG10(XMIN)-0.1*LOG10(XMAX/XMIN)/(DISPX1-DISPX0-0.2) 112 - USERX1=LOG10(XMAX)+0.1*LOG10(XMAX/XMIN)/(DISPX1-DISPX0-0.2) 113 - ELSE 114 - USERX0=XMIN-0.1*(XMAX-XMIN)/(DISPX1-DISPX0-0.2) 115 - USERX1=XMAX+0.1*(XMAX-XMIN)/(DISPX1-DISPX0-0.2) 116 - ENDIF 117 - IF(LOGY)THEN 118 - USERY0=LOG10(YMIN)-0.1*LOG10(YMAX/YMIN)/(DISPY1-DISPY0-0.2) 119 - USERY1=LOG10(YMAX)+0.1*LOG10(YMAX/YMIN)/(DISPY1-DISPY0-0.2) 120 - ELSE 121 - USERY0=YMIN-0.1*(YMAX-YMIN)/(DISPY1-DISPY0-0.2) 122 - USERY1=YMAX+0.1*(YMAX-YMIN)/(DISPY1-DISPY0-0.2) 123 - ENDIF 124 - CALL GSWN(1,USERX0,USERX1,USERY0,USERY1) 125 - CALL GRATTS('BOX-TICKMARKS','POLYLINE') 126 - CALL GRATTS('NUMBERS','TEXT') 127 - CALL GSTXP(0) 128 - *** Figure out number of decades for log scaled plots. 129 - NDECX=0 130 - NDECY=0 131 - IF(LOGX)NDECX=NINT(LOG10(MAX(XMIN,XMAX)/MIN(XMIN,XMAX))) 132 - IF(LOGY)NDECY=NINT(LOG10(MAX(YMIN,YMAX)/MIN(YMIN,YMAX))) 133 - IF(LDEBUG)WRITE(10,'('' ++++++ GRAXIS DEBUG : Number of'', 134 - - '' decades in x='',I3,'' in y='',I3)') NDECX,NDECY 135 - *** Find a reasonable scale order-of-magnitude in x. 136 - IF(NDECX.LE.1)THEN 137 - KX=INT(LOG10(XMAX-XMIN)) 138 - KKX=3*INT(LOG10(XMAX-XMIN)/3.0) 139 - IF(LOG10(XMAX-XMIN).LT.0.0)KX=KX-1 140 - IF(XMAX-XMIN.LT.0.1)KKX=KKX-3 141 - DX=(XMAX-XMIN)/10.0**KX 142 - IF(DX.LT.2.0)DX=0.1 143 - IF(DX.GE.2.0.AND.DX.LT.5.0)DX=0.2 144 - IF(DX.GE.5.0)DX=0.5 145 - DX=DX*10.0**KX 146 - ELSE 147 - KKX=0 148 - ENDIF 149 - * And same thing in y. 150 - IF(NDECY.LE.1)THEN 151 - KY=INT(LOG10(YMAX-YMIN)) 152 - KKY=3*INT(LOG10(YMAX-YMIN)/3.0) 153 - IF(LOG10(YMAX-YMIN).LT.0.0)KY=KY-1 154 - IF(YMAX-YMIN.LT.0.1)KKY=KKY-3 155 - DY=(YMAX-YMIN)/10.0**KY 156 - IF(DY.LT.2.0)DY=0.1 157 - IF(DY.GE.2.0.AND.DY.LT.5.0)DY=0.2 158 - IF(DY.GE.5.0)DY=0.5 159 - DY=DY*10.0**KY 160 - ELSE 161 - KKY=0 162 - ENDIF 163 - *** Calculate the length of a tick mark. 164 - IF(LOGX)THEN 165 - TICKX=10.0**(LOG10(XMAX/XMIN)/100.0) 166 - ELSE 167 - TICKX=(XMAX-XMIN)/100.0 168 - ENDIF 169 - IF(LOGY)THEN 170 - TICKY=10.0**(LOG10(YMAX/YMIN)/100.0) 171 - ELSE 172 - TICKY=(YMAX-YMIN)/100.0 173 - ENDIF 174 - IF(LDEBUG)WRITE(10,'('' ++++++ GRAXIS DEBUG : Tickmark size'', 175 - - '' in x='',E12.5,'' in y='',E12.5)') TICKX,TICKY 176 - *** Plot a box around the user area. 177 - XU(1)=XMIN 178 - YU(1)=YMIN 179 - XU(2)=XMAX 180 - YU(2)=YMIN 181 - XU(3)=XMAX 182 - YU(3)=YMAX 183 - XU(4)=XMIN 184 - YU(4)=YMAX 185 - XU(5)=XMIN 1 136 P=GRAPHICS D=GRCART 3 PAGE 232 186 - YU(5)=YMIN 187 - CALL GSELNT(1) 188 - CALL GRLINE(5,XU,YU) 189 - *** x-Axis: tickmarks and scales. 190 - IF(NDECX.LE.1)THEN 191 - CALL GSCHUP(+1.0,0.0) 192 - CALL GSTXAL(1,3) 193 - DO 20 I=0,1+INT((XMAX-XMIN)/DX) 194 - XVAL=DX*(INT(XMIN/DX)+I) 195 - IF(XMIN.GE.XVAL.OR.XVAL.GE.XMAX)GOTO 20 196 - * Tickmarks. 197 - XU(1)=XVAL 198 - XU(2)=XVAL 199 - YU(1)=YMIN 200 - IF(LOGY)THEN 201 - YU(2)=YMIN*TICKY 202 - ELSE 203 - YU(2)=YMIN+TICKY 204 - ENDIF 205 - CALL GRLINE(2,XU,YU) 206 - YU(1)=YMAX 207 - IF(LOGY)THEN 208 - YU(2)=YMAX/TICKY 209 - ELSE 210 - YU(2)=YMAX-TICKY 211 - ENDIF 212 - CALL GRLINE(2,XU,YU) 213 - * Optional grid. 214 - IF(LGRID)THEN 215 - IF(LOGY)THEN 216 - YU(1)=YMIN*TICKY 217 - YU(2)=YMAX/TICKY 218 - ELSE 219 - YU(1)=YMIN+TICKY 220 - YU(2)=YMAX-TICKY 221 - ENDIF 222 - CALL GRATTS('GRID','POLYLINE') 223 - CALL GRLINE(2,XU,YU) 224 - CALL GRATTS('BOX-TICKMARKS','POLYLINE') 225 - ENDIF 226 - * Scale. 227 - CALL OUTFMT(XVAL/10.0**KKX,2,TICK,NC,'LEFT') 228 - CALL GSELNT(0) 229 - IF(.NOT.LOGX)XSC=XUTOD(XVAL) 230 - IF(LOGX)XSC=XUTOD(LOG10(XVAL)) 231 - CALL GRTX(XSC,0.1-GPXN,TICK(1:NC)) 232 - CALL GSELNT(1) 233 - 20 CONTINUE 234 - ** Log scale of 3 decades and less: 1-9 every decade. 235 - ELSE 236 - * Compute the size of the power-of-10 box. 237 - CALL GSCHUP(0.0,1.0) 238 - CALL GSTXAL(0,0) 239 - CALL GSELNT(0) 240 - CALL GQTXX(IWK,0.5,0.5,'9',IERR,CPX,CPY,XBOX,YBOX) 241 - YPOWER=MAX(YBOX(1),YBOX(2),YBOX(3),YBOX(4))- 242 - - MIN(YBOX(1),YBOX(2),YBOX(3),YBOX(4)) 243 - CALL GSELNT(1) 244 - * Establish range of decades. 245 - NDEC0=INT(LOG10(XMIN))-1 246 - NDEC1=INT(LOG10(XMAX))+1 247 - * Loop over the decades. 248 - DO 30 IDEC=NDEC0,NDEC1 249 - DO 40 I=1,9 250 - XVAL=I*10.0**IDEC 251 - IF(XVAL.LE.XMIN.OR.XVAL.GE.XMAX)GOTO 40 252 - * Tickmarks. 253 - XU(1)=XVAL 254 - XU(2)=XVAL 255 - YU(1)=YMIN 256 - IF(LOGY)THEN 257 - YU(2)=YMIN*TICKY 258 - ELSE 259 - YU(2)=YMIN+TICKY 260 - ENDIF 261 - CALL GRLINE(2,XU,YU) 262 - YU(1)=YMAX 263 - IF(LOGY)THEN 264 - YU(2)=YMAX/TICKY 265 - ELSE 266 - YU(2)=YMAX-TICKY 267 - ENDIF 268 - CALL GRLINE(2,XU,YU) 269 - * Optional grid. 270 - IF(LGRID)THEN 271 - IF(LOGY)THEN 272 - YU(1)=YMIN*TICKY 273 - YU(2)=YMAX/TICKY 274 - ELSE 275 - YU(1)=YMIN+TICKY 276 - YU(2)=YMAX-TICKY 277 - ENDIF 278 - CALL GRATTS('GRID','POLYLINE') 279 - CALL GRLINE(2,XU,YU) 280 - CALL GRATTS('BOX-TICKMARKS','POLYLINE') 281 - ENDIF 282 - * Scale. 283 - CALL GSELNT(0) 284 - * Decades. 285 - IF(I.EQ.1)THEN 286 - IF(LOGX)THEN 287 - XSC=XUTOD(LOG10(XVAL)) 288 - ELSE 289 - XSC=XUTOD(XVAL) 290 - ENDIF 291 - IF(IDEC.EQ.0)THEN 1 136 P=GRAPHICS D=GRCART 4 PAGE 233 292 - CALL GSTXAL(2,1) 293 - CALL GRTX(XSC,0.1-GPXN10-YPOWER,'1') 294 - ELSEIF(IDEC.EQ.1)THEN 295 - CALL GSTXAL(2,1) 296 - CALL GRTX(XSC,0.1-GPXN10-YPOWER,'10') 297 - ELSE 298 - CALL GSTXAL(2,1) 299 - CALL GRTX(XSC,0.1-GPXN10-YPOWER,'10') 300 - CALL GQTXX(IWK,0.5,0.5,'10',IERR,CPX,CPY, 301 - - XBOX,YBOX) 302 - XPOWER=MAX(XBOX(1),XBOX(2),XBOX(3),XBOX(4))- 303 - - MIN(XBOX(1),XBOX(2),XBOX(3),XBOX(4)) 304 - CALL OUTFMT(REAL(IDEC),2,TICK,NC,'LEFT') 305 - CALL GSTXAL(1,0) 306 - CALL GRTX(XSC+XPOWER/2,0.1-GPXN10-YPOWER, 307 - - TICK(1:NC)) 308 - ENDIF 309 - * Numbers. 310 - ELSEIF(NDECX.LE.3)THEN 311 - CALL OUTFMT(REAL(I),2,TICK,NC,'LEFT') 312 - IF(LOGX)THEN 313 - XSC=XUTOD(LOG10(XVAL)) 314 - ELSE 315 - XSC=XUTOD(XVAL) 316 - ENDIF 317 - CALL GSTXAL(2,1) 318 - CALL GRTX(XSC,0.1-GPXN,TICK(1:NC)) 319 - ENDIF 320 - CALL GSELNT(1) 321 - 40 CONTINUE 322 - 30 CONTINUE 323 - ENDIF 324 - *** y-Axis: Tickmarks and scales. 325 - CALL GSCHUP(0.0,1.0) 326 - IF(NDECY.LE.1)THEN 327 - CALL GSTXAL(3,3) 328 - DO 50 I=0,1+INT((YMAX-YMIN)/DY) 329 - YVAL=DY*(INT(YMIN/DY)+I) 330 - IF(YMIN.GE.YVAL.OR.YVAL.GE.YMAX)GOTO 50 331 - * Tickmarks. 332 - YU(1)=YVAL 333 - YU(2)=YVAL 334 - XU(1)=XMIN 335 - IF(LOGX)THEN 336 - XU(2)=XMIN*TICKX 337 - ELSE 338 - XU(2)=XMIN+TICKX 339 - ENDIF 340 - CALL GRLINE(2,XU,YU) 341 - XU(1)=XMAX 342 - IF(LOGX)THEN 343 - XU(2)=XMAX/TICKX 344 - ELSE 345 - XU(2)=XMAX-TICKX 346 - ENDIF 347 - CALL GRLINE(2,XU,YU) 348 - * Optional grid. 349 - IF(LGRID)THEN 350 - IF(LOGX)THEN 351 - XU(1)=XMIN*TICKX 352 - XU(2)=XMAX/TICKX 353 - ELSE 354 - XU(1)=XMIN+TICKX 355 - XU(2)=XMAX-TICKX 356 - ENDIF 357 - CALL GRATTS('GRID','POLYLINE') 358 - CALL GRLINE(2,XU,YU) 359 - CALL GRATTS('BOX-TICKMARKS','POLYLINE') 360 - ENDIF 361 - * Scale. 362 - CALL OUTFMT(YVAL/10.0**KKY,2,TICK,NC,'LEFT') 363 - CALL GSELNT(0) 364 - IF(LOGY)THEN 365 - YSC=YUTOD(LOG10(YVAL)) 366 - ELSE 367 - YSC=YUTOD(YVAL) 368 - ENDIF 369 - CALL GRTX(0.1-GPYN,YSC,TICK(1:NC)) 370 - CALL GSELNT(1) 371 - 50 CONTINUE 372 - ** Log scale of 3 decades and less: 1-9 every decade. 373 - ELSE 374 - * Compute decade range. 375 - NDEC0=INT(LOG10(YMIN))-1 376 - NDEC1=INT(LOG10(YMAX))+1 377 - * Loop over the decades. 378 - DO 60 IDEC=NDEC0,NDEC1 379 - DO 70 I=1,9 380 - YVAL=I*10.0**IDEC 381 - IF(YVAL.LE.YMIN.OR.YVAL.GE.YMAX)GOTO 70 382 - * Tickmarks. 383 - XU(1)=XMIN 384 - IF(LOGX)THEN 385 - XU(2)=XMIN*TICKX 386 - ELSE 387 - XU(2)=XMIN+TICKX 388 - ENDIF 389 - YU(1)=YVAL 390 - YU(2)=YVAL 391 - CALL GRLINE(2,XU,YU) 392 - XU(1)=XMAX 393 - IF(LOGX)THEN 394 - XU(2)=XMAX/TICKX 395 - ELSE 396 - XU(2)=XMAX-TICKX 397 - ENDIF 1 136 P=GRAPHICS D=GRCART 5 PAGE 234 398 - CALL GRLINE(2,XU,YU) 399 - * Optional grid. 400 - IF(LGRID)THEN 401 - IF(LOGX)THEN 402 - XU(1)=XMIN*TICKX 403 - XU(2)=XMAX/TICKX 404 - ELSE 405 - XU(1)=XMIN+TICKX 406 - XU(2)=XMAX-TICKX 407 - ENDIF 408 - CALL GRATTS('GRID','POLYLINE') 409 - CALL GRLINE(2,XU,YU) 410 - CALL GRATTS('BOX-TICKMARKS','POLYLINE') 411 - ENDIF 412 - * Scale. 413 - CALL GSELNT(0) 414 - IF(I.EQ.1)THEN 415 - IF(LOGY)THEN 416 - YSC=YUTOD(LOG10(YVAL)) 417 - ELSE 418 - YSC=YUTOD(YVAL) 419 - ENDIF 420 - IF(IDEC.EQ.0)THEN 421 - CALL GSTXAL(3,3) 422 - CALL GRTX(0.1-GPYN10,YSC,'1') 423 - ELSEIF(IDEC.EQ.1)THEN 424 - CALL GSTXAL(3,3) 425 - CALL GRTX(0.1-GPYN10,YSC,'10') 426 - ELSE 427 - CALL GSTXAL(3,3) 428 - CALL OUTFMT(REAL(IDEC),2,TICK,NC,'LEFT') 429 - CALL GQTXX(IWK,0.5,0.5,TICK(1:NC),IERR,CPX,CPY, 430 - - XBOX,YBOX) 431 - XPOWER=MAX(XBOX(1),XBOX(2),XBOX(3),XBOX(4))- 432 - - MIN(XBOX(1),XBOX(2),XBOX(3),XBOX(4)) 433 - YPOWER=MAX(YBOX(1),YBOX(2),YBOX(3),YBOX(4))- 434 - - MIN(YBOX(1),YBOX(2),YBOX(3),YBOX(4)) 435 - CALL GRTX(0.1-GPYN10-XPOWER,YSC,'10') 436 - CALL GSTXAL(1,0) 437 - CALL GRTX(0.1-GPYN10-XPOWER,YSC+YPOWER/2, 438 - - TICK(1:NC)) 439 - ENDIF 440 - ELSEIF(NDECY.LE.3)THEN 441 - CALL OUTFMT(REAL(I),2,TICK,NC,'LEFT') 442 - IF(LOGY)THEN 443 - YSC=YUTOD(LOG10(YVAL)) 444 - ELSE 445 - YSC=YUTOD(YVAL) 446 - ENDIF 447 - CALL GSTXAL(3,3) 448 - CALL GRTX(0.1-GPYN,YSC,TICK(1:NC)) 449 - ENDIF 450 - CALL GSELNT(1) 451 - 70 CONTINUE 452 - 60 CONTINUE 453 - ENDIF 454 - *** Plot the title at the top and labels along the axis. 455 - CALL GSELNT(0) 456 - * Title. 457 - CALL GSCHUP(0.0,1.0) 458 - CALL GSTXAL(1,1) 459 - CALL GRATTS('TITLE','TEXT') 460 - CALL GRTX(0.1,1.0-GPXT,TITLE) 461 - * Label the x-axis. 462 - CALL GSTXAL(3,0) 463 - CALL GSCHUP(0.0,1.0) 464 - CALL GRATTS('LABELS','TEXT') 465 - CALL GQTXX(IWK,0.5,0.5,XTXT,IERR,CPX,CPY,XBOX,YBOX) 466 - YSHIFT=0.5-MIN(YBOX(1),YBOX(2),YBOX(3),YBOX(4)) 467 - CALL GRTX(0.9,GPXL+YSHIFT,XTXT) 468 - IF(KKX.NE.0)THEN 469 - CALL GSTXAL(1,0) 470 - CALL GSCHUP(1.0,0.0) 471 - CALL OUTFMT(REAL(KKX),2,AUX,NC,'LEFT') 472 - CALL GQTXX(IWK,0.5,0.5,AUX(1:NC),IERR,CPX,CPY,XBOX,YBOX) 473 - XPOWER=MAX(XBOX(1),XBOX(2),XBOX(3),XBOX(4))- 474 - - MIN(XBOX(1),XBOX(2),XBOX(3),XBOX(4)) 475 - YPOWER=MAX(YBOX(1),YBOX(2),YBOX(3),YBOX(4))- 476 - - MIN(YBOX(1),YBOX(2),YBOX(3),YBOX(4)) 477 - CALL GSTXAL(3,1) 478 - CALL GRATTS('LABELS','TEXT') 479 - CALL GRTX(1.0-GPYL-XPOWER,GPXL+YPOWER,'*10') 480 - CALL GRATTS('NUMBERS','TEXT') 481 - CALL GRTX(1.0-GPYL,GPXL,AUX(1:NC)) 482 - ENDIF 483 - * And label the y-axis. 484 - CALL GSTXAL(3,1) 485 - CALL GSCHUP(-1.0,0.0) 486 - CALL GRATTS('LABELS','TEXT') 487 - CALL GRTX(GPYL,0.9,YTXT) 488 - IF(KKY.NE.0)THEN 489 - CALL GSTXAL(0,0) 490 - CALL GSCHUP(0.0,1.0) 491 - CALL OUTFMT(REAL(KKY),2,AUX,NC,'LEFT') 492 - CALL GQTXX(IWK,0.5,0.5,'*10',IERR,CPX,CPY,XBOX,YBOX) 493 - XPOWER=MAX(XBOX(1),XBOX(2),XBOX(3),XBOX(4))- 494 - - MIN(XBOX(1),XBOX(2),XBOX(3),XBOX(4)) 495 - YPOWER=MAX(YBOX(1),YBOX(2),YBOX(3),YBOX(4))- 496 - - MIN(YBOX(1),YBOX(2),YBOX(3),YBOX(4)) 497 - CALL GRATTS('LABELS','TEXT') 498 - CALL GRTX(GPYL,0.92,'*10') 499 - CALL GRATTS('NUMBERS','TEXT') 500 - CALL GRTX(GPYL+XPOWER,0.92+YPOWER,AUX(1:NC)) 501 - ENDIF 502 - * Reset normalisation transformation, alignment and up-vector. 503 - CALL GSELNT(1) 1 136 P=GRAPHICS D=GRCART 6 PAGE 235 504 - CALL GSTXAL(0,0) 505 - CALL GSCHUP(0.0,1.0) 506 - END 137 GARFIELD ================================================== P=GRAPHICS D=GRCLWK 1 ============================ 0 + +DECK,GRCLWK. 1 - SUBROUTINE GRCLWK(NAME) 2 - *----------------------------------------------------------------------- 3 - * GRCLWK - Closes a workstation - GKS version. 4 - * (Last changed on 21/ 3/92.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,PRINTPLOT. 8.- +SEQ,GRAPHICS. 9 - EXTERNAL INPCMX 10 - INTEGER INPCMX 11 - CHARACTER*(*) NAME 12 - CHARACTER*(MXNAME) AUX 13 - *** Locate workstation. 14 - CALL GRQIWK(NAME,IWK,IFAIL) 15 - IF(IFAIL.NE.0)RETURN 16 - *** Check the current state of the workstation. 17 - IF(WKSTAT(IWK).LT.2)THEN 18 - PRINT *,' !!!!!! GRCLWK WARNING : Workstation ',NAME, 19 - - ' is not open ; not closed.' 20 - RETURN 21 - ENDIF 22 - CALL GQWKS(IWK,IERR,ISTATE) 23 - IF(IERR.NE.0)PRINT *,' !!!!!! GRCLWK WARNING : Inquiry error'// 24 - - ' for state of ',NAME,' ; assumed active.' 25 - IF(IERR.NE.0.OR.ISTATE.EQ.1)THEN 26 - PRINT *,' !!!!!! GRCLWK WARNING : Workstation ',NAME, 27 - - ' is still active; deactivated.' 28 - CALL GDAWK(IWK) 29 - WKSTAT(IWK)=2 0 30-+ +SELF,IF=HIGZ. 31 - CALL SGFLAG 0 32-+ +SELF. 33 - ENDIF 34 - *** And at last close the workstation. 35 - CALL GCLWK(IWK) 36 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRCLWK DEBUG :'', 37 - - '' Workstation '',A,'' has been closed.'')') NAME 38 - WKSTAT(IWK)=1 39 - * And any file associated with it. 40 - IF(WKLUN(IWK).GT.0)THEN 41 - CLOSE(UNIT=WKLUN(IWK),ERR=2030,IOSTAT=IOS) 42 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRCLWK DEBUG :'', 43 - - '' The associated file on unit '',I3, 44 - - '' has been closed.'')') WKLUN(IWK) 45 - ENDIF 46 - RETURN 47 - *** Error handling. 48 - 2030 CONTINUE 49 - CALL STRBUF('READ',WKFREF(IWK),AUX,NC,IFAIL1) 50 - PRINT *,' !!!!!! GRCLWK WARNING : Metafile '//AUX(1:NC)//' on '// 51 - - ' unit ',WKLUN(IWK),' is not properly closed.' 52 - CALL INPIOS(IOS) 53 - END 138 GARFIELD ================================================== P=GRAPHICS D=GRCOLC 1 ============================ 0 + +DECK,GRCOLC. 1 - SUBROUTINE GRCOLC(IWKID,IWKTYP,IFLAG) 2 - *----------------------------------------------------------------------- 3 - * GRCOLC - Routine figures out whether a wk has got colours or not. 4 - * (Last changed on 5/ 9/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,PRINTPLOT. 8 - INTEGER IWKID,IWKTYP,IFLAG,IERR,ISTATE,ICONID,IWKCAT, 9 - - NCOLS,ICOLS,NPRE 10 - *** Initial value: 1 meaning no colours. 11 - IFLAG=1 12 - *** Make sure the wk is active. 13 - CALL GQWKS(IWKID,IERR,ISTATE) 14 - IF(IERR.NE.0.OR.ISTATE.NE.1)THEN 15 - PRINT *,' !!!!!! GRCOLC WARNING : The workstation on'// 16 - - ' which the colours are to be set is not active.' 17 - RETURN 18 - ENDIF 19 - *** Determine wk type and category. 20 - CALL GQWKC(IWKID,IERR,ICONID,IWKTYP) 21 - IF(IERR.NE.0)THEN 22 - PRINT *,' !!!!!! GRCOLC WARNING : Unable to determine the'// 23 - - ' workstation type ; no colours set.' 24 - RETURN 25 - ENDIF 26 - CALL GQWKCA(IWKTYP,IERR,IWKCAT) 27 - IF(IERR.NE.0)THEN 28 - PRINT *,' !!!!!! GRCOLC WARNING : Unable to determine the'// 29 - - ' workstation category ; no colours set.' 30 - RETURN 31 - ENDIF 32 - * For WISS and MO, no way to see whether there are colours. 33 - IF(IWKCAT.EQ.3.OR.IWKCAT.EQ.4)THEN 34 - IF(LDEBUG)PRINT *,' ++++++ GRCOLC DEBUG : Workstation'// 35 - - ' category WISS or MO; no further checks.' 36 - IFLAG=-1 37 - RETURN 38 - ENDIF 39 - *** Ask the number of colours. 40 - CALL GQCF(IWKTYP,IERR,NCOLS,ICOLS,NPRE) 1 138 P=GRAPHICS D=GRCOLC 2 PAGE 236 41 - IF(LDEBUG)WRITE(LUNOUT,*) 42 - - ' ++++++ GRCOLC DEBUG : Colour data'// 43 - - ' for workstation ',IWKID,' of type ',IWKTYP,':' 44 - IF(LDEBUG)WRITE(LUNOUT,*) 45 - - ' Colours y/n', 46 - - ICOLS,', number of colours: ',NCOLS,', predefined: ',NPRE 47 - IF(IERR.NE.0)THEN 48 - PRINT *,' !!!!!! GRCOLC WARNING : Unable to determine'// 49 - - ' whether the workstation has colours ; nothing done.' 50 - RETURN 51 - ELSEIF(ICOLS.EQ.0.OR.NCOLS.EQ.2)THEN 52 - PRINT *,' !!!!!! GRCOLC WARNING : The workstation has'// 53 - - ' no colour facilities ; nothing done.' 54 - RETURN 55 - ENDIF 56 - *** OK, set flag to 0. 57 - IFLAG=0 58 - END 139 GARFIELD ================================================== P=GRAPHICS D=GRCOLR 1 ============================ 0 + +DECK,GRCOLR. 1 - SUBROUTINE GRCOLR(IKEY,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GRCOLR - Reads colour descriptions and stores them. 4 - * GRCOLQ - Returns the index for a given colour name. 5 - * GRCOLD - Returns the name for a colour with a given index. 6 - * GRCOLW - Writes a colour table to a library. 7 - * GRCOLG - Retrieves a colour table from a library. 8 - * GRCOLM - Plots a colour map. 9 - * GRCOLS - Resets the colour table. 10 - * (Last changed on 5/ 9/99.) 11 - *----------------------------------------------------------------------- 12 - implicit none 13.- +SEQ,DIMENSIONS. 14.- +SEQ,PRINTPLOT. 15 - INTEGER MXCOL 16 - PARAMETER (MXCOL=25) 17 - CHARACTER*(*) COLCMP,OPTION 18 - CHARACTER*(MXINCH) STRING 19 - CHARACTER*(MXNAME) FILE 20 - CHARACTER*80 DESCR,AUX 21 - CHARACTER*29 REMARK 22 - CHARACTER*20 COLNAM(0:MXCOL),AUX1,AUX2,AUX3 23 - CHARACTER*8 TIME,DATE,MEMBER 24 - LOGICAL EXIS,DSNCMP,EXMEMB 25 - INTEGER INPTYP,INPCMP,INPCMX,NC,NC1,NC2,NC3,ICOL,NCOL,IKEY, 26 - - IOPSTA,NWORD,IWK,IERR,IDUM,IWKID,ITYPE,IWKTYP, 27 - - IERR0,IERR1,IERR2,MPL,MPM,MTX,MFA,MPA,MXCOLI, 28 - - IWKCAT,INEXT,IFAIL,IFAIL1,IFLAG,IC,NCC,IWKDUM,ICIND,NCD, 29 - - NCFILE,NCMEMB,NCREM,I,II,IOS,ICONID,IWKDES,NACT 30 - REAL XPL(5),YPL(5),BLUE,GREEN,RED,BLUES,GREENS,REDS,BLUER,GREENR, 31 - - REDR 32 - EXTERNAL INPTYP,INPCMP,INPCMX 0 33-+ +SELF,IF=SAVE. 34 - SAVE COLNAM,NCOL 0 35-+ +SELF. 36 - DATA NCOL /1/ 37 - DATA (COLNAM(I),I=0,1) / 38 - - 'BACKGROUND ', 39 - - 'FOREGROUND '/ 40 - *** Assume the command fails. 41 - IFAIL=1 42 - *** Pick up the name of the colour. 43 - CALL INPNUM(NWORD) 44 - ICOL=-1 45 - IF(IKEY+1.LE.NWORD)THEN 46 - CALL INPSTR(IKEY+1,IKEY+1,STRING,NC) 47 - IF(NC.GT.20)THEN 48 - PRINT *,' !!!!!! GRCOLR WARNING : The name of the'// 49 - - ' colour is longer than 20 chars ; truncated.' 50 - NC=20 51 - ENDIF 52 - DO 10 I=0,NCOL 53 - IF(STRING(1:NC).EQ.COLNAM(I))THEN 54 - ICOL=I 55 - GOTO 20 56 - ENDIF 57 - 10 CONTINUE 58 - ICOL=NCOL+1 59 - 20 CONTINUE 60 - ELSE 61 - STRING=' ' 62 - NC=1 63 - ENDIF 64 - *** Default workstation (find one that has output). 65 - CALL GQOPS(IOPSTA) 66 - * No active workstations. 67 - IF(IOPSTA.LT.3)THEN 68 - PRINT *,' !!!!!! GRCOLR WARNING : No active workstations'// 69 - - ' ; COLOUR not executed.' 70 - RETURN 71 - ENDIF 72 - * Determine number of active workstations. 73 - CALL GQACWK(0,IERR,NACT,IWK) 74 - IWKID=-1 75 - ITYPE=0 76 - DO 30 I=1,NACT 77 - CALL GQACWK(I,IERR,IDUM,IWK) 78 - * Locate one an out/in ws, if not existing one of type out. 79 - CALL GQWKC(IWK,IERR1,ICONID,IWKTYP) 80 - CALL GQWKCA(IWKTYP,IERR2,IWKCAT) 81 - IF(IWKCAT.EQ.2.AND.ITYPE.LT.2)THEN 82 - IWKID=IWK 1 139 P=GRAPHICS D=GRCOLR 2 PAGE 237 83 - ITYPE=2 84 - ELSEIF((IWKCAT.EQ.0.OR.IWKCAT.EQ.4).AND.ITYPE.LT.1)THEN 85 - IWKID=IWK 86 - ITYPE=1 87 - ENDIF 88 - 30 CONTINUE 89 - * Issue an string request to an input workstation. 90 - IF(IWKID.EQ.-1)THEN 91 - PRINT *,' !!!!!! GRCOLR WARNING : No active workstations'// 92 - - ' with output facilities ; COLOUR not executed.' 93 - RETURN 94 - ENDIF 95 - *** Default colour. 96 - BLUE=-1.0 97 - GREEN=-1.0 98 - RED=-1.0 99 - *** Read the various components of the colour description. 100 - INEXT=IKEY+2 101 - DO 100 I=IKEY+2,NWORD 102 - IF(I.LT.INEXT)GOTO 100 103 - IF(INPCMP(I,'BL#UE').NE.0)THEN 104 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN 105 - CALL INPMSG(I,'Blue value missing or not real') 106 - ELSE 107 - CALL INPCHK(I+1,2,IFAIL1) 108 - CALL INPRDR(I+1,BLUE,-1.0) 109 - IF(IFAIL1.EQ.0.AND.(BLUE.LT.0.0.OR.BLUE.GT.1.0)) 110 - - CALL INPMSG(I+1,'Blue value not in range [0,1].') 111 - INEXT=I+2 112 - ENDIF 113 - ELSEIF(INPCMP(I,'GR#EEN').NE.0)THEN 114 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN 115 - CALL INPMSG(I,'Green is missing or not real. ') 116 - ELSE 117 - CALL INPCHK(I+1,2,IFAIL1) 118 - CALL INPRDR(I+1,GREEN,-1.0) 119 - IF(IFAIL1.EQ.0.AND.(GREEN.LT.0.0.OR.GREEN.GT.1.0)) 120 - - CALL INPMSG(I+1,'Green value not in range [0,1]') 121 - INEXT=I+2 122 - ENDIF 123 - ELSEIF(INPCMP(I,'RED').NE.0)THEN 124 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN 125 - CALL INPMSG(I,'Red value missing or not real.') 126 - ELSE 127 - CALL INPCHK(I+1,2,IFAIL1) 128 - CALL INPRDR(I+1,RED,-1.0) 129 - IF(IFAIL1.EQ.0.AND.(RED.LT.0.0.OR.RED.GT.1.0)) 130 - - CALL INPMSG(I+1,'Red value not in range [0,1]. ') 131 - INEXT=I+2 132 - ENDIF 133 - ELSEIF(INPCMP(I,'WORK#STATION').NE.0)THEN 134 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN 135 - CALL INPMSG(I,'Workstation missing or invalid') 136 - ELSE 137 - CALL INPCHK(I+1,1,IFAIL1) 138 - CALL INPRDI(I+1,IWKID,1) 139 - INEXT=I+2 140 - ENDIF 141 - ELSE 142 - CALL INPMSG(I,'This is not a known keyword. ') 143 - ENDIF 144 - 100 CONTINUE 145 - *** Dump the error messages. 146 - CALL INPERR 147 - *** Now check whether the workstation has at all colour facilities. 148 - CALL GRCOLC(IWKID,IWKTYP,IFLAG) 149 - IF(IFLAG.GT.0)THEN 150 - PRINT *,' !!!!!! GRCOLR WARNING : The workstation does'// 151 - - ' not have colour facilities.' 152 - RETURN 153 - ENDIF 154 - *** Check validity of the request in terms of intensities. 155 - IF(NWORD.GT.IKEY+1.AND.(BLUE.LT.0.OR.BLUE.GT.1.OR.RED.LT.0.OR. 156 - - RED.GT.1.OR.GREEN.LT.0.OR.GREEN.GT.1))THEN 157 - PRINT *,' !!!!!! GRCOLR WARNING : Your update request is'// 158 - - ' not carried out because the' 159 - PRINT *,' colour is either'// 160 - - ' incompletely or incorrectly specified.' 161 - RETURN 162 - ENDIF 163 - *** Try incrementing the number of colours if update is requested. 164 - IF(ICOL.GT.NCOL.AND.NWORD.GT.IKEY+1)THEN 165 - IF(IFLAG.LT.0)GOTO 1010 166 - CALL GQLWK(IWKTYP,IERR,MPL,MPM,MTX,MFA,MPA,MXCOLI) 167 - IF(LDEBUG)WRITE(LUNOUT,*) ' ++++++ GRCOLR DEBUG : Max.'// 168 - - ' number of colours on this workstation: ',MXCOLI 169 - IF(IERR.NE.0)THEN 170 - PRINT *,' !!!!!! GRCOLR WARNING : Unable to obtain'// 171 - - ' the wk state table length; nothing done.' 172 - RETURN 173 - ENDIF 174 - IF(ICOL+1.GT.MXCOLI)THEN 175 - PRINT *,' !!!!!! GRCOLR WARNING : Workstation table'// 176 - - ' of colours is full; new colour not defined.' 177 - RETURN 178 - ENDIF 179 - 1010 CONTINUE 180 - IF(ICOL+1.GT.MXCOL)THEN 181 - PRINT *,' !!!!!! GRCOLR WARNING : Internal colour'// 182 - - ' name table is full; increase MXCOL, not defined.' 183 - RETURN 184 - ENDIF 185 - NCOL=ICOL 186 - COLNAM(ICOL)=STRING(1:NC) 187 - *** Failing inquiry because the colour is not known. 188 - ELSEIF(ICOL.GT.NCOL.AND.NWORD.EQ.IKEY+1)THEN 1 139 P=GRAPHICS D=GRCOLR 3 PAGE 238 189 - PRINT *,' !!!!!! GRCOLR WARNING : The colour is not known.' 190 - RETURN 191 - ENDIF 192 - *** Inquiry and update. 193 - DO 200 I=0,NCOL 194 - IF(ICOL.EQ.-1.OR.(IKEY+1.EQ.NWORD.AND. 195 - - STRING(1:NC).EQ.COLNAM(I)))THEN 196 - CALL GRQCR(IWKID,I,0,IERR0,REDS,GREENS,BLUES) 197 - CALL GRQCR(IWKID,I,1,IERR1,REDR,GREENR,BLUER) 198 - DO 210 IC=20,1,-1 199 - IF(COLNAM(I)(IC:IC).NE.' ')THEN 200 - NCC=IC 201 - GOTO 220 202 - ENDIF 203 - 210 CONTINUE 204 - NCC=1 205 - 220 CONTINUE 206 - IF(IERR0.NE.0.OR.IERR1.NE.0)THEN 207 - WRITE(LUNOUT,'(/'' Unable to retrieve the current'', 208 - - '' representation of colour '',A,''.''/)') 209 - - COLNAM(I)(1:NCC) 210 - ELSE 211 - WRITE(LUNOUT,'(/'' Current representation of'', 212 - - '' colour '',A,'' on workstation '',I3,'':''// 213 - - 2X,'' Blue: '',F10.3,'' (set), '', 214 - - F10.3,'' (realised),''/ 215 - - 2X,'' Green: '',F10.3,'' (set), '', 216 - - F10.3,'' (realised),''/ 217 - - 2X,'' Red: '',F10.3,'' (set), '', 218 - - F10.3,'' (realised).''/)') COLNAM(I)(1:NCC), 219 - - IWKID,BLUES,BLUER,GREENS,GREENR,REDS,REDR 220 - ENDIF 221 - ELSEIF(NWORD.GT.IKEY+1.AND.STRING(1:NC).EQ.COLNAM(I))THEN 222 - CALL GRSCR(IWKID,ICOL,RED,GREEN,BLUE) 223 - ENDIF 224 - 200 CONTINUE 225 - *** If we get here, things are probably OK. 226 - IFAIL=0 227 - RETURN 228 - *** GRCOLQ: Return the table index corresponding to a colour name. 229 - ENTRY GRCOLQ(IWKDUM,COLCMP,ICIND) 230 - * Try to locate the colour in the table. 231 - DO 300 I=0,NCOL 232 - IF(INPCMX(COLCMP,COLNAM(I)).NE.0)THEN 233 - ICIND=I 234 - GOTO 320 235 - ENDIF 236 - 300 CONTINUE 237 - * Set to -1 if not found. 238 - ICIND=-1 239 - 320 CONTINUE 240 - RETURN 241 - *** GRCOLD: Return a string containing the description. 242 - ENTRY GRCOLD(IWKDES,ICIND,DESCR,NCD,OPTION) 243 - * Reject invalid colour reference numbers. 244 - IF(ICIND.LT.0.OR.ICIND.GT.NCOL)THEN 245 - DESCR='# Not a known colour.' 246 - NCD=21 247 - RETURN 248 - ENDIF 249 - * Inquire GKS about the intensities. 250 - CALL GRQCR(IWKDES,ICIND,1,IERR,RED,GREEN,BLUE) 251 - * And format the colour description. 252 - IF(IERR.NE.0)THEN 253 - DESCR='# Error retrieving the data.' 254 - NCD=28 255 - CALL INPFIX(COLNAM(ICIND),AUX,NC) 256 - DESCR=AUX(1:NC)//' (Unable to retrieve the description)' 257 - NCD=NC+37 258 - ELSE 259 - IF(OPTION.EQ.'RAW')THEN 260 - DESCR=COLNAM(ICIND) 261 - NCD=20 262 - ELSE 263 - CALL INPFIX(COLNAM(ICIND),AUX,NC) 264 - CALL OUTFMT(RED,2,AUX1,NC1,'LEFT') 265 - CALL OUTFMT(BLUE,2,AUX2,NC2,'LEFT') 266 - CALL OUTFMT(GREEN,2,AUX3,NC3,'LEFT') 267 - DESCR=AUX(1:NC)//' (Red '//AUX1(1:NC1)//', Blue '// 268 - - AUX2(1:NC2)//', Green '//AUX3(1:NC3)//')' 269 - NCD=NC+NC1+NC2+NC3+22 270 - ENDIF 271 - ENDIF 272 - RETURN 273 - *** Write the settings to a file. 274 - ENTRY GRCOLW(IKEY,IFAIL) 275 - * Initial settings. 276 - FILE=' ' 277 - NCFILE=1 278 - MEMBER='< none >' 279 - NCMEMB=8 280 - REMARK='none' 281 - NCREM=4 282 - IFAIL=1 283 - IWKID=1 284 - * Make sure there are colours. 285 - CALL GRCOLC(IWKID,IWKTYP,IFLAG) 286 - IF(IFLAG.GT.0)THEN 287 - PRINT *,' !!!!!! GRCOLW WARNING : The workstation does'// 288 - - ' not have colour facilities.' 289 - RETURN 290 - ENDIF 291 - * First decode the argument string. 292 - CALL INPNUM(NWORD) 293 - * Make sure there is at least one argument. 294 - IF(NWORD.EQ.IKEY)THEN 1 139 P=GRAPHICS D=GRCOLR 4 PAGE 239 295 - PRINT *,' !!!!!! GRCOLW WARNING : WRITE takes at least one', 296 - - ' argument (a dataset name); data will not be written.' 297 - RETURN 298 - * Check whether keywords have been used. 299 - ELSEIF(INPCMP(IKEY+1,'D#ATASET')+ 300 - - INPCMP(IKEY+1,'R#EMARK').NE.0)THEN 301 - INEXT=IKEY+1 302 - DO 410 I=IKEY+1,NWORD 303 - IF(I.LT.INEXT)GOTO 410 304 - IF(INPCMP(I,'D#ATASET').NE.0)THEN 305 - IF(INPCMP(I+1,'R#EMARK').NE.0.OR.I+1.GT.NWORD)THEN 306 - CALL INPMSG(I,'The dataset name is missing. ') 307 - INEXT=I+1 308 - ELSE 309 - CALL INPSTR(I+1,I+1,STRING,NCFILE) 310 - FILE=STRING 311 - INEXT=I+2 312 - IF(INPCMP(I+2,'R#EMARK').EQ.0.AND. 313 - - I+2.LE.NWORD)THEN 314 - CALL INPSTR(I+2,I+2,STRING,NCMEMB) 315 - MEMBER=STRING 316 - INEXT=I+3 317 - ENDIF 318 - ENDIF 319 - ELSEIF(INPCMP(I,'R#EMARK').NE.0)THEN 320 - IF(INPCMP(I+1,'D#ATASET').NE.0.OR.I+1.GT.NWORD)THEN 321 - CALL INPMSG(I,'The remark is missing. ') 322 - INEXT=I+1 323 - ELSE 324 - CALL INPSTR(I+1,I+1,STRING,NCREM) 325 - REMARK=STRING 326 - INEXT=I+2 327 - ENDIF 328 - ELSE 329 - CALL INPMSG(I,'The parameter is not known. ') 330 - ENDIF 331 - 410 CONTINUE 332 - * Otherwise the string is interpreted as a file name (+ member name). 333 - ELSE 334 - CALL INPSTR(IKEY+1,IKEY+1,STRING,NCFILE) 335 - FILE=STRING 336 - IF(NWORD.GE.IKEY+2)THEN 337 - CALL INPSTR(IKEY+2,IKEY+2,STRING,NCMEMB) 338 - MEMBER=STRING 339 - ENDIF 340 - IF(NWORD.GE.IKEY+3)THEN 341 - CALL INPSTR(IKEY+3,NWORD,STRING,NCREM) 342 - REMARK=STRING 343 - ENDIF 344 - ENDIF 345 - * Print error messages. 346 - CALL INPERR 347 - IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! GRCOLW WARNING : The file', 348 - - ' name is truncated to MXNAME (=',MXNAME,') characters.' 349 - IF(NCMEMB.GT.8)PRINT *,' !!!!!! GRCOLW WARNING : The member', 350 - - ' name is shortened to ',MEMBER,', first 8 characters.' 351 - IF(NCREM.GT.29)PRINT *,' !!!!!! GRCOLW WARNING : The remark', 352 - - ' shortened to ',REMARK,', first 29 characters.' 353 - NCFILE=MIN(NCFILE,MXNAME) 354 - NCMEMB=MIN(NCMEMB,8) 355 - NCREM=MIN(NCREM,29) 356 - * Check whether the member already exists. 357 - CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'GRAPHCOL',EXMEMB) 358 - IF(JEXMEM.EQ.2.AND.EXMEMB)THEN 359 - PRINT *,' ------ GRCOLW MESSAGE : A copy of the member'// 360 - - ' exists; new member will be appended.' 361 - ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN 362 - PRINT *,' !!!!!! GRCOLW WARNING : A copy of the member'// 363 - - ' exists already; member will not be written.' 364 - RETURN 365 - ENDIF 366 - * Print some debugging output if requested. 367 - IF(LDEBUG)THEN 368 - PRINT *,' ++++++ GRCOLW DEBUG : File= '//FILE(1:NCFILE)// 369 - - ', member= '//MEMBER(1:NCMEMB) 370 - PRINT *,' Remark= '//REMARK(1:NCREM) 371 - ENDIF 372 - ** Open the dataset for sequential write and inform DSNLOG. 373 - CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) 374 - IF(IFAIL.NE.0)THEN 375 - PRINT *,' !!!!!! GRCOLW WARNING : Opening '//FILE(1:NCFILE), 376 - - ' failed ; the colour data will not be written.' 377 - RETURN 378 - ENDIF 379 - CALL DSNLOG(FILE,'Colours ','Sequential','Write ') 380 - IF(LDEBUG)PRINT *,' ++++++ GRCOLW DEBUG : Dataset ', 381 - - FILE(1:NCFILE),' opened on unit 12 for seq write.' 382 - * Now write a heading record to the file. 383 - CALL DATTIM(DATE,TIME) 384 - WRITE(STRING,'(''% Created '',A8,'' At '',A8,1X,A8,'' GRAPHCOL'', 385 - - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK 386 - WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING 387 - IF(LDEBUG)THEN 388 - PRINT *,' ++++++ GRCOLW DEBUG : Dataset heading record:' 389 - PRINT *,STRING 390 - ENDIF 391 - * Write the actual data, start with the number of colours. 392 - WRITE(12,'('' NCOL='',I3)',ERR=2010,IOSTAT=IOS) NCOL 393 - * Next a list of Polyline attributes. 394 - DO 420 I=0,NCOL 395 - CALL GRQCR(IWKID,I,1,IERR,RED,GREEN,BLUE) 396 - IF(IERR.NE.0)THEN 397 - PRINT *,' !!!!!! GRCOLW WARNING : Unable to retrieve data'// 398 - - ' about colour ',I 399 - GOTO 420 400 - ENDIF 1 139 P=GRAPHICS D=GRCOLR 5 PAGE 240 401 - WRITE(12,'(A20,3E15.8)',ERR=2010,IOSTAT=IOS) 402 - - COLNAM(I),RED,BLUE,GREEN 403 - 420 CONTINUE 404 - ** Close the file after the operation. 405 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 406 - CALL TIMLOG('Writing out a list of colours: ') 407 - IFAIL=0 408 - RETURN 409 - *** Read the presentation from dataset. 410 - ENTRY GRCOLG(IKEY,IFAIL) 411 - * Initial values. 412 - FILE=' ' 413 - MEMBER='*' 414 - NCFILE=8 415 - NCMEMB=1 416 - IFAIL=1 417 - IWKID=1 418 - * Make sure there are colours. 419 - CALL GRCOLC(IWKID,IWKTYP,IFLAG) 420 - IF(IFLAG.GT.0)THEN 421 - PRINT *,' !!!!!! GRCOLW WARNING : The workstation does'// 422 - - ' not have colour facilities.' 423 - RETURN 424 - ENDIF 425 - ** First decode the argument string, setting file name + member name. 426 - CALL INPNUM(NWORD) 427 - * If there's only one argument, it's the dataset name. 428 - IF(NWORD.GE.IKEY+1)THEN 429 - CALL INPSTR(IKEY+1,IKEY+1,STRING,NCFILE) 430 - FILE=STRING 431 - ENDIF 432 - * If there's a second argument, it is the member name. 433 - IF(NWORD.GE.IKEY+2)THEN 434 - CALL INPSTR(IKEY+2,IKEY+2,STRING,NCMEMB) 435 - MEMBER=STRING 436 - ENDIF 437 - * Check the various lengths. 438 - IF(NCFILE.GT.MXNAME)THEN 439 - PRINT *,' !!!!!! GRCOLG WARNING : The file name is'// 440 - - ' truncated to MXNAME (=',MXNAME,') characters.' 441 - NCFILE=MIN(NCFILE,MXNAME) 442 - ENDIF 443 - IF(NCMEMB.GT.8)THEN 444 - PRINT *,' !!!!!! GRCOLG WARNING : The member name is'// 445 - - ' shortened to ',MEMBER,', first 8 characters.' 446 - NCMEMB=MIN(NCMEMB,8) 447 - ELSEIF(NCMEMB.LE.0)THEN 448 - PRINT *,' !!!!!! GRCOLG WARNING : The member'// 449 - - ' name has zero length, replaced by "*".' 450 - MEMBER='*' 451 - NCMEMB=1 452 - ENDIF 453 - * Reject the empty file name case. 454 - IF(FILE.EQ.' '.OR.NWORD.EQ.1)THEN 455 - PRINT *,' !!!!!! GRCOLG WARNING : GET must be at least'// 456 - - ' followed by a dataset name ; no data are read.' 457 - RETURN 458 - ENDIF 459 - * If there are even more args, warn they are ignored. 460 - IF(NWORD.GT.IKEY+2)PRINT *,' !!!!!! GRCOLG WARNING : GET takes'// 461 - - ' at most two arguments (dataset and member); rest ignored.' 462 - ** Open the dataset and inform DSNLOG. 463 - CALL DSNOPN(FILE,NCFILE,12,'READ-LIBRARY',IFAIL1) 464 - IF(IFAIL1.NE.0)THEN 465 - PRINT *,' !!!!!! GRCOLG WARNING : Opening ',FILE(1:NCFILE), 466 - - ' failed ; colour data are not read.' 467 - RETURN 468 - ENDIF 469 - CALL DSNLOG(FILE,'Colours ','Sequential','Read only ') 470 - IF(LDEBUG)PRINT *,' ++++++ GRCOLG DEBUG : Dataset', 471 - - FILE(1:NCFILE),' opened on unit 12 for seq read.' 472 - * Locate the pointer on the header of the requested member. 473 - CALL DSNLOC(MEMBER,NCMEMB,'GRAPHCOL',12,EXIS,'RESPECT') 474 - IF(.NOT.EXIS)THEN 475 - CALL DSNLOC(MEMBER,NCMEMB,'GRAPHCOL',12,EXIS,'IGNORE') 476 - IF(EXIS)THEN 477 - PRINT *,' ###### GRCOLG ERROR : Colour data ', 478 - - MEMBER(1:NCMEMB),' has been deleted from ', 479 - - FILE(1:NCFILE),'; not read.' 480 - ELSE 481 - PRINT *,' ###### GRCOLG ERROR : Colour data ', 482 - - MEMBER(1:NCMEMB),' not found on ',FILE(1:NCFILE) 483 - ENDIF 484 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 485 - RETURN 486 - ENDIF 487 - ** Check that the member is acceptable date wise. 488 - READ(12,'(A80)',END=2000,IOSTAT=IOS,ERR=2010) STRING 489 - IF(LDEBUG)THEN 490 - PRINT *,' ++++++ GRCOLG DEBUG : Dataset header'// 491 - - ' record follows:' 492 - PRINT *,STRING 493 - ENDIF 494 - IF(DSNCMP('14-07-89',STRING(11:18)))THEN 495 - PRINT *,' !!!!!! GRCOLG WARNING : Member '//STRING(32:39)// 496 - - ' can not be read because of a change in format.' 497 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 498 - RETURN 499 - ENDIF 500 - WRITE(LUNOUT,'('' Member '',A8,'' was created on '',A8, 501 - - '' at '',A8/'' Remarks: '',A29)') 502 - - STRING(32:39),STRING(11:18),STRING(23:30),STRING(51:79) 503 - * Read the actual data, start with the number of items of each type. 504 - READ(12,'(6X,I3)',END=2000,ERR=2010,IOSTAT=IOS) NCOL 505 - * Make sure none of these exceeds the maximum numbers. 506 - CALL GQLWK(IWKTYP,IERR,MPL,MPM,MTX,MFA,MPA,MXCOLI) 1 139 P=GRAPHICS D=GRCOLR 6 PAGE 241 507 - IF(NCOL.GT.MXCOLI.OR.NCOL.GT.MXCOL)THEN 508 - PRINT *,' !!!!!! GRCOLG WARNING : The number of colours'// 509 - - ' is larger than either the GKS or' 510 - PRINT *,' the compilation maxima;'// 511 - - ' increase these and recompile.' 512 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 513 - RETURN 514 - ENDIF 515 - * Read the list of colours. 516 - DO 430 I=0,NCOL 517 - READ(12,'(A20,3E15.8)',END=2000,ERR=2010,IOSTAT=IOS) 518 - - COLNAM(I),RED,BLUE,GREEN 519 - CALL GRSCR(IWKID,I,RED,GREEN,BLUE) 520 - 430 CONTINUE 521 - ** Close the file after the operation. 522 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 523 - CALL TIMLOG('Reading in a list of colours: ') 524 - IFAIL=0 525 - RETURN 526 - *** Plot a colour map. 527 - ENTRY GRCOLM 528 - ** Loop over the colours, first the loop over the pages. 529 - DO 510 II=0,NCOL,20 530 - * Switch to graphics mode. 531 - CALL GRGRAF(.TRUE.) 532 - * Switch to normalised device coordinates. 533 - CALL GSELNT(0) 534 - * Switch to solid interior style. 535 - CALL GSFAIS(1) 536 - * Set reasonable character attributes. 537 - CALL GSTXFP(0,2) 538 - CALL GSCHXP(1.0) 539 - CALL GSCHSP(0.0) 540 - CALL GSCHH(0.02) 541 - CALL GSTXAL(1,3) 542 - CALL GSCHUP(0.0,1.0) 543 - CALL GSTXCI(1) 544 - * Put some bands over the screen to compare colours, first white. 545 - XPL(1)=0.25 546 - YPL(1)=0 547 - XPL(2)=0.25 548 - YPL(2)=1 549 - XPL(3)=0.375 550 - YPL(3)=1 551 - XPL(4)=0.375 552 - YPL(4)=0 553 - XPL(5)=0.25 554 - YPL(5)=0 555 - CALL GSFACI(0) 556 - CALL GFA(5,XPL,YPL) 557 - * Then a black band. 558 - XPL(1)=0.375 559 - YPL(1)=0 560 - XPL(2)=0.375 561 - YPL(2)=1 562 - XPL(3)=0.5 563 - YPL(3)=1 564 - XPL(4)=0.5 565 - YPL(4)=0 566 - XPL(5)=0.375 567 - YPL(5)=0 568 - CALL GSFACI(1) 569 - CALL GFA(5,XPL,YPL) 570 - * If there are lots of colours, another white band. 571 - IF(MIN(19,NCOL-II).GE.10)THEN 572 - XPL(1)=0.75 573 - YPL(1)=0 574 - XPL(2)=0.75 575 - YPL(2)=1 576 - XPL(3)=0.875 577 - YPL(3)=1 578 - XPL(4)=0.875 579 - YPL(4)=0 580 - XPL(5)=0.75 581 - YPL(5)=0 582 - CALL GSFACI(0) 583 - CALL GFA(5,XPL,YPL) 584 - * And another black band. 585 - XPL(1)=0.875 586 - YPL(1)=0 587 - XPL(2)=0.875 588 - YPL(2)=1 589 - XPL(3)=1 590 - YPL(3)=1 591 - XPL(4)=1 592 - YPL(4)=0 593 - XPL(5)=0.875 594 - YPL(5)=0 595 - CALL GSFACI(1) 596 - CALL GFA(5,XPL,YPL) 597 - ENDIF 598 - ** Then the loop over the colours on this page. 599 - DO 520 I=0,MIN(19,NCOL-II) 600 - * Plot the colour name. 601 - CALL INPFIX(COLNAM(II+I),AUX,NC) 602 - IF(I.LE.9)THEN 603 - CALL GTX(0.02,0.95-0.1*I,AUX(1:NC)) 604 - ELSE 605 - CALL GTX(0.52,1.95-0.1*I,AUX(1:NC)) 606 - ENDIF 607 - * Set the colour. 608 - CALL GSFACI(II+I) 609 - * Plot a box with the colour. 610 - IF(I.LE.9)THEN 611 - XPL(1)=0.26 612 - YPL(1)=0.99-0.1*I 1 139 P=GRAPHICS D=GRCOLR 7 PAGE 242 613 - XPL(2)=0.26 614 - YPL(2)=0.91-0.1*I 615 - XPL(3)=0.49 616 - YPL(3)=0.91-0.1*I 617 - XPL(4)=0.49 618 - YPL(4)=0.99-0.1*I 619 - XPL(5)=0.26 620 - YPL(5)=0.99-0.1*I 621 - ELSE 622 - XPL(1)=0.76 623 - YPL(1)=1.99-0.1*I 624 - XPL(2)=0.76 625 - YPL(2)=1.91-0.1*I 626 - XPL(3)=0.99 627 - YPL(3)=1.91-0.1*I 628 - XPL(4)=0.99 629 - YPL(4)=1.99-0.1*I 630 - XPL(5)=0.76 631 - YPL(5)=1.99-0.1*I 632 - ENDIF 633 - CALL GFA(5,XPL,YPL) 634 - * Next colour. 635 - 520 CONTINUE 636 - * Next page. 637 - CALL GRALOG('Colour map:') 638 - CALL GRNEXT 639 - 510 CONTINUE 640 - * Keep track of CPU time consumption. 641 - CALL TIMLOG('Producing a colour map: ') 642 - RETURN 643 - *** Colour table reset. 644 - ENTRY GRCOLS 645 - NCOL=1 646 - RETURN 647 - *** Handle the error conditions. 648 - 2000 CONTINUE 649 - PRINT *,' ###### GRCOLG ERROR : Premature EOF ecountered on '// 650 - - FILE(1:NCFILE)//' read via unit 12 ; no valid data read.' 651 - CALL INPIOS(IOS) 652 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 653 - RETURN 654 - 2010 CONTINUE 655 - PRINT *,' ###### GRCOLW ERROR : I/O error accessing '// 656 - - FILE(1:NCFILE)//' via unit 12 ; no data read or written.' 657 - CALL INPIOS(IOS) 658 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 659 - RETURN 660 - 2030 CONTINUE 661 - PRINT *,' ###### GRCOLW ERROR : Dataset '//FILE(1:NCFILE)// 662 - - ' unit 12 cannot be closed ; results not predictable' 663 - CALL INPIOS(IOS) 664 - END 140 GARFIELD ================================================== P=GRAPHICS D=GRSCRH 1 ============================ 0 + +DECK,GRSCRH,IF=HIGZ. 1 - SUBROUTINE GRSCR(IWKID,ICOL,RED,GREEN,BLUE) 2 - *----------------------------------------------------------------------- 3 - * GRSCR - Sets a colour representation. 4 - * GRQCR - Query of a colour representation. 5 - * (Last changed on 18/ 5/96.) 6 - *----------------------------------------------------------------------- 7 - INTEGER IWKID,ICOL,IERR,IFLAG,MXCOL 8 - PARAMETER(MXCOL=100) 9 - REAL RED,GREEN,BLUE,RGB(MXCOL,3) 10 - LOGICAL COLSET(MXCOL) 0 11-+ +SELF,IF=SAVE. 12 - SAVE RGB,COLSET 0 13-+ +SELF. 14 - DATA RGB /MXCOL*0,MXCOL*0,MXCOL*0/, 15 - - COLSET /MXCOL*.FALSE./ 16 - *** Setting colours: if index makes sense, store it. 17 - IF(ICOL.GE.1.AND.ICOL.LE.MXCOL)THEN 18 - RGB(ICOL,1)=RED 19 - RGB(ICOL,2)=GREEN 20 - RGB(ICOL,3)=BLUE 21 - COLSET(ICOL)=.TRUE. 22 - ENDIF 23 - * At any rate pass on to HIGZ. 24 - CALL ISCR(IWKID,ICOL,RED,GREEN,BLUE) 25 - RETURN 26 - *** Queries on colour. 27 - ENTRY GRQCR(IWKID,ICOL,IFLAG,IERR,RED,GREEN,BLUE) 28 - * If within range, return colour setting. 29 - IF(ICOL.EQ.0)THEN 30 - RED=1 31 - GREEN=1 32 - BLUE=1 33 - IERR=0 34 - ELSEIF(ICOL.EQ.1)THEN 35 - RED=0 36 - GREEN=0 37 - BLUE=0 38 - IERR=0 39 - ELSEIF(ICOL.GE.1.AND.ICOL.LE.MXCOL)THEN 40 - RED=RGB(ICOL,1) 41 - GREEN=RGB(ICOL,2) 42 - BLUE=RGB(ICOL,3) 43 - IF(COLSET(ICOL))THEN 44 - IERR=0 45 - ELSE 46 - IERR=1 47 - ENDIF 48 - * Otherwise don't. 1 140 P=GRAPHICS D=GRSCRH 2 PAGE 243 49 - ELSE 50 - RED=0 51 - GREEN=0 52 - BLUE=0 53 - IERR=1 54 - ENDIF 55 - END 141 GARFIELD ================================================== P=GRAPHICS D=GRSCRG 1 ============================ 0 + +DECK,GRSCRG,IF=-HIGZ. 1 - SUBROUTINE GRSCR(IWKID,ICOL,RED,GREEN,BLUE) 2 - *----------------------------------------------------------------------- 3 - * GRSCR - Sets a colour representation. 4 - * GRQCR - Query of a colour representation. 5 - * (Last changed on 16/ 8/96.) 6 - *----------------------------------------------------------------------- 7 - INTEGER IWKID,ICOL,IERR,IFLAG,MXCOL 8 - REAL RED,GREEN,BLUE 9 - *** Setting colours. 10 - CALL GSCR(IWKID,ICOL,RED,GREEN,BLUE) 11 - RETURN 12 - *** Queries on colour. 13 - ENTRY GRQCR(IWKID,ICOL,IFLAG,IERR,RED,GREEN,BLUE) 14 - CALL GQCR(IWKID,ICOL,IFLAG,IERR,RED,GREEN,BLUE) 15 - END 142 GARFIELD ================================================== P=GRAPHICS D=GRSPLN 1 ============================ 0 + +DECK,GRSPLN. 1 - SUBROUTINE GRSPLN(NU,XU,YU) 2 - *----------------------------------------------------------------------- 3 - * GRSPLN - Plots a smooth line through a set of points. 4 - * (Last changed on 12/ 8/96.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7 - INTEGER NU,IFAIL,I 8 - REAL XU(*),YU(*),XPL(MXLIST),YPL(MXLIST),Z(MXLIST),C(MXLIST) 9 - *** Check number of points. 10 - IF(NU.LE.1)THEN 11 - WRITE(10,'('' !!!!!! GRSPLN WARNING : Insufficient'', 12 - - '' number ('',I3,'') of points on line; not'', 13 - - '' plotted.'')') NU 14 - RETURN 15 - ELSEIF(NU.GT.MXLIST)THEN 16 - WRITE(10,'('' !!!!!! GRSPLN WARNING : Too many points'', 17 - - '' ('',I3,'') on line; not plotted.'')') NU 18 - RETURN 19 - ENDIF 20 - *** Prepare interpolation vector. 21 - DO 10 I=1,NU 22 - Z(I)=1+REAL(MXLIST-1)*REAL(I-1)/REAL(NU-1) 23 - 10 CONTINUE 24 - *** Prepare x-spline interpolation. 25 - CALL SPLINE(Z,XU,C,NU,IFAIL) 26 - IF(IFAIL.NE.0)THEN 27 - WRITE(10,'('' !!!!!! GRSPLN WARNING : Preparation of'', 28 - - '' x-spline failed; line not plotted.'')') 29 - RETURN 30 - ENDIF 31 - *** Perform x-spline interpolation. 32 - DO 20 I=1,MXLIST 33 - IF(I.EQ.1)THEN 34 - XPL(I)=XU(1) 35 - ELSEIF(I.EQ.MXLIST)THEN 36 - XPL(I)=XU(NU) 37 - ELSE 38 - CALL INTERP(Z,XU,C,N,REAL(I),XPL(I),IFAIL) 39 - IF(IFAIL.NE.0)THEN 40 - WRITE(10,'('' !!!!!! GRSPLN WARNING : Interpolating'', 41 - - '' x-spline failed; line not plotted.'')') 42 - RETURN 43 - ENDIF 44 - ENDIF 45 - 20 CONTINUE 46 - *** Prepare y-spline interpolation. 47 - CALL SPLINE(Z,YU,C,NU,IFAIL) 48 - IF(IFAIL.NE.0)THEN 49 - WRITE(10,'('' !!!!!! GRSPLN WARNING : Preparation of'', 50 - - '' y-spline failed; line not plotted.'')') 51 - RETURN 52 - ENDIF 53 - *** Perform x-spline interpolation. 54 - DO 30 I=1,MXLIST 55 - IF(I.EQ.1)THEN 56 - YPL(I)=YU(1) 57 - ELSEIF(I.EQ.MXLIST)THEN 58 - YPL(I)=YU(NU) 59 - ELSE 60 - CALL INTERP(Z,YU,C,N,REAL(I),YPL(I),IFAIL) 61 - IF(IFAIL.NE.0)THEN 62 - WRITE(10,'('' !!!!!! GRSPLN WARNING : Interpolating'', 63 - - '' y-spline failed; line not plotted.'')') 64 - RETURN 65 - ENDIF 66 - ENDIF 67 - 30 CONTINUE 68 - *** Plot the curve. 69 - CALL GRLINE(MXLIST,XPL,YPL) 70 - END 1 143 GARFIELD ================================================== P=GRAPHICS D=GRCOMM 1 =================== PAGE 244 0 + +DECK,GRCOMM. 1 - SUBROUTINE GRCOMM(I,TEXT) 2 - *----------------------------------------------------------------------- 3 - * GRCOMM - Plotting a comment line on the plot (up to 4 of them). 4 - * (Last changed on 3/ 6/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - INTEGER I 8 - CHARACTER*(*) TEXT 9 - *** Check that the field label is in the range 1 to 4. 10 - IF(I.LT.1.OR.I.GT.5)THEN 11 - PRINT *,' ###### GRCOMM ERROR : Invalid field label ',I, 12 - - ' for the text "',TEXT,'" ; ignored (program bug).' 13 - RETURN 14 - ENDIF 15 - *** Make sure we're in the NDC coordinates. 16 - CALL GSELNT(0) 17 - *** Set the attributes belonging to comments. 18 - CALL GRATTS('COMMENT','TEXT') 19 - *** Set the text alignment and character-up vectors properly. 20 - CALL GSTXAL(0,0) 21 - CALL GSCHUP(0.0,1.0) 22 - *** Plot the string in the appropriate place. 23 - IF(I.EQ.1)THEN 24 - CALL GRTX(0.1,0.93,TEXT) 25 - ELSEIF(I.EQ.2)THEN 26 - CALL GRTX(0.1,0.91,TEXT) 27 - ELSEIF(I.EQ.3)THEN 28 - CALL GRTX(0.5,0.93,TEXT) 29 - ELSEIF(I.EQ.4)THEN 30 - CALL GRTX(0.5,0.91,TEXT) 31 - ELSEIF(I.EQ.5)THEN 32 - CALL GRTX(0.1,0.01,TEXT) 33 - ENDIF 34 - *** Switch back to the regular coordinate system. 35 - CALL GSELNT(1) 36 - END 144 GARFIELD ================================================== P=GRAPHICS D=GRGRPH 1 ============================ 0 + +DECK,GRGRPH. 1 - SUBROUTINE GRGRPH(X,Y,N,XTEXT,YTEXT,TITLE) 2 - *----------------------------------------------------------------------- 3 - * GRGRPH - Routine plotting a graph of the points (X,Y). 4 - * GRGRSC - Sets the scale of the next graph to be plotted. 5 - * VARIABLES : X : x-coordinates of plot points. 6 - * Y : y-coordinates of plot points. 7 - * N : Number of plot points. 8 - * XTEXT : Text along the x-axis. 9 - * YTEXT : Text along the y-axis. 10 - * (Last changed on 5/ 4/95.) 11 - *----------------------------------------------------------------------- 12 - implicit none 13.- +SEQ,DIMENSIONS. 14.- +SEQ,GRAPHICS. 15 - CHARACTER*(*) XTEXT,YTEXT,TITLE 16 - REAL X(*),Y(*),XMIN,YMIN,XMAX,YMAX,XMINR,YMINR,XMAXR,YMAXR, 17 - - SCMIN,SCMAX,SCMINI,SCMAXI 18 - LOGICAL FORCE,XSET,YSET,XFLAG,YFLAG 19 - INTEGER I,N 0 20-+ +SELF,IF=SAVE. 21 - SAVE FORCE,SCMIN,SCMAX 0 22-+ +SELF. 23 - DATA FORCE/.FALSE./ 24 - DATA SCMIN/0.0/,SCMAX/0.0/ 25 - *** Determine boundaries of plots. 26 - XSET=.FALSE. 27 - YSET=.FALSE. 28 - XFLAG=.FALSE. 29 - YFLAG=.FALSE. 30 - DO 10 I=1,N 31 - IF((LOGX.AND.X(I).GT.0).OR..NOT.LOGX)THEN 32 - IF(XSET)THEN 33 - XMIN=MIN(XMIN,X(I)) 34 - XMAX=MAX(XMAX,X(I)) 35 - ELSE 36 - XMIN=X(I) 37 - XMAX=X(I) 38 - XSET=.TRUE. 39 - ENDIF 40 - ELSE 41 - XFLAG=.TRUE. 42 - ENDIF 43 - IF((LOGY.AND.Y(I).GT.0).OR..NOT.LOGY)THEN 44 - IF(YSET)THEN 45 - YMIN=MIN(YMIN,Y(I)) 46 - YMAX=MAX(YMAX,Y(I)) 47 - ELSE 48 - YMIN=Y(I) 49 - YMAX=Y(I) 50 - YSET=.TRUE. 51 - ENDIF 52 - ELSE 53 - YFLAG=.TRUE. 54 - ENDIF 55 - 10 CONTINUE 56 - *** Make the scale a bit bigger so that the curve fits nicely. 57 - IF(LOGX)THEN 58 - IF(XFLAG)WRITE(10,'('' !!!!!! GRGRPH WARNING : Non-pos'', 59 - - ''itive x-values found on an x-log plot; ignored.'')') 60 - IF(.NOT.XSET)THEN 61 - PRINT *,' !!!!!! GRGRPH WARNING : x-Range is'// 62 - - ' entirely non-positive although logarithmic' 63 - PRINT *,' x-scaling'// 1 144 P=GRAPHICS D=GRGRPH 2 PAGE 245 64 - - ' has been requested; range set to [1,10].' 65 - XMIN=1 66 - XMAX=10 67 - ENDIF 68 - XMINR=10.0**(LOG10(XMIN)-LOG10(XMAX/XMIN)/20.0) 69 - XMAXR=10.0**(LOG10(XMAX)+LOG10(XMAX/XMIN)/20.0) 70 - ELSE 71 - XMINR=XMIN-(XMAX-XMIN)/20.0 72 - XMAXR=XMAX+(XMAX-XMIN)/20.0 73 - ENDIF 74 - *** Verify the automatic scaling request. 75 - IF(FORCE.AND.LOGY.AND.(SCMIN.LE.0.OR.SCMAX.LE.0))THEN 76 - PRINT *,' !!!!!! GRGRPH WARNING : The specified y-scale'// 77 - - ' is not valid as a log scale; using default.' 78 - FORCE=.FALSE. 79 - ENDIF 80 - IF(FORCE.AND.SCMIN.EQ.SCMAX)THEN 81 - PRINT *,' !!!!!! GRGRPH WARNING : The specified y-scale'// 82 - - ' has zero range; using default.' 83 - FORCE=.FALSE. 84 - ENDIF 85 - *** Override default scale by forced scale if applicable. 86 - IF(FORCE)THEN 87 - YMINR=SCMIN 88 - YMAXR=SCMAX 89 - FORCE=.FALSE. 90 - * And handle the y range the same way as the x range 91 - ELSEIF(LOGY)THEN 92 - IF(YFLAG)WRITE(10,'('' !!!!!! GRGRPH WARNING : Non-pos'', 93 - - ''itive y-values found on a y-log plot; ignored.'')') 94 - IF(.NOT.YSET)THEN 95 - PRINT *,' !!!!!! GRGRPH WARNING : y-Range is'// 96 - - ' entirely non-positive although logarithmic' 97 - PRINT *,' y-scaling'// 98 - - ' has been requested; range set to [1,10].' 99 - YMIN=1 100 - YMAX=10 101 - ENDIF 102 - YMINR=10.0**(LOG10(YMIN)-LOG10(YMAX/YMIN)/20.0) 103 - YMAXR=10.0**(LOG10(YMAX)+LOG10(YMAX/YMIN)/20.0) 104 - ELSE 105 - YMINR=YMIN-(YMAX-YMIN)/20.0 106 - YMAXR=YMAX+(YMAX-YMIN)/20.0 107 - ENDIF 108 - *** Plot the coordinate axes. 109 - CALL GRCART(XMINR,YMINR,XMAXR,YMAXR,XTEXT,YTEXT,TITLE) 110 - *** Plot the line. 111 - CALL GRATTS('FUNCTION-1','POLYLINE') 112 - IF(N.GT.1)CALL GRLINE(N,X,Y) 113 - RETURN 114 - *** Entry point to force a scale. 115 - ENTRY GRGRSC(SCMINI,SCMAXI) 116 - FORCE=.TRUE. 117 - SCMIN=MIN(SCMINI,SCMAXI) 118 - SCMAX=MAX(SCMINI,SCMAXI) 119 - END 145 GARFIELD ================================================== P=GRAPHICS D=GRGRP2 1 ============================ 0 + +DECK,GRGRP2. 1 - SUBROUTINE GRGRP2(X,Y,N,XTEXT,YTEXT,TITLE) 2 - *----------------------------------------------------------------------- 3 - * GRGRP2 - Routine plotting a graph of the points (X,Y). 4 - * GRGRS2 - Sets the scale of the next graph to be plotted. 5 - * VARIABLES : X : x-coordinates of plot points. 6 - * Y : y-coordinates of plot points. 7 - * N : Number of plot points. 8 - * XTEXT : Text along the x-axis. 9 - * YTEXT : Text along the y-axis. 10 - * (Last changed on 4/10/99.) 11 - *----------------------------------------------------------------------- 12 - implicit none 13.- +SEQ,DIMENSIONS. 14.- +SEQ,GRAPHICS. 15 - CHARACTER*(*) XTEXT,YTEXT,TITLE 16 - DOUBLE PRECISION X(*),Y(*),XMIN,YMIN,XMAX,YMAX, 17 - - SCMIN,SCMAX,SCMINI,SCMAXI 18 - REAL XMINR,YMINR,XMAXR,YMAXR 19 - LOGICAL FORCE,XSET,YSET,XFLAG,YFLAG 20 - INTEGER I,N 0 21-+ +SELF,IF=SAVE. 22 - SAVE FORCE,SCMIN,SCMAX 0 23-+ +SELF. 24 - DATA FORCE/.FALSE./ 25 - DATA SCMIN/0.0D0/,SCMAX/0.0D0/ 26 - *** Determine boundaries of plots. 27 - XSET=.FALSE. 28 - YSET=.FALSE. 29 - XFLAG=.FALSE. 30 - YFLAG=.FALSE. 31 - DO 10 I=1,N 32 - IF((LOGX.AND.X(I).GT.0).OR..NOT.LOGX)THEN 33 - IF(XSET)THEN 34 - XMIN=MIN(XMIN,X(I)) 35 - XMAX=MAX(XMAX,X(I)) 36 - ELSE 37 - XMIN=X(I) 38 - XMAX=X(I) 39 - XSET=.TRUE. 40 - ENDIF 41 - ELSE 42 - XFLAG=.TRUE. 43 - ENDIF 44 - IF((LOGY.AND.Y(I).GT.0).OR..NOT.LOGY)THEN 1 145 P=GRAPHICS D=GRGRP2 2 PAGE 246 45 - IF(YSET)THEN 46 - YMIN=MIN(YMIN,Y(I)) 47 - YMAX=MAX(YMAX,Y(I)) 48 - ELSE 49 - YMIN=Y(I) 50 - YMAX=Y(I) 51 - YSET=.TRUE. 52 - ENDIF 53 - ELSE 54 - YFLAG=.TRUE. 55 - ENDIF 56 - 10 CONTINUE 57 - *** Make the scale a bit bigger so that the curve fits nicely. 58 - IF(LOGX)THEN 59 - IF(XFLAG)WRITE(10,'('' !!!!!! GRGRP2 WARNING : Non-pos'', 60 - - ''itive x-values found on an x-log plot; ignored.'')') 61 - IF(.NOT.XSET)THEN 62 - PRINT *,' !!!!!! GRGRP2 WARNING : x-Range is'// 63 - - ' entirely non-positive although logarithmic' 64 - PRINT *,' x-scaling'// 65 - - ' has been requested; range set to [1,10].' 66 - XMIN=1 67 - XMAX=10 68 - ENDIF 69 - XMINR=REAL(10.0D0**(LOG10(XMIN)-LOG10(XMAX/XMIN)/20.0D0)) 70 - XMAXR=REAL(10.0D0**(LOG10(XMAX)+LOG10(XMAX/XMIN)/20.0D0)) 71 - ELSE 72 - XMINR=REAL(XMIN-(XMAX-XMIN)/20.0D0) 73 - XMAXR=REAL(XMAX+(XMAX-XMIN)/20.0D0) 74 - ENDIF 75 - *** Verify the automatic scaling request. 76 - IF(FORCE.AND.LOGY.AND.(SCMIN.LE.0.OR.SCMAX.LE.0))THEN 77 - PRINT *,' !!!!!! GRGRP2 WARNING : The specified y-scale'// 78 - - ' is not valid as a log scale; using default.' 79 - FORCE=.FALSE. 80 - ENDIF 81 - IF(FORCE.AND.SCMIN.EQ.SCMAX)THEN 82 - PRINT *,' !!!!!! GRGRP2 WARNING : The specified y-scale'// 83 - - ' has zero range; using default.' 84 - FORCE=.FALSE. 85 - ENDIF 86 - *** Override default scale by forced scale if applicable. 87 - IF(FORCE)THEN 88 - YMINR=SCMIN 89 - YMAXR=SCMAX 90 - FORCE=.FALSE. 91 - * And handle the y range the same way as the x range 92 - ELSEIF(LOGY)THEN 93 - IF(YFLAG)WRITE(10,'('' !!!!!! GRGRP2 WARNING : Non-pos'', 94 - - ''itive y-values found on a y-log plot; ignored.'')') 95 - IF(.NOT.YSET)THEN 96 - PRINT *,' !!!!!! GRGRP2 WARNING : y-Range is'// 97 - - ' entirely non-positive although logarithmic' 98 - PRINT *,' y-scaling'// 99 - - ' has been requested; range set to [1,10].' 100 - YMIN=1 101 - YMAX=10 102 - ENDIF 103 - YMINR=REAL(10.0D0**(LOG10(YMIN)-LOG10(YMAX/YMIN)/20.0D0)) 104 - YMAXR=REAL(10.0D0**(LOG10(YMAX)+LOG10(YMAX/YMIN)/20.0D0)) 105 - ELSE 106 - YMINR=REAL(YMIN-(YMAX-YMIN)/20.0) 107 - YMAXR=REAL(YMAX+(YMAX-YMIN)/20.0) 108 - ENDIF 109 - *** Plot the coordinate axes. 110 - CALL GRCART(XMINR,YMINR,XMAXR,YMAXR,XTEXT,YTEXT,TITLE) 111 - *** Plot the line. 112 - CALL GRATTS('FUNCTION-1','POLYLINE') 113 - IF(N.GT.1)CALL GRLIN2(N,X,Y) 114 - RETURN 115 - *** Entry point to force a scale. 116 - ENTRY GRGRS2(SCMINI,SCMAXI) 117 - FORCE=.TRUE. 118 - SCMIN=MIN(SCMINI,SCMAXI) 119 - SCMAX=MAX(SCMINI,SCMAXI) 120 - END 146 GARFIELD ================================================== P=GRAPHICS D=GRGRAF 1 ============================ 0 + +DECK,GRGRAF. 1 - SUBROUTINE GRGRAF(WAIT) 2 - *----------------------------------------------------------------------- 3 - * GRGRAF - Clears the screen, preparing it for graphics. 4 - * (Last changed on 5/ 9/93.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,PRINTPLOT. 8.- +SEQ,GRAPHICS. 9 - EXTERNAL STDSTR 10 - CHARACTER*80 DUMMY 11 - LOGICAL STDSTR,WAIT 12 - *** See whether there is a workstation with input facilities. 13 - CALL GQOPS(IOPSTA) 14 - IF(IOPSTA.LT.3)THEN 15 - IF(LDEBUG)WRITE(10,'('' ++++++ GRGRAF DEBUG :'', 16 - - '' No active workstations.'')') 17 - RETURN 18 - ENDIF 19 - *** Try to find a workstation with input facilities. 20 - CALL GQACWK(0,IERR,NACT,IWK) 21 - IWKREQ=-1 22 - DO 20 I=1,NACT 23 - CALL GQACWK(I,IERR,IDUM,IWK) 24 - * Locate one that has input facilities. 25 - CALL GQWKC(IWK,IERR1,ICONID,IWKTYP) 26 - CALL GQWKCA(IWKTYP,IERR2,IWKCAT) 1 146 P=GRAPHICS D=GRGRAF 2 PAGE 247 27 - IF(IWKCAT.EQ.2)IWKREQ=IWK 28 - 20 CONTINUE 29 - *** Only debugging output if there isn't one. 30 - IF(IWKREQ.EQ.-1)THEN 31 - IF(LDEBUG)WRITE(10,'('' ++++++ GRGRAF DEBUG :'', 32 - - '' No active in-out workstation found.'')') 33 - *** Warn if there is one while running in batch. 34 - ELSEIF(.NOT.STDSTR('INPUT'))THEN 35 - WRITE(10,'('' ###### GRGRAF ERROR : Workstation with'', 36 - - '' input found in a batch job; please report.'')') 37 - *** Otherwise wait for user response. 38 - ELSE 39 - IF(WAIT.AND.LWAITB)THEN 40 - PRINT *,' ' 41 - PRINT *,' ----------------------------------' 42 - PRINT *,' Graphics output - waiting for (CR)' 43 - PRINT *,' ----------------------------------' 44 - PRINT *,' ' 0 45-+ +SELF,IF=-CMS. 46 - READ(5,'(A80)',END=10) DUMMY 0 47-+ +SELF,IF=CMS. 48 - READ(5,END=2000,NUM=NDUMMY) DUMMY 49 - GOTO 10 50 - 2000 CONTINUE 51 - REWIND(UNIT=5) 0 52-+ +SELF. 53 - 10 CONTINUE 54 - ENDIF 0 55-+ +SELF,IF=HIGZ. 56 - IF(IWKREQ.NE.-1)CALL IGSG(IWKREQ) 0 57-+ +SELF,IF=VAX,CMS,IF=GTSGRAL,IF=-HIGZ. 58 - IF(IWKREQ.NE.-1)CALL GCATOG(IWKREQ) 0 59-+ +SELF,IF=VAX,IF=ATCGKS,IF=-HIGZ. 60 - CALL GUESC001(IWKREQ,1) 0 61-+ +SELF. 62 - ENDIF 63 - *** Clear screen if requested. 64 - IF(LGCLRB.AND.WAIT)THEN 65 - * Determine Operating State value. 66 - CALL GQOPS(IOPSTA) 67 - IF(LDEBUG)WRITE(10,'('' ++++++ GRGRAF DEBUG : Current'', 68 - - '' GKS operating state: '',I1,''.'')') IOPSTA 69 - * Close current segment if open. 70 - IF(IOPSTA.EQ.4)CALL GCLSG 71 - * Do a clear on all active workstations, if there are any open. 72 - IF(IOPSTA.GE.3)THEN 73 - CALL GQACWK(0,IERR,NACT,IWK) 74 - IF(LDEBUG)WRITE(10,'('' ++++++ GRGRAF DEBUG :'', 75 - - '' Number of active WS: '',I3,'', inq err: '', 76 - - I3,''.'')') NACT,IERR 77 - DO 30 I=1,NACT 78 - CALL GQACWK(I,IERR,IDUM,IWK) 79 - CALL GCLRWK(IWK,1) 80 - IF(LDEBUG)WRITE(10,'('' ++++++ GRGRAF DEBUG :'', 81 - - '' Clear sent to WS '',I3,'', inq err: '', 82 - - I3,''.'')') IWK,IERR 83 - 30 CONTINUE 84 - ENDIF 85 - * Debugging information ? 86 - ELSEIF(LDEBUG)THEN 87 - WRITE(10,'('' ++++++ GRGRAF DEBUG : No clear'', 88 - - '' of WS done because LGCLRB & WAIT=F.'')') 89 - ENDIF 90 - END 147 GARFIELD ================================================== P=GRAPHICS D=GRHIST 1 ============================ 0 + +DECK,GRHIST. 1 - SUBROUTINE GRHIST(CONTEN,NCHA,XMIN,XMAX,XTXT,TITLE,FRAME) 2 - *---------------------------------------------------------------------- 3 - * GRHIST - Subroutine plotting a histogram using the vector CONTEN 4 - * as contents and XMIN and XMAX as lower and upper x-bounds. 5 - * (Last changed on 27/ 6/98.) 6 - *---------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,GRAPHICS. 11 - CHARACTER*(*) XTXT,TITLE 12 - CHARACTER*20 AUX1,AUX2,AUX3 13 - INTEGER NCHA,I,IOUT,NC1,NC2,NC3 14 - REAL XPL(MXLIST),YPL(MXLIST),CONTEN(0:NCHA+1),SUM,XMIN,XMAX, 15 - - YMIN,YMAX 16 - LOGICAL FRAME,SETRAN 17 - *** Determine maximum and minimum y and compute the total contents. 18 - SETRAN=.FALSE. 19 - SUM=0 20 - DO 10 I=1,NCHA 21 - IF((.NOT.LOGY).OR.CONTEN(I).GT.0)THEN 22 - IF(.NOT.SETRAN)THEN 23 - YMIN=CONTEN(I) 24 - YMAX=CONTEN(I) 25 - SETRAN=.TRUE. 26 - ELSE 27 - IF(YMIN.GT.CONTEN(I))YMIN=CONTEN(I) 28 - IF(YMAX.LT.CONTEN(I))YMAX=CONTEN(I) 29 - ENDIF 30 - ENDIF 31 - SUM=SUM+CONTEN(I) 1 147 P=GRAPHICS D=GRHIST 2 PAGE 248 32 - 10 CONTINUE 33 - *** Check that a range has been set. 34 - IF(.NOT.SETRAN)THEN 35 - PRINT *,' !!!!!! GRHIST WARNING : No range can be set'// 36 - - ' for the histogram plot.' 37 - IF(LOGY)THEN 38 - YMIN=1 39 - YMAX=10 40 - ELSE 41 - YMIN=-1 42 - YMAX=+1 43 - ENDIF 44 - ENDIF 45 - *** Make the range look a bit nicer. 46 - IF((YMIN.GT.0.0).AND.(.NOT.LOGY))YMIN=0.0 47 - IF(YMAX.LE.YMIN)YMAX=YMIN+1.0 48 - YMAX=1.1*YMAX 49 - *** Plot a frame using GRCART. 50 - IF(FRAME)CALL GRCART(XMIN,YMIN,XMAX,YMAX,XTXT, 51 - - 'Entries or probability',TITLE) 52 - *** Set the correct graphics representation for the histogram. 53 - CALL GRATTS('FUNCTION-1','POLYLINE') 54 - *** Plot the histogram. 55 - IOUT=0 56 - DO 20 I=1,NCHA 57 - * Draw the horizontal segment of the bin. 58 - XPL(IOUT+1)=XMIN+REAL(I-1)*(XMAX-XMIN)/REAL(NCHA) 59 - XPL(IOUT+2)=XMIN+REAL(I )*(XMAX-XMIN)/REAL(NCHA) 60 - YPL(IOUT+1)=CONTEN(I) 61 - YPL(IOUT+2)=CONTEN(I) 62 - * Check for 0 entries. 63 - IF(LOGX.AND.XPL(IOUT+1).LE.0)XPL(IOUT+1)=10.0**FRXMIN 64 - IF(LOGX.AND.XPL(IOUT+2).LE.0)XPL(IOUT+2)=10.0**FRXMIN 65 - IF(LOGY.AND.YPL(IOUT+1).LE.0)YPL(IOUT+1)=10.0**FRYMIN 66 - IF(LOGY.AND.YPL(IOUT+2).LE.0)YPL(IOUT+2)=10.0**FRYMIN 67 - * Increment the count. 68 - IOUT=IOUT+2 69 - * Check against buffer overflow. 70 - IF(IOUT.GE.MXLIST-1)THEN 71 - CALL GRLINE(IOUT,XPL,YPL) 72 - XPL(1)=XPL(IOUT) 73 - YPL(1)=YPL(IOUT) 74 - IOUT=1 75 - ENDIF 76 - 20 CONTINUE 77 - * Plot the remainder of the line. 78 - IF(IOUT.GE.2)CALL GRLINE(IOUT,XPL,YPL) 79 - *** Indicate over- and underflow. 80 - IF(FRAME)THEN 81 - CALL OUTFMT(CONTEN(0) ,2,AUX1,NC1,'LEFT') 82 - CALL OUTFMT(SUM ,2,AUX2,NC2,'LEFT') 83 - CALL OUTFMT(CONTEN(NCHA+1),2,AUX3,NC3,'LEFT') 84 - CALL GRCOMM(3,'Under: '//AUX1(1:NC1)//', in: '// 85 - - AUX2(1:NC2)//', over: '//AUX3(1:NC3)) 86 - ENDIF 87 - END 148 GARFIELD ================================================== P=GRAPHICS D=GRINIT 1 ============================ 0 + +DECK,GRINIT. 1 - SUBROUTINE GRINIT 2 - *----------------------------------------------------------------------- 3 - * GRINIT - Initialises the graphics system. 4 - * (Last changed on 9/ 9/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GRAPHICS. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,CONSTANTS. 11 - CHARACTER*8 DATE,TIME 12 - CHARACTER*(MXNAME) FILE 0 13-+ +SELF,IF=APOLLO,CRAY,UNIX. 14 - CHARACTER*1 STRING 0 15-+ +SELF,IF=CMS. 16 - INTEGER IFAIL 0 17-+ +SELF,IF=HIGZ. 18 - INTEGER NWORDS 19 - REAL RPAW 20 - PARAMETER (NWORDS=50000) 21 - COMMON /PAWC/ RPAW(NWORDS) 0 22-+ +SELF,IF=VAX. 23 - INTEGER IERR,IRMS,ISTV,IUNIT,ICOND 0 24-+ +SELF. 25 - EXTERNAL STDSTR 26 - LOGICAL STDSTR 27 - INTEGER IASF(13),IFAIL1,IFAIL2,IFAIL3,NCFILE,IOS 28 - DATA IASF /13*1/ 29 - *** Identify the routine. 30 - IF(LIDENT)PRINT *,' /// ROUTINE GRINIT ///' 31 - *** Fetch date and time. 32 - CALL DATTIM(DATE,TIME) 0 33-+ +SELF,IF=APOLLO. 34 - *** Open a file for GKS error messages. 35 - OPEN(UNIT=10,FILE='GKS_error.log',STATUS='UNKNOWN',IOSTAT=IOS, 36 - - ERR=2020) 37 - CALL DSNLOG('GKS_error.log','GKS errors','Sequential', 38 - - 'Append ') 39 - 10 CONTINUE 40 - READ(10,'(A1)',END=20) STRING 1 148 P=GRAPHICS D=GRINIT 2 PAGE 249 41 - GOTO 10 42 - 20 CONTINUE 43 - WRITE(10,'('' ========== New run on '',A8,'' at '',A8, 44 - - '' ========== '')',ERR=2010,IOSTAT=IOS) DATE,TIME 0 45-+ +SELF,IF=CMS. 46 - *** Open a file for GKS error messages. 47 - CALL DSNOPN('GKSERROR LOG A',14,10,'RW-FILE',IFAIL) 48 - CALL DSNLOG('GKSERROR LOG','GKS errors','Sequential', 49 - - 'Write ') 50 - IF(IFAIL.NE.0)THEN 51 - IOS=0 52 - GOTO 2020 53 - ENDIF 54 - WRITE(10,'('' ========== New run on '',A8,'' at '',A8, 55 - - '' ========== '')',ERR=2010,IOSTAT=IOS) DATE,TIME 0 56-+ +SELF,IF=CRAY,UNIX. 57 - *** Open a file for GKS error messages. 58 - OPEN(UNIT=10,FILE='GKS_error.log',STATUS='UNKNOWN',IOSTAT=IOS, 59 - - ERR=2020) 60 - CALL DSNLOG('GKS_error.log','GKS errors','Sequential', 61 - - 'Append ') 62 - 10 CONTINUE 63 - READ(10,'(A1)',END=20) STRING 64 - GOTO 10 65 - 20 CONTINUE 66 - BACKSPACE(10) 67 - WRITE(10,'('' ========== New run on '',A8,'' at '',A8, 68 - - '' ========== '')',ERR=2010,IOSTAT=IOS) DATE,TIME 0 69-+ +SELF,IF=VAX. 70 - *** Open a file for GKS error messages, first attempt APPEND mode. 71 - OPEN(UNIT=10,FILE='GKS_ERROR.LOG',STATUS='UNKNOWN', 72 - - ACCESS='APPEND',ERR=201) 73 - GOTO 202 74 - * If that failed, check error code for lock state and try NEW. 75 - 201 CONTINUE 76 - CALL ERRSNS(IERR,IRMS,ISTV,IUNIT,ICOND) 77 - IF(IRMS.EQ.98954)THEN 78 - PRINT *,' ------ GRINIT MESSAGE : Error logging file is'// 79 - - ' already open; opening a new file.' 80 - OPEN(UNIT=10,FILE='GKS_ERROR.LOG',STATUS='NEW',ERR=203) 81 - GOTO 202 82 - ELSE 83 - PRINT *,' ###### GRINIT ERROR : Error logging file can'// 84 - - ' not be opened for unknown reason; please report.' 85 - CALL QUIT 86 - RETURN 87 - ENDIF 88 - * If that too fails, report and quit. 89 - 203 CONTINUE 90 - PRINT *,' ###### GRINIT ERROR : Opening the new file fails'// 91 - - ' also; terminating program execution.' 92 - CALL QUIT 93 - RETURN 94 - * Things seem to have worked one way or other. 95 - 202 CONTINUE 96 - CALL DSNLOG('GKS_ERROR.LOG','GKS errors','Sequential', 97 - - 'Append ') 98 - WRITE(10,'('' ========== New run on '',A8,'' at '',A8, 99 - - '' ========== '')',ERR=2010,IOSTAT=IOS) DATE,TIME 0 100-+ +SELF,IF=HIGZ. 101 - *** Initialise HIGZ. 102 - CALL HLIMIT(NWORDS) 103 - CALL HPLINT(0) 104 - C CALL MZEBRA(-3) 105 - C CALL MZPAW(NWORDS,' ') 106 - C CALL IGINIT(0) 107 - C CALL IOPKS(10) 108 - CALL IGSET('PASS',1.0) 0 109-+ +SELF,IF=-HIGZ. 110 - *** Open GKS. 111 - CALL GOPKS(10,0) 0 112-+ +SELF. 113 - *** Set aspect-source flags. 114 - CALL GSASF(IASF) 115 - *** Initialise the workstation table. 116 - NWK=0 117 - * First the terminal. 118 - IF(STDSTR('INPUT'))THEN 119 - NWK=NWK+1 120 - WKNAME(NWK)='TERMINAL' 121 - NCWKNM(NWK)=8 122 - CALL GRTERM(WKID(NWK),WKCON(NWK),WKSTAT(NWK),IFAIL1) 123 - WKFREF(NWK)=0 124 - WKLUN(NWK)=-1 125 - * Open and activate. 126 - IF(IFAIL1.NE.0)THEN 127 - PRINT *,' !!!!!! GRINIT WARNING : Terminal graphics'// 128 - - ' graphics is currently disabled because of the'// 129 - - ' above error.' 130 - NWK=NWK-1 131 - ELSEIF(WKSTAT(NWK).GT.0.OR.WKSTAT(NWK).EQ.0)THEN 132 - CALL GROPWK(WKNAME(NWK)(1:NCWKNM(NWK))) 133 - CALL GRACWK(WKNAME(NWK)(1:NCWKNM(NWK))) 134 - CALL GSDS(NWK,1,1) 135 - ELSE 136 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRINIT DEBUG :'', 137 - - '' TERMINAL not defined at your request.'')') 138 - NWK=NWK-1 139 - ENDIF 140 - ENDIF 1 148 P=GRAPHICS D=GRINIT 3 PAGE 250 141 - * Then the metafile. 142 - NWK=NWK+1 143 - WKNAME(NWK)='METAFILE' 144 - NCWKNM(NWK)=8 145 - CALL GRMETA(WKID(NWK),WKCON(NWK),FILE,NCFILE,WKSTAT(NWK),IFAIL2) 146 - CALL STRBUF('STORE',WKFREF(NWK),FILE,NCFILE,IFAIL3) 147 - WKLUN(2)=0 148 - * Open and activate. 149 - IF(IFAIL2.NE.0.OR.IFAIL3.NE.0)THEN 150 - PRINT *,' !!!!!! GRINIT WARNING : Metafile output'// 151 - - ' is currently disabled because of the above error.' 152 - NWK=NWK-1 153 - ELSEIF(WKSTAT(NWK).GT.0.OR. 154 - - (WKSTAT(NWK).EQ.0.AND..NOT.STDSTR('INPUT')))THEN 155 - CALL GROPWK(WKNAME(NWK)(1:NCWKNM(NWK))) 156 - CALL GRACWK(WKNAME(NWK)(1:NCWKNM(NWK))) 157 - CALL GSDS(NWK,3,1) 158 - ELSE 159 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRINIT DEBUG :'', 160 - - '' METAFILE not defined at your request.'')') 161 - NWK=NWK-1 162 - ENDIF 163 - *** Switch terminal to alpha-numeric mode. 164 - CALL GRALPH 165 - *** Graphics options. 166 - LGRID=.FALSE. 167 - LOGX=.FALSE. 168 - LOGY=.FALSE. 169 - LSTAMP=.TRUE. 170 - LWAITA=.TRUE. 0 171-+ +SELF,IF=HIGZ. 172 - LWAITB=.FALSE. 0 173-+ +SELF,IF=-HIGZ. 174 - LWAITB=.TRUE. 0 175-+ +SELF. 176 - LGCLRB=.TRUE. 177 - LGCLRA=.FALSE. 178 - LXCCH=.FALSE. 179 - STAMP=' with Garfield version 7.04.' 180 - NCSTMP=28 181 - *** Display size. 182 - DISPX0=0.0 183 - DISPX1=1.0 184 - DISPY0=0.0 185 - DISPY1=1.0 186 - *** Window layout. 187 - GPXN =0.007 188 - GPXN10=0.015 189 - GPYN =0.007 190 - GPYN10=0.015 191 - GPXL =0.01 192 - GPYL =0.01 193 - GPXT =0.01 194 - *** Arrow top angle. 195 - ARRANG=30.0*PI/180.0 196 - ARRLEN=0.3 197 - *** Handle problems when opening various files 198 - RETURN 0 199-+ +SELF,IF=APOLLO,CMS,CRAY,UNIX,VAX. 200 - 2010 CONTINUE 201 - PRINT *,' ###### GRINIT ERROR : Unable to write the graphics'// 202 - - ' error logging file ; end of program execution.' 203 - CALL INPIOS(IOS) 204 - CALL QUIT 0 205-+ +SELF,IF=APOLLO,CMS,CRAY,UNIX. 206 - 2020 CONTINUE 207 - PRINT *,' ###### GRINIT ERROR : Unable to open the graphics'// 208 - - ' error logging file ; end of program execution.' 209 - CALL INPIOS(IOS) 210 - CALL QUIT 0 211-+ +SELF. 212 - END 149 GARFIELD ================================================== P=GRAPHICS D=GRLINE 1 ============================ 0 + +DECK,GRLINE. 1 - SUBROUTINE GRLINE(NU,XU,YU) 2 - *----------------------------------------------------------------------- 3 - * GRLINE - Draws a line in either log or linear coordinates. 4 - * (Last changed on 13/ 2/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GRAPHICS. 9.- +SEQ,PRINTPLOT. 10 - REAL XU(*),YU(*),XPL(MXLIST),YPL(MXLIST),XCUR,YCUR,XLAST,YLAST, 11 - - X0,Y0,X1,Y1 12 - INTEGER NPL,IFAIL,NU,I 13 - LOGICAL CURIN,LASTIN 14 - *** Check number of points. 15 - IF(NU.LE.1)RETURN 16 - *** Initial settings. 17 - LASTIN=.FALSE. 18 - NPL=0 19 - *** Loop over the input array. 20 - DO 10 I=1,NU 21 - * Transform x-coordinate if requested. 22 - IF(LOGX)THEN 23 - IF(XU(I).LE.0.0)THEN 24 - XCUR=FRXMIN-2*ABS(FRXMAX-FRXMIN) 1 149 P=GRAPHICS D=GRLINE 2 PAGE 251 25 - ELSE 26 - XCUR=LOG10(XU(I)) 27 - ENDIF 28 - ELSE 29 - XCUR=XU(I) 30 - ENDIF 31 - * Transform y-coordinate if requested. 32 - IF(LOGY)THEN 33 - IF(YU(I).LE.0.0)THEN 34 - YCUR=FRYMIN-2*ABS(FRYMAX-FRYMIN) 35 - ELSE 36 - YCUR=LOG10(YU(I)) 37 - ENDIF 38 - ELSE 39 - YCUR=YU(I) 40 - ENDIF 41 - * See whether this point is located is inside the frame. 42 - IF(XCUR.GE.FRXMIN.AND.XCUR.LE.FRXMAX.AND. 43 - - YCUR.GE.FRYMIN.AND.YCUR.LE.FRYMAX)THEN 44 - CURIN=.TRUE. 45 - ELSE 46 - CURIN=.FALSE. 47 - ENDIF 48 - * If this is the first point, add to the list and skip the rest. 49 - IF(I.EQ.1)THEN 50 - IF(CURIN)THEN 51 - NPL=1 52 - XPL(NPL)=XCUR 53 - YPL(NPL)=YCUR 54 - ENDIF 55 - GOTO 20 56 - ENDIF 57 - * Compute fragment of this that fits in the frame. 58 - X0=XLAST 59 - Y0=YLAST 60 - X1=XCUR 61 - Y1=YCUR 62 - CALL CLIP(X0,Y0,X1,Y1,FRXMIN,FRYMIN,FRXMAX,FRYMAX,IFAIL) 63 - * If fully out (IFAIL=1) then skip the rest. 64 - IF(IFAIL.NE.0)THEN 65 - GOTO 20 66 - * If both current and last point are 'in', add the point. 67 - ELSEIF(LASTIN.AND.CURIN)THEN 68 - IF(NPL.GE.MXLIST)THEN 69 - CALL GPL(NPL,XPL,YPL) 70 - XPL(1)=XPL(NPL) 71 - YPL(1)=YPL(NPL) 72 - NPL=1 73 - ENDIF 74 - NPL=NPL+1 75 - XPL(NPL)=X1 76 - YPL(NPL)=Y1 77 - * If the last point was 'in' and current 'out', add and plot. 78 - ELSEIF(LASTIN.AND.(.NOT.CURIN))THEN 79 - IF(NPL.GE.MXLIST)THEN 80 - CALL GPL(NPL,XPL,YPL) 81 - XPL(1)=XPL(NPL) 82 - YPL(1)=YPL(NPL) 83 - NPL=1 84 - ENDIF 85 - NPL=NPL+1 86 - XPL(NPL)=X1 87 - YPL(NPL)=Y1 88 - IF(NPL.GT.1)CALL GPL(NPL,XPL,YPL) 89 - NPL=0 90 - * If the last point was 'out' and the current 'in', start a new line. 91 - ELSEIF(CURIN.AND.(.NOT.LASTIN))THEN 92 - IF(NPL.GT.1)CALL GPL(NPL,XPL,YPL) 93 - XPL(1)=X0 94 - YPL(1)=Y0 95 - XPL(2)=X1 96 - YPL(2)=Y1 97 - NPL=2 98 - * If both this point and the last are out, draw this line. 99 - ELSE 100 - IF(NPL.GT.1)CALL GPL(NPL,XPL,YPL) 101 - XPL(1)=X0 102 - YPL(1)=Y0 103 - XPL(2)=X1 104 - YPL(2)=Y1 105 - CALL GPL(2,XPL,YPL) 106 - NPL=0 107 - ENDIF 108 - * Move 'current' point to 'last' point. 109 - 20 CONTINUE 110 - XLAST=XCUR 111 - YLAST=YCUR 112 - LASTIN=CURIN 113 - 10 CONTINUE 114 - *** Plot what remains in the buffer. 115 - IF(NPL.GE.2)CALL GPL(NPL,XPL,YPL) 116 - END 150 GARFIELD ================================================== P=GRAPHICS D=GRLIN2 1 ============================ 0 + +DECK,GRLIN2. 1 - SUBROUTINE GRLIN2(N,XPL2,YPL2) 2 - *----------------------------------------------------------------------- 3 - * GRLIN2 - Routine plotting an array of double precision points. 4 - * (Last changed on 5/ 2/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8 - DOUBLE PRECISION XPL2(*),YPL2(*) 9 - REAL XPL(MXLIST),YPL(MXLIST) 10 - INTEGER N,II,I,NPL 1 150 P=GRAPHICS D=GRLIN2 2 PAGE 252 11 - *** Loop over blocks of length MXLIST. 12 - DO 20 II=0,N-2,MXLIST-1 13 - *** Transfer XPL2 and YPL2 (double) to XPL and YPL (single precision). 14 - DO 10 I=1,MIN(N-II,MXLIST) 15 - XPL(I)=REAL(XPL2(II+I)) 16 - YPL(I)=REAL(YPL2(II+I)) 17 - 10 CONTINUE 18 - NPL=MIN(N-II,MXLIST) 19 - *** Plot the line. 20 - IF(NPL.GE.2)CALL GRLINE(NPL,XPL,YPL) 21 - 20 CONTINUE 22 - END 151 GARFIELD ================================================== P=GRAPHICS D=GRARE2 1 ============================ 0 + +DECK,GRARE2. 1 - SUBROUTINE GRARE2(N,XPL2,YPL2) 2 - *----------------------------------------------------------------------- 3 - * GRARE2 - Routine plotting an array of double precision points. 4 - * (Last changed on 5/ 2/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8 - DOUBLE PRECISION XPL2(*),YPL2(*) 9 - REAL XPL(MXLIST),YPL(MXLIST) 10 - INTEGER N,II,I,NPL 11 - *** Loop over blocks of length MXLIST. 12 - DO 20 II=0,N-2,MXLIST-1 13 - *** Transfer XPL2 and YPL2 (double) to XPL and YPL (single precision). 14 - DO 10 I=1,MIN(N-II,MXLIST) 15 - XPL(I)=REAL(XPL2(II+I)) 16 - YPL(I)=REAL(YPL2(II+I)) 17 - 10 CONTINUE 18 - NPL=MIN(N-II,MXLIST) 19 - *** Plot the line. 20 - IF(NPL.GE.3)CALL GRAREA(NPL,XPL,YPL) 21 - 20 CONTINUE 22 - END 152 GARFIELD ================================================== P=GRAPHICS D=GFA2 1 ============================ 0 + +DECK,GFA2. 1 - SUBROUTINE GFA2(N,XPL2,YPL2) 2 - *----------------------------------------------------------------------- 3 - * GFA2 - Routine plotting an array of double precision points. 4 - * (Last changed on 6/10/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8 - DOUBLE PRECISION XPL2(*),YPL2(*) 9 - REAL XPL(MXLIST),YPL(MXLIST) 10 - INTEGER N,I 11 - *** Can only work if the total length isn't exceeding MXLIST. 12 - IF(N.GT.MXLIST)THEN 13 - PRINT *,' !!!!!! GFA2 WARNING : Input array length'// 14 - - ' exceeds compilation limits ; area not plotted.' 15 - RETURN 16 - ENDIF 17 - *** Loop over the points. 18 - DO 10 I=1,N 19 - XPL(I)=REAL(XPL2(I)) 20 - YPL(I)=REAL(YPL2(I)) 21 - 10 CONTINUE 22 - *** Plot the line. 23 - IF(N.GE.3)CALL GFA(N,XPL,YPL) 24 - 20 CONTINUE 25 - END 153 GARFIELD ================================================== P=GRAPHICS D=GPM2 1 ============================ 0 + +DECK,GPM2. 1 - SUBROUTINE GPM2(N,XPL2,YPL2) 2 - *----------------------------------------------------------------------- 3 - * GPM2 - Routine plotting an array of double precision points. 4 - * (Last changed on 6/10/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8 - DOUBLE PRECISION XPL2(*),YPL2(*) 9 - REAL XPL(MXLIST),YPL(MXLIST) 10 - INTEGER N,II,I,NPL 11 - *** Loop over blocks of length MXLIST. 12 - DO 20 II=0,N-1,MXLIST 13 - *** Transfer XPL2 and YPL2 (double) to XPL and YPL (single precision). 14 - DO 10 I=1,MIN(N-II,MXLIST) 15 - XPL(I)=REAL(XPL2(II+I)) 16 - YPL(I)=REAL(YPL2(II+I)) 17 - 10 CONTINUE 18 - NPL=MIN(N-II,MXLIST) 19 - *** Plot the line. 20 - IF(NPL.GE.1)CALL GPM(NPL,XPL,YPL) 21 - 20 CONTINUE 22 - END 154 GARFIELD ================================================== P=GRAPHICS D=GRMARK 1 ============================ 0 + +DECK,GRMARK. 1 - SUBROUTINE GRMARK(NU,XU,YU) 2 - *----------------------------------------------------------------------- 3 - * GRMARK - Draws a polymarker in either log or linear coordinates. 4 - * (Last changed on 27/ 6/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GRAPHICS. 1 154 P=GRAPHICS D=GRMARK 2 PAGE 253 9.- +SEQ,PRINTPLOT. 10 - INTEGER NU,I 11 - REAL XU(NU),YU(NU),XPL(MXLIST),YPL(MXLIST) 12 - *** Check number of points. 13 - IF(NU.GT.MXLIST)WRITE(10,'('' !!!!!! GRMARK WARNING : Buffer'', 14 - - '' overflow, NU='',I3,''; bug, please report.'')') NU 15 - IF(LDEBUG)WRITE(10,'('' ++++++ GRMARK DEBUG : Line has '',I3, 16 - - '' points, scales: '',2L1)') NU,LOGX,LOGY 17 - *** Copy, transforming if needed. 18 - DO 10 I=1,MIN(NU,MXLIST) 19 - IF(LOGX)THEN 20 - IF(XU(I).LE.0.0)THEN 21 - C WRITE(10,'('' !!!!!! GRMARK WARNING : Negative'', 22 - C - '' value x='',E12.5,'' received.'')') XU(I) 23 - XPL(I)=FRXMIN-2*ABS(FRXMAX-FRXMIN) 24 - ELSE 25 - XPL(I)=LOG10(XU(I)) 26 - ENDIF 27 - ELSE 28 - XPL(I)=XU(I) 29 - ENDIF 30 - IF(LOGY)THEN 31 - IF(YU(I).LE.0.0)THEN 32 - C WRITE(10,'('' !!!!!! GRMARK WARNING : Negative'', 33 - C - '' value y='',E12.5,'' received.'')') YU(I) 34 - YPL(I)=FRYMIN-2*ABS(FRYMAX-FRYMIN) 35 - ELSE 36 - YPL(I)=LOG10(YU(I)) 37 - ENDIF 38 - ELSE 39 - YPL(I)=YU(I) 40 - ENDIF 41 - IF(LDEBUG)WRITE(10,'(26X,2E12.5,'' -> '',2E12.5)') 42 - - XU(I),YU(I),XPL(I),YPL(I) 43 - 10 CONTINUE 44 - *** Plot the line. 45 - CALL GPM(MIN(NU,MXLIST),XPL,YPL) 46 - END 155 GARFIELD ================================================== P=GRAPHICS D=GRMENUNW 1 ============================ 0 + +DECK,GRMENUNW,IF=-GTS26. 1 - SUBROUTINE GRMENU(STRING,SEPAR,XCMIN,YCMIN,XCMAX,YCMAX, 2 - - IWKCH,IDEVCH,ICPET,ICHOIC,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * GRMENU - Builds a menu from the input string. Version for use with 5 - * any GKS conforming to the final standard. 6 - *----------------------------------------------------------------------- 7 - PARAMETER(MXITEM=10) 8 - CHARACTER*(*) STRING 9 - CHARACTER SEPAR 10 - CHARACTER*20 ITEM(MXITEM) 11 - CHARACTER*500 RECORD 12 - INTEGER NITEM,LENGTH(MXITEM),IARRAY(1) 13 - REAL RARRAY(1) 14 - *** Assume we won't fail. 15 - IFAIL=0 16 - *** Scan for separator. 17 - NITEM=0 18 - I0=1 19 - DO 10 I=1,LEN(STRING) 20 - IF(STRING(I:I).EQ.SEPAR.OR.I.EQ.LEN(STRING))THEN 21 - IF(NITEM.LT.MXITEM)THEN 22 - NITEM=NITEM+1 23 - IF(I.EQ.LEN(STRING).AND.STRING(I:I).NE.SEPAR.AND. 24 - - I0.LE.I)THEN 25 - ITEM(NITEM)=STRING(I0:I) 26 - LENGTH(NITEM)=I-I0+1 27 - ELSEIF(I0.LE.I-1)THEN 28 - ITEM(NITEM)=STRING(I0:I-1) 29 - LENGTH(NITEM)=I-I0 30 - ELSE 31 - ITEM(NITEM)='< not labelled >' 32 - LENGTH(NITEM)=16 33 - ENDIF 34 - ELSE 35 - IFAIL=1 36 - RETURN 37 - ENDIF 38 - I0=I+1 39 - ENDIF 40 - 10 CONTINUE 41 - *** Pack the record. 42 - CALL GPREC(0,IARRAY,0,RARRAY,NITEM,LENGTH,ITEM,LEN(RECORD), 43 - - IERR,NCREC,RECORD) 44 - IF(IERR.NE.0)THEN 45 - CALL GMSG(IWKCH,'Unable to prepare the menu.') 46 - IFAIL=1 47 - RETURN 48 - ENDIF 49 - *** Check initial default for the choice. 50 - IF(ICHOIC.LE.0.OR.ICHOIC.GT.NITEM)ICHOIC=1 51 - *** Initialise the CHOICE. 52 - CALL GINCH(IWKCH,IDEVCH,1,ICHOIC,ICPET, 53 - - XCMIN,XCMAX,YCMIN,YCMAX,NCREC,RECORD) 54 - *** Request a choice. 55 - CALL GMSG(IWKCH,'Please choose an item from the menu.') 56 - 100 CONTINUE 57 - CALL GRQCH(IWKCH,IDEVCH,IERR,ICHOIC) 58 - IF(IERR.NE.1.OR.ICHOIC.LE.0.OR.ICHOIC.GT.NITEM)THEN 59 - CALL GMSG(IWKCH,'Not a valid choice, please try again.') 60 - GOTO 100 61 - ENDIF 62 - END 1 156 GARFIELD ================================================== P=GRAPHICS D=GRMENUOL 1 =================== PAGE 254 0 + +DECK,GRMENUOL,IF=GTS26. 1 - SUBROUTINE GRMENU(STRING,SEPAR,XCMIN,YCMIN,XCMAX,YCMAX, 2 - - IWKCH,IDEVCH,ICPET,ICHOIC,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * GRMENU - Builds a menu from the input string. Version for use with 5 - * the old GTS-GRAL, having a non-standard call for GPREC. 6 - *----------------------------------------------------------------------- 7 - PARAMETER(MXITEM=10) 8 - CHARACTER*(*) STRING 9 - CHARACTER SEPAR 10 - CHARACTER*200 ITEM 11 - CHARACTER*80 RECORD(10) 12 - INTEGER NITEM,LENGTH(MXITEM),IARRAY(1) 13 - REAL RARRAY(1) 14 - *** First few returns are all on failure. 15 - IFAIL=1 16 - *** Scan for separator. 17 - NITEM=0 18 - I0=1 19 - NCITEM=1 20 - DO 10 I=1,LEN(STRING) 21 - IF(STRING(I:I).EQ.SEPAR.OR.I.EQ.LEN(STRING))THEN 22 - IF(NITEM.LT.MXITEM)THEN 23 - NITEM=NITEM+1 24 - IF(I.EQ.LEN(STRING).AND.STRING(I:I).NE.SEPAR.AND. 25 - - I.GE.I0)THEN 26 - IF(NCITEM+I-I0.GT.LEN(ITEM))RETURN 27 - ITEM(NCITEM:NCITEM+I-I0)=STRING(I0:MIN(I0+19,I)) 28 - LENGTH(NITEM)=MIN(20,I-I0+1) 29 - NCITEM=NCITEM+MIN(20,I-I0+1) 30 - ELSEIF(I-1.GE.I0)THEN 31 - IF(NCITEM+I-I0-1.GT.LEN(ITEM))RETURN 32 - ITEM(NCITEM:NCITEM+I-I0-1)= 33 - - STRING(I0:MIN(I0+19,I-1)) 34 - LENGTH(NITEM)=MIN(20,I-I0) 35 - NCITEM=NCITEM+MIN(20,I-I0) 36 - ELSE 37 - IF(NCITEM+16.GT.LEN(ITEM))RETURN 38 - ITEM(NCITEM:NCITEM+15)='< not labelled >' 39 - LENGTH(NITEM)=16 40 - NCITEM=NCITEM+16 41 - ENDIF 42 - ELSE 43 - RETURN 44 - ENDIF 45 - I0=I+1 46 - ENDIF 47 - 10 CONTINUE 48 - *** Pack the record. 49 - CALL GPREC(NITEM,LENGTH,0,RARRAY,NCITEM,ITEM,10, 50 - - IERR,NCREC,RECORD) 51 - IF(IERR.NE.0)THEN 52 - CALL GMSG(IWKCH,'Unable to prepare the menu.') 53 - RETURN 54 - ENDIF 55 - *** Check initial default for the choice. 56 - IF(ICHOIC.LE.0.OR.ICHOIC.GT.NITEM)ICHOIC=1 57 - *** Initialise the CHOICE. 58 - CALL GINCH(IWKCH,IDEVCH,1,ICHOIC,ICPET, 59 - - XCMIN,XCMAX,YCMIN,YCMAX,NCREC,RECORD) 60 - *** Request a choice. 61 - CALL GMSG(IWKCH,'Please choose an item from the menu.') 62 - 100 CONTINUE 63 - CALL GRQCH(IWKCH,IDEVCH,IERR,ICHOIC) 64 - IF(IERR.NE.1.OR.ICHOIC.LE.0.OR.ICHOIC.GT.NITEM)THEN 65 - CALL GMSG(IWKCH,'Not a valid choice, please try again.') 66 - GOTO 100 67 - ENDIF 68 - *** Now it has worked. 69 - IFAIL=0 70 - END 157 GARFIELD ================================================== P=GRAPHICS D=GRMETAA 1 ============================ 0 + +DECK,GRMETAA,IF=APOLLO,UNIX. 1 - SUBROUTINE GRMETA(IWKTYP,IOFF,FILE,NCFILE,IFLAG,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GRMETA - Returns the workstation identifier from the command line. 4 - * (Last changed on 21/ 1/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 0 9-+ +SELF,IF=APOLLO. 10 - %include '/sys/ins/base.ins.ftn' 11 - %include '/sys/ins/pgm.ins.ftn' 12 - integer*2 iarg,nargs,istat 13 - integer pointer(128) 0 14-+ +SELF,IF=-APOLLO. 15 - integer iargc,nargs,iarg 16 - external iargc 0 17-+ +SELF. 18 - character*(*) file 19 - character*128 args 20 - integer iwktyp,ioff,ncfile,iflag,ifail,arg_length,inpcmx,istart, 21 - - iend,ionoff,icat,idum,inext,iwkr,ioffr,ifail1,ierr 22 - external inpcmx 23 - *** Default settings. 24 - call grwkid('*batch_default',iwktyp,ioff,icat,idum) 25 - file='garfield.metafile' 26 - ncfile=17 27 - ifail=1 28 - *** Pick up the value from the command line, count arguments. 1 157 P=GRAPHICS D=GRMETAA 2 PAGE 255 29-+ +SELF,IF=APOLLO. 30 - call pgm_$get_args(nargs,pointer) 31 - nargs=nargs-1 0 32-+ +SELF,IF=-APOLLO. 33 - nargs=iargc() 0 34-+ +SELF. 35 - *** Find the area devoted to the -metafile option. 36 - istart=0 37 - iend=nargs 38 - ionoff=0 39 - iflag=0 40 - do iarg=1,nargs 0 41-+ +SELF,IF=APOLLO. 42 - arg_length=pgm_$get_arg(iarg,args,istat) 43 - if(istat.ne.status_$ok)then 44 - print *,' !!!!!! GRMETA WARNING : Error fetching an'// 45 - - ' argument; default metafile type returned.' 46 - ifail=1 47 - return 48 - endif 0 49-+ +SELF,IF=-APOLLO. 50 - call argget(iarg,args,arg_length) 0 51-+ +SELF. 52 - if(args(1:1).eq.'-'.and.arg_length.gt.1.and.istart.ne.0)then 53 - iend=iarg-1 54 - goto 10 55 - elseif(inpcmx(args(1:arg_length),'-meta#file').ne.0)then 56 - istart=iarg+1 57 - ionoff=1 58 - elseif(inpcmx(args(1:arg_length),'-nometa#file').ne.0)then 59 - ionoff=-1 60 - endif 61 - enddo 62 - 10 continue 63 - *** Return here if there is a -nometafile or no -metafile. 64 - if(ionoff.eq.0)then 65 - ifail=0 66 - if(ldebug)write(lunout,'('' ++++++ GRMETA DEBUG :'', 67 - - '' No -metafile qualifier present.'')') 68 - iflag=0 69 - return 70 - elseif(ionoff.eq.-1)then 71 - ifail=0 72 - iflag=-1 73 - if(ldebug)write(lunout,'('' ++++++ GRMETA DEBUG :'', 74 - - '' Request not to produce a metafile.'')') 75 - return 76 - else 77 - iflag=+1 78 - endif 79 - *** Decode the part about the metafile. 80 - inext=istart 81 - do 20 iarg=istart,iend 82 - if(iarg.lt.inext)goto 20 83 - ** Retrieve the sub-keyword. 0 84-+ +SELF,IF=APOLLO. 85 - arg_length=pgm_$get_arg(iarg,args,istat) 0 86-+ +SELF,IF=-APOLLO. 87 - call argget(iarg,args,arg_length) 0 88-+ +SELF. 89 - ** Metafile type. 90 - if(inpcmx(args(1:arg_length),'t#ype').ne.0)then 91 - * Check there indeed is an argument. 92 - if(iarg.eq.iend)then 93 - PRINT *,' !!!!!! GRMETA WARNING : The argument'// 94 - - ' for "type" is missing.' 95 - ifail=1 96 - return 97 - endif 98 - * Retrieve the argument. 0 99-+ +SELF,IF=APOLLO. 100 - arg_length=pgm_$get_arg(iarg+1,args,istat) 0 101-+ +SELF,IF=-APOLLO. 102 - call argget(iarg+1,args,arg_length) 0 103-+ +SELF. 104 - * Compare with standard lists. 105 - call grwkid(args(1:arg_length),iwkr,ioffr,icat,ifail1) 106 - if((icat.ne.0.and.icat.ne.4).or.ifail1.ne.0)then 107 - PRINT *,' !!!!!! GRMETA WARNING : Metafile type '// 108 - - args(1:arg_length)//' not valid or only for'// 109 - - ' interactive use.' 110 - ifail=1 111 - return 112 - endif 113 - iwktyp=iwkr 114 - ioff=ioffr 115 - * Debugging output. 116 - if(ldebug)write(lunout,'('' ++++++ GRMETA DEBUG :'', 117 - - '' Metafile type '',A,'', GKS id '',I5,''.'')') 118 - - args(1:arg_length),iwktyp 119 - inext=iarg+2 120 - ** Metafile type via GKS identifier. 121 - elseif(inpcmx(args(1:arg_length),'GKS#_identifier').ne.0)then 122 - * Check there indeed is an argument. 123 - if(iarg.eq.iend)then 1 157 P=GRAPHICS D=GRMETAA 3 PAGE 256 124 - PRINT *,' !!!!!! GRMETA WARNING : The argument'// 125 - - ' for "GKS_identifier" is missing.' 126 - ifail=1 127 - return 128 - endif 129 - * Retrieve the argument. 0 130-+ +SELF,IF=APOLLO. 131 - arg_length=pgm_$get_arg(iarg+1,args,istat) 0 132-+ +SELF,IF=-APOLLO. 133 - call argget(iarg+1,args,arg_length) 0 134-+ +SELF. 135 - * Attempt to read the integer. 136 - call inpric(args(1:arg_length),iwkr,0,ifail1) 137 - if(ifail1.ne.0)then 138 - print *,' !!!!!! GRMETA WARNING : The metafile'// 139 - - ' GKS identifier is not a valid integer.' 140 - ifail=1 141 - return 142 - endif 143 - * Check workstation category. 144 - call gqwkca(iwkr,ierr,icat) 145 - if((icat.ne.0.and.icat.ne.4).or.ierr.ne.0)then 146 - PRINT *,' !!!!!! GRMETA WARNING : Metafile type '// 147 - - args(1:arg_length)//' not valid or only for'// 148 - - ' interactive use.' 149 - ifail=1 150 - return 151 - endif 152 - * Store the workstation type. 153 - iwktyp=iwkr 154 - * Debugging output. 155 - if(ldebug)write(lunout,'('' ++++++ GRMETA DEBUG :'', 156 - - '' GKS identifier '',I5,'' given for metafile'', 157 - - '' type.'')') iwktyp 158 - inext=iarg+2 159 - ** Connection offset. 160 - elseif(inpcmx(args(1:arg_length),'o#ffset').ne.0)then 161 - * Check there indeed is an argument. 162 - if(iarg.eq.iend)then 163 - PRINT *,' !!!!!! GRMETA WARNING : The argument'// 164 - - ' for "offset" is missing.' 165 - ifail=1 166 - return 167 - endif 168 - * Retrieve the argument. 0 169-+ +SELF,IF=APOLLO. 170 - arg_length=pgm_$get_arg(iarg+1,args,istat) 0 171-+ +SELF,IF=-APOLLO. 172 - call argget(iarg+1,args,arg_length) 0 173-+ +SELF. 174 - * Attempt to read the number. 175 - call inpric(args(1:arg_length),ioffr,0,ifail1) 176 - if(ifail1.ne.0)then 177 - print *,' !!!!!! GRMETA WARNING : The metafile'// 178 - - ' connection offset is not a valid integer.' 179 - ifail=1 180 - return 181 - endif 182 - ioff=ioffr 183 - * Debugging output. 184 - if(ldebug)write(lunout,'('' ++++++ GRMETA DEBUG :'', 185 - - '' Metafile connection offset '',I3,''.'')') 186 - - ioff 187 - inext=iarg+2 188 - ** Metafile file-name. 189 - elseif(inpcmx(args(1:arg_length),'n#ame').ne.0)then 190 - * Check there indeed is an argument. 191 - if(iarg.eq.iend)then 192 - PRINT *,' !!!!!! GRMETA WARNING : The argument'// 193 - - ' for "name" is missing.' 194 - ifail=1 195 - return 196 - endif 197 - * Retrieve the argument. 0 198-+ +SELF,IF=APOLLO. 199 - arg_length=pgm_$get_arg(iarg+1,args,istat) 0 200-+ +SELF,IF=-APOLLO. 201 - call argget(iarg+1,args,arg_length) 0 202-+ +SELF. 203 - * Check the length. 204 - if(arg_length.gt.mxname)then 205 - print *,' !!!!!! GRMETA WARNING : The file name'// 206 - - ' of the metafile is too long.' 207 - ifail=1 208 - return 209 - else 210 - file=args 211 - ncfile=arg_length 212 - endif 213 - * Debugging output. 214 - if(ldebug)write(lunout,'('' ++++++ GRMETA DEBUG :'', 215 - - '' Metafile file-name '',A,''.'')') FILE(1:NCFILE) 216 - inext=iarg+2 217 - ** Anything else is not valid. 218 - else 219 - print *,' !!!!!! GRMETA WARNING : The keyword '// 220 - - args(1:arg_length)//' is not valid within'// 1 157 P=GRAPHICS D=GRMETAA 4 PAGE 257 221 - - ' -metafile; is ignored.' 222 - endif 223 - 20 continue 224 - *** Things worked fine. 225 - ifail=0 226 - end 158 GARFIELD ================================================== P=GRAPHICS D=GRMETAV 1 ============================ 0 + +DECK,GRMETAV,IF=VAX. 1 - SUBROUTINE GRMETA(IWKTYP,IOFF,FILE,NCFILE,IFLAG,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GRMETA - Returns metafile information from the command line. 4 - * (Last changed on 21/ 3/92.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,PRINTPLOT. 8 - EXTERNAL CLI$GET_VALUE,CLI$PRESENT,CLI$_PRESENT,CLI$_ABSENT, 9 - - CLI$_NEGATED,CLI$_DEFAULTED 10 - INTEGER STATUS,CLI$GET_VALUE,CLI$PRESENT 11 - INTEGER*2 NC 12 - CHARACTER*255 META 13 - CHARACTER*(MXNAME) FILRES 14 - CHARACTER*(*) FILE 15 - INCLUDE '($FORDEF)' 16 - INCLUDE '($SSDEF)' 0 17-+ +SELF,IF=SAVE. 18 - SAVE INIT,IWKRES,IOFRES,FILRES,NCRES,IFRES,IFLAGR 0 19-+ +SELF. 20 - *** First and subsequent calls. 21 - DATA INIT/0/,IWKRES/0/,IOFRES/0/,IFRES/1/,IFLAGR/0/ 22 - DATA FILRES/'GARFIELD.METAFILE'/,NCRES/17/ 23 - IF(INIT.NE.0)THEN 24 - IWKTYP=IWKRES 25 - IOFF=IOFRES 26 - FILE=FILRES 27 - NCFILE=NCRES 28 - IFLAG=IFLAGR 29 - IFAIL=IFRES 30 - RETURN 31 - ELSE 32 - CALL GRWKID('*batch_default',IWKTYP,IOFF,ICAT,IDUM) 33 - FILE='GARFIELD.METAFILE' 34 - NCFILE=17 35 - IFAIL=1 36 - IFLAG=0 37 - INIT=1 38 - ENDIF 39 - *** Metafile qualifier at all present ? 40 - IF(CLI$PRESENT('METAFILE').EQ.%LOC(CLI$_NEGATED))THEN 41 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', 42 - - '' Request not to produce metafile graphics'', 43 - - '' output.'')') 44 - IFLAG=-1 45 - IFAIL=0 46 - GOTO 100 47 - ENDIF 48 - *** Is this a private metafile type ? 49 - IF(CLI$PRESENT('META_GKSID'))THEN 50 - STATUS=CLI$GET_VALUE('META_GKSID',META,NC) 51 - IFLAG=+1 52 - IF(STATUS.NE.SS$_NORMAL)THEN 53 - PRINT *,' !!!!!! GRMETA WARNING : Unable to get'// 54 - - ' the metafile GKS identifier.' 55 - GOTO 100 56 - ENDIF 57 - * Attempt to read as integer. 58 - CALL INPRIC(META(1:NC),IWKR,0,IFAIL1) 59 - IF(IFAIL1.NE.0)THEN 60 - PRINT *,' !!!!!! GRMETA WARNING : The metafile'// 61 - - ' GKS identifier is not a valid integer.' 62 - GOTO 100 63 - ENDIF 64 - * Check workstation category. 65 - CALL GQWKCA(IWKR,IERR,ICAT) 66 - IF((ICAT.NE.0.AND.ICAT.NE.4).OR.IERR.NE.0)THEN 67 - PRINT *,' !!!!!! GRMETA WARNING : Metafile type '// 68 - - META(1:NC)//' not valid or only for'// 69 - - ' interactive use.' 70 - GOTO 100 71 - ENDIF 72 - * Store workstation type. 73 - IWKTYP=IWKR 74 - * Debugging output. 75 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', 76 - - '' GKS identifier '',I5,'' given for metafile'', 77 - - '' type.'')') IWKTYP 78 - *** Or a standard metafile type ? 79 - ELSEIF(CLI$PRESENT('META_TYPE'))THEN 80 - STATUS=CLI$GET_VALUE('META_TYPE',META,NC) 81 - IFLAG=+1 82 - IF(STATUS.NE.SS$_NORMAL)THEN 83 - PRINT *,' !!!!!! GRMETA WARNING : Unable to get'// 84 - - ' the metafile type.' 85 - GOTO 100 86 - ENDIF 87 - CALL GRWKID(META(1:NC),IWKR,LUNOFF,ICAT,IFAIL1) 88 - IF((ICAT.NE.0.AND.ICAT.NE.4).OR.IFAIL1.NE.0)THEN 89 - PRINT *,' !!!!!! GRMETA WARNING : Metafile type '// 90 - - META(1:NC)//' not valid or only for'// 91 - - ' interactive use.' 92 - GOTO 100 93 - ENDIF 94 - IWKTYP=IWKR 1 158 P=GRAPHICS D=GRMETAV 2 PAGE 258 95 - IOFF=LUNOFF 96 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', 97 - - '' Metafile type '',A,'', GKS id '',I5,''.'')') 98 - - META(1:NC),IWKTYP 99 - ENDIF 100 - *** Logical unit offset. 101 - IF(CLI$PRESENT('META_OFFSET'))THEN 102 - STATUS=CLI$GET_VALUE('META_OFFSET',META,NC) 103 - IF(STATUS.NE.SS$_NORMAL)THEN 104 - PRINT *,' !!!!!! GRMETA WARNING : Unable to get'// 105 - - ' the metafile logical unit offset.' 106 - GOTO 100 107 - ENDIF 108 - CALL INPRIC(META(1:NC),IOFFR,0,IFAIL1) 109 - IF(IFAIL1.NE.0)THEN 110 - PRINT *,' !!!!!! GRMETA WARNING : The metafile'// 111 - - ' logical unit offset is not a valid integer.' 112 - GOTO 100 113 - ENDIF 114 - IOFF=IOFFR 115 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', 116 - - '' Metafile logical unit offset '',I3,''.'')') 117 - - IOFF 118 - ENDIF 119 - *** Metafile name. 120 - IF(CLI$PRESENT('META_NAME'))THEN 121 - STATUS=CLI$GET_VALUE('META_NAME',META,NCMETA) 122 - IF(STATUS.NE.SS$_NORMAL)THEN 123 - PRINT *,' !!!!!! GRMETA WARNING : Unable to get'// 124 - - ' the metafile file-name.' 125 - GOTO 100 126 - ENDIF 127 - IF(NCMETA.GT.MXNAME)THEN 128 - PRINT *,' !!!!!! GRMETA WARNING : The file name'// 129 - - ' of the metafile is too long.' 130 - GOTO 100 131 - ELSE 132 - FILE=META 133 - NCFILE=NCMETA 134 - ENDIF 135 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', 136 - - '' Metafile file-name '',A,''.'')') FILE(1:NCFILE) 137 - ENDIF 138 - *** Error handling and default storing. 139 - IFAIL=0 140 - 100 CONTINUE 141 - IWKRES=IWKTYP 142 - IFRES=IFAIL 143 - IOFRES=IOFF 144 - FILRES=FILE 145 - NCRES=NCFILE 146 - IFLAGR=IFLAG 147 - END 159 GARFIELD ================================================== P=GRAPHICS D=GRMETAC 1 ============================ 0 + +DECK,GRMETAC,IF=CMS. 1 - SUBROUTINE GRMETA(IWKTYP,IOFF,FILE,NCFILE,IFLAG,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GRMETA - Reads the command string to determine the metafile type. 4 - * (Last changed on 4/ 4/94.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,PRINTPLOT. 7 - INTEGER IRC 8 - CHARACTER*255 META 9 - CHARACTER*(*) FILE 10 - *** Default settings. 11 - CALL GRWKID('*batch_default',IWKTYP,IOFF,ICAT,IDUM) 12 - FILE='GARFIELD.METAFILE' 13 - NCFILE=17 14 - IFLAG=0 15 - IFAIL=1 16 - *** Check whether the metafile has to be active at all. 17 - CALL VMREXX('F','META_YN',META,IRC) 18 - * Handle errors picking up the value. 19 - IF(IRC.NE.0)THEN 20 - PRINT *,' !!!!!! GRMETA WARNING : Unable to pick up'// 21 - - ' the command line yes/no flag for metafiles.' 22 - IFAIL=1 23 - RETURN 24 - ENDIF 25 - * Check value. 26 - IF(META(1:2).EQ.'NO')THEN 27 - IFLAG=-1 28 - IF(LDEBUG)PRINT *,' ++++++ GRMETA DEBUG : Requested not'// 29 - - ' to produce metafile output.' 30 - IFAIL=0 31 - RETURN 32 - ELSEIF(META(1:3).NE.'YES')THEN 33 - IFLAG=0 34 - PRINT *,' !!!!!! GRMETA WARNING : Invalid metafile yes/no'// 35 - - ' flag on the command line; default returned.' 36 - IFAIL=1 37 - RETURN 38 - ELSE 39 - IFLAG=+1 40 - ENDIF 41 - *** Read the metafile type. 42 - CALL VMREXX('F','META_TYPE',META,IRC) 43 - * Handle errors picking up the value. 44 - IF(IRC.NE.0)THEN 45 - PRINT *,' !!!!!! GRMETA WARNING : Unable to pick up'// 46 - - ' the metafile type from the command line.' 47 - IFAIL=1 48 - RETURN 49 - ENDIF 1 159 P=GRAPHICS D=GRMETAC 2 PAGE 259 50 - ** Try to identify if it really is a type. 51 - IF(META(1:1).NE.'-')THEN 52 - * Determine the length. 53 - DO I=LEN(META),1,-1 54 - IF(META(I:I).NE.' ')THEN 55 - NC=I 56 - GOTO 10 57 - ENDIF 58 - ENDDO 59 - NC=0 60 - 10 CONTINUE 61 - IF(NC.GT.20)NC=20 62 - * Look in table. 63 - CALL GRWKID(META(1:NC),IWKR,LUNOFF,ICAT,IFAIL1) 64 - * Check the entry exists and is for batch use. 65 - IF((ICAT.NE.0.AND.ICAT.NE.4).OR.IFAIL1.NE.0)THEN 66 - PRINT *,' !!!!!! GRMETA WARNING : Metafile type '// 67 - - META(1:NC)//' not valid or only for'// 68 - - ' interactive use.' 69 - IFAIL=1 70 - RETURN 71 - ENDIF 72 - * Store if OK. 73 - IWKTYP=IWKR 74 - IOFF=LUNOFF 75 - * Debugging output. 76 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', 77 - - '' Metafile type '',A,'', GKS id '',I5,''.'')') 78 - - META(1:NC),IWKTYP 79 - ** Otherwise read the GKS identifier. 80 - ELSE 81 - CALL VMREXX('F','META_GKSID',META,IRC) 82 - * Handle errors picking up the value. 83 - IF(IRC.NE.0)THEN 84 - PRINT *,' !!!!!! GRMETA WARNING : Unable to pick up'// 85 - - ' the metafile GKS identifier from the command line.' 86 - IFAIL=1 87 - RETURN 88 - ENDIF 89 - * Determine the length. 90 - DO I=LEN(META),1,-1 91 - IF(META(I:I).NE.' ')THEN 92 - NC=I 93 - GOTO 20 94 - ENDIF 95 - ENDDO 96 - NC=0 97 - 20 CONTINUE 98 - * Interpret as a number. 99 - CALL INPRIC(META(1:NC),IWKR,0,IFAIL1) 100 - IF(IFAIL1.NE.0)THEN 101 - PRINT *,' !!!!!! GRMETA WARNING : The metafile'// 102 - - ' GKS identifier is not a valid integer.' 103 - IFAIL=1 104 - RETURN 105 - ENDIF 106 - * Check workstation category. 107 - CALL GQWKCA(IWKR,IERR,ICAT) 108 - IF((ICAT.NE.0.AND.ICAT.NE.4).OR.IERR.NE.0)THEN 109 - PRINT *,' !!!!!! GRMETA WARNING : Metafile type '// 110 - - META(1:NC)//' not valid or only for'// 111 - - ' interactive use.' 112 - IFAIL=1 113 - RETURN 114 - ENDIF 115 - * Store workstation type. 116 - IWKTYP=IWKR 117 - * Debugging output. 118 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', 119 - - '' Metafile GKS identifier is '',I5,''.'')') 120 - - IWKTYP 121 - ** And the logical unit offset. 122 - CALL VMREXX('F','META_OFFSET',META,IRC) 123 - * Handle errors picking up the value. 124 - IF(IRC.NE.0)THEN 125 - PRINT *,' !!!!!! GRMETA WARNING : Unable to get the'// 126 - - ' metafile logical unit offset.' 127 - IFAIL=1 128 - RETURN 129 - ENDIF 130 - * Determine the length. 131 - DO I=LEN(META),1,-1 132 - IF(META(I:I).NE.' ')THEN 133 - NC=I 134 - GOTO 30 135 - ENDIF 136 - ENDDO 137 - NC=0 138 - 30 CONTINUE 139 - * Interpret as a number. 140 - CALL INPRIC(META(1:NC),IOFFR,0,IFAIL1) 141 - IF(IFAIL1.NE.0)THEN 142 - PRINT *,' !!!!!! GRMETA WARNING : The metafile'// 143 - - ' logical unit offset is not a valid integer.' 144 - IFAIL=1 145 - RETURN 146 - ENDIF 147 - IOFF=IOFFR 148 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', 149 - - '' Metafile logical unit offset '',I3,''.'')') 150 - - IOFF 151 - ENDIF 152 - *** And also get the file name. 153 - CALL VMREXX('F','META_NAME',META,IRC) 154 - * Handle errors picking up the value. 155 - IF(IRC.NE.0)THEN 1 159 P=GRAPHICS D=GRMETAC 3 PAGE 260 156 - PRINT *,' !!!!!! GRMETA WARNING : Unable to get the'// 157 - - ' metafile file name.' 158 - IFAIL=1 159 - RETURN 160 - ENDIF 161 - * Determine the length. 162 - DO I=LEN(META),1,-1 163 - IF(META(I:I).NE.' ')THEN 164 - NC=I 165 - GOTO 40 166 - ENDIF 167 - ENDDO 168 - NC=0 169 - 40 CONTINUE 170 - * Verify the format. 171 - CALL VMNAME(META,NC,IFAIL1) 172 - IF(IFAIL1.NE.0)THEN 173 - PRINT *,' !!!!!! GRMETA WARNING : File name format is'// 174 - - ' not valid.' 175 - IFAIL=1 176 - RETURN 177 - ENDIF 178 - * Store the result. 179 - IF(NC.NE.0)THEN 180 - FILE=META(1:NC) 181 - NCFILE=NC 182 - ELSE 183 - FILE=' ' 184 - NCFILE=1 185 - ENDIF 186 - * Debugging output. 187 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', 188 - - '' Metafile file name: '',A,''.'')') FILE(1:NCFILE) 189 - *** Things went OK. 190 - IFAIL=0 191 - END 160 GARFIELD ================================================== P=GRAPHICS D=GRNEXT 1 ============================ 0 + +DECK,GRNEXT. 1 - SUBROUTINE GRNEXT 2 - *----------------------------------------------------------------------- 3 - * GRNEXT - Routine clearing the screen. 4 - * (Last changed on 26/ 5/94.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,PARAMETERS. 8.- +SEQ,GRAPHICS. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*120 STRING 11 - CHARACTER*8 DATE,TIME 12 - EXTERNAL STDSTR 13 - LOGICAL STDSTR 14 - *** Plot the time stamp if requested. 15 - IF(LSTAMP)THEN 16 - * GKS settings. 17 - CALL GSELNT(0) 18 - CALL GSTXP(0) 19 - CALL GRATTS('MESSAGE','TEXT') 20 - CALL GSTXAL(1,5) 21 - CALL GSCHUP(1.0,0.0) 22 - * Text itself. 23 - CALL DATTIM(DATE,TIME) 24 - STRING=STAMP 25 - NCSTR=NCSTMP 26 - CALL INPSUB(STRING,NCSTR,IFAIL) 27 - CALL GRTX(0.96,0.96,'Plotted at '//TIME//' on '//DATE// 28 - - STRING(1:NCSTR)) 29 - * Restore the normal environment. 30 - CALL GSTXAL(0,0) 31 - CALL GRTX(0.03,0.03,' ') 32 - CALL GSELNT(1) 33 - ENDIF 0 34-+ +SELF,IF=CMS,CRAY,VAX,IF=-HIGZ. 35 - *** Clear screen, first get Operating State value. 36 - CALL GQOPS(IOPSTA) 37 - IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG : Current'', 38 - - '' GKS operating state: '',I1)') IOPSTA 39 - * Close current segment if open. 40 - IF(IOPSTA.EQ.4)CALL GCLSG 41 - * Active workstations, update, wait and clear as appropriate. 42 - IF(IOPSTA.GE.3)THEN 43 - * Determine number of active workstations. 44 - CALL GQACWK(0,IERR,NACT,IWK) 45 - IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG : Number'', 46 - - '' of active WS: '',I3,'', inq err: '', 47 - - I3,''.'')') NACT,IERR 48 - IWKREQ=-1 49 - DO 20 I=1,NACT 50 - CALL GQACWK(I,IERR,IDUM,IWK) 51 - * Update those that are active. 52 - CALL GUWK(IWK,0) 53 - * Locate one that has input facilities. 54 - CALL GQWKC(IWK,IERR1,ICONID,IWKTYP) 55 - CALL GQWKCA(IWKTYP,IERR2,IWKCAT) 56 - IF(IWKCAT.EQ.1.OR.IWKCAT.EQ.2)IWKREQ=IWK 57 - IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG : WS '',I3, 58 - - '', type: '',I5,'', conid: '',I4,'' cat: '',I1, 59 - - '', GQWKC err: '',I3,'', GQWKCA err: '',I3,''.'')') 60 - - IWK,IWKTYP,ICONID,IWKCAT,IERR1,IERR2 61 - 20 CONTINUE 62 - * Issue an string request to an input workstation. 63 - IF(IWKREQ.NE.-1)THEN 64 - IF(LWAITA)THEN 65 - IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG '', 1 160 P=GRAPHICS D=GRNEXT 2 PAGE 261 66 - - '': Waiting for return on WS: '',I3,''.'')') 67 - - IWKREQ 68 - CALL GMSG(IWKREQ, 69 - - 'Plot completed, hit RETURN to continue.') 70 - CALL GRQST(IWKREQ,1,ISTAT,L,STRING) 71 - ELSE 72 - IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG '', 73 - - '': Waiting has not been requested.'')') 74 - ENDIF 75 - ELSEIF(LDEBUG)THEN 76 - WRITE(10,'('' ++++++ GRNEXT DEBUG : No WS with'', 77 - - '' input facilities found.'')') 78 - ENDIF 79 - * Clear all workstations, if that has been requested by the user. 80 - IF(LGCLRA)THEN 81 - DO 30 I=1,NACT 82 - CALL GQACWK(I,IERR,IDUM,IWK) 83 - CALL GCLRWK(IWK,1) 84 - IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG :'', 85 - - '' Clear sent to WS '',I3,'', inq err: '', 86 - - I3,''.'')') IWK,IERR 87 - 30 CONTINUE 88 - ELSEIF(LDEBUG)THEN 89 - WRITE(10,'('' ++++++ GRNEXT DEBUG : No clear'', 90 - - '' of WS done because LGCLRA=F.'')') 91 - ENDIF 92 - ENDIF 93 - * And switch to alpha mode. 94 - CALL GRALPH 0 95-+ +SELF,IF=APOLLO,UNIX,IF=-HIGZ. 96 - *** Clear screen, first get Operating State value. 97 - CALL GQOPS(IOPSTA) 98 - IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG : Current'', 99 - - '' GKS operating state: '',I1,''.'')') IOPSTA 100 - * Close current segment if open. 101 - IF(IOPSTA.EQ.4)CALL GCLSG 102 - * Active workstations, update, wait and clear as appropriate. 103 - IF(IOPSTA.GE.3)THEN 104 - * Determine number of active workstations. 105 - CALL GQACWK(0,IERR,NACT,IWK) 106 - IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG : Number'', 107 - - '' of active WS: '',I3,'', inq err: '', 108 - - I3,''.'')') NACT,IERR 109 - DO 40 I=1,NACT 110 - CALL GQACWK(I,IERR,IDUM,IWK) 111 - * Update those that are active. 112 - CALL GUWK(IWK,0) 113 - 40 CONTINUE 114 - * Wait for user response. 115 - IF(LWAITA.AND.STDSTR('INPUT'))THEN 116 - PRINT *,' Plot completed, hit RETURN to continue.' 117 - READ(5,'(A80)',END=10,IOSTAT=IOS,ERR=10) STRING 118 - 10 CONTINUE 119 - ENDIF 120 - * Clear all workstations, if that has been requested by the user. 121 - IF(LGCLRA)THEN 122 - DO 50 I=1,NACT 123 - CALL GQACWK(I,IERR,IDUM,IWK) 124 - CALL GCLRWK(IWK,1) 125 - IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG :'', 126 - - '' Clear sent to WS '',I3,''.'')') IWK 127 - 50 CONTINUE 128 - ELSEIF(LDEBUG)THEN 129 - WRITE(10,'('' ++++++ GRNEXT DEBUG : No clear'', 130 - - '' of WS done because LGCLRA=F.'')') 131 - ENDIF 132 - ENDIF 0 133-+ +SELF,IF=HIGZ,IF=-CMS. 134 - CALL IUWK(0,1) 135 - IF(LWAITA.AND.STDSTR('INPUT'))THEN 136 - IF(LSYNCH)THEN 137 - PRINT *,' >>>>>> graphics' 138 - ELSE 139 - PRINT *,' Plot completed, hit RETURN to proceed.' 140 - ENDIF 141 - READ(5,'(A80)',END=10,IOSTAT=IOS,ERR=10) STRING 142 - 10 CONTINUE 143 - ENDIF 144 - IF(LGCLRA)CALL ICLRWK(0,IFLAG) 0 145-+ +SELF,IF=HIGZ,IF=CMS. 146 - CALL IUWK(0,1) 147 - IF(LWAITA.AND.STDSTR('INPUT'))THEN 148 - IF(LSYNCH)THEN 149 - PRINT *,' >>>>>> graphics' 150 - ELSE 151 - PRINT *,' Plot completed, hit RETURN to proceed.' 152 - ENDIF 153 - READ(5,END=2000,NUM=NDUMMY) STRING 154 - GOTO 10 155 - 2000 CONTINUE 156 - REWIND(UNIT=5) 157 - 10 CONTINUE 158 - ENDIF 159 - IF(LGCLRA)CALL ICLRWK(0,IFLAG) 0 160-+ +SELF. 161 - END 1 161 GARFIELD ================================================== P=GRAPHICS D=GRAOPT 1 =================== PAGE 262 0 + +DECK,GRAOPT. 1 - SUBROUTINE GRAOPT(OPT) 2 - *----------------------------------------------------------------------- 3 - * GRAOPT - Log/linear scales and other options. 4 - * (Last changed on 18/ 6/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GRAPHICS. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*(*) OPT 11 - INTEGER INPCMX,I,J,INEXT,ILAST,LENOPT 12 - EXTERNAL INPCMX 13 - *** Store the length of the string for later reference. 14 - DO 50 I=LEN(OPT),1,-1 15 - IF(OPT(I:I).NE.' ')THEN 16 - LENOPT=I 17 - GOTO 60 18 - ENDIF 19 - 50 CONTINUE 20 - RETURN 21 - 60 CONTINUE 22 - *** Look for starting character of next word. 23 - INEXT=1 24 - DO 10 I=1,LENOPT 25 - IF(I.LT.INEXT)GOTO 10 26 - * Skip separators. 27 - IF(INDEX(' ,',OPT(I:I)).NE.0)GOTO 10 28 - * Word starts, look for the end. 29 - DO 20 J=I+1,LENOPT 30 - IF(INDEX(' ,',OPT(J:J)).EQ.0)GOTO 20 31 - ILAST=J-1 32 - GOTO 30 33 - 20 CONTINUE 34 - ILAST=LENOPT 35 - 30 CONTINUE 36 - INEXT=ILAST+1 37 - * Check the various options. 38 - IF(INPCMX(OPT(I:ILAST),'LIN#EAR-X').NE.0)THEN 39 - LOGX=.FALSE. 40 - ELSEIF(INPCMX(OPT(I:ILAST),'LOG#ARITHMIC-X').NE.0)THEN 41 - LOGX=.TRUE. 42 - ELSEIF(INPCMX(OPT(I:ILAST),'LIN#EAR-Y').NE.0)THEN 43 - LOGY=.FALSE. 44 - ELSEIF(INPCMX(OPT(I:ILAST),'LOG#ARITHMIC-Y').NE.0)THEN 45 - LOGY=.TRUE. 46 - ELSEIF(INPCMX(OPT(I:ILAST),'LOG#ARITHMIC-Y').NE.0)THEN 47 - LOGY=.FALSE. 48 - ELSEIF(INPCMX(OPT(I:ILAST),'GR#ID').NE.0)THEN 49 - LGRID=.TRUE. 50 - ELSEIF(INPCMX(OPT(I:ILAST),'NOGR#ID').NE.0)THEN 51 - LGRID=.FALSE. 52 - ELSEIF(INPCMX(OPT(I:ILAST),'T#IME-S#TAMP').NE.0)THEN 53 - LSTAMP=.TRUE. 54 - ELSEIF(INPCMX(OPT(I:ILAST),'NOT#IME-S#TAMP').NE.0)THEN 55 - LSTAMP=.FALSE. 56 - ELSEIF(INPCMX(OPT(I:ILAST),'CL#EAR-BEF#ORE-#PLOT').NE.0)THEN 57 - LGCLRB=.TRUE. 58 - ELSEIF(INPCMX(OPT(I:ILAST),'NOCL#EAR-BEF#ORE-#PLOT').NE.0)THEN 59 - LGCLRB=.FALSE. 60 - ELSEIF(INPCMX(OPT(I:ILAST),'CL#EAR-AFT#ER-#PLOT').NE.0)THEN 61 - LGCLRA=.TRUE. 62 - ELSEIF(INPCMX(OPT(I:ILAST),'NOCL#EAR-AFT#ER-#PLOT').NE.0)THEN 63 - LGCLRA=.FALSE. 64 - ELSEIF(INPCMX(OPT(I:ILAST),'WAIT-AFT#ER-#PLOT').NE.0)THEN 65 - LWAITA=.TRUE. 66 - ELSEIF(INPCMX(OPT(I:ILAST),'NOWAIT-AFT#ER-#PLOT').NE.0)THEN 67 - LWAITA=.FALSE. 68 - ELSEIF(INPCMX(OPT(I:ILAST),'WAIT-BEF#ORE-#PLOT').NE.0)THEN 69 - LWAITB=.TRUE. 70 - ELSEIF(INPCMX(OPT(I:ILAST),'NOWAIT-BEF#ORE-#PLOT').NE.0)THEN 71 - LWAITB=.FALSE. 72 - ELSEIF(INPCMX(OPT(I:ILAST),'EX#ECUTE-CONTR#OL-#CHARACTERS').NE. 73 - - 0)THEN 74 - LXCCH=.TRUE. 75 - ELSEIF(INPCMX(OPT(I:ILAST),'DISP#LAY-CONTR#OL-#CHARACTERS').NE. 76 - - 0)THEN 77 - LXCCH=.FALSE. 78 - ELSE 79 - PRINT *,' !!!!!! GRAOPT WARNING : The option ', 80 - - OPT(I:ILAST),' is not valid ; is ignored.' 81 - ENDIF 82 - * Position for next word. 83 - INEXT=ILAST+1 84 - IF(INEXT.GT.LENOPT)THEN 85 - IF(LDEBUG)WRITE(LUNOUT, 86 - - '('' ++++++ GRAOPT DEBUG : Current options:''/ 87 - - 26X,''Logarithmic-x= '',L1,'', Logarithmic-y='',L1/ 88 - - 26X,''Grid overlay = '',L1,'', Time stamp ='',L1/ 89 - - 26X,''Clear Before = '',L1,'', Clear After ='',L1/ 90 - - 26X,''Wait Before = '',L1,'', Wait After ='',L1/ 91 - - 26X,''Execute CC = '',L1)') 92 - - LOGX,LOGY,LGRID,LSTAMP,LGCLRB,LGCLRA,LWAITB,LWAITA, 93 - - LXCCH 94 - RETURN 95 - ENDIF 96 - 10 CONTINUE 97 - END 162 GARFIELD ================================================== P=GRAPHICS D=GRARRO 1 ============================ 0 + +DECK,GRARRO. 1 - SUBROUTINE GRARRO(X0,Y0,X1,Y1) 2 - *----------------------------------------------------------------------- 3 - * GRARRO - Plots an arrow. 4 - * (Last changed on 2/ 7/99.) 1 162 P=GRAPHICS D=GRARRO 2 PAGE 263 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,PARAMETERS. 10.- +SEQ,GRAPHICS. 11 - REAL X0,Y0,X1,Y1,X0NDC,Y0NDC,X1NDC,Y1NDC,XPL(3),YPL(3),XAUX,YAUX, 12 - - PHIARR,ALEN,WINDOW(4),VIEWP(4) 13 - INTEGER IERR,NT 14 - *** Inquire current NT. 15 - CALL GQCNTN(IERR,NT) 16 - IF(IERR.NE.0)THEN 17 - IF(LDEBUG)PRINT *,' ++++++ GRARRO DEBUG : Error from'// 18 - - ' GQCNTN, code=',IERR,'; text not plotted.' 19 - RETURN 20 - ENDIF 21 - *** Find out how big the screen is. 22 - CALL GQNT(NT,IERR,WINDOW,VIEWP) 23 - IF(IERR.NE.0)THEN 24 - IF(LDEBUG)PRINT *,' ++++++ GRARRO DEBUG : Error from'// 25 - - ' GQNT, code=',IERR,'; text not plotted.' 26 - RETURN 27 - ENDIF 28 - *** Transform points to NDC. 29 - IF(LOGX.AND.X0.GT.0)THEN 30 - X0NDC=(VIEWP(2)-VIEWP(1))*(LOG10(X0)-WINDOW(1))/ 31 - - (WINDOW(2)-WINDOW(1)) 32 - ELSEIF(LOGX)THEN 33 - X0NDC=-1 34 - ELSE 35 - X0NDC=(VIEWP(2)-VIEWP(1))*(X0-WINDOW(1))/ 36 - - (WINDOW(2)-WINDOW(1)) 37 - ENDIF 38 - IF(LOGX.AND.X1.GT.0)THEN 39 - X1NDC=(VIEWP(2)-VIEWP(1))*(LOG10(X1)-WINDOW(1))/ 40 - - (WINDOW(2)-WINDOW(1)) 41 - ELSEIF(LOGX)THEN 42 - X1NDC=-1 43 - ELSE 44 - X1NDC=(VIEWP(2)-VIEWP(1))*(X1-WINDOW(1))/ 45 - - (WINDOW(2)-WINDOW(1)) 46 - ENDIF 47 - IF(LOGY.AND.Y0.GT.0)THEN 48 - Y0NDC=(VIEWP(4)-VIEWP(3))*(LOG10(Y0)-WINDOW(3))/ 49 - - (WINDOW(4)-WINDOW(3)) 50 - ELSEIF(LOGY)THEN 51 - Y0NDC=-1 52 - ELSE 53 - Y0NDC=(VIEWP(4)-VIEWP(3))*(Y0-WINDOW(3))/ 54 - - (WINDOW(4)-WINDOW(3)) 55 - ENDIF 56 - IF(LOGY.AND.Y1.GT.0)THEN 57 - Y1NDC=(VIEWP(4)-VIEWP(3))*(LOG10(Y1)-WINDOW(3))/ 58 - - (WINDOW(4)-WINDOW(3)) 59 - ELSEIF(LOGY)THEN 60 - Y1NDC=-1 61 - ELSE 62 - Y1NDC=(VIEWP(4)-VIEWP(3))*(Y1-WINDOW(3))/ 63 - - (WINDOW(4)-WINDOW(3)) 64 - ENDIF 65 - *** Switch to NDC coordinates. 66 - CALL GSELNT(0) 67 - *** Straight line of the arrow. 68 - XPL(1)=X0NDC 69 - YPL(1)=Y0NDC 70 - XPL(2)=X1NDC 71 - YPL(2)=Y1NDC 72 - * Plot in polar coordinates. 73 - IF(PRVIEW.EQ.'R-PHI')THEN 74 - CALL CFMRTC(XPL,YPL,XAUX,YAUX,2) 75 - CALL GPL(2,XAUX,YAUX) 76 - * Or in Cartesian coordinates. 77 - ELSE 78 - CALL GPL(2,XPL,YPL) 79 - ENDIF 80 - *** Make the arrow top. 81 - PHIARR=ATAN2(Y1NDC-Y0NDC,X1NDC-X0NDC) 82 - ALEN=SQRT((X1NDC-X0NDC)**2+(Y1NDC-Y0NDC)**2) 83 - XPL(1)=X1NDC-ALEN*ARRLEN*COS(DBLE(PHIARR)+ARRANG) 84 - YPL(1)=Y1NDC-ALEN*ARRLEN*SIN(DBLE(PHIARR)+ARRANG) 85 - XPL(2)=X1NDC 86 - YPL(2)=Y1NDC 87 - XPL(3)=X1NDC-ALEN*ARRLEN*COS(DBLE(PHIARR)-ARRANG) 88 - YPL(3)=Y1NDC-ALEN*ARRLEN*SIN(DBLE(PHIARR)-ARRANG) 89 - * Plot in polar coordinates. 90 - IF(PRVIEW.EQ.'R-PHI')THEN 91 - CALL CFMRTC(XPL,YPL,XAUX,YAUX,3) 92 - CALL GPL(3,XAUX,YAUX) 93 - * Or in Cartesian coordinates. 94 - ELSE 95 - CALL GPL(3,XPL,YPL) 96 - ENDIF 97 - *** Restore coordinate system. 98 - CALL GSELNT(NT) 99 - END 163 GARFIELD ================================================== P=GRAPHICS D=GRTEXT 1 ============================ 0 + +DECK,GRTEXT. 1 - SUBROUTINE GRTEXT(XTXT,YTXT,TEXT) 2 - *----------------------------------------------------------------------- 3 - * GRTEXT - Plots a text in NT=0 at WC coordinates (XTXT,YTXT). 4 - * (Last changed on 13/11/96.) 5 - *----------------------------------------------------------------------- 6 - implicit none 1 163 P=GRAPHICS D=GRTEXT 2 PAGE 264 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,PARAMETERS. 10.- +SEQ,GRAPHICS. 11 - REAL XTXT,YTXT,XNDC,YNDC,WINDOW(4),VIEWP(4) 12 - INTEGER IERR,NT 13 - CHARACTER*(*) TEXT 14 - *** Inquire current NT. 15 - CALL GQCNTN(IERR,NT) 16 - IF(IERR.NE.0)THEN 17 - IF(LDEBUG)PRINT *,' ++++++ GRTEXT DEBUG : Error from'// 18 - - ' GQCNTN, code=',IERR,'; text not plotted.' 19 - RETURN 20 - ENDIF 21 - *** Find out how big the screen is. 22 - CALL GQNT(NT,IERR,WINDOW,VIEWP) 23 - IF(IERR.NE.0)THEN 24 - IF(LDEBUG)PRINT *,' ++++++ GRTEXT DEBUG : Error from'// 25 - - ' GQNT, code=',IERR,'; text not plotted.' 26 - RETURN 27 - ENDIF 28 - *** Translate the (XTXT,YTXT) pair into NDC. 29 - IF(LOGX.AND.XTXT.GT.0)THEN 30 - XNDC=(VIEWP(2)-VIEWP(1))*(LOG10(XTXT)-WINDOW(1))/ 31 - - (WINDOW(2)-WINDOW(1)) 32 - ELSEIF(LOGX)THEN 33 - XNDC=-1 34 - ELSE 35 - XNDC=(VIEWP(2)-VIEWP(1))*(XTXT-WINDOW(1))/ 36 - - (WINDOW(2)-WINDOW(1)) 37 - ENDIF 38 - IF(LOGY.AND.YTXT.GT.0)THEN 39 - YNDC=(VIEWP(4)-VIEWP(3))*(LOG10(YTXT)-WINDOW(3))/ 40 - - (WINDOW(4)-WINDOW(3)) 41 - ELSEIF(LOGY)THEN 42 - YNDC=-1 43 - ELSE 44 - YNDC=(VIEWP(4)-VIEWP(3))*(YTXT-WINDOW(3))/ 45 - - (WINDOW(4)-WINDOW(3)) 46 - ENDIF 47 - *** Plot the text. 48 - CALL GSELNT(0) 49 - CALL GRTX(XNDC,YNDC,TEXT) 50 - CALL GSELNT(NT) 51 - END 164 GARFIELD ================================================== P=GRAPHICS D=GRTXGKS 1 ============================ 0 + +DECK,GRTXGKS,IF=-HIGZ. 1 - SUBROUTINE GRTX(X,Y,TEXT) 2 - *----------------------------------------------------------------------- 3 - * GRTX - Calls GTX, version for GKS. 4 - * (Last changed on 19/ 5/95.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - REAL X,Y 8 - CHARACTER*(*) TEXT 9 - CALL GTX(X,Y,TEXT) 10 - END 165 GARFIELD ================================================== P=GRAPHICS D=GRTXHIGZ 1 ============================ 0 + +DECK,GRTXHIGZ,IF=HIGZ. 1 - SUBROUTINE GRTX(X,Y,STRING) 2 - *----------------------------------------------------------------------- 3 - * GRTX - Calls ITX, version for HIGZ. 4 - * (Last changed on 13/12/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,GRAPHICS. 10 - CHARACTER*(*) STRING 11 - CHARACTER*256 STROUT 12 - LOGICAL UNIT 13 - INTEGER NOUT,INEXT,I 14 - REAL X,Y 15 - *** Identify the routine if requested. 16 - IF(LIDENT)PRINT *,' /// ROUTINE GRTX (HIGZ version) ///' 17 - *** Debugging output. 18 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRTX DEBUG : In: "'',A, 19 - - ''",'')') STRING 20 - *** Do not process empty strings. 21 - IF(LEN(STRING).LT.1)RETURN 22 - *** Simply copy the string if control characters are to be executed. 23 - IF(LXCCH)THEN 24 - NOUT=MIN(256,LEN(STRING)) 25 - STROUT=STRING 26 - *** Convert the control characters in the string if requested. 27 - ELSE 28 - NOUT=0 29 - UNIT=.FALSE. 30 - * Loop over the string. 31 - INEXT=1 32 - DO 10 I=1,LEN(STRING) 33 - * Skip a few characters. 34 - IF(I.LT.INEXT)GOTO 10 35 - * Check for excessive length. 36 - IF(NOUT+9.GT.256)GOTO 20 37 - * Fix SGML controls. 38 - IF(I+4.LE.LEN(STRING).AND. 39 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.''.OR. 40 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'')THEN 41 - STROUT(NOUT+1:NOUT+1)='?' 42 - INEXT=I+5 43 - NOUT=NOUT+1 1 165 P=GRAPHICS D=GRTXHIGZ 2 PAGE 265 44 - ELSEIF(I+4.LE.LEN(STRING).AND. 45 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.''.OR. 46 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'')THEN 47 - STROUT(NOUT+1:NOUT+1)='^' 48 - INEXT=I+5 49 - NOUT=NOUT+1 50 - ELSEIF(I+5.LE.LEN(STRING).AND. 51 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.''.OR. 52 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'')THEN 53 - STROUT(NOUT+1:NOUT+1)='!' 54 - INEXT=I+6 55 - NOUT=NOUT+1 56 - ELSEIF(I+5.LE.LEN(STRING).AND. 57 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.''.OR. 58 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'')THEN 59 - STROUT(NOUT+1:NOUT+1)='!' 60 - INEXT=I+6 61 - NOUT=NOUT+1 62 - ELSEIF(I+5.LE.LEN(STRING).AND. 63 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.''.OR. 64 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'')THEN 65 - STROUT(NOUT+1:NOUT+1)='&' 66 - INEXT=I+6 67 - NOUT=NOUT+1 68 - * Fix a series of control characters. 69 - ELSEIF(STRING(I:I).EQ.'|')THEN 70 - STROUT(NOUT+1:NOUT+3)='"B#' 71 - NOUT=NOUT+3 72 - ELSEIF(STRING(I:I).EQ.'$')THEN 73 - STROUT(NOUT+1:NOUT+3)='"D#' 74 - NOUT=NOUT+3 75 - ELSEIF(STRING(I:I).EQ.'!')THEN 76 - STROUT(NOUT+1:NOUT+3)='"E#' 77 - NOUT=NOUT+3 78 - ELSEIF(STRING(I:I).EQ.'#')THEN 79 - STROUT(NOUT+1:NOUT+3)='"F#' 80 - NOUT=NOUT+3 81 - ELSEIF(STRING(I:I).EQ.'>')THEN 82 - STROUT(NOUT+1:NOUT+3)='"G#' 83 - NOUT=NOUT+3 84 - ELSEIF(STRING(I:I).EQ.'?')THEN 85 - STROUT(NOUT+1:NOUT+3)='"H#' 86 - NOUT=NOUT+3 87 - ELSEIF(STRING(I:I).EQ.':')THEN 88 - STROUT(NOUT+1:NOUT+3)='"J#' 89 - NOUT=NOUT+3 90 - ELSEIF(STRING(I:I).EQ.'<')THEN 91 - STROUT(NOUT+1:NOUT+3)='"L#' 92 - NOUT=NOUT+3 93 - ELSEIF(STRING(I:I).EQ.'[')THEN 94 - STROUT(NOUT+1:NOUT+3)='"M#' 95 - UNIT=.TRUE. 96 - NOUT=NOUT+3 97 - ELSEIF(STRING(I:I).EQ.']')THEN 98 - STROUT(NOUT+1:NOUT+3)='"N#' 99 - UNIT=.FALSE. 100 - NOUT=NOUT+3 101 - ELSEIF(STRING(I:I).EQ.'{')THEN 102 - STROUT(NOUT+1:NOUT+3)='"P#' 103 - NOUT=NOUT+3 104 - ELSEIF(STRING(I:I).EQ.'}')THEN 105 - STROUT(NOUT+1:NOUT+3)='"Q#' 106 - NOUT=NOUT+3 107 - ELSEIF(STRING(I:I).EQ.'%')THEN 108 - STROUT(NOUT+1:NOUT+3)='"Y#' 109 - NOUT=NOUT+3 110 - ELSEIF(STRING(I:I).EQ.'''')THEN 111 - STROUT(NOUT+1:NOUT+5)='"<9>#' 112 - NOUT=NOUT+5 113 - ELSEIF(STRING(I:I).EQ.'"')THEN 114 - STROUT(NOUT+1:NOUT+6)='"<99>#' 115 - NOUT=NOUT+6 116 - * SGML entities, first accented letters "a" and "A". 117 - ELSEIF(I+7.LE.LEN(STRING).AND. 118 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'á')THEN 119 - STROUT(NOUT+1:NOUT+4)='\\366' 120 - INEXT=I+8 121 - NOUT=NOUT+4 122 - ELSEIF(I+7.LE.LEN(STRING).AND. 123 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'Á')THEN 124 - STROUT(NOUT+1:NOUT+4)='\\367' 125 - INEXT=I+8 126 - NOUT=NOUT+4 127 - ELSEIF(I+6.LE.LEN(STRING).AND. 128 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'â')THEN 129 - STROUT(NOUT+1:NOUT+4)='\\276' 130 - INEXT=I+7 131 - NOUT=NOUT+4 132 - ELSEIF(I+6.LE.LEN(STRING).AND. 133 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Â')THEN 134 - STROUT(NOUT+1:NOUT+4)='\\300' 135 - INEXT=I+7 136 - NOUT=NOUT+4 137 - ELSEIF(I+7.LE.LEN(STRING).AND. 138 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'à')THEN 139 - STROUT(NOUT+1:NOUT+4)='\\260' 140 - INEXT=I+8 141 - NOUT=NOUT+4 142 - ELSEIF(I+7.LE.LEN(STRING).AND. 143 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'À')THEN 144 - STROUT(NOUT+1:NOUT+4)='\\265' 145 - INEXT=I+8 146 - NOUT=NOUT+4 147 - ELSEIF(I+6.LE.LEN(STRING).AND. 148 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'å')THEN 149 - STROUT(NOUT+1:NOUT+4)='\\357' 1 165 P=GRAPHICS D=GRTXHIGZ 3 PAGE 266 150 - INEXT=I+7 151 - NOUT=NOUT+4 152 - ELSEIF(I+6.LE.LEN(STRING).AND. 153 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Å')THEN 154 - STROUT(NOUT+1:NOUT+4)='\\362' 155 - INEXT=I+7 156 - NOUT=NOUT+4 157 - ELSEIF(I+5.LE.LEN(STRING).AND. 158 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'ä')THEN 159 - STROUT(NOUT+1:NOUT+4)='\\311' 160 - INEXT=I+6 161 - NOUT=NOUT+4 162 - ELSEIF(I+5.LE.LEN(STRING).AND. 163 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'Ä')THEN 164 - STROUT(NOUT+1:NOUT+4)='\\314' 165 - INEXT=I+6 166 - NOUT=NOUT+4 167 - * Accented letters "c" and "C". 168 - ELSEIF(I+7.LE.LEN(STRING).AND. 169 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'ç')THEN 170 - STROUT(NOUT+1:NOUT+4)='\\321' 171 - INEXT=I+8 172 - NOUT=NOUT+4 173 - ELSEIF(I+7.LE.LEN(STRING).AND. 174 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'Ç')THEN 175 - STROUT(NOUT+1:NOUT+4)='\\322' 176 - INEXT=I+8 177 - NOUT=NOUT+4 178 - * Accented letters "e" and "E". 179 - ELSEIF(I+7.LE.LEN(STRING).AND. 180 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'é')THEN 181 - STROUT(NOUT+1:NOUT+4)='\\323' 182 - INEXT=I+8 183 - NOUT=NOUT+4 184 - ELSEIF(I+7.LE.LEN(STRING).AND. 185 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'É')THEN 186 - STROUT(NOUT+1:NOUT+4)='\\324' 187 - INEXT=I+8 188 - NOUT=NOUT+4 189 - ELSEIF(I+6.LE.LEN(STRING).AND. 190 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'ê')THEN 191 - STROUT(NOUT+1:NOUT+4)='\\327' 192 - INEXT=I+7 193 - NOUT=NOUT+4 194 - ELSEIF(I+6.LE.LEN(STRING).AND. 195 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Ê')THEN 196 - STROUT(NOUT+1:NOUT+4)='\\330' 197 - INEXT=I+7 198 - NOUT=NOUT+4 199 - ELSEIF(I+7.LE.LEN(STRING).AND. 200 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'è')THEN 201 - STROUT(NOUT+1:NOUT+4)='\\325' 202 - INEXT=I+8 203 - NOUT=NOUT+4 204 - ELSEIF(I+7.LE.LEN(STRING).AND. 205 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'È')THEN 206 - STROUT(NOUT+1:NOUT+4)='\\326' 207 - INEXT=I+8 208 - NOUT=NOUT+4 209 - ELSEIF(I+5.LE.LEN(STRING).AND. 210 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'ë')THEN 211 - STROUT(NOUT+1:NOUT+4)='\\331' 212 - INEXT=I+6 213 - NOUT=NOUT+4 214 - ELSEIF(I+5.LE.LEN(STRING).AND. 215 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'Ë')THEN 216 - STROUT(NOUT+1:NOUT+4)='\\332' 217 - INEXT=I+6 218 - NOUT=NOUT+4 219 - * Accented letters "i" and "I". 220 - ELSEIF(I+6.LE.LEN(STRING).AND. 221 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'î')THEN 222 - STROUT(NOUT+1:NOUT+4)='\\333' 223 - INEXT=I+7 224 - NOUT=NOUT+4 225 - ELSEIF(I+6.LE.LEN(STRING).AND. 226 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Î')THEN 227 - STROUT(NOUT+1:NOUT+4)='\\334' 228 - INEXT=I+7 229 - NOUT=NOUT+4 230 - ELSEIF(I+5.LE.LEN(STRING).AND. 231 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'ï')THEN 232 - STROUT(NOUT+1:NOUT+4)='\\335' 233 - INEXT=I+6 234 - NOUT=NOUT+4 235 - ELSEIF(I+5.LE.LEN(STRING).AND. 236 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'Ï')THEN 237 - STROUT(NOUT+1:NOUT+4)='\\336' 238 - INEXT=I+6 239 - NOUT=NOUT+4 240 - * Accented letters "l" and "L". 241 - ELSEIF(I+7.LE.LEN(STRING).AND. 242 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'ł')THEN 243 - STROUT(NOUT+1:NOUT+4)='\\370' 244 - INEXT=I+8 245 - NOUT=NOUT+4 246 - ELSEIF(I+7.LE.LEN(STRING).AND. 247 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'Ł')THEN 248 - STROUT(NOUT+1:NOUT+4)='\\350' 249 - INEXT=I+8 250 - NOUT=NOUT+4 251 - * Accented letters "n" and "N". 252 - ELSEIF(I+7.LE.LEN(STRING).AND. 253 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'ñ')THEN 254 - STROUT(NOUT+1:NOUT+4)='\\337' 255 - INEXT=I+8 1 165 P=GRAPHICS D=GRTXHIGZ 4 PAGE 267 256 - NOUT=NOUT+4 257 - ELSEIF(I+7.LE.LEN(STRING).AND. 258 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'Ñ')THEN 259 - STROUT(NOUT+1:NOUT+4)='\\340' 260 - INEXT=I+8 261 - NOUT=NOUT+4 262 - * Accented letters "o" and "O". 263 - ELSEIF(I+6.LE.LEN(STRING).AND. 264 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'ô')THEN 265 - STROUT(NOUT+1:NOUT+4)='\\342' 266 - INEXT=I+7 267 - NOUT=NOUT+4 268 - ELSEIF(I+6.LE.LEN(STRING).AND. 269 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Ô')THEN 270 - STROUT(NOUT+1:NOUT+4)='\\344' 271 - INEXT=I+7 272 - NOUT=NOUT+4 273 - ELSEIF(I+7.LE.LEN(STRING).AND. 274 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'ø')THEN 275 - STROUT(NOUT+1:NOUT+4)='\\371' 276 - INEXT=I+8 277 - NOUT=NOUT+4 278 - ELSEIF(I+7.LE.LEN(STRING).AND. 279 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'Ø')THEN 280 - STROUT(NOUT+1:NOUT+4)='\\351' 281 - INEXT=I+8 282 - NOUT=NOUT+4 283 - ELSEIF(I+5.LE.LEN(STRING).AND. 284 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'ö')THEN 285 - STROUT(NOUT+1:NOUT+4)='\\345' 286 - INEXT=I+6 287 - NOUT=NOUT+4 288 - ELSEIF(I+5.LE.LEN(STRING).AND. 289 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'Ö')THEN 290 - STROUT(NOUT+1:NOUT+4)='\\346' 291 - INEXT=I+6 292 - NOUT=NOUT+4 293 - * Accented letters "u" and "U". 294 - ELSEIF(I+6.LE.LEN(STRING).AND. 295 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'û')THEN 296 - STROUT(NOUT+1:NOUT+4)='\\347' 297 - INEXT=I+7 298 - NOUT=NOUT+4 299 - ELSEIF(I+6.LE.LEN(STRING).AND. 300 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Û')THEN 301 - STROUT(NOUT+1:NOUT+4)='\\354' 302 - INEXT=I+7 303 - NOUT=NOUT+4 304 - ELSEIF(I+7.LE.LEN(STRING).AND. 305 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'ù')THEN 306 - STROUT(NOUT+1:NOUT+4)='\\374' 307 - INEXT=I+8 308 - NOUT=NOUT+4 309 - ELSEIF(I+7.LE.LEN(STRING).AND. 310 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'Ù')THEN 311 - STROUT(NOUT+1:NOUT+4)='\\375' 312 - INEXT=I+8 313 - NOUT=NOUT+4 314 - ELSEIF(I+5.LE.LEN(STRING).AND. 315 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'ü')THEN 316 - STROUT(NOUT+1:NOUT+4)='\\355' 317 - INEXT=I+6 318 - NOUT=NOUT+4 319 - ELSEIF(I+5.LE.LEN(STRING).AND. 320 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'Ü')THEN 321 - STROUT(NOUT+1:NOUT+4)='\\356' 322 - INEXT=I+6 323 - NOUT=NOUT+4 324 - * Ligatures. 325 - ELSEIF(I+6.LE.LEN(STRING).AND. 326 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'æ')THEN 327 - STROUT(NOUT+1:NOUT+4)='\\361' 328 - INEXT=I+7 329 - NOUT=NOUT+4 330 - ELSEIF(I+6.LE.LEN(STRING).AND. 331 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Æ')THEN 332 - STROUT(NOUT+1:NOUT+4)='\\341' 333 - INEXT=I+7 334 - NOUT=NOUT+4 335 - ELSEIF(I+6.LE.LEN(STRING).AND. 336 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'fi')THEN 337 - STROUT(NOUT+1:NOUT+4)='\\256' 338 - INEXT=I+7 339 - NOUT=NOUT+4 340 - ELSEIF(I+6.LE.LEN(STRING).AND. 341 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'fl')THEN 342 - STROUT(NOUT+1:NOUT+4)='\\257' 343 - INEXT=I+7 344 - NOUT=NOUT+4 345 - ELSEIF(I+6.LE.LEN(STRING).AND. 346 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'œ')THEN 347 - STROUT(NOUT+1:NOUT+4)='\\372' 348 - INEXT=I+7 349 - NOUT=NOUT+4 350 - ELSEIF(I+6.LE.LEN(STRING).AND. 351 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Œ')THEN 352 - STROUT(NOUT+1:NOUT+4)='\\352' 353 - INEXT=I+7 354 - NOUT=NOUT+4 355 - ELSEIF(I+6.LE.LEN(STRING).AND. 356 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'ß')THEN 357 - STROUT(NOUT+1:NOUT+4)='\\373' 358 - INEXT=I+7 359 - NOUT=NOUT+4 360 - * Lower case Greek characters. 361 - ELSEIF(I+6.LE.LEN(STRING).AND. 1 165 P=GRAPHICS D=GRTXHIGZ 5 PAGE 268 362 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'α')THEN 363 - STROUT(NOUT+1:NOUT+3)='[a]' 364 - INEXT=I+7 365 - NOUT=NOUT+3 366 - ELSEIF(I+5.LE.LEN(STRING).AND. 367 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'β')THEN 368 - STROUT(NOUT+1:NOUT+3)='[b]' 369 - INEXT=I+6 370 - NOUT=NOUT+3 371 - ELSEIF(I+4.LE.LEN(STRING).AND. 372 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'η')THEN 373 - STROUT(NOUT+1:NOUT+3)='[c]' 374 - INEXT=I+5 375 - NOUT=NOUT+3 376 - ELSEIF(I+6.LE.LEN(STRING).AND. 377 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'δ')THEN 378 - STROUT(NOUT+1:NOUT+3)='[d]' 379 - INEXT=I+7 380 - NOUT=NOUT+3 381 - ELSEIF(I+8.LE.LEN(STRING).AND. 382 - - STRING(I:MIN(LEN(STRING),I+8)).EQ.'ε')THEN 383 - STROUT(NOUT+1:NOUT+3)='[e]' 384 - INEXT=I+9 385 - NOUT=NOUT+3 386 - ELSEIF(I+4.LE.LEN(STRING).AND. 387 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'φ')THEN 388 - STROUT(NOUT+1:NOUT+3)='[f]' 389 - INEXT=I+5 390 - NOUT=NOUT+3 391 - ELSEIF(I+6.LE.LEN(STRING).AND. 392 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'γ')THEN 393 - STROUT(NOUT+1:NOUT+3)='[g]' 394 - INEXT=I+7 395 - NOUT=NOUT+3 396 - ELSEIF(I+4.LE.LEN(STRING).AND. 397 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'χ')THEN 398 - STROUT(NOUT+1:NOUT+3)='[h]' 399 - INEXT=I+5 400 - NOUT=NOUT+3 401 - ELSEIF(I+5.LE.LEN(STRING).AND. 402 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'ι')THEN 403 - STROUT(NOUT+1:NOUT+3)='[i]' 404 - INEXT=I+6 405 - NOUT=NOUT+3 406 - ELSEIF(I+6.LE.LEN(STRING).AND. 407 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'κ')THEN 408 - STROUT(NOUT+1:NOUT+3)='[k]' 409 - INEXT=I+7 410 - NOUT=NOUT+3 411 - ELSEIF(I+7.LE.LEN(STRING).AND. 412 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'λ')THEN 413 - STROUT(NOUT+1:NOUT+3)='[l]' 414 - INEXT=I+8 415 - NOUT=NOUT+3 416 - ELSEIF(I+3.LE.LEN(STRING).AND. 417 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'μ')THEN 418 - STROUT(NOUT+1:NOUT+3)='[m]' 419 - INEXT=I+4 420 - NOUT=NOUT+3 421 - ELSEIF(I+3.LE.LEN(STRING).AND. 422 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'ν')THEN 423 - STROUT(NOUT+1:NOUT+3)='[n]' 424 - INEXT=I+4 425 - NOUT=NOUT+3 426 - ELSEIF(I+8.LE.LEN(STRING).AND. 427 - - STRING(I:MIN(LEN(STRING),I+8)).EQ.'ο')THEN 428 - STROUT(NOUT+1:NOUT+3)='[o]' 429 - INEXT=I+9 430 - NOUT=NOUT+3 431 - ELSEIF(I+3.LE.LEN(STRING).AND. 432 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'π')THEN 433 - STROUT(NOUT+1:NOUT+3)='[p]' 434 - INEXT=I+4 435 - NOUT=NOUT+3 436 - ELSEIF(I+6.LE.LEN(STRING).AND. 437 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'θ')THEN 438 - STROUT(NOUT+1:NOUT+3)='[q]' 439 - INEXT=I+7 440 - NOUT=NOUT+3 441 - ELSEIF(I+9.LE.LEN(STRING).AND. 442 - - STRING(I:MIN(LEN(STRING),I+9)).EQ.'ϑ')THEN 443 - STROUT(NOUT+1:NOUT+6)='[\\112]' 444 - INEXT=I+10 445 - NOUT=NOUT+6 446 - ELSEIF(I+4.LE.LEN(STRING).AND. 447 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'ρ')THEN 448 - STROUT(NOUT+1:NOUT+3)='[r]' 449 - INEXT=I+5 450 - NOUT=NOUT+3 451 - ELSEIF(I+6.LE.LEN(STRING).AND. 452 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'σ')THEN 453 - STROUT(NOUT+1:NOUT+3)='[s]' 454 - INEXT=I+7 455 - NOUT=NOUT+3 456 - ELSEIF(I+7.LE.LEN(STRING).AND. 457 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'ς')THEN 458 - STROUT(NOUT+1:NOUT+6)='[\\126]' 459 - INEXT=I+8 460 - NOUT=NOUT+6 461 - ELSEIF(I+4.LE.LEN(STRING).AND. 462 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'τ')THEN 463 - STROUT(NOUT+1:NOUT+3)='[t]' 464 - INEXT=I+5 465 - NOUT=NOUT+3 466 - ELSEIF(I+8.LE.LEN(STRING).AND. 467 - - STRING(I:MIN(LEN(STRING),I+8)).EQ.'υ')THEN 1 165 P=GRAPHICS D=GRTXHIGZ 6 PAGE 269 468 - STROUT(NOUT+1:NOUT+3)='[u]' 469 - INEXT=I+9 470 - NOUT=NOUT+3 471 - ELSEIF(I+6.LE.LEN(STRING).AND. 472 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'ω')THEN 473 - STROUT(NOUT+1:NOUT+3)='[w]' 474 - INEXT=I+7 475 - NOUT=NOUT+3 476 - ELSEIF(I+4.LE.LEN(STRING).AND. 477 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'&ksi;')THEN 478 - STROUT(NOUT+1:NOUT+3)='[x]' 479 - INEXT=I+5 480 - NOUT=NOUT+3 481 - ELSEIF(I+4.LE.LEN(STRING).AND. 482 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'ψ')THEN 483 - STROUT(NOUT+1:NOUT+3)='[y]' 484 - INEXT=I+5 485 - NOUT=NOUT+3 486 - ELSEIF(I+5.LE.LEN(STRING).AND. 487 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'ζ')THEN 488 - STROUT(NOUT+1:NOUT+3)='[z]' 489 - INEXT=I+6 490 - NOUT=NOUT+3 491 - * Upper case Greek characters. 492 - ELSEIF(I+6.LE.LEN(STRING).AND. 493 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Α')THEN 494 - STROUT(NOUT+1:NOUT+3)='[A]' 495 - INEXT=I+7 496 - NOUT=NOUT+3 497 - ELSEIF(I+5.LE.LEN(STRING).AND. 498 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'Β')THEN 499 - STROUT(NOUT+1:NOUT+3)='[B]' 500 - INEXT=I+6 501 - NOUT=NOUT+3 502 - ELSEIF(I+4.LE.LEN(STRING).AND. 503 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'Η')THEN 504 - STROUT(NOUT+1:NOUT+3)='[E]' 505 - INEXT=I+5 506 - NOUT=NOUT+3 507 - ELSEIF(I+6.LE.LEN(STRING).AND. 508 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Δ')THEN 509 - STROUT(NOUT+1:NOUT+3)='[D]' 510 - INEXT=I+7 511 - NOUT=NOUT+3 512 - ELSEIF(I+8.LE.LEN(STRING).AND. 513 - - STRING(I:MIN(LEN(STRING),I+8)).EQ.'Ε')THEN 514 - STROUT(NOUT+1:NOUT+3)='[E]' 515 - INEXT=I+9 516 - NOUT=NOUT+3 517 - ELSEIF(I+4.LE.LEN(STRING).AND. 518 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'Φ')THEN 519 - STROUT(NOUT+1:NOUT+3)='[F]' 520 - INEXT=I+5 521 - NOUT=NOUT+3 522 - ELSEIF(I+6.LE.LEN(STRING).AND. 523 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Γ')THEN 524 - STROUT(NOUT+1:NOUT+3)='[G]' 525 - INEXT=I+7 526 - NOUT=NOUT+3 527 - ELSEIF(I+4.LE.LEN(STRING).AND. 528 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'Χ')THEN 529 - STROUT(NOUT+1:NOUT+3)='[H]' 530 - INEXT=I+5 531 - NOUT=NOUT+3 532 - ELSEIF(I+5.LE.LEN(STRING).AND. 533 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'Ι')THEN 534 - STROUT(NOUT+1:NOUT+3)='[I]' 535 - INEXT=I+6 536 - NOUT=NOUT+3 537 - ELSEIF(I+6.LE.LEN(STRING).AND. 538 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Κ')THEN 539 - STROUT(NOUT+1:NOUT+3)='[K]' 540 - INEXT=I+7 541 - NOUT=NOUT+3 542 - ELSEIF(I+7.LE.LEN(STRING).AND. 543 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'Λ')THEN 544 - STROUT(NOUT+1:NOUT+3)='[L]' 545 - INEXT=I+8 546 - NOUT=NOUT+3 547 - ELSEIF(I+3.LE.LEN(STRING).AND. 548 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'Μ')THEN 549 - STROUT(NOUT+1:NOUT+3)='[M]' 550 - INEXT=I+4 551 - NOUT=NOUT+3 552 - ELSEIF(I+3.LE.LEN(STRING).AND. 553 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'Ν')THEN 554 - STROUT(NOUT+1:NOUT+3)='[N]' 555 - INEXT=I+4 556 - NOUT=NOUT+3 557 - ELSEIF(I+8.LE.LEN(STRING).AND. 558 - - STRING(I:MIN(LEN(STRING),I+8)).EQ.'Ο')THEN 559 - STROUT(NOUT+1:NOUT+3)='[O]' 560 - INEXT=I+9 561 - NOUT=NOUT+3 562 - ELSEIF(I+3.LE.LEN(STRING).AND. 563 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'Π')THEN 564 - STROUT(NOUT+1:NOUT+3)='[P]' 565 - INEXT=I+4 566 - NOUT=NOUT+3 567 - ELSEIF(I+6.LE.LEN(STRING).AND. 568 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Θ')THEN 569 - STROUT(NOUT+1:NOUT+3)='[Q]' 570 - INEXT=I+7 571 - NOUT=NOUT+3 572 - ELSEIF(I+4.LE.LEN(STRING).AND. 573 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'Ρ')THEN 1 165 P=GRAPHICS D=GRTXHIGZ 7 PAGE 270 574 - STROUT(NOUT+1:NOUT+3)='[R]' 575 - INEXT=I+5 576 - NOUT=NOUT+3 577 - ELSEIF(I+6.LE.LEN(STRING).AND. 578 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Σ')THEN 579 - STROUT(NOUT+1:NOUT+3)='[S]' 580 - INEXT=I+7 581 - NOUT=NOUT+3 582 - ELSEIF(I+4.LE.LEN(STRING).AND. 583 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'Τ')THEN 584 - STROUT(NOUT+1:NOUT+3)='[T]' 585 - INEXT=I+5 586 - NOUT=NOUT+3 587 - ELSEIF(I+8.LE.LEN(STRING).AND. 588 - - STRING(I:MIN(LEN(STRING),I+8)).EQ.'Υ')THEN 589 - STROUT(NOUT+1:NOUT+3)='[U]' 590 - INEXT=I+9 591 - NOUT=NOUT+3 592 - ELSEIF(I+6.LE.LEN(STRING).AND. 593 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Ω')THEN 594 - STROUT(NOUT+1:NOUT+3)='[W]' 595 - INEXT=I+7 596 - NOUT=NOUT+3 597 - ELSEIF(I+4.LE.LEN(STRING).AND. 598 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'&Ksi;')THEN 599 - STROUT(NOUT+1:NOUT+3)='[X]' 600 - INEXT=I+5 601 - NOUT=NOUT+3 602 - ELSEIF(I+4.LE.LEN(STRING).AND. 603 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'Ψ')THEN 604 - STROUT(NOUT+1:NOUT+3)='[Y]' 605 - INEXT=I+5 606 - NOUT=NOUT+3 607 - ELSEIF(I+5.LE.LEN(STRING).AND. 608 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'Ζ')THEN 609 - STROUT(NOUT+1:NOUT+3)='[Z]' 610 - INEXT=I+6 611 - NOUT=NOUT+3 612 - * Some special symbols. 613 - ELSEIF(I+2.LE.LEN(STRING).AND. 614 - - (STRING(I:MIN(LEN(STRING),I+2)).EQ.'_+-'.OR. 615 - - STRING(I:MIN(LEN(STRING),I+2)).EQ.'_pm'))THEN 616 - STROUT(NOUT+1:NOUT+3)='"A#' 617 - INEXT=I+3 618 - NOUT=NOUT+3 619 - ELSEIF(I+7.LE.LEN(STRING).AND. 620 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'±')THEN 621 - STROUT(NOUT+1:NOUT+6)='"\\261#' 622 - INEXT=I+8 623 - NOUT=NOUT+6 624 - ELSEIF(I+1.LE.LEN(STRING).AND. 625 - - (STRING(I:MIN(LEN(STRING),I+1)).EQ.'<='.OR. 626 - - STRING(I:MIN(LEN(STRING),I+1)).EQ.'=<'))THEN 627 - STROUT(NOUT+1:NOUT+3)='"o#' 628 - INEXT=I+2 629 - NOUT=NOUT+3 630 - ELSEIF(I+1.LE.LEN(STRING).AND. 631 - - (STRING(I:MIN(LEN(STRING),I+1)).EQ.'>='.OR. 632 - - STRING(I:MIN(LEN(STRING),I+1)).EQ.'=>'))THEN 633 - STROUT(NOUT+1:NOUT+3)='"O#' 634 - INEXT=I+2 635 - NOUT=NOUT+3 636 - ELSEIF(I+3.LE.LEN(STRING).AND. 637 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'≤')THEN 638 - STROUT(NOUT+1:NOUT+6)='"\\243#' 639 - INEXT=I+4 640 - NOUT=NOUT+6 641 - ELSEIF(I+3.LE.LEN(STRING).AND. 642 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'<')THEN 643 - STROUT(NOUT+1:NOUT+6)='"\\074#' 644 - INEXT=I+4 645 - NOUT=NOUT+6 646 - ELSEIF(I+3.LE.LEN(STRING).AND. 647 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'≥')THEN 648 - STROUT(NOUT+1:NOUT+6)='"\\263#' 649 - INEXT=I+4 650 - NOUT=NOUT+6 651 - ELSEIF(I+3.LE.LEN(STRING).AND. 652 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'>')THEN 653 - STROUT(NOUT+1:NOUT+6)='"\\076#' 654 - INEXT=I+4 655 - NOUT=NOUT+6 656 - ELSEIF(I+8.LE.LEN(STRING).AND. 657 - - STRING(I:MIN(LEN(STRING),I+8)).EQ.'_integral')THEN 658 - STROUT(NOUT+1:NOUT+3)='"I#' 659 - INEXT=I+9 660 - NOUT=NOUT+3 661 - ELSEIF(I+4.LE.LEN(STRING).AND. 662 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'∫')THEN 663 - STROUT(NOUT+1:NOUT+6)='"\\111#' 664 - INEXT=I+5 665 - NOUT=NOUT+6 666 - ELSEIF(I+5.LE.LEN(STRING).AND. 667 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'&sqrt;')THEN 668 - STROUT(NOUT+1:NOUT+6)='"\\122#' 669 - INEXT=I+6 670 - NOUT=NOUT+6 671 - ELSEIF(I+3.LE.LEN(STRING).AND. 672 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'_sum')THEN 673 - STROUT(NOUT+1:NOUT+3)='[S]' 674 - INEXT=I+4 675 - NOUT=NOUT+3 676 - ELSEIF(I+4.LE.LEN(STRING).AND. 677 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'°')THEN 678 - STROUT(NOUT+1:NOUT+4)='\\312' 679 - INEXT=I+5 1 165 P=GRAPHICS D=GRTXHIGZ 8 PAGE 271 680 - NOUT=NOUT+4 681 - ELSEIF(I+5.LE.LEN(STRING).AND. 682 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.']')THEN 683 - STROUT(NOUT+1:NOUT+4)='\\135' 684 - INEXT=I+6 685 - NOUT=NOUT+4 686 - ELSEIF(I+5.LE.LEN(STRING).AND. 687 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'[')THEN 688 - STROUT(NOUT+1:NOUT+4)='\\133' 689 - INEXT=I+6 690 - NOUT=NOUT+4 691 - ELSEIF(I+6.LE.LEN(STRING).AND. 692 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'×')THEN 693 - STROUT(NOUT+1:NOUT+6)='"\\264#' 694 - INEXT=I+7 695 - NOUT=NOUT+6 696 - ELSEIF(I+7.LE.LEN(STRING).AND. 697 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'$')THEN 698 - STROUT(NOUT+1:NOUT+4)='\\044' 699 - INEXT=I+8 700 - NOUT=NOUT+4 701 - ELSEIF(I+4.LE.LEN(STRING).AND. 702 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'#')THEN 703 - STROUT(NOUT+1:NOUT+4)='\\043' 704 - INEXT=I+5 705 - NOUT=NOUT+4 706 - ELSEIF(I+4.LE.LEN(STRING).AND. 707 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'&')THEN 708 - STROUT(NOUT+1:NOUT+4)='\\046' 709 - INEXT=I+5 710 - NOUT=NOUT+4 711 - ELSEIF(I+7.LE.LEN(STRING).AND. 712 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'@')THEN 713 - STROUT(NOUT+1:NOUT+4)='\\100' 714 - INEXT=I+8 715 - NOUT=NOUT+4 716 - ELSEIF(I+7.LE.LEN(STRING).AND. 717 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'%')THEN 718 - STROUT(NOUT+1:NOUT+4)='\\045' 719 - INEXT=I+8 720 - NOUT=NOUT+4 721 - ELSEIF(I+7.LE.LEN(STRING).AND. 722 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'‰')THEN 723 - STROUT(NOUT+1:NOUT+4)='\\275' 724 - INEXT=I+8 725 - NOUT=NOUT+4 726 - * Punctuation and accents. 727 - ELSEIF(I+5.LE.LEN(STRING).AND. 728 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'!')THEN 729 - STROUT(NOUT+1:NOUT+4)='\\041' 730 - INEXT=I+6 731 - NOUT=NOUT+4 732 - ELSEIF(I+5.LE.LEN(STRING).AND. 733 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.''')THEN 734 - STROUT(NOUT+1:NOUT+4)='\\047' 735 - INEXT=I+6 736 - NOUT=NOUT+4 737 - ELSEIF(I+6.LE.LEN(STRING).AND. 738 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'`')THEN 739 - STROUT(NOUT+1:NOUT+4)='\\301' 740 - INEXT=I+7 741 - NOUT=NOUT+4 742 - ELSEIF(I+6.LE.LEN(STRING).AND. 743 - - STRING(I:MIN(LEN(STRING),I+6)).EQ.'´')THEN 744 - STROUT(NOUT+1:NOUT+4)='\\302' 745 - INEXT=I+7 746 - NOUT=NOUT+4 747 - * Particle names. 748 - ELSEIF(I+8.LE.LEN(STRING).AND. 749 - - STRING(I:MIN(LEN(STRING),I+8)).EQ.'electron-')THEN 750 - STROUT(NOUT+1:NOUT+4)='e^-!' 751 - INEXT=I+9 752 - NOUT=NOUT+4 753 - ELSEIF(I+8.LE.LEN(STRING).AND. 754 - - STRING(I:MIN(LEN(STRING),I+8)).EQ.'electron+')THEN 755 - STROUT(NOUT+1:NOUT+4)='e^+!' 756 - INEXT=I+9 757 - NOUT=NOUT+4 758 - ELSEIF(I+2.LE.LEN(STRING).AND. 759 - - STRING(I:MIN(LEN(STRING),I+2)).EQ.'mu-')THEN 760 - STROUT(NOUT+1:NOUT+6)='[m]^-!' 761 - INEXT=I+3 762 - NOUT=NOUT+6 763 - ELSEIF(I+2.LE.LEN(STRING).AND. 764 - - STRING(I:MIN(LEN(STRING),I+2)).EQ.'mu+')THEN 765 - STROUT(NOUT+1:NOUT+6)='[m]^+!' 766 - INEXT=I+3 767 - NOUT=NOUT+6 768 - ELSEIF(I+3.LE.LEN(STRING).AND. 769 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'tau-')THEN 770 - STROUT(NOUT+1:NOUT+6)='[t]^-!' 771 - INEXT=I+4 772 - NOUT=NOUT+6 773 - ELSEIF(I+3.LE.LEN(STRING).AND. 774 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'tau+')THEN 775 - STROUT(NOUT+1:NOUT+6)='[t]^+!' 776 - INEXT=I+4 777 - NOUT=NOUT+6 778 - ELSEIF(I+2.LE.LEN(STRING).AND. 779 - - STRING(I:MIN(LEN(STRING),I+2)).EQ.'pi-')THEN 780 - STROUT(NOUT+1:NOUT+6)='[p]^-!' 781 - INEXT=I+3 782 - NOUT=NOUT+6 783 - ELSEIF(I+2.LE.LEN(STRING).AND. 784 - - STRING(I:MIN(LEN(STRING),I+2)).EQ.'pi0')THEN 785 - STROUT(NOUT+1:NOUT+6)='[p]^0!' 1 165 P=GRAPHICS D=GRTXHIGZ 9 PAGE 272 786 - INEXT=I+3 787 - NOUT=NOUT+6 788 - ELSEIF(I+2.LE.LEN(STRING).AND. 789 - - STRING(I:MIN(LEN(STRING),I+2)).EQ.'pi+')THEN 790 - STROUT(NOUT+1:NOUT+6)='[p]^+!' 791 - INEXT=I+3 792 - NOUT=NOUT+6 793 - ELSEIF(I+5.LE.LEN(STRING).AND. 794 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'photon')THEN 795 - STROUT(NOUT+1:NOUT+3)='[g]' 796 - INEXT=I+7 797 - NOUT=NOUT+3 798 - * Names of chemical compounds. 799 - ELSEIF(I+2.LE.LEN(STRING).AND. 800 - - STRING(I:MIN(LEN(STRING),I+2)).EQ.'CO2')THEN 801 - STROUT(NOUT+1:NOUT+5)='CO?2!' 802 - INEXT=I+3 803 - NOUT=NOUT+5 804 - ELSEIF(I+2.LE.LEN(STRING).AND. 805 - - STRING(I:MIN(LEN(STRING),I+2)).EQ.'CH4')THEN 806 - STROUT(NOUT+1:NOUT+5)='CH?4!' 807 - INEXT=I+3 808 - NOUT=NOUT+5 809 - ELSEIF(I+4.LE.LEN(STRING).AND. 810 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'CH3OH')THEN 811 - STROUT(NOUT+1:NOUT+7)='CH?3!OH' 812 - INEXT=I+5 813 - NOUT=NOUT+7 814 - ELSEIF(I+2.LE.LEN(STRING).AND. 815 - - STRING(I:MIN(LEN(STRING),I+2)).EQ.'CF4')THEN 816 - STROUT(NOUT+1:NOUT+5)='CF?4!' 817 - INEXT=I+3 818 - NOUT=NOUT+5 819 - ELSEIF(I+2.LE.LEN(STRING).AND. 820 - - STRING(I:MIN(LEN(STRING),I+2)).EQ.'SF6')THEN 821 - STROUT(NOUT+1:NOUT+5)='SF?6!' 822 - INEXT=I+3 823 - NOUT=NOUT+5 824 - ELSEIF(I+2.LE.LEN(STRING).AND. 825 - - STRING(I:MIN(LEN(STRING),I+2)).EQ.'H2O')THEN 826 - STROUT(NOUT+1:NOUT+5)='H?2!O' 827 - INEXT=I+3 828 - NOUT=NOUT+5 829 - ELSEIF(I+2.LE.LEN(STRING).AND. 830 - - STRING(I:MIN(LEN(STRING),I+2)).EQ.'N2O')THEN 831 - STROUT(NOUT+1:NOUT+5)='N?2!O' 832 - INEXT=I+3 833 - NOUT=NOUT+5 834 - ELSEIF(I+3.LE.LEN(STRING).AND. 835 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'C2H6')THEN 836 - STROUT(NOUT+1:NOUT+8)='C?2!H?6!' 837 - INEXT=I+4 838 - NOUT=NOUT+8 839 - ELSEIF(I+3.LE.LEN(STRING).AND. 840 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'C2F6')THEN 841 - STROUT(NOUT+1:NOUT+8)='C?2!F?6!' 842 - INEXT=I+4 843 - NOUT=NOUT+8 844 - ELSEIF(I+5.LE.LEN(STRING).AND. 845 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'C2F4H2')THEN 846 - STROUT(NOUT+1:NOUT+12)='C?2!F?4!H?2!' 847 - INEXT=I+6 848 - NOUT=NOUT+12 849 - ELSEIF(I+5.LE.LEN(STRING).AND. 850 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'C2H2F4')THEN 851 - STROUT(NOUT+1:NOUT+12)='C?2!H?2!F?4!' 852 - INEXT=I+6 853 - NOUT=NOUT+12 854 - ELSEIF(I+5.LE.LEN(STRING).AND. 855 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'C2H5OH')THEN 856 - STROUT(NOUT+1:NOUT+10)='C?2!H?5!OH' 857 - INEXT=I+6 858 - NOUT=NOUT+10 859 - ELSEIF(I+3.LE.LEN(STRING).AND. 860 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'C2H4')THEN 861 - STROUT(NOUT+1:NOUT+8)='C?2!H?4!' 862 - INEXT=I+4 863 - NOUT=NOUT+8 864 - ELSEIF(I+3.LE.LEN(STRING).AND. 865 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'C2H2')THEN 866 - STROUT(NOUT+1:NOUT+8)='C?2!H?2!' 867 - INEXT=I+4 868 - NOUT=NOUT+8 869 - ELSEIF(I+3.LE.LEN(STRING).AND. 870 - - STRING(I:MIN(LEN(STRING),I+3)).EQ.'C3H8')THEN 871 - STROUT(NOUT+1:NOUT+8)='C?3!H?8!' 872 - INEXT=I+4 873 - NOUT=NOUT+8 874 - ELSEIF(I+5.LE.LEN(STRING).AND. 875 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'C3H7OH')THEN 876 - STROUT(NOUT+1:NOUT+10)='C?3!H?7!OH' 877 - INEXT=I+6 878 - NOUT=NOUT+10 879 - ELSEIF(I+4.LE.LEN(STRING).AND. 880 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'C4H10')THEN 881 - STROUT(NOUT+1:NOUT+9)='C?4!H?10!' 882 - INEXT=I+5 883 - NOUT=NOUT+9 884 - ELSEIF(I+4.LE.LEN(STRING).AND. 885 - - STRING(I:MIN(LEN(STRING),I+4)).EQ.'C5H12')THEN 886 - STROUT(NOUT+1:NOUT+9)='C?5!H?12!' 887 - INEXT=I+5 888 - NOUT=NOUT+9 889 - * Units which need special formatting. 890 - ELSEIF(UNIT.AND.I+2.LE.LEN(STRING).AND. 891 - - STRING(I:MIN(LEN(STRING),I+2)).EQ.'cm2')THEN 1 165 P=GRAPHICS D=GRTXHIGZ 10 PAGE 273 892 - STROUT(NOUT+1:NOUT+5)='cm^2!' 893 - INEXT=I+3 894 - NOUT=NOUT+5 895 - ELSEIF(UNIT.AND.I+2.LE.LEN(STRING).AND. 896 - - STRING(I:MIN(LEN(STRING),I+2)).EQ.'cm3')THEN 897 - STROUT(NOUT+1:NOUT+5)='cm^3!' 898 - INEXT=I+3 899 - NOUT=NOUT+5 900 - ELSEIF(UNIT.AND.I+7.LE.LEN(STRING).AND. 901 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'microsec')THEN 902 - STROUT(NOUT+1:NOUT+6)='[m]sec' 903 - INEXT=I+8 904 - NOUT=NOUT+6 905 - ELSEIF(UNIT.AND.I+5.LE.LEN(STRING).AND. 906 - - STRING(I:MIN(LEN(STRING),I+5)).EQ.'micron')THEN 907 - STROUT(NOUT+1:NOUT+4)='[m]m' 908 - INEXT=I+6 909 - NOUT=NOUT+4 910 - ELSEIF(UNIT.AND.I+7.LE.LEN(STRING).AND. 911 - - STRING(I:MIN(LEN(STRING),I+7)).EQ.'microamp')THEN 912 - STROUT(NOUT+1:NOUT+4)='[m]A' 913 - INEXT=I+8 914 - NOUT=NOUT+4 915 - * Now also replace underscores and ampersands that remain. 916 - ELSEIF(STRING(I:I).EQ.'_')THEN 917 - STROUT(NOUT+1:NOUT+3)='"-#' 918 - NOUT=NOUT+3 919 - ELSEIF(STRING(I:I).EQ.'&')THEN 920 - STROUT(NOUT+1:NOUT+3)='"W#' 921 - NOUT=NOUT+3 922 - * Copy all other characters as such. 923 - ELSE 924 - STROUT(NOUT+1:NOUT+1)=STRING(I:I) 925 - NOUT=NOUT+1 926 - ENDIF 927 - 10 CONTINUE 928 - ENDIF 929 - *** Now plot the converted string. 930 - 20 CONTINUE 931 - * Debugging output. 932 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Out: "'',A,''"''/26X, 933 - - ''Plot location: '',2E10.3)') STROUT(1:NOUT),X,Y 934 - * Plot the string. 935 - CALL ITX(X,Y,STROUT(1:NOUT)) 936 - END 166 GARFIELD ================================================== P=GRAPHICS D=GPL2 1 ============================ 0 + +DECK,GPL2. 1 - SUBROUTINE GPL2(N,XPL2,YPL2) 2 - *----------------------------------------------------------------------- 3 - * GPL2 - Routine plotting an array of double precision points. 4 - * (Last changed on 28/ 5/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8 - DOUBLE PRECISION XPL2(*),YPL2(*) 9 - REAL XPL(MXLIST),YPL(MXLIST) 10 - INTEGER N,II,I,NPL 11 - *** Loop over blocks of length MXLIST. 12 - DO 20 II=0,N-2,MXLIST-1 13 - *** Transfer XPL2 and YPL2 (double) to XPL and YPL (single precision). 14 - DO 10 I=1,MIN(N-II,MXLIST) 15 - XPL(I)=REAL(XPL2(II+I)) 16 - YPL(I)=REAL(YPL2(II+I)) 17 - 10 CONTINUE 18 - NPL=MIN(N-II,MXLIST) 19 - *** Plot the line. 20 - IF(NPL.GE.2)CALL GPL(NPL,XPL,YPL) 21 - 20 CONTINUE 22 - END 167 GARFIELD ================================================== P=GRAPHICS D=GRCBIS 1 ============================ 0 + +DECK,GRCBIS. 1 - SUBROUTINE GRCBIS(F,FC,X0,Y0,XL,YL,FL,IL,XR,YR,FR,IR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GRCBIS - Computes a starting point (X0,Y0) for a contour at function 4 - * value FC using bisection between (XL,YL) and (XR,YR). 5 - * (Last changed on 18/ 6/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CONTDATA. 10.- +SEQ,PRINTPLOT. 11 - REAL FC,X0,Y0,F0,X1,Y1,F1,X2,Y2,F2,X3,Y3,F3,XL,YL,FL,XR,YR,FR, 12 - - SCALE,SCALE1,SCALE2,DISC,FTEST1,FTEST2,P1,P2,P3 13 - INTEGER IFAIL,IL,IR,I1,I2,I3,ILOC0,ILOCT1,ILOCT2,IBITER 14 - EXTERNAL F 15 - *** Assume the procedure converges. 16 - IFAIL=0 17 - IF(LDEBUG)WRITE(10,'(1X,A,3E15.8,I3/25X,A,3E15.8,I3,A,E15.8)') 18 - - ' ++++++ GRCBIS DEBUG : Bisection between ', 19 - - XL,YL,FL,IL,' and ',XR,YR,FR,IR,' for F=',FC 20 - *** Make sure that not both points have special ILOCs. 21 - IF(IL.NE.0.AND.IR.NE.0)THEN 22 - WRITE(10,'('' !!!!!! GRCBIS WARNING : Bisection called'', 23 - - '' between 2 ILOC#0 points, ILOC='',2I5)') IL,IR 24 - IFAIL=1 25 - RETURN 26 - ENDIF 27 - *** Set up the bisection and search cycles. 28 - X1=XL 29 - Y1=YL 30 - F1=FL 31 - I1=IL 1 167 P=GRAPHICS D=GRCBIS 2 PAGE 274 32 - X3=XR 33 - Y3=YR 34 - F3=FR 35 - I3=IR 36 - *** In case either of the end points has ILOC/=0, fix range. 37 - IF(I1.NE.0.AND.I3.EQ.0)THEN 38 - DO 20 IBITER=1,NBITER 39 - X2=(X1+X3)/2 40 - Y2=(Y1+Y3)/2 41 - CALL F(X2,Y2,F2,I2) 42 - NFC=NFC+1 43 - IF(I2.EQ.0)THEN 44 - X3=X2 45 - Y3=Y2 46 - F3=F2 47 - I3=I2 48 - ELSE 49 - X1=X2 50 - Y1=Y2 51 - F1=F2 52 - I1=I2 53 - ENDIF 54 - IF((ABS(X3-X1)+ABS(Y3-Y1)).LT. 55 - - 1E-5*(ABS(X1+X3)+ABS(Y1+Y3)))GOTO 30 56 - 20 CONTINUE 57 - 30 CONTINUE 58 - X1=X3 59 - Y1=Y3 60 - F1=F3 61 - I1=I3 62 - X3=XR 63 - Y3=YR 64 - F3=FR 65 - I3=IR 66 - ELSEIF(I1.EQ.0.AND.I3.NE.0)THEN 67 - DO 40 IBITER=1,NBITER 68 - X2=(X1+X3)/2 69 - Y2=(Y1+Y3)/2 70 - CALL F(X2,Y2,F2,I2) 71 - NFC=NFC+1 72 - IF(I2.EQ.0)THEN 73 - X1=X2 74 - Y1=Y2 75 - F1=F2 76 - I1=I2 77 - ELSE 78 - X3=X2 79 - Y3=Y2 80 - F3=F2 81 - I3=I2 82 - ENDIF 83 - IF((ABS(X3-X1)+ABS(Y3-Y1)).LT. 84 - - 1E-5*(ABS(X1+X3)+ABS(Y1+Y3)))GOTO 50 85 - 40 CONTINUE 86 - 50 CONTINUE 87 - X1=XL 88 - Y1=YL 89 - F1=FL 90 - I1=IL 91 - X3=X1 92 - Y3=Y1 93 - F3=F1 94 - I3=I1 95 - ENDIF 96 - *** Iterate the bisection steps. 97 - DO 10 IBITER=1,NBITER 98 - IF(LDEBUG)WRITE(10,'(1X,A,I2)') ' ++++++ GRCBIS DEBUG :'// 99 - - ' Bisection cycle ',IBITER 100 - ** Add one point in the middle, to be used for a parabolic fit. 101 - X2=(X1+X3)/2 102 - Y2=(Y1+Y3)/2 103 - CALL F(X2,Y2,F2,I2) 104 - NFC=NFC+1 105 - IF(LDEBUG)WRITE(10,'(25X,''Middle point: '',2E15.8, 106 - - '', F='',E15.8,'', ILOC='',I5)') X2,Y2,F2,I2 107 - SCALE=-1 108 - ** First attempt to find the parabolic crossing point ... 109 - P1=2*(F1-2*F2+F3) 110 - P2=-3*F1+4*F2-F3 111 - P3=F1-FC 112 - DISC=P2**2-4*P1*P3 113 - * Immediate failure for zero discriminant and degenerate parabola's. 114 - IF(DISC.GE.0.AND.P1.NE.0)THEN 115 - SCALE1=(-P2+SQRT(DISC))/(2*P1) 116 - SCALE2=(-P2-SQRT(DISC))/(2*P1) 117 - IF(LDEBUG)WRITE(10,'(1X,A,2E15.8)') ' ++++++ GRCBIS'// 118 - - ' DEBUG : Parabolic scales: ',SCALE1,SCALE2 119 - * Only the first point is within range. 120 - IF(SCALE1.GE.0.AND.SCALE1.LE.1.AND. 121 - - (SCALE2.LT.0.OR.SCALE2.GT.1))THEN 122 - SCALE=SCALE1 123 - CALL F(X1+SCALE*(X3-X1),Y1+SCALE*(Y3-Y1),F0,ILOC0) 124 - NFC=NFC+1 125 - IF(ILOC0.NE.0)THEN 126 - IFAIL=1 127 - RETURN 128 - ENDIF 129 - IF(LDEBUG)WRITE(10,'(26X,A)') 'Only first satisfies.' 130 - * Only the second point is within range. 131 - ELSEIF(SCALE2.GE.0.0.AND.SCALE2.LE.1.0.AND. 132 - - (SCALE1.LT.0.0.OR.SCALE1.GT.1.0))THEN 133 - SCALE=SCALE2 134 - CALL F(X1+SCALE*(X3-X1),Y1+SCALE*(Y3-Y1),F0,ILOC0) 135 - NFC=NFC+1 136 - IF(ILOC0.NE.0)THEN 137 - IFAIL=1 1 167 P=GRAPHICS D=GRCBIS 3 PAGE 275 138 - RETURN 139 - ENDIF 140 - IF(LDEBUG)WRITE(10,'(26X,A)') 'Only second satisfies.' 141 - * Both are in range, select the one with the best function value. 142 - ELSEIF(SCALE1.GE.0.0.AND.SCALE1.LE.1.0.AND. 143 - - SCALE2.GE.0.0.AND.SCALE2.LE.1.0)THEN 144 - CALL F(X1+SCALE1*(X3-X1),Y1+SCALE1*(Y3-Y1), 145 - - FTEST1,ILOCT1) 146 - CALL F(X1+SCALE2*(X3-X1),Y1+SCALE2*(Y3-Y1), 147 - - FTEST2,ILOCT2) 148 - NFC=NFC+2 149 - IF(ILOCT1.NE.0.OR.ILOCT2.NE.0)THEN 150 - IFAIL=1 151 - RETURN 152 - ENDIF 153 - IF(ABS(FTEST1-FC).LT.ABS(FTEST2-FC))THEN 154 - SCALE=SCALE1 155 - F0=FTEST1 156 - IF(LDEBUG)WRITE(10,'(26X,A,E15.8)') 'First'// 157 - - ' scale gives closest function value: ',F0 158 - ELSE 159 - SCALE=SCALE2 160 - F0=FTEST2 161 - IF(LDEBUG)WRITE(10,'(26X,A,E15.8)') 'Second'// 162 - - ' scale gives closest function value: ',F0 163 - ENDIF 164 - ELSE 165 - SCALE=-1.0 166 - IF(LDEBUG)WRITE(10,'(26X,A)') 'Neither satisfies.' 167 - ENDIF 168 - ENDIF 169 - ** Attempt a linear procedure if the parabolic method failed. 170 - IF((F1.NE.F3).AND.(SCALE.LT.0.0.OR.SCALE.GT.1.0))THEN 171 - SCALE=(FC-F1)/(F3-F1) 172 - CALL F(X1+(X3-X1)*SCALE,Y1+(Y3-Y1)*SCALE,F0,ILOC0) 173 - NFC=NFC+1 174 - IF(ILOC0.NE.0)THEN 175 - IFAIL=1 176 - RETURN 177 - ENDIF 178 - IF(LDEBUG)WRITE(10,'(1X,2(A,E15.8))') ' +++++++ GRCBIS'// 179 - - ' DEBUG : Linear scale = ',SCALE,' F=',F0 180 - ENDIF 181 - ** Now try to insert the new point if it's there at the good place. 182 - IF(SCALE.GE.0.0.AND.SCALE.LE.1.0)THEN 183 - X0=X1+SCALE*(X3-X1) 184 - Y0=Y1+SCALE*(Y3-Y1) 185 - * Presumed crossing between point 1 and the 'optimum'. 186 - IF((F1-FC)*(FC-F0).GE.0.AND.SCALE.LE.0.5)THEN 187 - X3=X0 188 - Y3=Y0 189 - F3=F0 190 - C IF(LDEBUG)WRITE(10,'(26X,A)') 'New edges: 1, opt.' 191 - * Presumed crossing between point 'optimum' and point 2. 192 - ELSEIF((F0-FC)*(FC-F2).GE.0.AND.SCALE.LE.0.5)THEN 193 - X1=X0 194 - Y1=Y0 195 - F1=F0 196 - X3=X2 197 - Y3=Y2 198 - F3=F2 199 - IF(LDEBUG)WRITE(10,'(26X,A)') 'New edges: opt, 2.' 200 - * Presumed crossing between point 2 and the 'optimum'. 201 - ELSEIF((F2-FC)*(FC-F0).GE.0.AND.SCALE.GT.0.5)THEN 202 - X1=X2 203 - Y1=Y2 204 - F1=F2 205 - X3=X0 206 - Y3=Y0 207 - F3=F0 208 - * Presumed crossing between point 'optimum' and point 3. 209 - ELSEIF((F0-FC)*(FC-F3).GE.0.AND.SCALE.GT.0.5)THEN 210 - X1=X0 211 - Y1=Y0 212 - F1=F0 213 - * Elsewhere: failure, fall back on pure bisection. 214 - ELSE 215 - IF(LDEBUG)THEN 216 - WRITE(10,'(1X,A)') ' ++++++ GRCBIS DEBUG :'// 217 - - ' Pure bisection fallback forced'// 218 - - ' because of an unexpected case:' 219 - WRITE(10,'(25X,A,3E15.8)') ' point 1: ',X1,Y1,F1 220 - WRITE(10,'(25X,A,3E15.8)') ' point 2: ',X2,Y2,F2 221 - WRITE(10,'(25X,A,3E15.8)') ' point 3: ',X3,Y3,F3 222 - WRITE(10,'(25X,A,E15.8,A,E15.8)') ' parabola:'// 223 - - ' SCALE=',SCALE,' F=',F0 224 - ENDIF 225 - SCALE=-1.0 226 - ENDIF 227 - ENDIF 228 - ** Pure bisection. 229 - IF(SCALE.LT.0.0.OR.SCALE.GT.1.0)THEN 230 - * Set the new edges. 231 - IF((F1-FC)*(FC-F2).GT.0)THEN 232 - X3=X2 233 - Y3=Y2 234 - F3=F2 235 - ELSE 236 - X1=X2 237 - Y1=Y2 238 - F1=F2 239 - ENDIF 240 - * Compute F0 as the value halfway the interval. 241 - X0=0.5*(X1+X3) 242 - Y0=0.5*(Y1+Y3) 243 - CALL F(X0,Y0,F0,ILOC0) 1 167 P=GRAPHICS D=GRCBIS 4 PAGE 276 244 - NFC=NFC+1 245 - IF(ILOC0.NE.0)THEN 246 - IFAIL=1 247 - RETURN 248 - ENDIF 249 - ENDIF 250 - ** Check for convergence. 251 - IF(ABS(F0-FC).LT.EPSTRA*(1+ABS(FC)))THEN 252 - IF(LDEBUG)WRITE(10,'(1X,A)') ' ++++++ GRCBIS DEBUG :'// 253 - - ' Convergence achieved between F0 and FC at:' 254 - IF(LDEBUG)WRITE(10,'(26X,A,3E15.8)') '(x,y,f) = ',X0,Y0,F0 255 - RETURN 256 - ENDIF 257 - 10 CONTINUE 258 - *** This point is only reached if no convergence ia achieved. 259 - WRITE(10,'(1X,A)') ' !!!!!! GRCBIS WARNING : Bisection'// 260 - - ' didn''t converge.' 261 - IFAIL=1 262 - END 168 GARFIELD ================================================== P=GRAPHICS D=GRCONT 1 ============================ 0 + +DECK,GRCONT. 1 - SUBROUTINE GRCONT(F,FMIN,FMAX,QXMIN,QYMIN,QXMAX,QYMAX, 2 - - NF,AUTO,TRANSF,LABEL) 3 - *----------------------------------------------------------------------- 4 - * GRCONT - Routine plotting contours of the function F in the window 5 - * (XNIN,YMIN) to (XMAX,YMAX) using a grid of NGRIDX+1 by 6 - * NGRIDY+1 points. 7 - * VARIABLES : AUTO : If .TRUE. the scale will be determined 8 - * automatically. 9 - * (Last changed on 28/ 5/98.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,CONTDATA. 14.- +SEQ,PARAMETERS. 15.- +SEQ,PRINTPLOT. 16 - REAL FMIN,FMAX,GRMIN,GRMAX,STEP,X0,Y0,QXMIN,QYMIN,QXMAX,QYMAX, 17 - - XPL,YPL,FC 18 - INTEGER NF,INIT,IX,IY,IF,IFAIL 19 - LOGICAL AUTO,LOOP,TRANSF,LABEL 20 - EXTERNAL F 21 - *** Check the dimensions. 22 - IF(NGRIDX.LE.0.OR.NGRIDX.GT.MXGRID.OR. 23 - - NGRIDY.LE.0.OR.NGRIDY.GT.MXGRID)THEN 24 - WRITE(10,'(1X,A)') ' !!!!!! GRCONT WARNING : Grid'// 25 - - ' dimensions out of range ; contours not plotted.' 26 - RETURN 27 - ENDIF 28 - IF(NF.LT.1)THEN 29 - WRITE(10,'(1X,A)') ' !!!!!! GRCONT WARNING : Number of'// 30 - - ' contours is smaller than 1 ; no contours plotted.' 31 - RETURN 32 - ENDIF 33 - *** Copy the area etc to the local variables. 34 - CXMIN=QXMIN 35 - CXMAX=QXMAX 36 - CYMIN=QYMIN 37 - CYMAX=QYMAX 38 - TRANS=TRANSF 39 - CLAB =LABEL 40 - *** Set gradient step size. 41 - DXGRA=EPSGRA*ABS(CXMAX-CXMIN) 42 - DYGRA=EPSGRA*ABS(CYMAX-CYMIN) 43 - IF(DXGRA.LE.0.OR.DYGRA.LE.0)THEN 44 - WRITE(LUNOUT,'('' !!!!!! GRCONT WARNING : Gradient step'', 45 - - '' size is 0 ; check AREA and !CONTOUR-PARAMETERS.'')') 46 - RETURN 47 - ENDIF 48 - *** Fill the grid. 49 - INIT=0 50 - DO 10 IX=0,NGRIDX 51 - DO 20 IY=0,NGRIDY 52 - CALL F(CXMIN+REAL(IX)*(CXMAX-CXMIN)/REAL(NGRIDX), 53 - - CYMIN+REAL(IY)*(CYMAX-CYMIN)/REAL(NGRIDY), 54 - - GRID(IX,IY),ILOCGR(IX,IY)) 55 - IF(INIT.EQ.0)THEN 56 - GRMAX=GRID(IX,IY) 57 - GRMIN=GRID(IX,IY) 58 - INIT=1 59 - ELSE 60 - IF(GRMIN.GT.GRID(IX,IY))GRMIN=GRID(IX,IY) 61 - IF(GRMAX.LT.GRID(IX,IY))GRMAX=GRID(IX,IY) 62 - ENDIF 63 - 20 CONTINUE 64 - 10 CONTINUE 65 - NFC=(NGRIDX+1)*(NGRIDY+1) 66 - * Verify that a grid range has been set. 67 - IF(INIT.EQ.0)THEN 68 - WRITE(10,'('' !!!!!! GRCONT WARNING : No range found,'', 69 - - '' no contours plotted.'')') 70 - RETURN 71 - * Check the range makes sense if fixed. 72 - ELSEIF((.NOT.AUTO).AND. 73 - - (MAX(FMIN,FMAX).LT.MIN(GRMIN,GRMAX).OR. 74 - - MIN(FMIN,FMAX).GT.MAX(GRMIN,GRMAX)))THEN 75 - WRITE(10,'('' !!!!!! GRCONT WARNING : Specified range ('', 76 - - 2E12.5,'') does not overlap''/26X, 77 - - ''with effective range ('',2E12.5,'').''/ 78 - - 26X,''No contours will be drawn.'')') 79 - - FMIN,FMAX,GRMIN,GRMAX 80 - RETURN 81 - * Optionally fix the scale. 82 - ELSEIF(AUTO)THEN 83 - FMIN=GRMIN 1 168 P=GRAPHICS D=GRCONT 2 PAGE 277 84 - FMAX=GRMAX 85 - IF(GRMIN.EQ.GRMAX)THEN 86 - STEP=0.0 87 - NF=0 88 - ELSE 89 - CALL ROUND(FMIN,FMAX,NF,'SMALLER',STEP) 90 - NF=NINT((FMAX-FMIN)/STEP) 91 - ENDIF 92 - ELSEIF(NF.NE.0)THEN 93 - STEP=(FMAX-FMIN)/REAL(NF) 94 - ELSE 95 - WRITE(10,'('' !!!!!! GRCONT WARNING : Unable to find'', 96 - - '' a contour range ; no contours drawn.'')') 97 - RETURN 98 - ENDIF 99 - IF(LDEBUG)WRITE(10,'(1X,A,2E15.8/26X,A,2E15.8/26X,A,I3/ 100 - - 26X,A,E15.8)') 101 - - ' ++++++ GRCONT DEBUG : Grid function range: ', 102 - - GRMIN,GRMAX,'Contour height range: ',FMIN,FMAX, 103 - - 'Number of contours: ',NF, 104 - - 'Step size : ',STEP 105 - *** Set the attributes for contours. 106 - CALL GRATTS('CONTOUR-NORMAL','POLYLINE') 107 - *** Loop over the contour heights. 108 - DO 100 IF=0,NF 109 - FC=FMIN+REAL(IF)*STEP 110 - IF(FC.GT.FMAX)GOTO 100 111 - IF(LDEBUG)WRITE(10,'(1X,A,E15.8)') ' ++++++ GRCONT DEBUG :'// 112 - - ' Contour height = ',FC 113 - *** Clear the buffers that remember whether a contour was done. 114 - DO 110 IX=0,NGRIDX 115 - DO 120 IY=0,NGRIDY 116 - XDONE(IX,IY)=.FALSE. 117 - YDONE(IX,IY)=.FALSE. 118 - 120 CONTINUE 119 - 110 CONTINUE 120 - *** Check point by point whether there is a contour crossing. 121 - DO 130 IX=0,NGRIDX 122 - DO 140 IY=0,NGRIDY 123 - ** Avoid addressing problems. 124 - IF(IX.GE.NGRIDX)GOTO 150 125 - ** Check in x. 126 - IF((.NOT.XDONE(IX,IY)).AND. 127 - - (ILOCGR(IX,IY).EQ.0.OR.ILOCGR(IX+1,IY).EQ.0).AND. 128 - - (GRID(IX,IY)-FC)*(GRID(IX+1,IY)-FC).LT.0)THEN 129 - IF(LDEBUG)THEN 130 - CALL GSMK(4) 131 - XPL=CXMIN+REAL(IX)*(CXMAX-CXMIN)/REAL(NGRIDX) 132 - YPL=CYMIN+REAL(IY)*(CYMAX-CYMIN)/REAL(NGRIDY) 133 - IF(TRANS)CALL CFMRTC(XPL,YPL,XPL,YPL,1) 134 - CALL GPM(1,XPL,YPL) 135 - WRITE(10,'(1X,A,2E15.8)') ' ++++++ GRCONT DEBUG :'// 136 - - ' Start from an x-segment at ',XPL,YPL 137 - ENDIF 138 - CALL GRCBIS(F,FC,X0,Y0, 139 - - CXMIN+REAL(IX) *(CXMAX-CXMIN)/REAL(NGRIDX), 140 - - CYMIN+REAL(IY) *(CYMAX-CYMIN)/REAL(NGRIDY), 141 - - GRID(IX,IY),ILOCGR(IX,IY), 142 - - CXMIN+REAL(IX+1)*(CXMAX-CXMIN)/REAL(NGRIDX), 143 - - CYMIN+REAL(IY) *(CYMAX-CYMIN)/REAL(NGRIDY), 144 - - GRID(IX+1,IY),ILOCGR(IX+1,IY), 145 - - IFAIL) 146 - IF(IFAIL.EQ.0)THEN 147 - XDONE(IX,IY)=.TRUE. 148 - CALL GRCTRA(F,FC,X0,Y0,-1.0,LOOP) 149 - IF(.NOT.LOOP)CALL GRCTRA(F,FC,X0,Y0,+1.0,LOOP) 150 - ENDIF 151 - ENDIF 152 - ** Avoid addressing problems. 153 - 150 CONTINUE 154 - IF(IY.GE.NGRIDY)GOTO 140 155 - ** And similarly in y. 156 - IF((.NOT.YDONE(IX,IY)).AND. 157 - - (ILOCGR(IX,IY).EQ.0.OR.ILOCGR(IX,IY+1).EQ.0).AND. 158 - - (GRID(IX,IY)-FC)*(GRID(IX,IY+1)-FC).LT.0)THEN 159 - IF(LDEBUG)THEN 160 - CALL GSMK(5) 161 - XPL=CXMIN+REAL(IX)*(CXMAX-CXMIN)/REAL(NGRIDX) 162 - YPL=CYMIN+REAL(IY)*(CYMAX-CYMIN)/REAL(NGRIDY) 163 - IF(TRANS)CALL CFMRTC(XPL,YPL,XPL,YPL,1) 164 - CALL GPM(1,XPL,YPL) 165 - WRITE(10,'(1X,A,2E15.8)') ' ++++++ GRCONT DEBUG :'// 166 - - ' Start from a y-segment at ',XPL,YPL 167 - ENDIF 168 - CALL GRCBIS(F,FC,X0,Y0, 169 - - CXMIN+REAL(IX) *(CXMAX-CXMIN)/REAL(NGRIDX), 170 - - CYMIN+REAL(IY) *(CYMAX-CYMIN)/REAL(NGRIDY), 171 - - GRID(IX,IY),ILOCGR(IX,IY), 172 - - CXMIN+REAL(IX) *(CXMAX-CXMIN)/REAL(NGRIDX), 173 - - CYMIN+REAL(IY+1)*(CYMAX-CYMIN)/REAL(NGRIDY), 174 - - GRID(IX,IY+1),ILOCGR(IX,IY+1), 175 - - IFAIL) 176 - IF(IFAIL.EQ.0)THEN 177 - YDONE(IX,IY)=.TRUE. 178 - CALL GRCTRA(F,FC,X0,Y0,-1.0,LOOP) 179 - IF(.NOT.LOOP)CALL GRCTRA(F,FC,X0,Y0,+1.0,LOOP) 180 - ENDIF 181 - ENDIF 182 - 140 CONTINUE 183 - 130 CONTINUE 184 - *** Next contour height. 185 - 100 CONTINUE 186 - END 1 169 GARFIELD ================================================== P=GRAPHICS D=GRCGRA 1 =================== PAGE 278 0 + +DECK,GRCGRA. 1 - SUBROUTINE GRCGRA(F,XX,YY,DFDX,DFDY,IOPT1,IOPT2,IFLAG) 2 - *----------------------------------------------------------------------- 3 - * GRCGRA - Calculates the (normalised) gradient of F at (XX,YY). 4 - * VARIABLES : IOPT1 : If 0, the normal gradient is returned, 5 - * if 1, the orthognal gradient. 6 - * IOPT2 : If 0, no normalisation, if 1 normalisation 7 - * on one grid length along the gradient. 8 - * (Last changed on 22/ 6/98.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CONTDATA. 13.- +SEQ,PARAMETERS. 14 - REAL XX,YY,DFDX,DFDY,AUX,DFNORM,FXP,FXM,FYP,FYM,FM 15 - INTEGER IOPT1,IOPT2,ILOCXM,ILOCXP,ILOCYP,ILOCYM,ILOCM,IFLAG 16 - EXTERNAL F 17 - *** Preset flag to 0: free point, change to 1 if needed. 18 - IFLAG=0 19 - *** Function evaluation for the symmetric gradient. 20 - CALL F(XX+DXGRA,YY,FXP,ILOCXP) 21 - CALL F(XX-DXGRA,YY,FXM,ILOCXM) 22 - CALL F(XX,YY+DYGRA,FYP,ILOCYP) 23 - CALL F(XX,YY-DYGRA,FYM,ILOCYM) 24 - NFC=NFC+4 25 - * If one or more points are special, try asymmetric gradients. 26 - IF((ILOCXP.EQ.0.AND.ILOCXM.NE.0).OR. 27 - - (ILOCXP.NE.0.AND.ILOCXM.EQ.0).OR. 28 - - (ILOCYP.EQ.0.AND.ILOCYM.NE.0).OR. 29 - - (ILOCYP.NE.0.AND.ILOCYM.EQ.0))THEN 30 - CALL F(XX,YY,FM,ILOCM) 31 - NFC=NFC+1 32 - ELSE 33 - FM=0 34 - ILOCM=-1 35 - ENDIF 36 - *** Compute the symmetric x-gradient if this is possible. 37 - IF(ILOCXP.EQ.0.AND.ILOCXM.EQ.0)THEN 38 - DFDX=(FXP-FXM)/(2*DXGRA) 39 - * Abandon if there is no hope. 40 - ELSEIF(ILOCM.NE.0)THEN 41 - DFDX=0 42 - IFLAG=1 43 - * Take the +assymetric gradient. 44 - ELSEIF(ILOCXP.EQ.0)THEN 45 - DFDX=(FXP-FM)/DXGRA 46 - * Take the -assymetric gradient. 47 - ELSEIF(ILOCXM.EQ.0)THEN 48 - DFDX=(FM-FXM)/DXGRA 49 - ELSE 50 - WRITE(10,'('' !!!!!! GRCGRA WARNING : Unexpected case'', 51 - - '' computing an x-gradient.'')') 52 - IFLAG=1 53 - ENDIF 54 - *** Compute the symmetric y-gradient if this is possible. 55 - IF(ILOCYP.EQ.0.AND.ILOCYM.EQ.0)THEN 56 - DFDY=(FYP-FYM)/(2*DYGRA) 57 - * Abandon if there is no hope. 58 - ELSEIF(ILOCM.NE.0)THEN 59 - DFDY=0 60 - IFLAG=1 61 - * Take the +assymetric gradient. 62 - ELSEIF(ILOCYP.EQ.0)THEN 63 - DFDY=(FYP-FM)/DYGRA 64 - * Take the -assymetric gradient. 65 - ELSEIF(ILOCYM.EQ.0)THEN 66 - DFDY=(FM-FYM)/DYGRA 67 - ELSE 68 - WRITE(10,'('' !!!!!! GRCGRA WARNING : Unexpected case'', 69 - - '' computing a y-gradient.'')') 70 - IFLAG=1 71 - ENDIF 72 - *** Check the flag. 73 - IF(IFLAG.NE.0)THEN 74 - DFDX=0 75 - DFDY=0 76 - RETURN 77 - ENDIF 78 - *** Check for a zero gradient for other reasons. 79 - IF(DFDX**2+DFDY**2.EQ.0)RETURN 80 - *** Reverse the gradient in case of IOPT1=1. 81 - IF(IOPT1.EQ.1)THEN 82 - AUX=DFDX 83 - DFDX=-DFDY 84 - DFDY=AUX 85 - ENDIF 86 - *** Normalise the gradient to one grid unit if IOPT2=1. 87 - IF(IOPT2.EQ.1)THEN 88 - DFNORM=SQRT(((DFDX*REAL(NGRIDX))/(CXMAX-CXMIN))**2+ 89 - - ((DFDY*REAL(NGRIDY))/(CYMAX-CYMIN))**2) 90 - DFDX=DFDX/DFNORM 91 - DFDY=DFDY/DFNORM 92 - ENDIF 93 - END 170 GARFIELD ================================================== P=GRAPHICS D=GRCLAB 1 ============================ 0 + +DECK,GRCLAB. 1 - SUBROUTINE GRCLAB(NPL,XPL,YPL,FC) 2 - *----------------------------------------------------------------------- 3 - * GRCLAB - Plots the contour and adds labels if requested. 4 - * (Last changed on 16/ 5/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 1 170 P=GRAPHICS D=GRCLAB 2 PAGE 279 8.- +SEQ,CONTDATA. 9 - REAL XPL(*),YPL(*),WINDOW(4),VIEWPT(4),XBOX(5),YBOX(5),FC, 10 - - TXTLEN,CHH,CPX,CPY 11 - INTEGER NPL,IWK,NTOLD,ITXALH,ITXALV,IERR,IERR1,IERR2,I,NC, 12 - - IMID,ITXT 13 - CHARACTER*20 TEXT 14 - *** Skip label plotting if not requested. 15 - IF(.NOT.CLAB)THEN 16 - CALL GPL(NPL,XPL,YPL) 17 - RETURN 18 - ENDIF 19 - *** Label plotting, set workstation to 1 (only one workstation). 20 - IWK=1 21 - NTOLD=-1 22 - ITXALH=-1 23 - ITXALV=-1 24 - * Transform the curve to NT=0. 25 - CALL GQCNTN(IERR1,NTOLD) 26 - CALL GQNT(NTOLD,IERR2,WINDOW,VIEWPT) 27 - IF(IERR1.NE.0.OR.IERR2.NE.0.OR.WINDOW(1).EQ.WINDOW(2).OR. 28 - - WINDOW(3).EQ.WINDOW(4))THEN 29 - WRITE(10,'('' !!!!!! GRCLAB WARNING : Window/viewport/nt'', 30 - - '' inquiry failed, IERR='',2I3)') IERR1,IERR2 31 - GOTO 1000 32 - ENDIF 33 - DO 10 I=1,NPL 34 - XPL(I)=(XPL(I)-WINDOW(1))/(WINDOW(2)-WINDOW(1)) 35 - YPL(I)=(YPL(I)-WINDOW(3))/(WINDOW(4)-WINDOW(3)) 36 - 10 CONTINUE 37 - CALL GSELNT(0) 38 - * Set the attributes of the contour labels. 39 - CALL GRATTS('CONTOUR-LABELS','TEXT') 40 - * Format the label. 41 - CALL OUTFMT(FC,2,TEXT,NC,'LEFT') 42 - * Compute horizontal length of the text. 43 - CALL GSCHUP(0.0,1.0) 44 - CALL GQTXAL(IERR,ITXALH,ITXALV) 45 - IF(IERR.NE.0)THEN 46 - WRITE(10,'('' !!!!!! GRCLAB WARNING : Text alignments'', 47 - - '' inquiry failed, IERR='',I3)') IERR 48 - GOTO 1000 49 - ENDIF 50 - CALL GSTXAL(2,3) 51 - CALL GQTXX(IWK,0.5,0.5,TEXT(1:NC),IERR,CPX,CPY,XBOX,YBOX) 52 - IF(IERR.EQ.0)THEN 53 - TXTLEN=MAX(MAX(XBOX(1),XBOX(2),XBOX(3),XBOX(4))- 54 - - MIN(XBOX(1),XBOX(2),XBOX(3),XBOX(4)), 55 - - MAX(YBOX(1),YBOX(2),YBOX(3),YBOX(4))- 56 - - MIN(YBOX(1),YBOX(2),YBOX(3),YBOX(4))) 57 - ELSE 58 - CALL GQCHW(IERR,CHH) 59 - IF(IERR.NE.0)CALL GQCHH(IERR,CHH) 60 - IF(IERR.NE.0)CHH=0.01 61 - TXTLEN=NC*CHH 62 - ENDIF 63 - * Make the space a bit bigger to make the label more legible. 64 - TXTLEN=TXTLEN*1.1 65 - * Determine a piece of the curve that will hold the text. 66 - IMID=NPL/2 67 - DO 20 I=1,IMID 68 - IF(IMID-I.LE.0.OR.IMID+I.GT.NPL)GOTO 20 69 - IF((XPL(IMID-I)-XPL(IMID+I))**2+ 70 - - (YPL(IMID-I)-YPL(IMID+I))**2.GT.TXTLEN**2)THEN 71 - ITXT=I 72 - GOTO 30 73 - ENDIF 74 - 20 CONTINUE 75 - GOTO 1000 76 - * Plot the text. 77 - 30 CONTINUE 78 - IF(XPL(IMID+ITXT)-XPL(IMID-ITXT).LT.0.0.AND. 79 - - YPL(IMID-ITXT)-YPL(IMID+ITXT).LT.0.0)THEN 80 - CALL GSCHUP(YPL(IMID+ITXT)-YPL(IMID-ITXT), 81 - - XPL(IMID-ITXT)-XPL(IMID+ITXT)) 82 - ELSE 83 - CALL GSCHUP(YPL(IMID-ITXT)-YPL(IMID+ITXT), 84 - - XPL(IMID+ITXT)-XPL(IMID-ITXT)) 85 - ENDIF 86 - CALL GRTX((XPL(IMID-ITXT)+XPL(IMID+ITXT))/2.0, 87 - - (YPL(IMID-ITXT)+YPL(IMID+ITXT))/2.0,TEXT(1:NC)) 88 - * Plot the two line segments. 89 - IF(IMID-ITXT.GE.2)CALL GPL(IMID-ITXT,XPL,YPL) 90 - IF(NPL-IMID-ITXT+1.GE.2)CALL GPL(NPL-IMID-ITXT+1, 91 - - XPL(IMID+ITXT),YPL(IMID+ITXT)) 92 - * Restore the old situation. 93 - IF(NTOLD.GE.0)CALL GSELNT(NTOLD) 94 - IF(ITXALH.GE.0.AND.ITXALV.GE.0)CALL GSTXAL(ITXALH,ITXALV) 95 - CALL GSCHUP(0.0,1.0) 96 - RETURN 97 - *** Simple line drawing. 98 - 1000 CONTINUE 99 - CALL GPL(NPL,XPL,YPL) 100 - * Restore the old situation. 101 - IF(NTOLD.GE.0)CALL GSELNT(NTOLD) 102 - IF(ITXALH.GE.0.AND.ITXALV.GE.0)CALL GSTXAL(ITXALH,ITXALV) 103 - CALL GSCHUP(0.0,1.0) 104 - END 171 GARFIELD ================================================== P=GRAPHICS D=GRCMIN 1 ============================ 0 + +DECK,GRCMIN. 1 - SUBROUTINE GRCMIN(IX,IY,XX0,YY0,XX1,YY1,DIST,IFLAG) 2 - *----------------------------------------------------------------------- 3 - * GRCMIN - Minimizes the distance between a line segment and a point. 4 - * VARIABLES: (IX,IY) : Coordinates of the grid point. 5 - * (X0,Y0)-(X1,Y1): The line segment. 1 171 P=GRAPHICS D=GRCMIN 2 PAGE 280 6 - * IFLAG : -1 minimum is located before (X0,Y0), 7 - * 0 " " " at an interior point, 8 - * +1 " " " behind (X1,Y1). 9 - * XINP0,XINP1 : Inner products. 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,PARAMETERS. 13.- +SEQ,CONTDATA. 14 - INTEGER IFLAG 15 - *** Calculate the normalised positions. 16 - XW=REAL(IX) 17 - YW=REAL(IY) 18 - X0=(XX0-CXMIN)*REAL(NGRIDX)/(CXMAX-CXMIN) 19 - Y0=(YY0-CYMIN)*REAL(NGRIDY)/(CYMAX-CYMIN) 20 - X1=(XX1-CXMIN)*REAL(NGRIDX)/(CXMAX-CXMIN) 21 - Y1=(YY1-CYMIN)*REAL(NGRIDY)/(CYMAX-CYMIN) 22 - *** Compute the step length and check it is non-zero. 23 - STEP2=(X1-X0)**2+(Y1-Y0)**2 24 - *** Check these two are non-zero. 25 - IF(STEP2.LE.0.0)THEN 26 - IFLAG=0 27 - DIST=SQRT((XW-X0)**2+(YW-Y0)**2) 28 - RETURN 29 - ENDIF 30 - *** Find the precise location of the smallest distance. 31 - XINP0=((X1-X0)*(XW-X0)+(Y1-Y0)*(YW-Y0)) 32 - XINP1=((X0-X1)*(XW-X1)+(Y0-Y1)*(YW-Y1)) 33 - IF(XINP0.LT.0.0D0)THEN 34 - IFLAG=-1 35 - DIST2=(XW-X0)**2+(YW-Y0)**2 36 - ELSEIF(XINP1.LT.0.0D0)THEN 37 - IFLAG=+1 38 - DIST2=(XW-X1)**2+(YW-Y1)**2 39 - ELSEIF(XINP1**2*((XW-X0)**2+(YW-Y0)**2).GT. 40 - - XINP0**2*((XW-X1)**2+(YW-Y1)**2))THEN 41 - IFLAG=0 42 - DIST2=(XW-X0)**2+(YW-Y0)**2-XINP0**2/STEP2 43 - ELSE 44 - IFLAG=0 45 - DIST2=(XW-X1)**2+(YW-Y1)**2-XINP1**2/STEP2 46 - ENDIF 47 - *** Take the square root of the distance. 48 - DIST=SQRT(MAX(0.0,DIST2)) 49 - END 172 GARFIELD ================================================== P=GRAPHICS D=GRCPLT 1 ============================ 0 + +DECK,GRCPLT. 1 - SUBROUTINE GRCPLT(XX,YY,FC,OPTION) 2 - *----------------------------------------------------------------------- 3 - * GRCPLT - Buffers and plot contours. 4 - * VARIABLES : OPTION : If 'INIT' resets the buffer and stores, 5 - * if 'ADD' adds the point to the buffer 6 - * plotting the buffer if its is full, 7 - * if 'PLOT' empties the buffer. 8 - * (XX,YY) : New point, ignored if OPTION='PLOT' 9 - * (Last changed on 18/10/93.) 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,PARAMETERS. 13.- +SEQ,CONTDATA. 14 - PARAMETER (MXCBUF=100) 15 - CHARACTER*(*) OPTION 16 - REAL XPL(MXCBUF),YPL(MXCBUF) 0 17-+ +SELF,IF=SAVE. 18 - SAVE INIT,NPL,XPL,YPL 0 19-+ +SELF. 20 - DATA INIT/0/,NPL/0/ 21 - *** Initialisation. 22 - IF(OPTION.EQ.'INIT')THEN 23 - NPL=1 24 - XPL(NPL)=XX 25 - YPL(NPL)=YY 26 - INIT=1 27 - *** Add a new point. 28 - ELSEIF(OPTION.EQ.'ADD')THEN 29 - * Check buffer state. 30 - IF(INIT.NE.1)THEN 31 - WRITE(10,'(1X,A)') ' !!!!!! GRCPLT WARNING : Buffer'// 32 - - ' not in the proper state ; program bug.' 33 - RETURN 34 - ENDIF 35 - * Check whether further points can be added, plot if not. 36 - IF(NPL.GE.MXCBUF)THEN 37 - IF(NPL.GE.2)THEN 38 - XTEMP=XPL(NPL) 39 - YTEMP=YPL(NPL) 40 - IF(TRANS)CALL CFMRTC(XPL,YPL,XPL,YPL,NPL) 41 - CALL GRCLAB(NPL,XPL,YPL,FC) 42 - XPL(NPL)=XTEMP 43 - YPL(NPL)=YTEMP 44 - ENDIF 45 - XPL(1)=XPL(NPL) 46 - YPL(1)=YPL(NPL) 47 - NPL=1 48 - ENDIF 49 - * Add the point top the buffer. 50 - NPL=NPL+1 51 - XPL(NPL)=XX 52 - YPL(NPL)=YY 53 - *** Plot the buffer if the option is 'PLOT'. 54 - ELSEIF(OPTION.EQ.'PLOT')THEN 55 - IF(NPL.GE.2)THEN 56 - IF(TRANS)CALL CFMRTC(XPL,YPL,XPL,YPL,NPL) 1 172 P=GRAPHICS D=GRCPLT 2 PAGE 281 57 - CALL GRCLAB(NPL,XPL,YPL,FC) 58 - ENDIF 59 - INIT=0 60 - *** Only 'DUMP', used in case of irrecoverable errors. 61 - ELSEIF(OPTION.EQ.'DUMP')THEN 62 - IF(NPL.GE.2)THEN 63 - IF(TRANS)CALL CFMRTC(XPL,YPL,XPL,YPL,NPL) 64 - CALL GRCLAB(NPL,XPL,YPL,FC) 65 - ENDIF 66 - INIT=0 67 - *** Unknown option. 68 - ELSE 69 - WRITE(10,'(1X,A)') ' !!!!!! GRCPLT WARNING : Unknown'// 70 - - ' option "',OPTION,'" ; nothing done - program bug.' 71 - ENDIF 72 - END 173 GARFIELD ================================================== P=GRAPHICS D=GRCTRA 1 ============================ 0 + +DECK,GRCTRA. 1 - SUBROUTINE GRCTRA(F,FC,XST,YST,DIR,LOOP) 2 - *----------------------------------------------------------------------- 3 - * GRCTRA - Traces a contour of F at function value FC starting from 4 - * (XST,YST). The tracing method iterates in two stages (1) a 5 - * side step orthogonal to the gradient (2) a Newton-Raphson 6 - * stepping back to the contour. Conditions that can cause 7 - * termination include (1) leaving the plotting area (2) the 8 - * contour is back at its origin ... 9 - * VARIABLES : LOOP : Is set to .TRUE. if a full loop is found. 10 - * (Last changed on 18/10/93.) 11 - *----------------------------------------------------------------------- 12.- +SEQ,DIMENSIONS. 13.- +SEQ,CONTDATA. 14.- +SEQ,PRINTPLOT. 15 - REAL FC,XST,YST,DIR,X0,Y0,X1,Y1,X2,Y2 16 - LOGICAL CROSS,LOOP 17 - EXTERNAL F,CROSS 18 - *** Initialise plotting of this contour fragment. 19 - CALL GRCPLT(XST,YST,FC,'INIT') 20 - CALL GRCUPD(F,XST,YST,FC,'START',IFLAG) 21 - LOOP=.FALSE. 22 - *** Store a small segment that will be used to catch circular contours. 23 - CALL GRCGRA(F,XST,YST,DFDX,DFDY,0,1,IFLGST) 24 - * Check initial position. 25 - IF(IFLGST.NE.0)THEN 26 - IF(LDEBUG)WRITE(10,'('' ++++++ GRCTRA DEBUG : Initial'', 27 - - '' point has non-zero gradient flag: '',I3)') IFLGST 28 - RETURN 29 - ENDIF 30 - * Gradient calculated successfully, store the segment. 31 - XSEG1=XST-DFDX*STINIT 32 - YSEG1=YST-DFDY*STINIT 33 - XSEG2=XST+DFDX*STINIT 34 - YSEG2=YST+DFDY*STINIT 35 - *** Initialise the previous step, used from step 2 onwards. 36 - XL=XST 37 - YL=YST 38 - *** Initialise stepping. 39 - H=STINIT 40 - X0=XST 41 - Y0=YST 42 - *** Start of the stepping procedure. 43 - ISTEP=0 44 - 100 CONTINUE 45 - ISTEP=ISTEP+1 46 - *** Step to the side orthogonal to the gradient. 47 - CALL GRCGRA(F,X0,Y0,DFDX,DFDY,1,1,IFLG0) 48 - IF(IFLG0.NE.0)GOTO 3010 49 - IF(DFDX**2+DFDY**2.LE.0)GOTO 3000 50 - X1=X0+DIR*DFDX*H 51 - Y1=Y0+DIR*DFDY*H 52 - *** Newton-Raphson step back to the contour following the gradient. 53 - X2=X1 54 - Y2=Y1 55 - CALL F(X2,Y2,F2,ILOC2) 56 - NFC=NFC+1 57 - DO 10 INITER=1,NNITER 58 - CALL GRCGRA(F,X2,Y2,DFDX,DFDY,0,0,IFLG2) 59 - DFNORM=DFDX**2+DFDY**2 60 - IF(IFLG2.NE.0)GOTO 3010 61 - IF(DFNORM.LE.0.0)GOTO 3000 62 - X2=X2+DFDX*(FC-F2)/DFNORM 63 - Y2=Y2+DFDY*(FC-F2)/DFNORM 64 - CALL F(X2,Y2,F2,ILOC2) 65 - NFC=NFC+1 66 - IF(LDEBUG)WRITE(10,'(1X,A,I3,A,I2,A,3E15.8)') 67 - - ' ++++++ GRCTRA DEBUG : Step ',ISTEP,' Newton iteration ', 68 - - INITER,' leads to (x,y,f) = ',X2,Y2,F2 69 - IF(ABS(F2-FC).LE.EPSTRA*(1.0+ABS(FC)))THEN 70 - IF(LDEBUG)WRITE(10,'(1X,A,I2,A)') 71 - - ' ++++++ GRCTRA DEBUG : Newton search converged'// 72 - - ' at step ',INITER,'.' 73 - GOTO 20 74 - ENDIF 75 - 10 CONTINUE 76 - WRITE(10,'(1X,A)') ' !!!!!! GRCTRA WARNING : Newton search'// 77 - - ' didn''t converge ; tracing terminated.' 78 - CALL GRCPLT(X2,Y2,FC,'PLOT') 79 - RETURN 80 - 20 CONTINUE 81 - *** Update the stepsize. 82 - *** Check whether we are leaving the box. 83 - IF(X2.LE.CXMIN.OR.X2.GE.CXMAX.OR.Y2.LE.CYMIN.OR.Y2.GE.CYMAX)THEN 84 - CALL CLIP(X0,Y0,X2,Y2,CXMIN,CYMIN,CXMAX,CYMAX,IFAIL) 85 - CALL GRCPLT(X2,Y2,FC,'ADD') 86 - CALL GRCPLT(X2,Y2,FC,'PLOT') 1 173 P=GRAPHICS D=GRCTRA 2 PAGE 282 87 - IFLAG=0 88 - IF(X2.LE.CXMIN)IFLAG=IFLAG+1 89 - IF(X2.GE.CXMAX)IFLAG=IFLAG+2 90 - IF(Y2.LE.CYMIN)IFLAG=IFLAG+4 91 - IF(Y2.GE.CYMAX)IFLAG=IFLAG+8 92 - CALL GRCUPD(F,X2,Y2,FC,'EDGE,END',IFLAG) 93 - IF(LDEBUG)WRITE(10,'(1X,A,I3,A,2E15.8)') 94 - - ' ++++++ GRCTRA DEBUG : Contour leaves area, step ', 95 - - ISTEP,' tracing ended at ',X2,Y2 96 - RETURN 97 - ENDIF 98 - *** Check whether we have a full circle. 99 - IF(ISTEP.GT.1.AND.CROSS(X0,Y0,X2,Y2,XSEG1,YSEG1,XSEG2,YSEG2))THEN 100 - CALL GRCPLT(X2,Y2,FC,'ADD') 101 - CALL GRCPLT(X2,Y2,FC,'PLOT') 102 - CALL GRCUPD(F,X2,Y2,FC,'LOOP,END',IFLAG) 103 - IF(LDEBUG)WRITE(10,'(1X,A,I3,A,2E15.8)') 104 - - ' ++++++ GRCTRA DEBUG : Full loop detected at step ', 105 - - ISTEP,' tracing ended at ',X2,Y2 106 - LOOP=.TRUE. 107 - RETURN 108 - ENDIF 109 - *** Make sure to avoid going back and forth, e.g. on a saddle point. 110 - IF(ISTEP.GT.1.AND.(X2-X0)*(X0-XL)+(Y2-Y0)*(Y0-YL).LT.0)THEN 111 - CALL GRCPLT(X2,Y2,FC,'DUMP') 112 - CALL GRCUPD(F,X2,Y2,FC,'TURN,END',IFLAG) 113 - IF(LDEBUG)WRITE(10,'(1X,A,I3,A,2E15.8)') 114 - - ' ++++++ GRCTRA DEBUG : Attempt to turn at step ', 115 - - ISTEP,' tracing ended at ',X2,Y2 116 - RETURN 117 - ENDIF 118 - *** Check the number of steps. 119 - IF(ISTEP.GT.NGCMAX)THEN 120 - WRITE(10,'(1X,A)') ' !!!!!! GRCTRA WARNING : Maximum'// 121 - - ' number of steps reached, contour abandoned.' 122 - CALL GRCPLT(X2,Y2,FC,'ADD') 123 - CALL GRCPLT(X2,Y2,FC,'PLOT') 124 - CALL GRCUPD(F,X2,Y2,FC,'MAX,END',IFLAG) 125 - RETURN 126 - ENDIF 127 - *** Check we didn't miss a grid point. 128 - *** Add the point to the plotting buffer. 129 - XL=X0 130 - YL=Y0 131 - X0=X2 132 - Y0=Y2 133 - CALL GRCPLT(X0,Y0,FC,'ADD') 134 - CALL GRCUPD(F,X0,Y0,FC,'AREA',IFLAG) 135 - IF(IFLAG.NE.0)THEN 136 - IF(LDEBUG)WRITE(10,'(1X,A)') ' ++++++ GRCTRA DEBUG :'// 137 - - ' GRCUPD has raised IFLAG ; tracing abandoned.' 138 - RETURN 139 - ENDIF 140 - *** New step. 141 - GOTO 100 142 - *** Errors. 143 - 3000 CONTINUE 144 - CALL GRCPLT(X2,Y2,FC,'DUMP') 145 - WRITE(10,'(1X,A,I3,A)') ' !!!!!! GRCTRA WARNING : Zero'// 146 - - ' gradient at step ',ISTEP,'; tracing terminated.' 147 - RETURN 148 - 3010 CONTINUE 149 - CALL GRCPLT(X2,Y2,FC,'DUMP') 150 - WRITE(10,'(1X,A,I3,A)') ' !!!!!! GRCTRA WARNING : Stepped'// 151 - - ' into forbidden zone, step ',ISTEP,'; tracing terminated.' 152 - END 174 GARFIELD ================================================== P=GRAPHICS D=GRCUPD 1 ============================ 0 + +DECK,GRCUPD. 1 - SUBROUTINE GRCUPD(F,X1,Y1,FC,STATUS,IFLAG) 2 - *----------------------------------------------------------------------- 3 - * GRCUPD - Updates the grid for the contour segment (XPL,YPL). 4 - *----------------------------------------------------------------------- 5.- +SEQ,DIMENSIONS. 6.- +SEQ,CONTDATA. 7.- +SEQ,PARAMETERS. 8.- +SEQ,PRINTPLOT. 9 - LOGICAL CROSS 10 - CHARACTER*(*) STATUS 11 - EXTERNAL CROSS,F 12 - INTEGER INIT 0 13-+ +SELF,IF=SAVE. 14 - SAVE INIT,X0,Y0 0 15-+ +SELF. 16 - DATA INIT/0/ 17 - *** Check and set of the initialisation flag, first the start. 18 - IF(INDEX(STATUS,'START').NE.0)THEN 19 - X0=X1 20 - Y0=Y1 21 - IFLAG=0 22 - INIT=1 23 - RETURN 24 - * Last step on the contour: lock but do this one. 25 - ELSEIF(INDEX(STATUS,'END').NE.0)THEN 26 - INIT=0 27 - * For other operations, INIT must be set properly. 28 - ELSEIF(INIT.EQ.0)THEN 29 - WRITE(10,'('' !!!!!! GRCUPD WARNING : This routine has'', 30 - - '' not been initialsed properly; program bug.'')') 31 - IFLAG=1 32 - RETURN 33 - ENDIF 34 - *** In case the contour left the area, update the boundary. 1 174 P=GRAPHICS D=GRCUPD 2 PAGE 283 35 - IF(INDEX(STATUS,'EDGE').NE.0)THEN 36 - * Update of the lower x border. 37 - IF(1+2*INT(0.001+IFLAG/2).EQ.IFLAG)THEN 38 - IUPD=INT((Y1-CYMIN)*REAL(NGRIDY)/(CYMAX-CYMIN)) 39 - IF(IUPD.GE.0.AND.IUPD.LE.NGRIDY)YDONE(0,IUPD)=.TRUE. 40 - ENDIF 41 - * Update of the higher x border. 42 - IF(1+2*INT(0.001+IFLAG/4).EQ.IFLAG/2)THEN 43 - IUPD=INT((Y1-CYMIN)*REAL(NGRIDY)/(CYMAX-CYMIN)) 44 - IF(IUPD.GE.0.AND.IUPD.LE.NGRIDY) 45 - - YDONE(NGRIDX,IUPD)=.TRUE. 46 - ENDIF 47 - * Update of the lower y border. 48 - IF(1+2*INT(0.001+IFLAG/8).EQ.IFLAG/4)THEN 49 - IUPD=INT((X1-CXMIN)*REAL(NGRIDX)/(CXMAX-CXMIN)) 50 - IF(IUPD.GE.0.AND.IUPD.LE.NGRIDX)XDONE(IUPD,0)=.TRUE. 51 - ENDIF 52 - * Update of the higher y border. 53 - IF(1+2*INT(0.001+IFLAG/16).EQ.IFLAG/8)THEN 54 - IUPD=INT((X1-CXMIN)*REAL(NGRIDX)/(CXMAX-CXMIN)) 55 - IF(IUPD.GE.0.AND.IUPD.LE.NGRIDX) 56 - - XDONE(IUPD,NGRIDY)=.TRUE. 57 - ENDIF 58 - ENDIF 59 - *** IFLAG has now been used, assume the routine will work. 60 - IFLAG=0 61 - *** Determine other grid lines the contour may have crossed. 62 - IXMIN=MIN(INT((X0-CXMIN)*REAL(NGRIDX)/(CXMAX-CXMIN)), 63 - - INT((X1-CXMIN)*REAL(NGRIDX)/(CXMAX-CXMIN))) 64 - IXMAX=MAX(INT((X0-CXMIN)*REAL(NGRIDX)/(CXMAX-CXMIN)), 65 - - INT((X1-CXMIN)*REAL(NGRIDX)/(CXMAX-CXMIN))) 66 - IYMIN=MIN(INT((Y0-CYMIN)*REAL(NGRIDY)/(CYMAX-CYMIN)), 67 - - INT((Y1-CYMIN)*REAL(NGRIDY)/(CYMAX-CYMIN))) 68 - IYMAX=MAX(INT((Y0-CYMIN)*REAL(NGRIDY)/(CYMAX-CYMIN)), 69 - - INT((Y1-CYMIN)*REAL(NGRIDY)/(CYMAX-CYMIN))) 70 - IXMIN=MIN(MXGRID,NGRIDX,MAX(0,IXMIN)) 71 - IXMAX=MIN(MXGRID,NGRIDX,MAX(0,IXMAX)) 72 - IYMIN=MIN(MXGRID,NGRIDY,MAX(0,IYMIN)) 73 - IYMAX=MIN(MXGRID,NGRIDY,MAX(0,IYMAX)) 74 - ** Skip the case no line was crossed. 75 - IF(IXMIN.EQ.IXMAX.AND.IYMIN.EQ.IYMAX)THEN 76 - X0=X1 77 - Y0=Y1 78 - RETURN 79 - ENDIF 80 - if(ldebug)write(10,'('' x-range: '',2I3,'' y-range: '',2I3)') 81 - - ixmin,ixmax,iymin,iymax 82 - ** Loop over the subgrid. 83 - DO 20 IX=IXMIN,IXMAX 84 - DO 30 IY=IYMIN,IYMAX 85 - ** x-update, skipped if the grid point is on the boundary. 86 - IF((.NOT.XDONE(IX,IY)).AND.IX.LT.NGRIDX.AND.CROSS( 87 - - CXMIN+REAL(IX)*(CXMAX-CXMIN)/REAL(NGRIDX), 88 - - CYMIN+REAL(IY)*(CYMAX-CYMIN)/REAL(NGRIDY), 89 - - CXMIN+REAL(IX+1)*(CXMAX-CXMIN)/REAL(NGRIDX), 90 - - CYMIN+REAL(IY)*(CYMAX-CYMIN)/REAL(NGRIDY), 91 - - X0,Y0,X1,Y1))THEN 92 - * Assume no update occurs. 93 - IDONE=0 94 - * Crossing point within bounds, update always if FC within bounds. 95 - IF((GRID(IX,IY)-FC)*(FC-GRID(IX+1,IY)).GE.0)THEN 96 - XDONE(IX,IY)=.TRUE. 97 - IDONE=1 98 - ENDIF 99 - * Check whether the contour sneaked before the grid point. 100 - IF(IX.GT.0.AND.IDONE.EQ.0)THEN 101 - CALL GRCMIN(IX,IY,X0,Y0,X1,Y1,DNCR,ITYP) 102 - IF((GRID(IX-1,IY)-FC)*(FC-GRID(IX,IY)).GE.0.AND. 103 - - DNCR.LT.DNTHR)THEN 104 - XDONE(IX-1,IY)=.TRUE. 105 - IF(LDEBUG)WRITE(10,'('' ++++++ GRCUPD'', 106 - - '' DEBUG : Low-x update, d='',E15.8, 107 - - '' at '',2I3,''.'')') DNCR,IX-1,IY 108 - IDONE=1 109 - ENDIF 110 - ENDIF 111 - * Check whether the contour sneaked past the grid segment. 112 - IF(IX.LT.NGRIDX-1.AND.IDONE.EQ.0)THEN 113 - CALL GRCMIN(IX+1,IY,X0,Y0,X1,Y1,DNCR,ITYP) 114 - IF((GRID(IX+1,IY)-FC)*(FC-GRID(IX+2,IY)).GE.0.AND. 115 - - DNCR.LT.DNTHR)THEN 116 - XDONE(IX+1,IY)=.TRUE. 117 - IF(LDEBUG)WRITE(10,'('' ++++++ GRCUPD'', 118 - - '' DEBUG : High-x update, d='',E15.8, 119 - - '' at '',2I3,''.'')') DNCR,IX+1,IY 120 - IDONE=1 121 - ENDIF 122 - ENDIF 123 - * Make sure an update is found. 124 - IF(IDONE.EQ.0)THEN 125 - WRITE(10,'('' !!!!!! GRCUPD WARNING : No x-update'', 126 - - '' performed inspite of a segment crossing.'')') 127 - C CALL F(X0,Y0,F0,ILOC0) 128 - C CALL F(X1,Y1,F1,ILOC1) 129 - C NFC=NFC+2 130 - C WRITE(10,'(26X,''Grid='',4E12.5/ 131 - C - 26X,''Step='',4E12.5/26X,''F Grid='',3E12.5/ 132 - C - 26X,''F step='',3E12.5/ 133 - C - 26X,''Loc ='',12X,2I12)') 134 - C - CXMIN+IX*(CXMAX-CXMIN)/REAL(NGRIDX), 135 - C - CYMIN+IY*(CYMAX-CYMIN)/REAL(NGRIDY), 136 - C - CXMIN+(IX+1)*(CXMAX-CXMIN)/REAL(NGRIDX), 137 - C - CYMIN+IY*(CYMAX-CYMIN)/REAL(NGRIDY), 138 - C - X0,Y0,X1,Y1, 139 - C - GRID(IX-1,IY),GRID(IX,IY),GRID(IX+1,IY), 140 - C - FC,F0,F1,ILOC0,ILOC1 1 174 P=GRAPHICS D=GRCUPD 3 PAGE 284 141 - XDONE(IX,IY)=.TRUE. 142 - ENDIF 143 - ENDIF 144 - ** y-update, skipped if the grid point is on the boundary. 145 - IF((.NOT.YDONE(IX,IY)).AND.IY.LT.NGRIDY.AND.CROSS( 146 - - CXMIN+REAL(IX)*(CXMAX-CXMIN)/REAL(NGRIDX), 147 - - CYMIN+REAL(IY)*(CYMAX-CYMIN)/REAL(NGRIDY), 148 - - CXMIN+REAL(IX)*(CXMAX-CXMIN)/REAL(NGRIDX), 149 - - CYMIN+REAL(IY+1)*(CYMAX-CYMIN)/REAL(NGRIDY), 150 - - X0,Y0,X1,Y1))THEN 151 - * Assume no update occurs. 152 - IDONE=0 153 - * Crossing point within bounds, update always if FC within bounds. 154 - IF((GRID(IX,IY)-FC)*(FC-GRID(IX,IY+1)).GE.0)THEN 155 - YDONE(IX,IY)=.TRUE. 156 - IDONE=1 157 - ENDIF 158 - * Check whether the contour sneaked before the grid point. 159 - IF(IY.GT.0.AND.IDONE.EQ.0)THEN 160 - CALL GRCMIN(IX,IY,X0,Y0,X1,Y1,DNCR,ITYP) 161 - IF((GRID(IX,IY-1)-FC)*(FC-GRID(IX,IY)).GE.0.AND. 162 - - DNCR.LT.DNTHR)THEN 163 - YDONE(IX,IY-1)=.TRUE. 164 - IF(LDEBUG)WRITE(10,'('' ++++++ GRCUPD'', 165 - - '' DEBUG : Low-y update, d='',E15.8, 166 - - '' at '',2I3,''.'')') DNCR,IX,IY-1 167 - IDONE=1 168 - ENDIF 169 - ENDIF 170 - * Check whether the contour sneaked past the grid segment. 171 - IF(IY.LT.NGRIDY-1.AND.IDONE.EQ.0)THEN 172 - CALL GRCMIN(IX,IY+1,X0,Y0,X1,Y1,DNCR,ITYP) 173 - IF((GRID(IX,IY+1)-FC)*(FC-GRID(IX,IY+2)).GE.0.AND. 174 - - DNCR.LT.DNTHR)THEN 175 - YDONE(IX,IY+1)=.TRUE. 176 - IF(LDEBUG)WRITE(10,'('' ++++++ GRCUPD'', 177 - - '' DEBUG : High y-update, d='',E15.8, 178 - - '' at '',2I3,''.'')') DNCR,IX,IY+1 179 - IDONE=1 180 - ENDIF 181 - ENDIF 182 - * Make sure an update is found. 183 - IF(IDONE.EQ.0)THEN 184 - WRITE(10,'('' !!!!!! GRCUPD WARNING : No y-update'', 185 - - '' performed inspite of a segment crossing.'')') 186 - C WRITE(10,'(26X,''IX,IY='',2I3/26X,''F='',3E15.8)') 187 - C - IX,IY,GRID(IX,IY),FC,GRID(IX,IY+1) 188 - YDONE(IX,IY)=.TRUE. 189 - ENDIF 190 - ENDIF 191 - 30 CONTINUE 192 - 20 CONTINUE 193 - *** Shift the positions. 194 - X0=X1 195 - Y0=Y1 196 - END 175 GARFIELD ================================================== P=GRAPHICS D=GRCONV 1 ============================ 0 + +DECK,GRCONV. 1 - SUBROUTINE GRCONV(NPOL,XIN,YIN) 2 - *----------------------------------------------------------------------- 3 - * GRCONV - Plots a convex polygon inside a box. 4 - * (Last changed on 13/ 5/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GRAPHICS. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,CONSTANTS. 11.- +SEQ,PARAMETERS. 12 - REAL XIN(*),YIN(*),XPL(MXLIST),YPL(MXLIST),ZPL(MXLIST) 13 - DOUBLE PRECISION XPOL(MXLIST),YPOL(MXLIST),XAUX,YAUX 14 - INTEGER NPOL,I,J,NPL 15 - LOGICAL SKIP,INSIDE,EDGE,ADD,ONLIND 16 - EXTERNAL ONLIND 17 - *** Make sure there is at least 1 input point. 18 - IF(NPOL.LE.2)THEN 19 - RETURN 20 - * Check maximum length. 21 - ELSEIF(NPOL.GT.MXLIST)THEN 22 - PRINT *,' !!!!!! GRCONV WARNING : Input vector length'// 23 - - ' exceeds MXLIST ; area not plotted.' 24 - RETURN 25 - ENDIF 26 - *** Copy the input vector. 27 - DO 10 I=1,NPOL 28 - XPOL(I)=DBLE(XIN(I)) 29 - YPOL(I)=DBLE(YIN(I)) 30 - 10 CONTINUE 31 - *** Next find the intersections between the two sets. 32 - NPL=0 33 - DO 40 J=1,NPOL 34 - * Set flag to see whether we search for mid-line intersects. 35 - SKIP=.FALSE. 36 - * Scan the box. 37 - DO 30 I=1,NGBOX 38 - * See whether the polygon start is on any of the box edges. 39 - IF(ONLIND(GXBOX(1+MOD(I-1,NGBOX)),GYBOX(1+MOD(I-1,NGBOX)), 40 - - GXBOX(1+MOD(I,NGBOX)),GYBOX(1+MOD(I,NGBOX)), 41 - - XPOL(J),YPOL(J)))THEN 42 - IF(NPL.GE.MXLIST)GOTO 3000 43 - NPL=NPL+1 44 - XPL(NPL)=REAL(XPOL(J)) 45 - YPL(NPL)=REAL(YPOL(J)) 46 - ZPL(NPL)=0 1 175 P=GRAPHICS D=GRCONV 2 PAGE 285 47 - SKIP=.TRUE. 48 - ENDIF 49 - * See whether a box corner is on this polygon segment. 50 - IF(ONLIND(XPOL(1+MOD(J-1,NPOL)),YPOL(1+MOD(J-1,NPOL)), 51 - - XPOL(1+MOD(J,NPOL)),YPOL(1+MOD(J,NPOL)), 52 - - GXBOX(I),GYBOX(I)))THEN 53 - IF(NPL.GE.MXLIST)GOTO 3000 54 - NPL=NPL+1 55 - XPL(NPL)=REAL(GXBOX(I)) 56 - YPL(NPL)=REAL(GYBOX(I)) 57 - ZPL(NPL)=0 58 - SKIP=.TRUE. 59 - ENDIF 60 - 30 CONTINUE 61 - * If neither of this happened, look for mid-line intersects. 62 - IF(.NOT.SKIP)THEN 63 - DO 100 I=1,NGBOX 64 - CALL CRSPND( 65 - - GXBOX(1+MOD(I-1,NGBOX)),GYBOX(1+MOD(I-1,NGBOX)), 66 - - GXBOX(1+MOD(I ,NGBOX)),GYBOX(1+MOD(I ,NGBOX)), 67 - - XPOL(1+MOD(J-1,NPOL)),YPOL(1+MOD(J-1,NPOL)), 68 - - XPOL(1+MOD(J ,NPOL)),YPOL(1+MOD(J ,NPOL)), 69 - - XAUX,YAUX,ADD) 70 - IF(ADD)THEN 71 - IF(NPL.GE.MXLIST)GOTO 3000 72 - NPL=NPL+1 73 - XPL(NPL)=REAL(XAUX) 74 - YPL(NPL)=REAL(YAUX) 75 - ZPL(NPL)=0 76 - ENDIF 77 - 100 CONTINUE 78 - ENDIF 79 - 40 CONTINUE 80 - *** Find the vertices of the box internal to the polygon. 81 - DO 50 I=1,NGBOX 82 - CALL INTERD(NPOL,XPOL,YPOL,GXBOX(I),GYBOX(I),INSIDE,EDGE) 83 - * Skip box corners on the polygon. 84 - IF(EDGE)GOTO 50 85 - * Add internal points. 86 - IF(INSIDE)THEN 87 - IF(NPL.GE.MXLIST)GOTO 3000 88 - NPL=NPL+1 89 - XPL(NPL)=REAL(GXBOX(I)) 90 - YPL(NPL)=REAL(GYBOX(I)) 91 - ZPL(NPL)=0 92 - ENDIF 93 - 50 CONTINUE 94 - *** Find the vertices of the polygon internal to the box. 95 - DO 70 I=1,NPOL 96 - * Check whether the point is internal. 97 - XAUX=XPOL(I) 98 - YAUX=YPOL(I) 99 - CALL INTERD(NGBOX,GXBOX,GYBOX,XAUX,YAUX,INSIDE,EDGE) 100 - * Skip polygon corners on the box. 101 - IF(EDGE)GOTO 70 102 - * Add internal points. 103 - IF(INSIDE)THEN 104 - IF(NPL.GE.MXLIST)GOTO 3000 105 - NPL=NPL+1 106 - XPL(NPL)=REAL(XPOL(I)) 107 - YPL(NPL)=REAL(YPOL(I)) 108 - ZPL(NPL)=0 109 - ENDIF 110 - 70 CONTINUE 111 - *** Ensure there is no butterfly. 112 - CALL BUTFLY(NPL,XPL,YPL,ZPL) 113 - *** Plot the polygon. 114 - IF(NPL.GE.3)CALL GFA(NPL,XPL,YPL) 115 - RETURN 116 - *** Buffer overflow. 117 - 3000 CONTINUE 118 - PRINT *,' !!!!!! GRCONV WARNING : Plot vector buffer'// 119 - - ' overflow; area not plotted.' 120 - END 176 GARFIELD ================================================== P=GRAPHICS D=GRDAWK 1 ============================ 0 + +DECK,GRDAWK. 1 - SUBROUTINE GRDAWK(NAME) 2 - *----------------------------------------------------------------------- 3 - * GRDAWK - Deactivates a workstation - GKS version. 4 - * (Last changed on 21/ 3/92.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,GRAPHICS. 10 - EXTERNAL INPCMX 11 - INTEGER INPCMX,IWK,IFAIL,IERR,ISTATE 12 - CHARACTER*(*) NAME 13 - *** Locate workstation. 14 - CALL GRQIWK(NAME,IWK,IFAIL) 15 - IF(IFAIL.NE.0)RETURN 16 - *** Check the current state of the workstation. 17 - IF(WKSTAT(IWK).LT.2)THEN 18 - PRINT *,' !!!!!! GRDAWK WARNING : Workstation ',NAME, 19 - - ' is not even open; not deactivated.' 20 - RETURN 21 - ENDIF 22 - CALL GQWKS(IWK,IERR,ISTATE) 23 - IF(IERR.NE.0)PRINT *,' !!!!!! GRDAWK WARNING : Inquiry error'// 24 - - ' for state of ',NAME,' ; assumed active.' 25 - IF(IERR.EQ.0.AND.ISTATE.EQ.0)THEN 26 - PRINT *,' !!!!!! GRDAWK WARNING : Workstation ',NAME, 27 - - ' is already inactive.' 28 - RETURN 1 176 P=GRAPHICS D=GRDAWK 2 PAGE 286 29 - ENDIF 30 - *** And at last deactivate the workstation. 31 - CALL GDAWK(IWK) 32 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRDAWK DEBUG :'', 33 - - '' Workstation '',A,'' has been deactivated.'')') NAME 34 - WKSTAT(IWK)=2 0 35-+ +SELF,IF=HIGZ. 36 - CALL SGFLAG 0 37-+ +SELF. 38 - END 177 GARFIELD ================================================== P=GRAPHICS D=GRDLWK 1 ============================ 0 + +DECK,GRDLWK. 1 - SUBROUTINE GRDLWK 2 - *----------------------------------------------------------------------- 3 - * GRDLWK - Deletes a workstation - version for GKS. 4 - * (Last changed on 25/ 3/92.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,GRAPHICS. 10 - CHARACTER*(MXCHAR) STRING 11 - CHARACTER*20 NAME 12 - INTEGER NC,IKEY,NWORD,I,NCNAME,IWK 13 - *** Determine position of keyword. 14 - CALL INPSTR(1,1,STRING,NC) 15 - IF(STRING(1:1).EQ.'!'.AND.NC.EQ.1)THEN 16 - IKEY=2 17 - ELSE 18 - IKEY=1 19 - ENDIF 20 - *** Warn if there are no arguments. 21 - CALL INPNUM(NWORD) 22 - IF(NWORD.EQ.IKEY)THEN 23 - PRINT *,' !!!!!! GRDLWK WARNING : DELETE-WORKSTATION'// 24 - - ' needs one argument; nothing done.' 25 - RETURN 26 - ENDIF 27 - *** Locate the workstation in the table. 28 - CALL INPSTR(IKEY+1,IKEY+1,NAME,NCNAME) 29 - * Match with existing names. 30 - DO 10 I=1,NWK 31 - IF(NAME(1:NCNAME).EQ.WKNAME(I)(1:NCWKNM(I)))THEN 32 - IWK=I 33 - GOTO 20 34 - ENDIF 35 - 10 CONTINUE 36 - * Warn if not found. 37 - PRINT *,' !!!!!! GRDLWK WARNING : Workstation '//NAME(1:NCNAME)// 38 - - ' is not known; not deleted.' 39 - RETURN 40 - 20 CONTINUE 41 - *** Check current status. 42 - IF(WKSTAT(IWK).EQ.3)THEN 43 - PRINT *,' !!!!!! GRDLWK WARNING : '//NAME(1:NCNAME)// 44 - - ' is still active ; deactivating ...' 45 - CALL GRDAWK(NAME(1:NCNAME)) 46 - ENDIF 47 - IF(WKSTAT(IWK).EQ.2)THEN 48 - PRINT *,' !!!!!! GRDLWK WARNING : '//NAME(1:NCNAME)// 49 - - ' is still open ; closing ...' 50 - CALL GRCLWK(NAME(1:NCNAME)) 51 - ENDIF 52 - *** Delete from the table. 53 - DO 30 I=IWK+1,NWK 54 - WKNAME(I-1)=WKNAME(I) 55 - WKID (I-1)=WKID (I) 56 - NCWKNM(I-1)=NCWKNM(I) 57 - WKFREF(I-1)=WKFREF(I) 58 - WKCON (I-1)=WKCON (I) 59 - WKLUN (I-1)=WKLUN (I) 60 - WKATTR(I-1)=WKATTR(I) 61 - WKSTAT(I-1)=WKSTAT(I) 62 - 30 CONTINUE 63 - NWK=NWK-1 64 - END 178 GARFIELD ================================================== P=GRAPHICS D=GRQIWK 1 ============================ 0 + +DECK,GRQIWK. 1 - SUBROUTINE GRQIWK(NAME,IWK,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GRQIWK - Returns the wkid of a workstation. 4 - * (Last changed on 18/ 4/92.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,PRINTPLOT. 8.- +SEQ,GRAPHICS. 9 - EXTERNAL INPCMX 10 - INTEGER INPCMX 11 - CHARACTER*(*) NAME 12 - *** Assume the routine will fail. 13 - IFAIL=1 14 - *** Scan the workstation table. 15 - IWK=0 16 - NFOUND=0 17 - DO 10 I=1,NWK 18 - IF(INPCMX(NAME,WKNAME(I)(1:NCWKNM(I))).NE.0)THEN 19 - IWK=I 20 - NFOUND=NFOUND+1 21 - ENDIF 22 - 10 CONTINUE 1 178 P=GRAPHICS D=GRQIWK 2 PAGE 287 23 - *** Error messages. 24 - IF(NFOUND.EQ.0)THEN 25 - PRINT *,' !!!!!! GRQIWK WARNING : Workstation ',NAME, 26 - - ' is not known ; not opened.' 27 - RETURN 28 - ELSEIF(NFOUND.GT.1)THEN 29 - PRINT *,' !!!!!! GRQIWK WARNING : Workstation ',NAME, 30 - - ' is ambiguous ; not opened.' 31 - RETURN 32 - ENDIF 33 - *** Things are OK. 34 - IFAIL=0 35 - END 179 GARFIELD ================================================== P=GRAPHICS D=GROPWK 1 ============================ 0 + +DECK,GROPWK. 1 - SUBROUTINE GROPWK(NAME) 2 - *----------------------------------------------------------------------- 3 - * GROPWK - Opens a workstation - version for GKS. 4 - * (Last changed on 6/ 3/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,GRAPHICS. 10 - EXTERNAL INPCMX 11 - INTEGER INPCMX,IFAIL,IFAIL1,IWK,I,NC,IERR,ISTATE,IOS 12 - CHARACTER*(*) NAME 13 - CHARACTER*(MXNAME) AUX 14 - LOGICAL OPENED 15 - *** Locate workstation. 16 - CALL GRQIWK(NAME,IWK,IFAIL) 17 - IF(IFAIL.NE.0)RETURN 18 - *** Check the current state of the workstation. 19 - IF(WKSTAT(IWK).GE.2)THEN 20 - PRINT *,' !!!!!! GROPWK WARNING : Workstation ',NAME, 21 - - ' is already open ; not opened.' 22 - RETURN 23 - ENDIF 24 - *** And at last open the workstation, start with the file if any. 25 - IF(WKFREF(IWK).GT.0)THEN 26 - * Find a free logical unit. 27 - WKLUN(IWK)=0 28 - INQUIRE(UNIT=11,OPENED=OPENED) 29 - IF(OPENED)THEN 30 - DO 20 I=40,49 31 - INQUIRE(UNIT=I,OPENED=OPENED) 32 - IF(.NOT.OPENED)THEN 33 - WKLUN(IWK)=I 34 - GOTO 30 35 - ENDIF 36 - 20 CONTINUE 37 - PRINT *,' !!!!!! GROPWK WARNING : All logical units'// 38 - - ' reserved for metafiles are in use ; not opened.' 39 - RETURN 40 - 30 CONTINUE 41 - ELSE 42 - WKLUN(IWK)=11 43 - ENDIF 44 - * Retrieve the file name. 45 - CALL STRBUF('READ',WKFREF(IWK),AUX,NC,IFAIL1) 0 46-+ +SELF,IF=CMS. 47 - * And open the file. 48 - INQUIRE(FILE='/'//AUX(1:NC),OPENED=OPENED) 49 - IF(OPENED)THEN 50 - PRINT *,' !!!!!! GROPWK WARNING : You have already'// 51 - - ' opened file '//AUX(1:NC)//' ; workstation ', 52 - - NAME,' not opened.' 53 - RETURN 54 - ENDIF 55 - CALL FILEINF(IRC,'RECFM','V','LRECL',132) 56 - OPEN(UNIT=WKLUN(IWK),FILE='/'//AUX(1:NC), 57 - - ACTION='READWRITE',ACCESS='SEQUENTIAL', 58 - - ERR=2020,IOSTAT=IOS) 59 - CALL DSNLOG(AUX(1:NC),'Metafile ','Sequential', 60 - - 'Write ') 0 61-+ +SELF,IF=-CMS. 62 - * And open the file. 63 - CALL DSNOPN(AUX(1:NC),NC,WKLUN(IWK),'WRITE-FILE',IFAIL) 64 - IF(OPENED)THEN 65 - PRINT *,' !!!!!! GROPWK WARNING : Unable to open '// 66 - - AUX(1:NC)//' as metafile for workstation ', 67 - - NAME,'; left in "defined" state.' 68 - RETURN 69 - ENDIF 70 - CALL DSNLOG(AUX(1:NC),'Metafile ','Sequential', 71 - - 'Write ') 0 72-+ +SELF. 73 - * And open the workstation. 74 - CALL GOPWK(IWK,WKLUN(IWK)+WKCON(IWK),WKID(IWK)) 75 - WKSTAT(IWK)=2 76 - * Debugging output. 77 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GROPWK DEBUG :'', 78 - - '' File '',A,'' opened on unit '',I2,'' for'', 79 - - '' workstation '',A,'' of type '',I5,''.'')') 80 - - AUX(1:NC),WKLUN(IWK),NAME,WKID(IWK) 81 - ** No associated file. 82 - ELSE 83 - CALL GOPWK(IWK,WKCON(IWK),WKID(IWK)) 84 - WKSTAT(IWK)=2 85 - * Debugging output. 86 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GROPWK DEBUG :'', 1 179 P=GRAPHICS D=GROPWK 2 PAGE 288 87 - - '' Workstation '',A,'' of type '',I5,'' opened'', 88 - - '' without associated file.'')') NAME,WKID(IWK) 89 - ENDIF 90 - *** Check that the workstation is really open. 91 - CALL GQWKS(IWK,IERR,ISTATE) 92 - IF(IERR.EQ.7.OR.IERR.EQ.25)THEN 93 - PRINT *,' !!!!!! GROPWK WARNING : Workstation ',NAME, 94 - - ' could not be opened.' 95 - WKSTAT(IWK)=1 96 - RETURN 97 - ELSEIF(IERR.EQ.20)THEN 98 - PRINT *,' !!!!!! GROPWK WARNING : Cannot open ',NAME, 99 - - ' because the workstation identifier is not valid.' 100 - WKSTAT(IWK)=1 101 - RETURN 102 - ENDIF 103 - *** Set the workstation window. 104 - CALL GSWKWN(IWK,0.0,1.0,0.0,1.0) 105 - *** End of normal processing. 106 - RETURN 107 - *** Error handling. 108 - 2020 CONTINUE 109 - CALL STRBUF('READ',WKFREF(IWK),AUX,NC,IFAIL1) 110 - PRINT *,' !!!!!! GROPWK WARNING : Metafile '//AUX(1:NC)//' on '// 111 - - ' unit ',WKLUN(IWK),' can not be opened.' 112 - CALL INPIOS(IOS) 113 - END 180 GARFIELD ================================================== P=GRAPHICS D=GRTERMA 1 ============================ 0 + +DECK,GRTERMA,IF=APOLLO,UNIX. 1 - SUBROUTINE GRTERM(IWKTYP,ICON,IFLAG,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GRTERM - Returns the workstation identifier from the command line. 4 - * Version for GKS. 5 - * (Last changed on 21/ 1/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,PRINTPLOT. 0 9-+ +SELF,IF=APOLLO. 10 - %include '/sys/ins/base.ins.ftn' 11 - %include '/sys/ins/pgm.ins.ftn' 12 - integer*2 iarg,nargs,arg_length 13 - integer pointer(128) 0 14-+ +SELF,IF=-APOLLO. 15 - integer arg_length,iargc,nargs 16 - external iargc 0 17-+ +SELF. 18 - character*128 args 19 - integer istart,iend,ionoff,iflag,iarg,iwktyp,icon,ifail, 20 - - iwkr,iconr,icat,ifail1,inext,ierr,idum,inpcmx 21 - external inpcmx 22 - *** Default settings. 23 - call grwkid('*interactive_default',iwktyp,icon,icat,idum) 24 - ifail=1 25 - *** Pick up the value from the command line, count arguments. 0 26-+ +SELF,IF=APOLLO. 27 - call pgm_$get_args(nargs,pointer) 28 - nargs=nargs-1 0 29-+ +SELF,IF=-APOLLO. 30 - nargs=iargc() 0 31-+ +SELF. 32 - *** Find the area devoted to the -terminal option. 33 - istart=0 34 - iend=nargs 35 - ionoff=0 36 - iflag=0 37 - do iarg=1,nargs 0 38-+ +SELF,IF=APOLLO. 39 - arg_length=pgm_$get_arg(iarg,args,istat) 40 - if(istat.ne.status_$ok)then 41 - print *,' !!!!!! GRTERM WARNING : Error fetching an'// 42 - - ' argument; default terminal type returned.' 43 - ifail=1 44 - return 45 - endif 0 46-+ +SELF,IF=-APOLLO. 47 - call argget(iarg,args,arg_length) 0 48-+ +SELF. 49 - if(args(1:1).eq.'-'.and.arg_length.gt.1.and.istart.ne.0)then 50 - iend=iarg-1 51 - goto 10 52 - elseif(inpcmx(args(1:arg_length),'-term#inal').ne.0)then 53 - istart=iarg+1 54 - ionoff=1 55 - elseif(inpcmx(args(1:arg_length),'-noterm#inal').ne.0)then 56 - ionoff=-1 57 - endif 58 - enddo 59 - 10 continue 60 - *** Return here if there is a -noterminal or no -terminal. 61 - if(ionoff.eq.0)then 62 - ifail=0 63 - if(ldebug)write(lunout,'('' ++++++ GRTERM DEBUG :'', 64 - - '' No -terminal qualifier present.'')') 65 - iflag=0 66 - goto 100 1 180 P=GRAPHICS D=GRTERMA 2 PAGE 289 67 - elseif(ionoff.eq.-1)then 68 - ifail=0 69 - if(ldebug)write(lunout,'('' ++++++ GRTERM DEBUG :'', 70 - - '' Request not to produce terminal graphics.'')') 0 71-+ +SELF,IF=HIGZ. 72 - iflag=0 73 - iwktyp=0 0 74-+ +SELF,IF=-HIGZ. 75 - iflag=-1 0 76-+ +SELF. 77 - return 78 - else 79 - iflag=+1 80 - endif 81 - *** Decode the part about the terminal. 82 - inext=istart 83 - do 20 iarg=istart,iend 84 - if(iarg.lt.inext)goto 20 85 - ** Retrieve the sub-keyword. 0 86-+ +SELF,IF=APOLLO. 87 - arg_length=pgm_$get_arg(iarg,args,istat) 0 88-+ +SELF,IF=-APOLLO. 89 - call argget(iarg,args,arg_length) 0 90-+ +SELF. 91 - ** Terminal type. 92 - if(inpcmx(args(1:arg_length),'t#ype').ne.0)then 93 - * Check there indeed is an argument. 94 - if(iarg.eq.iend)then 95 - PRINT *,' !!!!!! GRTERM WARNING : The argument'// 96 - - ' for "type" is missing.' 97 - ifail=1 98 - goto 100 99 - endif 100 - * Retrieve the argument. 0 101-+ +SELF,IF=APOLLO. 102 - arg_length=pgm_$get_arg(iarg+1,args,istat) 0 103-+ +SELF,IF=-APOLLO. 104 - call argget(iarg+1,args,arg_length) 0 105-+ +SELF. 106 - * Compare with the workstation type list. 107 - call grwkid(args(1:arg_length),iwkr,iconr,icat,ifail1) 108 - * Check that this is a good interactive workstation type. 109 - if(icat.ne.2.or.ifail1.ne.0)then 110 - PRINT *,' !!!!!! GRTERM WARNING : Terminal type '// 111 - - args(1:arg_length)//' not valid or not for'// 112 - - ' interactive use.' 113 - ifail=1 114 - return 115 - endif 116 - iwktyp=iwkr 117 - icon=iconr 118 - * Debugging output. 119 - if(ldebug)write(lunout,'('' ++++++ GRTERM DEBUG :'', 120 - - '' Terminal type '',A,'', GKS id '',I5,''.'')') 121 - - args(1:arg_length),iwktyp 122 - inext=iarg+2 123 - ** Terminal type via GKS identifier. 124 - elseif(inpcmx(args(1:arg_length),'GKS#_identifier').ne.0)then 125 - * Check there indeed is an argument. 126 - if(iarg.eq.iend)then 127 - PRINT *,' !!!!!! GRTERM WARNING : The argument'// 128 - - ' for "GKS_identifier" is missing.' 129 - ifail=1 130 - goto 100 131 - endif 132 - * Retrieve the argument. 0 133-+ +SELF,IF=APOLLO. 134 - arg_length=pgm_$get_arg(iarg+1,args,istat) 0 135-+ +SELF,IF=-APOLLO. 136 - call argget(iarg+1,args,arg_length) 0 137-+ +SELF. 138 - * Attempt to read the integer. 139 - call inpric(args(1:arg_length),iwkr,0,ifail1) 140 - if(ifail1.ne.0)then 141 - print *,' !!!!!! GRTERM WARNING : The terminal'// 142 - - ' GKS identifier is not a valid integer.' 143 - ifail=1 144 - goto 100 145 - endif 146 - * Check workstation category. 147 - call gqwkca(iwkr,ierr,icat) 148 - if(icat.ne.2.or.ierr.ne.0)then 149 - PRINT *,' !!!!!! GRTERM WARNING : Terminal type '// 150 - - args(1:arg_length)//' not valid or not for'// 151 - - ' interactive use.' 152 - ifail=1 153 - goto 100 154 - endif 155 - * Store the workstation type. 156 - iwktyp=iwkr 157 - * Debugging output. 158 - if(ldebug)write(lunout,'('' ++++++ GRTERM DEBUG :'', 159 - - '' GKS identifier '',I5,'' given for terminal'', 160 - - '' type.'')') iwktyp 1 180 P=GRAPHICS D=GRTERMA 3 PAGE 290 161 - inext=iarg+2 162 - ** Connection identifier. 163 - elseif(inpcmx(args(1:arg_length), 164 - - 'c#onnection_identifier').ne.0)then 165 - * Check there indeed is an argument. 166 - if(iarg.eq.iend)then 167 - PRINT *,' !!!!!! GRTERM WARNING : The argument'// 168 - - ' for "connection_identifier" is missing.' 169 - ifail=1 170 - return 171 - endif 172 - * Retrieve the argument. 0 173-+ +SELF,IF=APOLLO. 174 - arg_length=pgm_$get_arg(iarg+1,args,istat) 0 175-+ +SELF,IF=-APOLLO. 176 - call argget(iarg+1,args,arg_length) 0 177-+ +SELF. 178 - * Attempt to read the number. 179 - call inpric(args(1:arg_length),iconr,0,ifail1) 180 - if(ifail1.ne.0)then 181 - print *,' !!!!!! GRTERM WARNING : The terminal'// 182 - - ' connection identifier is not a valid integer.' 183 - ifail=1 184 - return 185 - endif 186 - icon=iconr 187 - * Debugging output. 188 - if(ldebug)write(lunout,'('' ++++++ GRTERM DEBUG :'', 189 - - '' Terminal connection identifier '',I3,''.'')') 190 - - icon 191 - inext=iarg+2 192 - ** Anything else is not valid. 193 - else 194 - print *,' !!!!!! GRTERM WARNING : The keyword '// 195 - - args(1:arg_length)//' is not valid within'// 196 - - ' -terminal; is ignored.' 197 - endif 198 - 20 continue 199 - *** Continue here in case of errors. 200 - 100 continue 0 201-+ +SELF,IF=HIGZ. 202 - *** Check whether an inquiry is required. 203 - if(iwktyp.eq.-1.and.iflag.ge.0)then 204 - call igwkty(iwktyp) 205 - icon=0 206 - endif 0 207-+ +SELF. 208 - *** Things worked fine. 209 - ifail=0 210 - end 181 GARFIELD ================================================== P=GRAPHICS D=GRTERMV 1 ============================ 0 + +DECK,GRTERMV,IF=VAX. 1 - SUBROUTINE GRTERM(IWKTYP,ICON,IFLAG,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GRTERM - Returns the workstation identifier from the command line. 4 - * (Last changed on 17/ 6/95.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,PRINTPLOT. 7 - EXTERNAL CLI$GET_VALUE,CLI$PRESENT,CLI$_PRESENT,CLI$_ABSENT, 8 - - CLI$_NEGATED,CLI$_DEFAULTED 9 - INTEGER STATUS,CLI$GET_VALUE,CLI$PRESENT 10 - INTEGER*2 NC 11 - CHARACTER*255 TERM 12 - INCLUDE '($FORDEF)' 13 - INCLUDE '($SSDEF)' 0 14-+ +SELF,IF=SAVE. 15 - SAVE INIT,IWKRES,ICRES,IFRES,IFLAGR 0 16-+ +SELF. 17 - *** First and subsequent calls. 18 - DATA INIT/0/,IWKRES/0/,ICRES/-1/,IFRES/1/,IFLAGR/0/ 19 - IF(INIT.NE.0)THEN 20 - IWKTYP=IWKRES 21 - ICON=ICRES 22 - IFLAG=IFLAGR 23 - IFAIL=IFRES 24 - RETURN 25 - ELSE 26 - CALL GRWKID('*interactive_default',IWKTYP,ICON,ICAT,IDUM) 27 - IFAIL=1 28 - IFLAG=0 29 - INIT=1 30 - ENDIF 31 - *** Terminal qualifier negated ? 32 - IF(CLI$PRESENT('TERMINAL').EQ.%LOC(CLI$_NEGATED))THEN 33 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRTERM DEBUG :'', 34 - - '' Request not to produce terminal graphics'', 35 - - '' output.'')') 0 36-+ +SELF,IF=HIGZ. 37 - IFLAG=0 38 - IWKTYP=0 0 39-+ +SELF,IF=-HIGZ. 40 - IFLAG=-1 1 181 P=GRAPHICS D=GRTERMV 2 PAGE 291 41-+ +SELF. 42 - IFAIL=0 43 - GOTO 100 44 - ENDIF 45 - *** Is this a private terminal type ? 46 - IF(CLI$PRESENT('TERM_GKSID').EQ.%LOC(CLI$_PRESENT))THEN 47 - IFLAG=+1 48 - STATUS=CLI$GET_VALUE('TERM_GKSID',TERM,NC) 49 - IF(STATUS.NE.SS$_NORMAL)THEN 50 - PRINT *,' !!!!!! GRTERM WARNING : Unable to get'// 51 - - ' the terminal GKS identifier.' 52 - GOTO 100 53 - ENDIF 54 - * Attempt to read as integer. 55 - CALL INPRIC(TERM(1:NC),IWKR,0,IFAIL1) 56 - IF(IFAIL1.NE.0)THEN 57 - PRINT *,' !!!!!! GRTERM WARNING : The terminal'// 58 - - ' GKS identifier is not a valid integer.' 59 - GOTO 100 60 - ENDIF 61 - * Check workstation category. 62 - CALL GQWKCA(IWKR,IERR,ICAT) 63 - IF(ICAT.NE.2.OR.IERR.NE.0)THEN 64 - PRINT *,' !!!!!! GRTERM WARNING : Terminal type '// 65 - - TERM(1:NC)//' not valid or not for'// 66 - - ' interactive use.' 67 - GOTO 100 68 - ENDIF 69 - * Store workstation type. 70 - IWKTYP=IWKR 71 - * Debugging output. 72 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRTERM DEBUG :'// 73 - - ' Terminal specified by GKS id='',I6,''.'')') IWKTYP 74 - *** Or a standard terminal type ? 75 - ELSEIF(CLI$PRESENT('TERM_TYPE').EQ.%LOC(CLI$_PRESENT).OR. 76 - - CLI$PRESENT('TERM_TYPE').EQ.%LOC(CLI$_DEFAULTED))THEN 77 - STATUS=CLI$GET_VALUE('TERM_TYPE',TERM,NC) 78 - IF(STATUS.NE.SS$_NORMAL)THEN 79 - PRINT *,' !!!!!! GRTERM WARNING : Unable to get'// 80 - - ' the terminal type.' 81 - GOTO 100 82 - ENDIF 83 - IFLAG=+1 84 - * Compare with the workstation type list. 85 - CALL GRWKID(TERM(1:NC),IWKR,ICONR,ICAT,IFAIL1) 86 - * Check that this is a good interactive workstation type. 87 - IF(ICAT.NE.2.OR.IFAIL1.NE.0)THEN 88 - PRINT *,' !!!!!! GRTERM WARNING : Terminal type '// 89 - - TERM(1:NC)//' not valid or not for'// 90 - - ' interactive use.' 91 - GOTO 100 92 - ENDIF 93 - IWKTYP=IWKR 94 - ICON=ICONR 95 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRTERM DEBUG :'', 96 - - '' Terminal specified by type='',A,'', GKS id='', 97 - - I5,''.'')') TERM(1:NC),IWKTYP 98 - ENDIF 99 - *** Logical unit. 100 - IF(CLI$PRESENT('TERM_CONID').EQ.%LOC(CLI$_PRESENT))THEN 101 - STATUS=CLI$GET_VALUE('TERM_CONID',TERM,NC) 102 - IF(STATUS.NE.SS$_NORMAL)THEN 103 - PRINT *,' !!!!!! GRTERM WARNING : Unable to get'// 104 - - ' the terminal connection identifier.' 105 - GOTO 100 106 - ENDIF 107 - CALL INPRIC(TERM(1:NC),ICONR,0,IFAIL1) 108 - IF(IFAIL1.NE.0)THEN 109 - PRINT *,' !!!!!! GRTERM WARNING : The terminal'// 110 - - ' connection identifier is not a valid integer.' 111 - GOTO 100 112 - ENDIF 113 - ICON=ICONR 114 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRTERM DEBUG :'', 115 - - '' Terminal connection identifier '',I3,''.'')') 116 - - ICON 117 - ENDIF 118 - *** Things seem to have worked. 119 - IFAIL=0 120 - *** Continue here if something failed. 121 - 100 CONTINUE 0 122-+ +SELF,IF=HIGZ. 123 - *** Check whether an inquiry is required. 124 - IF(IWKTYP.EQ.-1.AND.IFLAG.GE.0.AND.IFAIL.EQ.0)THEN 125 - CALL IGWKTY(IWKTYP) 126 - ICON=0 127 - ENDIF 0 128-+ +SELF. 129 - *** Store defaults. 130 - IWKRES=IWKTYP 131 - ICRES=ICON 132 - IFLAGR=IFLAG 133 - IFRES=IFAIL 134 - END 182 GARFIELD ================================================== P=GRAPHICS D=GRTERMC 1 ============================ 0 + +DECK,GRTERMC,IF=CMS. 1 - SUBROUTINE GRTERM(IWKTYP,ICON,IFLAG,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GRTERM - Returns the workstation identifier from the command line. 4 - * (Last changed on 17/ 6/95.) 5 - *----------------------------------------------------------------------- 1 182 P=GRAPHICS D=GRTERMC 2 PAGE 292 6.- +SEQ,PRINTPLOT. 7 - INTEGER IRC 8 - CHARACTER*255 TERM 9 - *** Default settings. 10 - CALL GRWKID('*interactive_default',IWKTYP,IOFF,ICAT,IDUM) 11 - IFLAG=0 12 - IFAIL=1 13 - *** Check whether the terminal has to be active at all. 14 - CALL VMREXX('F','TERM_YN',TERM,IRC) 15 - * Handle errors picking up the value. 16 - IF(IRC.NE.0)THEN 17 - PRINT *,' !!!!!! GRTERM WARNING : Unable to pick up'// 18 - - ' the command line yes/no flag for terminals.' 19 - IFAIL=1 20 - GOTO 100 21 - ENDIF 22 - * Check value. 23 - IF(TERM(1:2).EQ.'NO')THEN 24 - IFLAG=-1 25 - IF(LDEBUG)PRINT *,' ++++++ GRTERM DEBUG : Requested not'// 26 - - ' to produce terminal graphics output.' 27 - IFAIL=0 28 - RETURN 29 - ELSEIF(TERM(1:3).NE.'YES')THEN 30 - PRINT *,' !!!!!! GRTERM WARNING : Invalid terminal yes/no'// 31 - - ' flag on the command line; default returned.' 32 - IFAIL=1 33 - GOTO 100 34 - ELSE 35 - IFLAG=+1 36 - ENDIF 37 - *** Read the terminal type. 38 - CALL VMREXX('F','TERM_TYPE',TERM,IRC) 39 - * Handle errors picking up the value. 40 - IF(IRC.NE.0)THEN 41 - PRINT *,' !!!!!! GRTERM WARNING : Unable to pick up'// 42 - - ' the terminal type from the command line.' 43 - IFAIL=1 44 - GOTO 100 45 - ENDIF 46 - ** Try to identify if it really is a type. 47 - IF(TERM(1:1).NE.'-')THEN 48 - * Determine the length. 49 - DO I=LEN(TERM),1,-1 50 - IF(TERM(I:I).NE.' ')THEN 51 - NC=I 52 - GOTO 10 53 - ENDIF 54 - ENDDO 55 - NC=0 56 - 10 CONTINUE 57 - IF(NC.GT.20)NC=20 58 - * Compare with the workstation type list. 59 - CALL GRWKID(TERM(1:NC),IWKR,ICONR,ICAT,IFAIL1) 60 - * Check the entry exists and is for interactive use. 61 - IF(ICAT.NE.2.OR.IFAIL1.NE.0)THEN 62 - PRINT *,' !!!!!! GRTERM WARNING : Terminal type '// 63 - - TERM(1:NC)//' not valid or not for'// 64 - - ' interactive use.' 65 - IFAIL=1 66 - RETURN 67 - ENDIF 68 - * Store if OK. 69 - IWKTYP=IWKR 70 - ICON=ICONR 71 - * Debugging output. 72 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRTERM DEBUG :'', 73 - - '' Terminal specified by type '',A,'', GKS id '', 74 - - I5,''.'')') TERM(1:NC),IWKTYP 75 - ** Otherwise read the GKS identifier. 76 - ELSE 77 - CALL VMREXX('F','TERM_GKSID',TERM,IRC) 78 - * Handle errors picking up the value. 79 - IF(IRC.NE.0)THEN 80 - PRINT *,' !!!!!! GRTERM WARNING : Unable to pick up'// 81 - - ' the terminal GKS identifier.' 82 - IFAIL=1 83 - GOTO 100 84 - ENDIF 85 - * Determine the length. 86 - DO I=LEN(TERM),1,-1 87 - IF(TERM(I:I).NE.' ')THEN 88 - NC=I 89 - GOTO 20 90 - ENDIF 91 - ENDDO 92 - NC=0 93 - 20 CONTINUE 94 - * Interpret as a number. 95 - CALL INPRIC(TERM(1:NC),IWKR,0,IFAIL1) 96 - IF(IFAIL1.NE.0)THEN 97 - PRINT *,' !!!!!! GRTERM WARNING : The terminal'// 98 - - ' GKS identifier is not a valid integer.' 99 - IFAIL=1 100 - GOTO 100 101 - ENDIF 102 - * Check workstation category. 103 - CALL GQWKCA(IWKR,IERR,ICAT) 104 - IF(ICAT.NE.2.OR.IERR.NE.0)THEN 105 - PRINT *,' !!!!!! GRTERM WARNING : Terminal type '// 106 - - TERM(1:NC)//' not valid or not for'// 107 - - ' interactive use.' 108 - IFAIL=1 109 - RETURN 110 - ENDIF 111 - * Store workstation type. 1 182 P=GRAPHICS D=GRTERMC 3 PAGE 293 112 - IWKTYP=IWKR 113 - * Debugging output. 114 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRTERM DEBUG :'', 115 - - '' Terminal GKS identifier is '',I5,''.'')') 116 - - IWKTYP 117 - ** And the logical unit offset. 118 - CALL VMREXX('F','TERM_CONID',TERM,IRC) 119 - * Handle errors picking up the value. 120 - IF(IRC.NE.0)THEN 121 - PRINT *,' !!!!!! GRTERM WARNING : Unable to get the'// 122 - - ' terminal connection identifier.' 123 - IFAIL=1 124 - RETURN 125 - ENDIF 126 - * Determine the length. 127 - DO I=LEN(TERM),1,-1 128 - IF(TERM(I:I).NE.' ')THEN 129 - NC=I 130 - GOTO 30 131 - ENDIF 132 - ENDDO 133 - NC=0 134 - 30 CONTINUE 135 - * Interpret as a number. 136 - CALL INPRIC(TERM(1:NC),ICONR,0,IFAIL1) 137 - IF(IFAIL1.NE.0)THEN 138 - PRINT *,' !!!!!! GRTERM WARNING : The terminal'// 139 - - ' connection identifier is not a valid integer.' 140 - IFAIL=1 141 - RETURN 142 - ENDIF 143 - ICON=ICONR 144 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRTERM DEBUG :'', 145 - - '' Terminal logical unit offset '',I3,''.'')') 146 - - IOFF 147 - ENDIF 148 - *** Continue here in case of errors. 149 - 100 CONTINUE 0 150-+ +SELF,IF=HIGZ. 151 - * Check whether an inquiry is required. 152 - IF(IWKTYP.EQ.0.AND.IFLAG.EQ.1)THEN 153 - CLOSE(5) 154 - OPEN(5) 155 - CALL IGWKTY(IWKTYP) 156 - CLOSE(5) 157 - OPEN(5,FORM='UNFORMATTED') 158 - ICON=0 159 - ENDIF 0 160-+ +SELF. 161 - *** Things went OK. 162 - IFAIL=0 163 - END 183 GARFIELD ================================================== P=GRAPHICS D=GRWCNC 1 ============================ 0 + +DECK,GRWCNC. 1 - SUBROUTINE GRWCNC(XWC,YWC,XNDC,YNDC) 2 - *----------------------------------------------------------------------- 3 - * GRWCNC - Converts world coordinates into NDC coordinates. 4 - * (Last changed on 29/ 6/96.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,PRINTPLOT. 8.- +SEQ,PARAMETERS. 9.- +SEQ,GRAPHICS. 10 - REAL XWC,YWC,XNDC,YNDC,WINDOW(4),VIEWP(4) 11 - INTEGER IERR,NT 12 - *** Inquire current NT. 13 - CALL GQCNTN(IERR,NT) 14 - IF(IERR.NE.0)THEN 15 - IF(LDEBUG)PRINT *,' ++++++ GRWCNC DEBUG : Error from'// 16 - - ' GQCNTN, code=',IERR,'; no conversion.' 17 - RETURN 18 - ENDIF 19 - *** Find out how big the screen is. 20 - CALL GQNT(NT,IERR,WINDOW,VIEWP) 21 - IF(IERR.NE.0)THEN 22 - IF(LDEBUG)PRINT *,' ++++++ GRWCNC DEBUG : Error from'// 23 - - ' GQNT, code=',IERR,'; no conversion.' 24 - RETURN 25 - ENDIF 26 - *** x-Coordinate. 27 - IF(LOGX.AND.XWC.GT.0)THEN 28 - XNDC=(VIEWP(2)-VIEWP(1))*(LOG10(XWC)-WINDOW(1))/ 29 - - (WINDOW(2)-WINDOW(1)) 30 - ELSEIF(LOGX)THEN 31 - XNDC=-1 32 - ELSE 33 - XNDC=(VIEWP(2)-VIEWP(1))*(XWC-WINDOW(1))/ 34 - - (WINDOW(2)-WINDOW(1)) 35 - ENDIF 36 - *** y-Coordinate. 37 - IF(LOGY.AND.YWC.GT.0)THEN 38 - YNDC=(VIEWP(4)-VIEWP(3))*(LOG10(YWC)-WINDOW(3))/ 39 - - (WINDOW(4)-WINDOW(3)) 40 - ELSEIF(LOGY)THEN 41 - YNDC=-1 42 - ELSE 43 - YNDC=(VIEWP(4)-VIEWP(3))*(YWC-WINDOW(3))/ 44 - - (WINDOW(4)-WINDOW(3)) 45 - ENDIF 46 - END 1 184 GARFIELD ================================================== P=GRAPHICS D=GRWKID 1 =================== PAGE 294 0 + +DECK,GRWKID. 1 - SUBROUTINE GRWKID(NAME,IWKID,LUNOFF,ICAT,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GRWKID - Associates a workstation name with an identifier. 4 - * VARIABLES : NAME : Input name of the workstation. 5 - * IWKID : Will be set to the workstation identifier. 6 - * LUNOFF : Offset between conid and lun. 7 - * (Last changed on 23/ 4/96.) 8 - *----------------------------------------------------------------------- 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*(*) NAME 11 - INTEGER IWKID,IFAIL,LUNOFF 0 12-+ +SELF,IF=APOLLO,IF=GTSGRAL. 13 - PARAMETER(NTYP=37) 14 - INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) 15 - CHARACTER*20 TYPE(NTYP) 16 - *** Workstation lists. 17 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,10)/ 18 - - 'DN300_bw ', 10002, 1, 1, 19 - - 'DN3000_bw ', 10002, 1, 1, 20 - - '*interactive_default', 10002, 1, 1, 21 - - 'DN3000_colour ', 10004, 1, 1, 22 - - 'DN550_colour ', 10003, 1, 1, 23 - - 'DN660_colour ', 10003, 1, 1, 24 - - 'GSR_1 ', 9701, 1, 1, 25 - - 'GSR_2 ', 9702, 1, 1, 26 - - 'GSR_3 ', 9703, 1, 1, 27 - - 'GSR_4 ', 9704, 1, 1/ 28 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=11,20)/ 29 - - 'GSR_5 ', 9705, 1, 1, 30 - - 'GSR_6 ', 9706, 1, 1, 31 - - 'GSR_7 ', 9707, 1, 1, 32 - - 'GSR_8 ', 9708, 1, 1, 33 - - 'X_windows_0 ', 32120, 1, 1, 34 - - 'X_windows_1 ', 32121, 1, 1, 35 - - 'X_windows_2 ', 32122, 1, 1, 36 - - 'X_windows_3 ', 32123, 1, 1, 37 - - 'X_windows_4 ', 32124, 1, 1, 38 - - 'X_windows_5 ', 32125, 1, 1/ 39 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=21,30)/ 40 - - 'X_windows_6 ', 32126, 1, 1, 41 - - 'X_windows_7 ', 32127, 1, 1, 42 - - 'X_windows_8 ', 32128, 1, 1, 43 - - 'X_windows_9 ', 32129, 1, 1, 44 - - 'X_windows ', 32120, 1, 1, 45 - - 'APPENDIX_E ', 4, 0, -1, 46 - - 'PS_portrait_colour ', 12201, 100, -1, 47 - - 'PS_landscape_colour ', 12202, 100, -1, 48 - - 'PS_landscape_bw ', 12204, 100, -1, 49 - - 'PS_portrait_bw ', 12203, 100, -1/ 50 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=31,NTYP)/ 51 - - 'PostScript ', 12203, 100, -1, 52 - - 'EPS_portrait_colour ', 12201, 200, -1, 53 - - 'EPS_landscape_colour', 12202, 200, -1, 54 - - 'EPS_landscape_bw ', 12204, 200, -1, 55 - - 'EPS_portrait_bw ', 12203, 200, -1, 56 - - 'Encapsulated_PS ', 12203, 200, -1, 57 - - '*batch_default ', 12203, 100, -1/ 0 58-+ +SELF,IF=-APOLLO,IF=GTSGRAL. 59 - PARAMETER(NTYP=51) 60 - INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) 61 - CHARACTER*20 TYPE(NTYP) 62 - *** Workstation lists. 63 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,10)/ 64 - - 'VT100_RETROGRAPHICS ', 1001, 1, 1, 65 - - 'VT100_SELENAR ', 1002, 1, 1, 66 - - 'VT125_REGIS ', 1010, 1, 1, 67 - - 'VT240_REGIS ', 1020, 1, 1, 68 - - 'VT241_REGIS ', 1021, 1, 1, 69 - - 'VT340 ', 1030, 1, 1, 70 - - 'VAXSTATION ', 8601, 1, 1, 71 - - 'PG7800 ', 7878, 1, 1, 72 - - 'MG600 ', 7800, 1, 1, 73 - - 'MX2000 ', 221, 1, 1/ 74 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=11,20)/ 75 - - 'MX7000 ', 221, 1, 1, 76 - - 'MX8000 ', 227, 1, 1, 77 - - '4010 ', 101, 1, 1, 78 - - '4012 ', 102, 1, 1, 79 - - '4014 ', 101, 1, 1, 80 - - '4015 ', 103, 1, 1, 81 - - '4105 ', 110, 1, 1, 82 - - '4107 ', 121, 1, 1, 83 - - '4109 ', 122, 1, 1, 84 - - '4207 ', 121, 1, 1/ 85 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=21,30)/ 86 - - '4209 ', 122, 1, 1, 87 - - '4111 ', 123, 1, 1, 88 - - '4113 ', 125, 1, 1, 89 - - '4114 ', 127, 1, 1, 90 - - '4115 ', 127, 1, 1, 91 - - 'FALCO ', 114, 1, 1, 92 - - 'X_WINDOWS_0 ', 32120, 1, 1, 93 - - 'X_WINDOWS_1 ', 32121, 1, 1, 94 - - 'X_WINDOWS_2 ', 32122, 1, 1, 95 - - 'X_WINDOWS_3 ', 32123, 1, 1/ 96 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=31,40)/ 97 - - 'X_WINDOWS_4 ', 32124, 1, 1, 98 - - 'X_WINDOWS_5 ', 32125, 1, 1, 99 - - 'X_WINDOWS_6 ', 32126, 1, 1, 100 - - 'X_WINDOWS_7 ', 32127, 1, 1, 101 - - 'X_WINDOWS_8 ', 32128, 1, 1, 102 - - 'X_WINDOWS_9 ', 32129, 1, 1, 103 - - 'X_WINDOWS ', 32120, 1, 1, 1 184 P=GRAPHICS D=GRWKID 2 PAGE 295 104 - - '*interactive_default', 7878, 1, 1, 105 - - 'PT-100G ', 112, 1, 1, 106 - - 'APPENDIX_E ', 4, 0, -1/ 107 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=41,50)/ 108 - - 'PS_PORTRAIT_COLOUR ', 12201, 100, -1, 109 - - 'PS_LANDSCAPE_COLOUR ', 12202, 100, -1, 110 - - 'PS_LANDSCAPE_BW ', 12204, 100, -1, 111 - - 'PS_PORTRAIT_BW ', 12203, 100, -1, 112 - - 'POSTSCRIPT ', 12203, 100, -1, 113 - - 'EPS_PORTRAIT_COLOUR ', 12201, 200, -1, 114 - - 'EPS_LANDSCAPE_COLOUR', 12202, 200, -1, 115 - - 'EPS_LANDSCAPE_BW ', 12204, 200, -1, 116 - - 'EPS_PORTRAIT_BW ', 12203, 200, -1, 117 - - 'ENCAPSULATED_PS ', 12203, 200, -1/ 118 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=51,NTYP)/ 119 - - '*batch_default ', 4, 0, -1/ 0 120-+ +SELF,IF=DECGKS. 121 - PARAMETER(NTYP=31) 122 - INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) 123 - CHARACTER*20 TYPE(NTYP) 124 - *** Workstation lists. 125 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,10)/ 126 - - 'LOGICAL ', 0, 0, 1, 127 - - 'VT125_COLOUR ', 11, 0, 1, 128 - - 'VT125_BW ', 12, 0, 1, 129 - - 'VT240_COLOUR ', 13, 0, 1, 130 - - 'VT240_BW ', 14, 0, 1, 131 - - 'VT330 ', 16, 0, 1, 132 - - 'VT340 ', 17, 0, 1, 133 - - 'VAXSTATION_1 ', 42, 0, 1, 134 - - 'VAXSTATION_2 ', 41, 0, 1, 135 - - 'VS_1 ', 42, 0, 1/ 136 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=11,20)/ 137 - - 'VS_2 ', 41, 0, 1, 138 - - 'VS_2000 ', 41, 0, 1, 139 - - 'DECWINDOWS ', 211, 0, 1, 140 - - '4014 ', 72, 0, 1, 141 - - '*interactive_default', 72, 0, 1, 142 - - '4017 ', 82, 0, 1, 143 - - 'POSTSCRIPT ', 61, 0, -1, 144 - - 'PS ', 61, 0, -1, 145 - - '*batch_default ', 61, 0, -1, 146 - - 'METAFILE ', 2, 0, -1/ 147 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=21,NTYP)/ 148 - - 'DECGKS_MO ', 2, 0, -1, 149 - - 'CGM ', 7, 0, -1, 150 - - 'LCP01 ', 15, 0, -1, 151 - - 'LCG01 ', 15, 0, -1, 152 - - 'LN03 ', 38, 0, -1, 153 - - 'HP7475 ', 51, 0, -1, 154 - - 'HP7550 ', 53, 0, -1, 155 - - 'HP7580 ', 54, 0, -1, 156 - - 'HP7585 ', 56, 0, -1, 157 - - 'LBP8A2 ', 531, 0, -1, 158 - - 'L880 ', 532, 0, -1/ 0 159-+ +SELF,IF=PLOT10GKS. 160 - PARAMETER(NTYP=9) 161 - INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) 162 - CHARACTER*20 TYPE(NTYP) 163 - *** Workstation lists. 164 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,NTYP)/ 165 - - '4014_NOTABLET ',401400, -2, 1, 166 - - '4014_TABLET ',401401, -2, 1, 167 - - '4105 ',410500, -2, 1, 168 - - '4107 ',410700, -2, 1, 169 - - '4109 ',410900, -2, 1, 170 - - 'PERICOM ',301400, -2, 1, 171 - - '*interactive_default',301400, -2, 1, 172 - - 'PLOT10_MO ',100000, 0, -1, 173 - - '*batch_default ',100000, 0, -1/ 0 174-+ +SELF,IF=MGKS. 175 - PARAMETER(NTYP=8) 176 - INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) 177 - CHARACTER*20 TYPE(NTYP) 178 - *** Workstation lists. 179 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,NTYP)/ 180 - - 'borrow ',300009, 1, 1, 181 - - 'frame ',300010, 1, 1, 182 - - 'direct ',300011, 1, 1, 183 - - '4014 ',401400, 1, 1, 184 - - 'PERICOM ',301400, 1, 1, 185 - - '*interactive_default',301400, 1, 1, 186 - - 'APPENDIX_E ',300018, 0, -1, 187 - - '*batch_default ',300018, 0, -1/ 0 188-+ +SELF,IF=SUNGKS. 189 - PARAMETER(NTYP=4) 190 - INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) 191 - CHARACTER*20 TYPE(NTYP) 192 - *** Workstation lists. 193 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,NTYP)/ 194 - - 'Console ', 4, 1, 1, 195 - - '*interactive_default', 4, 1, 1, 196 - - 'Appendix_E ', 7, 0, -1, 197 - - '*batch_default ', 7, 0, -1/ 0 198-+ +SELF,IF=GKSCO. 199 - PARAMETER(NTYP=6) 200 - INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) 201 - CHARACTER*20 TYPE(NTYP) 202 - *** Workstation lists. 203 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,NTYP)/ 204 - - 'Console ', 1, 1, 1, 1 184 P=GRAPHICS D=GRWKID 3 PAGE 296 205 - - 'X_windows ', 6, -1, 1, 206 - - '*interactive_default', 6, -1, 1, 207 - - 'GDF ', 5, 0, -1, 208 - - 'MO ', 3, 0, -1, 209 - - '*batch_default ', 3, 0, -1/ 0 210-+ +SELF,IF=ATCGKS. (From Werner Koellner) 211 - PARAMETER(NTYP=51) 212 - INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) 213 - CHARACTER*20 TYPE(NTYP) 214 - *** Workstation lists. 215 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,10)/ 216 - - 'VT125_REGIS ', 2600, 1, 1, 217 - - 'VT240_REGIS ', 2601, 1, 1, 218 - - 'VT241_REGIS ', 2602, 1, 1, 219 - - '*interactive_default', 2602, 1, 1, 220 - - 'VT330 ', 2603, 1, 1, 221 - - 'VT340 ', 2604, 1, 1, 222 - - 'VT340_COLOUR ', 2505, 1, 1, 223 - - '4010 ', 2500, 1, 1, 224 - - 'COMP_4010 ', 2501, 1, 1, 225 - - '4014 ', 2400, 1, 1/ 226 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=11,20)/ 227 - - '4105 ', 2300, 1, 1, 228 - - 'PIX_4105 ', 2301, 1, 1, 229 - - 'COMP_4105 ', 2302, 1, 1, 230 - - '4107 ', 3100, 1, 1, 231 - - '12B_4107 ', 3101, 1, 1, 232 - - '4205 ', 3102, 1, 1, 233 - - '12B_4205 ', 3103, 1, 1, 234 - - '4208 ', 3104, 1, 1, 235 - - '12B_4208 ', 3105, 1, 1, 236 - - '4111 ', 3200, 1, 1/ 237 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=21,30)/ 238 - - '32B_4111 ', 3201, 1, 1, 239 - - '4115 ', 3202, 1, 1, 240 - - '32B_4115 ', 3203, 1, 1, 241 - - '4125 ', 3204, 1, 1, 242 - - '32B_4125 ', 3205, 1, 1, 243 - - 'CIT_414A ', 2502, 1, 1, 244 - - 'GRAPHON ', 2506, 1, 1, 245 - - 'LAND_IMG ', 6300, 1, 1, 246 - - 'PORT_IMG ', 6301, 1, 1, 247 - - 'RETRO ', 3203, 1, 1/ 248 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=31,40)/ 249 - - 'X11 ', 5300, 1, 1, 250 - - 'X_WINDOWS ', 5300, 1, 1, 251 - - 'BS_X11 ', 5350, 1, 1, 252 - - 'CGM_BIN ', 10100, 100, -1, 253 - - 'CGM_MBIN ', 10101, 100, -1, 254 - - 'CGM_CHAR ', 10110, 200, -1, 255 - - 'CGM_TEXT ', 10120, 300, -1, 256 - - 'CGM_LBIN ', 10150, 100, -1, 257 - - 'CGM_LCHAR ', 10160, 200, -1, 258 - - 'CGM_LTEXT ', 10170, 300, -1/ 259 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=41,NTYP)/ 260 - - 'PS_PORTRAIT_COLOUR ', 1900, 400, -1, 261 - - '*batch_default ', 1900, 400, -1, 262 - - 'PS_LANDSCAPE_COLOUR ', 1901, 400, -1, 263 - - 'PS_LANDSCAPE_BW ', 1901, 400, -1, 264 - - 'PS_PORTRAIT_BW ', 1900, 400, -1, 265 - - 'POSTSCRIPT ', 1900, 400, -1, 266 - - 'EPS_PORTRAIT_COLOUR ', 1900, 400, -1, 267 - - 'EPS_LANDSCAPE_COLOUR', 1901, 400, -1, 268 - - 'EPS_LANDSCAPE_BW ', 1901, 400, -1, 269 - - 'EPS_PORTRAIT_BW ', 1900, 400, -1, 270 - - 'ENCAPSULATED_PS ', 1900, 400, -1/ 0 271-+ +SELF,IF=HIGZ. (From Zhengyong Feng) 272 - PARAMETER(NTYP=33) 273 - INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) 274 - CHARACTER*20 TYPE(NTYP) 275 - DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,NTYP)/ 276 - - '0 ', 0, 0, 1, 277 - - 'NONE ', 0, 0, 1, 278 - - 'none ', 0, 0, 1, 279 - - 'INQUIRE ', -1, 0, 1, 280 - - 'inquire ', -1, 0, 1, 281 - - '*interactive_default', -1, 0, 1, 282 - - '1 ', 1, 0, 1, 283 - - '2 ', 2, 0, 1, 284 - - '3 ', 3, 0, 1, 285 - - '4 ', 4, 0, 1, 286 - - '5 ', 5, 0, 1, 287 - - '6 ', 6, 0, 1, 288 - - '7 ', 7, 0, 1, 289 - - '8 ', 8, 0, 1, 290 - - '9 ', 9, 0, 1, 291 - - '7878 ', 7878, 0, 1, 292 - - 'FALCO ', 7878, 0, 1, 293 - - 'Falco ', 7878, 0, 1, 294 - - 'XTERM ', 7879, 0, 1, 295 - - 'PS_LANDSCAPE ', -112, 0, -1, 296 - - 'PS_landscape ', -112, 0, -1, 297 - - 'PS_PORTRAIT ', -111, 0, -1, 298 - - 'PS_portrait ', -111, 0, -1, 299 - - 'POSTSCRIPT ', -111, 0, -1, 300 - - 'PostScript ', -111, 0, -1, 301 - - '*batch_default ', -111, 0, -1, 302 - - 'EPS ', -113, 0, -1, 303 - - 'ENCAPSULATED_PS ', -113, 0, -1, 304 - - 'encapsulated_PS ', -113, 0, -1, 305 - - 'ENCAPSULATED_POSTSCR', -113, 0, -1, 306 - - 'encapsulated_PostScr', -113, 0, -1, 307 - - 'LATEX ', -777, 0, -1, 308 - - 'LaTeX ', -777, 0, -1/ 1 184 P=GRAPHICS D=GRWKID 4 PAGE 297 309-+ +SELF. 310 - *** Preset the workstation and logical unit offset to 0. 311 - IWKID=0 312 - LUNOFF=0 313 - *** Assume the routine will fail. 314 - IFAIL=1 315 - *** If NTYP has been set to 0, we don't recognise anything. 316 - IF(NTYP.EQ.0)THEN 317 - PRINT *,' !!!!!! GRWKID WARNING : No workstation type'// 318 - - ' list is available; no identifier returned.' 319 - IFAIL=1 320 - RETURN 321 - ENDIF 322 - *** Calculate the length of the workstation name. 323 - LENNAM=0 324 - DO 30 I=1,LEN(NAME) 325 - IF(NAME(I:I).NE.' ')LENNAM=I 326 - 30 CONTINUE 327 - *** Warn if the name is blank. 328 - IF(LENNAM.EQ.0)THEN 329 - PRINT *,' !!!!!! GRWKID WARNING : The workstation type'// 330 - - ' is blank; no identifier returned.' 331 - IFAIL=1 332 - RETURN 333 - ENDIF 334 - *** Scan the list of known workstaion names. 335 - IFOUND=0 336 - NFOUND=0 337 - DO 10 I=1,NTYP 338 - IF(NAME(1:LENNAM).EQ.TYPE(I)(1:LENNAM))THEN 339 - IFOUND=I 340 - NFOUND=NFOUND+1 341 - ENDIF 342 - 10 CONTINUE 343 - *** Warn if not known. 344 - IF(NFOUND.EQ.0)THEN 345 - PRINT *,' !!!!!! GRWKID WARNING : ',NAME(1:LENNAM), 346 - - ' is not a known workstation type.' 347 - IFAIL=1 348 - RETURN 349 - *** Inform about the choice if ambiguous. 350 - ELSEIF(NFOUND.GT.1)THEN 351 - NCPRT=1 352 - DO 20 J=20,1,-1 353 - IF(TYPE(IFOUND)(J:J).NE.' '.AND.NCPRT.EQ.1)NCPRT=J 354 - 20 CONTINUE 355 - PRINT *,' ------ GRWKID MESSAGE : ',NAME(1:LENNAM), 356 - - ' is an ambiguous workstation type; choosing '// 357 - - TYPE(IFOUND)(1:NCPRT)//'.' 358 - ENDIF 359 - *** Normal assignment. 360 - IWKID=ITYP(IFOUND) 361 - LUNOFF=IOFF(IFOUND) 362 - *** Determine the workstation category. 363 - CALL GQWKCA(IWKID,IERR,ICAT) 364 - IF(IERR.EQ.8)THEN 365 - IF(INOUT(IFOUND).EQ.1)THEN 366 - ICAT=2 367 - ELSE 368 - ICAT=4 369 - ENDIF 370 - ELSEIF(IERR.NE.0)THEN 371 - PRINT *,' !!!!!! GRWKID WARNING : ',NAME(1:LENNAM), 372 - - ' is not recognised by GKS as a valid workstation.' 373 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRWKID DEBUG :'', 374 - - '' GQWKCA Error code '',I3,'', category '',I1, 375 - - '' for wktype '',I5,''.'')') IERR,ICAT,IWKID 376 - ICAT=-1 377 - IFAIL=1 378 - ENDIF 379 - *** Things seem to have worked. 380 - IFAIL=0 381 - END 185 GARFIELD ================================================== P=GKSHIGZ D= 1 ============================ 0 + +PATCH,GKSHIGZ,IF=HIGZ. 1 - C 2 - C ***************************************************************************** 3 - C * * 4 - C * The goal of this package is using HIGZ to replace GKS in GARFIELD. * 5 - C * It has been tested with SGI/UNIX and HP/UNIX systems. I don't think * 6 - C * there will be big difficulties when use other systems, since HIGZ is * 7 - C * a standard CERNLIB package. By using HIGZ, with this preliminary * 8 - C * version of HIGZ/GKS/GARFIELD, the positions of texts on screen and in * 9 - C * .ps file are not same. The text positions in ps file, by printing, are * 10 - C * mostly expected. However, it needs more work. Some functions of original* 11 - C * GARFIELD are still missing, specially the PICK functions. TEXT and PICK * 12 - C * functions will be the next steps of the work. * 13 - C * * 14 - C * Some subroutines of GARFIELD/GRAPHICS are also modified to reflect HIGZ * 15 - C * use, with flag of HIGZ. They are: * 16 - C * * 17 - C * JOBLOG, DSNOPN * 18 - C * GRINIT, GRNEXT, GRWKID, GRCLAB, GRCUPD * 19 - C * GRACWK, GRADWK, GRMETA, GROPWK, GRTERM * 20 - C * * 21 - C * Zhengyong Feng * 22 - C * University of Washington * 23 - C * Apr. 25, 1994 * 24 - C * * 25 - C ***************************************************************************** 26 - C 1 186 GARFIELD ================================================== P=GKSHIGZ D=GCLSG 1 =================== PAGE 298 0 + +DECK,GCLSG. 1 - SUBROUTINE GCLSG 2 - CALL GUWK(1,0) 3 - RETURN 4 - END 187 GARFIELD ================================================== P=GKSHIGZ D=GCRSG 1 ============================ 0 + +DECK,GCRSG. 1 - SUBROUTINE GCRSG(ISEG) 2 - RETURN 3 - END 188 GARFIELD ================================================== P=GKSHIGZ D=GDSG 1 ============================ 0 + +DECK,GDSG. 1 - SUBROUTINE GDSG(ISEG) 2 - RETURN 3 - END 189 GARFIELD ================================================== P=GKSHIGZ D=GINCH 1 ============================ 0 + +DECK,GINCH. 1 - SUBROUTINE GINCH(KWKID,LCDNR,ISTAT,ICH,IPET,XMIN,XMAX, 2 - + YMIN,YMAX,LDR,DATREC) 3 - CHARACTER*80 DATREC(LDR) 4 - RETURN 5 - END 190 GARFIELD ================================================== P=GKSHIGZ D=GINLC 1 ============================ 0 + +DECK,GINLC. 1 - SUBROUTINE GINLC(KWKID,LCDNR,ITR,PX,PY,IPET,XMIN,XMAX, 2 - + YMIN,YMAX,LDR,DATREC) 3 - CHARACTER*80 DATREC(LDR) 4 - RETURN 5 - END 191 GARFIELD ================================================== P=GKSHIGZ D=GINPK 1 ============================ 0 + +DECK,GINPK. 1 - SUBROUTINE GINPK(KWKID,LCDNR,ISTAT,ISEG,IPICK,IPET,XMIN,XMAX, 2 - + YMIN,YMAX,LDR,DATREC) 3 - CHARACTER*80 DATREC(LDR) 4 - RETURN 5 - END 192 GARFIELD ================================================== P=GKSHIGZ D=GINSK 1 ============================ 0 + +DECK,GINSK. 1 - SUBROUTINE GINSK(KWKID,LCDNR,ITR,N,PX,PY,IPET,XMIN,XMAX, 2 - + YMIN,YMAX,LENBUF,LDR,DATREC) 3 - CHARACTER*80 DATREC(LDR) 4 - DIMENSION PX(N),PY(N) 5 - RETURN 6 - END 193 GARFIELD ================================================== P=GKSHIGZ D=GINVL 1 ============================ 0 + +DECK,GINVL. 1 - SUBROUTINE GINVL(KWKID,LCDNR,VAL,IPET,XMIN,XMAX, 2 - + YMIN,YMAX,VALLOW,VALHIG,LDR,DATREC) 3 - CHARACTER*80 DATREC(LDR) 4 - RETURN 5 - END 194 GARFIELD ================================================== P=GKSHIGZ D=GPREC 1 ============================ 0 + +DECK,GPREC. 1 - SUBROUTINE GPREC(LI,IA,LR,RA,LS,LSTR,STR,MDL,IERR,LD,D) 2 - implicit none 3 - INTEGER LI,IA(LI),LR,LS,LSTR,MDL,IERR,LD 4 - CHARACTER*(*) STR(LS),D(LD) 5 - REAL RA(LR) 6 - IERR=0 7 - RETURN 8 - END 195 GARFIELD ================================================== P=GKSHIGZ D=GSASF 1 ============================ 0 + +DECK,GSASF. 1 - SUBROUTINE GSASF(LASF) 2 - *----------------------------------------------------------------------- 3 - * GSASF - Set aspect source flag, not available in HIGZ. 4 - * (Last changed on 30/ 6/95.) 5 - *----------------------------------------------------------------------- 6 - INTEGER LASF(13) 7 - END 196 GARFIELD ================================================== P=GKSHIGZ D=GSCHSP 1 ============================ 0 + +DECK,GSCHSP. 1 - SUBROUTINE GSCHSP(CHSP) 2 - *----------------------------------------------------------------------- 3 - * GSCHSP - Set character spacing, not available in HIGZ. 4 - * (Last changed on 30/ 6/95.) 5 - *----------------------------------------------------------------------- 6 - REAL CHSP 7 - END 197 GARFIELD ================================================== P=GKSHIGZ D=GSCHXP 1 ============================ 0 + +DECK,GSCHXP. 1 - SUBROUTINE GSCHXP(SZSF) 2 - *----------------------------------------------------------------------- 3 - * GSCHXP - Set character expansion factor, imitated in HIGZ. 1 197 P=GKSHIGZ D=GSCHXP 2 PAGE 299 4 - * (Last changed on 30/ 6/95.) 5 - *----------------------------------------------------------------------- 6 - REAL SZSF 7 - COMMON /CHXP/CHXP0 8 - IF(SZSF.LT.0.)SZSF=1.0 9 - CHXP0=SZSF 10 - CALL IGQ('CHHE',HEIT) 11 - CHH = HEIT*SZSF 12 - CALL ISCHH(CHH) 13 - END 198 GARFIELD ================================================== P=GKSHIGZ D=GSTXP 1 ============================ 0 + +DECK,GSTXP. 1 - SUBROUTINE GSTXP(IRL) 2 - *----------------------------------------------------------------------- 3 - * GSTXP - Set the text path, limited availability in HIGZ. 4 - * (Last changed on 30/ 6/95.) 5 - *----------------------------------------------------------------------- 6 - IF(IRL.LT.0 .OR. IRL.GT.3)IRL=0 7 - IF(IRL.EQ.0)CALL ISTXAL(0,0) 8 - IF(IRL.EQ.1)CALL ISTXAL(3,0) 9 - IF(IRL.EQ.2)CALL ISTXAL(0,1) 10 - IF(IRL.EQ.3)CALL ISTXAL(0,3) 11 - END 199 GARFIELD ================================================== P=GKSHIGZ D=GMSG 1 ============================ 0 + +DECK,GMSG. 1 - SUBROUTINE GMSG(IWK,TEXT) 2 - *----------------------------------------------------------------------- 3 - * GMSG - Displays a message. 4 - * (Last changed on 2/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - CHARACTER*(*) TEXT 7 - PRINT *,' Graphics: ',TEXT 8 - END 200 GARFIELD ================================================== P=GKSHIGZ D=GQACWK 1 ============================ 0 + +DECK,GQACWK. 1 - SUBROUTINE GQACWK(I,IERR,NACT,IWK) 2 - *----------------------------------------------------------------------- 3 - * GQACWK - Returns the active workstation list. 4 - * (Last changed on 17/ 6/95.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,GRAPHICS. 8 - *** Initial values. 9 - NACT=0 10 - IWK=0 11 - IERR=0 12 - *** Loop over the workstation table. 13 - DO 10 J=1,NWK 14 - * Found an active workstation: return number and increment counter. 15 - IF(WKSTAT(J).GE.3)THEN 16 - NACT=NACT+1 17 - IF(NACT.EQ.I)IWK=J 18 - ENDIF 19 - 10 CONTINUE 20 - END 201 GARFIELD ================================================== P=GKSHIGZ D=GQCF 1 ============================ 0 + +DECK,GQCF. 1 - SUBROUTINE GQCF(IWKTYP,IERR,NCOLS,ICOLS,NPRE) 2 - *----------------------------------------------------------------------- 3 - * GQCF - Returns information on colour facilities. 4 - * (Last changed on 2/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - INTEGER IERR,NCOLS,ICOLS,NPRE,IWKTYP 8 - *** No idea, so return generous values. 9 - IERR=0 10 - NCOLS=10 11 - ICOLS=1 12 - NPRE=2 13 - END 202 GARFIELD ================================================== P=GKSHIGZ D=GQCHH 1 ============================ 0 + +DECK,GQCHH. 1 - SUBROUTINE GQCHH(IERR,CHH) 2 - *----------------------------------------------------------------------- 3 - * GQCHH - Returns the current character height. 4 - * (Last changed on 19/ 6/95.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - INTEGER IERR 8 - REAL CHH 9 - *** Set the error flag. 10 - IERR=0 11 - *** Call IGQ to determine the character size. 12 - CALL IGQ('CHHE',CHH) 13 - END 203 GARFIELD ================================================== P=GKSHIGZ D=GQCHUP 1 ============================ 0 + +DECK,GQCHUP. 1 - SUBROUTINE GQCHUP(IERR,XUP,YUP) 2 - *----------------------------------------------------------------------- 3 - * GQCHUP - Returns the current character up vector. 4 - * (Last changed on 16/ 5/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 1 203 P=GKSHIGZ D=GQCHUP 2 PAGE 300 7.- +SEQ,CONSTANTS. 8 - INTEGER IERR 9 - REAL XUP,YUP,RANGLE 10 - *** Set the error flag. 11 - IERR=0 12 - *** Call IGQ to obtain the text orientation. 13 - CALL IGQ('TANG',RANGLE) 14 - *** And compute up vector. 15 - XUP=COS(PI*(RANGLE+90)/180) 16 - YUP=SIN(PI*(RANGLE+90)/180) 17 - END 204 GARFIELD ================================================== P=GKSHIGZ D=GQCHXP 1 ============================ 0 + +DECK,GQCHXP. 1 - SUBROUTINE GQCHXP(IERR,CHEXP) 2 - *----------------------------------------------------------------------- 3 - * GQCHXP - Returns the current character expansion factor. 4 - * (Last changed on 2/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - INTEGER IERR 8 - REAL CHEXP 9 - *** Return by default an expansion factor of 1. 10 - IERR=0 11 - CHEXP=1.0 12 - END 205 GARFIELD ================================================== P=GKSHIGZ D=GQCHW 1 ============================ 0 + +DECK,GQCHW. 1 - SUBROUTINE GQCHW(IERR,CHW) 2 - *----------------------------------------------------------------------- 3 - * GQCHW - Returns the current width. 4 - * (Last changed on 2/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - INTEGER IERR 8 - REAL CHW 9 - *** We don't know the width. 10 - IERR=1 11 - CHW=0.01 12 - END 206 GARFIELD ================================================== P=GKSHIGZ D=GQCNTN 1 ============================ 0 + +DECK,GQCNTN. 1 - SUBROUTINE GQCNTN(IERR,NT) 2 - *----------------------------------------------------------------------- 3 - * GQCNTN - Returns the current normalisation transformation. 4 - * (Last changed on 19/ 6/95.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - REAL AUX 8 - INTEGER IERR,NT 9 - *** Set the error flag. 10 - IERR=0 11 - *** Find out what the current normalisation transformation is. 12 - CALL IGQWK(0,'NTNB',AUX) 13 - NT=NINT(AUX) 14 - END 207 GARFIELD ================================================== P=GKSHIGZ D=GQDSP 1 ============================ 0 + +DECK,GQDSP. 1 - SUBROUTINE GQDSP(IWKTYP,IERR,IUNIT,RX,RY,LX,LY) 2 - *----------------------------------------------------------------------- 3 - * GQDSP - Returns the screen size. 4 - * (Last changed on 6/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - INTEGER IWKTYP,IERR,IUNIT,LX,LY 8 - REAL RX,RY 9 - *** We don't know this. 10 - IERR=1 11 - *** Return some parameters nevertheless. 12 - IUNIT=1 13 - RX=1.0 14 - RY=1.0 15 - LX=1 16 - LY=1 17 - END 208 GARFIELD ================================================== P=GKSHIGZ D=GQFACI 1 ============================ 0 + +DECK,GQFACI. 1 - SUBROUTINE GQFACI(IERR,ICOL) 2 - *----------------------------------------------------------------------- 3 - * GQFACI - Inquiry of current fill area colour. 4 - * (Last changed on 29/11/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - INTEGER IERR,ICOL 8 - REAL RCOL 9 - *** Call the HIGZ function. 10 - CALL IGQ('FACI',RCOL) 11 - *** Convert to integer. 12 - ICOL=NINT(RCOL) 13 - *** Set the error flag. 14 - IERR=0 15 - END 1 209 GARFIELD ================================================== P=GKSHIGZ D=GQLVKS 1 =================== PAGE 301 0 + +DECK,GQLVKS. 1 - SUBROUTINE GQLVKS(IERR,LEVEL) 2 - *----------------------------------------------------------------------- 3 - * GQLVKS - Returns the GKS level. 4 - * (Last changed on 17/ 6/95.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - INTEGER IERR,LEVEL 8 - *** HIGZ is not reall a GKS, so return a non-existing value. 9 - IERR=0 10 - LEVEL=8 11 - END 210 GARFIELD ================================================== P=GKSHIGZ D=GQLWK 1 ============================ 0 + +DECK,GQLWK. 1 - SUBROUTINE GQLWK(IWKTYP,IERR,MPL,MPM,MTX,MFA,MPA,MXCOLI) 2 - *----------------------------------------------------------------------- 3 - * GQLWK - Returns properties of the workstation. 4 - * (Last changed on 2/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - INTEGER IWKTYP,IERR,MPL,MPM,MTX,MFA,MPA,MXCOLI 8 - *** Not known, but we don't really need accurate information either. 9 - IERR=0 10 - *** Return generous settings. 11 - MPL=100 12 - MPM=100 13 - MTX=100 14 - MFA=100 15 - MPA=100 16 - MXCOLI=100 17 - END 211 GARFIELD ================================================== P=GKSHIGZ D=GQNT 1 ============================ 0 + +DECK,GQNT. 1 - SUBROUTINE GQNT(NT,IERR,WINDOW,VIEWPT) 2 - *----------------------------------------------------------------------- 3 - * GQNT - Returns information about normalisation transformations. 4 - * (Last changed on 19/ 6/95.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - REAL WINDOW(4),VIEWPT(4) 8 - INTEGER IERR,NT 9 - *** Call IGQWK to find out. 10 - CALL IGQWK(0,'NTWN',WINDOW) 11 - CALL IGQWK(0,'NTVP',VIEWPT) 12 - *** Set the error indicator. 13 - IERR=0 14 - END 212 GARFIELD ================================================== P=GKSHIGZ D=GQOPS 1 ============================ 0 + +DECK,GQOPS. 1 - SUBROUTINE GQOPS(IOPS) 2 - *----------------------------------------------------------------------- 3 - * GQOPS - Returns the GKS operating state. 4 - * (Last changed on 17/ 6/95.) 5 - *----------------------------------------------------------------------- 6 - INTEGER IOPS,IERR1,IERR2,NACT,NOP,IWK 7 - *** Count number of open and active workstations. 8 - CALL GQACWK(0,IERR1,NACT,IWK) 9 - CALL GQOPWK(0,IERR2,NOP,IWK) 10 - *** Depending on the result, return the state. 11 - IF(NACT.GE.1)THEN 12 - IOPS=3 13 - ELSEIF(NOP.GE.1)THEN 14 - IOPS=2 15 - ELSE 16 - IOPS=1 17 - ENDIF 18 - END 213 GARFIELD ================================================== P=GKSHIGZ D=GQOPWK 1 ============================ 0 + +DECK,GQOPWK. 1 - SUBROUTINE GQOPWK(I,IERR,NOP,IWK) 2 - *----------------------------------------------------------------------- 3 - * GQOPWK - Returns the list of open workstations. 4 - * (Last changed on 17/ 6/95.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,GRAPHICS. 8 - *** Initial values. 9 - NOP=0 10 - IWK=0 11 - IERR=0 12 - *** Loop over the workstation table. 13 - DO 10 J=1,NWK 14 - * Found an active workstation: return number and increment counter. 15 - IF(WKSTAT(J).GE.2)THEN 16 - NOP=NOP+1 17 - IF(NOP.EQ.I)IWK=J 18 - ENDIF 19 - 10 CONTINUE 20 - END 214 GARFIELD ================================================== P=GKSHIGZ D=GQTXAL 1 ============================ 0 + +DECK,GQTXAL. 1 - SUBROUTINE GQTXAL(IERR,ITXALH,ITXALV) 2 - *----------------------------------------------------------------------- 3 - * GQTXAL - Returns the current text alignment. 4 - * (Last changed on 19/ 6/95.) 5 - *----------------------------------------------------------------------- 1 214 P=GKSHIGZ D=GQTXAL 2 PAGE 302 6 - REAL RVAL(2) 7 - INTEGER IERR,ITXALH,ITXALV 8 - *** Set the error flag. 9 - IERR=0 10 - *** Inquire. 11 - CALL IGQ('TXAL',RVAL) 12 - *** Set the alignments. 13 - ITXALH=RVAL(1) 14 - ITXALV=RVAL(2) 15 - END 215 GARFIELD ================================================== P=GKSHIGZ D=GQTXX 1 ============================ 0 + +DECK,GQTXX. 1 - SUBROUTINE GQTXX(IWK,X,Y,TEXT,IERR,CPX,CPY,XBOX,YBOX) 2 - *----------------------------------------------------------------------- 3 - * GQTXX - Returns the text extent, HIGZ version. Currently not able 4 - * to get the box directly from HIGZ, but try to do something 5 - * reasonable using the character height. 6 - * (Last changed on 28/ 1/00.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,PRINTPLOT. 10 - REAL X,Y,CPX,CPY,XBOX(*),YBOX(*),CHH,CHW,XUP,YUP,XOFF,YOFF,PHI, 11 - - XNEW,YNEW 12 - INTEGER IWK,IERR,ITXALH,ITXALV,I 13 - CHARACTER*(*) TEXT 14 - *** Try to get some reasonable estimate of the character size. 15 - CALL GQCHH(IERR,CHH) 16 - IF(IERR.NE.0)CHH=0.02 17 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GQTXX DEBUG : Height: '', 18 - - F10.3,'', ierr='',I5)') CHH,IERR 19 - CALL GQCHW(IERR,CHW) 20 - IF(IERR.NE.0)CHW=0.8*CHH 21 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GQTXX DEBUG : Width: '', 22 - - F10.3,'', ierr='',I5)') CHW,IERR 23 - *** Find out what the alignment is like. 24 - CALL GQTXAL(IERR,ITXALH,ITXALV) 25 - *** Compute from this what the x and y offsets are. 26 - IF(ITXALH.EQ.2)THEN 27 - XOFF=0.5*CHW*LEN(TEXT) 28 - ELSEIF(ITXALH.EQ.3)THEN 29 - XOFF=CHW*LEN(TEXT) 30 - ELSE 31 - XOFF=0 32 - ENDIF 33 - IF(ITXALV.EQ.1.OR.ITXALV.EQ.2)THEN 34 - YOFF=CHH 35 - ELSEIF(ITXALV.EQ.3)THEN 36 - YOFF=0.5*CHH 37 - ELSE 38 - YOFF=0 39 - ENDIF 40 - *** Construct a first box. 41 - XBOX(1)=-XOFF 42 - XBOX(2)=-XOFF 43 - XBOX(3)=CHW*LEN(TEXT)-XOFF 44 - XBOX(4)=CHW*LEN(TEXT)-XOFF 45 - YBOX(1)=-YOFF-0.2*CHH 46 - YBOX(2)=CHH-YOFF 47 - YBOX(3)=CHH-YOFF 48 - YBOX(4)=-YOFF-0.2*CHH 49 - *** Determine the character up vector. 50 - CALL GQCHUP(IERR,XUP,YUP) 51 - IF(IERR.NE.0.OR.XUP**2+YUP**2.LE.0)THEN 52 - XUP=0 53 - YUP=1 54 - ENDIF 55 - PHI=ATAN2(YUP,XUP) 56 - *** And rotate the box in place, translating it too. 57 - DO 10 I=1,4 58 - XNEW=+SIN(PHI)*XBOX(I)+COS(PHI)*YBOX(I) 59 - YNEW=-COS(PHI)*XBOX(I)+SIN(PHI)*YBOX(I) 60 - XBOX(I)=XNEW+X 61 - YBOX(I)=YNEW+Y 62 - 10 CONTINUE 63 - *** Definre the concatenation point. 64 - CPX=XBOX(4)+XOFF 65 - CPY=YBOX(4)+YOFF 66 - *** And set the error flag to "success". 67 - IERR=0 68 - *** Debugging output. 69 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GQTXX DEBUG :'', 70 - - '' String: "'',A,''"''/ 71 - - 26X,''x-box: '',4F10.3/26X,''y-box: '',4F10.3)') 72 - - TEXT,(XBOX(I),I=1,4),(YBOX(I),I=1,4) 73 - END 216 GARFIELD ================================================== P=GKSHIGZ D=GQWKC 1 ============================ 0 + +DECK,GQWKC. 1 - SUBROUTINE GQWKC(IWK,IERR,ICONID,IWKTYP) 2 - *----------------------------------------------------------------------- 3 - * GQWKC - Returns connection and type of workstation IWK. 4 - * (Last changed on 17/ 6/95.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,GRAPHICS. 8 - IWKTYP=0 9 - ICONID=0 10 - *** Return if this workstation is out of range. 11 - IF(IWK.LT.1.OR.IWK.GT.NWK)THEN 12 - IERR=20 13 - RETURN 14 - ENDIF 15 - *** Make sure the workstation is actually open. 1 216 P=GKSHIGZ D=GQWKC 2 PAGE 303 16 - IF(WKSTAT(IWK).LT.2)THEN 17 - IERR=25 18 - RETURN 19 - ENDIF 20 - *** Now return the information. 21 - ICONID=WKCON(IWK) 22 - IWKTYP=WKID(IWK) 23 - IERR=0 24 - END 217 GARFIELD ================================================== P=GKSHIGZ D=GQWKCA 1 ============================ 0 + +DECK,GQWKCA. 1 - SUBROUTINE GQWKCA(IWKID,IERR,ICAT) 2 - *----------------------------------------------------------------------- 3 - * GQWKCA - Returns the workstation category. 4 - * (Last changed on 5/ 2/97.) 5 - *----------------------------------------------------------------------- 6 - INTEGER IWKID,IERR,ICAT 7 - *** Initial values. 8 - ICAT=0 9 - IERR=0 10 - *** No output. 11 - IF(IWKID.EQ.-1)THEN 12 - ICAT=2 13 - *** Described in higzwindows.dat 14 - ELSEIF(IWKID.GE.0.AND.IWKID.LE.10)THEN 15 - ICAT=2 16 - *** Falco. 17 - ELSEIF(IWKID.GE.7878)THEN 18 - ICAT=2 19 - *** xterm. 20 - ELSEIF(IWKID.GE.7879)THEN 21 - ICAT=2 22 - *** Various PS formats. 23 - ELSEIF(IWKID.EQ. -111.OR.IWKID.EQ. -112.OR. 24 - - IWKID.EQ. -3111.OR.IWKID.EQ. -3112.OR. 25 - - IWKID.EQ. -99111.OR.IWKID.EQ. -99112.OR. 26 - - IWKID.EQ.-100111.OR.IWKID.EQ.-100112.OR. 27 - - IWKID.EQ.-200111.OR.IWKID.EQ.-200112.OR. 28 - - IWKID.EQ.-300111.OR.IWKID.EQ.-300112.OR. 29 - - IWKID.EQ.-300111.OR.IWKID.EQ.-300112)THEN 30 - ICAT=4 31 - *** EPS format. 32 - ELSEIF(IWKID.EQ.-113)THEN 33 - ICAT=4 34 - *** LaTeX format. 35 - ELSEIF(IWKID.EQ.-777)THEN 36 - ICAT=4 37 - *** Other values are not known. 38 - ELSE 39 - IERR=1 40 - ENDIF 41 - END 218 GARFIELD ================================================== P=GKSHIGZ D=GQWKDU 1 ============================ 0 + +DECK,GQWKDU. 1 - SUBROUTINE GQWKDU(I,IERR,IDEFM,IREGM,IEMPTY,IFRAME) 2 - *----------------------------------------------------------------------- 3 - * GQWKDU - Returns deferral and update state for a workstation. 4 - * (Last changed on 2/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - IERR=0 7 - IDEFM=0 8 - IREGM=0 9 - IEMPTY=0 10 - IFRAME=0 11 - END 219 GARFIELD ================================================== P=GKSHIGZ D=GQWKM 1 ============================ 0 + +DECK,GQWKM. 1 - SUBROUTINE GQWKM(IERR,MXOPWK,MXACWK,MXWKAS) 2 - *----------------------------------------------------------------------- 3 - * GQWKM - Returns workstation maxima. 4 - * (Last changed on 2/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - IERR=0 7 - MXOPWK=10 8 - MXACWK=10 9 - MXWKAS=10 10 - END 220 GARFIELD ================================================== P=GKSHIGZ D=GQWKS 1 ============================ 0 + +DECK,GQWKS. 1 - SUBROUTINE GQWKS(IWK,IERR,ISTATE) 2 - *----------------------------------------------------------------------- 3 - * GQWKS - Returns the state of a workstation. 4 - * (Last changed on 29/10/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GRAPHICS. 9 - INTEGER IWK,IERR,ISTATE 10 - *** Default state: not active. 11 - ISTATE=-1 12 - IERR=0 13 - *** Check validity of workstation number. 14 - IF(IWK.LT.1.OR.IWK.GT.NWK)THEN 15 - IERR=20 16 - RETURN 17 - ENDIF 18 - *** Make sure the workstation is actually open. 19 - IF(WKSTAT(IWK).LT.2)THEN 1 220 P=GKSHIGZ D=GQWKS 2 PAGE 304 20 - IERR=25 21 - RETURN 22 - ENDIF 23 - *** Look in workstation table to determine the state. 24 - IF(WKSTAT(IWK).LE.2)THEN 25 - ISTATE=0 26 - ELSE 27 - ISTATE=1 28 - ENDIF 29 - END 221 GARFIELD ================================================== P=GKSHIGZ D=GRQCH 1 ============================ 0 + +DECK,GRQCH. 1 - SUBROUTINE GRQCH(IWKCH,IDEVCH,IERR,ICHOIC) 2 - *----------------------------------------------------------------------- 3 - * GRQCH - Request choice input. 4 - * (Last changed on 2/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - IERR=1 7 - ICHOIC=0 8 - END 222 GARFIELD ================================================== P=GKSHIGZ D=GRQPK 1 ============================ 0 + +DECK,GRQPK. 1 - SUBROUTINE GRQPK(IWKPK,IDEVPK,IERR,ISGNA,IPCID) 2 - *----------------------------------------------------------------------- 3 - * GRQPK - Request pick input. 4 - * (Last changed on 2/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - IERR=1 7 - ISGNA=0 8 - IPCID=0 9 - END 223 GARFIELD ================================================== P=GKSHIGZ D=GRQVL 1 ============================ 0 + +DECK,GRQVL. 1 - SUBROUTINE GRQVL(IWKVL,IDEVVL,IERR,VAL) 2 - *----------------------------------------------------------------------- 3 - * GRQVL - Requests valuator input. 4 - * (Last changed on 2/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - IERR=1 7 - VAL=0.0 8 - end 224 GARFIELD ================================================== P=GKSHIGZ D=GSDS 1 ============================ 0 + +DECK,GSDS. 1 - SUBROUTINE GSDS(IWK,IDEF,IUPD) 2 - *----------------------------------------------------------------------- 3 - * GSDS - Set deferral and update state. 4 - * (Last changed on 2/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - END 225 GARFIELD ================================================== P=GKSHIGZ D=GSDTEC 1 ============================ 0 + +DECK,GSDTEC. 1 - SUBROUTINE GSDTEC(I,J) 2 - *----------------------------------------------------------------------- 3 - * GSDTEC - Segment detectability. 4 - * (Last changed on 2/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - END 226 GARFIELD ================================================== P=GKSHIGZ D=GSPA 1 ============================ 0 + +DECK,GSPA. 1 - SUBROUTINE GSPA(X,Y) 2 - *----------------------------------------------------------------------- 3 - * GSPA - Sets fill area pattern pattern size. 4 - * (Last changed on 2/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - END 227 GARFIELD ================================================== P=GKSHIGZ D=GSPARF 1 ============================ 0 + +DECK,GSPARF. 1 - SUBROUTINE GSPARF(X,Y) 2 - *----------------------------------------------------------------------- 3 - * GSPARF - Sets fill area pattern reference point. 4 - * (Last changed on 2/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - END 228 GARFIELD ================================================== P=GKSHIGZ D=GSPKID 1 ============================ 0 + +DECK,GSPKID. 1 - SUBROUTINE GSPKID(ID) 2 - *----------------------------------------------------------------------- 3 - * GSPKID - Sets the pick identifier. 4 - * (Last changed on 2/ 4/95.) 5 - *----------------------------------------------------------------------- 6 - END 229 GARFIELD ================================================== P=GKSHIGZ D=GSVPIP 1 ============================ 0 + +DECK,GSVPIP. 1 - SUBROUTINE GSVPIP(I,J,K) 2 - *----------------------------------------------------------------------- 3 - * GSVPIP - Sets the viewport input priority. 4 - * (Last changed on 2/ 4/95.) 5 - *----------------------------------------------------------------------- 1 229 P=GKSHIGZ D=GSVPIP 2 PAGE 305 6 - END 230 GARFIELD ================================================== P=GKSHIGZ D=SGFLAG 1 ============================ 0 + +DECK,SGFLAG. 1 - SUBROUTINE SGFLAG 2 - *----------------------------------------------------------------------- 3 - * SGFLAG - Sets GFLAG in HIGZ according to the workstations active. 4 - * (Last changed on 18/ 6/95.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,PRINTPLOT 7 - *KEEP,HIFLAG. 8 - *CMZ : 1.21/05 16/06/94 14.37.23 by O.Couet 9 - *-- Author : 10 - COMMON /HIFLAG/ GFLAG,GLFLAG,ZFLAG,PFLAG,MFLAG,TFLAG 11 - +,ASFLAG,GRFLAG,AXFLAG,CFLAG 12 - LOGICAL GFLAG,GLFLAG,ZFLAG,PFLAG,MFLAG,TFLAG 13 - +,ASFLAG,GRFLAG,AXFLAG,CFLAG 14 - *** Disable temporarily. 15 - C return 16 - *** Initial setting. 17 - GFLAG=.FALSE. 18 - *** Determine Operating State value. 19 - CALL GQOPS(IOPSTA) 20 - *** For states less than 'workstation active' flag is off. 21 - IF(IOPSTA.LT.3)THEN 22 - GFLAG=.FALSE. 23 - *** If a workstation is active, see whether there is an interactive one. 24 - ELSE 25 - GFLAG=.FALSE. 26 - CALL GQACWK(0,IERR,NACT,IWK) 27 - DO 10 I=1,NACT 28 - CALL GQACWK(I,IERR,IDUM,IWK) 29 - CALL GQWKC(IWK,IERR,ICONID,IWKTYP) 30 - CALL GQWKCA(IWKTYP,IERR,ICAT) 31 - IF(ICAT.EQ.2)GFLAG=.TRUE. 32 - 10 CONTINUE 33 - ENDIF 34 - *** Debugging output. 35 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SGFLAG DEBUG :'', 36 - - '' Setting GFLAG to '',L1,''.'')') GFLAG 37 - END 231 GARFIELD ================================================== P=PROJECTI D= 1 ============================ 0 + +PATCH,PROJECTION. 232 GARFIELD ================================================== P=PROJECTI D=PLAARR 1 ============================ 0 + +DECK,PLAARR. 1 - SUBROUTINE PLAARR(XX0,YY0,ZZ0,DX,DY,DZ) 2 - *----------------------------------------------------------------------- 3 - * PLAARR - Plots an arrow in projection. 4 - * (Last changed on 24/ 5/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GRAPHICS. 9.- +SEQ,PARAMETERS. 10 - REAL XX0,YY0,ZZ0,DX,DY,DZ 11 - DOUBLE PRECISION XPL(3),YPL(3),XAUX(3),YAUX(3), 12 - - X0D,Y0D,Z0D,X1D,Y1D,Z1D,X0,Y0,X1,Y1,PHIARR,ALEN 13 - *** Copy to double precision. 14 - X0D=DBLE(XX0) 15 - Y0D=DBLE(YY0) 16 - Z0D=DBLE(ZZ0) 17 - X1D=DBLE(XX0+DX) 18 - Y1D=DBLE(YY0+DY) 19 - Z1D=DBLE(ZZ0+DZ) 20 - *** Project begin and end point. 21 - CALL PLACOO(X0D,Y0D,Z0D,X0,Y0) 22 - CALL PLACOO(X1D,Y1D,Z1D,X1,Y1) 23 - *** Straight line of the arrow. 24 - XPL(1)=X0 25 - YPL(1)=Y0 26 - XPL(2)=X1 27 - YPL(2)=Y1 28 - * Plot in polar coordinates. 29 - IF(PRVIEW.EQ.'R-PHI')THEN 30 - CALL CF2RTC(XPL,YPL,XAUX,YAUX,2) 31 - CALL GPL2(2,XAUX,YAUX) 32 - * Or in Cartesian coordinates. 33 - ELSE 34 - CALL GPL2(2,XPL,YPL) 35 - ENDIF 36 - *** Make the arrow top. 37 - PHIARR=ATAN2(Y1-Y0,X1-X0) 38 - ALEN=SQRT((X1D-X0D)**2+(Y1D-Y0D)**2+(Z1D-Z0D)**2) 39 - XPL(1)=X1-ALEN*ARRLEN*COS(DBLE(PHIARR)+ARRANG) 40 - YPL(1)=Y1-ALEN*ARRLEN*SIN(DBLE(PHIARR)+ARRANG) 41 - XPL(2)=X1 42 - YPL(2)=Y1 43 - XPL(3)=X1-ALEN*ARRLEN*COS(DBLE(PHIARR)-ARRANG) 44 - YPL(3)=Y1-ALEN*ARRLEN*SIN(DBLE(PHIARR)-ARRANG) 45 - * Plot in polar coordinates. 46 - IF(PRVIEW.EQ.'R-PHI')THEN 47 - CALL CF2RTC(XPL,YPL,XAUX,YAUX,3) 48 - CALL GPL2(3,XAUX,YAUX) 49 - * Or in Cartesian coordinates. 50 - ELSE 51 - CALL GPL2(3,XPL,YPL) 52 - ENDIF 53 - END 1 233 GARFIELD ================================================== P=PROJECTI D=PLAGPL 1 =================== PAGE 306 0 + +DECK,PLAGPL. 1 - SUBROUTINE PLAGPL(NPL,XPL,YPL,ZPL) 2 - *----------------------------------------------------------------------- 3 - * PLAGPL - Plots a curve through the visible parts. 4 - * (Last changed on 5/10/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9.- +SEQ,PRINTPLOT. 10 - INTEGER NPL 11 - DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL), 12 - - XAUX(MXLIST),YAUX(MXLIST) 13 - *** Identification and debugging. 14 - IF(LIDENT)PRINT *,' /// ROUTINE PLAGPL ///' 15 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAGPL DEBUG : Drawing '', 16 - - I4,'' points in projection '',A)') NPL,PRVIEW 17 - *** Select the plotting routine, x-y view. 18 - IF(PRVIEW.EQ.'X-Y')THEN 19 - CALL GRLIN2(NPL,XPL,YPL) 20 - * r-phi view: transform from internal to Cartesian coordinates. 21 - ELSEIF(PRVIEW.EQ.'R-PHI')THEN 22 - IF(NPL.GT.MXLIST)THEN 23 - PRINT *,' !!!!!! PLAGPL WARNING : Array dimensions'// 24 - - ' insufficient to plot a vector; not plotted.' 25 - RETURN 26 - ENDIF 27 - CALL CF2RTC(XPL,YPL,XAUX,YAUX,NPL) 28 - CALL GRLIN2(NPL,XAUX,YAUX) 29 - * x-z view. 30 - ELSEIF(PRVIEW.EQ.'X-Z')THEN 31 - CALL GRLIN2(NPL,XPL,ZPL) 32 - * y-z view. 33 - ELSEIF(PRVIEW.EQ.'Y-Z')THEN 34 - CALL GRLIN2(NPL,YPL,ZPL) 35 - * cut view. 36 - ELSEIF(PRVIEW.EQ.'CUT')THEN 37 - CALL PLAGPC(NPL,XPL,YPL,ZPL) 38 - * 3D view. 39 - ELSEIF(PRVIEW.EQ.'3D')THEN 40 - CALL PLAGPP(NPL,XPL,YPL,ZPL) 41 - * Unknown. 42 - ELSE 43 - PRINT *,' !!!!!! PLAGPL WARNING : Received unknown'// 44 - - ' projection type '//PRVIEW 45 - ENDIF 46 - END 234 GARFIELD ================================================== P=PROJECTI D=PLAGPM 1 ============================ 0 + +DECK,PLAGPM. 1 - SUBROUTINE PLAGPM(NPL,XPL,YPL,ZPL) 2 - *----------------------------------------------------------------------- 3 - * PLAGPM - Plots markers which are visible. 4 - * (Last changed on 5/10/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9.- +SEQ,PRINTPLOT. 10 - INTEGER NPL 11 - DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL), 12 - - XAUX(MXLIST),YAUX(MXLIST) 13 - *** Identification and debugging. 14 - IF(LIDENT)PRINT *,' /// ROUTINE PLAGPM ///' 15 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAGPM DEBUG : Marking '', 16 - - I4,'' points in projection '',A)') NPL,PRVIEW 17 - *** Select the plotting routine, x-y view. 18 - IF(PRVIEW.EQ.'X-Y')THEN 19 - CALL GPM2(NPL,XPL,YPL) 20 - * r-phi view: transform from internal to Cartesian coordinates. 21 - ELSEIF(PRVIEW.EQ.'R-PHI')THEN 22 - IF(NPL.GT.MXLIST)THEN 23 - PRINT *,' !!!!!! PLAGPM WARNING : Array dimensions'// 24 - - ' insufficient to plot a vector; not plotted.' 25 - RETURN 26 - ENDIF 27 - CALL CF2RTC(XPL,YPL,XAUX,YAUX,NPL) 28 - CALL GPM2(NPL,XAUX,YAUX) 29 - * x-z view. 30 - ELSEIF(PRVIEW.EQ.'X-Z')THEN 31 - CALL GPM2(NPL,XPL,ZPL) 32 - * y-z view. 33 - ELSEIF(PRVIEW.EQ.'Y-Z')THEN 34 - CALL GPM2(NPL,YPL,ZPL) 35 - * cut view. 36 - ELSEIF(PRVIEW.EQ.'CUT')THEN 37 - CALL PLAGMC(NPL,XPL,YPL,ZPL) 38 - * 3D view. 39 - ELSEIF(PRVIEW.EQ.'3D')THEN 40 - CALL PLAGMP(NPL,XPL,YPL,ZPL) 41 - * Unknown. 42 - ELSE 43 - PRINT *,' !!!!!! PLAGPM WARNING : Received unknown'// 44 - - ' projection type '//PRVIEW 45 - ENDIF 46 - END 235 GARFIELD ================================================== P=PROJECTI D=PLAGPC 1 ============================ 0 + +DECK,PLAGPC. 1 - SUBROUTINE PLAGPC(NPL,XPL,YPL,ZPL) 2 - *----------------------------------------------------------------------- 3 - * PLAGPC - Plots a curve through the visible parts. 4 - * (Last changed on 8/10/98.) 5 - *----------------------------------------------------------------------- 1 235 P=PROJECTI D=PLAGPC 2 PAGE 307 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,SOLIDS. 11.- +SEQ,GRAPHICS. 12.- +SEQ,PRINTPLOT. 13 - INTEGER NPL,I,NOUT,IFAIL 14 - DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL), 15 - - XOUT(MXLIST),YOUT(MXLIST),X0,Y0,Z0,X1,Y1,Z1 16 - LOGICAL CURIN,LASTIN 17 - *** No plotting for too few points, 18 - IF(NPL.LE.1)RETURN 19 - *** Loop over the input array. 20 - NOUT=0 21 - DO 10 I=1,NPL-1 22 - * Copy the current and last point. 23 - X0=XPL(I) 24 - Y0=YPL(I) 25 - Z0=ZPL(I) 26 - LASTIN=X0.GE.GXMIN.AND.X0.LE.GXMAX.AND. 27 - - Y0.GE.GYMIN.AND.Y0.LE.GYMAX.AND. 28 - - Z0.GE.GZMIN.AND.Z0.LE.GZMAX 29 - X1=XPL(I+1) 30 - Y1=YPL(I+1) 31 - Z1=ZPL(I+1) 32 - CURIN=X1.GE.GXMIN.AND.X1.LE.GXMAX.AND. 33 - - Y1.GE.GYMIN.AND.Y1.LE.GYMAX.AND. 34 - - Z1.GE.GZMIN.AND.Z1.LE.GZMAX 35 - * Compute fragment of this that fits in the frame. 36 - CALL CLIP3D(X0,Y0,Z0,X1,Y1,Z1, 37 - - GXMIN,GYMIN,GZMIN,GXMAX,GYMAX,GZMAX,IFAIL) 38 - * If fully out (IFAIL=1) then skip the rest. 39 - IF(IFAIL.NE.0)THEN 40 - GOTO 10 41 - * If last point was 'in', add the current point, plot if now 'out'. 42 - ELSEIF(LASTIN)THEN 43 - IF(NOUT.EQ.0)THEN 44 - NOUT=NOUT+1 45 - CALL PLACOO(X0,Y0,Z0,XOUT(NOUT),YOUT(NOUT)) 46 - ELSEIF(NOUT.GE.MXLIST)THEN 47 - CALL GPL2(NOUT,XOUT,YOUT) 48 - XOUT(1)=XOUT(NOUT) 49 - YOUT(1)=YOUT(NOUT) 50 - NOUT=1 51 - ENDIF 52 - NOUT=NOUT+1 53 - CALL PLACOO(X1,Y1,Z1,XOUT(NOUT),YOUT(NOUT)) 54 - IF(.NOT.CURIN)THEN 55 - IF(NOUT.GT.1)CALL GPL2(NOUT,XOUT,YOUT) 56 - NOUT=0 57 - ENDIF 58 - * If the last point was 'out', start a new line, plot if now 'out'. 59 - ELSE 60 - IF(NOUT.GT.1)CALL GPL2(NOUT,XOUT,YOUT) 61 - CALL PLACOO(X0,Y0,Z0,XOUT(1),YOUT(1)) 62 - CALL PLACOO(X1,Y1,Z1,XOUT(2),YOUT(2)) 63 - NOUT=2 64 - IF(.NOT.CURIN)THEN 65 - CALL GPL2(NOUT,XOUT,YOUT) 66 - NOUT=0 67 - ENDIF 68 - ENDIF 69 - 10 CONTINUE 70 - *** Plot what remains in the buffer. 71 - IF(NOUT.GE.2)CALL GPL2(NOUT,XOUT,YOUT) 72 - END 236 GARFIELD ================================================== P=PROJECTI D=PLAGMC 1 ============================ 0 + +DECK,PLAGMC. 1 - SUBROUTINE PLAGMC(NPL,XPL,YPL,ZPL) 2 - *----------------------------------------------------------------------- 3 - * PLAGMC - Plots markers on a cut plot. 4 - * (Last changed on 29/ 9/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,SOLIDS. 11.- +SEQ,GRAPHICS. 12.- +SEQ,PRINTPLOT. 13 - INTEGER NPL,I 14 - DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL),XCUR(1),YCUR(1) 15 - *** Copy the curve, projecting each point. 16 - IF(NPL.GT.MXLIST)THEN 17 - PRINT *,' !!!!!! PLAGMC WARNING : Curve contains too many'// 18 - - ' points ; curve not plotted.' 19 - RETURN 20 - ENDIF 21 - DO 10 I=1,NPL 22 - IF(XPL(I).GE.GXMIN.AND.XPL(I).LE.GXMAX.AND. 23 - - YPL(I).GE.GYMIN.AND.YPL(I).LE.GYMAX.AND. 24 - - ZPL(I).GE.GZMIN.AND.ZPL(I).LE.GZMAX)THEN 25 - CALL PLACOO(XPL(I),YPL(I),ZPL(I),XCUR(1),YCUR(1)) 26 - CALL GPM2(1,XCUR,YCUR) 27 - ENDIF 28 - 10 CONTINUE 29 - END 1 237 GARFIELD ================================================== P=PROJECTI D=PLAGPP 1 =================== PAGE 308 0 + +DECK,PLAGPP. 1 - SUBROUTINE PLAGPP(NPL,XPL,YPL,ZPL) 2 - *----------------------------------------------------------------------- 3 - * PLAGPP - Plots a curve through the visible parts. 4 - * (Last changed on 28/10/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,SOLIDS. 11.- +SEQ,GRAPHICS. 12.- +SEQ,PRINTPLOT. 13 - INTEGER NPL,I,J,K,L,NPL1,ICOL,IFAIL,NCUR,NNEW,NL,IQMIN,I0 14 - DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL), 15 - - XPL1(MXEDGE),YPL1(MXEDGE),ZPL1(MXEDGE), 16 - - XCUR(MXLIST),YCUR(MXLIST),ZCUR(MXLIST), 17 - - XNEW(MXLIST),YNEW(MXLIST),ZNEW(MXLIST), 18 - - XL(MXEDGE),YL(MXEDGE),ZL(MXEDGE),QL(MXEDGE), 19 - - APL,BPL,CPL,DPL,XC,YC,ZC,XAUX,YAUX,ZAUX,QMIN,QAUX, 20 - - X0,Y0,Z0,X1,Y1,Z1,EPSX,EPSY,EPSZ 21 - LOGICAL DRAW(MXLIST),DRAWN(MXLIST),INSIDE,EDGE,CROSS,CURIN,LASTIN 22 - *** Set tolerances. 23 - IF(LEPSG)THEN 24 - EPSX=EPSGX 25 - EPSY=EPSGY 26 - EPSZ=EPSGZ 27 - ELSE 28 - EPSX=1.0D-8*ABS(GXMAX-GXMIN) 29 - EPSY=1.0D-8*ABS(GYMAX-GYMIN) 30 - EPSZ=1.0D-8*ABS(GZMAX-GZMIN) 31 - IF(EPSX.LE.0)EPSX=1.0D-8 32 - IF(EPSY.LE.0)EPSY=1.0D-8 33 - IF(EPSZ.LE.0)EPSZ=1.0D-8 34 - ENDIF 35 - *** Copy the curve, section by section, set initial number of points. 36 - NCUR=0 37 - * Loop over the points. 38 - DO 10 I=1,NPL-1 39 - * Make copies of the current and the last point. 40 - X0=XPL(I) 41 - Y0=YPL(I) 42 - Z0=ZPL(I) 43 - LASTIN=X0.GE.GXMIN.AND.X0.LE.GXMAX.AND. 44 - - Y0.GE.GYMIN.AND.Y0.LE.GYMAX.AND. 45 - - Z0.GE.GZMIN.AND.Z0.LE.GZMAX 46 - X1=XPL(I+1) 47 - Y1=YPL(I+1) 48 - Z1=ZPL(I+1) 49 - CURIN=X1.GE.GXMIN.AND.X1.LE.GXMAX.AND. 50 - - Y1.GE.GYMIN.AND.Y1.LE.GYMAX.AND. 51 - - Z1.GE.GZMIN.AND.Z1.LE.GZMAX 52 - * Adjust this piece to the dimensions of the box. 53 - CALL CLIP3D(X0,Y0,Z0,X1,Y1,Z1, 54 - - GXMIN,GYMIN,GZMIN,GXMAX,GYMAX,GZMAX,IFAIL) 55 - * If outside the box, skip the section altogether. 56 - IF(IFAIL.NE.0)THEN 57 - GOTO 10 58 - * Crossing of box, last point in: add current point. 59 - ELSEIF(LASTIN)THEN 60 - IF(NCUR.EQ.0)THEN 61 - NCUR=1 62 - CALL PLACO3(X0,Y0,Z0,XCUR(NCUR),YCUR(NCUR),ZCUR(NCUR)) 63 - ENDIF 64 - IF(NCUR.GE.MXLIST)GOTO 3010 65 - DRAW(NCUR)=.TRUE. 66 - NCUR=NCUR+1 67 - CALL PLACO3(X1,Y1,Z1,XCUR(NCUR),YCUR(NCUR),ZCUR(NCUR)) 68 - DRAW(NCUR)=CURIN 69 - * Crossing of box, last not in: add entry and exit. 70 - ELSE 71 - IF(NCUR.GT.0)DRAW(NCUR)=.FALSE. 72 - IF(NCUR.GE.MXLIST)GOTO 3010 73 - NCUR=NCUR+1 74 - CALL PLACO3(X0,Y0,Z0,XCUR(NCUR),YCUR(NCUR),ZCUR(NCUR)) 75 - DRAW(NCUR)=.TRUE. 76 - IF(NCUR.GE.MXLIST)GOTO 3010 77 - NCUR=NCUR+1 78 - CALL PLACO3(X1,Y1,Z1,XCUR(NCUR),YCUR(NCUR),ZCUR(NCUR)) 79 - DRAW(NCUR)=CURIN 80 - ENDIF 81 - 10 CONTINUE 82 - *** See whether we have collected anything. 83 - IF(NCUR.LT.2)RETURN 84 - *** Load all plot panels to see whether there is a crossing. 85 - DO 20 J=1,NQ 86 - CALL PLABU2('READ',IQ(J),NPL1,XPL1,YPL1,ZPL1,APL,BPL,CPL,DPL, 87 - - ICOL,IFAIL) 88 - IF(IFAIL.NE.0)THEN 89 - PRINT *,' !!!!!! PLAGPP WARNING : Unable to load a'// 90 - - ' plot panel ; curve not plotted.' 91 - RETURN 92 - ENDIF 93 - IF(NPL1.LE.2)GOTO 20 94 - * Skip this panel if it is almost normal. 95 - IF(ABS(CPL).LT.1.0D-4*SQRT(APL**2+BPL**2))GOTO 20 96 - *** Go over all line segments. 97 - NNEW=0 98 - DO 30 I=1,NCUR-1 99 - * For invisible and point segments, merely register the starting point. 100 - IF((.NOT.DRAW(I)).OR. 101 - - (ABS(XCUR(I+1)-XCUR(I)).LE.EPSX.AND. 102 - - ABS(YCUR(I+1)-YCUR(I)).LE.EPSY.AND. 103 - - ABS(ZCUR(I+1)-ZCUR(I)).LE.EPSZ))THEN 104 - IF(NNEW+1.GT.MXLIST)THEN 105 - PRINT *,' !!!!!! PLAGPP WARNING : Too many'// 1 237 P=PROJECTI D=PLAGPP 2 PAGE 309 106 - - ' points generated on curve; not plotted.' 107 - RETURN 108 - ENDIF 109 - IF(NNEW.GE.MXLIST)GOTO 3020 110 - NNEW=NNEW+1 111 - XNEW(NNEW)=XCUR(I) 112 - YNEW(NNEW)=YCUR(I) 113 - ZNEW(NNEW)=ZCUR(I) 114 - DRAWN(NNEW)=.FALSE. 115 - GOTO 30 116 - ENDIF 117 - * Establish the list of crossings. 118 - NL=2 119 - XL(1)=XCUR(I) 120 - YL(1)=YCUR(I) 121 - ZL(1)=ZCUR(I) 122 - QL(1)=0 123 - XL(2)=XCUR(I+1) 124 - YL(2)=YCUR(I+1) 125 - ZL(2)=ZCUR(I+1) 126 - QL(2)=1 127 - * Check for crossings in the plane. 128 - CALL PLALIN( 129 - - XCUR(I) ,YCUR(I) ,ZCUR(I) , 130 - - XCUR(I+1),YCUR(I+1),ZCUR(I+1), 131 - - XPL1(1) ,YPL1(1) ,ZPL1(1) , 132 - - APL,BPL,CPL,XC,YC,ZC,IFAIL) 133 - IF(IFAIL.EQ.0)THEN 134 - CALL INTERD(NPL1,XPL1,YPL1,XC,YC,INSIDE,EDGE) 135 - IF(INSIDE)THEN 136 - IF(NL+1.GT.MXEDGE)THEN 137 - PRINT *,' !!!!!! PLAGPP WARNING : Too many'// 138 - - ' crossings between curve and surface'// 139 - - ' elements; not plotted.' 140 - RETURN 141 - ENDIF 142 - NL=NL+1 143 - XL(NL)=XC 144 - YL(NL)=YC 145 - ZL(NL)=(DPL-APL*XL(NL)-BPL*YL(NL))/CPL 146 - CALL PLALAM(XCUR(I),XL(NL),XCUR(I+1), 147 - - YCUR(I),YL(NL),YCUR(I+1),QL(NL)) 148 - ENDIF 149 - ENDIF 150 - * Check for crossings on the edges. 151 - DO 40 K=1,NPL1 152 - CALL CRSPND( 153 - - XPL1(1+MOD(K-1,NPL1)),YPL1(1+MOD(K-1,NPL1)), 154 - - XPL1(1+MOD(K ,NPL1)),YPL1(1+MOD(K ,NPL1)), 155 - - XCUR(I),YCUR(I),XCUR(I+1),YCUR(I+1), 156 - - XC,YC,CROSS) 157 - IF(.NOT.CROSS)GOTO 40 158 - IF(NL+1.GT.MXEDGE)THEN 159 - PRINT *,' !!!!!! PLAGPP WARNING : Too many crossings'// 160 - - ' between curve and surface elements; not plotted.' 161 - RETURN 162 - ENDIF 163 - NL=NL+1 164 - XL(NL)=XC 165 - YL(NL)=YC 166 - CALL PLALAM(XCUR(I),XL(NL),XCUR(I+1),YCUR(I),YL(NL),YCUR(I+1), 167 - - QL(NL)) 168 - ZL(NL)=ZCUR(I)+QL(NL)*(ZCUR(I+1)-ZCUR(I)) 169 - 40 CONTINUE 170 - * Sort the list by using the lambda's. 171 - DO 60 K=1,NL-1 172 - QMIN=QL(K) 173 - IQMIN=K 174 - DO 50 L=K+1,NL 175 - IF(QL(L).LT.QMIN)THEN 176 - IQMIN=L 177 - QMIN=QL(L) 178 - ENDIF 179 - 50 CONTINUE 180 - IF(K.NE.IQMIN)THEN 181 - XAUX=XL(K) 182 - YAUX=YL(K) 183 - ZAUX=ZL(K) 184 - QAUX=QL(K) 185 - XL(K)=XL(IQMIN) 186 - YL(K)=YL(IQMIN) 187 - ZL(K)=ZL(IQMIN) 188 - QL(K)=QL(IQMIN) 189 - XL(IQMIN)=XAUX 190 - YL(IQMIN)=YAUX 191 - ZL(IQMIN)=ZAUX 192 - QL(IQMIN)=QAUX 193 - ENDIF 194 - 60 CONTINUE 195 - * Copy the points to the new vector. 196 - DO 70 K=1,NL-1 197 - IF(NNEW+1.GT.MXLIST)THEN 198 - PRINT *,' !!!!!! PLAGPP WARNING : Too many points'// 199 - - ' generated on curve; not plotted.' 200 - RETURN 201 - ENDIF 202 - IF(NNEW.GE.MXLIST)GOTO 3020 203 - NNEW=NNEW+1 204 - XNEW(NNEW)=XL(K) 205 - YNEW(NNEW)=YL(K) 206 - ZNEW(NNEW)=ZL(K) 207 - CALL INTERD(NPL1,XPL1,YPL1,(XL(K)+XL(K+1))/2,(YL(K)+YL(K+1))/2, 208 - - INSIDE,EDGE) 209 - IF(.NOT.(INSIDE.OR.EDGE).OR. 210 - - (ZL(K)+ZL(K+1))/2.GE.(DPL-APL*(XL(K)+XL(K+1))/2- 211 - - BPL*(YL(K)+YL(K+1))/2)/CPL)THEN 1 237 P=PROJECTI D=PLAGPP 3 PAGE 310 212 - DRAWN(NNEW)=.TRUE. 213 - ELSE 214 - DRAWN(NNEW)=.FALSE. 215 - ENDIF 216 - 70 CONTINUE 217 - * Next line segment. 218 - 30 CONTINUE 219 - * Place the last point of this section in the list. 220 - IF(NNEW.GE.MXLIST)GOTO 3020 221 - NNEW=NNEW+1 222 - XNEW(NNEW)=XCUR(NCUR) 223 - YNEW(NNEW)=YCUR(NCUR) 224 - ZNEW(NNEW)=ZCUR(NCUR) 225 - DRAWN(NNEW)=.TRUE. 226 - * Copy this list back to the main curve, eliminating invisible parts. 227 - IF(DRAWN(1))THEN 228 - NCUR=1 229 - XCUR(NCUR)=XNEW(1) 230 - YCUR(NCUR)=YNEW(1) 231 - ZCUR(NCUR)=ZNEW(1) 232 - DRAW(NCUR)=DRAWN(1) 233 - ELSE 234 - NCUR=0 235 - ENDIF 236 - DO 80 I=2,NNEW 237 - IF(.NOT.DRAWN(I).AND..NOT.DRAWN(I-1))GOTO 80 238 - IF(NCUR.GE.MXLIST)GOTO 3010 239 - NCUR=NCUR+1 240 - XCUR(NCUR)=XNEW(I) 241 - YCUR(NCUR)=YNEW(I) 242 - ZCUR(NCUR)=ZNEW(I) 243 - DRAW(NCUR)=DRAWN(I) 244 - 80 CONTINUE 245 - * Next panel. 246 - 20 CONTINUE 247 - *** Plot the remaining line. 248 - I0=1 249 - DO 100 I=1,NCUR-1 250 - IF(.NOT.DRAW(I))THEN 251 - IF(I-I0+1.GE.2)CALL GPL2(I-I0+1,XCUR(I0),YCUR(I0)) 252 - I0=I+1 253 - ENDIF 254 - 100 CONTINUE 255 - IF(NCUR-I0+1.GE.2)CALL GPL2(NCUR-I0+1,XCUR(I0),YCUR(I0)) 256 - RETURN 257 - *** Error processing. 258 - 3010 CONTINUE 259 - PRINT *,' !!!!!! PLAGPP WARNING : Curve contains too many'// 260 - - ' points ; curve not plotted.' 261 - RETURN 262 - 3020 CONTINUE 263 - PRINT *,' !!!!!! PLAGPP WARNING : Too many points'// 264 - - ' generated on curve; not plotted.' 265 - END 238 GARFIELD ================================================== P=PROJECTI D=PLAGMP 1 ============================ 0 + +DECK,PLAGMP. 1 - SUBROUTINE PLAGMP(NPL,XPL,YPL,ZPL) 2 - *----------------------------------------------------------------------- 3 - * PLAGMP - Plots markers at visible locations. 4 - * (Last changed on 8/10/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,SOLIDS. 11.- +SEQ,GRAPHICS. 12.- +SEQ,PRINTPLOT. 13 - INTEGER NPL,I,J,NPL1,ICOL,IFAIL,NCUR 14 - DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL), 15 - - XPL1(MXEDGE),YPL1(MXEDGE),ZPL1(MXEDGE), 16 - - XCUR(MXLIST),YCUR(MXLIST),ZCUR(MXLIST), 17 - - APL,BPL,CPL,DPL 18 - LOGICAL DRAW(MXLIST),INSIDE,EDGE 19 - *** Copy the curve, projecting each point. 20 - IF(NPL.GT.MXLIST)THEN 21 - PRINT *,' !!!!!! PLAGMP WARNING : Curve contains too many'// 22 - - ' points ; curve not plotted.' 23 - RETURN 24 - ENDIF 25 - DO 10 I=1,NPL 26 - CALL PLACO3(XPL(I),YPL(I),ZPL(I),XCUR(I),YCUR(I),ZCUR(I)) 27 - DRAW(I)=XPL(I).GE.GXMIN.AND.XPL(I).LE.GXMAX.AND. 28 - - YPL(I).GE.GYMIN.AND.YPL(I).LE.GYMAX.AND. 29 - - ZPL(I).GE.GZMIN.AND.ZPL(I).LE.GZMAX 30 - 10 CONTINUE 31 - NCUR=NPL 32 - *** Load all plot panels to see whether there is a crossing. 33 - DO 20 J=1,NQ 34 - CALL PLABU2('READ',IQ(J),NPL1,XPL1,YPL1,ZPL1,APL,BPL,CPL,DPL, 35 - - ICOL,IFAIL) 36 - IF(IFAIL.NE.0)THEN 37 - PRINT *,' !!!!!! PLAGMP WARNING : Unable to load a'// 38 - - ' plot panel ; curve not plotted.' 39 - RETURN 40 - ENDIF 41 - IF(NPL1.LE.2)GOTO 20 42 - * Skip this panel if it is almost normal. 43 - IF(ABS(CPL).LT.1.0D-4*SQRT(APL**2+BPL**2))GOTO 20 44 - * Go over all points. 45 - DO 30 I=1,NCUR 46 - IF(.NOT.DRAW(I))GOTO 30 47 - CALL INTERD(NPL1,XPL1,YPL1,XCUR(I),YCUR(I),INSIDE,EDGE) 48 - IF(INSIDE.AND.ZCUR(I).LT.(DPL-APL*XCUR(I)-BPL*YCUR(I))/CPL) 1 238 P=PROJECTI D=PLAGMP 2 PAGE 311 49 - - DRAW(I)=.FALSE. 50 - 30 CONTINUE 51 - 20 CONTINUE 52 - *** Plot the visible markers. 53 - DO 100 I=1,NCUR 54 - IF(DRAW(I))CALL GPM2(1,XCUR(I),YCUR(I)) 55 - 100 CONTINUE 56 - END 239 GARFIELD ================================================== P=PROJECTI D=PLAINT 1 ============================ 0 + +DECK,PLAINT. 1 - SUBROUTINE PLAINT 2 - *----------------------------------------------------------------------- 3 - * PLAINT - Initialisation of the projections. 4 - * (Last changed on 30/11/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9.- +SEQ,CONSTANTS. 10.- +SEQ,PRINTPLOT. 11 - INTEGER I,J,IFAIL1,IFAIL2 12 - DOUBLE PRECISION DET 13 - *** Projection matrices. 14 - DO 60 I=1,3 15 - DO 70 J=1,3 16 - FPROJ(I,J)=0 17 - FPRMAT(I,J)=0 18 - 70 CONTINUE 19 - IF(I.LE.2)FPROJ(I,I)=1 20 - IPRMAT(I)=I 21 - FPRMAT(I,I)=1 22 - 60 CONTINUE 23 - *** Prepare solved projection matrix. 24 - CALL DFACT(3,FPRMAT,3,IPRMAT,IFAIL1,DET,IFAIL2) 25 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAINT DEBUG :'', 26 - - '' Determinant of projection: '',E15.8)') DET 27 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)PRINT *,' ###### PLAINT'//' 28 - - ERROR : Error establishing a default projection.' 29 - *** Projection axis by default z-axis. 30 - FPROJA=0 31 - FPROJB=0 32 - FPROJC=1 33 - FPROJD=0 34 - FPROJN=1 35 - *** Labels. 36 - PXLAB='x-Axis [cm]' 37 - NCXLAB=11 38 - PYLAB='y-Axis [cm]' 39 - NCYLAB=11 40 - PROLAB='z=0' 41 - NCFPRO=3 42 - *** Light source. 43 - PRTHL=30.0*PI/180.0 44 - PRPHIL=30.0*PI/180.0 45 - *** Absorbed and reflected fractions. 46 - PRFABS=0.03 47 - PRFREF=0.1 48 - PRFCAL=0.7 49 - PRFMIN=0.1 50 - PRFMAX=0.95 51 - *** Colour table granularity. 52 - NPRCOL=10 53 - *** Colour offsets. 54 - ICOL0=30 55 - ICOLBX=0 56 - ICOLPL=0 57 - ICOLST=0 58 - ICOLW1=0 59 - ICOLW2=0 60 - ICOLW3=0 61 - ICOLD1=0 62 - ICOLD2=0 63 - ICOLD3=0 64 - *** Partial or full box, planes, tube. 65 - LFULLB=.FALSE. 66 - LFULLP=.TRUE. 67 - LFULLT=.TRUE. 68 - *** Cut overlaps. 69 - LSPLIT=.TRUE. 70 - *** Sort planes. 71 - LSORT=.FALSE. 72 - *** Outline. 73 - LOUTL=.TRUE. 74 - *** Single step plotting of planes. 75 - LGSTEP=.FALSE. 76 - *** Projection method. 77 - PRVIEW='X-Y' 78 - *** Axis rotation angle. 79 - PROROT=0 80 - END 240 GARFIELD ================================================== P=PROJECTI D=PLABOX 1 ============================ 0 + +DECK,PLABOX. 1 - SUBROUTINE PLABOX(XBOX,YBOX,ZBOX,NCUT,XCUT,YCUT,ZCUT, 2 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL) 3 - *----------------------------------------------------------------------- 4 - * PLABOX - Crossings between a box and a plane. 5 - * (Last changed on 4/ 2/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9 - INTEGER NCUT,IFAIL 10 - DOUBLE PRECISION XBOX(8),YBOX(8),ZBOX(8), 1 240 P=PROJECTI D=PLABOX 2 PAGE 312 11 - - XCUT(12),YCUT(12),ZCUT(12), 12 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC 13 - *** Initial number of crossings. 14 - NCUT=0 15 - *** Compute the, at most 6, crossings between plane and box. 16 - CALL PLALIN(XBOX(1),YBOX(1),ZBOX(1),XBOX(2),YBOX(2),ZBOX(2), 17 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) 18 - IF(IFAIL.EQ.0)THEN 19 - NCUT=NCUT+1 20 - XCUT(NCUT)=XC 21 - YCUT(NCUT)=YC 22 - ZCUT(NCUT)=ZC 23 - ENDIF 24 - CALL PLALIN(XBOX(2),YBOX(2),ZBOX(2),XBOX(3),YBOX(3),ZBOX(3), 25 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) 26 - IF(IFAIL.EQ.0)THEN 27 - NCUT=NCUT+1 28 - XCUT(NCUT)=XC 29 - YCUT(NCUT)=YC 30 - ZCUT(NCUT)=ZC 31 - ENDIF 32 - CALL PLALIN(XBOX(3),YBOX(3),ZBOX(3),XBOX(4),YBOX(4),ZBOX(4), 33 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) 34 - IF(IFAIL.EQ.0)THEN 35 - NCUT=NCUT+1 36 - XCUT(NCUT)=XC 37 - YCUT(NCUT)=YC 38 - ZCUT(NCUT)=ZC 39 - ENDIF 40 - CALL PLALIN(XBOX(4),YBOX(4),ZBOX(4),XBOX(1),YBOX(1),ZBOX(1), 41 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) 42 - IF(IFAIL.EQ.0)THEN 43 - NCUT=NCUT+1 44 - XCUT(NCUT)=XC 45 - YCUT(NCUT)=YC 46 - ZCUT(NCUT)=ZC 47 - ENDIF 48 - CALL PLALIN(XBOX(5),YBOX(5),ZBOX(5),XBOX(6),YBOX(6),ZBOX(6), 49 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) 50 - IF(IFAIL.EQ.0)THEN 51 - NCUT=NCUT+1 52 - XCUT(NCUT)=XC 53 - YCUT(NCUT)=YC 54 - ZCUT(NCUT)=ZC 55 - ENDIF 56 - CALL PLALIN(XBOX(6),YBOX(6),ZBOX(6),XBOX(7),YBOX(7),ZBOX(7), 57 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) 58 - IF(IFAIL.EQ.0)THEN 59 - NCUT=NCUT+1 60 - XCUT(NCUT)=XC 61 - YCUT(NCUT)=YC 62 - ZCUT(NCUT)=ZC 63 - ENDIF 64 - CALL PLALIN(XBOX(7),YBOX(7),ZBOX(7),XBOX(8),YBOX(8),ZBOX(8), 65 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) 66 - IF(IFAIL.EQ.0)THEN 67 - NCUT=NCUT+1 68 - XCUT(NCUT)=XC 69 - YCUT(NCUT)=YC 70 - ZCUT(NCUT)=ZC 71 - ENDIF 72 - CALL PLALIN(XBOX(8),YBOX(8),ZBOX(8),XBOX(5),YBOX(5),ZBOX(5), 73 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) 74 - IF(IFAIL.EQ.0)THEN 75 - NCUT=NCUT+1 76 - XCUT(NCUT)=XC 77 - YCUT(NCUT)=YC 78 - ZCUT(NCUT)=ZC 79 - ENDIF 80 - CALL PLALIN(XBOX(1),YBOX(1),ZBOX(1),XBOX(5),YBOX(5),ZBOX(5), 81 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) 82 - IF(IFAIL.EQ.0)THEN 83 - NCUT=NCUT+1 84 - XCUT(NCUT)=XC 85 - YCUT(NCUT)=YC 86 - ZCUT(NCUT)=ZC 87 - ENDIF 88 - CALL PLALIN(XBOX(2),YBOX(2),ZBOX(2),XBOX(6),YBOX(6),ZBOX(6), 89 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) 90 - IF(IFAIL.EQ.0)THEN 91 - NCUT=NCUT+1 92 - XCUT(NCUT)=XC 93 - YCUT(NCUT)=YC 94 - ZCUT(NCUT)=ZC 95 - ENDIF 96 - CALL PLALIN(XBOX(3),YBOX(3),ZBOX(3),XBOX(7),YBOX(7),ZBOX(7), 97 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) 98 - IF(IFAIL.EQ.0)THEN 99 - NCUT=NCUT+1 100 - XCUT(NCUT)=XC 101 - YCUT(NCUT)=YC 102 - ZCUT(NCUT)=ZC 103 - ENDIF 104 - CALL PLALIN(XBOX(4),YBOX(4),ZBOX(4),XBOX(8),YBOX(8),ZBOX(8), 105 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) 106 - IF(IFAIL.EQ.0)THEN 107 - NCUT=NCUT+1 108 - XCUT(NCUT)=XC 109 - YCUT(NCUT)=YC 110 - ZCUT(NCUT)=ZC 111 - ENDIF 112 - *** Eliminate the butterflies. 113 - CALL BUTFLD(NCUT,XCUT,YCUT,ZCUT) 114 - END 1 241 GARFIELD ================================================== P=PROJECTI D=PLACYP 1 =================== PAGE 313 0 + +DECK,PLACYP. 1 - SUBROUTINE PLACYP(IVOL,IOFCOL) 2 - *----------------------------------------------------------------------- 3 - * PLACYP - Generates a table of polygons for a cylinder. 4 - * (Last changed on 12/ 8/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,SOLIDS. 11.- +SEQ,GRAPHICS. 12.- +SEQ,PRINTPLOT. 13 - INTEGER IREF,IOFCOL,NMAX,N,IVOL,ICOL,IFAIL,I 14 - PARAMETER(NMAX=50) 15 - DOUBLE PRECISION R,ZL,X0,Y0,Z0,A,B,C,CT,ST,CP,SP,FNORM,WW, 16 - - U,V,W,XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE),AROT 17 - *** Locate the conductor. 18 - IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN 19 - PRINT *,' !!!!!! PLACYP WARNING : Volume reference is out'// 20 - - ' of range ; not plotted.' 21 - RETURN 22 - ENDIF 23 - IREF=ISTART(IVOL) 24 - IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN 25 - PRINT *,' !!!!!! PLACYP WARNING : Volume address is out'// 26 - - ' of range ; not plotted.' 27 - RETURN 28 - ENDIF 29 - *** Locate the cylinder parameters, first the radius. 30 - R= CBUF(IREF+1) 31 - IF(R.LE.0)THEN 32 - PRINT *,' !!!!!! PLACYP WARNING : Cylinder ',IVOL,' has a'// 33 - - ' non-positive radius; not plotted.' 34 - RETURN 35 - ENDIF 36 - * Half length in z. 37 - ZL=ABS(CBUF(IREF+2)) 38 - * Centre. 39 - X0=CBUF(IREF+3) 40 - Y0=CBUF(IREF+4) 41 - Z0=CBUF(IREF+5) 42 - * Direction vector. 43 - FNORM=SQRT(CBUF(IREF+6)**2+CBUF(IREF+7)**2+CBUF(IREF+8)**2) 44 - IF(FNORM.LE.0)THEN 45 - PRINT *,' !!!!!! PLACYP WARNING : Cylinder ',IVOL,' has a'// 46 - - ' zero norm direction vector; not plotted.' 47 - RETURN 48 - ENDIF 49 - A= CBUF(IREF+6)/FNORM 50 - B= CBUF(IREF+7)/FNORM 51 - C= CBUF(IREF+8)/FNORM 52 - N=MIN(NMAX-1,NINT(CBUF(IREF+9))) 53 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACYP DEBUG : Drawing a'', 54 - - '' cylinder of volume '',I4/26X,''Radius='',E10.3, 55 - - '', Half-length='',E10.3/26X,''Centre= '',3E10.3/ 56 - - 26X,''Direction='',3E10.3)') IVOL,R,ZL,X0,Y0,Z0,A,B,C 57 - * Shorthand for the rotations. 58 - CT=CBUF(IREF+10) 59 - ST=CBUF(IREF+11) 60 - CP=CBUF(IREF+12) 61 - SP=CBUF(IREF+13) 62 - * Axial rotation. 63 - AROT=CBUF(IREF+14) 64 - *** Determine a suitable number of points on the radii. 65 - IF(N.LT.1)THEN 66 - IF(R.LT.1E-3*MAX(ABS(FRXMAX-FRXMIN),ABS(FRYMAX-FRYMIN)))THEN 67 - N=MIN(MXEDGE-1,NMAX-1,5) 68 - ELSEIF(R.LT.1E-2*MAX(ABS(FRXMAX-FRXMIN), 69 - - ABS(FRYMAX-FRYMIN)))THEN 70 - N=MIN(MXEDGE-1,NMAX-1,10) 71 - ELSEIF(R.LT.1E-1*MAX(ABS(FRXMAX-FRXMIN), 72 - - ABS(FRYMAX-FRYMIN)))THEN 73 - N=MIN(MXEDGE-1,NMAX-1,100) 74 - ELSE 75 - N=MIN(MXEDGE-1,NMAX-1) 76 - ENDIF 77 - ENDIF 78 - *** Create the top lid. 79 - DO 10 I=1,N 80 - * Local coordinates, 81 - U=R*COS(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) 82 - V=R*SIN(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) 83 - W=ZL 84 - * Rotate into place. 85 - XPL(I)=X0+CP*CT*U-SP*V+CP*ST*W 86 - YPL(I)=Y0+SP*CT*U+CP*V+SP*ST*W 87 - ZPL(I)=Z0 -ST*U +CT*W 88 - 10 CONTINUE 89 - * Compute colour index. 90 - CALL COLWGT(A,B,C,WW) 91 - IF(WW.GT.0)THEN 92 - ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 93 - ELSE 94 - ICOL=IOFCOL 95 - ENDIF 96 - * Store the plane. 97 - CALL PLABU1('STORE',IREF,N,XPL,YPL,ZPL,A,B,C,ICOL,IVOL,IFAIL) 98 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACYP WARNING : Unable to'// 99 - - ' store the top lid of a cylinder.' 100 - *** Create the bottom lid. 101 - DO 20 I=1,N 102 - * Local coordinates, 103 - U=R*COS(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) 104 - V=R*SIN(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) 105 - W=-ZL 1 241 P=PROJECTI D=PLACYP 2 PAGE 314 106 - * Rotate into place. 107 - XPL(I)=X0+CP*CT*U-SP*V+CP*ST*W 108 - YPL(I)=Y0+SP*CT*U+CP*V+SP*ST*W 109 - ZPL(I)=Z0 -ST*U +CT*W 110 - 20 CONTINUE 111 - * Compute colour index. 112 - CALL COLWGT(-A,-B,-C,WW) 113 - IF(WW.GT.0)THEN 114 - ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 115 - ELSE 116 - ICOL=IOFCOL 117 - ENDIF 118 - * Store the plane. 119 - CALL PLABU1('STORE',IREF,N,XPL,YPL,ZPL,-A,-B,-C,ICOL,IVOL,IFAIL) 120 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACYP WARNING : Unable to'// 121 - - ' store the bottom lid of a cylinder.' 122 - *** Create the side panels. 123 - U=R*COS(AROT+2.0D0*PI*DBLE(0)/DBLE(N)) 124 - V=R*SIN(AROT+2.0D0*PI*DBLE(0)/DBLE(N)) 125 - W=ZL 126 - * Rotate into place. 127 - XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W 128 - YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W 129 - ZPL(1)=Z0 -ST*U +CT*W 130 - XPL(2)=X0+CP*CT*U-SP*V-CP*ST*W 131 - YPL(2)=Y0+SP*CT*U+CP*V-SP*ST*W 132 - ZPL(2)=Z0 -ST*U -CT*W 133 - ** Go around the cylinder. 134 - DO 30 I=1,N 135 - * Bottom and top of the line along the axis of the cylinder. 136 - U=R*COS(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) 137 - V=R*SIN(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) 138 - W=ZL 139 - * Rotated into place. 140 - XPL(3)=X0+CP*CT*U-SP*V-CP*ST*W 141 - YPL(3)=Y0+SP*CT*U+CP*V-SP*ST*W 142 - ZPL(3)=Z0 -ST*U -CT*W 143 - XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W 144 - YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W 145 - ZPL(4)=Z0 -ST*U +CT*W 146 - * Compute the colour index for this segment. 147 - CALL COLWGT(CP*CT*COS(AROT+2.0D0*PI*(I-0.5)/DBLE(N))- 148 - - SP*SIN(AROT+2.0D0*PI*(I-0.5)/DBLE(N)), 149 - - SP*CT*COS(AROT+2.0D0*PI*(I-0.5)/DBLE(N))+ 150 - - CP*SIN(AROT+2.0D0*PI*(I-0.5)/DBLE(N)), 151 - - -ST*COS(AROT+2.0D0*PI*(I-0.5)/DBLE(N)),WW) 152 - IF(WW.GT.0)THEN 153 - ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 154 - ELSE 155 - ICOL=IOFCOL 156 - ENDIF 157 - * Store the plane. 158 - CALL PLABU1('STORE',IREF,4,XPL,YPL,ZPL, 159 - - CP*CT*COS(AROT+2.0D0*PI*(I-0.5)/DBLE(N))- 160 - - SP*SIN(AROT+2.0D0*PI*(I-0.5)/DBLE(N)), 161 - - SP*CT*COS(AROT+2.0D0*PI*(I-0.5)/DBLE(N))+ 162 - - CP*SIN(AROT+2.0D0*PI*(I-0.5)/DBLE(N)), 163 - - -ST*COS(AROT+2.0D0*PI*(I-0.5)/DBLE(N)), 164 - - ICOL,IVOL,IFAIL) 165 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACYP WARNING : Unable to'// 166 - - ' store a panel of a cylinder.' 167 - * Shift the points. 168 - XPL(1)=XPL(4) 169 - YPL(1)=YPL(4) 170 - ZPL(1)=ZPL(4) 171 - XPL(2)=XPL(3) 172 - YPL(2)=YPL(3) 173 - ZPL(2)=ZPL(3) 174 - 30 CONTINUE 175 - *** Look for intersections with the outside box, x=xmin. 176 - CALL PLACYC(IVOL,GXMIN,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, 177 - - -1.0D0,0.0D0,0.0D0,IOFCOL+1) 178 - * x=xmax. 179 - CALL PLACYC(IVOL,GXMAX,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, 180 - - +1.0D0,0.0D0,0.0D0,IOFCOL+1) 181 - * y=ymin. 182 - CALL PLACYC(IVOL,(GXMIN+GXMAX)/2,GYMIN,(GZMIN+GZMAX)/2, 183 - - 0.0D0,-1.0D0,0.0D0,IOFCOL+1) 184 - * y=ymax. 185 - CALL PLACYC(IVOL,(GXMIN+GXMAX)/2,GYMAX,(GZMIN+GZMAX)/2, 186 - - 0.0D0,+1.0D0,0.0D0,IOFCOL+1) 187 - * z=zmin. 188 - CALL PLACYC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMIN, 189 - - 0.0D0,0.0D0,-1.0D0,IOFCOL+1) 190 - * z=zmax. 191 - CALL PLACYC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMAX, 192 - - 0.0D0,0.0D0,+1.0D0,IOFCOL+1) 193 - END 242 GARFIELD ================================================== P=PROJECTI D=PLACYC 1 ============================ 0 + +DECK,PLACYC. 1 - SUBROUTINE PLACYC(IVOL,X0PL,Y0PL,Z0PL,APL,BPL,CPL,ICOL) 2 - *----------------------------------------------------------------------- 3 - * PLACYC - Cuts cylinder IVOL with a plane. 4 - * (Last changed on 12/ 8/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,SOLIDS. 11.- +SEQ,GRAPHICS. 12.- +SEQ,PRINTPLOT. 13 - INTEGER IREF,NMAX,N,IVOL,IFAIL,I,NPL,ICOL 14 - PARAMETER(NMAX=50) 1 242 P=PROJECTI D=PLACYC 2 PAGE 315 15 - DOUBLE PRECISION R,ZL,X0,Y0,Z0,A,B,C,CT,ST,CP,SP,FNORM,AROT, 16 - - U,V,W,X1,Y1,Z1,X2,Y2,Z2,XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), 17 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XCUT,YCUT,ZCUT 18 - *** Locate the conductor. 19 - IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN 20 - PRINT *,' !!!!!! PLACYC WARNING : Volume reference is out'// 21 - - ' of range ; not plotted.' 22 - RETURN 23 - ENDIF 24 - IREF=ISTART(IVOL) 25 - IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN 26 - PRINT *,' !!!!!! PLACYC WARNING : Volume address is out'// 27 - - ' of range ; not plotted.' 28 - RETURN 29 - ENDIF 30 - *** Locate the cylinder parameters, first the radius. 31 - R= CBUF(IREF+1) 32 - IF(R.LE.0)THEN 33 - PRINT *,' !!!!!! PLACYC WARNING : Cylinder ',IVOL,' has a'// 34 - - ' non-positive radius; not plotted.' 35 - RETURN 36 - ENDIF 37 - * Half length in z. 38 - ZL=ABS(CBUF(IREF+2)) 39 - * Centre. 40 - X0=CBUF(IREF+3) 41 - Y0=CBUF(IREF+4) 42 - Z0=CBUF(IREF+5) 43 - * Direction vector. 44 - FNORM=SQRT(CBUF(IREF+6)**2+CBUF(IREF+7)**2+CBUF(IREF+8)**2) 45 - IF(FNORM.LE.0)THEN 46 - PRINT *,' !!!!!! PLACYC WARNING : Cylinder ',IVOL,' has a'// 47 - - ' zero norm direction vector; not plotted.' 48 - RETURN 49 - ENDIF 50 - A= CBUF(IREF+6)/FNORM 51 - B= CBUF(IREF+7)/FNORM 52 - C= CBUF(IREF+8)/FNORM 53 - N=MIN(NMAX-1,NINT(CBUF(IREF+9))) 54 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACYC DEBUG : Drawing a'', 55 - - '' cylinder of volume '',I4/26X,''Radius='',E10.3, 56 - - '', Half-length='',E10.3/26X,''Centre= '',3E10.3/ 57 - - 26X,''Direction='',3E10.3)') IVOL,R,ZL,X0,Y0,Z0,A,B,C 58 - * Shorthand for the rotations. 59 - CT=CBUF(IREF+10) 60 - ST=CBUF(IREF+11) 61 - CP=CBUF(IREF+12) 62 - SP=CBUF(IREF+13) 63 - * Axial rotation. 64 - AROT=CBUF(IREF+14) 65 - *** Determine a suitable number of points on the radii. 66 - IF(N.LT.1)THEN 67 - IF(R.LT.1E-3*MAX(ABS(FRXMAX-FRXMIN),ABS(FRYMAX-FRYMIN)))THEN 68 - N=MIN(MXEDGE-1,NMAX-1,5) 69 - ELSEIF(R.LT.1E-2*MAX(ABS(FRXMAX-FRXMIN), 70 - - ABS(FRYMAX-FRYMIN)))THEN 71 - N=MIN(MXEDGE-1,NMAX-1,10) 72 - ELSEIF(R.LT.1E-1*MAX(ABS(FRXMAX-FRXMIN), 73 - - ABS(FRYMAX-FRYMIN)))THEN 74 - N=MIN(MXEDGE-1,NMAX-1,100) 75 - ELSE 76 - N=MIN(MXEDGE-1,NMAX-1) 77 - ENDIF 78 - ENDIF 79 - *** Initialise the number of points. 80 - NPL=0 81 - *** Go through the lines of the top lid, first point. 82 - U=R*COS(AROT+2.0D0*PI*DBLE(0)/DBLE(N)) 83 - V=R*SIN(AROT+2.0D0*PI*DBLE(0)/DBLE(N)) 84 - W=ZL 85 - X1=X0+CP*CT*U-SP*V+CP*ST*W 86 - Y1=Y0+SP*CT*U+CP*V+SP*ST*W 87 - Z1=Z0 -ST*U +CT*W 88 - * Loop over the points. 89 - DO 10 I=1,N 90 - * Local coordinates, 91 - U=R*COS(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) 92 - V=R*SIN(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) 93 - W=ZL 94 - * Rotate into place. 95 - X2=X0+CP*CT*U-SP*V+CP*ST*W 96 - Y2=Y0+SP*CT*U+CP*V+SP*ST*W 97 - Z2=Z0 -ST*U +CT*W 98 - * Cut with the plane. 99 - CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, 100 - - XCUT,YCUT,ZCUT,IFAIL) 101 - * Store the result if there is one. 102 - IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN 103 - NPL=NPL+1 104 - XPL(NPL)=XCUT 105 - YPL(NPL)=YCUT 106 - ZPL(NPL)=ZCUT 107 - ELSEIF(NPL.GE.MXEDGE)THEN 108 - PRINT *,' !!!!!! PLACYC WARNING : Too many intersects'// 109 - - ' between cylinder and plane; stopped.' 110 - RETURN 111 - ENDIF 112 - * Shift the coordinates. 113 - X1=X2 114 - Y1=Y2 115 - Z1=Z2 116 - 10 CONTINUE 117 - *** Go through the lines of the bottom lid, first point. 118 - U=R*COS(AROT+2.0D0*PI*DBLE(0)/DBLE(N)) 119 - V=R*SIN(AROT+2.0D0*PI*DBLE(0)/DBLE(N)) 120 - W=-ZL 1 242 P=PROJECTI D=PLACYC 3 PAGE 316 121 - X1=X0+CP*CT*U-SP*V+CP*ST*W 122 - Y1=Y0+SP*CT*U+CP*V+SP*ST*W 123 - Z1=Z0 -ST*U +CT*W 124 - * Loop over the points. 125 - DO 20 I=1,N 126 - * Local coordinates, 127 - U=R*COS(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) 128 - V=R*SIN(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) 129 - W=-ZL 130 - * Rotate into place. 131 - X2=X0+CP*CT*U-SP*V+CP*ST*W 132 - Y2=Y0+SP*CT*U+CP*V+SP*ST*W 133 - Z2=Z0 -ST*U +CT*W 134 - * Cut with the plane. 135 - CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, 136 - - XCUT,YCUT,ZCUT,IFAIL) 137 - * Store the result if there is one. 138 - IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN 139 - NPL=NPL+1 140 - XPL(NPL)=XCUT 141 - YPL(NPL)=YCUT 142 - ZPL(NPL)=ZCUT 143 - ELSEIF(NPL.GE.MXEDGE)THEN 144 - PRINT *,' !!!!!! PLACYC WARNING : Too many intersects'// 145 - - ' between cylinder and plane; stopped.' 146 - RETURN 147 - ENDIF 148 - * Shift the coordinates. 149 - X1=X2 150 - Y1=Y2 151 - Z1=Z2 152 - 20 CONTINUE 153 - *** Go through the ribs. 154 - DO 30 I=1,N 155 - * Bottom and top of the line along the axis of the cylinder. 156 - U=R*COS(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) 157 - V=R*SIN(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) 158 - W=ZL 159 - * Rotated into place. 160 - X1=X0+CP*CT*U-SP*V-CP*ST*W 161 - Y1=Y0+SP*CT*U+CP*V-SP*ST*W 162 - Z1=Z0 -ST*U -CT*W 163 - X2=X0+CP*CT*U-SP*V+CP*ST*W 164 - Y2=Y0+SP*CT*U+CP*V+SP*ST*W 165 - Z2=Z0 -ST*U +CT*W 166 - * Cut with the plane. 167 - CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, 168 - - XCUT,YCUT,ZCUT,IFAIL) 169 - * Store the result if there is one. 170 - IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN 171 - NPL=NPL+1 172 - XPL(NPL)=XCUT 173 - YPL(NPL)=YCUT 174 - ZPL(NPL)=ZCUT 175 - ELSEIF(NPL.GE.MXEDGE)THEN 176 - PRINT *,' !!!!!! PLACYC WARNING : Too many intersects'// 177 - - ' between cylinder and plane; stopped.' 178 - RETURN 179 - ENDIF 180 - 30 CONTINUE 181 - *** Get rid of butterflies. 182 - CALL BUTFLD(NPL,XPL,YPL,ZPL) 183 - *** Store the plane. 184 - IF(NPL.GE.3)THEN 185 - CALL PLABU1('STORE',IREF,NPL,XPL,YPL,ZPL, 186 - - APL,BPL,CPL,ICOL,IVOL,IFAIL) 187 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACYC WARNING : Failed to'// 188 - - ' store a side cut of a cylinder.' 189 - ENDIF 190 - END 243 GARFIELD ================================================== P=PROJECTI D=PLACYI 1 ============================ 0 + +DECK,PLACYI. 1 - SUBROUTINE PLACYI(IVOL,XPOS,YPOS,ZPOS,INSIDE) 2 - *----------------------------------------------------------------------- 3 - * PLACYI - Determines whether a point is located inside a cylinder. 4 - * (Last changed on 12/ 8/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,SOLIDS. 10.- +SEQ,PRINTPLOT. 11 - INTEGER IREF,IVOL 12 - DOUBLE PRECISION R,ZL,X0,Y0,Z0,CT,ST,CP,SP,XPOS,YPOS,ZPOS,U,V,W, 13 - - AROT 14 - LOGICAL INSIDE 15 - *** Locate the conductor. 16 - IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN 17 - PRINT *,' !!!!!! PLACYI WARNING : Volume reference is out'// 18 - - ' of range ; not checked.' 19 - RETURN 20 - ENDIF 21 - IREF=ISTART(IVOL) 22 - IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN 23 - PRINT *,' !!!!!! PLACYI WARNING : Volume address is out'// 24 - - ' of range ; not checked.' 25 - RETURN 26 - ENDIF 27 - *** Locate the cylinder parameters, first the radius. 28 - R= CBUF(IREF+1) 29 - IF(R.LE.0)THEN 30 - PRINT *,' !!!!!! PLACYI WARNING : Cylinder ',IVOL,' has a'// 31 - - ' non-positive radius; not checked.' 32 - RETURN 1 243 P=PROJECTI D=PLACYI 2 PAGE 317 33 - ENDIF 34 - * Half length in z. 35 - ZL=ABS(CBUF(IREF+2)) 36 - * Centre. 37 - X0=CBUF(IREF+3) 38 - Y0=CBUF(IREF+4) 39 - Z0=CBUF(IREF+5) 40 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACYI DEBUG : Checking'', 41 - - '' cylindric volume '',I4/26X,''Radius='',E10.3, 42 - - '', Half-length='',E10.3/26X,''Centre= '',3E10.3)') 43 - - IVOL,R,ZL,X0,Y0,Z0 44 - * Shorthand for the rotations. 45 - CT=CBUF(IREF+10) 46 - ST=CBUF(IREF+11) 47 - CP=CBUF(IREF+12) 48 - SP=CBUF(IREF+13) 49 - * Axial rotation. 50 - AROT=CBUF(IREF+14) 51 - *** Transform the point to local coordinates. 52 - U=+CP*CT*(XPOS-X0)+SP*CT*(YPOS-Y0)-ST*(ZPOS-Z0) 53 - V=-SP *(XPOS-X0)+CP* (YPOS-Y0) 54 - W=+CP*ST*(XPOS-X0)+SP*ST*(YPOS-Y0)+CT*(ZPOS-Z0) 55 - *** See whether the point is inside. 56 - IF(ABS(W).GT.ZL.OR.U**2+V**2.GT.R**2)THEN 57 - INSIDE=.FALSE. 58 - ELSE 59 - INSIDE=.TRUE. 60 - ENDIF 61 - END 244 GARFIELD ================================================== P=PROJECTI D=PLABXP 1 ============================ 0 + +DECK,PLABXP. 1 - SUBROUTINE PLABXP(IVOL,IOFCOL) 2 - *----------------------------------------------------------------------- 3 - * PLABXP - Plots a box in 3D perspective. 4 - * (Last changed on 19/11/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,SOLIDS. 11.- +SEQ,GRAPHICS. 12.- +SEQ,PRINTPLOT. 13 - INTEGER IVOL,IREF,IOFCOL,ICOL,IFAIL 14 - DOUBLE PRECISION XL,YL,ZL,X0,Y0,Z0,A,B,C,CT,ST,CP,SP, 15 - - U1,V1,W1,WW,FNORM,XPL(4),YPL(4),ZPL(4) 16 - *** Locate the conductor. 17 - IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN 18 - PRINT *,' !!!!!! PLABXP WARNING : Volume reference is out'// 19 - - ' of range ; not plotted.' 20 - RETURN 21 - ENDIF 22 - IREF=ISTART(IVOL) 23 - IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN 24 - PRINT *,' !!!!!! PLABXP WARNING : Volume address is out'// 25 - - ' of range ; not plotted.' 26 - RETURN 27 - ENDIF 28 - *** Locate the cube parameters. 29 - XL=ABS(CBUF(IREF+1)) 30 - YL=ABS(CBUF(IREF+2)) 31 - ZL=ABS(CBUF(IREF+3)) 32 - X0=CBUF(IREF+4) 33 - Y0=CBUF(IREF+5) 34 - Z0=CBUF(IREF+6) 35 - FNORM=SQRT(CBUF(IREF+7)**2+CBUF(IREF+8)**2+CBUF(IREF+9)**2) 36 - IF(FNORM.LE.0)THEN 37 - PRINT *,' !!!!!! PLABXP WARNING : Box ',IVOL,' has a'// 38 - - ' zero norm direction vector; not plotted.' 39 - RETURN 40 - ENDIF 41 - A= CBUF(IREF+7)/FNORM 42 - B= CBUF(IREF+8)/FNORM 43 - C= CBUF(IREF+9)/FNORM 44 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLABXP DEBUG : Drawing a'', 45 - - '' box from address '',I4/26X,''Centre= '',3E10.3/ 46 - - 26X,''Half-lengths='',3E10.3/26X,''Direction= '',3E10.3)') 47 - - IREF,X0,Y0,Z0,XL,YL,ZL,A,B,C 48 - * Shorthand for the rotations. 49 - CT=CBUF(IREF+10) 50 - ST=CBUF(IREF+11) 51 - CP=CBUF(IREF+12) 52 - SP=CBUF(IREF+13) 53 - *** Draw the 6 sides of the box, start with the x=xmin face. 54 - U1=-XL 55 - V1=-YL 56 - W1=-ZL 57 - XPL(1)=X0+CP*CT*U1-SP*V1+CP*ST*W1 58 - YPL(1)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 59 - ZPL(1)=Z0 -ST*U1 +CT*W1 60 - U1=-XL 61 - V1=+YL 62 - W1=-ZL 63 - XPL(2)=X0+CP*CT*U1-SP*V1+CP*ST*W1 64 - YPL(2)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 65 - ZPL(2)=Z0 -ST*U1 +CT*W1 66 - U1=-XL 67 - V1=+YL 68 - W1=+ZL 69 - XPL(3)=X0+CP*CT*U1-SP*V1+CP*ST*W1 70 - YPL(3)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 71 - ZPL(3)=Z0 -ST*U1 +CT*W1 72 - U1=-XL 73 - V1=-YL 1 244 P=PROJECTI D=PLABXP 2 PAGE 318 74 - W1=+ZL 75 - XPL(4)=X0+CP*CT*U1-SP*V1+CP*ST*W1 76 - YPL(4)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 77 - ZPL(4)=Z0 -ST*U1 +CT*W1 78 - CALL COLWGT(-CP*CT,-SP*CT,+ST,WW) 79 - IF(WW.GE.0)THEN 80 - ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 81 - ELSE 82 - ICOL=IOFCOL 83 - ENDIF 84 - CALL PLABU1('STORE',IREF,4,XPL,YPL,ZPL,-CP*CT,-SP*CT,+ST, 85 - - ICOL,IVOL,IFAIL) 86 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLABXP WARNING : Unable to'// 87 - - ' store a panel of a box.' 88 - * The x=xmax face. 89 - U1=+XL 90 - V1=-YL 91 - W1=-ZL 92 - XPL(1)=X0+CP*CT*U1-SP*V1+CP*ST*W1 93 - YPL(1)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 94 - ZPL(1)=Z0 -ST*U1 +CT*W1 95 - U1=+XL 96 - V1=+YL 97 - W1=-ZL 98 - XPL(2)=X0+CP*CT*U1-SP*V1+CP*ST*W1 99 - YPL(2)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 100 - ZPL(2)=Z0 -ST*U1 +CT*W1 101 - U1=+XL 102 - V1=+YL 103 - W1=+ZL 104 - XPL(3)=X0+CP*CT*U1-SP*V1+CP*ST*W1 105 - YPL(3)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 106 - ZPL(3)=Z0 -ST*U1 +CT*W1 107 - U1=+XL 108 - V1=-YL 109 - W1=+ZL 110 - XPL(4)=X0+CP*CT*U1-SP*V1+CP*ST*W1 111 - YPL(4)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 112 - ZPL(4)=Z0 -ST*U1 +CT*W1 113 - CALL COLWGT(CP*CT,SP*CT,-ST,WW) 114 - IF(WW.GE.0)THEN 115 - ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 116 - ELSE 117 - ICOL=IOFCOL 118 - ENDIF 119 - CALL PLABU1('STORE',IREF,4,XPL,YPL,ZPL,CP*CT,SP*CT,-ST, 120 - - ICOL,IVOL,IFAIL) 121 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLABXP WARNING : Unable to'// 122 - - ' store a panel of a box.' 123 - * The y=ymin face. 124 - U1=-XL 125 - V1=-YL 126 - W1=-ZL 127 - XPL(1)=X0+CP*CT*U1-SP*V1+CP*ST*W1 128 - YPL(1)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 129 - ZPL(1)=Z0 -ST*U1 +CT*W1 130 - U1=+XL 131 - V1=-YL 132 - W1=-ZL 133 - XPL(2)=X0+CP*CT*U1-SP*V1+CP*ST*W1 134 - YPL(2)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 135 - ZPL(2)=Z0 -ST*U1 +CT*W1 136 - U1=+XL 137 - V1=-YL 138 - W1=+ZL 139 - XPL(3)=X0+CP*CT*U1-SP*V1+CP*ST*W1 140 - YPL(3)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 141 - ZPL(3)=Z0 -ST*U1 +CT*W1 142 - U1=-XL 143 - V1=-YL 144 - W1=+ZL 145 - XPL(4)=X0+CP*CT*U1-SP*V1+CP*ST*W1 146 - YPL(4)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 147 - ZPL(4)=Z0 -ST*U1 +CT*W1 148 - CALL COLWGT(+SP,-CP,0.0D0,WW) 149 - IF(WW.GE.0)THEN 150 - ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 151 - ELSE 152 - ICOL=IOFCOL 153 - ENDIF 154 - CALL PLABU1('STORE',IREF,4,XPL,YPL,ZPL,SP,-CP,0.0D0, 155 - - ICOL,IVOL,IFAIL) 156 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLABXP WARNING : Unable to'// 157 - - ' store a panel of a box.' 158 - * The y=ymax face. 159 - U1=-XL 160 - V1=+YL 161 - W1=-ZL 162 - XPL(1)=X0+CP*CT*U1-SP*V1+CP*ST*W1 163 - YPL(1)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 164 - ZPL(1)=Z0 -ST*U1 +CT*W1 165 - U1=+XL 166 - V1=+YL 167 - W1=-ZL 168 - XPL(2)=X0+CP*CT*U1-SP*V1+CP*ST*W1 169 - YPL(2)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 170 - ZPL(2)=Z0 -ST*U1 +CT*W1 171 - U1=+XL 172 - V1=+YL 173 - W1=+ZL 174 - XPL(3)=X0+CP*CT*U1-SP*V1+CP*ST*W1 175 - YPL(3)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 176 - ZPL(3)=Z0 -ST*U1 +CT*W1 177 - U1=-XL 178 - V1=+YL 179 - W1=+ZL 1 244 P=PROJECTI D=PLABXP 3 PAGE 319 180 - XPL(4)=X0+CP*CT*U1-SP*V1+CP*ST*W1 181 - YPL(4)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 182 - ZPL(4)=Z0 -ST*U1 +CT*W1 183 - CALL COLWGT(-SP,+CP,0.0D0,WW) 184 - IF(WW.GE.0)THEN 185 - ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 186 - ELSE 187 - ICOL=IOFCOL 188 - ENDIF 189 - CALL PLABU1('STORE',IREF,4,XPL,YPL,ZPL,-SP,+CP,0.0D0, 190 - - ICOL,IVOL,IFAIL) 191 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLABXP WARNING : Unable to'// 192 - - ' store a panel of a box.' 193 - * The z=zmin face. 194 - U1=-XL 195 - V1=-YL 196 - W1=-ZL 197 - XPL(1)=X0+CP*CT*U1-SP*V1+CP*ST*W1 198 - YPL(1)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 199 - ZPL(1)=Z0 -ST*U1 +CT*W1 200 - U1=-XL 201 - V1=+YL 202 - W1=-ZL 203 - XPL(2)=X0+CP*CT*U1-SP*V1+CP*ST*W1 204 - YPL(2)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 205 - ZPL(2)=Z0 -ST*U1 +CT*W1 206 - U1=+XL 207 - V1=+YL 208 - W1=-ZL 209 - XPL(3)=X0+CP*CT*U1-SP*V1+CP*ST*W1 210 - YPL(3)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 211 - ZPL(3)=Z0 -ST*U1 +CT*W1 212 - U1=+XL 213 - V1=-YL 214 - W1=-ZL 215 - XPL(4)=X0+CP*CT*U1-SP*V1+CP*ST*W1 216 - YPL(4)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 217 - ZPL(4)=Z0 -ST*U1 +CT*W1 218 - CALL COLWGT(-CP*ST,-SP*ST,-CT,WW) 219 - IF(WW.GE.0)THEN 220 - ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 221 - ELSE 222 - ICOL=IOFCOL 223 - ENDIF 224 - CALL PLABU1('STORE',IREF,4,XPL,YPL,ZPL,-CP*ST,-SP*ST,-CT, 225 - - ICOL,IVOL,IFAIL) 226 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLABXP WARNING : Unable to'// 227 - - ' store a panel of a box.' 228 - * The z=zmax face. 229 - U1=-XL 230 - V1=-YL 231 - W1=+ZL 232 - XPL(1)=X0+CP*CT*U1-SP*V1+CP*ST*W1 233 - YPL(1)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 234 - ZPL(1)=Z0 -ST*U1 +CT*W1 235 - U1=-XL 236 - V1=+YL 237 - W1=+ZL 238 - XPL(2)=X0+CP*CT*U1-SP*V1+CP*ST*W1 239 - YPL(2)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 240 - ZPL(2)=Z0 -ST*U1 +CT*W1 241 - U1=+XL 242 - V1=+YL 243 - W1=+ZL 244 - XPL(3)=X0+CP*CT*U1-SP*V1+CP*ST*W1 245 - YPL(3)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 246 - ZPL(3)=Z0 -ST*U1 +CT*W1 247 - U1=+XL 248 - V1=-YL 249 - W1=+ZL 250 - XPL(4)=X0+CP*CT*U1-SP*V1+CP*ST*W1 251 - YPL(4)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 252 - ZPL(4)=Z0 -ST*U1 +CT*W1 253 - CALL COLWGT(+CP*ST,+SP*ST,+CT,WW) 254 - IF(WW.GE.0)THEN 255 - ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 256 - ELSE 257 - ICOL=IOFCOL 258 - ENDIF 259 - CALL PLABU1('STORE',IREF,4,XPL,YPL,ZPL,+CP*ST,+SP*ST,+CT, 260 - - ICOL,IVOL,IFAIL) 261 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLABXP WARNING : Unable to'// 262 - - ' store a panel of a box.' 263 - *** Look for intersections with the outside box, x=xmin. 264 - CALL PLABXC(IVOL,GXMIN,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, 265 - - -1.0D0,0.0D0,0.0D0,IOFCOL+1) 266 - * x=xmax. 267 - CALL PLABXC(IVOL,GXMAX,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, 268 - - +1.0D0,0.0D0,0.0D0,IOFCOL+1) 269 - * y=ymin. 270 - CALL PLABXC(IVOL,(GXMIN+GXMAX)/2,GYMIN,(GZMIN+GZMAX)/2, 271 - - 0.0D0,-1.0D0,0.0D0,IOFCOL+1) 272 - * y=ymax. 273 - CALL PLABXC(IVOL,(GXMIN+GXMAX)/2,GYMAX,(GZMIN+GZMAX)/2, 274 - - 0.0D0,+1.0D0,0.0D0,IOFCOL+1) 275 - * z=zmin. 276 - CALL PLABXC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMIN, 277 - - 0.0D0,0.0D0,-1.0D0,IOFCOL+1) 278 - * z=zmax. 279 - CALL PLABXC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMAX, 280 - - 0.0D0,0.0D0,+1.0D0,IOFCOL+1) 281 - END 1 245 GARFIELD ================================================== P=PROJECTI D=PLABXC 1 =================== PAGE 320 0 + +DECK,PLABXC. 1 - SUBROUTINE PLABXC(IVOL,X0PL,Y0PL,Z0PL,APL,BPL,CPL,ICOL) 2 - *----------------------------------------------------------------------- 3 - * PLABXC - Cuts box IVOL with a plane. 4 - * (Last changed on 19/11/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,SOLIDS. 11.- +SEQ,GRAPHICS. 12.- +SEQ,PRINTPLOT. 13 - INTEGER IREF,IVOL,IFAIL,NPL,ICOL 14 - DOUBLE PRECISION X0,Y0,Z0,A,B,C,XL,YL,ZL,CT,ST,CP,SP, 15 - - FNORM,U1,V1,W1,U2,V2,W2,X1,Y1,Z1,X2,Y2,Z2, 16 - - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), 17 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XCUT,YCUT,ZCUT 18 - *** Locate the conductor. 19 - IF(ABS(IVOL).LT.1.OR.ABS(IVOL).GT.MXSOLI)THEN 20 - PRINT *,' !!!!!! PLABXC WARNING : Volume reference is out'// 21 - - ' of range ; not plotted.' 22 - RETURN 23 - ENDIF 24 - IREF=ISTART(ABS(IVOL)) 25 - IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN 26 - PRINT *,' !!!!!! PLABXC WARNING : Volume address is out'// 27 - - ' of range ; not plotted.' 28 - RETURN 29 - ENDIF 30 - *** Locate the cube parameters. 31 - XL=ABS(CBUF(IREF+1)) 32 - YL=ABS(CBUF(IREF+2)) 33 - ZL=ABS(CBUF(IREF+3)) 34 - X0=CBUF(IREF+4) 35 - Y0=CBUF(IREF+5) 36 - Z0=CBUF(IREF+6) 37 - FNORM=SQRT(CBUF(IREF+7)**2+CBUF(IREF+8)**2+CBUF(IREF+9)**2) 38 - IF(FNORM.LE.0)THEN 39 - PRINT *,' !!!!!! PLABXC WARNING : Box ',ABS(IVOL),' has a'// 40 - - ' zero norm direction vector; not plotted.' 41 - RETURN 42 - ENDIF 43 - A= CBUF(IREF+7)/FNORM 44 - B= CBUF(IREF+8)/FNORM 45 - C= CBUF(IREF+9)/FNORM 46 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLABXC DEBUG : Drawing a'', 47 - - '' box from address '',I4/26X,''Centre= '',3E10.3/ 48 - - 26X,''Half-lengths='',3E10.3/26X,''Direction= '',3E10.3)') 49 - - IREF,X0,Y0,Z0,XL,YL,ZL,A,B,C 50 - * Shorthand for the rotations. 51 - CT=CBUF(IREF+10) 52 - ST=CBUF(IREF+11) 53 - CP=CBUF(IREF+12) 54 - SP=CBUF(IREF+13) 55 - *** Initial number of points. 56 - NPL=0 57 - *** Draw all 12 lines and cut, (xmin,ymin,zmin) to (xmax,ymin,zmin). 58 - U1=-XL 59 - V1=-YL 60 - W1=-ZL 61 - X1=X0+CP*CT*U1-SP*V1+CP*ST*W1 62 - Y1=Y0+SP*CT*U1+CP*V1+SP*ST*W1 63 - Z1=Z0 -ST*U1 +CT*W1 64 - U2=+XL 65 - V2=-YL 66 - W2=-ZL 67 - X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 68 - Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 69 - Z2=Z0 -ST*U2 +CT*W2 70 - * Cut with the plane. 71 - CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, 72 - - XCUT,YCUT,ZCUT,IFAIL) 73 - * Store the result if there is one. 74 - IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN 75 - NPL=NPL+1 76 - XPL(NPL)=XCUT 77 - YPL(NPL)=YCUT 78 - ZPL(NPL)=ZCUT 79 - ELSEIF(NPL.GE.MXEDGE)THEN 80 - PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// 81 - - ' between box and plane; stopped.' 82 - RETURN 83 - ENDIF 84 - ** ... to (xmin,ymax,zmin). 85 - U2=-XL 86 - V2=+YL 87 - W2=-ZL 88 - X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 89 - Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 90 - Z2=Z0 -ST*U2 +CT*W2 91 - * Cut with the plane. 92 - CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, 93 - - XCUT,YCUT,ZCUT,IFAIL) 94 - * Store the result if there is one. 95 - IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN 96 - NPL=NPL+1 97 - XPL(NPL)=XCUT 98 - YPL(NPL)=YCUT 99 - ZPL(NPL)=ZCUT 100 - ELSEIF(NPL.GE.MXEDGE)THEN 101 - PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// 102 - - ' between box and plane; stopped.' 103 - RETURN 104 - ENDIF 105 - ** ... to (xmin,ymin,zmax). 1 245 P=PROJECTI D=PLABXC 2 PAGE 321 106 - U2=-XL 107 - V2=-YL 108 - W2=+ZL 109 - X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 110 - Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 111 - Z2=Z0 -ST*U2 +CT*W2 112 - * Cut with the plane. 113 - CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, 114 - - XCUT,YCUT,ZCUT,IFAIL) 115 - * Store the result if there is one. 116 - IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN 117 - NPL=NPL+1 118 - XPL(NPL)=XCUT 119 - YPL(NPL)=YCUT 120 - ZPL(NPL)=ZCUT 121 - ELSEIF(NPL.GE.MXEDGE)THEN 122 - PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// 123 - - ' between box and plane; stopped.' 124 - RETURN 125 - ENDIF 126 - *** The line (xmax,ymax,zmin) to (xmin,ymax,zmin). 127 - U1=+XL 128 - V1=+YL 129 - W1=-ZL 130 - X1=X0+CP*CT*U1-SP*V1+CP*ST*W1 131 - Y1=Y0+SP*CT*U1+CP*V1+SP*ST*W1 132 - Z1=Z0 -ST*U1 +CT*W1 133 - U2=-XL 134 - V2=+YL 135 - W2=-ZL 136 - X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 137 - Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 138 - Z2=Z0 -ST*U2 +CT*W2 139 - * Cut with the plane. 140 - CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, 141 - - XCUT,YCUT,ZCUT,IFAIL) 142 - * Store the result if there is one. 143 - IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN 144 - NPL=NPL+1 145 - XPL(NPL)=XCUT 146 - YPL(NPL)=YCUT 147 - ZPL(NPL)=ZCUT 148 - ELSEIF(NPL.GE.MXEDGE)THEN 149 - PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// 150 - - ' between box and plane; stopped.' 151 - RETURN 152 - ENDIF 153 - ** ... to (xmax,ymin,zmin). 154 - U2=+XL 155 - V2=-YL 156 - W2=-ZL 157 - X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 158 - Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 159 - Z2=Z0 -ST*U2 +CT*W2 160 - * Cut with the plane. 161 - CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, 162 - - XCUT,YCUT,ZCUT,IFAIL) 163 - * Store the result if there is one. 164 - IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN 165 - NPL=NPL+1 166 - XPL(NPL)=XCUT 167 - YPL(NPL)=YCUT 168 - ZPL(NPL)=ZCUT 169 - ELSEIF(NPL.GE.MXEDGE)THEN 170 - PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// 171 - - ' between box and plane; stopped.' 172 - RETURN 173 - ENDIF 174 - ** ... to (xmax,ymax,zmax). 175 - U2=+XL 176 - V2=+YL 177 - W2=+ZL 178 - X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 179 - Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 180 - Z2=Z0 -ST*U2 +CT*W2 181 - * Cut with the plane. 182 - CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, 183 - - XCUT,YCUT,ZCUT,IFAIL) 184 - * Store the result if there is one. 185 - IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN 186 - NPL=NPL+1 187 - XPL(NPL)=XCUT 188 - YPL(NPL)=YCUT 189 - ZPL(NPL)=ZCUT 190 - ELSEIF(NPL.GE.MXEDGE)THEN 191 - PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// 192 - - ' between box and plane; stopped.' 193 - RETURN 194 - ENDIF 195 - *** The line (xmin,ymax,zmax) to (xmax,ymax,zmax). 196 - U1=-XL 197 - V1=+YL 198 - W1=+ZL 199 - X1=X0+CP*CT*U1-SP*V1+CP*ST*W1 200 - Y1=Y0+SP*CT*U1+CP*V1+SP*ST*W1 201 - Z1=Z0 -ST*U1 +CT*W1 202 - U2=+XL 203 - V2=+YL 204 - W2=+ZL 205 - X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 206 - Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 207 - Z2=Z0 -ST*U2 +CT*W2 208 - * Cut with the plane. 209 - CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, 210 - - XCUT,YCUT,ZCUT,IFAIL) 211 - * Store the result if there is one. 1 245 P=PROJECTI D=PLABXC 3 PAGE 322 212 - IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN 213 - NPL=NPL+1 214 - XPL(NPL)=XCUT 215 - YPL(NPL)=YCUT 216 - ZPL(NPL)=ZCUT 217 - ELSEIF(NPL.GE.MXEDGE)THEN 218 - PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// 219 - - ' between box and plane; stopped.' 220 - RETURN 221 - ENDIF 222 - ** ... to (xmin,ymin,zmax). 223 - U2=-XL 224 - V2=-YL 225 - W2=+ZL 226 - X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 227 - Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 228 - Z2=Z0 -ST*U2 +CT*W2 229 - * Cut with the plane. 230 - CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, 231 - - XCUT,YCUT,ZCUT,IFAIL) 232 - * Store the result if there is one. 233 - IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN 234 - NPL=NPL+1 235 - XPL(NPL)=XCUT 236 - YPL(NPL)=YCUT 237 - ZPL(NPL)=ZCUT 238 - ELSEIF(NPL.GE.MXEDGE)THEN 239 - PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// 240 - - ' between box and plane; stopped.' 241 - RETURN 242 - ENDIF 243 - ** ... to (xmin,ymax,zmin). 244 - U1=-XL 245 - V1=+YL 246 - W1=-ZL 247 - X1=X0+CP*CT*U1-SP*V1+CP*ST*W1 248 - Y1=Y0+SP*CT*U1+CP*V1+SP*ST*W1 249 - Z1=Z0 -ST*U1 +CT*W1 250 - U2=-XL 251 - V2=+YL 252 - W2=+ZL 253 - X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 254 - Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 255 - Z2=Z0 -ST*U2 +CT*W2 256 - * Cut with the plane. 257 - CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, 258 - - XCUT,YCUT,ZCUT,IFAIL) 259 - * Store the result if there is one. 260 - IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN 261 - NPL=NPL+1 262 - XPL(NPL)=XCUT 263 - YPL(NPL)=YCUT 264 - ZPL(NPL)=ZCUT 265 - ELSEIF(NPL.GE.MXEDGE)THEN 266 - PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// 267 - - ' between box and plane; stopped.' 268 - RETURN 269 - ENDIF 270 - *** The line (xmax,ymin,zmax) to (xmin,ymin,zmax). 271 - U1=+XL 272 - V1=-YL 273 - W1=+ZL 274 - X1=X0+CP*CT*U1-SP*V1+CP*ST*W1 275 - Y1=Y0+SP*CT*U1+CP*V1+SP*ST*W1 276 - Z1=Z0 -ST*U1 +CT*W1 277 - U2=-XL 278 - V2=-YL 279 - W2=+ZL 280 - X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 281 - Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 282 - Z2=Z0 -ST*U2 +CT*W2 283 - * Cut with the plane. 284 - CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, 285 - - XCUT,YCUT,ZCUT,IFAIL) 286 - * Store the result if there is one. 287 - IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN 288 - NPL=NPL+1 289 - XPL(NPL)=XCUT 290 - YPL(NPL)=YCUT 291 - ZPL(NPL)=ZCUT 292 - ELSEIF(NPL.GE.MXEDGE)THEN 293 - PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// 294 - - ' between box and plane; stopped.' 295 - RETURN 296 - ENDIF 297 - * ... to (xmax,ymax,zmax). 298 - U2=+XL 299 - V2=+YL 300 - W2=+ZL 301 - X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 302 - Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 303 - Z2=Z0 -ST*U2 +CT*W2 304 - * Cut with the plane. 305 - CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, 306 - - XCUT,YCUT,ZCUT,IFAIL) 307 - * Store the result if there is one. 308 - IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN 309 - NPL=NPL+1 310 - XPL(NPL)=XCUT 311 - YPL(NPL)=YCUT 312 - ZPL(NPL)=ZCUT 313 - ELSEIF(NPL.GE.MXEDGE)THEN 314 - PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// 315 - - ' between box and plane; stopped.' 316 - RETURN 317 - ENDIF 1 245 P=PROJECTI D=PLABXC 4 PAGE 323 318 - * ... to (xmax,ymin,zmin). 319 - U2=+XL 320 - V2=-YL 321 - W2=-ZL 322 - X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 323 - Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 324 - Z2=Z0 -ST*U2 +CT*W2 325 - * Cut with the plane. 326 - CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, 327 - - XCUT,YCUT,ZCUT,IFAIL) 328 - * Store the result if there is one. 329 - IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN 330 - NPL=NPL+1 331 - XPL(NPL)=XCUT 332 - YPL(NPL)=YCUT 333 - ZPL(NPL)=ZCUT 334 - ELSEIF(NPL.GE.MXEDGE)THEN 335 - PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// 336 - - ' between box and plane; stopped.' 337 - RETURN 338 - ENDIF 339 - *** Get rid of butterflies. 340 - CALL BUTFLD(NPL,XPL,YPL,ZPL) 341 - *** Store the plane. 342 - IF(NPL.GE.3)THEN 343 - CALL PLABU1('STORE',IREF,NPL,XPL,YPL,ZPL, 344 - - APL,BPL,CPL,ICOL,IVOL,IFAIL) 345 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLABXC WARNING : Failed to'// 346 - - ' store a side cut of a box.' 347 - ENDIF 348 - END 246 GARFIELD ================================================== P=PROJECTI D=PLABXO 1 ============================ 0 + +DECK,PLABXO. 1 - SUBROUTINE PLABXO(IVOL) 2 - *----------------------------------------------------------------------- 3 - * PLABXO - Plots the outlines of a box. 4 - * (Last changed on 8/10/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9.- +SEQ,SOLIDS. 10.- +SEQ,PRINTPLOT. 11 - INTEGER IREF,IVOL 12 - DOUBLE PRECISION X0,Y0,Z0,XL,YL,ZL,CT,ST,CP,SP,U,V,W, 13 - - XPL(5),YPL(5),ZPL(5) 14 - *** Locate the conductor. 15 - IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN 16 - PRINT *,' !!!!!! PLABXO WARNING : Volume reference is out'// 17 - - ' of range ; not plotted.' 18 - RETURN 19 - ENDIF 20 - IREF=ISTART(IVOL) 21 - IF(IREF.LT.0.OR.IREF+11.GT.MXSBUF)THEN 22 - PRINT *,' !!!!!! PLABXO WARNING : Volume address is out'// 23 - - ' of range ; not plotted.' 24 - RETURN 25 - ENDIF 26 - *** Locate the cube parameters. 27 - XL=ABS(CBUF(IREF+1)) 28 - YL=ABS(CBUF(IREF+2)) 29 - ZL=ABS(CBUF(IREF+3)) 30 - X0=CBUF(IREF+4) 31 - Y0=CBUF(IREF+5) 32 - Z0=CBUF(IREF+6) 33 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLABXO DEBUG : Outlining'', 34 - - '' a box from address '',I4/26X,''Centre= '',3E10.3/ 35 - - 26X,''Half-lengths='',3E10.3)') IREF,X0,Y0,Z0,XL,YL,ZL 36 - * Shorthand for the rotations. 37 - CT=CBUF(IREF+10) 38 - ST=CBUF(IREF+11) 39 - CP=CBUF(IREF+12) 40 - SP=CBUF(IREF+13) 41 - *** The z=zmin face. 42 - U=-XL*1.0001 43 - V=-YL*1.0001 44 - W=-ZL*1.0001 45 - XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W 46 - YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W 47 - ZPL(1)=Z0 -ST*U +CT*W 48 - U=-XL*1.0001 49 - V=+YL*1.0001 50 - W=-ZL*1.0001 51 - XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W 52 - YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W 53 - ZPL(2)=Z0 -ST*U +CT*W 54 - U=+XL*1.0001 55 - V=+YL*1.0001 56 - W=-ZL*1.0001 57 - XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W 58 - YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W 59 - ZPL(3)=Z0 -ST*U +CT*W 60 - U=+XL*1.0001 61 - V=-YL*1.0001 62 - W=-ZL*1.0001 63 - XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W 64 - YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W 65 - ZPL(4)=Z0 -ST*U +CT*W 66 - XPL(5)=XPL(1) 67 - YPL(5)=YPL(1) 68 - ZPL(5)=ZPL(1) 69 - CALL PLAGPL(5,XPL,YPL,ZPL) 70 - *** The z=zmax face. 71 - U=-XL*1.0001 1 246 P=PROJECTI D=PLABXO 2 PAGE 324 72 - V=-YL*1.0001 73 - W=+ZL*1.0001 74 - XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W 75 - YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W 76 - ZPL(1)=Z0 -ST*U +CT*W 77 - U=-XL*1.0001 78 - V=+YL*1.0001 79 - W=+ZL*1.0001 80 - XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W 81 - YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W 82 - ZPL(2)=Z0 -ST*U +CT*W 83 - U=+XL*1.0001 84 - V=+YL*1.0001 85 - W=+ZL*1.0001 86 - XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W 87 - YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W 88 - ZPL(3)=Z0 -ST*U +CT*W 89 - U=+XL*1.0001 90 - V=-YL*1.0001 91 - W=+ZL*1.0001 92 - XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W 93 - YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W 94 - ZPL(4)=Z0 -ST*U +CT*W 95 - XPL(5)=XPL(1) 96 - YPL(5)=YPL(1) 97 - ZPL(5)=ZPL(1) 98 - CALL PLAGPL(5,XPL,YPL,ZPL) 99 - *** The ribs. 100 - U=-XL*1.0001 101 - V=-YL*1.0001 102 - W=-ZL*1.0001 103 - XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W 104 - YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W 105 - ZPL(1)=Z0 -ST*U +CT*W 106 - U=-XL*1.0001 107 - V=-YL*1.0001 108 - W=+ZL*1.0001 109 - XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W 110 - YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W 111 - ZPL(2)=Z0 -ST*U +CT*W 112 - CALL PLAGPL(2,XPL,YPL,ZPL) 113 - U=+XL*1.0001 114 - V=-YL*1.0001 115 - W=-ZL*1.0001 116 - XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W 117 - YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W 118 - ZPL(1)=Z0 -ST*U +CT*W 119 - U=+XL*1.0001 120 - V=-YL*1.0001 121 - W=+ZL*1.0001 122 - XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W 123 - YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W 124 - ZPL(2)=Z0 -ST*U +CT*W 125 - CALL PLAGPL(2,XPL,YPL,ZPL) 126 - U=-XL*1.0001 127 - V=+YL*1.0001 128 - W=-ZL*1.0001 129 - XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W 130 - YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W 131 - ZPL(1)=Z0 -ST*U +CT*W 132 - U=-XL*1.0001 133 - V=+YL*1.0001 134 - W=+ZL*1.0001 135 - XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W 136 - YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W 137 - ZPL(2)=Z0 -ST*U +CT*W 138 - CALL PLAGPL(2,XPL,YPL,ZPL) 139 - U=+XL*1.0001 140 - V=+YL*1.0001 141 - W=-ZL*1.0001 142 - XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W 143 - YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W 144 - ZPL(1)=Z0 -ST*U +CT*W 145 - U=+XL*1.0001 146 - V=+YL*1.0001 147 - W=+ZL*1.0001 148 - XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W 149 - YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W 150 - ZPL(2)=Z0 -ST*U +CT*W 151 - CALL PLAGPL(2,XPL,YPL,ZPL) 152 - END 247 GARFIELD ================================================== P=PROJECTI D=PLABXI 1 ============================ 0 + +DECK,PLABXI. 1 - SUBROUTINE PLABXI(IVOL,XPOS,YPOS,ZPOS,INSIDE) 2 - *----------------------------------------------------------------------- 3 - * PLABXI - Determines whether a point is located inside a box. 4 - * (Last changed on 31/ 8/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,SOLIDS. 10.- +SEQ,PRINTPLOT. 11 - INTEGER IVOL,IREF 12 - DOUBLE PRECISION XL,YL,ZL,X0,Y0,Z0,CT,ST,CP,SP, 13 - - XPOS,YPOS,ZPOS,U,V,W 14 - LOGICAL INSIDE 15 - *** Locate the conductor. 16 - IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN 17 - PRINT *,' !!!!!! PLABXI WARNING : Volume reference is out'// 18 - - ' of range ; not checked.' 19 - RETURN 20 - ENDIF 21 - IREF=ISTART(IVOL) 1 247 P=PROJECTI D=PLABXI 2 PAGE 325 22 - IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN 23 - PRINT *,' !!!!!! PLABXI WARNING : Volume address is out'// 24 - - ' of range ; not checked.' 25 - RETURN 26 - ENDIF 27 - *** Locate the cube parameters. 28 - XL=ABS(CBUF(IREF+1)) 29 - YL=ABS(CBUF(IREF+2)) 30 - ZL=ABS(CBUF(IREF+3)) 31 - X0=CBUF(IREF+4) 32 - Y0=CBUF(IREF+5) 33 - Z0=CBUF(IREF+6) 34 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLABXI DEBUG : Checking'', 35 - - '' box from address '',I4/26X,''Centre= '',3E10.3/ 36 - - 26X,''Half-lengths='',3E10.3)') IREF,X0,Y0,Z0,XL,YL,ZL 37 - * Shorthand for the rotations. 38 - CT=CBUF(IREF+10) 39 - ST=CBUF(IREF+11) 40 - CP=CBUF(IREF+12) 41 - SP=CBUF(IREF+13) 42 - *** Transform the point to local coordinates. 43 - U=+CP*CT*(XPOS-X0)+SP*CT*(YPOS-Y0)-ST*(ZPOS-Z0) 44 - V=-SP *(XPOS-X0)+CP* (YPOS-Y0) 45 - W=+CP*ST*(XPOS-X0)+SP*ST*(YPOS-Y0)+CT*(ZPOS-Z0) 46 - *** See whether the point is inside. 47 - IF(ABS(U).GT.XL.OR.ABS(V).GT.YL.OR.ABS(W).GT.ZL)THEN 48 - INSIDE=.FALSE. 49 - ELSE 50 - INSIDE=.TRUE. 51 - ENDIF 52 - END 248 GARFIELD ================================================== P=PROJECTI D=PLASPP 1 ============================ 0 + +DECK,PLASPP. 1 - SUBROUTINE PLASPP(IVOL,IOFCOL) 2 - *----------------------------------------------------------------------- 3 - * PLASPP - Plots a sphere in 3D perspective. 4 - * (Last changed on 4/ 2/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,SOLIDS. 11.- +SEQ,GRAPHICS. 12.- +SEQ,PRINTPLOT. 13 - INTEGER IVOL,IREF,IOFCOL,ICOL,NMAX,I,J,N,IFAIL 14 - PARAMETER(NMAX=50) 15 - DOUBLE PRECISION R,X0,Y0,Z0,WW,PHI0,PHI1,THETA0,THETA1, 16 - - XPL(4),YPL(4),ZPL(4),CI,SI 17 - *** Locate the conductor. 18 - IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN 19 - PRINT *,' !!!!!! PLASPP WARNING : Volume reference is out'// 20 - - ' of range ; not plotted.' 21 - RETURN 22 - ENDIF 23 - IREF=ISTART(IVOL) 24 - IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN 25 - PRINT *,' !!!!!! PLASPP WARNING : Volume address is out'// 26 - - ' of range ; not plotted.' 27 - RETURN 28 - ENDIF 29 - *** Locate the sphere parameters. 30 - R= CBUF(IREF+1) 31 - IF(R.LE.0)THEN 32 - PRINT *,' !!!!!! PLASPP WARNING : Sphere ',IVOL,' has a'// 33 - - ' non-positive radius; not plotted.' 34 - RETURN 35 - ENDIF 36 - X0=CBUF(IREF+2) 37 - Y0=CBUF(IREF+3) 38 - Z0=CBUF(IREF+4) 39 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASPP DEBUG : Drawing a'', 40 - - '' sphere from address '',I4/26X,''Radius='',E10.3/ 41 - - 26X,''Centre='',3E10.3)') IREF,R,X0,Y0,Z0 42 - N= MIN(MXEDGE-1,NMAX-1,NINT(CBUF(IREF+5))) 43 - *** Determine a suitable number of points on the radii. 44 - IF(N.LT.1)THEN 45 - IF(R.LT.1E-3*MAX(ABS(FRXMAX-FRXMIN),ABS(FRYMAX-FRYMIN)))THEN 46 - N=MIN(NMAX-1,MXEDGE-1,5) 47 - ELSEIF(R.LT.1E-2*MAX(ABS(FRXMAX-FRXMIN), 48 - - ABS(FRYMAX-FRYMIN)))THEN 49 - N=MIN(NMAX-1,MXEDGE-1,10) 50 - ELSEIF(R.LT.1E-1*MAX(ABS(FRXMAX-FRXMIN), 51 - - ABS(FRYMAX-FRYMIN)))THEN 52 - N=MIN(NMAX-1,MXEDGE-1,20) 53 - ELSE 54 - N=MIN(NMAX-1,MXEDGE-1) 55 - ENDIF 56 - ENDIF 57 - *** Loop over the sphere. 58 - DO 10 I=1,N 59 - PHI0=2.0D0*PI*DBLE(I-1)/DBLE(N) 60 - PHI1=2.0D0*PI*DBLE(I)/DBLE(N) 61 - DO 20 J=1,N 62 - THETA0=-PI/2+PI*DBLE(J-1)/DBLE(N) 63 - THETA1=-PI/2+PI*DBLE(J)/DBLE(N) 64 - * Corners of this parcel. 65 - XPL(1)=X0+R*COS(PHI0)*COS(THETA0) 66 - YPL(1)=Y0+R*SIN(PHI0)*COS(THETA0) 67 - ZPL(1)=Z0+R *SIN(THETA0) 68 - XPL(2)=X0+R*COS(PHI1)*COS(THETA0) 69 - YPL(2)=Y0+R*SIN(PHI1)*COS(THETA0) 70 - ZPL(2)=Z0+R *SIN(THETA0) 71 - XPL(3)=X0+R*COS(PHI1)*COS(THETA1) 1 248 P=PROJECTI D=PLASPP 2 PAGE 326 72 - YPL(3)=Y0+R*SIN(PHI1)*COS(THETA1) 73 - ZPL(3)=Z0+R *SIN(THETA1) 74 - XPL(4)=X0+R*COS(PHI0)*COS(THETA1) 75 - YPL(4)=Y0+R*SIN(PHI0)*COS(THETA1) 76 - ZPL(4)=Z0+R *SIN(THETA1) 77 - * Inclination angle in theta. 78 - CI=COS(ATAN2( 79 - - (COS(THETA0)-COS(THETA1))*SQRT((1+COS(PHI1-PHI0))/2), 80 - - SIN(THETA1)-SIN(THETA0))) 81 - SI=SIN(ATAN2( 82 - - (COS(THETA0)-COS(THETA1))*SQRT((1+COS(PHI1-PHI0))/2), 83 - - SIN(THETA1)-SIN(THETA0))) 84 - * Compute the colour index. 85 - CALL COLWGT(COS((PHI0+PHI1)/2)*CI,SIN((PHI0+PHI1)/2)*CI,SI,WW) 86 - IF(WW.GE.0)THEN 87 - ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 88 - ELSE 89 - ICOL=IOFCOL 90 - ENDIF 91 - * Store the panel. 92 - CALL PLABU1('STORE',IREF,4,XPL,YPL,ZPL, 93 - - COS((PHI0+PHI1)/2)*CI,SIN((PHI0+PHI1)/2)*CI,SI, 94 - - ICOL,IVOL,IFAIL) 95 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLASPP WARNING : Unable to'// 96 - - ' store a panel of a sphere.' 97 - * Next point. 98 - 20 CONTINUE 99 - 10 CONTINUE 100 - *** Look for intersections with the outside box, x=xmin. 101 - CALL PLASPC(IVOL,GXMIN,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, 102 - - -1.0D0,0.0D0,0.0D0,IOFCOL+1) 103 - * x=xmax. 104 - CALL PLASPC(IVOL,GXMAX,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, 105 - - +1.0D0,0.0D0,0.0D0,IOFCOL+1) 106 - * y=ymin. 107 - CALL PLASPC(IVOL,(GXMIN+GXMAX)/2,GYMIN,(GZMIN+GZMAX)/2, 108 - - 0.0D0,-1.0D0,0.0D0,IOFCOL+1) 109 - * y=ymax. 110 - CALL PLASPC(IVOL,(GXMIN+GXMAX)/2,GYMAX,(GZMIN+GZMAX)/2, 111 - - 0.0D0,+1.0D0,0.0D0,IOFCOL+1) 112 - * z=zmin. 113 - CALL PLASPC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMIN, 114 - - 0.0D0,0.0D0,-1.0D0,IOFCOL+1) 115 - * z=zmax. 116 - CALL PLASPC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMAX, 117 - - 0.0D0,0.0D0,+1.0D0,IOFCOL+1) 118 - END 249 GARFIELD ================================================== P=PROJECTI D=PLASPC 1 ============================ 0 + +DECK,PLASPC. 1 - SUBROUTINE PLASPC(IVOL,X0PL,Y0PL,Z0PL,APL,BPL,CPL,ICOL) 2 - *----------------------------------------------------------------------- 3 - * PLASPC - Cuts sphere IVOL with a plane. 4 - * (Last changed on 4/ 2/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,SOLIDS. 11.- +SEQ,GRAPHICS. 12.- +SEQ,PRINTPLOT. 13 - INTEGER IREF,IVOL,IFAIL,I,J,NPL,N,NMAX,ICOL 14 - PARAMETER(NMAX=50) 15 - DOUBLE PRECISION X0,Y0,Z0,X1,X2,Y1,Y2,Z1,Z2, 16 - - PHI0,PHI1,THETA0,THETA1,R, 17 - - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), 18 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XCUT,YCUT,ZCUT 19 - *** Locate the conductor. 20 - IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN 21 - PRINT *,' !!!!!! PLASPC WARNING : Volume reference is out'// 22 - - ' of range ; not plotted.' 23 - RETURN 24 - ENDIF 25 - IREF=ISTART(IVOL) 26 - IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN 27 - PRINT *,' !!!!!! PLASPC WARNING : Volume address is out'// 28 - - ' of range ; not plotted.' 29 - RETURN 30 - ENDIF 31 - *** Locate the sphere parameters. 32 - R= CBUF(IREF+1) 33 - IF(R.LE.0)THEN 34 - PRINT *,' !!!!!! PLASPC WARNING : Sphere ',IVOL,' has a'// 35 - - ' non-positive radius; not plotted.' 36 - RETURN 37 - ENDIF 38 - X0=CBUF(IREF+2) 39 - Y0=CBUF(IREF+3) 40 - Z0=CBUF(IREF+4) 41 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASPC DEBUG : Drawing a'', 42 - - '' sphere from address '',I4/26X,''Radius='',E10.3/ 43 - - 26X,''Centre='',3E10.3)') IREF,R,X0,Y0,Z0 44 - N= MIN(MXEDGE-1,NMAX-1,NINT(CBUF(IREF+5))) 45 - *** Determine a suitable number of points on the radii. 46 - IF(N.LT.1)THEN 47 - IF(R.LT.1E-3*MAX(ABS(FRXMAX-FRXMIN),ABS(FRYMAX-FRYMIN)))THEN 48 - N=MIN(NMAX-1,MXEDGE-1,5) 49 - ELSEIF(R.LT.1E-2*MAX(ABS(FRXMAX-FRXMIN), 50 - - ABS(FRYMAX-FRYMIN)))THEN 51 - N=MIN(NMAX-1,MXEDGE-1,10) 52 - ELSEIF(R.LT.1E-1*MAX(ABS(FRXMAX-FRXMIN), 53 - - ABS(FRYMAX-FRYMIN)))THEN 54 - N=MIN(NMAX-1,MXEDGE-1,20) 55 - ELSE 1 249 P=PROJECTI D=PLASPC 2 PAGE 327 56 - N=MIN(NMAX-1,MXEDGE-1) 57 - ENDIF 58 - ENDIF 59 - *** Initialise the number of points on the square. 60 - NPL=0 61 - *** Loop over the sphere. 62 - DO 10 I=1,N 63 - * phi-Coordinates. 64 - PHI0=2.0D0*PI*DBLE(I-1)/DBLE(N) 65 - PHI1=2.0D0*PI*DBLE(I)/DBLE(N) 66 - DO 20 J=1,N 67 - * theta-Coordinates. 68 - THETA0=-PI/2+PI*DBLE(J-1)/DBLE(N) 69 - THETA1=-PI/2+PI*DBLE(J)/DBLE(N) 70 - * Reference point of this square. 71 - X1=X0+R*COS(PHI0)*COS(THETA0) 72 - Y1=Y0+R*SIN(PHI0)*COS(THETA0) 73 - Z1=Z0+R *SIN(THETA0) 74 - ** The meridian segment, doesn't exist at the S pole. 75 - IF(J.GT.0)THEN 76 - X2=X0+R*COS(PHI1)*COS(THETA0) 77 - Y2=Y0+R*SIN(PHI1)*COS(THETA0) 78 - Z2=Z0+R *SIN(THETA0) 79 - * Cut with the plane. 80 - CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, 81 - - XCUT,YCUT,ZCUT,IFAIL) 82 - * Store the result if there is one. 83 - IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN 84 - NPL=NPL+1 85 - XPL(NPL)=XCUT 86 - YPL(NPL)=YCUT 87 - ZPL(NPL)=ZCUT 88 - ELSEIF(NPL.GE.MXEDGE)THEN 89 - PRINT *,' !!!!!! PLASPC WARNING : Too many'// 90 - - ' intersects between sphere and plane; stopped.' 91 - RETURN 92 - ENDIF 93 - ENDIF 94 - ** The latitude. 95 - X2=X0+R*COS(PHI0)*COS(THETA1) 96 - Y2=Y0+R*SIN(PHI0)*COS(THETA1) 97 - Z2=Z0+R *SIN(THETA1) 98 - * Cut with the plane. 99 - CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, 100 - - XCUT,YCUT,ZCUT,IFAIL) 101 - * Store the result if there is one. 102 - IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN 103 - NPL=NPL+1 104 - XPL(NPL)=XCUT 105 - YPL(NPL)=YCUT 106 - ZPL(NPL)=ZCUT 107 - ELSEIF(NPL.GE.MXEDGE)THEN 108 - PRINT *,' !!!!!! PLASPC WARNING : Too many intersects'// 109 - - ' between sphere and plane; stopped.' 110 - RETURN 111 - ENDIF 112 - * Next point. 113 - 20 CONTINUE 114 - 10 CONTINUE 115 - *** Get rid of butterflies. 116 - CALL BUTFLD(NPL,XPL,YPL,ZPL) 117 - *** Store the plane. 118 - IF(NPL.GE.3)THEN 119 - CALL PLABU1('STORE',IREF,NPL,XPL,YPL,ZPL, 120 - - APL,BPL,CPL,ICOL,IVOL,IFAIL) 121 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLASPC WARNING : Failed to'// 122 - - ' store a side cut of a sphere.' 123 - ENDIF 124 - END 250 GARFIELD ================================================== P=PROJECTI D=PLASPI 1 ============================ 0 + +DECK,PLASPI. 1 - SUBROUTINE PLASPI(IVOL,XPOS,YPOS,ZPOS,INSIDE) 2 - *----------------------------------------------------------------------- 3 - * PLASPI - Determines whether a point is located inside a sphere. 4 - * (Last changed on 4/ 2/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,SOLIDS. 10.- +SEQ,PRINTPLOT. 11 - INTEGER IVOL,IREF 12 - DOUBLE PRECISION R,X0,Y0,Z0,XPOS,YPOS,ZPOS 13 - LOGICAL INSIDE 14 - *** Locate the conductor. 15 - IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN 16 - PRINT *,' !!!!!! PLASPI WARNING : Volume reference is out'// 17 - - ' of range ; not checked.' 18 - RETURN 19 - ENDIF 20 - IREF=ISTART(IVOL) 21 - IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN 22 - PRINT *,' !!!!!! PLASPI WARNING : Volume address is out'// 23 - - ' of range ; not checked.' 24 - RETURN 25 - ENDIF 26 - *** Locate the sphere parameters. 27 - R= CBUF(IREF+1) 28 - IF(R.LE.0)THEN 29 - PRINT *,' !!!!!! PLASPI WARNING : Sphere ',IVOL,' has a'// 30 - - ' non-positive radius; not checked.' 31 - RETURN 32 - ENDIF 33 - X0=CBUF(IREF+2) 1 250 P=PROJECTI D=PLASPI 2 PAGE 328 34 - Y0=CBUF(IREF+3) 35 - Z0=CBUF(IREF+4) 36 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASPI DEBUG : Checking'', 37 - - '' sphere from address '',I4/26X,''Radius='',E10.3/ 38 - - 26X,''Centre='',3E10.3)') IREF,R,X0,Y0,Z0 39 - *** See whether the point is inside. 40 - IF((XPOS-X0)**2+(YPOS-Y0)**2+(ZPOS-Z0)**2.GT.R**2)THEN 41 - INSIDE=.FALSE. 42 - ELSE 43 - INSIDE=.TRUE. 44 - ENDIF 45 - END 251 GARFIELD ================================================== P=PROJECTI D=PLACHP 1 ============================ 0 + +DECK,PLACHP. 1 - SUBROUTINE PLACHP(IVOL,IOFCOL) 2 - *----------------------------------------------------------------------- 3 - * PLACHP - Plots a cylindrical hole in a box. 4 - * (Last changed on 1/ 9/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,SOLIDS. 11.- +SEQ,GRAPHICS. 12.- +SEQ,PRINTPLOT. 13 - INTEGER IVOL,IREF,IOFCOL,ICOL,IFAIL, 14 - - N,NMAX,I,ISIDE 15 - PARAMETER(NMAX=50) 16 - DOUBLE PRECISION XL,YL,ZL,X0,Y0,Z0,R1,R2,R,A,B,C,CT,ST,CP,SP, 17 - - U,V,W,WW,FNORM,XPL(4),YPL(4),ZPL(4),CI,SI 18 - *** Locate the conductor. 19 - IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN 20 - PRINT *,' !!!!!! PLACHP WARNING : Volume reference is out'// 21 - - ' of range ; not plotted.' 22 - RETURN 23 - ENDIF 24 - IREF=ISTART(IVOL) 25 - IF(IREF.LT.0.OR.IREF+11.GT.MXSBUF)THEN 26 - PRINT *,' !!!!!! PLACHP WARNING : Volume address is out'// 27 - - ' of range ; not plotted.' 28 - RETURN 29 - ENDIF 30 - *** Locate the parameters of the surrounding box and of the cylinder. 31 - R1= CBUF(IREF+1) 32 - R2= CBUF(IREF+2) 33 - IF(R1.LE.0.OR.R2.LE.0)THEN 34 - PRINT *,' !!!!!! PLACHP WARNING : Cylindrical hole ',IVOL, 35 - - ' has a non-positive radius; not plotted.' 36 - RETURN 37 - ENDIF 38 - XL=ABS(CBUF(IREF+3)) 39 - YL=ABS(CBUF(IREF+4)) 40 - ZL=ABS(CBUF(IREF+5)) 41 - IF(R1.GE.XL.OR.R1.GE.YL.OR.R2.GE.XL.OR.R2.GE.YL)THEN 42 - PRINT *,' !!!!!! PLACHP WARNING : Cylindrical hole ',IVOL, 43 - - ' is smaller than the box; not plotted.' 44 - RETURN 45 - ENDIF 46 - X0=CBUF(IREF+6) 47 - Y0=CBUF(IREF+7) 48 - Z0=CBUF(IREF+8) 49 - FNORM=SQRT(CBUF(IREF+9)**2+CBUF(IREF+10)**2+CBUF(IREF+11)**2) 50 - IF(FNORM.LE.0)THEN 51 - PRINT *,' !!!!!! PLACHP WARNING : Cylindrical hole ',IVOL, 52 - - ' has a zero norm direction vector; not plotted.' 53 - RETURN 54 - ENDIF 55 - A= CBUF(IREF+9)/FNORM 56 - B= CBUF(IREF+10)/FNORM 57 - C= CBUF(IREF+11)/FNORM 58 - N= MIN(MXEDGE-3,NMAX-1,NINT(CBUF(IREF+12))) 59 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACHP DEBUG : Drawing a'', 60 - - '' hole from address '',I4/26X,''Centre= '',3E10.3/ 61 - - 26X,''Half-lengths='',3E10.3/26X,''Direction= '',3E10.3/ 62 - - 26X,''Radii= '',2E10.3)') 63 - - IREF,X0,Y0,Z0,XL,YL,ZL,A,B,C,R1,R2 64 - * Shorthand for the rotations. 65 - CT=CBUF(IREF+13) 66 - ST=CBUF(IREF+14) 67 - CP=CBUF(IREF+15) 68 - SP=CBUF(IREF+16) 69 - *** Determine a suitable number of points on the radii. 70 - IF(N.LE.1)THEN 71 - R=MAX(R1,R2) 72 - IF(R.LT.1E-2*MAX(ABS(GXMAX-GXMIN),ABS(GYMAX-GYMIN), 73 - - ABS(GZMAX-GZMIN)))THEN 74 - N=MIN(MXEDGE-3,NMAX-1,2) 75 - ELSEIF(R.LT.1E-1*MAX(ABS(GXMAX-GXMIN),ABS(GYMAX-GYMIN), 76 - - ABS(GZMAX-GZMIN)))THEN 77 - N=MIN(MXEDGE-3,NMAX-1,3) 78 - ELSE 79 - N=MIN(MXEDGE-3,NMAX-1,4) 80 - ENDIF 81 - ENDIF 82 - *** Draw the 6 sides of the box, start with the x=xmin face. 83 - U=-XL 84 - V=-YL 85 - W=-ZL 86 - XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W 87 - YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W 88 - ZPL(1)=Z0 -ST*U +CT*W 89 - U=-XL 90 - V=+YL 1 251 P=PROJECTI D=PLACHP 2 PAGE 329 91 - W=-ZL 92 - XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W 93 - YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W 94 - ZPL(2)=Z0 -ST*U +CT*W 95 - U=-XL 96 - V=+YL 97 - W=+ZL 98 - XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W 99 - YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W 100 - ZPL(3)=Z0 -ST*U +CT*W 101 - U=-XL 102 - V=-YL 103 - W=+ZL 104 - XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W 105 - YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W 106 - ZPL(4)=Z0 -ST*U +CT*W 107 - CALL COLWGT(-CP*CT,-SP*CT,+ST,WW) 108 - IF(WW.GE.0)THEN 109 - ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 110 - ELSE 111 - ICOL=IOFCOL 112 - ENDIF 113 - CALL PLABU1('STORE',IREF,4,XPL,YPL,ZPL,-CP*CT,-SP*CT,+ST, 114 - - ICOL,IVOL,IFAIL) 115 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// 116 - - ' store a panel of a box.' 117 - * The x=xmax face. 118 - U=+XL 119 - V=-YL 120 - W=-ZL 121 - XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W 122 - YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W 123 - ZPL(1)=Z0 -ST*U +CT*W 124 - U=+XL 125 - V=+YL 126 - W=-ZL 127 - XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W 128 - YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W 129 - ZPL(2)=Z0 -ST*U +CT*W 130 - U=+XL 131 - V=+YL 132 - W=+ZL 133 - XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W 134 - YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W 135 - ZPL(3)=Z0 -ST*U +CT*W 136 - U=+XL 137 - V=-YL 138 - W=+ZL 139 - XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W 140 - YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W 141 - ZPL(4)=Z0 -ST*U +CT*W 142 - CALL COLWGT(CP*CT,SP*CT,-ST,WW) 143 - IF(WW.GE.0)THEN 144 - ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 145 - ELSE 146 - ICOL=IOFCOL 147 - ENDIF 148 - CALL PLABU1('STORE',IREF,4,XPL,YPL,ZPL,CP*CT,SP*CT,-ST, 149 - - ICOL,IVOL,IFAIL) 150 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// 151 - - ' store a panel of a box.' 152 - * The y=ymin face. 153 - U=-XL 154 - V=-YL 155 - W=-ZL 156 - XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W 157 - YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W 158 - ZPL(1)=Z0 -ST*U +CT*W 159 - U=+XL 160 - V=-YL 161 - W=-ZL 162 - XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W 163 - YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W 164 - ZPL(2)=Z0 -ST*U +CT*W 165 - U=+XL 166 - V=-YL 167 - W=+ZL 168 - XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W 169 - YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W 170 - ZPL(3)=Z0 -ST*U +CT*W 171 - U=-XL 172 - V=-YL 173 - W=+ZL 174 - XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W 175 - YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W 176 - ZPL(4)=Z0 -ST*U +CT*W 177 - CALL COLWGT(+SP,-CP,0.0D0,WW) 178 - IF(WW.GE.0)THEN 179 - ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 180 - ELSE 181 - ICOL=IOFCOL 182 - ENDIF 183 - CALL PLABU1('STORE',IREF,4,XPL,YPL,ZPL,SP,-CP,0.0D0, 184 - - ICOL,IVOL,IFAIL) 185 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// 186 - - ' store a panel of a box.' 187 - * The y=ymax face. 188 - U=-XL 189 - V=+YL 190 - W=-ZL 191 - XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W 192 - YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W 193 - ZPL(1)=Z0 -ST*U +CT*W 194 - U=+XL 195 - V=+YL 196 - W=-ZL 1 251 P=PROJECTI D=PLACHP 3 PAGE 330 197 - XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W 198 - YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W 199 - ZPL(2)=Z0 -ST*U +CT*W 200 - U=+XL 201 - V=+YL 202 - W=+ZL 203 - XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W 204 - YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W 205 - ZPL(3)=Z0 -ST*U +CT*W 206 - U=-XL 207 - V=+YL 208 - W=+ZL 209 - XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W 210 - YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W 211 - ZPL(4)=Z0 -ST*U +CT*W 212 - CALL COLWGT(-SP,+CP,0.0D0,WW) 213 - IF(WW.GE.0)THEN 214 - ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 215 - ELSE 216 - ICOL=IOFCOL 217 - ENDIF 218 - CALL PLABU1('STORE',IREF,4,XPL,YPL,ZPL,-SP,+CP,0.0D0, 219 - - ICOL,IVOL,IFAIL) 220 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// 221 - - ' store a panel of a box.' 222 - * The faces at constant z have a hole, and are drawn in parts. 223 - DO 10 ISIDE=-1,+1,2 224 - IF(ISIDE.EQ.-1)THEN 225 - R=R1 226 - ELSE 227 - R=R2 228 - ENDIF 229 - * All sub-panels have the same colour. 230 - CALL COLWGT(ISIDE*CP*ST,ISIDE*SP*ST,ISIDE*CT,WW) 231 - IF(WW.GE.0)THEN 232 - ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 233 - ELSE 234 - ICOL=IOFCOL 235 - ENDIF 236 - * Loop over the panels. 237 - DO 20 I=1,N-1 238 - * The panels for x=xmax. 239 - U=R*COS(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 240 - V=R*SIN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 241 - W=ZL*ISIDE 242 - XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W 243 - YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W 244 - ZPL(1)=Z0 -ST*U +CT*W 245 - U=XL 246 - V=YL*TAN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 247 - W=ZL*ISIDE 248 - XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W 249 - YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W 250 - ZPL(2)=Z0 -ST*U +CT*W 251 - U=XL 252 - V=YL*TAN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 253 - W=ZL*ISIDE 254 - XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W 255 - YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W 256 - ZPL(3)=Z0 -ST*U +CT*W 257 - U=R*COS(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 258 - V=R*SIN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 259 - W=ZL*ISIDE 260 - XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W 261 - YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W 262 - ZPL(4)=Z0 -ST*U +CT*W 263 - CALL PLABU1('STORE',IREF,4,XPL,YPL,ZPL, 264 - - ISIDE*CP*ST,ISIDE*SP*ST,ISIDE*CT, 265 - - ICOL,IVOL,IFAIL) 266 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// 267 - - ' store a panel of a box.' 268 - * The panels for y=ymax. 269 - U=R*COS(+PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 270 - V=R*SIN(+PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 271 - W=ZL*ISIDE 272 - XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W 273 - YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W 274 - ZPL(1)=Z0 -ST*U +CT*W 275 - U=-XL*TAN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 276 - V=YL 277 - W=ZL*ISIDE 278 - XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W 279 - YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W 280 - ZPL(2)=Z0 -ST*U +CT*W 281 - U=-XL*TAN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 282 - V=YL 283 - W=ZL*ISIDE 284 - XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W 285 - YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W 286 - ZPL(3)=Z0 -ST*U +CT*W 287 - U=R*COS(+PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 288 - V=R*SIN(+PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 289 - W=ZL*ISIDE 290 - XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W 291 - YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W 292 - ZPL(4)=Z0 -ST*U +CT*W 293 - CALL PLABU1('STORE',IREF,4,XPL,YPL,ZPL, 294 - - ISIDE*CP*ST,ISIDE*SP*ST,ISIDE*CT, 295 - - ICOL,IVOL,IFAIL) 296 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// 297 - - ' store a panel of a box.' 298 - * The panels for x=xmin. 299 - U=R*COS(3*PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 300 - V=R*SIN(3*PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 301 - W=ZL*ISIDE 302 - XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W 1 251 P=PROJECTI D=PLACHP 4 PAGE 331 303 - YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W 304 - ZPL(1)=Z0 -ST*U +CT*W 305 - U=-XL 306 - V=-YL*TAN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 307 - W=ZL*ISIDE 308 - XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W 309 - YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W 310 - ZPL(2)=Z0 -ST*U +CT*W 311 - U=-XL 312 - V=-YL*TAN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 313 - W=ZL*ISIDE 314 - XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W 315 - YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W 316 - ZPL(3)=Z0 -ST*U +CT*W 317 - U=R*COS(3*PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 318 - V=R*SIN(3*PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 319 - W=ZL*ISIDE 320 - XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W 321 - YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W 322 - ZPL(4)=Z0 -ST*U +CT*W 323 - CALL PLABU1('STORE',IREF,4,XPL,YPL,ZPL, 324 - - ISIDE*CP*ST,ISIDE*SP*ST,ISIDE*CT, 325 - - ICOL,IVOL,IFAIL) 326 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// 327 - - ' store a panel of a box.' 328 - * The panels for y=ymin. 329 - U=R*COS(-3*PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 330 - V=R*SIN(-3*PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 331 - W=ZL*ISIDE 332 - XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W 333 - YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W 334 - ZPL(1)=Z0 -ST*U +CT*W 335 - U=XL*TAN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 336 - V=-YL 337 - W=ZL*ISIDE 338 - XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W 339 - YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W 340 - ZPL(2)=Z0 -ST*U +CT*W 341 - U=XL*TAN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 342 - V=-YL 343 - W=ZL*ISIDE 344 - XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W 345 - YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W 346 - ZPL(3)=Z0 -ST*U +CT*W 347 - U=R*COS(-3*PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 348 - V=R*SIN(-3*PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 349 - W=ZL*ISIDE 350 - XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W 351 - YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W 352 - ZPL(4)=Z0 -ST*U +CT*W 353 - CALL PLABU1('STORE',IREF,4,XPL,YPL,ZPL, 354 - - ISIDE*CP*ST,ISIDE*SP*ST,ISIDE*CT, 355 - - ICOL,IVOL,IFAIL) 356 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// 357 - - ' store a panel of a box.' 358 - 20 CONTINUE 359 - 10 CONTINUE 360 - *** The panels of the central cylinder, compute the projection angles. 361 - CI=COS(ATAN2((R1-R2)*COS(PI/(4*(N-1))),2*ZL)) 362 - SI=SIN(ATAN2((R1-R2)*COS(PI/(4*(N-1))),2*ZL)) 363 - * Initialise loop. 364 - U=R1*COS(-PI/4) 365 - V=R1*SIN(-PI/4) 366 - W=-ZL 367 - XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W 368 - YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W 369 - ZPL(1)=Z0 -ST*U +CT*W 370 - U=R2*COS(-PI/4) 371 - V=R2*SIN(-PI/4) 372 - W=+ZL 373 - XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W 374 - YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W 375 - ZPL(2)=Z0 -ST*U +CT*W 376 - ** Go around the cylinder. 377 - DO 40 I=2,4*N-3 378 - * Bottom and top of the line along the axis of the cylinder. 379 - U=R2*COS(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 380 - V=R2*SIN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 381 - W=+ZL 382 - XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W 383 - YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W 384 - ZPL(3)=Z0 -ST*U +CT*W 385 - U=R1*COS(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 386 - V=R1*SIN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 387 - W=-ZL 388 - XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W 389 - YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W 390 - ZPL(4)=Z0 -ST*U +CT*W 391 - * Compute the colour index for this segment. 392 - CALL COLWGT( 393 - - -CP*CT*COS(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI+ 394 - - SP* SIN(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI- 395 - - CP*ST *SI, 396 - - -SP*CT*COS(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI- 397 - - CP* SIN(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI- 398 - - SP*ST *SI, 399 - - ST* COS(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI- 400 - - CT *SI, 401 - - WW) 402 - IF(WW.GT.0)THEN 403 - ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 404 - ELSE 405 - ICOL=IOFCOL 406 - ENDIF 407 - * Store the plane. 408 - CALL PLABU1('STORE',IREF,4,XPL,YPL,ZPL, 1 251 P=PROJECTI D=PLACHP 5 PAGE 332 409 - - -CP*CT*COS(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI+ 410 - - SP* SIN(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI- 411 - - CP*ST *SI, 412 - - -SP*CT*COS(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI- 413 - - CP* SIN(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI- 414 - - SP*ST *SI, 415 - - ST* COS(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI- 416 - - CT *SI, 417 - - ICOL,IVOL,IFAIL) 418 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// 419 - - ' store a panel of a cylinder.' 420 - * Shift the points. 421 - XPL(1)=XPL(4) 422 - YPL(1)=YPL(4) 423 - ZPL(1)=ZPL(4) 424 - XPL(2)=XPL(3) 425 - YPL(2)=YPL(3) 426 - ZPL(2)=ZPL(3) 427 - 40 CONTINUE 428 - *** Look for intersections with the outside box, x=xmin. 429 - CALL PLACHC(IVOL,GXMIN,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, 430 - - -1.0D0,0.0D0,0.0D0,IOFCOL+1) 431 - * x=xmax. 432 - CALL PLACHC(IVOL,GXMAX,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, 433 - - +1.0D0,0.0D0,0.0D0,IOFCOL+1) 434 - * y=ymin. 435 - CALL PLACHC(IVOL,(GXMIN+GXMAX)/2,GYMIN,(GZMIN+GZMAX)/2, 436 - - 0.0D0,-1.0D0,0.0D0,IOFCOL+1) 437 - * y=ymax. 438 - CALL PLACHC(IVOL,(GXMIN+GXMAX)/2,GYMAX,(GZMIN+GZMAX)/2, 439 - - 0.0D0,+1.0D0,0.0D0,IOFCOL+1) 440 - * z=zmin. 441 - CALL PLACHC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMIN, 442 - - 0.0D0,0.0D0,-1.0D0,IOFCOL+1) 443 - * z=zmax. 444 - CALL PLACHC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMAX, 445 - - 0.0D0,0.0D0,+1.0D0,IOFCOL+1) 446 - END 252 GARFIELD ================================================== P=PROJECTI D=PLACHC 1 ============================ 0 + +DECK,PLACHC. 1 - SUBROUTINE PLACHC(IVOL,X0PL,Y0PL,Z0PL,APL,BPL,CPL,ICOL) 2 - *----------------------------------------------------------------------- 3 - * PLACHC - Cuts a cylindrical hole with a plane. 4 - * (Last changed on 4/ 2/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,SOLIDS. 11.- +SEQ,GRAPHICS. 12.- +SEQ,PRINTPLOT. 13 - INTEGER IREF,IVOL,IFAIL,NCUT,N,NMAX,I,ICOL,ISIDE 14 - PARAMETER(NMAX=50) 15 - DOUBLE PRECISION X0,Y0,Z0,A,B,C,XL,YL,ZL,CT,ST,CP,SP, 16 - - FNORM,U,V,W,R1,R2,R, 17 - - XBOX(8),YBOX(8),ZBOX(8),XCUT(12),YCUT(12),ZCUT(12), 18 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL 19 - *** Locate the conductor. 20 - IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN 21 - PRINT *,' !!!!!! PLACHC WARNING : Volume reference is out'// 22 - - ' of range ; not plotted.' 23 - RETURN 24 - ENDIF 25 - IREF=ISTART(IVOL) 26 - IF(IREF.LT.0.OR.IREF+11.GT.MXSBUF)THEN 27 - PRINT *,' !!!!!! PLACHC WARNING : Volume address is out'// 28 - - ' of range ; not plotted.' 29 - RETURN 30 - ENDIF 31 - *** Locate the parameters of the surrounding box and of the cylinder. 32 - R1= CBUF(IREF+1) 33 - R2= CBUF(IREF+2) 34 - IF(R1.LE.0.OR.R2.LE.0)THEN 35 - PRINT *,' !!!!!! PLACHC WARNING : Cylindrical hole ',IREF, 36 - - ' has a non-positive radius; not plotted.' 37 - RETURN 38 - ENDIF 39 - XL=ABS(CBUF(IREF+3)) 40 - YL=ABS(CBUF(IREF+4)) 41 - ZL=ABS(CBUF(IREF+5)) 42 - IF(R1.GE.XL.OR.R1.GE.YL.OR.R2.GE.XL.OR.R2.GE.YL)THEN 43 - PRINT *,' !!!!!! PLACHC WARNING : Cylindrical hole ',IREF, 44 - - ' is smaller than the box; not plotted.' 45 - RETURN 46 - ENDIF 47 - X0=CBUF(IREF+6) 48 - Y0=CBUF(IREF+7) 49 - Z0=CBUF(IREF+8) 50 - FNORM=SQRT(CBUF(IREF+9)**2+CBUF(IREF+10)**2+CBUF(IREF+11)**2) 51 - IF(FNORM.LE.0)THEN 52 - PRINT *,' !!!!!! PLACHC WARNING : Cylindrical hole ',IREF, 53 - - ' has a zero norm direction vector; not plotted.' 54 - RETURN 55 - ENDIF 56 - A= CBUF(IREF+9)/FNORM 57 - B= CBUF(IREF+10)/FNORM 58 - C= CBUF(IREF+11)/FNORM 59 - N= MIN(MXEDGE-3,NMAX-1,NINT(CBUF(IREF+12))) 60 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACHC DEBUG : Drawing a'', 61 - - '' hole from address '',I4/26X,''Centre= '',3E10.3/ 62 - - 26X,''Half-lengths='',3E10.3/26X,''Direction= '',3E10.3/ 63 - - 26X,''Radii= '',2E10.3)') 64 - - IREF,X0,Y0,Z0,XL,YL,ZL,A,B,C,R1,R2 1 252 P=PROJECTI D=PLACHC 2 PAGE 333 65 - * Shorthand for the rotations. 66 - CT=CBUF(IREF+13) 67 - ST=CBUF(IREF+14) 68 - CP=CBUF(IREF+15) 69 - SP=CBUF(IREF+16) 70 - *** Determine a suitable number of points on the radii. 71 - IF(N.LE.1)THEN 72 - R=MAX(R1,R2) 73 - IF(R.LT.1E-2*MAX(ABS(GXMAX-GXMIN),ABS(GYMAX-GYMIN), 74 - - ABS(GZMAX-GZMIN)))THEN 75 - N=MIN(MXEDGE-3,NMAX-1,2) 76 - ELSEIF(R.LT.1E-1*MAX(ABS(GXMAX-GXMIN),ABS(GYMAX-GYMIN), 77 - - ABS(GZMAX-GZMIN)))THEN 78 - N=MIN(MXEDGE-3,NMAX-1,3) 79 - ELSE 80 - N=MIN(MXEDGE-3,NMAX-1,4) 81 - ENDIF 82 - ENDIF 83 - *** Loop over the boxes that make up the hole. 84 - DO 10 I=1,N-1 85 - * The boxes ending at x=xmax. 86 - DO 20 ISIDE=-1,+1,2 87 - IF(ISIDE.EQ.-1)THEN 88 - R=R1 89 - ELSE 90 - R=R2 91 - ENDIF 92 - U=R*COS(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 93 - V=R*SIN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 94 - W=ISIDE*ZL 95 - XBOX(2+2*ISIDE+1)=X0+CP*CT*U-SP*V+CP*ST*W 96 - YBOX(2+2*ISIDE+1)=Y0+SP*CT*U+CP*V+SP*ST*W 97 - ZBOX(2+2*ISIDE+1)=Z0 -ST*U +CT*W 98 - U=XL 99 - V=YL*TAN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 100 - W=ISIDE*ZL 101 - XBOX(2+2*ISIDE+2)=X0+CP*CT*U-SP*V+CP*ST*W 102 - YBOX(2+2*ISIDE+2)=Y0+SP*CT*U+CP*V+SP*ST*W 103 - ZBOX(2+2*ISIDE+2)=Z0 -ST*U +CT*W 104 - U=XL 105 - V=YL*TAN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 106 - W=ISIDE*ZL 107 - XBOX(2+2*ISIDE+3)=X0+CP*CT*U-SP*V+CP*ST*W 108 - YBOX(2+2*ISIDE+3)=Y0+SP*CT*U+CP*V+SP*ST*W 109 - ZBOX(2+2*ISIDE+3)=Z0 -ST*U +CT*W 110 - U=R*COS(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 111 - V=R*SIN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 112 - W=ISIDE*ZL 113 - XBOX(2+2*ISIDE+4)=X0+CP*CT*U-SP*V+CP*ST*W 114 - YBOX(2+2*ISIDE+4)=Y0+SP*CT*U+CP*V+SP*ST*W 115 - ZBOX(2+2*ISIDE+4)=Z0 -ST*U +CT*W 116 - 20 CONTINUE 117 - CALL PLABOX(XBOX,YBOX,ZBOX,NCUT,XCUT,YCUT,ZCUT, 118 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL) 119 - IF(NCUT.GE.3)THEN 120 - CALL PLABU1('STORE',IREF,NCUT,XCUT,YCUT,ZCUT, 121 - - APL,BPL,CPL,ICOL,IVOL,IFAIL) 122 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHC WARNING : Unable to'// 123 - - ' store a panel of a box.' 124 - ENDIF 125 - * The panels for y=ymax. 126 - DO 30 ISIDE=-1,+1,2 127 - IF(ISIDE.EQ.-1)THEN 128 - R=R1 129 - ELSE 130 - R=R2 131 - ENDIF 132 - U=R*COS(+PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 133 - V=R*SIN(+PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 134 - W=ZL*ISIDE 135 - XBOX(2+2*ISIDE+1)=X0+CP*CT*U-SP*V+CP*ST*W 136 - YBOX(2+2*ISIDE+1)=Y0+SP*CT*U+CP*V+SP*ST*W 137 - ZBOX(2+2*ISIDE+1)=Z0 -ST*U +CT*W 138 - U=-XL*TAN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 139 - V=YL 140 - W=ZL*ISIDE 141 - XBOX(2+2*ISIDE+2)=X0+CP*CT*U-SP*V+CP*ST*W 142 - YBOX(2+2*ISIDE+2)=Y0+SP*CT*U+CP*V+SP*ST*W 143 - ZBOX(2+2*ISIDE+2)=Z0 -ST*U +CT*W 144 - U=-XL*TAN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 145 - V=YL 146 - W=ZL*ISIDE 147 - XBOX(2+2*ISIDE+3)=X0+CP*CT*U-SP*V+CP*ST*W 148 - YBOX(2+2*ISIDE+3)=Y0+SP*CT*U+CP*V+SP*ST*W 149 - ZBOX(2+2*ISIDE+3)=Z0 -ST*U +CT*W 150 - U=R*COS(+PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 151 - V=R*SIN(+PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 152 - W=ZL*ISIDE 153 - XBOX(2+2*ISIDE+4)=X0+CP*CT*U-SP*V+CP*ST*W 154 - YBOX(2+2*ISIDE+4)=Y0+SP*CT*U+CP*V+SP*ST*W 155 - ZBOX(2+2*ISIDE+4)=Z0 -ST*U +CT*W 156 - 30 CONTINUE 157 - CALL PLABOX(XBOX,YBOX,ZBOX,NCUT,XCUT,YCUT,ZCUT, 158 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL) 159 - IF(NCUT.GE.3)THEN 160 - CALL PLABU1('STORE',IREF,NCUT,XCUT,YCUT,ZCUT, 161 - - APL,BPL,CPL,ICOL,IVOL,IFAIL) 162 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHC WARNING : Unable to'// 163 - - ' store a panel of a box.' 164 - ENDIF 165 - * The panels for x=xmin. 166 - DO 40 ISIDE=-1,+1,2 167 - IF(ISIDE.EQ.-1)THEN 168 - R=R1 169 - ELSE 170 - R=R2 1 252 P=PROJECTI D=PLACHC 3 PAGE 334 171 - ENDIF 172 - U=R*COS(3*PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 173 - V=R*SIN(3*PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 174 - W=ZL*ISIDE 175 - XBOX(2+2*ISIDE+1)=X0+CP*CT*U-SP*V+CP*ST*W 176 - YBOX(2+2*ISIDE+1)=Y0+SP*CT*U+CP*V+SP*ST*W 177 - ZBOX(2+2*ISIDE+1)=Z0 -ST*U +CT*W 178 - U=-XL 179 - V=-YL*TAN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 180 - W=ZL*ISIDE 181 - XBOX(2+2*ISIDE+2)=X0+CP*CT*U-SP*V+CP*ST*W 182 - YBOX(2+2*ISIDE+2)=Y0+SP*CT*U+CP*V+SP*ST*W 183 - ZBOX(2+2*ISIDE+2)=Z0 -ST*U +CT*W 184 - U=-XL 185 - V=-YL*TAN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 186 - W=ZL*ISIDE 187 - XBOX(2+2*ISIDE+3)=X0+CP*CT*U-SP*V+CP*ST*W 188 - YBOX(2+2*ISIDE+3)=Y0+SP*CT*U+CP*V+SP*ST*W 189 - ZBOX(2+2*ISIDE+3)=Z0 -ST*U +CT*W 190 - U=R*COS(3*PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 191 - V=R*SIN(3*PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 192 - W=ZL*ISIDE 193 - XBOX(2+2*ISIDE+4)=X0+CP*CT*U-SP*V+CP*ST*W 194 - YBOX(2+2*ISIDE+4)=Y0+SP*CT*U+CP*V+SP*ST*W 195 - ZBOX(2+2*ISIDE+4)=Z0 -ST*U +CT*W 196 - 40 CONTINUE 197 - CALL PLABOX(XBOX,YBOX,ZBOX,NCUT,XCUT,YCUT,ZCUT, 198 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL) 199 - IF(NCUT.GE.3)THEN 200 - CALL PLABU1('STORE',IREF,NCUT,XCUT,YCUT,ZCUT, 201 - - APL,BPL,CPL,ICOL,IVOL,IFAIL) 202 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHC WARNING : Unable to'// 203 - - ' store a panel of a box.' 204 - ENDIF 205 - * The panels for y=ymin. 206 - DO 50 ISIDE=-1,+1,2 207 - IF(ISIDE.EQ.-1)THEN 208 - R=R1 209 - ELSE 210 - R=R2 211 - ENDIF 212 - U=R*COS(-3*PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 213 - V=R*SIN(-3*PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 214 - W=ZL*ISIDE 215 - XBOX(2+2*ISIDE+1)=X0+CP*CT*U-SP*V+CP*ST*W 216 - YBOX(2+2*ISIDE+1)=Y0+SP*CT*U+CP*V+SP*ST*W 217 - ZBOX(2+2*ISIDE+1)=Z0 -ST*U +CT*W 218 - U=XL*TAN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 219 - V=-YL 220 - W=ZL*ISIDE 221 - XBOX(2+2*ISIDE+2)=X0+CP*CT*U-SP*V+CP*ST*W 222 - YBOX(2+2*ISIDE+2)=Y0+SP*CT*U+CP*V+SP*ST*W 223 - ZBOX(2+2*ISIDE+2)=Z0 -ST*U +CT*W 224 - U=XL*TAN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 225 - V=-YL 226 - W=ZL*ISIDE 227 - XBOX(2+2*ISIDE+3)=X0+CP*CT*U-SP*V+CP*ST*W 228 - YBOX(2+2*ISIDE+3)=Y0+SP*CT*U+CP*V+SP*ST*W 229 - ZBOX(2+2*ISIDE+3)=Z0 -ST*U +CT*W 230 - U=R*COS(-3*PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 231 - V=R*SIN(-3*PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) 232 - W=ZL*ISIDE 233 - XBOX(2+2*ISIDE+4)=X0+CP*CT*U-SP*V+CP*ST*W 234 - YBOX(2+2*ISIDE+4)=Y0+SP*CT*U+CP*V+SP*ST*W 235 - ZBOX(2+2*ISIDE+4)=Z0 -ST*U +CT*W 236 - 50 CONTINUE 237 - CALL PLABOX(XBOX,YBOX,ZBOX,NCUT,XCUT,YCUT,ZCUT, 238 - - X0PL,Y0PL,Z0PL,APL,BPL,CPL) 239 - IF(NCUT.GE.3)THEN 240 - CALL PLABU1('STORE',IREF,NCUT,XCUT,YCUT,ZCUT, 241 - - APL,BPL,CPL,ICOL,IVOL,IFAIL) 242 - IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHC WARNING : Unable to'// 243 - - ' store a panel of a box.' 244 - ENDIF 245 - 10 CONTINUE 246 - END 253 GARFIELD ================================================== P=PROJECTI D=PLACHO 1 ============================ 0 + +DECK,PLACHO. 1 - SUBROUTINE PLACHO(IVOL) 2 - *----------------------------------------------------------------------- 3 - * PLACHO - Plots the outlines of a cylindrical hole. 4 - * (Last changed on 8/10/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,SOLIDS. 11.- +SEQ,GRAPHICS. 12.- +SEQ,PRINTPLOT. 13 - INTEGER IREF,IVOL,N,NMAX,I,ISIDE 14 - PARAMETER(NMAX=50) 15 - DOUBLE PRECISION X0,Y0,Z0,A,B,C,XL,YL,ZL,CT,ST,CP,SP, 16 - - FNORM,U,V,W,R1,R2,R, 17 - - XPL(4*MXEDGE),YPL(4*MXEDGE),ZPL(4*MXEDGE) 18 - *** Locate the conductor. 19 - IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN 20 - PRINT *,' !!!!!! PLACHO WARNING : Volume reference is out'// 21 - - ' of range ; not plotted.' 22 - RETURN 23 - ENDIF 24 - IREF=ISTART(IVOL) 25 - IF(IREF.LT.0.OR.IREF+11.GT.MXSBUF)THEN 26 - PRINT *,' !!!!!! PLACHO WARNING : Volume address is out'// 1 253 P=PROJECTI D=PLACHO 2 PAGE 335 27 - - ' of range ; not plotted.' 28 - RETURN 29 - ENDIF 30 - *** Locate the parameters of the surrounding box and of the cylinder. 31 - R1= CBUF(IREF+1) 32 - R2= CBUF(IREF+2) 33 - IF(R1.LE.0.OR.R2.LE.0)THEN 34 - PRINT *,' !!!!!! PLACHO WARNING : Cylindrical hole ',IVOL, 35 - - ' has a non-positive radius; not plotted.' 36 - RETURN 37 - ENDIF 38 - XL=ABS(CBUF(IREF+3)) 39 - YL=ABS(CBUF(IREF+4)) 40 - ZL=ABS(CBUF(IREF+5)) 41 - IF(R1.GE.XL.OR.R1.GE.YL.OR.R2.GE.XL.OR.R2.GE.YL)THEN 42 - PRINT *,' !!!!!! PLACHO WARNING : Cylindrical hole ',IVOL, 43 - - ' is larger than the box; not plotted.' 44 - RETURN 45 - ENDIF 46 - X0=CBUF(IREF+6) 47 - Y0=CBUF(IREF+7) 48 - Z0=CBUF(IREF+8) 49 - FNORM=SQRT(CBUF(IREF+9)**2+CBUF(IREF+10)**2+CBUF(IREF+11)**2) 50 - IF(FNORM.LE.0)THEN 51 - PRINT *,' !!!!!! PLACHO WARNING : Cylindrical hole ',IVOL, 52 - - ' has a zero norm direction vector; not plotted.' 53 - RETURN 54 - ENDIF 55 - A= CBUF(IREF+9)/FNORM 56 - B= CBUF(IREF+10)/FNORM 57 - C= CBUF(IREF+11)/FNORM 58 - N= MIN(MXEDGE-3,NMAX-1,NINT(CBUF(IREF+12))) 59 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACHO DEBUG : Drawing a'', 60 - - '' hole from address '',I4/26X,''Centre= '',3E10.3/ 61 - - 26X,''Half-lengths='',3E10.3/26X,''Direction= '',3E10.3/ 62 - - 26X,''Radii= '',2E10.3)') 63 - - IREF,X0,Y0,Z0,XL,YL,ZL,A,B,C,R1,R2 64 - * Shorthand for the rotations. 65 - CT=CBUF(IREF+13) 66 - ST=CBUF(IREF+14) 67 - CP=CBUF(IREF+15) 68 - SP=CBUF(IREF+16) 69 - *** Determine a suitable number of points on the radii. 70 - IF(N.LE.1)THEN 71 - R=MAX(R1,R2) 72 - IF(R.LT.1E-2*MAX(ABS(GXMAX-GXMIN),ABS(GYMAX-GYMIN), 73 - - ABS(GZMAX-GZMIN)))THEN 74 - N=MIN(MXEDGE-3,NMAX-1,2) 75 - ELSEIF(R.LT.1E-1*MAX(ABS(GXMAX-GXMIN),ABS(GYMAX-GYMIN), 76 - - ABS(GZMAX-GZMIN)))THEN 77 - N=MIN(MXEDGE-3,NMAX-1,3) 78 - ELSE 79 - N=MIN(MXEDGE-3,NMAX-1,4) 80 - ENDIF 81 - ENDIF 82 - * Loop over the panels. 83 - DO 10 ISIDE=-1,+1,2 84 - IF(ISIDE.EQ.-1)THEN 85 - R=0.9999*R1 86 - ELSE 87 - R=0.9999*R2 88 - ENDIF 89 - DO 20 I=1,4*N-3 90 - * The panels for x=xmax. 91 - U=R*COS(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 92 - V=R*SIN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) 93 - W=1.0001*ZL*ISIDE 94 - XPL(I)=X0+CP*CT*U-SP*V+CP*ST*W 95 - YPL(I)=Y0+SP*CT*U+CP*V+SP*ST*W 96 - ZPL(I)=Z0 -ST*U +CT*W 97 - 20 CONTINUE 98 - CALL PLAGPL(4*N-3,XPL,YPL,ZPL) 99 - 10 CONTINUE 100 - END 254 GARFIELD ================================================== P=PROJECTI D=PLACHI 1 ============================ 0 + +DECK,PLACHI. 1 - SUBROUTINE PLACHI(IVOL,XPOS,YPOS,ZPOS,INSIDE) 2 - *----------------------------------------------------------------------- 3 - * PLABXI - Determines whether a point is located inside a box. 4 - * (Last changed on 31/ 8/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,SOLIDS. 10.- +SEQ,PRINTPLOT. 11 - INTEGER IVOL,IREF 12 - DOUBLE PRECISION XL,YL,ZL,X0,Y0,Z0,R1,R2,CT,ST,CP,SP, 13 - - XPOS,YPOS,ZPOS,U,V,W 14 - LOGICAL INSIDE 15 - *** Locate the conductor. 16 - IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN 17 - PRINT *,' !!!!!! PLACHI WARNING : Volume reference is out'// 18 - - ' of range ; not checked.' 19 - RETURN 20 - ENDIF 21 - IREF=ISTART(IVOL) 22 - IF(IREF.LT.0.OR.IREF+11.GT.MXSBUF)THEN 23 - PRINT *,' !!!!!! PLACHI WARNING : Volume address is out'// 24 - - ' of range ; not checked.' 25 - RETURN 26 - ENDIF 27 - *** Locate the parameters of the surrounding box and of the cylinder. 28 - R1= CBUF(IREF+1) 1 254 P=PROJECTI D=PLACHI 2 PAGE 336 29 - R2= CBUF(IREF+2) 30 - IF(R1.LE.0.OR.R2.LE.0)THEN 31 - PRINT *,' !!!!!! PLACHI WARNING : Cylindrical hole ',IVOL, 32 - - ' has a non-positive radius; not checked.' 33 - RETURN 34 - ENDIF 35 - XL=ABS(CBUF(IREF+3)) 36 - YL=ABS(CBUF(IREF+4)) 37 - ZL=ABS(CBUF(IREF+5)) 38 - IF(R1.GE.XL.OR.R1.GE.YL.OR.R2.GE.XL.OR.R2.GE.YL.OR.ZL.LE.0)THEN 39 - PRINT *,' !!!!!! PLACHI WARNING : Cylindrical hole ',IVOL, 40 - - ' is smaller than the box; not checked.' 41 - RETURN 42 - ENDIF 43 - X0=CBUF(IREF+6) 44 - Y0=CBUF(IREF+7) 45 - Z0=CBUF(IREF+8) 46 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACHI DEBUG : Checking'', 47 - - '' hole from address '',I4/26X,''Centre= '',3E10.3/ 48 - - 26X,''Half-lengths='',3E10.3/26X,''Radii= '',2E10.3)') 49 - - IREF,X0,Y0,Z0,XL,YL,ZL,R1,R2 50 - * Shorthand for the rotations. 51 - CT=CBUF(IREF+13) 52 - ST=CBUF(IREF+14) 53 - CP=CBUF(IREF+15) 54 - SP=CBUF(IREF+16) 55 - *** Transform the point to local coordinates. 56 - U=+CP*CT*(XPOS-X0)+SP*CT*(YPOS-Y0)-ST*(ZPOS-Z0) 57 - V=-SP *(XPOS-X0)+CP* (YPOS-Y0) 58 - W=+CP*ST*(XPOS-X0)+SP*ST*(YPOS-Y0)+CT*(ZPOS-Z0) 59 - *** See whether the point is inside. 60 - IF(ABS(U).GT.XL.OR.ABS(V).GT.YL.OR.ABS(W).GT.ZL.OR. 61 - - U**2+V**2.LT.(R1+(W+ZL)*(R2-R1)/(2*ZL))**2)THEN 62 - INSIDE=.FALSE. 63 - ELSE 64 - INSIDE=.TRUE. 65 - ENDIF 66 - END 255 GARFIELD ================================================== P=PROJECTI D=PLATUB 1 ============================ 0 + +DECK,PLATUB. 1 - SUBROUTINE PLATUB(R,NTUBE,ZMIN,ZMAX) 2 - *----------------------------------------------------------------------- 3 - * PLATUB - Cross section between a plane and a tube. 4 - * (Last changed on 19/11/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,CONSTANTS. 8 - INTEGER NMAX 9 - PARAMETER(NMAX=200) 10 - DOUBLE PRECISION XPL(NMAX),YPL(NMAX),R,ZMIN,ZMAX, 11 - - X1,Y1,X2,Y2,XCUT,YCUT 12 - INTEGER NTUBE,NPL,I,N 13 - LOGICAL CUT 14 - *** Ensure the radius is not zero, and the number of corners reasonable. 15 - IF(R.LE.0.OR.NTUBE.LT.0)THEN 16 - PRINT *,' !!!!!! PLATUB WARNING : Receiving invalid'// 17 - - ' tube parameters; tube not plotted.' 18 - RETURN 19 - ENDIF 20 - *** Check that the receiving array is large enough. 21 - IF(NMAX.LT.NTUBE+1.AND.NTUBE.GT.0)THEN 22 - PRINT *,' !!!!!! PLATUB WARNING : Plot vector'// 23 - - ' is too small; tube not plotted.' 24 - RETURN 25 - ENDIF 26 - *** Number of corners. 27 - IF(NTUBE.EQ.0)THEN 28 - N=NMAX-1 29 - ELSE 30 - N=NTUBE 31 - ENDIF 32 - *** Go around the polygon or circle, initialise on first edge. 33 - X1=R 34 - Y1=0 35 - CALL PLACUT(X1,Y1,ZMIN,X1,Y1,ZMAX,XCUT,YCUT,CUT) 36 - * Loop over the edges. 37 - DO 10 I=1,N 38 - IF(CUT)THEN 39 - NPL=1 40 - XPL(NPL)=XCUT 41 - YPL(NPL)=YCUT 42 - ELSE 43 - NPL=0 44 - ENDIF 45 - * New edge. 46 - X2=R*COS(2.0D0*PI*DBLE(I)/DBLE(N)) 47 - Y2=R*SIN(2.0D0*PI*DBLE(I)/DBLE(N)) 48 - * Cut along the bottom lid. 49 - CALL PLACUT(X1,Y1,ZMIN,X2,Y2,ZMIN,XCUT,YCUT,CUT) 50 - IF(CUT)THEN 51 - NPL=NPL+1 52 - XPL(NPL)=XCUT 53 - YPL(NPL)=YCUT 54 - ENDIF 55 - * Cut along the top lid. 56 - CALL PLACUT(X1,Y1,ZMAX,X2,Y2,ZMAX,XCUT,YCUT,CUT) 57 - IF(CUT)THEN 58 - NPL=NPL+1 59 - XPL(NPL)=XCUT 60 - YPL(NPL)=YCUT 61 - ENDIF 62 - * Cut along the edge. 63 - CALL PLACUT(X2,Y2,ZMIN,X2,Y2,ZMAX,XCUT,YCUT,CUT) 64 - IF(CUT)THEN 1 255 P=PROJECTI D=PLATUB 2 PAGE 337 65 - NPL=NPL+1 66 - XPL(NPL)=XCUT 67 - YPL(NPL)=YCUT 68 - ENDIF 69 - * Plot in case a one of the lids has been crossed. 70 - IF(NPL.GE.2)CALL GRLIN2(NPL,XPL,YPL) 71 - * Shift the point. 72 - X1=X2 73 - Y1=Y2 74 - 10 CONTINUE 75 - END 256 GARFIELD ================================================== P=PROJECTI D=PLAPLA 1 ============================ 0 + +DECK,PLAPLA. 1 - SUBROUTINE PLAPLA(APL,BPL,CPL,DPL,VXMIN,VYMIN,VXMAX,VYMAX) 2 - *----------------------------------------------------------------------- 3 - * PLAPLA - Cross section between a plane and another plane. 4 - * (Last changed on 8/11/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9 - DOUBLE PRECISION APL,BPL,CPL,DPL,XPL(2),YPL(2), 10 - - VXMIN,VXMAX,VYMIN,VYMAX,A,B,C,X1,Y1,X2,Y2 11 - *** See whether the 2 planes are parallel. 12 - IF(ABS(APL*FPROJ(1,1)+BPL*FPROJ(1,2)+CPL*FPROJ(1,3)).LT. 13 - - 1D-6*SQRT(APL**2+BPL**2+CPL**2).AND. 14 - - ABS(APL*FPROJ(2,1)+BPL*FPROJ(2,2)+CPL*FPROJ(2,3)).LT. 15 - - 1D-6*SQRT(APL**2+BPL**2+CPL**2))THEN 16 - RETURN 17 - *** For non-parallel planes, establish crossing points. 18 - ELSE 19 - * Intersection equation parameters. 20 - A=FPROJ(1,1)*APL+FPROJ(1,2)*BPL+FPROJ(1,3)*CPL 21 - B=FPROJ(2,1)*APL+FPROJ(2,2)*BPL+FPROJ(2,3)*CPL 22 - C=DPL-FPROJ(3,1)*APL-FPROJ(3,2)*BPL-FPROJ(3,3)*CPL 23 - * Two points on the line. 24 - IF(A.EQ.0.AND.B.EQ.0)THEN 25 - PRINT *,' !!!!!! PLAPLA WARNING : Unable to compute'// 26 - - ' intersect between 2 lines; line not plotted.' 27 - RETURN 28 - ELSEIF(ABS(A).GT.ABS(B))THEN 29 - CALL PLACOO( 30 - - FPROJ(3,1)+C*FPROJ(1,1)/A, 31 - - FPROJ(3,2)+C*FPROJ(1,2)/A, 32 - - FPROJ(3,3)+C*FPROJ(1,3)/A, 33 - - X1,Y1) 34 - CALL PLACOO( 35 - - FPROJ(3,1)+FPROJ(2,1)+(C-B)*FPROJ(1,1)/A, 36 - - FPROJ(3,2)+FPROJ(2,2)+(C-B)*FPROJ(1,2)/A, 37 - - FPROJ(3,3)+FPROJ(2,3)+(C-B)*FPROJ(1,3)/A, 38 - - X2,Y2) 39 - ELSE 40 - CALL PLACOO( 41 - - FPROJ(3,1)+C*FPROJ(2,1)/B, 42 - - FPROJ(3,2)+C*FPROJ(2,2)/B, 43 - - FPROJ(3,3)+C*FPROJ(2,3)/B, 44 - - X1,Y1) 45 - CALL PLACOO( 46 - - FPROJ(3,1)+FPROJ(1,1)+(C-A)*FPROJ(2,1)/B, 47 - - FPROJ(3,2)+FPROJ(1,2)+(C-A)*FPROJ(2,2)/B, 48 - - FPROJ(3,3)+FPROJ(1,3)+(C-A)*FPROJ(2,3)/B, 49 - - X2,Y2) 50 - ENDIF 51 - * Extend the line to the full area. 52 - IF(X1.EQ.X2.AND.Y1.EQ.Y2)THEN 53 - PRINT *,' !!!!!! PLAPLA WARNING : Intersect line'// 54 - - ' is point-like; line not plotted.' 55 - RETURN 56 - ELSEIF(ABS(X1-X2).GT.ABS(Y1-Y2))THEN 57 - XPL(1)=VXMIN 58 - YPL(1)=Y1+(VXMIN-X1)*(Y2-Y1)/(X2-X1) 59 - XPL(2)=VXMAX 60 - YPL(2)=Y1+(VXMAX-X1)*(Y2-Y1)/(X2-X1) 61 - ELSE 62 - XPL(1)=X1+(VYMIN-Y1)*(X2-X1)/(Y2-Y1) 63 - YPL(1)=VYMIN 64 - XPL(2)=X1+(VYMAX-Y1)*(X2-X1)/(Y2-Y1) 65 - YPL(2)=VYMAX 66 - ENDIF 67 - ENDIF 68 - *** Seems to have worked, plot the line. 69 - CALL GRLIN2(2,XPL,YPL) 70 - END 257 GARFIELD ================================================== P=PROJECTI D=PLAPOL 1 ============================ 0 + +DECK,PLAPOL. 1 - SUBROUTINE PLAPOL(XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX,XIN,YIN,ZIN,NIN, 2 - - A,B,C,XPL,YPL,ZPL,NPL) 3 - *----------------------------------------------------------------------- 4 - * PLAPOL - Cuts a box with a polygon. 5 - * (Last changed on 30/ 9/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PARAMETERS. 10 - INTEGER NIN,NPL,IFAIL,NBOX,I,J 11 - DOUBLE PRECISION XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX, 12 - - XIN(NIN),YIN(NIN),ZIN(NIN), 13 - - A,B,C,EPSX,EPSY,EPSZ,ZAUX1,ZAUX2, 14 - - XPOL(MXEDGE),YPOL(MXEDGE),ZPOL(MXEDGE),XAUX,YAUX,ZAUX, 15 - - XBOX(12),YBOX(12),ZBOX(12), 16 - - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), 17 - - X0,Y0,Z0,X1,Y1,Z1 1 257 P=PROJECTI D=PLAPOL 2 PAGE 338 18 - LOGICAL CROSSD,ONLIND,ADD,SKIP,INSIDE,EDGE 19 - EXTERNAL CROSSD,ONLIND 20 - C print *,' PLAPOL - Number of points: ',NIN 21 - C do i=1,nin 22 - C print '(3f12.5)',xin(i),yin(i),zin(i) 23 - C enddo 24 - C print *,' PLAPOL - Plane: ',a,b,c 25 - *** Make sure there is at least 1 input point. 26 - IF(NIN.LT.0)THEN 27 - NPL=0 28 - RETURN 29 - * Check that there is enough storage space. 30 - ELSEIF(NIN.GT.MXEDGE)THEN 31 - PRINT *,' !!!!!! PLAPOL WARNING : Array dimensions are'// 32 - - ' not sufficient ; no plot vector returned.' 33 - NPL=0 34 - RETURN 35 - ENDIF 36 - *** Compute the, at most, 6 distinct crossings between plane and box. 37 - NBOX=0 38 - CALL PLALIN(XMIN,YMIN,ZMIN,XMAX,YMIN,ZMIN,XIN(1),YIN(1),ZIN(1), 39 - - A,B,C,XAUX,YAUX,ZAUX,IFAIL) 40 - IF(IFAIL.EQ.0)THEN 41 - NBOX=NBOX+1 42 - CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) 43 - ENDIF 44 - CALL PLALIN(XMIN,YMIN,ZMIN,XMIN,YMAX,ZMIN,XIN(1),YIN(1),ZIN(1), 45 - - A,B,C,XAUX,YAUX,ZAUX,IFAIL) 46 - IF(IFAIL.EQ.0)THEN 47 - NBOX=NBOX+1 48 - CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) 49 - ENDIF 50 - CALL PLALIN(XMIN,YMIN,ZMIN,XMIN,YMIN,ZMAX,XIN(1),YIN(1),ZIN(1), 51 - - A,B,C,XAUX,YAUX,ZAUX,IFAIL) 52 - IF(IFAIL.EQ.0)THEN 53 - NBOX=NBOX+1 54 - CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) 55 - ENDIF 56 - CALL PLALIN(XMAX,YMAX,ZMIN,XMAX,YMIN,ZMIN,XIN(1),YIN(1),ZIN(1), 57 - - A,B,C,XAUX,YAUX,ZAUX,IFAIL) 58 - IF(IFAIL.EQ.0)THEN 59 - NBOX=NBOX+1 60 - CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) 61 - ENDIF 62 - CALL PLALIN(XMAX,YMAX,ZMIN,XMIN,YMAX,ZMIN,XIN(1),YIN(1),ZIN(1), 63 - - A,B,C,XAUX,YAUX,ZAUX,IFAIL) 64 - IF(IFAIL.EQ.0)THEN 65 - NBOX=NBOX+1 66 - CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) 67 - ENDIF 68 - CALL PLALIN(XMAX,YMAX,ZMIN,XMAX,YMAX,ZMAX,XIN(1),YIN(1),ZIN(1), 69 - - A,B,C,XAUX,YAUX,ZAUX,IFAIL) 70 - IF(IFAIL.EQ.0)THEN 71 - NBOX=NBOX+1 72 - CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) 73 - ENDIF 74 - CALL PLALIN(XMAX,YMIN,ZMAX,XMAX,YMIN,ZMIN,XIN(1),YIN(1),ZIN(1), 75 - - A,B,C,XAUX,YAUX,ZAUX,IFAIL) 76 - IF(IFAIL.EQ.0)THEN 77 - NBOX=NBOX+1 78 - CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) 79 - ENDIF 80 - CALL PLALIN(XMAX,YMIN,ZMAX,XMAX,YMAX,ZMAX,XIN(1),YIN(1),ZIN(1), 81 - - A,B,C,XAUX,YAUX,ZAUX,IFAIL) 82 - IF(IFAIL.EQ.0)THEN 83 - NBOX=NBOX+1 84 - CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) 85 - ENDIF 86 - CALL PLALIN(XMAX,YMIN,ZMAX,XMIN,YMIN,ZMAX,XIN(1),YIN(1),ZIN(1), 87 - - A,B,C,XAUX,YAUX,ZAUX,IFAIL) 88 - IF(IFAIL.EQ.0)THEN 89 - NBOX=NBOX+1 90 - CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) 91 - ENDIF 92 - CALL PLALIN(XMIN,YMAX,ZMAX,XMIN,YMAX,ZMIN,XIN(1),YIN(1),ZIN(1), 93 - - A,B,C,XAUX,YAUX,ZAUX,IFAIL) 94 - IF(IFAIL.EQ.0)THEN 95 - NBOX=NBOX+1 96 - CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) 97 - ENDIF 98 - CALL PLALIN(XMIN,YMAX,ZMAX,XMIN,YMIN,ZMAX,XIN(1),YIN(1),ZIN(1), 99 - - A,B,C,XAUX,YAUX,ZAUX,IFAIL) 100 - IF(IFAIL.EQ.0)THEN 101 - NBOX=NBOX+1 102 - CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) 103 - ENDIF 104 - CALL PLALIN(XMIN,YMAX,ZMAX,XMAX,YMAX,ZMAX,XIN(1),YIN(1),ZIN(1), 105 - - A,B,C,XAUX,YAUX,ZAUX,IFAIL) 106 - IF(IFAIL.EQ.0)THEN 107 - NBOX=NBOX+1 108 - CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) 109 - ENDIF 110 - *** If there are no box points, there can't be an intersect. 111 - IF(NBOX.LE.0)THEN 112 - C print *,' Polygon plane does not cross the box' 113 - NPL=0 114 - RETURN 115 - ENDIF 116 - *** Ensure there is no butterfly. 117 - C print *,' Box before butterfly: ' 118 - C do i=1,nbox 119 - C print '(3e12.5)',xbox(i),ybox(i),zbox(i) 120 - C enddo 121 - CALL BUTFLD(NBOX,XBOX,YBOX,ZBOX) 122 - C call gsln(2) 123 - C call gpl2(nbox,xbox,ybox) 1 257 P=PROJECTI D=PLAPOL 3 PAGE 339 124 - C call guwk(0,1) 125 - C print *,' Number of box points: ',nbox 126 - *** Set tolerances. 127 - IF(LEPSG)THEN 128 - EPSX=EPSGX 129 - EPSY=EPSGY 130 - EPSZ=EPSGZ 131 - ELSE 132 - EPSX=1.0D-8*ABS(XMAX-XMIN) 133 - EPSY=1.0D-8*ABS(YMAX-YMIN) 134 - EPSZ=1.0D-8*ABS(ZMAX-ZMIN) 135 - IF(EPSX.LE.0)EPSX=1.0E-8 136 - IF(EPSY.LE.0)EPSY=1.0E-8 137 - IF(EPSZ.LE.0)EPSZ=1.0E-8 138 - ENDIF 139 - *** Compute projections of the input points. 140 - DO 20 I=1,NIN 141 - CALL PLACO3(XIN(I),YIN(I),ZIN(I),XPOL(I),YPOL(I),ZPOL(I)) 142 - 20 CONTINUE 143 - C call gpl2(nin,xpol,ypol) 144 - C call guwk(0,1) 145 - *** Next find the intersections between the two sets. 146 - NPL=0 147 - DO 40 J=1,NIN 148 - C print *,' Polygon corner ',J,' : ',xpol(j),ypol(j) 149 - * Set flag to see whether we search for mid-line intersects. 150 - SKIP=.FALSE. 151 - * Scan the box. 152 - DO 30 I=1,NBOX 153 - * See whether the polygon start is on any of the box edges. 154 - IF(ONLIND(XBOX(1+MOD(I-1,NBOX)),YBOX(1+MOD(I-1,NBOX)), 155 - - XBOX(1+MOD(I,NBOX)),YBOX(1+MOD(I,NBOX)), 156 - - XPOL(J),YPOL(J)).AND. 157 - - XIN(J).GE.XMIN-EPSX.AND.XIN(J).LE.XMAX+EPSX.AND. 158 - - YIN(J).GE.YMIN-EPSY.AND.YIN(J).LE.YMAX+EPSY.AND. 159 - - ZIN(J).GE.ZMIN-EPSZ.AND.ZIN(J).LE.ZMAX+EPSZ)THEN 160 - NPL=NPL+1 161 - XPL(NPL)=XPOL(J) 162 - YPL(NPL)=YPOL(J) 163 - ZPL(NPL)=ZPOL(J) 164 - C print *,' Polygon corner on box line: ',xpl(npl),ypl(npl), 165 - C - zpl(npl) 166 - SKIP=.TRUE. 167 - ENDIF 168 - * See whether a box corner is on this polygon segment. 169 - IF(ONLIND(XPOL(1+MOD(J-1,NIN)),YPOL(1+MOD(J-1,NIN)), 170 - - XPOL(1+MOD(J,NIN)),YPOL(1+MOD(J,NIN)), 171 - - XBOX(I),YBOX(I)))THEN 172 - NPL=NPL+1 173 - XPL(NPL)=XBOX(I) 174 - YPL(NPL)=YBOX(I) 175 - ZPL(NPL)=ZBOX(I) 176 - C print *,' Box corner on polygon line: ',xpl(npl),ypl(npl), 177 - C - zpl(npl) 178 - SKIP=.TRUE. 179 - ENDIF 180 - 30 CONTINUE 181 - * Make sure that the polygon segment at least crosses the box. 182 - X0=XIN(1+MOD(J-1,NIN)) 183 - Y0=YIN(1+MOD(J-1,NIN)) 184 - Z0=ZIN(1+MOD(J-1,NIN)) 185 - X1=XIN(1+MOD(J ,NIN)) 186 - Y1=YIN(1+MOD(J ,NIN)) 187 - Z1=ZIN(1+MOD(J ,NIN)) 188 - IF(.NOT.(((ABS(X0-XMIN).LT.EPSX.AND.ABS(X1-XMIN).LT.EPSX).OR. 189 - - (ABS(X0-XMAX).LT.EPSX.AND.ABS(X1-XMAX).LT.EPSX)).AND. 190 - - ((YMIN-Y0)*(Y0-YMAX).GE.0.OR.(YMIN-Y1)*(Y1-YMAX).GE.0).AND. 191 - - ((ZMIN-Z0)*(Z0-ZMAX).GE.0.OR.(ZMIN-Z1)*(Z1-ZMAX).GE.0).OR. 192 - - ((ABS(Y0-YMIN).LT.EPSY.AND.ABS(Y1-YMIN).LT.EPSY).OR. 193 - - (ABS(Y0-YMAX).LT.EPSY.AND.ABS(Y1-YMAX).LT.EPSY)).AND. 194 - - ((XMIN-X0)*(X0-XMAX).GE.0.OR.(XMIN-X1)*(X1-XMAX).GE.0).AND. 195 - - ((ZMIN-Z0)*(Z0-ZMAX).GE.0.OR.(ZMIN-Z1)*(Z1-ZMAX).GE.0).OR. 196 - - ((ABS(Z0-ZMIN).LT.EPSZ.AND.ABS(Z1-ZMIN).LT.EPSZ).OR. 197 - - (ABS(Z0-ZMAX).LT.EPSZ.AND.ABS(Z1-ZMAX).LT.EPSZ)).AND. 198 - - ((XMIN-X0)*(X0-XMAX).GE.0.OR.(XMIN-X1)*(X1-XMAX).GE.0).AND. 199 - - ((YMIN-Y0)*(Y0-YMAX).GE.0.OR.(YMIN-Y1)*(Y1-YMAX).GE.0)))THEN 200 - CALL CLIP3D(X0,Y0,Z0,X1,Y1,Z1,XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX, 201 - - IFAIL) 202 - C if(ifail.ne.0)print *,' Segment not through volume.' 203 - C if(ifail.ne.0)print '(2x,3f12.5)',x0,y0,z0 204 - C if(ifail.ne.0)print '(2x,3f12.5)',x1,y1,z1 205 - IF(IFAIL.NE.0)SKIP=.TRUE. 206 - C else 207 - C print *,' Line segment on outer box.' 208 - ENDIF 209 - * If neither of this happened, look for mid-line intersects. 210 - IF(.NOT.SKIP)THEN 211 - DO 100 I=1,NBOX 212 - CALL CRSPND(XBOX(1+MOD(I-1,NBOX)),YBOX(1+MOD(I-1,NBOX)), 213 - - XBOX(1+MOD(I ,NBOX)),YBOX(1+MOD(I ,NBOX)), 214 - - XPOL(1+MOD(J-1,NIN )),YPOL(1+MOD(J-1,NIN )), 215 - - XPOL(1+MOD(J ,NIN )),YPOL(1+MOD(J ,NIN )), 216 - - XAUX,YAUX,ADD) 217 - IF(ADD)THEN 218 - NPL=NPL+1 219 - XPL(NPL)=XAUX 220 - YPL(NPL)=YAUX 221 - IF(XBOX(1+MOD(I,NBOX)).EQ.XBOX(1+MOD(I-1,NBOX)).AND. 222 - - YBOX(1+MOD(I,NBOX)).EQ.YBOX(1+MOD(I-1,NBOX)))THEN 223 - PRINT *,' !!!!!! PLAPOL WARNING : Unable to'// 224 - - ' compute intersect offset ; skipped.' 225 - NPL=NPL-1 226 - GOTO 100 227 - ELSEIF(ABS(XBOX(1+MOD(I,NBOX))- 228 - - XBOX(1+MOD(I-1,NBOX))).GT. 229 - - ABS(YBOX(1+MOD(I,NBOX))- 1 257 P=PROJECTI D=PLAPOL 4 PAGE 340 230 - - YBOX(1+MOD(I-1,NBOX))))THEN 231 - ZAUX1=ZBOX(1+MOD(I-1,NBOX))+ 232 - - (XAUX-XBOX(1+MOD(I-1,NBOX)))* 233 - - (ZBOX(1+MOD(I,NBOX))-ZBOX(1+MOD(I-1,NBOX)))/ 234 - - (XBOX(1+MOD(I,NBOX))-XBOX(1+MOD(I-1,NBOX))) 235 - ELSE 236 - ZAUX1=ZBOX(1+MOD(I-1,NBOX))+ 237 - - (YAUX-YBOX(1+MOD(I-1,NBOX)))* 238 - - (ZBOX(1+MOD(I,NBOX))-ZBOX(1+MOD(I-1,NBOX)))/ 239 - - (YBOX(1+MOD(I,NBOX))-YBOX(1+MOD(I-1,NBOX))) 240 - ENDIF 241 - IF(XPOL(1+MOD(J,NIN)).EQ.XPOL(1+MOD(J-1,NIN)).AND. 242 - - YPOL(1+MOD(J,NIN)).EQ.YPOL(1+MOD(J-1,NIN)))THEN 243 - PRINT *,' !!!!!! PLAPOL WARNING : Unable to'// 244 - - ' compute intersect offset ; skipped.' 245 - NPL=NPL-1 246 - GOTO 100 247 - ELSEIF(ABS(XPOL(1+MOD(J,NIN))-XPOL(1+MOD(J-1,NIN))).GT. 248 - - ABS(YPOL(1+MOD(J,NIN))-YPOL(1+MOD(J-1,NIN))))THEN 249 - ZAUX2=ZPOL(1+MOD(J-1,NIN))+ 250 - - (XAUX-XPOL(1+MOD(J-1,NIN)))* 251 - - (ZPOL(1+MOD(J,NIN))-ZPOL(1+MOD(J-1,NIN)))/ 252 - - (XPOL(1+MOD(J,NIN))-XPOL(1+MOD(J-1,NIN))) 253 - ELSE 254 - ZAUX2=ZPOL(1+MOD(J-1,NIN))+ 255 - - (YAUX-YPOL(1+MOD(J-1,NIN)))* 256 - - (ZPOL(1+MOD(J,NIN))-ZPOL(1+MOD(J-1,NIN)))/ 257 - - (YPOL(1+MOD(J,NIN))-YPOL(1+MOD(J-1,NIN))) 258 - ENDIF 259 - ZPL(NPL)=0.5*(ZAUX1+ZAUX2) 260 - C print *,' Offsets: ',zaux1,zaux2,zpl(npl) 261 - C print *,' Line crossing: ',xpl(npl),ypl(npl),zpl(npl) 262 - ENDIF 263 - 100 CONTINUE 264 - ENDIF 265 - 40 CONTINUE 266 - *** Find the vertices of the box internal to the polygon. 267 - DO 50 I=1,NBOX 268 - C print *,' Box ',i,':',xbox(i),ybox(i),zbox(i) 269 - CALL INTERD(NIN,XPOL,YPOL,XBOX(I),YBOX(I),INSIDE,EDGE) 270 - * Skip box corners on the polygon. 271 - IF(EDGE)GOTO 50 272 - * Add internal points. 273 - IF(INSIDE)THEN 274 - NPL=NPL+1 275 - XPL(NPL)=XBOX(I) 276 - YPL(NPL)=YBOX(I) 277 - ZPL(NPL)=ZBOX(I) 278 - C print *,' box in polygon: ',xpl(npl),ypl(npl),zpl(npl) 279 - ENDIF 280 - 50 CONTINUE 281 - *** Find the vertices of the polygon internal to the box. 282 - DO 70 I=1,NIN 283 - C print *,' Pol ',i,':',xpol(i),ypol(i),zpol(i) 284 - * Skip points which were not inside the box. 285 - IF(XIN(I).LT.XMIN-EPSX.OR.XIN(I).GT.XMAX+EPSX.OR. 286 - - YIN(I).LT.YMIN-EPSY.OR.YIN(I).GT.YMAX+EPSY.OR. 287 - - ZIN(I).LT.ZMIN-EPSZ.OR.ZIN(I).GT.ZMAX+EPSZ)GOTO 70 288 - * Check whether the point is internal. 289 - CALL INTERD(NBOX,XBOX,YBOX,XPOL(I),YPOL(I),INSIDE,EDGE) 290 - * Skip polygon corners on the box. 291 - IF(EDGE)GOTO 70 292 - * Add internal points. 293 - IF(INSIDE)THEN 294 - NPL=NPL+1 295 - XPL(NPL)=XPOL(I) 296 - YPL(NPL)=YPOL(I) 297 - ZPL(NPL)=ZPOL(I) 298 - C print *,' polygon in box: ',xpl(npl),ypl(npl),zpl(npl) 299 - ENDIF 300 - 70 CONTINUE 301 - *** Ensure there is no butterfly. 302 - C print *,' Checking for butterfly' 303 - CALL BUTFLD(NPL,XPL,YPL,ZPL) 304 - C print *,' Continue ? Enter an integer.' 305 - C read *,j 306 - C call gsln(1) 307 - C call gpl2(npl,xpl,ypl) 308 - C call guwk(0,1) 309 - C print *,' PLAPOL - Final result, NPL=',npl 310 - C do i=1,npl 311 - C print '(3f12.5)',xpl(i),ypl(i),zpl(i) 312 - C enddo 313 - END 258 GARFIELD ================================================== P=PROJECTI D=PLACUT 1 ============================ 0 + +DECK,PLACUT. 1 - SUBROUTINE PLACUT(X1,Y1,Z1,X2,Y2,Z2,XCUT,YCUT,CUT) 2 - *----------------------------------------------------------------------- 3 - * PLACUT - Cuts a plane with a line. 4 - * (Last changed on 7/11/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9 - DOUBLE PRECISION X1,Y1,Z1,X2,Y2,Z2,XCUT,YCUT,A(3,3),B(3) 10 - INTEGER IR(3),IFAIL 11 - LOGICAL CUT 12 - *** Initial settings. 13 - XCUT=0 14 - YCUT=0 15 - CUT=.FALSE. 16 - *** Fill the matrices. 17 - A(1,1)=FPROJ(1,1) 18 - A(2,1)=FPROJ(1,2) 1 258 P=PROJECTI D=PLACUT 2 PAGE 341 19 - A(3,1)=FPROJ(1,3) 20 - A(1,2)=FPROJ(2,1) 21 - A(2,2)=FPROJ(2,2) 22 - A(3,2)=FPROJ(2,3) 23 - A(1,3)=X1-X2 24 - A(2,3)=Y1-Y2 25 - A(3,3)=Z1-Z2 26 - B(1)=X1-FPROJ(3,1) 27 - B(2)=Y1-FPROJ(3,2) 28 - B(3)=Z1-FPROJ(3,3) 29 - *** Solve the equation. 30 - CALL DEQN(3,A,3,IR,IFAIL,1,B) 31 - *** Immediate return if there is no solution. 32 - IF(IFAIL.NE.0)RETURN 33 - *** If there is a solution, ensure it is between point 1 and 2. 34 - IF(B(3).LT.0.OR.B(3).GT.1)RETURN 35 - *** Otherwise it is a bonafide solution. 36 - XCUT=B(1) 37 - YCUT=B(2) 38 - CUT=.TRUE. 39 - END 259 GARFIELD ================================================== P=PROJECTI D=PLACOO 1 ============================ 0 + +DECK,PLACOO. 1 - SUBROUTINE PLACOO(X1,Y1,Z1,XCUT,YCUT) 2 - *----------------------------------------------------------------------- 3 - * PLACOO - Determines plane coordinates. 4 - * (Last changed on 29/ 9/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9 - DOUBLE PRECISION X1,Y1,Z1,XCUT,YCUT,B(3) 10 - *** Fill the vector. 11 - B(1)=X1 12 - B(2)=Y1 13 - B(3)=Z1 14 - *** Solve the equation. 15 - CALL DFEQN(3,FPRMAT,3,IPRMAT,1,B) 16 - *** Return the solution. 17 - XCUT=B(1) 18 - YCUT=B(2) 19 - END 260 GARFIELD ================================================== P=PROJECTI D=PLACO3 1 ============================ 0 + +DECK,PLACO3. 1 - SUBROUTINE PLACO3(X1,Y1,Z1,XCUT,YCUT,ZCUT) 2 - *----------------------------------------------------------------------- 3 - * PLACO3 - Determines plane coordinates. 4 - * (Last changed on 29/ 9/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9 - DOUBLE PRECISION X1,Y1,Z1,XCUT,YCUT,ZCUT,B(3) 10 - *** Fill the vector. 11 - B(1)=X1 12 - B(2)=Y1 13 - B(3)=Z1 14 - *** Solve the equation. 15 - CALL DFEQN(3,FPRMAT,3,IPRMAT,1,B) 16 - *** Return the solution. 17 - XCUT=B(1) 18 - YCUT=B(2) 19 - ZCUT=(FPROJA*X1+FPROJB*Y1+FPROJC*Z1)/FPROJN 20 - END 261 GARFIELD ================================================== P=PROJECTI D=PLALIN 1 ============================ 0 + +DECK,PLALIN. 1 - SUBROUTINE PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0,Y0,Z0,A,B,C, 2 - - XCUT,YCUT,ZCUT,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * PLALIN - Cuts an arbitrary plane with a line. 5 - * Variables : (X1,Y1,Z1) : starting point of the line 6 - * (X2,Y2,Z2) : end point of the line 7 - * (X0,Y0,Z0) : point on the plane 8 - * (A,B,C) : parameters of the plane 9 - * (Last changed on 31/ 1/98.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12 - DOUBLE PRECISION X1,Y1,Z1,X2,Y2,Z2,X0,Y0,Z0,A,B,C, 13 - - XCUT,YCUT,ZCUT,XLAM,PROD1,PROD2,EPS 14 - INTEGER IFAIL 15 - *** Initial values for the return parameters. 16 - XCUT=0 17 - YCUT=0 18 - ZCUT=0 19 - *** Form the two products. 20 - PROD1=(X0-X1)*A+(Y0-Y1)*B+(Z0-Z1)*C 21 - PROD2=(X2-X1)*A+(Y2-Y1)*B+(Z2-Z1)*C 22 - *** Set a tolerance for lambda. 23 - EPS=1.0D-5 24 - *** Check the products are non-zero. 25 - IF(ABS(PROD2).GT.1.0D-6*SQRT((A**2+B**2+C**2)* 26 - - (X2-X1)**2+(Y2-Y1)**2+(Z2-Z1)**2))THEN 27 - XLAM=PROD1/PROD2 28 - IF(XLAM.GE.-EPS.AND.XLAM.LE.1.0D0+EPS)THEN 29 - IFAIL=0 30 - ELSE 31 - IFAIL=1 32 - ENDIF 33 - XLAM=MAX(0.0D0,MIN(1.0D0,XLAM)) 34 - XCUT=X1+XLAM*(X2-X1) 1 261 P=PROJECTI D=PLALIN 2 PAGE 342 35 - YCUT=Y1+XLAM*(Y2-Y1) 36 - ZCUT=Z1+XLAM*(Z2-Z1) 37 - ELSE 38 - XCUT=0 39 - YCUT=0 40 - ZCUT=0 41 - IFAIL=1 42 - ENDIF 43 - END 262 GARFIELD ================================================== P=PROJECTI D=PLACHK 1 ============================ 0 + +DECK,PLACHK. 1 - SUBROUTINE PLACHK(NPL,XPL,YPL,ZPL,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * PLACHK - Checks whether a set of points builds a non-trivial 4 - * polygon in the (x,y) plane. 5 - * (Last changed on 22/ 9/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PARAMETERS. 10 - INTEGER NPL,IFAIL,I1,I2,I 11 - DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL),X1,Y1,X2,Y2, 12 - - DIST,XMIN,YMIN,XMAX,YMAX,EPSX,EPSY 13 - *** First check number of points. 14 - IF(NPL.LT.3)THEN 15 - C print *,' PLACHK - Not enough points: ',NPL 16 - IFAIL=1 17 - RETURN 18 - ENDIF 19 - *** Find a second point at maximum distance of the first. 20 - DIST=0 21 - I1=0 22 - XMIN=XPL(1) 23 - YMIN=YPL(1) 24 - XMAX=XPL(1) 25 - YMAX=YPL(1) 26 - DO 10 I=2,NPL 27 - XMIN=MIN(XMIN,XPL(I)) 28 - YMIN=MIN(YMIN,YPL(I)) 29 - XMAX=MAX(XMAX,XPL(I)) 30 - YMAX=MAX(YMAX,YPL(I)) 31 - IF((XPL(I)-XPL(1))**2+(YPL(I)-YPL(1))**2.GT.DIST)THEN 32 - X1=XPL(I)-XPL(1) 33 - Y1=YPL(I)-YPL(1) 34 - DIST=X1**2+Y1**2 35 - I1=I 36 - ENDIF 37 - 10 CONTINUE 38 - *** Set tolerances. 39 - IF(LEPSG)THEN 40 - EPSX=EPSGX 41 - EPSY=EPSGY 42 - ELSE 43 - EPSX=1.0D-6*(ABS(XMAX)+ABS(XMIN)) 44 - EPSY=1.0D-6*(ABS(YMAX)+ABS(YMIN)) 45 - IF(EPSX.LE.0)EPSX=1.0D-6 46 - IF(EPSY.LE.0)EPSY=1.0D-6 47 - ENDIF 48 - *** See whether there is a range at all. 49 - IF(ABS(XMAX-XMIN).LE.EPSX.AND.ABS(YMAX-YMIN).LE.EPSY)THEN 50 - C print *,' PLACHK - Is a single point.' 51 - IFAIL=1 52 - RETURN 53 - ENDIF 54 - *** See whether there is a second point. 55 - IF(DIST.LE.EPSX**2+EPSY**2.OR.I1.LE.0)THEN 56 - C print *,' PLACHK - No second point.' 57 - IFAIL=1 58 - RETURN 59 - ENDIF 60 - *** Find a third point maximising the external product. 61 - DIST=0 62 - I2=0 63 - DO 20 I=2,NPL 64 - IF(I.EQ.I1)GOTO 20 65 - IF(ABS(X1*(YPL(I)-YPL(1))-Y1*(XPL(I)-XPL(1))).GT.DIST)THEN 66 - X2=XPL(I)-XPL(1) 67 - Y2=YPL(I)-YPL(1) 68 - DIST=ABS(X1*Y2-Y1*X2) 69 - I2=I 70 - ENDIF 71 - 20 CONTINUE 72 - IF(DIST.LE.EPSX*EPSY.OR.I2.LE.0)THEN 73 - C print *,' PLACHK - No third point, DIST2=',DIST,' EPS=',EPS 74 - IFAIL=1 75 - RETURN 76 - ENDIF 77 - *** Seems to be OK. 78 - IFAIL=0 79 - END 263 GARFIELD ================================================== P=PROJECTI D=PLASEP 1 ============================ 0 + +DECK,PLASEP. 1 - SUBROUTINE PLASEP( 2 - - NPL1,XPL1,YPL1,ZPL1,A1,B1,C1,D1, 3 - - NPL2,XPL2,YPL2,ZPL2,A2,B2,C2,D2, 4 - - X0,Y0,Z0,AI,BI,CI,IFAIL) 5 - *----------------------------------------------------------------------- 6 - * PLASEP - Computes a plane that includes the crossing between plane 7 - * 1 and 2 and doesn't coincide with either. 8 - * them for plotting. 9 - * (Last changed on 29/ 9/98.) 10 - *----------------------------------------------------------------------- 1 263 P=PROJECTI D=PLASEP 2 PAGE 343 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,PARAMETERS. 14.- +SEQ,PRINTPLOT. 15 - INTEGER IFAIL,NPL1,NPL2,NCOM,I,J,K 16 - DOUBLE PRECISION A1,B1,C1,D1,A2,B2,C2,D2,XC,YC,ZC,XL, 17 - - X0,Y0,Z0,AI,BI,CI,FNORM, 18 - - EPSX,EPSY,EPSZ,XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX, 19 - - XPL1(NPL1),YPL1(NPL1),ZPL1(NPL1), 20 - - XPL2(NPL2),YPL2(NPL2),ZPL2(NPL2), 21 - - XCOM(MXEDGE),YCOM(MXEDGE),ZCOM(MXEDGE) 22 - *** Set tolerances. 23 - IF(LEPSG)THEN 24 - EPSX=EPSGX 25 - EPSY=EPSGY 26 - EPSZ=EPSGZ 27 - ELSE 28 - XMIN=XPL1(1) 29 - XMAX=XPL1(1) 30 - YMIN=YPL1(1) 31 - YMAX=YPL1(1) 32 - ZMIN=ZPL1(1) 33 - ZMAX=ZPL1(1) 34 - DO 10 I=2,NPL1 35 - XMIN=MIN(XMIN,XPL1(I)) 36 - XMAX=MAX(XMAX,XPL1(I)) 37 - YMIN=MIN(YMIN,YPL1(I)) 38 - YMAX=MAX(YMAX,YPL1(I)) 39 - ZMIN=MIN(ZMIN,ZPL1(I)) 40 - ZMAX=MAX(ZMAX,ZPL1(I)) 41 - 10 CONTINUE 42 - DO 20 I=1,NPL2 43 - XMIN=MIN(XMIN,XPL2(I)) 44 - XMAX=MAX(XMAX,XPL2(I)) 45 - YMIN=MIN(YMIN,YPL2(I)) 46 - YMAX=MAX(YMAX,YPL2(I)) 47 - ZMIN=MIN(ZMIN,ZPL2(I)) 48 - ZMAX=MAX(ZMAX,ZPL2(I)) 49 - 20 CONTINUE 50 - EPSX=1.0D-8*ABS(XMAX-XMIN) 51 - EPSY=1.0D-8*ABS(YMAX-YMIN) 52 - EPSZ=1.0D-8*ABS(ZMAX-ZMIN) 53 - IF(EPSX.LE.0)EPSX=1.0D-8 54 - IF(EPSY.LE.0)EPSY=1.0D-8 55 - IF(EPSZ.LE.0)EPSZ=1.0D-8 56 - ENDIF 57 - *** Initial values for the return parameters. 58 - X0=0 59 - Y0=0 60 - Z0=0 61 - AI=0 62 - BI=0 63 - CI=0 64 - *** See whether the planes are parallel. 65 - IF((B1*C2-B2*C1)**2+(C1*A2-C2*A1)**2+(A1*B2-A2*B1)**2.LT. 66 - - 1.0D-6*SQRT((A1**2+B1**2+C1**2)*(A2**2+B2**2+C2**2)))THEN 67 - IFAIL=1 68 - RETURN 69 - ENDIF 70 - *** See how many common points there are between the curves. 71 - NCOM=0 72 - DO 100 I=1,NPL1 73 - DO 110 J=1,NPL2 74 - IF(ABS(XPL1(I)-XPL2(J)).LE.EPSX.AND. 75 - - ABS(YPL1(I)-YPL2(J)).LE.EPSY.AND. 76 - - ABS(ZPL1(I)-ZPL2(J)).LE.EPSZ)THEN 77 - DO 120 K=1,NCOM 78 - IF(ABS(XPL1(I)+XPL2(J)-2*XCOM(K)).LE.EPSX.AND. 79 - - ABS(YPL1(I)+YPL2(J)-2*YCOM(K)).LE.EPSY.AND. 80 - - ABS(ZPL1(I)+ZPL2(J)-2*ZCOM(K)).LE.EPSZ)GOTO 110 81 - 120 CONTINUE 82 - NCOM=NCOM+1 83 - IF(NCOM.GE.MXEDGE)GOTO 110 84 - XCOM(NCOM)=(XPL1(I)+XPL2(J))/2 85 - YCOM(NCOM)=(YPL1(I)+YPL2(J))/2 86 - ZCOM(NCOM)=(ZPL1(I)+ZPL2(J))/2 87 - ENDIF 88 - 110 CONTINUE 89 - 100 CONTINUE 90 - *** Debugging output. 91 - IF(LDEBUG)THEN 92 - WRITE(LUNOUT,'('' ++++++ PLASEP DEBUG : Number of'', 93 - - '' common points: '',I3)') NCOM 94 - DO 130 I=1,NCOM 95 - WRITE(LUNOUT,'(26X,''Point '',I3,'' (x,y,z)='',3F12.5)') 96 - - I,XCOM(I),YCOM(I),ZCOM(I) 97 - 130 CONTINUE 98 - ENDIF 99 - *** No common points. 100 - IF(NCOM.EQ.0)THEN 101 - * Compute a point on the separation line. 102 - IF(ABS(B1*C2-B2*C1).GT.ABS(C1*A2-C2*A1).AND. 103 - - ABS(B1*C2-B2*C1).GT.ABS(A1*B2-A2*B1))THEN 104 - X0=0 105 - Y0=+(D1*C2-D2*C1)/(B1*C2-B2*C1) 106 - Z0=-(D1*B2-D2*B1)/(B1*C2-B2*C1) 107 - ELSEIF(ABS(C1*A2-C2*A1).GT.ABS(A1*B2-A2*B1))THEN 108 - X0=+(D1*C2-D2*C1)/(A1*C2-A2*C1) 109 - Y0=0 110 - Z0=-(D1*A2-D2*A1)/(A1*C2-A2*C1) 111 - ELSE 112 - X0=+(D1*B2-D2*B1)/(A1*B2-A2*B1) 113 - Y0=-(D1*A2-D2*A1)/(A1*B2-A2*B1) 114 - Z0=0 115 - ENDIF 116 - * Establish the parameters along the separation line. 1 263 P=PROJECTI D=PLASEP 3 PAGE 344 117 - AI=B1*C2-C1*B2 118 - BI=C1*A2-A1*C2 119 - CI=A1*B2-B1*A2 120 - FNORM=SQRT(AI**2+BI**2+CI**2) 121 - IF(FNORM.LE.0)THEN 122 - PRINT *,' !!!!!! PLASEP WARNING : Intersect line'// 123 - - ' not found; no separation plane.' 124 - IFAIL=1 125 - RETURN 126 - ENDIF 127 - AI=AI/FNORM 128 - BI=BI/FNORM 129 - CI=CI/FNORM 130 - *** A single point in common. 131 - ELSEIF(NCOM.EQ.1)THEN 132 - * Use the point as reference. 133 - X0=XCOM(1) 134 - Y0=YCOM(1) 135 - Z0=ZCOM(1) 136 - * Still compute the parameters of the separation line. 137 - AI=B1*C2-C1*B2 138 - BI=C1*A2-A1*C2 139 - CI=A1*B2-B1*A2 140 - FNORM=SQRT(AI**2+BI**2+CI**2) 141 - IF(FNORM.LE.0)THEN 142 - PRINT *,' !!!!!! PLASEP WARNING : Intersect line'// 143 - - ' not found; no separation plane.' 144 - IFAIL=1 145 - RETURN 146 - ENDIF 147 - AI=AI/FNORM 148 - BI=BI/FNORM 149 - CI=CI/FNORM 150 - *** Two points in common. 151 - ELSEIF(NCOM.EQ.2)THEN 152 - * Use the first point as reference. 153 - X0=XCOM(1) 154 - Y0=YCOM(1) 155 - Z0=ZCOM(1) 156 - * Compute the separation line from the other point. 157 - AI=XCOM(2)-XCOM(1) 158 - BI=YCOM(2)-YCOM(1) 159 - CI=ZCOM(2)-ZCOM(1) 160 - FNORM=SQRT(AI**2+BI**2+CI**2) 161 - IF(FNORM.LE.0)THEN 162 - PRINT *,' !!!!!! PLASEP WARNING : Intersect line'// 163 - - ' not found; no separation plane.' 164 - IFAIL=1 165 - RETURN 166 - ENDIF 167 - AI=AI/FNORM 168 - BI=BI/FNORM 169 - CI=CI/FNORM 170 - *** More than 2 points in common. 171 - ELSE 172 - * Use the first point as reference. 173 - X0=XCOM(1) 174 - Y0=YCOM(1) 175 - Z0=ZCOM(1) 176 - * Compute the separation line from the other point. 177 - AI=XCOM(2)-XCOM(1) 178 - BI=YCOM(2)-YCOM(1) 179 - CI=ZCOM(2)-ZCOM(1) 180 - FNORM=SQRT(AI**2+BI**2+CI**2) 181 - IF(FNORM.LE.0)THEN 182 - PRINT *,' !!!!!! PLASEP WARNING : Intersect line'// 183 - - ' not found; no separation plane.' 184 - IFAIL=1 185 - RETURN 186 - ENDIF 187 - AI=AI/FNORM 188 - BI=BI/FNORM 189 - CI=CI/FNORM 190 - * See whether the other points are on the line. 191 - DO 200 I=3,NCOM 192 - XL=((XCOM(I)-X0)*AI+(YCOM(I)-Y0)*BI+(ZCOM(I)-Z0)*CI)/FNORM 193 - XC=X0+XL*AI 194 - YC=Y0+XL*BI 195 - ZC=Z0+XL*CI 196 - IF(ABS(XCOM(I)-XC).GT.EPSX.OR. 197 - - ABS(YCOM(I)-YC).GT.EPSY.OR. 198 - - ABS(ZCOM(I)-ZC).GT.EPSZ)THEN 199 - PRINT *,' !!!!!! PLASEP WARNING : Found non-colinear'// 200 - - ' common points; no separation plane.' 201 - IFAIL=1 202 - RETURN 203 - ENDIF 204 - 200 CONTINUE 205 - ENDIF 206 - *** Debugging result. 207 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASEP DEBUG : Point: '', 208 - - 4X,3F12.5/26X,''Direction: '',3F12.5)') X0,Y0,Z0,AI,BI,CI 209 - *** Seems to have worked. 210 - IFAIL=0 211 - END 264 GARFIELD ================================================== P=PROJECTI D=PLARED 1 ============================ 0 + +DECK,PLARED. 1 - SUBROUTINE PLARED(NPL,XPL,YPL,ZPL,A,B,C,D) 2 - *----------------------------------------------------------------------- 3 - * PLARED - Removes duplicate branches from a curve. 4 - * (Last changed on 2/ 2/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 1 264 P=PROJECTI D=PLARED 2 PAGE 345 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9 - INTEGER NPL,I,J,NNEW,JCUT 10 - DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL),EPSX,EPSY, 11 - - XSHIFT,YSHIFT,EPS,A,B,C,D,XMIN,YMIN,XMAX,YMAX 12 - LOGICAL MARK(MXEDGE),ONLIND 13 - EXTERNAL ONLIND 14 - *** Check number of points. 15 - IF(NPL.GT.MXEDGE)THEN 16 - PRINT *,' !!!!!! PLARED WARNING : Too many points.' 17 - RETURN 18 - ELSEIF(NPL.LT.3)THEN 19 - RETURN 20 - ENDIF 21 - *** Set tolerances. 22 - IF(LEPSG)THEN 23 - EPSX=EPSGX 24 - EPSY=EPSGY 25 - ELSE 26 - * Compute range. 27 - XMIN=XPL(1) 28 - XMAX=XPL(1) 29 - YMIN=YPL(1) 30 - YMAX=YPL(1) 31 - DO 90 I=2,NPL 32 - XMIN=MIN(XMIN,XPL(I)) 33 - XMAX=MAX(XMAX,XPL(I)) 34 - YMIN=MIN(YMIN,YPL(I)) 35 - YMAX=MAX(YMAX,YPL(I)) 36 - 90 CONTINUE 37 - * Set epsilons accordingly. 38 - EPSX=1.0D-8*ABS(XMAX-XMIN) 39 - EPSY=1.0D-8*ABS(YMAX-YMIN) 40 - IF(EPSX.LE.0)EPSX=1.0D-8 41 - IF(EPSY.LE.0)EPSY=1.0D-8 42 - ENDIF 43 - *** Make a first marker list. 44 - 100 CONTINUE 45 - DO 10 I=1,NPL 46 - MARK(I)=.FALSE. 47 - 10 CONTINUE 48 - *** Find a point that is surrounded on both side by equal points. 49 - DO 20 I=1,NPL 50 - JCUT=0 51 - DO 30 J=1,NPL/2 52 - IF( ABS(XPL(1+MOD(I+J-1 ,NPL))- 53 - - XPL(1+MOD(I-J-1+NPL,NPL))).GT.EPSX.OR. 54 - - ABS(YPL(1+MOD(I+J-1 ,NPL))- 55 - - YPL(1+MOD(I-J-1+NPL,NPL))).GT.EPSY)GOTO 40 56 - JCUT=J 57 - 30 CONTINUE 58 - 40 CONTINUE 59 - * See whether we found one. 60 - IF(JCUT.GT.0)THEN 61 - C print *,' Cutting a tail of ',JCUT,' points.' 62 - DO 70 J=I-JCUT+1,I+JCUT 63 - MARK(1+MOD(J-1+NPL,NPL))=.TRUE. 64 - 70 CONTINUE 65 - GOTO 50 66 - ENDIF 67 - 20 CONTINUE 68 - *** See whether there are partial returns. 69 - DO 80 I=1,NPL 70 - IF(ONLIND( 71 - - XPL(1+MOD(I-1 ,NPL)),YPL(1+MOD(I-1 ,NPL)), 72 - - XPL(1+MOD(I ,NPL)),YPL(1+MOD(I ,NPL)), 73 - - XPL(1+MOD(I-2+NPL,NPL)),YPL(1+MOD(I-2+NPL,NPL))).OR. 74 - - ONLIND( 75 - - XPL(1+MOD(I-1 ,NPL)),YPL(1+MOD(I-1 ,NPL)), 76 - - XPL(1+MOD(I-2+NPL,NPL)),YPL(1+MOD(I-2+NPL,NPL)), 77 - - XPL(1+MOD(I ,NPL)),YPL(1+MOD(I ,NPL))))THEN 78 - MARK(1+MOD(I-1 ,NPL))=.TRUE. 79 - C print *,' Cutting a partial return.' 80 - GOTO 50 81 - ENDIF 82 - 80 CONTINUE 83 - *** No further cuts, move points which appear twice. 84 - DO 120 I=1,NPL 85 - DO 110 J=I+1,NPL 86 - * Identify the points. 87 - IF(ABS(XPL(I)-XPL(J)).LT.100*EPSX.AND. 88 - - ABS(YPL(I)-YPL(J)).LT.100*EPSY)THEN 89 - * Find the axis along which to displace the points. 90 - XSHIFT=(XPL(1+MOD(I-2+NPL,NPL))+XPL(1+MOD(I,NPL)))/2- 91 - - XPL(I) 92 - YSHIFT=(YPL(1+MOD(I-2+NPL,NPL))+YPL(1+MOD(I,NPL)))/2- 93 - - YPL(I) 94 - IF(SQRT(XSHIFT**2+YSHIFT**2).LE.SQRT(EPSX**2+EPSY**2))THEN 95 - PRINT *,' !!!!!! PLARED WARNING : Curve is too'// 96 - - ' small ; eliminated.' 97 - NPL=0 98 - RETURN 99 - ENDIF 100 - EPS=1000*SQRT(EPSX**2+EPSY**2)/SQRT(XSHIFT**2+YSHIFT**2) 101 - XPL(I)=XPL(I)+XSHIFT*EPS 102 - YPL(I)=YPL(I)+YSHIFT*EPS 103 - ZPL(I)=(D-A*XPL(I)-B*YPL(I))/C 104 - XSHIFT=(XPL(1+MOD(J-2+NPL,NPL))+XPL(1+MOD(J,NPL)))/2- 105 - - XPL(J) 106 - YSHIFT=(YPL(1+MOD(J-2+NPL,NPL))+YPL(1+MOD(J,NPL)))/2- 107 - - YPL(J) 108 - IF(SQRT(XSHIFT**2+YSHIFT**2).LE.SQRT(EPSX**2+EPSY**2))THEN 109 - PRINT *,' !!!!!! PLARED WARNING : Curve is too'// 110 - - ' small ; eliminated.' 111 - NPL=0 112 - RETURN 1 264 P=PROJECTI D=PLARED 3 PAGE 346 113 - ENDIF 114 - EPS=1000*SQRT(EPSX**2+EPSY**2)/SQRT(XSHIFT**2+YSHIFT**2) 115 - XPL(J)=XPL(J)+XSHIFT*EPS 116 - YPL(J)=YPL(J)+YSHIFT*EPS 117 - ZPL(J)=(D-A*XPL(J)-B*YPL(J))/C 118 - C print *,' Shifting a point to avoid overlaps.' 119 - ENDIF 120 - 110 CONTINUE 121 - 120 CONTINUE 122 - RETURN 123 - *** Eliminate the piece. 124 - 50 CONTINUE 125 - NNEW=0 126 - DO 60 I=1,NPL 127 - IF(MARK(I))GOTO 60 128 - NNEW=NNEW+1 129 - XPL(NNEW)=XPL(I) 130 - YPL(NNEW)=YPL(I) 131 - ZPL(NNEW)=ZPL(I) 132 - 60 CONTINUE 133 - NPL=NNEW 134 - GOTO 100 135 - END 265 GARFIELD ================================================== P=PROJECTI D=PLASPL 1 ============================ 0 + +DECK,PLASPL. 1 - SUBROUTINE PLASPL(IREF1,IREF2,NREF,IREFO,KEEP,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * PLASPL - Isolates the parts of plane 1 that are not hidden by 2. 4 - * (Last changed on 29/ 9/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,CONSTANTS. 10.- +SEQ,PARAMETERS. 11 - INTEGER MXCORN 12 - PARAMETER(MXCORN=3*MXEDGE) 13 - DOUBLE PRECISION 14 - - XPL1(MXEDGE),YPL1(MXEDGE),ZPL1(MXEDGE),APL1,BPL1,CPL1,DPL1, 15 - - XPL2(MXEDGE),YPL2(MXEDGE),ZPL2(MXEDGE),APL2,BPL2,CPL2,DPL2, 16 - - XINT,YINT,ZINT,AINT,BINT,CDUM,EPSD, 17 - - XSEPA,YSEPA,XSEPB,YSEPB,XMEAN,YMEAN, 18 - - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), 19 - - XCUT(MXCORN),YCUT(MXCORN),ZCUT(MXCORN), 20 - - XL(MXCORN,3),YL(MXCORN,3),ZL(MXCORN,3), 21 - - Q(MXCORN,3),QMIN,XAUX,YAUX,ZAUX,QAUX, 22 - - XC,YC,ZC,EPSX,EPSY,EPSZ,XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX, 23 - - ZAUX1,ZAUX2,ZAUX3,ZAUX4, 24 - - XMIN1,YMIN1,ZMIN1,XMAX1,YMAX1,ZMAX1, 25 - - XMIN2,YMIN2,ZMIN2,XMAX2,YMAX2,ZMAX2, 26 - - X1,Y1,PHI0,PHI1,PHI2,PHI3,PHI4,PHI5,PHI6,PHIOPT,DX,DY,STEP 27 - INTEGER NPL1,NPL2,IFAIL1,IFAIL2,IFAIL,I,J,K,N1,N2,NS, 28 - - M1,M2,IQMIN,IAUX,IT(MXCORN,3),IREF(MXCORN,3,3), 29 - - NPL,IL,JL,IP,JP,JP2,JP3,NP,IDIR,JDIR,NFOUND,NFOUN1,NFOUN2, 30 - - INITP,INITD,INITL,NCUT,J0,J1,K0,K1,IREFO(MXPLAN), 31 - - IREF1,IREF2,NREF,ICOL1,ICOL2,IR, 32 - - ISIDE0,ISIDE1,ISIDE2,ISIDE3,ISIDE4,ISIDE5,ISIDE6, 33 - - N1L,N1R,N2L,N2R 34 - LOGICAL ADD,INSIDE,IN1,IN2,IN3,IN4,EDGE,EDGE1,EDGE2,EDGE3,EDGE4, 35 - - ONLIND,CROSSD,START,OK,LSEP,MARK1(MXCORN),MARK2(MXCORN), 36 - - SWAP,KEEP,HOLE 37 - EXTERNAL ONLIND,CROSSD 38 - *** Initial setting of the number of produced planes. 39 - NREF=0 40 - *** Retrieve both planes. 41 - CALL PLABU2('READ',IREF1,NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1, 42 - - ICOL1,IFAIL1) 43 - CALL PLABU2('READ',IREF2,NPL2,XPL2,YPL2,ZPL2,APL2,BPL2,CPL2,DPL2, 44 - - ICOL2,IFAIL2) 45 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN 46 - PRINT *,' !!!!!! PLASPL WARNING : Unable to retrieve a'// 47 - - ' projected polygon; skipped.' 48 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASPL DEBUG :''// 49 - - '' Reference numbers: '',2I4)') IREF1,IREF2 50 - IFAIL=1 51 - RETURN 52 - ENDIF 53 - *** If the size of either is 0, simply return. 54 - IF(NPL1.LE.2.OR.NPL2.LE.2)THEN 55 - KEEP=.TRUE. 56 - IFAIL=0 57 - RETURN 58 - ENDIF 59 - * Don't process planes that have no z-component. 60 - IF(CPL1**2.LT.1.0D-6*(APL1**2+BPL1**2).OR.CPL1.EQ.0.OR. 61 - - CPL2**2.LT.1.0D-6*(APL2**2+BPL2**2).OR.CPL2.EQ.0)THEN 62 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASPL DEBUG :''// 63 - - '' No z-component found; return with IFAIL=1.'')') 64 - IFAIL=1 65 - RETURN 66 - ENDIF 67 - *** Don't try to split parallel planes. 68 - IF((BPL1*CPL2-BPL2*CPL1)**2+(CPL1*APL2-CPL2*APL1)**2+ 69 - - (APL1*BPL2-APL2*BPL1)**2.LT. 70 - - 1.0D-4*SQRT((APL1**2+BPL1**2+CPL1**2)* 71 - - (APL2**2+BPL2**2+CPL2**2)))THEN 72 - LSEP=.FALSE. 73 - * Otherwise compute separation plane. 74 - ELSE 75 - CALL PLASEP( 76 - - NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1, 77 - - NPL2,XPL2,YPL2,ZPL2,APL2,BPL2,CPL2,DPL2, 78 - - XINT,YINT,ZINT,AINT,BINT,CDUM,IFAIL1) 79 - IF(IFAIL1.NE.0)THEN 1 265 P=PROJECTI D=PLASPL 2 PAGE 347 80 - PRINT *,' !!!!!! PLASPL WARNING : Unable to compute'// 81 - - ' a separation plane; plot may be incorrect.' 82 - KEEP=.TRUE. 83 - IFAIL=1 84 - RETURN 85 - ENDIF 86 - LSEP=.TRUE. 87 - ENDIF 88 - *** Compute the various tolerances. 89 - EPSD=0 90 - XMIN1=XPL1(1) 91 - YMIN1=YPL1(1) 92 - ZMIN1=ZPL1(1) 93 - XMAX1=XPL1(1) 94 - YMAX1=YPL1(1) 95 - ZMAX1=ZPL1(1) 96 - XMEAN=0 97 - YMEAN=0 98 - DO 10 I=1,NPL1 99 - EPSD=MAX(EPSD,ABS(APL2*XPL1(I)+BPL2*YPL1(I)+CPL2*ZPL1(I))) 100 - XMIN1=MIN(XMIN1,XPL1(I)) 101 - YMIN1=MIN(YMIN1,YPL1(I)) 102 - ZMIN1=MIN(ZMIN1,ZPL1(I)) 103 - XMAX1=MAX(XMAX1,XPL1(I)) 104 - YMAX1=MAX(YMAX1,YPL1(I)) 105 - ZMAX1=MAX(ZMAX1,ZPL1(I)) 106 - XMEAN=XMEAN+XPL1(I) 107 - YMEAN=YMEAN+YPL1(I) 108 - 10 CONTINUE 109 - XMIN2=XPL2(1) 110 - YMIN2=YPL2(1) 111 - ZMIN2=ZPL2(1) 112 - XMAX2=XPL2(1) 113 - YMAX2=YPL2(1) 114 - ZMAX2=ZPL2(1) 115 - DO 20 I=1,NPL2 116 - EPSD=MAX(EPSD,ABS(APL1*XPL2(I)+BPL1*YPL2(I)+CPL1*ZPL2(I))) 117 - XMIN2=MIN(XMIN2,XPL2(I)) 118 - YMIN2=MIN(YMIN2,YPL2(I)) 119 - ZMIN2=MIN(ZMIN2,ZPL2(I)) 120 - XMAX2=MAX(XMAX2,XPL2(I)) 121 - YMAX2=MAX(YMAX2,YPL2(I)) 122 - ZMAX2=MAX(ZMAX2,ZPL2(I)) 123 - XMEAN=XMEAN+XPL2(I) 124 - YMEAN=YMEAN+YPL2(I) 125 - 20 CONTINUE 126 - XMIN=MIN(XMIN1,XMIN2) 127 - YMIN=MIN(YMIN1,YMIN2) 128 - ZMIN=MIN(ZMIN1,ZMIN2) 129 - XMAX=MAX(XMAX1,XMAX2) 130 - YMAX=MAX(YMAX1,YMAX2) 131 - ZMAX=MAX(ZMAX1,ZMAX2) 132 - EPSD=1.0D-6*EPSD 133 - IF(LEPSG)THEN 134 - EPSX=EPSGX 135 - EPSY=EPSGY 136 - EPSZ=EPSGZ 137 - ELSE 138 - EPSX=1.0D-6*MAX(ABS(XMAX),ABS(XMIN)) 139 - EPSY=1.0D-6*MAX(ABS(YMAX),ABS(YMIN)) 140 - EPSZ=1.0D-6*MAX(ABS(ZMAX),ABS(ZMIN)) 141 - ENDIF 142 - XMEAN=XMEAN/DBLE(NPL1+NPL2) 143 - YMEAN=YMEAN/DBLE(NPL1+NPL2) 144 - * Override the z-tolerance. 145 - EPSD=EPSZ 146 - * Debugging output. 147 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASPL DEBUG :'', 148 - - '' Tolerances: x='',E12.5,'', y='',E12.5/38X, 149 - - ''z='',E12.5,'', d='',E12.5)') EPSX,EPSY,EPSZ,EPSD 150 - * If curve 1 is entirely above 2, simply keep. 151 - IF(ZMIN1.GE.ZMAX2)THEN 152 - KEEP=.TRUE. 153 - IFAIL=0 154 - RETURN 155 - * If the curves don't overlap at all, simply keep. 156 - ELSEIF(XMIN1.GE.XMAX2.OR.XMIN2.GE.XMAX1.OR. 157 - - YMIN1.GE.YMAX2.OR.YMIN2.GE.YMAX1)THEN 158 - KEEP=.TRUE. 159 - IFAIL=0 160 - RETURN 161 - * Otherwise, try to eliminate pieces of curve 1. 162 - ELSE 163 - KEEP=.FALSE. 164 - ENDIF 165 - * Compute start and end point of a separation line. 166 - XAUX=ABS(XMAX-XMIN) 167 - XMIN=XMIN-XAUX 168 - XMAX=XMAX+XAUX 169 - YAUX=ABS(YMAX-YMIN) 170 - YMIN=YMIN-YAUX 171 - YMAX=YMAX+YAUX 172 - IF(LSEP.AND.ABS(AINT).GT.ABS(BINT).AND.AINT.NE.0)THEN 173 - XSEPA=XMIN 174 - YSEPA=YINT+(XMIN-XINT)*BINT/AINT 175 - XSEPB=XMAX 176 - YSEPB=YINT+(XMAX-XINT)*BINT/AINT 177 - CALL CLIP2D(XSEPA,YSEPA,XSEPB,YSEPB,XMIN,YMIN,XMAX,YMAX, 178 - - IFAIL1) 179 - IF(IFAIL1.NE.0)THEN 180 - XSEPA=XMAX 181 - YSEPA=YMAX 182 - XSEPB=XMAX 183 - YSEPB=YMAX 184 - ENDIF 185 - ELSEIF(LSEP.AND.BINT.NE.0)THEN 1 265 P=PROJECTI D=PLASPL 3 PAGE 348 186 - XSEPA=XINT+(YMIN-YINT)*AINT/BINT 187 - YSEPA=YMIN 188 - XSEPB=XINT+(YMAX-YINT)*AINT/BINT 189 - YSEPB=YMAX 190 - CALL CLIP2D(XSEPA,YSEPA,XSEPB,YSEPB,XMIN,YMIN,XMAX,YMAX, 191 - - IFAIL1) 192 - IF(IFAIL1.NE.0)THEN 193 - XSEPA=XMAX 194 - YSEPA=YMAX 195 - XSEPB=XMAX 196 - YSEPB=YMAX 197 - ENDIF 198 - ELSE 199 - XSEPA=XMAX 200 - YSEPA=YMAX 201 - XSEPB=XMAX 202 - YSEPB=YMAX 203 - ENDIF 204 - * Show the separation line in debugging mode. 205 - IF(LDEBUG.AND.LSEP)THEN 206 - XPL(1)=XSEPA 207 - YPL(1)=YSEPA 208 - XPL(2)=XSEPB 209 - YPL(2)=YSEPB 210 - CALL GSLN(2) 211 - CALL GSPLCI(8) 212 - CALL GPL2(2,XPL,YPL) 213 - ENDIF 214 - *** Check whether we have to do anything, first non-parallel planes. 215 - IF(LSEP)THEN 216 - N1L=0 217 - N1R=0 218 - N2L=0 219 - N2R=0 220 - DO 30 I=1,NPL1 221 - IF((XPL1(I)-XINT)*BINT-(YPL1(I)-YINT)*AINT.GT.EPSD)THEN 222 - N1L=N1L+1 223 - ELSEIF((XPL1(I)-XINT)*BINT-(YPL1(I)-YINT)*AINT.LT.-EPSD)THEN 224 - N1R=N1R+1 225 - ENDIF 226 - MARK1(I)=.FALSE. 227 - 30 CONTINUE 228 - DO 40 I=1,NPL2 229 - IF((XPL2(I)-XINT)*BINT-(YPL2(I)-YINT)*AINT.GT.EPSD)THEN 230 - N2L=N2L+1 231 - ELSEIF((XPL2(I)-XINT)*BINT-(YPL2(I)-YINT)*AINT.LT.-EPSD)THEN 232 - N2R=N2R+1 233 - ENDIF 234 - MARK2(I)=.FALSE. 235 - 40 CONTINUE 236 - IF((N1L.EQ.0.AND.N2R.EQ.0).OR.(N1R.EQ.0.AND.N2L.EQ.0))THEN 237 - KEEP=.TRUE. 238 - IFAIL=0 239 - RETURN 240 - ELSE 241 - KEEP=.FALSE. 242 - ENDIF 243 - * Next parallel planes. 244 - ELSE 245 - IF((DPL1-APL1*XMEAN-BPL1*YMEAN)/CPL1.GE. 246 - - (DPL2-APL2*XMEAN-BPL2*YMEAN)/CPL2-EPSD)THEN 247 - KEEP=.TRUE. 248 - IFAIL=0 249 - RETURN 250 - ELSE 251 - KEEP=.FALSE. 252 - ENDIF 253 - ENDIF 254 - *** Establish the list of special points around polygon 1. 255 - N1=0 256 - NS=0 257 - OK=.TRUE. 258 - DO 100 I=1,NPL1 259 - * Add the vertex. 260 - IF(N1+1.GT.MXCORN)THEN 261 - PRINT *,' !!!!!! PLASPL WARNING : Too many special'// 262 - - ' points around a polygon ; list reduced.' 263 - OK=.FALSE. 264 - GOTO 150 265 - ENDIF 266 - N1=N1+1 267 - XL(N1,1)=XPL1(I) 268 - YL(N1,1)=YPL1(I) 269 - ZL(N1,1)=ZPL1(I) 270 - IT(N1,1)=1 271 - Q(N1,1)=0 272 - * If also on 2 or vertex of 2, flag it as crossing or foreign. 273 - DO 160 J=1,NPL2 274 - IF(ABS(XPL2(J)-XPL1(I)).LT.EPSX.AND. 275 - - ABS(YPL2(J)-YPL1(I)).LT.EPSY)IT(N1,1)=2 276 - IF(ONLIND(XPL2(1+MOD(J-1,NPL2)),YPL2(1+MOD(J-1,NPL2)), 277 - - XPL2(1+MOD(J ,NPL2)),YPL2(1+MOD(J ,NPL2)), 278 - - XPL1(I ),YPL1(I) ).AND. 279 - - (ABS(XPL2(1+MOD(J-1,NPL2))-XPL1(I)).GT.EPSX.OR. 280 - - ABS(YPL2(1+MOD(J-1,NPL2))-YPL1(I)).GT.EPSY).AND. 281 - - (ABS(XPL2(1+MOD(J ,NPL2))-XPL1(I)).GT.EPSX.OR. 282 - - ABS(YPL2(1+MOD(J ,NPL2))-YPL1(I)).GT.EPSY))IT(N1,1)=3 283 - 160 CONTINUE 284 - * Remember the starting point for the next list. 285 - M1=N1+1 286 - * Preset HOLE to False, i.e. do look for intersect crossings. 287 - HOLE=.FALSE. 288 - * See whether this line segment crosses plane 2. 289 - CALL PLALIN(XPL1(1+MOD(I-1,NPL1)),YPL1(1+MOD(I-1,NPL1)), 290 - - ZPL1(1+MOD(I-1,NPL1)),XPL1(1+MOD(I ,NPL1)), 291 - - YPL1(1+MOD(I ,NPL1)),ZPL1(1+MOD(I ,NPL1)), 1 265 P=PROJECTI D=PLASPL 4 PAGE 349 292 - - XPL2(1),YPL2(1),ZPL2(1),APL2,BPL2,CPL2,XC,YC,ZC,IFAIL1) 293 - IF(IFAIL1.EQ.0.AND. 294 - - (ABS(XPL1(1+MOD(I-1,NPL1))-XC).GT.EPSX.OR. 295 - - ABS(YPL1(1+MOD(I-1,NPL1))-YC).GT.EPSY).AND. 296 - - (ABS(XPL1(1+MOD(I ,NPL1))-XC).GT.EPSX.OR. 297 - - ABS(YPL1(1+MOD(I ,NPL1))-YC).GT.EPSY))THEN 298 - * Shouldn't be a located anywhere on the foreign curve. 299 - CALL INTERD(NPL2,XPL2,YPL2,XC,YC,INSIDE,EDGE) 300 - ADD=.NOT.EDGE 301 - * Add it to the list, if it remains. 302 - IF(ADD)THEN 303 - IF(N1+1.GT.MXCORN)THEN 304 - PRINT *,' !!!!!! PLASPL WARNING : Too many'// 305 - - ' points around a polygon ; list reduced.' 306 - OK=.FALSE. 307 - GOTO 150 308 - ENDIF 309 - N1=N1+1 310 - XL(N1,1)=XC 311 - YL(N1,1)=YC 312 - ZL(N1,1)=ZC 313 - IF(INSIDE)THEN 314 - IT(N1,1)=4 315 - ELSE 316 - IT(N1,1)=5 317 - ENDIF 318 - * If added, don't add the corners to the separation line. 319 - MARK1(1+MOD(I-1,NPL1))=.TRUE. 320 - MARK1(1+MOD(I ,NPL1))=.TRUE. 321 - * Seems to be a hole. 322 - HOLE=.TRUE. 323 - ENDIF 324 - * See whether the point is already in the separation list. 325 - DO 180 J=1,NS 326 - IF(ABS(XC-XL(J,3)).LT.EPSX.AND. 327 - - ABS(YC-YL(J,3)).LT.EPSY)ADD=.FALSE. 328 - 180 CONTINUE 329 - * Add this to the separation points, if not already in it. 330 - IF(ADD)THEN 331 - IF(NS+1.GT.MXCORN)THEN 332 - PRINT *,' !!!!!! PLASPL WARNING : Too many'// 333 - - ' points around a polygon ; list reduced.' 334 - OK=.FALSE. 335 - GOTO 150 336 - ENDIF 337 - NS=NS+1 338 - XL(NS,3)=XC 339 - YL(NS,3)=YC 340 - ZL(NS,3)=ZC 341 - IF(INSIDE.AND..NOT.EDGE)THEN 342 - IT(NS,3)=4 343 - ELSE 344 - IT(NS,3)=5 345 - ENDIF 346 - ENDIF 347 - ENDIF 348 - * Go over the line segments of the other polygon. 349 - DO 110 J=1,NPL2 350 - * Add vertices of 2 that are on this line. 351 - IF(ONLIND(XPL1(1+MOD(I-1,NPL1)),YPL1(1+MOD(I-1,NPL1)), 352 - - XPL1(1+MOD(I,NPL1)),YPL1(1+MOD(I,NPL1)), 353 - - XPL2(J),YPL2(J)).AND. 354 - - (ABS(XPL1(1+MOD(I-1,NPL1))-XPL2(J)).GT.EPSX.OR. 355 - - ABS(YPL1(1+MOD(I-1,NPL1))-YPL2(J)).GT.EPSY).AND. 356 - - (ABS(XPL1(1+MOD(I ,NPL1))-XPL2(J)).GT.EPSX.OR. 357 - - ABS(YPL1(1+MOD(I ,NPL1))-YPL2(J)).GT.EPSY))THEN 358 - IF(N1+1.GT.MXCORN)THEN 359 - PRINT *,' !!!!!! PLASPL WARNING : Too many special'// 360 - - ' points around a polygon ; list reduced.' 361 - OK=.FALSE. 362 - GOTO 150 363 - ENDIF 364 - N1=N1+1 365 - XL(N1,1)=XPL2(J) 366 - YL(N1,1)=YPL2(J) 367 - ZL(N1,1)=(DPL1-APL1*XPL2(J)-BPL1*YPL2(J))/CPL1 368 - IT(N1,1)=2 369 - ENDIF 370 - * Add crossing points. 371 - CALL CRSPND( 372 - - XPL1(1+MOD(I-1,NPL1)),YPL1(1+MOD(I-1,NPL1)), 373 - - XPL1(1+MOD(I ,NPL1)),YPL1(1+MOD(I ,NPL1)), 374 - - XPL2(1+MOD(J-1,NPL2)),YPL2(1+MOD(J-1,NPL2)), 375 - - XPL2(1+MOD(J ,NPL2)),YPL2(1+MOD(J ,NPL2)), 376 - - XC,YC,ADD) 377 - IF(ADD)THEN 378 - IF((ABS(XPL1(1+MOD(I-1,NPL1))-XC).LT.EPSX.AND. 379 - - ABS(YPL1(1+MOD(I-1,NPL1))-YC).LT.EPSY).OR. 380 - - (ABS(XPL1(1+MOD(I ,NPL1))-XC).LT.EPSX.AND. 381 - - ABS(YPL1(1+MOD(I ,NPL1))-YC).LT.EPSY))ADD=.FALSE. 382 - IF((ABS(XPL2(1+MOD(J-1,NPL2))-XC).LT.EPSX.AND. 383 - - ABS(YPL2(1+MOD(J-1,NPL2))-YC).LT.EPSY).OR. 384 - - (ABS(XPL2(1+MOD(J ,NPL2))-XC).LT.EPSX.AND. 385 - - ABS(YPL2(1+MOD(J ,NPL2))-YC).LT.EPSY))ADD=.FALSE. 386 - IF((ABS(XPL1(1+MOD(I-1,NPL1))- 387 - - XPL2(1+MOD(J-1,NPL2))).LT.EPSX.AND. 388 - - ABS(YPL1(1+MOD(I-1,NPL1))- 389 - - YPL2(1+MOD(J-1,NPL2))).LT.EPSY).OR. 390 - - (ABS(XPL1(1+MOD(I-1,NPL1))- 391 - - XPL2(1+MOD(J ,NPL2))).LT.EPSX.AND. 392 - - ABS(YPL1(1+MOD(I-1,NPL1))- 393 - - YPL2(1+MOD(J ,NPL2))).LT.EPSY).OR. 394 - - (ABS(XPL1(1+MOD(I ,NPL1))- 395 - - XPL2(1+MOD(J-1,NPL2))).LT.EPSX.AND. 396 - - ABS(YPL1(1+MOD(I ,NPL1))- 397 - - YPL2(1+MOD(J-1,NPL2))).LT.EPSY).OR. 1 265 P=PROJECTI D=PLASPL 5 PAGE 350 398 - - (ABS(XPL1(1+MOD(I-1,NPL1))- 399 - - XPL2(1+MOD(J-1,NPL2))).LT.EPSX.AND. 400 - - ABS(YPL1(1+MOD(I-1,NPL1))- 401 - - YPL2(1+MOD(J-1,NPL2))).LT.EPSY))ADD=.FALSE. 402 - ENDIF 403 - IF(ADD)THEN 404 - IF(N1+1.GT.MXCORN)THEN 405 - PRINT *,' !!!!!! PLASPL WARNING : Too many special'// 406 - - ' points around a polygon ; list reduced.' 407 - OK=.FALSE. 408 - GOTO 150 409 - ENDIF 410 - N1=N1+1 411 - XL(N1,1)=XC 412 - YL(N1,1)=YC 413 - ZL(N1,1)=(DPL1-APL1*XC-BPL1*YC)/CPL1 414 - IT(N1,1)=3 415 - ENDIF 416 - * Perhaps also add to the separation list. 417 - IF(ADD.AND.ONLIND(XSEPA,YSEPA,XSEPB,YSEPB,XC,YC))THEN 418 - IF(NS+1.GT.MXCORN)THEN 419 - PRINT *,' !!!!!! PLASPL WARNING : Too many special'// 420 - - ' points around a polygon ; list reduced.' 421 - OK=.FALSE. 422 - GOTO 150 423 - ENDIF 424 - NS=NS+1 425 - XL(NS,3)=XC 426 - YL(NS,3)=YC 427 - ZL(NS,3)=(DPL1-APL1*XC-BPL1*YC)/CPL1 428 - IT(NS,3)=3 429 - ENDIF 430 - 110 CONTINUE 431 - * See whether this segment crosses the separation line. 432 - IF(.NOT.HOLE)THEN 433 - CALL CRSPND( 434 - - XPL1(1+MOD(I-1,NPL1)),YPL1(1+MOD(I-1,NPL1)), 435 - - XPL1(1+MOD(I ,NPL1)),YPL1(1+MOD(I ,NPL1)), 436 - - XSEPA,YSEPA,XSEPB,YSEPB,XC,YC,ADD) 437 - IF(ADD)THEN 438 - IF((ABS(XPL1(1+MOD(I-1,NPL1))-XC).LT.EPSX.AND. 439 - - ABS(YPL1(1+MOD(I-1,NPL1))-YC).LT.EPSY).OR. 440 - - (ABS(XPL1(1+MOD(I ,NPL1))-XC).LT.EPSX.AND. 441 - - ABS(YPL1(1+MOD(I ,NPL1))-YC).LT.EPSY))ADD=.FALSE. 442 - ENDIF 443 - IF(ADD)THEN 444 - DO 195 J=1,NPL2 445 - IF(ABS(XC-XPL2(J)).LT.EPSX.AND. 446 - - ABS(YC-YPL2(J)).LT.EPSY)ADD=.FALSE. 447 - 195 CONTINUE 448 - ENDIF 449 - IF(ADD)THEN 450 - ADD=.TRUE. 451 - DO 190 J=M1,N1 452 - IF(ABS(XC-XL(J,1)).LT.EPSX.AND. 453 - - ABS(YC-YL(J,1)).LT.EPSY)ADD=.FALSE. 454 - 190 CONTINUE 455 - IF(ADD)THEN 456 - IF(N1+1.GT.MXCORN)THEN 457 - PRINT *,' !!!!!! PLASPL WARNING : Too many'// 458 - - ' special points around a polygon ;'// 459 - - ' list reduced.' 460 - OK=.FALSE. 461 - GOTO 150 462 - ENDIF 463 - N1=N1+1 464 - XL(N1,1)=XC 465 - YL(N1,1)=YC 466 - ZL(N1,1)=(DPL1-APL1*XC-BPL1*YC)/CPL1 467 - IT(N1,1)=1 468 - ENDIF 469 - ADD=.TRUE. 470 - DO 170 J=1,NS 471 - IF(ABS(XC-XL(J,3)).LT.EPSX.AND. 472 - - ABS(YC-YL(J,3)).LT.EPSY)ADD=.FALSE. 473 - 170 CONTINUE 474 - IF(ADD)THEN 475 - IF(NS+1.GT.MXCORN)THEN 476 - PRINT *,' !!!!!! PLASPL WARNING : Too many'// 477 - - ' special points around a polygon ;'// 478 - - ' list reduced.' 479 - OK=.FALSE. 480 - GOTO 150 481 - ENDIF 482 - NS=NS+1 483 - XL(NS,3)=XC 484 - YL(NS,3)=YC 485 - ZL(NS,3)=(DPL1-APL1*XC-BPL1*YC)/CPL1 486 - IT(NS,3)=1 487 - ENDIF 488 - ENDIF 489 - ENDIF 490 - * Compute the lambda's for these points. 491 - DO 120 J=M1,N1 492 - CALL PLALAM(XPL1(1+MOD(I-1,NPL1)),XL(J,1),XPL1(1+MOD(I,NPL1)), 493 - - YPL1(1+MOD(I-1,NPL1)),YL(J,1),YPL1(1+MOD(I,NPL1)),Q(J,1)) 494 - 120 CONTINUE 495 - * Sort the list by using the lambda's. 496 - DO 140 J=M1,N1 497 - QMIN=Q(J,1) 498 - IQMIN=J 499 - DO 130 K=J+1,N1 500 - IF(Q(K,1).LT.QMIN)THEN 501 - IQMIN=K 502 - QMIN=Q(K,1) 503 - ENDIF 1 265 P=PROJECTI D=PLASPL 6 PAGE 351 504 - 130 CONTINUE 505 - IF(J.NE.IQMIN)THEN 506 - XAUX=XL(J,1) 507 - YAUX=YL(J,1) 508 - ZAUX=ZL(J,1) 509 - QAUX=Q (J,1) 510 - IAUX=IT(J,1) 511 - XL(J,1)=XL(IQMIN,1) 512 - YL(J,1)=YL(IQMIN,1) 513 - ZL(J,1)=ZL(IQMIN,1) 514 - Q (J,1)=Q (IQMIN,1) 515 - IT(J,1)=IT(IQMIN,1) 516 - XL(IQMIN,1)=XAUX 517 - YL(IQMIN,1)=YAUX 518 - ZL(IQMIN,1)=ZAUX 519 - Q (IQMIN,1)=QAUX 520 - IT(IQMIN,1)=IAUX 521 - ENDIF 522 - 140 CONTINUE 523 - * Next vertex. 524 - 100 CONTINUE 525 - *** Establish the list of special points around polygon 2. 526 - 150 CONTINUE 527 - N2=0 528 - DO 200 I=1,NPL2 529 - * Add the vertex. 530 - IF(N2+1.GT.MXCORN)THEN 531 - PRINT *,' !!!!!! PLASPL WARNING : Too many special'// 532 - - ' points around a polygon ; list reduced.' 533 - OK=.FALSE. 534 - GOTO 250 535 - ENDIF 536 - N2=N2+1 537 - XL(N2,2)=XPL2(I) 538 - YL(N2,2)=YPL2(I) 539 - ZL(N2,2)=ZPL2(I) 540 - IT(N2,2)=1 541 - Q(N2,2)=0 542 - * If also on 1 or a vertex of 1, flag it as crossing or foreign. 543 - DO 260 J=1,NPL1 544 - IF(ABS(XPL1(J)-XPL2(I)).LT.EPSX.AND. 545 - - ABS(YPL1(J)-YPL2(I)).LT.EPSY)IT(N2,2)=2 546 - IF(ONLIND(XPL1(1+MOD(J-1,NPL1)),YPL1(1+MOD(J-1,NPL1)), 547 - - XPL1(1+MOD(J ,NPL1)),YPL1(1+MOD(J ,NPL1)), 548 - - XPL2(I ),YPL2(I) ).AND. 549 - - (ABS(XPL1(1+MOD(J-1,NPL1))-XPL2(I)).GT.EPSX.OR. 550 - - ABS(YPL1(1+MOD(J-1,NPL1))-YPL2(I)).GT.EPSY).AND. 551 - - (ABS(XPL1(1+MOD(J ,NPL1))-XPL2(I)).GT.EPSX.OR. 552 - - ABS(YPL1(1+MOD(J ,NPL1))-YPL2(I)).GT.EPSY))IT(N2,2)=3 553 - 260 CONTINUE 554 - * Remember the starting point for the next list. 555 - M2=N2+1 556 - * See whether this line segment crosses plane 1. 557 - CALL PLALIN(XPL2(1+MOD(I-1,NPL2)),YPL2(1+MOD(I-1,NPL2)), 558 - - ZPL2(1+MOD(I-1,NPL2)),XPL2(1+MOD(I ,NPL2)), 559 - - YPL2(1+MOD(I ,NPL2)),ZPL2(1+MOD(I ,NPL2)), 560 - - XPL1(1),YPL1(1),ZPL1(1),APL1,BPL1,CPL1,XC,YC,ZC,IFAIL1) 561 - IF(IFAIL1.EQ.0.AND. 562 - - (ABS(XPL2(1+MOD(I-1,NPL2))-XC).GT.EPSX.OR. 563 - - ABS(YPL2(1+MOD(I-1,NPL2))-YC).GT.EPSY).AND. 564 - - (ABS(XPL2(1+MOD(I ,NPL2))-XC).GT.EPSX.OR. 565 - - ABS(YPL2(1+MOD(I ,NPL2))-YC).GT.EPSY))THEN 566 - * Shouldn't be a located anywhere on the foreign curve. 567 - CALL INTERD(NPL1,XPL1,YPL1,XC,YC,INSIDE,EDGE) 568 - ADD=.NOT.EDGE 569 - * Add this point to the list if not a vertex. 570 - IF(ADD)THEN 571 - IF(N2+1.GT.MXCORN)THEN 572 - PRINT *,' !!!!!! PLASPL WARNING : Too many'// 573 - - ' points around a polygon ; list reduced.' 574 - OK=.FALSE. 575 - GOTO 250 576 - ENDIF 577 - N2=N2+1 578 - XL(N2,2)=XC 579 - YL(N2,2)=YC 580 - ZL(N2,2)=ZC 581 - IF(INSIDE)THEN 582 - IT(N2,2)=4 583 - ELSE 584 - IT(N2,2)=5 585 - ENDIF 586 - * If added, don't add the corners to the separation line. 587 - MARK2(1+MOD(I-1,NPL2))=.TRUE. 588 - MARK2(1+MOD(I ,NPL2))=.TRUE. 589 - ENDIF 590 - * See whether the point is already in the separation list. 591 - DO 280 J=1,NS 592 - IF(ABS(XC-XL(J,3)).LT.EPSX.AND. 593 - - ABS(YC-YL(J,3)).LT.EPSY)ADD=.FALSE. 594 - 280 CONTINUE 595 - * Add this to the separation points, if not already in it. 596 - IF(ADD)THEN 597 - IF(NS+1.GT.MXCORN)THEN 598 - PRINT *,' !!!!!! PLASPL WARNING : Too many'// 599 - - ' points around a polygon ; list reduced.' 600 - OK=.FALSE. 601 - GOTO 250 602 - ENDIF 603 - NS=NS+1 604 - XL(NS,3)=XC 605 - YL(NS,3)=YC 606 - ZL(NS,3)=ZC 607 - IF(INSIDE)THEN 608 - IT(NS,3)=4 609 - ELSE 1 265 P=PROJECTI D=PLASPL 7 PAGE 352 610 - IT(NS,3)=5 611 - ENDIF 612 - ENDIF 613 - ENDIF 614 - * Go over the line segments of the other polygon. 615 - DO 210 J=1,NPL1 616 - * Add vertices of 1 that are on this line. 617 - IF(ONLIND(XPL2(1+MOD(I-1,NPL2)),YPL2(1+MOD(I-1,NPL2)), 618 - - XPL2(1+MOD(I,NPL2)),YPL2(1+MOD(I,NPL2)), 619 - - XPL1(J),YPL1(J)).AND. 620 - - (ABS(XPL2(1+MOD(I-1,NPL2))-XPL1(J)).GT.EPSX.OR. 621 - - ABS(YPL2(1+MOD(I-1,NPL2))-YPL1(J)).GT.EPSY).AND. 622 - - (ABS(XPL2(1+MOD(I ,NPL2))-XPL1(J)).GT.EPSX.OR. 623 - - ABS(YPL2(1+MOD(I ,NPL2))-YPL1(J)).GT.EPSY))THEN 624 - IF(N2+1.GT.MXCORN)THEN 625 - PRINT *,' !!!!!! PLASPL WARNING : Too many special'// 626 - - ' points around a polygon ; list reduced.' 627 - OK=.FALSE. 628 - GOTO 250 629 - ENDIF 630 - N2=N2+1 631 - XL(N2,2)=XPL1(J) 632 - YL(N2,2)=YPL1(J) 633 - ZL(N2,2)=(DPL2-APL2*XPL1(J)-BPL2*YPL1(J))/CPL2 634 - IT(N2,2)=2 635 - ENDIF 636 - * Add crossing points. 637 - CALL CRSPND( 638 - - XPL2(1+MOD(I-1,NPL2)),YPL2(1+MOD(I-1,NPL2)), 639 - - XPL2(1+MOD(I ,NPL2)),YPL2(1+MOD(I ,NPL2)), 640 - - XPL1(1+MOD(J-1,NPL1)),YPL1(1+MOD(J-1,NPL1)), 641 - - XPL1(1+MOD(J ,NPL1)),YPL1(1+MOD(J ,NPL1)), 642 - - XC,YC,ADD) 643 - IF(ADD)THEN 644 - IF((ABS(XPL2(1+MOD(I-1,NPL2))-XC).LT.EPSX.AND. 645 - - ABS(YPL2(1+MOD(I-1,NPL2))-YC).LT.EPSY).OR. 646 - - (ABS(XPL2(1+MOD(I,NPL2))-XC).LT.EPSX.AND. 647 - - ABS(YPL2(1+MOD(I,NPL2))-YC).LT.EPSY))ADD=.FALSE. 648 - IF((ABS(XPL1(1+MOD(J-1,NPL1))-XC).LT.EPSX.AND. 649 - - ABS(YPL1(1+MOD(J-1,NPL1))-YC).LT.EPSY).OR. 650 - - (ABS(XPL1(1+MOD(J,NPL1))-XC).LT.EPSX.AND. 651 - - ABS(YPL1(1+MOD(J,NPL1))-YC).LT.EPSY))ADD=.FALSE. 652 - IF((ABS(XPL1(1+MOD(J-1,NPL1))- 653 - - XPL2(1+MOD(I-1,NPL2))).LT.EPSX.AND. 654 - - ABS(YPL1(1+MOD(J-1,NPL1))- 655 - - YPL2(1+MOD(I-1,NPL2))).LT.EPSY).OR. 656 - - (ABS(XPL1(1+MOD(J-1,NPL1))- 657 - - XPL2(1+MOD(I ,NPL2))).LT.EPSX.AND. 658 - - ABS(YPL1(1+MOD(J-1,NPL1))- 659 - - YPL2(1+MOD(I ,NPL2))).LT.EPSY).OR. 660 - - (ABS(XPL1(1+MOD(J ,NPL1))- 661 - - XPL2(1+MOD(I-1,NPL2))).LT.EPSX.AND. 662 - - ABS(YPL1(1+MOD(J ,NPL1))- 663 - - YPL2(1+MOD(I-1,NPL2))).LT.EPSY).OR. 664 - - (ABS(XPL1(1+MOD(J-1,NPL1))- 665 - - XPL2(1+MOD(I-1,NPL2))).LT.EPSX.AND. 666 - - ABS(YPL1(1+MOD(J-1,NPL1))- 667 - - YPL2(1+MOD(I-1,NPL2))).LT.EPSY))ADD=.FALSE. 668 - ENDIF 669 - IF(ADD)THEN 670 - IF(N2+1.GT.MXCORN)THEN 671 - PRINT *,' !!!!!! PLASPL WARNING : Too many special'// 672 - - ' points around a polygon ; list reduced.' 673 - OK=.FALSE. 674 - GOTO 250 675 - ENDIF 676 - N2=N2+1 677 - XL(N2,2)=XC 678 - YL(N2,2)=YC 679 - ZL(N2,2)=(DPL2-APL2*XC-BPL2*YC)/CPL2 680 - IT(N2,2)=3 681 - ENDIF 682 - 210 CONTINUE 683 - * Compute the lambda's for these points. 684 - DO 220 J=M2,N2 685 - CALL PLALAM(XPL2(1+MOD(I-1,NPL2)),XL(J,2),XPL2(1+MOD(I,NPL2)), 686 - - YPL2(1+MOD(I-1,NPL2)),YL(J,2),YPL2(1+MOD(I,NPL2)),Q(J,2)) 687 - 220 CONTINUE 688 - * Sort the list by using the lambda's. 689 - DO 240 J=M2,N2 690 - QMIN=Q(J,2) 691 - IQMIN=J 692 - DO 230 K=J+1,N2 693 - IF(Q(K,2).LT.QMIN)THEN 694 - IQMIN=K 695 - QMIN=Q(K,2) 696 - ENDIF 697 - 230 CONTINUE 698 - IF(J.NE.IQMIN)THEN 699 - XAUX=XL(J,2) 700 - YAUX=YL(J,2) 701 - ZAUX=ZL(J,2) 702 - QAUX=Q (J,2) 703 - IAUX=IT(J,2) 704 - XL(J,2)=XL(IQMIN,2) 705 - YL(J,2)=YL(IQMIN,2) 706 - ZL(J,2)=ZL(IQMIN,2) 707 - Q (J,2)=Q (IQMIN,2) 708 - IT(J,2)=IT(IQMIN,2) 709 - XL(IQMIN,2)=XAUX 710 - YL(IQMIN,2)=YAUX 711 - ZL(IQMIN,2)=ZAUX 712 - Q (IQMIN,2)=QAUX 713 - IT(IQMIN,2)=IAUX 714 - ENDIF 715 - 240 CONTINUE 1 265 P=PROJECTI D=PLASPL 8 PAGE 353 716 - * Next vertex. 717 - 200 CONTINUE 718 - *** Establish the list of special points along the separation line. 719 - 250 CONTINUE 720 - * Add the vertices of plane 1 that are on the separation line. 721 - DO 300 I=1,NPL1 722 - IF(.NOT.MARK1(I).AND. 723 - - ONLIND(XSEPA,YSEPA,XSEPB,YSEPB,XPL1(I),YPL1(I)))THEN 724 - IF(NS+1.GT.MXCORN)THEN 725 - PRINT *,' !!!!!! PLASPL WARNING : Too many special'// 726 - - ' points along separation ; list reduced.' 727 - OK=.FALSE. 728 - GOTO 350 729 - ENDIF 730 - NS=NS+1 731 - XL(NS,3)=XPL1(I) 732 - YL(NS,3)=YPL1(I) 733 - ZL(NS,3)=ZPL1(I) 734 - IT(NS,3)=1 735 - ENDIF 736 - 300 CONTINUE 737 - * Add the vertices of plane 2 which are not also vertices of 1. 738 - DO 310 I=1,NPL2 739 - DO 360 J=1,NPL1 740 - IF(ABS(XPL2(I)-XPL1(J)).LT.EPSX.AND. 741 - - ABS(YPL2(I)-YPL1(J)).LT.EPSY)GOTO 310 742 - 360 CONTINUE 743 - IF(.NOT.MARK2(I).AND. 744 - - ONLIND(XSEPA,YSEPA,XSEPB,YSEPB,XPL2(I),YPL2(I)))THEN 745 - IF(NS+1.GT.MXCORN)THEN 746 - PRINT *,' !!!!!! PLASPL WARNING : Too many special'// 747 - - ' points along separation ; list reduced.' 748 - OK=.FALSE. 749 - GOTO 350 750 - ENDIF 751 - NS=NS+1 752 - XL(NS,3)=XPL2(I) 753 - YL(NS,3)=YPL2(I) 754 - ZL(NS,3)=ZPL2(I) 755 - CALL INTERD(NPL1,XPL1,YPL1,XPL2(I),YPL2(I),INSIDE,EDGE) 756 - IF(EDGE)THEN 757 - IT(NS,3)=1 758 - ELSE 759 - IT(NS,3)=2 760 - ENDIF 761 - ENDIF 762 - 310 CONTINUE 763 - * Compute the lambda's for these points. 764 - DO 320 I=1,NS 765 - CALL PLALAM(XSEPA,XL(I,3),XSEPB,YSEPA,YL(I,3),YSEPB,Q(I,3)) 766 - 320 CONTINUE 767 - * Sort the list by using the lambda's. 768 - DO 340 J=1,NS 769 - QMIN=Q(J,3) 770 - IQMIN=J 771 - DO 330 K=J+1,NS 772 - IF(Q(K,3).LT.QMIN)THEN 773 - IQMIN=K 774 - QMIN=Q(K,3) 775 - ENDIF 776 - 330 CONTINUE 777 - IF(J.NE.IQMIN)THEN 778 - XAUX=XL(J,3) 779 - YAUX=YL(J,3) 780 - ZAUX=ZL(J,3) 781 - QAUX=Q (J,3) 782 - IAUX=IT(J,3) 783 - XL(J,3)=XL(IQMIN,3) 784 - YL(J,3)=YL(IQMIN,3) 785 - ZL(J,3)=ZL(IQMIN,3) 786 - Q (J,3)=Q (IQMIN,3) 787 - IT(J,3)=IT(IQMIN,3) 788 - XL(IQMIN,3)=XAUX 789 - YL(IQMIN,3)=YAUX 790 - ZL(IQMIN,3)=ZAUX 791 - Q (IQMIN,3)=QAUX 792 - IT(IQMIN,3)=IAUX 793 - ENDIF 794 - 340 CONTINUE 795 - *** Look up the cross-links. 796 - 350 CONTINUE 797 - ** Links from plane 1 to plane 2. 798 - DO 500 I=1,N1 799 - IREF(I,1,1)=I 800 - NFOUND=0 801 - IREF(I,1,2)=0 802 - DO 510 J=1,N2 803 - IF(ABS(XL(I,1)-XL(J,2)).LT.EPSX.AND. 804 - - ABS(YL(I,1)-YL(J,2)).LT.EPSY)THEN 805 - NFOUND=NFOUND+1 806 - IREF(I,1,2)=J 807 - ENDIF 808 - 510 CONTINUE 809 - IF(NFOUND.EQ.0.AND.(IT(I,1).EQ.2.OR.IT(I,1).EQ.3))THEN 810 - PRINT *,' !!!!!! PLASPL WARNING : Expected match not'// 811 - - ' found (1-2)' 812 - OK=.FALSE. 813 - IREF(I,1,2)=0 814 - ELSEIF(NFOUND.GT.1)THEN 815 - PRINT *,' !!!!!! PLASPL WARNING : More than 1 match'// 816 - - ' found (1-2).' 817 - OK=.FALSE. 818 - IREF(I,1,2)=0 819 - ENDIF 820 - * Links from plane 1 to the separation line. 821 - NFOUND=0 1 265 P=PROJECTI D=PLASPL 9 PAGE 354 822 - IREF(I,1,3)=0 823 - DO 530 J=1,NS 824 - IF(ABS(XL(I,1)-XL(J,3)).LT.EPSX.AND. 825 - - ABS(YL(I,1)-YL(J,3)).LT.EPSY)THEN 826 - NFOUND=NFOUND+1 827 - IREF(I,1,3)=J 828 - ENDIF 829 - 530 CONTINUE 830 - IF(NFOUND.EQ.0.AND.(IT(I,1).EQ.4.OR.IT(I,1).EQ.5))THEN 831 - PRINT *,' !!!!!! PLASPL WARNING : Expected match not'// 832 - - ' found (1-S).' 833 - OK=.FALSE. 834 - IREF(I,1,3)=0 835 - ELSEIF(NFOUND.GT.1)THEN 836 - PRINT *,' !!!!!! PLASPL WARNING : More than 1 match'// 837 - - ' found (1-S).' 838 - OK=.FALSE. 839 - IREF(I,1,3)=0 840 - ENDIF 841 - 500 CONTINUE 842 - ** Links from plane 2 to plane 1. 843 - DO 540 I=1,N2 844 - IREF(I,2,2)=I 845 - NFOUND=0 846 - IREF(I,2,1)=0 847 - DO 550 J=1,N1 848 - IF(ABS(XL(I,2)-XL(J,1)).LT.EPSX.AND. 849 - - ABS(YL(I,2)-YL(J,1)).LT.EPSY)THEN 850 - NFOUND=NFOUND+1 851 - IREF(I,2,1)=J 852 - ENDIF 853 - 550 CONTINUE 854 - IF(NFOUND.EQ.0.AND.(IT(I,2).EQ.2.OR.IT(I,2).EQ.3))THEN 855 - PRINT *,' !!!!!! PLASPL WARNING : Expected match not'// 856 - - ' found (2-1).' 857 - OK=.FALSE. 858 - IREF(I,2,1)=0 859 - ELSEIF(NFOUND.GT.1)THEN 860 - PRINT *,' !!!!!! PLASPL WARNING : More than 1 match'// 861 - - ' found (2-1).' 862 - OK=.FALSE. 863 - IREF(I,2,1)=0 864 - ENDIF 865 - * Links from plane 2 to the separation line. 866 - NFOUND=0 867 - IREF(I,2,3)=0 868 - DO 560 J=1,NS 869 - IF(ABS(XL(I,2)-XL(J,3)).LT.EPSX.AND. 870 - - ABS(YL(I,2)-YL(J,3)).LT.EPSY)THEN 871 - NFOUND=NFOUND+1 872 - IREF(I,2,3)=J 873 - ENDIF 874 - 560 CONTINUE 875 - IF(NFOUND.EQ.0.AND.(IT(I,2).EQ.4.OR.IT(I,2).EQ.5))THEN 876 - PRINT *,' !!!!!! PLASPL WARNING : Expected match not'// 877 - - ' found (2-S).' 878 - OK=.FALSE. 879 - IREF(I,2,3)=0 880 - ELSEIF(NFOUND.GT.1)THEN 881 - PRINT *,' !!!!!! PLASPL WARNING : More than 1 match'// 882 - - ' found (2-S).' 883 - OK=.FALSE. 884 - IREF(I,2,3)=0 885 - ENDIF 886 - 540 CONTINUE 887 - ** Links from the separation line to planes 1 and 2. 888 - DO 570 I=1,NS 889 - IREF(I,3,3)=I 890 - NFOUN1=0 891 - IREF(I,3,1)=0 892 - DO 580 J=1,N1 893 - IF(ABS(XL(I,3)-XL(J,1)).LT.EPSX.AND. 894 - - ABS(YL(I,3)-YL(J,1)).LT.EPSY)THEN 895 - NFOUN1=NFOUN1+1 896 - IREF(I,3,1)=J 897 - ENDIF 898 - 580 CONTINUE 899 - IREF(I,3,2)=0 900 - NFOUN2=0 901 - DO 590 J=1,N2 902 - IF(ABS(XL(I,3)-XL(J,2)).LT.EPSX.AND. 903 - - ABS(YL(I,3)-YL(J,2)).LT.EPSY)THEN 904 - NFOUN2=NFOUN2+1 905 - IREF(I,3,2)=J 906 - ENDIF 907 - 590 CONTINUE 908 - IF(NFOUN1.EQ.0.AND.NFOUN2.EQ.0)THEN 909 - PRINT *,' !!!!!! PLASPL WARNING : Expected match not'// 910 - - ' found (S-1,2).' 911 - OK=.FALSE. 912 - IREF(I,3,1)=0 913 - IREF(I,3,2)=0 914 - ELSEIF(NFOUN1.GT.1.OR.NFOUN2.GT.1)THEN 915 - PRINT *,' !!!!!! PLASPL WARNING : More than 1 match'// 916 - - ' found (S-1,2).' 917 - OK=.FALSE. 918 - IREF(I,3,1)=0 919 - IREF(I,3,2)=0 920 - ENDIF 921 - 570 CONTINUE 922 - * List the points for debugging. 923 - IF(LDEBUG)THEN 924 - DO 610 J=1,3 925 - WRITE(LUNOUT,'('' ++++++ PLASPL DEBUG : Polygon '',I1, 926 - - '':''/'' No Type x y'', 927 - - '' z Q links'')') J 1 265 P=PROJECTI D=PLASPL 10 PAGE 355 928 - CALL GSMK(2) 929 - IF(J.EQ.1)THEN 930 - NP=N1 931 - CALL GSMK(2) 932 - ELSEIF(J.EQ.2)THEN 933 - NP=N2 934 - CALL GSMK(4) 935 - ELSEIF(J.EQ.3)THEN 936 - NP=NS 937 - CALL GSMK(5) 938 - ENDIF 939 - DO 600 I=1,NP 940 - WRITE(LUNOUT,'(2X,I3,I5,3F13.6,F10.3,3I3)') I,IT(I,J), 941 - - XL(I,J),YL(I,J),ZL(I,J),Q(I,J),(IREF(I,J,K),K=1,3) 942 - CALL GPM2(1,XL(I,J),YL(I,J)) 943 - 600 CONTINUE 944 - C call testtest(np,xl(1,J),yl(1,j),zl(1,j)) 945 - 610 CONTINUE 946 - ENDIF 947 - *** If a mistake was found, simply draw the curve. 948 - IF(.NOT.OK)THEN 949 - PRINT *,' !!!!!! PLASPL WARNING : No further processing'// 950 - - ' because of the above errors ; please report.' 951 - LGSIG=.TRUE. 952 - DO 2020 I=1,NREF 953 - CALL PLABU2('DELETE',IREFO(I),NPL1,XPL1,YPL1,ZPL1, 954 - - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) 955 - 2020 CONTINUE 956 - NREF=0 957 - IFAIL=1 958 - KEEP=.TRUE. 959 - RETURN 960 - ENDIF 961 - *** Draw the visible part of 1, first locate visible points. 962 - DO 400 I=1,N1 963 - IF(IREF(I,1,3).NE.0)THEN 964 - MARK1(I)=.TRUE. 965 - ELSEIF(IT(I,1).EQ.1)THEN 966 - CALL INTERD(NPL2,XPL2,YPL2,XL(I,1),YL(I,1),INSIDE,EDGE) 967 - IF(INSIDE.OR.EDGE)THEN 968 - IF((DPL1-APL1*XL(I,1)-BPL1*YL(I,1))/CPL1.GE. 969 - - (DPL2-APL2*XL(I,1)-BPL2*YL(I,1))/CPL2)THEN 970 - MARK1(I)=.FALSE. 971 - ELSE 972 - MARK1(I)=.TRUE. 973 - ENDIF 974 - ELSE 975 - MARK1(I)=.FALSE. 976 - ENDIF 977 - ELSE 978 - MARK1(I)=.FALSE. 979 - ENDIF 980 - 400 CONTINUE 981 - *** Resume from here for the next piece of curve. 982 - 410 CONTINUE 983 - *** Find a point that still hasn't been marked. 984 - DO 420 I=1,N1 985 - * Skip points that are marked. 986 - C if(MARK1(i))print *,' Search skips point ',i,' (marked)' 987 - IF(MARK1(I))GOTO 420 988 - * Set reference variables. 989 - IP=I 990 - IL=1 991 - * See which side of the surve is visible. 992 - CALL INTERD(NPL2,XPL2,YPL2, 993 - - 0.5*(XL(IP,IL)+XL(1+MOD(IP,N1),IL)), 994 - - 0.5*(YL(IP,IL)+YL(1+MOD(IP,N1),IL)),IN1,EDGE1) 995 - ZAUX1=(DPL1- 996 - - APL1*0.5*(XL(IP,IL)+XL(1+MOD(IP,N1),IL))- 997 - - BPL1*0.5*(YL(IP,IL)+YL(1+MOD(IP,N1),IL)))/CPL1 998 - ZAUX2=(DPL2- 999 - - APL2*0.5*(XL(IP,IL)+XL(1+MOD(IP,N1),IL))- 1000 - - BPL2*0.5*(YL(IP,IL)+YL(1+MOD(IP,N1),IL)))/CPL2 1001 - CALL INTERD(NPL2,XPL2,YPL2, 1002 - - 0.5*(XL(IP,IL)+XL(1+MOD(IP-2+N1,N1),IL)), 1003 - - 0.5*(YL(IP,IL)+YL(1+MOD(IP-2+N1,N1),IL)),IN2,EDGE2) 1004 - ZAUX3=(DPL1- 1005 - - APL1*0.5*(XL(IP,IL)+XL(1+MOD(IP-2+N1,N1),IL))- 1006 - - BPL1*0.5*(YL(IP,IL)+YL(1+MOD(IP-2+N1,N1),IL)))/CPL1 1007 - ZAUX4=(DPL2- 1008 - - APL2*0.5*(XL(IP,IL)+XL(1+MOD(IP-2+N1,N1),IL))- 1009 - - BPL2*0.5*(YL(IP,IL)+YL(1+MOD(IP-2+N1,N1),IL)))/CPL2 1010 - * Find the direction in which to move. 1011 - IF(.NOT.(IN1.OR.EDGE1))THEN 1012 - IDIR=+1 1013 - ELSEIF(.NOT.(IN2.OR.EDGE2))THEN 1014 - IDIR=-1 1015 - ELSEIF(ZAUX1.GT.ZAUX2+EPSD)THEN 1016 - IDIR=+1 1017 - ELSEIF(ZAUX3.GT.ZAUX4+EPSD)THEN 1018 - IDIR=-1 1019 - ELSE 1020 - C print *,' Search skips point ',i,' (no visible way out)' 1021 - MARK1(I)=.TRUE. 1022 - GOTO 410 1023 - ENDIF 1024 - * Leave the loop, we found a point. 1025 - GOTO 440 1026 - 420 CONTINUE 1027 - *** No point found anymore, continue with the cut-outs. 1028 - GOTO 1000 1029 - *** Initial settings for the curve. 1030 - 440 CONTINUE 1031 - INITP=IP 1032 - INITD=IDIR 1033 - INITL=IL 1 265 P=PROJECTI D=PLASPL 11 PAGE 356 1034 - XPL(1)=XL(IP,1) 1035 - YPL(1)=YL(IP,1) 1036 - ZPL(1)=ZL(IP,1) 1037 - MARK1(IP)=.TRUE. 1038 - IP=1+MOD(IP+IDIR-1+N1,N1) 1039 - NPL=1 1040 - START=.TRUE. 1041 - IF(LDEBUG)WRITE(LUNOUT,'('' Starting from list '',I3, 1042 - - '' point '',I3,'' direction '',I2)') INITL,INITP,INITD 1043 - ** Make a step along the edges. 1044 - 430 CONTINUE 1045 - IF(IL.EQ.1.AND.IDIR.NE.INITD)THEN 1046 - PRINT *,' !!!!!! PLASPL WARNING : Change in direction on'// 1047 - - ' main curve ; abandoned.' 1048 - DO 2040 I=1,NREF 1049 - CALL PLABU2('DELETE',IREFO(I),NPL1,XPL1,YPL1,ZPL1, 1050 - - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) 1051 - 2040 CONTINUE 1052 - NREF=0 1053 - KEEP=.TRUE. 1054 - IFAIL=1 1055 - LGSIG=.TRUE. 1056 - RETURN 1057 - ENDIF 1058 - *** See whether we are back where we started. 1059 - IF((.NOT.START).AND. 1060 - - ABS(XL(IP,IL)-XL(INITP,INITL)).LT.EPSX.AND. 1061 - - ABS(YL(IP,IL)-YL(INITP,INITL)).LT.EPSY)THEN 1062 - * Store the plane. 1063 - IF(NREF+1.LE.MXPLAN)THEN 1064 - CALL PLARED(NPL,XPL,YPL,ZPL,APL1,BPL1,CPL1,DPL1) 1065 - IF(NPL.GE.3)THEN 1066 - NREF=NREF+1 1067 - CALL PLABU2('STORE',IREFO(NREF),NPL,XPL,YPL,ZPL, 1068 - - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) 1069 - IF(IFAIL1.NE.0)THEN 1070 - PRINT *,' !!!!!! PLASPL WARNING : Unable'// 1071 - - ' to store a plane ; plot probably'// 1072 - - ' incomplete.' 1073 - NREF=NREF-1 1074 - ENDIF 1075 - ENDIF 1076 - ELSE 1077 - PRINT *,' !!!!!! PLASPL WARNING : Unable to store'// 1078 - - ' a plane ; plot probably incomplete.' 1079 - ENDIF 1080 - * And resume search. 1081 - GOTO 410 1082 - ENDIF 1083 - *** Now we have really started. 1084 - START=.FALSE. 1085 - * Mark the current point if we're in plane 1. 1086 - IF(IREF(IP,IL,1).NE.0)MARK1(IREF(IP,IL,1))=.TRUE. 1087 - * Set the number of points in the current list. 1088 - IF(IL.EQ.1)THEN 1089 - NP=N1 1090 - ELSEIF(IL.EQ.2)THEN 1091 - NP=N2 1092 - ELSE 1093 - NP=NS 1094 - ENDIF 1095 - * Add this point to the list if there still is room. 1096 - IF(NPL+1.GT.MXEDGE)THEN 1097 - PRINT *,' !!!!!! PLASPL WARNING : Curve exceeds maximum'// 1098 - - ' length ; truncated.' 1099 - LGSIG=.TRUE. 1100 - DO 2010 I=1,NREF 1101 - CALL PLABU2('DELETE',IREFO(I),NPL1,XPL1,YPL1,ZPL1, 1102 - - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) 1103 - 2010 CONTINUE 1104 - NREF=0 1105 - KEEP=.TRUE. 1106 - IFAIL=1 1107 - RETURN 1108 - ENDIF 1109 - IF(NPL.GE.2)THEN 1110 - IF(.NOT.ONLIND(XPL(NPL-1),YPL(NPL-1),XL(IP,IL),YL(IP,IL), 1111 - - XPL(NPL),YPL(NPL)))NPL=NPL+1 1112 - ELSE 1113 - NPL=NPL+1 1114 - ENDIF 1115 - XPL(NPL)=XL(IP,IL) 1116 - YPL(NPL)=YL(IP,IL) 1117 - ZPL(NPL)=(DPL1-APL1*XL(IP,IL)-BPL1*YL(IP,IL))/CPL1 1118 - ** In debugging mode, print where we are now. 1119 - IF(LDEBUG)WRITE(LUNOUT,'('' Currently at list '',I3, 1120 - - '' point '',I3,'' direction '',I2,'' type '',I1)') 1121 - - IL,IP,IDIR,IT(IP,IL) 1122 - ** If a private vertex, simply move on. 1123 - IF(IT(IP,IL).EQ.1.AND.IL.NE.3)THEN 1124 - IF(LDEBUG)WRITE(LUNOUT,'('' Own vertex.'')') 1125 - IP=1+MOD(IP+IDIR-1+NP,NP) 1126 - GOTO 430 1127 - ** If this is a triple intersect. 1128 - ELSEIF(IREF(IP,IL,1).NE.0.AND.IREF(IP,IL,2).NE.0.AND. 1129 - - IREF(IP,IL,3).NE.0)THEN 1130 - IF(LDEBUG)WRITE(LUNOUT,'('' Triple intersect, list 1: '', 1131 - - I3,'', list 2: '',I3,'' list 3: '',I3)') 1132 - - IREF(IP,IL,1),IREF(IP,IL,2),IREF(IP,IL,3) 1133 - * Step size check, also used for side determination. 1134 - STEP=SQRT( 1135 - - (XL(1+MOD(IP-IDIR-1+NP,NP),IL)-XL(IP,IL))**2+ 1136 - - (YL(1+MOD(IP-IDIR-1+NP,NP),IL)-YL(IP,IL))**2) 1137 - IF(STEP.LE.0.OR. 1138 - - (IL.EQ.3.AND.IP.EQ. 1.AND.IDIR.EQ.+1).OR. 1139 - - (IL.EQ.3.AND.IP.EQ.NP.AND.IDIR.EQ.-1))THEN 1 265 P=PROJECTI D=PLASPL 12 PAGE 357 1140 - PRINT *,' !!!!!! PLASPL WARNING : Not a valid'// 1141 - - ' step into crossing ; skipped.' 1142 - LGSIG=.TRUE. 1143 - IP=1+MOD(IP+IDIR-1+NP,NP) 1144 - GOTO 1200 1145 - ENDIF 1146 - * Compute the incidence angle. 1147 - PHI0=ATAN2( 1148 - - YL(1+MOD(IP-IDIR-1+NP,NP),IL)-YL(IP,IL), 1149 - - XL(1+MOD(IP-IDIR-1+NP,NP),IL)-XL(IP,IL)) 1150 - * See on which side of this line we enter into 1. 1151 - X1= (XL(1+MOD(IP-IDIR-1+NP,NP),IL)+XL(IP,IL))/2 1152 - Y1= (YL(1+MOD(IP-IDIR-1+NP,NP),IL)+YL(IP,IL))/2 1153 - DO 1210 K=3,10 1154 - DX=-(YL(1+MOD(IP-IDIR-1+NP,NP),IL)-YL(IP,IL))* 1155 - - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP 1156 - DY=+(XL(1+MOD(IP-IDIR-1+NP,NP),IL)-XL(IP,IL))* 1157 - - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP 1158 - CALL INTERD(NPL1,XPL1,YPL1,X1+DX,Y1+DY,IN1,EDGE1) 1159 - CALL INTERD(NPL1,XPL1,YPL1,X1-DX,Y1-DY,IN2,EDGE2) 1160 - IF((IN1.OR.IN2).AND..NOT.(EDGE1.OR.EDGE2))THEN 1161 - CALL INTERD(NPL2,XPL2,YPL2,X1+DX,Y1+DY,IN3,EDGE3) 1162 - ZAUX1=(DPL1-APL1*(X1+DX)-BPL1*(Y1+DY))/CPL1 1163 - ZAUX2=(DPL2-APL2*(X1+DX)-BPL2*(Y1+DY))/CPL2 1164 - CALL INTERD(NPL2,XPL2,YPL2,X1-DX,Y1-DY,IN4,EDGE4) 1165 - ZAUX3=(DPL1-APL1*(X1-DX)-BPL1*(Y1-DY))/CPL1 1166 - ZAUX4=(DPL2-APL2*(X1-DX)-BPL2*(Y1-DY))/CPL2 1167 - IF(IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. 1168 - - ZAUX1.GT.ZAUX2-EPSD))THEN 1169 - ISIDE0=+1 1170 - ELSEIF(IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. 1171 - - ZAUX3.GT.ZAUX4-EPSD))THEN 1172 - ISIDE0=-1 1173 - ELSE 1174 - PRINT *,' !!!!!! PLASPL WARNING : Line does'// 1175 - - ' not seem to follow a visible part of'// 1176 - - ' plane 1 ; skipped.' 1177 - DO 2030 I=1,NREF 1178 - CALL PLABU2('DELETE',IREFO(I), 1179 - - NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1, 1180 - - ICOL1,IFAIL1) 1181 - 2030 CONTINUE 1182 - NREF=0 1183 - IFAIL=1 1184 - KEEP=.TRUE. 1185 - ENDIF 1186 - GOTO 1220 1187 - ENDIF 1188 - 1210 CONTINUE 1189 - PRINT *,' !!!!!! PLASPL WARNING : Line doesn''t seem'// 1190 - - ' to follow plane 1 ; abandoning overlap test.' 1191 - LGSIG=.TRUE. 1192 - DO 2000 I=1,NREF 1193 - CALL PLABU2('DELETE',IREFO(I),NPL1,XPL1,YPL1,ZPL1, 1194 - - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) 1195 - 2000 CONTINUE 1196 - NREF=0 1197 - KEEP=.TRUE. 1198 - IFAIL=0 1199 - RETURN 1200 - 1220 CONTINUE 1201 - * Check each branch for angle and 1-side, start with plane 1-. 1202 - JP=IREF(IP,IL,1) 1203 - * Compute the incidence angle. 1204 - PHI1=MOD(ATAN2( 1205 - - YL(1+MOD(JP-2+N1,N1),1)-YL(IP,IL), 1206 - - XL(1+MOD(JP-2+N1,N1),1)-XL(IP,IL))-PHI0,2.0D0*PI) 1207 - IF(PHI1.LT.-PI)PHI1=PHI1+2.0D0*PI 1208 - IF(PHI1.GT.+PI)PHI1=PHI1-2.0D0*PI 1209 - IF(ISIDE0.EQ.+1.AND.PHI1.LT.0)PHI1=PHI1+2.0D0*PI 1210 - IF(ISIDE0.EQ.-1.AND.PHI1.GT.0)PHI1=PHI1-2.0D0*PI 1211 - * See on which side of this line we enter visibly into 1. 1212 - X1= (XL(1+MOD(JP-2+N1,N1),1)+XL(IP,IL))/2 1213 - Y1= (YL(1+MOD(JP-2+N1,N1),1)+YL(IP,IL))/2 1214 - STEP=SQRT( 1215 - - (XL(1+MOD(JP-2+N1,N1),1)-XL(IP,IL))**2+ 1216 - - (YL(1+MOD(JP-2+N1,N1),1)-YL(IP,IL))**2) 1217 - DO 1230 K=3,10 1218 - DX=-(YL(1+MOD(JP-2+N1,N1),1)-YL(IP,IL))* 1219 - - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP 1220 - DY=+(XL(1+MOD(JP-2+N1,N1),1)-XL(IP,IL))* 1221 - - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP 1222 - CALL INTERD(NPL1,XPL1,YPL1,X1+DX,Y1+DY,IN1,EDGE1) 1223 - CALL INTERD(NPL1,XPL1,YPL1,X1-DX,Y1-DY,IN2,EDGE2) 1224 - CALL INTERD(NPL2,XPL2,YPL2,X1+DX,Y1+DY,IN3,EDGE3) 1225 - CALL INTERD(NPL2,XPL2,YPL2,X1-DX,Y1-DY,IN4,EDGE4) 1226 - IF(IN1.AND..NOT.(EDGE1.OR.IN2.OR.EDGE2))THEN 1227 - ZAUX1=(DPL1-APL1*(X1+DX)-BPL1*(Y1+DY))/CPL1 1228 - ZAUX2=(DPL2-APL2*(X1+DX)-BPL2*(Y1+DY))/CPL2 1229 - IF(.NOT.(IN3.OR.EDGE3).OR.ZAUX1.GT.ZAUX2-EPSD)THEN 1230 - ISIDE1=+1 1231 - ELSE 1232 - ISIDE1=0 1233 - ENDIF 1234 - GOTO 1240 1235 - ELSEIF(IN2.AND..NOT.(EDGE2.OR.IN1.OR.EDGE1))THEN 1236 - ZAUX1=(DPL1-APL1*(X1-DX)-BPL1*(Y1-DY))/CPL1 1237 - ZAUX2=(DPL2-APL2*(X1-DX)-BPL2*(Y1-DY))/CPL2 1238 - IF(.NOT.(IN4.OR.EDGE4).OR.ZAUX1.GT.ZAUX2-EPSD)THEN 1239 - ISIDE1=-1 1240 - ELSE 1241 - ISIDE1=0 1242 - ENDIF 1243 - GOTO 1240 1244 - ENDIF 1245 - 1230 CONTINUE 1 265 P=PROJECTI D=PLASPL 13 PAGE 358 1246 - ISIDE1=0 1247 - 1240 CONTINUE 1248 - * Verify whether this branch is at all visible. 1249 - CALL INTERD(NPL2,XPL2,YPL2,X1,Y1,IN1,EDGE1) 1250 - ZAUX1=(DPL1-APL1*X1-BPL1*Y1)/CPL1 1251 - ZAUX2=(DPL2-APL2*X1-BPL2*Y1)/CPL2 1252 - IF((IN1.OR.EDGE1).AND.ZAUX1.LT.ZAUX2-EPSD)ISIDE1=0 1253 - * Check plane 1+, compute the incidence angle. 1254 - PHI2=MOD(ATAN2( 1255 - - YL(1+MOD(JP,N1),1)-YL(IP,IL), 1256 - - XL(1+MOD(JP,N1),1)-XL(IP,IL))-PHI0,2.0D0*PI) 1257 - IF(PHI2.LT.-PI)PHI2=PHI2+2.0D0*PI 1258 - IF(PHI2.GT.+PI)PHI2=PHI2-2.0D0*PI 1259 - IF(ISIDE0.EQ.+1.AND.PHI2.LT.0)PHI2=PHI2+2.0D0*PI 1260 - IF(ISIDE0.EQ.-1.AND.PHI2.GT.0)PHI2=PHI2-2.0D0*PI 1261 - * See on which side of this line we enter visibly into 1. 1262 - X1= (XL(1+MOD(JP,N1),1)+XL(IP,IL))/2 1263 - Y1= (YL(1+MOD(JP,N1),1)+YL(IP,IL))/2 1264 - STEP=SQRT( 1265 - - (XL(1+MOD(JP,N1),1)-XL(IP,IL))**2+ 1266 - - (YL(1+MOD(JP,N1),1)-YL(IP,IL))**2) 1267 - DO 1250 K=3,10 1268 - DX=-(YL(1+MOD(JP,N1),1)-YL(IP,IL))* 1269 - - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP 1270 - DY=+(XL(1+MOD(JP,N1),1)-XL(IP,IL))* 1271 - - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP 1272 - CALL INTERD(NPL1,XPL1,YPL1,X1+DX,Y1+DY,IN1,EDGE1) 1273 - CALL INTERD(NPL1,XPL1,YPL1,X1-DX,Y1-DY,IN2,EDGE2) 1274 - CALL INTERD(NPL2,XPL2,YPL2,X1+DX,Y1+DY,IN3,EDGE3) 1275 - CALL INTERD(NPL2,XPL2,YPL2,X1-DX,Y1-DY,IN4,EDGE4) 1276 - IF(IN1.AND..NOT.(EDGE1.OR.IN2.OR.EDGE2))THEN 1277 - ZAUX1=(DPL1-APL1*(X1+DX)-BPL1*(Y1+DY))/CPL1 1278 - ZAUX2=(DPL2-APL2*(X1+DX)-BPL2*(Y1+DY))/CPL2 1279 - IF(.NOT.(IN3.OR.EDGE3).OR.ZAUX1.GT.ZAUX2-EPSD)THEN 1280 - ISIDE2=+1 1281 - ELSE 1282 - ISIDE2=0 1283 - ENDIF 1284 - GOTO 1260 1285 - ELSEIF(IN2.AND..NOT.(EDGE2.OR.IN1.OR.EDGE1))THEN 1286 - ZAUX1=(DPL1-APL1*(X1-DX)-BPL1*(Y1-DY))/CPL1 1287 - ZAUX2=(DPL2-APL2*(X1-DX)-BPL2*(Y1-DY))/CPL2 1288 - IF(.NOT.(IN4.OR.EDGE4).OR.ZAUX1.GT.ZAUX2-EPSD)THEN 1289 - ISIDE2=-1 1290 - ELSE 1291 - ISIDE2=0 1292 - ENDIF 1293 - GOTO 1260 1294 - ENDIF 1295 - 1250 CONTINUE 1296 - ISIDE2=0 1297 - 1260 CONTINUE 1298 - * Verify whether this branch is at all visible. 1299 - CALL INTERD(NPL2,XPL2,YPL2,X1,Y1,IN1,EDGE1) 1300 - ZAUX1=(DPL1-APL1*X1-BPL1*Y1)/CPL1 1301 - ZAUX2=(DPL2-APL2*X1-BPL2*Y1)/CPL2 1302 - IF((IN1.OR.EDGE1).AND.ZAUX1.LT.ZAUX2-EPSD)ISIDE2=0 1303 - * Plane 2-. 1304 - JP=IREF(IP,IL,2) 1305 - * Compute the incidence angle. 1306 - PHI3=MOD(ATAN2( 1307 - - YL(1+MOD(JP-2+N2,N2),2)-YL(IP,IL), 1308 - - XL(1+MOD(JP-2+N2,N2),2)-XL(IP,IL))-PHI0,2.0D0*PI) 1309 - IF(PHI3.LT.-PI)PHI3=PHI3+2.0D0*PI 1310 - IF(PHI3.GT.+PI)PHI3=PHI3-2.0D0*PI 1311 - IF(ISIDE0.EQ.+1.AND.PHI3.LT.0)PHI3=PHI3+2.0D0*PI 1312 - IF(ISIDE0.EQ.-1.AND.PHI3.GT.0)PHI3=PHI3-2.0D0*PI 1313 - * See on which side of this line we enter visibly into 1. 1314 - X1= (XL(1+MOD(JP-2+N2,N2),2)+XL(IP,IL))/2 1315 - Y1= (YL(1+MOD(JP-2+N2,N2),2)+YL(IP,IL))/2 1316 - STEP=SQRT( 1317 - - (XL(1+MOD(JP-2+N2,N2),2)-XL(IP,IL))**2+ 1318 - - (YL(1+MOD(JP-2+N2,N2),2)-YL(IP,IL))**2) 1319 - DO 1270 K=3,10 1320 - DX=-(YL(1+MOD(JP-2+N2,N2),2)-YL(IP,IL))* 1321 - - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP 1322 - DY=+(XL(1+MOD(JP-2+N2,N2),2)-XL(IP,IL))* 1323 - - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP 1324 - CALL INTERD(NPL1,XPL1,YPL1,X1+DX,Y1+DY,IN1,EDGE1) 1325 - CALL INTERD(NPL1,XPL1,YPL1,X1-DX,Y1-DY,IN2,EDGE2) 1326 - IF((IN1.OR.IN2).AND..NOT.(EDGE1.OR.EDGE2))THEN 1327 - CALL INTERD(NPL2,XPL2,YPL2,X1+DX,Y1+DY,IN3,EDGE3) 1328 - ZAUX1=(DPL1-APL1*(X1+DX)-BPL1*(Y1+DY))/CPL1 1329 - ZAUX2=(DPL2-APL2*(X1+DX)-BPL2*(Y1+DY))/CPL2 1330 - CALL INTERD(NPL2,XPL2,YPL2,X1-DX,Y1-DY,IN4,EDGE4) 1331 - ZAUX3=(DPL1-APL1*(X1-DX)-BPL1*(Y1-DY))/CPL1 1332 - ZAUX4=(DPL2-APL2*(X1-DX)-BPL2*(Y1-DY))/CPL2 1333 - IF((IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. 1334 - - ZAUX1.GT.ZAUX2-EPSD)).AND. 1335 - - (IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. 1336 - - ZAUX3.GT.ZAUX4-EPSD)))THEN 1337 - ISIDE3=2 1338 - ELSEIF(IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. 1339 - - ZAUX1.GT.ZAUX2-EPSD))THEN 1340 - ISIDE3=+1 1341 - ELSEIF(IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. 1342 - - ZAUX3.GT.ZAUX4-EPSD))THEN 1343 - ISIDE3=-1 1344 - ELSE 1345 - ISIDE3=0 1346 - ENDIF 1347 - GOTO 1280 1348 - ENDIF 1349 - 1270 CONTINUE 1350 - ISIDE3=0 1351 - 1280 CONTINUE 1 265 P=PROJECTI D=PLASPL 14 PAGE 359 1352 - * Verify whether this branch is at all visible. 1353 - ZAUX1=(DPL1-APL1*X1-BPL1*Y1)/CPL1 1354 - ZAUX2=(DPL2-APL2*X1-BPL2*Y1)/CPL2 1355 - IF(ZAUX2.LT.ZAUX1-EPSD)ISIDE3=0 1356 - * Check plane 2+, compute the incidence angle. 1357 - PHI4=MOD(ATAN2( 1358 - - YL(1+MOD(JP,N2),2)-YL(IP,IL), 1359 - - XL(1+MOD(JP,N2),2)-XL(IP,IL))-PHI0,2.0D0*PI) 1360 - IF(PHI4.LT.-PI)PHI4=PHI4+2.0D0*PI 1361 - IF(PHI4.GT.+PI)PHI4=PHI4-2.0D0*PI 1362 - IF(ISIDE0.EQ.+1.AND.PHI4.LT.0)PHI4=PHI4+2.0D0*PI 1363 - IF(ISIDE0.EQ.-1.AND.PHI4.GT.0)PHI4=PHI4-2.0D0*PI 1364 - * See on which side of this line we enter visibly into 1. 1365 - X1= (XL(1+MOD(JP,N2),2)+XL(IP,IL))/2 1366 - Y1= (YL(1+MOD(JP,N2),2)+YL(IP,IL))/2 1367 - STEP=SQRT( 1368 - - (XL(1+MOD(JP,N2),2)-XL(IP,IL))**2+ 1369 - - (YL(1+MOD(JP,N2),2)-YL(IP,IL))**2) 1370 - DO 1290 K=3,10 1371 - DX=-(YL(1+MOD(JP,N2),2)-YL(IP,IL))* 1372 - - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP 1373 - DY=+(XL(1+MOD(JP,N2),2)-XL(IP,IL))* 1374 - - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP 1375 - CALL INTERD(NPL1,XPL1,YPL1,X1+DX,Y1+DY,IN1,EDGE1) 1376 - CALL INTERD(NPL1,XPL1,YPL1,X1-DX,Y1-DY,IN2,EDGE2) 1377 - IF((IN1.OR.IN2).AND..NOT.(EDGE1.OR.EDGE2))THEN 1378 - CALL INTERD(NPL2,XPL2,YPL2,X1+DX,Y1+DY,IN3,EDGE3) 1379 - ZAUX1=(DPL1-APL1*(X1+DX)-BPL1*(Y1+DY))/CPL1 1380 - ZAUX2=(DPL2-APL2*(X1+DX)-BPL2*(Y1+DY))/CPL2 1381 - CALL INTERD(NPL2,XPL2,YPL2,X1-DX,Y1-DY,IN4,EDGE4) 1382 - ZAUX3=(DPL1-APL1*(X1-DX)-BPL1*(Y1-DY))/CPL1 1383 - ZAUX4=(DPL2-APL2*(X1-DX)-BPL2*(Y1-DY))/CPL2 1384 - IF((IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. 1385 - - ZAUX1.GT.ZAUX2-EPSD)).AND. 1386 - - (IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. 1387 - - ZAUX3.GT.ZAUX4-EPSD)))THEN 1388 - ISIDE4=2 1389 - ELSEIF(IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. 1390 - - ZAUX1.GT.ZAUX2-EPSD))THEN 1391 - ISIDE4=+1 1392 - ELSEIF(IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. 1393 - - ZAUX3.GT.ZAUX4-EPSD))THEN 1394 - ISIDE4=-1 1395 - ELSE 1396 - ISIDE4=0 1397 - ENDIF 1398 - GOTO 1300 1399 - ENDIF 1400 - 1290 CONTINUE 1401 - ISIDE4=0 1402 - 1300 CONTINUE 1403 - * Verify whether this branch is at all visible. 1404 - ZAUX1=(DPL1-APL1*X1-BPL1*Y1)/CPL1 1405 - ZAUX2=(DPL2-APL2*X1-BPL2*Y1)/CPL2 1406 - IF(ZAUX2.LT.ZAUX1-EPSD)ISIDE4=0 1407 - * Check separation line - side. 1408 - JP=IREF(IP,IL,3) 1409 - * Make sure we are at all allowed to go in this direction. 1410 - IF(JP.LE.1)THEN 1411 - ISIDE5=0 1412 - PHI5=3*PI 1413 - GOTO 1320 1414 - ENDIF 1415 - * Compute the incidence angle. 1416 - PHI5=MOD(ATAN2( 1417 - - YL(1+MOD(JP-2+NS,NS),3)-YL(IP,IL), 1418 - - XL(1+MOD(JP-2+NS,NS),3)-XL(IP,IL))-PHI0,2.0D0*PI) 1419 - IF(PHI5.LT.-PI)PHI5=PHI5+2.0D0*PI 1420 - IF(PHI5.GT.+PI)PHI5=PHI5-2.0D0*PI 1421 - IF(ISIDE0.EQ.+1.AND.PHI5.LT.0)PHI5=PHI5+2.0D0*PI 1422 - IF(ISIDE0.EQ.-1.AND.PHI5.GT.0)PHI5=PHI5-2.0D0*PI 1423 - * See on which side of this line we enter visibly into 1. 1424 - X1= (XL(1+MOD(JP-2+NS,NS),3)+XL(IP,IL))/2 1425 - Y1= (YL(1+MOD(JP-2+NS,NS),3)+YL(IP,IL))/2 1426 - STEP=SQRT( 1427 - - (XL(1+MOD(JP-2+NS,NS),3)-XL(IP,IL))**2+ 1428 - - (YL(1+MOD(JP-2+NS,NS),3)-YL(IP,IL))**2) 1429 - DO 1310 K=3,10 1430 - DX=-(YL(1+MOD(JP-2+NS,NS),3)-YL(IP,IL))* 1431 - - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP 1432 - DY=+(XL(1+MOD(JP-2+NS,NS),3)-XL(IP,IL))* 1433 - - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP 1434 - CALL INTERD(NPL1,XPL1,YPL1,X1+DX,Y1+DY,IN1,EDGE1) 1435 - CALL INTERD(NPL1,XPL1,YPL1,X1-DX,Y1-DY,IN2,EDGE2) 1436 - IF((IN1.OR.IN2).AND..NOT.(EDGE1.OR.EDGE2))THEN 1437 - CALL INTERD(NPL2,XPL2,YPL2,X1+DX,Y1+DY,IN3,EDGE3) 1438 - ZAUX1=(DPL1-APL1*(X1+DX)-BPL1*(Y1+DY))/CPL1 1439 - ZAUX2=(DPL2-APL2*(X1+DX)-BPL2*(Y1+DY))/CPL2 1440 - CALL INTERD(NPL2,XPL2,YPL2,X1-DX,Y1-DY,IN4,EDGE4) 1441 - ZAUX3=(DPL1-APL1*(X1-DX)-BPL1*(Y1-DY))/CPL1 1442 - ZAUX4=(DPL2-APL2*(X1-DX)-BPL2*(Y1-DY))/CPL2 1443 - IF((IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. 1444 - - ZAUX1.GT.ZAUX2-EPSD)).AND. 1445 - - (IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. 1446 - - ZAUX3.GT.ZAUX4-EPSD)))THEN 1447 - ISIDE5=2 1448 - ELSEIF(IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. 1449 - - ZAUX1.GT.ZAUX2-EPSD))THEN 1450 - ISIDE5=+1 1451 - ELSEIF(IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. 1452 - - ZAUX3.GT.ZAUX4-EPSD))THEN 1453 - ISIDE5=-1 1454 - ELSE 1455 - ISIDE5=0 1456 - ENDIF 1457 - GOTO 1320 1 265 P=PROJECTI D=PLASPL 15 PAGE 360 1458 - ENDIF 1459 - 1310 CONTINUE 1460 - ISIDE5=0 1461 - 1320 CONTINUE 1462 - * Separation line, + side, can we go in this direction. 1463 - IF(JP.GE.NS)THEN 1464 - ISIDE6=0 1465 - PHI6=3*PI 1466 - GOTO 1340 1467 - ENDIF 1468 - * Compute the incidence angle. 1469 - PHI6=MOD(ATAN2( 1470 - - YL(1+MOD(JP,NS),3)-YL(IP,IL), 1471 - - XL(1+MOD(JP,NS),3)-XL(IP,IL))-PHI0,2.0D0*PI) 1472 - IF(PHI6.LT.-PI)PHI6=PHI6+2.0D0*PI 1473 - IF(PHI6.GT.+PI)PHI6=PHI6-2.0D0*PI 1474 - IF(ISIDE0.EQ.+1.AND.PHI6.LT.0)PHI6=PHI6+2.0D0*PI 1475 - IF(ISIDE0.EQ.-1.AND.PHI6.GT.0)PHI6=PHI6-2.0D0*PI 1476 - * See on which side of this line we enter visibly into 1. 1477 - X1= (XL(1+MOD(JP,NS),3)+XL(IP,IL))/2 1478 - Y1= (YL(1+MOD(JP,NS),3)+YL(IP,IL))/2 1479 - STEP=SQRT( 1480 - - (XL(1+MOD(JP,NS),3)-XL(IP,IL))**2+ 1481 - - (YL(1+MOD(JP,NS),3)-YL(IP,IL))**2) 1482 - DO 1330 K=3,10 1483 - DX=-(YL(1+MOD(JP,NS),3)-YL(IP,IL))* 1484 - - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP 1485 - DY=+(XL(1+MOD(JP,NS),3)-XL(IP,IL))* 1486 - - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP 1487 - CALL INTERD(NPL1,XPL1,YPL1,X1+DX,Y1+DY,IN1,EDGE1) 1488 - CALL INTERD(NPL1,XPL1,YPL1,X1-DX,Y1-DY,IN2,EDGE2) 1489 - IF((IN1.OR.IN2).AND..NOT.(EDGE1.OR.EDGE2))THEN 1490 - CALL INTERD(NPL2,XPL2,YPL2,X1+DX,Y1+DY,IN3,EDGE3) 1491 - ZAUX1=(DPL1-APL1*(X1+DX)-BPL1*(Y1+DY))/CPL1 1492 - ZAUX2=(DPL2-APL2*(X1+DX)-BPL2*(Y1+DY))/CPL2 1493 - CALL INTERD(NPL2,XPL2,YPL2,X1-DX,Y1-DY,IN4,EDGE4) 1494 - ZAUX3=(DPL1-APL1*(X1-DX)-BPL1*(Y1-DY))/CPL1 1495 - ZAUX4=(DPL2-APL2*(X1-DX)-BPL2*(Y1-DY))/CPL2 1496 - IF((IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. 1497 - - ZAUX1.GT.ZAUX2-EPSD)).AND. 1498 - - (IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. 1499 - - ZAUX3.GT.ZAUX4-EPSD)))THEN 1500 - ISIDE6=2 1501 - ELSEIF(IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. 1502 - - ZAUX1.GT.ZAUX2-EPSD))THEN 1503 - ISIDE6=+1 1504 - ELSEIF(IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. 1505 - - ZAUX3.GT.ZAUX4-EPSD))THEN 1506 - ISIDE6=-1 1507 - ELSE 1508 - ISIDE6=0 1509 - ENDIF 1510 - GOTO 1340 1511 - ENDIF 1512 - 1330 CONTINUE 1513 - ISIDE6=0 1514 - 1340 CONTINUE 1515 - * Make sure we are at all allowed to go in this direction. 1516 - IF(JP.GE.NS)ISIDE6=0 1517 - * Don't follow 2+ or 2- is degenerate with s+ or s-. 1518 - JP2=IREF(IP,IL,2) 1519 - JP3=IREF(IP,IL,3) 1520 - IF(IREF(1+MOD(JP2-2+N2,N2),2,3).EQ.1+MOD(JP3-2+NS,NS).AND. 1521 - - IREF(1+MOD(JP2-2+N2,N2),2,3).NE.0.AND. 1522 - - (ISIDE3*ISIDE5.EQ.-1.OR.ABS(ISIDE3*ISIDE5).GE.2).AND. 1523 - - ABS(PHI3-PHI5).LT.0.001)THEN 1524 - ISIDE3=0 1525 - ISIDE5=0 1526 - C print *,' Eliminated 2-/s- degeneracy' 1527 - ENDIF 1528 - IF(IREF(1+MOD(JP2-2+N2,N2),2,3).EQ.1+MOD(JP3 ,NS).AND. 1529 - - IREF(1+MOD(JP2-2+N2,N2),2,3).NE.0.AND. 1530 - - (ISIDE3*ISIDE6.EQ.-1.OR.ABS(ISIDE3*ISIDE6).GE.2).AND. 1531 - - ABS(PHI3-PHI6).LT.0.001)THEN 1532 - ISIDE3=0 1533 - ISIDE6=0 1534 - C print *,' Eliminated 2-/s+ degeneracy' 1535 - ENDIF 1536 - IF(IREF(1+MOD(JP2 ,N2),2,3).EQ.1+MOD(JP3-2+NS,NS).AND. 1537 - - IREF(1+MOD(JP2 ,N2),2,3).NE.0.AND. 1538 - - (ISIDE4*ISIDE5.EQ.-1.OR.ABS(ISIDE4*ISIDE5).GE.2).AND. 1539 - - ABS(PHI4-PHI5).LT.0.001)THEN 1540 - ISIDE4=0 1541 - ISIDE5=0 1542 - C print *,' Eliminated 2+/s- degeneracy' 1543 - ENDIF 1544 - IF(IREF(1+MOD(JP2 ,N2),2,3).EQ.1+MOD(JP3 ,NS).AND. 1545 - - IREF(1+MOD(JP2 ,N2),2,3).NE.0.AND. 1546 - - (ISIDE4*ISIDE6.EQ.-1.OR.ABS(ISIDE4*ISIDE6).GE.2).AND. 1547 - - ABS(PHI4-PHI6).LT.0.001)THEN 1548 - ISIDE4=0 1549 - ISIDE6=0 1550 - C print *,' Eliminated 2+/s+ degeneracy' 1551 - ENDIF 1552 - * Find the optimal branch to take. 1553 - PHIOPT=3*PI 1554 - IF(ISIDE0*ISIDE1.EQ.-1.AND.ISIDE0*PHI1.LT.PHIOPT-0.001)THEN 1555 - JDIR=-1 1556 - JP=1+MOD(IREF(IP,IL,1)+JDIR-1+N1,N1) 1557 - JL=1 1558 - PHIOPT=ISIDE0*PHI1 1559 - ENDIF 1560 - IF(ISIDE0*ISIDE2.EQ.-1.AND.ISIDE0*PHI2.LT.PHIOPT-0.001)THEN 1561 - JDIR=+1 1562 - JP=1+MOD(IREF(IP,IL,1)+JDIR-1+N1,N1) 1563 - JL=1 1 265 P=PROJECTI D=PLASPL 16 PAGE 361 1564 - PHIOPT=ISIDE0*PHI2 1565 - ENDIF 1566 - IF(ISIDE0*ISIDE3.EQ.-1.AND.ISIDE0*PHI3.LT.PHIOPT-0.001)THEN 1567 - JDIR=-1 1568 - JP=1+MOD(IREF(IP,IL,2)+JDIR-1+N2,N2) 1569 - JL=2 1570 - PHIOPT=ISIDE0*PHI3 1571 - ENDIF 1572 - IF(ISIDE0*ISIDE4.EQ.-1.AND.ISIDE0*PHI4.LT.PHIOPT-0.001)THEN 1573 - JDIR=+1 1574 - JP=1+MOD(IREF(IP,IL,2)+JDIR-1+N2,N2) 1575 - JL=2 1576 - PHIOPT=ISIDE0*PHI4 1577 - ENDIF 1578 - IF(ISIDE0*ISIDE5.EQ.-1.AND.ISIDE0*PHI5.LT.PHIOPT-0.001)THEN 1579 - JDIR=-1 1580 - JP=1+MOD(IREF(IP,IL,3)+JDIR-1+NS,NS) 1581 - JL=3 1582 - PHIOPT=ISIDE0*PHI5 1583 - ENDIF 1584 - IF(ISIDE0*ISIDE6.EQ.-1.AND.ISIDE0*PHI6.LT.PHIOPT-0.001)THEN 1585 - JDIR=+1 1586 - JP=1+MOD(IREF(IP,IL,3)+JDIR-1+NS,NS) 1587 - JL=3 1588 - PHIOPT=ISIDE0*PHI6 1589 - ENDIF 1590 - IF(LDEBUG)WRITE(LUNOUT,'( 1591 - - 5X,''Incoming, side='',I2,'' angle= '',F10.3/ 1592 - - 5X,''List 1 -, side='',I2,'' relative angle='',F10.3/ 1593 - - 5X,''List 1 +, side='',I2,'' relative angle='',F10.3/ 1594 - - 5X,''List 2 -, side='',I2,'' relative angle='',F10.3/ 1595 - - 5X,''List 2 +, side='',I2,'' relative angle='',F10.3/ 1596 - - 5X,''Split -, side='',I2,'' relative angle='',F10.3/ 1597 - - 5X,''Split +, side='',I2,'' relative angle='',F10.3/ 1598 - - 5X,''Selected list '',I3,'' point '',I3, 1599 - - '' direction '',I3)') 1600 - - ISIDE0,PHI0,ISIDE1,PHI1,ISIDE2,PHI2,ISIDE3,PHI3, 1601 - - ISIDE4,PHI4,ISIDE5,PHI5,ISIDE6,PHI6,JL,JP,JDIR 1602 - * See whether a solution has been found. 1603 - IF(PHIOPT.GT.2.0D0*PI)THEN 1604 - PRINT *,' !!!!!! PLASPL WARNING : Did not find a'// 1605 - - ' way out of the triple crossing ; skipping.' 1606 - LGSIG=.TRUE. 1607 - IP=1+MOD(IP+IDIR-1+NP,NP) 1608 - ELSE 1609 - IP=JP 1610 - IL=JL 1611 - IDIR=JDIR 1612 - ENDIF 1613 - 1200 CONTINUE 1614 - ** If this is an intersect or a vertex of the other plane. 1615 - ELSEIF((IT(IP,IL).EQ.2.OR.IT(IP,IL).EQ.3).AND.IL.NE.3)THEN 1616 - IF(LDEBUG)WRITE(LUNOUT,'('' Crossing / foreign vertex'')') 1617 - * Compute offsets for plane 1 (ZAUX1) and for plane 2 (ZAUX2). 1618 - ZAUX1=(DPL1-APL1*XL(IP,IL)-BPL1*YL(IP,IL))/CPL1 1619 - ZAUX2=(DPL2-APL2*XL(IP,IL)-BPL2*YL(IP,IL))/CPL2 1620 - * If on plane 2 and crossing under 1, follow 1 in old direction. 1621 - IF(IL.EQ.2.AND.ZAUX1.GT.ZAUX2-EPSD)THEN 1622 - IF(LDEBUG)WRITE(LUNOUT,'(5X,''On 2, going under 1'')') 1623 - IL=1 1624 - IDIR=INITD 1625 - IP=1+MOD(IREF(IP,2,1)+IDIR-1+N1,N1) 1626 - * If on plane 2 and crossing over 1, follow visible part of 1. 1627 - ELSEIF(IL.EQ.2)THEN 1628 - IF(LDEBUG)WRITE(LUNOUT,'(5X,''On 2, going over 1'')') 1629 - JP=IREF(IP,IL,3-IL) 1630 - CALL INTERD(NPL2,XPL2,YPL2, 1631 - - 0.5*(XL(1+MOD(JP-2+N1,N1),1)+ 1632 - - XL(1+MOD(JP-1 ,N1),1)), 1633 - - 0.5*(YL(1+MOD(JP-2+N1,N1),1)+ 1634 - - YL(1+MOD(JP-1 ,N1),1)),IN1,EDGE1) 1635 - CALL INTERD(NPL2,XPL2,YPL2, 1636 - - 0.5*(XL(1+MOD(JP ,N1),1)+ 1637 - - XL(1+MOD(JP-1 ,N1),1)), 1638 - - 0.5*(YL(1+MOD(JP ,N1),1)+ 1639 - - YL(1+MOD(JP-1 ,N1),1)),IN2,EDGE2) 1640 - IF(.NOT.(IN1.OR.IN2.OR.EDGE1.OR.EDGE2))THEN 1641 - PHI0=ATAN2( 1642 - - YL(1+MOD(IP-IDIR-1+NP,NP),IL)-YL(IP,IL), 1643 - - XL(1+MOD(IP-IDIR-1+NP,NP),IL)-XL(IP,IL)) 1644 - PHI1=MOD(ATAN2( 1645 - - YL(1+MOD(IP+IDIR-1+NP,NP),IL)-YL(IP,IL), 1646 - - XL(1+MOD(IP+IDIR-1+NP,NP),IL)-XL(IP,IL))- 1647 - - PHI0,2.0D0*PI) 1648 - IF(PHI1.LT.-PI)PHI1=PHI1+2*PI 1649 - IF(PHI1.GT.+PI)PHI1=PHI1-2*PI 1650 - PHI2=MOD(ATAN2( 1651 - - YL(1+MOD(JP-2+N1,N1),1)-YL(IP,IL), 1652 - - XL(1+MOD(JP-2+N1,N1),1)-XL(IP,IL))- 1653 - - PHI0,2.0D0*PI) 1654 - IF(PHI2.LT.-PI)PHI2=PHI2+2*PI 1655 - IF(PHI2.GT.+PI)PHI2=PHI2-2*PI 1656 - PHI3=MOD(ATAN2( 1657 - - YL(1+MOD(JP ,N1),1)-YL(IP,IL), 1658 - - XL(1+MOD(JP ,N1),1)-XL(IP,IL))- 1659 - - PHI0,2.0D0*PI) 1660 - IF(PHI3.LT.-PI)PHI3=PHI3+2*PI 1661 - IF(PHI3.GT.+PI)PHI3=PHI3-2*PI 1662 - IF((ABS(PHI2).LT.ABS(PHI1).AND. 1663 - - PHI1*PHI2.GE.0).OR. 1664 - - (ABS(PHI3).LT.ABS(PHI1).AND. 1665 - - PHI1*PHI3.GE.0))THEN 1666 - IF(ABS(PHI2).LT.ABS(PHI3))THEN 1667 - IP=1+MOD(JP-2+N1,N1) 1668 - IDIR=-1 1669 - ELSE 1 265 P=PROJECTI D=PLASPL 17 PAGE 362 1670 - IP=1+MOD(JP ,N1) 1671 - IDIR=+1 1672 - ENDIF 1673 - ELSE 1674 - IF(PHI1.GT.0)THEN 1675 - IF(PHI2.LT.0)PHI2=PHI2+2*PI 1676 - IF(PHI3.LT.0)PHI3=PHI3+2*PI 1677 - ELSE 1678 - IF(PHI2.GT.0)PHI2=PHI2-2*PI 1679 - IF(PHI3.GT.0)PHI3=PHI3-2*PI 1680 - ENDIF 1681 - IF(ABS(PHI2).GT.ABS(PHI3))THEN 1682 - IP=1+MOD(JP-2+N1,N1) 1683 - IDIR=-1 1684 - ELSE 1685 - IP=1+MOD(JP ,N1) 1686 - IDIR=+1 1687 - ENDIF 1688 - ENDIF 1689 - IL=1 1690 - ELSEIF(.NOT.(IN1.OR.EDGE1))THEN 1691 - IL=1 1692 - IDIR=-1 1693 - IP=1+MOD(JP+IDIR-1+N1,N1) 1694 - ELSEIF(.NOT.(IN2.OR.EDGE2))THEN 1695 - IL=1 1696 - IDIR=+1 1697 - IP=1+MOD(JP+IDIR-1+N1,N1) 1698 - ELSE 1699 - IL=2 1700 - IP=1+MOD(IP+IDIR-1+N2,N2) 1701 - ENDIF 1702 - * If on plane 1 and crossing under 2, follow part of 2 entering 1. 1703 - ELSEIF(IL.EQ.1.AND.ZAUX1.LT.ZAUX2-EPSD)THEN 1704 - IF(LDEBUG)WRITE(LUNOUT,'(5X,''On 1, going under 2'')') 1705 - JP=IREF(IP,IL,3-IL) 1706 - CALL INTERD(NPL1,XPL1,YPL1, 1707 - - 0.5*(XL(1+MOD(JP-2+N2,N2),2)+ 1708 - - XL(1+MOD(JP-1 ,N2),2)), 1709 - - 0.5*(YL(1+MOD(JP-2+N2,N2),2)+ 1710 - - YL(1+MOD(JP-1 ,N2),2)),IN1,EDGE1) 1711 - CALL INTERD(NPL1,XPL1,YPL1, 1712 - - 0.5*(XL(1+MOD(JP ,N2),2)+ 1713 - - XL(1+MOD(JP-1 ,N2),2)), 1714 - - 0.5*(YL(1+MOD(JP ,N2),2)+ 1715 - - YL(1+MOD(JP-1 ,N2),2)),IN2,EDGE2) 1716 - IF(IN1.AND.IN2)THEN 1717 - PHI0=ATAN2( 1718 - - YL(1+MOD(IP-IDIR-1+NP,NP),IL)-YL(IP,IL), 1719 - - XL(1+MOD(IP-IDIR-1+NP,NP),IL)-XL(IP,IL)) 1720 - PHI1=MOD(ATAN2( 1721 - - YL(1+MOD(IP+IDIR-1+NP,NP),IL)-YL(IP,IL), 1722 - - XL(1+MOD(IP+IDIR-1+NP,NP),IL)-XL(IP,IL))- 1723 - - PHI0,2.0D0*PI) 1724 - IF(PHI1.LT.-PI)PHI1=PHI1+2*PI 1725 - IF(PHI1.GT.+PI)PHI1=PHI1-2*PI 1726 - PHI2=MOD(ATAN2( 1727 - - YL(1+MOD(JP-2+N2,N2),2)-YL(IP,IL), 1728 - - XL(1+MOD(JP-2+N2,N2),2)-XL(IP,IL))- 1729 - - PHI0,2.0D0*PI) 1730 - IF(PHI2.LT.-PI)PHI2=PHI2+2*PI 1731 - IF(PHI2.GT.+PI)PHI2=PHI2-2*PI 1732 - PHI3=MOD(ATAN2( 1733 - - YL(1+MOD(JP ,N2),2)-YL(IP,IL), 1734 - - XL(1+MOD(JP ,N2),2)-XL(IP,IL))- 1735 - - PHI0,2.0D0*PI) 1736 - IF(PHI3.LT.-PI)PHI3=PHI3+2*PI 1737 - IF(PHI3.GT.+PI)PHI3=PHI3-2*PI 1738 - IF((ABS(PHI2).LT.ABS(PHI1).AND. 1739 - - PHI1*PHI2.GE.0).OR. 1740 - - (ABS(PHI3).LT.ABS(PHI1).AND. 1741 - - PHI1*PHI3.GE.0))THEN 1742 - IF(ABS(PHI2).LT.ABS(PHI3))THEN 1743 - IP=1+MOD(JP-2+N2,N2) 1744 - IDIR=-1 1745 - ELSE 1746 - IP=1+MOD(JP ,N2) 1747 - IDIR=+1 1748 - ENDIF 1749 - ELSE 1750 - IF(PHI1.GT.0)THEN 1751 - IF(PHI2.LT.0)PHI2=PHI2+2*PI 1752 - IF(PHI3.LT.0)PHI3=PHI3+2*PI 1753 - ELSE 1754 - IF(PHI2.GT.0)PHI2=PHI2-2*PI 1755 - IF(PHI3.GT.0)PHI3=PHI3-2*PI 1756 - ENDIF 1757 - IF(ABS(PHI2).GT.ABS(PHI3))THEN 1758 - IP=1+MOD(JP-2+N2,N2) 1759 - IDIR=-1 1760 - ELSE 1761 - IP=1+MOD(JP ,N2) 1762 - IDIR=+1 1763 - ENDIF 1764 - ENDIF 1765 - IL=2 1766 - ELSEIF(IN1)THEN 1767 - IL=2 1768 - IDIR=-1 1769 - IP=1+MOD(JP+IDIR-1+N2,N2) 1770 - ELSEIF(IN2)THEN 1771 - IL=2 1772 - IDIR=+1 1773 - IP=1+MOD(JP+IDIR-1+N2,N2) 1774 - ELSE 1775 - IL=1 1 265 P=PROJECTI D=PLASPL 18 PAGE 363 1776 - IP=1+MOD(IP+IDIR-1+N1,N1) 1777 - ENDIF 1778 - * If on plane 1 and crossing above 2, simply continue. 1779 - ELSEIF(IL.EQ.1)THEN 1780 - IF(LDEBUG)WRITE(LUNOUT,'(5X,''On 1, going over 2'')') 1781 - IP=1+MOD(IP+IDIR-1+NP,NP) 1782 - ENDIF 1783 - ** If this is a vertex lying on the intersection line. 1784 - ELSEIF((IT(IP,IL).EQ.1.OR.IT(IP,IL).EQ.2).AND.IL.EQ.3)THEN 1785 - IF(LDEBUG)WRITE(LUNOUT,'('' Crossing or vertex of list '', 1786 - - I3,'' on the separation line.'')') IT(IP,IL) 1787 - * Check visibility ZAUX1/3 on plane 1, ZAUX2/4 on plane 2. 1788 - IF(IT(IP,IL).EQ.1)THEN 1789 - JP=IREF(IP,3,1) 1790 - ZAUX1=(DPL1- 1791 - - APL1*(XL(IP,IL)+XL(1+MOD(JP-2+N1,N1),1))/2- 1792 - - BPL1*(YL(IP,IL)+YL(1+MOD(JP-2+N1,N1),1))/2)/CPL1 1793 - ZAUX2=(DPL2- 1794 - - APL2*(XL(IP,IL)+XL(1+MOD(JP-2+N1,N1),1))/2- 1795 - - BPL2*(YL(IP,IL)+YL(1+MOD(JP-2+N1,N1),1))/2)/CPL2 1796 - ZAUX3=(DPL1- 1797 - - APL1*(XL(IP,IL)+XL(1+MOD(JP,N1),1))/2- 1798 - - BPL1*(YL(IP,IL)+YL(1+MOD(JP,N1),1))/2)/CPL1 1799 - ZAUX4=(DPL2- 1800 - - APL2*(XL(IP,IL)+XL(1+MOD(JP,N1),1))/2- 1801 - - BPL2*(YL(IP,IL)+YL(1+MOD(JP,N1),1))/2)/CPL2 1802 - CALL INTERD(NPL2,XPL2,YPL2, 1803 - - (XL(IP,IL)+XL(1+MOD(JP-2+N1,N1),1))/2, 1804 - - (YL(IP,IL)+YL(1+MOD(JP-2+N1,N1),1))/2, 1805 - - IN1,EDGE1) 1806 - CALL INTERD(NPL2,XPL2,YPL2, 1807 - - (XL(IP,IL)+XL(1+MOD(JP,N1),1))/2, 1808 - - (YL(IP,IL)+YL(1+MOD(JP,N1),1))/2, 1809 - - IN2,EDGE2) 1810 - IF(.NOT.(IN1.OR.IN2.OR.EDGE1.OR.EDGE2))THEN 1811 - IF(((XL(1+MOD(JP-2+N1 ,N1),1 )-XL(IP,IL))* 1812 - - (XL(1+MOD(IP-IDIR-1+NP,NP),IL)-XL(IP,IL))+ 1813 - - (YL(1+MOD(JP-2+N1 ,N1),1 )-YL(IP,IL))* 1814 - - (YL(1+MOD(IP-IDIR-1+NP,NP),IL)-YL(IP,IL)))* 1815 - - SQRT((XL(1+MOD(JP ,N1),1 )-XL(IP,IL))**2+ 1816 - - (YL(1+MOD(JP ,N1),1 )-YL(IP,IL))**2) 1817 - - .LT. 1818 - - ((XL(1+MOD(JP ,N1),1 )-XL(IP,IL))* 1819 - - (XL(1+MOD(IP-IDIR-1+NP,NP),IL)-XL(IP,IL))+ 1820 - - (YL(1+MOD(JP ,N1),1 )-YL(IP,IL))* 1821 - - (YL(1+MOD(IP-IDIR-1+NP,NP),IL)-YL(IP,IL)))* 1822 - - SQRT((XL(1+MOD(JP-2+N1,N1),1 )-XL(IP,IL))**2+ 1823 - - (YL(1+MOD(JP-2+N1,N1),1 )-YL(IP,IL))**2) 1824 - - )THEN 1825 - IDIR=-1 1826 - ELSE 1827 - IDIR=+1 1828 - ENDIF 1829 - C print *,' Both ways visible, choosing ',IDIR 1830 - IL=1 1831 - IP=1+MOD(JP+IDIR-1+N1,N1) 1832 - ELSEIF((.NOT.(IN1.OR.EDGE1).OR.ZAUX1.GE.ZAUX2).AND. 1833 - - (.NOT.(IN2.OR.EDGE2).OR.ZAUX3.GE.ZAUX4))THEN 1834 - C print *,' Choosing initial direction.' 1835 - IL=1 1836 - IDIR=INITD 1837 - IP=1+MOD(JP+IDIR-1+N1,N1) 1838 - ELSEIF(.NOT.(IN1.OR.EDGE1))THEN 1839 - C print *,' Choosing -' 1840 - IL=1 1841 - IDIR=-1 1842 - IP=1+MOD(JP+IDIR-1+N1,N1) 1843 - ELSEIF(.NOT.(IN2.OR.EDGE2))THEN 1844 - C print *,' Choosing +' 1845 - IL=1 1846 - IDIR=+1 1847 - IP=1+MOD(JP+IDIR-1+N1,N1) 1848 - ELSEIF(ZAUX1.GE.ZAUX2)THEN 1849 - C print *,' Choosing -' 1850 - IL=1 1851 - IDIR=-1 1852 - IP=1+MOD(JP+IDIR-1+N1,N1) 1853 - ELSEIF(ZAUX3.GE.ZAUX4)THEN 1854 - C print *,' Choosing +' 1855 - IL=1 1856 - IDIR=+1 1857 - IP=1+MOD(JP+IDIR-1+N1,N1) 1858 - ELSE 1859 - PRINT *,' !!!!!! PLASPL WARNING : Found no way'// 1860 - - ' out of a vertex on intersect.' 1861 - LGSIG=.TRUE. 1862 - IP=1+MOD(IP+IDIR-1+NP,NP) 1863 - ENDIF 1864 - * Continue via plane 2. 1865 - ELSEIF(IT(IP,IL).EQ.2)THEN 1866 - PRINT *,' !!!!!! PLASPL WARNING : Crossed plane 2', 1867 - - ' via the separation line; skipped.' 1868 - IP=1+MOD(IP+IDIR-1+NP,NP) 1869 - ENDIF 1870 - ** If this is a hole in the other plane. 1871 - ELSEIF(IT(IP,IL).EQ.4)THEN 1872 - IF(LDEBUG)WRITE(LUNOUT,'('' Hole in other plane.'')') 1873 - * If on plane 1, follow separation line entering plane 1. 1874 - IF(IL.EQ.1)THEN 1875 - JP=IREF(IP,IL,3) 1876 - CALL INTERD(NPL1,XPL1,YPL1, 1877 - - 0.5*(XL(1+MOD(JP-2+NS,NS),3)+ 1878 - - XL(1+MOD(JP-1 ,NS),3)), 1879 - - 0.5*(YL(1+MOD(JP-2+NS,NS),3)+ 1880 - - YL(1+MOD(JP-1 ,NS),3)),IN1,EDGE1) 1881 - CALL INTERD(NPL1,XPL1,YPL1, 1 265 P=PROJECTI D=PLASPL 19 PAGE 364 1882 - - 0.5*(XL(1+MOD(JP ,NS),3)+ 1883 - - XL(1+MOD(JP-1 ,NS),3)), 1884 - - 0.5*(YL(1+MOD(JP ,NS),3)+ 1885 - - YL(1+MOD(JP-1 ,NS),3)),IN2,EDGE2) 1886 - IF(JP.LE.1)THEN 1887 - IP=1 1888 - IDIR=+1 1889 - IL=3 1890 - IP=1+MOD(IP+IDIR-1+NS,NS) 1891 - ELSEIF(JP.GE.NS)THEN 1892 - IP=NS 1893 - IDIR=-1 1894 - IL=3 1895 - IP=1+MOD(IP+IDIR-1+NS,NS) 1896 - ELSEIF(IN1.OR.(EDGE1.AND..NOT.IN2))THEN 1897 - IP=JP 1898 - IDIR=-1 1899 - IL=3 1900 - IP=1+MOD(IP+IDIR-1+NS,NS) 1901 - ELSEIF(IN2.OR.(EDGE2.AND..NOT.IN1))THEN 1902 - IP=JP 1903 - IDIR=+1 1904 - IL=3 1905 - IP=1+MOD(IP+IDIR-1+NS,NS) 1906 - ELSE 1907 - IP=1+MOD(IP+IDIR-1+NP,NP) 1908 - ENDIF 1909 - * If on plane 2, follow separation line entering plane 2. 1910 - ELSEIF(IL.EQ.2)THEN 1911 - JP=IREF(IP,IL,3) 1912 - CALL INTERD(NPL2,XPL2,YPL2, 1913 - - 0.5*(XL(1+MOD(JP-2+NS,NS),3)+ 1914 - - XL(1+MOD(JP-1 ,NS),3)), 1915 - - 0.5*(YL(1+MOD(JP-2+NS,NS),3)+ 1916 - - YL(1+MOD(JP-1 ,NS),3)),IN1,EDGE1) 1917 - CALL INTERD(NPL2,XPL2,YPL2, 1918 - - 0.5*(XL(1+MOD(JP ,NS),3)+ 1919 - - XL(1+MOD(JP-1 ,NS),3)), 1920 - - 0.5*(YL(1+MOD(JP ,NS),3)+ 1921 - - YL(1+MOD(JP-1 ,NS),3)),IN2,EDGE2) 1922 - IF(JP.LE.1)THEN 1923 - IP=1 1924 - IDIR=+1 1925 - IL=3 1926 - IP=1+MOD(IP+IDIR-1+NS,NS) 1927 - ELSEIF(JP.GE.NS)THEN 1928 - IP=NS 1929 - IDIR=-1 1930 - IL=3 1931 - IP=1+MOD(IP+IDIR-1+NS,NS) 1932 - ELSEIF(IN1.OR.(EDGE1.AND..NOT.IN2))THEN 1933 - IP=JP 1934 - IDIR=-1 1935 - IL=3 1936 - IP=1+MOD(IP+IDIR-1+NS,NS) 1937 - ELSEIF(IN2.OR.(EDGE2.AND..NOT.IN1))THEN 1938 - IP=JP 1939 - IDIR=+1 1940 - IL=3 1941 - IP=1+MOD(IP+IDIR-1+NS,NS) 1942 - ELSE 1943 - IP=1+MOD(IP+IDIR-1+NP,NP) 1944 - ENDIF 1945 - * If on separation line, follow visible part of plane entered. 1946 - ELSEIF(IL.EQ.3)THEN 1947 - * Find out which plane we enter. 1948 - IF(IREF(IP,3,1).NE.0)THEN 1949 - JP=IREF(IP,3,1) 1950 - IL=1 1951 - ZAUX1=(DPL1- 1952 - - APL1*0.5*(XL(JP,IL)+XL(1+MOD(JP,N1),IL))- 1953 - - BPL1*0.5*(YL(JP,IL)+YL(1+MOD(JP,N1),IL)))/ 1954 - - CPL1 1955 - ZAUX2=(DPL2- 1956 - - APL2*0.5*(XL(JP,IL)+XL(1+MOD(JP,N1),IL))- 1957 - - BPL2*0.5*(YL(JP,IL)+YL(1+MOD(JP,N1),IL)))/ 1958 - - CPL2 1959 - ZAUX3=(DPL1- 1960 - - APL1*0.5*(XL(JP,IL)+ 1961 - - XL(1+MOD(JP-2+N1,N1),IL))- 1962 - - BPL1*0.5*(YL(JP,IL)+ 1963 - - YL(1+MOD(JP-2+N1,N1),IL)))/CPL1 1964 - ZAUX4=(DPL2- 1965 - - APL2*0.5*(XL(JP,IL)+ 1966 - - XL(1+MOD(JP-2+N1,N1),IL))- 1967 - - BPL2*0.5*(YL(JP,IL)+ 1968 - - YL(1+MOD(JP-2+N1,N1),IL)))/CPL2 1969 - IF(ZAUX1.GT.ZAUX2)THEN 1970 - IDIR=+1 1971 - ELSEIF(ZAUX3.GT.ZAUX4)THEN 1972 - IDIR=-1 1973 - ENDIF 1974 - IP=1+MOD(JP+IDIR-1+N1,N1) 1975 - ELSEIF(IREF(IP,3,2).NE.0)THEN 1976 - JP=IREF(IP,3,2) 1977 - IL=2 1978 - ZAUX1=(DPL1- 1979 - - APL1*0.5*(XL(JP,IL)+XL(1+MOD(JP,N2),IL))- 1980 - - BPL1*0.5*(YL(JP,IL)+YL(1+MOD(JP,N2),IL)))/ 1981 - - CPL1 1982 - ZAUX2=(DPL2- 1983 - - APL2*0.5*(XL(JP,IL)+XL(1+MOD(JP,N2),IL))- 1984 - - BPL2*0.5*(YL(JP,IL)+YL(1+MOD(JP,N2),IL)))/ 1985 - - CPL2 1986 - ZAUX3=(DPL1- 1987 - - APL1*0.5*(XL(JP,IL)+ 1 265 P=PROJECTI D=PLASPL 20 PAGE 365 1988 - - XL(1+MOD(JP-2+N2,N2),IL))- 1989 - - BPL1*0.5*(YL(JP,IL)+ 1990 - - YL(1+MOD(JP-2+N2,N2),IL)))/CPL1 1991 - ZAUX4=(DPL2- 1992 - - APL2*0.5*(XL(JP,IL)+ 1993 - - XL(1+MOD(JP-2+N2,N2),IL))- 1994 - - BPL2*0.5*(YL(JP,IL)+ 1995 - - YL(1+MOD(JP-2+N2,N2),IL)))/CPL2 1996 - IF(ZAUX2.GT.ZAUX1)THEN 1997 - IDIR=+1 1998 - ELSEIF(ZAUX4.GT.ZAUX3)THEN 1999 - IDIR=-1 2000 - ENDIF 2001 - IP=1+MOD(JP+IDIR-1+N2,N2) 2002 - ELSE 2003 - PRINT *,' !!!!!! PLASPL WARNING : Hole has no'// 2004 - - ' matching plane.' 2005 - IP=1+MOD(IP+IDIR-1+NP,NP) 2006 - ENDIF 2007 - ENDIF 2008 - ** If this is a crossing with the separation line. 2009 - ELSEIF(IT(IP,IL).EQ.5)THEN 2010 - IF(LDEBUG)WRITE(LUNOUT,'('' Plane crosses separation.'')') 2011 - * If we are on plane 1, ensure we don't dive under other plane. 2012 - IF(IL.EQ.1)THEN 2013 - CALL INTERD(NPL2,XPL2,YPL2, 2014 - - (XL(IP,IL)+XL(1+MOD(IP+IDIR-1,NP),IL))/2, 2015 - - (YL(IP,IL)+YL(1+MOD(IP+IDIR-1,NP),IL))/2, 2016 - - IN1,EDGE1) 2017 - ZAUX1=(DPL1- 2018 - - APL1*(XL(IP,IL)+XL(1+MOD(IP+IDIR-1,NP),IL))/2- 2019 - - BPL1*(YL(IP,IL)+YL(1+MOD(IP+IDIR-1,NP),IL))/2)/ 2020 - - CPL1 2021 - ZAUX2=(DPL2- 2022 - - APL2*(XL(IP,IL)+XL(1+MOD(IP+IDIR-1,NP),IL))/2- 2023 - - BPL2*(YL(IP,IL)+YL(1+MOD(IP+IDIR-1,NP),IL))/2)/ 2024 - - CPL2 2025 - IF((IN1.OR.EDGE1).AND.ZAUX1.LT.ZAUX2)THEN 2026 - IF(LDEBUG)WRITE(LUNOUT,'(5X, 2027 - - ''On 1, going over 2'')') 2028 - JP=IREF(IP,IL,3) 2029 - CALL INTERD(NPL1,XPL1,YPL1, 2030 - - (XL(JP,3)+XL(1+MOD(JP-2+NS,NS),3))/2, 2031 - - (YL(JP,3)+YL(1+MOD(JP-2+NS,NS),3))/2, 2032 - - IN1,EDGE1) 2033 - CALL INTERD(NPL1,XPL1,YPL1, 2034 - - (XL(JP,3)+XL(1+MOD(JP ,NS),3))/2, 2035 - - (YL(JP,3)+YL(1+MOD(JP ,NS),3))/2, 2036 - - IN2,EDGE2) 2037 - CALL INTERD(NPL2,XPL2,YPL2, 2038 - - (XL(JP,3)+XL(1+MOD(JP-2+NS,NS),3))/2, 2039 - - (YL(JP,3)+YL(1+MOD(JP-2+NS,NS),3))/2, 2040 - - IN3,EDGE3) 2041 - CALL INTERD(NPL2,XPL2,YPL2, 2042 - - (XL(JP,3)+XL(1+MOD(JP ,NS),3))/2, 2043 - - (YL(JP,3)+YL(1+MOD(JP ,NS),3))/2, 2044 - - IN4,EDGE4) 2045 - IF((IN1.OR.EDGE1).AND.(IN3.OR.EDGE3))THEN 2046 - IF(JP.LE.1)THEN 2047 - PRINT *,' !!!!!! PLASPL WARNING :'// 2048 - - ' Reached start of separation.' 2049 - LGSIG=.TRUE. 2050 - IDIR=+1 2051 - ELSE 2052 - IDIR=-1 2053 - ENDIF 2054 - IL=3 2055 - IP=JP+IDIR 2056 - ELSEIF((IN2.OR.EDGE2).AND.(IN4.OR.EDGE4))THEN 2057 - IF(JP.GE.NS)THEN 2058 - PRINT *,' !!!!!! PLASPL WARNING :'// 2059 - - ' Reached end of separation.' 2060 - LGSIG=.TRUE. 2061 - IDIR=-1 2062 - ELSE 2063 - IDIR=+1 2064 - ENDIF 2065 - IL=3 2066 - IP=JP+IDIR 2067 - ELSE 2068 - C print *,' No interest in changing line.' 2069 - IP=1+MOD(IP+IDIR-1+NP,NP) 2070 - ENDIF 2071 - ELSE 2072 - C print *,' Staying on curve' 2073 - IP=1+MOD(IP+IDIR-1+NP,NP) 2074 - ENDIF 2075 - * If we are on plane 2, ensure we don't dive under other plane. 2076 - ELSEIF(IL.EQ.2)THEN 2077 - CALL INTERD(NPL1,XPL1,YPL1, 2078 - - (XL(IP,IL)+XL(1+MOD(IP+IDIR-1,NP),IL))/2, 2079 - - (YL(IP,IL)+YL(1+MOD(IP+IDIR-1,NP),IL))/2, 2080 - - IN1,EDGE1) 2081 - ZAUX1=(DPL1- 2082 - - APL1*(XL(IP,IL)+XL(1+MOD(IP+IDIR-1,NP),IL))/2- 2083 - - BPL1*(YL(IP,IL)+YL(1+MOD(IP+IDIR-1,NP),IL))/2)/ 2084 - - CPL1 2085 - ZAUX2=(DPL2- 2086 - - APL2*(XL(IP,IL)+XL(1+MOD(IP+IDIR-1,NP),IL))/2- 2087 - - BPL2*(YL(IP,IL)+YL(1+MOD(IP+IDIR-1,NP),IL))/2)/ 2088 - - CPL2 2089 - IF((IN1.OR.EDGE1).AND.ZAUX1.GT.ZAUX2)THEN 2090 - IF(LDEBUG)WRITE(LUNOUT,'(5X, 2091 - - ''On 1, going over 2'')') 2092 - JP=IREF(IP,IL,3) 2093 - CALL INTERD(NPL2,XPL2,YPL2, 1 265 P=PROJECTI D=PLASPL 21 PAGE 366 2094 - - (XL(JP,3)+XL(1+MOD(JP-2+NS,NS),3))/2, 2095 - - (YL(JP,3)+YL(1+MOD(JP-2+NS,NS),3))/2, 2096 - - IN1,EDGE1) 2097 - CALL INTERD(NPL2,XPL2,YPL2, 2098 - - (XL(JP,3)+XL(1+MOD(JP ,NS),3))/2, 2099 - - (YL(JP,3)+YL(1+MOD(JP ,NS),3))/2, 2100 - - IN2,EDGE2) 2101 - CALL INTERD(NPL1,XPL1,YPL1, 2102 - - (XL(JP,3)+XL(1+MOD(JP-2+NS,NS),3))/2, 2103 - - (YL(JP,3)+YL(1+MOD(JP-2+NS,NS),3))/2, 2104 - - IN3,EDGE3) 2105 - CALL INTERD(NPL1,XPL1,YPL1, 2106 - - (XL(JP,3)+XL(1+MOD(JP ,NS),3))/2, 2107 - - (YL(JP,3)+YL(1+MOD(JP ,NS),3))/2, 2108 - - IN4,EDGE4) 2109 - IF((IN1.OR.EDGE1).AND.(IN3.OR.EDGE3))THEN 2110 - IF(JP.LE.1)THEN 2111 - PRINT *,' !!!!!! PLASPL WARNING :'// 2112 - - ' Reached start of separation.' 2113 - LGSIG=.TRUE. 2114 - IDIR=+1 2115 - ELSE 2116 - IDIR=-1 2117 - ENDIF 2118 - IL=3 2119 - IP=JP+IDIR 2120 - ELSEIF((IN2.OR.EDGE2).AND.(IN4.OR.EDGE4))THEN 2121 - IF(JP.GE.NS)THEN 2122 - PRINT *,' !!!!!! PLASPL WARNING :'// 2123 - - ' Reached end of separation.' 2124 - LGSIG=.TRUE. 2125 - IDIR=-1 2126 - ELSE 2127 - IDIR=+1 2128 - ENDIF 2129 - IL=3 2130 - IP=JP+IDIR 2131 - ELSE 2132 - C print *,' No interest in changing line.' 2133 - IP=1+MOD(IP+IDIR-1+NP,NP) 2134 - ENDIF 2135 - ELSE 2136 - C print *,' Staying on curve' 2137 - IP=1+MOD(IP+IDIR-1+NP,NP) 2138 - ENDIF 2139 - * If on intersect, continue on the new plane. 2140 - ELSEIF(IL.EQ.3)THEN 2141 - * If crossing plane 1, continue in original direction. 2142 - IF(IREF(IP,3,1).NE.0)THEN 2143 - C print *,' Entering plane 1' 2144 - JP=IREF(IP,3,1) 2145 - CALL INTERD(NPL2,XPL2,YPL2, 2146 - - (XL(JP,1)+XL(1+MOD(JP-2+N1,N1),1))/2, 2147 - - (YL(JP,1)+YL(1+MOD(JP-2+N1,N1),1))/2, 2148 - - IN1,EDGE1) 2149 - CALL INTERD(NPL2,XPL2,YPL2, 2150 - - (XL(JP,1)+XL(1+MOD(JP ,N1),1))/2, 2151 - - (YL(JP,1)+YL(1+MOD(JP ,N1),1))/2, 2152 - - IN2,EDGE2) 2153 - ZAUX1=(DPL1- 2154 - - APL1*(XL(JP,1)+XL(1+MOD(JP-2+N1,N1),1))/2- 2155 - - BPL1*(YL(JP,1)+YL(1+MOD(JP-2+N1,N1),1))/2)/ 2156 - - CPL1 2157 - ZAUX2=(DPL2- 2158 - - APL2*(XL(JP,1)+XL(1+MOD(JP-2+N1,N1),1))/2- 2159 - - BPL2*(YL(JP,1)+YL(1+MOD(JP-2+N1,N1),1))/2)/ 2160 - - CPL2 2161 - ZAUX3=(DPL1- 2162 - - APL1*(XL(JP,1)+XL(1+MOD(JP ,N1),1))/2- 2163 - - BPL1*(YL(JP,1)+YL(1+MOD(JP ,N1),1))/2)/ 2164 - - CPL1 2165 - ZAUX4=(DPL2- 2166 - - APL2*(XL(JP,1)+XL(1+MOD(JP ,N1),1))/2- 2167 - - BPL2*(YL(JP,1)+YL(1+MOD(JP ,N1),1))/2)/ 2168 - - CPL2 2169 - IF(.NOT.(IN1.OR.EDGE1))THEN 2170 - IDIR=-1 2171 - ELSEIF(.NOT.(IN2.OR.EDGE2))THEN 2172 - IDIR=+1 2173 - ELSEIF(ZAUX1.GT.ZAUX2)THEN 2174 - IDIR=-1 2175 - ELSEIF(ZAUX3.GT.ZAUX4)THEN 2176 - IDIR=+1 2177 - ELSE 2178 - C print *,' Resuming plane 1 in old direction.' 2179 - IDIR=INITD 2180 - ENDIF 2181 - IL=1 2182 - IP=1+MOD(JP+IDIR-1+N1,N1) 2183 - ELSEIF(IREF(IP,3,2).NE.0)THEN 2184 - JP=IREF(IP,3,2) 2185 - IL=2 2186 - PRINT *,' !!!!!! PLASPL WARNING : Entered plane'// 2187 - - ' 2.' 2188 - LGSIG=.TRUE. 2189 - ZAUX1=(DPL1- 2190 - - APL1*0.5*(XL(JP,IL)+XL(1+MOD(JP,N2),IL))- 2191 - - BPL1*0.5*(YL(JP,IL)+YL(1+MOD(JP,N2),IL)))/ 2192 - - CPL1 2193 - ZAUX2=(DPL2- 2194 - - APL2*0.5*(XL(JP,IL)+XL(1+MOD(JP,N2),IL))- 2195 - - BPL2*0.5*(YL(JP,IL)+YL(1+MOD(JP,N2),IL)))/ 2196 - - CPL2 2197 - ZAUX3=(DPL1- 2198 - - APL1*0.5*(XL(JP,IL)+ 2199 - - XL(1+MOD(JP-2+N2,N2),IL))- 1 265 P=PROJECTI D=PLASPL 22 PAGE 367 2200 - - BPL1*0.5*(YL(JP,IL)+ 2201 - - YL(1+MOD(JP-2+N2,N2),IL)))/CPL1 2202 - ZAUX4=(DPL2- 2203 - - APL2*0.5*(XL(JP,IL)+ 2204 - - XL(1+MOD(JP-2+N2,N2),IL))- 2205 - - BPL2*0.5*(YL(JP,IL)+ 2206 - - YL(1+MOD(JP-2+N2,N2),IL)))/CPL2 2207 - IF(ZAUX2.GT.ZAUX1)THEN 2208 - IDIR=+1 2209 - ELSEIF(ZAUX4.GT.ZAUX3)THEN 2210 - IDIR=-1 2211 - ENDIF 2212 - IP=1+MOD(JP+IDIR-1+N2,N2) 2213 - ELSE 2214 - PRINT *,' !!!!!! PLASPL WARNING : No connection'// 2215 - - ' found.' 2216 - LGSIG=.TRUE. 2217 - IP=1+MOD(JP+IDIR-1+NP,NP) 2218 - ENDIF 2219 - * Move in the direction in which the line visible. 2220 - ENDIF 2221 - ** Anything else. 2222 - ELSE 2223 - PRINT *,' !!!!!! PLASPL WARNING : Unknown type for a'// 2224 - - ' point; skipped.' 2225 - IP=1+MOD(IP+IDIR-1+NP,NP) 2226 - ENDIF 2227 - *** Resume the loop. 2228 - GOTO 430 2229 - *** And process cut-outs, pieces of 2 sticking out above the plane. 2230 - 1000 CONTINUE 2231 - ** Loop over the planes that were produced. 2232 - DO 1010 IR=1,NREF 2233 - IF(IREFO(IR).LE.0)GOTO 1010 2234 - CALL PLABU2('READ',IREFO(IR),NPL,XPL,YPL,ZPL, 2235 - - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) 2236 - IF(IFAIL1.NE.0)THEN 2237 - PRINT *,' !!!!!! PLASPL WARNING : Unable to retrieve a'// 2238 - - ' plane ; not checked for cut-outs.' 2239 - GOTO 1010 2240 - ENDIF 2241 - * Find a first vertex sticking out. 2242 - DO 710 I=1,N2 2243 - IF(IT(I,2).NE.1)GOTO 710 2244 - CALL INTERD(NPL,XPL,YPL,XL(I,2),YL(I,2),INSIDE,EDGE) 2245 - IF(INSIDE.AND.(.NOT.EDGE).AND. 2246 - - ZL(I,2).GT.(DPL1-APL1*XL(I,2)-BPL1*YL(I,2))/CPL1)THEN 2247 - IP=I 2248 - IL=2 2249 - NCUT=0 2250 - C print *,' Found a vertex sticking out IP/IL=',ip,il 2251 - C print *,' xyz: ',xl(i,2),yl(i,2),zl(i,2) 2252 - C print *,' offset: ',(dpl1-apl1*xl(i,2)-bpl1*yl(i,2))/cpl1 2253 - ** Trace the curve from here. 2254 - START=.TRUE. 2255 - 720 CONTINUE 2256 - * See whether the loop is closed. 2257 - IF(.NOT.START.AND. 2258 - - ABS(XL(IP,IL)-XCUT(1)).LT.EPSX.AND. 2259 - - ABS(YL(IP,IL)-YCUT(1)).LT.EPSY)THEN 2260 - IF(NCUT.LT.3)THEN 2261 - C print *,' Loop closed, not long enough' 2262 - GOTO 710 2263 - ELSE 2264 - C print *,' Loop closed, length=',ncut 2265 - GOTO 730 2266 - ENDIF 2267 - ENDIF 2268 - START=.FALSE. 2269 - * Add the current point. 2270 - IF(NCUT+1.LE.MXCORN)THEN 2271 - NCUT=NCUT+1 2272 - XCUT(NCUT)=XL(IP,IL) 2273 - YCUT(NCUT)=YL(IP,IL) 2274 - ZCUT(NCUT)=(DPL1-APL1*XL(IP,IL)-BPL1*YL(IP,IL))/CPL1 2275 - ELSE 2276 - PRINT *,' !!!!!! PLASPL WARNING : Cut-out too long'// 2277 - - ' ; truncated.' 2278 - C print *,' Length=',ncut 2279 - GOTO 730 2280 - ENDIF 2281 - * Ensure there is no link with plane 1. 2282 - IF(IREF(IP,IL,1).NE.0)THEN 2283 - C print *,' Linked with 1, abandoned' 2284 - GOTO 710 2285 - * See whether this is a vertex of 2. 2286 - ELSEIF(IL.EQ.2.AND.IT(IP,IL).EQ.1)THEN 2287 - C print *,' Vertex IP/IL=',IP,IL 2288 - CALL INTERD(NPL,XPL,YPL,XL(IP,IL),YL(IP,IL), 2289 - - INSIDE,EDGE) 2290 - IF((.NOT.INSIDE).OR.EDGE.OR.ZL(IP,IL).LT. 2291 - - (DPL1-APL1*XL(IP,IL)-BPL1*YL(IP,IL))/CPL1)THEN 2292 - C print *,' - Not useable, abandoned.' 2293 - GOTO 710 2294 - ENDIF 2295 - IP=1+MOD(IP,N2) 2296 - * See whether this is an intersect with the separation. 2297 - ELSEIF(IL.EQ.2.AND.IT(IP,IL).EQ.4)THEN 2298 - C print *,' Intersect with separation IP/IL=',IP,IL 2299 - JP=IREF(IP,2,3) 2300 - CALL INTERD(N2,XL(1,2),YL(1,2), 2301 - - (XL(JP,3)+XL(1+MOD(JP ,NS),3))/2, 2302 - - (YL(JP,3)+YL(1+MOD(JP ,NS),3))/2,IN1,EDGE1) 2303 - CALL INTERD(N2,XL(1,2),YL(1,2), 2304 - - (XL(JP,3)+XL(1+MOD(JP-2+NS,NS),3))/2, 2305 - - (YL(JP,3)+YL(1+MOD(JP-2+NS,NS),3))/2,IN2,EDGE2) 1 265 P=PROJECTI D=PLASPL 23 PAGE 368 2306 - IF(JP.LE.1.AND..NOT.(IN1.OR.EDGE1))THEN 2307 - C print *,' - Lost trace on separation' 2308 - GOTO 710 2309 - ELSEIF(JP.LE.1)THEN 2310 - IP=2 2311 - IL=3 2312 - ELSEIF(JP.GE.NS.AND..NOT.(IN2.OR.EDGE2))THEN 2313 - C print *,' - Lost trace on separation' 2314 - GOTO 710 2315 - ELSEIF(JP.GE.NS)THEN 2316 - IP=NS-1 2317 - IL=3 2318 - ELSEIF(IN1.OR.EDGE1)THEN 2319 - IP=JP+1 2320 - IL=3 2321 - ELSEIF(IN2.OR.EDGE2)THEN 2322 - IP=JP-1 2323 - IL=3 2324 - ELSE 2325 - C print *,' - No way out.' 2326 - GOTO 710 2327 - ENDIF 2328 - * See whether the intersect crosses plane 2 here. 2329 - ELSEIF(IL.EQ.3.AND.(IT(IP,IL).EQ.4.OR.IT(IP,IL).EQ.2))THEN 2330 - C print *,' Crossing 2' 2331 - JP=1+MOD(IREF(IP,3,2),N2) 2332 - CALL INTERD(NPL,XPL,YPL,XL(JP,2),YL(JP,2),INSIDE,EDGE) 2333 - IF(IREF(IP,3,2).EQ.0.OR. 2334 - - (.NOT.INSIDE).OR.EDGE.OR.ZL(JP,2).LT. 2335 - - (DPL1-APL1*XL(JP,2)-BPL1*YL(JP,2))/CPL1)THEN 2336 - C print *,' - Not useable, abandoned.' 2337 - GOTO 710 2338 - ELSE 2339 - IP=JP 2340 - IL=2 2341 - ENDIF 2342 - * Other cases should not occur. 2343 - ELSE 2344 - PRINT *,' !!!!!! PLASPL WARNING : Unknown cut-out'// 2345 - - ' case seen.' 2346 - LGSIG=.TRUE. 2347 - ENDIF 2348 - * Make another step. 2349 - GOTO 720 2350 - ENDIF 2351 - 710 CONTINUE 2352 - * End of vertex loop. 2353 - GOTO 1010 2354 - * Check number of points. 2355 - 730 CONTINUE 2356 - C print *,' Genuine cut-out:' 2357 - C call gsplci(9) 2358 - C call gsln(1) 2359 - C call gpl2(ncut,xcut,ycut) 2360 - C call gspmci(9) 2361 - C call gsmk(5) 2362 - ** Find a place where we can connect cutout and curve. 2363 - DO 770 K=1,NPL-1 2364 - DO 740 J=1,NCUT 2365 - * Check for intersects with the visible parts of curve 2. 2366 - DO 760 I=1,N2 2367 - IF( (ABS(XCUT(1+MOD(J-1,NCUT))-XL(1+MOD(I-1,N2),2)).GT.EPSX.OR. 2368 - - ABS(YCUT(1+MOD(J-1,NCUT))-YL(1+MOD(I-1,N2),2)).GT.EPSY).AND. 2369 - - (ABS(XCUT(1+MOD(J-1,NCUT))-XL(1+MOD(I ,N2),2)).GT.EPSX.OR. 2370 - - ABS(YCUT(1+MOD(J-1,NCUT))-YL(1+MOD(I ,N2),2)).GT.EPSY).AND. 2371 - - CROSSD( 2372 - - XPL (K ),YPL (K ), 2373 - - XCUT(1+MOD(J-1,NCUT)),YCUT(1+MOD(J-1,NCUT)), 2374 - - XL (1+MOD(I-1,N2),2),YL (1+MOD(I-1,N2),2), 2375 - - XL (1+MOD(I ,N2),2),YL (1+MOD(I ,N2),2)))GOTO 740 2376 - IF( (ABS(XCUT(1+MOD(J-1,NCUT))-XL(1+MOD(I-1,N2),2)).GT.EPSX.OR. 2377 - - ABS(YCUT(1+MOD(J-1,NCUT))-YL(1+MOD(I-1,N2),2)).GT.EPSY).AND. 2378 - - ONLIND( 2379 - - XPL (K ),YPL (K ), 2380 - - XCUT(1+MOD(J-1,NCUT)),YCUT(1+MOD(J-1,NCUT)), 2381 - - XL (1+MOD(I-1,N2),2),YL (1+MOD(I-1,N2),2)))GOTO 740 2382 - IF( (ABS(XCUT(1+MOD(J ,NCUT))-XL(1+MOD(I-1,N2),2)).GT.EPSX.OR. 2383 - - ABS(YCUT(1+MOD(J ,NCUT))-YL(1+MOD(I-1,N2),2)).GT.EPSY).AND. 2384 - - (ABS(XCUT(1+MOD(J ,NCUT))-XL(1+MOD(I ,N2),2)).GT.EPSX.OR. 2385 - - ABS(YCUT(1+MOD(J ,NCUT))-YL(1+MOD(I ,N2),2)).GT.EPSY).AND. 2386 - - CROSSD( 2387 - - XPL (K+1 ),YPL (K+1 ), 2388 - - XCUT(1+MOD(J ,NCUT)),YCUT(1+MOD(J ,NCUT)), 2389 - - XL (1+MOD(I-1,N2),2),YL (1+MOD(I-1,N2),2), 2390 - - XL (1+MOD(I ,N2),2),YL (1+MOD(I ,N2),2)))GOTO 740 2391 - IF( (ABS(XCUT(1+MOD(J ,NCUT))-XL(1+MOD(I-1,N2),2)).GT.EPSX.OR. 2392 - - ABS(YCUT(1+MOD(J ,NCUT))-YL(1+MOD(I-1,N2),2)).GT.EPSY).AND. 2393 - - ONLIND( 2394 - - XPL (K+1 ),YPL (K+1 ), 2395 - - XCUT(1+MOD(J ,NCUT)),YCUT(1+MOD(J ,NCUT)), 2396 - - XL (1+MOD(I-1,N2),2),YL (1+MOD(I-1,N2),2)))GOTO 740 2397 - 760 CONTINUE 2398 - * Check for intersects with the cut-out. 2399 - DO 755 I=1,NCUT 2400 - IF( 1+MOD(J-1,NCUT).NE.1+MOD(I-1,NCUT).AND. 2401 - - 1+MOD(J-1,NCUT).NE.1+MOD(I ,NCUT).AND. 2402 - - CROSSD( 2403 - - XPL (K ),YPL (K ), 2404 - - XCUT(1+MOD(J-1,NCUT)),YCUT(1+MOD(J-1,NCUT)), 2405 - - XCUT(1+MOD(I-1,NCUT)),YCUT(1+MOD(I-1,NCUT)), 2406 - - XCUT(1+MOD(I ,NCUT)),YCUT(1+MOD(I ,NCUT))))GOTO 740 2407 - IF( 1+MOD(J-1,NCUT).NE.1+MOD(I-1,NCUT).AND. 2408 - - ONLIND( 2409 - - XPL (K ),YPL (K ), 2410 - - XCUT(1+MOD(J-1,NCUT)),YCUT(1+MOD(J-1,NCUT)), 2411 - - XCUT(1+MOD(I-1,NCUT)),YCUT(1+MOD(I-1,NCUT))))GOTO 740 1 265 P=PROJECTI D=PLASPL 24 PAGE 369 2412 - IF( 1+MOD(J ,NCUT).NE.1+MOD(I-1,NCUT).AND. 2413 - - 1+MOD(J ,NCUT).NE.1+MOD(I ,NCUT).AND. 2414 - - CROSSD( 2415 - - XPL (K+1 ),YPL (K+1 ), 2416 - - XCUT(1+MOD(J ,NCUT)),YCUT(1+MOD(J ,NCUT)), 2417 - - XCUT(1+MOD(I-1,NCUT)),YCUT(1+MOD(I-1,NCUT)), 2418 - - XCUT(1+MOD(I ,NCUT)),YCUT(1+MOD(I ,NCUT))))GOTO 740 2419 - IF( 1+MOD(J ,NCUT).NE.1+MOD(I-1,NCUT).AND. 2420 - - ONLIND( 2421 - - XPL (K+1 ),YPL (K+1 ), 2422 - - XCUT(1+MOD(J ,NCUT)),YCUT(1+MOD(J ,NCUT)), 2423 - - XCUT(1+MOD(I-1,NCUT)),YCUT(1+MOD(I-1,NCUT))))GOTO 740 2424 - 755 CONTINUE 2425 - * Check for intersects with the curve. 2426 - DO 750 I=1,NPL 2427 - IF( K .NE.1+MOD(I-1,NPL).AND. 2428 - - K .NE.1+MOD(I ,NPL).AND. 2429 - - CROSSD( 2430 - - XPL (K ),YPL (K ), 2431 - - XCUT(1+MOD(J-1,NCUT)),YCUT(1+MOD(J-1,NCUT)), 2432 - - XPL (1+MOD(I-1,NPL )),YPL (1+MOD(I-1,NPL )), 2433 - - XPL (1+MOD(I ,NPL )),YPL (1+MOD(I ,NPL ))))GOTO 740 2434 - IF( K .NE.1+MOD(I-1,NPL).AND. 2435 - - ONLIND( 2436 - - XPL (K ),YPL (K ), 2437 - - XCUT(1+MOD(J-1,NCUT)),YCUT(1+MOD(J-1,NCUT)), 2438 - - XPL (1+MOD(I-1,NPL )),YPL (1+MOD(I-1,NPL ))))GOTO 740 2439 - IF( K+1.NE.1+MOD(I-1,NPL).AND. 2440 - - K+1.NE.1+MOD(I ,NPL).AND. 2441 - - CROSSD( 2442 - - XPL (K+1 ),YPL (K+1 ), 2443 - - XCUT(1+MOD(J ,NCUT)),YCUT(1+MOD(J ,NCUT)), 2444 - - XPL (1+MOD(I-1,NPL )),YPL (1+MOD(I-1,NPL )), 2445 - - XPL (1+MOD(I ,NPL )),YPL (1+MOD(I ,NPL ))))GOTO 740 2446 - IF( K+1.NE.1+MOD(I-1,NPL).AND. 2447 - - ONLIND( 2448 - - XPL (K+1 ),YPL (K+1 ), 2449 - - XCUT(1+MOD(J ,NCUT)),YCUT(1+MOD(J ,NCUT)), 2450 - - XPL (1+MOD(I-1,NPL )),YPL (1+MOD(I-1,NPL ))))GOTO 740 2451 - 750 CONTINUE 2452 - * Found a pair. 2453 - K0=K 2454 - K1=K+1 2455 - C call gspmci(1) 2456 - C call gsmk(4) 2457 - C call gpm2(1,xpl(k0),ypl(k0)) 2458 - C call gpm2(1,xpl(k1),ypl(k1)) 2459 - C print *,' Point 0 on curve: ',k0,xpl(k0),ypl(k0) 2460 - C print *,' Point 1 on curve: ',k1,xpl(k1),ypl(k1) 2461 - C print *,' (Range: ',1,npl,')' 2462 - J0=1+MOD(J-1,NCUT) 2463 - J1=1+MOD(J ,NCUT) 2464 - C call gsmk(2) 2465 - C call gpm2(1,xcut(j0),ycut(j0)) 2466 - C call gpm2(1,xcut(j1),ycut(j1)) 2467 - C print *,' Point 0 on cutout: ',j0,xcut(j0),ycut(j0) 2468 - C print *,' Point 1 on cutout: ',j1,xcut(j1),ycut(j1) 2469 - C print *,' (Range: ',1,ncut,')' 2470 - GOTO 780 2471 - * Continue loops. 2472 - 740 CONTINUE 2473 - 770 CONTINUE 2474 - * No connection found. 2475 - PRINT *,' !!!!!! PLASPL WARNING : Can''t connect cut-out'// 2476 - - ' to outer plane ; cut-out ignored.' 2477 - GOTO 1010 2478 - ** Constract the 2 halves and store separately. 2479 - 780 CONTINUE 2480 - * See whether we have memory for this at all. 2481 - IF(NCUT+NPL.GT.MXCORN.OR.NREF+2.GT.MXPLAN)THEN 2482 - PRINT *,' !!!!!! PLASPL WARNING : Lack of reference space'// 2483 - - ' or list length for cut-out.' 2484 - GOTO 1010 2485 - ENDIF 2486 - * See whether the junction lines cross. 2487 - IF(CROSSD(XPL(K0),YPL(K0),XCUT(J0),YCUT(J0), 2488 - - XPL(K1),YPL(K1),XCUT(J1),YCUT(J1)))THEN 2489 - IAUX=J1 2490 - J1=J0 2491 - J0=IAUX 2492 - C print *,' Interchanging J0/J1' 2493 - ENDIF 2494 - * First make the small 4-point loop. 2495 - XPL1(1)=XPL(K0) 2496 - YPL1(1)=YPL(K0) 2497 - ZPL1(1)=ZPL(K0) 2498 - XPL1(2)=XCUT(J0) 2499 - YPL1(2)=YCUT(J0) 2500 - ZPL1(2)=(DPL1-APL1*XCUT(J0)-BPL1*YCUT(J0))/CPL1 2501 - XPL1(3)=XCUT(J1) 2502 - YPL1(3)=YCUT(J1) 2503 - ZPL1(3)=(DPL1-APL1*XCUT(J1)-BPL1*YCUT(J1))/CPL1 2504 - XPL1(4)=XPL(K1) 2505 - YPL1(4)=YPL(K1) 2506 - ZPL1(4)=ZPL(K1) 2507 - NPL1=4 2508 - * Test to see whether this includes a point of the cut-out. 2509 - SWAP=.FALSE. 2510 - DO 820 I=1,NCUT 2511 - IF(I.EQ.J0.OR.I.EQ.J1)GOTO 820 2512 - CALL INTERD(NPL1,XPL1,YPL1,XCUT(I),YCUT(I),INSIDE,EDGE) 2513 - IF(INSIDE.OR.EDGE)SWAP=.TRUE. 2514 - 820 CONTINUE 2515 - C if(swap)print *,' Found an internal point of cut-out.' 2516 - * If there was, select the other branch. 2517 - IF(SWAP)THEN 1 265 P=PROJECTI D=PLASPL 25 PAGE 370 2518 - XPL1(1)=XPL(K0) 2519 - YPL1(1)=YPL(K0) 2520 - ZPL1(1)=ZPL(K0) 2521 - IF(MOD(J0-J1+NCUT,NCUT).EQ.+1)THEN 2522 - DO 830 J=J0,J1+NCUT 2523 - XPL1(1+J-J0+1)=XCUT(1+MOD(J-1,NCUT)) 2524 - YPL1(1+J-J0+1)=YCUT(1+MOD(J-1,NCUT)) 2525 - ZPL1(1+J-J0+1)=(DPL1-APL1*XPL1(1+J-J0+1)- 2526 - - BPL1*YPL1(1+J-J0+1))/CPL1 2527 - 830 CONTINUE 2528 - ELSE 2529 - DO 840 J=J0,J1-NCUT,-1 2530 - XPL1(1+J0-J+1)=XCUT(1+MOD(J-1+NCUT,NCUT)) 2531 - YPL1(1+J0-J+1)=YCUT(1+MOD(J-1+NCUT,NCUT)) 2532 - ZPL1(1+J0-J+1)=(DPL1-APL1*XPL1(1+J0-J+1)- 2533 - - BPL1*YPL1(1+J0-J+1))/CPL1 2534 - 840 CONTINUE 2535 - ENDIF 2536 - XPL1(NCUT+2)=XPL(K1) 2537 - YPL1(NCUT+2)=YPL(K1) 2538 - ZPL1(NCUT+2)=ZPL(K1) 2539 - NPL1=NCUT+2 2540 - ENDIF 2541 - C call gsln(1) 2542 - C call gsplci(8) 2543 - C call gpl2(npl1,xpl1,ypl1) 2544 - * Store this part of the curve. 2545 - CALL PLARED(NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1) 2546 - IF(NPL1.GE.3)THEN 2547 - NREF=NREF+1 2548 - CALL PLABU2('STORE',IREFO(NREF),NPL1,XPL1,YPL1,ZPL1, 2549 - - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) 2550 - IF(IFAIL1.NE.0)THEN 2551 - PRINT *,' !!!!!! PLASPL WARNING : Unable to store'// 2552 - - ' small half of a split plane.' 2553 - NREF=NREF-1 2554 - ENDIF 2555 - ENDIF 2556 - * Now make the large loop. 2557 - IF(SWAP)THEN 2558 - XPL2(1)=XCUT(J1) 2559 - YPL2(1)=YCUT(J1) 2560 - ZPL2(1)=(DPL1-APL1*XPL2(1)-BPL1*YPL2(1))/CPL1 2561 - XPL2(2)=XCUT(J0) 2562 - YPL2(2)=YCUT(J0) 2563 - ZPL2(2)=(DPL1-APL1*XPL2(2)-BPL1*YPL2(2))/CPL1 2564 - NPL2=2 2565 - ELSEIF(MOD(J1-J0+NCUT,NCUT).EQ.+1)THEN 2566 - DO 790 J=J1,J0+NCUT 2567 - XPL2(J-J1+1)=XCUT(1+MOD(J-1,NCUT)) 2568 - YPL2(J-J1+1)=YCUT(1+MOD(J-1,NCUT)) 2569 - ZPL2(J-J1+1)=(DPL1-APL1*XPL2(J-J1+1)- 2570 - - BPL1*YPL2(J-J1+1))/CPL1 2571 - 790 CONTINUE 2572 - NPL2=NCUT 2573 - ELSE 2574 - DO 810 J=J1,J0-NCUT,-1 2575 - XPL2(J1-J+1)=XCUT(1+MOD(J-1+NCUT,NCUT)) 2576 - YPL2(J1-J+1)=YCUT(1+MOD(J-1+NCUT,NCUT)) 2577 - ZPL2(J1-J+1)=(DPL1-APL1*XPL2(J1-J+1)- 2578 - - BPL1*YPL2(J1-J+1))/CPL1 2579 - 810 CONTINUE 2580 - NPL2=NCUT 2581 - ENDIF 2582 - DO 800 K=K0+NPL,K1,-1 2583 - XPL2(NPL2+K0+NPL-K+1)=XPL(1+MOD(K-1,NPL)) 2584 - YPL2(NPL2+K0+NPL-K+1)=YPL(1+MOD(K-1,NPL)) 2585 - ZPL2(NPL2+K0+NPL-K+1)=ZPL(1+MOD(K-1,NPL)) 2586 - 800 CONTINUE 2587 - NPL2=NPL2+NPL 2588 - C call gsln(1) 2589 - C call gsplci(12) 2590 - C call gpl2(npl2,xpl2,ypl2) 2591 - * Store this part of the curve. 2592 - CALL PLARED(NPL2,XPL2,YPL2,ZPL2,APL1,BPL1,CPL1,DPL1) 2593 - IF(NPL2.GE.3)THEN 2594 - NREF=NREF+1 2595 - CALL PLABU2('STORE',IREFO(NREF),NPL2,XPL2,YPL2,ZPL2, 2596 - - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL2) 2597 - IF(IFAIL2.NE.0)THEN 2598 - PRINT *,' !!!!!! PLASPL WARNING : Unable to store'// 2599 - - ' large half of a split plane.' 2600 - NREF=NREF-1 2601 - ENDIF 2602 - ENDIF 2603 - C call guwk(1,0) 2604 - C read *,iaux 2605 - ** Delete original plane and start from scratch. 2606 - CALL PLABU2('DELETE',IREFO(IR),NPL1,XPL1,YPL1,ZPL1, 2607 - - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) 2608 - IREFO(IR)=0 2609 - GOTO 1000 2610 - ** Continue with next plane. 2611 - 1010 CONTINUE 2612 - *** Seems to have worked. 2613 - IFAIL=0 2614 - END 266 GARFIELD ================================================== P=PROJECTI D=PLASRP 1 ============================ 0 + +DECK,PLASRP. 1 - SUBROUTINE PLASRP 2 - *----------------------------------------------------------------------- 3 - * PLASRP - Cuts the current set of planes to avoid overlaps and sorts 4 - * them for plotting, version for 3D impressions. 5 - * (Last changed on 19/11/98.) 1 266 P=PROJECTI D=PLASRP 2 PAGE 371 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,SOLIDS. 12 - INTEGER NPL1,NPL2,IVOL1,ICOL1,ICOL2,IFAIL1,IFAIL2, 13 - - I,J,K,L,NREF,NFIRST,NLAST,NNLAST, 14 - - IREF,IREFL(2*MXPLAN),IREFO(MXPLAN),NPLAN1,NPLAN2 15 - DOUBLE PRECISION XPL1(MXEDGE),YPL1(MXEDGE),ZPL1(MXEDGE), 16 - - XPL2(MXEDGE),YPL2(MXEDGE),ZPL2(MXEDGE), 17 - - APL1,BPL1,CPL1,DPL1,APL2,BPL2,CPL2,DPL2,VEC(3),FNORM, 18 - - XCUT,YCUT,ZCUT,XEMIN,XEMAX,YEMIN,YEMAX,ZEMIN,ZEMAX 19 - LOGICAL CROSSD,PLAGT,KEEP,MARK(2*MXPLAN) 20 - EXTERNAL CROSSD,PLAGT 21 - *** Identification output. 22 - IF(LIDENT)PRINT *,' /// ROUTINE PLASRP ///' 23 - *** Set the tolerances. 24 - CALL PLACO3(GXMIN,GYMIN,GZMIN,XCUT,YCUT,ZCUT) 25 - XEMIN=XCUT 26 - YEMIN=YCUT 27 - ZEMIN=ZCUT 28 - XEMAX=XCUT 29 - YEMAX=YCUT 30 - ZEMAX=ZCUT 31 - CALL PLACO3(GXMIN,GYMIN,GZMAX,XCUT,YCUT,ZCUT) 32 - IF(XCUT.LT.XEMIN)XEMIN=XCUT 33 - IF(XCUT.GT.XEMAX)XEMAX=XCUT 34 - IF(YCUT.LT.YEMIN)YEMIN=YCUT 35 - IF(YCUT.GT.YEMAX)YEMAX=YCUT 36 - IF(ZCUT.LT.ZEMIN)ZEMIN=ZCUT 37 - IF(ZCUT.GT.ZEMAX)ZEMAX=ZCUT 38 - CALL PLACO3(GXMIN,GYMAX,GZMIN,XCUT,YCUT,ZCUT) 39 - IF(XCUT.LT.XEMIN)XEMIN=XCUT 40 - IF(XCUT.GT.XEMAX)XEMAX=XCUT 41 - IF(YCUT.LT.YEMIN)YEMIN=YCUT 42 - IF(YCUT.GT.YEMAX)YEMAX=YCUT 43 - IF(ZCUT.LT.ZEMIN)ZEMIN=ZCUT 44 - IF(ZCUT.GT.ZEMAX)ZEMAX=ZCUT 45 - CALL PLACO3(GXMIN,GYMAX,GZMAX,XCUT,YCUT,ZCUT) 46 - IF(XCUT.LT.XEMIN)XEMIN=XCUT 47 - IF(XCUT.GT.XEMAX)XEMAX=XCUT 48 - IF(YCUT.LT.YEMIN)YEMIN=YCUT 49 - IF(YCUT.GT.YEMAX)YEMAX=YCUT 50 - IF(ZCUT.LT.ZEMIN)ZEMIN=ZCUT 51 - IF(ZCUT.GT.ZEMAX)ZEMAX=ZCUT 52 - CALL PLACO3(GXMAX,GYMIN,GZMIN,XCUT,YCUT,ZCUT) 53 - IF(XCUT.LT.XEMIN)XEMIN=XCUT 54 - IF(XCUT.GT.XEMAX)XEMAX=XCUT 55 - IF(YCUT.LT.YEMIN)YEMIN=YCUT 56 - IF(YCUT.GT.YEMAX)YEMAX=YCUT 57 - IF(ZCUT.LT.ZEMIN)ZEMIN=ZCUT 58 - IF(ZCUT.GT.ZEMAX)ZEMAX=ZCUT 59 - CALL PLACO3(GXMAX,GYMIN,GZMAX,XCUT,YCUT,ZCUT) 60 - IF(XCUT.LT.XEMIN)XEMIN=XCUT 61 - IF(XCUT.GT.XEMAX)XEMAX=XCUT 62 - IF(YCUT.LT.YEMIN)YEMIN=YCUT 63 - IF(YCUT.GT.YEMAX)YEMAX=YCUT 64 - IF(ZCUT.LT.ZEMIN)ZEMIN=ZCUT 65 - IF(ZCUT.GT.ZEMAX)ZEMAX=ZCUT 66 - CALL PLACO3(GXMAX,GYMAX,GZMIN,XCUT,YCUT,ZCUT) 67 - IF(XCUT.LT.XEMIN)XEMIN=XCUT 68 - IF(XCUT.GT.XEMAX)XEMAX=XCUT 69 - IF(YCUT.LT.YEMIN)YEMIN=YCUT 70 - IF(YCUT.GT.YEMAX)YEMAX=YCUT 71 - IF(ZCUT.LT.ZEMIN)ZEMIN=ZCUT 72 - IF(ZCUT.GT.ZEMAX)ZEMAX=ZCUT 73 - CALL PLACO3(GXMAX,GYMAX,GZMAX,XCUT,YCUT,ZCUT) 74 - IF(XCUT.LT.XEMIN)XEMIN=XCUT 75 - IF(XCUT.GT.XEMAX)XEMAX=XCUT 76 - IF(YCUT.LT.YEMIN)YEMIN=YCUT 77 - IF(YCUT.GT.YEMAX)YEMAX=YCUT 78 - IF(ZCUT.LT.ZEMIN)ZEMIN=ZCUT 79 - IF(ZCUT.GT.ZEMAX)ZEMAX=ZCUT 80 - CALL EPSSET('SET',1D-7*(XEMAX-XEMIN),1D-7*(YEMAX-YEMIN), 81 - - 1D-7*(ZEMAX-ZEMIN)) 82 - *** Progress printing. 83 - CALL PROFLD(1,'Counting planes',-1.0) 84 - CALL PROSTA(1,0.0) 85 - *** Find out how many planes are in store. 86 - CALL PLABU1('QUERY',NPLAN1,NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1, 87 - - ICOL1,IVOL1,IFAIL1) 88 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASRP DEBUG : Found '', 89 - - I5,'' geometric panels.'')') NPLAN1 90 - *** Reset the plot-plane buffer. 91 - CALL PROFLD(1,'Projecting planes',REAL(NPLAN1)) 92 - CALL PLABU2('RESET',IREF,NPL1,XPL2,YPL2,ZPL2, 93 - - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL2) 94 - *** Project the planes. 95 - NPLAN2=0 96 - DO 10 I=1,NPLAN1 97 - CALL PROSTA(1,REAL(I)) 98 - * Read plane. 99 - CALL PLABU1('READ',I,NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,ICOL1, 100 - - IVOL1,IFAIL1) 101 - * Skip empty and deleted planes. 102 - IF(IFAIL1.NE.0.OR.NPL1.LT.3)GOTO 10 103 - * Ensure that the plane is visible. 104 - IF(APL1*FPROJA+BPL1*FPROJB+CPL1*FPROJC.LT. 105 - - 1D-6*SQRT((APL1**2+BPL1**2+CPL1**2)* 106 - - (FPROJA**2+FPROJB**2+FPROJC**2)))THEN 107 - GOTO 10 108 - ENDIF 109 - * Project points, adjusting to box dimensions, also compute offset. 110 - C IF(IVOL1.GT.0)THEN 111 - CALL PLAPOL(GXMIN,GYMIN,GZMIN,GXMAX,GYMAX,GZMAX, 1 266 P=PROJECTI D=PLASRP 3 PAGE 372 112 - - XPL1,YPL1,ZPL1,NPL1,APL1,BPL1,CPL1,XPL2,YPL2,ZPL2,NPL2) 113 - C ELSE 114 - C DO 30 J=1,NPL1 115 - C CALL PLACO3(XPL1(J),YPL1(J),ZPL1(J),XPL2(J),YPL2(J),ZPL2(J)) 116 - C30 CONTINUE 117 - C NPL2=NPL1 118 - C ENDIF 119 - * Verify the resulting plane. 120 - CALL PLACHK(NPL2,XPL2,YPL2,ZPL2,IFAIL2) 121 - IF(IFAIL2.NE.0)GOTO 10 122 - * Compute the norm vector of the projected plane and re-check. 123 - VEC(1)=APL1 124 - VEC(2)=BPL1 125 - VEC(3)=CPL1 126 - CALL DFEQN(3,FPRMAT,3,IPRMAT,1,VEC) 127 - FNORM=SQRT(VEC(1)**2+VEC(2)**2+VEC(3)**2) 128 - IF(FNORM.LE.0.OR.NPL2.LE.2)THEN 129 - PRINT *,' !!!!!! PLASRP WARNING : Unable to project a'// 130 - - ' panel; panel skipped.' 131 - GOTO 10 132 - ENDIF 133 - APL2=VEC(1)/FNORM 134 - BPL2=VEC(2)/FNORM 135 - CPL2=VEC(3)/FNORM 136 - DPL2=0 137 - DO 20 J=1,NPL2 138 - DPL2=DPL2+APL2*XPL2(J)+BPL2*YPL2(J)+CPL2*ZPL2(J) 139 - 20 CONTINUE 140 - DPL2=DPL2/NPL2 141 - * Skip planes perpendicular to the view. 142 - IF(ABS(CPL2).LT.1.0E-2*SQRT(APL2**2+BPL2**2))GOTO 10 143 - * Store the projected plane. 144 - CALL PLABU2('STORE',IREF,NPL2,XPL2,YPL2,ZPL2, 145 - - APL2,BPL2,CPL2,DPL2,ICOL1,IFAIL2) 146 - IF(IFAIL2.NE.0)THEN 147 - PRINT *,' !!!!!! PLASRP WARNING : Storage error for a'// 148 - - ' projected plane ; plot likely to be incomplete.' 149 - ELSE 150 - IF(NPLAN2.GE.2*MXPLAN)GOTO 3010 151 - NPLAN2=NPLAN2+1 152 - IREFL(NPLAN2)=IREF 153 - ENDIF 154 - 10 CONTINUE 155 - * Debugging output. 156 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASRP DEBUG : Created '', 157 - - I5,'' projected planes.'')') NPLAN2 158 - *** Split planes that have hide each other in part. 159 - IF(LSPLIT)THEN 160 - CALL PROFLD(1,'Cutting overlaps',REAL(NPLAN2)) 161 - ** Loop over plane I, which is the one being cut. 162 - NFIRST=NPLAN2+1 163 - DO 100 I=1,NPLAN2 164 - * Progress printing. 165 - CALL PROSTA(1,REAL(I)) 166 - * Set the initial mark value. 167 - MARK(I)=.FALSE. 168 - * Copy its reference to the end. 169 - IREFL(NFIRST)=IREFL(I) 170 - * Initialise the counter of planes generated sofar. 171 - NLAST=NFIRST 172 - ** Loop over plane J, which is the one that cuts. 173 - DO 110 J=1,NPLAN2 174 - IF(I.EQ.J)GOTO 110 175 - ** Cut plane I with all other planes. 176 - NNLAST=NLAST 177 - DO 120 K=NFIRST,NNLAST 178 - IF(IREFL(K).EQ.0)GOTO 120 179 - * Perform the actual split. 180 - LGSIG=.FALSE. 181 - CALL PLASPL(IREFL(K),IREFL(J),NREF,IREFO,KEEP,IFAIL1) 182 - * Debugging output and quit when stop flag is set. 183 - IF(LGSTOP.AND.LGSIG)THEN 184 - PRINT *,' !!!!!! PLASRP WARNING : Separation error'// 185 - - ' detected ; generating dump and quitting.' 186 - CALL PLABU2('READ',IREFL(K),NPL1,XPL1,YPL1,ZPL1, 187 - - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) 188 - CALL PLABU2('READ',IREFL(J),NPL2,XPL2,YPL2,ZPL2, 189 - - APL2,BPL2,CPL2,DPL2,ICOL2,IFAIL2) 190 - OPEN(UNIT=12,FILE='plaspl.dat',STATUS='UNKNOWN') 191 - WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG 192 - WRITE(12,*) APL1,BPL1,CPL1,DPL1,ICOL1 193 - WRITE(12,*) NPL1 194 - DO 200 L=1,NPL1 195 - WRITE(12,*) XPL1(L),YPL1(L),ZPL1(L) 196 - 200 CONTINUE 197 - WRITE(12,*) APL2,BPL2,CPL2,DPL2,ICOL2 198 - WRITE(12,*) NPL2 199 - DO 210 L=1,NPL2 200 - WRITE(12,*) XPL2(L),YPL2(L),ZPL2(L) 201 - 210 CONTINUE 202 - CLOSE(12) 203 - CALL QUIT 204 - ENDIF 205 - * Store the result, delete the original. 206 - IF(IFAIL1.EQ.0.AND..NOT.KEEP)THEN 207 - IF(IREFL(K).NE.IREFL(I))THEN 208 - CALL PLABU2('DELETE',IREFL(K), 209 - - NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1, 210 - - ICOL1,IFAIL1) 211 - ELSE 212 - MARK(I)=.TRUE. 213 - ENDIF 214 - IREFL(K)=0 215 - IF(NREF.EQ.1.AND.IREFO(1).NE.0)THEN 216 - IREFL(K)=IREFO(1) 217 - ELSE 1 266 P=PROJECTI D=PLASRP 4 PAGE 373 218 - DO 130 L=1,NREF 219 - IF(IREFO(L).NE.0)THEN 220 - IF(NLAST.GE.2*MXPLAN)GOTO 3010 221 - NLAST=NLAST+1 222 - IREFL(NLAST)=IREFO(L) 223 - ENDIF 224 - 130 CONTINUE 225 - ENDIF 226 - ELSEIF(.NOT.KEEP)THEN 227 - PRINT *,' !!!!!! PLASRP WARNING : Unable to remove;'// 228 - - ' invisible parts ; keeping original.' 229 - ENDIF 230 - 120 CONTINUE 231 - ** Compress the list. 232 - NNLAST=NLAST 233 - NLAST=NFIRST-1 234 - DO 140 K=NFIRST,NNLAST 235 - IF(IREFL(K).EQ.0)GOTO 140 236 - NLAST=NLAST+1 237 - IREFL(NLAST)=IREFL(K) 238 - 140 CONTINUE 239 - * If there is not a single plane left, stop cutting. 240 - IF(NLAST.LT.NFIRST)GOTO 100 241 - ** Next plane that cuts. 242 - 110 CONTINUE 243 - ** Next plane being cut, update the start of list marker. 244 - IF(NLAST.GE.2*MXPLAN)GOTO 3010 245 - NFIRST=NLAST+1 246 - 100 CONTINUE 247 - ** Remove the original planes. 248 - DO 150 I=1,NPLAN2 249 - IF(MARK(I))CALL PLABU2('DELETE',IREFL(I), 250 - - NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) 251 - 150 CONTINUE 252 - ENDIF 253 - *** Sort the planes so that the backmost plane is plotted first. 254 - NQ=0 255 - CALL PROFLD(1,'Counting planes',-1.0) 256 - CALL PROSTA(1,0.0) 257 - DO 300 I=1,MXPLAN 258 - * Read the plane. 259 - CALL PLABU2('READ',I,NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1, 260 - - ICOL1,IFAIL1) 261 - * Skip if deleted or empty. 262 - IF(IFAIL1.NE.0.OR.NPL1.LE.2)GOTO 300 263 - * Compute largest offset. 264 - NQ=NQ+1 265 - * Store reference. 266 - IQ(NQ)=I 267 - 300 CONTINUE 268 - * Debugging output. 269 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASRP DEBUG : Created '', 270 - - I5,'' visible planes.'')') NQ 271 - * Sort the planes. 272 - IF(LSORT)THEN 273 - CALL PROFLD(1,'Sorting planes',-1.0) 274 - CALL PROSTA(1,0.0) 275 - CALL BSORT(IQ,NQ,PLAGT) 276 - ENDIF 277 - RETURN 278 - *** Error processing. 279 - 3010 CONTINUE 280 - PRINT *,' !!!!!! PLASRP WARNING : Removing invisible parts'// 281 - - ' generated too many sub-panels ; aborted.' 282 - END 267 GARFIELD ================================================== P=PROJECTI D=PLASRC 1 ============================ 0 + +DECK,PLASRC. 1 - SUBROUTINE PLASRC 2 - *----------------------------------------------------------------------- 3 - * PLASRC - Prepares the current set of volume cuts for plotting. 4 - * version for cut-throughs impressions. 5 - * (Last changed on 8/10/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,SOLIDS. 11 - INTEGER NPL,IVOL,ICOL,IFAIL,I,J,IREF,NPLANE,NCUT 12 - DOUBLE PRECISION XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), 13 - - APL,BPL,CPL,DPL,VEC(3),FNORM, 14 - - XCUT(MXEDGE),YCUT(MXEDGE),ZCUT(MXEDGE) 15 - *** Progress printing. 16 - CALL PROFLD(1,'Counting planes',-1.0) 17 - CALL PROSTA(1,0.0) 18 - *** Find out how many planes are in store. 19 - CALL PLABU1('QUERY',NPLANE,NPL,XPL,YPL,ZPL,APL,BPL,CPL, 20 - - ICOL,IVOL,IFAIL) 21 - *** Reset the plot-plane buffer. 22 - CALL PROFLD(1,'Copying planes',REAL(NPLANE)) 23 - CALL PLABU2('RESET',IREF,NPL,XPL,YPL,ZPL,APL,BPL,CPL,DPL, 24 - - ICOL,IFAIL) 25 - *** Copy the planes. 26 - NQ=0 27 - DO 10 I=1,NPLANE 28 - CALL PROSTA(1,REAL(I)) 29 - * Read plane. 30 - CALL PLABU1('READ',I,NPL,XPL,YPL,ZPL,APL,BPL,CPL,ICOL,IVOL,IFAIL) 31 - * Skip empty and deleted planes. 32 - IF(IFAIL.NE.0.OR.NPL.LT.3)GOTO 10 33 - * Project points, adjusting to box dimensions. 34 - CALL PLAPOL(GXMIN,GYMIN,GZMIN,GXMAX,GYMAX,GZMAX, 35 - - XPL,YPL,ZPL,NPL,APL,BPL,CPL,XCUT,YCUT,ZCUT,NCUT) 36 - * Verify the resulting plane. 37 - CALL PLACHK(NCUT,XCUT,YCUT,ZCUT,IFAIL) 1 267 P=PROJECTI D=PLASRC 2 PAGE 374 38 - IF(IFAIL.NE.0)GOTO 10 39 - * Compute normal vector. 40 - VEC(1)=APL 41 - VEC(2)=BPL 42 - VEC(3)=CPL 43 - CALL DFEQN(3,FPRMAT,3,IPRMAT,1,VEC) 44 - FNORM=SQRT(VEC(1)**2+VEC(2)**2+VEC(3)**2) 45 - IF(FNORM.LE.0.OR.NCUT.LE.2)THEN 46 - PRINT *,' !!!!!! PLASRC WARNING : Unable to project a'// 47 - - ' panel; panel skipped.' 48 - GOTO 10 49 - ENDIF 50 - APL=VEC(1)/FNORM 51 - BPL=VEC(2)/FNORM 52 - CPL=VEC(3)/FNORM 53 - DPL=0 54 - DO 20 J=1,NCUT 55 - DPL=DPL+APL*XCUT(J)+BPL*YCUT(J)+CPL*ZCUT(J) 56 - 20 CONTINUE 57 - DPL=DPL/NCUT 58 - * Store the projected plane. 59 - CALL PLABU2('STORE',IREF,NCUT,XCUT,YCUT,ZCUT,APL,BPL,CPL,DPL, 60 - - ICOL,IFAIL) 61 - IF(IFAIL.NE.0)THEN 62 - PRINT *,' !!!!!! PLASRC WARNING : Storage error for a'// 63 - - ' projected plane ; plot likely to be incomplete.' 64 - ELSE 65 - NQ=NQ+1 66 - IQ(NQ)=IREF 67 - ENDIF 68 - 10 CONTINUE 69 - END 268 GARFIELD ================================================== P=PROJECTI D=PLAGT 1 ============================ 0 + +DECK,PLAGT. 1 - LOGICAL FUNCTION PLAGT(I1,I2) 2 - *----------------------------------------------------------------------- 3 - * PLAGT - Determines whick plane partially overlaps the other. 4 - * (Last changed on 29/ 9/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9 - INTEGER I1,I2,NPL1,NPL2,ICOL1,ICOL2,IFAIL1,IFAIL2,I,J 10 - DOUBLE PRECISION XPL1(MXEDGE),YPL1(MXEDGE),ZPL1(MXEDGE), 11 - - XPL2(MXEDGE),YPL2(MXEDGE),ZPL2(MXEDGE), 12 - - APL1,BPL1,CPL1,DPL1,APL2,BPL2,CPL2,DPL2, 13 - - OFFSET,OFF1,OFF2,XC,YC,EPS,ZMAX,ZMIN 14 - LOGICAL INSIDE,EDGE,LT12,EQ12,GT12,CROSS 15 - *** If the planes are identical, return True. 16 - IF(I1.EQ.I2)THEN 17 - PLAGT=.TRUE. 18 - RETURN 19 - ENDIF 20 - *** Fetch both planes. 21 - CALL PLABU2('READ',I1,NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1, 22 - - ICOL1,IFAIL1) 23 - CALL PLABU2('READ',I2,NPL2,XPL2,YPL2,ZPL2,APL2,BPL2,CPL2,DPL2, 24 - - ICOL2,IFAIL2) 25 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.NPL1.LE.2.OR.NPL2.LE.2)THEN 26 - PRINT *,' !!!!!! PLAGT WARNING : Error fetching a plane'// 27 - - ' ; overlap set to False.' 28 - PLAGT=.FALSE. 29 - RETURN 30 - ENDIF 31 - *** Compute and epsilon for equality comparisons. 32 - IF(LEPSG)THEN 33 - EPS=EPSGZ 34 - ELSE 35 - ZMIN=ZPL1(1) 36 - ZMAX=ZPL1(1) 37 - DO 50 I=2,NPL1 38 - ZMIN=MIN(ZMIN,ZPL1(I)) 39 - ZMAX=MAX(ZMAX,ZPL1(I)) 40 - 50 CONTINUE 41 - DO 60 I=1,NPL2 42 - ZMIN=MIN(ZMIN,ZPL2(I)) 43 - ZMAX=MAX(ZMAX,ZPL2(I)) 44 - 60 CONTINUE 45 - EPS=1.0D-6*ABS(ZMAX-ZMIN) 46 - ENDIF 47 - *** Check for perpendicular planes. 48 - IF(CPL1.EQ.0.OR.CPL2.EQ.0)THEN 49 - PLAGT=.FALSE. 50 - RETURN 51 - ENDIF 52 - *** Initial setting of the flags. 53 - LT12=.FALSE. 54 - EQ12=.FALSE. 55 - GT12=.FALSE. 56 - *** Find the corners of 1 internal to 2. 57 - DO 10 I=1,NPL1 58 - CALL INTERD(NPL2,XPL2,YPL2,XPL1(I),YPL1(I),INSIDE,EDGE) 59 - * For these points, compute the offset projected on plane 2. 60 - IF(INSIDE.OR.EDGE)THEN 61 - OFFSET=(DPL2-APL2*XPL1(I)-BPL2*YPL1(I))/CPL2 62 - IF(ABS(OFFSET-ZPL1(I)).LT.EPS)THEN 63 - EQ12=.TRUE. 64 - ELSEIF(ZPL1(I).GT.OFFSET)THEN 65 - GT12=.TRUE. 66 - ELSEIF(ZPL1(I).LT.OFFSET)THEN 67 - LT12=.TRUE. 68 - ENDIF 69 - ENDIF 70 - 10 CONTINUE 1 268 P=PROJECTI D=PLAGT 2 PAGE 375 71 - *** Find the corners of 2 internal to 1. 72 - DO 20 I=1,NPL2 73 - CALL INTERD(NPL1,XPL1,YPL1,XPL2(I),YPL2(I),INSIDE,EDGE) 74 - * For these points, compute the offset projected on plane 1. 75 - IF(INSIDE.OR.EDGE)THEN 76 - OFFSET=(DPL1-APL1*XPL2(I)-BPL1*YPL2(I))/CPL1 77 - IF(ABS(OFFSET-ZPL2(I)).LT.EPS)THEN 78 - EQ12=.TRUE. 79 - ELSEIF(OFFSET.GT.ZPL2(I))THEN 80 - GT12=.TRUE. 81 - ELSEIF(OFFSET.LT.ZPL2(I))THEN 82 - LT12=.TRUE. 83 - ENDIF 84 - ENDIF 85 - 20 CONTINUE 86 - *** Check for mid-line intersects. 87 - DO 30 I=1,NPL1 88 - DO 40 J=1,NPL2 89 - CALL CRSPND( 90 - - XPL1(1+MOD(I-1,NPL1)),YPL1(1+MOD(I-1,NPL1)), 91 - - XPL1(1+MOD(I ,NPL1)),YPL1(1+MOD(I ,NPL1)), 92 - - XPL2(1+MOD(J-1,NPL2)),YPL2(1+MOD(J-1,NPL2)), 93 - - XPL2(1+MOD(J ,NPL2)),YPL2(1+MOD(J ,NPL2)), 94 - - XC,YC,CROSS) 95 - IF(CROSS)THEN 96 - OFF1=(DPL1-APL1*XC-BPL1*YC)/CPL1 97 - OFF2=(DPL2-APL2*XC-BPL2*YC)/CPL2 98 - IF(ABS(OFF1-OFF2).LT.EPS)THEN 99 - EQ12=.TRUE. 100 - ELSEIF(OFF1.GT.OFF2)THEN 101 - GT12=.TRUE. 102 - ELSEIF(OFF1.LT.OFF2)THEN 103 - LT12=.TRUE. 104 - ENDIF 105 - ENDIF 106 - 40 CONTINUE 107 - 30 CONTINUE 108 - *** Check the final flags. 109 - IF(LT12.AND.GT12)THEN 110 - PRINT *,' !!!!!! PLAGT WARNING : Planes probably'// 111 - - ' intersect ; plot probably incorrect.' 112 - PLAGT=.TRUE. 113 - ELSEIF(GT12)THEN 114 - PLAGT=.TRUE. 115 - ELSE 116 - PLAGT=.FALSE. 117 - ENDIF 118 - END 269 GARFIELD ================================================== P=PROJECTI D=PLAPLT 1 ============================ 0 + +DECK,PLAPLT. 1 - SUBROUTINE PLAPLT 2 - *----------------------------------------------------------------------- 3 - * PLAPLT - Plots the current set of planes. 4 - * (Last changed on 30/ 9/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,SOLIDS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,PRINTPLOT. 11 - DOUBLE PRECISION XPL(MXEDGE+1),YPL(MXEDGE+1),ZPL(MXEDGE+1), 12 - - APL,BPL,CPL,DPL 13 - INTEGER I,J,IVOL,ICOL,IFAIL,NPL,NWORD,INPCMP,NCSTR 14 - CHARACTER*20 STR 15 - EXTERNAL INPCMP 16 - *** Identification. 17 - IF(LIDENT)PRINT *,' /// ROUTINE PLAPLT ///' 18 - *** Open a segment so that we can later on pick out the wires. 19 - C CALL GCRSG(1) 20 - *** Make the solids detectable. 21 - C CALL GSDTEC(1,1) 22 - *** Plot the panels, prepare for requesting input if needed. 23 - IF(LGSTEP)THEN 24 - WRITE(LUNOUT,'('' Showing the '',I4,'' panels one at'', 25 - - '' the time, hit return or SHOW to proceed.'')') NQ 26 - CALL INPSWI('TERMINAL') 27 - ENDIF 28 - * Loop over the panels. 29 - DO 10 I=1,NQ 30 - * Read the panel. 31 - CALL PLABU2('READ',IQ(I),NPL,XPL,YPL,ZPL,APL,BPL,CPL,DPL, 32 - - ICOL,IFAIL) 33 - IF(IFAIL.NE.0.OR.NPL.LE.2)GOTO 10 34 - * Set a pick identifier for each solid separately. 35 - C CALL GSPKID(IVOL) 36 - * Set the representations. 37 - IF(ICOL.GE.50.AND.ICOL.LT.50+NPRCOL)THEN 38 - CALL GRATTS('CONDUCTORS-1','AREA') 39 - ELSE 40 - CALL GRATTS('DIELECTRIC-1','AREA') 41 - ENDIF 42 - * Set the colour. 43 - CALL GSFACI(ICOL) 44 - CALL GSPLCI(ICOL) 45 - * Add the last point to make a complete loop. 46 - NPL=NPL+1 47 - XPL(NPL)=XPL(1) 48 - YPL(NPL)=YPL(1) 49 - ZPL(NPL)=ZPL(1) 50 - * Plot the area. 51 - CALL GFA2(NPL,XPL,YPL) 52 - CALL GPL2(NPL,XPL,YPL) 53 - * Debugging. 54 - IF(LGSTEP)THEN 1 269 P=PROJECTI D=PLAPLT 2 PAGE 376 55 - CALL GUWK(1,0) 56 - CALL OUTFMT(REAL(I),2,STR,NCSTR,'LEFT') 57 - CALL INPPRM('Panel '//STR(1:NCSTR),'ADD-NOPRINT') 58 - CALL INPWRD(NWORD) 59 - CALL INPPRM(' ','BACK-PRINT') 60 - IF(NWORD.EQ.1.AND.INPCMP(1,'S#HOW')+ 61 - - INPCMP(1,'Y#ES').NE.0)THEN 62 - WRITE(LUNOUT,'('' Panel '',I3,'': reference='',I4, 63 - - '', colour='',I3,'', edges='',I3// 64 - - 11X,''x'',13X,''y'',13X,''z'')') I,IQ(I),ICOL,NPL 65 - DO 20 J=1,NPL 66 - WRITE(LUNOUT,'(3(2X,F12.5))') XPL(J),YPL(J),ZPL(J) 67 - 20 CONTINUE 68 - ELSEIF(NWORD.NE.0)THEN 69 - PRINT *,' !!!!!! PLAPLT WARNING : Unknown response ;'// 70 - - ' not showing details.' 71 - ENDIF 72 - ENDIF 73 - 10 CONTINUE 74 - * Restore input. 75 - IF(LGSTEP)CALL INPSWI('RESTORE') 76 - *** Close the segment for the solids. 77 - C CALL GCLSG 78 - *** Optionally also plot the outline. 79 - IF(LOUTL)THEN 80 - * Set the representation. 81 - CALL GRATTS('OUTLINE','POLYLINE') 82 - DO 1010 IVOL=1,NSOLID 83 - * cylinders ... 84 - IF(ISOLTP(IVOL).EQ.1)THEN 85 - C CALL PLACYO(IVOL) 86 - * cylindrical holes ... 87 - ELSEIF(ISOLTP(IVOL).EQ.2)THEN 88 - CALL PLACHO(IVOL) 89 - * boxes ... 90 - ELSEIF(ISOLTP(IVOL).EQ.3)THEN 91 - CALL PLABXO(IVOL) 92 - * spheres ... 93 - ELSEIF(ISOLTP(IVOL).EQ.4)THEN 94 - C CALL PLASPO(IVOL) 95 - * other things not known. 96 - ELSE 97 - PRINT *,' !!!!!! PLAPLT WARNING : Asked to plot an'// 98 - - ' outline of unknown type ',ISOLTP(IVOL), 99 - - '; not plotted.' 100 - ENDIF 101 - 1010 CONTINUE 102 - ENDIF 103 - END 270 GARFIELD ================================================== P=PROJECTI D=PLALAM 1 ============================ 0 + +DECK,PLALAM. 1 - SUBROUTINE PLALAM(X1,X0,X2,Y1,Y0,Y2,XLAM) 2 - *----------------------------------------------------------------------- 3 - * PLALAM - Computes lambda for a point on a line (0 = start, 1 = end). 4 - * (Last changed on 20/ 1/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - DOUBLE PRECISION X1,X0,X2,Y0,Y1,Y2,XLAM 8 - *** Segment of zero length. 9 - IF((X1-X2).EQ.0.AND.(Y1-Y2).EQ.0)THEN 10 - PRINT *,' !!!!!! PLALAM WARNING : Zero length segment.' 11 - XLAM=2 12 - *** Point nearer to (X1,Y1). 13 - ELSEIF((X0-X1)**2+(Y0-Y1)**2.LT.(X0-X2)**2+(Y0-Y2)**2)THEN 14 - IF(ABS(Y1-Y2).GT.ABS(X1-X2))THEN 15 - XLAM=(Y0-Y1)/(Y2-Y1) 16 - ELSE 17 - XLAM=(X0-X1)/(X2-X1) 18 - ENDIF 19 - *** Point nearer to (X2,Y2). 20 - ELSE 21 - IF(ABS(Y1-Y2).GT.ABS(X1-X2))THEN 22 - XLAM=1-(Y0-Y2)/(Y1-Y2) 23 - ELSE 24 - XLAM=1-(X0-X2)/(X1-X2) 25 - ENDIF 26 - ENDIF 27 - END 271 GARFIELD ================================================== P=PROJECTI D=PLABU1 1 ============================ 0 + +DECK,PLABU1. 1 - SUBROUTINE PLABU1(ACTION,IREF,NPL,XPL,YPL,ZPL,APL,BPL,CPL, 2 - - ICOL,IVOL,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * PLABU1 - Stores planes of surfaces. 5 - * (Last changed on 8/ 1/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PRINTPLOT. 10 - DOUBLE PRECISION XBUF(MXPOIN),YBUF(MXPOIN),ZBUF(MXPOIN), 11 - - ABUF(MXPLAN),BBUF(MXPLAN),CBUF(MXPLAN), 12 - - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE),APL,BPL,CPL 13 - C double precision dpl 14 - INTEGER ICBUF(MXPLAN),IVBUF(MXPLAN),NBUF(MXPLAN),ISTART(MXPLAN), 15 - - ICURR,IND(MXPLAN),II,IREF,NPL,ICOL,IVOL,IFAIL,I,J 16 - LOGICAL USE(MXPLAN) 17 - CHARACTER*(*) ACTION 1 271 P=PROJECTI D=PLABU1 2 PAGE 377 18-+ +SELF,IF=SAVE. 19 - SAVE NBUF,XBUF,YBUF,ZBUF,ABUF,BBUF,CBUF,IVBUF,ICBUF, 20 - - ISTART,ICURR,USE 0 21-+ +SELF. 22 - DATA ICURR/0/,USE/MXPLAN*.FALSE./,ISTART/MXPLAN*-1/ 23 - *** Assume failure. 24 - IFAIL=1 25 - *** Store a new plane. 26 - IF(ACTION.EQ.'STORE')THEN 27 - * Basic check on the data. 28 - IF(NPL.LT.0.OR.NPL.GT.MXEDGE)THEN 29 - PRINT *,' !!!!!! PLABU1 WARNING : Number of points'// 30 - - ' on polygon < 0 or > MXEDGE ; not stored.' 31 - RETURN 32 - ENDIF 33 - * See whether there is a free slot. 34 - IREF=0 35 - DO 10 I=1,MXPLAN 36 - IF(.NOT.USE(I))THEN 37 - IREF=I 38 - GOTO 20 39 - ENDIF 40 - 10 CONTINUE 41 - PRINT *,' !!!!!! PLABU1 WARNING : No room to store'// 42 - - ' further polygons ; increase MXPLAN.' 43 - RETURN 44 - 20 CONTINUE 45 - * See whether there is free space, garbage collect if not. 46 - IF(ICURR+NPL.GT.MXPOIN)THEN 47 - CALL SORTZV(ISTART,IND,MXPLAN,-1,0,0) 48 - ICURR=0 49 - DO 30 II=1,MXPLAN 50 - I=IND(II) 51 - IF(ISTART(I).LT.0.OR..NOT.USE(I))GOTO 30 52 - DO 40 J=1,NBUF(I) 53 - XBUF(ICURR+J)=XBUF(ISTART(I)+J) 54 - YBUF(ICURR+J)=YBUF(ISTART(I)+J) 55 - ZBUF(ICURR+J)=ZBUF(ISTART(I)+J) 56 - 40 CONTINUE 57 - ISTART(I)=ICURR 58 - ICURR=ICURR+NBUF(I) 59 - 30 CONTINUE 60 - ENDIF 61 - * See whether there now is enough space. 62 - IF(ICURR+NPL.GT.MXPOIN)THEN 63 - PRINT *,' !!!!!! PLABU1 WARNING : No room to store'// 64 - - ' further points; increase MXPOIN.' 65 - RETURN 66 - ENDIF 67 - * Store the polygon. 68 - ISTART(IREF)=ICURR 69 - USE(IREF)=.TRUE. 70 - NBUF(IREF)=NPL 71 - ABUF(IREF)=APL 72 - BBUF(IREF)=BPL 73 - CBUF(IREF)=CPL 74 - ICBUF(IREF)=ICOL 75 - IVBUF(IREF)=IVOL 76 - C dpl=0 77 - DO 50 I=1,NPL 78 - XBUF(ISTART(IREF)+I)=XPL(I) 79 - YBUF(ISTART(IREF)+I)=YPL(I) 80 - ZBUF(ISTART(IREF)+I)=ZPL(I) 81 - C dpl=dpl+apl*xpl(i)+bpl*ypl(i)+cpl*zpl(i) 82 - 50 CONTINUE 83 - C dpl=dpl/npl 84 - C do i=1,npl 85 - C if(abs(dpl-xpl(i)*apl-ypl(i)*bpl-zpl(i)*cpl).gt.1e-4)then 86 - C print *,' PLABU1 Offset Error: ' 87 - C print *,' Point: ',xpl(i),ypl(i),zpl(i) 88 - C print *,' Error: ',dpl-xpl(i)*apl-ypl(i)*bpl- 89 - C - cpl*zpl(i) 90 - C endif 91 - C enddo 92 - ICURR=ICURR+NPL 93 - *** Read back a plane. 94 - ELSEIF(ACTION.EQ.'READ')THEN 95 - * Basic checks of the index. 96 - IF(IREF.LT.1.OR.IREF.GT.MXPLAN)THEN 97 - PRINT *,' !!!!!! PLABU1 WARNING : Polygon reference'// 98 - - ' number out of range; not read.' 99 - RETURN 100 - ELSEIF(.NOT.USE(IREF))THEN 101 - IF(LDEBUG)PRINT *,' ++++++ PLABU1 DEBUG :'// 102 - - ' Requested polygon is not defined; not read.' 103 - RETURN 104 - ENDIF 105 - * Return the polygon. 106 - DO 100 I=1,NBUF(IREF) 107 - XPL(I)=XBUF(ISTART(IREF)+I) 108 - YPL(I)=YBUF(ISTART(IREF)+I) 109 - ZPL(I)=ZBUF(ISTART(IREF)+I) 110 - 100 CONTINUE 111 - APL=ABUF(IREF) 112 - BPL=BBUF(IREF) 113 - CPL=CBUF(IREF) 114 - ICOL=ICBUF(IREF) 115 - IVOL=IVBUF(IREF) 116 - NPL=NBUF(IREF) 117 - *** Delete a plane. 118 - ELSEIF(ACTION.EQ.'DELETE')THEN 119 - * Basic checks of the index. 120 - IF(IREF.LT.1.OR.IREF.GT.MXPLAN)THEN 121 - PRINT *,' !!!!!! PLABU1 WARNING : Polygon reference'// 122 - - ' number out of range; not deleted.' 1 271 P=PROJECTI D=PLABU1 3 PAGE 378 123 - RETURN 124 - ELSEIF(.NOT.USE(IREF))THEN 125 - PRINT *,' ------ PLABU1 MESSAGE : Requested polygon'// 126 - - ' is currently not defined.' 127 - RETURN 128 - ENDIF 129 - * Delete the polygon. 130 - USE(IREF)=.FALSE. 131 - ISTART(IREF)=-1 132 - *** Reset the buffer. 133 - ELSEIF(ACTION.EQ.'RESET'.OR.ACTION.EQ.'INITIALISE')THEN 134 - ICURR=0 135 - DO 200 I=1,MXPLAN 136 - NBUF(I)=0 137 - USE(I)=.FALSE. 138 - ISTART(I)=-1 139 - 200 CONTINUE 140 - *** List the buffer. 141 - ELSEIF(ACTION.EQ.'LIST'.OR.ACTION.EQ.'PRINT')THEN 142 - DO 300 I=1,MXPLAN 143 - IF(USE(I))THEN 144 - WRITE(LUNOUT,'(2X,''Polygon '',I4,'' is stored '', 145 - - '' from '',I4)') I,ISTART(I) 146 - WRITE(LUNOUT,'(2X,''Colour index: '',I5)') ICBUF(I) 147 - WRITE(LUNOUT,'(2X,''Volume index: '',I5)') IVBUF(I) 148 - WRITE(LUNOUT,'(2X,''Plane parameters: '',3E15.8)') 149 - - ABUF(I),BBUF(I),CBUF(I) 150 - WRITE(LUNOUT,'(2X,''Number of points: '',I5)') 151 - - NBUF(I) 152 - DO 310 J=1,NBUF(I) 153 - WRITE(LUNOUT,'(10X,3E15.8)') XBUF(ISTART(I)+J), 154 - - YBUF(ISTART(I)+J),ZBUF(ISTART(I)+J) 155 - 310 CONTINUE 156 - ENDIF 157 - 300 CONTINUE 158 - *** Query of maximum numbers. 159 - ELSEIF(ACTION.EQ.'QUERY')THEN 160 - DO 400 I=MXPLAN,1,-1 161 - IF(USE(I))THEN 162 - IREF=I 163 - GOTO 410 164 - ENDIF 165 - 400 CONTINUE 166 - IREF=0 167 - 410 CONTINUE 168 - *** Other actions not known. 169 - ELSE 170 - PRINT *,' !!!!!! PLABU1 WARNING : Unknown action ', 171 - - ACTION,' received ; nothing done.' 172 - IFAIL=1 173 - RETURN 174 - ENDIF 175 - *** Seems to have worked. 176 - IFAIL=0 177 - END 272 GARFIELD ================================================== P=PROJECTI D=PLABU2 1 ============================ 0 + +DECK,PLABU2. 1 - SUBROUTINE PLABU2(ACTION,IREF,NPL,XPL,YPL,ZPL,APL,BPL,CPL,DPL, 2 - - ICOL,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * PLABU2 - Stores projected planes of surfaces. 5 - * (Last changed on 29/ 9/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PRINTPLOT. 10 - DOUBLE PRECISION XBUF(MXPOIN),YBUF(MXPOIN),ZBUF(MXPOIN), 11 - - ABUF(MXPLAN),BBUF(MXPLAN),CBUF(MXPLAN),DBUF(MXPLAN), 12 - - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE),APL,BPL,CPL,DPL 13 - INTEGER ICBUF(MXPLAN),NBUF(MXPLAN),ISTART(MXPLAN),ICURR, 14 - - IREF,NPL,ICOL,IFAIL,I,J,IND(MXPLAN),II 15 - LOGICAL USE(MXPLAN) 16 - CHARACTER*(*) ACTION 0 17-+ +SELF,IF=SAVE. 18 - SAVE NBUF,XBUF,YBUF,ZBUF,ABUF,BBUF,CBUF,DBUF,ICBUF, 19 - - ISTART,ICURR,USE 0 20-+ +SELF. 21 - DATA ICURR/0/,USE/MXPLAN*.FALSE./,ISTART/MXPLAN*-1/ 22 - *** Assume failure. 23 - IFAIL=1 24 - *** Store a new plane. 25 - IF(ACTION.EQ.'STORE')THEN 26 - * Basic check on the data. 27 - IF(NPL.LT.0.OR.NPL.GT.MXEDGE)THEN 28 - PRINT *,' !!!!!! PLABU2 WARNING : Number of points'// 29 - - ' on polygon < 0 or > MXEDGE ; not stored.' 30 - RETURN 31 - ENDIF 32 - * See whether there is a free slot. 33 - IREF=0 34 - DO 10 I=1,MXPLAN 35 - IF(.NOT.USE(I))THEN 36 - IREF=I 37 - GOTO 20 38 - ENDIF 39 - 10 CONTINUE 40 - PRINT *,' !!!!!! PLABU2 WARNING : No room to store'// 41 - - ' further polygons ; increase MXPLAN.' 42 - RETURN 43 - 20 CONTINUE 44 - * See whether there is free space, garbage collect if not. 45 - IF(ICURR+NPL.GT.MXPOIN)THEN 1 272 P=PROJECTI D=PLABU2 2 PAGE 379 46 - CALL SORTZV(ISTART,IND,MXPLAN,-1,0,0) 47 - ICURR=0 48 - DO 30 II=1,MXPLAN 49 - I=IND(II) 50 - IF(ISTART(I).LT.0.OR..NOT.USE(I))GOTO 30 51 - DO 40 J=1,NBUF(I) 52 - XBUF(ICURR+J)=XBUF(ISTART(I)+J) 53 - YBUF(ICURR+J)=YBUF(ISTART(I)+J) 54 - ZBUF(ICURR+J)=ZBUF(ISTART(I)+J) 55 - 40 CONTINUE 56 - ISTART(I)=ICURR 57 - ICURR=ICURR+NBUF(I) 58 - 30 CONTINUE 59 - ENDIF 60 - * See whether there now is enough space. 61 - IF(ICURR+NPL.GT.MXPOIN)THEN 62 - PRINT *,' !!!!!! PLABU2 WARNING : No room to store'// 63 - - ' further points; increase MXPOIN.' 64 - RETURN 65 - ENDIF 66 - * Store the polygon. 67 - ISTART(IREF)=ICURR 68 - USE(IREF)=.TRUE. 69 - NBUF(IREF)=NPL 70 - ABUF(IREF)=APL 71 - BBUF(IREF)=BPL 72 - CBUF(IREF)=CPL 73 - DBUF(IREF)=DPL 74 - ICBUF(IREF)=ICOL 75 - DO 50 I=1,NPL 76 - XBUF(ISTART(IREF)+I)=XPL(I) 77 - YBUF(ISTART(IREF)+I)=YPL(I) 78 - ZBUF(ISTART(IREF)+I)=ZPL(I) 79 - C if(abs(dpl-xpl(i)*apl-ypl(i)*bpl-zpl(i)*cpl).gt.1e-4)then 80 - C print *,' PLABU2 Offset Error: ' 81 - C print *,' Point: ',xpl(i),ypl(i),zpl(i) 82 - C print *,' Error: ',dpl-xpl(i)*apl-ypl(i)*bpl- 83 - C - cpl*zpl(i) 84 - C endif 85 - 50 CONTINUE 86 - ICURR=ICURR+NPL 87 - *** Read back a plane. 88 - ELSEIF(ACTION.EQ.'READ')THEN 89 - * Basic checks of the index. 90 - IF(IREF.LT.1.OR.IREF.GT.MXPLAN)THEN 91 - PRINT *,' !!!!!! PLABU2 WARNING : Polygon reference'// 92 - - ' number out of range; not read.' 93 - RETURN 94 - ELSEIF(.NOT.USE(IREF))THEN 95 - IF(LDEBUG)PRINT *,' ++++++ PLABU2 DEBUG :'// 96 - - ' Requested polygon is not defined; not read.' 97 - RETURN 98 - ENDIF 99 - * Return the polygon. 100 - APL=ABUF(IREF) 101 - BPL=BBUF(IREF) 102 - CPL=CBUF(IREF) 103 - DPL=DBUF(IREF) 104 - DO 100 I=1,NBUF(IREF) 105 - XPL(I)=XBUF(ISTART(IREF)+I) 106 - YPL(I)=YBUF(ISTART(IREF)+I) 107 - ZPL(I)=ZBUF(ISTART(IREF)+I) 108 - 100 CONTINUE 109 - ICOL=ICBUF(IREF) 110 - NPL=NBUF(IREF) 111 - *** Delete a plane. 112 - ELSEIF(ACTION.EQ.'DELETE')THEN 113 - * Basic checks of the index. 114 - IF(IREF.LT.1.OR.IREF.GT.MXPLAN)THEN 115 - PRINT *,' !!!!!! PLABU2 WARNING : Polygon reference'// 116 - - ' number out of range; not deleted.' 117 - RETURN 118 - ELSEIF(.NOT.USE(IREF))THEN 119 - PRINT *,' ------ PLABU2 MESSAGE : Requested polygon'// 120 - - ' is currently not defined.' 121 - RETURN 122 - ENDIF 123 - * Delete the polygon. 124 - USE(IREF)=.FALSE. 125 - ISTART(IREF)=-1 126 - *** Reset the buffer. 127 - ELSEIF(ACTION.EQ.'RESET'.OR.ACTION.EQ.'INITIALISE')THEN 128 - ICURR=0 129 - DO 200 I=1,MXPLAN 130 - NBUF(I)=0 131 - USE(I)=.FALSE. 132 - ISTART(I)=-1 133 - 200 CONTINUE 134 - *** List the buffer. 135 - ELSEIF(ACTION.EQ.'LIST'.OR.ACTION.EQ.'PRINT')THEN 136 - DO 300 I=1,MXPLAN 137 - IF(USE(I))THEN 138 - WRITE(LUNOUT,'(2X,''Polygon '',I4,'' is stored '', 139 - - '' from '',I4)') I,ISTART(I) 140 - WRITE(LUNOUT,'(2X,''Colour index: '',I5)') ICBUF(I) 141 - WRITE(LUNOUT,'(2X,''Plane parameters: '',4E15.8)') 142 - - ABUF(I),BBUF(I),CBUF(I),DBUF(I) 143 - WRITE(LUNOUT,'(2X,''Number of points: '',I5)') 144 - - NBUF(I) 145 - DO 310 J=1,NBUF(I) 146 - WRITE(LUNOUT,'(10X,3E15.8)') XBUF(ISTART(I)+J), 147 - - YBUF(ISTART(I)+J),ZBUF(ISTART(I)+J) 148 - 310 CONTINUE 149 - ENDIF 150 - 300 CONTINUE 151 - *** Query of maximum numbers. 1 272 P=PROJECTI D=PLABU2 3 PAGE 380 152 - ELSEIF(ACTION.EQ.'QUERY')THEN 153 - DO 400 I=MXPLAN,1,-1 154 - IF(USE(I))THEN 155 - IREF=I 156 - GOTO 410 157 - ENDIF 158 - 400 CONTINUE 159 - IREF=0 160 - 410 CONTINUE 161 - *** Other actions not known. 162 - ELSE 163 - PRINT *,' !!!!!! PLABU2 WARNING : Unknown action ', 164 - - ACTION,' received ; nothing done.' 165 - IFAIL=1 166 - RETURN 167 - ENDIF 168 - *** Seems to have worked. 169 - IFAIL=0 170 - END 273 GARFIELD ================================================== P=ROUTINES D= 1 ============================ 0 + +PATCH,ROUTINES. 274 GARFIELD ================================================== P=ROUTINES D=ARGGET 1 ============================ 0 + +DECK,ARGGET,IF=UNIX. 1 - subroutine argget(iarg,string,nc) 2 - *----------------------------------------------------------------------- 3 - * ARGGET - Returns an argument with its length, for Unix systems only. 4 - * (Last changed on 4/ 6/92.) 5 - *----------------------------------------------------------------------- 6 - character*(*) string 7 - call getarg(iarg,string) 8 - do i=len(string),1,-1 9 - if(string(i:i).ne.' ')then 10 - nc=i 11 - return 12 - endif 13 - enddo 14 - nc=0 15 - end 275 GARFIELD ================================================== P=ROUTINES D=BOXIN2 1 ============================ 0 + +DECK,BOXIN2. 1 - SUBROUTINE BOXIN2(VALUE,XAXIS,YAXIS,MAXX,MAXY,NX,NY,X,Y,F,IORDER, 2 - - IFAIL) 3 - *----------------------------------------------------------------------- 4 - * BOXIN2 - Interpolation of order 1 and 2 in an irregular rectangular 5 - * 2-dimensional grid. 6 - * (Last changed on 24/ 1/00.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9 - INTEGER MAXX,MAXY,NX,NY,IORDER,IFAIL,I,INODE,IGRID,IX,IX0,IX1, 10 - - IY,IY0,IY1 11 - REAL VALUE(MAXX,MAXY),XAXIS(MAXX),YAXIS(MAXY),X,Y,F,DIST, 12 - - XLOCAL,YLOCAL,XALPHA,YALPHA,FX(3),FY(3) 13 - *** Ensure we are in the grid. 14 - IF((XAXIS(NX)-X)*(X-XAXIS(1)).LT.0.OR. 15 - - (YAXIS(NY)-Y)*(Y-YAXIS(1)).LT.0)THEN 16 - C PRINT *,' !!!!!! BOXIN2 WARNING : Point not in the grid;'// 17 - C ' no interpolation.' 18 - F=0 19 - IFAIL=1 20 - RETURN 21 - * Make sure we have enough points. 22 - ELSEIF(IORDER.LT.0.OR.IORDER.GT.2.OR. 23 - - NX.LT.1.OR.NX.GT.MAXX.OR.NY.LT.1.OR.NY.GT.MAXY)THEN 24 - PRINT *,' !!!!!! BOXIN2 WARNING : Incorrect order or'// 25 - - ' number of points; no interpolation.' 26 - F=0 27 - IFAIL=1 28 - RETURN 29 - ENDIF 30 - *** Zeroth order interpolation in x. 31 - IF(IORDER.EQ.0.OR.NX.LE.1)THEN 32 - * Find the nearest node. 33 - DIST=ABS(X-XAXIS(1)) 34 - INODE=1 35 - DO 10 I=2,NX 36 - IF(ABS(X-XAXIS(I)).LT.DIST)THEN 37 - DIST=ABS(X-XAXIS(I)) 38 - INODE=I 39 - ENDIF 40 - 10 CONTINUE 41 - * Set the summing range. 42 - IX0=INODE 43 - IX1=INODE 44 - * Establish the shape functions. 45 - FX(1)=1 46 - FX(2)=0 47 - FX(3)=0 48 - *** First order interpolation in x. 49 - ELSEIF(IORDER.EQ.1.OR.NX.LE.2)THEN 50 - * Find the grid segment containing this point. 51 - IGRID=0 52 - DO 20 I=2,NX 53 - IF((XAXIS(I-1)-X)*(X-XAXIS(I)).GE.0)IGRID=I 54 - 20 CONTINUE 55 - * Ensure there won't be divisions by zero. 56 - IF(XAXIS(IGRID).EQ.XAXIS(IGRID-1))THEN 57 - PRINT *,' !!!!!! BOXIN2 WARNING : Incorrect grid;'// 58 - - ' no interpolation.' 59 - F=0 60 - IFAIL=1 1 275 P=ROUTINES D=BOXIN2 2 PAGE 381 61 - RETURN 62 - ENDIF 63 - * Compute local coordinates. 64 - XLOCAL=(X-XAXIS(IGRID-1))/(XAXIS(IGRID)-XAXIS(IGRID-1)) 65 - * Set the summing range. 66 - IX0=IGRID-1 67 - IX1=IGRID 68 - * Set the shape functions. 69 - FX(1)=1-XLOCAL 70 - FX(2)=XLOCAL 71 - FX(3)=0 72 - *** Second order interpolation in x. 73 - ELSEIF(IORDER.EQ.2)THEN 74 - * Find the nearest node and the grid segment. 75 - DIST=ABS(X-XAXIS(1)) 76 - INODE=1 77 - DO 30 I=2,NX 78 - IF(ABS(X-XAXIS(I)).LT.DIST)THEN 79 - DIST=ABS(X-XAXIS(I)) 80 - INODE=I 81 - ENDIF 82 - 30 CONTINUE 83 - * Find the nearest fitting 2x2 matrix. 84 - IGRID=MAX(2,MIN(NX-1,INODE)) 85 - * Ensure there won't be divisions by zero. 86 - IF(XAXIS(IGRID+1).EQ.XAXIS(IGRID-1))THEN 87 - PRINT *,' !!!!!! BOXIN2 WARNING : Incorrect grid;'// 88 - - ' no interpolation.' 89 - F=0 90 - IFAIL=1 91 - RETURN 92 - ENDIF 93 - * Compute the alpha and local coordinate for this grid segment. 94 - XALPHA=(XAXIS(IGRID)-XAXIS(IGRID-1))/ 95 - - (XAXIS(IGRID+1)-XAXIS(IGRID-1)) 96 - XLOCAL=(X-XAXIS(IGRID-1))/(XAXIS(IGRID+1)-XAXIS(IGRID-1)) 97 - * Ensure there won't be divisions by zero. 98 - IF(XALPHA.LE.0.OR.XALPHA.GE.1)THEN 99 - PRINT *,' !!!!!! BOXIN2 WARNING : Incorrect grid;'// 100 - - ' no interpolation.' 101 - F=0 102 - IFAIL=1 103 - RETURN 104 - ENDIF 105 - * Set the summing range. 106 - IX0=IGRID-1 107 - IX1=IGRID+1 108 - * Set the shape functions. 109 - FX(1)=XLOCAL**2/XALPHA-XLOCAL*(1+XALPHA)/XALPHA+1 110 - FX(2)=(XLOCAL**2-XLOCAL)/(XALPHA**2-XALPHA) 111 - FX(3)=(XLOCAL**2-XLOCAL*XALPHA)/(1-XALPHA) 112 - ENDIF 113 - *** Zeroth order interpolation in y. 114 - IF(IORDER.EQ.0.OR.NY.LE.1)THEN 115 - * Find the nearest node. 116 - DIST=ABS(Y-YAXIS(1)) 117 - INODE=1 118 - DO 40 I=2,NY 119 - IF(ABS(Y-YAXIS(I)).LT.DIST)THEN 120 - DIST=ABS(Y-YAXIS(I)) 121 - INODE=I 122 - ENDIF 123 - 40 CONTINUE 124 - * Set the summing range. 125 - IY0=INODE 126 - IY1=INODE 127 - * Establish the shape functions. 128 - FY(1)=1 129 - FY(2)=0 130 - FY(3)=0 131 - *** First order interpolation in y. 132 - ELSEIF(IORDER.EQ.1.OR.NY.LE.2)THEN 133 - * Find the grid segment containing this point. 134 - IGRID=0 135 - DO 50 I=2,NY 136 - IF((YAXIS(I-1)-Y)*(Y-YAXIS(I)).GE.0)IGRID=I 137 - 50 CONTINUE 138 - * Ensure there won't be divisions by zero. 139 - IF(YAXIS(IGRID).EQ.YAXIS(IGRID-1))THEN 140 - PRINT *,' !!!!!! BOXIN2 WARNING : Incorrect grid;'// 141 - - ' no interpolation.' 142 - F=0 143 - IFAIL=1 144 - RETURN 145 - ENDIF 146 - * Compute local coordinates. 147 - YLOCAL=(Y-YAXIS(IGRID-1))/(YAXIS(IGRID)-YAXIS(IGRID-1)) 148 - * Set the summing range. 149 - IY0=IGRID-1 150 - IY1=IGRID 151 - * Set the shape functions. 152 - FY(1)=1-YLOCAL 153 - FY(2)=YLOCAL 154 - FY(3)=0 155 - *** Second order interpolation in y. 156 - ELSEIF(IORDER.EQ.2)THEN 157 - * Find the nearest node and the grid segment. 158 - DIST=ABS(Y-YAXIS(1)) 159 - INODE=1 160 - DO 60 I=2,NY 161 - IF(ABS(Y-YAXIS(I)).LT.DIST)THEN 162 - DIST=ABS(Y-YAXIS(I)) 163 - INODE=I 164 - ENDIF 165 - 60 CONTINUE 166 - * Find the nearest fitting 2x2 matrix. 1 275 P=ROUTINES D=BOXIN2 3 PAGE 382 167 - IGRID=MAX(2,MIN(NY-1,INODE)) 168 - * Ensure there won't be divisions by zero. 169 - IF(YAXIS(IGRID+1).EQ.YAXIS(IGRID-1))THEN 170 - PRINT *,' !!!!!! BOXIN2 WARNING : Incorrect grid;'// 171 - - ' no interpolation.' 172 - F=0 173 - IFAIL=1 174 - RETURN 175 - ENDIF 176 - * Compute the alpha and local coordinate for this grid segment. 177 - YALPHA=(YAXIS(IGRID)-YAXIS(IGRID-1))/ 178 - - (YAXIS(IGRID+1)-YAXIS(IGRID-1)) 179 - YLOCAL=(Y-YAXIS(IGRID-1))/(YAXIS(IGRID+1)-YAXIS(IGRID-1)) 180 - * Ensure there won't be divisions by zero. 181 - IF(YALPHA.LE.0.OR.YALPHA.GE.1)THEN 182 - PRINT *,' !!!!!! BOXIN2 WARNING : Incorrect grid;'// 183 - - ' no interpolation.' 184 - F=0 185 - IFAIL=1 186 - RETURN 187 - ENDIF 188 - * Set the summing range. 189 - IY0=IGRID-1 190 - IY1=IGRID+1 191 - * Set the shape functions. 192 - FY(1)=YLOCAL**2/YALPHA-YLOCAL*(1+YALPHA)/YALPHA+1 193 - FY(2)=(YLOCAL**2-YLOCAL)/(YALPHA**2-YALPHA) 194 - FY(3)=(YLOCAL**2-YLOCAL*YALPHA)/(1-YALPHA) 195 - ENDIF 196 - *** Sum the shape functions. 197 - F=0 198 - DO 100 IX=IX0,IX1 199 - DO 110 IY=IY0,IY1 200 - F=F+VALUE(IX,IY)*FX(IX-IX0+1)*FY(IY-IY0+1) 201 - 110 CONTINUE 202 - 100 CONTINUE 203 - *** Seems to have worked. 204 - IFAIL=0 205 - END 276 GARFIELD ================================================== P=ROUTINES D=BOXIN3 1 ============================ 0 + +DECK,BOXIN3. 1 - SUBROUTINE BOXIN3(VALUE,XAXIS,YAXIS,ZAXIS,MAXX,MAXY,MAXZ, 2 - - NX,NY,NZ,XX,YY,ZZ,F,IORDER,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * BOXIN3 - Interpolation of order 1 and 2 in an irregular rectangular 5 - * 3-dimensional grid. 6 - * (Last changed on 13/ 2/00.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9 - INTEGER MAXX,MAXY,MAXZ,NX,NY,NZ,IORDER,IFAIL,I,INODE,IGRID, 10 - - IX,IX0,IX1,IY,IY0,IY1,IZ,IZ0,IZ1 11 - REAL VALUE(MAXX,MAXY,MAXZ),XAXIS(MAXX),YAXIS(MAXY),ZAXIS(MAXZ), 12 - - X,Y,Z,F,DIST,XLOCAL,YLOCAL,ZLOCAL, 13 - - FX(4),FY(4),FZ(4),XX,YY,ZZ 14 - *** Ensure we are in the grid. 15 - X=MIN(MAX(XX,MIN(XAXIS(1),XAXIS(NX))),MAX(XAXIS(1),XAXIS(NX))) 16 - Y=MIN(MAX(YY,MIN(YAXIS(1),YAXIS(NY))),MAX(YAXIS(1),YAXIS(NY))) 17 - Z=MIN(MAX(ZZ,MIN(ZAXIS(1),ZAXIS(NZ))),MAX(ZAXIS(1),ZAXIS(NZ))) 18 - * Make sure we have enough points. 19 - IF(IORDER.LT.0.OR.IORDER.GT.2.OR. 20 - - NX.LT.1.OR.NX.GT.MAXX.OR. 21 - - NY.LT.1.OR.NY.GT.MAXY.OR. 22 - - NZ.LT.1.OR.NZ.GT.MAXZ)THEN 23 - PRINT *,' !!!!!! BOXIN3 WARNING : Incorrect order or'// 24 - - ' number of points; no interpolation.' 25 - F=0 26 - IFAIL=1 27 - RETURN 28 - ENDIF 29 - *** Zeroth order interpolation in x. 30 - IF(IORDER.EQ.0.OR.NX.LE.1)THEN 31 - * Find the nearest node. 32 - DIST=ABS(X-XAXIS(1)) 33 - INODE=1 34 - DO 10 I=2,NX 35 - IF(ABS(X-XAXIS(I)).LT.DIST)THEN 36 - DIST=ABS(X-XAXIS(I)) 37 - INODE=I 38 - ENDIF 39 - 10 CONTINUE 40 - * Set the summing range. 41 - IX0=INODE 42 - IX1=INODE 43 - * Establish the shape functions. 44 - FX(1)=1 45 - FX(2)=0 46 - FX(3)=0 47 - *** First order interpolation in x. 48 - ELSEIF(IORDER.EQ.1.OR.NX.LE.2)THEN 49 - * Find the grid segment containing this point. 50 - IGRID=0 51 - DO 20 I=2,NX 52 - IF((XAXIS(I-1)-X)*(X-XAXIS(I)).GE.0)IGRID=I 53 - 20 CONTINUE 54 - * Ensure there won't be divisions by zero. 55 - IF(XAXIS(IGRID).EQ.XAXIS(IGRID-1))THEN 56 - PRINT *,' !!!!!! BOXIN3 WARNING : Incorrect grid;'// 57 - - ' no interpolation.' 58 - F=0 59 - IFAIL=1 60 - RETURN 61 - ENDIF 62 - * Compute local coordinates. 63 - XLOCAL=(X-XAXIS(IGRID-1))/(XAXIS(IGRID)-XAXIS(IGRID-1)) 1 276 P=ROUTINES D=BOXIN3 2 PAGE 383 64 - * Set the summing range. 65 - IX0=IGRID-1 66 - IX1=IGRID 67 - * Set the shape functions. 68 - FX(1)=1-XLOCAL 69 - FX(2)=XLOCAL 70 - FX(3)=0 71 - *** Second order interpolation in x. 72 - ELSEIF(IORDER.EQ.2)THEN 73 - * Find the grid segment containing this point. 74 - IGRID=0 75 - DO 30 I=2,NX 76 - IF((XAXIS(I-1)-X)*(X-XAXIS(I)).GE.0)IGRID=I 77 - 30 CONTINUE 78 - * Compute the local coordinate for this grid segment. 79 - XLOCAL=(X-XAXIS(IGRID-1))/(XAXIS(IGRID)-XAXIS(IGRID-1)) 80 - * Set the summing range and shape functions. 81 - IF(IGRID.EQ.2)THEN 82 - IX0=IGRID-1 83 - IX1=IGRID+1 84 - IF( XAXIS(IX0 ).EQ.XAXIS(IX0+1).OR. 85 - - XAXIS(IX0 ).EQ.XAXIS(IX0+2).OR. 86 - - XAXIS(IX0+1).EQ.XAXIS(IX0+2))GOTO 3010 87 - FX(1)=(X -XAXIS(IX0+1))* 88 - - (X -XAXIS(IX0+2))/ 89 - - ((XAXIS(IX0 )-XAXIS(IX0+1))* 90 - - (XAXIS(IX0 )-XAXIS(IX0+2))) 91 - FX(2)=(X -XAXIS(IX0 ))* 92 - - (X -XAXIS(IX0+2))/ 93 - - ((XAXIS(IX0+1)-XAXIS(IX0 ))* 94 - - (XAXIS(IX0+1)-XAXIS(IX0+2))) 95 - FX(3)=(X -XAXIS(IX0 ))* 96 - - (X -XAXIS(IX0+1))/ 97 - - ((XAXIS(IX0+2)-XAXIS(IX0 ))* 98 - - (XAXIS(IX0+2)-XAXIS(IX0+1))) 99 - ELSEIF(IGRID.EQ.NX)THEN 100 - IX0=IGRID-2 101 - IX1=IGRID 102 - IF( XAXIS(IX0 ).EQ.XAXIS(IX0+1).OR. 103 - - XAXIS(IX0 ).EQ.XAXIS(IX0+2).OR. 104 - - XAXIS(IX0+1).EQ.XAXIS(IX0+2))GOTO 3010 105 - FX(1)=(X -XAXIS(IX0+1))* 106 - - (X -XAXIS(IX0+2))/ 107 - - ((XAXIS(IX0 )-XAXIS(IX0+1))* 108 - - (XAXIS(IX0 )-XAXIS(IX0+2))) 109 - FX(2)=(X -XAXIS(IX0 ))* 110 - - (X -XAXIS(IX0+2))/ 111 - - ((XAXIS(IX0+1)-XAXIS(IX0 ))* 112 - - (XAXIS(IX0+1)-XAXIS(IX0+2))) 113 - FX(3)=(X -XAXIS(IX0 ))* 114 - - (X -XAXIS(IX0+1))/ 115 - - ((XAXIS(IX0+2)-XAXIS(IX0 ))* 116 - - (XAXIS(IX0+2)-XAXIS(IX0+1))) 117 - ELSE 118 - IX0=IGRID-2 119 - IX1=IGRID+1 120 - IF( XAXIS(IX0 ).EQ.XAXIS(IX0+1).OR. 121 - - XAXIS(IX0 ).EQ.XAXIS(IX0+2).OR. 122 - - XAXIS(IX0 ).EQ.XAXIS(IX0+3).OR. 123 - - XAXIS(IX0+1).EQ.XAXIS(IX0+2).OR. 124 - - XAXIS(IX0+1).EQ.XAXIS(IX0+3).OR. 125 - - XAXIS(IX0+2).EQ.XAXIS(IX0+3))GOTO 3010 126 - FX(1)=(1-XLOCAL)* 127 - - (X -XAXIS(IX0+1))* 128 - - (X -XAXIS(IX0+2))/ 129 - - ((XAXIS(IX0 )-XAXIS(IX0+1))* 130 - - (XAXIS(IX0 )-XAXIS(IX0+2))) 131 - FX(2)=(1-XLOCAL)* 132 - - (X -XAXIS(IX0 ))* 133 - - (X -XAXIS(IX0+2))/ 134 - - ((XAXIS(IX0+1)-XAXIS(IX0 ))* 135 - - (XAXIS(IX0+1)-XAXIS(IX0+2)))+ 136 - - XLOCAL* 137 - - (X -XAXIS(IX0+2))* 138 - - (X -XAXIS(IX0+3))/ 139 - - ((XAXIS(IX0+1)-XAXIS(IX0+2))* 140 - - (XAXIS(IX0+1)-XAXIS(IX0+3))) 141 - FX(3)=(1-XLOCAL)* 142 - - (X -XAXIS(IX0 ))* 143 - - (X -XAXIS(IX0+1))/ 144 - - ((XAXIS(IX0+2)-XAXIS(IX0 ))* 145 - - (XAXIS(IX0+2)-XAXIS(IX0+1)))+ 146 - - XLOCAL* 147 - - (X -XAXIS(IX0+1))* 148 - - (X -XAXIS(IX0+3))/ 149 - - ((XAXIS(IX0+2)-XAXIS(IX0+1))* 150 - - (XAXIS(IX0+2)-XAXIS(IX0+3))) 151 - FX(4)=XLOCAL* 152 - - (X -XAXIS(IX0+1))* 153 - - (X -XAXIS(IX0+2))/ 154 - - ((XAXIS(IX0+3)-XAXIS(IX0+1))* 155 - - (XAXIS(IX0+3)-XAXIS(IX0+2))) 156 - ENDIF 157 - ENDIF 158 - *** Zeroth order interpolation in y. 159 - IF(IORDER.EQ.0.OR.NY.LE.1)THEN 160 - * Find the nearest node. 161 - DIST=ABS(Y-YAXIS(1)) 162 - INODE=1 163 - DO 40 I=2,NY 164 - IF(ABS(Y-YAXIS(I)).LT.DIST)THEN 165 - DIST=ABS(Y-YAXIS(I)) 166 - INODE=I 167 - ENDIF 168 - 40 CONTINUE 169 - * Set the summing range. 1 276 P=ROUTINES D=BOXIN3 3 PAGE 384 170 - IY0=INODE 171 - IY1=INODE 172 - * Establish the shape functions. 173 - FY(1)=1 174 - FY(2)=0 175 - FY(3)=0 176 - *** First order interpolation in y. 177 - ELSEIF(IORDER.EQ.1.OR.NY.LE.2)THEN 178 - * Find the grid segment containing this point. 179 - IGRID=0 180 - DO 50 I=2,NY 181 - IF((YAXIS(I-1)-Y)*(Y-YAXIS(I)).GE.0)IGRID=I 182 - 50 CONTINUE 183 - * Ensure there won't be divisions by zero. 184 - IF(YAXIS(IGRID).EQ.YAXIS(IGRID-1))THEN 185 - PRINT *,' !!!!!! BOXIN3 WARNING : Incorrect grid;'// 186 - - ' no interpolation.' 187 - F=0 188 - IFAIL=1 189 - RETURN 190 - ENDIF 191 - * Compute local coordinates. 192 - YLOCAL=(Y-YAXIS(IGRID-1))/(YAXIS(IGRID)-YAXIS(IGRID-1)) 193 - * Set the summing range. 194 - IY0=IGRID-1 195 - IY1=IGRID 196 - * Set the shape functions. 197 - FY(1)=1-YLOCAL 198 - FY(2)=YLOCAL 199 - FY(3)=0 200 - *** Second order interpolation in y. 201 - ELSEIF(IORDER.EQ.2)THEN 202 - * Find the grid segment containing this point. 203 - IGRID=0 204 - DO 60 I=2,NY 205 - IF((YAXIS(I-1)-Y)*(Y-YAXIS(I)).GE.0)IGRID=I 206 - 60 CONTINUE 207 - * Compute the local coordinate for this grid segment. 208 - YLOCAL=(Y-YAXIS(IGRID-1))/(YAXIS(IGRID)-YAXIS(IGRID-1)) 209 - * Set the summing range and shape functions. 210 - IF(IGRID.EQ.2)THEN 211 - IY0=IGRID-1 212 - IY1=IGRID+1 213 - IF( YAXIS(IY0 ).EQ.YAXIS(IY0+1).OR. 214 - - YAXIS(IY0 ).EQ.YAXIS(IY0+2).OR. 215 - - YAXIS(IY0+1).EQ.YAXIS(IY0+2))GOTO 3010 216 - FY(1)=(Y -YAXIS(IY0+1))* 217 - - (Y -YAXIS(IY0+2))/ 218 - - ((YAXIS(IY0 )-YAXIS(IY0+1))* 219 - - (YAXIS(IY0 )-YAXIS(IY0+2))) 220 - FY(2)=(Y -YAXIS(IY0 ))* 221 - - (Y -YAXIS(IY0+2))/ 222 - - ((YAXIS(IY0+1)-YAXIS(IY0 ))* 223 - - (YAXIS(IY0+1)-YAXIS(IY0+2))) 224 - FY(3)=(Y -YAXIS(IY0 ))* 225 - - (Y -YAXIS(IY0+1))/ 226 - - ((YAXIS(IY0+2)-YAXIS(IY0 ))* 227 - - (YAXIS(IY0+2)-YAXIS(IY0+1))) 228 - ELSEIF(IGRID.EQ.NY)THEN 229 - IY0=IGRID-2 230 - IY1=IGRID 231 - IF( YAXIS(IY0 ).EQ.YAXIS(IY0+1).OR. 232 - - YAXIS(IY0 ).EQ.YAXIS(IY0+2).OR. 233 - - YAXIS(IY0+1).EQ.YAXIS(IY0+2))GOTO 3010 234 - FY(1)=(Y -YAXIS(IY0+1))* 235 - - (Y -YAXIS(IY0+2))/ 236 - - ((YAXIS(IY0 )-YAXIS(IY0+1))* 237 - - (YAXIS(IY0 )-YAXIS(IY0+2))) 238 - FY(2)=(Y -YAXIS(IY0 ))* 239 - - (Y -YAXIS(IY0+2))/ 240 - - ((YAXIS(IY0+1)-YAXIS(IY0 ))* 241 - - (YAXIS(IY0+1)-YAXIS(IY0+2))) 242 - FY(3)=(Y -YAXIS(IY0 ))* 243 - - (Y -YAXIS(IY0+1))/ 244 - - ((YAXIS(IY0+2)-YAXIS(IY0 ))* 245 - - (YAXIS(IY0+2)-YAXIS(IY0+1))) 246 - ELSE 247 - IY0=IGRID-2 248 - IY1=IGRID+1 249 - IF( YAXIS(IY0 ).EQ.YAXIS(IY0+1).OR. 250 - - YAXIS(IY0 ).EQ.YAXIS(IY0+2).OR. 251 - - YAXIS(IY0 ).EQ.YAXIS(IY0+3).OR. 252 - - YAXIS(IY0+1).EQ.YAXIS(IY0+2).OR. 253 - - YAXIS(IY0+1).EQ.YAXIS(IY0+3).OR. 254 - - YAXIS(IY0+2).EQ.YAXIS(IY0+3))GOTO 3010 255 - FY(1)=(1-YLOCAL)* 256 - - (Y -YAXIS(IY0+1))* 257 - - (Y -YAXIS(IY0+2))/ 258 - - ((YAXIS(IY0 )-YAXIS(IY0+1))* 259 - - (YAXIS(IY0 )-YAXIS(IY0+2))) 260 - FY(2)=(1-YLOCAL)* 261 - - (Y -YAXIS(IY0 ))* 262 - - (Y -YAXIS(IY0+2))/ 263 - - ((YAXIS(IY0+1)-YAXIS(IY0 ))* 264 - - (YAXIS(IY0+1)-YAXIS(IY0+2)))+ 265 - - YLOCAL* 266 - - (Y -YAXIS(IY0+2))* 267 - - (Y -YAXIS(IY0+3))/ 268 - - ((YAXIS(IY0+1)-YAXIS(IY0+2))* 269 - - (YAXIS(IY0+1)-YAXIS(IY0+3))) 270 - FY(3)=(1-YLOCAL)* 271 - - (Y -YAXIS(IY0 ))* 272 - - (Y -YAXIS(IY0+1))/ 273 - - ((YAXIS(IY0+2)-YAXIS(IY0 ))* 274 - - (YAXIS(IY0+2)-YAXIS(IY0+1)))+ 275 - - YLOCAL* 1 276 P=ROUTINES D=BOXIN3 4 PAGE 385 276 - - (Y -YAXIS(IY0+1))* 277 - - (Y -YAXIS(IY0+3))/ 278 - - ((YAXIS(IY0+2)-YAXIS(IY0+1))* 279 - - (YAXIS(IY0+2)-YAXIS(IY0+3))) 280 - FY(4)=YLOCAL* 281 - - (Y -YAXIS(IY0+1))* 282 - - (Y -YAXIS(IY0+2))/ 283 - - ((YAXIS(IY0+3)-YAXIS(IY0+1))* 284 - - (YAXIS(IY0+3)-YAXIS(IY0+2))) 285 - ENDIF 286 - ENDIF 287 - *** Zeroth order interpolation in z. 288 - IF(IORDER.EQ.0.OR.NZ.LE.1)THEN 289 - * Find the nearest node. 290 - DIST=ABS(Z-ZAXIS(1)) 291 - INODE=1 292 - DO 70 I=2,NZ 293 - IF(ABS(Z-ZAXIS(I)).LT.DIST)THEN 294 - DIST=ABS(Z-ZAXIS(I)) 295 - INODE=I 296 - ENDIF 297 - 70 CONTINUE 298 - * Set the summing range. 299 - IZ0=INODE 300 - IZ1=INODE 301 - * Establish the shape functions. 302 - FZ(1)=1 303 - FZ(2)=0 304 - FZ(3)=0 305 - *** First order interpolation in z. 306 - ELSEIF(IORDER.EQ.1.OR.NZ.LE.2)THEN 307 - * Find the grid segment containing this point. 308 - IGRID=0 309 - DO 80 I=2,NZ 310 - IF((ZAXIS(I-1)-Z)*(Z-ZAXIS(I)).GE.0)IGRID=I 311 - 80 CONTINUE 312 - * Ensure there won't be divisions by zero. 313 - IF(ZAXIS(IGRID).EQ.ZAXIS(IGRID-1))THEN 314 - PRINT *,' !!!!!! BOXIN3 WARNING : Incorrect grid;'// 315 - - ' no interpolation.' 316 - F=0 317 - IFAIL=1 318 - RETURN 319 - ENDIF 320 - * Compute local coordinates. 321 - ZLOCAL=(Z-ZAXIS(IGRID-1))/(ZAXIS(IGRID)-ZAXIS(IGRID-1)) 322 - * Set the summing range. 323 - IZ0=IGRID-1 324 - IZ1=IGRID 325 - * Set the shape functions. 326 - FZ(1)=1-ZLOCAL 327 - FZ(2)=ZLOCAL 328 - FZ(3)=0 329 - *** Second order interpolation in z. 330 - ELSEIF(IORDER.EQ.2)THEN 331 - * Find the grid segment containing this point. 332 - IGRID=0 333 - DO 90 I=2,NZ 334 - IF((ZAXIS(I-1)-Z)*(Z-ZAXIS(I)).GE.0)IGRID=I 335 - 90 CONTINUE 336 - * Compute the local coordinate for this grid segment. 337 - ZLOCAL=(Z-ZAXIS(IGRID-1))/(ZAXIS(IGRID)-ZAXIS(IGRID-1)) 338 - * Set the summing range and shape functions. 339 - IF(IGRID.EQ.2)THEN 340 - IZ0=IGRID-1 341 - IZ1=IGRID+1 342 - IF( ZAXIS(IZ0 ).EQ.ZAXIS(IZ0+1).OR. 343 - - ZAXIS(IZ0 ).EQ.ZAXIS(IZ0+2).OR. 344 - - ZAXIS(IZ0+1).EQ.ZAXIS(IZ0+2))GOTO 3010 345 - FZ(1)=(Z -ZAXIS(IZ0+1))* 346 - - (Z -ZAXIS(IZ0+2))/ 347 - - ((ZAXIS(IZ0 )-ZAXIS(IZ0+1))* 348 - - (ZAXIS(IZ0 )-ZAXIS(IZ0+2))) 349 - FZ(2)=(Z -ZAXIS(IZ0 ))* 350 - - (Z -ZAXIS(IZ0+2))/ 351 - - ((ZAXIS(IZ0+1)-ZAXIS(IZ0 ))* 352 - - (ZAXIS(IZ0+1)-ZAXIS(IZ0+2))) 353 - FZ(3)=(Z -ZAXIS(IZ0 ))* 354 - - (Z -ZAXIS(IZ0+1))/ 355 - - ((ZAXIS(IZ0+2)-ZAXIS(IZ0 ))* 356 - - (ZAXIS(IZ0+2)-ZAXIS(IZ0+1))) 357 - ELSEIF(IGRID.EQ.NZ)THEN 358 - IZ0=IGRID-2 359 - IZ1=IGRID 360 - IF( ZAXIS(IZ0 ).EQ.ZAXIS(IZ0+1).OR. 361 - - ZAXIS(IZ0 ).EQ.ZAXIS(IZ0+2).OR. 362 - - ZAXIS(IZ0+1).EQ.ZAXIS(IZ0+2))GOTO 3010 363 - FZ(1)=(Z -ZAXIS(IZ0+1))* 364 - - (Z -ZAXIS(IZ0+2))/ 365 - - ((ZAXIS(IZ0 )-ZAXIS(IZ0+1))* 366 - - (ZAXIS(IZ0 )-ZAXIS(IZ0+2))) 367 - FZ(2)=(Z -ZAXIS(IZ0 ))* 368 - - (Z -ZAXIS(IZ0+2))/ 369 - - ((ZAXIS(IZ0+1)-ZAXIS(IZ0 ))* 370 - - (ZAXIS(IZ0+1)-ZAXIS(IZ0+2))) 371 - FZ(3)=(Z -ZAXIS(IZ0 ))* 372 - - (Z -ZAXIS(IZ0+1))/ 373 - - ((ZAXIS(IZ0+2)-ZAXIS(IZ0 ))* 374 - - (ZAXIS(IZ0+2)-ZAXIS(IZ0+1))) 375 - ELSE 376 - IZ0=IGRID-2 377 - IZ1=IGRID+1 378 - IF( ZAXIS(IZ0 ).EQ.ZAXIS(IZ0+1).OR. 379 - - ZAXIS(IZ0 ).EQ.ZAXIS(IZ0+2).OR. 380 - - ZAXIS(IZ0 ).EQ.ZAXIS(IZ0+3).OR. 381 - - ZAXIS(IZ0+1).EQ.ZAXIS(IZ0+2).OR. 1 276 P=ROUTINES D=BOXIN3 5 PAGE 386 382 - - ZAXIS(IZ0+1).EQ.ZAXIS(IZ0+3).OR. 383 - - ZAXIS(IZ0+2).EQ.ZAXIS(IZ0+3))GOTO 3010 384 - FZ(1)=(1-ZLOCAL)* 385 - - (Z -ZAXIS(IZ0+1))* 386 - - (Z -ZAXIS(IZ0+2))/ 387 - - ((ZAXIS(IZ0 )-ZAXIS(IZ0+1))* 388 - - (ZAXIS(IZ0 )-ZAXIS(IZ0+2))) 389 - FZ(2)=(1-ZLOCAL)* 390 - - (Z -ZAXIS(IZ0 ))* 391 - - (Z -ZAXIS(IZ0+2))/ 392 - - ((ZAXIS(IZ0+1)-ZAXIS(IZ0 ))* 393 - - (ZAXIS(IZ0+1)-ZAXIS(IZ0+2)))+ 394 - - ZLOCAL* 395 - - (Z -ZAXIS(IZ0+2))* 396 - - (Z -ZAXIS(IZ0+3))/ 397 - - ((ZAXIS(IZ0+1)-ZAXIS(IZ0+2))* 398 - - (ZAXIS(IZ0+1)-ZAXIS(IZ0+3))) 399 - FZ(3)=(1-ZLOCAL)* 400 - - (Z -ZAXIS(IZ0 ))* 401 - - (Z -ZAXIS(IZ0+1))/ 402 - - ((ZAXIS(IZ0+2)-ZAXIS(IZ0 ))* 403 - - (ZAXIS(IZ0+2)-ZAXIS(IZ0+1)))+ 404 - - ZLOCAL* 405 - - (Z -ZAXIS(IZ0+1))* 406 - - (Z -ZAXIS(IZ0+3))/ 407 - - ((ZAXIS(IZ0+2)-ZAXIS(IZ0+1))* 408 - - (ZAXIS(IZ0+2)-ZAXIS(IZ0+3))) 409 - FZ(4)=ZLOCAL* 410 - - (Z -ZAXIS(IZ0+1))* 411 - - (Z -ZAXIS(IZ0+2))/ 412 - - ((ZAXIS(IZ0+3)-ZAXIS(IZ0+1))* 413 - - (ZAXIS(IZ0+3)-ZAXIS(IZ0+2))) 414 - ENDIF 415 - ENDIF 416 - *** Sum the shape functions. 417 - F=0 418 - DO 100 IX=IX0,IX1 419 - DO 110 IY=IY0,IY1 420 - DO 120 IZ=IZ0,IZ1 421 - F=F+VALUE(IX,IY,IZ)*FX(IX-IX0+1)*FY(IY-IY0+1)*FZ(IZ-IZ0+1) 422 - 120 CONTINUE 423 - 110 CONTINUE 424 - 100 CONTINUE 425 - *** Seems to have worked. 426 - IFAIL=0 427 - RETURN 428 - *** Error handling. 429 - 3010 CONTINUE 430 - PRINT *,' !!!!!! BOXIN3 WARNING : One or more grid points in'// 431 - - ' x coincide; no interpolation.' 432 - F=0 433 - IFAIL=1 434 - END 277 GARFIELD ================================================== P=ROUTINES D=BUTFLY 1 ============================ 0 + +DECK,BUTFLY. 1 - SUBROUTINE BUTFLY(NPL,XPL,YPL,ZPL) 2 - *---------------------------------------------------------------------- 3 - * BUTFLY - Tries to eliminate "butterflies", i.e. the crossing of 2 4 - * adjacent segments of a polygon, by point exchanges. 5 - * (Last changed on 30/ 9/98.) 6 - *---------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,PARAMETERS. 11 - INTEGER NPL,I,J,K,NPASS,IAXIS,NNEW 12 - REAL XPL(NPL),YPL(NPL),ZPL(NPL),XAUX,YAUX,ZAUX, 13 - - XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,EPSX,EPSY,EPSZ, 14 - - XSURF,YSURF,ZSURF 15 - LOGICAL CROSS,REPASS,MARK(MXEDGE) 16 - EXTERNAL CROSS 17 - *** Check the number of points. 18 - IF(NPL.GT.MXEDGE)THEN 19 - PRINT *,' !!!!!! BUTFLY WARNING : Received more than'// 20 - - ' MXEDGE points; data not processed.' 21 - RETURN 22 - ENDIF 23 - *** Compute range. 24 - XMIN=XPL(1) 25 - XMAX=XPL(1) 26 - YMIN=YPL(1) 27 - YMAX=YPL(1) 28 - ZMIN=ZPL(1) 29 - ZMAX=ZPL(1) 30 - XSURF=0 31 - YSURF=0 32 - ZSURF=0 33 - DO 100 I=2,NPL 34 - XMIN=MIN(XMIN,XPL(I)) 35 - XMAX=MAX(XMAX,XPL(I)) 36 - YMIN=MIN(YMIN,YPL(I)) 37 - YMAX=MAX(YMAX,YPL(I)) 38 - ZMIN=MIN(ZMIN,ZPL(I)) 39 - ZMAX=MAX(ZMAX,ZPL(I)) 40 - IF(I.GE.3)THEN 41 - XSURF=XSURF+ABS( 42 - - (YPL(I )-YPL(1))*(ZPL(I-1)-ZPL(1))- 43 - - (YPL(I-1)-YPL(1))*(ZPL(I )-ZPL(1))) 44 - YSURF=YSURF+ABS( 45 - - (XPL(I )-XPL(1))*(ZPL(I-1)-ZPL(1))- 46 - - (XPL(I-1)-XPL(1))*(ZPL(I )-ZPL(1))) 47 - ZSURF=ZSURF+ABS( 48 - - (XPL(I )-XPL(1))*(YPL(I-1)-YPL(1))- 49 - - (XPL(I-1)-XPL(1))*(YPL(I )-YPL(1))) 1 277 P=ROUTINES D=BUTFLY 2 PAGE 387 50 - ENDIF 51 - 100 CONTINUE 52 - *** Set tolerances. 53 - IF(LEPSG)THEN 54 - EPSX=EPSGX 55 - EPSY=EPSGY 56 - EPSZ=EPSGZ 57 - ELSE 58 - EPSX=1.0E-5*ABS(XMAX-XMIN) 59 - EPSY=1.0E-5*ABS(YMAX-YMIN) 60 - EPSZ=1.0E-5*ABS(ZMAX-ZMIN) 61 - IF(EPSX.LE.1E-6)EPSX=1.0E-6 62 - IF(EPSY.LE.1E-6)EPSY=1.0E-6 63 - IF(EPSZ.LE.1E-6)EPSZ=1.0E-6 64 - ENDIF 65 - *** Eliminate points appearing twice, initialise marks. 66 - DO 50 I=1,NPL 67 - MARK(I)=.FALSE. 68 - 50 CONTINUE 69 - * Scan the list. 70 - DO 110 I=1,NPL 71 - IF(MARK(I))GOTO 110 72 - DO 120 J=I+1,NPL 73 - IF(ABS(XPL(I)-XPL(J)).LE.EPSX.AND. 74 - - ABS(YPL(I)-YPL(J)).LE.EPSY.AND. 75 - - ABS(ZPL(I)-ZPL(J)).LE.EPSZ)MARK(J)=.TRUE. 76 - 120 CONTINUE 77 - 110 CONTINUE 78 - * And remove the duplicate points. 79 - NNEW=0 80 - DO 130 I=1,NPL 81 - IF(.NOT.MARK(I))THEN 82 - NNEW=NNEW+1 83 - XPL(NNEW)=XPL(I) 84 - YPL(NNEW)=YPL(I) 85 - ZPL(NNEW)=ZPL(I) 86 - ENDIF 87 - 130 CONTINUE 88 - * Update the number of points. 89 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ BUTFLY DEBUG : Old /'', 90 - - '' new number of points: '',2I3)') NPL,NNEW 91 - NPL=NNEW 92 - *** No risk of having a butterfly with less than 4 points. 93 - IF(NPL.LE.3)RETURN 94 - *** Select the axis with the largest norm. 95 - IF(XSURF.GT.YSURF.AND.XSURF.GT.ZSURF)THEN 96 - IAXIS=1 97 - ELSEIF(YSURF.GT.ZSURF)THEN 98 - IAXIS=2 99 - ELSE 100 - IAXIS=3 101 - ENDIF 102 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ BUTFLY DEBUG : Main'', 103 - - '' axis: '',I3/26X,''x-Surface: '',E15.8/ 104 - - 26X,''y-Surface: '',E15.8/26X,''z-Surface: '',E15.8)') 105 - - IAXIS,XSURF,YSURF,ZSURF 106 - *** Set number of passes to avoid endless loop. 107 - NPASS=0 108 - *** Make a pass. 109 - 40 CONTINUE 110 - NPASS=NPASS+1 111 - REPASS=.FALSE. 112 - DO 10 I=1,NPL 113 - DO 20 J=I+2,NPL 114 - IF(J+1.GT.NPL.AND.1+MOD(J,NPL).GE.I)GOTO 20 115 - * Check for a crossing. 116 - IF((IAXIS.EQ.1.AND.CROSS( 117 - - YPL(1+MOD(I-1,NPL)),ZPL(1+MOD(I-1,NPL)), 118 - - YPL(1+MOD(I ,NPL)),ZPL(1+MOD(I ,NPL)), 119 - - YPL(1+MOD(J-1,NPL)),ZPL(1+MOD(J-1,NPL)), 120 - - YPL(1+MOD(J ,NPL)),ZPL(1+MOD(J ,NPL)))).OR. 121 - - (IAXIS.EQ.2.AND.CROSS( 122 - - XPL(1+MOD(I-1,NPL)),ZPL(1+MOD(I-1,NPL)), 123 - - XPL(1+MOD(I ,NPL)),ZPL(1+MOD(I ,NPL)), 124 - - XPL(1+MOD(J-1,NPL)),ZPL(1+MOD(J-1,NPL)), 125 - - XPL(1+MOD(J ,NPL)),ZPL(1+MOD(J ,NPL)))).OR. 126 - - (IAXIS.EQ.3.AND.CROSS( 127 - - XPL(1+MOD(I-1,NPL)),YPL(1+MOD(I-1,NPL)), 128 - - XPL(1+MOD(I ,NPL)),YPL(1+MOD(I ,NPL)), 129 - - XPL(1+MOD(J-1,NPL)),YPL(1+MOD(J-1,NPL)), 130 - - XPL(1+MOD(J ,NPL)),YPL(1+MOD(J ,NPL)))))THEN 131 - * If there is a crossing, exchange the portion in between. 132 - DO 30 K=1,(J-I)/2 133 - XAUX=XPL(1+MOD(I+K-1,NPL)) 134 - YAUX=YPL(1+MOD(I+K-1,NPL)) 135 - ZAUX=ZPL(1+MOD(I+K-1,NPL)) 136 - XPL(1+MOD(I+K-1,NPL))=XPL(1+MOD(J-K,NPL)) 137 - YPL(1+MOD(I+K-1,NPL))=YPL(1+MOD(J-K,NPL)) 138 - ZPL(1+MOD(I+K-1,NPL))=ZPL(1+MOD(J-K,NPL)) 139 - XPL(1+MOD(J-K,NPL))=XAUX 140 - YPL(1+MOD(J-K,NPL))=YAUX 141 - ZPL(1+MOD(J-K,NPL))=ZAUX 142 - 30 CONTINUE 143 - * And remember we have to do another pass after this. 144 - REPASS=.TRUE. 145 - ENDIF 146 - 20 CONTINUE 147 - 10 CONTINUE 148 - *** See whether we have to do another pass. 149 - IF(REPASS.AND.NPASS.LE.NPL)THEN 150 - GOTO 40 151 - ELSEIF(REPASS)THEN 152 - PRINT *,' !!!!!! BUTFLY WARNING : Unable to eliminate'// 153 - - ' the internal crossings; plot probably incorrect.' 154 - IF(LGSTOP)THEN 155 - OPEN(UNIT=12,FILE='butfly.dat',STATUS='UNKNOWN') 1 277 P=ROUTINES D=BUTFLY 3 PAGE 388 156 - WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG 157 - WRITE(12,*) NPL 158 - DO 60 I=1,NPL 159 - WRITE(12,*) XPL(I),YPL(I),ZPL(I) 160 - 60 CONTINUE 161 - CLOSE(12) 162 - CALL QUIT 163 - ENDIF 164 - ENDIF 165 - END 278 GARFIELD ================================================== P=ROUTINES D=BUTFLD 1 ============================ 0 + +DECK,BUTFLD. 1 - SUBROUTINE BUTFLD(NPL,XPL,YPL,ZPL) 2 - *---------------------------------------------------------------------- 3 - * BUTFLD - Tries to eliminate "butterflies", i.e. the crossing of 2 4 - * adjacent segments of a polygon, by point exchanges. 5 - * (Last changed on 30/ 9/98.) 6 - *---------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,PARAMETERS. 11 - INTEGER NPL,I,J,K,NPASS,IAXIS,NNEW 12 - DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL),XAUX,YAUX,ZAUX, 13 - - XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,EPSX,EPSY,EPSZ, 14 - - XSURF,YSURF,ZSURF 15 - LOGICAL CROSSD,REPASS,MARK(MXEDGE) 16 - EXTERNAL CROSSD 17 - *** Check the number of points. 18 - IF(NPL.GT.MXEDGE)THEN 19 - PRINT *,' !!!!!! BUTFLD WARNING : Received more than'// 20 - - ' MXEDGE points; data not processed.' 21 - RETURN 22 - ENDIF 23 - *** Compute range. 24 - XMIN=XPL(1) 25 - XMAX=XPL(1) 26 - YMIN=YPL(1) 27 - YMAX=YPL(1) 28 - ZMIN=ZPL(1) 29 - ZMAX=ZPL(1) 30 - XSURF=0 31 - YSURF=0 32 - ZSURF=0 33 - DO 100 I=2,NPL 34 - XMIN=MIN(XMIN,XPL(I)) 35 - XMAX=MAX(XMAX,XPL(I)) 36 - YMIN=MIN(YMIN,YPL(I)) 37 - YMAX=MAX(YMAX,YPL(I)) 38 - ZMIN=MIN(ZMIN,ZPL(I)) 39 - ZMAX=MAX(ZMAX,ZPL(I)) 40 - IF(I.GE.3)THEN 41 - XSURF=XSURF+ABS( 42 - - (YPL(I )-YPL(1))*(ZPL(I-1)-ZPL(1))- 43 - - (YPL(I-1)-YPL(1))*(ZPL(I )-ZPL(1))) 44 - YSURF=YSURF+ABS( 45 - - (XPL(I )-XPL(1))*(ZPL(I-1)-ZPL(1))- 46 - - (XPL(I-1)-XPL(1))*(ZPL(I )-ZPL(1))) 47 - ZSURF=ZSURF+ABS( 48 - - (XPL(I )-XPL(1))*(YPL(I-1)-YPL(1))- 49 - - (XPL(I-1)-XPL(1))*(YPL(I )-YPL(1))) 50 - ENDIF 51 - 100 CONTINUE 52 - *** Set tolerances. 53 - IF(LEPSG)THEN 54 - EPSX=EPSGX 55 - EPSY=EPSGY 56 - EPSZ=EPSGZ 57 - ELSE 58 - EPSX=1.0D-10*ABS(XMAX-XMIN) 59 - EPSY=1.0D-10*ABS(YMAX-YMIN) 60 - EPSZ=1.0D-10*ABS(ZMAX-ZMIN) 61 - IF(EPSX.LE.1D-6)EPSX=1.0D-6 62 - IF(EPSY.LE.1D-6)EPSY=1.0D-6 63 - IF(EPSZ.LE.1D-6)EPSZ=1.0D-6 64 - ENDIF 65 - *** Eliminate points appearing twice, initialise marks. 66 - DO 50 I=1,NPL 67 - MARK(I)=.FALSE. 68 - 50 CONTINUE 69 - * Scan the list. 70 - DO 110 I=1,NPL 71 - IF(MARK(I))GOTO 110 72 - DO 120 J=I+1,NPL 73 - IF(ABS(XPL(I)-XPL(J)).LE.EPSX.AND. 74 - - ABS(YPL(I)-YPL(J)).LE.EPSY.AND. 75 - - ABS(ZPL(I)-ZPL(J)).LE.EPSZ)MARK(J)=.TRUE. 76 - 120 CONTINUE 77 - 110 CONTINUE 78 - * And remove the duplicate points. 79 - NNEW=0 80 - DO 130 I=1,NPL 81 - IF(.NOT.MARK(I))THEN 82 - NNEW=NNEW+1 83 - XPL(NNEW)=XPL(I) 84 - YPL(NNEW)=YPL(I) 85 - ZPL(NNEW)=ZPL(I) 86 - ENDIF 87 - 130 CONTINUE 88 - * Update the number of points. 89 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ BUTFLD DEBUG : Old /'', 90 - - '' new number of points: '',2I3)') NPL,NNEW 91 - NPL=NNEW 92 - *** No risk of having a butterfly with less than 4 points. 1 278 P=ROUTINES D=BUTFLD 2 PAGE 389 93 - IF(NPL.LE.3)RETURN 94 - *** Select the axis with the largest norm. 95 - IF(XSURF.GT.YSURF.AND.XSURF.GT.ZSURF)THEN 96 - IAXIS=1 97 - ELSEIF(YSURF.GT.ZSURF)THEN 98 - IAXIS=2 99 - ELSE 100 - IAXIS=3 101 - ENDIF 102 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ BUTFLD DEBUG : Main'', 103 - - '' axis: '',I3/26X,''x-Surface: '',E15.8/ 104 - - 26X,''y-Surface: '',E15.8/26X,''z-Surface: '',E15.8)') 105 - - IAXIS,XSURF,YSURF,ZSURF 106 - *** Set number of passes to avoid endless loop. 107 - NPASS=0 108 - *** Make a pass. 109 - 40 CONTINUE 110 - NPASS=NPASS+1 111 - REPASS=.FALSE. 112 - DO 10 I=1,NPL 113 - DO 20 J=I+2,NPL 114 - IF(J+1.GT.NPL.AND.1+MOD(J,NPL).GE.I)GOTO 20 115 - * Check for a crossing. 116 - IF((IAXIS.EQ.1.AND.CROSSD( 117 - - YPL(1+MOD(I-1,NPL)),ZPL(1+MOD(I-1,NPL)), 118 - - YPL(1+MOD(I ,NPL)),ZPL(1+MOD(I ,NPL)), 119 - - YPL(1+MOD(J-1,NPL)),ZPL(1+MOD(J-1,NPL)), 120 - - YPL(1+MOD(J ,NPL)),ZPL(1+MOD(J ,NPL)))).OR. 121 - - (IAXIS.EQ.2.AND.CROSSD( 122 - - XPL(1+MOD(I-1,NPL)),ZPL(1+MOD(I-1,NPL)), 123 - - XPL(1+MOD(I ,NPL)),ZPL(1+MOD(I ,NPL)), 124 - - XPL(1+MOD(J-1,NPL)),ZPL(1+MOD(J-1,NPL)), 125 - - XPL(1+MOD(J ,NPL)),ZPL(1+MOD(J ,NPL)))).OR. 126 - - (IAXIS.EQ.3.AND.CROSSD( 127 - - XPL(1+MOD(I-1,NPL)),YPL(1+MOD(I-1,NPL)), 128 - - XPL(1+MOD(I ,NPL)),YPL(1+MOD(I ,NPL)), 129 - - XPL(1+MOD(J-1,NPL)),YPL(1+MOD(J-1,NPL)), 130 - - XPL(1+MOD(J ,NPL)),YPL(1+MOD(J ,NPL)))))THEN 131 - * If there is a crossing, exchange the portion in between. 132 - DO 30 K=1,(J-I)/2 133 - XAUX=XPL(1+MOD(I+K-1,NPL)) 134 - YAUX=YPL(1+MOD(I+K-1,NPL)) 135 - ZAUX=ZPL(1+MOD(I+K-1,NPL)) 136 - XPL(1+MOD(I+K-1,NPL))=XPL(1+MOD(J-K,NPL)) 137 - YPL(1+MOD(I+K-1,NPL))=YPL(1+MOD(J-K,NPL)) 138 - ZPL(1+MOD(I+K-1,NPL))=ZPL(1+MOD(J-K,NPL)) 139 - XPL(1+MOD(J-K,NPL))=XAUX 140 - YPL(1+MOD(J-K,NPL))=YAUX 141 - ZPL(1+MOD(J-K,NPL))=ZAUX 142 - 30 CONTINUE 143 - * And remember we have to do another pass after this. 144 - REPASS=.TRUE. 145 - ENDIF 146 - 20 CONTINUE 147 - 10 CONTINUE 148 - *** See whether we have to do another pass. 149 - IF(REPASS.AND.NPASS.LE.NPL)THEN 150 - GOTO 40 151 - ELSEIF(REPASS)THEN 152 - PRINT *,' !!!!!! BUTFLD WARNING : Unable to eliminate'// 153 - - ' the internal crossings; plot probably incorrect.' 154 - IF(LGSTOP)THEN 155 - OPEN(UNIT=12,FILE='butfld.dat',STATUS='UNKNOWN') 156 - WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG 157 - WRITE(12,*) NPL 158 - DO 60 I=1,NPL 159 - WRITE(12,*) XPL(I),YPL(I),ZPL(I) 160 - 60 CONTINUE 161 - CLOSE(12) 162 - CALL QUIT 163 - ENDIF 164 - ENDIF 165 - END 279 GARFIELD ================================================== P=ROUTINES D=CROSS 1 ============================ 0 + +DECK,CROSS. 1 - LOGICAL FUNCTION CROSS(X1S,Y1S,X2S,Y2S,U1S,V1S,U2S,V2S) 2 - *----------------------------------------------------------------------- 3 - * CROSS - Determines whether the 2 straight lines (X1,Y1) to (X2,Y2) 4 - * and (U1,U2) to (V1,V2) cross at an intermediate point for 5 - * both lines. The variables have been introduced to make this 6 - * already elementary routine more understandable. 7 - * VARIABLES : A : Matrix storing direction vectors. 8 - * DET : Determinant of A. 9 - * EPS : Minimum value for DET to be non-zero. 10 - * (Last changed on 3/ 9/98.) 11 - *----------------------------------------------------------------------- 12 - implicit none 13.- +SEQ,DIMENSIONS. 14.- +SEQ,PARAMETERS. 15 - DOUBLE PRECISION X1,X2,Y1,Y2,U1,U2,V1,V2,A(2,2),DET,EPSX,EPSY, 16 - - AUX,XC,YC 17 - REAL X1S,Y1S,X2S,Y2S,U1S,U2S,V1S,V2S 18 - LOGICAL ONLIND 19 - EXTERNAL ONLIND 20 - *** Convert input (single precision) variables to double precision. 21 - X1=DBLE(X1S) 22 - X2=DBLE(X2S) 23 - Y1=DBLE(Y1S) 24 - Y2=DBLE(Y2S) 25 - U1=DBLE(U1S) 26 - U2=DBLE(U2S) 27 - V1=DBLE(V1S) 28 - V2=DBLE(V2S) 29 - *** Matrix to compute the crossing point. 1 279 P=ROUTINES D=CROSS 2 PAGE 390 30 - A(1,1)=Y2-Y1 31 - A(2,1)=V2-V1 32 - A(1,2)=X1-X2 33 - A(2,2)=U1-U2 34 - DET=A(1,1)*A(2,2)-A(1,2)*A(2,1) 35 - *** Set tolerances. 36 - IF(LEPSG)THEN 37 - EPSX=EPSGX 38 - EPSY=EPSGY 39 - ELSE 40 - EPSX=1.0D-5*MAX(ABS(X1),ABS(X2),ABS(U1),ABS(U2)) 41 - EPSY=1.0D-5*MAX(ABS(Y1),ABS(Y2),ABS(V1),ABS(V2)) 42 - IF(EPSX.LE.0)EPSX=1.0D-5 43 - IF(EPSY.LE.0)EPSY=1.0D-5 44 - ENDIF 45 - * Verify the tolerances. 46 - IF(EPSX.LE.0.OR.EPSY.LE.0)THEN 47 - PRINT *,' !!!!!! CROSS WARNING : Tolerances not'// 48 - - ' > 0; returning False.' 49 - CROSS=.FALSE. 50 - RETURN 51 - ENDIF 52 - *** Check for a point of one line located on the other line. 53 - IF( ONLIND(X1,Y1,X2,Y2,U1,V1).OR.ONLIND(X1,Y1,X2,Y2,U2,V2).OR. 54 - - ONLIND(U1,V1,U2,V2,X1,Y1).OR.ONLIND(U1,V1,U2,V2,X2,Y2))THEN 55 - C print *,' Point on other line' 56 - CROSS=.TRUE. 57 - *** Otherwise parallel lines do not cross. 58 - ELSEIF(ABS(DET).LT.EPSX*EPSY)THEN 59 - C print *,' Parallel, non-touching' 60 - CROSS=.FALSE. 61 - ELSE 62 - *** Crossing, non-trivial lines: solve crossing equations. 63 - AUX=A(2,2) 64 - A(2,2)=A(1,1)/DET 65 - A(1,1)=AUX/DET 66 - A(1,2)=-A(1,2)/DET 67 - A(2,1)=-A(2,1)/DET 68 - * Compute crossing point. 69 - XC=A(1,1)*(X1*Y2-X2*Y1)+A(1,2)*(U1*V2-U2*V1) 70 - YC=A(2,1)*(X1*Y2-X2*Y1)+A(2,2)*(U1*V2-U2*V1) 71 - * See whether the crossing point is on both lines. 72 - IF( ONLIND(X1,Y1,X2,Y2,XC,YC).AND. 73 - - ONLIND(U1,V1,U2,V2,XC,YC))THEN 74 - C print *,' Intersecting lines at ',xc,yc 75 - CROSS=.TRUE. 76 - ELSE 77 - C print *,' Crossing point not on both lines ',xc,yc 78 - CROSS=.FALSE. 79 - ENDIF 80 - ENDIF 81 - END 280 GARFIELD ================================================== P=ROUTINES D=CROSSD 1 ============================ 0 + +DECK,CROSSD. 1 - LOGICAL FUNCTION CROSSD(X1,Y1,X2,Y2,U1,V1,U2,V2) 2 - *----------------------------------------------------------------------- 3 - * CROSSD - Determines whether the 2 straight lines (X1,Y1) to (X2,Y2) 4 - * and (U1,U2) to (V1,V2) cross at an intermediate point for 5 - * both lines. The variables have been introduced to make this 6 - * already elementary routine more understandable. 7 - * VARIABLES : A : Matrix storing direction vectors. 8 - * DET : Determinant of A. 9 - * EPS : Minimum value for DET to be non-zero. 10 - * (Last changed on 3/ 9/98.) 11 - *----------------------------------------------------------------------- 12 - implicit none 13.- +SEQ,DIMENSIONS. 14.- +SEQ,PARAMETERS. 15 - DOUBLE PRECISION X1,X2,Y1,Y2,U1,U2,V1,V2,A(2,2),DET,EPSX,EPSY, 16 - - AUX,XC,YC 17 - LOGICAL ONLIND 18 - EXTERNAL ONLIND 19 - *** Matrix to compute the crossing point. 20 - A(1,1)=Y2-Y1 21 - A(2,1)=V2-V1 22 - A(1,2)=X1-X2 23 - A(2,2)=U1-U2 24 - DET=A(1,1)*A(2,2)-A(1,2)*A(2,1) 25 - *** Set tolerances. 26 - IF(LEPSG)THEN 27 - EPSX=EPSGX 28 - EPSY=EPSGY 29 - ELSE 30 - EPSX=1.0D-10*MAX(ABS(X1),ABS(X2),ABS(U1),ABS(U2)) 31 - EPSY=1.0D-10*MAX(ABS(Y1),ABS(Y2),ABS(V1),ABS(V2)) 32 - IF(EPSX.LE.0)EPSX=1.0D-10 33 - IF(EPSY.LE.0)EPSY=1.0D-10 34 - ENDIF 35 - * Verify the tolerances. 36 - IF(EPSX.LE.0.OR.EPSY.LE.0)THEN 37 - PRINT *,' !!!!!! CROSSD WARNING : Tolerances not'// 38 - - ' > 0; returning False.' 39 - CROSSD=.FALSE. 40 - RETURN 41 - ENDIF 42 - *** Check for a point of one line located on the other line. 43 - IF( ONLIND(X1,Y1,X2,Y2,U1,V1).OR.ONLIND(X1,Y1,X2,Y2,U2,V2).OR. 44 - - ONLIND(U1,V1,U2,V2,X1,Y1).OR.ONLIND(U1,V1,U2,V2,X2,Y2))THEN 45 - C print *,' Point on other line' 46 - CROSSD=.TRUE. 47 - *** Otherwise parallel lines do not cross. 48 - ELSEIF(ABS(DET).LT.EPSX*EPSY)THEN 49 - C print *,' Parallel, non-touching' 50 - CROSSD=.FALSE. 1 280 P=ROUTINES D=CROSSD 2 PAGE 391 51 - ELSE 52 - *** Crossing, non-trivial lines: solve crossing equations. 53 - AUX=A(2,2) 54 - A(2,2)=A(1,1)/DET 55 - A(1,1)=AUX/DET 56 - A(1,2)=-A(1,2)/DET 57 - A(2,1)=-A(2,1)/DET 58 - * Compute crossing point. 59 - XC=A(1,1)*(X1*Y2-X2*Y1)+A(1,2)*(U1*V2-U2*V1) 60 - YC=A(2,1)*(X1*Y2-X2*Y1)+A(2,2)*(U1*V2-U2*V1) 61 - * See whether the crossing point is on both lines. 62 - IF( ONLIND(X1,Y1,X2,Y2,XC,YC).AND. 63 - - ONLIND(U1,V1,U2,V2,XC,YC))THEN 64 - C print *,' Intersecting lines at ',xc,yc 65 - CROSSD=.TRUE. 66 - ELSE 67 - C print *,' Crossing point not on both lines ',xc,yc 68 - CROSSD=.FALSE. 69 - ENDIF 70 - ENDIF 71 - END 281 GARFIELD ================================================== P=ROUTINES D=CRSPNT 1 ============================ 0 + +DECK,CRSPNT. 1 - SUBROUTINE CRSPNT(X1S,Y1S,X2S,Y2S,U1S,V1S,U2S,V2S,XCS,YCS,CROSS) 2 - *----------------------------------------------------------------------- 3 - * CRSPNT - Determines whether the 2 straight lines (X1,Y1) to (X2,Y2) 4 - * and (U1,U2) to (V1,V2) cross at an intermediate point for 5 - * both lines. The variables have been introduced to make this 6 - * already elementary routine more understandable. 7 - * VARIABLES : A : Matrix storing direction vectors. 8 - * DET : Determinant of A. 9 - * EPS : Minimum value for DET to be non-zero. 10 - * (Last changed on 3/ 9/98.) 11 - *----------------------------------------------------------------------- 12 - implicit none 13.- +SEQ,DIMENSIONS. 14.- +SEQ,PARAMETERS. 15 - DOUBLE PRECISION X1,X2,Y1,Y2,U1,U2,V1,V2,A(2,2),DET,EPSX,EPSY, 16 - - AUX,XC,YC 17 - REAL X1S,Y1S,X2S,Y2S,U1S,V1S,U2S,V2S,XCS,YCS 18 - LOGICAL ONLIND,CROSS 19 - EXTERNAL ONLIND 20 - *** Convert to double precision. 21 - X1=DBLE(X1S) 22 - Y1=DBLE(Y1S) 23 - X2=DBLE(X2S) 24 - Y2=DBLE(Y2S) 25 - U1=DBLE(U1S) 26 - V1=DBLE(V1S) 27 - U2=DBLE(U2S) 28 - V2=DBLE(V2S) 29 - *** Matrix to compute the crossing point. 30 - A(1,1)=Y2-Y1 31 - A(2,1)=V2-V1 32 - A(1,2)=X1-X2 33 - A(2,2)=U1-U2 34 - DET=A(1,1)*A(2,2)-A(1,2)*A(2,1) 35 - *** Initial values. 36 - XCS=0 37 - YCS=0 38 - *** Set tolerances. 39 - IF(LEPSG)THEN 40 - EPSX=EPSGX 41 - EPSY=EPSGY 42 - ELSE 43 - EPSX=1.0D-5*MAX(ABS(X1),ABS(X2),ABS(U1),ABS(U2)) 44 - EPSY=1.0D-5*MAX(ABS(Y1),ABS(Y2),ABS(V1),ABS(V2)) 45 - IF(EPSX.LE.0)EPSX=1.0D-5 46 - IF(EPSY.LE.0)EPSY=1.0D-5 47 - ENDIF 48 - * Verify the tolerances. 49 - IF(EPSX.LE.0.OR.EPSY.LE.0)THEN 50 - PRINT *,' !!!!!! CRSPNT WARNING : Tolerances not'// 51 - - ' > 0; returning False.' 52 - CROSS=.FALSE. 53 - RETURN 54 - ENDIF 55 - *** Check for a point of one line located on the other line. 56 - IF(ONLIND(X1,Y1,X2,Y2,U1,V1))THEN 57 - C print *,' Point on other line' 58 - XC=U1 59 - YC=V1 60 - CROSS=.TRUE. 61 - ELSEIF(ONLIND(X1,Y1,X2,Y2,U2,V2))THEN 62 - C print *,' Point on other line' 63 - XC=U2 64 - YC=V2 65 - CROSS=.TRUE. 66 - ELSEIF(ONLIND(U1,V1,U2,V2,X1,Y1))THEN 67 - C print *,' Point on other line' 68 - XC=X1 69 - YC=Y1 70 - CROSS=.TRUE. 71 - ELSEIF(ONLIND(U1,V1,U2,V2,X2,Y2))THEN 72 - C print *,' Point on other line' 73 - XC=X2 74 - YC=Y2 75 - CROSS=.TRUE. 76 - *** Otherwise parallel lines do not cross. 77 - ELSEIF(ABS(DET).LT.EPSX*EPSY)THEN 78 - C print *,' Parallel, non-touching' 79 - CROSS=.FALSE. 80 - ELSE 81 - *** Crossing, non-trivial lines: solve crossing equations. 1 281 P=ROUTINES D=CRSPNT 2 PAGE 392 82 - AUX=A(2,2) 83 - A(2,2)=A(1,1)/DET 84 - A(1,1)=AUX/DET 85 - A(1,2)=-A(1,2)/DET 86 - A(2,1)=-A(2,1)/DET 87 - * Compute crossing point. 88 - XC=A(1,1)*(X1*Y2-X2*Y1)+A(1,2)*(U1*V2-U2*V1) 89 - YC=A(2,1)*(X1*Y2-X2*Y1)+A(2,2)*(U1*V2-U2*V1) 90 - * See whether the crossing point is on both lines. 91 - IF( ONLIND(X1,Y1,X2,Y2,XC,YC).AND. 92 - - ONLIND(U1,V1,U2,V2,XC,YC))THEN 93 - C print *,' Intersecting lines at ',xc,yc 94 - CROSS=.TRUE. 95 - ELSE 96 - C print *,' Crossing point not on both lines ',xc,yc 97 - CROSS=.FALSE. 98 - ENDIF 99 - ENDIF 100 - *** Convert crossing to single precision. 101 - XCS=REAL(XC) 102 - YCS=REAL(YC) 103 - END 282 GARFIELD ================================================== P=ROUTINES D=CRSPND 1 ============================ 0 + +DECK,CRSPND. 1 - SUBROUTINE CRSPND(X1,Y1,X2,Y2,U1,V1,U2,V2,XC,YC,CROSS) 2 - *----------------------------------------------------------------------- 3 - * CRSPND - Determines whether the 2 straight lines (X1,Y1) to (X2,Y2) 4 - * and (U1,U2) to (V1,V2) cross at an intermediate point for 5 - * both lines. The variables have been introduced to make this 6 - * already elementary routine more understandable. 7 - * VARIABLES : A : Matrix storing direction vectors. 8 - * DET : Determinant of A. 9 - * EPS : Minimum value for DET to be non-zero. 10 - * (Last changed on 3/ 9/98.) 11 - *----------------------------------------------------------------------- 12 - implicit none 13.- +SEQ,DIMENSIONS. 14.- +SEQ,PARAMETERS. 15 - DOUBLE PRECISION X1,X2,Y1,Y2,U1,U2,V1,V2,A(2,2),DET,EPSX,EPSY, 16 - - AUX,XC,YC 17 - LOGICAL ONLIND,CROSS 18 - EXTERNAL ONLIND 19 - *** Matrix to compute the crossing point. 20 - A(1,1)=Y2-Y1 21 - A(2,1)=V2-V1 22 - A(1,2)=X1-X2 23 - A(2,2)=U1-U2 24 - DET=A(1,1)*A(2,2)-A(1,2)*A(2,1) 25 - *** Initial values. 26 - XC=0 27 - YC=0 28 - *** Set tolerances. 29 - IF(LEPSG)THEN 30 - EPSX=EPSGX 31 - EPSY=EPSGY 32 - ELSE 33 - EPSX=1.0D-10*MAX(ABS(X1),ABS(X2),ABS(U1),ABS(U2)) 34 - EPSY=1.0D-10*MAX(ABS(Y1),ABS(Y2),ABS(V1),ABS(V2)) 35 - IF(EPSX.LE.0)EPSX=1.0D-10 36 - IF(EPSY.LE.0)EPSY=1.0D-10 37 - ENDIF 38 - * Verify the tolerances. 39 - IF(EPSX.LE.0.OR.EPSY.LE.0)THEN 40 - PRINT *,' !!!!!! CRSPND WARNING : Tolerances not'// 41 - - ' > 0; returning False.' 42 - CROSS=.FALSE. 43 - RETURN 44 - ENDIF 45 - *** Check for a point of one line located on the other line. 46 - IF(ONLIND(X1,Y1,X2,Y2,U1,V1))THEN 47 - C print *,' Point on other line' 48 - XC=U1 49 - YC=V1 50 - CROSS=.TRUE. 51 - ELSEIF(ONLIND(X1,Y1,X2,Y2,U2,V2))THEN 52 - C print *,' Point on other line' 53 - XC=U2 54 - YC=V2 55 - CROSS=.TRUE. 56 - ELSEIF(ONLIND(U1,V1,U2,V2,X1,Y1))THEN 57 - C print *,' Point on other line' 58 - XC=X1 59 - YC=Y1 60 - CROSS=.TRUE. 61 - ELSEIF(ONLIND(U1,V1,U2,V2,X2,Y2))THEN 62 - C print *,' Point on other line' 63 - XC=X2 64 - YC=Y2 65 - CROSS=.TRUE. 66 - *** Otherwise parallel lines do not cross. 67 - ELSEIF(ABS(DET).LT.EPSX*EPSY)THEN 68 - C print *,' Parallel, non-touching' 69 - CROSS=.FALSE. 70 - ELSE 71 - *** Crossing, non-trivial lines: solve crossing equations. 72 - AUX=A(2,2) 73 - A(2,2)=A(1,1)/DET 74 - A(1,1)=AUX/DET 75 - A(1,2)=-A(1,2)/DET 76 - A(2,1)=-A(2,1)/DET 77 - * Compute crossing point. 78 - XC=A(1,1)*(X1*Y2-X2*Y1)+A(1,2)*(U1*V2-U2*V1) 79 - YC=A(2,1)*(X1*Y2-X2*Y1)+A(2,2)*(U1*V2-U2*V1) 80 - * See whether the crossing point is on both lines. 1 282 P=ROUTINES D=CRSPND 2 PAGE 393 81 - IF( ONLIND(X1,Y1,X2,Y2,XC,YC).AND. 82 - - ONLIND(U1,V1,U2,V2,XC,YC))THEN 83 - C print *,' Intersecting lines at ',xc,yc 84 - CROSS=.TRUE. 85 - ELSE 86 - C print *,' Crossing point not on both lines ',xc,yc 87 - CROSS=.FALSE. 88 - ENDIF 89 - ENDIF 90 - END 283 GARFIELD ================================================== P=ROUTINES D=DENLAN 1 ============================ 0 + +DECK,DENLAN. 1 - FUNCTION DENLAN(X) 2 - *----------------------------------------------------------------------- 3 - * DENLAN - Stolen from G110 in GENLIB. 4 - *----------------------------------------------------------------------- 5 - C 6 - DIMENSION P1(0:4),P2(0:4),P3(0:4),P4(0:4),P5(0:4),P6(0:4) 7 - DIMENSION Q1(0:4),Q2(0:4),Q3(0:4),Q4(0:4),Q5(0:4),Q6(0:4) 8 - DIMENSION A1(1:3),A2(1:2) 9 - C 10 - DATA (P1(I),I=0,4),(Q1(J),J=0,4) 11 - 1/ 0.42598 94875E+0,-0.12497 62550E+0, 0.39842 43700E-1, 12 - 2 -0.62982 87635E-2, 0.15111 62253E-2, 13 - 3 1.0 ,-0.33882 60629E+0, 0.95943 93323E-1, 14 - 4 -0.16080 42283E-1, 0.37789 42063E-2/ 15 - C 16 - DATA (P2(I),I=0,4),(Q2(J),J=0,4) 17 - 1/ 0.17885 41609E+0, 0.11739 57403E+0, 0.14888 50518E-1, 18 - 2 -0.13949 89411E-2, 0.12836 17211E-3, 19 - 3 1.0 , 0.74287 95082E+0, 0.31539 32961E+0, 20 - 4 0.66942 19548E-1, 0.87906 09714E-2/ 21 - C 22 - DATA (P3(I),I=0,4),(Q3(J),J=0,4) 23 - 1/ 0.17885 44503E+0, 0.93591 61662E-1, 0.63253 87654E-2, 24 - 2 0.66116 67319E-4,-0.20310 49101E-5, 25 - 3 1.0 , 0.60978 09921E+0, 0.25606 16665E+0, 26 - 4 0.47467 22384E-1, 0.69573 01675E-2/ 27 - C 28 - DATA (P4(I),I=0,4),(Q4(J),J=0,4) 29 - 1/ 0.98740 54407E+0, 0.11867 23273E+3, 0.84927 94360E+3, 30 - 2 -0.74377 92444E+3, 0.42702 62186E+3, 31 - 3 1.0 , 0.10686 15961E+3, 0.33764 96214E+3, 32 - 4 0.20167 12389E+4, 0.15970 63511E+4/ 33 - C 34 - DATA (P5(I),I=0,4),(Q5(J),J=0,4) 35 - 1/ 0.10036 75074E+1, 0.16757 02434E+3, 0.47897 11289E+4, 36 - 2 0.21217 86767E+5,-0.22324 94910E+5, 37 - 3 1.0 , 0.15694 24537E+3, 0.37453 10488E+4, 38 - 4 0.98346 98876E+4, 0.66924 28357E+5/ 39 - C 40 - DATA (P6(I),I=0,4),(Q6(J),J=0,4) 41 - 1/ 0.10008 27619E+1, 0.66491 43136E+3, 0.62972 92665E+5, 42 - 2 0.47555 46998E+6,-0.57436 09109E+7, 43 - 3 1.0 , 0.65141 01098E+3, 0.56974 73333E+5, 44 - 4 0.16591 74725E+6,-0.28157 59939E+7/ 45 - C 46 - DATA (A1(I),I=1,3) 47 - 1/ 0.41666 66667E-1,-0.19965 27778E-1, 0.27095 38966E-1/ 48 - C 49 - DATA (A2(I),I=1,2) 50 - 1/-0.18455 68670E+1,-0.42846 40743E+1/ 51 - C 52 - V=X 53 - *** Modification (RV 7/3/97) 54 - IF(V.LT.-5.0)THEN 55 - DENLAN=0 56 - ELSEIF(V.GT.1E12)THEN 57 - DENLAN=0 58 - C IF(V .LT. -5.5) THEN 59 - C U=EXP(V+1.0) 60 - C DENLAN=0.3989422803*(EXP(-1.0/U)/SQRT(U))* 61 - C 1 (1.0+(A1(1)+(A1(2)+A1(3)*U)*U)*U) 62 - *** End of modification. 63 - ELSE IF(V .LT. -1.0) THEN 64 - U=EXP(-V-1.0) 65 - DENLAN=EXP(-U)*SQRT(U)* 66 - 1 (P1(0)+(P1(1)+(P1(2)+(P1(3)+P1(4)*V)*V)*V)*V)/ 67 - 2 (Q1(0)+(Q1(1)+(Q1(2)+(Q1(3)+Q1(4)*V)*V)*V)*V) 68 - ELSE IF(V .LT. 1.0) THEN 69 - DENLAN=(P2(0)+(P2(1)+(P2(2)+(P2(3)+P2(4)*V)*V)*V)*V)/ 70 - 1 (Q2(0)+(Q2(1)+(Q2(2)+(Q2(3)+Q2(4)*V)*V)*V)*V) 71 - ELSE IF(V .LT. 5.0) THEN 72 - DENLAN=(P3(0)+(P3(1)+(P3(2)+(P3(3)+P3(4)*V)*V)*V)*V)/ 73 - 1 (Q3(0)+(Q3(1)+(Q3(2)+(Q3(3)+Q3(4)*V)*V)*V)*V) 74 - ELSE IF(V .LT. 12.0) THEN 75 - U=1.0/V 76 - DENLAN=U**2*(P4(0)+(P4(1)+(P4(2)+(P4(3)+P4(4)*U)*U)*U)*U)/ 77 - 1 (Q4(0)+(Q4(1)+(Q4(2)+(Q4(3)+Q4(4)*U)*U)*U)*U) 78 - ELSE IF(V .LT. 50.0) THEN 79 - U=1.0/V 80 - DENLAN=U**2*(P5(0)+(P5(1)+(P5(2)+(P5(3)+P5(4)*U)*U)*U)*U)/ 81 - 1 (Q5(0)+(Q5(1)+(Q5(2)+(Q5(3)+Q5(4)*U)*U)*U)*U) 82 - ELSE IF(V .LT. 300.0) THEN 83 - U=1.0/V 84 - DENLAN=U**2*(P6(0)+(P6(1)+(P6(2)+(P6(3)+P6(4)*U)*U)*U)*U)/ 85 - 1 (Q6(0)+(Q6(1)+(Q6(2)+(Q6(3)+Q6(4)*U)*U)*U)*U) 86 - ELSE 87 - U=1.0/(V-V*LOG(V)/(V+1.0)) 88 - DENLAN=U**2*(1.0+(A2(1)+A2(2)*U)*U) 89 - END IF 90 - END 1 284 GARFIELD ================================================== P=ROUTINES D=DIVDF2E 1 =================== PAGE 394 0 + +DECK,DIVDF2E,IF=ESSL. 1 - DOUBLE PRECISION FUNCTION DIVDF2(F,A,N,X,M) 2 - *----------------------------------------------------------------------- 3 - * DIVDF2 - Double precision interpolation routine, calling sequence 4 - * as for DIVDIF (E105) but using ESSL. 5 - * (Last changed on 27/ 3/96.) 6 - *----------------------------------------------------------------------- 7 - IMPLICIT DOUBLE PRECISION(A-H,O-Z) 8.- +SEQ,DIMENSIONS. 9 - DOUBLE PRECISION F(*),A(*),T(1),S(1),AUX(MXLIST+1),X 10 - T(1)=X 11 - CALL DTPINT(A,F,N,M+1,T,S,1,AUX,MXLIST+1) 12 - DIVDF2=S(1) 13 - END 285 GARFIELD ================================================== P=ROUTINES D=DIVDF2C 1 ============================ 0 + +DECK,DIVDF2C,IF=-ESSL. 1 - DOUBLE PRECISION FUNCTION DIVDF2(F,A,NN,X,MM) 2 - *----------------------------------------------------------------------- 3 - * DIVDF2 - Double precision version of DIVDIF. 4 - * Adapted from DIVDIF (CERN program library E105). 5 - * (Last changed on 19/10/93.) 6 - *----------------------------------------------------------------------- 7 - IMPLICIT DOUBLE PRECISION (A-H,O-Z) 8 - DIMENSION A(*),F(*),T(20),D(20) 9 - LOGICAL EXTRA 10 - DATA MMAX/10/ 11 - C 12 - C TABULAR INTERPOLATION USING SYMMETRICALLY PLACED ARGUMENT POINTS. 13 - C 14 - C START. FIND SUBSCRIPT IX OF X IN ARRAY A. 15 - IF( (NN.LT.2) .OR. (MM.LT.1) ) THEN 16 - PRINT *,' ###### DIVDF2 ERROR : Invalid dimensions'// 17 - - ' received for the arguments.' 18 - GO TO 20 19 - ENDIF 20 - N=NN 21 - M=MIN0(MM,MMAX,N-1) 22 - MPLUS=M+1 23 - IX=0 24 - IY=N+1 25 - IF(A(1).GT.A(N)) GO TO 4 26 - *** Search increasing arguments. 27 - 1 MID=(IX+IY)/2 28 - IF(X.GE.A(MID)) GO TO 2 29 - IY=MID 30 - GO TO 3 31 - *** If true. 32 - 2 IX=MID 33 - 3 IF(IY-IX.GT.1) GO TO 1 34 - GO TO 7 35 - *** Search decreasing arguments. 36 - 4 MID=(IX+IY)/2 37 - IF(X.LE.A(MID)) GO TO 5 38 - IY=MID 39 - GO TO 6 40 - C (IF TRUE.) 41 - 5 IX=MID 42 - 6 IF(IY-IX.GT.1) GO TO 4 43 - C 44 - C Copy reordered interpolation points into (T(I),D(I)), setting 45 - C *EXTRA* to TRUE if M+2 points to be used. 46 - C 47 - 7 NPTS=M+2-MOD(M,2) 48 - IP=0 49 - L=0 50 - GO TO 9 51 - 8 L=-L 52 - IF(L.GE.0) L=L+1 53 - 9 ISUB=IX+L 54 - IF((1.LE.ISUB).AND.(ISUB.LE.N)) GO TO 10 55 - *** skip point. 56 - NPTS=MPLUS 57 - GO TO 11 58 - *** Insert point. 59 - 10 IP=IP+1 60 - T(IP)=A(ISUB) 61 - D(IP)=F(ISUB) 62 - 11 IF(IP.LT.NPTS) GO TO 8 63 - EXTRA=NPTS.NE.MPLUS 64 - C 65 - C Replace d by the leading diagonal of a divided-difference table, sup- 66 - C plemented by an extra line if *EXTRA* is true. 67 - C 68 - DO 14 L=1,M 69 - IF(.NOT.EXTRA) GO TO 12 70 - ISUB=MPLUS-L 71 - D(M+2)=(D(M+2)-D(M))/(T(M+2)-T(ISUB)) 72 - 12 I=MPLUS 73 - DO 13 J=L,M 74 - ISUB=I-L 75 - D(I)=(D(I)-D(I-1))/(T(I)-T(ISUB)) 76 - I=I-1 77 - 13 CONTINUE 78 - 14 CONTINUE 79 - C 80 - C Evaluate the Newton interpolation formula at X, averaging two values 81 - C of last difference if *EXTRA* is TRUE. 82 - C 83 - SUM=D(MPLUS) 84 - IF(EXTRA) SUM=0.5*(SUM+D(M+2)) 85 - J=M 86 - DO 15 L=1,M 87 - SUM=D(J)+(X-T(J))*SUM 88 - J=J-1 1 285 P=ROUTINES D=DIVDF2C 2 PAGE 395 89 - 15 CONTINUE 90 - DIVDF2=SUM 91 - RETURN 92 - *** Error processing. 93 - 20 CONTINUE 94 - DIVDF2=0 95 - END 286 GARFIELD ================================================== P=ROUTINES D=BOOK 1 ============================ 0 + +DECK,BOOK. 1 - SUBROUTINE BOOK(ACTION,REFER,MYNAME,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * BOOK - Book keeping of various items. 4 - * (Last changed on 12/10/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9 - INTEGER MXBOOK 10 - PARAMETER(MXBOOK=50) 11 - CHARACTER*(*) ACTION,REFER,MYNAME 12 - CHARACTER*10 NAME(MXBOOK),USER(MXBOOK) 13 - INTEGER STATE(MXBOOK),IFAIL,INPCMX,NBOOK,IREF,I 14 - EXTERNAL INPCMX 0 15-+ +SELF,IF=SAVE. 16 - SAVE NAME,STATE,NBOOK,USER 0 17-+ +SELF. 18 - DATA NBOOK/0/ 19 - *** Allocate a new class. 20 - IF(INPCMX(ACTION,'INIT#IALISE').NE.0)THEN 21 - * Check there is space left. 22 - IF(NBOOK.GE.MXBOOK)THEN 23 - PRINT *,' ###### BOOK ERROR : No room to for'// 24 - - ' the new object ',REFER,'.' 25 - IFAIL=1 26 - RETURN 27 - ENDIF 28 - * Add the item to the list. 29 - NBOOK=NBOOK+1 30 - NAME(NBOOK)=REFER 31 - STATE(NBOOK)=0 32 - USER(NBOOK)=' ' 33 - * Debugging output. 34 - IF(LDEBUG)PRINT *,' ++++++ BOOK DEBUG : New object ', 35 - - REFER,' declared as item ',NBOOK,'.' 36 - * Successful completion. 37 - IFAIL=0 38 - *** Book an object. 39 - ELSEIF(INPCMX(ACTION,'BOOK').NE.0)THEN 40 - * Locate the object. 41 - IREF=0 42 - DO 10 I=1,NBOOK 43 - IF(INPCMX(REFER,NAME(I)).NE.0)IREF=I 44 - 10 CONTINUE 45 - * Object not known. 46 - IF(IREF.EQ.0)THEN 47 - PRINT *,' !!!!!! BOOK WARNING : The object ', 48 - - REFER,' is not known ; not booked.' 49 - IFAIL=1 50 - RETURN 51 - ENDIF 52 - * First check the object has not yet been booked. 53 - IF(STATE(IREF).EQ.1.AND.USER(IREF).EQ.MYNAME)THEN 54 - PRINT *,' ------ BOOK MESSAGE : Object ', 55 - - REFER,' is already booked by same user;'// 56 - - ' not booked again.' 57 - IFAIL=1 58 - RETURN 59 - ELSEIF(STATE(IREF).EQ.1)THEN 60 - PRINT *,' !!!!!! BOOK WARNING : Object ', 61 - - REFER,' is already booked by user '// 62 - - USER(IREF)//'; not booked again.' 63 - IFAIL=1 64 - RETURN 65 - ENDIF 66 - * Book the object. 67 - STATE(IREF)=1 68 - USER(IREF)=MYNAME 69 - * Debugging output. 70 - IF(LDEBUG)PRINT *,' ++++++ BOOK DEBUG : Object ', 71 - - REFER,' booked by ',MYNAME,'.' 72 - * Successful completion. 73 - IFAIL=0 74 - *** Release an object. 75 - ELSEIF(INPCMX(ACTION,'REL#EASE').NE.0)THEN 76 - * Locate the object. 77 - IREF=0 78 - DO 20 I=1,NBOOK 79 - IF(INPCMX(REFER,NAME(I)).NE.0)IREF=I 80 - 20 CONTINUE 81 - * Object not known. 82 - IF(IREF.EQ.0)THEN 83 - PRINT *,' !!!!!! BOOK WARNING : The object ', 84 - - REFER,' is not known ; not released.' 85 - IFAIL=1 86 - RETURN 87 - ENDIF 88 - * Don't release an object booked by someone else. 89 - IF(STATE(IREF).EQ.1.AND.USER(IREF).NE.MYNAME)THEN 90 - PRINT *,' !!!!!! BOOK WARNING : The object ', 91 - - REFER,' was booked by ',USER(IREF) 92 - PRINT *,' Permission'// 93 - - ' to release denied ; not released.' 1 286 P=ROUTINES D=BOOK 2 PAGE 396 94 - IFAIL=1 95 - RETURN 96 - ENDIF 97 - * Debugging output. 98 - IF(LDEBUG)PRINT *,' ++++++ BOOK DEBUG : Object ', 99 - - REFER,' released, previous state ',STATE(IREF), 100 - - ', previous user ',USER(IREF) 101 - * Release the object. 102 - C IF(INPCMX(ACTION,'CL#EAR').NE.0)THEN 103 - STATE(IREF)=0 104 - USER(IREF)=' ' 105 - C ELSE 106 - C STATE(IREF)=2 107 - C ENDIF 108 - * Successful completion. 109 - IFAIL=0 110 - *** Inquiry. 111 - ELSEIF(INPCMX(ACTION,'INQ#UIRE').NE.0)THEN 112 - * Locate the object. 113 - IREF=0 114 - DO 30 I=1,NBOOK 115 - IF(INPCMX(REFER,NAME(I)).NE.0)IREF=I 116 - 30 CONTINUE 117 - * Object not known. 118 - IF(IREF.EQ.0)THEN 119 - PRINT *,' !!!!!! BOOK WARNING : The object ', 120 - - REFER,' is not known ; no information.' 121 - IFAIL=1 122 - RETURN 123 - ENDIF 124 - * Return the user name. 125 - IF(STATE(IREF).EQ.0)THEN 126 - MYNAME=' ' 127 - ELSE 128 - MYNAME=USER(IREF) 129 - ENDIF 130 - * Successful completion. 131 - IFAIL=0 132 - *** List of states. 133 - ELSEIF(INPCMX(ACTION,'L#IST').NE.0)THEN 134 - * Header, depending on the number of objects. 135 - IF(NBOOK.EQ.0)THEN 136 - WRITE(LUNOUT,'(/'' No objects defined sofar.''/)') 137 - IFAIL=0 138 - RETURN 139 - ELSE 140 - WRITE(LUNOUT,'(/'' CURRENTLY KNOWN OBJECTS:''// 141 - - '' Name '',5X,'' Status'')') 142 - ENDIF 143 - * List of objects. 144 - DO 40 I=1,NBOOK 145 - IF(STATE(I).EQ.0)THEN 146 - WRITE(LUNOUT,'(2X,A10,5X,'' Declared, not in use'')') 147 - - NAME(I) 148 - ELSEIF(STATE(I).EQ.1)THEN 149 - WRITE(LUNOUT,'(2X,A10,5X,'' Booked by '',A10)') 150 - - NAME(I),USER(I) 151 - ELSEIF(STATE(I).EQ.2)THEN 152 - WRITE(LUNOUT,'(2X,A10,5X,'' Free, last used by '', 153 - - A10)') NAME(I),USER(I) 154 - ELSE 155 - WRITE(LUNOUT,'(2X,A10,5X,'' Declared, state code '', 156 - - I5,'', user '',A10)') STATE(I),NAME(I),USER(I) 157 - ENDIF 158 - 40 CONTINUE 159 - WRITE(LUNOUT,'('' '')') 160 - * Always successful. 161 - IFAIL=0 162 - *** Unknown action. 163 - ELSE 164 - PRINT *,' !!!!!! BOOK WARNING : Unknown request ',ACTION, 165 - - ' received; nothing done.' 166 - IFAIL=1 167 - ENDIF 168 - END 287 GARFIELD ================================================== P=ROUTINES D=BTEXT 1 ============================ 0 + +DECK,BTEXT,IF=CDC. 1 - SUBROUTINE BTEXT(TEXT) 2 - *----------------------------------------------------------------------- 3 - * N I K H E F C Y B E R O N L Y 4 - * BTEXT - ROUTINE DIE EEN TEKSTJE OP HET B-SCHERM VAN DE CYBER ZET 5 - *----------------------------------------------------------------------- 6 - COMMON/BDISP/ITEXT(8) 7 - CHARACTER*80 TEXT 8 - CHARACTER*80 INFILE 0 9-+ +SELF,IF=SAVE. 10 - SAVE NUMMER 0 11-+ +SELF. 12 - DATA NUMMER/0/ 13 - *** ENIGE FORMATS DEFINIEREN 14 - 1010 FORMAT(8A10) 15 - 1020 FORMAT('===== DRIFTKAMER ',A14,' =====', 16 - - '===== STAP ',I3,' =====') 17 - *** CHARACTER VERSIE TEKST MAKEN EN OMZETTEN IN INTEGER 18 - NUMMER=NUMMER+1 19 - WRITE(INFILE,1020) TEXT(1:14),NUMMER 20 - READ(INFILE,1010) ITEXT 21 - *** TEKST OP SCHERM ZETTEN MET COMPASS ROUTINE BDISP 22 - CALL BDISP 23 - END 24 - IDENT BDISP 25 - LIST -L,-R 1 287 P=ROUTINES D=BTEXT 2 PAGE 397 26 - USE /BDISP/ 27 - ADRESS BSS 8 28 - USE * 29 - ENTRY BDISP 30 - BDISP BSS 1 31 - MESSAGE ADRESS,B,RECALL 32 - JP BDISP 33 - END 288 GARFIELD ================================================== P=ROUTINES D=CRTUBE 1 ============================ 0 + +DECK,CRTUBE. 1 - SUBROUTINE CRTUBE(X0,Y0,Z0,X1,Y1,Z1, 2 - - XX0,YY0,ZZ0,XX1,YY1,ZZ1,R,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * CRTUBE - Computes the crossing points of a tube with a line segment. 5 - * (Last changed on 25/ 3/96.) 6 - *----------------------------------------------------------------------- 7 - DOUBLE PRECISION C0,C1,C2,DET2,P1,P2 8 - REAL X0,Y0,Z0,X1,Y1,Z1,XX0,YY0,ZZ0,XX1,YY1,ZZ1,R 9 - INTEGER IFAIL 10 - *** Initial values. 11 - XX0=X0 12 - XX1=X1 13 - YY0=Y0 14 - YY1=Y1 15 - ZZ0=Z0 16 - ZZ1=Z1 17 - IFAIL=1 18 - *** Polynomial coefficients. 19 - C2=(X1-X0)**2+(Y1-Y0)**2 20 - C1=2*X0*(X1-X0)+2*Y0*(Y1-Y0) 21 - C0=X0**2+Y0**2-R**2 22 - *** Determinant. 23 - DET2=C1**2-4*C0*C2 24 - *** Solutions. 25 - IF(DET2.LT.0)THEN 26 - PRINT *,' !!!!!! CRTUBE WARNING : The line segment does'// 27 - - ' not cross the tube.' 28 - RETURN 29 - ELSEIF(DET2.EQ.0)THEN 30 - C P1=-C1/(2*C2) 31 - C P2=-C1/(2*C2) 32 - PRINT *,' !!!!!! CRTUBE WARNING : The line segment'// 33 - - ' touches the tube or has length 0.' 34 - RETURN 35 - ELSE 36 - P1=(-C1-SQRT(DET2))/(2*C2) 37 - P2=(-C1+SQRT(DET2))/(2*C2) 38 - ENDIF 39 - IF((P1.LT.0.AND.P2.LT.0).OR.(P1.GT.1.AND.P2.GT.1))THEN 40 - PRINT *,' !!!!!! CRTUBE WARNING : The line segment is'// 41 - - ' located outside the tube.' 42 - RETURN 43 - ENDIF 44 - *** Slightly shorten the line segment. 45 - IF(P1.LT.0)THEN 46 - P1=0 47 - ELSEIF(P1.GT.1)THEN 48 - P1=1 49 - ELSEIF(P1.GT.0.5)THEN 50 - P1=0.999*P1 51 - ELSE 52 - P1=1.001*P1 53 - ENDIF 54 - IF(P2.LT.0)THEN 55 - P2=0 56 - ELSEIF(P2.GT.1)THEN 57 - P2=1 58 - ELSEIF(P2.GT.0.5)THEN 59 - P2=0.999*P2 60 - ELSE 61 - P2=1.001*P2 62 - ENDIF 63 - *** And establish the new end points. 64 - XX0=X0+P1*(X1-X0) 65 - YY0=Y0+P1*(Y1-Y0) 66 - ZZ0=Z0+P1*(Z1-Z0) 67 - XX1=X0+P2*(X1-X0) 68 - YY1=Y0+P2*(Y1-Y0) 69 - ZZ1=Z0+P2*(Z1-Z0) 70 - *** Things worked, reset IFAIL to 0. 71 - IFAIL=0 72 - END 289 GARFIELD ================================================== P=ROUTINES D=ROUCAL 1 ============================ 0 + +DECK,ROUCAL. 1 - SUBROUTINE ROUCAL(INSTR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * ROUCAL - Interface to some routines. 4 - * (Last changed on 18/ 9/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9.- +SEQ,ALGDATA. 10.- +SEQ,GLOBALS. 11 - INTEGER ISIZ(MXMDIM),NARG,IPROC,INSTR,IFAIL,MATSLT,IFAIL1,IFAIL2, 12 - - ISLOT1,ISLOT2,ISLOT3,ISLOT4,IREF3,IREF4,NITMAX, 13 - - NDIM,IMOD,LENGTH,J,NC,IENTRY,NNRES,NCOPT 14 - REAL CUMRNF(200),FRNDFU,EPSX,EPSF 15 - CHARACTER*(MXCHAR) STRING,OPTION 16 - CHARACTER*10 VARLIS(MXVAR) 17 - LOGICAL USE(MXVAR),FUNSET 18 - EXTERNAL MATSLT,FRNDFU 1 289 P=ROUTINES D=ROUCAL 2 PAGE 398 19 - COMMON /RNDFCM/ IENTRY,FUNSET,CUMRNF 20 - *** Assume the CALL will fail. 21 - IFAIL=1 22 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 23 - *** Some easy reference variables. 24 - NARG=INS(INSTR,3) 25 - IPROC=INS(INSTR,1) 26 - *** Cartesian, Polar, Internal to one of the others. 27 - IF(IPROC.LE.-701.AND.IPROC.GE.-706)THEN 28 - * Warn if there are arguments. 29 - IF(NARG.NE.4.OR. 30 - - (MODARG(1).NE.2.AND.MODARG(1).NE.5).OR. 31 - - (MODARG(2).NE.2.AND.MODARG(2).NE.5).OR. 32 - - MODARG(1).NE.MODARG(2).OR. 33 - - ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2)THEN 34 - PRINT *,' !!!!!! ROUCAL WARNING : The mapping'// 35 - - ' procedure got wrong arguments; no mapping.' 36 - RETURN 37 - ENDIF 38 - * Clear up any storage associated with the output arguments. 39 - CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) 40 - CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 41 - ** If the arguments are simple numbers ... 42 - IF(MODARG(1).EQ.2)THEN 43 - IF(IPROC.EQ.-701)THEN 44 - CALL CFMCTP(ARG(1),ARG(2),ARG(3),ARG(4),1) 45 - ELSEIF(IPROC.EQ.-702)THEN 46 - CALL CFMCTR(ARG(1),ARG(2),ARG(3),ARG(4),1) 47 - ELSEIF(IPROC.EQ.-703)THEN 48 - CALL CFMPTC(ARG(1),ARG(2),ARG(3),ARG(4),1) 49 - ELSEIF(IPROC.EQ.-704)THEN 50 - CALL CFMPTR(ARG(1),ARG(2),ARG(3),ARG(4),1,IFAIL1) 51 - IF(IFAIL1.NE.0)THEN 52 - PRINT *,' !!!!!! ROUCAL WARNING : Invalid'// 53 - - ' polar coordinates; no conversion.' 54 - RETURN 55 - ENDIF 56 - ELSEIF(IPROC.EQ.-705)THEN 57 - CALL CFMRTC(ARG(1),ARG(2),ARG(3),ARG(4),1) 58 - ELSEIF(IPROC.EQ.-706)THEN 59 - CALL CFMRTP(ARG(1),ARG(2),ARG(3),ARG(4),1) 60 - ENDIF 61 - * And make sure the output is registered as a number. 62 - MODARG(3)=2 63 - MODARG(4)=2 64 - ** If the arguments are matrices. 65 - ELSE 66 - * Locate the input matrices. 67 - ISLOT1=MATSLT(NINT(ARG(1))) 68 - ISLOT2=MATSLT(NINT(ARG(2))) 69 - IF(ISLOT1.LE.0.OR.ISLOT2.LE.0)THEN 70 - PRINT *,' !!!!!! ROUCAL WARNING : Unable to'// 71 - - ' locate input matrices; no conversion.' 72 - RETURN 73 - ELSEIF(MLEN(ISLOT1).NE.MLEN(ISLOT2).OR. 74 - - MLEN(ISLOT1).LT.1)THEN 75 - PRINT *,' !!!!!! ROUCAL WARNING : Matrices have'// 76 - - ' different or zero size; no conversion.' 77 - RETURN 78 - ENDIF 79 - * Store the length. 80 - LENGTH=MLEN(ISLOT1) 81 - * Create output matrices of the size of the input matrices. 82 - DO 10 J=1,MDIM(ISLOT1) 83 - ISIZ(J)=MSIZ(ISLOT1,J) 84 - 10 CONTINUE 85 - NDIM=MDIM(ISLOT1) 86 - IMOD=MMOD(ISLOT1) 87 - CALL MATADM('ALLOCATE',IREF3,NDIM,ISIZ,IMOD,IFAIL1) 88 - CALL MATADM('ALLOCATE',IREF4,NDIM,ISIZ,IMOD,IFAIL2) 89 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN 90 - PRINT *,' !!!!!! ROUCAL WARNING : Unable to'// 91 - - ' allocate output matrices; no conversion.' 92 - RETURN 93 - ENDIF 94 - * Now locate all matrices again (they can have been relocated). 95 - ISLOT1=MATSLT(NINT(ARG(1))) 96 - ISLOT2=MATSLT(NINT(ARG(2))) 97 - ISLOT3=MATSLT(IREF3) 98 - ISLOT4=MATSLT(IREF4) 99 - IF(ISLOT1.LE.0.OR.ISLOT2.LE.0.OR. 100 - - ISLOT3.LE.0.OR.ISLOT4.LE.0)THEN 101 - PRINT *,' !!!!!! ROUCAL WARNING : Unable to'// 102 - - ' locate a matrix; no conversion.' 103 - RETURN 104 - ENDIF 105 - * And carry out the conversion. 106 - IF(IPROC.EQ.-701)THEN 107 - CALL CFMCTP(MVEC(MORG(ISLOT1)+1), 108 - - MVEC(MORG(ISLOT2)+1),MVEC(MORG(ISLOT3)+1), 109 - - MVEC(MORG(ISLOT4)+1),LENGTH) 110 - ELSEIF(IPROC.EQ.-702)THEN 111 - CALL CFMCTR(MVEC(MORG(ISLOT1)+1), 112 - - MVEC(MORG(ISLOT2)+1),MVEC(MORG(ISLOT3)+1), 113 - - MVEC(MORG(ISLOT4)+1),LENGTH) 114 - ELSEIF(IPROC.EQ.-703)THEN 115 - CALL CFMPTC(MVEC(MORG(ISLOT1)+1), 116 - - MVEC(MORG(ISLOT2)+1),MVEC(MORG(ISLOT3)+1), 117 - - MVEC(MORG(ISLOT4)+1),LENGTH) 118 - ELSEIF(IPROC.EQ.-704)THEN 119 - CALL CFMPTR(MVEC(MORG(ISLOT1)+1), 120 - - MVEC(MORG(ISLOT2)+1),MVEC(MORG(ISLOT3)+1), 121 - - MVEC(MORG(ISLOT4)+1),LENGTH,IFAIL1) 122 - IF(IFAIL1.NE.0)THEN 123 - PRINT *,' !!!!!! ROUCAL WARNING : Invalid'// 124 - - ' polar coordinates; no conversion.' 1 289 P=ROUTINES D=ROUCAL 3 PAGE 399 125 - RETURN 126 - ENDIF 127 - ELSEIF(IPROC.EQ.-705)THEN 128 - CALL CFMRTC(MVEC(MORG(ISLOT1)+1), 129 - - MVEC(MORG(ISLOT2)+1),MVEC(MORG(ISLOT3)+1), 130 - - MVEC(MORG(ISLOT4)+1),LENGTH) 131 - ELSEIF(IPROC.EQ.-706)THEN 132 - CALL CFMRTP(MVEC(MORG(ISLOT1)+1), 133 - - MVEC(MORG(ISLOT2)+1),MVEC(MORG(ISLOT3)+1), 134 - - MVEC(MORG(ISLOT4)+1),LENGTH) 135 - ENDIF 136 - * Update the output arrays. 137 - ARG(3)=IREF3 138 - ARG(4)=IREF4 139 - MODARG(3)=5 140 - MODARG(4)=5 141 - ENDIF 142 - *** Random numbers according to a function: preparation. 143 - ELSEIF(IPROC.EQ.-710)THEN 144 - * Check the arguments. 145 - IF(NARG.NE.3.OR.MODARG(1).NE.1.OR.MODARG(2).NE.2.OR. 146 - - MODARG(3).NE.2)THEN 147 - PRINT *,' !!!!!! ROUCAL WARNING :'// 148 - - ' PREPARE_RND_FUNCTION received an incorrect'// 149 - - ' argument list; not executed.' 150 - FUNSET=.FALSE. 151 - RETURN 152 - ENDIF 153 - * Fetch the function. 154 - CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL) 155 - IF(IFAIL.NE.0)THEN 156 - PRINT *,' !!!!!! ROUCAL WARNING : Unable to retrieve'// 157 - - ' the PREPARE_RND_FUNCTION function; call not'// 158 - - ' executed.' 159 - FUNSET=.FALSE. 160 - RETURN 161 - ENDIF 162 - CALL CLTOU(STRING(1:NC)) 163 - * Translate the function. 164 - VARLIS(1)='X' 165 - CALL ALGPRE(STRING(1:NC),NC,VARLIS,1,NNRES,USE,IENTRY,IFAIL) 166 - IF(IFAIL.NE.0)THEN 167 - PRINT *,' !!!!!! ROUCAL WARNING : Unable to'// 168 - - ' translate '//STRING(1:NC)//' ; no random'// 169 - - ' numbers.' 170 - FUNSET=.FALSE. 171 - RETURN 172 - ELSEIF(NNRES.NE.1)THEN 173 - PRINT *,' !!!!!! ROUCAL WARNING : '//STRING(1:NC)// 174 - - ' does not return 1 result; no random numbers.' 175 - CALL ALGCLR(IENTRY) 176 - FUNSET=.FALSE. 177 - RETURN 178 - ENDIF 179 - * Prepare the function with FUGLXF. 180 - CALL FUGLXP(FRNDFU,CUMRNF,ARG(2),ARG(3),IFAIL) 181 - IF(IFAIL.NE.0)THEN 182 - PRINT *,' !!!!!! ROUCAL WARNING : Preparing '// 183 - - STRING(1:NC)//' for random number generation'// 184 - - ' failed; no random numbers.' 185 - CALL ALGCLR(IENTRY) 186 - FUNSET=.FALSE. 187 - RETURN 188 - ENDIF 189 - * If we get this far, preparation was successful. 190 - FUNSET=.TRUE. 191 - *** Extremum search. 192 - ELSEIF(IPROC.EQ.-711)THEN 193 - ** Syntax for a function argument. 194 - IF(MODARG(1).EQ.1)THEN 195 - * Check argument list. 196 - IF(NARG.LT.4.OR.NARG.GT.8.OR. 197 - - (ARGREF(2,2).LT.1.OR.ARGREF(2,2).GT.NGLB).OR. 198 - - MODARG(3).NE.2.OR.MODARG(4).NE.2.OR. 199 - - (NARG.GE.5.AND.MODARG(5).NE.1).OR. 200 - - (NARG.GE.6.AND.MODARG(6).NE.2).OR. 201 - - (NARG.GE.7.AND.MODARG(7).NE.2).OR. 202 - - (NARG.GE.8.AND.MODARG(8).NE.2))THEN 203 - PRINT *,' !!!!!! ROUCAL WARNING : Incorrect'// 204 - - ' argument list for EXTREMUM; not called.' 205 - RETURN 206 - ENDIF 207 - * Retrieve the parameters, first the function. 208 - CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL) 209 - IF(IFAIL.NE.0.OR.NC.LT.1)THEN 210 - PRINT *,' !!!!!! ROUCAL WARNING : Unable to'// 211 - - ' retrieve the function for EXTREMUM;'// 212 - - ' not called.' 213 - RETURN 214 - ENDIF 215 - CALL CLTOU(STRING(1:NC)) 216 - * Convergence. 217 - IF(NARG.GE.6)THEN 218 - EPSX=ARG(6) 219 - ELSE 220 - EPSX=1.0E-4 221 - ENDIF 222 - IF(NARG.GE.7)THEN 223 - EPSF=ARG(7) 224 - ELSE 225 - EPSF=1.0E-4 226 - ENDIF 227 - IF(NARG.GE.6)THEN 228 - NITMAX=NINT(ARG(8)) 229 - ELSE 230 - NITMAX=20 1 289 P=ROUTINES D=ROUCAL 4 PAGE 400 231 - ENDIF 232 - * Options. 233 - IF(NARG.GE.5)THEN 234 - CALL STRBUF('READ',NINT(ARG(5)),OPTION,NCOPT, 235 - - IFAIL) 236 - IF(IFAIL.NE.0)THEN 237 - PRINT *,' !!!!!! ROUCAL WARNING : Unable'// 238 - - ' to retrieve the options for'// 239 - - ' EXTREMUM; not called.' 240 - RETURN 241 - ENDIF 242 - IF(NCOPT.LT.1)THEN 243 - OPTION=' ' 244 - NCOPT=1 245 - ENDIF 246 - CALL CLTOU(OPTION(1:NCOPT)) 247 - ELSE 248 - OPTION=' ' 249 - NCOPT=1 250 - ENDIF 251 - * Call the procedure. 252 - CALL FUNEXT(STRING(1:NC),NC,ARGREF(2,2),ARG(3),ARG(4), 253 - - OPTION(1:NCOPT),EPSX,EPSF,NITMAX,IFAIL) 254 - IF(IFAIL.NE.0)THEN 255 - PRINT *,' !!!!!! ROUCAL WARNING : Extremum'// 256 - - ' search failed; global not updated.' 257 - RETURN 258 - ENDIF 259 - * Return the result. 260 - ARG(2)=GLBVAL(ARGREF(2,2)) 261 - MODARG(2)=2 262 - ** Matrix arguments. 263 - ELSEIF(MODARG(1).EQ.5.AND.MODARG(2).EQ.5)THEN 264 - * Check argument list. 265 - IF(NARG.LT.3.OR.NARG.GT.7.OR. 266 - - (ARGREF(3,2).LT.1.OR.ARGREF(3,2).GT.NGLB).OR. 267 - - (NARG.GE.4.AND.MODARG(4).NE.1).OR. 268 - - (NARG.GE.5.AND.MODARG(5).NE.2).OR. 269 - - (NARG.GE.6.AND.MODARG(6).NE.2).OR. 270 - - (NARG.GE.7.AND.MODARG(7).NE.2))THEN 271 - PRINT *,' !!!!!! ROUCAL WARNING : Incorrect'// 272 - - ' argument list for EXTREMUM; not called.' 273 - RETURN 274 - ENDIF 275 - * Convergence. 276 - IF(NARG.GE.5)THEN 277 - EPSX=ARG(5) 278 - ELSE 279 - EPSX=1.0E-4 280 - ENDIF 281 - IF(NARG.GE.6)THEN 282 - EPSF=ARG(6) 283 - ELSE 284 - EPSF=1.0E-4 285 - ENDIF 286 - IF(NARG.GE.7)THEN 287 - NITMAX=NINT(ARG(7)) 288 - ELSE 289 - NITMAX=20 290 - ENDIF 291 - * Options. 292 - IF(NARG.GE.4)THEN 293 - CALL STRBUF('READ',NINT(ARG(4)),OPTION,NCOPT, 294 - - IFAIL) 295 - IF(IFAIL.NE.0)THEN 296 - PRINT *,' !!!!!! ROUCAL WARNING : Unable'// 297 - - ' to retrieve the options for'// 298 - - ' EXTREMUM; not called.' 299 - RETURN 300 - ENDIF 301 - IF(NCOPT.LT.1)THEN 302 - OPTION=' ' 303 - NCOPT=1 304 - ENDIF 305 - CALL CLTOU(OPTION(1:NCOPT)) 306 - ELSE 307 - OPTION=' ' 308 - NCOPT=1 309 - ENDIF 310 - * Call the procedure. 311 - CALL MATEXT(NINT(ARG(1)),NINT(ARG(2)),ARG(3), 312 - - OPTION(1:NCOPT),EPSX,EPSF,NITMAX,IFAIL) 313 - IF(IFAIL.NE.0)THEN 314 - PRINT *,' !!!!!! ROUCAL WARNING : Extremum'// 315 - - ' search failed; global not updated.' 316 - RETURN 317 - ENDIF 318 - MODARG(3)=2 319 - ELSE 320 - PRINT *,' !!!!!! ROUCAL WARNING : Unknown argument'// 321 - - ' type for EXTREMUM; not called.' 322 - RETURN 323 - ENDIF 324 - *** Unknown routine. 325 - ELSE 326 - PRINT *,' !!!!!! ROUCAL WARNING : Unknown procedure code'// 327 - - ' received; nothing done.' 328 - IFAIL=1 329 - RETURN 330 - ENDIF 331 - *** Seems to have worked. 332 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 333 - IFAIL=0 334 - END 1 290 GARFIELD ================================================== P=ROUTINES D=FRNDFU 1 =================== PAGE 401 0 + +DECK,FRNDFU. 1 - REAL FUNCTION FRNDFU(X) 2 - *----------------------------------------------------------------------- 3 - * FRNDFU - Called from FUGLXP when preparing for generating random 4 - * numbers according to a function PREPARE_RND_FUNCTION. 5 - * (Last chaned on 29/ 8/99.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9 - REAL X,VAR(MXVAR),RES(1),CUMRNF(200) 10 - INTEGER IENTRY,MODVAR(MXVAR),MODRES(1),IFAIL,NREXP,NVAR 11 - LOGICAL FUNSET 12 - COMMON /RNDFCM/ IENTRY,FUNSET,CUMRNF 13 - *** Assign the coordinate. 14 - VAR(1)=X 15 - MODVAR(1)=2 16 - NVAR=1 17 - *** Compute the function. 18 - NREXP=1 19 - CALL AL2EXE(IENTRY,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL) 20 - *** Return the result. 21 - IF(MODRES(1).NE.2)THEN 22 - PRINT *,' !!!!!! FRNDFU WARNING : Function evaluates to'// 23 - - ' a datatype other than Number; set to -1.' 24 - FRNDFU=-1 25 - ELSE 26 - FRNDFU=RES(1) 27 - ENDIF 28 - END 291 GARFIELD ================================================== P=ROUTINES D=CFMCTR 1 ============================ 0 + +DECK,CFMCTR. 1 - SUBROUTINE CFMCTR(X,Y,RHO,PHI,N) 2 - *----------------------------------------------------------------------- 3 - * CFMCTR - Routine transforming (x,y) to (rho,phi) via the conformal 4 - * map (x,y)=exp(rho,phi). This routine may in principle be 5 - * replaced by any conformal mapping routine. 6 - * (Last changed on 14/ 2/97.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9 - REAL X(*),Y(*),RHO(*),PHI(*),RHOI,PHII 10 - INTEGER I,N 11 - COMPLEX Z 12 - *** Loop over the points. 13 - DO 10 I=1,N 14 - IF(X(I).EQ.0.AND.Y(I).EQ.0)THEN 15 - RHOI=-25.0 16 - PHII=0.0 17 - ELSE 18 - Z=LOG(CMPLX(X(I),Y(I))) 19 - RHOI=REAL(Z) 20 - PHII=AIMAG(Z) 21 - ENDIF 22 - RHO(I)=RHOI 23 - PHI(I)=PHII 24 - 10 CONTINUE 25 - END 292 GARFIELD ================================================== P=ROUTINES D=CF2CTR 1 ============================ 0 + +DECK,CF2CTR. 1 - SUBROUTINE CF2CTR(X,Y,RHO,PHI,N) 2 - *----------------------------------------------------------------------- 3 - * CF2CTR - Routine transforming (x,y) to (rho,phi) via the conformal 4 - * map (x,y)=exp(rho,phi). This routine may in principle be 5 - * replaced by any conformal mapping routine. 6 - * (Last changed on 3/10/98.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9 - DOUBLE PRECISION X(*),Y(*),RHO(*),PHI(*),RHOI,PHII 10 - INTEGER I,N 11 - *** Loop over the points. 12 - DO 10 I=1,N 13 - IF(X(I).EQ.0.AND.Y(I).EQ.0)THEN 14 - RHOI=-25.0 15 - PHII=0.0 16 - ELSE 17 - RHOI=0.5*LOG(X(I)**2+Y(I)**2) 18 - PHII=ATAN2(Y(I),X(I)) 19 - ENDIF 20 - RHO(I)=RHOI 21 - PHI(I)=PHII 22 - 10 CONTINUE 23 - END 293 GARFIELD ================================================== P=ROUTINES D=CFMCTP 1 ============================ 0 + +DECK,CFMCTP. 1 - SUBROUTINE CFMCTP(X,Y,R,THETA,N) 2 - *----------------------------------------------------------------------- 3 - * CFMCTP - Routine transforming cartesian to polar coordinates. 4 - * (Last changed on 14/ 2/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,CONSTANTS. 8 - REAL R(*),THETA(*),X(*),Y(*),RI,THETAI 9 - INTEGER N,I 10 - *** Loop over the points. 11 - DO 10 I=1,N 12 - IF(X(I).EQ.0.AND.Y(I).EQ.0)THEN 13 - RI=0 14 - THETAI=0 15 - ELSE 16 - RI=SQRT(X(I)**2+Y(I)**2) 17 - THETAI=180*ATAN2(Y(I),X(I))/PI 1 293 P=ROUTINES D=CFMCTP 2 PAGE 402 18 - ENDIF 19 - R(I)=RI 20 - THETA(I)=THETAI 21 - 10 CONTINUE 22 - END 294 GARFIELD ================================================== P=ROUTINES D=CF2CTP 1 ============================ 0 + +DECK,CF2CTP. 1 - SUBROUTINE CF2CTP(X,Y,R,THETA,N) 2 - *----------------------------------------------------------------------- 3 - * CFM2TP - Routine transforming cartesian to polar coordinates. 4 - * (Last changed on 14/ 2/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,CONSTANTS. 8 - INTEGER N,I 9 - DOUBLE PRECISION R(*),THETA(*),X(*),Y(*),RI,THETAI 10 - *** Loop over the points. 11 - DO 10 I=1,N 12 - IF(X(I).EQ.0.AND.Y(I).EQ.0)THEN 13 - RI=0 14 - THETAI=0 15 - ELSE 16 - RI=SQRT(X(I)**2+Y(I)**2) 17 - THETAI=180*ATAN2(Y(I),X(I))/PI 18 - ENDIF 19 - R(I)=RI 20 - THETA(I)=THETAI 21 - 10 CONTINUE 22 - END 295 GARFIELD ================================================== P=ROUTINES D=CFMPTC 1 ============================ 0 + +DECK,CFMPTC. 1 - SUBROUTINE CFMPTC(R,THETA,X,Y,N) 2 - *----------------------------------------------------------------------- 3 - * CFMPTC - Routine transforming polar to cartesian coordinates. 4 - * (Last changed on 14/ 2/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,CONSTANTS. 8 - REAL R(*),THETA(*),X(*),Y(*),XI,YI 9 - INTEGER N,I 10 - *** Loop over the points. 11 - DO 10 I=1,N 12 - XI=R(I)*COS(PI*THETA(I)/180.0) 13 - YI=R(I)*SIN(PI*THETA(I)/180.0) 14 - X(I)=XI 15 - Y(I)=YI 16 - 10 CONTINUE 17 - END 296 GARFIELD ================================================== P=ROUTINES D=CFMPTR 1 ============================ 0 + +DECK,CFMPTR. 1 - SUBROUTINE CFMPTR(R,THETA,RHO,PHI,N,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * CFMPTR - Routine transforming (r,theta) to (rho,phi) via the map 4 - * (r,theta)=(exp(rho),180*phi/pi). It makes entering cells 5 - * in polar coordinates somewhat easier. 6 - * (Last changed on 14/ 2/97.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,CONSTANTS. 10 - REAL R(*),THETA(*),RHO(*),PHI(*),RHOI,PHII 11 - INTEGER N,IFAIL,I 12 - *** Preset error flag. 13 - IFAIL=0 14 - *** Loop over the points. 15 - DO 10 I=1,N 16 - IF(R(I).EQ.0)THEN 17 - RHOI=-25.0 18 - ELSEIF(R(I).GT.0.0)THEN 19 - RHOI=LOG(R(I)) 20 - ELSE 21 - IFAIL=1 22 - RHO(I)=1 23 - RETURN 24 - ENDIF 25 - PHII=PI*THETA(I)/180.0 26 - RHO(I)=RHOI 27 - PHI(I)=PHII 28 - 10 CONTINUE 29 - END 297 GARFIELD ================================================== P=ROUTINES D=CFMRTC 1 ============================ 0 + +DECK,CFMRTC. 1 - SUBROUTINE CFMRTC(RHO,PHI,X,Y,N) 2 - *----------------------------------------------------------------------- 3 - * CFMRTC - Routine transforming (rho,phi) to (x,y) via the conformal 4 - * map (x,y)=exp(rho,phi). This routine may in principle be 5 - * replaced by any conformal mapping routine. 6 - * (Last changed on 14/ 2/97.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9 - REAL X(*),Y(*),RHO(*),PHI(*),XI,YI 10 - INTEGER N,I 11 - COMPLEX Z 12 - *** Loop over the points. 13 - DO 10 I=1,N 14 - Z=EXP(CMPLX(RHO(I),PHI(I))) 15 - XI=REAL(Z) 16 - YI=AIMAG(Z) 17 - X(I)=XI 1 297 P=ROUTINES D=CFMRTC 2 PAGE 403 18 - Y(I)=YI 19 - 10 CONTINUE 20 - END 298 GARFIELD ================================================== P=ROUTINES D=CFMRTP 1 ============================ 0 + +DECK,CFMRTP. 1 - SUBROUTINE CFMRTP(RHO,PHI,R,THETA,N) 2 - *----------------------------------------------------------------------- 3 - * CFMRTP - Routine transforming (r,theta) to (rho,phi) via the map 4 - * (r,theta)=(exp(rho),180*phi/pi). 5 - * (Last changed on 14/ 2/97.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,CONSTANTS. 9 - REAL R(*),THETA(*),RHO(*),PHI(*),RI,THETAI 10 - INTEGER N,I 11 - *** Loop over the points. 12 - DO 10 I=1,N 13 - RI=EXP(RHO(I)) 14 - THETAI=180.0*PHI(I)/PI 15 - R(I)=RI 16 - THETA(I)=THETAI 17 - 10 CONTINUE 18 - END 299 GARFIELD ================================================== P=ROUTINES D=CF2RTC 1 ============================ 0 + +DECK,CF2RTC. 1 - SUBROUTINE CF2RTC(RHO,PHI,X,Y,N) 2 - *----------------------------------------------------------------------- 3 - * CF2RTC - Routine transforming (rho,phi) to (x,y) via the conformal 4 - * map (x,y)=exp(rho,phi). This routine may in principle be 5 - * replaced by any conformal mapping routine. 6 - * (Last changed on 14/ 2/97.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9 - DOUBLE PRECISION X(*),Y(*),RHO(*),PHI(*),XI,YI 10 - INTEGER I,N 11 - *** Loop over the points. 12 - DO 10 I=1,N 13 - XI=EXP(RHO(I))*COS(PHI(I)) 14 - YI=EXP(RHO(I))*SIN(PHI(I)) 15 - X(I)=XI 16 - Y(I)=YI 17 - 10 CONTINUE 18 - END 300 GARFIELD ================================================== P=ROUTINES D=CF2RTP 1 ============================ 0 + +DECK,CF2RTP. 1 - SUBROUTINE CF2RTP(RHO,PHI,R,THETA,N) 2 - *----------------------------------------------------------------------- 3 - * CF2RTP - Routine transforming (r,theta) to (rho,phi) via the map 4 - * (r,theta)=(exp(rho),180*phi/pi). 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,CONSTANTS. 8 - DOUBLE PRECISION R(*),THETA(*),RHO(*),PHI(*),RI,THETAI 9 - INTEGER I,N 10 - DO 10 I=1,N 11 - RI=EXP(RHO(I)) 12 - THETAI=180.0*PHI(I)/PI 13 - R(I)=RI 14 - THETA(I)=THETAI 15 - 10 CONTINUE 16 - END 301 GARFIELD ================================================== P=ROUTINES D=CLIP 1 ============================ 0 + +DECK,CLIP. 1 - SUBROUTINE CLIP(X0,Y0,X1,Y1,XLL,YLL,XUR,YUR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * CLIP - Routine clipping the line (X0,Y0) to (X1,Y1) to the size of 4 - * the box formed by (XLL,YLL) (XUR,YUR). 5 - * VARIABLES : (X0,Y0) : Begin point of line. 6 - * (X1,Y1) : End point of line. 7 - * (XLL,YLL) : Lower left hand corner of the box. 8 - * (XUR,YUR) : Upper right hand corner of the box. 9 - *----------------------------------------------------------------------- 10 - *** Return on IFAIL=0 if no changes have to be made. 11 - IFAIL=0 12 - IF(XLL.LE.X0.AND.X0.LE.XUR.AND.XLL.LE.X1.AND.X1.LE.XUR.AND. 13 - - YLL.LE.Y0.AND.Y0.LE.YUR.AND.YLL.LE.Y1.AND.Y1.LE.YUR)RETURN 14 - *** The next few returns are on IFAIL=1. 15 - IFAIL=1 16 - *** Return with IFAIL=1 if X0 and X1 are out of range. 17 - IF((X0.LT.XLL.AND.X1.LT.XLL).OR.(X0.GT.XUR.AND.X1.GT.XUR))RETURN 18 - IF(X0.NE.X1)THEN 19 - * Adjust X0. 20 - IF(X0.LT.XLL)THEN 21 - Y0=Y0+((Y1-Y0)/(X1-X0))*(XLL-X0) 22 - X0=XLL 23 - ENDIF 24 - IF(X0.GT.XUR)THEN 25 - Y0=Y0+((Y1-Y0)/(X1-X0))*(XUR-X0) 26 - X0=XUR 27 - ENDIF 28 - * Adjust X1. 29 - IF(X1.LT.XLL)THEN 30 - Y1=Y1+((Y1-Y0)/(X1-X0))*(XLL-X1) 31 - X1=XLL 32 - ENDIF 33 - IF(X1.GT.XUR)THEN 34 - Y1=Y1+((Y1-Y0)/(X1-X0))*(XUR-X1) 35 - X1=XUR 1 301 P=ROUTINES D=CLIP 2 PAGE 404 36 - ENDIF 37 - ENDIF 38 - *** Return with an IFAIL=1 if Y0 and Y1 are out of range. 39 - IF((Y0.LT.YLL.AND.Y1.LT.YLL).OR.(Y0.GT.YUR.AND.Y1.GT.YUR))RETURN 40 - IF(Y0.NE.Y1)THEN 41 - * Adjust Y0. 42 - IF(Y0.LT.YLL)THEN 43 - X0=X0+((X1-X0)/(Y1-Y0))*(YLL-Y0) 44 - Y0=YLL 45 - ENDIF 46 - IF(Y0.GT.YUR)THEN 47 - X0=X0+((X1-X0)/(Y1-Y0))*(YUR-Y0) 48 - Y0=YUR 49 - ENDIF 50 - * Adjust y1. 51 - IF(Y1.LT.YLL)THEN 52 - X1=X1+((X1-X0)/(Y1-Y0))*(YLL-Y1) 53 - Y1=YLL 54 - ENDIF 55 - IF(Y1.GT.YUR)THEN 56 - X1=X1+((X1-X0)/(Y1-Y0))*(YUR-Y1) 57 - Y1=YUR 58 - ENDIF 59 - ENDIF 60 - *** If begin and end point coincide, return with IFAIL=1. 61 - IF(X0.EQ.X1.AND.Y0.EQ.Y1)RETURN 62 - *** All is OK, therefore IFAIL=0. 63 - IFAIL=0 64 - END 302 GARFIELD ================================================== P=ROUTINES D=CLIP2D 1 ============================ 0 + +DECK,CLIP2D. 1 - SUBROUTINE CLIP2D(X0,Y0,X1,Y1,XLL,YLL,XUR,YUR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * CLIP2D - Routine clipping the line (X0,Y0) (X1,Y1) to the size of 4 - * the box formed by (XLL,YLL) (XUR,YUR). 5 - * VARIABLES : (X0,Y0) : Begin point of line. 6 - * (X1,Y1) : End point of line. 7 - * (XLL,ULL) : Lower left hand corner of the box. 8 - * (XUR,YUR) : Upper right hand corner of the box. 9 - * (Last changed on 5/ 2/97.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12 - DOUBLE PRECISION X0,Y0,X1,Y1,XLL,YLL,XUR,YUR 13 - INTEGER IFAIL 14 - *** Return on IFAIL=0 if no changes have to be made. 15 - IFAIL=0 16 - IF(XLL.LE.X0.AND.X0.LE.XUR.AND.XLL.LE.X1.AND.X1.LE.XUR.AND. 17 - - YLL.LE.Y0.AND.Y0.LE.YUR.AND.YLL.LE.Y1.AND.Y1.LE.YUR)RETURN 18 - *** The next few returns are on IFAIL=1. 19 - IFAIL=1 20 - *** Return with IFAIL=1 if X0 and X1 are out of range. 21 - IF((X0.LT.XLL.AND.X1.LT.XLL).OR.(X0.GT.XUR.AND.X1.GT.XUR))RETURN 22 - IF(X0.NE.X1)THEN 23 - * Adjust X0. 24 - IF(X0.LT.XLL)THEN 25 - Y0=Y0+((Y1-Y0)/(X1-X0))*(XLL-X0) 26 - X0=XLL 27 - ENDIF 28 - IF(X0.GT.XUR)THEN 29 - Y0=Y0+((Y1-Y0)/(X1-X0))*(XUR-X0) 30 - X0=XUR 31 - ENDIF 32 - * Adjust X1. 33 - IF(X1.LT.XLL)THEN 34 - Y1=Y1+((Y1-Y0)/(X1-X0))*(XLL-X1) 35 - X1=XLL 36 - ENDIF 37 - IF(X1.GT.XUR)THEN 38 - Y1=Y1+((Y1-Y0)/(X1-X0))*(XUR-X1) 39 - X1=XUR 40 - ENDIF 41 - ENDIF 42 - *** Return with an IFAIL=1 if Y0 and Y1 are out of range. 43 - IF((Y0.LT.YLL.AND.Y1.LT.YLL).OR.(Y0.GT.YUR.AND.Y1.GT.YUR))RETURN 44 - IF(Y0.NE.Y1)THEN 45 - * Adjust y0. 46 - IF(Y0.LT.YLL)THEN 47 - X0=X0+((X1-X0)/(Y1-Y0))*(YLL-Y0) 48 - Y0=YLL 49 - ENDIF 50 - IF(Y0.GT.YUR)THEN 51 - X0=X0+((X1-X0)/(Y1-Y0))*(YUR-Y0) 52 - Y0=YUR 53 - ENDIF 54 - * Adjust y1. 55 - IF(Y1.LT.YLL)THEN 56 - X1=X1+((X1-X0)/(Y1-Y0))*(YLL-Y1) 57 - Y1=YLL 58 - ENDIF 59 - IF(Y1.GT.YUR)THEN 60 - X1=X1+((X1-X0)/(Y1-Y0))*(YUR-Y1) 61 - Y1=YUR 62 - ENDIF 63 - ENDIF 64 - *** If begin and end point coincide, return with IFAIL=1. 65 - IF(X0.EQ.X1.AND.Y0.EQ.Y1)RETURN 66 - *** All is OK, therefore IFAIL=0. 67 - IFAIL=0 68 - END 1 303 GARFIELD ================================================== P=ROUTINES D=CLIP3D 1 =================== PAGE 405 0 + +DECK,CLIP3D. 1 - SUBROUTINE CLIP3D(X0,Y0,Z0,X1,Y1,Z1, 2 - - XLL,YLL,ZLL,XUR,YUR,ZUR,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * CLIP3D - Routine clipping the line (X0,Y0,Z0) to (X1,Y1,Z1) to the 5 - * size of the box formed by (XLL,YLL,ZLL) (XUR,YUR,ZUR). 6 - * VARIABLES : (X0,Y0,Z0) : Begin point of line. 7 - * (X1,Y1,Z1) : End point of line. 8 - * (X/Y/ZLL) : Lower left hand corner of the box. 9 - * (X/Y/ZUR) : Upper right hand corner of the box. 10 - * (Last changed on 6/12/97.) 11 - *----------------------------------------------------------------------- 12 - implicit none 13 - DOUBLE PRECISION X0,Y0,Z0,X1,Y1,Z1,XLL,YLL,ZLL,XUR,YUR,ZUR 14 - INTEGER IFAIL 15 - *** Return on IFAIL=0 if no changes have to be made. 16 - IFAIL=0 17 - IF(XLL.LE.X0.AND.X0.LE.XUR.AND.XLL.LE.X1.AND.X1.LE.XUR.AND. 18 - - YLL.LE.Y0.AND.Y0.LE.YUR.AND.YLL.LE.Y1.AND.Y1.LE.YUR.AND. 19 - - ZLL.LE.Z0.AND.Z0.LE.ZUR.AND.ZLL.LE.Z1.AND.Z1.LE.ZUR)RETURN 20 - *** The next few returns are on IFAIL=1. 21 - IFAIL=1 22 - *** Return with IFAIL=1 if X0 and X1 are out of range. 23 - IF((X0.LT.XLL.AND.X1.LT.XLL).OR.(X0.GT.XUR.AND.X1.GT.XUR))RETURN 24 - IF(X0.NE.X1)THEN 25 - * Adjust X0. 26 - IF(X0.LT.XLL)THEN 27 - Y0=Y0+((Y1-Y0)/(X1-X0))*(XLL-X0) 28 - Z0=Z0+((Z1-Z0)/(X1-X0))*(XLL-X0) 29 - X0=XLL 30 - ENDIF 31 - IF(X0.GT.XUR)THEN 32 - Y0=Y0+((Y1-Y0)/(X1-X0))*(XUR-X0) 33 - Z0=Z0+((Z1-Z0)/(X1-X0))*(XUR-X0) 34 - X0=XUR 35 - ENDIF 36 - * Adjust X1. 37 - IF(X1.LT.XLL)THEN 38 - Y1=Y1+((Y1-Y0)/(X1-X0))*(XLL-X1) 39 - Z1=Z1+((Z1-Z0)/(X1-X0))*(XLL-X1) 40 - X1=XLL 41 - ENDIF 42 - IF(X1.GT.XUR)THEN 43 - Y1=Y1+((Y1-Y0)/(X1-X0))*(XUR-X1) 44 - Z1=Z1+((Z1-Z0)/(X1-X0))*(XUR-X1) 45 - X1=XUR 46 - ENDIF 47 - ENDIF 48 - *** Return with an IFAIL=1 if Y0 and Y1 are out of range. 49 - IF((Y0.LT.YLL.AND.Y1.LT.YLL).OR.(Y0.GT.YUR.AND.Y1.GT.YUR))RETURN 50 - IF(Y0.NE.Y1)THEN 51 - * Adjust Y0. 52 - IF(Y0.LT.YLL)THEN 53 - X0=X0+((X1-X0)/(Y1-Y0))*(YLL-Y0) 54 - Z0=Z0+((Z1-Z0)/(Y1-Y0))*(YLL-Y0) 55 - Y0=YLL 56 - ENDIF 57 - IF(Y0.GT.YUR)THEN 58 - X0=X0+((X1-X0)/(Y1-Y0))*(YUR-Y0) 59 - Z0=Z0+((Z1-Z0)/(Y1-Y0))*(YUR-Y0) 60 - Y0=YUR 61 - ENDIF 62 - * Adjust Y1. 63 - IF(Y1.LT.YLL)THEN 64 - X1=X1+((X1-X0)/(Y1-Y0))*(YLL-Y1) 65 - Z1=Z1+((Z1-Z0)/(Y1-Y0))*(YLL-Y1) 66 - Y1=YLL 67 - ENDIF 68 - IF(Y1.GT.YUR)THEN 69 - X1=X1+((X1-X0)/(Y1-Y0))*(YUR-Y1) 70 - Z1=Z1+((Z1-Z0)/(Y1-Y0))*(YUR-Y1) 71 - Y1=YUR 72 - ENDIF 73 - ENDIF 74 - *** Return with an IFAIL=1 if Z0 and Z1 are out of range. 75 - IF((Z0.LT.ZLL.AND.Z1.LT.ZLL).OR.(Z0.GT.ZUR.AND.Z1.GT.ZUR))RETURN 76 - IF(Z0.NE.Z1)THEN 77 - * Adjust Z0. 78 - IF(Z0.LT.ZLL)THEN 79 - X0=X0+((X1-X0)/(Z1-Z0))*(ZLL-Z0) 80 - Y0=Y0+((Y1-Y0)/(Z1-Z0))*(ZLL-Z0) 81 - Z0=ZLL 82 - ENDIF 83 - IF(Z0.GT.ZUR)THEN 84 - X0=X0+((X1-X0)/(Z1-Z0))*(ZUR-Z0) 85 - Y0=Y0+((Y1-Y0)/(Z1-Z0))*(ZUR-Z0) 86 - Z0=ZUR 87 - ENDIF 88 - * Adjust Z1. 89 - IF(Z1.LT.ZLL)THEN 90 - X1=X1+((X1-X0)/(Z1-Z0))*(ZLL-Z1) 91 - Y1=Y1+((Y1-Y0)/(Z1-Z0))*(ZLL-Z1) 92 - Z1=ZLL 93 - ENDIF 94 - IF(Z1.GT.ZUR)THEN 95 - X1=X1+((X1-X0)/(Z1-Z0))*(ZUR-Z1) 96 - Y1=Y1+((Y1-Y0)/(Z1-Z0))*(ZUR-Z1) 97 - Z1=ZUR 98 - ENDIF 99 - ENDIF 100 - *** If begin and end point coincide, return with IFAIL=1. 101 - IF(X0.EQ.X1.AND.Y0.EQ.Y1.AND.Z0.EQ.Z1)RETURN 102 - *** All is OK, therefore IFAIL=0. 103 - IFAIL=0 104 - END 1 304 GARFIELD ================================================== P=ROUTINES D=CLIP3 1 =================== PAGE 406 0 + +DECK,CLIP3. 1 - SUBROUTINE CLIP3(X0,Y0,Z0,X1,Y1,Z1,XLL,YLL,ZLL,XUR,YUR,ZUR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * CLIP3 - Routine clipping the line (X0,Y0,Z0) to (X1,Y1,Z1) to the 4 - * size of the box formed by (XLL,YLL,ZLL) (XUR,YUR,ZUR). 5 - * VARIABLES : (X0,Y0,Z0) : Begin point of line. 6 - * (X1,Y1,Z1) : End point of line. 7 - * (X/Y/ZLL) : Lower left hand corner of the box. 8 - * (X/Y/ZUR) : Upper right hand corner of the box. 9 - * (Last changed on 26/ 8/98.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12 - REAL X0,Y0,Z0,X1,Y1,Z1,XLL,YLL,ZLL,XUR,YUR,ZUR 13 - INTEGER IFAIL 14 - *** Return on IFAIL=0 if no changes have to be made. 15 - IFAIL=0 16 - IF(XLL.LE.X0.AND.X0.LE.XUR.AND.XLL.LE.X1.AND.X1.LE.XUR.AND. 17 - - YLL.LE.Y0.AND.Y0.LE.YUR.AND.YLL.LE.Y1.AND.Y1.LE.YUR.AND. 18 - - ZLL.LE.Z0.AND.Z0.LE.ZUR.AND.ZLL.LE.Z1.AND.Z1.LE.ZUR)RETURN 19 - *** The next few returns are on IFAIL=1. 20 - IFAIL=1 21 - *** Return with IFAIL=1 if X0 and X1 are out of range. 22 - IF((X0.LT.XLL.AND.X1.LT.XLL).OR.(X0.GT.XUR.AND.X1.GT.XUR))RETURN 23 - IF(X0.NE.X1)THEN 24 - * Adjust X0. 25 - IF(X0.LT.XLL)THEN 26 - Y0=Y0+((Y1-Y0)/(X1-X0))*(XLL-X0) 27 - Z0=Z0+((Z1-Z0)/(X1-X0))*(XLL-X0) 28 - X0=XLL 29 - ENDIF 30 - IF(X0.GT.XUR)THEN 31 - Y0=Y0+((Y1-Y0)/(X1-X0))*(XUR-X0) 32 - Z0=Z0+((Z1-Z0)/(X1-X0))*(XUR-X0) 33 - X0=XUR 34 - ENDIF 35 - * Adjust X1. 36 - IF(X1.LT.XLL)THEN 37 - Y1=Y1+((Y1-Y0)/(X1-X0))*(XLL-X1) 38 - Z1=Z1+((Z1-Z0)/(X1-X0))*(XLL-X1) 39 - X1=XLL 40 - ENDIF 41 - IF(X1.GT.XUR)THEN 42 - Y1=Y1+((Y1-Y0)/(X1-X0))*(XUR-X1) 43 - Z1=Z1+((Z1-Z0)/(X1-X0))*(XUR-X1) 44 - X1=XUR 45 - ENDIF 46 - ENDIF 47 - *** Return with an IFAIL=1 if Y0 and Y1 are out of range. 48 - IF((Y0.LT.YLL.AND.Y1.LT.YLL).OR.(Y0.GT.YUR.AND.Y1.GT.YUR))RETURN 49 - IF(Y0.NE.Y1)THEN 50 - * Adjust Y0. 51 - IF(Y0.LT.YLL)THEN 52 - X0=X0+((X1-X0)/(Y1-Y0))*(YLL-Y0) 53 - Z0=Z0+((Z1-Z0)/(Y1-Y0))*(YLL-Y0) 54 - Y0=YLL 55 - ENDIF 56 - IF(Y0.GT.YUR)THEN 57 - X0=X0+((X1-X0)/(Y1-Y0))*(YUR-Y0) 58 - Z0=Z0+((Z1-Z0)/(Y1-Y0))*(YUR-Y0) 59 - Y0=YUR 60 - ENDIF 61 - * Adjust Y1. 62 - IF(Y1.LT.YLL)THEN 63 - X1=X1+((X1-X0)/(Y1-Y0))*(YLL-Y1) 64 - Z1=Z1+((Z1-Z0)/(Y1-Y0))*(YLL-Y1) 65 - Y1=YLL 66 - ENDIF 67 - IF(Y1.GT.YUR)THEN 68 - X1=X1+((X1-X0)/(Y1-Y0))*(YUR-Y1) 69 - Z1=Z1+((Z1-Z0)/(Y1-Y0))*(YUR-Y1) 70 - Y1=YUR 71 - ENDIF 72 - ENDIF 73 - *** Return with an IFAIL=1 if Z0 and Z1 are out of range. 74 - IF((Z0.LT.ZLL.AND.Z1.LT.ZLL).OR.(Z0.GT.ZUR.AND.Z1.GT.ZUR))RETURN 75 - IF(Z0.NE.Z1)THEN 76 - * Adjust Z0. 77 - IF(Z0.LT.ZLL)THEN 78 - X0=X0+((X1-X0)/(Z1-Z0))*(ZLL-Z0) 79 - Y0=Y0+((Y1-Y0)/(Z1-Z0))*(ZLL-Z0) 80 - Z0=ZLL 81 - ENDIF 82 - IF(Z0.GT.ZUR)THEN 83 - X0=X0+((X1-X0)/(Z1-Z0))*(ZUR-Z0) 84 - Y0=Y0+((Y1-Y0)/(Z1-Z0))*(ZUR-Z0) 85 - Z0=ZUR 86 - ENDIF 87 - * Adjust Z1. 88 - IF(Z1.LT.ZLL)THEN 89 - X1=X1+((X1-X0)/(Z1-Z0))*(ZLL-Z1) 90 - Y1=Y1+((Y1-Y0)/(Z1-Z0))*(ZLL-Z1) 91 - Z1=ZLL 92 - ENDIF 93 - IF(Z1.GT.ZUR)THEN 94 - X1=X1+((X1-X0)/(Z1-Z0))*(ZUR-Z1) 95 - Y1=Y1+((Y1-Y0)/(Z1-Z0))*(ZUR-Z1) 96 - Z1=ZUR 97 - ENDIF 98 - ENDIF 99 - *** If begin and end point coincide, return with IFAIL=1. 100 - IF(X0.EQ.X1.AND.Y0.EQ.Y1.AND.Z0.EQ.Z1)RETURN 101 - *** All is OK, therefore IFAIL=0. 102 - IFAIL=0 103 - END 1 305 GARFIELD ================================================== P=ROUTINES D=DATTIMO 1 =================== PAGE 407 0 + +DECK,DATTIMO,IF=-VAX. 1 - SUBROUTINE DATTIM(DAT,TIM) 2 - *----------------------------------------------------------------------- 3 - * DATTIM - Interface to DATIMH for non-Vax computers. 4 - * (Last changed on 30/ 8/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - CHARACTER*8 DAT,TIM 8 - CALL DATIMH(DAT,TIM) 9 - END 306 GARFIELD ================================================== P=ROUTINES D=DATTIMV 1 ============================ 0 + +DECK,DATTIMV,IF=VAX. 1 - SUBROUTINE DATTIM(DAT,TIM) 2 - *----------------------------------------------------------------------- 3 - * DATTIM - Simulates DATIMH (Z007) on a VAX, the standard DATE 4 - * routine on a Vax returns 9 characters. 5 - * (Last changed on 30/ 8/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8 - CHARACTER*8 DAT,TIM 9 - CHARACTER*9 VAXDAT 10 - *** Call the date and time functions. 11 - CALL TIME(TIM) 12 - CALL DATE(VAXDAT) 13 - *** Convert the named month to a sequence number. 14 - DAT(1:3)=VAXDAT(1:2)//'/' 15 - DAT(4:5)='??' 16 - IF(VAXDAT(4:6).EQ.'JAN')DAT(4:5)='01' 17 - IF(VAXDAT(4:6).EQ.'FEB')DAT(4:5)='02' 18 - IF(VAXDAT(4:6).EQ.'MAR')DAT(4:5)='03' 19 - IF(VAXDAT(4:6).EQ.'APR')DAT(4:5)='04' 20 - IF(VAXDAT(4:6).EQ.'MAY')DAT(4:5)='05' 21 - IF(VAXDAT(4:6).EQ.'JUN')DAT(4:5)='06' 22 - IF(VAXDAT(4:6).EQ.'JUL')DAT(4:5)='07' 23 - IF(VAXDAT(4:6).EQ.'AUG')DAT(4:5)='08' 24 - IF(VAXDAT(4:6).EQ.'SEP')DAT(4:5)='09' 25 - IF(VAXDAT(4:6).EQ.'OCT')DAT(4:5)='10' 26 - IF(VAXDAT(4:6).EQ.'NOV')DAT(4:5)='11' 27 - IF(VAXDAT(4:6).EQ.'DEC')DAT(4:5)='12' 28 - DAT(6:8)='/'//VAXDAT(8:9) 29 - END 307 GARFIELD ================================================== P=ROUTINES D=EPSSET 1 ============================ 0 + +DECK,EPSSET. 1 - SUBROUTINE EPSSET(OPT,EPSX,EPSY,EPSZ) 2 - *----------------------------------------------------------------------- 3 - * EPSSET - Sets the tolerances for point comparisons. 4 - * (Last changed on 30/ 8/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*(*) OPT 11 - DOUBLE PRECISION EPSX,EPSY,EPSZ 12 - *** Tracing. 13 - IF(LIDENT)PRINT *,' /// ROUTINE EPSSET ///' 14 - *** Set new tolerances. 15 - IF(OPT.EQ.'SET')THEN 16 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ EPSSET DEBUG :'', 17 - - '' Setting tolerances: '',3E10.3)') EPSX,EPSY,EPSZ 18 - EPSGX=EPSX 19 - EPSGY=EPSY 20 - EPSGZ=EPSZ 21 - LEPSG=.TRUE. 22 - *** Reset the tolerances. 23 - ELSEIF(OPT.EQ.'RESET')THEN 24 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ EPSSET DEBUG :'', 25 - - '' Resetting the tolerances.'')') 26 - LEPSG=.FALSE. 27 - *** Other options are not known. 28 - ELSE 29 - PRINT *,' !!!!!! EPSSET WARNING : Received the unknown'// 30 - - ' option "',OPT,'" ; ignored.' 31 - ENDIF 32 - END 308 GARFIELD ================================================== P=ROUTINES D=EXPFIT 1 ============================ 0 + +DECK,EXPFIT. 1 - SUBROUTINE EXPFIT(X,Y,EY,N,LPRINT,AA,EA,NA,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * EXPFIT - Fits an exponential of a polynomial. 4 - * (Last changed on 12/ 2/98.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,PRINTPLOT. 8 - INTEGER NNA,IWORK(MXFPAR) 9 - COMMON /PFDAT/ NNA 10 - REAL X(*),Y(*),EY(*) 11 - DOUBLE PRECISION XX(MXLIST),YY(MXLIST),EEY(MXLIST), 12 - - AA(*),EA(*),CHI2,D(MXFPAR,MXFPAR+2),AUX,YSUM 13 - INTEGER N,NA,IFAIL,NDATA 14 - LOGICAL LPRINT 15 - EXTERNAL EXPFUN 16 - *** Preset the error flag. 17 - IFAIL=1 18 - *** Debugging and identification output. 19 - IF(LIDENT)PRINT *,' /// ROUTINE EXPFIT ///' 20 - *** Check dimensions. 21 - IF(NA.GT.MXFPAR.OR.N.GT.MXLIST)THEN 22 - PRINT *,' !!!!!! EXPFIT WARNING : Dimensions of the'// 23 - - ' problem exceed compilation parameters; no fit.' 1 308 P=ROUTINES D=EXPFIT 2 PAGE 408 24 - RETURN 25 - ENDIF 26 - *** Copy the vectors. 27 - YSUM=0 28 - NDATA=0 29 - DO 100 I=1,N 30 - XX(I)=DBLE(X(I)) 31 - YY(I)=DBLE(Y(I)) 32 - IF(YY(I).GT.0)NDATA=NDATA+1 33 - YSUM=YSUM+ABS(YY(I)) 34 - EEY(I)=DBLE(EY(I)) 35 - 100 CONTINUE 36 - *** See whether there are enough valid points. 37 - IF(NDATA.LT.NA)THEN 38 - PRINT *,' !!!!!! EXPFIT WARNING : The problem is under-'// 39 - - 'determined (after eliminating y<=0 points); no fit.' 40 - RETURN 41 - ENDIF 42 - *** Estimate fitting results, first fill matrix. 43 - DO 10 I=0,2*(NA-1) 44 - IF(I.EQ.0)THEN 45 - AUX=NDATA 46 - ELSE 47 - AUX=0 48 - DO 20 J=1,N 49 - IF(YY(J).GT.0)AUX=AUX+XX(J)**I 50 - 20 CONTINUE 51 - ENDIF 52 - DO 30 J=1,NA 53 - K=I+2-J 54 - IF(K.LT.1.OR.K.GT.NA)GOTO 30 55 - D(J,K)=AUX 56 - 30 CONTINUE 57 - 10 CONTINUE 58 - * Left hand side. 59 - DO 40 I=0,NA-1 60 - AUX=0 61 - DO 50 J=1,N 62 - IF(YY(J).LE.0)GOTO 50 63 - IF(I.EQ.0)THEN 64 - AUX=AUX+LOG(YY(J)) 65 - ELSE 66 - AUX=AUX+LOG(YY(J))*XX(J)**I 67 - ENDIF 68 - 50 CONTINUE 69 - D(I+1,MXFPAR+1)=AUX 70 - 40 CONTINUE 71 - * Now solve the equation. 72 - CALL DEQN(NA,D,MXFPAR,IWORK,IFAIL1,1,D(1,MXFPAR+1)) 73 - * Check error condition. 74 - IF(IFAIL1.NE.0)THEN 75 - PRINT *,' !!!!!! EXPFIT WARNING : Failure to obtain'// 76 - - ' a first estimate of the solution; not solved.' 77 - RETURN 78 - ENDIF 79 - * Copy the solution. 80 - DO 60 I=1,NA 81 - AA(I)=D(I,MXFPAR+1) 82 - 60 CONTINUE 83 - * Debugging output. 84 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ EXPFIT DEBUG : Guess'', 85 - - '' before fit: a_i='',3E15.8,(/26X,5E15.8:))') 86 - - (AA(I),I=1,NA) 87 - *** Now carry out the fit. 88 - NNA=NA 89 - CALL LSQFIT(EXPFUN,AA,EA,NA,XX,YY,EEY,N,200,0.01*YSUM/N, 90 - - CHI2,1.0D-3,LPRINT,IFAIL) 91 - END 309 GARFIELD ================================================== P=ROUTINES D=EXPFUN 1 ============================ 0 + +DECK,EXPFUN. 1 - SUBROUTINE EXPFUN(X,A,F) 2 - *----------------------------------------------------------------------- 3 - * EXPFUN - Auxiliary function for fitting an exponential polynomial. 4 - * (Last changed on 9/ 5/96.) 5 - *----------------------------------------------------------------------- 6 - DOUBLE PRECISION A(*),X,F 7 - INTEGER NNA 8 - COMMON /PFDAT/ NNA 9 - *** Sum the polynomial. 10 - F=0 11 - DO 10 I=NNA,1,-1 12 - F=F*X+A(I) 13 - 10 CONTINUE 14 - *** Take an exponential. 15 - IF(F.LT.-50)THEN 16 - F=0 17 - ELSE 18 - F=EXP(MIN(30.0D0,F)) 19 - ENDIF 20 - END 310 GARFIELD ================================================== P=ROUTINES D=PYAFIT 1 ============================ 0 + +DECK,PYAFIT. 1 - SUBROUTINE PYAFIT(X,Y,EY,N,LPRINT,LSQRT,LSCALE,LAUTO,AA,EA,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * PYAFIT - Fits a Polya distribution to a polynomial or histogram. 4 - * (Last changed on 21/ 8/96.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,PRINTPLOT. 8 - REAL X(*),Y(*),EY(*) 9 - REAL XPL(200),YPL(200) 10 - DOUBLE PRECISION XXX,YYY 1 310 P=ROUTINES D=PYAFIT 2 PAGE 409 11 - DOUBLE PRECISION XX(MXLIST),YY(MXLIST),EEY(MXLIST),SFACT,SSIG, 12 - - AA(*),EA(*),CHI2,D(2,4),YTOT,YSUM,YINT,XFIRST,XLAST,TOL 13 - INTEGER N,IFAIL,NDATA,IWORK(2) 14 - LOGICAL LPRINT,LSCALE,LAUTO,XSET,LSQRT 15 - EXTERNAL PYAFUN 16 - *** Preset the error flag. 17 - IFAIL=1 18 - *** Debugging and identification output. 19 - IF(LIDENT)PRINT *,' /// ROUTINE PYAFIT ///' 20 - *** Check dimensions. 21 - IF(N.GT.MXLIST)THEN 22 - PRINT *,' !!!!!! PYAFIT WARNING : Dimensions of the'// 23 - - ' problem exceed compilation parameters; no fit.' 24 - RETURN 25 - ENDIF 26 - *** Copy the vectors, prepare matrix etc - first initialise. 27 - YSUM=0 28 - YINT=0 29 - YTOT=0 30 - SFACT=0 31 - SSIG=0 32 - NDATA=0 33 - NSTART=N/3 34 - XSET=.FALSE. 35 - D(1,1)=0 36 - D(1,2)=0 37 - D(1,3)=0 38 - D(2,1)=0 39 - D(2,2)=0 40 - D(2,3)=0 41 - DO 100 I=1,N 42 - * Vector copy. 43 - XX(I)=DBLE(X(I)) 44 - YY(I)=DBLE(Y(I)) 45 - EEY(I)=DBLE(EY(I)) 46 - * Find smallest and largest x. 47 - IF(Y(I).GT.0)THEN 48 - IF(XSET)THEN 49 - IF(XX(I).LT.XFIRST)XFIRST=XX(I) 50 - IF(XX(I).GT.XLAST)XLAST=XX(I) 51 - ELSE 52 - XFIRST=XX(I) 53 - XLAST=XX(I) 54 - XSET=.TRUE. 55 - ENDIF 56 - ENDIF 57 - * Exponential fit matrix. 58 - IF(EY(I).GT.0.AND.Y(I).GT.0.AND.I.GE.NSTART)THEN 59 - NDATA=NDATA+1 60 - D(1,1)=D(1,1)+ (Y(I)/EY(I))**2 61 - D(1,2)=D(1,2)+X(I) *(Y(I)/EY(I))**2 62 - D(2,1)=D(2,1)+X(I) *(Y(I)/EY(I))**2 63 - D(2,2)=D(2,2)+X(I)**2 *(Y(I)/EY(I))**2 64 - D(1,3)=D(1,3)+LOG(Y(I)) *(Y(I)/EY(I))**2 65 - D(2,3)=D(2,3)+LOG(Y(I))*X(I)*(Y(I)/EY(I))**2 66 - ENDIF 67 - * Normalisation for fixed scale fits. 68 - IF(I.GE.NSTART.AND..NOT.LSCALE)THEN 69 - SFACT=SFACT+EY(I)*Y(I)/EXP(-AA(3)-AA(4)*X(I)) 70 - SSIG=SSIG+EY(I) 71 - ENDIF 72 - * Integral. 73 - YTOT=YTOT+Y(I) 74 - IF(I.EQ.1)THEN 75 - YINT=0 76 - ELSE 77 - YSUM=YSUM+0.5*(Y(I)+Y(I-1))*ABS(X(I)-X(I-1)) 78 - IF(I.GT.NSTART)YINT=YINT+0.5*(Y(I)+Y(I-1))* 79 - - ABS(X(I)-X(I-1)) 80 - ENDIF 81 - 100 CONTINUE 82 - *** See whether there are enough valid points. 83 - IF(NDATA.LT.4.OR. 84 - - (.NOT.LSCALE.AND.SSIG.LE.0).OR. 85 - - YSUM.LE.0.OR.YINT.LE.0.OR. 86 - - XLAST.LE.XFIRST)THEN 87 - PRINT *,' !!!!!! PYAFIT WARNING : The problem is under-'// 88 - - 'determined (after eliminating y<=0 points); no fit.' 89 - RETURN 90 - ENDIF 91 - * Now solve the equation. 92 - CALL DEQN(2,D,2,IWORK,IFAIL1,1,D(1,3)) 93 - * Check error condition. 94 - IF(IFAIL1.NE.0)THEN 95 - PRINT *,' !!!!!! PYAFIT WARNING : Failure to obtain'// 96 - - ' a first estimate of the solution; not solved.' 97 - RETURN 98 - ENDIF 99 - * Copy the solution. 100 - IF(LAUTO)THEN 101 - IF(D(2,3).EQ.0)THEN 102 - PRINT *,' !!!!!! PYAFIT WARNING : Estimated scale'// 103 - - ' is zero; no fit.' 104 - RETURN 105 - ENDIF 106 - AA(2)=0.5 107 - IF(LSCALE)THEN 108 - AA(1)=EXP(D(1,3)+D(2,3)*XFIRST+ 109 - - 0.01*ABS(D(2,3)*(XLAST-XFIRST)))/ 110 - - ABS(D(2,3)) 111 - AA(3)=D(2,3)*XFIRST+ 112 - - 0.01*ABS(D(2,3)*(XLAST-XFIRST)) 113 - AA(4)=-D(2,3) 114 - ELSE 115 - AA(1)=SFACT/SSIG 116 - ENDIF 1 310 P=ROUTINES D=PYAFIT 3 PAGE 410 117 - ENDIF 118 - * Debugging output. 119 - IF(LDEBUG)THEN 120 - WRITE(LUNOUT,'('' ++++++ PYAFIT DEBUG : Guess'', 121 - - '' before fit: a_i=''/26X,4E15.8)') (AA(I),I=1,4) 122 - * Switch to logarithmic scale. 123 - CALL GRAOPT('LIN-X, LOG-Y') 124 - * Make the plot. 125 - CALL GRGRPH(X,Y,N,'x','y','Pre-fit situation') 126 - * Prepare the plot vector. 127 - DO 10 I=1,200 128 - XPL(I)=X(1)+REAL(I-1)*(X(N)-X(1))/199.0 129 - XXX=XPL(I) 130 - CALL PYAFUN(XXX,AA,YYY) 131 - YPL(I)=YYY 132 - 10 CONTINUE 133 - * Set the attributes. 134 - CALL GRATTS('FUNCTION-2','POLYLINE') 135 - * Slot the line itself. 136 - CALL GRLINE(200,XPL,YPL) 137 - * Close the plot. 138 - CALL GRNEXT 139 - * Switch to normal mode. 140 - CALL GRAOPT('LIN-X, LIN-Y') 141 - ENDIF 142 - *** Now carry out the fit. 143 - IF(LSQRT)THEN 144 - TOL=3 145 - ELSE 146 - TOL=0.01*YTOT/N 147 - ENDIF 148 - IF(LSCALE)THEN 149 - CALL LSQFIT(PYAFUN,AA,EA,4,XX,YY,EEY,N,200,TOL, 150 - - CHI2,1.0D-3,LPRINT,IFAIL) 151 - ELSE 152 - CALL LSQFIT(PYAFUN,AA,EA,2,XX,YY,EEY,N,200,TOL, 153 - - CHI2,1.0D-3,LPRINT,IFAIL) 154 - EA(3)=0 155 - EA(4)=0 156 - ENDIF 157 - END 311 GARFIELD ================================================== P=ROUTINES D=PYAFUN 1 ============================ 0 + +DECK,PYAFUN. 1 - SUBROUTINE PYAFUN(X,A,F) 2 - *----------------------------------------------------------------------- 3 - * PYAFUN - Auxiliary function for fitting a Polya distribution. 4 - * (Last changed on 19/ 8/96.) 5 - *----------------------------------------------------------------------- 6 - DOUBLE PRECISION A(*),X,F,DGAMMF 7 - EXTERNAL DGAMMF 8 - *** Compute Polya function. 9 - IF(A(3)+A(4)*X.LE.0)THEN 10 - F=0 11 - ELSEIF(A(2).LE.-1)THEN 12 - F=0 13 - ELSEIF(ABS((A(2)+1)*(A(3)+A(4)*X)).GT.30)THEN 14 - F=0 15 - ELSE 16 - F=A(1)*A(4)*(A(2)+1)**(A(2)+1)/DGAMMF(A(2)+1)* 17 - - (A(3)+A(4)*X)**A(2)* 18 - - EXP(-(A(2)+1)*(A(3)+A(4)*X)) 19 - ENDIF 20 - END 312 GARFIELD ================================================== P=ROUTINES D=FUGLXP 1 ============================ 0 + +DECK,FUGLXP. 1 - SUBROUTINE FUGLXP (FUNC,XFCUM,X2LOW,X2HIGH,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * FUGLXP - Prepares the user function FUNC for FUGLUX. 4 - * Inspired by and mostly copied from FUNPRE and FUNRAN 5 - * except that 6 - * 1. FUNLUX uses RANLUX underneath, 7 - * 2. FUNLXP expands the first and last bins to cater for 8 - * functions with long tails on left and/or right, 9 - * 3. FUNLXP calls FUNPCT to do the actual finding of 10 - * percentiles. 11 - * 4. both FUNLXP and FUNPCT use RADAPT for Gaussian 12 - * integration. 13 - * Origin: V152, Fred James, Sept 1994 14 - *----------------------------------------------------------------------- 15 - implicit none 16.- +SEQ,PRINTPLOT. 17 - EXTERNAL FUNC 18 - INTEGER IFAIL,IERR 19 - REAL XFCUM(200),X2LOW,X2HIGH,XLOW,XHIGH,XRANGE,X2,X3,RTEPS,TFTOT, 20 - - TFTOT1,TFTOT2,UNCERT,FUNC 21 - PARAMETER (RTEPS=0.0002) 22 - *** Find range where function is non-zero. 23 - CALL FUGLZ(FUNC,X2LOW,X2HIGH,XLOW,XHIGH) 24 - XRANGE = XHIGH-XLOW 25 - IF(XRANGE .LE. 0)THEN 26 - PRINT *,' ###### FUGLXP ERROR : Non-zero range of the'// 27 - - ' function has non-positive length; function not'// 28 - - ' prepared for random number generation.' 29 - IFAIL=1 30 - RETURN 31 - ENDIF 32 - *** Integrate the function. 33 - CALL RADAPT(FUNC,XLOW,XHIGH,1,RTEPS,0.,TFTOT ,UNCERT) 34 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ FUGLXP DEBUG : Integral'', 35 - - '' from '',E12.5,'' to '',E12.5,'' is '',E12.5)') 36 - - XLOW,XHIGH,TFTOT 37 - *** Compute percentiles. 1 312 P=ROUTINES D=FUGLXP 2 PAGE 411 38 - CALL FUGPCT(FUNC,XLOW,XHIGH,XFCUM,1,99,TFTOT,IERR) 39 - IF (IERR .GT. 0) GOTO 900 40 - X2 = XFCUM(3) 41 - CALL RADAPT(FUNC,XLOW,X2,1,RTEPS,0.,TFTOT1 ,UNCERT) 42 - CALL FUGPCT(FUNC,XLOW,X2 ,XFCUM,101,49,TFTOT1,IERR) 43 - IF (IERR .GT. 0) GOTO 900 44 - X3 = XFCUM(98) 45 - CALL RADAPT(FUNC,X3,XHIGH,1,RTEPS,0.,TFTOT2 ,UNCERT) 46 - CALL FUGPCT(FUNC,X3,XHIGH,XFCUM,151,49,TFTOT2,IERR) 47 - IF (IERR .GT. 0) GOTO 900 48 - *** Seems to have worked. 49 - IFAIL=0 50 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ FUGLXP DEBUG : Function'', 51 - - '' successfully prepared.'')') 52 - RETURN 53 - *** Error processing. 54 - 900 CONTINUE 55 - IFAIL=1 56 - PRINT *,' ###### FUGLXP ERROR : Error while computing the'// 57 - - ' percentiles ; can not generate random numbers.' 58 - END 313 GARFIELD ================================================== P=ROUTINES D=FUGPCT 1 ============================ 0 + +DECK,FUGPCT. 1 - SUBROUTINE FUGPCT(FUNC,XLOW,XHIGH,XFCUM,NLO,NBINS,TFTOT,IERR) 2 - *----------------------------------------------------------------------- 3 - * FUGPCT - Array XFCUM is filled from NLO to NLO+NBINS, which makes 4 - * the number of values NBINS+1, or the number of bins NBINS 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - EXTERNAL FUNC 8 - REAL XFCUM(*),XLOW,XHIGH,TFTOT,RTEPS,PRECIS,TPCTIL,TZ,TZMAX,X,F, 9 - - X1,X2,F1,TINCR,XINCR,FUNC,DXMAX,TCUM,XBEST,DTBEST,DTABS, 10 - - TPART,TPART2,DTPAR2,REFX,UNCERT,ABERR,FMIN,FMINZ 11 - INTEGER NLO,NBINS,NZ,MAXZ,IZ,IHOME,NITMAX,IBIN,IERR 12 - PARAMETER (RTEPS=0.005, NZ=10, MAXZ=20, NITMAX=6,PRECIS=1.E-6) 13 - *** Set error flag to 'success'. 14 - IERR = 0 15 - *** Check for integral. 16 - IF (TFTOT .LE. 0.) GOTO 900 17 - *** Coarse estimate of percentiles. 18 - TPCTIL = TFTOT/NBINS 19 - TZ = TPCTIL/NZ 20 - TZMAX = TZ * 2. 21 - XFCUM(NLO) = XLOW 22 - XFCUM(NLO+NBINS) = XHIGH 23 - X = XLOW 24 - F = FUNC(X) 25 - IF (F .LT. 0.) GOTO 900 26 - *** Loop over percentile bins 27 - DO 600 IBIN = NLO, NLO+NBINS-2 28 - TCUM = 0. 29 - X1 = X 30 - F1 = F 31 - DXMAX = (XHIGH -X) / NZ 32 - FMIN = TZ/DXMAX 33 - FMINZ = FMIN 34 - *** Loop over trapezoids within a supposed percentile 35 - DO 500 IZ= 1, MAXZ 36 - XINCR = TZ/MAX(F1,FMIN,FMINZ) 37 - 350 X = X1 + XINCR 38 - F = FUNC(X) 39 - IF (F .LT. 0.) GOTO 900 40 - TINCR = (X-X1) * 0.5 * (F+F1) 41 - IF (TINCR .LT. TZMAX) GOTO 370 42 - XINCR = XINCR * 0.5 43 - GOTO 350 44 - 370 CONTINUE 45 - TCUM = TCUM + TINCR 46 - IF (TCUM .GE. TPCTIL*0.99) GOTO 520 47 - FMINZ = TZ*F/ (TPCTIL-TCUM) 48 - F1 = F 49 - X1 = X 50 - 500 CONTINUE 51 - PRINT *,' !!!!!! FUGPCT WARNING : Insufficient trapezoid'// 52 - - ' accuracy over a percentile; inaccurate results.' 53 - *** Adjust, Gaussian integration with Newton corr, F is the derivative. 54 - 520 CONTINUE 55 - X1 = XFCUM(IBIN) 56 - XBEST = X 57 - DTBEST = TPCTIL 58 - TPART = TPCTIL 59 - *** Allow for maximum NITMAX more iterations on RADAPT 60 - DO 550 IHOME= 1, NITMAX 61 - 535 XINCR = (TPCTIL-TPART) / MAX(F,FMIN) 62 - X = XBEST + XINCR 63 - X2 = X 64 - IF (IHOME .GT. 1 .AND. X2 .EQ. XBEST) THEN 65 - PRINT *,' !!!!!! FUGPCT WARNING : Insufficient Gauss'// 66 - - ' precision at X=',X,'; inaccurate results.' 67 - GOTO 580 68 - ENDIF 69 - REFX = ABS(X)+PRECIS 70 - CALL RADAPT(FUNC,X1,X2,1,RTEPS,0.,TPART2,UNCERT) 71 - DTPAR2 = TPART2-TPCTIL 72 - DTABS = ABS(DTPAR2) 73 - IF(ABS(XINCR)/REFX .LT. PRECIS) GOTO 545 74 - IF(DTABS .LT. DTBEST) GOTO 545 75 - XINCR = XINCR * 0.5 76 - GOTO 535 77 - 545 DTBEST = DTABS 78 - XBEST = X 79 - TPART = TPART2 80 - F = FUNC(X) 81 - IF(F .LT. 0.) GOTO 900 1 313 P=ROUTINES D=FUGPCT 2 PAGE 412 82 - IF(DTABS .LT. RTEPS*TPCTIL) GOTO 580 83 - 550 CONTINUE 84 - PRINT *,' !!!!!! FUGPCT WARNING : No convergence in bin ',IBIN, 85 - - ' ; inaccurate results.' 86 - *** < none > 87 - 580 CONTINUE 88 - XINCR = (TPCTIL-TPART) / MAX(F,FMIN) 89 - X = XBEST + XINCR 90 - XFCUM(IBIN+1) = X 91 - F = FUNC(X) 92 - IF(F .LT. 0.) GOTO 900 93 - 600 CONTINUE 94 - *** End of loop over bins 95 - X1 = XFCUM(NLO+NBINS-1) 96 - X2 = XHIGH 97 - CALL RADAPT(FUNC,X1,X2,1,RTEPS,0.,TPART ,UNCERT) 98 - ABERR = ABS(TPART-TPCTIL)/TFTOT 99 - IF(ABERR .GT. RTEPS)PRINT *,' !!!!!! FUGPCT WARNING :'// 100 - - ' Relative error in cumulative distribution may be as big'// 101 - - ' as ',ABERR 102 - *** Normal return. 103 - RETURN 104 - *** Error processing. 105 - 900 CONTINUE 106 - PRINT *,' ###### FUGPCT WARNING : Function negative at x=',X, 107 - - ' f=',F 108 - IERR = 1 109 - END 314 GARFIELD ================================================== P=ROUTINES D=FUGLUX 1 ============================ 0 + +DECK,FUGLUX. 1 - SUBROUTINE FUGLUX(ARRAY,XRAN,LEN) 2 - *----------------------------------------------------------------------- 3 - * FUGLUX - Generation of LEN random numbers in any given distribution, 4 - * by 4-point interpolation in the inverse cumulative distr. 5 - * which was previously generated by FUGLXP 6 - * 7 - * The array ARRAY is assumed to have the following structure: 8 - * ARRAY(1-100) contains the 99 bins of the inverse cumulative 9 - * distribution of the entire function. 10 - * ARRAY(101-150) contains the 49-bin blowup of main bins 11 - * 1 and 2 (left tail of distribution) 12 - * ARRAY(151-200) contains the 49-bin blowup of main bins 13 - * 98 and 99 (right tail of distribution) 14 - * 15 - * Origin: V152, Fred James 16 - *----------------------------------------------------------------------- 17 - implicit none 18 - INTEGER LEN,IBUF,J,J1 19 - REAL ARRAY(*),XRAN(LEN),GAP,GAPINV,TLEFT,BRIGHT,GAPS,GAPINS, 20 - - X,P,A,B 21 - *** Bin width for main sequence, and its inverse 22 - PARAMETER (GAP= 1./99., GAPINV=99.) 23 - *** Top of left tail, bottom of right tail (each tail replaces 2 bins) 24 - PARAMETER (TLEFT= 2./99.,BRIGHT=97./99.) 25 - *** Bin width for minor sequences (tails), and its inverse 26 - PARAMETER (GAPS=TLEFT/49., GAPINS=1./GAPS) 27 - *** Draw random numbers. 28 - CALL RANLUX(XRAN,LEN) 29 - *** Compute random numbers. 30 - DO 500 IBUF= 1, LEN 31 - X = XRAN(IBUF) 32 - J = INT( X *GAPINV) + 1 33 - IF (J .LT. 3) THEN 34 - J1 = INT( X *GAPINS) 35 - J = J1 + 101 36 - J = MAX(J,102) 37 - J = MIN(J,148) 38 - P = ( X -GAPS*(J1-1)) * GAPINS 39 - A = (P+1.0) * ARRAY(J+2) - (P-2.0)*ARRAY(J-1) 40 - B = (P-1.0) * ARRAY(J) - P * ARRAY(J+1) 41 - XRAN(IBUF) = A*P*(P-1.0)*0.16666667 + B*(P+1.0)*(P-2.0)*0.5 42 - ELSE IF (J .GT. 97) THEN 43 - J1 = INT((X-BRIGHT)*GAPINS) 44 - J = J1 + 151 45 - J = MAX(J,152) 46 - J = MIN(J,198) 47 - P = (X -BRIGHT -GAPS*(J1-1)) * GAPINS 48 - A = (P+1.0) * ARRAY(J+2) - (P-2.0)*ARRAY(J-1) 49 - B = (P-1.0) * ARRAY(J) - P * ARRAY(J+1) 50 - XRAN(IBUF) = A*P*(P-1.0)*0.16666667 + B*(P+1.0)*(P-2.0)*0.5 51 - ELSE 52 - P = ( X -GAP*(J-1)) * GAPINV 53 - A = (P+1.0) * ARRAY(J+2) - (P-2.0)*ARRAY(J-1) 54 - B = (P-1.0) * ARRAY(J) - P * ARRAY(J+1) 55 - XRAN(IBUF) = A*P*(P-1.0)*0.16666667 + B*(P+1.0)*(P-2.0)*0.5 56 - ENDIF 57 - 500 CONTINUE 58 - END 315 GARFIELD ================================================== P=ROUTINES D=FUGLZ 1 ============================ 0 + +DECK,FUGLZ. 1 - SUBROUTINE FUGLZ(FUNC,X2LOW,X2HIGH,XLOW,XHIGH) 2 - *----------------------------------------------------------------------- 3 - * FUGLZ - Find range where func is non-zero. 4 - * Origin: V152, Fred James (1980, 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - REAL FUNC,X2LOW,X2HIGH,XLOW,XHIGH,XMID,XH,XL,XNEW 8 - INTEGER LOGN,NSLICE,K,I 9 - EXTERNAL FUNC 10 - *** Set initial limits. 11 - XLOW = X2LOW 12 - XHIGH = X2HIGH 1 315 P=ROUTINES D=FUGLZ 2 PAGE 413 13 - *** Find out if function is zero at one end or both. 14 - XMID = XLOW 15 - IF (FUNC(XLOW) .GT. 0.) GOTO 120 16 - XMID = XHIGH 17 - IF (FUNC(XHIGH) .GT. 0.) GOTO 50 18 - *** Function is zero at both ends, look for place where it is non-zero. 19 - DO 30 LOGN= 1, 7 20 - NSLICE = 2**LOGN 21 - DO 20 I= 1, NSLICE, 2 22 - XMID = XLOW + I * (XHIGH-XLOW) / NSLICE 23 - IF (FUNC(XMID) .GT. 0.) GOTO 50 24 - 20 CONTINUE 25 - 30 CONTINUE 26 - *** Falling through loop means cannot find non-zero value 27 - PRINT *,' !!!!!! FUGLZ WARNING : Cannot find positive'// 28 - - ' function values in the range ',XLOW,XHIGH 29 - XLOW = 0. 30 - XHIGH = 0. 31 - GOTO 220 32 - 50 CONTINUE 33 - *** Delete 'leading' zero range. 34 - XH = XMID 35 - XL = XLOW 36 - DO 70 K= 1, 20 37 - XNEW = 0.5*(XH+XL) 38 - IF (FUNC(XNEW) .EQ. 0.) GOTO 68 39 - XH = XNEW 40 - GOTO 70 41 - 68 XL = XNEW 42 - 70 CONTINUE 43 - XLOW = XL 44 - PRINT *,' !!!!!! FUGLZ WARNING : Cannot find positive'// 45 - - ' function values in the range ',X2LOW,XLOW 46 - 120 CONTINUE 47 - IF (FUNC(XHIGH) .GT. 0.) GOTO 220 48 - *** Delete 'trailing' range of zeroes. 49 - XL = XMID 50 - XH = XHIGH 51 - DO 170 K= 1, 20 52 - XNEW = 0.5*(XH+XL) 53 - IF (FUNC(XNEW) .EQ. 0.) GOTO 168 54 - XL = XNEW 55 - GOTO 170 56 - 168 XH = XNEW 57 - 170 CONTINUE 58 - XHIGH = XH 59 - PRINT *,' !!!!!! FUGLZ WARNING : Cannot find positive'// 60 - - ' function values in the range ',XHIGH,X2HIGH 61 - 220 CONTINUE 62 - END 316 GARFIELD ================================================== P=ROUTINES D=FUNEXT 1 ============================ 0 + +DECK,FUNEXT. 1 - SUBROUTINE FUNEXT(FUN,NC,IGLB,XMIN,XMAX,OPTION,EEPSX,EEPSF, 2 - - NITMAX,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * FUNEXT - Searches for extrema of a function. 5 - * VARIABLES : 6 - * (Last changed on 6/10/00.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,GLOBALS. 11.- +SEQ,PRINTPLOT. 12 - CHARACTER*(*) FUN,OPTION 13 - CHARACTER*20 AUX1,AUX2 14 - INTEGER NC,IENTRY,MODSAV,NITMAX,IGLB,IFAIL,IFAIL1,I,NRNDM, 15 - - MODRES(1),NRES,NREXP,NC1,NC2 16 - REAL XMIN,XMAX,VALSAV,RES(1),RNDUNI,XPL(MXLIST),YPL(MXLIST), 17 - - EEPSX,EEPSF 18 - DOUBLE PRECISION X1,X2,X3,F1,F2,F3,XPARA,FPARA,EPSX,EPSF,FTRY, 19 - - XTRY,FMIN,FMAX 20 - LOGICAL SET1,SET2,SET3,USE(MXVAR),LPRINT,LPLOT,SMIN,SMAX,SKIP 21 - EXTERNAL RNDUNI 22 - *** Identification. 23 - IF(LIDENT)PRINT *,' /// ROUTINE FUNEXT ///' 24 - *** Assume this will work. 25 - IFAIL=0 26 - *** Decode options. 27 - LPLOT=.FALSE. 28 - IF(INDEX(OPTION,'NOPLOT').NE.0)THEN 29 - LPLOT=.FALSE. 30 - ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN 31 - LPLOT=.TRUE. 32 - ENDIF 33 - LPRINT=.FALSE. 34 - IF(INDEX(OPTION,'NOPRINT').NE.0)THEN 35 - LPRINT=.FALSE. 36 - ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN 37 - LPRINT=.TRUE. 38 - ENDIF 39 - SMIN=.TRUE. 40 - SMAX=.FALSE. 41 - IF(INDEX(OPTION,'MIN').NE.0)THEN 42 - SMIN=.TRUE. 43 - SMAX=.FALSE. 44 - ELSEIF(INDEX(OPTION,'MAX').NE.0)THEN 45 - SMIN=.FALSE. 46 - SMAX=.TRUE. 47 - ENDIF 48 - *** Accuracy settings. 49 - EPSX=DBLE(EEPSX) 50 - EPSF=DBLE(EEPSF) 51 - NRNDM=100 52 - *** Debugging output. 1 316 P=ROUTINES D=FUNEXT 2 PAGE 414 53 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ FUNEXT DEBUG : '', 54 - - ''Function to be searched: '',A/26X, 55 - - ''Range to be searched: '',2E15.8/26X, 56 - - ''Minimum / Maximum: '',2L15/26X, 57 - - ''Location / function convergence: '',2F15.8/26X, 58 - - ''Random cycles / max iterations: '',2I15)') 59 - - FUN(1:NC),XMIN,XMAX,SMIN,SMAX,EPSX,EPSF,NRNDM,NITMAX 60 - *** Check the parameters. 61 - IF(EPSX.LE.0.OR.EPSF.LE.0.OR.NITMAX.LT.1)THEN 62 - PRINT *,' !!!!!! FUNEXT WARNING : Received incorrect'// 63 - - ' convergence criteria; no search.' 64 - RETURN 65 - ENDIF 66 - *** Print output. 67 - IF(LPRINT)THEN 68 - IF(SMIN)THEN 69 - WRITE(LUNOUT,'('' Searching for the minimum of '',A)') 70 - - FUN(1:NC) 71 - ELSEIF(SMAX)THEN 72 - WRITE(LUNOUT,'('' Searching for the maximum of '',A)') 73 - - FUN(1:NC) 74 - ENDIF 75 - CALL OUTFMT(XMIN,2,AUX1,NC1,'LEFT') 76 - CALL OUTFMT(XMAX,2,AUX2,NC2,'LEFT') 77 - WRITE(LUNOUT,'('' Search range: '',A,'' < '',A,'' < '',A)') 78 - - AUX1(1:NC1),GLBVAR(IGLB),AUX2(1:NC2) 79 - CALL OUTFMT(REAL(EPSX),2,AUX1,NC1,'LEFT') 80 - WRITE(LUNOUT,'('' Convergence declared for relative'', 81 - - '' position changes less than '',A)') AUX1(1:NC1) 82 - CALL OUTFMT(REAL(EPSF),2,AUX1,NC1,'LEFT') 83 - WRITE(LUNOUT,'('' and for relative function value'', 84 - - '' variations less than '',A,''.'')') AUX1(1:NC1) 85 - CALL OUTFMT(REAL(NRNDM),2,AUX1,NC1,'LEFT') 86 - CALL OUTFMT(REAL(NITMAX),2,AUX2,NC2,'LEFT') 87 - WRITE(LUNOUT,'('' Doing '',A,'' random cycles and at'', 88 - - '' most '',A,'' parabolic searches.''/)') AUX1(1:NC1), 89 - - AUX2(1:NC2) 90 - ENDIF 91 - *** Check the global variable index. 92 - IF(IGLB.LE.0.OR.IGLB.GT.NGLB)THEN 93 - PRINT *,' !!!!!! FUNEXT WARNING : Global variable'// 94 - - ' reference is out of range; no extrema search.' 95 - IFAIL=1 96 - RETURN 97 - ENDIF 98 - *** Save current value in case minimisation fails. 99 - MODSAV=GLBMOD(IGLB) 100 - VALSAV=GLBVAL(IGLB) 101 - *** Prepare the function. 102 - CALL ALGPRE(FUN(1:NC),NC,GLBVAR,NGLB,NRES,USE,IENTRY,IFAIL1) 103 - * Verify that the translation worked. 104 - IF(IFAIL1.NE.0)THEN 105 - PRINT *,' !!!!!! FUNEXT WARNING : The function ',FUN(1:NC), 106 - - ' can not be translated; no extrema search.' 107 - IFAIL=1 108 - CALL ALGCLR(IENTRY) 109 - RETURN 110 - * Ensure there is only 1 result. 111 - ELSEIF(NRES.NE.1)THEN 112 - PRINT *,' !!!!!! FUNEXT WARNING : The function ',FUN(1:NC), 113 - - ' does not return 1 result; no extrema search.' 114 - IFAIL=1 115 - CALL ALGCLR(IENTRY) 116 - RETURN 117 - * Ensure that the function depends on the parameter. 118 - ELSEIF(.NOT.USE(IGLB))THEN 119 - PRINT *,' !!!!!! FUNEXT WARNING : The function ',FUN(1:NC), 120 - - ' does not depend on global ',GLBVAR(IGLB), 121 - - '; no extrema search.' 122 - IFAIL=1 123 - CALL ALGCLR(IENTRY) 124 - RETURN 125 - ENDIF 126 - *** Start a plot, if requested. 127 - IF(LPLOT)THEN 128 - DO 30 I=1,MXLIST 129 - XPL(I)=XMIN+REAL(I-1)*(XMAX-XMIN)/REAL(MXLIST-1) 130 - NREXP=1 131 - GLBVAL(IGLB)=XPL(I) 132 - GLBMOD(IGLB)=2 133 - CALL AL2EXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,NREXP, 134 - - IFAIL1) 135 - IF(IFAIL1.NE.0.OR.MODRES(1).NE.2)THEN 136 - PRINT *,' !!!!!! FUNEXT WARNING : Error evaluating'// 137 - - ' the function ; no extremum search.' 138 - IFAIL=1 139 - GOTO 3000 140 - ENDIF 141 - YPL(I)=RES(1) 142 - 30 CONTINUE 143 - CALL GRGRPH(XPL,YPL,MXLIST,GLBVAR(IGLB),FUN(1:NC), 144 - - 'Function extrema search') 145 - ENDIF 146 - *** Random search for the 3 extreme points. 147 - SET1=.FALSE. 148 - SET2=.FALSE. 149 - SET3=.FALSE. 150 - X1=0 151 - X2=0 152 - X3=0 153 - F1=0 154 - F2=0 155 - F3=0 156 - DO 10 I=1,NRNDM 157 - * Evaluate function. 158 - XTRY=XMIN+RNDUNI(1.0)*(XMAX-XMIN) 1 316 P=ROUTINES D=FUNEXT 3 PAGE 415 159 - NREXP=1 160 - GLBVAL(IGLB)=REAL(XTRY) 161 - GLBMOD(IGLB)=2 162 - CALL AL2EXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,NREXP,IFAIL1) 163 - IF(IFAIL1.NE.0.OR.MODRES(1).NE.2)THEN 164 - PRINT *,' !!!!!! FUNEXT WARNING : Error evaluating the'// 165 - - ' function ; no extremum search.' 166 - IFAIL=1 167 - GOTO 3000 168 - ENDIF 169 - FTRY=RES(1) 170 - * Keep track of the 3 smallest numbers. 171 - IF((SMIN.AND.FTRY.LT.F1).OR.(SMAX.AND.FTRY.GT.F1).OR. 172 - - .NOT.SET1)THEN 173 - F3=F2 174 - X3=X2 175 - IF(SET2)SET3=.TRUE. 176 - F2=F1 177 - X2=X1 178 - IF(SET1)SET2=.TRUE. 179 - F1=FTRY 180 - X1=XTRY 181 - SET1=.TRUE. 182 - ELSEIF((SMIN.AND.FTRY.LT.F2).OR.(SMAX.AND.FTRY.GT.F2).OR. 183 - - .NOT.SET2)THEN 184 - F3=F2 185 - X3=X2 186 - IF(SET2)SET3=.TRUE. 187 - F2=FTRY 188 - X2=XTRY 189 - SET2=.TRUE. 190 - ELSEIF((SMIN.AND.FTRY.LT.F3).OR.(SMAX.AND.FTRY.GT.F3).OR. 191 - - .NOT.SET3)THEN 192 - F3=FTRY 193 - X3=XTRY 194 - SET3=.TRUE. 195 - ENDIF 196 - * Keep track of function range. 197 - IF(LPLOT)THEN 198 - IF(I.EQ.1)THEN 199 - FMIN=FTRY 200 - FMAX=FTRY 201 - ELSE 202 - FMIN=MIN(FTRY,FMIN) 203 - FMAX=MAX(FTRY,FMAX) 204 - ENDIF 205 - ENDIF 206 - * Next random cycle. 207 - 10 CONTINUE 208 - * Print result of random search. 209 - IF(LPRINT)WRITE(LUNOUT,'('' Random search finds an extreme'', 210 - - '' value at x='',E15.8,'' f='',E15.8)') X1,F1 211 - *** Compare with the boundary values. 212 - SKIP=.FALSE. 213 - NREXP=1 214 - GLBVAL(IGLB)=XMIN 215 - GLBMOD(IGLB)=2 216 - CALL AL2EXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,NREXP, 217 - - IFAIL1) 218 - IF(IFAIL1.NE.0.OR.MODRES(1).NE.2)THEN 219 - PRINT *,' !!!!!! FUNEXT WARNING : Error evaluating'// 220 - - ' the function ; no extremum search.' 221 - IFAIL=1 222 - GOTO 3000 223 - ENDIF 224 - IF((SMIN.AND.RES(1).LT.F1).OR.(SMAX.AND.RES(1).GT.F1))THEN 225 - X1=XMIN 226 - F1=RES(1) 227 - SKIP=.TRUE. 228 - IF(LPRINT)WRITE(LUNOUT,'('' Function value at lower'', 229 - - '' range limit is better: f='',E15.8)') RES(1) 230 - ENDIF 231 - NREXP=1 232 - GLBVAL(IGLB)=XMAX 233 - GLBMOD(IGLB)=2 234 - CALL AL2EXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,NREXP, 235 - - IFAIL1) 236 - IF(IFAIL1.NE.0.OR.MODRES(1).NE.2)THEN 237 - PRINT *,' !!!!!! FUNEXT WARNING : Error evaluating'// 238 - - ' the function ; no extremum search.' 239 - IFAIL=1 240 - GOTO 3000 241 - ENDIF 242 - IF((SMIN.AND.RES(1).LT.F1).OR.(SMAX.AND.RES(1).GT.F1))THEN 243 - X1=XMAX 244 - F1=RES(1) 245 - SKIP=.TRUE. 246 - IF(LPRINT)WRITE(LUNOUT,'('' Function value at upper'', 247 - - '' range limit is better: f='',E15.8)') RES(1) 248 - ENDIF 249 - IF(SKIP)THEN 250 - GLBVAL(IGLB)=X1 251 - GLBMOD(IGLB)=2 252 - GOTO 3000 253 - ENDIF 254 - *** Refine the estimate by parabolic extremum search. 255 - DO 20 I=1,NITMAX 256 - * Estimate parabolic extremum. 257 - XPARA=( (F1-F2)*X3**2+(F3-F1)*X2**2+(F2-F3)*X1**2)/ 258 - - (2*((F1-F2)*X3 +(F3-F1)*X2 +(F2-F3)*X1)) 259 - FPARA=-(4*((F1*X2**2-F2*X1**2)*X3-(F1*X2-F2*X1)*X3**2- 260 - - X2**2*F3*X1+X2*F3*X1**2)*((F1-F2)*X3-F1*X2+ 261 - - X2*F3+F2*X1-F3*X1)+((F1-F2)*X3**2-F1*X2**2+X2**2*F3+ 262 - - F2*X1**2-F3*X1**2)**2)/(4*((F1-F2)*X3-F1*X2+ 263 - - X2*F3+F2*X1-F3*X1)*(X3-X2)*(X3-X1)*(X2-X1)) 264 - * Debugging output. 1 316 P=ROUTINES D=FUNEXT 4 PAGE 416 265 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ FUNEXT DEBUG :'', 266 - - '' Start of iteration '',I3// 267 - - 26X,''Point 1: x='',E15.8,'' f='',E15.8/ 268 - - 26X,''Point 2: x='',E15.8,'' f='',E15.8/ 269 - - 26X,''Point 3: x='',E15.8,'' f='',E15.8// 270 - - 26X,''Parabola: x='',E15.8,'' f='',E15.8)') 271 - - I,X1,F1,X2,F2,X3,F3,XPARA,FPARA 272 - * Check that the parabolic estimate is within range. 273 - IF((XMIN-XPARA)*(XPARA-XMAX).LT.0)THEN 274 - PRINT *,' !!!!!! FUNEXT WARNING : Estimated parabolic'// 275 - - ' extremum is located outside curve range.' 276 - IFAIL=1 277 - GOTO 3000 278 - ENDIF 279 - * Check that the new estimate doesn't coincide with an old point. 280 - IF(ABS(XPARA-X1).LT.EPSX*(EPSX+ABS(XPARA)).OR. 281 - - ABS(XPARA-X2).LT.EPSX*(EPSX+ABS(XPARA)).OR. 282 - - ABS(XPARA-X3).LT.EPSX*(EPSX+ABS(XPARA)))THEN 283 - IF(LPRINT)WRITE(LUNOUT,'(/'' Location convergence'', 284 - - '' criterion satisfied.''/)') 285 - GOTO 3000 286 - ENDIF 287 - * Evaluate things over there. 288 - NREXP=1 289 - GLBVAL(IGLB)=REAL(XPARA) 290 - GLBMOD(IGLB)=2 291 - CALL AL2EXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,NREXP,IFAIL1) 292 - IF(IFAIL1.NE.0.OR.MODRES(1).NE.2)THEN 293 - PRINT *,' !!!!!! FUNEXT WARNING : Error evaluating the'// 294 - - ' function ; no extremum search.' 295 - IFAIL=1 296 - GOTO 3000 297 - ENDIF 298 - FPARA=RES(1) 299 - * Normal printout. 300 - IF(LPRINT)WRITE(LUNOUT,'('' Iteration '',I3,'' x='',E15.8, 301 - - '': f = '',E15.8,''.'')') I,XPARA,FPARA 302 - IF(LPLOT)THEN 303 - IF(SMIN)THEN 304 - CALL GRARRO(REAL(XPARA),REAL(FPARA+0.1*(FMAX-FMIN)), 305 - - REAL(XPARA),REAL(FPARA)) 306 - ELSEIF(SMAX)THEN 307 - CALL GRARRO(REAL(XPARA),REAL(FPARA-0.1*(FMAX-FMIN)), 308 - - REAL(XPARA),REAL(FPARA)) 309 - ENDIF 310 - ENDIF 311 - * Check convergence. 312 - IF(ABS(FPARA-F1).LT.EPSF*(ABS(FPARA)+ABS(F1)+EPSF))THEN 313 - IF(LPRINT)WRITE(LUNOUT,'(/'' Function value convergence'', 314 - - '' criterion satisfied.''/)') 315 - GOTO 3000 316 - ENDIF 317 - * Store the value in the table. 318 - IF((SMIN.AND.FPARA.LT.F1).OR.(SMAX.AND.FPARA.GT.F1))THEN 319 - F3=F2 320 - X3=X2 321 - F2=F1 322 - X2=X1 323 - F1=FPARA 324 - X1=XPARA 325 - ELSEIF((SMIN.AND.FPARA.LT.F2).OR.(SMAX.AND.FPARA.GT.F2))THEN 326 - F3=F2 327 - X3=X2 328 - F2=FPARA 329 - X2=XPARA 330 - ELSEIF((SMIN.AND.FPARA.LT.F3).OR.(SMAX.AND.FPARA.GT.F3))THEN 331 - F3=FPARA 332 - X3=XPARA 333 - ELSE 334 - PRINT *,' !!!!!! FUNEXT WARNING : Parabolic extremum'// 335 - - ' is outside current search range; search stopped.' 336 - IFAIL=1 337 - GOTO 3000 338 - ENDIF 339 - 20 CONTINUE 340 - *** No convergence. 341 - PRINT *,' !!!!!! FUNEXT WARNING : No convergence after maximum'// 342 - - ' number of steps.' 343 - PRINT *,' Current extremum f=',F1 344 - PRINT *,' Found for x=',X1 345 - *** Clean up. 346 - 3000 CONTINUE 347 - * Display number of algebra errors. 348 - CALL ALGERR 349 - * Kill algebra entry points. 350 - CALL ALGCLR(IENTRY) 351 - * Close graphics, if active. 352 - IF(LPLOT)CALL GRNEXT 353 - * Restore original results in case of failure. 354 - IF(IFAIL.NE.0)THEN 355 - GLBVAL(IGLB)=VALSAV 356 - GLBMOD(IGLB)=MODSAV 357 - ENDIF 358 - END 317 GARFIELD ================================================== P=ROUTINES D=FUNFIT 1 ============================ 0 + +DECK,FUNFIT. 1 - SUBROUTINE FUNFIT(FUN,X,Y,EY,N,LPRINT,IA,IE,NA,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * FUNFIT - Fits an arbitrary function. 4 - * (Last changed on 17/ 9/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 1 317 P=ROUTINES D=FUNFIT 2 PAGE 417 8.- +SEQ,PRINTPLOT. 9.- +SEQ,GLOBALS. 10 - CHARACTER*(*) FUN 11 - REAL X(*),Y(*),EY(*) 12 - DOUBLE PRECISION XX(MXLIST),YY(MXLIST),EEY(MXLIST), 13 - - AA(MXVAR),EA(MXVAR),CHI2,YSUM 14 - INTEGER N,NA,NNA,IFAIL,IFAIL1,IA(*),IE(*),IENTRY,I,IIA,NRES,NDATA 15 - LOGICAL LPRINT,USE(MXVAR),OK 16 - COMMON /FFUDAT/ NNA,IENTRY,IIA(MXVAR) 17 - EXTERNAL FUNFUN 18 - *** Preset the error flag. 19 - IFAIL=1 20 - OK=.TRUE. 21 - *** Debugging and identification output. 22 - IF(LIDENT)PRINT *,' /// ROUTINE FUNFIT ///' 23 - *** Copy the vectors. 24 - YSUM=0 25 - NDATA=0 26 - DO 30 I=1,N 27 - IF(EY(I).GT.0)THEN 28 - NDATA=NDATA+1 29 - IF(NDATA.LE.MXLIST)THEN 30 - XX(NDATA)=DBLE(X(I)) 31 - YY(NDATA)=DBLE(Y(I)) 32 - YSUM=YSUM+ABS(YY(I)) 33 - EEY(NDATA)=DBLE(EY(I)) 34 - ENDIF 35 - ENDIF 36 - 30 CONTINUE 37 - *** Check remaining number of data points. 38 - IF(NDATA.LT.N)PRINT *,' ------ FUNFIT MESSAGE : Eliminated ', 39 - - N-NDATA,' data points for which error <= 0.' 40 - IF(NDATA.LT.NA)THEN 41 - PRINT *,' !!!!!! FUNFIT WARNING : The problem is not'// 42 - - ' sufficiently constrained; no fit.' 43 - OK=.FALSE. 44 - ENDIF 45 - *** Check dimensions. 46 - IF(NA.GT.MXFPAR.OR.NA.GT.MXVAR.OR.NDATA.GT.MXLIST)THEN 47 - PRINT *,' !!!!!! FUNFIT WARNING : Dimensions of the'// 48 - - ' problem exceed compilation parameters; no fit.' 49 - OK=.FALSE. 50 - ELSEIF(NA.LE.0)THEN 51 - PRINT *,' !!!!!! FUNFIT WARNING : No parameters to be'// 52 - - ' adjusted; no fit.' 53 - OK=.FALSE. 54 - ENDIF 55 - *** Convert the function. 56 - CALL ALGPRE(FUN,LEN(FUN),GLBVAR,NGLB,NRES,USE,IENTRY,IFAIL1) 57 - * Check error flag. 58 - IF(IFAIL1.NE.0)THEN 59 - PRINT *,' !!!!!! FUNFIT WARNING : Translating the'// 60 - - ' function ',FUN,' failed; no fit.' 61 - RETURN 62 - ENDIF 63 - * Check the type of the used globals and copy to a fit vector. 64 - DO 10 I=1,NGLB 65 - IF(USE(I).AND.GLBMOD(I).EQ.0)THEN 66 - PRINT *,' !!!!!! FUNFIT WARNING : The function uses the'// 67 - - ' uninitialised variable '//GLBVAR(I) 68 - OK=.FALSE. 69 - ELSEIF(USE(I).AND.GLBMOD(I).NE.2)THEN 70 - PRINT *,' !!!!!! FUNFIT WARNING : The function uses the'// 71 - - ' non-numeric global '//GLBVAR(I) 72 - OK=.FALSE. 73 - ENDIF 74 - 10 CONTINUE 75 - * Check that all variables are in fact used. 76 - NNA=NA 77 - DO 20 I=1,NA 78 - IF(IA(I).LE.0.OR.IA(I).GT.NGLB)THEN 79 - PRINT *,' !!!!!! FUNFIT WARNING : Incorrect reference'// 80 - - ' to a global received; program bug, please report.' 81 - OK=.FALSE. 82 - ELSEIF(.NOT.USE(IA(I)))THEN 83 - PRINT *,' !!!!!! FUNFIT WARNING : The function does not'// 84 - - ' depend on the variable '//GLBVAR(IA(I)) 85 - OK=.FALSE. 86 - ENDIF 87 - AA(I)=DBLE(GLBVAL(IA(I))) 88 - IIA(I)=IA(I) 89 - 20 CONTINUE 90 - * Ensure that the function depends on x. 91 - IF(NA.GT.1.AND..NOT.USE(8))THEN 92 - PRINT *,' !!!!!! FUNFIT WARNING : The function does not'// 93 - - ' depend on X but on more than 1 fit parameter.' 94 - OK=.FALSE. 95 - ELSEIF(.NOT.USE(8))THEN 96 - PRINT *,' ------ FUNFIT MESSAGE : The function does not'// 97 - - ' depend on X (acceptable for 1 free parameter).' 98 - ENDIF 99 - * Set the mode of global 8 (=X) to 2 and delete anything tied to it. 100 - CALL ALGREU(8,GLBMOD(8),0) 101 - GLBMOD(8)=2 102 - * Check error status. 103 - IF(.NOT.OK)THEN 104 - PRINT *,' !!!!!! FUNFIT WARNING : No fit because of the'// 105 - - ' above warnings.' 106 - RETURN 107 - ENDIF 108 - *** Now carry out the fit. 109 - CALL LSQFIT(FUNFUN,AA,EA,NA,XX,YY,EEY,NDATA,200,0.01*YSUM/NDATA, 110 - - CHI2,1.0D-3,LPRINT,IFAIL1) 111 - * Print the number of errors. 112 - CALL ALGERR 113 - * Check error flag. 1 317 P=ROUTINES D=FUNFIT 3 PAGE 418 114 - IF(IFAIL1.NE.0)THEN 115 - PRINT *,' !!!!!! FUNFIT WARNING : Error fitting the'// 116 - - ' function; results not returned.' 117 - RETURN 118 - ENDIF 119 - *** Transfer the results back. 120 - DO 40 I=1,NA 121 - GLBVAL(IA(I))=REAL(AA(I)) 122 - GLBVAL(IE(I))=REAL(EA(I)) 123 - GLBMOD(IA(I))=2 124 - GLBMOD(IE(I))=2 125 - 40 CONTINUE 126 - *** Things seem to have worked. 127 - IFAIL=0 128 - END 318 GARFIELD ================================================== P=ROUTINES D=FUNFUN 1 ============================ 0 + +DECK,FUNFUN. 1 - SUBROUTINE FUNFUN(X,A,F) 2 - *----------------------------------------------------------------------- 3 - * FUNFUN - Auxiliary function for fitting an arbitrary function. 4 - * (Last changed on 17/ 9/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GLOBALS. 9 - DOUBLE PRECISION A(*),X,F 10 - REAL AA(MXVAR),RES(1) 11 - INTEGER NNA,IIA,IFAIL1,I,IENTRY,MODRES(1) 12 - COMMON /FFUDAT/ NNA,IENTRY,IIA(MXVAR) 13 - *** Copy fit parameters to single precision. 14 - DO 10 I=1,NGLB 15 - AA(I)=GLBVAL(I) 16 - 10 CONTINUE 17 - DO 20 I=1,NNA 18 - AA(IIA(I))=REAL(A(I)) 19 - 20 CONTINUE 20 - *** Copy ordinate to single precision. 21 - AA(8)=REAL(X) 22 - *** Evaluate the function. 23 - CALL AL2EXE(IENTRY,AA,GLBMOD,NGLB,RES,MODRES,1,IFAIL1) 24 - *** And return the result. 25 - IF(IFAIL1.EQ.0)THEN 26 - F=DBLE(RES(1)) 27 - ELSE 28 - F=0 29 - ENDIF 30 - END 319 GARFIELD ================================================== P=ROUTINES D=F010 1 ============================ 0 + +DECK,F010,IF=NAGNUM. 1 - SUBROUTINE DEQINV(N,A,IDIM,R,IFAIL,K,B) 2 - *----------------------------------------------------------------------- 3 - * DEQINV - Replacement for the DEQINV (F010) routine from the KERNLIB 4 - * at CERN using NAG routines. This routine will only work in 5 - * the Garfield environment. The input matrix is assumed to be 6 - * symmetric. If it's also positive definite, Choleski's method 7 - * is used; if a more approximate implementation of Crout's. 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,PRINTPLOT. 11 - DOUBLE PRECISION A(IDIM,*),R(IDIM),B(IDIM) 12 - DOUBLE PRECISION C(MXWIRE+1,MXWIRE+1),EPS,X(MXWIRE+1) 13 - *** Check that the declared dimensions are sufficient. 14 - IF(N.GE.IDIM.OR.N.GE.MXWIRE+1)THEN 15 - PRINT *,' ###### DEQINV ERROR : Matrix dimension too', 16 - - ' large, recompile with a MXWIRE > ',N+1 17 - IFAIL=1 18 - RETURN 19 - ENDIF 20 - *** Set the precision 21 - EPS=X02AAF(DUMMY) 22 - *** Perform a Choleski inversion. 23 - IFAIL=1 24 - CALL F01ACF(N,EPS,A,IDIM,C,MXWIRE+1,R,L,IFAIL) 25 - IF(IFAIL.EQ.1)THEN 26 - PRINT *,' !!!!!! DEQINV WARNING : The matrix is not'// 27 - - ' pos. def., perhaps due to rouding errors (F01ACF);' 28 - PRINT *,' An attempt will be made'// 29 - - ' to invert using Crout''s method.' 30 - GOTO 100 31 - ELSEIF(IFAIL.EQ.2)THEN 32 - PRINT *,' !!!!!! DEQINV WARNING : The refinement fails to'// 33 - - ' converge, ie the matrix is ill-conditioned (F01ACF);' 34 - PRINT *,' An attempt will be made'// 35 - - ' to invert using Crout''s method.' 36 - GOTO 100 37 - ELSEIF(IFAIL.NE.0.AND.IFAIL.NE.1.AND.IFAIL.NE.2)THEN 38 - PRINT *,' !!!!!! DEQINV WARNING : Unidentified NAG error'// 39 - - ' error condition from F01ACF: ',IFAIL,';' 40 - PRINT *,' An attempt will be made'// 41 - - ' to invert using Crout''s method.' 42 - GOTO 100 43 - ENDIF 44 - IF(LDEBUG)PRINT *,' ++++++ DEQINV DEBUG : F01ACF iterations ', 45 - - L,' IFAIL=',IFAIL 46 - *** Set the correct inverse all over the matrix 47 - DO 20 I=2,N+1 48 - DO 10 J=1,I-1 49 - A(I-1,J)=A(I,J) 50 - A(J,I-1)=A(I,J) 51 - 10 CONTINUE 52 - 20 CONTINUE 53 - *** Skip the next part which is only used if Choleski fails. 1 319 P=ROUTINES D=F010 2 PAGE 419 54 - GOTO 200 55 - *** Try Crout's method if Choleski fails. First restore matrix. 56 - 100 CONTINUE 57 - DO 110 I=1,N 58 - DO 120 J=I,N 59 - A(J,I)=A(I,J) 60 - 120 CONTINUE 61 - 110 CONTINUE 62 - *** Next call the Crout, approximate, routine. 63 - IFAIL=1 64 - CALL F01AAF(A,IDIM,N,C,MXWIRE+1,R,IFAIL) 65 - IF(IFAIL.EQ.1)THEN 66 - PRINT *,' ###### DEQINV ERROR : The matrix is (almost)', 67 - - ' singular, perhaps due to rounding errors (F01AAF).' 68 - RETURN 69 - ELSEIF(IFAIL.NE.0.AND.IFAIL.NE.1)THEN 70 - PRINT *,' ###### DEQINV WARNING : Unidentified NAG error', 71 - - ' error condition from F01AAF: ',IFAIL 72 - RETURN 73 - ENDIF 74 - PRINT *,' !!!!!! DEQINV WARNING : Crout''s method succeeded'// 75 - - ' but the results are less accurate (F01AAF).' 76 - *** Copy the inverted matrix to A. 77 - DO 130 I=1,N 78 - DO 140 J=1,N 79 - A(I,J)=C(I,J) 80 - 140 CONTINUE 81 - 130 CONTINUE 82 - *** Solve the system of equations. 83 - 200 CONTINUE 84 - DO 210 I=1,N 85 - X(I)=0 86 - DO 220 J=1,N 87 - X(I)=X(I)+A(I,J)*B(J) 88 - 220 CONTINUE 89 - 210 CONTINUE 90 - *** Copy X to B. 91 - DO 230 I=1,N 92 - B(I)=X(I) 93 - 230 CONTINUE 94 - END 95 - SUBROUTINE DEQN(N,A,IDIM,R,IFAIL,K,B) 96 - *----------------------------------------------------------------------- 97 - * DEQN - Replacement for the DEQN (F010) routine from the KERNLIB at 98 - * CERN using NAG routines. This routine will only work in the 99 - * Garfield environment. 100 - *----------------------------------------------------------------------- 101.- +SEQ,DIMENSIONS. 102.- +SEQ,PRINTPLOT. 103 - PARAMETER(MXRGHT=3) 104 - DOUBLE PRECISION A(IDIM,*),R(IDIM),B(IDIM,*) 105 - DOUBLE PRECISION AA(MXWIRE+1,MXWIRE+1),EPS,D1,X(MXWIRE+1,MXRGHT), 106 - - BB(MXWIRE+1,MXRGHT) 107 - *** Check the dimensions. 108 - IF(K.GT.MXRGHT)THEN 109 - PRINT *,' ###### DEQN ERROR : Too many right hand', 110 - - ' sides; recompile with MXRGHT=',K 111 - IFAIL=1 112 - RETURN 113 - ENDIF 114 - IF(N.GT.MXWIRE+1)THEN 115 - PRINT *,' ###### DEQN ERROR : Order of the matrix is', 116 - - ' too large; use the true DEQN routine.' 117 - IFAIL=1 118 - ENDIF 119 - *** Set the precision 120 - EPS=X02AAF(DUMMY) 121 - *** Copy the input array AA 122 - DO 10 I=1,N 123 - DO 20 J=1,N 124 - AA(I,J)=A(I,J) 125 - 20 CONTINUE 126 - 10 CONTINUE 127 - *** Perform a Crout factorisation. 128 - IFAIL=1 129 - CALL F03AFF(N,EPS,AA,MXWIRE+1,D1,ID,R,IFAIL) 130 - IF(IFAIL.EQ.1)THEN 131 - PRINT *,' ###### DEQN ERROR : The matrix is singular', 132 - - ' perhaps because of rounding errors (F03AFF).' 133 - RETURN 134 - ELSEIF(IFAIL.NE.0.AND.IFAIL.NE.1)THEN 135 - PRINT *,' ###### DEQN ERROR : Unidentified NAG error', 136 - - ' error condition from F03AFF: ',IFAIL 137 - RETURN 138 - ENDIF 139 - IF(LDEBUG)PRINT *,' ++++++ DEQN DEBUG : Determinant equals', 140 - - D1*2.0**ID,' F03AFF IFAIL=',IFAIL 141 - *** Solve the system of equations. 142 - IFAIL=1 143 - CALL F04AHF(N,K,A,IDIM,AA,MXWIRE+1,R,B,IDIM,EPS, 144 - - X,MXWIRE+1,BB,MXWIRE+1,L,IFAIL) 145 - IF(IFAIL.EQ.1)THEN 146 - PRINT *,' ###### DEQN ERROR : The matrix is too', 147 - - ' ill-conditioned to produce a correctly rounded', 148 - - ' solution (F04AHF).' 149 - RETURN 150 - ELSEIF(IFAIL.NE.0.AND.IFAIL.NE.1)THEN 151 - PRINT *,' ###### DEQN ERROR : Unidentified NAG error', 152 - - ' error condition from F04AHF: ',IFAIL 153 - RETURN 154 - ENDIF 155 - IF(LDEBUG)THEN 156 - PRINT *,' ++++++ DEQN DEBUG : F04AHF IFAIL=',IFAIL, 157 - - ' iterations ',L,' list of residuals follows:' 158 - DO 30 I=1,N 159 - PRINT *,' I=',I,' Residuals= ',(BB(I,KK),KK=1,K) 1 319 P=ROUTINES D=F010 3 PAGE 420 160 - 30 CONTINUE 161 - PRINT *,' ++++++ DEQN DEBUG : End of list.' 162 - ENDIF 163 - *** Copy X to B. 164 - DO 50 KK=1,K 165 - DO 40 I=1,N 166 - B(I,KK)=X(I,KK) 167 - 40 CONTINUE 168 - 50 CONTINUE 169 - END 170 - SUBROUTINE REQN(N,AIN,IDIM,RIN,IFAIL,K,BIN) 171 - *----------------------------------------------------------------------- 172 - * REQN - Replaces the CERN library routine REQN (F010) by a NAG 173 - * equivalent. This routine will only work in the Garfield 174 - * environment. 175 - * PARAMETERS: MXREQN : Maximum input dimension 176 - *----------------------------------------------------------------------- 177.- +SEQ,PRINTPLOT. 178 - PARAMETER (MXREQN=3,MXRGHT=3) 179 - REAL AIN(IDIM,*),RIN(IDIM),BIN(IDIM,*) 180 - DOUBLE PRECISION A(MXREQN,MXREQN),R(MXREQN),B(MXREQN,MXRGHT), 181 - - AA(MXREQN,MXREQN),EPS,D1,X(MXREQN,MXRGHT),BB(MXREQN,MXRGHT) 182 - *** Check dimension of the matrix. 183 - IF(K.GT.MXRGHT)THEN 184 - PRINT *,' ###### REQN ERROR : Too many right hand', 185 - - ' sides; recompile with MXRGHT=',K 186 - IFAIL=1 187 - RETURN 188 - ENDIF 189 - IF(N.GT.MXREQN)THEN 190 - PRINT *,' ###### REQN ERROR : Dimension of input', 191 - - ' exceeds MXREQN; change to at least ',N 192 - IFAIL=1 193 - RETURN 194 - ENDIF 195 - *** Copy the (single precision) input to double precision variables. 196 - DO 5 KK=1,K 197 - DO 10 I=1,N 198 - B(I,KK)=DBLE(BIN(I,KK)) 199 - DO 20 J=1,N 200 - A(I,J)=DBLE(AIN(I,J)) 201 - AA(I,J)=A(I,J) 202 - 20 CONTINUE 203 - 10 CONTINUE 204 - 5 CONTINUE 205 - *** Set the precision to 1E-6, about the REAL*4 accuracy of an IBM. 206 - EPS=1.0D-6 207 - *** Perform a Crout factorisation. 208 - IFAIL=1 209 - CALL F03AFF(N,EPS,AA,MXREQN,D1,ID,R,IFAIL) 210 - IF(IFAIL.EQ.1)THEN 211 - PRINT *,' ###### REQN ERROR : The matrix is singular', 212 - - ' perhaps because of rounding errors (F03AFF).' 213 - RETURN 214 - ELSEIF(IFAIL.NE.0.AND.IFAIL.NE.1)THEN 215 - PRINT *,' ###### REQN ERROR : Unidentified NAG error', 216 - - ' error condition from F03AFF: ',IFAIL 217 - RETURN 218 - ENDIF 219 - IF(LDEBUG)PRINT *,' ++++++ REQN DEBUG : F03AFF Determinant', 220 - - ' equals ',D1,'*2**',ID,', IFAIL=',IFAIL 221 - *** Solve the system of equations. 222 - IFAIL=1 223 - CALL F04AHF(N,K,A,MXREQN,AA,MXREQN,R,B,MXREQN,EPS, 224 - - X,MXREQN,BB,MXREQN,L,IFAIL) 225 - IF(IFAIL.EQ.1)THEN 226 - PRINT *,' ###### REQN ERROR : The matrix is too', 227 - - ' ill-conditioned to produce a correctly rounded', 228 - - ' solution (F04AHF).' 229 - RETURN 230 - ELSEIF(IFAIL.NE.0.AND.IFAIL.NE.1)THEN 231 - PRINT *,' ###### REQN ERROR : Unidentified NAG error', 232 - - ' error condition from F04AHF: ',IFAIL 233 - RETURN 234 - ENDIF 235 - IF(LDEBUG)THEN 236 - PRINT *,' ++++++ REQN DEBUG : F04AHF IFAIL=',IFAIL, 237 - - ' iterations ',L,' list of residuals follows:' 238 - DO 30 I=1,N 239 - PRINT *,' I=',I,' Residual= ',(BB(I,KK),KK=1,K) 240 - 30 CONTINUE 241 - PRINT *,' ++++++ REQN DEBUG : End of list.' 242 - ENDIF 243 - *** Copy X to B. 244 - DO 50 KK=1,K 245 - DO 40 I=1,N 246 - BIN(I,KK)=REAL(X(I,KK)) 247 - 40 CONTINUE 248 - 50 CONTINUE 249 - END 320 GARFIELD ================================================== P=ROUTINES D=CRNERR 1 ============================ 0 + +DECK,CRNERR. 1 - SUBROUTINE CRNERR 2 - *----------------------------------------------------------------------- 3 - * CRNERR - Error handling 4 - *----------------------------------------------------------------------- 5.- +SEQ,PRINTPLOT. 6 - EXTERNAL INPCMP 7 - CHARACTER*6 ER 8 - INTEGER LM,LR 9 - *** Default value. 10 - ER='??????' 11 - LM=100 12 - LR=100 1 320 P=ROUTINES D=CRNERR 2 PAGE 421 13 - IER=0 14 - ILM=0 15 - ILR=0 16 - *** Decode the argument string 17 - CALL INPNUM(NWORD) 18 - INEXT=2 19 - DO 10 I=2,NWORD 20 - * Skip arguments etc. 21 - IF(I.LT.INEXT)GOTO 10 22 - * Message string. 23 - IF(INPCMP(I,'M#ESSAGE').NE.0)THEN 24 - CALL INPSTR(I+1,I+1,ER,NCH) 25 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ ',ER(1:1)).EQ.0.OR. 26 - - INDEX('0123456789 ', ER(2:2)).EQ.0.OR. 27 - - INDEX('0123456789 ', ER(3:3)).EQ.0.OR. 28 - - INDEX('0123456789 ', ER(4:4)).EQ.0.OR. 29 - - INDEX('. ', ER(5:5)).EQ.0.OR. 30 - - INDEX('0123456789 ', ER(6:6)).EQ.0)THEN 31 - CALL INPMSG(I+1,'Not correctly formatted. ') 32 - ER='??????' 33 - IER=0 34 - ELSE 35 - IER=1 36 - ENDIF 37 - INEXT=I+2 38 - * Number of times to print. 39 - ELSEIF(INPCMP(I,'PR#INT').NE.0)THEN 40 - IF(INPCMP(I+1,'A#LWAYS').NE.0)THEN 41 - LM=100 42 - ELSEIF(INPCMP(I+1,'N#EVER').NE.0)THEN 43 - LM=0 44 - ELSE 45 - CALL INPCHK(I+1,1,IFAIL1) 46 - CALL INPRDI(I+1,LM,100) 47 - ENDIF 48 - INEXT=I+2 49 - ILM=1 50 - * Number of occurences before ABEND. 51 - ELSEIF(INPCMP(I,'AB#END').NE.0)THEN 52 - IF(INPCMP(I+1,'N#EVER').NE.0)THEN 53 - LR=100 54 - ELSE 55 - CALL INPCHK(I+1,1,IFAIL1) 56 - CALL INPRDI(I+1,LR,100) 57 - ENDIF 58 - INEXT=I+2 59 - ILR=1 60 - * Anything not valid. 61 - ELSE 62 - CALL INPMSG(I,'Keyword not recognised. ') 63 - ENDIF 64 - 10 CONTINUE 65 - *** Dump error messages. 66 - CALL INPERR 67 - *** Check at least the message id was specified. 68 - IF(IER.EQ.0)THEN 69 - PRINT *,' !!!!!! CRNERR WARNING : Error message id not'// 70 - - ' specified ; no call to KERSET.' 71 - RETURN 72 - ENDIF 73 - *** Register request with KERSET. 74 - CALL KERSET(ER,0,LM,LR) 75 - IF(LDEBUG)PRINT *,' ++++++ CRNERR DEBUG : KERSET called for'// 76 - - ' message '//ER//': printing ',LM,' times, ABEND after ', 77 - - LR,' occurences.' 78 - END 321 GARFIELD ================================================== P=ROUTINES D=HISPRD 1 ============================ 0 + +DECK,HISPRD. 1 - SUBROUTINE HISPRD(Y,N) 2 - *----------------------------------------------------------------------- 3 - * HISPRD - Initialize histogram to form cumulative distribution. 4 - * Author: F. James, modified for double precision. 5 - * (Last changed on 17/10/95.) 6 - *----------------------------------------------------------------------- 7 - IMPLICIT DOUBLE PRECISION (A-H,O-Z) 8 - DOUBLE PRECISION Y(*) 9 - INTEGER N 10 - *** Form cumulative distribution. 11 - YTOT = 0 12 - DO 100 I= 1, N 13 - IF(Y(I).LT.0)THEN 14 - PRINT *,' !!!!!! HISPRD WARNING : Found a negative'// 15 - - ' probability in bin ',I,'; set to 0.' 16 - ELSE 17 - YTOT = YTOT + Y(I) 18 - Y(I) = YTOT 19 - ENDIF 20 - 100 CONTINUE 21 - IF(YTOT.LE.0)THEN 22 - PRINT *,' !!!!!! HISPRD WARNING : Histogram has a zero'// 23 - - ' integral ; not useable.' 24 - YTOT=1 25 - ENDIF 26 - *** Normalise the distribution. 27 - YINV = 1/YTOT 28 - DO 110 I= 1, N 29 - Y(I) = Y(I) * YINV 30 - 110 CONTINUE 31 - Y(N) = 1.0 32 - END 1 322 GARFIELD ================================================== P=ROUTINES D=HISRAD 1 =================== PAGE 422 0 + +DECK,HISRAD. 1 - SUBROUTINE HISRAD(Y,N,XLO,XWID,XRAN) 2 - *----------------------------------------------------------------------- 3 - * HISRAD - Subroutine to generate random numbers according to an 4 - * empirical distribution supplied by the user in the form of 5 - * a histogram. 6 - * Author: F. James, modified for DOUBLE PRECISION usage. 7 - * (Last changed on 13/ 3/99.) 8 - *----------------------------------------------------------------------- 9 - IMPLICIT DOUBLE PRECISION (A-H,O-Z) 10 - PARAMETER(NVEC=100) 11 - DOUBLE PRECISION Y(*),RVEC(NVEC),XLO,XWID,XRAN,YR 12 - INTEGER L,IVEC,LOCATD 13 - EXTERNAL LOCATD 14 - DATA IVEC/0/ 0 15-+ +SELF,IF=SAVE. 16 - SAVE RVEC,IVEC 0 17-+ +SELF. 18 - *** Make sure that the histogram has been prepared. 19 - IF(Y(N).NE.1)THEN 20 - PRINT *,' !!!!!! HISRAD WARNING : HISPRD has apparently'// 21 - - ' not been called; calling it now.' 22 - CALL HISPRD(Y,N) 23 - ENDIF 24 - *** Now generate random number between 0 and one. 25 - IF(IVEC.EQ.0.OR.IVEC.GE.NVEC)THEN 26 - CALL RM48(RVEC,NVEC) 27 - IVEC=1 28 - ELSE 29 - IVEC=IVEC+1 30 - ENDIF 31 - YR = RVEC(IVEC) 32 - * Verify random number. 33 - IF(YR.LE.0.OR.YR.GT.1)PRINT *,' !!!!!! HISRAD WARNING :'// 34 - - ' Received ',YR,' from RM48 - please ensure you have'// 35 - - ' an up to date version of CERNLIB.' 36 - * and transform it into the corresponding x-value 37 - L = LOCATD(Y,N,YR) 38 - * point falls in first bin. special case 39 - IF(L.EQ.0)THEN 40 - IF(Y(1).LE.0)THEN 41 - XRAN = XLO + XWID / 2 42 - ELSE 43 - XRAN = XLO + XWID * (YR/Y(1)) 44 - ENDIF 45 - * guard against special case of falling on empty bin 46 - ELSEIF(L.GT.0)THEN 47 - XRAN = XLO + L * XWID 48 - * usually come here. 49 - ELSE 50 - L = ABS(L) 51 - IF(Y(L+1)-Y(L).LE.0)THEN 52 - XRAN = XLO + XWID * (L + 0.5) 53 - ELSE 54 - XRAN = XLO + XWID * (L +((YR-Y(L))/(Y(L+1)-Y(L)))) 55 - ENDIF 56 - ENDIF 57 - END 323 GARFIELD ================================================== P=ROUTINES D=LOCATD 1 ============================ 0 + +DECK,LOCATD. 1 - INTEGER FUNCTION LOCATD(ARRAY,LENGTH,OBJECT) 2 - *----------------------------------------------------------------------- 3 - * LOCATD - binary search thru ARRAY to find OBJECT. ARRAY is assumed 4 - * to be sorted prior to call. If a match is found, function 5 - * returns position of element. If no match is found, function 6 - * gives negative of nearest element smaller than object. 7 - * Author: F. James, double precision version. 8 - * (Last changed on 17/10/95.) 9 - *----------------------------------------------------------------------- 10 - IMPLICIT DOUBLE PRECISION (A-H,O-Z) 11 - DOUBLE PRECISION ARRAY(*) 12 - INTEGER LENGTH,NABOVE,NBELOW,MIDDLE 13 - NABOVE = LENGTH + 1 14 - NBELOW = 0 15 - 10 IF (NABOVE-NBELOW .LE. 1) GO TO 200 16 - MIDDLE = (NABOVE+NBELOW) / 2 17 - IF (OBJECT - ARRAY(MIDDLE)) 100, 180, 140 18 - 100 NABOVE = MIDDLE 19 - GO TO 10 20 - 140 NBELOW = MIDDLE 21 - GO TO 10 22 - 180 LOCATD = MIDDLE 23 - GO TO 300 24 - 200 LOCATD = -NBELOW 25 - 300 RETURN 26 - END 324 GARFIELD ================================================== P=ROUTINES D=STDSTR 1 ============================ 0 + +DECK,STDSTR. 1 - LOGICAL FUNCTION STDSTR(STREAM) 2 - *----------------------------------------------------------------------- 3 - * STDSTR - Checks whether the data stream STREAM is connected to 4 - * standard input or output. 5 - * (Last changed on 21/ 1/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,PRINTPLOT. 9 - CHARACTER*(*) STREAM 10 - INTEGER LENARG,IARG,NARGS,INIT,INPCMX,iargc,DUMMY 11 - CHARACTER*128 ARGS 12 - LOGICAL LSTATE,INTRAC 1 324 P=ROUTINES D=STDSTR 2 PAGE 423 13 - EXTERNAL INPCMX,INTRAC,iargc 0 14-+ +SELF,IF=SAVE. 15 - SAVE LSTATE,INIT 0 16-+ +SELF. 17 - *** For input. 18 - IF(STREAM.EQ.'INPUT')THEN 19 - * On first call, determine the state. 20 - DATA INIT/0/ 21 - IF(INIT.EQ.0)THEN 22 - * Default is obtained from INTRAC. 23 - LSTATE=INTRAC(DUMMY) 0 24-+ +SELF,IF=UNIX. 25 - * Loop over the command line arguments. 26 - NARGS=iargc() 27 - DO 10 IARG=1,NARGS 28 - * Fetch the option. 29 - CALL ARGGET(IARG,ARGS,LENARG) 30 - * If -interactive, then force interactive mode. 31 - IF(INPCMX(args(1:LENARG),'-interact#ive').NE.0)THEN 32 - LSTATE=.TRUE. 33 - * If -batch, then force batch mode. 34 - ELSEIF(INPCMX(ARGS(1:LENARG),'-batch').NE.0)THEN 35 - LSTATE=.FALSE. 36 - ENDIF 37 - 10 CONTINUE 0 38-+ +SELF. 39 - INIT=1 40 - ENDIF 41 - * On subsequent calls, retrieve old state. 42 - STDSTR=LSTATE 43 - *** Output. 44 - ELSEIF(STREAM.EQ.'OUTPUT')THEN 45 - STDSTR=LUNOUT.EQ.6 46 - *** Other streams not known. 47 - ELSE 48 - PRINT *,' !!!!!! STDSTR WARNING : Received an unknown'// 49 - - ' stream name "',STREAM,'"; returning "True".' 50 - STDSTR=.TRUE. 51 - ENDIF 52 - END 325 GARFIELD ================================================== P=ROUTINES D=INTERN 1 ============================ 0 + +DECK,INTERN. 1 - SUBROUTINE INTERN(NPL,XPL,YPL,X,Y,INSIDE,EDGE) 2 - *----------------------------------------------------------------------- 3 - * INTERN - Determines whether the point (X,Y) is located inside of the 4 - * polygon (XPL,YPL). 5 - * (Last changed on 6/10/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,PARAMETERS. 11 - INTEGER NPL,NITER,I,J,NCROSS 12 - REAL XPL(NPL),YPL(NPL),X,Y,XINF,YINF,XMAX,YMAX,XMIN,YMIN,RNDUNI, 13 - - EPSX,EPSY 14 - LOGICAL CROSS,ONLINE,INSIDE,EDGE 15 - EXTERNAL CROSS,ONLINE,RNDUNI 16 - *** Initial settings. 17 - INSIDE=.FALSE. 18 - EDGE=.FALSE. 19 - *** Special treatment for few points. 20 - IF(NPL.LT.2)THEN 21 - RETURN 22 - ELSEIF(NPL.EQ.2)THEN 23 - EDGE=ONLINE(XPL(1),YPL(1),XPL(2),YPL(2),X,Y) 24 - RETURN 25 - ENDIF 26 - *** Determine the range of the data. 27 - XMIN=XPL(1) 28 - YMIN=YPL(1) 29 - XMAX=XPL(1) 30 - YMAX=YPL(1) 31 - DO 10 I=2,NPL 32 - XMIN=MIN(XMIN,XPL(I)) 33 - YMIN=MIN(YMIN,YPL(I)) 34 - XMAX=MAX(XMAX,XPL(I)) 35 - YMAX=MAX(YMAX,YPL(I)) 36 - 10 CONTINUE 37 - *** Set tolerances. 38 - IF(LEPSG)THEN 39 - EPSX=EPSGX 40 - EPSY=EPSGY 41 - ELSE 42 - EPSX=1.0E-5*MAX(ABS(XMIN),ABS(XMAX)) 43 - EPSY=1.0E-5*MAX(ABS(YMIN),ABS(YMAX)) 44 - IF(EPSX.LE.0)EPSX=1.0E-5 45 - IF(EPSY.LE.0)EPSY=1.0E-5 46 - ENDIF 47 - *** Ensure that we have a range. 48 - IF(ABS(XMAX-XMIN).LE.EPSX)THEN 49 - IF(Y.GE.YMIN-EPSY.AND.Y.LE.YMAX+EPSY.AND. 50 - - ABS(XMAX+XMIN-2*X).LE.EPSX)THEN 51 - EDGE=.TRUE. 52 - ELSE 53 - EDGE=.FALSE. 54 - ENDIF 55 - RETURN 56 - ELSEIF(ABS(YMAX-YMIN).LE.EPSY)THEN 57 - IF(X.GE.XMIN-EPSX.AND.X.LE.XMAX+EPSX.AND. 58 - - ABS(YMAX+YMIN-2*Y).LE.EPSY)THEN 1 325 P=ROUTINES D=INTERN 2 PAGE 424 59 - EDGE=.TRUE. 60 - ELSE 61 - EDGE=.FALSE. 62 - ENDIF 63 - RETURN 64 - ENDIF 65 - *** Choose a point at "infinity". 66 - XINF=XMIN-ABS(XMAX-XMIN) 67 - YINF=YMIN-ABS(YMAX-YMIN) 68 - *** Loop over the edges counting intersections. 69 - NITER=0 70 - 20 CONTINUE 71 - NCROSS=0 72 - DO 30 J=1,NPL 73 - * Flag points located on one of the edges. 74 - IF(ONLINE(XPL(1+MOD(J-1,NPL)),YPL(1+MOD(J-1,NPL)), 75 - - XPL(1+MOD(J,NPL)),YPL(1+MOD(J,NPL)),X,Y))THEN 76 - EDGE=.TRUE. 77 - RETURN 78 - ENDIF 79 - * Count mid-line intersects. 80 - IF(CROSS(X,Y,XINF,YINF, 81 - - XPL(1+MOD(J-1,NPL)),YPL(1+MOD(J-1,NPL)), 82 - - XPL(1+MOD(J ,NPL)),YPL(1+MOD(J ,NPL))))NCROSS=NCROSS+1 83 - * Ensure that the testing line doesn't cross a corner. 84 - IF(ONLINE(X,Y,XINF,YINF,XPL(J),YPL(J)))THEN 85 - XINF=XMIN-RNDUNI(1.0)*ABS(XMAX-XINF) 86 - YINF=YMIN+RNDUNI(-1.0)*ABS(YMAX-YINF) 87 - NITER=NITER+1 88 - IF(NITER.LT.100)GOTO 20 89 - PRINT *,' !!!!!! INTERN WARNING : Unable to verify'// 90 - - ' whether a point is internal; setting to "edge".' 91 - INSIDE=.FALSE. 92 - EDGE=.TRUE. 93 - * Produce a dump if requested. 94 - IF(LGSTOP)THEN 95 - OPEN(UNIT=12,FILE='intern.dat',STATUS='UNKNOWN') 96 - WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG 97 - WRITE(12,*) X,Y 98 - WRITE(12,*) NPL 99 - DO 40 I=1,NPL 100 - WRITE(12,*) I,XPL(I),YPL(I) 101 - 40 CONTINUE 102 - CLOSE(12) 103 - PRINT *,' ------ INTERN MESSAGE : Dump produced;'// 104 - - ' terminating program execution.' 105 - CALL QUIT 106 - ENDIF 107 - RETURN 108 - ENDIF 109 - 30 CONTINUE 110 - *** Set the INSIDE flag. 111 - IF(NCROSS.NE.2*(NCROSS/2))INSIDE=.TRUE. 112 - END 326 GARFIELD ================================================== P=ROUTINES D=INTERD 1 ============================ 0 + +DECK,INTERD. 1 - SUBROUTINE INTERD(NPL,XPL,YPL,X,Y,INSIDE,EDGE) 2 - *----------------------------------------------------------------------- 3 - * INTERD - Determines whether the point (X,Y) is located inside of the 4 - * polygon (XPL,YPL). 5 - * (Last changed on 6/10/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,PARAMETERS. 11 - INTEGER NPL,NITER,I,J,NCROSS 12 - DOUBLE PRECISION XPL(NPL),YPL(NPL),X,Y,XINF,YINF, 13 - - XMAX,YMAX,XMIN,YMIN,EPSX,EPSY 14 - REAL RNDUNI 15 - LOGICAL CROSSD,ONLIND,INSIDE,EDGE 16 - EXTERNAL CROSSD,ONLIND,RNDUNI 17 - *** Initial settings. 18 - INSIDE=.FALSE. 19 - EDGE=.FALSE. 20 - *** Special treatment for few points. 21 - IF(NPL.LT.2)THEN 22 - RETURN 23 - ELSEIF(NPL.EQ.2)THEN 24 - EDGE=ONLIND(XPL(1),YPL(1),XPL(2),YPL(2),X,Y) 25 - RETURN 26 - ENDIF 27 - *** Determine the range of the data. 28 - XMIN=XPL(1) 29 - YMIN=YPL(1) 30 - XMAX=XPL(1) 31 - YMAX=YPL(1) 32 - DO 10 I=2,NPL 33 - XMIN=MIN(XMIN,XPL(I)) 34 - YMIN=MIN(YMIN,YPL(I)) 35 - XMAX=MAX(XMAX,XPL(I)) 36 - YMAX=MAX(YMAX,YPL(I)) 37 - 10 CONTINUE 38 - *** Set tolerances. 39 - IF(LEPSG)THEN 40 - EPSX=EPSGX 41 - EPSY=EPSGY 42 - ELSE 43 - EPSX=1.0D-8*MAX(ABS(XMIN),ABS(XMAX)) 44 - EPSY=1.0D-8*MAX(ABS(YMIN),ABS(YMAX)) 45 - IF(EPSX.LE.0)EPSX=1.0D-8 46 - IF(EPSY.LE.0)EPSY=1.0D-8 47 - ENDIF 48 - *** Ensure that we have a range. 1 326 P=ROUTINES D=INTERD 2 PAGE 425 49 - IF(ABS(XMAX-XMIN).LE.EPSX)THEN 50 - IF(Y.GE.YMIN-EPSY.AND.Y.LE.YMAX+EPSY.AND. 51 - - ABS(XMAX+XMIN-2*X).LE.EPSX)THEN 52 - EDGE=.TRUE. 53 - ELSE 54 - EDGE=.FALSE. 55 - ENDIF 56 - RETURN 57 - ELSEIF(ABS(YMAX-YMIN).LE.EPSY)THEN 58 - IF(X.GE.XMIN-EPSX.AND.X.LE.XMAX+EPSX.AND. 59 - - ABS(YMAX+YMIN-2*Y).LE.EPSY)THEN 60 - EDGE=.TRUE. 61 - ELSE 62 - EDGE=.FALSE. 63 - ENDIF 64 - RETURN 65 - ENDIF 66 - *** Choose a point at "infinity". 67 - XINF=XMIN-ABS(XMAX-XMIN) 68 - YINF=YMIN-ABS(YMAX-YMIN) 69 - *** Loop over the edges counting intersections. 70 - NITER=0 71 - 20 CONTINUE 72 - NCROSS=0 73 - DO 30 J=1,NPL 74 - * Flag points located on one of the edges. 75 - IF(ONLIND(XPL(1+MOD(J-1,NPL)),YPL(1+MOD(J-1,NPL)), 76 - - XPL(1+MOD(J,NPL)),YPL(1+MOD(J,NPL)),X,Y))THEN 77 - EDGE=.TRUE. 78 - RETURN 79 - ENDIF 80 - * Count mid-line intersects. 81 - IF(CROSSD(X,Y,XINF,YINF, 82 - - XPL(1+MOD(J-1,NPL)),YPL(1+MOD(J-1,NPL)), 83 - - XPL(1+MOD(J ,NPL)),YPL(1+MOD(J ,NPL))))NCROSS=NCROSS+1 84 - * Ensure that the testing line doesn't cross a corner. 85 - IF(ONLIND(X,Y,XINF,YINF,XPL(J),YPL(J)))THEN 86 - XINF=XMIN-RNDUNI(1.0)*ABS(XMAX-XINF) 87 - YINF=YMIN+RNDUNI(-1.0)*ABS(YMAX-YINF) 88 - NITER=NITER+1 89 - IF(NITER.LT.100)GOTO 20 90 - PRINT *,' !!!!!! INTERD WARNING : Unable to verify'// 91 - - ' whether a point is internal; setting to "edge".' 92 - INSIDE=.FALSE. 93 - EDGE=.TRUE. 94 - * Produce a dump if requested. 95 - IF(LGSTOP)THEN 96 - OPEN(UNIT=12,FILE='interd.dat',STATUS='UNKNOWN') 97 - WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG 98 - WRITE(12,*) X,Y 99 - WRITE(12,*) NPL 100 - DO 40 I=1,NPL 101 - WRITE(12,*) I,XPL(I),YPL(I) 102 - 40 CONTINUE 103 - CLOSE(12) 104 - PRINT *,' ------ INTERD MESSAGE : Dump produced;'// 105 - - ' terminating program execution.' 106 - CALL QUIT 107 - ENDIF 108 - RETURN 109 - ENDIF 110 - 30 CONTINUE 111 - *** Set the INSIDE flag. 112 - IF(NCROSS.NE.2*(NCROSS/2))INSIDE=.TRUE. 113 - END 327 GARFIELD ================================================== P=ROUTINES D=INTERP 1 ============================ 0 + +DECK,INTERP. 1 - SUBROUTINE INTERP(X,Y,C,N,XIN,YIN,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * INTERP - A routine using the interpolation results of SPLINE in 4 - * order to give a y value corresponding to XIN. 5 - * VARIABLES : See SPLINE 6 - * REFERENCE : See SPLINE 7 - * (Last changed on 25/ 4/94.) 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10 - REAL X(MXLIST),Y(MXLIST),C(MXLIST) 11 - J=1 12 - *** Set IFAIL to 0 : OK 13 - IFAIL=0 14 - YIN=0.0 15 - *** Determine the interval in which XIN is located. 16 - 10 CONTINUE 17 - IF(X(J).LE.XIN.AND.XIN.LE.X(J+1))THEN 18 - BETA=(Y(J+1)-Y(J))/(X(J+1)-X(J))- 19 - - (2.0*C(J)+C(J+1))*(X(J+1)-X(J))/6.0 20 - GAMMA=C(J)/2.0 21 - DELTA=(C(J+1)-C(J))/(6.0*(X(J+1)-X(J))) 22 - YIN=Y(J)+BETA*(XIN-X(J))+GAMMA*(XIN-X(J))**2+ 23 - - DELTA*(XIN-X(J))**3 24 - ELSE 25 - J=J+1 26 - IF(J.EQ.N)THEN 27 - PRINT *,' ###### INTERP ERROR : The ordinate ',XIN, 28 - - ' is out of the range (',X(1),',',X(N),').' 29 - IFAIL=1 30 - RETURN 31 - ENDIF 32 - GOTO 10 33 - ENDIF 34 - END 1 328 GARFIELD ================================================== P=ROUTINES D=INTER2 1 =================== PAGE 426 0 + +DECK,INTER2. 1 - SUBROUTINE INTER2(X,Y,C,N,XIN,YIN,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * INTERP - A routine using the interpolation results of SPLIN2 in 4 - * order to give a y value corresponding to XIN. 5 - * VARIABLES : See SPLINE2 6 - * REFERENCE : See SPLINE2 7 - *----------------------------------------------------------------------- 8 - IMPLICIT DOUBLE PRECISION (A-H,O-Z) 9.- +SEQ,DIMENSIONS. 10 - DIMENSION X(MXLIST),Y(MXLIST),C(MXLIST) 11 - J=1 12 - *** Set IFAIL to 0 : OK 13 - IFAIL=0 14 - *** Determine the interval in which XIN is located. 15 - 10 CONTINUE 16 - IF(X(J).LE.XIN.AND.XIN.LE.X(J+1))THEN 17 - BETA=(Y(J+1)-Y(J))/(X(J+1)-X(J))- 18 - - (2.0*C(J)+C(J+1))*(X(J+1)-X(J))/6.0 19 - GAMMA=C(J)/2.0 20 - DELTA=(C(J+1)-C(J))/(6.0*(X(J+1)-X(J))) 21 - YIN=Y(J)+BETA*(XIN-X(J))+GAMMA*(XIN-X(J))**2+ 22 - - DELTA*(XIN-X(J))**3 23 - ELSE 24 - J=J+1 25 - IF(J.EQ.N)THEN 26 - PRINT *,' ###### INTER2 ERROR : The ordinate ',XIN, 27 - - ' is out of the range (',X(1),',',X(N),').' 28 - IFAIL=1 29 - RETURN 30 - ENDIF 31 - GOTO 10 32 - ENDIF 33 - END 329 GARFIELD ================================================== P=ROUTINES D=INTUBE 1 ============================ 0 + +DECK,INTUBE. 1 - SUBROUTINE INTUBE(X,Y,A,N,ILOC) 2 - *----------------------------------------------------------------------- 3 - * INTUBE - Determines whether a point is located inside a polygon. 4 - * (Last changed on 21/ 2/94.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,CONSTANTS. 7 - *** Special case: x=y=0 8 - IF(X.EQ.0.AND.Y.EQ.0)THEN 9 - ILOC=0 10 - *** Special case: round tube. 11 - ELSEIF(N.EQ.0)THEN 12 - IF(X**2+Y**2.GT.A**2)THEN 13 - ILOC=1 14 - ELSE 15 - ILOC=0 16 - ENDIF 17 - *** Illegal number of edges. 18 - ELSEIF(N.LT.0.OR.N.EQ.1.OR.N.EQ.2)THEN 19 - PRINT *,' ###### INTUBE ERROR : Invalid number of'// 20 - - ' edges received (N=',N,').' 21 - ILOC=-1 22 - ELSE 23 - *** Reduce angle to the first sector. 24 - PHI=ATAN2(Y,X) 25 - IF(PHI.LT.0.0)PHI=PHI+2*PI 26 - PHI=PHI-REAL(2)*PI*INT(0.5*N*PHI/PI)/REAL(N) 27 - *** Compare the length to the local radius. 28 - IF((X**2+Y**2)*COS(PI/REAL(N)-PHI)**2.GT. 29 - - A**2*COS(PI/REAL(N))**2)THEN 30 - ILOC=-1 31 - ELSE 32 - ILOC=0 33 - ENDIF 34 - ENDIF 35 - END 330 GARFIELD ================================================== P=ROUTINES D=INVINT 1 ============================ 0 + +DECK,INVINT. 1 - SUBROUTINE INVINT(CIN,NCHA,XMIN,XMAX,EPS,XEPS,IORDER,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * INVINT - Inverse interpolation to find XEPS such that P(X 0; no fit done.' 55 - IFAIL=1 56 - RETURN 57 - ENDIF 58 - * Compute initial residuals. 59 - CALL F(X(I),A,VAL) 60 - R(I)=(Y(I)-VAL)/EY(I) 61 - NFC=NFC+1 62 - * Compute initial maximum difference. 63 - IF(I.EQ.1)DIFFC=ABS(R(I)) 64 - IF(I.GT.1.AND.DIFFC.LT.ABS(R(I)))DIFFC=ABS(R(I)) 65 - * And compute initial chi2. 66 - CHI2=CHI2+R(I)**2 67 - 10 CONTINUE 68 - * Set initial parameter error and correction vectors. 69 - DO 50 I=1,N 70 - S(I)=0 71 - EA(I)=0 72 - 50 CONTINUE 73 - *** Print a table of the input if debug is on. 74 - IF(LDEBUG)THEN 75 - WRITE(LUNOUT,'('' ++++++ LSQFIT DEBUG : Start of debug'', 76 - - '' output'',//,26X,''Number of input data points= '', 77 - - I4,//,30X,''I X(I) Y(I)'', 78 - - '' Weight Y-F(X)'')') M 79 - DO 30 I=1,M 80 - WRITE(LUNOUT,'(26X,I5,4(1X,E15.8))') 81 - - I,X(I),Y(I),EY(I),R(I) 82 - 30 CONTINUE 83 - WRITE(LUNOUT,'(26X,''Number of parameters to optimise ='', 84 - - I2/26X,''Initial parameter values:''/ 85 - - 30X,''I A(I)'')') N 86 - DO 40 I=1,N 87 - WRITE(LUNOUT,'(26X,I5,1X,E15.8)') I,A(I) 88 - 40 CONTINUE 89 - WRITE(LUNOUT,'(26X,''Initial CHI2 '',E12.5, 90 - - '', initial DIFF '',E12.5,/,26X,''required DIFF is '', 91 - - E12.5/)') CHI2,DIFFC,DIFF 92 - ENDIF 93 - *** Print some summary information if LFITPR is on. 94 - IF(LFITPR)THEN 95 - WRITE(LUNOUT,'(/'' MINIMISATION SUMMARY''/)') 96 - WRITE(LUNOUT,'('' Initial situation:'',/,5X,''largest '', 97 - - ''difference between field and target function : '', 98 - - E15.8)') DIFFC 99 - WRITE(LUNOUT,'(5X,''sum of squares of these differences '', 100 - - '' (chi-squared) : '',E15.8/)') CHI2 101 - WRITE(LUNOUT,'('' Stopping criteria:'',/,5X,''difference'', 102 - - '' between field and target function less than : '', 103 - - E15.8)') DIFF 104 - WRITE(LUNOUT,'(5X,''the relative chi-squared variation'', 105 - - '' becomes less than : '',E15.8)') EPS 106 - WRITE(LUNOUT,'(5X,''the number of iterations exceeds the'', 107 - - '' maximum : '',I3/)') KMAX 108 - ENDIF 109 - *** Start optimising loop. 110 - DO 20 ITER=1,KMAX 111 - ** Check the stopping criteria: (1) max norm, (2) change in CHI2. 112 - IF((DIFFC.LT.DIFF).OR. 113 - - (ITER.GT.1.AND.ABS(CHI2L-CHI2).LT.EPS*CHI2))THEN 114 - IFAIL=0 115 - IF(LDEBUG.AND.DIFFC.LT.DIFF)THEN 116 - WRITE(LUNOUT,'(26X,''Maximum difference stopping'', 117 - - '' criterion satisfied.'',/)') 118 - ELSEIF(LDEBUG)THEN 119 - WRITE(LUNOUT,'(26X,''Relative change in CHI2 has'', 120 - - ''dropped below '',E10.3,''.''/)') EPS 121 - ENDIF 122 - IF(LFITPR.AND.DIFFC.LT.DIFF)THEN 123 - WRITE(LUNOUT,'(/,'' The maximum difference stopping'', 124 - - '' criterion is satisfied.'')') 125 - ELSEIF(LFITPR)THEN 126 - WRITE(LUNOUT,'(/,'' The relative change in chi-'', 127 - - ''squared has dropped below the threshold.'')') 128 - ENDIF 129 - GOTO 600 130 - ENDIF 131 - ** Calculate the derivative matrix. 132 - DO 100 J=1,N 133 - EPSDIF=EPS*(1+ABS(A(J))) 134 - A(J)=A(J)+EPSDIF/2 135 - DO 110 I=1,M 136 - CALL F(X(I),A,D(I,J)) 1 331 P=ROUTINES D=LSQFIT 3 PAGE 429 137 - NFC=NFC+1 138 - 110 CONTINUE 139 - A(J)=A(J)-EPSDIF 140 - DO 120 I=1,M 141 - CALL F(X(I),A,VAL) 142 - D(I,J)=(D(I,J)-VAL)/(EPSDIF*EY(I)) 143 - NFC=NFC+1 144 - 120 CONTINUE 145 - A(J)=A(J)+EPSDIF/2 146 - 100 CONTINUE 147 - ** Invert the matrix in Householder style. 148 - DO 200 J=1,N 149 - SIGMA=0.0 150 - DO 210 I=J,M 151 - SIGMA=SIGMA+D(I,J)**2 152 - 210 CONTINUE 153 - IF(SIGMA.EQ.0.OR.SQRT(SIGMA).LT.1E-8*ABS(D(J,J)))THEN 154 - PRINT *,' !!!!!! LSQFIT WARNING : Householder matrix'// 155 - - ' (nearly) singular; no further optimisation.' 156 - PRINT *,' Ensure the function'// 157 - - ' depends on the parameters' 158 - PRINT *,' and try to supply'// 159 - - ' reasonable starting values.' 160 - GOTO 600 161 - ENDIF 162 - IF(D(J,J).LT.0.0)THEN 163 - SIGMA=SQRT(SIGMA) 164 - ELSE 165 - SIGMA=-SQRT(SIGMA) 166 - ENDIF 167 - BETA=1/(SIGMA*D(J,J)-SIGMA**2) 168 - D(J,J)=D(J,J)-SIGMA 169 - SUM=0 170 - DO 220 I=J,M 171 - SUM=SUM+D(I,J)*R(I) 172 - 220 CONTINUE 173 - SUM=SUM*BETA 174 - DO 230 I=J,M 175 - R(I)=R(I)+SUM*D(I,J) 176 - 230 CONTINUE 177 - DO 240 K=J+1,N 178 - SUM=0 179 - DO 250 I=J,M 180 - SUM=SUM+D(I,J)*D(I,K) 181 - 250 CONTINUE 182 - SUM=SUM*BETA 183 - DO 260 I=J,M 184 - D(I,K)=D(I,K)+D(I,J)*SUM 185 - 260 CONTINUE 186 - 240 CONTINUE 187 - D(J,J)=SIGMA 188 - 200 CONTINUE 189 - ** Solve the system of equations. 190 - DO 300 I=N,1,-1 191 - SUM=0 192 - DO 310 J=N,I+1,-1 193 - SUM=SUM+D(I,J)*S(J) 194 - 310 CONTINUE 195 - S(I)=(R(I)-SUM)/D(I,I) 196 - 300 CONTINUE 197 - ** Generate some debugging output. 198 - IF(LDEBUG)THEN 199 - WRITE(LUNOUT,'(26X,''Correction vector in minimisation'', 200 - - '' loop '',I3)') ITER 201 - DO 320 I=1,N 202 - WRITE(LUNOUT,'(26X,I5,1X,E15.8)') I,S(I) 203 - 320 CONTINUE 204 - ENDIF 205 - ** Add part of the correction vector to the estimate to improve CHI2. 206 - CHI2L=CHI2 207 - DO 400 I=1,N 208 - A(I)=A(I)+S(I)*2 209 - 400 CONTINUE 210 - CHI2=2.0*CHI2L 211 - DO 410 I=0,10 212 - IF(CHI2.GT.CHI2L)THEN 213 - IF(ABS(CHI2L-CHI2).LT.EPS*CHI2)THEN 214 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Too little'', 215 - - '' improvement, reduction loop halted.'')') 216 - GOTO 440 217 - ENDIF 218 - CHI2=0.0 219 - DO 420 J=1,N 220 - A(J)=A(J)-S(J)/2**I 221 - 420 CONTINUE 222 - DO 430 J=1,M 223 - CALL F(X(J),A,VAL) 224 - R(J)=(Y(J)-VAL)/EY(J) 225 - NFC=NFC+1 226 - CHI2=CHI2+R(J)**2 227 - 430 CONTINUE 228 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Reduction loop '',I2, 229 - - '' produces a CHI2 of '',E15.8)') I,CHI2 230 - ELSE 231 - GOTO 440 232 - ENDIF 233 - 410 CONTINUE 234 - 440 CONTINUE 235 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''shortening the correction'', 236 - - '' vector by a factor of '',I4)') 2**(I-1) 237 - * Calculate the max norm. 238 - DIFFC=ABS(R(1)) 239 - DO 450 I=2,M 240 - IF(DIFFC.LT.ABS(R(I)))DIFFC=ABS(R(I)) 241 - 450 CONTINUE 242 - ** Print some debugging output. 1 331 P=ROUTINES D=LSQFIT 4 PAGE 430 243 - IF(LDEBUG)THEN 244 - WRITE(LUNOUT,'(26X, 245 - - ''Values of the parameters after the step'')') 246 - DO 500 I=1,N 247 - WRITE(LUNOUT,'(26X,I5,1X,E15.8)') I,A(I) 248 - 500 CONTINUE 249 - WRITE(LUNOUT,'(26X,''for which CHI2='',E15.8, 250 - - '' and DIFF='',E15.8/)') CHI2,DIFFC 251 - ENDIF 252 - ** And some logging output. 253 - IF(LFITPR)WRITE(LUNOUT,'('' Iteration '',I3,'': largest '', 254 - - ''deviation = '',E15.8,'', Chi2='',E15.8)') ITER,DIFFC,CHI2 255 - *** End of optimisation loop. 256 - 20 CONTINUE 257 - IF(LFITPR)THEN 258 - WRITE(LUNOUT,'(/'' The maximum number of iterations has'', 259 - - '' been reached.'')') 260 - ELSE 261 - PRINT *,' !!!!!! LSQFIT WARNING : Maximum number of'// 262 - - ' iterations reached, stopping criteria not satisfied.' 263 - ENDIF 264 - *** End of fit, perform error calculation. 265 - 600 CONTINUE 266 - * Calculate the derivative matrix for the final settings. 267 - DO 800 J=1,N 268 - EPSDIF=EPS*(1+ABS(A(J))) 269 - A(J)=A(J)+EPSDIF/2 270 - DO 810 I=1,M 271 - CALL F(X(I),A,D(I,J)) 272 - NFC=NFC+1 273 - 810 CONTINUE 274 - A(J)=A(J)-EPSDIF 275 - DO 820 I=1,M 276 - CALL F(X(I),A,VAL) 277 - D(I,J)=(D(I,J)-VAL)/(EPSDIF*EY(I)) 278 - NFC=NFC+1 279 - 820 CONTINUE 280 - A(J)=A(J)+EPSDIF/2 281 - 800 CONTINUE 282 - * Calculate the error matrix. 283 - DO 830 I=1,N 284 - DO 840 J=1,N 285 - DA(I,J)=0 286 - DO 850 K=1,M 287 - DA(I,J)=DA(I,J)+D(K,I)*D(K,J) 288 - 850 CONTINUE 289 - 840 CONTINUE 290 - 830 CONTINUE 291 - * Compute the scaling factor for the errors. 292 - IF(M.GT.N)THEN 293 - SCALE=CHI2/DBLE(M-N) 294 - ELSE 295 - SCALE=1 296 - ENDIF 297 - * Invert it to get the covariance matrix. 298 - CALL DINV(N,DA,MXFPAR,IR,IFAIL1) 299 - IF(IFAIL1.NE.0)THEN 300 - PRINT *,' !!!!!! LSQINV WARNING : Singular covariance'// 301 - - ' matrix ; no error calculation.' 302 - DO 860 I=1,N 303 - EA(I)=0 304 - 860 CONTINUE 305 - ELSE 306 - DO 870 I=1,N 307 - DO 880 J=1,N 308 - DA(I,J)=SCALE*DA(I,J) 309 - 880 CONTINUE 310 - EA(I)=SQRT(MAX(0.0D0,DA(I,I))) 311 - 870 CONTINUE 312 - ENDIF 313 - *** Print results. 314 - IF(LDEBUG)THEN 315 - WRITE(LUNOUT,'(26X,''Comparison between input and fit'',/, 316 - - 30X,''I X(I) Y(I)'', 317 - - '' F(X)'')') 318 - DO 610 I=1,M 319 - CALL F(X(I),A,VAL) 320 - NFC=NFC+1 321 - WRITE(LUNOUT,'(26X,I5,3(1X,E15.8))') I,X(I),Y(I),VAL 322 - 610 CONTINUE 323 - WRITE(LUNOUT,'(/26X,''Covariance matrix:''/)') 324 - DO 620 I=1,N 325 - WRITE(LUNOUT,'(1X,8(1X,E15.8):(/17X,7(1X,E15.8)))') 326 - - (DA(I,J),J=1,N) 327 - 620 CONTINUE 328 - WRITE(LUNOUT,'(/26X,''Number of function calls '',I4,/ 329 - - '' ++++++ LSQFIT DEBUG : End of debug output.'')') 330 - - NFC 331 - ENDIF 332 - IF(LFITPR)THEN 333 - WRITE(LUNOUT,'(/'' Final values of the fit parameters:''/ 334 - - '' Parameter Value Error''/)') 335 - DO 640 I=1,N 336 - WRITE(LUNOUT,'(2X,I9,2X,E15.8,2X,E15.8)') I,A(I),EA(I) 337 - 640 CONTINUE 338 - WRITE(LUNOUT,'(/'' The errors have been scaled by a'', 339 - - '' factor of '',E15.8,''.'')') SQRT(SCALE) 340 - WRITE(LUNOUT,'(/'' Minimisation finished.'')') 341 - ENDIF 342 - END 1 332 GARFIELD ================================================== P=ROUTINES D=MSNFIT 1 =================== PAGE 431 0 + +DECK,MSNFIT. 1 - SUBROUTINE MSNFIT(X,Y,EY,N,LPRINT,LFITK3,AA,EA,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MSNFIT - Fits a Mathieson distribution. 4 - * (Last changed on 17/ 4/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9 - REAL X(*),Y(*),EY(*) 10 - DOUBLE PRECISION XX(MXLIST),YY(MXLIST),EEY(MXLIST), 11 - - AA(6),EA(6),S0,S1,S2,CHI2 12 - INTEGER N,IFAIL,I,NUSE 13 - LOGICAL LPRINT,LFITK3 14 - EXTERNAL MSNFUN 15 - *** Estimate fitting results. 16 - S0=0 17 - S1=0 18 - S2=0 19 - NUSE=0 20 - DO 10 I=1,N 21 - IF(Y(I).GT.0)NUSE=NUSE+1 22 - S0=S0+Y(I) 23 - S1=S1+Y(I)*X(I) 24 - S2=S2+Y(I)*X(I)**2 25 - XX(I)=X(I) 26 - YY(I)=Y(I) 27 - EEY(I)=EY(I) 28 - 10 CONTINUE 29 - *** Avoid divide by zero. 30 - IF(S0.LE.0)THEN 31 - PRINT *,' !!!!!! MSNFIT WARNING : Integrated contents'// 32 - - ' too small for fit; no fit.' 33 - IFAIL=1 34 - RETURN 35 - ELSEIF(NUSE.LE.3)THEN 36 - PRINT *,' !!!!!! MSNFIT WARNING : Too few non-zero data'// 37 - - ' points; no fit.' 38 - IFAIL=1 39 - RETURN 40 - ELSEIF(AA(3).LE.0.AND..NOT.LFITK3)THEN 41 - PRINT *,' !!!!!! MSNFIT WARNING : K3 is to be fixed, but'// 42 - - ' its value is not > 0; no fit.' 43 - IFAIL=1 44 - RETURN 45 - ENDIF 46 - *** Make a reasonable initial guess. 47 - AA(1)=S1/S0 48 - AA(2)=S0 49 - AA(4)=X(2)-X(1) 50 - AA(5)=X(1)-AA(4)/2 51 - *** from Sigma = SQRT(MAX(0.0D0,(S2-S1**2/S0)/S0)) 52 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MSNFIT DEBUG : Guess'', 53 - - '' before fit: ''/ 54 - - 26X,''Centre: '',E15.8,'' [cm]''/ 55 - - 26X,''Normalisation: '',E15.8/ 56 - - 26X,''K3: '',E15.8/ 57 - - 26X,''Strip width: '',E15.8,'' [cm]''/ 58 - - 26X,''x Offset: '',E15.8,'' [cm]''/ 59 - - 26X,''Anode-cathode: '',E15.8,'' [cm]'')') AA 60 - *** Call LSQFIT to do the real fit. 61 - IF(LFITK3)THEN 62 - CALL LSQFIT(MSNFUN,AA,EA,3,XX,YY,EEY,N,200,0.01*AA(2)/N, 63 - - CHI2,1.0D-3,LPRINT,IFAIL) 64 - ELSE 65 - CALL LSQFIT(MSNFUN,AA,EA,2,XX,YY,EEY,N,200,0.01*AA(2)/N, 66 - - CHI2,1.0D-3,LPRINT,IFAIL) 67 - EA(3)=0 68 - ENDIF 69 - END 333 GARFIELD ================================================== P=ROUTINES D=MSNFUN 1 ============================ 0 + +DECK,MSNFUN. 1 - SUBROUTINE MSNFUN(X,A,F) 2 - *----------------------------------------------------------------------- 3 - * MSNFUN - Auxiliary function for fitting a Mathieson distribution. 4 - * (Last changed on 17/ 4/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,CONSTANTS. 8 - DOUBLE PRECISION A(6),X,F,K1,K2,K3,K4,D,XC,L1,L2,FACTOR,XMIN, 9 - - STRIP,S 10 - *** Check for illegal values of K3. 11 - IF(A(3).LT.0)THEN 12 - F=0 13 - RETURN 14 - ENDIF 15 - *** Compute the various K's. 16 - XC=A(1) 17 - FACTOR=A(2) 18 - K3=A(3) 19 - K2=PI*(1-SQRT(K3)/2)/2 20 - K1=K2*SQRT(K3)/(4*ATAN(SQRT(K3))) 21 - K4=K1/(K2*SQRT(K3)) 22 - D=A(4) 23 - XMIN=A(5) 24 - S=A(6) 25 - *** Determine integration range. 26 - STRIP=DINT((X-XMIN)/D) 27 - IF(STRIP.LT.0.5)STRIP=STRIP-1 28 - L1=((XMIN-XC)+STRIP*D)/S 29 - L2=((XMIN-XC)+(STRIP+1)*D)/S 30 - *** Compute function. 31 - F=2*FACTOR*K4*(ATAN(SQRT(K3)*TANH(K2*L2))- 32 - - ATAN(SQRT(K3)*TANH(K2*L1))) 1 333 P=ROUTINES D=MSNFUN 2 PAGE 432 33 - END 334 GARFIELD ================================================== P=ROUTINES D=NORFIT 1 ============================ 0 + +DECK,NORFIT. 1 - SUBROUTINE NORFIT(X,Y,EY,N,LPRINT,AA,EA,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * NORFIT - Fits a Gaussian. 4 - * (Last changed on 25/ 2/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9 - REAL X(*),Y(*),EY(*),FACT,AVER,SIGMA 10 - DOUBLE PRECISION XX(MXLIST),YY(MXLIST),EEY(MXLIST), 11 - - AA(3),EA(3),S0,S1,S2,CHI2 12 - INTEGER N,IFAIL,I,NUSE 13 - LOGICAL LPRINT 14 - EXTERNAL NORFUN 15 - *** Estimate fitting results. 16 - S0=0 17 - S1=0 18 - S2=0 19 - NUSE=0 20 - DO 10 I=1,N 21 - IF(Y(I).GT.0)NUSE=NUSE+1 22 - S0=S0+Y(I) 23 - S1=S1+Y(I)*X(I) 24 - S2=S2+Y(I)*X(I)**2 25 - XX(I)=X(I) 26 - YY(I)=Y(I) 27 - EEY(I)=EY(I) 28 - 10 CONTINUE 29 - *** Avoid divide by zero. 30 - IF(S0.LE.0)THEN 31 - FACT=0 32 - AVER=0 33 - SIGMA=0 34 - IFAIL=1 35 - PRINT *,' !!!!!! NORFIT WARNING : Integrated contents'// 36 - - ' too small for fit; no fit.' 37 - RETURN 38 - ELSEIF(NUSE.LE.3)THEN 39 - FACT=0 40 - AVER=0 41 - SIGMA=0 42 - IFAIL=1 43 - PRINT *,' !!!!!! NORFIT WARNING : Too few non-zero data'// 44 - - ' points; no fit.' 45 - RETURN 46 - ENDIF 47 - *** Make a reasonable initial guess. 48 - AA(1)=(X(N)-X(1))*S0/REAL(N) 49 - AA(2)=S1/S0 50 - AA(3)=SQRT(MAX(0.0D0,(S2-S1**2/S0)/S0)) 51 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ NORFIT DEBUG : Guess'', 52 - - '' before fit: f/m/s='',3E15.8)') AA 53 - *** Call LSQFIT to do the real fit. 54 - CALL LSQFIT(NORFUN,AA,EA,3,XX,YY,EEY,N,200,0.01*AA(1)/N, 55 - - CHI2,1.0D-3,LPRINT,IFAIL) 56 - END 335 GARFIELD ================================================== P=ROUTINES D=NORFUN 1 ============================ 0 + +DECK,NORFUN. 1 - SUBROUTINE NORFUN(X,A,F) 2 - *----------------------------------------------------------------------- 3 - * NORFUN - Auxiliary function for fitting a Gaussian. 4 - * (Last changed on 22/ 5/95.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,CONSTANTS. 8 - DOUBLE PRECISION A(*),X,F 9 - *** Avoid floating over and underflow. 10 - IF(ABS(X-A(2)).GT.5*ABS(A(3)).OR.A(3).EQ.0)THEN 11 - F=0.0 12 - *** Otherwise evaluate the exponential. 13 - ELSE 14 - F=A(1)*EXP(-0.5*((X-A(2))/A(3))**2)/(SQRT(2*PI)*A(3)) 15 - ENDIF 16 - END 336 GARFIELD ================================================== P=ROUTINES D=NORRAN 1 ============================ 0 + +DECK,NORRAN,IF=NAGNUM. 1 - SUBROUTINE NORRAN(XRAN) 2 - *----------------------------------------------------------------------- 3 - * NORRAN - Replaces the CERN library routine NORRAN (V101) with its 4 - * NAG equivalent G05DDF. 5 - * (Last changed on 8/ 9/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8 - REAL XRAN,DUMMY 9 - DOUBLE PRECISION G05DDF 10 - EXTERNAL G05DDF 11 - *** Manipulate XRAN to avoid optimisation. 12 - DUMMY=XRAN+2.0 13 - *** Call the NAG procedure. 14 - XRAN=REAL(G05DDF(0.0D0,1.0D0)) 15 - END 1 337 GARFIELD ================================================== P=ROUTINES D=ONLINE 1 =================== PAGE 433 0 + +DECK,ONLINE. 1 - LOGICAL FUNCTION ONLINE(X1S,Y1S,X2S,Y2S,US,VS) 2 - *----------------------------------------------------------------------- 3 - * ONLINE - Determines whether a point (U,V) lies on the straight lines 4 - * (X1,Y1) to (X2,Y2). 5 - * (Last changed on 22/ 9/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PARAMETERS. 10 - DOUBLE PRECISION X1,X2,Y1,Y2,U,V,XC,YC,XL,EPSX,EPSY 11 - REAL X1S,Y1S,X2S,Y2S,US,VS 12 - *** Convert input (single precision) variables to double precision. 13 - X1=DBLE(X1S) 14 - X2=DBLE(X2S) 15 - Y1=DBLE(Y1S) 16 - Y2=DBLE(Y2S) 17 - U=DBLE(US) 18 - V=DBLE(VS) 19 - *** Set tolerances. 20 - IF(LEPSG)THEN 21 - EPSX=EPSGX 22 - EPSY=EPSGY 23 - C print *,' Using set tolerances: ',epsx,epsy 24 - ELSE 25 - EPSX=1.0D-5*MAX(ABS(X1),ABS(X2),ABS(U)) 26 - EPSY=1.0D-5*MAX(ABS(Y1),ABS(Y2),ABS(V)) 27 - IF(EPSX.LE.0)EPSX=1.0D-5 28 - IF(EPSY.LE.0)EPSY=1.0D-5 29 - C print *,' Setting tolerances: ',epsx,epsy 30 - ENDIF 31 - * Verify the tolerances. 32 - IF(EPSX.LE.0.OR.EPSY.LE.0)THEN 33 - PRINT *,' !!!!!! ONLINE WARNING : Tolerances not'// 34 - - ' > 0; returning False.' 35 - ONLINE=.FALSE. 36 - RETURN 37 - ENDIF 38 - *** Point to be examined coincides with start or end, 39 - IF((ABS(X1-U).LE.EPSX.AND.ABS(Y1-V).LE.EPSY).OR. 40 - - (ABS(X2-U).LE.EPSX.AND.ABS(Y2-V).LE.EPSY))THEN 41 - ONLINE=.TRUE. 42 - RETURN 43 - *** The line (X1,Y1) to (X2,Y2) is in fact a point. 44 - ELSEIF(ABS(X1-X2).LE.EPSX.AND.ABS(Y1-Y2).LE.EPSY)THEN 45 - ONLINE=.FALSE. 46 - RETURN 47 - *** (U,V) is nearer to (X1,Y1). 48 - ELSEIF(ABS(U-X1)+ABS(V-Y1).LT.ABS(U-X2)+ABS(V-Y2))THEN 49 - C print *,' Nearer to point 1' 50 - XL=((U-X1)*(X2-X1)+(V-Y1)*(Y2-Y1))/((X2-X1)**2+(Y2-Y1)**2) 51 - IF(XL.LT.0.0D0)THEN 52 - XC=X1 53 - YC=Y1 54 - ELSEIF(XL.GT.1.0D0)THEN 55 - XC=X2 56 - YC=Y2 57 - ELSE 58 - XC=X1+XL*(X2-X1) 59 - YC=Y1+XL*(Y2-Y1) 60 - ENDIF 61 - *** (U,V) is nearer to (X2,Y2). 62 - ELSE 63 - C print *,' Nearer to point 2' 64 - XL=((U-X2)*(X1-X2)+(V-Y2)*(Y1-Y2))/((X2-X1)**2+(Y2-Y1)**2) 65 - IF(XL.LT.0.0D0)THEN 66 - XC=X2 67 - YC=Y2 68 - ELSEIF(XL.GT.1.0D0)THEN 69 - XC=X1 70 - YC=Y1 71 - ELSE 72 - XC=X2+XL*(X1-X2) 73 - YC=Y2+XL*(Y1-Y2) 74 - ENDIF 75 - ENDIF 76 - C print *,' Nearest point: ',xc,yc 77 - *** See whether the point is on the line. 78 - IF(ABS(U-XC).LT.EPSX.AND.ABS(V-YC).LT.EPSY)THEN 79 - ONLINE=.TRUE. 80 - ELSE 81 - ONLINE=.FALSE. 82 - ENDIF 83 - END 338 GARFIELD ================================================== P=ROUTINES D=ONLIND 1 ============================ 0 + +DECK,ONLIND. 1 - LOGICAL FUNCTION ONLIND(X1,Y1,X2,Y2,U,V) 2 - *----------------------------------------------------------------------- 3 - * ONLIND - Determines whether a point (U,V) lies on the straight lines 4 - * (X1,Y1) to (X2,Y2). 5 - * (Last changed on 22/ 9/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PARAMETERS. 10 - DOUBLE PRECISION X1,X2,Y1,Y2,U,V,XC,YC,XL,EPSX,EPSY 11 - *** Set tolerances. 12 - IF(LEPSG)THEN 13 - EPSX=EPSGX 14 - EPSY=EPSGY 15 - C print *,' Using set tolerances: ',epsx,epsy 16 - ELSE 17 - EPSX=1.0D-10*MAX(ABS(X1),ABS(X2),ABS(U)) 18 - EPSY=1.0D-10*MAX(ABS(Y1),ABS(Y2),ABS(V)) 1 338 P=ROUTINES D=ONLIND 2 PAGE 434 19 - IF(EPSX.LE.0)EPSX=1.0D-10 20 - IF(EPSY.LE.0)EPSY=1.0D-10 21 - C print *,' Setting tolerances: ',epsx,epsy 22 - ENDIF 23 - * Verify the tolerances. 24 - IF(EPSX.LE.0.OR.EPSY.LE.0)THEN 25 - PRINT *,' !!!!!! ONLIND WARNING : Tolerances not'// 26 - - ' > 0; returning False.' 27 - ONLIND=.FALSE. 28 - RETURN 29 - ENDIF 30 - *** Point to be examined coincides with start or end, 31 - IF((ABS(X1-U).LE.EPSX.AND.ABS(Y1-V).LE.EPSY).OR. 32 - - (ABS(X2-U).LE.EPSX.AND.ABS(Y2-V).LE.EPSY))THEN 33 - ONLIND=.TRUE. 34 - RETURN 35 - *** The line (X1,Y1) to (X2,Y2) is in fact a point. 36 - ELSEIF(ABS(X1-X2).LE.EPSX.AND.ABS(Y1-Y2).LE.EPSY)THEN 37 - ONLIND=.FALSE. 38 - RETURN 39 - *** (U,V) is nearer to (X1,Y1). 40 - ELSEIF(ABS(U-X1)+ABS(V-Y1).LT.ABS(U-X2)+ABS(V-Y2))THEN 41 - C print *,' Nearer to point 1' 42 - XL=((U-X1)*(X2-X1)+(V-Y1)*(Y2-Y1))/((X2-X1)**2+(Y2-Y1)**2) 43 - IF(XL.LT.0.0D0)THEN 44 - XC=X1 45 - YC=Y1 46 - ELSEIF(XL.GT.1.0D0)THEN 47 - XC=X2 48 - YC=Y2 49 - ELSE 50 - XC=X1+XL*(X2-X1) 51 - YC=Y1+XL*(Y2-Y1) 52 - ENDIF 53 - *** (U,V) is nearer to (X2,Y2). 54 - ELSE 55 - C print *,' Nearer to point 2' 56 - XL=((U-X2)*(X1-X2)+(V-Y2)*(Y1-Y2))/((X2-X1)**2+(Y2-Y1)**2) 57 - IF(XL.LT.0.0D0)THEN 58 - XC=X2 59 - YC=Y2 60 - ELSEIF(XL.GT.1.0D0)THEN 61 - XC=X1 62 - YC=Y1 63 - ELSE 64 - XC=X2+XL*(X1-X2) 65 - YC=Y2+XL*(Y1-Y2) 66 - ENDIF 67 - ENDIF 68 - C print *,' Nearest point: ',xc,yc 69 - *** See whether the point is on the line. 70 - IF(ABS(U-XC).LT.EPSX.AND.ABS(V-YC).LT.EPSY)THEN 71 - ONLIND=.TRUE. 72 - ELSE 73 - ONLIND=.FALSE. 74 - ENDIF 75 - END 339 GARFIELD ================================================== P=ROUTINES D=OUTFMT 1 ============================ 0 + +DECK,OUTFMT. 1 - SUBROUTINE OUTFMT(VAL,IFMT,STRING,NC,ALIGN) 2 - *----------------------------------------------------------------------- 3 - * OUTFMT - Takes care of output formatting. 4 - * VARIABLES : VAL : The number to be formatted. 5 - * IFMT : Format code, 0=undefined, 1=string, 6 - * 2=number, 3=logical, 4=histogram. 7 - * STRING : Output string, use only first NC chars. 8 - * (Last changed on 9/ 4/00.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11 - CHARACTER*(*) STRING,ALIGN 12 - INTEGER NC,IFMT,I,IFAIL 13 - REAL VAL 14 - *** Initialise the string. 15 - STRING=' ' 16 - *** Unitialised variables. 17 - IF(IFMT.EQ.0)THEN 18 - IF(LEN(STRING).LT.4)THEN 19 - STRING='?' 20 - ELSE 21 - STRING='Nill' 22 - ENDIF 23 - *** Take care of strings. 24 - ELSEIF(IFMT.EQ.1)THEN 25 - CALL STRBUF('READ',NINT(VAL),STRING,NC,IFAIL) 26 - RETURN 27 - *** Take care of numbers. 28 - ELSEIF(IFMT.EQ.2)THEN 29 - CALL OUTFM2(VAL,STRING) 30 - *** Take care of logicals. 31 - ELSEIF(IFMT.EQ.3)THEN 32 - IF(LEN(STRING).LT.5)THEN 33 - STRING='***' 34 - ELSEIF(NINT(VAL).EQ.0)THEN 35 - STRING='False' 36 - ELSEIF(NINT(VAL).EQ.1)THEN 37 - STRING='True' 38 - ELSE 39 - STRING='???' 40 - ENDIF 41 - *** Take care of histograms. 42 - ELSEIF(IFMT.EQ.4)THEN 43 - STRING='Histogram' 44 - *** Take care of matrices. 45 - ELSEIF(IFMT.EQ.5)THEN 1 339 P=ROUTINES D=OUTFMT 2 PAGE 435 46 - CALL OUTFM5(VAL,STRING) 47 - *** Only other format is real (2). 48 - ELSE 49 - PRINT *,' ###### OUTFMT ERROR : Invalid format code'// 50 - - ' received: ',IFMT,'; program bug, please report.' 51 - STRING='???' 52 - NC=3 53 - RETURN 54 - ENDIF 55 - *** Count the length, removing blanks for left alignment. 56 - IF(ALIGN.EQ.'LEFT')THEN 57 - NC=0 58 - DO 10 I=1,LEN(STRING) 59 - IF(STRING(I:I).NE.' ')THEN 60 - NC=NC+1 61 - IF(STRING(I:I).EQ.'%')THEN 62 - STRING(NC:NC)=' ' 63 - ELSE 64 - STRING(NC:NC)=STRING(I:I) 65 - ENDIF 66 - ENDIF 67 - 10 CONTINUE 68 - IF(NC.LT.LEN(STRING)) 69 - - STRING(MIN(LEN(STRING),NC+1):LEN(STRING))=' ' 70 - * For right alignment. 71 - ELSEIF(ALIGN.EQ.'RIGHT')THEN 72 - NC=0 73 - DO 80 I=LEN(STRING),1,-1 74 - IF(STRING(I:I).NE.' ')THEN 75 - NC=NC+1 76 - IF(STRING(I:I).EQ.'%')THEN 77 - STRING(LEN(STRING)-NC+1:LEN(STRING)-NC+1)=' ' 78 - ELSE 79 - STRING(LEN(STRING)-NC+1:LEN(STRING)-NC+1)= 80 - - STRING(I:I) 81 - ENDIF 82 - ENDIF 83 - 80 CONTINUE 84 - IF(NC.LT.LEN(STRING)) 85 - - STRING(1:MAX(1,LEN(STRING)-NC))=' ' 86 - * Invalid alignment code. 87 - ELSE 88 - STRING='???' 89 - NC=3 90 - PRINT *,' ###### OUTFMT ERROR : Received invalid'// 91 - - ' alignment code: ',ALIGN,'.' 92 - ENDIF 93 - END 340 GARFIELD ================================================== P=ROUTINES D=OUTFM2 1 ============================ 0 + +DECK,OUTFM2. 1 - SUBROUTINE OUTFM2(VAL,STRING) 2 - *----------------------------------------------------------------------- 3 - * OUTFM2 - Takes care of formatting a real. 4 - * VARIABLES : VAL : The number to be formatted. 5 - * STRING : Output string, use only first NC chars. 6 - * (Last changed on 26/ 5/97.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9 - CHARACTER*(*) STRING 10 - CHARACTER*13 AUX 11 - CHARACTER*7 REST 12 - CHARACTER*8 FMT 13 - CHARACTER SIGN,FIRST 14 - INTEGER I,J,NOUT,IEXP 15 - REAL VAL 16 - *** Initialise the string. 17 - STRING=' ' 18 - *** Carry on for reals, first handle the special value 0. 19 - IF(VAL.EQ.0)THEN 20 - STRING='0' 21 - *** Integer numbers less than 1E7. 22 - ELSEIF(ABS(VAL).LT.1.0E7.AND. 23 - - ABS(VAL-ANINT(VAL)).LT.1.0E-5*ABS(VAL))THEN 24 - IF(LEN(STRING).LT.10)THEN 25 - STRING='***' 26 - ELSE 27 - WRITE(STRING,'(I10)') NINT(VAL) 28 - ENDIF 29 - *** Non-integer numbers without exponent, above 1. 30 - ELSEIF(ABS(VAL).LT.1.0E6.AND.ABS(VAL).GE.1.0)THEN 31 - IF(LEN(STRING).LT.8)THEN 32 - STRING='***' 33 - ELSE 34 - WRITE(FMT,'(''(F8.'',I1,'' )'')') 35 - - 5-INT(LOG10(ABS(VAL))) 36 - WRITE(STRING,FMT) VAL 37 - DO 40 I=8,1,-1 38 - IF(STRING(I:I).EQ.'0')THEN 39 - STRING(I:I)=' ' 40 - ELSEIF(STRING(I:I).EQ.'.')THEN 41 - STRING(I:I)=' ' 42 - GOTO 50 43 - ELSEIF(STRING(I:I).NE.' ')THEN 44 - GOTO 50 45 - ENDIF 46 - 40 CONTINUE 47 - 50 CONTINUE 48 - ENDIF 49 - *** Non-integer format less than 1. 50 - ELSEIF(ABS(VAL).LT.1.AND.ABS(VAL).GT.1E-5)THEN 51 - IF(LEN(STRING).LT.13)THEN 52 - STRING='***' 53 - ELSE 54 - WRITE(FMT,'(''(F'',I2,''.'',I2,'')'')') 1 340 P=ROUTINES D=OUTFM2 2 PAGE 436 55 - - 8-INT(LOG10(ABS(VAL))),5-INT(LOG10(ABS(VAL))) 56 - WRITE(STRING,FMT) VAL 57 - DO 60 I=13,1,-1 58 - IF(STRING(I:I).EQ.'0')THEN 59 - STRING(I:I)=' ' 60 - ELSEIF(STRING(I:I).EQ.'.')THEN 61 - STRING(I:I)=' ' 62 - GOTO 70 63 - ELSEIF(STRING(I:I).NE.' ')THEN 64 - GOTO 70 65 - ENDIF 66 - 60 CONTINUE 67 - 70 CONTINUE 68 - ENDIF 69 - *** Anything else. 70 - ELSE 71 - IF(LEN(STRING).LT.13)THEN 72 - STRING='***' 73 - ELSE 74 - WRITE(AUX,'(E13.6)') VAL 75 - IF(VAL.GE.0)THEN 76 - SIGN=' ' 77 - ELSE 78 - SIGN='-' 79 - ENDIF 80 - IF(INDEX('+-0123456789',AUX(11:11)).EQ.0.OR. 81 - - INDEX('0123456789',AUX(12:12)).EQ.0.OR. 82 - - INDEX('0123456789',AUX(13:13)).EQ.0)THEN 83 - STRING=AUX 84 - ELSE 85 - READ(AUX,'(3X,A1,A5,1X,I3)') FIRST,REST,IEXP 86 - DO 20 I=5,1,-1 87 - IF(REST(I:I).NE.'0')GOTO 30 88 - IF(REST(I:I).EQ.'0')REST(I:I)=' ' 89 - 20 CONTINUE 90 - 30 CONTINUE 91 - WRITE(STRING,'(A1,A1,''.'',A5,''E'',I3)') 92 - - SIGN,FIRST,REST,IEXP-1 93 - IF(IEXP.EQ.1)STRING(9:)=' ' 94 - IF(REST.EQ.' ')STRING(3:3)=' ' 95 - ENDIF 96 - ENDIF 97 - ENDIF 98 - *** See whether the expression starts with a dot. 99 - DO 110 I=1,LEN(STRING) 100 - * If it does, try to shift all the rest and add a '0'. 101 - IF(STRING(I:I).EQ.'.')THEN 102 - DO 120 J=LEN(STRING)-1,I,-1 103 - STRING(J+1:J+1)=STRING(J:J) 104 - STRING(J:J)=' ' 105 - 120 CONTINUE 106 - IF(STRING(I:I).EQ.' ')STRING(I:I)='0' 107 - GOTO 130 108 - * If the string starts with something else, leave search. 109 - ELSEIF(INDEX(' +-',STRING(I:I)).EQ.0)THEN 110 - GOTO 130 111 - ENDIF 112 - 110 CONTINUE 113 - 130 CONTINUE 114 - *** Remove blanks. 115 - NOUT=0 116 - DO 100 I=1,LEN(STRING) 117 - IF(STRING(I:I).NE.' ')THEN 118 - IF(NOUT.GE.LEN(STRING))THEN 119 - STRING='***' 120 - RETURN 121 - ENDIF 122 - NOUT=NOUT+1 123 - IF(NOUT.NE.I)THEN 124 - STRING(NOUT:NOUT)=STRING(I:I) 125 - STRING(I:I)=' ' 126 - ENDIF 127 - ENDIF 128 - 100 CONTINUE 129 - END 341 GARFIELD ================================================== P=ROUTINES D=OUTFM5 1 ============================ 0 + +DECK,OUTFM5. 1 - SUBROUTINE OUTFM5(VAL,STRING) 2 - *----------------------------------------------------------------------- 3 - * OUTFM5 - Takes care of formatting a matrix. 4 - * VARIABLES : VAL : Reference to the matrix to be formatted. 5 - * STRING : Output string. 6 - * (Last changed on 9/ 4/96.) 7 - *----------------------------------------------------------------------- 8.- +SEQ,DIMENSIONS. 9.- +SEQ,MATDATA. 10 - CHARACTER*(*) STRING 11 - CHARACTER*20 AUX 12 - REAL VAL 13 - *** Initialise the string. 14 - STRING=' ' 15 - *** Matrix reference. 16 - IREF=NINT(VAL) 17 - *** Locate the matrix. 18 - DO 10 I=1,MXMAT 19 - IF(MREF(I).EQ.IREF)THEN 20 - ISLOT=I 21 - GOTO 20 22 - ENDIF 23 - 10 CONTINUE 24 - * Issue warning if this doesn't exist. 25 - IF(LEN(STRING).GE.18)THEN 26 - STRING='<%unknown%matrix%>' 27 - ELSE 1 341 P=ROUTINES D=OUTFM5 2 PAGE 437 28 - STRING='?' 29 - ENDIF 30 - RETURN 31 - 20 CONTINUE 32 - *** If the matrix is not suitable for formatting, show dimensions. 33 - IF(MDIM(ISLOT).GT.1.AND.MLEN(ISLOT).GT.1)THEN 34 - * Format the number of dimensions. 35 - CALL OUTFM2(REAL(MDIM(ISLOT)),AUX) 36 - * Get the length. 37 - DO 30 I=LEN(AUX),1,-1 38 - IF(AUX(I:I).NE.' ')THEN 39 - NC=I 40 - GOTO 70 41 - ENDIF 42 - 30 CONTINUE 43 - NC=1 44 - 70 CONTINUE 45 - * Format the description. 46 - IF(LEN(STRING).GE.NC+7)THEN 47 - STRING=AUX(1:NC)//'-Matrix' 48 - ELSE 49 - STRING='***' 50 - ENDIF 51 - RETURN 52 - ENDIF 53 - *** If the string is too short, no way to format. 54 - IF(LEN(STRING).LT.5)THEN 55 - STRING='***' 56 - RETURN 57 - ENDIF 58 - *** Format the first bit of the matrix. 59 - STRING(1:1)='(' 60 - NCSTR=1 61 - DO 40 I=1,MLEN(ISLOT) 62 - * Format an element. 63 - CALL OUTFM2(MVEC(MORG(ISLOT)+I),AUX) 64 - * Get the length. 65 - DO 50 J=LEN(AUX),1,-1 66 - IF(AUX(J:J).NE.' ')THEN 67 - NC=J 68 - GOTO 60 69 - ENDIF 70 - 50 CONTINUE 71 - NC=1 72 - 60 CONTINUE 73 - * Add it to the string. 74 - IF(LEN(STRING).GE.NCSTR+NC+2)THEN 75 - STRING(NCSTR+1:NCSTR+NC+2)=AUX(1:NC)//',%' 76 - NCSTR=NCSTR+NC+2 77 - ELSEIF(LEN(STRING).GE.NCSTR+4)THEN 78 - STRING(NCSTR+1:NCSTR+4)='...)' 79 - NCSTR=NCSTR+4 80 - RETURN 81 - ELSE 82 - STRING(LEN(STRING)-3:)='***)' 83 - NCSTR=LEN(STRING) 84 - RETURN 85 - ENDIF 86 - 40 CONTINUE 87 - IF(NCSTR.GE.2)STRING(NCSTR-1:NCSTR)=') ' 88 - END 342 GARFIELD ================================================== P=ROUTINES D=POLFIT 1 ============================ 0 + +DECK,POLFIT. 1 - SUBROUTINE POLFIT(X,Y,EY,N,LPRINT,AA,EA,NA,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * POLFIT - Fits a Polynomial 4 - * (Last changed on 9/ 6/96.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,PRINTPLOT. 8 - INTEGER NNA,IWORK(MXFPAR) 9 - COMMON /PFDAT/ NNA 10 - REAL X(*),Y(*),EY(*) 11 - DOUBLE PRECISION XX(MXLIST),YY(MXLIST),EEY(MXLIST), 12 - - AA(*),EA(*),CHI2,D(MXFPAR,MXFPAR+2),AUX,YSUM 13 - INTEGER N,NA,IFAIL 14 - LOGICAL LPRINT 15 - EXTERNAL POLFUN 16 - *** Preset the error flag. 17 - IFAIL=1 18 - *** Debugging and identification output. 19 - IF(LIDENT)PRINT *,' /// ROUTINE POLFIT ///' 20 - *** Check dimensions. 21 - IF(NA.GT.MXFPAR.OR.N.GT.MXLIST)THEN 22 - PRINT *,' !!!!!! POLFIT WARNING : Dimensions of the'// 23 - - ' problem exceed compilation parameters; no fit.' 24 - RETURN 25 - ENDIF 26 - *** Copy the vectors. 27 - YSUM=0 28 - DO 100 I=1,N 29 - XX(I)=DBLE(X(I)) 30 - YY(I)=DBLE(Y(I)) 31 - YSUM=YSUM+ABS(YY(I)) 32 - EEY(I)=DBLE(EY(I)) 33 - 100 CONTINUE 34 - *** Estimate fitting results, first fill matrix. 35 - DO 10 I=0,2*(NA-1) 36 - IF(I.EQ.0)THEN 37 - AUX=N 38 - ELSE 39 - AUX=0 40 - DO 20 J=1,N 41 - AUX=AUX+XX(J)**I 1 342 P=ROUTINES D=POLFIT 2 PAGE 438 42 - 20 CONTINUE 43 - ENDIF 44 - DO 30 J=1,NA 45 - K=I+2-J 46 - IF(K.LT.1.OR.K.GT.NA)GOTO 30 47 - D(J,K)=AUX 48 - 30 CONTINUE 49 - 10 CONTINUE 50 - * Left hand side. 51 - DO 40 I=0,NA-1 52 - AUX=0 53 - DO 50 J=1,N 54 - IF(I.EQ.0)THEN 55 - AUX=AUX+YY(J) 56 - ELSE 57 - AUX=AUX+YY(J)*XX(J)**I 58 - ENDIF 59 - 50 CONTINUE 60 - D(I+1,MXFPAR+1)=AUX 61 - 40 CONTINUE 62 - * Now solve the equation. 63 - CALL DEQN(NA,D,MXFPAR,IWORK,IFAIL1,1,D(1,MXFPAR+1)) 64 - * Check error condition. 65 - IF(IFAIL1.NE.0)THEN 66 - PRINT *,' !!!!!! POLFIT WARNING : Failure to obtain'// 67 - - ' a first estimate of the solution; not solved.' 68 - RETURN 69 - ENDIF 70 - * Copy the solution. 71 - DO 60 I=1,NA 72 - AA(I)=D(I,MXFPAR+1) 73 - 60 CONTINUE 74 - * Debugging output. 75 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ POLFIT DEBUG : Guess'', 76 - - '' before fit: a_i='',3E15.8,(/26X,5E15.8:))') 77 - - (AA(I),I=1,NA) 78 - *** Now carry out the fit. 79 - NNA=NA 80 - CALL LSQFIT(POLFUN,AA,EA,NA,XX,YY,EEY,N,200,0.01*YSUM/N, 81 - - CHI2,1.0D-3,LPRINT,IFAIL) 82 - END 343 GARFIELD ================================================== P=ROUTINES D=POLFUN 1 ============================ 0 + +DECK,POLFUN. 1 - SUBROUTINE POLFUN(X,A,F) 2 - *----------------------------------------------------------------------- 3 - * POLFUN - Auxiliary function for fitting a polynomial. 4 - * (Last changed on 9/ 5/96.) 5 - *----------------------------------------------------------------------- 6 - DOUBLE PRECISION A(*),X,F 7 - INTEGER NNA 8 - COMMON /PFDAT/ NNA 9 - *** Sum the polynomial. 10 - F=0 11 - DO 10 I=NNA,1,-1 12 - F=F*X+A(I) 13 - 10 CONTINUE 14 - END 344 GARFIELD ================================================== P=ROUTINES D=PROINT 1 ============================ 0 + +DECK,PROINT. 1 - SUBROUTINE PROINT(NAME,NFIELD,LUN) 2 - *----------------------------------------------------------------------- 3 - * PROINT - Initialises progress printing. 4 - * PROFLD - Sets field names 5 - * PRORED - Changes the number of fields. 6 - * PROSTA - Prints current status. 7 - * PROEND - Ends progress printing. 8 - * (Last changed on 18/ 1/99). 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,PRINTPLOT. 12 - INTEGER MXFLD 13 - PARAMETER(MXFLD=10) 14 - CHARACTER*130 OUT 15 - CHARACTER*(*) NAME 16 - CHARACTER*20 FLD(MXFLD),FAC 17 - INTEGER NFIELD,NCFLD(MXFLD),MFLD,NFLD,NCFAC,NCOUT,IXFLD(MXFLD), 18 - - LUN,LUNPRO,I,IFLD 19 - REAL X,XRNG(MXFLD),RANGE 0 20-+ +SELF,IF=SAVE. 21 - SAVE FLD,NCFLD,MFLD,NFLD,IXFLD,FAC,NCFAC,LUNPRO,XRNG 0 22-+ +SELF. 23 - DATA NFLD/0/,MFLD/0/,LUNPRO/6/,NCFAC/7/ 24 - DATA FAC/'Unknown '/ 25 - *** Check setting of nfield. 26 - IF(NFIELD.LT.1.OR.NFIELD.GT.MXFLD)THEN 27 - PRINT *,' !!!!!! PROINT WARNING : Received an incorrect'// 28 - - ' number of fields ; program bug - please report.' 29 - RETURN 30 - ENDIF 31 - *** Keep the routine name. 32 - FAC=NAME 33 - NCFAC=MIN(LEN(NAME),LEN(FAC)) 34 - *** Initialise the field names. 35 - DO 10 I=1,NFIELD 36 - FLD(I)=' ' 37 - NCFLD(I)=0 38 - IXFLD(I)=0 39 - 10 CONTINUE 40 - NFLD=NFIELD 41 - MFLD=0 1 344 P=ROUTINES D=PROINT 2 PAGE 439 42 - *** Keep the logical unit number. 43 - LUNPRO=LUN 44 - *** Write out a blank line or a synchronisation record. 45 - IF(LPROPR)THEN 46 - IF(LSYNCH)THEN 47 - WRITE(6,'('' >>>>>> progress init '',I5,'' '',A)') 48 - - NFLD,FAC(1:NCFAC) 49 - ELSE 50 - WRITE(LUNPRO,'('' '')') 51 - ENDIF 52 - ENDIF 53 - *** That's it for this entry. 54 - RETURN 55 - ENTRY PROFLD(IFLD,NAME,RANGE) 56 - *** Check validity of the field index. 57 - IF(IFLD.LT.1.OR.IFLD.GT.NFLD.OR.NFLD.LT.1)THEN 58 - PRINT *,' !!!!!! PROFLD WARNING : Received an incorrect'// 59 - - ' field index; program bug - please report.' 60 - RETURN 61 - ENDIF 62 - *** Update the latest received field. 63 - MFLD=MAX(MFLD,IFLD) 64 - *** Otherwise store this field name. 65 - FLD(IFLD)=NAME 66 - NCFLD(IFLD)=MIN(LEN(NAME),LEN(FLD(IFLD))) 67 - XRNG(IFLD)=RANGE 68 - *** Reset the progress counter for this field to 0. 69 - IXFLD(IFLD)=0 70 - *** Synchronisation records. 71 - IF(LSYNCH)WRITE(6,'('' >>>>>> progress field '',I5,'' '', 72 - - E15.8,'' '',A)') IFLD,XRNG(IFLD),FLD(IFLD)(1:NCFLD(IFLD)) 73 - *** That's it for this entry. 74 - RETURN 75 - *** Reduce or increase the number of fields. 76 - ENTRY PRORED(NFIELD) 77 - *** Check validity of the field index. 78 - IF(NFIELD.LE.0)THEN 79 - PRINT *,' !!!!!! PRORED WARNING : Received an incorrect'// 80 - - ' new number of fields; program bug - please report.' 81 - ELSE 82 - IF(LSYNCH)WRITE(6,'('' >>>>>> progress count '',I5, 83 - - '' '',I4)') NFIELD,NFLD 84 - DO 15 I=NFLD+1,NFIELD 85 - FLD(I)=' ' 86 - NCFLD(I)=0 87 - IXFLD(I)=0 88 - 15 CONTINUE 89 - NFLD=NFIELD 90 - MFLD=MIN(MFLD,NFIELD) 91 - ENDIF 92 - *** All for this entry. 93 - RETURN 94 - *** Print current status. 95 - ENTRY PROSTA(IFLD,X) 96 - *** Check validity of the field index. 97 - IF(IFLD.LT.1.OR.IFLD.GT.NFLD.OR.NFLD.LT.1)THEN 98 - PRINT *,' !!!!!! PROSTA WARNING : Received an incorrect'// 99 - - ' field index; program bug - please report.' 100 - RETURN 101 - ENDIF 102 - *** Update the counter for the field. 103 - IF(XRNG(IFLD).GT.0)THEN 104 - IXFLD(IFLD)=MAX(0,MIN(10,INT(10*X/XRNG(IFLD)+0.0001))) 105 - IF(LSYNCH)WRITE(6,'('' >>>>>> progress set '',I5, 106 - - '' '',E15.8)') IFLD,X/XRNG(IFLD) 107 - ELSE 108 - IXFLD(IFLD)=-1 109 - IF(LSYNCH)WRITE(6,'('' >>>>>> progress set '',I5, 110 - - '' working'')') IFLD 111 - ENDIF 112 - *** Reset all lower counters. 113 - DO 20 I=IFLD+1,NFLD 114 - IF(XRNG(I).GT.0)THEN 115 - IXFLD(I)=0 116 - IF(LSYNCH)WRITE(6,'('' >>>>>> progress set '',I5, 117 - - '' 0'')') IFLD 118 - ELSE 119 - IXFLD(I)=-1 120 - IF(LSYNCH)WRITE(6,'('' >>>>>> progress set '',I5, 121 - - '' working'')') IFLD 122 - ENDIF 123 - 20 CONTINUE 124 - *** In case of synchronisation output, this is all. 125 - IF(LSYNCH)RETURN 126 - *** Print the current status. 127 - OUT=FAC(1:NCFAC)//': ' 128 - NCOUT=NCFAC+2 129 - DO 30 I=1,MFLD 130 - IF(NCOUT+14.GT.LEN(OUT))THEN 131 - IF(NCOUT+2.LE.LEN(OUT))THEN 132 - OUT(NCOUT-1:NCOUT+2)=' ...' 133 - NCOUT=NCOUT+3 134 - ENDIF 135 - GOTO 40 136 - ENDIF 137 - IF(NCFLD(I).GT.0)THEN 138 - OUT(NCOUT+1:NCOUT+NCFLD(I))=FLD(I)(1:NCFLD(I))//' ' 139 - NCOUT=NCOUT+NCFLD(I)+1 140 - ENDIF 141 - IF(IXFLD(I).EQ.-1)THEN 142 - IF(NCOUT.GT.1)NCOUT=NCOUT-1 143 - OUT(NCOUT+1:NCOUT+13)=', ' 144 - NCOUT=NCOUT+2 145 - ELSEIF(IXFLD(I).EQ.0)THEN 146 - OUT(NCOUT+1:NCOUT+14)='[ Starting ], ' 147 - NCOUT=NCOUT+14 1 344 P=ROUTINES D=PROINT 3 PAGE 440 148 - ELSEIF(IXFLD(I).EQ.20)THEN 149 - OUT(NCOUT+1:NCOUT+14)='[ Finished ], ' 150 - NCOUT=NCOUT+14 151 - ELSE 152 - OUT(NCOUT+1:NCOUT+14)='[..........], ' 153 - IF(IXFLD(I).GE.2) 154 - - OUT(NCOUT+2:NCOUT+IXFLD(I))='--------------------' 155 - OUT(NCOUT+IXFLD(I)+1:NCOUT+IXFLD(I)+1)='>' 156 - NCOUT=NCOUT+14 157 - ENDIF 158 - 30 CONTINUE 159 - IF(NCOUT.GT.2)THEN 160 - OUT(NCOUT-1:NCOUT)='. ' 161 - NCOUT=NCOUT-1 162 - ENDIF 163 - 40 CONTINUE 0 164-+ +SELF,IF=IBMRT. 165 - IF(LPROPR)WRITE(LUNPRO,'(A1,'' '',A)',ADVANCE='NO') 166 - - CHAR(13),OUT(1:MAX(78,NCOUT)) 0 167-+ +SELF,IF=SUN,HPUX,LINUX,DECS. 168 - IF(LPROPR)WRITE(LUNPRO,'(A1,'' '',A,$)') 169 - - CHAR(13),OUT(1:MAX(78,NCOUT)) 0 170-+ +SELF,IF=-IBMRT,IF=-SUN,IF=-HPUX,IF=-LINUX,IF=-DECS. 171 - IF(LPROPR)WRITE(LUNPRO,'(''+ '',A)') OUT(1:MAX(78,NCOUT)) 0 172-+ +SELF. 173 - *** That's all for this entry. 174 - RETURN 175 - ENTRY PROEND 176 - *** Say that we're done. 177 - IF(LSYNCH)THEN 178 - WRITE(6,'('' >>>>>> progress end'')') 179 - ELSE 180 - OUT=' ' 181 - OUT(1:NCFAC)=FAC(1:NCFAC) 182 - OUT(NCFAC+1:NCFAC+12)=': Completed.' 0 183-+ +SELF,IF=IBMRT,SUN,HPUX,LINUX,DECS. 184 - IF(LPROPR)WRITE(LUNPRO,'(A1,'' '',A)') 185 - - CHAR(13),OUT(1:MAX(78,NCFAC+12)) 0 186-+ +SELF,IF=-IBMRT,IF=-SUN,IF=-HPUX,IF=-LINUX,IF=-DECS. 187 - IF(LPROPR)WRITE(LUNPRO,'(''+ '',A)') OUT(1:MAX(78,NCFAC+12)) 0 188-+ +SELF. 189 - ENDIF 190 - *** Reset the fields flag. 191 - NFLD=0 192 - END 345 GARFIELD ================================================== P=ROUTINES D=RNDEXP 1 ============================ 0 + +DECK,RNDEXP. 1 - REAL FUNCTION RNDEXP(A) 2 - *----------------------------------------------------------------------- 3 - * RNDEXP - Function returning a randomly distributed number from an 4 - * exponential distribution with parameter A. 5 - * VARIABLES : X : A homogeneously distributed number. 6 - * A : Expectation value of the distribution. 7 - * (Last changed on 17/10/95.) 8 - *----------------------------------------------------------------------- 9 - PARAMETER(NVEC=100) 10 - REAL RVEC(NVEC) 11 - INTEGER IVEC 0 12-+ +SELF,IF=SAVE. 13 - SAVE RVEC,IVEC 0 14-+ +SELF. 15 - DATA IVEC/0/ 16 - *** Return here if we got by accident an end-point (should not happen). 17 - 10 CONTINUE 18 - * Get a random number. 19 - IF(IVEC.EQ.0.OR.IVEC.GE.NVEC)THEN 20 - CALL RANLUX(RVEC,NVEC) 21 - IVEC=1 22 - ELSE 23 - IVEC=IVEC+1 24 - ENDIF 25 - X=RVEC(IVEC) 26 - * Check the value we got. 27 - IF(X.LE.0.0.OR.X.GT.1.0)GOTO 10 28 - * And assign. 29 - RNDEXP=-A*LOG(X) 30 - END 346 GARFIELD ================================================== P=ROUTINES D=RNDNBN 1 ============================ 0 + +DECK,RNDNBN,IF=NAGNUM. 1 - SUBROUTINE RNDNBN(PP,N,IRAN,NRAN) 2 - *----------------------------------------------------------------------- 3 - * RNDNBN - Random numbers according to a negative binomial. 4 - * Version for use with the NAG Fortran mark 16 libraries. 5 - * (Last changed on 12/ 6/97.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8 - INTEGER N,NR,IFAIL,G05EYF,INIT,IRAN(*),NRAN,I 9 - PARAMETER(NR=2000) 10 - DOUBLE PRECISION P,R(NR) 11 - REAL PP 12 - EXTERNAL G05EYF 1 346 P=ROUTINES D=RNDNBN 2 PAGE 441 13-+ +SELF,IF=SAVE. 14 - SAVE INIT 0 15-+ +SELF. 16 - *** Initialise the generator. 17 - DATA INIT/0/ 18 - IF(INIT.EQ.0)THEN 19 - CALL G05CBF(0) 20 - INIT=1 21 - ENDIF 22 - *** Check value of P and copy to double precision. 23 - IF(PP.LT.0.OR.PP.GT.1)THEN 24 - DO 50 I=1,NRAN 25 - IRAN(I)=-1 26 - 50 CONTINUE 27 - RETURN 28 - ELSE 29 - P=MIN(1.0D0,MAX(0.0D0,DBLE(PP))) 30 - ENDIF 31 - *** Check value of N. 32 - IF(N.LT.0)THEN 33 - DO 40 I=1,NRAN 34 - IRAN(I)=-1 35 - 40 CONTINUE 36 - RETURN 37 - ENDIF 38 - *** Create reference vector. 39 - IFAIL=+1 40 - CALL G05EEF(N,P,R,NR,IFAIL) 41 - * If array too short, we almost certainly need size 0. 42 - IF(IFAIL.EQ.3.OR.IFAIL.EQ.2)THEN 43 - C print *,' IFAIL=',ifail,' p=',p,' n=',n 44 - DO 20 I=1,NRAN 45 - IRAN(I)=0 46 - 20 CONTINUE 47 - RETURN 48 - * Other errors are genuine - return -1. 49 - ELSEIF(IFAIL.NE.0)THEN 50 - PRINT *,' !!!!!! RNDNBN WARNING : Received error status'// 51 - - ' IFAIL=',IFAIL,' from G05EEF' 52 - PRINT *,' For a probability p=',P, 53 - - ' and n=',N,'.' 54 - DO 30 I=1,NRAN 55 - IRAN(I)=-1 56 - 30 CONTINUE 57 - RETURN 58 - ENDIF 59 - *** And return a random number. 60 - DO 10 I=1,NRAN 61 - IRAN(I)=G05EYF(R,NR) 62 - 10 CONTINUE 63 - END 347 GARFIELD ================================================== P=ROUTINES D=RNDNOR 1 ============================ 0 + +DECK,RNDNOR. 1 - REAL FUNCTION RNDNOR(AVER,SIGMA) 2 - *----------------------------------------------------------------------- 3 - * RNDNOR - Function generating random numbers according to a normal 4 - * distribution with expected value MU and standard deviation 5 - * SIGMA. 6 - * VARIABLES : MU : average of the random numbers. 7 - * SIGMA : standard deviation of the random numbers. 8 - * (Last changed on 15/ 9/99.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11 - INTEGER IVEC,MXVEC 12 - PARAMETER(MXVEC=1000) 13 - REAL AVER,SIGMA,RVEC(MXVEC) 0 14-+ +SELF,IF=SAVE. 15 - SAVE RVEC,IVEC 0 16-+ +SELF. 17 - DATA IVEC/0/ 18 - IF(IVEC.EQ.0.OR.IVEC+1.GT.MXVEC)THEN 19 - CALL RNORML(RVEC,MXVEC) 20 - IVEC=1 21 - ENDIF 22 - RNDNOR=AVER+SIGMA*RVEC(IVEC) 23 - IVEC=IVEC+1 24 - END 348 GARFIELD ================================================== P=ROUTINES D=RNDPOL 1 ============================ 0 + +DECK,RNDPOL. 1 - REAL FUNCTION RNDPOL(THETA) 2 - *----------------------------------------------------------------------- 3 - * RNDPOL - Generates random numbers according to a Polya distribution 4 - * with parameter THETA. Since this is simply a scaled Gamma 5 - * distribution with parameter 1+THETA, RNGAMA (V135) is used. 6 - * (Last changed on 6/ 7/95.) 7 - *----------------------------------------------------------------------- 8 - REAL RNGAMA,THETA 9 - EXTERNAL RNGAMA 10 - *** Verify the parameter. 11 - IF(THETA.GT.-1)THEN 12 - RNDPOL=RNGAMA(1+THETA)/(1+THETA) 13 - ELSE 14 - RNDPOL=0 15 - ENDIF 16 - END 1 349 GARFIELD ================================================== P=ROUTINES D=RNDFUN 1 =================== PAGE 442 0 + +DECK,RNDFUN. 1 - REAL FUNCTION RNDFUN(ARG) 2 - *----------------------------------------------------------------------- 3 - * RNDFUN - Generates random numbers according to a function, uses the 4 - * V152 routines. 5 - * (Last changed on 30/ 8/99.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8 - INTEGER IENTRY 9 - REAL ARG,CUMRNF(200),XRAN(1) 10 - LOGICAL FUNSET 11 - COMMON /RNDFCM/ IENTRY,FUNSET,CUMRNF 12 - *** Verify that the function has been prepared. 13 - IF(.NOT.FUNSET)THEN 14 - PRINT *,' !!!!!! RNDFUN WARNING : Before using'// 15 - - ' RND_FUNCTION, you must call PREPARE_RND_FUNCTION;'// 16 - - ' no random number' 17 - RNDFUN=0 18 - RETURN 19 - ENDIF 20 - *** Generate a random number. 21 - CALL FUGLUX(CUMRNF,XRAN,1) 22 - RNDFUN=XRAN(1) 23 - END 350 GARFIELD ================================================== P=ROUTINES D=RNDHIS 1 ============================ 0 + +DECK,RNDHIS. 1 - SUBROUTINE RNDHIS(IREF,X) 2 - *----------------------------------------------------------------------- 3 - * RNDHIS - Generates random numbers according to a histogram. 4 - * (Last changed on 4/10/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,HISTDATA. 9 - INTEGER IREF,IFAIL,I,NITMAX 10 - PARAMETER(NITMAX=10) 11 - REAL X,XRAN(1) 12 - *** Initial settings. 13 - X=0 14 - *** Check reference number and scale setting. 15 - IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN 16 - PRINT *,' !!!!!! RNDHIS WARNING : Histogram reference'// 17 - - ' not valid; no random number.' 18 - RETURN 19 - ELSEIF(.NOT.SET(IREF))THEN 20 - PRINT *,' !!!!!! RNDHIS WARNING : The scale of this'// 21 - - ' auto-range histogram is not yet set; no random'// 22 - - ' number.' 23 - RETURN 24 - ENDIF 25 - *** Try NITMAX times to get a random number. 26 - DO 10 I=1,NITMAX 27 - * Get a random number. 28 - CALL RANLUX(XRAN,1) 29 - * Reverse interpolation. 30 - CALL HISINV(IREF,XRAN(1),X,2,IFAIL) 31 - * Leave when OK. 32 - IF(IFAIL.EQ.0)THEN 33 - CALL LOGSAV(.TRUE.,'OK',IFAIL) 34 - RETURN 35 - ENDIF 36 - 10 CONTINUE 37 - *** If this still fails after 10 tries, then abandon. 38 - IF(IFAIL.NE.0)THEN 39 - PRINT *,' !!!!!! RNDHIS WARNING : Inverse interpolation'// 40 - - ' error; no random number.' 41 - X=0 42 - CALL LOGSAV(.FALSE.,'OK',IFAIL) 43 - RETURN 44 - ENDIF 45 - END 351 GARFIELD ================================================== P=ROUTINES D=RNDUNI 1 ============================ 0 + +DECK,RNDUNI. 1 - REAL FUNCTION RNDUNI(SCALE) 2 - *----------------------------------------------------------------------- 3 - * RNDUNI - Function generating random numbers according to a uniform 4 - * distribution over the range <0,SCALE>, end-points are 5 - * excluded. 6 - * VARIABLES : SCALE : upper limit of range of the distribution. 7 - * (Last changed on 6/10/00.) 8 - *----------------------------------------------------------------------- 9 - implicit none 10 - INTEGER IVEC,MXVEC 11 - PARAMETER(MXVEC=1000) 12 - REAL SCALE,RVEC(MXVEC) 0 13-+ +SELF,IF=SAVE. 14 - SAVE RVEC,IVEC 0 15-+ +SELF. 16 - DATA IVEC/0/ 17 - IF(IVEC.EQ.0.OR.IVEC+1.GT.MXVEC)THEN 18 - CALL RANLUX(RVEC,MXVEC) 19 - IVEC=1 20 - ENDIF 21 - RNDUNI=SCALE*RVEC(IVEC) 22 - IVEC=IVEC+1 23 - END 1 352 GARFIELD ================================================== P=ROUTINES D=RNDM 1 =================== PAGE 443 0 + +DECK,RNDM,IF=NAGNUM. 1 - REAL FUNCTION RNDM(DUMMY) 2 - *----------------------------------------------------------------------- 3 - * RNDM - Replaces the CERN library routine RNDM (V104) with the NAG 4 - * equivalent G05CAF. 5 - *----------------------------------------------------------------------- 6 - RNDM=REAL(G05CAF(DUMMY)) 7 - END 353 GARFIELD ================================================== P=ROUTINES D=ROUND 1 ============================ 0 + +DECK,ROUND. 1 - SUBROUTINE ROUND(XMIN,XMAX,N,DIR,STEP) 2 - *----------------------------------------------------------------------- 3 - * ROUND - Rounds the input range (XMIN.XMAX) to the nearest decent 4 - * interval. 5 - * VARIABLES : DIR : The new interval may be larger if .TRUE. 6 - * N : The number of intermediate points. 7 - * STEP : Contains the step size. 8 - * (Last changed on 20/ 5/99.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11 - REAL XMAX,XMIN,STEP,STNEW,XMINC,XMAXC 12 - INTEGER N,K 13 - CHARACTER*(*) DIR 14 - *** Check the validity of the input. 15 - IF(XMAX.EQ.XMIN)THEN 16 - STEP=0.0 17 - RETURN 18 - ELSEIF(XMAX.LE.XMIN)THEN 19 - PRINT *,' !!!!!! ROUND WARNING : Illegal range: ',XMIN,XMAX 20 - RETURN 21 - ELSEIF(N.LE.0)THEN 22 - PRINT *,' !!!!!! ROUND WARNING : Illegal number of points.' 23 - RETURN 24 - ENDIF 25 - *** Set the rough interval. 26 - STEP=(XMAX-XMIN)/REAL(N) 27 - * Compute order of magnitude. 28 - K=NINT(LOG10(STEP)) 29 - * Very large range: abandon. 30 - IF(K.GT.30)THEN 31 - RETURN 32 - * Normal range larger than 1: eliminate order of magnitude. 33 - ELSEIF(K.GE.0)THEN 34 - STEP=STEP/10.0**K 35 - * Very small range: abandon. 36 - ELSEIF(K.LT.-30)THEN 37 - RETURN 38 - * Normal range smaller than 1: eliminate order of magnitude. 39 - ELSE 40 - STEP=STEP*10.0**(-K) 41 - ENDIF 42 - * Make more bins. 43 - IF(INDEX(DIR,'COARSER').NE.0)THEN 44 - IF(STEP.GE.0.1.AND.STEP.LT.0.2)THEN 45 - STNEW=0.2 46 - ELSEIF(STEP.GE.0.2.AND.STEP.LT.0.5)THEN 47 - STNEW=0.5 48 - ELSEIF(STEP.GE.0.5.AND.STEP.LT.1.0)THEN 49 - STNEW=1.0 50 - ELSEIF(STEP.GE.1.0.AND.STEP.LT.2.0)THEN 51 - STNEW=2.0 52 - ELSEIF(STEP.GE.2.0.AND.STEP.LT.5.0)THEN 53 - STNEW=5.0 54 - ELSEIF(STEP.GE.5.0.AND.STEP.LT.10.0)THEN 55 - STNEW=10.0 56 - ELSE 57 - PRINT *,' ###### ROUND ERROR : Unable to find a', 58 - - ' new interval for STEP=',STEP,' program bug.' 59 - RETURN 60 - ENDIF 61 - * Or make fewer bins. 62 - ELSE 63 - IF(STEP.GE.0.1.AND.STEP.LT.0.2)THEN 64 - STNEW=0.1 65 - ELSEIF(STEP.GE.0.2.AND.STEP.LT.0.5)THEN 66 - STNEW=0.2 67 - ELSEIF(STEP.GE.0.5.AND.STEP.LT.1.0)THEN 68 - STNEW=0.5 69 - ELSEIF(STEP.GE.1.0.AND.STEP.LT.2.0)THEN 70 - STNEW=1.0 71 - ELSEIF(STEP.GE.2.0.AND.STEP.LT.5.0)THEN 72 - STNEW=2.0 73 - ELSEIF(STEP.GE.5.0.AND.STEP.LT.10.0)THEN 74 - STNEW=5.0 75 - ELSE 76 - PRINT *,' ###### ROUND ERROR : Unable to find a', 77 - - ' new interval for STEP=',STEP,' program bug.' 78 - RETURN 79 - ENDIF 80 - ENDIF 81 - * Add order of magnitude again. 82 - IF(K.GE.0)THEN 83 - STEP=STNEW*10.0**K 84 - ELSE 85 - STEP=STNEW/10.0**(-K) 86 - ENDIF 87 - * Check whether the bins need to be integer. 88 - IF(INDEX(DIR,'INTEGER').NE.0.AND.STEP.LT.1)STEP=1 89 - *** Set the new XMIN and XMAX. 90 - XMINC=STEP*ANINT(XMIN/STEP) 91 - XMAXC=STEP*ANINT(XMAX/STEP) 92 - IF(INDEX(DIR,'LARGER').NE.0)THEN 93 - IF(XMINC.LE.XMIN+STEP/10.0)XMIN=XMINC 94 - IF(XMINC.GT.XMIN+STEP/10.0)XMIN=XMINC-STEP 1 353 P=ROUTINES D=ROUND 2 PAGE 444 95 - IF(XMAXC.LT.XMAX-STEP/10.0)XMAX=XMAXC+STEP 96 - IF(XMAXC.GE.XMAX-STEP/10.0)XMAX=XMAXC 97 - ELSE 98 - IF(XMINC.LT.XMIN-STEP/10.0)XMIN=XMINC+STEP 99 - IF(XMINC.GE.XMIN-STEP/10.0)XMIN=XMINC 100 - IF(XMAXC.LE.XMAX+STEP/10.0)XMAX=XMAXC 101 - IF(XMAXC.GT.XMAX+STEP/10.0)XMAX=XMAXC-STEP 102 - ENDIF 103 - END 354 GARFIELD ================================================== P=ROUTINES D=SPLINE 1 ============================ 0 + +DECK,SPLINE. 1 - SUBROUTINE SPLINE(X,Y,C,N,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SPLINE - Routine preparing a cubic spline interpolation through the 4 - * the points (X(I),Y(I)) I=1,N. 5 - * VARIABLES : Most of the variables are the same as in the reference, 6 - * the only major difference being that the indices start 7 - * at 1 instead of at 0 and that C (program) is M (ref). 8 - * REFERENCE : Stoer and Bulirsch, Einfuhrung in die numerische 9 - * Mathematic, I, Heidelberger taschenbucher. 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12 - DIMENSION X(MXLIST),Y(MXLIST),Q(MXLIST),U(MXLIST),C(MXLIST) 13 - *** Initialise IFAIL to 0 (success). 14 - IFAIL=0 15 - *** Reject the trivial case. 16 - IF(N.LE.1)THEN 17 - PRINT *,' ###### SPLINE ERROR : Only ',N,' points on', 18 - - ' the spline while a minimum of 2 is required.' 19 - IFAIL=1 20 - RETURN 21 - ENDIF 22 - *** The X's should be all different and in strictly ascending order. 23 - DO 10 I=1,N-1 24 - IF(X(I).EQ.X(I+1))THEN 25 - PRINT *,' ###### SPLINE ERROR : Two ordinates are equal.' 26 - IFAIL=1 27 - RETURN 28 - ENDIF 29 - IF(X(I).GT.X(I+1))THEN 30 - PRINT *,' ###### SPLINE ERROR : The ordinates are not in', 31 - - ' strictly ascending order.' 32 - IFAIL=1 33 - RETURN 34 - ENDIF 35 - 10 CONTINUE 36 - *** Define 'boundary values' of ALFA and D. 37 - ALFA=0 38 - D=0 39 - *** Solve the set of linear equations determining the C's. 40 - Q(1)=-ALFA/2.0 41 - U(1)=D/2.0 42 - DO 20 K=2,N-1 43 - ALFA=(X(K+1)-X(K))/(X(K+1)-X(K-1)) 44 - BETA=1.0-ALFA 45 - D=6.0*((Y(K+1)-Y(K))/(X(K+1)-X(K))-(Y(K)-Y(K-1))/(X(K)-X(K-1)))/ 46 - - (X(K+1)-X(K-1)) 47 - P=BETA*Q(K-1)+2 48 - Q(K)=-ALFA/P 49 - U(K)=(D-BETA*U(K-1))/P 50 - 20 CONTINUE 51 - *** Set the C's starting from the last one. 52 - C(N)=0 53 - DO 30 K=N-1,1,-1 54 - C(K)=Q(K)*C(K+1)+U(K) 55 - 30 CONTINUE 56 - END 355 GARFIELD ================================================== P=ROUTINES D=SPLINE2 1 ============================ 0 + +DECK,SPLINE2. 1 - SUBROUTINE SPLIN2(X,Y,C,N,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SPLIN2 - Routine preparing a cubic spline interpolation through the 4 - * the points (X(I),Y(I)) I=1,N in double precision. 5 - * VARIABLES : Most of the variables are the same as in the reference, 6 - * the only major difference being that the indices start 7 - * at 1 instead of at 0 and that C (program) is M (ref). 8 - * REFERENCE : Stoer and Bulirsch, Einfuhrung in die numerische 9 - * Mathematic, I, Heidelberger taschenbucher. 10 - *----------------------------------------------------------------------- 11 - IMPLICIT DOUBLE PRECISION (A-H,O-Z) 12.- +SEQ,DIMENSIONS. 13 - DIMENSION X(MXLIST),Y(MXLIST),Q(MXLIST),U(MXLIST),C(MXLIST) 14 - *** Initialise IFAIL to 0 (success). 15 - IFAIL=0 16 - *** Reject the trivial case. 17 - IF(N.LE.1)THEN 18 - PRINT *,' ###### SPLIN2 ERROR : Only ',N,' points on', 19 - - ' the spline whereas a minimum of 2 is required.' 20 - IFAIL=1 21 - RETURN 22 - ENDIF 23 - *** The x's should be all different and in ascending order. 24 - DO 10 I=1,N-1 25 - IF(X(I).EQ.X(I+1))THEN 26 - C PRINT *,' ###### SPLIN2 ERROR : Two ordinates are equal.' 27 - IFAIL=1 28 - RETURN 29 - ENDIF 30 - IF(X(I).GT.X(I+1))THEN 31 - PRINT *,' ###### SPLIN2 ERROR : The ordinates are not in', 32 - - ' strictly ascending order.' 33 - IFAIL=1 1 355 P=ROUTINES D=SPLINE2 2 PAGE 445 34 - RETURN 35 - ENDIF 36 - 10 CONTINUE 37 - *** Define 'boundary values' of ALFA and D. 38 - ALFA=0 39 - D=0 40 - *** Solve the set of linear equations determining the C's. 41 - Q(1)=-ALFA/2.0 42 - U(1)=D/2.0 43 - DO 20 K=2,N-1 44 - ALFA=(X(K+1)-X(K))/(X(K+1)-X(K-1)) 45 - BETA=1.0-ALFA 46 - D=6.0*((Y(K+1)-Y(K))/(X(K+1)-X(K))-(Y(K)-Y(K-1))/(X(K)-X(K-1)))/ 47 - - (X(K+1)-X(K-1)) 48 - P=BETA*Q(K-1)+2 49 - Q(K)=-ALFA/P 50 - U(K)=(D-BETA*U(K-1))/P 51 - 20 CONTINUE 52 - *** Define the C's starting from the last one. 53 - C(N)=0 54 - DO 30 K=N-1,1,-1 55 - C(K)=Q(K)*C(K+1)+U(K) 56 - 30 CONTINUE 57 - END 356 GARFIELD ================================================== P=ROUTINES D=STRCAL 1 ============================ 0 + +DECK,STRCAL. 1 - SUBROUTINE STRCAL(INSTR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * STRCAL - Handles string procedure calls. 4 - * (Last changed on 21/ 1/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,ALGDATA. 9.- +SEQ,GLOBALS. 10.- +SEQ,PRINTPLOT. 11 - CHARACTER*(MXINCH) STRING,AUX1,AUX2,AUX3 12 - INTEGER INSTR,IFAIL,NARG,IPROC,NC,NC1,NC2,NC3,IFAIL1,IFAIL2, 13 - - IFAIL3,IFAIL4,IAUX,IF,IL,I,NOUT,ISEP,ISQ,IDQ,NWORD,I0,I1, 14 - - IMATCH,INEXT,INPCMX,IREF 15 - EXTERNAL INPCMX 16 - *** Assume that this will fail. 17 - IFAIL=1 18 - *** Some easy reference variables. 19 - NARG=INS(INSTR,3) 20 - IPROC=INS(INSTR,1) 21 - *** Locate one string inside another. 22 - IF(IPROC.EQ.-901)THEN 23 - * Check arguments. 24 - IF(NARG.NE.3.OR.ARGREF(3,1).GE.2.OR. 25 - - MODARG(1).NE.1.OR.MODARG(2).NE.1)THEN 26 - PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// 27 - - ' of arguments for STRING_INDEX.' 28 - RETURN 29 - ENDIF 30 - * Get strings from store. 31 - CALL STRBUF('READ',NINT(ARG(1)),STRING,NC1,IFAIL1) 32 - CALL STRBUF('READ',NINT(ARG(2)),AUX2,NC2,IFAIL2) 33 - * Clear previous use of result. 34 - CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) 35 - * And store result of operation. 36 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN 37 - ARG(3)=INDEX(STRING(1:NC1),AUX2(1:NC2)) 38 - MODARG(3)=2 39 - ELSE 40 - ARG(3)=-1 41 - MODARG(3)=2 42 - PRINT *,' !!!!!! STRCAL WARNING : Unable to fetch a'// 43 - - ' string for STRING_INDEX.' 44 - ENDIF 45 - *** Return a substring. 46 - ELSEIF(IPROC.EQ.-902)THEN 47 - * Check arguments. 48 - IF(NARG.NE.4.OR.ARGREF(4,1).GE.2.OR.MODARG(1).NE.1.OR. 49 - - MODARG(2).NE.2.OR.MODARG(3).NE.2)THEN 50 - PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// 51 - - ' of arguments for STRING_PORTION.' 52 - RETURN 53 - ENDIF 54 - * Get string from store. 55 - CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL1) 56 - * Clear previous use of result. 57 - CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 58 - * And store result of operation. 59 - IF(IFAIL1.NE.0)THEN 60 - IFAIL2=1 61 - ELSEIF((ARG(2).GT.NC.AND.ARG(3).GT.NC).OR. 62 - - (ARG(2).LT.1.AND.ARG(3).LT.1))THEN 63 - CALL STRBUF('STORE',IAUX,' ',0,IFAIL2) 64 - ARG(4)=REAL(IAUX) 65 - MODARG(4)=1 66 - ELSE 67 - IF=MAX(1,MIN(NC,NINT(ARG(2)))) 68 - IL=MAX(1,MIN(NC,NINT(ARG(3)))) 69 - IF(IL.GE.IF)THEN 70 - DO 100 I=IF,IL 71 - AUX1(I-IF+1:I-IF+1)=STRING(I:I) 72 - 100 CONTINUE 73 - ELSE 74 - DO 110 I=IF,IL,-1 75 - AUX1(IF-I+1:IF-I+1)=STRING(I:I) 76 - 110 CONTINUE 77 - ENDIF 78 - NC=ABS(IL-IF)+1 1 356 P=ROUTINES D=STRCAL 2 PAGE 446 79 - CALL STRBUF('STORE',IAUX,AUX1(1:NC),NC,IFAIL2) 80 - ARG(4)=REAL(IAUX) 81 - MODARG(4)=1 82 - ENDIF 83 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0) 84 - - PRINT *,' !!!!!! STRCAL WARNING : Unable to fetch or'// 85 - - ' store a string for STRING_PORTION.' 86 - *** Delete part of a string. 87 - ELSEIF(IPROC.EQ.-903)THEN 88 - * Check arguments. 89 - IF(NARG.NE.4.OR.ARGREF(4,1).GE.2.OR.MODARG(1).NE.1.OR. 90 - - MODARG(2).NE.2.OR.MODARG(3).NE.2)THEN 91 - PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// 92 - - ' of arguments for STRING_DELETE.' 93 - RETURN 94 - ENDIF 95 - * Get string from store. 96 - CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL1) 97 - * Clear previous use of result. 98 - CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 99 - * And store result of operation. 100 - IF(IFAIL1.EQ.0)THEN 101 - NOUT=0 102 - AUX1=' ' 103 - DO 120 I=1,NC 104 - IF(I.GE.MIN(NINT(ARG(2)),NINT(ARG(3))).AND. 105 - - I.LE.MAX(NINT(ARG(2)),NINT(ARG(3))))GOTO 120 106 - NOUT=NOUT+1 107 - AUX1(NOUT:NOUT)=STRING(I:I) 108 - 120 CONTINUE 109 - CALL STRBUF('STORE',IAUX,AUX1(1:(MAX(1,NC))),NC, 110 - - IFAIL2) 111 - ARG(4)=REAL(IAUX) 112 - MODARG(4)=1 113 - ELSE 114 - IFAIL2=1 115 - ENDIF 116 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0) 117 - - PRINT *,' !!!!!! STRCAL WARNING : Unable to fetch or'// 118 - - ' store a string for STRING_DELETE.' 119 - *** Convert a string to lower case. 120 - ELSEIF(IPROC.EQ.-904)THEN 121 - * Check arguments. 122 - IF(NARG.NE.1.OR.ARGREF(1,1).GE.2.OR.MODARG(1).NE.1)THEN 123 - PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// 124 - - ' of arguments for STRING_LOWER.' 125 - RETURN 126 - ENDIF 127 - * Get string from store. 128 - CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL1) 129 - * Clear previous use of result. 130 - CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) 131 - * Store result of operation. 132 - IF(IFAIL1.EQ.0)THEN 133 - CALL CUTOL(STRING(1:NC)) 134 - CALL STRBUF('STORE',IAUX,STRING(1:NC),NC,IFAIL2) 135 - ARG(1)=REAL(IAUX) 136 - MODARG(1)=1 137 - ELSE 138 - IFAIL2=0 139 - ENDIF 140 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0) 141 - - PRINT *,' !!!!!! STRCAL WARNING : Unable to fetch or'// 142 - - ' store a string for STRING_LOWER.' 143 - *** Convert a string to upper case. 144 - ELSEIF(IPROC.EQ.-905)THEN 145 - * Check arguments. 146 - IF(NARG.NE.1.OR.ARGREF(1,1).GE.2.OR.MODARG(1).NE.1)THEN 147 - PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// 148 - - ' of arguments for STRING_UPPER.' 149 - RETURN 150 - ENDIF 151 - * Get string from store. 152 - CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL1) 153 - * Clear previous use of result. 154 - CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) 155 - * Store result of operation. 156 - IF(IFAIL1.EQ.0)THEN 157 - CALL CLTOU(STRING(1:NC)) 158 - CALL STRBUF('STORE',IAUX,STRING(1:NC),NC,IFAIL2) 159 - ARG(1)=REAL(IAUX) 160 - MODARG(1)=1 161 - ELSE 162 - IFAIL2=0 163 - ENDIF 164 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0) 165 - - PRINT *,' !!!!!! STRCAL WARNING : Unable to fetch or'// 166 - - ' store a string for STRING_UPPER.' 167 - *** Number of words in a string. 168 - ELSEIF(IPROC.EQ.-906)THEN 169 - * Check arguments. 170 - IF(NARG.NE.2.OR.ARGREF(2,1).GE.2.OR.MODARG(1).NE.1)THEN 171 - PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// 172 - - ' of arguments for STRING_WORDS.' 173 - RETURN 174 - ENDIF 175 - * Get string from store. 176 - CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL1) 177 - * Clear previous use of result. 178 - CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) 179 - * Store result of operation. 180 - IF(IFAIL1.EQ.0)THEN 181 - ARG(2)=0 182 - MODARG(2)=2 183 - ISEP=1 184 - ISQ=0 1 356 P=ROUTINES D=STRCAL 3 PAGE 447 185 - IDQ=0 186 - DO 130 I=1,NC 187 - IF(STRING(I:I).EQ.''''.AND.IDQ.EQ.0)ISQ=1-ISQ 188 - IF(STRING(I:I).EQ.'"'.AND.ISQ.EQ.0)IDQ=1-IDQ 189 - IF(ISQ.EQ.0.AND.IDQ.EQ.0.AND. 190 - - INDEX(' :,=',STRING(I:I)).NE.0)THEN 191 - IF(ISEP.EQ.0)ARG(2)=ARG(2)+1 192 - ISEP=1 193 - ELSE 194 - ISEP=0 195 - ENDIF 196 - 130 CONTINUE 197 - IF(ISEP.EQ.0)ARG(2)=ARG(2)+1 198 - IF(ISQ.NE.0)PRINT *,' !!!!!! STRCAL WARNING: Odd'// 199 - - ' number of single quotes; one added at end.' 200 - IF(IDQ.NE.0)PRINT *,' !!!!!! STRCAL WARNING: Odd'// 201 - - ' number of double quotes; one added at end.' 202 - ELSE 203 - ARG(2)=-1 204 - MODARG(2)=2 205 - PRINT *,' !!!!!! STRCAL WARNING :'// 206 - - ' Unable to fetch a string for STRING_WORDS.' 207 - ENDIF 208 - *** Return a word from a string. 209 - ELSEIF(IPROC.EQ.-907)THEN 210 - * Check arguments. 211 - IF(NARG.NE.3.OR.ARGREF(3,1).GE.2.OR. 212 - - MODARG(1).NE.1.OR.MODARG(2).NE.2)THEN 213 - PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// 214 - - ' of arguments for STRING_WORD.' 215 - RETURN 216 - ENDIF 217 - * Get string from store. 218 - CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL1) 219 - * Clear previous use of result. 220 - CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) 221 - * Store result of operation. 222 - IF(IFAIL1.EQ.0)THEN 223 - ISEP=1 224 - ISQ=0 225 - IDQ=0 226 - I0=1 227 - AUX1=' ' 228 - NC1=0 229 - NWORD=0 230 - DO 140 I=1,NC 231 - IF(STRING(I:I).EQ.''''.AND.IDQ.EQ.0)ISQ=1-ISQ 232 - IF(STRING(I:I).EQ.'"'.AND.ISQ.EQ.0)IDQ=1-IDQ 233 - IF(ISQ.EQ.0.AND.IDQ.EQ.0.AND. 234 - - INDEX(' :,=',STRING(I:I)).NE.0)THEN 235 - IF(ISEP.EQ.0)NWORD=NWORD+1 236 - IF(NWORD.EQ.NINT(ARG(2)).AND.ISEP.EQ.0)THEN 237 - IF(INDEX('''"',STRING(I0:I0)).NE.0)I0=I0+1 238 - I1=I-1 239 - IF(INDEX('''"',STRING(I1:I1)).NE.0)I1=I1-1 240 - IF(I1.GE.I0.AND.I0.GE.1.AND.I1.GE.1.AND. 241 - - I0.LE.NC.AND.I1.LE.NC)THEN 242 - AUX1=STRING(I0:I1) 243 - NC1=I1-I0+1 244 - ELSE 245 - AUX1=' ' 246 - NC1=1 247 - ENDIF 248 - ENDIF 249 - ISEP=1 250 - ELSE 251 - IF(ISEP.EQ.1)I0=I 252 - ISEP=0 253 - ENDIF 254 - 140 CONTINUE 255 - IF(ISEP.EQ.0)NWORD=NWORD+1 256 - IF(NWORD.EQ.NINT(ARG(2)).AND.ISEP.EQ.0)THEN 257 - IF(INDEX('''"',STRING(I0:I0)).NE.0)I0=I0+1 258 - I1=NC 259 - IF(INDEX('''"',STRING(I1:I1)).NE.0)I1=I1-1 260 - IF(I1.GE.I0.AND.I0.GE.1.AND.I1.GE.1.AND. 261 - - I0.LE.NC.AND.I1.LE.NC)THEN 262 - AUX1=STRING(I0:I1) 263 - NC1=I1-I0+1 264 - ELSE 265 - AUX1=' ' 266 - NC1=1 267 - ENDIF 268 - ENDIF 269 - CALL STRBUF('STORE',IAUX,AUX1(1:NC1),NC1,IFAIL2) 270 - ARG(3)=REAL(IAUX) 271 - MODARG(3)=1 272 - ELSE 273 - IFAIL2=0 274 - ENDIF 275 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0) 276 - - PRINT *,' !!!!!! STRCAL WARNING : Unable to fetch or'// 277 - - ' store a string for STRING_WORD.' 278 - *** See whether two strings match. 279 - ELSEIF(IPROC.EQ.-908)THEN 280 - * Check arguments. 281 - IF(NARG.NE.3.OR.ARGREF(3,1).GE.2.OR. 282 - - MODARG(1).NE.1.OR.MODARG(2).NE.1)THEN 283 - PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// 284 - - ' of arguments for STRING_MATCH.' 285 - RETURN 286 - ENDIF 287 - * Get strings from store. 288 - CALL STRBUF('READ',NINT(ARG(1)),STRING,NC1,IFAIL1) 289 - CALL STRBUF('READ',NINT(ARG(2)),AUX2,NC2,IFAIL2) 290 - * Clear previous use of result. 1 356 P=ROUTINES D=STRCAL 4 PAGE 448 291 - CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) 292 - * Result of opetration. 293 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN 294 - IMATCH=INPCMX(STRING(1:NC1),AUX2(1:NC2)) 295 - IF(IMATCH.NE.0)THEN 296 - ARG(3)=1 297 - ELSE 298 - ARG(3)=0 299 - ENDIF 300 - MODARG(3)=3 301 - ELSE 302 - PRINT *,' !!!!!! STRCAL WARNING : Unable to fetch'// 303 - - ' a string for STRING_MATCH.' 304 - ENDIF 305 - *** Replace parts of a string. 306 - ELSEIF(IPROC.EQ.-909)THEN 307 - * Check arguments. 308 - IF(NARG.NE.3.OR.ARGREF(4,1).GE.2.OR.MODARG(1).NE.1.OR. 309 - - MODARG(2).NE.1.OR.MODARG(3).NE.1)THEN 310 - PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// 311 - - ' of arguments for STRING_REPLACE.' 312 - RETURN 313 - ENDIF 314 - * Get string from store. 315 - CALL STRBUF('READ',NINT(ARG(1)),STRING,NC1,IFAIL1) 316 - CALL STRBUF('READ',NINT(ARG(2)),AUX2, NC2,IFAIL2) 317 - CALL STRBUF('READ',NINT(ARG(3)),AUX3, NC3,IFAIL3) 318 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0)THEN 319 - PRINT *,' !!!!!! STRCAL WARNING : Unable to retrieve'// 320 - - ' an argument of STRING_REPLACE; not executed.' 321 - RETURN 322 - ENDIF 323 - * Start. 324 - INEXT=1 325 - NOUT=0 326 - * Replace. 327 - DO 150 I=1,NC1 328 - IF(I.LT.INEXT)GOTO 150 329 - IF(STRING(I:MIN(NC1,I+NC2-1)).EQ.AUX2(1:NC2).AND. 330 - - I+NC2-1.LE.NC1)THEN 331 - IF(NOUT+NC3.GT.LEN(AUX1))THEN 332 - PRINT *,' !!!!!! STRCAL WARNING : String grows'// 333 - - ' too much while replacing characters;'// 334 - - ' string not changed.' 335 - RETURN 336 - ENDIF 337 - AUX1(NOUT+1:NOUT+NC3)=AUX3(1:NC3) 338 - NOUT=NOUT+NC3 339 - INEXT=I+NC2 340 - ELSE 341 - IF(NOUT+1.GT.LEN(AUX1))THEN 342 - PRINT *,' !!!!!! STRCAL WARNING : String grows'// 343 - - ' too much while replacing characters;'// 344 - - ' string not changed.' 345 - RETURN 346 - ENDIF 347 - AUX1(NOUT+1:NOUT+1)=STRING(I:I) 348 - NOUT=NOUT+1 349 - INEXT=I+1 350 - ENDIF 351 - 150 CONTINUE 352 - * Clear previous use of result. 353 - CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) 354 - * And store result of operation. 355 - IF(IFAIL1.EQ.0)THEN 356 - CALL STRBUF('STORE',IAUX,AUX1(1:NOUT),NOUT,IFAIL4) 357 - ARG(1)=REAL(IAUX) 358 - MODARG(1)=1 359 - IF(IFAIL4.NE.0)THEN 360 - PRINT *,' !!!!!! STRCAL WARNING : Unable to'// 361 - - ' store the processed string; original'// 362 - - ' string lost.' 363 - RETURN 364 - ENDIF 365 - ENDIF 366 - *** List the string buffer. 367 - ELSEIF(IPROC.EQ.-910)THEN 368 - IF(NARG.NE.0)PRINT *,' !!!!!! STRCAL WARNING : The'// 369 - - ' LIST_STRINGS procedure has no arguments; ignored.' 370 - CALL STRBUF('DUMP',IREF,' ',1,IFAIL) 371 - *** Length of a string. 372 - ELSEIF(IPROC.EQ.-911)THEN 373 - * Check arguments. 374 - IF(NARG.NE.2.OR.ARGREF(2,1).GE.2.OR.MODARG(1).NE.1)THEN 375 - PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// 376 - - ' of arguments for STRING_LENGTH.' 377 - RETURN 378 - ENDIF 379 - * Get string from store. 380 - CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL1) 381 - * Clear previous use of result. 382 - CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) 383 - * Store result of operation. 384 - IF(IFAIL1.EQ.0)THEN 385 - ARG(2)=REAL(NC) 386 - MODARG(2)=2 387 - ELSE 388 - ARG(2)=-1 389 - MODARG(2)=2 390 - PRINT *,' !!!!!! STRCAL WARNING :'// 391 - - ' Unable to fetch a string for STRING_LENGTH.' 392 - ENDIF 393 - *** Delete strings. 394 - ELSEIF(IPROC.EQ.-912)THEN 395 - * Without arguments, delete all strings. 396 - IF(NARG.LT.1)THEN 1 356 P=ROUTINES D=STRCAL 5 PAGE 449 397 - DO 10 I=1,NGLB 398 - IF(GLBMOD(I).EQ.1)THEN 399 - CALL STRBUF('DELETE',NINT(GLBVAL(I)),' ',1,IFAIL1) 400 - GLBVAL(I)=0 401 - GLBMOD(I)=0 402 - ENDIF 403 - 10 CONTINUE 404 - * Delete all the matrices in the arguments. 405 - ELSE 406 - DO 20 I=1,NARG 407 - IF(MODARG(I).NE.1)THEN 408 - PRINT *,' !!!!!! STRCAL WARNING : Argument ',I, 409 - - ' is not a string; not deleted.' 410 - GOTO 20 411 - ENDIF 412 - CALL STRBUF('DELETE',NINT(ARG(I)),' ',1,IFAIL1) 413 - ARG(I)=0 414 - MODARG(I)=0 415 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! STRCAL WARNING :'// 416 - - ' Deleting a string failed.' 417 - 20 CONTINUE 418 - ENDIF 419 - *** Other procedures are not known. 420 - ELSE 421 - PRINT *,' !!!!!! STRCAL WARNING : Unknown procedure code'// 422 - - ' received.' 423 - RETURN 424 - ENDIF 425 - *** Things worked fine. 426 - IFAIL=0 427 - END 357 GARFIELD ================================================== P=ROUTINES D=STRBUF 1 ============================ 0 + +DECK,STRBUF. 1 - SUBROUTINE STRBUF(COMM,IREF,STRING,NC,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * STRBUF - General purpose dynamical string store. 4 - * (Last changed on 6/11/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,GLOBALS. 10 - INTEGER MXSTRL,MXNSTR 11 - PARAMETER (MXSTRL=20000,MXNSTR=1000) 12 - CHARACTER*(*) STRING,COMM 13 - CHARACTER*(MXSTRL) BUFFER 14 - CHARACTER*10 NAME 15 - INTEGER IREF,IREFL,NC,REF(3,MXNSTR),NBUF,ISTART,I,J,IFAIL,NOLD 16 - LOGICAL ACTIVE(MXNSTR) 0 17-+ +SELF,IF=SAVE. 18 - SAVE BUFFER,REF,NBUF,ISTART,IREFL,ACTIVE 0 19-+ +SELF. 20 - DATA ISTART,NBUF,IREFL /1,0,1/ 21 - *** Identify the routine if requested. 22 - IF(LIDENT)PRINT *,' /// ROUTINE STRBUF ///' 23 - *** If requested, store the string. 24 - IF(COMM.EQ.'STORE')THEN 25 - * Garbage collection if there is no more space. 26 - IF(ISTART+NC-1.GT.MXSTRL.OR.NBUF+1.GT.MXNSTR)THEN 27 - * Inform in case debugging is requested. 28 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ STRBUF DEBUG :'', 29 - - '' Garbage collection to make room for a new'', 30 - - '' string.''/26X,''Free storage: '',I5, 31 - - '', Needed: '',I5/26X,''Strings in store: '',I5, 32 - - '', Available: '',I5)') 33 - - MXSTRL-ISTART+1,NC,NBUF,MXNSTR 34 - * Reset the start pointer, string number pointer etc. 35 - ISTART=1 36 - NOLD=NBUF 37 - NBUF=0 38 - * Loop over the strings in store, skipping those that are dropped. 39 - DO 10 I=1,NOLD 40 - IF(.NOT.ACTIVE(I))GOTO 10 41 - NBUF=NBUF+1 42 - IF(REF(2,I).GT.0)THEN 43 - DO 30 J=1,REF(2,I) 44 - BUFFER(ISTART+J-1:ISTART+J-1)= 45 - - BUFFER(REF(1,I)+J-1:REF(1,I)+J-1) 46 - 30 CONTINUE 47 - ENDIF 48 - REF(1,NBUF)=ISTART 49 - REF(2,NBUF)=REF(2,I) 50 - REF(3,NBUF)=REF(3,I) 51 - ISTART=ISTART+REF(2,NBUF) 52 - ACTIVE(NBUF)=.TRUE. 53 - 10 CONTINUE 54 - * Check the amount of free storage again. 55 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ STRBUF DEBUG :'', 56 - - '' Free storage after garbage collect: '',I5/ 57 - - 26X,''Number of strings in use: '',I5)') 58 - - MXSTRL-ISTART+1,NBUF 59 - IF(ISTART+NC-1.GT.MXSTRL.OR.NBUF+1.GT.MXNSTR)THEN 60 - PRINT *,' ###### STRBUF WARNING : No room to'// 61 - - ' store your string; delete some strings'// 62 - - ' or increase MXSTRL, MXNSTR and recompile.' 63 - IFAIL=1 64 - RETURN 65 - ENDIF 66 - ENDIF 67 - * Store the new string. 68 - NBUF=NBUF+1 69 - IF(NC.GT.0)BUFFER(ISTART:ISTART+NC-1)=STRING(1:NC) 1 357 P=ROUTINES D=STRBUF 2 PAGE 450 70 - IREF=IREFL 71 - IREFL=IREFL+1 72 - REF(1,NBUF)=ISTART 73 - REF(2,NBUF)=NC 74 - REF(3,NBUF)=IREF 75 - ACTIVE(NBUF)=.TRUE. 76 - ISTART=ISTART+NC 77 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ STRBUF DEBUG :'', 78 - - '' Stored "'',A,''"''/26X,''Reference='',I5, 79 - - '', Start='',I5,'', Record='',I5)') 80 - - STRING(1:NC),IREF,REF(1,NBUF),NBUF 81 - IFAIL=0 82 - *** Read an existing string. 83 - ELSEIF(COMM.EQ.'READ')THEN 84 - DO 100 I=1,NBUF 85 - IF(REF(3,I).NE.IREF)GOTO 100 86 - IF(.NOT.ACTIVE(I))PRINT *,' !!!!!! STRBUF WARNING :'// 87 - - ' The string has been deleted but is still in store.' 88 - IF(REF(2,I).GT.LEN(STRING))PRINT *,' !!!!!! STRBUF'// 89 - - ' WARNING : String longer than receiving string'// 90 - - ' length; truncated.' 91 - IF(REF(2,I).GT.0)THEN 92 - STRING=BUFFER(REF(1,I):REF(1,I)+REF(2,I)-1) 93 - ELSE 94 - STRING=' ' 95 - ENDIF 96 - NC=MIN(REF(2,I),LEN(STRING)) 97 - IFAIL=0 98 - RETURN 99 - 100 CONTINUE 100 - PRINT *,' !!!!!! STRBUF WARNING : The string you ask for'// 101 - - ' is not in store.' 102 - NC=20 103 - STRING='< string not found >' 104 - IFAIL=1 105 - *** Delete the string. 106 - ELSEIF(COMM.EQ.'DELETE')THEN 107 - DO 200 I=1,NBUF 108 - IF(REF(3,I).NE.IREF)GOTO 200 109 - ACTIVE(I)=.FALSE. 110 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ STRBUF DEBUG :'', 111 - - '' Deleted string with reference '',I5)') IREF 112 - IFAIL=0 113 - RETURN 114 - 200 CONTINUE 115 - PRINT *,' !!!!!! STRBUF WARNING : The string you ask for'// 116 - - ' is not in store.' 117 - IFAIL=1 118 - *** Dump the entire contents. 119 - ELSEIF(COMM.EQ.'DUMP')THEN 120 - WRITE(LUNOUT,'(/'' CURRENTLY KNOWN STRINGS:''// 121 - - '' No Start NC Ref Global String'')') 122 - DO 300 I=1,NBUF 123 - NAME='< none >' 124 - DO 710 J=1,NGLB 125 - IF(GLBMOD(J).EQ.1.AND.NINT(GLBVAL(J)).EQ.REF(3,I)) 126 - - NAME=GLBVAR(J) 127 - 710 CONTINUE 128 - IF(.NOT.ACTIVE(I))THEN 129 - WRITE(LUNOUT,'(4(1X,I5),1X,A10,1X,A)') I,REF(1,I), 130 - - REF(2,I),REF(3,I),NAME,'(deleted)' 131 - ELSE 132 - WRITE(LUNOUT,'(4(1X,I5),1X,A10,1X,A)') I,REF(1,I), 133 - - REF(2,I),REF(3,I),NAME, 134 - - BUFFER(REF(1,I):REF(1,I)+REF(2,I)-1) 135 - ENDIF 136 - 300 CONTINUE 137 - IFAIL=0 138 - WRITE(LUNOUT,'(/'' Total of '',I3,'' strings.''/)') NBUF 139 - *** Anything else is not valid. 140 - ELSE 141 - PRINT *,' ###### STRBUF ERROR : Unknown command ',COMM, 142 - - ' received.' 143 - IFAIL=1 144 - ENDIF 145 - END 358 GARFIELD ================================================== P=ROUTINES D=STRSAV 1 ============================ 0 + +DECK,STRSAV. 1 - SUBROUTINE STRSAV(VAL,NAME,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * STRSAV - Assigns a string to a global variable. 4 - * (Last changed on 31/ 8/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GLOBALS. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*(*) VAL,NAME 11 - INTEGER IFAIL,JVAR,I,IFAIL1,IREF 12 - *** Tracing and debugging output. 13 - IF(LIDENT)PRINT *,' /// ROUTINE STRSAV ///' 14 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ STRSAV WARNING : Storing '', 15 - - A,'' as '',A)') VAL,NAME 16 - *** Initial failure flag setting. 17 - IFAIL=1 18 - *** Scan the list of global variables. 19 - JVAR=0 20 - DO 10 I=1,NGLB 21 - IF(GLBVAR(I).EQ.NAME)JVAR=I 22 - 10 CONTINUE 23 - *** If it didn't exist, create a new global ... 24 - IF(JVAR.EQ.0)THEN 25 - * if there still is space, 26 - IF(NGLB.LT.MXVAR)THEN 1 358 P=ROUTINES D=STRSAV 2 PAGE 451 27 - NGLB=NGLB+1 28 - GLBVAR(NGLB)=NAME 29 - JVAR=NGLB 30 - * otherwise issue a warning. 31 - ELSE 32 - PRINT *,' !!!!!! STRSAV WARNING : No global variable'// 33 - - ' space left for ',NAME,'; string not saved.' 34 - RETURN 35 - ENDIF 36 - *** Otherwise re-use an existing global. 37 - ELSE 38 - CALL ALGREU(NINT(GLBVAL(JVAR)),GLBMOD(JVAR),0) 39 - ENDIF 40 - *** Assign the string to the global. 41 - CALL STRBUF('STORE',IREF,VAL,LEN(VAL),IFAIL1) 42 - IF(IFAIL1.NE.0)THEN 43 - PRINT *,' !!!!!! STRSAV WARNING : Unable to store the'// 44 - - ' string; global variable not assigned a value.' 45 - RETURN 46 - ENDIF 47 - GLBVAL(JVAR)=IREF 48 - GLBMOD(JVAR)=1 49 - *** Things seem to have worked. 50 - IFAIL=0 51 - END 359 GARFIELD ================================================== P=ROUTINES D=TIMLOG 1 ============================ 0 + +DECK,TIMLOG. 1 - SUBROUTINE TIMLOG(NAME) 2 - *----------------------------------------------------------------------- 3 - * TIMLOG - Routine accumulating data on CPU-time usage and printing 4 - * its data when called with an empty name. 5 - * VARIABLES : CPU : CPU time used since previous timing. 6 - * TIME : Vector containing the cpu times used. 7 - * NAME : Description of the step just completed. 8 - * LIST : List of the above descriptions. 9 - * ICOUNT : Counts the number of names entered. 10 - *----------------------------------------------------------------------- 11 - CHARACTER*(*) NAME 12 - CHARACTER*40 LIST(100) 0 13-+ +SELF,IF=-VECTOR,-CMS. 14 - INTEGER TIME(100) 0 15-+ +SELF,IF=VECTOR,IF=CMS. 16 - DOUBLE PRECISION TVEC(4),TLAST(4) 17 - INTEGER TIME(4,100) 0 18-+ +SELF,IF=SAVE. 19 - SAVE LIST,TIME,ICOUNT 0 20-+ +SELF. 21 - *** Initialise ICOUNT. 22 - DATA ICOUNT/0/ 23 - *** If the input is all blank, print the LIST and TIME vectors. 24 - IF(NAME(1:1).EQ.' ')THEN 25 - WRITE(*,'(''1'')') 26 - IF(ICOUNT.EQ.0)THEN 27 - PRINT *,' No steps have been executed.' 28 - RETURN 29 - ENDIF 30 - PRINT *,' CPU time usage for some selected steps:' 31 - PRINT *,' =======================================' 32 - PRINT *,' ' 0 33-+ +SELF,IF=-VECTOR,-CMS. 34 - PRINT *,' Description of the step '// 35 - - ' CPU time used' 36 - PRINT *,' ' 37 - DO 10 J=1,MIN(ICOUNT,100) 38 - PRINT '(2X,A40,I14)',LIST(J),TIME(J) 39 - 10 CONTINUE 0 40-+ +SELF,IF=VECTOR,IF=CMS. 41 - PRINT *,' Description of the step '// 42 - - ' CPU time used % Vector' 43 - PRINT *,' ' 44 - DO J=1,MIN(ICOUNT,100) 45 - IF(TIME(3,J).GT.0)THEN 46 - IVFRAC=INT(100.0*REAL(TIME(4,J))/REAL(TIME(3,J))) 47 - ELSE 48 - IVFRAC=0 49 - ENDIF 50 - PRINT '(2X,A40,I14,I12)',LIST(J),TIME(3,J),IVFRAC 51 - ENDDO 0 52-+ +SELF. 53 - *** Otherwise store the information obtained. 54 - ELSEIF(ICOUNT.LT.100)THEN 55 - ICOUNT=ICOUNT+1 56 - LIST(ICOUNT)=NAME 0 57-+ +SELF,IF=-VECTOR,-CMS. 58 - CALL TIMED(CPU) 59 - TIME(ICOUNT)=INT(1000.0*CPU) 0 60-+ +SELF,IF=VECTOR,IF=CMS. 61 - CALL VCLOC(TVEC) 62 - IF(ICOUNT.GE.1)THEN 63 - DO I=1,4 64 - TIME(I,ICOUNT)=INT(TVEC(I)-TLAST(I)) 65 - ENDDO 66 - ELSE 67 - TIME(I,ICOUNT)=INT(TVEC(I)) 68 - ENDIF 1 359 P=ROUTINES D=TIMLOG 2 PAGE 452 69 - DO I=1,4 70 - TLAST(I)=TVEC(I) 71 - ENDDO 0 72-+ +SELF. 73 - *** Print a warning if 100 items have been stored. 74 - ELSEIF(ICOUNT.EQ.100)THEN 75 - ICOUNT=101 76 - PRINT *,' !!!!!! TIMLOG WARNING : 100 Items have been'// 77 - - ' stored ; no further CPU time registration.' 78 - ENDIF 79 - END 360 GARFIELD ================================================== P=ROUTINES D=UNITS 1 ============================ 0 + +DECK,UNITS. 1 - SUBROUTINE UNITS(XIN,UIN,XOUT,UOUT,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * UNITS - Converts units. 4 - * (Last changed on 29/ 3/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - REAL XIN,XOUT 8 - CHARACTER*(*) UIN,UOUT 9 - INTEGER IFAIL,INPCMX 10 - EXTERNAL INPCMX 11 - *** Preset the output and failure flag. 12 - XOUT=0 13 - IFAIL=1 14 - *** If this is a pressure unit. 15 - IF(INPCMX(UIN,'ATM#OSPHERE')+INPCMX(UIN,'BAR')+ 16 - - INPCMX(UIN,'MBAR')+INPCMX(UIN,'M#ILLI-BAR')+ 17 - - INPCMX(UIN,'TORR#ICELLI')+INPCMX(UIN,'MM-HG')+ 18 - - INPCMX(UIN,'INCH-HG')+INPCMX(UIN,'PA#SCAL')+ 19 - - INPCMX(UIN,'HPA#SCAL')+INPCMX(UIN,'H#ECTO-PA#SCAL')+ 20 - - INPCMX(UIN,'N/M2').NE.0)THEN 21 - * Convert all incoming units to atmospheres. 22 - IF(INPCMX(UIN,'ATM#OSPHERE').NE.0)THEN 23 - XOUT=XIN/1 24 - ELSEIF(INPCMX(UIN,'BAR').NE.0)THEN 25 - XOUT=XIN/1.01325 26 - ELSEIF(INPCMX(UIN,'TORR#ICELLI')+ 27 - - INPCMX(UIN,'MM-HG').NE.0)THEN 28 - XOUT=XIN/760 29 - ELSEIF(INPCMX(UIN,'INCH-HG').NE.0)THEN 30 - XOUT=XIN/29.9213 31 - ELSEIF(INPCMX(UIN,'PA#SCAL')+INPCMX(UIN,'N/M2').NE.0)THEN 32 - XOUT=XIN/101325 33 - ELSEIF(INPCMX(UIN,'HPA#SCAL')+ 34 - - INPCMX(UIN,'H#ECTO-PA#SCAL')+ 35 - - INPCMX(UIN,'MBAR')+ 36 - - INPCMX(UIN,'M#ILLI-BAR').NE.0)THEN 37 - XOUT=XIN/1013.25 38 - ELSE 39 - PRINT *,' !!!!!! UNITS WARNING : Incoming unit ', 40 - - UIN,' not recognised.' 41 - XOUT=0 42 - IFAIL=1 43 - RETURN 44 - ENDIF 45 - * Convert atmospheres to the desired unit. 46 - IF(INPCMX(UOUT,'ATM#OSPHERE').NE.0)THEN 47 - XOUT=XOUT*1 48 - ELSEIF(INPCMX(UOUT,'BAR').NE.0)THEN 49 - XOUT=XOUT*1.01325 50 - ELSEIF(INPCMX(UOUT,'TORR#ICELLI')+ 51 - - INPCMX(UOUT,'MM-HG').NE.0)THEN 52 - XOUT=XOUT*760 53 - ELSEIF(INPCMX(UOUT,'INCH-HG').NE.0)THEN 54 - XOUT=XOUT*29.9213 55 - ELSEIF(INPCMX(UOUT,'PA#SCAL')+INPCMX(UOUT,'N/M2').NE.0)THEN 56 - XOUT=XOUT*101325 57 - ELSEIF(INPCMX(UOUT,'HPA#SCAL')+ 58 - - INPCMX(UOUT,'H#ECTO-PA#SCAL')+ 59 - - INPCMX(UOUT,'MBAR')+ 60 - - INPCMX(UOUT,'M#ILLI-BAR').NE.0)THEN 61 - XOUT=XOUT*1013.25 62 - ELSE 63 - PRINT *,' !!!!!! UNITS WARNING : Unit mismatch, ', 64 - - UIN,' is a pressure while ',UOUT,' is not.' 65 - XOUT=0 66 - IFAIL=1 67 - RETURN 68 - ENDIF 69 - *** Temperature units. 70 - ELSEIF(INPCMX(UIN,'K#ELVIN')+INPCMX(UIN,'C#ELSIUS')+ 71 - - INPCMX(UIN,'F#AHRENHEIT')+INPCMX(UIN,'RA#NKINE')+ 72 - - INPCMX(UIN,'RE#AUMUR').NE.0)THEN 73 - * Convert all incoming units to Celsius. 74 - IF(INPCMX(UIN,'K#ELVIN').NE.0)THEN 75 - XOUT=XIN-273.15 76 - ELSEIF(INPCMX(UIN,'C#ELSIUS').NE.0)THEN 77 - XOUT=XIN 78 - ELSEIF(INPCMX(UIN,'F#AHRENHEIT').NE.0)THEN 79 - XOUT=(XIN-32.0)*5.0/9.0 80 - ELSEIF(INPCMX(UIN,'RA#NKINE').NE.0)THEN 81 - XOUT=(XIN-32.0-459.67)*5.0/9.0 82 - ELSEIF(INPCMX(UIN,'RE#AUMUR').NE.0)THEN 83 - XOUT=XIN*5.0/4.0 84 - ELSE 85 - PRINT *,' !!!!!! UNITS WARNING : Incoming unit ', 86 - - UIN,' not recognised.' 87 - XOUT=0 88 - IFAIL=1 89 - RETURN 90 - ENDIF 1 360 P=ROUTINES D=UNITS 2 PAGE 453 91 - * Convert Celsius to the desired unit. 92 - IF(INPCMX(UOUT,'K#ELVIN').NE.0)THEN 93 - XOUT=XOUT+273.15 94 - ELSEIF(INPCMX(UOUT,'C#ELSIUS').NE.0)THEN 95 - XOUT=XOUT 96 - ELSEIF(INPCMX(UOUT,'F#AHRENHEIT').NE.0)THEN 97 - XOUT=XOUT*9.0/5.0+32.0 98 - ELSEIF(INPCMX(UOUT,'RA#NKINE').NE.0)THEN 99 - XOUT=XOUT*9.0/5.0+32.0+459.67 100 - ELSEIF(INPCMX(UOUT,'RE#AUMUR').NE.0)THEN 101 - XOUT=XOUT*4.0/5.0 102 - ELSE 103 - PRINT *,' !!!!!! UNITS WARNING : Unit mismatch, ', 104 - - UIN,' is a temperature while ',UOUT,' is not.' 105 - XOUT=0 106 - IFAIL=1 107 - RETURN 108 - ENDIF 109 - *** Other units. 110 - ELSE 111 - PRINT *,' !!!!!! UNITS WARNING : Incoming unit ',UIN, 112 - - ' is not known.' 113 - XOUT=0 114 - IFAIL=1 115 - RETURN 116 - ENDIF 117 - *** Seems to have worked. 118 - IFAIL=0 119 - END 361 GARFIELD ================================================== P=ROUTINES D=VMCMS 1 ============================ 0 + +DECK,VMCMS,IF=CMS. 1 - SUBROUTINE VMCMS(COMMAN,IRC) 2 - *----------------------------------------------------------------------- 3 - * VMCMS - Replacement for the CERN library routine VMCMS (Z305) using 4 - * the assembly language routine below. 5 - *----------------------------------------------------------------------- 6 - CHARACTER*(*) COMMAN 7 - CALL SUBSET(COMMAN,LEN(COMMAN),IRC) 8 - END 362 GARFIELD ================================================== P=ROUTINES D=SUBSET 1 ============================ 0 + +DECK,SUBSET,T=ASSEMBLER,IF=CMS. 1 - SUBSET CSECT 2 - * 3 - * CALL SUBSET(command,len,iretcode), or just CALL SUBSET. 4 - * 5 - * This routine executes a system command (CP or CMS) in SUBSET mode. 6 - * If a command is provided, that command is executed in SUBSET mode. 7 - * If the 'len' of the command is non-positive in a FORTVS program, 8 - * then the implicit length of the 'command' character value is used. 9 - * The return code from the command is stored in 'iretcode'. 10 - * If no args, CMS SUBSET is entered and any number of commands can be 11 - * entered at the terminal; the program is resumed by entering 'RETURN'. 12 - * 13 - * CMS SUBSET mode documentation taken from CMS routine DMSINT. 14 - * 15 - * The SUBSET technique is used so that: 16 - * 1) Commands which otherwise would overlay a program are rejected. 17 - * 2) Commands may be entered as normal without CP or EXEC prefix, 18 - * assuming of course that IMPCP and IMPEX are on. 19 - * 3) Tokenising the command line is left to the system. 20 - * 21 - * Written L.S.Lowe, Birmingham, 1982. 472-1301 ex 2428. 22 - * Updated L.S.Lowe, Jul 83, in order to allow the FORTVS release 3 23 - * extended argument list to be used if the given command length is <=0. 24 - * Updated S.O'Neale, Apr 85, to accept the argument passing of the 25 - * Siemens Fortran 77 compiler. Patchy selection of FORTVS or FUJITSU 26 - * is required. 27 - * 28 - USING *,R12 29 - SAVE (14,12),,* SAVE REGS 30 - LR R12,R15 LOAD BASE REG 31 - LTR R1,R1 TEST FOR PARMS 32 - BZ SUBENTER NO - ENTER CMS SUBSET 33 - LM R4,R6,0(R1) YES - GET USER'S PARMS 34 - ST R4,ATTNLIST+12 STORE BUFFER ADDRESS 35 - ICM R7,15,0(R5) GET AND TEST LENGTH 36 - BP SUBLENCH JUMP IF POSITIVE 37 - LR R15,R1 COPY ARG LIST POINTER 38 - SH R15,=H'4' POINT TO WORD BEFORE ARG LIST 39 - CLC 0(4,R15),=F'12' VALIDATE FORTVS EXTENDED PARMLIST 40 - BNE SUBARGER JUMP IF ERROR 41 - L R5,12(,R1) OK - GET FIRST ARG LENGTH ADDRESS 42 - L R7,0(,R5) LOAD FIRST ARG LENGTH 43 - SUBLENCH LTR R7,R7 TEST LENGTH 44 - BNP SUBARGER ERROR IF NON-POSITIVE 45 - CH R7,=H'255' TEST LENGTH 46 - BH SUBARGER ERROR IF TOO LONG 47 - STC R7,ATTNLIST+12 STORE LENGTH IN STACK LIST 48 - LA R1,ATTNLIST POINT TO STACK LIST 49 - SVC 202 STACK THE LINE LIFO 50 - DC AL4(*+4) POSSIBLE ERROR RETURN 51 - LA R1,SUBRLIST POINT TO SUBSET & RETURN PLIST 52 - SVC 202 EXECUTE ONE COMMAND IN CMS SUBSET 53 - DC AL4(*+4) POSSIBLE ERROR RETURN 54 - B SUBDONE JUMP TO STORE RETCODE 55 - SUBARGER WRTERM 'SUBSET: invalid argument list' 56 - SR R15,R15 FOR SYNTAX ERROR 57 - BCTR R15,0 SET RETURN CODE -1 58 - SUBDONE DS 0H 59 - ST R15,0(,R6) STORE RETURN CODE FOR USER 60 - LTR R15,R15 TEST RETURN CODE 61 - BZ *+8 SKIP IF ZERO 1 362 P=ROUTINES D=SUBSET 2 PAGE 454 62 - LA R15,4 NON-ZERO - SET UP A RETURN 1 63 - B SUBEXIT AND JUMP TO EXIT 64 - SUBENTER LA R1,SUBPLIST POINT TO SUBSET PLIST 65 - SVC 202 ENTER CMS SUBSET MODE 66 - DC AL4(*+4) POSSIBLE ERROR RETURN 67 - SR R15,R15 CLEAR RETURN CODE 68 - SUBEXIT RETURN (14,12),T,RC=(15) RETURN TO CALLER 69 - * 70 - DC 0F'0' 71 - ATTNLIST DC CL8'ATTN',CL4'LIFO',A(1) 72 - SUBPLIST DC CL8'SUBSET',8X'FF' 73 - SUBRLIST DC CL8'SUBSET',CL8'(RETURN)',8X'FF' 74 - REGEQU 75 - END 363 GARFIELD ================================================== P=ROUTINES D=VMNAME 1 ============================ 0 + +DECK,VMNAME,IF=CMS. 1 - SUBROUTINE VMNAME(FILE,NCFILE,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * VMNAME - Verifies the format of a VM file name. 4 - * (Last changed on 4/ 4/94.) 5 - *----------------------------------------------------------------------- 6 - CHARACTER*(*) FILE 7 - CHARACTER*20 WRONG 8 - *** Initialise. 9 - NCWR=0 10 - WRONG=' ' 11 - IFAIL=0 12 - NCSEG=0 13 - *** Scan for dots, remove multiple blanks and spot illegal characters. 14 - J=0 15 - DO 10 I=1,NCFILE 16 - * Replace dots by blanks. 17 - IF(FILE(I:I).EQ.'.')FILE(I:I)=' ' 18 - * No multiple blanks. 19 - IF(FILE(I:I).NE.' '.OR. 20 - - (I.GT.1.AND.FILE(MAX(1,I-1):MAX(1,I-1)).NE.' '))J=J+1 21 - * Straight copy. 22 - FILE(J:J)=FILE(I:I) 23 - * Illegal characters. 24 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789$_ ', 25 - - FILE(J:J)).NE.0)GOTO 10 26 - NCWR=NCWR+1 27 - IF(NCWR.LE.LEN(WRONG))WRONG(NCWR:NCWR)=FILE(J:J) 28 - 10 CONTINUE 29 - * Update string length. 30 - IF(FILE(J:J).NE.' ')THEN 31 - NCFILE=J 32 - ELSE 33 - NCFILE=MAX(1,J-1) 34 - ENDIF 35 - * Stop of any were found. 36 - IF(NCWR.GT.0)THEN 37 - PRINT *,' !!!!!! VMNAME WARNING : Invalid characters "'// 38 - - WRONG(1:MIN(20,NCWR))//'" found in file name "', 39 - - FILE(1:NCFILE),'".' 40 - IFAIL=1 41 - RETURN 42 - ENDIF 43 - *** Stop if the string is entirely blank. 44 - IF(FILE(1:NCFILE).EQ.' ')THEN 45 - PRINT *,' !!!!!! VMNAME WARNING : The file name is'// 46 - - ' empty.' 47 - IFAIL=1 48 - RETURN 49 - ENDIF 50 - *** Count segments and verify each segment, begin by dissecting. 51 - IFN0=1 52 - IFN1=INDEX(FILE(1:NCFILE),' ')-1 53 - IF(IFN1.NE.-1.AND.IFN1+2.LE.NCFILE)THEN 54 - IFT0=IFN1+2 55 - IFT1=IFT0+INDEX(FILE(IFT0:NCFILE),' ')-2 56 - IF(IFT1.EQ.IFT0-2)IFT1=NCFILE 57 - ELSE 58 - PRINT *,' !!!!!! VMNAME WARNING : The file type has not'// 59 - - ' been specified; not valid.' 60 - IFAIL=1 61 - RETURN 62 - ENDIF 63 - IF(IFT1.NE.0.AND.IFT1+2.LE.NCFILE)THEN 64 - IFM0=IFT1+2 65 - IFM1=IFM0+INDEX(FILE(IFM0:NCFILE),' ')-2 66 - IF(IFM1.EQ.IFM0-2)THEN 67 - IFM1=NCFILE 68 - ELSE 69 - PRINT *,' !!!!!! VMNAME WARNING : Text "', 70 - - FILE(IFM1+2:NCFILE),'" found after'// 71 - - ' the file mode ; blanked out.' 72 - FILE(IFM1+2:NCFILE)=' ' 73 - NCFILE=IFM1 74 - ENDIF 75 - ELSE 76 - IFM0=0 77 - IFM1=0 78 - ENDIF 79 - * Verify the individual segments. 80 - IF(IFN0.NE.0.AND.IFN1.NE.0.AND.IFN1-IFN0+1.GT.8)THEN 81 - PRINT *,' !!!!!! VMNAME WARNING : Name part of the file'// 82 - - ' name "',FILE(IFN0:IFN1),'" too long ; rejected.' 83 - IFAIL=1 84 - RETURN 85 - ENDIF 86 - IF(IFT0.NE.0.AND.IFT1.NE.0.AND.IFT1-IFT0+1.GT.8)THEN 87 - PRINT *,' !!!!!! VMNAME WARNING : Type part of the file'// 88 - - ' name "',FILE(IFT0:IFT1),'" too long ; rejected.' 1 363 P=ROUTINES D=VMNAME 2 PAGE 455 89 - IFAIL=1 90 - RETURN 91 - ENDIF 92 - IF(IFM0.NE.0.AND.IFM1.NE.0.AND.IFM1-IFM0+1.GT.2)THEN 93 - PRINT *,' !!!!!! VMNAME WARNING : Mode part of the file'// 94 - - ' name "',FILE(IFM0:IFM1),'" too long ; rejected.' 95 - IFAIL=1 96 - RETURN 97 - ENDIF 98 - IF((IFM0.NE.0.AND.INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ', 99 - - FILE(MAX(1,IFM0):MAX(1,IFM0))).EQ.0).OR. 100 - - (IFM1.NE.IFM0.AND.IFM0.NE.0.AND.INDEX('0123456789', 101 - - FILE(MAX(1,IFM1):MAX(1,IFM1))).EQ.0))THEN 102 - PRINT *,' !!!!!! VMNAME WARNING : File mode format of "'// 103 - - FILE(IFM0:IFM1),'" not valid ; rejected.' 104 - IFAIL=1 105 - RETURN 106 - ENDIF 107 - END 364 GARFIELD ================================================== P=ROUTINES D=WLDCRD 1 ============================ 0 + +DECK,WLDCRD. 1 - SUBROUTINE WLDCRD(REFIN,WILDIN,FREEND,MATCH) 2 - *----------------------------------------------------------------------- 3 - * WLDCRD - Compares a string with a wildcard (the asterix may stand 4 - * for any number of arbitrary characters). 5 - * VARIABLES : REF : The reference string, without asterix 6 - * WILD : The wildcard 7 - * FREEND : Equivalent to a final asterix in WILD. 8 - * MATCH : Set to .TRUE. only if the strings match. 9 - * IW0, IW1 : Begin and end of a segment in the wildcard 10 - * IR0, IR1 : Begin of the part of the reference string 11 - * to be searched and the start of the match. 12 - *----------------------------------------------------------------------- 13.- +SEQ,DIMENSIONS. 14.- +SEQ,INPUT. 15 - CHARACTER*(*) REFIN,WILDIN 16 - CHARACTER*80 REF,WILD 17 - LOGICAL FREEND,MATCH,ASTER 18 - *** Check for empty strings. 19 - IF(REFIN.EQ.' '.OR.LEN(REFIN).EQ.0.OR. 20 - - WILDIN.EQ.' '.OR.LEN(WILDIN).EQ.0)THEN 21 - MATCH=.FALSE. 22 - RETURN 23 - ENDIF 24 - *** Avoid out of bounds array references. 25 - IF(LEN(REFIN).GT.80.OR.LEN(WILDIN).GT.80)THEN 26 - PRINT *,' ###### WLDCRD ERROR : Input strings too long:'// 27 - - ' REF: ',LEN(REF),' WILD: ',LEN(WILD) 28 - PRINT *,' (program bug - please'// 29 - - ' report); strings declared non-matching.' 30 - MATCH=.FALSE. 31 - RETURN 32 - ENDIF 33 - *** Copy the strings translating to upper case. 34 - NREF=0 35 - DO 10 I=1,LEN(REFIN) 36 - IC=ICHAR(REFIN(I:I)) 37 - * ASCII: all letters are contiguous and located between 97 and 122. 38 - IF(ICHSET.EQ.1.AND.IC.LE.122.AND.IC.GE.97)THEN 39 - REF(I:I)=CHAR(IC-32) 40 - * EBCDIC: there are 2 gaps in the set (idea from IBM of course). 41 - ELSEIF(ICHSET.EQ.2.AND.((IC.GE.129.AND.IC.LE.137).OR. 42 - - (IC.GE.145.AND.IC.LE.153).OR.(IC.GE.162.AND.IC.LE.169)))THEN 43 - REF(I:I)=CHAR(IC+64) 44 - * Anything else: don't do anything. 45 - ELSE 46 - REF(I:I)=CHAR(IC) 47 - ENDIF 48 - * Keep track of the lenghts. 49 - IF(REF(I:I).NE.' ')NREF=I 50 - 10 CONTINUE 51 - ** Do the same for the wildcard. 52 - NWILD=0 53 - DO 20 I=1,LEN(WILDIN) 54 - IC=ICHAR(WILDIN(I:I)) 55 - * ASCII: all letters are contiguous and located between 97 and 122. 56 - IF(ICHSET.EQ.1.AND.IC.LE.122.AND.IC.GE.97)THEN 57 - WILD(I:I)=CHAR(IC-32) 58 - * EBCDIC: there are 2 gaps in the set (idea from IBM of course). 59 - ELSEIF(ICHSET.EQ.2.AND.((IC.GE.129.AND.IC.LE.137).OR. 60 - - (IC.GE.145.AND.IC.LE.153).OR.(IC.GE.162.AND.IC.LE.169)))THEN 61 - WILD(I:I)=CHAR(IC+64) 62 - * Anything else: don't do anything. 63 - ELSE 64 - WILD(I:I)=CHAR(IC) 65 - ENDIF 66 - * Keep track of the lenghts. 67 - IF(WILD(I:I).NE.' ')NWILD=I 68 - 20 CONTINUE 69 - *** Compare segment by segment. 70 - IW0=1 71 - IW1=1 72 - IR0=1 73 - IR1=1 74 - INIT=1 75 - * Pick up the next segment of the wildcard. 76 - 100 CONTINUE 77 - IW1=IW0+INDEX(WILD(IW0:NWILD),'*')-2 78 - IF(IW1.EQ.IW0-2)THEN 79 - IW1=NWILD 80 - ELSEIF(IW1.LT.IW0)THEN 81 - IW0=IW1+2 82 - IF(IW0.GT.NWILD)GOTO 500 83 - GOTO 100 1 364 P=ROUTINES D=WLDCRD 2 PAGE 456 84 - ENDIF 85 - * Attempt to match with the reference string. 86 - IR1=IR0+INDEX(REF(IR0:NREF),WILD(IW0:IW1))-1 87 - IF(IR1.EQ.IR0-1)THEN 88 - MATCH=.FALSE. 89 - RETURN 90 - ENDIF 91 - * Check the asterix at the beginning of the wildcard. 92 - IF(IR1.NE.1.AND.INIT.EQ.1.AND.WILD(1:1).NE.'*')THEN 93 - MATCH=.FALSE. 94 - RETURN 95 - ENDIF 96 - * Update the start of string pointers. 97 - IR0=IR1+(IW1-IW0+1) 98 - IW0=IW1+2 99 - * Check whether the end has been reached. 100 - IF(IW0.GT.NWILD.OR.IR0.GT.NREF)GOTO 500 101 - * Look for the next segment. 102 - INIT=0 103 - GOTO 100 104 - *** End of the line is reached. 105 - 500 CONTINUE 106 - * Figure out whether the end of the wildcard is pure asterix. 107 - ASTER=.TRUE. 108 - DO 510 I=MAX(1,IW0-1),NWILD 109 - IF(WILD(I:I).NE.'*')THEN 110 - ASTER=.FALSE. 111 - GOTO 520 112 - ENDIF 113 - 510 CONTINUE 114 - 520 CONTINUE 115 - * Match if both strings have been used up entirely. 116 - IF(IR0.GT.NREF.AND.IW0.GT.NWILD)THEN 117 - MATCH=.TRUE. 118 - * Free end of reference string matching. 119 - ELSEIF(IR0.LE.NREF)THEN 120 - IF((IW0.GT.NWILD.AND.FREEND).OR. 121 - - (IW0.LE.NWILD+1.AND.ASTER))THEN 122 - MATCH=.TRUE. 123 - ELSE 124 - MATCH=.FALSE. 125 - ENDIF 126 - * Excess of non-asterix characters at the end of the wildcard. 127 - ELSEIF(IW0.LE.NWILD)THEN 128 - IF(IR0.GT.NREF.AND..NOT.ASTER)THEN 129 - MATCH=.FALSE. 130 - ELSE 131 - MATCH=.TRUE. 132 - ENDIF 133 - * Strange case. 134 - ELSE 135 - PRINT *,' ###### WLDCRD ERROR : No handling available,'// 136 - - ' program bug ; declared not to match.' 137 - PRINT *,' IW0=',IW0,', IW1=',IW1, 138 - - ', NWILD=',NWILD,', WILD="'//WILD(1:NWILD)//'"' 139 - PRINT *,' IR0=',IR0,', IR1=',IR1, 140 - - ', NREF =',NREF,', REF ="'//REF(1:NREF)//'"' 141 - PRINT *,' FREEND=',FREEND, 142 - - ', ASTER=',ASTER 143 - MATCH=.FALSE. 144 - ENDIF 145 - END 365 GARFIELD ================================================== P=ROUTINES D=BSORT 1 ============================ 0 + +DECK,BSORT. 1 - SUBROUTINE BSORT(A,NR,COMPGT) 2 - *----------------------------------------------------------------------- 3 - * BSORT - Bubble sort using function COMPGT for comparisons. 4 - * Variables: 5 - * (Last changed on 20/ 1/97.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8 - INTEGER NR,A(NR),AUX,I,J,INEW,NSWAP,NCOMP 9 - LOGICAL COMPGT 10 - EXTERNAL COMPGT 11 - *** Counters. 12 - NCOMP=0 13 - NSWAP=0 14 - C print *,' Initial ',(A(I),I=1,NR) 15 - C do i=1,nr 16 - C print *,(compgt(a(i),a(j)),j=1,nr) 17 - C enddo 18 - *** Loop over element to be put into place. 19 - DO 10 I=NR-1,1,-1 20 - CALL PROSTA(1,REAL(NR-I)) 21 - *** Find its proper place. 22 - INEW=I 23 - DO 20 J=I+1,NR 24 - IF(COMPGT(A(I),A(J)))INEW=J 25 - NCOMP=NCOMP+1 26 - 20 CONTINUE 27 - *** Move it into that place. 28 - IF(INEW.NE.I)THEN 29 - * Check the sort. 30 - DO 50 J=I+1,INEW 31 - IF(COMPGT(A(J),A(I)))THEN 32 - PRINT *,' !!!!!! BSORT WARNING : Data not sortable'// 33 - - ' use the SPLIT-INTERSECTING-PLANES option.' 34 - RETURN 35 - ENDIF 36 - 50 CONTINUE 37 - * Exchange. 38 - C print *,' Exchanging ',A(I),' and ',A(INEW) 39 - AUX=A(I) 40 - DO 30 J=I+1,INEW 1 365 P=ROUTINES D=BSORT 2 PAGE 457 41 - A(J-1)=A(J) 42 - 30 CONTINUE 43 - A(INEW)=AUX 44 - NSWAP=NSWAP+1 45 - ENDIF 46 - 10 CONTINUE 47 - C print *,' Final ',(A(I),I=1,NR) 48 - *** Statistics. 49 - C print *,' Comparisons: ',ncomp,', Swaps: ',nswap 50 - END 366 GARFIELD ================================================== P=ROUTINES D=QSORT 1 ============================ 0 + +DECK,QSORT,IF=NEVER. 1 - SUBROUTINE QSORT(A,NR,LESSEQ) 2 - *----------------------------------------------------------------------- 3 - * QSORT - Quick sort algorithm of the objects in array A, using the 4 - * function LESSEQ for comparison. Based on CERNLIB M109. 5 - * Variables: L : Lower limit of the interval (input) 6 - * R : Upper limit of the interval (input) 7 - * I : Lower limit of upper sub-interval (output) 8 - * J : Upper limit of lower sub-interval (output) 9 - * (Last changed on 9/ 1/98.) 10 - *---------------------------------------------------------------------- 11 - implicit none 12 - INTEGER MXLEV 13 - PARAMETER(MXLEV=20) 14 - INTEGER NR,A(NR),X,LT(MXLEV),RT(MXLEV),TEMP,LEVEL,L,R,I,J,M, 15 - - NCOMP,NSWAP 16 - LOGICAL LESSEQ 17 - EXTERNAL LESSEQ 18 - *** Initial division level and subdivision range. 19 - LEVEL=1 20 - LT(1)=1 21 - RT(1)=NR 22 - *** Counters. 23 - NCOMP=0 24 - NSWAP=0 25 - *** Move a level higher up. 26 - 10 CONTINUE 27 - L=LT(LEVEL) 28 - R=RT(LEVEL) 29 - LEVEL=LEVEL-1 30 - *** Start sort. 31 - 20 CONTINUE 32 - *** See whether lower and upper limit coincide. 33 - IF(R.LE.L)THEN 34 - * Sort not finished, move a level back. 35 - IF(LEVEL.GT.0)THEN 36 - GOTO 10 37 - * Sort finished, reverse the order of the rows. 38 - ELSE 39 - print *,' Comparisons: ',ncomp,', Swaps: ',nswap 40 - RETURN 41 - ENDIF 42 - ENDIF 43 - *** Sort the new interval around its middle point. 44 - I=L 45 - J=R 46 - M=(L+R)/2 47 - X=A(M) 48 - *** Sort the lower half of this interval. 49 - 30 CONTINUE 50 - NCOMP=NCOMP+1 51 - IF(LESSEQ(X,A(I)))GOTO 40 52 - I=I+1 53 - GOTO 30 54 - *** Search for a point in the upper half that is smaller. 55 - 40 CONTINUE 56 - NCOMP=NCOMP+1 57 - IF(LESSEQ(A(J),X))THEN 58 - * When found, swap I and J and resume if there are more points. 59 - IF(I.LE.J)THEN 60 - TEMP=A(I) 61 - A(I)=A(J) 62 - A(J)=TEMP 63 - NSWAP=NSWAP+1 64 - I=I+1 65 - J=J-1 66 - IF(I.LE.J)GOTO 30 67 - ENDIF 68 - * See whether a level can be added. 69 - IF(LEVEL+1.GT.MXLEV)THEN 70 - PRINT *,' !!!!!! SORTQ WARNING : Subdivision level'// 71 - - ' exceeds maximum; increase MXLEV.' 72 - RETURN 73 - ENDIF 74 - LEVEL=LEVEL+1 75 - * Add a level and restart search. 76 - IF((R-I).GE.(J-L))THEN 77 - LT(LEVEL)=I 78 - RT(LEVEL)=R 79 - R=J 80 - ELSE 81 - LT(LEVEL)=L 82 - RT(LEVEL)=J 83 - L=I 84 - ENDIF 85 - GOTO 20 86 - ENDIF 87 - J=J-1 88 - GOTO 40 89 - END 1 367 GARFIELD ================================================== P=HISTOGRA D= 1 =================== PAGE 458 0 + +PATCH,HISTOGRAM. 368 GARFIELD ================================================== P=HISTOGRA D=HISADM 1 ============================ 0 + +DECK,HISADM. 1 - SUBROUTINE HISADM(ACTION,IREF,NNCHA,XXMIN,XXMAX,AUTO,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HISADM - Takes care of histogram booking. 4 - * range setting if requested. 5 - * (Last changed on 11/ 2/97.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,HISTDATA. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,GLOBALS. 12 - CHARACTER*(*) ACTION 13 - CHARACTER*10 NAME 14 - INTEGER IREF,IFAIL,NNCHA,I,J,NLIST 15 - REAL XXMIN,XXMAX 16 - LOGICAL AUTO 17 - *** Allocate a new histogram. 18 - IF(ACTION.EQ.'ALLOCATE'.OR.ACTION.EQ.'INTEGER')THEN 19 - * Check the request is reasonable. 20 - IF(NNCHA.GT.MXCHA.OR.NNCHA.LE.0.OR. 21 - - (XXMIN.GE.XXMAX.AND..NOT.AUTO))THEN 22 - PRINT *,' !!!!!! HISADM WARNING : Unreasonable'// 23 - - ' allocation request refused.' 24 - IFAIL=1 25 - RETURN 26 - ENDIF 27 - * Look for a free slot. 28 - DO 10 I=1,MXHIST 29 - * Found a free slot. 30 - IF(.NOT.HISUSE(I))THEN 31 - IREF=I 32 - DO 20 J=0,MXCHA+1 33 - CONTEN(IREF,J)=0.0 34 - 20 CONTINUE 35 - SX0(IREF)=0.0D0 36 - SX1(IREF)=0.0D0 37 - SX2(IREF)=0.0D0 38 - NENTRY(IREF)=0 39 - XMIN(IREF)=XXMIN 40 - XMAX(IREF)=XXMAX 41 - NCHA(IREF)=NNCHA 42 - SET(IREF)=.NOT.AUTO 43 - HISUSE(IREF)=.TRUE. 44 - IF(ACTION.EQ.'INTEGER')THEN 45 - HISLIN(IREF)=.TRUE. 46 - ELSE 47 - HISLIN(IREF)=.FALSE. 48 - ENDIF 49 - IFAIL=0 50 - IF(LDEBUG)PRINT *,' ++++++ HISADM DEBUG :'// 51 - - ' Histogram ',IREF,' allocated.' 52 - RETURN 53 - ENDIF 54 - 10 CONTINUE 55 - * No free slot found. 56 - PRINT *,' !!!!!! HISADM WARNING : No free histogram'// 57 - - ' storage available; no slot allocated.' 58 - IREF=0 59 - IFAIL=1 60 - *** Release an allocated histogram. 61 - ELSEIF(ACTION.EQ.'DELETE')THEN 62 - IF(IREF.GE.1.AND.IREF.LE.MXHIST)THEN 63 - HISUSE(IREF)=.FALSE. 64 - IF(LDEBUG)PRINT *,' ++++++ HISADM DEBUG :'// 65 - - ' Histogram ',IREF,' deallocated.' 66 - DO 45 J=1,NGLB 67 - IF(GLBMOD(J).EQ.4.AND.NINT(GLBVAL(J)).EQ.IREF) 68 - - GLBMOD(J)=0 69 - 45 CONTINUE 70 - IFAIL=0 71 - ELSE 72 - PRINT *,' !!!!!! HISADM WARNING : Histogram to be'// 73 - - ' deleted not found.' 74 - IFAIL=1 75 - ENDIF 76 - *** List of histograms. 77 - ELSEIF(ACTION.EQ.'LIST')THEN 78 - * Print a header. 79 - WRITE(LUNOUT,'(/'' OVERVIEW OF EXISTING HISTOGRAMS''// 80 - - '' Number Global Integral Average'', 81 - - '' RMS Minimum Maximum''/)') 82 - * Loop over all histograms. 83 - NLIST=0 84 - DO 30 I=1,MXHIST 85 - * Case 1: histogram slot not in use. 86 - IF(.NOT.HISUSE(I))GOTO 30 87 - * Locate the global variable name that goes with the histogram. 88 - NAME='(none)' 89 - DO 40 J=1,NGLB 90 - IF(GLBMOD(J).EQ.4.AND.NINT(GLBVAL(J)).EQ.I) 91 - - NAME=GLBVAR(J) 92 - 40 CONTINUE 93 - * Case 2: histogram in use but still empty, range set. 94 - IF(NENTRY(I).EQ.0.AND.SET(I))THEN 95 - WRITE(LUNOUT,'(2X,I6,1X,A10,'' No entries yet'',16X, 96 - - 2(1X,E10.3))') I,NAME,XMIN(I),XMAX(I) 97 - * Case 3: histogram in use but still empty, range not yet set. 98 - ELSEIF(NENTRY(I).EQ.0)THEN 99 - WRITE(LUNOUT,'(2X,I6,1X,A10,'' Autorange histogram'', 100 - - '' without entries sofar'')') I,NAME 101 - * Case 4: entries available. 1 368 P=HISTOGRA D=HISADM 2 PAGE 459 102 - ELSEIF(SET(I))THEN 103 - IF(SX0(I).LT.0)THEN 104 - WRITE(LUNOUT,'(2X,I6,1X,A10,1X,E10.3, 105 - - '' No statistics yet'',2(1X,E10.3))') 106 - - I,NAME,SX0(I),XMIN(I),XMAX(I) 107 - ELSEIF(SX0(I).LT.2)THEN 108 - WRITE(LUNOUT,'(2X,I6,1X,A10,2(1X,E10.3), 109 - - '' Undefined'',2(1X,E10.3))') 110 - - I,NAME,SX0(I),SX1(I)/SX0(I),XMIN(I),XMAX(I) 111 - ELSE 112 - WRITE(LUNOUT,'(2X,I6,1X,A10,5(1X,E10.3))') 113 - - I,NAME,SX0(I),SX1(I)/SX0(I), 114 - - SQRT((SX2(I)-SX1(I)**2/SX0(I))/ 115 - - (SX0(I)-1)),XMIN(I),XMAX(I) 116 - ENDIF 117 - ELSE 118 - WRITE(LUNOUT,'(2X,I6,1X,A10,3(1X,E10.3), 119 - - '' Range not yet set'')') I,NAME, 120 - - SX0(I),SX1(I)/SX0(I), 121 - - SQRT((SX2(I)-SX1(I)**2/SX0(I))/ 122 - - (SX0(I)-1)) 123 - ENDIF 124 - * Increment the counter. 125 - NLIST=NLIST+1 126 - 30 CONTINUE 127 - * Say how many histograms are currently known. 128 - WRITE(LUNOUT,'(/'' Number of histograms booked: '',I5/)') 129 - - NLIST 130 - *** Unknown action. 131 - ELSE 132 - PRINT *,' !!!!!! HISADM WARNING : Invalid action requested.' 133 - IFAIL=1 134 - ENDIF 135 - END 369 GARFIELD ================================================== P=HISTOGRA D=HISBAR 1 ============================ 0 + +DECK,HISBAR. 1 - SUBROUTINE HISBAR(IREF,NBAR,XBAR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HISBAR - Returns the barycentre. 4 - * (Last changed on 4/ 2/96.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,HISTDATA. 8 - INTEGER IREF,NBAR,IFAIL 9 - REAL XBAR,XSUM,SUM,SUMMAX,WSUM 10 - *** Preset output for the event of failure. 11 - XBAR=0.0 12 - IFAIL=1 13 - *** Ensure that IREF exists and has a range. 14 - IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN 15 - PRINT *,' !!!!!! HISBAR WARNING : Histogram reference'// 16 - - ' not valid; no barycentre.' 17 - RETURN 18 - ELSEIF(.NOT.SET(IREF))THEN 19 - PRINT *,' !!!!!! HISBAR WARNING : The scale of the'// 20 - - ' input histogram is not yet set; no barycentre.' 21 - RETURN 22 - ELSEIF(NCHA(IREF).LE.0)THEN 23 - PRINT *,' !!!!!! HISBAR WARNING : Input histogram'// 24 - - ' has no bins; no barycentre.' 25 - RETURN 26 - ENDIF 27 - *** Also make sure the the number of bins to average over is OK. 28 - IF(NBAR.LE.0)THEN 29 - PRINT *,' !!!!!! HISBAR WARNING : Number of bins to'// 30 - - ' average over < 1; no barycentre.' 31 - RETURN 32 - ENDIF 33 - *** Locate the maximum. 34 - SUMMAX=-1 35 - DO 10 I=1,MAX(1,NCHA(IREF)-NBAR+1) 36 - SUM=0 37 - XSUM=0 38 - WSUM=0 39 - DO 20 J=I,MIN(I+NBAR-1,NCHA(IREF)) 40 - SUM=SUM+ABS(CONTEN(IREF,J)) 41 - XSUM=XSUM+CONTEN(IREF,J)* 42 - - (XMIN(IREF)+(J-0.5)*(XMAX(IREF)-XMIN(IREF))/ 43 - - REAL(NCHA(IREF))) 44 - WSUM=WSUM+CONTEN(IREF,J) 45 - 20 CONTINUE 46 - IF(SUM.GT.SUMMAX.AND.WSUM.NE.0)THEN 47 - SUMMAX=SUM 48 - XBAR=XSUM/WSUM 49 - ENDIF 50 - 10 CONTINUE 51 - *** Check that a maximum has been found. 52 - IF(SUMMAX.LE.0)THEN 53 - PRINT *,' !!!!!! HISBAR WARNING : No maximum has been'// 54 - - ' found; no barycentre.' 55 - RETURN 56 - ENDIF 57 - *** Seems to have worked. 58 - IFAIL=0 59 - END 370 GARFIELD ================================================== P=HISTOGRA D=HISCAL 1 ============================ 0 + +DECK,HISCAL. 1 - SUBROUTINE HISCAL(INSTR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HISCAL - Processes histogram related procedure calls. 4 - * (Last changed on 18/ 3/01.) 5 - *----------------------------------------------------------------------- 1 370 P=HISTOGRA D=HISCAL 2 PAGE 460 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,ALGDATA. 9.- +SEQ,HISTDATA. 10.- +SEQ,MATDATA. 11.- +SEQ,GLOBALS. 12 - CHARACTER*(MXINCH) STRING 13 - CHARACTER*80 XTXT,TITLE 14 - CHARACTER*8 MEMBER 15 - REAL XXMIN,XXMAX,AVER,SIGMA,HMIN,HMAX,ENTRY,WEIGHT,XX 16 - LOGICAL HAUTO,HEXIST,HSET,FRAME,HINT 17 - INTEGER INPCMX,IPROC,NARG,IFAIL,INSTR,NNCHA,NNENTR,IREF,IFAIL1, 18 - - IFAIL2,IFAIL3,NCMEMB,NCREM,NCXTXT,NC,NCTITL,I,J,ISTR,NBIN, 19 - - IHISRF,IMATRF,IMATSL,MATSLT,ISIZ(1),NHIST,ISENT,ISWGT, 20 - - NSIZE 21 - EXTERNAL INPCMX,MATSLT 22 - *** Assume the CALL will fail. 23 - IFAIL=1 24 - *** Some easy reference variables. 25 - NARG=INS(INSTR,3) 26 - IPROC=INS(INSTR,1) 27 - *** Book a histogram. 28 - IF(IPROC.EQ.-602)THEN 29 - * Check number and type of arguments. 30 - IF(NARG.LT.1.OR.NARG.GT.5.OR. 31 - - (NARG.EQ.2.AND.MODARG(2).NE.2.AND.MODARG(2).NE.1).OR. 32 - - (NARG.GT.2.AND.MODARG(2).NE.2).OR. 33 - - (NARG.EQ.3.AND.MODARG(3).NE.1).OR. 34 - - (NARG.GE.4.AND.(MODARG(3).NE.2.OR.MODARG(4).NE.2)).OR. 35 - - (NARG.GE.5.AND.MODARG(5).NE.1))THEN 36 - PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// 37 - - ' list provided for BOOK_HISTOGRAM.' 38 - RETURN 39 - ENDIF 40 - * Check that the reference number can be transferred back. 41 - IF(ARGREF(1,1).GE.2)THEN 42 - PRINT *,' !!!!!! HISCAL WARNING : Unable to return'// 43 - - ' the histogram reference to calling procedure.' 44 - RETURN 45 - ENDIF 46 - * Free memory associated with argument. 47 - CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) 48 - * Store arguments. 49 - IF(NARG.GE.2)THEN 50 - NNCHA=NINT(ARG(2)) 51 - ELSE 52 - NNCHA=100 53 - ENDIF 54 - IF(NARG.GE.4)THEN 55 - HMIN=ARG(3) 56 - HMAX=ARG(4) 57 - HAUTO=.FALSE. 58 - ELSE 59 - HMIN=-1 60 - HMAX=+1 61 - HAUTO=.TRUE. 62 - ENDIF 63 - HINT=.FALSE. 64 - IF(MODARG(NARG).EQ.1)THEN 65 - CALL STRBUF('READ',NINT(ARG(NARG)),XTXT,NCXTXT,IFAIL1) 66 - IF(NCXTXT.LE.0)THEN 67 - XTXT=' ' 68 - NCXTXT=1 69 - ENDIF 70 - CALL CLTOU(XTXT(1:NCXTXT)) 71 - IF(INDEX(XTXT(1:MAX(1,NCXTXT)),'MANUAL').NE.0)THEN 72 - IF(NARG.LT.5)THEN 73 - PRINT *,' !!!!!! HISCAL WARNING : The'// 74 - - ' MANUAL option requires the range'// 75 - - ' to be specified; assuming AUTO.' 76 - ELSE 77 - HAUTO=.FALSE. 78 - ENDIF 79 - ELSEIF(INDEX(XTXT(1:MAX(1,NCXTXT)),'AUTO').NE.0)THEN 80 - HAUTO=.TRUE. 81 - ENDIF 82 - IF(INDEX(XTXT(1:MAX(1,NCXTXT)),'INTEGER').NE.0)THEN 83 - HINT=.TRUE. 84 - ELSEIF(INDEX(XTXT(1:MAX(1,NCXTXT)),'REAL').NE.0)THEN 85 - HINT=.FALSE. 86 - ENDIF 87 - ENDIF 88 - * Book the histogram. 89 - IF(HINT)THEN 90 - CALL HISADM('INTEGER',IHISRF,NNCHA,HMIN,HMAX, 91 - - HAUTO,IFAIL1) 92 - ELSE 93 - CALL HISADM('ALLOCATE',IHISRF,NNCHA,HMIN,HMAX, 94 - - HAUTO,IFAIL1) 95 - ENDIF 96 - * Back-transfer the reference number. 97 - IF(IFAIL1.EQ.0)THEN 98 - ARG(1)=IHISRF 99 - MODARG(1)=4 100 - ELSE 101 - PRINT *,' !!!!!! HISCAL WARNING : Unable to allocate'// 102 - - ' the histogram.' 103 - ARG(1)=0 104 - MODARG(1)=0 105 - ENDIF 106 - *** Fill histogram. 107 - ELSEIF(IPROC.EQ.-603)THEN 108 - * Check number and type of arguments. 109 - IF(MODARG(1).NE.4.OR. 110 - - (MODARG(2).NE.2.AND.MODARG(2).NE.5).OR. 111 - - (NARG.GE.3.AND.MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. 1 370 P=HISTOGRA D=HISCAL 3 PAGE 461 112 - - NARG.LT.2.OR.NARG.GT.3)THEN 113 - PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// 114 - - ' list provided for FILL_HISTOGRAM.' 115 - RETURN 116 - ENDIF 117 - * Locate entries. 118 - IF(MODARG(2).EQ.5)THEN 119 - ISENT=MATSLT(NINT(ARG(2))) 120 - IF(ISENT.LE.0)THEN 121 - PRINT *,' !!!!!! HISCAL WARNING : Unable'// 122 - - ' to locate the entries; no filling.' 123 - RETURN 124 - ENDIF 125 - ELSE 126 - ISENT=0 127 - ENDIF 128 - * Locate weights. 129 - IF(MODARG(3).EQ.5.AND.NARG.GE.3)THEN 130 - ISWGT=MATSLT(NINT(ARG(3))) 131 - IF(ISWGT.LE.0)THEN 132 - PRINT *,' !!!!!! HISCAL WARNING : Unable'// 133 - - ' to locate the weights; no filling.' 134 - RETURN 135 - ENDIF 136 - ELSE 137 - ISWGT=0 138 - ENDIF 139 - * Verify compatibility. 140 - IF(ISENT.NE.0.AND.ISWGT.NE.0)THEN 141 - IF(MLEN(ISENT).NE.MLEN(ISWGT))THEN 142 - PRINT *,' !!!!!! HISCAL WARNING : Entry'// 143 - - ' and weight vectors are not'// 144 - - ' compatible; no filling.' 145 - RETURN 146 - ELSE 147 - NSIZE=MLEN(ISENT) 148 - ENDIF 149 - ELSEIF(ISENT.NE.0)THEN 150 - NSIZE=MLEN(ISENT) 151 - ELSEIF(ISWGT.NE.0)THEN 152 - NSIZE=MLEN(ISWGT) 153 - ELSE 154 - NSIZE=1 155 - ENDIF 156 - * Perform filling. 157 - DO 110 I=1,NSIZE 158 - IF(ISENT.EQ.0)THEN 159 - ENTRY=ARG(2) 160 - ELSE 161 - ENTRY=MVEC(MORG(ISENT)+I) 162 - ENDIF 163 - IF(ISWGT.EQ.0)THEN 164 - IF(NARG.GE.3)THEN 165 - WEIGHT=ARG(3) 166 - ELSE 167 - WEIGHT=1.0 168 - ENDIF 169 - ELSE 170 - WEIGHT=MVEC(MORG(ISWGT)+I) 171 - ENDIF 172 - CALL HISENT(NINT(ARG(1)),ENTRY,WEIGHT) 173 - 110 CONTINUE 174 - *** Plot a histogram. 175 - ELSEIF(IPROC.EQ.-604)THEN 176 - * Check number and type of arguments. 177 - IF(MODARG(1).NE.4.OR. 178 - - (NARG.GE.2.AND.MODARG(2).NE.1).OR. 179 - - (NARG.GE.3.AND.MODARG(3).NE.1).OR. 180 - - (NARG.GE.4.AND.MODARG(4).NE.1).OR. 181 - - NARG.LT.1.OR.NARG.GT.4)THEN 182 - PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// 183 - - ' list provided for PLOT_HISTOGRAM.' 184 - RETURN 185 - ENDIF 186 - * Check option. 187 - FRAME=.TRUE. 188 - IF(NARG.GE.4)THEN 189 - CALL STRBUF('READ',NINT(ARG(4)),TITLE,NCTITL,IFAIL1) 190 - IF(NCTITL.LT.1)THEN 191 - TITLE=' ' 192 - NCTITL=1 193 - ENDIF 194 - CALL CLTOU(TITLE(1:NCTITL)) 195 - IF(INDEX(TITLE(1:NCTITL),'NOFRAME').NE.0)THEN 196 - FRAME=.FALSE. 197 - ELSEIF(INDEX(TITLE(1:NCTITL),'FRAME').NE.0)THEN 198 - FRAME=.TRUE. 199 - ENDIF 200 - ENDIF 201 - * Fetch titles. 202 - IF(NARG.GE.2)THEN 203 - CALL STRBUF('READ',NINT(ARG(2)),XTXT,NCXTXT,IFAIL1) 204 - IF(IFAIL1.NE.0)XTXT=' ' 205 - IF(IFAIL1.NE.0)NCXTXT=1 206 - ELSE 207 - XTXT='Coordinate' 208 - NCXTXT=10 209 - ENDIF 210 - IF(NARG.GE.3)THEN 211 - CALL STRBUF('READ',NINT(ARG(3)),TITLE,NCTITL,IFAIL2) 212 - IF(IFAIL2.NE.0)TITLE=' ' 213 - IF(IFAIL2.NE.0)NCTITL=1 214 - ELSE 215 - TITLE='Title' 216 - NCTITL=5 217 - ENDIF 1 370 P=HISTOGRA D=HISCAL 4 PAGE 462 218 - IF((NARG.LT.3.OR.TITLE(1:NCTITL).EQ.'*').AND. 219 - - ARGREF(1,2).GE.1.AND.ARGREF(1,2).LE.NGLB)THEN 220 - TITLE=GLBVAR(ARGREF(1,2)) 221 - NCTITL=LEN(GLBVAR(ARGREF(1,2))) 222 - ENDIF 223 - * Plot. 224 - CALL HISPLT(NINT(ARG(1)),XTXT(1:NCXTXT),TITLE(1:NCTITL), 225 - - FRAME) 226 - *** Print a histogram. 227 - ELSEIF(IPROC.EQ.-605)THEN 228 - * Check number and type of arguments. 229 - IF(MODARG(1).NE.4.OR. 230 - - (NARG.GE.2.AND.MODARG(2).NE.1).OR. 231 - - (NARG.GE.3.AND.MODARG(3).NE.1).OR. 232 - - NARG.LT.1.OR.NARG.GT.3)THEN 233 - PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// 234 - - ' list provided for PRINT_HISTOGRAM.' 235 - RETURN 236 - ENDIF 237 - * Fetch strings. 238 - IF(NARG.GE.2)THEN 239 - CALL STRBUF('READ',NINT(ARG(2)),XTXT,NCXTXT,IFAIL1) 240 - IF(IFAIL1.NE.0)XTXT=' ' 241 - IF(IFAIL1.NE.0)NCXTXT=1 242 - ELSE 243 - XTXT='Coordinate' 244 - NCXTXT=10 245 - ENDIF 246 - IF(NARG.GE.3)THEN 247 - CALL STRBUF('READ',NINT(ARG(3)),TITLE,NCTITL,IFAIL2) 248 - IF(IFAIL2.NE.0)TITLE=' ' 249 - IF(IFAIL2.NE.0)NCTITL=1 250 - ELSE 251 - TITLE='Title' 252 - NCTITL=5 253 - ENDIF 254 - IF((NARG.LT.3.OR.TITLE(1:NCTITL).EQ.'*').AND. 255 - - ARGREF(1,2).GE.1.AND.ARGREF(1,2).LE.NGLB)THEN 256 - TITLE=GLBVAR(ARGREF(1,2)) 257 - NCTITL=LEN(GLBVAR(ARGREF(1,2))) 258 - ENDIF 259 - * Print. 260 - CALL HISPRT(NINT(ARG(1)),XTXT(1:NCXTXT),TITLE(1:NCTITL)) 261 - *** Delete a histogram. 262 - ELSEIF(IPROC.EQ.-606)THEN 263 - * Without arguments, delete all histograms. 264 - IF(NARG.LT.1)THEN 265 - DO 10 I=1,NGLB 266 - IF(GLBMOD(I).EQ.4)THEN 267 - CALL HISADM('DELETE',NINT(GLBVAL(I)), 268 - - 0,0.0,0.0,.FALSE.,IFAIL1) 269 - GLBVAL(I)=0 270 - GLBMOD(I)=0 271 - ENDIF 272 - 10 CONTINUE 273 - CALL HISINT 274 - * Delete all the matrices in the arguments. 275 - ELSE 276 - DO 40 I=1,NARG 277 - IF(MODARG(I).NE.4)THEN 278 - PRINT *,' !!!!!! HISCAL WARNING : Argument ',I, 279 - - ' is not an histogram; not deleted.' 280 - GOTO 40 281 - ENDIF 282 - CALL HISADM('DELETE',NINT(ARG(I)), 283 - - 0,0.0,0.0,.FALSE.,IFAIL1) 284 - ARG(I)=0 285 - MODARG(I)=0 286 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! HISCAL WARNING :'// 287 - - ' Deleting an histogram failed.' 288 - 40 CONTINUE 289 - ENDIF 290 - *** List histograms. 291 - ELSEIF(IPROC.EQ.-607)THEN 292 - * Check number and type of arguments. 293 - IF(NARG.NE.0)THEN 294 - PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// 295 - - ' list provided for LIST_HISTOGRAMS.' 296 - RETURN 297 - ENDIF 298 - * List. 299 - CALL HISADM('LIST',0,0,0.0,0.0,.FALSE.,IFAIL1) 300 - *** Write a histogram to disk. 301 - ELSEIF(IPROC.EQ.-608)THEN 302 - * Check number and type of arguments. 303 - IF(MODARG(1).NE.4.OR.MODARG(2).NE.1.OR. 304 - - (NARG.GE.3.AND.MODARG(3).NE.1).OR. 305 - - (NARG.GE.4.AND.MODARG(4).NE.1).OR. 306 - - NARG.LT.2.OR.NARG.GT.4)THEN 307 - PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// 308 - - ' list provided for WRITE_HISTOGRAM.' 309 - RETURN 310 - ENDIF 311 - * Fetch file name. 312 - CALL STRBUF('READ',NINT(ARG(2)),STRING,NC,IFAIL1) 313 - * Member name. 314 - IF(NARG.GE.3)THEN 315 - CALL STRBUF('READ',NINT(ARG(3)),MEMBER,NCMEMB,IFAIL2) 316 - IF(NCMEMB.GT.8)PRINT *,' !!!!!! HISCAL WARNING :'// 317 - - ' Member name truncated to first 8 characters' 318 - NCMEMB=MIN(8,NCMEMB) 319 - ELSE 320 - DO 20 J=1,NGLB 321 - IF(GLBMOD(J).NE.4)GOTO 20 322 - IF(NINT(GLBVAL(J)).EQ.NINT(ARG(1)))THEN 323 - MEMBER=GLBVAR(J) 1 370 P=HISTOGRA D=HISCAL 5 PAGE 463 324 - NCMEMB=8 325 - GOTO 30 326 - ENDIF 327 - 20 CONTINUE 328 - MEMBER='< none >' 329 - NCMEMB=8 330 - 30 CONTINUE 331 - IFAIL2=0 332 - ENDIF 333 - * Remark. 334 - IF(NARG.GE.4)THEN 335 - CALL STRBUF('READ',NINT(ARG(4)),TITLE,NCREM,IFAIL3) 336 - IF(NCREM.GT.29)PRINT *,' !!!!!! HISCAL WARNING :'// 337 - - ' Remark truncated to first 29 characters' 338 - NCREM=MIN(29,NCREM) 339 - ELSE 340 - TITLE='none' 341 - NCREM=4 342 - IFAIL3=0 343 - ENDIF 344 - * Write the histogram. 345 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN 346 - CALL HISWRT(NINT(ARG(1)),STRING(1:NC),MEMBER(1:NCMEMB), 347 - - TITLE(1:NCREM),IFAIL2) 348 - IF(IFAIL2.NE.0)PRINT *,' !!!!!! HISCAL WARNING :'// 349 - - ' Writing histogram to disk failed.' 350 - ELSE 351 - PRINT *,' !!!!!! HISCAL WARNING :'// 352 - - ' Not able to obtain a name; histogram'// 353 - - ' not written to disk.' 354 - ENDIF 355 - *** Read a histogram from disk. 356 - ELSEIF(IPROC.EQ.-609)THEN 357 - * Check number and type of arguments. 358 - IF(ARGREF(1,1).GE.2.OR. 359 - - MODARG(2).NE.1.OR. 360 - - (NARG.GE.3.AND.MODARG(3).NE.1).OR. 361 - - NARG.LT.2.OR.NARG.GT.3)THEN 362 - PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// 363 - - ' list provided for GET_HISTOGRAM.' 364 - RETURN 365 - ENDIF 366 - * Fetch file name. 367 - CALL STRBUF('READ',NINT(ARG(2)),STRING,NC,IFAIL1) 368 - * Fetch the member name, if present. 369 - IF(NARG.GE.3)THEN 370 - CALL STRBUF('READ',NINT(ARG(3)),MEMBER,NCMEMB,IFAIL2) 371 - IF(NCMEMB.GT.8)PRINT *,' !!!!!! HISCAL WARNING :'// 372 - - ' Member name truncated to first 8 characters' 373 - NCMEMB=MIN(8,NCMEMB) 374 - ELSEIF(ARGREF(1,2).GE.1.AND.ARGREF(1,2).LE.NGLB)THEN 375 - MEMBER=GLBVAR(ARGREF(1,2)) 376 - NCMEMB=8 377 - IFAIL2=0 378 - ELSE 379 - MEMBER='*' 380 - NCMEMB=1 381 - IFAIL2=0 382 - ENDIF 383 - * Read the histogram. 384 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN 385 - CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) 386 - CALL HISGET(IREF,STRING(1:NC),MEMBER(1:NCMEMB),IFAIL3) 387 - IF(IFAIL3.NE.0)THEN 388 - PRINT *,' !!!!!! HISCAL WARNING :'// 389 - - ' Reading histogram from disk failed.' 390 - ARG(1)=0 391 - MODARG(1)=0 392 - ELSE 393 - ARG(1)=IREF 394 - MODARG(1)=4 395 - ENDIF 396 - ELSE 397 - PRINT *,' !!!!!! HISCAL WARNING :'// 398 - - ' Not able to obtain a name; histogram'// 399 - - ' not read from disk.' 400 - ENDIF 401 - *** Obtain information about an histogram. 402 - ELSEIF(IPROC.EQ.-610)THEN 403 - * Check number and type of arguments. 404 - IF(MODARG(1).NE.4.OR.NARG.LT.2.OR. 405 - - (NARG.GE.2.AND.ARGREF(2,1).GE.2).OR. 406 - - (NARG.GE.3.AND.ARGREF(3,1).GE.2).OR. 407 - - (NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. 408 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. 409 - - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. 410 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. 411 - - (NARG.GE.8.AND.ARGREF(8,1).GE.2).OR. 412 - - (NARG.GE.9.AND.ARGREF(9,1).GE.2))THEN 413 - PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// 414 - - ' list provided for INQUIRE_HISTOGRAM.' 415 - RETURN 416 - ENDIF 417 - * Obtain the information. 418 - CALL HISINQ(NINT(ARG(1)),HEXIST,HSET,NNCHA,XXMIN,XXMAX, 419 - - NNENTR,AVER,SIGMA) 420 - * Variables already in use ? 421 - DO 250 ISTR=2,NARG 422 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 423 - 250 CONTINUE 424 - * Transfer information. 425 - IF(NARG.GE.2)THEN 426 - IF(HEXIST)THEN 427 - ARG(2)=1 428 - ELSE 429 - ARG(2)=0 1 370 P=HISTOGRA D=HISCAL 6 PAGE 464 430 - ENDIF 431 - ENDIF 432 - IF(NARG.GE.3)THEN 433 - MODARG(2)=3 434 - IF(HSET)THEN 435 - ARG(3)=1 436 - ELSE 437 - ARG(3)=0 438 - ENDIF 439 - MODARG(3)=3 440 - ENDIF 441 - IF(NARG.GE.4)THEN 442 - ARG(4)=REAL(NNCHA) 443 - MODARG(4)=2 444 - ENDIF 445 - IF(NARG.GE.5)THEN 446 - ARG(5)=XXMIN 447 - MODARG(5)=2 448 - ENDIF 449 - IF(NARG.GE.6)THEN 450 - ARG(6)=XXMAX 451 - MODARG(6)=2 452 - ENDIF 453 - IF(NARG.GE.7)THEN 454 - ARG(7)=REAL(NNENTR) 455 - MODARG(7)=2 456 - ENDIF 457 - IF(NARG.GE.8)THEN 458 - ARG(8)=AVER 459 - MODARG(8)=2 460 - ENDIF 461 - IF(NARG.GE.9)THEN 462 - ARG(9)=SIGMA 463 - MODARG(9)=2 464 - ENDIF 465 - *** Convolute 2 histograms. 466 - ELSEIF(IPROC.EQ.-611)THEN 467 - * Check argument list. 468 - IF(NARG.NE.3.OR.MODARG(1).NE.4.OR.MODARG(2).NE.4.OR. 469 - - ARGREF(3,1).GE.2)THEN 470 - PRINT *,' !!!!!! HISCAL WARNING : Incorrect set of'// 471 - - ' arguments given to CONVOLUTE; nothing done.' 472 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 473 - RETURN 474 - ENDIF 475 - * Free memory associated with the return argument. 476 - CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) 477 - * Perform the convolution. 478 - CALL HISCNV(NINT(ARG(1)),NINT(ARG(2)),IREF,IFAIL1) 479 - * Check the return code. 480 - IF(IFAIL1.NE.0)THEN 481 - PRINT *,' !!!!!! HISCAL WARNING : Convolution'// 482 - - ' failed; no histogram returned.' 483 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 484 - ELSE 485 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 486 - ARG(3)=IREF 487 - MODARG(3)=4 488 - ENDIF 489 - *** Compute the barycentre of a histogram. 490 - ELSEIF(IPROC.EQ.-612)THEN 491 - * Check the argument list. 492 - IF(NARG.LT.2.OR.MODARG(1).NE.4.OR.ARGREF(2,1).GE.2.OR. 493 - - (NARG.GE.3.AND.MODARG(3).NE.2).OR. 494 - - NARG.GT.3)THEN 495 - PRINT *,' !!!!!! HISCAL WARNING : Incorrect set of'// 496 - - ' arguments given to BARYCENTRE; nothing done.' 497 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 498 - RETURN 499 - ENDIF 500 - * Free memory associated with the return argument. 501 - CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) 502 - * Pick up the number of bins. 503 - NBIN=3 504 - IF(NARG.GE.3)NBIN=NINT(ARG(3)) 505 - * Compute the barycentre. 506 - CALL HISBAR(NINT(ARG(1)),NBIN,ARG(2),IFAIL1) 507 - * Check the return code. 508 - IF(IFAIL1.NE.0)THEN 509 - PRINT *,' !!!!!! HISCAL WARNING : Barycentre'// 510 - - ' calculation failed; no value returned.' 511 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 512 - ELSE 513 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 514 - MODARG(2)=2 515 - ENDIF 516 - *** Copy a histogram to a matrix. 517 - ELSEIF(IPROC.EQ.-613)THEN 518 - * Check argument list. 519 - IF(NARG.LT.2.OR.NARG.GT.4.OR. 520 - - MODARG(1).NE.4.OR. 521 - - ARGREF(2,1).GE.2.OR. 522 - - (NARG.GE.3.AND.ARGREF(3,1).GE.2).OR. 523 - - (NARG.GE.4.AND.ARGREF(4,1).GE.2))THEN 524 - PRINT *,' !!!!!! HISCAL WARNING : Incorrect set of'// 525 - - ' arguments for HISTOGRAM_TO_MATRIX;'// 526 - - ' nothing done.' 527 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 528 - RETURN 529 - ENDIF 530 - * Check the histogram. 531 - IHISRF=NINT(ARG(1)) 532 - IF(IHISRF.LE.0.OR.IHISRF.GT.MXHIST)THEN 533 - PRINT *,' !!!!!! HISCAL WARNING : Invalid histogram'// 534 - - ' reference; no copied to a matrix.' 535 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 1 370 P=HISTOGRA D=HISCAL 7 PAGE 465 536 - RETURN 537 - ELSEIF((.NOT.HISUSE(IHISRF)).OR.(.NOT.SET(IHISRF)))THEN 538 - PRINT *,' !!!!!! HISCAL WARNING : Histogram not in'// 539 - - ' use or range not set; no copied to a matrix.' 540 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 541 - RETURN 542 - ENDIF 543 - * Free memory associated with the return argument. 544 - CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) 545 - IF(NARG.GE.3)CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) 546 - IF(NARG.GE.4)CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 547 - * Book a matrix for the contents. 548 - ISIZ(1)=NCHA(IHISRF) 549 - CALL MATADM('ALLOCATE',IMATRF,1,ISIZ,2,IFAIL1) 550 - * Locate the matrix. 551 - IMATSL=MATSLT(IMATRF) 552 - IF(IFAIL1.NE.0.OR.IMATSL.LE.0)THEN 553 - PRINT *,' !!!!!! HISCAL WARNING : Unable to obtain'// 554 - - ' matrix space ; histogram not copied.' 555 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 556 - RETURN 557 - ENDIF 558 - * Copy the histogram to a matrix. 559 - DO 50 I=1,NCHA(IHISRF) 560 - MVEC(MORG(IMATSL)+I)=CONTEN(IHISRF,I) 561 - 50 CONTINUE 562 - ARG(2)=IMATRF 563 - MODARG(2)=5 564 - * And copy the ranges if requested. 565 - IF(NARG.GE.3)THEN 566 - ARG(3)=XMIN(IHISRF) 567 - MODARG(3)=2 568 - ENDIF 569 - IF(NARG.GE.4)THEN 570 - ARG(4)=XMAX(IHISRF) 571 - MODARG(4)=2 572 - ENDIF 573 - * Seems to have worked. 574 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 575 - *** Copy a matrix to a histogram. 576 - ELSEIF(IPROC.EQ.-614)THEN 577 - * Check argument list. 578 - IF(NARG.GT.4.OR. 579 - - MODARG(1).NE.5.OR.MODARG(2).NE.2.OR.MODARG(3).NE.2.OR. 580 - - ARGREF(4,1).GE.2)THEN 581 - PRINT *,' !!!!!! HISCAL WARNING : Incorrect set of'// 582 - - ' arguments for MATRIX_TO_HISTOGRAM;'// 583 - - ' nothing done.' 584 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 585 - RETURN 586 - ENDIF 587 - * Check the matrix. 588 - IMATRF=NINT(ARG(1)) 589 - IMATSL=MATSLT(IMATRF) 590 - IF(IMATSL.LE.0)THEN 591 - PRINT *,' !!!!!! HISCAL WARNING : Invalid matrix'// 592 - - ' reference; no copied to a histogram.' 593 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 594 - RETURN 595 - ELSEIF(MDIM(IMATSL).NE.1)THEN 596 - PRINT *,' ------ HISCAL MESSAGE : Matrix is not'// 597 - - ' 1-dimensional; unfolded.' 598 - ENDIF 599 - * Free memory associated with the return argument. 600 - CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 601 - * Book a histogram for the contents. 602 - CALL HISADM('ALLOCATE',IHISRF,MLEN(IMATSL),ARG(2),ARG(3), 603 - - .FALSE.,IFAIL1) 604 - IF(IFAIL1.NE.0)THEN 605 - PRINT *,' !!!!!! HISCAL WARNING : Unable to obtain'// 606 - - ' histogram space ; matrix not copied.' 607 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 608 - RETURN 609 - ENDIF 610 - * Copy the histogram to a matrix. 611 - SX0(IHISRF)=0 612 - SX1(IHISRF)=0 613 - SX2(IHISRF)=0 614 - DO 60 I=1,NCHA(IHISRF) 615 - CONTEN(IHISRF,I)=MVEC(MORG(IMATSL)+I) 616 - XX=XMIN(IHISRF)+REAL(I-0.5)*(XMAX(IHISRF)-XMIN(IHISRF))/ 617 - - REAL(NCHA(IHISRF)) 618 - SX0(IHISRF)=SX0(IHISRF)+CONTEN(IHISRF,I) 619 - SX1(IHISRF)=SX1(IHISRF)+CONTEN(IHISRF,I)*XX 620 - SX2(IHISRF)=SX2(IHISRF)+CONTEN(IHISRF,I)*XX**2 621 - 60 CONTINUE 622 - NENTRY(IHISRF)=0 623 - ARG(4)=IHISRF 624 - MODARG(4)=4 625 - * Seems to have worked. 626 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 0 627-+ +SELF,IF=HIGZ. 628 - *** RZ output of an histogram. 629 - ELSEIF(IPROC.EQ.-615)THEN 630 - * Check argument list. 631 - IF(NARG.GT.3.OR. 632 - - (NARG.GE.1.AND.MODARG(1).NE.4.AND.MODARG(1).NE.1).OR. 633 - - (NARG.GE.2.AND.MODARG(2).NE.1).OR. 634 - - (NARG.GE.3.AND.MODARG(3).NE.1))THEN 635 - PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// 636 - - ' list for WRITE_HISTOGRAM_RZ; not written.' 637 - RETURN 638 - ENDIF 639 - * Check the histogram number. 640 - IF(NARG.LE.0)THEN 1 370 P=HISTOGRA D=HISCAL 8 PAGE 466 641 - IREF=0 642 - ELSEIF(MODARG(1).EQ.1)THEN 643 - CALL STRBUF('READ',NINT(ARG(1)),XTXT,NCXTXT,IFAIL1) 644 - IF(NCXTXT.LE.0)NCXTXT=1 645 - CALL CLTOU(XTXT(1:NCXTXT)) 646 - IF(XTXT(1:NCXTXT).EQ.'ALL')THEN 647 - IREF=0 648 - ELSE 649 - PRINT *,' !!!!!! HISCAL WARNING : Invalid'// 650 - - ' histogram identifier; nothing written.' 651 - RETURN 652 - ENDIF 653 - ELSEIF(MODARG(1).EQ.4)THEN 654 - IREF=NINT(ARG(1)) 655 - ELSE 656 - PRINT *,' !!!!!! HISCAL WARNING : Invalid'// 657 - - ' histogram identifier; nothing written.' 658 - RETURN 659 - ENDIF 660 - * Fetch the file name. 661 - IF(NARG.GE.2)THEN 662 - CALL STRBUF('READ',NINT(ARG(2)),STRING,NC,IFAIL1) 663 - ELSE 664 - STRING='garfield.rz' 665 - NC=11 666 - IFAIL1=0 667 - ENDIF 668 - * Fetch the title. 669 - IF(NARG.GE.3)THEN 670 - CALL STRBUF('READ',NINT(ARG(3)),TITLE,NCTITL,IFAIL2) 671 - IF(NCTITL.LE.0)THEN 672 - TITLE=' ' 673 - NCTITL=1 674 - ENDIF 675 - ELSE 676 - TITLE=' ' 677 - NCTITL=1 678 - IFAIL2=0 679 - ENDIF 680 - * Check fetches. 681 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN 682 - PRINT *,' !!!!!! HISCAL WARNING : Unable to fetch an'// 683 - - ' argument of WRITE_HISTOGRAM_RZ; no write.' 684 - RETURN 685 - ENDIF 686 - * Write all histograms. 687 - IF(IREF.EQ.0)THEN 688 - NHIST=0 689 - DO 70 I=1,MXHIST 690 - IF(.NOT.HISUSE(I))GOTO 70 691 - TITLE='Histogram ' 692 - CALL OUTFMT(REAL(I),2,TITLE(11:),NCTITL,'LEFT') 693 - NCTITL=NCTITL+11 694 - DO 80 J=1,NGLB 695 - IF(GLBMOD(J).EQ.4.AND.NINT(GLBVAL(J)).EQ.I)THEN 696 - TITLE=GLBVAR(J) 697 - NCTITL=LEN(GLBVAR(J)) 698 - ENDIF 699 - 80 CONTINUE 700 - IF(.NOT.SET(I))THEN 701 - PRINT *,' !!!!!! HISCAL WARNING : '// 702 - - TITLE(1:NCTITL)//' not written to the RZ'// 703 - - ' file because the range is not set.' 704 - ELSE 705 - PRINT *,' ------ HISCAL MESSAGE : Writing '// 706 - - TITLE(1:NCTITL) 707 - CALL HISRZO(I,STRING(1:NC),TITLE(1:NCTITL), 708 - - IFAIL1) 709 - IF(IFAIL1.NE.0)THEN 710 - PRINT *,' !!!!!! HISCAL WARNING : Writing '// 711 - - TITLE(1:NCTITL)//' failed.' 712 - ELSE 713 - NHIST=NHIST+1 714 - ENDIF 715 - ENDIF 716 - 70 CONTINUE 717 - PRINT *,' ------ HISCAL MESSAGE : ',NHIST, 718 - - ' Histograms written to the RZ file.' 719 - * Write only 1 histogram. 720 - ELSE 721 - IF(NARG.LT.3.AND.ARGREF(1,2).GE.1.AND. 722 - - ARGREF(1,2).LE.NGLB)THEN 723 - TITLE=GLBVAR(ARGREF(1,2)) 724 - NCTITL=LEN(GLBVAR(ARGREF(1,2))) 725 - ENDIF 726 - CALL HISRZO(IREF,STRING(1:NC),TITLE(1:NCTITL),IFAIL1) 727 - IF(IFAIL1.NE.0)THEN 728 - PRINT *,' !!!!!! HISCAL WARNING : Writing in RZ'// 729 - - ' format failed.' 730 - RETURN 731 - ENDIF 732 - ENDIF 0 733-+ +SELF. 734 - *** Cut an histogram. 735 - ELSEIF(IPROC.EQ.-616)THEN 736 - * Check argument list. 737 - IF(NARG.NE.4.OR.MODARG(1).NE.4.OR. 738 - - MODARG(2).NE.2.OR.MODARG(3).NE.2.OR. 739 - - ARGREF(4,1).GE.2)THEN 740 - PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// 741 - - ' list for CUT_HISTOGRAM; no sub-range.' 742 - RETURN 743 - ENDIF 744 - * Take the sub-range. 745 - CALL HISCUT(NINT(ARG(1)),ARG(2),ARG(3),IREF,IFAIL1) 1 370 P=HISTOGRA D=HISCAL 9 PAGE 467 746 - IF(IFAIL1.NE.0)THEN 747 - PRINT *,' !!!!!! HISCAL WARNING : Cutting the'// 748 - - ' histogram failed; no sub-range.' 749 - RETURN 750 - ENDIF 751 - * Free memory associated with the return argument. 752 - CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 753 - * Return the histogram. 754 - ARG(4)=REAL(IREF) 755 - MODARG(4)=4 756 - *** Rebin an histogram. 757 - ELSEIF(IPROC.EQ.-617)THEN 758 - * Check argument list. 759 - IF(NARG.NE.3.OR.MODARG(1).NE.4.OR. 760 - - MODARG(2).NE.2.OR. 761 - - ARGREF(3,1).GE.2)THEN 762 - PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// 763 - - ' list for REBIN_HISTOGRAM; not sub-range.' 764 - RETURN 765 - ENDIF 766 - * Take the sub-range. 767 - CALL HISREB(NINT(ARG(1)),NINT(ARG(2)),IREF,IFAIL1) 768 - IF(IFAIL1.NE.0)THEN 769 - PRINT *,' !!!!!! HISCAL WARNING : Rebinning the'// 770 - - ' histogram failed; no rebinned histogram.' 771 - RETURN 772 - ENDIF 773 - * Free memory associated with the return argument. 774 - CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) 775 - * Return the histogram. 776 - ARG(3)=REAL(IREF) 777 - MODARG(3)=4 778 - *** Reset the contents of an histogram. 779 - ELSEIF(IPROC.EQ.-618)THEN 780 - * Without arguments, reset all histograms. 781 - IF(NARG.LT.1)THEN 782 - DO 100 I=1,NGLB 783 - IF(GLBMOD(I).EQ.4)CALL HISRES(NINT(GLBVAL(I)),IFAIL1) 784 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! HISCAL WARNING :'// 785 - - ' Failed to delete histogram '//GLBVAR(I) 786 - 100 CONTINUE 787 - ELSE 788 - DO 90 I=1,NARG 789 - IF(MODARG(I).NE.4)THEN 790 - PRINT *,' !!!!!! HISCAL WARNING : Argument ',I, 791 - - ' of RESET_HISTOGRAM is not an histogram;'// 792 - - ' not reset.' 793 - ELSEIF(ARGREF(I,1).GE.2)THEN 794 - PRINT *,' !!!!!! HISCAL WARNING : Argument ',I, 795 - - ' of RESET_HISTOGRAM is not modifiable;'// 796 - - ' not reset.' 797 - ELSE 798 - CALL HISRES(NINT(ARG(I)),IFAIL1) 799 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! HISCAL'// 800 - - ' WARNING : Failed to delete histogram '// 801 - - ' for argument ',I 802 - ENDIF 803 - 90 CONTINUE 804 - ENDIF 805 - *** Cumulate an histogram. 806 - ELSEIF(IPROC.EQ.-619)THEN 807 - * Check argument list. 808 - IF(NARG.NE.2.OR.MODARG(1).NE.4)THEN 809 - PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// 810 - - ' list for CUMULATE_HISTOGRAM; not output.' 811 - RETURN 812 - ENDIF 813 - * Take the sub-range. 814 - CALL HISCUM(NINT(ARG(1)),IREF,IFAIL1) 815 - IF(IFAIL1.NE.0)THEN 816 - PRINT *,' !!!!!! HISCAL WARNING : Unable to create'// 817 - - ' a cumulative histogram; no output.' 818 - RETURN 819 - ENDIF 820 - * Free memory associated with the return argument. 821 - CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) 822 - * Return the histogram. 823 - ARG(2)=REAL(IREF) 824 - MODARG(2)=4 825 - *** Unknown matrix operation. 826 - ELSE 827 - PRINT *,' !!!!!! HISCAL WARNING : Unknown procedure code'// 828 - - ' received; nothing done.' 829 - IFAIL=1 830 - RETURN 831 - ENDIF 832 - *** Seems to have worked. 833 - IFAIL=0 834 - END 371 GARFIELD ================================================== P=HISTOGRA D=HISCNV 1 ============================ 0 + +DECK,HISCNV. 1 - SUBROUTINE HISCNV(IREF1,IREF2,IREF3,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HISCNV - Convolutes histograms IREF1 and IREF2 to yield IREF3. 4 - * (Last changed on 4/ 2/96.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,HISTDATA. 8 - INTEGER IREF1,IREF2,IREF3,IFAIL 9 - REAL BIN1,BIN2 10 - *** Preset IREF3 to 0, i.e. non-existing. 11 - IREF3=0 12 - IFAIL=1 13 - *** Ensure that both IREF1 and IREF2 exist and have a range. 1 371 P=HISTOGRA D=HISCNV 2 PAGE 468 14 - IF(IREF1.LE.0.OR.IREF1.GT.MXHIST.OR. 15 - - IREF2.LE.0.OR.IREF2.GT.MXHIST)THEN 16 - PRINT *,' !!!!!! HISCNV WARNING : Histogram reference'// 17 - - ' not valid; no convolution.' 18 - RETURN 19 - ELSEIF((.NOT.SET(IREF1)).OR.(.NOT.SET(IREF2)))THEN 20 - PRINT *,' !!!!!! HISCNV WARNING : The scale of an'// 21 - - ' input histogram is not yet set; no convolution.' 22 - RETURN 23 - ELSEIF(NCHA(IREF1).LE.0.OR.NCHA(IREF2).LE.0)THEN 24 - PRINT *,' !!!!!! HISCNV WARNING : An input histogram'// 25 - - ' has no bins; no convolution.' 26 - RETURN 27 - ENDIF 28 - *** Check the compatibility between the histograms. 29 - BIN1=(XMAX(IREF1)-XMIN(IREF1))/NCHA(IREF1) 30 - BIN2=(XMAX(IREF2)-XMIN(IREF2))/NCHA(IREF2) 31 - IF(ABS(BIN1-BIN2).GT.1E-4*(ABS(BIN1)+ABS(BIN2)))THEN 32 - PRINT *,' !!!!!! HISCNV WARNING : Bin size of the'// 33 - - ' histograms differs, no convolution.' 34 - RETURN 35 - ENDIF 36 - *** Obtain a new histogram. 37 - CALL HISADM('ALLOCATE',IREF3,NCHA(IREF1)+NCHA(IREF2)-1, 38 - - XMIN(IREF1)+XMIN(IREF2)+(BIN1+BIN2)/4, 39 - - XMAX(IREF1)+XMAX(IREF2)-(BIN1+BIN2)/4, 40 - - .FALSE.,IFAIL1) 41 - IF(IFAIL1.NE.0)THEN 42 - PRINT *,' !!!!!! HISCNV WARNING : Unable to obtain an'// 43 - - ' output histogram; no convolution.' 44 - RETURN 45 - ENDIF 46 - *** Now perform the convolution. 47 - DO 10 I=1,NCHA(IREF3) 48 - CONTEN(IREF3,I)=0 49 - DO 20 J=1,NCHA(IREF1) 50 - IF(I-J+1.LT.1.OR.I-J+1.GT.NCHA(IREF2))GOTO 20 51 - CONTEN(IREF3,I)=CONTEN(IREF3,I)+ 52 - - CONTEN(IREF1,J)*CONTEN(IREF2,I-J+1) 53 - 20 CONTINUE 54 - 10 CONTINUE 55 - *** Seems to have worked. 56 - IFAIL=0 57 - END 372 GARFIELD ================================================== P=HISTOGRA D=HISCUM 1 ============================ 0 + +DECK,HISCUM. 1 - SUBROUTINE HISCUM(IREFI,IREFO,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HISCUM - Creates a cumulative version of a histogram. 4 - * (Last changed on 24/ 7/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,HISTDATA. 9.- +SEQ,PRINTPLOT. 10 - INTEGER IREFI,IREFO,IFAIL,IFAIL1,I 11 - *** Assume that things will work. 12 - IFAIL=0 13 - *** Check reference number. 14 - IF(IREFI.LE.0)THEN 15 - PRINT *,' !!!!!! HISCUM WARNING : Histogram reference'// 16 - - ' not valid; no cumulative version returned.' 17 - IFAIL=1 18 - RETURN 19 - * See whether the histogram is in use. 20 - ELSEIF(.NOT.HISUSE(IREFI))THEN 21 - PRINT *,' !!!!!! HISCUM WARNING : Histogram is not'// 22 - - ' currently in use; no cumulative version.' 23 - RETURN 24 - * See whether the range is set. 25 - ELSEIF(.NOT.SET(IREFI))THEN 26 - PRINT *,' !!!!!! HISCUM WARNING : Range not yet set;'// 27 - - ' no cumulative version.' 28 - RETURN 29 - ENDIF 30 - *** Book an histogram with the same dimensions. 31 - CALL HISADM('ALLOCATE',IREFO,NCHA(IREFI), 32 - - XMIN(IREFI),XMAX(IREFI),.FALSE.,IFAIL1) 33 - IF(IFAIL1.NE.0)THEN 34 - PRINT *,' !!!!!! HISCUM WARNING : Unable to create an'// 35 - - ' histogram; no cumulative version returned.' 36 - IFAIL=1 37 - RETURN 38 - ENDIF 39 - *** Produce a cumulative histogram. 40 - CONTEN(IREFO,0)=CONTEN(IREFI,0) 41 - DO 40 I=1,NCHA(IREFI)+1 42 - CONTEN(IREFO,I)=CONTEN(IREFO,I-1)+CONTEN(IREFI,I) 43 - 40 CONTINUE 44 - *** Copy entries and summing information. 45 - SX0(IREFO)=SX0(IREFI) 46 - SX1(IREFO)=SX1(IREFI) 47 - SX2(IREFO)=SX2(IREFI) 48 - NENTRY(IREFO)=NENTRY(IREFI) 49 - END 373 GARFIELD ================================================== P=HISTOGRA D=HISCUT 1 ============================ 0 + +DECK,HISCUT. 1 - SUBROUTINE HISCUT(IREF1,X0,X1,IREF2,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HISCUT - Cuts a piece from a histogram. 4 - * (Last changed on 12/ 9/99.) 5 - *----------------------------------------------------------------------- 1 373 P=HISTOGRA D=HISCUT 2 PAGE 469 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,HISTDATA. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,GLOBALS. 11 - INTEGER IREF1,IREF2,IFAIL,IFAIL1,I0,I1,I,IAUX 12 - REAL X0,X1,XX0,XX1 13 - *** Assume this will fail. 14 - IFAIL=1 15 - *** Check reference number. 16 - IF(IREF1.LE.0.OR.IREF1.GT.MXHIST)THEN 17 - PRINT *,' !!!!!! HISCUT WARNING : Invalid histogram'// 18 - - ' reference; no sub-range.' 19 - RETURN 20 - * See whether the histogram is in use. 21 - ELSEIF(.NOT.HISUSE(IREF1))THEN 22 - PRINT *,' !!!!!! HISCUT WARNING : Histogram is not'// 23 - - ' currently in use; no sub-range.' 24 - RETURN 25 - * See whether the range is set. 26 - ELSEIF(.NOT.SET(IREF1))THEN 27 - PRINT *,' !!!!!! HISCUT WARNING : Range not yet set;'// 28 - - ' no sub-range.' 29 - RETURN 30 - * Ensure that the range at least partially overlaps. 31 - ELSEIF(MAX(X0,X1).LT.XMIN(IREF1).OR. 32 - - MIN(X0,X1).GT.XMAX(IREF1))THEN 33 - PRINT *,' !!!!!! HISCUT WARNING : Sub-range does not'// 34 - - ' overlap with histogram range ; no sub-range.' 35 - RETURN 36 - * Warn if there is only a partial overlap. 37 - ELSEIF((XMIN(IREF1)-X0)*(X0-XMAX(IREF1)).LT.0.OR. 38 - - (XMIN(IREF1)-X1)*(X1-XMAX(IREF1)).LT.0)THEN 39 - PRINT *,' ------ HISCUT MESSAGE : Sub-range overlaps'// 40 - - ' only partially with histogram range.' 41 - ENDIF 42 - *** Compute the parameters of the new histogram. 43 - I0=1+INT(REAL(NCHA(IREF1))*(X0-XMIN(IREF1))/ 44 - - (XMAX(IREF1)-XMIN(IREF1))) 45 - I1=1+INT(REAL(NCHA(IREF1))*(X1-XMIN(IREF1))/ 46 - - (XMAX(IREF1)-XMIN(IREF1))) 47 - * Reorder if needed. 48 - IF(I1.LT.I0)THEN 49 - IAUX=I1 50 - I1=I0 51 - I0=I1 52 - ENDIF 53 - * Verify boundaries. 54 - IF(I0.LT.1)I0=1 55 - IF(I1.GT.NCHA(IREF1))I1=NCHA(IREF1) 56 - IF(I0.GT.NCHA(IREF1).OR.I1.LT.1)THEN 57 - PRINT *,' !!!!!! HISCUT WARNING : Sub-range does not'// 58 - - ' overlap with histogram range ; no sub-range.' 59 - RETURN 60 - ENDIF 61 - * Ensure that there is at least 1 bin left. 62 - IF(I0.GE.I1)THEN 63 - PRINT *,' !!!!!! HISCUT WARNING : Sub-range overlaps'// 64 - - ' with less than 1 bin with histogram ; no sub-range.' 65 - RETURN 66 - ENDIF 67 - * Range. 68 - XX0=XMIN(IREF1)+(I0-1)*(XMAX(IREF1)-XMIN(IREF1))/ 69 - - REAL(NCHA(IREF1)) 70 - XX1=XMIN(IREF1)+I1*(XMAX(IREF1)-XMIN(IREF1))/REAL(NCHA(IREF1)) 71 - *** Allocate a new histogram. 72 - CALL HISADM('ALLOCATE',IREF2,I1-I0+1,XX0,XX1,.FALSE.,IFAIL1) 73 - * Ensure that this has worked. 74 - IF(IFAIL1.NE.0)THEN 75 - PRINT *,' !!!!!! HISCUT WARNING : Unable to allocate'// 76 - - ' space for the sub-range histogram.' 77 - RETURN 78 - ENDIF 79 - *** Fill the new histogram. 80 - CONTEN(IREF2,0)=CONTEN(IREF1,0) 81 - CONTEN(IREF2,NCHA(IREF2)+1)=CONTEN(IREF1,NCHA(IREF1)+1) 82 - DO 10 I=1,NCHA(IREF1) 83 - IF(I.LT.I0)THEN 84 - CONTEN(IREF2,0)=CONTEN(IREF2,0)+CONTEN(IREF1,I) 85 - ELSEIF(I.GE.I0.AND.I.LE.I1)THEN 86 - CONTEN(IREF2,I-I0+1)=CONTEN(IREF1,I) 87 - ELSE 88 - CONTEN(IREF2,NCHA(IREF2)+1)=CONTEN(IREF2,NCHA(IREF2)+1)+ 89 - - CONTEN(IREF1,I) 90 - ENDIF 91 - 10 CONTINUE 92 - *** Copy entries and summing information. 93 - SX0(IREF2)=SX0(IREF1) 94 - SX1(IREF2)=SX1(IREF1) 95 - SX2(IREF2)=SX2(IREF1) 96 - NENTRY(IREF2)=NENTRY(IREF1) 97 - *** Seems to have worked. 98 - IFAIL=0 99 - END 374 GARFIELD ================================================== P=HISTOGRA D=HISENT 1 ============================ 0 + +DECK,HISENT. 1 - SUBROUTINE HISENT(IREF,X,W) 2 - *----------------------------------------------------------------------- 3 - * HISENT - Routine storing entries in a histogram, taking care of the 4 - * range setting if requested. 5 - * (Last changed on 20/ 3/97.) 6 - *----------------------------------------------------------------------- 7 - implicit none 1 374 P=HISTOGRA D=HISENT 2 PAGE 470 8.- +SEQ,DIMENSIONS. 9.- +SEQ,HISTDATA. 10.- +SEQ,PRINTPLOT. 11 - REAL AUX(MXCHA),X,AVER,SIGMA,W,STEP 12 - INTEGER I,IREF,IND,NBIN,NADD1,NADD2 13 - *** Check reference number. 14 - IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN 15 - IF(LDEBUG)PRINT *,' ++++++ HISENT DEBUG : Entry ignored'// 16 - - ' because IREF=',IREF,' is not valid.' 17 - RETURN 18 - ENDIF 19 - *** Keep track of sum of entries and their squares. 20 - SX0(IREF)=SX0(IREF)+W 21 - SX1(IREF)=SX1(IREF)+W*X 22 - SX2(IREF)=SX2(IREF)+W*X**2 23 - NENTRY(IREF)=NENTRY(IREF)+1 24 - *** Histogram range has been set. 25 - IF(SET(IREF))THEN 26 - IND=1+INT(REAL(NCHA(IREF))*(X-XMIN(IREF))/ 27 - - (XMAX(IREF)-XMIN(IREF))) 28 - IF(IND.LT.0)THEN 29 - IND=0 30 - ELSEIF(IND.GT.NCHA(IREF))THEN 31 - IND=NCHA(IREF)+1 32 - ENDIF 33 - CONTEN(IREF,IND)=CONTEN(IREF,IND)+W 34 - *** Histogram range has not yet been set. 35 - ELSE 36 - ** Not yet enough entries to normalise. 37 - IF(NENTRY(IREF).LE.NCHA(IREF)/2)THEN 38 - CONTEN(IREF,2*NENTRY(IREF)-1)=X 39 - CONTEN(IREF,2*NENTRY(IREF))=W 40 - ** There are enough entries, but the total weight is near zero. 41 - ELSEIF(SX0(IREF).EQ.0)THEN 42 - PRINT *,' !!!!!! HISENT WARNING : Not yet able to'// 43 - - ' autoscale since the integrated weight is 0.' 44 - NENTRY(IREF)=0 45 - SX0(IREF)=0 46 - SX1(IREF)=0 47 - SX2(IREF)=0 48 - ** Normalise. 49 - ELSE 50 - * Compute average and width. 51 - AVER=REAL(SX1(IREF)/SX0(IREF)) 52 - SIGMA=REAL(SQRT(MAX(0.0D0,(SX2(IREF)-SX1(IREF)**2/ 53 - - SX0(IREF))/SX0(IREF)))) 54 - * If width is zero, then take either mean or arbitrarily 1. 55 - IF(SIGMA.LE.0)SIGMA=ABS(AVER) 56 - IF(SIGMA.LE.0)SIGMA=1 57 - * Determine a reasonable range for the histogram. 58 - XMIN(IREF)=AVER-3*SIGMA 59 - XMAX(IREF)=AVER+3*SIGMA 60 - IF(HISLIN(IREF))THEN 61 - CALL ROUND(XMIN(IREF),XMAX(IREF),NCHA(IREF), 62 - - 'LARGER,COARSER,INTEGER',STEP) 63 - XMIN(IREF)=XMIN(IREF)-0.5 64 - XMAX(IREF)=XMAX(IREF)-0.5 65 - ELSE 66 - CALL ROUND(XMIN(IREF),XMAX(IREF),NCHA(IREF), 67 - - 'LARGER,COARSER',STEP) 68 - ENDIF 69 - IF(STEP.LE.0)STEP=1 70 - NBIN=0.1+(XMAX(IREF)-XMIN(IREF))/STEP 71 - NADD1=(NBIN-NCHA(IREF))/2 72 - NADD2=NBIN-NCHA(IREF)-NADD1 73 - XMIN(IREF)=XMIN(IREF)+NADD1*STEP 74 - XMAX(IREF)=XMAX(IREF)-NADD2*STEP 75 - * Debugging output. 76 - IF(LDEBUG)PRINT *,' ++++++ HISENT DEBUG :'// 77 - - ' Range of histogram ',IREF,' has been set.' 78 - * Remember the range has been set. 79 - SET(IREF)=.TRUE. 80 - * Save the entries collected so far and reset the histogram. 81 - DO 10 I=1,NCHA(IREF) 82 - AUX(I)=CONTEN(IREF,I) 83 - CONTEN(IREF,I)=0.0 84 - 10 CONTINUE 85 - CONTEN(IREF,0)=0 86 - CONTEN(IREF,NCHA(IREF)+1)=0 87 - * Fill the histogram. 88 - DO 20 I=1,NCHA(IREF)/2-1,2 89 - IND=1+INT(REAL(NCHA(IREF))*(AUX(I)-XMIN(IREF))/ 90 - - (XMAX(IREF)-XMIN(IREF))) 91 - IF(IND.LT.0)THEN 92 - IND=0 93 - ELSEIF(IND.GT.NCHA(IREF))THEN 94 - IND=NCHA(IREF)+1 95 - ENDIF 96 - CONTEN(IREF,IND)=CONTEN(IREF,IND)+AUX(I+1) 97 - 20 CONTINUE 98 - ENDIF 99 - ENDIF 100 - END 375 GARFIELD ================================================== P=HISTOGRA D=HISFEX 1 ============================ 0 + +DECK,HISFEX. 1 - SUBROUTINE HISFEX(IREF,OPTION,PAR,ERR,NPAR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HISFEX - Fits an exponential of a polynomial to a histogram. 4 - * (Last changed on 27/ 6/96.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,HISTDATA. 8.- +SEQ,PRINTPLOT. 9 - LOGICAL LSQRT,LPRINT,LPLOT 1 375 P=HISTOGRA D=HISFEX 2 PAGE 471 10 - CHARACTER*(*) OPTION 11 - REAL PAR(*),ERR(*), 12 - - X(MXCHA),Y(MXCHA),EY(MXCHA),XPL(MXLIST),YPL(MXLIST) 13 - DOUBLE PRECISION AA(MXFPAR),EA(MXFPAR),XX,YY 14 - INTEGER IFAIL,IFAIL1,NPAR 15 - *** Assume the fit will fail. 16 - IFAIL=1 17 - *** Check reference number. 18 - IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN 19 - PRINT *,' !!!!!! HISFEX WARNING : Histogram reference'// 20 - - ' not valid; histogram not fitted.' 21 - RETURN 22 - *** No entries yet. 23 - ELSEIF(NENTRY(IREF).EQ.0.OR.SX0(IREF).EQ.0)THEN 24 - PRINT *,' !!!!!! HISFEX WARNING : Histogram has no'// 25 - - ' entries yet; histogram not fitted.' 26 - RETURN 27 - *** Range not yet set. 28 - ELSEIF(.NOT.SET(IREF))THEN 29 - PRINT *,' !!!!!! HISFEX WARNING : Range of this auto'// 30 - - 'range histogram not yet set; histogram not fitted.' 31 - RETURN 32 - ENDIF 33 - *** Decode the option string. 34 - LSQRT=.TRUE. 35 - LPRINT=.FALSE. 36 - LPLOT=.FALSE. 37 - IF(INDEX(OPTION,'NOPLOT').NE.0)THEN 38 - LPLOT=.FALSE. 39 - ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN 40 - LPLOT=.TRUE. 41 - ENDIF 42 - IF(INDEX(OPTION,'NOPRINT').NE.0)THEN 43 - LPRINT=.FALSE. 44 - ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN 45 - LPRINT=.TRUE. 46 - ENDIF 47 - IF(INDEX(OPTION,'EQUAL').NE.0)THEN 48 - LSQRT=.FALSE. 49 - ELSEIF(INDEX(OPTION,'POISSON').NE.0)THEN 50 - LSQRT=.TRUE. 51 - ENDIF 52 - *** Prepare the arrays. 53 - DO 10 I=1,NCHA(IREF) 54 - X(I)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) 55 - Y(I)=CONTEN(IREF,I) 56 - IF(LSQRT)THEN 57 - EY(I)=SQRT(Y(I)+1) 58 - ELSE 59 - EY(I)=1 60 - ENDIF 61 - 10 CONTINUE 62 - *** Call the fitting routine. 63 - CALL EXPFIT(X,Y,EY,NCHA(IREF),LPRINT,AA,EA,NPAR,IFAIL1) 64 - IF(IFAIL1.NE.0)THEN 65 - PRINT *,' !!!!!! HISFEX WARNING : The exponential fit'// 66 - - ' failed.' 67 - RETURN 68 - ENDIF 69 - DO 15 I=1,NPAR 70 - PAR(I)=REAL(AA(I)) 71 - ERR(I)=REAL(EA(I)) 72 - 15 CONTINUE 73 - *** Make a plot of the fit, start plotting the frame. 74 - IF(LPLOT)THEN 75 - * Switch to logarithmic scale. 76 - CALL GRAOPT('LIN-X, LOG-Y') 77 - * Make the plot. 78 - CALL HISPLT(IREF,'Coordinate','Histogram',.TRUE.) 79 - * Plot the error bars. 80 - CALL GRATTS('FUNCTION-1','POLYLINE') 81 - IF(LSQRT)THEN 82 - DO 20 I=1,NCHA(IREF) 83 - XPL(1)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/ 84 - - REAL(NCHA(IREF)) 85 - YPL(1)=Y(I)+EY(I) 86 - XPL(2)=XPL(1) 87 - YPL(2)=Y(I)-EY(I) 88 - CALL GRLINE(2,XPL,YPL) 89 - 20 CONTINUE 90 - ENDIF 91 - * Prepare the plot vector. 92 - DO 30 I=1,MXLIST 93 - XPL(I)=XMIN(IREF)+REAL(I-1)*(XMAX(IREF)-XMIN(IREF))/ 94 - - REAL(MXLIST-1) 95 - XX=XPL(I) 96 - CALL EXPFUN(XX,AA,YY) 97 - YPL(I)=YY 98 - 30 CONTINUE 99 - * Set the attributes. 100 - CALL GRATTS('FUNCTION-2','POLYLINE') 101 - * Plot the line itself. 102 - CALL GRLINE(MXLIST,XPL,YPL) 103 - * Close the plot. 104 - CALL GRNEXT 105 - * Switch to normal mode. 106 - CALL GRAOPT('LIN-X, LIN-Y') 107 - * Register the plot. 108 - CALL GRALOG('Exponential fit to a histogram') 109 - ENDIF 110 - *** Seems to have worked. 111 - IFAIL=0 112 - END 1 376 GARFIELD ================================================== P=HISTOGRA D=HISFPR 1 =================== PAGE 472 0 + +DECK,HISFPR. 1 - SUBROUTINE HISFPR(IREF,OPTION,FACT,OFF,SLOPE,THETA, 2 - - EFACT,EOFF,ESLOPE,ETHETA,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * HISFPR - Fits a Polya distribution to a histogram. 5 - * (Last changed on 19/ 8/96.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,HISTDATA. 9.- +SEQ,PRINTPLOT. 10 - LOGICAL LSQRT,LAUTO,LSCALE,LPRINT,LPLOT 11 - CHARACTER*(*) OPTION 12 - REAL FACT,OFF,SLOPE,THETA,EFACT,EOFF,ESLOPE,ETHETA, 13 - - X(MXCHA),Y(MXCHA),EY(MXCHA),XPL(MXLIST),YPL(MXLIST) 14 - DOUBLE PRECISION AA(4),EA(4),XX,YY 15 - INTEGER IFAIL,IFAIL1 16 - *** Assume the fit will fail. 17 - IFAIL=1 18 - *** Check reference number. 19 - IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN 20 - PRINT *,' !!!!!! HISFPR WARNING : Histogram reference'// 21 - - ' not valid; histogram not fitted.' 22 - RETURN 23 - *** No entries yet. 24 - ELSEIF(NENTRY(IREF).EQ.0.OR.SX0(IREF).EQ.0)THEN 25 - PRINT *,' !!!!!! HISFPR WARNING : Histogram has no'// 26 - - ' entries yet; histogram not fitted.' 27 - RETURN 28 - *** Range not yet set. 29 - ELSEIF(.NOT.SET(IREF))THEN 30 - PRINT *,' !!!!!! HISFPR WARNING : Range of this auto'// 31 - - 'range histogram not yet set; histogram not fitted.' 32 - RETURN 33 - ENDIF 34 - *** Decode the option string. 35 - LSQRT=.TRUE. 36 - LPRINT=.FALSE. 37 - LPLOT=.FALSE. 38 - LAUTO=.TRUE. 39 - LSCALE=.TRUE. 40 - IF(INDEX(OPTION,'NOPLOT').NE.0)THEN 41 - LPLOT=.FALSE. 42 - ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN 43 - LPLOT=.TRUE. 44 - ENDIF 45 - IF(INDEX(OPTION,'NOPRINT').NE.0)THEN 46 - LPRINT=.FALSE. 47 - ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN 48 - LPRINT=.TRUE. 49 - ENDIF 50 - IF(INDEX(OPTION,'EQUAL').NE.0)THEN 51 - LSQRT=.FALSE. 52 - ELSEIF(INDEX(OPTION,'POISSON').NE.0)THEN 53 - LSQRT=.TRUE. 54 - ENDIF 55 - IF(INDEX(OPTION,'FIT').NE.0)THEN 56 - LSCALE=.TRUE. 57 - ELSEIF(INDEX(OPTION,'FIX').NE.0)THEN 58 - LSCALE=.FALSE. 59 - ENDIF 60 - IF(INDEX(OPTION,'AUTO').NE.0)THEN 61 - LAUTO=.TRUE. 62 - ELSEIF(INDEX(OPTION,'MANUAL').NE.0)THEN 63 - LAUTO=.FALSE. 64 - ENDIF 65 - *** Prepare the arrays. 66 - DO 10 I=1,NCHA(IREF) 67 - X(I)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) 68 - Y(I)=CONTEN(IREF,I) 69 - IF(LSQRT)THEN 70 - EY(I)=SQRT(Y(I)+1) 71 - ELSE 72 - EY(I)=1 73 - ENDIF 74 - 10 CONTINUE 75 - *** Call the fitting routine. 76 - AA(1)=FACT 77 - AA(2)=THETA 78 - AA(3)=OFF 79 - AA(4)=SLOPE 80 - CALL PYAFIT(X,Y,EY,NCHA(IREF), 81 - - LPRINT,LSQRT,LSCALE,LAUTO,AA,EA,IFAIL1) 82 - IF(IFAIL1.NE.0)THEN 83 - PRINT *,' !!!!!! HISFPL WARNING : The Polya fit'// 84 - - ' failed.' 85 - RETURN 86 - ENDIF 87 - FACT=AA(1) 88 - THETA=AA(2) 89 - OFF=AA(3) 90 - SLOPE=AA(4) 91 - EFACT=EA(1) 92 - ETHETA=EA(2) 93 - EOFF=EA(3) 94 - ESLOPE=EA(4) 95 - *** Make a plot of the fit, start plotting the frame. 96 - IF(LPLOT)THEN 97 - * Switch to logarithmic scale. 98 - CALL GRAOPT('LIN-X, LOG-Y') 99 - * Make the plot. 100 - CALL HISPLT(IREF,'Coordinate','Histogram',.TRUE.) 101 - * Plot the error bars. 102 - CALL GRATTS('FUNCTION-1','POLYLINE') 103 - IF(LSQRT)THEN 104 - DO 20 I=1,NCHA(IREF) 105 - XPL(1)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/ 1 376 P=HISTOGRA D=HISFPR 2 PAGE 473 106 - - REAL(NCHA(IREF)) 107 - YPL(1)=Y(I)+EY(I) 108 - XPL(2)=XPL(1) 109 - YPL(2)=Y(I)-EY(I) 110 - CALL GRLINE(2,XPL,YPL) 111 - 20 CONTINUE 112 - ENDIF 113 - * Prepare the plot vector. 114 - DO 30 I=1,MXLIST 115 - XPL(I)=XMIN(IREF)+REAL(I-1)*(XMAX(IREF)-XMIN(IREF))/ 116 - - REAL(MXLIST-1) 117 - XX=XPL(I) 118 - CALL PYAFUN(XX,AA,YY) 119 - YPL(I)=YY 120 - 30 CONTINUE 121 - * Set the attributes. 122 - CALL GRATTS('FUNCTION-2','POLYLINE') 123 - * Plot the line itself. 124 - CALL GRLINE(MXLIST,XPL,YPL) 125 - * Close the plot. 126 - CALL GRNEXT 127 - * Switch to normal mode. 128 - CALL GRAOPT('LIN-X, LIN-Y') 129 - * Register the plot. 130 - CALL GRALOG('Polya fit to a histogram') 131 - ENDIF 132 - *** Seems to have worked. 133 - IFAIL=0 134 - END 377 GARFIELD ================================================== P=HISTOGRA D=HISFNR 1 ============================ 0 + +DECK,HISFNR. 1 - SUBROUTINE HISFNR(IREF,OPTION,FACT,AVER,SIGMA, 2 - - EFACT,EAVER,ESIGMA,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * HISFNR - Fits a Gaussian to a histogram. 5 - * (Last changed on 29/10/95.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,HISTDATA. 9.- +SEQ,PRINTPLOT. 10 - LOGICAL LSQRT,LPRINT,LPLOT 11 - CHARACTER*(*) OPTION 12 - REAL FACT,AVER,SIGMA,EFACT,EAVER,ESIGMA, 13 - - X(MXCHA),Y(MXCHA),EY(MXCHA),XPL(MXLIST),YPL(MXLIST) 14 - DOUBLE PRECISION AA(3),EA(3),XX,YY 15 - INTEGER IFAIL,IFAIL1 16 - *** Assume the fit will fail. 17 - IFAIL=1 18 - *** Check reference number. 19 - IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN 20 - PRINT *,' !!!!!! HISFNR WARNING : Histogram reference'// 21 - - ' not valid; histogram not fitted.' 22 - RETURN 23 - *** No entries yet. 24 - ELSEIF(NENTRY(IREF).EQ.0.OR.SX0(IREF).EQ.0)THEN 25 - PRINT *,' !!!!!! HISFNR WARNING : Histogram has no'// 26 - - ' entries yet; histogram not fitted.' 27 - RETURN 28 - *** Range not yet set. 29 - ELSEIF(.NOT.SET(IREF))THEN 30 - PRINT *,' !!!!!! HISFNR WARNING : Range of this auto'// 31 - - 'range histogram not yet set; histogram not fitted.' 32 - RETURN 33 - ENDIF 34 - *** Decode the option string. 35 - LSQRT=.TRUE. 36 - LPRINT=.FALSE. 37 - LPLOT=.FALSE. 38 - IF(INDEX(OPTION,'NOPLOT').NE.0)THEN 39 - LPLOT=.FALSE. 40 - ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN 41 - LPLOT=.TRUE. 42 - ENDIF 43 - IF(INDEX(OPTION,'NOPRINT').NE.0)THEN 44 - LPRINT=.FALSE. 45 - ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN 46 - LPRINT=.TRUE. 47 - ENDIF 48 - IF(INDEX(OPTION,'EQUAL').NE.0)THEN 49 - LSQRT=.FALSE. 50 - ELSEIF(INDEX(OPTION,'POISSON').NE.0)THEN 51 - LSQRT=.TRUE. 52 - ENDIF 53 - *** Prepare the arrays. 54 - DO 10 I=1,NCHA(IREF) 55 - X(I)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) 56 - Y(I)=CONTEN(IREF,I) 57 - IF(LSQRT)THEN 58 - EY(I)=SQRT(Y(I)+1) 59 - ELSE 60 - EY(I)=1 61 - ENDIF 62 - 10 CONTINUE 63 - *** Call the fitting routine. 64 - CALL NORFIT(X,Y,EY,NCHA(IREF),LPRINT,AA,EA,IFAIL1) 65 - IF(IFAIL1.NE.0)THEN 66 - PRINT *,' !!!!!! HISFNR WARNING : The Gaussian fit'// 67 - - ' failed.' 68 - RETURN 69 - ENDIF 70 - FACT=REAL(AA(1)) 71 - AVER=REAL(AA(2)) 72 - SIGMA=REAL(AA(3)) 73 - EFACT=REAL(EA(1)) 1 377 P=HISTOGRA D=HISFNR 2 PAGE 474 74 - EAVER=REAL(EA(2)) 75 - ESIGMA=REAL(EA(3)) 76 - *** Make a plot of the fit, start plotting the frame. 77 - IF(LPLOT)THEN 78 - CALL HISPLT(IREF,'Coordinate','Histogram',.TRUE.) 79 - * Plot the error bars. 80 - CALL GRATTS('FUNCTION-1','POLYLINE') 81 - IF(LSQRT)THEN 82 - DO 20 I=1,NCHA(IREF) 83 - XPL(1)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/ 84 - - REAL(NCHA(IREF)) 85 - YPL(1)=Y(I)+EY(I) 86 - XPL(2)=XPL(1) 87 - YPL(2)=Y(I)-EY(I) 88 - CALL GRLINE(2,XPL,YPL) 89 - 20 CONTINUE 90 - ENDIF 91 - * Prepare the plot vector. 92 - DO 30 I=1,MXLIST 93 - XPL(I)=XMIN(IREF)+REAL(I-1)*(XMAX(IREF)-XMIN(IREF))/ 94 - - REAL(MXLIST-1) 95 - XX=XPL(I) 96 - CALL NORFUN(XX,AA,YY) 97 - YPL(I)=YY 98 - 30 CONTINUE 99 - * Set the attributes. 100 - CALL GRATTS('FUNCTION-2','POLYLINE') 101 - * Plot the line itself. 102 - CALL GRLINE(MXLIST,XPL,YPL) 103 - * Close the plot. 104 - CALL GRNEXT 105 - * Register the plot. 106 - CALL GRALOG('Gaussian fit to a histogram.') 107 - ENDIF 108 - *** Seems to have worked. 109 - IFAIL=0 110 - END 378 GARFIELD ================================================== P=HISTOGRA D=HISFPL 1 ============================ 0 + +DECK,HISFPL. 1 - SUBROUTINE HISFPL(IREF,OPTION,PAR,ERR,NPAR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HISFPL - Fits a polynomial to a histogram. 4 - * (Last changed on 12/ 6/96.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,HISTDATA. 8.- +SEQ,PRINTPLOT. 9 - LOGICAL LSQRT,LPRINT,LPLOT 10 - CHARACTER*(*) OPTION 11 - REAL PAR(*),ERR(*), 12 - - X(MXCHA),Y(MXCHA),EY(MXCHA),XPL(MXLIST),YPL(MXLIST) 13 - DOUBLE PRECISION AA(MXFPAR),EA(MXFPAR),XX,YY 14 - INTEGER IFAIL,IFAIL1,NPAR 15 - *** Assume the fit will fail. 16 - IFAIL=1 17 - *** Check reference number. 18 - IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN 19 - PRINT *,' !!!!!! HISFPL WARNING : Histogram reference'// 20 - - ' not valid; histogram not fitted.' 21 - RETURN 22 - *** No entries yet. 23 - ELSEIF(NENTRY(IREF).EQ.0.OR.SX0(IREF).EQ.0)THEN 24 - PRINT *,' !!!!!! HISFPL WARNING : Histogram has no'// 25 - - ' entries yet; histogram not fitted.' 26 - RETURN 27 - *** Range not yet set. 28 - ELSEIF(.NOT.SET(IREF))THEN 29 - PRINT *,' !!!!!! HISFPL WARNING : Range of this auto'// 30 - - 'range histogram not yet set; histogram not fitted.' 31 - RETURN 32 - ENDIF 33 - *** Decode the option string. 34 - LSQRT=.TRUE. 35 - LPRINT=.FALSE. 36 - LPLOT=.FALSE. 37 - IF(INDEX(OPTION,'NOPLOT').NE.0)THEN 38 - LPLOT=.FALSE. 39 - ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN 40 - LPLOT=.TRUE. 41 - ENDIF 42 - IF(INDEX(OPTION,'NOPRINT').NE.0)THEN 43 - LPRINT=.FALSE. 44 - ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN 45 - LPRINT=.TRUE. 46 - ENDIF 47 - IF(INDEX(OPTION,'EQUAL').NE.0)THEN 48 - LSQRT=.FALSE. 49 - ELSEIF(INDEX(OPTION,'POISSON').NE.0)THEN 50 - LSQRT=.TRUE. 51 - ENDIF 52 - *** Prepare the arrays. 53 - DO 10 I=1,NCHA(IREF) 54 - X(I)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) 55 - Y(I)=CONTEN(IREF,I) 56 - IF(LSQRT)THEN 57 - EY(I)=SQRT(Y(I)+1) 58 - ELSE 59 - EY(I)=1 60 - ENDIF 61 - 10 CONTINUE 62 - *** Call the fitting routine. 63 - CALL POLFIT(X,Y,EY,NCHA(IREF),LPRINT,AA,EA,NPAR,IFAIL1) 64 - IF(IFAIL1.NE.0)THEN 65 - PRINT *,' !!!!!! HISFPL WARNING : The polynomial fit'// 1 378 P=HISTOGRA D=HISFPL 2 PAGE 475 66 - - ' failed.' 67 - RETURN 68 - ENDIF 69 - DO 15 I=1,NPAR 70 - PAR(I)=REAL(AA(I)) 71 - ERR(I)=REAL(EA(I)) 72 - 15 CONTINUE 73 - *** Make a plot of the fit, start plotting the frame. 74 - IF(LPLOT)THEN 75 - CALL HISPLT(IREF,'Coordinate','Histogram',.TRUE.) 76 - * Plot the error bars. 77 - CALL GRATTS('FUNCTION-1','POLYLINE') 78 - IF(LSQRT)THEN 79 - DO 20 I=1,NCHA(IREF) 80 - XPL(1)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/ 81 - - REAL(NCHA(IREF)) 82 - YPL(1)=Y(I)+EY(I) 83 - XPL(2)=XPL(1) 84 - YPL(2)=Y(I)-EY(I) 85 - CALL GRLINE(2,XPL,YPL) 86 - 20 CONTINUE 87 - ENDIF 88 - * Prepare the plot vector. 89 - DO 30 I=1,MXLIST 90 - XPL(I)=XMIN(IREF)+REAL(I-1)*(XMAX(IREF)-XMIN(IREF))/ 91 - - REAL(MXLIST-1) 92 - XX=XPL(I) 93 - CALL POLFUN(XX,AA,YY) 94 - YPL(I)=YY 95 - 30 CONTINUE 96 - * Set the attributes. 97 - CALL GRATTS('FUNCTION-2','POLYLINE') 98 - * Plot the line itself. 99 - CALL GRLINE(MXLIST,XPL,YPL) 100 - * Close the plot. 101 - CALL GRNEXT 102 - * Register the plot. 103 - CALL GRALOG('Polynomial fit to a histogram.') 104 - ENDIF 105 - *** Seems to have worked. 106 - IFAIL=0 107 - END 379 GARFIELD ================================================== P=HISTOGRA D=HISFFU 1 ============================ 0 + +DECK,HISFFU. 1 - SUBROUTINE HISFFU(IREF,FUN,OPTION,IA,IE,NPAR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HISFFU - Fits an arbitrary function to an histogram. 4 - * (Last changed on 19/ 2/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,HISTDATA. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,GLOBALS. 11 - LOGICAL LSQRT,LPRINT,LPLOT 12 - CHARACTER*(*) OPTION,FUN 13 - REAL X(MXCHA),Y(MXCHA),EY(MXCHA),XPL(MXLIST),YPL(MXLIST) 14 - DOUBLE PRECISION AA(MXFPAR),XX,YY 15 - INTEGER IFAIL,IFAIL1,NPAR,NNA,IIA,IA(*),IE(*),IREF,I,IENTRY 16 - COMMON /FFUDAT/ NNA,IENTRY,IIA(MXVAR) 17 - *** Assume the fit will fail. 18 - IFAIL=1 19 - *** Check reference number. 20 - IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN 21 - PRINT *,' !!!!!! HISFFU WARNING : Histogram reference'// 22 - - ' not valid; histogram not fitted.' 23 - RETURN 24 - *** No entries yet. 25 - ELSEIF(NENTRY(IREF).EQ.0.OR.SX0(IREF).EQ.0)THEN 26 - PRINT *,' !!!!!! HISFFU WARNING : Histogram has no'// 27 - - ' entries yet; histogram not fitted.' 28 - RETURN 29 - *** Range not yet set. 30 - ELSEIF(.NOT.SET(IREF))THEN 31 - PRINT *,' !!!!!! HISFFU WARNING : Range of this auto'// 32 - - 'range histogram not yet set; histogram not fitted.' 33 - RETURN 34 - ENDIF 35 - *** Decode the option string. 36 - LSQRT=.TRUE. 37 - LPRINT=.FALSE. 38 - LPLOT=.FALSE. 39 - IF(INDEX(OPTION,'NOPLOT').NE.0)THEN 40 - LPLOT=.FALSE. 41 - ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN 42 - LPLOT=.TRUE. 43 - ENDIF 44 - IF(INDEX(OPTION,'NOPRINT').NE.0)THEN 45 - LPRINT=.FALSE. 46 - ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN 47 - LPRINT=.TRUE. 48 - ENDIF 49 - IF(INDEX(OPTION,'EQUAL').NE.0)THEN 50 - LSQRT=.FALSE. 51 - ELSEIF(INDEX(OPTION,'POISSON').NE.0)THEN 52 - LSQRT=.TRUE. 53 - ENDIF 54 - *** Prepare the arrays. 55 - DO 10 I=1,NCHA(IREF) 56 - X(I)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) 57 - Y(I)=CONTEN(IREF,I) 58 - IF(LSQRT)THEN 59 - EY(I)=SQRT(Y(I)+1) 60 - ELSE 1 379 P=HISTOGRA D=HISFFU 2 PAGE 476 61 - EY(I)=1 62 - ENDIF 63 - 10 CONTINUE 64 - *** Call the fitting routine. 65 - CALL FUNFIT(FUN,X,Y,EY,NCHA(IREF),LPRINT,IA,IE,NPAR,IFAIL1) 66 - IF(IFAIL1.NE.0)THEN 67 - PRINT *,' !!!!!! HISFFU WARNING : The fit to ',FUN, 68 - - ' failed.' 69 - CALL ALGCLR(IENTRY) 70 - RETURN 71 - ENDIF 72 - *** Make a plot of the fit, start plotting the frame. 73 - IF(LPLOT)THEN 74 - * Make the plot. 75 - CALL HISPLT(IREF,'Coordinate','Histogram',.TRUE.) 76 - * Plot the error bars. 77 - CALL GRATTS('FUNCTION-1','POLYLINE') 78 - IF(LSQRT)THEN 79 - DO 20 I=1,NCHA(IREF) 80 - XPL(1)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/ 81 - - REAL(NCHA(IREF)) 82 - YPL(1)=Y(I)+EY(I) 83 - XPL(2)=XPL(1) 84 - YPL(2)=Y(I)-EY(I) 85 - CALL GRLINE(2,XPL,YPL) 86 - 20 CONTINUE 87 - ENDIF 88 - * Prepare the parameter list. 89 - DO 40 I=1,NPAR 90 - AA(I)=GLBVAL(IIA(I)) 91 - 40 CONTINUE 92 - * Prepare the plot vector. 93 - DO 30 I=1,MXLIST 94 - XPL(I)=XMIN(IREF)+REAL(I-1)*(XMAX(IREF)-XMIN(IREF))/ 95 - - REAL(MXLIST-1) 96 - XX=XPL(I) 97 - CALL FUNFUN(XX,AA,YY) 98 - YPL(I)=YY 99 - 30 CONTINUE 100 - * Set the attributes. 101 - CALL GRATTS('FUNCTION-2','POLYLINE') 102 - * Plot the line itself. 103 - CALL GRLINE(MXLIST,XPL,YPL) 104 - * Close the plot. 105 - CALL GRNEXT 106 - * Register the plot. 107 - CALL GRALOG('Function fit to a histogram') 108 - ENDIF 109 - *** We're now done with the function, so can delete the entry point. 110 - CALL ALGCLR(IENTRY) 111 - *** Seems to have worked. 112 - IFAIL=0 113 - END 380 GARFIELD ================================================== P=HISTOGRA D=HISFMS 1 ============================ 0 + +DECK,HISFMS. 1 - SUBROUTINE HISFMS(IREF,OPTION,S,XC,FACT,K3,EXC,EFACT,EK3,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HISFMS - Fits a Mathieson distribution to an histogram. 4 - * (Last changed on 17/ 4/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,HISTDATA. 9.- +SEQ,PRINTPLOT. 10 - LOGICAL LSQRT,LPRINT,LPLOT,LFITK3 11 - CHARACTER*(*) OPTION 12 - REAL S,FACT,XC,K3,EFACT,EXC,EK3,X(MXCHA),Y(MXCHA),EY(MXCHA), 13 - - XPL(MXLIST),YPL(MXLIST) 14 - DOUBLE PRECISION XX,YY,AA(6),EA(6) 15 - INTEGER IFAIL,IFAIL1,IREF,I 16 - *** Assume the fit will fail. 17 - IFAIL=1 18 - *** Check reference number. 19 - IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN 20 - PRINT *,' !!!!!! HISFMS WARNING : Histogram reference'// 21 - - ' not valid; histogram not fitted.' 22 - RETURN 23 - *** No entries yet. 24 - ELSEIF(SX0(IREF).EQ.0)THEN 25 - PRINT *,' !!!!!! HISFMS WARNING : Histogram has no'// 26 - - ' entries yet; histogram not fitted.' 27 - RETURN 28 - *** Range not yet set. 29 - ELSEIF(.NOT.SET(IREF))THEN 30 - PRINT *,' !!!!!! HISFMS WARNING : Range of this auto'// 31 - - 'range histogram not yet set; histogram not fitted.' 32 - RETURN 33 - ENDIF 34 - *** Decode the option string. 35 - LSQRT=.FALSE. 36 - LPRINT=.FALSE. 37 - LPLOT=.FALSE. 38 - LFITK3=.TRUE. 39 - IF(INDEX(OPTION,'NOPLOT').NE.0)THEN 40 - LPLOT=.FALSE. 41 - ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN 42 - LPLOT=.TRUE. 43 - ENDIF 44 - IF(INDEX(OPTION,'NOPRINT').NE.0)THEN 45 - LPRINT=.FALSE. 46 - ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN 47 - LPRINT=.TRUE. 48 - ENDIF 49 - IF(INDEX(OPTION,'EQUAL').NE.0)THEN 1 380 P=HISTOGRA D=HISFMS 2 PAGE 477 50 - LSQRT=.FALSE. 51 - ELSEIF(INDEX(OPTION,'POISSON').NE.0)THEN 52 - LSQRT=.TRUE. 53 - ENDIF 54 - IF(INDEX(OPTION,'NOFITK3').NE.0)THEN 55 - LFITK3=.FALSE. 56 - ELSEIF(INDEX(OPTION,'FITK3').NE.0)THEN 57 - LFITK3=.TRUE. 58 - ENDIF 59 - *** Prepare the arrays. 60 - DO 10 I=1,NCHA(IREF) 61 - X(I)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) 62 - Y(I)=CONTEN(IREF,I) 63 - IF(LSQRT)THEN 64 - EY(I)=SQRT(Y(I)+1) 65 - ELSE 66 - EY(I)=1 67 - ENDIF 68 - 10 CONTINUE 69 - *** Transfer the parameters that can be used for initialisation. 70 - AA(1)=XC 71 - AA(2)=FACT 72 - AA(3)=K3 73 - AA(6)=S 74 - *** Call the fitting routine. 75 - CALL MSNFIT(X,Y,EY,NCHA(IREF),LPRINT,LFITK3,AA,EA,IFAIL1) 76 - IF(IFAIL1.NE.0)THEN 77 - PRINT *,' !!!!!! HISFMS WARNING : The Mathieson fit'// 78 - - ' failed.' 79 - RETURN 80 - ENDIF 81 - *** Transfer the parameters back. 82 - XC=AA(1) 83 - EXC=EA(1) 84 - FACT=AA(2) 85 - EFACT=EA(2) 86 - K3=AA(3) 87 - EK3=EA(3) 88 - *** Make a plot of the fit, start plotting the frame. 89 - IF(LPLOT)THEN 90 - CALL HISPLT(IREF,'Coordinate','Histogram',.TRUE.) 91 - * Plot the error bars. 92 - CALL GRATTS('FUNCTION-1','POLYLINE') 93 - IF(LSQRT)THEN 94 - DO 20 I=1,NCHA(IREF) 95 - XPL(1)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/ 96 - - REAL(NCHA(IREF)) 97 - YPL(1)=Y(I)+EY(I) 98 - XPL(2)=XPL(1) 99 - YPL(2)=Y(I)-EY(I) 100 - CALL GRLINE(2,XPL,YPL) 101 - 20 CONTINUE 102 - ENDIF 103 - * Prepare the plot vector. 104 - DO 30 I=1,NCHA(IREF) 105 - XPL(I)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/ 106 - - REAL(NCHA(IREF)) 107 - XX=XPL(I) 108 - CALL MSNFUN(XX,AA,YY) 109 - YPL(I)=YY 110 - 30 CONTINUE 111 - * Set the attributes. 112 - CALL GRATTS('FUNCTION-2','POLYMARKER') 113 - * Plot the line itself. 114 - CALL GRMARK(NCHA(IREF),XPL,YPL) 115 - * Close the plot. 116 - CALL GRNEXT 117 - * Register the plot. 118 - CALL GRALOG('Mathieson fit to a histogram.') 119 - ENDIF 120 - *** Seems to have worked. 121 - IFAIL=0 122 - END 381 GARFIELD ================================================== P=HISTOGRA D=HISGET 1 ============================ 0 + +DECK,HISGET. 1 - SUBROUTINE HISGET(IREF,FILE,MEMB,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HISGET - This routine reads an histogram from a file. 4 - * VARIABLES : STRING : Character string that should contain a 5 - * description of the dataset being read. 6 - * (Last changed on 20/ 3/97.) 7 - *----------------------------------------------------------------------- 8.- +SEQ,DIMENSIONS. 9.- +SEQ,HISTDATA. 10.- +SEQ,PRINTPLOT. 11 - CHARACTER*(MXINCH) STRING 12 - CHARACTER*(*) FILE,MEMB 13 - CHARACTER*8 MEMBER 14 - CHARACTER*1 DUMMY 15 - LOGICAL DSNCMP,EXIS 16 - EXTERNAL DSNCMP 17 - *** Identify the routine, if requested. 18 - IF(LIDENT)PRINT *,' /// ROUTINE HISGET ///' 19 - *** Initialise IFAIL on 1 (i.e. fail). 20 - IFAIL=1 21 - *** Transfer variables. 22 - MEMBER=MEMB 23 - *** Initialise IREF so that HISADM always gets a valid argument. 24 - IREF=-1 25 - *** Open the dataset and inform DSNLOG. 26 - CALL DSNOPN(FILE,LEN(FILE),12,'READ-LIBRARY',IFAIL1) 27 - IF(IFAIL1.NE.0)THEN 28 - PRINT *,' !!!!!! HISGET WARNING : Opening ',FILE, 29 - - ' failed ; histogram not read.' 1 381 P=HISTOGRA D=HISGET 2 PAGE 478 30 - IFAIL=1 31 - RETURN 32 - ENDIF 33 - CALL DSNLOG(FILE,'Histogram ','Sequential','Read only ') 34 - IF(LDEBUG)PRINT *,' ++++++ HISGET DEBUG : Dataset ', 35 - - FILE,' opened on unit 12 for seq read.' 36 - * Locate the pointer on the header of the requested member. 37 - CALL DSNLOC(MEMBER,LEN(MEMBER),'HIST ',12,EXIS,'RESPECT') 38 - IF(.NOT.EXIS)THEN 39 - CALL DSNLOC(MEMBER,LEN(MEMBER),'HIST ',12,EXIS,'IGNORE') 40 - IF(EXIS)THEN 41 - PRINT *,' ###### HISGET ERROR : Histogram ',MEMBER, 42 - - ' has been deleted from ',FILE,'; not read.' 43 - ELSE 44 - PRINT *,' ###### HISGET ERROR : Histogram ',MEMBER, 45 - - ' not found on ',FILE,'.' 46 - ENDIF 47 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 48 - IFAIL=1 49 - RETURN 50 - ENDIF 51 - *** Check that the member is acceptable. 52 - READ(12,'(A80)',END=2000,IOSTAT=IOS,ERR=2010) STRING 53 - IF(DSNCMP('20- 3-97',STRING(11:18)))THEN 54 - PRINT *,' !!!!!! HISGET WARNING : Member ',STRING(32:39), 55 - - ' can not be read because of a change in format.' 56 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 57 - IFAIL=1 58 - RETURN 59 - ENDIF 60 - WRITE(LUNOUT,'('' Member '',A8,'' was created on '',A8, 61 - - '' at '',A8/'' Remarks: '',A29)') 62 - - STRING(32:39),STRING(11:18),STRING(23:30),STRING(51:79) 63 - *** Find a free histogram. 64 - CALL HISADM('ALLOCATE',IREF,1,0.0,0.0,.TRUE.,IFAIL1) 65 - IF(IFAIL1.NE.0)THEN 66 - PRINT *,' !!!!!! HISGET WARNING : Unable to obtain space'// 67 - - ' to store the histogram to be read; not read.' 68 - IFAIL=1 69 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 70 - RETURN 71 - ENDIF 72 - *** Execute read operations if a valid name is available. 73 - READ(12,'(/12X,E15.8/12X,E15.8/12X,I10/12X,L1/12X,L1/ 74 - - 12X,3E15.8/12X,I10)',IOSTAT=IOS,ERR=2010,END=2000) 75 - - XMIN(IREF),XMAX(IREF),NCHA(IREF),SET(IREF),HISLIN(IREF), 76 - - SX0(IREF),SX1(IREF),SX2(IREF),NENTRY(IREF) 77 - READ(12,'(A1)',IOSTAT=IOS,ERR=2010,END=2000) DUMMY 78 - DO 210 I=0,NCHA(IREF)+1 79 - READ(12,'(10X,E15.8)',IOSTAT=IOS,ERR=2010,END=2000) 80 - - CONTEN(IREF,I) 81 - 210 CONTINUE 82 - * Close the file after the operation. 83 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 84 - *** Register the amount of CPU time used for reading. 85 - CALL TIMLOG('Reading an histogram from a dataset: ') 86 - *** Things worked, reset the error flag. 87 - IFAIL=0 88 - RETURN 89 - *** Handle the I/O error conditions. 90 - 2000 CONTINUE 91 - PRINT *,' ###### HISGET ERROR : EOF encountered while', 92 - - ' reading ',FILE,' from unit 12 ; no histogram read.' 93 - CALL INPIOS(IOS) 94 - IF(IREF.NE.-1)CALL HISADM('DELETE',IREF,1,0.0,0.0,.TRUE.,IFAIL1) 95 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 96 - RETURN 97 - 2010 CONTINUE 98 - PRINT *,' ###### HISGET ERROR : Error while reading ', 99 - - FILE,' from unit 12 ; no histogram read.' 100 - CALL INPIOS(IOS) 101 - IF(IREF.NE.-1)CALL HISADM('DELETE',IREF,1,0.0,0.0,.TRUE.,IFAIL1) 102 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 103 - RETURN 104 - 2030 CONTINUE 105 - PRINT *,' ###### HISGET ERROR : Dataset ',FILE, 106 - - ' on unit 12 cannot be closed ; results not predictable.' 107 - CALL INPIOS(IOS) 108 - END 382 GARFIELD ================================================== P=HISTOGRA D=HISINT 1 ============================ 0 + +DECK,HISINT. 1 - SUBROUTINE HISINT 2 - *----------------------------------------------------------------------- 3 - * HISINT - Initialises the histogram system. 4 - * (Last changed on 9/10/93.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,PRINTPLOT. 8.- +SEQ,HISTDATA. 9 - DO 10 I=1,MXHIST 10 - DO 20 J=0,MXCHA+1 11 - CONTEN(I,J)=0.0 12 - 20 CONTINUE 13 - HISUSE(I)=.FALSE. 14 - HISLIN(I)=.FALSE. 15 - XMIN(I)=0.0 16 - XMAX(I)=1.0 17 - NCHA(I)=0 18 - SET(I)=.FALSE. 19 - SX0(I)=0.0D0 20 - SX1(I)=0.0D0 21 - SX2(I)=0.0D0 22 - NENTRY(I)=0 23 - 10 CONTINUE 1 382 P=HISTOGRA D=HISINT 2 PAGE 479 24 - END 383 GARFIELD ================================================== P=HISTOGRA D=HISINV 1 ============================ 0 + +DECK,HISINV. 1 - SUBROUTINE HISINV(IREF,EPS,XEPS,IORDER,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HISINV - Inverse interpolation to find XEPS such that P(X 0).'')') 25 - RETURN 26 - *** Straight dump for auto range histogram without set range. 27 - ELSEIF(.NOT.SET(IREF))THEN 28 - WRITE(LUNOUT,'(''1''/'' Title: '',A/'' Axis: '',A//, 29 - - '' This is an auto-range histogram for which the'', 30 - - '' range has not yet been set.''// 31 - - '' Entry Value'')') 32 - - TITLE,XTXT 33 - SUM0=0.0 34 - SUM1=0.0 35 - SUM2=0.0 36 - DO 10 I=1,NENTRY(IREF) 37 - CALL OUTFMT(CONTEN(IREF,I),2,AUX1,NCAUX1,'RIGHT') 38 - WRITE(LUNOUT,'(2X,I5,2X,A15)') I,AUX1 39 - SUM1=SUM1+CONTEN(IREF,I) 40 - 10 CONTINUE 41 - ELSE 42 - *** Determine maximum and minimum. 43 - HISMIN=CONTEN(IREF,1) 44 - HISMAX=CONTEN(IREF,1) 45 - DO 20 I=2,NCHA(IREF) 46 - HISMIN=MIN(HISMIN,CONTEN(IREF,I)) 47 - HISMAX=MAX(HISMAX,CONTEN(IREF,I)) 48 - 20 CONTINUE 49 - *** Set the scale of the printing axes. 50 - IF(HISMAX.LE.HISMIN)THEN 51 - DIV=0.0 52 - ELSE 53 - DIV=LEN(LINE)/(HISMAX-HISMIN) 54 - ENDIF 55 - *** Print the header for the histogram. 56 - WRITE(LUNOUT,'(''1''/'' Title: '',A/ 57 - - '' Axis: '',A/'' Reference: '',I4// 58 - - '' Bin Bin centre Contents'', 59 - - '' Histogram''/)') TITLE,XTXT,IREF 60 - *** Print the histogram. 61 - SUM0=CONTEN(IREF,0) 62 - SUM1=0.0 63 - SUM2=CONTEN(IREF,NCHA(IREF)+1) 64 - DO 30 I=1,NCHA(IREF) 65 - LINE='*****************************************'// 66 - - '*****************************************' 67 - IND=NINT(DIV*(CONTEN(IREF,I)-HISMIN)) 68 - IND=MIN(LEN(LINE),MAX(1,IND)) 69 - LINE(IND:)=' ' 70 - CALL OUTFMT(XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/ 71 - - REAL(NCHA(IREF)),2,AUX1,NCAUX1,'RIGHT') 72 - CALL OUTFMT(CONTEN(IREF,I),2,AUX2,NCAUX2,'RIGHT') 73 - WRITE(LUNOUT,'(2X,I3,2X,A15,2X,A15,2X,A)') 74 - - I,AUX1,AUX2,LINE(1:MAX(1,IND-1)) 75 - SUM1=SUM1+CONTEN(IREF,I) 76 - 30 CONTINUE 77 - SUM0=SUM0*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) 78 - SUM1=SUM1*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) 79 - SUM2=SUM2*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) 80 - ENDIF 81 - *** Print histogram statistics. 82 - WRITE(LUNOUT,'(/'' STATISTICS:''// 83 - - '' Entries : '',I8,'' (including under and overflow),''// 84 - - '' Underflow : '',E15.8, 85 - - '' (coordinates below '',E15.8,''),''/ 86 - - '' Contents : '',E15.8/ 87 - - '' Overflow : '',E15.8, 88 - - '' (coordinates above '',E15.8,''),''// 89 - - '' Average : '',E15.8/ 90 - - '' RMS : '',E15.8/)') 91 - - NENTRY(IREF),SUM0,XMIN(IREF),SUM1,SUM2,XMAX(IREF), 92 - - SX1(IREF)/SX0(IREF), 93 - - SQRT((SX2(IREF)-SX1(IREF)**2/SX0(IREF))/SX0(IREF)) 94 - END 386 GARFIELD ================================================== P=HISTOGRA D=HISPLT 1 ============================ 0 + +DECK,HISPLT. 1 - SUBROUTINE HISPLT(IREF,XTXT,TITLE,FRAME) 2 - *----------------------------------------------------------------------- 3 - * HISPLT - Plots a histogram via GRHIST. 4 - * (Last changed on 17/ 5/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,HISTDATA. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*(*) XTXT,TITLE 11 - CHARACTER*20 AUX1,AUX2,AUX3 12 - REAL AUX(0:MXCHA+1) 13 - INTEGER IREF,I,NC1,NC2,NC3 14 - LOGICAL FRAME 1 386 P=HISTOGRA D=HISPLT 2 PAGE 482 15 - *** Check reference number and scale setting. 16 - IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN 17 - PRINT *,' !!!!!! HISPLT WARNING : Histogram reference'// 18 - - ' not valid; plotting empty box.' 19 - IF(FRAME)CALL GRCART(-1.0,-1.0,1.0,1.0,' ',' ', 20 - - 'Invalid histogram reference') 21 - RETURN 22 - ENDIF 23 - IF(.NOT.SET(IREF))THEN 24 - PRINT *,' !!!!!! HISPLT WARNING : The scale of this'// 25 - - ' auto-range histogram is not yet set; no plot.' 26 - IF(FRAME)CALL GRCART(-1.0,-1.0,1.0,1.0,' ',' ', 27 - - 'Range not yet set') 28 - RETURN 29 - ENDIF 30 - *** Call GRHIST. 31 - DO 10 I=0,MXCHA+1 32 - AUX(I)=CONTEN(IREF,I) 33 - 10 CONTINUE 34 - CALL GRHIST(AUX,NCHA(IREF),XMIN(IREF),XMAX(IREF),XTXT,TITLE, 35 - - FRAME) 36 - *** Show contents, mean and RMS. 37 - IF(FRAME)THEN 38 - IF(SX0(IREF).EQ.0)THEN 39 - CALL GRCOMM(4,'Sum: 0, Mean and RMS undefined.') 40 - ELSE 41 - CALL OUTFMT(REAL(SX0(IREF)),2,AUX1,NC1,'LEFT') 42 - CALL OUTFMT(REAL(SX1(IREF)/SX0(IREF)), 43 - - 2,AUX2,NC2,'LEFT') 44 - CALL OUTFMT(REAL(SQRT(MAX(0.0D0, 45 - - (SX2(IREF)-SX1(IREF)**2/SX0(IREF))/SX0(IREF)))),2, 46 - - AUX3,NC3,'LEFT') 47 - CALL GRCOMM(4,'Sum: '//AUX1(1:NC1)//', Mean: '// 48 - - AUX2(1:NC2)//', RMS: '//AUX3(1:NC3)) 49 - ENDIF 50 - ENDIF 51 - END 387 GARFIELD ================================================== P=HISTOGRA D=HISREB 1 ============================ 0 + +DECK,HISREB. 1 - SUBROUTINE HISREB(IREF1,NGROUP,IREF2,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HISREB - Rebins a histogram. 4 - * (Last changed on 12/ 9/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,HISTDATA. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,GLOBALS. 11 - INTEGER IREF1,IREF2,IFAIL,IFAIL1,NGROUP,I,II,NBIN 12 - REAL X0,X1 13 - *** Assume this will fail. 14 - IFAIL=1 15 - *** Check reference number. 16 - IF(IREF1.LE.0.OR.IREF1.GT.MXHIST)THEN 17 - PRINT *,' !!!!!! HISREB WARNING : Invalid histogram'// 18 - - ' reference; no rebinning.' 19 - RETURN 20 - * See whether the histogram is in use. 21 - ELSEIF(.NOT.HISUSE(IREF1))THEN 22 - PRINT *,' !!!!!! HISREB WARNING : Histogram is not'// 23 - - ' currently in use; no rebinning.' 24 - RETURN 25 - * See whether the range is set. 26 - ELSEIF(.NOT.SET(IREF1))THEN 27 - PRINT *,' !!!!!! HISREB WARNING : Range not yet set;'// 28 - - ' no rebinning.' 29 - RETURN 30 - * Make sure that the grouping makes sense. 31 - ELSEIF(NGROUP.LE.1.OR.NGROUP.GT.NCHA(IREF1))THEN 32 - PRINT *,' !!!!!! HISREB WARNING : Number of bins to'// 33 - - ' be grouped out of range; no rebinning.' 34 - RETURN 35 - ELSEIF(NCHA(IREF1).NE.NGROUP*(NCHA(IREF1)/NGROUP))THEN 36 - PRINT *,' ------ HISREB MESSAGE : Grouping does not'// 37 - - ' divide number of bins; binned data will be lost.' 38 - ENDIF 39 - *** Compute the parameters of the new histogram. 40 - NBIN=NCHA(IREF1)/NGROUP 41 - X0=XMIN(IREF1) 42 - X1=X0+NBIN*NGROUP*(XMAX(IREF1)-XMIN(IREF1))/REAL(NCHA(IREF1)) 43 - *** Allocate a new histogram. 44 - CALL HISADM('ALLOCATE',IREF2,NBIN,X0,X1,.FALSE.,IFAIL1) 45 - * Ensure that this has worked. 46 - IF(IFAIL1.NE.0)THEN 47 - PRINT *,' !!!!!! HISREB WARNING : Unable to allocate'// 48 - - ' space for the rebinned histogram.' 49 - RETURN 50 - ENDIF 51 - *** Fill the new histogram. 52 - CONTEN(IREF2,0)=CONTEN(IREF1,0) 53 - CONTEN(IREF2,NCHA(IREF2)+1)=CONTEN(IREF1,NCHA(IREF1)+1) 54 - DO 10 I=1,NCHA(IREF1) 55 - II=1+(I-1)/NGROUP 56 - IF(II.LE.NBIN)THEN 57 - CONTEN(IREF2,II)=CONTEN(IREF2,II)+CONTEN(IREF1,I) 58 - ELSE 59 - CONTEN(IREF2,NCHA(IREF2)+1)=CONTEN(IREF1,NCHA(IREF1)+1)+ 60 - - CONTEN(IREF1,I) 61 - ENDIF 62 - 10 CONTINUE 63 - *** Copy entries and summing information. 64 - SX0(IREF2)=SX0(IREF1) 65 - SX1(IREF2)=SX1(IREF1) 1 387 P=HISTOGRA D=HISREB 2 PAGE 483 66 - SX2(IREF2)=SX2(IREF1) 67 - NENTRY(IREF2)=NENTRY(IREF1) 68 - *** Seems to have worked. 69 - IFAIL=0 70 - END 388 GARFIELD ================================================== P=HISTOGRA D=HISRES 1 ============================ 0 + +DECK,HISRES. 1 - SUBROUTINE HISRES(IREF,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HISRES - Resets the contents of a histogram to 0. 4 - * (Last changed on 13/11/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,HISTDATA. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,GLOBALS. 11 - INTEGER IREF,IFAIL,I 12 - *** Assume this will fail. 13 - IFAIL=1 14 - *** Check reference number. 15 - IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN 16 - PRINT *,' !!!!!! HISRES WARNING : Invalid histogram'// 17 - - ' reference; not reset.' 18 - RETURN 19 - * See whether the histogram is in use. 20 - ELSEIF(.NOT.HISUSE(IREF))THEN 21 - PRINT *,' !!!!!! HISRES WARNING : Histogram is not'// 22 - - ' currently in use; not reset.' 23 - RETURN 24 - ENDIF 25 - *** Reset the contents. 26 - DO 10 I=0,MXCHA+1 27 - CONTEN(IREF,I)=0.0 28 - 10 CONTINUE 29 - SX0(IREF)=0.0D0 30 - SX1(IREF)=0.0D0 31 - SX2(IREF)=0.0D0 32 - NENTRY(IREF)=0 33 - *** Seems to have worked. 34 - IFAIL=0 35 - END 389 GARFIELD ================================================== P=HISTOGRA D=HISRZO 1 ============================ 0 + +DECK,HISRZO,IF=HIGZ. 1 - SUBROUTINE HISRZO(IREF,FILE,TITLE,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HISRZO - Writes an histogram to an RZ file. 4 - *----------------------------------------------------------------------- 5 - implicit none 6.- +SEQ,DIMENSIONS. 7.- +SEQ,HISTDATA. 8 - LOGICAL EXIST 9 - INTEGER LREC,ISTAT,IFAIL,IREF,ICYCLE,I 10 - REAL AUX(MXCHA) 11 - CHARACTER*(*) FILE,TITLE 12 - CHARACTER*10 CHOPT 13 - *** Assume the call will work. 14 - IFAIL=0 15 - *** Check reference number and scale setting. 16 - IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN 17 - PRINT *,' !!!!!! HISRZO WARNING : Histogram reference'// 18 - - ' not valid; histogram not written.' 19 - IFAIL=1 20 - RETURN 21 - ENDIF 22 - IF(.NOT.SET(IREF))THEN 23 - PRINT *,' !!!!!! HISRZO WARNING : The scale of this'// 24 - - ' auto-range histogram is not yet set; not written.' 25 - IFAIL=1 26 - RETURN 27 - ENDIF 28 - *** Book the histogram. 29 - CALL HBOOK1(IREF,TITLE,NCHA(IREF),XMIN(IREF),XMAX(IREF),0.0) 30 - *** Copy the histogram to HBOOK. 31 - DO 10 I=1,NCHA(IREF) 32 - AUX(I)=CONTEN(IREF,I) 33 - 10 CONTINUE 34 - CALL HPAK(IREF,AUX) 35 - *** Open the RZ file. 36 - INQUIRE(FILE=FILE,EXIST=EXIST) 37 - IF(EXIST)THEN 38 - CHOPT='U' 39 - ELSE 40 - CHOPT='N' 41 - ENDIF 42 - LREC=1024 43 - CALL HROPEN(12,'Garfield',FILE,CHOPT,LREC,ISTAT) 44 - IF(ISTAT.NE.0)THEN 45 - PRINT *,' !!!!!! HISRZO WARNING : Error while opening'// 46 - - ' the RZ file.' 47 - IFAIL=1 48 - RETURN 49 - ENDIF 50 - *** Write the histogram. 51 - ICYCLE=0 52 - CALL HROUT(IREF,ICYCLE,' ') 53 - PRINT *,' ------ HISRZO MESSAGE : Histogram written to ',FILE, 54 - - ' with identifier ',IREF,', cycle ',ICYCLE,'.' 55 - *** Close the file. 56 - CALL HREND('Garfield') 57 - CLOSE(UNIT=12,STATUS='KEEP') 58 - *** Delete the histogram from memory. 1 389 P=HISTOGRA D=HISRZO 2 PAGE 484 59 - CALL HDELET(IREF) 60 - END 390 GARFIELD ================================================== P=HISTOGRA D=HISSAV 1 ============================ 0 + +DECK,HISSAV. 1 - SUBROUTINE HISSAV(IREF,NAME,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HISSAV - Assigns a histogram to a global variable. 4 - * (Last changed on 5/ 9/95.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,HISTDATA. 8.- +SEQ,GLOBALS. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*(*) NAME 11 - INTEGER IREF,IFAIL 12 - *** Initial failure flag setting. 13 - IFAIL=1 14 - *** Check reference number. 15 - IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN 16 - PRINT *,' !!!!!! HISSAV WARNING : Histogram reference'// 17 - - ' not valid; not saved.' 18 - RETURN 19 - ENDIF 20 - IF(.NOT.HISUSE(IREF))THEN 21 - PRINT *,' !!!!!! HISSAV WARNING : Histogram to be'// 22 - - ' saved does not exist; not saved.' 23 - IFAIL=1 24 - RETURN 25 - ENDIF 26 - *** Scan the list of global variables. 27 - JVAR=0 28 - DO 10 I=1,NGLB 29 - IF(GLBVAR(I).EQ.NAME)JVAR=I 30 - 10 CONTINUE 31 - *** If it didn't exist, create a new global ... 32 - IF(JVAR.EQ.0)THEN 33 - * if there still is space, 34 - IF(NGLB.LT.MXVAR)THEN 35 - NGLB=NGLB+1 36 - GLBVAR(NGLB)=NAME 37 - JVAR=NGLB 38 - * otherwise issue a warning. 39 - ELSE 40 - PRINT *,' !!!!!! HISSAV WARNING : No global variable'// 41 - - ' space left for ',NAME,'; histogram not saved.' 42 - RETURN 43 - ENDIF 44 - *** Otherwise re-use an existing global. 45 - ELSE 46 - CALL ALGREU(NINT(GLBVAL(JVAR)),GLBMOD(JVAR),0) 47 - ENDIF 48 - *** Assign the histogram to the global. 49 - GLBVAL(JVAR)=IREF 50 - GLBMOD(JVAR)=4 51 - *** Things seem to have worked. 52 - IFAIL=0 53 - END 391 GARFIELD ================================================== P=HISTOGRA D=HISSCL 1 ============================ 0 + +DECK,HISSCL. 1 - SUBROUTINE HISSCL(IREF,SCALE) 2 - *----------------------------------------------------------------------- 3 - * HISSCL - Scales an histogram by some factor. 4 - * (Last changed on 4/ 8/90.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,HISTDATA. 8.- +SEQ,PRINTPLOT. 9 - *** Check reference number and scale setting. 10 - IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN 11 - PRINT *,' !!!!!! HISSCL WARNING : Histogram reference'// 12 - - ' not valid; no histogram scaled.' 13 - RETURN 14 - ENDIF 15 - IF(.NOT.SET(IREF))THEN 16 - PRINT *,' !!!!!! HISSCL WARNING : The range of this'// 17 - - ' auto-range histogram is not yet set; no scaling.' 18 - RETURN 19 - ENDIF 20 - *** Multiply the histogram by some factor. 21 - DO 10 I=0,MXCHA+1 22 - CONTEN(IREF,I)=CONTEN(IREF,I)*SCALE 23 - 10 CONTINUE 24 - END 392 GARFIELD ================================================== P=HISTOGRA D=HISWRT 1 ============================ 0 + +DECK,HISWRT. 1 - SUBROUTINE HISWRT(IREF,FILE,MEMB,REM,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HISWRT - This routine writes a histogram to a dataset. 4 - * VARIABLES : 5 - * (Last changed on 30/ 8/97.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,HISTDATA. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*(MXINCH) STRING 11 - CHARACTER*(*) FILE,MEMB,REM 12 - CHARACTER*29 REMARK 13 - CHARACTER*8 TIME,DATE,MEMBER 14 - LOGICAL EXMEMB 15 - *** Identify the routine. 1 392 P=HISTOGRA D=HISWRT 2 PAGE 485 16 - IF(LIDENT)PRINT *,' /// ROUTINE HISWRT ///' 17 - *** Preset IFAIL to 1: failure. 18 - IFAIL=1 19 - *** Transfer variables. 20 - REMARK=REM 21 - MEMBER=MEMB 22 - *** Print some debugging output if requested. 23 - IF(LDEBUG)PRINT *,' ++++++ HISWRT DEBUG : Ref=',IREF, 24 - - ', File=',FILE,', member=',MEMBER,', Remark=',REMARK,'.' 25 - *** Check whether the member already exists. 26 - CALL DSNREM(FILE,MEMB,'HIST',EXMEMB) 27 - IF(JEXMEM.EQ.2.AND.EXMEMB)THEN 28 - PRINT *,' ------ HISWRT MESSAGE : A copy of the member'// 29 - - ' exists; new member will be appended.' 30 - ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN 31 - PRINT *,' !!!!!! HISWRT WARNING : A copy of the member'// 32 - - ' exists already; member will not be written.' 33 - RETURN 34 - ENDIF 35 - *** Verify the histogram reference. 36 - IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN 37 - PRINT *,' !!!!!! HISWRT WARNING : Invalid histogram'// 38 - - ' reference received; histogram not written.' 39 - IFAIL=1 40 - RETURN 41 - ENDIF 42 - IF(.NOT.HISUSE(IREF))THEN 43 - PRINT *,' !!!!!! HISWRT WARNING : Histogram to be'// 44 - - ' written does not exist; histogram not written.' 45 - IFAIL=1 46 - RETURN 47 - ENDIF 48 - *** Open the dataset for sequential write and inform DSNLOG. 49 - CALL DSNOPN(FILE,LEN(FILE),12,'WRITE-LIBRARY',IFAIL1) 50 - IF(IFAIL1.NE.0)THEN 51 - PRINT *,' !!!!!! HISWRT WARNING : Opening ',FILE, 52 - - ' failed ; histogram will not be written.' 53 - IFAIL=1 54 - RETURN 55 - ENDIF 56 - CALL DSNLOG(FILE,'Histogram ','Sequential','Write ') 57 - IF(LDEBUG)PRINT *,' ++++++ HISWRT DEBUG : Dataset ', 58 - - FILE,' opened on unit 12 for seq write.' 59 - * Now write a heading record to the file. 60 - CALL DATTIM(DATE,TIME) 61 - WRITE(STRING,'(''% Created '',A8,'' At '',A8,1X,A8,'' HIST '', 62 - - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK 63 - WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING 64 - * Write the histogram. 65 - WRITE(12,'('' HISTOGRAM INFORMATION:'')',IOSTAT=IOS,ERR=2010) 66 - WRITE(12,'('' Minimum: '',E15.8/'' Maximum: '',E15.8/ 67 - - '' Bins: '',I10/'' Range set: '',L1/ 68 - - '' Integer: '',L1)',IOSTAT=IOS,ERR=2010) XMIN(IREF), 69 - - XMAX(IREF),NCHA(IREF),SET(IREF),HISLIN(IREF) 70 - WRITE(12,'('' Sums: '',3E15.8/'' Entries: '',I10)', 71 - - IOSTAT=IOS,ERR=2010) SX0(IREF),SX1(IREF),SX2(IREF), 72 - - NENTRY(IREF) 73 - WRITE(12,'('' CONTENTS'')',IOSTAT=IOS,ERR=2010) 74 - DO 210 I=0,NCHA(IREF)+1 75 - WRITE(12,'(I10,E15.8)',IOSTAT=IOS,ERR=2010) I,CONTEN(IREF,I) 76 - 210 CONTINUE 77 - * Close the file after the operation. 78 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 79 - CALL TIMLOG('Writing an histogram to a dataset: ') 80 - *** Things worked, reset error flag. 81 - IFAIL=0 82 - RETURN 83 - *** Handle the error conditions. 84 - 2010 CONTINUE 85 - PRINT *,' ###### HISWRT ERROR : Error while writing'// 86 - - ' to ',FILE,' via unit 12 ; histogram not written.' 87 - CALL INPIOS(IOS) 88 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 89 - RETURN 90 - 2030 CONTINUE 91 - PRINT *,' ###### HISWRT ERROR : Dataset ',FILE, 92 - - ' unit 12 cannot be closed ; results not predictable' 93 - CALL INPIOS(IOS) 94 - END 393 GARFIELD ================================================== P=MATRIX D= 1 ============================ 0 + +PATCH,MATRIX. 394 GARFIELD ================================================== P=MATRIX D=MATADJ 1 ============================ 0 + +DECK,MATADJ. 1 - SUBROUTINE MATADJ(IREF,NDIM,ISIZ,PAD,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MATADJ - Changes the dimensions of a matrix, keeping shape. 4 - * Variables: IREF : Reference of matrix 5 - * ISIZ : Dimension sizes 6 - * PAD : Value for new elements in matrix 7 - * (Last changed on 12/ 4/96.) 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,MATDATA. 11.- +SEQ,PRINTPLOT. 12 - INTEGER IREF,IMOD,NDIM,ISIZ(*),IFAIL,ISLOT,ISLOTN,IA(MXMDIM), 13 - - MATADR,MATSLT,IADDR,IADDRN 14 - REAL PAD 15 - EXTERNAL MATADR,MATSLT 16 - *** Identify the routine if requested. 17 - IF(LIDENT)PRINT *,' /// ROUTINE MATADJ ///' 18 - *** Initial value of the failure flag. 19 - IFAIL=1 1 394 P=MATRIX D=MATADJ 2 PAGE 486 20 - *** Locate the current matrix. 21 - ISLOT=MATSLT(IREF) 22 - IF(ISLOT.LE.0)THEN 23 - PRINT *,' !!!!!! MATADJ WARNING : Matrix to be re-sized'// 24 - - ' has not been found.' 25 - RETURN 26 - ENDIF 27 - *** Check array dimensions. 28 - IF(NDIM.NE.MDIM(ISLOT))THEN 29 - PRINT *,' !!!!!! MATADJ WARNING : Existing matrix has a'// 30 - - ' different number of dimensions; not adjusted.' 31 - RETURN 32 - ENDIF 33 - *** Allocate space for the new matrix. 34 - IMOD=MMOD(ISLOT) 35 - CALL MATADM('ALLOCATE',IREFN,NDIM,ISIZ,IMOD,IFAIL1) 36 - IF(IFAIL1.NE.0)THEN 37 - PRINT *,' !!!!!! MATADJ WARNING : Unable to allocate'// 38 - - ' space for the re-sized matrix ; not re-sized.' 39 - RETURN 40 - ENDIF 41 - *** Re-locate the current matrix. 42 - ISLOT=MATSLT(IREF) 43 - IF(ISLOT.LE.0)THEN 44 - PRINT *,' !!!!!! MATADJ WARNING : Matrix to be re-sized'// 45 - - ' has not been found.' 46 - RETURN 47 - ENDIF 48 - *** Find where the new matrix sits. 49 - ISLOTN=MATSLT(IREFN) 50 - IF(ISLOTN.LE.0)THEN 51 - PRINT *,' !!!!!! MATADJ WARNING : New matrix not found;'// 52 - - ' program bug - please report.' 53 - RETURN 54 - ENDIF 55 - *** Initialise the new matrix. 56 - DO 50 I=1,MLEN(ISLOTN) 57 - MVEC(MORG(ISLOTN)+I)=PAD 58 - 50 CONTINUE 59 - *** Initial address vector. 60 - DO 60 I=1,MDIM(ISLOT) 61 - IA(I)=1 62 - 60 CONTINUE 63 - * Return here for the next element. 64 - 70 CONTINUE 65 - * Compute addresses in old and new matrix. 66 - IADDR=MATADR(ISLOT,IA) 67 - IADDRN=MATADR(ISLOTN,IA) 68 - * Assign. 69 - IF(IADDR.GT.0.AND.IADDRN.GT.0)MVEC(IADDRN)=MVEC(IADDR) 70 - * Increment the address vector. 71 - DO 80 I=1,MDIM(ISLOT) 72 - IF(IA(I).LT.MSIZ(ISLOT,I))THEN 73 - IA(I)=IA(I)+1 74 - DO 90 J=1,I-1 75 - IA(J)=1 76 - 90 CONTINUE 77 - GOTO 70 78 - ENDIF 79 - 80 CONTINUE 80 - *** Modify the pointer information. 81 - MREF(ISLOTN)=MREF(ISLOT) 82 - *** Delete the old matrix. 83 - MREF(ISLOT)=0 84 - *** Things seem to have worked. 85 - IFAIL=0 86 - END 395 GARFIELD ================================================== P=MATRIX D=MATADM 1 ============================ 0 + +DECK,MATADM. 1 - SUBROUTINE MATADM(ACTION,IREF,NDIM,IDIM,IMOD,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MATADM - Takes care of matrix booking. 4 - * (Last changed on 24/10/95.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9.- +SEQ,GLOBALS. 10.- +SEQ,PRINTPLOT. 11 - CHARACTER*(*) ACTION 12 - CHARACTER*78 STRING 13 - CHARACTER*20 STRAUX 14 - CHARACTER*10 TYPE,NAME 15 - INTEGER IREF,NDIM,IDIM(*),IMOD,IFAIL,NLEN,ISLOT,ILAST,ISTART, 16 - - IFREE,NFREE,INEW,IORG,NUSED,I,J,NC,NCAUX 17 - *** Allocate a new matrix. 18 - IF(ACTION.EQ.'ALLOCATE')THEN 19 - ** Assign a provision reference in case of error. 20 - IREF=0 21 - ** Set a provisional error flag. 22 - IFAIL=1 23 - ** Check the number of dimensions. 24 - IF(NDIM.GT.MXMDIM)THEN 25 - PRINT *,' !!!!!! MATADM WARNING : Matrix has more'// 26 - - ' than MXMDIM dimensions; matrix not booked.' 27 - RETURN 28 - ENDIF 29 - ** See how large the new matrix is. 30 - NLEN=1 31 - DO 10 I=1,NDIM 32 - IF(IDIM(I).LE.0)THEN 33 - PRINT *,' !!!!!! MATADM WARNING : Dimension ',I,' of', 34 - - ' the matrix is non-positive; matrix not booked.' 35 - RETURN 1 395 P=MATRIX D=MATADM 2 PAGE 487 36 - ENDIF 37 - NLEN=NLEN*IDIM(I) 38 - 10 CONTINUE 39 - ** Debugging output. 40 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATADM DEBUG :'', 41 - - '' Booking matrix, length '',I5,'', dimension '',I5, 42 - - '', mode '',I1,''.'')') NLEN,NDIM,IMOD 43 - ** See whether we've space without garbage collect. 44 - ILAST=0 45 - IFREE=0 46 - DO 20 I=1,MXMAT+1 47 - * If slot free, register and find next free slot. 48 - IF(MREF(I).EQ.0)THEN 49 - IF(IFREE.EQ.0)IFREE=I 50 - * Sufficient space ? Try to get a slot with it. 51 - ELSEIF(MORG(I)-ILAST.GE.NLEN)THEN 52 - IF(IFREE.NE.0)THEN 53 - ISLOT=IFREE 54 - ISTART=ILAST 55 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Fits in slot '', 56 - - I5,'' with origin '',I5,''.'')') 57 - - ISLOT,ISTART 58 - GOTO 300 59 - ELSE 60 - ISLOT=I-1 61 - ISTART=ILAST 62 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Trying to put'', 63 - - '' in slot '',I5,'' at origin '',I5,''.'')') 64 - - ISLOT,ISTART 65 - GOTO 100 66 - ENDIF 67 - * Not enough space ? Re-start searching from here. 68 - ELSE 69 - ILAST=MORG(I)+MLEN(I) 70 - IFREE=0 71 - ENDIF 72 - 20 CONTINUE 73 - ** If we get here, there is no free space without garbage collect. 74 - GOTO 200 75 - ** Resume here is there is free space, but no slot in the right place. 76 - 100 CONTINUE 77 - * Eliminate empty entries below the slot to be assigned. 78 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 79 - - ''Removing empty slots below target slot.'')') 80 - INEW=0 81 - DO 30 I=1,ISLOT 82 - IF(MREF(I).NE.0)THEN 83 - INEW=INEW+1 84 - MREF(INEW)=MREF(I) 85 - MORG(INEW)=MORG(I) 86 - DO 40 J=1,MXMDIM 87 - MSIZ(INEW,J)=MSIZ(I,J) 88 - 40 CONTINUE 89 - MDIM(INEW)=MDIM(I) 90 - MLEN(INEW)=MLEN(I) 91 - MMOD(INEW)=MMOD(I) 92 - IF(I.NE.INEW)MREF(I)=0 93 - ENDIF 94 - 30 CONTINUE 95 - * Is there a free slot now ? 96 - IF(INEW.LT.ISLOT)THEN 97 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Fits in slot '', 98 - - I5,'' with origin '',I5,''.'')') 99 - - ISLOT,ISTART 100 - GOTO 300 101 - ENDIF 102 - * Still no free slot, try to get the next higher slot. 103 - IF(ISLOT+1.LE.MXMAT)THEN 104 - ISLOT=ISLOT+1 105 - ELSE 106 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Unable to get place'', 107 - - '' by shifting, trying garbage collect.'')') 108 - GOTO 200 109 - ENDIF 110 - * And move the pointers ahead of the slot up. 111 - INEW=MXMAT+1 112 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 113 - - ''Removing empty slots above target slot.'')') 114 - DO 50 I=MXMAT,ISLOT,-1 115 - IF(MREF(I).NE.0)THEN 116 - INEW=INEW-1 117 - MREF(INEW)=MREF(I) 118 - MORG(INEW)=MORG(I) 119 - DO 60 J=1,MXMDIM 120 - MSIZ(INEW,J)=MSIZ(I,J) 121 - 60 CONTINUE 122 - MDIM(INEW)=MDIM(I) 123 - MLEN(INEW)=MLEN(I) 124 - MMOD(INEW)=MMOD(I) 125 - IF(I.NE.INEW)MREF(I)=0 126 - ENDIF 127 - 50 CONTINUE 128 - * Is there a free slot now ? 129 - IF(ISLOT.LT.INEW)THEN 130 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Fits in slot '', 131 - - I5,'' with origin '',I5,''.'')') 132 - - ISLOT,ISTART 133 - GOTO 300 134 - ENDIF 135 - ** If all failed, try a garbage collect. 136 - 200 CONTINUE 137 - INEW=0 138 - IORG=0 139 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Garbage collection.'')') 140 - DO 70 I=1,MXMAT 141 - * Skip empty matrices. 1 395 P=MATRIX D=MATADM 3 PAGE 488 142 - IF(MREF(I).EQ.0)GOTO 70 143 - * Copy the matrix itself. 144 - DO 90 J=1,MLEN(I) 145 - MVEC(IORG+J)=MVEC(MORG(I)+J) 146 - 90 CONTINUE 147 - * Increment matrix counter. 148 - INEW=INEW+1 149 - * Copy the reference information. 150 - MREF(INEW)=MREF(I) 151 - MORG(INEW)=IORG 152 - IORG=IORG+MLEN(I) 153 - DO 80 J=1,MXMDIM 154 - MSIZ(INEW,J)=MSIZ(I,J) 155 - 80 CONTINUE 156 - MDIM(INEW)=MDIM(I) 157 - MLEN(INEW)=MLEN(I) 158 - MMOD(INEW)=MMOD(I) 159 - 70 CONTINUE 160 - * Reset the pointers for the rest of the list. 161 - DO 110 I=INEW+1,MXMAT 162 - MREF(I)=0 163 - MORG(I)=0 164 - MLEN(I)=0 165 - MDIM(I)=0 166 - MMOD(I)=0 167 - DO 120 J=1,MXMDIM 168 - MSIZ(I,J)=0 169 - 120 CONTINUE 170 - 110 CONTINUE 171 - * Is there a free slot ? 172 - IF(INEW.GE.MXMAT)THEN 173 - PRINT *,' !!!!!! MATADM WARNING : No free slot'// 174 - - ' found; matrix not booked.' 175 - RETURN 176 - ENDIF 177 - * Is there enough space now ? 178 - IF(MORG(INEW)+MLEN(INEW)+NLEN.LE.MXEMAT)THEN 179 - ISLOT=INEW+1 180 - ISTART=MORG(INEW)+MLEN(INEW) 181 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Fits in slot '', 182 - - I5,'' with origin '',I5,''.'')') 183 - - ISLOT,ISTART 184 - GOTO 300 185 - ENDIF 186 - * Not enough room. 187 - PRINT *,' !!!!!! MATADM WARNING : Not enough matrix'// 188 - - ' space; matrix not booked.' 189 - RETURN 190 - ** We got a slot with enough space, save matrix information. 191 - 300 CONTINUE 192 - NREFL=NREFL+1 193 - MREF(ISLOT)=NREFL 194 - IREF=NREFL 195 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Assigning reference '',I5)') 196 - - IREF 197 - MDIM(ISLOT)=NDIM 198 - MORG(ISLOT)=ISTART 199 - MMOD(ISLOT)=IMOD 200 - MLEN(ISLOT)=NLEN 201 - DO 130 I=1,NDIM 202 - MSIZ(ISLOT,I)=IDIM(I) 203 - 130 CONTINUE 204 - *** Initialise the matrix. 205 - DO 140 I=1,MLEN(ISLOT) 206 - MVEC(MORG(ISLOT)+I)=REAL(I) 207 - 140 CONTINUE 208 - ** Debugging output. 209 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Matrix allocation done.'')') 210 - ** Remember that this worked. 211 - IFAIL=0 212 - *** Release an allocated matrix. 213 - ELSEIF(ACTION.EQ.'DELETE')THEN 214 - * Check whether there is a global associated with this matrix. 215 - DO 505 J=1,NGLB 216 - IF(GLBMOD(J).EQ.5.AND.NINT(GLBVAL(J)).EQ.IREF) 217 - - GLBMOD(J)=0 218 - 505 CONTINUE 219 - * Locate the matrix. 220 - DO 500 I=1,MXMAT 221 - IF(MREF(I).EQ.IREF)THEN 222 - MREF(I)=0 223 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Matrix with'', 224 - - '' reference '',I5,'' cleared.'')') IREF 225 - IFAIL=0 226 - RETURN 227 - ENDIF 228 - 500 CONTINUE 229 - * Warn if the matrix is not found. 230 - PRINT *,' !!!!!! MATADM WARNING : Matrix to be deleted'// 231 - - ' has not been found.' 232 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Reference: '',I5)') IREF 233 - IFAIL=1 234 - *** List of matrices. 235 - ELSEIF(ACTION.EQ.'LIST')THEN 236 - * Print a header. 237 - WRITE(LUNOUT,'(/'' OVERVIEW OF EXISTING MATRICES''// 238 - - '' Reference n-Dim Type Global '', 239 - - '' Dimensions ... ''/)') 240 - * Keep track of free space and number of matrices in use. 241 - NFREE=0 242 - ILAST=0 243 - NUSED=0 244 - * Loop over the matrices. 245 - DO 700 I=1,MXMAT 246 - IF(MREF(I).EQ.0)THEN 247 - NFREE=NFREE+1 1 395 P=MATRIX D=MATADM 4 PAGE 489 248 - ELSE 249 - NUSED=NUSED+1 250 - IF(NFREE.GT.0.OR.MORG(I).NE.ILAST)THEN 251 - STRING(1:1)='(' 252 - NC=1 253 - CALL OUTFMT(REAL(NFREE),2,STRAUX,NCAUX,'LEFT') 254 - STRING(NC+1:NC+NCAUX)=STRAUX(1:NCAUX) 255 - NC=NC+NCAUX 256 - STRING(NC+1:NC+16)=' free slots for ' 257 - NC=NC+16 258 - CALL OUTFMT(REAL(MORG(I)-ILAST),2, 259 - - STRAUX,NCAUX,'LEFT') 260 - STRING(NC+1:NC+NCAUX)=STRAUX(1:NCAUX) 261 - NC=NC+NCAUX 262 - STRING(NC+1:NC+13)=' free words.)' 263 - NC=NC+13 264 - WRITE(LUNOUT,'(2X,A)') STRING(1:NC) 265 - ENDIF 266 - NFREE=0 267 - ILAST=MORG(I)+MLEN(I) 268 - IF(MMOD(I).EQ.0)THEN 269 - TYPE='Undefined' 270 - ELSEIF(MMOD(I).EQ.1)THEN 271 - TYPE='String' 272 - ELSEIF(MMOD(I).EQ.2)THEN 273 - TYPE='Number' 274 - ELSEIF(MMOD(I).EQ.3)THEN 275 - TYPE='Logical' 276 - ELSEIF(MMOD(I).EQ.4)THEN 277 - TYPE='Histogram' 278 - ENDIF 279 - NAME='< none >' 280 - DO 710 J=1,NGLB 281 - IF(GLBMOD(J).EQ.5.AND.NINT(GLBVAL(J)).EQ.MREF(I)) 282 - - NAME=GLBVAR(J) 283 - 710 CONTINUE 284 - WRITE(LUNOUT,'(2X,I9,1X,I5,1X,A10,1X,A10,1X, 285 - - (10(I4,1X,:)/40X))') 286 - - MREF(I),MDIM(I),TYPE,NAME,(MSIZ(I,J),J=1,MDIM(I)) 287 - ENDIF 288 - 700 CONTINUE 289 - IF(NFREE.GT.0.OR.MXEMAT.GT.ILAST)THEN 290 - STRING(1:1)='(' 291 - NC=1 292 - CALL OUTFMT(REAL(NFREE),2,STRAUX,NCAUX,'LEFT') 293 - STRING(NC+1:NC+NCAUX)=STRAUX(1:NCAUX) 294 - NC=NC+NCAUX 295 - STRING(NC+1:NC+16)=' free slots for ' 296 - NC=NC+16 297 - CALL OUTFMT(REAL(MXEMAT-ILAST),2, 298 - - STRAUX,NCAUX,'LEFT') 299 - STRING(NC+1:NC+NCAUX)=STRAUX(1:NCAUX) 300 - NC=NC+NCAUX 301 - STRING(NC+1:NC+13)=' free words.)' 302 - NC=NC+13 303 - WRITE(LUNOUT,'(2X,A)') STRING(1:NC) 304 - ENDIF 305 - * Print number of matrices in use. 306 - WRITE(LUNOUT,'(/'' Number of matrices booked: '',I5/)') 307 - - NUSED 308 - *** Unknown action. 309 - ELSE 310 - PRINT *,' !!!!!! MATADM WARNING : Invalid action requested.' 311 - IFAIL=1 312 - ENDIF 313 - END 396 GARFIELD ================================================== P=MATRIX D=MATADR 1 ============================ 0 + +DECK,MATADR. 1 - INTEGER FUNCTION MATADR(ISLOT,IA) 2 - *----------------------------------------------------------------------- 3 - * MATADR - Returns an address of a matrix element. 4 - * (Last changed on 25/10/95.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9 - INTEGER ISLOT,IA(*),I 10 - *** Verify address. 11 - IF(ISLOT.LE.0.OR.ISLOT.GT.MXMAT)THEN 12 - MATADR=-1 13 - RETURN 14 - ENDIF 15 - *** Loop over the dimensions. 16 - DO 10 I=MDIM(ISLOT),1,-1 17 - * Don't go beyond array bounds. 18 - IF(IA(I).LE.0.OR.IA(I).GT.MSIZ(ISLOT,I))THEN 19 - MATADR=-1 20 - RETURN 21 - * First round. 22 - ELSEIF(I.EQ.MDIM(ISLOT))THEN 23 - MATADR=IA(I)-1 24 - * All other terms. 25 - ELSE 26 - MATADR=MATADR*MSIZ(ISLOT,I)+IA(I)-1 27 - ENDIF 28 - 10 CONTINUE 29 - *** Offset by the matrix starting point. 30 - MATADR=MATADR+MORG(ISLOT)+1 31 - END 1 397 GARFIELD ================================================== P=MATRIX D=MATBND 1 =================== PAGE 490 0 + +DECK,MATBND. 1 - SUBROUTINE MATBND(IREF1,IREF2,IREF3) 2 - *----------------------------------------------------------------------- 3 - * MATBND - Plots an error band. 4 - * (Last changed on 19/ 7/96.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9.- +SEQ,PRINTPLOT. 10 - REAL XPL(MXLIST),YPL(MXLIST) 11 - INTEGER MATSLT,IREF1,IREF2,IREF3,ISLOT1,ISLOT2,ISLOT3,I 12 - EXTERNAL MATSLT 13 - *** Indentify the routine if requested. 14 - IF(LIDENT)PRINT *,' /// ROUTINE MATBND ///' 15 - *** Debugging output. 16 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATBND DEBUG : Plotting'', 17 - - '' error band for '',3I5)') IREF1,IREF2,IREF3 18 - *** Locate the 3 vectors. 19 - ISLOT1=MATSLT(IREF1) 20 - ISLOT2=MATSLT(IREF2) 21 - ISLOT3=MATSLT(IREF3) 22 - IF(ISLOT1.LE.0.OR.ISLOT2.LE.0.OR.ISLOT3.LE.0)THEN 23 - PRINT *,' !!!!!! MATBND WARNING : Didn''t find all'// 24 - - ' matrices forming the error band; not plotted.' 25 - RETURN 26 - ENDIF 27 - *** Verify that the 3 have the same length. 28 - IF(MLEN(ISLOT1).NE.MLEN(ISLOT2).OR. 29 - - MLEN(ISLOT2).NE.MLEN(ISLOT3))THEN 30 - PRINT *,' !!!!!! MATBND WARNING : The 3 vectors do not'// 31 - - ' have the same length; error band not plotted.' 32 - RETURN 33 - ENDIF 34 - *** Verify that the length is at least 2. 35 - IF(MLEN(ISLOT1).LT.2.OR.2*MLEN(ISLOT1)+1.GT.MXLIST)THEN 36 - PRINT *,' !!!!!! MATBND WARNING : The vectors have a'// 37 - - ' length outside [2,(MXLIST-1)/2]; not plotted.' 38 - RETURN 39 - ENDIF 40 - *** Set the appropriate representations. 41 - CALL GRATTS('ERROR-BAND','POLYLINE') 42 - CALL GRATTS('ERROR-BAND','AREA') 43 - *** Plot the line. 44 - DO 10 I=1,MLEN(ISLOT1) 45 - XPL(I)=MVEC(MORG(ISLOT1)+I) 46 - YPL(I)=MVEC(MORG(ISLOT2)+I) 47 - XPL(2*MLEN(ISLOT1)-I+1)=MVEC(MORG(ISLOT1)+I) 48 - YPL(2*MLEN(ISLOT1)-I+1)=MVEC(MORG(ISLOT3)+I) 49 - 10 CONTINUE 50 - XPL(2*MLEN(ISLOT1)+1)=MVEC(MORG(ISLOT1)+1) 51 - YPL(2*MLEN(ISLOT1)+1)=MVEC(MORG(ISLOT2)+1) 52 - CALL GRAREA(2*MLEN(ISLOT1)+1,XPL,YPL) 53 - CALL GRLINE(2*MLEN(ISLOT1)+1,XPL,YPL) 54 - END 398 GARFIELD ================================================== P=MATRIX D=MATCAL 1 ============================ 0 + +DECK,MATCAL. 1 - SUBROUTINE MATCAL(INSTR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MATCAL - Handles matrix procedure calls. 4 - * (Last changed on 14/11/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,ALGDATA. 9.- +SEQ,GLOBALS. 10.- +SEQ,MATDATA. 11.- +SEQ,PRINTPLOT. 12 - CHARACTER*80 XTXT,YTXT,TITLE,FILE,OPTION 13 - CHARACTER*30 NAME 14 - CHARACTER*29 REMARK 15 - CHARACTER*8 MEMBER 16 - REAL AUX,ZERO(MXLIST),PAD,THETA,PHI 17 - INTEGER ISIZ(MXMDIM),ISEL(MXLIST),NSEL,MATSLT,NCXTXT,NCYTXT, 18 - - NCTIT,IREFX,IREFY,ISDUM1,ISDUM2,NARG,IPROC,INSTR,IFAIL, 19 - - IFAIL1,IFAIL2,IFAIL3,IFAIL4,NCOPT,NCONT,NZERO,I,J,K,NIN, 20 - - ISLOT,IRMAT,ISMAT,NDIM,NDUM,NCFILE,NCMEMB,NCREM,LORD,NORD, 21 - - ISORD,ISORDI,IROUT,IWRONG,IDUM,IREF,IREFD,ISLOTD,ISDIM,IRORD 22 - EXTERNAL MATSLT 23 - *** Assume that this will fail. 24 - IFAIL=1 25 - *** Some easy reference variables. 26 - NARG=INS(INSTR,3) 27 - IPROC=INS(INSTR,1) 28 - *** Extract a sub-matrix. 29 - IF(IPROC.EQ.-80)THEN 30 - * Check the format of the argument list. 31 - IF(NARG.LT.3.OR.ARGREF(NARG,1).GE.2.OR. 32 - - MODARG(NARG-1).NE.5.OR.MODARG(1).NE.2.OR. 33 - - NINT(ARG(1)).LT.1)THEN 34 - PRINT *,' !!!!!! MATCAL WARNING : EXTRACT_SUBMATRIX'// 35 - - ' received an invalid argument list.' 36 - RETURN 37 - ENDIF 38 - * Copy the selection vector, expanding any vectors used as address. 39 - IF(1+NINT(ARG(1)).GT.MXLIST)GOTO 69 40 - ISEL(1)=NINT(ARG(1)) 41 - NSEL=1+NINT(ARG(1)) 42 - NIN=1+NINT(ARG(1)) 43 - DO 60 I=2,1+NINT(ARG(1)) 44 - IF(MODARG(I).NE.2)THEN 45 - PRINT *,' !!!!!! MATCAL WARNING : Incorrectly'// 46 - - ' specified selection size; no sub-matrix.' 47 - RETURN 1 398 P=MATRIX D=MATCAL 2 PAGE 491 48 - ENDIF 49 - ISEL(I)=0 50 - DO 61 J=1,NINT(ARG(I)) 51 - IF(MODARG(NIN+J).EQ.2)THEN 52 - IF(NSEL+1.GT.MXLIST)GOTO 69 53 - NSEL=NSEL+1 54 - ISEL(NSEL)=NINT(ARG(NIN+J)) 55 - ISEL(I)=ISEL(I)+1 56 - ELSEIF(MODARG(NIN+J).EQ.5)THEN 57 - DO 62 K=1,MXMAT 58 - IF(MREF(K).EQ.NINT(ARG(NIN+J)))THEN 59 - ISLOT=K 60 - GOTO 63 61 - ENDIF 62 - 62 CONTINUE 63 - PRINT *,' !!!!!! MATCAL WARNING : Matrix not found;'// 64 - - ' program bug - please report.' 65 - RETURN 66 - 63 CONTINUE 67 - DO 64 K=1,MLEN(ISLOT) 68 - IF(NSEL+1.GT.MXLIST)GOTO 69 69 - NSEL=NSEL+1 70 - ISEL(NSEL)=NINT(MVEC(MORG(ISLOT)+K)) 71 - ISEL(I)=ISEL(I)+1 72 - 64 CONTINUE 73 - ELSE 74 - PRINT *,' !!!!!! MATCAL WARNING : Incorrectly'// 75 - - ' specified selection item; no sub-matrix.' 76 - RETURN 77 - ENDIF 78 - 61 CONTINUE 79 - NIN=NIN+NINT(ARG(I)) 80 - 60 CONTINUE 81 - * Store the sub-matrix in the matrix. 82 - CALL MATSUB('EXTRACT',ISEL,NINT(ARG(NARG-1)),IRMAT,IFAIL1) 83 - IF(IFAIL1.NE.0)THEN 84 - PRINT *,' !!!!!! MATCAL WARNING : Extracting the'// 85 - - ' submatrix failed.' 86 - RETURN 87 - ENDIF 88 - * Free the receiving argument. 89 - CALL ALGREU(NINT(ARG(NARG)),MODARG(NARG),ARGREF(NARG,1)) 90 - * Update the argument list. 91 - ARG(NARG)=IRMAT 92 - MODARG(NARG)=5 93 - * In case of failure. 94 - GOTO 68 95 - 69 CONTINUE 96 - PRINT *,' !!!!!! MATCAL WARNING : Insufficient memory'// 97 - - ' to expand matrix selection vector; no sub-matrix.' 98 - RETURN 99 - 68 CONTINUE 100 - *** Store a sub-matrix. 101 - ELSEIF(IPROC.EQ.-81)THEN 102 - * Check the format of the argument list. 103 - IF(NARG.LT.3.OR.ARGREF(NARG-1,1).GE.2.OR. 104 - - MODARG(NARG-1).NE.5.OR. 105 - - (MODARG(NARG).NE.2.AND.MODARG(NARG).NE.5))THEN 106 - PRINT *,' !!!!!! MATCAL WARNING : STORE_SUBMATRIX'// 107 - - ' received an invalid argument list.' 108 - RETURN 109 - ENDIF 110 - * Process the case that we've to store a scalar in a matrix. 111 - IF(MODARG(NARG).EQ.2)THEN 112 - ISIZ(1)=1 113 - CALL MATADM('ALLOCATE',IRMAT,1,ISIZ,2,IFAIL1) 114 - IF(IFAIL1.NE.0)THEN 115 - PRINT *,' !!!!!! MATCAL WARNING : Unable to'// 116 - - ' allocate a temporary matrix for a scalar.' 117 - RETURN 118 - ENDIF 119 - DO 80 I=1,MXMAT 120 - IF(MREF(I).EQ.IRMAT)THEN 121 - ISMAT=I 122 - GOTO 90 123 - ENDIF 124 - 80 CONTINUE 125 - PRINT *,' !!!!!! MATCAL WARNING : Scalar not found;'// 126 - - ' program bug - please report.' 127 - RETURN 128 - 90 CONTINUE 129 - MVEC(MORG(ISMAT)+1)=ARG(NARG) 130 - ELSE 131 - IRMAT=NINT(ARG(NARG)) 132 - ENDIF 133 - * Copy the selection vector, expanding any vectors used as address. 134 - IF(1+NINT(ARG(1)).GT.MXLIST)GOTO 79 135 - ISEL(1)=NINT(ARG(1)) 136 - NSEL=1+NINT(ARG(1)) 137 - NIN=1+NINT(ARG(1)) 138 - DO 70 I=2,1+NINT(ARG(1)) 139 - IF(MODARG(I).NE.2)THEN 140 - PRINT *,' !!!!!! MATCAL WARNING : Incorrectly'// 141 - - ' specified selection size; no sub-matrix.' 142 - IF(MODARG(NARG).EQ.2) 143 - - CALL MATADM('DELETE',IRMAT,1,ISIZ,2,IFAIL2) 144 - RETURN 145 - ENDIF 146 - ISEL(I)=0 147 - DO 71 J=1,NINT(ARG(I)) 148 - IF(MODARG(NIN+J).EQ.2)THEN 149 - IF(NSEL+1.GT.MXLIST)GOTO 79 150 - NSEL=NSEL+1 151 - ISEL(NSEL)=NINT(ARG(NIN+J)) 152 - ISEL(I)=ISEL(I)+1 153 - ELSEIF(MODARG(NIN+J).EQ.5)THEN 1 398 P=MATRIX D=MATCAL 3 PAGE 492 154 - DO 72 K=1,MXMAT 155 - IF(MREF(K).EQ.NINT(ARG(NIN+J)))THEN 156 - ISLOT=K 157 - GOTO 73 158 - ENDIF 159 - 72 CONTINUE 160 - PRINT *,' !!!!!! MATCAL WARNING : Matrix not found;'// 161 - - ' program bug - please report.' 162 - RETURN 163 - 73 CONTINUE 164 - DO 74 K=1,MLEN(ISLOT) 165 - IF(NSEL+1.GT.MXLIST)GOTO 79 166 - NSEL=NSEL+1 167 - ISEL(NSEL)=NINT(MVEC(MORG(ISLOT)+K)) 168 - ISEL(I)=ISEL(I)+1 169 - 74 CONTINUE 170 - ELSE 171 - PRINT *,' !!!!!! MATCAL WARNING : Incorrectly'// 172 - - ' specified selection item; no sub-matrix.' 173 - IF(MODARG(NARG).EQ.2) 174 - - CALL MATADM('DELETE',IRMAT,1,ISIZ,2,IFAIL2) 175 - RETURN 176 - ENDIF 177 - 71 CONTINUE 178 - NIN=NIN+NINT(ARG(I)) 179 - 70 CONTINUE 180 - * Store the matrix in the sub-matrix. 181 - CALL MATSUB('STORE',ISEL,NINT(ARG(NARG-1)),IRMAT,IFAIL1) 182 - * Remove the temporary matrix if we assigned a scalar. 183 - IF(MODARG(NARG).EQ.2) 184 - - CALL MATADM('DELETE',IRMAT,1,ISIZ,2,IFAIL2) 185 - * Check error flags. 186 - IF(IFAIL1.NE.0)THEN 187 - PRINT *,' !!!!!! MATCAL WARNING : Storing in the'// 188 - - ' submatrix failed.' 189 - RETURN 190 - ENDIF 191 - * Failure. 192 - GOTO 78 193 - 79 CONTINUE 194 - PRINT *,' !!!!!! MATCAL WARNING : Insufficient memory'// 195 - - ' to expand matrix selection vector; no sub-matrix.' 196 - RETURN 197 - 78 CONTINUE 198 - *** Print a matrix. 199 - ELSEIF(IPROC.EQ.-82)THEN 200 - * There should be at least 1 argument. 201 - IF(NARG.LE.0)THEN 202 - PRINT *,' !!!!!! MATCAL WARNING : Incorrect number'// 203 - - ' arguments received by PRINT_MATRIX.' 204 - * Print all matrices provided as arguments, find their names. 205 - ELSE 206 - DO 10 I=1,NARG 207 - IF(MODARG(I).NE.5)THEN 208 - PRINT *,' !!!!!! MATCAL WARNING : An argument'// 209 - - ' is not of type matrix ; ignored.' 210 - GOTO 10 211 - ENDIF 212 - NAME='(temporary matrix)' 213 - DO 20 J=1,NGLB 214 - IF(GLBMOD(J).EQ.5.AND.NINT(GLBVAL(J)).EQ.NINT(ARG(I))) 215 - - NAME=GLBVAR(J) 216 - 20 CONTINUE 217 - WRITE(LUNOUT,'(2X,A)') NAME 218 - CALL MATPRT(NINT(ARG(I))) 219 - 10 CONTINUE 220 - ENDIF 221 - *** Create a matrix. 222 - ELSEIF(IPROC.EQ.-83)THEN 223 - * Check number of arguments. 224 - IF(NARG.LE.1.OR.ARGREF(1,1).GE.2)THEN 225 - PRINT *,' !!!!!! MATCAL WARNING : Incorrect argument'// 226 - - ' list received by BOOK_MATRIX.' 227 - ELSE 228 - * Get the matrix dimensions. 229 - NDIM=0 230 - DO 30 I=2,NARG 231 - IF(MODARG(I).EQ.2)THEN 232 - IF(NDIM+1.GT.MXMDIM)THEN 233 - PRINT *,' !!!!!! MATCAL WARNING : Too'// 234 - - ' many dimensions; matrix not booked.' 235 - RETURN 236 - ENDIF 237 - NDIM=NDIM+1 238 - ISIZ(NDIM)=NINT(ARG(I)) 239 - ELSEIF(MODARG(I).EQ.5)THEN 240 - ISDIM=MATSLT(NINT(ARG(I))) 241 - IF(ISDIM.LE.0)THEN 242 - PRINT *,' !!!!!! MATCAL WARNING : Size'// 243 - - ' not found; matrix not booked.' 244 - RETURN 245 - ENDIF 246 - DO 35 J=1,MLEN(ISDIM) 247 - IF(NDIM+1.GT.MXMDIM)THEN 248 - PRINT *,' !!!!!! MATCAL WARNING : Too'// 249 - - ' many dimensions; matrix not booked.' 250 - RETURN 251 - ENDIF 252 - NDIM=NDIM+1 253 - ISIZ(NDIM)=NINT(MVEC(MORG(ISDIM)+J)) 254 - 35 CONTINUE 255 - ELSE 256 - PRINT *,' !!!!!! MATCAL WARNING : Incorrect'// 257 - - ' data type in array dimensions.' 258 - RETURN 259 - ENDIF 1 398 P=MATRIX D=MATCAL 4 PAGE 493 260 - 30 CONTINUE 261 - * Create the matrix. 262 - CALL MATADM('ALLOCATE',IREF,NDIM,ISIZ,2,IFAIL1) 263 - * See whether this worked. 264 - IF(IFAIL1.NE.0)THEN 265 - PRINT *,' !!!!!! MATCAL WARNING : Unable to'// 266 - - ' create the requested matrix.' 267 - RETURN 268 - ENDIF 269 - * Clear the variable. 270 - CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) 271 - * Assign the result to the variable. 272 - ARG(1)=REAL(IREF) 273 - MODARG(1)=5 274 - ENDIF 275 - *** Resize a matrix. 276 - ELSEIF(IPROC.EQ.-84)THEN 277 - * Check number of arguments. 278 - IF(NARG.LE.2.OR.NARG.GT.MXMDIM+2.OR. 279 - - ARGREF(1,1).GE.2.OR.MODARG(1).NE.5.OR. 280 - - MODARG(NARG).NE.2)THEN 281 - PRINT *,' !!!!!! MATCAL WARNING : Incorrect argument'// 282 - - ' list received by RESHAPE_MATRIX.' 283 - ELSE 284 - * Get padding. 285 - PAD=ARG(NARG) 286 - * Get the matrix dimensions. 287 - NDIM=NARG-2 288 - DO 40 I=1,NDIM 289 - IF(MODARG(I+1).NE.2)THEN 290 - PRINT *,' !!!!!! MATCAL WARNING : Incorrect'// 291 - - ' data type in array dimensions.' 292 - RETURN 293 - ENDIF 294 - ISIZ(I)=NINT(ARG(I+1)) 295 - 40 CONTINUE 296 - * Resize the matrix. 297 - CALL MATCHS(NINT(ARG(1)),NDIM,ISIZ,PAD,IFAIL1) 298 - * See whether this worked. 299 - IF(IFAIL1.NE.0)THEN 300 - PRINT *,' !!!!!! MATCAL WARNING : Unable to'// 301 - - ' re-shape the matrix.' 302 - RETURN 303 - ENDIF 304 - ENDIF 305 - *** Adjust a matrix. 306 - ELSEIF(IPROC.EQ.-85)THEN 307 - * Check number of arguments. 308 - IF(NARG.LE.2.OR.NARG.GT.MXMDIM+2.OR. 309 - - ARGREF(1,1).GE.2.OR.MODARG(1).NE.5.OR. 310 - - MODARG(NARG).NE.2)THEN 311 - PRINT *,' !!!!!! MATCAL WARNING : Incorrect argument'// 312 - - ' list received by ADJUST_MATRIX.' 313 - ELSE 314 - * Get padding. 315 - PAD=ARG(NARG) 316 - * Get the matrix dimensions. 317 - NDIM=NARG-2 318 - DO 45 I=1,NDIM 319 - IF(MODARG(I+1).NE.2)THEN 320 - PRINT *,' !!!!!! MATCAL WARNING : Incorrect'// 321 - - ' data type in array dimensions.' 322 - RETURN 323 - ENDIF 324 - ISIZ(I)=NINT(ARG(I+1)) 325 - 45 CONTINUE 326 - * Resize the matrix. 327 - CALL MATADJ(NINT(ARG(1)),NDIM,ISIZ,PAD,IFAIL1) 328 - * See whether this worked. 329 - IF(IFAIL1.NE.0)THEN 330 - PRINT *,' !!!!!! MATCAL WARNING : Unable to'// 331 - - ' adjust the matrix.' 332 - RETURN 333 - ENDIF 334 - ENDIF 335 - *** Delete a matrix. 336 - ELSEIF(IPROC.EQ.-86)THEN 337 - * Check number of arguments. 338 - IF(NARG.LT.1)THEN 339 - DO 55 I=1,NGLB 340 - IF(GLBMOD(I).EQ.5)THEN 341 - CALL MATADM('DELETE',NINT(GLBVAL(I)), 342 - - 0,ISIZ,2,IFAIL1) 343 - GLBVAL(I)=0 344 - GLBMOD(I)=0 345 - ENDIF 346 - 55 CONTINUE 347 - CALL MATINT 348 - C PRINT *,' !!!!!! MATCAL WARNING : DELETE_MATRIX'// 349 - C - ' needs at least 1 argument.' 350 - * Delete all the matrices in the arguments. 351 - ELSE 352 - DO 50 I=1,NARG 353 - IF(MODARG(I).NE.5)THEN 354 - C PRINT *,' !!!!!! MATCAL WARNING : Incorrect'// 355 - C - ' data type in DELETE_MATRIX call.' 356 - GOTO 50 357 - ENDIF 358 - CALL MATADM('DELETE',NINT(ARG(I)),0,ISIZ,2,IFAIL1) 359 - ARG(I)=0 360 - MODARG(I)=0 361 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! MATCAL WARNING :'// 362 - - ' Deleting a matrix failed.' 363 - 50 CONTINUE 364 - ENDIF 365 - *** List matrices in memory. 1 398 P=MATRIX D=MATCAL 5 PAGE 494 366 - ELSEIF(IPROC.EQ.-87)THEN 367 - * Check number and type of arguments. 368 - IF(NARG.NE.0)THEN 369 - PRINT *,' !!!!!! MATCAL WARNING : Incorrect argument'// 370 - - ' list provided for LIST_MATRICES.' 371 - RETURN 372 - ENDIF 373 - * List. 374 - CALL MATADM('LIST',IDUM,NDUM,ISIZ,NDUM,IFAIL1) 375 - *** Write a matrix to a library. 376 - ELSEIF(IPROC.EQ.-88)THEN 377 - * Check number and type of arguments. 378 - IF(MODARG(1).NE.5.OR.MODARG(2).NE.1.OR. 379 - - (NARG.GE.3.AND.MODARG(3).NE.1).OR. 380 - - (NARG.GE.4.AND.MODARG(4).NE.1).OR. 381 - - NARG.LT.2.OR.NARG.GT.4)THEN 382 - PRINT *,' !!!!!! MATCAL WARNING : Incorrect argument'// 383 - - ' list provided for WRITE_MATRIX.' 384 - RETURN 385 - ENDIF 386 - * Fetch file name. 387 - CALL STRBUF('READ',NINT(ARG(2)),FILE,NCFILE,IFAIL1) 388 - * Member name. 389 - IF(NARG.GE.3)THEN 390 - CALL STRBUF('READ',NINT(ARG(3)),MEMBER,NCMEMB,IFAIL2) 391 - IF(NCMEMB.GT.8)PRINT *,' !!!!!! MATCAL WARNING :'// 392 - - ' Member name truncated to first 8 characters' 393 - NCMEMB=MIN(8,NCMEMB) 394 - ELSE 395 - DO 120 J=1,NGLB 396 - IF(GLBMOD(J).NE.5)GOTO 120 397 - IF(NINT(GLBVAL(J)).EQ.NINT(ARG(1)))THEN 398 - MEMBER=GLBVAR(J) 399 - NCMEMB=8 400 - GOTO 130 401 - ENDIF 402 - 120 CONTINUE 403 - MEMBER='< none >' 404 - NCMEMB=8 405 - 130 CONTINUE 406 - IFAIL2=0 407 - ENDIF 408 - * Remark. 409 - IF(NARG.GE.4)THEN 410 - CALL STRBUF('READ',NINT(ARG(4)),REMARK,NCREM,IFAIL3) 411 - IF(NCREM.GT.29)PRINT *,' !!!!!! MATCAL WARNING :'// 412 - - ' Remark truncated to first 29 characters' 413 - NCREM=MIN(29,NCREM) 414 - ELSE 415 - REMARK='none' 416 - NCREM=4 417 - IFAIL3=0 418 - ENDIF 419 - * Write the matrix. 420 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN 421 - CALL MATWRT(NINT(ARG(1)),FILE(1:NCFILE), 422 - - MEMBER(1:NCMEMB),REMARK(1:NCREM),IFAIL2) 423 - IF(IFAIL2.NE.0)PRINT *,' !!!!!! MATCAL WARNING :'// 424 - - ' Writing matrix to disk failed.' 425 - ELSE 426 - PRINT *,' !!!!!! MATCAL WARNING :'// 427 - - ' Not able to obtain a name; matrix'// 428 - - ' not written to disk.' 429 - ENDIF 430 - *** Get a matrix from a library. 431 - ELSEIF(IPROC.EQ.-89)THEN 432 - * Check number and type of arguments. 433 - IF(ARGREF(1,1).GE.2.OR. 434 - - MODARG(2).NE.1.OR. 435 - - (NARG.GE.3.AND.MODARG(3).NE.1).OR. 436 - - NARG.LT.2.OR.NARG.GT.3)THEN 437 - PRINT *,' !!!!!! MATCAL WARNING : Incorrect argument'// 438 - - ' list provided for GET_MATRIX.' 439 - RETURN 440 - ENDIF 441 - * Fetch file name. 442 - CALL STRBUF('READ',NINT(ARG(2)),FILE,NCFILE,IFAIL1) 443 - * Fetch member name, if any. 444 - IF(NARG.GE.3)THEN 445 - CALL STRBUF('READ',NINT(ARG(3)),MEMBER,NCMEMB,IFAIL2) 446 - IF(NCMEMB.GT.8)PRINT *,' !!!!!! MATCAL WARNING :'// 447 - - ' Member name truncated to first 8 characters' 448 - NCMEMB=MIN(8,NCMEMB) 449 - ELSEIF(ARGREF(1,2).GE.1.AND.ARGREF(1,2).LE.NGLB)THEN 450 - MEMBER=GLBVAR(ARGREF(1,2)) 451 - NCMEMB=8 452 - IFAIL2=0 453 - ELSE 454 - MEMBER='*' 455 - NCMEMB=1 456 - IFAIL2=0 457 - ENDIF 458 - * Read the matrix. 459 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN 460 - CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) 461 - CALL MATGET(IREF,FILE(1:NCFILE), 462 - - MEMBER(1:NCMEMB),IFAIL3) 463 - IF(IFAIL3.NE.0)THEN 464 - PRINT *,' !!!!!! MATCAL WARNING :'// 465 - - ' Reading matrix from disk failed.' 466 - ARG(1)=0 467 - MODARG(1)=0 468 - ELSE 469 - ARG(1)=IREF 470 - MODARG(1)=5 471 - ENDIF 1 398 P=MATRIX D=MATCAL 6 PAGE 495 472 - ELSE 473 - PRINT *,' !!!!!! MATCAL WARNING :'// 474 - - ' Not able to obtain a name; matrix'// 475 - - ' not read from disk.' 476 - ENDIF 477 - *** Matrix multiplication. 478 - ELSEIF(IPROC.EQ.-90)THEN 479 - *** Solve linear equation. 480 - ELSEIF(IPROC.EQ.-91)THEN 481 - *** Return matrix dimensions. 482 - ELSEIF(IPROC.EQ.-92)THEN 483 - * Check number and type of arguments. 484 - IF(NARG.NE.3.OR. 485 - - ARGREF(2,1).GE.2.OR.ARGREF(3,1).GE.2.OR. 486 - - MODARG(1).NE.5)THEN 487 - PRINT *,' !!!!!! MATCAL WARNING : Incorrect argument'// 488 - - ' list provided for DIMENSIONS.' 489 - RETURN 490 - ENDIF 491 - * Locate the matrix. 492 - DO 180 I=1,MXMAT 493 - IF(MREF(I).EQ.NINT(ARG(1)))THEN 494 - ISLOT=I 495 - NDIM=MDIM(I) 496 - GOTO 140 497 - ENDIF 498 - 180 CONTINUE 499 - PRINT *,' !!!!!! MATCAL WARNING : Matrix not found;'// 500 - - ' no dimensions returned.' 501 - RETURN 502 - 140 CONTINUE 503 - * Clear the output arguments. 504 - CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) 505 - CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) 506 - * Store the dimension. 507 - ARG(2)=NDIM 508 - MODARG(2)=2 509 - * Get a matrix for the dimensions. 510 - ISIZ(1)=NDIM 511 - CALL MATADM('ALLOCATE',IREFD,1,ISIZ,2,IFAIL1) 512 - IF(IFAIL1.NE.0)RETURN 513 - ISLOT=-1 514 - ISLOTD=-1 515 - DO 150 I=1,MXMAT 516 - IF(MREF(I).EQ.NINT(ARG(1)))THEN 517 - ISLOT=I 518 - ELSEIF(MREF(I).EQ.IREFD)THEN 519 - ISLOTD=I 520 - ENDIF 521 - IF(ISLOT.GT.0.AND.ISLOTD.GT.0)GOTO 160 522 - 150 CONTINUE 523 - PRINT *,' !!!!!! MATCAL WARNING : Matrix not found;'// 524 - - ' no dimensions returned.' 525 - RETURN 526 - 160 CONTINUE 527 - * Store the dimensions. 528 - DO 170 J=1,NDIM 529 - MVEC(MORG(ISLOTD)+J)=MSIZ(ISLOT,J) 530 - 170 CONTINUE 531 - * Save the output. 532 - ARG(3)=IREFD 533 - MODARG(3)=5 534 - *** Matrix interpolation. 535 - ELSEIF(IPROC.EQ.-93)THEN 536 - * Check the format of the argument list. 537 - IF(NARG.LT.4.OR.ARGREF(NARG,1).GE.2.OR. 538 - - MODARG(1).NE.5.OR.MODARG(NARG-1).NE.5)THEN 539 - PRINT *,' !!!!!! MATCAL WARNING : INTERPOLATE'// 540 - - ' received an invalid argument list.' 541 - RETURN 542 - ENDIF 543 - * Locate the matrix. 544 - ISMAT=MATSLT(NINT(ARG(1))) 545 - IF(ISMAT.LE.0)THEN 546 - PRINT *,' !!!!!! MATCAL WARNING : Matrix to be'// 547 - - ' interpolated has not been found.' 548 - RETURN 549 - ENDIF 550 - * Determine the size of the combined ordinate vector. 551 - LORD=0 552 - DO 203 I=1,MDIM(ISMAT) 553 - LORD=LORD+MSIZ(ISMAT,I) 554 - 203 CONTINUE 555 - * Allocate a matrix for the combined ordinate vector. 556 - ISIZ(1)=LORD 557 - CALL MATADM('ALLOCATE',IRORD,1,ISIZ,2,IFAIL1) 558 - IF(IFAIL1.NE.0)THEN 559 - PRINT *,' !!!!!! MATCAL WARNING : Unable to allocate'// 560 - - ' an ordinate vector.' 561 - RETURN 562 - ENDIF 563 - * And find this matrix. 564 - ISORD=MATSLT(IRORD) 565 - IF(ISORD.LE.0)THEN 566 - PRINT *,' !!!!!! MATCAL WARNING : Combined ordinate'// 567 - - ' vector not found.' 568 - RETURN 569 - ENDIF 570 - * Find the matrix again. 571 - ISMAT=MATSLT(NINT(ARG(1))) 572 - IF(ISMAT.LE.0)THEN 573 - PRINT *,' !!!!!! MATCAL WARNING : Matrix to be'// 574 - - ' interpolated has not been found.' 575 - RETURN 576 - ENDIF 577 - * Loop over the ordinate vectors. 1 398 P=MATRIX D=MATCAL 7 PAGE 496 578 - NORD=0 579 - DO 200 I=2,NARG-2 580 - IF(MODARG(I).NE.5)THEN 581 - PRINT *,' !!!!!! MATCAL WARNING : An'// 582 - - ' ordinate vector is not a declared matrix.' 583 - CALL MATADM('DELETE',IRORD,1,ISIZ,2,IFAIL1) 584 - RETURN 585 - ENDIF 586 - * Locate the vector. 587 - ISORDI=MATSLT(NINT(ARG(I))) 588 - IF(ISORDI.LE.0)THEN 589 - PRINT *,' !!!!!! MATCAL WARNING : An ordinate'// 590 - - ' vector has not been found.' 591 - CALL MATADM('DELETE',IRORD,1,ISIZ,2,IFAIL1) 592 - RETURN 593 - ENDIF 594 - * Ensure it is a 1-dimensional vector and the right size. 595 - IF(MDIM(ISORDI).NE.1.OR. 596 - - MSIZ(ISORDI,1).NE.MSIZ(ISMAT,I-1))THEN 597 - PRINT *,' !!!!!! MATCAL WARNING : An'// 598 - - ' ordinate vector is not of the right size.' 599 - CALL MATADM('DELETE',IRORD,1,ISIZ,2,IFAIL1) 600 - RETURN 601 - ENDIF 602 - * Copy this vector to the large ordinate vector, checking ordering. 603 - DO 230 J=1,MSIZ(ISORDI,1) 604 - NORD=NORD+1 605 - MVEC(MORG(ISORD)+NORD)=MVEC(MORG(ISORDI)+J) 606 - IF(J.GT.1)THEN 607 - IF(MVEC(MORG(ISORDI)+J).LE.MVEC(MORG(ISORDI)+J-1))THEN 608 - PRINT *,' !!!!!! MATCAL WARNING : An ordinate'// 609 - - ' vector is not well ordered.' 610 - CALL MATADM('DELETE',IRORD,1,ISIZ,2,IFAIL1) 611 - RETURN 612 - ENDIF 613 - ENDIF 614 - 230 CONTINUE 615 - * Next dimension. 616 - 200 CONTINUE 617 - * Output argument. 618 - IF(MODARG(NARG).EQ.5)THEN 619 - IROUT=NINT(ARG(NARG)) 620 - ELSE 621 - IROUT=-1 622 - ENDIF 623 - * Call the interpolation routine. 624 - CALL MATINN(NINT(ARG(1)),IRORD,NINT(ARG(NARG-1)), 625 - - IROUT,IFAIL2) 626 - IF(IFAIL2.NE.0)PRINT *,' !!!!!! MATCAL WARNING :'// 627 - - ' Matrix interpolation failed.' 628 - * Assign the output. 629 - ARG(NARG)=IROUT 630 - MODARG(NARG)=5 631 - * Remove the ordinate vector. 632 - CALL MATADM('DELETE',IRORD,1,ISIZ,2,IFAIL1) 633 - IF(IFAIL2.NE.0)RETURN 634 - *** Surface plots. 635 - ELSEIF(IPROC.EQ.-94)THEN 636 - * Check argument list. 637 - IF(NARG.LT.1.OR.NARG.GT.8.OR. 638 - - MODARG(1).NE.5.OR. 639 - - (NARG.GE.2.AND.MODARG(2).NE.2).OR. 640 - - (NARG.GE.3.AND.MODARG(3).NE.2).OR. 641 - - (NARG.GE.4.AND.MODARG(4).NE.5).OR. 642 - - (NARG.GE.5.AND.MODARG(5).NE.5).OR. 643 - - (NARG.GE.6.AND.MODARG(6).NE.1).OR. 644 - - (NARG.GE.7.AND.MODARG(7).NE.1).OR. 645 - - (NARG.GE.8.AND.MODARG(8).NE.1))THEN 646 - PRINT *,' !!!!!! MATCAL WARNING : Some arguments of'// 647 - - ' PLOT_SURFACE are of incorrect type.' 648 - RETURN 649 - ENDIF 650 - * Plotting angles. 651 - IF(NARG.GE.2)THEN 652 - THETA=ARG(2) 653 - ELSE 654 - THETA=60 655 - ENDIF 656 - IF(NARG.GE.3)THEN 657 - PHI=ARG(3) 658 - ELSE 659 - PHI=60 660 - ENDIF 661 - * Axis ranges. 662 - IF(NARG.GE.4)THEN 663 - IREFX=NINT(ARG(4)) 664 - ELSE 665 - IREFX=-1 666 - ENDIF 667 - IF(NARG.GE.5)THEN 668 - IREFY=NINT(ARG(5)) 669 - ELSE 670 - IREFY=-1 671 - ENDIF 672 - * Fetch the x-axis label. 673 - IF(NARG.GE.6)THEN 674 - CALL STRBUF('READ',NINT(ARG(6)),XTXT,NCXTXT,IFAIL1) 675 - ELSEIF(NARG.GE.4)THEN 676 - DO 171 J=1,NGLB 677 - IF(GLBMOD(J).NE.5)GOTO 171 678 - IF(NINT(GLBVAL(J)).EQ.IREFX)THEN 679 - XTXT=GLBVAR(J) 680 - NCXTXT=10 681 - GOTO 172 682 - ENDIF 683 - 171 CONTINUE 1 398 P=MATRIX D=MATCAL 8 PAGE 497 684 - XTXT='x-axis' 685 - NCXTXT=6 686 - 172 CONTINUE 687 - IFAIL1=0 688 - ELSE 689 - XTXT='x-axis' 690 - NCXTXT=6 691 - IFAIL1=0 692 - ENDIF 693 - * Fetch the y-axis label. 694 - IF(NARG.GE.7)THEN 695 - CALL STRBUF('READ',NINT(ARG(7)),YTXT,NCYTXT,IFAIL2) 696 - ELSEIF(NARG.GE.5)THEN 697 - DO 173 J=1,NGLB 698 - IF(GLBMOD(J).NE.5)GOTO 173 699 - IF(NINT(GLBVAL(J)).EQ.IREFY)THEN 700 - YTXT=GLBVAR(J) 701 - NCYTXT=10 702 - GOTO 174 703 - ENDIF 704 - 173 CONTINUE 705 - YTXT='y-axis' 706 - NCYTXT=6 707 - 174 CONTINUE 708 - IFAIL2=0 709 - ELSE 710 - YTXT='y-axis' 711 - NCYTXT=6 712 - IFAIL2=0 713 - ENDIF 714 - * Fetch the global title. 715 - IF(NARG.GE.8)THEN 716 - CALL STRBUF('READ',NINT(ARG(8)),TITLE,NCTIT,IFAIL3) 717 - ELSE 718 - DO 175 J=1,NGLB 719 - IF(GLBMOD(J).NE.5)GOTO 175 720 - IF(NINT(GLBVAL(J)).EQ.NINT(ARG(1)))THEN 721 - TITLE=GLBVAR(J) 722 - NCTIT=10 723 - GOTO 176 724 - ENDIF 725 - 175 CONTINUE 726 - TITLE=' ' 727 - NCTIT=1 728 - 176 CONTINUE 729 - IFAIL3=0 730 - ENDIF 731 - * Plot the surface. 732 - CALL MATSUR(NINT(ARG(1)),IREFX,IREFY,XTXT(1:NCXTXT), 733 - - YTXT(1:NCYTXT),TITLE(1:NCTIT),PHI,THETA) 734 - * Switch back to normal screen. 735 - CALL GRALPH 736 - * Error processing. 737 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0) 738 - - PRINT *,' !!!!!! MATCAL WARNING : Error'// 739 - - ' retrieving a string for PLOT_SURFACE.' 740 - *** Contour plots. 741 - ELSEIF(IPROC.EQ.-100)THEN 742 - * Check argument list. 743 - IF(NARG.LT.1.OR.NARG.GT.8.OR. 744 - - MODARG(1).NE.5.OR. 745 - - (NARG.GE.2.AND.MODARG(2).NE.2).OR. 746 - - (NARG.GE.3.AND.MODARG(3).NE.1).OR. 747 - - (NARG.GE.4.AND.MODARG(4).NE.5).OR. 748 - - (NARG.GE.5.AND.MODARG(5).NE.5).OR. 749 - - (NARG.GE.6.AND.MODARG(6).NE.1).OR. 750 - - (NARG.GE.7.AND.MODARG(7).NE.1).OR. 751 - - (NARG.GE.8.AND.MODARG(8).NE.1))THEN 752 - PRINT *,' !!!!!! MATCAL WARNING : Some arguments of'// 753 - - ' PLOT_CONTOURS are of incorrect type.' 754 - RETURN 755 - ENDIF 756 - * Fetch the options, if present. 757 - IF(NARG.GE.2)THEN 758 - NCONT=NINT(ARG(2)) 759 - ELSE 760 - NCONT=20 761 - ENDIF 762 - IF(NARG.GE.3)THEN 763 - CALL STRBUF('READ',NINT(ARG(3)),OPTION,NCOPT,IFAIL4) 764 - CALL CLTOU(OPTION(1:NCOPT)) 765 - ELSE 766 - OPTION=' ' 767 - NCOPT=1 768 - IFAIL4=0 769 - ENDIF 770 - * Axis ranges. 771 - IF(NARG.GE.4)THEN 772 - IREFX=NINT(ARG(4)) 773 - ELSE 774 - IREFX=-1 775 - ENDIF 776 - IF(NARG.GE.5)THEN 777 - IREFY=NINT(ARG(5)) 778 - ELSE 779 - IREFY=-1 780 - ENDIF 781 - * Fetch the x-axis label. 782 - IF(NARG.GE.6)THEN 783 - CALL STRBUF('READ',NINT(ARG(6)),XTXT,NCXTXT,IFAIL1) 784 - ELSEIF(NARG.GE.4.AND. 785 - - ARGREF(4,2).GE.1.AND.ARGREF(4,2).LE.NGLB)THEN 786 - XTXT=GLBVAR(ARGREF(4,2)) 787 - NCXTXT=LEN(GLBVAR(ARGREF(4,2))) 788 - IFAIL1=0 789 - ELSE 1 398 P=MATRIX D=MATCAL 9 PAGE 498 790 - XTXT='x-axis' 791 - NCXTXT=6 792 - IFAIL1=0 793 - ENDIF 794 - * Fetch the y-axis label. 795 - IF(NARG.GE.7)THEN 796 - CALL STRBUF('READ',NINT(ARG(7)),YTXT,NCYTXT,IFAIL2) 797 - ELSEIF(NARG.GE.5.AND. 798 - - ARGREF(5,2).GE.1.AND.ARGREF(5,2).LE.NGLB)THEN 799 - YTXT=GLBVAR(ARGREF(5,2)) 800 - NCYTXT=LEN(GLBVAR(ARGREF(5,2))) 801 - IFAIL2=0 802 - ELSE 803 - YTXT='y-axis' 804 - NCYTXT=6 805 - IFAIL2=0 806 - ENDIF 807 - * Fetch the global title. 808 - IF(NARG.GE.8)THEN 809 - CALL STRBUF('READ',NINT(ARG(8)),TITLE,NCTIT,IFAIL3) 810 - ELSEIF(NARG.GE.1.AND. 811 - - ARGREF(1,2).GE.1.AND.ARGREF(1,2).LE.NGLB)THEN 812 - TITLE=GLBVAR(ARGREF(1,2)) 813 - NCTIT=LEN(GLBVAR(ARGREF(1,2))) 814 - IFAIL3=0 815 - ELSE 816 - TITLE='Matrix contours' 817 - NCTIT=15 818 - IFAIL3=0 819 - ENDIF 820 - * Plot the surface. 821 - CALL MATCON(NINT(ARG(1)),IREFX,IREFY,XTXT(1:NCXTXT), 822 - - YTXT(1:NCYTXT),TITLE(1:NCTIT),NCONT,OPTION(1:NCOPT)) 823 - * Switch back to normal screen. 824 - CALL GRALPH 825 - * Error processing. 826 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR.IFAIL4.NE.0) 827 - - PRINT *,' !!!!!! MATCAL WARNING : Error'// 828 - - ' retrieving a string for PLOT_CONTOURS.' 829 - *** Derivative. 830 - ELSEIF(IPROC.EQ.-95)THEN 831 - * Check argument list. 832 - IF(NARG.LT.4.OR.NARG.GT.5.OR. 833 - - MODARG(1).NE.5.OR.MODARG(2).NE.5.OR.MODARG(3).NE.2.OR. 834 - - ARGREF(4,1).GE.2.OR. 835 - - (NARG.GE.5.AND.MODARG(5).NE.1))THEN 836 - PRINT *,' !!!!!! MATCAL WARNING : Some arguments of'// 837 - - ' DERIVATIVE are of incorrect type.' 838 - RETURN 839 - ENDIF 840 - * Get hold of the option string. 841 - IF(NARG.GE.5)THEN 842 - CALL STRBUF('READ',NINT(ARG(5)),TITLE,NCTIT,IFAIL1) 843 - CALL CLTOU(TITLE(1:NCTIT)) 844 - ELSE 845 - TITLE=' ' 846 - NCTIT=1 847 - IFAIL1=0 848 - ENDIF 849 - * Calculate the derivative. 850 - CALL MATDER(NINT(ARG(1)),NINT(ARG(2)),ARG(3),AUX, 851 - - TITLE(1:NCTIT),IFAIL2) 852 - * Clear the memory associated with the return argument. 853 - CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 854 - * Return the result. 855 - ARG(4)=AUX 856 - MODARG(4)=2 857 - * Error processing. 858 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0) 859 - - PRINT *,' !!!!!! MATCAL WARNING : Error'// 860 - - ' processing a DERIVATIVE call.' 861 - *** Interpolation of various orders. 862 - ELSEIF(IPROC.EQ.-96.OR.IPROC.EQ.-97.OR.IPROC.EQ.-98.OR. 863 - - IPROC.EQ.-99)THEN 864 - * Check argument list. 865 - IF(NARG.NE.4.OR. 866 - - MODARG(1).NE.5.OR.MODARG(2).NE.5.OR.MODARG(3).NE.2.OR. 867 - - ARGREF(4,1).GE.2)THEN 868 - PRINT *,' !!!!!! MATCAL WARNING : Some arguments of'// 869 - - ' INTERPOLATE_i are of incorrect type.' 870 - RETURN 871 - ENDIF 872 - * Clear the output argument. 873 - CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 874 - * Call the procedure. 875 - ISDUM1=-1 876 - ISDUM2=-1 877 - IF(IPROC.EQ.-96)THEN 878 - CALL MATIN1(NINT(ARG(1)),NINT(ARG(2)),1,ARG(3),ARG(4), 879 - - ISDUM1,ISDUM2,1,IFAIL1) 880 - ELSEIF(IPROC.EQ.-97)THEN 881 - CALL MATIN1(NINT(ARG(1)),NINT(ARG(2)),1,ARG(3),ARG(4), 882 - - ISDUM1,ISDUM2,2,IFAIL1) 883 - ELSEIF(IPROC.EQ.-98)THEN 884 - CALL MATIN1(NINT(ARG(1)),NINT(ARG(2)),1,ARG(3),ARG(4), 885 - - ISDUM1,ISDUM2,3,IFAIL1) 886 - ELSEIF(IPROC.EQ.-99)THEN 887 - CALL MATIN1(NINT(ARG(1)),NINT(ARG(2)),1,ARG(3),ARG(4), 888 - - ISDUM1,ISDUM2,4,IFAIL1) 889 - ENDIF 890 - MODARG(4)=2 891 - * Check the error condition. 892 - IF(IFAIL1.NE.0)THEN 893 - PRINT *,' !!!!!! MATCAL WARNING : INTERPOLATE_n did'// 894 - - ' not work correctly; no interpolation.' 895 - RETURN 1 398 P=MATRIX D=MATCAL 10 PAGE 499 896 - ENDIF 897 - *** Plot an error band. 898 - ELSEIF(IPROC.EQ.-101)THEN 899 - * Check number of arguments. 900 - IF(NARG.NE.3.OR.MODARG(1).NE.5.OR.MODARG(2).NE.5.OR. 901 - - MODARG(3).NE.5)THEN 902 - PRINT *,' !!!!!! MATCAL WARNING : Incorrect set of'// 903 - - ' arguments for ERROR_BAND.' 904 - RETURN 905 - ENDIF 906 - * Switch to graphics screen. 907 - CALL GRGRAF(.FALSE.) 908 - * Plot the error band. 909 - CALL MATBND(NINT(ARG(1)),NINT(ARG(2)),NINT(ARG(3))) 910 - * Switch back to alphanumeric screen. 911 - CALL GRALPH 912 - *** Find zeroes of a matrix vs another matrix. 913 - ELSEIF(IPROC.EQ.-102)THEN 914 - * Check the arguments. 915 - IWRONG=0 916 - DO 240 I=4,NARG 917 - IF(ARGREF(I,1).GE.2)IWRONG=IWRONG+1 918 - 240 CONTINUE 919 - IF(NARG.LT.3.OR.MODARG(1).NE.5.OR.MODARG(2).NE.5.OR. 920 - - ARGREF(3,1).GE.2.OR.IWRONG.GT.0)THEN 921 - PRINT *,' !!!!!! MATCAL WARNING : Incorrect set of'// 922 - - ' arguments for ZEROES; no zero search.' 923 - RETURN 924 - ENDIF 925 - * Get the zero crossings. 926 - CALL MATZRO(NINT(ARG(1)),NINT(ARG(2)),NZERO,ZERO,IFAIL1) 927 - ARG(3)=REAL(NZERO) 928 - MODARG(3)=2 929 - DO 190 I=4,MXARG 930 - CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 931 - IF(I-3.LE.NZERO)THEN 932 - ARG(I)=ZERO(I-3) 933 - MODARG(I)=2 934 - ELSE 935 - ARG(I)=0 936 - MODARG(I)=0 937 - ENDIF 938 - 190 CONTINUE 939 - *** Unknown matrix operation. 940 - ELSE 941 - PRINT *,' !!!!!! MATCAL WARNING : Unknown procedure code'// 942 - - ' received; nothing done.' 943 - IFAIL=1 944 - RETURN 945 - ENDIF 946 - *** Seems to have worked. 947 - IFAIL=0 948 - END 399 GARFIELD ================================================== P=MATRIX D=MATCHS 1 ============================ 0 + +DECK,MATCHS. 1 - SUBROUTINE MATCHS(IREF,NDIM,IDIM,PAD,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MATCHS - Changes the format of a matrix. 4 - * (Last changed on 10/ 4/96.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,MATDATA. 8.- +SEQ,PRINTPLOT. 9 - INTEGER IREF,IREFN,NDIM,IDIM(*),IFAIL,ISLOT,ISLOTN,MATSLT,IMOD 10 - REAL PAD 11 - EXTERNAL MATSLT 12 - *** Identify the routine if requested. 13 - IF(LIDENT)PRINT *,' /// ROUTINE MATCHS ///' 14 - *** Debugging information. 15 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATCHS DEBUG : Changing '', 16 - - I5,'' to '',I5,'' dimensions, pad='',E12.5)') 17 - - IREF,NDIM,PAD 18 - *** Initial value of the failure flag. 19 - IFAIL=1 20 - *** Check validity of reference. 21 - IF(IREF.LE.0)THEN 22 - PRINT *,' !!!!!! MATCHS WARNING : Non-positive reference'// 23 - - ' given; matrix not re-shaped.' 24 - RETURN 25 - ENDIF 26 - *** Find the mode of the current matrix. 27 - ISLOT=MATSLT(IREF) 28 - IF(ISLOT.LE.0)THEN 29 - PRINT *,' !!!!!! MATCHS WARNING : Matrix to be re-shaped'// 30 - - ' has not been found.' 31 - RETURN 32 - ENDIF 33 - IMOD=MMOD(ISLOT) 34 - *** Allocate space for the new matrix. 35 - CALL MATADM('ALLOCATE',IREFN,NDIM,IDIM,IMOD,IFAIL1) 36 - IF(IFAIL1.NE.0)THEN 37 - PRINT *,' !!!!!! MATCHS WARNING : Unable to allocate'// 38 - - ' space for the re-shaped matrix ; not re-shaped.' 39 - RETURN 40 - ENDIF 41 - *** Locate the current matrix. 42 - ISLOT=MATSLT(IREF) 43 - IF(ISLOT.LE.0)THEN 44 - PRINT *,' !!!!!! MATCHS WARNING : Matrix to be re-shaped'// 45 - - ' has not been found.' 46 - RETURN 47 - ENDIF 48 - *** Find where the new matrix sits. 49 - ISLOTN=MATSLT(IREFN) 1 399 P=MATRIX D=MATCHS 2 PAGE 500 50 - IF(ISLOTN.LE.0)THEN 51 - PRINT *,' !!!!!! MATCHS WARNING : New matrix not found;'// 52 - - ' program bug - please report.' 53 - RETURN 54 - ENDIF 55 - *** Copy the old matrix to the new one. 56 - DO 60 I=1,MIN(MLEN(ISLOT),MLEN(ISLOTN)) 57 - MVEC(MORG(ISLOTN)+I)=MVEC(MORG(ISLOT)+I) 58 - 60 CONTINUE 59 - DO 70 I=MLEN(ISLOT)+1,MLEN(ISLOTN) 60 - MVEC(MORG(ISLOTN)+I)=PAD 61 - 70 CONTINUE 62 - *** Modify the pointer information. 63 - MREF(ISLOTN)=MREF(ISLOT) 64 - *** Delete the old matrix. 65 - MREF(ISLOT)=0 66 - *** Things seem to have worked. 67 - IFAIL=0 68 - END 400 GARFIELD ================================================== P=MATRIX D=MATDER 1 ============================ 0 + +DECK,MATDER. 1 - SUBROUTINE MATDER(IRX,IRY,XINT,DERIV,OPTION,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MATDER - Computes a numerical derivative of one vector interpolated 4 - * vs another vector. 5 - * (Last changed on 8/ 5/96.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9.- +SEQ,PRINTPLOT. 10 - REAL F1,F2,FM,EPS,EPSMAX,DELTA,XINT,DERIV,DIVDIF 11 - INTEGER I,N,ITER,NITMAX,INIT,IORD,IRX,IRY,MATSLT,MATADR,IFAIL 12 - CHARACTER*(*) OPTION 13 - EXTERNAL DIVDIF,MATSLT,MATADR 0 14-+ +SELF,IF=SAVE. 15 - SAVE INIT,NITMAX,DELTA 0 16-+ +SELF. 17 - *** Identify the routine if requested. 18 - IF(LIDENT)PRINT *,' /// ROUTINE MATDER ///' 19 - *** Preset the IFAIL flag. 20 - IFAIL=1 21 - *** Decode the option string. 22 - IORD=2 23 - IF(INDEX(OPTION,'LINEAR').NE.0)THEN 24 - IORD=1 25 - ELSEIF(INDEX(OPTION,'PARABOLIC')+ 26 - - INDEX(OPTION,'QUADRATIC').NE.0)THEN 27 - IORD=2 28 - ELSEIF(INDEX(OPTION,'CUBIC').NE.0)THEN 29 - IORD=3 30 - ENDIF 31 - *** Locate the matrices. 32 - ISX=MATSLT(IRX) 33 - ISY=MATSLT(IRY) 34 - IF(ISX.LE.0.OR.ISY.LE.0)THEN 35 - PRINT *,' !!!!!! MATDER WARNING : Unable to find an'// 36 - - ' input vector; no derivative.' 37 - RETURN 38 - ENDIF 39 - IF(MDIM(ISX).NE.1.OR.MDIM(ISY).NE.1.OR. 40 - - MLEN(ISX).NE.MLEN(ISY).OR. 41 - - MLEN(ISX).LT.IORD+1.OR. 42 - - MLEN(ISY).LT.IORD+1)THEN 43 - PRINT *,' !!!!!! MATDER WARNING : Input matrices not'// 44 - - ' 1D, not same length or too short; no derivative.' 45 - RETURN 46 - ENDIF 47 - N=MIN(MLEN(ISX),MLEN(ISY)) 48 - *** Debugging output. 49 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATDER DEBUG : x='',I5, 50 - - '', y='',I5,'' length='',I5,'' order='',I5)') IRX,IRY,N,IORD 51 - *** Check proper sequence. 52 - DO 100 I=1,N-1 53 - IF(MVEC(MORG(ISX)+I).GE.MVEC(MORG(ISX)+I+1))THEN 54 - PRINT *,' !!!!!! MATDER WARNING : Ordinates not ordered'// 55 - - ' ; no derivative calculated.' 56 - RETURN 57 - ENDIF 58 - 100 CONTINUE 59 - *** Initialise delta. 60 - DATA INIT/0/ 61 - IF(INIT.EQ.0)THEN 62 - * Set number of iterations. 63 - NITMAX=50 64 - * Compute DELTA. 65 - DELTA=1 66 - ITER=0 67 - 10 CONTINUE 68 - ITER=ITER+1 69 - IF(1+DELTA.GT.1)THEN 70 - DELTA=DELTA/2 71 - IF(ITER.LE.NITMAX)GOTO 10 72 - DELTA=1E-8 73 - ENDIF 74 - DELTA=SQRT(DELTA) 75 - * Initialisation done. 76 - INIT=1 77 - * Debugging output. 78 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATDER DEBUG :'', 79 - - '' Delta='',E12.5,'', Iter max='',I5)') DELTA,NITMAX 80 - ENDIF 81 - *** Find minimum and maximum value for EPS. 1 400 P=MATRIX D=MATDER 2 PAGE 501 82 - DO 20 I=1,N-1 83 - * Intermediate points. 84 - IF((MVEC(MORG(ISX)+I)-XINT)*(XINT-MVEC(MORG(ISX)+I+1)).GE.0)THEN 85 - EPSMAX=MAX(DELTA,ABS(XINT-MVEC(MORG(ISX)+I)), 86 - - ABS(XINT-MVEC(MORG(ISX)+I+1))) 87 - GOTO 30 88 - ENDIF 89 - 20 CONTINUE 90 - * External points. 91 - IF(XINT.LT.MVEC(MORG(ISX)+1))THEN 92 - EPSMAX=MAX(DELTA,2*ABS(XINT-MVEC(MORG(ISX)+1))) 93 - ELSE 94 - EPSMAX=MAX(DELTA,2*ABS(XINT-MVEC(MORG(ISX)+N))) 95 - ENDIF 96 - 30 CONTINUE 97 - *** Iterate to find the proper value for EPS, starting values. 98 - FM=DIVDIF(MVEC(MORG(ISY)+1),MVEC(MORG(ISX)+1),N,XINT,IORD) 99 - EPS=DELTA*(1+ABS(XINT)) 100 - ITER=0 101 - * Loop. 102 - 40 CONTINUE 103 - * Increment iteration counter to avoid endless loops. 104 - ITER=ITER+1 105 - * Compute function values at x +/- eps. 106 - F1=DIVDIF(MVEC(MORG(ISY)+1),MVEC(MORG(ISX)+1),N,XINT+EPS,IORD) 107 - F2=DIVDIF(MVEC(MORG(ISY)+1),MVEC(MORG(ISX)+1),N,XINT-EPS,IORD) 108 - * Update EPS accordingly. 109 - IF(ITER.GT.NITMAX)THEN 110 - GOTO 50 111 - ELSEIF(ABS(F1-F2).GT.5*DELTA*MAX(ABS(F1),ABS(FM),ABS(F2)))THEN 112 - EPS=EPS/2 113 - IF(EPS.GT.EPSMAX)GOTO 50 114 - ELSEIF(ABS(F1-F2).LT.DELTA*MAX(ABS(F1),ABS(FM),ABS(F2))/5)THEN 115 - EPS=2*EPS 116 - ELSE 117 - GOTO 50 118 - ENDIF 119 - GOTO 40 120 - 50 CONTINUE 121 - *** Set the derivative. 122 - DERIV=(F1-F2)/(2*EPS) 123 - *** Debugging output. 124 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATDER DEBUG : For x='', 125 - - E12.5,'' found dy='',E12.5)') XINT,DERIV 126 - *** Seems to have worked. 127 - IFAIL=0 128 - END 401 GARFIELD ================================================== P=MATRIX D=MATERR 1 ============================ 0 + +DECK,MATERR. 1 - SUBROUTINE MATERR(IRX,IRY,IREX1,IREY1,IREX2,IREY2,TYPE,SIZE) 2 - *----------------------------------------------------------------------- 3 - * MATERR - Plots error bars. 4 - * (Last changed on 19/ 7/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,CONSTANTS. 11 - REAL X0,X1,X2,Y0,Y1,Y2,SIZE,XPL(80),YPL(80),STFACT,XC,YC, 12 - - EX1,EY1,EX2,EY2 13 - INTEGER IRX,IRY,IREX1,IREY1,IREX2,IREY2,I,J,NPOINT, 14 - - ISX,ISY,ISEX1,ISEY1,ISEX2,ISEY2,MATSLT,IERR,NT 15 - CHARACTER*(*) TYPE 16 - EXTERNAL MATSLT 17 - *** Locate the matrices. 18 - ISX=MATSLT(IRX) 19 - ISY=MATSLT(IRY) 20 - ISEX1=MATSLT(IREX1) 21 - ISEY1=MATSLT(IREY1) 22 - ISEX2=MATSLT(IREX2) 23 - ISEY2=MATSLT(IREY2) 24 - *** Determine current NT. 25 - CALL GQCNTN(IERR,NT) 26 - IF(IERR.NE.0)THEN 27 - PRINT *,' !!!!!! MATERR WARNING : Error from'// 28 - - ' GQCNTN, code=',IERR,'; no error bars plotted.' 29 - RETURN 30 - ENDIF 31 - *** Make sure that the marker type makes sense. 32 - IF(INDEX(TYPE,'CIRCLE')+INDEX(TYPE,'SQUARE')+ 33 - - INDEX(TYPE,'CROSS')+INDEX(TYPE,'PLUS')+ 34 - - INDEX(TYPE,'ELLIPSE')+INDEX(TYPE,'TRIANGLE')+ 35 - - INDEX(TYPE,'STAR')+INDEX(TYPE,'DAVID')+ 36 - - INDEX(TYPE,'HEXAGON').EQ.0)THEN 37 - PRINT *,' !!!!!! MATERR WARNING : Error bar model ', 38 - - TYPE,' not known ; no error bars plotted.' 39 - RETURN 40 - ENDIF 41 - *** Check the size of the markers. 42 - IF(SIZE.LE.0.OR.SIZE.GT.1.0)THEN 43 - PRINT *,' !!!!!! MATERR WARNING : Error bar size is'// 44 - - ' out of range [0,1] ; no error bars plotted.' 45 - RETURN 46 - ENDIF 47 - *** Set the appropriate representations. 48 - CALL GRATTS('ERROR-BAR','POLYLINE') 49 - CALL GRATTS('ERROR-BAR','AREA') 50 - *** Loop over the points. 51 - DO 10 I=1,MLEN(ISX) 52 - ** Translate the various reference points into NDC. 53 - XC=0 54 - YC=0 55 - EX1=0 1 401 P=MATRIX D=MATERR 2 PAGE 502 56 - EY1=0 57 - EX2=0 58 - EY2=0 59 - IF(ISX.GT.0)XC=MVEC(MORG(ISX)+I) 60 - IF(ISY.GT.0)YC=MVEC(MORG(ISY)+I) 61 - IF(ISEX1.GT.0)EX1=MVEC(MORG(ISEX1)+I) 62 - IF(ISEY1.GT.0)EY1=MVEC(MORG(ISEY1)+I) 63 - IF(ISEX2.GT.0)EX2=MVEC(MORG(ISEX2)+I) 64 - IF(ISEY2.GT.0)EY2=MVEC(MORG(ISEY2)+I) 65 - CALL GRWCNC(XC,YC,X0,Y0) 66 - CALL GRWCNC(XC-ABS(EX1),YC-ABS(EY1),X1,Y1) 67 - CALL GRWCNC(XC+ABS(EX2),YC+ABS(EY2),X2,Y2) 68 - ** Move to NDC coordinates. 69 - CALL GSELNT(0) 70 - ** Error bar type CIRCLE and SQUARE. 71 - IF(INDEX(TYPE,'CIRCLE')+INDEX(TYPE,'SQUARE').NE.0)THEN 72 - * Plot the marker. 73 - IF(INDEX(TYPE,'CIRCLE').NE.0)THEN 74 - DO 20 J=1,20 75 - XPL(J)=X0+COS(2*PI*REAL(J-1)/19.0)*SIZE 76 - YPL(J)=Y0+SIN(2*PI*REAL(J-1)/19.0)*SIZE 77 - 20 CONTINUE 78 - CALL GFA(20,XPL,YPL) 79 - CALL GPL(20,XPL,YPL) 80 - ELSE 81 - XPL(1)=X0-SIZE 82 - YPL(1)=Y0-SIZE 83 - XPL(2)=X0+SIZE 84 - YPL(2)=Y0-SIZE 85 - XPL(3)=X0+SIZE 86 - YPL(3)=Y0+SIZE 87 - XPL(4)=X0-SIZE 88 - YPL(4)=Y0+SIZE 89 - XPL(5)=X0-SIZE 90 - YPL(5)=Y0-SIZE 91 - CALL GFA(5,XPL,YPL) 92 - CALL GPL(5,XPL,YPL) 93 - ENDIF 94 - * Plot the error bars. 95 - IF(X1.LE.X0-SIZE)THEN 96 - XPL(1)=X1 97 - XPL(2)=X0-SIZE 98 - YPL(1)=Y0 99 - YPL(2)=Y0 100 - CALL GPL(2,XPL,YPL) 101 - XPL(1)=X1 102 - XPL(2)=X1 103 - YPL(1)=Y0-SIZE 104 - YPL(2)=Y0+SIZE 105 - CALL GPL(2,XPL,YPL) 106 - ENDIF 107 - IF(X2.GE.X0+SIZE)THEN 108 - XPL(1)=X2 109 - XPL(2)=X0+SIZE 110 - YPL(1)=Y0 111 - YPL(2)=Y0 112 - CALL GPL(2,XPL,YPL) 113 - XPL(1)=X2 114 - XPL(2)=X2 115 - YPL(1)=Y0-SIZE 116 - YPL(2)=Y0+SIZE 117 - CALL GPL(2,XPL,YPL) 118 - ENDIF 119 - IF(Y1.LE.Y0-SIZE)THEN 120 - XPL(1)=X0 121 - XPL(2)=X0 122 - YPL(1)=Y1 123 - YPL(2)=Y0-SIZE 124 - CALL GPL(2,XPL,YPL) 125 - XPL(1)=X0-SIZE 126 - XPL(2)=X0+SIZE 127 - YPL(1)=Y1 128 - YPL(2)=Y1 129 - CALL GPL(2,XPL,YPL) 130 - ENDIF 131 - IF(Y2.GE.Y0+SIZE)THEN 132 - XPL(1)=X0 133 - XPL(2)=X0 134 - YPL(1)=Y2 135 - YPL(2)=Y0+SIZE 136 - CALL GPL(2,XPL,YPL) 137 - XPL(1)=X0-SIZE 138 - XPL(2)=X0+SIZE 139 - YPL(1)=Y2 140 - YPL(2)=Y2 141 - CALL GPL(2,XPL,YPL) 142 - ENDIF 143 - ** ELLIPSE shaped error bars. 144 - ELSEIF(INDEX(TYPE,'ELLIPSE').NE.0)THEN 145 - DO 30 J=1,20 146 - XPL(J)=X0+(X2-X0)*COS(PI*REAL(J-1)/38.0) 147 - YPL(J)=Y0+(Y2-Y0)*SIN(PI*REAL(J-1)/38.0) 148 - 30 CONTINUE 149 - DO 40 J=1,20 150 - XPL(20+J)=X0-(X1-X0)*COS(PI/2+PI*REAL(J-1)/38.0) 151 - YPL(20+J)=Y0+(Y2-Y0)*SIN(PI/2+PI*REAL(J-1)/38.0) 152 - 40 CONTINUE 153 - DO 50 J=1,20 154 - XPL(40+J)=X0-(X1-X0)*COS(PI+PI*REAL(J-1)/38.0) 155 - YPL(40+J)=Y0-(Y1-Y0)*SIN(PI+PI*REAL(J-1)/38.0) 156 - 50 CONTINUE 157 - DO 60 J=1,20 158 - XPL(60+J)=X0+(X2-X0)*COS(3*PI/2+PI*REAL(J-1)/38.0) 159 - YPL(60+J)=Y0-(Y1-Y0)*SIN(3*PI/2+PI*REAL(J-1)/38.0) 160 - 60 CONTINUE 161 - CALL GFA(80,XPL,YPL) 1 401 P=MATRIX D=MATERR 3 PAGE 503 162 - CALL GPL(80,XPL,YPL) 163 - ** CROSS and PLUS shaped error bars. 164 - ELSEIF(INDEX(TYPE,'CROSS')+INDEX(TYPE,'PLUS').NE.0)THEN 165 - * Plot the marker. 166 - IF(INDEX(TYPE,'CROSS').NE.0)THEN 167 - XPL(1)=X0-SIZE 168 - YPL(1)=Y0-SIZE 169 - XPL(2)=X0+SIZE 170 - YPL(2)=Y0+SIZE 171 - CALL GPL(2,XPL,YPL) 172 - XPL(1)=X0-SIZE 173 - YPL(1)=Y0+SIZE 174 - XPL(2)=X0+SIZE 175 - YPL(2)=Y0-SIZE 176 - CALL GPL(2,XPL,YPL) 177 - ENDIF 178 - * Plot the error bars. 179 - XPL(1)=X1 180 - YPL(1)=Y0 181 - XPL(2)=X2 182 - YPL(2)=Y0 183 - CALL GPL(2,XPL,YPL) 184 - XPL(1)=X0-SIZE 185 - YPL(1)=Y1 186 - XPL(2)=X0+SIZE 187 - YPL(2)=Y1 188 - CALL GPL(2,XPL,YPL) 189 - XPL(1)=X0-SIZE 190 - YPL(1)=Y2 191 - XPL(2)=X0+SIZE 192 - YPL(2)=Y2 193 - CALL GPL(2,XPL,YPL) 194 - XPL(1)=X0 195 - YPL(1)=Y1 196 - XPL(2)=X0 197 - YPL(2)=Y2 198 - CALL GPL(2,XPL,YPL) 199 - XPL(1)=X1 200 - YPL(1)=Y0-SIZE 201 - XPL(2)=X1 202 - YPL(2)=Y0+SIZE 203 - CALL GPL(2,XPL,YPL) 204 - XPL(1)=X2 205 - YPL(1)=Y0-SIZE 206 - XPL(2)=X2 207 - YPL(2)=Y0+SIZE 208 - CALL GPL(2,XPL,YPL) 209 - ** Error bar of type HEXAGON. 210 - ELSEIF(INDEX(TYPE,'HEXAGON').NE.0)THEN 211 - * Plot the marker. 212 - XPL(1)=X0+SIZE*0.5*SQRT(3.0) 213 - YPL(1)=Y0+SIZE*0.5 214 - XPL(2)=X0 215 - YPL(2)=Y0+SIZE 216 - XPL(3)=X0-SIZE*0.5*SQRT(3.0) 217 - YPL(3)=Y0+SIZE*0.5 218 - XPL(4)=X0-SIZE*0.5*SQRT(3.0) 219 - YPL(4)=Y0-SIZE*0.5 220 - XPL(5)=X0 221 - YPL(5)=Y0-SIZE 222 - XPL(6)=X0+SIZE*0.5*SQRT(3.0) 223 - YPL(6)=Y0-SIZE*0.5 224 - XPL(7)=XPL(1) 225 - YPL(7)=YPL(1) 226 - CALL GFA(7,XPL,YPL) 227 - CALL GPL(7,XPL,YPL) 228 - * Plot the error bars. 229 - IF(X1.LE.X0-0.5*SQRT(3.0)*SIZE)THEN 230 - XPL(1)=X1 231 - XPL(2)=X0-0.5*SQRT(3.0)*SIZE 232 - YPL(1)=Y0 233 - YPL(2)=Y0 234 - CALL GPL(2,XPL,YPL) 235 - XPL(1)=X1 236 - XPL(2)=X1 237 - YPL(1)=Y0-SIZE 238 - YPL(2)=Y0+SIZE 239 - CALL GPL(2,XPL,YPL) 240 - ENDIF 241 - IF(X2.GE.X0+0.5*SQRT(3.0)*SIZE)THEN 242 - XPL(1)=X2 243 - XPL(2)=X0+0.5*SQRT(3.0)*SIZE 244 - YPL(1)=Y0 245 - YPL(2)=Y0 246 - CALL GPL(2,XPL,YPL) 247 - XPL(1)=X2 248 - XPL(2)=X2 249 - YPL(1)=Y0-SIZE 250 - YPL(2)=Y0+SIZE 251 - CALL GPL(2,XPL,YPL) 252 - ENDIF 253 - IF(Y1.LE.Y0-SIZE)THEN 254 - XPL(1)=X0 255 - XPL(2)=X0 256 - YPL(1)=Y1 257 - YPL(2)=Y0-SIZE 258 - CALL GPL(2,XPL,YPL) 259 - XPL(1)=X0-SIZE 260 - XPL(2)=X0+SIZE 261 - YPL(1)=Y1 262 - YPL(2)=Y1 263 - CALL GPL(2,XPL,YPL) 264 - ENDIF 265 - IF(Y2.GE.Y0+SIZE)THEN 266 - XPL(1)=X0 267 - XPL(2)=X0 1 401 P=MATRIX D=MATERR 4 PAGE 504 268 - YPL(1)=Y2 269 - YPL(2)=Y0+SIZE 270 - CALL GPL(2,XPL,YPL) 271 - XPL(1)=X0-SIZE 272 - XPL(2)=X0+SIZE 273 - YPL(1)=Y2 274 - YPL(2)=Y2 275 - CALL GPL(2,XPL,YPL) 276 - ENDIF 277 - ** Error bar type RIGHT-TRIANGLE. 278 - ELSEIF(INDEX(TYPE,'RIGHT-TRIANGLE')+ 279 - - INDEX(TYPE,'TRIANGLE-RIGHT')+ 280 - - INDEX(TYPE,'EAST-TRIANGLE')+ 281 - - INDEX(TYPE,'TRIANGLE-EAST')+ 282 - - INDEX(TYPE,'E-TRIANGLE')+ 283 - - INDEX(TYPE,'TRIANGLE-E').NE.0)THEN 284 - * Plot the marker. 285 - XPL(1)=X0+SIZE 286 - YPL(1)=Y0 287 - XPL(2)=X0-0.5*SIZE 288 - YPL(2)=Y0+0.5*SQRT(3.0)*SIZE 289 - XPL(3)=X0-0.5*SIZE 290 - YPL(3)=Y0-0.5*SQRT(3.0)*SIZE 291 - XPL(4)=XPL(1) 292 - YPL(4)=YPL(1) 293 - CALL GFA(4,XPL,YPL) 294 - CALL GPL(4,XPL,YPL) 295 - * Plot the error bars. 296 - IF(X1.LE.X0-0.5*SIZE)THEN 297 - XPL(1)=X1 298 - XPL(2)=X0-0.5*SIZE 299 - YPL(1)=Y0 300 - YPL(2)=Y0 301 - CALL GPL(2,XPL,YPL) 302 - XPL(1)=X1 303 - XPL(2)=X1 304 - YPL(1)=Y0-SIZE 305 - YPL(2)=Y0+SIZE 306 - CALL GPL(2,XPL,YPL) 307 - ENDIF 308 - IF(X2.GE.X0+SIZE)THEN 309 - XPL(1)=X2 310 - XPL(2)=X0+SIZE 311 - YPL(1)=Y0 312 - YPL(2)=Y0 313 - CALL GPL(2,XPL,YPL) 314 - XPL(1)=X2 315 - XPL(2)=X2 316 - YPL(1)=Y0-SIZE 317 - YPL(2)=Y0+SIZE 318 - CALL GPL(2,XPL,YPL) 319 - ENDIF 320 - IF(Y1.LE.Y0-SIZE)THEN 321 - XPL(1)=X0 322 - XPL(2)=X0 323 - YPL(1)=Y1 324 - YPL(2)=Y0-SIZE/SQRT(3.0) 325 - CALL GPL(2,XPL,YPL) 326 - XPL(1)=X0-SIZE 327 - XPL(2)=X0+SIZE 328 - YPL(1)=Y1 329 - YPL(2)=Y1 330 - CALL GPL(2,XPL,YPL) 331 - ENDIF 332 - IF(Y2.GE.Y0+SIZE)THEN 333 - XPL(1)=X0 334 - XPL(2)=X0 335 - YPL(1)=Y2 336 - YPL(2)=Y0+SIZE/SQRT(3.0) 337 - CALL GPL(2,XPL,YPL) 338 - XPL(1)=X0-SIZE 339 - XPL(2)=X0+SIZE 340 - YPL(1)=Y2 341 - YPL(2)=Y2 342 - CALL GPL(2,XPL,YPL) 343 - ENDIF 344 - ** Error bar type LEFT-TRIANGLE. 345 - ELSEIF(INDEX(TYPE,'LEFT-TRIANGLE')+ 346 - - INDEX(TYPE,'TRIANGLE-LEFT')+ 347 - - INDEX(TYPE,'WEST-TRIANGLE')+ 348 - - INDEX(TYPE,'TRIANGLE-WEST')+ 349 - - INDEX(TYPE,'W-TRIANGLE')+ 350 - - INDEX(TYPE,'TRIANGLE-W').NE.0)THEN 351 - * Plot the marker. 352 - XPL(1)=X0-SIZE 353 - YPL(1)=Y0 354 - XPL(2)=X0+0.5*SIZE 355 - YPL(2)=Y0+0.5*SQRT(3.0)*SIZE 356 - XPL(3)=X0+0.5*SIZE 357 - YPL(3)=Y0-0.5*SQRT(3.0)*SIZE 358 - XPL(4)=XPL(1) 359 - YPL(4)=YPL(1) 360 - CALL GFA(4,XPL,YPL) 361 - CALL GPL(4,XPL,YPL) 362 - * Plot the error bars. 363 - IF(X1.LE.X0-SIZE)THEN 364 - XPL(1)=X1 365 - XPL(2)=X0-SIZE 366 - YPL(1)=Y0 367 - YPL(2)=Y0 368 - CALL GPL(2,XPL,YPL) 369 - XPL(1)=X1 370 - XPL(2)=X1 371 - YPL(1)=Y0-SIZE 372 - YPL(2)=Y0+SIZE 373 - CALL GPL(2,XPL,YPL) 1 401 P=MATRIX D=MATERR 5 PAGE 505 374 - ENDIF 375 - IF(X2.GE.X0+0.5*SIZE)THEN 376 - XPL(1)=X2 377 - XPL(2)=X0+0.5*SIZE 378 - YPL(1)=Y0 379 - YPL(2)=Y0 380 - CALL GPL(2,XPL,YPL) 381 - XPL(1)=X2 382 - XPL(2)=X2 383 - YPL(1)=Y0-SIZE 384 - YPL(2)=Y0+SIZE 385 - CALL GPL(2,XPL,YPL) 386 - ENDIF 387 - IF(Y1.LE.Y0-SIZE)THEN 388 - XPL(1)=X0 389 - XPL(2)=X0 390 - YPL(1)=Y1 391 - YPL(2)=Y0-SIZE/SQRT(3.0) 392 - CALL GPL(2,XPL,YPL) 393 - XPL(1)=X0-SIZE 394 - XPL(2)=X0+SIZE 395 - YPL(1)=Y1 396 - YPL(2)=Y1 397 - CALL GPL(2,XPL,YPL) 398 - ENDIF 399 - IF(Y2.GE.Y0+SIZE)THEN 400 - XPL(1)=X0 401 - XPL(2)=X0 402 - YPL(1)=Y2 403 - YPL(2)=Y0+SIZE/SQRT(3.0) 404 - CALL GPL(2,XPL,YPL) 405 - XPL(1)=X0-SIZE 406 - XPL(2)=X0+SIZE 407 - YPL(1)=Y2 408 - YPL(2)=Y2 409 - CALL GPL(2,XPL,YPL) 410 - ENDIF 411 - ** Error bar type DOWN-TRIANGLE. 412 - ELSEIF(INDEX(TYPE,'DOWN-TRIANGLE')+ 413 - - INDEX(TYPE,'TRIANGLE-DOWN')+ 414 - - INDEX(TYPE,'SOUTH-TRIANGLE')+ 415 - - INDEX(TYPE,'TRIANGLE-SOUTH')+ 416 - - INDEX(TYPE,'S-TRIANGLE')+ 417 - - INDEX(TYPE,'TRIANGLE-S').NE.0)THEN 418 - * Plot the marker. 419 - XPL(1)=X0 420 - YPL(1)=Y0-SIZE 421 - XPL(2)=X0+0.5*SQRT(3.0)*SIZE 422 - YPL(2)=Y0+0.5*SIZE 423 - XPL(3)=X0-0.5*SQRT(3.0)*SIZE 424 - YPL(3)=Y0+0.5*SIZE 425 - XPL(4)=XPL(1) 426 - YPL(4)=YPL(1) 427 - CALL GFA(4,XPL,YPL) 428 - CALL GPL(4,XPL,YPL) 429 - * Plot the error bars. 430 - IF(X1.LE.X0-SIZE)THEN 431 - XPL(1)=X1 432 - XPL(2)=X0-SIZE/SQRT(3.0) 433 - YPL(1)=Y0 434 - YPL(2)=Y0 435 - CALL GPL(2,XPL,YPL) 436 - XPL(1)=X1 437 - XPL(2)=X1 438 - YPL(1)=Y0-SIZE 439 - YPL(2)=Y0+SIZE 440 - CALL GPL(2,XPL,YPL) 441 - ENDIF 442 - IF(X2.GE.X0+SIZE)THEN 443 - XPL(1)=X2 444 - XPL(2)=X0+SIZE/SQRT(3.0) 445 - YPL(1)=Y0 446 - YPL(2)=Y0 447 - CALL GPL(2,XPL,YPL) 448 - XPL(1)=X2 449 - XPL(2)=X2 450 - YPL(1)=Y0-SIZE 451 - YPL(2)=Y0+SIZE 452 - CALL GPL(2,XPL,YPL) 453 - ENDIF 454 - IF(Y1.LE.Y0-SIZE)THEN 455 - XPL(1)=X0 456 - XPL(2)=X0 457 - YPL(1)=Y1 458 - YPL(2)=Y0-SIZE 459 - CALL GPL(2,XPL,YPL) 460 - XPL(1)=X0-SIZE 461 - XPL(2)=X0+SIZE 462 - YPL(1)=Y1 463 - YPL(2)=Y1 464 - CALL GPL(2,XPL,YPL) 465 - ENDIF 466 - IF(Y2.GE.Y0+0.5*SIZE)THEN 467 - XPL(1)=X0 468 - XPL(2)=X0 469 - YPL(1)=Y2 470 - YPL(2)=Y0+0.5*SIZE 471 - CALL GPL(2,XPL,YPL) 472 - XPL(1)=X0-SIZE 473 - XPL(2)=X0+SIZE 474 - YPL(1)=Y2 475 - YPL(2)=Y2 476 - CALL GPL(2,XPL,YPL) 477 - ENDIF 478 - ** Error bar type UP-TRIANGLE. 479 - ELSEIF(INDEX(TYPE,'TRIANGLE').NE.0)THEN 1 401 P=MATRIX D=MATERR 6 PAGE 506 480 - * Plot the marker. 481 - XPL(1)=X0 482 - YPL(1)=Y0+SIZE 483 - XPL(2)=X0+0.5*SQRT(3.0)*SIZE 484 - YPL(2)=Y0-0.5*SIZE 485 - XPL(3)=X0-0.5*SQRT(3.0)*SIZE 486 - YPL(3)=Y0-0.5*SIZE 487 - XPL(4)=XPL(1) 488 - YPL(4)=YPL(1) 489 - CALL GFA(4,XPL,YPL) 490 - CALL GPL(4,XPL,YPL) 491 - * Plot the error bars. 492 - IF(X1.LE.X0-SIZE)THEN 493 - XPL(1)=X1 494 - XPL(2)=X0-SIZE/SQRT(3.0) 495 - YPL(1)=Y0 496 - YPL(2)=Y0 497 - CALL GPL(2,XPL,YPL) 498 - XPL(1)=X1 499 - XPL(2)=X1 500 - YPL(1)=Y0-SIZE 501 - YPL(2)=Y0+SIZE 502 - CALL GPL(2,XPL,YPL) 503 - ENDIF 504 - IF(X2.GE.X0+SIZE)THEN 505 - XPL(1)=X2 506 - XPL(2)=X0+SIZE/SQRT(3.0) 507 - YPL(1)=Y0 508 - YPL(2)=Y0 509 - CALL GPL(2,XPL,YPL) 510 - XPL(1)=X2 511 - XPL(2)=X2 512 - YPL(1)=Y0-SIZE 513 - YPL(2)=Y0+SIZE 514 - CALL GPL(2,XPL,YPL) 515 - ENDIF 516 - IF(Y1.LE.Y0-SIZE)THEN 517 - XPL(1)=X0 518 - XPL(2)=X0 519 - YPL(1)=Y1 520 - YPL(2)=Y0-0.5*SIZE 521 - CALL GPL(2,XPL,YPL) 522 - XPL(1)=X0-SIZE 523 - XPL(2)=X0+SIZE 524 - YPL(1)=Y1 525 - YPL(2)=Y1 526 - CALL GPL(2,XPL,YPL) 527 - ENDIF 528 - IF(Y2.GE.Y0+0.5*SIZE)THEN 529 - XPL(1)=X0 530 - XPL(2)=X0 531 - YPL(1)=Y2 532 - YPL(2)=Y0+SIZE 533 - CALL GPL(2,XPL,YPL) 534 - XPL(1)=X0-SIZE 535 - XPL(2)=X0+SIZE 536 - YPL(1)=Y2 537 - YPL(2)=Y2 538 - CALL GPL(2,XPL,YPL) 539 - ENDIF 540 - ** Error bar of type STAR. 541 - ELSEIF(INDEX(TYPE,'STAR')+INDEX(TYPE,'DAVID').NE.0)THEN 542 - * Plot the marker. 543 - IF(INDEX(TYPE,'4-STAR').NE.0)THEN 544 - NPOINT=8 545 - STFACT=0.3 546 - ELSEIF(INDEX(TYPE,'6-STAR').NE.0)THEN 547 - NPOINT=12 548 - STFACT=0.3 549 - ELSEIF(INDEX(TYPE,'DAVID').NE.0)THEN 550 - NPOINT=12 551 - STFACT=0.5/COS(PI/6) 552 - ELSEIF(INDEX(TYPE,'8-STAR').NE.0)THEN 553 - NPOINT=16 554 - STFACT=0.3 555 - ELSEIF(INDEX(TYPE,'10-STAR').NE.0)THEN 556 - NPOINT=20 557 - STFACT=0.3 558 - ELSE 559 - NPOINT=12 560 - STFACT=0.3 561 - ENDIF 562 - DO 70 J=1,NPOINT 563 - IF(J.EQ.2*(J/2))THEN 564 - XPL(J)=X0+SIZE*COS(2*PI*J/REAL(NPOINT)) 565 - YPL(J)=Y0+SIZE*SIN(2*PI*J/REAL(NPOINT)) 566 - ELSE 567 - XPL(J)=X0+STFACT*SIZE*COS(2*PI*J/REAL(NPOINT)) 568 - YPL(J)=Y0+STFACT*SIZE*SIN(2*PI*J/REAL(NPOINT)) 569 - ENDIF 570 - 70 CONTINUE 571 - XPL(NPOINT+1)=XPL(1) 572 - YPL(NPOINT+1)=YPL(1) 573 - CALL GFA(NPOINT+1,XPL,YPL) 574 - CALL GPL(NPOINT+1,XPL,YPL) 575 - * Plot the error bars. 576 - IF(X1.LE.X0-SIZE)THEN 577 - XPL(1)=X1 578 - XPL(2)=X0-SIZE 579 - YPL(1)=Y0 580 - YPL(2)=Y0 581 - CALL GPL(2,XPL,YPL) 582 - XPL(1)=X1 583 - XPL(2)=X1 584 - YPL(1)=Y0-SIZE 585 - YPL(2)=Y0+SIZE 1 401 P=MATRIX D=MATERR 7 PAGE 507 586 - CALL GPL(2,XPL,YPL) 587 - ENDIF 588 - IF(X2.GE.X0+SIZE)THEN 589 - XPL(1)=X2 590 - XPL(2)=X0+SIZE 591 - YPL(1)=Y0 592 - YPL(2)=Y0 593 - CALL GPL(2,XPL,YPL) 594 - XPL(1)=X2 595 - XPL(2)=X2 596 - YPL(1)=Y0-SIZE 597 - YPL(2)=Y0+SIZE 598 - CALL GPL(2,XPL,YPL) 599 - ENDIF 600 - IF(Y1.LE.Y0-SIZE)THEN 601 - XPL(1)=X0 602 - XPL(2)=X0 603 - YPL(1)=Y1 604 - IF(NPOINT.EQ.8*(NPOINT/8))THEN 605 - YPL(2)=Y0-SIZE 606 - ELSE 607 - YPL(2)=Y0-STFACT*SIZE 608 - ENDIF 609 - CALL GPL(2,XPL,YPL) 610 - XPL(1)=X0-SIZE 611 - XPL(2)=X0+SIZE 612 - YPL(1)=Y1 613 - YPL(2)=Y1 614 - CALL GPL(2,XPL,YPL) 615 - ENDIF 616 - IF(Y2.GE.Y0+SIZE)THEN 617 - XPL(1)=X0 618 - XPL(2)=X0 619 - YPL(1)=Y2 620 - IF(NPOINT.EQ.8*(NPOINT/8))THEN 621 - YPL(2)=Y0+SIZE 622 - ELSE 623 - YPL(2)=Y0+STFACT*SIZE 624 - ENDIF 625 - CALL GPL(2,XPL,YPL) 626 - XPL(1)=X0-SIZE 627 - XPL(2)=X0+SIZE 628 - YPL(1)=Y2 629 - YPL(2)=Y2 630 - CALL GPL(2,XPL,YPL) 631 - ENDIF 632 - ** Unknown marker type. 633 - ELSE 634 - PRINT *,' !!!!!! MATERR WARNING : Marker type not'// 635 - - ' recognised; no markers plotted.' 636 - ENDIF 637 - ** Move to the original normalisation transformation. 638 - CALL GSELNT(NT) 639 - ** Next point. 640 - 10 CONTINUE 641 - END 402 GARFIELD ================================================== P=MATRIX D=MATEXT 1 ============================ 0 + +DECK,MATEXT. 1 - SUBROUTINE MATEXT(IRX,IRF,XEXT,OPTION,EEPSX,EEPSF,NITMAX,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MATEXT - Searches for extrema of a matrix interpolation. 4 - * VARIABLES : 5 - * (Last changed on 15/10/01.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,GLOBALS. 10.- +SEQ,MATDATA. 11.- +SEQ,PRINTPLOT. 12 - CHARACTER*(*) OPTION 13 - CHARACTER*20 AUX1,AUX2 14 - CHARACTER*10 NAMEX,NAMEF 15 - INTEGER NC,MODSAV,NITMAX,IFAIL,I,NRNDM, 16 - - NC1,NC2,MATSLT,IRX,IRF,ISX,ISF,IORDER 17 - REAL XMIN,XMAX,RNDUNI,XPL(MXLIST),YPL(MXLIST), 18 - - EEPSX,EEPSF,XEXT,DIVDIF 19 - DOUBLE PRECISION X1,X2,X3,F1,F2,F3,XPARA,FPARA,EPSX,EPSF,FTRY, 20 - - XTRY,FMIN,FMAX 21 - LOGICAL SET1,SET2,SET3,LPRINT,LPLOT,SMIN,SMAX,SKIP 22 - EXTERNAL RNDUNI,MATSLT,DIVDIF 23 - *** Identification. 24 - IF(LIDENT)PRINT *,' /// ROUTINE MATEXT ///' 25 - *** Assume this will not work. 26 - IFAIL=1 27 - *** Find the matrices. 28 - ISX=MATSLT(IRX) 29 - ISF=MATSLT(IRF) 30 - * Ensure they both exist. 31 - IF(ISX.EQ.0.OR.ISF.EQ.0)THEN 32 - PRINT *,' !!!!!! MATEXT WARNING : Ordinate or function'// 33 - - ' matrix not found; no extremum search.' 34 - RETURN 35 - * The matrices must have the same size > 1. 36 - ELSEIF(MLEN(ISX).NE.MLEN(ISF))THEN 37 - PRINT *,' !!!!!! MATEXT WARNING : Ordinate and function'// 38 - - ' matrices have different length; no extremum search.' 39 - RETURN 40 - ELSEIF(MLEN(ISX).LE.1)THEN 41 - PRINT *,' !!!!!! MATEXT WARNING : Ordinate and function'// 42 - - ' matrices have length<2; no extremum search.' 43 - RETURN 44 - * The matrices must be 1-dimensional. 45 - ELSEIF(MDIM(ISX).NE.1)THEN 46 - PRINT *,' !!!!!! MATEXT WARNING : Ordinate or function'// 1 402 P=MATRIX D=MATEXT 2 PAGE 508 47 - - ' matrix not 1-dimensional; no extremum search.' 48 - RETURN 49 - ENDIF 50 - *** Verify that the ordinate matrix is well ordered. 51 - IF(MVEC(MORG(ISX)+2).GT.MVEC(MORG(ISX)+1))THEN 52 - DO 40 I=2,MLEN(ISX) 53 - IF(MVEC(MORG(ISX)+I).LE.MVEC(MORG(ISX)+I-1))THEN 54 - PRINT *,' !!!!!! MATEXT WARNING : The ordinate'// 55 - - ' vector is not strictly ordered; no extremum'// 56 - - ' search.' 57 - RETURN 58 - ENDIF 59 - 40 CONTINUE 60 - ELSEIF(MVEC(MORG(ISX)+2).LT.MVEC(MORG(ISX)+1))THEN 61 - DO 50 I=2,MLEN(ISX) 62 - IF(MVEC(MORG(ISX)+I).GE.MVEC(MORG(ISX)+I-1))THEN 63 - PRINT *,' !!!!!! MATEXT WARNING : The ordinate'// 64 - - ' vector is not strictly ordered; no extremum'// 65 - - ' search.' 66 - RETURN 67 - ENDIF 68 - 50 CONTINUE 69 - ELSE 70 - PRINT *,' !!!!!! MATEXT WARNING : The ordinate vector'// 71 - - ' is not strictly ordered; no extremum search.' 72 - RETURN 73 - ENDIF 74 - *** Decode options. 75 - LPLOT=.FALSE. 76 - IF(INDEX(OPTION,'NOPLOT').NE.0)THEN 77 - LPLOT=.FALSE. 78 - ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN 79 - LPLOT=.TRUE. 80 - ENDIF 81 - LPRINT=.FALSE. 82 - IF(INDEX(OPTION,'NOPRINT').NE.0)THEN 83 - LPRINT=.FALSE. 84 - ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN 85 - LPRINT=.TRUE. 86 - ENDIF 87 - SMIN=.TRUE. 88 - SMAX=.FALSE. 89 - IF(INDEX(OPTION,'MIN').NE.0)THEN 90 - SMIN=.TRUE. 91 - SMAX=.FALSE. 92 - ELSEIF(INDEX(OPTION,'MAX').NE.0)THEN 93 - SMIN=.FALSE. 94 - SMAX=.TRUE. 95 - ENDIF 96 - IORDER=MIN(2,MLEN(ISX)) 97 - IF(INDEX(OPTION,'LINEAR').NE.0)THEN 98 - IORDER=1 99 - ELSEIF(INDEX(OPTION,'QUAD').NE.0)THEN 100 - IF(MLEN(ISX).LT.3)THEN 101 - PRINT *,' !!!!!! MATEXT WARNING : Vectors are too'// 102 - - ' short for quadratic interpolation; no'// 103 - - ' extremum search.' 104 - RETURN 105 - ELSE 106 - IORDER=2 107 - ENDIF 108 - ELSEIF(INDEX(OPTION,'CUBIC').NE.0)THEN 109 - IF(MLEN(ISX).LT.4)THEN 110 - PRINT *,' !!!!!! MATEXT WARNING : Vectors are too'// 111 - - ' short for cubic interpolation; no extremum'// 112 - - ' search.' 113 - RETURN 114 - ELSE 115 - IORDER=3 116 - ENDIF 117 - ENDIF 118 - *** Set the range. 119 - XMIN=MVEC(MORG(ISX)+1) 120 - XMAX=MVEC(MORG(ISX)+MLEN(ISX)) 121 - *** Accuracy settings. 122 - EPSX=DBLE(EEPSX) 123 - EPSF=DBLE(EEPSF) 124 - NRNDM=100 125 - *** Debugging output. 126 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATEXT DEBUG : '', 127 - - ''Ordinate and function vectors: '',I5,1X,I5/26X, 128 - - ''Interpolation order: '',I5/26X, 129 - - ''Range to be searched: '',2E15.8/26X, 130 - - ''Minimum / Maximum: '',2L15/26X, 131 - - ''Location / function convergence: '',2F15.8/26X, 132 - - ''Random cycles / max iterations: '',2I15)') 133 - - ISX,ISF,IORDER,XMIN,XMAX,SMIN,SMAX,EPSX,EPSF,NRNDM,NITMAX 134 - *** Check the parameters. 135 - IF(EPSX.LE.0.OR.EPSF.LE.0.OR.NITMAX.LT.1)THEN 136 - PRINT *,' !!!!!! MATEXT WARNING : Received incorrect'// 137 - - ' convergence criteria; no search.' 138 - RETURN 139 - ENDIF 140 - *** Print output. 141 - IF(LPRINT)THEN 142 - NAMEX='temporary' 143 - NAMEF='temporary' 144 - DO 60 I=1,NGLB 145 - IF(NINT(GLBVAL(I)).EQ.IRX)THEN 146 - NAMEX=GLBVAR(I) 147 - ELSEIF(NINT(GLBVAL(I)).EQ.IRF)THEN 148 - NAMEF=GLBVAR(I) 149 - ENDIF 150 - 60 CONTINUE 151 - IF(SMIN)THEN 152 - WRITE(LUNOUT,'('' Searching for the minimum of '',A, 1 402 P=MATRIX D=MATEXT 3 PAGE 509 153 - - '' vs '',A)') NAMEF,NAMEX 154 - ELSEIF(SMAX)THEN 155 - WRITE(LUNOUT,'('' Searching for the maximum of '',A, 156 - - '' vs '',A)') NAMEF,NAMEX 157 - ENDIF 158 - CALL OUTFMT(XMIN,2,AUX1,NC1,'LEFT') 159 - CALL OUTFMT(XMAX,2,AUX2,NC2,'LEFT') 160 - WRITE(LUNOUT,'('' Search range: '',A,'' to '',A)') 161 - - AUX1(1:NC1),AUX2(1:NC2) 162 - CALL OUTFMT(REAL(EPSX),2,AUX1,NC1,'LEFT') 163 - WRITE(LUNOUT,'('' Convergence declared for relative'', 164 - - '' position changes less than '',A)') AUX1(1:NC1) 165 - CALL OUTFMT(REAL(EPSF),2,AUX1,NC1,'LEFT') 166 - WRITE(LUNOUT,'('' and for relative function value'', 167 - - '' variations less than '',A,''.'')') AUX1(1:NC1) 168 - CALL OUTFMT(REAL(NRNDM),2,AUX1,NC1,'LEFT') 169 - CALL OUTFMT(REAL(NITMAX),2,AUX2,NC2,'LEFT') 170 - WRITE(LUNOUT,'('' Doing '',A,'' random cycles and at'', 171 - - '' most '',A,'' parabolic searches.''/)') AUX1(1:NC1), 172 - - AUX2(1:NC2) 173 - ENDIF 174 - *** Start a plot, if requested. 175 - IF(LPLOT)THEN 176 - DO 30 I=1,MXLIST 177 - XPL(I)=XMIN+REAL(I-1)*(XMAX-XMIN)/REAL(MXLIST-1) 178 - YPL(I)=DIVDIF(MVEC(MORG(ISF)+1),MVEC(MORG(ISX)+1), 179 - - MLEN(ISX),XPL(I),IORDER) 180 - 30 CONTINUE 181 - CALL GRGRPH(XPL,YPL,MXLIST,NAMEX,NAMEF, 182 - - 'Matrix interpolation extrema search') 183 - ENDIF 184 - *** Random search for the 3 extreme points. 185 - SET1=.FALSE. 186 - SET2=.FALSE. 187 - SET3=.FALSE. 188 - X1=0 189 - X2=0 190 - X3=0 191 - F1=0 192 - F2=0 193 - F3=0 194 - DO 10 I=1,NRNDM 195 - * Evaluate function. 196 - XTRY=DBLE(XMIN+RNDUNI(1.0)*(XMAX-XMIN)) 197 - FTRY=DBLE(DIVDIF(MVEC(MORG(ISF)+1),MVEC(MORG(ISX)+1), 198 - - MLEN(ISX),REAL(XTRY),IORDER)) 199 - * Keep track of the 3 smallest numbers. 200 - IF((SMIN.AND.FTRY.LT.F1).OR.(SMAX.AND.FTRY.GT.F1).OR. 201 - - .NOT.SET1)THEN 202 - F3=F2 203 - X3=X2 204 - IF(SET2)SET3=.TRUE. 205 - F2=F1 206 - X2=X1 207 - IF(SET1)SET2=.TRUE. 208 - F1=FTRY 209 - X1=XTRY 210 - SET1=.TRUE. 211 - ELSEIF((SMIN.AND.FTRY.LT.F2).OR.(SMAX.AND.FTRY.GT.F2).OR. 212 - - .NOT.SET2)THEN 213 - F3=F2 214 - X3=X2 215 - IF(SET2)SET3=.TRUE. 216 - F2=FTRY 217 - X2=XTRY 218 - SET2=.TRUE. 219 - ELSEIF((SMIN.AND.FTRY.LT.F3).OR.(SMAX.AND.FTRY.GT.F3).OR. 220 - - .NOT.SET3)THEN 221 - F3=FTRY 222 - X3=XTRY 223 - SET3=.TRUE. 224 - ENDIF 225 - * Keep track of function range. 226 - IF(LPLOT)THEN 227 - IF(I.EQ.1)THEN 228 - FMIN=FTRY 229 - FMAX=FTRY 230 - ELSE 231 - FMIN=MIN(FTRY,FMIN) 232 - FMAX=MAX(FTRY,FMAX) 233 - ENDIF 234 - ENDIF 235 - * Next random cycle. 236 - 10 CONTINUE 237 - * Print result of random search. 238 - IF(LPRINT)WRITE(LUNOUT,'('' Random search finds an extreme'', 239 - - '' value at x='',E15.8,'' f='',E15.8)') X1,F1 240 - *** Compare with the boundary values. 241 - SKIP=.FALSE. 242 - FTRY=DIVDIF(MVEC(MORG(ISF)+1),MVEC(MORG(ISX)+1), 243 - - MLEN(ISX),XMIN,IORDER) 244 - IF((SMIN.AND.FTRY.LT.F1).OR.(SMAX.AND.FTRY.GT.F1))THEN 245 - X1=XMIN 246 - F1=FTRY 247 - SKIP=.TRUE. 248 - IF(LPRINT)WRITE(LUNOUT,'('' Function value at lower'', 249 - - '' range limit is better: f='',E15.8)') FTRY 250 - ENDIF 251 - FTRY=DIVDIF(MVEC(MORG(ISF)+1),MVEC(MORG(ISX)+1), 252 - - MLEN(ISX),XMAX,IORDER) 253 - IF((SMIN.AND.FTRY.LT.F1).OR.(SMAX.AND.FTRY.GT.F1))THEN 254 - X1=XMAX 255 - F1=FTRY 256 - SKIP=.TRUE. 257 - IF(LPRINT)WRITE(LUNOUT,'('' Function value at upper'', 258 - - '' range limit is better: f='',E15.8)') FTRY 1 402 P=MATRIX D=MATEXT 4 PAGE 510 259 - ENDIF 260 - IF(SKIP)THEN 261 - XEXT=X1 262 - GOTO 3000 263 - ENDIF 264 - *** Refine the estimate by parabolic extremum search. 265 - DO 20 I=1,NITMAX 266 - * Estimate parabolic extremum. 267 - XPARA=( (F1-F2)*X3**2+(F3-F1)*X2**2+(F2-F3)*X1**2)/ 268 - - (2*((F1-F2)*X3 +(F3-F1)*X2 +(F2-F3)*X1)) 269 - FPARA=-(4*((F1*X2**2-F2*X1**2)*X3-(F1*X2-F2*X1)*X3**2- 270 - - X2**2*F3*X1+X2*F3*X1**2)*((F1-F2)*X3-F1*X2+ 271 - - X2*F3+F2*X1-F3*X1)+((F1-F2)*X3**2-F1*X2**2+X2**2*F3+ 272 - - F2*X1**2-F3*X1**2)**2)/(4*((F1-F2)*X3-F1*X2+ 273 - - X2*F3+F2*X1-F3*X1)*(X3-X2)*(X3-X1)*(X2-X1)) 274 - * Debugging output. 275 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATEXT DEBUG :'', 276 - - '' Start of iteration '',I3// 277 - - 26X,''Point 1: x='',E15.8,'' f='',E15.8/ 278 - - 26X,''Point 2: x='',E15.8,'' f='',E15.8/ 279 - - 26X,''Point 3: x='',E15.8,'' f='',E15.8// 280 - - 26X,''Parabola: x='',E15.8,'' f='',E15.8)') 281 - - I,X1,F1,X2,F2,X3,F3,XPARA,FPARA 282 - * Check that the parabolic estimate is within range. 283 - IF((XMIN-XPARA)*(XPARA-XMAX).LT.0)THEN 284 - PRINT *,' !!!!!! MATEXT WARNING : Estimated parabolic'// 285 - - ' extremum is located outside curve range.' 286 - IFAIL=1 287 - GOTO 3000 288 - ENDIF 289 - * Check that the new estimate doesn't coincide with an old point. 290 - IF(ABS(XPARA-X1).LT.EPSX*(EPSX+ABS(XPARA)).OR. 291 - - ABS(XPARA-X2).LT.EPSX*(EPSX+ABS(XPARA)).OR. 292 - - ABS(XPARA-X3).LT.EPSX*(EPSX+ABS(XPARA)))THEN 293 - IF(LPRINT)WRITE(LUNOUT,'(/'' Location convergence'', 294 - - '' criterion satisfied.''/)') 295 - GOTO 3000 296 - ENDIF 297 - * Evaluate things over there. 298 - XEXT=REAL(XPARA) 299 - FPARA=DBLE(DIVDIF(MVEC(MORG(ISF)+1),MVEC(MORG(ISX)+1), 300 - - MLEN(ISX),REAL(XPARA),IORDER)) 301 - * Normal printout. 302 - IF(LPRINT)WRITE(LUNOUT,'('' Iteration '',I3,'' x='',E15.8, 303 - - '': f = '',E15.8,''.'')') I,XPARA,FPARA 304 - IF(LPLOT)THEN 305 - IF(SMIN)THEN 306 - CALL GRARRO(REAL(XPARA),REAL(FPARA+0.1*(FMAX-FMIN)), 307 - - REAL(XPARA),REAL(FPARA)) 308 - ELSEIF(SMAX)THEN 309 - CALL GRARRO(REAL(XPARA),REAL(FPARA-0.1*(FMAX-FMIN)), 310 - - REAL(XPARA),REAL(FPARA)) 311 - ENDIF 312 - ENDIF 313 - * Check convergence. 314 - IF(ABS(FPARA-F1).LT.EPSF*(ABS(FPARA)+ABS(F1)+EPSF))THEN 315 - IF(LPRINT)WRITE(LUNOUT,'(/'' Function value convergence'', 316 - - '' criterion satisfied.''/)') 317 - GOTO 3000 318 - ENDIF 319 - * Store the value in the table. 320 - IF((SMIN.AND.FPARA.LT.F1).OR.(SMAX.AND.FPARA.GT.F1))THEN 321 - F3=F2 322 - X3=X2 323 - F2=F1 324 - X2=X1 325 - F1=FPARA 326 - X1=XPARA 327 - ELSEIF((SMIN.AND.FPARA.LT.F2).OR.(SMAX.AND.FPARA.GT.F2))THEN 328 - F3=F2 329 - X3=X2 330 - F2=FPARA 331 - X2=XPARA 332 - ELSEIF((SMIN.AND.FPARA.LT.F3).OR.(SMAX.AND.FPARA.GT.F3))THEN 333 - F3=FPARA 334 - X3=XPARA 335 - ELSE 336 - PRINT *,' !!!!!! MATEXT WARNING : Parabolic extremum'// 337 - - ' is outside current search range; search stopped.' 338 - IFAIL=1 339 - GOTO 3000 340 - ENDIF 341 - 20 CONTINUE 342 - *** No convergence. 343 - PRINT *,' !!!!!! MATEXT WARNING : No convergence after maximum'// 344 - - ' number of steps.' 345 - PRINT *,' Current extremum f=',F1 346 - PRINT *,' Found for x=',X1 347 - *** Clean up. 348 - 3000 CONTINUE 349 - * Close graphics, if active. 350 - IF(LPLOT)CALL GRNEXT 351 - * Seems to have worked. 352 - IFAIL=0 353 - END 403 GARFIELD ================================================== P=MATRIX D=MATFAR 1 ============================ 0 + +DECK,MATFAR. 1 - SUBROUTINE MATFAR(IREF1,IREF2,OPTION) 2 - *----------------------------------------------------------------------- 3 - * MATFAR - Plots an area. 4 - * (Last changed on 17/11/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 1 403 P=MATRIX D=MATFAR 2 PAGE 511 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9.- +SEQ,PRINTPLOT. 10 - INTEGER IREF1,IREF2,ISLOT1,ISLOT2,MATSLT 11 - EXTERNAL MATSLT 12 - CHARACTER*(*) OPTION 13 - *** Indentify the routine if requested. 14 - IF(LIDENT)PRINT *,' /// ROUTINE MATFAR ///' 15 - *** Debugging output. 16 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATFAR DEBUG : Plotting'', 17 - - '' line vectors '',2I5)') IREF1,IREF2 18 - *** Locate the 2 vectors. 19 - ISLOT1=MATSLT(IREF1) 20 - ISLOT2=MATSLT(IREF2) 21 - IF(ISLOT1.EQ.0.OR.ISLOT2.EQ.0)THEN 22 - PRINT *,' !!!!!! MATFAR WARNING : Matrix to be plotted'// 23 - - ' has not been found.' 24 - RETURN 25 - ENDIF 26 - *** Verify that the 2 have the same length. 27 - IF(MLEN(ISLOT1).NE.MLEN(ISLOT2))THEN 28 - PRINT *,' !!!!!! MATFAR WARNING : The 2 vectors do not'// 29 - - ' have the same length; not plotted.' 30 - RETURN 31 - ENDIF 32 - *** Verify that the length is at least 3. 33 - IF(MLEN(ISLOT1).LT.2.OR.MLEN(ISLOT2).LT.2)THEN 34 - PRINT *,' !!!!!! MATFAR WARNING : The vectors have a'// 35 - - ' length less than 3; not plotted.' 36 - RETURN 37 - ENDIF 38 - *** Plot the area. 39 - IF(INDEX(OPTION,'GKS').NE.0)THEN 40 - CALL GFA(MLEN(ISLOT1),MVEC(MORG(ISLOT1)+1), 41 - - MVEC(MORG(ISLOT2)+1)) 42 - ELSE 43 - CALL GRAREA(MLEN(ISLOT1),MVEC(MORG(ISLOT1)+1), 44 - - MVEC(MORG(ISLOT2)+1)) 45 - ENDIF 46 - END 404 GARFIELD ================================================== P=MATRIX D=MATFEX 1 ============================ 0 + +DECK,MATFEX. 1 - SUBROUTINE MATFEX(IREFX,IREFY,IREFEY,OPTION,PAR,ERR,NPAR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MATFEX - Fits an exponential of a polynomial to a matrix. 4 - * (Last changed on 2/ 7/96.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,MATDATA. 8.- +SEQ,PRINTPLOT. 9 - LOGICAL LPRINT,LPLOT 10 - CHARACTER*(*) OPTION 11 - REAL PAR(*),ERR(*),XPL(MXLIST),YPL(MXLIST),XMIN,XMAX,YMIN,YMAX 12 - DOUBLE PRECISION AA(MXFPAR),EA(MXFPAR),XX,YY 13 - INTEGER IFAIL,NPAR,MATSLT,ISX,ISY,ISEY,IREFX,IREFY,IREFEY 14 - EXTERNAL MATSLT 15 - *** Assume the fit will fail. 16 - IFAIL=1 17 - *** Locate the matrices. 18 - ISX=MATSLT(IREFX) 19 - ISY=MATSLT(IREFY) 20 - ISEY=MATSLT(IREFEY) 21 - * Make sure that they exist. 22 - IF(ISX.LE.0.OR.ISY.LE.0.OR.ISEY.LE.0)THEN 23 - PRINT *,' !!!!!! MATFEX WARNING : One or more matrix'// 24 - - ' references not valid; no fit.' 25 - RETURN 26 - * Make sure they are 1-dimensional. 27 - ELSEIF(MDIM(ISX).NE.1.OR.MDIM(ISY).NE.1.OR.MDIM(ISEY).NE.1)THEN 28 - PRINT *,' !!!!!! MATFEX WARNING : One or more matrices'// 29 - - ' is not 1-dimensional; no fit.' 30 - RETURN 31 - * Make sure there are the same length and sufficiently long. 32 - ELSEIF(MLEN(ISX).NE.MLEN(ISY).OR.MLEN(ISY).NE.MLEN(ISEY).OR. 33 - - MLEN(ISX).LT.NPAR.OR.NPAR.LT.1)THEN 34 - PRINT *,' !!!!!! MATFEX WARNING : Matrix dimensions not'// 35 - - ' compatible or too small; no fit.' 36 - RETURN 37 - ENDIF 38 - *** Decode the option string. 39 - LPRINT=.FALSE. 40 - LPLOT=.FALSE. 41 - IF(INDEX(OPTION,'NOPLOT').NE.0)THEN 42 - LPLOT=.FALSE. 43 - ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN 44 - LPLOT=.TRUE. 45 - ENDIF 46 - IF(INDEX(OPTION,'NOPRINT').NE.0)THEN 47 - LPRINT=.FALSE. 48 - ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN 49 - LPRINT=.TRUE. 50 - ENDIF 51 - *** Call the fitting routine. 52 - CALL EXPFIT(MVEC(MORG(ISX)+1),MVEC(MORG(ISY)+1), 53 - - MVEC(MORG(ISEY)+1),MLEN(ISX),LPRINT,AA,EA,NPAR,IFAIL) 54 - DO 10 I=1,NPAR 55 - PAR(I)=REAL(AA(I)) 56 - ERR(I)=REAL(EA(I)) 57 - 10 CONTINUE 58 - *** Make a plot of the fit, start plotting the frame. 59 - IF(LPLOT)THEN 60 - * Switch to logarithmic scale. 61 - CALL GRAOPT('LIN-X, LOG-Y') 62 - * Determine scale. 1 404 P=MATRIX D=MATFEX 2 PAGE 512 63 - DO 20 I=1,MLEN(ISX) 64 - IF(I.EQ.1)THEN 65 - XMIN=MVEC(MORG(ISX)+I) 66 - XMAX=MVEC(MORG(ISX)+I) 67 - YMIN=MVEC(MORG(ISY)+I)-ABS(MVEC(MORG(ISEY)+I)) 68 - YMAX=MVEC(MORG(ISY)+I)+ABS(MVEC(MORG(ISEY)+I)) 69 - ELSE 70 - XMIN=MIN(XMIN,MVEC(MORG(ISX)+I)) 71 - XMAX=MAX(XMAX,MVEC(MORG(ISX)+I)) 72 - YMIN=MIN(YMIN,MVEC(MORG(ISY)+I)- 73 - - ABS(MVEC(MORG(ISEY)+I))) 74 - YMAX=MAX(YMAX,MVEC(MORG(ISY)+I)+ 75 - - ABS(MVEC(MORG(ISEY)+I))) 76 - ENDIF 77 - 20 CONTINUE 78 - * Plot frame. 79 - CALL GRCART(XMIN-0.1*(XMAX-XMIN),YMIN-0.1*(YMAX-YMIN), 80 - - XMAX+0.1*(XMAX-XMIN),YMAX+0.1*(YMAX-YMIN), 81 - - 'x','y','Exponential fit') 82 - * Plot the error bars. 83 - CALL MATERR(IREFX,IREFY,0,IREFEY,0,IREFEY,'CIRCLE',0.01) 84 - * Prepare the plot vector. 85 - DO 30 I=1,MXLIST 86 - XPL(I)=XMIN+REAL(I-1)*(XMAX-XMIN)/REAL(MXLIST-1) 87 - XX=XPL(I) 88 - CALL EXPFUN(XX,AA,YY) 89 - YPL(I)=YY 90 - 30 CONTINUE 91 - * Set the attributes. 92 - CALL GRATTS('FUNCTION-2','POLYLINE') 93 - * Plot the line itself. 94 - CALL GRLINE(MXLIST,XPL,YPL) 95 - * Close the plot. 96 - CALL GRNEXT 97 - * Switch to normal mode. 98 - CALL GRAOPT('LIN-X, LIN-Y') 99 - * Register the plot. 100 - CALL GRALOG('Exponential fit to a matrix.') 101 - ENDIF 102 - END 405 GARFIELD ================================================== P=MATRIX D=MATFPR 1 ============================ 0 + +DECK,MATFPR. 1 - SUBROUTINE MATFPR(IREFX,IREFY,IREFEY,OPTION, 2 - - FACT,OFF,SLOPE,THETA,EFACT,EOFF,ESLOPE,ETHETA,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * MATFPR - Fits a Polya distribution to a matrix. 5 - * (Last changed on 21/ 8/96.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9.- +SEQ,PRINTPLOT. 10 - LOGICAL LPRINT,LPLOT,LSCALE,LAUTO 11 - CHARACTER*(*) OPTION 12 - REAL FACT,OFF,SLOPE,THETA,EFACT,EOFF,ESLOPE,ETHETA, 13 - - XPL(MXLIST),YPL(MXLIST),XMIN,XMAX,YMIN,YMAX 14 - DOUBLE PRECISION AA(4),EA(4),XX,YY 15 - INTEGER IFAIL,MATSLT,ISX,ISY,ISEY,IREFX,IREFY,IREFEY 16 - EXTERNAL MATSLT 17 - *** Assume the fit will fail. 18 - IFAIL=1 19 - *** Locate the matrices. 20 - ISX=MATSLT(IREFX) 21 - ISY=MATSLT(IREFY) 22 - ISEY=MATSLT(IREFEY) 23 - * Make sure that they exist. 24 - IF(ISX.LE.0.OR.ISY.LE.0.OR.ISEY.LE.0)THEN 25 - PRINT *,' !!!!!! MATFPR WARNING : One or more matrix'// 26 - - ' references not valid; no fit.' 27 - RETURN 28 - * Make sure they are 1-dimensional. 29 - ELSEIF(MDIM(ISX).NE.1.OR.MDIM(ISY).NE.1.OR.MDIM(ISEY).NE.1)THEN 30 - PRINT *,' !!!!!! MATFPR WARNING : One or more matrices'// 31 - - ' is not 1-dimensional; no fit.' 32 - RETURN 33 - * Make sure there are the same length and sufficiently long. 34 - ELSEIF(MLEN(ISX).NE.MLEN(ISY).OR.MLEN(ISY).NE.MLEN(ISEY).OR. 35 - - MLEN(ISX).LT.4)THEN 36 - PRINT *,' !!!!!! MATFPR WARNING : Matrix dimensions not'// 37 - - ' compatible or too small; no fit.' 38 - RETURN 39 - ENDIF 40 - *** Decode the option string. 41 - LPRINT=.FALSE. 42 - LPLOT=.FALSE. 43 - LAUTO=.TRUE. 44 - LSCALE=.TRUE. 45 - IF(INDEX(OPTION,'NOPLOT').NE.0)THEN 46 - LPLOT=.FALSE. 47 - ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN 48 - LPLOT=.TRUE. 49 - ENDIF 50 - IF(INDEX(OPTION,'NOPRINT').NE.0)THEN 51 - LPRINT=.FALSE. 52 - ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN 53 - LPRINT=.TRUE. 54 - ENDIF 55 - IF(INDEX(OPTION,'FIT').NE.0)THEN 56 - LSCALE=.TRUE. 57 - ELSEIF(INDEX(OPTION,'FIX').NE.0)THEN 58 - LSCALE=.FALSE. 59 - ENDIF 60 - IF(INDEX(OPTION,'AUTO').NE.0)THEN 61 - LAUTO=.TRUE. 62 - ELSEIF(INDEX(OPTION,'MANUAL').NE.0)THEN 1 405 P=MATRIX D=MATFPR 2 PAGE 513 63 - LAUTO=.FALSE. 64 - ENDIF 65 - *** Call the fitting routine. 66 - AA(1)=FACT 67 - AA(2)=THETA 68 - AA(3)=OFF 69 - AA(4)=SLOPE 70 - CALL PYAFIT(MVEC(MORG(ISX)+1),MVEC(MORG(ISY)+1), 71 - - MVEC(MORG(ISEY)+1),MLEN(ISX),LPRINT,.TRUE.,LSCALE,LAUTO, 72 - - AA,EA,IFAIL) 73 - FACT=AA(1) 74 - THETA=AA(2) 75 - OFF=AA(3) 76 - SLOPE=AA(4) 77 - EFACT=EA(1) 78 - ETHETA=EA(2) 79 - EOFF=EA(3) 80 - ESLOPE=EA(4) 81 - *** Make a plot of the fit, start plotting the frame. 82 - IF(LPLOT)THEN 83 - * Switch to logarithmic scale. 84 - CALL GRAOPT('LIN-X, LOG-Y') 85 - * Determine scale. 86 - DO 20 I=1,MLEN(ISX) 87 - IF(I.EQ.1)THEN 88 - XMIN=MVEC(MORG(ISX)+I) 89 - XMAX=MVEC(MORG(ISX)+I) 90 - YMIN=MVEC(MORG(ISY)+I)-ABS(MVEC(MORG(ISEY)+I)) 91 - YMAX=MVEC(MORG(ISY)+I)+ABS(MVEC(MORG(ISEY)+I)) 92 - ELSE 93 - XMIN=MIN(XMIN,MVEC(MORG(ISX)+I)) 94 - XMAX=MAX(XMAX,MVEC(MORG(ISX)+I)) 95 - YMIN=MIN(YMIN,MVEC(MORG(ISY)+I)- 96 - - ABS(MVEC(MORG(ISEY)+I))) 97 - YMAX=MAX(YMAX,MVEC(MORG(ISY)+I)+ 98 - - ABS(MVEC(MORG(ISEY)+I))) 99 - ENDIF 100 - 20 CONTINUE 101 - * Plot frame. 102 - CALL GRCART(XMIN-0.1*(XMAX-XMIN),0.9*YMIN, 103 - - XMAX+0.1*(XMAX-XMIN),1.1*YMAX, 104 - - 'Multiplication','Frequency','Polya fit') 105 - * Plot the error bars. 106 - CALL MATERR(IREFX,IREFY,0,IREFEY,0,IREFEY,'CIRCLE',0.01) 107 - * Prepare the plot vector. 108 - DO 30 I=1,MXLIST 109 - XPL(I)=XMIN+REAL(I-1)*(XMAX-XMIN)/REAL(MXLIST-1) 110 - XX=XPL(I) 111 - CALL PYAFUN(XX,AA,YY) 112 - YPL(I)=YY 113 - 30 CONTINUE 114 - * Set the attributes. 115 - CALL GRATTS('FUNCTION-2','POLYLINE') 116 - * Plot the line itself. 117 - CALL GRLINE(MXLIST,XPL,YPL) 118 - * Close the plot. 119 - CALL GRNEXT 120 - * Switch to normal mode. 121 - CALL GRAOPT('LIN-X, LIN-Y') 122 - * Register the plot. 123 - CALL GRALOG('Polya fit to a matrix.') 124 - ENDIF 125 - END 406 GARFIELD ================================================== P=MATRIX D=MATFNR 1 ============================ 0 + +DECK,MATFNR. 1 - SUBROUTINE MATFNR(IREFX,IREFY,IREFEY,OPTION,FACT,AVER,SIGMA, 2 - - EFACT,EAVER,ESIGMA,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * MATFNR - Fits a Gaussian to a matrix. 5 - * (Last changed on 2/ 7/96.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9.- +SEQ,PRINTPLOT. 10 - LOGICAL LPRINT,LPLOT 11 - CHARACTER*(*) OPTION 12 - REAL XPL(MXLIST),YPL(MXLIST),XMIN,XMAX,YMIN,YMAX,FACT,AVER,SIGMA, 13 - - EFACT,EAVER,ESIGMA 14 - DOUBLE PRECISION AA(3),EA(3),XX,YY 15 - INTEGER IFAIL,MATSLT,ISX,ISY,ISEY,IREFX,IREFY,IREFEY 16 - EXTERNAL MATSLT 17 - *** Assume the fit will fail. 18 - IFAIL=1 19 - *** Locate the matrices. 20 - ISX=MATSLT(IREFX) 21 - ISY=MATSLT(IREFY) 22 - ISEY=MATSLT(IREFEY) 23 - * Make sure that they exist. 24 - IF(ISX.LE.0.OR.ISY.LE.0.OR.ISEY.LE.0)THEN 25 - PRINT *,' !!!!!! MATFNR WARNING : One or more matrix'// 26 - - ' references not valid; no fit.' 27 - RETURN 28 - * Make sure they are 1-dimensional. 29 - ELSEIF(MDIM(ISX).NE.1.OR.MDIM(ISY).NE.1.OR.MDIM(ISEY).NE.1)THEN 30 - PRINT *,' !!!!!! MATFNR WARNING : One or more matrices'// 31 - - ' is not 1-dimensional; no fit.' 32 - RETURN 33 - * Make sure there are the same length and sufficiently long. 34 - ELSEIF(MLEN(ISX).NE.MLEN(ISY).OR.MLEN(ISY).NE.MLEN(ISEY).OR. 35 - - MLEN(ISX).LT.3)THEN 36 - PRINT *,' !!!!!! MATFNR WARNING : Matrix dimensions not'// 37 - - ' compatible or too small; no fit.' 38 - RETURN 39 - ENDIF 1 406 P=MATRIX D=MATFNR 2 PAGE 514 40 - *** Decode the option string. 41 - LPRINT=.FALSE. 42 - LPLOT=.FALSE. 43 - IF(INDEX(OPTION,'NOPLOT').NE.0)THEN 44 - LPLOT=.FALSE. 45 - ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN 46 - LPLOT=.TRUE. 47 - ENDIF 48 - IF(INDEX(OPTION,'NOPRINT').NE.0)THEN 49 - LPRINT=.FALSE. 50 - ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN 51 - LPRINT=.TRUE. 52 - ENDIF 53 - *** Call the fitting routine. 54 - CALL NORFIT(MVEC(MORG(ISX)+1),MVEC(MORG(ISY)+1), 55 - - MVEC(MORG(ISEY)+1),MLEN(ISX),LPRINT,AA,EA,IFAIL) 56 - FACT=REAL(AA(1)) 57 - AVER=REAL(AA(2)) 58 - SIGMA=REAL(AA(3)) 59 - EFACT=REAL(EA(1)) 60 - EAVER=REAL(EA(2)) 61 - ESIGMA=REAL(EA(3)) 62 - *** Make a plot of the fit, start plotting the frame. 63 - IF(LPLOT)THEN 64 - * Determine scale. 65 - DO 10 I=1,MLEN(ISX) 66 - IF(I.EQ.1)THEN 67 - XMIN=MVEC(MORG(ISX)+I) 68 - XMAX=MVEC(MORG(ISX)+I) 69 - YMIN=MVEC(MORG(ISY)+I)-ABS(MVEC(MORG(ISEY)+I)) 70 - YMAX=MVEC(MORG(ISY)+I)+ABS(MVEC(MORG(ISEY)+I)) 71 - ELSE 72 - XMIN=MIN(XMIN,MVEC(MORG(ISX)+I)) 73 - XMAX=MAX(XMAX,MVEC(MORG(ISX)+I)) 74 - YMIN=MIN(YMIN,MVEC(MORG(ISY)+I)- 75 - - ABS(MVEC(MORG(ISEY)+I))) 76 - YMAX=MAX(YMAX,MVEC(MORG(ISY)+I)+ 77 - - ABS(MVEC(MORG(ISEY)+I))) 78 - ENDIF 79 - 10 CONTINUE 80 - * Plot frame. 81 - CALL GRCART(XMIN-0.1*(XMAX-XMIN),YMIN-0.1*(YMAX-YMIN), 82 - - XMAX+0.1*(XMAX-XMIN),YMAX+0.1*(YMAX-YMIN), 83 - - 'x','y','Gaussian fit') 84 - * Plot the error bars. 85 - CALL MATERR(IREFX,IREFY,0,IREFEY,0,IREFEY,'CIRCLE',0.01) 86 - * Prepare the plot vector. 87 - DO 30 I=1,MXLIST 88 - XPL(I)=XMIN+REAL(I-1)*(XMAX-XMIN)/REAL(MXLIST-1) 89 - XX=XPL(I) 90 - CALL NORFUN(XX,AA,YY) 91 - YPL(I)=YY 92 - 30 CONTINUE 93 - * Set the attributes. 94 - CALL GRATTS('FUNCTION-2','POLYLINE') 95 - * Plot the line itself. 96 - CALL GRLINE(MXLIST,XPL,YPL) 97 - * Close the plot. 98 - CALL GRNEXT 99 - * Register the plot. 100 - CALL GRALOG('Gaussian fit to a matrix.') 101 - ENDIF 102 - END 407 GARFIELD ================================================== P=MATRIX D=MATFPL 1 ============================ 0 + +DECK,MATFPL. 1 - SUBROUTINE MATFPL(IREFX,IREFY,IREFEY,OPTION,PAR,ERR,NPAR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MATFPL - Fits a polynomial to a matrix. 4 - * (Last changed on 12/ 6/96.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,MATDATA. 8.- +SEQ,PRINTPLOT. 9 - LOGICAL LPRINT,LPLOT 10 - CHARACTER*(*) OPTION 11 - REAL PAR(*),ERR(*),XPL(MXLIST),YPL(MXLIST),XMIN,XMAX 12 - DOUBLE PRECISION AA(MXFPAR),EA(MXFPAR),XX,YY 13 - INTEGER IFAIL,NPAR,MATSLT,ISX,ISY,ISEY,IREFX,IREFY,IREFEY 14 - EXTERNAL MATSLT 15 - *** Assume the fit will fail. 16 - IFAIL=1 17 - *** Locate the matrices. 18 - ISX=MATSLT(IREFX) 19 - ISY=MATSLT(IREFY) 20 - ISEY=MATSLT(IREFEY) 21 - * Make sure that they exist. 22 - IF(ISX.LE.0.OR.ISY.LE.0.OR.ISEY.LE.0)THEN 23 - PRINT *,' !!!!!! MATFPL WARNING : One or more matrix'// 24 - - ' references not valid; no fit.' 25 - RETURN 26 - * Make sure they are 1-dimensional. 27 - ELSEIF(MDIM(ISX).NE.1.OR.MDIM(ISY).NE.1.OR.MDIM(ISEY).NE.1)THEN 28 - PRINT *,' !!!!!! MATFPL WARNING : One or more matrices'// 29 - - ' is not 1-dimensional; no fit.' 30 - RETURN 31 - * Make sure there are the same length and sufficiently long. 32 - ELSEIF(MLEN(ISX).NE.MLEN(ISY).OR.MLEN(ISY).NE.MLEN(ISEY).OR. 33 - - MLEN(ISX).LT.NPAR.OR.NPAR.LT.1)THEN 34 - PRINT *,' !!!!!! MATFPL WARNING : Matrix dimensions not'// 35 - - ' compatible or too small; no fit.' 36 - RETURN 37 - ENDIF 38 - *** Decode the option string. 39 - LPRINT=.FALSE. 1 407 P=MATRIX D=MATFPL 2 PAGE 515 40 - LPLOT=.FALSE. 41 - IF(INDEX(OPTION,'NOPLOT').NE.0)THEN 42 - LPLOT=.FALSE. 43 - ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN 44 - LPLOT=.TRUE. 45 - ENDIF 46 - IF(INDEX(OPTION,'NOPRINT').NE.0)THEN 47 - LPRINT=.FALSE. 48 - ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN 49 - LPRINT=.TRUE. 50 - ENDIF 51 - *** Call the fitting routine. 52 - CALL POLFIT(MVEC(MORG(ISX)+1),MVEC(MORG(ISY)+1), 53 - - MVEC(MORG(ISEY)+1),MLEN(ISX),LPRINT,AA,EA,NPAR,IFAIL) 54 - DO 10 I=1,NPAR 55 - PAR(I)=REAL(AA(I)) 56 - ERR(I)=REAL(EA(I)) 57 - 10 CONTINUE 58 - *** Make a plot of the fit, start plotting the frame. 59 - IF(LPLOT)THEN 60 - * Determine scale. 61 - DO 20 I=1,MLEN(ISX) 62 - IF(I.EQ.1)THEN 63 - XMIN=MVEC(MORG(ISX)+I) 64 - XMAX=MVEC(MORG(ISX)+I) 65 - YMIN=MVEC(MORG(ISY)+I)-ABS(MVEC(MORG(ISEY)+I)) 66 - YMAX=MVEC(MORG(ISY)+I)+ABS(MVEC(MORG(ISEY)+I)) 67 - ELSE 68 - XMIN=MIN(XMIN,MVEC(MORG(ISX)+I)) 69 - XMAX=MAX(XMAX,MVEC(MORG(ISX)+I)) 70 - YMIN=MIN(YMIN,MVEC(MORG(ISY)+I)- 71 - - ABS(MVEC(MORG(ISEY)+I))) 72 - YMAX=MAX(YMAX,MVEC(MORG(ISY)+I)+ 73 - - ABS(MVEC(MORG(ISEY)+I))) 74 - ENDIF 75 - 20 CONTINUE 76 - * Plot frame. 77 - CALL GRCART(XMIN-0.1*(XMAX-XMIN),YMIN-0.1*(YMAX-YMIN), 78 - - XMAX+0.1*(XMAX-XMIN),YMAX+0.1*(YMAX-YMIN), 79 - - 'x','y','Polynomial fit') 80 - * Plot the error bars. 81 - CALL MATERR(IREFX,IREFY,0,IREFEY,0,IREFEY,'CIRCLE',0.01) 82 - * Prepare the plot vector. 83 - DO 30 I=1,MXLIST 84 - XPL(I)=XMIN+REAL(I-1)*(XMAX-XMIN)/REAL(MXLIST-1) 85 - XX=XPL(I) 86 - CALL POLFUN(XX,AA,YY) 87 - YPL(I)=YY 88 - 30 CONTINUE 89 - * Set the attributes. 90 - CALL GRATTS('FUNCTION-2','POLYLINE') 91 - * Plot the line itself. 92 - CALL GRLINE(MXLIST,XPL,YPL) 93 - * Close the plot. 94 - CALL GRNEXT 95 - * Register the plot. 96 - CALL GRALOG('Polynomial fit to a matrix.') 97 - ENDIF 98 - END 408 GARFIELD ================================================== P=MATRIX D=MATFFU 1 ============================ 0 + +DECK,MATFFU. 1 - SUBROUTINE MATFFU(IREFX,IREFY,IREFEY,FUN,OPTION,IA,IE,NPAR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MATFFU - Fits a function to a matrix. 4 - * (Last changed on 20/ 2/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,GLOBALS. 11 - LOGICAL LPRINT,LPLOT 12 - CHARACTER*(*) OPTION,FUN 13 - CHARACTER*40 TITLE 14 - REAL XPL(MXLIST),YPL(MXLIST),XMIN,XMAX,YMIN,YMAX 15 - DOUBLE PRECISION AA(MXFPAR),XX,YY 16 - INTEGER IFAIL,IFAIL1,NPAR,NNA,IIA,IA(*),IE(*),I,IENTRY,MATSLT, 17 - - ISX,ISY,ISEY,IREFX,IREFY,IREFEY 18 - COMMON /FFUDAT/ NNA,IENTRY,IIA(MXVAR) 19 - EXTERNAL MATSLT 20 - *** Assume the fit will fail. 21 - IFAIL=1 22 - *** Locate the matrices. 23 - ISX=MATSLT(IREFX) 24 - ISY=MATSLT(IREFY) 25 - ISEY=MATSLT(IREFEY) 26 - * Make sure that they exist. 27 - IF(ISX.LE.0.OR.ISY.LE.0.OR.ISEY.LE.0)THEN 28 - PRINT *,' !!!!!! MATFFU WARNING : One or more matrix'// 29 - - ' references not valid; no fit.' 30 - RETURN 31 - * Make sure they are 1-dimensional. 32 - ELSEIF(MDIM(ISX).NE.1.OR.MDIM(ISY).NE.1.OR.MDIM(ISEY).NE.1)THEN 33 - PRINT *,' !!!!!! MATFFU WARNING : One or more matrices'// 34 - - ' is not 1-dimensional; no fit.' 35 - RETURN 36 - * Make sure there are the same length and sufficiently long. 37 - ELSEIF(MLEN(ISX).NE.MLEN(ISY).OR.MLEN(ISY).NE.MLEN(ISEY).OR. 38 - - MLEN(ISX).LT.NPAR.OR.NPAR.LT.1)THEN 39 - PRINT *,' !!!!!! MATFFU WARNING : Matrix dimensions not'// 40 - - ' compatible or too small; no fit.' 41 - RETURN 42 - ENDIF 43 - *** Decode the option string. 1 408 P=MATRIX D=MATFFU 2 PAGE 516 44 - LPRINT=.FALSE. 45 - LPLOT=.FALSE. 46 - IF(INDEX(OPTION,'NOPLOT').NE.0)THEN 47 - LPLOT=.FALSE. 48 - ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN 49 - LPLOT=.TRUE. 50 - ENDIF 51 - IF(INDEX(OPTION,'NOPRINT').NE.0)THEN 52 - LPRINT=.FALSE. 53 - ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN 54 - LPRINT=.TRUE. 55 - ENDIF 56 - *** Call the fitting routine. 57 - CALL FUNFIT(FUN,MVEC(MORG(ISX)+1),MVEC(MORG(ISY)+1), 58 - - MVEC(MORG(ISEY)+1),MLEN(ISX),LPRINT,IA,IE,NPAR,IFAIL1) 59 - IF(IFAIL1.NE.0)THEN 60 - PRINT *,' !!!!!! MATFFU WARNING : The fit to ',FUN, 61 - - ' failed.' 62 - CALL ALGCLR(IENTRY) 63 - RETURN 64 - ENDIF 65 - *** Make a plot of the fit, start plotting the frame. 66 - IF(LPLOT)THEN 67 - * Determine scale. 68 - DO 20 I=1,MLEN(ISX) 69 - IF(I.EQ.1)THEN 70 - XMIN=MVEC(MORG(ISX)+I) 71 - XMAX=MVEC(MORG(ISX)+I) 72 - YMIN=MVEC(MORG(ISY)+I)-ABS(MVEC(MORG(ISEY)+I)) 73 - YMAX=MVEC(MORG(ISY)+I)+ABS(MVEC(MORG(ISEY)+I)) 74 - ELSE 75 - XMIN=MIN(XMIN,MVEC(MORG(ISX)+I)) 76 - XMAX=MAX(XMAX,MVEC(MORG(ISX)+I)) 77 - YMIN=MIN(YMIN,MVEC(MORG(ISY)+I)- 78 - - ABS(MVEC(MORG(ISEY)+I))) 79 - YMAX=MAX(YMAX,MVEC(MORG(ISY)+I)+ 80 - - ABS(MVEC(MORG(ISEY)+I))) 81 - ENDIF 82 - 20 CONTINUE 83 - * Plot frame. 84 - WRITE(TITLE,'(''Fit to '',A)') FUN(1:MIN(LEN(FUN),33)) 85 - CALL GRCART(XMIN-0.1*(XMAX-XMIN),YMIN-0.1*(YMAX-YMIN), 86 - - XMAX+0.1*(XMAX-XMIN),YMAX+0.1*(YMAX-YMIN), 87 - - 'x','y',TITLE) 88 - * Plot the error bars. 89 - CALL MATERR(IREFX,IREFY,0,IREFEY,0,IREFEY,'CIRCLE',0.01) 90 - * Prepare the parameter list. 91 - DO 40 I=1,NPAR 92 - AA(I)=GLBVAL(IIA(I)) 93 - 40 CONTINUE 94 - * Prepare the plot vector. 95 - DO 30 I=1,MXLIST 96 - XPL(I)=XMIN+REAL(I-1)*(XMAX-XMIN)/REAL(MXLIST-1) 97 - XX=XPL(I) 98 - CALL FUNFUN(XX,AA,YY) 99 - YPL(I)=YY 100 - 30 CONTINUE 101 - * Set the attributes. 102 - CALL GRATTS('FUNCTION-2','POLYLINE') 103 - * Plot the line itself. 104 - CALL GRLINE(MXLIST,XPL,YPL) 105 - * Close the plot. 106 - CALL GRNEXT 107 - * Register the plot. 108 - CALL GRALOG('Function fit to a matrix.') 109 - ENDIF 110 - *** We're now done with the function, so can delete the entry point. 111 - CALL ALGCLR(IENTRY) 112 - *** Seems to have worked. 113 - IFAIL=0 114 - END 409 GARFIELD ================================================== P=MATRIX D=MATGET 1 ============================ 0 + +DECK,MATGET. 1 - SUBROUTINE MATGET(IREF,FILE,MEMB,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MATGET - This routine reads an matrix from a file. 4 - * VARIABLES : STRING : Character string that should contain a 5 - * description of the dataset being read. 6 - * (Last changed on 3/12/96.) 7 - *----------------------------------------------------------------------- 8.- +SEQ,DIMENSIONS. 9.- +SEQ,MATDATA. 10.- +SEQ,PRINTPLOT. 11 - CHARACTER*132 STRING 12 - CHARACTER*(*) FILE,MEMB 13 - CHARACTER*8 MEMBER 14 - INTEGER ISIZ(MXMDIM),MATSLT 15 - LOGICAL DSNCMP,EXIS 16 - EXTERNAL DSNCMP,MATSLT 17 - *** Identify the routine, if requested. 18 - IF(LIDENT)PRINT *,' /// ROUTINE MATGET ///' 19 - *** Initialise IFAIL on 1 (i.e. fail). 20 - IFAIL=1 21 - *** Transfer variables. 22 - MEMBER=MEMB 23 - *** Initialise IREF so that MATCAL always gets something back. 24 - IREF=-1 25 - *** Open the dataset and inform DSNLOG. 26 - CALL DSNOPN(FILE,LEN(FILE),12,'READ-LIBRARY',IFAIL1) 27 - IF(IFAIL1.NE.0)THEN 28 - PRINT *,' !!!!!! MATGET WARNING : Opening ',FILE, 29 - - ' failed ; matrix not read.' 30 - IFAIL=1 31 - RETURN 1 409 P=MATRIX D=MATGET 2 PAGE 517 32 - ENDIF 33 - CALL DSNLOG(FILE,'Matrix ','Sequential','Read only ') 34 - IF(LDEBUG)PRINT *,' ++++++ MATGET DEBUG : Dataset ', 35 - - FILE,' opened on unit 12 for seq read.' 36 - * Locate the pointer on the header of the requested member. 37 - CALL DSNLOC(MEMBER,LEN(MEMBER),'MATRIX ',12,EXIS,'RESPECT') 38 - IF(.NOT.EXIS)THEN 39 - CALL DSNLOC(MEMBER,LEN(MEMBER),'MATRIX ',12,EXIS,'IGNORE') 40 - IF(EXIS)THEN 41 - PRINT *,' ###### MATGET ERROR : Matrix ',MEMBER, 42 - - ' has been deleted from ',FILE,'; not read.' 43 - ELSE 44 - PRINT *,' ###### MATGET ERROR : Matrix ',MEMBER, 45 - - ' not found on ',FILE,'.' 46 - ENDIF 47 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 48 - IFAIL=1 49 - RETURN 50 - ENDIF 51 - *** Check that the member is acceptable. 52 - READ(12,'(A80)',END=2000,IOSTAT=IOS,ERR=2010) STRING 53 - IF(DSNCMP('03-12-96',STRING(11:18)))THEN 54 - PRINT *,' !!!!!! MATGET WARNING : Member ',STRING(32:39), 55 - - ' can not be read because of a change in format.' 56 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 57 - IFAIL=1 58 - RETURN 59 - ENDIF 60 - WRITE(LUNOUT,'('' Member '',A8,'' was created on '',A8, 61 - - '' at '',A8/'' Remarks: '',A29)') 62 - - STRING(32:39),STRING(11:18),STRING(23:30),STRING(51:79) 63 - *** Read the matrix dimension. 64 - READ(12,'(/12X,I10/12X,I10/12X,12I10:(/12X,12I10))', 65 - - IOSTAT=IOS,END=2000,ERR=2010) NDIM,IMOD,(ISIZ(I),I=1,NDIM) 66 - *** Allocate a matrix for this member. 67 - CALL MATADM('ALLOCATE',IREF,NDIM,ISIZ,IMOD,IFAIL1) 68 - IF(IFAIL1.NE.0)THEN 69 - PRINT *,' !!!!!! MATGET WARNING : Unable to obtain space'// 70 - - ' to store the matrix to be read; not read.' 71 - IFAIL=1 72 - IREF=-1 73 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 74 - RETURN 75 - ENDIF 76 - *** Find the newly allocated matrix. 77 - ISLOT=MATSLT(IREF) 78 - IF(ISLOT.LE.0)THEN 79 - PRINT *,' !!!!!! MATGET WARNING : New matrix not found;'// 80 - - ' program bug - please report.' 81 - IREF=-1 82 - IFAIL=1 83 - RETURN 84 - ENDIF 85 - *** Execute read operations if a valid name is available. 86 - READ(12,'()',IOSTAT=IOS,END=2000,ERR=2010) 87 - READ(12,'(2X,8E15.8)',IOSTAT=IOS,END=2000,ERR=2010) 88 - - (MVEC(MORG(ISLOT)+I),I=1,MLEN(ISLOT)) 89 - * Close the file after the operation. 90 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 91 - *** Register the amount of CPU time used for reading. 92 - CALL TIMLOG('Reading an matrix from a dataset: ') 93 - *** Things worked, reset the error flag. 94 - IFAIL=0 95 - RETURN 96 - *** Handle the I/O error conditions. 97 - 2000 CONTINUE 98 - PRINT *,' ###### MATGET ERROR : EOF encountered while', 99 - - ' reading ',FILE,' from unit 12 ; no matrix read.' 100 - CALL INPIOS(IOS) 101 - IF(IREF.NE.-1)CALL MATADM('DELETE',IREF,1,ISIZ,2,IFAIL1) 102 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 103 - RETURN 104 - 2010 CONTINUE 105 - PRINT *,' ###### MATGET ERROR : Error while reading ', 106 - - FILE,' from unit 12 ; no matrix read.' 107 - CALL INPIOS(IOS) 108 - IF(IREF.NE.-1)CALL MATADM('DELETE',IREF,1,ISIZ,2,IFAIL1) 109 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 110 - RETURN 111 - 2030 CONTINUE 112 - PRINT *,' ###### MATGET ERROR : Dataset ',FILE, 113 - - ' on unit 12 cannot be closed ; results not predictable.' 114 - CALL INPIOS(IOS) 115 - END 410 GARFIELD ================================================== P=MATRIX D=MATGRA 1 ============================ 0 + +DECK,MATGRA. 1 - SUBROUTINE MATGRA(IREF1,IREF2,XTXT,YTXT,TITLE) 2 - *----------------------------------------------------------------------- 3 - * MATGRA - Plots a graph. 4 - * (Last changed on 6/ 4/98.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,MATDATA. 8.- +SEQ,PRINTPLOT. 9 - CHARACTER*(*) XTXT,YTXT,TITLE 10 - *** Identify the routine if requested. 11 - IF(LIDENT)PRINT *,' /// ROUTINE MATGRA ///' 12 - *** Debugging output. 13 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATGRA DEBUG : Graph'', 14 - - '' of '',I5,'' vs '',I5/26X,''x-Axis label: '',A/ 15 - - 26X,''y-Axis label: '',A/26X,''Title: '',A)') 16 - - IREF1,IREF2,XTXT,YTXT,TITLE 17 - *** Locate the 2 vectors. 18 - ISLOT1=0 1 410 P=MATRIX D=MATGRA 2 PAGE 518 19 - ISLOT2=0 20 - DO 10 I=1,MXMAT 21 - IF(MREF(I).EQ.IREF1)THEN 22 - ISLOT1=I 23 - ELSEIF(MREF(I).EQ.IREF2)THEN 24 - ISLOT2=I 25 - ENDIF 26 - IF(ISLOT1.NE.0.AND.ISLOT2.NE.0)GOTO 20 27 - 10 CONTINUE 28 - PRINT *,' !!!!!! MATGRA WARNING : Matrix to be plotted has'// 29 - - ' not been found.' 30 - RETURN 31 - 20 CONTINUE 32 - *** Verify that the 2 have the same length. 33 - IF(MLEN(ISLOT1).NE.MLEN(ISLOT2))THEN 34 - PRINT *,' !!!!!! MATGRA WARNING : The 2 vectors do not'// 35 - - ' have the same length; not plotted.' 36 - RETURN 37 - ENDIF 38 - *** Verify that the length is at least 2. 39 - IF(MLEN(ISLOT1).LT.2.OR.MLEN(ISLOT2).LT.2)THEN 40 - PRINT *,' !!!!!! MATGRA WARNING : The vectors have a'// 41 - - ' length less than 2; not plotted.' 42 - RETURN 43 - ENDIF 44 - *** Set the correct graphics representation for the curve. 45 - CALL GRATTS('FUNCTION-1','POLYLINE') 46 - *** Plot the line. 47 - CALL GRGRPH(MVEC(MORG(ISLOT1)+1),MVEC(MORG(ISLOT2)+1), 48 - - MLEN(ISLOT1),XTXT,YTXT,TITLE) 49 - END 411 GARFIELD ================================================== P=MATRIX D=MATIN1 1 ============================ 0 + +DECK,MATIN1. 1 - SUBROUTINE MATIN1(IRVEC1,IRVEC2,N,X,Y,ISVEC1,ISVEC2,IORD,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MATIN1 - Interpolates two vectors. 4 - * (Last changed on 19/ 9/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9.- +SEQ,PRINTPLOT. 10 - INTEGER IRVEC1,IRVEC2,ISVEC1,ISVEC2,IFAIL,I,N,MATSLT,IORD 11 - REAL X(*),Y(*) 12 - EXTERNAL MATSLT 0 13-+ +SELF,IF=ESSL. 14 - INTEGER NAUX 15 - PARAMETER(NAUX=2*MXLIST) 16 - REAL AUX(NAUX) 0 17-+ +SELF,IF=-ESSL. 18 - REAL DIVDIF 19 - EXTERNAL DIVDIF 0 20-+ +SELF. 21 - *** Indentify the routine. 0 22-+ +SELF,IF=ESSL. 23 - IF(LIDENT)PRINT *,' /// ROUTINE MATIN1 (ESSL) ///' 0 24-+ +SELF,IF=-ESSL. 25 - IF(LIDENT)PRINT *,' /// ROUTINE MATIN1 (CERNLIB) ///' 0 26-+ +SELF. 27 - *** Debugging information. 28 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATIN1 DEBUG : Order '',I2, 29 - - '' interpolation for '',I5,'' vs '',I5,'' with '',I5, 30 - - '' points.'')') IORD,IRVEC1,IRVEC2,N 31 - *** Assume the routine will fail. 32 - IFAIL=1 33 - *** Check the interpolation order. 34 - IF(IORD.LT.1)THEN 35 - PRINT *,' !!!!!! MATIN1 WARNING : Interpolation order'// 36 - - ' is not at least 1; no interpolation.' 37 - RETURN 38 - ENDIF 39 - *** Locate slots if not already done. 40 - IF(ISVEC1.LE.0.OR.ISVEC2.LE.0)THEN 41 - * Find the slot numbers. 42 - ISVEC1=MATSLT(IRVEC1) 43 - ISVEC2=MATSLT(IRVEC2) 44 - * Ensure that the vectors exist. 45 - IF(ISVEC1.LE.0.OR.ISVEC2.LE.0)THEN 46 - PRINT *,' !!!!!! MATIN1 WARNING : Unable to locate'// 47 - - ' one of the 2 vectors; no interpolation.' 48 - RETURN 49 - ENDIF 50 - * Make sure they are indeed vectors. 51 - IF(MDIM(ISVEC1).NE.1.OR.MDIM(ISVEC2).NE.1.OR. 52 - - MLEN(ISVEC1).NE.MLEN(ISVEC2).OR. 53 - - MLEN(ISVEC1).LT.2.OR.MLEN(ISVEC2).LT.2)THEN 54 - PRINT *,' !!!!!! MATIN1 WARNING : The 2 vectors are'// 55 - - ' not 1-dimensional, too short or not compatible.' 56 - ISVEC1=-1 57 - ISVEC2=-1 58 - RETURN 59 - ENDIF 60 - * Check that they are properly ordered. 61 - IF(MVEC(MORG(ISVEC1)+2).GT.MVEC(MORG(ISVEC1)+1))THEN 62 - DO 10 I=2,MLEN(ISVEC1) 63 - IF(MVEC(MORG(ISVEC1)+I).LE.MVEC(MORG(ISVEC1)+I-1))THEN 64 - PRINT *,' !!!!!! MATIN1 WARNING : The ordinate'// 65 - - ' vector is not strictly ordered.' 1 411 P=MATRIX D=MATIN1 2 PAGE 519 66 - ISVEC1=-1 67 - ISVEC2=-1 68 - RETURN 69 - ENDIF 70 - 10 CONTINUE 71 - ELSEIF(MVEC(MORG(ISVEC1)+2).LT.MVEC(MORG(ISVEC1)+1))THEN 72 - DO 20 I=2,MLEN(ISVEC1) 73 - IF(MVEC(MORG(ISVEC1)+I).GE.MVEC(MORG(ISVEC1)+I-1))THEN 74 - PRINT *,' !!!!!! MATIN1 WARNING : The ordinate'// 75 - - ' vector is not strictly ordered.' 76 - ISVEC1=-1 77 - ISVEC2=-1 78 - RETURN 79 - ENDIF 80 - 20 CONTINUE 81 - ELSE 82 - PRINT *,' !!!!!! MATIN1 WARNING : The ordinate'// 83 - - ' vector is not strictly ordered.' 84 - ISVEC1=-1 85 - ISVEC2=-1 86 - RETURN 87 - ENDIF 88 - ENDIF 89 - *** Carry out the interpolation. 90 - IF(N.LT.1)THEN 91 - PRINT *,' !!!!!! MATIN1 WARNING : Invalid number of'// 92 - - ' points received ; no interpolation.' 93 - RETURN 94 - ENDIF 0 95-+ +SELF,IF=-ESSL. 96 - DO 30 I=1,N 97 - * Avoid extrapolation. 98 - IF((MVEC(MORG(ISVEC1)+1)-X(I))* 99 - - (MVEC(MORG(ISVEC1)+MLEN(ISVEC1))-X(I)).GT.0)THEN 100 - Y(I)=0 101 - * Interpolation. 102 - ELSE 103 - Y(I)=DIVDIF(MVEC(MORG(ISVEC2)+1),MVEC(MORG(ISVEC1)+1), 104 - - MLEN(ISVEC1),X(I),MIN(IORD,MLEN(ISVEC1)-1)) 105 - ENDIF 106 - 30 CONTINUE 0 107-+ +SELF,IF=ESSL. 108 - * Check space. 109 - IF(NAUX.LT.MLEN(ISVEC1)+N)THEN 110 - PRINT *,' !!!!!! MATIN1 WARNING : Insufficient space'// 111 - - ' allocated for SPTINT; recompile.' 112 - RETURN 113 - ENDIF 114 - * Interpolation. 115 - CALL STPINT(MVEC(MORG(ISVEC1)+1),MVEC(MORG(ISVEC2)+1), 116 - - MLEN(ISVEC1),1+MIN(IORD,MLEN(ISVEC1)-1),X,Y,N,AUX,NAUX) 117 - * Avoid extrapolation. 118 - DO 40 I=1,N 119 - IF((MVEC(MORG(ISVEC1)+1)-X(I))* 120 - - (MVEC(MORG(ISVEC1)+MLEN(ISVEC1))-X(I)).GT.0)Y(I)=0 121 - 40 CONTINUE 0 122-+ +SELF. 123 - *** Seems to have worked. 124 - IFAIL=0 125 - END 412 GARFIELD ================================================== P=MATRIX D=MATINN 1 ============================ 0 + +DECK,MATINN. 1 - SUBROUTINE MATINN(IRMAT,IRORD,IRPNT,IROUT,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MATINN - Interpolates. 4 - * (Last changed on 11/ 4/96.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,MATDATA. 8.- +SEQ,PRINTPLOT. 9 - INTEGER IRMAT,IRORD,IRPNT,IROUT,IFAIL,ISMAT,ISORD,ISPNT,ISOUT,I, 10 - - LORD,ISIZ(MXMDIM),IA(MXMDIM),NPOINT,MATADR 11 - REAL FINT 12 - EXTERNAL FINT,MATADR 13 - *** Identify the routine. 14 - IF(LIDENT)PRINT *,' /// ROUTINE MATINN ///' 15 - *** Assume that the routine will fail. 16 - IFAIL=1 17 - *** Look up the matrices a first time. 18 - ISMAT=0 19 - ISORD=0 20 - ISPNT=0 21 - ISOUT=0 22 - * Scan the table. 23 - DO 10 I=1,MXMAT 24 - IF(MREF(I).EQ.IRMAT)THEN 25 - ISMAT=I 26 - ELSEIF(MREF(I).EQ.IRORD)THEN 27 - ISORD=I 28 - ELSEIF(MREF(I).EQ.IRPNT)THEN 29 - ISPNT=I 30 - ELSEIF(MREF(I).EQ.IROUT)THEN 31 - ISOUT=I 32 - ENDIF 33 - IF(ISMAT.GT.0.AND.ISORD.GT.0.AND. 34 - - ISPNT.GT.0.AND.ISOUT.GT.0)GOTO 20 35 - 10 CONTINUE 36 - * Don't insist on the presence of an output matrix. 37 - IF(ISMAT.GT.0.AND.ISORD.GT.0.AND.ISPNT.GT.0)GOTO 20 38 - * The others however should exist. 39 - PRINT *,' !!!!!! MATINN WARNING : Could not find one of the'// 1 412 P=MATRIX D=MATINN 2 PAGE 520 40 - - ' matrices; no interpolation.' 41 - RETURN 42 - 20 CONTINUE 43 - *** Interpolation routine FINT is limited to 5 dimensions. 44 - IF(MDIM(ISMAT).GT.5.OR.MDIM(ISMAT).LT.1)THEN 45 - PRINT *,' !!!!!! MATINN WARNING : Library interpolation'// 46 - - ' routine limited to 1-5 dimensions; nothing done.' 47 - RETURN 48 - ENDIF 49 - *** Verify the dimensions. 50 - LORD=0 51 - DO 30 I=1,MDIM(ISMAT) 52 - LORD=LORD+MSIZ(ISMAT,I) 53 - 30 CONTINUE 54 - IF(MDIM(ISMAT).NE.MSIZ(ISPNT,1).OR. 55 - - LORD.NE.MSIZ(ISORD,1).OR.MDIM(ISORD).NE.1.OR. 56 - - (MDIM(ISPNT).NE.1.AND.MDIM(ISPNT).NE.2))THEN 57 - PRINT *,' !!!!!! MATINN WARNING : Incompatible dimensions'// 58 - - ' of matrix, ordinates and coordinates.' 59 - RETURN 60 - ENDIF 61 - *** Take care of the output matrix. 62 - IF(ISOUT.NE.0)THEN 63 - ** Already exists, check whether the size and shape are OK. 64 - IF(MDIM(ISOUT).NE.1.OR. 65 - - MSIZ(ISOUT,1).LT.MSIZ(ISPNT,2))THEN 66 - * If not OK, re-shape the matrix. 67 - ISIZ(1)=MSIZ(ISPNT,2) 68 - CALL MATCHS(IROUT,1,ISIZ,0.0,IFAIL1) 69 - * Quit if re-shaping failed. 70 - IF(IFAIL1.NE.0)THEN 71 - PRINT *,' !!!!!! MATINN WARNING : Unable to'// 72 - - ' reshape output matrix; no interpolation.' 73 - RETURN 74 - ENDIF 75 - ENDIF 76 - ** Output matrix did not exist yet, create one. 77 - ELSE 78 - ISIZ(1)=MSIZ(ISPNT,2) 79 - CALL MATADM('ALLOCATE',IROUT,1,ISIZ,2,IFAIL1) 80 - * Quit if creating failed. 81 - IF(IFAIL1.NE.0)THEN 82 - PRINT *,' !!!!!! MATINN WARNING : Unable to'// 83 - - ' create an output matrix; no interpolation.' 84 - RETURN 85 - ENDIF 86 - ENDIF 87 - *** Look up the matrices a second time. 88 - ISMAT=0 89 - ISORD=0 90 - ISPNT=0 91 - ISOUT=0 92 - * Scan the table. 93 - DO 40 I=1,MXMAT 94 - IF(MREF(I).EQ.IRMAT)THEN 95 - ISMAT=I 96 - ELSEIF(MREF(I).EQ.IRORD)THEN 97 - ISORD=I 98 - ELSEIF(MREF(I).EQ.IRPNT)THEN 99 - ISPNT=I 100 - ELSEIF(MREF(I).EQ.IROUT)THEN 101 - ISOUT=I 102 - ENDIF 103 - IF(ISMAT.GT.0.AND.ISORD.GT.0.AND. 104 - - ISPNT.GT.0.AND.ISOUT.GT.0)GOTO 50 105 - 40 CONTINUE 106 - * Now insist on the presence of an output matrix. 107 - PRINT *,' !!!!!! MATINN WARNING : Could not find one of the'// 108 - - ' matrices; no interpolation.' 109 - RETURN 110 - 50 CONTINUE 111 - *** Carry out the actual interpolation, loop over the points. 112 - IF(MDIM(ISPNT).EQ.2)THEN 113 - NPOINT=MSIZ(ISPNT,2) 114 - ELSE 115 - NPOINT=1 116 - ENDIF 117 - * Make a vector of sizes. 118 - DO 110 I=1,MDIM(ISMAT) 119 - ISIZ(I)=MSIZ(ISMAT,I) 120 - 110 CONTINUE 121 - * Do the actual interpolations. 122 - DO 100 I=1,NPOINT 123 - IA(1)=1 124 - IA(2)=I 125 - MVEC(MORG(ISOUT)+I)=FINT(MDIM(ISMAT),MVEC(MATADR(ISPNT,IA)), 126 - - ISIZ,MVEC(MORG(ISORD)+1),MVEC(MORG(ISMAT)+1)) 127 - 100 CONTINUE 128 - *** Seems to have worked. 129 - IFAIL=0 130 - END 413 GARFIELD ================================================== P=MATRIX D=MATINT 1 ============================ 0 + +DECK,MATINT. 1 - SUBROUTINE MATINT 2 - *----------------------------------------------------------------------- 3 - * MATINT - Initialises the matrix system. 4 - * (Last changed on 23/10/95.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,MATDATA. 8.- +SEQ,PRINTPLOT. 9 - *** Identify the routine if requested. 10 - IF(LIDENT)PRINT *,' /// ROUTINE MATINT ///' 11 - *** Debugging information. 1 413 P=MATRIX D=MATINT 2 PAGE 521 12 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATINT DEBUG :'', 13 - - '' Initialising the matrix storage.''/ 14 - - 26X,''Maximum number of matrices: '',I5/ 15 - - 26X,''Maximum number of dimensions: '',I5/ 16 - - 26X,''Total storage area: '',I5)') 17 - - MXMAT,MXMDIM,MXEMAT 18 - *** Matrix reference information. 19 - DO 10 I=1,MXMAT 20 - MORG(I)=0 21 - MLEN(I)=0 22 - MREF(I)=0 23 - MMOD(I)=0 24 - DO 20 J=1,MXMDIM 25 - MSIZ(I,J)=0 26 - 20 CONTINUE 27 - MDIM(I)=0 28 - 10 CONTINUE 29 - MREF(MXMAT+1)=-1 30 - MORG(MXMAT+1)=MXEMAT 31 - MLEN(MXMAT+1)=0 32 - *** Matrix space. 33 - DO 30 I=1,MXEMAT 34 - MVEC(I)=0 35 - 30 CONTINUE 36 - *** Reference counter. 37 - NREFL=0 38 - END 414 GARFIELD ================================================== P=MATRIX D=MATLIN 1 ============================ 0 + +DECK,MATLIN. 1 - SUBROUTINE MATLIN(IREF1,IREF2,OPTION) 2 - *----------------------------------------------------------------------- 3 - * MATLIN - Plots a line. 4 - * (Last changed on 17/11/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9.- +SEQ,PRINTPLOT. 10 - INTEGER IREF1,IREF2,ISLOT1,ISLOT2,MATSLT 11 - EXTERNAL MATSLT 12 - CHARACTER*(*) OPTION 13 - *** Indentify the routine if requested. 14 - IF(LIDENT)PRINT *,' /// ROUTINE MATLIN ///' 15 - *** Debugging output. 16 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATLIN DEBUG : Plotting'', 17 - - '' line vectors '',2I5)') IREF1,IREF2 18 - *** Locate the 2 vectors. 19 - ISLOT1=MATSLT(IREF1) 20 - ISLOT2=MATSLT(IREF2) 21 - IF(ISLOT1.EQ.0.OR.ISLOT2.EQ.0)THEN 22 - PRINT *,' !!!!!! MATLIN WARNING : Matrix to be plotted'// 23 - - ' has not been found.' 24 - RETURN 25 - ENDIF 26 - *** Verify that the 2 have the same length. 27 - IF(MLEN(ISLOT1).NE.MLEN(ISLOT2))THEN 28 - PRINT *,' !!!!!! MATLIN WARNING : The 2 vectors do not'// 29 - - ' have the same length; not plotted.' 30 - RETURN 31 - ENDIF 32 - *** Verify that the length is at least 2. 33 - IF(MLEN(ISLOT1).LT.2.OR.MLEN(ISLOT2).LT.2)THEN 34 - PRINT *,' !!!!!! MATLIN WARNING : The vectors have a'// 35 - - ' length less than 2; not plotted.' 36 - RETURN 37 - ENDIF 38 - *** Plot the line. 39 - IF(INDEX(OPTION,'SMOOTH').NE.0.AND. 40 - - INDEX(OPTION,'NOSMOOTH').EQ.0)THEN 41 - CALL GRSPLN(MLEN(ISLOT1),MVEC(MORG(ISLOT1)+1), 42 - - MVEC(MORG(ISLOT2)+1)) 43 - ELSEIF(INDEX(OPTION,'GKS').NE.0)THEN 44 - CALL GPL(MLEN(ISLOT1),MVEC(MORG(ISLOT1)+1), 45 - - MVEC(MORG(ISLOT2)+1)) 46 - ELSE 47 - CALL GRLINE(MLEN(ISLOT1),MVEC(MORG(ISLOT1)+1), 48 - - MVEC(MORG(ISLOT2)+1)) 49 - ENDIF 50 - END 415 GARFIELD ================================================== P=MATRIX D=MATMRK 1 ============================ 0 + +DECK,MATMRK. 1 - SUBROUTINE MATMRK(IREF1,IREF2,OPTION) 2 - *----------------------------------------------------------------------- 3 - * MATMRK - Plots a set of markers. 4 - * (Last changed on 17/11/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9.- +SEQ,PRINTPLOT. 10 - INTEGER IREF1,IREF2,ISLOT1,ISLOT2,MATSLT 11 - EXTERNAL MATSLT 12 - CHARACTER*(*) OPTION 13 - *** Indentify the routine if requested. 14 - IF(LIDENT)PRINT *,' /// ROUTINE MATMRK ///' 15 - *** Debugging output. 16 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATMRK DEBUG : Plotting'', 17 - - '' marker vectors '',2I5)') IREF1,IREF2 18 - *** Locate the 2 vectors. 19 - ISLOT1=MATSLT(IREF1) 20 - ISLOT2=MATSLT(IREF2) 21 - IF(ISLOT1.EQ.0.OR.ISLOT2.EQ.0)THEN 1 415 P=MATRIX D=MATMRK 2 PAGE 522 22 - PRINT *,' !!!!!! MATMRK WARNING : Matrix to be plotted'// 23 - - ' has not been found.' 24 - RETURN 25 - ENDIF 26 - *** Verify that the 2 have the same length. 27 - IF(MLEN(ISLOT1).NE.MLEN(ISLOT2))THEN 28 - PRINT *,' !!!!!! MATMRK WARNING : The 2 vectors do not'// 29 - - ' have the same length; not plotted.' 30 - RETURN 31 - ENDIF 32 - *** Verify that the length is at least 1. 33 - IF(MLEN(ISLOT1).LT.1.OR.MLEN(ISLOT2).LT.1)THEN 34 - PRINT *,' !!!!!! MATMRK WARNING : The vectors have a'// 35 - - ' length less than 1; not plotted.' 36 - RETURN 37 - ENDIF 38 - *** Plot the markers. 39 - IF(OPTION.EQ.'GKS')THEN 40 - CALL GRMARK(MLEN(ISLOT1),MVEC(MORG(ISLOT1)+1), 41 - - MVEC(MORG(ISLOT2)+1)) 42 - ELSE 43 - CALL GRMARK(MLEN(ISLOT1),MVEC(MORG(ISLOT1)+1), 44 - - MVEC(MORG(ISLOT2)+1)) 45 - ENDIF 46 - END 416 GARFIELD ================================================== P=MATRIX D=MATPLN 1 ============================ 0 + +DECK,MATPLN. 1 - SUBROUTINE MATPLN(IREF1,IREF2,IREF3) 2 - *----------------------------------------------------------------------- 3 - * MATPLN - Plots a line. 4 - * (Last changed on 1/11/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9.- +SEQ,PRINTPLOT. 10 - INTEGER IREF1,IREF2,IREF3,ISLOT1,ISLOT2,ISLOT3,I,MATSLT 11 - DOUBLE PRECISION XPL(MXLIST),YPL(MXLIST),ZPL(MXLIST) 12 - EXTERNAL MATSLT 13 - *** Indentify the routine if requested. 14 - IF(LIDENT)PRINT *,' /// ROUTINE MATPLN ///' 15 - *** Debugging output. 16 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATPLN DEBUG : Plotting'', 17 - - '' line vectors '',3I5)') IREF1,IREF2,IREF3 18 - *** Locate the 3 vectors. 19 - ISLOT1=MATSLT(IREF1) 20 - ISLOT2=MATSLT(IREF2) 21 - ISLOT3=MATSLT(IREF3) 22 - IF(ISLOT1.EQ.0.OR.ISLOT2.EQ.0.OR.ISLOT3.EQ.0)THEN 23 - PRINT *,' !!!!!! MATPLN WARNING : One or more of the'// 24 - - ' plot vectors has not been found; not plotted.' 25 - RETURN 26 - ENDIF 27 - *** Verify that the 3 have the same length. 28 - IF(MLEN(ISLOT1).NE.MLEN(ISLOT2).OR. 29 - - MLEN(ISLOT2).NE.MLEN(ISLOT3))THEN 30 - PRINT *,' !!!!!! MATPLN WARNING : The 3 vectors do not'// 31 - - ' have the same length; not plotted.' 32 - RETURN 33 - ENDIF 34 - *** Verify that the length is in the range [2,MXLIST]. 35 - IF(MLEN(ISLOT1).LT.2.OR.MLEN(ISLOT1).GT.MXLIST)THEN 36 - PRINT *,' !!!!!! MATPLN WARNING : The length of the'// 37 - - ' vectors is not in the range [2,MXLIST]; not plotted.' 38 - RETURN 39 - ENDIF 40 - *** Make a double precision copy of the vector. 41 - DO 10 I=1,MLEN(ISLOT1) 42 - XPL(I)=DBLE(MVEC(MORG(ISLOT1)+I)) 43 - YPL(I)=DBLE(MVEC(MORG(ISLOT2)+I)) 44 - ZPL(I)=DBLE(MVEC(MORG(ISLOT3)+I)) 45 - 10 CONTINUE 46 - *** Plot the line. 47 - CALL PLAGPL(MLEN(ISLOT1),XPL,YPL,ZPL) 48 - END 417 GARFIELD ================================================== P=MATRIX D=MATPMK 1 ============================ 0 + +DECK,MATPMK. 1 - SUBROUTINE MATPMK(IREF1,IREF2,IREF3) 2 - *----------------------------------------------------------------------- 3 - * MATPMK - Plots a set of markers. 4 - * (Last changed on 14/12/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9.- +SEQ,PRINTPLOT. 10 - INTEGER IREF1,IREF2,IREF3,ISLOT1,ISLOT2,ISLOT3,I,MATSLT 11 - DOUBLE PRECISION XPL(MXLIST),YPL(MXLIST),ZPL(MXLIST) 12 - EXTERNAL MATSLT 13 - *** Indentify the routine if requested. 14 - IF(LIDENT)PRINT *,' /// ROUTINE MATPMK ///' 15 - *** Debugging output. 16 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATPMK DEBUG : Plotting'', 17 - - '' marker vectors '',3I5)') IREF1,IREF2,IREF3 18 - *** Locate the 3 vectors. 19 - ISLOT1=MATSLT(IREF1) 20 - ISLOT2=MATSLT(IREF2) 21 - ISLOT3=MATSLT(IREF3) 22 - IF(ISLOT1.EQ.0.OR.ISLOT2.EQ.0.OR.ISLOT3.EQ.0)THEN 23 - PRINT *,' !!!!!! MATPMK WARNING : One or more of the'// 24 - - ' plot vectors has not been found; not plotted.' 25 - RETURN 1 417 P=MATRIX D=MATPMK 2 PAGE 523 26 - ENDIF 27 - *** Verify that the 3 have the same length. 28 - IF(MLEN(ISLOT1).NE.MLEN(ISLOT2).OR. 29 - - MLEN(ISLOT2).NE.MLEN(ISLOT3))THEN 30 - PRINT *,' !!!!!! MATPMK WARNING : The 3 vectors do not'// 31 - - ' have the same length; not plotted.' 32 - RETURN 33 - ENDIF 34 - *** Verify that the length is in the range [1,MXLIST]. 35 - IF(MLEN(ISLOT1).LT.1.OR.MLEN(ISLOT1).GT.MXLIST)THEN 36 - PRINT *,' !!!!!! MATPMK WARNING : The length of the'// 37 - - ' vectors is not in the range [1,MXLIST]; not plotted.' 38 - RETURN 39 - ENDIF 40 - *** Make a double precision copy of the vector. 41 - DO 10 I=1,MLEN(ISLOT1) 42 - XPL(I)=DBLE(MVEC(MORG(ISLOT1)+I)) 43 - YPL(I)=DBLE(MVEC(MORG(ISLOT2)+I)) 44 - ZPL(I)=DBLE(MVEC(MORG(ISLOT3)+I)) 45 - 10 CONTINUE 46 - *** Plot the markers. 47 - CALL PLAGPM(MLEN(ISLOT1),XPL,YPL,ZPL) 48 - END 418 GARFIELD ================================================== P=MATRIX D=MATPRT 1 ============================ 0 + +DECK,MATPRT. 1 - SUBROUTINE MATPRT(IREF) 2 - *----------------------------------------------------------------------- 3 - * MATPRT - Prints a matrix. 4 - * (Last changed on 25/10/95.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,MATDATA. 8.- +SEQ,PRINTPLOT. 9 - INTEGER IREF,ISLOT,IA(MXMDIM),MATADR 10 - REAL AUX 11 - CHARACTER*78 STRING 12 - CHARACTER*20 STRAUX 13 - EXTERNAL MATADR 14 - *** Check validity of reference. 15 - IF(IREF.LE.0)THEN 16 - PRINT *,' !!!!!! MATPRT WARNING : Non-positive reference'// 17 - - ' given; matrix not printed.' 18 - RETURN 19 - ENDIF 20 - *** Locate the current matrix. 21 - DO 10 I=1,MXMAT 22 - IF(MREF(I).EQ.IREF)THEN 23 - ISLOT=I 24 - GOTO 20 25 - ENDIF 26 - 10 CONTINUE 27 - PRINT *,' !!!!!! MATPRT WARNING : Matrix to be printed has'// 28 - - ' not been found.' 29 - RETURN 30 - 20 CONTINUE 31 - *** Special case: null matrices. 32 - IF(MDIM(ISLOT).LT.1)THEN 33 - WRITE(LUNOUT,'('' (Null matrix)''/)') 34 - *** Special case: the 1-dimensional matrix. 35 - ELSEIF(MDIM(ISLOT).EQ.1)THEN 36 - NC=0 37 - STRING=' ' 38 - DO 130 I=1,MSIZ(ISLOT,1) 39 - CALL OUTFMT(MVEC(MORG(ISLOT)+I),MMOD(ISLOT), 40 - - STRAUX,NCAUX,'LEFT') 41 - IF(NC+NCAUX+1.GT.LEN(STRING))THEN 42 - IF(NC.GE.1)WRITE(LUNOUT,'(2X,A)') STRING(1:NC) 43 - STRING(1:5)=' ' 44 - NC=5 45 - ENDIF 46 - STRING(NC+1:NC+NCAUX+1)=STRAUX(1:NCAUX)//' ' 47 - NC=NC+NCAUX+1 48 - 130 CONTINUE 49 - WRITE(LUNOUT,'(2X,A/)') STRING(1:NC) 50 - *** Print larger matrices. 51 - ELSE 52 - * First establish an initial address vector. 53 - DO 30 I=1,MDIM(ISLOT) 54 - IA(I)=1 55 - 30 CONTINUE 56 - * Return here to print a further layer of the matrix. 57 - 120 CONTINUE 58 - * Print a header for the matrix of the last 2 dimensions. 59 - IF(MDIM(ISLOT).GT.2)THEN 60 - STRING(1:1)='[' 61 - NC=1 62 - DO 40 I=1,MDIM(ISLOT)-2 63 - AUX=REAL(IA(I)) 64 - CALL OUTFMT(AUX,2,STRAUX,NCAUX,'LEFT') 65 - STRING(NC+1:NC+NCAUX)=STRAUX(1:NCAUX) 66 - IF(NC+NCAUX+4.GT.LEN(STRING))THEN 67 - STRING(LEN(STRING)-7:LEN(STRING))=' ... ;;]' 68 - NC=LEN(STRING) 69 - GOTO 50 70 - ENDIF 71 - NC=NC+NCAUX 72 - IF(I.LT.MDIM(ISLOT)-2)THEN 73 - STRING(NC+1:NC+1)=';' 74 - NC=NC+1 75 - ENDIF 76 - 40 CONTINUE 77 - STRING(NC+1:NC+3)=';;]' 78 - NC=NC+3 79 - 50 CONTINUE 1 418 P=MATRIX D=MATPRT 2 PAGE 524 80 - WRITE(LUNOUT,'(2X,A)') STRING(1:NC) 81 - ENDIF 82 - * Print the matrix for the last 2 dimensions, find longest element. 83 - MAXLEN=0 84 - DO 60 I=1,MSIZ(ISLOT,MDIM(ISLOT)-1) 85 - DO 70 J=1,MSIZ(ISLOT,MDIM(ISLOT)) 86 - IA(MDIM(ISLOT)-1)=I 87 - IA(MDIM(ISLOT))=J 88 - IADDR=MATADR(ISLOT,IA) 89 - CALL OUTFMT(MVEC(IADDR),MMOD(ISLOT),STRAUX,NCAUX,'LEFT') 90 - MAXLEN=MAX(MAXLEN,NCAUX) 91 - 70 CONTINUE 92 - 60 CONTINUE 93 - * And now print the matrix itself. 94 - DO 80 I=1,MSIZ(ISLOT,MDIM(ISLOT)) 95 - NC=0 96 - STRING=' ' 97 - DO 90 J=1,MSIZ(ISLOT,MDIM(ISLOT)-1) 98 - IA(MDIM(ISLOT))=I 99 - IA(MDIM(ISLOT)-1)=J 100 - IADDR=MATADR(ISLOT,IA) 101 - CALL OUTFMT(MVEC(IADDR),MMOD(ISLOT),STRAUX,NCAUX,'RIGHT') 102 - IF(NC+MAXLEN+1.GT.LEN(STRING))THEN 103 - WRITE(LUNOUT,'(2X,A)') STRING(1:NC) 104 - STRING(1:MAXLEN+1)=' ' 105 - NC=MAXLEN+1 106 - ENDIF 107 - STRING(NC+1:NC+MAXLEN+1)=STRAUX(LEN(STRAUX)-MAXLEN+1:)//' ' 108 - NC=NC+MAXLEN+1 109 - 90 CONTINUE 110 - WRITE(LUNOUT,'(2X,A)') STRING(1:NC) 111 - 80 CONTINUE 112 - WRITE(LUNOUT,'('' '')') 113 - * Increment the address vector. 114 - DO 100 I=1,MDIM(ISLOT)-2 115 - IF(IA(I).LT.MSIZ(ISLOT,I))THEN 116 - IA(I)=IA(I)+1 117 - DO 110 J=1,I-1 118 - IA(J)=1 119 - 110 CONTINUE 120 - GOTO 120 121 - ENDIF 122 - 100 CONTINUE 123 - ENDIF 124 - END 419 GARFIELD ================================================== P=MATRIX D=MATSLT 1 ============================ 0 + +DECK,MATSLT. 1 - INTEGER FUNCTION MATSLT(IREF) 2 - *----------------------------------------------------------------------- 3 - * MATSLT - Finds the slot number for a matrix. 4 - * Variables: IREF - Matrix to be located. 5 - * (Last changed on 12/ 4/96.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9 - INTEGER IREF,I 10 - *** Return with 0 if out of range. 11 - IF(IREF.LE.0)THEN 12 - MATSLT=0 13 - RETURN 14 - ENDIF 15 - *** Scan the list of matrices. 16 - DO 10 I=1,MXMAT 17 - IF(MREF(I).EQ.IREF)THEN 18 - MATSLT=I 19 - RETURN 20 - ENDIF 21 - 10 CONTINUE 22 - *** Return 0 if not found. 23 - MATSLT=0 24 - END 420 GARFIELD ================================================== P=MATRIX D=MATSAV 1 ============================ 0 + +DECK,MATSAV. 1 - SUBROUTINE MATSAV(VAL,NDIM,IDIM,ISIZ,NAME,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MATSAV - Assigns a matrix to a global variable. 4 - * (Last changed on 26/ 6/96.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,MATDATA. 8.- +SEQ,GLOBALS. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*(*) NAME 11 - REAL VAL(*) 12 - INTEGER IFAIL,JVAR,I,NDIM,ISIZ(*),IDIM(*),MATSLT,MATADR, 13 - - IA(MXMDIM),IADDR,JADDR 14 - EXTERNAL MATSLT,MATADR 15 - *** Tracing and debugging output. 16 - IF(LIDENT)PRINT *,' /// ROUTINE MATSAV ///' 17 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATSAV DEBUG : Storing '', 18 - - I3,''-matrix to '',A,''.'')') NDIM,NAME 19 - *** Initial failure flag setting. 20 - IFAIL=1 21 - *** Make sure that the number of dimensions is reasonable. 22 - IF(NDIM.GT.MXMDIM.OR.NDIM.LT.1)THEN 23 - PRINT *,' !!!!!! MATSAV WARNING : Number of dimensions'// 24 - - ' not in the range [1,MXMDIM]; not stored.' 25 - RETURN 26 - ENDIF 27 - *** Scan the list of global variables. 28 - JVAR=0 29 - DO 100 I=1,NGLB 1 420 P=MATRIX D=MATSAV 2 PAGE 525 30 - IF(GLBVAR(I).EQ.NAME)JVAR=I 31 - 100 CONTINUE 32 - *** If it didn't exist, create a new global ... 33 - IF(JVAR.EQ.0)THEN 34 - * if there still is space, 35 - IF(NGLB.LT.MXVAR)THEN 36 - NGLB=NGLB+1 37 - GLBVAR(NGLB)=NAME 38 - JVAR=NGLB 39 - * otherwise issue a warning. 40 - ELSE 41 - PRINT *,' !!!!!! MATSAV WARNING : No global variable'// 42 - - ' space left for ',NAME,'; matrix not saved.' 43 - RETURN 44 - ENDIF 45 - *** Otherwise re-use an existing global. 46 - ELSE 47 - CALL ALGREU(NINT(GLBVAL(JVAR)),GLBMOD(JVAR),0) 48 - ENDIF 49 - *** Allocate a matrix. 50 - CALL MATADM('ALLOCATE',IRMAT,NDIM,ISIZ,2,IFAIL1) 51 - * Check error condition. 52 - IF(IFAIL1.NE.0)THEN 53 - PRINT *,' !!!!!! MATSAV WARNING : Unable to allocate'// 54 - - ' space for ',NAME,'; matrix not saved.' 55 - RETURN 56 - ENDIF 57 - * Find location. 58 - ISMAT=MATSLT(IRMAT) 59 - IF(ISMAT.LE.0)THEN 60 - PRINT *,' !!!!!! MATSAV WARNING : Failure to locate'// 61 - - ' the receiving matrix; matrix not stored.' 62 - RETURN 63 - ENDIF 64 - *** Copy the array to the matrix, initial address vector. 65 - DO 10 I=1,NDIM 66 - IF(ISIZ(I).LE.0)THEN 67 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATSAV DEBUG :'', 68 - - '' Dimension '',I2,'' has length < 1.'')') I 69 - RETURN 70 - ENDIF 71 - IA(I)=1 72 - 10 CONTINUE 73 - 20 CONTINUE 74 - * Compute matrix address. 75 - IADDR=MATADR(ISMAT,IA) 76 - * Compute Fortran address. 77 - JADDR=IA(NDIM)-1 78 - DO 30 I=NDIM-1,1,-1 79 - JADDR=JADDR*IDIM(I)+IA(I)-1 80 - 30 CONTINUE 81 - JADDR=JADDR+1 82 - * Copy. 83 - MVEC(IADDR)=VAL(JADDR) 84 - * Update address pointer. 85 - DO 40 I=1,NDIM 86 - IF(IA(I).LT.ISIZ(I))THEN 87 - IA(I)=IA(I)+1 88 - DO 50 J=1,I-1 89 - IA(J)=1 90 - 50 CONTINUE 91 - GOTO 20 92 - ENDIF 93 - 40 CONTINUE 94 - *** Assign the number to the global. 95 - GLBVAL(JVAR)=REAL(IRMAT) 96 - GLBMOD(JVAR)=5 97 - *** Things seem to have worked. 98 - IFAIL=0 99 - END 421 GARFIELD ================================================== P=MATRIX D=MT2SAV 1 ============================ 0 + +DECK,MT2SAV. 1 - SUBROUTINE MT2SAV(VAL,NDIM,IDIM,ISIZ,NAME,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MT2SAV - Assigns a double precision matrix to a global variable. 4 - * (Last changed on 26/ 6/96.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,MATDATA. 8.- +SEQ,GLOBALS. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*(*) NAME 11 - DOUBLE PRECISION VAL(*) 12 - INTEGER IFAIL,JVAR,I,NDIM,ISIZ(*),IDIM(*),MATSLT,MATADR, 13 - - IA(MXMDIM),IADDR,JADDR 14 - EXTERNAL MATSLT,MATADR 15 - *** Tracing and debugging output. 16 - IF(LIDENT)PRINT *,' /// ROUTINE MT2SAV ///' 17 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MT2SAV DEBUG : Storing '', 18 - - I3,''-matrix to '',A,''.'')') NDIM,NAME 19 - *** Initial failure flag setting. 20 - IFAIL=1 21 - *** Make sure that the number of dimensions is reasonable. 22 - IF(NDIM.GT.MXMDIM.OR.NDIM.LT.1)THEN 23 - PRINT *,' !!!!!! MT2SAV WARNING : Number of dimensions'// 24 - - ' not in the range [1,MXMDIM]; not stored.' 25 - RETURN 26 - ENDIF 27 - *** Scan the list of global variables. 28 - JVAR=0 29 - DO 100 I=1,NGLB 30 - IF(GLBVAR(I).EQ.NAME)JVAR=I 31 - 100 CONTINUE 32 - *** If it didn't exist, create a new global ... 1 421 P=MATRIX D=MT2SAV 2 PAGE 526 33 - IF(JVAR.EQ.0)THEN 34 - * if there still is space, 35 - IF(NGLB.LT.MXVAR)THEN 36 - NGLB=NGLB+1 37 - GLBVAR(NGLB)=NAME 38 - JVAR=NGLB 39 - * otherwise issue a warning. 40 - ELSE 41 - PRINT *,' !!!!!! MT2SAV WARNING : No global variable'// 42 - - ' space left for ',NAME,'; matrix not saved.' 43 - RETURN 44 - ENDIF 45 - *** Otherwise re-use an existing global. 46 - ELSE 47 - CALL ALGREU(NINT(GLBVAL(JVAR)),GLBMOD(JVAR),0) 48 - ENDIF 49 - *** Allocate a matrix. 50 - CALL MATADM('ALLOCATE',IRMAT,NDIM,ISIZ,2,IFAIL1) 51 - * Check error condition. 52 - IF(IFAIL1.NE.0)THEN 53 - PRINT *,' !!!!!! MT2SAV WARNING : Unable to allocate'// 54 - - ' space for ',NAME,'; matrix not saved.' 55 - RETURN 56 - ENDIF 57 - * Find location. 58 - ISMAT=MATSLT(IRMAT) 59 - IF(ISMAT.LE.0)THEN 60 - PRINT *,' !!!!!! MT2SAV WARNING : Failure to locate'// 61 - - ' the receiving matrix; matrix not stored.' 62 - RETURN 63 - ENDIF 64 - *** Copy the array to the matrix, initial address vector. 65 - DO 10 I=1,NDIM 66 - IF(ISIZ(I).LE.0)THEN 67 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MT2SAV DEBUG :'', 68 - - '' Dimension '',I2,'' has length < 1.'')') I 69 - RETURN 70 - ENDIF 71 - IA(I)=1 72 - 10 CONTINUE 73 - 20 CONTINUE 74 - * Compute matrix address. 75 - IADDR=MATADR(ISMAT,IA) 76 - * Compute Fortran address. 77 - JADDR=IA(NDIM)-1 78 - DO 30 I=NDIM-1,1,-1 79 - JADDR=JADDR*IDIM(I)+IA(I)-1 80 - 30 CONTINUE 81 - JADDR=JADDR+1 82 - * Copy. 83 - MVEC(IADDR)=REAL(VAL(JADDR)) 84 - * Update address pointer. 85 - DO 40 I=1,NDIM 86 - IF(IA(I).LT.ISIZ(I))THEN 87 - IA(I)=IA(I)+1 88 - DO 50 J=1,I-1 89 - IA(J)=1 90 - 50 CONTINUE 91 - GOTO 20 92 - ENDIF 93 - 40 CONTINUE 94 - *** Assign the number to the global. 95 - GLBVAL(JVAR)=REAL(IRMAT) 96 - GLBMOD(JVAR)=5 97 - *** Things seem to have worked. 98 - IFAIL=0 99 - END 422 GARFIELD ================================================== P=MATRIX D=MATSUB 1 ============================ 0 + +DECK,MATSUB. 1 - SUBROUTINE MATSUB(ACTION,ISEL,IRSUB,IRMAT,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MATSUB - Stores in or extracts from a sub-matrix. 4 - * Variables: ACTION - Either STORE to save the matrix IRMAT in a 5 - * IRMAT submatrix of IRSUB, or EXTRACT to save a 6 - * IRSUB submatrix of IRSUB in matrix IRMAT. 7 - * ISEL - Sub matrix selection (#dim, #sel in dim1, 8 - * #sel in dim2 ..., sel dim1, sel dim2, ... 9 - * (Last changed on 12/ 4/96.) 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,MATDATA. 13.- +SEQ,PRINTPLOT. 14 - INTEGER IRSUB,IRMAT,ISSUB,ISMAT,ISEL(*),IA(MXMDIM),MATADR,ILEN, 15 - - ISIZ(MXMDIM),IOFF(MXMDIM),IASUB(MXMDIM),IADDR,MATSLT 16 - CHARACTER*(*) ACTION 17 - EXTERNAL MATADR,MATSLT 18 - *** Identify the routine. 19 - IF(LIDENT)PRINT *,' /// ROUTINE MATSUB ///' 20 - *** Assume this will fail. 21 - IFAIL=1 22 - *** Check the ACTION flag. 23 - IF(ACTION.NE.'STORE'.AND.ACTION.NE.'EXTRACT')THEN 24 - PRINT *,' !!!!!! MATSUB WARNING : Unknown action'// 25 - - ' received; nothing done.' 26 - RETURN 27 - ENDIF 28 - *** Locate the matrix of which a sub-matrix is to be formed. 29 - ISSUB=MATSLT(IRSUB) 30 - IF(ISSUB.LE.0)THEN 31 - PRINT *,' !!!!!! MATSUB WARNING : Indexed matrix not found.' 32 - RETURN 33 - ENDIF 34 - *** Check that the number of dimensions matches the selection vector. 35 - IF(MDIM(ISSUB).NE.ISEL(1).OR.ISEL(1).LE.0)THEN 1 422 P=MATRIX D=MATSUB 2 PAGE 527 36 - PRINT *,' !!!!!! MATSUB WARNING : Matrix dimension and'// 37 - - ' indexing do not match.' 38 - RETURN 39 - ENDIF 40 - *** Prepare sub-matrix addressing vectors, check the dimensions. 41 - DO 90 I=1,ISEL(1) 42 - ISIZ(I)=ISEL(I+1) 43 - IF(ISIZ(I).EQ.0)ISIZ(I)=MSIZ(ISSUB,I) 44 - IF(I.EQ.1)THEN 45 - IOFF(I)=ISEL(1)+1 46 - ELSE 47 - IOFF(I)=IOFF(I-1)+ISEL(I) 48 - ENDIF 49 - DO 100 J=IOFF(I)+1,IOFF(I)+ISEL(I+1) 50 - IF(ISEL(J).LT.1.OR.ISEL(J).GT.MSIZ(ISSUB,I))THEN 51 - PRINT *,' !!!!!! MATSUB WARNING : Indexing out of bounds'// 52 - - ' of the matrix; no sub-matrix.' 53 - RETURN 54 - ENDIF 55 - 100 CONTINUE 56 - 90 CONTINUE 57 - *** Locate the input matrix when STORE'ing. 58 - IF(ACTION.EQ.'STORE')THEN 59 - * Find the matrix. 60 - ISMAT=MATSLT(IRMAT) 61 - IF(ISMAT.LE.0)THEN 62 - PRINT *,' !!!!!! MATSUB WARNING : Input matrix has'// 63 - - ' not been found.' 64 - RETURN 65 - ENDIF 66 - * See whether the size is the same as that of the sub-matrix. 67 - ILEN=1 68 - DO 50 I=1,ISEL(1) 69 - ILEN=ILEN*ISIZ(I) 70 - 50 CONTINUE 71 - IF(MLEN(ISMAT).NE.1.AND.ILEN.NE.MLEN(ISMAT))THEN 72 - PRINT *,' !!!!!! MATSUB WARNING : Mismatch in matrix'// 73 - - ' sizes; matrix not assigned.' 74 - RETURN 75 - ENDIF 76 - *** Or allocate a matrix when EXTRACT'ing. 77 - ELSE 78 - * Set the mode for the new matrix. 79 - IMOD=MMOD(ISSUB) 80 - * Allocate. 81 - CALL MATADM('ALLOCATE',IRMAT,ISEL(1),ISIZ,IMOD,IFAIL1) 82 - IF(IFAIL1.NE.0)THEN 83 - PRINT *,' !!!!!! MATSUB WARNING : Unable to allocate'// 84 - - ' space for the sub-matrix; not extracted.' 85 - RETURN 86 - ENDIF 87 - * Find where the new matrix sits. 88 - ISMAT=MATSLT(IRMAT) 89 - IF(ISMAT.LE.0)THEN 90 - PRINT *,' !!!!!! MATSUB WARNING : New matrix not'// 91 - - ' found; program bug - please report.' 92 - RETURN 93 - ENDIF 94 - ENDIF 95 - *** Re-locate the matrix of which a sub-matrix is to be formed. 96 - ISSUB=MATSLT(IRSUB) 97 - IF(ISSUB.LE.0)THEN 98 - PRINT *,' !!!!!! MATSUB WARNING : Indexed matrix not found.' 99 - RETURN 100 - ENDIF 101 - *** Loop over the sub matrix, initial address vector. 102 - DO 200 I=1,MDIM(ISSUB) 103 - IA(I)=1 104 - 200 CONTINUE 105 - * Initial pointer in the matrix vector. 106 - IELEM=MORG(ISMAT) 107 - * Return here for the next element. 108 - 210 CONTINUE 109 - IF(MLEN(ISMAT).EQ.1)THEN 110 - IELEM=MORG(ISMAT)+1 111 - ELSE 112 - IELEM=IELEM+1 113 - ENDIF 114 - * Convert the address in a true sub-matrix address. 115 - DO 240 I=1,MDIM(ISSUB) 116 - IF(ISEL(I+1).EQ.0)THEN 117 - IASUB(I)=IA(I) 118 - ELSE 119 - IASUB(I)=ISEL(IOFF(I)+IA(I)) 120 - ENDIF 121 - 240 CONTINUE 122 - * Carry out the assignments. 123 - IADDR=MATADR(ISSUB,IASUB) 124 - IF(ACTION.EQ.'STORE')THEN 125 - MVEC(IADDR)=MVEC(IELEM) 126 - ELSE 127 - MVEC(IELEM)=MVEC(IADDR) 128 - ENDIF 129 - * Increment the address vector. 130 - DO 220 I=1,MDIM(ISSUB) 131 - IF(IA(I).LT.ISIZ(I))THEN 132 - IA(I)=IA(I)+1 133 - DO 230 J=1,I-1 134 - IA(J)=1 135 - 230 CONTINUE 136 - GOTO 210 137 - ENDIF 138 - 220 CONTINUE 139 - *** Seems to have worked. 140 - IFAIL=0 141 - END 1 423 GARFIELD ================================================== P=MATRIX D=MATSUR 1 =================== PAGE 528 0 + +DECK,MATSUR. 1 - SUBROUTINE MATSUR(IREFM,IREFX,IREFY,XTXT,YTXT,TITLE,PHI,THETA) 2 - *----------------------------------------------------------------------- 3 - * MATSUR - Plots a surface for a matrix. 4 - * (Last changed on 19/ 8/99.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,MATDATA. 8.- +SEQ,PRINTPLOT. 9 - INTEGER MATSLT,MATADR,IA(MXMDIM),NX,NY, 10 - - ISLOTX,ISLOTY,ISLOTM,IREFX,IREFY,IREFM 11 - REAL PHI,THETA,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX 12 - CHARACTER*(*) XTXT,YTXT,TITLE 13 - EXTERNAL MATSLT,MATADR 0 14-+ +SELF,IF=NAG. 15 - DOUBLE PRECISION WS,CHTS 16 - PARAMETER(MXWS=MXWIRE**2+3*MXWIRE+3) 17 - COMMON /MATRIX/ WS(MXWS),CHTS(MXWIRE) 0 18-+ +SELF,IF=HIGZ. 19 - REAL WS,PAR 20 - PARAMETER(MXWS=2*MXWIRE**2+8*MXWIRE-31) 21 - COMMON /MATRIX/ WS(MXWS),PAR(37) 0 22-+ +SELF. 23 - *** Identify the routine if requested. 24 - IF(LIDENT)PRINT *,' /// ROUTINE MATSUR ///' 25 - *** Debugging output. 26 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATSUR DEBUG : Plotting'', 27 - - '' matrix '',I5,'' axes '',2I5/ 28 - - 26X,''Viewing angles: '',2F10.2,'' degrees''/ 29 - - 26X,''x-Axis label: '',A/26X,''y-Axis label: '',A/ 30 - - 26X,''Title: '',A)') 31 - - IREFM,IREFX,IREFY,PHI,THETA,XTXT,YTXT,TITLE 0 32-+ +SELF,IF=-NAG,IF=-HIGZ. 33 - *** This routine needs either NAG or HIGZ. 34 - PRINT *,' ------ MATSUR MESSAGE : No graphics package capable'// 35 - - ' of plotting has been linked; no surface plot.' 36 - RETURN 0 37-+ +SELF. 38 - *** Locate the matrix. 39 - ISLOTM=MATSLT(IREFM) 40 - IF(ISLOTM.LE.0)THEN 41 - PRINT *,' !!!!!! MATSUR WARNING : Matrix to be plotted'// 42 - - ' does not exist; not plotted.' 43 - RETURN 44 - ENDIF 45 - NX=MSIZ(ISLOTM,1) 46 - NY=MSIZ(ISLOTM,2) 47 - *** See whether the coordinates are present. 48 - ISLOTX=MATSLT(IREFX) 49 - IF(ISLOTX.GT.0)THEN 50 - IF(MDIM(ISLOTX).EQ.1.AND.MSIZ(ISLOTX,1).EQ.NX)THEN 51 - XMIN=MVEC(MORG(ISLOTX)+1) 52 - XMAX=MVEC(MORG(ISLOTX)+MLEN(ISLOTX)) 53 - ELSE 54 - PRINT *,' !!!!!! MATSUR WARNING : x-Coordinate'// 55 - - ' vector does not have the right format.' 56 - XMIN=0 57 - XMAX=1 58 - ENDIF 59 - ELSE 60 - PRINT *,' ------ MATSUR MESSAGE : x-Range of plot not'// 61 - - ' given; set to [0,1].' 62 - XMIN=0 63 - XMAX=1 64 - ENDIF 65 - ISLOTY=MATSLT(IREFY) 66 - IF(ISLOTY.GT.0)THEN 67 - IF(MDIM(ISLOTY).EQ.1.AND.MSIZ(ISLOTY,1).EQ.NY)THEN 68 - YMIN=MVEC(MORG(ISLOTY)+1) 69 - YMAX=MVEC(MORG(ISLOTY)+MLEN(ISLOTY)) 70 - ELSE 71 - PRINT *,' !!!!!! MATSUR WARNING : y-Coordinate'// 72 - - ' vector does not have the right format.' 73 - YMIN=0 74 - YMAX=1 75 - ENDIF 76 - ELSE 77 - PRINT *,' ------ MATSUR MESSAGE : y-Range of plot not'// 78 - - ' given; set to [0,1].' 79 - YMIN=0 80 - YMAX=1 81 - ENDIF 82 - *** Make sure that this matrix has the right dimensions. 83 - IF(MDIM(ISLOTM).NE.2.OR. 84 - - NX.LT.2.OR.NY.LT.2.OR. 85 - - NX*NY.GT.MXWS)THEN 86 - PRINT *,' !!!!!! MATSUR WARNING : The matrix to be'// 87 - - ' plotted doesn''t have the right dimensions.' 88 - RETURN 89 - ENDIF 0 90-+ +SELF,IF=NAG,HIGZ. 91 - *** Obtain the matrix for surface plotting. 92 - CALL BOOK('BOOK','MATRIX','MATSURF',IFAIL) 93 - IF(IFAIL.NE.0)THEN 94 - PRINT *,' !!!!!! MATSUR WARNING : Unable to obtain'// 95 - - ' storage for the surface plot; plot not made.' 96 - RETURN 97 - ENDIF 98 - *** Transfer the matrix to the fixed arrays, establish range. 99 - IELEM=0 1 423 P=MATRIX D=MATSUR 2 PAGE 529 100 - DO 10 IY=1,NY 101 - DO 20 IX=1,NX 102 - IA(1)=IX 103 - IA(2)=IY 104 - IELEM=IELEM+1 105 - WS(IELEM)=MVEC(MATADR(ISLOTM,IA)) 106 - IF(IELEM.EQ.1)THEN 107 - ZMIN=WS(IELEM) 108 - ZMAX=WS(IELEM) 109 - ELSE 110 - IF(ZMIN.GT.WS(IELEM))ZMIN=WS(IELEM) 111 - IF(ZMAX.LT.WS(IELEM))ZMAX=WS(IELEM) 112 - ENDIF 113 - 20 CONTINUE 114 - 10 CONTINUE 115 - *** Make the plot, go to to graphics mode. 116 - CALL GRGRAF(.TRUE.) 0 117-+ +SELF,IF=NAG. 118 - * Store the CH eXPansion, NAG has the nasty habit of changing it. 119 - CALL GQCHXP(IERR,CHEXP) 120 - IF(IERR.NE.0)CHEXP=1.0 121 - * Initialize NAG. 122 - CALL X04AAF(1,10) 123 - CALL J06WAF 124 - CALL J06WCF(0.1D0,0.9D0,0.1D0,0.9D0) 125 - CALL J06WBF(0.0D0,1.0D0,0.0D0,1.0D0,1) 126 - IFAIL=0 127 - CALL J06HCF(WS,NX,NX,NY,DBLE(THETA), 128 - - DBLE(PHI),XTXT,YTXT,IFAIL) 129 - * Reset the CH eXPension factor to the original value, 130 - CALL GSCHXP(CHEXP) 0 131-+ +SELF,IF=HIGZ. 132 - * Fill the PAR vector. 133 - PAR(1)=THETA 134 - PAR(2)=PHI 135 - PAR(3)=XMIN-0.5*(XMAX-XMIN)/REAL(NX-1) 136 - PAR(4)=XMAX+0.5*(XMAX-XMIN)/REAL(NX-1) 137 - PAR(5)=YMIN-0.5*(YMAX-YMIN)/REAL(NY-1) 138 - PAR(6)=YMAX+0.5*(YMAX-YMIN)/REAL(NY-1) 139 - PAR(7)=ZMIN 140 - PAR(8)=ZMAX 141 - PAR(9)=0 142 - PAR(10)=0 143 - PAR(11)=510 144 - PAR(12)=510 145 - PAR(13)=510 146 - PAR(14)=1 147 - PAR(15)=1 148 - PAR(16)=1 149 - PAR(17)=0.02 150 - PAR(18)=0.02 151 - PAR(19)=0.02 152 - PAR(20)=0.03 153 - PAR(21)=2 154 - PAR(22)=0.03 155 - PAR(23)=0.03 156 - PAR(24)=0.03 157 - PAR(25)=7 158 - PAR(26)=8 159 - PAR(27)=9 160 - PAR(28)=10 161 - PAR(29)=11 162 - PAR(30)=12 163 - PAR(31)=13 164 - PAR(32)=14 165 - PAR(33)=15 166 - PAR(34)=16 167 - PAR(35)=17 168 - PAR(36)=18 169 - PAR(37)=19 170 - * Plot the surface. 171 - CALL ISVP(1,0.1,0.9,0.1,0.9) 172 - CALL ISWN(1,0.0,1.0,0.0,1.0) 173 - CALL ISELNT(1) 174 - CALL IGTABL(NX,NY,WS,37,PAR,'S1') 0 175-+ +SELF. 176 - *** Plot the title at the top. 177 - CALL GSELNT(0) 178 - CALL GSTXAL(0,0) 179 - CALL GSCHUP(0.0,1.0) 180 - CALL GRATTS('TITLE','TEXT') 181 - CALL GRTX(0.1,0.95,TITLE) 182 - *** Close the plot and register it. 183 - CALL GRNEXT 184 - CALL TIMLOG('Making a 3-dimensional plot: ') 185 - CALL GRALOG('3-D plot of a matrix.') 186 - *** Release the matrix. 187 - CALL BOOK('RELEASE','MATRIX','MATSURF',IFAIL) 188 - END 424 GARFIELD ================================================== P=MATRIX D=MATCON 1 ============================ 0 + +DECK,MATCON. 1 - SUBROUTINE MATCON(IREFM,IREFX,IREFY,XTXT,YTXT,TITLE,NCHTS,OPTION) 2 - *----------------------------------------------------------------------- 3 - * MATCON - Plots contours for a matrix. 4 - * (Last changed on 19/ 8/99.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,MATDATA. 8.- +SEQ,PRINTPLOT. 9 - INTEGER MATSLT,MATADR,IA(MXMDIM),NX,NY,NCHTS, 10 - - ISLOTX,ISLOTY,ISLOTM,IREFX,IREFY,IREFM,IELEM 1 424 P=MATRIX D=MATCON 2 PAGE 530 11 - REAL XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX 12 - CHARACTER*(*) XTXT,YTXT,TITLE,OPTION 13 - EXTERNAL MATSLT,MATADR 0 14-+ +SELF,IF=NAG. 15 - DOUBLE PRECISION WS,CHTS 16 - REAL XMINP,YMINP,XMAXP,YMAXP,CHEXP 17 - PARAMETER(MXWS=MXWIRE**2+3*MXWIRE+3) 18 - COMMON /MATRIX/ WS(MXWS),CHTS(MXWIRE) 19 - COMMON /LWSCOM/ LWS 20 - LOGICAL LWS(MXWIRE**2) 21 - INTEGER ILAB,IERR 22 - EXTERNAL J06GBY,J06GBV 0 23-+ +SELF,IF=HIGZ. 24 - REAL WS,PAR,COLFLG 25 - PARAMETER(MXWS=2*MXWIRE**2+8*MXWIRE-31) 26 - COMMON /MATRIX/ WS(MXWS),PAR(37) 0 27-+ +SELF. 28 - *** Identify the routine if requested. 29 - IF(LIDENT)PRINT *,' /// ROUTINE MATCON ///' 30 - *** Debugging output. 31 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATCON DEBUG : Plotting'', 32 - - '' matrix '',I5,'' axes '',2I5,'' #contours='',I5/ 33 - - 26X,''x-Axis label: '',A/26X,''y-Axis label: '',A/ 34 - - 26X,''Title: '',A/26X,''Options: '',A/)') 35 - - IREFM,IREFX,IREFY,NCHTS,XTXT,YTXT,TITLE,OPTION 0 36-+ +SELF,IF=-NAG,IF=-HIGZ. 37 - *** This routine needs either NAG or HIGZ. 38 - PRINT *,' ------ MATCON MESSAGE : No graphics package capable'// 39 - - ' of plotting has been linked; no contour plot.' 40 - RETURN 0 41-+ +SELF. 42 - *** Verify number of contours. 43 - IF(NCHTS.LT.2.OR.NCHTS.GT.50)THEN 44 - PRINT *,' !!!!!! MATCON WARNING : Number of contours out'// 45 - - ' of range; set to 10.' 46 - NCHTS=10 47 - ENDIF 48 - *** Locate the matrix. 49 - ISLOTM=MATSLT(IREFM) 50 - IF(ISLOTM.LE.0)THEN 51 - PRINT *,' !!!!!! MATCON WARNING : Matrix to be plotted'// 52 - - ' does not exist; not plotted.' 53 - RETURN 54 - ENDIF 55 - NX=MSIZ(ISLOTM,1) 56 - NY=MSIZ(ISLOTM,2) 57 - *** See whether the coordinates are present. 58 - ISLOTX=MATSLT(IREFX) 59 - IF(ISLOTX.GT.0)THEN 60 - IF(MDIM(ISLOTX).EQ.1.AND.MSIZ(ISLOTX,1).EQ.NX)THEN 61 - XMIN=MVEC(MORG(ISLOTX)+1) 62 - XMAX=MVEC(MORG(ISLOTX)+MLEN(ISLOTX)) 63 - ELSE 64 - PRINT *,' !!!!!! MATCON WARNING : x-Coordinate'// 65 - - ' vector does not have the right format.' 66 - XMIN=0 67 - XMAX=1 68 - ENDIF 69 - ELSE 70 - PRINT *,' ------ MATCON MESSAGE : x-Range of plot not'// 71 - - ' given; set to [0,1].' 72 - XMIN=0 73 - XMAX=1 74 - ENDIF 75 - ISLOTY=MATSLT(IREFY) 76 - IF(ISLOTY.GT.0)THEN 77 - IF(MDIM(ISLOTY).EQ.1.AND.MSIZ(ISLOTY,1).EQ.NY)THEN 78 - YMIN=MVEC(MORG(ISLOTY)+1) 79 - YMAX=MVEC(MORG(ISLOTY)+MLEN(ISLOTY)) 80 - ELSE 81 - PRINT *,' !!!!!! MATCON WARNING : y-Coordinate'// 82 - - ' vector does not have the right format.' 83 - YMIN=0 84 - YMAX=1 85 - ENDIF 86 - ELSE 87 - PRINT *,' ------ MATCON MESSAGE : y-Range of plot not'// 88 - - ' given; set to [0,1].' 89 - YMIN=0 90 - YMAX=1 91 - ENDIF 92 - *** Make sure that this matrix has the right dimensions. 93 - IF(MDIM(ISLOTM).NE.2.OR. 94 - - NX.LT.2.OR.NY.LT.2.OR. 95 - - NX*NY.GT.MXWS)THEN 96 - PRINT *,' !!!!!! MATCON WARNING : The matrix to be'// 97 - - ' plotted doesn''t have the right dimensions.' 98 - RETURN 99 - ENDIF 0 100-+ +SELF,IF=NAG,HIGZ. 101 - *** Obtain the matrix for surface plotting. 102 - CALL BOOK('BOOK','MATRIX','MATCONT',IFAIL) 103 - IF(IFAIL.NE.0)THEN 104 - PRINT *,' !!!!!! MATCON WARNING : Unable to obtain'// 105 - - ' storage for the surface plot; plot not made.' 106 - RETURN 107 - ENDIF 108 - *** Transfer the matrix to the fixed arrays, establish range. 109 - IELEM=0 110 - DO 10 IY=1,NY 1 424 P=MATRIX D=MATCON 3 PAGE 531 111 - DO 20 IX=1,NX 112 - IA(1)=IX 113 - IA(2)=IY 114 - IELEM=IELEM+1 115 - WS(IELEM)=MVEC(MATADR(ISLOTM,IA)) 116 - IF(IELEM.EQ.1)THEN 117 - ZMIN=WS(IELEM) 118 - ZMAX=WS(IELEM) 119 - ELSE 120 - IF(ZMIN.GT.WS(IELEM))ZMIN=WS(IELEM) 121 - IF(ZMAX.LT.WS(IELEM))ZMAX=WS(IELEM) 122 - ENDIF 123 - 20 CONTINUE 124 - 10 CONTINUE 125 - *** Make the plot, go to to graphics mode. 126 - CALL GRGRAF(.TRUE.) 0 127-+ +SELF,IF=NAG. 128 - * Store the CH eXPansion, NAG has the nasty habit of changing it. 129 - CALL GQCHXP(IERR,CHEXP) 130 - IF(IERR.NE.0)CHEXP=1.0 131 - * Initialize NAG. 132 - CALL X04AAF(1,10) 133 - CALL J06XAF 134 - IF(INDEX(OPTION,'POLAR').EQ.0)THEN 135 - CALL GRCART(XMIN,YMIN,XMAX,YMAX,XTXT,YTXT,TITLE) 136 - CALL J06WBF(DBLE(XMIN),DBLE(XMAX),DBLE(YMIN),DBLE(YMAX),0) 137 - ELSE 138 - CALL CFMRTP(XMIN,YMIN,XMINP,YMINP,1) 139 - CALL CFMRTP(XMAX,YMAX,XMAXP,YMAXP,1) 140 - CALL GRCART(XMINP,YMINP,XMAXP,YMAXP,XTXT,YTXT,TITLE) 141 - CALL J06WBF(DBLE(XMINP),DBLE(XMAXP),DBLE(YMINP), 142 - - DBLE(YMAXP),0) 143 - ENDIF 144 - CALL J06WCF(0.1D0,0.9D0,0.1D0,0.9D0) 145 - IFAIL=1 146 - IF(INDEX(OPTION,'LABEL').NE.0)THEN 147 - ILAB=1 148 - ELSE 149 - ILAB=0 150 - ENDIF 151 - CALL J06GBF(WS,NX,1,NX,1,NY,NCHTS,CHTS,0, 152 - - J06GBY,ILAB,0,J06GBV,0,LWS,IFAIL) 153 - * Reset the CH eXPension factor to the original value, 154 - CALL GSCHXP(CHEXP) 0 155-+ +SELF,IF=HIGZ. 156 - * Compute a reasonable set of contours. 157 - CMIN=ZMIN 158 - CMAX=ZMAX 159 - IF(INDEX(OPTION,'ROUND').NE.0)THEN 160 - CALL ROUND(CMIN,CMAX,NCHTS,'SMALLER',STEP) 161 - IF(STEP.NE.0)THEN 162 - NCHTS=1+NINT((CMAX-CMIN)/STEP) 163 - ELSE 164 - CMIN=ZMIN 165 - CMAX=ZMAX 166 - NCHTS=10 167 - ENDIF 168 - ENDIF 169 - IF(INDEX(OPTION,'COLOUR').NE.0)THEN 170 - COLFLG=0 171 - ELSEIF(INDEX(OPTION,'TYPE').NE.0)THEN 172 - COLFLG=1 173 - ELSE 174 - COLFLG=2 175 - ENDIF 176 - * Fill the PAR vector. 177 - IF(COLFLG.LT.0.5)THEN 178 - PAR(1)=0 179 - PAR(2)=0 180 - ELSE 181 - PAR(1)=NCHTS 182 - PAR(2)=COLFLG 183 - ENDIF 184 - PAR(3)=XMIN-0.5*(XMAX-XMIN)/REAL(NX-1) 185 - PAR(4)=XMAX+0.5*(XMAX-XMIN)/REAL(NX-1) 186 - PAR(5)=YMIN-0.5*(YMAX-YMIN)/REAL(NY-1) 187 - PAR(6)=YMAX+0.5*(YMAX-YMIN)/REAL(NY-1) 188 - PAR(7)=CMIN 189 - PAR(8)=CMAX 190 - PAR(9)=0 191 - PAR(10)=0 192 - * Plot the contours. 193 - CALL GRCART(PAR(3),PAR(5),PAR(4),PAR(6),XTXT,YTXT,TITLE) 194 - CALL ISVP(1,0.1,0.9,0.1,0.9) 195 - CALL ISELNT(1) 196 - IF(COLFLG.LT.0.5)THEN 197 - CALL IGTABL(NX,NY,WS,10,PAR,'COL') 198 - ELSE 199 - CALL IGTABL(NX,NY,WS,10,PAR,'C') 200 - ENDIF 0 201-+ +SELF. 202 - *** Close the plot and register it. 203 - CALL GRNEXT 204 - CALL TIMLOG('Making a contour plot of a matrix: ') 205 - CALL GRALOG('Contour plot of a matrix:') 206 - *** Release the matrix. 207 - CALL BOOK('RELEASE','MATRIX','MATCONT',IFAIL) 208 - END 1 425 GARFIELD ================================================== P=MATRIX D=MATVCR 1 =================== PAGE 532 0 + +DECK,MATVCR. 1 - SUBROUTINE MATVCR(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MATVCR - Reads vectors from input. 4 - * VARIABLES : IBLOCK - Block size for matrix allocation. 5 - * (Last changed on 12/ 4/96.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9.- +SEQ,GLOBALS. 10.- +SEQ,PRINTPLOT. 11 - CHARACTER*(MXCHAR) STRING 12 - INTEGER ISIZ(MXMDIM),IBLOCK,ISLOT(MXWORD),IREF(MXWORD),NVECT, 13 - - NREAD(MXWORD),IGLB(MXWORD),MATSLT 14 - REAL ELEM 15 - LOGICAL EXTEND(MXWORD),BLOCK(MXWORD),LPRINT 16 - EXTERNAL MATSLT 17 - PARAMETER(IBLOCK=100,LPRINT=.TRUE.) 18 - *** Assume the routine will fail. 19 - IFAIL=1 20 - *** Get the number of words. 21 - CALL INPNUM(NWORD) 22 - *** Set the number of vectors to read. 23 - NVECT=NWORD-1 24 - IF(NVECT.LT.1)THEN 25 - PRINT *,' ------ MATVCR MESSAGE : Please provide at least'// 26 - - ' one vector name as argument; nothing done.' 27 - RETURN 28 - ENDIF 29 - *** Read a word at the time. 30 - DO 10 IWORD=2,NWORD 31 - ** Fetch the name of the global. 32 - CALL INPSTR(IWORD,IWORD,STRING,NC) 33 - * Check the name starts with a character. 34 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',STRING(1:1)).EQ.0)THEN 35 - PRINT *,' !!!!!! MATVCR WARNING : A vector name does'// 36 - - ' not start with a character.' 37 - RETURN 38 - ENDIF 39 - * Check for illegal characters. 40 - DO 20 I=1,NC 41 - IF(INDEX('+-*/&|<=#>^ ,.:;([{)]}''"`',STRING(I:I)).NE.0)THEN 42 - PRINT *,' !!!!!! MATVCR WARNING : A vector name'// 43 - - ' contains at least 1 illegal character; ignored.' 44 - RETURN 45 - ENDIF 46 - 20 CONTINUE 47 - * Make sure the name is not empty. 48 - IF(STRING.EQ.' '.OR.NC.LT.1)THEN 49 - PRINT *,' !!!!!! MATVCR WARNING : A vector name'// 50 - - ' is empty; definition is ignored.' 51 - RETURN 52 - ENDIF 53 - * Warn if the name is longer than 10 characters. 54 - IF(NC.GT.10)PRINT *,' !!!!!! MATVCR WARNING : A vector'// 55 - - ' name is truncated to the first 10 characters.' 56 - ** Scan the list of globals, add an entry if needed. 57 - DO 30 I=1,NGLB 58 - IF(GLBVAR(I).EQ.STRING(1:MAX(1,MIN(10,NC))))THEN 59 - IGLB(IWORD-1)=I 60 - GOTO 40 61 - ENDIF 62 - 30 CONTINUE 63 - IF(NGLB.GE.MXVAR)THEN 64 - PRINT *,' !!!!!! MATVCR WARNING : No room to add another'// 65 - - ' global variable; definition ignored.' 66 - RETURN 67 - ENDIF 68 - NGLB=NGLB+1 69 - IGLB(IWORD-1)=NGLB 70 - GLBVAR(IGLB(IWORD-1))=STRING(1:MAX(1,MIN(10,NC))) 71 - GLBMOD(IGLB(IWORD-1))=0 72 - ** Ensure that this variable is not a system variable. 73 - 40 CONTINUE 74 - IF(IGLB(IWORD-1).LE.4)THEN 75 - PRINT *,' !!!!!! MATVCR WARNING : This variable may'// 76 - - ' not be user redefined.' 77 - RETURN 78 - ENDIF 79 - ** If this is not a matrix, generate one. 80 - IF(GLBMOD(IGLB(IWORD-1)).NE.5)THEN 81 - * Erase the current contents. 82 - CALL ALGREU(NINT(GLBVAL(IGLB(IWORD-1))), 83 - - GLBMOD(IGLB(IWORD-1)),0) 84 - * Create a new matrix for it. 85 - ISIZ(1)=IBLOCK 86 - IMOD=2 87 - CALL MATADM('ALLOCATE',IREF(IWORD-1),1,ISIZ,IMOD,IFAIL1) 88 - * Quit if the matrix could not be created. 89 - IF(IFAIL1.NE.0)THEN 90 - PRINT *,' !!!!!! MATVCR WARNING : Unable to'// 91 - - ' allocate matrix storage; not read.' 92 - RETURN 93 - ENDIF 94 - * Otherwise register the array with the global variable. 95 - GLBVAL(IGLB(IWORD-1))=IREF(IWORD-1) 96 - GLBMOD(IGLB(IWORD-1))=5 97 - * These can be extended if desired. 98 - EXTEND(IWORD-1)=.TRUE. 99 - * If already a matrix, then do/don't extend. 100 - ELSE 101 - EXTEND(IWORD-1)=.TRUE. 102 - IREF(IWORD-1)=NINT(GLBVAL(IGLB(IWORD-1))) 103 - ENDIF 104 - 10 CONTINUE 105 - *** Find the slots for the matrices and open all of them. 1 425 P=MATRIX D=MATVCR 2 PAGE 533 106 - DO 50 I=1,NVECT 107 - ISLOT(I)=MATSLT(IREF(I)) 108 - IF(ISLOT(I).LE.0)THEN 109 - PRINT *,' !!!!!! MATVCR WARNING : Matrix to be read has'// 110 - - ' not been found.' 111 - RETURN 112 - ENDIF 113 - BLOCK(I)=.FALSE. 114 - NREAD(I)=0 115 - 50 CONTINUE 116 - *** Read the contents, line by line. 117 - CALL INPPRM('Matrix','ADD-NOPRINT') 118 - 100 CONTINUE 119 - * Read a line. 120 - CALL INPWRD(NWORD) 121 - * Quit if the line is empty. 122 - IF(NWORD.EQ.0)GOTO 200 123 - * Make sure no attempt is made to leave the section here. 124 - CALL INPSTR(1,1,STRING,NC) 125 - IF(STRING(1:1).EQ.'&')THEN 126 - PRINT *,' !!!!!! MATVCR WARNING : The section can'// 127 - - ' not be left at this point ; line ignored.' 128 - GOTO 100 129 - ENDIF 130 - ** If only 1 vector, store the words. 131 - IF(NVECT.EQ.1)THEN 132 - * Read each word in turn. 133 - DO 110 I=1,NWORD 134 - * Skip the rest if the array is full. 135 - IF(BLOCK(1))GOTO 110 136 - * See whether there is need to adjust array length. 137 - IF(NREAD(1)+1.GT.MLEN(ISLOT(1)))THEN 138 - IF(EXTEND(1))THEN 139 - ISIZ(1)=MLEN(ISLOT(1))+IBLOCK 140 - CALL MATADJ(IREF(1),1,ISIZ,0.0,IFAIL1) 141 - ISLOT(1)=MATSLT(IREF(1)) 142 - IF(ISLOT(1).LE.0)THEN 143 - PRINT *,' !!!!!! MATVCR WARNING : Matrix'// 144 - - ' has not been found; program bug.' 145 - RETURN 146 - ENDIF 147 - ELSE 148 - IFAIL1=1 149 - ENDIF 150 - * Warn if adjust failed. 151 - IF(IFAIL1.NE.0)THEN 152 - PRINT *,' !!!!!! MATVCR WARNING : Vector too'// 153 - - ' short or not extendable; reading stopped.' 154 - BLOCK(1)=.TRUE. 155 - ENDIF 156 - ENDIF 157 - * Store the elements. 158 - IF(.NOT.BLOCK(1))THEN 159 - NREAD(1)=NREAD(1)+1 160 - CALL INPCHK(I,2,IFAIL2) 161 - CALL INPRDR(I,ELEM,0.0) 162 - MVEC(MORG(ISLOT(1))+NREAD(1))=ELEM 163 - ENDIF 164 - 110 CONTINUE 165 - CALL INPERR 166 - ** Only if only 1 vector is to be read, accept any number of words. 167 - ELSEIF(NWORD.NE.NVECT)THEN 168 - PRINT *,' !!!!!! MATVCR WARNING : The # of words'// 169 - - ' differs from the # of vectors ; line ignored.' 170 - GOTO 100 171 - ** More than 1 word: each word on the line goes to a vector. 172 - ELSE 173 - DO 120 I=1,NWORD 174 - IF(BLOCK(I))GOTO 120 175 - * If not long enough. 176 - IF(NREAD(I)+1.GT.MLEN(ISLOT(I)))THEN 177 - * If extendable, try to extend. 178 - IF(EXTEND(I))THEN 179 - ISIZ(1)=MLEN(ISLOT(I))+IBLOCK 180 - CALL MATADJ(IREF(I),1,ISIZ,0.0,IFAIL1) 181 - * Relocate all matrices. 182 - DO 160 J=1,NVECT 183 - ISLOT(J)=MATSLT(IREF(J)) 184 - IF(ISLOT(J).LE.0)THEN 185 - PRINT *,' !!!!!! MATVCR WARNING : Matrix'// 186 - - ' to be read has not been found.' 187 - BLOCK(J)=.TRUE. 188 - ENDIF 189 - 160 CONTINUE 190 - * If not extendable, nothing much can be done. 191 - ELSE 192 - IFAIL1=1 193 - ENDIF 194 - * Process the errors. 195 - IF(IFAIL1.NE.0)THEN 196 - PRINT *,' !!!!!! MATVCR WARNING : Vector too'// 197 - - ' short or not extendable; reading stopped.' 198 - BLOCK(I)=.TRUE. 199 - ENDIF 200 - ENDIF 201 - * If still open, read the word. 202 - IF(.NOT.BLOCK(I))THEN 203 - NREAD(I)=NREAD(I)+1 204 - CALL INPCHK(I,2,IFAIL2) 205 - CALL INPRDR(I,ELEM,0.0) 206 - MVEC(MORG(ISLOT(I))+NREAD(I))=ELEM 207 - ENDIF 208 - * Next word. 209 - 120 CONTINUE 210 - * Print error messages. 211 - CALL INPERR 1 425 P=MATRIX D=MATVCR 3 PAGE 534 212 - ENDIF 213 - * New line of input. 214 - GOTO 100 215 - 200 CONTINUE 216 - * Reset the prompt. 217 - CALL INPPRM(' ','BACK-PRINT') 218 - *** Truncate the newly created extendable vectors to their real length. 219 - DO 210 I=1,NVECT 220 - IF(EXTEND(I))THEN 221 - ISIZ(1)=NREAD(I) 222 - CALL MATADJ(IREF(I),1,ISIZ,0.0,IFAIL1) 223 - ENDIF 224 - IF(LPRINT)WRITE(LUNOUT,'('' Matrix '',A,'' has received '', 225 - - I10,'' words.'')') GLBVAR(IGLB(I)),NREAD(I) 226 - 210 CONTINUE 227 - END 426 GARFIELD ================================================== P=MATRIX D=MATWRT 1 ============================ 0 + +DECK,MATWRT. 1 - SUBROUTINE MATWRT(IREF,FILE,MEMB,REM,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MATWRT - This routine writes a matrix to a dataset. 4 - * VARIABLES : 5 - * (Last changed on 30/ 8/97.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*132 STRING 11 - CHARACTER*(*) FILE,MEMB,REM 12 - CHARACTER*29 REMARK 13 - CHARACTER*8 TIME,DATE,MEMBER 14 - LOGICAL EXMEMB 15 - *** Identify the routine. 16 - IF(LIDENT)PRINT *,' /// ROUTINE MATWRT ///' 17 - *** Preset IFAIL to 1: failure. 18 - IFAIL=1 19 - *** Check whether the member already exists. 20 - CALL DSNREM(FILE,MEMB,'MATRIX',EXMEMB) 21 - IF(JEXMEM.EQ.2.AND.EXMEMB)THEN 22 - PRINT *,' ------ MATWRT MESSAGE : A copy of the member'// 23 - - ' exists; new member will be appended.' 24 - ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN 25 - PRINT *,' !!!!!! MATWRT WARNING : A copy of the member'// 26 - - ' exists already; member will not be written.' 27 - RETURN 28 - ENDIF 29 - *** Transfer variables. 30 - REMARK=REM 31 - MEMBER=MEMB 32 - *** Print some debugging output if requested. 33 - IF(LDEBUG)PRINT *,' ++++++ MATWRT DEBUG : Ref=',IREF, 34 - - ', File=',FILE,', member=',MEMBER,', Remark=',REMARK,'.' 35 - *** Find the slot where the matrix is stored. 36 - DO 10 I=1,MXMAT 37 - IF(MREF(I).EQ.IREF)THEN 38 - ISLOT=I 39 - GOTO 20 40 - ENDIF 41 - 10 CONTINUE 42 - PRINT *,' !!!!!! MATWRT WARNING : Matrix to be written has'// 43 - - ' not been found.' 44 - RETURN 45 - 20 CONTINUE 46 - *** Open the dataset for sequential write and inform DSNLOG. 47 - CALL DSNOPN(FILE,LEN(FILE),12,'WRITE-LIBRARY',IFAIL1) 48 - IF(IFAIL1.NE.0)THEN 49 - PRINT *,' !!!!!! MATWRT WARNING : Opening ',FILE, 50 - - ' failed ; matrix will not be written.' 51 - IFAIL=1 52 - RETURN 53 - ENDIF 54 - CALL DSNLOG(FILE,'Matrix ','Sequential','Write ') 55 - IF(LDEBUG)PRINT *,' ++++++ MATWRT DEBUG : Dataset ', 56 - - FILE,' opened on unit 12 for seq write.' 57 - * Now write a heading record to the file. 58 - CALL DATTIM(DATE,TIME) 59 - WRITE(STRING,'(''% Created '',A8,'' At '',A8,1X,A8,'' MATRIX '', 60 - - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK 61 - WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING 62 - * Write the matrix. 63 - WRITE(12,'('' MATRIX INFORMATION:''/'' Dimension: '',I10/ 64 - - '' Mode: '',I10/ 65 - - '' Sizes: '',12I10:(/12X,12I10))',IOSTAT=IOS,ERR=2010) 66 - - MDIM(ISLOT),MMOD(ISLOT),(MSIZ(ISLOT,I),I=1,MDIM(ISLOT)) 67 - WRITE(12,'('' CONTENTS''/(2X,8E15.8))',IOSTAT=IOS,ERR=2010) 68 - - (MVEC(MORG(ISLOT)+I),I=1,MLEN(ISLOT)) 69 - * Close the file after the operation. 70 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 71 - CALL TIMLOG('Writing a matrix to a dataset: ') 72 - *** Things worked, reset error flag. 73 - IFAIL=0 74 - RETURN 75 - *** Handle the error conditions. 76 - 2010 CONTINUE 77 - PRINT *,' ###### MATWRT ERROR : Error while writing'// 78 - - ' to ',FILE,' via unit 12 ; matrix not written.' 79 - CALL INPIOS(IOS) 80 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 81 - RETURN 82 - 2030 CONTINUE 83 - PRINT *,' ###### MATWRT ERROR : Dataset ',FILE, 84 - - ' unit 12 cannot be closed ; results not predictable' 85 - CALL INPIOS(IOS) 86 - END 1 427 GARFIELD ================================================== P=MATRIX D=MATZRO 1 =================== PAGE 535 0 + +DECK,MATZRO. 1 - SUBROUTINE MATZRO(IREF1,IREF2,NZERO,ZERO,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MATZRO - Finds the zeroes of one matrix vs another. 4 - * (Last changed on 21/ 7/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,MATDATA. 9.- +SEQ,PRINTPLOT. 10 - INTEGER IREF1,IREF2,ISLOT1,ISLOT2,I,J,MATSLT,NZERO,NVEC,IFAIL 11 - REAL ZERO(MXLIST),XVEC(4),YVEC(4),DIVDIF 12 - EXTERNAL MATSLT,DIVDIF 13 - *** Indentify the routine if requested. 14 - IF(LIDENT)PRINT *,' /// ROUTINE MATZRO ///' 15 - *** Assume this will fail. 16 - IFAIL=1 17 - *** Preset number of zeroes. 18 - NZERO=0 19 - *** Debugging output. 20 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATZRO DEBUG : Searching'', 21 - - '' for zero crossings of vectors '',2I5)') IREF1,IREF2 22 - *** Locate the 3 vectors. 23 - ISLOT1=MATSLT(IREF1) 24 - ISLOT2=MATSLT(IREF2) 25 - IF(ISLOT1.EQ.0.OR.ISLOT2.EQ.0)THEN 26 - PRINT *,' !!!!!! MATZRO WARNING : One or more of the'// 27 - - ' vectors has not been found; no zero search.' 28 - RETURN 29 - ENDIF 30 - *** Verify that the 2 have the same length. 31 - IF(MLEN(ISLOT1).NE.MLEN(ISLOT2))THEN 32 - PRINT *,' !!!!!! MATZRO WARNING : The vectors do not'// 33 - - ' have the same length; no zero search.' 34 - RETURN 35 - ENDIF 36 - *** Scan the vectors. 37 - DO 10 I=1,MLEN(ISLOT1)-1 38 - ** See whether the starting point is a zero. 39 - IF(MVEC(MORG(ISLOT2)+I).EQ.0)THEN 40 - NZERO=NZERO+1 41 - ZERO(NZERO)=MVEC(MORG(ISLOT1)+I) 42 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATZRO DEBUG :'', 43 - - '' Point '',I4,'': '',E15.8,'' is a zero.'')') 44 - - I,ZERO(NZERO) 45 - ** Look for crossings in the interval. 46 - ELSEIF(MVEC(MORG(ISLOT2)+I)*MVEC(MORG(ISLOT2)+I+1).LT.0)THEN 47 - * Add the point below, if in the same order. 48 - NVEC=0 49 - IF(I-1.GE.1)THEN 50 - IF((MVEC(MORG(ISLOT2)+I-1).GT. 51 - - MVEC(MORG(ISLOT2)+I).AND. 52 - - MVEC(MORG(ISLOT2)+I).GT.0).OR. 53 - - (MVEC(MORG(ISLOT2)+I-1).LT. 54 - - MVEC(MORG(ISLOT2)+I).AND. 55 - - MVEC(MORG(ISLOT2)+I).LT.0))THEN 56 - NVEC=NVEC+1 57 - XVEC(NVEC)=MVEC(MORG(ISLOT1)+I-1) 58 - YVEC(NVEC)=MVEC(MORG(ISLOT2)+I-1) 59 - ENDIF 60 - ENDIF 61 - * Add the 2 points around the crossing. 62 - NVEC=NVEC+1 63 - XVEC(NVEC)=MVEC(MORG(ISLOT1)+I) 64 - YVEC(NVEC)=MVEC(MORG(ISLOT2)+I) 65 - NVEC=NVEC+1 66 - XVEC(NVEC)=MVEC(MORG(ISLOT1)+I+1) 67 - YVEC(NVEC)=MVEC(MORG(ISLOT2)+I+1) 68 - * Add the point above, if in the same order. 69 - IF(I+2.LE.MLEN(ISLOT1))THEN 70 - IF((MVEC(MORG(ISLOT2)+I+2).GT. 71 - - MVEC(MORG(ISLOT2)+I+1).AND. 72 - - MVEC(MORG(ISLOT2)+I+1).GT.0).OR. 73 - - (MVEC(MORG(ISLOT2)+I+2).LT. 74 - - MVEC(MORG(ISLOT2)+I+1).AND. 75 - - MVEC(MORG(ISLOT2)+I+1).LT.0))THEN 76 - NVEC=NVEC+1 77 - XVEC(NVEC)=MVEC(MORG(ISLOT1)+I+2) 78 - YVEC(NVEC)=MVEC(MORG(ISLOT2)+I+2) 79 - ENDIF 80 - ENDIF 81 - * Interpolate. 82 - IF(LDEBUG)THEN 83 - WRITE(LUNOUT,'('' ++++++ MATZRO DEBUG :'', 84 - - '' Zero search over the point: '')') 85 - DO 20 J=1,NVEC 86 - WRITE(LUNOUT,'(26X,2E15.8)') XVEC(J),YVEC(J) 87 - 20 CONTINUE 88 - ENDIF 89 - NZERO=NZERO+1 90 - IF(NZERO.LE.MXLIST)THEN 91 - ZERO(NZERO)=DIVDIF(XVEC,YVEC,NVEC,0.0,MIN(2,NVEC-1)) 92 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATZRO DEBUG :'', 93 - - '' Zero at '',E15.8)') ZERO(NZERO) 94 - ELSE 95 - WRITE(LUNOUT,'('' ++++++ MATZRO DEBUG : Zero not'', 96 - - '' added, buffer is full.'')') 97 - ENDIF 98 - ENDIF 99 - 10 CONTINUE 100 - *** Check the last point. 101 - IF(MVEC(MORG(ISLOT2)+MLEN(ISLOT1)).EQ.0)THEN 102 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATZRO DEBUG :'', 103 - - '' Final point '',E15.8,'' is a zero.'')') ZERO(NZERO) 104 - NZERO=NZERO+1 105 - IF(NZERO.LE.MXLIST)ZERO(NZERO)= 1 427 P=MATRIX D=MATZRO 2 PAGE 536 106 - - MVEC(MORG(ISLOT1)+MLEN(ISLOT1)) 107 - ENDIF 108 - *** Check the total zero count. 109 - IF(NZERO.GT.MXLIST)THEN 110 - PRINT *,' !!!!!! MATZRO WARNING : Number of zeroes'// 111 - - ' exceeds MXLIST; list truncated.' 112 - NZERO=MXLIST 113 - ENDIF 114 - *** Seems to have worked. 115 - IFAIL=0 116 - END 428 GARFIELD ================================================== P=VAXAST D= 1 ============================ 0 + +PATCH,VAXAST,IF=VAX,IF=AST. 429 GARFIELD ================================================== P=VAXAST D=ASTDOC 1 ============================ 0 + +DECK,ASTDOC,IF=NEVER. 1 - Copyright (C) 1988 CAJ Mekenkamp. All Rights Reserved. 2 - Carlo Mekenkamp, President Krugerstraat 42, 1975 EH IJmuiden, Holland 3 - * 4 - * Date: 10-MAR-1988 5 - * The author of this program does not accept any responsibilities for 6 - * damage caused by use or ill-use of this program. 7 - * This program may be used in combination with FIOPAT.MAR 8 - * together with the program GARFIELD which was written by Rob Veenhof. 9 - * 10 - * PROGRAM DESCRIPTION: 11 - * 12 - * Control-C interrupt routines 13 - * 14 - * Routines below: 15 - * ASTINT - Init Control-C AST Routines 16 - * ASTXIT - Exit Control-C AST Routines 17 - * ASTECC - Enable Control-C AST 18 - * ASTDCC - Disable Control-C AST 19 - * ASTCCA - Control-C AST Routine 20 - * ASTCCH - Control-C Condition Handler 21 - * ASTSCS - Start Critical Section 22 - * ASTECS - End Critical Section 23 - * 24 - * AUTHOR: 25 - * 26 - * C.A.J. Mekenkamp 27 - * 28 - * CREATION DATE: 10-MAR-1988 29 - * 30 - * VERSION: 2.04 31 - * 32 - * C H A N G E L O G 33 - * 34 - * Date | Name | Description 35 - *----------------------------------------------------------------------- 36 - * [change_entry] 37 - * 38 - * Start of the routines 39 - * 430 GARFIELD ================================================== P=VAXAST D=ASTINT 1 ============================ 0 + +DECK,ASTINT. 1 - SUBROUTINE ASTINT 2 - *----------------------------------------------------------------------- 3 - * ASTINT - Initialisation Control C AST Routines 4 - * AUTHOR : Carlo Mekenkamp /Leiden (MEKENKAM@HLERUL5) 5 - * SIDE EFFECTS: Initialize ASTCS and ASTIP to .FALSE., 6 - * Assign a channel to the terminal, 7 - * Enable control-C AST. 8 - * CREATION DATE: 10-MAR-1988 9 - *----------------------------------------------------------------------- 10.- +SEQ,ASTCOM. 11 - INCLUDE '($SYSSRVNAM)/NOLIST' 12 - ASTCS = .FALSE. 13 - ASTIP = .FALSE. 14 - CALL SYS$ASSIGN('TT',CHAN,,) 15 - CALL ASTECC 16 - END 431 GARFIELD ================================================== P=VAXAST D=ASTXIT 1 ============================ 0 + +DECK,ASTXIT. 1 - SUBROUTINE ASTXIT 2 - *----------------------------------------------------------------------- 3 - * ASTXIT - Exitialisation Control C AST routines 4 - * AUTHOR : Carlo Mekenkamp /Leiden (MEKENKAM@HLERUL5) 5 - * SIDE EFFECTS: Disable control-C AST, 6 - * Deassign channel to terminal. 7 - * CREATION DATE: 10-MAR-1988 8 - *----------------------------------------------------------------------- 9.- +SEQ,ASTCOM. 10 - INCLUDE '($SYSSRVNAM)/NOLIST' 11 - CALL ASTDCC 12 - CALL SYS$DASSGN(%VAL(CHAN)) 13 - END 432 GARFIELD ================================================== P=VAXAST D=ASTECC 1 ============================ 0 + +DECK,ASTECC. 1 - SUBROUTINE ASTECC 2 - *----------------------------------------------------------------------- 3 - * ASTECC - Enables Control C AST 4 - * AUTHOR : Carlo Mekenkamp /Leiden (MEKENKAM@HLERUL5) 5 - * SIDE EFFECTS: Queues a control-C-AST to CHAN. 6 - * CREATION DATE: 10-MAR-1988 7 - *----------------------------------------------------------------------- 1 432 P=VAXAST D=ASTECC 2 PAGE 537 8.- +SEQ,ASTCOM. 9 - EXTERNAL ASTCCA 10 - INCLUDE '($SYSSRVNAM)/NOLIST' 11 - INCLUDE '($IODEF)/NOLIST' 12 - CALL SYS$QIOW(,%VAL(CHAN),%VAL(IOR(IO$_SETMODE,IO$M_CTRLCAST)), 13 - - ,,,ASTCCA,,,,,) 14 - END 433 GARFIELD ================================================== P=VAXAST D=ASTDCC 1 ============================ 0 + +DECK,ASTDCC. 1 - SUBROUTINE ASTDCC 2 - *----------------------------------------------------------------------- 3 - * ASTDCC - Disables Control C AST 4 - * AUTHOR : Carlo Mekenkamp /Leiden (MEKENKAM@HLERUL5) 5 - * SIDE EFFECTS: Cancels control-C-AST on CHAN. 6 - * CREATION DATE: 10-MAR-1988 7 - *----------------------------------------------------------------------- 8.- +SEQ,ASTCOM. 9 - INCLUDE '($SYSSRVNAM)/NOLIST' 10 - CALL SYS$CANCEL(%VAL(CHAN)) 11 - END 434 GARFIELD ================================================== P=VAXAST D=ASTCCA 1 ============================ 0 + +DECK,ASTCCA. 1 - SUBROUTINE ASTCCA 2 - *----------------------------------------------------------------------- 3 - * ASTCCA - This routines receives control when a control_c is typed 4 - * to the terminal. 5 - * AUTHOR : Carlo Mekenkamp /Leiden (MEKENKAM@HLERUL5) 6 - * SIDE EFFECTS: Signal SS$_CONTROLC. 7 - * CREATION DATE: 10-MAR-1988 8 - *----------------------------------------------------------------------- 9.- +SEQ,ASTCOM. 10 - INCLUDE '($SYSSRVNAM)/NOLIST' 11 - INCLUDE '($SSDEF)/NOLIST' 12 - INCLUDE '($LIBDEF)/NOLIST' 13 - INCLUDE '($STSDEF)/NOLIST' 14 - CALL LIB$SIGNAL(%VAL(IOR(IAND(-(STS$M_SEVERITY+1), 15 - - SS$_CONTROLC),STS$K_ERROR))) 16 - END 435 GARFIELD ================================================== P=VAXAST D=ASTCCH 1 ============================ 0 + +DECK,ASTCCH. 1 - INTEGER*4 FUNCTION ASTCCH(SA, MA) 2 - *----------------------------------------------------------------------- 3 - * ASTCCH - This routine gets control if an exception occurs 4 - * when established 5 - * AUTHOR : Carlo Mekenkamp /Leiden (MEKENKAM@HLERUL5) 6 - * VARIABLES : SA : Signal Array 7 - * SA(1) Number of arguments 8 - * SA(2) Condition name 9 - * SA(3) First signal-specific argument 10 - * ... 11 - * SA(SA(1)) PC at time exception 12 - * SA(SA(1)+1) PSL at time exception 13 - * MA : Mechanism Array 14 - * MA(1) Number of mechanism arguments 15 - * MA(2) Establisher frame address 16 - * MA(3) Frame depth of establisher 17 - * MA(4) Saved register R0 18 - * MA(5) Saved register R1 19 - * SIDE EFFECTS: IF condition matches SS$_CONTROLC THEN 20 - * IF NOT ASTCS THEN 21 - * stack unwind to establisher of caller 22 - * enable control-C AST 23 - * ELSE 24 - * ASTIP=.TRUE. 25 - * return SS$_CONTINUE 26 - * ENDIF 27 - * ELSE 28 - * resignal 29 - * ENDIF 30 - * CREATION DATE: 10-MAR-1988 31 - *----------------------------------------------------------------------- 32.- +SEQ,ASTCOM. 33 - INTEGER*4 SA(*), MA(5) 34 - INCLUDE '($SYSSRVNAM)/NOLIST' 35 - INCLUDE '($LIBDEF)/NOLIST' 36 - INCLUDE '($SSDEF)/NOLIST' 37 - INTEGER*4 LIB$MATCH_COND 38 - IF(LIB$MATCH_COND(SA(2),SS$_CONTROLC).EQ.1)THEN 39 - IF(ASTCS)THEN 40 - ASTIP = .TRUE. 41 - ASTCCH = SS$_CONTINUE 42 - ELSE 43 - CALL SYS$UNWIND(MA(3),) 44 - CALL ASTECC 45 - ENDIF 46 - ELSE 47 - ASTCCH = SS$_RESIGNAL 48 - ENDIF 49 - END 436 GARFIELD ================================================== P=VAXAST D=ASTSCS 1 ============================ 0 + +DECK,ASTSCS. 1 - SUBROUTINE ASTSCS 2 - *----------------------------------------------------------------------- 3 - * ASTSCS - Starts critical section in which no stack unwind may occur 4 - * AUTHOR : Carlo Mekenkamp /Leiden (MEKENKAM@HLERUL5) 5 - * SIDE EFFECTS: ASTCS = .TRUE. 6 - * CREATION DATE: 10-MAR-1988 7 - *----------------------------------------------------------------------- 1 436 P=VAXAST D=ASTSCS 2 PAGE 538 8.- +SEQ,ASTCOM. 9 - ASTCS = .TRUE. 10 - END 437 GARFIELD ================================================== P=VAXAST D=ASTECS 1 ============================ 0 + +DECK,ASTECS. 1 - SUBROUTINE ASTECS 2 - *----------------------------------------------------------------------- 3 - * ASTECS - Ends critical section in which no stack unwind may occur 4 - * AUTHOR : Carlo Mekenkamp /Leiden (MEKENKAM@HLERUL5) 5 - * SIDE EFFECTS: ASTCS = .FALSE., 6 - * IF ASTIP THEN SIGNAL SS$_CONTROLC 7 - * CREATION DATE: 10-MAR-1988 8 - *----------------------------------------------------------------------- 9.- +SEQ,ASTCOM. 10 - INCLUDE '($LIBDEF)/NOLIST' 11 - INCLUDE '($SSDEF)/NOLIST' 12 - INCLUDE '($STSDEF)/NOLIST' 13 - ASTCS = .FALSE. 14 - IF(ASTIP)THEN 15 - ASTIP=.FALSE. 16 - CALL LIB$SIGNAL(%VAL(IOR(IAND(-(STS$M_SEVERITY+1), 17 - - SS$_CONTROLC),STS$K_ERROR))) 18 - ENDIF 19 - END 438 GARFIELD ================================================== P=HELP D= 1 ============================ 0 + +PATCH,HELP. 439 GARFIELD ================================================== P=HELP D=HLPCNT 1 ============================ 0 + +DECK,HLPCNT,IF=APOLLO,CMS,UNIX. 1 - SUBROUTINE HLPCNT(NOUT,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HLPCNT - Counts the number of records the packed dataset will have. 4 - * (Last changed on 21/11/90.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,PRINTPLOT. 8 - LOGICAL EXIST 9 - CHARACTER*80 IN 10 - CHARACTER*(MXHLRL) OUT 11 - *** Check the existence of both raw and processed help files. 0 12-+ +SELF,IF=VAX. 13 - INQUIRE(FILE='HELP_RAW$GARFIELD',EXIST=EXIST) 0 14-+ +SELF,IF=APOLLO,UNIX. 15 - INQUIRE(FILE='garfield.rawhelp',EXIST=EXIST) 0 16-+ +SELF,IF=CMS. 17 - CALL VMCMS('STATE GARFIELD RAWHELP *',IRC) 18 - IF(IRC.EQ.0)THEN 19 - EXIST=.TRUE. 20 - ELSE 21 - EXIST=.FALSE. 22 - ENDIF 0 23-+ +SELF. 24 - IF(.NOT.EXIST)THEN 25 - PRINT *,' !!!!!! HLPCNT WARNING : Raw help dataset not'// 26 - - ' found ; no record count.' 27 - IFAIL=1 28 - RETURN 29 - ENDIF 30 - *** Open the raw help file. 0 31-+ +SELF,IF=VAX. 32 - OPEN(UNIT=12,FILE='HELP_RAW$GARFIELD',STATUS='OLD',IOSTAT=IOS, 33 - - ERR=2020) 0 34-+ +SELF,IF=APOLLO,UNIX. 35 - OPEN(UNIT=12,FILE='garfield.rawhelp',STATUS='OLD',IOSTAT=IOS, 36 - - ERR=2020) 0 37-+ +SELF,IF=CMS. 38 - OPEN(UNIT=12,FILE='/GARFIELD RAWHELP *',STATUS='OLD',IOSTAT=IOS, 39 - - FORM='UNFORMATTED',ERR=2020) 0 40-+ +SELF. 41 - *** Initialise various global variables. 42 - NOUT=1 43 - NIN=0 44 - IOUT=1 45 - OUT=' ' 46 - ** Read a line from the file, skipping comment lines. 47 - 10 CONTINUE 0 48-+ +SELF,IF=-CMS. 49 - READ(12,'(A80)',IOSTAT=IOS,ERR=2010,END=20) IN 50 - LENIN=80 0 51-+ +SELF,IF=CMS. 52 - READ(12,IOSTAT=IOS,ERR=2010,END=20,NUM=LENIN) IN 0 53-+ +SELF. 54 - NIN=NIN+1 55 - IF(IN(1:1).EQ.'!')GOTO 10 56 - ** New heading level. 57 - IF(IN(1:2).NE.' ')THEN 58 - NOUT=NOUT+2 59 - IOUT=1 60 - OUT=' ' 61 - ** Ordinary line, simply written to the file. 1 439 P=HELP D=HLPCNT 2 PAGE 539 62 - ELSE 63 - * Determine the length of the line. 64 - DO 100 I=LENIN,3,-1 65 - IF(IN(I:I).NE.' ')THEN 66 - N=I 67 - GOTO 110 68 - ENDIF 69 - 100 CONTINUE 70 - N=3 71 - 110 CONTINUE 72 - * Add the present line to the buffer. 73 - IFIRST=3 74 - 120 CONTINUE 75 - ILAST=MIN(N+1,IFIRST+MXHLRL-1) 76 - IF(IOUT+ILAST-IFIRST.GT.MXHLRL)ILAST=MXHLRL-IOUT+IFIRST 77 - IF(IOUT+ILAST-IFIRST.EQ.MXHLRL)THEN 78 - NOUT=NOUT+1 79 - IOUT=1 80 - OUT=' ' 81 - ELSE 82 - IOUT=IOUT+ILAST-IFIRST+1 83 - ENDIF 84 - IFIRST=ILAST+1 85 - IF(IFIRST.LE.N+1)GOTO 120 86 - ENDIF 87 - GOTO 10 88 - *** Jump to this point at EOF on the raw help file. 89 - 20 CONTINUE 90 - * Write the current record to the file, if not empty. 91 - NOUT=NOUT+1 92 - * Close the files. 93 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 94 - * Signal to the calling routine that everything worked well. 95 - IFAIL=0 96 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ HLPCNT DEBUG : Expected'', 97 - - '' count of the number of output records:'',I5/26X, 98 - - ''The input file contains'',I5,'' records.'')') NOUT,NIN 99 - RETURN 100 - *** Handle I/O errors. 101 - 2010 CONTINUE 102 - PRINT *,' ###### HLPCNT ERROR : I/O error reading the raw'// 103 - - ' help file at record ',NIN,'; no record count.' 104 - CALL INPIOS(IOS) 105 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 106 - IFAIL=1 107 - RETURN 108 - 2020 CONTINUE 109 - PRINT *,' ###### HLPCNT ERROR : Unable to open the raw help'// 110 - - ' file ; no record count.' 111 - CALL INPIOS(IOS) 112 - IFAIL=1 113 - RETURN 114 - 2030 CONTINUE 115 - PRINT *,' !!!!!! HLPCNT WARNING : Unable to close the raw'// 116 - - ' help file ; record count probably OK.' 117 - CALL INPIOS(IOS) 118 - RETURN 119 - END 440 GARFIELD ================================================== P=HELP D=HLPDEB 1 ============================ 0 + +DECK,HLPDEB,IF=APOLLO,CMS,UNIX. 1 - SUBROUTINE HLPDEB 2 - *----------------------------------------------------------------------- 3 - * HLPDEB - Debugging routine that dumps the entire HELP file. 4 - *----------------------------------------------------------------------- 5.- +SEQ,DIMENSIONS. 6 - INTEGER PATH(MXSUBT) 7 - CHARACTER*20 TOPIC 8 - LOGICAL EXIST 9 - *** Open the help file. 0 10-+ +SELF,IF=VAX. 11 - INQUIRE(FILE='HELP$GARFIELD',EXIST=EXIST) 0 12-+ +SELF,IF=APOLLO,UNIX. 13 - INQUIRE(FILE='garfield.packhelp',EXIST=EXIST) 0 14-+ +SELF,IF=CMS. 15 - CALL VMCMS('STATE GARFIELD PACKHELP *',IRC) 16 - IF(IRC.EQ.0)THEN 17 - EXIST=.TRUE. 18 - ELSE 19 - EXIST=.FALSE. 20 - ENDIF 0 21-+ +SELF. 22 - IF(.NOT.EXIST)THEN 23 - PRINT *,' !!!!!! HLPDEB WARNING : The HELP library can''t'// 24 - - ' be found; no help is offered.' 25 - CALL INPPRM(' ','BACK') 26 - RETURN 27 - ENDIF 0 28-+ +SELF,IF=APOLLO,UNIX. 29 - OPEN(UNIT=17,FILE='garfield.packhelp',ACCESS='DIRECT', 30 - - STATUS='OLD',RECL=MXHLRL,IOSTAT=IOS,ERR=2020) 0 31-+ +SELF,IF=CMS. 32 - CALL VMCMS('FILEDEF HELP CLEAR',IRC) 33 - CALL VMCMS('FILEDEF HELP DISK GARFIELD PACKHELP * (CHANGE'// 34 - - ' XTENT 2000',IRC) 35 - IF(IRC.NE.0)GOTO 2020 36 - OPEN(UNIT=17,FILE='HELP',ACCESS='DIRECT',STATUS='OLD', 37 - - RECL=MXHLRL,FORM='UNFORMATTED',IOSTAT=IOS,ERR=2020) 1 440 P=HELP D=HLPDEB 2 PAGE 540 38-+ +SELF,IF=VAX. 39 - OPEN(UNIT=17,FILE='HELP$GARFIELD',ACCESS='DIRECT',STATUS='OLD', 40 - - IOSTAT=IOS,ERR=2020) 0 41-+ +SELF. 42 - *** Search the entire tree, start at the root. 43 - NPATH=1 44 - PATH(1)=1 45 - 10 CONTINUE 46 - CALL HLPINQ(PATH,NPATH,EXIST,NSUB,TOPIC,IREC,IFAIL) 47 - IF(IFAIL.NE.0)THEN 48 - PRINT *,' !!!!!! HLPDEB WARNING : Inquiry for the'// 49 - - ' existence of a topic failed; help ended.' 50 - RETURN 51 - ENDIF 52 - IF(EXIST)THEN 53 - CALL HLPPRT(IREC,2*NPATH,IFAIL) 54 - IF(IFAIL.NE.0)THEN 55 - PRINT *,' !!!!!! HLPDEB WARNING : Unable to print'// 56 - - ' the subtopics; help ended.' 57 - RETURN 58 - ENDIF 59 - CALL HLPSUB(IREC,2*NPATH,IFAIL) 60 - IF(IFAIL.NE.0)THEN 61 - PRINT *,' !!!!!! HLPDEB WARNING : Unable to list'// 62 - - ' the subtopics; help ended.' 63 - RETURN 64 - ENDIF 65 - NPATH=NPATH+1 66 - PATH(NPATH)=1 67 - ELSE 68 - NPATH=NPATH-1 69 - IF(NPATH.LE.0)THEN 70 - PRINT *,' End of listing.' 71 - CLOSE(UNIT=17,STATUS='KEEP',ERR=2030) 72 - RETURN 73 - ENDIF 74 - PATH(NPATH)=PATH(NPATH)+1 75 - ENDIF 76 - GOTO 10 77 - *** Handle I/O errors during opening of the file. 78 - 2020 CONTINUE 79 - PRINT *,' ###### HLPDEB WARNING : Unable to open the help file.' 80 - RETURN 81 - 2030 CONTINUE 82 - PRINT *,' ###### HLPDEB WARNING : Unable to close the help file.' 83 - END 441 GARFIELD ================================================== P=HELP D=HLPINPAL 1 ============================ 0 + +DECK,HLPINPAL,IF=-APOLLO,IF=-CMS,IF=-UNIX,IF=-VAX. 1 - SUBROUTINE HLPINP 2 - *----------------------------------------------------------------------- 3 - * HELP - Routine providing help. 4 - *----------------------------------------------------------------------- 5 - PRINT *,' !!!!!! HLPINP WARNING : Sorry, online help'// 6 - - ' is not available on this machine.' 7 - END 442 GARFIELD ================================================== P=HELP D=HLPINPVX 1 ============================ 0 + +DECK,HLPINPVX,IF=VAX. 1 - SUBROUTINE HLPINP 2 - *----------------------------------------------------------------------- 3 - * HLPINP - Routine calling the VAX/VMS HELP utility to display online 4 - * help information. 5 - * AUTHOR: Carlo Mekenkamp / Rijks Universiteit Leiden 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8 - CHARACTER*(MXINCH) STRING 9 - EXTERNAL LBR$OUTPUT_HELP, LIB$PUT_OUTPUT, LIB$GET_INPUT 10 - INTEGER*4 LBR$OUTPUT_HELP, LIB$PUT_OUTPUT, LIB$GET_INPUT 11 - LOGICAL EXIST 12 - *** Pick up the argument string. 13 - CALL INPNUM(NWORD) 14 - CALL INPSTR(1,NWORD,STRING,NC) 15 - IF(STRING(1:1).EQ.'?')THEN 16 - STRING(1:1)=' ' 17 - ELSEIF(NWORD.GE.2)THEN 18 - CALL INPSTR(2,NWORD,STRING,NC) 19 - ELSE 20 - NC=1 21 - STRING=' ' 22 - ENDIF 23 - IF(STRING(1:NC).EQ.' ')THEN 24 - PRINT *,' ' 25 - PRINT *,' ------------------------------------------------' 26 - PRINT *,' ---------- Help subsection ----------' 27 - PRINT *,' ------------------------------------------------' 28 - PRINT *,' ' 29 - ENDIF 30 - *** Check for the existence of the help library. 31 - INQUIRE(FILE='HELP$GARFIELD',EXIST=EXIST) 32 - IF(.NOT.EXIST)THEN 33 - PRINT *,' !!!!!! HLPINP WARNING : Unable to find the HELP'// 34 - - ' library; check the logical HELP$GARFIELD.' 35 - RETURN 36 - ENDIF 37 - *** Call the Vax/VMS HELP facility. 38 - IERR=LBR$OUTPUT_HELP( 39 - * Output routine for HELP 40 - - LIB$PUT_OUTPUT, 41 - * Number of characters on an output line 42 - - 80, 43 - * Initial command 44 - - STRING(1:NC), 1 442 P=HELP D=HLPINPVX 2 PAGE 541 45 - * HELP library 46 - - 'HELP$GARFIELD', 47 - * Indicate that we wish further help 48 - - 1, 49 - * Input routine for HELP 50 - - LIB$GET_INPUT) 51 - *** Check the error status on return. 52 - IF(IERR.EQ.2*INT(IERR/2.0))PRINT *,' !!!!!! HLPINP WARNING :'// 53 - - ' Error status ',IERR,' received from VMS HELP.' 54 - END 443 GARFIELD ================================================== P=HELP D=HLPINPOT 1 ============================ 0 + +DECK,HLPINPOT,IF=APOLLO,CMS,UNIX. 1 - SUBROUTINE HLPINP 2 - *----------------------------------------------------------------------- 3 - * HLPINP - Reads the help commands and fetches the information. 4 - * (Last changed on 12/ 1/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9 - CHARACTER*100 FILE 0 10-+ +SELF,IF=UNIX. 11 - CHARACTER*80 HOME 12 - INTEGER NCHOME 0 13-+ +SELF. 14 - CHARACTER*80 STRING,BLANK 15 - CHARACTER*20 TOPIC,SEARCH(MXHLEV),TOPL(MXHLEV),TOPTL(MXHLEV),AUX 16 - INTEGER PATH(MXHLEV),IRECL(MXHLEV),IRECTL(MXHLEV),NOCCUR, 17 - - INPCMP,NCFILE,IOS,NWORD,I,ISMIN,ISMAX,NC,IOLD,NPATH,NSUB, 18 - - NSUBN,IREC,IFAIL,ISTR,NCAUX 0 19-+ +SELF,IF=CMS. 20 - INTEGER IRC 0 21-+ +SELF. 22 - LOGICAL EXIST,MATCH,DSNCMP 23 - EXTERNAL INPCMP,DSNCMP 24 - *** Set the blank string which is used for indenting. 25 - BLANK=' ' 26 - *** Open the help file. 0 27-+ +SELF,IF=VAX. 28 - * First try with a logical. 29 - FILE='HELP$GARFIELD' 30 - NCFILE=13 31 - INQUIRE(FILE=FILE(1:NCFILE),EXIST=EXIST) 32 - * If this fails, try an explicit file name. 33 - IF(.NOT.EXIST)THEN 34 - FILE='GARFIELD.HLB' 35 - NCFILE=12 36 - INQUIRE(FILE=FILE(1:NCFILE),EXIST=EXIST) 37 - ENDIF 38 - * If found, open the file. 39 - IF(EXIST)THEN 40 - OPEN(UNIT=17,FILE='HELP$GARFIELD',ACCESS='DIRECT', 41 - - STATUS='OLD',IOSTAT=IOS,ERR=2020) 42 - ELSE 43 - PRINT *,' !!!!!! HLPINP WARNING : No help library'// 44 - - ' found; try the URL' 45 - PRINT *,' http://consult'// 46 - - '.cern.ch/writeup/garfield/help' 47 - CALL INPPRM(' ','BACK') 48 - RETURN 49 - ENDIF 0 50-+ +SELF,IF=APOLLO,UNIX. 51 - * Determine home directory. 52 - CALL GETENV('HOME',HOME) 53 - DO 50 I=LEN(HOME),1,-1 54 - IF(HOME(I:I).NE.' ')THEN 55 - NCHOME=I 56 - GOTO 60 57 - ENDIF 58 - 50 CONTINUE 59 - NCHOME=1 60 - HOME=' ' 61 - 60 CONTINUE 62 - * Try a file or link in the current directory. 63 - FILE='garfield.packhelp' 64 - NCFILE=17 65 - INQUIRE(FILE=FILE(1:NCFILE),EXIST=EXIST) 66 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ HLPINP DEBUG :'', 67 - - '' Checking for '',A/26X,''Existence flag: '',L1)') 68 - - FILE(1:NCFILE),EXIST 69 - * If not found, look in the home directory. 70 - IF(.NOT.EXIST)THEN 71 - FILE=HOME(1:NCHOME)//'/garfield.packhelp' 72 - NCFILE=MIN(NCHOME+18,LEN(FILE)) 73 - INQUIRE(FILE=FILE(1:NCFILE),EXIST=EXIST) 74 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ HLPINP DEBUG :'', 75 - - '' Checking for '',A/26X,''Existence flag: '',L1)') 76 - - FILE(1:NCFILE),EXIST 77 - ENDIF 78 - IF(.NOT.EXIST)THEN 79 - FILE=HOME(1:NCHOME)//'/.garfield.packhelp' 80 - NCFILE=MIN(NCHOME+19,LEN(FILE)) 81 - INQUIRE(FILE=FILE(1:NCFILE),EXIST=EXIST) 82 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ HLPINP DEBUG :'', 83 - - '' Checking for '',A/26X,''Existence flag: '',L1)') 84 - - FILE(1:NCFILE),EXIST 85 - ENDIF 86 - * If still not found, try the AFS file name. 1 443 P=HELP D=HLPINPOT 2 PAGE 542 87 - IF(.NOT.EXIST)THEN 88 - FILE='/afs/cern.ch/user/r/rjd/Garfield/Files/'// 89 - - 'garfield.packhelp' 90 - NCFILE=MIN(56,LEN(FILE)) 91 - INQUIRE(FILE=FILE(1:NCFILE),EXIST=EXIST) 92 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ HLPINP DEBUG :'', 93 - - '' Checking for '',A/26X,''Existence flag: '',L1)') 94 - - FILE(1:NCFILE),EXIST 95 - ENDIF 96 - * If found, open the file. 97 - IF(EXIST)THEN 98 - OPEN(UNIT=17,FILE=FILE(1:NCFILE),ACCESS='DIRECT', 99 - - STATUS='OLD',RECL=MXHLRL,IOSTAT=IOS,ERR=2020) 100 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ HLPINP DEBUG :'', 101 - - '' Opened '',A)') FILE(1:NCFILE) 102 - ELSE 103 - PRINT *,' !!!!!! HLPINP WARNING : No help library'// 104 - - ' found; try the URL' 105 - PRINT *,' http://consult'// 106 - - '.cern.ch/writeup/garfield/help' 107 - CALL INPPRM(' ','BACK') 108 - RETURN 109 - ENDIF 0 110-+ +SELF,IF=CMS. 111 - CALL VMCMS('STATE GARFIELD PACKHELP *',IRC) 112 - IF(IRC.EQ.0)THEN 113 - EXIST=.TRUE. 114 - ELSE 115 - EXIST=.FALSE. 116 - ENDIF 117 - IF(.NOT.EXIST)THEN 118 - PRINT *,' !!!!!! HLPINP WARNING : No help library'// 119 - - ' found; try the URL' 120 - PRINT *,' http://consult'// 121 - - '.cern.ch/writeup/garfield/help' 122 - CALL INPPRM(' ','BACK') 123 - RETURN 124 - ENDIF 125 - CALL VMCMS('FILEDEF HELP CLEAR',IRC) 126 - CALL VMCMS('FILEDEF HELP DISK GARFIELD PACKHELP * (CHANGE'// 127 - - ' XTENT 2000',IRC) 128 - IF(IRC.NE.0)GOTO 2020 129 - OPEN(UNIT=17,FILE='HELP',ACCESS='DIRECT',STATUS='OLD', 130 - - RECL=MXHLRL,FORM='UNFORMATTED',IOSTAT=IOS,ERR=2020) 0 131-+ +SELF. 132 - *** Read the root record to check the date on which the file was packed. 133 - READ(UNIT=17,REC=1,ERR=2010,IOSTAT=IOS) TOPIC 134 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ HLPINP DEBUG :'', 135 - - '' Creation date of help library: '',A)') TOPIC(5:12) 136 - IF(DSNCMP('01-01-01',TOPIC(5:12)).OR. 137 - - DSNCMP(TOPIC(5:12),'01-01-02').OR. 138 - - TOPIC(5:12).EQ.' ')THEN 139 - PRINT *,' !!!!!! HLPINP WARNING : Mismatch between the'// 140 - - ' help file and program versions;' 0 141-+ +SELF,IF=CMS. 142 - PRINT *,' you may have to link'// 143 - - ' the library disk at another mode,' 0 144-+ +SELF. 145 - PRINT *,' contact the program'// 146 - - ' library office or the author.' 147 - C CLOSE(UNIT=17,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 148 - C RETURN 149 - ENDIF 150 - *** Set the prompt. 151 - CALL INPPRM('Help','ADD-PRINT') 152 - *** Pick up the initial list. 153 - CALL INPNUM(NWORD) 154 - IF(NWORD.EQ.1.AND.INPCMP(1,'?')+INPCMP(1,'HELP')+ 155 - - INPCMP(1,'INFO#RMATION').NE.0)THEN 156 - PRINT *,' ------------------------------------------------' 157 - PRINT *,' ---------- Help subsection ----------' 158 - PRINT *,' ------------------------------------------------' 159 - 40 CONTINUE 160 - CALL HLPSUB(1,1,IFAIL) 161 - IF(IFAIL.NE.0)THEN 162 - PRINT *,' !!!!!! HLPINP WARNING : Unable to list'// 163 - - ' the subtopics; help ended.' 164 - CLOSE(UNIT=17,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 165 - RETURN 166 - ENDIF 167 - CALL INPPRM('Topic','ADD-PRINT') 168 - WRITE(LUNOUT,'('' '')') 169 - CALL INPGET 170 - CALL INPNUM(NWORD) 171 - CALL INPPRM(' ','BACK-PRINT') 172 - IF(INPCMP(1,'?').NE.0)GOTO 40 173 - ENDIF 174 - *** Return if all parameters are absent, shouldn't be the case. 175 - IF(NWORD.EQ.0)THEN 176 - CALL INPPRM(' ','BACK') 177 - CLOSE(UNIT=17,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 178 - RETURN 179 - ENDIF 180 - * Store the parameters in the search stack. 181 - ISMIN=1 182 - ISMAX=0 183 - DO 10 I=1,NWORD 184 - * Get the string, skip if blank. 185 - CALL INPSTR(I,I,STRING,NC) 186 - IF(NC.EQ.0.OR.STRING.EQ.' '.OR.(INPCMP(I,'?')+INPCMP(I,'HELP')+ 187 - - INPCMP(I,'INFO#RMATION').NE.0.AND.I.EQ.1))GOTO 10 188 - * Add to the stack. 1 443 P=HELP D=HLPINPOT 3 PAGE 543 189 - IF(ISMAX+1.GT.MXHLEV)THEN 190 - PRINT *,' !!!!!! HLPINP WARNING : Too many keywords'// 191 - - ' provided, list truncated.' 192 - GOTO 30 193 - ENDIF 194 - ISMAX=ISMAX+1 195 - IF(I.EQ.1.AND.STRING(1:1).EQ.'?')THEN 196 - SEARCH(ISMAX)=STRING(2:NC) 197 - ELSE 198 - SEARCH(ISMAX)=STRING(1:NC) 199 - ENDIF 200 - 10 CONTINUE 201 - 30 CONTINUE 202 - *** Loop over the input. 203 - IOLD=1 204 - 20 CONTINUE 205 - * Search for the topic, starting from the root. 206 - NPATH=1 207 - PATH(1)=1 208 - NOCCUR=0 209 - ** Return at this point for a next item to be examined. 210 - 100 CONTINUE 211 - ** Determine whether the item exists at all. 212 - CALL HLPINQ(PATH,NPATH,EXIST,NSUB,TOPIC,IREC,IFAIL) 213 - IF(IFAIL.NE.0)THEN 214 - PRINT *,' !!!!!! HLPINP WARNING : Inquiry for the'// 215 - - ' existence of a topic failed; help ended.' 216 - CLOSE(UNIT=17,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 217 - RETURN 218 - ENDIF 219 - * If it exists, check whether the strings match. 220 - IF(EXIST)THEN 221 - CALL WLDCRD(TOPIC,SEARCH(NPATH),.TRUE.,MATCH) 222 - ELSE 223 - MATCH=.FALSE. 224 - ENDIF 225 - ** Assume the strings match ... 226 - IF(EXIST.AND.MATCH)THEN 227 - * Remember the full reference string and record reference. 228 - TOPTL(NPATH)=TOPIC 229 - IRECTL(NPATH)=IREC 230 - * print if we are at the end of the tree and keep track, 231 - IF(NPATH.EQ.ISMAX)THEN 232 - NOCCUR=NOCCUR+1 233 - NSUBN=NSUB 234 - DO 120 I=1,ISMAX 235 - TOPL(I)=TOPTL(I) 236 - IRECL(I)=IRECTL(I) 237 - 120 CONTINUE 238 - DO 130 I=1,ISMAX-1 239 - WRITE(LUNOUT,'(1X,A)') BLANK(1:1+3*(I-1))//TOPL(I) 240 - 130 CONTINUE 241 - CALL HLPPRT(IREC,1+3*(NPATH-1),IFAIL) 242 - IF(IFAIL.NE.0)THEN 243 - PRINT *,' !!!!!! HLPINP WARNING : Unable to'// 244 - - ' print the subtopics; help ended.' 245 - CLOSE(UNIT=17,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 246 - RETURN 247 - ENDIF 248 - PATH(NPATH)=PATH(NPATH)+1 249 - * if there are subtopics, go deeper, 250 - ELSEIF(NSUB.GT.0)THEN 251 - NPATH=NPATH+1 252 - PATH(NPATH)=1 253 - * otherwise go further on the same level. 254 - ELSE 255 - PATH(NPATH)=PATH(NPATH)+1 256 - ENDIF 257 - ** In case the item exists but doesn't match. 258 - ELSEIF(EXIST)THEN 259 - PATH(NPATH)=PATH(NPATH)+1 260 - ** If there is no match, return one level. 261 - ELSE 262 - NPATH=NPATH-1 263 - IF(NPATH.LT.ISMIN)GOTO 200 264 - PATH(NPATH)=PATH(NPATH)+1 265 - ENDIF 266 - * And go for the next item. 267 - GOTO 100 268 - *** Take care of the subtopics. 269 - 200 CONTINUE 270 - * Information not found, revert to old record. 271 - IF(NOCCUR.EQ.0)THEN 272 - PRINT *,' ' 273 - PRINT *,' The information you requested is not available.' 274 - PRINT *,' ' 275 - IREC=IOLD 276 - ISTR=1 277 - * Only one occurence and subtopics for that one. 278 - ELSEIF(NOCCUR.EQ.1.AND.NSUBN.GT.0)THEN 279 - IREC=IRECL(ISMAX) 280 - IOLD=IREC 281 - ISMIN=ISMAX+1 282 - ISTR=2 283 - * Anything else: go back to the previous choice. 284 - ELSE 285 - IREC=IOLD 286 - ISTR=1 287 - ENDIF 288 - * Display the subtopics. 289 - 220 CONTINUE 290 - IF(ISTR.EQ.1)THEN 291 - WRITE(LUNOUT,'('' '')') 292 - DO 230 I=1,ISMIN-1 293 - WRITE(LUNOUT,'(1X,A)') BLANK(1:1+3*(I-1))//TOPL(I) 294 - 230 CONTINUE 1 443 P=HELP D=HLPINPOT 4 PAGE 544 295 - CALL INPPRM('Topic','ADD-PRINT') 296 - ELSE 297 - WRITE(LUNOUT,'('' '')') 298 - CALL OUTFMT(REAL(ISMIN),2,AUX,NCAUX,'LEFT') 299 - CALL INPPRM('Subtopic_'//AUX(1:NCAUX),'ADD-PRINT') 300 - ENDIF 301 - CALL HLPSUB(IREC,MAX(1,1+3*(ISMIN-2)),IFAIL) 302 - IF(IFAIL.NE.0)THEN 303 - PRINT *,' !!!!!! HLPINP WARNING : Unable to list'// 304 - - ' the subtopics; help ended.' 305 - CLOSE(UNIT=17,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 306 - RETURN 307 - ENDIF 308 - * And ask which of the subtopics the user likes most. 309 - WRITE(LUNOUT,'('' '')') 310 - CALL INPGET 311 - CALL INPNUM(NWORD) 312 - CALL INPSTR(1,1,STRING,NC) 313 - CALL INPPRM(' ','BACK-PRINT') 314 - IF(NWORD.EQ.1.AND.STRING.EQ.'?'.AND.NC.EQ.1)GOTO 220 315 - * Put the new words on the stack. 316 - IF(NWORD.GE.1)THEN 317 - DO 240 I=1,NWORD 318 - IF(ISMIN+I-1.GT.MXHLEV)THEN 319 - PRINT *,' !!!!!! HLPINP WARNING : Too many keywords'// 320 - - ' provided, list truncated.' 321 - ISMAX=MXHLEV 322 - GOTO 250 323 - ENDIF 324 - CALL INPSTR(I,I,STRING,NC) 325 - SEARCH(ISMIN+I-1)=STRING(1:NC) 326 - 240 CONTINUE 327 - ISMAX=ISMIN+NWORD-1 328 - 250 CONTINUE 329 - * Return one level if the return is blank. 330 - ELSE 331 - ISMIN=ISMIN-1 332 - IF(ISMIN.LE.0)THEN 333 - CALL INPPRM(' ','BACK') 334 - CLOSE(UNIT=17,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 335 - RETURN 336 - ENDIF 337 - IF(ISMIN.GT.1)THEN 338 - IREC=IRECL(ISMIN-1) 339 - ELSE 340 - IREC=1 341 - ENDIF 342 - IOLD=IREC 343 - ISTR=1 344 - GOTO 220 345 - ENDIF 346 - *** Go back for a new input line. 347 - GOTO 20 348 - *** Handle I/O problems. 349 - 2010 CONTINUE 350 - PRINT *,' !!!!!! HLPINP WARNING : I/O error reading the root'// 351 - - ' record of the help file ; no help can ne provided.' 352 - CALL INPIOS(IOS) 353 - CLOSE(UNIT=17,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 354 - RETURN 355 - 2020 CONTINUE 356 - PRINT *,' !!!!!! HLPINP WARNING : Unable to open the help'// 357 - - ' file ; no help can be provided.' 358 - CALL INPIOS(IOS) 359 - RETURN 360 - 2030 CONTINUE 361 - PRINT *,' !!!!!! HLPINP WARNING : Unable to close the help'// 362 - - ' file after use ; future use might be troublesome.' 363 - CALL INPIOS(IOS) 364 - END 444 GARFIELD ================================================== P=HELP D=HLPINQ 1 ============================ 0 + +DECK,HLPINQ,IF=APOLLO,CMS,UNIX. 1 - SUBROUTINE HLPINQ(PATH,NPATH,EXIST,NSUB,TOPIC,IREC,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HLPINQ - This routine determines whether some branch exists or not 4 - * and it returns the number of subbranches (NSUB) and the 5 - * topic string (TOPIC) if it does. 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8 - INTEGER PATH(NPATH),SUBREC(MXSUBT) 9 - LOGICAL EXIST 10 - CHARACTER*20 TOPIC 11 - *** Start lifting the root reference list. 12 - NXTREC=1 13 - *** And next trace down the path. 14 - DO 10 I=1,NPATH 15 - READ(UNIT=17,REC=NXTREC,IOSTAT=IOS,ERR=2010) 16 - - TOPIC,NREC,NSUB,(SUBREC(J),J=1,MIN(MXSUBT,NSUB)) 17 - IF(NSUB.GT.MXSUBT)THEN 18 - PRINT *,' ###### HLPINQ ERROR : Number of subrecords'// 19 - - ' exceeds MXSUBT; recompile with at least ',NSUB 20 - IFAIL=1 21 - RETURN 22 - ENDIF 23 - * Make sure the next branch really exists, flag if not. 24 - IF(NSUB.LT.PATH(I).OR.0.GE.PATH(I))THEN 25 - EXIST=.FALSE. 26 - IFAIL=0 27 - RETURN 28 - ENDIF 29 - * Set the next reference record. 30 - NXTREC=SUBREC(PATH(I)) 31 - 10 CONTINUE 32 - *** Passing here means the record exists. 1 444 P=HELP D=HLPINQ 2 PAGE 545 33 - READ(UNIT=17,REC=NXTREC,IOSTAT=IOS,ERR=2010) 34 - - TOPIC,NREC,NSUB,(SUBREC(I),I=1,MIN(MXSUBT,NSUB)) 35 - IF(NSUB.GT.MXSUBT)THEN 36 - PRINT *,' ###### HLPINQ ERROR : Number of subrecords'// 37 - - ' exceeds MXSUBT; recompile with at least ',NSUB 38 - IFAIL=1 39 - RETURN 40 - ENDIF 41 - IREC=NXTREC 42 - EXIST=.TRUE. 43 - IFAIL=0 44 - RETURN 45 - *** Take care of I/O problems. 46 - 2010 CONTINUE 47 - PRINT *,' ###### HLPINQ ERROR : I/O error on the HELP file.' 48 - CALL INPIOS(IOS) 49 - IFAIL=1 50 - END 445 GARFIELD ================================================== P=HELP D=HLPPACVX 1 ============================ 0 + +DECK,HLPPACVX,IF=VAX. 1 - SUBROUTINE HLPPAC(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HLPPAC - Packs the help file into a help library. 4 - * (Last changed on 19/10/93.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,PRINTPLOT. 8 - LOGICAL EXIST 9 - INTEGER LIB$SPAWN 10 - EXTERNAL LIB$SPAWN 11 - *** Figure out whether the raw help file exists. 12 - INQUIRE(FILE='HELP_RAW$GARFIELD',EXIST=EXIST) 13 - IF(.NOT.EXIST)THEN 14 - PRINT *,' !!!!!! HLPPAC WARNING : Unable to find the raw'// 15 - - ' help file; no help library made.' 16 - IFAIL=1 17 - RETURN 18 - ENDIF 19 - *** Prepare the library, always as a new version. 20 - IERR=LIB$SPAWN( 21 - - 'LIBRARY/CREATE/HELP HELP$GARFIELD HELP_RAW$GARFIELD') 22 - *** Check the error flag. 23 - IF(IERR.EQ.2*INT(IERR/2.0))THEN 24 - IFAIL=1 25 - ELSE 26 - IFAIL=0 27 - ENDIF 28 - *** Keep track of CPU time consumption. 29 - CALL TIMLOG('Packing the help file') 30 - END 446 GARFIELD ================================================== P=HELP D=HLPPACOT 1 ============================ 0 + +DECK,HLPPACOT,IF=APOLLO,CMS,UNIX. 1 - SUBROUTINE HLPPAC(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HLPPAC - Packs the help file into a direct access dataset. 4 - * (Last changed on 19/ 7/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9 - LOGICAL EXIST 10 - CHARACTER*500 IN 11 - CHARACTER*20 TOPIC 12 - CHARACTER*8 DATE,TIME 13 - CHARACTER*(MXHLRL) OUT 14 - INTEGER PATH(0:MXHLEV),SUBREC(0:MXSUBT),INPCMP,I,NWORD,IFAIL,IOS, 15 - - NTOTAL,NOUT,NIN,IOUT,NREC,LEVEL,LAST,LENIN,NSUB,IFIRST,J, 16 - - ILAST,N,NEWLEV,NNREC,ISTART,IEND,IADD 17 - EXTERNAL INPCMP 0 18-+ +SELF,IF=CMS. 19 - CHARACTER*80 FILDEF 20 - LOGICAL LHLPTR 21 - INTEGER IRC,IRC1,IRC2 22 - DATA LHLPTR /.FALSE./ 0 23-+ +SELF,IF=VAX. 0 24-+ +SELF. 25 - *** Determine whether character translation is to be performed. 26 - CALL INPNUM(NWORD) 27 - DO 40 I=2,NWORD 28 - IF(INPCMP(I,'TR#ANSLATE').NE.0)THEN 0 29-+ +SELF,IF=CMS. 30 - LHLPTR=.TRUE. 0 31-+ +SELF,IF=-CMS. 32 - CALL INPMSG(I,'Option only meaningful on IBM.') 0 33-+ +SELF. 34 - ELSEIF(INPCMP(I,'NOTR#ANSLATE').NE.0)THEN 0 35-+ +SELF,IF=CMS. 36 - LHLPTR=.FALSE. 0 37-+ +SELF,IF=-CMS. 38 - CALL INPMSG(I,'Option only meaningful on IBM.') 1 446 P=HELP D=HLPPACOT 2 PAGE 546 39-+ +SELF. 40 - ELSE 41 - CALL INPMSG(I,'Not a valid option. ') 42 - ENDIF 43 - 40 CONTINUE 44 - *** Check the existence of both raw and processed help files. 0 45-+ +SELF,IF=VAX. 46 - INQUIRE(FILE='HELP_RAW$GARFIELD',EXIST=EXIST) 0 47-+ +SELF,IF=APOLLO,UNIX. 48 - INQUIRE(FILE='garfield.rawhelp',EXIST=EXIST) 0 49-+ +SELF,IF=CMS. 50 - CALL VMCMS('STATE GARFIELD RAWHELP *',IRC) 51 - IF(IRC.EQ.0)THEN 52 - EXIST=.TRUE. 53 - ELSE 54 - EXIST=.FALSE. 55 - ENDIF 0 56-+ +SELF. 57 - IF(.NOT.EXIST)THEN 58 - PRINT *,' !!!!!! HLPPAC WARNING : Raw help dataset not'// 59 - - ' found ; direct access dataset not prepared.' 60 - IFAIL=1 61 - RETURN 62 - ENDIF 0 63-+ +SELF,IF=VAX. 64 - INQUIRE(FILE='HELP$GARFIELD',EXIST=EXIST) 0 65-+ +SELF,IF=APOLLO,UNIX. 66 - INQUIRE(FILE='garfield.packhelp',EXIST=EXIST) 0 67-+ +SELF,IF=CMS. 68 - CALL VMCMS('STATE GARFIELD PACKHELP A6',IRC) 69 - IF(IRC.EQ.0)THEN 70 - EXIST=.TRUE. 71 - ELSE 72 - EXIST=.FALSE. 73 - ENDIF 0 74-+ +SELF. 75 - IF(EXIST)THEN 76 - PRINT *,' !!!!!! HLPPAC WARNING : Packed help file'// 77 - - ' exists already ; no new copy prepared.' 78 - IFAIL=1 79 - RETURN 80 - ENDIF 81 - *** Have the number of records counted. 82 - CALL HLPCNT(NTOTAL,IFAIL) 83 - *** Open the raw and the direct access help file. 0 84-+ +SELF,IF=APOLLO,UNIX. 85 - OPEN(UNIT=12,FILE='garfield.rawhelp',STATUS='OLD',IOSTAT=IOS, 86 - - ERR=2020) 87 - OPEN(UNIT=17,FILE='garfield.packhelp',STATUS='NEW', 88 - - ACCESS='DIRECT',RECL=MXHLRL,FORM='UNFORMATTED', 89 - - IOSTAT=IOS,ERR=2020) 90 - CALL DSNLOG('garfield.rawhelp','Raw help ','Sequential', 91 - - 'Read ') 92 - CALL DSNLOG('garfield.packhelp','HELP file ','Direct ', 93 - - 'Created ') 0 94-+ +SELF,IF=VAX. 95 - OPEN(UNIT=12,FILE='HELP_RAW$GARFIELD',STATUS='OLD',IOSTAT=IOS, 96 - - ERR=2020) 97 - OPEN(UNIT=17,FILE='HELP$GARFIELD',STATUS='NEW',ACCESS='DIRECT', 98 - - RECL=MXHLRL/4,FORM='UNFORMATTED',MAXREC=NTOTAL, 99 - - IOSTAT=IOS,ERR=2020) 100 - CALL DSNLOG('HELP_RAW$GARFIELD','Raw help ','Sequential', 101 - - 'Read ') 102 - CALL DSNLOG('HELP$GARFIELD','HELP file ','Direct ', 103 - - 'Created ') 0 104-+ +SELF,IF=CMS. 105 - WRITE(FILDEF,'(''FILEDEF HELP DISK GARFIELD PACKHELP A6'', 106 - - '' (XTENT '',I5)') NTOTAL 107 - CALL VMCMS('FILEDEF HELP CLEAR',IRC1) 108 - CALL VMCMS(FILDEF,IRC2) 109 - IF(IRC1.NE.0.OR.IRC2.NE.0)GOTO 2020 110 - OPEN(UNIT=12,FILE='/GARFIELD RAWHELP *',STATUS='OLD',IOSTAT=IOS, 111 - - FORM='UNFORMATTED',ERR=2020) 112 - OPEN(UNIT=17,FILE='HELP',STATUS='NEW',ACCESS='DIRECT', 113 - - RECL=MXHLRL,FORM='UNFORMATTED',IOSTAT=IOS,ERR=2020) 114 - CALL DSNLOG('GARFIELD RAWHELP *','Raw help ','Sequential', 115 - - 'Read ') 116 - CALL DSNLOG('GARFIELD PACKHELP A6','HELP file ','Direct ', 117 - - 'Created ') 0 118-+ +SELF. 119 - *** Initialise various global variables. 120 - NOUT=0 121 - NIN=0 122 - IOUT=1 123 - NREC=0 124 - OUT=' ' 125 - LEVEL=0 126 - PATH(0)=1 127 - LAST=1 128 - ** Write the initial pointer record. 129 - CALL DATTIM(DATE,TIME) 130 - TOPIC='Root'//DATE//TIME 131 - NOUT=NOUT+1 132 - WRITE(UNIT=17,REC=NOUT,IOSTAT=IOS,ERR=2015) TOPIC,0,0 1 446 P=HELP D=HLPPACOT 3 PAGE 547 133 - ** Read a line from the file, skipping comment lines. 134 - 10 CONTINUE 0 135-+ +SELF,IF=-CMS. 136 - READ(12,'(A)',IOSTAT=IOS,ERR=2010,END=20) IN 137 - LENIN=LEN(IN) 0 138-+ +SELF,IF=CMS. 139 - READ(12,IOSTAT=IOS,ERR=2010,END=20,NUM=LENIN) IN 140 - IF(LENIN.LT.LEN(IN))IN(LENIN+1:)=' ' 0 141-+ +SELF. 142 - NIN=NIN+1 143 - IF(IN(1:1).EQ.'!')GOTO 10 0 144-+ +SELF,IF=CMS. 145 - * Translate curly brackets when the file is coming from a Vax. 146 - IF(LHLPTR)THEN 147 - DO 30 I=1,LENIN 148 - IF(ICHAR(IN(I:I)).EQ.192)IN(I:I)=CHAR(139) 149 - IF(ICHAR(IN(I:I)).EQ.208)IN(I:I)=CHAR(155) 150 - 30 CONTINUE 151 - ENDIF 0 152-+ +SELF. 153 - ** New heading level. 154 - IF(IN(1:2).NE.' ')THEN 155 - * Empty the buffer. 156 - IF(IOUT.GT.1)THEN 157 - NOUT=NOUT+1 158 - OUT(IOUT-1:IOUT-1)=CHAR(11) 159 - WRITE(UNIT=17,REC=NOUT,IOSTAT=IOS,ERR=2015) OUT 160 - NREC=NREC+1 161 - ELSE 162 - NOUT=NOUT+1 163 - WRITE(UNIT=17,REC=NOUT,IOSTAT=IOS,ERR=2015) CHAR(11) 164 - NREC=NREC+1 165 - ENDIF 166 - IOUT=1 167 - OUT=' ' 168 - * Read the new heading level. 169 - CALL INPRIC(IN(1:2),NEWLEV,0,IFAIL) 170 - IF(IFAIL.NE.0)THEN 171 - PRINT *,' !!!!!! HLPPAC WARNING : Invalid level'// 172 - - ' string "'//IN(1:2)//'" encountered at line', 173 - - NIN,' ; packed help file deleted.' 174 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 175 - CLOSE(UNIT=17,STATUS='DELETE',IOSTAT=IOS,ERR=2030) 176 - RETURN 177 - ENDIF 178 - IF(NEWLEV.GT.LEVEL+1.OR.NEWLEV.LE.0)THEN 179 - PRINT *,' !!!!!! HLPPAC WARNING : Incorrect heading'// 180 - - ' level (',NEWLEV,') encountered at line ',NIN,'.' 181 - PRINT *,' Packed help-file'// 182 - - ' deleted.' 183 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 184 - CLOSE(UNIT=17,STATUS='DELETE',IOSTAT=IOS,ERR=2030) 185 - IFAIL=1 186 - RETURN 187 - ENDIF 188 - IF(NEWLEV.GT.MXHLEV)THEN 189 - PRINT *,' !!!!!! HLPPAC WARNING : Heading level'// 190 - - ' exceeds compilation limit (',NEWLEV,' vs ', 191 - - MXHLEV,') at line ',NIN,'.' 192 - PRINT *,' Packed help-file'// 193 - - ' deleted.' 194 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 195 - CLOSE(UNIT=17,STATUS='DELETE',IOSTAT=IOS,ERR=2030) 196 - IFAIL=1 197 - RETURN 198 - ENDIF 199 - LEVEL=NEWLEV 200 - * Write an almost empty header for this topic, updated later on. 201 - NOUT=NOUT+1 202 - WRITE(UNIT=17,REC=NOUT,IOSTAT=IOS,ERR=2015) IN(3:22),0,0 203 - C print *,' Heading at level ',LEVEL,': ',IN(3:22) 204 - * Update the link record for the next higher level. 205 - READ(UNIT=17,REC=PATH(LEVEL-1),IOSTAT=IOS,ERR=2015) 206 - - TOPIC,NNREC,NSUB,(SUBREC(I),I=1,NSUB) 207 - NSUB=NSUB+1 208 - IF(NSUB.GT.MXSUBT)THEN 209 - PRINT *,' ###### HLPPAC ERROR : The help file'// 210 - - ' cannot be packed because MXSUBT is too small.' 211 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 212 - CLOSE(UNIT=17,STATUS='DELETE',IOSTAT=IOS,ERR=2030) 213 - IFAIL=1 214 - RETURN 215 - ENDIF 216 - SUBREC(NSUB)=NOUT 217 - WRITE(UNIT=17,REC=PATH(LEVEL-1),IOSTAT=IOS,ERR=2015) 218 - - TOPIC,NNREC,NSUB,(SUBREC(I),I=1,NSUB) 219 - * Update the path pointer for this level. 220 - PATH(LEVEL)=NOUT 221 - * Update the number of records the previous item had. 222 - READ(UNIT=17,REC=LAST,IOSTAT=IOS,ERR=2015) 223 - - TOPIC,NNREC,NSUB,(SUBREC(I),I=1,NSUB) 224 - WRITE(UNIT=17,REC=LAST,IOSTAT=IOS,ERR=2015) 225 - - TOPIC,NREC,NSUB,(SUBREC(I),I=1,NSUB) 226 - * Update the pointer to the new last item (this one). 227 - LAST=NOUT 228 - NREC=0 229 - ** Ordinary line, simply written to the file. 230 - ELSE 231 - * Determine the length of the line. 232 - DO 100 I=LENIN,3,-1 233 - IF(IN(I:I).NE.' ')THEN 1 446 P=HELP D=HLPPACOT 4 PAGE 548 234 - N=I 235 - GOTO 110 236 - ENDIF 237 - 100 CONTINUE 238 - N=3 239 - 110 CONTINUE 240 - * Compress lines which contain an HTML reference. 241 - 30 CONTINUE 242 - IF(INDEX(IN(1:N),'"->').NE.0)THEN 243 - ISTART=INDEX(IN(1:N),'"->') 244 - IEND=ISTART+INDEX(IN(ISTART+1:N),'"') 245 - IF(IEND.LE.ISTART)THEN 246 - PRINT *,' !!!!!! HLPPAC WARNING : Reference'// 247 - - ' string at line ',NIN,' not closed;'// 248 - - ' line not compressed.' 249 - GOTO 50 250 - ENDIF 251 - IADD=ISTART 252 - DO 70 I=IEND-1,ISTART,-1 253 - IF(IN(I:I).EQ.' ')THEN 254 - DO 80 J=I+1,IEND-1 255 - IN(IADD:IADD)=IN(J:J) 256 - IADD=IADD+1 257 - 80 CONTINUE 258 - GOTO 90 259 - ENDIF 260 - 70 CONTINUE 261 - 90 CONTINUE 262 - DO 60 I=IEND+1,N 263 - IN(IADD:IADD)=IN(I:I) 264 - IADD=IADD+1 265 - 60 CONTINUE 266 - IN(IADD:)=' ' 267 - N=IADD-1 268 - GOTO 30 269 - ENDIF 270 - 50 CONTINUE 271 - * Add the present line to the buffer, separating by a LF (ASCII 10). 272 - IFIRST=3 273 - 120 CONTINUE 274 - ILAST=MIN(N+1,IFIRST+MXHLRL-1) 275 - IF(IOUT+ILAST-IFIRST.GT.MXHLRL)ILAST=MXHLRL-IOUT+IFIRST 276 - IF(ILAST.EQ.N+1)THEN 277 - IF(ILAST.GT.IFIRST)OUT(IOUT:IOUT+ILAST-IFIRST)= 278 - - IN(IFIRST:ILAST-1)//CHAR(10) 279 - IF(ILAST.EQ.IFIRST)OUT(IOUT:IOUT)=CHAR(10) 280 - ELSE 281 - OUT(IOUT:IOUT+ILAST-IFIRST)=IN(IFIRST:ILAST) 282 - ENDIF 283 - IF(IOUT+ILAST-IFIRST.EQ.MXHLRL)THEN 284 - NOUT=NOUT+1 285 - WRITE(UNIT=17,REC=NOUT,IOSTAT=IOS,ERR=2015) OUT 286 - IOUT=1 287 - OUT=' ' 288 - NREC=NREC+1 289 - ELSE 290 - IOUT=IOUT+ILAST-IFIRST+1 291 - ENDIF 292 - IFIRST=ILAST+1 293 - IF(IFIRST.LE.N+1)GOTO 120 294 - ENDIF 295 - GOTO 10 296 - *** Jump to this point at EOF on the raw help file. 297 - 20 CONTINUE 298 - * Write the current record to the file, if not empty. 299 - IF(IOUT.GT.1)THEN 300 - NOUT=NOUT+1 301 - OUT(IOUT-1:IOUT-1)=CHAR(11) 302 - WRITE(UNIT=17,REC=NOUT,IOSTAT=IOS,ERR=2015) OUT 303 - NREC=NREC+1 304 - ELSE 305 - NOUT=NOUT+1 306 - WRITE(UNIT=17,REC=NOUT,IOSTAT=IOS,ERR=2015) CHAR(11) 307 - NREC=NREC+1 308 - ENDIF 309 - * Update the number of records the final item had. 310 - READ(UNIT=17,REC=LAST,IOSTAT=IOS,ERR=2015) 311 - - TOPIC,NNREC,NSUB,(SUBREC(I),I=1,NSUB) 312 - WRITE(UNIT=17,REC=LAST,IOSTAT=IOS,ERR=2015) 313 - - TOPIC,NREC,NSUB,(SUBREC(I),I=1,NSUB) 314 - * Close the files. 315 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 316 - CLOSE(UNIT=17,IOSTAT=IOS,ERR=2030) 317 - * Signal to the calling routine that everything worked well. 318 - IFAIL=0 319 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ HLPPAC DEBUG : Reference'', 320 - - '' count of the number of records:'',I5)') NOUT 321 - *** Keep track of CPU time consumption. 322 - CALL TIMLOG('Packing the help file') 323 - RETURN 324 - *** Handle I/O errors. 325 - 2010 CONTINUE 326 - PRINT *,' ###### HLPPAC ERROR : I/O error reading the raw'// 327 - - ' help file at line ',NIN,' ; packed help file deleted.' 328 - CALL INPIOS(IOS) 329 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 330 - CLOSE(UNIT=17,STATUS='DELETE',IOSTAT=IOS,ERR=2030) 331 - IFAIL=1 332 - RETURN 333 - 2015 CONTINUE 334 - PRINT *,' ###### HLPPAC ERROR : I/O error on the direct'// 335 - - ' access help file ; dataset not prepared.' 336 - CALL INPIOS(IOS) 337 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 338 - CLOSE(UNIT=17,STATUS='DELETE',IOSTAT=IOS,ERR=2030) 339 - IFAIL=1 1 446 P=HELP D=HLPPACOT 5 PAGE 549 340 - RETURN 341 - 2020 CONTINUE 342 - PRINT *,' ###### HLPPAC ERROR : Unable to open a help'// 343 - - ' file ; direct access dataset not prepared.' 344 - CALL INPIOS(IOS) 345 - IFAIL=1 346 - RETURN 347 - 2030 CONTINUE 348 - PRINT *,' !!!!!! HLPPAC WARNING : Unable to close the raw or'// 349 - - ' the packed help file ; direct access file probably OK.' 350 - CALL INPIOS(IOS) 351 - RETURN 352 - END 447 GARFIELD ================================================== P=HELP D=HLPPRT 1 ============================ 0 + +DECK,HLPPRT,IF=APOLLO,CMS,UNIX. 1 - SUBROUTINE HLPPRT(IREC,INDENT,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HLPPRT - Prints the item starting at record IREC 4 - * (Last changed on 20/ 7/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9 - INTEGER SUBREC(MXSUBT),NREC,NSUB,J,IOUT,NSTR,I0,I1,IREC,INDENT, 10 - - IFAIL,IOS 11 - CHARACTER*20 TOPIC 12 - CHARACTER*132 OUT 13 - CHARACTER*(MXSUBT) BLANK 14 - CHARACTER*(MXHLRL) STRING 15 - *** Set BLANK to blank. 16 - BLANK=' ' 17 - *** Read the heading record and loop over all records of the item. 18 - READ(UNIT=17,REC=IREC,IOSTAT=IOS,ERR=2010) 19 - - TOPIC,NREC,NSUB,(SUBREC(J),J=1,MIN(MXSUBT,NSUB)) 20 - IF(NSUB.GT.MXSUBT)THEN 21 - PRINT *,' ###### HLPPRT ERROR : Number of subrecords'// 22 - - ' exceeds MXSUBT; recompile with at least ',NSUB 23 - IFAIL=1 24 - RETURN 25 - ENDIF 26 - * Print the TOPIC as a heading. 27 - WRITE(LUNOUT,'(1X,A,/)') BLANK(1:INDENT)//TOPIC 28 - * Record loop. 29 - OUT=' ' 30 - IOUT=1 31 - DO 10 J=1,NREC 32 - READ(UNIT=17,REC=IREC+J,IOSTAT=IOS,ERR=2010) STRING 33 - * Determine the length of the string. 34 - NSTR=INDEX(STRING,CHAR(11))-1 35 - IF(NSTR.EQ.-1)THEN 36 - NSTR=MXHLRL 37 - ELSEIF(NSTR.EQ.0)THEN 38 - GOTO 10 39 - ENDIF 40 - * Figure out where the line-breaks are. 41 - I0=1 42 - 20 CONTINUE 43 - I1=I0+INDEX(STRING(I0:NSTR),CHAR(10))-2 44 - * Take the end of the line in case there is no LF left. 45 - IF(I1.EQ.I0-2)I1=NSTR 46 - * Print or skip a line if I1 < I0. 47 - IF(I1.LT.I0)THEN 48 - IF(IOUT.GT.1)THEN 49 - WRITE(LUNOUT,'(1X,A)') BLANK(1:INDENT)//OUT(1:IOUT-1) 50 - ELSE 51 - WRITE(LUNOUT,'(1X)') 52 - ENDIF 53 - OUT=' ' 54 - IOUT=1 55 - I0=I1+2 56 - IF(I0.LE.NSTR)GOTO 20 57 - * Restrict when the total record would be too long. 58 - ELSEIF(IOUT+I1-I0.GT.LEN(OUT))THEN 59 - PRINT *,' ###### HLPPRT ERROR : Record longer'// 60 - - ' than ',LEN(OUT),' characters encountered.' 61 - I1=LEN(OUT)+I0-IOUT 62 - OUT(IOUT:IOUT+I1-I0)=STRING(I0:I1) 63 - IOUT=IOUT+I1-I0+1 64 - WRITE(LUNOUT,'(1X,A)') 65 - - BLANK(1:INDENT)//OUT(1:IOUT-1) 66 - OUT=' ' 67 - IOUT=1 68 - I0=I1+1 69 - IF(I0.LE.NSTR)GOTO 20 70 - * Buffer when no line-break is present at the end of record. 71 - ELSEIF(I1.EQ.NSTR.AND.STRING(NSTR:NSTR).NE.CHAR(10))THEN 72 - OUT(IOUT:IOUT+I1-I0)=STRING(I0:I1) 73 - IOUT=IOUT+I1-I0+1 74 - I0=I1+1 75 - IF(I0.LE.NSTR)GOTO 20 76 - * Output when the line-break is seen. 77 - ELSE 78 - OUT(IOUT:IOUT+I1-I0)=STRING(I0:I1) 79 - WRITE(LUNOUT,'(1X,A)') BLANK(1:INDENT)//OUT(1:IOUT+I1-I0) 80 - OUT=' ' 81 - IOUT=1 82 - I0=I1+2 83 - IF(I0.LE.NSTR)GOTO 20 84 - ENDIF 85 - * Next record. 86 - 10 CONTINUE 87 - *** Print the remainder of the last record. 88 - IF(IOUT.GT.1)WRITE(LUNOUT,'(1X,A)') 89 - - BLANK(1:INDENT)//OUT(1:IOUT-1) 1 447 P=HELP D=HLPPRT 2 PAGE 550 90 - WRITE(LUNOUT,'('' '')') 91 - *** Things worked it seems. 92 - IFAIL=0 93 - RETURN 94 - *** Handle I/O errors. 95 - 2010 CONTINUE 96 - PRINT *,' ###### HLPPRT ERROR : I/O error on the HELP file.' 97 - CALL INPIOS(IOS) 98 - IFAIL=1 99 - END 448 GARFIELD ================================================== P=HELP D=HLPSUB 1 ============================ 0 + +DECK,HLPSUB,IF=APOLLO,CMS,UNIX. 1 - SUBROUTINE HLPSUB(IREC,INDENT,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * HLPSUB - List the subtopics for the item starting at record IREC. 4 - *----------------------------------------------------------------------- 5.- +SEQ,DIMENSIONS. 6.- +SEQ,PRINTPLOT. 7 - INTEGER SUBREC(MXSUBT) 8 - CHARACTER*20 TOPIC 9 - CHARACTER*80 OUT 10 - CHARACTER*(MXSUBT) BLANK 11 - *** Set BLANK to blank. 12 - BLANK=' ' 13 - *** Read the heading record and loop over all records of the item. 14 - READ(UNIT=17,REC=IREC,IOSTAT=IOS,ERR=2010) 15 - - TOPIC,NREC,NSUB,(SUBREC(J),J=1,MIN(MXSUBT,NSUB)) 16 - IF(NSUB.GT.MXSUBT)THEN 17 - PRINT *,' ###### HLPSUB ERROR : Number of subrecords'// 18 - - ' exceeds MXSUBT; recompile with at least ',NSUB 19 - IFAIL=1 20 - RETURN 21 - ENDIF 22 - *** Last record done, print the candidate subtopics. 23 - IF(NSUB.GT.0)THEN 24 - * Print a heading. 25 - WRITE(LUNOUT,'(/,1X,A,/)') 26 - - BLANK(1:INDENT)//'Additional information available:' 27 - OUT=' ' 28 - IOUT=1 29 - * Pick up the topics one by one. 30 - DO 100 I=1,NSUB 31 - READ(UNIT=17,REC=SUBREC(I),IOSTAT=IOS,ERR=2010) TOPIC 32 - * Figure out how long the topic is. 33 - DO 110 J=20,1,-1 34 - IF(TOPIC(J:J).NE.' ')THEN 35 - NTOPIC=J 36 - GOTO 120 37 - ENDIF 38 - 110 CONTINUE 39 - * Substitute a string if empty. 40 - TOPIC='< not named >' 41 - NTOPIC=13 42 - 120 CONTINUE 43 - * Output the string if the new topic won't fit anymore. 44 - IF(INDENT+IOUT+NTOPIC-1.GE.80)THEN 45 - WRITE(LUNOUT,'(1X,A)') BLANK(1:INDENT)//OUT(1:IOUT) 46 - IOUT=1 47 - OUT=' ' 48 - ENDIF 49 - * Store the subtopic names in an output string, properly tabbed. 50 - OUT(IOUT:IOUT+NTOPIC-1)=TOPIC(1:NTOPIC) 51 - DO 130 J=1,61,15 52 - IF(OUT(MAX(1,J-2):).EQ.' ')THEN 53 - IOUT=J 54 - GOTO 100 55 - ENDIF 56 - 130 CONTINUE 57 - * Output the string if the new topic won't fit anymore. 58 - WRITE(LUNOUT,'(1X,A)') BLANK(1:INDENT)//OUT(1:IOUT+NTOPIC-1) 59 - IOUT=1 60 - OUT=' ' 61 - 100 CONTINUE 62 - * Don't forget to output the last piece of string. 63 - WRITE(LUNOUT,'(1X,A)') BLANK(1:INDENT)//OUT(1:IOUT) 64 - ELSE 65 - WRITE(LUNOUT,'(/,'' No subtopics.'',/)') 66 - ENDIF 67 - *** Things worked it seems. 68 - IFAIL=0 69 - RETURN 70 - *** Handle I/O errors. 71 - 2010 CONTINUE 72 - PRINT *,' ###### HLPSUB ERROR : I/O error on the HELP file.' 73 - CALL INPIOS(IOS) 74 - IFAIL=1 75 - END 449 GARFIELD ================================================== P=CELL D= 1 ============================ 0 + +PATCH,CELL. 450 GARFIELD ================================================== P=CELL D=CELCAL 1 ============================ 0 + +DECK,CELCAL. 1 - SUBROUTINE CELCAL(INSTR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * CELCAL - Processes cell related procedure calls. 4 - * (Last changed on 1/12/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 1 450 P=CELL D=CELCAL 2 PAGE 551 9.- +SEQ,ALGDATA. 10 - INTEGER INPCMX,IFAIL1,IFAIL2,IFAIL3,ISTR,IAUX,NARG,IPROC,NC,I,IW, 11 - - INSTR,IFAIL 12 - EXTERNAL INPCMX 13 - *** Assume the CALL will fail. 14 - IFAIL=1 15 - *** Verify that we really have a cell. 16 - IF(.NOT.CELSET)THEN 17 - PRINT *,' !!!!!! CELCAL WARNING : Cell data not available'// 18 - - ' ; call not executed.' 19 - RETURN 20 - ENDIF 21 - *** Some easy reference variables. 22 - NARG=INS(INSTR,3) 23 - IPROC=INS(INSTR,1) 24 - ** Get general information about the cell. 25 - IF(IPROC.EQ.-11)THEN 26 - * Check number of arguments. 27 - IF(NARG.GT.4)THEN 28 - PRINT *,' !!!!!! CELCAL WARNING : Incorrect number'// 29 - - ' of arguments for GET_CELL_DATA.' 30 - RETURN 31 - * Check the the results can be transferred back. 32 - ELSEIF((NARG.GE.1.AND.ARGREF(1,1).GE.2).OR. 33 - - (NARG.GE.2.AND.ARGREF(2,1).GE.2).OR. 34 - - (NARG.GE.3.AND.ARGREF(3,1).GE.2).OR. 35 - - (NARG.GE.4.AND.ARGREF(4,1).GE.2))THEN 36 - PRINT *,' !!!!!! CELCAL WARNING : Some arguments'// 37 - - ' of GET_CELL_DATA can not be modified.' 38 - RETURN 39 - ENDIF 40 - * Variables already in use as strings ? 41 - DO 200 ISTR=1,NARG 42 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 43 - 200 CONTINUE 44 - * Store the cell information. 45 - IF(NARG.GE.1)THEN 46 - ARG(1)=REAL(NWIRE) 47 - MODARG(1)=2 48 - ENDIF 49 - IF(NARG.GE.2)THEN 50 - CALL STRBUF('STORE',IAUX,TYPE,3,IFAIL1) 51 - ARG(2)=REAL(IAUX) 52 - MODARG(2)=1 53 - ELSE 54 - IFAIL1=0 55 - ENDIF 56 - IF(NARG.GE.3)THEN 57 - IF(POLAR)THEN 58 - CALL STRBUF('STORE',IAUX,'Polar',5,IFAIL2) 59 - ELSEIF(TUBE)THEN 60 - CALL STRBUF('STORE',IAUX,'Tube',4,IFAIL2) 61 - ELSE 62 - CALL STRBUF('STORE',IAUX,'Cartesian',9,IFAIL2) 63 - ENDIF 64 - ARG(3)=REAL(IAUX) 65 - MODARG(3)=1 66 - ELSE 67 - IFAIL2=0 68 - ENDIF 69 - IF(NARG.GE.4)THEN 70 - DO 300 I=LEN(CELLID),1,-1 71 - IF(CELLID(I:I).NE.' ')THEN 72 - NC=I 73 - GOTO 310 74 - ENDIF 75 - 300 CONTINUE 76 - NC=1 77 - 310 CONTINUE 78 - CALL STRBUF('STORE',IAUX,CELLID,NC,IFAIL3) 79 - ARG(4)=REAL(IAUX) 80 - MODARG(4)=1 81 - ELSE 82 - IFAIL3=0 83 - ENDIF 84 - * Error processing. 85 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0) 86 - - PRINT *,' !!!!!! CELCAL WARNING : Error storing'// 87 - - ' strings for GET_CELL_DATA.' 88 - *** Get the cell size. 89 - ELSEIF(IPROC.EQ.-12)THEN 90 - * Check number of arguments. 91 - IF(NARG.NE.6.AND.NARG.NE.4)THEN 92 - PRINT *,' !!!!!! CELCAL WARNING : Incorrect number'// 93 - - ' of arguments for GET_CELL_SIZE.' 94 - RETURN 95 - * Check the the results can be transferred back. 96 - ELSEIF(ARGREF(1,1).GE.2.OR.ARGREF(2,1).GE.2.OR. 97 - - ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2.OR. 98 - - (NARG.EQ.6.AND.ARGREF(5,1).GE.2).OR. 99 - - (NARG.EQ.6.AND.ARGREF(6,1).GE.2))THEN 100 - PRINT *,' !!!!!! CELCAL WARNING : Some arguments'// 101 - - ' of GET_CELL_SIZE can not be modified.' 102 - RETURN 103 - ENDIF 104 - * Variables already in use as strings ? 105 - DO 210 ISTR=1,NARG 106 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 107 - 210 CONTINUE 108 - * Store the cell size. 109 - IF(NARG.EQ.4)THEN 110 - ARG(1)=XMIN 111 - MODARG(1)=2 112 - ARG(2)=YMIN 113 - MODARG(2)=2 114 - ARG(3)=XMAX 1 450 P=CELL D=CELCAL 3 PAGE 552 115 - MODARG(3)=2 116 - ARG(4)=YMAX 117 - MODARG(4)=2 118 - ELSE 119 - ARG(1)=XMIN 120 - MODARG(1)=2 121 - ARG(2)=YMIN 122 - MODARG(2)=2 123 - ARG(3)=ZMIN 124 - MODARG(3)=2 125 - ARG(4)=XMAX 126 - MODARG(4)=2 127 - ARG(5)=YMAX 128 - MODARG(5)=2 129 - ARG(6)=ZMAX 130 - MODARG(6)=2 131 - ENDIF 132 - *** Get wire information. 133 - ELSEIF(IPROC.EQ.-13)THEN 134 - * Check number of arguments. 135 - IF(NARG.LT.2.OR.NARG.GT.10)THEN 136 - PRINT *,' !!!!!! CELCAL WARNING : Incorrect number'// 137 - - ' of arguments for GET_WIRE_DATA.' 138 - RETURN 139 - * Check the the results can be transferred back. 140 - ELSEIF((NARG.GE.2.AND.ARGREF(2,1).GE.2).OR. 141 - - (NARG.GE.3.AND.ARGREF(3,1).GE.2).OR. 142 - - (NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. 143 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. 144 - - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. 145 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. 146 - - (NARG.GE.8.AND.ARGREF(8,1).GE.2).OR. 147 - - (NARG.GE.9.AND.ARGREF(9,1).GE.2).OR. 148 - - (NARG.GE.10.AND.ARGREF(10,1).GE.2))THEN 149 - PRINT *,' !!!!!! CELCAL WARNING : Some arguments'// 150 - - ' of GET_WIRE_DATA can not be modified.' 151 - RETURN 152 - ENDIF 153 - * Verify the wire number. 154 - IF(MODARG(1).NE.2.OR.ABS(ARG(1)-ANINT(ARG(1))).GT.1E-3.OR. 155 - - NINT(ARG(1)).LE.0.OR.NINT(ARG(1)).GT.NWIRE)THEN 156 - PRINT *,' CELCAL WARNING : The wire number in the'// 157 - - ' GET_WIRE_DATA call is not valid.' 158 - RETURN 159 - ENDIF 160 - * Variables already in use as strings ? 161 - DO 220 ISTR=2,NARG 162 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 163 - 220 CONTINUE 164 - * Store the wire information. 165 - IW=NINT(ARG(1)) 166 - IF(NARG.GE.2)THEN 167 - ARG(2)=X(IW) 168 - MODARG(2)=2 169 - ENDIF 170 - IF(NARG.GE.3)THEN 171 - ARG(3)=Y(IW) 172 - MODARG(3)=2 173 - ENDIF 174 - IF(NARG.GE.4)THEN 175 - ARG(4)=V(IW) 176 - MODARG(4)=2 177 - ENDIF 178 - IF(NARG.GE.5)THEN 179 - ARG(5)=D(IW) 180 - MODARG(5)=2 181 - ENDIF 182 - IF(NARG.GE.6)THEN 183 - ARG(6)=E(IW) 184 - MODARG(6)=2 185 - ENDIF 186 - IF(NARG.GE.7)THEN 187 - CALL STRBUF('STORE',IAUX,WIRTYP(IW),1,IFAIL1) 188 - ARG(7)=IAUX 189 - MODARG(7)=1 190 - ELSE 191 - IFAIL1=0 192 - ENDIF 193 - IF(NARG.GE.8)THEN 194 - ARG(8)=U(IW) 195 - MODARG(8)=2 196 - ENDIF 197 - IF(NARG.GE.9)THEN 198 - ARG(9)=W(IW) 199 - MODARG(9)=2 200 - ENDIF 201 - IF(NARG.GE.10)THEN 202 - ARG(10)=DENS(IW) 203 - MODARG(10)=2 204 - ENDIF 205 - * Error processing. 206 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! CELCAL WARNING : Error'// 207 - - ' storing strings for GET_WIRE_DATA.' 208 - *** Get information about the planes in x. 209 - ELSEIF(IPROC.EQ.-14)THEN 210 - * Check number of arguments. 211 - IF(NARG.NE.8)THEN 212 - PRINT *,' !!!!!! CELCAL WARNING : Incorrect number'// 213 - - ' of arguments for GET_X_PLANES.' 214 - RETURN 215 - * Check the the results can be transferred back. 216 - ELSEIF(ARGREF(1,1).GE.2.OR.ARGREF(2,1).GE.2.OR. 217 - - ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2.OR. 218 - - ARGREF(5,1).GE.2.OR.ARGREF(6,1).GE.2.OR. 219 - - ARGREF(7,1).GE.2.OR.ARGREF(8,1).GE.2)THEN 220 - PRINT *,' !!!!!! CELCAL WARNING : Some arguments'// 1 450 P=CELL D=CELCAL 4 PAGE 553 221 - - ' of GET_X_PLANES can not be modified.' 222 - RETURN 223 - ENDIF 224 - * Variables already in use as strings ? 225 - DO 230 ISTR=1,8 226 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 227 - 230 CONTINUE 228 - * Store the information about the planes. 229 - IF(YNPLAN(1))THEN 230 - ARG(1)=1 231 - ARG(2)=COPLAN(1) 232 - ARG(3)=VTPLAN(1) 233 - CALL STRBUF('STORE',IAUX,PLATYP(1),1,IFAIL1) 234 - ARG(4)=REAL(IAUX) 235 - MODARG(1)=3 236 - MODARG(2)=2 237 - MODARG(3)=2 238 - MODARG(4)=1 239 - ELSE 240 - ARG(1)=0 241 - ARG(2)=0 242 - ARG(3)=0 243 - ARG(4)=0 244 - MODARG(1)=3 245 - MODARG(2)=0 246 - MODARG(3)=0 247 - MODARG(4)=0 248 - ENDIF 249 - IF(YNPLAN(2))THEN 250 - ARG(5)=1 251 - ARG(6)=COPLAN(2) 252 - ARG(7)=VTPLAN(2) 253 - CALL STRBUF('STORE',IAUX,PLATYP(2),1,IFAIL1) 254 - ARG(8)=REAL(IAUX) 255 - MODARG(5)=3 256 - MODARG(6)=2 257 - MODARG(7)=2 258 - MODARG(8)=1 259 - ELSE 260 - ARG(5)=0 261 - ARG(6)=0 262 - ARG(7)=0 263 - ARG(8)=0 264 - MODARG(5)=3 265 - MODARG(6)=0 266 - MODARG(7)=0 267 - MODARG(8)=0 268 - ENDIF 269 - *** Get information about the planes in y. 270 - ELSEIF(IPROC.EQ.-15)THEN 271 - * Check number of arguments. 272 - IF(NARG.NE.8)THEN 273 - PRINT *,' !!!!!! CELCAL WARNING : Incorrect number'// 274 - - ' of arguments for GET_Y_PLANES.' 275 - RETURN 276 - * Check the the results can be transferred back. 277 - ELSEIF(ARGREF(1,1).GE.2.OR.ARGREF(2,1).GE.2.OR. 278 - - ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2.OR. 279 - - ARGREF(5,1).GE.2.OR.ARGREF(6,1).GE.2.OR. 280 - - ARGREF(7,1).GE.2.OR.ARGREF(8,1).GE.2)THEN 281 - PRINT *,' !!!!!! CELCAL WARNING : Some arguments'// 282 - - ' of GET_Y_PLANES can not be modified.' 283 - RETURN 284 - ENDIF 285 - * Variables already in use as strings ? 286 - DO 235 ISTR=1,8 287 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 288 - 235 CONTINUE 289 - * Store the information about the planes. 290 - IF(YNPLAN(3))THEN 291 - ARG(1)=1 292 - ARG(2)=COPLAN(3) 293 - ARG(3)=VTPLAN(3) 294 - CALL STRBUF('STORE',IAUX,PLATYP(3),1,IFAIL1) 295 - ARG(4)=REAL(IAUX) 296 - MODARG(1)=3 297 - MODARG(2)=2 298 - MODARG(3)=2 299 - MODARG(4)=1 300 - ELSE 301 - ARG(1)=0 302 - ARG(2)=0 303 - ARG(3)=0 304 - ARG(4)=0 305 - MODARG(1)=3 306 - MODARG(2)=0 307 - MODARG(3)=0 308 - MODARG(4)=0 309 - ENDIF 310 - IF(YNPLAN(4))THEN 311 - ARG(5)=1 312 - ARG(6)=COPLAN(4) 313 - ARG(7)=VTPLAN(4) 314 - CALL STRBUF('STORE',IAUX,PLATYP(4),1,IFAIL1) 315 - ARG(8)=REAL(IAUX) 316 - MODARG(5)=3 317 - MODARG(6)=2 318 - MODARG(7)=2 319 - MODARG(8)=1 320 - ELSE 321 - ARG(5)=0 322 - ARG(6)=0 323 - ARG(7)=0 324 - ARG(8)=0 325 - MODARG(5)=3 326 - MODARG(6)=0 1 450 P=CELL D=CELCAL 5 PAGE 554 327 - MODARG(7)=0 328 - MODARG(8)=0 329 - ENDIF 330 - *** Get information about periodicities. 331 - ELSEIF(IPROC.EQ.-16)THEN 332 - * Check number of arguments. 333 - IF(NARG.NE.4)THEN 334 - PRINT *,' !!!!!! CELCAL WARNING : Incorrect number'// 335 - - ' of arguments for GET_PERIODS.' 336 - RETURN 337 - * Check the the results can be transferred back. 338 - ELSEIF(ARGREF(1,1).GE.2.OR.ARGREF(2,1).GE.2.OR. 339 - - ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2)THEN 340 - PRINT *,' !!!!!! CELCAL WARNING : Some arguments'// 341 - - ' of GET_PERIODS can not be modified.' 342 - RETURN 343 - ENDIF 344 - * Variables already in use ? 345 - DO 240 ISTR=1,4 346 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 347 - 240 CONTINUE 348 - * Store the periodicity information. 349 - MODARG(1)=3 350 - MODARG(2)=2 351 - IF(PERX)THEN 352 - ARG(1)=1 353 - ARG(2)=SX 354 - ELSE 355 - ARG(1)=0 356 - ARG(2)=0 357 - ENDIF 358 - MODARG(3)=3 359 - MODARG(4)=2 360 - IF(PERY)THEN 361 - ARG(3)=1 362 - ARG(4)=SY 363 - ELSE 364 - ARG(3)=0 365 - ARG(4)=0 366 - ENDIF 367 - *** Unknown cell operation. 368 - ELSE 369 - PRINT *,' !!!!!! CELCAL WARNING : Unknown procedure code'// 370 - - ' received; nothing done.' 371 - IFAIL=1 372 - RETURN 373 - ENDIF 374 - *** Seems to have worked. 375 - IFAIL=0 376 - END 451 GARFIELD ================================================== P=CELL D=CELCHK 1 ============================ 0 + +DECK,CELCHK. 1 - SUBROUTINE CELCHK(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * CELCHK - Subroutine checking the wire positions, The equipotential 4 - * planes and the periodicity. Two planes having different 5 - * voltages are not allowed to have a common line, wires are 6 - * not allowed to be at the same position etc. 7 - * This routine determines also the cell-dimensions. 8 - * VARIABLE : WRONG(I) : .TRUE. if wire I will be removed 9 - * IPLAN. : Number of wires with coord > than plane . 10 - * (Last changed on 29/11/00.) 11 - *----------------------------------------------------------------------- 12 - implicit none 13.- +SEQ,DIMENSIONS. 14.- +SEQ,CELLDATA. 15.- +SEQ,FIELDMAP. 16.- +SEQ,PRINTPLOT. 17.- +SEQ,PARAMETERS. 18.- +SEQ,CONSTANTS. 19 - LOGICAL WRONG(MXWIRE),WRMATX(MXMATT),WRMATY(MXMATT),OK, 20 - - SETX,SETY,SETZ,SETV 21 - REAL CONEW1,CONEW2,CONEW3,CONEW4,COHLP,VTHLP,XNEW,YNEW, 22 - - XPRT,YPRT,XPRTI,YPRTI,XPRTJ,YPRTJ,XSEPAR,YSEPAR, 23 - - XAUX1,YAUX1,XAUX2,YAUX2,SMIN,SMAX,GAP 24 - INTEGER IFAIL,I,J,IPLAN1,IPLAN2,IPLAN3,IPLAN4,IWIRE,NXOLD,NYOLD, 25 - - IOUT,NC1,NC2,NC3,NC4,IFAIL1,NELEM,NHLP 26 - CHARACTER*10 USER 27 - CHARACTER*20 STR1,STR2,STR3,STR4 28 - CHARACTER LABHLP 29 - *** Identify the routine. 30 - IF(LIDENT)PRINT *,' /// ROUTINE CELCHK ///' 31 - IFAIL=1 32 - OK=.TRUE. 33 - *** See whether this is a field map cell. 34 - CALL BOOK('INQUIRE','MAP',USER,IFAIL1) 35 - * Unable to tell: reset the field map. 36 - IF(IFAIL1.NE.0)THEN 37 - PRINT *,' !!!!!! CELCHK WARNING : Unable to obtain'// 38 - - ' field map allocation information ; assumed to'// 39 - - ' be a non-field map cell.' 40 - OK=.FALSE. 41 - CALL MAPINT 42 - * Field map chamber: ensure that there are no other elements. 43 - ELSEIF(USER.EQ.'CELL')THEN 44 - IF(TUBE)THEN 45 - TUBE=.FALSE. 46 - PRINT *,' !!!!!! CELCHK WARNING : Field map cell'// 47 - - ' found to have a tube; tube deleted.' 48 - OK=.FALSE. 49 - ENDIF 50 - IF(POLAR)THEN 51 - POLAR=.FALSE. 52 - PRINT *,' !!!!!! CELCHK WARNING : Field map cell'// 1 451 P=CELL D=CELCHK 2 PAGE 555 53 - - ' found to be polar; set to Cartesian.' 54 - OK=.FALSE. 55 - ENDIF 56 - IF(NWIRE.NE.0)THEN 57 - NWIRE=0 58 - PRINT *,' !!!!!! CELCHK WARNING : Wires found in'// 59 - - ' field map cell; wires deleted.' 60 - OK=.FALSE. 61 - ENDIF 62 - IF(YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4))THEN 63 - YNPLAN(1)=.FALSE. 64 - YNPLAN(2)=.FALSE. 65 - YNPLAN(3)=.FALSE. 66 - YNPLAN(4)=.FALSE. 67 - PRINT *,' !!!!!! CELCHK WARNING : Plane found in'// 68 - - ' field map cell; planes deleted.' 69 - OK=.FALSE. 70 - ENDIF 71 - IF(NXMATT.NE.0.OR.NYMATT.NE.0)THEN 72 - NXMATT=0 73 - NYMATT=0 74 - PRINT *,' !!!!!! CELCHK WARNING : Dielectric slab'// 75 - - ' found in a field map cell; dielectrica deleted.' 76 - OK=.FALSE. 77 - ENDIF 78 - IF(NMAP.LE.0.OR..NOT.MAPFLG(1))THEN 79 - PRINT *,' ###### CELCHK ERROR : The field map has'// 80 - - ' no elements or no mesh; cell rejected.' 81 - RETURN 82 - ENDIF 83 - GOTO 3000 84 - ENDIF 85 - *** Checks on the planes, first move the x planes to the basic cell. 86 - IF(PERX)THEN 87 - CONEW1=COPLAN(1)-SX*ANINT(COPLAN(1)/SX) 88 - CONEW2=COPLAN(2)-SX*ANINT(COPLAN(2)/SX) 89 - * Check that they are not one on top of the other. 90 - IF(YNPLAN(1).AND.YNPLAN(2).AND.CONEW1.EQ.CONEW2)THEN 91 - IF(CONEW1.GT.0.0)THEN 92 - CONEW1=CONEW1-SX 93 - ELSE 94 - CONEW2=CONEW2+SX 95 - ENDIF 96 - ENDIF 97 - * Print some warnings if the planes have been moved. 98 - IF((CONEW1.NE.COPLAN(1).AND.YNPLAN(1)).OR. 99 - - (CONEW2.NE.COPLAN(2).AND.YNPLAN(2))) 100 - - PRINT *,' ------ CELCHK MESSAGE : The planes in x or'// 101 - - ' r are moved to the basic period; this should'// 102 - - ' not affect the results.' 103 - COPLAN(1)=CONEW1 104 - COPLAN(2)=CONEW2 105 - * Two planes should now be separated by SX, cancel PERX if not. 106 - IF(YNPLAN(1).AND.YNPLAN(2).AND. 107 - - ABS(COPLAN(2)-COPLAN(1)).NE.SX)THEN 108 - PRINT *,' !!!!!! CELCHK WARNING : The separation of'// 109 - - ' the x or r planes does not match the period;'// 110 - - ' the periodicity is cancelled.' 111 - PERX=.FALSE. 112 - OK=.FALSE. 113 - ENDIF 114 - * If there are two planes left, they should have identical V's. 115 - IF(YNPLAN(1).AND.YNPLAN(2).AND.VTPLAN(1).NE.VTPLAN(2))THEN 116 - PRINT *,' !!!!!! CELCHK WARNING : The voltages of'// 117 - - ' the two x (or r) planes differ;'// 118 - - ' the periodicity is cancelled.' 119 - PERX=.FALSE. 120 - OK=.FALSE. 121 - ENDIF 122 - ENDIF 123 - ** Idem for the y or r planes: move them to the basic period. 124 - IF(PERY)THEN 125 - CONEW3=COPLAN(3)-SY*ANINT(COPLAN(3)/SY) 126 - CONEW4=COPLAN(4)-SY*ANINT(COPLAN(4)/SY) 127 - * Check that they are not one on top of the other. 128 - IF(YNPLAN(3).AND.YNPLAN(4).AND.CONEW3.EQ.CONEW4)THEN 129 - IF(CONEW3.GT.0.0)THEN 130 - CONEW3=CONEW3-SY 131 - ELSE 132 - CONEW4=CONEW4+SY 133 - ENDIF 134 - ENDIF 135 - * Print some warnings if the planes have been moved. 136 - IF((CONEW3.NE.COPLAN(3).AND.YNPLAN(3)).OR. 137 - - (CONEW4.NE.COPLAN(4).AND.YNPLAN(4))) 138 - - PRINT *,' ------ CELCHK MESSAGE : The planes in y'// 139 - - ' are moved to the basic period; this should'// 140 - - ' not affect the results.' 141 - COPLAN(3)=CONEW3 142 - COPLAN(4)=CONEW4 143 - * Two planes should now be separated by SY, cancel PERY if not. 144 - IF(YNPLAN(3).AND.YNPLAN(4).AND. 145 - - ABS(COPLAN(4)-COPLAN(3)).NE.SY)THEN 146 - PRINT *,' !!!!!! CELCHK WARNING : The separation of'// 147 - - ' the two y planes does not match the period;'// 148 - - ' the periodicity is cancelled.' 149 - PERY=.FALSE. 150 - OK=.FALSE. 151 - ENDIF 152 - * If there are two planes left, they should have identical V's. 153 - IF(YNPLAN(3).AND.YNPLAN(4).AND.VTPLAN(3).NE.VTPLAN(4))THEN 154 - PRINT *,' !!!!!! CELCHK WARNING : The voltages of'// 155 - - ' the two y planes differ;'// 156 - - ' the periodicity is cancelled.' 157 - PERY=.FALSE. 158 - OK=.FALSE. 1 451 P=CELL D=CELCHK 3 PAGE 556 159 - ENDIF 160 - ENDIF 161 - ** Check that there is no voltage conflict of crossing planes. 162 - DO 20 I=1,2 163 - DO 10 J=3,4 164 - IF(YNPLAN(I).AND.YNPLAN(J).AND.VTPLAN(I).NE.VTPLAN(J))THEN 165 - PRINT *,' !!!!!! CELCHK WARNING : Conflicting potential of', 166 - - ' 2 crossing planes; one y (or phi) plane is removed.' 167 - YNPLAN(J)=.FALSE. 168 - OK=.FALSE. 169 - ENDIF 170 - 10 CONTINUE 171 - 20 CONTINUE 172 - ** Make sure the the coordinates of the planes are properly ordered. 173 - DO 30 I=1,3,2 174 - IF(YNPLAN(I).AND.YNPLAN(I+1))THEN 175 - IF(COPLAN(I).EQ.COPLAN(I+1))THEN 176 - PRINT *,' !!!!!! CELCHK WARNING : Two planes are on'// 177 - - ' top of each other; one of them is removed.' 178 - YNPLAN(I+1)=.FALSE. 179 - OK=.FALSE. 180 - ENDIF 181 - IF(COPLAN(I).GT.COPLAN(I+1))THEN 182 - IF(LDEBUG)PRINT *,' ++++++ CELCHK DEBUG : Planes ',I, 183 - - ' and ',I+1,' are interchanged.' 184 - COHLP=COPLAN(I) 185 - COPLAN(I)=COPLAN(I+1) 186 - COPLAN(I+1)=COHLP 187 - VTHLP=VTPLAN(I) 188 - VTPLAN(I)=VTPLAN(I+1) 189 - VTPLAN(I+1)=VTHLP 190 - LABHLP=PLATYP(I) 191 - PLATYP(I)=PLATYP(I+1) 192 - PLATYP(I+1)=LABHLP 193 - DO 300 J=1,MXPSTR 194 - SMIN=PLSTR1(I,J,1) 195 - SMAX=PLSTR1(I,J,2) 196 - GAP= PLSTR1(I,J,3) 197 - LABHLP=PSLAB1(I,J) 198 - PLSTR1(I,J,1)=PLSTR1(I+1,J,1) 199 - PLSTR1(I,J,2)=PLSTR1(I+1,J,2) 200 - PLSTR1(I,J,3)=PLSTR1(I+1,J,3) 201 - PSLAB1(I,J)=PSLAB1(I+1,J) 202 - PLSTR1(I+1,J,1)=SMIN 203 - PLSTR1(I+1,J,2)=SMAX 204 - PLSTR1(I+1,J,3)=GAP 205 - PSLAB1(I+1,J)=LABHLP 206 - SMIN=PLSTR2(I,J,1) 207 - SMAX=PLSTR2(I,J,2) 208 - GAP= PLSTR2(I,J,3) 209 - LABHLP=PSLAB2(I,J) 210 - PLSTR2(I,J,1)=PLSTR2(I+1,J,1) 211 - PLSTR2(I,J,2)=PLSTR2(I+1,J,2) 212 - PLSTR2(I,J,3)=PLSTR2(I+1,J,3) 213 - PSLAB2(I,J)=PSLAB2(I+1,J) 214 - PLSTR2(I+1,J,1)=SMIN 215 - PLSTR2(I+1,J,2)=SMAX 216 - PLSTR2(I+1,J,3)=GAP 217 - PSLAB2(I+1,J)=LABHLP 218 - 300 CONTINUE 219 - NHLP=NPSTR1(I) 220 - NPSTR1(I)=NPSTR1(I+1) 221 - NPSTR1(I+1)=NHLP 222 - NHLP=NPSTR2(I) 223 - NPSTR2(I)=NPSTR2(I+1) 224 - NPSTR2(I+1)=NHLP 225 - ENDIF 226 - ENDIF 227 - 30 CONTINUE 228 - *** Checks on the wires, start moving them to the basic x period. 229 - IF(PERX)THEN 230 - DO 40 I=1,NWIRE 231 - XNEW=X(I)-SX*ANINT(X(I)/SX) 232 - IF(ANINT(X(I)/SX).NE.0)THEN 233 - XPRT=X(I) 234 - YPRT=Y(I) 235 - IF(POLAR)CALL CFMRTP(XPRT,YPRT,XPRT,YPRT,1) 236 - CALL OUTFMT(XPRT,2,STR1,NC1,'LEFT') 237 - CALL OUTFMT(YPRT,2,STR2,NC2,'LEFT') 238 - PRINT *,' ------ CELCHK MESSAGE : The '//WIRTYP(I)// 239 - - '-wire at ('//STR1(1:NC1)//','//STR2(1:NC2)// 240 - - ') is moved to the basic x' 241 - PRINT *,' (or r) period;'// 242 - - ' this should not affect the results.' 243 - ENDIF 244 - X(I)=XNEW 245 - 40 CONTINUE 246 - ENDIF 247 - ** In case of y-periodicity, all wires should be in the first y-period. 248 - IF(TUBE.AND.PERY)THEN 249 - DO 55 I=1,NWIRE 250 - XNEW=X(I) 251 - YNEW=Y(I) 252 - CALL CFMCTP(XNEW,YNEW,XNEW,YNEW,1) 253 - IF(ANINT((PI*YNEW)/(SY*180.0)).NE.0)THEN 254 - CALL OUTFMT(X(I),2,STR1,NC1,'LEFT') 255 - CALL OUTFMT(Y(I),2,STR2,NC2,'LEFT') 256 - PRINT *,' ------ CELCHK MESSAGE : The '//WIRTYP(I)// 257 - - '-wire at ('//STR1(1:NC1)//','//STR2(1:NC2)// 258 - - ') is moved to the basic phi period;' 259 - PRINT *,' this should not', 260 - - ' affect the results.' 261 - YNEW=YNEW-180*SY*ANINT((PI*YNEW)/(SY*180.0))/PI 262 - CALL CFMPTC(XNEW,YNEW,X(I),Y(I),1) 263 - ENDIF 264 - 55 CONTINUE 1 451 P=CELL D=CELCHK 4 PAGE 557 265 - ELSEIF(PERY)THEN 266 - DO 50 I=1,NWIRE 267 - YNEW=Y(I)-SY*ANINT(Y(I)/SY) 268 - IF(ANINT(Y(I)/SY).NE.0)THEN 269 - XPRT=X(I) 270 - YPRT=Y(I) 271 - IF(POLAR)CALL CFMRTP(XPRT,YPRT,XPRT,YPRT,1) 272 - CALL OUTFMT(XPRT,2,STR1,NC1,'LEFT') 273 - CALL OUTFMT(YPRT,2,STR2,NC2,'LEFT') 274 - PRINT *,' ------ CELCHK MESSAGE : The '//WIRTYP(I)// 275 - - '-wire at ('//STR1(1:NC1)//','//STR2(1:NC2)// 276 - - ') is moved to the basic y period;' 277 - PRINT *,' this should not', 278 - - ' affect the results.' 279 - ENDIF 280 - Y(I)=YNEW 281 - 50 CONTINUE 282 - ENDIF 283 - *** Make sure the plane numbering is standard: P1 wires P2, P3 wires P4. 284 - IPLAN1=0 285 - IPLAN2=0 286 - IPLAN3=0 287 - IPLAN4=0 288 - DO 60 I=1,NWIRE 289 - IF(YNPLAN(1).AND.X(I).LE.COPLAN(1))IPLAN1=IPLAN1+1 290 - IF(YNPLAN(2).AND.X(I).LE.COPLAN(2))IPLAN2=IPLAN2+1 291 - IF(YNPLAN(3).AND.Y(I).LE.COPLAN(3))IPLAN3=IPLAN3+1 292 - IF(YNPLAN(4).AND.Y(I).LE.COPLAN(4))IPLAN4=IPLAN4+1 293 - 60 CONTINUE 294 - * find out whether smaller (-1) or larger (+1) coord. are to be kept. 295 - IF(YNPLAN(1).AND.YNPLAN(2))THEN 296 - IF(IPLAN1.GT.NWIRE/2)THEN 297 - YNPLAN(2)=.FALSE. 298 - IPLAN1=-1 299 - ELSE 300 - IPLAN1=+1 301 - ENDIF 302 - IF(IPLAN2.LT.NWIRE/2)THEN 303 - YNPLAN(1)=.FALSE. 304 - IPLAN2=+1 305 - ELSE 306 - IPLAN2=-1 307 - ENDIF 308 - ENDIF 309 - IF(YNPLAN(1).AND..NOT.YNPLAN(2))THEN 310 - IF(IPLAN1.GT.NWIRE/2)THEN 311 - IPLAN1=-1 312 - ELSE 313 - IPLAN1=+1 314 - ENDIF 315 - ENDIF 316 - IF(YNPLAN(2).AND..NOT.YNPLAN(1))THEN 317 - IF(IPLAN2.LT.NWIRE/2)THEN 318 - IPLAN2=+1 319 - ELSE 320 - IPLAN2=-1 321 - ENDIF 322 - ENDIF 323 - IF(YNPLAN(3).AND.YNPLAN(4))THEN 324 - IF(IPLAN3.GT.NWIRE/2)THEN 325 - YNPLAN(4)=.FALSE. 326 - IPLAN3=-1 327 - ELSE 328 - IPLAN3=+1 329 - ENDIF 330 - IF(IPLAN4.LT.NWIRE/2)THEN 331 - YNPLAN(3)=.FALSE. 332 - IPLAN4=+1 333 - ELSE 334 - IPLAN4=-1 335 - ENDIF 336 - ENDIF 337 - IF(YNPLAN(3).AND..NOT.YNPLAN(4))THEN 338 - IF(IPLAN3.GT.NWIRE/2)THEN 339 - IPLAN3=-1 340 - ELSE 341 - IPLAN3=+1 342 - ENDIF 343 - ENDIF 344 - IF(YNPLAN(4).AND..NOT.YNPLAN(3))THEN 345 - IF(IPLAN4.LT.NWIRE/2)THEN 346 - IPLAN4=+1 347 - ELSE 348 - IPLAN4=-1 349 - ENDIF 350 - ENDIF 351 - * Adapt the numbering of the planes if necessary. 352 - IF(IPLAN1.EQ.-1)THEN 353 - YNPLAN(1)=.FALSE. 354 - YNPLAN(2)=.TRUE. 355 - COPLAN(2)=COPLAN(1) 356 - VTPLAN(2)=VTPLAN(1) 357 - PLATYP(2)=PLATYP(1) 358 - DO 310 J=1,MXPSTR 359 - PLSTR1(2,J,1)=PLSTR1(1,J,1) 360 - PLSTR1(2,J,2)=PLSTR1(1,J,2) 361 - PLSTR1(2,J,3)=PLSTR1(1,J,3) 362 - PSLAB1(2,J)= PSLAB1(1,J) 363 - PLSTR2(2,J,1)=PLSTR2(1,J,1) 364 - PLSTR2(2,J,2)=PLSTR2(1,J,2) 365 - PLSTR2(2,J,3)=PLSTR2(1,J,3) 366 - PSLAB2(2,J)= PSLAB2(1,J) 367 - 310 CONTINUE 368 - NPSTR1(2)= NPSTR1(1) 369 - NPSTR2(2)= NPSTR2(1) 370 - NPSTR1(1)= 0 1 451 P=CELL D=CELCHK 5 PAGE 558 371 - NPSTR2(1)= 0 372 - ENDIF 373 - IF(IPLAN2.EQ.+1)THEN 374 - YNPLAN(2)=.FALSE. 375 - YNPLAN(1)=.TRUE. 376 - COPLAN(1)=COPLAN(2) 377 - VTPLAN(1)=VTPLAN(2) 378 - PLATYP(1)=PLATYP(2) 379 - DO 320 J=1,MXPSTR 380 - PLSTR1(1,J,1)=PLSTR1(2,J,1) 381 - PLSTR1(1,J,2)=PLSTR1(2,J,2) 382 - PLSTR1(1,J,3)=PLSTR1(2,J,3) 383 - PSLAB1(1,J)= PSLAB1(2,J) 384 - PLSTR2(1,J,1)=PLSTR2(2,J,1) 385 - PLSTR2(1,J,2)=PLSTR2(2,J,2) 386 - PLSTR2(1,J,3)=PLSTR2(2,J,3) 387 - PSLAB2(1,J)= PSLAB2(2,J) 388 - 320 CONTINUE 389 - NPSTR1(1)= NPSTR1(2) 390 - NPSTR2(1)= NPSTR2(2) 391 - NPSTR1(2)= 0 392 - NPSTR2(2)= 0 393 - ENDIF 394 - IF(IPLAN3.EQ.-1)THEN 395 - YNPLAN(3)=.FALSE. 396 - YNPLAN(4)=.TRUE. 397 - COPLAN(4)=COPLAN(3) 398 - VTPLAN(4)=VTPLAN(3) 399 - PLATYP(4)=PLATYP(3) 400 - DO 330 J=1,MXPSTR 401 - PLSTR1(4,J,1)=PLSTR1(3,J,1) 402 - PLSTR1(4,J,2)=PLSTR1(3,J,2) 403 - PLSTR1(4,J,3)=PLSTR1(3,J,3) 404 - PSLAB1(4,J)= PSLAB1(3,J) 405 - PLSTR2(4,J,1)=PLSTR2(3,J,1) 406 - PLSTR2(4,J,2)=PLSTR2(3,J,2) 407 - PLSTR2(4,J,3)=PLSTR2(3,J,3) 408 - PSLAB2(4,J)= PSLAB2(3,J) 409 - 330 CONTINUE 410 - NPSTR1(4)= NPSTR1(3) 411 - NPSTR2(4)= NPSTR2(3) 412 - NPSTR1(3)= 0 413 - NPSTR2(3)= 0 414 - ENDIF 415 - IF(IPLAN4.EQ.+1)THEN 416 - YNPLAN(4)=.FALSE. 417 - YNPLAN(3)=.TRUE. 418 - COPLAN(3)=COPLAN(4) 419 - VTPLAN(3)=VTPLAN(4) 420 - PLATYP(3)=PLATYP(4) 421 - DO 340 J=1,MXPSTR 422 - PLSTR1(3,J,1)=PLSTR1(4,J,1) 423 - PLSTR1(3,J,2)=PLSTR1(4,J,2) 424 - PLSTR1(3,J,3)=PLSTR1(4,J,3) 425 - PSLAB1(3,J)= PSLAB1(4,J) 426 - PLSTR2(3,J,1)=PLSTR2(4,J,1) 427 - PLSTR2(3,J,2)=PLSTR2(4,J,2) 428 - PLSTR2(3,J,3)=PLSTR2(4,J,3) 429 - PSLAB2(3,J)= PSLAB2(4,J) 430 - 340 CONTINUE 431 - NPSTR1(3)= NPSTR1(4) 432 - NPSTR2(3)= NPSTR2(4) 433 - NPSTR1(4)= 0 434 - NPSTR2(4)= 0 435 - ENDIF 436 - *** Second pass for the wires, check position relative to the planes. 437 - DO 70 I=1,NWIRE 438 - WRONG(I)=.FALSE. 439 - IF(YNPLAN(1).AND.X(I)-.5*D(I).LE.COPLAN(1))WRONG(I)=.TRUE. 440 - IF(YNPLAN(2).AND.X(I)+.5*D(I).GE.COPLAN(2))WRONG(I)=.TRUE. 441 - IF(YNPLAN(3).AND.Y(I)-.5*D(I).LE.COPLAN(3))WRONG(I)=.TRUE. 442 - IF(YNPLAN(4).AND.Y(I)+.5*D(I).GE.COPLAN(4))WRONG(I)=.TRUE. 443 - IF(TUBE)THEN 444 - CALL INTUBE(X(I),Y(I),COTUBE,NTUBE,IOUT) 445 - IF(IOUT.NE.0)THEN 446 - CALL OUTFMT(X(I),2,STR1,NC1,'LEFT') 447 - CALL OUTFMT(Y(I),2,STR2,NC2,'LEFT') 448 - PRINT *,' !!!!!! CELCHK WARNING : The '//WIRTYP(I)// 449 - - '-wire at ('//STR1(1:NC1)//','//STR2(1:NC2)// 450 - - ') is located outside the tube; removed.' 451 - WRONG(I)=.TRUE. 452 - OK=.FALSE. 453 - ENDIF 454 - ELSEIF(WRONG(I))THEN 455 - XPRT=X(I) 456 - YPRT=Y(I) 457 - IF(POLAR)CALL CFMRTP(XPRT,YPRT,XPRT,YPRT,1) 458 - CALL OUTFMT(XPRT,2,STR1,NC1,'LEFT') 459 - CALL OUTFMT(YPRT,2,STR2,NC2,'LEFT') 460 - PRINT *,' !!!!!! CELCHK WARNING : The '//WIRTYP(I)// 461 - - '-wire at ('//STR1(1:NC1)//','//STR2(1:NC2)// 462 - - ') is located outside the planes; it is removed.' 463 - OK=.FALSE. 464 - ELSEIF((PERX.AND.D(I).GE.SX).OR.(PERY.AND.D(I).GE.SY))THEN 465 - XPRT=X(I) 466 - YPRT=Y(I) 467 - IF(POLAR)CALL CFMRTP(XPRT,YPRT,XPRT,YPRT,1) 468 - CALL OUTFMT(XPRT,2,STR1,NC1,'LEFT') 469 - CALL OUTFMT(YPRT,2,STR2,NC2,'LEFT') 470 - PRINT *,' !!!!!! CELCHK WARNING : The diameter of the '// 471 - - WIRTYP(I)//'-wire at ('//STR1(1:NC1)//','// 472 - - STR2(1:NC2)//') exceeds 1 period; it is removed.' 473 - WRONG(I)=.TRUE. 474 - OK=.FALSE. 475 - ENDIF 476 - 70 CONTINUE 1 451 P=CELL D=CELCHK 6 PAGE 559 477 - ** Check the wire spacing. 478 - DO 90 I=1,NWIRE 479 - IF(WRONG(I))GOTO 90 480 - DO 80 J=I+1,NWIRE 481 - IF(WRONG(J))GOTO 80 482 - IF(TUBE)THEN 483 - IF(PERY)THEN 484 - CALL CFMCTP(X(I),Y(I),XAUX1,YAUX1,1) 485 - CALL CFMCTP(X(J),Y(J),XAUX2,YAUX2,1) 486 - YAUX1=YAUX1-SY*ANINT(YAUX1/SY) 487 - YAUX2=YAUX2-SY*ANINT(YAUX2/SY) 488 - CALL CFMPTC(XAUX1,YAUX1,XAUX1,YAUX1,1) 489 - CALL CFMPTC(XAUX2,YAUX2,XAUX2,YAUX2,1) 490 - XSEPAR=XAUX1-XAUX2 491 - YSEPAR=YAUX1-YAUX2 492 - ELSE 493 - XSEPAR=X(I)-X(J) 494 - YSEPAR=Y(I)-Y(J) 495 - ENDIF 496 - ELSE 497 - XSEPAR=ABS(X(I)-X(J)) 498 - IF(PERX)XSEPAR=XSEPAR-SX*ANINT(XSEPAR/SX) 499 - YSEPAR=ABS(Y(I)-Y(J)) 500 - IF(PERY)YSEPAR=YSEPAR-SY*ANINT(YSEPAR/SY) 501 - ENDIF 502 - IF(XSEPAR**2+YSEPAR**2.LT.0.25*(D(I)+D(J))**2)THEN 503 - XPRTI=X(I) 504 - YPRTI=Y(I) 505 - XPRTJ=X(J) 506 - YPRTJ=Y(J) 507 - IF(POLAR)CALL CFMRTP(XPRTI,YPRTI,XPRTI,YPRTI,1) 508 - IF(POLAR)CALL CFMRTP(XPRTJ,YPRTJ,XPRTJ,YPRTJ,1) 509 - CALL OUTFMT(XPRTI,2,STR1,NC1,'LEFT') 510 - CALL OUTFMT(YPRTI,2,STR2,NC2,'LEFT') 511 - CALL OUTFMT(XPRTJ,2,STR3,NC3,'LEFT') 512 - CALL OUTFMT(YPRTJ,2,STR4,NC4,'LEFT') 513 - PRINT *,' !!!!!! CELCHK WARNING : The '//WIRTYP(I)// 514 - - '-wire at ('//STR1(1:NC1)//','//STR2(1:NC2)//') and'// 515 - - ' the '//WIRTYP(J)//'-wire at ('//STR3(1:NC3)//','// 516 - - STR4(1:NC4)//')' 517 - PRINT *,' overlap at least', 518 - - ' partially; the latter is removed.' 519 - WRONG(J)=.TRUE. 520 - OK=.FALSE. 521 - ENDIF 522 - 80 CONTINUE 523 - 90 CONTINUE 524 - ** Remove the wires which are not acceptable for one reason or another. 525 - IWIRE=NWIRE 526 - NWIRE=0 527 - DO 100 I=1,IWIRE 528 - IF(.NOT.WRONG(I))THEN 529 - NWIRE=NWIRE+1 530 - X(NWIRE)=X(I) 531 - Y(NWIRE)=Y(I) 532 - D(NWIRE)=D(I) 533 - V(NWIRE)=V(I) 534 - WIRTYP(NWIRE)=WIRTYP(I) 535 - ENDIF 536 - 100 CONTINUE 537 - *** Ensure that some elements are left. 538 - NELEM=NWIRE 539 - IF(YNPLAN(1))NELEM=NELEM+1 540 - IF(YNPLAN(2))NELEM=NELEM+1 541 - IF(YNPLAN(3))NELEM=NELEM+1 542 - IF(YNPLAN(4))NELEM=NELEM+1 543 - IF(TUBE)NELEM=NELEM+1 544 - IF(NELEM.LT.2)THEN 545 - PRINT *,' ###### CELCHK ERROR : Neither a field map,'// 546 - - ' nor at least 2 elements; cell rejected.' 547 - OK=.FALSE. 548 - RETURN 549 - ENDIF 550 - *** Check dielectrica, initialise the remove flag for the slabs. 551 - DO 150 I=1,MXMATT 552 - WRMATX(I)=.FALSE. 553 - WRMATY(I)=.FALSE. 554 - 150 CONTINUE 555 - * Check overlapping x-slabs and kill slabs outside the planes. 556 - DO 160 I=1,NXMATT 557 - IF(WRMATX(I))GOTO 160 558 - DO 170 J=I+1,NXMATT 559 - IF(WRMATX(J))GOTO 170 560 - IF(XMATT(I,3).NE.0.AND.XMATT(J,3).NE.0)THEN 561 - PRINT *,' !!!!!! CELCHK WARNING : Two dielectric slabs'// 562 - - ' extend to -infinity in x ; one is removed.' 563 - WRMATX(J)=.TRUE. 564 - OK=.FALSE. 565 - ELSEIF(XMATT(I,4).NE.0.AND.XMATT(J,4).NE.0)THEN 566 - PRINT *,' !!!!!! CELCHK WARNING : Two dielectric slabs'// 567 - - ' extend to +infinity in x ; one is removed.' 568 - WRMATX(J)=.TRUE. 569 - OK=.FALSE. 570 - ELSEIF((XMATT(I,3).NE.0.AND.XMATT(I,2).GT.XMATT(J,1)).OR. 571 - - (XMATT(I,4).NE.0.AND.XMATT(I,1).LT.XMATT(J,2)).OR. 572 - - (XMATT(J,3).NE.0.AND.XMATT(J,2).GT.XMATT(I,1)).OR. 573 - - (XMATT(J,4).NE.0.AND.XMATT(J,1).LT.XMATT(I,2)))THEN 574 - PRINT *,' !!!!!! CELCHK WARNING : A dielectric'// 575 - - ' semi-infinite x-slab overlaps partially' 576 - PRINT *,' with another x-slab.'// 577 - - ' One of the slabs is removed.' 578 - WRMATX(J)=.TRUE. 579 - OK=.FALSE. 580 - ELSEIF(XMATT(I,3).EQ.0.AND.XMATT(I,4).EQ.0.AND. 581 - - XMATT(J,3).EQ.0.AND.XMATT(J,4).EQ.0.AND. 582 - - ((XMATT(I,1)-XMATT(J,1))*(XMATT(J,1)-XMATT(I,2)).GT.0.OR. 1 451 P=CELL D=CELCHK 7 PAGE 560 583 - - (XMATT(I,1)-XMATT(J,2))*(XMATT(J,2)-XMATT(I,2)).GT.0))THEN 584 - PRINT *,' !!!!!! CELCHK WARNING : Two finite dielectric'// 585 - - ' x-slabs overlap (in part) ; one is removed.' 586 - WRMATX(J)=.TRUE. 587 - OK=.FALSE. 588 - ENDIF 589 - 170 CONTINUE 590 - IF(WRMATX(I))GOTO 160 591 - IF((YNPLAN(1).AND. 592 - - (XMATT(I,3).NE.0.OR.COPLAN(1).GT.XMATT(I,1))).OR. 593 - - (YNPLAN(2).AND. 594 - - (XMATT(I,4).NE.0.OR.COPLAN(2).LT.XMATT(I,2))))THEN 595 - PRINT *,' !!!!!! CELCHK WARNING : A dielectric x-slab'// 596 - - ' covers a plane ; it is removed.' 597 - WRMATX(I)=.TRUE. 598 - OK=.FALSE. 599 - ENDIF 600 - IF(WRMATX(I))GOTO 160 601 - IF(PERX.AND.(XMATT(I,3).NE.0.OR.XMATT(I,4).NE.0.OR. 602 - - ABS(XMATT(I,1)-XMATT(I,2)).GT.SX))THEN 603 - PRINT *,' !!!!!! CELCHK WARNING : The dielectric x-slab'// 604 - - ' from (',XMATT(I,1),' to ',XMATT(I,2),')' 605 - PRINT *,' covers more than one'// 606 - - ' x-period ; it is removed.' 607 - WRMATX(I)=.TRUE. 608 - OK=.FALSE. 609 - ENDIF 610 - 160 CONTINUE 611 - * Check overlapping y-slabs and kill slabs outside the planes. 612 - DO 180 I=1,NYMATT 613 - IF(WRMATY(I))GOTO 180 614 - DO 190 J=I+1,NYMATT 615 - IF(WRMATY(J))GOTO 190 616 - IF(YMATT(I,3).NE.0.AND.YMATT(J,3).NE.0)THEN 617 - PRINT *,' !!!!!! CELCHK WARNING : Two dielectric slabs'// 618 - - ' extend to -infinity in y ; one is removed.' 619 - WRMATY(J)=.TRUE. 620 - OK=.FALSE. 621 - ELSEIF(YMATT(I,4).NE.0.AND.YMATT(J,4).NE.0)THEN 622 - PRINT *,' !!!!!! CELCHK WARNING : Two dielectric slabs'// 623 - - ' extend to +infinity in y ; one is removed.' 624 - WRMATY(J)=.TRUE. 625 - OK=.FALSE. 626 - ELSEIF((YMATT(I,3).NE.0.AND.YMATT(I,2).GT.YMATT(J,1)).OR. 627 - - (YMATT(I,4).NE.0.AND.YMATT(I,1).LT.YMATT(J,2)).OR. 628 - - (YMATT(J,3).NE.0.AND.YMATT(J,2).GT.YMATT(I,1)).OR. 629 - - (YMATT(J,4).NE.0.AND.YMATT(J,1).LT.YMATT(I,2)))THEN 630 - PRINT *,' !!!!!! CELCHK WARNING : A dielectric'// 631 - - ' semi-infinite y-slab overlaps partially' 632 - PRINT *,' with another y-slab.'// 633 - - ' One of the slabs is removed.' 634 - WRMATY(J)=.TRUE. 635 - OK=.FALSE. 636 - ELSEIF(YMATT(I,3).EQ.0.AND.YMATT(I,4).EQ.0.AND. 637 - - YMATT(J,3).EQ.0.AND.YMATT(J,4).EQ.0.AND. 638 - - ((YMATT(I,1)-YMATT(J,1))*(YMATT(J,1)-YMATT(I,2)).GT.0.OR. 639 - - (YMATT(I,1)-YMATT(J,2))*(YMATT(J,2)-YMATT(I,2)).GT.0))THEN 640 - PRINT *,' !!!!!! CELCHK WARNING : Two finite dielectric'// 641 - - ' y-slabs overlap (in part) ; one is removed.' 642 - WRMATY(J)=.TRUE. 643 - OK=.FALSE. 644 - ENDIF 645 - 190 CONTINUE 646 - IF(WRMATY(I))GOTO 180 647 - IF((YNPLAN(3).AND. 648 - - (YMATT(I,3).NE.0.OR.COPLAN(3).GT.YMATT(I,1))).OR. 649 - - (YNPLAN(4).AND. 650 - - (YMATT(I,4).NE.0.OR.COPLAN(4).LT.YMATT(I,2))))THEN 651 - PRINT *,' !!!!!! CELCHK WARNING : A dielectric y-slab'// 652 - - ' covers a plane ; it is removed.' 653 - WRMATY(I)=.TRUE. 654 - OK=.FALSE. 655 - ENDIF 656 - IF(WRMATY(I))GOTO 180 657 - IF(PERX.AND.(YMATT(I,3).NE.0.OR.YMATT(I,4).NE.0.OR. 658 - - ABS(YMATT(I,1)-YMATT(I,2)).GT.SX))THEN 659 - PRINT *,' !!!!!! CELCHK WARNING : The dielectric y-slab'// 660 - - ' from (',YMATT(I,1),' to ',YMATT(I,2),')' 661 - PRINT *,' covers more than one'// 662 - - ' x-period ; it is removed.' 663 - WRMATY(I)=.TRUE. 664 - OK=.FALSE. 665 - ENDIF 666 - 180 CONTINUE 667 - * And finally crossing slabs with different epsilons. 668 - DO 200 I=1,NXMATT 669 - IF(WRMATX(I))GOTO 200 670 - DO 210 J=1,NYMATT 671 - IF(WRMATY(J))GOTO 210 672 - IF(ABS(XMATT(I,5)-YMATT(J,5)).GT.1.0E-5*(1.0+ABS(XMATT(I,5))+ 673 - - ABS(YMATT(J,5))))THEN 674 - PRINT *,' !!!!!! CELCHK WARNING : A dielectric x-slab'// 675 - - ' crosses a y-slab but has a' 676 - PRINT *,' different dielectric'// 677 - - ' constant; the x-slab is removed.' 678 - WRMATX(I)=.TRUE. 679 - OK=.FALSE. 680 - ENDIF 681 - 210 CONTINUE 682 - 200 CONTINUE 683 - * Remove slabs, first x, than y. 684 - NXOLD=NXMATT 685 - NXMATT=0 686 - DO 220 I=1,NXOLD 687 - IF(WRMATX(I))GOTO 220 688 - NXMATT=NXMATT+1 1 451 P=CELL D=CELCHK 8 PAGE 561 689 - DO 230 J=1,5 690 - XMATT(NXMATT,J)=XMATT(I,J) 691 - 230 CONTINUE 692 - 220 CONTINUE 693 - NYOLD=NYMATT 694 - NYMATT=0 695 - DO 240 I=1,NYOLD 696 - IF(WRMATY(I))GOTO 240 697 - NYMATT=NYMATT+1 698 - DO 250 J=1,5 699 - YMATT(NYMATT,J)=YMATT(I,J) 700 - 250 CONTINUE 701 - 240 CONTINUE 702 - *** Determine maximum and minimum coordinates and potentials. 703 - SETX=.FALSE. 704 - SETY=.FALSE. 705 - SETZ=.FALSE. 706 - SETV=.FALSE. 707 - XMIN=0 708 - XMAX=0 709 - YMIN=0 710 - YMAX=0 711 - ZMIN=0 712 - ZMAX=0 713 - VMIN=0 714 - VMAX=0 715 - * Loop over the wires. 716 - DO 120 I=1,NWIRE 717 - IF(SETX)THEN 718 - XMIN=MIN(XMIN,X(I)-D(I)/2) 719 - XMAX=MAX(XMAX,X(I)+D(I)/2) 720 - ELSE 721 - XMIN=X(I)-D(I)/2 722 - XMAX=X(I)+D(I)/2 723 - SETX=.TRUE. 724 - ENDIF 725 - IF(SETY)THEN 726 - YMIN=MIN(YMIN,Y(I)-D(I)/2) 727 - YMAX=MAX(YMAX,Y(I)+D(I)/2) 728 - ELSE 729 - YMIN=Y(I)-D(I)/2 730 - YMAX=Y(I)+D(I)/2 731 - SETY=.TRUE. 732 - ENDIF 733 - IF(SETZ)THEN 734 - ZMIN=MIN(ZMIN,-U(I)/2) 735 - ZMAX=MAX(ZMAX,+U(I)/2) 736 - ELSE 737 - ZMIN=-U(I)/2 738 - ZMAX=+U(I)/2 739 - SETZ=.TRUE. 740 - ENDIF 741 - IF(SETV)THEN 742 - VMIN=MIN(VMIN,V(I)) 743 - VMAX=MAX(VMAX,V(I)) 744 - ELSE 745 - VMIN=V(I) 746 - VMAX=V(I) 747 - SETV=.TRUE. 748 - ENDIF 749 - 120 CONTINUE 750 - * Consider the planes. 751 - DO 130 I=1,4 752 - IF(YNPLAN(I))THEN 753 - IF(I.LE.2)THEN 754 - IF(SETX)THEN 755 - XMIN=MIN(XMIN,COPLAN(I)) 756 - XMAX=MAX(XMAX,COPLAN(I)) 757 - ELSE 758 - XMIN=COPLAN(I) 759 - XMAX=COPLAN(I) 760 - SETX=.TRUE. 761 - ENDIF 762 - ELSE 763 - IF(SETY)THEN 764 - YMIN=MIN(YMIN,COPLAN(I)) 765 - YMAX=MAX(YMAX,COPLAN(I)) 766 - ELSE 767 - YMIN=COPLAN(I) 768 - YMAX=COPLAN(I) 769 - SETY=.TRUE. 770 - ENDIF 771 - ENDIF 772 - IF(SETV)THEN 773 - VMIN=MIN(VMIN,VTPLAN(I)) 774 - VMAX=MAX(VMAX,VTPLAN(I)) 775 - ELSE 776 - VMIN=VTPLAN(I) 777 - VMAX=VTPLAN(I) 778 - SETV=.TRUE. 779 - ENDIF 780 - ENDIF 781 - 130 CONTINUE 782 - * Consider the dielectrica. 783 - DO 260 I=1,NXMATT 784 - IF(XMATT(I,3).EQ.0)THEN 785 - IF(SETX)THEN 786 - XMIN=MIN(XMIN,XMATT(I,1)) 787 - XMAX=MAX(XMAX,XMATT(I,1)) 788 - ELSE 789 - XMIN=XMATT(I,1) 790 - XMAX=XMATT(I,1) 791 - SETX=.TRUE. 792 - ENDIF 793 - ENDIF 794 - IF(XMATT(I,4).EQ.0)THEN 1 451 P=CELL D=CELCHK 9 PAGE 562 795 - IF(SETX)THEN 796 - XMIN=MIN(XMIN,XMATT(I,2)) 797 - XMAX=MAX(XMAX,XMATT(I,2)) 798 - ELSE 799 - XMIN=XMATT(I,2) 800 - XMAX=XMATT(I,2) 801 - SETX=.TRUE. 802 - ENDIF 803 - ENDIF 804 - 260 CONTINUE 805 - DO 270 I=1,NYMATT 806 - IF(YMATT(I,3).EQ.0)THEN 807 - IF(SETY)THEN 808 - YMIN=MIN(YMIN,YMATT(I,1)) 809 - YMAX=MAX(YMAX,YMATT(I,1)) 810 - ELSE 811 - YMIN=YMATT(I,1) 812 - YMAX=YMATT(I,1) 813 - SETY=.TRUE. 814 - ENDIF 815 - ENDIF 816 - IF(YMATT(I,4).EQ.0)THEN 817 - IF(SETY)THEN 818 - YMIN=MIN(YMIN,YMATT(I,2)) 819 - YMAX=MAX(YMAX,YMATT(I,2)) 820 - ELSE 821 - YMIN=YMATT(I,2) 822 - YMAX=YMATT(I,2) 823 - SETY=.TRUE. 824 - ENDIF 825 - ENDIF 826 - 270 CONTINUE 827 - * Consider the tube. 828 - IF(TUBE)THEN 829 - XMIN=-1.1*COTUBE 830 - XMAX=+1.1*COTUBE 831 - SETX=.TRUE. 832 - YMIN=-1.1*COTUBE 833 - YMAX=+1.1*COTUBE 834 - SETY=.TRUE. 835 - VMIN=MIN(VMIN,VTTUBE) 836 - VMAX=MAX(VMAX,VTTUBE) 837 - SETV=.TRUE. 838 - ENDIF 839 - ** In case of x-periodicity, XMAX-XMIN should be SX, 840 - IF(PERX.AND.SX.GT.(XMAX-XMIN))THEN 841 - XMIN=-SX/2.0 842 - XMAX=SX/2.0 843 - SETX=.TRUE. 844 - ENDIF 845 - * in case of y-periodicity, YMAX-YMIN should be SY, 846 - IF(PERY.AND.SY.GT.(YMAX-YMIN))THEN 847 - YMIN=-SY/2.0 848 - YMAX=SY/2.0 849 - SETY=.TRUE. 850 - ENDIF 851 - * in case the cell is polar, the y range should be < 2 pi. 852 - IF(POLAR.AND.YMAX-YMIN.GE.2.0*PI)THEN 853 - YMIN=-PI 854 - YMAX=+PI 855 - SETY=.TRUE. 856 - ENDIF 857 - ** Fill in missing dimensions. 858 - IF(SETX.AND.XMIN.NE.XMAX.AND.(YMIN.EQ.YMAX.OR..NOT.SETY))THEN 859 - YMIN=YMIN-ABS(XMAX-XMIN)/2 860 - YMAX=YMAX+ABS(XMAX-XMIN)/2 861 - SETY=.TRUE. 862 - ENDIF 863 - IF(SETY.AND.YMIN.NE.YMAX.AND.(XMIN.EQ.XMAX.OR..NOT.SETX))THEN 864 - XMIN=XMIN-ABS(YMAX-YMIN)/2 865 - XMAX=XMAX+ABS(YMAX-YMIN)/2 866 - SETX=.TRUE. 867 - ENDIF 868 - IF(.NOT.SETZ)THEN 869 - ZMIN=-(ABS(XMAX-XMIN)+ABS(YMAX-YMIN))/4 870 - ZMAX=+(ABS(XMAX-XMIN)+ABS(YMAX-YMIN))/4 871 - SETZ=.TRUE. 872 - ENDIF 873 - * Ensure that all dimensions are now set. 874 - IF(.NOT.(SETX.AND.SETY.AND.SETZ))THEN 875 - PRINT *,' !!!!!! CELCHK WARNING : Unable to establish'// 876 - - ' default dimensions in all directions; use AREA.' 877 - OK=.FALSE. 878 - ENDIF 879 - *** Check that at least some different voltages are present. 880 - IF(VMIN.EQ.VMAX.OR..NOT.SETV)THEN 881 - PRINT *,' ###### CELCHK ERROR : All potentials in the'// 882 - - ' cell are the same; there is no point in going on.' 883 - OK=.FALSE. 884 - RETURN 885 - ENDIF 886 - *** Resume here for maps. 887 - 3000 CONTINUE 888 - *** Take action on the warnings if requested. 889 - IF(JFAIL.EQ.2.AND..NOT.OK)THEN 890 - PRINT *,' ###### CELCHK ERROR : Cell declared to be'// 891 - - ' unuseable because of the above warnings.' 892 - RETURN 893 - ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN 894 - PRINT *,' ###### CELCHK ERROR : Program terminated'// 895 - - ' because of the above warnings.' 896 - CALL QUIT 897 - RETURN 898 - ENDIF 899 - *** Cell seems to be alright since it passed all critical tests. 900 - IFAIL=0 1 451 P=CELL D=CELCHK 10 PAGE 563 901 - *** Print the amount of CPU time used. 902 - CALL TIMLOG('Checking that the cell makes sense: ') 903 - END 452 GARFIELD ================================================== P=CELL D=CELCNW 1 ============================ 0 + +DECK,CELCNW. 1 - SUBROUTINE CELCNW(PPXMIN,PPYMIN,PPXMAX,PPYMAX) 2 - *----------------------------------------------------------------------- 3 - * CELCNW - Generates a conductor table from the wires. 4 - * VARIABLES : NXMIN,NXMAX: Numbers of resp first and last x-period. 5 - * NYMIN,NYMAX: " " " " " " y " 6 - * (Last changed on 12/ 8/99.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,SOLIDS. 12.- +SEQ,CONSTANTS. 13.- +SEQ,PRINTPLOT. 14.- +SEQ,PARAMETERS. 15 - INTEGER I,NX,NY,NXMIN,NYMIN,NXMAX,NYMAX 16 - REAL XPOS,YPOS,PPXMIN,PPYMIN,PPXMAX,PPYMAX 17 - *** Determine the number of periods present in the cell. 18 - NXMIN=0 19 - NXMAX=0 20 - NYMIN=0 21 - NYMAX=0 22 - IF(PERX)THEN 23 - NXMIN=INT(PPXMIN/SX)-1 24 - NXMAX=INT(PPXMAX/SX)+1 25 - ENDIF 26 - IF(PERY)THEN 27 - NYMIN=INT(PPYMIN/SY)-1 28 - NYMAX=INT(PPYMAX/SY)+1 29 - ENDIF 30 - *** Initialise the conductor table. 31 - NSOLID=0 32 - ICCURR=0 33 - *** Loop over the wires. 34 - DO 80 I=1,NWIRE 35 - * Loop over the periods. 36 - DO 90 NX=NXMIN,NXMAX 37 - DO 70 NY=NYMIN,NYMAX 38 - * Wire location in non-tube shaped cells. 39 - IF(.NOT.TUBE)THEN 40 - XPOS=X(I)+NX*SX 41 - YPOS=Y(I)+NY*SY 42 - * Tubed shaped cells. 43 - ELSE 44 - CALL CFMCTP(X(I),Y(I),XPOS,YPOS,1) 45 - IF(PERY)YPOS=YPOS+REAL(NY*360)/REAL(MTUBE) 46 - CALL CFMPTC(XPOS,YPOS,XPOS,YPOS,1) 47 - ENDIF 48 - ** Enter in the conductor table. 49 - IF(NSOLID.GE.MXSOLI)THEN 50 - PRINT *,' !!!!!! CELCNW WARNING : Solids list is full'// 51 - - ' ; not copying some wires.' 52 - RETURN 53 - ELSEIF(ICCURR+13.GT.MXSBUF)THEN 54 - PRINT *,' !!!!!! CELCNW WARNING : Solids description'// 55 - - ' buffer is full ; not copying some wires.' 56 - RETURN 57 - ENDIF 58 - NSOLID=NSOLID+1 59 - * Start of the record. 60 - ISTART(NSOLID)=ICCURR 61 - * Type of solid. 62 - ISOLTP(NSOLID)=1 63 - * Material the solid is made of. 64 - ISOLMT(NSOLID)=1 65 - * Label assigned to the solid. 66 - SOLTYP(NSOLID)=WIRTYP(I) 67 - * Diameter. 68 - CBUF(ICCURR+1)=D(I)/2 69 - * Half length. 70 - CBUF(ICCURR+2)=U(I)/2 71 - * Position of centre. 72 - CBUF(ICCURR+3)=XPOS 73 - CBUF(ICCURR+4)=YPOS 74 - CBUF(ICCURR+5)=0.0 75 - * Direction vector. 76 - CBUF(ICCURR+6)=0.0 77 - CBUF(ICCURR+7)=0.0 78 - CBUF(ICCURR+8)=1.0 79 - * Number of points. 80 - CBUF(ICCURR+9)=0 81 - * Orientation cos and sin of angles. 82 - CBUF(ICCURR+10)=1.0 83 - CBUF(ICCURR+11)=0.0 84 - CBUF(ICCURR+12)=1.0 85 - CBUF(ICCURR+13)=0.0 86 - * No axial rotation. 87 - CBUF(ICCURR+14)=0 88 - * Amount of data. 89 - ICCURR=ICCURR+14 90 - * Next periods. 91 - 70 CONTINUE 92 - 90 CONTINUE 93 - * Next wire. 94 - 80 CONTINUE 95 - END 1 453 GARFIELD ================================================== P=CELL D=CELSOL 1 =================== PAGE 564 0 + +DECK,CELSOL. 1 - SUBROUTINE CELSOL 2 - *----------------------------------------------------------------------- 3 - * CELSOL - Reads a list of solids. 4 - * VARIABLES : NXMIN,NXMAX: Numbers of resp first and last x-period. 5 - * NYMIN,NYMAX: " " " " " " y " 6 - * (Last changed on 12/ 8/99.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,SOLIDS. 12.- +SEQ,CONSTANTS. 13.- +SEQ,PRINTPLOT. 14.- +SEQ,PARAMETERS. 15 - CHARACTER*80 STRING 16 - CHARACTER AUXTYP 17 - INTEGER I,INEXT,NWORD,IFAIL1,IFAIL2,IFAIL3,INPCMP,NC,IMAT,N,NR, 18 - - NCAUX 19 - REAL XDIR,YDIR,ZDIR,XPOS,YPOS,ZPOS,XSIZ,YSIZ,ZSIZ,R,R1,R2, 20 - - AUX1,AUX2,AUX3,THETA,PHI,AROT 21 - LOGICAL LRAD,LRAD1,LRAD2,LPOS,LSIZ,STDSTR 22 - EXTERNAL INPCMP,STDSTR 23 - *** Read the number of words. 24 - CALL INPNUM(NWORD) 25 - *** Warn if there are options. 26 - IF(NWORD.NE.1)PRINT *,' !!!!!! CELSOL WARNING : No arguments'// 27 - - ' for SOLIDS known; ignored.' 28 - *** Initialise the conductor table. 29 - NSOLID=0 30 - ICCURR=0 31 - *** Set the prompt. 32 - CALL INPPRM('Solids','ADD-NOPRINT') 33 - IF(STDSTR('INPUT'))PRINT *,' ====== CELSOL INPUT : Please'// 34 - - ' enter the solids, terminate with a blank line.' 35 - *** Read a line. 36 - 10 CONTINUE 37 - CALL INPWRD(NWORD) 38 - *** If empty, leave the routine. 39 - IF(NWORD.EQ.0)THEN 40 - CALL INPPRM(' ','BACK-PRINT') 41 - RETURN 42 - ENDIF 43 - *** Could be a cylinder. 44 - IF(INPCMP(1,'CYL#INDER').NE.0)THEN 45 - * Default parameters. 46 - XDIR=0 47 - YDIR=0 48 - ZDIR=1 49 - AROT=0 50 - IMAT=1 51 - AUXTYP='C' 52 - N=0 53 - * Required parameters. 54 - LRAD=.FALSE. 55 - LPOS=.FALSE. 56 - LSIZ=.FALSE. 57 - * Read the parameters. 58 - INEXT=2 59 - DO 20 I=2,NWORD 60 - IF(I.LT.INEXT)GOTO 20 61 - * Centre. 62 - IF(INPCMP(I,'CEN#TRE')+INPCMP(I,'CEN#TER').NE.0)THEN 63 - CALL INPCHK(I+1,2,IFAIL1) 64 - CALL INPCHK(I+2,2,IFAIL2) 65 - CALL INPCHK(I+3,2,IFAIL3) 66 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN 67 - CALL INPRDR(I+1,XPOS,0.0) 68 - CALL INPRDR(I+2,YPOS,0.0) 69 - CALL INPRDR(I+3,ZPOS,0.0) 70 - LPOS=.TRUE. 71 - ELSE 72 - CALL INPMSG(I,'Arguments not valid.') 73 - ENDIF 74 - INEXT=I+4 75 - * Direction. 76 - ELSEIF(INPCMP(I,'DIR#ECTION').NE.0)THEN 77 - CALL INPCHK(I+1,2,IFAIL1) 78 - CALL INPCHK(I+2,2,IFAIL2) 79 - CALL INPCHK(I+3,2,IFAIL3) 80 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN 81 - CALL INPRDR(I+1,XDIR,0.0) 82 - CALL INPRDR(I+2,YDIR,0.0) 83 - CALL INPRDR(I+3,ZDIR,0.0) 84 - ELSE 85 - CALL INPMSG(I,'Arguments not valid.') 86 - ENDIF 87 - INEXT=I+4 88 - * Radius. 89 - ELSEIF(INPCMP(I,'R#ADIUS').NE.0)THEN 90 - CALL INPCHK(I+1,2,IFAIL1) 91 - IF(IFAIL1.EQ.0)THEN 92 - CALL INPRDR(I+1,AUX1,-1.0) 93 - IF(AUX1.GT.0)THEN 94 - R=AUX1 95 - LRAD=.TRUE. 96 - ELSE 97 - CALL INPMSG(I+1,'Radius not positive.') 98 - ENDIF 99 - ELSE 100 - CALL INPMSG(I,'Arguments not valid.') 101 - ENDIF 102 - INEXT=I+2 103 - * Half-length. 104 - ELSEIF(INPCMP(I,'HALF-#LENGTH').NE.0)THEN 105 - CALL INPCHK(I+1,2,IFAIL1) 1 453 P=CELL D=CELSOL 2 PAGE 565 106 - IF(IFAIL1.EQ.0)THEN 107 - CALL INPRDR(I+1,AUX1,-1.0) 108 - IF(AUX1.GT.0)THEN 109 - ZSIZ=AUX1 110 - LSIZ=.TRUE. 111 - ELSE 112 - CALL INPMSG(I+1,'Radius not positive.') 113 - ENDIF 114 - ELSE 115 - CALL INPMSG(I,'Arguments not valid.') 116 - ENDIF 117 - INEXT=I+2 118 - * Rotation. 119 - ELSEIF(INPCMP(I,'ROT#ATE').NE.0)THEN 120 - CALL INPCHK(I+1,2,IFAIL1) 121 - IF(IFAIL1.EQ.0)THEN 122 - CALL INPRDR(I+1,AUX1,-1.0) 123 - AROT=AUX1*PI/180 124 - ELSE 125 - CALL INPMSG(I,'Arguments not valid.') 126 - ENDIF 127 - INEXT=I+2 128 - * Number of points. 129 - ELSEIF(INPCMP(I,'N').NE.0)THEN 130 - CALL INPCHK(I+1,1,IFAIL1) 131 - IF(IFAIL1.EQ.0)THEN 132 - CALL INPRDI(I+1,NR,-1) 133 - IF(NR.LE.1)THEN 134 - CALL INPMSG(I+1,'Should be > 1.') 135 - ELSE 136 - N=NR 137 - ENDIF 138 - ELSE 139 - CALL INPMSG(I,'Arguments not valid.') 140 - ENDIF 141 - INEXT=I+2 142 - * Material. 143 - ELSEIF(INPCMP(I,'CON#DUCTOR')+ 144 - - INPCMP(I,'CON#DUCTOR-1').NE.0)THEN 145 - IMAT=1 146 - ELSEIF(INPCMP(I,'CON#DUCTOR-2').NE.0)THEN 147 - IMAT=2 148 - ELSEIF(INPCMP(I,'CON#DUCTOR-3').NE.0)THEN 149 - IMAT=3 150 - ELSEIF(INPCMP(I,'DIEL#ECTRICUM')+ 151 - - INPCMP(I,'DIEL#ECTRICUM-1').NE.0)THEN 152 - IMAT=11 153 - ELSEIF(INPCMP(I,'DIEL#ECTRICUM-2').NE.0)THEN 154 - IMAT=12 155 - ELSEIF(INPCMP(I,'DIEL#ECTRICUM-3').NE.0)THEN 156 - IMAT=13 157 - * Label. 158 - ELSEIF(INPCMP(I,'LAB#EL')+INPCMP(I,'TYPE').NE.0)THEN 159 - CALL INPSTR(I+1,I+1,AUXTYP,NCAUX) 160 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',AUXTYP).EQ. 161 - - 0)THEN 162 - CALL INPMSG(1,'The label must be a letter.') 163 - AUXTYP='C' 164 - ENDIF 165 - INEXT=I+2 166 - * Other things are not known. 167 - ELSE 168 - CALL INPMSG(I,'Not a known keyword.') 169 - ENDIF 170 - 20 CONTINUE 171 - * Print error messages. 172 - CALL INPERR 173 - * Enter in the conductor table. 174 - IF(LPOS.AND.LRAD.AND.LSIZ.AND. 175 - - (NSOLID+1.GT.MXSOLI.OR.ICCURR+13.GT.MXSBUF))THEN 176 - PRINT *,' !!!!!! CELSOL WARNING : Conductor table'// 177 - - ' is full; cylinder not stored.' 178 - ELSEIF(LPOS.AND.LRAD.AND.LSIZ)THEN 179 - NSOLID=NSOLID+1 180 - ISTART(NSOLID)=ICCURR 181 - ISOLTP(NSOLID)=1 182 - ISOLMT(NSOLID)=IMAT 183 - SOLTYP(NSOLID)=AUXTYP 184 - CBUF(ICCURR+1)=R 185 - CBUF(ICCURR+2)=ZSIZ 186 - CBUF(ICCURR+3)=XPOS 187 - CBUF(ICCURR+4)=YPOS 188 - CBUF(ICCURR+5)=ZPOS 189 - CBUF(ICCURR+6)=XDIR 190 - CBUF(ICCURR+7)=YDIR 191 - CBUF(ICCURR+8)=ZDIR 192 - CBUF(ICCURR+9)=DBLE(N) 193 - * Compute rotation angles. 194 - IF(XDIR**2+YDIR**2.LE.0)THEN 195 - PHI=0 196 - IF(ZDIR.GT.0)THEN 197 - THETA=0 198 - ELSE 199 - THETA=PI 200 - ENDIF 201 - ELSE 202 - PHI=ATAN2(YDIR,XDIR) 203 - THETA=ATAN2(SQRT(XDIR**2+YDIR**2),ZDIR) 204 - ENDIF 205 - CBUF(ICCURR+10)=COS(THETA) 206 - CBUF(ICCURR+11)=SIN(THETA) 207 - CBUF(ICCURR+12)=COS(PHI) 208 - CBUF(ICCURR+13)=SIN(PHI) 209 - * Rotation angle of the object. 210 - CBUF(ICCURR+14)=AROT 211 - * Store size. 1 453 P=CELL D=CELSOL 3 PAGE 566 212 - ICCURR=ICCURR+14 213 - * Or warn that some element is missing. 214 - ELSE 215 - PRINT *,' !!!!!! CELSOL WARNING : Cylinder not'// 216 - - ' entered because the position, the radius'// 217 - - ' or the length has not been given.' 218 - ENDIF 219 - *** Cylindrical hole. 220 - ELSEIF(INPCMP(1,'HOLE').NE.0)THEN 221 - * Default parameters. 222 - XDIR=0 223 - YDIR=0 224 - ZDIR=1 225 - IMAT=1 226 - N=0 227 - AUXTYP='H' 228 - * Required parameters. 229 - LRAD1=.FALSE. 230 - LRAD2=.FALSE. 231 - LPOS=.FALSE. 232 - LSIZ=.FALSE. 233 - * Read the parameters. 234 - INEXT=2 235 - DO 60 I=2,NWORD 236 - IF(I.LT.INEXT)GOTO 60 237 - * Centre. 238 - IF(INPCMP(I,'CEN#TRE')+INPCMP(I,'CEN#TER').NE.0)THEN 239 - CALL INPCHK(I+1,2,IFAIL1) 240 - CALL INPCHK(I+2,2,IFAIL2) 241 - CALL INPCHK(I+3,2,IFAIL3) 242 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN 243 - CALL INPRDR(I+1,XPOS,0.0) 244 - CALL INPRDR(I+2,YPOS,0.0) 245 - CALL INPRDR(I+3,ZPOS,0.0) 246 - LPOS=.TRUE. 247 - ELSE 248 - CALL INPMSG(I,'Arguments not valid.') 249 - ENDIF 250 - INEXT=I+4 251 - * Direction. 252 - ELSEIF(INPCMP(I,'DIR#ECTION').NE.0)THEN 253 - CALL INPCHK(I+1,2,IFAIL1) 254 - CALL INPCHK(I+2,2,IFAIL2) 255 - CALL INPCHK(I+3,2,IFAIL3) 256 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN 257 - CALL INPRDR(I+1,XDIR,0.0) 258 - CALL INPRDR(I+2,YDIR,0.0) 259 - CALL INPRDR(I+3,ZDIR,0.0) 260 - ELSE 261 - CALL INPMSG(I,'Arguments not valid.') 262 - ENDIF 263 - INEXT=I+4 264 - * Number of points. 265 - ELSEIF(INPCMP(I,'N').NE.0)THEN 266 - CALL INPCHK(I+1,1,IFAIL1) 267 - IF(IFAIL1.EQ.0)THEN 268 - CALL INPRDI(I+1,NR,-1) 269 - IF(NR.LE.1)THEN 270 - CALL INPMSG(I+1,'Should be > 1.') 271 - ELSE 272 - N=NR 273 - ENDIF 274 - ELSE 275 - CALL INPMSG(I,'Arguments not valid.') 276 - ENDIF 277 - INEXT=I+2 278 - * Radius or radii. 279 - ELSEIF(INPCMP(I,'R#ADIUS')+ 280 - - INPCMP(I,'R#ADII').NE.0)THEN 281 - CALL INPCHK(I+1,2,IFAIL1) 282 - IF(IFAIL1.EQ.0)THEN 283 - CALL INPRDR(I+1,AUX1,-1.0) 284 - IF(AUX1.GT.0)THEN 285 - R1=AUX1 286 - R2=AUX1 287 - LRAD1=.TRUE. 288 - LRAD2=.TRUE. 289 - ELSE 290 - CALL INPMSG(I+1,'Radius not positive.') 291 - ENDIF 292 - ELSE 293 - CALL INPMSG(I,'Arguments not valid.') 294 - ENDIF 295 - INEXT=I+2 296 - ELSEIF(INPCMP(I,'UP#PER-R#ADIUS').NE.0)THEN 297 - CALL INPCHK(I+1,2,IFAIL1) 298 - IF(IFAIL1.EQ.0)THEN 299 - CALL INPRDR(I+1,AUX1,-1.0) 300 - IF(AUX1.GT.0)THEN 301 - R2=AUX1 302 - LRAD2=.TRUE. 303 - ELSE 304 - CALL INPMSG(I+1,'Radius not positive.') 305 - ENDIF 306 - ELSE 307 - CALL INPMSG(I,'Arguments not valid.') 308 - ENDIF 309 - INEXT=I+2 310 - ELSEIF(INPCMP(I,'LOW#ER-R#ADIUS').NE.0)THEN 311 - CALL INPCHK(I+1,2,IFAIL1) 312 - IF(IFAIL1.EQ.0)THEN 313 - CALL INPRDR(I+1,AUX1,-1.0) 314 - IF(AUX1.GT.0)THEN 315 - R1=AUX1 316 - LRAD1=.TRUE. 317 - ELSE 1 453 P=CELL D=CELSOL 4 PAGE 567 318 - CALL INPMSG(I+1,'Radius not positive.') 319 - ENDIF 320 - ELSE 321 - CALL INPMSG(I,'Arguments not valid.') 322 - ENDIF 323 - INEXT=I+2 324 - * Half-lengths. 325 - ELSEIF(INPCMP(I,'HALF-#LENGTHS')+ 326 - - INPCMP(I,'HALF-#SIZES').NE.0)THEN 327 - CALL INPCHK(I+1,2,IFAIL1) 328 - CALL INPCHK(I+2,2,IFAIL2) 329 - CALL INPCHK(I+3,2,IFAIL3) 330 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN 331 - CALL INPRDR(I+1,AUX1,0.0) 332 - CALL INPRDR(I+2,AUX2,0.0) 333 - CALL INPRDR(I+3,AUX3,0.0) 334 - IF(AUX1.GT.0.AND.AUX2.GT.0.AND.AUX3.GT.0)THEN 335 - XSIZ=AUX1 336 - YSIZ=AUX2 337 - ZSIZ=AUX3 338 - LSIZ=.TRUE. 339 - ELSE 340 - IF(AUX1.LE.0)CALL INPMSG(I+1,'Is not > 0.') 341 - IF(AUX2.LE.0)CALL INPMSG(I+2,'Is not > 0.') 342 - IF(AUX3.LE.0)CALL INPMSG(I+3,'Is not > 0.') 343 - ENDIF 344 - ELSE 345 - CALL INPMSG(I,'Arguments not valid.') 346 - ENDIF 347 - INEXT=I+4 348 - * Material. 349 - ELSEIF(INPCMP(I,'CON#DUCTOR')+ 350 - - INPCMP(I,'CON#DUCTOR-1').NE.0)THEN 351 - IMAT=1 352 - ELSEIF(INPCMP(I,'CON#DUCTOR-2').NE.0)THEN 353 - IMAT=2 354 - ELSEIF(INPCMP(I,'CON#DUCTOR-3').NE.0)THEN 355 - IMAT=3 356 - ELSEIF(INPCMP(I,'DIEL#ECTRICUM')+ 357 - - INPCMP(I,'DIEL#ECTRICUM-1').NE.0)THEN 358 - IMAT=11 359 - ELSEIF(INPCMP(I,'DIEL#ECTRICUM-2').NE.0)THEN 360 - IMAT=12 361 - ELSEIF(INPCMP(I,'DIEL#ECTRICUM-3').NE.0)THEN 362 - IMAT=13 363 - * Label. 364 - ELSEIF(INPCMP(I,'LAB#EL')+INPCMP(I,'TYPE').NE.0)THEN 365 - CALL INPSTR(I+1,I+1,AUXTYP,NCAUX) 366 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',AUXTYP).EQ. 367 - - 0)THEN 368 - CALL INPMSG(1,'The label must be a letter.') 369 - AUXTYP='H' 370 - ENDIF 371 - INEXT=I+2 372 - * Other things are not known. 373 - ELSE 374 - CALL INPMSG(I,'Not a known keyword.') 375 - ENDIF 376 - 60 CONTINUE 377 - * Print error messages. 378 - CALL INPERR 379 - * Enter in the conductor table. 380 - IF(LPOS.AND.LRAD1.AND.LRAD2.AND.LSIZ.AND. 381 - - (NSOLID+1.GT.MXSOLI.OR.ICCURR+16.GT.MXSBUF))THEN 382 - PRINT *,' !!!!!! CELSOL WARNING : Conductor table'// 383 - - ' is full; hole not stored.' 384 - ELSEIF(LPOS.AND.LRAD1.AND.LRAD2.AND.LSIZ)THEN 385 - NSOLID=NSOLID+1 386 - ISTART(NSOLID)=ICCURR 387 - ISOLTP(NSOLID)=2 388 - ISOLMT(NSOLID)=IMAT 389 - SOLTYP(NSOLID)=AUXTYP 390 - CBUF(ICCURR+1)=R1 391 - CBUF(ICCURR+2)=R2 392 - CBUF(ICCURR+3)=XSIZ 393 - CBUF(ICCURR+4)=YSIZ 394 - CBUF(ICCURR+5)=ZSIZ 395 - CBUF(ICCURR+6)=XPOS 396 - CBUF(ICCURR+7)=YPOS 397 - CBUF(ICCURR+8)=ZPOS 398 - CBUF(ICCURR+9)=XDIR 399 - CBUF(ICCURR+10)=YDIR 400 - CBUF(ICCURR+11)=ZDIR 401 - CBUF(ICCURR+12)=DBLE(N) 402 - * Compute rotation angles. 403 - IF(XDIR**2+YDIR**2.LE.0)THEN 404 - PHI=0 405 - IF(ZDIR.GT.0)THEN 406 - THETA=0 407 - ELSE 408 - THETA=PI 409 - ENDIF 410 - ELSE 411 - PHI=ATAN2(YDIR,XDIR) 412 - THETA=ATAN2(SQRT(XDIR**2+YDIR**2),ZDIR) 413 - ENDIF 414 - CBUF(ICCURR+13)=COS(THETA) 415 - CBUF(ICCURR+14)=SIN(THETA) 416 - CBUF(ICCURR+15)=COS(PHI) 417 - CBUF(ICCURR+16)=SIN(PHI) 418 - ICCURR=ICCURR+16 419 - * Or warn that some element is missing. 420 - ELSE 421 - PRINT *,' !!!!!! CELSOL WARNING : Hole not'// 422 - - ' entered because the position, the radii'// 423 - - ' or the box size has not been given.' 1 453 P=CELL D=CELSOL 5 PAGE 568 424 - ENDIF 425 - *** Could be a box. 426 - ELSEIF(INPCMP(1,'BOX').NE.0)THEN 427 - * Default parameters. 428 - XDIR=0 429 - YDIR=0 430 - ZDIR=1 431 - IMAT=1 432 - AUXTYP='B' 433 - * Required parameters. 434 - LSIZ=.FALSE. 435 - LPOS=.FALSE. 436 - * Read the parameters. 437 - INEXT=2 438 - DO 40 I=2,NWORD 439 - IF(I.LT.INEXT)GOTO 40 440 - * Centre. 441 - IF(INPCMP(I,'CEN#TRE')+INPCMP(I,'CEN#TER').NE.0)THEN 442 - CALL INPCHK(I+1,2,IFAIL1) 443 - CALL INPCHK(I+2,2,IFAIL2) 444 - CALL INPCHK(I+3,2,IFAIL3) 445 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN 446 - CALL INPRDR(I+1,XPOS,0.0) 447 - CALL INPRDR(I+2,YPOS,0.0) 448 - CALL INPRDR(I+3,ZPOS,0.0) 449 - LPOS=.TRUE. 450 - ELSE 451 - CALL INPMSG(I,'Arguments not valid.') 452 - ENDIF 453 - INEXT=I+4 454 - * Direction. 455 - ELSEIF(INPCMP(I,'DIR#ECTION').NE.0)THEN 456 - CALL INPCHK(I+1,2,IFAIL1) 457 - CALL INPCHK(I+2,2,IFAIL2) 458 - CALL INPCHK(I+3,2,IFAIL3) 459 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN 460 - CALL INPRDR(I+1,XDIR,0.0) 461 - CALL INPRDR(I+2,YDIR,0.0) 462 - CALL INPRDR(I+3,ZDIR,0.0) 463 - ELSE 464 - CALL INPMSG(I,'Arguments not valid.') 465 - ENDIF 466 - INEXT=I+4 467 - * Half-lengths. 468 - ELSEIF(INPCMP(I,'HALF-#LENGTHS')+ 469 - - INPCMP(I,'HALF-#SIZES').NE.0)THEN 470 - CALL INPCHK(I+1,2,IFAIL1) 471 - CALL INPCHK(I+2,2,IFAIL2) 472 - CALL INPCHK(I+3,2,IFAIL3) 473 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN 474 - CALL INPRDR(I+1,AUX1,0.0) 475 - CALL INPRDR(I+2,AUX2,0.0) 476 - CALL INPRDR(I+3,AUX3,0.0) 477 - IF(AUX1.GT.0.AND.AUX2.GT.0.AND.AUX3.GT.0)THEN 478 - XSIZ=AUX1 479 - YSIZ=AUX2 480 - ZSIZ=AUX3 481 - LSIZ=.TRUE. 482 - ELSE 483 - IF(AUX1.LE.0)CALL INPMSG(I+1,'Is not > 0.') 484 - IF(AUX2.LE.0)CALL INPMSG(I+2,'Is not > 0.') 485 - IF(AUX3.LE.0)CALL INPMSG(I+3,'Is not > 0.') 486 - ENDIF 487 - ELSE 488 - CALL INPMSG(I,'Arguments not valid.') 489 - ENDIF 490 - INEXT=I+4 491 - * Material. 492 - ELSEIF(INPCMP(I,'CON#DUCTOR')+ 493 - - INPCMP(I,'CON#DUCTOR-1').NE.0)THEN 494 - IMAT=1 495 - ELSEIF(INPCMP(I,'CON#DUCTOR-2').NE.0)THEN 496 - IMAT=2 497 - ELSEIF(INPCMP(I,'CON#DUCTOR-3').NE.0)THEN 498 - IMAT=3 499 - ELSEIF(INPCMP(I,'DIEL#ECTRICUM')+ 500 - - INPCMP(I,'DIEL#ECTRICUM-1').NE.0)THEN 501 - IMAT=11 502 - ELSEIF(INPCMP(I,'DIEL#ECTRICUM-2').NE.0)THEN 503 - IMAT=12 504 - ELSEIF(INPCMP(I,'DIEL#ECTRICUM-3').NE.0)THEN 505 - IMAT=13 506 - * Label. 507 - ELSEIF(INPCMP(I,'LAB#EL')+INPCMP(I,'TYPE').NE.0)THEN 508 - CALL INPSTR(I+1,I+1,AUXTYP,NCAUX) 509 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',AUXTYP).EQ. 510 - - 0)THEN 511 - CALL INPMSG(1,'The label must be a letter.') 512 - AUXTYP='B' 513 - ENDIF 514 - INEXT=I+2 515 - * Other things are not known. 516 - ELSE 517 - CALL INPMSG(I,'Not a known keyword.') 518 - ENDIF 519 - 40 CONTINUE 520 - * Print error messages. 521 - CALL INPERR 522 - * Enter in the conductor table. 523 - IF(LPOS.AND.LSIZ.AND. 524 - - (NSOLID+1.GT.MXSOLI.OR.ICCURR+13.GT.MXSBUF))THEN 525 - PRINT *,' !!!!!! CELSOL WARNING : Conductor table'// 526 - - ' is full; box not stored.' 527 - ELSEIF(LPOS.AND.LSIZ)THEN 528 - NSOLID=NSOLID+1 529 - ISTART(NSOLID)=ICCURR 1 453 P=CELL D=CELSOL 6 PAGE 569 530 - ISOLTP(NSOLID)=3 531 - ISOLMT(NSOLID)=IMAT 532 - SOLTYP(NSOLID)=AUXTYP 533 - CBUF(ICCURR+1)=XSIZ 534 - CBUF(ICCURR+2)=YSIZ 535 - CBUF(ICCURR+3)=ZSIZ 536 - CBUF(ICCURR+4)=XPOS 537 - CBUF(ICCURR+5)=YPOS 538 - CBUF(ICCURR+6)=ZPOS 539 - CBUF(ICCURR+7)=XDIR 540 - CBUF(ICCURR+8)=YDIR 541 - CBUF(ICCURR+9)=ZDIR 542 - * Compute rotation angles. 543 - IF(XDIR**2+YDIR**2.LE.0)THEN 544 - PHI=0 545 - IF(ZDIR.GT.0)THEN 546 - THETA=0 547 - ELSE 548 - THETA=PI 549 - ENDIF 550 - ELSE 551 - PHI=ATAN2(YDIR,XDIR) 552 - THETA=ATAN2(SQRT(XDIR**2+YDIR**2),ZDIR) 553 - ENDIF 554 - CBUF(ICCURR+10)=COS(THETA) 555 - CBUF(ICCURR+11)=SIN(THETA) 556 - CBUF(ICCURR+12)=COS(PHI) 557 - CBUF(ICCURR+13)=SIN(PHI) 558 - ICCURR=ICCURR+13 559 - * Or warn that some element is missing. 560 - ELSE 561 - PRINT *,' !!!!!! CELSOL WARNING : Box not'// 562 - - ' entered because the position or the size'// 563 - - ' has not been given.' 564 - ENDIF 565 - *** Could also be sphere. 566 - ELSEIF(INPCMP(1,'SPHERE').NE.0)THEN 567 - * Required parameters. 568 - LRAD=.FALSE. 569 - LPOS=.FALSE. 570 - N=0 571 - IMAT=1 572 - AUXTYP='S' 573 - * Read the parameters. 574 - INEXT=2 575 - DO 50 I=2,NWORD 576 - IF(I.LT.INEXT)GOTO 50 577 - * Centre. 578 - IF(INPCMP(I,'CEN#TRE')+INPCMP(I,'CEN#TER').NE.0)THEN 579 - CALL INPCHK(I+1,2,IFAIL1) 580 - CALL INPCHK(I+2,2,IFAIL2) 581 - CALL INPCHK(I+3,2,IFAIL3) 582 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN 583 - CALL INPRDR(I+1,XPOS,0.0) 584 - CALL INPRDR(I+2,YPOS,0.0) 585 - CALL INPRDR(I+3,ZPOS,0.0) 586 - LPOS=.TRUE. 587 - ELSE 588 - CALL INPMSG(I,'Arguments not valid.') 589 - ENDIF 590 - INEXT=I+4 591 - * Radius. 592 - ELSEIF(INPCMP(I,'R#ADIUS').NE.0)THEN 593 - CALL INPCHK(I+1,2,IFAIL1) 594 - IF(IFAIL1.EQ.0)THEN 595 - CALL INPRDR(I+1,AUX1,-1.0) 596 - IF(AUX1.GT.0)THEN 597 - R=AUX1 598 - LRAD=.TRUE. 599 - ELSE 600 - CALL INPMSG(I+1,'Radius not positive.') 601 - ENDIF 602 - ELSE 603 - CALL INPMSG(I,'Arguments not valid.') 604 - ENDIF 605 - INEXT=I+2 606 - * Material. 607 - ELSEIF(INPCMP(I,'CON#DUCTOR')+ 608 - - INPCMP(I,'CON#DUCTOR-1').NE.0)THEN 609 - IMAT=1 610 - ELSEIF(INPCMP(I,'CON#DUCTOR-2').NE.0)THEN 611 - IMAT=2 612 - ELSEIF(INPCMP(I,'CON#DUCTOR-3').NE.0)THEN 613 - IMAT=3 614 - ELSEIF(INPCMP(I,'DIEL#ECTRICUM')+ 615 - - INPCMP(I,'DIEL#ECTRICUM-1').NE.0)THEN 616 - IMAT=11 617 - ELSEIF(INPCMP(I,'DIEL#ECTRICUM-2').NE.0)THEN 618 - IMAT=12 619 - ELSEIF(INPCMP(I,'DIEL#ECTRICUM-3').NE.0)THEN 620 - IMAT=13 621 - * Number of points. 622 - ELSEIF(INPCMP(I,'N').NE.0)THEN 623 - CALL INPCHK(I+1,1,IFAIL1) 624 - IF(IFAIL1.EQ.0)THEN 625 - CALL INPRDI(I+1,NR,-1) 626 - IF(NR.LE.1)THEN 627 - CALL INPMSG(I+1,'Should be > 1.') 628 - ELSE 629 - N=NR 630 - ENDIF 631 - ELSE 632 - CALL INPMSG(I,'Arguments not valid.') 633 - ENDIF 634 - INEXT=I+2 635 - * Label. 1 453 P=CELL D=CELSOL 7 PAGE 570 636 - ELSEIF(INPCMP(I,'LAB#EL')+INPCMP(I,'TYPE').NE.0)THEN 637 - CALL INPSTR(I+1,I+1,AUXTYP,NCAUX) 638 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',AUXTYP).EQ. 639 - - 0)THEN 640 - CALL INPMSG(1,'The label must be a letter.') 641 - AUXTYP='S' 642 - ENDIF 643 - INEXT=I+2 644 - * Other things are not known. 645 - ELSE 646 - CALL INPMSG(I,'Not a known keyword.') 647 - ENDIF 648 - 50 CONTINUE 649 - * Print error messages. 650 - CALL INPERR 651 - * Enter in the conductor table. 652 - IF(LPOS.AND.LRAD.AND. 653 - - (NSOLID+1.GT.MXSOLI.OR.ICCURR+5.GT.MXSBUF))THEN 654 - PRINT *,' !!!!!! CELSOL WARNING : Conductor table'// 655 - - ' is full; sphere not stored.' 656 - ELSEIF(LPOS.AND.LRAD)THEN 657 - NSOLID=NSOLID+1 658 - ISTART(NSOLID)=ICCURR 659 - ISOLTP(NSOLID)=4 660 - ISOLMT(NSOLID)=IMAT 661 - SOLTYP(NSOLID)=AUXTYP 662 - CBUF(ICCURR+1)=R 663 - CBUF(ICCURR+2)=XPOS 664 - CBUF(ICCURR+3)=YPOS 665 - CBUF(ICCURR+4)=ZPOS 666 - CBUF(ICCURR+5)=DBLE(N) 667 - ICCURR=ICCURR+5 668 - * Or warn that some element is missing. 669 - ELSE 670 - PRINT *,' !!!!!! CELSOL WARNING : Sphere not'// 671 - - ' entered because the position or the radius'// 672 - - ' has not been given.' 673 - ENDIF 674 - *** Other things are not known. 675 - ELSE 676 - CALL INPSTR(1,1,STRING,NC) 677 - PRINT *,' !!!!!! CELSOL WARNING : Shape '//STRING(1:NC)// 678 - - ' is not known; ignored.' 679 - ENDIF 680 - *** Read the next line. 681 - GOTO 10 682 - END 454 GARFIELD ================================================== P=CELL D=CELSPR 1 ============================ 0 + +DECK,CELSPR. 1 - SUBROUTINE CELSPR 2 - *----------------------------------------------------------------------- 3 - * CELSPR - Prints an overview of the solids. 4 - * (Last changed on 30/11/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,SOLIDS. 9.- +SEQ,CONSTANTS. 10.- +SEQ,PRINTPLOT. 11 - INTEGER I,NCYL,NHOLE,NBOX,NSPHER,NC1,NC2,NC3,NC4,NC5,NC6,NC7,NC8, 12 - - NC9,NC10,NC11,NC12,NCNUM 13 - CHARACTER*20 MAT,AUX1,AUX2,AUX3,AUX4,AUX5,AUX6,AUX7,AUX8,AUX9, 14 - - AUX10,AUX11,AUX12,AUXNUM 15 - *** See whether there are any solids. 16 - IF(NSOLID.LT.1)THEN 17 - WRITE(LUNOUT,'('' There are currently no solids.'')') 18 - RETURN 19 - ELSE 20 - WRITE(LUNOUT,'(/'' SOLIDS'')') 21 - ENDIF 22 - *** Count the various types of solids. 23 - NCYL=0 24 - NHOLE=0 25 - NBOX=0 26 - NSPHER=0 27 - DO 10 I=1,NSOLID 28 - IF(ISOLTP(I).EQ.1)THEN 29 - NCYL=NCYL+1 30 - ELSEIF(ISOLTP(I).EQ.2)THEN 31 - NHOLE=NHOLE+1 32 - ELSEIF(ISOLTP(I).EQ.3)THEN 33 - NBOX=NBOX+1 34 - ELSEIF(ISOLTP(I).EQ.4)THEN 35 - NSPHER=NSPHER+1 36 - ELSE 37 - PRINT *,' !!!!!! CELSPR WARNING : Found a solid of'// 38 - - ' unknown type ',ISOLTP(I),'; ignored.' 39 - ENDIF 40 - 10 CONTINUE 41 - *** Print the cylinders. 42 - IF(NCYL.GE.1)THEN 43 - WRITE(LUNOUT,'(/'' Cylinders:'')') 44 - DO 20 I=1,NSOLID 45 - IF(ISOLTP(I).NE.1)GOTO 20 46 - IF(ISOLMT(I).EQ.1)THEN 47 - MAT='Conductor 1' 48 - ELSEIF(ISOLMT(I).EQ.2)THEN 49 - MAT='Conductor 2' 50 - ELSEIF(ISOLMT(I).EQ.3)THEN 51 - MAT='Conductor 3' 52 - ELSEIF(ISOLMT(I).EQ.11)THEN 53 - MAT='Dielectricum 1' 54 - ELSEIF(ISOLMT(I).EQ.12)THEN 55 - MAT='Dielectricum 2' 1 454 P=CELL D=CELSPR 2 PAGE 571 56 - ELSEIF(ISOLMT(I).EQ.13)THEN 57 - MAT='Dielectricum 3' 58 - ELSE 59 - MAT='# Unknown' 60 - ENDIF 61 - CALL OUTFMT(REAL(I),2,AUXNUM,NCNUM,'LEFT') 62 - CALL OUTFMT(REAL(CBUF(ISTART(I)+1)),2,AUX1,NC1,'LEFT') 63 - CALL OUTFMT(REAL(CBUF(ISTART(I)+2)),2,AUX2,NC2,'LEFT') 64 - CALL OUTFMT(REAL(CBUF(ISTART(I)+3)),2,AUX3,NC3,'LEFT') 65 - CALL OUTFMT(REAL(CBUF(ISTART(I)+4)),2,AUX4,NC4,'LEFT') 66 - CALL OUTFMT(REAL(CBUF(ISTART(I)+5)),2,AUX5,NC5,'LEFT') 67 - CALL OUTFMT(REAL(CBUF(ISTART(I)+6)),2,AUX6,NC6,'LEFT') 68 - CALL OUTFMT(REAL(CBUF(ISTART(I)+7)),2,AUX7,NC7,'LEFT') 69 - CALL OUTFMT(REAL(CBUF(ISTART(I)+8)),2,AUX8,NC8,'LEFT') 70 - CALL OUTFMT(REAL(NINT(CBUF(ISTART(I)+9))),2,AUX9,NC9,'LEFT') 71 - WRITE(LUNOUT,'(2X,A1,A4,'' - '', 72 - - ''Radius: '',A,'' cm''/ 73 - - 10X,''Half-length: '',A,'' cm''/ 74 - - 10X,''Centre: ('',A,'', '',A,'', '',A,'') cm''/ 75 - - 10X,''Axis: ('',A,'', '',A,'', '',A,'')''/ 76 - - 10X,''Material: '',A/ 77 - - 10X,''Corners: '',A)') 78 - - SOLTYP(I),AUXNUM(1:4), 79 - - AUX1(1:NC1),AUX2(1:NC2),AUX3(1:NC3), 80 - - AUX4(1:NC4),AUX5(1:NC5),AUX6(1:NC6),AUX7(1:NC7), 81 - - AUX8(1:NC8),MAT,AUX9(1:NC9) 82 - 20 CONTINUE 83 - ENDIF 84 - *** Print the holes. 85 - IF(NHOLE.GE.1)THEN 86 - WRITE(LUNOUT,'(/'' Holes:'')') 87 - DO 30 I=1,NSOLID 88 - IF(ISOLTP(I).NE.2)GOTO 30 89 - IF(ISOLMT(I).EQ.1)THEN 90 - MAT='Conductor 1' 91 - ELSEIF(ISOLMT(I).EQ.2)THEN 92 - MAT='Conductor 2' 93 - ELSEIF(ISOLMT(I).EQ.3)THEN 94 - MAT='Conductor 3' 95 - ELSEIF(ISOLMT(I).EQ.11)THEN 96 - MAT='Dielectricum 1' 97 - ELSEIF(ISOLMT(I).EQ.12)THEN 98 - MAT='Dielectricum 2' 99 - ELSEIF(ISOLMT(I).EQ.13)THEN 100 - MAT='Dielectricum 3' 101 - ELSE 102 - MAT='# Unknown' 103 - ENDIF 104 - CALL OUTFMT(REAL(I),2,AUXNUM,NCNUM,'LEFT') 105 - CALL OUTFMT(REAL(CBUF(ISTART(I)+ 1)),2,AUX1, NC1, 'LEFT') 106 - CALL OUTFMT(REAL(CBUF(ISTART(I)+ 2)),2,AUX2, NC2, 'LEFT') 107 - CALL OUTFMT(REAL(CBUF(ISTART(I)+ 3)),2,AUX3, NC3, 'LEFT') 108 - CALL OUTFMT(REAL(CBUF(ISTART(I)+ 4)),2,AUX4, NC4, 'LEFT') 109 - CALL OUTFMT(REAL(CBUF(ISTART(I)+ 5)),2,AUX5, NC5, 'LEFT') 110 - CALL OUTFMT(REAL(CBUF(ISTART(I)+ 6)),2,AUX6, NC6, 'LEFT') 111 - CALL OUTFMT(REAL(CBUF(ISTART(I)+ 7)),2,AUX7, NC7, 'LEFT') 112 - CALL OUTFMT(REAL(CBUF(ISTART(I)+ 8)),2,AUX8, NC8, 'LEFT') 113 - CALL OUTFMT(REAL(CBUF(ISTART(I)+ 9)),2,AUX9, NC9, 'LEFT') 114 - CALL OUTFMT(REAL(CBUF(ISTART(I)+10)),2,AUX10,NC10,'LEFT') 115 - CALL OUTFMT(REAL(CBUF(ISTART(I)+11)),2,AUX11,NC11,'LEFT') 116 - CALL OUTFMT(REAL(NINT(CBUF(ISTART(I)+12))),2,AUX12,NC12, 117 - - 'LEFT') 118 - WRITE(LUNOUT,'(2X,A1,A4,'' - '', 119 - - ''Radii: '',A,'' and '',A,'' cm''/ 120 - - 10X,''Half-lengths: ('',A,'', '',A,'', '',A,'') cm''/ 121 - - 10X,''Centre: ('',A,'', '',A,'', '',A,'') cm''/ 122 - - 10X,''Axis: ('',A,'', '',A,'', '',A,'')''/ 123 - - 10X,''Material: '',A/ 124 - - 10X,''Corners: '',A)') 125 - - SOLTYP(I),AUXNUM(1:4), 126 - - AUX1(1:NC1),AUX2(1:NC2),AUX3(1:NC3), 127 - - AUX4(1:NC4),AUX5(1:NC5),AUX6(1:NC6),AUX7(1:NC7), 128 - - AUX8(1:NC8),AUX9(1:NC9),AUX10(1:NC10),AUX11(1:NC11), 129 - - MAT,AUX12(1:NC12) 130 - 30 CONTINUE 131 - ENDIF 132 - *** Print the boxes. 133 - IF(NBOX.GE.1)THEN 134 - WRITE(LUNOUT,'(/'' Boxes:'')') 135 - DO 40 I=1,NSOLID 136 - IF(ISOLTP(I).NE.3)GOTO 40 137 - IF(ISOLMT(I).EQ.1)THEN 138 - MAT='Conductor 1' 139 - ELSEIF(ISOLMT(I).EQ.2)THEN 140 - MAT='Conductor 2' 141 - ELSEIF(ISOLMT(I).EQ.3)THEN 142 - MAT='Conductor 3' 143 - ELSEIF(ISOLMT(I).EQ.11)THEN 144 - MAT='Dielectricum 1' 145 - ELSEIF(ISOLMT(I).EQ.12)THEN 146 - MAT='Dielectricum 2' 147 - ELSEIF(ISOLMT(I).EQ.13)THEN 148 - MAT='Dielectricum 3' 149 - ELSE 150 - MAT='# Unknown' 151 - ENDIF 152 - CALL OUTFMT(REAL(I),2,AUXNUM,NCNUM,'LEFT') 153 - CALL OUTFMT(REAL(CBUF(ISTART(I)+1)),2,AUX1,NC1,'LEFT') 154 - CALL OUTFMT(REAL(CBUF(ISTART(I)+2)),2,AUX2,NC2,'LEFT') 155 - CALL OUTFMT(REAL(CBUF(ISTART(I)+3)),2,AUX3,NC3,'LEFT') 156 - CALL OUTFMT(REAL(CBUF(ISTART(I)+4)),2,AUX4,NC4,'LEFT') 157 - CALL OUTFMT(REAL(CBUF(ISTART(I)+5)),2,AUX5,NC5,'LEFT') 158 - CALL OUTFMT(REAL(CBUF(ISTART(I)+6)),2,AUX6,NC6,'LEFT') 159 - CALL OUTFMT(REAL(CBUF(ISTART(I)+7)),2,AUX7,NC7,'LEFT') 160 - CALL OUTFMT(REAL(CBUF(ISTART(I)+8)),2,AUX8,NC8,'LEFT') 161 - CALL OUTFMT(REAL(CBUF(ISTART(I)+9)),2,AUX9,NC9,'LEFT') 1 454 P=CELL D=CELSPR 3 PAGE 572 162 - WRITE(LUNOUT,'(2X,A1,A4,'' - '', 163 - - ''Half-lengths: ('',A,'', '',A,'', '',A,'') cm''/ 164 - - 10X,''Centre: ('',A,'', '',A,'', '',A,'') cm''/ 165 - - 10X,''Axis: ('',A,'', '',A,'', '',A,'')''/ 166 - - 10X,''Material: '',A)') 167 - - SOLTYP(I),AUXNUM(1:4), 168 - - AUX1(1:NC1),AUX2(1:NC2),AUX3(1:NC3), 169 - - AUX4(1:NC4),AUX5(1:NC5),AUX6(1:NC6),AUX7(1:NC7), 170 - - AUX8(1:NC8),AUX9(1:NC9),MAT 171 - 40 CONTINUE 172 - ENDIF 173 - *** Print the spheres. 174 - IF(NSPHER.GE.1)THEN 175 - WRITE(LUNOUT,'(/'' Spheres:'')') 176 - DO 50 I=1,NSOLID 177 - IF(ISOLTP(I).NE.4)GOTO 50 178 - IF(ISOLMT(I).EQ.1)THEN 179 - MAT='Conductor 1' 180 - ELSEIF(ISOLMT(I).EQ.2)THEN 181 - MAT='Conductor 2' 182 - ELSEIF(ISOLMT(I).EQ.3)THEN 183 - MAT='Conductor 3' 184 - ELSEIF(ISOLMT(I).EQ.11)THEN 185 - MAT='Dielectricum 1' 186 - ELSEIF(ISOLMT(I).EQ.12)THEN 187 - MAT='Dielectricum 2' 188 - ELSEIF(ISOLMT(I).EQ.13)THEN 189 - MAT='Dielectricum 3' 190 - ELSE 191 - MAT='# Unknown' 192 - ENDIF 193 - CALL OUTFMT(REAL(I),2,AUXNUM,NCNUM,'LEFT') 194 - CALL OUTFMT(REAL(CBUF(ISTART(I)+1)),2,AUX1,NC1,'LEFT') 195 - CALL OUTFMT(REAL(CBUF(ISTART(I)+2)),2,AUX2,NC2,'LEFT') 196 - CALL OUTFMT(REAL(CBUF(ISTART(I)+3)),2,AUX3,NC3,'LEFT') 197 - CALL OUTFMT(REAL(CBUF(ISTART(I)+4)),2,AUX4,NC4,'LEFT') 198 - CALL OUTFMT(REAL(NINT(CBUF(ISTART(I)+5))),2,AUX5,NC5,'LEFT') 199 - WRITE(LUNOUT,'(2X,A1,A4,'' - '', 200 - - ''Radius: '',A,'' cm''/ 201 - - 10X,''Centre: ('',A,'', '',A,'', '',A,'') cm''/ 202 - - 10X,''Material: '',A/ 203 - - 10X,''Corners: '',A)') 204 - - SOLTYP(I),AUXNUM(1:4), 205 - - AUX1(1:NC1),AUX2(1:NC2),AUX3(1:NC3), 206 - - AUX4(1:NC4),MAT,AUX5(1:NC5) 207 - 50 CONTINUE 208 - ENDIF 209 - END 455 GARFIELD ================================================== P=CELL D=CELLA3 1 ============================ 0 + +DECK,CELLA3. 1 - SUBROUTINE CELLA3 2 - *----------------------------------------------------------------------- 3 - * CELLA3 - This routine draws all elements of the cell inside the 4 - * box (PPXMIN,PPYMIN,PPZMIN) to (PPXMAX,PPYMAX,PPZMAX), 5 - * taking care of periodicities etc, on the plot being made. 6 - * Version used for 3D impressions of space. 7 - * VARIABLES : NXMIN,NXMAX: Numbers of resp first and last x-period. 8 - * NYMIN,NYMAX: " " " " " " y " 9 - * XPL,YPL : Used for plotting of lines. 10 - * (Last changed on 1/12/00.) 11 - *----------------------------------------------------------------------- 12 - implicit none 13.- +SEQ,DIMENSIONS. 14.- +SEQ,CELLDATA. 15.- +SEQ,SOLIDS. 16.- +SEQ,CONSTANTS. 17.- +SEQ,PRINTPLOT. 18.- +SEQ,PARAMETERS. 19 - DOUBLE PRECISION XPL(5),YPL(5),WW,XPMIN,YPMIN,XPMAX,YPMAX, 20 - - X1,Y1,X2,Y2,XX1,YY1,XX2,YY2,SMIN,SMAX 21 - INTEGER NX,NXMIN,NXMAX,NY,NYMIN,NYMAX,I,ICOL,IFAIL1,NMAX 22 - PARAMETER(NMAX=100) 23 - *** Determine the number of periods present in the cell. 24 - NXMIN=0 25 - NXMAX=0 26 - NYMIN=0 27 - NYMAX=0 28 - IF(PERX)THEN 29 - NXMIN=INT(GXMIN/SX)-1 30 - NXMAX=INT(GXMAX/SX)+1 31 - ENDIF 32 - IF(PERY)THEN 33 - NYMIN=INT(GYMIN/SY)-1 34 - NYMAX=INT(GYMAX/SY)+1 35 - ENDIF 36 - *** Draw the illuminated x and y-planes, set the representations. 37 - CALL GRATTS('PLANES','AREA') 38 - CALL GRATTS('PLANES','POLYLINE') 39 - * Generate the colour table (shared with the tube). 40 - IF((YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4)).AND. 41 - - ICOLPL.EQ.0)THEN 42 - ICOLPL=ICOL0 43 - CALL COLSHD(ICOLPL) 44 - ICOL0=ICOL0+NPRCOL 45 - ENDIF 46 - * Ensure the planes do not hide each other. 47 - IF(YNPLAN(1))THEN 48 - XPMIN=COPLAN(1) 49 - ELSE 50 - XPMIN=GXMIN 51 - ENDIF 52 - IF(YNPLAN(2))THEN 53 - XPMAX=COPLAN(2) 54 - ELSE 1 455 P=CELL D=CELLA3 2 PAGE 573 55 - XPMAX=GXMAX 56 - ENDIF 57 - IF(YNPLAN(3))THEN 58 - YPMIN=COPLAN(3) 59 - ELSE 60 - YPMIN=GYMIN 61 - ENDIF 62 - IF(YNPLAN(4))THEN 63 - YPMAX=COPLAN(4) 64 - ELSE 65 - YPMAX=GYMAX 66 - ENDIF 67 - * The x-planes. 68 - DO 10 NX=NXMIN,NXMAX 69 - IF(YNPLAN(1).AND.COPLAN(1)+NX*SX.GE.GXMIN.AND. 70 - - COPLAN(1)+NX*SX.LE.GXMAX.AND.FPROJA.GT.0)THEN 71 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMIN,GZMIN,XPL(1),YPL(1)) 72 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMIN,GZMAX,XPL(2),YPL(2)) 73 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMAX,GZMAX,XPL(3),YPL(3)) 74 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMAX,GZMIN,XPL(4),YPL(4)) 75 - XPL(5)=XPL(1) 76 - YPL(5)=YPL(1) 77 - CALL COLWGT(+1.0D0,0.0D0,0.0D0,WW) 78 - IF(WW.GE.0)THEN 79 - ICOL=ICOLPL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 80 - ELSE 81 - PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// 82 - - ' a plane seen from the back (program bug).' 83 - ICOL=ICOLPL 84 - ENDIF 85 - CALL GSFACI(ICOL) 86 - CALL GFA2(5,XPL,YPL) 87 - CALL GPL2(5,XPL,YPL) 88 - ENDIF 89 - IF(YNPLAN(2).AND.COPLAN(2)+NX*SX.GE.GXMIN.AND. 90 - - COPLAN(2)+NX*SX.LE.GXMAX.AND.FPROJA.LT.0)THEN 91 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMIN,GZMIN,XPL(1),YPL(1)) 92 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMIN,GZMAX,XPL(2),YPL(2)) 93 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMAX,GZMAX,XPL(3),YPL(3)) 94 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMAX,GZMIN,XPL(4),YPL(4)) 95 - XPL(5)=XPL(1) 96 - YPL(5)=YPL(1) 97 - CALL COLWGT(-1.0D0,0.0D0,0.0D0,WW) 98 - IF(WW.GE.0)THEN 99 - ICOL=ICOLPL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 100 - ELSE 101 - PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// 102 - - ' a plane seen from the back (program bug).' 103 - ICOL=ICOLPL 104 - ENDIF 105 - CALL GSFACI(ICOL) 106 - CALL GFA2(5,XPL,YPL) 107 - CALL GPL2(5,XPL,YPL) 108 - ENDIF 109 - 10 CONTINUE 110 - DO 20 NY=NYMIN,NYMAX 111 - IF(YNPLAN(3).AND.COPLAN(3)+NY*SY.GE.GYMIN.AND. 112 - - COPLAN(3)+NY*SY.LE.GYMAX.AND.FPROJB.GT.0)THEN 113 - CALL PLACOO(XPMIN,DBLE(COPLAN(3)+NY*SY),GZMIN,XPL(1),YPL(1)) 114 - CALL PLACOO(XPMIN,DBLE(COPLAN(3)+NY*SY),GZMAX,XPL(2),YPL(2)) 115 - CALL PLACOO(XPMAX,DBLE(COPLAN(3)+NY*SY),GZMAX,XPL(3),YPL(3)) 116 - CALL PLACOO(XPMAX,DBLE(COPLAN(3)+NY*SY),GZMIN,XPL(4),YPL(4)) 117 - XPL(5)=XPL(1) 118 - YPL(5)=YPL(1) 119 - CALL COLWGT(0.0D0,+1.0D0,0.0D0,WW) 120 - IF(WW.GE.0)THEN 121 - ICOL=ICOLPL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 122 - ELSE 123 - PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// 124 - - ' a plane seen from the back (program bug).' 125 - ICOL=ICOLPL 126 - ENDIF 127 - CALL GSFACI(ICOL) 128 - CALL GFA2(5,XPL,YPL) 129 - CALL GPL2(5,XPL,YPL) 130 - ENDIF 131 - IF(YNPLAN(4).AND.COPLAN(4)+NY*SY.GE.GYMIN.AND. 132 - - COPLAN(4)+NY*SY.LE.GYMAX.AND.FPROJB.LT.0)THEN 133 - CALL PLACOO(XPMIN,DBLE(COPLAN(4)+NY*SY),GZMIN,XPL(1),YPL(1)) 134 - CALL PLACOO(XPMIN,DBLE(COPLAN(4)+NY*SY),GZMAX,XPL(2),YPL(2)) 135 - CALL PLACOO(XPMAX,DBLE(COPLAN(4)+NY*SY),GZMAX,XPL(3),YPL(3)) 136 - CALL PLACOO(XPMAX,DBLE(COPLAN(4)+NY*SY),GZMIN,XPL(4),YPL(4)) 137 - XPL(5)=XPL(1) 138 - YPL(5)=YPL(1) 139 - CALL COLWGT(0.0D0,-1.0D0,0.0D0,WW) 140 - IF(WW.GE.0)THEN 141 - ICOL=ICOLPL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 142 - ELSE 143 - PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// 144 - - ' a plane seen from the back (program bug).' 145 - ICOL=ICOLPL 146 - ENDIF 147 - CALL GSFACI(ICOL) 148 - CALL GFA2(5,XPL,YPL) 149 - CALL GPL2(5,XPL,YPL) 150 - ENDIF 151 - 20 CONTINUE 152 - *** Draw the illuminated x and y-plane strips, set the representations. 153 - CALL GRATTS('STRIPS','AREA') 154 - CALL GRATTS('STRIPS','POLYLINE') 155 - * Generate the colour table (shared with the tube). 156 - IF((YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4)).AND. 157 - - ICOLST.EQ.0)THEN 158 - ICOLST=ICOL0 159 - CALL COLSHD(ICOLST) 160 - ICOL0=ICOL0+NPRCOL 1 455 P=CELL D=CELLA3 3 PAGE 574 161 - ENDIF 162 - * Ensure the planes do not hide each other. 163 - IF(YNPLAN(1))THEN 164 - XPMIN=COPLAN(1) 165 - ELSE 166 - XPMIN=GXMIN 167 - ENDIF 168 - IF(YNPLAN(2))THEN 169 - XPMAX=COPLAN(2) 170 - ELSE 171 - XPMAX=GXMAX 172 - ENDIF 173 - IF(YNPLAN(3))THEN 174 - YPMIN=COPLAN(3) 175 - ELSE 176 - YPMIN=GYMIN 177 - ENDIF 178 - IF(YNPLAN(4))THEN 179 - YPMAX=COPLAN(4) 180 - ELSE 181 - YPMAX=GYMAX 182 - ENDIF 183 - * The x-planes. 184 - DO 110 NX=NXMIN,NXMAX 185 - IF(YNPLAN(1).AND.COPLAN(1)+NX*SX.GE.GXMIN.AND. 186 - - COPLAN(1)+NX*SX.LE.GXMAX.AND.FPROJA.GT.0)THEN 187 - DO 130 I=1,NPSTR1(1) 188 - SMIN=DBLE(PLSTR1(1,I,1)) 189 - SMAX=DBLE(PLSTR1(1,I,2)) 190 - IF(SMAX.LT.GYMIN.OR.SMIN.GT.GYMAX)GOTO 130 191 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),SMIN,GZMIN,XPL(1),YPL(1)) 192 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),SMIN,GZMAX,XPL(2),YPL(2)) 193 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),SMAX,GZMAX,XPL(3),YPL(3)) 194 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),SMAX,GZMIN,XPL(4),YPL(4)) 195 - XPL(5)=XPL(1) 196 - YPL(5)=YPL(1) 197 - CALL COLWGT(+1.0D0,0.0D0,0.0D0,WW) 198 - IF(WW.GE.0)THEN 199 - ICOL=ICOLST+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 200 - ELSE 201 - PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// 202 - - ' a plane seen from the back (program bug).' 203 - ICOL=ICOLST 204 - ENDIF 205 - CALL GSFACI(ICOL) 206 - CALL GFA2(5,XPL,YPL) 207 - CALL GPL2(5,XPL,YPL) 208 - 130 CONTINUE 209 - DO 140 I=1,NPSTR2(1) 210 - SMIN=DBLE(PLSTR2(1,I,1)) 211 - SMAX=DBLE(PLSTR2(1,I,2)) 212 - IF(SMAX.LT.GZMIN.OR.SMIN.GT.GZMAX)GOTO 140 213 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMIN,SMIN,XPL(1),YPL(1)) 214 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMIN,SMAX,XPL(2),YPL(2)) 215 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMAX,SMAX,XPL(3),YPL(3)) 216 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMAX,SMIN,XPL(4),YPL(4)) 217 - XPL(5)=XPL(1) 218 - YPL(5)=YPL(1) 219 - CALL COLWGT(+1.0D0,0.0D0,0.0D0,WW) 220 - IF(WW.GE.0)THEN 221 - ICOL=ICOLST+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 222 - ELSE 223 - PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// 224 - - ' a plane seen from the back (program bug).' 225 - ICOL=ICOLST 226 - ENDIF 227 - CALL GSFACI(ICOL) 228 - CALL GFA2(5,XPL,YPL) 229 - CALL GPL2(5,XPL,YPL) 230 - 140 CONTINUE 231 - ENDIF 232 - IF(YNPLAN(2).AND.COPLAN(2)+NX*SX.GE.GXMIN.AND. 233 - - COPLAN(2)+NX*SX.LE.GXMAX.AND.FPROJA.LT.0)THEN 234 - DO 150 I=1,NPSTR1(2) 235 - SMIN=DBLE(PLSTR1(2,I,1)) 236 - SMAX=DBLE(PLSTR1(2,I,2)) 237 - IF(SMAX.LT.GYMIN.OR.SMIN.GT.GYMAX)GOTO 150 238 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),SMIN,GZMIN,XPL(1),YPL(1)) 239 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),SMIN,GZMAX,XPL(2),YPL(2)) 240 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),SMAX,GZMAX,XPL(3),YPL(3)) 241 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),SMAX,GZMIN,XPL(4),YPL(4)) 242 - XPL(5)=XPL(1) 243 - YPL(5)=YPL(1) 244 - CALL COLWGT(-1.0D0,0.0D0,0.0D0,WW) 245 - IF(WW.GE.0)THEN 246 - ICOL=ICOLST+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 247 - ELSE 248 - PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// 249 - - ' a plane seen from the back (program bug).' 250 - ICOL=ICOLST 251 - ENDIF 252 - CALL GSFACI(ICOL) 253 - CALL GFA2(5,XPL,YPL) 254 - CALL GPL2(5,XPL,YPL) 255 - 150 CONTINUE 256 - DO 160 I=1,NPSTR2(2) 257 - SMIN=DBLE(PLSTR2(2,I,1)) 258 - SMAX=DBLE(PLSTR2(2,I,2)) 259 - IF(SMAX.LT.GZMIN.OR.SMIN.GT.GZMAX)GOTO 160 260 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMIN,SMIN,XPL(1),YPL(1)) 261 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMIN,SMAX,XPL(2),YPL(2)) 262 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMAX,SMAX,XPL(3),YPL(3)) 263 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMAX,SMIN,XPL(4),YPL(4)) 264 - XPL(5)=XPL(1) 265 - YPL(5)=YPL(1) 266 - CALL COLWGT(-1.0D0,0.0D0,0.0D0,WW) 1 455 P=CELL D=CELLA3 4 PAGE 575 267 - IF(WW.GE.0)THEN 268 - ICOL=ICOLST+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 269 - ELSE 270 - PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// 271 - - ' a plane seen from the back (program bug).' 272 - ICOL=ICOLST 273 - ENDIF 274 - CALL GSFACI(ICOL) 275 - CALL GFA2(5,XPL,YPL) 276 - CALL GPL2(5,XPL,YPL) 277 - 160 CONTINUE 278 - ENDIF 279 - 110 CONTINUE 280 - DO 120 NY=NYMIN,NYMAX 281 - IF(YNPLAN(3).AND.COPLAN(3)+NY*SY.GE.GYMIN.AND. 282 - - COPLAN(3)+NY*SY.LE.GYMAX.AND.FPROJB.GT.0)THEN 283 - DO 170 I=1,NPSTR1(3) 284 - SMIN=DBLE(PLSTR1(3,I,1)) 285 - SMAX=DBLE(PLSTR1(3,I,2)) 286 - IF(SMAX.LT.GXMIN.OR.SMIN.GT.GXMAX)GOTO 170 287 - CALL PLACOO(SMIN,DBLE(COPLAN(3)+NY*SY),GZMIN,XPL(1),YPL(1)) 288 - CALL PLACOO(SMIN,DBLE(COPLAN(3)+NY*SY),GZMAX,XPL(2),YPL(2)) 289 - CALL PLACOO(SMAX,DBLE(COPLAN(3)+NY*SY),GZMAX,XPL(3),YPL(3)) 290 - CALL PLACOO(SMAX,DBLE(COPLAN(3)+NY*SY),GZMIN,XPL(4),YPL(4)) 291 - XPL(5)=XPL(1) 292 - YPL(5)=YPL(1) 293 - CALL COLWGT(0.0D0,+1.0D0,0.0D0,WW) 294 - IF(WW.GE.0)THEN 295 - ICOL=ICOLST+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 296 - ELSE 297 - PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// 298 - - ' a plane seen from the back (program bug).' 299 - ICOL=ICOLST 300 - ENDIF 301 - CALL GSFACI(ICOL) 302 - CALL GFA2(5,XPL,YPL) 303 - CALL GPL2(5,XPL,YPL) 304 - 170 CONTINUE 305 - DO 180 I=1,NPSTR2(3) 306 - SMIN=DBLE(PLSTR2(3,I,1)) 307 - SMAX=DBLE(PLSTR2(3,I,2)) 308 - IF(SMAX.LT.GZMIN.OR.SMIN.GT.GZMAX)GOTO 180 309 - CALL PLACOO(XPMIN,DBLE(COPLAN(3)+NY*SY),SMIN,XPL(1),YPL(1)) 310 - CALL PLACOO(XPMIN,DBLE(COPLAN(3)+NY*SY),SMAX,XPL(2),YPL(2)) 311 - CALL PLACOO(XPMAX,DBLE(COPLAN(3)+NY*SY),SMAX,XPL(3),YPL(3)) 312 - CALL PLACOO(XPMAX,DBLE(COPLAN(3)+NY*SY),SMIN,XPL(4),YPL(4)) 313 - XPL(5)=XPL(1) 314 - YPL(5)=YPL(1) 315 - CALL COLWGT(0.0D0,+1.0D0,0.0D0,WW) 316 - IF(WW.GE.0)THEN 317 - ICOL=ICOLST+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 318 - ELSE 319 - PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// 320 - - ' a plane seen from the back (program bug).' 321 - ICOL=ICOLST 322 - ENDIF 323 - CALL GSFACI(ICOL) 324 - CALL GFA2(5,XPL,YPL) 325 - CALL GPL2(5,XPL,YPL) 326 - 180 CONTINUE 327 - ENDIF 328 - IF(YNPLAN(4).AND.COPLAN(4)+NY*SY.GE.GYMIN.AND. 329 - - COPLAN(4)+NY*SY.LE.GYMAX.AND.FPROJB.LT.0)THEN 330 - DO 190 I=1,NPSTR1(4) 331 - SMIN=DBLE(PLSTR1(4,I,1)) 332 - SMAX=DBLE(PLSTR1(4,I,2)) 333 - IF(SMAX.LT.GXMIN.OR.SMIN.GT.GXMAX)GOTO 190 334 - CALL PLACOO(SMIN,DBLE(COPLAN(4)+NY*SY),GZMIN,XPL(1),YPL(1)) 335 - CALL PLACOO(SMIN,DBLE(COPLAN(4)+NY*SY),GZMAX,XPL(2),YPL(2)) 336 - CALL PLACOO(SMAX,DBLE(COPLAN(4)+NY*SY),GZMAX,XPL(3),YPL(3)) 337 - CALL PLACOO(SMAX,DBLE(COPLAN(4)+NY*SY),GZMIN,XPL(4),YPL(4)) 338 - XPL(5)=XPL(1) 339 - YPL(5)=YPL(1) 340 - CALL COLWGT(0.0D0,-1.0D0,0.0D0,WW) 341 - IF(WW.GE.0)THEN 342 - ICOL=ICOLST+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 343 - ELSE 344 - PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// 345 - - ' a plane seen from the back (program bug).' 346 - ICOL=ICOLST 347 - ENDIF 348 - CALL GSFACI(ICOL) 349 - CALL GFA2(5,XPL,YPL) 350 - CALL GPL2(5,XPL,YPL) 351 - 190 CONTINUE 352 - DO 200 I=1,NPSTR2(4) 353 - SMIN=DBLE(PLSTR2(4,I,1)) 354 - SMAX=DBLE(PLSTR2(4,I,2)) 355 - IF(SMAX.LT.GZMIN.OR.SMIN.GT.GZMAX)GOTO 200 356 - CALL PLACOO(XPMIN,DBLE(COPLAN(4)+NY*SY),SMIN,XPL(1),YPL(1)) 357 - CALL PLACOO(XPMIN,DBLE(COPLAN(4)+NY*SY),SMAX,XPL(2),YPL(2)) 358 - CALL PLACOO(XPMAX,DBLE(COPLAN(4)+NY*SY),SMAX,XPL(3),YPL(3)) 359 - CALL PLACOO(XPMAX,DBLE(COPLAN(4)+NY*SY),SMIN,XPL(4),YPL(4)) 360 - XPL(5)=XPL(1) 361 - YPL(5)=YPL(1) 362 - CALL COLWGT(0.0D0,-1.0D0,0.0D0,WW) 363 - IF(WW.GE.0)THEN 364 - ICOL=ICOLST+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 365 - ELSE 366 - PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// 367 - - ' a plane seen from the back (program bug).' 368 - ICOL=ICOLST 369 - ENDIF 370 - CALL GSFACI(ICOL) 371 - CALL GFA2(5,XPL,YPL) 372 - CALL GPL2(5,XPL,YPL) 1 455 P=CELL D=CELLA3 5 PAGE 576 373 - 200 CONTINUE 374 - ENDIF 375 - 120 CONTINUE 376 - *** Draw the illuminated parts of the tube. 377 - IF(TUBE)THEN 378 - * Set the representations. 379 - CALL GRATTS('TUBE','POLYLINE') 380 - CALL GRATTS('TUBE','AREA') 381 - * Generate the colour table (shared with the planes). 382 - IF(ICOLPL.EQ.0)THEN 383 - ICOLPL=ICOL0 384 - CALL COLSHD(ICOLPL) 385 - ICOL0=ICOL0+NPRCOL 386 - ENDIF 387 - * Case of a polygon. 388 - IF(NTUBE.GT.0)THEN 389 - X1=COTUBE*COS(2.0D0*PI*DBLE(0)/DBLE(NTUBE)) 390 - Y1=COTUBE*SIN(2.0D0*PI*DBLE(0)/DBLE(NTUBE)) 391 - DO 50 I=1,NTUBE 392 - X2=COTUBE*COS(2.0D0*PI*DBLE(I)/DBLE(NTUBE)) 393 - Y2=COTUBE*SIN(2.0D0*PI*DBLE(I)/DBLE(NTUBE)) 394 - XX1=X1 395 - YY1=Y1 396 - XX2=X2 397 - YY2=Y2 398 - CALL CLIP2D(XX1,YY1,XX2,YY2,GXMIN,GYMIN, 399 - - GXMAX,GYMAX,IFAIL1) 400 - IF(IFAIL1.NE.0)THEN 401 - X1=X2 402 - Y1=Y2 403 - GOTO 50 404 - ENDIF 405 - CALL PLACOO(XX1,YY1,GZMIN,XPL(1),YPL(1)) 406 - CALL PLACOO(XX1,YY1,GZMAX,XPL(2),YPL(2)) 407 - CALL PLACOO(XX2,YY2,GZMAX,XPL(3),YPL(3)) 408 - CALL PLACOO(XX2,YY2,GZMIN,XPL(4),YPL(4)) 409 - XPL(5)=XPL(1) 410 - YPL(5)=YPL(1) 411 - CALL COLWGT(-X1-X2,-Y1-Y2,0.0D0,WW) 412 - IF(WW.GE.0)THEN 413 - ICOL=ICOLPL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 414 - CALL GSFACI(ICOL) 415 - CALL GFA2(5,XPL,YPL) 416 - CALL GPL2(5,XPL,YPL) 417 - ENDIF 418 - X1=X2 419 - Y1=Y2 420 - 50 CONTINUE 421 - * Case of a cylinder. 422 - ELSE 423 - X1=COTUBE*COS(2.0D0*PI*DBLE(0)/DBLE(NMAX)) 424 - Y1=COTUBE*SIN(2.0D0*PI*DBLE(0)/DBLE(NMAX)) 425 - DO 70 I=1,NMAX 426 - X2=COTUBE*COS(2.0D0*PI*DBLE(I)/DBLE(NMAX)) 427 - Y2=COTUBE*SIN(2.0D0*PI*DBLE(I)/DBLE(NMAX)) 428 - XX1=X1 429 - YY1=Y1 430 - XX2=X2 431 - YY2=Y2 432 - CALL CLIP2D(XX1,YY1,XX2,YY2,GXMIN,GYMIN, 433 - - GXMAX,GYMAX,IFAIL1) 434 - IF(IFAIL1.NE.0)THEN 435 - X1=X2 436 - Y1=Y2 437 - GOTO 70 438 - ENDIF 439 - CALL PLACOO(XX1,YY1,GZMIN,XPL(1),YPL(1)) 440 - CALL PLACOO(XX1,YY1,GZMAX,XPL(2),YPL(2)) 441 - CALL PLACOO(XX2,YY2,GZMAX,XPL(3),YPL(3)) 442 - CALL PLACOO(XX2,YY2,GZMIN,XPL(4),YPL(4)) 443 - XPL(5)=XPL(1) 444 - YPL(5)=YPL(1) 445 - CALL COLWGT(-X1-X2,-Y1-Y2,0.0D0,WW) 446 - IF(WW.GE.0)THEN 447 - ICOL=ICOLPL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) 448 - CALL GSFACI(ICOL) 449 - CALL GFA2(5,XPL,YPL) 450 - ENDIF 451 - CALL GPL2(2,XPL(2),YPL(2)) 452 - CALL GPL2(2,XPL(4),YPL(4)) 453 - X1=X2 454 - Y1=Y2 455 - 70 CONTINUE 456 - ENDIF 457 - ENDIF 458 - *** Plot the solids. 459 - CALL PLAPLT 460 - *** Draw the parts of the tube seen from the outside. 461 - IF(TUBE.AND.LFULLT)THEN 462 - * Set the representations. 463 - CALL GRATTS('TUBE','POLYLINE') 464 - * Case of a polygon. 465 - IF(NTUBE.GT.0)THEN 466 - X1=COTUBE*COS(2.0D0*PI*DBLE(0)/DBLE(NTUBE)) 467 - Y1=COTUBE*SIN(2.0D0*PI*DBLE(0)/DBLE(NTUBE)) 468 - DO 60 I=1,NTUBE 469 - X2=COTUBE*COS(2.0D0*PI*DBLE(I)/DBLE(NTUBE)) 470 - Y2=COTUBE*SIN(2.0D0*PI*DBLE(I)/DBLE(NTUBE)) 471 - XX1=X1 472 - YY1=Y1 473 - XX2=X2 474 - YY2=Y2 475 - CALL CLIP2D(XX1,YY1,XX2,YY2,GXMIN,GYMIN, 476 - - GXMAX,GYMAX,IFAIL1) 477 - IF(IFAIL1.NE.0)THEN 478 - X1=X2 1 455 P=CELL D=CELLA3 6 PAGE 577 479 - Y1=Y2 480 - GOTO 60 481 - ENDIF 482 - CALL PLACOO(XX1,YY1,GZMIN,XPL(1),YPL(1)) 483 - CALL PLACOO(XX1,YY1,GZMAX,XPL(2),YPL(2)) 484 - CALL PLACOO(XX2,YY2,GZMAX,XPL(3),YPL(3)) 485 - CALL PLACOO(XX2,YY2,GZMIN,XPL(4),YPL(4)) 486 - XPL(5)=XPL(1) 487 - YPL(5)=YPL(1) 488 - CALL COLWGT(-X1-X2,-Y1-Y2,0.0D0,WW) 489 - IF(WW.LT.0)CALL GPL2(5,XPL,YPL) 490 - X1=X2 491 - Y1=Y2 492 - 60 CONTINUE 493 - * Case of a cylinder. 494 - ELSE 495 - X1=COTUBE*COS(2.0D0*PI*DBLE(0)/DBLE(NMAX)) 496 - Y1=COTUBE*SIN(2.0D0*PI*DBLE(0)/DBLE(NMAX)) 497 - DO 80 I=1,NMAX 498 - X2=COTUBE*COS(2.0D0*PI*DBLE(I)/DBLE(NMAX)) 499 - Y2=COTUBE*SIN(2.0D0*PI*DBLE(I)/DBLE(NMAX)) 500 - XX1=X1 501 - YY1=Y1 502 - XX2=X2 503 - YY2=Y2 504 - CALL CLIP2D(XX1,YY1,XX2,YY2,GXMIN,GYMIN, 505 - - GXMAX,GYMAX,IFAIL1) 506 - IF(IFAIL1.NE.0)THEN 507 - X1=X2 508 - Y1=Y2 509 - GOTO 80 510 - ENDIF 511 - CALL COLWGT(-X1-X2,-Y1-Y2,0.0D0,WW) 512 - IF(WW.LT.0)THEN 513 - CALL PLACOO(XX1,YY1,GZMIN,XPL(1),YPL(1)) 514 - CALL PLACOO(XX2,YY2,GZMIN,XPL(2),YPL(2)) 515 - CALL GPL2(2,XPL,YPL) 516 - CALL PLACOO(XX1,YY1,GZMAX,XPL(1),YPL(1)) 517 - CALL PLACOO(XX2,YY2,GZMAX,XPL(2),YPL(2)) 518 - CALL GPL2(2,XPL,YPL) 519 - ENDIF 520 - X1=X2 521 - Y1=Y2 522 - 80 CONTINUE 523 - ENDIF 524 - ENDIF 525 - *** Second pass of the x and y-planes, set the representations. 526 - IF(LFULLP)THEN 527 - * Set the representation. 528 - CALL GRATTS('PLANES','POLYLINE') 529 - * The x-planes. 530 - DO 30 NX=NXMIN,NXMAX 531 - IF(YNPLAN(1).AND.COPLAN(1)+NX*SX.GE.GXMIN.AND. 532 - - COPLAN(1)+NX*SX.LE.GXMAX.AND.FPROJA.LE.0)THEN 533 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMIN,GZMIN, 534 - - XPL(1),YPL(1)) 535 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMIN,GZMAX, 536 - - XPL(2),YPL(2)) 537 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMAX,GZMAX, 538 - - XPL(3),YPL(3)) 539 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMAX,GZMIN, 540 - - XPL(4),YPL(4)) 541 - XPL(5)=XPL(1) 542 - YPL(5)=YPL(1) 543 - CALL GPL2(5,XPL,YPL) 544 - ENDIF 545 - IF(YNPLAN(2).AND.COPLAN(2)+NX*SX.GE.GXMIN.AND. 546 - - COPLAN(2)+NX*SX.LE.GXMAX.AND.FPROJA.GE.0)THEN 547 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMIN,GZMIN, 548 - - XPL(1),YPL(1)) 549 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMIN,GZMAX, 550 - - XPL(2),YPL(2)) 551 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMAX,GZMAX, 552 - - XPL(3),YPL(3)) 553 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMAX,GZMIN, 554 - - XPL(4),YPL(4)) 555 - XPL(5)=XPL(1) 556 - YPL(5)=YPL(1) 557 - CALL GPL2(5,XPL,YPL) 558 - ENDIF 559 - 30 CONTINUE 560 - DO 40 NY=NYMIN,NYMAX 561 - IF(YNPLAN(3).AND.COPLAN(3)+NY*SY.GE.GYMIN.AND. 562 - - COPLAN(3)+NY*SY.LE.GYMAX.AND.FPROJB.LE.0)THEN 563 - CALL PLACOO(XPMIN,DBLE(COPLAN(3)+NY*SY),GZMIN, 564 - - XPL(1),YPL(1)) 565 - CALL PLACOO(XPMIN,DBLE(COPLAN(3)+NY*SY),GZMAX, 566 - - XPL(2),YPL(2)) 567 - CALL PLACOO(XPMAX,DBLE(COPLAN(3)+NY*SY),GZMAX, 568 - - XPL(3),YPL(3)) 569 - CALL PLACOO(XPMAX,DBLE(COPLAN(3)+NY*SY),GZMIN, 570 - - XPL(4),YPL(4)) 571 - XPL(5)=XPL(1) 572 - YPL(5)=YPL(1) 573 - CALL GPL2(5,XPL,YPL) 574 - ENDIF 575 - IF(YNPLAN(4).AND.COPLAN(4)+NY*SY.GE.GYMIN.AND. 576 - - COPLAN(4)+NY*SY.LE.GYMAX.AND.FPROJB.GE.0)THEN 577 - CALL PLACOO(XPMIN,DBLE(COPLAN(4)+NY*SY),GZMIN, 578 - - XPL(1),YPL(1)) 579 - CALL PLACOO(XPMIN,DBLE(COPLAN(4)+NY*SY),GZMAX, 580 - - XPL(2),YPL(2)) 581 - CALL PLACOO(XPMAX,DBLE(COPLAN(4)+NY*SY),GZMAX, 582 - - XPL(3),YPL(3)) 583 - CALL PLACOO(XPMAX,DBLE(COPLAN(4)+NY*SY),GZMIN, 584 - - XPL(4),YPL(4)) 1 455 P=CELL D=CELLA3 7 PAGE 578 585 - XPL(5)=XPL(1) 586 - YPL(5)=YPL(1) 587 - CALL GPL2(5,XPL,YPL) 588 - ENDIF 589 - 40 CONTINUE 590 - ** Plot the strips, set the representation. 591 - CALL GRATTS('STRIPS','POLYLINE') 592 - * The x-planes. 593 - DO 210 NX=NXMIN,NXMAX 594 - IF(YNPLAN(1).AND.COPLAN(1)+NX*SX.GE.GXMIN.AND. 595 - - COPLAN(1)+NX*SX.LE.GXMAX.AND.FPROJA.LE.0)THEN 596 - DO 230 I=1,NPSTR1(1) 597 - SMIN=DBLE(PLSTR1(1,I,1)) 598 - SMAX=DBLE(PLSTR1(1,I,2)) 599 - IF(SMAX.LT.GYMIN.OR.SMIN.GT.GYMAX)GOTO 230 600 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),SMIN,GZMIN, 601 - - XPL(1),YPL(1)) 602 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),SMIN,GZMAX, 603 - - XPL(2),YPL(2)) 604 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),SMAX,GZMAX, 605 - - XPL(3),YPL(3)) 606 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),SMAX,GZMIN, 607 - - XPL(4),YPL(4)) 608 - XPL(5)=XPL(1) 609 - YPL(5)=YPL(1) 610 - CALL GPL2(5,XPL,YPL) 611 - 230 CONTINUE 612 - DO 240 I=1,NPSTR2(1) 613 - SMIN=DBLE(PLSTR2(1,I,1)) 614 - SMAX=DBLE(PLSTR2(1,I,2)) 615 - IF(SMAX.LT.GZMIN.OR.SMIN.GT.GZMAX)GOTO 240 616 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMIN,SMIN, 617 - - XPL(1),YPL(1)) 618 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMIN,SMAX, 619 - - XPL(2),YPL(2)) 620 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMAX,SMAX, 621 - - XPL(3),YPL(3)) 622 - CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMAX,SMIN, 623 - - XPL(4),YPL(4)) 624 - XPL(5)=XPL(1) 625 - YPL(5)=YPL(1) 626 - CALL GPL2(5,XPL,YPL) 627 - 240 CONTINUE 628 - ENDIF 629 - IF(YNPLAN(2).AND.COPLAN(2)+NX*SX.GE.GXMIN.AND. 630 - - COPLAN(2)+NX*SX.LE.GXMAX.AND.FPROJA.GE.0)THEN 631 - DO 250 I=1,NPSTR1(2) 632 - SMIN=DBLE(PLSTR1(2,I,1)) 633 - SMAX=DBLE(PLSTR1(2,I,2)) 634 - IF(SMAX.LT.GYMIN.OR.SMIN.GT.GYMAX)GOTO 250 635 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),SMIN,GZMIN, 636 - - XPL(1),YPL(1)) 637 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),SMIN,GZMAX, 638 - - XPL(2),YPL(2)) 639 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),SMAX,GZMAX, 640 - - XPL(3),YPL(3)) 641 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),SMAX,GZMIN, 642 - - XPL(4),YPL(4)) 643 - XPL(5)=XPL(1) 644 - YPL(5)=YPL(1) 645 - CALL GPL2(5,XPL,YPL) 646 - 250 CONTINUE 647 - DO 260 I=1,NPSTR2(2) 648 - SMIN=DBLE(PLSTR2(2,I,1)) 649 - SMAX=DBLE(PLSTR2(2,I,2)) 650 - IF(SMAX.LT.GZMIN.OR.SMIN.GT.GZMAX)GOTO 260 651 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMIN,SMIN, 652 - - XPL(1),YPL(1)) 653 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMIN,SMAX, 654 - - XPL(2),YPL(2)) 655 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMAX,SMAX, 656 - - XPL(3),YPL(3)) 657 - CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMAX,SMIN, 658 - - XPL(4),YPL(4)) 659 - XPL(5)=XPL(1) 660 - YPL(5)=YPL(1) 661 - CALL GPL2(5,XPL,YPL) 662 - 260 CONTINUE 663 - ENDIF 664 - 210 CONTINUE 665 - DO 220 NY=NYMIN,NYMAX 666 - IF(YNPLAN(3).AND.COPLAN(3)+NY*SY.GE.GYMIN.AND. 667 - - COPLAN(3)+NY*SY.LE.GYMAX.AND.FPROJB.LE.0)THEN 668 - DO 270 I=1,NPSTR1(3) 669 - SMIN=DBLE(PLSTR1(3,I,1)) 670 - SMAX=DBLE(PLSTR1(3,I,2)) 671 - IF(SMAX.LT.GXMIN.OR.SMIN.GT.GXMAX)GOTO 270 672 - CALL PLACOO(SMIN,DBLE(COPLAN(3)+NY*SY),GZMIN, 673 - - XPL(1),YPL(1)) 674 - CALL PLACOO(SMIN,DBLE(COPLAN(3)+NY*SY),GZMAX, 675 - - XPL(2),YPL(2)) 676 - CALL PLACOO(SMAX,DBLE(COPLAN(3)+NY*SY),GZMAX, 677 - - XPL(3),YPL(3)) 678 - CALL PLACOO(SMAX,DBLE(COPLAN(3)+NY*SY),GZMIN, 679 - - XPL(4),YPL(4)) 680 - XPL(5)=XPL(1) 681 - YPL(5)=YPL(1) 682 - CALL GPL2(5,XPL,YPL) 683 - 270 CONTINUE 684 - DO 280 I=1,NPSTR2(3) 685 - SMIN=DBLE(PLSTR2(3,I,1)) 686 - SMAX=DBLE(PLSTR2(3,I,2)) 687 - IF(SMAX.LT.GZMIN.OR.SMIN.GT.GZMAX)GOTO 280 688 - CALL PLACOO(XPMIN,DBLE(COPLAN(3)+NY*SY),SMIN, 689 - - XPL(1),YPL(1)) 690 - CALL PLACOO(XPMIN,DBLE(COPLAN(3)+NY*SY),SMAX, 1 455 P=CELL D=CELLA3 8 PAGE 579 691 - - XPL(2),YPL(2)) 692 - CALL PLACOO(XPMAX,DBLE(COPLAN(3)+NY*SY),SMAX, 693 - - XPL(3),YPL(3)) 694 - CALL PLACOO(XPMAX,DBLE(COPLAN(3)+NY*SY),SMIN, 695 - - XPL(4),YPL(4)) 696 - XPL(5)=XPL(1) 697 - YPL(5)=YPL(1) 698 - CALL GPL2(5,XPL,YPL) 699 - 280 CONTINUE 700 - ENDIF 701 - IF(YNPLAN(4).AND.COPLAN(4)+NY*SY.GE.GYMIN.AND. 702 - - COPLAN(4)+NY*SY.LE.GYMAX.AND.FPROJB.GE.0)THEN 703 - DO 290 I=1,NPSTR1(4) 704 - SMIN=DBLE(PLSTR1(4,I,1)) 705 - SMAX=DBLE(PLSTR1(4,I,2)) 706 - IF(SMAX.LT.GXMIN.OR.SMIN.GT.GXMAX)GOTO 290 707 - CALL PLACOO(SMIN,DBLE(COPLAN(4)+NY*SY),GZMIN, 708 - - XPL(1),YPL(1)) 709 - CALL PLACOO(SMIN,DBLE(COPLAN(4)+NY*SY),GZMAX, 710 - - XPL(2),YPL(2)) 711 - CALL PLACOO(SMAX,DBLE(COPLAN(4)+NY*SY),GZMAX, 712 - - XPL(3),YPL(3)) 713 - CALL PLACOO(SMAX,DBLE(COPLAN(4)+NY*SY),GZMIN, 714 - - XPL(4),YPL(4)) 715 - XPL(5)=XPL(1) 716 - YPL(5)=YPL(1) 717 - CALL GPL2(5,XPL,YPL) 718 - 290 CONTINUE 719 - DO 300 I=1,NPSTR2(4) 720 - SMIN=DBLE(PLSTR2(4,I,1)) 721 - SMAX=DBLE(PLSTR2(4,I,2)) 722 - IF(SMAX.LT.GZMIN.OR.SMIN.GT.GZMAX)GOTO 300 723 - CALL PLACOO(XPMIN,DBLE(COPLAN(4)+NY*SY),SMIN, 724 - - XPL(1),YPL(1)) 725 - CALL PLACOO(XPMIN,DBLE(COPLAN(4)+NY*SY),SMAX, 726 - - XPL(2),YPL(2)) 727 - CALL PLACOO(XPMAX,DBLE(COPLAN(4)+NY*SY),SMAX, 728 - - XPL(3),YPL(3)) 729 - CALL PLACOO(XPMAX,DBLE(COPLAN(4)+NY*SY),SMIN, 730 - - XPL(4),YPL(4)) 731 - XPL(5)=XPL(1) 732 - YPL(5)=YPL(1) 733 - CALL GPL2(5,XPL,YPL) 734 - 300 CONTINUE 735 - ENDIF 736 - 220 CONTINUE 737 - ENDIF 738 - END 456 GARFIELD ================================================== P=CELL D=CELLAC 1 ============================ 0 + +DECK,CELLAC. 1 - SUBROUTINE CELLAC(VXMIN,VYMIN,VXMAX,VYMAX) 2 - *----------------------------------------------------------------------- 3 - * CELLAC - This routine draws all elements of the cell inside the 4 - * rectangle (VXMIN,VYMIN) to (VXMAX,VYMAX), taking care of 5 - * periodicities etc, on the plot being made. Basic version 6 - * for 3D impression. 7 - * VARIABLES : NXMIN,NXMAX: Numbers of resp first and last x-period. 8 - * NYMIN,NYMAX: " " " " " " y " 9 - * (Last changed on 8/10/98.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,CELLDATA. 14.- +SEQ,CONSTANTS. 15.- +SEQ,PRINTPLOT. 16.- +SEQ,PARAMETERS. 17.- +SEQ,SOLIDS. 18 - DOUBLE PRECISION VXMIN,VYMIN,VXMAX,VYMAX 19 - INTEGER NX,NXMIN,NXMAX,NY,NYMIN,NYMAX 20 - *** Determine the number of periods present in the cell. 21 - NXMIN=0 22 - NXMAX=0 23 - NYMIN=0 24 - NYMAX=0 25 - IF(PERX)THEN 26 - NXMIN=INT(GXMIN/SX)-1 27 - NXMAX=INT(GXMAX/SX)+1 28 - ENDIF 29 - IF(PERY)THEN 30 - NYMIN=INT(GYMIN/SY)-1 31 - NYMAX=INT(GYMAX/SY)+1 32 - ENDIF 33 - *** Draw the field map if present. 34 - CALL MAPPLT(REAL(GXMIN),REAL(GYMIN),REAL(GZMIN), 35 - - REAL(GXMAX),REAL(GYMAX),REAL(GZMAX)) 36 - *** Draw the cuts. 37 - CALL PLAPLT 38 - *** Draw lines at the positions of the x and y-planes. 39 - CALL GRATTS('PLANES','POLYLINE') 40 - DO 60 NX=NXMIN,NXMAX 41 - IF(YNPLAN(1).AND.COPLAN(1)+NX*SX.GE.GXMIN.AND. 42 - - COPLAN(1)+NX*SX.LE.GXMAX)CALL PLAPLA(1.0D0,0.0D0,0.0D0, 43 - - DBLE(COPLAN(1)+NX*SX),VXMIN,VYMIN,VXMAX,VYMAX) 44 - IF(YNPLAN(2).AND.COPLAN(2)+NX*SX.GE.GXMIN.AND. 45 - - COPLAN(2)+NX*SX.LE.GXMAX)CALL PLAPLA(1.0D0,0.0D0,0.0D0, 46 - - DBLE(COPLAN(2)+NX*SX),VXMIN,VYMIN,VXMAX,VYMAX) 47 - 60 CONTINUE 48 - DO 90 NY=NYMIN,NYMAX 49 - IF(YNPLAN(3).AND.COPLAN(3)+NY*SY.GE.GYMIN.AND. 50 - - COPLAN(3)+NY*SY.LE.GYMAX)CALL PLAPLA(0.0D0,1.0D0,0.0D0, 51 - - DBLE(COPLAN(3)+NY*SY),VXMIN,VYMIN,VXMAX,VYMAX) 52 - IF(YNPLAN(4).AND.COPLAN(4)+NY*SY.GE.GYMIN.AND. 53 - - COPLAN(4)+NY*SY.LE.GYMAX)CALL PLAPLA(0.0D0,1.0D0,0.0D0, 54 - - DBLE(COPLAN(4)+NY*SY),VXMIN,VYMIN,VXMAX,VYMAX) 1 456 P=CELL D=CELLAC 2 PAGE 580 55 - 90 CONTINUE 56 - *** Draw the tube. 57 - IF(TUBE)THEN 58 - CALL GRATTS('TUBE','POLYLINE') 59 - CALL PLATUB(DBLE(COTUBE),NTUBE,DBLE(ZMIN),DBLE(ZMAX)) 60 - ENDIF 61 - END 457 GARFIELD ================================================== P=CELL D=CELWCH 1 ============================ 0 + +DECK,CELWCH. 1 - SUBROUTINE CELWCH(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * CELWCH - Subroutine checking the wire positions only, contrary 4 - * to CELCHK, this routine does not modify the cell. 5 - * (Last changed on 22/ 5/96.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,PARAMETERS. 11.- +SEQ,CONSTANTS. 12 - *** Identify the routine. 13 - IF(LIDENT)PRINT *,' /// ROUTINE CELWCH ///' 14 - IFAIL=0 15 - *** Preliminary checks, NWIRE > 0, data has to be present. 16 - IF(NWIRE.LE.0)THEN 17 - IFAIL=1 18 - RETURN 19 - ENDIF 20 - IF(NWIRE.LE.1.AND. 21 - - .NOT.(YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4)).AND. 22 - - .NOT.TUBE)THEN 23 - IFAIL=1 24 - RETURN 25 - ENDIF 26 - *** Check position relative to the planes. 27 - DO 70 I=1,NWIRE 28 - IF(YNPLAN(1).AND.X(I)-0.5*D(I).LE.COPLAN(1))IFAIL=1 29 - IF(YNPLAN(2).AND.X(I)+0.5*D(I).GE.COPLAN(2))IFAIL=1 30 - IF(YNPLAN(3).AND.Y(I)-0.5*D(I).LE.COPLAN(3))IFAIL=1 31 - IF(YNPLAN(4).AND.Y(I)+0.5*D(I).GE.COPLAN(4))IFAIL=1 32 - IF(TUBE)THEN 33 - CALL INTUBE(X(I),Y(I),COTUBE,NTUBE,IOUT) 34 - IF(IOUT.NE.0)IFAIL=1 35 - ELSEIF((PERX.AND.D(I).GE.SX).OR.(PERY.AND.D(I).GE.SY))THEN 36 - IFAIL=1 37 - ENDIF 38 - 70 CONTINUE 39 - *** Don't continue if IFAIL is already 1. 40 - IF(IFAIL.NE.0)RETURN 41 - *** Check the wire spacing. 42 - DO 90 I=1,NWIRE 43 - DO 80 J=I+1,NWIRE 44 - IF(TUBE)THEN 45 - IF(PERY)THEN 46 - CALL CFMCTP(X(I),Y(I),XAUX1,YAUX1,1) 47 - CALL CFMCTP(X(J),Y(J),XAUX2,YAUX2,1) 48 - YAUX1=YAUX1-SY*ANINT(YAUX1/SY) 49 - YAUX2=YAUX2-SY*ANINT(YAUX2/SY) 50 - CALL CFMPTC(XAUX1,YAUX1,XAUX1,YAUX1,1) 51 - CALL CFMPTC(XAUX2,YAUX2,XAUX2,YAUX2,1) 52 - XSEPAR=XAUX1-XAUX2 53 - YSEPAR=YAUX1-YAUX2 54 - ELSE 55 - XSEPAR=X(I)-X(J) 56 - YSEPAR=Y(I)-Y(J) 57 - ENDIF 58 - ELSE 59 - XSEPAR=ABS(X(I)-X(J)) 60 - IF(PERX)XSEPAR=XSEPAR-SX*ANINT(XSEPAR/SX) 61 - YSEPAR=ABS(Y(I)-Y(J)) 62 - IF(PERY)YSEPAR=YSEPAR-SY*ANINT(YSEPAR/SY) 63 - ENDIF 64 - IF(XSEPAR**2+YSEPAR**2.LT.0.25*(D(I)+D(J))**2)IFAIL=1 65 - 80 CONTINUE 66 - 90 CONTINUE 67 - END 458 GARFIELD ================================================== P=CELL D=CELDEF 1 ============================ 0 + +DECK,CELDEF. 1 - SUBROUTINE CELDEF(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * CELDEF - Routine controling the flow of the cell-definition routines 4 - * it calls CELINP ,CELPRT, CELPLT, CELCHK, SETUP and CELTYP. 5 - * VARIABLES : IGET : 1 if cell was read from dataset, 0 else. 6 - * (Last changed on 7/12/00.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,CONSTANTS. 12.- +SEQ,CELLDATA. 13.- +SEQ,FIELDMAP. 14.- +SEQ,PARAMETERS. 15.- +SEQ,DRIFTLINE. 16 - INTEGER IFAIL,IGET,I,J 17 - *** Reset the cell data. 18 - CALL CELINT 19 - IF(LSYNCH)WRITE(6,'('' >>>>>> set cell set 0'')') 20 - *** Write the header of the cell section. 21 - WRITE(*,'(''1'')') 22 - PRINT *,' ================================================' 23 - PRINT *,' ========== Start of cell definition ==========' 24 - PRINT *,' ================================================' 1 458 P=CELL D=CELDEF 2 PAGE 581 25 - PRINT *,' ' 26 - *** Read the cell data, IGET tells the origin of the data. 27 - IGET=0 28 - CALL CELINP(IGET,IFAIL) 29 - IF(IFAIL.NE.0)THEN 30 - PRINT *,' ###### CELDEF ERROR : Your cell description'// 31 - - ' can not be processed ; no cell data.' 32 - RETURN 33 - ENDIF 34 - IF(IGET.EQ.1)GOTO 10 35 - *** Check that the cell makes sense. 36 - CALL CELCHK(IFAIL) 37 - IF(IFAIL.EQ.1)THEN 38 - PRINT *,' ###### CELDEF ERROR : Your cell does not'// 39 - - ' meet the requirements ; no cell data.' 40 - RETURN 41 - ENDIF 42 - *** Determine the cell type. 43 - CALL CELTYP 44 - *** Calculate the charges. 45 - CALL SETUP(IFAIL) 46 - IF(IFAIL.EQ.1)THEN 47 - PRINT *,' ###### CELDEF ERROR : Cell preparation is'// 48 - - ' stopped; end of this cell section.' 49 - RETURN 50 - ENDIF 51 - *** Assign default strip widths. 52 - CALL CELSTR(IFAIL) 53 - IF(IFAIL.EQ.1)THEN 54 - PRINT *,' ###### CELDEF ERROR : Strip preparation'// 55 - - ' failed; end of this cell section.' 56 - RETURN 57 - ENDIF 58 - 10 CONTINUE 59 - *** Output the cell data to a printer or a plotter, if requested. 60 - IF(LCELPR)CALL CELPRT 61 - IF(LCELPL)CALL CELPLT 62 - *** Write the complete cell data in compact format to a dataset. 63 - CALL CELWRT(2) 64 - *** Preselect the sense wires, taking all wires with code S. 65 - NSW=0 66 - DO 20 I=1,NWIRE 67 - IF(WIRTYP(I).EQ.'S')THEN 68 - NSW=NSW+1 69 - INDSW(I)=NSW 70 - ELSE 71 - INDSW(I)=0 72 - ENDIF 73 - 20 CONTINUE 74 - DO 30 I=1,5 75 - IF(I.LE.4)THEN 76 - IF(.NOT.YNPLAN(I))GOTO 30 77 - ENDIF 78 - IF(PLATYP(I).EQ.'S')THEN 79 - NSW=NSW+1 80 - INDPLA(I)=NSW 81 - ELSE 82 - INDPLA(I)=0 83 - ENDIF 84 - DO 50 J=1,NPSTR1(I) 85 - IF(PSLAB1(I,J).EQ.'S')THEN 86 - NSW=NSW+1 87 - INDST1(I,J)=NSW 88 - ELSE 89 - INDST1(I,J)=0 90 - ENDIF 91 - 50 CONTINUE 92 - DO 60 J=1,NPSTR2(I) 93 - IF(PSLAB2(I,J).EQ.'S')THEN 94 - NSW=NSW+1 95 - INDST2(I,J)=NSW 96 - ELSE 97 - INDST2(I,J)=0 98 - ENDIF 99 - 60 CONTINUE 100 - 30 CONTINUE 101 - DO 40 I=1,NWMAP 102 - IF(EWSTYP(I).EQ.'S')THEN 103 - NSW=NSW+1 104 - INDEWS(I)=NSW 105 - ELSE 106 - INDEWS(I)=0 107 - ENDIF 108 - 40 CONTINUE 109 - IF(NSW.GT.MXSW)THEN 110 - PRINT *,' !!!!!! CELDEF WARNING : Too many'// 111 - - ' electrodes with label S for default'// 112 - - ' selection; reducing the set.' 113 - NSW=MXSW 114 - ENDIF 115 - *** Get rid of the current track. 116 - CALL TRAINT 117 - *** Set the default field plotting area. 118 - PXMIN=XMIN-(XMAX-XMIN)*0.1 119 - PXMAX=XMAX+(XMAX-XMIN)*0.1 120 - PYMIN=YMIN-(YMAX-YMIN)*0.1 121 - PYMAX=YMAX+(YMAX-YMIN)*0.1 122 - PZMIN=ZMIN-(ZMAX-ZMIN)*0.1 123 - PZMAX=ZMAX+(ZMAX-ZMIN)*0.1 124 - IF(POLAR.AND.PYMAX-PYMIN.GE.2.0*PI)THEN 125 - PYMIN=-PI 126 - PYMAX=PI 127 - ENDIF 128 - *** Set the default graphics area. 129 - GXMIN=DBLE(PXMIN) 130 - GYMIN=DBLE(PYMIN) 1 458 P=CELL D=CELDEF 3 PAGE 582 131 - GZMIN=DBLE(PZMIN) 132 - GXMAX=DBLE(PXMAX) 133 - GYMAX=DBLE(PYMAX) 134 - GZMAX=DBLE(PZMAX) 135 - *** Define the default drift area. 136 - DXMIN=XMIN 137 - IF(YNPLAN(1))DXMIN=COPLAN(1)+0.01*(XMAX-XMIN) 138 - DXMAX=XMAX 139 - IF(YNPLAN(2))DXMAX=COPLAN(2)-0.01*(XMAX-XMIN) 140 - DYMIN=YMIN 141 - IF(YNPLAN(3))DYMIN=COPLAN(3)+0.01*(YMAX-YMIN) 142 - DYMAX=YMAX 143 - IF(YNPLAN(4))DYMAX=COPLAN(4)-0.01*(YMAX-YMIN) 144 - DZMIN=ZMIN 145 - DZMAX=ZMAX 146 - IF(POLAR.AND.DYMAX-DYMIN.GE.2.0*PI)THEN 147 - PYMIN=-PI 148 - PYMAX=+PI 149 - ENDIF 150 - *** Set the default projection method. 151 - CALL PLAINT 152 - IF(POLAR)THEN 153 - PRVIEW='R-PHI' 154 - ELSE 155 - PRVIEW='X-Y' 156 - ENDIF 157 - *** Seems to have worked. 158 - CELSET=.TRUE. 159 - *** Output for synchronisation. 160 - IF(LSYNCH)CALL CELSYN 161 - END 459 GARFIELD ================================================== P=CELL D=CELRES 1 ============================ 0 + +DECK,CELRES. 1 - SUBROUTINE CELRES(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * CELRES - Recomputes the current cell after modification. 4 - * VARIABLES : 5 - * (Last changed on 5/12/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,CONSTANTS. 11.- +SEQ,CELLDATA. 12.- +SEQ,FIELDMAP. 13.- +SEQ,PARAMETERS. 14.- +SEQ,DRIFTLINE. 15 - INTEGER IFAIL,I,J 16 - *** Tracing output. 17 - IF(LIDENT)PRINT *,' /// ROUTINE CELRES ///' 18 - *** Reset the cell flag. 19 - CELSET=.FALSE. 20 - IF(LSYNCH)WRITE(6,'('' >>>>>> set cell set 0'')') 21 - *** Check that the cell makes sense. 22 - CALL CELCHK(IFAIL) 23 - IF(IFAIL.EQ.1)THEN 24 - PRINT *,' ###### CELRES ERROR : Your cell does not'// 25 - - ' meet the requirements ; no cell data.' 26 - RETURN 27 - ENDIF 28 - *** Determine the cell type. 29 - CALL CELTYP 30 - *** Calculate the charges. 31 - CALL SETUP(IFAIL) 32 - IF(IFAIL.EQ.1)THEN 33 - PRINT *,' ###### CELRES ERROR : Cell preparation is'// 34 - - ' stopped; end of this cell-section' 35 - PRINT *,' slightly varying the'// 36 - - ' wire diameters might help.' 37 - RETURN 38 - ENDIF 39 - 10 CONTINUE 40 - *** Preselect the sense wires, taking all wires with code S. 41 - NSW=0 42 - DO 20 I=1,NWIRE 43 - IF(WIRTYP(I).EQ.'S')THEN 44 - NSW=NSW+1 45 - INDSW(I)=NSW 46 - ELSE 47 - INDSW(I)=0 48 - ENDIF 49 - 20 CONTINUE 50 - DO 30 I=1,5 51 - IF(I.LE.4)THEN 52 - IF(.NOT.YNPLAN(I))GOTO 30 53 - ENDIF 54 - IF(PLATYP(I).EQ.'S')THEN 55 - NSW=NSW+1 56 - INDPLA(I)=NSW 57 - ELSE 58 - INDPLA(I)=0 59 - ENDIF 60 - DO 50 J=1,NPSTR1(I) 61 - IF(PSLAB1(I,J).EQ.'S')THEN 62 - NSW=NSW+1 63 - INDST1(I,J)=NSW 64 - ELSE 65 - INDST1(I,J)=0 66 - ENDIF 67 - 50 CONTINUE 68 - DO 60 J=1,NPSTR2(I) 69 - IF(PSLAB2(I,J).EQ.'S')THEN 70 - NSW=NSW+1 71 - INDST2(I,J)=NSW 1 459 P=CELL D=CELRES 2 PAGE 583 72 - ELSE 73 - INDST2(I,J)=0 74 - ENDIF 75 - 60 CONTINUE 76 - 30 CONTINUE 77 - DO 40 I=1,NWMAP 78 - IF(EWSTYP(I).EQ.'S')THEN 79 - NSW=NSW+1 80 - INDEWS(I)=NSW 81 - ELSE 82 - INDEWS(I)=0 83 - ENDIF 84 - 40 CONTINUE 85 - IF(NSW.GT.MXSW)THEN 86 - PRINT *,' !!!!!! CELRES WARNING : Too many'// 87 - - ' electrodes with label S for default'// 88 - - ' selection; reducing the set.' 89 - NSW=MXSW 90 - ENDIF 91 - *** Get rid of the current track. 92 - CALL TRAINT 93 - *** Set the default field plotting area. 94 - PXMIN=XMIN-(XMAX-XMIN)*0.1 95 - PXMAX=XMAX+(XMAX-XMIN)*0.1 96 - PYMIN=YMIN-(YMAX-YMIN)*0.1 97 - PYMAX=YMAX+(YMAX-YMIN)*0.1 98 - PZMIN=ZMIN-(ZMAX-ZMIN)*0.1 99 - PZMAX=ZMAX+(ZMAX-ZMIN)*0.1 100 - IF(POLAR.AND.PYMAX-PYMIN.GE.2.0*PI)THEN 101 - PYMIN=-PI 102 - PYMAX=PI 103 - ENDIF 104 - *** Set the default graphics area. 105 - GXMIN=DBLE(PXMIN) 106 - GYMIN=DBLE(PYMIN) 107 - GZMIN=DBLE(PZMIN) 108 - GXMAX=DBLE(PXMAX) 109 - GYMAX=DBLE(PYMAX) 110 - GZMAX=DBLE(PZMAX) 111 - *** Define the default drift area. 112 - DXMIN=XMIN 113 - IF(YNPLAN(1))DXMIN=COPLAN(1)+0.01*(XMAX-XMIN) 114 - DXMAX=XMAX 115 - IF(YNPLAN(2))DXMAX=COPLAN(2)-0.01*(XMAX-XMIN) 116 - DYMIN=YMIN 117 - IF(YNPLAN(3))DYMIN=COPLAN(3)+0.01*(YMAX-YMIN) 118 - DYMAX=YMAX 119 - IF(YNPLAN(4))DYMAX=COPLAN(4)-0.01*(YMAX-YMIN) 120 - DZMIN=ZMIN 121 - DZMAX=ZMAX 122 - IF(POLAR.AND.DYMAX-DYMIN.GE.2.0*PI)THEN 123 - PYMIN=-PI 124 - PYMAX=+PI 125 - ENDIF 126 - *** Seems to have worked. 127 - CELSET=.TRUE. 128 - *** Output for synchronisation. 129 - IF(LSYNCH)CALL CELSYN 130 - END 460 GARFIELD ================================================== P=CELL D=CELGET 1 ============================ 0 + +DECK,CELGET. 1 - SUBROUTINE CELGET(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * CELGET - This routine reads all cell information from an external 4 - * dataset. It checks that the dataset exists and that it is 5 - * of the correct type. 6 - * VARIABLES : STRING : Character string that should contain a 7 - * description of the dataset being read. 8 - * (Last changed on 29/11/00.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13.- +SEQ,SOLIDS. 14.- +SEQ,PRINTPLOT. 15 - CHARACTER*(MXINCH) STRING 16 - CHARACTER*8 MEMBER 17 - CHARACTER*(MXNAME) FILE 18 - CHARACTER*1 DUMMY 19 - INTEGER IFAIL,IFAIL1,NCFILE,NCMEMB,NWORD,I,J,K,IOS 20 - LOGICAL DSNCMP,EXIS 21 - EXTERNAL DSNCMP 22 - *** Identify the routine, if requested. 23 - IF(LIDENT)PRINT *,' /// ROUTINE CELGET ///' 24 - *** Initialise IFAIL on 1 (i.e. fail). 25 - IFAIL=1 26 - FILE=' ' 27 - MEMBER='*' 28 - NCFILE=8 29 - NCMEMB=1 30 - *** First decode the argument string, setting file name + member name. 31 - CALL INPNUM(NWORD) 32 - * If there's only one argument, it's the dataset name. 33 - IF(NWORD.GE.2)THEN 34 - CALL INPSTR(2,2,STRING,NCFILE) 35 - FILE=STRING 36 - ENDIF 37 - * If there's a second argument, it is the member name. 38 - IF(NWORD.GE.3)THEN 39 - CALL INPSTR(3,3,STRING,NCMEMB) 40 - MEMBER=STRING 41 - ENDIF 42 - * Check the various lengths. 43 - IF(NCFILE.GT.MXNAME)THEN 1 460 P=CELL D=CELGET 2 PAGE 584 44 - PRINT *,' !!!!!! CELGET WARNING : The file name is'// 45 - - ' truncated to MXNAME (=',MXNAME,') characters.' 46 - NCFILE=MIN(NCFILE,MXNAME) 47 - ENDIF 48 - IF(NCMEMB.GT.8)THEN 49 - PRINT *,' !!!!!! CELGET WARNING : The member name is'// 50 - - ' shortened to ',MEMBER,', first 8 characters.' 51 - NCMEMB=MIN(NCMEMB,8) 52 - ELSEIF(NCMEMB.LE.0)THEN 53 - PRINT *,' !!!!!! CELGET WARNING : The member'// 54 - - ' name has zero length, replaced by "*".' 55 - MEMBER='*' 56 - NCMEMB=1 57 - ENDIF 58 - * Reject the empty file name case. 59 - IF(FILE.EQ.' '.OR.NWORD.EQ.1)THEN 60 - PRINT *,' !!!!!! CELGET WARNING : GET must be at least'// 61 - - ' followed by a dataset name ; no data are read.' 62 - RETURN 63 - ENDIF 64 - * If there are even more args, warn because they are ignored. 65 - IF(NWORD.GT.3)PRINT *,' !!!!!! CELGET WARNING : GET takes'// 66 - - ' at most two arguments (dataset and member); rest ignored.' 67 - *** Open the dataset and inform DSNLOG. 68 - CALL DSNOPN(FILE(1:NCFILE),NCFILE,12,'READ-LIBRARY',IFAIL1) 69 - IF(IFAIL1.NE.0)THEN 70 - PRINT *,' !!!!!! CELGET WARNING : Opening ',FILE(1:NCFILE), 71 - - ' failed ; cell data are not read.' 72 - RETURN 73 - ENDIF 74 - CALL DSNLOG(FILE,'Cell data ','Sequential','Read only ') 75 - IF(LDEBUG)PRINT *,' ++++++ CELGET DEBUG : Dataset ', 76 - - FILE(1:NCFILE),' opened on unit 12 for seq read.' 77 - * Locate the pointer on the header of the requested member. 78 - CALL DSNLOC(MEMBER,NCMEMB,'CELL ',12,EXIS,'RESPECT') 79 - IF(.NOT.EXIS)THEN 80 - CALL DSNLOC(MEMBER,NCMEMB,'CELL ',12,EXIS,'IGNORE') 81 - IF(EXIS)THEN 82 - PRINT *,' ###### CELGET ERROR : Cell description ', 83 - - MEMBER(1:NCMEMB),' has been deleted from ', 84 - - FILE(1:NCFILE),'; not read.' 85 - ELSE 86 - PRINT *,' ###### CELGET ERROR : Cell description ', 87 - - MEMBER(1:NCMEMB),' not found on ',FILE(1:NCFILE) 88 - ENDIF 89 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 90 - RETURN 91 - ENDIF 92 - *** Check that the member is acceptable. 93 - READ(12,'(A80)',END=2000,IOSTAT=IOS,ERR=2010) STRING 94 - IF(LDEBUG)THEN 95 - PRINT *,' ++++++ CELGET DEBUG : Dataset header', 96 - - ' record follows:' 97 - PRINT *,STRING 98 - ENDIF 99 - * Print member information. 100 - WRITE(LUNOUT,'('' Member '',A8,'' was created on '',A8, 101 - - '' at '',A8/'' Remarks: '',A29)') 102 - - STRING(32:39),STRING(11:18),STRING(23:30),STRING(51:79) 103 - * Check the version. 104 - READ(12,'(A14)',END=2000,IOSTAT=IOS,ERR=2010) STRING 105 - IF(STRING(1:14).NE.' Version : 1')THEN 106 - PRINT *,' !!!!!! CELGET WARNING : This member can not'// 107 - - ' be read because of a change in format.' 108 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 109 - RETURN 110 - ENDIF 111 - *** Execute read operations if a valid name is available. 112 - READ(12,'(9X,A)',END=2000,IOSTAT=IOS,ERR=2010) CELLID 113 - READ(12,'(9X,I10,7X,A3,I2,8X,L1,7X,L1)', 114 - - END=2000,IOSTAT=IOS,ERR=2010) 115 - - NWIRE,TYPE,ICTYPE,POLAR,TUBE 116 - * Cell-data cannot be used if MXWIRE < NWIRE. 117 - IF(NWIRE.GT.MXWIRE)THEN 118 - PRINT *,' ###### CELGET ERROR : Program not suitably', 119 - - ' compiled to use member ',MEMBER(1:NCMEMB),' on ', 120 - - FILE(1:NCFILE),' ; increase MXWIRE to ',NWIRE 121 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 122 - RETURN 123 - ENDIF 124 - READ(12,'(7X,6E15.8,/,10X,2E15.8)',END=2000,IOSTAT=IOS,ERR=2010) 125 - - XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,VMIN,VMAX 126 - READ(12,'(A1)',END=2000,IOSTAT=IOS,ERR=2010) DUMMY 127 - DO 210 I=1,NWIRE 128 - READ(12,'(1X,A1,6E15.8/2X,5E15.8)',END=2000,IOSTAT=IOS,ERR=2010) 129 - - WIRTYP(I),X(I),Y(I),V(I),E(I),D(I),W(I),U(I),DENS(I), 130 - - B2SIN(I),WMAP(I) 131 - 210 CONTINUE 132 - READ(12,'(10X,3E15.8)',END=2000,IOSTAT=IOS,ERR=2010) 133 - - (DOWN(I),I=1,3) 134 - READ(12,'(8X,3E15.8,5X,E15.8)',END=2000,IOSTAT=IOS,ERR=2010) 135 - - CORVTA,CORVTB,CORVTC,V0 136 - READ(12,'(11X,2(L1,2E15.8,A1))',END=2000,IOSTAT=IOS,ERR=2010) 137 - - (YNPLAN(I),COPLAN(I),VTPLAN(I),PLATYP(I),I=1,2) 138 - READ(12,'(11X,2(L1,2E15.8,A1))',END=2000,IOSTAT=IOS,ERR=2010) 139 - - (YNPLAN(I),COPLAN(I),VTPLAN(I),PLATYP(I),I=3,4) 140 - READ(12,'(21X,2L1,2E15.8)',END=2000,IOSTAT=IOS,ERR=2010) 141 - - YNPLAX,YNPLAY,COPLAX,COPLAY 142 - READ(12,'(9X,5I10/9X,5I10)',END=2000,IOSTAT=IOS,ERR=2010) 143 - - (NPSTR1(I),NPSTR2(I),I=1,5) 144 - DO 240 I=1,5 145 - DO 250 J=1,NPSTR1(I) 146 - READ(12,'(1X,A1,1X,3E15.8)',END=2000,IOSTAT=IOS,ERR=2010) 147 - - PSLAB1(I,J),(PLSTR1(I,J,K),K=1,3) 148 - 250 CONTINUE 149 - DO 260 J=1,NPSTR2(I) 1 460 P=CELL D=CELGET 3 PAGE 585 150 - READ(12,'(1X,A1,1X,3E15.8)',END=2000,IOSTAT=IOS,ERR=2010) 151 - - PSLAB2(I,J),(PLSTR2(I,J,K),K=1,3) 152 - 260 CONTINUE 153 - 240 CONTINUE 154 - READ(12,'(15X,2(L1,E15.8))',END=2000,IOSTAT=IOS,ERR=2010) 155 - - PERX,SX,PERY,SY 156 - IF(TYPE(1:1).EQ.'C')READ(12,'(14X,5E15.8,I10)',END=2000, 157 - - IOSTAT=IOS,ERR=2010) ZMULT,P1,P2,C1,MODE 158 - IF(TYPE.EQ.'D3 '.OR.TYPE.EQ.'D4 ') 159 - - READ(12,'(13X,E15.8)',END=2000,IOSTAT=IOS,ERR=2010) KAPPA 160 - READ(12,'(17X,I3,5X,I3)',END=2000,IOSTAT=IOS,ERR=2010) 161 - - NXMATT,NYMATT 162 - IF(NXMATT.GT.MXMATT.OR.NYMATT.GT.MXMATT)THEN 163 - PRINT *,' ###### CELGET ERROR : Program not suitably', 164 - - ' compiled to use member ',MEMBER(1:NCMEMB),' on ', 165 - - FILE(1:NCFILE),' ; increase MXMATT to ', 166 - - MAX(NXMATT,NYMATT) 167 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 168 - RETURN 169 - ENDIF 170 - DO 220 I=1,NXMATT 171 - READ(12,'(1X,5E15.8)',END=2000,IOSTAT=IOS,ERR=2010) 172 - - (XMATT(I,J),J=1,5) 173 - 220 CONTINUE 174 - DO 230 I=1,NYMATT 175 - READ(12,'(1X,5E15.8)',END=2000,IOSTAT=IOS,ERR=2010) 176 - - (YMATT(I,J),J=1,5) 177 - 230 CONTINUE 178 - IF(TUBE)READ(12,'(7X,2E15.8,2I10,A1)',END=2000,IOSTAT=IOS, 179 - - ERR=2010) COTUBE,VTTUBE,NTUBE,MTUBE,PLATYP(5) 180 - READ(12,'(9X,2I10)',END=2000,IOSTAT=IOS,ERR=2010) 181 - - NSOLID,ICCURR 182 - IF(NSOLID.GT.0)READ(12,'(1X,3I10)',END=2000,IOSTAT=IOS,ERR=2010) 183 - - (ISTART(I),ISOLTP(I),ISOLMT(I),I=1,NSOLID) 184 - IF(ICCURR.GT.0)READ(12,'(1X,8E15.8)',END=2000,IOSTAT=IOS, 185 - - ERR=2010) (CBUF(I),I=1,ICCURR) 186 - * Close the file after the operation. 187 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 188 - IFAIL=0 189 - *** Register the amount of CPU time used for reading. 190 - CALL TIMLOG('Reading the cell data from a dataset: ') 191 - RETURN 192 - *** Handle the I/O error conditions. 193 - 2000 CONTINUE 194 - PRINT *,' ###### CELGET ERROR : EOF encountered while reading', 195 - - ' ',FILE(1:NCFILE),' from unit 12 ; no cell data read.' 196 - CALL INPIOS(IOS) 197 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 198 - RETURN 199 - 2010 CONTINUE 200 - PRINT *,' ###### CELGET ERROR : Error while reading', 201 - - ' ',FILE(1:NCFILE),' from unit 12 ; no cell data read.' 202 - CALL INPIOS(IOS) 203 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 204 - RETURN 205 - 2030 CONTINUE 206 - PRINT *,' ###### CELGET ERROR : Dataset ',FILE(1:NCFILE),' on', 207 - - ' unit 12 cannot be closed ; results not predictable.' 208 - CALL INPIOS(IOS) 209 - END 461 GARFIELD ================================================== P=CELL D=CELINP 1 ============================ 0 + +DECK,CELINP. 1 - SUBROUTINE CELINP(IGET,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * CELINP - Subroutine reading the cell data from the input file. It 4 - * fills the common block wire in part. 5 - * VARIABLES : DX : The x-increment in the present row. 6 - * DY : The y-increment in the present row. 7 - * DV : The voltage increment in the present row. 8 - * NX,NY : Number of x,y planes read so far. 9 - * IGET : 1 if data comes from dataset, 0 else. 10 - * (Last changed on 15/ 1/01.) 11 - *----------------------------------------------------------------------- 12 - implicit none 13.- +SEQ,DIMENSIONS. 14.- +SEQ,CELLDATA. 15.- +SEQ,PRINTPLOT. 16.- +SEQ,CONSTANTS. 17.- +SEQ,SOLIDS. 18 - CHARACTER*(MXINCH) STRING,FUNCT 19 - CHARACTER*10 VARLIS(MXVAR),USER 20 - CHARACTER DIR,PLATPR,STRTPR,WIRTPR 21 - REAL VAR(MXVAR),RES(8),DOWNXR,DOWNYR,DOWNZR,DNORM, 22 - - DR,SR,UR,VR,WR,XR,YR,VARVAL,EPSR,CMIN,CMAX,S,COOR,VOLT, 23 - - RADIUS,SMIN,SMAX,SAUX,GAP 24 - LOGICAL USE(MXVAR),CCART,CPOLAR,CTUBE,STDSTR,OK,DELETE 25 - INTEGER INPCMP,INPTYP,MODVAR(MXVAR),MODRES(8),NVAR,IENTRY,NRES, 26 - - IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5,IFAIL6,IFAIL7,IFAIL, 27 - - IFOUND,MODTMP,IVAR,IDTYPE, 28 - - INEXT,NR,NFUNCT,NTUBER,NX,NY,IGET,NWORD,I,J,NC 29 - EXTERNAL STDSTR,INPCMP,INPTYP 0 30-+ +SELF,IF=AST. 31 - EXTERNAL ASTCCH 0 32-+ +SELF. 33 - *** Preset error flag and indicator for file reading. 34 - IFAIL=0 35 - IGET=0 36 - *** Initial number of DEFINE variables. 37 - NVAR=0 38 - *** Initialise number of planes and coordinate system flags. 39 - NX=0 40 - NY=2 1 461 P=CELL D=CELINP 2 PAGE 586 41 - CCART=.FALSE. 42 - CPOLAR=.FALSE. 43 - CTUBE=.FALSE. 44 - * Initialise the solids. 45 - NSOLID=0 46 - ICCURR=0 47 - * Release the matrix, will be reallocated by SETUP. 48 - CALL BOOK('INQUIRE','MATRIX',USER,IFAIL1) 49 - IF(IFAIL1.NE.0)THEN 50 - PRINT *,' !!!!!! CELINP WARNING : Unable to obtain'// 51 - - ' capacitance allocation information ; wire and'// 52 - - ' plane based fields probably not possible.' 53 - ELSEIF(USER.EQ.'CELL')THEN 54 - CALL BOOK('RELEASE','MATRIX','CELL',IFAIL1) 55 - ELSEIF(USER.NE.' ')THEN 56 - CALL BOOK('RELEASE','MATRIX',USER,IFAIL1) 57 - PRINT *,' ------ CELINP MESSAGE : Capacitance matrix'// 58 - - ' was not released by ',USER,'; release forced.' 59 - ENDIF 60 - * Release CELL use of the field map. 61 - CALL BOOK('INQUIRE','MAP',USER,IFAIL1) 62 - IF(IFAIL1.NE.0)THEN 63 - PRINT *,' !!!!!! CELINP WARNING : Unable to obtain'// 64 - - ' field map allocation information ; field map'// 65 - - ' probably not useable.' 66 - ELSEIF(USER.EQ.'CELL')THEN 67 - CALL MAPINT 68 - CALL BOOK('RELEASE','MAP','CELL',IFAIL1) 69 - ELSEIF(USER.EQ.' ')THEN 70 - CALL MAPINT 71 - ELSE 72 - PRINT *,' !!!!!! CELINP WARNING : Field map is in use'// 73 - - ' by ',USER,'; field map probably not useable.' 74 - ENDIF 75 - *** Read a line from input. 76 - CALL INPPRM('Cell','NEW-PRINT') 77 - 10 CONTINUE 78 - CALL INPWRD(NWORD) 0 79-+ +SELF,IF=AST. 80 - *** Set up ASTCCH as the condition handler. 81 - CALL LIB$ESTABLISH(ASTCCH) 0 82-+ +SELF. 83 - *** Skip this line if there are no words. 84 - CALL INPSTR(1,MXWORD,STRING,NC) 85 - IF(NWORD.EQ.0)GOTO 10 86 - *** If an '&' is the first letter of the instr, it is the next section. 87 - IF(STRING(1:1).EQ.'&')THEN 88 - GOTO 50 89 - *** If CELL-ID is a keyword: store CELLID. 90 - ELSEIF(INPCMP(1,'C#ELL-#IDENTIFIER').NE.0)THEN 91 - IF(NWORD.EQ.1.AND.CELLID.EQ.' ')THEN 92 - WRITE(LUNOUT,'(2X/''No cell identification set at'', 93 - - '' the moment.''/)') 94 - ELSEIF(NWORD.EQ.1)THEN 95 - WRITE(LUNOUT,'(2X/''The current cell identification'', 96 - - '' is: '',A/)') CELLID 97 - ELSE 98 - CALL INPSTR(2,2,STRING,NC) 99 - IF(NC.GT.40)PRINT *,' !!!!!! CELINP WARNING : The'// 100 - - ' cell identifier is truncated to 40 characters.' 101 - CELLID=STRING(1:MIN(NC,80)) 102 - ENDIF 103 - *** Add a new variable to the list, if DEFINE is a keyword. 104 - ELSEIF(INPCMP(1,'DEF#INE').NE.0)THEN 105 - * Display all variables if no arguments have been provided. 106 - IF(NWORD.EQ.1)THEN 107 - IF(NVAR.EQ.0)THEN 108 - WRITE(LUNOUT,'(/, 109 - - '' No variables have been set sofar.''/)') 110 - ELSE 111 - WRITE(LUNOUT,'(/, 112 - - '' Variable name Value'')') 113 - DO 13 I=1,NVAR 114 - WRITE(LUNOUT,'(2X,A10,5X,F15.5)') VARLIS(I),VAR(I) 115 - 13 CONTINUE 116 - WRITE(LUNOUT,'('' '')') 117 - ENDIF 118 - * Display only the value of the variable, if value is omitted. 119 - ELSEIF(NWORD.EQ.2)THEN 120 - CALL INPSTR(2,2,STRING,NC) 121 - IF(NC.LT.1)THEN 122 - PRINT *,' !!!!!! CELINP WARNING : A variable'// 123 - - ' name must have at least some characters.' 124 - ELSE 125 - IFOUND=0 126 - DO 18 I=1,NVAR 127 - IF(VARLIS(I).EQ.STRING(1:NC))THEN 128 - IF(IFOUND.EQ.0)WRITE(LUNOUT,'(/, 129 - - '' Variable name Value'')') 130 - WRITE(LUNOUT,'(2X,A10,5X,F15.5)') 131 - - VARLIS(I),VAR(I) 132 - IFOUND=1 133 - ENDIF 134 - 18 CONTINUE 135 - IF(IFOUND.EQ.1)WRITE(LUNOUT,'('' '')') 136 - IF(IFOUND.EQ.0)PRINT *,' !!!!!! CELINP WARNING'// 137 - - ' : The variable '//STRING(1:NC)//' has not', 138 - - ' yet been defined.' 139 - ENDIF 140 - * Apparently a true define request, study it in detail. 141 - ELSEIF(NWORD.EQ.3)THEN 142 - CALL INPSTR(3,3,STRING,NC) 143 - CALL ALGPRE(STRING,NC,VARLIS,NVAR,NRES,USE,IENTRY, 144 - - IFAIL1) 1 461 P=CELL D=CELINP 3 PAGE 587 145 - CALL ALGEXE(IENTRY,VAR,MODVAR,NVAR, 146 - - RES,MODRES,1,IFAIL2) 147 - CALL ALGCLR(IENTRY) 148 - IF(IFAIL1+IFAIL2.NE.0)THEN 149 - PRINT *,' !!!!!! CELINP WARNING : Variable'// 150 - - ' is not stored (syntax errors).' 151 - GOTO 10 152 - ENDIF 153 - VARVAL=RES(1) 154 - MODTMP=MODRES(1) 155 - * Extract the name of the variable. 156 - CALL INPSTR(2,2,STRING,NC) 157 - IF(NC.GT.10)THEN 158 - PRINT *,' !!!!!! CELINP WARNING : '//STRING(1:NC) 159 - - //' is longer than 10 characters,' 160 - PRINT *,' shortened to '// 161 - - STRING(1:10)//'.' 162 - ENDIF 163 - * Check that the name is legal. 164 - IFAIL1=0 165 - DO 15 I=1,NC 166 - IF(INDEX('+-*/&|<=#>^ ,.:;([{)]}''"`', 167 - - STRING(I:I)).NE.0)THEN 168 - PRINT *,' !!!!!! CELINP WARNING : '//STRING(1:NC) 169 - - //' contains illegal characters; not stored.' 170 - GOTO 10 171 - ENDIF 172 - 15 CONTINUE 173 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',STRING(1:1)) 174 - - .EQ.0)THEN 175 - PRINT *,' !!!!!! CELINP WARNING : The first'// 176 - - ' character of '//STRING(1:NC)//' is not'// 177 - - ' alphabetic; variable not stored.' 178 - GOTO 10 179 - ENDIF 180 - * Make sure it is not the reserved loop variable I. 181 - IF(STRING(1:NC).EQ.'I'.AND.NC.EQ.1)THEN 182 - PRINT *,' !!!!!! CELINP WARNING : I is reserved'// 183 - - ' as the ROW loop variable; not added.' 184 - GOTO 10 185 - ENDIF 186 - * See whether it duplicates an older variable, 187 - IVAR=NVAR+1 188 - DO 16 I=1,NVAR 189 - IF(STRING(1:10).EQ.VARLIS(I))IVAR=I 190 - 16 CONTINUE 191 - * check that there is still room for new variables, 192 - IF(IVAR+1.GE.MXVAR)THEN 193 - PRINT *,' !!!!!! CELINP WARNING : No room for'// 194 - - ' new variables ; increase MXVAR.' 195 - GOTO 10 196 - ENDIF 197 - * and store it along with its value. 198 - IF(IVAR.EQ.NVAR+1)THEN 199 - NVAR=NVAR+1 200 - VARLIS(NVAR)=STRING(1:10) 201 - ELSE 202 - IF(LDEBUG)PRINT *,' !!!!!! CELINP WARNING : '// 203 - - ' variable '//STRING(1:NC)//' is redefined.' 204 - IF(LDEBUG)PRINT *,' '// 205 - - ' old value=',VAR(IVAR),' new value=',VARVAL 206 - ENDIF 207 - VAR(IVAR)=VARVAL 208 - MODVAR(IVAR)=MODTMP 209 - * Incorrect number of arguments. 210 - ELSE 211 - PRINT *,' !!!!!! CELINP WARNING : DEFINE needs 2'// 212 - - ' arguments ; instruction is ignored.' 213 - ENDIF 214 - *** Dielectrica. 215 - ELSEIF(INPCMP(1,'DIEL#ECTRICUM').NE.0)THEN 216 - PRINT *,' !!!!!! CELINP WARNING : Instruction not released.' 217 - * Initial values. 218 - EPSR=-1.0 219 - CMIN=0.0 220 - CMAX=0.0 221 - DIR=' ' 222 - IDTYPE=2 223 - IFAIL1=1 224 - IFAIL2=1 225 - IFAIL3=1 226 - * Loop over the input string. 227 - INEXT=2 228 - DO 19 I=2,NWORD 229 - IF(I.LT.INEXT)GOTO 19 230 - * The extent and direction of the dielectricum. 231 - IF(INPCMP(I,'X-#RANGE')+INPCMP(I,'Y-#RANGE').NE.0)THEN 232 - IF(I+2.GT.NWORD)THEN 233 - CALL INPMSG(I,'RANGE needs two values. ') 234 - ELSEIF((INPTYP(I+1).LE.0.AND. 235 - - INPCMP(I+1,'-INF#INITY')+ 236 - - INPCMP(I+1,'+INF#INITY')+ 237 - - INPCMP(I+1,'INF#INITY').EQ.0).OR. 238 - - (INPTYP(I+2).LE.0.AND. 239 - - INPCMP(I+2,'-INF#INITY')+ 240 - - INPCMP(I+2,'+INF#INITY')+ 241 - - INPCMP(I+2,'INF#INITY').EQ.0))THEN 242 - CALL INPMSG(I,'Invalid range specification. ') 243 - INEXT=I+3 244 - ELSEIF(INPCMP(I+1,'INF#INITY')+ 245 - - INPCMP(I+1,'+INF#INITY').NE.0)THEN 246 - CALL INPMSG(I+1,'Should be -INF or a number. ') 247 - INEXT=I+3 248 - ELSEIF(INPCMP(I+2,'-INF#INITY').NE.0)THEN 249 - CALL INPMSG(I+2,'Should be +INF or a number. ') 250 - INEXT=I+3 1 461 P=CELL D=CELINP 4 PAGE 588 251 - ELSEIF(INPCMP(I+1,'-INF#INITY').NE.0.AND. 252 - - INPCMP(I+2,'INF#INITY')+ 253 - - INPCMP(I+2,'+INF#INITY').NE.0)THEN 254 - CALL INPMSG(I,'Full coverage is not allowed. ') 255 - INEXT=I+3 256 - ELSE 257 - IF(INPCMP(I+1,'-INF#INITY').NE.0)THEN 258 - IFAIL1=0 259 - CALL INPCHK(I+2,2,IFAIL2) 260 - IF(IFAIL2.EQ.0)CALL INPRDR(I+2,CMAX,0.0) 261 - IDTYPE=-1 262 - ELSEIF(INPCMP(I+2,'INF#INITY')+ 263 - - INPCMP(I+2,'+INF#INITY').NE.0)THEN 264 - CALL INPCHK(I+1,2,IFAIL1) 265 - IF(IFAIL1.EQ.0)CALL INPRDR(I+1,CMIN,0.0) 266 - IFAIL2=0 267 - IDTYPE=+1 268 - ELSE 269 - CALL INPCHK(I+1,2,IFAIL1) 270 - IF(IFAIL1.EQ.0)CALL INPRDR(I+1,CMIN,0.0) 271 - CALL INPCHK(I+2,2,IFAIL2) 272 - IF(IFAIL2.EQ.0)CALL INPRDR(I+2,CMAX,0.0) 273 - IDTYPE=0 274 - ENDIF 275 - IF(IDTYPE.EQ.0.AND.CMIN.EQ.CMAX)THEN 276 - CALL INPMSG(I+1, 277 - - 'Zero range not permitted. ') 278 - CALL INPMSG(I+2, 279 - - 'See the preceding message. ') 280 - ENDIF 281 - IF(INPCMP(I,'X-#RANGE').NE.0)THEN 282 - DIR='X' 283 - ELSEIF(INPCMP(I,'Y-#RANGE').NE.0)THEN 284 - DIR='Y' 285 - ENDIF 286 - INEXT=I+3 287 - ENDIF 288 - * The dielectric constant. 289 - ELSEIF(INPCMP(I,'EPS#ILON').NE.0)THEN 290 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN 291 - CALL INPMSG(I,'Epsilon must be specified. ') 292 - ELSE 293 - CALL INPCHK(I+1,2,IFAIL3) 294 - CALL INPRDR(I+1,EPSR,-1.0) 295 - INEXT=I+2 296 - IF(EPSR.LE.0.0)CALL INPMSG(I, 297 - - 'Epsilon must be positive. ') 298 - ENDIF 299 - * Anything else: not valid. 300 - ELSE 301 - CALL INPMSG(I,'Unrecognised keyword. ') 302 - ENDIF 303 - 19 CONTINUE 304 - CALL INPERR 305 - * Store the dielectricum. 306 - IF(DIR.EQ.' '.OR.IDTYPE.EQ.2.OR.(IDTYPE.EQ.0.AND. 307 - - CMIN.EQ.CMAX).OR.EPSR.LE.0.0.OR. 308 - - IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0)THEN 309 - PRINT *,' !!!!!! CELINP WARNING : The DIELECTRICUM'// 310 - - ' statement is either invalid or incomplete:' 311 - PRINT *,' It is skipped,'// 312 - - ' check the documentation for proper syntax.' 313 - ELSEIF((NXMATT.GE.MXMATT.AND.DIR.EQ.'X').OR. 314 - - (NYMATT.GE.MXMATT.AND.DIR.EQ.'Y'))THEN 315 - PRINT *,' !!!!!! CELINP WARNING : No room to store'// 316 - - ' further dielectrica ; increase MXMATT.' 317 - ELSEIF(DIR.EQ.'X')THEN 318 - NXMATT=NXMATT+1 319 - IF(IDTYPE.EQ.+1)THEN 320 - XMATT(NXMATT,1)=CMIN 321 - XMATT(NXMATT,2)=0.0 322 - XMATT(NXMATT,3)=0 323 - XMATT(NXMATT,4)=1 324 - ELSEIF(IDTYPE.EQ.0)THEN 325 - XMATT(NXMATT,1)=MIN(CMIN,CMAX) 326 - XMATT(NXMATT,2)=MAX(CMIN,CMAX) 327 - XMATT(NXMATT,3)=0 328 - XMATT(NXMATT,4)=0 329 - ELSEIF(IDTYPE.EQ.-1)THEN 330 - XMATT(NXMATT,1)=0.0 331 - XMATT(NXMATT,2)=CMAX 332 - XMATT(NXMATT,3)=1 333 - XMATT(NXMATT,4)=0 334 - ENDIF 335 - XMATT(NXMATT,5)=EPSR 336 - ELSEIF(DIR.EQ.'Y')THEN 337 - NYMATT=NYMATT+1 338 - IF(IDTYPE.EQ.+1)THEN 339 - YMATT(NYMATT,1)=CMIN 340 - YMATT(NYMATT,2)=0.0 341 - YMATT(NYMATT,3)=0 342 - YMATT(NYMATT,4)=1 343 - ELSEIF(IDTYPE.EQ.0)THEN 344 - YMATT(NYMATT,1)=MIN(CMIN,CMAX) 345 - YMATT(NYMATT,2)=MAX(CMIN,CMAX) 346 - YMATT(NYMATT,3)=0 347 - YMATT(NYMATT,4)=0 348 - ELSEIF(IDTYPE.EQ.-1)THEN 349 - YMATT(NYMATT,1)=0.0 350 - YMATT(NYMATT,2)=CMAX 351 - YMATT(NYMATT,3)=1 352 - YMATT(NYMATT,4)=0 353 - ENDIF 354 - YMATT(NYMATT,5)=EPSR 355 - ENDIF 356 - *** Read a field map. 1 461 P=CELL D=CELINP 5 PAGE 589 357 - ELSEIF(INPCMP(1,'FIELD-MAP')+ 358 - - INPCMP(1,'READ-FIELD-MAP').NE.0)THEN 359 - * Obtain the field map for main-field use. 360 - CALL BOOK('INQUIRE','MAP',USER,IFAIL1) 361 - IF(NWORD.EQ.1)THEN 362 - IFAIL1=0 363 - ELSEIF(USER.EQ.'OPTIMISE')THEN 364 - PRINT *,' ------ CELINP MESSAGE : Deleting the'// 365 - - ' background field map to make space for the'// 366 - - ' main field map.' 367 - CALL MAPINT 368 - CALL BOOK('RELEASE','MAP','OPTIMISE',IFAIL2) 369 - IF(LBGFMP)THEN 370 - PRINT *,' ------ CELINP MESSAGE : Background'// 371 - - ' field deleted because of dependence on'// 372 - - ' the field map.' 373 - IF(IENBGF.NE.0)CALL ALGCLR(IENBGF) 374 - IENBGF=0 375 - ENDIF 376 - CALL BOOK('BOOK','MAP','CELL',IFAIL3) 377 - IF(IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN 378 - IFAIL1=0 379 - ELSE 380 - PRINT *,' !!!!!! CELINP WARNING : Change of'// 381 - - ' field map allocation failed; field'// 382 - - ' map not useable.' 383 - IFAIL1=1 384 - ENDIF 385 - ELSEIF(USER.EQ.' ')THEN 386 - CALL BOOK('BOOK','MAP','CELL',IFAIL1) 387 - ELSE 388 - IFAIL1=0 389 - ENDIF 390 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! CELINP WARNING : Unable'// 391 - - ' to obtain control of the field map for use as'// 392 - - ' main field.' 393 - * Read the field map. 394 - IF(IFAIL1.EQ.0)THEN 395 - IF(INPCMP(1,'FIELD-MAP').NE.0)THEN 396 - CALL MAPREA(IFAIL1) 397 - ELSE 398 - CALL MAPFMF(IFAIL1) 399 - ENDIF 400 - ENDIF 401 - * Check the error flag from map reading. 402 - IF(IFAIL1.EQ.0.AND.NWORD.GT.1)THEN 403 - IF(CPOLAR)THEN 404 - PRINT *,' !!!!!! CELINP WARNING : Description'// 405 - - ' started in polar coordinates; field'// 406 - - ' map ignored.' 407 - GOTO 10 408 - ENDIF 409 - IF(.NOT.CTUBE)CCART=.TRUE. 410 - IF(NWIRE.NE.0)PRINT *,' ------ CELINP MESSAGE :'// 411 - - ' Deleted the wires when reading field map.' 412 - IF(NX.NE.0.OR.NY.NE.2)PRINT *,' ------ CELINP'// 413 - - ' MESSAGE : Deleted the planes when reading'// 414 - - ' the field map.' 415 - IF(NXMATT.NE.0.OR.NYMATT.NE.0) 416 - - PRINT *,' ------ CELINP MESSAGE : Deleted'// 417 - - ' the dielectrics when reading the field map.' 418 - NWIRE=0 419 - NX=0 420 - NY=2 421 - YNPLAN(1)=.FALSE. 422 - YNPLAN(2)=.FALSE. 423 - YNPLAN(3)=.FALSE. 424 - YNPLAN(4)=.FALSE. 425 - NXMATT=0 426 - NYMATT=0 427 - ELSEIF(NWORD.GT.1)THEN 428 - PRINT *,' !!!!!! CELINP WARNING : Reading a field'// 429 - - ' map failed.' 430 - ENDIF 431 - *** Write the field map in binary format. 432 - ELSEIF(INPCMP(1,'SAVE-F#IELD-#MAP').NE.0)THEN 433 - CALL MAPFMS 434 - *** Read the cell from dataset, if GET is a keyword 435 - ELSEIF(INPCMP(1,'G#ET').NE.0)THEN 436 - CALL CELGET(IFAIL) 437 - IF(IFAIL.NE.0)THEN 438 - PRINT *,' !!!!!! CELINP WARNING : New cell data must'// 439 - - ' be entered.' 440 - IGET=0 441 - NX=0 442 - NY=2 443 - CCART=.FALSE. 444 - CPOLAR=.FALSE. 445 - CTUBE=.FALSE. 446 - CALL CELINT 447 - NSOLID=0 448 - ICCURR=0 449 - CALL MAPINT 450 - IFAIL=0 451 - ELSE 452 - IGET=1 453 - IF(POLAR)THEN 454 - CPOLAR=.TRUE. 455 - CCART=.FALSE. 456 - CTUBE=.FALSE. 457 - ELSEIF(TUBE)THEN 458 - CPOLAR=.FALSE. 459 - CCART=.FALSE. 460 - CTUBE=.TRUE. 461 - ELSE 462 - CPOLAR=.FALSE. 1 461 P=CELL D=CELINP 6 PAGE 590 463 - CCART=.TRUE. 464 - CTUBE=.FALSE. 465 - ENDIF 466 - ENDIF 467 - *** Gravity orientation. 468 - ELSEIF(INPCMP(1,'GRAV#ITY').NE.0)THEN 469 - IF(NWORD.EQ.1)THEN 470 - WRITE(LUNOUT,'('' Gravity works along the axis ('', 471 - - F6.3,'','',F6.3,'','',F6.3,'') [g].'')') 472 - - (DOWN(I),I=1,3) 473 - ELSEIF(NWORD.NE.4)THEN 474 - PRINT *,' !!!!!! CELINP WARNING : The GRAVITY'// 475 - - ' command takes 3 arguments; ignored.' 476 - ELSE 477 - CALL INPCHK(2,2,IFAIL1) 478 - CALL INPCHK(3,2,IFAIL2) 479 - CALL INPCHK(4,2,IFAIL3) 480 - CALL INPRDR(2,DOWNXR,DOWN(1)) 481 - CALL INPRDR(3,DOWNYR,DOWN(2)) 482 - CALL INPRDR(4,DOWNZR,DOWN(3)) 483 - DNORM=SQRT(DOWNXR**2+DOWNYR**2+DOWNZR**2) 484 - IF(DNORM.GT.0)THEN 485 - DOWN(1)=DOWNXR/DNORM 486 - DOWN(2)=DOWNYR/DNORM 487 - DOWN(3)=DOWNZR/DNORM 488 - ELSE 489 - PRINT *,' !!!!!! CELINP WARNING : The gravity'// 490 - - ' vector has 0 norm ; ignored.' 491 - ENDIF 492 - ENDIF 493 - *** If OPTION is a keyword, find out what the options are, 494 - ELSEIF(INPCMP(1,'OPT#IONS').NE.0)THEN 495 - IF(NWORD.EQ.1)WRITE(LUNOUT,'(/ 496 - - '' LOCAL OPTIONS CURRENTLY IN EFFECT:''// 497 - - '' Plotting the layout of the cell (LAYOUT): '', 498 - - L1/ 499 - - '' Printing a cell summary table (CELL-PRINT): '', 500 - - L1/ 501 - - '' Plot wires by markers (WIRE-MARKERS): '', 502 - - L1/ 503 - - '' Layout plotted isometrically (ISOMETRIC): '', 504 - - L1/ 505 - - '' Check charge calculation (CHARGE-CHECK): '', 506 - - L1)') LCELPL,LCELPR,LWRMRK,LISOCL,LCHGCH 507 - DO 11 I=2,NWORD 508 - * check the plotting-of-layout option, 509 - IF(INPCMP(I,'NOLAY#OUT').NE.0)THEN 510 - LCELPL=.FALSE. 511 - ELSEIF(INPCMP(I,'LAY#OUT').NE.0)THEN 512 - LCELPL=.TRUE. 513 - * check the printing-of-layout option, 514 - ELSEIF(INPCMP(I,'NOC#ELL-PR#INT').NE.0)THEN 515 - LCELPR=.FALSE. 516 - ELSEIF(INPCMP(I,'C#ELL-PR#INT').NE.0)THEN 517 - LCELPR=.TRUE. 518 - * check the wire markers option, 519 - ELSEIF(INPCMP(I,'NOW#IRE-M#ARKERS').NE.0)THEN 520 - LWRMRK=.FALSE. 521 - ELSEIF(INPCMP(I,'W#IRE-M#ARKERS').NE.0)THEN 522 - LWRMRK=.TRUE. 523 - * check the isometric option, 524 - ELSEIF(INPCMP(I,'NOTISO#METRIC').NE.0)THEN 525 - LISOCL=.FALSE. 526 - ELSEIF(INPCMP(I,'ISO#METRIC').NE.0)THEN 527 - LISOCL=.TRUE. 528 - * check charge calculation. 529 - ELSEIF(INPCMP(I,'NOCH#ARGE-#CHECK').NE.0)THEN 530 - LCHGCH=.FALSE. 531 - ELSEIF(INPCMP(I,'CH#ARGE-#CHECK').NE.0)THEN 532 - LCHGCH=.TRUE. 533 - * option not known. 534 - ELSE 535 - CALL INPMSG(I,'The option is not known. ') 536 - ENDIF 537 - 11 CONTINUE 538 - CALL INPERR 539 - *** If PERIOD is a keyword: 540 - ELSEIF(INPCMP(1,'PER#IODICITY').NE.0)THEN 541 - * check the syntax, 542 - IF(NWORD.NE.3)THEN 543 - PRINT *,' !!!!!! CELINP WARNING : PERIOD requires'// 544 - - ' 2 arguments (direction and length) ; ignored.' 545 - GOTO 10 546 - ENDIF 547 - * Try to read the periodicity. 548 - CALL INPCHK(3,2,IFAIL1) 549 - CALL INPRDR(3,S,-1.0) 550 - * Check that the periodicity direction makes sense. 551 - IF(INPCMP(2,'X')+INPCMP(2,'Y')+INPCMP(2,'PHI').EQ.0) 552 - - CALL INPMSG(2,'Should be either X, Y or PHI. ') 553 - IF(S.LE.0.0)CALL INPMSG(3,'Periods should be > than 0. ') 554 - * Dump error messages. 555 - CALL INPERR 556 - * No further processing in case of invalid periodicities. 557 - IF((INPCMP(2,'X')+INPCMP(2,'Y')+ 558 - - INPCMP(2,'PHI').EQ.0).OR.IFAIL1.NE.0.OR.S.LE.0.0)THEN 559 - PRINT *,' !!!!!! CELINP WARNING : PERIOD statement'// 560 - - ' ignored because of syntax or argument errors.' 561 - * Make sure no mixed coordinates are used. 562 - ELSEIF((INPCMP(2,'X')+INPCMP(2,'Y').NE.0.AND. 563 - - (CTUBE.OR.CPOLAR)).OR. 564 - - (INPCMP(2,'PHI')+INPCMP(2,'R').NE.0.AND.CCART))THEN 565 - PRINT *,' !!!!!! CELINP WARNING : Use of mixed'// 566 - - ' coordinates not permitted ; PERIOD is ignored.' 567 - * Assign the periodicity to SX or to SY. 568 - ELSE 1 461 P=CELL D=CELINP 7 PAGE 591 569 - * If it is a x or a r periodicity: 570 - IF(INPCMP(2,'X')+INPCMP(2,'R').NE.0)THEN 571 - IF(PERX)PRINT *,' !!!!!! CELINP WARNING :'// 572 - - ' previous x period (',SX,') replaced.' 573 - PERX=.TRUE. 574 - IF(INPCMP(2,'X').NE.0)THEN 575 - SX=S 576 - CCART=.TRUE. 577 - ELSE 578 - SX=LOG(S) 579 - IF(.NOT.(CTUBE.OR.CPOLAR))CPOLAR=.TRUE. 580 - ENDIF 581 - * if it is a y or a phi periodicity: 582 - ELSE 583 - IF(INPCMP(2,'PHI').NE.0.AND. 584 - - ABS(360.0-S*ANINT(360.0/S)).GT.1.0E-4)THEN 585 - PRINT *,' !!!!!! CELINP WARNING : Phi'// 586 - - ' periods must divide 360 ; ignored.' 587 - ELSE 588 - IF(PERY.AND.CCART)PRINT *,' !!!!!! CELINP'// 589 - - ' WARNING : The previous y period (', 590 - - SY,') is replaced.' 591 - IF(PERY.AND.CPOLAR)PRINT *,' !!!!!! CELINP'// 592 - - ' WARNING : The previous phi period (', 593 - - SY*180.0/PI,') is replaced.' 594 - PERY=.TRUE. 595 - IF(INPCMP(2,'Y').NE.0)THEN 596 - SY=S 597 - CCART=.TRUE. 598 - ELSE 599 - SY=PI*S/180.0 600 - MTUBE=NINT(360.0/S) 601 - IF(.NOT.(CTUBE.OR.CPOLAR))CPOLAR=.TRUE. 602 - ENDIF 603 - ENDIF 604 - ENDIF 605 - * reset the get condition. 606 - IGET=0 607 - ENDIF 608 - *** Define a plane if PLANE is a keyword. 609 - ELSEIF(INPCMP(1,'PL#ANE').NE.0)THEN 610 - ** Ensure that planes are not entered in a tube geometry. 611 - IF(CTUBE)THEN 612 - PRINT *,' !!!!!! CELINP WARNING : Planes can not'// 613 - - ' be used with a TUBE; plane ignored.' 614 - OK=.FALSE. 615 - GOTO 10 616 - ENDIF 617 - ** Determine the direction of the plane. 618 - DIR=' ' 619 - INEXT=2 620 - DO 100 I=2,NWORD 621 - IF(I.LT.INEXT)GOTO 100 622 - IF(INPCMP(I,'X')+INPCMP(I,'R').NE.0)THEN 623 - IF(INPCMP(I,'X').NE.0)DIR='X' 624 - IF(INPCMP(I,'R').NE.0)DIR='R' 625 - INEXT=I+2 626 - ELSEIF(INPCMP(I,'Y')+INPCMP(I,'PHI').NE.0)THEN 627 - IF(INPCMP(I,'Y').NE.0)DIR='Y' 628 - IF(INPCMP(I,'PHI').NE.0)DIR='P' 629 - INEXT=I+2 630 - ELSEIF(INPCMP(I,'V#OLTAGE')+INPCMP(I,'LAB#EL')+ 631 - - INPCMP(I,'GAP').NE.0)THEN 632 - INEXT=I+2 633 - ELSEIF(INPCMP(I,'X-STRIP')+INPCMP(I,'Y-STRIP')+ 634 - - INPCMP(I,'R-STRIP')+INPCMP(I,'PHI-STRIP')+ 635 - - INPCMP(I,'Z-STRIP').NE.0)THEN 636 - INEXT=I+3 637 - ENDIF 638 - 100 CONTINUE 639 - ** Make sure a direction is indicated. 640 - IF(DIR.EQ.' ')THEN 641 - PRINT *,' !!!!!! CELINP WARNING : Direction of the'// 642 - - ' plane not indicated; plane ignored.' 643 - OK=.FALSE. 644 - GOTO 10 645 - * Make sure we can store this plane. 646 - ELSEIF((DIR.EQ.'X'.OR.DIR.EQ.'R').AND.NX.GE.2)THEN 647 - PRINT *,' !!!!!! CELINP WARNING : At most 2 planes'// 648 - - ' at constant x or r permitted; plane ignored.' 649 - OK=.FALSE. 650 - GOTO 10 651 - ELSEIF((DIR.EQ.'Y'.OR.DIR.EQ.'P').AND.NY.GE.4)THEN 652 - PRINT *,' !!!!!! CELINP WARNING : At most 2 planes'// 653 - - ' at constant y or phi permitted; plane ignored.' 654 - OK=.FALSE. 655 - GOTO 10 656 - * Make sure no mixed coordinates are used. 657 - ELSEIF(((DIR.EQ.'X'.OR.DIR.EQ.'Y').AND.CPOLAR).OR. 658 - - ((DIR.EQ.'R'.OR.DIR.EQ.'P').AND.CCART))THEN 659 - PRINT *,' !!!!!! CELINP WARNING : Use of mixed'// 660 - - ' coordinates not permitted ; plane ignored.' 661 - OK=.FALSE. 662 - GOTO 10 663 - ENDIF 664 - ** We now start modifying the cell. 665 - IGET=0 666 - ** Maintain a flag to be able to delete faulty planes. 667 - DELETE=.FALSE. 668 - * Set coordinate system flags. 669 - IF(DIR.EQ.'X'.OR.DIR.EQ.'R')THEN 670 - NX=NX+1 671 - YNPLAN(NX)=.TRUE. 672 - NPSTR1(NX)=0 673 - NPSTR2(NX)=0 674 - ELSEIF(DIR.EQ.'Y'.OR.DIR.EQ.'P')THEN 1 461 P=CELL D=CELINP 8 PAGE 592 675 - NY=NY+1 676 - YNPLAN(NY)=.TRUE. 677 - NPSTR1(NY)=0 678 - NPSTR2(NY)=0 679 - ENDIF 680 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ CELINP DEBUG :'', 681 - - '' Plane direction: '',A,'' NX, NY='',2I2)') DIR, 682 - - NX,NY 683 - ** Read command in detail. 684 - INEXT=2 685 - PLATPR='?' 686 - COOR=0.0 687 - VOLT=0.0 688 - DO 110 I=2,NWORD 689 - IF(I.LT.INEXT)GOTO 110 690 - ** Plane at constant x or constant r, accept at most 2 planes. 691 - IF(INPCMP(I,'X')+INPCMP(I,'R').NE.0)THEN 692 - * Read coordinate. 693 - CALL INPCHK(I+1,2,IFAIL1) 694 - CALL INPRDR(I+1,COOR,0.0) 695 - * Reject syntax errors. 696 - IF(IFAIL1.NE.0)THEN 697 - DELETE=.TRUE. 698 - OK=.FALSE. 699 - * Make sure a radial plane has r>0. 700 - ELSEIF(COOR.LE.0.AND.DIR.EQ.'R')THEN 701 - PRINT *,' !!!!!! CELINP WARNING : The radius of'// 702 - - ' constant r planes must be larger than'// 703 - - ' zero; plane ignored.' 704 - DELETE=.TRUE. 705 - OK=.FALSE. 706 - ENDIF 707 - * Next word. 708 - INEXT=I+2 709 - ** Plane at constant y or constant phi, accept at most 2 planes. 710 - ELSEIF(INPCMP(I,'Y')+INPCMP(I,'PHI').NE.0)THEN 711 - * Read coordinate. 712 - CALL INPCHK(I+1,2,IFAIL1) 713 - CALL INPRDR(I+1,COOR,0.0) 714 - * Reject syntax errors. 715 - IF(IFAIL1.NE.0)THEN 716 - OK=.FALSE. 717 - DELETE=.TRUE. 718 - ENDIF 719 - * Next word. 720 - INEXT=I+2 721 - ** Voltage definition, 722 - ELSEIF(INPCMP(I,'V#OLTAGE').NE.0)THEN 723 - * Read voltage. 724 - CALL INPCHK(I+1,2,IFAIL2) 725 - CALL INPRDR(I+1,VOLT,0.0) 726 - * Reject syntax errors. 727 - IF(IFAIL2.NE.0)THEN 728 - OK=.FALSE. 729 - DELETE=.TRUE. 730 - ENDIF 731 - * Next word. 732 - INEXT=I+2 733 - ** Global plane label. 734 - ELSEIF(INPCMP(I,'LAB#EL').NE.0)THEN 735 - * Read label. 736 - CALL INPSTR(I+1,I+1,STRING,NC) 737 - PLATPR=STRING(1:1) 738 - * Reject syntax errors. 739 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',PLATPR).EQ. 740 - - 0)THEN 741 - CALL INPMSG(I+1,'The label must be a letter.') 742 - OK=.FALSE. 743 - DELETE=.TRUE. 744 - ENDIF 745 - * Next word. 746 - INEXT=I+2 747 - ** Strips. 748 - ELSEIF(INPCMP(I,'X-STRIP')+INPCMP(I,'Y-STRIP')+ 749 - - INPCMP(I,'R-STRIP')+INPCMP(I,'PHI-STRIP')+ 750 - - INPCMP(I,'Z-STRIP').NE.0)THEN 751 - * Ensure there is no coordinate system conflict. 752 - IF((INPCMP(I,'X-STRIP')+INPCMP(I,'Y-STRIP').NE.0.AND. 753 - - (DIR.EQ.'R'.OR.DIR.EQ.'P')).OR. 754 - - (INPCMP(I,'R-STRIP')+ 755 - - INPCMP(I,'PHI-STRIP').NE.0.AND. 756 - - (DIR.EQ.'X'.OR.DIR.EQ.'Y')))THEN 757 - PRINT *,' !!!!!! CELINP WARNING : Use of mixed'// 758 - - ' coordinates not permitted ; strip ignored.' 759 - OK=.FALSE. 760 - DELETE=.TRUE. 761 - ENDIF 762 - * Initial values. 763 - SMIN=0.0 764 - SMAX=0.0 765 - GAP=-1.0 766 - STRTPR='?' 767 - * Read range. 768 - CALL INPCHK(I+1,2,IFAIL1) 769 - CALL INPRDR(I+1,SMIN,0.0) 770 - CALL INPCHK(I+2,2,IFAIL2) 771 - CALL INPRDR(I+2,SMAX,0.0) 772 - * Coordinate transformations for polar coordinates. 773 - IF(INPCMP(I,'PHI-STRIP').NE.0)THEN 774 - SMIN=PI*SMIN/180 775 - SMAX=PI*SMAX/180 776 - SMIN=MOD(SMIN,2*PI) 777 - IF(SMIN.GT.PI)SMIN=SMIN-2*PI 778 - IF(SMIN.LT.-PI)SMIN=SMIN+2*PI 779 - SMAX=MOD(SMAX,2*PI) 780 - IF(SMAX.GT.PI)SMAX=SMAX-2*PI 1 461 P=CELL D=CELINP 9 PAGE 593 781 - IF(SMAX.LT.-PI)SMAX=SMAX+2*PI 782 - ELSEIF(INPCMP(I,'R-STRIP').NE.0)THEN 783 - IF(SMIN.LE.0.OR.SMAX.LE.0)THEN 784 - CALL INPMSG(I+1,'Strip must be in r > 0.') 785 - CALL INPMSG(I+2,'Strip must be in r > 0.') 786 - OK=.FALSE. 787 - DELETE=.TRUE. 788 - SMIN=1 789 - SMAX=2 790 - ELSE 791 - SMIN=LOG(SMIN) 792 - SMAX=LOG(SMAX) 793 - ENDIF 794 - ENDIF 795 - * Order the coordinates if required. 796 - IF(ABS(SMIN-SMAX).LT.1E-4)THEN 797 - CALL INPMSG(I+1,'Zero range not permitted.') 798 - CALL INPMSG(I+2,'Zero range not permitted.') 799 - OK=.FALSE. 800 - DELETE=.TRUE. 801 - SMIN=1 802 - SMAX=1 803 - ELSEIF(SMIN.GT.SMAX)THEN 804 - SAUX=SMIN 805 - SMIN=SMAX 806 - SMAX=SAUX 807 - ENDIF 808 - * Make sure strips and plane are perpendicular. 809 - IF((DIR.EQ.'X'.AND.INPCMP(I,'X-STRIP').NE.0).OR. 810 - - (DIR.EQ.'R'.AND.INPCMP(I,'R-STRIP').NE.0).OR. 811 - - (DIR.EQ.'Y'.AND.INPCMP(I,'Y-STRIP').NE.0).OR. 812 - - (DIR.EQ.'P'.AND.INPCMP(I,'PHI-STRIP').NE.0))THEN 813 - CALL INPMSG(I,'Same direction strip and plane') 814 - OK=.FALSE. 815 - DELETE=.TRUE. 816 - * Reject syntax errors. 817 - ELSEIF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN 818 - OK=.FALSE. 819 - DELETE=.TRUE. 820 - ENDIF 821 - * Next word. 822 - INEXT=I+3 823 - ** Search for optional arguments, first initialise them. 824 - DO 120 J=I+3,NWORD 825 - IF(J.LT.INEXT)GOTO 120 826 - * Gap width. 827 - IF(INPCMP(J,'GAP').NE.0)THEN 828 - CALL INPCHK(J+1,2,IFAIL2) 829 - CALL INPRDR(J+1,GAP,0.0) 830 - IF(IFAIL2.NE.0)THEN 831 - OK=.FALSE. 832 - DELETE=.TRUE. 833 - GAP=-1.0 834 - ELSEIF(GAP.LE.0)THEN 835 - CALL INPMSG(J+1,'Gap must be > 0') 836 - OK=.FALSE. 837 - DELETE=.TRUE. 838 - GAP=-1.0 839 - ENDIF 840 - INEXT=J+2 841 - * Strip label. 842 - ELSEIF(INPCMP(J,'LAB#EL').NE.0)THEN 843 - CALL INPSTR(J+1,J+1,STRING,NC) 844 - STRTPR=STRING(1:1) 845 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',STRTPR).EQ. 846 - - 0)THEN 847 - CALL INPMSG(J+1, 848 - - 'The label must be a letter.') 849 - OK=.FALSE. 850 - DELETE=.TRUE. 851 - STRTPR='?' 852 - ENDIF 853 - INEXT=J+2 854 - * Otherwise, leave the loop. 855 - ELSE 856 - GOTO 130 857 - ENDIF 858 - 120 CONTINUE 859 - 130 CONTINUE 860 - ** Store the strip. 861 - IF(INPCMP(I,'R-STRIP')+INPCMP(I,'PHI-STRIP')+ 862 - - INPCMP(I,'X-STRIP')+INPCMP(I,'Y-STRIP').NE.0)THEN 863 - IF(DIR.EQ.'X'.OR.DIR.EQ.'R')THEN 864 - IF(NPSTR1(NX).GE.MXPSTR)THEN 865 - CALL INPMSG(I,'Maximum number of'// 866 - - ' strips reached.') 867 - OK=.FALSE. 868 - DELETE=.TRUE. 869 - ELSE 870 - NPSTR1(NX)=NPSTR1(NX)+1 871 - PLSTR1(NX,NPSTR1(NX),1)=SMIN 872 - PLSTR1(NX,NPSTR1(NX),2)=SMAX 873 - PLSTR1(NX,NPSTR1(NX),3)=GAP 874 - PSLAB1(NX,NPSTR1(NX))=STRTPR 875 - ENDIF 876 - ELSE 877 - IF(NPSTR1(NY).GE.MXPSTR)THEN 878 - CALL INPMSG(I,'Maximum number of'// 879 - - ' strips reached.') 880 - OK=.FALSE. 881 - DELETE=.TRUE. 882 - ELSE 883 - NPSTR1(NY)=NPSTR1(NY)+1 884 - PLSTR1(NY,NPSTR1(NY),1)=SMIN 885 - PLSTR1(NY,NPSTR1(NY),2)=SMAX 886 - PLSTR1(NY,NPSTR1(NY),3)=GAP 1 461 P=CELL D=CELINP 10 PAGE 594 887 - PSLAB1(NY,NPSTR1(NY))=STRTPR 888 - ENDIF 889 - ENDIF 890 - ELSEIF(INPCMP(I,'Z-STRIP').NE.0)THEN 891 - IF(DIR.EQ.'X'.OR.DIR.EQ.'R')THEN 892 - IF(NPSTR2(NX).GE.MXPSTR)THEN 893 - CALL INPMSG(I,'Maximum number of'// 894 - - ' strips reached.') 895 - OK=.FALSE. 896 - DELETE=.TRUE. 897 - ELSE 898 - NPSTR2(NX)=NPSTR2(NX)+1 899 - PLSTR2(NX,NPSTR2(NX),1)=SMIN 900 - PLSTR2(NX,NPSTR2(NX),2)=SMAX 901 - PLSTR2(NX,NPSTR2(NX),3)=GAP 902 - PSLAB2(NX,NPSTR2(NX))=STRTPR 903 - ENDIF 904 - ELSE 905 - IF(NPSTR2(NY).GE.MXPSTR)THEN 906 - CALL INPMSG(I,'Maximum number of'// 907 - - ' strips reached.') 908 - OK=.FALSE. 909 - DELETE=.TRUE. 910 - ELSE 911 - NPSTR2(NY)=NPSTR2(NY)+1 912 - PLSTR2(NY,NPSTR2(NY),1)=SMIN 913 - PLSTR2(NY,NPSTR2(NY),2)=SMAX 914 - PLSTR2(NY,NPSTR2(NY),3)=GAP 915 - PSLAB2(NY,NPSTR2(NY))=STRTPR 916 - ENDIF 917 - ENDIF 918 - ENDIF 919 - * Unknown field. 920 - ELSE 921 - CALL INPMSG(I,'Not a known parameter. ') 922 - CALL INPMSG(I+1,'See the previous message. ') 923 - ENDIF 924 - 110 CONTINUE 925 - ** Print the errors generated so far. 926 - CALL INPERR 927 - * Delete in case of errors. 928 - IF(DELETE)THEN 929 - PRINT *,' !!!!!! CELINP WARNING : Plane ignored'// 930 - - ' because of syntax or value errors.' 931 - IF(DIR.EQ.'X'.OR.DIR.EQ.'R')THEN 932 - YNPLAN(NX)=.FALSE. 933 - NPSTR1(NX)=0 934 - NPSTR2(NX)=0 935 - NX=NX-1 936 - ELSE 937 - YNPLAN(NY)=.FALSE. 938 - NPSTR1(NY)=0 939 - NPSTR2(NY)=0 940 - NY=NY-1 941 - ENDIF 942 - * Skip the rest. 943 - GOTO 10 944 - ENDIF 945 - ** Store the data. 946 - IF(DIR.EQ.'Y')THEN 947 - CCART=.TRUE. 948 - COPLAN(NY)=COOR 949 - VTPLAN(NY)=VOLT 950 - PLATYP(NY)=PLATPR 951 - ELSEIF(DIR.EQ.'P')THEN 952 - CPOLAR=.TRUE. 953 - COPLAN(NY)=PI*COOR/180.0 954 - VTPLAN(NY)=VOLT 955 - PLATYP(NY)=PLATPR 956 - ELSEIF(DIR.EQ.'X')THEN 957 - CCART=.TRUE. 958 - COPLAN(NX)=COOR 959 - VTPLAN(NX)=VOLT 960 - PLATYP(NX)=PLATPR 961 - ELSEIF(DIR.EQ.'R')THEN 962 - CPOLAR=.TRUE. 963 - COPLAN(NX)=LOG(COOR) 964 - VTPLAN(NX)=VOLT 965 - PLATYP(NX)=PLATPR 966 - ELSE 967 - PRINT *,' ###### CELINP ERROR : Direction not'// 968 - - ' recognised; program error - please report.' 969 - OK=.FALSE. 970 - GOTO 10 971 - ENDIF 972 - *** Provide a reset. 973 - ELSEIF(INPCMP(1,'RES#ET').NE.0)THEN 974 - DO 12 I=2,NWORD 975 - * Coordinate system. 976 - IF(INPCMP(I,'COOR#DINATES').NE.0)THEN 977 - CCART=.FALSE. 978 - CPOLAR=.FALSE. 979 - CTUBE=.FALSE. 980 - * Local variables. 981 - ELSEIF(INPCMP(I,'DEF#INITIONS').NE.0)THEN 982 - NVAR=0 983 - * Dielectrica. 984 - ELSEIF(INPCMP(I,'DIEL#ECTRICA').NE.0)THEN 985 - NXMATT=0 986 - NYMATT=0 987 - * Field map. 988 - ELSEIF(INPCMP(I,'F#IELD-M#AP').NE.0)THEN 989 - CALL MAPINT 990 - * Solids. 991 - ELSEIF(INPCMP(I,'SOL#IDS').NE.0)THEN 992 - NSOLID=0 1 461 P=CELL D=CELINP 11 PAGE 595 993 - ICCURR=0 994 - * Periodicities. 995 - ELSEIF(INPCMP(I,'PER#IODICITIES').NE.0)THEN 996 - PERX=.FALSE. 997 - PERY=.FALSE. 998 - PERZ=.FALSE. 999 - PERMX=.FALSE. 1000 - PERMY=.FALSE. 1001 - PERMZ=.FALSE. 1002 - PERAX=.FALSE. 1003 - PERAY=.FALSE. 1004 - PERAZ=.FALSE. 1005 - PERRX=.FALSE. 1006 - PERRY=.FALSE. 1007 - PERRZ=.FALSE. 1008 - * Planes. 1009 - ELSEIF(INPCMP(I,'PL#ANES').NE.0)THEN 1010 - NX=0 1011 - NY=2 1012 - YNPLAN(1)=.FALSE. 1013 - YNPLAN(2)=.FALSE. 1014 - YNPLAN(3)=.FALSE. 1015 - YNPLAN(4)=.FALSE. 1016 - * Tube. 1017 - ELSEIF(INPCMP(I,'TUB#E').NE.0)THEN 1018 - CTUBE=.FALSE. 1019 - * Wires. 1020 - ELSEIF(INPCMP(I,'ROW#S')+INPCMP(I,'WIR#ES').NE.0)THEN 1021 - NWIRE=0 1022 - * Something unknown. 1023 - ELSE 1024 - CALL INPMSG(I,'Is not known, can not be reset') 1025 - ENDIF 1026 - 12 CONTINUE 1027 - * Everything. 1028 - IF(NWORD.EQ.1)THEN 1029 - CALL CELINT 1030 - NX=0 1031 - NY=2 1032 - CCART=.FALSE. 1033 - CPOLAR=.FALSE. 1034 - CTUBE=.FALSE. 1035 - CALL MAPINT 1036 - NSOLID=0 1037 - ICCURR=0 1038 - ENDIF 1039 - * Dump error messages. 1040 - CALL INPERR 1041 - * Reset error flag. 1042 - IFAIL=0 1043 - * Reset data origin flag. 1044 - IGET=0 1045 - *** If ROW is a keyword, read the next few lines as rows. 1046 - ELSEIF(INPCMP(1,'RO#WS')+INPCMP(1,'WIR#ES').NE.0)THEN 1047 - * First find out whether they are in a polar or in a Cartesian system. 1048 - IF(NWORD.EQ.1)THEN 1049 - IF(.NOT.(CPOLAR.OR.CCART.OR.CTUBE))CCART=.TRUE. 1050 - ELSEIF(NWORD.EQ.2)THEN 1051 - IF(INPCMP(2,'CART#ESIAN').NE.0)THEN 1052 - IF(CPOLAR.OR.CTUBE)THEN 1053 - PRINT *,' !!!!!! CELINP WARNING : Mixed'// 1054 - - ' coordinates not permitted ;'// 1055 - - ' polar coordinates assumed.' 1056 - ELSE 1057 - CCART=.TRUE. 1058 - ENDIF 1059 - ELSEIF(INPCMP(2,'POL#AR').NE.0)THEN 1060 - IF(CCART)THEN 1061 - PRINT *,' !!!!!! CELINP WARNING : Mixed'// 1062 - - ' coordinates not permitted ;'// 1063 - - ' Cartesian coordinates assumed.' 1064 - ELSE 1065 - CPOLAR=.TRUE. 1066 - CTUBE=.FALSE. 1067 - ENDIF 1068 - ELSEIF(INPCMP(2,'TUBE').NE.0)THEN 1069 - IF(CCART)THEN 1070 - PRINT *,' !!!!!! CELINP WARNING : Mixed'// 1071 - - ' coordinates not permitted ;'// 1072 - - ' Cartesian coordinates assumed.' 1073 - ELSE 1074 - CTUBE=.TRUE. 1075 - CPOLAR=.FALSE. 1076 - ENDIF 1077 - ELSE 1078 - CALL INPSTR(2,2,STRING,NC) 1079 - PRINT *,' !!!!!! CELINP WARNING : '//STRING(1:NC) 1080 - - //' is not known as a coordinate system'// 1081 - - ' to ROWS ; it is ignored.' 1082 - IF(.NOT.(CPOLAR.OR.CCART))CCART=.TRUE. 1083 - ENDIF 1084 - ELSE 1085 - PRINT *,' !!!!!! CELINP WARNING : ROWS has at most'// 1086 - - ' one argument ; arguments ignored.' 1087 - IF(.NOT.(CPOLAR.OR.CCART.OR.CTUBE))CCART=.TRUE. 1088 - ENDIF 1089 - * Add the loop variable to the list. 1090 - IF(NVAR+1.GT.MXVAR)THEN 1091 - PRINT *,' !!!!!! CELINP WARNING : Variable stack'// 1092 - - ' exhausted, no room for a loop variable.' 1093 - ELSE 1094 - NVAR=NVAR+1 1095 - VARLIS(NVAR)='I' 1096 - VAR(NVAR)=0.0 1097 - ENDIF 1098 - * Print a prompt for interactive mode reading of cell data 1 461 P=CELL D=CELINP 12 PAGE 596 1099 - IF(STDSTR('INPUT'))PRINT *,' ====== CELINP INPUT :'// 1100 - - ' Please enter the rows, terminate with a blank line.' 1101 - CALL INPPRM('Rows','ADD-NOPRINT') 1102 - * Initialise number of wires. 1103 - NWIRE=0 1104 - 20 CONTINUE 1105 - * Input a line and make some preliminary checks. 1106 - CALL INPWRD(NWORD) 1107 - CALL INPSTR(1,1,STRING,NC) 1108 - IF(STRING(1:1).EQ.'&')THEN 1109 - PRINT *,' !!!!!! CELINP WARNING : The section can'// 1110 - - ' not be left at this point ; line ignored.' 1111 - GOTO 20 1112 - ENDIF 1113 - IF(NWORD.GT.9)PRINT *,' !!!!!! CELINP WARNING : At most 9'// 1114 - - ' items expected on a wire line ; excess is ignored.' 1115 - IF(NWORD.EQ.0)GOTO 60 1116 - * Read wire codes, checking that they are letters, 1117 - WIRTPR=STRING(1:1) 1118 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',WIRTPR).EQ.0)THEN 1119 - CALL INPMSG(1,'The wire code must be a letter') 1120 - IFAIL1=1 1121 - ELSE 1122 - IFAIL1=0 1123 - ENDIF 1124 - * Read n which may be symbolic but should not contain a loop-variable. 1125 - NFUNCT=0 1126 - IF(NWORD.GE.2.AND.INPCMP(2,'*').EQ.0)THEN 1127 - CALL INPSTR(2,2,STRING,NC) 1128 - FUNCT(1:NC)=STRING(1:NC) 1129 - NFUNCT=NC 1130 - ELSE 1131 - FUNCT(1:3)='1.0' 1132 - NFUNCT=3 1133 - ENDIF 1134 - CALL ALGPRE(FUNCT,NFUNCT,VARLIS,NVAR,NRES,USE,IENTRY,IFAIL4) 1135 - IF(USE(NVAR).AND.IFAIL4.EQ.0)THEN 1136 - CALL INPMSG(2,'Invalid use of loop variable I') 1137 - IFAIL4=1 1138 - IFAIL5=1 1139 - RES(1)=0 1140 - ELSEIF(NRES.NE.1.AND.IFAIL4.EQ.0)THEN 1141 - CALL INPMSG(2,'Returns more than 1 result. ') 1142 - IFAIL4=1 1143 - IFAIL5=1 1144 - RES(1)=0 1145 - ELSEIF(IFAIL4.EQ.0)THEN 1146 - CALL ALGEXE(IENTRY,VAR,MODVAR,NVAR,RES,MODRES,1,IFAIL5) 1147 - ELSE 1148 - IFAIL5=1 1149 - ENDIF 1150 - NR=NINT(RES(1)) 1151 - CALL ALGCLR(IENTRY) 1152 - * Check that the number of wires in the row is positive and integer. 1153 - IF(NR.LE.0.AND.IFAIL4.EQ.0)THEN 1154 - CALL INPMSG(2,'Number of wires should be > 0.') 1155 - IFAIL2=1 1156 - ELSEIF(ABS(NR-RES(1)).GT.1.0E-3.AND.IFAIL4.EQ.0)THEN 1157 - CALL INPMSG(2,'Does not evaluate to integer. ') 1158 - IFAIL2=1 1159 - ELSE 1160 - IFAIL2=0 1161 - ENDIF 1162 - * Translate d, x, y, V, W, l, s - symbolic, loop variable permitted. 1163 - NFUNCT=0 1164 - DO 21 I=3,9 1165 - IF(I.EQ.9.AND.INPCMP(I,'CU-BE#RYLLIUM')+ 1166 - - INPCMP(I,'C#OPPER-BE#RYLLIUM')+ 1167 - - INPCMP(I,'BE#RYLLIUM-#CU')+ 1168 - - INPCMP(I,'BE#RYLLIUM-#COPPER').NE.0)THEN 1169 - FUNCT(NFUNCT+1:NFUNCT+4)=',8.7' 1170 - NFUNCT=NFUNCT+4 1171 - ELSEIF(I.EQ.9.AND.INPCMP(I,'W')+ 1172 - - INPCMP(I,'TUNG#STEN').NE.0)THEN 1173 - FUNCT(NFUNCT+1:NFUNCT+5)=',19.3' 1174 - NFUNCT=NFUNCT+5 1175 - ELSEIF(NWORD.GE.I.AND.INPCMP(I,'*').EQ.0)THEN 1176 - CALL INPSTR(I,I,STRING,NC) 1177 - FUNCT(NFUNCT+1:NFUNCT+NC+1)=','//STRING(1:NC) 1178 - NFUNCT=NFUNCT+NC+1 1179 - ELSE 1180 - IF(I.EQ.3)THEN 1181 - FUNCT(NFUNCT+1:NFUNCT+5)=',0.01' 1182 - NFUNCT=NFUNCT+5 1183 - ELSEIF(I.EQ.7)THEN 1184 - FUNCT(NFUNCT+1:NFUNCT+5)=',50.0' 1185 - NFUNCT=NFUNCT+5 1186 - ELSEIF(I.EQ.8)THEN 1187 - FUNCT(NFUNCT+1:NFUNCT+6)=',100.0' 1188 - NFUNCT=NFUNCT+6 1189 - ELSEIF(I.EQ.9)THEN 1190 - FUNCT(NFUNCT+1:NFUNCT+5)=',19.3' 1191 - NFUNCT=NFUNCT+5 1192 - ELSE 1193 - FUNCT(NFUNCT+1:NFUNCT+4)=',0.0' 1194 - NFUNCT=NFUNCT+4 1195 - ENDIF 1196 - ENDIF 1197 - 21 CONTINUE 1198 - FUNCT(1:1)=' ' 1199 - CALL ALGPRE(FUNCT,NFUNCT,VARLIS,NVAR,NRES,USE,IENTRY,IFAIL6) 1200 - * Dump messages and skip the row if not meaningful. 1201 - CALL INPERR 1202 - IF(IFAIL1+IFAIL2+IFAIL4+IFAIL5+IFAIL6.NE.0)THEN 1203 - PRINT *,' !!!!!! CELINP WARNING : Row skipped'// 1204 - - ' because of syntax or value errors.' 1 461 P=CELL D=CELINP 13 PAGE 597 1205 - CALL ALGCLR(IENTRY) 1206 - GOTO 20 1207 - ENDIF 1208 - * Add the new wires to the list, making sure that # is not > MXWIRE. 1209 - DO 30 J=0,NR-1 1210 - VAR(NVAR)=J 1211 - MODVAR(NVAR)=2 1212 - CALL ALGEXE(IENTRY,VAR,MODVAR,NVAR,RES,MODRES,7,IFAIL7) 1213 - DR=RES(1) 1214 - XR=RES(2) 1215 - YR=RES(3) 1216 - VR=RES(4) 1217 - WR=RES(5) 1218 - UR=RES(6) 1219 - SR=RES(7) 1220 - IF(IFAIL7.NE.0)THEN 1221 - PRINT '('' !!!!!! CELINP WARNING : Algebra errors;'', 1222 - - '' wire '',I3,'' of this row is skipped.'')',J+1 1223 - GOTO 30 1224 - ELSEIF(DR.LE.0.0)THEN 1225 - PRINT '('' !!!!!! CELINP WARNING : Wire '',I3,'' of'', 1226 - - '' this row is skipped because its diameter is'', 1227 - - '' not positive.'')',J+1 1228 - GOTO 30 1229 - ELSEIF(WR.LE.0.0)THEN 1230 - PRINT '('' !!!!!! CELINP WARNING : Wire '',I3,'' of'', 1231 - - '' this row is skipped because its tension is'', 1232 - - '' not positive.'')',J+1 1233 - GOTO 30 1234 - ELSEIF(UR.LE.0.0)THEN 1235 - PRINT '('' !!!!!! CELINP WARNING : Wire '',I3,'' of'', 1236 - - '' this row is skipped because its length is'', 1237 - - '' not positive.'')',J+1 1238 - GOTO 30 1239 - ELSEIF(SR.LE.0.0)THEN 1240 - PRINT '('' !!!!!! CELINP WARNING : Wire '',I3,'' of'', 1241 - - '' this row is skipped because its density is'', 1242 - - '' not positive.'')',J+1 1243 - GOTO 30 1244 - ENDIF 1245 - NWIRE=NWIRE+1 1246 - IF(NWIRE.GT.MXWIRE)GOTO 30 1247 - X(NWIRE)=XR 1248 - Y(NWIRE)=YR 1249 - V(NWIRE)=VR 1250 - W(NWIRE)=WR 1251 - U(NWIRE)=UR 1252 - DENS(NWIRE)=SR 1253 - D(NWIRE)=DR 1254 - WIRTYP(NWIRE)=WIRTPR 1255 - INDSW(NWIRE)=0 1256 - * Convert from polar to internal coordinates if the cell is polar. 1257 - IF(CPOLAR.AND..NOT.CTUBE)THEN 1258 - IF(X(NWIRE).LE.D(I))THEN 1259 - PRINT '('' !!!!!! CELINP WARNING : Wire '',I3, 1260 - - '' of this row is too close to the origin;'', 1261 - - '' the wire is skipped.'')',J+1 1262 - NWIRE=NWIRE-1 1263 - ELSE 1264 - D(NWIRE)=DR/X(NWIRE) 1265 - CALL CFMPTR(X(NWIRE),Y(NWIRE),X(NWIRE),Y(NWIRE),1, 1266 - - IFAIL1) 1267 - ENDIF 1268 - ENDIF 1269 - 30 CONTINUE 1270 - * Release the algebra entry point. 1271 - CALL ALGCLR(IENTRY) 1272 - GOTO 20 1273 - 60 CONTINUE 1274 - * Reset the prompt. 1275 - CALL INPPRM(' ','BACK-PRINT') 1276 - * Reset the loop variable. 1277 - NVAR=NVAR-1 1278 - * Warn if no wires are found. 1279 - IF(NWIRE.EQ.0)THEN 1280 - PRINT *,' !!!!!! CELINP WARNING : No rows found'// 1281 - - ' after the instruction ROW.' 1282 - * Warn if NWIRE > MXWIRE. 1283 - ELSEIF(NWIRE.GT.MXWIRE)THEN 1284 - PRINT *,' ###### CELINP ERROR : The number of wires' 1285 - - //' found in the input is larger than MXWIRE'// 1286 - - ' for the present compilation' 1287 - PRINT *,' a correct value may' 1288 - - //' be obtained by inserting the following'// 1289 - - ' cards in the Patchy cradle before +PAM.' 1290 - PRINT *,' ' 1291 - PRINT *,'+REP,P=COMMONS,C=.' 1292 - PRINT *,' PARAMETER(MXWIRE=',NWIRE, 1293 - - ', MXSW=',MXSW,')' 1294 - PRINT *,' ' 1295 - NWIRE=MXWIRE 1296 - IFAIL=1 1297 - ENDIF 1298 - * Proceed with next input line in this section (reset GET condition). 1299 - IGET=0 1300 - *** Listing of solids. 1301 - ELSEIF(INPCMP(1,'SOL#IDS').NE.0)THEN 1302 - CALL CELSOL 1303 - *** TUBE statement. 1304 - ELSEIF(INPCMP(1,'TUBE').NE.0)THEN 1305 - * Can not be handled if the cell has started to be Cartesian. 1306 - IF(CCART)THEN 1307 - PRINT *,' !!!!!! CELINP WARNING : Cell description'// 1308 - - ' started in Cartesian coordinates; tube ignored.' 1309 - GOTO 10 1310 - ENDIF 1 461 P=CELL D=CELINP 14 PAGE 598 1311 - * Check for the presence of planes. 1312 - IF(NY.NE.2.OR.NX.NE.0)THEN 1313 - PRINT *,' !!!!!! CELINP WARNING : You have already'// 1314 - - ' defined one or more planes; they are deleted.' 1315 - NX=0 1316 - NY=2 1317 - ENDIF 1318 - * Reset the origin flag. 1319 - IGET=0 1320 - * Check the input syntax and extract the parameters. 1321 - RADIUS=0 1322 - NTUBER=0 1323 - VOLT=0.0 1324 - PLATPR='?' 1325 - DELETE=.FALSE. 1326 - * Preset the tube data. 1327 - COTUBE=1 1328 - VTTUBE=0 1329 - NTUBE=0 1330 - MTUBE=0 1331 - NPSTR1(5)=0 1332 - NPSTR2(5)=0 1333 - PLATYP(5)='?' 1334 - * Read the command line. 1335 - INEXT=2 1336 - DO 40 I=2,NWORD 1337 - IF(I.LT.INEXT)GOTO 40 1338 - * Look for the radius. 1339 - IF(INPCMP(I,'R#ADIUS').NE.0)THEN 1340 - CALL INPCHK(I+1,2,IFAIL1) 1341 - CALL INPRDR(I+1,RADIUS,0.0) 1342 - IF(IFAIL1.NE.0)THEN 1343 - DELETE=.TRUE. 1344 - OK=.FALSE. 1345 - ELSEIF(RADIUS.LE.0.0)THEN 1346 - CALL INPMSG(I,'Tube radius must be > 0.') 1347 - CALL INPMSG(I+1,'See the previous message.') 1348 - DELETE=.TRUE. 1349 - OK=.FALSE. 1350 - ELSE 1351 - COTUBE=RADIUS 1352 - ENDIF 1353 - INEXT=I+2 1354 - * Voltage definition, 1355 - ELSEIF(INPCMP(I,'V#OLTAGE').NE.0)THEN 1356 - CALL INPCHK(I+1,2,IFAIL1) 1357 - CALL INPRDR(I+1,VOLT,0.0) 1358 - IF(IFAIL1.NE.0)THEN 1359 - DELETE=.TRUE. 1360 - OK=.FALSE. 1361 - ELSE 1362 - VTTUBE=VOLT 1363 - ENDIF 1364 - INEXT=I+2 1365 - * Number of edges. 1366 - ELSEIF(INPCMP(I,'E#DGES').NE.0)THEN 1367 - CALL INPCHK(I+1,1,IFAIL1) 1368 - CALL INPRDI(I+1,NTUBER,0) 1369 - IF(IFAIL1.NE.0)THEN 1370 - DELETE=.TRUE. 1371 - OK=.FALSE. 1372 - ELSEIF((NTUBER.NE.0.AND.NTUBER.LT.3).OR. 1373 - - NTUBER.GT.8)THEN 1374 - CALL INPMSG(I+1,'Number of edges not valid. ') 1375 - DELETE=.TRUE. 1376 - OK=.FALSE. 1377 - ELSE 1378 - NTUBE=NTUBER 1379 - ENDIF 1380 - INEXT=I+2 1381 - ELSEIF(INPCMP(I,'CIRC#LE')+ 1382 - - INPCMP(I,'CIRC#ULAR')+ 1383 - - INPCMP(I,'CYL#INDER')+ 1384 - - INPCMP(I,'CYL#INDRICAL').NE.0)THEN 1385 - NTUBE=0 1386 - ELSEIF(INPCMP(I,'TRI#ANGLE')+ 1387 - - INPCMP(I,'TRI#ANGULAR').NE.0)THEN 1388 - NTUBE=3 1389 - ELSEIF(INPCMP(I,'SQU#ARE').NE.0)THEN 1390 - NTUBE=4 1391 - ELSEIF(INPCMP(I,'PENT#AGONAL').NE.0)THEN 1392 - NTUBE=5 1393 - ELSEIF(INPCMP(I,'HEX#AGONAL').NE.0)THEN 1394 - NTUBE=6 1395 - ELSEIF(INPCMP(I,'HEPT#AGONAL').NE.0)THEN 1396 - NTUBE=7 1397 - ELSEIF(INPCMP(I,'OCT#AGONAL').NE.0)THEN 1398 - NTUBE=8 1399 - * Label. 1400 - ELSEIF(INPCMP(I,'LAB#EL').NE.0)THEN 1401 - CALL INPSTR(I+1,I+1,STRING,NC) 1402 - PLATPR=STRING(1:1) 1403 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',PLATPR).EQ. 1404 - - 0)THEN 1405 - CALL INPMSG(I+1,'The label must be a letter.') 1406 - DELETE=.TRUE. 1407 - OK=.FALSE. 1408 - ELSE 1409 - PLATYP(5)=PLATPR 1410 - ENDIF 1411 - INEXT=I+2 1412 - ** Strips. 1413 - ELSEIF(INPCMP(I,'PHI-STRIP')+INPCMP(I,'Z-STRIP').NE.0)THEN 1414 - * Initial values. 1415 - SMIN=0.0 1416 - SMAX=0.0 1 461 P=CELL D=CELINP 15 PAGE 599 1417 - GAP=-1.0 1418 - STRTPR='?' 1419 - * Read range. 1420 - CALL INPCHK(I+1,2,IFAIL1) 1421 - CALL INPRDR(I+1,SMIN,0.0) 1422 - CALL INPCHK(I+2,2,IFAIL2) 1423 - CALL INPRDR(I+2,SMAX,0.0) 1424 - * Reject syntax errors. 1425 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN 1426 - OK=.FALSE. 1427 - DELETE=.TRUE. 1428 - ENDIF 1429 - * Coordinate transformations for polar coordinates. 1430 - IF(INPCMP(I,'PHI-STRIP').NE.0)THEN 1431 - SMIN=PI*SMIN/180 1432 - SMAX=PI*SMAX/180 1433 - SMIN=MOD(SMIN,2*PI) 1434 - IF(SMIN.GT.PI)SMIN=SMIN-2*PI 1435 - IF(SMIN.LT.-PI)SMIN=SMIN+2*PI 1436 - SMAX=MOD(SMAX,2*PI) 1437 - IF(SMAX.GT.PI)SMAX=SMAX-2*PI 1438 - IF(SMAX.LT.-PI)SMAX=SMAX+2*PI 1439 - ENDIF 1440 - * Order the coordinates if required. 1441 - IF(ABS(SMIN-SMAX).LT.1E-4)THEN 1442 - CALL INPMSG(I+1,'Zero range not permitted.') 1443 - CALL INPMSG(I+2,'Zero range not permitted.') 1444 - OK=.FALSE. 1445 - DELETE=.TRUE. 1446 - SMIN=1 1447 - SMAX=1 1448 - ELSEIF(SMIN.GT.SMAX)THEN 1449 - SAUX=SMIN 1450 - SMIN=SMAX 1451 - SMAX=SAUX 1452 - ENDIF 1453 - * Next word. 1454 - INEXT=I+3 1455 - ** Search for optional arguments, first initialise them. 1456 - DO 140 J=I+3,NWORD 1457 - IF(J.LT.INEXT)GOTO 140 1458 - * Gap width. 1459 - IF(INPCMP(J,'GAP').NE.0)THEN 1460 - CALL INPCHK(J+1,2,IFAIL2) 1461 - CALL INPRDR(J+1,GAP,0.0) 1462 - IF(IFAIL2.NE.0)THEN 1463 - OK=.FALSE. 1464 - DELETE=.TRUE. 1465 - GAP=-1.0 1466 - ELSEIF(GAP.LE.0)THEN 1467 - CALL INPMSG(J+1,'Gap must be > 0') 1468 - OK=.FALSE. 1469 - DELETE=.TRUE. 1470 - GAP=-1.0 1471 - ENDIF 1472 - INEXT=J+2 1473 - * Strip label. 1474 - ELSEIF(INPCMP(J,'LAB#EL').NE.0)THEN 1475 - CALL INPSTR(J+1,J+1,STRING,NC) 1476 - STRTPR=STRING(1:1) 1477 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',STRTPR).EQ. 1478 - - 0)THEN 1479 - CALL INPMSG(J+1, 1480 - - 'The label must be a letter.') 1481 - OK=.FALSE. 1482 - DELETE=.TRUE. 1483 - STRTPR='?' 1484 - ENDIF 1485 - INEXT=J+2 1486 - * Otherwise, leave the loop. 1487 - ELSE 1488 - GOTO 150 1489 - ENDIF 1490 - 140 CONTINUE 1491 - 150 CONTINUE 1492 - ** Store the strip. 1493 - IF(INPCMP(I,'PHI-STRIP').NE.0)THEN 1494 - IF(NPSTR1(5).GE.MXPSTR)THEN 1495 - CALL INPMSG(I,'Maximum number of'// 1496 - - ' strips reached.') 1497 - OK=.FALSE. 1498 - DELETE=.TRUE. 1499 - ELSE 1500 - NPSTR1(5)=NPSTR1(5)+1 1501 - PLSTR1(5,NPSTR1(5),1)=SMIN 1502 - PLSTR1(5,NPSTR1(5),2)=SMAX 1503 - PLSTR1(5,NPSTR1(5),3)=GAP 1504 - PSLAB1(5,NPSTR1(5))=STRTPR 1505 - ENDIF 1506 - ELSEIF(INPCMP(I,'Z-STRIP').NE.0)THEN 1507 - IF(NPSTR2(5).GE.MXPSTR)THEN 1508 - CALL INPMSG(I,'Maximum number of'// 1509 - - ' strips reached.') 1510 - OK=.FALSE. 1511 - DELETE=.TRUE. 1512 - ELSE 1513 - NPSTR2(5)=NPSTR2(5)+1 1514 - PLSTR2(5,NPSTR2(5),1)=SMIN 1515 - PLSTR2(5,NPSTR2(5),2)=SMAX 1516 - PLSTR2(5,NPSTR2(5),3)=GAP 1517 - PSLAB2(5,NPSTR2(5))=STRTPR 1518 - ENDIF 1519 - ENDIF 1520 - * Unknown field. 1521 - ELSE 1522 - CALL INPMSG(I,'Not known as a valid keyword. ') 1 461 P=CELL D=CELINP 16 PAGE 600 1523 - ENDIF 1524 - 40 CONTINUE 1525 - * Print the errors generated so far, return if errors are serious. 1526 - CALL INPERR 1527 - * Delete tube in case of errors. 1528 - IF(DELETE)THEN 1529 - PRINT *,' !!!!!! CELINP WARNING : Tube ignored'// 1530 - - ' because of syntax or value errors.' 1531 - NPSTR1(5)=0 1532 - NPSTR2(5)=0 1533 - CTUBE=.FALSE. 1534 - GOTO 10 1535 - ENDIF 1536 - * Update the coordinate system flags. 1537 - CCART=.FALSE. 1538 - CTUBE=.TRUE. 1539 - CPOLAR=.FALSE. 1540 - *** Call CELWRT with the name of the data set. 1541 - ELSEIF(INPCMP(1,'WR#ITE').NE.0)THEN 1542 - CALL CELWRT(1) 1543 - *** It is not possible to get here if a keyword is found. 1544 - ELSE 1545 - CALL INPSTR(1,1,STRING,NC) 1546 - PRINT *,' !!!!!! CELINP WARNING : '//STRING(1:NC)//' is'// 1547 - - ' not a valid instruction ; line is skipped.' 1548 - ENDIF 1549 - *** Finish reading loop. 1550 - GOTO 10 1551 - 50 CONTINUE 1552 - *** Set POLAR if the cell has cylindrical symmetry. 1553 - IF(CCART)THEN 1554 - POLAR=.FALSE. 1555 - TUBE=.FALSE. 1556 - * Tubes. 1557 - ELSEIF(CTUBE)THEN 1558 - POLAR=.FALSE. 1559 - TUBE=.TRUE. 1560 - * True polar cells, set phi period if neither periodic nor planes. 1561 - ELSEIF(CPOLAR)THEN 1562 - POLAR=.TRUE. 1563 - TUBE=.FALSE. 1564 - IF(.NOT.(PERY.OR.(YNPLAN(3).AND.YNPLAN(4))))THEN 1565 - SY=2.0*PI 1566 - PERY=.TRUE. 1567 - ENDIF 1568 - ENDIF 1569 - *** Register the amount of CPU time used by this routine. 1570 - CALL TIMLOG('Reading the cell definition: ') 1571 - *** Normaly the routine should end at this point. 1572 - END 462 GARFIELD ================================================== P=CELL D=CELINT 1 ============================ 0 + +DECK,CELINT. 1 - SUBROUTINE CELINT 2 - *----------------------------------------------------------------------- 3 - * CELINT - Initialises cell data. 4 - * (Last changed on 5/12/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9 - INTEGER I,J 10 - *** Overall flag for cell data. 11 - CELSET =.FALSE. 12 - *** Coordinate system. 13 - POLAR =.FALSE. 14 - TUBE =.FALSE. 15 - *** Cell type. 16 - TYPE ='A ' 17 - ICTYPE =1 18 - *** Identifier. 19 - CELLID =' ' 20 - *** Wires. 21 - NWIRE =0 22 - NSW =0 23 - KAPPA =0.0 24 - DO 40 I=1,MXWIRE 25 - X(I) =0.0 26 - Y(I) =0.0 27 - D(I) =0.0 28 - E(I) =0.0 29 - V(I) =0.0 30 - W(I) =50.0 31 - U(I) =100.0 32 - DENS(I) =19.3 33 - B2SIN(I) =0.0 34 - WMAP(I) =CMPLX(0.0,0.0) 35 - WIRTYP(I)='?' 36 - CNALSO(I)=.TRUE. 37 - 40 CONTINUE 38 - *** 3D charges. 39 - N3D =0 40 - DO 90 I=1,MX3D 41 - X3D(I) =0.0 42 - Y3D(I) =0.0 43 - Z3D(I) =0.0 44 - E3D(I) =0.0 45 - 90 CONTINUE 46 - NTERMB =10 47 - NTERMP =100 48 - *** Planes and tube. 49 - DO 20 I=1,5 50 - IF(I.LE.4)THEN 51 - YNPLAN(I)=.FALSE. 52 - COPLAN(I)=0.0 1 462 P=CELL D=CELINT 2 PAGE 601 53 - VTPLAN(I)=0.0 54 - ENDIF 55 - * Strips. 56 - NPSTR1(I)=0 57 - NPSTR2(I)=0 58 - DO 100 J=1,MXPSTR 59 - PLSTR1(I,J,1)=0 60 - PLSTR1(I,J,2)=0 61 - PLSTR1(I,J,3)=0 62 - PLSTR2(I,J,1)=0 63 - PLSTR2(I,J,2)=0 64 - PLSTR2(I,J,3)=0 65 - PSLAB1(I,J)='?' 66 - PSLAB2(I,J)='?' 67 - INDST1(I,J)=0 68 - INDST2(I,J)=0 69 - 100 CONTINUE 70 - 20 CONTINUE 71 - * Plane labels and references. 72 - DO 80 I=1,5 73 - PLATYP(I)='?' 74 - INDPLA(I)=0 75 - 80 CONTINUE 76 - * Plane shorthand. 77 - YNPLAX =.FALSE. 78 - YNPLAY =.FALSE. 79 - COPLAX =1.0 80 - COPLAY =1.0 81 - * Tube properties. 82 - NTUBE =0 83 - MTUBE =0 84 - *** Dielectrica. 85 - NXMATT =0 86 - NYMATT =0 87 - *** Periodicities. 88 - PERX =.FALSE. 89 - PERY =.FALSE. 90 - PERZ =.FALSE. 91 - PERMX =.FALSE. 92 - PERMY =.FALSE. 93 - PERMZ =.FALSE. 94 - PERAX =.FALSE. 95 - PERAY =.FALSE. 96 - PERAZ =.FALSE. 97 - PERRX =.FALSE. 98 - PERRY =.FALSE. 99 - PERRZ =.FALSE. 100 - SX =1.0 101 - SY =1.0 102 - SZ =1.0 103 - *** Gravity. 104 - DOWN(1) =0 105 - DOWN(2) =0 106 - DOWN(3) =1 107 - END 463 GARFIELD ================================================== P=CELL D=CELLAY 1 ============================ 0 + +DECK,CELLAY. 1 - SUBROUTINE CELLAY(PXMIN,PYMIN,PXMAX,PYMAX) 2 - *----------------------------------------------------------------------- 3 - * CELLAY - This routine draws all elements of the cell inside the 4 - * rectangle (PXMIN,PYMIN) to (PXMAX,PYMAX), taking care of 5 - * periodicities etc, on the plot being made. 6 - * VARIABLES : NXMIN,NXMAX: Numbers of resp first and last x-period. 7 - * NYMIN,NYMAX: " " " " " " y " 8 - * (XPOS,YPOS): Used for plotting (like XPL and YPL). 9 - * CHAR : Used because WIRTYP(I) may start in the 10 - * middle of a word. 11 - * XPL,YPL : Used for plotting of lines. 12 - * (Last changed on 1/12/00.) 13 - *----------------------------------------------------------------------- 14 - implicit none 15.- +SEQ,DIMENSIONS. 16.- +SEQ,CELLDATA. 17.- +SEQ,CONSTANTS. 18.- +SEQ,PRINTPLOT. 19 - REAL XPL(101),YPL(101),XPOS(1),YPOS(1),PXMIN,PYMIN,PXMAX,PYMAX 20 - INTEGER NX,NXMIN,NXMAX,NY,NYMIN,NYMAX,I,J,K 21 - *** Determine the number of periods present in the cell. 22 - NXMIN=0 23 - NXMAX=0 24 - NYMIN=0 25 - NYMAX=0 26 - IF(PERX)THEN 27 - NXMIN=INT(PXMIN/SX)-1 28 - NXMAX=INT(PXMAX/SX)+1 29 - ENDIF 30 - IF(PERY)THEN 31 - NYMIN=INT(PYMIN/SY)-1 32 - NYMAX=INT(PYMAX/SY)+1 33 - ENDIF 34 - *** Draw the field map if present. 35 - CALL MAPPLT(PXMIN,PYMIN,0.0,PXMAX,PYMAX,0.0) 36 - *** Plot the wires as MARKERS. 37 - IF(LWRMRK)THEN 38 - * Loop over the wires. 39 - DO 130 I=1,NWIRE 40 - * Loop over the periods. 41 - DO 140 NX=NXMIN,NXMAX 42 - DO 150 NY=NYMIN,NYMAX 43 - * Non-tube shaped cells. 44 - IF(.NOT.TUBE)THEN 45 - XPOS(1)=X(I)+NX*SX 46 - IF(XPOS(1)+0.5*D(I).LE.PXMIN.OR. 47 - - XPOS(1)-0.5*D(I).GE.PXMAX)GOTO 140 1 463 P=CELL D=CELLAY 2 PAGE 602 48 - YPOS(1)=Y(I)+NY*SY 49 - IF(YPOS(1)+0.5*D(I).LE.PYMIN.OR. 50 - - YPOS(1)-0.5*D(I).GE.PYMAX)GOTO 150 51 - IF(POLAR)CALL CFMRTC(XPOS,YPOS,XPOS,YPOS,1) 52 - * Tubed shaped cells. 53 - ELSE 54 - CALL CFMCTP(X(I),Y(I),XPOS,YPOS,1) 55 - IF(PERY)YPOS(1)=YPOS(1)+REAL(NY*360)/REAL(MTUBE) 56 - CALL CFMPTC(XPOS,YPOS,XPOS,YPOS,1) 57 - IF(XPOS(1)+0.5*D(I).LE.PXMIN.OR. 58 - - XPOS(1)-0.5*D(I).GE.PXMAX.OR. 59 - - YPOS(1)+0.5*D(I).LE.PYMIN.OR. 60 - - YPOS(1)-0.5*D(I).GE.PYMAX)GOTO 150 61 - ENDIF 62 - * Choose the appropriate representation. 63 - IF(WIRTYP(I).EQ.'S')THEN 64 - CALL GRATTS('S-WIRE','POLYMARKER') 65 - ELSEIF(WIRTYP(I).EQ.'P')THEN 66 - CALL GRATTS('P-WIRE','POLYMARKER') 67 - ELSEIF(WIRTYP(I).EQ.'C')THEN 68 - CALL GRATTS('C-WIRE','POLYMARKER') 69 - ELSE 70 - CALL GRATTS('OTHER-WIRE','POLYMARKER') 71 - ENDIF 72 - CALL GRMARK(1,XPOS,YPOS) 73 - 150 CONTINUE 74 - 140 CONTINUE 75 - 130 CONTINUE 76 - *** Plot the wires as AREAS. 77 - ELSE 78 - * Set fill area style, by default hollow to make GFA look like GPL. 79 - CALL GRATTS('WIRES','AREA') 80 - * Open a segment so that we can later on pick out the wires. 81 - CALL GCRSG(1) 82 - * Make the wires detectable. 83 - CALL GSDTEC(1,1) 84 - * Loop over all wires. 85 - DO 40 I=1,NWIRE 86 - * Set a pick identifier for each wire separately. 87 - CALL GSPKID(I) 88 - * Loop over the periods. 89 - DO 30 NX=NXMIN,NXMAX 90 - DO 20 NY=NYMIN,NYMAX 91 - * Non-tube shaped cells. 92 - IF(.NOT.TUBE)THEN 93 - XPOS(1)=X(I)+NX*SX 94 - IF(XPOS(1)+0.5*D(I).LE.PXMIN.OR. 95 - - XPOS(1)-0.5*D(I).GE.PXMAX)GOTO 30 96 - YPOS(1)=Y(I)+NY*SY 97 - IF(YPOS(1)+0.5*D(I).LE.PYMIN.OR. 98 - - YPOS(1)-0.5*D(I).GE.PYMAX)GOTO 20 99 - IF(POLAR)CALL CFMRTC(XPOS,YPOS,XPOS,YPOS,1) 100 - * Tubed shaped cells. 101 - ELSE 102 - CALL CFMCTP(X(I),Y(I),XPOS,YPOS,1) 103 - IF(PERY)YPOS(1)=YPOS(1)+REAL(NY*360)/REAL(MTUBE) 104 - CALL CFMPTC(XPOS,YPOS,XPOS,YPOS,1) 105 - IF(XPOS(1)+0.5*D(I).LE.PXMIN.OR. 106 - - XPOS(1)-0.5*D(I).GE.PXMAX.OR. 107 - - YPOS(1)+0.5*D(I).LE.PYMIN.OR. 108 - - YPOS(1)-0.5*D(I).GE.PYMAX)GOTO 20 109 - ENDIF 110 - * Calculate 20 points on each of the wires to make a circle. 111 - DO 10 J=1,21 112 - XPL(J)=XPOS(1)+0.5*D(I)*COS(PI*J/10.0) 113 - YPL(J)=YPOS(1)+0.5*D(I)*SIN(PI*J/10.0) 114 - IF(XPL(J).LT.PXMIN)XPL(J)=PXMIN 115 - IF(XPL(J).GT.PXMAX)XPL(J)=PXMAX 116 - IF(YPL(J).LT.PYMIN)YPL(J)=PYMIN 117 - IF(YPL(J).GT.PYMAX)YPL(J)=PYMAX 118 - 10 CONTINUE 119 - * Plots as fill areas. 120 - CALL GRAREA(21,XPL,YPL) 121 - * Next periods. 122 - 20 CONTINUE 123 - 30 CONTINUE 124 - * Next wire. 125 - 40 CONTINUE 126 - * Close the segment for the wires. 127 - CALL GCLSG 128 - ENDIF 129 - *** Draw lines at the positions of the x (or r)-planes. 130 - DO 70 I=1,2 131 - DO 60 NX=NXMIN,NXMAX 132 - IF(YNPLAN(I))THEN 133 - CALL GRATTS('PLANES','POLYLINE') 134 - XPOS(1)=COPLAN(I)+NX*SX 135 - IF(XPOS(1).LE.PXMIN.OR.XPOS(1).GE.PXMAX)GOTO 60 136 - DO 50 J=1,101 137 - XPL(J)=XPOS(1) 138 - YPL(J)=PYMIN+(J-1)*(PYMAX-PYMIN)/100 139 - 50 CONTINUE 140 - IF(POLAR)CALL CFMRTC(XPL,YPL,XPL,YPL,101) 141 - CALL GRLINE(101,XPL,YPL) 142 - CALL GRATTS('STRIPS','POLYLINE') 143 - DO 160 J=1,NPSTR1(I) 144 - DO 170 K=1,101 145 - XPL(K)=XPOS(1) 146 - YPL(K)=MAX(PLSTR1(I,J,1),PYMIN)+(K-1)* 147 - - (MIN(PLSTR1(I,J,2),PYMAX)-MAX(PLSTR1(I,J,1),PYMIN))/100 148 - 170 CONTINUE 149 - IF(POLAR)CALL CFMRTC(XPL,YPL,XPL,YPL,101) 150 - CALL GRLINE(101,XPL,YPL) 151 - 160 CONTINUE 152 - ENDIF 153 - 60 CONTINUE 1 463 P=CELL D=CELLAY 3 PAGE 603 154 - 70 CONTINUE 155 - *** Draw lines at the positions of the y-planes. 156 - DO 100 I=3,4 157 - DO 90 NY=NYMIN,NYMAX 158 - IF(YNPLAN(I))THEN 159 - CALL GRATTS('PLANES','POLYLINE') 160 - YPOS(1)=COPLAN(I)+NY*SY 161 - IF(YPOS(1).LE.PYMIN.OR.YPOS(1).GE.PYMAX)GOTO 90 162 - DO 80 J=1,101 163 - XPL(J)=PXMIN+(J-1)*(PXMAX-PXMIN)/100 164 - YPL(J)=YPOS(1) 165 - 80 CONTINUE 166 - IF(POLAR)CALL CFMRTC(XPL,YPL,XPL,YPL,101) 167 - CALL GRLINE(101,XPL,YPL) 168 - CALL GRATTS('STRIPS','POLYLINE') 169 - DO 180 J=1,NPSTR1(I) 170 - DO 190 K=1,101 171 - XPL(K)=MAX(PLSTR1(I,J,1),PXMIN)+(K-1)* 172 - - (MIN(PLSTR1(I,J,2),PXMAX)-MAX(PLSTR1(I,J,1),PXMIN))/100 173 - YPL(K)=YPOS(1) 174 - 190 CONTINUE 175 - IF(POLAR)CALL CFMRTC(XPL,YPL,XPL,YPL,101) 176 - CALL GRLINE(101,XPL,YPL) 177 - 180 CONTINUE 178 - ENDIF 179 - 90 CONTINUE 180 - 100 CONTINUE 181 - *** Draw the dielectrica, first switch to fill are style hatched. 182 - CALL GRATTS('DIELECTRICA-1','AREA') 183 - DO 110 I=1,NXMATT 184 - XPL(1)=PXMIN 185 - IF(XMATT(I,3).EQ.0)XPL(1)=MIN(PXMAX,MAX(PXMIN,XMATT(I,1))) 186 - YPL(1)=PYMIN 187 - XPL(2)=XPL(1) 188 - YPL(2)=PYMAX 189 - XPL(3)=PXMAX 190 - IF(XMATT(I,4).EQ.0)XPL(3)=MIN(PXMAX,MAX(PXMIN,XMATT(I,2))) 191 - YPL(3)=PYMAX 192 - XPL(4)=XPL(3) 193 - YPL(4)=PYMIN 194 - XPL(5)=XPL(1) 195 - YPL(5)=YPL(1) 196 - CALL GRLINE(5,XPL,YPL) 197 - CALL GRAREA(5,XPL,YPL) 198 - 110 CONTINUE 199 - DO 120 I=1,NYMATT 200 - XPL(1)=PXMIN 201 - YPL(1)=PYMIN 202 - IF(YMATT(I,3).EQ.0)YPL(1)=MIN(PYMAX,MAX(PYMIN,YMATT(I,1))) 203 - XPL(2)=PXMAX 204 - YPL(2)=YPL(1) 205 - XPL(3)=PXMAX 206 - YPL(3)=PYMAX 207 - IF(YMATT(I,4).EQ.0)YPL(3)=MIN(PYMAX,MAX(PYMIN,YMATT(I,2))) 208 - XPL(4)=PXMIN 209 - YPL(4)=YPL(3) 210 - XPL(5)=XPL(1) 211 - YPL(5)=YPL(1) 212 - CALL GRLINE(5,XPL,YPL) 213 - CALL GRAREA(5,XPL,YPL) 214 - 120 CONTINUE 215 - *** Draw the tube. 216 - CALL GRATTS('TUBE','POLYLINE') 217 - IF(TUBE.AND.NTUBE.EQ.0)THEN 218 - DO 200 I=1,101 219 - XPL(I)=COTUBE*COS(PI*REAL(I)/50.0) 220 - YPL(I)=COTUBE*SIN(PI*REAL(I)/50.0) 221 - 200 CONTINUE 222 - CALL GRLINE(101,XPL,YPL) 223 - ELSEIF(TUBE)THEN 224 - XPL(1)=COTUBE*COS(2*PI*REAL(0)/REAL(NTUBE)) 225 - YPL(1)=COTUBE*SIN(2*PI*REAL(0)/REAL(NTUBE)) 226 - DO 210 I=1,NTUBE 227 - XPL(2)=COTUBE*COS(2*PI*REAL(I)/REAL(NTUBE)) 228 - YPL(2)=COTUBE*SIN(2*PI*REAL(I)/REAL(NTUBE)) 229 - CALL GRLINE(2,XPL,YPL) 230 - XPL(1)=XPL(2) 231 - YPL(1)=YPL(2) 232 - 210 CONTINUE 233 - ENDIF 234 - END 464 GARFIELD ================================================== P=CELL D=CELPLT 1 ============================ 0 + +DECK,CELPLT. 1 - SUBROUTINE CELPLT 2 - *----------------------------------------------------------------------- 3 - * CELPLT - This routine produces a plotted layout of the cell 4 - * VARIABLES : PXMIN,PXMAX: x-range of layout plot 5 - * PYMIN,PYMAX: y-range of layout plot 6 - * (Last changed on 14/ 2/97.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,CONSTANTS. 12.- +SEQ,PARAMETERS. 13.- +SEQ,GRAPHICS. 14.- +SEQ,PRINTPLOT. 15 - REAL DIFF,DX,XPOS,YPOS,XPL,YPL 16 - INTEGER NX,NXMIN,NXMAX,NY,NYMIN,NYMAX,I 17 - *** Set plotting area. 18 - PXMIN=XMIN-0.1*(XMAX-XMIN) 19 - PXMAX=XMAX+0.1*(XMAX-XMIN) 20 - PYMIN=YMIN-0.1*(YMAX-YMIN) 21 - PYMAX=YMAX+0.1*(YMAX-YMIN) 1 464 P=CELL D=CELPLT 2 PAGE 604 22 - IF(POLAR.AND.PYMAX-PYMIN.GE.2.0*PI)THEN 23 - PYMIN=-PI 24 - PYMAX=PI 25 - ENDIF 26 - *** Determine the number of periods present in the cell. 27 - NXMIN=0 28 - NXMAX=0 29 - NYMIN=0 30 - NYMAX=0 31 - IF(PERX)THEN 32 - NXMIN=INT(PXMIN/SX)-2 33 - NXMAX=INT(PXMAX/SX)+1 34 - ENDIF 35 - IF(PERY)THEN 36 - NYMIN=INT(PYMIN/SY)-2 37 - NYMAX=INT(PYMAX/SY)+1 38 - ENDIF 39 - *** Plot the axes, the wires, the planes and the dielectrica. 40 - IF(LISOCL.AND.PXMAX-PXMIN.GT.PYMAX-PYMIN)THEN 41 - DIFF=(PXMAX-PXMIN)-(PYMAX-PYMIN) 42 - CALL GRAXIS(PXMIN,PYMIN-DIFF/2,PXMAX,PYMAX+DIFF/2, 43 - - 'LAYOUT OF THE CELL ') 44 - CALL CELLAY(PXMIN,PYMIN-DIFF/2,PXMAX,PYMAX+DIFF/2) 45 - ELSEIF(LISOCL)THEN 46 - DIFF=(PYMAX-PYMIN)-(PXMAX-PXMIN) 47 - CALL GRAXIS(PXMIN-DIFF/2,PYMIN,PXMAX+DIFF/2,PYMAX, 48 - - 'LAYOUT OF THE CELL ') 49 - CALL CELLAY(PXMIN-DIFF/2,PYMIN,PXMAX+DIFF/2,PYMAX) 50 - ELSE 51 - CALL GRAXIS(PXMIN,PYMIN,PXMAX,PYMAX, 52 - - 'LAYOUT OF THE CELL ') 53 - CALL CELLAY(PXMIN,PYMIN,PXMAX,PYMAX) 54 - ENDIF 55 - *** Put the cell label in. 56 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 57 - *** Switch to unscaled mode to get normal letters. 58 - CALL GSELNT(0) 59 - *** Calculate reasonable positions for the wire-code-labels, set DX. 60 - DX=(USERX1-USERX0)/50.0 61 - DO 10 I=1,NWIRE 62 - DO 20 NX=NXMIN,NXMAX 63 - XPOS=X(I)+NX*SX 64 - IF(XPOS.LT.PXMIN.OR.XPOS.GT.PXMAX)GOTO 20 65 - DO 30 NY=NYMIN,NYMAX 66 - YPOS=Y(I)+NY*SY 67 - IF(YPOS.LT.PYMIN.OR.YPOS.GT.PYMAX)GOTO 30 68 - * If polar, convert to cartesian coordinates. 69 - XPL=XPOS 70 - YPL=YPOS 71 - IF(POLAR)CALL CFMRTC(XPL,YPL,XPL,YPL,1) 72 - * Shift the location of the label slightly in x within the area. 73 - IF(XPL+5.0*MAX(D(I),DX).LT.USERX1)THEN 74 - XPL=XPL+2.0*MAX(D(I),DX) 75 - ELSEIF(XPL+5.0*MAX(D(I),DX).GT.USERX0)THEN 76 - XPL=XPL-2.0*MAX(D(I),DX) 77 - ELSE 78 - GOTO 20 79 - ENDIF 80 - * Plot, transforming to display coordinates (NDC). 81 - IF(.NOT.LWRMRK)CALL GRTX( 82 - - DISPX0+(DISPX1-DISPX0)*(XPL-USERX0)/(USERX1-USERX0), 83 - - DISPY0+(DISPY1-DISPY0)*(YPL-USERY0)/(USERY1-USERY0), 84 - - WIRTYP(I)) 85 - 30 CONTINUE 86 - 20 CONTINUE 87 - 10 CONTINUE 88 - CALL GSELNT(1) 89 - *** Clear the screen to allow the next plot to start. 90 - CALL GRNEXT 91 - *** Register the plot and the amount of CPU time used. 92 - CALL TIMLOG('Plotting the cell layout: ') 93 - CALL GRALOG('Layout of the drift cell. ') 94 - END 465 GARFIELD ================================================== P=CELL D=CELPRT 1 ============================ 0 + +DECK,CELPRT. 1 - SUBROUTINE CELPRT 2 - *----------------------------------------------------------------------- 3 - * CELPRT - Subroutine printing all available information on the cell. 4 - * VARIABLES : Only trivial local variables. 5 - * (Last changed on 29/11/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,SOLIDS. 11.- +SEQ,FIELDMAP. 12.- +SEQ,PRINTPLOT. 13.- +SEQ,CONSTANTS. 14 - CHARACTER*30 AUX1,AUX2,AUX3,AUX4,AUX5,AUX6,AUX7,AUX8,AUX9 15 - CHARACTER*120 OUTSTR 16 - INTEGER I,J,NCAUX,NC1,NC2,NC3,NC4,NC5,NC6,NC7,NC8,NC9,NCOUT, 17 - - LMIN,RMAX 18 - REAL XPRT,YPRT,DPRT,SUMCH,XMINP,YMINP,XMAXP,YMAXP 19 - *** Identify the procedure. 20 - IF(LIDENT)PRINT *,' /// ROUTINE CELPRT ///' 21 - *** Write a heading for the summary, including the cell id 22 - WRITE(LUNOUT,'(''1 SUMMARY OF THE CELL DATA''/ 23 - - '' ========================'')') 24 - IF(CELLID.NE.' ')WRITE(LUNOUT,'(/'' Cell identification : '', 25 - - A)') CELLID 26 - *** Print positions of wires, applied voltages and resulting charges. 27 - IF(POLAR.AND.NWIRE.GE.1)THEN 28 - WRITE(LUNOUT,'(/'' TABLE OF THE WIRES''// 29 - - '' Nr Diameter r phi Voltage'', 1 465 P=CELL D=CELPRT 2 PAGE 605 30 - - '' Charge Tension Length Density Label''/ 31 - - '' [micron] [cm] [deg] [Volt]'', 32 - - '' [pC/cm] [g] [cm] [g/cm3]''/)') 33 - ELSEIF(NWIRE.GE.1)THEN 34 - WRITE(LUNOUT,'(/'' TABLE OF THE WIRES''// 35 - - '' Nr Diameter x y Voltage'', 36 - - '' Charge Tension Length Density Label''/ 37 - - '' [micron] [cm] [cm] [Volt]'', 38 - - '' [pC/cm] [g] [cm] [g/cm3]''/)') 39 - ELSE 40 - WRITE(LUNOUT,'('' TABLE OF THE WIRES''// 41 - - '' There are no wires in this cell.'')') 42 - ENDIF 43 - DO 10 I=1,NWIRE 44 - XPRT=X(I) 45 - YPRT=Y(I) 46 - DPRT=D(I) 47 - IF(POLAR)THEN 48 - CALL CFMRTP(XPRT,YPRT,XPRT,YPRT,1) 49 - DPRT=D(I)*XPRT 50 - ENDIF 51 - CALL OUTFMT(REAL(I),2,AUX9,NC9,'RIGHT') 52 - CALL OUTFMT(DPRT*10000.0,2,AUX1,NC1,'RIGHT') 53 - CALL OUTFMT(XPRT,2,AUX2,NC2,'RIGHT') 54 - CALL OUTFMT(YPRT,2,AUX3,NC3,'RIGHT') 55 - CALL OUTFMT(V(I),2,AUX4,NC4,'RIGHT') 56 - CALL OUTFMT(2.0E12*PI*EPS0*E(I),2,AUX5,NC5,'RIGHT') 57 - CALL OUTFMT(W(I),2,AUX6,NC6,'RIGHT') 58 - CALL OUTFMT(U(I),2,AUX7,NC7,'RIGHT') 59 - CALL OUTFMT(DENS(I),2,AUX8,NC8,'RIGHT') 60 - WRITE(LUNOUT,'(2X,A4,A9,A9,A9,A9,A12,A9,A9,A9,5X,A1)') 61 - - AUX9(27:),AUX1(22:),AUX2(22:),AUX3(22:),AUX4(22:), 62 - - AUX5(19:),AUX6(22:),AUX7(22:),AUX8(22:),WIRTYP(I) 63 - 10 CONTINUE 64 - *** Field map perhaps ? 65 - IF(NMAP.GE.1)THEN 66 - WRITE(LUNOUT,'(/'' FIELD MAP'')') 67 - CALL MAPPRT 68 - ENDIF 69 - IF(NSOLID.GE.1)CALL CELSPR 70 - *** Print information on the tube if present. 71 - IF(TUBE)THEN 72 - CALL OUTFMT(VTTUBE,2,AUX1,NC1,'LEFT') 73 - CALL OUTFMT(COTUBE,2,AUX2,NC2,'LEFT') 74 - IF(NTUBE.EQ.0)THEN 75 - AUX3='Circular' 76 - NC3=8 77 - ELSEIF(NTUBE.EQ.3)THEN 78 - AUX3='Triangular' 79 - NC3=10 80 - ELSEIF(NTUBE.EQ.4)THEN 81 - AUX3='Square' 82 - NC3=6 83 - ELSEIF(NTUBE.EQ.5)THEN 84 - AUX3='Pentagonal' 85 - NC3=10 86 - ELSEIF(NTUBE.EQ.6)THEN 87 - AUX3='Hexagonal' 88 - NC3=9 89 - ELSEIF(NTUBE.EQ.7)THEN 90 - AUX3='Heptagonal' 91 - NC3=10 92 - ELSEIF(NTUBE.EQ.8)THEN 93 - AUX3='Octagonal' 94 - NC3=9 95 - ELSE 96 - CALL OUTFMT(REAL(NTUBE),2,AUX5,NC5,'LEFT') 97 - AUX3='polygonal with '//AUX5(1:NC5)//' corners' 98 - NC3=23+NC5 99 - ENDIF 100 - IF(PLATYP(5).EQ.'?')THEN 101 - AUX4='Not labeled' 102 - NC4=11 103 - ELSE 104 - AUX4=PLATYP(5) 105 - NC4=1 106 - ENDIF 107 - WRITE(LUNOUT,'(/'' ENCLOSING TUBE''// 108 - - '' Potential: '',A,'' V''/ 109 - - '' Radius: '',A,'' cm''/ 110 - - '' Shape: '',A/ 111 - - '' Label: '',A)') 112 - - AUX1(1:NC1),AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) 113 - IF(NPSTR1(5).GT.0)THEN 114 - WRITE(LUNOUT,'('' phi-Strips:'')') 115 - DO 110 I=1,NPSTR1(5) 116 - CALL OUTFMT(180*PLSTR1(5,I,1)/PI,2,AUX1,NC1,'LEFT') 117 - CALL OUTFMT(180*PLSTR1(5,I,2)/PI,2,AUX2,NC2,'LEFT') 118 - CALL OUTFMT(PLSTR1(5,I,3),2,AUX3,NC3,'LEFT') 119 - IF(PSLAB1(5,I).EQ.'?')THEN 120 - AUX4=' not labeled' 121 - NC4=12 122 - ELSE 123 - AUX4=' label = '//PSLAB1(5,I) 124 - NC4=10 125 - ENDIF 126 - WRITE(LUNOUT,'(14X,A)') AUX1(1:NC1)//' < phi < '// 127 - - AUX2(1:NC2)//' degrees, gap = '//AUX3(1:NC3)// 128 - - ' cm,'//AUX4(1:NC4) 129 - 110 CONTINUE 130 - ELSE 131 - WRITE(LUNOUT,'('' phi-Strips: None'')') 132 - ENDIF 133 - IF(NPSTR2(5).GT.0)THEN 134 - WRITE(LUNOUT,'('' z-Strips:'')') 135 - DO 120 I=1,NPSTR2(5) 1 465 P=CELL D=CELPRT 3 PAGE 606 136 - CALL OUTFMT(PLSTR2(5,I,1),2,AUX1,NC1,'LEFT') 137 - CALL OUTFMT(PLSTR2(5,I,2),2,AUX2,NC2,'LEFT') 138 - CALL OUTFMT(PLSTR2(5,I,3),2,AUX3,NC3,'LEFT') 139 - IF(PSLAB2(5,I).EQ.'?')THEN 140 - AUX4=' not labeled' 141 - NC4=12 142 - ELSE 143 - AUX4=' label = '//PSLAB2(5,I) 144 - NC4=10 145 - ENDIF 146 - WRITE(LUNOUT,'(14X,A)') AUX1(1:NC1)//' < z < '// 147 - - AUX2(1:NC2)//' cm, gap = '//AUX3(1:NC3)// 148 - - ' cm,'//AUX4(1:NC4) 149 - 120 CONTINUE 150 - ELSE 151 - WRITE(LUNOUT,'('' z-Strips: None'')') 152 - ENDIF 153 - *** Print data on the equipotential planes, first those at const x or r 154 - ELSEIF(YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4))THEN 155 - WRITE(LUNOUT,'(/'' EQUIPOTENTIAL PLANES'')') 156 - IF(YNPLAN(1).AND.YNPLAN(2).AND..NOT.POLAR)WRITE(LUNOUT, 157 - - '(/'' There are two planes at constant x:'')') 158 - IF(YNPLAN(1).AND.YNPLAN(2).AND.POLAR)WRITE(LUNOUT, 159 - - '(/'' There are two planes at constant r:'')') 160 - IF(((YNPLAN(1).AND..NOT.YNPLAN(2)).OR.(YNPLAN(2).AND..NOT. 161 - - YNPLAN(1))).AND..NOT.POLAR)WRITE(LUNOUT, 162 - - '(/'' There is one plane at constant x:'')') 163 - IF(((YNPLAN(1).AND..NOT.YNPLAN(2)).OR.(YNPLAN(2).AND..NOT. 164 - - YNPLAN(1))).AND.POLAR)WRITE(LUNOUT, 165 - - '(/'' There is one plane at constant r:'')') 166 - DO 20 I=1,2 167 - IF(.NOT.YNPLAN(I))GOTO 20 168 - NCOUT=0 169 - IF(POLAR)THEN 170 - CALL OUTFMT(EXP(COPLAN(I)),2,AUX1,NC1,'LEFT') 171 - OUTSTR(NCOUT+1:NCOUT+NC1+13)= 172 - - ' r = '//AUX1(1:NC1)//' cm,' 173 - NCOUT=NCOUT+NC1+13 174 - ELSE 175 - CALL OUTFMT(COPLAN(I),2,AUX1,NC1,'LEFT') 176 - OUTSTR(NCOUT+1:NCOUT+NC1+13)= 177 - - ' x = '//AUX1(1:NC1)//' cm,' 178 - NCOUT=NCOUT+NC1+13 179 - ENDIF 180 - IF(ABS(VTPLAN(I)).GT.1E-4)THEN 181 - CALL OUTFMT(VTPLAN(I),2,AUX1,NC1,'LEFT') 182 - OUTSTR(NCOUT+1:NCOUT+NC1+16)= 183 - - ' potential = '//AUX1(1:NC1)//' V,' 184 - NCOUT=NCOUT+NC1+16 185 - ELSE 186 - OUTSTR(NCOUT+1:NCOUT+9)=' earthed,' 187 - NCOUT=NCOUT+9 188 - ENDIF 189 - IF(PLATYP(I).NE.'?')THEN 190 - OUTSTR(NCOUT+1:NCOUT+11)=' label = '//PLATYP(I)//',' 191 - NCOUT=NCOUT+11 192 - ELSE 193 - OUTSTR(NCOUT+1:NCOUT+13)=' not labeled,' 194 - NCOUT=NCOUT+13 195 - ENDIF 196 - IF(NPSTR1(I).EQ.0.AND.NPSTR2(I).EQ.0)THEN 197 - OUTSTR(NCOUT+1:NCOUT+11)=' no strips.' 198 - NCOUT=NCOUT+11 199 - ELSE 200 - OUTSTR(NCOUT+1:NCOUT+21)=' divided into strips:' 201 - NCOUT=NCOUT+21 202 - ENDIF 203 - WRITE(LUNOUT,'(A)') OUTSTR(1:NCOUT) 204 - DO 70 J=1,NPSTR1(I) 205 - CALL OUTFMT(PLSTR1(I,J,3),2,AUX4,NC4,'LEFT') 206 - IF(PSLAB1(I,J).EQ.'?')THEN 207 - AUX5=' not labeled' 208 - NC5=12 209 - ELSE 210 - AUX5=' label = '//PSLAB1(I,J) 211 - NC5=10 212 - ENDIF 213 - IF(POLAR)THEN 214 - CALL OUTFMT(180*PLSTR1(I,J,1)/PI,2,AUX2,NC2,'LEFT') 215 - CALL OUTFMT(180*PLSTR1(I,J,2)/PI,2,AUX3,NC3,'LEFT') 216 - WRITE(LUNOUT,'(8X,A)') AUX2(1:NC2)//' < phi < '// 217 - - AUX3(1:NC3)//' degrees, gap = '//AUX4(1:NC4)// 218 - - ' cm,'//AUX5(1:NC5) 219 - ELSE 220 - CALL OUTFMT(PLSTR1(I,J,1),2,AUX2,NC2,'LEFT') 221 - CALL OUTFMT(PLSTR1(I,J,2),2,AUX3,NC3,'LEFT') 222 - WRITE(LUNOUT,'(8X,A)') AUX2(1:NC2)//' < y < '// 223 - - AUX3(1:NC3)//' cm, gap = '//AUX4(1:NC4)//' cm,'// 224 - - AUX5(1:NC5) 225 - ENDIF 226 - 70 CONTINUE 227 - DO 80 J=1,NPSTR2(I) 228 - CALL OUTFMT(PLSTR2(I,J,1),2,AUX2,NC2,'LEFT') 229 - CALL OUTFMT(PLSTR2(I,J,2),2,AUX3,NC3,'LEFT') 230 - CALL OUTFMT(PLSTR2(I,J,3),2,AUX4,NC4,'LEFT') 231 - IF(PSLAB2(I,J).EQ.'?')THEN 232 - AUX5=' not labeled' 233 - NC5=12 234 - ELSE 235 - AUX5=' label = '//PSLAB2(I,J) 236 - NC5=10 237 - ENDIF 238 - WRITE(LUNOUT,'(8X,A)') AUX2(1:NC2)//' < z < '// 239 - - AUX3(1:NC3)//' cm, gap = '//AUX4(1:NC4)//' cm,'// 240 - - AUX5(1:NC5) 241 - 80 CONTINUE 1 465 P=CELL D=CELPRT 4 PAGE 607 242 - 20 CONTINUE 243 - * Next the planes at constant y or phi 244 - IF(YNPLAN(3).AND.YNPLAN(4).AND..NOT.POLAR)WRITE(LUNOUT, 245 - - '(/'' There are two planes at constant y:'')') 246 - IF(YNPLAN(3).AND.YNPLAN(4).AND.POLAR)WRITE(LUNOUT, 247 - - '(/'' There are two planes at constant phi:'')') 248 - IF(((YNPLAN(3).AND..NOT.YNPLAN(4)).OR.(YNPLAN(4).AND..NOT. 249 - - YNPLAN(3))).AND..NOT.POLAR)WRITE(LUNOUT, 250 - - '(/'' There is one plane at constant y:'')') 251 - IF(((YNPLAN(3).AND..NOT.YNPLAN(4)).OR.(YNPLAN(4).AND..NOT. 252 - - YNPLAN(3))).AND.POLAR)WRITE(LUNOUT, 253 - - '(/'' There is one plane at constant phi:'')') 254 - DO 30 I=3,4 255 - IF(.NOT.YNPLAN(I))GOTO 30 256 - NCOUT=0 257 - IF(POLAR)THEN 258 - CALL OUTFMT(180*COPLAN(I)/PI,2,AUX1,NC1,'LEFT') 259 - OUTSTR(NCOUT+1:NCOUT+NC1+20)= 260 - - ' phi = '//AUX1(1:NC1)//' degrees,' 261 - NCOUT=NCOUT+NC1+20 262 - ELSE 263 - CALL OUTFMT(COPLAN(I),2,AUX1,NC1,'LEFT') 264 - OUTSTR(NCOUT+1:NCOUT+NC1+13)= 265 - - ' y = '//AUX1(1:NC1)//' cm,' 266 - NCOUT=NCOUT+NC1+13 267 - ENDIF 268 - IF(ABS(VTPLAN(I)).GT.1E-4)THEN 269 - CALL OUTFMT(VTPLAN(I),2,AUX1,NC1,'LEFT') 270 - OUTSTR(NCOUT+1:NCOUT+NC1+16)= 271 - - ' potential = '//AUX1(1:NC1)//' V,' 272 - NCOUT=NCOUT+NC1+16 273 - ELSE 274 - OUTSTR(NCOUT+1:NCOUT+9)=' earthed,' 275 - NCOUT=NCOUT+9 276 - ENDIF 277 - IF(PLATYP(I).NE.'?')THEN 278 - OUTSTR(NCOUT+1:NCOUT+11)=' label = '//PLATYP(I)//',' 279 - NCOUT=NCOUT+11 280 - ELSE 281 - OUTSTR(NCOUT+1:NCOUT+13)=' not labeled,' 282 - NCOUT=NCOUT+13 283 - ENDIF 284 - IF(NPSTR1(I).EQ.0.AND.NPSTR2(I).EQ.0)THEN 285 - OUTSTR(NCOUT+1:NCOUT+11)=' no strips.' 286 - NCOUT=NCOUT+11 287 - ELSE 288 - OUTSTR(NCOUT+1:NCOUT+21)=' divided into strips:' 289 - NCOUT=NCOUT+21 290 - ENDIF 291 - WRITE(LUNOUT,'(A)') OUTSTR(1:NCOUT) 292 - DO 90 J=1,NPSTR1(I) 293 - CALL OUTFMT(PLSTR1(I,J,3),2,AUX4,NC4,'LEFT') 294 - IF(PSLAB1(I,J).EQ.'?')THEN 295 - AUX5=' not labeled' 296 - NC5=12 297 - ELSE 298 - AUX5=' label = '//PSLAB1(I,J) 299 - NC5=10 300 - ENDIF 301 - IF(POLAR)THEN 302 - CALL OUTFMT(EXP(PLSTR1(I,J,1)),2,AUX2,NC2,'LEFT') 303 - CALL OUTFMT(EXP(PLSTR1(I,J,2)),2,AUX3,NC3,'LEFT') 304 - WRITE(LUNOUT,'(8X,A)') AUX2(1:NC2)//' < r < '// 305 - - AUX3(1:NC3)//' cm, gap = '//AUX4(1:NC4)// 306 - - ' cm,'//AUX5(1:NC5) 307 - ELSE 308 - CALL OUTFMT(PLSTR1(I,J,1),2,AUX2,NC2,'LEFT') 309 - CALL OUTFMT(PLSTR1(I,J,2),2,AUX3,NC3,'LEFT') 310 - WRITE(LUNOUT,'(8X,A)') AUX2(1:NC2)//' < x < '// 311 - - AUX3(1:NC3)//' cm, gap = '//AUX4(1:NC4)//' cm,'// 312 - - AUX5(1:NC5) 313 - ENDIF 314 - 90 CONTINUE 315 - DO 100 J=1,NPSTR2(I) 316 - CALL OUTFMT(PLSTR2(I,J,1),2,AUX2,NC2,'LEFT') 317 - CALL OUTFMT(PLSTR2(I,J,2),2,AUX3,NC3,'LEFT') 318 - CALL OUTFMT(PLSTR2(I,J,3),2,AUX4,NC4,'LEFT') 319 - IF(PSLAB2(I,J).EQ.'?')THEN 320 - AUX5=' not labeled' 321 - NC5=12 322 - ELSE 323 - AUX5=' label = '//PSLAB2(I,J) 324 - NC5=10 325 - ENDIF 326 - WRITE(LUNOUT,'(8X,A)') AUX2(1:NC2)//' < z < '// 327 - - AUX3(1:NC3)//' cm, gap = '//AUX4(1:NC4)//' cm,'// 328 - - AUX5(1:NC5) 329 - 100 CONTINUE 330 - 30 CONTINUE 331 - ENDIF 332 - *** Print the type of periodicity, first header and x direction. 333 - IF(NMAP.LT.1)THEN 334 - WRITE(LUNOUT,'(/'' PERIODICITY'')') 335 - IF(PERX.AND.POLAR)THEN 336 - CALL OUTFMT(EXP(SX),2,AUX1,NC1,'LEFT') 337 - WRITE(LUNOUT,'(/'' The cell is repeated every '',A, 338 - - '' cm in r.'')') AUX1(1:NC1) 339 - ELSEIF(PERMX.AND.POLAR)THEN 340 - CALL OUTFMT(EXP(SX),2,AUX1,NC1,'LEFT') 341 - WRITE(LUNOUT,'(/'' The cell has mirror periodicity'', 342 - - '' in r with a length of '',A,'' cm.'')') 343 - - AUX1(1:NC1) 344 - ELSEIF(PERX)THEN 345 - CALL OUTFMT(SX,2,AUX1,NC1,'LEFT') 346 - WRITE(LUNOUT,'(/'' The cell is repeated every '',A, 347 - - '' cm in x.'')') AUX1(1:NC1) 1 465 P=CELL D=CELPRT 5 PAGE 608 348 - ELSEIF(PERMX)THEN 349 - CALL OUTFMT(SX,2,AUX1,NC1,'LEFT') 350 - WRITE(LUNOUT,'(/'' The cell has mirror periodicity'', 351 - - '' in x with a length of '',A,'' cm.'')') 352 - - AUX1(1:NC1) 353 - ELSEIF(POLAR)THEN 354 - WRITE(LUNOUT,'(/'' The cell is not periodic in r.'')') 355 - ELSE 356 - WRITE(LUNOUT,'(/'' The cell has no translation'', 357 - - '' periodicity in x.'')') 358 - ENDIF 359 - IF(PERAX)THEN 360 - CALL OUTFMT((XAMAX-XAMIN)*180/PI,2,AUX1,NC1,'LEFT') 361 - WRITE(LUNOUT,'('' The cell has axial periodicity'', 362 - - '' around x with a length of '',A, 363 - - '' degrees.'')') AUX1(1:NC1) 364 - ELSEIF(PERRX)THEN 365 - WRITE(LUNOUT,'('' The cell is rotationally'', 366 - - '' symmetric around the x-axis.'')') 367 - ELSE 368 - WRITE(LUNOUT,'('' The cell has no axial'', 369 - - '' periodicity around the x axis.'')') 370 - ENDIF 371 - * In y. 372 - IF(PERY.AND.(POLAR.OR.TUBE))THEN 373 - CALL OUTFMT(180*SY/PI,2,AUX1,NC1,'LEFT') 374 - WRITE(LUNOUT,'('' The cell is repeated in phi'', 375 - - '' every '',A,'' degrees.'')') AUX1(1:NC1) 376 - ELSEIF(PERMY.AND.(POLAR.OR.TUBE))THEN 377 - CALL OUTFMT(180*SY/PI,2,AUX1,NC1,'LEFT') 378 - WRITE(LUNOUT,'('' The cell has mirror periodicity'', 379 - - '' in phi with a length of '',A,'' degrees.'')') 380 - - AUX1(1:NC1) 381 - ELSEIF(PERY)THEN 382 - CALL OUTFMT(SY,2,AUX1,NC1,'LEFT') 383 - WRITE(LUNOUT,'('' The cell is repeated every '',A, 384 - - '' cm in y.'')') AUX1(1:NC1) 385 - ELSEIF(PERMY)THEN 386 - CALL OUTFMT(SY,2,AUX1,NC1,'LEFT') 387 - WRITE(LUNOUT,'('' The cell has mirror periodicity'', 388 - - '' in y with a length of '',A,'' cm.'')') 389 - - AUX1(1:NC1) 390 - ELSEIF(POLAR)THEN 391 - WRITE(LUNOUT,'('' The cell is not periodic in'', 392 - - '' phi.'')') 393 - ELSE 394 - WRITE(LUNOUT,'('' The cell has no translation'', 395 - - '' periodicity in y.'')') 396 - ENDIF 397 - IF(PERAY)THEN 398 - CALL OUTFMT((YAMAX-YAMIN)*180/PI,2,AUX1,NC1,'LEFT') 399 - WRITE(LUNOUT,'('' The cell has axial periodicity'', 400 - - '' around y with a length of '',A,'' degrees.'')') 401 - - AUX1(1:NC1) 402 - ELSEIF(PERRY)THEN 403 - WRITE(LUNOUT,'('' The cell is rotationally'', 404 - - '' symmetric around the y-axis.'')') 405 - ELSE 406 - WRITE(LUNOUT,'('' The cell has no axial'', 407 - - '' periodicity around the y axis.'')') 408 - ENDIF 409 - * In z. 410 - IF(PERZ)THEN 411 - CALL OUTFMT(SZ,2,AUX1,NC1,'LEFT') 412 - WRITE(LUNOUT,'('' The cell is repeated every '',A, 413 - - '' cm in z.'')') AUX1(1:NC1) 414 - ELSEIF(PERMZ)THEN 415 - CALL OUTFMT(SZ,2,AUX1,NC1,'LEFT') 416 - WRITE(LUNOUT,'('' The cell has mirror periodicity'', 417 - - '' in z with a length of '',A,'' cm.'')') 418 - - AUX1(1:NC1) 419 - ELSE 420 - WRITE(LUNOUT,'('' The cell has no translation'', 421 - - '' periodicity in z.'')') 422 - ENDIF 423 - IF(PERAZ)THEN 424 - CALL OUTFMT((ZAMAX-ZAMIN)*180/PI,2,AUX1,NC1,'LEFT') 425 - WRITE(LUNOUT,'('' The cell has axial periodicity'', 426 - - '' around z with a length of '',A,'' degrees.'')') 427 - - AUX1(1:NC1) 428 - ELSEIF(PERRZ)THEN 429 - WRITE(LUNOUT,'('' The cell is rotationally'', 430 - - '' symmetric around the z-axis.'')') 431 - ELSE 432 - WRITE(LUNOUT,'('' The cell has no axial'', 433 - - '' periodicity around the z axis.'')') 434 - ENDIF 435 - ENDIF 436 - *** List the dielectrica. 437 - IF(NXMATT.NE.0.OR.NYMATT.NE.0)THEN 438 - WRITE(LUNOUT,'(/'' LIST OF DIELECTRICA''// 439 - - '' Direction From To Epsilon''/ 440 - - '' [cm] [cm] [relative]''/ 441 - - )') 442 - DO 50 I=1,NXMATT 443 - IF(XMATT(I,3).NE.0)THEN 444 - AUX1=' -infinity' 445 - ELSE 446 - CALL OUTFMT(XMATT(I,1),2,AUX1,NCAUX,'RIGHT') 447 - ENDIF 448 - IF(XMATT(I,4).NE.0)THEN 449 - AUX2=' +infinity' 450 - ELSE 451 - CALL OUTFMT(XMATT(I,2),2,AUX2,NCAUX,'RIGHT') 452 - ENDIF 453 - CALL OUTFMT(XMATT(I,5),2,AUX3,NCAUX,'RIGHT') 1 465 P=CELL D=CELPRT 6 PAGE 609 454 - WRITE(LUNOUT,'(10X,A1,A13,1X,A13,1X,A13)') 455 - - 'x',AUX1,AUX2,AUX3 456 - 50 CONTINUE 457 - DO 60 I=1,NYMATT 458 - IF(YMATT(I,3).NE.0)THEN 459 - AUX1=' -infinity' 460 - ELSE 461 - CALL OUTFMT(YMATT(I,1),2,AUX1,NCAUX,'RIGHT') 462 - ENDIF 463 - IF(YMATT(I,4).NE.0)THEN 464 - AUX2=' +infinity' 465 - ELSE 466 - CALL OUTFMT(YMATT(I,2),2,AUX2,NCAUX,'RIGHT') 467 - ENDIF 468 - CALL OUTFMT(YMATT(I,5),2,AUX3,NCAUX,'RIGHT') 469 - WRITE(LUNOUT,'(10X,A1,A13,1X,A13,1X,A13)') 470 - - 'y',AUX1,AUX2,AUX3 471 - 60 CONTINUE 472 - ENDIF 473 - *** Print cell size, type and various other things. 474 - WRITE(LUNOUT,'(/'' OTHER DATA'')') 475 - CALL OUTFMT(DOWN(1),2,AUX1,NC1,'LEFT') 476 - CALL OUTFMT(DOWN(2),2,AUX2,NC2,'LEFT') 477 - CALL OUTFMT(DOWN(3),2,AUX3,NC3,'LEFT') 478 - WRITE(LUNOUT,'(/'' Gravity vector: ('',A,'','',A,'','',A, 479 - - '') g.'')') AUX1(1:NC1),AUX2(1:NC2),AUX3(1:NC3) 480 - CALL OUTFMT(VMIN,2,AUX7,NC7,'RIGHT') 481 - CALL OUTFMT(VMAX,2,AUX8,NC8,'LEFT') 482 - IF(.NOT.POLAR)THEN 483 - CALL OUTFMT(XMIN,2,AUX1,NC1,'RIGHT') 484 - CALL OUTFMT(XMAX,2,AUX2,NC2,'LEFT') 485 - CALL OUTFMT(YMIN,2,AUX3,NC3,'RIGHT') 486 - CALL OUTFMT(YMAX,2,AUX4,NC4,'LEFT') 487 - CALL OUTFMT(ZMIN,2,AUX5,NC5,'RIGHT') 488 - CALL OUTFMT(ZMAX,2,AUX6,NC6,'LEFT') 489 - LMIN=LEN(AUX1)-MAX(NC1,NC3,NC5,NC7)+1 490 - RMAX=MAX(NC2,NC4,NC6,NC8) 491 - WRITE(LUNOUT,'(/'' Cell dimensions: '', 492 - - A,'' < x < '',A,'' cm,''/19X, 493 - - A,'' < y < '',A,'' cm,''/19X, 494 - - A,'' < z < '',A,'' cm.''// 495 - - '' Potential range: '', 496 - - A,'' < V < '',A,'' V.'')') 497 - - AUX1(LMIN:),AUX2(1:RMAX),AUX3(LMIN:),AUX4(1:RMAX), 498 - - AUX5(LMIN:),AUX6(1:RMAX),AUX7(LMIN:),AUX8(1:RMAX) 499 - ELSE 500 - CALL CFMRTP(XMIN,YMIN,XMINP,YMINP,1) 501 - CALL CFMRTP(XMAX,YMAX,XMAXP,YMAXP,1) 502 - CALL OUTFMT(XMINP,2,AUX1,NC1,'RIGHT') 503 - CALL OUTFMT(XMAXP,2,AUX2,NC2,'LEFT') 504 - CALL OUTFMT(YMINP,2,AUX3,NC3,'RIGHT') 505 - CALL OUTFMT(YMAXP,2,AUX4,NC4,'LEFT') 506 - CALL OUTFMT(ZMIN,2,AUX5,NC5,'RIGHT') 507 - CALL OUTFMT(ZMAX,2,AUX6,NC6,'LEFT') 508 - LMIN=LEN(AUX1)-MAX(NC1,NC3,NC5,NC7)+1 509 - RMAX=MAX(NC2,NC4,NC6,NC8) 510 - WRITE(LUNOUT,'(/'' Cell dimensions: '', 511 - - A,'' < r < '',A,'' cm,''/19X, 512 - - A,'' < phi < '',A,'' degrees,''/19X, 513 - - A,'' < z < '',A,'' cm.''// 514 - - '' Potential range: '', 515 - - A,'' < V < '',A,'' V.'')') 516 - - AUX1(LMIN:),AUX2(1:RMAX),AUX3(LMIN:),AUX4(1:RMAX), 517 - - AUX5(LMIN:),AUX6(1:RMAX),AUX7(LMIN:),AUX8(1:RMAX) 518 - ENDIF 519 - WRITE(LUNOUT,'(/'' The cell is of type '',A3,'' (code '',I2, 520 - - '', details can be found in the writeup.)'')') TYPE,ICTYPE 521 - * Print voltage shift in case no equipotential planes are present, 522 - IF(.NOT.(YNPLAN(1).OR.YNPLAN(2).OR. 523 - - YNPLAN(3).OR.YNPLAN(4).OR.TUBE))THEN 524 - CALL OUTFMT(V0,2,AUX1,NC1,'LEFT') 525 - WRITE(LUNOUT,'(/'' All voltages have been shifted by '', 526 - - A,'' V to avoid net wire charge.'')') AUX1(1:NC1) 527 - ELSE 528 - * else print the net charge on the wires. 529 - SUMCH=0.0 530 - DO 40 I=1,NWIRE 531 - SUMCH=SUMCH+E(I) 532 - 40 CONTINUE 533 - CALL OUTFMT(2.0E12*PI*EPS0*SUMCH,2,AUX1,NC1,'LEFT') 534 - WRITE(LUNOUT,'(/'' The net charge on the wires is '',A, 535 - - '' pC/cm.'')') AUX1(1:NC1) 536 - ENDIF 537 - *** Register the amount of CPU time used. 538 - CALL TIMLOG('Printing the cell properties: ') 539 - END 466 GARFIELD ================================================== P=CELL D=CELTYP 1 ============================ 0 + +DECK,CELTYP. 1 - SUBROUTINE CELTYP 2 - *----------------------------------------------------------------------- 3 - * CELTYP - Determines the cell type, see the writeup for explanations. 4 - * VARIABLES : no local variables. 5 - * (Last changed on 20/ 1/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,CONSTANTS. 11 - CHARACTER*10 USER 12 - INTEGER IFAIL 13 - *** Identify field maps. 14 - CALL BOOK('INQUIRE','MAP',USER,IFAIL) 15 - * Unable to tell: assume this isn't a field map. 16 - IF(IFAIL.NE.0)THEN 1 466 P=CELL D=CELTYP 2 PAGE 610 17 - PRINT *,' !!!!!! CELTYP WARNING : Unable to obtain'// 18 - - ' field map allocation information ; assumed to'// 19 - - ' be a non-field map cell.' 20 - * Field map chamber: ensure that there are no other elements. 21 - ELSEIF(USER.EQ.'CELL')THEN 22 - TYPE='MAP' 23 - GOTO 10 24 - ENDIF 25 - *** Provisionally handle all TUBE type cells via D00. 26 - IF(TUBE)THEN 27 - IF(NTUBE.EQ.0)THEN 28 - IF(PERY)THEN 29 - TYPE='D2 ' 30 - ELSE 31 - TYPE='D1 ' 32 - ENDIF 33 - ELSEIF(NTUBE.GE.3.AND.NTUBE.LE.8)THEN 34 - IF(PERY)THEN 35 - TYPE='D4 ' 36 - ELSE 37 - TYPE='D3 ' 38 - ENDIF 39 - ELSE 40 - PRINT *,' !!!!!! CELTYP WARNING : Potentials not yet'// 41 - - ' available, using a round tube.' 42 - NTUBE=0 43 - TYPE='D3 ' 44 - ENDIF 45 - GOTO 10 46 - ENDIF 47 - *** Find the 'A' type cell. 48 - IF(.NOT.(PERX.OR.PERY).AND. 49 - - .NOT.(YNPLAN(1).AND.YNPLAN(2)).AND. 50 - - .NOT.(YNPLAN(3).AND.YNPLAN(4)))THEN 51 - TYPE='A ' 52 - GOTO 10 53 - ENDIF 54 - *** Find the 'B1X' type cell. 55 - IF(PERX.AND..NOT.PERY.AND. 56 - - .NOT.(YNPLAN(1).OR.YNPLAN(2)).AND. 57 - - .NOT.(YNPLAN(3).AND.YNPLAN(4)))THEN 58 - TYPE='B1X' 59 - GOTO 10 60 - ENDIF 61 - *** Find the 'B1Y' type cell. 62 - IF(PERY.AND..NOT.PERX.AND. 63 - - .NOT.(YNPLAN(1).AND.YNPLAN(2)).AND. 64 - - .NOT.(YNPLAN(3).OR.YNPLAN(4)))THEN 65 - TYPE='B1Y' 66 - GOTO 10 67 - ENDIF 68 - *** Find the 'B2X' type cell. 69 - IF(PERX.AND..NOT.PERY.AND. 70 - - .NOT.(YNPLAN(3).AND.YNPLAN(4)))THEN 71 - TYPE='B2X' 72 - GOTO 10 73 - ENDIF 74 - IF(.NOT.(PERX.OR.PERY).AND. 75 - - .NOT.(YNPLAN(3).AND.YNPLAN(4)).AND. 76 - - (YNPLAN(1).AND.YNPLAN(2)))THEN 77 - SX=ABS(COPLAN(2)-COPLAN(1)) 78 - TYPE='B2X' 79 - GOTO 10 80 - ENDIF 81 - *** Find the 'B2Y' type cell. 82 - IF(PERY.AND..NOT.PERX.AND. 83 - - .NOT.(YNPLAN(1).AND.YNPLAN(2)))THEN 84 - TYPE='B2Y' 85 - GOTO 10 86 - ENDIF 87 - IF(.NOT.(PERX.OR.PERY).AND. 88 - - .NOT.(YNPLAN(1).AND.YNPLAN(2)).AND. 89 - - (YNPLAN(3).AND.YNPLAN(4)))THEN 90 - SY=ABS(COPLAN(4)-COPLAN(3)) 91 - TYPE='B2Y' 92 - GOTO 10 93 - ENDIF 94 - *** Find the 'C1 ' type cell. 95 - IF(.NOT.(YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4)).AND. 96 - - PERX.AND.PERY)THEN 97 - TYPE='C1 ' 98 - GOTO 10 99 - ENDIF 100 - *** Find the 'C2X' type cell. 101 - IF(.NOT.((YNPLAN(3).AND.PERY).OR.(YNPLAN(3).AND.YNPLAN(4))))THEN 102 - IF(YNPLAN(1).AND.YNPLAN(2))THEN 103 - SX=ABS(COPLAN(2)-COPLAN(1)) 104 - TYPE='C2X' 105 - GOTO 10 106 - ENDIF 107 - IF(PERX.AND.YNPLAN(1))THEN 108 - TYPE='C2X' 109 - GOTO 10 110 - ENDIF 111 - ENDIF 112 - *** Find the 'C2Y' type cell. 113 - IF(.NOT.((YNPLAN(1).AND.PERX).OR.(YNPLAN(1).AND.YNPLAN(2))))THEN 114 - IF(YNPLAN(3).AND.YNPLAN(4))THEN 115 - SY=ABS(COPLAN(4)-COPLAN(3)) 116 - TYPE='C2Y' 117 - GOTO 10 118 - ENDIF 119 - IF(PERY.AND.YNPLAN(3))THEN 120 - TYPE='C2Y' 121 - GOTO 10 122 - ENDIF 1 466 P=CELL D=CELTYP 3 PAGE 611 123 - ENDIF 124 - *** Find the 'C3 ' type cell. 125 - IF(PERX.AND.PERY)THEN 126 - TYPE='C3 ' 127 - GOTO 10 128 - ENDIF 129 - IF(PERX)THEN 130 - TYPE='C3 ' 131 - SY=ABS(COPLAN(4)-COPLAN(3)) 132 - GOTO 10 133 - ENDIF 134 - IF(PERY)THEN 135 - TYPE='C3 ' 136 - SX=ABS(COPLAN(2)-COPLAN(1)) 137 - GOTO 10 138 - ENDIF 139 - IF(YNPLAN(1).AND.YNPLAN(2).AND.YNPLAN(3).AND.YNPLAN(4))THEN 140 - TYPE='C3 ' 141 - SX=ABS(COPLAN(2)-COPLAN(1)) 142 - SY=ABS(COPLAN(4)-COPLAN(3)) 143 - GOTO 10 144 - ENDIF 145 - *** Fatal error if the cell is not recognised. 146 - PRINT *,' ###### CELTYP ERROR : Cell type not recognised ;', 147 - - ' fatal program bug - please send a message.' 148 - CALL QUIT 149 - 10 CONTINUE 150 - *** Make sure the periodicities are positive numbers. 151 - SX=ABS(SX) 152 - SY=ABS(SY) 153 - *** Store a numerical code for the cell type for greater efficiency. 154 - IF(TYPE.EQ.'MAP')ICTYPE=0 155 - IF(TYPE.EQ.'A ')ICTYPE=1 156 - IF(TYPE.EQ.'B1X')ICTYPE=2 157 - IF(TYPE.EQ.'B1Y')ICTYPE=3 158 - IF(TYPE.EQ.'B2X')ICTYPE=4 159 - IF(TYPE.EQ.'B2Y')ICTYPE=5 160 - IF(TYPE.EQ.'C1 ')ICTYPE=6 161 - IF(TYPE.EQ.'C2X')ICTYPE=7 162 - IF(TYPE.EQ.'C2Y')ICTYPE=8 163 - IF(TYPE.EQ.'C3 ')ICTYPE=9 164 - IF(TYPE.EQ.'D1 ')ICTYPE=10 165 - IF(TYPE.EQ.'D2 ')ICTYPE=11 166 - IF(TYPE.EQ.'D3 ')ICTYPE=12 167 - IF(TYPE.EQ.'D4 ')ICTYPE=13 168 - *** Store the amount of CPU time used for cell identification. 169 - CALL TIMLOG('Finding the cell type (A, B1X etc): ') 170 - END 467 GARFIELD ================================================== P=CELL D=CELVIE 1 ============================ 0 + +DECK,CELVIE. 1 - SUBROUTINE CELVIE(QXMIN,QYMIN,QZMIN,QXMAX,QYMAX,QZMAX) 2 - *----------------------------------------------------------------------- 3 - * CELVIE - Establishes viewing angles for the chamber. 4 - * (Last changed on 30/11/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,PARAMETERS. 11.- +SEQ,CONSTANTS. 12.- +SEQ,SOLIDS. 13.- +SEQ,FIELDMAP. 14 - CHARACTER*(MXCHAR) STRING,STRAUX 15 - CHARACTER*13 AUX1,AUX2,AUX3,AUX4,AUX5,AUX6 16 - CHARACTER*10 VARLIS(MXVAR) 17 - INTEGER MODVAR(MXVAR),MODRES(1),NCAUX,NRES,IENTRY,I,J,K,NWORD,NC, 18 - - IFAIL,IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5,IFAIL6,NCOLR, 19 - - INEXT,INPCMP,IEQ,IREF,IVOL,IERR,ICOL,NC1,NC2,NC3,NC4,NC5,NC6 20 - REAL VAR(MXVAR),RES(1),FRES(3,3,3),FXR,FYR,FZR,FNORM,AUXU(3), 21 - - AUXV(3),REFR,ABSR, 22 - - QXMIN,QYMIN,QZMIN,QXMAX,QYMAX,QZMAX, 23 - - QXMIND,QYMIND,QZMIND,QXMAXD,QYMAXD,QZMAXD, 24 - - QXMINR,QYMINR,QZMINR,QXMAXR,QYMAXR,QZMAXR 25 - DOUBLE PRECISION XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE),DET, 26 - - XAUX,YAUX,ZAUX 27 - LOGICAL USE(MXVAR),OK,FLAG(MXWORD+6),VIEW,PROJEC 28 - EXTERNAL INPCMP 29 - *** Find current number of arguments. 30 - CALL INPNUM(NWORD) 31 - *** Set default AREA parameters, in a format useful for printing. 32 - QXMIND=QXMIN 33 - QYMIND=QYMIN 34 - QZMIND=QZMIN 35 - QXMAXD=QXMAX 36 - QYMAXD=QYMAX 37 - QZMAXD=QZMAX 38 - IF(POLAR)CALL CFMRTP(QXMIND,QYMIND,QXMIND,QYMIND,1) 39 - IF(POLAR)CALL CFMRTP(QXMAXD,QYMAXD,QXMAXD,QYMAXD,1) 40 - *** Show current matrix if no arguments are given. 41 - IF(NWORD.EQ.1)THEN 42 - IF(LDEBUG)THEN 43 - WRITE(LUNOUT,'('' In-plane vector of current view: '', 44 - - 3E12.5)') (FPROJ(3,I),I=1,3) 45 - WRITE(LUNOUT,'('' u-vector in current view plane: '', 46 - - 3E12.5)') (FPROJ(1,I),I=1,3) 47 - WRITE(LUNOUT,'('' v-vector in current view plane: '', 48 - - 3E12.5)') (FPROJ(2,I),I=1,3) 49 - ENDIF 50 - CALL OUTFMT(QXMIND,2,AUX1,NC1,'RIGHT') 51 - CALL OUTFMT(QXMAXD,2,AUX2,NC2,'LEFT') 52 - CALL OUTFMT(QYMIND,2,AUX3,NC3,'RIGHT') 53 - CALL OUTFMT(QYMAXD,2,AUX4,NC4,'LEFT') 54 - CALL OUTFMT(QZMIND,2,AUX5,NC5,'RIGHT') 1 467 P=CELL D=CELVIE 2 PAGE 612 55 - CALL OUTFMT(QZMAXD,2,AUX6,NC6,'LEFT') 56 - IF(POLAR)THEN 57 - WRITE(LUNOUT,'('' The current area is '', 58 - - A13,'' < r < '',A13/22X, 59 - - A13,'' < phi < '',A13/ 60 - - '' [in cm and degrees] '', 61 - - A13,'' < z < '',A13)') 62 - - AUX1,AUX2,AUX3,AUX4,AUX5,AUX6 63 - ELSE 64 - WRITE(LUNOUT,'('' The current area is '', 65 - - A13,'' < x < '',A13/22X, 66 - - A13,'' < y < '',A13/ 67 - - '' [in cm] '', 68 - - A13,'' < z < '',A13)') 69 - - AUX1,AUX2,AUX3,AUX4,AUX5,AUX6 70 - ENDIF 71 - CALL OUTFMT(PROROT*180/PI,2,AUX1,NC1,'LEFT') 72 - WRITE(LUNOUT,'(/'' Current view plane: '',A,'' rotated '', 73 - - A,'' degrees''/'' Coordinate axes: u = '',A,'', '', 74 - - ''v = '',A)') PROLAB(1:NCFPRO),AUX1(1:NC1), 75 - - PXLAB(1:MAX(1,NCXLAB-10)),PYLAB(1:MAX(1,NCYLAB-10)) 76 - IF(PRVIEW.EQ.'X-Y')THEN 77 - WRITE(LUNOUT,'('' Plots show the x-y plane.'')') 78 - ELSEIF(PRVIEW.EQ.'X-Z')THEN 79 - WRITE(LUNOUT,'('' Plots show the x-z plane.'')') 80 - ELSEIF(PRVIEW.EQ.'Y-Z')THEN 81 - WRITE(LUNOUT,'('' Plots show the y-z plane.'')') 82 - ELSEIF(PRVIEW.EQ.'R-PHI')THEN 83 - WRITE(LUNOUT,'('' Plots show the r-phi plane.'')') 84 - ELSEIF(PRVIEW.EQ.'CUT')THEN 85 - WRITE(LUNOUT,'( 86 - - '' Plots show a cut at the above plane.'')') 87 - ELSEIF(PRVIEW.EQ.'3D')THEN 88 - WRITE(LUNOUT,'('' Plots show a 3D impression.'')') 89 - ELSE 90 - WRITE(LUNOUT,'('' ##### Unknown projection '', 91 - - A,''.'')') PRVIEW 92 - ENDIF 93 - CALL OUTFMT(PRPHIL*180/PI,2,AUX1,NC1,'LEFT') 94 - CALL OUTFMT(PRTHL*180/PI,2,AUX2,NC2,'LEFT') 95 - WRITE(LUNOUT,'(/'' Light source placed at phi = '',A, 96 - - '', theta = '',A,'' degrees,'')') 97 - - AUX1(1:NC1),AUX2(1:NC2) 98 - CALL OUTFMT((1-PRFABS)*PRFREF*100,2,AUX1,NC1,'LEFT') 99 - CALL OUTFMT((1-PRFABS)*(1-PRFREF)*100,2,AUX2,NC2,'LEFT') 100 - CALL OUTFMT(PRFABS*100,2,AUX3,NC3,'LEFT') 101 - WRITE(LUNOUT,'('' Of the light, '',A,'' % is absorbed, '', 102 - - A,'' % reflected and '',A,'' % diffused.'')') 103 - - AUX3(1:NC3),AUX1(1:NC1),AUX2(1:NC2) 104 - RETURN 105 - ENDIF 106 - *** First flag the keywords. 107 - DO 50 I=2,NWORD+6 108 - IF(INPCMP(I,'ROT#ATE')+INPCMP(I,'ROT#ATION-#ANGLE')+ 109 - - INPCMP(I,'X-Y')+INPCMP(I,'X-Z')+INPCMP(I,'Y-Z')+ 110 - - INPCMP(I,'R-PHI')+INPCMP(I,'CUT')+INPCMP(I,'3D')+ 111 - - INPCMP(I,'V#IEW')+INPCMP(I,'PL#ANE')+ 112 - - INPCMP(I,'LIGHT-#ORIGIN')+ 113 - - INPCMP(I,'REFL#ECTED-#FRACTION')+ 114 - - INPCMP(I,'ABS#ORBED-#FRACTION')+ 115 - - INPCMP(I,'COL#OURS')+ 116 - - INPCMP(I,'FULL-B#OX-#TICKMARKS')+ 117 - - INPCMP(I,'PART#IAL-B#OX-#TICKMARKS')+ 118 - - INPCMP(I,'FULL-T#UBE')+INPCMP(I,'PART#IAL-T#UBE')+ 119 - - INPCMP(I,'FULL-P#LANES')+INPCMP(I,'PART#IAL-P#LANES')+ 120 - - INPCMP(I,'SPL#IT-#INTERSECTING-#PLANES')+ 121 - - INPCMP(I,'NOSPL#IT-#INTERSECTING-#PLANES')+ 122 - - INPCMP(I,'SORT-#PLANES')+INPCMP(I,'NOSORT-#PLANES')+ 123 - - INPCMP(I,'OUT#LINE')+INPCMP(I,'NOOUT#LINE')+ 124 - - INPCMP(I,'PL#OT-MAP')+INPCMP(I,'NOPL#OT-MAP').NE.0)THEN 125 - FLAG(I)=.TRUE. 126 - ELSEIF(I.EQ.1.OR.I.GT.NWORD)THEN 127 - FLAG(I)=.TRUE. 128 - ELSE 129 - FLAG(I)=.FALSE. 130 - ENDIF 131 - 50 CONTINUE 132 - *** Get the area component, if specified. 133 - IF(NWORD.GE.7.AND..NOT.(FLAG(2).OR.FLAG(3).OR.FLAG(4).OR. 134 - - FLAG(5).OR.FLAG(6).OR.FLAG(7)))THEN 135 - CALL INPCHK(2,2,IFAIL1) 136 - CALL INPCHK(3,2,IFAIL2) 137 - CALL INPCHK(4,2,IFAIL3) 138 - CALL INPCHK(5,2,IFAIL4) 139 - CALL INPCHK(6,2,IFAIL5) 140 - CALL INPCHK(7,2,IFAIL6) 141 - CALL INPRDR(2,QXMINR,QXMIND) 142 - CALL INPRDR(3,QYMINR,QYMIND) 143 - CALL INPRDR(4,QZMINR,QZMIND) 144 - CALL INPRDR(5,QXMAXR,QXMAXD) 145 - CALL INPRDR(6,QYMAXR,QYMAXD) 146 - CALL INPRDR(7,QZMAXR,QZMAXD) 147 - INEXT=8 148 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. 149 - - IFAIL4.NE.0.OR.IFAIL5.NE.0.OR.IFAIL6.NE.0)THEN 150 - PRINT *,' !!!!!! CELVIE WARNING : AREA part', 151 - - ' ignored because of syntax errors.' 152 - GOTO 40 153 - ENDIF 154 - ELSEIF(NWORD.GE.5.AND..NOT.(FLAG(2).OR.FLAG(3).OR.FLAG(4).OR. 155 - - FLAG(5)))THEN 156 - CALL INPCHK(2,2,IFAIL1) 157 - CALL INPCHK(3,2,IFAIL2) 158 - CALL INPCHK(4,2,IFAIL3) 159 - CALL INPCHK(5,2,IFAIL4) 160 - CALL INPRDR(2,QXMINR,QXMIND) 1 467 P=CELL D=CELVIE 3 PAGE 613 161 - CALL INPRDR(3,QYMINR,QYMIND) 162 - CALL INPRDR(4,QXMAXR,QXMAXD) 163 - CALL INPRDR(5,QYMAXR,QYMAXD) 164 - QZMINR=QZMIND 165 - QZMAXR=QZMAXD 166 - INEXT=6 167 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR. 168 - - IFAIL3.NE.0.OR.IFAIL4.NE.0)THEN 169 - PRINT *,' !!!!!! CELVIE WARNING : AREA part'// 170 - - ' ignored because of syntax errors.' 171 - GOTO 40 172 - ENDIF 173 - ELSE 174 - INEXT=2 175 - GOTO 40 176 - ENDIF 177 - * Convert polar boundaries to internal coordinates. 178 - IFAIL1=0 179 - IFAIL2=0 180 - IF(POLAR)THEN 181 - CALL CFMPTR(QXMINR,QYMINR,QXMINR,QYMINR,1,IFAIL1) 182 - CALL CFMPTR(QXMAXR,QYMAXR,QXMAXR,QYMAXR,1,IFAIL2) 183 - ENDIF 184 - * Perform some elementary checks on these bounds. 185 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN 186 - PRINT *,' !!!!!! CELVIE WARNING : Incorrect area in'// 187 - - ' polar coordinates specified ; AREA is ignored.' 188 - ELSE 189 - IF(QXMINR.EQ.QXMAXR)THEN 190 - PRINT *,' !!!!!! CELVIE WARNING : Zero range'// 191 - - ' not permitted; x or r-part ignored.' 192 - ELSE 193 - QXMIN=MIN(QXMINR,QXMAXR) 194 - QXMAX=MAX(QXMINR,QXMAXR) 195 - ENDIF 196 - IF(QYMINR.EQ.QYMAXR)THEN 197 - PRINT *,' !!!!!! CELVIE WARNING : Zero range'// 198 - - ' not permitted; y or phi-part ignored.' 199 - ELSE 200 - QYMIN=MIN(QYMINR,QYMAXR) 201 - QYMAX=MAX(QYMINR,QYMAXR) 202 - ENDIF 203 - ENDIF 204 - IF(QZMINR.EQ.QZMAXR)THEN 205 - PRINT *,' !!!!!! CELVIE WARNING : Zero range'// 206 - - ' not permitted; z-part ignored.' 207 - ELSE 208 - QZMIN=MIN(QZMINR,QZMAXR) 209 - QZMAX=MAX(QZMINR,QZMAXR) 210 - ENDIF 211 - * Assign them to the graphics area. 212 - GXMIN=QXMIN 213 - GYMIN=QYMIN 214 - GZMIN=QZMIN 215 - GXMAX=QXMAX 216 - GYMAX=QYMAX 217 - GZMAX=QZMAX 218 - *** Get the other options. 219 - 40 CONTINUE 220 - *** Default options. 221 - VIEW=.FALSE. 222 - PROJEC=.FALSE. 223 - *** Search for further arguments. 224 - DO 10 I=2,NWORD 225 - IF(I.LT.INEXT)GOTO 10 226 - ** Viewing plane. 227 - IF(INPCMP(I,'V#IEW')+INPCMP(I,'PL#ANE').NE.0)THEN 228 - * Ensure a definition is present. 229 - IF(FLAG(I+1))THEN 230 - CALL INPMSG(I,'Plane is missing.') 231 - GOTO 10 232 - ENDIF 233 - * Check the format. 234 - CALL INPSTR(I+1,I+1,STRING,NC) 235 - IF(INDEX(STRING(1:NC),'=').EQ.0.AND.I+2.GT.NWORD)THEN 236 - CALL INPMSG(I+1,'Incomplete formula.') 237 - VIEW=.FALSE. 238 - ELSEIF(INDEX(STRING(1:NC),'=').EQ.0)THEN 239 - CALL INPSTR(I+1,I+2,STRING,NC) 240 - INEXT=I+3 241 - VIEW=.TRUE. 242 - ELSE 243 - INEXT=I+2 244 - VIEW=.TRUE. 245 - ENDIF 246 - IEQ=INDEX(STRING(1:NC),'=') 247 - IF(IEQ.EQ.0.OR.IEQ.GE.LEN(STRING).OR.IEQ.GE.NC)THEN 248 - CALL INPMSG(I+1,'= sign missing or misplaced.') 249 - VIEW=.FALSE. 250 - ENDIF 251 - * Replace the "=" sign. 252 - IF(VIEW)THEN 253 - STRAUX=STRING(IEQ+1:) 254 - NCAUX=NC-IEQ 255 - STRING(IEQ:)='-('//STRAUX(1:NCAUX)//')' 256 - NC=IEQ+NCAUX+2 257 - ENDIF 258 - * Reset the rotation. 259 - PROROT=0 260 - ** Rotation of the local coordinate frame. 261 - ELSEIF(INPCMP(I,'ROT#ATE')+ 262 - - INPCMP(I,'ROT#ATION-#ANGLE').NE.0)THEN 263 - IF(NWORD.LT.I+1)THEN 264 - CALL INPMSG(I,'Argument missing.') 265 - ELSE 266 - CALL INPCHK(I+1,2,IFAIL) 1 467 P=CELL D=CELVIE 4 PAGE 614 267 - IF(IFAIL.EQ.0)THEN 268 - CALL INPRDR(I+1,PROROT,0.0) 269 - PROROT=PI*PROROT/180 270 - ENDIF 271 - INEXT=I+2 272 - ENDIF 273 - ** Traditional x-y, x-z, y-z and r-phi plots. 274 - ELSEIF(INPCMP(I,'X-Y').NE.0)THEN 275 - IF(POLAR)THEN 276 - CALL INPMSG(I,'The cell is polar.') 277 - ELSE 278 - PRVIEW='X-Y' 279 - PROJEC=.TRUE. 280 - FPROJ(1,1)=1 281 - FPROJ(1,2)=0 282 - FPROJ(1,3)=0 283 - FPROJ(2,1)=0 284 - FPROJ(2,2)=1 285 - FPROJ(2,3)=0 286 - FPROJ(3,1)=0 287 - FPROJ(3,2)=0 288 - FPROJ(3,3)=0 289 - PXLAB='x-Axis [cm]' 290 - NCXLAB=11 291 - PYLAB='y-Axis [cm]' 292 - NCYLAB=11 293 - PROLAB='x-y' 294 - NCFPRO=3 295 - FPROJA=0 296 - FPROJB=0 297 - FPROJC=1 298 - FPROJD=0 299 - FPROJN=1 300 - PROROT=0 301 - ENDIF 302 - ELSEIF(INPCMP(I,'X-Z').NE.0)THEN 303 - IF(POLAR)THEN 304 - CALL INPMSG(I,'The cell is polar.') 305 - ELSE 306 - PRVIEW='X-Z' 307 - PROJEC=.TRUE. 308 - FPROJ(1,1)=1 309 - FPROJ(1,2)=0 310 - FPROJ(1,3)=0 311 - FPROJ(2,1)=0 312 - FPROJ(2,2)=0 313 - FPROJ(2,3)=1 314 - FPROJ(3,1)=0 315 - FPROJ(3,2)=0 316 - FPROJ(3,3)=0 317 - PXLAB='x-Axis [cm]' 318 - NCXLAB=11 319 - PYLAB='z-Axis [cm]' 320 - NCYLAB=11 321 - PROLAB='x-z' 322 - NCFPRO=3 323 - FPROJA=0 324 - FPROJB=1 325 - FPROJC=0 326 - FPROJD=0 327 - FPROJN=1 328 - PROROT=0 329 - ENDIF 330 - ELSEIF(INPCMP(I,'Y-Z').NE.0)THEN 331 - IF(POLAR)THEN 332 - CALL INPMSG(I,'The cell is polar.') 333 - ELSE 334 - PRVIEW='Y-Z' 335 - PROJEC=.TRUE. 336 - FPROJ(1,1)=0 337 - FPROJ(1,2)=1 338 - FPROJ(1,3)=0 339 - FPROJ(2,1)=0 340 - FPROJ(2,2)=0 341 - FPROJ(2,3)=1 342 - FPROJ(3,1)=0 343 - FPROJ(3,2)=0 344 - FPROJ(3,3)=0 345 - PXLAB='y-Axis [cm]' 346 - NCXLAB=11 347 - PYLAB='z-Axis [cm]' 348 - NCYLAB=11 349 - PROLAB='y-z' 350 - NCFPRO=3 351 - FPROJA=1 352 - FPROJB=0 353 - FPROJC=0 354 - FPROJD=0 355 - FPROJN=1 356 - PROROT=0 357 - ENDIF 358 - ELSEIF(INPCMP(I,'R-PHI').NE.0)THEN 359 - IF(POLAR)THEN 360 - PRVIEW='R-PHI' 361 - PROJEC=.TRUE. 362 - FPROJ(1,1)=1 363 - FPROJ(1,2)=0 364 - FPROJ(1,3)=0 365 - FPROJ(2,1)=0 366 - FPROJ(2,2)=1 367 - FPROJ(2,3)=0 368 - FPROJ(3,1)=0 369 - FPROJ(3,2)=0 370 - FPROJ(3,3)=0 371 - PXLAB='r-Axis [cm]' 372 - NCXLAB=11 1 467 P=CELL D=CELVIE 5 PAGE 615 373 - PYLAB='phi-Axis [degrees]' 374 - NCYLAB=18 375 - PROLAB='r-phi' 376 - NCFPRO=5 377 - FPROJA=0 378 - FPROJB=0 379 - FPROJC=1 380 - FPROJD=0 381 - FPROJN=1 382 - PROROT=0 383 - ELSE 384 - CALL INPMSG(I,'The cell is not polar') 385 - ENDIF 386 - ** Plot as a cut. 387 - ELSEIF(INPCMP(I,'CUT').NE.0)THEN 388 - IF(POLAR)THEN 389 - CALL INPMSG(I,'The cell is polar.') 390 - ELSE 391 - PRVIEW='CUT' 392 - PROJEC=.TRUE. 393 - ENDIF 394 - ** Plot in 3D. 395 - ELSEIF(INPCMP(I,'3D').NE.0)THEN 396 - IF(POLAR)THEN 397 - CALL INPMSG(I,'The cell is polar.') 398 - ELSE 399 - PRVIEW='3D' 400 - PROJEC=.TRUE. 401 - ENDIF 402 - ** Set the light origin relative to the normal vector. 403 - ELSEIF(INPCMP(I,'LIGHT-#ORIGIN').NE.0)THEN 404 - IF(NWORD.LT.I+2)THEN 405 - CALL INPMSG(I,'Arguments missing.') 406 - ELSE 407 - CALL INPCHK(I+1,2,IFAIL1) 408 - CALL INPCHK(I+2,2,IFAIL2) 409 - CALL INPRDR(I+1,PRPHIL,0.0) 410 - CALL INPRDR(I+2,PRTHL,30.0) 411 - PRPHIL=PRPHIL*PI/180.0 412 - PRTHL=PRTHL*PI/180.0 413 - INEXT=I+3 414 - ENDIF 415 - ** Set the reflection component. 416 - ELSEIF(INPCMP(I,'REFL#ECTED-#FRACTION').NE.0)THEN 417 - IF(NWORD.LT.I+1)THEN 418 - CALL INPMSG(I,'Arguments missing.') 419 - ELSE 420 - CALL INPCHK(I+1,2,IFAIL1) 421 - CALL INPRDR(I+1,REFR,PRFREF*100) 422 - IF(REFR.LT.0.OR.REFR.GT.100)THEN 423 - CALL INPMSG(I+1,'Fraction out of range [0,100].') 424 - ELSE 425 - PRFREF=REFR/100 426 - ENDIF 427 - INEXT=I+2 428 - ENDIF 429 - ** Set the absorbed component. 430 - ELSEIF(INPCMP(I,'ABS#ORBED-#FRACTION').NE.0)THEN 431 - IF(NWORD.LT.I+1)THEN 432 - CALL INPMSG(I,'Arguments missing.') 433 - ELSE 434 - CALL INPCHK(I+1,2,IFAIL1) 435 - CALL INPRDR(I+1,ABSR,PRFABS*100) 436 - IF(ABSR.LT.0.OR.ABSR.GT.100)THEN 437 - CALL INPMSG(I+1,'Fraction out of range [0,100].') 438 - ELSE 439 - PRFABS=ABSR/100 440 - ENDIF 441 - INEXT=I+2 442 - ENDIF 443 - ** Set the number of colours in the shading tables. 444 - ELSEIF(INPCMP(I,'COL#OURS').NE.0)THEN 445 - IF(NWORD.LT.I+1)THEN 446 - CALL INPMSG(I,'Arguments missing.') 447 - ELSE 448 - CALL INPCHK(I+1,1,IFAIL1) 449 - CALL INPRDI(I+1,NCOLR,NPRCOL) 450 - IF(NCOLR.LE.1)THEN 451 - CALL INPMSG(I+1,'Number of colours < 2.') 452 - ELSE 453 - NPRCOL=NCOLR 454 - ENDIF 455 - INEXT=I+2 456 - ENDIF 457 - ** Draw full boxes, tube and planes or not. 458 - ELSEIF(INPCMP(I,'FULL-B#OX-#TICKMARKS').NE.0)THEN 459 - LFULLB=.TRUE. 460 - ELSEIF(INPCMP(I,'PART#IAL-B#OX-#TICKMARKS').NE.0)THEN 461 - LFULLB=.FALSE. 462 - ELSEIF(INPCMP(I,'FULL-T#UBE').NE.0)THEN 463 - LFULLT=.TRUE. 464 - ELSEIF(INPCMP(I,'PART#IAL-T#UBE').NE.0)THEN 465 - LFULLT=.FALSE. 466 - ELSEIF(INPCMP(I,'FULL-P#LANES').NE.0)THEN 467 - LFULLP=.TRUE. 468 - ELSEIF(INPCMP(I,'PART#IAL-P#LANES').NE.0)THEN 469 - LFULLP=.FALSE. 470 - ELSEIF(INPCMP(I,'SPL#IT-#INTERSECTING-#PLANES').NE.0)THEN 471 - LSPLIT=.TRUE. 472 - ELSEIF(INPCMP(I,'NOSPL#IT-#INTERSECTING-#PLANES').NE.0)THEN 473 - LSPLIT=.FALSE. 474 - ELSEIF(INPCMP(I,'SORT-#PLANES').NE.0)THEN 475 - LSORT=.TRUE. 476 - ELSEIF(INPCMP(I,'NOSORT-#PLANES').NE.0)THEN 477 - LSORT=.FALSE. 478 - ELSEIF(INPCMP(I,'OUT#LINE').NE.0)THEN 1 467 P=CELL D=CELVIE 6 PAGE 616 479 - LOUTL=.TRUE. 480 - ELSEIF(INPCMP(I,'NOOUT#LINE').NE.0)THEN 481 - LOUTL=.FALSE. 482 - ELSEIF(INPCMP(I,'PL#OT-MAP').NE.0)THEN 483 - LMAPPL=.TRUE. 484 - ELSEIF(INPCMP(I,'NOPL#OT-MAP').NE.0)THEN 485 - LMAPPL=.FALSE. 486 - ELSEIF(INPCMP(I,'STEP').NE.0)THEN 487 - LGSTEP=.TRUE. 488 - ELSEIF(INPCMP(I,'NOSTEP').NE.0)THEN 489 - LGSTEP=.FALSE. 490 - * Other keywords not known. 491 - ELSE 492 - CALL INPMSG(I,'Not a known option.') 493 - ENDIF 494 - 10 CONTINUE 495 - *** R-PHI projection always and only in polar cells. 496 - IF(POLAR.AND.PRVIEW.NE.'R-PHI')THEN 497 - PRINT *,' !!!!!! CELVIE WARNING : Only the r-phi view is'// 498 - - ' available in polar cells; VIEW ignored.' 499 - RETURN 500 - ELSEIF(.NOT.POLAR.AND.PRVIEW.EQ.'R-PHI')THEN 501 - PRINT *,' !!!!!! CELVIE WARNING : The r-phi view is'// 502 - - ' only available in polar cells; VIEW ignored.' 503 - RETURN 504 - ENDIF 505 - *** Set a projection if not explicitely done. 506 - IF(VIEW.AND.(.NOT.PROJEC).AND.(PRVIEW.NE.'3D'))PRVIEW='CUT' 507 - *** Progress printing. 508 - IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROINT('AREA',1,6) 509 - *** If no formula was given, skip most of the rest. 510 - IF(.NOT.VIEW)GOTO 1000 511 - IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')THEN 512 - CALL PROFLD(1,'Processing formula',-1.0) 513 - CALL PROSTA(1,0.0) 514 - ENDIF 515 - *** Translate the formula. 516 - VARLIS(1)='X' 517 - VARLIS(2)='Y' 518 - VARLIS(3)='Z' 519 - CALL ALGPRE(STRING(1:NC),NC,VARLIS,3,NRES,USE,IENTRY,IFAIL) 520 - * Check the results. 521 - IF(IFAIL.NE.0)THEN 522 - CALL INPMSG(2,'Formula not translatable.') 523 - CALL ALGCLR(IENTRY) 524 - IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND 525 - RETURN 526 - ELSEIF(NRES.NE.1)THEN 527 - CALL INPMSG(2,'Does not return 1 result.') 528 - CALL ALGCLR(IENTRY) 529 - IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND 530 - RETURN 531 - ELSEIF(.NOT.(USE(1).OR.USE(2).OR.USE(3)))THEN 532 - CALL INPMSG(2,'Does not depend on x, y or z.') 533 - CALL ALGCLR(IENTRY) 534 - IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND 535 - RETURN 536 - ENDIF 537 - *** Compute function values at a (3x3) set of points. 538 - OK=.TRUE. 539 - MODVAR(1)=2 540 - MODVAR(2)=2 541 - MODVAR(3)=2 542 - DO 80 I=-1,1 543 - DO 90 J=-1,1 544 - DO 100 K=-1,1 545 - VAR(1)=0.5*(XMIN+XMAX)+I*(1+ABS(XMIN)+ABS(XMAX)) 546 - VAR(2)=0.5*(YMIN+YMAX)+J*(1+ABS(YMIN)+ABS(YMAX)) 547 - VAR(3)=0.5*(ZMIN+ZMAX)+K*(1+ABS(ZMIN)+ABS(ZMAX)) 548 - CALL ALGEXE(IENTRY,VAR,MODVAR,3,RES,MODRES,1,IFAIL) 549 - IF(IFAIL.NE.0.OR.MODRES(1).NE.2)OK=.FALSE. 550 - FRES(2+I,2+J,2+K)=RES(1) 551 - 100 CONTINUE 552 - 90 CONTINUE 553 - 80 CONTINUE 554 - * Ensure that all function evaluations worked. 555 - IF(.NOT.OK)THEN 556 - CALL INPMSG(2,'Formula can not be evaluated.') 557 - CALL ALGCLR(IENTRY) 558 - IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND 559 - RETURN 560 - ENDIF 561 - *** Extract parameters. 562 - FXR=((FRES(3,1,1)-FRES(1,1,1))+ 563 - - (FRES(3,1,2)-FRES(1,1,2))+ 564 - - (FRES(3,2,1)-FRES(1,2,1))+ 565 - - (FRES(3,2,2)-FRES(1,2,2)))/(8*(1+ABS(XMIN)+ABS(XMAX))) 566 - FYR=((FRES(1,3,1)-FRES(1,1,1))+ 567 - - (FRES(1,3,2)-FRES(1,1,2))+ 568 - - (FRES(2,3,1)-FRES(2,1,1))+ 569 - - (FRES(2,3,2)-FRES(2,1,2)))/(8*(1+ABS(YMIN)+ABS(YMAX))) 570 - FZR=((FRES(1,1,3)-FRES(1,1,1))+ 571 - - (FRES(1,2,3)-FRES(1,2,1))+ 572 - - (FRES(2,1,3)-FRES(2,1,1))+ 573 - - (FRES(2,2,3)-FRES(2,2,1)))/(8*(1+ABS(ZMIN)+ABS(ZMAX))) 574 - * Check the linearity and extract parameters. 575 - IF(ABS(FXR-0.5*(FRES(3,1,1)-FRES(1,1,1))/ 576 - - (1+ABS(XMIN)+ABS(XMAX))).GT.1E-4*(1+ABS(FXR)).OR. 577 - - ABS(FXR-0.5*(FRES(3,1,2)-FRES(1,1,2))/ 578 - - (1+ABS(XMIN)+ABS(XMAX))).GT.1E-4*(1+ABS(FXR)).OR. 579 - - ABS(FXR-0.5*(FRES(3,2,1)-FRES(1,2,1))/ 580 - - (1+ABS(XMIN)+ABS(XMAX))).GT.1E-4*(1+ABS(FXR)).OR. 581 - - ABS(FXR-0.5*(FRES(3,2,2)-FRES(1,2,2))/ 582 - - (1+ABS(XMIN)+ABS(XMAX))).GT.1E-4*(1+ABS(FXR)).OR. 583 - - ABS(FYR-0.5*(FRES(1,3,1)-FRES(1,1,1))/ 584 - - (1+ABS(YMIN)+ABS(YMAX))).GT.1E-4*(1+ABS(FYR)).OR. 1 467 P=CELL D=CELVIE 7 PAGE 617 585 - - ABS(FYR-0.5*(FRES(1,3,2)-FRES(1,1,2))/ 586 - - (1+ABS(YMIN)+ABS(YMAX))).GT.1E-4*(1+ABS(FYR)).OR. 587 - - ABS(FYR-0.5*(FRES(2,3,1)-FRES(2,1,1))/ 588 - - (1+ABS(YMIN)+ABS(YMAX))).GT.1E-4*(1+ABS(FYR)).OR. 589 - - ABS(FYR-0.5*(FRES(2,3,2)-FRES(2,1,2))/ 590 - - (1+ABS(YMIN)+ABS(YMAX))).GT.1E-4*(1+ABS(FYR)).OR. 591 - - ABS(FZR-0.5*(FRES(1,1,3)-FRES(1,1,1))/ 592 - - (1+ABS(ZMIN)+ABS(ZMAX))).GT.1E-4*(1+ABS(FZR)).OR. 593 - - ABS(FZR-0.5*(FRES(1,2,3)-FRES(1,2,1))/ 594 - - (1+ABS(ZMIN)+ABS(ZMAX))).GT.1E-4*(1+ABS(FZR)).OR. 595 - - ABS(FZR-0.5*(FRES(2,1,3)-FRES(2,1,1))/ 596 - - (1+ABS(ZMIN)+ABS(ZMAX))).GT.1E-4*(1+ABS(FZR)).OR. 597 - - ABS(FZR-0.5*(FRES(2,2,3)-FRES(2,2,1))/ 598 - - (1+ABS(ZMIN)+ABS(ZMAX))).GT.1E-4*(1+ABS(FZR)))THEN 599 - CALL INPMSG(2,'Formula is not linear.') 600 - CALL ALGCLR(IENTRY) 601 - IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND 602 - RETURN 603 - ENDIF 604 - *** Establish perpendicular vectors. 605 - FNORM=SQRT(FXR**2+FYR**2+FZR**2) 606 - IF(FXR**2+FZR**2.GT.0)THEN 607 - FPROJ(1,1)= FZR/SQRT(FXR**2+FZR**2) 608 - FPROJ(1,2)= 0 609 - FPROJ(1,3)=-FXR/SQRT(FXR**2+FZR**2) 610 - FPROJ(2,1)=-FXR*FYR/(SQRT(FXR**2+FZR**2)*FNORM) 611 - FPROJ(2,2)= (FXR**2+FZR**2)/(SQRT(FXR**2+FZR**2)*FNORM) 612 - FPROJ(2,3)=-FYR*FZR/(SQRT(FXR**2+FZR**2)*FNORM) 613 - FPROJ(3,1)= FXR 614 - FPROJ(3,2)= FYR 615 - FPROJ(3,3)= FZR 616 - ELSEIF(FYR**2+FZR**2.GT.0)THEN 617 - FPROJ(1,1)= (FYR**2+FZR**2)/(SQRT(FYR**2+FZR**2)*FNORM) 618 - FPROJ(1,2)=-FXR*FZR/(SQRT(FYR**2+FZR**2)*FNORM) 619 - FPROJ(1,3)=-FYR*FZR/(SQRT(FYR**2+FZR**2)*FNORM) 620 - FPROJ(2,1)= 0 621 - FPROJ(2,2)= FZR/SQRT(FYR**2+FZR**2) 622 - FPROJ(2,3)=-FYR/SQRT(FYR**2+FZR**2) 623 - FPROJ(3,1)= FXR 624 - FPROJ(3,2)= FYR 625 - FPROJ(3,3)= FZR 626 - ELSE 627 - CALL INPMSG(2,'Does not describe a plane.') 628 - CALL INPMSG(3,'See previous message.') 629 - CALL INPMSG(4,'See previous message.') 630 - CALL ALGCLR(IENTRY) 631 - IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND 632 - CALL PLAINT 633 - IF(POLAR)THEN 634 - PRVIEW='R-PHI' 635 - ELSE 636 - PRVIEW='X-Y' 637 - ENDIF 638 - RETURN 639 - ENDIF 640 - *** Rotate the vectors. 641 - DO 20 I=1,3 642 - AUXU(I)=COS(PROROT)*FPROJ(1,I)-SIN(PROROT)*FPROJ(2,I) 643 - AUXV(I)=SIN(PROROT)*FPROJ(1,I)+COS(PROROT)*FPROJ(2,I) 644 - 20 CONTINUE 645 - DO 30 I=1,3 646 - FPROJ(1,I)=AUXU(I) 647 - FPROJ(2,I)=AUXV(I) 648 - 30 CONTINUE 649 - *** Normalise the in-plane vector. 650 - VAR(1)=0 651 - VAR(2)=0 652 - VAR(3)=0 653 - CALL ALGEXE(IENTRY,VAR,MODVAR,3,RES,MODRES,1,IFAIL) 654 - IF(IFAIL.NE.0.OR.MODRES(1).NE.2)THEN 655 - CALL INPMSG(2,'Unable to compute the norm.') 656 - CALL ALGCLR(IENTRY) 657 - IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND 658 - CALL PLAINT 659 - IF(POLAR)THEN 660 - PRVIEW='R-PHI' 661 - ELSE 662 - PRVIEW='X-Y' 663 - ENDIF 664 - RETURN 665 - ENDIF 666 - FPROJ(3,1)=-RES(1)*FPROJ(3,1)/FNORM**2 667 - FPROJ(3,2)=-RES(1)*FPROJ(3,2)/FNORM**2 668 - FPROJ(3,3)=-RES(1)*FPROJ(3,3)/FNORM**2 669 - *** Store the plane parameters. 670 - FPROJA=FXR 671 - FPROJB=FYR 672 - FPROJC=FZR 673 - FPROJN=FNORM 674 - FPROJD=-RES(1) 675 - *** Delete the entry point. 676 - CALL ALGCLR(IENTRY) 677 - *** Format the x-axis label. 678 - IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')THEN 679 - CALL PROFLD(1,'Formatting labels',-1.0) 680 - CALL PROSTA(1,0.0) 681 - ENDIF 682 - NCXLAB=0 683 - PXLAB=' ' 684 - IF(ABS(FPROJ(1,1)-1).LE.1E-4)THEN 685 - PXLAB(NCXLAB+1:NCXLAB+1)='x' 686 - NCXLAB=NCXLAB+1 687 - ELSEIF(ABS(FPROJ(1,1)+1).LE.1E-4)THEN 688 - PXLAB(NCXLAB+1:NCXLAB+2)='-x' 689 - NCXLAB=NCXLAB+2 690 - ELSEIF(FPROJ(1,1).GT.1E-4)THEN 1 467 P=CELL D=CELVIE 8 PAGE 618 691 - CALL OUTFMT(REAL(FPROJ(1,1)),2,STRAUX,NCAUX,'LEFT') 692 - PXLAB(NCXLAB+1:NCXLAB+2+NCAUX)=STRAUX(1:NCAUX)//'*x' 693 - NCXLAB=NCXLAB+2+NCAUX 694 - ELSEIF(FPROJ(1,1).LT.-1E-4)THEN 695 - CALL OUTFMT(REAL(-FPROJ(1,1)),2,STRAUX,NCAUX,'LEFT') 696 - PXLAB(NCXLAB+1:NCXLAB+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*x' 697 - NCXLAB=NCXLAB+3+NCAUX 698 - ENDIF 699 - IF(ABS(FPROJ(1,2)-1).LE.1E-4)THEN 700 - IF(NCXLAB.EQ.0)THEN 701 - PXLAB(NCXLAB+1:NCXLAB+1)='y' 702 - NCXLAB=NCXLAB+1 703 - ELSE 704 - PXLAB(NCXLAB+1:NCXLAB+2)='+y' 705 - NCXLAB=NCXLAB+2 706 - ENDIF 707 - ELSEIF(ABS(FPROJ(1,2)+1).LE.1E-4)THEN 708 - PXLAB(NCXLAB+1:NCXLAB+2)='-y' 709 - NCXLAB=NCXLAB+2 710 - ELSEIF(FPROJ(1,2).GT.1E-4)THEN 711 - CALL OUTFMT(REAL(FPROJ(1,2)),2,STRAUX,NCAUX,'LEFT') 712 - IF(NCXLAB.EQ.0)THEN 713 - PXLAB(NCXLAB+1:NCXLAB+2+NCAUX)=STRAUX(1:NCAUX)//'*y' 714 - NCXLAB=NCXLAB+2+NCAUX 715 - ELSE 716 - PXLAB(NCXLAB+1:NCXLAB+3+NCAUX)='+'// 717 - - STRAUX(1:NCAUX)//'*y' 718 - NCXLAB=NCXLAB+3+NCAUX 719 - ENDIF 720 - ELSEIF(FPROJ(1,2).LT.-1E-4)THEN 721 - CALL OUTFMT(REAL(-FPROJ(1,2)),2,STRAUX,NCAUX,'LEFT') 722 - PXLAB(NCXLAB+1:NCXLAB+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*y' 723 - NCXLAB=NCXLAB+3+NCAUX 724 - ENDIF 725 - IF(ABS(FPROJ(1,3)-1).LE.1E-4)THEN 726 - IF(NCXLAB.EQ.0)THEN 727 - PXLAB(NCXLAB+1:NCXLAB+1)='z' 728 - NCXLAB=NCXLAB+1 729 - ELSE 730 - PXLAB(NCXLAB+1:NCXLAB+2)='+z' 731 - NCXLAB=NCXLAB+2 732 - ENDIF 733 - ELSEIF(ABS(FPROJ(1,3)+1).LE.1E-4)THEN 734 - PXLAB(NCXLAB+1:NCXLAB+2)='-z' 735 - NCXLAB=NCXLAB+2 736 - ELSEIF(FPROJ(1,3).GT.1E-4)THEN 737 - CALL OUTFMT(REAL(FPROJ(1,3)),2,STRAUX,NCAUX,'LEFT') 738 - IF(NCXLAB.EQ.0)THEN 739 - PXLAB(NCXLAB+1:NCXLAB+2+NCAUX)=STRAUX(1:NCAUX)//'*z' 740 - NCXLAB=NCXLAB+2+NCAUX 741 - ELSE 742 - PXLAB(NCXLAB+1:NCXLAB+3+NCAUX)='+'// 743 - - STRAUX(1:NCAUX)//'*z' 744 - NCXLAB=NCXLAB+3+NCAUX 745 - ENDIF 746 - ELSEIF(FPROJ(1,3).LT.-1E-4)THEN 747 - CALL OUTFMT(REAL(-FPROJ(1,3)),2,STRAUX,NCAUX,'LEFT') 748 - PXLAB(NCXLAB+1:NCXLAB+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*z' 749 - NCXLAB=NCXLAB+3+NCAUX 750 - ENDIF 751 - PXLAB(NCXLAB+1:NCXLAB+10)=' Axis [cm]' 752 - IF(NCXLAB.EQ.1)PXLAB(2:2)='-' 753 - NCXLAB=NCXLAB+10 754 - * Format the y-axis label. 755 - NCYLAB=0 756 - PYLAB=' ' 757 - IF(ABS(FPROJ(2,1)-1).LE.1E-4)THEN 758 - PYLAB(NCYLAB+1:NCYLAB+1)='x' 759 - NCYLAB=NCYLAB+1 760 - ELSEIF(ABS(FPROJ(2,1)+1).LE.1E-4)THEN 761 - PYLAB(NCYLAB+1:NCYLAB+2)='-x' 762 - NCYLAB=NCYLAB+2 763 - ELSEIF(FPROJ(2,1).GT.1E-4)THEN 764 - CALL OUTFMT(REAL(FPROJ(2,1)),2,STRAUX,NCAUX,'LEFT') 765 - PYLAB(NCYLAB+1:NCYLAB+2+NCAUX)=STRAUX(1:NCAUX)//'*x' 766 - NCYLAB=NCYLAB+2+NCAUX 767 - ELSEIF(FPROJ(2,1).LT.-1E-4)THEN 768 - CALL OUTFMT(REAL(-FPROJ(2,1)),2,STRAUX,NCAUX,'LEFT') 769 - PYLAB(NCYLAB+1:NCYLAB+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*x' 770 - NCYLAB=NCYLAB+3+NCAUX 771 - ENDIF 772 - IF(ABS(FPROJ(2,2)-1).LE.1E-4)THEN 773 - IF(NCYLAB.EQ.0)THEN 774 - PYLAB(NCYLAB+1:NCYLAB+1)='y' 775 - NCYLAB=NCYLAB+1 776 - ELSE 777 - PYLAB(NCYLAB+1:NCYLAB+2)='+y' 778 - NCYLAB=NCYLAB+2 779 - ENDIF 780 - ELSEIF(ABS(FPROJ(2,2)+1).LE.1E-4)THEN 781 - PYLAB(NCYLAB+1:NCYLAB+2)='-y' 782 - NCYLAB=NCYLAB+2 783 - ELSEIF(FPROJ(2,2).GT.1E-4)THEN 784 - CALL OUTFMT(REAL(FPROJ(2,2)),2,STRAUX,NCAUX,'LEFT') 785 - IF(NCYLAB.EQ.0)THEN 786 - PYLAB(NCYLAB+1:NCYLAB+2+NCAUX)=STRAUX(1:NCAUX)//'*y' 787 - NCYLAB=NCYLAB+2+NCAUX 788 - ELSE 789 - PYLAB(NCYLAB+1:NCYLAB+3+NCAUX)='+'// 790 - - STRAUX(1:NCAUX)//'*y' 791 - NCYLAB=NCYLAB+3+NCAUX 792 - ENDIF 793 - ELSEIF(FPROJ(2,2).LT.-1E-4)THEN 794 - CALL OUTFMT(REAL(-FPROJ(2,2)),2,STRAUX,NCAUX,'LEFT') 795 - PYLAB(NCYLAB+1:NCYLAB+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*y' 796 - NCYLAB=NCYLAB+3+NCAUX 1 467 P=CELL D=CELVIE 9 PAGE 619 797 - ENDIF 798 - IF(ABS(FPROJ(2,3)-1).LE.1E-4)THEN 799 - IF(NCYLAB.EQ.0)THEN 800 - PYLAB(NCYLAB+1:NCYLAB+1)='z' 801 - NCYLAB=NCYLAB+1 802 - ELSE 803 - PYLAB(NCYLAB+1:NCYLAB+2)='+z' 804 - NCYLAB=NCYLAB+2 805 - ENDIF 806 - ELSEIF(ABS(FPROJ(2,3)+1).LE.1E-4)THEN 807 - PYLAB(NCYLAB+1:NCYLAB+2)='-z' 808 - NCYLAB=NCYLAB+2 809 - ELSEIF(FPROJ(2,3).GT.1E-4)THEN 810 - CALL OUTFMT(REAL(FPROJ(2,3)),2,STRAUX,NCAUX,'LEFT') 811 - IF(NCYLAB.EQ.0)THEN 812 - PYLAB(NCYLAB+1:NCYLAB+2+NCAUX)=STRAUX(1:NCAUX)//'*z' 813 - NCYLAB=NCYLAB+2+NCAUX 814 - ELSE 815 - PYLAB(NCYLAB+1:NCYLAB+3+NCAUX)='+'// 816 - - STRAUX(1:NCAUX)//'*z' 817 - NCYLAB=NCYLAB+3+NCAUX 818 - ENDIF 819 - ELSEIF(FPROJ(2,3).LT.-1E-4)THEN 820 - CALL OUTFMT(REAL(-FPROJ(2,3)),2,STRAUX,NCAUX,'LEFT') 821 - PYLAB(NCYLAB+1:NCYLAB+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*z' 822 - NCYLAB=NCYLAB+3+NCAUX 823 - ENDIF 824 - PYLAB(NCYLAB+1:NCYLAB+10)=' Axis [cm]' 825 - IF(NCYLAB.EQ.1)PYLAB(2:2)='-' 826 - NCYLAB=NCYLAB+10 827 - * Format the plane description. 828 - NCFPRO=0 829 - PROLAB=' ' 830 - IF(ABS(FPROJA-1).LE.1E-4)THEN 831 - PROLAB(NCFPRO+1:NCFPRO+1)='x' 832 - NCFPRO=NCFPRO+1 833 - ELSEIF(ABS(FPROJA+1).LE.1E-4)THEN 834 - PROLAB(NCFPRO+1:NCFPRO+2)='-x' 835 - NCFPRO=NCFPRO+2 836 - ELSEIF(FPROJA.GT.1E-4)THEN 837 - CALL OUTFMT(REAL(FPROJA),2,STRAUX,NCAUX,'LEFT') 838 - PROLAB(NCFPRO+1:NCFPRO+2+NCAUX)=STRAUX(1:NCAUX)//'*x' 839 - NCFPRO=NCFPRO+2+NCAUX 840 - ELSEIF(FPROJA.LT.-1E-4)THEN 841 - CALL OUTFMT(REAL(-FPROJA),2,STRAUX,NCAUX,'LEFT') 842 - PROLAB(NCFPRO+1:NCFPRO+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*x' 843 - NCFPRO=NCFPRO+3+NCAUX 844 - ENDIF 845 - IF(ABS(FPROJB-1).LE.1E-4)THEN 846 - IF(NCFPRO.EQ.0)THEN 847 - PROLAB(NCFPRO+1:NCFPRO+1)='y' 848 - NCFPRO=NCFPRO+1 849 - ELSE 850 - PROLAB(NCFPRO+1:NCFPRO+2)='+y' 851 - NCFPRO=NCFPRO+2 852 - ENDIF 853 - ELSEIF(ABS(FPROJB+1).LE.1E-4)THEN 854 - PROLAB(NCFPRO+1:NCFPRO+2)='-y' 855 - NCFPRO=NCFPRO+2 856 - ELSEIF(FPROJB.GT.1E-4)THEN 857 - CALL OUTFMT(REAL(FPROJB),2,STRAUX,NCAUX,'LEFT') 858 - IF(NCFPRO.EQ.0)THEN 859 - PROLAB(NCFPRO+1:NCFPRO+2+NCAUX)=STRAUX(1:NCAUX)//'*y' 860 - NCFPRO=NCFPRO+2+NCAUX 861 - ELSE 862 - PROLAB(NCFPRO+1:NCFPRO+3+NCAUX)='+'// 863 - - STRAUX(1:NCAUX)//'*y' 864 - NCFPRO=NCFPRO+3+NCAUX 865 - ENDIF 866 - ELSEIF(FPROJB.LT.-1E-4)THEN 867 - CALL OUTFMT(REAL(-FPROJB),2,STRAUX,NCAUX,'LEFT') 868 - PROLAB(NCFPRO+1:NCFPRO+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*y' 869 - NCFPRO=NCFPRO+3+NCAUX 870 - ENDIF 871 - IF(ABS(FPROJC-1).LE.1E-4)THEN 872 - IF(NCFPRO.EQ.0)THEN 873 - PROLAB(NCFPRO+1:NCFPRO+1)='z' 874 - NCFPRO=NCFPRO+1 875 - ELSE 876 - PROLAB(NCFPRO+1:NCFPRO+2)='+z' 877 - NCFPRO=NCFPRO+2 878 - ENDIF 879 - ELSEIF(ABS(FPROJC+1).LE.1E-4)THEN 880 - PROLAB(NCFPRO+1:NCFPRO+2)='-z' 881 - NCFPRO=NCFPRO+2 882 - ELSEIF(FPROJC.GT.1E-4)THEN 883 - CALL OUTFMT(REAL(FPROJC),2,STRAUX,NCAUX,'LEFT') 884 - IF(NCFPRO.EQ.0)THEN 885 - PROLAB(NCFPRO+1:NCFPRO+2+NCAUX)=STRAUX(1:NCAUX)//'*z' 886 - NCFPRO=NCFPRO+2+NCAUX 887 - ELSE 888 - PROLAB(NCFPRO+1:NCFPRO+3+NCAUX)='+'// 889 - - STRAUX(1:NCAUX)//'*z' 890 - NCFPRO=NCFPRO+3+NCAUX 891 - ENDIF 892 - ELSEIF(FPROJC.LT.-1E-4)THEN 893 - CALL OUTFMT(REAL(-FPROJC),2,STRAUX,NCAUX,'LEFT') 894 - PROLAB(NCFPRO+1:NCFPRO+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*z' 895 - NCFPRO=NCFPRO+3+NCAUX 896 - ENDIF 897 - PROLAB(NCFPRO+1:NCFPRO+1)='=' 898 - NCFPRO=NCFPRO+1 899 - CALL OUTFMT(REAL(FPROJD),2,STRAUX,NCAUX,'LEFT') 900 - PROLAB(NCFPRO+1:NCFPRO+NCAUX)=STRAUX(1:NCAUX) 901 - NCFPRO=NCFPRO+NCAUX 902 - *** Next generate the tables. 1 467 P=CELL D=CELVIE 10 PAGE 620 903 - 1000 CONTINUE 904 - *** Prepare the projection matrix. 905 - FPRMAT(1,1)=FPROJ(1,1) 906 - FPRMAT(2,1)=FPROJ(1,2) 907 - FPRMAT(3,1)=FPROJ(1,3) 908 - FPRMAT(1,2)=FPROJ(2,1) 909 - FPRMAT(2,2)=FPROJ(2,2) 910 - FPRMAT(3,2)=FPROJ(2,3) 911 - FNORM=SQRT(FPROJA**2+FPROJB**2+FPROJC**2) 912 - IF(FNORM.LE.0)THEN 913 - PRINT *,' !!!!!! CELVIE WARNING : Zero norm vector'// 914 - - ' of viewing plane; reset to default.' 915 - IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND 916 - CALL PLAINT 917 - IF(POLAR)THEN 918 - PRVIEW='R-PHI' 919 - ELSE 920 - PRVIEW='X-Y' 921 - ENDIF 922 - RETURN 923 - ENDIF 924 - FPRMAT(1,3)=FPROJA/FNORM 925 - FPRMAT(2,3)=FPROJB/FNORM 926 - FPRMAT(3,3)=FPROJC/FNORM 927 - * Solve the matrix. 928 - CALL DFACT(3,FPRMAT,3,IPRMAT,IFAIL1,DET,IFAIL2) 929 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ CELVIE DEBUG :'', 930 - - '' Determinant of projection: '',E15.8)') DET 931 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN 932 - PRINT *,' !!!!!! CELVIE WARNING : Unable to solve'// 933 - - ' the projection matrix; reset to default.' 934 - IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND 935 - CALL PLAINT 936 - IF(POLAR)THEN 937 - PRVIEW='R-PHI' 938 - ELSE 939 - PRVIEW='X-Y' 940 - ENDIF 941 - RETURN 942 - ENDIF 943 - * Compute the, at most, 6 distinct crossings between plane and box. 944 - NGBOX=0 945 - CALL PLALIN(GXMIN,GYMIN,GZMIN, GXMAX,GYMIN,GZMIN, 946 - - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 947 - - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) 948 - IF(IFAIL.EQ.0)THEN 949 - NGBOX=NGBOX+1 950 - CALL PLACO3(XAUX,YAUX,ZAUX, 951 - - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) 952 - ENDIF 953 - CALL PLALIN(GXMIN,GYMIN,GZMIN, GXMIN,GYMAX,GZMIN, 954 - - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 955 - - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) 956 - IF(IFAIL.EQ.0)THEN 957 - NGBOX=NGBOX+1 958 - CALL PLACO3(XAUX,YAUX,ZAUX, 959 - - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) 960 - ENDIF 961 - CALL PLALIN(GXMIN,GYMIN,GZMIN, GXMIN,GYMIN,GZMAX, 962 - - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 963 - - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) 964 - IF(IFAIL.EQ.0)THEN 965 - NGBOX=NGBOX+1 966 - CALL PLACO3(XAUX,YAUX,ZAUX, 967 - - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) 968 - ENDIF 969 - CALL PLALIN(GXMAX,GYMAX,GZMIN, GXMIN,GYMAX,GZMIN, 970 - - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 971 - - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) 972 - IF(IFAIL.EQ.0)THEN 973 - NGBOX=NGBOX+1 974 - CALL PLACO3(XAUX,YAUX,ZAUX, 975 - - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) 976 - ENDIF 977 - CALL PLALIN(GXMAX,GYMAX,GZMIN, GXMAX,GYMIN,GZMIN, 978 - - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 979 - - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) 980 - IF(IFAIL.EQ.0)THEN 981 - NGBOX=NGBOX+1 982 - CALL PLACO3(XAUX,YAUX,ZAUX, 983 - - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) 984 - ENDIF 985 - CALL PLALIN(GXMAX,GYMAX,GZMIN, GXMAX,GYMAX,GZMAX, 986 - - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 987 - - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) 988 - IF(IFAIL.EQ.0)THEN 989 - NGBOX=NGBOX+1 990 - CALL PLACO3(XAUX,YAUX,ZAUX, 991 - - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) 992 - ENDIF 993 - CALL PLALIN(GXMAX,GYMIN,GZMAX, GXMIN,GYMIN,GZMAX, 994 - - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 995 - - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) 996 - IF(IFAIL.EQ.0)THEN 997 - NGBOX=NGBOX+1 998 - CALL PLACO3(XAUX,YAUX,ZAUX, 999 - - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) 1000 - ENDIF 1001 - CALL PLALIN(GXMAX,GYMIN,GZMAX, GXMAX,GYMAX,GZMAX, 1002 - - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 1003 - - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) 1004 - IF(IFAIL.EQ.0)THEN 1005 - NGBOX=NGBOX+1 1006 - CALL PLACO3(XAUX,YAUX,ZAUX, 1007 - - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) 1008 - ENDIF 1 467 P=CELL D=CELVIE 11 PAGE 621 1009 - CALL PLALIN(GXMAX,GYMIN,GZMAX, GXMAX,GYMIN,GZMIN, 1010 - - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 1011 - - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) 1012 - IF(IFAIL.EQ.0)THEN 1013 - NGBOX=NGBOX+1 1014 - CALL PLACO3(XAUX,YAUX,ZAUX, 1015 - - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) 1016 - ENDIF 1017 - CALL PLALIN(GXMIN,GYMAX,GZMAX, GXMAX,GYMAX,GZMAX, 1018 - - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 1019 - - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) 1020 - IF(IFAIL.EQ.0)THEN 1021 - NGBOX=NGBOX+1 1022 - CALL PLACO3(XAUX,YAUX,ZAUX, 1023 - - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) 1024 - ENDIF 1025 - CALL PLALIN(GXMIN,GYMAX,GZMAX, GXMIN,GYMIN,GZMAX, 1026 - - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 1027 - - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) 1028 - IF(IFAIL.EQ.0)THEN 1029 - NGBOX=NGBOX+1 1030 - CALL PLACO3(XAUX,YAUX,ZAUX, 1031 - - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) 1032 - ENDIF 1033 - CALL PLALIN(GXMIN,GYMAX,GZMAX, GXMIN,GYMAX,GZMIN, 1034 - - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 1035 - - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) 1036 - IF(IFAIL.EQ.0)THEN 1037 - NGBOX=NGBOX+1 1038 - CALL PLACO3(XAUX,YAUX,ZAUX, 1039 - - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) 1040 - ENDIF 1041 - * Ensure there is no butterfly. 1042 - CALL BUTFLD(NGBOX,GXBOX,GYBOX,GZBOX) 1043 - * Establish light direction. 1044 - PRAL=+COS(PRPHIL)*COS(PRTHL)*FPROJA-SIN(PRPHIL)*FPROJB+ 1045 - - COS(PRPHIL)*SIN(PRTHL)*FPROJC 1046 - PRBL=+SIN(PRPHIL)*COS(PRTHL)*FPROJA+COS(PRPHIL)*FPROJB+ 1047 - - SIN(PRPHIL)*SIN(PRTHL)*FPROJC 1048 - PRCL= -SIN(PRTHL)*FPROJA+ 1049 - - COS(PRTHL)*FPROJC 1050 - FNORM=SQRT(PRAL**2+PRBL**2+PRCL**2) 1051 - IF(FNORM.GT.0)THEN 1052 - PRAL=PRAL/FNORM 1053 - PRBL=PRBL/FNORM 1054 - PRCL=PRCL/FNORM 1055 - ENDIF 1056 - * Reset the buffer of the panels. 1057 - CALL PLABU1('RESET',IREF,0,XPL,YPL,ZPL, 1058 - - 0.0D0,0.0D0,0.0D0,0,0,IFAIL) 1059 - ** Copy the wires to the solids. 1060 - IF(NWIRE.NE.0.AND.NSOLID.EQ.0.AND. 1061 - - (PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')) 1062 - - CALL CELCNW(QXMIN,QYMIN,QXMAX,QYMAX) 1063 - ** Generate the plot panels for each solid, first for 3D views. 1064 - IF(PRVIEW.EQ.'3D')THEN 1065 - * Prepare colour tables. 1066 - ICOL0=30 1067 - ICOLBX=0 1068 - ICOLPL=0 1069 - ICOLST=0 1070 - ICOLW1=0 1071 - ICOLW2=0 1072 - ICOLW3=0 1073 - ICOLD1=0 1074 - ICOLD2=0 1075 - ICOLD3=0 1076 - * Loop over the volumes. 1077 - CALL PROFLD(1,'Generating volumes',REAL(NSOLID)) 1078 - DO 1010 IVOL=1,NSOLID 1079 - CALL PROSTA(1,REAL(IVOL)) 1080 - * Assign the colour index, generating colour tables as required. 1081 - IF(ISOLMT(IVOL).EQ.1)THEN 1082 - IF(ICOLW1.EQ.0)THEN 1083 - CALL GRATTS('CONDUCTORS-1','AREA') 1084 - ICOLW1=ICOL0 1085 - CALL COLSHD(ICOLW1) 1086 - ICOL0=ICOL0+NPRCOL 1087 - ENDIF 1088 - ICOL=ICOLW1 1089 - ELSEIF(ISOLMT(IVOL).EQ.2)THEN 1090 - IF(ICOLW2.EQ.0)THEN 1091 - CALL GRATTS('CONDUCTORS-2','AREA') 1092 - ICOLW2=ICOL0 1093 - CALL COLSHD(ICOLW2) 1094 - ICOL0=ICOL0+NPRCOL 1095 - ENDIF 1096 - ICOL=ICOLW2 1097 - ELSEIF(ISOLMT(IVOL).EQ.3)THEN 1098 - IF(ICOLW3.EQ.0)THEN 1099 - CALL GRATTS('CONDUCTORS-3','AREA') 1100 - ICOLW3=ICOL0 1101 - CALL COLSHD(ICOLW3) 1102 - ICOL0=ICOL0+NPRCOL 1103 - ENDIF 1104 - ICOL=ICOLW3 1105 - ELSEIF(ISOLMT(IVOL).EQ.11)THEN 1106 - IF(ICOLD1.EQ.0)THEN 1107 - CALL GRATTS('DIELECTRIC-1','AREA') 1108 - ICOLD1=ICOL0 1109 - CALL COLSHD(ICOLD1) 1110 - ICOL0=ICOL0+NPRCOL 1111 - ENDIF 1112 - ICOL=ICOLD1 1113 - ELSEIF(ISOLMT(IVOL).EQ.12)THEN 1114 - IF(ICOLD2.EQ.0)THEN 1 467 P=CELL D=CELVIE 12 PAGE 622 1115 - CALL GRATTS('DIELECTRIC-2','AREA') 1116 - ICOLD2=ICOL0 1117 - CALL COLSHD(ICOLD2) 1118 - ICOL0=ICOL0+NPRCOL 1119 - ENDIF 1120 - ICOL=ICOLD2 1121 - ELSEIF(ISOLMT(IVOL).EQ.13)THEN 1122 - IF(ICOLD3.EQ.0)THEN 1123 - CALL GRATTS('DIELECTRIC-3','AREA') 1124 - ICOLD3=ICOL0 1125 - CALL COLSHD(ICOLD3) 1126 - ICOL0=ICOL0+NPRCOL 1127 - ENDIF 1128 - ICOL=ICOLD3 1129 - ELSE 1130 - ICOL=0 1131 - ENDIF 1132 - * cylinders ... 1133 - IF(ISOLTP(IVOL).EQ.1)THEN 1134 - CALL PLACYP(IVOL,ICOL) 1135 - * cylindrical holes ... 1136 - ELSEIF(ISOLTP(IVOL).EQ.2)THEN 1137 - CALL PLACHP(IVOL,ICOL) 1138 - * boxes ... 1139 - ELSEIF(ISOLTP(IVOL).EQ.3)THEN 1140 - CALL PLABXP(IVOL,ICOL) 1141 - * spheres ... 1142 - ELSEIF(ISOLTP(IVOL).EQ.4)THEN 1143 - CALL PLASPP(IVOL,ICOL) 1144 - * other things not known. 1145 - ELSE 1146 - PRINT *,' !!!!!! CELVIE WARNING : Asked to plot a'// 1147 - - ' solid of unknown type ',ISOLTP(IVOL), 1148 - - '; not plotted.' 1149 - ENDIF 1150 - 1010 CONTINUE 1151 - * And sort them for plotting. 1152 - CALL PLASRP 1153 - ** Same thing for cut views. 1154 - ELSEIF(PRVIEW.EQ.'CUT')THEN 1155 - * Create the colour entries. 1156 - CALL PROFLD(1,'Making colour table',-1.0) 1157 - CALL PROSTA(1,0.0) 1158 - CALL GRATTS('CONDUCTORS-1','AREA') 1159 - CALL GQFACI(IERR,ICOLW1) 1160 - IF(IERR.NE.0)ICOLW1=1 1161 - CALL GRATTS('CONDUCTORS-2','AREA') 1162 - CALL GQFACI(IERR,ICOLW2) 1163 - IF(IERR.NE.0)ICOLW2=1 1164 - CALL GRATTS('CONDUCTORS-3','AREA') 1165 - CALL GQFACI(IERR,ICOLW3) 1166 - IF(IERR.NE.0)ICOLW3=1 1167 - CALL GRATTS('DIELECTRIC-1','AREA') 1168 - CALL GQFACI(IERR,ICOLD1) 1169 - IF(IERR.NE.0)ICOLD1=1 1170 - CALL GRATTS('DIELECTRIC-2','AREA') 1171 - CALL GQFACI(IERR,ICOLD2) 1172 - IF(IERR.NE.0)ICOLD2=1 1173 - CALL GRATTS('DIELECTRIC-3','AREA') 1174 - CALL GQFACI(IERR,ICOLD3) 1175 - IF(IERR.NE.0)ICOLD3=1 1176 - * Loop over the volumes. 1177 - CALL PROFLD(1,'Generating volumes',REAL(NSOLID)) 1178 - DO 1020 IVOL=1,NSOLID 1179 - CALL PROSTA(1,REAL(IVOL)) 1180 - * Assign the colour index. 1181 - IF(ISOLMT(IVOL).EQ.1)THEN 1182 - ICOL=ICOLW1 1183 - ELSEIF(ISOLMT(IVOL).EQ.2)THEN 1184 - ICOL=ICOLW2 1185 - ELSEIF(ISOLMT(IVOL).EQ.3)THEN 1186 - ICOL=ICOLW3 1187 - ELSEIF(ISOLMT(IVOL).EQ.11)THEN 1188 - ICOL=ICOLD1 1189 - ELSEIF(ISOLMT(IVOL).EQ.12)THEN 1190 - ICOL=ICOLD2 1191 - ELSEIF(ISOLMT(IVOL).EQ.13)THEN 1192 - ICOL=ICOLD3 1193 - ELSE 1194 - ICOL=0 1195 - ENDIF 1196 - * cylinders ... 1197 - IF(ISOLTP(IVOL).EQ.1)THEN 1198 - CALL PLACYC(IVOL,FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 1199 - - FPROJA,FPROJB,FPROJC,ICOL) 1200 - * cylindrical holes. 1201 - ELSEIF(ISOLTP(IVOL).EQ.2)THEN 1202 - CALL PLACHC(IVOL,FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 1203 - - FPROJA,FPROJB,FPROJC,ICOL) 1204 - * boxes ... 1205 - ELSEIF(ISOLTP(IVOL).EQ.3)THEN 1206 - CALL PLABXC(IVOL,FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 1207 - - FPROJA,FPROJB,FPROJC,ICOL) 1208 - * spheres ... 1209 - ELSEIF(ISOLTP(IVOL).EQ.4)THEN 1210 - CALL PLASPC(IVOL,FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 1211 - - FPROJA,FPROJB,FPROJC,ICOL) 1212 - * other things not known. 1213 - ELSE 1214 - PRINT *,' !!!!!! CELVIE WARNING : Asked to plot a'// 1215 - - ' solid of unknown type ',ISOLTP(IVOL), 1216 - - '; not plotted.' 1217 - ENDIF 1218 - 1020 CONTINUE 1219 - * And sort them for plotting. 1220 - CALL PLASRC 1 467 P=CELL D=CELVIE 13 PAGE 623 1221 - ENDIF 1222 - *** End of progress printing. 1223 - IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND 1224 - *** Reset tolerances. 1225 - CALL EPSSET('RESET',0.0D0,0.0D0,0.0D0) 1226 - END 468 GARFIELD ================================================== P=CELL D=CELWRT 1 ============================ 0 + +DECK,CELWRT. 1 - SUBROUTINE CELWRT(IMODE) 2 - *----------------------------------------------------------------------- 3 - * CELWRT - This routine writes all cell information on a dataset. 4 - * VARIABLES : IMODE : If 1 : find name, if 2 write cell. 5 - * IACC : If 0 no name specified, no write. 6 - * If 1 name OK, write will be executed. 7 - * If 2 name rejected no write. 8 - * (Last changed on 29/11/00.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13.- +SEQ,SOLIDS. 14.- +SEQ,PRINTPLOT. 15 - CHARACTER*(MXINCH) STRING 16 - CHARACTER*(MXNAME) FILE 17 - CHARACTER*29 REMARK 18 - CHARACTER*8 TIME,DATE,MEMBER 19 - INTEGER IMODE,IACC,NCFILE,NCMEMB,NCREM,I,J,K,IFAIL,INEXT,IOS, 20 - - INPCMP,NWORD 21 - LOGICAL EXMEMB 22 - EXTERNAL INPCMP 0 23-+ +SELF,IF=SAVE. 24 - SAVE IACC,FILE,NCFILE,MEMBER,NCMEMB,REMARK,NCREM 0 25-+ +SELF. 26 - DATA IACC/0/ 27 - *** Identify the routine. 28 - IF(LIDENT)PRINT *,' /// ROUTINE CELWRT ///' 29 - *** Goto 200 if a write is requested. 30 - IF(IMODE.EQ.2)GOTO 200 31 - * Set the file name etc. 32 - IACC=0 33 - FILE=' ' 34 - NCFILE=1 35 - MEMBER='< none >' 36 - NCMEMB=8 37 - REMARK='none' 38 - NCREM=4 39 - * First decode the argument string. 40 - CALL INPNUM(NWORD) 41 - * Make sure there is at least one argument. 42 - IF(NWORD.EQ.1)THEN 43 - PRINT *,' !!!!!! CELWRT WARNING : WRITE takes at least one', 44 - - ' argument (a dataset name); data will not be written.' 45 - RETURN 46 - * Check whether keywords have been used. 47 - ELSEIF(INPCMP(2,'D#ATASET')+INPCMP(2,'R#EMARK').NE.0)THEN 48 - INEXT=2 49 - DO 10 I=2,NWORD 50 - IF(I.LT.INEXT)GOTO 10 51 - IF(INPCMP(I,'D#ATASET').NE.0)THEN 52 - IF(INPCMP(I+1,'R#EMARK').NE.0.OR.I+1.GT.NWORD)THEN 53 - CALL INPMSG(I,'The dataset name is missing. ') 54 - INEXT=I+1 55 - ELSE 56 - CALL INPSTR(I+1,I+1,STRING,NCFILE) 57 - FILE=STRING 58 - INEXT=I+2 59 - IF(INPCMP(I+2,'R#EMARK').EQ.0.AND. 60 - - I+2.LE.NWORD)THEN 61 - CALL INPSTR(I+2,I+2,STRING,NCMEMB) 62 - MEMBER=STRING 63 - INEXT=I+3 64 - ENDIF 65 - ENDIF 66 - ELSEIF(INPCMP(I,'R#EMARK').NE.0)THEN 67 - IF(INPCMP(I+1,'D#ATASET').NE.0.OR.I+1.GT.NWORD)THEN 68 - CALL INPMSG(I,'The remark is missing. ') 69 - INEXT=I+1 70 - ELSE 71 - CALL INPSTR(I+1,I+1,STRING,NCREM) 72 - REMARK=STRING 73 - INEXT=I+2 74 - ENDIF 75 - ELSE 76 - CALL INPMSG(I,'The parameter is not known. ') 77 - ENDIF 78 - 10 CONTINUE 79 - * Otherwise the string is interpreted as a file name (+ member name). 80 - ELSE 81 - CALL INPSTR(2,2,STRING,NCFILE) 82 - FILE=STRING 83 - IF(NWORD.GE.3)THEN 84 - CALL INPSTR(3,3,STRING,NCMEMB) 85 - MEMBER=STRING 86 - ENDIF 87 - IF(NWORD.GE.4)THEN 88 - CALL INPSTR(4,NWORD,STRING,NCREM) 89 - REMARK=STRING 90 - ENDIF 91 - ENDIF 92 - * Print error messages. 93 - CALL INPERR 94 - IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! CELWRT WARNING : The file', 1 468 P=CELL D=CELWRT 2 PAGE 624 95 - - ' name is truncated to MXNAME (=',MXNAME,') characters.' 96 - IF(NCMEMB.GT.8)PRINT *,' !!!!!! CELWRT WARNING : The member', 97 - - ' name is shortened to ',MEMBER,', first 8 characters.' 98 - IF(NCREM.GT.29)PRINT *,' !!!!!! CELWRT WARNING : The remark', 99 - - ' shortened to ',REMARK,', first 29 characters.' 100 - NCFILE=MIN(NCFILE,MXNAME) 101 - NCMEMB=MIN(NCMEMB,8) 102 - NCREM=MIN(NCREM,29) 103 - * Check whether the member already exists. 104 - CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'CELL',EXMEMB) 105 - IF(JEXMEM.EQ.2.AND.EXMEMB)THEN 106 - PRINT *,' ------ CELWRT MESSAGE : A copy of the member'// 107 - - ' exists; new member will be appended.' 108 - ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN 109 - PRINT *,' !!!!!! CELWRT WARNING : A copy of the member'// 110 - - ' exists already; member will not be written.' 111 - RETURN 112 - ENDIF 113 - * Everything seems to be OK, the accept flag can be set to 'accept'. 114 - IACC=1 115 - * Print some debugging output if requested. 116 - IF(LDEBUG)THEN 117 - PRINT *,' ++++++ CELWRT DEBUG : File= '//FILE(1:NCFILE)// 118 - - ', member= '//MEMBER(1:NCMEMB),' IACC=',IACC 119 - PRINT *,' Remark= ',REMARK(1:NCREM) 120 - ENDIF 121 - RETURN 122 - *** Execute write operation if a valid name is available. 123 - 200 CONTINUE 124 - IF(IACC.EQ.0)RETURN 125 - IACC=0 126 - *** Open the dataset for sequential write and inform DSNLOG. 127 - CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) 128 - IF(IFAIL.NE.0)THEN 129 - PRINT *,' !!!!!! CELWRT WARNING : Opening '//FILE(1:NCFILE), 130 - - ' failed ; the cell data will not be written.' 131 - RETURN 132 - ENDIF 133 - CALL DSNLOG(FILE,'Cell data ','Sequential','Write ') 134 - IF(LDEBUG)PRINT *,' ++++++ CELWRT DEBUG : Dataset '// 135 - - FILE(1:NCFILE)//' opened on unit 12 for seq write.' 136 - * Now write a heading record to the file. 137 - CALL DATTIM(DATE,TIME) 138 - WRITE(STRING,'(''% Created '',A8,'' At '',A8,1X,A8,'' CELL '', 139 - - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK 140 - WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING 141 - IF(LDEBUG)THEN 142 - PRINT *,' ++++++ CELWRT DEBUG : Dataset heading record:' 143 - PRINT *,STRING 144 - ENDIF 145 - * Write a version number. 146 - WRITE(12,'('' Version : 1'')') 147 - * Write the cell on the dataset. 148 - WRITE(12,'('' CELLID: '',A)',IOSTAT=IOS,ERR=2010) CELLID 149 - WRITE(12,'('' Wires: '',I10,'' Type: '',A3,I2, 150 - - '' Polar: '',L1,'' Tube: '',L1)',IOSTAT=IOS,ERR=2010) 151 - - NWIRE,TYPE,ICTYPE,POLAR,TUBE 152 - WRITE(12,'('' Area: '',6E15.8,/,'' V-RANGE: '',2E15.8)', 153 - - IOSTAT=IOS,ERR=2010) XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,VMIN,VMAX 154 - WRITE(12,'('' Wire table follows: '')',IOSTAT=IOS,ERR=2010) 155 - DO 210 I=1,NWIRE 156 - WRITE(12,'(1X,A1,6E15.8/2X,5E15.8)',IOSTAT=IOS,ERR=2010) 157 - - WIRTYP(I),X(I),Y(I),V(I),E(I),D(I),W(I),U(I),DENS(I), 158 - - B2SIN(I),WMAP(I) 159 - 210 CONTINUE 160 - WRITE(12,'('' Gravity: '',3E15.8)',IOSTAT=IOS, 161 - - ERR=2010) (DOWN(I),I=1,3) 162 - WRITE(12,'('' CORVT: '',3E15.8,'' V0: '',E15.8)',IOSTAT=IOS, 163 - - ERR=2010) CORVTA,CORVTB,CORVTC,V0 164 - WRITE(12,'('' x-Planes: '',2(L1,2E15.8,A1))',IOSTAT=IOS,ERR=2010) 165 - - (YNPLAN(I),COPLAN(I),VTPLAN(I),PLATYP(I),I=1,2) 166 - WRITE(12,'('' y-Planes: '',2(L1,2E15.8,A1))',IOSTAT=IOS,ERR=2010) 167 - - (YNPLAN(I),COPLAN(I),VTPLAN(I),PLATYP(I),I=3,4) 168 - WRITE(12,'('' Plane summary data: '',2L1,2E15.8)',IOSTAT=IOS, 169 - - ERR=2010) YNPLAX,YNPLAY,COPLAX,COPLAY 170 - WRITE(12,'('' Strips: '',5I10/9X,5I10)',IOSTAT=IOS,ERR=2010) 171 - - (NPSTR1(I),NPSTR2(I),I=1,5) 172 - DO 240 I=1,5 173 - DO 250 J=1,NPSTR1(I) 174 - WRITE(12,'(1X,A1,1X,3E15.8)',IOSTAT=IOS,ERR=2010) 175 - - PSLAB1(I,J),(PLSTR1(I,J,K),K=1,3) 176 - 250 CONTINUE 177 - DO 260 J=1,NPSTR2(I) 178 - WRITE(12,'(1X,A1,1X,3E15.8)',IOSTAT=IOS,ERR=2010) 179 - - PSLAB2(I,J),(PLSTR2(I,J,K),K=1,3) 180 - 260 CONTINUE 181 - 240 CONTINUE 182 - WRITE(12,'('' Periodicity : '',2(L1,E15.8))',IOSTAT=IOS, 183 - - ERR=2010) PERX,SX,PERY,SY 184 - IF(TYPE(1:1).EQ.'C')WRITE(12,'('' C cell data: '',5E15.8,I10)', 185 - - IOSTAT=IOS,ERR=2010) ZMULT,P1,P2,C1,MODE 186 - IF(TYPE.EQ.'D3 '.OR.TYPE.EQ.'D4 ') 187 - - WRITE(12,'('' D3-D4 data: '',E15.8)', 188 - - IOSTAT=IOS,ERR=2010) KAPPA 189 - WRITE(12,'('' Dielectrica: nx='',I3,'', ny='',I3)',IOSTAT=IOS, 190 - - ERR=2010) NXMATT,NYMATT 191 - DO 220 I=1,NXMATT 192 - WRITE(12,'(1X,5E15.8)',IOSTAT=IOS,ERR=2010) (XMATT(I,J),J=1,5) 193 - 220 CONTINUE 194 - DO 230 I=1,NYMATT 195 - WRITE(12,'(1X,5E15.8)',IOSTAT=IOS,ERR=2010) (YMATT(I,J),J=1,5) 196 - 230 CONTINUE 197 - IF(TUBE)WRITE(12,'('' Tube: '',2E15.8,2I10,A1)',IOSTAT=IOS, 198 - - ERR=2010) COTUBE,VTTUBE,NTUBE,MTUBE,PLATYP(5) 199 - WRITE(12,'('' Solids: '',2I10)',IOSTAT=IOS,ERR=2010) 200 - - NSOLID,ICCURR 1 468 P=CELL D=CELWRT 3 PAGE 625 201 - IF(NSOLID.GT.0)WRITE(12,'(1X,3I10)',IOSTAT=IOS,ERR=2010) 202 - - (ISTART(I),ISOLTP(I),ISOLMT(I),I=1,NSOLID) 203 - IF(ICCURR.GT.0)WRITE(12,'(1X,8E15.8)',IOSTAT=IOS,ERR=2010) 204 - - (CBUF(I),I=1,ICCURR) 205 - * Close the file after the operation. 206 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 207 - CALL TIMLOG('Writing the cell data to a dataset: ') 208 - RETURN 209 - *** Handle the error conditions. 210 - 2010 CONTINUE 211 - PRINT *,' ###### CELWRT ERROR : Error while writing'// 212 - - ' to ',FILE(1:NCFILE),' via unit 12 ; no cell data written.' 213 - CALL INPIOS(IOS) 214 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 215 - RETURN 216 - 2030 CONTINUE 217 - PRINT *,' ###### CELWRT ERROR : Dataset '//FILE(1:NCFILE)// 218 - - ' unit 12 cannot be closed ; results not predictable' 219 - CALL INPIOS(IOS) 220 - END 469 GARFIELD ================================================== P=CELL D=CELSEL 1 ============================ 0 + +DECK,CELSEL. 1 - SUBROUTINE CELSEL 2 - *----------------------------------------------------------------------- 3 - * CELSEL - This routine allows the user to change his set of readout 4 - * electrodes. Wires can be identified by means of their label 5 - * and by their number. Planes and tubes by their label only. 6 - * (Last changed on 4/12/00.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,FIELDMAP. 12.- +SEQ,SOLIDS. 13.- +SEQ,PRINTPLOT. 14 - LOGICAL OPEN,OK,EXIST,FOUND,USED(MXWIRE+5+MXWMAP+10*MXPSTR), 15 - - SOLSEL 16 - INTEGER NC,I,J,K,L,II,IREAD,NWORD,IFAIL,INEXT 17 - CHARACTER*(MXINCH) TEXT,WRONG 18 - *** Identify the routine if requested. 19 - IF(LIDENT)PRINT *,' /// ROUTINE CELSEL ///' 20 - *** Obtain the argument string. 21 - CALL INPSTR(2,MXWORD,TEXT,NC) 22 - CALL INPNUM(NWORD) 23 - *** If the string is blank, only print the current settings. 24 - IF(NWORD.LE.1)THEN 25 - CALL CELPRC(LUNOUT,0) 26 - RETURN 27 - ENDIF 28 - *** Initialse INDSW, the logicals and the error logging array. 29 - OK=.TRUE. 30 - WRONG=' '// 31 - - ' ' 32 - DO 10 I=1,MXWIRE 33 - USED(I)=.FALSE. 34 - INDSW(I)=0 35 - 10 CONTINUE 36 - DO 160 I=1,5 37 - USED(MXWIRE+I)=.FALSE. 38 - INDPLA(I)=0 39 - DO 340 J=1,MXPSTR 40 - INDST1(I,J)=0 41 - INDST2(I,J)=0 42 - USED(MXWIRE+5+MXWMAP+(I-1)*MXPSTR+J)=.FALSE. 43 - USED(MXWIRE+5+MXWMAP+(I+4)*MXPSTR+J)=.FALSE. 44 - 340 CONTINUE 45 - 160 CONTINUE 46 - DO 260 I=1,NWMAP 47 - USED(MXWIRE+5+I)=.FALSE. 48 - INDEWS(I)=0 49 - 260 CONTINUE 50 - NSW=0 51 - DO 170 I=1,MXSOLI 52 - INDSOL(I)=0 53 - 170 CONTINUE 54 - SOLSEL=.FALSE. 55 - *** Loop over all characters in the string. 56 - OPEN=.FALSE. 57 - INEXT=1 58 - DO 20 I=1,NC 59 - IF(I.LT.INEXT)GOTO 20 60 - ** Skip blanks, commas and equal signs (the usual separators), 61 - IF(INDEX(' ,=',TEXT(I:I)).NE.0)GOTO 20 62 - ** "(" open brackets, 63 - IF(TEXT(I:I).EQ.'(')THEN 64 - IF(OPEN)THEN 65 - OK=.FALSE. 66 - WRONG(I:I)='|' 67 - ELSE 68 - OPEN=.TRUE. 69 - NSW=NSW+1 70 - EXIST=.FALSE. 71 - ENDIF 72 - * ")" close brackets, 73 - ELSEIF(TEXT(I:I).EQ.')')THEN 74 - IF(OPEN)THEN 75 - OPEN=.FALSE. 76 - IF(.NOT.EXIST)NSW=NSW-1 77 - ELSE 78 - OK=.FALSE. 79 - WRONG(I:I)='|' 80 - ENDIF 81 - ** Wire, plane, tube and field map code in numeric form, 82 - ELSEIF(INDEX('+-0123456789',TEXT(I:I)).NE.0)THEN 1 469 P=CELL D=CELSEL 2 PAGE 626 83 - J=I 84 - 30 CONTINUE 85 - J=J+1 86 - IF(J.LE.NC.AND.INDEX('0123456789',TEXT(J:J)).NE.0)GOTO 30 87 - CALL INPRIC(TEXT(I:J-1),IREAD,0,IFAIL) 88 - IF(IFAIL.NE.0.OR.IREAD.LT.-5-MXWMAP.OR.IREAD.GT.NWIRE.OR. 89 - - IREAD.EQ.0)THEN 90 - WRONG(I:I)='#' 91 - OK=.FALSE. 92 - INEXT=J 93 - GOTO 20 94 - ENDIF 95 - IF(IREAD.LT.0)IREAD=MXWIRE-IREAD 96 - IF(USED(IREAD))THEN 97 - OK=.FALSE. 98 - WRONG(I:I)='2' 99 - ELSE 100 - IF(.NOT.OPEN.AND.NSW.GE.MXSW)THEN 101 - PRINT *,' !!!!!! CELSEL WARNING : You have'// 102 - - ' selected more electrodes than the'// 103 - - ' program can store ; increase MXSW.' 104 - OK=.FALSE. 105 - DO 40 K=I,NC 106 - IF(TEXT(K:K).NE.' ')WRONG(K:K)='.' 107 - 40 CONTINUE 108 - NSW=MXSW 109 - GOTO 100 110 - ENDIF 111 - IF(IREAD.GE.MXWIRE+6.AND.IREAD.LE.MXWIRE+5+MXWMAP)THEN 112 - IF(NWMAP.LT.IREAD-MXWIRE-5)THEN 113 - WRONG(I:I)='M' 114 - OK=.FALSE. 115 - ELSE 116 - IF(.NOT.OPEN)NSW=NSW+1 117 - INDEWS(IREAD-MXWIRE-5)=NSW 118 - USED(IREAD)=.TRUE. 119 - EXIST=.TRUE. 120 - ENDIF 121 - ELSEIF(IREAD.EQ.MXWIRE+5)THEN 122 - IF(.NOT.TUBE)THEN 123 - WRONG(I:I)='T' 124 - OK=.FALSE. 125 - ELSE 126 - IF(.NOT.OPEN)NSW=NSW+1 127 - INDPLA(IREAD-MXWIRE)=NSW 128 - USED(IREAD)=.TRUE. 129 - EXIST=.TRUE. 130 - ENDIF 131 - ELSEIF(IREAD.GE.MXWIRE+1.AND.IREAD.LE.MXWIRE+4)THEN 132 - IF(.NOT.YNPLAN(IREAD-MXWIRE))THEN 133 - WRONG(I:I)='P' 134 - OK=.FALSE. 135 - ELSE 136 - IF(.NOT.OPEN)NSW=NSW+1 137 - INDPLA(IREAD-MXWIRE)=NSW 138 - USED(IREAD)=.TRUE. 139 - EXIST=.TRUE. 140 - ENDIF 141 - ELSE 142 - IF(.NOT.OPEN)NSW=NSW+1 143 - INDSW(IREAD)=NSW 144 - USED(IREAD)=.TRUE. 145 - EXIST=.TRUE. 146 - ENDIF 147 - ENDIF 148 - INEXT=J 149 - ** Wire and plane code as a letter, 150 - ELSEIF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',TEXT(I:I)).NE.0)THEN 151 - FOUND=.FALSE. 152 - * Check the wires. 153 - DO 60 J=1,NWIRE 154 - IF(WIRTYP(J).EQ.TEXT(I:I))THEN 155 - EXIST=.TRUE. 156 - FOUND=.TRUE. 157 - IF(USED(J))THEN 158 - OK=.FALSE. 159 - WRONG(I:I)='2' 160 - GOTO 60 161 - ELSE 162 - IF(.NOT.OPEN)NSW=NSW+1 163 - IF(NSW.GT.MXSW)THEN 164 - PRINT *,' !!!!!! CELSEL WARNING : You have'// 165 - - ' selected more electrodes than the'// 166 - - ' program can store ; increase MXSW.' 167 - OK=.FALSE. 168 - DO 50 K=I,NC 169 - IF(TEXT(K:K).NE.' ')WRONG(K:K)='.' 170 - 50 CONTINUE 171 - NSW=MXSW 172 - GOTO 100 173 - ENDIF 174 - INDSW(J)=NSW 175 - USED(J)=.TRUE. 176 - ENDIF 177 - ENDIF 178 - 60 CONTINUE 179 - * Check the planes and the tube. 180 - DO 180 J=1,5 181 - IF(J.LE.4)THEN 182 - IF(.NOT.YNPLAN(J))GOTO 180 183 - ELSE 184 - IF(.NOT.TUBE)GOTO 180 185 - ENDIF 186 - IF(PLATYP(J).EQ.TEXT(I:I))THEN 187 - EXIST=.TRUE. 188 - FOUND=.TRUE. 1 469 P=CELL D=CELSEL 3 PAGE 627 189 - IF(USED(MXWIRE+J))THEN 190 - OK=.FALSE. 191 - WRONG(I:I)='2' 192 - GOTO 180 193 - ELSE 194 - IF(.NOT.OPEN)NSW=NSW+1 195 - IF(NSW.GT.MXSW)THEN 196 - PRINT *,' !!!!!! CELSEL WARNING : You have'// 197 - - ' selected more electrodes than the'// 198 - - ' program can store ; increase MXSW.' 199 - OK=.FALSE. 200 - DO 190 K=I,NC 201 - IF(TEXT(K:K).NE.' ')WRONG(K:K)='.' 202 - 190 CONTINUE 203 - NSW=MXSW 204 - GOTO 100 205 - ENDIF 206 - INDPLA(J)=NSW 207 - USED(MXWIRE+J)=.TRUE. 208 - ENDIF 209 - ENDIF 210 - 180 CONTINUE 211 - * Check the strips on the planes and the tube. 212 - DO 240 J=1,5 213 - IF(J.LE.4)THEN 214 - IF(.NOT.YNPLAN(J))GOTO 240 215 - ELSE 216 - IF(.NOT.TUBE)GOTO 240 217 - ENDIF 218 - DO 280 K=1,NPSTR1(J) 219 - IF(PSLAB1(J,K).EQ.TEXT(I:I))THEN 220 - EXIST=.TRUE. 221 - FOUND=.TRUE. 222 - IF(USED(MXWIRE+5+MXWMAP+(J-1)*MXPSTR+K))THEN 223 - OK=.FALSE. 224 - WRONG(I:I)='2' 225 - GOTO 280 226 - ELSE 227 - IF(.NOT.OPEN)NSW=NSW+1 228 - IF(NSW.GT.MXSW)THEN 229 - PRINT *,' !!!!!! CELSEL WARNING : You have'// 230 - - ' selected more electrodes than the'// 231 - - ' program can store ; increase MXSW.' 232 - OK=.FALSE. 233 - DO 250 L=I,NC 234 - IF(TEXT(L:L).NE.' ')WRONG(L:L)='.' 235 - 250 CONTINUE 236 - NSW=MXSW 237 - GOTO 100 238 - ENDIF 239 - INDST1(J,K)=NSW 240 - USED(MXWIRE+5+MXWMAP+(J-1)*MXPSTR+K)=.TRUE. 241 - ENDIF 242 - ENDIF 243 - 280 CONTINUE 244 - DO 350 K=1,NPSTR2(J) 245 - IF(PSLAB2(J,K).EQ.TEXT(I:I))THEN 246 - EXIST=.TRUE. 247 - FOUND=.TRUE. 248 - IF(USED(MXWIRE+5+MXWMAP+(J+4)*MXPSTR+K))THEN 249 - OK=.FALSE. 250 - WRONG(I:I)='2' 251 - GOTO 350 252 - ELSE 253 - IF(.NOT.OPEN)NSW=NSW+1 254 - IF(NSW.GT.MXSW)THEN 255 - PRINT *,' !!!!!! CELSEL WARNING : You have'// 256 - - ' selected more electrodes than the'// 257 - - ' program can store ; increase MXSW.' 258 - OK=.FALSE. 259 - DO 360 L=I,NC 260 - IF(TEXT(L:L).NE.' ')WRONG(L:L)='.' 261 - 360 CONTINUE 262 - NSW=MXSW 263 - GOTO 100 264 - ENDIF 265 - INDST2(J,K)=NSW 266 - USED(MXWIRE+5+MXWMAP+(J+4)*MXPSTR+K)=.TRUE. 267 - ENDIF 268 - ENDIF 269 - 350 CONTINUE 270 - 240 CONTINUE 271 - * Check the field map. 272 - DO 270 J=1,NWMAP 273 - IF(EWSTYP(J).EQ.TEXT(I:I))THEN 274 - EXIST=.TRUE. 275 - FOUND=.TRUE. 276 - IF(USED(MXWIRE+5+J))THEN 277 - OK=.FALSE. 278 - WRONG(I:I)='2' 279 - ELSE 280 - IF(.NOT.OPEN)NSW=NSW+1 281 - IF(NSW.GT.MXSW)THEN 282 - PRINT *,' !!!!!! CELSEL WARNING : You have'// 283 - - ' selected more electrodes than the'// 284 - - ' program can store ; increase MXSW.' 285 - OK=.FALSE. 286 - DO 210 K=I,NC 287 - IF(TEXT(K:K).NE.' ')WRONG(K:K)='.' 288 - 210 CONTINUE 289 - NSW=MXSW 290 - GOTO 100 291 - ENDIF 292 - INDEWS(J)=NSW 293 - USED(MXWIRE+5+J)=.TRUE. 294 - ENDIF 1 469 P=CELL D=CELSEL 4 PAGE 628 295 - ENDIF 296 - 270 CONTINUE 297 - * Check the solids, do not assign new groups to these however. 298 - DO 150 J=1,NSOLID 299 - IF(SOLTYP(J).EQ.TEXT(I:I))THEN 300 - FOUND=.TRUE. 301 - SOLSEL=.TRUE. 302 - INDSOL(J)=-1 303 - ENDIF 304 - 150 CONTINUE 305 - * See that something has been found. 306 - IF(.NOT.FOUND)THEN 307 - OK=.FALSE. 308 - WRONG(I:I)='?' 309 - ENDIF 310 - ** invalid character. 311 - ELSE 312 - WRONG(I:I)='*' 313 - OK=.FALSE. 314 - ENDIF 315 - * Next selection character. 316 - 20 CONTINUE 317 - *** Match solids and weighting field, if selected. 318 - DO 290 J=1,NWMAP 319 - IF(INDEWS(J).NE.0)THEN 320 - DO 70 I=1,NSOLID 321 - IF(SOLTYP(I).EQ.EWSTYP(J))THEN 322 - IF(INDSOL(I).GT.0.AND.INDSOL(I).NE.INDEWS(J))THEN 323 - PRINT *,' !!!!!! CELSEL WARNING : Solid ',I, 324 - - ' matches more than one field map.' 325 - OK=.FALSE. 326 - ELSE 327 - INDSOL(I)=INDEWS(J) 328 - SOLSEL=.TRUE. 329 - ENDIF 330 - ENDIF 331 - 70 CONTINUE 332 - ENDIF 333 - 290 CONTINUE 334 - *** Check that there are electrodes. 335 - IF(NSW.EQ.0.AND.SOLSEL)THEN 336 - PRINT *,' ------ CELSEL MESSAGE : You have only'// 337 - - ' selected solids that are not read out.' 338 - ELSEIF(NSW.EQ.0.AND.JFAIL.EQ.1)THEN 339 - PRINT *,' !!!!!! CELSEL WARNING : No electrodes found'// 340 - - ' that match your selection ; searching for "S".' 341 - * Consider wires. 342 - DO 80 I=1,NWIRE 343 - IF(WIRTYP(I).EQ.'S')THEN 344 - NSW=NSW+1 345 - INDSW(I)=NSW 346 - ENDIF 347 - 80 CONTINUE 348 - * Planes and tube. 349 - DO 200 I=1,5 350 - IF(PLATYP(I).EQ.'S')THEN 351 - NSW=NSW+1 352 - INDPLA(I)=NSW 353 - ENDIF 354 - 200 CONTINUE 355 - * Field map. 356 - DO 300 I=1,NWMAP 357 - IF(EWSTYP(I).EQ.'S')THEN 358 - NSW=NSW+1 359 - INDEWS(I)=NSW 360 - ENDIF 361 - 300 CONTINUE 362 - IF(NSW.GT.MXSW)NSW=MXSW 363 - IF(NSW.EQ.0)THEN 364 - PRINT *,' !!!!!! CELSEL WARNING : The cell does not'// 365 - - ' contain "S" electrodes ; nothing selected.' 366 - NSW=0 367 - ENDIF 368 - ELSEIF(NSW.EQ.0.AND.JFAIL.EQ.2)THEN 369 - PRINT *,' !!!!!! CELSEL WARNING : No electrodes found'// 370 - - ' that match your selection ; nothing selected.' 371 - ELSEIF(NSW.EQ.0.AND.JFAIL.EQ.3)THEN 372 - PRINT *,' !!!!!! CELSEL WARNING : No electrodes found'// 373 - - ' that match your selection ; terminating.' 374 - CALL QUIT 375 - ENDIF 376 - *** Print an error message if an error occured. 377 - 100 CONTINUE 378 - IF(WRONG(1:NC).NE.' ')WRITE(*,'('' !!!!!! CELSEL WARNING : An'', 379 - - '' error occured in the selection of electrodes''/ 380 - - 9X,''Selection : '',A/ 381 - - 9X,''Error messages : '',A/ 382 - - 9X,''Error codes : '', 383 - - ''"?" label not found, "#" number out of range,''/ 384 - - 26X,''"*" invalid character, "|" unmatched bracket,''/ 385 - - 26X,''"2" referenced twice, "." (partially) ignored,''/ 386 - - 26X,''"M" no such map, "P" no such plane,''/ 387 - - 26X,''"T" there is no tube.'')') 388 - - TEXT(1:NC),WRONG(1:NC) 389 - *** Print some extra output if the debug option is on/input is blank. 390 - IF(LDEBUG)THEN 391 - WRITE(LUNOUT,'('' ++++++ CELSEL DEBUG : Number of'', 392 - - '' electrode groups: '',I5)') NSW 393 - * List wires. 394 - WRITE(LUNOUT,'('' ++++++ CELSEL DEBUG : The wires have'', 395 - - '' been selected as follows:'')') 396 - DO 120 II=1,NWIRE,4 397 - WRITE(WRONG,'(25X,4(I3,'' '',A1,'' - '',I3,'', ''))') 398 - - (I,WIRTYP(I),INDSW(I),I=II,MIN(II+3,NWIRE)) 399 - DO 110 I=II,MIN(II+3,NWIRE) 400 - IF(INDSW(I).EQ.0)WRONG(34+(I-II)*13:36+(I-II)*13)='---' 1 469 P=CELL D=CELSEL 5 PAGE 629 401 - 110 CONTINUE 402 - IF(II+3.GE.NWIRE)WRONG(37+(NWIRE-II)*13:37+(NWIRE-II)*13)= 403 - - '.' 404 - WRITE(LUNOUT,'(1X,A)') WRONG(1:76) 405 - 120 CONTINUE 406 - * List planes and tubes. 407 - WRITE(LUNOUT,'('' ++++++ CELSEL DEBUG : The planes'', 408 - - '' have been selected as follows:'')') 409 - WRITE(WRONG,'(25X,4(I3,'' '',A1,'' - '',I3,'', ''))') 410 - - (I,PLATYP(I),INDPLA(I),I=1,4) 411 - DO 140 I=1,4 412 - IF(INDPLA(I).EQ.0)WRONG(21+I*13:23+I*13)='---' 413 - 140 CONTINUE 414 - WRITE(LUNOUT,'(1X,A)') WRONG(1:76) 415 - WRITE(LUNOUT,'('' ++++++ CELSEL DEBUG : The tube'', 416 - - '' has been selected as follows:'')') 417 - WRITE(WRONG,'(25X,I3,'' '',A1,'' - '',I3,''.'')') 418 - - 1,PLATYP(5),INDPLA(5) 419 - IF(INDPLA(5).EQ.0)WRONG(34:36)='---' 420 - WRITE(LUNOUT,'(1X,A)') WRONG(1:76) 421 - * List strips. 422 - DO 370 I=1,5 423 - IF(NPSTR1(I).NE.0)WRITE(LUNOUT,'('' ++++++ CELSEL'', 424 - - '' DEBUG : The x-y strips of plane '',I3, 425 - - '' have been selected as follows:'')') I 426 - DO 380 II=1,NPSTR1(I),4 427 - WRITE(WRONG,'(25X,4(I3,'' '',A1,'' - '',I3,'', ''))') 428 - - (J,PSLAB1(I,J),INDST1(I,J),J=II,MIN(II+3,NPSTR1(I))) 429 - DO 390 J=II,MIN(II+3,NPSTR1(I)) 430 - IF(INDST1(I,J).EQ.0)WRONG(34+(J-II)*13:36+(J-II)*13)='---' 431 - 390 CONTINUE 432 - IF(II+3.GE.NPSTR1(I))WRONG(37+(NPSTR1(I)-II)*13: 433 - - 37+(NPSTR1(I)-II)*13)='.' 434 - WRITE(LUNOUT,'(1X,A)') WRONG(1:76) 435 - 380 CONTINUE 436 - IF(NPSTR2(I).NE.0)WRITE(LUNOUT,'('' ++++++ CELSEL'', 437 - - '' DEBUG : The z strips of plane '',I3, 438 - - '' have been selected as follows:'')') I 439 - DO 400 II=1,NPSTR2(I),4 440 - WRITE(WRONG,'(25X,4(I3,'' '',A1,'' - '',I3,'', ''))') 441 - - (J,PSLAB2(I,J),INDST2(I,J),J=II,MIN(II+3,NPSTR2(I))) 442 - DO 410 J=II,MIN(II+3,NPSTR2(I)) 443 - IF(INDST2(I,J).EQ.0)WRONG(34+(J-II)*13:36+(J-II)*13)='---' 444 - 410 CONTINUE 445 - IF(II+3.GE.NPSTR2(I))WRONG(37+(NPSTR2(I)-II)*13: 446 - - 37+(NPSTR2(I)-II)*13)='.' 447 - WRITE(LUNOUT,'(1X,A)') WRONG(1:76) 448 - 400 CONTINUE 449 - 370 CONTINUE 450 - * List the field maps. 451 - WRITE(LUNOUT,'('' ++++++ CELSEL DEBUG : The field'', 452 - - '' maps have been selected as follows:'')') 453 - DO 310 II=1,NWMAP,4 454 - WRITE(WRONG,'(25X,4(I3,'' '',A1,'' - '',I3,'', ''))') 455 - - (I,EWSTYP(I),INDEWS(I),I=II,MIN(II+3,NWMAP)) 456 - DO 320 I=II,MIN(II+3,NWMAP) 457 - IF(INDEWS(I).EQ.0)WRONG(34+(I-II)*13:36+(I-II)*13)='---' 458 - 320 CONTINUE 459 - IF(II+3.GE.NWMAP)WRONG(37+(NWMAP-II)*13: 460 - - 37+(NWMAP-II)*13)='.' 461 - WRITE(LUNOUT,'(1X,A)') WRONG(1:76) 462 - 310 CONTINUE 463 - * List solids. 464 - WRITE(LUNOUT,'('' ++++++ CELSEL DEBUG : The solids'', 465 - - '' have been selected as follows:'')') 466 - DO 220 II=1,NSOLID,4 467 - WRITE(WRONG,'(25X,4(I3,'' '',A1,'' - '',I3,'', ''))') 468 - - (I,SOLTYP(I),INDSOL(I),I=II,MIN(II+3,NSOLID)) 469 - DO 230 I=II,MIN(II+3,NSOLID) 470 - IF(INDSOL(I).EQ.0)WRONG(34+(I-II)*13:36+(I-II)*13)='---' 471 - 230 CONTINUE 472 - IF(II+3.GE.NSOLID)WRONG(37+(NSOLID-II)*13: 473 - - 37+(NSOLID-II)*13)='.' 474 - WRITE(LUNOUT,'(1X,A)') WRONG(1:76) 475 - 220 CONTINUE 476 - ENDIF 477 - END 470 GARFIELD ================================================== P=CELL D=CELPRC 1 ============================ 0 + +DECK,CELPRC. 1 - SUBROUTINE CELPRC(LUNPRT,ISW) 2 - *----------------------------------------------------------------------- 3 - * CELPRC - Prints the current selection to unit LUNPRT 4 - * (Last changed on 5/12/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,FIELDMAP. 10.- +SEQ,SOLIDS. 11.- +SEQ,CONSTANTS. 12 - REAL XPRT,YPRT 13 - INTEGER LUNPRT,NC1,NC2,NC3,NC4,NC5,I,J,K,IOS,ISW,NCOUNT 14 - CHARACTER*20 AUX1,AUX2,AUX3,AUX4,AUX5 15 - *** Print a header. 16 - IF(ISW.EQ.0)THEN 17 - IF(NSW.EQ.0)THEN 18 - WRITE(LUNPRT,'(/'' No electrode is currently'', 19 - - '' selected for read-out.'')', 20 - - ERR=2010,IOSTAT=IOS) 21 - ELSEIF(NSW.EQ.1)THEN 22 - WRITE(LUNPRT,'(/'' A single group of electrodes'', 23 - - '' is currently selected for read-out:'')', 24 - - ERR=2010,IOSTAT=IOS) 25 - ELSE 1 470 P=CELL D=CELPRC 2 PAGE 630 26 - CALL OUTFMT(REAL(NSW),2,AUX1,NC1,'LEFT') 27 - WRITE(LUNPRT,'(/'' At present, '',A,'' groups of'', 28 - - '' electrodes are selected for read-out:'')', 29 - - ERR=2010,IOSTAT=IOS) 30 - - AUX1(1:NC1) 31 - ENDIF 32 - ENDIF 33 - *** Loop over the electrodes. 34 - DO 210 I=1,NSW 35 - IF(ISW.NE.0.AND.I.NE.ISW)GOTO 210 36 - * Print a header for this group. 37 - CALL OUTFMT(REAL(I),2,AUX1,NC1,'LEFT') 38 - WRITE(LUNPRT,'(/'' Group '',A,'' consists of:'')', 39 - - ERR=2010,IOSTAT=IOS) AUX1(1:NC1) 40 - *** Loop over the wires. 41 - DO 220 J=1,NWIRE 42 - * Pick out those with a matching id. 43 - IF(INDSW(J).NE.I)GOTO 220 44 - * Format position and potential. 45 - XPRT=X(J) 46 - YPRT=Y(J) 47 - CALL OUTFMT(REAL(J),2,AUX2,NC2,'LEFT') 48 - CALL OUTFMT(V(J) ,2,AUX5,NC5,'LEFT') 49 - IF(POLAR)THEN 50 - CALL CFMRTP(XPRT,YPRT,XPRT,YPRT,1) 51 - CALL OUTFMT(XPRT ,2,AUX3,NC3,'LEFT') 52 - CALL OUTFMT(YPRT ,2,AUX4,NC4,'LEFT') 53 - WRITE(LUNPRT,'(5X,''Wire '',A,'' with label '',A, 54 - - '' at (r,phi)=('',A,'','',A,'') and at '',A, 55 - - '' V'')',ERR=2010,IOSTAT=IOS) AUX2(1:NC2),WIRTYP(J), 56 - - AUX3(1:NC3),AUX4(1:NC4),AUX5(1:NC5) 57 - ELSE 58 - CALL OUTFMT(XPRT ,2,AUX3,NC3,'LEFT') 59 - CALL OUTFMT(YPRT ,2,AUX4,NC4,'LEFT') 60 - WRITE(LUNPRT,'(5X,''Wire '',A,'' with label '',A, 61 - - '' at (x,y)=('',A,'','',A,'') and at '',A, 62 - - '' V'')',ERR=2010,IOSTAT=IOS) AUX2(1:NC2),WIRTYP(J), 63 - - AUX3(1:NC3),AUX4(1:NC4),AUX5(1:NC5) 64 - ENDIF 65 - 220 CONTINUE 66 - *** Loop over the x-planes. 67 - DO 230 J=1,2 68 - * Pick out those with a matching id. 69 - IF(INDPLA(J).EQ.I)THEN 70 - * Format position and potential. 71 - IF(POLAR)THEN 72 - CALL OUTFMT(EXP(COPLAN(J)),2,AUX2,NC2,'LEFT') 73 - CALL OUTFMT(VTPLAN(J) ,2,AUX3,NC3,'LEFT') 74 - WRITE(LUNPRT,'(5X,''The plane with label '',A, 75 - - '' at r='',A,'' cm and at '',A,'' V'')', 76 - - ERR=2010,IOSTAT=IOS) PLATYP(J),AUX2(1:NC2), 77 - - AUX3(1:NC3) 78 - ELSE 79 - CALL OUTFMT(COPLAN(J) ,2,AUX2,NC2,'LEFT') 80 - CALL OUTFMT(VTPLAN(J) ,2,AUX3,NC3,'LEFT') 81 - WRITE(LUNPRT,'(5X,''The plane with label '',A, 82 - - '' at x='',A,'' cm and at '',A,'' V'')', 83 - - ERR=2010,IOSTAT=IOS) PLATYP(J),AUX2(1:NC2), 84 - - AUX3(1:NC3) 85 - ENDIF 86 - ENDIF 87 - * See whether there are selected strips in the plane. 88 - DO 260 K=1,NPSTR1(J) 89 - IF(INDST1(J,K).EQ.I)THEN 90 - IF(POLAR)THEN 91 - CALL OUTFMT(EXP(COPLAN(J)),2,AUX2,NC2,'LEFT') 92 - CALL OUTFMT(180*PLSTR1(J,K,1)/PI,2,AUX4,NC4,'LEFT') 93 - CALL OUTFMT(180*PLSTR1(J,K,2)/PI,2,AUX5,NC5,'LEFT') 94 - WRITE(LUNPRT,'(5X,''The strip '',A,'' < phi < '', 95 - - A,'' degrees, labeled '',A,'', of the plane'', 96 - - '' at r='',A,'' cm'')',ERR=2010,IOSTAT=IOS) 97 - - AUX4(1:NC4),AUX5(1:NC5),PSLAB1(J,K),AUX2(1:NC2) 98 - ELSE 99 - CALL OUTFMT(COPLAN(J) ,2,AUX2,NC2,'LEFT') 100 - CALL OUTFMT(PLSTR1(J,K,1),2,AUX4,NC4,'LEFT') 101 - CALL OUTFMT(PLSTR1(J,K,2),2,AUX5,NC5,'LEFT') 102 - WRITE(LUNPRT,'(5X,''The strip '',A,'' < y < '', 103 - - A,'' cm, labeled '',A,'', of the plane'', 104 - - '' at x='',A,'' cm'')',ERR=2010,IOSTAT=IOS) 105 - - AUX4(1:NC4),AUX5(1:NC5),PSLAB1(J,K),AUX2(1:NC2) 106 - ENDIF 107 - ENDIF 108 - 260 CONTINUE 109 - DO 270 K=1,NPSTR2(J) 110 - IF(INDST2(J,K).EQ.I)THEN 111 - IF(POLAR)THEN 112 - CALL OUTFMT(EXP(COPLAN(J)),2,AUX2,NC2,'LEFT') 113 - CALL OUTFMT(PLSTR2(J,K,1) ,2,AUX4,NC4,'LEFT') 114 - CALL OUTFMT(PLSTR2(J,K,2) ,2,AUX5,NC5,'LEFT') 115 - WRITE(LUNPRT,'(5X,''The strip '',A,'' < z < '', 116 - - A,'' cm, labeled '',A,'', of the plane'', 117 - - '' at r='',A,'' cm'')',ERR=2010,IOSTAT=IOS) 118 - - AUX4(1:NC4),AUX5(1:NC5),PSLAB2(J,K),AUX2(1:NC2) 119 - ELSE 120 - CALL OUTFMT(COPLAN(J) ,2,AUX2,NC2,'LEFT') 121 - CALL OUTFMT(PLSTR2(J,K,1),2,AUX4,NC4,'LEFT') 122 - CALL OUTFMT(PLSTR2(J,K,2),2,AUX5,NC5,'LEFT') 123 - WRITE(LUNPRT,'(5X,''The strip '',A,'' < z < '', 124 - - A,'' cm, labeled '',A,'', of the plane'', 125 - - '' at x='',A,'' cm'')',ERR=2010,IOSTAT=IOS) 126 - - AUX4(1:NC4),AUX5(1:NC5),PSLAB2(J,K),AUX2(1:NC2) 127 - ENDIF 128 - ENDIF 129 - 270 CONTINUE 130 - 230 CONTINUE 131 - *** Loop over the y-planes. 1 470 P=CELL D=CELPRC 3 PAGE 631 132 - DO 240 J=3,4 133 - * Pick out those with a matching id. 134 - IF(INDPLA(J).EQ.I)THEN 135 - * Format position and potential. 136 - IF(POLAR)THEN 137 - CALL OUTFMT(180*COPLAN(J)/PI,2,AUX2,NC2,'LEFT') 138 - CALL OUTFMT(VTPLAN(J) ,2,AUX3,NC3,'LEFT') 139 - WRITE(LUNPRT,'(5X,''The plane with label '',A, 140 - - '' at phi='',A,'' degrees and at '',A, 141 - - '' V'')',ERR=2010,IOSTAT=IOS) PLATYP(J), 142 - - AUX2(1:NC2),AUX3(1:NC3) 143 - ELSE 144 - CALL OUTFMT(COPLAN(J) ,2,AUX2,NC2,'LEFT') 145 - CALL OUTFMT(VTPLAN(J) ,2,AUX3,NC3,'LEFT') 146 - WRITE(LUNPRT,'(5X,''The plane with label '',A, 147 - - '' at y='',A,'' cm and at '',A,'' V'')', 148 - - ERR=2010,IOSTAT=IOS) PLATYP(J),AUX2(1:NC2), 149 - - AUX3(1:NC3) 150 - ENDIF 151 - ENDIF 152 - * See whether there are selected strips in the plane. 153 - DO 280 K=1,NPSTR1(J) 154 - IF(INDST1(J,K).EQ.I)THEN 155 - IF(POLAR)THEN 156 - CALL OUTFMT(180*COPLAN(J)/PI,2,AUX2,NC2,'LEFT') 157 - CALL OUTFMT(EXP(PLSTR1(J,K,1)),2,AUX4,NC4,'LEFT') 158 - CALL OUTFMT(EXP(PLSTR1(J,K,2)),2,AUX5,NC5,'LEFT') 159 - WRITE(LUNPRT,'(5X,''The strip '',A,'' < r < '', 160 - - A,'' cm, labeled '',A,'', of the planen at'', 161 - - '' phi='',A,'' degrees'')',ERR=2010,IOSTAT=IOS) 162 - - AUX4(1:NC4),AUX5(1:NC5),PSLAB1(J,K),AUX2(1:NC2) 163 - ELSE 164 - CALL OUTFMT(COPLAN(J) ,2,AUX2,NC2,'LEFT') 165 - CALL OUTFMT(PLSTR1(J,K,1),2,AUX4,NC4,'LEFT') 166 - CALL OUTFMT(PLSTR1(J,K,2),2,AUX5,NC5,'LEFT') 167 - WRITE(LUNPRT,'(5X,''The strip '',A,'' < x < '', 168 - - A,'' cm, labeled '',A,'', of the plane at'', 169 - - '' y='',A,'' cm'')',ERR=2010,IOSTAT=IOS) 170 - - AUX4(1:NC4),AUX5(1:NC5),PSLAB1(J,K),AUX2(1:NC2) 171 - ENDIF 172 - ENDIF 173 - 280 CONTINUE 174 - DO 290 K=1,NPSTR2(J) 175 - IF(INDST2(J,K).EQ.I)THEN 176 - IF(POLAR)THEN 177 - CALL OUTFMT(180*COPLAN(J)/PI,2,AUX2,NC2,'LEFT') 178 - CALL OUTFMT(PLSTR2(J,K,1),2,AUX4,NC4,'LEFT') 179 - CALL OUTFMT(PLSTR2(J,K,2),2,AUX5,NC5,'LEFT') 180 - WRITE(LUNPRT,'(5X,''The strip '',A,'' < z < '', 181 - - A,'' cm, labeled '',A,'', of the plane at'', 182 - - '' phi='',A,'' degrees'')',ERR=2010,IOSTAT=IOS) 183 - - AUX4(1:NC4),AUX5(1:NC5),PSLAB2(J,K),AUX2(1:NC2) 184 - ELSE 185 - CALL OUTFMT(COPLAN(J) ,2,AUX2,NC2,'LEFT') 186 - CALL OUTFMT(PLSTR2(J,K,1),2,AUX4,NC4,'LEFT') 187 - CALL OUTFMT(PLSTR2(J,K,2),2,AUX5,NC5,'LEFT') 188 - WRITE(LUNPRT,'(5X,''The strip '',A,'' < z < '', 189 - - A,'' cm, labeled '',A,'', of the plane at'', 190 - - '' y='',A,'' cm'')',ERR=2010,IOSTAT=IOS) 191 - - AUX4(1:NC4),AUX5(1:NC5),PSLAB2(J,K),AUX2(1:NC2) 192 - ENDIF 193 - ENDIF 194 - 290 CONTINUE 195 - 240 CONTINUE 196 - *** Check whether the tube has been selected. 197 - IF(INDPLA(5).EQ.I)THEN 198 - CALL OUTFMT(COTUBE,2,AUX2,NC2,'LEFT') 199 - CALL OUTFMT(VTTUBE,2,AUX3,NC3,'LEFT') 200 - WRITE(LUNPRT,'(5X,''The tube with label '',A, 201 - - '', radius='',A,'' cm and potential '',A, 202 - - '' V'')',ERR=2010,IOSTAT=IOS) 203 - - PLATYP(5),AUX2(1:NC2),AUX3(1:NC3) 204 - ENDIF 205 - * See whether there are selected strips in the tube. 206 - DO 300 K=1,NPSTR1(5) 207 - IF(INDST1(5,K).EQ.I)THEN 208 - CALL OUTFMT(180*PLSTR1(5,K,1)/PI,2,AUX4,NC4,'LEFT') 209 - CALL OUTFMT(180*PLSTR1(5,K,2)/PI,2,AUX5,NC5,'LEFT') 210 - WRITE(LUNPRT,'(5X,''The sector '',A,'' < phi < '', 211 - - A,'' degrees, labeled '',A,'', of the tube'')', 212 - - ERR=2010,IOSTAT=IOS) 213 - - AUX4(1:NC4),AUX5(1:NC5),PSLAB1(5,K) 214 - ENDIF 215 - 300 CONTINUE 216 - DO 310 K=1,NPSTR2(5) 217 - IF(INDST2(5,K).EQ.I)THEN 218 - CALL OUTFMT(PLSTR2(5,K,1),2,AUX4,NC4,'LEFT') 219 - CALL OUTFMT(PLSTR2(5,K,2),2,AUX5,NC5,'LEFT') 220 - WRITE(LUNPRT,'(5X,''The ring '',A,'' < z < '', 221 - - A,'' cm, labeled '',A,'', of the tube'')', 222 - - ERR=2010,IOSTAT=IOS) 223 - - AUX4(1:NC4),AUX5(1:NC5),PSLAB2(5,K) 224 - ENDIF 225 - 310 CONTINUE 226 - *** Loop over the weighting field maps. 227 - DO 250 K=1,NWMAP 228 - * Pick out if matching. 229 - IF(INDEWS(K).NE.I)GOTO 250 230 - * Header. 231 - CALL OUTFMT(REAL(K),2,AUX1,NC1,'LEFT') 232 - WRITE(LUNPRT,'(5X,''Finite element weighting field map '',A, 233 - - '' with label '',A,'' representing:'')', 234 - - ERR=2010,IOSTAT=IOS) AUX1(1:NC1),EWSTYP(K) 235 - * Check for matching solids. 236 - NCOUNT=0 237 - DO 10 J=1,NSOLID 1 470 P=CELL D=CELPRC 4 PAGE 632 238 - IF(INDSOL(J).NE.I)GOTO 10 239 - CALL OUTFMT(REAL(J),2,AUX5,NC5,'LEFT') 240 - * Cylinders. 241 - IF(ISOLTP(J).EQ.1)THEN 242 - CALL OUTFMT(REAL(CBUF(ISTART(J)+3)),2,AUX2,NC2,'LEFT') 243 - CALL OUTFMT(REAL(CBUF(ISTART(J)+4)),2,AUX3,NC3,'LEFT') 244 - CALL OUTFMT(REAL(CBUF(ISTART(J)+5)),2,AUX4,NC4,'LEFT') 245 - WRITE(LUNPRT,'(8X,''Cylinder '',A,'' with label '',A, 246 - - '' centered at ('', A,'','',A,'','',A,'')'')', 247 - - ERR=2010,IOSTAT=IOS) AUX5(1:NC5),SOLTYP(J), 248 - - AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) 249 - NCOUNT=NCOUNT+1 250 - * Holes. 251 - ELSEIF(ISOLTP(J).EQ.2)THEN 252 - CALL OUTFMT(REAL(CBUF(ISTART(J)+6)),2,AUX2,NC2,'LEFT') 253 - CALL OUTFMT(REAL(CBUF(ISTART(J)+7)),2,AUX3,NC3,'LEFT') 254 - CALL OUTFMT(REAL(CBUF(ISTART(J)+8)),2,AUX4,NC4,'LEFT') 255 - WRITE(LUNPRT,'(8X,''Hole '',A,'' with label '',A, 256 - - '' centered at ('', A,'','',A,'','',A,'')'')', 257 - - ERR=2010,IOSTAT=IOS) AUX5(1:NC5),SOLTYP(J), 258 - - AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) 259 - NCOUNT=NCOUNT+1 260 - * Boxes. 261 - ELSEIF(ISOLTP(J).EQ.3)THEN 262 - CALL OUTFMT(REAL(CBUF(ISTART(J)+4)),2,AUX2,NC2,'LEFT') 263 - CALL OUTFMT(REAL(CBUF(ISTART(J)+5)),2,AUX3,NC3,'LEFT') 264 - CALL OUTFMT(REAL(CBUF(ISTART(J)+6)),2,AUX4,NC4,'LEFT') 265 - WRITE(LUNPRT,'(8X,''Box '',A,'' with label '',A, 266 - - '' centered at ('', A,'','',A,'','',A,'')'')', 267 - - ERR=2010,IOSTAT=IOS) AUX5(1:NC5),SOLTYP(J), 268 - - AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) 269 - NCOUNT=NCOUNT+1 270 - * Sphere. 271 - ELSEIF(ISOLTP(J).EQ.4)THEN 272 - CALL OUTFMT(REAL(CBUF(ISTART(J)+2)),2,AUX2,NC2,'LEFT') 273 - CALL OUTFMT(REAL(CBUF(ISTART(J)+3)),2,AUX3,NC3,'LEFT') 274 - CALL OUTFMT(REAL(CBUF(ISTART(J)+4)),2,AUX4,NC4,'LEFT') 275 - WRITE(LUNPRT,'(8X,''Sphere '',A,'' with label '',A, 276 - - '' centered at ('', A,'','',A,'','',A,'')'')', 277 - - ERR=2010,IOSTAT=IOS) AUX5(1:NC5),SOLTYP(J), 278 - - AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) 279 - NCOUNT=NCOUNT+1 280 - * Other 281 - ELSE 282 - PRINT *,' !!!!!! CELPRC WARNING : Found a solid'// 283 - - ' of unknown type; not printed.' 284 - ENDIF 285 - 10 CONTINUE 286 - IF(NCOUNT.EQ.0)WRITE(LUNPRT,'(8X,''No matching solid'')', 287 - - ERR=2010,IOSTAT=IOS) 288 - 250 CONTINUE 289 - *** Next electrode identifier. 290 - 210 CONTINUE 291 - *** Now check for selected solids not assigned to a readout group. 292 - IF(ISW.EQ.0)THEN 293 - * See whether there are any. 294 - NCOUNT=0 295 - DO 30 J=1,NSOLID 296 - IF(INDSOL(J).EQ.-1)NCOUNT=NCOUNT+1 297 - 30 CONTINUE 298 - * Header. 299 - IF(NCOUNT.EQ.0)THEN 300 - WRITE(LUNPRT,'(/'' No solid is currently selected'', 301 - - '' outside read-out.'')',ERR=2010,IOSTAT=IOS) 302 - ELSE 303 - WRITE(LUNPRT,'(/'' Solids which are selected but'', 304 - - '' not read out:'')',ERR=2010,IOSTAT=IOS) 305 - ENDIF 306 - * Check for matching solids. 307 - NCOUNT=0 308 - DO 20 J=1,NSOLID 309 - IF(INDSOL(J).NE.-1)GOTO 20 310 - CALL OUTFMT(REAL(J),2,AUX5,NC5,'LEFT') 311 - * Cylinders. 312 - IF(ISOLTP(J).EQ.1)THEN 313 - CALL OUTFMT(REAL(CBUF(ISTART(J)+3)),2,AUX2,NC2,'LEFT') 314 - CALL OUTFMT(REAL(CBUF(ISTART(J)+4)),2,AUX3,NC3,'LEFT') 315 - CALL OUTFMT(REAL(CBUF(ISTART(J)+5)),2,AUX4,NC4,'LEFT') 316 - WRITE(LUNPRT,'(5X,''Cylinder '',A,'' with label '',A, 317 - - '' centered at ('', A,'','',A,'','',A,'')'')', 318 - - ERR=2010,IOSTAT=IOS) AUX5(1:NC5),SOLTYP(J), 319 - - AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) 320 - NCOUNT=NCOUNT+1 321 - * Holes. 322 - ELSEIF(ISOLTP(J).EQ.2)THEN 323 - CALL OUTFMT(REAL(CBUF(ISTART(J)+6)),2,AUX2,NC2,'LEFT') 324 - CALL OUTFMT(REAL(CBUF(ISTART(J)+7)),2,AUX3,NC3,'LEFT') 325 - CALL OUTFMT(REAL(CBUF(ISTART(J)+8)),2,AUX4,NC4,'LEFT') 326 - WRITE(LUNPRT,'(5X,''Hole '',A,'' with label '',A, 327 - - '' centered at ('', A,'','',A,'','',A,'')'')', 328 - - ERR=2010,IOSTAT=IOS) AUX5(1:NC5),SOLTYP(J), 329 - - AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) 330 - NCOUNT=NCOUNT+1 331 - * Boxes. 332 - ELSEIF(ISOLTP(J).EQ.3)THEN 333 - CALL OUTFMT(REAL(CBUF(ISTART(J)+4)),2,AUX2,NC2,'LEFT') 334 - CALL OUTFMT(REAL(CBUF(ISTART(J)+5)),2,AUX3,NC3,'LEFT') 335 - CALL OUTFMT(REAL(CBUF(ISTART(J)+6)),2,AUX4,NC4,'LEFT') 336 - WRITE(LUNPRT,'(5X,''Box '',A,'' with label '',A, 337 - - '' centered at ('', A,'','',A,'','',A,'')'')', 338 - - ERR=2010,IOSTAT=IOS) AUX5(1:NC5),SOLTYP(J), 339 - - AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) 340 - NCOUNT=NCOUNT+1 341 - * Sphere. 342 - ELSEIF(ISOLTP(J).EQ.4)THEN 343 - CALL OUTFMT(REAL(CBUF(ISTART(J)+2)),2,AUX2,NC2,'LEFT') 1 470 P=CELL D=CELPRC 5 PAGE 633 344 - CALL OUTFMT(REAL(CBUF(ISTART(J)+3)),2,AUX3,NC3,'LEFT') 345 - CALL OUTFMT(REAL(CBUF(ISTART(J)+4)),2,AUX4,NC4,'LEFT') 346 - WRITE(LUNPRT,'(5X,''Sphere '',A,'' with label '',A, 347 - - '' centered at ('', A,'','',A,'','',A,'')'')', 348 - - ERR=2010,IOSTAT=IOS) AUX5(1:NC5),SOLTYP(J), 349 - - AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) 350 - NCOUNT=NCOUNT+1 351 - * Other 352 - ELSE 353 - PRINT *,' !!!!!! CELPRC WARNING : Found a solid'// 354 - - ' of unknown type; not printed.' 355 - ENDIF 356 - 20 CONTINUE 357 - ENDIF 358 - RETURN 359 - *** I/O errors. 360 - 2010 CONTINUE 361 - PRINT *,' !!!!!! CELPRC WARNING : Error writing out the group'// 362 - - ' composition of the electrodes to unit ',LUNPRT 363 - CALL INPIOS(IOS) 364 - END 471 GARFIELD ================================================== P=CELL D=CELSTR 1 ============================ 0 + +DECK,CELSTR. 1 - SUBROUTINE CELSTR(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * CELSTR - Assigns default anode-cathode gaps, if applicable. 4 - * (Last changed on 7/12/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9 - INTEGER IFAIL,I,J 10 - REAL GAPDEF(4) 11 - *** Assume this will work. 12 - IFAIL=0 13 - *** Compute default gaps. 14 - IF(YNPLAN(1))THEN 15 - IF(YNPLAN(2))THEN 16 - GAPDEF(1)=COPLAN(2)-COPLAN(1) 17 - ELSEIF(NWIRE.LE.0)THEN 18 - GAPDEF(1)=-1 19 - ELSE 20 - GAPDEF(1)=X(1)-COPLAN(1) 21 - DO 10 I=2,NWIRE 22 - IF(X(I)-COPLAN(1).LT.GAPDEF(1))GAPDEF(1)=X(I)-COPLAN(1) 23 - 10 CONTINUE 24 - ENDIF 25 - ENDIF 26 - IF(YNPLAN(2))THEN 27 - IF(YNPLAN(1))THEN 28 - GAPDEF(2)=COPLAN(2)-COPLAN(1) 29 - ELSEIF(NWIRE.LE.0)THEN 30 - GAPDEF(2)=-1 31 - ELSE 32 - GAPDEF(2)=COPLAN(2)-X(1) 33 - DO 20 I=2,NWIRE 34 - IF(COPLAN(2)-X(I).LT.GAPDEF(2))GAPDEF(2)=COPLAN(2)-X(I) 35 - 20 CONTINUE 36 - ENDIF 37 - ENDIF 38 - IF(YNPLAN(3))THEN 39 - IF(YNPLAN(4))THEN 40 - GAPDEF(3)=COPLAN(4)-COPLAN(3) 41 - ELSEIF(NWIRE.LE.0)THEN 42 - GAPDEF(3)=-1 43 - ELSE 44 - GAPDEF(3)=Y(1)-COPLAN(3) 45 - DO 30 I=2,NWIRE 46 - IF(Y(I)-COPLAN(3).LT.GAPDEF(3))GAPDEF(3)=Y(I)-COPLAN(3) 47 - 30 CONTINUE 48 - ENDIF 49 - ENDIF 50 - IF(YNPLAN(4))THEN 51 - IF(YNPLAN(3))THEN 52 - GAPDEF(4)=COPLAN(4)-COPLAN(3) 53 - ELSEIF(NWIRE.LE.0)THEN 54 - GAPDEF(4)=-1 55 - ELSE 56 - GAPDEF(4)=COPLAN(4)-X(1) 57 - DO 40 I=2,NWIRE 58 - IF(COPLAN(4)-Y(I).LT.GAPDEF(4))GAPDEF(4)=COPLAN(4)-Y(I) 59 - 40 CONTINUE 60 - ENDIF 61 - ENDIF 62 - *** Assign. 63 - DO 50 I=1,4 64 - DO 60 J=1,NPSTR1(I) 65 - IF(PLSTR1(I,J,3).LT.0)PLSTR1(I,J,3)=GAPDEF(I) 66 - IF(PLSTR1(I,J,3).LT.0)THEN 67 - PRINT *,' !!!!!! CELSTR WARNING : Not able to set a'// 68 - - ' default anode-cathode gap for x/y-strip ',J, 69 - - ' of plane ',I,'.' 70 - IFAIL=1 71 - ENDIF 72 - 60 CONTINUE 73 - DO 70 J=1,NPSTR2(I) 74 - IF(PLSTR2(I,J,3).LT.0)PLSTR2(I,J,3)=GAPDEF(I) 75 - IF(PLSTR2(I,J,3).LT.0)THEN 76 - PRINT *,' !!!!!! CELSTR WARNING : Not able to set a'// 77 - - ' default anode-cathode gap for z-strip ',J, 78 - - ' of plane ',I,'.' 79 - IFAIL=1 80 - ENDIF 81 - 70 CONTINUE 1 471 P=CELL D=CELSTR 2 PAGE 634 82 - 50 CONTINUE 83 - END 472 GARFIELD ================================================== P=CELL D=CELSYN 1 ============================ 0 + +DECK,CELSYN. 1 - SUBROUTINE CELSYN 2 - *----------------------------------------------------------------------- 3 - * CELSYN - Outputs the cell data for use by front end programs. 4 - * (Last changed on 23/ 2/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9 - INTEGER I,NC1,NC2 10 - CHARACTER*20 AUX1,AUX2 11 - *** Cell type. 12 - IF(POLAR)THEN 13 - WRITE(6,'('' >>>>>> set cell coordinates polar'')') 14 - ELSEIF(TUBE)THEN 15 - WRITE(6,'('' >>>>>> set cell coordinates tube'')') 16 - ELSE 17 - WRITE(6,'('' >>>>>> set cell coordinates cartesian'')') 18 - ENDIF 19 - *** Potential type. 20 - WRITE(6,'('' >>>>>> set cell type '',A)') TYPE 21 - *** Dimensions. 22 - WRITE(6,'('' >>>>>> set cell xmin '',E15.8/ 23 - - '' >>>>>> set cell ymin '',E15.8/ 24 - - '' >>>>>> set cell zmin '',E15.8/ 25 - - '' >>>>>> set cell xmax '',E15.8/ 26 - - '' >>>>>> set cell ymax '',E15.8/ 27 - - '' >>>>>> set cell zmax '',E15.8/ 28 - - '' >>>>>> set cell vmin '',E15.8/ 29 - - '' >>>>>> set cell vmax '',E15.8)') 30 - - XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX,VMIN,VMAX 31 - *** Number of wires. 32 - WRITE(6,'('' >>>>>> set cell nwire '',I10)') NWIRE 33 - *** Wire data. 34 - DO 10 I=1,NWIRE 35 - CALL OUTFMT(REAL(I),2,AUX1,NC1,'LEFT') 36 - CALL OUTFMT(X(I),2,AUX2,NC2,'LEFT') 37 - WRITE(6,'('' >>>>>> set cell x'',A,1X,A)') 38 - - AUX1(1:NC1),AUX2(1:NC2) 39 - CALL OUTFMT(Y(I),2,AUX2,NC2,'LEFT') 40 - WRITE(6,'('' >>>>>> set cell y'',A,1X,A)') 41 - - AUX1(1:NC1),AUX2(1:NC2) 42 - CALL OUTFMT(V(I),2,AUX2,NC2,'LEFT') 43 - WRITE(6,'('' >>>>>> set cell v'',A,1X,A)') 44 - - AUX1(1:NC1),AUX2(1:NC2) 45 - CALL OUTFMT(E(I),2,AUX2,NC2,'LEFT') 46 - WRITE(6,'('' >>>>>> set cell e'',A,1X,A)') 47 - - AUX1(1:NC1),AUX2(1:NC2) 48 - CALL OUTFMT(D(I),2,AUX2,NC2,'LEFT') 49 - WRITE(6,'('' >>>>>> set cell d'',A,1X,A)') 50 - - AUX1(1:NC1),AUX2(1:NC2) 51 - CALL OUTFMT(W(I),2,AUX2,NC2,'LEFT') 52 - WRITE(6,'('' >>>>>> set cell w'',A,1X,A)') 53 - - AUX1(1:NC1),AUX2(1:NC2) 54 - CALL OUTFMT(U(I),2,AUX2,NC2,'LEFT') 55 - WRITE(6,'('' >>>>>> set cell u'',A,1X,A)') 56 - - AUX1(1:NC1),AUX2(1:NC2) 57 - CALL OUTFMT(DENS(I),2,AUX2,NC2,'LEFT') 58 - WRITE(6,'('' >>>>>> set cell dens'',A,1X,A)') 59 - - AUX1(1:NC1),AUX2(1:NC2) 60 - WRITE(6,'('' >>>>>> set cell type'',A,'' "'',A1,''"'')') 61 - - AUX1(1:NC1),WIRTYP(I) 62 - 10 CONTINUE 63 - *** Plane data. 64 - DO 20 I=1,4 65 - IF(YNPLAN(I))THEN 66 - WRITE(6,'('' >>>>>> set cell plane'',I1,'' 1'')') I 67 - CALL OUTFMT(COPLAN(I),2,AUX1,NC1,'LEFT') 68 - WRITE(6,'('' >>>>>> set cell coorplane'',I1,1X,A)') 69 - - I,AUX1(1:NC1) 70 - CALL OUTFMT(VTPLAN(I),2,AUX1,NC1,'LEFT') 71 - WRITE(6,'('' >>>>>> set cell voltplane'',I1,1X,A)') 72 - - I,AUX1(1:NC1) 73 - WRITE(6,'('' >>>>>> set cell typeplane'',I1,'' "'', 74 - - A1,''"'')') I,PLATYP(I) 75 - ELSE 76 - WRITE(6,'('' >>>>>> set cell plane'',I1,'' 0'')') I 77 - WRITE(6,'('' >>>>>> set cell coorplane'',I1,'' 0'')') I 78 - WRITE(6,'('' >>>>>> set cell voltplane'',I1,'' 0'')') I 79 - WRITE(6,'('' >>>>>> set cell typeplane'',I1,'' "?"'')') I 80 - ENDIF 81 - 20 CONTINUE 82 - *** Tube. 83 - IF(TUBE)THEN 84 - WRITE(6,'('' >>>>>> set cell tube 1'')') 85 - CALL OUTFMT(COTUBE,2,AUX1,NC1,'LEFT') 86 - WRITE(6,'('' >>>>>> set cell coortube '',A)') 87 - - AUX1(1:NC1) 88 - CALL OUTFMT(VTTUBE,2,AUX1,NC1,'LEFT') 89 - WRITE(6,'('' >>>>>> set cell volttube '',A)') 90 - - AUX1(1:NC1) 91 - WRITE(6,'('' >>>>>> set cell ntube '',I10)') NTUBE 92 - WRITE(6,'('' >>>>>> set cell mtube '',I10)') MTUBE 93 - WRITE(6,'('' >>>>>> set cell typetube "'',A1,''"'')') 94 - - PLATYP(5) 95 - ELSE 96 - WRITE(6,'('' >>>>>> set cell tube 0'')') 97 - WRITE(6,'('' >>>>>> set cell coortube 0'')') 98 - WRITE(6,'('' >>>>>> set cell volttube 0'')') 99 - WRITE(6,'('' >>>>>> set cell ntube 0'')') 100 - WRITE(6,'('' >>>>>> set cell mtube 0'')') 1 472 P=CELL D=CELSYN 2 PAGE 635 101 - WRITE(6,'('' >>>>>> set cell typetube 0'')') 102 - ENDIF 103 - *** Declare the cell as having been set. 104 - WRITE(6,'('' >>>>>> set cell set 1'')') 105 - END 473 GARFIELD ================================================== P=CELL D=MAGCMP 1 ============================ 0 + +DECK,MAGCMP. 1 - SUBROUTINE MAGCMP 2 - *----------------------------------------------------------------------- 3 - * MAGCMP - Reads the B field components. 4 - * (Last changed on 25/ 2/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,BFIELD. 10.- +SEQ,GLOBALS. 11.- +SEQ,MATDATA. 12.- +SEQ,PRINTPLOT. 13 - CHARACTER*(MXCHAR) FUN 14 - CHARACTER*30 AUX1,AUX2,UNIT 15 - CHARACTER*10 VARLIS(MXVAR) 16 - REAL B0,BMIN,BMAX 17 - INTEGER NWORD,NC1,NC2,NCUNIT,NVAR,I,J,K,INEXT, 18 - - ISLOT,MATSLT,NDIM,IDIM(1),IMOD, 19 - - ISCOPY,ISDATA,INPTYP,INPCMP,NRES,IFAIL,NCFUN,IENTRY, 20 - - IREFB,IREFV,IBTYPE,IDIR,IGLB 21 - LOGICAL USE(MXVAR),OK 22 - EXTERNAL INPCMP,INPTYP,MATSLT 23 - *** Identify the routine. 24 - IF(LIDENT)PRINT *,' /// ROUTINE MAGCMP ///' 25 - *** Count words. 26 - CALL INPNUM(NWORD) 27 - *** Display current state if there are no arguments. 28 - IF(NWORD.EQ.1)THEN 29 - * Scale factor. 30 - IF(ABS(BSCALE-100.0).LT.0.01)THEN 31 - UNIT(1:1)='T' 32 - NCUNIT=1 33 - ELSEIF(ABS(BSCALE-0.01).LT.0.00001)THEN 34 - UNIT(1:1)='G' 35 - NCUNIT=1 36 - ELSE 37 - CALL OUTFMT(BSCALE/100,2,AUX1,NC1,'LEFT') 38 - UNIT=' * '//AUX1(1:NC1)//' T' 39 - NCUNIT=NC1+5 40 - ENDIF 41 - * x-component. 42 - IF(POLAR)THEN 43 - WRITE(LUNOUT,'('' Magnetic field components:'', 44 - - '' Br = 0 T,'')') 45 - ELSEIF(IBXTYP.EQ.0)THEN 46 - WRITE(LUNOUT,'('' Magnetic field components: Bx = '', 47 - - ''Undefined, assumed to be 0 T,'')') 48 - ELSEIF(IBXTYP.EQ.1)THEN 49 - CALL OUTFMT(B0X*BSCALE/100,2,AUX1,NC1,'LEFT') 50 - WRITE(LUNOUT,'('' Magnetic field components: Bx = '', 51 - - A,'' T,'')') AUX1(1:NC1) 52 - ELSEIF(IBXTYP.EQ.2)THEN 53 - WRITE(LUNOUT,'('' Magnetic field components: Bx = '', 54 - - A,'' '',A,'','')') FUNB0X(1:NCB0X),UNIT(1:NCUNIT) 55 - ELSEIF(IBXTYP.EQ.3)THEN 56 - CALL OUTFMT(REAL(IRB0X),5,AUX1,NC1,'LEFT') 57 - CALL OUTFMT(REAL(IRV0X),5,AUX2,NC2,'LEFT') 58 - IF(IBXDIR.EQ.1)THEN 59 - WRITE(LUNOUT,'('' Magnetic field components:'', 60 - - '' Bx = '',A,'' '',A,'' vs''/34X,A, 61 - - '' cm as x,'')') AUX1(1:NC1),UNIT(1:NCUNIT), 62 - - AUX2(1:NC2) 63 - ELSEIF(IBXDIR.EQ.2)THEN 64 - WRITE(LUNOUT,'('' Magnetic field components:'', 65 - - '' Bx = '',A,'' '',A,'' vs''/34X,A, 66 - - '' cm as x,'')') AUX1(1:NC1),UNIT(1:NCUNIT), 67 - - AUX2(1:NC2) 68 - ELSEIF(IBXDIR.EQ.3)THEN 69 - WRITE(LUNOUT,'('' Magnetic field components:'', 70 - - '' Bx = '',A,'' '',A,'' vs''/34X,A, 71 - - '' cm as x,'')') AUX1(1:NC1),UNIT(1:NCUNIT), 72 - - AUX2(1:NC2) 73 - ELSE 74 - WRITE(LUNOUT,'('' Magnetic field components:'', 75 - - '' Bx = Invalid interpolation,'', 76 - - '' assumed to 0 T,'')') 77 - ENDIF 78 - ELSE 79 - WRITE(LUNOUT,'('' Magnetic field components: Bx = '', 80 - - '' Unknown, assumed to be 0 T,'')') 81 - ENDIF 82 - * y-component. 83 - IF(POLAR)THEN 84 - WRITE(LUNOUT,'(29X,''By = 0 T,'')') 85 - ELSEIF(IBYTYP.EQ.0)THEN 86 - WRITE(LUNOUT,'(29X,''By = Undefined, assumed to be'', 87 - - '' 0 T,'')') 88 - ELSEIF(IBYTYP.EQ.1)THEN 89 - CALL OUTFMT(B0Y*BSCALE/100,2,AUX1,NC1,'LEFT') 90 - WRITE(LUNOUT,'(29X,''By = '',A,'' T,'')') AUX1(1:NC1) 91 - ELSEIF(IBYTYP.EQ.2)THEN 92 - WRITE(LUNOUT,'(29X,''By = '',A,'' '',A,'','')') 93 - - FUNB0Y(1:NCB0Y),UNIT(1:NCUNIT) 94 - ELSEIF(IBYTYP.EQ.3)THEN 95 - CALL OUTFMT(REAL(IRB0Y),5,AUX1,NC1,'LEFT') 96 - CALL OUTFMT(REAL(IRV0Y),5,AUX2,NC2,'LEFT') 97 - IF(IBYDIR.EQ.1)THEN 1 473 P=CELL D=MAGCMP 2 PAGE 636 98 - WRITE(LUNOUT,'(29X,''By = '',A,'' '',A,'' vs''/ 99 - - 34X,A,'' cm as x,'')') 100 - - AUX1(1:NC1),UNIT(1:NCUNIT),AUX2(1:NC2) 101 - ELSEIF(IBYDIR.EQ.2)THEN 102 - WRITE(LUNOUT,'(29X,''By = '',A,'' '',A,'' vs''/ 103 - - 34X,A,'' cm as y,'')') 104 - - AUX1(1:NC1),UNIT(1:NCUNIT),AUX2(1:NC2) 105 - ELSEIF(IBYDIR.EQ.3)THEN 106 - WRITE(LUNOUT,'(29X,''By = '',A,'' '',A,'' vs''/ 107 - - 34X,A,'' cm as z,'')') 108 - - AUX1(1:NC1),UNIT(1:NCUNIT),AUX2(1:NC2) 109 - ELSE 110 - WRITE(LUNOUT,'(29X,''By = Invalid'', 111 - - '' interpolation, assumed to 0 T,'')') 112 - ENDIF 113 - ELSE 114 - WRITE(LUNOUT,'(29X,''By = Unknown, assumed to be'', 115 - - '' 0 T,'')') 116 - ENDIF 117 - * z-component. 118 - IF(IBZTYP.EQ.0)THEN 119 - WRITE(LUNOUT,'(29X,''Bz = Undefined, assumed to be'', 120 - - '' 0 T.'')') 121 - ELSEIF(IBZTYP.EQ.1)THEN 122 - CALL OUTFMT(B0Z*BSCALE/100,2,AUX1,NC1,'LEFT') 123 - WRITE(LUNOUT,'(29X,''Bz = '',A,'' T.'')') AUX1(1:NC1) 124 - ELSEIF(IBZTYP.EQ.2)THEN 125 - WRITE(LUNOUT,'(29X,''Bz = '',A,'' '',A,''.'')') 126 - - FUNB0Z(1:NCB0Z),UNIT(1:NCUNIT) 127 - ELSEIF(IBZTYP.EQ.3)THEN 128 - CALL OUTFMT(REAL(IRB0Z),5,AUX1,NC1,'LEFT') 129 - CALL OUTFMT(REAL(IRV0Z),5,AUX2,NC2,'LEFT') 130 - IF(IBZDIR.EQ.1)THEN 131 - WRITE(LUNOUT,'(29X,''Bz = '',A,'' '',A,'' vs''/ 132 - - 34X,A,'' cm as x.'')') 133 - - AUX1(1:NC1),UNIT(1:NCUNIT),AUX2(1:NC2) 134 - ELSEIF(IBZDIR.EQ.2)THEN 135 - WRITE(LUNOUT,'(29X,''Bz = '',A,'' '',A,'' vs''/ 136 - - 34X,A,'' cm as y.'')') 137 - - AUX1(1:NC1),UNIT(1:NCUNIT),AUX2(1:NC2) 138 - ELSEIF(IBZDIR.EQ.3)THEN 139 - WRITE(LUNOUT,'(29X,''Bz = '',A,'' '',A,'' vs''/ 140 - - 34X,A,'' cm as z.'')') 141 - - AUX1(1:NC1),UNIT(1:NCUNIT),AUX2(1:NC2) 142 - ELSE 143 - WRITE(LUNOUT,'(29X,''Bz = Invalid'', 144 - - '' interpolation, assumed to 0 T.'')') 145 - ENDIF 146 - ELSE 147 - WRITE(LUNOUT,'(29X,''Bz = Unknown, assumed to be'', 148 - - '' 0 T.'')') 149 - ENDIF 150 - * Range. 151 - CALL OUTFMT(BFMIN*BSCALE/100,2,AUX1,NC1,'LEFT') 152 - CALL OUTFMT(BFMAX*BSCALE/100,2,AUX2,NC2,'LEFT') 153 - WRITE(LUNOUT,'(/'' Default magnetic field range is '',A, 154 - - '' < B < '',A,'' T.'')') AUX1(1:NC1),AUX2(1:NC2) 155 - * Nothing more to be done. 156 - RETURN 157 - ENDIF 158 - *** Set the list of variables. 159 - IF(POLAR)THEN 160 - VARLIS(1)='R' 161 - VARLIS(2)='PHI' 162 - VARLIS(3)='Z' 163 - ELSE 164 - VARLIS(1)='X' 165 - VARLIS(2)='Y' 166 - VARLIS(3)='Z' 167 - ENDIF 168 - NVAR=3 169 - *** Reset the OK flag. 170 - OK=.TRUE. 171 - *** Reset the scale to Tesla. 172 - BSCALE=100.0 173 - *** Get each of the 3 components in turn. 174 - INEXT=2 175 - DO 100 K=1,3 176 - * Preset the variables. 177 - IF(K.EQ.1)THEN 178 - B0=B0X 179 - FUN=FUNB0X 180 - NCFUN=NCB0X 181 - IENTRY=IENB0X 182 - IREFB=IRB0X 183 - IREFV=IRV0X 184 - IBTYPE=IBXTYP 185 - IDIR=IBXDIR 186 - BMIN=BFXMIN 187 - BMAX=BFXMAX 188 - ELSEIF(K.EQ.2)THEN 189 - B0=B0Y 190 - FUN=FUNB0Y 191 - NCFUN=NCB0Y 192 - IENTRY=IENB0Y 193 - IREFB=IRB0Y 194 - IREFV=IRV0Y 195 - IBTYPE=IBYTYP 196 - IDIR=IBYDIR 197 - BMIN=BFYMIN 198 - BMAX=BFYMAX 199 - ELSEIF(K.EQ.3)THEN 200 - B0=B0Z 201 - FUN=FUNB0Z 202 - NCFUN=NCB0Z 203 - IENTRY=IENB0Z 1 473 P=CELL D=MAGCMP 3 PAGE 637 204 - IREFB=IRB0Z 205 - IREFV=IRV0Z 206 - IBTYPE=IBZTYP 207 - IDIR=IBZDIR 208 - BMIN=BFZMIN 209 - BMAX=BFZMAX 210 - ENDIF 211 - *** Get the component, try the format "Matrix VS {X|Y|Z} Matrix". 212 - IF(INPCMP(INEXT+1,'VS').NE.0.AND.INEXT+3.LE.NWORD)THEN 213 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAGCMP DEBUG :'', 214 - - '' Component '',I1,'': Matrix interpolation.'')') K 215 - ** Extract the name of the B vector. 216 - CALL INPSTR(INEXT,INEXT,AUX1,NC1) 217 - IF(NC1.LT.1)THEN 218 - AUX1='?' 219 - NC1=1 220 - ENDIF 221 - * Scan the list of globals for the B vector. 222 - ISDATA=0 223 - ISCOPY=0 224 - IGLB=0 225 - DO 10 I=1,NGLB 226 - IF(GLBVAR(I).EQ.AUX1(1:NC1))THEN 227 - * Ensure this is a Matrix. 228 - IF(GLBMOD(I).NE.5)THEN 229 - CALL INPMSG(INEXT,AUX1(1:NC1)// 230 - - ' is not a Matrix.') 231 - OK=.FALSE. 232 - GOTO 10 233 - ENDIF 234 - * Locate it. 235 - ISLOT=MATSLT(NINT(GLBVAL(I))) 236 - IF(ISLOT.LE.0)THEN 237 - PRINT *,' !!!!!! MAGCMP WARNING : '//AUX1(1:NC1)// 238 - - ' can not be located in the Matrix buffer.' 239 - OK=.FALSE. 240 - * Ensure it is 1-dimensional. 241 - ELSEIF(MDIM(ISLOT).NE.1)THEN 242 - CALL INPMSG(INEXT,AUX1(1:NC1)// 243 - - ' is not 1-dimensional.') 244 - OK=.FALSE. 245 - * And that it has a length of at least 1. 246 - ELSEIF(MLEN(ISLOT).LT.2)THEN 247 - CALL INPMSG(INEXT,'Length of '//AUX1(1:NC1)// 248 - - ' < 2.') 249 - OK=.FALSE. 250 - * Duplicate B, delete an old copy if there is one. 251 - ELSE 252 - IF(IREFB.NE.0)CALL MATADM('DELETE',IREFB,NDIM, 253 - - IDIM,IMOD,IFAIL) 254 - NDIM=MDIM(ISLOT) 255 - IMOD=MMOD(ISLOT) 256 - IDIM(1)=MSIZ(ISLOT,1) 257 - CALL MATADM('ALLOCATE',IREFB,NDIM,IDIM,IMOD,IFAIL) 258 - IF(IFAIL.NE.0)THEN 259 - PRINT *,' !!!!!! MAGCMP WARNING : Failed'// 260 - - ' to obtain space for a copy of B.' 261 - OK=.FALSE. 262 - ENDIF 263 - ISCOPY=MATSLT(IREFB) 264 - IF(ISCOPY.LE.0)THEN 265 - PRINT *,' !!!!!! MAGCMP WARNING : Failed'// 266 - - ' to locate the copy of B.' 267 - OK=.FALSE. 268 - ENDIF 269 - DO 20 J=1,MLEN(ISLOT) 270 - MVEC(MORG(ISCOPY)+J)=MVEC(MORG(ISLOT)+J) 271 - IF(J.EQ.1)THEN 272 - BMIN=MVEC(MORG(ISLOT)+J) 273 - BMAX=MVEC(MORG(ISLOT)+J) 274 - ELSE 275 - BMIN=MIN(BMIN,MVEC(MORG(ISLOT)+J)) 276 - BMAX=MAX(BMAX,MVEC(MORG(ISLOT)+J)) 277 - ENDIF 278 - 20 CONTINUE 279 - ENDIF 280 - * Also look for the name of the copy in the global list. 281 - ELSEIF((GLBVAR(I).EQ.'Bx field'.AND.K.EQ.1).OR. 282 - - (GLBVAR(I).EQ.'By field'.AND.K.EQ.2).OR. 283 - - (GLBVAR(I).EQ.'Bz field'.AND.K.EQ.3))THEN 284 - IGLB=I 285 - ENDIF 286 - 10 CONTINUE 287 - * Ensure we did find the vector. 288 - IF(ISCOPY.LE.0)THEN 289 - CALL INPMSG(INEXT,AUX1(1:NC1)//' is not a Global.') 290 - OK=.FALSE. 291 - INEXT=INEXT+4 292 - GOTO 100 293 - ELSE 294 - ISDATA=ISCOPY 295 - ENDIF 296 - * Add to the globals list, if not yet done. 297 - IF(IGLB.EQ.0.AND.NGLB.LT.MXVAR)THEN 298 - NGLB=NGLB+1 299 - IF(K.EQ.1)THEN 300 - GLBVAR(NGLB)='Bx field' 301 - ELSEIF(K.EQ.2)THEN 302 - GLBVAR(NGLB)='By field' 303 - ELSEIF(K.EQ.3)THEN 304 - GLBVAR(NGLB)='Bz field' 305 - ENDIF 306 - IGLB=NGLB 307 - ELSEIF(IGLB.EQ.0.AND.NGLB.GE.MXVAR)THEN 308 - PRINT *,' !!!!!! MAGCMP WARNING : Unable to obtain'// 309 - - ' naming space for an interpolation vector;'// 1 473 P=CELL D=MAGCMP 4 PAGE 638 310 - - ' do not reference the vector.' 311 - ENDIF 312 - IF(IGLB.NE.0)THEN 313 - GLBVAL(IGLB)=IREFB 314 - GLBMOD(IGLB)=5 315 - ENDIF 316 - * Debugging. 317 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAGCMP DEBUG :'', 318 - - '' Field: name='',A,'', ref='',I3,'', slot='',I3)') 319 - - AUX1(1:NC1),IREFB,ISCOPY 320 - ** Find out which direction the coordinate vector represents. 321 - IF(INPCMP(INEXT+2,'X')+INPCMP(INEXT+2,'R').NE.0)THEN 322 - IDIR=1 323 - ELSEIF(INPCMP(INEXT+2,'Y')+INPCMP(INEXT+2,'PHI').NE.0)THEN 324 - IDIR=2 325 - ELSEIF(INPCMP(INEXT+2,'Z').NE.0)THEN 326 - IDIR=3 327 - ELSE 328 - CALL INPMSG(INEXT+2,'Not a valid direction.') 329 - IDIR=0 330 - OK=.FALSE. 331 - INEXT=INEXT+4 332 - GOTO 100 333 - ENDIF 334 - * Debugging. 335 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAGCMP DEBUG :'', 336 - - '' Direction: '',I1)') IDIR 337 - ** Extract the name of the coordinate vector. 338 - CALL INPSTR(INEXT+3,INEXT+3,AUX1,NC1) 339 - IF(NC1.LT.1)THEN 340 - AUX1='?' 341 - NC1=1 342 - ENDIF 343 - * Scan the list of globals for the B vector. 344 - ISCOPY=0 345 - IGLB=0 346 - DO 30 I=1,NGLB 347 - IF(GLBVAR(I).EQ.AUX1(1:NC1))THEN 348 - * Ensure this is a Matrix. 349 - IF(GLBMOD(I).NE.5)THEN 350 - CALL INPMSG(INEXT+3,AUX1(1:NC1)// 351 - - ' is not a Matrix.') 352 - OK=.FALSE. 353 - GOTO 30 354 - ENDIF 355 - * Locate it. 356 - ISLOT=MATSLT(NINT(GLBVAL(I))) 357 - IF(ISLOT.LE.0)THEN 358 - PRINT *,' !!!!!! MAGCMP WARNING : '//AUX1(1:NC1)// 359 - - ' can not be located in the Matrix buffer.' 360 - OK=.FALSE. 361 - * Ensure it is 1-dimensional. 362 - ELSEIF(MDIM(ISLOT).NE.1)THEN 363 - CALL INPMSG(INEXT+3,AUX1(1:NC1)// 364 - - ' is not 1-dimensional.') 365 - OK=.FALSE. 366 - * Ensure the length is the same as the B vector. 367 - ELSEIF(MLEN(ISLOT).NE.MLEN(ISDATA))THEN 368 - CALL INPMSG(INEXT+3, 369 - - 'Lengths of B and coord differ.') 370 - OK=.FALSE. 371 - * Duplicate coordinate, delete an old copy if there is one. 372 - ELSE 373 - IF(IREFV.NE.0)CALL MATADM('DELETE',IREFV,NDIM, 374 - - IDIM,IMOD,IFAIL) 375 - NDIM=MDIM(ISLOT) 376 - IMOD=MMOD(ISLOT) 377 - IDIM(1)=MSIZ(ISLOT,1) 378 - CALL MATADM('ALLOCATE',IREFV,NDIM,IDIM,IMOD,IFAIL) 379 - IF(IFAIL.NE.0)THEN 380 - PRINT *,' !!!!!! MAGCMP WARNING : Failed'// 381 - - ' to obtain space for a copy of the'// 382 - - ' coordinate vector.' 383 - OK=.FALSE. 384 - ENDIF 385 - ISCOPY=MATSLT(IREFV) 386 - IF(ISCOPY.LE.0)THEN 387 - PRINT *,' !!!!!! MAGCMP WARNING : Failed'// 388 - - ' locate the copy of a coordinate'// 389 - - ' vector.' 390 - OK=.FALSE. 391 - ENDIF 392 - DO 40 J=1,MLEN(ISLOT) 393 - MVEC(MORG(ISCOPY)+J)=MVEC(MORG(ISLOT)+J) 394 - 40 CONTINUE 395 - ENDIF 396 - * Also look for the name of the copy in the global list. 397 - ELSEIF((GLBVAR(I).EQ.'Bx coord'.AND.K.EQ.1).OR. 398 - - (GLBVAR(I).EQ.'By coord'.AND.K.EQ.2).OR. 399 - - (GLBVAR(I).EQ.'Bz coord'.AND.K.EQ.3))THEN 400 - IGLB=I 401 - ENDIF 402 - 30 CONTINUE 403 - * Be sure we found the vector. 404 - IF(ISCOPY.LE.0)THEN 405 - CALL INPMSG(INEXT+3,AUX1(1:NC1)//' is not a Global.') 406 - OK=.FALSE. 407 - INEXT=INEXT+4 408 - GOTO 100 409 - ENDIF 410 - * Add to the globals list, if not yet done. 411 - IF(IGLB.EQ.0.AND.NGLB.LT.MXVAR)THEN 412 - NGLB=NGLB+1 413 - IF(K.EQ.1)THEN 414 - GLBVAR(NGLB)='Bx coord' 415 - ELSEIF(K.EQ.2)THEN 1 473 P=CELL D=MAGCMP 5 PAGE 639 416 - GLBVAR(NGLB)='By coord' 417 - ELSEIF(K.EQ.3)THEN 418 - GLBVAR(NGLB)='Bz coord' 419 - ENDIF 420 - IGLB=NGLB 421 - ELSEIF(IGLB.EQ.0.AND.NGLB.GE.MXVAR)THEN 422 - PRINT *,' !!!!!! MAGCMP WARNING : Unable to obtain'// 423 - - ' naming space for an interpolation vector;'// 424 - - ' do not reference the vector.' 425 - ENDIF 426 - IF(IGLB.NE.0)THEN 427 - GLBVAL(IGLB)=IREFV 428 - GLBMOD(IGLB)=5 429 - ENDIF 430 - * Debugging. 431 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAGCMP DEBUG :'', 432 - - '' Coordinates: name='',A,'', ref='',I3,'', slot='', 433 - - I3)') AUX1(1:NC1),IREFV,ISCOPY 434 - * Remember the source of B. 435 - IBTYPE=3 436 - ** Update the pointer. 437 - INEXT=INEXT+4 438 - *** Try the fixed value format. 439 - ELSEIF(INPTYP(INEXT).EQ.1.OR.INPTYP(INEXT).EQ.2)THEN 440 - * Read the value. 441 - CALL INPCHK(INEXT,2,IFAIL) 442 - IF(IFAIL.EQ.0)THEN 443 - CALL INPRDR(INEXT,B0,0.0) 444 - IBTYPE=1 445 - ENDIF 446 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAGCMP DEBUG :'', 447 - - '' Component '',I1,'': fixed value '',E10.3, 448 - - '', IFAIL='',I1)') K,B0,IFAIL 449 - * Update the limits. 450 - BMIN=B0 451 - BMAX=B0 452 - * Update the pointer. 453 - INEXT=INEXT+1 454 - *** Try the formula format. 455 - ELSEIF(INEXT.LE.NWORD)THEN 456 - * Retrieve the formula. 457 - CALL INPSTR(INEXT,INEXT,FUN,NCFUN) 458 - IF(NCFUN.LT.1)THEN 459 - FUN='?' 460 - NCFUN=1 461 - ENDIF 462 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAGCMP DEBUG :'', 463 - - '' Component '',I1,'': formula '',A)') K,FUN(1:NCFUN) 464 - * Clear old entry point, if there is one. 465 - IF(IENTRY.NE.0)CALL ALGCLR(IENTRY) 466 - * Translate it. 467 - IF(INDEX(FUN(1:NCFUN),'@').NE.0)THEN 468 - NRES=1 469 - PRINT *,' ------ MAGCMP MESSAGE : Please edit the'// 470 - - ' function.' 471 - CALL ALGEDT(VARLIS,NVAR,IENTRY,USE,NRES) 472 - IFAIL=0 473 - * Usual function translation if not. 474 - ELSE 475 - CALL ALGPRE(FUN(1:NCFUN),NCFUN,VARLIS,NVAR,NRES,USE, 476 - - IENTRY,IFAIL) 477 - ENDIF 478 - * Check return code of translation. 479 - IF(IFAIL.NE.0)THEN 480 - PRINT *,' !!!!!! MAGCMP WARNING : Error translating'// 481 - - ' a B function.' 482 - OK=.FALSE. 483 - CALL ALGCLR(IENTRY) 484 - * Check number of results returned by the function. 485 - ELSEIF(NRES.NE.1)THEN 486 - PRINT *,' !!!!!! MAGCMP WARNING : A B function'// 487 - - ' does not return 1 result.' 488 - OK=.FALSE. 489 - CALL ALGCLR(IENTRY) 490 - ELSE 491 - * Remember the source of B. 492 - IBTYPE=2 493 - ENDIF 494 - * Set the limits. 495 - BMIN=0 496 - BMAX=0 497 - * Update the pointer. 498 - INEXT=INEXT+1 499 - *** Unknown format. 500 - ELSE 501 - * Issue message. 502 - CALL INPMSG(INEXT,'Not a recognised format') 503 - * Set type to non-set. 504 - IBTYPE=0 505 - * Set the limits. 506 - BMIN=0 507 - BMAX=0 508 - * Set OK flag. 509 - OK=.FALSE. 510 - ENDIF 511 - *** Transfer the results. 512 - IF(K.EQ.1)THEN 513 - B0X=B0 514 - FUNB0X=FUN 515 - NCB0X=NCFUN 516 - IENB0X=IENTRY 517 - IRB0X=IREFB 518 - IRV0X=IREFV 519 - IBXTYP=IBTYPE 520 - IBXDIR=IDIR 521 - BFXMIN=BMIN 1 473 P=CELL D=MAGCMP 6 PAGE 640 522 - BFXMAX=BMAX 523 - ELSEIF(K.EQ.2)THEN 524 - B0Y=B0 525 - FUNB0Y=FUN 526 - NCB0Y=NCFUN 527 - IENB0Y=IENTRY 528 - IRB0Y=IREFB 529 - IRV0Y=IREFV 530 - IBYTYP=IBTYPE 531 - IBYDIR=IDIR 532 - BFYMIN=BMIN 533 - BFYMAX=BMAX 534 - ELSEIF(K.EQ.3)THEN 535 - B0Z=B0 536 - FUNB0Z=FUN 537 - NCB0Z=NCFUN 538 - IENB0Z=IENTRY 539 - IRB0Z=IREFB 540 - IRV0Z=IREFV 541 - IBZTYP=IBTYPE 542 - IBZDIR=IDIR 543 - BFZMIN=BMIN 544 - BFZMAX=BMAX 545 - ENDIF 546 - *** Next component. 547 - 100 CONTINUE 548 - *** Now look for other elements, such as units. 549 - DO 50 I=INEXT,NWORD 550 - IF(INPCMP(I,'T#ESLA').NE.0)THEN 551 - BSCALE=100.0 552 - ELSEIF(INPCMP(I,'G#AUSS')+INPCMP(I,'OE#RSTED').NE.0)THEN 553 - BSCALE=0.01 554 - ELSEIF(INPCMP(I,'V.MICROSEC/CM2').NE.0)THEN 555 - BSCALE=1.0 556 - ELSE 557 - CALL INPMSG(I,'Not a known keyword') 558 - OK=.FALSE. 559 - ENDIF 560 - 50 CONTINUE 561 - *** Dump the error messages. 562 - CALL INPERR 563 - *** Ensure no extra fields have been entered in polar coordinates. 564 - IF(POLAR.AND.(IBXTYP.NE.1.OR.B0X.NE.0.OR. 565 - - IBXTYP.NE.1.OR.B0X.NE.0))THEN 566 - PRINT *,' !!!!!! MAGCMP WARNING : In polar coordinates,'// 567 - - ' only Bz may be non-zero; Br and Bphi ignored.' 568 - OK=.FALSE. 569 - ENDIF 570 - *** See whether we have all components. 571 - IF(IBXTYP.EQ.0.OR.IBYTYP.EQ.0.OR.IBZTYP.EQ.0)THEN 572 - PRINT *,' !!!!!! MAGCMP WARNING : Not all magnetic'// 573 - - ' field components have been entered.' 574 - OK=.FALSE. 575 - ENDIF 576 - *** See whether we continue. 577 - IF(JFAIL.EQ.2.AND..NOT.OK)THEN 578 - PRINT *,' ###### MAGCMP ERROR : No magnetic field'// 579 - - ' because of the above errors.' 580 - IBXTYP=0 581 - IBYTYP=0 582 - IBZTYP=0 583 - MAGSRC=0 584 - MAGOK=.FALSE. 585 - RETURN 586 - ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN 587 - PRINT *,' ###### MAGCMP ERROR : Program terminated'// 588 - - ' because of the above errors.' 589 - CALL QUIT 590 - RETURN 591 - ENDIF 592 - *** Determine the range of the magnetic field. 593 - IF(IBXTYP.EQ.2.OR.IBYTYP.EQ.2.OR.IBZTYP.EQ.2)THEN 594 - BFMIN=0 595 - BFMAX=5 596 - ELSE 597 - BFMIN=SQRT(BFXMIN**2+BFYMIN**2+BFZMIN**2) 598 - BFMAX=SQRT(BFXMAX**2+BFYMAX**2+BFZMAX**2) 599 - ENDIF 600 - *** This B field is not defined by a field map. 601 - MAGSRC=1 602 - *** Set the magnetic field flag. 603 - IF((IBXTYP.EQ.1.AND.B0X.NE.0).OR.IBXTYP.GE.2.OR. 604 - - (IBYTYP.EQ.1.AND.B0Y.NE.0).OR.IBYTYP.GE.2.OR. 605 - - (IBZTYP.EQ.1.AND.B0Z.NE.0).OR.IBZTYP.GE.2)THEN 606 - MAGOK=.TRUE. 607 - ELSE 608 - MAGOK=.FALSE. 609 - ENDIF 610 - END 474 GARFIELD ================================================== P=CELL D=MAGINP 1 ============================ 0 + +DECK,MAGINP. 1 - SUBROUTINE MAGINP 2 - *----------------------------------------------------------------------- 3 - * MAGINP - Routine reading the magnetic field data from input file. 4 - * VARIABLES : IUNIT : Unit system (0: internal, 1: Gauss, 2: T) 5 - * (Last changed on 13/ 2/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,BFIELD. 10.- +SEQ,PRINTPLOT. 11 - CHARACTER*(MXCHAR) STRING 12 - INTEGER INPCMP,NWORD,NC,IFAIL1,IFAIL2,I 13 - REAL SUSGSR,SUSWRR 1 474 P=CELL D=MAGINP 2 PAGE 641 14 - EXTERNAL INPCMP 0 15-+ +SELF,IF=AST. 16 - EXTERNAL ASTCCH 0 17-+ +SELF. 18 - *** Identify the routine. 19 - IF(LIDENT)PRINT *,' /// ROUTINE MAGINP ///' 20 - *** Print a heading for this section. 21 - WRITE(*,'(''1'')') 22 - PRINT *,' ================================================' 23 - PRINT *,' ========== Start of B-field input ==========' 24 - PRINT *,' ================================================' 25 - PRINT *,' ' 26 - *** Start the input loop. 27 - CALL INPPRM('B field','NEW-PRINT') 28 - 10 CONTINUE 29 - CALL INPWRD(NWORD) 0 30-+ +SELF,IF=AST. 31 - *** Set up ASTCCH as the condition handler. 32 - CALL LIB$ESTABLISH(ASTCCH) 0 33-+ +SELF. 34 - CALL INPSTR(1,1,STRING,NC) 35 - IF(NWORD.EQ.0)GOTO 10 36 - *** Return to calling routine if the instruction contains an &. 37 - IF(STRING(1:1).EQ.'&')THEN 38 - GOTO 20 39 - *** Magnetic field components. 40 - ELSEIF(INPCMP(1,'COMP#ONENTS').NE.0)THEN 41 - CALL MAGCMP 42 - *** Reset the magnetic field. 43 - ELSEIF(INPCMP(1,'RES#ET').NE.0)THEN 44 - IF(NWORD.EQ.1)THEN 45 - CALL MAGINT 46 - ELSE 47 - DO 30 I=2,NWORD 48 - IF(INPCMP(I,'COMP#ONENTS').NE.0)THEN 49 - MAGSRC=0 50 - ELSEIF(INPCMP(I,'PERM#EABILITY').NE.0)THEN 51 - ALFA=0 52 - ELSE 53 - CALL INPMSG(I,'Not a known item.') 54 - ENDIF 55 - 30 CONTINUE 56 - ENDIF 57 - *** Permeability. 58 - ELSEIF(INPCMP(1,'PERM#EABILITY').NE.0)THEN 59 - ** No arguments, print current values. 60 - IF(NWORD.EQ.1)THEN 61 - WRITE(LUNOUT,'(/'' Currently, the permeabilities'', 62 - - '' are set to the following values:'',/, 63 - - 5X,''Wires: '',E15.8,'' [Arbitrary units],'',/, 64 - - 5X,''Gas : '',E15.8,'' [Arbitrary units]'',/, 65 - - '' which leads to Alpha = '',E15.8/)') 66 - - SUSWIR,SUSGAS,ALFA 67 - ** One argument: look for the IGNORE keyword, otherwise reject. 68 - ELSEIF(NWORD.EQ.2)THEN 69 - IF(INPCMP(2,'IGN#ORE').NE.0)THEN 70 - ALFA=0.0 71 - SUSWIR=1.0 72 - SUSGAS=1.0 73 - ELSE 74 - CALL INPMSG(2,'Not a valid option. ') 75 - ENDIF 76 - ** Two arguments: specification of new values. 77 - ELSEIF(NWORD.EQ.3)THEN 78 - CALL INPCHK(2,2,IFAIL1) 79 - CALL INPCHK(3,2,IFAIL2) 80 - CALL INPRDR(2,SUSWRR,1.0) 81 - CALL INPRDR(3,SUSGSR,1.0) 82 - * Reject negative permeabilities. 83 - IF(SUSWRR.LT.0.0.AND.IFAIL1.EQ.0)THEN 84 - CALL INPMSG(2,'Wire permeability not > 0.') 85 - IFAIL1=1 86 - ELSE 87 - SUSWIR=SUSWRR 88 - ENDIF 89 - IF(SUSGSR.LT.0.0.AND.IFAIL2.EQ.0)THEN 90 - CALL INPMSG(2,'Gas permeability not > 0.') 91 - IFAIL2=1 92 - ELSE 93 - SUSGAS=SUSGSR 94 - ENDIF 95 - * Calculate ALFA, the coefficient needed in the rest of the program. 96 - IF(SUSWIR.LE.0.AND.SUSGAS.LE.0)THEN 97 - ALFA=0 98 - ELSE 99 - ALFA=(SUSWIR-SUSGAS)/(SUSWIR+SUSGAS) 100 - ENDIF 101 - ** Strange number of arguments. 102 - ELSE 103 - PRINT *,' !!!!!! MAGINP WARNING : PERMEABILITY'// 104 - - ' needs up to 2 arguments ; line is ignored.' 105 - ENDIF 106 - *** It is not possible to get here if the option was recognised. 107 - ELSE 108 - CALL INPSTR(1,1,STRING,NC) 109 - PRINT *,' !!!!!! MAGINP WARNING : '//STRING(1:NC)//' is'// 110 - - ' not a valid instruction ; line is ignored.' 111 - ENDIF 112 - *** Dump error messages. 113 - CALL INPERR 114 - *** And return for a new input line. 115 - GOTO 10 1 474 P=CELL D=MAGINP 3 PAGE 642 116 - 20 CONTINUE 117 - *** Register the amount of CPU time used for reading these data. 118 - CALL TIMLOG('Reading the magnetic field section: ') 119 - END 475 GARFIELD ================================================== P=CELL D=MAGINT 1 ============================ 0 + +DECK,MAGINT. 1 - SUBROUTINE MAGINT 2 - *----------------------------------------------------------------------- 3 - * MAGINT - Initialises the B field. 4 - * (Last changed on 13/ 2/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,BFIELD. 9 - *** Set the overall flag. 10 - MAGOK=.FALSE. 11 - *** Source of the B field. 12 - MAGSRC=0 13 - IBXTYP=0 14 - IBYTYP=0 15 - IBZTYP=0 16 - *** Components when using a fixed field. 17 - B0X=0 18 - B0Y=0 19 - B0Z=0 20 - *** Matrix references when interpolating. 21 - IRB0X=0 22 - IRB0Y=0 23 - IRB0Z=0 24 - IRV0X=0 25 - IRV0Y=0 26 - IRV0Z=0 27 - *** Directions when interpolating. 28 - IBXDIR=0 29 - IBYDIR=0 30 - IBZDIR=0 31 - *** Function strings and lengths. 32 - FUNB0X=' ' 33 - FUNB0Y=' ' 34 - FUNB0Z=' ' 35 - NCB0X=1 36 - NCB0Y=1 37 - NCB0Z=1 38 - IENB0X=0 39 - IENB0Y=0 40 - IENB0Z=0 41 - *** Permeability. 42 - ALFA=0 43 - SUSWIR=1 44 - SUSGAS=1 45 - *** Default unit: Tesla. 46 - BSCALE=100.0 47 - *** B field range. 48 - BFXMIN=0 49 - BFXMAX=0 50 - BFYMIN=0 51 - BFYMAX=0 52 - BFZMIN=0 53 - BFZMAX=0 54 - BFMIN=0 55 - BFMAX=0 56 - END 476 GARFIELD ================================================== P=CELL D=MAPCHK 1 ============================ 0 + +DECK,MAPCHK. 1 - SUBROUTINE MAPCHK(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MAPCHK - Checks the element aspect ratio and measure range. 4 - * (Last changed on 26/ 1/99) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,FIELDMAP. 10 - REAL DMIN,DMAX,DIST,SMIN,SMAX,SURF,RMIN,RMAX,STEP 11 - INTEGER I,J,K,NP,NCHA,IFAIL1,IFAIL2,IASP,IVOL,IFAIL 12 - *** By default, this should work. 13 - IFAIL=0 14 - *** Ensure there are some triangles / tetrahedrons. 15 - IF(NMAP.LE.0)THEN 16 - PRINT *,' !!!!!! MAPCHK WARNING : No elements in the'// 17 - - ' current map ; histograms not made, map rejected.' 18 - IFAIL=1 19 - RETURN 20 - ENDIF 21 - *** Compute the range of volumes. 22 - DO 40 I=1,NMAP 23 - IF(MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3)THEN 24 - SURF=ABS( 25 - - (XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1))- 26 - - (YMAP(I,3)-YMAP(I,1))*(XMAP(I,2)-XMAP(I,1)))/2 27 - ELSEIF(MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13)THEN 28 - SURF=ABS( 29 - - (XMAP(I,4)-XMAP(I,1))*( 30 - - (YMAP(I,2)-YMAP(I,1))*(ZMAP(I,3)-ZMAP(I,1))- 31 - - (YMAP(I,3)-YMAP(I,1))*(ZMAP(I,2)-ZMAP(I,1)))+ 32 - - (YMAP(I,4)-YMAP(I,1))*( 33 - - (ZMAP(I,2)-ZMAP(I,1))*(XMAP(I,3)-XMAP(I,1))- 34 - - (ZMAP(I,3)-ZMAP(I,1))*(XMAP(I,2)-XMAP(I,1)))+ 35 - - (ZMAP(I,4)-ZMAP(I,1))*( 36 - - (XMAP(I,2)-XMAP(I,1))*(YMAP(I,3)-YMAP(I,1))- 37 - - (XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1))))/6 38 - ELSEIF(MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16)THEN 1 476 P=CELL D=MAPCHK 2 PAGE 643 39 - SURF=ABS( 40 - - (XMAP(I,4)-XMAP(I,1))*( 41 - - (YMAP(I,2)-YMAP(I,1))*(ZMAP(I,3)-ZMAP(I,1))- 42 - - (YMAP(I,3)-YMAP(I,1))*(ZMAP(I,2)-ZMAP(I,1)))+ 43 - - (YMAP(I,4)-YMAP(I,1))*( 44 - - (ZMAP(I,2)-ZMAP(I,1))*(XMAP(I,3)-XMAP(I,1))- 45 - - (ZMAP(I,3)-ZMAP(I,1))*(XMAP(I,2)-XMAP(I,1)))+ 46 - - (ZMAP(I,4)-ZMAP(I,1))*( 47 - - (XMAP(I,2)-XMAP(I,1))*(YMAP(I,3)-YMAP(I,1))- 48 - - (XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1)))) 49 - ELSE 50 - SURF=0 51 - ENDIF 52 - IF(I.EQ.0)THEN 53 - SMIN=SURF 54 - SMAX=SURF 55 - ELSE 56 - SMIN=MIN(SMIN,SURF) 57 - SMAX=MAX(SMAX,SURF) 58 - ENDIF 59 - 40 CONTINUE 60 - *** Number of bins. 61 - NCHA=MIN(100,MXCHA) 62 - *** Check we do have a range and round it. 63 - SMIN=MAX(0.0,SMIN-0.1*(SMAX-SMIN)) 64 - SMAX=SMAX+0.1*(SMAX-SMIN) 65 - IF(SMIN.EQ.SMAX)THEN 66 - SMIN=SMIN-(1+ABS(SMIN)) 67 - SMAX=SMAX+(1+ABS(SMAX)) 68 - ENDIF 69 - CALL ROUND(SMIN,SMAX,NCHA,'LARGER,COARSER',STEP) 70 - *** Book histograms. 71 - CALL HISADM('ALLOCATE',IASP,NCHA,0.0,100.0,.FALSE.,IFAIL1) 72 - CALL HISADM('ALLOCATE',IVOL,NCHA,SMIN,SMAX,.FALSE.,IFAIL2) 73 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN 74 - PRINT *,' !!!!!! MAPCHK WARNING : Unable to allocate'// 75 - - ' histograms ; no check done.' 76 - CALL HISADM('DELETE',IASP,NCHA,0.0,100.0,.FALSE.,IFAIL1) 77 - CALL HISADM('DELETE',IVOL,NCHA,0.0,100.0,.FALSE.,IFAIL2) 78 - RETURN 79 - ENDIF 80 - *** Set the number of vertices. 81 - IF(MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3)THEN 82 - NP=3 83 - ELSEIF(MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13)THEN 84 - NP=4 85 - ELSEIF(MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16)THEN 86 - NP=4 87 - ELSE 88 - NP=0 89 - ENDIF 90 - *** Loop over all triangles or tetrahedrons. 91 - DO 10 I=1,NMAP 92 - * And over all pairs of vertices. 93 - DO 20 J=1,NP-1 94 - DO 30 K=J+1,NP 95 - * Compute distance. 96 - DIST=SQRT((XMAP(I,J)-XMAP(I,K))**2+(YMAP(I,J)-YMAP(I,K))**2+ 97 - - (ZMAP(I,J)-ZMAP(I,K))**2) 98 - * And update maximum/minimum. 99 - IF(K.EQ.2)THEN 100 - DMIN=DIST 101 - DMAX=DIST 102 - ELSE 103 - DMIN=MIN(DMIN,DIST) 104 - DMAX=MAX(DMAX,DIST) 105 - ENDIF 106 - * Next vertex pair. 107 - 30 CONTINUE 108 - 20 CONTINUE 109 - * Check for null-sizes. 110 - IF(DMIN.LE.0)THEN 111 - PRINT *,' !!!!!! MAPCHK WARNING : Found a shape with a'// 112 - - ' zero-length vertex separation; map rejected.' 113 - IFAIL=1 114 - GOTO 10 115 - ENDIF 116 - * Histogramming. 117 - CALL HISENT(IASP,DMAX/DMIN,1.0) 118 - ** Compute the surface or volume. 119 - IF(MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3)THEN 120 - SURF=ABS( 121 - - (XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1))- 122 - - (YMAP(I,3)-YMAP(I,1))*(XMAP(I,2)-XMAP(I,1)))/2 123 - ELSEIF(MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13)THEN 124 - SURF=ABS( 125 - - (XMAP(I,4)-XMAP(I,1))*( 126 - - (YMAP(I,2)-YMAP(I,1))*(ZMAP(I,3)-ZMAP(I,1))- 127 - - (YMAP(I,3)-YMAP(I,1))*(ZMAP(I,2)-ZMAP(I,1)))+ 128 - - (YMAP(I,4)-YMAP(I,1))*( 129 - - (ZMAP(I,2)-ZMAP(I,1))*(XMAP(I,3)-XMAP(I,1))- 130 - - (ZMAP(I,3)-ZMAP(I,1))*(XMAP(I,2)-XMAP(I,1)))+ 131 - - (ZMAP(I,4)-ZMAP(I,1))*( 132 - - (XMAP(I,2)-XMAP(I,1))*(YMAP(I,3)-YMAP(I,1))- 133 - - (XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1))))/6 134 - ELSEIF(MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16)THEN 135 - SURF=ABS( 136 - - (XMAP(I,4)-XMAP(I,1))*( 137 - - (YMAP(I,2)-YMAP(I,1))*(ZMAP(I,3)-ZMAP(I,1))- 138 - - (YMAP(I,3)-YMAP(I,1))*(ZMAP(I,2)-ZMAP(I,1)))+ 139 - - (YMAP(I,4)-YMAP(I,1))*( 140 - - (ZMAP(I,2)-ZMAP(I,1))*(XMAP(I,3)-XMAP(I,1))- 141 - - (ZMAP(I,3)-ZMAP(I,1))*(XMAP(I,2)-XMAP(I,1)))+ 142 - - (ZMAP(I,4)-ZMAP(I,1))*( 143 - - (XMAP(I,2)-XMAP(I,1))*(YMAP(I,3)-YMAP(I,1))- 144 - - (XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1)))) 1 476 P=CELL D=MAPCHK 3 PAGE 644 145 - ELSE 146 - SURF=0 147 - ENDIF 148 - * Check for null-sizes. 149 - IF(SURF.LE.0)THEN 150 - PRINT *,' !!!!!! MAPCHK WARNING : Found a shape with a'// 151 - - ' zero surface or volume; map rejected.' 152 - IFAIL=1 153 - GOTO 10 154 - ENDIF 155 - * Histogramming. 156 - CALL HISENT(IVOL,SURF,1.0) 157 - * Update maxima and minima. 158 - IF(I.EQ.1)THEN 159 - SMIN=SURF 160 - SMAX=SURF 161 - RMIN=DMAX/DMIN 162 - RMAX=DMAX/DMIN 163 - ELSE 164 - SMIN=MIN(SMIN,SURF) 165 - SMAX=MAX(SMAX,SURF) 166 - RMIN=MIN(RMIN,DMAX/DMIN) 167 - RMAX=MAX(RMAX,DMAX/DMIN) 168 - ENDIF 169 - * Next triangle or tetrahedron. 170 - 10 CONTINUE 171 - *** Final output, aspect ratio plot. 172 - C CALL GRAOPT('LOG-Y') 173 - CALL HISPLT(IASP,'Largest / smallest vertex distance', 174 - - 'Aspect ratio',.TRUE.) 175 - CALL GRNEXT 176 - CALL GRALOG('Aspect ratio histogram') 177 - CALL HISADM('DELETE',IASP,0,0.0,0.0,.FALSE.,IFAIL1) 178 - C CALL GRAOPT('LIN-Y') 179 - * Volumes. 180 - CALL GRAOPT('LOG-Y') 181 - CALL HISPLT(IVOL,'Surface [cm2] or Volume [cm3]', 182 - - 'Element measure',.TRUE.) 183 - CALL GRNEXT 184 - CALL GRALOG('Element measure') 185 - CALL HISADM('DELETE',IVOL,0,0.0,0.0,.FALSE.,IFAIL2) 186 - CALL GRAOPT('LIN-Y') 187 - * Printout. 188 - WRITE(LUNOUT,'('' Aspect ratios: ''/ 189 - - 5X,''Smallest: '',F10.3/5X,''Largest: '',F10.3/ 190 - - '' Volumes or Surfaces: ''/ 191 - - 5X,''Smallest: '',E10.3/5X,''Largest: '',E10.3)') 192 - - RMIN,RMAX,SMIN,SMAX 193 - *** Record the time needed. 194 - CALL TIMLOG('Checking the mesh') 195 - END 477 GARFIELD ================================================== P=CELL D=MAPEPS 1 ============================ 0 + +DECK,MAPEPS. 1 - SUBROUTINE MAPEPS(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MAPEPS - Sorts the dielectric constants and the conductivities. 4 - * (Last changed on 29/11/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,FIELDMAP. 9.- +SEQ,PRINTPLOT. 10 - INTEGER IND(MXEPS),INEW,I,II,J,IFAIL 11 - REAL AUX 12 - *** Identify the routine if requested. 13 - IF(LIDENT)PRINT *,' /// ROUTINE MAPEPS ///' 14 - *** Assume the routine will fail. 15 - IFAIL=1 16 - *** Sort the epsilons. 17 - CALL SORTZV(EPSMAT,IND,NEPS,0,0,0) 18 - *** Attribute new numbers to the volumes. 19 - DO 10 I=1,NMAP 20 - * Search what the old index of this material was. 21 - DO 20 J=1,NEPS 22 - IF(IND(J).EQ.MATMAP(I))THEN 23 - INEW=J 24 - GOTO 30 25 - ENDIF 26 - 20 CONTINUE 27 - PRINT *,' !!!!!! MAPEPS WARNING : Unable to trace back a'// 28 - - ' material index; program bug, please report.' 29 - INEW=I 30 - 30 CONTINUE 31 - * Assign the new material number. 32 - MATMAP(I)=INEW 33 - 10 CONTINUE 34 - *** Sort the epsilons. 35 - DO 150 I=1,NEPS 36 - * Find the I'th epsilon. 37 - II=0 38 - DO 110 J=I,NEPS 39 - IF(IND(J).EQ.I)II=J 40 - 110 CONTINUE 41 - * Exchange. 42 - AUX=EPSMAT(I) 43 - EPSMAT(I)=EPSMAT(IND(I)) 44 - EPSMAT(IND(I))=AUX 45 - IND(II)=IND(I) 46 - 150 CONTINUE 47 - *** Compute volumes and areas. 48 - DO 40 I=1,NEPS 49 - EPSSUR(I)=0 50 - DO 50 J=1,NMAP 51 - IF(MATMAP(J).EQ.I)THEN 1 477 P=CELL D=MAPEPS 2 PAGE 645 52 - IF(MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3)THEN 53 - EPSSUR(I)=EPSSUR(I)+ABS( 54 - - (XMAP(J,3)-XMAP(J,1))*(YMAP(J,2)-YMAP(J,1))- 55 - - (YMAP(J,3)-YMAP(J,1))*(XMAP(J,2)-XMAP(J,1)))/2 56 - ELSEIF(MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13)THEN 57 - EPSSUR(I)=EPSSUR(I)+ABS( 58 - - (XMAP(J,4)-XMAP(J,1))*( 59 - - (YMAP(J,2)-YMAP(J,1))*(ZMAP(J,3)-ZMAP(J,1))- 60 - - (YMAP(J,3)-YMAP(J,1))*(ZMAP(J,2)-ZMAP(J,1)))+ 61 - - (YMAP(J,4)-YMAP(J,1))*( 62 - - (ZMAP(J,2)-ZMAP(J,1))*(XMAP(J,3)-XMAP(J,1))- 63 - - (ZMAP(J,3)-ZMAP(J,1))*(XMAP(J,2)-XMAP(J,1)))+ 64 - - (ZMAP(J,4)-ZMAP(J,1))*( 65 - - (XMAP(J,2)-XMAP(J,1))*(YMAP(J,3)-YMAP(J,1))- 66 - - (XMAP(J,3)-XMAP(J,1))*(YMAP(J,2)-YMAP(J,1))))/6 67 - ELSEIF(MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16)THEN 68 - EPSSUR(I)=EPSSUR(I)+ABS( 69 - - (XMAP(J,4)-XMAP(J,1))*( 70 - - (YMAP(J,2)-YMAP(J,1))*(ZMAP(J,3)-ZMAP(J,1))- 71 - - (YMAP(J,3)-YMAP(J,1))*(ZMAP(J,2)-ZMAP(J,1)))+ 72 - - (YMAP(J,4)-YMAP(J,1))*( 73 - - (ZMAP(J,2)-ZMAP(J,1))*(XMAP(J,3)-XMAP(J,1))- 74 - - (ZMAP(J,3)-ZMAP(J,1))*(XMAP(J,2)-XMAP(J,1)))+ 75 - - (ZMAP(J,4)-ZMAP(J,1))*( 76 - - (XMAP(J,2)-XMAP(J,1))*(YMAP(J,3)-YMAP(J,1))- 77 - - (XMAP(J,3)-XMAP(J,1))*(YMAP(J,2)-YMAP(J,1)))) 78 - ENDIF 79 - ENDIF 80 - 50 CONTINUE 81 - * Debugging output. 82 - IF(LDEBUG)THEN 83 - IF(MATSRC.EQ.'EPSILON')THEN 84 - WRITE(LUNOUT,'('' ++++++ MAPEPS DEBUG :'', 85 - - '' Material '',I3,'': epsilon='',E10.3,'', '', 86 - - '' surface '',E10.3)') I,EPSMAT(I),EPSSUR(I) 87 - ELSE 88 - WRITE(LUNOUT,'('' ++++++ MAPEPS DEBUG :'', 89 - - '' Material '',I3,'': sigma='',E10.3,'' S/m, '', 90 - - '' surface '',E10.3)') I,EPSMAT(I),EPSSUR(I) 91 - ENDIF 92 - ENDIF 93 - 40 CONTINUE 94 - *** Seems to have worked. 95 - IFAIL=0 96 - END 478 GARFIELD ================================================== P=CELL D=MAPFMF 1 ============================ 0 + +DECK,MAPFMF. 1 - SUBROUTINE MAPFMF(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MAPFMF - Retrieves the field map data in binary format. 4 - * (Last changed on 13/ 3/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,FIELDMAP. 9.- +SEQ,CELLDATA. 10.- +SEQ,BFIELD. 11.- +SEQ,GASDATA. 12 - INTEGER I,J,K,IOS,NWORD,NC,IFAIL,IFAIL1,IVERS 13 - CHARACTER*(MXNAME) FILE 14 - *** Assume for the time being that this will fail. 15 - IFAIL=1 16 - *** Get hold of the file name. 17 - CALL INPNUM(NWORD) 18 - * Make sure there is at least one argument. 19 - IF(NWORD.NE.2)THEN 20 - PRINT *,' !!!!!! MAPFMF WARNING : FETCH-FIELD-MAP takes 1'// 21 - - ' argument (a dataset name); the map will not be read.' 22 - RETURN 23 - ENDIF 24 - CALL INPSTR(2,2,FILE,NC) 25 - * Check the length. 26 - IF(NC.GT.MXNAME)PRINT *,' !!!!!! MAPFMF WARNING : The file', 27 - - ' name is truncated to MXNAME (=',MXNAME,') characters.' 28 - NC=MIN(NC,MXNAME) 29 - *** Open the file for sequential binary read. 30 - CALL DSNOPN(FILE,NC,12,'READ-BINARY',IFAIL1) 31 - IF(IFAIL1.NE.0)THEN 32 - PRINT *,' !!!!!! MAPFMF WARNING : Opening '//FILE(1:NC)// 33 - - ' failed ; the field map will not be read.' 34 - CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 35 - RETURN 36 - ENDIF 37 - *** Reset the field map. 38 - CALL MAPINT 39 - *** Read version number. 40 - READ(12,ERR=2010,IOSTAT=IOS) IVERS 41 - IF(IVERS.NE.3)THEN 42 - PRINT *,' !!!!!! MAPFMF WARNING : Format of '//FILE(1:NC)// 43 - - ' is not compatible with program version; not read.' 44 - CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 45 - RETURN 46 - ENDIF 47 - *** Read # triangles, map order, availability, 3D, plot flag. 48 - READ(12,ERR=2010,IOSTAT=IOS) NMAP,MAPORD, 49 - - (MAPFLG(I),I=1,10+3*MXWMAP),MAPTYP,LMAPPL,NWMAP 50 - * Verify that the dimensions match. 51 - IF(NMAP.GT.MXMAP)THEN 52 - PRINT *,' !!!!!! MAPFMF WARNING : The map in '//FILE(1:NC)// 53 - - ' exceeds dimensions of this compilation; not read.' 54 - CALL MAPINT 55 - CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 56 - RETURN 57 - ELSEIF(NWMAP.GT.MXWMAP)THEN 1 478 P=CELL D=MAPFMF 2 PAGE 646 58 - PRINT *,' !!!!!! MAPFMF WARNING : Too many weighting'// 59 - - ' fields in '//FILE(1:NC)//' for this compilation;'// 60 - - ' not read.' 61 - CALL MAPINT 62 - CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 63 - RETURN 64 - * Make sure there is a field map. 65 - ELSEIF(NMAP.LE.0.OR..NOT.MAPFLG(1))THEN 66 - PRINT *,' !!!!!! MAPFMF WARNING : The map in '//FILE(1:NC)// 67 - - ' is empty; file not read.' 68 - CALL MAPINT 69 - CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 70 - RETURN 71 - ENDIF 72 - *** Read the triangles or tetrahedrons, dimensions and periodicities. 73 - IF(MAPFLG(1))READ(12,ERR=2010,IOSTAT=IOS) 74 - - ((XMAP(I,J),I=1,NMAP),J=1,4), 75 - - ((YMAP(I,J),I=1,NMAP),J=1,4), 76 - - ((ZMAP(I,J),I=1,NMAP),J=1,4), 77 - - XMMIN,XMMAX,YMMIN,YMMAX,ZMMIN,ZMMAX, 78 - - XAMIN,XAMAX,YAMIN,YAMAX,ZAMIN,ZAMAX, 79 - - SETAX,SETAY,SETAZ,SX,SY,SZ,PERX,PERY,PERZ, 80 - - PERMX,PERMY,PERMZ,PERAX,PERAY,PERAZ,PERRX,PERRY,PERRZ 81 - * The (Ex,Ey,Ez) field, if available. 82 - IF(MAPFLG(2))READ(12,ERR=2010,IOSTAT=IOS) 83 - - ((EXMAP(I,J),I=1,NMAP),J=1,10) 84 - IF(MAPFLG(3))READ(12,ERR=2010,IOSTAT=IOS) 85 - - ((EYMAP(I,J),I=1,NMAP),J=1,10) 86 - IF(MAPFLG(4))READ(12,ERR=2010,IOSTAT=IOS) 87 - - ((EZMAP(I,J),I=1,NMAP),J=1,10) 88 - * The potential and potential range, if available. 89 - IF(MAPFLG(5))READ(12,ERR=2010,IOSTAT=IOS) 90 - - ((VMAP(I,J),I=1,NMAP),J=1,10),VMMIN,VMMAX 91 - * The (Bx,By,Bz) field, if available. 92 - IF(MAPFLG(6))READ(12,ERR=2010,IOSTAT=IOS) 93 - - ((BXMAP(I,J),I=1,NMAP),J=1,10) 94 - IF(MAPFLG(7))READ(12,ERR=2010,IOSTAT=IOS) 95 - - ((BYMAP(I,J),I=1,NMAP),J=1,10) 96 - IF(MAPFLG(8))READ(12,ERR=2010,IOSTAT=IOS) 97 - - ((BZMAP(I,J),I=1,NMAP),J=1,10) 98 - * The material map, if available. 99 - IF(MAPFLG(9))READ(12,ERR=2010,IOSTAT=IOS) 100 - - (MATMAP(I),I=1,NMAP) 101 - * The weighting (Ex,Ey,Ez) field and label, if available. 102 - DO 10 K=1,NWMAP 103 - IF(MAPFLG(10+3*K-2))READ(12,ERR=2010,IOSTAT=IOS) 104 - - ((EWXMAP(I,J,K),I=1,NMAP),J=1,10) 105 - IF(MAPFLG(11+3*K-2))READ(12,ERR=2010,IOSTAT=IOS) 106 - - ((EWYMAP(I,J,K),I=1,NMAP),J=1,10) 107 - IF(MAPFLG(12+3*K-2))READ(12,ERR=2010,IOSTAT=IOS) 108 - - ((EWZMAP(I,J,K),I=1,NMAP),J=1,10) 109 - IF(MAPFLG(10+3*K-2).OR.MAPFLG(11+3*K-2).OR.MAPFLG(12+3*K-2)) 110 - - READ(12,ERR=2010,IOSTAT=IOS) EWSTYP(K) 111 - 10 CONTINUE 112 - *** Read the number of materials and the drift medium. 113 - READ(12,ERR=2010,IOSTAT=IOS) NEPS,IDRMAT 114 - * Verify that the dimensions match. 115 - IF(NEPS.GT.MXEPS)THEN 116 - PRINT *,' !!!!!! MAPFMF WARNING : The map in '//FILE(1:NC)// 117 - - ' exceeds dimensions of this compilation; not read.' 118 - CALL MAPINT 119 - CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 120 - RETURN 121 - ENDIF 122 - *** Read the material table. 123 - READ(12,ERR=2010,IOSTAT=IOS) (EPSMAT(I),I=1,NEPS), 124 - - (EPSSUR(I),I=1,NEPS) 125 - *** Close the file. 126 - CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 127 - *** Set the same limits for the cell. 128 - XMIN=XMMIN 129 - XMAX=XMMAX 130 - YMIN=YMMIN 131 - YMAX=YMMAX 132 - ZMIN=ZMMIN 133 - ZMAX=ZMMAX 134 - VMIN=VMMIN 135 - VMAX=VMMAX 136 - IF(PERX.OR.PERMX)SX=ABS(XMMAX-XMMIN) 137 - IF(PERY.OR.PERMY)SY=ABS(YMMAX-YMMIN) 138 - IF(PERZ.OR.PERMZ)SZ=ABS(ZMMAX-ZMMIN) 139 - IF(PERRX)THEN 140 - XMIN=YMMIN 141 - XMAX=YMMAX 142 - YMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) 143 - YMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) 144 - ZMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) 145 - ZMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) 146 - ELSEIF(PERRY)THEN 147 - XMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) 148 - XMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) 149 - YMIN=YMMIN 150 - YMAX=YMMAX 151 - ZMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) 152 - ZMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) 153 - ELSEIF(PERRZ)THEN 154 - XMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) 155 - XMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) 156 - YMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) 157 - YMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) 158 - ZMIN=YMMIN 159 - ZMAX=YMMAX 160 - ENDIF 161 - IF(PERAX)THEN 162 - YMIN=-MAX(ABS(YMMIN),ABS(YMMAX),ABS(ZMMIN),ABS(ZMMAX)) 163 - YMAX=+MAX(ABS(YMMIN),ABS(YMMAX),ABS(ZMMIN),ABS(ZMMAX)) 1 478 P=CELL D=MAPFMF 3 PAGE 647 164 - ZMIN=-MAX(ABS(YMMIN),ABS(YMMAX),ABS(ZMMIN),ABS(ZMMAX)) 165 - ZMAX=+MAX(ABS(YMMIN),ABS(YMMAX),ABS(ZMMIN),ABS(ZMMAX)) 166 - ELSEIF(PERAY)THEN 167 - XMIN=-MAX(ABS(XMMIN),ABS(XMMAX),ABS(ZMMIN),ABS(ZMMAX)) 168 - XMAX=+MAX(ABS(XMMIN),ABS(XMMAX),ABS(ZMMIN),ABS(ZMMAX)) 169 - ZMIN=-MAX(ABS(XMMIN),ABS(XMMAX),ABS(ZMMIN),ABS(ZMMAX)) 170 - ZMAX=+MAX(ABS(XMMIN),ABS(XMMAX),ABS(ZMMIN),ABS(ZMMAX)) 171 - ELSEIF(PERAZ)THEN 172 - XMIN=-MAX(ABS(XMMIN),ABS(XMMAX),ABS(YMMIN),ABS(YMMAX)) 173 - XMAX=+MAX(ABS(XMMIN),ABS(XMMAX),ABS(YMMIN),ABS(YMMAX)) 174 - YMIN=-MAX(ABS(XMMIN),ABS(XMMAX),ABS(YMMIN),ABS(YMMAX)) 175 - YMAX=+MAX(ABS(XMMIN),ABS(XMMAX),ABS(YMMIN),ABS(YMMAX)) 176 - ENDIF 177 - *** Set magnetic field flag. 178 - IF(MAPFLG(6).AND.MAPFLG(7).AND.MAPFLG(8))THEN 179 - MAGOK=.TRUE. 180 - IF(MAGSRC.EQ.1)PRINT *,' ------ MAGFMF MESSAGE : B field'// 181 - - ' from &MAGNETIC replaced by a field map.' 182 - MAGSRC=2 183 - IF(GASSET)PRINT *,' ------ MAPFMF MESSAGE : Previous gas'// 184 - - ' data deleted.' 185 - GASSET=.FALSE. 186 - ELSEIF(MAGSRC.EQ.2)THEN 187 - PRINT *,' ------ MAGFMF MESSAGE : The new field map has'// 188 - - ' no magnetic field; currently no magnetic field.' 189 - MAGSRC=0 190 - MAGOK=.FALSE. 191 - IF(GASSET)PRINT *,' ------ MAPFMF MESSAGE : Previous gas'// 192 - - ' data deleted.' 193 - GASSET=.FALSE. 194 - ENDIF 195 - *** Register file access. 196 - CALL DSNLOG(FILE(1:NC),'Field map ','Sequential', 197 - - 'Bin Read ') 198 - *** Seems to have worked. 199 - IFAIL=0 200 - RETURN 201 - *** Handle I/O errors. 202 - 2010 CONTINUE 203 - PRINT *,' !!!!!! MAPFMF WARNING : Error during binary read'// 204 - - ' to file '//FILE(1:NC)//'; resetting field map.' 205 - CALL INPIOS(IOS) 206 - CALL MAPINT 207 - CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 208 - RETURN 209 - 2030 CONTINUE 210 - PRINT *,' !!!!!! MAPFMF WARNING : Error closing '//FILE(1:NC)// 211 - - ' after binary read; effect not known.' 212 - CALL INPIOS(IOS) 213 - END 479 GARFIELD ================================================== P=CELL D=MAPFMS 1 ============================ 0 + +DECK,MAPFMS. 1 - SUBROUTINE MAPFMS 2 - *----------------------------------------------------------------------- 3 - * MAPFMS - Writes the field map data in binary format. 4 - * (Last changed on 4/ 9/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,FIELDMAP. 9.- +SEQ,CELLDATA. 10 - INTEGER I,J,K,IOS,NWORD,NC,IFAIL 11 - CHARACTER*(MXNAME) FILE 12 - *** Make sure there is a field map. 13 - IF(NMAP.LE.0.OR..NOT.MAPFLG(1))THEN 14 - PRINT *,' !!!!!! MAPFMS WARNING : There is currently no'// 15 - - ' valid field map in memory; map not saved.' 16 - RETURN 17 - ENDIF 18 - *** Get hold of the file name. 19 - CALL INPNUM(NWORD) 20 - * Make sure there is at least one argument. 21 - IF(NWORD.NE.2)THEN 22 - PRINT *,' !!!!!! MAPFMS WARNING : SAVE-FIELD-MAP takes 1'// 23 - - ' argument (a dataset name); map will not be saved.' 24 - RETURN 25 - ENDIF 26 - CALL INPSTR(2,2,FILE,NC) 27 - * Check the length. 28 - IF(NC.GT.MXNAME)PRINT *,' !!!!!! MAPFMS WARNING : The file'// 29 - - ' name is truncated to MXNAME (=',MXNAME,') characters.' 30 - NC=MIN(NC,MXNAME) 31 - *** Open the file for sequential binary write. 32 - CALL DSNOPN(FILE,NC,12,'WRITE-BINARY',IFAIL) 33 - IF(IFAIL.NE.0)THEN 34 - PRINT *,' !!!!!! MAPFMS WARNING : Opening '//FILE(1:NC)// 35 - - ' failed ; the field map will not be written.' 36 - RETURN 37 - ENDIF 38 - *** Write the version number. 39 - WRITE(12,ERR=2010,IOSTAT=IOS) 3 40 - *** Write # triangles, map order, availability, 3D, plot flag. 41 - WRITE(12,ERR=2010,IOSTAT=IOS) NMAP,MAPORD, 42 - - (MAPFLG(I),I=1,10+3*MXWMAP),MAPTYP,LMAPPL,NWMAP 43 - *** Write the triangles or tetrahedrons, dimensions and periodicities. 44 - IF(MAPFLG(1))WRITE(12,ERR=2010,IOSTAT=IOS) 45 - - ((XMAP(I,J),I=1,NMAP),J=1,4), 46 - - ((YMAP(I,J),I=1,NMAP),J=1,4), 47 - - ((ZMAP(I,J),I=1,NMAP),J=1,4), 48 - - XMMIN,XMMAX,YMMIN,YMMAX,ZMMIN,ZMMAX, 49 - - XAMIN,XAMAX,YAMIN,YAMAX,ZAMIN,ZAMAX, 50 - - SETAX,SETAY,SETAZ,SX,SY,SZ,PERX,PERY,PERZ, 51 - - PERMX,PERMY,PERMZ,PERAX,PERAY,PERAZ,PERRX,PERRY,PERRZ 52 - * The (Ex,Ey,Ez) field, if available. 1 479 P=CELL D=MAPFMS 2 PAGE 648 53 - IF(MAPFLG(2))WRITE(12,ERR=2010,IOSTAT=IOS) 54 - - ((EXMAP(I,J),I=1,NMAP),J=1,10) 55 - IF(MAPFLG(3))WRITE(12,ERR=2010,IOSTAT=IOS) 56 - - ((EYMAP(I,J),I=1,NMAP),J=1,10) 57 - IF(MAPFLG(4))WRITE(12,ERR=2010,IOSTAT=IOS) 58 - - ((EZMAP(I,J),I=1,NMAP),J=1,10) 59 - * The potential and potential range, if available. 60 - IF(MAPFLG(5))WRITE(12,ERR=2010,IOSTAT=IOS) 61 - - ((VMAP(I,J),I=1,NMAP),J=1,10),VMMIN,VMMAX 62 - * The (Bx,By,Bz) field, if available. 63 - IF(MAPFLG(6))WRITE(12,ERR=2010,IOSTAT=IOS) 64 - - ((BXMAP(I,J),I=1,NMAP),J=1,10) 65 - IF(MAPFLG(7))WRITE(12,ERR=2010,IOSTAT=IOS) 66 - - ((BYMAP(I,J),I=1,NMAP),J=1,10) 67 - IF(MAPFLG(8))WRITE(12,ERR=2010,IOSTAT=IOS) 68 - - ((BZMAP(I,J),I=1,NMAP),J=1,10) 69 - * The material map, if available. 70 - IF(MAPFLG(9))WRITE(12,ERR=2010,IOSTAT=IOS) 71 - - (MATMAP(I),I=1,NMAP) 72 - * The weighting (Ex,Ey,Ez) field and label, if available. 73 - DO 10 K=1,NWMAP 74 - IF(MAPFLG(10+3*K-2))WRITE(12,ERR=2010,IOSTAT=IOS) 75 - - ((EWXMAP(I,J,K),I=1,NMAP),J=1,10) 76 - IF(MAPFLG(11+3*K-2))WRITE(12,ERR=2010,IOSTAT=IOS) 77 - - ((EWYMAP(I,J,K),I=1,NMAP),J=1,10) 78 - IF(MAPFLG(12+3*K-2))WRITE(12,ERR=2010,IOSTAT=IOS) 79 - - ((EWZMAP(I,J,K),I=1,NMAP),J=1,10) 80 - IF(MAPFLG(10+3*K-2).OR.MAPFLG(11+3*K-2).OR.MAPFLG(12+3*K-2)) 81 - - WRITE(12,ERR=2010,IOSTAT=IOS) EWSTYP(K) 82 - 10 CONTINUE 83 - *** Write the number of materials and the drift medium. 84 - WRITE(12,ERR=2010,IOSTAT=IOS) NEPS,IDRMAT 85 - *** Write the material table. 86 - WRITE(12,ERR=2010,IOSTAT=IOS) (EPSMAT(I),I=1,NEPS), 87 - - (EPSSUR(I),I=1,NEPS) 88 - *** Close the file. 89 - CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 90 - *** Register file access. 91 - CALL DSNLOG(FILE(1:NC),'Field map ','Sequential', 92 - - 'Bin Write ') 93 - RETURN 94 - *** Handle I/O errors. 95 - 2010 CONTINUE 96 - PRINT *,' !!!!!! MAPFMS WARNING : Error during binary write'// 97 - - ' to file '//FILE(1:NC)//'; deleting file.' 98 - CALL INPIOS(IOS) 99 - CLOSE(UNIT=12,STATUS='DELETE',ERR=2030,IOSTAT=IOS) 100 - RETURN 101 - 2030 CONTINUE 102 - PRINT *,' !!!!!! MAPFMS WARNING : Error closing '//FILE(1:NC)// 103 - - ' after binary write; effect not known.' 104 - CALL INPIOS(IOS) 105 - END 480 GARFIELD ================================================== P=CELL D=MAPFMR 1 ============================ 0 + +DECK,MAPFMR. 1 - SUBROUTINE MAPFMR(FMAP,NCMAP,IFORM,IDATA,IWMAP, 2 - - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,DELBKG, 3 - - MAPMAX,IFAIL) 4 - *----------------------------------------------------------------------- 5 - * MAPFMR - Reads one interpolation table. 6 - * (Last changed on 4/ 9/99.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,FIELDMAP. 12 - CHARACTER*(*) FMAP 13 - INTEGER NCMAP,IFAIL,IOS,I,IFORM,IDATA,IFAIL1,INPCMP,MAPMAX, 14 - - NWORD,IWMAP 15 - REAL WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX 16 - LOGICAL EXIST,WINDOW,DELBKG 17 - EXTERNAL INPCMP 18 - *** Identify the routine if requested. 19 - IF(LIDENT)PRINT *,' /// ROUTINE MAPFMR ///' 20 - *** Assume the routine will fail. 21 - IFAIL=1 22 - *** Reset search for volumes. 23 - CALL MAPINR 24 - *** Debugging output. 25 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFMR DEBUG : Field'', 26 - - '' map: '',A/26X,''Format: '',I2/26X,''Contents: '', 27 - - I2)') FMAP(1:NCMAP),IFORM,IDATA 28 - *** Check the existence of the field map or mesh file. 29 - CALL DSNINQ(FMAP,NCMAP,EXIST) 30 - IF(.NOT.EXIST)THEN 31 - PRINT *,' !!!!!! MAPFMR WARNING : Field map file ', 32 - - FMAP(1:NCMAP),' not found; field map not read.' 33 - RETURN 34 - ENDIF 35 - * Open the field map file. 36 - CALL DSNOPN(FMAP,NCMAP,12,'READ-FILE',IFAIL1) 37 - IF(IFAIL1.NE.0)THEN 38 - PRINT *,' !!!!!! MAPFMR WARNING : Unable to open the'// 39 - - ' field map file ',FMAP(1:NCMAP),'; not read.' 40 - RETURN 41 - ENDIF 42 - * Record the opening. 43 - CALL DSNLOG(FMAP(1:NCMAP),'Field map ','Sequential', 44 - - 'Read only ') 45 - * Read the header records, switch to the data file. 46 - CALL INPSWI('UNIT12') 47 - CALL INPGET 48 - CALL INPNUM(NWORD) 49 - * Check for empty files. 1 480 P=CELL D=MAPFMR 2 PAGE 649 50 - IF(NWORD.EQ.0)THEN 51 - PRINT *,' !!!!!! MAPFMR WARNING : The file ', 52 - - FMAP(1:NCMAP),' seems to be empty; not read.' 53 - CALL INPSWI('RESTORE') 54 - CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 55 - RETURN 56 - ENDIF 57 - *** In case of planar and real data, try Maxwell Parameter Extractor 2D. 58 - IF(INPCMP(1,'PLANE').NE.0.AND.INPCMP(3,'REAL').NE.0.AND. 59 - - INPCMP(4,'SIZE').NE.0)THEN 60 - IF(IFORM.NE.1.AND.IFORM.NE.0)PRINT *,' !!!!!! MAPFMR'// 61 - - ' WARNING : File ',FMAP(1:NCMAP),' seems to be in'// 62 - - ' Maxwell Parameter Extractor 2D format,'// 63 - - ' contrary to your indications.' 64 - CALL MAPFM2(FMAP,NCMAP,IDATA,IWMAP, 65 - - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,IFAIL1) 66 - MAPMAX=2 67 - IF(IFAIL1.NE.0)THEN 68 - PRINT *,' !!!!!! MAPFMR WARNING : File ',FMAP(1:NCMAP), 69 - - ' could not successfully be read as Maxwell 2D.' 70 - CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 71 - RETURN 72 - ENDIF 73 - * Non-planar real data could be Maxwell Parameter Extractor 3D. 74 - ELSEIF(INPCMP(2,'REAL').NE.0.AND.INPCMP(3,'SIZE').NE.0)THEN 75 - IF(IFORM.NE.2.AND.IFORM.NE.0)PRINT *,' !!!!!! MAPFMR'// 76 - - ' WARNING : File ',FMAP(1:NCMAP),' seems to be in'// 77 - - ' Maxwell Parameter Extractor 3D format,'// 78 - - ' contrary to your indications.' 79 - CALL MAPFM3(FMAP,NCMAP,IDATA,IWMAP, 80 - - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,IFAIL1) 81 - MAPMAX=2 82 - IF(IFAIL1.NE.0)THEN 83 - PRINT *,' !!!!!! MAPFMR WARNING : File ',FMAP(1:NCMAP), 84 - - ' could not successfully be read as Maxwell 3D.' 85 - CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 86 - RETURN 87 - ENDIF 88 - * Try Maxwell Field Simulator 3D. 89 - ELSEIF(INPCMP(1,'HYDRAS').NE.0.OR. 90 - - INPCMP(1,'POINTS').NE.0.OR. 91 - - (INPCMP(1,'SCALAR').NE.0.AND.INPCMP(2,'DATA').NE.0.AND. 92 - - NWORD.EQ.3).OR. 93 - - (INPCMP(1,'VECTOR').NE.0.AND.INPCMP(2,'DATA').NE.0.AND. 94 - - NWORD.EQ.3))THEN 95 - IF(IFORM.NE.4.AND.IFORM.NE.0)PRINT *,' !!!!!! MAPFMR'// 96 - - ' WARNING : File ',FMAP(1:NCMAP),' seems to be in'// 97 - - ' Maxwell Field Simulator 3D format,'// 98 - - ' contrary to your indications.' 99 - IF(INPCMP(1,'HYDRAS')+INPCMP(1,'POINTS').NE.0)IDATA=1 100 - CALL MAPFM5(FMAP,NCMAP,IDATA,IWMAP, 101 - - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,DELBKG, 102 - - IFAIL1) 103 - MAPMAX=2 104 - IF(IFAIL1.NE.0)THEN 105 - PRINT *,' !!!!!! MAPFMR WARNING : File ',FMAP(1:NCMAP), 106 - - ' could not successfully be read as Maxwell 3D.' 107 - CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 108 - RETURN 109 - ENDIF 110 - * Tosca. 111 - ELSEIF(IFORM.EQ.5)THEN 112 - CALL MAPFM6(FMAP,NCMAP,IDATA,IWMAP, 113 - - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,IFAIL1) 114 - MAPMAX=1 115 - IF(IFAIL1.NE.0)THEN 116 - PRINT *,' !!!!!! MAPFMR WARNING : File ',FMAP(1:NCMAP), 117 - - ' could not successfully be read as Tosca.' 118 - CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 119 - RETURN 120 - ENDIF 121 - * Other formats are not currently known. 122 - ELSE 123 - PRINT *,' !!!!!! MAPFMR WARNING : Data in ',FMAP(1:NCMAP), 124 - - ' is in an unknown format; not read.' 125 - CALL INPSWI('RESTORE') 126 - CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 127 - RETURN 128 - ENDIF 129 - *** We should have read everything now. 130 - CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 131 - *** Debugging output. 132 - IF(LDEBUG)THEN 133 - WRITE(LUNOUT,'('' ++++++ MAPFMR DEBUG :'', 134 - - '' Current set of flags: '',13L1)') 135 - - (MAPFLG(I),I=1,13) 136 - IF(MAPFLG(1))WRITE(LUNOUT,'('' ++++++ MAPFMR'', 137 - - '' DEBUG : Grid covers: ''/ 138 - - 26X,E15.8,'' < x < '',E15.8/ 139 - - 26X,E15.8,'' < y < '',E15.8/ 140 - - 26X,E15.8,'' < z < '',E15.8)') 141 - - XMMIN,XMMAX,YMMIN,YMMAX,ZMMIN,ZMMAX 142 - IF(MAPFLG(5))WRITE(LUNOUT,'('' ++++++ MAPFMR'', 143 - - '' DEBUG : Potential range: ''/ 144 - - 26X,E15.8,'' < V < '',E15.8)') VMMIN,VMMAX 145 - ENDIF 146 - *** Seems to have worked, set error flag to OK and return. 147 - IFAIL=0 148 - RETURN 149 - *** Handle error conditions. 150 - 2030 CONTINUE 151 - PRINT *,' !!!!!! MAPFMR WARNING : Error closing field map'// 152 - - ' file ',FMAP(1:NCMAP),'; map not available.' 153 - RETURN 154 - END 1 481 GARFIELD ================================================== P=CELL D=MAPFM2 1 =================== PAGE 650 0 + +DECK,MAPFM2. 1 - SUBROUTINE MAPFM2(FMAP,NCMAP,IDATA,IWMAP, 2 - - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * MAPFM2 - Reads a Maxwell 2D table of triangles. 5 - * (Last changed on 28/ 2/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,CELLDATA. 11.- +SEQ,FIELDMAP. 12.- +SEQ,CONSTANTS. 13 - INTEGER IMAP,IEPS,ICONT(3),IMAX,IWMAP, 14 - - I,J,IREAD,NCMAP,IFAIL,IFAIL1,IOS,NC, 15 - - INPCMP,IDATA,NDECL,NDELET 16 - REAL TEMPRE,TEMPIM,XAUX(3),YAUX(3),ZAUX(3),SUM, 17 - - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,T1,T2,T3,T4,ECOMP,DCOMP, 18 - - DXCOMP,DYCOMP 19 - CHARACTER*(*) FMAP 20 - CHARACTER*80 STRING 21 - CHARACTER*8 STRAUX 22 - LOGICAL SCALAR,WINDOW,NEWEPS 23 - EXTERNAL INPCMP 24 - *** Identify the routine if requested. 25 - IF(LIDENT)PRINT *,' /// ROUTINE MAPFM2 ///' 26 - C print *,' Cutting window: ',window 27 - C print *,wxmin,' < x < ',wxmax 28 - C print *,wymin,' < x < ',wymax 29 - *** Assume that this will fail. 30 - IFAIL=1 31 - *** First read the line with number of triangles. 32 - CALL INPCHK(5,1,IFAIL1) 33 - CALL INPRDI(5,NDECL,0) 34 - IF(IFAIL1.NE.0.OR.NDECL.LE.0)THEN 35 - PRINT *,' !!!!!! MAPFM2 WARNING : The file ', 36 - - FMAP(1:NCMAP),' has an unreadable number'// 37 - - ' of triangles; not read.' 38 - CALL INPSWI('RESTORE') 39 - RETURN 40 - ENDIF 41 - * Debugging output. 42 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG : Number'', 43 - - '' of triangles: '',I5)') NDECL 44 - *** Progress printing. 45 - CALL PROFLD(2,'Triangles',REAL(NDECL)) 46 - *** See whether the data is scalar or vector. 47 - IF(INPCMP(2,'SCALAR').NE.0)THEN 48 - SCALAR=.TRUE. 49 - ELSEIF(INPCMP(2,'VECTOR').NE.0)THEN 50 - SCALAR=.FALSE. 51 - ELSE 52 - PRINT *,' !!!!!! MAPFM2 WARNING : The file ', 53 - - FMAP(1:NCMAP),' contains neither scalar nor'// 54 - - ' vectorial data; not read.' 55 - CALL INPSWI('RESTORE') 56 - RETURN 57 - ENDIF 58 - *** Next determine the contents of the file, read the next record. 59 - CALL INPGET 60 - * Set the expected word count. 61 - IF(SCALAR)THEN 62 - IMAX=1 63 - ELSE 64 - IMAX=3 65 - ENDIF 66 - * Initial contents flags. 67 - ICONT(1)=0 68 - ICONT(2)=0 69 - ICONT(3)=0 70 - NEWEPS=.FALSE. 71 - * Loop over the words. 72 - DO 40 I=1,IMAX 73 - * Ex or EWx or Er or EWr. 74 - IF(INPCMP(I,'smooth(E(x))')+INPCMP(I,'E(x)')+ 75 - - INPCMP(I,'smooth(E(r))')+INPCMP(I,'E(r)').NE.0)THEN 76 - ICONT(I)=2 77 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', 78 - - '' Field '',I1,'': x/r-component E field.'')') I 79 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 80 - IF(MAPFLG(2))PRINT *,' ------ MAPFM2 MESSAGE :'// 81 - - ' Overwriting current Ex/r map.' 82 - MAPFLG(2)=.FALSE. 83 - ELSEIF(IDATA.EQ.10)THEN 84 - IF(MAPFLG(10+3*IWMAP-2)) 85 - - PRINT *,' ------ MAPFM2 MESSAGE :'// 86 - - ' Overwriting current weighting Ex/r map.' 87 - MAPFLG(10+3*IWMAP-2)=.FALSE. 88 - ENDIF 89 - IF(INPCMP(I,'smooth(E(r))')+INPCMP(I,'E(r)').NE.0) 90 - - PERRZ=.TRUE. 91 - * Ey or EWy. 92 - ELSEIF(INPCMP(I,'smooth(E(y))')+INPCMP(I,'E(y)').NE.0)THEN 93 - ICONT(I)=3 94 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', 95 - - '' Field '',I1,'': y-component E field.'')') I 96 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 97 - IF(MAPFLG(3))PRINT *,' ------ MAPFM2 MESSAGE :'// 98 - - ' Overwriting current Ey map.' 99 - MAPFLG(3)=.FALSE. 100 - ELSEIF(IDATA.EQ.10)THEN 101 - IF(MAPFLG(11+3*IWMAP-2)) 102 - - PRINT *,' ------ MAPFM2 MESSAGE :'// 103 - - ' Overwriting current weighting Ey map.' 104 - MAPFLG(11+3*IWMAP-2)=.FALSE. 105 - ENDIF 1 481 P=CELL D=MAPFM2 2 PAGE 651 106 - * Ez or EWz. 107 - ELSEIF(INPCMP(I,'smooth(E(z))')+INPCMP(I,'E(z)').NE.0)THEN 108 - ICONT(I)=4 109 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', 110 - - '' Field '',I1,'': z-component E field.'')') I 111 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 112 - IF(MAPFLG(4))PRINT *,' ------ MAPFM2 MESSAGE :'// 113 - - ' Overwriting current Ez map.' 114 - MAPFLG(4)=.FALSE. 115 - ELSEIF(IDATA.EQ.10)THEN 116 - IF(MAPFLG(12+3*IWMAP-2)) 117 - - PRINT *,' ------ MAPFM2 MESSAGE :'// 118 - - ' Overwriting current weighting Ez map.' 119 - MAPFLG(12+3*IWMAP-2)=.FALSE. 120 - ENDIF 121 - * Dx or Dr. 122 - ELSEIF(INPCMP(I,'smooth(D(x))')+INPCMP(I,'D(x)')+ 123 - - INPCMP(I,'smooth(D(r))')+INPCMP(I,'D(r)').NE.0)THEN 124 - ICONT(I)=-9 125 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', 126 - - '' Field '',I1,'': x-component D field.'')') I 127 - IF(MAPFLG(9))PRINT *,' ------ MAPFM2 MESSAGE :'// 128 - - ' Overwriting current material map.' 129 - MAPFLG(9)=.FALSE. 130 - MATSRC='EPSILON' 131 - * Dy. 132 - ELSEIF(INPCMP(I,'smooth(D(y))')+INPCMP(I,'D(y)').NE.0)THEN 133 - ICONT(I)=-9 134 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', 135 - - '' Field '',I1,'': y-component D field.'')') I 136 - IF(MAPFLG(9))PRINT *,' ------ MAPFM2 MESSAGE :'// 137 - - ' Overwriting current material map.' 138 - MAPFLG(9)=.FALSE. 139 - MATSRC='EPSILON' 140 - * Dz. 141 - ELSEIF(INPCMP(I,'smooth(D(z))')+INPCMP(I,'D(z)').NE.0)THEN 142 - ICONT(I)=-9 143 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', 144 - - '' Field '',I1,'': z-component D field.'')') I 145 - IF(MAPFLG(9))PRINT *,' ------ MAPFM2 MESSAGE :'// 146 - - ' Overwriting current material map.' 147 - MAPFLG(9)=.FALSE. 148 - MATSRC='EPSILON' 149 - * V 150 - ELSEIF(INPCMP(I,'smooth(voltage)')+INPCMP(I,'voltage').NE.0)THEN 151 - ICONT(I)=5 152 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', 153 - - '' Field '',I1,'': potential.'')') I 154 - IF(MAPFLG(5))PRINT *,' ------ MAPFM2 MESSAGE :'// 155 - - ' Overwriting current potential map.' 156 - MAPFLG(5)=.FALSE. 157 - * Bx 158 - ELSEIF(INPCMP(I,'smooth(B(x))')+INPCMP(I,'B(x)')+ 159 - - INPCMP(I,'smooth(B(r))')+INPCMP(I,'B(r)').NE.0)THEN 160 - ICONT(I)=6 161 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', 162 - - '' Field '',I1,'': x/r-component B field.'')') I 163 - IF(MAPFLG(6))PRINT *,' ------ MAPFM2 MESSAGE :'// 164 - - ' Overwriting current Bx/r map.' 165 - MAPFLG(6)=.FALSE. 166 - IF(INPCMP(I,'smooth(B(r))')+INPCMP(I,'B(r)').NE.0) 167 - - PERRZ=.TRUE. 168 - * By 169 - ELSEIF(INPCMP(I,'smooth(B(y))')+INPCMP(I,'B(y)').NE.0)THEN 170 - ICONT(I)=7 171 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', 172 - - '' Field '',I1,'': y-component B field.'')') I 173 - IF(MAPFLG(7))PRINT *,' ------ MAPFM2 MESSAGE :'// 174 - - ' Overwriting current By map.' 175 - MAPFLG(7)=.FALSE. 176 - * Bz 177 - ELSEIF(INPCMP(I,'smooth(B(z))')+INPCMP(I,'B(z)').NE.0)THEN 178 - ICONT(I)=8 179 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', 180 - - '' Field '',I1,'': z-component B field.'')') I 181 - IF(MAPFLG(8))PRINT *,' ------ MAPFM2 MESSAGE :'// 182 - - ' Overwriting current Bz map.' 183 - MAPFLG(8)=.FALSE. 184 - * epsilon 185 - ELSEIF(INPCMP(I,'(r( 1.00000e+00) * epsilon)')+ 186 - - INPCMP(I,'(r( 1.00000e+000) * epsilon)').NE.0)THEN 187 - ICONT(I)=9 188 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', 189 - - '' Field '',I1,'': dielectric constant.'')') I 190 - IF(MAPFLG(9))PRINT *,' ------ MAPFM2 MESSAGE :'// 191 - - ' Overwriting material map.' 192 - MAPFLG(9)=.FALSE. 193 - MATSRC='EPSILON' 194 - * sigma. 195 - ELSEIF(INPCMP(I,'(r( 1.00000e+00) * sigma)')+ 196 - - INPCMP(I,'(r( 1.00000e+000) * sigma)').NE.0)THEN 197 - ICONT(I)=9 198 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', 199 - - '' Field '',I1,'': Conductivity.'')') I 200 - IF(MAPFLG(9))PRINT *,' ------ MAPFM2 MESSAGE :'// 201 - - ' Overwriting material map.' 202 - MAPFLG(9)=.FALSE. 203 - MATSRC='SIGMA' 204 - * dummy field 205 - ELSEIF(INPCMP(I,'smooth(0)')+INPCMP(I,'0')+ 206 - - INPCMP(I,'r( 0.00000e+00)')+ 207 - - INPCMP(I,'(r( 1.00000e+00) * )')+ 208 - - INPCMP(I,'(r( 0.00000e+000) * epsilon)')+ 209 - - INPCMP(I,'(r( 0.00000e+00) * epsilon)')+ 210 - - INPCMP(I,'(r( 0.00000e+000) * sigma)')+ 211 - - INPCMP(I,'(r( 0.00000e+00) * sigma)').NE.0)THEN 1 481 P=CELL D=MAPFM2 3 PAGE 652 212 - ICONT(I)=0 213 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', 214 - - '' Field '',I1,'': dummy.'')') I 215 - * unrecognised items. 216 - ELSE 217 - CALL INPSTR(I,I,STRING,NC) 218 - PRINT *,' !!!!!! MAPFM2 WARNING : The file ', 219 - - FMAP(1:NCMAP),' contains a "'//STRING(1:NC)// 220 - - '" field which is not known; field ignored.' 221 - ICONT(I)=0 222 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', 223 - - '' Field '',I1,'': not recognised.'')') I 224 - ENDIF 225 - * Ensure that the data type matches the declared type. 226 - IF(((ICONT(I).EQ.2.OR.ICONT(I).EQ.3.OR.ICONT(I).EQ.4).AND. 227 - - (IDATA.NE.0.AND.IDATA.NE.2.AND.IDATA.NE.10)).OR. 228 - - (ICONT(I).EQ.5.AND.(IDATA.NE.0.AND.IDATA.NE.5)).OR. 229 - - ((ICONT(I).EQ.6.OR.ICONT(I).EQ.7.OR.ICONT(I).EQ.8).AND. 230 - - (IDATA.NE.0.AND.IDATA.NE.6)).OR. 231 - - ((ICONT(I).EQ.9.OR.ICONT(I).EQ.-9).AND. 232 - - (IDATA.NE.0.AND.IDATA.NE.9)))THEN 233 - PRINT *,' !!!!!! MAPFM2 WARNING : Field ',I,' of file ', 234 - - FMAP(1:NCMAP),' does not contain the declared', 235 - - ' kind of data; skipped.' 236 - ICONT(I)=0 237 - ENDIF 238 - 40 CONTINUE 239 - *** Switch back to regular input. 240 - CALL INPSWI('RESTORE') 241 - *** Loop over the triangles. 242 - I=0 243 - NDELET=0 244 - DO 10 IREAD=1,NDECL 245 - IF(IREAD.EQ.MAX(1,NDECL/100)*(IREAD/MAX(1,NDECL/100))) 246 - - CALL PROSTA(2,REAL(IREAD)) 247 - *** Increment triangle count, checking there is space. 248 - IF(I+1.GT.MXMAP)THEN 249 - PRINT *,' !!!!!! MAPFM2 WARNING : Number of'// 250 - - ' triangles in ',FMAP(1:NCMAP), 251 - - ' exceeds compilation limit; file not read.' 252 - RETURN 253 - ELSE 254 - I=I+1 255 - ENDIF 256 - *** Skip until the line with the word "Vertices". 257 - 21 CONTINUE 258 - READ(12,'(A8)',END=2000,ERR=2010,IOSTAT=IOS) STRAUX 259 - IF(STRAUX.NE.'Vertices')GOTO 21 260 - *** Read vertex coordinates. 261 - DO 20 J=1,3 262 - * If the grid is already defined, merely store for check. 263 - IF(MAPFLG(1))THEN 264 - READ(12,'(E27.20,1X,E27.20,1X,E27.7)',END=2000,ERR=2010, 265 - - IOSTAT=IOS) XAUX(J),YAUX(J),ZAUX(J) 266 - XAUX(J)=XAUX(J)*100 267 - YAUX(J)=YAUX(J)*100 268 - ZAUX(J)=ZAUX(J)*100 269 - * See whether the triangle fits in the window. 270 - IF(WINDOW.AND.(XAUX(J).LT.WXMIN.OR.XAUX(J).GT.WXMAX.OR. 271 - - YAUX(J).LT.WYMIN.OR.YAUX(J).GT.WYMAX))THEN 272 - NDELET=NDELET+1 273 - I=I-1 274 - GOTO 10 275 - ENDIF 276 - * Otherwise store the grid, converting units from m to cm. 277 - ELSE 278 - READ(12,'(E27.20,1X,E27.20,1X,E27.7)',END=2000,ERR=2010, 279 - - IOSTAT=IOS) XMAP(I,J),YMAP(I,J),ZMAP(I,J) 280 - XMAP(I,J)=XMAP(I,J)*100 281 - YMAP(I,J)=YMAP(I,J)*100 282 - ZMAP(I,J)=ZMAP(I,J)*100 283 - * See whether the triangle fits in the window. 284 - IF(WINDOW.AND. 285 - - (XMAP(I,J).LT.WXMIN.OR.XMAP(I,J).GT.WXMAX.OR. 286 - - YMAP(I,J).LT.WYMIN.OR.YMAP(I,J).GT.WYMAX))THEN 287 - NDELET=NDELET+1 288 - C print *,' Elimination ',ndelet,' at triangle ',iread 289 - C print *,' point: ',xmap(i,j),ymap(i,j) 290 - I=I-1 291 - GOTO 10 292 - ENDIF 293 - * Update maxima and minima. 294 - IF(I.EQ.1.AND.J.EQ.1)THEN 295 - XMMIN=XMAP(I,J) 296 - XMMAX=XMAP(I,J) 297 - YMMIN=YMAP(I,J) 298 - YMMAX=YMAP(I,J) 299 - ELSE 300 - XMMIN=MIN(XMMIN,XMAP(I,J)) 301 - XMMAX=MAX(XMMAX,XMAP(I,J)) 302 - YMMIN=MIN(YMMIN,YMAP(I,J)) 303 - YMMAX=MAX(YMMAX,YMAP(I,J)) 304 - ENDIF 305 - * Update angular range. 306 - IF(XMAP(I,J).NE.0.OR.YMAP(I,J).NE.0)THEN 307 - IF(SETAZ)THEN 308 - ZAMIN=MIN(ZAMIN,ATAN2(YMAP(I,J),XMAP(I,J))) 309 - ZAMAX=MAX(ZAMAX,ATAN2(YMAP(I,J),XMAP(I,J))) 310 - ELSE 311 - ZAMIN=ATAN2(YMAP(I,J),XMAP(I,J)) 312 - ZAMAX=ATAN2(YMAP(I,J),XMAP(I,J)) 313 - SETAZ=.TRUE. 314 - ENDIF 315 - ENDIF 316 - ENDIF 317 - 20 CONTINUE 1 481 P=CELL D=MAPFM2 4 PAGE 653 318 - * Now check that the triangles fit. 319 - IF(MAPFLG(1))THEN 320 - CALL MAPIND((XAUX(1)+XAUX(2)+XAUX(3))/3, 321 - - (YAUX(1)+YAUX(2)+YAUX(3))/3, 322 - - (ZAUX(1)+ZAUX(2)+ZAUX(3))/3,T1,T2,T3,T4,IMAP) 323 - IF(I.NE.IMAP)THEN 324 - PRINT *,' !!!!!! MAPFM2 WARNING : The grid in ', 325 - - FMAP(1:NCMAP),' does not match the current'// 326 - - ' grid; file not read.' 327 - RETURN 328 - ENDIF 329 - ENDIF 330 - *** Read scalar field values over the triangle. 331 - IF(SCALAR)THEN 332 - SUM=0 333 - ** Read field values over the triangle. 334 - DO 60 J=1,6 335 - READ(12,'(E27.20,1X,E27.20)',END=2000,ERR=2010, 336 - - IOSTAT=IOS) TEMPRE,TEMPIM 337 - * Can be either a potential. 338 - IF(ICONT(1).EQ.5)THEN 339 - IF(J.EQ.1)THEN 340 - VMAP(I,1)=TEMPRE 341 - ELSEIF(J.EQ.4)THEN 342 - VMAP(I,2)=TEMPRE 343 - ELSEIF(J.EQ.6)THEN 344 - VMAP(I,3)=TEMPRE 345 - ELSEIF(J.EQ.2)THEN 346 - VMAP(I,4)=TEMPRE 347 - ELSEIF(J.EQ.3)THEN 348 - VMAP(I,5)=TEMPRE 349 - ELSEIF(J.EQ.5)THEN 350 - VMAP(I,6)=TEMPRE 351 - ENDIF 352 - * Or a dielectricum. 353 - ELSEIF(ICONT(1).EQ.9)THEN 354 - SUM=SUM+TEMPRE 355 - ENDIF 356 - 60 CONTINUE 357 - ** If dielectricum, identify the material. 358 - IF(ICONT(1).EQ.9)THEN 359 - SUM=SUM/(600*EPS0) 360 - IEPS=-1 361 - DO 100 J=1,NEPS 362 - IF(ABS(SUM-EPSMAT(J)).LT.1E-4*(ABS(SUM)+ 363 - - ABS(EPSMAT(J))))IEPS=J 364 - 100 CONTINUE 365 - IF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN 366 - PRINT *,' !!!!!! MAPFM2 WARNING : Unable'// 367 - - ' to store a dielectricum from file ', 368 - - FMAP(1:NCMAP),'; file not read.' 369 - RETURN 370 - ELSEIF(IEPS.LT.0)THEN 371 - NEPS=NEPS+1 372 - IEPS=NEPS 373 - EPSMAT(IEPS)=SUM 374 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2'', 375 - - '' DEBUG : Adding dielectricum with'', 376 - - '' eps='',E10.3,''.'')') EPSMAT(IEPS) 377 - ENDIF 378 - MATMAP(I)=IEPS 379 - NEWEPS=.TRUE. 380 - ** If a potential, keep track of potential range. 381 - ELSEIF(ICONT(1).EQ.5)THEN 382 - IF(I.EQ.1)THEN 383 - VMMIN=VMAP(I,1) 384 - VMMAX=VMAP(I,1) 385 - ENDIF 386 - VMMIN=MIN(VMMIN,VMAP(I,1),VMAP(I,2),VMAP(I,3), 387 - - VMAP(I,4),VMAP(I,5),VMAP(I,6)) 388 - VMMAX=MAX(VMMAX,VMAP(I,1),VMAP(I,2),VMAP(I,3), 389 - - VMAP(I,4),VMAP(I,5),VMAP(I,6)) 390 - ENDIF 391 - *** Read vectorial field values over the triangle. 392 - ELSE 393 - * Take care of knowing |D| either from Ex or by summing. 394 - IF(ICONT(1).EQ.-9.AND.ICONT(2).EQ.-9)THEN 395 - DXCOMP=0 396 - DYCOMP=0 397 - ELSEIF(MAPFLG(10))THEN 398 - DXCOMP=EXMAP(I,1) 399 - DYCOMP=EYMAP(I,1) 400 - ENDIF 401 - * Prepare a summing scalar for epsilons entered as such. 402 - SUM=0 403 - * Read the various fields. 404 - DO 30 J=1,18 405 - READ(12,'(E27.20,1X,E27.20)',END=2000,ERR=2010, 406 - - IOSTAT=IOS) TEMPRE,TEMPIM 407 - * Averaging of epsilons. 408 - IF(ICONT(1).EQ.9)THEN 409 - IF(J.LE.6)SUM=SUM+TEMPRE 410 - ELSEIF(ICONT(2).EQ.9)THEN 411 - IF(J.GT.6.AND.J.LE.12)SUM=SUM+TEMPRE 412 - ELSEIF(ICONT(3).EQ.9)THEN 413 - IF(J.GT.13.AND.J.LE.18)SUM=SUM+TEMPRE 414 - ENDIF 415 - * Ex or Bx corner 1. 416 - IF(J.EQ.1)THEN 417 - IF(ICONT(1).EQ.2)THEN 418 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 419 - EXMAP(I,1)=TEMPRE/100 420 - ELSEIF(IDATA.EQ.10)THEN 421 - EWXMAP(I,1,IWMAP)=TEMPRE/100 422 - ENDIF 423 - ELSEIF(ICONT(1).EQ.6)THEN 1 481 P=CELL D=MAPFM2 5 PAGE 654 424 - BXMAP(I,1)=TEMPRE 425 - ELSEIF(ICONT(1).EQ.-9)THEN 426 - DXCOMP=DXCOMP+TEMPRE/100 427 - ENDIF 428 - * Ex or Bx corner 2. 429 - ELSEIF(J.EQ.4)THEN 430 - IF(ICONT(1).EQ.2)THEN 431 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 432 - EXMAP(I,2)=TEMPRE/100 433 - ELSEIF(IDATA.EQ.10)THEN 434 - EWXMAP(I,2,IWMAP)=TEMPRE/100 435 - ENDIF 436 - ELSEIF(ICONT(1).EQ.6)THEN 437 - BXMAP(I,2)=TEMPRE 438 - ELSEIF(ICONT(1).EQ.-9)THEN 439 - DXCOMP=DXCOMP+TEMPRE/100 440 - ENDIF 441 - * Ex or Bx corner 3. 442 - ELSEIF(J.EQ.6)THEN 443 - IF(ICONT(1).EQ.2)THEN 444 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 445 - EXMAP(I,3)=TEMPRE/100 446 - ELSEIF(IDATA.EQ.10)THEN 447 - EWXMAP(I,3,IWMAP)=TEMPRE/100 448 - ENDIF 449 - ELSEIF(ICONT(1).EQ.6)THEN 450 - BXMAP(I,3)=TEMPRE 451 - ELSEIF(ICONT(1).EQ.-9)THEN 452 - DXCOMP=DXCOMP+TEMPRE/100 453 - ENDIF 454 - * Ex or Bx corner 4. 455 - ELSEIF(J.EQ.2)THEN 456 - IF(ICONT(1).EQ.2)THEN 457 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 458 - EXMAP(I,4)=TEMPRE/100 459 - ELSEIF(IDATA.EQ.10)THEN 460 - EWXMAP(I,4,IWMAP)=TEMPRE/100 461 - ENDIF 462 - ELSEIF(ICONT(1).EQ.6)THEN 463 - BXMAP(I,4)=TEMPRE 464 - ELSEIF(ICONT(1).EQ.-9)THEN 465 - DXCOMP=DXCOMP+TEMPRE/100 466 - ENDIF 467 - * Ex or Bx corner 5. 468 - ELSEIF(J.EQ.3)THEN 469 - IF(ICONT(1).EQ.2)THEN 470 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 471 - EXMAP(I,5)=TEMPRE/100 472 - ELSEIF(IDATA.EQ.10)THEN 473 - EWXMAP(I,5,IWMAP)=TEMPRE/100 474 - ENDIF 475 - ELSEIF(ICONT(1).EQ.6)THEN 476 - BXMAP(I,5)=TEMPRE 477 - ELSEIF(ICONT(1).EQ.-9)THEN 478 - DXCOMP=DXCOMP+TEMPRE/100 479 - ENDIF 480 - * Ex or Bx corner 6. 481 - ELSEIF(J.EQ.5)THEN 482 - IF(ICONT(1).EQ.2)THEN 483 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 484 - EXMAP(I,6)=TEMPRE/100 485 - ELSEIF(IDATA.EQ.10)THEN 486 - EWXMAP(I,6,IWMAP)=TEMPRE/100 487 - ENDIF 488 - ELSEIF(ICONT(1).EQ.6)THEN 489 - BXMAP(I,6)=TEMPRE 490 - ELSEIF(ICONT(1).EQ.-9)THEN 491 - DXCOMP=DXCOMP+TEMPRE/100 492 - ENDIF 493 - * Ey or By corner 1. 494 - ELSEIF(J.EQ.7)THEN 495 - IF(ICONT(2).EQ.3)THEN 496 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 497 - EYMAP(I,1)=TEMPRE/100 498 - ELSEIF(IDATA.EQ.10)THEN 499 - EWYMAP(I,1,IWMAP)=TEMPRE/100 500 - ENDIF 501 - ELSEIF(ICONT(2).EQ.7)THEN 502 - BYMAP(I,1)=TEMPRE 503 - ELSEIF(ICONT(2).EQ.-9)THEN 504 - DYCOMP=DYCOMP+TEMPRE/100 505 - ENDIF 506 - * Ey or By corner 2. 507 - ELSEIF(J.EQ.10)THEN 508 - IF(ICONT(2).EQ.3)THEN 509 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 510 - EYMAP(I,2)=TEMPRE/100 511 - ELSEIF(IDATA.EQ.10)THEN 512 - EWYMAP(I,2,IWMAP)=TEMPRE/100 513 - ENDIF 514 - ELSEIF(ICONT(2).EQ.7)THEN 515 - BYMAP(I,2)=TEMPRE 516 - ELSEIF(ICONT(2).EQ.-9)THEN 517 - DYCOMP=DYCOMP+TEMPRE/100 518 - ENDIF 519 - * Ey or By corner 3. 520 - ELSEIF(J.EQ.12)THEN 521 - IF(ICONT(2).EQ.3)THEN 522 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 523 - EYMAP(I,3)=TEMPRE/100 524 - ELSEIF(IDATA.EQ.10)THEN 525 - EWYMAP(I,3,IWMAP)=TEMPRE/100 526 - ENDIF 527 - ELSEIF(ICONT(2).EQ.7)THEN 528 - BYMAP(I,3)=TEMPRE 529 - ELSEIF(ICONT(2).EQ.-9)THEN 1 481 P=CELL D=MAPFM2 6 PAGE 655 530 - DYCOMP=DYCOMP+TEMPRE/100 531 - ENDIF 532 - * Ey or By corner 4. 533 - ELSEIF(J.EQ.8)THEN 534 - IF(ICONT(2).EQ.3)THEN 535 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 536 - EYMAP(I,4)=TEMPRE/100 537 - ELSEIF(IDATA.EQ.10)THEN 538 - EWYMAP(I,4,IWMAP)=TEMPRE/100 539 - ENDIF 540 - ELSEIF(ICONT(2).EQ.7)THEN 541 - BYMAP(I,4)=TEMPRE 542 - ELSEIF(ICONT(2).EQ.-9)THEN 543 - DYCOMP=DYCOMP+TEMPRE/100 544 - ENDIF 545 - * Ey or By corner 5. 546 - ELSEIF(J.EQ.9)THEN 547 - IF(ICONT(2).EQ.3)THEN 548 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 549 - EYMAP(I,5)=TEMPRE/100 550 - ELSEIF(IDATA.EQ.10)THEN 551 - EWYMAP(I,5,IWMAP)=TEMPRE/100 552 - ENDIF 553 - ELSEIF(ICONT(2).EQ.7)THEN 554 - BYMAP(I,5)=TEMPRE 555 - ELSEIF(ICONT(2).EQ.-9)THEN 556 - DYCOMP=DYCOMP+TEMPRE/100 557 - ENDIF 558 - * Ey or By corner 6. 559 - ELSEIF(J.EQ.11)THEN 560 - IF(ICONT(2).EQ.3)THEN 561 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 562 - EYMAP(I,6)=TEMPRE/100 563 - ELSEIF(IDATA.EQ.10)THEN 564 - EWYMAP(I,6,IWMAP)=TEMPRE/100 565 - ENDIF 566 - ELSEIF(ICONT(2).EQ.7)THEN 567 - BYMAP(I,6)=TEMPRE 568 - ELSEIF(ICONT(2).EQ.-9)THEN 569 - DYCOMP=DYCOMP+TEMPRE/100 570 - ENDIF 571 - * Ez or Bz corner 1. 572 - ELSEIF(J.EQ.13)THEN 573 - IF(ICONT(3).EQ.4)THEN 574 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 575 - EZMAP(I,1)=TEMPRE/100 576 - ELSEIF(IDATA.EQ.10)THEN 577 - EWZMAP(I,1,IWMAP)=TEMPRE/100 578 - ENDIF 579 - ELSEIF(ICONT(3).EQ.8)THEN 580 - BZMAP(I,1)=TEMPRE 581 - ENDIF 582 - * Ez or Bz corner 2. 583 - ELSEIF(J.EQ.16)THEN 584 - IF(ICONT(3).EQ.4)THEN 585 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 586 - EZMAP(I,2)=TEMPRE/100 587 - ELSEIF(IDATA.EQ.10)THEN 588 - EWZMAP(I,2,IWMAP)=TEMPRE/100 589 - ENDIF 590 - ELSEIF(ICONT(3).EQ.8)THEN 591 - BZMAP(I,2)=TEMPRE 592 - ENDIF 593 - * Ez or Bz corner 3. 594 - ELSEIF(J.EQ.18)THEN 595 - IF(ICONT(3).EQ.4)THEN 596 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 597 - EZMAP(I,3)=TEMPRE/100 598 - ELSEIF(IDATA.EQ.10)THEN 599 - EWZMAP(I,3,IWMAP)=TEMPRE/100 600 - ENDIF 601 - ELSEIF(ICONT(3).EQ.8)THEN 602 - BZMAP(I,3)=TEMPRE 603 - ENDIF 604 - * Ez or Bz corner 4. 605 - ELSEIF(J.EQ.14)THEN 606 - IF(ICONT(3).EQ.4)THEN 607 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 608 - EZMAP(I,4)=TEMPRE/100 609 - ELSEIF(IDATA.EQ.10)THEN 610 - EWZMAP(I,4,IWMAP)=TEMPRE/100 611 - ENDIF 612 - ELSEIF(ICONT(3).EQ.8)THEN 613 - BZMAP(I,4)=TEMPRE 614 - ENDIF 615 - * Ez or Bz corner 5. 616 - ELSEIF(J.EQ.15)THEN 617 - IF(ICONT(3).EQ.4)THEN 618 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 619 - EZMAP(I,5)=TEMPRE/100 620 - ELSEIF(IDATA.EQ.10)THEN 621 - EWZMAP(I,5,IWMAP)=TEMPRE/100 622 - ENDIF 623 - ELSEIF(ICONT(3).EQ.8)THEN 624 - BZMAP(I,5)=TEMPRE 625 - ENDIF 626 - * Ez or Bz corner 6. 627 - ELSEIF(J.EQ.17)THEN 628 - IF(ICONT(3).EQ.4)THEN 629 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 630 - EZMAP(I,6)=TEMPRE/100 631 - ELSEIF(IDATA.EQ.10)THEN 632 - EWZMAP(I,6,IWMAP)=TEMPRE/100 633 - ENDIF 634 - ELSEIF(ICONT(3).EQ.8)THEN 635 - BZMAP(I,6)=TEMPRE 1 481 P=CELL D=MAPFM2 7 PAGE 656 636 - ENDIF 637 - ENDIF 638 - 30 CONTINUE 639 - ** If dielectricum, identify the material. 640 - IF(ICONT(1).EQ.9.OR.ICONT(2).EQ.9.OR.ICONT(3).EQ.9)THEN 641 - SUM=SUM/(600*EPS0) 642 - IEPS=-1 643 - DO 160 J=1,NEPS 644 - IF(ABS(SUM-EPSMAT(J)).LT.1E-4*(ABS(SUM)+ 645 - - ABS(EPSMAT(J))))IEPS=J 646 - 160 CONTINUE 647 - IF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN 648 - PRINT *,' !!!!!! MAPFM2 WARNING : Unable'// 649 - - ' to store a dielectricum from file ', 650 - - FMAP(1:NCMAP),'; file not read.' 651 - RETURN 652 - ELSEIF(IEPS.LT.0)THEN 653 - NEPS=NEPS+1 654 - IEPS=NEPS 655 - EPSMAT(IEPS)=SUM 656 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2'', 657 - - '' DEBUG : Adding dielectricum with'', 658 - - '' eps='',E10.3,''.'')') EPSMAT(IEPS) 659 - ENDIF 660 - MATMAP(I)=IEPS 661 - ** Dielectricum identification via D/E comparison. 662 - ELSEIF((MAPFLG(2).AND.MAPFLG(3).AND. 663 - - (.NOT.MAPFLG(9)).AND. 664 - - ICONT(1).EQ.-9.AND.ICONT(2).EQ.-9).OR. 665 - - (MAPFLG(10).AND.(.NOT.MAPFLG(9)).AND. 666 - - ICONT(1).EQ.2.AND.ICONT(2).EQ.3))THEN 667 - IEPS=-1 668 - DCOMP=DXCOMP**2+DYCOMP**2 669 - ECOMP=(EXMAP(I,1)+EXMAP(I,2)+EXMAP(I,3)+ 670 - - EXMAP(I,4)+EXMAP(I,5)+EXMAP(I,6))**2+ 671 - - (EYMAP(I,1)+EYMAP(I,2)+EYMAP(I,3)+ 672 - - EYMAP(I,4)+EYMAP(I,5)+EYMAP(I,6))**2 673 - DO 170 J=1,NEPS 674 - IF(ABS(ECOMP*(100*EPS0*EPSMAT(J))**2-DCOMP).LT.1E-4* 675 - - (ABS(ECOMP*(100*EPS0*EPSMAT(J))**2)+ 676 - - ABS(DCOMP)))IEPS=J 677 - 170 CONTINUE 678 - IF(ECOMP.LE.0.AND.DCOMP.GT.0)THEN 679 - PRINT *,' !!!!!! MAPFM2 WARNING : Found'// 680 - - ' a dielectric constant of 0; skipped.' 681 - ELSEIF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN 682 - PRINT *,' !!!!!! MAPFM2 WARNING : Unable'// 683 - - ' to store a dielectricum from file ', 684 - - FMAP(1:NCMAP),'; file not read.' 685 - RETURN 686 - ELSEIF(IEPS.LT.0)THEN 687 - NEPS=NEPS+1 688 - IEPS=NEPS 689 - IF(ECOMP.LE.0)THEN 690 - PRINT *,' ------ MAPFM2 MESSAGE : Unable'// 691 - - ' to determine epsilon in an E=0'// 692 - - ' tetrahedron; epsilon set to 0.' 693 - EPSMAT(IEPS)=0 694 - ELSE 695 - EPSMAT(IEPS)=SQRT(DCOMP/ECOMP)/(100*EPS0) 696 - ENDIF 697 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2'', 698 - - '' DEBUG : Adding dielectricum with'', 699 - - '' eps='',E10.3,''.'')') EPSMAT(IEPS) 700 - ENDIF 701 - MATMAP(I)=IEPS 702 - NEWEPS=.TRUE. 703 - * Otherwise store the field. 704 - ELSEIF(ICONT(1).EQ.-9.AND.ICONT(2).EQ.-9.AND. 705 - - (.NOT.MAPFLG(2)).AND.(.NOT.MAPFLG(3)))THEN 706 - EXMAP(I,1)=DXCOMP 707 - EYMAP(I,1)=DYCOMP 708 - ENDIF 709 - ENDIF 710 - * Skip blank line at the end. 711 - READ(12,'()',END=2000,ERR=2010,IOSTAT=IOS) 712 - 10 CONTINUE 713 - *** Assign triangle count. 714 - IF(MAPFLG(1))THEN 715 - IF(I.NE.NMAP)THEN 716 - PRINT *,' !!!!!! MAPFM2 WARNING : Number of'// 717 - - ' triangles in ',FMAP(1:NCMAP),' does'// 718 - - ' not agree with previous files; not read.' 719 - RETURN 720 - ENDIF 721 - ELSE 722 - IF(I.LE.0)THEN 723 - PRINT *,' !!!!!! MAPFM2 WARNING : ',FMAP(1:NCMAP), 724 - - ' contain no triangles; not read.' 725 - RETURN 726 - ELSE 727 - NMAP=I 728 - ENDIF 729 - IF(WINDOW.AND.NDELET.NE.0)PRINT *,' ------ MAPFM2'// 730 - - ' MESSAGE : Found ',NDELET,' triangles partially'// 731 - - ' outside the WINDOW.' 732 - ENDIF 733 - *** Material has been defined is NEWEPS is set. 734 - IF(NEWEPS)MAPFLG(9)=.TRUE. 735 - *** Flag those elements which have been defined. 736 - MAPFLG(1)=.TRUE. 737 - DO 70 I=1,3 738 - IF(ICONT(I).EQ.2.OR.ICONT(I).EQ.3.OR.ICONT(I).EQ.4)THEN 739 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 740 - MAPFLG(ICONT(I))=.TRUE. 741 - ELSEIF(IDATA.EQ.10)THEN 1 481 P=CELL D=MAPFM2 8 PAGE 657 742 - MAPFLG(8+ICONT(I)+3*IWMAP-2)=.TRUE. 743 - ENDIF 744 - ELSEIF(ICONT(I).GT.0)THEN 745 - MAPFLG(ICONT(I))=.TRUE. 746 - ELSEIF(ICONT(I).EQ.-9)THEN 747 - MAPFLG(10)=.TRUE. 748 - ENDIF 749 - 70 CONTINUE 750 - *** Seems to have worked, set error flag to OK and return. 751 - IFAIL=0 752 - MAPTYP=2 753 - RETURN 754 - *** Handle error conditions. 755 - 2000 CONTINUE 756 - PRINT *,' !!!!!! MAPFM2 WARNING : Premature end of file on ', 757 - - FMAP(1:NCMAP),'; map not available.' 758 - RETURN 759 - 2010 CONTINUE 760 - PRINT *,' !!!!!! MAPFM2 WARNING : Error reading field map'// 761 - - ' file ',FMAP(1:NCMAP),'; map not available.' 762 - RETURN 763 - END 482 GARFIELD ================================================== P=CELL D=MAPFM3 1 ============================ 0 + +DECK,MAPFM3. 1 - SUBROUTINE MAPFM3(FMAP,NCMAP,IDATA,IWMAP, 2 - - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * MAPFM3 - Reads a Maxwell 3D table of tetrahedrons. 5 - * (Last changed on 29/11/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,FIELDMAP. 11.- +SEQ,CONSTANTS. 12 - INTEGER NDECL,IMAP,IEPS,ICONT(3),IMAX,IWMAP, 13 - - I,J,K,NCMAP,IFAIL,IFAIL1,IOS,NC,INPCMP, 14 - - NREAD,IDATA 15 - REAL TEMP(10),XAUX(4),YAUX(4),ZAUX(4),SUM,ECOMP,DCOMP, 16 - - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,T1,T2,T3,T4 17 - CHARACTER*(*) FMAP 18 - CHARACTER*80 STRING 19 - LOGICAL SCALAR,READ,WINDOW,NEWEPS 20 - EXTERNAL INPCMP 21 - *** Identify the routine if requested. 22 - IF(LIDENT)PRINT *,' /// ROUTINE MAPFM3 ///' 23 - *** Assume that this will fail. 24 - IFAIL=1 25 - *** First read the line with number of tetrahedrons. 26 - CALL INPCHK(4,1,IFAIL1) 27 - CALL INPRDI(4,NDECL,0) 28 - IF(IFAIL1.NE.0.OR.NDECL.LE.0)THEN 29 - PRINT *,' !!!!!! MAPFM3 WARNING : The file ', 30 - - FMAP(1:NCMAP),' has an unreadable number'// 31 - - ' of tetrahedrons; not read.' 32 - CALL INPSWI('RESTORE') 33 - RETURN 34 - ENDIF 35 - * Debugging output. 36 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG : Number'', 37 - - '' of tetrahedrons: '',I5)') NDECL 38 - * Progress printing. 39 - CALL PROFLD(2,'Tetrahedrons',REAL(NDECL)) 40 - *** See whether the data is scalar or vector. 41 - IF(INPCMP(1,'SCALAR').NE.0)THEN 42 - SCALAR=.TRUE. 43 - ELSEIF(INPCMP(1,'VECTOR').NE.0)THEN 44 - SCALAR=.FALSE. 45 - ELSE 46 - PRINT *,' !!!!!! MAPFM3 WARNING : The file ', 47 - - FMAP(1:NCMAP),' contains neither scalar nor'// 48 - - ' vectorial data; not read.' 49 - CALL INPSWI('RESTORE') 50 - RETURN 51 - ENDIF 52 - *** Next determine the contents of the file, read the next record. 53 - CALL INPGET 54 - * Set the expected word count. 55 - IF(SCALAR)THEN 56 - IMAX=1 57 - ELSE 58 - IMAX=3 59 - ENDIF 60 - * Initial contents flags. 61 - ICONT(1)=0 62 - ICONT(2)=0 63 - ICONT(3)=0 64 - READ=.FALSE. 65 - NEWEPS=.FALSE. 66 - * Loop over the words. 67 - DO 40 I=1,IMAX 68 - * Ex. 69 - IF(INPCMP(I,'smh(E(x))').NE.0)THEN 70 - ICONT(I)=2 71 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', 72 - - '' Field '',I1,'': x-component E field.'')') I 73 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 74 - IF(MAPFLG(2))PRINT *,' ------ MAPFM3 MESSAGE :'// 75 - - ' Overwriting current Ex map.' 76 - MAPFLG(2)=.FALSE. 77 - ELSEIF(IDATA.EQ.10)THEN 78 - IF(MAPFLG(10+3*IWMAP-2)) 79 - - PRINT *,' ------ MAPFM3 MESSAGE :'// 80 - - ' Overwriting current weighting Ex map.' 1 482 P=CELL D=MAPFM3 2 PAGE 658 81 - MAPFLG(10+3*IWMAP-2)=.FALSE. 82 - ENDIF 83 - * Ey. 84 - ELSEIF(INPCMP(I,'smh(E(y))').NE.0)THEN 85 - ICONT(I)=3 86 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', 87 - - '' Field '',I1,'': y-component E field.'')') I 88 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 89 - IF(MAPFLG(3))PRINT *,' ------ MAPFM3 MESSAGE :'// 90 - - ' Overwriting current Ey map.' 91 - MAPFLG(3)=.FALSE. 92 - ELSEIF(IDATA.EQ.10)THEN 93 - IF(MAPFLG(11+3*IWMAP-2)) 94 - - PRINT *,' ------ MAPFM3 MESSAGE :'// 95 - - ' Overwriting current weighting Ey map.' 96 - MAPFLG(11+3*IWMAP-2)=.FALSE. 97 - ENDIF 98 - * Ez. 99 - ELSEIF(INPCMP(I,'smh(E(z))').NE.0)THEN 100 - ICONT(I)=4 101 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', 102 - - '' Field '',I1,'': z-component E field.'')') I 103 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 104 - IF(MAPFLG(4))PRINT *,' ------ MAPFM3 MESSAGE :'// 105 - - ' Overwriting current Ez map.' 106 - MAPFLG(4)=.FALSE. 107 - ELSEIF(IDATA.EQ.10)THEN 108 - IF(MAPFLG(12+3*IWMAP-2)) 109 - - PRINT *,' ------ MAPFM3 MESSAGE :'// 110 - - ' Overwriting current weighting Ez map.' 111 - MAPFLG(12+3*IWMAP-2)=.FALSE. 112 - ENDIF 113 - * Dx. 114 - ELSEIF(INPCMP(I,'smh(D(x))').NE.0)THEN 115 - ICONT(I)=-9 116 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', 117 - - '' Field '',I1,'': x-component D field.'')') I 118 - IF(MAPFLG(9))PRINT *,' ------ MAPFM3 MESSAGE :'// 119 - - ' Overwriting current material map.' 120 - MAPFLG(9)=.FALSE. 121 - MATSRC='EPSILON' 122 - * Dy. 123 - ELSEIF(INPCMP(I,'smh(D(y))').NE.0)THEN 124 - ICONT(I)=-9 125 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', 126 - - '' Field '',I1,'': y-component D field.'')') I 127 - IF(MAPFLG(9))PRINT *,' ------ MAPFM3 MESSAGE :'// 128 - - ' Overwriting current material map.' 129 - MAPFLG(9)=.FALSE. 130 - MATSRC='EPSILON' 131 - * Dz. 132 - ELSEIF(INPCMP(I,'smh(D(z))').NE.0)THEN 133 - ICONT(I)=-9 134 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', 135 - - '' Field '',I1,'': z-component D field.'')') I 136 - IF(MAPFLG(9))PRINT *,' ------ MAPFM3 MESSAGE :'// 137 - - ' Overwriting current material map.' 138 - MAPFLG(9)=.FALSE. 139 - MATSRC='EPSILON' 140 - * Unsmoothed electric fields. 141 - ELSEIF(INPCMP(I,'E(x)')+INPCMP(I,'E(y)')+INPCMP(I,'E(z)')+ 142 - - INPCMP(I,'D(x)')+INPCMP(I,'D(y)')+INPCMP(I,'D(z)').NE. 143 - - 0)THEN 144 - ICONT(I)=0 145 - PRINT *,' !!!!!! MAPFM3 WARNING : Maxwell 3D fields must'// 146 - - ' be smoothed; field not read.' 147 - * V. 148 - ELSEIF(INPCMP(I,'smh(phi)')+INPCMP(I,'phi').NE.0)THEN 149 - ICONT(I)=5 150 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', 151 - - '' Field '',I1,'': potential.'')') I 152 - IF(MAPFLG(5))PRINT *,' ------ MAPFM3 MESSAGE :'// 153 - - ' Overwriting current potential map.' 154 - MAPFLG(5)=.FALSE. 155 - * Bx. 156 - ELSEIF(INPCMP(I,'smh(B(x))')+INPCMP(I,'B(x)').NE.0)THEN 157 - ICONT(I)=6 158 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', 159 - - '' Field '',I1,'': x-component B field.'')') I 160 - IF(MAPFLG(6))PRINT *,' ------ MAPFM3 MESSAGE :'// 161 - - ' Overwriting current Bx map.' 162 - MAPFLG(6)=.FALSE. 163 - * By. 164 - ELSEIF(INPCMP(I,'smh(B(y))')+INPCMP(I,'B(y)').NE.0)THEN 165 - ICONT(I)=7 166 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', 167 - - '' Field '',I1,'': y-component B field.'')') I 168 - IF(MAPFLG(7))PRINT *,' ------ MAPFM3 MESSAGE :'// 169 - - ' Overwriting current By map.' 170 - MAPFLG(7)=.FALSE. 171 - * Bz. 172 - ELSEIF(INPCMP(I,'smh(B(z))')+INPCMP(I,'B(z)').NE.0)THEN 173 - ICONT(I)=8 174 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', 175 - - '' Field '',I1,'': z-component B field.'')') I 176 - IF(MAPFLG(8))PRINT *,' ------ MAPFM3 MESSAGE :'// 177 - - ' Overwriting current Bz map.' 178 - MAPFLG(8)=.FALSE. 179 - * epsilon. 180 - ELSEIF(INPCMP(I,'(r( 1.00000e+00) * epsilon)')+ 181 - - INPCMP(I,'(r( 1.00000e+000) * epsilon)').NE.0)THEN 182 - ICONT(I)=9 183 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', 184 - - '' Field '',I1,'': dielectric constant.'')') I 185 - IF(MAPFLG(9))PRINT *,' ------ MAPFM3 MESSAGE :'// 186 - - ' Overwriting material map.' 1 482 P=CELL D=MAPFM3 3 PAGE 659 187 - MAPFLG(9)=.FALSE. 188 - MATSRC='EPSILON' 189 - * sigma. 190 - ELSEIF(INPCMP(I,'(r( 1.00000e+00) * sigma)')+ 191 - - INPCMP(I,'(r( 1.00000e+000) * sigma)').NE.0)THEN 192 - ICONT(I)=9 193 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', 194 - - '' Field '',I1,'': conductivity.'')') I 195 - IF(MAPFLG(9))PRINT *,' ------ MAPFM3 MESSAGE :'// 196 - - ' Overwriting material map.' 197 - MAPFLG(9)=.FALSE. 198 - MATSRC='SIGMA' 199 - * dummy field. 200 - ELSEIF(INPCMP(I,'smh(0)')+INPCMP(I,'0')+ 201 - - INPCMP(I,'r( 0.00000e+00)')+ 202 - - INPCMP(I,'(r( 1.00000e+00) * )')+ 203 - - INPCMP(I,'(r( 0.00000e+000) * epsilon)')+ 204 - - INPCMP(I,'(r( 0.00000e+00) * epsilon)')+ 205 - - INPCMP(I,'(r( 0.00000e+000) * sigma)')+ 206 - - INPCMP(I,'(r( 0.00000e+00) * sigma)').NE.0)THEN 207 - ICONT(I)=0 208 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', 209 - - '' Field '',I1,'': dummy.'')') I 210 - * unrecognised items. 211 - ELSE 212 - CALL INPSTR(I,I,STRING,NC) 213 - PRINT *,' !!!!!! MAPFM3 WARNING : The file ', 214 - - FMAP(1:NCMAP),' contains a "'//STRING(1:NC)// 215 - - '" field which is not known; field ignored.' 216 - ICONT(I)=0 217 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', 218 - - '' Field '',I1,'': not recognised.'')') I 219 - ENDIF 220 - * Check whether reading is required. 221 - IF(ICONT(I).NE.0)READ=.TRUE. 222 - * Ensure that the data type matches the declared type. 223 - IF(((ICONT(I).EQ.2.OR.ICONT(I).EQ.3.OR.ICONT(I).EQ.4).AND. 224 - - (IDATA.NE.0.AND.IDATA.NE.2.AND.IDATA.NE.10)).OR. 225 - - (ICONT(I).EQ.5.AND.(IDATA.NE.0.AND.IDATA.NE.5)).OR. 226 - - ((ICONT(I).EQ.6.OR.ICONT(I).EQ.7.OR.ICONT(I).EQ.8).AND. 227 - - (IDATA.NE.0.AND.IDATA.NE.6)).OR. 228 - - ((ICONT(I).EQ.9.OR.ICONT(I).EQ.-9).AND. 229 - - (IDATA.NE.0.AND.IDATA.NE.9)))THEN 230 - PRINT *,' !!!!!! MAPFM3 WARNING : Field ',I,' of file ', 231 - - FMAP(1:NCMAP),' does not contain the declared', 232 - - ' kind of data; skipped.' 233 - ICONT(I)=0 234 - ENDIF 235 - 40 CONTINUE 236 - *** Switch back to regular input. 237 - CALL INPSWI('RESTORE') 238 - * See whether any item is left. 239 - IF(.NOT.READ)THEN 240 - PRINT *,' !!!!!! MAPFM3 WARNING : The file ', 241 - - FMAP(1:NCMAP),' contains no useable'// 242 - - ' information; file not read.' 243 - RETURN 244 - ENDIF 245 - *** Loop over the tetrahedrons. 246 - NREAD=0 247 - DO 10 I=1,NDECL 248 - IF(I.EQ.MAX(1,NDECL/100)*(I/MAX(1,NDECL/100))) 249 - - CALL PROSTA(2,REAL(I)) 250 - *** Read the line with the word "Vertices" or with "x". 251 - 50 CONTINUE 252 - READ(12,'(A80)',END=2000,ERR=2010,IOSTAT=IOS) STRING 253 - IF(STRING(1:8).NE.'Vertices')GOTO 50 254 - * Ensure there is still space in memory. 255 - IF(.NOT.MAPFLG(1))THEN 256 - IF(NREAD+1.GT.MXMAP)THEN 257 - PRINT *,' !!!!!! MAPFM3 WARNING : Number of'// 258 - - ' tetrahedrons in ',FMAP(1:NCMAP), 259 - - ' exceeds compilation limit; file not read.' 260 - RETURN 261 - ENDIF 262 - ENDIF 263 - *** Read vertex coordinates. 264 - DO 20 J=1,4 265 - * If the grid is already defined, merely store for check. 266 - IF(MAPFLG(1))THEN 267 - READ(12,'(E27.20,1X,E27.20,1X,E27.7)',END=2000,ERR=2010, 268 - - IOSTAT=IOS) XAUX(J),YAUX(J),ZAUX(J) 269 - XAUX(J)=XAUX(J)*100 270 - YAUX(J)=YAUX(J)*100 271 - ZAUX(J)=ZAUX(J)*100 272 - * Otherwise store the grid, converting units from m to cm. 273 - ELSE 274 - READ(12,'(E27.20,1X,E27.20,1X,E27.7)',END=2000,ERR=2010, 275 - - IOSTAT=IOS) XMAP(I,J),YMAP(I,J),ZMAP(I,J) 276 - XMAP(I,J)=XMAP(I,J)*100 277 - YMAP(I,J)=YMAP(I,J)*100 278 - ZMAP(I,J)=ZMAP(I,J)*100 279 - IF(I.EQ.1.AND.J.EQ.1)THEN 280 - XMMIN=XMAP(I,J) 281 - XMMAX=XMAP(I,J) 282 - YMMIN=YMAP(I,J) 283 - YMMAX=YMAP(I,J) 284 - ZMMIN=ZMAP(I,J) 285 - ZMMAX=ZMAP(I,J) 286 - ELSE 287 - XMMIN=MIN(XMMIN,XMAP(I,J)) 288 - XMMAX=MAX(XMMAX,XMAP(I,J)) 289 - YMMIN=MIN(YMMIN,YMAP(I,J)) 290 - YMMAX=MAX(YMMAX,YMAP(I,J)) 291 - ZMMIN=MIN(ZMMIN,ZMAP(I,J)) 292 - ZMMAX=MAX(ZMMAX,ZMAP(I,J)) 1 482 P=CELL D=MAPFM3 4 PAGE 660 293 - ENDIF 294 - * Update angular range. 295 - IF(YMAP(I,J).NE.0.OR.ZMAP(I,J).NE.0)THEN 296 - IF(SETAX)THEN 297 - XAMIN=MIN(XAMIN,ATAN2(ZMAP(I,J),YMAP(I,J))) 298 - XAMAX=MAX(XAMAX,ATAN2(ZMAP(I,J),YMAP(I,J))) 299 - ELSE 300 - XAMIN=ATAN2(ZMAP(I,J),YMAP(I,J)) 301 - XAMAX=ATAN2(ZMAP(I,J),YMAP(I,J)) 302 - SETAX=.TRUE. 303 - ENDIF 304 - ENDIF 305 - IF(ZMAP(I,J).NE.0.OR.XMAP(I,J).NE.0)THEN 306 - IF(SETAY)THEN 307 - YAMIN=MIN(YAMIN,ATAN2(XMAP(I,J),ZMAP(I,J))) 308 - YAMAX=MAX(YAMAX,ATAN2(XMAP(I,J),ZMAP(I,J))) 309 - ELSE 310 - YAMIN=ATAN2(XMAP(I,J),ZMAP(I,J)) 311 - YAMAX=ATAN2(XMAP(I,J),ZMAP(I,J)) 312 - SETAY=.TRUE. 313 - ENDIF 314 - ENDIF 315 - IF(XMAP(I,J).NE.0.OR.YMAP(I,J).NE.0)THEN 316 - IF(SETAZ)THEN 317 - ZAMIN=MIN(ZAMIN,ATAN2(YMAP(I,J),XMAP(I,J))) 318 - ZAMAX=MAX(ZAMAX,ATAN2(YMAP(I,J),XMAP(I,J))) 319 - ELSE 320 - ZAMIN=ATAN2(YMAP(I,J),XMAP(I,J)) 321 - ZAMAX=ATAN2(YMAP(I,J),XMAP(I,J)) 322 - SETAZ=.TRUE. 323 - ENDIF 324 - ENDIF 325 - ENDIF 326 - 20 CONTINUE 327 - * Now check that the tetrahedrons fit. 328 - IF(MAPFLG(1))THEN 329 - CALL MAPIND((XAUX(1)+XAUX(2)+XAUX(3)+XAUX(4))/4, 330 - - (YAUX(1)+YAUX(2)+YAUX(3)+YAUX(4))/4, 331 - - (ZAUX(1)+ZAUX(2)+ZAUX(3)+ZAUX(4))/4,T1,T2,T3,T4,IMAP) 332 - IF(IMAP.NE.I)THEN 333 - PRINT *,' !!!!!! MAPFM3 WARNING : The grid in ', 334 - - FMAP(1:NCMAP),' does not match the current'// 335 - - ' grid; file not read.' 336 - WRITE(LUNOUT,'('' Read tetrahedron '',I6, 337 - - 4(/'' (x,y,z) = '',3F15.6)/ 338 - - '' Found tetrahedron '',I6, 339 - - 4(/'' (x,y,z) = '',3F15.6))') 340 - - I,(XAUX(J),YAUX(J),ZAUX(J),J=1,4), 341 - - IMAP,(XMAP(IMAP,J),YMAP(IMAP,J),ZMAP(IMAP,J),J=1,4) 342 - C RETURN 343 - ENDIF 344 - ENDIF 345 - *** Read scalar field values over the tetrahedron. 346 - IF(SCALAR)THEN 347 - ** Read field values over the tetrahedron. 348 - READ(12,'(10(E27.20,1X))',END=2000,ERR=2010, 349 - - IOSTAT=IOS) (TEMP(J),J=1,10) 350 - * Can be either a potential. 351 - IF(ICONT(1).EQ.5)THEN 352 - VMAP(I,1)=TEMP(1) 353 - VMAP(I,2)=TEMP(5) 354 - VMAP(I,3)=TEMP(8) 355 - VMAP(I,4)=TEMP(10) 356 - VMAP(I,5)=TEMP(2) 357 - VMAP(I,6)=TEMP(3) 358 - VMAP(I,7)=TEMP(4) 359 - VMAP(I,8)=TEMP(6) 360 - VMAP(I,9)=TEMP(7) 361 - VMAP(I,10)=TEMP(9) 362 - * Or a dielectricum. 363 - ELSEIF(ICONT(1).EQ.9)THEN 364 - SUM=0 365 - DO 60 J=1,10 366 - SUM=SUM+TEMP(J) 367 - 60 CONTINUE 368 - SUM=SUM/(1000*EPS0) 369 - ENDIF 370 - ** If dielectricum, identify the material. 371 - IF(ICONT(1).EQ.9)THEN 372 - IEPS=-1 373 - DO 100 J=1,NEPS 374 - IF(ABS(SUM-EPSMAT(J)).LT.1E-4*(ABS(SUM)+ 375 - - ABS(EPSMAT(J))))IEPS=J 376 - 100 CONTINUE 377 - IF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN 378 - PRINT *,' !!!!!! MAPFM3 WARNING : Unable'// 379 - - ' to store a dielectricum from file ', 380 - - FMAP(1:NCMAP),'; file not read.' 381 - RETURN 382 - ELSEIF(IEPS.LT.0)THEN 383 - NEPS=NEPS+1 384 - IEPS=NEPS 385 - EPSMAT(IEPS)=SUM 386 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3'', 387 - - '' DEBUG : Adding dielectricum with'', 388 - - '' eps='',E10.3,''.'')') EPSMAT(IEPS) 389 - ENDIF 390 - MATMAP(I)=IEPS 391 - ** If a potential, keep track of potential range. 392 - ELSEIF(ICONT(1).EQ.5)THEN 393 - IF(I.EQ.1)THEN 394 - VMMIN=VMAP(I,1) 395 - VMMAX=VMAP(I,1) 396 - ENDIF 397 - VMMIN=MIN(VMMIN,VMAP(I,1),VMAP(I,2),VMAP(I,3), 398 - - VMAP(I,4),VMAP(I,5),VMAP(I,6),VMAP(I,7), 1 482 P=CELL D=MAPFM3 5 PAGE 661 399 - - VMAP(I,8),VMAP(I,9),VMAP(I,10)) 400 - VMMAX=MAX(VMMAX,VMAP(I,1),VMAP(I,2),VMAP(I,3), 401 - - VMAP(I,4),VMAP(I,5),VMAP(I,6),VMAP(I,7), 402 - - VMAP(I,8),VMAP(I,9),VMAP(I,10)) 403 - ENDIF 404 - *** Read vectorial field values over the tetrahedron. 405 - ELSE 406 - * Take care of knowing |D| either from Ex or by summing. 407 - IF(ICONT(1).EQ.-9.AND.ICONT(2).EQ.-9.AND. 408 - - ICONT(3).EQ.-9)THEN 409 - DCOMP=0 410 - ELSEIF(MAPFLG(10))THEN 411 - DCOMP=EXMAP(I,1) 412 - ENDIF 413 - * Loop over the vectors. 414 - DO 30 J=1,3 415 - READ(12,'(10(E27.20,1X))',END=2000,ERR=2010, 416 - - IOSTAT=IOS) (TEMP(K),K=1,10) 417 - * Averaging of epsilons. 418 - IF(ICONT(J).EQ.9)THEN 419 - SUM=0 420 - DO 80 K=1,10 421 - SUM=SUM+TEMP(K) 422 - 80 CONTINUE 423 - SUM=SUM/(1000*EPS0) 424 - ELSEIF(ICONT(J).EQ.-9)THEN 425 - DCOMP=DCOMP+(TEMP(1)+TEMP(5)+TEMP(8)+TEMP(10))**2/ 426 - - 160000 427 - ENDIF 428 - * Ex or EWx 429 - IF(ICONT(J).EQ.2)THEN 430 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 431 - EXMAP(I,1)=TEMP(1)/100 432 - EXMAP(I,2)=TEMP(5)/100 433 - EXMAP(I,3)=TEMP(8)/100 434 - EXMAP(I,4)=TEMP(10)/100 435 - EXMAP(I,5)=TEMP(2)/100 436 - EXMAP(I,6)=TEMP(3)/100 437 - EXMAP(I,7)=TEMP(4)/100 438 - EXMAP(I,8)=TEMP(6)/100 439 - EXMAP(I,9)=TEMP(7)/100 440 - EXMAP(I,10)=TEMP(9)/100 441 - ELSEIF(IDATA.EQ.10)THEN 442 - EWXMAP(I,1,IWMAP)=TEMP(1)/100 443 - EWXMAP(I,2,IWMAP)=TEMP(5)/100 444 - EWXMAP(I,3,IWMAP)=TEMP(8)/100 445 - EWXMAP(I,4,IWMAP)=TEMP(10)/100 446 - EWXMAP(I,5,IWMAP)=TEMP(2)/100 447 - EWXMAP(I,6,IWMAP)=TEMP(3)/100 448 - EWXMAP(I,7,IWMAP)=TEMP(4)/100 449 - EWXMAP(I,8,IWMAP)=TEMP(6)/100 450 - EWXMAP(I,9,IWMAP)=TEMP(7)/100 451 - EWXMAP(I,10,IWMAP)=TEMP(9)/100 452 - ENDIF 453 - * Bx. 454 - ELSEIF(ICONT(J).EQ.6)THEN 455 - BXMAP(I,1)=TEMP(1) 456 - BXMAP(I,2)=TEMP(5) 457 - BXMAP(I,3)=TEMP(8) 458 - BXMAP(I,4)=TEMP(10) 459 - BXMAP(I,5)=TEMP(2) 460 - BXMAP(I,6)=TEMP(3) 461 - BXMAP(I,7)=TEMP(4) 462 - BXMAP(I,8)=TEMP(6) 463 - BXMAP(I,9)=TEMP(7) 464 - BXMAP(I,10)=TEMP(9) 465 - * Ey or EWy. 466 - ELSEIF(ICONT(J).EQ.3)THEN 467 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 468 - EYMAP(I,1)=TEMP(1)/100 469 - EYMAP(I,2)=TEMP(5)/100 470 - EYMAP(I,3)=TEMP(8)/100 471 - EYMAP(I,4)=TEMP(10)/100 472 - EYMAP(I,5)=TEMP(2)/100 473 - EYMAP(I,6)=TEMP(3)/100 474 - EYMAP(I,7)=TEMP(4)/100 475 - EYMAP(I,8)=TEMP(6)/100 476 - EYMAP(I,9)=TEMP(7)/100 477 - EYMAP(I,10)=TEMP(9)/100 478 - ELSEIF(IDATA.EQ.10)THEN 479 - EWYMAP(I,1,IWMAP)=TEMP(1)/100 480 - EWYMAP(I,2,IWMAP)=TEMP(5)/100 481 - EWYMAP(I,3,IWMAP)=TEMP(8)/100 482 - EWYMAP(I,4,IWMAP)=TEMP(10)/100 483 - EWYMAP(I,5,IWMAP)=TEMP(2)/100 484 - EWYMAP(I,6,IWMAP)=TEMP(3)/100 485 - EWYMAP(I,7,IWMAP)=TEMP(4)/100 486 - EWYMAP(I,8,IWMAP)=TEMP(6)/100 487 - EWYMAP(I,9,IWMAP)=TEMP(7)/100 488 - EWYMAP(I,10,IWMAP)=TEMP(9)/100 489 - ENDIF 490 - * By. 491 - ELSEIF(ICONT(J).EQ.7)THEN 492 - BYMAP(I,1)=TEMP(1) 493 - BYMAP(I,2)=TEMP(5) 494 - BYMAP(I,3)=TEMP(8) 495 - BYMAP(I,4)=TEMP(10) 496 - BYMAP(I,5)=TEMP(2) 497 - BYMAP(I,6)=TEMP(3) 498 - BYMAP(I,7)=TEMP(4) 499 - BYMAP(I,8)=TEMP(6) 500 - BYMAP(I,9)=TEMP(7) 501 - BYMAP(I,10)=TEMP(9) 502 - * Ez or EWz. 503 - ELSEIF(ICONT(J).EQ.4)THEN 504 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 1 482 P=CELL D=MAPFM3 6 PAGE 662 505 - EZMAP(I,1)=TEMP(1)/100 506 - EZMAP(I,2)=TEMP(5)/100 507 - EZMAP(I,3)=TEMP(8)/100 508 - EZMAP(I,4)=TEMP(10)/100 509 - EZMAP(I,5)=TEMP(2)/100 510 - EZMAP(I,6)=TEMP(3)/100 511 - EZMAP(I,7)=TEMP(4)/100 512 - EZMAP(I,8)=TEMP(6)/100 513 - EZMAP(I,9)=TEMP(7)/100 514 - EZMAP(I,10)=TEMP(9)/100 515 - ELSEIF(IDATA.EQ.10)THEN 516 - EWZMAP(I,1,IWMAP)=TEMP(1)/100 517 - EWZMAP(I,2,IWMAP)=TEMP(5)/100 518 - EWZMAP(I,3,IWMAP)=TEMP(8)/100 519 - EWZMAP(I,4,IWMAP)=TEMP(10)/100 520 - EWZMAP(I,5,IWMAP)=TEMP(2)/100 521 - EWZMAP(I,6,IWMAP)=TEMP(3)/100 522 - EWZMAP(I,7,IWMAP)=TEMP(4)/100 523 - EWZMAP(I,8,IWMAP)=TEMP(6)/100 524 - EWZMAP(I,9,IWMAP)=TEMP(7)/100 525 - EWZMAP(I,10,IWMAP)=TEMP(9)/100 526 - ENDIF 527 - * Bz. 528 - ELSEIF(ICONT(J).EQ.8)THEN 529 - BZMAP(I,1)=TEMP(1) 530 - BZMAP(I,2)=TEMP(5) 531 - BZMAP(I,3)=TEMP(8) 532 - BZMAP(I,4)=TEMP(10) 533 - BZMAP(I,5)=TEMP(2) 534 - BZMAP(I,6)=TEMP(3) 535 - BZMAP(I,7)=TEMP(4) 536 - BZMAP(I,8)=TEMP(6) 537 - BZMAP(I,9)=TEMP(7) 538 - BZMAP(I,10)=TEMP(9) 539 - ENDIF 540 - 30 CONTINUE 541 - ** If dielectricum, identify the material. 542 - IF(ICONT(1).EQ.9.OR.ICONT(2).EQ.9.OR.ICONT(3).EQ.9)THEN 543 - IEPS=-1 544 - DO 160 J=1,NEPS 545 - IF(ABS(SUM-EPSMAT(J)).LT.1E-4*(ABS(SUM)+ 546 - - ABS(EPSMAT(J))))IEPS=J 547 - 160 CONTINUE 548 - IF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN 549 - PRINT *,' !!!!!! MAPFM3 WARNING : Unable'// 550 - - ' to store a dielectricum from file ', 551 - - FMAP(1:NCMAP),'; file not read.' 552 - RETURN 553 - ELSEIF(IEPS.LT.0)THEN 554 - NEPS=NEPS+1 555 - IEPS=NEPS 556 - EPSMAT(IEPS)=SUM 557 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3'', 558 - - '' DEBUG : Adding dielectricum with'', 559 - - '' eps='',E10.3,''.'')') EPSMAT(IEPS) 560 - ENDIF 561 - MATMAP(I)=IEPS 562 - NEWEPS=.TRUE. 563 - ** Dielectricum identification via D/E comparison. 564 - ELSEIF((MAPFLG(2).AND.MAPFLG(3).AND.MAPFLG(4).AND. 565 - - (.NOT.MAPFLG(9)).AND.ICONT(1).EQ.-9.AND. 566 - - ICONT(2).EQ.-9.AND.ICONT(3).EQ.-9).OR. 567 - - (MAPFLG(10).AND.(.NOT.MAPFLG(9)).AND. 568 - - ICONT(1).EQ.2.AND.ICONT(2).EQ.3.AND. 569 - - ICONT(3).EQ.4))THEN 570 - IEPS=-1 571 - ECOMP=((EXMAP(I,1)+EXMAP(I,2)+EXMAP(I,3)+ 572 - - EXMAP(I,4))**2+(EYMAP(I,1)+EYMAP(I,2)+ 573 - - EYMAP(I,3)+EYMAP(I,4))**2+(EZMAP(I,1)+ 574 - - EZMAP(I,2)+EZMAP(I,3)+EZMAP(I,4))**2)/16 575 - DO 170 J=1,NEPS 576 - IF(ABS(ECOMP*(100*EPS0*EPSMAT(J))**2-DCOMP).LT.1E-4* 577 - - (ABS(ECOMP*(100*EPS0*EPSMAT(J))**2)+ 578 - - ABS(DCOMP)))IEPS=J 579 - 170 CONTINUE 580 - IF(ECOMP.LE.0.AND.DCOMP.GT.0)THEN 581 - PRINT *,' !!!!!! MAPFM3 WARNING : Found'// 582 - - ' a dielectric constant of 0; skipped.' 583 - ELSEIF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN 584 - PRINT *,' !!!!!! MAPFM3 WARNING : Unable'// 585 - - ' to store a dielectricum from file ', 586 - - FMAP(1:NCMAP),'; file not read.' 587 - RETURN 588 - ELSEIF(IEPS.LT.0)THEN 589 - NEPS=NEPS+1 590 - IEPS=NEPS 591 - IF(ECOMP.LE.0)THEN 592 - PRINT *,' ------ MAPFM3 MESSAGE : Unable'// 593 - - ' to determine epsilon in an E=0'// 594 - - ' tetrahedron; epsilon set to 0.' 595 - EPSMAT(IEPS)=0 596 - ELSE 597 - EPSMAT(IEPS)=SQRT(DCOMP/ECOMP)/(100*EPS0) 598 - ENDIF 599 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3'', 600 - - '' DEBUG : Adding dielectricum with'', 601 - - '' eps='',E10.3,''.'')') EPSMAT(IEPS) 602 - ENDIF 603 - MATMAP(I)=IEPS 604 - NEWEPS=.TRUE. 605 - * Otherwise store the field. 606 - ELSEIF(ICONT(1).EQ.-9.AND.ICONT(2).EQ.-9.AND. 607 - - ICONT(3).EQ.-9.AND.(.NOT.MAPFLG(2)))THEN 608 - EXMAP(I,1)=DCOMP 609 - ENDIF 610 - ENDIF 1 482 P=CELL D=MAPFM3 7 PAGE 663 611 - * Update the count. 612 - NREAD=NREAD+1 613 - * Skip the line with "h" at the end. 614 - READ(12,'()',END=2000,ERR=2010,IOSTAT=IOS) 615 - 10 CONTINUE 616 - *** Be sure something has been read. 617 - 2000 CONTINUE 618 - IF(MAPFLG(1))THEN 619 - IF(NREAD.NE.NMAP)THEN 620 - PRINT *,' !!!!!! MAPFM3 WARNING : Number of'// 621 - - ' tetrahedrons in ',FMAP(1:NCMAP),' does'// 622 - - ' not agree with previous files; not read.' 623 - RETURN 624 - ENDIF 625 - ELSE 626 - IF(NREAD.LE.0)THEN 627 - PRINT *,' !!!!!! MAPFM3 WARNING : ',FMAP(1:NCMAP), 628 - - ' contain no tetrahedrons; not read.' 629 - RETURN 630 - ELSE 631 - NMAP=NREAD 632 - ENDIF 633 - ENDIF 634 - *** Materials have been defined is NEWEPS is set. 635 - IF(NEWEPS)MAPFLG(9)=.TRUE. 636 - *** Flag those elements which have been defined. 637 - MAPFLG(1)=.TRUE. 638 - DO 70 I=1,3 639 - IF(ICONT(I).EQ.2.OR.ICONT(I).EQ.3.OR.ICONT(I).EQ.4)THEN 640 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 641 - MAPFLG(ICONT(I))=.TRUE. 642 - ELSEIF(IDATA.EQ.10)THEN 643 - MAPFLG(8+ICONT(I)+3*IWMAP-2)=.TRUE. 644 - ENDIF 645 - ELSEIF(ICONT(I).GT.0)THEN 646 - MAPFLG(ICONT(I))=.TRUE. 647 - ELSEIF(ICONT(I).EQ.-9)THEN 648 - MAPFLG(10)=.TRUE. 649 - ENDIF 650 - 70 CONTINUE 651 - *** Seems to have worked, set error flag to OK and return. 652 - IFAIL=0 653 - MAPTYP=12 654 - RETURN 655 - *** Handle error conditions. 656 - 2010 CONTINUE 657 - PRINT *,' !!!!!! MAPFM3 WARNING : Error reading field map'// 658 - - ' file ',FMAP(1:NCMAP),'; map not available.' 659 - RETURN 660 - END 483 GARFIELD ================================================== P=CELL D=MAPFM5 1 ============================ 0 + +DECK,MAPFM5. 1 - SUBROUTINE MAPFM5(FMAP,NCMAP,IDATA,IWMAP, 2 - - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,DELBKG,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * MAPFM5 - Reads a Maxwell 3D Field Simulator version 4.0 table of 5 - * tetrahedrons. 6 - * (Last changed on 29/11/99.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,FIELDMAP. 12.- +SEQ,CONSTANTS. 13 - INTEGER IEPS,ICONT(3),IMAX,NUSE,IWMAP, 14 - - I,J,K,NCMAP,IFAIL,IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5, 15 - - IT1,IT2,IT3,IT4,ITETRA,IOS,NC,INPCMP, 16 - - IDATA,NWORD,NCAUX,IEND,IP,NTETRA,NTOTAL,NPOINT, 17 - - MTETRA,MPOINT,LOOKUP(10),NDELET 18 - REAL TEMP(10),SUM,ECOMP,DCOMP,DX,DY,DZ, 19 - - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,XP,YP,ZP 20 - CHARACTER*(*) FMAP 21 - CHARACTER*(MXNAME) FAUX 22 - CHARACTER*80 STRING 23 - LOGICAL SCALAR,READ,NEWEPS,WINDOW,EXIST,EXIST2,DELBKG, 24 - - DELFLG(MXMAP),FIRST 25 - EXTERNAL INPCMP 0 26-+ +SELF,IF=SAVE. 27 - SAVE NTETRA,NPOINT,LOOKUP 0 28-+ +SELF. 29 - DATA NTETRA/0/, NPOINT/0/ 30 - DATA LOOKUP/1, 5, 6, 7, 2, 8, 9, 3, 10, 4/ 31 - **** Identify the routine if requested. 32 - IF(LIDENT)PRINT *,' /// ROUTINE MAPFM5 ///' 33 - *** Assume that this will fail. 34 - IFAIL=1 35 - *** Make sure the file names are not too long. 36 - IF(NCMAP.GT.MXNAME)THEN 37 - PRINT *,' !!!!!! MAPFM5 WARNING : Field map file name ', 38 - - FMAP(1:NCMAP),' is too long; not read.' 39 - CALL INPSWI('RESTORE') 40 - RETURN 41 - ENDIF 42 - *** Check for mesh files - or guess mesh name if there is no mesh yet. 43 - IF(IDATA.EQ.1)THEN 44 - * Get rid of extensions, if any. 45 - IEND=0 46 - DO 1050 I=NCMAP,1,-1 47 - IF(FMAP(I:I).NE.' '.AND.IEND.EQ.0)IEND=I 48 - IF(FMAP(I:I).EQ.'/')THEN 49 - IF(IEND.GT.0)THEN 50 - FAUX=FMAP(1:IEND)//'.' 1 483 P=CELL D=MAPFM5 2 PAGE 664 51 - NCAUX=IEND+1 52 - ELSE 53 - FAUX=FMAP 54 - NCAUX=NCMAP 55 - ENDIF 56 - GOTO 1060 57 - ELSEIF(FMAP(I:I).EQ.'.')THEN 58 - FAUX=FMAP(1:I) 59 - NCAUX=I 60 - GOTO 1060 61 - ENDIF 62 - 1050 CONTINUE 63 - IF(IEND.EQ.0)THEN 64 - PRINT *,' !!!!!! MAPFM5 WARNING : Mesh file name'// 65 - - ' empty ; not read.' 66 - CALL INPSWI('RESTORE') 67 - RETURN 68 - ENDIF 69 - FAUX=FMAP(1:IEND)//'.' 70 - NCAUX=IEND+1 71 - 1060 CONTINUE 72 - * Verify that the resulting file name is not too long. 73 - IF(NCAUX+3.GT.MXNAME)THEN 74 - PRINT *,' !!!!!! MAPFM5 WARNING : Mesh file name'// 75 - - ' too long after expansion ; not read.' 76 - CALL INPSWI('RESTORE') 77 - RETURN 78 - ENDIF 79 - * Check for the existence of the files. 80 - CALL DSNINQ(FAUX(1:NCAUX)//'hyd',NCAUX+3,EXIST) 81 - IF(.NOT.EXIST)THEN 82 - PRINT *,' !!!!!! MAPFM5 WARNING : Hydra file '// 83 - - FAUX(1:NCAUX)//'hyd not found; map not read.' 84 - CALL INPSWI('RESTORE') 85 - RETURN 86 - ENDIF 87 - CALL DSNINQ(FAUX(1:NCAUX)//'pnt',NCAUX+3,EXIST) 88 - IF(.NOT.EXIST)THEN 89 - PRINT *,' !!!!!! MAPFM5 WARNING : Point file '// 90 - - FAUX(1:NCAUX)//'pnt not found; map not read.' 91 - CALL INPSWI('RESTORE') 92 - RETURN 93 - ENDIF 94 - IF(DELBKG)THEN 95 - CALL DSNINQ(FAUX(1:NCAUX)//'shd',NCAUX+3,EXIST) 96 - IF(.NOT.EXIST)THEN 97 - PRINT *,' !!!!!! MAPFM5 WARNING : Solid file '// 98 - - FAUX(1:NCAUX)//'shd not found; map not read.' 99 - CALL INPSWI('RESTORE') 100 - RETURN 101 - ENDIF 102 - ENDIF 103 - ** If we didn't get a mesh file, try to guess the name. 104 - ELSEIF(.NOT.MAPFLG(1))THEN 105 - * Locate the directory name. 106 - IEND=0 107 - DO 1070 I=NCMAP,1,-1 108 - IF(FMAP(I:I).NE.' '.AND.IEND.EQ.0)IEND=I 109 - IF(FMAP(I:I).EQ.'/')THEN 110 - FAUX=FMAP(1:I) 111 - NCAUX=I 112 - GOTO 1080 113 - ENDIF 114 - 1070 CONTINUE 115 - IF(IEND.EQ.0)THEN 116 - PRINT *,' !!!!!! MAPFM5 WARNING : Field file name'// 117 - - ' empty ; not read.' 118 - CALL INPSWI('RESTORE') 119 - RETURN 120 - ENDIF 121 - FAUX='./' 122 - NCAUX=2 123 - 1080 CONTINUE 124 - * Test for various files. 125 - CALL DSNINQ(FAUX(1:NCAUX)//'fileset2.hyd',NCAUX+12,EXIST) 126 - IF(EXIST)THEN 127 - CALL DSNINQ(FAUX(1:NCAUX)//'fileset2.pnt',NCAUX+12, 128 - - EXIST) 129 - IF(DELBKG)THEN 130 - CALL DSNINQ(FAUX(1:NCAUX)//'fileset2.shd', 131 - - NCAUX+12,EXIST2) 132 - ELSE 133 - EXIST2=.TRUE. 134 - ENDIF 135 - IF(EXIST.AND.EXIST2)THEN 136 - FAUX=FAUX(:NCAUX)//'fileset2.' 137 - NCAUX=NCAUX+9 138 - PRINT *,' ------ MAPFM5 MESSAGE : Taking the'// 139 - - ' "fileset2" mesh.' 140 - GOTO 1090 141 - ENDIF 142 - ENDIF 143 - CALL DSNINQ(FAUX(1:NCAUX)//'fileset1.hyd',NCAUX+12,EXIST) 144 - IF(EXIST)THEN 145 - CALL DSNINQ(FAUX(1:NCAUX)//'fileset1.pnt',NCAUX+12, 146 - - EXIST) 147 - IF(DELBKG)THEN 148 - CALL DSNINQ(FAUX(1:NCAUX)//'fileset1.shd', 149 - - NCAUX+12,EXIST2) 150 - ELSE 151 - EXIST2=.TRUE. 152 - ENDIF 153 - IF(EXIST.AND.EXIST2)THEN 154 - FAUX=FAUX(:NCAUX)//'fileset1.' 155 - NCAUX=NCAUX+9 156 - PRINT *,' ------ MAPFM5 MESSAGE : Taking the'// 1 483 P=CELL D=MAPFM5 3 PAGE 665 157 - - ' "fileset1" mesh.' 158 - GOTO 1090 159 - ENDIF 160 - ENDIF 161 - CALL DSNINQ(FAUX(1:NCAUX)//'current.hyd',NCAUX+11,EXIST) 162 - IF(EXIST)THEN 163 - CALL DSNINQ(FAUX(1:NCAUX)//'current.pnt',NCAUX+11, 164 - - EXIST) 165 - IF(DELBKG)THEN 166 - CALL DSNINQ(FAUX(1:NCAUX)//'current.shd', 167 - - NCAUX+11,EXIST2) 168 - ELSE 169 - EXIST2=.TRUE. 170 - ENDIF 171 - IF(EXIST.AND.EXIST2)THEN 172 - FAUX=FAUX(:NCAUX)//'current.' 173 - NCAUX=NCAUX+8 174 - PRINT *,' ------ MAPFM5 MESSAGE : Taking the'// 175 - - ' "current" mesh.' 176 - GOTO 1090 177 - ENDIF 178 - ENDIF 179 - CALL DSNINQ(FAUX(1:NCAUX)//'efs3d.hyd',NCAUX+9,EXIST) 180 - IF(EXIST)THEN 181 - CALL DSNINQ(FAUX(1:NCAUX)//'efs3d.pnt',NCAUX+9, 182 - - EXIST) 183 - IF(DELBKG)THEN 184 - CALL DSNINQ(FAUX(1:NCAUX)//'efs3d.shd', 185 - - NCAUX+9,EXIST2) 186 - ELSE 187 - EXIST2=.TRUE. 188 - ENDIF 189 - IF(EXIST.AND.EXIST2)THEN 190 - FAUX=FAUX(:NCAUX)//'efs3d.' 191 - NCAUX=NCAUX+6 192 - PRINT *,' ------ MAPFM5 MESSAGE : Taking the'// 193 - - ' "efs3d" mesh.' 194 - GOTO 1090 195 - ENDIF 196 - ENDIF 197 - CALL DSNINQ(FAUX(1:NCAUX)//'previous.hyd',NCAUX+12,EXIST) 198 - IF(EXIST)THEN 199 - CALL DSNINQ(FAUX(1:NCAUX)//'previous.pnt',NCAUX+12, 200 - - EXIST) 201 - IF(DELBKG)THEN 202 - CALL DSNINQ(FAUX(1:NCAUX)//'previous.shd', 203 - - NCAUX+12,EXIST2) 204 - ELSE 205 - EXIST2=.TRUE. 206 - ENDIF 207 - IF(EXIST.AND.EXIST2)THEN 208 - FAUX=FAUX(:NCAUX)//'previous.' 209 - NCAUX=NCAUX+9 210 - PRINT *,' ------ MAPFM5 MESSAGE : Taking the'// 211 - - ' "previous" mesh.' 212 - GOTO 1090 213 - ENDIF 214 - ENDIF 215 - CALL DSNINQ(FAUX(1:NCAUX)//'initial.hyd',NCAUX+11,EXIST) 216 - IF(EXIST)THEN 217 - CALL DSNINQ(FAUX(1:NCAUX)//'initial.pnt',NCAUX+11, 218 - - EXIST) 219 - IF(DELBKG)THEN 220 - CALL DSNINQ(FAUX(1:NCAUX)//'initial.shd', 221 - - NCAUX+11,EXIST2) 222 - ELSE 223 - EXIST2=.TRUE. 224 - ENDIF 225 - IF(EXIST.AND.EXIST2)THEN 226 - FAUX=FAUX(:NCAUX)//'initial.' 227 - NCAUX=NCAUX+8 228 - PRINT *,' ------ MAPFM5 MESSAGE : Taking the'// 229 - - ' "initial" mesh.' 230 - GOTO 1090 231 - ENDIF 232 - ENDIF 233 - PRINT *,' !!!!!! MAPFM5 WARNING : Hydra, point and'// 234 - - ' solid files not found; specify mesh explicitely.' 235 - CALL INPSWI('RESTORE') 236 - RETURN 237 - * Verify that the resulting file name is not too long. 238 - 1090 CONTINUE 239 - IF(NCAUX+3.GT.MXNAME)THEN 240 - PRINT *,' !!!!!! MAPFM5 WARNING : Mesh file name'// 241 - - ' too long after expansion ; not read.' 242 - CALL INPSWI('RESTORE') 243 - RETURN 244 - ENDIF 245 - ENDIF 246 - *** Skip the mesh decoding if this has already been done. 247 - IF(IDATA.NE.1.AND.MAPFLG(1))GOTO 1000 248 - * Close the current file, re-open later. 249 - CALL INPSWI('RESTORE') 250 - CLOSE(12,ERR=2030,IOSTAT=IOS) 251 - *** If background suppression has been requested, read .shd file. 252 - DO 1150 I=1,MXMAP 253 - DELFLG(I)=.FALSE. 254 - 1150 CONTINUE 255 - IF(DELBKG)THEN 256 - * Construct the hydra file name. 257 - FAUX=FAUX(1:NCAUX)//'shd' 258 - NCAUX=NCAUX+3 259 - * Open the hydra file. 260 - CALL DSNOPN(FAUX,NCAUX,12,'READ-FILE',IFAIL1) 261 - IF(IFAIL1.NE.0)THEN 262 - PRINT *,' !!!!!! MAPFM5 WARNING : Unable to open the'// 1 483 P=CELL D=MAPFM5 4 PAGE 666 263 - - ' solid file '//FAUX(1:NCAUX)//'; map not read.' 264 - RETURN 265 - ENDIF 266 - * Record the opening. 267 - CALL DSNLOG(FAUX(1:NCAUX),'Solids ','Sequential', 268 - - 'Read only ') 269 - * Switch to reading the file. 270 - CALL INPSWI('UNIT12') 271 - ** Read the header records, switch to the data file. 272 - CALL INPGET 273 - CALL INPNUM(NWORD) 274 - * Check for empty files. 275 - IF(NWORD.EQ.0)THEN 276 - PRINT *,' !!!!!! MAPFM5 WARNING : The file '// 277 - - FAUX(1:NCAUX)//' seems to be empty; map not read.' 278 - CALL INPSWI('RESTORE') 279 - CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 280 - RETURN 281 - ENDIF 282 - * Read the number of tetrahedrons. 283 - CALL INPNUM(NWORD) 284 - CALL INPCHK(2,1,IFAIL1) 285 - CALL INPRDI(2,NTOTAL,0) 286 - IF(IFAIL1.NE.0.OR.NTOTAL.LE.0.OR.NWORD.NE.2)THEN 287 - PRINT *,' !!!!!! MAPFM5 WARNING : The file '// 288 - - FAUX(1:NCAUX)//' has an unreadable number'// 289 - - ' of tetrahedrons; not read.' 290 - CALL INPSWI('RESTORE') 291 - RETURN 292 - ELSEIF(NTOTAL.GT.MXMAP)THEN 293 - PRINT *,' !!!!!! MAPFM5 WARNING : Number of'// 294 - - ' tetrahedrons in '//FAUX(1:NCAUX)// 295 - - ' exceeds compilation limit; file not read.' 296 - CALL INPSWI('RESTORE') 297 - RETURN 298 - ENDIF 299 - * Debugging output. 300 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG :'', 301 - - '' Number of .shd tetrahedrons (incl bkg): '',I5)') 302 - - NTOTAL 303 - ** Loop over the tetrahedrons, with progress printing. 304 - CALL PROFLD(2,'Volumes',REAL(NTOTAL)) 305 - NDELET=0 306 - DO 1160 I=1,NTOTAL 307 - IF(I.EQ.MAX(1,NTOTAL/100)*(I/MAX(1,NTOTAL/100))) 308 - - CALL PROSTA(2,REAL(I)) 309 - * Read the data line. 310 - CALL INPGET 311 - CALL INPNUM(NWORD) 312 - IF(NWORD.EQ.3)THEN 313 - DELFLG(I)=.TRUE. 314 - NDELET=NDELET+1 315 - ENDIF 316 - 1160 CONTINUE 317 - * Switch back to regular input. 318 - CALL INPSWI('RESTORE') 319 - * Close the solids file. 320 - CLOSE(12,ERR=2030,IOSTAT=IOS) 321 - * Reestablish the root name length. 322 - NCAUX=NCAUX-3 323 - ENDIF 324 - * Construct the hydra file name. 325 - FAUX=FAUX(1:NCAUX)//'hyd' 326 - NCAUX=NCAUX+3 327 - * Open the hydra file. 328 - CALL DSNOPN(FAUX,NCAUX,12,'READ-FILE',IFAIL1) 329 - IF(IFAIL1.NE.0)THEN 330 - PRINT *,' !!!!!! MAPFM5 WARNING : Unable to open the'// 331 - - ' hydra file '//FAUX(1:NCAUX)//'; map not read.' 332 - RETURN 333 - ENDIF 334 - * Record the opening. 335 - CALL DSNLOG(FAUX(1:NCAUX),'Hydra ','Sequential', 336 - - 'Read only ') 337 - * Switch to reading the file. 338 - CALL INPSWI('UNIT12') 339 - ** Read the header records, switch to the data file. 340 - CALL INPGET 341 - CALL INPNUM(NWORD) 342 - * Check for empty files. 343 - IF(NWORD.EQ.0)THEN 344 - PRINT *,' !!!!!! MAPFM5 WARNING : The file '// 345 - - FAUX(1:NCAUX)//' seems to be empty; map not read.' 346 - CALL INPSWI('RESTORE') 347 - CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 348 - RETURN 349 - ENDIF 350 - * Read the number of tetrahedrons. 351 - CALL INPNUM(NWORD) 352 - CALL INPCHK(2,1,IFAIL1) 353 - CALL INPRDI(2,NTOTAL,0) 354 - IF(IFAIL1.NE.0.OR.NTOTAL.LE.0.OR.NWORD.NE.2)THEN 355 - PRINT *,' !!!!!! MAPFM5 WARNING : The file '// 356 - - FAUX(1:NCAUX)//' has an unreadable number'// 357 - - ' of tetrahedrons; not read.' 358 - CALL INPSWI('RESTORE') 359 - RETURN 360 - ELSEIF(NTOTAL.GT.MXMAP)THEN 361 - PRINT *,' !!!!!! MAPFM5 WARNING : Number of'// 362 - - ' tetrahedrons in '//FAUX(1:NCAUX)// 363 - - ' exceeds compilation limit; file not read.' 364 - CALL INPSWI('RESTORE') 365 - RETURN 366 - ENDIF 367 - * Debugging output. 368 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG : Number'', 1 483 P=CELL D=MAPFM5 5 PAGE 667 369 - - '' of .hyd tetrahedrons (incl bkg): '',I5)') NTOTAL 370 - ** Loop over the tetrahedrons, with progress printing. 371 - CALL PROFLD(2,'Hydra',REAL(NTOTAL)) 372 - NTETRA=0 373 - DO 1030 I=1,NTOTAL 374 - IF(I.EQ.MAX(1,NTOTAL/100)*(I/MAX(1,NTOTAL/100))) 375 - - CALL PROSTA(2,REAL(I)) 376 - * Skip tetrahedron or increment counter. 377 - IF(DELBKG.AND.DELFLG(I))THEN 378 - READ(12,'(/////)',ERR=2015,END=2005,IOSTAT=IOS) 379 - GOTO 1030 380 - ELSE 381 - NTETRA=NTETRA+1 382 - ENDIF 383 - * Skip the blank header. 384 - CALL INPGET 385 - * Read the data line. 386 - CALL INPGET 387 - CALL INPNUM(NWORD) 388 - IF(NWORD.NE.6)THEN 389 - PRINT *,' !!!!!! MAPFM5 WARNING : The format of '// 390 - - FAUX(1:NCAUX)//' is not known; map not read.' 391 - CALL INPSWI('RESTORE') 392 - RETURN 393 - ENDIF 394 - * Find the pointers to the .pnt file. 395 - CALL INPCHK(2,1,IFAIL1) 396 - CALL INPCHK(3,1,IFAIL2) 397 - CALL INPCHK(4,1,IFAIL3) 398 - CALL INPCHK(5,1,IFAIL4) 399 - CALL INPCHK(6,1,IFAIL5) 400 - CALL INPRDI(2,ITETRA,0) 401 - CALL INPRDI(3,IT1,0) 402 - CALL INPRDI(4,IT2,0) 403 - CALL INPRDI(5,IT3,0) 404 - CALL INPRDI(6,IT4,0) 405 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR. 406 - - IFAIL3.NE.0.OR.IFAIL4.NE.0.OR.IFAIL5.NE.0.OR. 407 - - IT1.LE.0.OR.IT2.LE.0.OR.IT3.LE.0.OR.IT4.LE.0.OR. 408 - - ITETRA.LE.0.OR.ITETRA.GT.NTOTAL)THEN 409 - PRINT *,' !!!!!! MAPFM5 WARNING : Reference to points'// 410 - - ' unreadable in '//FAUX(1:NCAUX)//'; map not read.' 411 - CALL INPSWI('RESTORE') 412 - RETURN 413 - ENDIF 414 - * Store the reference pointers temporarily in Ex. 415 - EXMAP(NTETRA,1)=IT1 416 - EXMAP(NTETRA,2)=IT2 417 - EXMAP(NTETRA,3)=IT3 418 - EXMAP(NTETRA,4)=IT4 419 - * Skip the 4 lines of additional information. 420 - READ(12,'(///)',ERR=2015,END=2005,IOSTAT=IOS) 421 - 1030 CONTINUE 422 - * Make sure we're at the end. 423 - READ(12,'(A9)',ERR=2015,END=2005,IOSTAT=IOS) STRING(1:9) 424 - IF(STRING(1:9).NE.'end_hydra')PRINT *,' !!!!!! MAPFM5 WARNING'// 425 - - ' : Didn''t find the hydra EOF marker ; map probably'// 426 - - ' incomplete.' 427 - * Switch back to regular input. 428 - CALL INPSWI('RESTORE') 429 - * Close the hydra file. 430 - CLOSE(12,ERR=2030,IOSTAT=IOS) 431 - ** Construct the name of the .pnt file. 432 - FAUX(NCAUX-2:NCAUX)='pnt' 433 - * Open the points file. 434 - CALL DSNOPN(FAUX,NCAUX,12,'READ-FILE',IFAIL1) 435 - IF(IFAIL1.NE.0)THEN 436 - PRINT *,' !!!!!! MAPFM5 WARNING : Unable to open the'// 437 - - ' points file '//FAUX(1:NCAUX)//'; map not read.' 438 - RETURN 439 - ENDIF 440 - * Record the opening. 441 - CALL DSNLOG(FAUX(1:NCAUX),'Points ','Sequential', 442 - - 'Read only ') 443 - ** Read the header records, switch to the data file. 444 - CALL INPSWI('UNIT12') 445 - * Read the number of points. 446 - CALL INPGET 447 - CALL INPNUM(NWORD) 448 - CALL INPCHK(2,1,IFAIL1) 449 - CALL INPRDI(2,NPOINT,0) 450 - IF(IFAIL1.NE.0.OR.NPOINT.LE.0.OR.NWORD.NE.2)THEN 451 - PRINT *,' !!!!!! MAPFM5 WARNING : The file '// 452 - - FAUX(1:NCAUX)//' has an unreadable number'// 453 - - ' of points; not read.' 454 - CALL INPSWI('RESTORE') 455 - RETURN 456 - ENDIF 457 - * Debugging output. 458 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG : Number'', 459 - - '' of points: '',I5)') NPOINT 460 - ** Loop over the tetrahedrons, with progress printing. 461 - CALL PROFLD(2,'Points',REAL(NPOINT)) 462 - FIRST=.TRUE. 463 - DO 1040 I=1,NPOINT 464 - IF(I.EQ.MAX(1,NPOINT/100)*(I/MAX(1,NPOINT/100))) 465 - - CALL PROSTA(2,REAL(I)) 466 - * Read the data line. 467 - CALL INPGET 468 - CALL INPNUM(NWORD) 469 - IF(NWORD.NE.5)THEN 470 - PRINT *,' !!!!!! MAPFM5 WARNING : The format of '// 471 - - FAUX(1:NCAUX)//' is not known; map not read.' 472 - CALL INPSWI('RESTORE') 473 - RETURN 474 - ENDIF 1 483 P=CELL D=MAPFM5 6 PAGE 668 475 - * Read the point coordinates and the reference to the .hyd file. 476 - CALL INPCHK(2,1,IFAIL2) 477 - CALL INPCHK(3,2,IFAIL3) 478 - CALL INPCHK(4,2,IFAIL4) 479 - CALL INPCHK(5,2,IFAIL5) 480 - CALL INPRDI(2,IP,0) 481 - CALL INPRDR(3,XP,0.0) 482 - CALL INPRDR(4,YP,0.0) 483 - CALL INPRDR(5,ZP,0.0) 484 - IF(IFAIL2.NE.0.OR.IFAIL3.NE.0.OR.IFAIL4.NE.0.OR.IFAIL5.NE.0.OR. 485 - - IP.LE.0)THEN 486 - PRINT *,' !!!!!! MAPFM5 WARNING : Reference to hydra'// 487 - - ' unreadable in '//FAUX(1:NCAUX)//'; map not read.' 488 - CALL INPSWI('RESTORE') 489 - RETURN 490 - ENDIF 491 - * Convert from m to cm. 492 - XP=XP*100 493 - YP=YP*100 494 - ZP=ZP*100 495 - * Store the tetrahedron parameters that refer to this point. 496 - NUSE=0 497 - DO 1100 K=1,NTETRA 498 - DO 1110 J=1,4 499 - IF(NINT(EXMAP(K,J)).EQ.IP)THEN 500 - NUSE=NUSE+1 501 - XMAP(K,J)=XP 502 - YMAP(K,J)=YP 503 - ZMAP(K,J)=ZP 504 - EXMAP(K,J)=-1 505 - ENDIF 506 - 1110 CONTINUE 507 - 1100 CONTINUE 508 - * If this point was not used, skip the rest. 509 - IF(NUSE.LE.0)GOTO 1040 510 - * Update the chamber dimensions. 511 - IF(FIRST)THEN 512 - FIRST=.FALSE. 513 - XMMIN=XP 514 - XMMAX=XP 515 - YMMIN=YP 516 - YMMAX=YP 517 - ZMMIN=ZP 518 - ZMMAX=ZP 519 - ELSE 520 - XMMIN=MIN(XMMIN,XP) 521 - XMMAX=MAX(XMMAX,XP) 522 - YMMIN=MIN(YMMIN,YP) 523 - YMMAX=MAX(YMMAX,YP) 524 - ZMMIN=MIN(ZMMIN,ZP) 525 - ZMMAX=MAX(ZMMAX,ZP) 526 - ENDIF 527 - * Update angular ranges. 528 - IF(YP.NE.0.OR.ZP.NE.0)THEN 529 - IF(SETAX)THEN 530 - XAMIN=MIN(XAMIN,ATAN2(ZP,YP)) 531 - XAMAX=MAX(XAMAX,ATAN2(ZP,YP)) 532 - ELSE 533 - XAMIN=ATAN2(ZP,YP) 534 - XAMAX=ATAN2(ZP,YP) 535 - SETAX=.TRUE. 536 - ENDIF 537 - ENDIF 538 - IF(ZP.NE.0.OR.XP.NE.0)THEN 539 - IF(SETAY)THEN 540 - YAMIN=MIN(YAMIN,ATAN2(XP,ZP)) 541 - YAMAX=MAX(YAMAX,ATAN2(XP,ZP)) 542 - ELSE 543 - YAMIN=ATAN2(XP,ZP) 544 - YAMAX=ATAN2(XP,ZP) 545 - SETAY=.TRUE. 546 - ENDIF 547 - ENDIF 548 - IF(XP.NE.0.OR.YP.NE.0)THEN 549 - IF(SETAZ)THEN 550 - ZAMIN=MIN(ZAMIN,ATAN2(YP,XP)) 551 - ZAMAX=MAX(ZAMAX,ATAN2(YP,XP)) 552 - ELSE 553 - ZAMIN=ATAN2(YP,XP) 554 - ZAMAX=ATAN2(YP,XP) 555 - SETAZ=.TRUE. 556 - ENDIF 557 - ENDIF 558 - * Next point. 559 - 1040 CONTINUE 560 - * Make sure we're at the end. 561 - READ(12,'(A11)',ERR=2015,END=2005,IOSTAT=IOS) STRING(1:11) 562 - IF(STRING(1:11).NE.'end_points')PRINT *,' !!!!!! MAPFM5'// 563 - - ' WARNING : Didn''t find the points EOF marker ; map'// 564 - - ' probably incomplete.' 565 - ** Switch back to regular input. 566 - CALL INPSWI('RESTORE') 567 - * End of reading, make sure that all hydra references are solved. 568 - DO 1120 I=1,NTETRA 569 - DO 1130 J=1,4 570 - IF(EXMAP(I,J).GE.0)THEN 571 - PRINT *,' !!!!!! MAPFM5 WARNING : Unresolved references'// 572 - - ' in hydra ; map rejected.' 573 - RETURN 574 - ENDIF 575 - 1130 CONTINUE 576 - 1120 CONTINUE 577 - * Store the number of tetrahedrons. 578 - NMAP=NTETRA 579 - ** Set the flag that the mesh is now defined. 580 - MAPFLG(1)=.TRUE. 1 483 P=CELL D=MAPFM5 7 PAGE 669 581 - ** Print number of deletec tetrahedrons. 582 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG :'', 583 - - '' Tetrahedrons: '',I5,'' Background: '',I5)') 584 - - NTETRA,NDELET 585 - IF(NDELET.NE.0)PRINT *,' ------ MAPFM5 MESSAGE : Found ',NDELET, 586 - - ' background tetrahedrons.' 587 - ** In case this was an explicit mesh, return with success status. 588 - IF(IDATA.EQ.1)THEN 589 - IFAIL=0 590 - RETURN 591 - * Otherwise, close the points file and re-open mesh file. 592 - ELSE 593 - CLOSE(12,ERR=2030,IOSTAT=IOS) 594 - CALL DSNOPN(FMAP,NCMAP,12,'READ-FILE',IFAIL1) 595 - IF(IFAIL1.NE.0)THEN 596 - PRINT *,' !!!!!! MAPFM5 WARNING : Re-opening the'// 597 - - ' field map failed ; map not read.' 598 - RETURN 599 - ENDIF 600 - * Record the opening. 601 - CALL DSNLOG(FMAP(1:NCMAP),'Field map ','Sequential', 602 - - 'Re-read ') 603 - * Read the header records, switch to the data file. 604 - CALL INPSWI('UNIT12') 605 - CALL INPGET 606 - CALL INPNUM(NWORD) 607 - * Check for empty files. 608 - IF(NWORD.EQ.0)THEN 609 - PRINT *,' !!!!!! MAPFM5 WARNING : The file ', 610 - - FMAP(1:NCMAP),' seems to be empty; not read.' 611 - CALL INPSWI('RESTORE') 612 - CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) 613 - RETURN 614 - ENDIF 615 - ENDIF 616 - *** Read the field map. 617 - 1000 CONTINUE 618 - * See whether the data is scalar or vector. 619 - IF(INPCMP(1,'SCALAR').NE.0)THEN 620 - SCALAR=.TRUE. 621 - ELSEIF(INPCMP(1,'VECTOR').NE.0)THEN 622 - SCALAR=.FALSE. 623 - ELSEIF(INPCMP(1,'HYDRAS')+INPCMP(1,'POINTS').NE.0)THEN 624 - PRINT *,' !!!!!! MAPFM5 WARNING : The file ', 625 - - FMAP(1:NCMAP),' contains a mesh, the mesh is'// 626 - - ' already defined ; file not read.' 627 - CALL INPSWI('RESTORE') 628 - RETURN 629 - ELSE 630 - PRINT *,' !!!!!! MAPFM5 WARNING : The file ', 631 - - FMAP(1:NCMAP),' contains neither scalar nor'// 632 - - ' vectorial data; not read.' 633 - CALL INPSWI('RESTORE') 634 - RETURN 635 - ENDIF 636 - * Initial contents flags. 637 - READ=.FALSE. 638 - NEWEPS=.FALSE. 639 - *** Determine the contents of the file, first for scalar files. 640 - IF(SCALAR)THEN 641 - * They contain 1 data word per line. 642 - IMAX=1 643 - * Potentials. 644 - IF(INPCMP(3,'Phi')+INPCMP(3,'smh(Phi)').NE.0)THEN 645 - ICONT(1)=5 646 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG :'', 647 - - '' File contains a potential.'')') 648 - IF(MAPFLG(5))PRINT *,' ------ MAPFM5 MESSAGE :'// 649 - - ' Overwriting current potential map.' 650 - MAPFLG(5)=.FALSE. 651 - READ=.TRUE. 652 - * Dielectric constants. 653 - ELSEIF(INPCMP(3,'epsilon').NE.0)THEN 654 - ICONT(1)=9 655 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG :'', 656 - - '' File contains an epsilon map.'')') 657 - IF(MAPFLG(9))PRINT *,' ------ MAPFM5 MESSAGE :'// 658 - - ' Overwriting current material map.' 659 - MAPFLG(9)=.FALSE. 660 - NEWEPS=.TRUE. 661 - READ=.TRUE. 662 - MATSRC='EPSILON' 663 - * Conductivity. 664 - ELSEIF(INPCMP(3,'sigma').NE.0)THEN 665 - ICONT(1)=9 666 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG :'', 667 - - '' File contains a conductivity map.'')') 668 - IF(MAPFLG(9))PRINT *,' ------ MAPFM5 MESSAGE :'// 669 - - ' Overwriting current material map.' 670 - MAPFLG(9)=.FALSE. 671 - NEWEPS=.TRUE. 672 - READ=.TRUE. 673 - MATSRC='SIGMA' 674 - * All the rest is not known. 675 - ELSE 676 - CALL INPSTR(3,3,STRING,NC) 677 - PRINT *,' !!!!!! MAPFM5 WARNING : The file ', 678 - - FMAP(1:NCMAP),' contains the unknown "'// 679 - - STRING(1:NC)//'" field; ignored.' 680 - ICONT(1)=0 681 - READ=.TRUE. 682 - ENDIF 683 - ICONT(2)=0 684 - ICONT(3)=0 685 - ** Next for vector files. 686 - ELSE 1 483 P=CELL D=MAPFM5 8 PAGE 670 687 - * Which have 3 words per line. 688 - IMAX=3 689 - * E field, either main field or weighting field. 690 - IF(INPCMP(3,'')+ 691 - - INPCMP(3,'').NE.0)THEN 692 - ICONT(1)=2 693 - ICONT(2)=3 694 - ICONT(3)=4 695 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG :'', 696 - - '' File contains an E field.'')') 697 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 698 - IF(MAPFLG(2).OR.MAPFLG(3).OR.MAPFLG(4)) 699 - - PRINT *,' ------ MAPFM5 MESSAGE :'// 700 - - ' Overwriting current E field map.' 701 - MAPFLG(2)=.FALSE. 702 - MAPFLG(3)=.FALSE. 703 - MAPFLG(4)=.FALSE. 704 - ELSEIF(IDATA.EQ.10)THEN 705 - IF(MAPFLG(10+3*IWMAP-2).OR. 706 - - MAPFLG(11+3*IWMAP-2).OR. 707 - - MAPFLG(12+3*IWMAP-2)) 708 - - PRINT *,' ------ MAPFM5 MESSAGE :'// 709 - - ' Overwriting current weighting field map.' 710 - MAPFLG(10+3*IWMAP-2)=.FALSE. 711 - MAPFLG(11+3*IWMAP-2)=.FALSE. 712 - MAPFLG(12+3*IWMAP-2)=.FALSE. 713 - ENDIF 714 - READ=.TRUE. 715 - * B field. 716 - ELSEIF(INPCMP(3,'')+ 717 - - INPCMP(3,'').NE.0)THEN 718 - ICONT(1)=6 719 - ICONT(2)=7 720 - ICONT(3)=8 721 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG :'', 722 - - '' File contains a B field.'')') 723 - IF(MAPFLG(6).OR.MAPFLG(7).OR.MAPFLG(8)) 724 - - PRINT *,' ------ MAPFM5 MESSAGE :'// 725 - - ' Overwriting current E field map.' 726 - MAPFLG(6)=.FALSE. 727 - MAPFLG(7)=.FALSE. 728 - MAPFLG(8)=.FALSE. 729 - READ=.TRUE. 730 - * D field. 731 - ELSEIF(INPCMP(3,'')+ 732 - - INPCMP(3,'').NE.0)THEN 733 - ICONT(1)=-9 734 - ICONT(2)=-9 735 - ICONT(3)=-9 736 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG :'', 737 - - '' File contains a D field.'')') 738 - IF(MAPFLG(9))PRINT *,' ------ MAPFM5 MESSAGE :'// 739 - - ' Overwriting current material map.' 740 - MAPFLG(9)=.FALSE. 741 - READ=.TRUE. 742 - MATSRC='EPSILON' 743 - * All the rest is not known. 744 - ELSE 745 - CALL INPSTR(3,3,STRING,NC) 746 - PRINT *,' !!!!!! MAPFM5 WARNING : The file ', 747 - - FMAP(1:NCMAP),' contains the unknown "'// 748 - - STRING(1:NC)//' field; ignored.' 749 - ICONT(1)=0 750 - ICONT(2)=0 751 - ICONT(3)=0 752 - READ=.TRUE. 753 - ENDIF 754 - ENDIF 755 - ** Ensure that the data type matches the declared type. 756 - DO 40 I=1,IMAX 757 - IF(((ICONT(I).EQ.2.OR.ICONT(I).EQ.3.OR.ICONT(I).EQ.4).AND. 758 - - (IDATA.NE.0.AND.IDATA.NE.2.AND.IDATA.NE.10)).OR. 759 - - (ICONT(I).EQ.5.AND.(IDATA.NE.0.AND.IDATA.NE.5)).OR. 760 - - ((ICONT(I).EQ.6.OR.ICONT(I).EQ.7.OR.ICONT(I).EQ.8).AND. 761 - - (IDATA.NE.0.AND.IDATA.NE.6)).OR. 762 - - ((ICONT(I).EQ.9.OR.ICONT(I).EQ.-9).AND. 763 - - (IDATA.NE.0.AND.IDATA.NE.9)))THEN 764 - PRINT *,' !!!!!! MAPFM5 WARNING : Field ',I,' of file ', 765 - - FMAP(1:NCMAP),' does not contain the declared', 766 - - ' kind of data; skipped.' 767 - ICONT(I)=0 768 - ENDIF 769 - 40 CONTINUE 770 - *** Read the number of points and number of tetrahedrons. 771 - CALL INPGET 772 - CALL INPNUM(NWORD) 773 - * Verify the tetrahedron and points count. 774 - CALL INPCHK(2,1,IFAIL1) 775 - CALL INPCHK(4,1,IFAIL2) 776 - CALL INPRDI(2,MTETRA,0) 777 - CALL INPRDI(4,MPOINT,0) 778 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.NWORD.NE.4)THEN 779 - PRINT *,' !!!!!! MAPFM5 WARNING : The file ', 780 - - FMAP(1:NCMAP),' has an unreadable number'// 781 - - ' of tetrahedrons or points; not read.' 782 - CALL INPSWI('RESTORE') 783 - RETURN 784 - ENDIF 785 - * Debugging output. 786 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG : Number'', 787 - - '' of field tetrahedrons (incl bkg): '',I5)') NTOTAL 788 - * Progress printing. 789 - CALL PROFLD(2,'Tetrahedrons',REAL(NTOTAL)) 790 - *** Switch back to regular input. 791 - CALL INPSWI('RESTORE') 792 - * See whether any item is left. 1 483 P=CELL D=MAPFM5 9 PAGE 671 793 - IF(.NOT.READ)THEN 794 - PRINT *,' !!!!!! MAPFM5 WARNING : The file ', 795 - - FMAP(1:NCMAP),' contains no useable'// 796 - - ' information; file not read.' 797 - RETURN 798 - ENDIF 799 - *** Loop over the tetrahedrons. 800 - NTETRA=0 801 - DO 10 I=1,NTOTAL 802 - IF(I.EQ.MAX(1,NTOTAL/100)*(I/MAX(1,NTOTAL/100))) 803 - - CALL PROSTA(2,REAL(I)) 804 - *** Read the line with the word "Tet". 805 - 20 CONTINUE 806 - READ(12,'(A80)',END=2000,ERR=2010,IOSTAT=IOS) STRING 807 - IF(STRING(1:3).NE.'Tet')GOTO 20 808 - * Read the tetrahedron number. 809 - READ(STRING,'(3X,BN,I10)',ERR=2010,IOSTAT=IOS) ITETRA 810 - * Ensure this number is in range. 811 - IF(ITETRA.LE.0.OR.ITETRA.GT.NTOTAL)THEN 812 - PRINT *,' !!!!!! MAPFM5 WARNING : Tetrahedron number ', 813 - - ITETRA,' out of range in ',FMAP(1:NCMAP) 814 - READ(12,'(/////////)',ERR=2010,END=2000,IOSTAT=IOS) 815 - GOTO 10 816 - * Skip tetrahedron or increment counter. 817 - ELSEIF(DELBKG.AND.DELFLG(ITETRA))THEN 818 - READ(12,'(/////////)',ERR=2010,END=2000,IOSTAT=IOS) 819 - GOTO 10 820 - ELSE 821 - NTETRA=NTETRA+1 822 - ENDIF 823 - *** Read scalar field values over the tetrahedron. 824 - IF(SCALAR)THEN 825 - ** Can be either a potential, first read. 826 - IF(ICONT(1).EQ.5)THEN 827 - READ(12,*,END=2000,ERR=2010,IOSTAT=IOS) 828 - - (VMAP(NTETRA,LOOKUP(K)),K=1,10) 829 - * Then keep track of potential range. 830 - IF(I.EQ.1)THEN 831 - VMMIN=VMAP(NTETRA,1) 832 - VMMAX=VMAP(NTETRA,1) 833 - ENDIF 834 - VMMIN=MIN(VMMIN, 835 - - VMAP(NTETRA,1),VMAP(NTETRA,2),VMAP(NTETRA,3), 836 - - VMAP(NTETRA,4),VMAP(NTETRA,5),VMAP(NTETRA,6), 837 - - VMAP(NTETRA,7),VMAP(NTETRA,8),VMAP(NTETRA,9), 838 - - VMAP(NTETRA,10)) 839 - VMMAX=MAX(VMMAX, 840 - - VMAP(NTETRA,1),VMAP(NTETRA,2),VMAP(NTETRA,3), 841 - - VMAP(NTETRA,4),VMAP(NTETRA,5),VMAP(NTETRA,6), 842 - - VMAP(NTETRA,7),VMAP(NTETRA,8),VMAP(NTETRA,9), 843 - - VMAP(NTETRA,10)) 844 - ** Or a dielectricum, first read. 845 - ELSEIF(ICONT(1).EQ.9)THEN 846 - READ(12,*,END=2000,ERR=2010,IOSTAT=IOS) 847 - - (TEMP(K),K=1,10) 848 - * Average the epsilons/conductivity. 849 - SUM=0 850 - DO 30 J=1,10 851 - SUM=SUM+TEMP(J) 852 - 30 CONTINUE 853 - SUM=SUM/(1000*EPS0) 854 - * Identify the material. 855 - IEPS=-1 856 - DO 80 J=1,NEPS 857 - IF(ABS(SUM-EPSMAT(J)).LT.1E-4*(ABS(SUM)+ 858 - - ABS(EPSMAT(J))))IEPS=J 859 - 80 CONTINUE 860 - IF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN 861 - PRINT *,' !!!!!! MAPFM5 WARNING : Unable'// 862 - - ' to store a dielectricum from file ', 863 - - FMAP(1:NCMAP),'; file not read.' 864 - RETURN 865 - ELSEIF(IEPS.LT.0)THEN 866 - NEPS=NEPS+1 867 - IEPS=NEPS 868 - EPSMAT(IEPS)=SUM 869 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5'', 870 - - '' DEBUG : Adding dielectricum with'', 871 - - '' eps='',E10.3,''.'')') EPSMAT(IEPS) 872 - ENDIF 873 - MATMAP(NTETRA)=IEPS 874 - ENDIF 875 - *** Read vectorial field values over the tetrahedron. 876 - ELSE 877 - * Take care of knowing |D| either from Ex or by summing. 878 - IF(MAPFLG(10))DCOMP=EXMAP(NTETRA,1) 879 - * E or EW. 880 - IF(ICONT(1).EQ.2.AND.ICONT(2).EQ.3.AND.ICONT(3).EQ.4)THEN 881 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 882 - READ(12,*,END=2000,ERR=2010,IOSTAT=IOS) 883 - - (EXMAP(NTETRA,LOOKUP(K)), 884 - - EYMAP(NTETRA,LOOKUP(K)), 885 - - EZMAP(NTETRA,LOOKUP(K)),K=1,10) 886 - ELSEIF(IDATA.EQ.10)THEN 887 - READ(12,*,END=2000,ERR=2010,IOSTAT=IOS) 888 - - (EWXMAP(NTETRA,LOOKUP(K),IWMAP), 889 - - EWYMAP(NTETRA,LOOKUP(K),IWMAP), 890 - - EWZMAP(NTETRA,LOOKUP(K),IWMAP),K=1,10) 891 - ENDIF 892 - * B. 893 - ELSEIF(ICONT(1).EQ.6.AND.ICONT(2).EQ.7.AND. 894 - - ICONT(3).EQ.8)THEN 895 - READ(12,*,END=2000,ERR=2010,IOSTAT=IOS) 896 - - (BXMAP(NTETRA,LOOKUP(K)), 897 - - BYMAP(NTETRA,LOOKUP(K)), 898 - - BZMAP(NTETRA,LOOKUP(K)),K=1,10) 1 483 P=CELL D=MAPFM5 10 PAGE 672 899 - * D field. 900 - ELSEIF(ICONT(1).EQ.-9.AND.ICONT(2).EQ.-9.AND. 901 - - ICONT(3).EQ.-9)THEN 902 - DX=0 903 - DY=0 904 - DZ=0 905 - DO 50 J=1,10 906 - READ(12,*,END=2000,ERR=2010,IOSTAT=IOS) 907 - - (TEMP(K),K=1,3) 908 - IF(J.EQ.1.OR.J.EQ.5.OR.J.EQ.8.OR.J.EQ.10)THEN 909 - DX=DX+TEMP(1) 910 - DY=DY+TEMP(2) 911 - DZ=DZ+TEMP(3) 912 - ENDIF 913 - 50 CONTINUE 914 - DCOMP=(DX**2+DY**2+DZ**2)/160000 915 - ENDIF 916 - ** Dielectricum identification via D/E comparison. 917 - IF((MAPFLG(2).AND.MAPFLG(3).AND.MAPFLG(4).AND. 918 - - (.NOT.MAPFLG(9)).AND.ICONT(1).EQ.-9.AND. 919 - - ICONT(2).EQ.-9.AND.ICONT(3).EQ.-9).OR. 920 - - (MAPFLG(10).AND.(.NOT.MAPFLG(9)).AND. 921 - - ICONT(1).EQ.2.AND.ICONT(2).EQ.3.AND. 922 - - ICONT(3).EQ.4))THEN 923 - IEPS=-1 924 - ECOMP=((EXMAP(NTETRA,1)+EXMAP(NTETRA,2)+ 925 - - EXMAP(NTETRA,3)+EXMAP(NTETRA,4))**2+ 926 - - (EYMAP(NTETRA,1)+EYMAP(NTETRA,2)+ 927 - - EYMAP(NTETRA,3)+EYMAP(NTETRA,4))**2+ 928 - - (EZMAP(NTETRA,1)+EZMAP(NTETRA,2)+ 929 - - EZMAP(NTETRA,3)+EZMAP(NTETRA,4))**2)/16 930 - IF(ICONT(1).EQ.2.AND.ICONT(2).EQ.3.AND. 931 - - ICONT(3).EQ.4)ECOMP=ECOMP/10000 932 - DO 60 J=1,NEPS 933 - IF(ABS(ECOMP*(100*EPS0*EPSMAT(J))**2-DCOMP).LE.1E-4* 934 - - (ABS(ECOMP*(100*EPS0*EPSMAT(J))**2)+ 935 - - ABS(DCOMP)))IEPS=J 936 - 60 CONTINUE 937 - IF(ECOMP.LE.0.AND.DCOMP.GT.0)THEN 938 - PRINT *,' !!!!!! MAPFM5 WARNING : Found'// 939 - - ' a dielectric constant of 0; skipped.' 940 - ELSEIF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN 941 - PRINT *,' !!!!!! MAPFM5 WARNING : Unable'// 942 - - ' to store a dielectricum from file ', 943 - - FMAP(1:NCMAP),'; file not read.' 944 - RETURN 945 - ELSEIF(IEPS.LT.0)THEN 946 - NEPS=NEPS+1 947 - IEPS=NEPS 948 - IF(ECOMP.LE.0)THEN 949 - PRINT *,' ------ MAPFM5 MESSAGE : Unable'// 950 - - ' to determine epsilon in an E=0'// 951 - - ' tetrahedron; epsilon set to 0.' 952 - EPSMAT(IEPS)=0 953 - ELSE 954 - EPSMAT(IEPS)=SQRT(DCOMP/ECOMP)/(100*EPS0) 955 - ENDIF 956 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5'', 957 - - '' DEBUG : Adding dielectricum with'', 958 - - '' eps='',E10.3,''.'')') EPSMAT(IEPS) 959 - ENDIF 960 - MATMAP(NTETRA)=IEPS 961 - NEWEPS=.TRUE. 962 - * Otherwise store the field. 963 - ELSEIF(ICONT(1).EQ.-9.AND.ICONT(2).EQ.-9.AND. 964 - - ICONT(3).EQ.-9.AND.(.NOT.MAPFLG(2)))THEN 965 - EXMAP(NTETRA,1)=DCOMP 966 - ENDIF 967 - ENDIF 968 - 10 CONTINUE 969 - *** Be sure something has been read. 970 - 2000 CONTINUE 971 - IF(NTETRA.NE.NMAP)THEN 972 - PRINT *,' !!!!!! MAPFM5 WARNING : Number of'// 973 - - ' tetrahedrons in ',FMAP(1:NCMAP),' does not'// 974 - - ' match current mesh; not read.' 975 - RETURN 976 - ENDIF 977 - *** Materials have been defined is NEWEPS is set. 978 - IF(NEWEPS)MAPFLG(9)=.TRUE. 979 - *** Scale electric fields if they have been entered. 980 - IF(ICONT(1).EQ.2.AND.(IDATA.EQ.0.OR.IDATA.EQ.2))THEN 981 - DO 200 I=1,NMAP 982 - DO 210 J=1,10 983 - EXMAP(I,J)=EXMAP(I,J)/100 984 - EYMAP(I,J)=EYMAP(I,J)/100 985 - EZMAP(I,J)=EZMAP(I,J)/100 986 - 210 CONTINUE 987 - 200 CONTINUE 988 - ELSEIF(ICONT(1).EQ.2.AND.IDATA.EQ.10)THEN 989 - DO 220 I=1,NMAP 990 - DO 230 J=1,10 991 - EWXMAP(I,J,IWMAP)=EWXMAP(I,J,IWMAP)/100 992 - EWYMAP(I,J,IWMAP)=EWYMAP(I,J,IWMAP)/100 993 - EWZMAP(I,J,IWMAP)=EWZMAP(I,J,IWMAP)/100 994 - 230 CONTINUE 995 - 220 CONTINUE 996 - ENDIF 997 - *** Flag those elements which have been defined. 998 - DO 70 I=1,3 999 - IF(ICONT(I).EQ.2.OR.ICONT(I).EQ.3.OR.ICONT(I).EQ.4)THEN 1000 - IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN 1001 - MAPFLG(ICONT(I))=.TRUE. 1002 - ELSEIF(IDATA.EQ.10)THEN 1003 - MAPFLG(8+ICONT(I)+3*IWMAP-2)=.TRUE. 1004 - ENDIF 1 483 P=CELL D=MAPFM5 11 PAGE 673 1005 - ELSEIF(ICONT(I).GT.0)THEN 1006 - MAPFLG(ICONT(I))=.TRUE. 1007 - ELSEIF(ICONT(I).EQ.-9)THEN 1008 - MAPFLG(10)=.TRUE. 1009 - ENDIF 1010 - 70 CONTINUE 1011 - *** Seems to have worked, set error flag to OK and return. 1012 - IFAIL=0 1013 - MAPTYP=12 1014 - RETURN 1015 - *** Handle error conditions. 1016 - 2005 CONTINUE 1017 - PRINT *,' !!!!!! MAPFM5 WARNING : Premature end of file'// 1018 - - ' reading a mesh file; map not available.' 1019 - IF(LDEBUG)CALL INPIOS(IOS) 1020 - CLOSE(12,ERR=2030) 1021 - RETURN 1022 - 2010 CONTINUE 1023 - PRINT *,' !!!!!! MAPFM5 WARNING : Error reading field map'// 1024 - - ' file ',FMAP(1:NCMAP),'; map not available.' 1025 - IF(LDEBUG)CALL INPIOS(IOS) 1026 - RETURN 1027 - 2015 CONTINUE 1028 - PRINT *,' !!!!!! MAPFM5 WARNING : Error reading a mesh'// 1029 - - ' file ; map not available.' 1030 - IF(LDEBUG)CALL INPIOS(IOS) 1031 - CLOSE(12,ERR=2030) 1032 - RETURN 1033 - 2030 CONTINUE 1034 - PRINT *,' !!!!!! MAPFM5 WARNING : Error closing field map'// 1035 - - ' file ',FMAP(1:NCMAP),'; map not available.' 1036 - IF(LDEBUG)CALL INPIOS(IOS) 1037 - RETURN 1038 - END 484 GARFIELD ================================================== P=CELL D=MAPFM6 1 ============================ 0 + +DECK,MAPFM6. 1 - SUBROUTINE MAPFM6(FMAP,NCMAP,IDATA,IWMAP, 2 - - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * MAPFM6 - Reads a Tosca table of boxes (hexhedrons). 5 - * (Last changed on 29/11/99.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,FIELDMAP. 11.- +SEQ,CONSTANTS. 12 - INTEGER MXCONT 13 - PARAMETER(MXCONT=20) 14 - INTEGER IEPS,ICONT(MXCONT),IMAX,I,J,JJ,K,L,M,NCMAP,IFAIL, 15 - - IH1,IH2,IH3,IH4,IH5,IH6,IH7,IH8,IHEX,IOS,INPCMP, 16 - - IDATA,IP,NHEX,NPOINT,IWMAP, 17 - - MPOINT,IMAP(MXMAP,8) 18 - REAL TEMP(MXCONT),ECOMP,DCOMP,WXMIN,WYMIN,WZMIN, 19 - - WXMAX,WYMAX,WZMAX,XP,YP,ZP 20 - DOUBLE PRECISION DXMAP(MXMAP),DYMAP(MXMAP),DZMAP(MXMAP) 21 - CHARACTER*(*) FMAP 22 - CHARACTER*5 DATA 23 - LOGICAL READ,WINDOW,BXOK,BYOK,BZOK,DXOK,DYOK,DZOK, 24 - - EXOK,EYOK,EZOK 25 - EXTERNAL INPCMP 0 26-+ +SELF,IF=SAVE. 27 - SAVE NHEX,NPOINT,DXMAP,DYMAP,DZMAP,IMAP 0 28-+ +SELF. 29 - DATA NHEX/0/, NPOINT/0/ 30 - **** Identify the routine if requested. 31 - IF(LIDENT)PRINT *,' /// ROUTINE MAPFM6 ///' 32 - *** Assume that this will fail. 33 - IFAIL=1 34 - *** We will only do Fortran reads, and want to read from the start. 35 - CALL INPSWI('RESTORE') 36 - REWIND(UNIT=12,ERR=2040,IOSTAT=IOS) 37 - *** If this is a mesh file. 38 - IF(IDATA.EQ.1)THEN 39 - * Read the number of hexahedrons. 40 - READ(12,'(I10)',END=2000,ERR=2010,IOSTAT=IOS) NPOINT 41 - * Check the value. 42 - IF(NPOINT.LE.0)THEN 43 - PRINT *,' !!!!!! MAPFM6 WARNING : The file ', 44 - - FMAP(1:NCMAP),' contains 0 or fewer'// 45 - - ' vertices; not read.' 46 - RETURN 47 - ENDIF 48 - * Debugging output. 49 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM6 DEBUG :'', 50 - - '' Number of vertices: '',I5)') NPOINT 51 - ** Skip to the hexahedron composition. 52 - CALL PROFLD(2,'Skipping',-1.0) 53 - CALL PROSTA(2,0.0) 54 - DO 1010 I=1,NPOINT 55 - READ(12,'(1X)',END=2000,ERR=2010,IOSTAT=IOS) 56 - 1010 CONTINUE 57 - * Read the number of hexahedrons. 58 - READ(12,'(I10)',END=2000,ERR=2010,IOSTAT=IOS) NHEX 59 - * Check the value. 60 - IF(NHEX.LE.0)THEN 61 - PRINT *,' !!!!!! MAPFM6 WARNING : The file ', 62 - - FMAP(1:NCMAP),' contains 0 or fewer'// 63 - - ' hexahedrons; not read.' 64 - RETURN 65 - ELSEIF(NHEX.GT.MXMAP)THEN 66 - PRINT *,' !!!!!! MAPFM6 WARNING : Number of'// 1 484 P=CELL D=MAPFM6 2 PAGE 674 67 - - ' hexahedrons in ',FMAP(1:NCMAP), 68 - - ' exceeds compilation limit; file not read.' 69 - RETURN 70 - ENDIF 71 - * Debugging output. 72 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM6 DEBUG :'', 73 - - '' Number of hexahedrons: '',I5)') NHEX 74 - * Initialise the tetrahedron to vertex pointers. 75 - DO 1050 J=1,8 76 - DO 1060 I=1,NHEX 77 - IMAP(I,J)=0 78 - 1060 CONTINUE 79 - 1050 CONTINUE 80 - ** Loop over the hexahedrons. 81 - CALL PROFLD(2,'Hexahedrons',REAL(NHEX)) 82 - DO 1030 I=1,NHEX 83 - IF(I.EQ.MAX(1,NHEX/100)*(I/MAX(1,NHEX/100))) 84 - - CALL PROSTA(2,REAL(I)) 85 - * Read the hexahedron number. 86 - READ(12,'(I10)',END=2000,ERR=2010,IOSTAT=IOS) IHEX 87 - * Read the pointers for its vertices. 88 - READ(12,'(8I10)',END=2000,ERR=2010,IOSTAT=IOS) 89 - - IH1,IH2,IH3,IH4,IH5,IH6,IH7,IH8 90 - * Ensure they all make sense. 91 - IF(IH1.LE.0.OR.IH2.LE.0.OR.IH3.LE.0.OR.IH4.LE.0.OR. 92 - - IH5.LE.0.OR.IH6.LE.0.OR.IH7.LE.0.OR.IH8.LE.0.OR. 93 - - IHEX.LE.0.OR.IHEX.GT.NHEX)THEN 94 - PRINT *,' !!!!!! MAPFM6 WARNING : Invalid hexahedron'// 95 - - ' reference in ',FMAP(1:NCMAP),'; map not read.' 96 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM6 DEBUG :'', 97 - - '' Hexahedron '',I5,'' / '',I5,'', Points: '',I5/ 98 - - 26X,''Vertices: '',4(2X,I5)/37X,4(2X,I5))') 99 - - IHEX,NHEX,NPOINT,IH1,IH2,IH3,IH4,IH5,IH6,IH7,IH8 100 - RETURN 101 - ENDIF 102 - * Store the reference pointers (negative sign for checks). 103 - IMAP(IHEX,1)=-IH1 104 - IMAP(IHEX,2)=-IH2 105 - IMAP(IHEX,3)=-IH3 106 - IMAP(IHEX,4)=-IH4 107 - IMAP(IHEX,5)=-IH5 108 - IMAP(IHEX,6)=-IH6 109 - IMAP(IHEX,7)=-IH7 110 - IMAP(IHEX,8)=-IH8 111 - 1030 CONTINUE 112 - ** Return to the start of the file. 113 - CALL PROFLD(2,'Rewind',-1.0) 114 - CALL PROSTA(2,0.0) 115 - REWIND(UNIT=12,ERR=2040,IOSTAT=IOS) 116 - * Skip the number of points. 117 - READ(12,'()',END=2000,ERR=2010,IOSTAT=IOS) 118 - ** Loop over the points. 119 - CALL PROFLD(2,'Vertices',REAL(NPOINT)) 120 - DO 1040 I=1,NPOINT 121 - IF(I.EQ.MAX(1,NPOINT/100)*(I/MAX(1,NPOINT/100))) 122 - - CALL PROSTA(2,REAL(I)) 123 - * Read the line. 124 - READ(12,'(I10,3F21.8)',END=2000,ERR=2010,IOSTAT=IOS) 125 - - IP,XP,YP,ZP 126 - IF(IP.LE.0)THEN 127 - PRINT *,' !!!!!! MAPFM6 WARNING : Invalid point'// 128 - - ' reference in ',FMAP(1:NCMAP),'; map not read.' 129 - RETURN 130 - ENDIF 131 - * Update the chamber dimensions. 132 - IF(I.EQ.1)THEN 133 - XMMIN=XP 134 - XMMAX=XP 135 - YMMIN=YP 136 - YMMAX=YP 137 - ZMMIN=ZP 138 - ZMMAX=ZP 139 - ELSE 140 - XMMIN=MIN(XMMIN,XP) 141 - XMMAX=MAX(XMMAX,XP) 142 - YMMIN=MIN(YMMIN,YP) 143 - YMMAX=MAX(YMMAX,YP) 144 - ZMMIN=MIN(ZMMIN,ZP) 145 - ZMMAX=MAX(ZMMAX,ZP) 146 - ENDIF 147 - * Update angular ranges. 148 - IF(YP.NE.0.OR.ZP.NE.0)THEN 149 - IF(SETAX)THEN 150 - XAMIN=MIN(XAMIN,ATAN2(ZP,YP)) 151 - XAMAX=MAX(XAMAX,ATAN2(ZP,YP)) 152 - ELSE 153 - XAMIN=ATAN2(ZP,YP) 154 - XAMAX=ATAN2(ZP,YP) 155 - SETAX=.TRUE. 156 - ENDIF 157 - ENDIF 158 - IF(ZP.NE.0.OR.XP.NE.0)THEN 159 - IF(SETAY)THEN 160 - YAMIN=MIN(YAMIN,ATAN2(XP,ZP)) 161 - YAMAX=MAX(YAMAX,ATAN2(XP,ZP)) 162 - ELSE 163 - YAMIN=ATAN2(XP,ZP) 164 - YAMAX=ATAN2(XP,ZP) 165 - SETAY=.TRUE. 166 - ENDIF 167 - ENDIF 168 - IF(XP.NE.0.OR.YP.NE.0)THEN 169 - IF(SETAZ)THEN 170 - ZAMIN=MIN(ZAMIN,ATAN2(YP,XP)) 171 - ZAMAX=MAX(ZAMAX,ATAN2(YP,XP)) 172 - ELSE 1 484 P=CELL D=MAPFM6 3 PAGE 675 173 - ZAMIN=ATAN2(YP,XP) 174 - ZAMAX=ATAN2(YP,XP) 175 - SETAZ=.TRUE. 176 - ENDIF 177 - ENDIF 178 - * Find referring hexahedrons, trace resolved references with sign. 179 - DO 1100 J=1,8 180 - IF(J.EQ.1.OR.J.EQ.2)THEN 181 - JJ=J 182 - ELSEIF(J.EQ.4.OR.J.EQ.5)THEN 183 - JJ=J-1 184 - ELSE 185 - JJ=0 186 - ENDIF 187 - DO 1110 K=1,NHEX 188 - IF(IP.EQ.ABS(IMAP(K,J)))THEN 189 - IF(JJ.NE.0)THEN 190 - XMAP(K,JJ)=XP 191 - YMAP(K,JJ)=YP 192 - ZMAP(K,JJ)=ZP 193 - ENDIF 194 - IMAP(K,J)=ABS(IMAP(K,J)) 195 - ENDIF 196 - 1110 CONTINUE 197 - 1100 CONTINUE 198 - * Next point. 199 - 1040 CONTINUE 200 - * End of reading, check reference resolution. 201 - CALL PROFLD(2,'Verifying',-1.0) 202 - CALL PROSTA(2,0.0) 203 - DO 1120 J=1,8 204 - DO 1130 I=1,NHEX 205 - IF(IMAP(I,J).LE.0)THEN 206 - PRINT *,' !!!!!! MAPFM6 WARNING : Unresolved point'// 207 - - ' references in mesh ; map rejected.' 208 - RETURN 209 - ENDIF 210 - 1130 CONTINUE 211 - 1120 CONTINUE 212 - * Preset Dx, Dy, Dz and the material. 213 - DO 1160 I=1,NHEX 214 - DXMAP(I)=0 215 - DYMAP(I)=0 216 - DZMAP(I)=0 217 - MATMAP(I)=-1 218 - 1160 CONTINUE 219 - * Now set the number of elements. 220 - NMAP=NHEX 221 - * Set the flag that the mesh is now defined. 222 - MAPFLG(1)=.TRUE. 223 - * Set the element type. 224 - MAPTYP=14 225 - *** Read field map files. 226 - ELSE 227 - * Make sure that the mesh has been read. 228 - IF(.NOT.MAPFLG(1))THEN 229 - PRINT *,' !!!!!! MAPFM6 WARNING : Attempt to read'// 230 - - ' a field map before the mesh ; not read.' 231 - RETURN 232 - ENDIF 233 - * Read the number of points in this file, check it matches the mesh. 234 - CALL PROFLD(2,'Contents',-1.0) 235 - CALL PROSTA(2,0.0) 236 - READ(12,'(I12)',END=2000,ERR=2010,IOSTAT=IOS) MPOINT 237 - IF(MPOINT.NE.NPOINT)THEN 238 - PRINT *,' !!!!!! MAPFM6 WARNING : Number of'// 239 - - ' points in ',FMAP(1:NCMAP),' does not'// 240 - - ' match current mesh; not read.' 241 - RETURN 242 - ENDIF 243 - ** Determine the contents of this field map. 244 - READ=.FALSE. 245 - IMAX=0 246 - BXOK=.FALSE. 247 - BYOK=.FALSE. 248 - BZOK=.FALSE. 249 - DXOK=.FALSE. 250 - DYOK=.FALSE. 251 - DZOK=.FALSE. 252 - EXOK=.FALSE. 253 - EYOK=.FALSE. 254 - EZOK=.FALSE. 255 - * Read up to the line stating the units. 256 - 100 CONTINUE 257 - READ(12,'(3X,A5)',END=2000,ERR=2010,IOSTAT=IOS) DATA 258 - IF(DATA.EQ.'[CGS]')THEN 259 - GOTO 110 260 - ELSEIF(IMAX.GE.MXCONT)THEN 261 - PRINT *,' !!!!!! MAPFM6 WARNING : Number of data'// 262 - - ' fields in ',FMAP(1:NCMAP),' is too large;'// 263 - - ' not read.' 264 - RETURN 265 - ENDIF 266 - IMAX=IMAX+1 267 - * Coordinates. 268 - IF(DATA.EQ.'X'.OR.DATA.EQ.'Y'.OR.DATA.EQ.'Z')THEN 269 - ICONT(IMAX)=1 270 - * Ex or Ewx. 271 - ELSEIF(DATA.EQ.'EX')THEN 272 - IF(IDATA.EQ.10)THEN 273 - IF(MAPFLG(10+3*IWMAP-2)) 274 - - PRINT *,' ------ MAPFM6 MESSAGE :'// 275 - - ' Overwriting current weighting Ex map.' 276 - MAPFLG(10+3*IWMAP-2)=.FALSE. 277 - ICONT(IMAX)=10+3*IWMAP-2 278 - ELSE 1 484 P=CELL D=MAPFM6 4 PAGE 676 279 - IF(MAPFLG(2))PRINT *,' ------ MAPFM6 MESSAGE :'// 280 - - ' Overwriting current Ex field map.' 281 - MAPFLG(2)=.FALSE. 282 - ICONT(IMAX)=2 283 - ENDIF 284 - EXOK=.TRUE. 285 - READ=.TRUE. 286 - * Ey or Ewy. 287 - ELSEIF(DATA.EQ.'EY')THEN 288 - IF(IDATA.EQ.10)THEN 289 - IF(MAPFLG(11+3*IWMAP-2)) 290 - - PRINT *,' ------ MAPFM6 MESSAGE :'// 291 - - ' Overwriting current weighting Ey map.' 292 - MAPFLG(11+3*IWMAP-2)=.FALSE. 293 - ICONT(IMAX)=11+3*IWMAP-2 294 - ELSE 295 - IF(MAPFLG(3))PRINT *,' ------ MAPFM6 MESSAGE :'// 296 - - ' Overwriting current Ey field map.' 297 - MAPFLG(3)=.FALSE. 298 - ICONT(IMAX)=3 299 - ENDIF 300 - EYOK=.TRUE. 301 - READ=.TRUE. 302 - * Ez or Ewz. 303 - ELSEIF(DATA.EQ.'EZ')THEN 304 - IF(IDATA.EQ.10)THEN 305 - IF(MAPFLG(12+3*IWMAP-2)) 306 - - PRINT *,' ------ MAPFM6 MESSAGE :'// 307 - - ' Overwriting current weighting Ez map.' 308 - MAPFLG(12+3*IWMAP-2)=.FALSE. 309 - ICONT(IMAX)=12+3*IWMAP-2 310 - ELSE 311 - IF(MAPFLG(4))PRINT *,' ------ MAPFM6 MESSAGE :'// 312 - - ' Overwriting current Ez field map.' 313 - MAPFLG(4)=.FALSE. 314 - ICONT(IMAX)=4 315 - ENDIF 316 - EZOK=.TRUE. 317 - READ=.TRUE. 318 - * Potential. 319 - ELSEIF(DATA.EQ.'V')THEN 320 - IF(MAPFLG(5))PRINT *,' ------ MAPFM6 MESSAGE :'// 321 - - ' Overwriting current potential map.' 322 - MAPFLG(5)=.FALSE. 323 - ICONT(IMAX)=5 324 - READ=.TRUE. 325 - * Bx, By and Bz. 326 - ELSEIF(DATA.EQ.'BX')THEN 327 - IF(MAPFLG(6))PRINT *,' ------ MAPFM6 MESSAGE :'// 328 - - ' Overwriting current Bx field map.' 329 - MAPFLG(6)=.FALSE. 330 - ICONT(IMAX)=6 331 - BXOK=.TRUE. 332 - READ=.TRUE. 333 - ELSEIF(DATA.EQ.'BY')THEN 334 - IF(MAPFLG(7))PRINT *,' ------ MAPFM6 MESSAGE :'// 335 - - ' Overwriting current Bx field map.' 336 - MAPFLG(7)=.FALSE. 337 - ICONT(IMAX)=7 338 - BYOK=.TRUE. 339 - READ=.TRUE. 340 - ELSEIF(DATA.EQ.'BZ')THEN 341 - IF(MAPFLG(8))PRINT *,' ------ MAPFM6 MESSAGE :'// 342 - - ' Overwriting current Bx field map.' 343 - MAPFLG(8)=.FALSE. 344 - ICONT(IMAX)=8 345 - BZOK=.TRUE. 346 - READ=.TRUE. 347 - * Dx, Dy and Dz. 348 - ELSEIF(DATA.EQ.'DX'.OR.DATA.EQ.'DY'.OR.DATA.EQ.'DZ')THEN 349 - IF(DATA.EQ.'DX')THEN 350 - ICONT(IMAX)=-2 351 - DXOK=.TRUE. 352 - ELSEIF(DATA.EQ.'DY')THEN 353 - ICONT(IMAX)=-3 354 - DYOK=.TRUE. 355 - ELSEIF(DATA.EQ.'DZ')THEN 356 - ICONT(IMAX)=-4 357 - DZOK=.TRUE. 358 - ENDIF 359 - IF(DXOK.AND.DYOK.AND.DZOK)THEN 360 - IF(MAPFLG(9))PRINT *,' ------ MAPFM6 MESSAGE :'// 361 - - ' Overwriting current material map.' 362 - MAPFLG(9)=.FALSE. 363 - ENDIF 364 - READ=.TRUE. 365 - MATSRC='EPSILON' 366 - * Other fields. 367 - ELSE 368 - PRINT *,' !!!!!! MAPFM6 WARNING : The file ', 369 - - FMAP(1:NCMAP),' contains data of the unknown'// 370 - - ' kind '//DATA//'; item skipped.' 371 - ICONT(IMAX)=0 372 - ENDIF 373 - GOTO 100 374 - 110 CONTINUE 375 - ** See whether any item is to be read. 376 - IF(.NOT.READ)THEN 377 - PRINT *,' !!!!!! MAPFM6 WARNING : The file ', 378 - - FMAP(1:NCMAP),' contains no useable'// 379 - - ' information; file not read.' 380 - RETURN 381 - * Make sure all 3 components of a vector are present. 382 - ELSEIF((BXOK.AND..NOT.(BYOK.AND.BZOK)).OR. 383 - - (BYOK.AND..NOT.(BXOK.AND.BZOK)).OR. 384 - - (BZOK.AND..NOT.(BXOK.AND.BYOK)))THEN 1 484 P=CELL D=MAPFM6 5 PAGE 677 385 - PRINT *,' !!!!!! MAPFM6 WARNING : Bx, By and Bz must'// 386 - - ' appear in one file; ',FMAP(1:NCMAP),' not read.' 387 - RETURN 388 - ELSEIF((DXOK.AND..NOT.(DYOK.AND.DZOK)).OR. 389 - - (DYOK.AND..NOT.(DXOK.AND.DZOK)).OR. 390 - - (DZOK.AND..NOT.(DXOK.AND.DYOK)))THEN 391 - PRINT *,' !!!!!! MAPFM6 WARNING : Dx, Dy and Dz must'// 392 - - ' appear in one file; ',FMAP(1:NCMAP),' not read.' 393 - RETURN 394 - ELSEIF((EXOK.AND..NOT.(EYOK.AND.EZOK)).OR. 395 - - (EYOK.AND..NOT.(EXOK.AND.EZOK)).OR. 396 - - (EZOK.AND..NOT.(EXOK.AND.EYOK)))THEN 397 - PRINT *,' !!!!!! MAPFM6 WARNING : Ex, Ey and Ez must'// 398 - - ' appear in one file; ',FMAP(1:NCMAP),' not read.' 399 - RETURN 400 - ENDIF 401 - ** Read the list of points with associated field values. 402 - CALL PROFLD(2,'Vertices',REAL(NPOINT)) 403 - DO 10 I=1,NPOINT 404 - IF(I.EQ.MAX(1,NPOINT/100)*(I/MAX(1,NPOINT/100))) 405 - - CALL PROSTA(2,REAL(I)) 406 - * Read the data line. 407 - READ(12,'(10F13.4)',END=2000,ERR=2010,IOSTAT=IOS) 408 - - (TEMP(J),J=1,IMAX) 409 - * Assign the data to the arrays. 410 - DO 20 L=1,8 411 - DO 30 K=1,NHEX 412 - DO 40 J=1,IMAX 413 - IF(ICONT(J).EQ.2.AND.IMAP(K,L).EQ.I)THEN 414 - EXMAP(K,L)=TEMP(J) 415 - ELSEIF(ICONT(J).EQ.3.AND.IMAP(K,L).EQ.I)THEN 416 - EYMAP(K,L)=TEMP(J) 417 - ELSEIF(ICONT(J).EQ.4.AND.IMAP(K,L).EQ.I)THEN 418 - EZMAP(K,L)=TEMP(J) 419 - ELSEIF(ICONT(J).EQ.5.AND.IMAP(K,L).EQ.I)THEN 420 - VMAP(K,L)=TEMP(J) 421 - IF(I.EQ.1)THEN 422 - VMMIN=TEMP(J) 423 - VMMAX=TEMP(J) 424 - ELSE 425 - VMMIN=MIN(VMMIN,TEMP(J)) 426 - VMMAX=MAX(VMMAX,TEMP(J)) 427 - ENDIF 428 - ELSEIF(ICONT(J).EQ.6.AND.IMAP(K,L).EQ.I)THEN 429 - BXMAP(K,L)=TEMP(J) 430 - ELSEIF(ICONT(J).EQ.7.AND.IMAP(K,L).EQ.I)THEN 431 - BYMAP(K,L)=TEMP(J) 432 - ELSEIF(ICONT(J).EQ.8.AND.IMAP(K,L).EQ.I)THEN 433 - BZMAP(K,L)=TEMP(J) 434 - ELSEIF(ICONT(J).EQ.9.AND.IMAP(K,L).EQ.I.AND.L.EQ.1)THEN 435 - IEPS=-1 436 - DO 80 M=1,NEPS 437 - IF(ABS(TEMP(J)-EPSMAT(M)).LT.1E-4*(ABS(TEMP(J))+ 438 - - ABS(EPSMAT(M))))IEPS=M 439 - 80 CONTINUE 440 - IF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN 441 - PRINT *,' !!!!!! MAPFM6 WARNING : More media'// 442 - - ' than storage allows in file ', 443 - - FMAP(1:NCMAP),'; medium not assigned.' 444 - RETURN 445 - ELSEIF(IEPS.LT.0)THEN 446 - NEPS=NEPS+1 447 - IEPS=NEPS 448 - EPSMAT(IEPS)=TEMP(J) 449 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM6'', 450 - - '' DEBUG : Adding dielectricum with'', 451 - - '' eps='',E10.3,''.'')') EPSMAT(IEPS) 452 - ENDIF 453 - MATMAP(K)=IEPS 454 - ELSEIF(ICONT(J).EQ.-2.AND.IMAP(K,L).EQ.I)THEN 455 - DXMAP(K)=DXMAP(K)+TEMP(J) 456 - ELSEIF(ICONT(J).EQ.-3.AND.IMAP(K,L).EQ.I)THEN 457 - DYMAP(K)=DYMAP(K)+TEMP(J) 458 - ELSEIF(ICONT(J).EQ.-4.AND.IMAP(K,L).EQ.I)THEN 459 - DZMAP(K)=DZMAP(K)+TEMP(J) 460 - ELSEIF(ICONT(J).GE.11.AND.IMAP(K,L).EQ.I)THEN 461 - EWXMAP(K,L,IWMAP)=TEMP(J) 462 - ELSEIF(ICONT(J).GE.12.AND.IMAP(K,L).EQ.I)THEN 463 - EWYMAP(K,L,IWMAP)=TEMP(J) 464 - ELSEIF(ICONT(J).GE.13.AND.IMAP(K,L).EQ.I)THEN 465 - EWZMAP(K,L,IWMAP)=TEMP(J) 466 - ENDIF 467 - 40 CONTINUE 468 - 30 CONTINUE 469 - 20 CONTINUE 470 - * Next point. 471 - 10 CONTINUE 472 - ** Flag those elements which have been defined. 473 - DO 70 I=1,IMAX 474 - IF(ICONT(I).GT.0)THEN 475 - MAPFLG(ICONT(I))=.TRUE. 476 - ELSEIF(ICONT(I).EQ.-2.OR.ICONT(I).EQ.-3.OR. 477 - - ICONT(I).EQ.-4)THEN 478 - MAPFLG(10)=.TRUE. 479 - ENDIF 480 - 70 CONTINUE 481 - ** Identify materials if both D and E are now available. 482 - IF(MAPFLG(2).AND.MAPFLG(3).AND.MAPFLG(4).AND. 483 - - MAPFLG(10).AND..NOT.MAPFLG(9))THEN 484 - * Loop over the elements. 485 - CALL PROFLD(2,'Epsilons',REAL(NMAP)) 486 - DO 50 I=1,NMAP 487 - IF(I.EQ.MAX(1,NMAP/100)*(I/MAX(1,NMAP/100))) 488 - - CALL PROSTA(2,REAL(I)) 489 - IEPS=-1 490 - * Compute |E| and |D| up to a factor 64. 1 484 P=CELL D=MAPFM6 6 PAGE 678 491 - ECOMP=(EXMAP(I,1)+EXMAP(I,2)+EXMAP(I,3)+EXMAP(I,4)+ 492 - - EXMAP(I,5)+EXMAP(I,6)+EXMAP(I,7)+EXMAP(I,8))**2+ 493 - - (EYMAP(I,1)+EYMAP(I,2)+EYMAP(I,3)+EYMAP(I,4)+ 494 - - EYMAP(I,5)+EYMAP(I,6)+EYMAP(I,7)+EYMAP(I,8))**2+ 495 - - (EZMAP(I,1)+EZMAP(I,2)+EZMAP(I,3)+EZMAP(I,4)+ 496 - - EZMAP(I,5)+EZMAP(I,6)+EZMAP(I,7)+EZMAP(I,8))**2 497 - DCOMP=DXMAP(I)**2+DYMAP(I)**2+DZMAP(I)**2 498 - * Match with existing epsilons. 499 - DO 60 J=1,NEPS 500 - IF((ECOMP.LE.0.AND.EPSMAT(J).LE.0).OR.( 501 - - ABS(ECOMP*(EPS0*EPSMAT(J))**2-DCOMP).LE.1E-4* 502 - - (ABS(ECOMP*(EPS0*EPSMAT(J))**2)+ 503 - - ABS(DCOMP))))IEPS=J 504 - 60 CONTINUE 505 - * Check for |E|=|D|=0. 506 - IF(ECOMP.LE.0.AND.DCOMP.GT.0)THEN 507 - PRINT *,' !!!!!! MAPFM6 WARNING : Found'// 508 - - ' a dielectric constant of 0; skipped.' 509 - * Warn if we run out of spcae. 510 - ELSEIF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN 511 - PRINT *,' !!!!!! MAPFM6 WARNING : More media'// 512 - - ' than storage allows in file ', 513 - - FMAP(1:NCMAP),'; medium not assigned.' 514 - RETURN 515 - * Add new epsilon to the table. 516 - ELSEIF(IEPS.LT.0)THEN 517 - NEPS=NEPS+1 518 - IEPS=NEPS 519 - IF(ECOMP.LE.0)THEN 520 - PRINT *,' ------ MAPFM6 MESSAGE : Unable'// 521 - - ' to determine epsilon in an E=0'// 522 - - ' hexahedron; epsilon set to 0.' 523 - EPSMAT(IEPS)=0 524 - ELSE 525 - EPSMAT(IEPS)=SQRT(DCOMP/ECOMP)/EPS0 526 - ENDIF 527 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM6'', 528 - - '' DEBUG : Adding dielectricum with'', 529 - - '' eps='',E10.3,''.'')') EPSMAT(IEPS) 530 - ENDIF 531 - * Assign the value. 532 - MATMAP(I)=IEPS 533 - 50 CONTINUE 534 - * Set the flag. 535 - MAPFLG(9)=.TRUE. 536 - ENDIF 537 - ENDIF 538 - *** Seems to have worked, set error flag to OK and return. 539 - IFAIL=0 540 - RETURN 541 - *** Error handling. 542 - 2000 CONTINUE 543 - PRINT *,' !!!!!! MAPFM6 WARNING : Premature end of file on ', 544 - - FMAP(1:NCMAP),'; file not read.' 545 - IF(LDEBUG)CALL INPIOS(IOS) 546 - RETURN 547 - 2010 CONTINUE 548 - PRINT *,' !!!!!! MAPFM6 WARNING : Error while reading ', 549 - - FMAP(1:NCMAP),'; file not read.' 550 - IF(LDEBUG)CALL INPIOS(IOS) 551 - RETURN 552 - 2040 CONTINUE 553 - PRINT *,' !!!!!! MAPFM6 WARNING : Error while rewinding ', 554 - - FMAP(1:NCMAP),'; file not read.' 555 - IF(LDEBUG)CALL INPIOS(IOS) 556 - RETURN 557 - END 485 GARFIELD ================================================== P=CELL D=MAPIND 1 ============================ 0 + +DECK,MAPIND. 1 - SUBROUTINE MAPIND(X,Y,Z,T1,T2,T3,T4,IMAP) 2 - *----------------------------------------------------------------------- 3 - * MAPIND - Finds the index of the triangle or tetrahedron in which 4 - * (X,Y,Z) is located and returns the triangle / tetrahedron 5 - * coordinates of the point. 6 - * (Last changed on 10/ 3/99.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,FIELDMAP. 11.- +SEQ,PRINTPLOT. 12 - INTEGER MXFOUN 13 - PARAMETER(MXFOUN=10) 14 - REAL X,Y,Z,T1,T2,T3,T4,TT1,TT2,TT3,TT4,PAR(3,3),VEC(3),RAUX(3) 15 - INTEGER I,IMAP,IL,NFOUND,IFOUND(MXFOUN),IFAIL 16 - DATA IL/0/ 0 17-+ +SELF,IF=SAVE. 18 - SAVE IL 0 19-+ +SELF. 20 - *** Initial values. 21 - T1=0 22 - T2=0 23 - T3=0 24 - T4=0 25 - IMAP=0 26 - *** Verify the count of volumes that contain the point. 27 - NFOUND=0 28 - *** Check for the last volume, first tetrahedrons. 29 - IF((MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13).AND. 30 - - IL.GE.1.AND.IL.LE.NMAP.AND..NOT.LMAPCH)THEN 31 - TT1=(X-XMAP(IL,2))*( 32 - - (YMAP(IL,3)-YMAP(IL,2))*(ZMAP(IL,4)-ZMAP(IL,2))- 33 - - (YMAP(IL,4)-YMAP(IL,2))*(ZMAP(IL,3)-ZMAP(IL,2)))+ 1 485 P=CELL D=MAPIND 2 PAGE 679 34 - - (Y-YMAP(IL,2))*( 35 - - (ZMAP(IL,3)-ZMAP(IL,2))*(XMAP(IL,4)-XMAP(IL,2))- 36 - - (ZMAP(IL,4)-ZMAP(IL,2))*(XMAP(IL,3)-XMAP(IL,2)))+ 37 - - (Z-ZMAP(IL,2))*( 38 - - (XMAP(IL,3)-XMAP(IL,2))*(YMAP(IL,4)-YMAP(IL,2))- 39 - - (XMAP(IL,4)-XMAP(IL,2))*(YMAP(IL,3)-YMAP(IL,2))) 40 - TT2=(X-XMAP(IL,3))*( 41 - - (YMAP(IL,1)-YMAP(IL,3))*(ZMAP(IL,4)-ZMAP(IL,3))- 42 - - (YMAP(IL,4)-YMAP(IL,3))*(ZMAP(IL,1)-ZMAP(IL,3)))+ 43 - - (Y-YMAP(IL,3))*( 44 - - (ZMAP(IL,1)-ZMAP(IL,3))*(XMAP(IL,4)-XMAP(IL,3))- 45 - - (ZMAP(IL,4)-ZMAP(IL,3))*(XMAP(IL,1)-XMAP(IL,3)))+ 46 - - (Z-ZMAP(IL,3))*( 47 - - (XMAP(IL,1)-XMAP(IL,3))*(YMAP(IL,4)-YMAP(IL,3))- 48 - - (XMAP(IL,4)-XMAP(IL,3))*(YMAP(IL,1)-YMAP(IL,3))) 49 - TT3=(X-XMAP(IL,4))*( 50 - - (YMAP(IL,1)-YMAP(IL,4))*(ZMAP(IL,2)-ZMAP(IL,4))- 51 - - (YMAP(IL,2)-YMAP(IL,4))*(ZMAP(IL,1)-ZMAP(IL,4)))+ 52 - - (Y-YMAP(IL,4))*( 53 - - (ZMAP(IL,1)-ZMAP(IL,4))*(XMAP(IL,2)-XMAP(IL,4))- 54 - - (ZMAP(IL,2)-ZMAP(IL,4))*(XMAP(IL,1)-XMAP(IL,4)))+ 55 - - (Z-ZMAP(IL,4))*( 56 - - (XMAP(IL,1)-XMAP(IL,4))*(YMAP(IL,2)-YMAP(IL,4))- 57 - - (XMAP(IL,2)-XMAP(IL,4))*(YMAP(IL,1)-YMAP(IL,4))) 58 - TT4=(X-XMAP(IL,1))*( 59 - - (YMAP(IL,3)-YMAP(IL,1))*(ZMAP(IL,2)-ZMAP(IL,1))- 60 - - (YMAP(IL,2)-YMAP(IL,1))*(ZMAP(IL,3)-ZMAP(IL,1)))+ 61 - - (Y-YMAP(IL,1))*( 62 - - (ZMAP(IL,3)-ZMAP(IL,1))*(XMAP(IL,2)-XMAP(IL,1))- 63 - - (ZMAP(IL,2)-ZMAP(IL,1))*(XMAP(IL,3)-XMAP(IL,1)))+ 64 - - (Z-ZMAP(IL,1))*( 65 - - (XMAP(IL,3)-XMAP(IL,1))*(YMAP(IL,2)-YMAP(IL,1))- 66 - - (XMAP(IL,2)-XMAP(IL,1))*(YMAP(IL,3)-YMAP(IL,1))) 67 - IF((TT1.GE.0.AND.TT2.GE.0.AND.TT3.GE.0.AND.TT4.GE.0).OR. 68 - - (TT1.LE.0.AND.TT2.LE.0.AND.TT3.LE.0.AND.TT4.LE.0))THEN 69 - T1=TT1/((XMAP(IL,1)-XMAP(IL,2))*( 70 - - (YMAP(IL,3)-YMAP(IL,2))*(ZMAP(IL,4)-ZMAP(IL,2))- 71 - - (YMAP(IL,4)-YMAP(IL,2))*(ZMAP(IL,3)-ZMAP(IL,2)))+ 72 - - (YMAP(IL,1)-YMAP(IL,2))*( 73 - - (ZMAP(IL,3)-ZMAP(IL,2))*(XMAP(IL,4)-XMAP(IL,2))- 74 - - (ZMAP(IL,4)-ZMAP(IL,2))*(XMAP(IL,3)-XMAP(IL,2)))+ 75 - - (ZMAP(IL,1)-ZMAP(IL,2))*( 76 - - (XMAP(IL,3)-XMAP(IL,2))*(YMAP(IL,4)-YMAP(IL,2))- 77 - - (XMAP(IL,4)-XMAP(IL,2))*(YMAP(IL,3)-YMAP(IL,2)))) 78 - T2=TT2/((XMAP(IL,2)-XMAP(IL,3))*( 79 - - (YMAP(IL,1)-YMAP(IL,3))*(ZMAP(IL,4)-ZMAP(IL,3))- 80 - - (YMAP(IL,4)-YMAP(IL,3))*(ZMAP(IL,1)-ZMAP(IL,3)))+ 81 - - (YMAP(IL,2)-YMAP(IL,3))*( 82 - - (ZMAP(IL,1)-ZMAP(IL,3))*(XMAP(IL,4)-XMAP(IL,3))- 83 - - (ZMAP(IL,4)-ZMAP(IL,3))*(XMAP(IL,1)-XMAP(IL,3)))+ 84 - - (ZMAP(IL,2)-ZMAP(IL,3))*( 85 - - (XMAP(IL,1)-XMAP(IL,3))*(YMAP(IL,4)-YMAP(IL,3))- 86 - - (XMAP(IL,4)-XMAP(IL,3))*(YMAP(IL,1)-YMAP(IL,3)))) 87 - T3=TT3/((XMAP(IL,3)-XMAP(IL,4))*( 88 - - (YMAP(IL,1)-YMAP(IL,4))*(ZMAP(IL,2)-ZMAP(IL,4))- 89 - - (YMAP(IL,2)-YMAP(IL,4))*(ZMAP(IL,1)-ZMAP(IL,4)))+ 90 - - (YMAP(IL,3)-YMAP(IL,4))*( 91 - - (ZMAP(IL,1)-ZMAP(IL,4))*(XMAP(IL,2)-XMAP(IL,4))- 92 - - (ZMAP(IL,2)-ZMAP(IL,4))*(XMAP(IL,1)-XMAP(IL,4)))+ 93 - - (ZMAP(IL,3)-ZMAP(IL,4))*( 94 - - (XMAP(IL,1)-XMAP(IL,4))*(YMAP(IL,2)-YMAP(IL,4))- 95 - - (XMAP(IL,2)-XMAP(IL,4))*(YMAP(IL,1)-YMAP(IL,4)))) 96 - T4=TT4/((XMAP(IL,4)-XMAP(IL,1))*( 97 - - (YMAP(IL,3)-YMAP(IL,1))*(ZMAP(IL,2)-ZMAP(IL,1))- 98 - - (YMAP(IL,2)-YMAP(IL,1))*(ZMAP(IL,3)-ZMAP(IL,1)))+ 99 - - (YMAP(IL,4)-YMAP(IL,1))*( 100 - - (ZMAP(IL,3)-ZMAP(IL,1))*(XMAP(IL,2)-XMAP(IL,1))- 101 - - (ZMAP(IL,2)-ZMAP(IL,1))*(XMAP(IL,3)-XMAP(IL,1)))+ 102 - - (ZMAP(IL,4)-ZMAP(IL,1))*( 103 - - (XMAP(IL,3)-XMAP(IL,1))*(YMAP(IL,2)-YMAP(IL,1))- 104 - - (XMAP(IL,2)-XMAP(IL,1))*(YMAP(IL,3)-YMAP(IL,1)))) 105 - IMAP=IL 106 - RETURN 107 - ENDIF 108 - * Triangles. 109 - ELSEIF((MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3).AND. 110 - - IL.GE.1.AND.IL.LE.NMAP.AND..NOT.LMAPCH)THEN 111 - TT1=(X-XMAP(IL,2))*(YMAP(IL,3)-YMAP(IL,2))- 112 - - (Y-YMAP(IL,2))*(XMAP(IL,3)-XMAP(IL,2)) 113 - TT2=(X-XMAP(IL,3))*(YMAP(IL,1)-YMAP(IL,3))- 114 - - (Y-YMAP(IL,3))*(XMAP(IL,1)-XMAP(IL,3)) 115 - TT3=(X-XMAP(IL,1))*(YMAP(IL,2)-YMAP(IL,1))- 116 - - (Y-YMAP(IL,1))*(XMAP(IL,2)-XMAP(IL,1)) 117 - IF((TT1.GE.0.AND.TT2.GE.0.AND.TT3.GE.0).OR. 118 - - (TT1.LE.0.AND.TT2.LE.0.AND.TT3.LE.0))THEN 119 - T1=TT1/ 120 - - ((XMAP(IL,1)-XMAP(IL,2))*(YMAP(IL,3)-YMAP(IL,2))- 121 - - (XMAP(IL,3)-XMAP(IL,2))*(YMAP(IL,1)-YMAP(IL,2))) 122 - T2=TT2/ 123 - - ((XMAP(IL,2)-XMAP(IL,3))*(YMAP(IL,1)-YMAP(IL,3))- 124 - - (XMAP(IL,1)-XMAP(IL,3))*(YMAP(IL,2)-YMAP(IL,3))) 125 - T3=TT3/ 126 - - ((XMAP(IL,3)-XMAP(IL,1))*(YMAP(IL,2)-YMAP(IL,1))- 127 - - (XMAP(IL,2)-XMAP(IL,1))*(YMAP(IL,3)-YMAP(IL,1))) 128 - T4=0 129 - IMAP=IL 130 - RETURN 131 - ENDIF 132 - * Regular hexahedrons. 133 - ELSEIF((MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16).AND. 134 - - IL.GE.1.AND.IL.LE.NMAP.AND..NOT.LMAPCH)THEN 135 - PAR(1,1)=(XMAP(IL,2)-XMAP(IL,1))**2+ 136 - - (YMAP(IL,2)-YMAP(IL,1))**2+(ZMAP(IL,2)-ZMAP(IL,1))**2 137 - PAR(2,2)=(XMAP(IL,3)-XMAP(IL,1))**2+ 138 - - (YMAP(IL,3)-YMAP(IL,1))**2+(ZMAP(IL,3)-ZMAP(IL,1))**2 139 - PAR(3,3)=(XMAP(IL,4)-XMAP(IL,1))**2+ 1 485 P=CELL D=MAPIND 3 PAGE 680 140 - - (YMAP(IL,4)-YMAP(IL,1))**2+(ZMAP(IL,4)-ZMAP(IL,1))**2 141 - PAR(1,2)= 142 - - (XMAP(IL,2)-XMAP(IL,1))*(XMAP(IL,3)-XMAP(IL,1))+ 143 - - (YMAP(IL,2)-YMAP(IL,1))*(YMAP(IL,3)-YMAP(IL,1))+ 144 - - (ZMAP(IL,2)-ZMAP(IL,1))*(ZMAP(IL,3)-ZMAP(IL,1)) 145 - PAR(2,1)=PAR(1,2) 146 - PAR(1,3)= 147 - - (XMAP(IL,2)-XMAP(IL,1))*(XMAP(IL,4)-XMAP(IL,1))+ 148 - - (YMAP(IL,2)-YMAP(IL,1))*(YMAP(IL,4)-YMAP(IL,1))+ 149 - - (ZMAP(IL,2)-ZMAP(IL,1))*(ZMAP(IL,4)-ZMAP(IL,1)) 150 - PAR(3,1)=PAR(1,3) 151 - PAR(2,3)= 152 - - (XMAP(IL,3)-XMAP(IL,1))*(XMAP(IL,4)-XMAP(IL,1))+ 153 - - (YMAP(IL,3)-YMAP(IL,1))*(YMAP(IL,4)-YMAP(IL,1))+ 154 - - (ZMAP(IL,3)-ZMAP(IL,1))*(ZMAP(IL,4)-ZMAP(IL,1)) 155 - PAR(2,3)=PAR(3,2) 156 - VEC(1)=(X-XMAP(IL,1))*(XMAP(IL,2)-XMAP(IL,1))+ 157 - - (Y-YMAP(IL,1))*(YMAP(IL,2)-YMAP(IL,1))+ 158 - - (Z-ZMAP(IL,1))*(ZMAP(IL,2)-ZMAP(IL,1)) 159 - VEC(2)=(X-XMAP(IL,1))*(XMAP(IL,3)-XMAP(IL,1))+ 160 - - (Y-YMAP(IL,1))*(YMAP(IL,3)-YMAP(IL,1))+ 161 - - (Z-ZMAP(IL,1))*(ZMAP(IL,3)-ZMAP(IL,1)) 162 - VEC(3)=(X-XMAP(IL,1))*(XMAP(IL,4)-XMAP(IL,1))+ 163 - - (Y-YMAP(IL,1))*(YMAP(IL,4)-YMAP(IL,1))+ 164 - - (Z-ZMAP(IL,1))*(ZMAP(IL,4)-ZMAP(IL,1)) 165 - CALL REQN(3,PAR,3,RAUX,IFAIL,1,VEC) 166 - IF(IFAIL.NE.0)THEN 167 - IMAP=0 168 - RETURN 169 - ENDIF 170 - IF(VEC(1).GE.0.AND.VEC(1).LE.1.AND. 171 - - VEC(2).GE.0.AND.VEC(2).LE.1.AND. 172 - - VEC(3).GE.0.AND.VEC(3).LE.1)THEN 173 - T1=VEC(1) 174 - T2=VEC(2) 175 - T3=VEC(3) 176 - T4=0 177 - IMAP=IL 178 - RETURN 179 - ENDIF 180 - ENDIF 181 - *** Loop over the volumes, first tetrahedrons. 182 - IF(MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13)THEN 183 - DO 10 I=1,NMAP 184 - IF(X.LT.MIN(XMAP(I,1),XMAP(I,2),XMAP(I,3),XMAP(I,4)).OR. 185 - - X.GT.MAX(XMAP(I,1),XMAP(I,2),XMAP(I,3),XMAP(I,4)).OR. 186 - - Y.LT.MIN(YMAP(I,1),YMAP(I,2),YMAP(I,3),YMAP(I,4)).OR. 187 - - Y.GT.MAX(YMAP(I,1),YMAP(I,2),YMAP(I,3),YMAP(I,4)).OR. 188 - - Z.LT.MIN(ZMAP(I,1),ZMAP(I,2),ZMAP(I,3),ZMAP(I,4)).OR. 189 - - Z.GT.MAX(ZMAP(I,1),ZMAP(I,2),ZMAP(I,3),ZMAP(I,4))) 190 - - GOTO 10 191 - TT1=(X-XMAP(I,2))*( 192 - - (YMAP(I,3)-YMAP(I,2))*(ZMAP(I,4)-ZMAP(I,2))- 193 - - (YMAP(I,4)-YMAP(I,2))*(ZMAP(I,3)-ZMAP(I,2)))+ 194 - - (Y-YMAP(I,2))*( 195 - - (ZMAP(I,3)-ZMAP(I,2))*(XMAP(I,4)-XMAP(I,2))- 196 - - (ZMAP(I,4)-ZMAP(I,2))*(XMAP(I,3)-XMAP(I,2)))+ 197 - - (Z-ZMAP(I,2))*( 198 - - (XMAP(I,3)-XMAP(I,2))*(YMAP(I,4)-YMAP(I,2))- 199 - - (XMAP(I,4)-XMAP(I,2))*(YMAP(I,3)-YMAP(I,2))) 200 - TT2=(X-XMAP(I,3))*( 201 - - (YMAP(I,1)-YMAP(I,3))*(ZMAP(I,4)-ZMAP(I,3))- 202 - - (YMAP(I,4)-YMAP(I,3))*(ZMAP(I,1)-ZMAP(I,3)))+ 203 - - (Y-YMAP(I,3))*( 204 - - (ZMAP(I,1)-ZMAP(I,3))*(XMAP(I,4)-XMAP(I,3))- 205 - - (ZMAP(I,4)-ZMAP(I,3))*(XMAP(I,1)-XMAP(I,3)))+ 206 - - (Z-ZMAP(I,3))*( 207 - - (XMAP(I,1)-XMAP(I,3))*(YMAP(I,4)-YMAP(I,3))- 208 - - (XMAP(I,4)-XMAP(I,3))*(YMAP(I,1)-YMAP(I,3))) 209 - TT3=(X-XMAP(I,4))*( 210 - - (YMAP(I,1)-YMAP(I,4))*(ZMAP(I,2)-ZMAP(I,4))- 211 - - (YMAP(I,2)-YMAP(I,4))*(ZMAP(I,1)-ZMAP(I,4)))+ 212 - - (Y-YMAP(I,4))*( 213 - - (ZMAP(I,1)-ZMAP(I,4))*(XMAP(I,2)-XMAP(I,4))- 214 - - (ZMAP(I,2)-ZMAP(I,4))*(XMAP(I,1)-XMAP(I,4)))+ 215 - - (Z-ZMAP(I,4))*( 216 - - (XMAP(I,1)-XMAP(I,4))*(YMAP(I,2)-YMAP(I,4))- 217 - - (XMAP(I,2)-XMAP(I,4))*(YMAP(I,1)-YMAP(I,4))) 218 - TT4=(X-XMAP(I,1))*( 219 - - (YMAP(I,3)-YMAP(I,1))*(ZMAP(I,2)-ZMAP(I,1))- 220 - - (YMAP(I,2)-YMAP(I,1))*(ZMAP(I,3)-ZMAP(I,1)))+ 221 - - (Y-YMAP(I,1))*( 222 - - (ZMAP(I,3)-ZMAP(I,1))*(XMAP(I,2)-XMAP(I,1))- 223 - - (ZMAP(I,2)-ZMAP(I,1))*(XMAP(I,3)-XMAP(I,1)))+ 224 - - (Z-ZMAP(I,1))*( 225 - - (XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1))- 226 - - (XMAP(I,2)-XMAP(I,1))*(YMAP(I,3)-YMAP(I,1))) 227 - IF((TT1.GE.0.AND.TT2.GE.0.AND.TT3.GE.0.AND.TT4.GE.0).OR. 228 - - (TT1.LE.0.AND.TT2.LE.0.AND.TT3.LE.0.AND.TT4.LE.0))THEN 229 - T1=TT1/((XMAP(I,1)-XMAP(I,2))*( 230 - - (YMAP(I,3)-YMAP(I,2))*(ZMAP(I,4)-ZMAP(I,2))- 231 - - (YMAP(I,4)-YMAP(I,2))*(ZMAP(I,3)-ZMAP(I,2)))+ 232 - - (YMAP(I,1)-YMAP(I,2))*( 233 - - (ZMAP(I,3)-ZMAP(I,2))*(XMAP(I,4)-XMAP(I,2))- 234 - - (ZMAP(I,4)-ZMAP(I,2))*(XMAP(I,3)-XMAP(I,2)))+ 235 - - (ZMAP(I,1)-ZMAP(I,2))*( 236 - - (XMAP(I,3)-XMAP(I,2))*(YMAP(I,4)-YMAP(I,2))- 237 - - (XMAP(I,4)-XMAP(I,2))*(YMAP(I,3)-YMAP(I,2)))) 238 - T2=TT2/((XMAP(I,2)-XMAP(I,3))*( 239 - - (YMAP(I,1)-YMAP(I,3))*(ZMAP(I,4)-ZMAP(I,3))- 240 - - (YMAP(I,4)-YMAP(I,3))*(ZMAP(I,1)-ZMAP(I,3)))+ 241 - - (YMAP(I,2)-YMAP(I,3))*( 242 - - (ZMAP(I,1)-ZMAP(I,3))*(XMAP(I,4)-XMAP(I,3))- 243 - - (ZMAP(I,4)-ZMAP(I,3))*(XMAP(I,1)-XMAP(I,3)))+ 244 - - (ZMAP(I,2)-ZMAP(I,3))*( 245 - - (XMAP(I,1)-XMAP(I,3))*(YMAP(I,4)-YMAP(I,3))- 1 485 P=CELL D=MAPIND 4 PAGE 681 246 - - (XMAP(I,4)-XMAP(I,3))*(YMAP(I,1)-YMAP(I,3)))) 247 - T3=TT3/((XMAP(I,3)-XMAP(I,4))*( 248 - - (YMAP(I,1)-YMAP(I,4))*(ZMAP(I,2)-ZMAP(I,4))- 249 - - (YMAP(I,2)-YMAP(I,4))*(ZMAP(I,1)-ZMAP(I,4)))+ 250 - - (YMAP(I,3)-YMAP(I,4))*( 251 - - (ZMAP(I,1)-ZMAP(I,4))*(XMAP(I,2)-XMAP(I,4))- 252 - - (ZMAP(I,2)-ZMAP(I,4))*(XMAP(I,1)-XMAP(I,4)))+ 253 - - (ZMAP(I,3)-ZMAP(I,4))*( 254 - - (XMAP(I,1)-XMAP(I,4))*(YMAP(I,2)-YMAP(I,4))- 255 - - (XMAP(I,2)-XMAP(I,4))*(YMAP(I,1)-YMAP(I,4)))) 256 - T4=TT4/((XMAP(I,4)-XMAP(I,1))*( 257 - - (YMAP(I,3)-YMAP(I,1))*(ZMAP(I,2)-ZMAP(I,1))- 258 - - (YMAP(I,2)-YMAP(I,1))*(ZMAP(I,3)-ZMAP(I,1)))+ 259 - - (YMAP(I,4)-YMAP(I,1))*( 260 - - (ZMAP(I,3)-ZMAP(I,1))*(XMAP(I,2)-XMAP(I,1))- 261 - - (ZMAP(I,2)-ZMAP(I,1))*(XMAP(I,3)-XMAP(I,1)))+ 262 - - (ZMAP(I,4)-ZMAP(I,1))*( 263 - - (XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1))- 264 - - (XMAP(I,2)-XMAP(I,1))*(YMAP(I,3)-YMAP(I,1)))) 265 - IMAP=I 266 - IL=I 267 - NFOUND=NFOUND+1 268 - IF(NFOUND.LE.MXFOUN)IFOUND(NFOUND)=IMAP 269 - IF(.NOT.LMAPCH)RETURN 270 - ENDIF 271 - 10 CONTINUE 272 - * Triangles. 273 - ELSEIF(MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3)THEN 274 - DO 20 I=1,NMAP 275 - IF(X.LT.MIN(XMAP(I,1),XMAP(I,2),XMAP(I,3)).OR. 276 - - X.GT.MAX(XMAP(I,1),XMAP(I,2),XMAP(I,3)).OR. 277 - - Y.LT.MIN(YMAP(I,1),YMAP(I,2),YMAP(I,3)).OR. 278 - - Y.GT.MAX(YMAP(I,1),YMAP(I,2),YMAP(I,3)))GOTO 20 279 - TT1=(X-XMAP(I,2))*(YMAP(I,3)-YMAP(I,2))- 280 - - (Y-YMAP(I,2))*(XMAP(I,3)-XMAP(I,2)) 281 - TT2=(X-XMAP(I,3))*(YMAP(I,1)-YMAP(I,3))- 282 - - (Y-YMAP(I,3))*(XMAP(I,1)-XMAP(I,3)) 283 - TT3=(X-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1))- 284 - - (Y-YMAP(I,1))*(XMAP(I,2)-XMAP(I,1)) 285 - IF((TT1.GE.0.AND.TT2.GE.0.AND.TT3.GE.0).OR. 286 - - (TT1.LE.0.AND.TT2.LE.0.AND.TT3.LE.0))THEN 287 - T1=TT1/((XMAP(I,1)-XMAP(I,2))*(YMAP(I,3)-YMAP(I,2))- 288 - - (XMAP(I,3)-XMAP(I,2))*(YMAP(I,1)-YMAP(I,2))) 289 - T2=TT2/((XMAP(I,2)-XMAP(I,3))*(YMAP(I,1)-YMAP(I,3))- 290 - - (XMAP(I,1)-XMAP(I,3))*(YMAP(I,2)-YMAP(I,3))) 291 - T3=TT3/((XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1))- 292 - - (XMAP(I,2)-XMAP(I,1))*(YMAP(I,3)-YMAP(I,1))) 293 - T4=0 294 - IMAP=I 295 - IL=I 296 - NFOUND=NFOUND+1 297 - IF(NFOUND.LE.MXFOUN)IFOUND(NFOUND)=IMAP 298 - IF(.NOT.LMAPCH)RETURN 299 - ENDIF 300 - 20 CONTINUE 301 - * Regular hexahedrons. 302 - ELSEIF(MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16)THEN 303 - DO 30 I=1,NMAP 304 - IF(X.LT.MIN(XMAP(I,1),XMAP(I,2),XMAP(I,3),XMAP(I,4)).OR. 305 - - X.GT.MAX(XMAP(I,1),XMAP(I,2),XMAP(I,3),XMAP(I,4)).OR. 306 - - Y.LT.MIN(YMAP(I,1),YMAP(I,2),YMAP(I,3),YMAP(I,4)).OR. 307 - - Y.GT.MAX(YMAP(I,1),YMAP(I,2),YMAP(I,3),YMAP(I,4)).OR. 308 - - Z.LT.MIN(ZMAP(I,1),ZMAP(I,2),ZMAP(I,3),ZMAP(I,4)).OR. 309 - - Z.GT.MAX(ZMAP(I,1),ZMAP(I,2),ZMAP(I,3),ZMAP(I,4))) 310 - - GOTO 30 311 - PAR(1,1)=(XMAP(I,2)-XMAP(I,1))**2+ 312 - - (YMAP(I,2)-YMAP(I,1))**2+(ZMAP(I,2)-ZMAP(I,1))**2 313 - PAR(2,2)=(XMAP(I,3)-XMAP(I,1))**2+ 314 - - (YMAP(I,3)-YMAP(I,1))**2+(ZMAP(I,3)-ZMAP(I,1))**2 315 - PAR(3,3)=(XMAP(I,4)-XMAP(I,1))**2+ 316 - - (YMAP(I,4)-YMAP(I,1))**2+(ZMAP(I,4)-ZMAP(I,1))**2 317 - PAR(1,2)= 318 - - (XMAP(I,2)-XMAP(I,1))*(XMAP(I,3)-XMAP(I,1))+ 319 - - (YMAP(I,2)-YMAP(I,1))*(YMAP(I,3)-YMAP(I,1))+ 320 - - (ZMAP(I,2)-ZMAP(I,1))*(ZMAP(I,3)-ZMAP(I,1)) 321 - PAR(2,1)=PAR(1,2) 322 - PAR(1,3)= 323 - - (XMAP(I,2)-XMAP(I,1))*(XMAP(I,4)-XMAP(I,1))+ 324 - - (YMAP(I,2)-YMAP(I,1))*(YMAP(I,4)-YMAP(I,1))+ 325 - - (ZMAP(I,2)-ZMAP(I,1))*(ZMAP(I,4)-ZMAP(I,1)) 326 - PAR(3,1)=PAR(1,3) 327 - PAR(2,3)= 328 - - (XMAP(I,3)-XMAP(I,1))*(XMAP(I,4)-XMAP(I,1))+ 329 - - (YMAP(I,3)-YMAP(I,1))*(YMAP(I,4)-YMAP(I,1))+ 330 - - (ZMAP(I,3)-ZMAP(I,1))*(ZMAP(I,4)-ZMAP(I,1)) 331 - PAR(2,3)=PAR(3,2) 332 - VEC(1)=(X-XMAP(I,1))*(XMAP(I,2)-XMAP(I,1))+ 333 - - (Y-YMAP(I,1))*(YMAP(I,2)-YMAP(I,1))+ 334 - - (Z-ZMAP(I,1))*(ZMAP(I,2)-ZMAP(I,1)) 335 - VEC(2)=(X-XMAP(I,1))*(XMAP(I,3)-XMAP(I,1))+ 336 - - (Y-YMAP(I,1))*(YMAP(I,3)-YMAP(I,1))+ 337 - - (Z-ZMAP(I,1))*(ZMAP(I,3)-ZMAP(I,1)) 338 - VEC(3)=(X-XMAP(I,1))*(XMAP(I,4)-XMAP(I,1))+ 339 - - (Y-YMAP(I,1))*(YMAP(I,4)-YMAP(I,1))+ 340 - - (Z-ZMAP(I,1))*(ZMAP(I,4)-ZMAP(I,1)) 341 - CALL REQN(3,PAR,3,RAUX,IFAIL,1,VEC) 342 - IF(IFAIL.NE.0)THEN 343 - IMAP=0 344 - RETURN 345 - ENDIF 346 - IF(VEC(1).GE.0.AND.VEC(1).LE.1.AND. 347 - - VEC(2).GE.0.AND.VEC(2).LE.1.AND. 348 - - VEC(3).GE.0.AND.VEC(3).LE.1)THEN 349 - T1=VEC(1) 350 - T2=VEC(2) 351 - T3=VEC(3) 1 485 P=CELL D=MAPIND 5 PAGE 682 352 - T4=0 353 - IMAP=I 354 - IL=I 355 - NFOUND=NFOUND+1 356 - IF(NFOUND.LE.MXFOUN)IFOUND(NFOUND)=IMAP 357 - IF(.NOT.LMAPCH)RETURN 358 - ENDIF 359 - 30 CONTINUE 360 - ELSE 361 - PRINT *,' !!!!!! MAPIND WARNING : Unknown element type ', 362 - - MAPTYP,' no map index returned.' 363 - IMAP=-1 364 - T1=-1 365 - T2=-1 366 - T3=-1 367 - T4=-1 368 - RETURN 369 - ENDIF 370 - *** In checking mode, verify the tetrahedron/triangle count. 371 - IF(LMAPCH)THEN 372 - IF(NFOUND.LE.0)THEN 373 - IMAP=0 374 - IL=0 375 - ELSEIF(NFOUND.GT.1)THEN 376 - PRINT *,' ------ MAPIND MESSAGE : Found ',NFOUND, 377 - - ' elements for point ',X,Y,Z 378 - DO 40 I=1,MIN(NFOUND,MXFOUN) 379 - IF(MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13)THEN 380 - WRITE(LUNOUT,'('' Tetrahedron '',I2, 381 - - '', index '',I5,'':''/ 382 - - '' (x1,y1,z1)='',3(E15.8,2X)/ 383 - - '' (x2,y2,z2)='',3(E15.8,2X)/ 384 - - '' (x3,y3,z3)='',3(E15.8,2X)/ 385 - - '' (x4,y4,z4)='',3(E15.8,2X))') 386 - - I,IFOUND(I), 387 - - XMAP(IFOUND(I),1),YMAP(IFOUND(I),1), 388 - - ZMAP(IFOUND(I),1), 389 - - XMAP(IFOUND(I),2),YMAP(IFOUND(I),2), 390 - - ZMAP(IFOUND(I),2), 391 - - XMAP(IFOUND(I),3),YMAP(IFOUND(I),3), 392 - - ZMAP(IFOUND(I),3), 393 - - XMAP(IFOUND(I),4),YMAP(IFOUND(I),4), 394 - - ZMAP(IFOUND(I),4) 395 - ELSEIF(MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3)THEN 396 - WRITE(LUNOUT,'('' Triangle '',I2, 397 - - '', index '',I5,'':''/ 398 - - '' (x1,y1)='',2(E15.8,2X)/ 399 - - '' (x2,y2)='',2(E15.8,2X)/ 400 - - '' (x3,y3)='',2(E15.8,2X))') 401 - - I,IFOUND(I), 402 - - XMAP(IFOUND(I),1),YMAP(IFOUND(I),1), 403 - - XMAP(IFOUND(I),2),YMAP(IFOUND(I),2), 404 - - XMAP(IFOUND(I),3),YMAP(IFOUND(I),3) 405 - ELSEIF(MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR. 406 - - MAPTYP.EQ.16)THEN 407 - WRITE(LUNOUT,'('' Hexahedron '',I2, 408 - - '', index '',I5,'':''/ 409 - - '' (x1,y1,z1)='',3(E15.8,2X)/ 410 - - '' (x2,y2,z2)='',3(E15.8,2X)/ 411 - - '' (x3,y3,z3)='',3(E15.8,2X)/ 412 - - '' (x4,y4,z4)='',3(E15.8,2X))') 413 - - I,IFOUND(I), 414 - - XMAP(IFOUND(I),1),YMAP(IFOUND(I),1), 415 - - ZMAP(IFOUND(I),1), 416 - - XMAP(IFOUND(I),2),YMAP(IFOUND(I),2), 417 - - ZMAP(IFOUND(I),2), 418 - - XMAP(IFOUND(I),3),YMAP(IFOUND(I),3), 419 - - ZMAP(IFOUND(I),3), 420 - - XMAP(IFOUND(I),4),YMAP(IFOUND(I),4), 421 - - ZMAP(IFOUND(I),4) 422 - ENDIF 423 - 40 CONTINUE 424 - ENDIF 425 - IF((MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3.OR. 426 - - MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13).AND. 427 - - NFOUND.GE.1.AND.ABS(T1+T2+T3+T4-1).GT.1E-3)THEN 428 - PRINT *,' !!!!!! MAPIND WARNING : Triangular'// 429 - - ' coordinates do not add up to 1.' 430 - PRINT *,' T1=',T1,', T2=',T2,', T3=',T3,', T4=',T4 431 - PRINT *,' X= ',X ,', Y= ',Y ,', Z= ',Z 432 - ENDIF 433 - *** No volume found. 434 - ELSE 435 - IMAP=0 436 - IL=0 437 - ENDIF 438 - RETURN 439 - *** Reset of volume. 440 - ENTRY MAPINR 441 - IL=0 442 - END 486 GARFIELD ================================================== P=CELL D=MAPINT 1 ============================ 0 + +DECK,MAPINT. 1 - SUBROUTINE MAPINT 2 - *----------------------------------------------------------------------- 3 - * MAPINT - Initialises the field map. 4 - * (Last changed on 29/11/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,FIELDMAP. 9 - INTEGER I,IFAIL,INIT 1 486 P=CELL D=MAPINT 2 PAGE 683 10-+ +SELF,IF=SAVE. 11 - SAVE INIT 0 12-+ +SELF. 13 - *** Set the number of triangles to 0. 14 - NMAP=0 15 - *** Set the availability flags to "not available". 16 - DO 10 I=1,10+3*MXWMAP 17 - MAPFLG(I)=.FALSE. 18 - 10 CONTINUE 19 - *** Reset the list of materials, number of different media. 20 - NEPS=0 21 - * Set all epsilons to -1 (i.e. unknown). 22 - DO 20 I=1,MXEPS 23 - EPSMAT(I)=-1 24 - 20 CONTINUE 25 - * Set drift medium to unknown. 26 - IDRMAT=-1 27 - * Set the material source to unknown. 28 - MATSRC='?' 29 - *** Reset the material indices. 30 - DO 30 I=1,MXMAP 31 - MATMAP(I)=-1 32 - 30 CONTINUE 33 - *** Preset the ranges. 34 - XMMIN=0 35 - XMMAX=0 36 - YMMIN=0 37 - YMMAX=0 38 - ZMMIN=0 39 - ZMMAX=0 40 - XAMIN=0 41 - XAMAX=0 42 - YAMIN=0 43 - YAMAX=0 44 - ZAMIN=0 45 - ZAMAX=0 46 - SETAX=.FALSE. 47 - SETAY=.FALSE. 48 - SETAZ=.FALSE. 49 - VMMIN=0 50 - VMMAX=0 51 - *** Field map interpolation order. 52 - MAPORD=1 53 - *** Volume element type. 54 - MAPTYP=0 55 - *** Reset interpolation. 56 - CALL MAPINR 57 - *** Plot the material map in principle. 58 - LMAPPL=.TRUE. 59 - *** Reset the number of weighting fields to 0 ... 60 - NWMAP=0 61 - * and reset the weighting field association string. 62 - DO 40 I=1,MXWMAP 63 - EWSTYP(I)='?' 64 - 40 CONTINUE 65 - *** Generate a booking entry on first call. 66 - DATA INIT/0/ 67 - IF(INIT.EQ.0)THEN 68 - CALL BOOK('INITIALISE','MAP',' ',IFAIL) 69 - IF(IFAIL.NE.0)PRINT *,' !!!!!! MAPINT WARNING : Unable'// 70 - - ' to allocate a booking entry for the field map;'// 71 - - ' field maps can not be used.' 72 - INIT=1 73 - ENDIF 74 - END 487 GARFIELD ================================================== P=CELL D=MAPREA 1 ============================ 0 + +DECK,MAPREA. 1 - SUBROUTINE MAPREA(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * MAPREA - Reads an interpolation table. 4 - * (Last changed on 29/11/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,FIELDMAP. 10.- +SEQ,CELLDATA. 11.- +SEQ,BFIELD. 12.- +SEQ,GASDATA. 13.- +SEQ,CONSTANTS. 14 - INTEGER IFAIL,IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5,IFAIL6,I,J,K,K0, 15 - - NWORD,INEXT,INPCMP,NCMAP,IFORM,IFILE(MXWORD),NFILE, 16 - - ISEL,INPTYP,IDATA(MXWORD),IWMAP(MXWORD),MAPMAX,MAPMXR,IORD, 17 - - NCAUX,IMESH 18 - REAL EPSSEL,ZMMINR,ZMMAXR,WXMIN,WYMIN,WZMIN,WXMAX,WYMAX, 19 - - WZMAX,AUX 20 - CHARACTER*(MXNAME) FMAP 21 - CHARACTER*20 AUXSTR 22 - LOGICAL OK,FLAG(MXWORD+2),WINDOW,NEWDRM,OLDFL9,LHISMP,DELBKG 23 - EXTERNAL INPCMP,INPTYP 24 - *** Inform that the routine has been called. 25 - IF(LIDENT)PRINT *,' /// ROUTINE MAPREA ///' 26 - *** Preset error flag. 27 - IFAIL=1 28 - *** Count words. 29 - CALL INPNUM(NWORD) 30 - *** Without arguments, print current field map status. 31 - IF(NWORD.LE.1)THEN 32 - CALL MAPPRT 33 - IFAIL=0 34 - RETURN 35 - ENDIF 36 - *** Preset all other parameters. 1 487 P=CELL D=MAPREA 2 PAGE 684 37 - NCMAP=0 38 - NFILE=0 39 - ISEL=0 40 - EPSSEL=-1 41 - NEWDRM=.FALSE. 42 - IMESH=0 43 - ZMMIN=-50 44 - ZMMAX=+50 45 - WXMIN=-1 46 - WXMAX=+1 47 - WYMIN=-1 48 - WYMAX=+1 49 - WZMIN=-1 50 - WZMAX=+1 51 - WINDOW=.FALSE. 52 - DELBKG=.TRUE. 53 - IORD=0 54 - PERX=.FALSE. 55 - PERY=.FALSE. 56 - PERZ=.FALSE. 57 - PERMX=.FALSE. 58 - PERMY=.FALSE. 59 - PERMZ=.FALSE. 60 - PERAX=.FALSE. 61 - PERAY=.FALSE. 62 - PERAZ=.FALSE. 63 - SETAX=.FALSE. 64 - SETAY=.FALSE. 65 - SETAZ=.FALSE. 66 - PERRX=.FALSE. 67 - PERRY=.FALSE. 68 - PERRZ=.FALSE. 69 - LHISMP=.FALSE. 70 - IFORM=0 71 - *** Prepare for progress printing. 72 - CALL PROINT('FIELD-MAP',1,6) 73 - CALL PROFLD(1,'Reading command',-1.0) 74 - CALL PROSTA(1,0.0) 75 - *** Scan for known keywords. 76 - DO 10 I=1,MXWORD+2 77 - FLAG(I)=.FALSE. 78 - IF(INPCMP(I,'FILE#S')+INPCMP(I,'RES#ET')+INPCMP(I,'Z-RAN#GE')+ 79 - - INPCMP(I,'DR#IFT-#MEDIUM')+INPCMP(I,'WIN#DOW')+ 80 - - INPCMP(I,'DEL#ETE-BACK#GROUND')+ 81 - - INPCMP(I,'KEEP-BACK#GROUND')+ 82 - - INPCMP(I,'X-PER#IODIC')+INPCMP(I,'X-MIR#ROR-PER#IODIC')+ 83 - - INPCMP(I,'Y-PER#IODIC')+INPCMP(I,'Y-MIR#ROR-PER#IODIC')+ 84 - - INPCMP(I,'Z-PER#IODIC')+INPCMP(I,'Z-MIR#ROR-PER#IODIC')+ 85 - - INPCMP(I,'X-AX#IALLY-PER#IODIC')+ 86 - - INPCMP(I,'Y-AX#IALLY-PER#IODIC')+ 87 - - INPCMP(I,'Z-AX#IALLY-PER#IODIC')+ 88 - - INPCMP(I,'NOT-X-PER#IODIC')+INPCMP(I,'NOT-Y-PER#IODIC')+ 89 - - INPCMP(I,'NOT-Z-PER#IODIC')+ 90 - - INPCMP(I,'NOPL#OT-MAP')+INPCMP(I,'PL#OT-MAP')+ 91 - - INPCMP(I,'NOHIST#OGRAM-#MAP')+INPCMP(I,'HIST#OGRAM-#MAP')+ 92 - - INPCMP(I,'LIN#EAR-#INTERPOLATION')+ 93 - - INPCMP(I,'QUA#DRATIC-#INTERPOLATION')+ 94 - - INPCMP(I,'CUB#IC-#INTERPOLATION')+ 95 - - INPCMP(I,'MAX#WELL-PAR#AMETER-EX#TRACTOR-2D')+ 96 - - INPCMP(I,'PAR#AMETER-EX#TRACTOR-2D')+ 97 - - INPCMP(I,'MAX#WELL-PAR#AMETER-EX#TRACTOR-3D')+ 98 - - INPCMP(I,'PAR#AMETER-EX#TRACTOR-3D')+ 99 - - INPCMP(I,'MAX#WELL-F#IELD-SIM#ULATOR-#3D')+ 100 - - INPCMP(I,'F#IELD-SIM#ULATOR-#3D')+ 101 - - INPCMP(I,'TOSCA').GT.0.OR.I.GT.NWORD) 102 - - FLAG(I)=.TRUE. 103 - 10 CONTINUE 104 - *** Read the arguments, 105 - INEXT=2 106 - OK=.TRUE. 107 - DO 20 I=2,NWORD 108 - IF(I.LT.INEXT)GOTO 20 109 - ** File name. 110 - IF(INPCMP(I,'FILE#S').NE.0)THEN 111 - * Ensure that at least 1 is present. 112 - IF(I+1.GT.NWORD.OR.FLAG(I+1))THEN 113 - CALL INPMSG(I,'Should have an argument.') 114 - OK=.FALSE. 115 - ELSE 116 - * Reset number of weighting fields. 117 - NWMAP=0 118 - * Loop over the candidate names. 119 - DO 30 J=I+1,NWORD 120 - IF(J.LT.INEXT)GOTO 30 121 - * Skip remainder if a keyword. 122 - IF(FLAG(J))THEN 123 - INEXT=J 124 - GOTO 40 125 - * Store the file name with contents and format. 126 - ELSE 127 - * See whether this can be stored at all. 128 - IF(NFILE.GE.MXWORD)THEN 129 - CALL INPMSG(J,'Unable to store name.') 130 - INEXT=J+1 131 - GOTO 40 132 - ENDIF 133 - NFILE=NFILE+1 134 - * Will usually not be a weighting field. 135 - IWMAP(NFILE)=0 136 - * Look for contents. 137 - IF(INPCMP(J,'MESH').NE.0)THEN 138 - IDATA(NFILE)=1 139 - INEXT=J+1 140 - IMESH=NFILE 141 - ELSEIF(INPCMP(J,'POT#ENTIAL')+ 142 - - INPCMP(J,'VOLT#AGE').NE.0)THEN 1 487 P=CELL D=MAPREA 3 PAGE 685 143 - IDATA(NFILE)=5 144 - INEXT=J+1 145 - ELSEIF(INPCMP(J,'MAT#ERIAL')+ 146 - - INPCMP(J,'D-#FIELD').NE.0)THEN 147 - IDATA(NFILE)=9 148 - INEXT=J+1 149 - ELSEIF(INPCMP(J,'E#LECTRIC-#FIELD').NE.0)THEN 150 - IDATA(NFILE)=2 151 - INEXT=J+1 152 - ELSEIF(INPCMP(J,'B-#FIELD')+ 153 - - INPCMP(J,'MAG#NETIC-#FIELD').NE.0)THEN 154 - IDATA(NFILE)=6 155 - INEXT=J+1 156 - ELSEIF(INPCMP(J,'W#EIGHTING-#FIELD').NE.0)THEN 157 - IF(NWMAP+1.LE.MXWMAP)THEN 158 - NWMAP=NWMAP+1 159 - IWMAP(NFILE)=NWMAP 160 - IDATA(NFILE)=10 161 - INEXT=J+1 162 - ELSE 163 - CALL INPMSG(J, 164 - - 'Too many weighting fields.') 165 - INEXT=J+1 166 - NFILE=NFILE-1 167 - GOTO 40 168 - ENDIF 169 - ELSE 170 - IDATA(NFILE)=0 171 - INEXT=J 172 - ENDIF 173 - * Pick up the file name. 174 - IF(FLAG(INEXT).OR.INEXT.GT.NWORD)THEN 175 - CALL INPMSG(J,'File name is missing.') 176 - INEXT=J+1 177 - GOTO 40 178 - ENDIF 179 - CALL INPSTR(INEXT,INEXT,FMAP,NCMAP) 180 - CALL STRBUF('STORE',IFILE(NFILE), 181 - - FMAP,NCMAP,IFAIL1) 182 - IF(IFAIL1.NE.0)THEN 183 - CALL INPMSG(INEXT,'String buffer error.') 184 - IFILE(NFILE)=0 185 - ENDIF 186 - INEXT=INEXT+1 187 - * See whether there is a format etc. 188 - K0=INEXT 189 - IF(IDATA(NFILE).EQ.10)EWSTYP(IWMAP(NFILE))='?' 190 - DO 60 K=K0,NWORD 191 - IF(K.LT.INEXT)THEN 192 - GOTO 60 193 - ELSEIF(FLAG(K))THEN 194 - INEXT=K 195 - GOTO 40 196 - ELSEIF(INPCMP(K,'SOL#IDS')+ 197 - - INPCMP(K,'LAB#EL').NE.0)THEN 198 - IF(FLAG(K+1).OR.K+1.GT.NWORD)THEN 199 - CALL INPMSG(K,'Solid label missing.') 200 - OK=.FALSE. 201 - ELSEIF(IDATA(NFILE).NE.10)THEN 202 - CALL INPMSG(K,'Only applicable to Ew.') 203 - ELSE 204 - CALL INPSTR(K+1,K+1,AUXSTR,NCAUX) 205 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ', 206 - - AUXSTR(1:1)).EQ.0.OR.NCAUX.LE. 207 - - 0)THEN 208 - CALL INPMSG(K+1, 209 - - 'The label must be a letter.') 210 - OK=.FALSE. 211 - ELSE 212 - EWSTYP(IWMAP(NFILE))=AUXSTR(1:1) 213 - ENDIF 214 - ENDIF 215 - INEXT=K+2 216 - ELSE 217 - INEXT=K 218 - GOTO 30 219 - ENDIF 220 - 60 CONTINUE 221 - ENDIF 222 - * Next file. 223 - 30 CONTINUE 224 - INEXT=NWORD+1 225 - * Leave file loop. 226 - 40 CONTINUE 227 - ENDIF 228 - ** Field map format. 229 - ELSEIF(INPCMP(I,'MAX#WELL-PAR#AMETER-EX#TRACTOR-2D')+ 230 - - INPCMP(I,'PAR#AMETER-EX#TRACTOR-2D').NE.0)THEN 231 - IFORM=1 232 - ELSEIF(INPCMP(I,'MAX#WELL-PAR#AMETER-EX#TRACTOR-3D')+ 233 - - INPCMP(I,'PAR#AMETER-EX#TRACTOR-3D').NE.0)THEN 234 - IFORM=2 235 - ELSEIF(INPCMP(I,'MAX#WELL-F#IELD-SIM#ULATOR-#3D')+ 236 - - INPCMP(I,'F#IELD-SIM#ULATOR-#3D').NE.0)THEN 237 - IFORM=4 238 - ELSEIF(INPCMP(I,'TOSCA').NE.0)THEN 239 - IFORM=5 240 - ** Select a drift medium. 241 - ELSEIF(INPCMP(I,'DR#IFT-#MEDIUM').NE.0)THEN 242 - IF(FLAG(I+1).OR.I+1.GT.NWORD)THEN 243 - CALL INPMSG(I,'Should have an argument') 244 - OK=.FALSE. 245 - ELSEIF(INPTYP(I+1).EQ.1)THEN 246 - CALL INPCHK(I+1,1,IFAIL1) 247 - CALL INPRDI(I+1,ISEL,0) 248 - IF(ISEL.NE.0)THEN 1 487 P=CELL D=MAPREA 4 PAGE 686 249 - NEWDRM=.TRUE. 250 - EPSSEL=-1 251 - ELSE 252 - CALL INPMSG(I+1,'Must be non-zero.') 253 - OK=.FALSE. 254 - ENDIF 255 - INEXT=I+2 256 - ELSEIF(INPTYP(I+1).EQ.2)THEN 257 - CALL INPCHK(I+1,2,IFAIL1) 258 - CALL INPRDR(I+1,EPSSEL,-1.0) 259 - IF(EPSSEL.GT.0)THEN 260 - NEWDRM=.TRUE. 261 - ISEL=0 262 - ELSE 263 - CALL INPMSG(I+1,'Must be > 0.') 264 - OK=.FALSE. 265 - ENDIF 266 - INEXT=I+2 267 - ELSEIF(INPCMP(I+1,'SMALL#EST-#EPSILON')+ 268 - - INPCMP(I+1,'LOW#EST-#EPSILON')+ 269 - - INPCMP(I+1,'SMALL#EST-#SIGMA')+ 270 - - INPCMP(I+1,'LOW#EST-#SIGMA').NE.0)THEN 271 - NEWDRM=.TRUE. 272 - ISEL=1 273 - EPSSEL=-1 274 - INEXT=I+2 275 - ELSEIF(INPCMP(I+1,'SEC#OND-SM#ALLEST-#EPSILON')+ 276 - - INPCMP(I+1,'ONE-BUT-SM#ALLEST-#EPSILON')+ 277 - - INPCMP(I+1,'SEC#OND-LOW#EST-#EPSILON')+ 278 - - INPCMP(I+1,'ONE-BUT-LOW#EST-#EPSILON')+ 279 - - INPCMP(I+1,'SEC#OND-SM#ALLEST-#SIGMA')+ 280 - - INPCMP(I+1,'ONE-BUT-SM#ALLEST-#SIGMA')+ 281 - - INPCMP(I+1,'SEC#OND-LOW#EST-#SIGMA')+ 282 - - INPCMP(I+1,'ONE-BUT-LOW#EST-#SIGMA').NE.0)THEN 283 - NEWDRM=.TRUE. 284 - ISEL=2 285 - EPSSEL=-1 286 - INEXT=I+2 287 - ELSEIF(INPCMP(I+1,'LARG#EST-#EPSILON')+ 288 - - INPCMP(I+1,'BIG#GEST-#EPSILON')+ 289 - - INPCMP(I+1,'LARG#EST-#SIGMA')+ 290 - - INPCMP(I+1,'BIG#GEST-#SIGMA').NE.0)THEN 291 - NEWDRM=.TRUE. 292 - ISEL=-1 293 - EPSSEL=-1 294 - INEXT=I+2 295 - ELSEIF(INPCMP(I+1,'SEC#OND-LARG#EST-#EPSILON')+ 296 - - INPCMP(I+1,'SEC#OND-BIG#GEST-#EPSILON')+ 297 - - INPCMP(I+1,'ONE-BUT-LARG#EST-#EPSILON')+ 298 - - INPCMP(I+1,'ONE-BUT-BIG#GEST-#EPSILON')+ 299 - - INPCMP(I+1,'SEC#OND-LARG#EST-#SIGMA')+ 300 - - INPCMP(I+1,'SEC#OND-BIG#GEST-#SIGMA')+ 301 - - INPCMP(I+1,'ONE-BUT-LARG#EST-#SIGMA')+ 302 - - INPCMP(I+1,'ONE-BUT-BIG#GEST-#SIGMA').NE.0)THEN 303 - NEWDRM=.TRUE. 304 - ISEL=-2 305 - EPSSEL=-1 306 - INEXT=I+2 307 - ELSE 308 - CALL INPMSG(I+1,'Not a known keyword.') 309 - OK=.FALSE. 310 - INEXT=I+2 311 - ENDIF 312 - ** Reset of the field maps. 313 - ELSEIF(INPCMP(I,'RES#ET').NE.0)THEN 314 - CALL MAPINT 315 - NEWDRM=.FALSE. 316 - ** Periodicities. 317 - ELSEIF(INPCMP(I,'NOT-X-PER#IODIC').NE.0)THEN 318 - PERX=.FALSE. 319 - PERAX=.FALSE. 320 - PERMX=.FALSE. 321 - PERRX=.FALSE. 322 - ELSEIF(INPCMP(I,'NOT-Y-PER#IODIC').NE.0)THEN 323 - PERY=.FALSE. 324 - PERAY=.FALSE. 325 - PERMY=.FALSE. 326 - PERRY=.FALSE. 327 - ELSEIF(INPCMP(I,'NOT-Z-PER#IODIC').NE.0)THEN 328 - PERZ=.FALSE. 329 - PERAZ=.FALSE. 330 - PERMZ=.FALSE. 331 - PERRZ=.FALSE. 332 - ELSEIF(INPCMP(I,'X-PER#IODIC').NE.0)THEN 333 - PERX=.TRUE. 334 - PERMX=.FALSE. 335 - ELSEIF(INPCMP(I,'Y-PER#IODIC').NE.0)THEN 336 - PERY=.TRUE. 337 - PERMY=.FALSE. 338 - ELSEIF(INPCMP(I,'Z-PER#IODIC').NE.0)THEN 339 - PERZ=.TRUE. 340 - PERMZ=.FALSE. 341 - ELSEIF(INPCMP(I,'X-MIR#ROR-PER#IODIC').NE.0)THEN 342 - PERMX=.TRUE. 343 - PERX=.FALSE. 344 - ELSEIF(INPCMP(I,'Y-MIR#ROR-PER#IODIC').NE.0)THEN 345 - PERMY=.TRUE. 346 - PERY=.FALSE. 347 - ELSEIF(INPCMP(I,'Z-MIR#ROR-PER#IODIC').NE.0)THEN 348 - PERMZ=.TRUE. 349 - PERZ=.FALSE. 350 - ELSEIF(INPCMP(I,'X-AX#IALLY-PER#IODIC').NE.0)THEN 351 - PERAX=.TRUE. 352 - ELSEIF(INPCMP(I,'Y-AX#IALLY-PER#IODIC').NE.0)THEN 353 - PERAY=.TRUE. 354 - ELSEIF(INPCMP(I,'Z-AX#IALLY-PER#IODIC').NE.0)THEN 1 487 P=CELL D=MAPREA 5 PAGE 687 355 - PERAZ=.TRUE. 356 - ELSEIF(INPCMP(I,'X-ROT#ATIONALLY-SYMM#ETRIC').NE.0)THEN 357 - PERRX=.TRUE. 358 - ELSEIF(INPCMP(I,'Y-ROT#ATIONALLY-SYMM#ETRIC').NE.0)THEN 359 - PERRY=.TRUE. 360 - ELSEIF(INPCMP(I,'Z-ROT#ATIONALLY-SYMM#ETRIC').NE.0)THEN 361 - PERRZ=.TRUE. 362 - ** Plotting options. 363 - ELSEIF(INPCMP(I,'PL#OT-MAP').NE.0)THEN 364 - LMAPPL=.TRUE. 365 - ELSEIF(INPCMP(I,'NOPL#OT-MAP').NE.0)THEN 366 - LMAPPL=.FALSE. 367 - ELSEIF(INPCMP(I,'HIST#OGRAM-#MAP').NE.0)THEN 368 - LHISMP=.TRUE. 369 - ELSEIF(INPCMP(I,'NOHIST#OGRAM-#MAP').NE.0)THEN 370 - LHISMP=.FALSE. 371 - ** Interpolation orders. 372 - ELSEIF(INPCMP(I,'LIN#EAR-#INTERPOLATION').NE.0)THEN 373 - IORD=1 374 - ELSEIF(INPCMP(I,'QUA#DRATIC-#INTERPOLATION').NE.0)THEN 375 - IORD=2 376 - ELSEIF(INPCMP(I,'CUB#IC-#INTERPOLATION').NE.0)THEN 377 - IORD=3 378 - ** Specification of a range in z (for 2-dimensional field maps). 379 - ELSEIF(INPCMP(I,'Z-RAN#GE').NE.0)THEN 380 - IF(I+2.GT.NWORD.OR.FLAG(I+1).OR.FLAG(I+2).OR. 381 - - (INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. 382 - - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2))THEN 383 - CALL INPMSG(I,'Should have 2 arguments.') 384 - ELSE 385 - CALL INPCHK(I+1,2,IFAIL1) 386 - CALL INPCHK(I+2,2,IFAIL2) 387 - CALL INPRDR(I+1,ZMMINR,ZMMIN) 388 - CALL INPRDR(I+2,ZMMAXR,ZMMAX) 389 - IF(ZMMINR.EQ.ZMMAXR)THEN 390 - CALL INPMSG(I+1,'Zero range not permitted.') 391 - CALL INPMSG(I+2,'See previous message.') 392 - ELSEIF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN 393 - ZMMIN=MIN(ZMMINR,ZMMAXR) 394 - ZMMAX=MAX(ZMMINR,ZMMAXR) 395 - ENDIF 396 - ENDIF 397 - INEXT=I+3 398 - ** Background deletion. 399 - ELSEIF(INPCMP(I,'DEL#ETE-BACK#GROUND').NE.0)THEN 400 - DELBKG=.TRUE. 401 - ELSEIF(INPCMP(I,'KEEP-BACK#GROUND').NE.0)THEN 402 - DELBKG=.FALSE. 403 - ** Window for cutting triangles. 404 - ELSEIF(INPCMP(I,'WIN#DOW').NE.0)THEN 405 - * Check argument types. 406 - IF(I+4.GT.NWORD.OR. 407 - - FLAG(I+1).OR.FLAG(I+2).OR.FLAG(I+3).OR.FLAG(I+4).OR. 408 - - (INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. 409 - - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. 410 - - (INPTYP(I+3).NE.1.AND.INPTYP(I+3).NE.2).OR. 411 - - (INPTYP(I+4).NE.1.AND.INPTYP(I+4).NE.2))THEN 412 - CALL INPMSG(I,'Should have 4 or 6 arguments.') 413 - ELSE 414 - * 3-dimensional window specification. 415 - IF((INPTYP(I+5).EQ.1.OR.INPTYP(I+5).EQ.2).AND. 416 - - (INPTYP(I+6).EQ.1.OR.INPTYP(I+6).EQ.2))THEN 417 - CALL INPCHK(I+1,2,IFAIL1) 418 - CALL INPCHK(I+2,2,IFAIL2) 419 - CALL INPCHK(I+3,2,IFAIL3) 420 - CALL INPCHK(I+4,2,IFAIL4) 421 - CALL INPCHK(I+5,2,IFAIL5) 422 - CALL INPCHK(I+6,2,IFAIL6) 423 - CALL INPRDR(I+1,WXMIN,-1.0) 424 - CALL INPRDR(I+2,WYMIN,-1.0) 425 - CALL INPRDR(I+3,WZMIN,-1.0) 426 - CALL INPRDR(I+4,WXMAX,+1.0) 427 - CALL INPRDR(I+5,WYMAX,+1.0) 428 - CALL INPRDR(I+6,WZMAX,+1.0) 429 - WZMIN=-1 430 - WZMAX=+1 431 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND. 432 - - IFAIL3.EQ.0.AND.IFAIL4.EQ.0.AND. 433 - - IFAIL5.EQ.0.AND.IFAIL6.EQ.0.AND. 434 - - WXMIN.NE.WXMAX.AND.WYMIN.NE.WYMAX.AND. 435 - - WZMIN.NE.WZMAX)THEN 436 - WINDOW=.TRUE. 437 - ELSE 438 - PRINT *,' !!!!!! MAPREA WARNING : Not a'// 439 - - ' valid window; ignored.' 440 - WINDOW=.FALSE. 441 - ENDIF 442 - INEXT=I+7 443 - * 2-dimensional window specification. 444 - ELSE 445 - CALL INPCHK(I+1,2,IFAIL1) 446 - CALL INPCHK(I+2,2,IFAIL2) 447 - CALL INPCHK(I+3,2,IFAIL3) 448 - CALL INPCHK(I+4,2,IFAIL4) 449 - CALL INPRDR(I+1,WXMIN,-1.0) 450 - CALL INPRDR(I+2,WYMIN,-1.0) 451 - CALL INPRDR(I+3,WXMAX,+1.0) 452 - CALL INPRDR(I+4,WYMAX,+1.0) 453 - WZMIN=-1 454 - WZMAX=+1 455 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND. 456 - - IFAIL3.EQ.0.AND.IFAIL4.EQ.0.AND. 457 - - WXMIN.NE.WXMAX.AND.WYMIN.NE.WYMAX)THEN 458 - WINDOW=.TRUE. 459 - ELSE 460 - PRINT *,' !!!!!! MAPREA WARNING : Not a'// 1 487 P=CELL D=MAPREA 6 PAGE 688 461 - - ' valid window; ignored.' 462 - WINDOW=.FALSE. 463 - ENDIF 464 - INEXT=I+5 465 - ENDIF 466 - * Ordering of window limits. 467 - IF(WXMIN.GT.WXMAX)THEN 468 - AUX=WXMIN 469 - WXMIN=WXMAX 470 - WXMAX=AUX 471 - ENDIF 472 - IF(WYMIN.GT.WYMAX)THEN 473 - AUX=WYMIN 474 - WYMIN=WYMAX 475 - WYMAX=AUX 476 - ENDIF 477 - IF(WZMIN.GT.WZMAX)THEN 478 - AUX=WZMIN 479 - WZMIN=WZMAX 480 - WZMAX=AUX 481 - ENDIF 482 - ENDIF 483 - ** Other options not known. 484 - ELSE 485 - CALL INPMSG(I,'Not a known option') 486 - OK=.FALSE. 487 - ENDIF 488 - 20 CONTINUE 489 - *** Print the error messages. 490 - CALL INPERR 491 - *** Read the mesh file if there is one. 492 - IF(IMESH.GT.0)THEN 493 - * Progress print. 494 - CALL PROFLD(1,'Mesh',-1.0) 495 - CALL PROSTA(1,0.0) 496 - * Retrieve mesh file name. 497 - CALL STRBUF('READ',IFILE(IMESH),FMAP,NCMAP,IFAIL1) 498 - * Ensure that there was no string buffer error. 499 - IF(IFAIL1.NE.0)THEN 500 - PRINT *,' !!!!!! MAPREA WARNING : String buffer'// 501 - - ' error retrieving mesh file name.' 502 - OK=.FALSE. 503 - * Be sure the name is not empty. 504 - ELSEIF(NCMAP.LT.1)THEN 505 - PRINT *,' !!!!!! MAPREA WARNING : The mesh file has'// 506 - - ' a name of length zero; file not read.' 507 - OK=.FALSE. 508 - ELSE 509 - * And read the file. 510 - CALL PRORED(2) 511 - CALL MAPFMR(FMAP,NCMAP,IFORM,IDATA(IMESH),IWMAP(IMESH), 512 - - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,DELBKG, 513 - - MAPMXR,IFAIL1) 514 - CALL PRORED(1) 515 - IF(IFAIL1.NE.0)THEN 516 - PRINT *,' !!!!!! MAPREA WARNING : File '// 517 - - FMAP(1:NCMAP)//' could not be read.' 518 - OK=.FALSE. 519 - ENDIF 520 - ENDIF 521 - * Delete the string. 522 - CALL STRBUF('DELETE',IFILE(IMESH),' ',1,IFAIL1) 523 - ENDIF 524 - *** Now read the field maps. 525 - IF(IMESH.GT.0)THEN 526 - CALL PROFLD(1,'Field maps',REAL(NFILE-1)) 527 - ELSE 528 - CALL PROFLD(1,'Field maps',REAL(NFILE)) 529 - ENDIF 530 - MAPMAX=0 531 - OLDFL9=MAPFLG(9) 532 - DO 50 I=1,NFILE 533 - * Progress print. 534 - CALL PROSTA(1,REAL(I)) 535 - * Skip if this is the mesh file. 536 - IF(I.EQ.IMESH)GOTO 50 537 - * Retrieve file name. 538 - CALL STRBUF('READ',IFILE(I),FMAP,NCMAP,IFAIL1) 539 - * Ensure that there was no string buffer error. 540 - IF(IFAIL1.NE.0)THEN 541 - PRINT *,' !!!!!! MAPREA WARNING : String buffer error', 542 - - ' retrieving name of file ',I,' to be read.' 543 - OK=.FALSE. 544 - * Be sure the name is not empty. 545 - ELSEIF(NCMAP.LT.1)THEN 546 - PRINT *,' !!!!!! MAPREA WARNING : File ',I,' to be', 547 - - ' read has name of length zero; file not read.' 548 - OK=.FALSE. 549 - ELSE 550 - * And read the file. 551 - CALL PRORED(2) 552 - CALL MAPFMR(FMAP,NCMAP,IFORM,IDATA(I),IWMAP(I), 553 - - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,DELBKG, 554 - - MAPMXR,IFAIL1) 555 - CALL PRORED(1) 556 - IF(IFAIL1.NE.0)THEN 557 - PRINT *,' !!!!!! MAPREA WARNING : File '// 558 - - FMAP(1:NCMAP)//' could not be read.' 559 - OK=.FALSE. 560 - ENDIF 561 - IF(MAPMAX.EQ.0)THEN 562 - MAPMAX=MAPMXR 563 - ELSE 564 - MAPMAX=MIN(MAPMAX,MAPMXR) 565 - ENDIF 566 - ENDIF 1 487 P=CELL D=MAPREA 7 PAGE 689 567 - * Delete the string. 568 - CALL STRBUF('DELETE',IFILE(I),' ',1,IFAIL1) 569 - 50 CONTINUE 570 - *** Final progress printing. 571 - CALL PROFLD(1,'Post processing',-1.0) 572 - CALL PROSTA(1,0.0) 573 - *** Establish the final interpolation order. 574 - IF(MAPMAX.LE.0)THEN 575 - PRINT *,' !!!!!! MAPREA WARNING : Reading routines did'// 576 - - ' not return a maximum interpolation order; set to 1.' 577 - MAPORD=1 578 - ELSEIF(IORD.EQ.0)THEN 579 - MAPORD=MAPMAX 580 - ELSEIF(IORD.GT.MAPMAX)THEN 581 - OK=.FALSE. 582 - PRINT *,' !!!!!! MAPREA WARNING : Requested interpolation'// 583 - - ' order exceeds field map granularity; set to maximum.' 584 - MAPORD=MAPMAX 585 - ELSE 586 - MAPORD=IORD 587 - ENDIF 588 - *** Sort the epsilons if a new epsilon map has been provided. 589 - IF(MAPFLG(9).AND..NOT.OLDFL9)CALL MAPEPS(IFAIL1) 590 - IF(IFAIL1.NE.0)THEN 591 - PRINT *,' !!!!!! MAPREA WARNING : Sorting the'// 592 - - ' material properties failed.' 593 - OK=.FALSE. 594 - ENDIF 595 - *** Figure out which material is drift medium. 596 - IF(NEWDRM.AND..NOT.MAPFLG(9))THEN 597 - PRINT *,' !!!!!! MAPREA WARNING : Cannot set a drift'// 598 - - ' medium since there are no material properties.' 599 - OK=.FALSE. 600 - IDRMAT=-1 601 - ELSEIF(NEWDRM.OR.(MAPFLG(9).AND..NOT.OLDFL9))THEN 602 - IF(NEPS.LT.1)THEN 603 - PRINT *,' !!!!!! MAPREA WARNING : No dielectric'// 604 - - ' media found; cannot select drift medium.' 605 - OK=.FALSE. 606 - IDRMAT=-1 607 - ELSEIF(ISEL.GT.NEPS.OR. 608 - - (ISEL.LT.0.AND.NEPS+ISEL+1.LE.0).OR. 609 - - (ISEL.LT.0.AND.NEPS+ISEL+1.GT.NEPS))THEN 610 - PRINT *,' !!!!!! MAPREA WARNING : Selection of'// 611 - - ' dielectric constant via invalid sequence'// 612 - - ' number; no assignment.' 613 - OK=.FALSE. 614 - IDRMAT=1 615 - ELSEIF(ISEL.LT.0)THEN 616 - IDRMAT=NEPS+ISEL+1 617 - ELSEIF(ISEL.EQ.0.AND.EPSSEL.LT.0)THEN 618 - PRINT *,' ------ MAPREA MESSAGE : No drift medium'// 619 - - ' has been selected ; choosing' 620 - PRINT *,' the one with'// 621 - - ' the lowest dielectric constant.' 622 - IDRMAT=1 623 - ELSEIF(ISEL.EQ.0)THEN 624 - IDRMAT=1 625 - DO 130 I=1,NEPS 626 - IF(ABS(EPSSEL-EPSMAT(I)).LT. 627 - - ABS(EPSSEL-EPSMAT(IDRMAT)))IDRMAT=I 628 - 130 CONTINUE 629 - PRINT *,' ------ MAPREA MESSAGE : Dielectric'// 630 - - ' constant nearest to ',EPSSEL,' is ', 631 - - EPSMAT(IDRMAT) 632 - ELSE 633 - IDRMAT=ISEL 634 - ENDIF 635 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPREA DEBUG :'', 636 - - '' Drift medium index='',I3)') IDRMAT 637 - ENDIF 638 - *** Verify that there is no x or y axial symmetry in 2D. 639 - IF((PERAX.OR.PERAY).AND.MAPTYP.LT.10)THEN 640 - PRINT *,' !!!!!! MAPREA WARNING : Axial symmetry has been'// 641 - - ' requested around x or y for a 2D map; reset.' 642 - PERAX=.FALSE. 643 - PERAY=.FALSE. 644 - OK=.FALSE. 645 - ENDIF 646 - *** For rotational symmetries, ensure that the fields are present. 647 - IF((PERRX.AND.(PERRY.OR.PERRZ)).OR. 648 - - (PERRY.AND.(PERRX.OR.PERRZ)).OR. 649 - - (PERRZ.AND.(PERRX.OR.PERRY)))THEN 650 - PRINT *,' !!!!!! MAPREA WARNING : More than one'// 651 - - ' rotational symmetry; reset.' 652 - PERRX=.FALSE. 653 - PERRY=.FALSE. 654 - PERRZ=.FALSE. 655 - OK=.FALSE. 656 - ELSEIF((PERRX.OR.PERRY.OR.PERRZ).AND.MAPTYP.GE.11)THEN 657 - PRINT *,' !!!!!! MAPREA WARNING : Rotational symmetry'// 658 - - ' declared for a 3D field map; reset.' 659 - PERRX=.FALSE. 660 - PERRY=.FALSE. 661 - PERRZ=.FALSE. 662 - OK=.FALSE. 663 - ELSEIF((PERRX.AND.(MAPFLG(3).OR.MAPFLG(7))).OR. 664 - - (PERRY.AND.(MAPFLG(4).OR.MAPFLG(8))).OR. 665 - - (PERRZ.AND.(MAPFLG(3).OR.MAPFLG(7))))THEN 666 - PRINT *,' !!!!!! MAPREA WARNING : Rotational symmetry'// 667 - - ' for the axis perpendicular to the map; reset.' 668 - PERRX=.FALSE. 669 - PERRY=.FALSE. 670 - PERRZ=.FALSE. 671 - OK=.FALSE. 672 - ENDIF 1 487 P=CELL D=MAPREA 8 PAGE 690 673 - *** Verify the ranges for axial symmetry have been set. 674 - IF(PERAX.AND.((.NOT.SETAX).OR. 675 - - ABS(MOD(XAMAX-XAMIN,2*PI)).LT.0.01))THEN 676 - PRINT *,' !!!!!! MAPREA WARNING : Axial symmetry around x'// 677 - - ' requested but range could not be set; reset.' 678 - PERAX=.FALSE. 679 - OK=.FALSE. 680 - ENDIF 681 - IF(PERAY.AND.((.NOT.SETAY).OR. 682 - - ABS(MOD(YAMAX-YAMIN,2*PI)).LT.0.01))THEN 683 - PRINT *,' !!!!!! MAPREA WARNING : Axial symmetry around y'// 684 - - ' requested but range could not be set; reset.' 685 - PERAY=.FALSE. 686 - OK=.FALSE. 687 - ENDIF 688 - IF(PERAZ.AND.((.NOT.SETAZ).OR. 689 - - ABS(MOD(ZAMAX-ZAMIN,2*PI)).LT.0.01))THEN 690 - PRINT *,' !!!!!! MAPREA WARNING : Axial symmetry around z'// 691 - - ' requested but range could not be set; reset.' 692 - PERAZ=.FALSE. 693 - OK=.FALSE. 694 - ENDIF 695 - *** Correct the axial range if needed. 696 - IF(PERAX.AND.XAMAX-XAMIN.GT.PI)THEN 697 - AUX=XAMIN 698 - XAMIN=XAMAX 699 - XAMAX=AUX+2*PI 700 - ENDIF 701 - IF(PERAY.AND.YAMAX-YAMIN.GT.PI)THEN 702 - AUX=YAMIN 703 - YAMIN=YAMAX 704 - YAMAX=AUX+2*PI 705 - ENDIF 706 - IF(PERAZ.AND.ZAMAX-ZAMIN.GT.PI)THEN 707 - AUX=ZAMIN 708 - ZAMIN=ZAMAX 709 - ZAMAX=AUX+2*PI 710 - ENDIF 711 - *** Verify that the range is a integral fraction of 2 pi. 712 - IF(PERAX)THEN 713 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPREA DEBUG :'', 714 - - '' x-Angular coverage: '',2F10.3/26X, 715 - - ''Periods: '',F10.3)') 716 - - 180*XAMIN/PI,180*XAMAX/PI,ABS(2*PI/(XAMAX-XAMIN)) 717 - IF(ABS(2*PI/(XAMAX-XAMIN)-ANINT(2*PI/(XAMAX-XAMIN))).GT. 718 - - 0.001.OR.ANINT(2*PI/(XAMAX-XAMIN)).LT.2)THEN 719 - PRINT *,' !!!!!! MAPREA WARNING : The map doesn''t'// 720 - - ' cover an integral fraction of 2 pi around x;'// 721 - - ' axial periodicity reset.' 722 - PERAX=.FALSE. 723 - OK=.FALSE. 724 - ENDIF 725 - ENDIF 726 - IF(PERAY)THEN 727 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPREA DEBUG :'', 728 - - '' y-Angular coverage: '',2F10.3/26X, 729 - - ''Periods: '',F10.3)') 730 - - 180*YAMIN/PI,180*YAMAX/PI,ABS(2*PI/(YAMAX-YAMIN)) 731 - IF(ABS(2*PI/(YAMAX-YAMIN)-ANINT(2*PI/(YAMAX-YAMIN))).GT. 732 - - 0.001.OR.ANINT(2*PI/(YAMAX-YAMIN)).LT.2)THEN 733 - PRINT *,' !!!!!! MAPREA WARNING : The map doesn''t'// 734 - - ' cover an integral fraction of 2 pi around y;'// 735 - - ' axial periodicity reset.' 736 - PERAY=.FALSE. 737 - OK=.FALSE. 738 - ENDIF 739 - ENDIF 740 - IF(PERAZ)THEN 741 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPREA DEBUG :'', 742 - - '' z-Angular coverage: '',2F10.3/26X, 743 - - ''Periods: '',F10.3)') 744 - - 180*ZAMIN/PI,180*ZAMAX/PI,ABS(2*PI/(ZAMAX-ZAMIN)) 745 - IF(ABS(2*PI/(ZAMAX-ZAMIN)-ANINT(2*PI/(ZAMAX-ZAMIN))).GT. 746 - - 0.001.OR.ANINT(2*PI/(ZAMAX-ZAMIN)).LT.2)THEN 747 - PRINT *,' !!!!!! MAPREA WARNING : The map doesn''t'// 748 - - ' cover an integral fraction of 2 pi around z;'// 749 - - ' axial periodicity reset.' 750 - PERAZ=.FALSE. 751 - OK=.FALSE. 752 - ENDIF 753 - ENDIF 754 - *** Verify that the weighting field has received a label. 755 - DO 70 I=1,NWMAP 756 - IF((MAPFLG(10+3*I-2).OR.MAPFLG(11+3*I-2).OR. 757 - - MAPFLG(12+3*I-2)))THEN 758 - IF(EWSTYP(I).EQ.'?')THEN 759 - PRINT *,' ------ MAPREA MESSAGE : Assigning label'// 760 - - ' "S" to weighting field ',I 761 - EWSTYP(I)='S' 762 - ENDIF 763 - ENDIF 764 - 70 CONTINUE 765 - *** End of progress printing. 766 - CALL PROEND 767 - *** Set magnetic field flag. 768 - IF(MAPFLG(6).AND.MAPFLG(7).AND.MAPFLG(8))THEN 769 - MAGOK=.TRUE. 770 - IF(MAGSRC.EQ.1)PRINT *,' ------ MAGREA MESSAGE : B field'// 771 - - ' from &MAGNETIC replaced by a field map.' 772 - MAGSRC=2 773 - IF(GASSET)PRINT *,' ------ MAPREA MESSAGE : Previous gas'// 774 - - ' data deleted.' 775 - GASSET=.FALSE. 776 - ELSEIF(MAGSRC.EQ.2)THEN 777 - PRINT *,' ------ MAGREA MESSAGE : The new field map has'// 778 - - ' no magnetic field; currently no magnetic field.' 1 487 P=CELL D=MAPREA 9 PAGE 691 779 - MAGSRC=0 780 - MAGOK=.FALSE. 781 - IF(GASSET)PRINT *,' ------ MAPREA MESSAGE : Previous gas'// 782 - - ' data deleted.' 783 - GASSET=.FALSE. 784 - ENDIF 785 - *** Check the map if requested. 786 - IF(LHISMP)THEN 787 - CALL MAPCHK(IFAIL1) 788 - IF(IFAIL1.NE.0)THEN 789 - PRINT *,' !!!!!! MAPREA WARNING : Histogramming'// 790 - - ' found map errors ; map rejected.' 791 - OK=.FALSE. 792 - ENDIF 793 - ENDIF 794 - *** Check that reading worked, 795 - IF(JFAIL.EQ.2.AND..NOT.OK)THEN 796 - PRINT *,' ###### MAPREA ERROR : Field maps reset'// 797 - - ' because of the above errors.' 798 - CALL MAPINT 799 - RETURN 800 - ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN 801 - PRINT *,' ###### MAPREA ERROR : Program terminated'// 802 - - ' because of the above errors.' 803 - CALL QUIT 804 - RETURN 805 - ENDIF 806 - *** Set the same limits for the cell. 807 - XMIN=XMMIN 808 - XMAX=XMMAX 809 - YMIN=YMMIN 810 - YMAX=YMMAX 811 - ZMIN=ZMMIN 812 - ZMAX=ZMMAX 813 - VMIN=VMMIN 814 - VMAX=VMMAX 815 - IF(PERX.OR.PERMX)SX=ABS(XMMAX-XMMIN) 816 - IF(PERY.OR.PERMY)SY=ABS(YMMAX-YMMIN) 817 - IF(PERZ.OR.PERMZ)SZ=ABS(ZMMAX-ZMMIN) 818 - IF(PERRX)THEN 819 - XMIN=YMMIN 820 - XMAX=YMMAX 821 - YMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) 822 - YMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) 823 - ZMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) 824 - ZMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) 825 - ELSEIF(PERRY)THEN 826 - XMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) 827 - XMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) 828 - YMIN=YMMIN 829 - YMAX=YMMAX 830 - ZMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) 831 - ZMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) 832 - ELSEIF(PERRZ)THEN 833 - XMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) 834 - XMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) 835 - YMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) 836 - YMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) 837 - ZMIN=YMMIN 838 - ZMAX=YMMAX 839 - ENDIF 840 - IF(PERAX)THEN 841 - YMIN=-MAX(ABS(YMMIN),ABS(YMMAX),ABS(ZMMIN),ABS(ZMMAX)) 842 - YMAX=+MAX(ABS(YMMIN),ABS(YMMAX),ABS(ZMMIN),ABS(ZMMAX)) 843 - ZMIN=-MAX(ABS(YMMIN),ABS(YMMAX),ABS(ZMMIN),ABS(ZMMAX)) 844 - ZMAX=+MAX(ABS(YMMIN),ABS(YMMAX),ABS(ZMMIN),ABS(ZMMAX)) 845 - ELSEIF(PERAY)THEN 846 - XMIN=-MAX(ABS(XMMIN),ABS(XMMAX),ABS(ZMMIN),ABS(ZMMAX)) 847 - XMAX=+MAX(ABS(XMMIN),ABS(XMMAX),ABS(ZMMIN),ABS(ZMMAX)) 848 - ZMIN=-MAX(ABS(XMMIN),ABS(XMMAX),ABS(ZMMIN),ABS(ZMMAX)) 849 - ZMAX=+MAX(ABS(XMMIN),ABS(XMMAX),ABS(ZMMIN),ABS(ZMMAX)) 850 - ELSEIF(PERAZ)THEN 851 - XMIN=-MAX(ABS(XMMIN),ABS(XMMAX),ABS(YMMIN),ABS(YMMAX)) 852 - XMAX=+MAX(ABS(XMMIN),ABS(XMMAX),ABS(YMMIN),ABS(YMMAX)) 853 - YMIN=-MAX(ABS(XMMIN),ABS(XMMAX),ABS(YMMIN),ABS(YMMAX)) 854 - YMAX=+MAX(ABS(XMMIN),ABS(XMMAX),ABS(YMMIN),ABS(YMMAX)) 855 - ENDIF 856 - *** Return with flag "successful". 857 - IFAIL=0 858 - END 488 GARFIELD ================================================== P=CELL D=MAPPLT 1 ============================ 0 + +DECK,MAPPLT. 1 - SUBROUTINE MAPPLT(PPXMIN,PPYMIN,PPZMIN,PPXMAX,PPYMAX,PPZMAX) 2 - *----------------------------------------------------------------------- 3 - * MAPPLT - Plots the materials. 4 - * (Last changed on 13/ 5/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,FIELDMAP. 9.- +SEQ,CELLDATA. 10.- +SEQ,PARAMETERS. 11 - REAL PPXMIN,PPYMIN,PPZMIN,PPXMAX,PPYMAX,PPZMAX, 12 - - XPL(20),YPL(20) 13 - DOUBLE PRECISION X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,X4,Y4,Z4,X5,Y5,Z5, 14 - - X6,Y6,Z6,X7,Y7,Z7,X8,Y8,Z8,XCUT,YCUT 15 - INTEGER I,NX,NXMIN,NXMAX,NY,NYMIN,NYMAX,NZ,NZMIN,NZMAX,NPL 16 - LOGICAL CUT,CROSS,IN1,IN2,IN3,IN4,IN5,IN6,IN7,IN8 17 - EXTERNAL CROSS 18 - *** Don't do anything if the material map is not present. 19 - IF(.NOT.MAPFLG(9).OR..NOT.LMAPPL)RETURN 20 - *** 2D maps make only sense in a z-projection. 21 - IF((MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3).AND. 22 - - ABS(FPROJC).LT.0.999*FPROJN)RETURN 1 488 P=CELL D=MAPPLT 2 PAGE 692 23 - *** Set the tolerances for butterfly elimination. 24 - CALL EPSSET('SET',1.0D-6*ABS(PPXMAX-PPXMIN), 25 - - 1.0D-6*ABS(PPYMAX-PPYMIN),1.0D-6*ABS(PPZMAX-PPZMIN)) 26 - *** Determine the number of periods present in the cell. 27 - NXMIN=0 28 - NXMAX=0 29 - NYMIN=0 30 - NYMAX=0 31 - NZMIN=0 32 - NZMAX=0 33 - IF(PERX.OR.PERMX)THEN 34 - NXMIN=INT(PPXMIN/SX)-1 35 - NXMAX=INT(PPXMAX/SX)+1 36 - ENDIF 37 - IF(PERY.OR.PERMY)THEN 38 - NYMIN=INT(PPYMIN/SY)-1 39 - NYMAX=INT(PPYMAX/SY)+1 40 - ENDIF 41 - IF(PERZ.OR.PERMZ)THEN 42 - NZMIN=INT(PPZMIN/SZ)-1 43 - NZMAX=INT(PPZMAX/SZ)+1 44 - ENDIF 45 - *** Loop over the triangles. 46 - DO 10 I=1,NMAP 47 - * Skip the drift medium. 48 - IF(MATMAP(I).EQ.IDRMAT.OR.MATMAP(I).EQ.-1)GOTO 10 49 - ** Triangular maps. 50 - IF(MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3)THEN 51 - * Loop over the periods, if present. 52 - DO 20 NX=NXMIN,NXMAX 53 - DO 30 NY=NYMIN,NYMAX 54 - * Determine corners of the triangle. 55 - IF(PERMX.AND.NX.NE.2*(NX/2))THEN 56 - XPL(1)=XMMIN+XMMAX-XMAP(I,1)+NX*SX 57 - XPL(2)=XMMIN+XMMAX-XMAP(I,2)+NX*SX 58 - XPL(3)=XMMIN+XMMAX-XMAP(I,3)+NX*SX 59 - XPL(4)=XMMIN+XMMAX-XMAP(I,1)+NX*SX 60 - ELSE 61 - XPL(1)=XMAP(I,1)+NX*SX 62 - XPL(2)=XMAP(I,2)+NX*SX 63 - XPL(3)=XMAP(I,3)+NX*SX 64 - XPL(4)=XMAP(I,1)+NX*SX 65 - ENDIF 66 - IF(PERMY.AND.NY.NE.2*(NY/2))THEN 67 - YPL(1)=YMMIN+YMMAX-YMAP(I,1)+NY*SY 68 - YPL(2)=YMMIN+YMMAX-YMAP(I,2)+NY*SY 69 - YPL(3)=YMMIN+YMMAX-YMAP(I,3)+NY*SY 70 - YPL(4)=YMMIN+YMMAX-YMAP(I,1)+NY*SY 71 - ELSE 72 - YPL(1)=YMAP(I,1)+NY*SY 73 - YPL(2)=YMAP(I,2)+NY*SY 74 - YPL(3)=YMAP(I,3)+NY*SY 75 - YPL(4)=YMAP(I,1)+NY*SY 76 - ENDIF 77 - * Plot the various media. 78 - IF(MATMAP(I).EQ.1)THEN 79 - CALL GRATTS('MATERIAL-1','AREA') 80 - CALL GRCONV(4,XPL,YPL) 81 - ELSEIF(MATMAP(I).EQ.2)THEN 82 - CALL GRATTS('MATERIAL-2','AREA') 83 - CALL GRCONV(4,XPL,YPL) 84 - ELSEIF(MATMAP(I).EQ.3)THEN 85 - CALL GRATTS('MATERIAL-3','AREA') 86 - CALL GRCONV(4,XPL,YPL) 87 - ELSEIF(MATMAP(I).EQ.4)THEN 88 - CALL GRATTS('MATERIAL-4','AREA') 89 - CALL GRCONV(4,XPL,YPL) 90 - ELSE 91 - CALL GRATTS('MATERIAL-5','AREA') 92 - CALL GRCONV(4,XPL,YPL) 93 - ENDIF 94 - * Next medium. 95 - 30 CONTINUE 96 - 20 CONTINUE 97 - ** Tetrahedral maps. 98 - ELSEIF(MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13)THEN 99 - * Loop over the x-periods, determine corners of tetrahedrons. 100 - DO 120 NX=NXMIN,NXMAX 101 - IF(PERMX.AND.NX.NE.2*(NX/2))THEN 102 - X1=XMMIN+XMMAX-XMAP(I,1)+NX*SX 103 - X2=XMMIN+XMMAX-XMAP(I,2)+NX*SX 104 - X3=XMMIN+XMMAX-XMAP(I,3)+NX*SX 105 - X4=XMMIN+XMMAX-XMAP(I,4)+NX*SX 106 - ELSE 107 - X1=XMAP(I,1)+NX*SX 108 - X2=XMAP(I,2)+NX*SX 109 - X3=XMAP(I,3)+NX*SX 110 - X4=XMAP(I,4)+NX*SX 111 - ENDIF 112 - * Loop over the y-periods, determine corners of tetrahedrons. 113 - DO 130 NY=NYMIN,NYMAX 114 - IF(PERMY.AND.NY.NE.2*(NY/2))THEN 115 - Y1=YMMIN+YMMAX-YMAP(I,1)+NY*SY 116 - Y2=YMMIN+YMMAX-YMAP(I,2)+NY*SY 117 - Y3=YMMIN+YMMAX-YMAP(I,3)+NY*SY 118 - Y4=YMMIN+YMMAX-YMAP(I,4)+NY*SY 119 - ELSE 120 - Y1=YMAP(I,1)+NY*SY 121 - Y2=YMAP(I,2)+NY*SY 122 - Y3=YMAP(I,3)+NY*SY 123 - Y4=YMAP(I,4)+NY*SY 124 - ENDIF 125 - * Loop over the z-periods, determine corners of tetrahedrons. 126 - DO 140 NZ=NZMIN,NZMAX 127 - IF(PERMZ.AND.NZ.NE.2*(NZ/2))THEN 128 - Z1=ZMMIN+ZMMAX-ZMAP(I,1)+NZ*SZ 1 488 P=CELL D=MAPPLT 3 PAGE 693 129 - Z2=ZMMIN+ZMMAX-ZMAP(I,2)+NZ*SZ 130 - Z3=ZMMIN+ZMMAX-ZMAP(I,3)+NZ*SZ 131 - Z4=ZMMIN+ZMMAX-ZMAP(I,4)+NZ*SZ 132 - ELSE 133 - Z1=ZMAP(I,1)+NZ*SZ 134 - Z2=ZMAP(I,2)+NZ*SZ 135 - Z3=ZMAP(I,3)+NZ*SZ 136 - Z4=ZMAP(I,4)+NZ*SZ 137 - ENDIF 138 - * See whether the edges are in the plane. 139 - IN1=.FALSE. 140 - IN2=.FALSE. 141 - IN3=.FALSE. 142 - IN4=.FALSE. 143 - IF(ABS(FPROJA*X1+FPROJB*Y1+FPROJC*Z1-FPROJD).LT. 144 - - 1.0E-4*MAX(ABS(X1),ABS(Y1),ABS(Z1),ABS(FPROJA), 145 - - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN1=.TRUE. 146 - IF(ABS(FPROJA*X2+FPROJB*Y2+FPROJC*Z2-FPROJD).LT. 147 - - 1.0E-4*MAX(ABS(X2),ABS(Y2),ABS(Z2),ABS(FPROJA), 148 - - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN2=.TRUE. 149 - IF(ABS(FPROJA*X3+FPROJB*Y3+FPROJC*Z3-FPROJD).LT. 150 - - 1.0E-4*MAX(ABS(X3),ABS(Y3),ABS(Z3),ABS(FPROJA), 151 - - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN3=.TRUE. 152 - IF(ABS(FPROJA*X4+FPROJB*Y4+FPROJC*Z4-FPROJD).LT. 153 - - 1.0E-4*MAX(ABS(X4),ABS(Y4),ABS(Z4),ABS(FPROJA), 154 - - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN4=.TRUE. 155 - * Add those of the 4 corners that are in the plane. 156 - NPL=0 157 - IF(IN1)THEN 158 - CALL PLACOO(X1,Y1,Z1,XCUT,YCUT) 159 - NPL=NPL+1 160 - XPL(NPL)=XCUT 161 - YPL(NPL)=YCUT 162 - ENDIF 163 - IF(IN2)THEN 164 - CALL PLACOO(X2,Y2,Z2,XCUT,YCUT) 165 - NPL=NPL+1 166 - XPL(NPL)=XCUT 167 - YPL(NPL)=YCUT 168 - ENDIF 169 - IF(IN3)THEN 170 - CALL PLACOO(X3,Y3,Z3,XCUT,YCUT) 171 - NPL=NPL+1 172 - XPL(NPL)=XCUT 173 - YPL(NPL)=YCUT 174 - ENDIF 175 - IF(IN4)THEN 176 - CALL PLACOO(X4,Y4,Z4,XCUT,YCUT) 177 - NPL=NPL+1 178 - XPL(NPL)=XCUT 179 - YPL(NPL)=YCUT 180 - ENDIF 181 - * Cut the 6 edges with the viewing plane. 182 - IF(.NOT.(IN1.OR.IN2))THEN 183 - CALL PLACUT(X1,Y1,Z1,X2,Y2,Z2,XCUT,YCUT,CUT) 184 - IF(CUT)THEN 185 - NPL=NPL+1 186 - XPL(NPL)=XCUT 187 - YPL(NPL)=YCUT 188 - ENDIF 189 - ENDIF 190 - IF(.NOT.(IN1.OR.IN3))THEN 191 - CALL PLACUT(X1,Y1,Z1,X3,Y3,Z3,XCUT,YCUT,CUT) 192 - IF(CUT)THEN 193 - NPL=NPL+1 194 - XPL(NPL)=XCUT 195 - YPL(NPL)=YCUT 196 - ENDIF 197 - ENDIF 198 - IF(.NOT.(IN1.OR.IN4))THEN 199 - CALL PLACUT(X1,Y1,Z1,X4,Y4,Z4,XCUT,YCUT,CUT) 200 - IF(CUT)THEN 201 - NPL=NPL+1 202 - XPL(NPL)=XCUT 203 - YPL(NPL)=YCUT 204 - ENDIF 205 - ENDIF 206 - IF(.NOT.(IN2.OR.IN3))THEN 207 - CALL PLACUT(X2,Y2,Z2,X3,Y3,Z3,XCUT,YCUT,CUT) 208 - IF(CUT)THEN 209 - NPL=NPL+1 210 - XPL(NPL)=XCUT 211 - YPL(NPL)=YCUT 212 - ENDIF 213 - ENDIF 214 - IF(.NOT.(IN2.OR.IN4))THEN 215 - CALL PLACUT(X2,Y2,Z2,X4,Y4,Z4,XCUT,YCUT,CUT) 216 - IF(CUT)THEN 217 - NPL=NPL+1 218 - XPL(NPL)=XCUT 219 - YPL(NPL)=YCUT 220 - ENDIF 221 - ENDIF 222 - IF(.NOT.(IN3.OR.IN4))THEN 223 - CALL PLACUT(X3,Y3,Z3,X4,Y4,Z4,XCUT,YCUT,CUT) 224 - IF(CUT)THEN 225 - NPL=NPL+1 226 - XPL(NPL)=XCUT 227 - YPL(NPL)=YCUT 228 - ENDIF 229 - ENDIF 230 - * Plot the various media. 231 - IF(NPL.GE.3)THEN 232 - NPL=NPL+1 233 - XPL(NPL)=XPL(1) 234 - YPL(NPL)=YPL(1) 1 488 P=CELL D=MAPPLT 4 PAGE 694 235 - IF(MATMAP(I).EQ.1)THEN 236 - CALL GRATTS('MATERIAL-1','AREA') 237 - CALL GRCONV(NPL,XPL,YPL) 238 - ELSEIF(MATMAP(I).EQ.2)THEN 239 - CALL GRATTS('MATERIAL-2','AREA') 240 - CALL GRCONV(NPL,XPL,YPL) 241 - ELSEIF(MATMAP(I).EQ.3)THEN 242 - CALL GRATTS('MATERIAL-3','AREA') 243 - CALL GRCONV(NPL,XPL,YPL) 244 - ELSEIF(MATMAP(I).EQ.4)THEN 245 - CALL GRATTS('MATERIAL-4','AREA') 246 - CALL GRCONV(NPL,XPL,YPL) 247 - ELSE 248 - CALL GRATTS('MATERIAL-5','AREA') 249 - CALL GRCONV(NPL,XPL,YPL) 250 - ENDIF 251 - ENDIF 252 - * Next periods. 253 - 140 CONTINUE 254 - 130 CONTINUE 255 - 120 CONTINUE 256 - ** Hexahedral maps. 257 - ELSEIF(MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16)THEN 258 - * Loop over the x-periods, determine corners of hexahedrons. 259 - DO 150 NX=NXMIN,NXMAX 260 - IF(PERMX.AND.NX.NE.2*(NX/2))THEN 261 - X1=XMMIN+XMMAX-XMAP(I,1)+NX*SX 262 - X2=X1-(XMAP(I,2)-XMAP(I,1)) 263 - X4=X1-(XMAP(I,3)-XMAP(I,1)) 264 - X3=X2+X4-X1 265 - X5=X1-(XMAP(I,4)-XMAP(I,1)) 266 - X6=X2-(XMAP(I,4)-XMAP(I,1)) 267 - X7=X3-(XMAP(I,4)-XMAP(I,1)) 268 - X8=X4-(XMAP(I,4)-XMAP(I,1)) 269 - ELSE 270 - X1=XMAP(I,1)+NX*SX 271 - X2=X1+(XMAP(I,2)-XMAP(I,1)) 272 - X4=X1+(XMAP(I,3)-XMAP(I,1)) 273 - X3=X2+X4-X1 274 - X5=X1+(XMAP(I,4)-XMAP(I,1)) 275 - X6=X2+(XMAP(I,4)-XMAP(I,1)) 276 - X7=X3+(XMAP(I,4)-XMAP(I,1)) 277 - X8=X4+(XMAP(I,4)-XMAP(I,1)) 278 - ENDIF 279 - * Loop over the y-periods, determine corners of tetrahedrons. 280 - DO 160 NY=NYMIN,NYMAX 281 - IF(PERMY.AND.NY.NE.2*(NY/2))THEN 282 - Y1=YMMIN+YMMAX-YMAP(I,1)+NY*SY 283 - Y2=Y1-(YMAP(I,2)-YMAP(I,1)) 284 - Y4=Y1-(YMAP(I,3)-YMAP(I,1)) 285 - Y3=Y2+Y4-Y1 286 - Y5=Y1-(YMAP(I,4)-YMAP(I,1)) 287 - Y6=Y2-(YMAP(I,4)-YMAP(I,1)) 288 - Y7=Y3-(YMAP(I,4)-YMAP(I,1)) 289 - Y8=Y4-(YMAP(I,4)-YMAP(I,1)) 290 - ELSE 291 - Y1=YMAP(I,1)+NY*SY 292 - Y2=Y1+(YMAP(I,2)-YMAP(I,1)) 293 - Y4=Y1+(YMAP(I,3)-YMAP(I,1)) 294 - Y3=Y2+Y4-Y1 295 - Y5=Y1+(YMAP(I,4)-YMAP(I,1)) 296 - Y6=Y2+(YMAP(I,4)-YMAP(I,1)) 297 - Y7=Y3+(YMAP(I,4)-YMAP(I,1)) 298 - Y8=Y4+(YMAP(I,4)-YMAP(I,1)) 299 - ENDIF 300 - * Loop over the z-periods, determine corners of tetrahedrons. 301 - DO 170 NZ=NZMIN,NZMAX 302 - IF(PERMZ.AND.NZ.NE.2*(NZ/2))THEN 303 - Z1=ZMMIN+ZMMAX-ZMAP(I,1)+NZ*SZ 304 - Z2=Z1-(ZMAP(I,2)-ZMAP(I,1)) 305 - Z4=Z1-(ZMAP(I,3)-ZMAP(I,1)) 306 - Z3=Z2+Z4-Z1 307 - Z5=Z1-(ZMAP(I,4)-ZMAP(I,1)) 308 - Z6=Z2-(ZMAP(I,4)-ZMAP(I,1)) 309 - Z7=Z3-(ZMAP(I,4)-ZMAP(I,1)) 310 - Z8=Z4-(ZMAP(I,4)-ZMAP(I,1)) 311 - ELSE 312 - Z1=ZMAP(I,1)+NZ*SZ 313 - Z2=Z1+(ZMAP(I,2)-ZMAP(I,1)) 314 - Z4=Z1+(ZMAP(I,3)-ZMAP(I,1)) 315 - Z3=Z2+Z4-Z1 316 - Z5=Z1+(ZMAP(I,4)-ZMAP(I,1)) 317 - Z6=Z2+(ZMAP(I,4)-ZMAP(I,1)) 318 - Z7=Z3+(ZMAP(I,4)-ZMAP(I,1)) 319 - Z8=Z4+(ZMAP(I,4)-ZMAP(I,1)) 320 - ENDIF 321 - * See whether the edges are in the plane. 322 - IN1=.FALSE. 323 - IN2=.FALSE. 324 - IN3=.FALSE. 325 - IN4=.FALSE. 326 - IN5=.FALSE. 327 - IN6=.FALSE. 328 - IN7=.FALSE. 329 - IN8=.FALSE. 330 - IF(ABS(FPROJA*X1+FPROJB*Y1+FPROJC*Z1-FPROJD).LT. 331 - - 1.0E-4*MAX(ABS(X1),ABS(Y1),ABS(Z1),ABS(FPROJA), 332 - - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN1=.TRUE. 333 - IF(ABS(FPROJA*X2+FPROJB*Y2+FPROJC*Z2-FPROJD).LT. 334 - - 1.0E-4*MAX(ABS(X2),ABS(Y2),ABS(Z2),ABS(FPROJA), 335 - - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN2=.TRUE. 336 - IF(ABS(FPROJA*X3+FPROJB*Y3+FPROJC*Z3-FPROJD).LT. 337 - - 1.0E-4*MAX(ABS(X3),ABS(Y3),ABS(Z3),ABS(FPROJA), 338 - - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN3=.TRUE. 339 - IF(ABS(FPROJA*X4+FPROJB*Y4+FPROJC*Z4-FPROJD).LT. 340 - - 1.0E-4*MAX(ABS(X4),ABS(Y4),ABS(Z4),ABS(FPROJA), 1 488 P=CELL D=MAPPLT 5 PAGE 695 341 - - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN4=.TRUE. 342 - IF(ABS(FPROJA*X5+FPROJB*Y5+FPROJC*Z5-FPROJD).LT. 343 - - 1.0E-4*MAX(ABS(X5),ABS(Y5),ABS(Z5),ABS(FPROJA), 344 - - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN5=.TRUE. 345 - IF(ABS(FPROJA*X6+FPROJB*Y6+FPROJC*Z6-FPROJD).LT. 346 - - 1.0E-4*MAX(ABS(X6),ABS(Y6),ABS(Z6),ABS(FPROJA), 347 - - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN6=.TRUE. 348 - IF(ABS(FPROJA*X7+FPROJB*Y7+FPROJC*Z7-FPROJD).LT. 349 - - 1.0E-4*MAX(ABS(X7),ABS(Y7),ABS(Z7),ABS(FPROJA), 350 - - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN7=.TRUE. 351 - IF(ABS(FPROJA*X8+FPROJB*Y8+FPROJC*Z8-FPROJD).LT. 352 - - 1.0E-4*MAX(ABS(X8),ABS(Y8),ABS(Z8),ABS(FPROJA), 353 - - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN8=.TRUE. 354 - * Add those of the 8 corners that are in the plane. 355 - NPL=0 356 - IF(IN1)THEN 357 - CALL PLACOO(X1,Y1,Z1,XCUT,YCUT) 358 - NPL=NPL+1 359 - XPL(NPL)=XCUT 360 - YPL(NPL)=YCUT 361 - ENDIF 362 - IF(IN2)THEN 363 - CALL PLACOO(X2,Y2,Z2,XCUT,YCUT) 364 - NPL=NPL+1 365 - XPL(NPL)=XCUT 366 - YPL(NPL)=YCUT 367 - ENDIF 368 - IF(IN3)THEN 369 - CALL PLACOO(X3,Y3,Z3,XCUT,YCUT) 370 - NPL=NPL+1 371 - XPL(NPL)=XCUT 372 - YPL(NPL)=YCUT 373 - ENDIF 374 - IF(IN4)THEN 375 - CALL PLACOO(X4,Y4,Z4,XCUT,YCUT) 376 - NPL=NPL+1 377 - XPL(NPL)=XCUT 378 - YPL(NPL)=YCUT 379 - ENDIF 380 - IF(IN5)THEN 381 - CALL PLACOO(X5,Y5,Z5,XCUT,YCUT) 382 - NPL=NPL+1 383 - XPL(NPL)=XCUT 384 - YPL(NPL)=YCUT 385 - ENDIF 386 - IF(IN6)THEN 387 - CALL PLACOO(X6,Y6,Z6,XCUT,YCUT) 388 - NPL=NPL+1 389 - XPL(NPL)=XCUT 390 - YPL(NPL)=YCUT 391 - ENDIF 392 - IF(IN7)THEN 393 - CALL PLACOO(X7,Y7,Z7,XCUT,YCUT) 394 - NPL=NPL+1 395 - XPL(NPL)=XCUT 396 - YPL(NPL)=YCUT 397 - ENDIF 398 - IF(IN8)THEN 399 - CALL PLACOO(X8,Y8,Z8,XCUT,YCUT) 400 - NPL=NPL+1 401 - XPL(NPL)=XCUT 402 - YPL(NPL)=YCUT 403 - ENDIF 404 - * Cut the 12 edges with the viewing plane. 405 - IF(.NOT.(IN1.OR.IN2))THEN 406 - CALL PLACUT(X1,Y1,Z1,X2,Y2,Z2,XCUT,YCUT,CUT) 407 - IF(CUT)THEN 408 - NPL=NPL+1 409 - XPL(NPL)=XCUT 410 - YPL(NPL)=YCUT 411 - ENDIF 412 - ENDIF 413 - IF(.NOT.(IN2.OR.IN3))THEN 414 - CALL PLACUT(X2,Y2,Z2,X3,Y3,Z3,XCUT,YCUT,CUT) 415 - IF(CUT)THEN 416 - NPL=NPL+1 417 - XPL(NPL)=XCUT 418 - YPL(NPL)=YCUT 419 - ENDIF 420 - ENDIF 421 - IF(.NOT.(IN3.OR.IN4))THEN 422 - CALL PLACUT(X3,Y3,Z3,X4,Y4,Z4,XCUT,YCUT,CUT) 423 - IF(CUT)THEN 424 - NPL=NPL+1 425 - XPL(NPL)=XCUT 426 - YPL(NPL)=YCUT 427 - ENDIF 428 - ENDIF 429 - IF(.NOT.(IN4.OR.IN1))THEN 430 - CALL PLACUT(X4,Y4,Z4,X1,Y1,Z1,XCUT,YCUT,CUT) 431 - IF(CUT)THEN 432 - NPL=NPL+1 433 - XPL(NPL)=XCUT 434 - YPL(NPL)=YCUT 435 - ENDIF 436 - ENDIF 437 - IF(.NOT.(IN5.OR.IN6))THEN 438 - CALL PLACUT(X5,Y5,Z5,X6,Y6,Z6,XCUT,YCUT,CUT) 439 - IF(CUT)THEN 440 - NPL=NPL+1 441 - XPL(NPL)=XCUT 442 - YPL(NPL)=YCUT 443 - ENDIF 444 - ENDIF 445 - IF(.NOT.(IN6.OR.IN7))THEN 446 - CALL PLACUT(X6,Y6,Z6,X7,Y7,Z7,XCUT,YCUT,CUT) 1 488 P=CELL D=MAPPLT 6 PAGE 696 447 - IF(CUT)THEN 448 - NPL=NPL+1 449 - XPL(NPL)=XCUT 450 - YPL(NPL)=YCUT 451 - ENDIF 452 - ENDIF 453 - IF(.NOT.(IN7.OR.IN8))THEN 454 - CALL PLACUT(X7,Y7,Z7,X8,Y8,Z8,XCUT,YCUT,CUT) 455 - IF(CUT)THEN 456 - NPL=NPL+1 457 - XPL(NPL)=XCUT 458 - YPL(NPL)=YCUT 459 - ENDIF 460 - ENDIF 461 - IF(.NOT.(IN8.OR.IN5))THEN 462 - CALL PLACUT(X8,Y8,Z8,X5,Y5,Z5,XCUT,YCUT,CUT) 463 - IF(CUT)THEN 464 - NPL=NPL+1 465 - XPL(NPL)=XCUT 466 - YPL(NPL)=YCUT 467 - ENDIF 468 - ENDIF 469 - IF(.NOT.(IN1.OR.IN5))THEN 470 - CALL PLACUT(X1,Y1,Z1,X5,Y5,Z5,XCUT,YCUT,CUT) 471 - IF(CUT)THEN 472 - NPL=NPL+1 473 - XPL(NPL)=XCUT 474 - YPL(NPL)=YCUT 475 - ENDIF 476 - ENDIF 477 - IF(.NOT.(IN2.OR.IN6))THEN 478 - CALL PLACUT(X2,Y2,Z2,X6,Y6,Z6,XCUT,YCUT,CUT) 479 - IF(CUT)THEN 480 - NPL=NPL+1 481 - XPL(NPL)=XCUT 482 - YPL(NPL)=YCUT 483 - ENDIF 484 - ENDIF 485 - IF(.NOT.(IN3.OR.IN7))THEN 486 - CALL PLACUT(X3,Y3,Z3,X7,Y7,Z7,XCUT,YCUT,CUT) 487 - IF(CUT)THEN 488 - NPL=NPL+1 489 - XPL(NPL)=XCUT 490 - YPL(NPL)=YCUT 491 - ENDIF 492 - ENDIF 493 - IF(.NOT.(IN4.OR.IN8))THEN 494 - CALL PLACUT(X4,Y4,Z4,X8,Y8,Z8,XCUT,YCUT,CUT) 495 - IF(CUT)THEN 496 - NPL=NPL+1 497 - XPL(NPL)=XCUT 498 - YPL(NPL)=YCUT 499 - ENDIF 500 - ENDIF 501 - * Plot the various media. 502 - IF(NPL.GE.3)THEN 503 - NPL=NPL+1 504 - XPL(NPL)=XPL(1) 505 - YPL(NPL)=YPL(1) 506 - IF(MATMAP(I).EQ.1)THEN 507 - CALL GRATTS('MATERIAL-1','AREA') 508 - CALL GRCONV(NPL,XPL,YPL) 509 - ELSEIF(MATMAP(I).EQ.2)THEN 510 - CALL GRATTS('MATERIAL-2','AREA') 511 - CALL GRCONV(NPL,XPL,YPL) 512 - ELSEIF(MATMAP(I).EQ.3)THEN 513 - CALL GRATTS('MATERIAL-3','AREA') 514 - CALL GRCONV(NPL,XPL,YPL) 515 - ELSEIF(MATMAP(I).EQ.4)THEN 516 - CALL GRATTS('MATERIAL-4','AREA') 517 - CALL GRCONV(NPL,XPL,YPL) 518 - ELSE 519 - CALL GRATTS('MATERIAL-5','AREA') 520 - CALL GRCONV(NPL,XPL,YPL) 521 - ENDIF 522 - ENDIF 523 - * Next periods. 524 - 170 CONTINUE 525 - 160 CONTINUE 526 - 150 CONTINUE 527 - ENDIF 528 - * Next element. 529 - 10 CONTINUE 530 - *** Reset the tolerances. 531 - CALL EPSSET('RESET',0.0D0,0.0D0,0.0D0) 532 - END 489 GARFIELD ================================================== P=CELL D=MAPPRT 1 ============================ 0 + +DECK,MAPPRT. 1 - SUBROUTINE MAPPRT 2 - *----------------------------------------------------------------------- 3 - * MAPPRT - Prints a field map overview. 4 - * (Last changed on 29/11/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,FIELDMAP. 9.- +SEQ,CELLDATA. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,CONSTANTS. 12 - INTEGER I 13 - *** Make sure there is a field map. 14 - IF(NMAP.LE.1)THEN 15 - WRITE(LUNOUT,'(/'' There is currently no field'', 16 - - '' map.'')/') 1 489 P=CELL D=MAPPRT 2 PAGE 697 17 - RETURN 18 - ENDIF 19 - *** Print the elements that are present. 20 - IF(MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3)THEN 21 - WRITE(LUNOUT,'(/'' The field is taken from a field map'', 22 - - '' of '',I5,'' triangles,''/'' at the vertices'', 23 - - '' of which the following are known:'')') NMAP 24 - ELSEIF(MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13)THEN 25 - WRITE(LUNOUT,'(/'' The field is taken from a field map'', 26 - - '' of '',I5,'' tetrahedrons,''/'' at the vertices'', 27 - - '' of which the following are known:'')') NMAP 28 - ELSEIF(MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16)THEN 29 - WRITE(LUNOUT,'(/'' The field is taken from a field map'', 30 - - '' of '',I5,'' parallelepipeds,''/ 31 - - '' at the vertices of which the following'', 32 - - '' are known:'')') NMAP 33 - ELSE 34 - WRITE(LUNOUT,'(/'' The field is taken from a field map'', 35 - - '' of '',I5,'' elements of unknown type,''/ 36 - - '' at the vertices of which the following''/ 37 - - '' are known:'')') NMAP 38 - ENDIF 39 - IF(MAPFLG(2))WRITE(LUNOUT,'('' - x-component of the'', 40 - - '' electric field'')') 41 - IF(MAPFLG(3))WRITE(LUNOUT,'('' - y-component of the'', 42 - - '' electric field'')') 43 - IF(MAPFLG(4))WRITE(LUNOUT,'('' - z-component of the'', 44 - - '' electric field'')') 45 - IF(MAPFLG(5))WRITE(LUNOUT,'('' - electrostatic'', 46 - - '' potential'')') 47 - IF(MAPFLG(6))WRITE(LUNOUT,'('' - x-component of the'', 48 - - '' magnetic field'')') 49 - IF(MAPFLG(7))WRITE(LUNOUT,'('' - y-component of the'', 50 - - '' magnetic field'')') 51 - IF(MAPFLG(8))WRITE(LUNOUT,'('' - z-component of the'', 52 - - '' magnetic field'')') 53 - IF(MAPFLG(9))WRITE(LUNOUT,'('' - dielectric constants'', 54 - - '' of the materials'')') 55 - DO 10 I=1,NWMAP 56 - IF(MAPFLG(10+3*I-2))WRITE(LUNOUT,'('' - x-component of a'', 57 - - '' weighting field for solids with label '',A1)') EWSTYP(I) 58 - IF(MAPFLG(11+3*I-2))WRITE(LUNOUT,'('' - y-component of a'', 59 - - '' weighting field for solids with label '',A1)') EWSTYP(I) 60 - IF(MAPFLG(12+3*I-2))WRITE(LUNOUT,'('' - z-component of a'', 61 - - '' weighting field for solids with label '',A1)') EWSTYP(I) 62 - 10 CONTINUE 63 - *** Print the ranges and periodicities. 64 - WRITE(LUNOUT,'(/'' The grid covers the area: ''/ 65 - - 5X,E15.8,'' < x < '',E15.8/ 66 - - 5X,E15.8,'' < y < '',E15.8/ 67 - - 5X,E15.8,'' < z < '',E15.8)') 68 - - XMMIN,XMMAX,YMMIN,YMMAX,ZMMIN,ZMMAX 69 - IF(MAPFLG(5))WRITE(LUNOUT,'('' and has a potential'', 70 - - '' range: ''/ 71 - - 5X,E15.8,'' < V < '',E15.8)') VMMIN,VMMAX 72 - IF(PERX)THEN 73 - WRITE(LUNOUT,'(/'' The cell is repeated in x, the'', 74 - - '' length of a period is '',F10.3,'' cm.'')') SX 75 - ELSEIF(PERMX)THEN 76 - WRITE(LUNOUT,'(/'' The cell has mirror periodicity'', 77 - - '' in x with a length of '',F10.3,'' cm.'')') SX 78 - ELSE 79 - WRITE(LUNOUT,'(/'' The cell has no translation'', 80 - - '' periodicity in x.'')') 81 - ENDIF 82 - IF(PERAX)THEN 83 - WRITE(LUNOUT,'('' The cell has axial periodicity'', 84 - - '' around the x-axis of '',F10.1, 85 - - '' degrees.'')') (XAMAX-XAMIN)*180/PI 86 - ELSEIF(PERRX)THEN 87 - WRITE(LUNOUT,'('' The cell is rotationally'', 88 - - '' symmetric around the x-axis.'')') 89 - ELSE 90 - WRITE(LUNOUT,'('' The cell has no axial periodicity'', 91 - - '' around the x-axis.'')') 92 - ENDIF 93 - * In y. 94 - IF(PERY)THEN 95 - WRITE(LUNOUT,'('' The cell is repeated in y, the'', 96 - - '' length of a period is '',F10.3,'' cm.'')') SY 97 - ELSEIF(PERMY)THEN 98 - WRITE(LUNOUT,'('' The cell has mirror periodicity'', 99 - - '' in y with a length of '',F10.3, 100 - - '' cm.'')') SY 101 - ELSE 102 - WRITE(LUNOUT,'('' The cell has no translation'', 103 - - '' periodicity in y.'')') 104 - ENDIF 105 - IF(PERAY)THEN 106 - WRITE(LUNOUT,'('' The cell has axial periodicity'', 107 - - '' around the y-axis of '',F10.1, 108 - - '' degrees.'')') (YAMAX-YAMIN)*180/PI 109 - ELSEIF(PERRY)THEN 110 - WRITE(LUNOUT,'('' The cell is rotationally'', 111 - - '' symmetric around the y-axis.'')') 112 - ELSE 113 - WRITE(LUNOUT,'('' The cell has no axial periodicity'', 114 - - '' around the y-axis.'')') 115 - ENDIF 116 - * In z. 117 - IF(PERZ)THEN 118 - WRITE(LUNOUT,'('' The cell is repeated in z, the'', 119 - - '' length of a period is '',F10.3,'' cm.'')') SZ 120 - ELSEIF(PERMZ)THEN 121 - WRITE(LUNOUT,'('' The cell has mirror periodicity'', 122 - - '' in z with a length of '',F10.3,'' cm.'')') SZ 1 489 P=CELL D=MAPPRT 3 PAGE 698 123 - ELSE 124 - WRITE(LUNOUT,'('' The cell has no translation'', 125 - - '' periodicity in z.'')') 126 - ENDIF 127 - IF(PERAZ)THEN 128 - WRITE(LUNOUT,'('' The cell has axial periodicity'', 129 - - '' around the z-axis of '',F10.1, 130 - - '' degrees.'')') (ZAMAX-ZAMIN)*180/PI 131 - ELSEIF(PERRZ)THEN 132 - WRITE(LUNOUT,'('' The cell is rotationally'', 133 - - '' symmetric around the z-axis.'')') 134 - ELSE 135 - WRITE(LUNOUT,'('' The cell has no axial periodicity'', 136 - - '' around the z-axis.'')') 137 - ENDIF 138 - *** List the materials. 139 - IF(NEPS.GE.1)THEN 140 - IF(MAPTYP.GT.10.AND.MATSRC.EQ.'SIGMA')THEN 141 - WRITE(LUNOUT,'(/'' There are '',I5,'' materials'', 142 - - '' which differ by conducivity: ''/ 143 - - '' Index Sigma [S/m] Volume [cm3]'')') 144 - - NEPS 145 - ELSEIF(MAPTYP.GT.10)THEN 146 - WRITE(LUNOUT,'(/'' There are '',I5,'' materials'', 147 - - '' which differ by dielectric constant: ''/ 148 - - '' Index Epsilon Volume [cm3]'')') 149 - - NEPS 150 - ELSEIF(MATSRC.EQ.'SIGMA')THEN 151 - WRITE(LUNOUT,'(/'' There are '',I5,'' materials'', 152 - - '' which differ by conducivity: ''/ 153 - - '' Index Sigma [S/m] Surface [cm2]'')') 154 - - NEPS 155 - ELSE 156 - WRITE(LUNOUT,'(/'' There are '',I5,'' materials'', 157 - - '' which differ by dielectric constant: ''/ 158 - - '' Index Epsilon Surface [cm2]'')') 159 - - NEPS 160 - ENDIF 161 - DO 70 I=1,NEPS 162 - IF(MATSRC.EQ.'SIGMA')THEN 163 - IF(I.EQ.IDRMAT)THEN 164 - WRITE(LUNOUT,'('' '',I5,2X,E12.5,2X,E15.8, 165 - - '' (drift medium)'')') 166 - - I,EPSMAT(I),EPSSUR(I) 167 - ELSE 168 - WRITE(LUNOUT,'('' '',I5,2X,E12.5,2X,E15.8)') 169 - - I,EPSMAT(I),EPSSUR(I) 170 - ENDIF 171 - ELSE 172 - IF(I.EQ.IDRMAT)THEN 173 - WRITE(LUNOUT,'('' '',I5,2X,F12.3,2X,E15.8, 174 - - '' (drift medium)'')') 175 - - I,EPSMAT(I),EPSSUR(I) 176 - ELSE 177 - WRITE(LUNOUT,'('' '',I5,2X,F12.3,2X,E15.8)') 178 - - I,EPSMAT(I),EPSSUR(I) 179 - ENDIF 180 - ENDIF 181 - 70 CONTINUE 182 - ELSE 183 - WRITE(LUNOUT,'(/'' No material properties available.'')') 184 - ENDIF 185 - *** Print the interpolation order. 186 - IF(MAPORD.EQ.1)THEN 187 - WRITE(LUNOUT,'(/'' The field maps will be interpolated'', 188 - - '' linearly.'')') 189 - ELSEIF(MAPORD.EQ.2)THEN 190 - WRITE(LUNOUT,'(/'' The field maps will be interpolated'', 191 - - '' quadratically.'')') 192 - ELSE 193 - WRITE(LUNOUT,'(/'' The field maps will be interpolated'', 194 - - '' to order '',I2,''.'')') MAPORD 195 - ENDIF 196 - END 490 GARFIELD ================================================== P=OPTIMISE D= 1 ============================ 0 + +PATCH,OPTIMISE. 491 GARFIELD ================================================== P=OPTIMISE D=OPTADD 1 ============================ 0 + +DECK,OPTADD. 1 - SUBROUTINE OPTADD(CHANGE) 2 - *----------------------------------------------------------------------- 3 - * OPTADD - This routine adds items to the cell. 4 - * (Last changed on 29/11/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,CONSTANTS. 10.- +SEQ,CELLDATA. 11 - CHARACTER*(MXCHAR) STRING 12 - CHARACTER WIRCDE 13 - INTEGER INPCMP,INPTYP,NWORD,I,J,INEXT,IDIR,ICSET,IXYSET, 14 - - IVSET,IFAIL,IFAIL1,IFAIL2,NC 15 - REAL S,COOR,VOLT,XWIR,YWIR,DWIR,VWIR,UWIR,WWIR,DENWIR 16 - EXTERNAL INPCMP,INPTYP 17 - LOGICAL CHANGE 18 - *** Assume no change at first. 19 - CHANGE=.FALSE. 20 - *** Pick up the number of arguments. 21 - CALL INPNUM(NWORD) 22 - IF(NWORD.LE.1)THEN 23 - PRINT *,' !!!!!! OPTADD WARNING : You must specify which'// 24 - - ' items you wish to add; cell not changed.' 1 491 P=OPTIMISE D=OPTADD 2 PAGE 699 25 - RETURN 26 - ENDIF 27 - *** Loop over the arguments. 28 - INEXT=2 29 - DO 10 I=2,NWORD 30 - IF(I.LT.INEXT)GOTO 10 31 - ** Add a periodicity. 32 - IF(INPCMP(I,'PE#RIODICITY').NE.0)THEN 33 - * Check there are arguments. 34 - IF(I+2.LT.NWORD)THEN 35 - CALL INPMSG(I,'Should have two arguments. ') 36 - GOTO 10 37 - ENDIF 38 - * Initialise the direction and length. 39 - IDIR=0 40 - S=-1.0 41 - * Check the coordinate system and reject r periodicities. 42 - IF(INPCMP(I+1,'X')+INPCMP(I+1,'Y').NE.0.AND.POLAR)THEN 43 - CALL INPMSG(I+1,'Only polar elements permitted.') 44 - INEXT=I+2 45 - GOTO 10 46 - ELSEIF(INPCMP(I+1,'PHI').NE.0.AND..NOT.POLAR)THEN 47 - CALL INPMSG(I+1,'No polar elements permitted. ') 48 - INEXT=I+2 49 - GOTO 10 50 - ELSEIF(INPCMP(I+1,'R').NE.0)THEN 51 - CALL INPMSG(I+1,'No radial periods permitted. ') 52 - INEXT=I+3 53 - GOTO 10 54 - ENDIF 55 - * Read the length. 56 - IF(INPCMP(I+1,'X')+INPCMP(I+1,'Y')+ 57 - - INPCMP(I+1,'PHI').NE.0)THEN 58 - CALL INPCHK(I+2,2,IFAIL) 59 - IF(IFAIL.NE.0)THEN 60 - INEXT=I+3 61 - GOTO 10 62 - ENDIF 63 - CALL INPRDR(I+2,S,-1.0) 64 - IF(S.LE.0.0)CALL INPMSG(I+2, 65 - - 'The length must be > 0. ') 66 - ENDIF 67 - * Store the period direction. 68 - IF(INPCMP(I+1,'X').NE.0)THEN 69 - IDIR=1 70 - ELSEIF(INPCMP(I+1,'Y').NE.0)THEN 71 - IDIR=2 72 - ELSEIF(INPCMP(I+1,'PHI').NE.0)THEN 73 - IDIR=4 74 - ELSEIF(INPCMP(I+1,'PE#RIODICITY')+INPCMP(I+1,'PL#ANE')+ 75 - - INPCMP(I+1,'W#IRE').NE.0)THEN 76 - CALL INPMSG(I,'Should have two arguments. ') 77 - INEXT=I+1 78 - GOTO 10 79 - ELSE 80 - CALL INPMSG(I+1,'Not a valid period direction. ') 81 - INEXT=I+1 82 - GOTO 10 83 - ENDIF 84 - * Check the data and update the cell. 85 - IF(IDIR.EQ.0.OR.S.LE.0.0)THEN 86 - CALL INPMSG(I,'Not a valid specification. ') 87 - ELSEIF(IDIR.EQ.1)THEN 88 - IF(PERX)PRINT *,' !!!!!! OPTADD WARNING :'// 89 - - ' Previous x periodicity overridden.' 90 - CHANGE=.TRUE. 91 - PERX=.TRUE. 92 - SX=S 93 - ELSEIF(IDIR.EQ.2)THEN 94 - IF(PERY)PRINT *,' !!!!!! OPTADD WARNING :'// 95 - - ' Previous y periodicity overridden.' 96 - CHANGE=.TRUE. 97 - PERY=.TRUE. 98 - SY=S 99 - ELSEIF(IDIR.EQ.4)THEN 100 - IF(PERY)PRINT *,' !!!!!! OPTADD WARNING :'// 101 - - ' Previous phi periodicity overridden.' 102 - IF(ABS(360.0-S*ANINT(360.0/S)).GT.1.0E-4)PRINT *, 103 - - ' !!!!!! OPTADD WARNING : The phi period is'// 104 - - ' rounded so that it divides 360.' 105 - CHANGE=.TRUE. 106 - PERY=.TRUE. 107 - SY=2*PI*ANINT(360.0/S) 108 - ENDIF 109 - * Skip the words that were read. 110 - INEXT=I+3 111 - ** Add a plane. 112 - ELSEIF(INPCMP(I,'PL#ANE').NE.0)THEN 113 - * Initialise the direction and coordinate. 114 - IDIR=0 115 - COOR=0.0 116 - ICSET=0 117 - VOLT=0.0 118 - WIRCDE=' ' 119 - * Read the specified direction and length. 120 - DO 40 J=I+1,NWORD-1 121 - IF(J.LT.INEXT)GOTO 40 122 - * Trivial errors. 123 - IF(INPCMP(J,'R')+INPCMP(J,'PHI').NE.0.AND..NOT.POLAR)THEN 124 - CALL INPMSG(J,'No polar planes are permitted.') 125 - INEXT=J+1 126 - GOTO 40 127 - ELSEIF(INPCMP(J,'X')+INPCMP(J,'Y').NE.0.AND.POLAR)THEN 128 - CALL INPMSG(J,'Only polar planes permitted. ') 129 - INEXT=J+1 130 - GOTO 40 1 491 P=OPTIMISE D=OPTADD 3 PAGE 700 131 - ENDIF 132 - * Pick up the direction, if it is one. 133 - IF(INPCMP(J,'X').NE.0)THEN 134 - IDIR=1 135 - ELSEIF(INPCMP(J,'Y').NE.0)THEN 136 - IDIR=2 137 - ELSEIF(INPCMP(J,'R').NE.0)THEN 138 - IDIR=3 139 - ELSEIF(INPCMP(J,'PHI').NE.0)THEN 140 - IDIR=4 141 - ENDIF 142 - * Pick up the position or the potential. 143 - IF(INPCMP(J,'R')+INPCMP(J,'PHI')+ 144 - - INPCMP(J,'X')+INPCMP(J,'Y').NE.0)THEN 145 - CALL INPCHK(J+1,2,IFAIL) 146 - CALL INPRDR(J+1,COOR,0.0) 147 - INEXT=J+2 148 - IF(INPCMP(J,'R').NE.0.AND.COOR.LE.0.0.AND. 149 - - IFAIL.EQ.0)THEN 150 - CALL INPMSG(J+1,'Radial coordinate must be > 0.') 151 - GOTO 10 152 - ENDIF 153 - ICSET=1 154 - ELSEIF(INPCMP(J,'V#OLTAGE').NE.0)THEN 155 - CALL INPCHK(J+1,2,IFAIL) 156 - CALL INPRDR(J+1,VOLT,0.0) 157 - INEXT=J+2 158 - * Labels. 159 - ELSEIF(INPCMP(J,'LAB#EL').NE.0)THEN 160 - CALL INPSTR(J+1,J+1,STRING,NC) 161 - WIRCDE=STRING(1:1) 162 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',WIRCDE).EQ. 163 - - 0)THEN 164 - CALL INPMSG(J+1,'The label must be a letter.') 165 - GOTO 10 166 - ENDIF 167 - INEXT=J+2 168 - * Other keywords. 169 - ELSEIF(INPCMP(J,'PE#RIODICITY')+INPCMP(J,'PL#ANE')+ 170 - - INPCMP(J,'W#IRE').NE.0)THEN 171 - GOTO 50 172 - ELSE 173 - CALL INPMSG(J,'Neither a V nor a direction. ') 174 - INEXT=J+1 175 - ENDIF 176 - 40 CONTINUE 177 - * Check the data and store the plane. 178 - 50 CONTINUE 179 - IF(IDIR.EQ.0.OR.ICSET.EQ.0)THEN 180 - CALL INPMSG(I,'Not a valid specification. ') 181 - ELSEIF(IDIR.EQ.1.OR.IDIR.EQ.3)THEN 182 - IF(IDIR.EQ.3)COOR=LOG(COOR) 183 - IF(.NOT.YNPLAN(1))THEN 184 - YNPLAN(1)=.TRUE. 185 - COPLAN(1)=COOR 186 - VTPLAN(1)=VOLT 187 - PLATYP(1)=WIRCDE 188 - INDPLA(1)=0 189 - NPSTR1(1)=0 190 - NPSTR2(1)=0 191 - CHANGE=.TRUE. 192 - ELSEIF(.NOT.YNPLAN(2))THEN 193 - YNPLAN(2)=.TRUE. 194 - COPLAN(2)=COOR 195 - VTPLAN(2)=VOLT 196 - PLATYP(2)=WIRCDE 197 - INDPLA(2)=0 198 - NPSTR1(2)=0 199 - NPSTR2(2)=0 200 - CHANGE=.TRUE. 201 - ELSE 202 - CALL INPMSG(I,'No room for further planes. ') 203 - ENDIF 204 - ELSEIF(IDIR.EQ.2.OR.IDIR.EQ.4)THEN 205 - IF(IDIR.EQ.3)COOR=PI*COOR/180.0 206 - IF(.NOT.YNPLAN(3))THEN 207 - YNPLAN(3)=.TRUE. 208 - COPLAN(3)=COOR 209 - VTPLAN(3)=VOLT 210 - PLATYP(3)=WIRCDE 211 - INDPLA(3)=0 212 - NPSTR1(3)=0 213 - NPSTR2(3)=0 214 - CHANGE=.TRUE. 215 - ELSEIF(.NOT.YNPLAN(4))THEN 216 - YNPLAN(4)=.TRUE. 217 - COPLAN(4)=COOR 218 - VTPLAN(4)=VOLT 219 - PLATYP(4)=WIRCDE 220 - INDPLA(4)=0 221 - NPSTR1(4)=0 222 - NPSTR2(4)=0 223 - CHANGE=.TRUE. 224 - ELSE 225 - CALL INPMSG(I,'No room for further planes. ') 226 - ENDIF 227 - ENDIF 228 - ** Add a wire. 229 - ELSEIF(INPCMP(I,'W#IRE').NE.0)THEN 230 - * Initialise wire-code, diameter, position and potential. 231 - WIRCDE='?' 232 - XWIR=0.0 233 - YWIR=0.0 234 - IXYSET=0 235 - VWIR=0.0 236 - IVSET=0 1 491 P=OPTIMISE D=OPTADD 4 PAGE 701 237 - DWIR=0.0100 238 - UWIR=100.0 239 - WWIR=50.0 240 - DENWIR=19.3 241 - * Loop over the keywords. 242 - DO 70 J=I+1,NWORD 243 - IF(J.LT.INEXT)GOTO 70 244 - * Wire position. 245 - IF(INPCMP(J,'AT').NE.0)THEN 246 - IF(J+2.GT.NWORD.OR.INPTYP(J+1).LE.0.OR. 247 - - INPTYP(J+2).LE.0)THEN 248 - CALL INPMSG(I,'Needs two numeric arguments. ') 249 - IF(INPTYP(J+1).LE.0)THEN 250 - INEXT=J+1 251 - ELSEIF(INPTYP(J+2).LE.0)THEN 252 - INEXT=J+2 253 - ELSE 254 - INEXT=J+3 255 - ENDIF 256 - GOTO 70 257 - ENDIF 258 - CALL INPCHK(J+1,2,IFAIL1) 259 - CALL INPCHK(J+2,2,IFAIL2) 260 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN 261 - CALL INPRDR(J+1,XWIR,0.0) 262 - CALL INPRDR(J+2,YWIR,0.0) 263 - IF(POLAR.AND.XWIR.LE.0.0)THEN 264 - CALL INPMSG(J+1, 265 - - 'Invalid polar coordinate. ') 266 - ELSE 267 - IXYSET=1 268 - ENDIF 269 - ENDIF 270 - INEXT=J+3 271 - * Wire potential. 272 - ELSEIF(INPCMP(J,'V#OLTAGE').NE.0)THEN 273 - IF(J+1.GT.NWORD.OR.INPTYP(J+1).LE.0)THEN 274 - CALL INPMSG(I,'Needs one numeric argument. ') 275 - IF(INPTYP(J+1).LE.0)THEN 276 - INEXT=J+1 277 - ELSE 278 - INEXT=J+2 279 - ENDIF 280 - GOTO 70 281 - ENDIF 282 - CALL INPCHK(J+1,2,IFAIL1) 283 - IF(IFAIL1.EQ.0)THEN 284 - CALL INPRDR(J+1,VWIR,0.0) 285 - IVSET=1 286 - ENDIF 287 - INEXT=J+2 288 - * Wire label. 289 - ELSEIF(INPCMP(J,'TYP#E')+INPCMP(J,'LAB#EL').NE.0)THEN 290 - IF(J+1.GT.NWORD)THEN 291 - CALL INPMSG(J,'Has one character as argument.') 292 - INEXT=J+1 293 - GOTO 70 294 - ENDIF 295 - CALL INPSTR(J+1,J+1,STRING,NC) 296 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ', 297 - - STRING(1:1)).EQ.0)THEN 298 - CALL INPMSG(J+1,'Non-alphabetic first character') 299 - ELSE 300 - WIRCDE=STRING(1:1) 301 - ENDIF 302 - INEXT=J+2 303 - * Wire diameter. 304 - ELSEIF(INPCMP(J,'D#IAMETER').NE.0)THEN 305 - IF(J+1.GT.NWORD.OR.INPTYP(J+1).LE.0)THEN 306 - CALL INPMSG(I,'Needs one numeric argument. ') 307 - IF(INPTYP(J+1).LE.0)THEN 308 - INEXT=J+1 309 - ELSE 310 - INEXT=J+2 311 - ENDIF 312 - GOTO 70 313 - ENDIF 314 - CALL INPCHK(J+1,2,IFAIL1) 315 - IF(IFAIL1.EQ.0)THEN 316 - CALL INPRDR(J+1,DWIR,0.01) 317 - IF(DENWIR.LE.0)CALL INPMSG(J+1, 318 - - 'The diameter must be > 0.') 319 - ENDIF 320 - INEXT=J+2 321 - * Density. 322 - ELSEIF(INPCMP(J,'DENS#ITY')+INPCMP(J,'MAT#ERIAL').NE.0)THEN 323 - IF(J+1.GT.NWORD)THEN 324 - CALL INPMSG(J,'Has an argument.') 325 - INEXT=J+1 326 - ELSEIF(INPCMP(J+1,'CU-BE#RYLLIUM')+ 327 - - INPCMP(J+1,'C#OPPER-BE#RYLLIUM')+ 328 - - INPCMP(J+1,'BE#RYLLIUM-#CU')+ 329 - - INPCMP(J+1,'BE#RYLLIUM-#COPPER').NE.0)THEN 330 - DENWIR=8.7 331 - INEXT=J+2 332 - ELSEIF(INPTYP(J+1).EQ.4.OR.INPCMP(J+1,'W')+ 333 - - INPCMP(J+1,'TUNG#STEN').NE.0)THEN 334 - DENWIR=19.3 335 - INEXT=J+2 336 - ELSEIF(INPTYP(J+1).EQ.1.OR.INPTYP(J+1).EQ.2)THEN 337 - CALL INPCHK(J+1,2,IFAIL1) 338 - CALL INPRDR(J+1,DENWIR,19.3) 339 - IF(DENWIR.LE.0)CALL INPMSG(J+1, 340 - - 'The density must be > 0.') 341 - INEXT=J+2 342 - ELSE 1 491 P=OPTIMISE D=OPTADD 5 PAGE 702 343 - CALL INPMSG(J+1,'Not a valid argument.') 344 - INEXT=J+2 345 - ENDIF 346 - * Length. 347 - ELSEIF(INPCMP(J,'L#ENGTH').NE.0)THEN 348 - IF(J+1.GT.NWORD.OR.INPTYP(J+1).LE.0)THEN 349 - CALL INPMSG(I,'Needs one numeric argument. ') 350 - IF(INPTYP(J+1).LE.0)THEN 351 - INEXT=J+1 352 - ELSE 353 - INEXT=J+2 354 - ENDIF 355 - GOTO 70 356 - ENDIF 357 - CALL INPCHK(J+1,2,IFAIL1) 358 - IF(IFAIL1.EQ.0)THEN 359 - CALL INPRDR(J+1,UWIR,100.0) 360 - IF(UWIR.LE.0)CALL INPMSG(J+1, 361 - - 'The length must be > 0.') 362 - ENDIF 363 - INEXT=J+2 364 - * Weight. 365 - ELSEIF(INPCMP(J,'W#EIGHT')+INPCMP(J,'TENS#ION').NE.0)THEN 366 - IF(J+1.GT.NWORD.OR.INPTYP(J+1).LE.0)THEN 367 - CALL INPMSG(I,'Needs one numeric argument. ') 368 - IF(INPTYP(J+1).LE.0)THEN 369 - INEXT=J+1 370 - ELSE 371 - INEXT=J+2 372 - ENDIF 373 - GOTO 70 374 - ENDIF 375 - CALL INPCHK(J+1,2,IFAIL1) 376 - IF(IFAIL1.EQ.0)THEN 377 - CALL INPRDR(J+1,WWIR,50.0) 378 - IF(WWIR.LE.0)CALL INPMSG(J+1, 379 - - 'The weight must be > 0.') 380 - ENDIF 381 - INEXT=J+2 382 - * Back to main category. 383 - ELSEIF(INPCMP(J,'PE#RIODICITY')+INPCMP(J,'PL#ANE')+ 384 - - INPCMP(J,'W#IRE').NE.0)THEN 385 - GOTO 80 386 - * Unrecognised keyword. 387 - ELSE 388 - CALL INPMSG(J,'Not a valid keyword.') 389 - ENDIF 390 - 70 CONTINUE 391 - * Check whether sufficient data were provided. 392 - 80 CONTINUE 393 - IF(IXYSET.EQ.0.OR.WIRCDE.EQ.'?')THEN 394 - CALL INPMSG(I,'Incompletely specified wire.') 395 - ELSEIF(DWIR.LE.0.OR.UWIR.LE.0.OR.WWIR.LE.0.OR. 396 - - DENWIR.LE.0)THEN 397 - CALL INPMSG(I,'Invalid wire specification.') 398 - ELSEIF(NWIRE.GE.MXWIRE)THEN 399 - CALL INPMSG(I,'No room for further wires.') 400 - ELSE 401 - NWIRE=NWIRE+1 402 - X(NWIRE)=XWIR 403 - Y(NWIRE)=YWIR 404 - V(NWIRE)=VWIR 405 - D(NWIRE)=DWIR 406 - U(NWIRE)=UWIR 407 - W(NWIRE)=WWIR 408 - DENS(NWIRE)=DENWIR 409 - WIRTYP(NWIRE)=WIRCDE 410 - INDSW(NWIRE)=0 411 - IF(POLAR)THEN 412 - D(NWIRE)=D(NWIRE)/X(NWIRE) 413 - CALL CFMPTR(X(NWIRE),Y(NWIRE),X(NWIRE),Y(NWIRE),1, 414 - - IFAIL1) 415 - IF(IFAIL1.NE.0)THEN 416 - CALL INPMSG(I, 417 - - 'Invalid polar position. ') 418 - NWIRE=NWIRE-1 419 - ENDIF 420 - ENDIF 421 - CHANGE=.TRUE. 422 - ENDIF 423 - ** Unrecognised argument. 424 - ELSE 425 - CALL INPMSG(I,'Not PERIOD, PLANE or WIRE. ') 426 - ENDIF 427 - 10 CONTINUE 428 - CALL INPERR 429 - END 492 GARFIELD ================================================== P=OPTIMISE D=OPTBGF 1 ============================ 0 + +DECK,OPTBGF. 1 - SUBROUTINE OPTBGF 2 - *----------------------------------------------------------------------- 3 - * OPTBGF - Adds a background field. 4 - * (Last changed on 5/ 4/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,PRINTPLOT. 10 - CHARACTER*(MXCHAR) STRV,STREX,STREY,STREZ 11 - CHARACTER*10 VARLIS(MXVAR),USER 12 - INTEGER NWORD,I,INEXT,INPCMP,NVAR,NCFV,NCFEX,NCFEY,NCFEZ,NRES, 13 - - IFAIL1 14 - LOGICAL USE(MXVAR),OK 15 - EXTERNAL INPCMP 1 492 P=OPTIMISE D=OPTBGF 2 PAGE 703 16-+ +SELF,IF=SAVE. 17 - SAVE STRV,STREX,STREY,STREZ,NCFV,NCFEX,NCFEY,NCFEZ 0 18-+ +SELF. 19 - DATA NCFV,NCFEX,NCFEY,NCFEZ /0,0,0,0/ 20 - *** Identify the routine. 21 - IF(LIDENT)PRINT *,' /// ROUTINE OPTBGF ///' 22 - *** Count words. 23 - CALL INPNUM(NWORD) 24 - *** Display current state if there are no arguments. 25 - IF(NWORD.EQ.1)THEN 26 - IF(IENBGF.LE.0)THEN 27 - WRITE(LUNOUT,'('' Currently no background field.'')') 28 - ELSE 29 - WRITE(LUNOUT,'('' Currently the background field'', 30 - - '' is:''//'' potential: '',A/'' Ex: '', 31 - - A/'' Ey: '',A/'' Ez: '',A)') 32 - - STRV(1:MAX(1,NCFV)),STREX(1:MAX(1,NCFEX)), 33 - - STREY(1:MAX(1,NCFEY)),STREZ(1:MAX(1,NCFEZ)) 34 - ENDIF 35 - RETURN 36 - ENDIF 37 - *** Set the list of variables. 38 - IF(POLAR)THEN 39 - VARLIS(1)='R' 40 - VARLIS(2)='PHI' 41 - VARLIS(3)='Z' 42 - VARLIS(4)='EXMAP' 43 - VARLIS(5)='EYMAP' 44 - VARLIS(6)='EZMAP' 45 - VARLIS(7)='VMAP' 46 - ELSE 47 - VARLIS(1)='X' 48 - VARLIS(2)='Y' 49 - VARLIS(3)='Z' 50 - VARLIS(4)='EXMAP' 51 - VARLIS(5)='EYMAP' 52 - VARLIS(6)='EZMAP' 53 - VARLIS(7)='VMAP' 54 - ENDIF 55 - NVAR=7 56 - *** Preset the strings. 57 - STRV=' ' 58 - NCFV=0 59 - STREX=' ' 60 - NCFEX=0 61 - STREY=' ' 62 - NCFEY=0 63 - STREZ=' ' 64 - NCFEZ=0 65 - *** Delete old entry points if present. 66 - IF(IENBGF.NE.0)CALL ALGCLR(IENBGF) 67 - IENBGF=0 68 - LBGFMP=.FALSE. 69 - *** Loop over the components. 70 - OK=.TRUE. 71 - INEXT=2 72 - DO 10 I=2,NWORD 73 - IF(I.LT.INEXT)GOTO 10 74 - *** Pick up the field components. 75 - IF(INPCMP(I,'V#OLTAGE')+INPCMP(I,'POT#ENTIAL').NE.0)THEN 76 - CALL INPSTR(I+1,I+1,STRV,NCFV) 77 - INEXT=I+2 78 - ELSEIF(INPCMP(I,'EX').NE.0)THEN 79 - CALL INPSTR(I+1,I+1,STREX,NCFEX) 80 - INEXT=I+2 81 - ELSEIF(INPCMP(I,'EY').NE.0)THEN 82 - CALL INPSTR(I+1,I+1,STREY,NCFEY) 83 - INEXT=I+2 84 - ELSEIF(INPCMP(I,'EZ').NE.0)THEN 85 - CALL INPSTR(I+1,I+1,STREZ,NCFEZ) 86 - INEXT=I+2 87 - ELSE 88 - CALL INPMSG(I,'Not a known field.') 89 - OK=.FALSE. 90 - ENDIF 91 - 10 CONTINUE 92 - *** Dump error messages. 93 - CALL INPERR 94 - *** Check that all fields are present. 95 - IF(NCFV.LE.0)THEN 96 - PRINT *,' ------ OPTBGF MESSAGE : Potential of the'// 97 - - ' background field is missing; set to 0.' 98 - STRV='0' 99 - NCFV=1 100 - OK=.FALSE. 101 - ENDIF 102 - IF(NCFEX.LE.0)THEN 103 - PRINT *,' ------ OPTBGF MESSAGE : Ex of the'// 104 - - ' background field is missing; set to 0.' 105 - STREX='0' 106 - NCFEX=1 107 - OK=.FALSE. 108 - ENDIF 109 - IF(NCFEY.LE.0)THEN 110 - PRINT *,' ------ OPTBGF MESSAGE : Ey of the'// 111 - - ' background field is missing; set to 0.' 112 - STREY='0' 113 - NCFEY=1 114 - OK=.FALSE. 115 - ENDIF 116 - IF(NCFEZ.LE.0)THEN 117 - PRINT *,' ------ OPTBGF MESSAGE : Ez of the'// 118 - - ' background field is missing; set to 0.' 119 - STREZ='0' 120 - NCFEZ=1 1 492 P=OPTIMISE D=OPTBGF 3 PAGE 704 121 - ENDIF 122 - *** See whether we continue. 123 - IF(JFAIL.EQ.2.AND..NOT.OK)THEN 124 - PRINT *,' ###### OPTBGF ERROR : No background field'// 125 - - ' because of the above errors.' 126 - IENBGF=0 127 - RETURN 128 - ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN 129 - PRINT *,' ###### OPTBGF ERROR : Program terminated'// 130 - - ' because of the above errors.' 131 - CALL QUIT 132 - RETURN 133 - ENDIF 134 - *** Reset the error flag. 135 - OK=.TRUE. 136 - *** Translate the background field. 137 - IF(INDEX(STRV(1:NCFV)//','//STREX(1:NCFEX)//','//STREY(1:NCFEY) 138 - - //','//STREZ(1:NCFEZ),'@').NE.0)THEN 139 - NRES=4 140 - PRINT *,' ------ OPTBGF MESSAGE : Please edit the'// 141 - - ' function.' 142 - CALL ALGEDT(VARLIS,NVAR,IENBGF,USE,NRES) 143 - IFAIL1=0 144 - * Usual function translation if not. 145 - ELSE 146 - CALL ALGPRE(STRV(1:NCFV)//','//STREX(1:NCFEX)//','// 147 - - STREY(1:NCFEY)//','//STREZ(1:NCFEZ), 148 - - NCFV+NCFEX+NCFEY+NCFEZ+3,VARLIS,NVAR,NRES,USE, 149 - - IENBGF,IFAIL1) 150 - ENDIF 151 - * Check return code of translation. 152 - IF(IFAIL1.NE.0)THEN 153 - PRINT *,' !!!!!! OPTBGF WARNING : Error translating the'// 154 - - ' field functions.' 155 - OK=.FALSE. 156 - CALL ALGCLR(IENBGF) 157 - ENDIF 158 - * Check number of results returned by the function. 159 - IF(NRES.NE.4)THEN 160 - PRINT *,' !!!!!! OPTBGF WARNING : The field functions do'// 161 - - ' not return 4 results.' 162 - OK=.FALSE. 163 - CALL ALGCLR(IENBGF) 164 - ENDIF 165 - * Check use of field map. 166 - IF(USE(4).OR.USE(5).OR.USE(6).OR.USE(7))THEN 167 - CALL BOOK('INQUIRE','MAP',USER,IFAIL1) 168 - IF(IFAIL1.NE.0)THEN 169 - PRINT *,' !!!!!! OPTBGF WARNING : Unable to'// 170 - - ' find out who owns the field map; background'// 171 - - ' field rejected.' 172 - OK=.FALSE. 173 - CALL ALGCLR(IENBGF) 174 - ELSEIF(USER.EQ.'CELL')THEN 175 - PRINT *,' !!!!!! OPTBGF WARNING : Field map is used'// 176 - - ' as main field; background field rejected.' 177 - OK=.FALSE. 178 - CALL ALGCLR(IENBGF) 179 - ELSEIF(USER.NE.'OPTIMISE')THEN 180 - PRINT *,' !!!!!! OPTBGF WARNING : No background'// 181 - - ' field map available ; background field'// 182 - - ' rejected.' 183 - OK=.FALSE. 184 - CALL ALGCLR(IENBGF) 185 - ELSEIF(POLAR)THEN 186 - PRINT *,' !!!!!! OPTBGF WARNING : Background fields'// 187 - - ' no available in polar cells; background field'// 188 - - ' rejected.' 189 - OK=.FALSE. 190 - CALL ALGCLR(IENBGF) 191 - ELSE 192 - LBGFMP=.TRUE. 193 - ENDIF 194 - ENDIF 195 - *** See whether we continue. 196 - IF(JFAIL.EQ.2.AND..NOT.OK)THEN 197 - PRINT *,' ###### OPTBGF ERROR : No background field'// 198 - - ' because of the above errors.' 199 - IENBGF=0 200 - RETURN 201 - ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN 202 - PRINT *,' ###### OPTBGF ERROR : Program terminated'// 203 - - ' because of the above errors.' 204 - CALL QUIT 205 - RETURN 206 - ENDIF 207 - END 493 GARFIELD ================================================== P=OPTIMISE D=OPTCHV 1 ============================ 0 + +DECK,OPTCHV. 1 - SUBROUTINE OPTCHV 2 - *----------------------------------------------------------------------- 3 - * OPTCHV - Changes voltages. 4 - * (Last changed on 20/10/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,CELLDATA. 10 - INTEGER INPCMP,INPTYP,I,J,NWORD,INEXT,IWIRE,IFAIL,IFAIL1,IFAIL2, 11 - - NC,IPLANE,NFOUND 12 - REAL VNEW(MXWIRE),VPLNEW(5),VREAD 13 - CHARACTER*(MXCHAR) CODE 14 - LOGICAL OK 15 - EXTERNAL INPCMP,INPTYP 1 493 P=OPTIMISE D=OPTCHV 2 PAGE 705 16 - *** Original settings for wires, planes and tube. 17 - DO 20 I=1,NWIRE 18 - VNEW(I)=V(I) 19 - 20 CONTINUE 20 - DO 30 I=1,4 21 - VPLNEW(I)=VTPLAN(I) 22 - 30 CONTINUE 23 - VPLNEW(5)=VTTUBE 24 - *** Decode the argument string. 25 - CALL INPNUM(NWORD) 26 - * Check there are at least some words on the line. 27 - IF(NWORD.LE.1)THEN 28 - PRINT *,' !!!!!! OPTCHV WARNING : This instruction needs'// 29 - - ' arguments; nothing done.' 30 - RETURN 31 - ENDIF 32 - ** Keep track of errors. 33 - OK=.TRUE. 34 - ** Loop over the arguments. 35 - INEXT=2 36 - DO 10 I=1,NWORD 37 - IF(I.LT.INEXT)GOTO 10 38 - ** Wire selection. 39 - IF(INPCMP(I,'W#IRE').NE.0)THEN 40 - * Ensure the wire is specified. 41 - IF(NWORD.LT.I+1)THEN 42 - CALL INPMSG(I,'The wire should be specified.') 43 - IWIRE=0 44 - * Read the wire number. 45 - ELSEIF(INPTYP(I+1).EQ.1)THEN 46 - CALL INPCHK(I+1,1,IFAIL1) 47 - IF(IFAIL1.EQ.0)THEN 48 - CALL INPRDI(I+1,IWIRE,0) 49 - IF(IWIRE.LE.0.OR.IWIRE.GT.NWIRE)THEN 50 - CALL INPMSG(I+1,'Wire number out of range.') 51 - IWIRE=0 52 - OK=.FALSE. 53 - ENDIF 54 - ELSE 55 - IWIRE=0 56 - ENDIF 57 - * Read the wire code. 58 - ELSE 59 - CALL INPSTR(I+1,I+1,CODE,NC) 60 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',CODE(1:1)) 61 - - .EQ.0)THEN 62 - CALL INPMSG(I+1,'Not a valid wire code.') 63 - OK=.FALSE. 64 - IWIRE=0 65 - ELSE 66 - IWIRE=-1 67 - ENDIF 68 - IF(NC.GT.1) 69 - - CALL INPMSG(I+1,'Only first character used. ') 70 - ENDIF 71 - ** Read the new voltage. 72 - IF(INPCMP(I+2,'V#OLTAGE').EQ.0.OR.NWORD.LT.I+3)THEN 73 - CALL INPMSG(I,'The voltage is missing.') 74 - OK=.FALSE. 75 - INEXT=I+2 76 - GOTO 10 77 - ELSE 78 - CALL INPCHK(I+3,2,IFAIL2) 79 - CALL INPRDR(I+3,VREAD,0.0) 80 - ENDIF 81 - * Store the result in the proper location. 82 - IF(IWIRE.GT.0.AND.IWIRE.LE.NWIRE)THEN 83 - VNEW(IWIRE)=VREAD 84 - ELSEIF(IWIRE.EQ.-1)THEN 85 - NFOUND=0 86 - DO 40 J=1,NWIRE 87 - IF(WIRTYP(J).EQ.CODE(1:1))THEN 88 - VNEW(J)=VREAD 89 - NFOUND=NFOUND+1 90 - ENDIF 91 - 40 CONTINUE 92 - IF(NFOUND.EQ.0)THEN 93 - CALL INPMSG(I+1,'No such wire.') 94 - OK=.FALSE. 95 - ENDIF 96 - ENDIF 97 - * And increment the word. 98 - INEXT=I+4 99 - ** Plane selection. 100 - ELSEIF(INPCMP(I,'PL#ANE').NE.0)THEN 101 - * Ensure the plane is specified. 102 - IF(NWORD.LT.I+1)THEN 103 - CALL INPMSG(I,'The plane should be specified.') 104 - IPLANE=0 105 - * Read the plane number. 106 - ELSEIF(INPTYP(I+1).EQ.1)THEN 107 - CALL INPCHK(I+1,1,IFAIL1) 108 - IF(IFAIL1.EQ.0)THEN 109 - CALL INPRDI(I+1,IPLANE,0) 110 - IPLANE=ABS(IPLANE) 111 - IF(IPLANE.LE.0.OR.IPLANE.GT.5)THEN 112 - CALL INPMSG(I+1,'Plane number out of range.') 113 - IPLANE=0 114 - OK=.FALSE. 115 - ENDIF 116 - ELSE 117 - IPLANE=0 118 - ENDIF 119 - * Plane selection by name. 120 - ELSEIF(INPCMP(I+1,'LOW#ER-X')+INPCMP(I+1,'L#EFT').NE.0)THEN 121 - IF(.NOT.YNPLAN(1))THEN 1 493 P=OPTIMISE D=OPTCHV 3 PAGE 706 122 - CALL INPMSG(I+1,'No such plane.') 123 - OK=.FALSE. 124 - ELSE 125 - IPLANE=1 126 - ENDIF 127 - ELSEIF(INPCMP(I+1,'UP#PER-X')+INPCMP(I+1,'R#IGHT').NE.0)THEN 128 - IF(.NOT.YNPLAN(2))THEN 129 - CALL INPMSG(I+1,'No such plane.') 130 - OK=.FALSE. 131 - ELSE 132 - IPLANE=2 133 - ENDIF 134 - ELSEIF(INPCMP(I+1,'LOW#ER-Y')+ 135 - - INPCMP(I+1,'B#OTTOM').NE.0)THEN 136 - IF(.NOT.YNPLAN(3))THEN 137 - CALL INPMSG(I+1,'No such plane.') 138 - OK=.FALSE. 139 - ELSE 140 - IPLANE=3 141 - ENDIF 142 - ELSEIF(INPCMP(I+1,'UP#PER-X')+INPCMP(I+1,'T#OP').NE.0)THEN 143 - IF(.NOT.YNPLAN(4))THEN 144 - CALL INPMSG(I+1,'No such plane.') 145 - OK=.FALSE. 146 - ELSE 147 - IPLANE=4 148 - ENDIF 149 - ELSEIF(INPCMP(I+1,'TUBE').NE.0)THEN 150 - IF(.NOT.TUBE)THEN 151 - CALL INPMSG(I+1,'No tube in this cell.') 152 - OK=.FALSE. 153 - ELSE 154 - IPLANE=5 155 - ENDIF 156 - * Read the PLANE code. 157 - ELSE 158 - CALL INPSTR(I+1,I+1,CODE,NC) 159 - IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',CODE(1:1)) 160 - - .EQ.0)THEN 161 - CALL INPMSG(I+1,'Not a valid plane code.') 162 - IPLANE=0 163 - OK=.FALSE. 164 - ELSE 165 - IPLANE=-1 166 - ENDIF 167 - IF(NC.GT.1) 168 - - CALL INPMSG(I+1,'Only first character used.') 169 - ENDIF 170 - ** Read the new voltage. 171 - IF(INPCMP(I+2,'V#OLTAGE').EQ.0.OR.NWORD.LT.I+3)THEN 172 - CALL INPMSG(I,'The voltage is missing.') 173 - INEXT=I+2 174 - OK=.FALSE. 175 - GOTO 10 176 - ELSE 177 - CALL INPCHK(I+3,2,IFAIL2) 178 - CALL INPRDR(I+3,VREAD,0.0) 179 - ENDIF 180 - * Store the result in the proper location. 181 - IF(IPLANE.GE.1.AND.IPLANE.LE.5)THEN 182 - VPLNEW(IPLANE)=VREAD 183 - ELSEIF(IPLANE.EQ.-1)THEN 184 - NFOUND=0 185 - DO 50 J=1,5 186 - IF(PLATYP(J).EQ.CODE(1:1))THEN 187 - VPLNEW(J)=VREAD 188 - NFOUND=NFOUND+1 189 - ENDIF 190 - 50 CONTINUE 191 - IF(NFOUND.EQ.0)THEN 192 - CALL INPMSG(I+1,'No such plane.') 193 - OK=.FALSE. 194 - ENDIF 195 - ENDIF 196 - * And increment the word. 197 - INEXT=I+4 198 - ** Tube selection. 199 - ELSEIF(INPCMP(I,'TUBE').NE.0)THEN 200 - ** Read the new voltage. 201 - IF(INPCMP(I+1,'V#OLTAGE').EQ.0.OR.NWORD.LT.I+2)THEN 202 - CALL INPMSG(I,'The voltage is missing.') 203 - INEXT=I+1 204 - OK=.FALSE. 205 - GOTO 10 206 - ELSE 207 - CALL INPCHK(I+2,2,IFAIL2) 208 - CALL INPRDR(I+2,VREAD,0.0) 209 - ENDIF 210 - * Store the result in the proper location. 211 - IF(TUBE)THEN 212 - VPLNEW(5)=VREAD 213 - ELSE 214 - CALL INPMSG(I,'No tube in this cell.') 215 - OK=.FALSE. 216 - ENDIF 217 - * And increment the word. 218 - INEXT=I+3 219 - ** Valid keyword out of context. 220 - ELSEIF(INPCMP(I,'V#OLTAGE').NE.0)THEN 221 - CALL INPMSG(I,'Valid keyword out of context. ') 222 - OK=.FALSE. 223 - * Invalid keywords. 224 - ELSE 225 - CALL INPMSG(I,'Not a valid keyword. ') 226 - OK=.FALSE. 227 - ENDIF 1 493 P=OPTIMISE D=OPTCHV 4 PAGE 707 228 - 10 CONTINUE 229 - *** Dump error messages. 230 - CALL INPERR 231 - *** Take action depending on the state of OK. 232 - IF(.NOT.OK)THEN 233 - IF(JFAIL.EQ.1)THEN 234 - PRINT *,' !!!!!! OPTCHV WARNING : Errors found in'// 235 - - ' the command; performing a partial update.' 236 - ELSEIF(JFAIL.EQ.2)THEN 237 - PRINT *,' !!!!!! OPTCHV WARNING : Errors found in'// 238 - - ' the command; not changing any voltages.' 239 - RETURN 240 - ELSE 241 - PRINT *,' !!!!!! OPTCHV WARNING : Errors found in'// 242 - - ' the command; terminating program execution.' 243 - CALL QUIT 244 - ENDIF 245 - ENDIF 246 - *** Set new voltages. 247 - CALL SETNEW(VNEW,VPLNEW,IFAIL) 248 - IF(IFAIL.NE.0)THEN 249 - PRINT *,' ###### OPTCHV ERROR : Voltage change failed;'// 250 - - ' cell deleted.' 251 - CELSET=.FALSE. 252 - ENDIF 253 - END 494 GARFIELD ================================================== P=OPTIMISE D=OPTDEL 1 ============================ 0 + +DECK,OPTDEL. 1 - SUBROUTINE OPTDEL(CHANGE) 2 - *----------------------------------------------------------------------- 3 - * OPTDEL - This routine removes items from the cell. 4 - *----------------------------------------------------------------------- 5 - implicit none 6.- +SEQ,DIMENSIONS. 7.- +SEQ,PRINTPLOT. 8.- +SEQ,CELLDATA. 9 - INTEGER INPCMP 10 - EXTERNAL INPCMP 11 - LOGICAL CHANGE 12 - *** Doesn't yet do anything. 13 - PRINT *,' ###### OPTDEL ERROR : Instruction not yet released.' 14 - END 495 GARFIELD ================================================== P=OPTIMISE D=OPTFRC 1 ============================ 0 + +DECK,OPTFRC. 1 - SUBROUTINE OPTFRC 2 - *----------------------------------------------------------------------- 3 - * OPTFRC - Studies the electrostatic forces on a wire. 4 - * (Last changed on 21/10/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,CONSTANTS. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,SHAPEDATA. 12 - INTEGER INPCMP,INPTYP,IX,IY,INEXT,IFAIL1,ISIZ(2),IDIM(2),IIW, 13 - - IFAIL2,IFAIL3,IFAIL4,I,J,II,JJ,NXR,NYR,NC,NWORD,IFAIL,JW, 14 - - NSAG,NSHOTR,NSTEPR,NC1,NC2,NC3,NC4,NC5,NC6,NC7,NC8,NC9,NC10, 15 - - NC11,NC12,JSORDR,IWR,ITER,NFITRR,IOS,IMAX,JMAX 16 - REAL XPL(MXGRID),YPL(MXGRID),XSAG(0:MXLIST),YSAG(0:MXLIST), 17 - - CSAG(0:MXLIST),XNEAR,YNEAR,SHIFTX,SHIFTY,CORR, 18 - - FX0,FY0,XSAGMX,YSAGMX,XSAGAV,YSAGAV,XSAGMI,YSAGMI, 19 - - BXMIN,BYMIN,BXMAX,BYMAX,SXMIN,SYMIN,SXMAX,SYMAX,EX,EY, 20 - - FXMIN,FXMAX,FYMIN,FYMAX,FSXMIN,FSYMIN,FSXMAX,FSYMAX, 21 - - SXMINR,SXMAXR,SYMINR,SYMAXR,SFACT,SFACTR,XOFFR,YOFFR,TOLER, 22 - - TOLERR,CORMAX 23 - DOUBLE PRECISION WLENG,SS 24 - CHARACTER*20 AUXSTR,AUX1,AUX2,AUX3,AUX4,AUX5,AUX6,AUX7,AUX8,AUX9, 25 - - AUX10,AUX11,AUX12 26 - LOGICAL LFAST,LSAGPR,LSAGPL,LSAGKP,LFRCPR,LFRCPL,LFRCKP,INAREA, 27 - - OK,SFORCE,SLARGE,CONVIT,LSTAB 28 - EXTERNAL INPCMP,INPTYP 0 29-+ +SELF,IF=SAVE. 30 - SAVE LFAST,LSAGPR,LSAGPL,LSAGKP,LFRCPR,LFRCPL,LFRCKP,LSTAB 0 31-+ +SELF. 32 - DATA LFAST /.FALSE./, LSTAB /.FALSE./, 33 - - LSAGPR /.TRUE./ , LSAGPL /.FALSE./, LSAGKP /.FALSE./, 34 - - LFRCPR /.FALSE./, LFRCPL /.FALSE./, LFRCKP /.FALSE./ 35 - *** Routine identification. 36 - IF(LIDENT)PRINT *,' /// ROUTINE OPTFRC ///' 37 - *** Check for polar cells. 38 - IF(POLAR)THEN 39 - PRINT *,' !!!!!! OPTFRC WARNING : This instruction is not'// 40 - - ' able to handle polar cells.' 41 - RETURN 42 - ENDIF 43 - *** General purpose parameters. 44 - SFORCE=.FALSE. 45 - SLARGE=.FALSE. 46 - SFACT=2.0 47 - *** Number of shots and number of intermediate steps. 48 - NSHOT=2 49 - NSTEP=20 50 - *** Differentiation parameter, iterations, convergence criteria. 51 - EPS=1.0E-4 52 - NITMAX=100 53 - EPSX=1E-4 54 - EPSF=1E-4 55 - JSORD=2 56 - NSCANX=MIN(11,MXGRID) 1 495 P=OPTIMISE D=OPTFRC 2 PAGE 708 57 - NSCANY=MIN(11,MXGRID) 58 - *** Terms to be included. 59 - LFELEC=.TRUE. 60 - LFGRAV=.TRUE. 61 - *** Permit extrapolation or not. 62 - LFEXTR=.FALSE. 63 - *** Print flag for debugging purposes. 64 - LZROPR=.FALSE. 65 - *** Iterate over all wires or not, update for such iterations. 66 - LFITER=NSW.GT.1 67 - NFITER=5 68 - TOLER=0.0010 69 - *** Store nominal wire position and preset wire offset. 70 - DO 5 I=1,NWIRE 71 - XORIG(I)=X(I) 72 - YORIG(I)=Y(I) 73 - XOFF(I)=0 74 - YOFF(I)=0 75 - 5 CONTINUE 76 - *** Decode the argument list. 77 - CALL INPNUM(NWORD) 78 - INEXT=2 79 - DO 10 I=2,NWORD 80 - IF(I.LT.INEXT)GOTO 10 81 - * Printing. 82 - IF(INPCMP(I,'PR#INT-S#AG').NE.0)THEN 83 - LSAGPR=.TRUE. 84 - ELSEIF(INPCMP(I,'NOPR#INT-S#AG').NE.0)THEN 85 - LSAGPR=.FALSE. 86 - ELSEIF(INPCMP(I,'PR#INT-F#ORCES').NE.0)THEN 87 - LFRCPR=.TRUE. 88 - ELSEIF(INPCMP(I,'NOPR#INT-F#ORCES').NE.0)THEN 89 - LFRCPR=.FALSE. 90 - ELSEIF(INPCMP(I,'PR#INT-Z#ERO-#SEARCH').NE.0)THEN 91 - LZROPR=.TRUE. 92 - ELSEIF(INPCMP(I,'NOPR#INT-Z#ERO-#SEARCH').NE.0)THEN 93 - LZROPR=.FALSE. 94 - * Plotting. 95 - ELSEIF(INPCMP(I,'PL#OT-S#AG').NE.0)THEN 96 - LSAGPL=.TRUE. 97 - ELSEIF(INPCMP(I,'NOPL#OT-S#AG').NE.0)THEN 98 - LSAGPL=.FALSE. 99 - ELSEIF(INPCMP(I,'PL#OT-F#ORCES').NE.0)THEN 100 - LFRCPL=.TRUE. 101 - ELSEIF(INPCMP(I,'NOPL#OT-F#ORCES').NE.0)THEN 102 - LFRCPL=.FALSE. 103 - * Option to keep the results. 104 - ELSEIF(INPCMP(I,'KEEP-S#AG').NE.0)THEN 105 - LSAGKP=.TRUE. 106 - ELSEIF(INPCMP(I,'NOKEEP-S#AG').NE.0)THEN 107 - LSAGKP=.FALSE. 108 - ELSEIF(INPCMP(I,'KEEP-F#ORCES').NE.0)THEN 109 - LFRCKP=.TRUE. 110 - ELSEIF(INPCMP(I,'NOKEEP-F#ORCES').NE.0)THEN 111 - LFRCKP=.FALSE. 112 - ELSEIF(INPCMP(I,'KEEP-R#ESULTS').NE.0)THEN 113 - LSAGKP=.TRUE. 114 - LFRCKP=.TRUE. 115 - ELSEIF(INPCMP(I,'NOKEEP-R#ESULTS').NE.0)THEN 116 - LSAGKP=.FALSE. 117 - LFRCKP=.FALSE. 118 - * Inclusion or not of gravity and electrostatics. 119 - ELSEIF(INPCMP(I,'GRAV#ITY').NE.0)THEN 120 - LFGRAV=.TRUE. 121 - ELSEIF(INPCMP(I,'NOGRAV#ITY').NE.0)THEN 122 - LFGRAV=.FALSE. 123 - ELSEIF(INPCMP(I,'ELEC#TROSTATICS').NE.0)THEN 124 - LFELEC=.TRUE. 125 - ELSEIF(INPCMP(I,'NOELEC#TROSTATICS').NE.0)THEN 126 - LFELEC=.FALSE. 127 - * Detailed or fast calculation. 128 - ELSEIF(INPCMP(I,'DET#AILED').NE.0)THEN 129 - LFAST=.FALSE. 130 - ELSEIF(INPCMP(I,'FAST').NE.0)THEN 131 - LFAST=.TRUE. 132 - * Check for wire stability or not. 133 - ELSEIF(INPCMP(I,'CH#ECK-STAB#ILITY')+ 134 - - INPCMP(I,'STAB#ILITY-#CHECK').NE.0)THEN 135 - LSTAB=.TRUE. 136 - ELSEIF(INPCMP(I,'NOCH#ECK-STAB#ILITY')+ 137 - - INPCMP(I,'NOSTAB#ILITY-#CHECK').NE.0)THEN 138 - LSTAB=.FALSE. 139 - * Iterate or not. 140 - ELSEIF(INPCMP(I,'ITER#ATE').NE.0)THEN 141 - LFITER=.TRUE. 142 - IF(INPTYP(I+1).EQ.1)THEN 143 - CALL INPCHK(I+1,1,IFAIL1) 144 - CALL INPRDI(I+1,NFITRR,5) 145 - IF(NFITRR.GE.1)THEN 146 - NFITER=NFITRR 147 - ELSE 148 - CALL INPMSG(I+1,'Should be > 0.') 149 - ENDIF 150 - INEXT=I+2 151 - ENDIF 152 - ELSEIF(INPCMP(I,'NOITER#ATE').NE.0)THEN 153 - LFITER=.FALSE. 154 - NFITER=0 155 - * Extrapolate or not beyond scanning area. 156 - ELSEIF(INPCMP(I,'EXTR#APOLATE').NE.0)THEN 157 - LFEXTR=.TRUE. 158 - ELSEIF(INPCMP(I,'NOEXTR#APOLATE').NE.0)THEN 159 - LFEXTR=.FALSE. 160 - * Scanning size. 161 - ELSEIF(INPCMP(I,'SCAN#NING-GR#ID').NE.0)THEN 162 - IF(INPTYP(I+1).EQ.4)THEN 1 495 P=OPTIMISE D=OPTFRC 3 PAGE 709 163 - INEXT=I+2 164 - IFAIL1=0 165 - ELSEIF(INPTYP(I+1).EQ.1)THEN 166 - CALL INPCHK(I+1,1,IFAIL1) 167 - CALL INPRDI(I+1,NXR,NSCANX) 168 - IF(IFAIL1.EQ.0.AND.NXR.GT.1.AND.NXR.LE.MXGRID)THEN 169 - NSCANX=NXR 170 - IF(INPTYP(I+2).NE.1.AND. 171 - - INPTYP(I+2).NE.4)NSCANY=NXR 172 - ELSE 173 - IFAIL1=1 174 - CALL INPMSG(I+1,'Should be 1 < n <= MXGRID') 175 - ENDIF 176 - INEXT=I+2 177 - ELSE 178 - IFAIL1=1 179 - ENDIF 180 - IF(IFAIL1.EQ.0.AND.INPTYP(I+2).EQ.4)THEN 181 - INEXT=I+3 182 - ELSEIF(IFAIL1.EQ.0.AND.INPTYP(I+2).EQ.1)THEN 183 - CALL INPCHK(I+2,1,IFAIL1) 184 - CALL INPRDI(I+2,NYR,NSCANY) 185 - IF(IFAIL1.EQ.0.AND.NYR.GT.1.AND.NYR.LE.MXGRID)THEN 186 - NSCANY=NYR 187 - ELSE 188 - CALL INPMSG(I+2,'Should be 1 < n <= MXGRID') 189 - ENDIF 190 - INEXT=I+3 191 - ENDIF 192 - * Scanning area. 193 - ELSEIF(INPCMP(I,'SCAN#NING-A#REA').NE.0)THEN 194 - IF(INPCMP(I+1,'MAX#IMAL')+INPCMP(I+1,'MAX#IMUM')+ 195 - - INPCMP(I+1,'LARG#EST').NE.0)THEN 196 - SLARGE=.TRUE. 197 - SFORCE=.FALSE. 198 - INEXT=I+2 199 - ELSEIF(INPCMP(I+1,'F#IRST-ORD#ER-#ENLARGED-#BY')+ 200 - - INPCMP(I+1,'ENL#ARGED-#BY').NE.0)THEN 201 - IF(NWORD.GE.I+2.AND. 202 - - (INPTYP(I+2).EQ.1.OR.INPTYP(I+2).EQ.2))THEN 203 - CALL INPCHK(I+2,2,IFAIL1) 204 - CALL INPRDR(I+2,SFACTR,2.0) 205 - IF(SFACTR.LE.0)THEN 206 - CALL INPMSG(I+1,'Should be > 0.') 207 - ELSE 208 - SFACT=SFACTR 209 - ENDIF 210 - INEXT=I+3 211 - ELSEIF(NWORD.GE.I+2.AND.INPTYP(I+2).EQ.4)THEN 212 - SFACT=2.0 213 - INEXT=I+3 214 - ELSE 215 - SFACT=2.0 216 - INEXT=I+2 217 - ENDIF 218 - SFORCE=.FALSE. 219 - SLARGE=.FALSE. 220 - ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. 221 - - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. 222 - - (INPTYP(I+3).NE.1.AND.INPTYP(I+3).NE.2).OR. 223 - - (INPTYP(I+4).NE.1.AND.INPTYP(I+4).NE.2))THEN 224 - CALL INPMSG(I,'Incorrect set of arguments.') 225 - ELSE 226 - CALL INPCHK(I+1,2,IFAIL1) 227 - CALL INPCHK(I+2,2,IFAIL2) 228 - CALL INPCHK(I+3,2,IFAIL3) 229 - CALL INPCHK(I+4,2,IFAIL4) 230 - CALL INPRDR(I+1,SXMINR,0.0) 231 - CALL INPRDR(I+2,SYMINR,0.0) 232 - CALL INPRDR(I+3,SXMAXR,0.0) 233 - CALL INPRDR(I+4,SYMAXR,0.0) 234 - SFORCE=.TRUE. 235 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND. 236 - - SXMINR.EQ.SXMAXR)THEN 237 - CALL INPMSG(I+1,'Zero range not permitted.') 238 - CALL INPMSG(I+2,'See previous message.') 239 - SFORCE=.FALSE. 240 - ELSE 241 - FSXMIN=MIN(SXMINR,SXMAXR) 242 - FSXMAX=MAX(SXMINR,SXMAXR) 243 - ENDIF 244 - IF(IFAIL3.EQ.0.AND.IFAIL4.EQ.0.AND. 245 - - SYMINR.EQ.SYMAXR)THEN 246 - CALL INPMSG(I+3,'Zero range not permitted.') 247 - CALL INPMSG(I+4,'See previous message.') 248 - SFORCE=.FALSE. 249 - ELSE 250 - FSYMIN=MIN(SYMINR,SYMAXR) 251 - FSYMAX=MAX(SYMINR,SYMAXR) 252 - ENDIF 253 - SLARGE=.FALSE. 254 - INEXT=I+5 255 - ENDIF 256 - * Initial wire offsets. 257 - ELSEIF(INPCMP(I,'OFF#SET').NE.0)THEN 258 - IF(INPTYP(I+1).NE.1.OR. 259 - - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. 260 - - (INPTYP(I+3).NE.1.AND.INPTYP(I+3).NE.2))THEN 261 - CALL INPMSG(I,'Incorrect set of arguments.') 262 - ELSE 263 - CALL INPCHK(I+1,1,IFAIL1) 264 - CALL INPCHK(I+2,2,IFAIL2) 265 - CALL INPCHK(I+3,2,IFAIL3) 266 - CALL INPRDI(I+1,IWR,0) 267 - CALL INPRDR(I+2,XOFFR,0.0) 268 - CALL INPRDR(I+3,YOFFR,0.0) 1 495 P=OPTIMISE D=OPTFRC 4 PAGE 710 269 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0.AND. 270 - - (IWR.LE.0.OR.IWR.GT.NWIRE))THEN 271 - CALL INPMSG(I+1,'Wire number out of range.') 272 - ELSEIF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN 273 - XOFF(IWR)=XOFFR 274 - YOFF(IWR)=YOFFR 275 - ENDIF 276 - INEXT=I+4 277 - ENDIF 278 - * Shots and steps per shot. 279 - ELSEIF(INPCMP(I,'SHOT#S').NE.0)THEN 280 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN 281 - CALL INPMSG(I,'The argument is missing') 282 - ELSE 283 - CALL INPCHK(I+1,1,IFAIL1) 284 - CALL INPRDI(I+1,NSHOTR,NSHOT) 285 - IF(NSHOTR.GE.0)THEN 286 - NSHOT=NSHOTR 287 - ELSE 288 - CALL INPMSG(I+1,'Must be at least 0.') 289 - ENDIF 290 - INEXT=I+2 291 - ENDIF 292 - ELSEIF(INPCMP(I,'STEP#S-#PER-#SHOT').NE.0)THEN 293 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN 294 - CALL INPMSG(I,'The argument is missing') 295 - ELSE 296 - CALL INPCHK(I+1,1,IFAIL1) 297 - CALL INPRDI(I+1,NSTEPR,NSTEP) 298 - IF(NSTEPR.GE.1)THEN 299 - NSTEP=NSTEPR 300 - ELSE 301 - CALL INPMSG(I+1,'Must be at least 1.') 302 - ENDIF 303 - INEXT=I+2 304 - ENDIF 305 - * Interpolation order. 306 - ELSEIF(INPCMP(I,'INT#ERPOLATION-ORD#ER').NE.0)THEN 307 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN 308 - CALL INPMSG(I,'The argument is missing') 309 - ELSE 310 - CALL INPCHK(I+1,1,IFAIL1) 311 - CALL INPRDI(I+1,JSORDR,JSORD) 312 - IF(JSORDR.GE.1.AND.JSORDR.LE.10)THEN 313 - JSORD=JSORDR 314 - ELSE 315 - CALL INPMSG(I+1,'Must be at in the range [1,10]') 316 - ENDIF 317 - INEXT=I+2 318 - ENDIF 319 - * Wire shift tolerance. 320 - ELSEIF(INPCMP(I,'TOL#ERANCE').NE.0)THEN 321 - IF(NWORD.LT.I+1.OR.( 322 - - INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2))THEN 323 - CALL INPMSG(I,'The argument is missing') 324 - ELSE 325 - CALL INPCHK(I+1,2,IFAIL1) 326 - CALL INPRDR(I+1,TOLERR,0.0010) 327 - IF(TOLERR.GT.0)THEN 328 - TOLER=TOLERR 329 - ELSE 330 - CALL INPMSG(I+1,'Must be > 0') 331 - ENDIF 332 - INEXT=I+2 333 - ENDIF 334 - * Unrecognised keywords. 335 - ELSE 336 - CALL INPMSG(I,'Not a known keyword.') 337 - ENDIF 338 - * Next keyword. 339 - 10 CONTINUE 340 - *** Dump the error messages. 341 - CALL INPERR 342 - *** Check interpolation order compared with grid size. 343 - IF(JSORD.GT.NSCANX-1.OR.JSORD.GT.NSCANY-1.OR.JSORD.LT.1)THEN 344 - JSORD=MIN(NSCANX-1,NSCANY-1,JSORD) 345 - IF(JSORD.LT.1)JSORD=1 346 - PRINT *,' !!!!!! OPTFRC WARNING : Interpolation order'// 347 - - ' larger than scanning grid size; reduced to ',JSORD 348 - ENDIF 349 - *** Debugging output. 350 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTFRC DEBUG : Settings'', 351 - - '' of options:''// 352 - - 26X,''0th Order only: '',L1/ 353 - - 26X,''Plot forces: '',L1/ 354 - - 26X,''Print force table: '',L1/ 355 - - 26X,''Store forces: '',L1/ 356 - - 26X,''Plot wire sag: '',L1/ 357 - - 26X,''Print wire sag: '',L1/ 358 - - 26X,''Store wire sag: '',L1)') 359 - - LFAST,LFRCPL,LFRCPR,LFRCKP,LSAGPL,LSAGPR,LSAGKP 360 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTFRC DEBUG : Settings'', 361 - - '' of parameters:''// 362 - - 26X,''Number of shots: '',I5/ 363 - - 26X,''Steps per shot: '',I5/ 364 - - 26X,''Epsilon differentials: '',E10.3/ 365 - - 26X,''Position convergence: '',E10.3/ 366 - - 26X,''Function convergence: '',E10.3/ 367 - - 26X,''Zero search iterations: '',I5/ 368 - - 26X,''Zero search printing: '',L5/ 369 - - 26X,''Permit extrapolation: '',L5/ 370 - - 26X,''Do all-wire iterations: '',L5/ 371 - - 26X,''# all-wire iterations: '',I5/ 372 - - 26X,''Maximum scanning area: '',L5/ 373 - - 26X,''Scanning area enlarging: '',E10.3/ 374 - - 26X,''Forced scanning area: '',L5/ 1 495 P=OPTIMISE D=OPTFRC 5 PAGE 711 375 - - 26X,''User scanning area: '',4E10.3/ 376 - - 26X,''Scanning grid density: '',2I5)') 377 - - NSHOT,NSTEP,EPS,EPSX,EPSF,NITMAX,LZROPR,LFEXTR,LFITER, 378 - - NFITER,SLARGE,SFACT,SFORCE,FSXMIN,FSYMIN,FSXMAX,FSYMAX, 379 - - NSCANX,NSCANY 380 - *** Return here for a further loop. 381 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 382 - ITER=0 383 - CONVIT=.NOT.LFITER 384 - 1000 CONTINUE 385 - * Increment iteration counter. 386 - ITER=ITER+1 387 - * Reset larges wire shift. 388 - CORMAX=0 389 - *** Establish the initial configuration. 390 - DO 15 J=1,NWIRE 391 - X(J)=XORIG(J)+XOFF(J) 392 - Y(J)=YORIG(J)+YOFF(J) 393 - 15 CONTINUE 394 - *** Loop over wires. 395 - DO 20 IIW=1,NWIRE 396 - * Reject all that were not SELECT'ed. 397 - IF(INDSW(IIW).EQ.0)GOTO 20 398 - * Place the current wire at its nominal position. 399 - X(IIW)=XORIG(IIW) 400 - Y(IIW)=YORIG(IIW) 401 - *** First order approximation, also used if detail is required. 402 - CALL SETUP(IFAIL) 403 - * Print a warning if this failed. 404 - IF(IFAIL.NE.0)THEN 405 - PRINT *,' !!!!!! OPTFRC WARNING : Charge'// 406 - - ' calculation failed at central position.' 407 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 408 - FX0=0.0 409 - FY0=0.0 410 - * Otherwise compute the forces. 411 - ELSE 412 - CALL FFIELD(IIW,EX,EY) 413 - FX0=0 414 - FY0=0 415 - IF(LFELEC)THEN 416 - FX0=FX0-EX*E(IIW)*2*PI*EPS0*100 417 - FY0=FY0-EY*E(IIW)*2*PI*EPS0*100 418 - ENDIF 419 - IF(LFGRAV)THEN 420 - FX0=FX0-DOWN(1)*GRAV*DENS(IIW)*PI*D(IIW)**2/4000 421 - FY0=FY0-DOWN(2)*GRAV*DENS(IIW)*PI*D(IIW)**2/4000 422 - ENDIF 423 - ENDIF 424 - * And compute the shift from this. 425 - SHIFTX=-125*FX0*U(IIW)**2/(GRAV*W(IIW)) 426 - SHIFTY=-125*FY0*U(IIW)**2/(GRAV*W(IIW)) 427 - * Get the elongation from this. 428 - SS=4*SQRT(DBLE(SHIFTX)**2+DBLE(SHIFTY)**2)/U(IIW) 429 - IF(SS.LE.0)THEN 430 - WLENG=U(IIW) 431 - ELSE 432 - WLENG=(SQRT(1+SS**2)+LOG(SS+SQRT(1+SS**2))/SS)*U(IIW)/2 433 - ENDIF 434 - *** If requested, print results. 435 - IF(LSAGPR.AND.CONVIT)THEN 436 - CALL OUTFMT(REAL(IIW),2,AUX1,NC1,'LEFT') 437 - CALL OUTFMT(XORIG(IIW),2,AUX2,NC2,'LEFT') 438 - CALL OUTFMT(YORIG(IIW),2,AUX3,NC3,'LEFT') 439 - CALL OUTFMT(V(IIW),2,AUX4,NC4,'LEFT') 440 - CALL OUTFMT(U(IIW),2,AUX5,NC5,'LEFT') 441 - CALL OUTFMT(W(IIW),2,AUX6,NC6,'LEFT') 442 - CALL OUTFMT(FX0,2,AUX7,NC7,'LEFT') 443 - CALL OUTFMT(FY0,2,AUX8,NC8,'LEFT') 444 - CALL OUTFMT(SHIFTX,2,AUX9,NC9,'LEFT') 445 - CALL OUTFMT(SHIFTY,2,AUX10,NC10,'LEFT') 446 - CALL OUTFMT(REAL(WLENG-U(IIW))/U(IIW),2,AUX11,NC11,'LEFT') 447 - WRITE(LUNOUT,'('' FORCES AND DISPLACEMENT IN 0th ORDER''// 448 - - '' Wire information: number = '',A/ 449 - - '' type = '',A1/ 450 - - '' location = ('',A,'', '',A,'') cm''/ 451 - - '' voltage = '',A,'' V''/ 452 - - '' length = '',A,'' cm''/ 453 - - '' tension = '',A,'' g''// 454 - - '' In this position: Fx = '',A,'' N/cm''/ 455 - - '' Fy = '',A,'' N/cm''/ 456 - - '' x-shift = '',A,'' cm''/ 457 - - '' y-shift = '',A,'' cm''/ 458 - - '' stretch = '',A,'' fraction'')') 459 - - AUX1(1:NC1),WIRTYP(IIW),AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4), 460 - - AUX5(1:NC5),AUX6(1:NC6),AUX7(1:NC7),AUX8(1:NC8),AUX9(1:NC9), 461 - - AUX10(1:NC10),AUX11(1:NC11) 462 - ENDIF 463 - *** Save the forces if requested and if the rest is skipped. 464 - IF(LFAST.AND.LFRCKP.AND.CONVIT)THEN 465 - * Format the wire number. 466 - CALL OUTFMT(REAL(IIW),2,AUXSTR,NC,'LEFT') 467 - * Assign the results to globals. 468 - CALL NUMSAV(FX0,'FORCE_X_'//AUXSTR(1:NC),IFAIL1) 469 - CALL NUMSAV(FY0,'FORCE_Y_'//AUXSTR(1:NC),IFAIL2) 470 - * Check the error condition. 471 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN 472 - PRINT *,' ------ OUTFRC MESSAGE : The forces'// 473 - - ' acting on wire '//AUXSTR(1:NC)//' are' 474 - PRINT *,' saved as FORCE_X_'// 475 - - AUXSTR(1:NC)//' and FORCE_Y_'//AUXSTR(1:NC)//'.' 476 - ELSE 477 - PRINT *,' !!!!!! OPTFRC WARNING : Saving the forces'// 478 - - ' failed.' 479 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 480 - ENDIF 1 495 P=OPTIMISE D=OPTFRC 6 PAGE 712 481 - ENDIF 482 - *** Save the sag if requested and if the rest is skipped. 483 - IF(LFAST.AND.LSAGKP.AND.CONVIT)THEN 484 - * Format the wire number. 485 - CALL OUTFMT(REAL(IIW),2,AUXSTR,NC,'LEFT') 486 - * Assign the results to globals. 487 - CALL NUMSAV(SHIFTX,'SHIFT_X_'//AUXSTR(1:NC),IFAIL1) 488 - CALL NUMSAV(SHIFTY,'SHIFT_Y_'//AUXSTR(1:NC),IFAIL2) 489 - CALL NUMSAV(REAL((WLENG-U(IIW))/U(IIW)), 490 - - 'STRETCH_'//AUXSTR(1:NC),IFAIL3) 491 - * Check the error condition. 492 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN 493 - PRINT *,' ------ OUTFRC MESSAGE : Shift and'// 494 - - ' elongation of wire '//AUXSTR(1:NC) 495 - PRINT *,' saved as SHIFT_X_'// 496 - - AUXSTR(1:NC)//', SHIFT_Y_'//AUXSTR(1:NC)// 497 - - ' and STRETCH_'//AUXSTR(1:NC)//'.' 498 - ELSE 499 - PRINT *,' !!!!!! OPTFRC WARNING : Saving the sag'// 500 - - ' failed.' 501 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 502 - ENDIF 503 - ENDIF 504 - *** And skip the rest if fast calculation was requested. 505 - IF(LFAST)THEN 506 - CORMAX=MAX(CORMAX,ABS(2.0*SHIFTX/3.0-XOFF(IIW)), 507 - - ABS(2.0*SHIFTY/3.0-YOFF(IIW))) 508 - X(IIW)=XORIG(IIW)+XOFF(IIW) 509 - Y(IIW)=YORIG(IIW)+YOFF(IIW) 510 - XOFF(IIW)=2.0*SHIFTX/3.0 511 - YOFF(IIW)=2.0*SHIFTY/3.0 512 - GOTO 20 513 - ENDIF 514 - *** Detailed calculation: compute a 'safe box' around the wire. 515 - IF(PERX)THEN 516 - BXMIN=X(IIW)-SX/2 517 - BXMAX=X(IIW)+SX/2 518 - ELSE 519 - BXMIN=2*XMIN-XMAX 520 - BXMAX=2*XMAX-XMIN 521 - ENDIF 522 - IF(PERY)THEN 523 - BYMIN=Y(IIW)-SY/2 524 - BYMAX=Y(IIW)+SY/2 525 - ELSE 526 - BYMIN=2*YMIN-YMAX 527 - BYMAX=2*YMAX-YMIN 528 - ENDIF 529 - * If the initial area is almost zero in 1 direction, make it square. 530 - IF(ABS(BXMAX-BXMIN).LT.0.1*ABS(BYMAX-BYMIN))THEN 531 - BXMIN=X(IIW)-ABS(BYMAX-BYMIN)/2 532 - BXMAX=X(IIW)+ABS(BYMAX-BYMIN)/2 533 - ELSEIF(ABS(BYMAX-BYMIN).LT.0.1*ABS(BXMAX-BXMIN))THEN 534 - BYMIN=Y(IIW)-ABS(BXMAX-BXMIN)/2 535 - BYMAX=Y(IIW)+ABS(BXMAX-BXMIN)/2 536 - ENDIF 537 - * Scan the other wires. 538 - DO 100 JW=1,NWIRE 539 - IF(JW.EQ.IIW)GOTO 100 540 - IF(PERX)THEN 541 - XNEAR=X(JW)-ANINT((X(JW)-X(IIW))/SX)*SX 542 - ELSE 543 - XNEAR=X(JW) 544 - ENDIF 545 - IF(PERY)THEN 546 - YNEAR=Y(JW)-ANINT((Y(JW)-Y(IIW))/SY)*SY 547 - ELSE 548 - YNEAR=Y(JW) 549 - ENDIF 550 - IF(ABS(XNEAR-X(IIW)).GT.ABS(YNEAR-Y(IIW)))THEN 551 - IF(XNEAR.LT.X(IIW))THEN 552 - BXMIN=MAX(BXMIN,XNEAR+D(JW)+D(IIW)) 553 - IF(PERX)BXMAX=MIN(BXMAX,XNEAR+SX-D(JW)-D(IIW)) 554 - ELSE 555 - BXMAX=MIN(BXMAX,XNEAR-D(JW)-D(IIW)) 556 - IF(PERX)BXMIN=MAX(BXMIN,XNEAR-SX+D(JW)+D(IIW)) 557 - ENDIF 558 - ELSE 559 - IF(YNEAR.LT.Y(IIW))THEN 560 - BYMIN=MAX(BYMIN,YNEAR-D(JW)-D(IIW),YNEAR+D(JW)+D(IIW)) 561 - IF(PERY)BYMAX=MIN(BYMAX,YNEAR+SY-D(JW)-D(IIW)) 562 - ELSE 563 - BYMAX=MIN(BYMAX,YNEAR-D(JW)-D(IIW),YNEAR+D(JW)+D(IIW)) 564 - IF(PERY)BYMIN=MAX(BYMIN,YNEAR-SY+D(JW)+D(IIW)) 565 - ENDIF 566 - ENDIF 567 - 100 CONTINUE 568 - * Scan the planes. 569 - IF(YNPLAN(1))BXMIN=MAX(BXMIN,COPLAN(1)+D(IIW)) 570 - IF(YNPLAN(2))BXMAX=MIN(BXMAX,COPLAN(2)-D(IIW)) 571 - IF(YNPLAN(3))BYMIN=MAX(BYMIN,COPLAN(3)+D(IIW)) 572 - IF(YNPLAN(4))BYMAX=MIN(BYMAX,COPLAN(4)-D(IIW)) 573 - * If there is a tube, check all corners. 574 - IF(TUBE.AND.COTUBE**2-D(IIW)**2.GT.0)THEN 575 - CORR=SQRT((BXMIN**2+BYMIN**2)/(COTUBE**2-D(IIW)**2)) 576 - IF(CORR.GT.1)THEN 577 - BXMIN=BXMIN/CORR 578 - BYMIN=BYMIN/CORR 579 - ENDIF 580 - CORR=SQRT((BXMIN**2+BYMIN**2)/(COTUBE**2-D(IIW)**2)) 581 - IF(CORR.GT.1)THEN 582 - BXMIN=BXMIN/CORR 583 - BYMAX=BYMAX/CORR 584 - ENDIF 585 - CORR=SQRT((BXMIN**2+BYMIN**2)/(COTUBE**2-D(IIW)**2)) 586 - IF(CORR.GT.1)THEN 1 495 P=OPTIMISE D=OPTFRC 7 PAGE 713 587 - BXMAX=BXMAX/CORR 588 - BYMIN=BYMIN/CORR 589 - ENDIF 590 - CORR=SQRT((BXMIN**2+BYMIN**2)/(COTUBE**2-D(IIW)**2)) 591 - IF(CORR.GT.1)THEN 592 - BXMAX=BXMAX/CORR 593 - BYMAX=BYMAX/CORR 594 - ENDIF 595 - ELSEIF(TUBE)THEN 596 - PRINT *,' !!!!!! OPTFRC WARNING : Wire diameter too'// 597 - - ' large compared to tube; wire ',IIW,' skipped.' 598 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 599 - GOTO 20 600 - ENDIF 601 - * Make sure we found a reasonable 'safe area'. 602 - IF((BXMIN-X(IIW))*(X(IIW)-BXMAX).LE.0.OR. 603 - - (BYMIN-Y(IIW))*(Y(IIW)-BYMAX).LE.0)THEN 604 - PRINT *,' !!!!!! OPTFRC WARNING : Unable to find'// 605 - - ' an area free of elements around wire ',IIW 606 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 607 - GOTO 20 608 - ENDIF 609 - *** Now set a reasonable scanning range: if user specified range: 610 - IF(SFORCE)THEN 611 - SXMIN=X(IIW)+FSXMIN 612 - SYMIN=Y(IIW)+FSYMIN 613 - SXMAX=X(IIW)+FSXMAX 614 - SYMAX=Y(IIW)+FSYMAX 615 - * if maximum area: 616 - ELSEIF(SLARGE)THEN 617 - SXMIN=BXMIN 618 - SXMAX=BXMAX 619 - SYMIN=BYMIN 620 - SYMAX=BYMAX 621 - * if 0th order estimate of shift is not small: 622 - ELSEIF(ABS(SHIFTX).GT.D(IIW)/20.OR.ABS(SHIFTY).GT.D(IIW)/20)THEN 623 - SXMIN=MAX(BXMIN,MIN(X(IIW)+SFACT*SHIFTX, 624 - - X(IIW)-SHIFTX/SFACT)) 625 - SYMIN=MAX(BYMIN,MIN(Y(IIW)+SFACT*SHIFTY, 626 - - Y(IIW)-SHIFTY/SFACT)) 627 - SXMAX=MIN(BXMAX,MAX(X(IIW)+SFACT*SHIFTX, 628 - - X(IIW)-SHIFTX/SFACT)) 629 - SYMAX=MIN(BYMAX,MAX(Y(IIW)+SFACT*SHIFTY, 630 - - Y(IIW)-SHIFTY/SFACT)) 631 - * If one is very small, make the area square within bounds. 632 - IF(ABS(SXMAX-SXMIN).LT.0.1*ABS(SYMAX-SYMIN))THEN 633 - SXMIN=MAX(BXMIN,X(IIW)-0.5*ABS(SYMAX-SYMIN)) 634 - SXMAX=MIN(BXMAX,X(IIW)+0.5*ABS(SYMAX-SYMIN)) 635 - ELSEIF(ABS(SYMAX-SYMIN).LT.0.1*ABS(SXMAX-SXMIN))THEN 636 - SYMIN=MAX(BYMIN,Y(IIW)-0.5*ABS(SXMAX-SXMIN)) 637 - SYMAX=MIN(BYMAX,Y(IIW)+0.5*ABS(SXMAX-SXMIN)) 638 - ENDIF 639 - * Otherwise, take full acceptable range. 640 - ELSE 641 - SXMIN=BXMIN 642 - SYMIN=BYMIN 643 - SXMAX=BXMAX 644 - SYMAX=BYMAX 645 - ENDIF 646 - *** Debugging output. 647 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTFRC DEBUG : '', 648 - - ''Free area '',E12.5,'' < x < '',E12.5/26X, 649 - - '' '',E12.5,'' < y < '',E12.5/26X, 650 - - ''Scan area '',E12.5,'' < x < '',E12.5/26X, 651 - - '' '',E12.5,'' < y < '',E12.5)') 652 - - BXMIN,BXMAX,BYMIN,BYMAX,SXMIN,SXMAX,SYMIN,SYMAX 653 - *** Prepare an interpolation table. 654 - OK=.TRUE. 655 - DO 30 IX=1,NSCANX 656 - XSCAN(IX)=SXMIN+REAL(IX-1)*(SXMAX-SXMIN)/REAL(NSCANX-1) 657 - DO 40 IY=1,NSCANY 658 - YSCAN(IY)=SYMIN+REAL(IY-1)*(SYMAX-SYMIN)/REAL(NSCANY-1) 659 - * Get the wire position for this shift. 660 - X(IIW)=REAL(XSCAN(IX)) 661 - Y(IIW)=REAL(YSCAN(IY)) 662 - * Verify the current situation. 663 - CALL CELWCH(IFAIL1) 664 - IF(IFAIL1.NE.0)THEN 665 - PRINT *,' !!!!!! OPTFRC WARNING : Scan involves a'// 666 - - ' disallowed wire position; wire ',IIW,' skipped.' 667 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 668 - FX(IX,IY)=0.0 669 - FY(IX,IY)=0.0 670 - OK=.FALSE. 671 - GOTO 40 672 - ENDIF 673 - * Recompute the charges for this configuration. 674 - CALL SETUP(IFAIL) 675 - IF(IFAIL.NE.0)THEN 676 - PRINT *,' !!!!!! OPTFRC WARNING : Failed to compute'// 677 - - ' charges at a scan point; wire ',IIW,' skipped.' 678 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 679 - FX(IX,IY)=0.0 680 - FY(IX,IY)=0.0 681 - OK=.FALSE. 682 - GOTO 40 683 - ENDIF 684 - * Compute the forces. 685 - CALL FFIELD(IIW,EX,EY) 686 - FX(IX,IY)=-EX*E(IIW)*2*PI*EPS0*100 687 - FY(IX,IY)=-EY*E(IIW)*2*PI*EPS0*100 688 - * And keep track of the range of the forces. 689 - IF(IX.EQ.1.AND.IY.EQ.1)THEN 690 - FXMIN=REAL(FX(IX,IY)) 691 - FXMAX=REAL(FX(IX,IY)) 692 - FYMIN=REAL(FY(IX,IY)) 1 495 P=OPTIMISE D=OPTFRC 8 PAGE 714 693 - FYMAX=REAL(FY(IX,IY)) 694 - ELSE 695 - FXMIN=MIN(FXMIN,REAL(FX(IX,IY))) 696 - FXMAX=MAX(FXMAX,REAL(FX(IX,IY))) 697 - FYMIN=MIN(FYMIN,REAL(FY(IX,IY))) 698 - FYMAX=MAX(FYMAX,REAL(FY(IX,IY))) 699 - ENDIF 700 - * Next point. 701 - 40 CONTINUE 702 - 30 CONTINUE 703 - *** Place the wire back in its shifted position. 704 - X(IIW)=XORIG(IIW)+XOFF(IIW) 705 - Y(IIW)=YORIG(IIW)+YOFF(IIW) 706 - *** Skip the rest in case of failure. 707 - IF(.NOT.OK)GOTO 20 708 - *** Plot the force field if requested. 709 - IF(LFRCPL.AND.CONVIT)THEN 710 - * Open a frame for the x-grid lines. 711 - CALL GRCART(SXMIN,MIN(FXMIN,FYMIN)-0.1* 712 - - (MAX(FXMAX,FYMAX)-MIN(FXMIN,FYMIN)), 713 - - SXMAX,MAX(FXMAX,FYMAX)+0.1* 714 - - (MAX(FXMAX,FYMAX)-MIN(FXMIN,FYMIN)), 715 - - 'Wire x position [cm]','Force [N/cm]', 716 - - 'Forces as function of wire shift') 717 - * Add comments. 718 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 719 - CALL OUTFMT(REAL(IIW),2,AUXSTR,NC,'LEFT') 720 - CALL GRCOMM(2,'Wire: '//AUXSTR(1:NC)//' ('// 721 - - WIRTYP(IIW)//')') 722 - * Plot the forces. 723 - DO 140 IY=1,NSCANY 724 - CALL GRATTS('FUNCTION-1','POLYLINE') 725 - DO 150 IX=1,NSCANX 726 - XPL(IX)=REAL(XSCAN(IX)) 727 - YPL(IX)=REAL(FX(IX,IY)) 728 - 150 CONTINUE 729 - CALL GRLINE(NSCANX,XPL,YPL) 730 - CALL GRATTS('FUNCTION-2','POLYLINE') 731 - DO 160 IX=1,NSCANX 732 - XPL(IX)=REAL(XSCAN(IX)) 733 - YPL(IX)=REAL(FY(IX,IY)) 734 - 160 CONTINUE 735 - CALL GRLINE(NSCANX,XPL,YPL) 736 - 140 CONTINUE 737 - * Register the plot and close this frame. 738 - CALL GRALOG('Forces on wire '//AUXSTR(1:NC)) 739 - CALL GRNEXT 740 - * Open a frame for the y-grid lines. 741 - CALL GRCART(SYMIN,MIN(FXMIN,FYMIN)-0.1* 742 - - (MAX(FXMAX,FYMAX)-MIN(FXMIN,FYMIN)), 743 - - SYMAX,MAX(FXMAX,FYMAX)+0.1* 744 - - (MAX(FXMAX,FYMAX)-MIN(FXMIN,FYMIN)), 745 - - 'Wire y position [cm]','Force [N/cm]', 746 - - 'Forces as function of wire shift') 747 - * Add comments. 748 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 749 - CALL GRCOMM(2,'Wire: '//AUXSTR(1:NC)//' ('// 750 - - WIRTYP(IIW)//')') 751 - * Plot the forces. 752 - DO 110 IX=1,NSCANX 753 - CALL GRATTS('FUNCTION-1','POLYLINE') 754 - DO 120 IY=1,NSCANY 755 - XPL(IY)=REAL(YSCAN(IY)) 756 - YPL(IY)=REAL(FX(IX,IY)) 757 - 120 CONTINUE 758 - CALL GRLINE(NSCANY,XPL,YPL) 759 - CALL GRATTS('FUNCTION-2','POLYLINE') 760 - DO 130 IY=1,NSCANY 761 - XPL(IY)=REAL(YSCAN(IY)) 762 - YPL(IY)=REAL(FY(IX,IY)) 763 - 130 CONTINUE 764 - CALL GRLINE(NSCANY,XPL,YPL) 765 - 110 CONTINUE 766 - * Register the plot and close this frame. 767 - CALL GRALOG('Forces on wire '//AUXSTR(1:NC)) 768 - CALL GRNEXT 769 - ENDIF 770 - *** Print the table of the forces. 771 - IF(LFRCPR.AND.CONVIT)THEN 772 - * Print a header. 773 - WRITE(LUNOUT,'('' FORCES ACTING ON WIRE '',I4// 774 - - '' Fx [N/cm]''/'' Fy [N/cm]''/'' |F| [N/cm]'')') 775 - - IIW 776 - * Print them block by block. 777 - DO 170 JJ=0,10*INT((NSCANY-1)/10.0),10 778 - JMAX=MIN(NSCANY-JJ,10) 779 - DO 180 II=0,10*INT((NSCANX-1)/10.0),10 780 - IMAX=MIN(NSCANX-II,10) 781 - WRITE(LUNOUT,'(''1 Force-print'',109X, 782 - - ''Part '',I1,''.'',I1)', 783 - - ERR=2010,IOSTAT=IOS) 1+II/10,1+JJ/10 784 - WRITE(LUNOUT,'('' ==========='',109X,''========''/)', 785 - - IOSTAT=IOS,ERR=2010) 786 - WRITE(LUNOUT,'('' y x:'',10(E11.4,1X:)/)', 787 - - IOSTAT=IOS,ERR=2010) (XSCAN(II+I),I=1,IMAX) 788 - DO 190 J=1,JMAX 789 - WRITE(LUNOUT,'(1X,E10.3)',IOSTAT=IOS,ERR=2010) 790 - - YSCAN(JJ+J) 791 - WRITE(LUNOUT,'(12X,10(E11.4,1X:))',IOSTAT=IOS,ERR=2010) 792 - - (FX(II+I,JJ+J),I=1,IMAX) 793 - WRITE(LUNOUT,'(12X,10(E11.4,1X:))',IOSTAT=IOS,ERR=2010) 794 - - (FY(II+I,JJ+J),I=1,IMAX) 795 - WRITE(LUNOUT,'(12X,10(E11.4,1X:))',IOSTAT=IOS,ERR=2010) 796 - - (SQRT(FX(II+I,JJ+J)**2+FY(II+I,JJ+J)**2),I=1,IMAX) 797 - 190 CONTINUE 798 - 180 CONTINUE 1 495 P=OPTIMISE D=OPTFRC 9 PAGE 715 799 - 170 CONTINUE 800 - ENDIF 801 - *** Save the force table if requested. 802 - IF(LFRCKP.AND.CONVIT)THEN 803 - * Format the wire number. 804 - CALL OUTFMT(REAL(IIW),2,AUXSTR,NC,'LEFT') 805 - * Assign the results to globals. 806 - ISIZ(1)=NSCANX 807 - ISIZ(2)=NSCANY 808 - IDIM(1)=MXGRID 809 - IDIM(2)=MXGRID 810 - CALL MT2SAV(FX,2,IDIM,ISIZ,'FX_'//AUXSTR(1:NC),IFAIL1) 811 - CALL MT2SAV(FY,2,IDIM,ISIZ,'FY_'//AUXSTR(1:NC),IFAIL2) 812 - ISIZ(1)=NSCANX 813 - IDIM(1)=MXGRID 814 - CALL MT2SAV(XSCAN,1,IDIM,ISIZ, 815 - - 'X_F_'//AUXSTR(1:NC),IFAIL3) 816 - ISIZ(1)=NSCANY 817 - IDIM(1)=MXGRID 818 - CALL MT2SAV(YSCAN,1,IDIM,ISIZ, 819 - - 'Y_F_'//AUXSTR(1:NC),IFAIL4) 820 - * Check the error condition. 821 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND. 822 - - IFAIL3.EQ.0.AND.IFAIL4.EQ.0)THEN 823 - PRINT *,' ------ OUTFRC MESSAGE : Force table'// 824 - - ' of wire '//AUXSTR(1:NC)//' saved as' 825 - PRINT *,' FX_'//AUXSTR(1:NC)// 826 - - ', FY_'//AUXSTR(1:NC)//', X_F_'//AUXSTR(1:NC)// 827 - - ' and Y_F_'//AUXSTR(1:NC)//'.' 828 - ELSE 829 - PRINT *,' !!!!!! OPTFRC WARNING : Saving the force'// 830 - - ' table failed.' 831 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 832 - ENDIF 833 - ENDIF 834 - *** Compute the detailed wire shift. 835 - NSAG=MXLIST 836 - CALL OPTSAG(IIW,'PARABOLIC',CSAG,XSAG,YSAG,NSAG,IFAIL1) 837 - C CALL OPTSAG(IIW,'RANDOM',CSAG,XSAG,YSAG,NSAG,IFAIL1) 838 - * Check error status. 839 - IF(IFAIL1.NE.0.OR.NSAG.LE.0)THEN 840 - PRINT *,' !!!!!! OPTFRC WARNING : Computation of the'// 841 - - ' wire sag failed; wire ',IIW,' skipped.' 842 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 843 - GOTO 20 844 - ENDIF 845 - * And compute mean and maximum sag, verify that the wire is in range. 846 - XSAGMI=XSAG(0) 847 - YSAGMI=YSAG(0) 848 - XSAGMX=XSAG(0) 849 - YSAGMX=YSAG(0) 850 - XSAGAV=0 851 - YSAGAV=0 852 - INAREA=.TRUE. 853 - DO 210 I=0,NSAG 854 - IF(I.EQ.0)THEN 855 - WLENG=0 856 - ELSE 857 - WLENG=WLENG+SQRT((XSAG(I)-XSAG(I-1))**2+ 858 - - (YSAG(I)-YSAG(I-1))**2+(CSAG(I)-CSAG(I-1))**2) 859 - ENDIF 860 - IF(XORIG(IIW)+XSAG(I).LT.SXMIN.OR. 861 - - XORIG(IIW)+XSAG(I).GT.SXMAX.OR. 862 - - YORIG(IIW)+YSAG(I).LT.SYMIN.OR. 863 - - YORIG(IIW)+YSAG(I).GT.SYMAX)INAREA=.FALSE. 864 - XSAGMI=MIN(XSAGMI,XSAG(I)) 865 - YSAGMI=MIN(YSAGMI,YSAG(I)) 866 - XSAGMX=MAX(XSAGMX,XSAG(I)) 867 - YSAGMX=MAX(YSAGMX,YSAG(I)) 868 - XSAGAV=XSAGAV+XSAG(I) 869 - YSAGAV=YSAGAV+YSAG(I) 870 - 210 CONTINUE 871 - XSAGAV=XSAGAV/REAL(NSAG+1) 872 - YSAGAV=YSAGAV/REAL(NSAG+1) 873 - * Update the wire offset vector. 874 - CORMAX=MAX(CORMAX,ABS(XSAGAV-XOFF(IIW)),ABS(YSAGAV-YOFF(IIW))) 875 - XOFF(IIW)=XSAGAV 876 - YOFF(IIW)=YSAGAV 877 - * Warn if a point outside the scanning area was found. 878 - IF(.NOT.INAREA)THEN 879 - PRINT *,' !!!!!! OPTFRC WARNING : The wire profile is'// 880 - - ' located partially outside the scanning area.' 881 - ENDIF 882 - *** If required, print the wire sag. 883 - IF(LSAGPR.AND.CONVIT)THEN 884 - CALL OUTFMT(REAL(IIW),2,AUX1,NC1,'LEFT') 885 - CALL OUTFMT(V(IIW),2,AUX2,NC2,'LEFT') 886 - CALL OUTFMT(U(IIW),2,AUX3,NC3,'LEFT') 887 - CALL OUTFMT(W(IIW),2,AUX4,NC4,'LEFT') 888 - CALL OUTFMT(DENS(IIW),2,AUX5,NC5,'LEFT') 889 - CALL OUTFMT(XORIG(IIW),2,AUX6,NC6,'LEFT') 890 - CALL OUTFMT(YORIG(IIW),2,AUX7,NC7,'LEFT') 891 - CALL OUTFMT(XSAGAV,2,AUX8,NC8,'LEFT') 892 - CALL OUTFMT(YSAGAV,2,AUX9,NC9,'LEFT') 893 - CALL OUTFMT(MAX(ABS(XSAGMX),ABS(XSAGMI)),2, 894 - - AUX10,NC10,'LEFT') 895 - CALL OUTFMT(MAX(ABS(YSAGMX),ABS(YSAGMI)),2, 896 - - AUX11,NC11,'LEFT') 897 - CALL OUTFMT(100*REAL(WLENG-U(IIW))/U(IIW),2, 898 - - AUX12,NC12,'LEFT') 899 - WRITE(LUNOUT,'('' SAG PROFILE FOR WIRE '',A,'' (TYPE '',A1, 900 - - '')''// 901 - - '' Wire voltage: '',A,'' V''/ 902 - - '' Wire length: '',A,'' cm''/ 903 - - '' Wire stretching weight: '',A,'' g''/ 904 - - '' Wire density: '',A,'' g/cm3''/ 1 495 P=OPTIMISE D=OPTFRC 10 PAGE 716 905 - - '' Nominal wire position: ('',A,'','',A,'') cm''// 906 - - '' Average sag in x and y: '',A,'' and '',A,'' cm''/ 907 - - '' Maximum sag in x and y: '',A,'' and '',A,'' cm''/ 908 - - '' Elongation: '',A,'' %''// 909 - - '' Point z [cm] x-sag [cm]'', 910 - - '' y-sag [cm]''/)') 911 - - AUX1(1:NC1),WIRTYP(IIW),AUX2(1:NC2),AUX3(1:NC3), 912 - - AUX4(1:NC4),AUX5(1:NC5),AUX6(1:NC6),AUX7(1:NC7), 913 - - AUX8(1:NC8),AUX9(1:NC9),AUX10(1:NC10),AUX11(1:NC11), 914 - - AUX12(1:NC12) 915 - DO 200 I=0,NSAG 916 - WRITE(LUNOUT,'(I7,3(2X,E12.5))') I,CSAG(I),XSAG(I),YSAG(I) 917 - 200 CONTINUE 918 - ENDIF 919 - *** Plot the wire profile, if requested. 920 - IF(LSAGPL.AND.CONVIT)THEN 921 - * Open a frame. 922 - CALL GRCART(CSAG(0),MIN(XSAGMI,YSAGMI)- 923 - - 0.1*(MAX(XSAGMX,YSAGMX)-MIN(XSAGMI,YSAGMI)), 924 - - CSAG(NSAG),MAX(XSAGMX,YSAGMX)+ 925 - - 0.1*(MAX(XSAGMX,YSAGMX)-MIN(XSAGMI,YSAGMI)), 926 - - 'z [cm]','Sag [cm]','Wire profile') 927 - * Add some comments to the plot. 928 - CALL OUTFMT(REAL(IIW),2,AUXSTR,NC,'LEFT') 929 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 930 - CALL GRCOMM(2,'Wire: '//AUXSTR(1:NC)//' ('// 931 - - WIRTYP(IIW)//')') 932 - * Plot the curves. 933 - CALL GRATTS('FUNCTION-1','POLYLINE') 934 - CALL GRLINE(NSAG+1,CSAG(0),XSAG(0)) 935 - CALL GRATTS('FUNCTION-2','POLYLINE') 936 - CALL GRLINE(NSAG+1,CSAG(0),YSAG(0)) 937 - * Register the plot. 938 - CALL GRALOG('Sag profile of wire '//AUXSTR(1:NC)//':') 939 - * Close the frame. 940 - CALL GRNEXT 941 - ENDIF 942 - *** Save the results if requested. 943 - IF(LSAGKP.AND.CONVIT)THEN 944 - * Format the wire number. 945 - CALL OUTFMT(REAL(IIW),2,AUXSTR,NC,'LEFT') 946 - * Assign the results to globals. 947 - ISIZ(1)=NSAG+1 948 - IDIM(1)=MXLIST+1 949 - CALL MATSAV(CSAG(0),1,IDIM,ISIZ, 950 - - 'Z_'//AUXSTR(1:NC),IFAIL1) 951 - CALL MATSAV(XSAG(0),1,IDIM,ISIZ, 952 - - 'SAG_X_'//AUXSTR(1:NC),IFAIL2) 953 - CALL MATSAV(YSAG(0),1,IDIM,ISIZ, 954 - - 'SAG_Y_'//AUXSTR(1:NC),IFAIL3) 955 - CALL NUMSAV(REAL((WLENG-U(IIW))/U(IIW)), 956 - - 'STRETCH_'//AUXSTR(1:NC),IFAIL4) 957 - * Check the error condition. 958 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND. 959 - - IFAIL3.EQ.0.AND.IFAIL4.EQ.0)THEN 960 - PRINT *,' ------ OUTFRC MESSAGE : Sag profile'// 961 - - ' of wire '//AUXSTR(1:NC)//' saved as' 962 - PRINT *,' Z_'//AUXSTR(1:NC)// 963 - - ', SAG_X_'//AUXSTR(1:NC)//', SAG_Y_'// 964 - - AUXSTR(1:NC)//' and STRETCH_'//AUXSTR(1:NC)//'.' 965 - ELSE 966 - PRINT *,' !!!!!! OPTFRC WARNING : Saving the results'// 967 - - ' failed.' 968 - ENDIF 969 - ENDIF 970 - *** Check for wire stability. 971 - IF(LSTAB)THEN 972 - CALL OPTENM 973 - ENDIF 974 - *** Next wire. 975 - 20 CONTINUE 976 - *** If iteration over all wires was requested ... 977 - IF(LFITER.AND..NOT.CONVIT)THEN 978 - * Print current status. 979 - WRITE(LUNOUT,'('' Iteration '',I3/)') ITER 980 - DO 1050 I=1,NWIRE 981 - IF(INDSW(I).EQ.0)GOTO 1050 982 - WRITE(LUNOUT,'('' Wire '',I3,'' moves on average by ('', 983 - - E12.5,'','',E12.5,'') cm'')') I,XOFF(I),YOFF(I) 984 - 1050 CONTINUE 985 - WRITE(LUNOUT,'(/'' Largest average shift: '',E12.5, 986 - - '' cm.'')') CORMAX 987 - * Check convergence, send for a last round if needed. 988 - IF(CORMAX.LE.TOLER)THEN 989 - WRITE(LUNOUT,'('' Convergence achieved.'')') 990 - CONVIT=.TRUE. 991 - GOTO 1000 992 - ELSEIF(ITER.LT.NFITER)THEN 993 - GOTO 1000 994 - ELSE 995 - WRITE(LUNOUT,'('' Maximum number if iterations'', 996 - - '' reached - iteration stopped.'')') 997 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 998 - ENDIF 999 - ENDIF 1000 - *** Restore the initial situation. 1001 - DO 1100 I=1,NWIRE 1002 - X(I)=XORIG(I) 1003 - Y(I)=YORIG(I) 1004 - 1100 CONTINUE 1005 - CALL SETUP(IFAIL) 1006 - IF(IFAIL.NE.0)THEN 1007 - PRINT *,' ###### OPTFRC ERROR : Unable to'// 1008 - - ' restore the initial configuration.' 1009 - PRINT *,' Setting the'// 1010 - - ' number of wires to 0.' 1 495 P=OPTIMISE D=OPTFRC 11 PAGE 717 1011 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 1012 - NWIRE=0 1013 - ENDIF 1014 - *** Register the amount of CPU time used with TIMLOG. 1015 - CALL TIMLOG('Computing forces on the wires: ') 1016 - *** Normal end of the routine. 1017 - RETURN 1018 - *** Handle I/O errors. 1019 - 2010 CONTINUE 1020 - PRINT *,' ###### OPTFRC ERROR : Error writing the force'// 1021 - - ' table on unit ',LUNOUT,' ; output terminated.' 1022 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 1023 - CALL INPIOS(IOS) 1024 - END 496 GARFIELD ================================================== P=OPTIMISE D=OPTSAG 1 ============================ 0 + +DECK,OPTSAG. 1 - SUBROUTINE OPTSAG(IWIRE,START,CSAG,XSAG,YSAG,NSAG,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * OPTSAG - Computes the wire sag due to eletrostatic and gravitational 4 - * forces, using a Runge-Kutta-Nystrom multiple shoot method, 5 - * where the intermediate conditions are imposed through a 6 - * Broyden rank-1 zero search. 7 - * (Last changed on 13/ 4/99.) 8 - *----------------------------------------------------------------------- 9 - IMPLICIT DOUBLE PRECISION (A-H,O-Z) 10.- +SEQ,DIMENSIONS. 11.- +SEQ,PRINTPLOT. 12.- +SEQ,SHAPEDATA. 13.- +SEQ,CELLDATA. 14.- +SEQ,CONSTANTS. 15 - INTEGER IFAIL,IFAIL1,NSAG,I 16 - CHARACTER*(*) START 17 - REAL CSAG(0:*),XSAG(0:*),YSAG(0:*),RNDM 18 - DOUBLE PRECISION COOR,XST(2),DXST(2),WORK(12),XX(4*MXSHOT+2), 19 - - FXMEAN,FYMEAN,SAGX0,SAGY0,FORCE(2) 20 - EXTERNAL OPTSHT,OPTSTP,RNDM 21 - *** Assume the routine will fail. 22 - IFAIL=1 23 - *** Check the values of the parameters. 24 - IF(IWIRE.LE.0.OR.IWIRE.GT.NWIRE)THEN 25 - PRINT *,' !!!!!! OPTSAG WARNING : Wire number out of'// 26 - - ' range; sag not computed.' 27 - RETURN 28 - ELSEIF(NSAG.LT.NSTEP*(NSHOT+1))THEN 29 - PRINT *,' !!!!!! OPTSAG WARNING : Output arrays are'// 30 - - ' too small; sag not computed.' 31 - RETURN 32 - ENDIF 33 - *** Copy the wire number to the common block. 34 - IW=IWIRE 35 - *** Temporarily set the number of output values to 0. 36 - NSAG=0 37 - *** Compute the step width based on the number of steps. 38 - STEP=DBLE(U(IW))/DBLE(NSTEP*(NSHOT+1)) 39 - *** Compute expected maximum sag, constant-force approximation. 40 - XST(1)=0 41 - XST(2)=0 42 - DXST(1)=0 43 - DXST(2)=0 44 - FXMEAN=0 45 - FYMEAN=0 46 - * Check whether there is extrapolation. 47 - LFWARN=.FALSE. 48 - * Loop over the whole wire. 49 - DO 40 I=0,NSTEP*(NSHOT+1) 50 - COOR=I*STEP 51 - CALL OPTSTP(COOR,XST,DXST,FORCE) 52 - FXMEAN=FXMEAN+FORCE(1) 53 - FYMEAN=FYMEAN+FORCE(2) 54 - 40 CONTINUE 55 - * Check the extrapolation warning flag. 56 - IF(LFWARN)THEN 57 - PRINT *,' !!!!!! OPTSAG WARNING : Wire at nominal'// 58 - - ' position outside scanning area; no sag calculated.' 59 - RETURN 60 - ENDIF 61 - * Compute expected sag. 62 - SAGX0=-FXMEAN*DBLE(U(IW))**2/DBLE(8*(1+NSTEP*(NSHOT+1))) 63 - SAGY0=-FYMEAN*DBLE(U(IW))**2/DBLE(8*(1+NSTEP*(NSHOT+1))) 64 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTSAG DEBUG :'', 65 - - '' Parabolic sag dx='',E12.5,'', dy='',E12.5,'' [cm]'')') 66 - - SAGX0,SAGY0 67 - *** Starting position: parabolic sag. 68 - IF(START.EQ.'PARABOLIC')THEN 69 - * Derivative first point. 70 - XX(1)=4*SAGX0/U(IW) 71 - XX(2)=4*SAGY0/U(IW) 72 - * Intermediate points, both position and derivative. 73 - DO 10 I=1,NSHOT 74 - * Position. 75 - COOR=I*NSTEP*STEP-U(IW)/2 76 - * Deflection. 77 - XX(4*I-1)=SAGX0*(1-4*COOR**2/U(IW)**2) 78 - XX(4*I)=SAGY0*(1-4*COOR**2/U(IW)**2) 79 - * Derivative. 80 - XX(4*I+1)=-8*SAGX0*COOR/U(IW)**2 81 - XX(4*I+2)=-8*SAGY0*COOR/U(IW)**2 82 - 10 CONTINUE 83 - *** Starting position: random position. 84 - ELSEIF(START.EQ.'RANDOM')THEN 85 - DO 15 I=1,4*NSHOT+2 86 - * Derivatives. 87 - IF(I-1.EQ.4*((I-1)/4).OR.I-2.EQ.4*((I-2)/4))THEN 88 - XX(I)=RNDM(I)-0.5 1 496 P=OPTIMISE D=OPTSAG 2 PAGE 718 89 - * Positions. 90 - ELSE 91 - XX(I)=0.1*(RNDM(I)-0.5)*U(IW) 92 - ENDIF 93 - 15 CONTINUE 94 - *** Unknown starting position. 95 - ELSE 96 - PRINT *,' !!!!!! OPTSAG WARNING : Unknown starting'// 97 - - ' choice received ; no sag calculated.' 98 - RETURN 99 - ENDIF 100 - *** Search for solution. 101 - CALL OPTZRO(OPTSHT,XX,4*NSHOT+2,IFAIL1) 102 - IF(IFAIL1.NE.0)THEN 103 - PRINT *,' !!!!!! OPTSAG WARNING : Failed to solve'// 104 - - ' the differential equation for the sag; no'// 105 - - ' sag returned.' 106 - RETURN 107 - ENDIF 108 - *** And return the detailed solution, first the starting point. 109 - CSAG(0)=-U(IW)/2 110 - XSAG(0)=0 111 - YSAG(0)=0 112 - COOR=-U(IW)/2 113 - DO 30 I=0,NSHOT 114 - * Set the starting value and starting derivative. 115 - IF(I.EQ.0)THEN 116 - XST(1)=0 117 - XST(2)=0 118 - DXST(1)=XX(1) 119 - DXST(2)=XX(2) 120 - ELSE 121 - XST(1)=XX(4*I-1) 122 - XST(2)=XX(4*I) 123 - DXST(1)=XX(4*I+1) 124 - DXST(2)=XX(4*I+2) 125 - ENDIF 126 - * Store the intermediate values. 127 - DO 20 J=1,NSTEP 128 - CALL DRKNYS(2,STEP,COOR,XST,DXST,OPTSTP,WORK) 129 - CSAG(I*NSTEP+J)=COOR 130 - XSAG(I*NSTEP+J)=XST(1) 131 - YSAG(I*NSTEP+J)=XST(2) 132 - 20 CONTINUE 133 - 30 CONTINUE 134 - *** Seems to have worked. 135 - NSAG=NSTEP*(NSHOT+1) 136 - IFAIL=0 137 - END 497 GARFIELD ================================================== P=OPTIMISE D=OPTSHT 1 ============================ 0 + +DECK,OPTSHT. 1 - SUBROUTINE OPTSHT(XX,F,N) 2 - *----------------------------------------------------------------------- 3 - * OPTSHT - Auxiliary routine for the wire sag routines which computes 4 - * for a given set of positions and derivatives the next set 5 - * which is used by OPTZRO to match the sections. Uses a 6 - * 2nd order Runge-Kutta-Nystrom integration routine (D203). 7 - * (Last changed on 1/ 5/96.) 8 - *----------------------------------------------------------------------- 9 - IMPLICIT DOUBLE PRECISION (A-H,O-Z) 10.- +SEQ,DIMENSIONS. 11.- +SEQ,PRINTPLOT. 12.- +SEQ,SHAPEDATA. 13.- +SEQ,CELLDATA. 14 - DOUBLE PRECISION XX(4*MXSHOT+2),F(*),COOR,XST(2),DXST(2),WORK(12) 15 - INTEGER N,I,J 16 - EXTERNAL OPTSTP 17 - *** For the starting set in XX, compute the next round. 18 - COOR=-U(IW)/2 19 - DO 10 I=0,NSHOT 20 - * Set the starting value and starting derivative. 21 - IF(I.EQ.0)THEN 22 - XST(1)=0 23 - XST(2)=0 24 - DXST(1)=XX(1) 25 - DXST(2)=XX(2) 26 - ELSE 27 - XST(1)=XX(4*I-1) 28 - XST(2)=XX(4*I) 29 - DXST(1)=XX(4*I+1) 30 - DXST(2)=XX(4*I+2) 31 - ENDIF 32 - * Compute the end value and end derivative. 33 - DO 20 J=1,NSTEP 34 - CALL DRKNYS(2,STEP,COOR,XST,DXST,OPTSTP,WORK) 35 - 20 CONTINUE 36 - * Store the differences as function value. 37 - IF(I.LT.NSHOT)THEN 38 - F(4*I+1)=XST(1)-XX(4*I+3) 39 - F(4*I+2)=XST(2)-XX(4*I+4) 40 - F(4*I+3)=DXST(1)-XX(4*I+5) 41 - F(4*I+4)=DXST(2)-XX(4*I+6) 42 - ELSE 43 - F(4*NSHOT+1)=XST(1) 44 - F(4*NSHOT+2)=XST(2) 45 - ENDIF 46 - * Next shot. 47 - 10 CONTINUE 48 - END 1 498 GARFIELD ================================================== P=OPTIMISE D=OPTSTP 1 =================== PAGE 719 0 + +DECK,OPTSTP. 1 - SUBROUTINE OPTSTP(COOR,BEND,DBEND,F) 2 - *----------------------------------------------------------------------- 3 - * OPTSTP - Returns the electrostatic and gravitational force divided 4 - * by the stretching force acting on a wire at position COOR, 5 - * with deflection BEND and bending derivative DBEND. 6 - * (Last changed on 25/ 5/96.) 7 - *----------------------------------------------------------------------- 8 - IMPLICIT DOUBLE PRECISION (A-H,O-Z) 9.- +SEQ,DIMENSIONS. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,CELLDATA. 12.- +SEQ,SHAPEDATA. 13.- +SEQ,CONSTANTS. 14 - DOUBLE PRECISION COOR,BEND(2),DBEND(2),F(2),DIVDF2,XAUX(MXGRID), 15 - - YAUX(MXGRID) 16 - EXTERNAL DIVDF2 17 - *** Initialise the forces. 18 - F(1)=0 19 - F(2)=0 20 - *** In case extrapolation is not permitted, check range. 21 - IF((.NOT.LFEXTR).AND. 22 - - (XSCAN(1)-BEND(1)-XORIG(IW))* 23 - - (BEND(1)+XORIG(IW)-XSCAN(NSCANX)).LT.0.OR. 24 - - (YSCAN(1)-BEND(2)-YORIG(IW))* 25 - - (BEND(2)+YORIG(IW)-YSCAN(NSCANY)).LT.0)THEN 26 - LFWARN=.TRUE. 27 - RETURN 28 - ENDIF 29 - *** Electrostatic force: interpolate the table, first along the x-lines 30 - IF(LFELEC)THEN 31 - DO 10 I=1,NSCANY 32 - XAUX(I)=DIVDF2(FX(1,I),XSCAN,NSCANX, 33 - - BEND(1)+DBLE(XORIG(IW)),JSORD) 34 - YAUX(I)=DIVDF2(FY(1,I),XSCAN,NSCANX, 35 - - BEND(1)+DBLE(XORIG(IW)),JSORD) 36 - 10 CONTINUE 37 - * Then along the y-lines. 38 - F(1)=F(1)+DIVDF2(XAUX,YSCAN,NSCANY, 39 - - BEND(2)+DBLE(YORIG(IW)),JSORD) 40 - F(2)=F(2)+DIVDF2(YAUX,YSCAN,NSCANY, 41 - - BEND(2)+DBLE(YORIG(IW)),JSORD) 42 - ENDIF 43 - *** Add the gravity term. 44 - IF(LFGRAV)THEN 45 - F(1)=F(1)-DOWN(1)*GRAV*DENS(IW)*PI*D(IW)**2/4000 46 - F(2)=F(2)-DOWN(2)*GRAV*DENS(IW)*PI*D(IW)**2/4000 47 - ENDIF 48 - *** Divide by the stretching force. 49 - F(1)=1000*F(1)/(GRAV*W(IW)) 50 - F(2)=1000*F(2)/(GRAV*W(IW)) 51 - END 499 GARFIELD ================================================== P=OPTIMISE D=OPTZRO 1 ============================ 0 + +DECK,OPTZRO. 1 - SUBROUTINE OPTZRO(F,X,N,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * OPTZRO - Tries to find zeroes of a set of functions F. Uses the 4 - * Broyden rank-1 update variant of an n-dimensional Newton- 5 - * Raphson zero search in most steps, except every 5th step 6 - * and whenever the step length update becomes less than 0.5, 7 - * when a new derivative is computed. 8 - * (Last changed on 29/ 4/96.) 9 - *----------------------------------------------------------------------- 10 - IMPLICIT DOUBLE PRECISION (A-H,O-Z) 11.- +SEQ,DIMENSIONS. 12.- +SEQ,PRINTPLOT. 13.- +SEQ,SHAPEDATA. 14 - INTEGER N,IFAIL,IFAIL1,IWORK(MXZPAR),NBSMAX,NIT,NFC 15 - DOUBLE PRECISION X(*),B(MXZPAR,MXZPAR),BB(MXZPAR,MXZPAR),EPSDIF, 16 - - AUX1(MXZPAR),AUX2(MXZPAR),AUX3(MXZPAR),FOLD(MXZPAR), 17 - - SCALE,XNORM,DXNORM,FNORM,FNORML,DFNORM 18 - EXTERNAL F 19 - PARAMETER(NBSMAX=10) 20 - *** Identification and debugging output. 21 - IF(LIDENT)PRINT *,' /// ROUTINE OPTZRO ///' 22 - *** Assume this will fail. 23 - IFAIL=1 24 - *** Extrapolation warning. 25 - LFWARN=.FALSE. 26 - *** Check the value of N. 27 - IF(N.LT.1.OR.N.GT.MXZPAR)THEN 28 - PRINT *,' !!!!!! OPTZRO WARNING : Number of points not'// 29 - - ' in the range [1,MXZPAR]; no zero search.' 30 - RETURN 31 - ENDIF 32 - *** Initial deviation. 33 - FNORML=0 34 - CALL F(X,FOLD,N) 35 - IF(LFWARN.AND..NOT.LFEXTR)THEN 36 - PRINT *,' !!!!!! OPTZRO WARNING : Zero search stopped:'// 37 - - ' initial position outside scanning area.' 38 - RETURN 39 - ENDIF 40 - DO 70 I=1,N 41 - FNORML=FNORML+FOLD(I)**2 42 - 70 CONTINUE 43 - *** Debugging output for initial situation. 44 - IF(LDEBUG)THEN 45 - WRITE(LUNOUT,'('' ++++++ OPTZRO DEBUG : Start of'', 46 - - '' zero search.''// 47 - - 26X,''Number of parameters: '',I4/ 48 - - 26X,''Maximum bisections: '',I4/ 49 - - 26X,''Maximum iterations: '',I4/ 50 - - 26X,''Epsilon differentation: '',E12.5/ 1 499 P=OPTIMISE D=OPTZRO 2 PAGE 720 51 - - 26X,''Required location change: '',E12.5/ 52 - - 26X,''Required function norm: '',E12.5// 53 - - 26X,''Initial function norm: '',E12.5// 54 - - 26X,''Parameter Value Function'')') 55 - - N,NBSMAX,NITMAX,EPS,EPSX,EPSF,SQRT(FNORML) 56 - DO 300 I=1,N 57 - WRITE(LUNOUT,'(26X,I9,1X,E12.5,1X,E12.5)') 58 - - I,X(I),FOLD(I) 59 - 300 CONTINUE 60 - ENDIF 61 - *** Set number of iterations. 62 - NIT=0 63 - *** Set number of function calls. 64 - NFC=0 65 - *** Compute derivative matrix. 66 - 200 CONTINUE 67 - DO 10 I=1,N 68 - EPSDIF=EPS*(1+ABS(X(I))) 69 - X(I)=X(I)+EPSDIF/2 70 - CALL F(X,AUX1,N) 71 - X(I)=X(I)-EPSDIF 72 - CALL F(X,AUX2,N) 73 - X(I)=X(I)+EPSDIF/2 74 - IF(LFWARN.AND..NOT.LFEXTR)THEN 75 - PRINT *,' !!!!!! OPTZRO WARNING : Zero search stopped:'// 76 - - ' differential matrix requires a point outside'// 77 - - ' scanning area.' 78 - RETURN 79 - ENDIF 80 - DO 20 J=1,N 81 - B(J,I)=(AUX1(J)-AUX2(J))/EPSDIF 82 - 20 CONTINUE 83 - 10 CONTINUE 84 - 210 CONTINUE 85 - NFC=NFC+2*N 86 - *** Next iteration. 87 - NIT=NIT+1 88 - IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Start of iteration '',I5)') NIT 89 - IF(LZROPR)THEN 90 - WRITE(LUNOUT,'('' Start of iteration '',I5)') NIT 91 - WRITE(LUNOUT,'('' x ='',5E12.5:(/5X,5E12.5))') 92 - - (X(3+4*I),I=0,NSHOT-1) 93 - WRITE(LUNOUT,'('' y ='',5E12.5:(/5X,5E12.5))') 94 - - (X(4+4*I),I=0,NSHOT-1) 95 - ENDIF 96 - *** Find the correction vector to 0th order, AUX1: f. 97 - DO 30 I=1,N 98 - AUX1(I)=FOLD(I) 99 - DO 35 J=1,N 100 - BB(I,J)=B(I,J) 101 - 35 CONTINUE 102 - 30 CONTINUE 103 - CALL DEQN(N,BB,MXZPAR,IWORK,IFAIL1,1,AUX1) 104 - * Check error condition, AUX1: correction vector. 105 - IF(IFAIL1.NE.0)THEN 106 - PRINT *,' !!!!!! OPTZRO WARNING : Solving the update'// 107 - - ' equation failed; zero search stopped.' 108 - GOTO 1000 109 - ENDIF 110 - IF(LZROPR)THEN 111 - WRITE(LUNOUT,'('' dx='',5E12.5:(/5X,5E12.5))') 112 - - (AUX1(3+4*I),I=0,NSHOT-1) 113 - WRITE(LUNOUT,'('' dy='',5E12.5:(/5X,5E12.5))') 114 - - (AUX1(4+4*I),I=0,NSHOT-1) 115 - ENDIF 116 - *** Scale the correction vector to improve FNORM, AUX3: f. 117 - SCALE=1 118 - DO 60 ITER=1,NBSMAX 119 - DO 40 I=1,N 120 - AUX2(I)=X(I)-SCALE*AUX1(I) 121 - 40 CONTINUE 122 - CALL F(AUX2,AUX3,N) 123 - IF(LFWARN.AND..NOT.LFEXTR)THEN 124 - PRINT *,' !!!!!! OPTZRO WARNING : Zero search stopped:'// 125 - - ' step update leads to a point outside the'// 126 - - ' scanning area.' 127 - RETURN 128 - ENDIF 129 - NFC=NFC+1 130 - FNORM=0 131 - DO 50 I=1,N 132 - FNORM=FNORM+AUX3(I)**2 133 - 50 CONTINUE 134 - IF(FNORM.LE.FNORML)THEN 135 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Scaling factor: '',E12.5)') 136 - - SCALE 137 - GOTO 80 138 - ENDIF 139 - SCALE=SCALE/2 140 - 60 CONTINUE 141 - PRINT *,' !!!!!! OPTZRO WARNING : Bisection search for scaling'// 142 - - ' factor did not converge ; zero search stopped.' 143 - GOTO 1000 144 - *** Update the estimate, AUX1: dx, AUX2: df, AUX3: f_new. 145 - 80 CONTINUE 146 - * Initial values of norms. 147 - XNORM=0 148 - DXNORM=0 149 - DFNORM=0 150 - * Loop over the vectors. 151 - DO 90 I=1,N 152 - AUX1(I)=AUX2(I)-X(I) 153 - DXNORM=DXNORM+AUX1(I)**2 154 - X(I)=AUX2(I) 155 - XNORM=XNORM+X(I)**2 156 - AUX2(I)=AUX3(I)-FOLD(I) 1 499 P=OPTIMISE D=OPTZRO 3 PAGE 721 157 - DFNORM=DFNORM+AUX2(I)**2 158 - FOLD(I)=AUX3(I) 159 - 90 CONTINUE 160 - * Debugging output to show current status. 161 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''After this iteration, ''/ 162 - - 26X,''Norm and change of position: '',2E12.5/ 163 - - 26X,''Norm and change of function: '',2E12.5)') 164 - - SQRT(XNORM),SQRT(DXNORM),SQRT(FNORM),SQRT(DFNORM) 165 - *** See whether convergence has been achieved. 166 - IF(SQRT(DXNORM).LT.EPSX*SQRT(XNORM))THEN 167 - IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Positional convergence'', 168 - - '' criterion is satisfied.'')') 169 - IFAIL=0 170 - GOTO 1000 171 - ELSEIF(SQRT(FNORM).LT.EPSF)THEN 172 - IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Function value'', 173 - - '' convergence criterion is satisfied.'')') 174 - IFAIL=0 175 - GOTO 1000 176 - ENDIF 177 - *** Update the difference. 178 - FNORML=FNORM 179 - *** If the scaling factor is small, then update (rank-1 Broyden). 180 - IF(SCALE.GT.0.4.AND.NIT.NE.5*(NIT/5))THEN 181 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Performing a Broyden'', 182 - - '' rank-1 update.'')') 183 - * Compute the "df - B dx" term, "dx" is still in AUX1 184 - DO 100 I=1,N 185 - AUX3(I)=AUX2(I) 186 - DO 110 J=1,N 187 - AUX3(I)=AUX3(I)-B(I,J)*AUX1(J) 188 - 110 CONTINUE 189 - 100 CONTINUE 190 - * Update the matrix. 191 - DO 120 I=1,N 192 - DO 130 J=1,N 193 - B(I,J)=B(I,J)+AUX3(I)*AUX1(J)/DXNORM 194 - 130 CONTINUE 195 - 120 CONTINUE 196 - * And restart the iteration from the matrix solution. 197 - IF(NIT.LE.NITMAX)GOTO 210 198 - *** Otherwise, recompute the differential. 199 - ELSE 200 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Recomputing the covariance'', 201 - - '' matrix.'')') 202 - IF(NIT.LE.NITMAX)GOTO 200 203 - ENDIF 204 - *** Ending here means that the process didn't converge. 205 - PRINT *,' !!!!!! OPTZRO WARNING : Zero search did not'// 206 - - ' convergence in maximum number of loops.' 207 - *** Final debugging output. 208 - 1000 CONTINUE 209 - IF(LDEBUG)THEN 210 - CALL F(X,AUX1,N) 211 - NFC=NFC+1 212 - WRITE(LUNOUT,'(26X,''Final values: ''// 213 - - 26X,''Parameter Value Function'')') 214 - DO 1010 I=1,N 215 - WRITE(LUNOUT,'(26X,I9,1X,E12.5,1X,E12.5)') 216 - - I,X(I),AUX1(I) 217 - 1010 CONTINUE 218 - WRITE(LUNOUT,'(26X,''Total number of function calls: '',I5/ 219 - - 26X,''End of debugging output.'')') NFC 220 - ENDIF 221 - END 500 GARFIELD ================================================== P=OPTIMISE D=OPTSTB 1 ============================ 0 + +DECK,OPTSTB. 1 - SUBROUTINE OPTSTB(CSAG,XSAG,YSAG,NSAG,DIST,PHI) 2 - *----------------------------------------------------------------------- 3 - * OPTSTB - Checks whether a wire location is stable or labile. 4 - *----------------------------------------------------------------------- 5 - implicit none 6.- +SEQ,DIMENSIONS. 7.- +SEQ,CELLDATA. 8.- +SEQ,SHAPEDATA. 9.- +SEQ,CONSTANTS. 10 - INTEGER I,NSAG 11 - REAL CSAG(0:NSAG+1),XSAG(0:NSAG+1),YSAG(0:NSAG+1),DIST,PHI, 12 - - WI,WMIN,WMAX 13 - DOUBLE PRECISION COOR,BEND(2),DBEND(2),F0(2),F1(2) 14 - *** Loop over the shape. 15 - DO 10 I=1,NSAG 16 - * Compute the force at the nominal position. 17 - COOR=CSAG(I) 18 - BEND(1)=XSAG(I) 19 - BEND(2)=YSAG(I) 20 - DBEND(1)=0 21 - DBEND(2)=0 22 - CALL OPTSTP(COOR,BEND,DBEND,F0) 23 - * Compute the force at the offset location. 24 - COOR=CSAG(I) 25 - BEND(1)=XSAG(I)+COS(PHI)*DIST*(1-(CSAG(I)/CSAG(0))**2) 26 - BEND(2)=YSAG(I)+SIN(PHI)*DIST*(1-(CSAG(I)/CSAG(0))**2) 27 - DBEND(1)=0 28 - DBEND(2)=0 29 - CALL OPTSTP(COOR,BEND,DBEND,F1) 30 - * Minimum tension to keep in place. 31 - WI=W(IW)*U(IW)**2* 32 - - (COS(PHI)*(F1(1)-F0(1))+SIN(PHI)*(F1(2)-F0(2)))/(8*DIST) 33 - print *,' Point ',I,' required weight: ',WI 34 - * Update limits. 35 - IF(I.EQ.1)THEN 36 - WMIN=WI 37 - WMAX=WI 1 500 P=OPTIMISE D=OPTSTB 2 PAGE 722 38 - ELSE 39 - WMIN=MIN(WMIN,WI) 40 - WMAX=MAX(WMAX,WI) 41 - ENDIF 42 - 10 CONTINUE 43 - PRINT *,' Checking for direction ',PHI*180/PI, 44 - - ' and distance ',DIST,' for wire ',IW 45 - PRINT *,' Weight needed to keep the wire stable: ', 46 - - WMIN,WMAX 47 - PRINT *,' Currently applied weight: ',W(IW) 48 - END 501 GARFIELD ================================================== P=OPTIMISE D=OPTENM 1 ============================ 0 + +DECK,OPTENM. 1 - SUBROUTINE OPTENM 2 - *----------------------------------------------------------------------- 3 - * OPTENM - Computes the energy of a parabolic wire deflection by a 4 - * distance (DX,DY). 5 - * (Last changed on 3/12/99.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,SHAPEDATA. 11.- +SEQ,CONSTANTS. 12 - INTEGER NCONT,I,IFAIL,ISIZ(1),IDIM(1) 13 - REAL CMIN,CMAX,XPL(MXLIST),YPL(MXLIST),EPL(MXLIST) 14 - EXTERNAL OPTENE 15 - *** Number of contours. 16 - NCONT=10 17 - *** Contour range. 18 - CMIN=0 19 - CMAX=0 20 - *** Plot a cut of the energy. 21 - if(.true.)then 22 - DO 10 I=1,200 23 - XPL(I)=XORIG(IW) 24 - YPL(I)=YSCAN(1)+(I-1)*(YSCAN(NSCANY)-YSCAN(1))/REAL(200-1) 25 - CALL OPTENE(XPL(I)-XORIG(IW),YPL(I)-YORIG(IW),EPL(I),IFAIL) 26 - 10 CONTINUE 27 - CALL GRGRPH(YPL,EPL,200,'y [cm]','Energy','Vertical shifts') 28 - CALL GRNEXT 29 - * Save the energy. 30 - ISIZ(1)=200 31 - IDIM(1)=MXLIST 32 - CALL MATSAV(YPL,1,IDIM,ISIZ,'OFFSET',IFAIL) 33 - CALL MATSAV(EPL,1,IDIM,ISIZ,'ENERGY',IFAIL) 34 - endif 35 - *** Plot frame. 36 - if(.false.)then 37 - CALL GRCART( 38 - - REAL(XSCAN(1) -XORIG(IW)),REAL(YSCAN(1) -YORIG(IW)), 39 - - REAL(XSCAN(NSCANX)-XORIG(IW)),REAL(YSCAN(NSCANY)-YORIG(IW)), 40 - - 'x-Offset [cm]','y-Offset [cm]','Contours of the energy') 41 - CALL CELLAY( 42 - - REAL(XSCAN(1) -XORIG(IW)),REAL(YSCAN(1) -YORIG(IW)), 43 - - REAL(XSCAN(NSCANX)-XORIG(IW)),REAL(YSCAN(NSCANY)-YORIG(IW))) 44 - *** Plot the energy. 45 - CALL GRCONT(OPTENE,CMIN,CMAX, 46 - - REAL(XSCAN(1) -XORIG(IW)),REAL(YSCAN(1) -YORIG(IW)), 47 - - REAL(XSCAN(NSCANX)-XORIG(IW)),REAL(YSCAN(NSCANY)-YORIG(IW)), 48 - - NCONT,.TRUE.,.FALSE.,.TRUE.) 49 - *** Next plot. 50 - CALL GRNEXT 51 - endif 52 - END 502 GARFIELD ================================================== P=OPTIMISE D=OPTENE 1 ============================ 0 + +DECK,OPTENE. 1 - SUBROUTINE OPTENE(DX,DY,ETOT,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * OPTENE - Computes the energy of a parabolic wire deflection by a 4 - * distance (DX,DY). The energy is scaled by a common factor 5 - * of g * w/1000 of the 2 force components. 6 - * (Last changed on 14/ 8/99.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,SHAPEDATA. 12.- +SEQ,CONSTANTS. 13 - DOUBLE PRECISION XAUX(6),DGMLT2,DDX,DDY 14 - REAL EW,EF,ETOT,DX,DY 15 - INTEGER IFAIL 16 - EXTERNAL DGMLT2,FOPTE2 17 - COMMON /FEODAT/ DDX,DDY 18 - *** Assign the shift to the common for use by the integration routines. 19 - DDX=DBLE(DX) 20 - DDY=DBLE(DY) 21 - *** Compute the deflection energy, integrate over the wire. 22 - EF=REAL(DGMLT2(FOPTE2,DBLE(-U(IW)/2),DBLE(U(IW)/2),3,6,XAUX)) 23 - *** Compute the wire energy. 24 - EW=REAL(8*(DDX**2+DDY**2)/(3*U(IW))) 25 - *** Return the total. 26 - ETOT=EW+EF 27 - *** Has worked. 28 - IFAIL=0 29 - END 1 503 GARFIELD ================================================== P=OPTIMISE D=FOPTE2 1 =================== PAGE 723 0 + +DECK,FOPTE2. 1 - SUBROUTINE FOPTE2(M,U2,F2,XAUX) 2 - *----------------------------------------------------------------------- 3 - * FOPTE2 - Integrates the energy over the wire. 4 - * (Last changed on 12/ 8/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,SHAPEDATA. 10 - DOUBLE PRECISION U2(*),F2(*),XAUX(*),DGMLT1,DDX,DDY 11 - INTEGER L,M 12 - EXTERNAL FOPTE1,DGMLT1 13 - COMMON /FEODAT/ DDX,DDY 14 - *** Loop over the positions. 15 - DO 10 L=1,M 16 - XAUX(2)=U2(L) 17 - F2(L)=DGMLT1(FOPTE1,0.0D0, 18 - - (1-(2*XAUX(2)/U(IW))**2)*SQRT(DDX**2+DDY**2),3,6,X) 19 - 10 CONTINUE 20 - END 504 GARFIELD ================================================== P=OPTIMISE D=FOPTE1 1 ============================ 0 + +DECK,FOPTE1. 1 - SUBROUTINE FOPTE1(M,U1,F1,XAUX) 2 - *----------------------------------------------------------------------- 3 - * FOPTE1 - Integrates the energy over the deflection path. 4 - * (Last changed on 12/ 8/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,SHAPEDATA. 10 - DOUBLE PRECISION U1(*),F1(*),XAUX(*),COOR,BEND(2),DBEND(2),F0(2), 11 - - DDX,DDY 12 - INTEGER L,M 13 - COMMON /FEODAT/ DDX,DDY 14 - *** Loop over the wire delections. 15 - DO 10 L=1,M 16 - * Obtain the deflection. 17 - XAUX(1)=U1(L) 18 - * Set the sag parameters. 19 - COOR=XAUX(2) 20 - BEND(1)=DDX*XAUX(1)/SQRT(DDX**2+DDY**2) 21 - BEND(2)=DDY*XAUX(1)/SQRT(DDX**2+DDY**2) 22 - DBEND(1)=0 23 - DBEND(2)=0 24 - * Compute the force. 25 - CALL OPTSTP(COOR,BEND,DBEND,F0) 26 - * Take the component in the direction of the bend. 27 - F1(L)=(F0(1)*DDX+F0(2)*DDY)/SQRT(DDX**2+DDY**2) 28 - 10 CONTINUE 29 - END 505 GARFIELD ================================================== P=OPTIMISE D=OPTINP 1 ============================ 0 + +DECK,OPTINP. 1 - SUBROUTINE OPTINP 2 - *----------------------------------------------------------------------- 3 - * OPTINP - Routine reading cell optimisation instructions. 4 - * VARIABLES : 5 - * (Last changed on 25/ 3/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,PARAMETERS. 11.- +SEQ,CELLDATA. 12.- +SEQ,BFIELD. 13.- +SEQ,CONSTANTS. 14.- +SEQ,OPTDATA. 15.- +SEQ,DRIFTLINE. 16 - CHARACTER*(MXCHAR) STRING 17 - CHARACTER*10 USER 18 - REAL XPOS,YPOS 19 - INTEGER IDUMMY,NWORD,NC,IFAIL,IFAIL1,IFAIL2,IFAIL3,IFAIL4, 20 - - I,IW,ISW,NPOINR,NGRDXR,NGRDYR,NGRIDR,INPCMP,IREFNO 21 - LOGICAL STDSTR,CHANGE 22 - EXTERNAL STDSTR,INPCMP 0 23-+ +SELF,IF=AST. 24 - EXTERNAL ASTCCH 0 25-+ +SELF. 26 - *** Define some formats. 27 - 1060 FORMAT(/' The plot area is at present ',F10.3,' < r < ',F10.3/ 28 - - ' and ',F10.3,' < phi < ',F10.3/) 29 - 1070 FORMAT(/' The track is delimited by (',2F10.3,') and (', 30 - - 2F10.3,')'/) 31 - 1080 FORMAT(/' The plot area is at present ',F10.3,' < x < ',F10.3/ 32 - - ' and ',F10.3,' < y < ',F10.3/) 33 - 1090 FORMAT(/' The number of grid points is ',I5,' by ',I5,'.'/) 34 - *** Identify the routine. 35 - IF(LIDENT)PRINT *,' /// ROUTINE OPTINP ///' 36 - *** Print a header for this page. 37 - WRITE(*,'(''1'')') 38 - PRINT *,' ================================================' 39 - PRINT *,' ========== Start optimisation section ==========' 40 - PRINT *,' ================================================' 41 - PRINT *,' ' 42 - *** Open a dataset and save the initial setting. 43 - IDUMMY=0 44 - CALL OPTDSN('OPEN',IDUMMY) 45 - CALL OPTDSN('SAVE',IREFNO) 46 - *** Start an input loop. 1 505 P=OPTIMISE D=OPTINP 2 PAGE 724 47 - CALL INPPRM('Optimise','NEW-PRINT') 48 - 10 CONTINUE 49 - CALL INPWRD(NWORD) 0 50-+ +SELF,IF=AST. 51 - *** Set up ASTCCH as the condition handler. 52 - CALL LIB$ESTABLISH(ASTCCH) 0 53-+ +SELF. 54 - CALL INPSTR(1,1,STRING,NC) 55 - *** Skip the line if blank. 56 - IF(NWORD.EQ.0)GOTO 10 57 - *** Return to main program if '&' is the first character. 58 - IF(STRING(1:1).EQ.'&')THEN 59 - * Close the auxilliary file. 60 - CALL OPTDSN('CLOSE',IDUMMY) 61 - RETURN 62 - *** Look for the ADD instruction. 63 - ELSEIF(INPCMP(1,'ADD').NE.0)THEN 64 - CALL OPTADD(CHANGE) 65 - IF(CHANGE)CALL CELRES(IFAIL) 66 - IF(IFAIL.NE.0)THEN 67 - PRINT *,' !!!!!! OPTINP WARNING : The new cell'// 68 - - ' is not acceptable ; leaving &OPTIMISE.' 69 - RETURN 70 - ENDIF 71 - *** Look for the AREA instruction. 72 - ELSEIF(INPCMP(1,'AR#EA').NE.0)THEN 73 - CALL CELVIE(PXMIN,PYMIN,PZMIN,PXMAX,PYMAX,PZMAX) 74 - CALL INPERR 75 - *** Background field. 76 - ELSEIF(INPCMP(1,'BACKGR#OUND-#FIELD').NE.0)THEN 77 - CALL OPTBGF 78 - ELSEIF(INPCMP(1,'DEL#ETE-BACKGR#OUND-#FIELD').NE.0)THEN 79 - IF(IENBGF.NE.0)CALL ALGCLR(IENBGF) 80 - IENBGF=0 81 - *** Look for 3-dimensional charges. 82 - ELSEIF(INPCMP(1,'CHARGE#S').NE.0)THEN 83 - * Print a prompt for interactive mode reading of charges. 84 - IF(STDSTR('INPUT'))PRINT *,' ====== OPTINP INPUT :'// 85 - - ' Please enter the charges, terminate with a'// 86 - - ' blank line.' 87 - CALL INPPRM('Charges','ADD-NOPRINT') 88 - * Initialise number of charges. 89 - N3D=0 90 - 20 CONTINUE 91 - * Input a line and check the basics. 92 - CALL INPWRD(NWORD) 93 - IF(N3D.GE.MX3D)THEN 94 - PRINT *,' !!!!!! OPTINP WARNING : Unable to store'// 95 - - ' further charges ; increase MX3D.' 96 - ELSEIF(NWORD.EQ.3.OR.NWORD.EQ.4)THEN 97 - N3D=N3D+1 98 - CALL INPCHK(1,2,IFAIL1) 99 - CALL INPCHK(2,2,IFAIL2) 100 - CALL INPCHK(3,2,IFAIL3) 101 - CALL INPRDR(1,X3D(N3D),0.0) 102 - CALL INPRDR(2,Y3D(N3D),0.0) 103 - CALL INPRDR(3,Z3D(N3D),0.0) 104 - IF(NWORD.EQ.4)THEN 105 - CALL INPCHK(4,2,IFAIL4) 106 - CALL INPRDR(4,E3D(N3D),1.0) 107 - ELSE 108 - IFAIL4=0 109 - E3D(N3D)=1.0 110 - ENDIF 111 - CALL INPERR 112 - ELSEIF(NWORD.GT.0)THEN 113 - PRINT *,' !!!!!! OPTINP WARNING : Incorrect number'// 114 - - ' of keywords ; ignoring this charge.' 115 - ENDIF 116 - IF(NWORD.NE.0)GOTO 20 117 - CALL INPPRM(' ','BACK-PRINT') 118 - *** Look for the DELETE-CHARGES instruction. 119 - ELSEIF(INPCMP(1,'DEL#ETE-CHA#RGES').NE.0)THEN 120 - N3D=0 121 - *** Look for the LIST-CHARGES instruction. 122 - ELSEIF(INPCMP(1,'L#IST-CHA#RGES').NE.0)THEN 123 - IF(N3D.EQ.0)THEN 124 - WRITE(LUNOUT,'('' No three dimensional charges'', 125 - - '' are present at the moment.'')') 126 - ELSE 127 - WRITE(LUNOUT,'('' LIST OF 3-DIMENSIONAL CHARGES''// 128 - - '' x-charge [cm] y-charge [cm]'', 129 - - '' z-charge [cm] Q [4 pi eps0]''//)') 130 - DO 40 I=1,N3D 131 - WRITE(LUNOUT,'(1X,4(1X,E15.8))') 132 - - X3D(I),Y3D(I),Z3D(I),E3D(I) 133 - 40 CONTINUE 134 - ENDIF 135 - *** Look for the DRIFT-AREA instruction. 136 - ELSEIF(INPCMP(1,'DR#IFT-AREA').NE.0)THEN 137 - CALL CELVIE(DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX) 138 - CALL INPERR 139 - *** Look for the CHANGE-VOLTAGES instruction. 140 - ELSEIF(INPCMP(1,'CHAN#GE-#VOLTAGES').NE.0)THEN 141 - CALL OPTCHV 142 - *** Look for the DELETE instruction. 143 - ELSEIF(INPCMP(1,'DE#LETE').NE.0)THEN 144 - CALL OPTDEL(CHANGE) 145 - IF(CHANGE)CALL CELRES(IFAIL) 146 - IF(IFAIL.NE.0)THEN 147 - PRINT *,' !!!!!! OPTINP WARNING : The new cell'// 148 - - ' is not acceptable ; leaving &OPTIMISE.' 149 - RETURN 150 - ENDIF 1 505 P=OPTIMISE D=OPTINP 3 PAGE 725 151 - *** Display the potential settings. 152 - ELSEIF(INPCMP(1,'DI#SPLAY').NE.0)THEN 153 - WRITE(LUNOUT,'('' CURRENT POTENTIAL SETTINGS:'',//, 154 - - '' You have selected '',I3,'' groups of wires to be'', 155 - - '' varied collectively:'')') NSW 156 - DO 110 ISW=1,NSW 157 - WRITE(LUNOUT,'(/'' Group '',I3)') ISW 158 - DO 100 IW=1,NWIRE 159 - IF(INDSW(IW).NE.ISW)GOTO 100 160 - XPOS=X(IW) 161 - YPOS=Y(IW) 162 - IF(POLAR)CALL CFMRTP(XPOS,YPOS,XPOS,YPOS,1) 163 - WRITE(LUNOUT,'(5X,''Wire '',I3,'', code '',A1,'', V='', 164 - - E15.8,'', at: ('',E15.8,'','',E15.8,'').'')') 165 - - IW,WIRTYP(IW),V(IW),XPOS,YPOS 166 - 100 CONTINUE 167 - 110 CONTINUE 168 - WRITE(LUNOUT,'('' '')') 169 - *** Search for the FACTOR instruction. 170 - ELSEIF(INPCMP(1,'FA#CTOR').NE.0)THEN 171 - CALL OPTFAC 172 - *** Read a field map. 173 - ELSEIF(INPCMP(1,'FIELD-MAP')+ 174 - - INPCMP(1,'READ-FIELD-MAP').NE.0)THEN 175 - * Obtain the field map for background field use. 176 - CALL BOOK('INQUIRE','MAP',USER,IFAIL) 177 - IF(USER.EQ.'CELL')THEN 178 - PRINT *,' !!!!!! OPTINP WARNING : Field map is'// 179 - - ' currently used for the main field; field'// 180 - - ' map not read as background field.' 181 - IFAIL=1 182 - ELSEIF(USER.EQ.' ')THEN 183 - CALL BOOK('BOOK','MAP','OPTIMISE',IFAIL) 184 - IF(IFAIL.NE.0)PRINT *,' !!!!!! OPTINP WARNING :'// 185 - - ' Unable to obtain control of the field map'// 186 - - ' for use as background field.' 187 - ELSEIF(USER.EQ.'OPTIMISE')THEN 188 - IFAIL=0 189 - ELSE 190 - PRINT *,' !!!!!! OPTINP WARNING : Field map is in'// 191 - - ' use by '//USER//' not reallocated.' 192 - IFAIL=1 193 - ENDIF 194 - * Read the field map. 195 - IF(IFAIL.EQ.0)THEN 196 - IF(INPCMP(1,'FIELD-MAP').NE.0)THEN 197 - CALL MAPREA(IFAIL) 198 - ELSE 199 - CALL MAPFMF(IFAIL) 200 - ENDIF 201 - ENDIF 202 - * Check the error flag from mapo reading. 203 - IF(IFAIL.NE.0)PRINT *,' !!!!!! OPTINP WARNING : Reading'// 204 - - ' a field map failed.' 205 - *** Delete a field map. 206 - ELSEIF(INPCMP(1,'DEL#ETE-F#IELD-MAP')+ 207 - - INPCMP(1,'DEL#ETE-MAP').NE.0)THEN 208 - * Delete the field map itself. 209 - CALL MAPINT 210 - CALL BOOK('RELEASE','MAP','OPTIMISE',IFAIL) 211 - * Check whether the background field is to be kept. 212 - IF(LBGFMP)THEN 213 - PRINT *,' ------ OPTINP MESSAGE : Background field'// 214 - - ' deleted because of dependence on the field map.' 215 - IF(IENBGF.NE.0)CALL ALGCLR(IENBGF) 216 - IENBGF=0 217 - ENDIF 218 - *** Plot of the forces acting on a wire. 219 - ELSEIF(INPCMP(1,'FO#RCES').NE.0)THEN 220 - CALL OPTFRC 221 - *** Look for the keyword GRID. 222 - ELSEIF(INPCMP(1,'G#RID').NE.0)THEN 223 - IF(NWORD.EQ.1)THEN 224 - PRINT 1090,NGRIDX,NGRIDY 225 - ELSEIF(NWORD.EQ.2)THEN 226 - CALL INPCHK(2,1,IFAIL1) 227 - CALL INPRDI(2,NGRIDR,25) 228 - IF(NGRIDR.LE.1.OR.NGRIDR.GT.MXGRID) 229 - - CALL INPMSG(2,'GRID out of range 2 -> MXGRID.') 230 - CALL INPERR 231 - IF(IFAIL1.NE.0.OR.NGRIDR.LE.1.OR.NGRIDR.GT.MXGRID)THEN 232 - PRINT *,' !!!!!! OPTINP WARNING : GRID statement', 233 - - ' ignored because of syntax or value errors.' 234 - ELSE 235 - NGRIDX=NGRIDR 236 - NGRIDY=NGRIDR 237 - ENDIF 238 - ELSEIF(NWORD.EQ.3)THEN 239 - CALL INPCHK(2,1,IFAIL1) 240 - CALL INPCHK(3,1,IFAIL2) 241 - CALL INPRDI(2,NGRDXR,25) 242 - CALL INPRDI(3,NGRDYR,25) 243 - IF(NGRDXR.LE.1.OR.NGRDXR.GT.MXGRID) 244 - - CALL INPMSG(2,'out of the range 2 -> MXGRID. ') 245 - IF(NGRDYR.LE.1.OR.NGRDYR.GT.MXGRID) 246 - - CALL INPMSG(2,'out of the range 2 -> MXGRID. ') 247 - CALL INPERR 248 - IF(IFAIL1.NE.0.OR.NGRDXR.LE.1.OR.NGRDXR.GT.MXGRID.OR. 249 - - NGRDYR.LE.1.OR.NGRDYR.GT.MXGRID)THEN 250 - PRINT *,' !!!!!! OPTINP WARNING : GRID statement', 251 - - ' ignored because of syntax or value errors.' 252 - ELSE 253 - NGRIDX=NGRDXR 254 - NGRIDY=NGRDYR 255 - ENDIF 256 - ELSE 1 505 P=OPTIMISE D=OPTINP 4 PAGE 726 257 - PRINT *,' !!!!!! OPTINP WARNING : GRID requires 1'// 258 - - ' or 2 arguments ; the instruction is ignored.' 259 - ENDIF 260 - *** Look for the keyword OPTION, 261 - ELSEIF(INPCMP(1,'O#PTIONS').NE.0)THEN 262 - * No valid options here. 263 - DO 30 I=2,NWORD 264 - CALL INPMSG(I,'The option is not known. ') 265 - 30 CONTINUE 266 - CALL INPERR 267 - *** Look for the instruction POINT. 268 - ELSEIF(INPCMP(1,'P#OINTS').NE.0)THEN 269 - IF(NWORD.EQ.1)THEN 270 - WRITE(LUNOUT,'('' Current number of points on'', 271 - - '' the track: '',I3,''.'')') NPOINT 272 - ELSEIF(NWORD.NE.2)THEN 273 - PRINT *,' !!!!!! OPTINP WARNING : POINTS requires 1'// 274 - - ' argument ; the instruction is ignored.' 275 - ELSE 276 - CALL INPCHK(2,1,IFAIL1) 277 - CALL INPRDI(2,NPOINR,20) 278 - IF(NPOINR.LE.1) 279 - - CALL INPMSG(2,'POINT should be larger than 1.') 280 - CALL INPERR 281 - IF(IFAIL1.NE.0.OR.NPOINR.LE.1)THEN 282 - PRINT *,' !!!!!! OPTINP WARNING : POINTS is'// 283 - - ' ignored because of syntax or value errors.' 284 - ELSE 285 - NPOINT=NPOINR 286 - ENDIF 287 - ENDIF 288 - *** Print the cell. 289 - ELSEIF(INPCMP(1,'PR#INT-#CELL')+INPCMP(1,'C#ELL-PR#INT') 290 - - .NE.0)THEN 291 - CALL CELPRT 292 - *** Retrieve a record. 293 - ELSEIF(INPCMP(1,'R#ESTORE').NE.0)THEN 294 - IREFNO=1 295 - IFAIL=0 296 - IF(NWORD.GE.2)THEN 297 - CALL INPCHK(2,1,IFAIL) 298 - CALL INPRDI(2,IREFNO,1) 299 - ENDIF 300 - IF(NWORD.GT.2)PRINT *,' !!!!!! OPTINP WARNING : RETRIEVE'// 301 - - ' takes a single arguments ; the rest is ignored.' 302 - IF(IFAIL.EQ.0)THEN 303 - CALL OPTDSN('RESTORE',IREFNO) 304 - ELSE 305 - PRINT *,' !!!!!! OPTINP WARNING : RETRIEVE is'// 306 - - ' ignored because of errors.' 307 - ENDIF 308 - *** Save a record. 309 - ELSEIF(INPCMP(1,'SA#VE').NE.0)THEN 310 - CALL OPTDSN('SAVE',IREFNO) 311 - IF(NWORD.GT.1)PRINT *,' !!!!!! OPTINP WARNING : SAVE'// 312 - - ' takes no arguments ; they are ignored.' 313 - IF(IREFNO.EQ.0)THEN 314 - PRINT *,' !!!!!! OPTINP WARNING : The voltages have'// 315 - - ' not been saved.' 316 - ELSE 317 - WRITE(LUNOUT,'('' ------ OPTINP MESSAGE : Reference'', 318 - - '' number for this set of potentials: '',I3)') 319 - - IREFNO 320 - ENDIF 321 - *** Write the field map in binary format. 322 - ELSEIF(INPCMP(1,'SAVE-F#IELD-#MAP').NE.0)THEN 323 - CALL MAPFMS 324 - *** Search for the SELECT instruction. 325 - ELSEIF(INPCMP(1,'SEL#ECT').NE.0)THEN 326 - CALL CELSEL 327 - *** Look for the SET instruction. 328 - ELSEIF(INPCMP(1,'SET').NE.0)THEN 329 - CALL OPTSET 330 - *** Look for the instruction TRACK. 331 - ELSEIF(INPCMP(1,'TR#ACK').NE.0)THEN 332 - CALL TRAREA 333 - *** It is not possible to get here if the keyword is valid. 334 - ELSE 335 - CALL INPSTR(1,1,STRING,NC) 336 - PRINT *,' !!!!!! OPTINP WARNING : '//STRING(1:NC)//' is'// 337 - - ' not a valid instruction ; ignored.' 338 - ENDIF 339 - *** Go on with the next input line. 340 - GOTO 10 341 - END 506 GARFIELD ================================================== P=OPTIMISE D=OPTFAC 1 ============================ 0 + +DECK,OPTFAC. 1 - SUBROUTINE OPTFAC 2 - *----------------------------------------------------------------------- 3 - * OPTFAC - Routine which prints the dependence of the field on the 4 - * potential of the wires. 5 - * Variables : FAC(.,I) : Coefficient of V in V(1), Ex(2), Ey(3) 6 - * NDATA : Number of data points used in the average 7 - * CVTARS etc : Backup copies of some cell data. 8 - * FACTYP : average over (1) grid (2) track (3) wires 9 - * EXBACK etc : Background term of the field 10 - * CHKEX etc : Debug check on the correctness of the FAC 11 - * VCOMP : If .FALSE. grouping is useful. 12 - *----------------------------------------------------------------------- 13.- +SEQ,DIMENSIONS. 14.- +SEQ,CELLDATA. 15.- +SEQ,CAPACMATRIX. 16.- +SEQ,PRINTPLOT. 1 506 P=OPTIMISE D=OPTFAC 2 PAGE 727 17.- +SEQ,PARAMETERS. 18.- +SEQ,CONSTANTS. 19 - DOUBLE PRECISION FAC(3,0:MXWIRE),AIJXJ,AIJYJ,EXBACK,EYBACK, 20 - - VTBACK,SUMVT,SUMEX,SUMEY,CHKVT,CHKEX,CHKEY 21 - REAL ERES(MXWIRE) 22 - INTEGER FACTYP 23 - LOGICAL LGROUP,VCOMP,VSET 0 24-+ +SELF,IF=SAVE. 25 - SAVE LGROUP,FACTYP 0 26-+ +SELF. 27 - *** Preset the grouping and averaging options. 28 - DATA LGROUP /.FALSE./ 29 - DATA FACTYP /1/ 30 - *** Define the output formats. 31 - 1010 FORMAT(' a total of ',I4,' points is effectively used in the', 32 - - ' averages.'//' With the present voltage settings, the', 33 - - ' field averages are:'/10X,'V = ',E12.5,' Volt,'/10X, 34 - - 'Ex = ',E12.5,' V/cm,'/10X,'Ey = ',E12.5,' V/cm.'// 35 - - ' These averages are composed of two parts:'/' (1) the', 36 - - ' field due to a voltage shift or to non-grounded planes:'/ 37 - - 10X,'V = ',E12.5,' Volt,'/10X,'Ex = ',E12.5,' V/cm,'/10X, 38 - - 'Ey = ',E12.5,' V/cm.'//' (2) the field exactly linear', 39 - - ' in the wire potentials.'/8X,'The factors for each wire', 40 - - ' are printed in the table below.'/) 41 - *** Identify the subroutine. 42 - IF(LIDENT)PRINT *,' /// ROUTINE OPTFAC ///' 43 - PRINT *,' !!!!!! ROUTINE BEING WORKED ON !!!!!!' 44 - *** First decode the argument list. 45 - CALL INPNUM(NWORD) 46 - DO 10 I=2,NWORD 47 - IF(INPCMP(I,'GR#ID').NE.0)THEN 48 - FACTYP=1 49 - ELSEIF(INPCMP(I,'TR#ACK').NE.0)THEN 50 - IF(.NOT.TRFLAG(1))THEN 51 - CALL INPMSG(I,'The track has not been set. ') 52 - ELSE 53 - FACTYP=2 54 - ENDIF 55 - ELSEIF(INPCMP(I,'WIR#ES').NE.0)THEN 56 - FACTYP=3 57 - ELSEIF(INPCMP(I,'GR#OUP').NE.0)THEN 58 - LGROUP=.TRUE. 59 - ELSEIF(INPCMP(I,'NOGR#OUP').NE.0)THEN 60 - LGROUP=.FALSE. 61 - ELSE 62 - CALL INPMSG(I,'Not a known option. ') 63 - ENDIF 64 - 10 CONTINUE 65 - CALL INPERR 66 - *** Print some debugging output. 67 - IF(LDEBUG)THEN 68 - PRINT *,' ++++++ OPTFAC DEBUG : FACTYP=',FACTYP, 69 - - ' LGROUP= ',LGROUP,' NGRIDX=',NGRIDX,' NGRIDY=',NGRIDY 70 - PRINT *,' TYPE=',TYPE,', MODE=',MODE 71 - ENDIF 72 - *** Quit if FACTYP=2 (track) is still on and no track has been set. 73 - IF(FACTYP.EQ.2.AND..NOT.TRFLAG(1))THEN 74 - PRINT *,' !!!!!! OPTFAC WARNING : The track has not been'// 75 - - ' set ; the calculations are not carried out.' 76 - RETURN 77 - ENDIF 78 - *** Recalculate the capacitance matrix (absent if cell is from dataset). 79 - CALL SETUP(IFAIL) 80 - IF(IFAIL.NE.0)THEN 81 - PRINT *,' ###### OPTFAC ERROR : Setting up the'// 82 - - ' capacitance matrix failed ; no valid cell' 83 - PRINT *,' is available from'// 84 - - ' now on, the number of wires is set to 0.' 85 - NWIRE=0 86 - RETURN 87 - ENDIF 88 - *** Loop over the wires, I=0 is used to calculate the current V, EX, EY. 89 - DO 110 I=0,NWIRE 90 - * First save the charges at the first wire loop. 91 - IF(I.EQ.1)THEN 92 - CVTARS=CORVTA 93 - CVTBRS=CORVTB 94 - CVTCRS=CORVTC 95 - V0RES =V0 96 - C1RES =C1 97 - CORVTA=0.0 98 - CORVTB=0.0 99 - CORVTC=0.0 100 - V0 =0.0 101 - C1 =0.0 102 - DO 100 J=1,NWIRE 103 - ERES(J)=E(J) 104 - 100 CONTINUE 105 - ENDIF 106 - * Next swap the charges and the capacitance matrix elements. 107 - IF(I.GT.0)THEN 108 - DO 120 J=1,NWIRE 109 - E(J)=A(I,J) 110 - 120 CONTINUE 111 - NDATRF=0 112 - ELSE 113 - NDATA=0 114 - VTBACK=0.0 115 - EXBACK=0.0 116 - EYBACK=0.0 117 - ENDIF 118 - * Initialise the output array. 119 - FAC(1,I)=0.0 120 - FAC(2,I)=0.0 1 506 P=OPTIMISE D=OPTFAC 3 PAGE 728 121 - FAC(3,I)=0.0 122 - * Set the linear correction terms for doubly periodic cells. 123 - IF(TYPE(1:1).EQ.'C'.AND.I.GT.0)THEN 124 - AIJXJ=0.0 125 - AIJYJ=0.0 126 - DO 180 J=1,NWIRE 127 - IF(TYPE.EQ.'C1 '.AND.MODE.EQ.0)THEN 128 - AIJXJ=AIJXJ+A(I,J)*X(J) 129 - ELSEIF(TYPE.EQ.'C1 '.AND.MODE.EQ.1)THEN 130 - AIJYJ=AIJYJ+A(I,J)*Y(J) 131 - ELSEIF(TYPE.EQ.'C2X'.AND.MODE.EQ.0)THEN 132 - AIJXJ=AIJXJ+A(I,J)*(X(J)-COPLAX) 133 - ELSEIF(TYPE.EQ.'C2Y'.AND.MODE.EQ.1)THEN 134 - AIJYJ=AIJYJ+A(I,J)*(Y(J)-COPLAY) 135 - ENDIF 136 - 180 CONTINUE 137 - AIJXJ=-AIJXJ*2.0*PI/(SX*SY) 138 - AIJYJ=-AIJYJ*2.0*PI/(SX*SY) 139 - ENDIF 140 - * Next do the field calculations, with the modified charges if I > 0. 141 - IF(FACTYP.EQ.1)THEN 142 - DO 130 IX=1,NGRIDX 143 - DO 140 IY=1,NGRIDY 144 - CALL EFIELD(PXMIN+REAL(IX-1)*(PXMAX-PXMIN)/REAL(NGRIDX-1), 145 - - PYMIN+REAL(IY-1)*(PYMAX-PYMIN)/REAL(NGRIDY-1),0.0, 146 - - EX,EY,EZ,ETOT,VOLT,1,ILOC) 147 - IF(ILOC.NE.0)GOTO 140 148 - FAC(1,I)=FAC(1,I)+VOLT 149 - FAC(2,I)=FAC(2,I)+EX 150 - FAC(3,I)=FAC(3,I)+EY 151 - IF(I.EQ.0)THEN 152 - NDATA=NDATA+1 153 - VTBACK=VTBACK+V0+ 154 - - CORVTA*(PXMIN+REAL(IX-1)*(PXMAX-PXMIN)/ 155 - - REAL(NGRIDX-1))+ 156 - - CORVTB*(PYMIN+REAL(IY-1)*(PYMAX-PYMIN)/ 157 - - REAL(NGRIDY-1))+ 158 - - CORVTC 159 - EXBACK=EXBACK-CORVTA 160 - EYBACK=EYBACK-CORVTB 161 - ELSE 162 - NDATRF=NDATRF+1 163 - IF(TYPE.EQ.'C1 '.AND.MODE.EQ.0)THEN 164 - FAC(1,I)=FAC(1,I)+AIJXJ*(PXMIN+REAL(IX-1)* 165 - - (PXMAX-PXMIN)/REAL(NGRIDX-1)) 166 - FAC(2,I)=FAC(2,I)-AIJXJ 167 - ELSEIF(TYPE.EQ.'C1 '.AND.MODE.EQ.1)THEN 168 - FAC(1,I)=FAC(1,I)+AIJYJ*(PYMIN+REAL(IY-1)* 169 - - (PYMAX-PYMIN)/REAL(NGRIDY-1)) 170 - FAC(3,I)=FAC(3,I)-AIJYJ 171 - ELSEIF(TYPE.EQ.'C2X'.AND.MODE.EQ.0)THEN 172 - FAC(1,I)=FAC(1,I)+AIJXJ*(PXMIN+REAL(IX-1)* 173 - - (PXMAX-PXMIN)/REAL(NGRIDX-1)-COPLAX) 174 - FAC(2,I)=FAC(2,I)-AIJXJ 175 - ELSEIF(TYPE.EQ.'C2Y'.AND.MODE.EQ.1)THEN 176 - FAC(1,I)=FAC(1,I)+AIJYJ*(PYMIN+REAL(IY-1)* 177 - - (PYMAX-PYMIN)/REAL(NGRIDY-1)-COPLAY) 178 - FAC(3,I)=FAC(3,I)-AIJYJ 179 - ENDIF 180 - ENDIF 181 - 140 CONTINUE 182 - 130 CONTINUE 183 - * Average over the track if FACTYP = 2. 184 - ELSEIF(FACTYP.EQ.2)THEN 185 - DO 150 IT=1,MXLIST 186 - CALL EFIELD(XT0+REAL(IT-1)*(XT1-XT0)/REAL(MXLIST-1), 187 - - YT0+REAL(IT-1)*(YT1-YT0)/REAL(MXLIST-1), 188 - - ZT0+REAL(IT-1)*(ZT1-ZT0)/REAL(MXLIST-1), 189 - - EX,EY,EZ,ETOT,VOLT,1,ILOC) 190 - IF(ILOC.NE.0)GOTO 150 191 - FAC(1,I)=FAC(1,I)+VOLT 192 - FAC(2,I)=FAC(2,I)+EX 193 - FAC(3,I)=FAC(3,I)+EY 194 - IF(I.EQ.0)THEN 195 - NDATA=NDATA+1 196 - VTBACK=VTBACK+V0+ 197 - - CORVTA*(XT0+REAL(IT-1)*(XT1-XT0)/ 198 - - REAL(MXLIST-1))+ 199 - - CORVTB*(YT0+REAL(IT-1)*(YT1-YT0)/ 200 - - REAL(MXLIST-1))+ 201 - - CORVTC 202 - EXBACK=EXBACK-CORVTA 203 - EYBACK=EYBACK-CORVTB 204 - ELSE 205 - NDATRF=NDATRF+1 206 - IF(TYPE.EQ.'C1 '.AND.MODE.EQ.0)THEN 207 - FAC(1,I)=FAC(1,I)+AIJXJ* 208 - - (XT0+REAL(IT-1)*(XT1-XT0)/REAL(MXLIST-1)) 209 - FAC(2,I)=FAC(2,I)-AIJXJ 210 - ELSEIF(TYPE.EQ.'C1 '.AND.MODE.EQ.1)THEN 211 - FAC(1,I)=FAC(1,I)+AIJYJ* 212 - - (YT0+REAL(IT-1)*(YT1-YT0)/REAL(MXLIST-1)) 213 - FAC(3,I)=FAC(3,I)-AIJYJ 214 - ELSEIF(TYPE.EQ.'C2X'.AND.MODE.EQ.0)THEN 215 - FAC(1,I)=FAC(1,I)+AIJXJ*(XT0+REAL(IT-1)* 216 - - (XT1-XT0)/REAL(MXLIST-1)-COPLAX) 217 - FAC(2,I)=FAC(2,I)-AIJXJ 218 - ELSEIF(TYPE.EQ.'C2Y'.AND.MODE.EQ.1)THEN 219 - FAC(1,I)=FAC(1,I)+AIJYJ*(YT0+REAL(IT-1)* 220 - - (YT1-YT0)/REAL(MXLIST-1)-COPLAY) 221 - FAC(3,I)=FAC(3,I)-AIJYJ 222 - ENDIF 223 - ENDIF 224 - 150 CONTINUE 225 - * Loop over the surface of the sense wires if FACTYP = 3. 226 - ELSE 1 506 P=OPTIMISE D=OPTFAC 4 PAGE 729 227 - DO 160 IW=1,NWIRE 228 - IF(INDSW(IW).EQ.0)GOTO 160 229 - DO 170 ANG=0.0,1.9*PI,0.2*PI 230 - CALL EFIELD(X(IW)+0.51*D(IW)*COS(ANG), 231 - - Y(IW)+0.51*D(IW)*SIN(ANG),0.0, 232 - - EX,EY,EZ,ETOT,VOLT,1,ILOC) 233 - IF(ILOC.NE.0)GOTO 170 234 - FAC(1,I)=FAC(1,I)+VOLT 235 - FAC(2,I)=FAC(2,I)+EX 236 - FAC(3,I)=FAC(3,I)+EY 237 - IF(I.EQ.0)THEN 238 - NDATA=NDATA+1 239 - VTBACK=VTBACK+V0+CORVTA*(X(IW)+0.51*D(IW)*COS(ANG))+ 240 - - CORVTB*(Y(IW)+0.51*D(IW)*SIN(ANG))+CORVTC 241 - EXBACK=EXBACK-CORVTA 242 - EYBACK=EYBACK-CORVTB 243 - ELSE 244 - NDATRF=NDATRF+1 245 - IF(TYPE.EQ.'C1 '.AND.MODE.EQ.0)THEN 246 - FAC(1,I)=FAC(1,I)+AIJXJ* 247 - - (X(IW)+0.51*D(IW)*COS(ANG)) 248 - FAC(2,I)=FAC(2,I)-AIJXJ 249 - ELSEIF(TYPE.EQ.'C1 '.AND.MODE.EQ.1)THEN 250 - FAC(1,I)=FAC(1,I)+AIJYJ* 251 - - (Y(IW)+0.51*D(IW)*SIN(ANG)) 252 - FAC(3,I)=FAC(3,I)-AIJYJ 253 - ELSEIF(TYPE.EQ.'C2X'.AND.MODE.EQ.0)THEN 254 - FAC(1,I)=FAC(1,I)+AIJXJ* 255 - - (X(IW)+0.51*D(IW)*COS(ANG)-COPLAX) 256 - FAC(2,I)=FAC(2,I)-AIJXJ 257 - ELSEIF(TYPE.EQ.'C2Y'.AND.MODE.EQ.1)THEN 258 - FAC(1,I)=FAC(1,I)+AIJYJ* 259 - - (Y(IW)+0.51*D(IW)*SIN(ANG)-COPLAY) 260 - FAC(3,I)=FAC(3,I)-AIJYJ 261 - ENDIF 262 - ENDIF 263 - 170 CONTINUE 264 - 160 CONTINUE 265 - ENDIF 266 - * Stop this routine if NDATA is 0. 267 - IF(I.EQ.0.AND.NDATA.LE.0)THEN 268 - PRINT *,' !!!!!! OPTFAC WARNING : No output can be printed', 269 - - ' because the field is zero at all sampling points.' 270 - RETURN 271 - ENDIF 272 - * Average the EX, EY and V factors over the sampling points. 273 - FAC(1,I)=FAC(1,I)/NDATA 274 - FAC(2,I)=FAC(2,I)/NDATA 275 - FAC(3,I)=FAC(3,I)/NDATA 276 - * Add the wire term to the VTBACK sum or average if not yet done. 277 - IF(I.GT.0)THEN 278 - VTBACK=VTBACK- 279 - - (V0RES+CVTARS*X(I)+CVTBRS*Y(I)+CVTCRS)*FAC(1,I) 280 - EXBACK=EXBACK- 281 - - (V0RES+CVTARS*X(I)+CVTBRS*Y(I)+CVTCRS)*FAC(2,I) 282 - EYBACK=EYBACK- 283 - - (V0RES+CVTARS*X(I)+CVTBRS*Y(I)+CVTCRS)*FAC(3,I) 284 - IF(NDATA.NE.NDATRF)PRINT *,' !!!!!! OPTFAC WARNING : ', 285 - - ' Number of sampling points has changed; data for', 286 - - ' wire ',I,' are not reliable.' 287 - ELSE 288 - VTBACK=VTBACK/NDATA 289 - EXBACK=EXBACK/NDATA 290 - EYBACK=EYBACK/NDATA 291 - ENDIF 292 - * Continue with the next wire. 293 - 110 CONTINUE 294 - *** Swap the charges back into place. 295 - DO 200 I=1,NWIRE 296 - E(I)=ERES(I) 297 - 200 CONTINUE 298 - CORVTA=CVTARS 299 - CORVTB=CVTBRS 300 - CORVTC=CVTCRS 301 - V0=V0RES 302 - C1=C1RES 303 - *** Print the results obtained. 304 - WRITE(LUNOUT,'(''1 How the field comes about''/ 305 - - '' =========================''/)') 306 - IF(FACTYP.EQ.1)THEN 307 - WRITE(LUNOUT,'('' The data below apply to the average'', 308 - - '' field over a grid of '',I3,'' x '',I3,'' points''/ 309 - - '' in the area ('',E12.5,'','',E12.5,'') to ('', 310 - - E12.5,'','',E12.5,''),'')') 311 - - NGRIDX,NGRIDY,PXMIN,PYMIN,PXMAX,PYMAX 312 - ELSEIF(FACTYP.EQ.2)THEN 313 - WRITE(LUNOUT,'('' The data below apply to the average'', 314 - - '' field over a track of '',I3,'' points''/ 315 - - '' from ('',E12.5,'','',E12.5,'') to ('', 316 - - E12.5,'','',E12.5,''),'')') 317 - - MXLIST,XT0,XT1,YT0,YT1 318 - ELSEIF(FACTYP.EQ.3)THEN 319 - WRITE(LUNOUT,'('' The data below apply to the average'', 320 - - '' field on the surface of the sense wires,'')') 321 - ENDIF 322 - *** Print the rest of the introductory heading. 323 - WRITE(LUNOUT,1010) NDATA,(FAC(I,0),I=1,3),VTBACK,EXBACK,EYBACK 324 - ** Printing in case wires should be grouped. 325 - IF(LGROUP)THEN 326 - WRITE(LUNOUT,'('' Wire V-factor Ex-factor'', 327 - - '' Ey-factor Group Tot V-factor Tot Ex-factor'', 328 - - '' Tot Ey-factor'')') 329 - WRITE(LUNOUT,'('' [numeric] [cm**-1]'', 330 - - '' [cm**-1] [numeric] [cm**-1]'', 331 - - '' [cm**-1]'')') 332 - DO 300 I=0,NSW 1 506 P=OPTIMISE D=OPTFAC 5 PAGE 730 333 - * Preset summing variables. 334 - SUMVT=0.0 335 - SUMEX=0.0 336 - SUMEY=0.0 337 - NSUM=0 338 - * Preset the logicals used to check whether grouping is useful. 339 - VCOMP=.FALSE. 340 - VSET=.FALSE. 341 - VREF=0.0 342 - * Pick out the wires belonging to the group. 343 - WRITE(LUNOUT,'('' '')') 344 - DO 310 J=1,NWIRE 345 - IF(INDSW(J).NE.I)GOTO 310 346 - IF(VSET.AND.V(J).NE.VREF)VCOMP=.TRUE. 347 - IF(.NOT.VSET)THEN 348 - VREF=V(J) 349 - VSET=.TRUE. 350 - ENDIF 351 - * Add to the totals. 352 - NSUM=NSUM+1 353 - SUMVT=SUMVT+FAC(1,J) 354 - SUMEX=SUMEX+FAC(2,J) 355 - SUMEY=SUMEY+FAC(3,J) 356 - WRITE(LUNOUT,'(2X,I5,3(1X,E12.5))') 357 - - J,FAC(1,J),FAC(2,J),FAC(3,J) 358 - 310 CONTINUE 359 - * Print the information collected for this group. 360 - IF(I.EQ.0.AND.NSUM.NE.0)WRITE(LUNOUT,'(49X,''Wires not'', 361 - - '' belonging to any group.'')') 362 - IF(NSUM.EQ.0.OR.I.EQ.0)GOTO 300 363 - IF(.NOT.VCOMP)THEN 364 - WRITE(LUNOUT,'(49X,I5,3(1X,E12.5))') 365 - - I,SUMVT,SUMEX,SUMEY 366 - ELSE 367 - WRITE(LUNOUT,'(49X,I5, 368 - - '' Meaningless: differing wire voltages.'')') I 369 - ENDIF 370 - 300 CONTINUE 371 - ** Printing in case grouping should not be performed. 372 - ELSE 373 - WRITE(LUNOUT,'('' Wire V-factor'', 374 - - '' Ex-factor Ey-factor'')') 375 - WRITE(LUNOUT,'('' [numeric]'', 376 - - '' [cm**-1] [cm**-1]''/)') 377 - DO 320 I=1,NWIRE 378 - WRITE(LUNOUT,'(2X,I5,3(5X,E12.5))') 379 - - I,FAC(1,I),FAC(2,I),FAC(3,I) 380 - 320 CONTINUE 381 - ENDIF 382 - ** In case the debug option was specified, verify the sums. 383 - IF(LDEBUG)THEN 384 - CHKVT=VTBACK 385 - CHKEX=EXBACK 386 - CHKEY=EYBACK 387 - DO 400 I=1,NWIRE 388 - CHKVT=CHKVT+FAC(1,I)*V(I) 389 - CHKEX=CHKEX+FAC(2,I)*V(I) 390 - CHKEY=CHKEY+FAC(3,I)*V(I) 391 - 400 CONTINUE 392 - PRINT *,' ++++++ OPTFAC DEBUG : Summing the wire', 393 - - ' contributions and the background yields:' 394 - WRITE(*,'(10X,''V = '',E12.5,'' Volt,''/10X,''Ex = '', 395 - - E12.5,'' V/cm,''/10X,''Ey = '',E12.5,'' V/cm.'')') 396 - - CHKVT,CHKEX,CHKEY 397 - ENDIF 398 - ** Make sure that the next output line starts on a fresh page. 399 - WRITE(LUNOUT,'(''1'')') 400 - *** Register the amount of CPU time used with TIMLOG. 401 - CALL TIMLOG('Printing V, Ex and Ey factors: ') 402 - END 507 GARFIELD ================================================== P=OPTIMISE D=OPTSET 1 ============================ 0 + +DECK,OPTSET. 1 - SUBROUTINE OPTSET 2 - *----------------------------------------------------------------------- 3 - * OPTSET - Routine attempting to find proper voltage settings. 4 - * (Last changed on 20/10/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,CELLDATA. 10.- +SEQ,GASDATA. 11.- +SEQ,OPTDATA. 12.- +SEQ,PARAMETERS. 13 - CHARACTER*10 VARLIS(MXVAR) 14 - LOGICAL FLAG(MXWORD+1),USE(MXVAR),LFITPR,OK 15 - INTEGER NITMAX,NWORD,I,INEXT,NRES,IFAIL,NPNT,NPAR,INPCMP 16 - DOUBLE PRECISION XFIT(MXFPNT),YFIT(MXFPNT),WEIGHT(MXFPNT), 17 - - AFIT(MXFPAR),EAFIT(MXFPAR),CHI2,DIST,EPS 18 - REAL VFIT(MXWIRE),VPLFIT(5),DISTR,EPSR,AVER 19 - EXTERNAL OPTFUN,INPCMP 0 20-+ +SELF,IF=SAVE. 21 - SAVE DIST,EPS,NITMAX,LFITPR 0 22-+ +SELF. 23 - DATA DIST,EPS /1.0D0,1.0D-4/ 24 - DATA NITMAX /10/ 25 - DATA LFITPR /.TRUE./ 26 - *** Decode the argument string, first get the number of arguments. 27 - CALL INPNUM(NWORD) 28 - ** Preset the flagging logicals. 29 - DO 10 I=1,MXWORD+1 30 - FLAG(I)=.FALSE. 1 507 P=OPTIMISE D=OPTSET 2 PAGE 731 31 - IF(INPCMP(I,'A#VERAGE')+INPCMP(I,'D#ISTANCE')+ 32 - - INPCMP(I,'EPS#ILON')+ 33 - - INPCMP(I,'I#TERATE-#LIMIT')+INPCMP(I,'G#RID')+ 34 - - INPCMP(I,'NOPR#INT')+INPCMP(I,'ON')+INPCMP(I,'PR#INT')+ 35 - - INPCMP(I,'TO')+INPCMP(I,'TR#ACK')+INPCMP(I,'W#IRE').NE.0.OR. 36 - - I.GT.NWORD)FLAG(I)=.TRUE. 37 - 10 CONTINUE 38 - * The first arguments is normally the function. 39 - IF(NWORD.GT.1.AND..NOT.FLAG(2))THEN 40 - INEXT=3 41 - CALL INPSTR(2,2,FUNFLD,NFLD) 42 - ELSE 43 - INEXT=2 44 - ENDIF 45 - * Keep track of errors in the input. 46 - OK=.TRUE. 47 - * Loop over the arguments. 48 - DO 20 I=2,NWORD 49 - IF(I.LT.INEXT)GOTO 20 50 - * Set the maximum-norm. 51 - IF(INPCMP(I,'D#ISTANCE').NE.0)THEN 52 - IF(FLAG(I+1))THEN 53 - CALL INPMSG(I,'No value of the norm present. ') 54 - OK=.FALSE. 55 - ELSE 56 - CALL INPCHK(I+1,2,IFAIL) 57 - CALL INPRDR(I+1,DISTR,1.0) 58 - DIST=DISTR 59 - INEXT=I+2 60 - ENDIF 61 - * Set the differentiation and change parameter. 62 - ELSEIF(INPCMP(I,'EPS#ILON').NE.0)THEN 63 - IF(FLAG(I+1))THEN 64 - CALL INPMSG(I,'No value of EPSILON present. ') 65 - OK=.FALSE. 66 - ELSE 67 - CALL INPCHK(I+1,2,IFAIL) 68 - CALL INPRDR(I+1,EPSR,1.0E-4) 69 - EPS=EPSR 70 - INEXT=I+2 71 - ENDIF 72 - * Set the iteration limit. 73 - ELSEIF(INPCMP(I,'I#TERATE-#LIMIT').NE.0)THEN 74 - IF(FLAG(I+1))THEN 75 - CALL INPMSG(I,'No iteration bound present. ') 76 - OK=.FALSE. 77 - ELSE 78 - CALL INPCHK(I+1,1,IFAIL) 79 - CALL INPRDI(I+1,NITMAX,10) 80 - INEXT=I+2 81 - ENDIF 82 - * Select the NOPRINT option. 83 - ELSEIF(INPCMP(I,'NOPR#INT').NE.0)THEN 84 - LFITPR=.FALSE. 85 - * Find the domain. 86 - ELSEIF(INPCMP(I,'ON').NE.0)THEN 87 - IF(INPCMP(I+1,'TR#ACK').NE.0)THEN 88 - IF(TRFLAG(1))THEN 89 - PNTTYP='TRACK' 90 - INEXT=I+2 91 - ELSE 92 - CALL INPMSG(I+1,'No track has been defined. ') 93 - OK=.FALSE. 94 - ENDIF 95 - ELSEIF(INPCMP(I+1,'G#RID').NE.0)THEN 96 - PNTTYP='GRID' 97 - INEXT=I+2 98 - ELSEIF(INPCMP(I+1,'W#IRE').NE.0)THEN 99 - PNTTYP='WIRE' 100 - INEXT=I+2 101 - ENDIF 102 - * Select the PRINT option. 103 - ELSEIF(INPCMP(I,'PR#INT').NE.0)THEN 104 - LFITPR=.TRUE. 105 - * Find the target function. 106 - ELSEIF(INPCMP(I,'TO').NE.0)THEN 107 - IF(INPCMP(I+1,'A#VERAGE').NE.0)THEN 108 - VALTYP='AVERAGE' 109 - INEXT=I+2 110 - ELSEIF(.NOT.FLAG(I+1))THEN 111 - CALL INPSTR(I+1,I+1,FUNPOS,NPOS) 112 - VALTYP='FUNCTION' 113 - INEXT=I+2 114 - ENDIF 115 - * Valid keyword out of context. 116 - ELSEIF(INPCMP(I,'TR#ACK')+INPCMP(I,'G#RID')+ 117 - - INPCMP(I,'A#VERAGE').NE.0)THEN 118 - CALL INPMSG(I,'Valid keyword out of context. ') 119 - OK=.FALSE. 120 - * Weighting function. 121 - ELSEIF(INPCMP(I,'W#EIGHT').NE.0)THEN 122 - IF(FLAG(I+1))THEN 123 - CALL INPMSG(I,'No weighting function found. ') 124 - OK=.FALSE. 125 - ELSE 126 - CALL INPSTR(I+1,I+1,FUNWGT,NWGT) 127 - INEXT=I+2 128 - ENDIF 129 - * Keyword unknown. 130 - ELSE 131 - CALL INPMSG(I,'Not a known keyword. ') 132 - OK=.FALSE. 133 - ENDIF 134 - 20 CONTINUE 135 - ** Dump error messages, if any. 136 - CALL INPERR 1 507 P=OPTIMISE D=OPTSET 3 PAGE 732 137 - *** Take action depending on the state of OK. 138 - IF(.NOT.OK)THEN 139 - IF(JFAIL.EQ.1)THEN 140 - PRINT *,' !!!!!! OPTSET WARNING : Errors found in'// 141 - - ' the command; trying with defaults.' 142 - ELSEIF(JFAIL.EQ.2)THEN 143 - PRINT *,' !!!!!! OPTSET WARNING : Errors found in'// 144 - - ' the command; no attempt to achieve settings.' 145 - RETURN 146 - ELSE 147 - PRINT *,' !!!!!! OPTSET WARNING : Errors found in'// 148 - - ' the command; terminating program execution.' 149 - CALL QUIT 150 - ENDIF 151 - ENDIF 152 - *** Generate some debugging output. 153 - IF(LDEBUG)THEN 154 - WRITE(LUNOUT,'('' ++++++ OPTSET DEBUG : The function '', 155 - - A,'' has to approximate'')') FUNFLD(1:NFLD) 156 - IF(VALTYP.EQ.'AVERAGE')WRITE(LUNOUT,'(26X,''the current'', 157 - - '' average of the function,'')') 158 - IF(VALTYP.EQ.'FUNCTION')WRITE(LUNOUT,'(26X,''the value of'', 159 - - '' the function '',A,'','')') FUNPOS(1:NPOS) 160 - WRITE(LUNOUT,'(26X,''using '',A, 161 - - '' as weighting function.'')') FUNWGT(1:NWGT) 162 - WRITE(LUNOUT,'(26X,''Averaging takes place over the '',A)') 163 - - PNTTYP 164 - WRITE(LUNOUT,'(26X,''Maximum distance='',E10.3,'', eps='', 165 - - E10.3,'', NITMAX='',I3,''.'')') DIST,EPS,NITMAX 166 - ENDIF 167 - *** Get the number of 'S' wires if the WIRE option has been selected. 168 - IF(PNTTYP.EQ.'WIRE')THEN 169 - NSWIRE=0 170 - DO 30 I=1,NWIRE 171 - IF(WIRTYP(I).EQ.'S')NSWIRE=NSWIRE+1 172 - 30 CONTINUE 173 - ENDIF 174 - *** Convert the field function, first set variable names. 175 - IF(POLAR)THEN 176 - VARLIS(1)='R ' 177 - VARLIS(2)='PHI ' 178 - VARLIS(3)='ER ' 179 - VARLIS(4)='EPHI ' 180 - ELSE 181 - VARLIS(1)='X ' 182 - VARLIS(2)='Y ' 183 - VARLIS(3)='EX ' 184 - VARLIS(4)='EY ' 185 - ENDIF 186 - VARLIS(5)='E ' 187 - VARLIS(6)='V ' 188 - * Drift related information. 189 - VARLIS(7)='TIME ' 190 - VARLIS(8)='DIFFUSION ' 191 - VARLIS(9)='AVALANCHE ' 192 - C VARLIS(10)='LORENTZ ' 193 - * Conversion of the field-function (dependence check + average). 194 - CALL ALGPRE(FUNFLD(1:NFLD),NFLD,VARLIS, 9,NRES,USE,IENFLD,IFAIL) 195 - * Check the output. 196 - IF(IFAIL.NE.0)THEN 197 - PRINT *,' !!!!!! OPTSET WARNING : SET not executed'// 198 - - ' because of an error in the field function.' 199 - CALL ALGCLR(IENFLD) 200 - RETURN 201 - ELSEIF(NRES.NE.1)THEN 202 - PRINT *,' !!!!!! OPTSET WARNING : SET not executed'// 203 - - ' because the field function does not return a', 204 - - ' single value.' 205 - CALL ALGCLR(IENFLD) 206 - RETURN 207 - ELSEIF(.NOT.(USE(3).OR.USE(4).OR.USE(5).OR.USE(6).OR. 208 - - USE(7).OR.USE(8).OR.USE(9)))THEN 209 - PRINT *,' !!!!!! OPTSET WARNING : SET not executed'// 210 - - ' because the field function is field independent.' 211 - CALL ALGCLR(IENFLD) 212 - RETURN 213 - ENDIF 214 - * Check whether we have to evaluate V. 215 - IF(USE(6))THEN 216 - IOPT=1 217 - ELSE 218 - IOPT=0 219 - ENDIF 220 - * Drift velocity data. 221 - IF(USE(7).AND..NOT.GASOK(1))THEN 222 - PRINT *,' !!!!!! OPTSET WARNING : The field function uses'// 223 - - ' the drift time but drift' 224 - PRINT *,' velocity data has not'// 225 - - ' been entered; not executed.' 226 - CALL ALGCLR(IENFLD) 227 - RETURN 228 - ELSEIF(USE(7) )THEN 229 - EVALT=.TRUE. 230 - ELSE 231 - EVALT=.FALSE. 232 - ENDIF 233 - * Diffusion data. 234 - IF(USE(8).AND..NOT.GASOK(3))THEN 235 - PRINT *,' !!!!!! OPTSET WARNING : The field function uses'// 236 - - ' the diffusion but diffusion' 237 - PRINT *,' coefficients have not'// 238 - - ' been entered; not executed.' 239 - CALL ALGCLR(IENFLD) 240 - RETURN 241 - ELSEIF(USE(8))THEN 242 - EVALD=.TRUE. 1 507 P=OPTIMISE D=OPTSET 4 PAGE 733 243 - ELSE 244 - EVALD=.FALSE. 245 - ENDIF 246 - * Avalanche data. 247 - IF(USE(9).AND..NOT.GASOK(4))THEN 248 - PRINT *,' !!!!!! OPTSET WARNING : The field function uses'// 249 - - ' the avalanche but Townsend' 250 - PRINT *,' coefficients have not'// 251 - - ' been entered; not executed.' 252 - CALL ALGCLR(IENFLD) 253 - RETURN 254 - ELSEIF(USE(9))THEN 255 - EVALA=.TRUE. 256 - ELSE 257 - EVALA=.FALSE. 258 - ENDIF 259 - * Any of the above for other than TRACK or GRID. 260 - IF((USE(7).OR.USE(8).OR.USE(9)).AND.PNTTYP.EQ.'WIRE')THEN 261 - PRINT *,' !!!!!! OPTSET WARNING : Drift time, diffusion'// 262 - - ' and multiplication not allowed with ON WIRE.' 263 - CALL ALGCLR(IENFLD) 264 - RETURN 265 - ENDIF 266 - *** Get the average of the field function, if needed. 267 - IF(VALTYP.EQ.'AVERAGE')THEN 268 - CALL OPTAVE(AVER,IFAIL) 269 - IF(IFAIL.NE.0)THEN 270 - PRINT *,' !!!!!! OPTSET WARNING : Unable to evaluate'// 271 - - ' the current function average.' 272 - CALL ALGCLR(IENFLD) 273 - RETURN 274 - ENDIF 275 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTSET DEBUG : The'', 276 - - '' current field-function average is '',E15.8)') AVER 277 - WRITE(FUNPOS,'(E15.8,65X)') AVER 278 - NPOS=15 279 - ENDIF 280 - *** Convert the target and weight functions, set variable names. 281 - IF(POLAR)THEN 282 - VARLIS(1)='R ' 283 - VARLIS(2)='PHI ' 284 - ELSE 285 - VARLIS(1)='X ' 286 - VARLIS(2)='Y ' 287 - ENDIF 288 - * The conversion itself. 289 - CALL ALGPRE(FUNPOS(1:NPOS),NPOS,VARLIS,2,NRES,USE,IENPOS,IFAIL) 290 - * Check the output. 291 - IF(IFAIL.NE.0)THEN 292 - PRINT *,' !!!!!! OPTSET WARNING : SET not executed'// 293 - - ' because of an error in the position function.' 294 - CALL ALGCLR(IENFLD) 295 - CALL ALGCLR(IENPOS) 296 - RETURN 297 - ELSEIF(NRES.NE.1)THEN 298 - PRINT *,' !!!!!! OPTSET WARNING : SET not executed'// 299 - - ' because the position function does not return'// 300 - - ' a single value.' 301 - CALL ALGCLR(IENFLD) 302 - CALL ALGCLR(IENPOS) 303 - RETURN 304 - ENDIF 305 - ** Conversion of the weight-function. 306 - CALL ALGPRE(FUNWGT(1:NWGT),NWGT,VARLIS,2,NRES,USE,IENWGT,IFAIL) 307 - * Check the output. 308 - IF(IFAIL.NE.0)THEN 309 - PRINT *,' !!!!!! OPTSET WARNING : SET not executed'// 310 - - ' because of an error in the weight function.' 311 - CALL ALGCLR(IENFLD) 312 - CALL ALGCLR(IENWGT) 313 - CALL ALGCLR(IENPOS) 314 - RETURN 315 - ELSEIF(NRES.NE.1)THEN 316 - PRINT *,' !!!!!! OPTSET WARNING : SET not executed'// 317 - - ' because the weight function does not return a', 318 - - ' single value.' 319 - CALL ALGCLR(IENFLD) 320 - CALL ALGCLR(IENWGT) 321 - CALL ALGCLR(IENPOS) 322 - RETURN 323 - ENDIF 324 - *** Set the fitting input parameters. 325 - CALL OPTXYA(XFIT,YFIT,AFIT,WEIGHT,IFAIL) 326 - IF(IFAIL.NE.0)THEN 327 - PRINT *,' !!!!!! OPTSET WARNING : SET not executed'// 328 - - ' because setting fitting parameters failed.' 329 - CALL ALGCLR(IENFLD) 330 - CALL ALGCLR(IENWGT) 331 - CALL ALGCLR(IENPOS) 332 - RETURN 333 - ENDIF 334 - *** Carry out the fitting itself. 335 - IF(PNTTYP.EQ.'GRID')THEN 336 - NPNT=NGRIDX*NGRIDY 337 - ELSEIF(PNTTYP.EQ.'TRACK')THEN 338 - NPNT=NPOINT 339 - ELSEIF(PNTTYP.EQ.'WIRE')THEN 340 - NPNT=NSWIRE 341 - ENDIF 342 - NPAR=NSW 343 - CALL LSQFIT(OPTFUN,AFIT,EAFIT,NPAR,XFIT,YFIT,WEIGHT,NPNT, 344 - - NITMAX,DIST,CHI2,EPS,LFITPR,IFAIL) 345 - IF(IFAIL.NE.0)PRINT *,' !!!!!! OPTSET WARNING : The new'// 346 - - ' potentials do not fulfill your requirements.' 347 - *** And calculate the charges for the final result. 348 - DO 100 I=1,NWIRE 1 507 P=OPTIMISE D=OPTSET 5 PAGE 734 349 - IF(INDSW(I).NE.0)THEN 350 - VFIT(I)=VST(I)+AFIT(INDSW(I)) 351 - ELSE 352 - VFIT(I)=VST(I) 353 - ENDIF 354 - 100 CONTINUE 355 - DO 110 I=1,4 356 - IF(YNPLAN(I).AND.INDPLA(I).NE.0)THEN 357 - VPLFIT(I)=VPLST(I)+AFIT(INDPLA(I)) 358 - ELSE 359 - VPLFIT(I)=VPLST(I) 360 - ENDIF 361 - 110 CONTINUE 362 - IF(TUBE.AND.INDPLA(5).NE.0)THEN 363 - VPLFIT(5)=VPLST(5)+AFIT(INDPLA(5)) 364 - ELSE 365 - VPLFIT(5)=VPLST(5) 366 - ENDIF 367 - CALL SETNEW(VFIT,VPLFIT,IFAIL) 368 - IF(IFAIL.NE.0)PRINT *,' !!!!!! OPTSET WARNING : Failure to'// 369 - - ' compute the wire charges for the final settings.' 370 - *** Release the field and position function instruction list. 371 - CALL ALGCLR(IENFLD) 372 - CALL ALGCLR(IENWGT) 373 - CALL ALGCLR(IENPOS) 374 - *** Register the amount of CPU time spent on these calculations. 375 - CALL TIMLOG('Playing with the voltage settings: ') 376 - END 508 GARFIELD ================================================== P=OPTIMISE D=OPTFUN 1 ============================ 0 + +DECK,OPTFUN. 1 - SUBROUTINE OPTFUN(PNT,AFIT,VALUE) 2 - *----------------------------------------------------------------------- 3 - * OPTFUN - Function returning the value of the field function at the 4 - * position corresponding to PNT (integer code). 5 - * (Last changed on 20/10/99.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,CAPACMATRIX. 11.- +SEQ,OPTDATA. 12.- +SEQ,PARAMETERS. 13.- +SEQ,CONSTANTS. 14.- +SEQ,DRIFTLINE. 15 - DOUBLE PRECISION PNT,AFIT(MXFPAR),VALUE 16 - REAL RES(1),VAR(MXVAR),VFIT(MXWIRE),EX,EY,EZ,ETOT,VOLT,DRES,QPLT, 17 - - ANG,VPLFIT(5) 18 - INTEGER MODVAR(MXVAR),MODRES(1),I,ITYPE,ILOC,ISWIRE,IFAIL,IPOS, 19 - - JPOS 20 - *** Drift line parameters. 21 - QPLT=-1.0 22 - ITYPE=1 23 - *** First set the potentials. 24 - DO 10 I=1,NWIRE 25 - IF(INDSW(I).NE.0)THEN 26 - VFIT(I)=VST(I)+AFIT(INDSW(I)) 27 - ELSE 28 - VFIT(I)=VST(I) 29 - ENDIF 30 - 10 CONTINUE 31 - DO 20 I=1,4 32 - IF(YNPLAN(I).AND.INDPLA(I).NE.0)THEN 33 - VPLFIT(I)=VPLST(I)+AFIT(INDPLA(I)) 34 - ELSE 35 - VPLFIT(I)=VPLST(I) 36 - ENDIF 37 - 20 CONTINUE 38 - IF(TUBE.AND.INDPLA(5).NE.0)THEN 39 - VPLFIT(5)=VPLST(5)+AFIT(INDPLA(5)) 40 - ELSE 41 - VPLFIT(5)=VPLST(5) 42 - ENDIF 43 - *** Next reconstruct the charges. 44 - CALL SETNEW(VFIT,VPLFIT,IFAIL) 45 - IF(IFAIL.NE.0)THEN 46 - VALUE=0.0 47 - RETURN 48 - ENDIF 49 - *** Find out to which coordinate PNT belongs. 50 - C if(abs(pnt-anint(pnt)).gt.1.0e-5)print *,' Rounding error !!!' 51 - IF(PNTTYP.EQ.'TRACK')THEN 52 - VAR(1)=XT0+(PNT-1.0)*(XT1-XT0)/REAL(NPOINT-1) 53 - VAR(2)=YT0+(PNT-1.0)*(YT1-YT0)/REAL(NPOINT-1) 54 - IF(POLAR)CALL CFMCTR(VAR(1),VAR(2),VAR(1),VAR(2),1) 55 - CALL EFIELD(VAR(1),VAR(2),0.0, 56 - - VAR(3),VAR(4),EZ,VAR(5),VAR(6), 57 - - IOPT,ILOC) 58 - IF(EVALT.OR.EVALD.OR.EVALA)THEN 59 - CALL DLCALC(VAR(1),VAR(2),0.0,QPLT,ITYPE) 60 - VAR(7)=TU(NU) 61 - IF(EVALD)CALL DLCDIF(VAR(8)) 62 - IF(EVALA)CALL DLCTWN(VAR(9)) 63 - ENDIF 64 - ELSEIF(PNTTYP.EQ.'GRID')THEN 65 - JPOS=1+NINT(PNT-1.0)/NGRIDX 66 - IPOS=NINT(PNT)-NGRIDX*(JPOS-1) 67 - IF(.NOT.POLAR)THEN 68 - VAR(1)=PXMIN+REAL(IPOS-1)*(PXMAX-PXMIN)/REAL(NGRIDX-1) 69 - ELSE 70 - VAR(1)=LOG(EXP(PXMIN)+REAL(IPOS-1)* 71 - - (EXP(PXMAX)-EXP(PXMIN))/REAL(NGRIDX-1)) 72 - ENDIF 73 - VAR(2)=PYMIN+REAL(JPOS-1)*(PYMAX-PYMIN)/REAL(NGRIDY-1) 74 - CALL EFIELD(VAR(1),VAR(2),0.0, 1 508 P=OPTIMISE D=OPTFUN 2 PAGE 735 75 - - VAR(3),VAR(4),EZ,VAR(5),VAR(6), 76 - - IOPT,ILOC) 77 - IF(EVALT.OR.EVALD.OR.EVALA)THEN 78 - CALL DLCALC(VAR(1),VAR(2),0.0,QPLT,ITYPE) 79 - VAR(7)=TU(NU) 80 - IF(EVALD)CALL DLCDIF(VAR(8)) 81 - IF(EVALA)CALL DLCTWN(VAR(9)) 82 - ENDIF 83 - ELSEIF(PNTTYP.EQ.'WIRE')THEN 84 - ISWIRE=0 85 - DO 50 I=1,NWIRE 86 - IF(WIRTYP(I).EQ.'S')ISWIRE=ISWIRE+1 87 - IF(ISWIRE.EQ.NINT(PNT))THEN 88 - DRES=D(I) 89 - D(I)=0.0 90 - VAR(1)=X(I) 91 - VAR(2)=Y(I) 92 - VAR(3)=0.0 93 - VAR(4)=0.0 94 - VAR(5)=0.0 95 - VAR(6)=0.0 96 - DO 60 ANG=0.0,(2.0-1.0/REAL(NPOINT))*PI, 97 - - 2.0*PI/REAL(NPOINT) 98 - CALL EFIELD(X(I)+COS(ANG)*DRES/2, 99 - - Y(I)+SIN(ANG)*DRES/2,0.0, 100 - - EX,EY,EZ,ETOT,VOLT,IOPT,ILOC) 101 - VAR(5)=VAR(5)+ETOT 102 - VAR(6)=VAR(6)+VOLT 103 - 60 CONTINUE 104 - VAR(5)=VAR(5)/REAL(NPOINT) 105 - VAR(6)=VAR(6)/REAL(NPOINT) 106 - D(I)=DRES 107 - GOTO 70 108 - ENDIF 109 - 50 CONTINUE 110 - 70 CONTINUE 111 - VAR(7)=0.0 112 - VAR(8)=0.0 113 - VAR(9)=0.0 114 - ENDIF 115 - *** Transform to polar if needed. 116 - IF(POLAR)THEN 117 - CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) 118 - VAR(3)=VAR(3)/VAR(1) 119 - VAR(4)=VAR(4)/VAR(1) 120 - VAR(5)=VAR(5)/VAR(1) 121 - ENDIF 122 - *** Fill in the mode of the variables. 123 - DO 80 I=1,9 124 - MODVAR(I)=2 125 - 80 CONTINUE 126 - *** Calculate the field function with this field. 127 - CALL ALGEXE(IENFLD,VAR,MODVAR,9,RES,MODRES,1,IFAIL) 128 - *** And return the answer to LSQFIT. 129 - VALUE=RES(1) 130 - END 509 GARFIELD ================================================== P=OPTIMISE D=OPTXYA 1 ============================ 0 + +DECK,OPTXYA. 1 - SUBROUTINE OPTXYA(XFIT,YFIT,AFIT,WEIGHT,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * OPTXYA - Routine fixing the X, Y and A vectors for the fit. 4 - * (Last changed on 20/10/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,OPTDATA. 9.- +SEQ,CELLDATA. 10.- +SEQ,PARAMETERS. 11 - REAL RES(1),VAR(MXVAR),VSUM 12 - DOUBLE PRECISION XFIT(MXFPNT),YFIT(MXFPNT),WEIGHT(MXFPNT), 13 - - AFIT(MXFPAR) 14 - INTEGER MODVAR(MXVAR),MODRES(1),IFAIL,I,J,ISWIRE,ISW,IW,IP,NSUM 15 - *** Check the size of the problem. 16 - IF((PNTTYP.EQ.'TRACK'.AND.NPOINT.GT.MXFPNT).OR. 17 - - (PNTTYP.EQ.'WIRE'.AND.NSWIRE.GT.MXFPNT).OR. 18 - - (PNTTYP.EQ.'GRID'.AND.NGRIDX*NGRIDY.GT.MXFPNT))THEN 19 - PRINT *,' !!!!!! OPTXYA WARNING : The number of points'// 20 - - ' in the fit is too large ; decrease GRID or POINTS'// 21 - - ' as appropriate.' 22 - IFAIL=1 23 - RETURN 24 - ENDIF 25 - IF((PNTTYP.EQ.'TRACK'.AND.NPOINT.LT.1).OR. 26 - - (PNTTYP.EQ.'WIRE'.AND.NSWIRE.LT.1).OR. 27 - - (PNTTYP.EQ.'GRID'.AND.NGRIDX*NGRIDY.LT.1))THEN 28 - PRINT *,' !!!!!! OPTXYA WARNING : The number of points'// 29 - - ' in the fit is too small ; increase GRID or POINTS'// 30 - - ' as appropriate.' 31 - IFAIL=1 32 - RETURN 33 - ENDIF 34 - *** Loop over the track or ... 35 - IF(PNTTYP.EQ.'TRACK')THEN 36 - DO 10 I=1,NPOINT 37 - * Internal coordinate. 38 - XFIT(I)=I 39 - * Position variables. 40 - VAR(1)=XT0+REAL(I-1)*(XT1-XT0)/REAL(NPOINT-1) 41 - VAR(2)=YT0+REAL(I-1)*(YT1-YT0)/REAL(NPOINT-1) 42 - IF(POLAR)CALL CFMCTP(VAR(1),VAR(2),VAR(1),VAR(2),1) 43 - MODVAR(1)=2 44 - MODVAR(2)=2 45 - * Position dependent target function. 46 - CALL ALGEXE(IENPOS,VAR,MODVAR,2,RES,MODRES,1,IFAIL) 1 509 P=OPTIMISE D=OPTXYA 2 PAGE 736 47 - IF(IFAIL.NE.0)THEN 48 - PRINT *,' !!!!!! OPTXYA WARNING : Arithmetic error'// 49 - - ' evaluating the position function.' 50 - RETURN 51 - ENDIF 52 - YFIT(I)=RES(1) 53 - * Position dependent weighting function. 54 - CALL ALGEXE(IENWGT,VAR,MODVAR,2,RES,MODRES,1,IFAIL) 55 - IF(IFAIL.NE.0)THEN 56 - PRINT *,' !!!!!! OPTXYA WARNING : Arithmetic error'// 57 - - ' evaluating the weighting function.' 58 - RETURN 59 - ELSEIF(RES(1).LE.0.0)THEN 60 - PRINT *,' !!!!!! OPTXYA WARNING : The weighting'// 61 - - ' function is not >0 at (',VAR(1),',',VAR(2),').' 62 - RETURN 63 - ENDIF 64 - WEIGHT(I)=RES(1) 65 - 10 CONTINUE 66 - *** over the grid or ... 67 - ELSEIF(PNTTYP.EQ.'GRID')THEN 68 - DO 30 I=1,NGRIDX 69 - DO 20 J=1,NGRIDY 70 - * Internal coordinate. 71 - XFIT(I+NGRIDX*(J-1))=I+NGRIDX*(J-1) 72 - * Grid position. 73 - IF(.NOT.POLAR)THEN 74 - VAR(1)=PXMIN+REAL(I-1)*(PXMAX-PXMIN)/REAL(NGRIDX-1) 75 - ELSE 76 - VAR(1)=LOG(EXP(PXMIN)+REAL(I-1)* 77 - - (EXP(PXMAX)-EXP(PXMIN))/REAL(NGRIDX-1)) 78 - ENDIF 79 - VAR(2)=PYMIN+REAL(J-1)*(PYMAX-PYMIN)/REAL(NGRIDY-1) 80 - IF(POLAR)CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) 81 - MODVAR(1)=2 82 - MODVAR(2)=2 83 - * Position dependent target function. 84 - CALL ALGEXE(IENPOS,VAR,MODVAR,2,RES,MODRES,1,IFAIL) 85 - IF(IFAIL.NE.0)THEN 86 - PRINT *,' !!!!!! OPTXYA WARNING : Arithmetic error'// 87 - - ' evaluating the position function.' 88 - RETURN 89 - ENDIF 90 - YFIT(I+NGRIDX*(J-1))=RES(1) 91 - * Position dependent weighting function. 92 - CALL ALGEXE(IENWGT,VAR,MODVAR,2,RES,MODRES,1,IFAIL) 93 - IF(IFAIL.NE.0)THEN 94 - PRINT *,' !!!!!! OPTXYA WARNING : Arithmetic error'// 95 - - ' evaluating the weighting function.' 96 - RETURN 97 - ELSEIF(RES(1).EQ.0.0)THEN 98 - PRINT *,' !!!!!! OPTXYA WARNING : The weighting'// 99 - - ' function is zero at (',VAR(1),',',VAR(2),').' 100 - RETURN 101 - ENDIF 102 - WEIGHT(I+NGRIDX*(J-1))=RES(1) 103 - 20 CONTINUE 104 - 30 CONTINUE 105 - *** over the wire surface or ... 106 - ELSEIF(PNTTYP.EQ.'WIRE')THEN 107 - ISWIRE=0 108 - DO 50 I=1,NWIRE 109 - * Wire selection. 110 - IF(WIRTYP(I).NE.'S')GOTO 50 111 - ISWIRE=ISWIRE+1 112 - * Internal coordinate. 113 - XFIT(ISWIRE)=ISWIRE 114 - * Position. 115 - VAR(1)=X(I) 116 - VAR(2)=Y(I) 117 - IF(POLAR)CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) 118 - MODVAR(1)=2 119 - MODVAR(2)=2 120 - * Position dependent target function. 121 - CALL ALGEXE(IENPOS,VAR,MODVAR,2,RES,MODRES,1,IFAIL) 122 - IF(IFAIL.NE.0)THEN 123 - PRINT *,' !!!!!! OPTXYA WARNING : Arithmetic error'// 124 - - ' evaluating the position function.' 125 - RETURN 126 - ENDIF 127 - YFIT(ISWIRE)=RES(1) 128 - * Position dependent weighting function. 129 - CALL ALGEXE(IENWGT,VAR,MODVAR,2,RES,MODRES,1,IFAIL) 130 - IF(IFAIL.NE.0)THEN 131 - PRINT *,' !!!!!! OPTXYA WARNING : Arithmetic error'// 132 - - ' evaluating the weighting function.' 133 - RETURN 134 - ELSEIF(RES(1).EQ.0.0)THEN 135 - PRINT *,' !!!!!! OPTXYA WARNING : The weighting'// 136 - - ' function is zero for wire ',I,'.' 137 - RETURN 138 - ENDIF 139 - WEIGHT(ISWIRE)=RES(1) 140 - 50 CONTINUE 141 - *** over something unknown. 142 - ELSE 143 - PRINT *,' ###### OPTXYA ERROR : Unknown averaging type ', 144 - - PNTTYP,' received; program bug - please report.' 145 - IFAIL=1 146 - RETURN 147 - ENDIF 148 - *** Next set the parameters to be fitted, check size first. 149 - IF(NSW.GT.MXFPAR)THEN 150 - PRINT *,' !!!!!! OPTXYA WARNING : The number of'// 151 - - ' electrode groups is too large ; decrease to ', 152 - - MXFPAR,'.' 1 509 P=OPTIMISE D=OPTXYA 3 PAGE 737 153 - IFAIL=1 154 - RETURN 155 - ENDIF 156 - IF(NSW.LT.1)THEN 157 - PRINT *,' !!!!!! OPTXYA WARNING : There are no'// 158 - - ' electrode groups ; use SELECT to get some.' 159 - IFAIL=1 160 - RETURN 161 - ENDIF 162 - * Loop over the electrode groups. 163 - DO 120 ISW=1,NSW 164 - * Sum the current potential of the fitting parameters. 165 - VSUM=0.0 166 - NSUM=0 167 - DO 130 IW=1,NWIRE 168 - IF(INDSW(IW).EQ.ISW)THEN 169 - VSUM=VSUM+V(IW) 170 - NSUM=NSUM+1 171 - ENDIF 172 - 130 CONTINUE 173 - DO 140 IP=1,4 174 - IF(YNPLAN(IP).AND.INDPLA(IP).EQ.ISW)THEN 175 - VSUM=VSUM+VTPLAN(IP) 176 - NSUM=NSUM+1 177 - ENDIF 178 - 140 CONTINUE 179 - IF(TUBE.AND.INDPLA(5).EQ.ISW)THEN 180 - VSUM=VSUM+VTTUBE 181 - NSUM=NSUM+1 182 - ENDIF 183 - * Take the average. 184 - IF(NSUM.EQ.0)THEN 185 - PRINT *,' !!!!!! OPTXYA WARNING : Group ',ISW,' is'// 186 - - ' empty; SET not executed.' 187 - IFAIL=1 188 - RETURN 189 - ENDIF 190 - AFIT(ISW)=VSUM/NSUM 191 - 120 CONTINUE 192 - *** Subtract from the original settings and store as starting values. 193 - DO 150 IW=1,NWIRE 194 - IF(INDSW(IW).GT.0)THEN 195 - VST(IW)=V(IW)-AFIT(INDSW(IW)) 196 - ELSE 197 - VST(IW)=V(IW) 198 - ENDIF 199 - 150 CONTINUE 200 - DO 160 IP=1,4 201 - IF(YNPLAN(IP).AND.INDPLA(IP).GT.0)THEN 202 - VPLST(IP)=VTPLAN(IP)-AFIT(INDPLA(IP)) 203 - ELSE 204 - VPLST(IP)=VTPLAN(IP) 205 - ENDIF 206 - 160 CONTINUE 207 - IF(TUBE.AND.INDPLA(5).GT.0)THEN 208 - VPLST(5)=VTTUBE-AFIT(INDPLA(5)) 209 - ELSE 210 - VPLST(5)=VTTUBE 211 - ENDIF 212 - *** Things seem to be OK, set IFAIL to 0 and return. 213 - IFAIL=0 214 - END 510 GARFIELD ================================================== P=OPTIMISE D=OPTAVE 1 ============================ 0 + +DECK,OPTAVE. 1 - SUBROUTINE OPTAVE(AVER,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * OPTAVE - Routine returning the current function average. 4 - * (Last changed on 10/ 9/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,OPTDATA. 10.- +SEQ,PARAMETERS. 11.- +SEQ,CONSTANTS. 12.- +SEQ,DRIFTLINE. 13 - REAL VAR(MXVAR),RES(1),QPLT,AVER,ANG,DRES,EZ 14 - INTEGER MODVAR(MXVAR),MODRES(1),ITYPE,IFAIL,I,J,NDATA,ILOC 15 - *** Drift line parameters. 16 - QPLT=-1.0 17 - ITYPE=1 18 - *** Preset the sum and the number of data-points. 19 - AVER=0.0 20 - NDATA=0 21 - *** The variable modes never change. 22 - DO 5 I=1,9 23 - MODVAR(I)=2 24 - 5 CONTINUE 25 - *** Loop over the track or ... 26 - IF(PNTTYP.EQ.'TRACK')THEN 27 - DO 10 I=1,NPOINT 28 - VAR(1)=XT0+REAL(I-1)*(XT1-XT0)/REAL(NPOINT-1) 29 - VAR(2)=YT0+REAL(I-1)*(YT1-YT0)/REAL(NPOINT-1) 30 - IF(POLAR)CALL CFMCTR(VAR(1),VAR(2),VAR(1),VAR(2),1) 31 - CALL EFIELD(VAR(1),VAR(2),0.0, 32 - - VAR(3),VAR(4),EZ,VAR(5),VAR(6), 33 - - IOPT,ILOC) 34 - IF(EVALT.OR.EVALD.OR.EVALA)THEN 35 - CALL DLCALC(VAR(1),VAR(2),0.0,QPLT,ITYPE) 36 - VAR(7)=TU(NU) 37 - IF(EVALD)CALL DLCDIF(VAR(8)) 38 - IF(EVALA)CALL DLCTWN(VAR(9)) 39 - ENDIF 40 - IF(ILOC.EQ.0)THEN 1 510 P=OPTIMISE D=OPTAVE 2 PAGE 738 41 - IF(POLAR)THEN 42 - CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) 43 - VAR(3)=VAR(3)/VAR(1) 44 - VAR(4)=VAR(4)/VAR(1) 45 - VAR(5)=VAR(5)/VAR(1) 46 - ENDIF 47 - CALL ALGEXE(IENFLD,VAR,MODVAR,9,RES,MODRES,1,IFAIL) 48 - IF(IFAIL.EQ.0)THEN 49 - AVER=AVER+RES(1) 50 - NDATA=NDATA+1 51 - ENDIF 52 - ENDIF 53 - 10 CONTINUE 54 - *** over the grid. 55 - ELSEIF(PNTTYP.EQ.'GRID')THEN 56 - DO 30 I=1,NGRIDX 57 - DO 20 J=1,NGRIDY 58 - IF(.NOT.POLAR)THEN 59 - VAR(1)=PXMIN+REAL(I-1)*(PXMAX-PXMIN)/REAL(NGRIDX-1) 60 - ELSE 61 - VAR(1)=LOG(EXP(PXMIN)+REAL(I-1)* 62 - - (EXP(PXMAX)-EXP(PXMIN))/REAL(NGRIDX-1)) 63 - ENDIF 64 - VAR(2)=PYMIN+REAL(J-1)*(PYMAX-PYMIN)/REAL(NGRIDY-1) 65 - CALL EFIELD(VAR(1),VAR(2),0.0, 66 - - VAR(3),VAR(4),EZ,VAR(5),VAR(6), 67 - - IOPT,ILOC) 68 - IF(EVALT.OR.EVALD.OR.EVALA)THEN 69 - CALL DLCALC(VAR(1),VAR(2),0.0,QPLT,ITYPE) 70 - VAR(7)=TU(NU) 71 - IF(EVALD)CALL DLCDIF(VAR(8)) 72 - IF(EVALA)CALL DLCTWN(VAR(9)) 73 - ENDIF 74 - IF(ILOC.EQ.0)THEN 75 - IF(POLAR)THEN 76 - CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) 77 - VAR(3)=VAR(3)/VAR(1) 78 - VAR(4)=VAR(4)/VAR(1) 79 - VAR(5)=VAR(5)/VAR(1) 80 - ENDIF 81 - CALL ALGEXE(IENFLD,VAR,MODVAR,9,RES,MODRES,1,IFAIL) 82 - IF(IFAIL.EQ.0)THEN 83 - AVER=AVER+RES(1) 84 - NDATA=NDATA+1 85 - ENDIF 86 - ENDIF 87 - 20 CONTINUE 88 - 30 CONTINUE 89 - *** over the wires or ... 90 - ELSEIF(PNTTYP.EQ.'WIRE')THEN 91 - DO 50 I=1,NWIRE 92 - IF(WIRTYP(I).NE.'S')GOTO 50 93 - DRES=D(I) 94 - D(I)=0.0 95 - DO 60 ANG=0.0,(2.0-1.0/REAL(NPOINT))*PI, 96 - - 2.0*PI/REAL(NPOINT) 97 - VAR(1)=X(I)+COS(ANG)*DRES/2 98 - VAR(2)=Y(I)+SIN(ANG)*DRES/2 99 - CALL EFIELD(VAR(1),VAR(2),0.0, 100 - - VAR(3),VAR(4),EZ,VAR(5),VAR(6), 101 - - IOPT,ILOC) 102 - VAR(7)=0.0 103 - VAR(8)=0.0 104 - VAR(9)=0.0 105 - IF(ILOC.EQ.0)THEN 106 - IF(POLAR)THEN 107 - CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) 108 - VAR(3)=VAR(3)/VAR(1) 109 - VAR(4)=VAR(4)/VAR(1) 110 - VAR(5)=VAR(5)/VAR(1) 111 - ENDIF 112 - CALL ALGEXE(IENFLD,VAR,MODVAR,9,RES,MODRES,1,IFAIL) 113 - IF(IFAIL.EQ.0)THEN 114 - AVER=AVER+RES(1) 115 - NDATA=NDATA+1 116 - ENDIF 117 - ENDIF 118 - 60 CONTINUE 119 - D(I)=DRES 120 - 50 CONTINUE 121 - *** Or over something unknown. 122 - ELSE 123 - PRINT *,' ###### OPTAVE ERROR : Unknown averaging type ', 124 - - PNTTYP,' received; program bug - please report.' 125 - RETURN 126 - ENDIF 127 - *** Check there are enough data-points. 128 - IF(NDATA.LT.1)THEN 129 - PRINT *,' !!!!!! OPTAVE WARNING : Insufficient number of', 130 - - ' normal data-points found.' 131 - IFAIL=1 132 - RETURN 133 - ENDIF 134 - *** Calculate the average. 135 - AVER=AVER/REAL(NDATA) 136 - *** Reset IFAIL to 0, things seem to be OK. 137 - IFAIL=0 138 - END 511 GARFIELD ================================================== P=OPTIMISE D=OPTDSN 1 ============================ 0 + +DECK,OPTDSN. 1 - SUBROUTINE OPTDSN(ACTION,IREFNO) 2 - *----------------------------------------------------------------------- 3 - * OPTDSN - Saves and restores those parts of the cell description 4 - * that are modified during optimisation. 1 511 P=OPTIMISE D=OPTDSN 2 PAGE 739 5 - * VARIABLES : ACTION : Type of dataset operation. 6 - * IREFNO : Record reference number. 7 - * (Last changed on 9/10/90.) 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,PRINTPLOT. 12 - LOGICAL OPENED 0 13-+ +SELF,IF=SAVE. 14 - SAVE IREF 0 15-+ +SELF. 16 - CHARACTER*(*) ACTION 17 - * Open the dataset and log the file. 18 - IF(ACTION.EQ.'OPEN')THEN 0 19-+ +SELF,IF=CMS. 20 - CALL VMCMS('FILEDEF 13 DISK GARFTEMP OPTIMISE A6'// 21 - - ' (CHANGE XTENT 1000',IRC) 22 - IF(IRC.NE.0)THEN 23 - PRINT *,' !!!!!! OPTDSN WARNING : Error issuing a'// 24 - - ' FILEDEF for the potential dataset.' 25 - GOTO 2020 26 - ENDIF 0 27-+ +SELF,IF=CRAY. 28 - OPEN(UNIT=13,STATUS='SCRATCH',ACCESS='DIRECT', 29 - - FORM='UNFORMATTED',RECL=8+8*NWIRE,IOSTAT=IOS,ERR=2020) 30 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTDSN DEBUG : Cray'', 31 - - '' Optimisation file opened on lun 13, lrecl='',I5)') 32 - - 8+8*NWIRE 0 33-+ +SELF,IF=-CRAY. 34 - OPEN(UNIT=13,STATUS='SCRATCH',ACCESS='DIRECT', 35 - - FORM='UNFORMATTED',RECL=8+4*NWIRE,IOSTAT=IOS,ERR=2020) 36 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTDSN DEBUG :'', 37 - - '' Optimisation file opened on lun 13, lrecl='',I5)') 38 - - 8+4*NWIRE 0 39-+ +SELF. 40 - CALL DSNLOG('< Optimisation auxilliary file >','Scratch ', 41 - - 'Direct ','Read/Write') 42 - IREF=0 43 - * Close the dataset. 44 - ELSEIF(ACTION.EQ.'CLOSE')THEN 45 - INQUIRE(UNIT=13,OPENED=OPENED) 46 - IF(.NOT.OPENED)THEN 47 - PRINT *,' ###### OPTDSN ERROR : Dataset not opened;', 48 - - ' program bug - please report.' 49 - ELSE 50 - CLOSE(UNIT=13,IOSTAT=IOS,ERR=2030) 51 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTDSN DEBUG :'', 52 - - '' The optimisation file has been closed.'')') 53 - ENDIF 54 - * Save a record. 55 - ELSEIF(ACTION.EQ.'SAVE')THEN 56 - IREFNO=0 57 - INQUIRE(UNIT=13,OPENED=OPENED) 58 - IF(.NOT.OPENED)THEN 59 - PRINT *,' ###### OPTDSN ERROR : Dataset not;'// 60 - - ' opened; program bug - please report.' 61 - ELSE 62 - IREF=IREF+1 63 - IF(IREF.GT.1000)THEN 64 - PRINT *,' !!!!!! OPTDSN WARNING : Cannot'// 65 - - ' be saved because the dataset if full.' 66 - RETURN 67 - ENDIF 68 - WRITE(13,REC=IREF,IOSTAT=IOS,ERR=2010) 69 - - V0,(V(I),I=1,NWIRE) 70 - IREFNO=IREF 71 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTDSN DEBUG :'', 72 - - '' Record '',I3,'' has been saved.'')') IREF 73 - ENDIF 74 - * Retrieve a record. 75 - ELSEIF(ACTION.EQ.'RESTORE')THEN 76 - INQUIRE(UNIT=13,OPENED=OPENED) 77 - IF(.NOT.OPENED)THEN 78 - PRINT *,' ###### OPTDSN ERROR : Dataset not yet;'// 79 - - ' opened program bug - please report.' 80 - ELSE 81 - IF(IREFNO.LE.0.OR.IREFNO.GT.IREF)THEN 82 - PRINT *,' !!!!!! OPTDSN WARNING : Illegal'// 83 - - ' reference number.' 84 - ELSE 85 - READ(13,REC=IREFNO,IOSTAT=IOS,ERR=2010) 86 - - V0,(V(I),I=1,NWIRE) 87 - IF(LDEBUG)WRITE(LUNOUT, 88 - - '('' ++++++ OPTDSN DEBUG : Record '',I3, 89 - - '' has been retrieved.'')') IREF 90 - ENDIF 91 - ENDIF 92 - * Invalid instruction. 93 - ELSE 94 - PRINT *,' ###### OPTDSN ERROR : Invalid action arg ', 95 - - ACTION,' received; program bug - please report.' 96 - ENDIF 97 - RETURN 98 - *** Handle I/O problems. 99 - 2010 CONTINUE 100 - PRINT *,' !!!!!! OPTDSN WARNING : I/O error while saving or'// 101 - - ' restoring a modification record.' 102 - CALL INPIOS(IOS) 103 - RETURN 104 - 2020 CONTINUE 1 511 P=OPTIMISE D=OPTDSN 3 PAGE 740 105 - PRINT *,' !!!!!! OPTDSN WARNING : Error opening a modification'// 106 - - ' dataset ; do not use SAVE and RESTORE.' 107 - CALL INPIOS(IOS) 108 - CLOSE(UNIT=13,IOSTAT=IOS,ERR=2030) 109 - RETURN 110 - 2030 CONTINUE 111 - PRINT *,' !!!!!! OPTDSN WARNING : Error closing a modification'// 112 - - ' dataset ; probably harmless.' 113 - CALL INPIOS(IOS) 114 - END 512 GARFIELD ================================================== P=GAS D= 1 ============================ 0 + +PATCH,GAS. 513 GARFIELD ================================================== P=GAS D=GASADD 1 ============================ 0 + +DECK,GASADD. 1 - SUBROUTINE GASADD 2 - *----------------------------------------------------------------------- 3 - * GASADD - Adds pieces to the gas table. 4 - * (Last changed on 7/ 3/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GASDATA. 9.- +SEQ,CONSTANTS. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,BFIELD. 12.- +SEQ,GLOBALS. 13.- +SEQ,MATDATA. 14 - CHARACTER*(MXCHAR) STRFUN 15 - CHARACTER*10 VARLIS(MXVAR),NAME 16 - REAL VAR(MXVAR),RES(1) 17 - INTEGER NWORD,I,J,K,L,INEXT,INPCMP,IOBJ,NVAR,NCFUN,NCNAME,IENTRY, 18 - - IRMAT1,ISMAT1,IRMAT2,ISMAT2,MATSLT,NRES,IFAIL1,NERR,IORD, 19 - - IORDR,MODVAR(MXVAR),MODRES(1) 20 - LOGICAL USE(MXVAR),OK 21 - EXTERNAL INPCMP,MATSLT 22 - *** Identify the routine. 23 - IF(LIDENT)PRINT *,' /// ROUTINE GASADD ///' 24 - *** Make sure that the electric field table is present. 25 - IF(NGAS.LT.2)THEN 26 - PRINT *,' !!!!!! GASADD WARNING : The electric field'// 27 - - ' vector has not been set yet; nothing added.' 28 - RETURN 29 - ENDIF 30 - *** Set the list of variables. 31 - VARLIS(1)='EP' 32 - VARLIS(2)='ANGLE_EB' 33 - VARLIS(3)='VELOCITY' 34 - VARLIS(4)='MOBILITY' 35 - VARLIS(5)='SIGMA_L' 36 - VARLIS(6)='SIGMA_T' 37 - VARLIS(7)='TOWNSEND' 38 - VARLIS(8)='ATTACHMENT' 39 - VARLIS(9)='LORENTZ' 40 - VARLIS(10)='B' 41 - VARLIS(11)='BOLTZMANN' 42 - VARLIS(12)='ECHARGE' 43 - VARLIS(13)='P' 44 - VARLIS(14)='T' 45 - NVAR=14 46 - *** Count words. 47 - CALL INPNUM(NWORD) 48 - *** Loop over the components. 49 - INEXT=2 50 - DO 10 I=2,NWORD 51 - IF(I.LT.INEXT)GOTO 10 52 - *** Find out which element is to be changed. 53 - IOBJ=0 54 - IF(INPCMP(I,'DR#IFT-#VELOCITY').NE.0)THEN 55 - IOBJ=1 56 - ELSEIF(INPCMP(I,'ION-MOB#ILITY')+ 57 - - INPCMP(I,'MOB#ILITY').NE.0)THEN 58 - IOBJ=2 59 - ELSEIF(INPCMP(I,'LONG#ITUDINAL-DIFF#USION')+ 60 - - INPCMP(I,'DIFF#USION').NE.0)THEN 61 - IOBJ=3 62 - ELSEIF(INPCMP(I,'TRANS#VERSE-DIFF#USION').NE.0)THEN 63 - IOBJ=8 64 - ELSEIF(INPCMP(I,'TOWN#SEND-#COEFFICIENTS').NE.0)THEN 65 - IOBJ=4 66 - ELSEIF(INPCMP(I,'ATT#ACHMENT-#COEFFICIENTS').NE.0)THEN 67 - IOBJ=6 68 - ELSEIF(INPCMP(I,'LOR#ENTZ-#ANGLES').NE.0)THEN 69 - IF(MAGOK)THEN 70 - IOBJ=7 71 - ELSE 72 - CALL INPMSG(I,'There is no B field.') 73 - GOTO 10 74 - ENDIF 75 - ELSE 76 - CALL INPMSG(I,'Not a known object.') 77 - GOTO 10 78 - ENDIF 79 - *** Pick up the function string or the pair of matrices. 80 - IF(I+1.GT.NWORD)THEN 81 - CALL INPMSG(I,'Should have an argument.') 82 - GOTO 10 83 - ** Could be a set of matrices. 84 - ELSEIF(INPCMP(I+2,'VS').NE.0.AND.I+3.LE.NWORD)THEN 85 - * Continue 4 words from here. 86 - INEXT=I+4 87 - * Locate both matrices. 88 - IRMAT1=0 1 513 P=GAS D=GASADD 2 PAGE 741 89 - IRMAT2=0 90 - CALL INPSTR(I+1,I+1,NAME,NCNAME) 91 - DO 110 J=1,NGLB 92 - IF(GLBMOD(J).EQ.5.AND.GLBVAR(J).EQ.NAME(1:NCNAME)) 93 - - IRMAT1=NINT(GLBVAL(J)) 94 - 110 CONTINUE 95 - ISMAT1=MATSLT(IRMAT1) 96 - CALL INPSTR(I+3,I+3,NAME,NCNAME) 97 - DO 120 J=1,NGLB 98 - IF(GLBMOD(J).EQ.5.AND.GLBVAR(J).EQ.NAME(1:NCNAME)) 99 - - IRMAT2=NINT(GLBVAL(J)) 100 - 120 CONTINUE 101 - ISMAT2=MATSLT(IRMAT2) 102 - * Make sure both exist. 103 - IF(ISMAT1.EQ.0)CALL INPMSG(I+1,'Not a known matrix.') 104 - IF(ISMAT2.EQ.0)CALL INPMSG(I+3,'Not a known matrix.') 105 - IF(ISMAT1.EQ.0.OR.ISMAT2.EQ.0)GOTO 10 106 - * Make sure they are 1-dimensional. 107 - IF(MDIM(ISMAT1).NE.1)CALL INPMSG(I+1,'Not 1-dimensional.') 108 - IF(MDIM(ISMAT2).NE.1)CALL INPMSG(I+3,'Not 1-dimensional.') 109 - IF(MDIM(ISMAT1).NE.1.OR.MDIM(ISMAT2).NE.1)GOTO 10 110 - IENTRY=0 111 - * Make sure the table range is covered. 112 - IF(MVEC(MORG(ISMAT2)+1).GT.EGAS(1).OR. 113 - - MVEC(MORG(ISMAT2)+MLEN(ISMAT2)).LT.EGAS(NGAS))THEN 114 - IF(.NOT.GASOK(IOBJ))THEN 115 - CALL INPMSG(I+3,'Does not cover the table.') 116 - GOTO 10 117 - ELSE 118 - PRINT *,' ------ GASADD MESSAGE : Data covers'// 119 - - ' table only partially; keeping old values'// 120 - - ' where needed.' 121 - ENDIF 122 - ENDIF 123 - * There could still be an order of interpolation. 124 - IORD=2 125 - IF(INPCMP(INEXT,'LIN#EAR').NE.0)THEN 126 - IORD=1 127 - INEXT=INEXT+1 128 - ELSEIF(INPCMP(INEXT,'QUA#DRATIC').NE.0)THEN 129 - IORD=2 130 - INEXT=INEXT+1 131 - ELSEIF(INPCMP(INEXT,'CUB#IC').NE.0)THEN 132 - IORD=3 133 - INEXT=INEXT+1 134 - ELSEIF(INPCMP(INEXT,'ORD#ER').NE.0)THEN 135 - IF(INEXT+1.LT.NWORD)THEN 136 - CALL INPMSG(INEXT,'Should have an argument.') 137 - ELSE 138 - CALL INPCHK(INEXT+1,IORDR,2) 139 - IF(IORDR.GT.0.AND.IORDR.LT.10)THEN 140 - IORD=IORDR 141 - ELSE 142 - CALL INPMSG(INEXT+1,'Out of range [1,10].') 143 - ENDIF 144 - ENDIF 145 - INEXT=INEXT+2 146 - ENDIF 147 - * Debugging information. 148 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASADD DEBUG :'', 149 - - '' Component '',I1,'': matrix '',I4,''('',I4, 150 - - '') vs '',I4,''('',I4,'').'')') IOBJ,IRMAT1,ISMAT1, 151 - - IRMAT2,ISMAT2 152 - ** Could be an incomplete set of matrices. 153 - ELSEIF(INPCMP(I+2,'VS').NE.0.AND.I+3.GT.NWORD)THEN 154 - CALL INPMSG(I,'Argument invalid or missing.') 155 - GOTO 10 156 - ** If a function, translate. 157 - ELSE 158 - * Continue after the function. 159 - INEXT=I+2 160 - * Get the string. 161 - CALL INPSTR(I+1,I+1,STRFUN,NCFUN) 162 - * Call editor of specified as @. 163 - IF(INDEX(STRFUN(1:NCFUN),'@').NE.0)THEN 164 - NRES=1 165 - PRINT *,' ------ GASADD MESSAGE : Please edit the'// 166 - - ' function.' 167 - CALL ALGEDT(VARLIS,NVAR,IENTRY,USE,NRES) 168 - IFAIL1=0 169 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASADD DEBUG :'', 170 - - '' Component '',I1,'': edited function with'', 171 - - '' entry '',I5,'', results '',I5)') IENTRY,NRES 172 - * Usual function translation if not. 173 - ELSE 174 - CALL ALGPRE(STRFUN,NCFUN,VARLIS,NVAR,NRES,USE, 175 - - IENTRY,IFAIL1) 176 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASADD DEBUG :'', 177 - - '' Component '',I1,'': function '',A/26X, 178 - - ''entry '',I5,'', results '',I5)') 179 - - IOBJ,STRFUN(1:NCFUN),IENTRY,NRES 180 - ENDIF 181 - * Check use of angle. 182 - IF((USE(2).OR.USE(10)).AND..NOT.TAB2D)THEN 183 - CALL INPMSG(I+1,'Uses B but there is no B field.') 184 - CALL ALGCLR(IENTRY) 185 - GOTO 10 186 - * Check use of mobility. 187 - ELSEIF(USE(3).AND..NOT.GASOK(1))THEN 188 - CALL INPMSG(I+1,'Uses drift velocity data.') 189 - CALL ALGCLR(IENTRY) 190 - GOTO 10 191 - * Check use of mobility. 192 - ELSEIF(USE(4).AND..NOT.GASOK(2))THEN 193 - CALL INPMSG(I+1,'Tries to use mobility data.') 194 - CALL ALGCLR(IENTRY) 1 513 P=GAS D=GASADD 3 PAGE 742 195 - GOTO 10 196 - * Check use of longitudinal diffusion. 197 - ELSEIF(USE(5).AND..NOT.GASOK(3))THEN 198 - CALL INPMSG(I+1,'Uses longitudinal diffusion.') 199 - CALL ALGCLR(IENTRY) 200 - GOTO 10 201 - * Check use of transverse diffusion. 202 - ELSEIF(USE(6).AND..NOT.GASOK(8))THEN 203 - CALL INPMSG(I+1,'Uses longitudinal diffusion.') 204 - CALL ALGCLR(IENTRY) 205 - GOTO 10 206 - * Check use of Townsend coefficients. 207 - ELSEIF(USE(7).AND..NOT.GASOK(4))THEN 208 - CALL INPMSG(I+1,'Uses Townsend coefficients.') 209 - CALL ALGCLR(IENTRY) 210 - GOTO 10 211 - * Check use of attachment coefficients. 212 - ELSEIF(USE(8).AND..NOT.GASOK(6))THEN 213 - CALL INPMSG(I+1,'Uses attachment coefficients.') 214 - CALL ALGCLR(IENTRY) 215 - GOTO 10 216 - * Check use of Lorentz angle. 217 - ELSEIF(USE(9).AND..NOT.GASOK(7))THEN 218 - CALL INPMSG(I+1,'Tries to use (v,E) angles.') 219 - CALL ALGCLR(IENTRY) 220 - GOTO 10 221 - ENDIF 222 - * Check return code of translation. 223 - IF(IFAIL1.NE.0)THEN 224 - CALL INPMSG(I+1,'Not a valid function.') 225 - CALL ALGCLR(IENTRY) 226 - GOTO 10 227 - ENDIF 228 - * Check number of results returned by the function. 229 - IF(NRES.NE.1)THEN 230 - CALL INPMSG(I+1,'Does not give 1 result.') 231 - CALL ALGCLR(IENTRY) 232 - GOTO 10 233 - ENDIF 234 - ENDIF 235 - *** Perform the actual interpolation. 236 - NERR=0 237 - OK=.TRUE. 238 - ** First the 2-dimensional tables. 239 - IF(TAB2D)THEN 240 - * Loop over the E/p points, skipping points outside the table. 241 - DO 20 J=1,NGAS 242 - IF(IENTRY.EQ.0.AND. 243 - - (EGAS(J).LT.MVEC(MORG(ISMAT2)+1).OR. 244 - - EGAS(J).GT.MVEC(MORG(ISMAT2)+MLEN(ISMAT2))))GOTO 20 245 - * Loop over cos(E-B). 246 - DO 30 K=1,NBANG 247 - DO 50 L=1,NBTAB 248 - VAR(1)=EGAS(J) 249 - VAR(2)=180*BANG(K)/PI 250 - VAR(3)=VGAS2(J,K,L) 251 - VAR(4)=MGAS2(J,K,L) 252 - VAR(5)=DGAS2(J,K,L) 253 - VAR(6)=OGAS2(J,K,L) 254 - VAR(7)=EXP(AGAS2(J,K,L)) 255 - VAR(8)=EXP(BGAS2(J,K,L)) 256 - VAR(9)=180*WGAS2(J,K,L)/PI 257 - VAR(10)=BTAB(L)/100 258 - VAR(11)=BOLTZ 259 - VAR(12)=ECHARG 260 - VAR(13)=PGAS 261 - VAR(14)=TGAS 262 - MODVAR(1)=2 263 - MODVAR(2)=2 264 - MODVAR(3)=2 265 - MODVAR(4)=2 266 - MODVAR(5)=2 267 - MODVAR(6)=2 268 - MODVAR(7)=2 269 - MODVAR(8)=2 270 - MODVAR(9)=2 271 - MODVAR(10)=2 272 - MODVAR(11)=2 273 - MODVAR(12)=2 274 - MODVAR(13)=2 275 - MODVAR(14)=2 276 - * Evaluate the formula ... 277 - IF(IENTRY.NE.0)THEN 278 - CALL ALGEXE(IENTRY,VAR,MODVAR,NVAR,RES, 279 - - MODRES,1,IFAIL1) 280 - IF(MODRES(1).NE.2.OR.IFAIL1.NE.0)THEN 281 - NERR=NERR+1 282 - OK=.FALSE. 283 - RES(1)=0 284 - ENDIF 285 - * or interpolate the matrices. 286 - ELSE 287 - CALL MATIN1(IRMAT2,IRMAT1,1,VAR(1),RES(1), 288 - - ISMAT2,ISMAT1,IORD,IFAIL1) 289 - IF(IFAIL1.NE.0)THEN 290 - NERR=NERR+1 291 - OK=.FALSE. 292 - RES(1)=0 293 - ENDIF 294 - ENDIF 295 - * Assign the result. 296 - IF(IOBJ.EQ.1)THEN 297 - VGAS2(J,K,L)=RES(1) 298 - ELSEIF(IOBJ.EQ.2)THEN 299 - MGAS2(J,K,L)=RES(1) 300 - ELSEIF(IOBJ.EQ.3)THEN 1 513 P=GAS D=GASADD 4 PAGE 743 301 - DGAS2(J,K,L)=RES(1) 302 - ELSEIF(IOBJ.EQ.4)THEN 303 - IF(RES(1).GT.0)THEN 304 - AGAS2(J,K,L)=LOG(RES(1)) 305 - ELSE 306 - AGAS2(J,K,L)=-30.0 307 - ENDIF 308 - ELSEIF(IOBJ.EQ.6)THEN 309 - IF(RES(1).GT.0)THEN 310 - BGAS2(J,K,L)=LOG(RES(1)) 311 - ELSE 312 - BGAS2(J,K,L)=-30.0 313 - ENDIF 314 - ELSEIF(IOBJ.EQ.7)THEN 315 - WGAS2(J,K,L)=PI*RES(1)/180 316 - ELSEIF(IOBJ.EQ.8)THEN 317 - OGAS2(J,K,L)=RES(1) 318 - ELSE 319 - PRINT *,' ###### GASADD ERROR : Unidentified'// 320 - - ' field; program bug - please report.' 321 - OK=.FALSE. 322 - ENDIF 323 - * Next point. 324 - 50 CONTINUE 325 - 30 CONTINUE 326 - 20 CONTINUE 327 - ** And the 1-dimensional case. 328 - ELSE 329 - * Loop over the E/p points, skipping points outside the table. 330 - DO 40 J=1,NGAS 331 - IF(IENTRY.EQ.0.AND. 332 - - (EGAS(J).LT.MVEC(MORG(ISMAT2)+1).OR. 333 - - EGAS(J).GT.MVEC(MORG(ISMAT2)+MLEN(ISMAT2))))GOTO 40 334 - VAR(1)=EGAS(J) 335 - VAR(2)=0 336 - VAR(3)=VGAS(J) 337 - VAR(4)=MGAS(J) 338 - VAR(5)=DGAS(J) 339 - VAR(6)=OGAS(J) 340 - VAR(7)=EXP(AGAS(J)) 341 - VAR(8)=EXP(BGAS(J)) 342 - VAR(9)=180*WGAS(J)/PI 343 - VAR(10)=0 344 - VAR(11)=BOLTZ 345 - VAR(12)=ECHARG 346 - VAR(13)=PGAS 347 - VAR(14)=TGAS 348 - MODVAR(1)=2 349 - MODVAR(2)=2 350 - MODVAR(3)=2 351 - MODVAR(4)=2 352 - MODVAR(5)=2 353 - MODVAR(6)=2 354 - MODVAR(7)=2 355 - MODVAR(8)=2 356 - MODVAR(9)=2 357 - MODVAR(10)=2 358 - MODVAR(11)=2 359 - MODVAR(12)=2 360 - MODVAR(13)=2 361 - MODVAR(14)=2 362 - * Evaluate the formula ... 363 - IF(IENTRY.NE.0)THEN 364 - CALL ALGEXE(IENTRY,VAR,MODVAR,NVAR,RES, 365 - - MODRES,1,IFAIL1) 366 - IF(MODRES(1).NE.2.OR.IFAIL1.NE.0)THEN 367 - NERR=NERR+1 368 - OK=.FALSE. 369 - RES(1)=0 370 - ENDIF 371 - * or interpolate the matrices. 372 - ELSE 373 - CALL MATIN1(IRMAT2,IRMAT1,1,VAR(1),RES(1), 374 - - ISMAT2,ISMAT1,IORD,IFAIL1) 375 - IF(IFAIL1.NE.0)THEN 376 - NERR=NERR+1 377 - OK=.FALSE. 378 - RES(1)=0 379 - ENDIF 380 - ENDIF 381 - * Assign the result. 382 - IF(IOBJ.EQ.1)THEN 383 - VGAS(J)=RES(1) 384 - ELSEIF(IOBJ.EQ.2)THEN 385 - MGAS(J)=RES(1) 386 - ELSEIF(IOBJ.EQ.3)THEN 387 - DGAS(J)=RES(1) 388 - ELSEIF(IOBJ.EQ.4)THEN 389 - IF(RES(1).GT.0)THEN 390 - AGAS(J)=LOG(RES(1)) 391 - ELSE 392 - AGAS(J)=-30.0 393 - ENDIF 394 - ELSEIF(IOBJ.EQ.6)THEN 395 - IF(RES(1).GT.0)THEN 396 - BGAS(J)=LOG(RES(1)) 397 - ELSE 398 - BGAS(J)=-30.0 399 - ENDIF 400 - ELSEIF(IOBJ.EQ.7)THEN 401 - WGAS(J)=PI*RES(1)/180 402 - ELSEIF(IOBJ.EQ.8)THEN 403 - OGAS(J)=RES(1) 404 - ELSE 405 - PRINT *,' ###### GASADD ERROR : Unidentified'// 406 - - ' field; program bug - please report.' 1 513 P=GAS D=GASADD 5 PAGE 744 407 - OK=.FALSE. 408 - ENDIF 409 - * Next point. 410 - 40 CONTINUE 411 - ENDIF 412 - *** Check the error flag and set the GASOK bit accordingly. 413 - CALL ALGERR 414 - IF(OK)THEN 415 - GASOK(IOBJ)=.TRUE. 416 - ELSE 417 - PRINT *,' !!!!!! GASADD WARNING : In total ',NERR, 418 - - ' type or arithmetic errors were found; entry'// 419 - - ' deleted.' 420 - GASOK(IOBJ)=.FALSE. 421 - ENDIF 422 - *** If a formula was used, delete the entry point. 423 - IF(IENTRY.GT.0)CALL ALGCLR(IENTRY) 424 - *** Next item. 425 - 10 CONTINUE 426 - *** Print the error messages. 427 - CALL INPERR 428 - END 514 GARFIELD ================================================== P=GAS D=GASCAL 1 ============================ 0 + +DECK,GASCAL. 1 - SUBROUTINE GASCAL(INSTR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GASCAL - Processes gas related procedure calls. 4 - * (Last changed on 13/ 2/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GASDATA. 9.- +SEQ,MATDATA. 10.- +SEQ,ALGDATA. 11.- +SEQ,BFIELD. 12 - CHARACTER*(MXINCH) STRING 13 - INTEGER INPCMX,IFAIL,IFAIL1,IFAIL3,INSTR,IPROC,NARG,ISIZ(MXMDIM), 14 - - IREP,ISEP,IREF(7),ISLOT(7),NDAT,MATSLT,I,J,NC,IAUX,NDATA 15 - REAL GASVEL,GASMOB,GASDFT,GASTWN,GASATT,GASDFL,GASLOR, 16 - - GASVT1,GASVT2 17 - EXTERNAL INPCMX,MATSLT,GASVEL,GASMOB,GASDFT,GASTWN,GASATT, 18 - - GASDFL,GASLOR,GASVT1,GASVT2 19 - *** Assume the CALL will fail. 20 - IFAIL=1 21 - *** Verify that gas initialisation has been done. 22 - IF(.NOT.GASSET)THEN 23 - PRINT *,' !!!!!! GASCAL WARNING : Gas data not available'// 24 - - ' ; procedure not executed.' 25 - RETURN 26 - ENDIF 27 - *** Some easy reference variables. 28 - NARG=INS(INSTR,3) 29 - IPROC=INS(INSTR,1) 30 - *** Get gas availability flags. 31 - IF(IPROC.EQ.-201)THEN 32 - * Check arguments. 33 - IF(NARG.NE.2.OR.MODARG(1).NE.1.OR.ARGREF(2,1).GE.2)THEN 34 - PRINT *,' !!!!!! GASCAL WARNING : Incorrect'// 35 - - ' argument list for GAS_AVAILABILITY.' 36 - RETURN 37 - ENDIF 38 - * Clear the return argument. 39 - CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) 40 - * Get hold of the item requested. 41 - CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL1) 42 - * Convert to upper case. 43 - CALL CLTOU(STRING(1:NC)) 44 - * Drift velocity. 45 - IF(INPCMX(STRING(1:NC),'DR#IFT-VEL#OCITY').NE.0)THEN 46 - IF(GASOK(1))THEN 47 - ARG(2)=1 48 - ELSE 49 - ARG(2)=0 50 - ENDIF 51 - MODARG(2)=3 52 - * Ion mobility. 53 - ELSEIF(INPCMX(STRING(1:NC),'ION-MOB#ILITY').NE.0)THEN 54 - IF(GASOK(2))THEN 55 - ARG(2)=1 56 - ELSE 57 - ARG(2)=0 58 - ENDIF 59 - MODARG(2)=3 60 - * Longitudinal diffusion. 61 - ELSEIF(INPCMX(STRING(1:NC), 62 - - 'LONG#ITUDINAL-DIFF#USION-#COEFFICIENT')+ 63 - - INPCMX(STRING(1:NC), 64 - - 'DIFF#USION-#COEFFICIENT').NE.0)THEN 65 - IF(GASOK(3))THEN 66 - ARG(2)=1 67 - ELSE 68 - ARG(2)=0 69 - ENDIF 70 - MODARG(2)=3 71 - * Townsend coefficient. 72 - ELSEIF(INPCMX(STRING(1:NC), 73 - - 'TOWN#SEND-#COEFFICIENT').NE.0)THEN 74 - IF(GASOK(4))THEN 75 - ARG(2)=1 76 - ELSE 77 - ARG(2)=0 78 - ENDIF 79 - MODARG(2)=3 80 - * Clustering data. 1 514 P=GAS D=GASCAL 2 PAGE 745 81 - ELSEIF(INPCMX(STRING(1:NC), 82 - - 'CLUS#TERING-DATA').NE.0)THEN 83 - IF(GASOK(5))THEN 84 - ARG(2)=1 85 - ELSE 86 - ARG(2)=0 87 - ENDIF 88 - MODARG(2)=3 89 - * Attachment coefficient. 90 - ELSEIF(INPCMX(STRING(1:NC), 91 - - 'ATT#ACHMENT-#COEFFICIENT').NE.0)THEN 92 - IF(GASOK(6))THEN 93 - ARG(2)=1 94 - ELSE 95 - ARG(2)=0 96 - ENDIF 97 - MODARG(2)=3 98 - * Lorentz angle. 99 - ELSEIF(INPCMX(STRING(1:NC), 100 - - 'LOR#ENTZ-#ANGLE').NE.0)THEN 101 - IF(GASOK(7))THEN 102 - ARG(2)=1 103 - ELSE 104 - ARG(2)=0 105 - ENDIF 106 - MODARG(2)=3 107 - * Transverse diffusion. 108 - ELSEIF(INPCMX(STRING(1:NC), 109 - - 'TRANS#VERSE-DIFF#USION-#COEFFICIENT').NE.0)THEN 110 - IF(GASOK(3))THEN 111 - ARG(2)=1 112 - ELSE 113 - ARG(2)=0 114 - ENDIF 115 - MODARG(2)=3 116 - * Unknown item. 117 - ELSE 118 - PRINT *,' !!!!!! GASCAL WARNING : '// 119 - - STRING(1:NC)//' is not a known gas item.' 120 - ARG(2)=0 121 - MODARG(2)=0 122 - ENDIF 123 - *** Get gas data. 124 - ELSEIF(IPROC.EQ.-202)THEN 125 - * Check arguments. 126 - IF(NARG.LT.1.OR.NARG.GT.3.OR. 127 - - (NARG.GE.1.AND.ARGREF(1,1).GE.2).OR. 128 - - (NARG.GE.2.AND.ARGREF(2,1).GE.2).OR. 129 - - (NARG.GE.3.AND.ARGREF(3,1).GE.2))THEN 130 - PRINT *,' !!!!!! GASCAL WARNING : Incorrect'// 131 - - ' argument list for GET_GAS_DATA.' 132 - RETURN 133 - ENDIF 134 - * Clear the storage. 135 - IF(NARG.GE.1)CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) 136 - IF(NARG.GE.2)CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) 137 - IF(NARG.GE.3)CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) 138 - * Store pressure. 139 - IF(NARG.GE.1)THEN 140 - ARG(1)=PGAS 141 - MODARG(1)=2 142 - ENDIF 143 - * Store temperature. 144 - IF(NARG.GE.2)THEN 145 - ARG(2)=TGAS 146 - MODARG(2)=2 147 - ENDIF 148 - * Store identifier. 149 - IF(NARG.GE.3)THEN 150 - DO 10 I=LEN(GASID),1,-1 151 - IF(GASID(I:I).NE.' ')THEN 152 - NC=I 153 - GOTO 20 154 - ENDIF 155 - 10 CONTINUE 156 - NC=1 157 - 20 CONTINUE 158 - CALL STRBUF('STORE',IAUX,GASID,NC,IFAIL3) 159 - ARG(3)=REAL(IAUX) 160 - MODARG(3)=1 161 - ENDIF 162 - *** Get drift velocity, mobility, diffusion, Townsend, attachment. 163 - ELSEIF(IPROC.LE.-203.AND.IPROC.GE.-212)THEN 164 - ** Check arguments. 165 - IF((.NOT.MAGOK).AND.(NARG.NE.4.OR. 166 - - (MODARG(1).NE.2.AND.MODARG(1).NE.5).OR. 167 - - (MODARG(2).NE.2.AND.MODARG(2).NE.5).OR. 168 - - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. 169 - - ARGREF(4,1).GE.2))THEN 170 - PRINT *,' !!!!!! GASCAL WARNING : Incorrect'// 171 - - ' argument list for getting a no-B gas table.' 172 - RETURN 173 - ELSEIF(MAGOK.AND.(NARG.NE.7.OR. 174 - - (MODARG(1).NE.2.AND.MODARG(1).NE.5).OR. 175 - - (MODARG(2).NE.2.AND.MODARG(2).NE.5).OR. 176 - - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. 177 - - (MODARG(4).NE.2.AND.MODARG(4).NE.5).OR. 178 - - (MODARG(5).NE.2.AND.MODARG(5).NE.5).OR. 179 - - (MODARG(6).NE.2.AND.MODARG(6).NE.5).OR. 180 - - ARGREF(7,1).GE.2))THEN 181 - PRINT *,' !!!!!! GASCAL WARNING : Incorrect'// 182 - - ' argument list for getting a B gas table.' 183 - RETURN 184 - ELSEIF(NGAS.LT.1.OR. 185 - - (IPROC.EQ.-203.AND..NOT.GASOK(1)).OR. 186 - - (IPROC.EQ.-204.AND..NOT.GASOK(2)).OR. 1 514 P=GAS D=GASCAL 3 PAGE 746 187 - - (IPROC.EQ.-205.AND..NOT.GASOK(3)).OR. 188 - - (IPROC.EQ.-206.AND..NOT.GASOK(4)).OR. 189 - - (IPROC.EQ.-207.AND..NOT.GASOK(6)).OR. 190 - - (IPROC.EQ.-208.AND..NOT.GASOK(7)).OR. 191 - - (IPROC.EQ.-209.AND..NOT.GASOK(8)))THEN 192 - PRINT *,' !!!!!! GASCAL WARNING : Requested'// 193 - - ' gas data is not available.' 194 - RETURN 195 - ENDIF 196 - ** Clear the storage. 197 - IF(MAGOK)THEN 198 - CALL ALGREU(NINT(ARG(7)),MODARG(7),ARGREF(7,1)) 199 - ELSE 200 - CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 201 - ENDIF 202 - ** Are all arguments scalars ? 203 - IF((.NOT.MAGOK).AND. 204 - - MODARG(1).EQ.2.AND.MODARG(2).EQ.2.AND. 205 - - MODARG(3).EQ.2)THEN 206 - IF(IPROC.EQ.-203)THEN 207 - ARG(4)=GASVEL(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) 208 - ELSEIF(IPROC.EQ.-204)THEN 209 - ARG(4)=GASMOB(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) 210 - ELSEIF(IPROC.EQ.-205)THEN 211 - ARG(4)=GASDFL(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) 212 - ELSEIF(IPROC.EQ.-206)THEN 213 - ARG(4)=GASTWN(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) 214 - ELSEIF(IPROC.EQ.-207)THEN 215 - ARG(4)=GASATT(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) 216 - ELSEIF(IPROC.EQ.-208)THEN 217 - ARG(4)=GASLOR(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) 218 - ELSEIF(IPROC.EQ.-209)THEN 219 - ARG(4)=GASDFT(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) 220 - ELSEIF(IPROC.EQ.-210)THEN 221 - ARG(4)=SQRT( 222 - - GASVEL(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0)**2+ 223 - - GASVT1(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0)**2+ 224 - - GASVT2(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0)**2) 225 - ELSEIF(IPROC.EQ.-211)THEN 226 - ARG(4)=GASVT1(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) 227 - ELSEIF(IPROC.EQ.-212)THEN 228 - ARG(4)=GASVT2(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) 229 - ELSE 230 - PRINT *,' !!!!!! GASCAL WARNING : Incorrect'// 231 - - ' procedure code received; please report.' 232 - ARG(4)=0 233 - ENDIF 234 - MODARG(4)=2 235 - ELSEIF(MAGOK.AND. 236 - - MODARG(1).EQ.2.AND.MODARG(2).EQ.2.AND. 237 - - MODARG(3).EQ.2.AND.MODARG(4).EQ.2.AND. 238 - - MODARG(5).EQ.2.AND.MODARG(6).EQ.2)THEN 239 - IF(IPROC.EQ.-203)THEN 240 - ARG(7)=GASVEL(ARG(1),ARG(2),ARG(3), 241 - - ARG(4),ARG(5),ARG(6)) 242 - ELSEIF(IPROC.EQ.-204)THEN 243 - ARG(7)=GASMOB(ARG(1),ARG(2),ARG(3), 244 - - ARG(4),ARG(5),ARG(6)) 245 - ELSEIF(IPROC.EQ.-205)THEN 246 - ARG(7)=GASDFL(ARG(1),ARG(2),ARG(3), 247 - - ARG(4),ARG(5),ARG(6)) 248 - ELSEIF(IPROC.EQ.-206)THEN 249 - ARG(7)=GASTWN(ARG(1),ARG(2),ARG(3), 250 - - ARG(4),ARG(5),ARG(6)) 251 - ELSEIF(IPROC.EQ.-207)THEN 252 - ARG(7)=GASATT(ARG(1),ARG(2),ARG(3), 253 - - ARG(4),ARG(5),ARG(6)) 254 - ELSEIF(IPROC.EQ.-208)THEN 255 - ARG(7)=GASLOR(ARG(1),ARG(2),ARG(3), 256 - - ARG(4),ARG(5),ARG(6)) 257 - ELSEIF(IPROC.EQ.-209)THEN 258 - ARG(7)=GASDFT(ARG(1),ARG(2),ARG(3), 259 - - ARG(4),ARG(5),ARG(6)) 260 - ELSEIF(IPROC.EQ.-210)THEN 261 - ARG(7)=SQRT( 262 - - GASVEL(ARG(1),ARG(2),ARG(3), 263 - - ARG(4),ARG(5),ARG(6))**2+ 264 - - GASVT1(ARG(1),ARG(2),ARG(3), 265 - - ARG(4),ARG(5),ARG(6))**2+ 266 - - GASVT2(ARG(1),ARG(2),ARG(3), 267 - - ARG(4),ARG(5),ARG(6))**2) 268 - ELSEIF(IPROC.EQ.-211)THEN 269 - ARG(7)=GASVT1(ARG(1),ARG(2),ARG(3), 270 - - ARG(4),ARG(5),ARG(6)) 271 - ELSEIF(IPROC.EQ.-212)THEN 272 - ARG(7)=GASVT2(ARG(1),ARG(2),ARG(3), 273 - - ARG(4),ARG(5),ARG(6)) 274 - ELSE 275 - PRINT *,' !!!!!! GASCAL WARNING : Incorrect'// 276 - - ' procedure code received; please report.' 277 - ARG(7)=0 278 - ENDIF 279 - MODARG(7)=2 280 - ** At least one of them is a matrix. 281 - ELSE 282 - * Figure out what the dimensions are. 283 - NDAT=-1 284 - IF(MAGOK)THEN 285 - NDATA=6 286 - ELSE 287 - NDATA=3 288 - ENDIF 289 - DO 30 I=1,NDATA 290 - IF(MODARG(I).EQ.5)THEN 291 - IREF(I)=NINT(ARG(I)) 292 - ISLOT(I)=MATSLT(IREF(I)) 1 514 P=GAS D=GASCAL 4 PAGE 747 293 - IF(ISLOT(I).LE.0)THEN 294 - PRINT *,' !!!!!! GASCAL WARNING : Unable'// 295 - - ' locate a matrix.' 296 - RETURN 297 - ELSEIF(MMOD(ISLOT(I)).NE.2)THEN 298 - PRINT *,' !!!!!! GASCAL WARNING : E or B'// 299 - - ' vector of incorrect type.' 300 - RETURN 301 - ENDIF 302 - IF(NDAT.LT.0)THEN 303 - NDAT=MLEN(ISLOT(I)) 304 - ELSEIF(NDAT.NE.MLEN(ISLOT(I)))THEN 305 - PRINT *,' !!!!!! GASCAL WARNING : E and'// 306 - - ' B have inconsistent lengths.' 307 - RETURN 308 - ENDIF 309 - ENDIF 310 - 30 CONTINUE 311 - IF(NDAT.LT.1)THEN 312 - PRINT *,' !!!!!! GASCAL WARNING : Unable'// 313 - - ' to find an E or B vector.' 314 - RETURN 315 - ENDIF 316 - * Now book matrices for the missing elements and initialise them. 317 - DO 40 I=1,NDATA 318 - IF(MODARG(I).NE.5)THEN 319 - ISIZ(1)=NDAT 320 - CALL MATADM('ALLOCATE',IREF(I),1,ISIZ,2,IFAIL1) 321 - IF(IFAIL1.NE.0)THEN 322 - PRINT *,' !!!!!! GASCAL WARNING : Unable'// 323 - - ' to get a vector replacement.' 324 - RETURN 325 - ENDIF 326 - ISLOT(I)=MATSLT(IREF(I)) 327 - IF(ISLOT(I).LE.0)THEN 328 - PRINT *,' !!!!!! GASCAL WARNING : Unable'// 329 - - ' to locate a vector replacement.' 330 - RETURN 331 - ENDIF 332 - DO 50 J=1,MLEN(ISLOT(I)) 333 - MVEC(MORG(ISLOT(I))+J)=ARG(I) 334 - 50 CONTINUE 335 - ENDIF 336 - 40 CONTINUE 337 - * Allocate an output vector. 338 - ISIZ(1)=NDAT 339 - CALL MATADM('ALLOCATE',IREF(NDATA+1),1,ISIZ,2,IFAIL1) 340 - IF(IFAIL1.NE.0)THEN 341 - PRINT *,' !!!!!! GASCAL WARNING : Unable'// 342 - - ' to get an output vector.' 343 - RETURN 344 - ENDIF 345 - * And finally locate all vectors. 346 - DO 60 I=1,NDATA+1 347 - ISLOT(I)=MATSLT(IREF(I)) 348 - IF(ISLOT(I).LE.0)THEN 349 - PRINT *,' !!!!!! GASCAL WARNING : Unable'// 350 - - ' to locate E, B or output.' 351 - RETURN 352 - ENDIF 353 - 60 CONTINUE 354 - * And compute the data. 355 - IF(MAGOK)THEN 356 - DO 70 I=1,NDAT 357 - IF(IPROC.EQ.-203)THEN 358 - MVEC(MORG(ISLOT(7))+I)=GASVEL( 359 - - MVEC(MORG(ISLOT(1))+I), 360 - - MVEC(MORG(ISLOT(2))+I), 361 - - MVEC(MORG(ISLOT(3))+I), 362 - - MVEC(MORG(ISLOT(4))+I), 363 - - MVEC(MORG(ISLOT(5))+I), 364 - - MVEC(MORG(ISLOT(6))+I)) 365 - ELSEIF(IPROC.EQ.-204)THEN 366 - MVEC(MORG(ISLOT(7))+I)=GASMOB( 367 - - MVEC(MORG(ISLOT(1))+I), 368 - - MVEC(MORG(ISLOT(2))+I), 369 - - MVEC(MORG(ISLOT(3))+I), 370 - - MVEC(MORG(ISLOT(4))+I), 371 - - MVEC(MORG(ISLOT(5))+I), 372 - - MVEC(MORG(ISLOT(6))+I)) 373 - ELSEIF(IPROC.EQ.-205)THEN 374 - MVEC(MORG(ISLOT(7))+I)=GASDFL( 375 - - MVEC(MORG(ISLOT(1))+I), 376 - - MVEC(MORG(ISLOT(2))+I), 377 - - MVEC(MORG(ISLOT(3))+I), 378 - - MVEC(MORG(ISLOT(4))+I), 379 - - MVEC(MORG(ISLOT(5))+I), 380 - - MVEC(MORG(ISLOT(6))+I)) 381 - ELSEIF(IPROC.EQ.-206)THEN 382 - MVEC(MORG(ISLOT(7))+I)=GASTWN( 383 - - MVEC(MORG(ISLOT(1))+I), 384 - - MVEC(MORG(ISLOT(2))+I), 385 - - MVEC(MORG(ISLOT(3))+I), 386 - - MVEC(MORG(ISLOT(4))+I), 387 - - MVEC(MORG(ISLOT(5))+I), 388 - - MVEC(MORG(ISLOT(6))+I)) 389 - ELSEIF(IPROC.EQ.-207)THEN 390 - MVEC(MORG(ISLOT(7))+I)=GASATT( 391 - - MVEC(MORG(ISLOT(1))+I), 392 - - MVEC(MORG(ISLOT(2))+I), 393 - - MVEC(MORG(ISLOT(3))+I), 394 - - MVEC(MORG(ISLOT(4))+I), 395 - - MVEC(MORG(ISLOT(5))+I), 396 - - MVEC(MORG(ISLOT(6))+I)) 397 - ELSEIF(IPROC.EQ.-208)THEN 398 - MVEC(MORG(ISLOT(7))+I)=GASLOR( 1 514 P=GAS D=GASCAL 5 PAGE 748 399 - - MVEC(MORG(ISLOT(1))+I), 400 - - MVEC(MORG(ISLOT(2))+I), 401 - - MVEC(MORG(ISLOT(3))+I), 402 - - MVEC(MORG(ISLOT(4))+I), 403 - - MVEC(MORG(ISLOT(5))+I), 404 - - MVEC(MORG(ISLOT(6))+I)) 405 - ELSEIF(IPROC.EQ.-209)THEN 406 - MVEC(MORG(ISLOT(7))+I)=GASDFT( 407 - - MVEC(MORG(ISLOT(1))+I), 408 - - MVEC(MORG(ISLOT(2))+I), 409 - - MVEC(MORG(ISLOT(3))+I), 410 - - MVEC(MORG(ISLOT(4))+I), 411 - - MVEC(MORG(ISLOT(5))+I), 412 - - MVEC(MORG(ISLOT(6))+I)) 413 - ELSEIF(IPROC.EQ.-210)THEN 414 - MVEC(MORG(ISLOT(7))+I)=SQRT( 415 - - GASVEL( 416 - - MVEC(MORG(ISLOT(1))+I), 417 - - MVEC(MORG(ISLOT(2))+I), 418 - - MVEC(MORG(ISLOT(3))+I), 419 - - MVEC(MORG(ISLOT(4))+I), 420 - - MVEC(MORG(ISLOT(5))+I), 421 - - MVEC(MORG(ISLOT(6))+I))**2+ 422 - - GASVT1( 423 - - MVEC(MORG(ISLOT(1))+I), 424 - - MVEC(MORG(ISLOT(2))+I), 425 - - MVEC(MORG(ISLOT(3))+I), 426 - - MVEC(MORG(ISLOT(4))+I), 427 - - MVEC(MORG(ISLOT(5))+I), 428 - - MVEC(MORG(ISLOT(6))+I))**2+ 429 - - GASVT2( 430 - - MVEC(MORG(ISLOT(1))+I), 431 - - MVEC(MORG(ISLOT(2))+I), 432 - - MVEC(MORG(ISLOT(3))+I), 433 - - MVEC(MORG(ISLOT(4))+I), 434 - - MVEC(MORG(ISLOT(5))+I), 435 - - MVEC(MORG(ISLOT(6))+I))**2) 436 - ELSEIF(IPROC.EQ.-211)THEN 437 - MVEC(MORG(ISLOT(7))+I)=GASVT1( 438 - - MVEC(MORG(ISLOT(1))+I), 439 - - MVEC(MORG(ISLOT(2))+I), 440 - - MVEC(MORG(ISLOT(3))+I), 441 - - MVEC(MORG(ISLOT(4))+I), 442 - - MVEC(MORG(ISLOT(5))+I), 443 - - MVEC(MORG(ISLOT(6))+I)) 444 - ELSEIF(IPROC.EQ.-212)THEN 445 - MVEC(MORG(ISLOT(7))+I)=GASVT2( 446 - - MVEC(MORG(ISLOT(1))+I), 447 - - MVEC(MORG(ISLOT(2))+I), 448 - - MVEC(MORG(ISLOT(3))+I), 449 - - MVEC(MORG(ISLOT(4))+I), 450 - - MVEC(MORG(ISLOT(5))+I), 451 - - MVEC(MORG(ISLOT(6))+I)) 452 - ELSE 453 - PRINT *,' !!!!!! GASCAL WARNING : Wrong'// 454 - - ' procedure code received; report.' 455 - MVEC(MORG(ISLOT(4))+I)=0 456 - ENDIF 457 - 70 CONTINUE 458 - ELSE 459 - DO 90 I=1,NDAT 460 - IF(IPROC.EQ.-203)THEN 461 - MVEC(MORG(ISLOT(4))+I)=GASVEL( 462 - - MVEC(MORG(ISLOT(1))+I), 463 - - MVEC(MORG(ISLOT(2))+I), 464 - - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) 465 - ELSEIF(IPROC.EQ.-204)THEN 466 - MVEC(MORG(ISLOT(4))+I)=GASMOB( 467 - - MVEC(MORG(ISLOT(1))+I), 468 - - MVEC(MORG(ISLOT(2))+I), 469 - - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) 470 - ELSEIF(IPROC.EQ.-205)THEN 471 - MVEC(MORG(ISLOT(4))+I)=GASDFL( 472 - - MVEC(MORG(ISLOT(1))+I), 473 - - MVEC(MORG(ISLOT(2))+I), 474 - - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) 475 - ELSEIF(IPROC.EQ.-206)THEN 476 - MVEC(MORG(ISLOT(4))+I)=GASTWN( 477 - - MVEC(MORG(ISLOT(1))+I), 478 - - MVEC(MORG(ISLOT(2))+I), 479 - - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) 480 - ELSEIF(IPROC.EQ.-207)THEN 481 - MVEC(MORG(ISLOT(4))+I)=GASATT( 482 - - MVEC(MORG(ISLOT(1))+I), 483 - - MVEC(MORG(ISLOT(2))+I), 484 - - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) 485 - ELSEIF(IPROC.EQ.-208)THEN 486 - MVEC(MORG(ISLOT(4))+I)=GASLOR( 487 - - MVEC(MORG(ISLOT(1))+I), 488 - - MVEC(MORG(ISLOT(2))+I), 489 - - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) 490 - ELSEIF(IPROC.EQ.-209)THEN 491 - MVEC(MORG(ISLOT(4))+I)=GASDFT( 492 - - MVEC(MORG(ISLOT(1))+I), 493 - - MVEC(MORG(ISLOT(2))+I), 494 - - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) 495 - ELSEIF(IPROC.EQ.-210)THEN 496 - MVEC(MORG(ISLOT(4))+I)=SQRT( 497 - - GASVEL( 498 - - MVEC(MORG(ISLOT(1))+I), 499 - - MVEC(MORG(ISLOT(2))+I), 500 - - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0)**2+ 501 - - GASVT1( 502 - - MVEC(MORG(ISLOT(1))+I), 503 - - MVEC(MORG(ISLOT(2))+I), 504 - - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0)**2+ 1 514 P=GAS D=GASCAL 6 PAGE 749 505 - - GASVT2( 506 - - MVEC(MORG(ISLOT(1))+I), 507 - - MVEC(MORG(ISLOT(2))+I), 508 - - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0)**2) 509 - ELSEIF(IPROC.EQ.-211)THEN 510 - MVEC(MORG(ISLOT(4))+I)=GASVT1( 511 - - MVEC(MORG(ISLOT(1))+I), 512 - - MVEC(MORG(ISLOT(2))+I), 513 - - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) 514 - ELSEIF(IPROC.EQ.-212)THEN 515 - MVEC(MORG(ISLOT(4))+I)=GASVT2( 516 - - MVEC(MORG(ISLOT(1))+I), 517 - - MVEC(MORG(ISLOT(2))+I), 518 - - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) 519 - ELSE 520 - PRINT *,' !!!!!! GASCAL WARNING : Wrong'// 521 - - ' procedure code received; report.' 522 - MVEC(MORG(ISLOT(4))+I)=0 523 - ENDIF 524 - 90 CONTINUE 525 - ENDIF 526 - * Delete temporary matrices. 527 - DO 80 I=1,NDATA 528 - IF(MODARG(I).NE.5)THEN 529 - ISIZ(1)=NDAT 530 - CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL1) 531 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! GASCAL WARNING'// 532 - - ' : Unable to delete a vector replacement.' 533 - ENDIF 534 - 80 CONTINUE 535 - * And save the output. 536 - ARG(NDATA+1)=IREF(NDATA+1) 537 - MODARG(NDATA+1)=5 538 - ENDIF 539 - *** Get E/p. 540 - ELSEIF(IPROC.EQ.-213)THEN 541 - * Check arguments. 542 - IF(NARG.NE.1.OR.ARGREF(1,1).GE.2)THEN 543 - PRINT *,' !!!!!! GASCAL WARNING : Incorrect'// 544 - - ' argument list for GET_EP_TABLE.' 545 - RETURN 546 - ELSEIF(NGAS.LT.1)THEN 547 - PRINT *,' !!!!!! GASCAL WARNING : No E/p table'// 548 - - ' available.' 549 - RETURN 550 - ENDIF 551 - * Clear the storage. 552 - CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) 553 - * Get a matrix of the proper size. 554 - ISIZ(1)=NGAS 555 - CALL MATADM('ALLOCATE',IREP,1,ISIZ,2,IFAIL1) 556 - ISEP=MATSLT(IREP) 557 - IF(IFAIL1.NE.0.OR.ISEP.LE.0)THEN 558 - PRINT *,' !!!!!! GASCAL WARNING : Unable to obtain'// 559 - - ' matrix storage.' 560 - RETURN 561 - ENDIF 562 - * Copy the contents. 563 - DO 150 I=1,NGAS 564 - MVEC(MORG(ISEP)+I)=EGAS(I) 565 - 150 CONTINUE 566 - * And save the output. 567 - ARG(1)=IREP 568 - MODARG(1)=5 569 - *** Unknown gas operation. 570 - ELSE 571 - PRINT *,' !!!!!! GASCAL WARNING : Unknown procedure code'// 572 - - ' received; nothing done.' 573 - IFAIL=1 574 - RETURN 575 - ENDIF 576 - *** Seems to have worked. 577 - IFAIL=0 578 - END 515 GARFIELD ================================================== P=GAS D=GASCHK 1 ============================ 0 + +DECK,GASCHK. 1 - SUBROUTINE GASCHK(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GASCHK - Checks the validity of tha gas data entered in GASINP. 4 - * VARIABLES : IFAIL : 1 if routine failed 0 if succesful 5 - * (Last changed on 21/ 2/01.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,GASDATA. 10.- +SEQ,PRINTPLOT. 11 - DOUBLE PRECISION SUMCLS 12 - INTEGER IFAIL,I,J,K 13 - LOGICAL OK 14 - *** Identify the routine if requested. 15 - IF(LIDENT)PRINT *,' /// ROUTINE GASCHK ///' 16 - *** Preset IFAIL to 0, i.e. pass. 17 - IFAIL=0 18 - OK=.TRUE. 19 - *** Table check: check the number of data points. 20 - IF(NGAS.LT.1)THEN 21 - PRINT *,' !!!!!! GASCHK WARNING : The electron transport'// 22 - - ' property table has too few points.' 23 - GASOK(1)=.FALSE. 24 - GASOK(2)=.FALSE. 25 - GASOK(3)=.FALSE. 26 - GASOK(4)=.FALSE. 27 - GASOK(6)=.FALSE. 28 - GASOK(7)=.FALSE. 1 515 P=GAS D=GASCHK 2 PAGE 750 29 - GASOK(8)=.FALSE. 30 - GASOK(9)=.FALSE. 31 - GASOK(10)=.FALSE. 32 - OK=.FALSE. 33 - ENDIF 34 - DO 10 I=1,NGAS 35 - * Check that the E/p array is all positive. 36 - IF(EGAS(I).LE.0.0)THEN 37 - PRINT *,' !!!!!! GASCHK WARNING : E/p is not strictly', 38 - - ' positive in table entry ',I,'; table is rejected.' 39 - GASOK(1)=.FALSE. 40 - GASOK(2)=.FALSE. 41 - GASOK(3)=.FALSE. 42 - GASOK(4)=.FALSE. 43 - GASOK(6)=.FALSE. 44 - GASOK(7)=.FALSE. 45 - GASOK(8)=.FALSE. 46 - GASOK(9)=.FALSE. 47 - GASOK(10)=.FALSE. 48 - OK=.FALSE. 49 - ENDIF 50 - * Check that the E/p array is in increasing order. 51 - IF(I.GT.1)THEN 52 - IF(EGAS(I).LE.EGAS(I-1))THEN 53 - PRINT *,' !!!!!! GASCHK WARNING : E/p is not in'// 54 - - ' increasing order; table is rejected.' 55 - GASOK(1)=.FALSE. 56 - GASOK(2)=.FALSE. 57 - GASOK(3)=.FALSE. 58 - GASOK(4)=.FALSE. 59 - GASOK(6)=.FALSE. 60 - GASOK(7)=.FALSE. 61 - GASOK(8)=.FALSE. 62 - GASOK(9)=.FALSE. 63 - GASOK(10)=.FALSE. 64 - OK=.FALSE. 65 - ENDIF 66 - ENDIF 67 - ** Case of a 2 dimensional table. 68 - IF(TAB2D)THEN 69 - DO 20 J=1,NBANG 70 - DO 30 K=1,NBTAB 71 - * Check that the v || E is all positive (leave other components). 72 - IF(GASOK(1).AND.VGAS2(I,J,K).LE.0.0)THEN 73 - PRINT *,' !!!!!! GASCHK WARNING : v || E is not > 0'// 74 - - ' in table entry ',I,J,K,'; Vdrift is rejected.' 75 - GASOK(1)=.FALSE. 76 - OK=.FALSE. 77 - ENDIF 78 - * Check that the ion mobility is all positive. 79 - IF(GASOK(2).AND.MGAS2(I,J,K).LE.0.0)THEN 80 - PRINT *,' !!!!!! GASCHK WARNING : Ion mobility < 0', 81 - - ' at table entry ',I,J,K,'; mobility rejected.' 82 - GASOK(2)=.FALSE. 83 - OK=.FALSE. 84 - ENDIF 85 - * Check that the sigma-diffusion array is all positive. 86 - IF(GASOK(3).AND.DGAS2(I,J,K).LT.0.0)THEN 87 - PRINT *,' !!!!!! GASCHK WARNING : Long. diffusion < 0', 88 - - ' at table entry ',I,J,K,'; data are rejected.' 89 - GASOK(3)=.FALSE. 90 - OK=.FALSE. 91 - ENDIF 92 - IF(GASOK(8).AND.OGAS2(I,J,K).LT.0.0)THEN 93 - PRINT *,' !!!!!! GASCHK WARNING : Tr. diffusion < 0', 94 - - ' at table entry ',I,J,K,'; data are rejected.' 95 - OK=.FALSE. 96 - GASOK(8)=.FALSE. 97 - ENDIF 98 - * Check that the Townsend coefficients are all reasonable. 99 - IF(GASOK(4).AND.AGAS2(I,J,K).LT.-30.001)THEN 100 - PRINT *,' ------ GASCHK MESSAGE : Setting alpha/p ='// 101 - - ' 0 in table entry ',I,J,K,'.' 102 - AGAS2(I,J,K)=-30 103 - ENDIF 104 - * Check that the attachment coefficients are all positive. 105 - IF(GASOK(6).AND.BGAS2(I,J,K).LT.-30.001)THEN 106 - PRINT *,' ------ GASCHK MESSAGE : Setting eta/p ='// 107 - - ' 0 in table entry ',I,J,K,'.' 108 - BGAS2(I,J,K)=-30 109 - ENDIF 110 - 30 CONTINUE 111 - 20 CONTINUE 112 - ** Case of a 1-dimensional table. 113 - ELSE 114 - * Check that the v || E is all positive (leave other components). 115 - IF(GASOK(1).AND.VGAS(I).LE.0.0)THEN 116 - PRINT *,' !!!!!! GASCHK WARNING : v || E is not > 0'// 117 - - ' in table entry ',I,'; Vdrift is rejected.' 118 - OK=.FALSE. 119 - GASOK(1)=.FALSE. 120 - ENDIF 121 - * Check that the ion mobility is all positive. 122 - IF(GASOK(2).AND.MGAS(I).LE.0.0)THEN 123 - PRINT *,' !!!!!! GASCHK WARNING : Ion mobility < 0', 124 - - ' at table entry ',I,'; ion mobility rejected.' 125 - OK=.FALSE. 126 - GASOK(2)=.FALSE. 127 - ENDIF 128 - * Check that the sigma-diffusion array is all positive. 129 - IF(GASOK(3).AND.DGAS(I).LT.0.0)THEN 130 - PRINT *,' !!!!!! GASCHK WARNING : Long. diffusion < 0', 131 - - ' at table entry ',I,'; data are rejected.' 132 - OK=.FALSE. 133 - GASOK(3)=.FALSE. 134 - ENDIF 1 515 P=GAS D=GASCHK 3 PAGE 751 135 - IF(GASOK(8).AND.OGAS(I).LT.0.0)THEN 136 - PRINT *,' !!!!!! GASCHK WARNING : Tr. diffusion < 0', 137 - - ' at table entry ',I,'; data are rejected.' 138 - GASOK(8)=.FALSE. 139 - OK=.FALSE. 140 - ENDIF 141 - * Check that the Townsend coefficients are reasonable. 142 - IF(GASOK(4).AND.AGAS(I).LT.-30.001)THEN 143 - PRINT *,' ------ GASCHK MESSAGE : Setting alpha/p ='// 144 - - ' 0 in table entry ',I,J,K,'.' 145 - AGAS(I)=-30 146 - ENDIF 147 - * Check that the attachment coefficients are all positive. 148 - IF(GASOK(6).AND.BGAS(I).LT.-30.001)THEN 149 - PRINT *,' ------ GASCHK MESSAGE : Setting eta/p ='// 150 - - ' 0 in table entry ',I,J,K,'.' 151 - BGAS(I)=-30 152 - ENDIF 153 - ENDIF 154 - 10 CONTINUE 155 - *** Check interpolation and extrapolation methods. 156 - IF(NGAS.GT.1.AND.GASOK(1).AND.(((.NOT.TAB2D).AND. 157 - - (IVMETH.LT.0.OR.IVMETH.GT.MIN(10,NGAS-1))).OR. 158 - - (TAB2D.AND.(IVMETH.LT.0.OR.IVMETH.GT.2))))THEN 159 - IVMETH=MIN(2,NGAS-1) 160 - PRINT *,' !!!!!! GASCHK WARNING : Invalid drift velocity'// 161 - - ' interpolation; taking polynomial of order ',IVMETH 162 - OK=.FALSE. 163 - ENDIF 164 - IF(GASOK(1).AND.(IVEXTR.LT.0.OR.IVEXTR.GT.2.OR. 165 - - JVEXTR.LT.0.OR.JVEXTR.GT.2).AND..NOT.TAB2D)THEN 166 - PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// 167 - - ' method for v; assuming linear.' 168 - IVEXTR=1 169 - JVEXTR=1 170 - OK=.FALSE. 171 - ENDIF 172 - IF(NGAS.GT.1.AND.GASOK(2).AND.(((.NOT.TAB2D).AND. 173 - - (IMMETH.LT.0.OR.IMMETH.GT.MIN(10,NGAS-1))).OR. 174 - - (TAB2D.AND.(IMMETH.LT.0.OR.IMMETH.GT.2))))THEN 175 - IMMETH=MIN(2,NGAS-1) 176 - PRINT *,' !!!!!! GASCHK WARNING : Invalid ion mobility'// 177 - - ' interpolation; taking polynomial of order ',IMMETH 178 - OK=.FALSE. 179 - ENDIF 180 - IF(GASOK(2).AND.(IMEXTR.LT.0.OR.IMEXTR.GT.2.OR. 181 - - JMEXTR.LT.0.OR.JMEXTR.GT.2).AND..NOT.TAB2D)THEN 182 - PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// 183 - - ' method for the ion mobility; assuming linear.' 184 - IMEXTR=1 185 - JMEXTR=1 186 - OK=.FALSE. 187 - ENDIF 188 - IF(NGAS.GT.1.AND.GASOK(3).AND.(((.NOT.TAB2D).AND. 189 - - (IDMETH.LT.0.OR.IDMETH.GT.MIN(10,NGAS-1))).OR. 190 - - (TAB2D.AND.(IDMETH.LT.0.OR.IDMETH.GT.2))))THEN 191 - IDMETH=MIN(2,NGAS-1) 192 - PRINT *,' !!!!!! GASCHK WARNING : Invalid sigma L'// 193 - - ' interpolation; taking polynomial of order ',IDMETH 194 - OK=.FALSE. 195 - ENDIF 196 - IF(GASOK(3).AND.(IDEXTR.LT.0.OR.IDEXTR.GT.2).AND..NOT.TAB2D)THEN 197 - PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// 198 - - ' method for sigma L; assuming linear.' 199 - IDEXTR=1 200 - JDEXTR=1 201 - OK=.FALSE. 202 - ENDIF 203 - IF(NGAS.GT.1.AND.GASOK(4).AND.(((.NOT.TAB2D).AND. 204 - - (IAMETH.LT.0.OR.IAMETH.GT.MIN(10,NGAS-1))).OR. 205 - - (TAB2D.AND.(IAMETH.LT.0.OR.IAMETH.GT.2))))THEN 206 - IAMETH=MIN(2,NGAS-1) 207 - PRINT *,' !!!!!! GASCHK WARNING : Invalid Townsend'// 208 - - ' interpolation; taking polynomial of order ',IAMETH 209 - OK=.FALSE. 210 - ENDIF 211 - IF(GASOK(4).AND.(IAEXTR.LT.0.OR.IAEXTR.GT.2).AND..NOT.TAB2D)THEN 212 - PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// 213 - - ' method for Townsend coefficient; assuming linear.' 214 - IAEXTR=1 215 - JAEXTR=1 216 - OK=.FALSE. 217 - ENDIF 218 - IF(NGAS.GT.1.AND.GASOK(6).AND.(((.NOT.TAB2D).AND. 219 - - (IBMETH.LT.0.OR.IBMETH.GT.MIN(10,NGAS-1))).OR. 220 - - (TAB2D.AND.(IBMETH.LT.0.OR.IBMETH.GT.2))))THEN 221 - IBMETH=MIN(2,NGAS-1) 222 - PRINT *,' !!!!!! GASCHK WARNING : Invalid attachment'// 223 - - ' interpolation; taking polynomial of order ',IBMETH 224 - OK=.FALSE. 225 - ENDIF 226 - IF(GASOK(6).AND.(IBEXTR.LT.0.OR.IBEXTR.GT.2).AND..NOT.TAB2D)THEN 227 - PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// 228 - - ' method for the attachment; assuming linear.' 229 - IBEXTR=1 230 - JBEXTR=1 231 - OK=.FALSE. 232 - ENDIF 233 - IF(NGAS.GT.1.AND.GASOK(7).AND.(((.NOT.TAB2D).AND. 234 - - (IWMETH.LT.0.OR.IWMETH.GT.MIN(10,NGAS-1))).OR. 235 - - (TAB2D.AND.(IWMETH.LT.0.OR.IWMETH.GT.2))))THEN 236 - IWMETH=MIN(2,NGAS-1) 237 - PRINT *,' !!!!!! GASCHK WARNING : Invalid (v,E) angle'// 238 - - ' interpolation; taking polynomial of order ',IWMETH 239 - OK=.FALSE. 240 - ENDIF 1 515 P=GAS D=GASCHK 4 PAGE 752 241 - IF(GASOK(7).AND.(IWEXTR.LT.0.OR.IWEXTR.GT.2.OR. 242 - - JWEXTR.LT.0.OR.JWEXTR.GT.2).AND..NOT.TAB2D)THEN 243 - PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// 244 - - ' method for the (v,E) angle; assuming linear.' 245 - IWEXTR=1 246 - JWEXTR=1 247 - OK=.FALSE. 248 - ENDIF 249 - IF(NGAS.GT.1.AND.GASOK(8).AND.(((.NOT.TAB2D).AND. 250 - - (IOMETH.LT.0.OR.IOMETH.GT.MIN(10,NGAS-1))).OR. 251 - - (TAB2D.AND.(IOMETH.LT.0.OR.IOMETH.GT.2))))THEN 252 - IOMETH=MIN(2,NGAS-1) 253 - PRINT *,' !!!!!! GASCHK WARNING : Invalid sigma T'// 254 - - ' interpolation; taking polynomial of order ',IOMETH 255 - OK=.FALSE. 256 - ENDIF 257 - IF(GASOK(8).AND.(IOEXTR.LT.0.OR.IOEXTR.GT.2.OR. 258 - - JOEXTR.LT.0.OR.JOEXTR.GT.2).AND..NOT.TAB2D)THEN 259 - PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// 260 - - ' method for sigma T; assuming linear.' 261 - IOEXTR=1 262 - JOEXTR=1 263 - OK=.FALSE. 264 - ENDIF 265 - IF(NGAS.GT.1.AND.GASOK(9).AND.(((.NOT.TAB2D).AND. 266 - - (IXMETH.LT.0.OR.IXMETH.GT.MIN(10,NGAS-1))).OR. 267 - - (TAB2D.AND.(IXMETH.LT.0.OR.IXMETH.GT.2))))THEN 268 - IXMETH=MIN(2,NGAS-1) 269 - PRINT *,' !!!!!! GASCHK WARNING : Invalid v || Btrans'// 270 - - ' interpolation; using polynomial of order ',IXMETH 271 - OK=.FALSE. 272 - ENDIF 273 - IF(GASOK(9).AND.(IXEXTR.LT.0.OR.IXEXTR.GT.2.OR. 274 - - JXEXTR.LT.0.OR.JXEXTR.GT.2).AND..NOT.TAB2D)THEN 275 - PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// 276 - - ' method for v || Btrans; assuming linear.' 277 - IXEXTR=1 278 - JXEXTR=1 279 - OK=.FALSE. 280 - ENDIF 281 - IF(NGAS.GT.1.AND.GASOK(10).AND.(((.NOT.TAB2D).AND. 282 - - (IYMETH.LT.0.OR.IYMETH.GT.MIN(10,NGAS-1))).OR. 283 - - (TAB2D.AND.(IYMETH.LT.0.OR.IYMETH.GT.2))))THEN 284 - IYMETH=MIN(2,NGAS-1) 285 - PRINT *,' !!!!!! GASCHK WARNING : Invalid v || ExB'// 286 - - ' interpolation; taking polynomial of order ',IYMETH 287 - OK=.FALSE. 288 - ENDIF 289 - IF(GASOK(10).AND.(IYEXTR.LT.0.OR.IYEXTR.GT.2.OR. 290 - - JYEXTR.LT.0.OR.JYEXTR.GT.2).AND..NOT.TAB2D)THEN 291 - PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// 292 - - ' method for v || ExB; assuming linear.' 293 - IYEXTR=1 294 - JYEXTR=1 295 - OK=.FALSE. 296 - ENDIF 297 - *** Mean check: should be positive if cluster data have been entered. 298 - IF(GASOK(5).AND.CMEAN.LE.0)THEN 299 - PRINT *,' !!!!!! GASCHK WARNING : Number of clusters/cm'// 300 - - ' is absent or not positive; cluster data reset.' 301 - GASOK(5)=.FALSE. 302 - OK=.FALSE. 303 - ENDIF 304 - * MEAN makes no sense if no other cluster data are present. 305 - IF(CLSTYP.EQ.'NOT SET'.AND.GASOK(5))THEN 306 - PRINT *,' !!!!!! GASCHK WARNING : The MEAN parameter by'// 307 - - ' itself is not enough to have cluster data.' 308 - PRINT *,' Include the other', 309 - - ' parameters (A, Z etc), use HEED or use CLUSTER.' 310 - GASOK(5)=.FALSE. 311 - OK=.FALSE. 312 - ENDIF 313 - *** Cluster check: parameters for the Landau approximation must be > 0. 314 - IF(CLSTYP.EQ.'LANDAU'.AND.GASOK(5))THEN 315 - IF(A .LE.0)PRINT *,' !!!!!! GASCHK WARNING : The'// 316 - - ' number of nucleons is absent or not positive;'// 317 - - ' cluster data reset.' 318 - IF(Z .LE.0)PRINT *,' !!!!!! GASCHK WARNING : The'// 319 - - ' nuclear charge is absent or not positive;'// 320 - - ' cluster data reset.' 321 - IF(EMPROB.LE.0)PRINT *,' !!!!!! GASCHK WARNING : The most'// 322 - - ' probable energy loss is absent or not positive;'// 323 - - ' cluster data reset.' 324 - IF(EPAIR .LE.0)PRINT *,' !!!!!! GASCHK WARNING : The pair'// 325 - - ' creation energy is absent or not positive;'// 326 - - ' cluster data reset.' 327 - IF(RHO .LE.0)PRINT *,' !!!!!! GASCHK WARNING : The gas'// 328 - - ' density is absent or not positive;'// 329 - - ' cluster data reset.' 330 - IF(A.LE.0.OR.Z.LE.0.OR.EMPROB.LE.0.OR.EPAIR.LE.0.OR. 331 - - RHO.LE.0.OR.CMEAN.LE.0)THEN 332 - PRINT *,' !!!!!! GASCHK WARNING : No Landau based'// 333 - - ' cluster size distribution will be generated.' 334 - GASOK(5)=.FALSE. 335 - OK=.FALSE. 336 - ENDIF 337 - ENDIF 338 - * Direct cluster data, check number of points. 339 - IF((CLSTYP.EQ.'TABLE'.OR.CLSTYP.EQ.'FUNCTION'.OR. 340 - - CLSTYP.EQ.'FILE').AND.GASOK(5).AND.NCLS.LE.1)THEN 341 - PRINT *,' !!!!!! GASCHK WARNING : The number of cluster', 342 - - ' size distribution data points is insufficient.' 343 - GASOK(5)=.FALSE. 344 - OK=.FALSE. 345 - ENDIF 346 - * Direct cluster data, check positiveness. 1 515 P=GAS D=GASCHK 5 PAGE 753 347 - IF((CLSTYP.EQ.'TABLE'.OR.CLSTYP.EQ.'FUNCTION').AND.GASOK(5))THEN 348 - SUMCLS=0 349 - DO 40 I=1,NCLS 350 - IF(CLSDIS(I).LT.0)THEN 351 - PRINT *,' !!!!!! GASCHK WARNING : The probability for', 352 - - ' cluster size ',I,' is set to 0, was ',CLSDIS(I) 353 - CLSDIS(I)=0 354 - ENDIF 355 - SUMCLS=SUMCLS+CLSDIS(I) 356 - 40 CONTINUE 357 - * Direct cluster data, check integral. 358 - IF(SUMCLS.LE.0.0)THEN 359 - PRINT *,' !!!!!! GASCHK WARNING : The integral'// 360 - - ' over the cluster size distribution is'// 361 - - ' zero ; distribution rejected.' 362 - GASOK(5)=.FALSE. 363 - OK=.FALSE. 364 - ENDIF 365 - ENDIF 366 - * Check the consitency between CLSTYP and GASOK(5). 367 - IF(CLSTYP.NE.'FUNCTION'.AND.CLSTYP.NE.'TABLE'.AND.CLSTYP.NE. 368 - - 'LANDAU'.AND.CLSTYP.NE.'FILE'.AND.CLSTYP.NE.'OVERLAP'.AND. 369 - - GASOK(5))THEN 370 - PRINT *,' ###### GASCHK ERROR : Inconsistent cluster'// 371 - - ' type and flag; program bug, please report.' 372 - GASOK(5)=.FALSE. 373 - OK=.FALSE. 374 - ENDIF 375 - *** Flag data as unuseable if not a single table is present. 376 - IF(.NOT.(GASOK(1).OR.GASOK(2).OR.GASOK(3).OR.GASOK(4).OR. 377 - - GASOK(5).OR.GASOK(6).OR.GASOK(7).OR.GASOK(8).OR. 378 - - GASOK(9).OR.GASOK(10)))THEN 379 - PRINT *,' !!!!!! GASCHK WARNING : Not a single gas'// 380 - - ' element left in the description; gas rejected.' 381 - IFAIL=1 382 - ELSEIF((JFAIL.EQ.2.OR.JFAIL.EQ.3).AND..NOT.OK)THEN 383 - PRINT *,' !!!!!! GASCHK WARNING : Gas marked as'// 384 - - ' unuseable because of the above errors.' 385 - IFAIL=1 386 - ENDIF 387 - *** Generate some debugging output. 388 - IF(LDEBUG)PRINT *,' ++++++ GASCHK DEBUG : After checking the'// 389 - - ' GASOK bits are: ',(GASOK(I),I=1,10) 390 - *** And register the amount of CPU time used for checking. 391 - CALL TIMLOG('Checking the gas data makes sense: ') 392 - END 516 GARFIELD ================================================== P=GAS D=GASDEF 1 ============================ 0 + +DECK,GASDEF. 1 - SUBROUTINE GASDEF(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GASDEF - Routine controlling the gas input and output routines. 4 - * VARIABLES : LGASPL : Controls plotting of the gas data. 5 - * LGASPR : Controls printing of the gas data. 6 - * (Last changed on 5/ 2/00.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,GASDATA. 11.- +SEQ,PRINTPLOT. 12 - INTEGER IFAIL 13 - LOGICAL LGASPL,LGASPR,LGASWR 0 14-+ +SELF,IF=SAVE. 15 - SAVE LGASPL,LGASPR 0 16-+ +SELF. 17 - DATA LGASPL,LGASPR/.FALSE.,.FALSE./ 18 - *** Identify the routine, if requested. 19 - IF(LIDENT)PRINT *,' /// ROUTINE GASDEF ///' 20 - *** Identify the new section. 21 - WRITE(*,'(''1'')') 22 - PRINT *,' ' 23 - PRINT *,' ================================================' 24 - PRINT *,' ========== Start of gas definition ==========' 25 - PRINT *,' ================================================' 26 - PRINT *,' ' 27 - *** Initialise IFAIL to OK, reset the overall gas availability flag. 28 - IFAIL=0 29 - GASSET=.FALSE. 30 - *** First read and check all data. 31 - CALL GASINP(LGASPL,LGASPR,LGASWR,IFAIL) 32 - IF(IFAIL.NE.0)THEN 33 - IF(JFAIL.EQ.1)THEN 34 - PRINT *,' !!!!!! GASDEF WARNING : Input of the'// 35 - - ' gas data failed; CO2 will be used.' 36 - ELSEIF(JFAIL.EQ.2)THEN 37 - PRINT *,' !!!!!! GASDEF WARNING : Input of the'// 38 - - ' gas data failed; no gas data.' 39 - RETURN 40 - ELSE 41 - PRINT *,' !!!!!! GASDEF WARNING : Input of the'// 42 - - ' gas data failed; program quit.' 43 - CALL QUIT 44 - ENDIF 45 - ELSE 46 - CALL GASCHK(IFAIL) 47 - IF(IFAIL.NE.0)THEN 48 - IF(JFAIL.EQ.1)THEN 49 - PRINT *,' !!!!!! GASDEF WARNING : Gas data'// 50 - - ' not useable; CO2 will be used.' 51 - ELSEIF(JFAIL.EQ.2)THEN 52 - PRINT *,' !!!!!! GASDEF WARNING : Gas data'// 53 - - ' not useable; no gas data.' 54 - RETURN 1 516 P=GAS D=GASDEF 2 PAGE 754 55 - ELSE 56 - PRINT *,' !!!!!! GASDEF WARNING : Gas data'// 57 - - ' not useable; program quit.' 58 - CALL QUIT 59 - ENDIF 60 - ELSE 61 - GOTO 10 62 - ENDIF 63 - ENDIF 64 - *** Provide an emergency entry for creation of gasdata. 65 - ENTRY XXXGAS(IFAIL) 66 - CALL CO2 67 - TAB2D=.FALSE. 68 - LGASWR=.FALSE. 69 - *** Prepare the gas data for use later on. 70 - 10 CONTINUE 71 - CALL GASPRE(IFAIL) 72 - *** Print, plot and write them as requested. 73 - IF(LGASPR)CALL GASPRT 74 - IF(LGASPL)CALL GASPLT 75 - IF(LGASWR)CALL GASWRT(2) 76 - *** Seems to have worked, make gas available. 77 - GASSET=.TRUE. 78 - END 517 GARFIELD ================================================== P=GAS D=GASGET 1 ============================ 0 + +DECK,GASGET. 1 - SUBROUTINE GASGET(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GASGET - This routine retrieves the gas data written to an external 4 - * dataset written by a WRITE instruction. 5 - * VARIABLES : NWORD : Number of parameters provided. 6 - * STRING : String for character manipulation. 7 - * (Last changed on 7/ 4/00.) 8 - *----------------------------------------------------------------------- 9 - implicit none 10.- +SEQ,DIMENSIONS. 11.- +SEQ,GASDATA. 12.- +SEQ,BFIELD. 13.- +SEQ,PRINTPLOT. 14 - CHARACTER*(MXCHAR) STRING 15 - CHARACTER*8 MEMBER 16 - CHARACTER*(MXNAME) FILE 17 - INTEGER IFAIL,NCFILE,NCMEMB,I,II,J,K,IOS,IFAIL1,NWORD 18 - LOGICAL DSNCMP,EXIS 19 - EXTERNAL DSNCMP 20 - *** Identify the routine. 21 - IF(LIDENT)PRINT *,' /// ROUTINE GASGET ///' 22 - *** Initialise IFAIL on 1 (i.e. fail). 23 - IFAIL=1 24 - FILE=' ' 25 - MEMBER='*' 26 - NCFILE=8 27 - NCMEMB=1 28 - *** First decode the argument string, setting file name + member name. 29 - CALL INPNUM(NWORD) 30 - * If there's only one argument, it's the dataset name. 31 - IF(NWORD.GE.2)THEN 32 - CALL INPSTR(2,2,STRING,NCFILE) 33 - FILE=STRING 34 - ENDIF 35 - * If there's a second argument, it is the member name. 36 - IF(NWORD.GE.3)THEN 37 - CALL INPSTR(3,3,STRING,NCMEMB) 38 - MEMBER=STRING 39 - ENDIF 40 - * Check the various lengths. 41 - IF(NCFILE.GT.MXNAME)THEN 42 - PRINT *,' !!!!!! GASGET WARNING : The file name is'// 43 - - ' truncated to MXNAME (=',MXNAME,') characters.' 44 - NCFILE=MIN(NCFILE,MXNAME) 45 - ENDIF 46 - IF(NCMEMB.GT.8)THEN 47 - PRINT *,' !!!!!! GASGET WARNING : The member name is'// 48 - - ' shortened to ',MEMBER,', first 8 characters.' 49 - NCMEMB=MIN(NCMEMB,8) 50 - ELSEIF(NCMEMB.LE.0)THEN 51 - PRINT *,' !!!!!! GASGET WARNING : The member'// 52 - - ' name has zero length, replaced by "*".' 53 - MEMBER='*' 54 - NCMEMB=1 55 - ENDIF 56 - * Reject the empty file name case. 57 - IF(FILE.EQ.' '.OR.NWORD.EQ.1)THEN 58 - PRINT *,' !!!!!! GASGET WARNING : GET must be at least'// 59 - - ' followed by a dataset name ; no data are read.' 60 - RETURN 61 - ENDIF 62 - * If there are even more args, warn they are ignored. 63 - IF(NWORD.GT.3)PRINT *,' !!!!!! GASGET WARNING : GET takes'// 64 - - ' at most two arguments (dataset and member); rest ignored.' 65 - *** Open a dataset and inform DSNLOG. 66 - CALL DSNOPN(FILE,NCFILE,12,'READ-LIBRARY',IFAIL1) 67 - IF(IFAIL1.NE.0)THEN 68 - PRINT *,' !!!!!! GASGET WARNING : Opening ',FILE(1:NCFILE), 69 - - ' failed ; gas data are not read.' 70 - RETURN 71 - ENDIF 72 - CALL DSNLOG(FILE,'Gas data ','Sequential','Read only ') 73 - IF(LDEBUG)PRINT *,' ++++++ GASGET DEBUG : Dataset ', 74 - - FILE(1:NCFILE),' opened on unit 12 for seq read.' 75 - * Locate the pointer on the header of the requested member. 76 - CALL DSNLOC(MEMBER,NCMEMB,'GAS ',12,EXIS,'RESPECT') 77 - IF(.NOT.EXIS)THEN 78 - CALL DSNLOC(MEMBER,NCMEMB,'GAS ',12,EXIS,'IGNORE') 1 517 P=GAS D=GASGET 2 PAGE 755 79 - IF(EXIS)THEN 80 - PRINT *,' ###### GASGET ERROR : Gas description '// 81 - - MEMBER(1:NCMEMB)//' has been deleted from '// 82 - - FILE(1:NCFILE)//'; not read.' 83 - ELSE 84 - PRINT *,' ###### GASGET ERROR : Gas description '// 85 - - MEMBER(1:NCMEMB)//' not found in '//FILE(1:NCFILE) 86 - ENDIF 87 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 88 - RETURN 89 - ENDIF 90 - * Check that this member contains indeed gas data. 91 - READ(12,'(A80)',END=2000,IOSTAT=IOS,ERR=2010) STRING 92 - IF(LDEBUG)THEN 93 - PRINT *,' ++++++ GASGET DEBUG : Dataset header'// 94 - - ' record follows:' 95 - PRINT *,STRING 96 - ENDIF 97 - WRITE(*,'('' Member '',A8,'' was created on '',A8, 98 - - '' at '',A8/'' Remarks: '',A29)') 99 - - STRING(32:39),STRING(11:18),STRING(23:30),STRING(51:79) 100 - * Check the version. 101 - READ(12,'(A14)',END=2000,IOSTAT=IOS,ERR=2010) STRING 102 - IF(STRING(1:14).NE.' Version : 3')THEN 103 - PRINT *,' !!!!!! GASGET WARNING : This member'// 104 - - ' can not be read because of a change in format.' 105 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 106 - RETURN 107 - ENDIF 108 - *** Read the rest of the dataset. 109 - READ(12,'(13X,10L1)',END=2000,IOSTAT=IOS,ERR=2010) 110 - - (GASOK(I),I=1,10) 111 - READ(12,'(13X,A)',END=2000,IOSTAT=IOS,ERR=2010) GASID 112 - READ(12,'(13X,A80)',END=2000,IOSTAT=IOS,ERR=2010) FCNTAB 113 - READ(12,'(13X,L1,3I10)',END=2000,IOSTAT=IOS,ERR=2010) 114 - - TAB2D,NGAS,NBANG,NBTAB 115 - C READ(12,'(13X,E15.8)',END=2000,IOSTAT=IOS,ERR=2010) BREAD 116 - C IF(ABS(BREAD-SQRT(B0XY**2+B0Z**2)).GT.1E-4*(1+ABS(BREAD)+ 117 - C - SQRT(B0XY**2+B0Z**2)))THEN 118 - C PRINT *,' !!!!!! GASGET WARNING : The gas table to be'// 119 - C - ' read was made for B=',BREAD/100,' T' 120 - C PRINT *,' while the current B-'// 121 - C - 'field is ',SQRT(B0XY**2+B0Z**2)/100,' T; not read.' 122 - C CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 123 - C RETURN 124 - C ENDIF 125 - * Skip the header line. 126 - READ(12,*,END=2000,IOSTAT=IOS,ERR=2010) 127 - * Check the number of E points. 128 - IF(NGAS.LE.0.OR.NGAS.GT.MXLIST)THEN 129 - PRINT *,' !!!!!! GASGET WARNING : Number of gas points in', 130 - - ' dataset ',FILE(1:NCFILE),' out of range: ',NGAS 131 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 132 - RETURN 133 - * Check the number of angles. 134 - ELSEIF(TAB2D.AND.(NBANG.LE.0.OR.NBANG.GT.MXBANG))THEN 135 - PRINT *,' !!!!!! GASGET WARNING : Number of E-B angles in', 136 - - ' dataset ',FILE(1:NCFILE),' out of range: ',NBANG 137 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 138 - RETURN 139 - * Check the number of B points. 140 - ELSEIF(TAB2D.AND.(NBTAB.LE.0.OR.NBTAB.GT.MXBTAB))THEN 141 - PRINT *,' !!!!!! GASGET WARNING : Number of B fields in', 142 - - ' dataset ',FILE(1:NCFILE),' out of range: ',NBTAB 143 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 144 - RETURN 145 - * Read a 2-dimensional table. 146 - ELSEIF(TAB2D)THEN 147 - READ(12,'(/(5E15.8))',IOSTAT=IOS,ERR=2010,END=2000) 148 - - (BANG(I),I=1,NBANG) 149 - READ(12,'(/(5E15.8))',IOSTAT=IOS,ERR=2010,END=2000) 150 - - (BTAB(I),I=1,NBTAB) 151 - DO 210 I=1,NGAS 152 - DO 220 J=1,NBANG 153 - DO 230 K=1,NBTAB 154 - READ(12,'(8E15.8/2E15.8)',IOSTAT=IOS,ERR=2010,END=2000) 155 - - EGAS(I),VGAS2(I,J,K),XGAS2(I,J,K),YGAS2(I,J,K), 156 - - DGAS2(I,J,K),OGAS2(I,J,K), 157 - - AGAS2(I,J,K),BGAS2(I,J,K),MGAS2(I,J,K),WGAS2(I,J,K) 158 - 230 CONTINUE 159 - 220 CONTINUE 160 - 210 CONTINUE 161 - * Read a 1-dimensional table. 162 - ELSE 163 - DO 212 I=1,NGAS 164 - READ(12,'(8E15.8/15X,7E15.8/15X,4E15.8)',END=2000, 165 - - IOSTAT=IOS,ERR=2010) 166 - - EGAS(I), 167 - - VGAS(I),CVGAS(I),XGAS(I),CXGAS(I),YGAS(I),CYGAS(I), 168 - - DGAS(I),CDGAS(I),OGAS(I),COGAS(I), 169 - - AGAS(I),CAGAS(I),BGAS(I),CBGAS(I),MGAS(I),CMGAS(I), 170 - - WGAS(I),CWGAS(I) 171 - 212 CONTINUE 172 - READ(12,'(9X,9(/I2,2E15.8))',END=2000,IOSTAT=IOS,ERR=2010) 173 - - IVEXTR,VEXTR1,VEXTR2, 174 - - IXEXTR,XEXTR1,XEXTR2,IYEXTR,YEXTR1,YEXTR2, 175 - - IDEXTR,DEXTR1,DEXTR2, 176 - - IAEXTR,AEXTR1,AEXTR2,IBEXTR,BEXTR1,BEXTR2, 177 - - IMEXTR,MEXTR1,MEXTR2,IWEXTR,WEXTR1,WEXTR2, 178 - - IOEXTR,OEXTR1,OEXTR2 179 - READ(12,'(9X,9(/I2,2E15.8))',END=2000,IOSTAT=IOS,ERR=2010) 180 - - JVEXTR,VEXTR3,VEXTR4, 181 - - JXEXTR,XEXTR3,XEXTR4,JYEXTR,YEXTR3,YEXTR4, 182 - - JDEXTR,DEXTR3,DEXTR4, 183 - - JAEXTR,AEXTR3,AEXTR4,JBEXTR,BEXTR3,BEXTR4, 184 - - JMEXTR,MEXTR3,MEXTR4,JWEXTR,WEXTR3,WEXTR4, 1 517 P=GAS D=GASGET 3 PAGE 756 185 - - JOEXTR,OEXTR3,OEXTR4 186 - ENDIF 187 - * Read interpolation methods. 188 - READ(12,'(13X,BN,2I10)',IOSTAT=IOS,ERR=2010) IATHR,IBTHR 189 - READ(12,'(9X,BN,9I10)',IOSTAT=IOS,ERR=2010) 190 - - IVMETH,IXMETH,IYMETH,IDMETH,IAMETH,IBMETH,IMMETH, 191 - - IWMETH,IOMETH 192 - * Read cluster data. 193 - READ(12,'(4(8X,E15.8,1X))',END=2000,IOSTAT=IOS,ERR=2010) 194 - - A,Z,EMPROB,EPAIR 195 - * Ion diffusion. 196 - READ(12,'(16X,2E15.8)') DLION,DTION 197 - * Further cluster data. 198 - READ(12,'(4(8X,E15.8,1X))',END=2000,IOSTAT=IOS,ERR=2010) 199 - - CMEAN,RHO,PGAS,TGAS 200 - * Clustering model and cluster size distribution. 201 - READ(12,'(13X,A10)',END=2000,IOSTAT=IOS,ERR=2010) CLSTYP 202 - READ(12,'(13X,A80)',END=2000,IOSTAT=IOS,ERR=2010) FCNCLS 203 - READ(12,'(13X,BN,2I10)',END=2000,IOSTAT=IOS,ERR=2010) NCLS 204 - READ(12,'(13X,D25.18)',END=2000,IOSTAT=IOS,ERR=2010) CLSAVE 205 - DO 240 II=1,NCLS,5 206 - READ(12,'(5D25.18)',END=2000,IOSTAT=IOS,ERR=2010) 207 - - (CLSDIS(I),I=II,MIN(II+4,NCLS)) 208 - 240 CONTINUE 209 - * Heed initialisation data. 210 - CALL GASHGT(IFAIL1) 211 - IF(IFAIL1.NE.0)THEN 212 - PRINT *,' !!!!!! GASGET WARNING : Reading Heed data'// 213 - - ' failed ; gas data not available.' 214 - RETURN 215 - ENDIF 216 - *** Close the file after the operation. 217 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 218 - IFAIL=0 219 - CALL TIMLOG('Reading the gas data from a dataset: ') 220 - RETURN 221 - *** Handle the I/O error conditions. 222 - 2000 CONTINUE 223 - PRINT *,' ###### GASGET ERROR : EOF encountered while reading', 224 - - ' '//FILE(1:NCFILE)//' from unit 12 ; no gas data read.' 225 - CALL INPIOS(IOS) 226 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 227 - RETURN 228 - 2010 CONTINUE 229 - PRINT *,' ###### GASGET ERROR : Error while reading'// 230 - - ' '//FILE(1:NCFILE)//' from unit 12 ; no gas data read.' 231 - CALL INPIOS(IOS) 232 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 233 - RETURN 234 - 2030 CONTINUE 235 - PRINT *,' ###### GASGET ERROR : Dataset '//FILE(1:NCFILE)// 236 - - ' on unit 12 cannot be closed ; results not predictable.' 237 - CALL INPIOS(IOS) 238 - END 518 GARFIELD ================================================== P=GAS D=GASINP 1 ============================ 0 + +DECK,GASINP. 1 - SUBROUTINE GASINP(LGASPL,LGASPR,LGASWR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GASINP - Subroutine initialising gasdata (i.e. filling /GASDAT/). 4 - * VARIABLES : IFAIL : 1 if routine failed 0 if succesful 5 - * (Last changed on 12/ 9/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,GASDATA. 10.- +SEQ,BFIELD. 11.- +SEQ,PRINTPLOT. 12.- +SEQ,CONSTANTS. 13 - CHARACTER*(MXCHAR) STRING 14 - CHARACTER*10 VARTAB(MXVAR),VARCLS(MXVAR),UNIT 15 - CHARACTER*20 STRAUX 16 - LOGICAL USE(MXVAR),STDSTR,LGASPL,LGASPR,LGASWR,FLAG(MXWORD+3), 17 - - OVERLP,EPLOG,OK 18 - REAL VAR(MXVAR),RES(MXWORD),SIZ,CLSR,PGASR,TGASR, 19 - - PGASRR,TGASRR,DATAR,DIONR,YMINR,YMAXR, 20 - - EPMIN,EPMAX,EPMINR,EPMAXR, 21 - - BANGMN,BANGMX,BAMINR,BAMAXR, 22 - - BTABMN,BTABMX,BTMINR,BTMAXR 23 - INTEGER MODVAR(MXVAR),MODRES(MXWORD),IFAIL,INPCMP,INPTYP,I,J,K, 24 - - INEXT,II,IINEXT,NWORD,IENTRY,NRES,NC,ICLS,IMETHR,IFAIL1, 25 - - IFAIL2,IFAIL3,IRANGE,NCLR,IOBJ,IEXTRR,NNGAS, 26 - - ITAB,IEP,IDRIFT,IVB,IVEXB,IDIFF,ITRANS,IMOBIL,ITOWN,IATT, 27 - - ILOREN,IFCN,NCUNIT,NGASR,NBANGR,NBTABR,NCAUX 28 - EXTERNAL STDSTR,INPCMP,INPTYP 0 29-+ +SELF,IF=AST. 30 - EXTERNAL ASTCCH 0 31-+ +SELF,IF=SAVE. 32 - SAVE VARTAB,VARCLS 0 33-+ +SELF. 34 - DATA (VARTAB(I),I=1,7)/ 35 - - 'EP ','BOLTZMANN ','ECHARGE ','ANGLE_EB ', 36 - - 'B ','T ','P '/ 37 - DATA VARCLS(1)/'N '/ 38 - *** Define some output formats. 39 - 1050 FORMAT(/' LOCAL OPTIONS CURRENTLY IN EFFECT:'// 40 - - ' Plotting graphs of the gas data (GAS-PLOT): ',L1/ 41 - - ' Printing a gas summary table (GAS-PRINT): ',L1/) 42 - *** Identify the routine, if requested. 43 - IF(LIDENT)PRINT *,' /// ROUTINE GASINP ///' 44 - *** Preset the control variables. 45 - LGASWR=.FALSE. 1 518 P=GAS D=GASINP 2 PAGE 757 46 - *** Preset the gas data. 47 - CALL GASINT 48 - *** Loop over the input commands, until a new heading is found. 49 - CALL INPPRM('Gas','NEW-PRINT') 50 - 10 CONTINUE 51 - *** Read a new input line. 52 - CALL INPWRD(NWORD) 0 53-+ +SELF,IF=AST. 54 - *** Set up ASTCCH as the condition handler. 55 - CALL LIB$ESTABLISH(ASTCCH) 0 56-+ +SELF. 57 - *** Skip this line if it is blank. 58 - CALL INPSTR(1,1,STRING,NC) 59 - IF(NWORD.EQ.0)GOTO 10 60 - *** Leave if the first sign in the command is &. 61 - IF(STRING(1:1).EQ.'&')THEN 62 - IF(LDEBUG)PRINT *,' ++++++ GASINP DEBUG : On leaving,', 63 - - ' the GASOK bits are ',(GASOK(I),I=1,10) 64 - CALL TIMLOG('Reading the gas data: ') 65 - RETURN 66 - *** Add an item to the gas tables. 67 - ELSEIF(INPCMP(1,'ADD')+INPCMP(1,'REPL#ACE').NE.0)THEN 68 - * Call the routine. 69 - CALL GASADD 70 - *** Axes for the plots. 71 - ELSEIF(INPCMP(1,'PL#OT-OPT#IONS')+INPCMP(1,'AX#ES').NE.0)THEN 72 - * No arguments: list current settings. 73 - IF(NWORD.EQ.1)THEN 74 - WRITE(LUNOUT, 75 - - '(/'' GAS PLOT OPTIONS:''/ 76 - - '' Quantity '', 77 - - '' Log-x Log-y Range''/)') 78 - IF(.NOT.GASOPT(1,3))THEN 79 - WRITE(LUNOUT,'('' Drift velocity: '', 80 - - '' Not plotted.'')') 81 - ELSEIF(GASOPT(1,4))THEN 82 - WRITE(LUNOUT,'('' Drift velocity: '', 83 - - 2L6,2X,2E12.5)') (GASOPT(1,J),J=1,2), 84 - - (GASRNG(1,J),J=1,2) 85 - ELSE 86 - WRITE(LUNOUT,'('' Drift velocity: '', 87 - - 2L6,2X,''Automatic'')') (GASOPT(1,J),J=1,2) 88 - ENDIF 89 - IF(.NOT.GASOPT(2,3))THEN 90 - WRITE(LUNOUT,'('' Ion mobility: '', 91 - - '' Not plotted.'')') 92 - ELSEIF(GASOPT(2,4))THEN 93 - WRITE(LUNOUT,'('' Ion mobility: '', 94 - - 2L6,2X,2E12.5)') (GASOPT(2,J),J=1,2), 95 - - (GASRNG(2,J),J=1,2) 96 - ELSE 97 - WRITE(LUNOUT,'('' Ion mobility: '', 98 - - 2L6,2X,''Automatic'')') (GASOPT(2,J),J=1,2) 99 - ENDIF 100 - IF(.NOT.GASOPT(3,3))THEN 101 - WRITE(LUNOUT,'('' Diffusion coefficients: '', 102 - - '' Not plotted.'')') 103 - ELSEIF(GASOPT(3,4))THEN 104 - WRITE(LUNOUT,'('' Diffusion coefficients: '', 105 - - 2L6,2X,2E12.5)') (GASOPT(3,J),J=1,2), 106 - - (GASRNG(3,J),J=1,2) 107 - ELSE 108 - WRITE(LUNOUT,'('' Diffusion coefficients: '', 109 - - 2L6,2X,''Automatic'')') (GASOPT(3,J),J=1,2) 110 - ENDIF 111 - IF(.NOT.GASOPT(4,3))THEN 112 - WRITE(LUNOUT,'('' Townsend & attachment: '', 113 - - '' Not plotted.'')') 114 - ELSEIF(GASOPT(4,4))THEN 115 - WRITE(LUNOUT,'('' Townsend & attachment: '', 116 - - 2L6,2X,2E12.5)') (GASOPT(4,J),J=1,2), 117 - - (GASRNG(4,J),J=1,2) 118 - ELSE 119 - WRITE(LUNOUT,'('' Townsend & attachment: '', 120 - - 2L6,2X,''Automatic'')') (GASOPT(4,J),J=1,2) 121 - ENDIF 122 - IF(.NOT.GASOPT(7,3))THEN 123 - WRITE(LUNOUT,'('' Angle between v and E: '', 124 - - '' Not plotted.'')') 125 - ELSEIF(GASOPT(7,4))THEN 126 - WRITE(LUNOUT,'('' Angle between v and E: '', 127 - - 2L6,2X,2E12.5)') (GASOPT(7,J),J=1,2), 128 - - (GASRNG(7,J),J=1,2) 129 - ELSE 130 - WRITE(LUNOUT,'('' Angle between v and E: '', 131 - - 2L6,2X,''Automatic'')') (GASOPT(7,J),J=1,2) 132 - ENDIF 133 - IF(.NOT.GASOPT(5,3))THEN 134 - WRITE(LUNOUT,'('' Cluster size distribution:'', 135 - - '' Not plotted.'')') 136 - ELSE 137 - WRITE(LUNOUT,'('' Cluster size distribution:'', 138 - - 2L6)') (GASOPT(5,J),J=1,2) 139 - ENDIF 140 - GOTO 10 141 - ENDIF 142 - * Loop over the arguments. 143 - INEXT=2 144 - DO 700 I=2,NWORD 145 - IF(INEXT.GT.I)GOTO 700 146 - * Identify the plot. 147 - IOBJ=0 148 - IF(INPCMP(I,'DR#IFT-#VELOCITY-#PLOT').NE.0)THEN 149 - IOBJ=1 1 518 P=GAS D=GASINP 3 PAGE 758 150 - GASOPT(1,3)=.TRUE. 151 - ELSEIF(INPCMP(I,'NODR#IFT-#VELOCITY-#PLOT').NE.0)THEN 152 - IOBJ=0 153 - GASOPT(1,3)=.FALSE. 154 - ELSEIF(INPCMP(I,'ION-MOB#ILITY-#PLOT')+ 155 - - INPCMP(I,'MOB#ILITY-#PLOT').NE.0)THEN 156 - GASOPT(2,3)=.TRUE. 157 - IOBJ=2 158 - ELSEIF(INPCMP(I,'NOION-MOB#ILITY-#PLOT')+ 159 - - INPCMP(I,'NOMOB#ILITY-#PLOT').NE.0)THEN 160 - GASOPT(2,3)=.FALSE. 161 - IOBJ=0 162 - ELSEIF(INPCMP(I,'DIFF#USION-#COEFFICIENTS-#PLOT')+ 163 - - INPCMP(I,'DIFF#USION-#PLOT').NE.0)THEN 164 - IOBJ=3 165 - GASOPT(3,3)=.TRUE. 166 - ELSEIF(INPCMP(I,'NODIFF#USION-#COEFFICIENTS-#PLOT')+ 167 - - INPCMP(I,'NODIFF#USION-#PLOT').NE.0)THEN 168 - IOBJ=0 169 - GASOPT(3,3)=.FALSE. 170 - ELSEIF(INPCMP(I,'TOWN#SEND-#COEFFICIENTS-#PLOT')+ 171 - - INPCMP(I,'TOWN#SEND-#PLOT')+ 172 - - INPCMP(I,'ATT#ACHMENT-#COEFFICIENTS-#PLOT')+ 173 - - INPCMP(I,'ATT#ACHMENT-#PLOT').NE.0)THEN 174 - IOBJ=4 175 - GASOPT(4,3)=.TRUE. 176 - ELSEIF(INPCMP(I,'NOTOWN#SEND-#COEFFICIENTS-#PLOT')+ 177 - - INPCMP(I,'NOTOWN#SEND-#PLOT')+ 178 - - INPCMP(I,'ATT#ACHMENT-#COEFFICIENTS-#PLOT')+ 179 - - INPCMP(I,'ATT#ACHMENT-#PLOT').NE.0)THEN 180 - IOBJ=0 181 - GASOPT(4,3)=.FALSE. 182 - ELSEIF(INPCMP(I,'CLUS#TER-#SIZE-#DISTRIBUTION-#PLOT')+ 183 - - INPCMP(I,'CLUS#TER-#SIZE-#PLOT').NE.0)THEN 184 - IOBJ=5 185 - GASOPT(5,3)=.TRUE. 186 - ELSEIF(INPCMP(I,'NOCLUS#TER-#SIZE-#DISTRIBUTION-#PLOT')+ 187 - - INPCMP(I,'NOCLUS#TER-#SIZE-#PLOT').NE.0)THEN 188 - IOBJ=0 189 - GASOPT(5,3)=.FALSE. 190 - ELSEIF(INPCMP(I,'LOR#ENTZ-#ANGLES-#PLOT').NE.0)THEN 191 - IOBJ=7 192 - GASOPT(7,3)=.TRUE. 193 - ELSEIF(INPCMP(I,'NOLOR#ENTZ-#ANGLES-#PLOT').NE.0)THEN 194 - IOBJ=0 195 - GASOPT(7,3)=.FALSE. 196 - ELSE 197 - CALL INPMSG(I,'Not a known plot.') 198 - GOTO 700 199 - ENDIF 200 - * Skip rest if plot not requested. 201 - IF(IOBJ.EQ.0)GOTO 700 202 - * Identify the axes and ranges. 203 - DO 730 J=I+1,NWORD 204 - IF(J.LT.INEXT)GOTO 730 205 - IF(INPCMP(J,'LIN#EAR-X').NE.0)THEN 206 - GASOPT(IOBJ,1)=.FALSE. 207 - INEXT=J+1 208 - ELSEIF(INPCMP(J,'LOG#ARITHMIC-X').NE.0)THEN 209 - GASOPT(IOBJ,1)=.TRUE. 210 - INEXT=J+1 211 - ELSEIF(INPCMP(J,'LIN#EAR-Y').NE.0)THEN 212 - GASOPT(IOBJ,2)=.FALSE. 213 - INEXT=J+1 214 - ELSEIF(INPCMP(J,'LOG#ARITHMIC-Y').NE.0)THEN 215 - GASOPT(IOBJ,2)=.TRUE. 216 - INEXT=J+1 217 - ELSEIF(INPCMP(J,'RANGE')+INPCMP(J,'SCALE').NE.0)THEN 218 - IF(INPCMP(J+1,'AUTO#MATIC').NE.0)THEN 219 - GASOPT(IOBJ,4)=.FALSE. 220 - INEXT=J+2 221 - ELSEIF(INPTYP(J+1).LE.0.OR.INPTYP(J+2).LE.0)THEN 222 - CALL INPMSG(J,'Values missing') 223 - ELSE 224 - GASOPT(IOBJ,4)=.TRUE. 225 - CALL INPCHK(J+1,2,IFAIL1) 226 - CALL INPCHK(J+2,2,IFAIL2) 227 - CALL INPRDR(J+1,YMINR,0.0) 228 - CALL INPRDR(J+2,YMAXR,0.0) 229 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN 230 - IF(YMINR.NE.YMAXR)THEN 231 - GASRNG(IOBJ,1)=MIN(YMINR,YMAXR) 232 - GASRNG(IOBJ,2)=MAX(YMINR,YMAXR) 233 - ELSE 234 - CALL INPMSG(J+1, 235 - - 'Zero range not permitted.') 236 - CALL INPMSG(J+1, 237 - - 'See previous message.') 238 - ENDIF 239 - ENDIF 240 - INEXT=J+3 241 - ENDIF 242 - ELSE 243 - INEXT=J 244 - GOTO 700 245 - ENDIF 246 - 730 CONTINUE 247 - * Next plot. 248 - 700 CONTINUE 249 - * Dump error messages. 250 - CALL INPERR 251 - *** Call the routine A50E50 if ARGON-50-ETHANE-50 is the keyword. 252 - ELSEIF(INPCMP(1,'A#RGON-50-E#THANE-50')+ 253 - - INPCMP(1,'E#THANE-50-A#RGON-50').NE.0)THEN 254 - CALL A50E50 255 - *** Call the routine A20E80 if ARGON-20-ETHANE-80 is the keyword. 1 518 P=GAS D=GASINP 4 PAGE 759 256 - ELSEIF(INPCMP(1,'A#RGON-20-E#THANE-80')+ 257 - - INPCMP(1,'E#THANE-80-A#RGON-20').NE.0)THEN 258 - CALL A20E80 259 - *** Call the routine A80E20 if ARGON-80-ETHANE-20 is the keyword. 260 - ELSEIF(INPCMP(1,'A#RGON-80-E#THANE-20')+ 261 - - INPCMP(1,'E#THANE-20-A#RGON-80').NE.0)THEN 262 - CALL A80E20 263 - *** Call the routine A73M20 if ARGON-73-ETHANE-20-PROPANOL-7 is asked. 264 - ELSEIF(INPCMP(1,'A#RGON-73-M#ETHANE-20-#PROPANOL-#7')+ 265 - - INPCMP(1,'M#ETHANE-20-A#RGON-73-#PROPANOL-#7').NE.0)THEN 266 - CALL A73M20 267 - *** Call the routine C80E20 if CO2-80-ETHANE-20 is the keyword. 268 - ELSEIF(INPCMP(1,'CO2-80-E#THANE-20')+ 269 - - INPCMP(1,'E#THANE-20-CO2-80').NE.0)THEN 270 - CALL C80E20 271 - *** Call the routine C90E10 if CO2-90-ETHANE-10 is the keyword. 272 - ELSEIF(INPCMP(1,'CO2-90-E#THANE-10')+ 273 - - INPCMP(1,'E#THANE-10-CO2-90').NE.0)THEN 274 - CALL C90E10 275 - *** Call the routine C90I10 if CO2-90-ISOBUTANE-10 is the keyword. 276 - ELSEIF(INPCMP(1,'CO2-90-I#SOBUTANE-10')+ 277 - - INPCMP(1,'I#SOBUTANE-10-CO2-90').NE.0)THEN 278 - CALL C90I10 279 - *** Call the routine CO2 to transfer data if CO2 is a keyword. 280 - ELSEIF(INPCMP(1,'CO2').NE.0)THEN 281 - CALL CO2 282 - *** Read the cluster size distribution if CLUSTER-SIZE is a keyword. 283 - ELSEIF(INPCMP(1,'CL#USTER-#SIZE-#DISTRIBUTION').NE.0)THEN 284 - ** Initialise. 285 - NFCLS=0 286 - FCNCLS='?' 287 - NCLS=MXPAIR 288 - OVERLP=.FALSE. 289 - ** Read further command line arguments. 290 - IINEXT=2 291 - DO 30 II=2,NWORD 292 - IF(II.LT.IINEXT)GOTO 30 293 - * Function following ? 294 - IF(INPCMP(II,'F#UNCTION').NE.0)THEN 295 - CALL INPSTR(II+1,II+1,STRING,NFCLS) 296 - FCNCLS=STRING(1:NFCLS) 297 - IINEXT=II+2 298 - * Maximum number of entries for functions. 299 - ELSEIF(INPCMP(II,'N-#MAXIMUM')+ 300 - - INPCMP(II,'MAX#IMUM-#CLUSTER-#SIZE').NE.0)THEN 301 - CALL INPCHK(II+1,1,IFAIL1) 302 - CALL INPRDI(II+1,NCLR,0) 303 - IF(NCLR.LE.0.AND.IFAIL1.EQ.0)THEN 304 - CALL INPMSG(II+1,'Not a positive integer.') 305 - ELSEIF(NCLR.GT.MXPAIR.OR.IFAIL1.NE.0)THEN 306 - CALL INPMSG(II+1,'Should be < MXPAIR.') 307 - NCLS=MXPAIR 308 - ELSE 309 - NCLS=NCLR 310 - ENDIF 311 - IINEXT=II+2 312 - * Overlap with table entries. 313 - ELSEIF(INPCMP(II,'OVERLAP-#TABLE-#AND-#FUNCTION').NE.0)THEN 314 - OVERLP=.TRUE. 315 - ELSEIF(INPCMP(II,'NOOVERLAP-#TABLE-#AND-#FUNCTION').NE. 316 - - 0)THEN 317 - OVERLP=.FALSE. 318 - * Other keywords are not known. 319 - ELSE 320 - CALL INPMSG(II+1,'Not a known keyword.') 321 - ENDIF 322 - 30 CONTINUE 323 - * Print error messages. 324 - CALL INPERR 325 - ** Check that a function was indeed specified. 326 - IF(NWORD.GT.1.AND.NFCLS.LE.0)PRINT *,' !!!!!! GASINP'// 327 - - ' WARNING : Cluster function not found.' 328 - IF(NWORD.GT.1.AND.NFCLS.LE.0.AND..NOT.OVERLP)THEN 329 - PRINT *,' !!!!!! GASINP WARNING : Also no OVERLAP'// 330 - - ' option; CLUSTER ignored.' 331 - GOTO 10 332 - ENDIF 333 - ** If a function is present, process it. 334 - IF(NFCLS.GE.1)THEN 335 - IF(INDEX(FCNCLS(1:NFCLS),'@').NE.0)THEN 336 - NRES=1 337 - CALL ALGEDT(VARCLS,1,IENTRY,USE,NRES) 338 - ELSE 339 - CALL ALGPRE(FCNCLS,NFCLS,VARCLS,1,NRES,USE,IENTRY, 340 - - IFAIL1) 341 - IF(IFAIL1.NE.0)THEN 342 - PRINT *,' !!!!!! GASINP WARNING : Cluster'// 343 - - ' size distribution function rejected.' 344 - CALL ALGCLR(IENTRY) 345 - GOTO 10 346 - ENDIF 347 - ENDIF 348 - IF(NRES.NE.1)THEN 349 - PRINT *,' !!!!!! GASINP WARNING : Number of'// 350 - - ' results returned by the cluster size'// 351 - - ' distribution function is not 1.' 352 - CALL ALGCLR(IENTRY) 353 - GOTO 10 354 - ENDIF 355 - * Enter the function into the CLSDIS histogram. 356 - DO 200 I=1,NCLS 357 - VAR(1)=I-1.0 358 - MODVAR(1)=2 359 - CALL ALGEXE(IENTRY,VAR,MODVAR,1,RES,MODRES,1,IFAIL1) 360 - SIZ=RES(1) 361 - VAR(1)=I-0.5 1 518 P=GAS D=GASINP 5 PAGE 760 362 - CALL ALGEXE(IENTRY,VAR,MODVAR,1,RES,MODRES,1,IFAIL2) 363 - SIZ=SIZ+4.0*RES(1) 364 - VAR(1)=I 365 - CALL ALGEXE(IENTRY,VAR,MODVAR,1,RES,MODRES,1,IFAIL3) 366 - SIZ=(SIZ+RES(1))/6.0 367 - IF(SIZ.LT.0.0.OR.IFAIL1+IFAIL2+IFAIL3.NE.0)THEN 368 - PRINT *,' !!!!!! GASINP WARNING : Function gave'// 369 - - ' non-positive probability or arithmetic'// 370 - - ' error for size ',I,' ; set to 0.' 371 - CLSDIS(I)=0 372 - ELSE 373 - CLSDIS(I)=SIZ 374 - ENDIF 375 - 200 CONTINUE 376 - * Print number of algebra errors. 377 - CALL ALGERR 378 - * Finally accept the function and remember it was a function. 379 - GASOK(5)=.TRUE. 380 - CLSTYP='FUNCTION' 381 - * Release the instruction list. 382 - CALL ALGCLR(IENTRY) 383 - ENDIF 384 - ** Read a table. 385 - IF(NWORD.EQ.1.OR.OVERLP)THEN 386 - ICLS=0 387 - IFAIL=0 388 - * Output a prompt in interactive use. 389 - IF(STDSTR('INPUT')) 390 - - PRINT *,' ====== GASINP INPUT :'// 391 - - ' Please enter the cluster size distribution ;'// 392 - - ' terminate with a blank line.' 393 - CALL INPPRM('Cluster','ADD-NOPRINT') 394 - * Read the table line by line. 395 - 210 CONTINUE 396 - CALL INPWRD(NWORD) 397 - IF(NWORD.EQ.0)GOTO 230 398 - CALL INPSTR(1,1,STRING,NC) 399 - IF(STRING(1:1).EQ.'&')THEN 400 - PRINT *,' !!!!!! GASINP WARNING : You can not'// 401 - - ' leave the section here ; line ignored.' 402 - GOTO 210 403 - ENDIF 404 - * And read all probabilities within each line. 405 - DO 220 I=1,NWORD 406 - ICLS=ICLS+1 407 - IF(ICLS.GT.MXPAIR)GOTO 210 408 - CALL INPCHK(I,2,IFAIL1) 409 - CALL INPRDR(I,CLSR,0.0) 410 - IF(CLSR.LT.0.0)THEN 411 - CALL INPMSG(I,'Probabilities may not be < 0. ') 412 - CLSDIS(ICLS)=0 413 - ELSE 414 - CLSDIS(ICLS)=CLSR 415 - ENDIF 416 - 220 CONTINUE 417 - CALL INPERR 418 - GOTO 210 419 - * End of reading loop: check some correct data is present. 420 - 230 CONTINUE 421 - * If this was a pure table, set NCLS. 422 - IF(.NOT.OVERLP)NCLS=ICLS 423 - IF(NCLS.GT.MXPAIR)THEN 424 - PRINT *,' !!!!!! GASINP WARNING : Too many', 425 - - ' cluster size points ; excess ignored.' 426 - NCLS=MXPAIR 427 - GASOK(5)=.TRUE. 428 - IF(OVERLP)THEN 429 - CLSTYP='OVERLAP' 430 - ELSE 431 - CLSTYP='TABLE' 432 - ENDIF 433 - ELSEIF(NCLS.EQ.0)THEN 434 - PRINT *,' !!!!!! GASINP WARNING : The CLUSTER'// 435 - - ' statement is empty and is ignored.' 436 - ELSE 437 - GASOK(5)=.TRUE. 438 - IF(OVERLP)THEN 439 - CLSTYP='OVERLAP' 440 - ELSE 441 - CLSTYP='TABLE' 442 - ENDIF 443 - ENDIF 444 - * Reset the prompt. 445 - CALL INPPRM(' ','BACK-PRINT') 446 - ENDIF 447 - *** Call routine ETHANE to transfer data if ETHANE is a keyword. 448 - ELSEIF(INPCMP(1,'ETH#ANE').NE.0)THEN 449 - CALL ETHANE 450 - *** Set the extrapolation method. 451 - ELSEIF(INPCMP(1,'EXT#RAPOLATIONS').NE.0)THEN 452 - * Print the current settings if entered without argument. 453 - IF(NWORD.EQ.1)THEN 454 - WRITE(LUNOUT,'(/1X,A)') ' Currently, the'// 455 - - ' extraplation methods for large E/p, are'// 456 - - ' set as follows:' 457 - * Drift velocity for large E/p. 458 - IF(IVEXTR.EQ.0)THEN 459 - WRITE(LUNOUT,'(5X,A)') 'v || E: constant,' 460 - ELSEIF(IVEXTR.EQ.1)THEN 461 - WRITE(LUNOUT,'(5X,A)') 'v || E: linear,' 462 - ELSEIF(IVEXTR.EQ.2)THEN 463 - WRITE(LUNOUT,'(5X,A)') 'v || E: exponential,' 464 - ENDIF 465 - * Drift velocity ExB component large E/p. 466 - IF(IXEXTR.EQ.0)THEN 467 - WRITE(LUNOUT,'(5X,A)') 'v || Btrans: constant,' 1 518 P=GAS D=GASINP 6 PAGE 761 468 - ELSEIF(IXEXTR.EQ.1)THEN 469 - WRITE(LUNOUT,'(5X,A)') 'v || Btrans: linear,' 470 - ELSEIF(IXEXTR.EQ.2)THEN 471 - WRITE(LUNOUT,'(5X,A)') 'v || Btrans: exponential,' 472 - ENDIF 473 - * Drift velocity B component for large E/p. 474 - IF(IYEXTR.EQ.0)THEN 475 - WRITE(LUNOUT,'(5X,A)') 'v || ExB: constant,' 476 - ELSEIF(IYEXTR.EQ.1)THEN 477 - WRITE(LUNOUT,'(5X,A)') 'v || ExB: linear,' 478 - ELSEIF(IYEXTR.EQ.2)THEN 479 - WRITE(LUNOUT,'(5X,A)') 'v || ExB: exponential,' 480 - ENDIF 481 - * Lorentz angle for large E/p. 482 - IF(IWEXTR.EQ.0)THEN 483 - WRITE(LUNOUT,'(5X,A)') '(v,E) angle: constant,' 484 - ELSEIF(IWEXTR.EQ.1)THEN 485 - WRITE(LUNOUT,'(5X,A)') '(v,E) angle: linear,' 486 - ELSEIF(IWEXTR.EQ.2)THEN 487 - WRITE(LUNOUT,'(5X,A)') 488 - - '(v,E) angle: exponential,' 489 - ENDIF 490 - * Mobility for large E/p. 491 - IF(IMEXTR.EQ.0)THEN 492 - WRITE(LUNOUT,'(5X,A)') 'ion mobility: constant,' 493 - ELSEIF(IMEXTR.EQ.1)THEN 494 - WRITE(LUNOUT,'(5X,A)') 'ion mobility: linear,' 495 - ELSEIF(IMEXTR.EQ.2)THEN 496 - WRITE(LUNOUT,'(5X,A)') 497 - - 'ion mobility: exponential,' 498 - ENDIF 499 - * Longitudinal diffusion for large E/p. 500 - IF(IDEXTR.EQ.0)THEN 501 - WRITE(LUNOUT,'(5X,A)') 502 - - 'longitudinal diffusion: constant,' 503 - ELSEIF(IDEXTR.EQ.1)THEN 504 - WRITE(LUNOUT,'(5X,A)') 505 - - 'longitudinal diffusion: linear,' 506 - ELSEIF(IDEXTR.EQ.2)THEN 507 - WRITE(LUNOUT,'(5X,A)') 508 - - 'longitudinal diffusion: exponential,' 509 - ENDIF 510 - * Transverse diffusion for large E/p. 511 - IF(IOEXTR.EQ.0)THEN 512 - WRITE(LUNOUT,'(5X,A)') 513 - - 'transverse diffusion: constant,' 514 - ELSEIF(IOEXTR.EQ.1)THEN 515 - WRITE(LUNOUT,'(5X,A)') 516 - - 'transverse diffusion: linear,' 517 - ELSEIF(IOEXTR.EQ.2)THEN 518 - WRITE(LUNOUT,'(5X,A)') 519 - - 'transverse diffusion: exponential,' 520 - ENDIF 521 - * Townsend coefficient for large E/p. 522 - IF(IAEXTR.EQ.0)THEN 523 - WRITE(LUNOUT,'(5X,A)') 524 - - 'Townsend coefficient: constant,' 525 - ELSEIF(IAEXTR.EQ.1)THEN 526 - WRITE(LUNOUT,'(5X,A)') 527 - - 'Townsend coefficient: linear,' 528 - ELSEIF(IAEXTR.EQ.2)THEN 529 - WRITE(LUNOUT,'(5X,A)') 530 - - 'Townsend coefficient: exponential,' 531 - ENDIF 532 - * Attachment coefficient for large E/p. 533 - IF(IBEXTR.EQ.0)THEN 534 - WRITE(LUNOUT,'(5X,A)') 535 - - 'attachment coefficient: constant.' 536 - ELSEIF(IBEXTR.EQ.1)THEN 537 - WRITE(LUNOUT,'(5X,A)') 538 - - 'attachment coefficient: linear.' 539 - ELSEIF(IBEXTR.EQ.2)THEN 540 - WRITE(LUNOUT,'(5X,A)') 541 - - 'attachment coefficient: exponential.' 542 - ENDIF 543 - * Small values. 544 - WRITE(LUNOUT,'(/1X,A)') ' The extrapolations'// 545 - - ' to E/p below the first table point are done'// 546 - - ' as follows:' 547 - * Drift velocity for small E/p. 548 - IF(JVEXTR.EQ.0)THEN 549 - WRITE(LUNOUT,'(5X,A)') 'v || E: constant,' 550 - ELSEIF(JVEXTR.EQ.1)THEN 551 - WRITE(LUNOUT,'(5X,A)') 'v || E: linear,' 552 - ELSEIF(JVEXTR.EQ.2)THEN 553 - WRITE(LUNOUT,'(5X,A)') 'v || E: exponential,' 554 - ENDIF 555 - IF(JXEXTR.EQ.0)THEN 556 - WRITE(LUNOUT,'(5X,A)') 'v || Btrans: constant,' 557 - ELSEIF(JXEXTR.EQ.1)THEN 558 - WRITE(LUNOUT,'(5X,A)') 'v || Btrans: linear,' 559 - ELSEIF(JXEXTR.EQ.2)THEN 560 - WRITE(LUNOUT,'(5X,A)') 'v || Btrans: exponential,' 561 - ENDIF 562 - IF(JYEXTR.EQ.0)THEN 563 - WRITE(LUNOUT,'(5X,A)') 'v || ExB: constant,' 564 - ELSEIF(JYEXTR.EQ.1)THEN 565 - WRITE(LUNOUT,'(5X,A)') 'v || ExB: linear,' 566 - ELSEIF(JYEXTR.EQ.2)THEN 567 - WRITE(LUNOUT,'(5X,A)') 'v || ExB: exponential,' 568 - ENDIF 569 - * Lorentz angle for small E/p. 570 - IF(JWEXTR.EQ.0)THEN 571 - WRITE(LUNOUT,'(5X,A)') '(v,E) angle: constant,' 572 - ELSEIF(JWEXTR.EQ.1)THEN 573 - WRITE(LUNOUT,'(5X,A)') '(v,E) angle: linear,' 1 518 P=GAS D=GASINP 7 PAGE 762 574 - ELSEIF(JWEXTR.EQ.2)THEN 575 - WRITE(LUNOUT,'(5X,A)') 576 - - '(v,E) angle: exponential,' 577 - ENDIF 578 - * Ion mobility for small E/p. 579 - IF(JMEXTR.EQ.0)THEN 580 - WRITE(LUNOUT,'(5X,A)') 'ion mobility: constant,' 581 - ELSEIF(JMEXTR.EQ.1)THEN 582 - WRITE(LUNOUT,'(5X,A)') 'ion mobility: linear,' 583 - ELSEIF(JMEXTR.EQ.2)THEN 584 - WRITE(LUNOUT,'(5X,A)') 585 - - 'ion mobility: exponential,' 586 - ENDIF 587 - * Longitudinal diffusion for small E/p. 588 - IF(JDEXTR.EQ.0)THEN 589 - WRITE(LUNOUT,'(5X,A)') 590 - - 'longitudinal diffusion: constant,' 591 - ELSEIF(JDEXTR.EQ.1)THEN 592 - WRITE(LUNOUT,'(5X,A)') 593 - - 'longitudinal diffusion: linear,' 594 - ELSEIF(JDEXTR.EQ.2)THEN 595 - WRITE(LUNOUT,'(5X,A)') 596 - - 'longitudinal diffusion: exponential,' 597 - ENDIF 598 - * Transverse diffusion for small E/p. 599 - IF(JOEXTR.EQ.0)THEN 600 - WRITE(LUNOUT,'(5X,A)') 601 - - 'transverse diffusion: constant,' 602 - ELSEIF(JOEXTR.EQ.1)THEN 603 - WRITE(LUNOUT,'(5X,A)') 604 - - 'transverse diffusion: linear,' 605 - ELSEIF(JOEXTR.EQ.2)THEN 606 - WRITE(LUNOUT,'(5X,A)') 607 - - 'transverse diffusion: exponential,' 608 - ENDIF 609 - * Townsend coefficient for small E/p. 610 - IF(JAEXTR.EQ.0)THEN 611 - WRITE(LUNOUT,'(5X,A)') 612 - - 'Townsend coefficient: constant,' 613 - ELSEIF(JAEXTR.EQ.1)THEN 614 - WRITE(LUNOUT,'(5X,A)') 615 - - 'Townsend coefficient: linear,' 616 - ELSEIF(JAEXTR.EQ.2)THEN 617 - WRITE(LUNOUT,'(5X,A)') 618 - - 'Townsend coefficient: exponential,' 619 - ENDIF 620 - * Attachment coefficient for small E/p. 621 - IF(JBEXTR.EQ.0)THEN 622 - WRITE(LUNOUT,'(5X,A)') 623 - - 'attachment coefficient: constant.' 624 - ELSEIF(JBEXTR.EQ.1)THEN 625 - WRITE(LUNOUT,'(5X,A)') 626 - - 'attachment coefficient: linear.' 627 - ELSEIF(JBEXTR.EQ.2)THEN 628 - WRITE(LUNOUT,'(5X,A)') 629 - - 'attachment coefficient: exponential.' 630 - ENDIF 631 - * Number of points used for the extrapolations. 632 - IF(IVEXTR.EQ.0.OR. 633 - - IXEXTR.EQ.0.OR.IYEXTR.EQ.0.OR. 634 - - IAEXTR.EQ.0.OR.IBEXTR.EQ.0.OR. 635 - - IMEXTR.EQ.0.OR.IWEXTR.EQ.0.OR. 636 - - IDEXTR.EQ.0.OR.IOEXTR.EQ.0.OR. 637 - - JVEXTR.EQ.0.OR.JDEXTR.EQ.0.OR. 638 - - JXEXTR.EQ.0.OR.JYEXTR.EQ.0.OR. 639 - - JAEXTR.EQ.0.OR.JBEXTR.EQ.0.OR. 640 - - JMEXTR.EQ.0.OR.JWEXTR.EQ.0.OR. 641 - - JOEXTR.EQ.0) 642 - - WRITE(LUNOUT,'(/1X,A/)') 643 - - ' Constant extrapolations use the last point.' 644 - IF(IVEXTR.GT.0.OR. 645 - - IXEXTR.GT.0.OR.IYEXTR.GT.0.OR. 646 - - IAEXTR.GT.0.OR.IBEXTR.GT.0.OR. 647 - - IMEXTR.GT.0.OR.IWEXTR.GT.0.OR. 648 - - IDEXTR.GT.0.OR.IOEXTR.GT.0.OR. 649 - - JVEXTR.GT.0.OR.JDEXTR.GT.0.OR. 650 - - JXEXTR.GT.0.OR.JYEXTR.GT.0.OR. 651 - - JAEXTR.GT.0.OR.JBEXTR.GT.0.OR. 652 - - JMEXTR.GT.0.OR.JWEXTR.GT.0.OR. 653 - - JOEXTR.GT.0) 654 - - WRITE(LUNOUT,'(/1X,A/)') 655 - - ' Linear and exponential extrapolations are'// 656 - - ' based on the last 2 points.' 657 - WRITE(LUNOUT,'('' '')') 658 - ENDIF 659 - * Read the string if there are arguments. 660 - INEXT=2 661 - DO 710 I=2,NWORD 662 - IF(I.LT.INEXT)GOTO 710 663 - IF(I+1.GT.NWORD)THEN 664 - CALL INPMSG(I,'The method should be specified') 665 - GOTO 710 666 - ELSEIF(INPCMP(I+1,'C#ONSTANT').NE.0)THEN 667 - IEXTRR=0 668 - INEXT=I+2 669 - ELSEIF(INPCMP(I+1,'E#XPONENTIALLY').NE.0)THEN 670 - IEXTRR=2 671 - INEXT=I+2 672 - ELSEIF(INPCMP(I+1,'L#INEARLY').NE.0)THEN 673 - IEXTRR=1 674 - INEXT=I+2 675 - ELSE 676 - CALL INPMSG(I,'Valid method not specified. ') 677 - CALL INPMSG(I+1,'Unknown extrapolation method. ') 678 - GOTO 710 679 - ENDIF 1 518 P=GAS D=GASINP 8 PAGE 763 680 - IF(INPCMP(I,'H#IGH-DR#IFT-#VELOCITY')+ 681 - - INPCMP(I,'DR#IFT-#VELOCITY').NE.0)THEN 682 - IVEXTR=IEXTRR 683 - ELSEIF(INPCMP(I,'H#IGH-DI#FFUSION-#COEFFICIENT')+ 684 - - INPCMP(I,'DI#FFUSION-#COEFFICIENT')+ 685 - - INPCMP(I,'H#IGH-LONG#ITUDINAL-'// 686 - - 'DI#FFUSION-#COEFFICIENT')+ 687 - - INPCMP(I,'LONG#ITUDINAL-'// 688 - - 'DI#FFUSION-#COEFFICIENT').NE.0)THEN 689 - IDEXTR=IEXTRR 690 - ELSEIF(INPCMP(I,'H#IGH-TRANS#VERSE-'// 691 - - 'DI#FFUSION-#COEFFICIENT')+ 692 - - INPCMP(I,'TRANS#VERSE-'// 693 - - 'DI#FFUSION-#COEFFICIENT').NE.0)THEN 694 - IOEXTR=IEXTRR 695 - ELSEIF(INPCMP(I,'H#IGH-LOR#ENTZ-#ANGLE')+ 696 - - INPCMP(I,'LOR#ENTZ-#ANGLE').NE.0)THEN 697 - IWEXTR=IEXTRR 698 - ELSEIF(INPCMP(I,'H#IGH-T#OWNSEND-#COEFFICIENT')+ 699 - - INPCMP(I,'T#OWNSEND-#COEFFICIENT').NE.0)THEN 700 - IAEXTR=IEXTRR 701 - ELSEIF(INPCMP(I,'H#IGH-A#TTACHMENT-#COEFFICIENT')+ 702 - - INPCMP(I,'A#TTACHMENT-#COEFFICIENT').NE.0)THEN 703 - IBEXTR=IEXTRR 704 - ELSEIF(INPCMP(I,'H#IGH-ION-MOB#ILITY')+ 705 - - INPCMP(I,'ION-MOB#ILITY').NE.0)THEN 706 - IMEXTR=IEXTRR 707 - ELSEIF(INPCMP(I,'L#OW-DR#IFT-#VELOCITY').NE.0)THEN 708 - JVEXTR=IEXTRR 709 - ELSEIF(INPCMP(I,'L#OW-DI#FFUSION-#COEFFICIENT')+ 710 - - INPCMP(I,'L#OW-LONG#ITUDINAL-'// 711 - - 'DI#FFUSION-#COEFFICIENT').NE.0)THEN 712 - JDEXTR=IEXTRR 713 - ELSEIF(INPCMP(I,'L#OW-TRANS#VERSE-'// 714 - - 'DI#FFUSION-#COEFFICIENT').NE.0)THEN 715 - JOEXTR=IEXTRR 716 - ELSEIF(INPCMP(I,'L#OW-LOR#ENTZ-#ANGLE').NE.0)THEN 717 - JWEXTR=IEXTRR 718 - ELSEIF(INPCMP(I,'L#OW-T#OWNSEND-#COEFFICIENT').NE.0)THEN 719 - JAEXTR=IEXTRR 720 - ELSEIF(INPCMP(I,'L#OW-A#TTACHMENT-#COEFFICIENT').NE.0)THEN 721 - JBEXTR=IEXTRR 722 - ELSEIF(INPCMP(I,'L#OW-ION-MOB#ILITY').NE.0)THEN 723 - JMEXTR=IEXTRR 724 - ELSE 725 - CALL INPMSG(I,'Unknown object to extrapolate.') 726 - ENDIF 727 - 710 CONTINUE 728 - CALL INPERR 729 - *** Set the interpolation method. 730 - ELSEIF(INPCMP(1,'INT#ERPOLATIONS').NE.0)THEN 731 - * Print the current settings if entered without argument. 732 - IF(NWORD.EQ.1)THEN 733 - WRITE(LUNOUT,'(/1X,A)') 734 - - ' Currently the interpolation methods'// 735 - - ' are chosen as follows:' 736 - * Drift velocity. 737 - IF(IVMETH.EQ.0)THEN 738 - WRITE(LUNOUT,'(5X,''v || E: Cubic splines,'')') 739 - ELSE 740 - WRITE(LUNOUT,'(5X,''v || E: Newton'', 741 - - '' interpolation of order'',I3,'','')') 742 - - IVMETH 743 - ENDIF 744 - IF(IXMETH.EQ.0)THEN 745 - WRITE(LUNOUT,'(5X,''v || Btrans: Cubic'', 746 - - '' splines,'')') 747 - ELSE 748 - WRITE(LUNOUT,'(5X,''v || Btrans: Newton'', 749 - - '' interpolation of order'',I3,'','')') 750 - - IXMETH 751 - ENDIF 752 - IF(IYMETH.EQ.0)THEN 753 - WRITE(LUNOUT,'(5X,''v || ExB: Cubic'', 754 - - '' splines,'')') 755 - ELSE 756 - WRITE(LUNOUT,'(5X,''v || ExB: Newton'', 757 - - '' interpolation of order'',I3,'','')') 758 - - IYMETH 759 - ENDIF 760 - * Lorentz angle. 761 - IF(IWMETH.EQ.0)THEN 762 - WRITE(LUNOUT,'(5X,''(v,E) angle: Cubic'', 763 - - '' splines,'')') 764 - ELSE 765 - WRITE(LUNOUT,'(5X,''(v,E) angle: Newton'', 766 - - '' interpolation of order'',I3,'','')') 767 - - IWMETH 768 - ENDIF 769 - * Ion mobility. 770 - IF(IMMETH.EQ.0)THEN 771 - WRITE(LUNOUT,'(5X,''ion mobility: Cubic'', 772 - - '' splines,'')') 773 - ELSE 774 - WRITE(LUNOUT,'(5X,''ion mobility: Newton'', 775 - - '' interpolation of order'',I3,'','')') 776 - - IMMETH 777 - ENDIF 778 - * Longitudinal diffusion. 779 - IF(IDMETH.EQ.0)THEN 780 - WRITE(LUNOUT,'(5X,''longitudinal diffusion:'', 781 - - '' Cubic splines,'')') 782 - ELSE 783 - WRITE(LUNOUT,'(5X,''longitudinal diffusion:'', 784 - - '' Newton interpolation of order'',I3, 785 - - '','')') IDMETH 1 518 P=GAS D=GASINP 9 PAGE 764 786 - ENDIF 787 - * Transverse diffusion. 788 - IF(IOMETH.EQ.0)THEN 789 - WRITE(LUNOUT,'(5X,''transverse diffusion:'', 790 - - '' Cubic splines,'')') 791 - ELSE 792 - WRITE(LUNOUT,'(5X,''transverse diffusion:'', 793 - - '' Newton interpolation of order'',I3, 794 - - '','')') IOMETH 795 - ENDIF 796 - * Townsend coefficient. 797 - IF(IAMETH.EQ.0)THEN 798 - WRITE(LUNOUT,'(5X,''Townsend coefficient:'', 799 - - '' Cubic splines,'')') 800 - ELSE 801 - WRITE(LUNOUT,'(5X,''Townsend coefficient:'', 802 - - '' Newton interpolation of order'',I3, 803 - - '','')') IAMETH 804 - ENDIF 805 - * Attachment coefficient. 806 - IF(IBMETH.EQ.0)THEN 807 - WRITE(LUNOUT,'(5X,''attachment coefficient:'', 808 - - '' Cubic splines.'')') 809 - ELSE 810 - WRITE(LUNOUT,'(5X,''attachment coefficient:'', 811 - - '' Newton interpolation of order'',I3, 812 - - ''.'')') IBMETH 813 - ENDIF 814 - WRITE(LUNOUT,'('' '')') 815 - ENDIF 816 - * Read the string if there are arguments. 817 - INEXT=2 818 - DO 720 I=2,NWORD 819 - IF(I.LT.INEXT)GOTO 720 820 - IF(I+1.GT.NWORD)THEN 821 - CALL INPMSG(I,'The method should be specified') 822 - GOTO 720 823 - ELSEIF(INPCMP(I+1,'SPL#INES').NE.0)THEN 824 - IMETHR=0 825 - INEXT=I+2 826 - ELSEIF(INPCMP(I+1,'LIN#EAR').NE.0)THEN 827 - IMETHR=1 828 - INEXT=I+2 829 - ELSEIF(INPCMP(I+1,'QUA#DRATIC').NE.0)THEN 830 - IMETHR=2 831 - INEXT=I+2 832 - ELSEIF(INPCMP(I+1,'CUB#IC').NE.0)THEN 833 - IMETHR=3 834 - INEXT=I+2 835 - ELSEIF(INPCMP(I+1,'NEW#TON-#POLYNOMIALS').NE.0)THEN 836 - IF(NWORD.LT.I+2.OR.INPTYP(I+2).NE.1)THEN 837 - IMETHR=2 838 - INEXT=I+2 839 - ELSE 840 - CALL INPCHK(I+2,1,IFAIL1) 841 - CALL INPRDI(I+2,IMETHR,2) 842 - IF(IMETHR.LT.1)THEN 843 - CALL INPMSG(I+2, 844 - - 'The order must be 1 or larger.') 845 - IMETHR=2 846 - ENDIF 847 - INEXT=I+3 848 - ENDIF 849 - ELSE 850 - CALL INPMSG(I,'Not followed by a method. ') 851 - CALL INPMSG(I+1,'Unknown interpolation method. ') 852 - INEXT=I+2 853 - GOTO 720 854 - ENDIF 855 - IF(INPCMP(I,'DR#IFT-#VELOCITY').NE.0)THEN 856 - IVMETH=IMETHR 857 - ELSEIF(INPCMP(I,'LOR#ENTZ-#ANGLE').NE.0)THEN 858 - IWMETH=IMETHR 859 - ELSEIF(INPCMP(I,'ION-MOB#ILITY').NE.0)THEN 860 - IMMETH=IMETHR 861 - ELSEIF(INPCMP(I,'DI#FFUSION-#COEFFICIENT')+ 862 - - INPCMP(I,'LONG#ITUDINAL-'// 863 - - 'DI#FFUSION-#COEFFICIENT').NE.0)THEN 864 - IDMETH=IMETHR 865 - ELSEIF(INPCMP(I,'TRANS#VERSE-'// 866 - - 'DI#FFUSION-#COEFFICIENT').NE.0)THEN 867 - IOMETH=IMETHR 868 - ELSEIF(INPCMP(I,'T#OWNSEND-#COEFFICIENT').NE.0)THEN 869 - IAMETH=IMETHR 870 - ELSEIF(INPCMP(I,'A#TTACHMENT-#COEFFICIENT').NE.0)THEN 871 - IBMETH=IMETHR 872 - ELSE 873 - CALL INPMSG(I,'Unknown object to interpolate.') 874 - ENDIF 875 - 720 CONTINUE 876 - CALL INPERR 877 - *** Call routine ISOBUT to transfer data if ISOBUTANE is a keyword. 878 - ELSEIF(INPCMP(1,'ISO#BUTANE').NE.0)THEN 879 - CALL ISOBUT 880 - *** Call routine METHAN to transfer data if METHANE is a keyword. 881 - ELSEIF(INPCMP(1,'MET#HANE').NE.0)THEN 882 - CALL METHAN 883 - *** Set GAS-ID if this is a keyword. 884 - ELSEIF(INPCMP(1,'GAS-ID#ENTIFIER').NE.0)THEN 885 - IF(NWORD.EQ.1.AND.GASID.EQ.' ')THEN 886 - WRITE(LUNOUT,'(2X/''The gas identification has'', 887 - - '' not yet been set.''/)') 888 - ELSEIF(NWORD.EQ.1)THEN 889 - WRITE(LUNOUT,'(2X/''The current gas identification'', 890 - - '' is: '',A/)') GASID 891 - ELSE 1 518 P=GAS D=GASINP 10 PAGE 765 892 - CALL INPSTR(2,2,STRING,NC) 893 - IF(NC.GT.80)PRINT *,' !!!!!! GASINP WARNING : The'// 894 - - ' gas identifier is truncated to 80 characters.' 895 - GASID=STRING(1:MIN(NC,80)) 896 - ENDIF 897 - *** Read the gas from dataset, if GET is a keyword. 898 - ELSEIF(INPCMP(1,'GET').NE.0)THEN 899 - CALL GASGET(IFAIL1) 900 - IF(IFAIL1.NE.0)CALL GASINT 901 - *** Heed gas mixing. 902 - ELSEIF(INPCMP(1,'HEED').NE.0)THEN 903 - CALL GASHEE(IFAIL1) 904 - *** Gas mixing. 905 - ELSEIF(INPCMP(1,'MIX').NE.0)THEN 906 - CALL GASMIX 907 - *** Magboltz gas mixing. 908 - ELSEIF(INPCMP(1,'MAGBOLTZ').NE.0)THEN 909 - CALL GASBMC(IFAIL1) 910 - *** Identify the options if OPTION is a keyword. 911 - ELSEIF(INPCMP(1,'OPT#IONS').NE.0)THEN 912 - IF(NWORD.EQ.1)PRINT 1050,LGASPL,LGASPR 913 - DO 400 I=2,NWORD 914 - * Check for gas plot options. 915 - IF(INPCMP(I,'NOG#AS-PL#OT').NE.0)THEN 916 - LGASPL=.FALSE. 917 - ELSEIF(INPCMP(I,'G#AS-PL#OT').NE.0)THEN 918 - LGASPL=.TRUE. 919 - * Check for gas print options. 920 - ELSEIF(INPCMP(I,'NOG#AS-PR#INT').NE.0)THEN 921 - LGASPR=.FALSE. 922 - ELSEIF(INPCMP(I,'G#AS-PR#INT').NE.0)THEN 923 - LGASPR=.TRUE. 924 - * Option is not known. 925 - ELSE 926 - CALL INPMSG(I,'The option is not known. ') 927 - ENDIF 928 - 400 CONTINUE 929 - CALL INPERR 930 - *** Find the gas-parameter setting instructions. 931 - ELSEIF(INPCMP(1,'PAR#AMETERS').NE.0)THEN 932 - IF(NWORD.LT.3)WRITE(LUNOUT,'('' CURRENT SETTINGS OF'', 933 - - '' SOME GAS PARAMETERS: ''// 934 - - '' Number of protons in one molecule : '',F5.0/ 935 - - '' Atomic number of the gas : '',F5.0/ 936 - - '' Density : '',E10.3, 937 - - '' [g/cm3]''// 938 - - '' Average number of clusters per cm : '',F10.2/ 939 - - '' Most probable energy loss per cm : '',F10.2, 940 - - '' [eV/cm]''/ 941 - - '' Energy needed for one ion pair : '',F10.2, 942 - - '' [eV]''// 943 - - '' Longitudinal ion diffusion : '',F10.3, 944 - - '' [cm for 1 cm of drift]''/ 945 - - '' Transverse ion diffusion : '',F10.3, 946 - - '' [cm for 1 cm of drift]'')') 947 - - A,Z,RHO,CMEAN,EMPROB,EPAIR,DLION,DTION 948 - DO 500 I=2,NWORD-1,2 949 - IF(INPCMP(I,'A').NE.0)THEN 950 - CALL INPCHK(I+1,2,IFAIL1) 951 - CALL INPRDR(I+1,A,-1.0) 952 - GASOK(5)=.TRUE. 953 - CLSTYP='LANDAU' 954 - IF(A.LE.0.0.AND.IFAIL1.EQ.0) 955 - - CALL INPMSG(I+1,'The atomic number must be > 0.') 956 - ELSEIF(INPCMP(I,'Z').NE.0)THEN 957 - CALL INPCHK(I+1,2,IFAIL1) 958 - CALL INPRDR(I+1,Z,-1.0) 959 - GASOK(5)=.TRUE. 960 - CLSTYP='LANDAU' 961 - IF(Z.LE.0.0.AND.IFAIL1.EQ.0) 962 - - CALL INPMSG(I+1,'The nuclear charge is not > 0.') 963 - ELSEIF(INPCMP(I,'E#NERGY-M#OST-#PROBABLE')+ 964 - - INPCMP(I,'M#OST-PR#OBABLE-E#NERGY-#LOSS').NE.0)THEN 965 - CALL INPCHK(I+1,2,IFAIL1) 966 - CALL INPRDR(I+1,EMPROB,-1.0) 967 - GASOK(5)=.TRUE. 968 - CLSTYP='LANDAU' 969 - IF(EMPROB.LE.0.0.AND.IFAIL1.EQ.0) 970 - - CALL INPMSG(I+1,'The energy loss should be > 0.') 971 - ELSEIF(INPCMP(I,'ME#AN').NE.0.OR. 972 - - INPCMP(I,'N-#MEAN').NE.0)THEN 973 - CALL INPCHK(I+1,2,IFAIL1) 974 - CALL INPRDR(I+1,CMEAN,-1.0) 975 - GASOK(5)=.TRUE. 976 - IF(CMEAN.LE.0.0.AND.IFAIL1.EQ.0) 977 - - CALL INPMSG(I+1,'The cluster spacing is not > 0') 978 - ELSEIF(INPCMP(I,'P#AIR-C#REATION-#ENERGY')+ 979 - - INPCMP(I,'E#NERGY-P#AIR').NE.0)THEN 980 - CALL INPCHK(I+1,2,IFAIL1) 981 - CALL INPRDR(I+1,EPAIR,-1.0) 982 - GASOK(5)=.TRUE. 983 - CLSTYP='LANDAU' 984 - IF(EPAIR.LE.0.0.AND.IFAIL1.EQ.0) 985 - - CALL INPMSG(I+1,'The pair energy should be > 0.') 986 - ELSEIF(INPCMP(I,'R#HO').NE.0.OR. 987 - - INPCMP(I,'D#ENSITY').NE.0)THEN 988 - CALL INPCHK(I+1,2,IFAIL1) 989 - CALL INPRDR(I+1,RHO,-1.0) 990 - GASOK(5)=.TRUE. 991 - CLSTYP='LANDAU' 992 - IF(RHO.LE.0.0.AND.IFAIL1.EQ.0) 993 - - CALL INPMSG(I+1,'The density should be > 0. ') 994 - ELSEIF(INPCMP(I,'TR#ANSVERSE-ION-DIFF#USION').NE.0)THEN 995 - CALL INPCHK(I+1,2,IFAIL1) 996 - CALL INPRDR(I+1,DIONR,-1.0) 997 - IF(DIONR.LT.0.0.AND.IFAIL1.EQ.0)THEN 1 518 P=GAS D=GASINP 11 PAGE 766 998 - CALL INPMSG(I+1,'The diffusion should be > 0. ') 999 - ELSEIF(DIONR.GE.0)THEN 1000 - DTION=DIONR 1001 - ENDIF 1002 - ELSEIF(INPCMP(I,'LONG#ITUDINAL-ION-DIFF#USION').NE.0)THEN 1003 - CALL INPCHK(I+1,2,IFAIL1) 1004 - CALL INPRDR(I+1,DIONR,-1.0) 1005 - IF(DIONR.LT.0.0.AND.IFAIL1.EQ.0)THEN 1006 - CALL INPMSG(I+1,'The diffusion should be > 0. ') 1007 - ELSEIF(DIONR.GE.0)THEN 1008 - DLION=DIONR 1009 - ENDIF 1010 - ELSEIF(INPCMP(I,'ION-DIFF#USION').NE.0)THEN 1011 - CALL INPCHK(I+1,2,IFAIL1) 1012 - CALL INPRDR(I+1,DIONR,-1.0) 1013 - IF(DIONR.LT.0.0.AND.IFAIL1.EQ.0)THEN 1014 - CALL INPMSG(I+1,'The diffusion should be > 0. ') 1015 - ELSEIF(DIONR.GE.0)THEN 1016 - DTION=DIONR 1017 - DLION=DIONR 1018 - ENDIF 1019 - ELSE 1020 - CALL INPMSG(I,'The keyword is not known. ') 1021 - CALL INPMSG(I+1,'See the preceding message. ') 1022 - ENDIF 1023 - 500 CONTINUE 1024 - * Check for an extra keyword. 1025 - IF(NWORD.EQ.2*INT(REAL(NWORD)/2.0).AND.NWORD.GT.1) 1026 - - CALL INPMSG(NWORD,'Extra keyword cannot be used. ') 1027 - CALL INPERR 1028 - *** If PRESSURE is a keyword, find the pressure. 1029 - ELSEIF(INPCMP(1,'PR#ESSURE').NE.0)THEN 1030 - IF(NWORD.EQ.1)THEN 1031 - CALL OUTFMT(PGAS,2,STRAUX,NCAUX,'LEFT') 1032 - WRITE(LUNOUT,'('' The pressure of the gas is '', 1033 - - A,'' Torr.'')') STRAUX(1:NCAUX) 1034 - ELSEIF(NWORD.EQ.2.OR.NWORD.EQ.3)THEN 1035 - IF(NWORD.EQ.3)THEN 1036 - CALL INPSTR(3,3,UNIT,NCUNIT) 1037 - ELSE 1038 - UNIT='TORR' 1039 - NCUNIT=4 1040 - ENDIF 1041 - CALL INPCHK(2,2,IFAIL1) 1042 - CALL INPRDR(2,PGASRR,760.0) 1043 - CALL UNITS(PGASRR,UNIT(1:NCUNIT),PGASR,'TORR',IFAIL2) 1044 - IF(IFAIL2.NE.0)THEN 1045 - CALL INPMSG(3,'Not a valid pressure unit.') 1046 - ELSEIF(PGASR.LE.0.0.AND.IFAIL1.EQ.0)THEN 1047 - CALL INPMSG(2,'The pressure must be positive.') 1048 - IFAIL1=1 1049 - ELSE 1050 - PGAS=PGASR 1051 - ENDIF 1052 - CALL INPERR 1053 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! GASINP WARNING : The', 1054 - - ' PRESSURE statement is ignored.' 1055 - ELSE 1056 - PRINT *,' !!!!!! GASINP WARNING : PRESSURE takes', 1057 - - ' a single argument ; excess ignored.' 1058 - ENDIF 1059 - *** The RESET instruction. 1060 - ELSEIF(INPCMP(1,'RES#ET')+INPCMP(1,'DEL#ETE').NE.0)THEN 1061 - DO 60 I=2,NWORD 1062 - * Drift velocity. 1063 - IF(INPCMP(I,'DR#IFT-#VELOCITY').NE.0)THEN 1064 - GASOK(1)=.FALSE. 1065 - GASOK(9)=.FALSE. 1066 - GASOK(10)=.FALSE. 1067 - IVEXTR=1 1068 - JVEXTR=0 1069 - IVMETH=2 1070 - IXEXTR=1 1071 - JXEXTR=0 1072 - IXMETH=2 1073 - IYEXTR=1 1074 - JYEXTR=0 1075 - IYMETH=2 1076 - * Ion mobility. 1077 - ELSEIF(INPCMP(I,'ION-MOB#ILITY')+ 1078 - - INPCMP(I,'MOB#ILITY').NE.0)THEN 1079 - GASOK(2)=.FALSE. 1080 - IMEXTR=1 1081 - JMEXTR=0 1082 - IMMETH=2 1083 - * Diffusion. 1084 - ELSEIF(INPCMP(I,'LONG#ITUDINAL-DIFF#USION').NE.0)THEN 1085 - GASOK(3)=.FALSE. 1086 - IDEXTR=1 1087 - JDEXTR=0 1088 - IDMETH=2 1089 - ELSEIF(INPCMP(I,'TRANS#VERSE-DIFF#USION').NE.0)THEN 1090 - GASOK(8)=.FALSE. 1091 - IOEXTR=1 1092 - JOEXTR=0 1093 - IOMETH=2 1094 - ELSEIF(INPCMP(I,'DIFF#USION').NE.0)THEN 1095 - GASOK(8)=.FALSE. 1096 - IOEXTR=1 1097 - JOEXTR=0 1098 - IOMETH=2 1099 - GASOK(3)=.FALSE. 1100 - IDEXTR=1 1101 - JDEXTR=0 1102 - IDMETH=2 1103 - * Townsend coefficients. 1 518 P=GAS D=GASINP 12 PAGE 767 1104 - ELSEIF(INPCMP(I,'TOWN#SEND-#COEFFICIENTS').NE.0)THEN 1105 - GASOK(4)=.FALSE. 1106 - IAEXTR=1 1107 - JAEXTR=0 1108 - IAMETH=2 1109 - * Clustering data. 1110 - ELSEIF(INPCMP(I,'CLUST#ERING-#DATA').NE.0)THEN 1111 - GASOK(5)=.FALSE. 1112 - HEEDOK=.FALSE. 1113 - NCLS=0 1114 - CLSTYP='NOT SET' 1115 - FCNCLS=' ' 1116 - NFCLS=1 1117 - A=0 1118 - Z=0 1119 - EMPROB=0 1120 - EPAIR=0 1121 - RHO=0 1122 - CMEAN=0 1123 - * Attachment coefficients. 1124 - ELSEIF(INPCMP(I,'ATT#ACHMENT-#COEFFICIENTS').NE.0)THEN 1125 - GASOK(6)=.FALSE. 1126 - IBEXTR=1 1127 - JBEXTR=0 1128 - IBMETH=2 1129 - * Lorentz angle. 1130 - ELSEIF(INPCMP(I,'LOR#ENTZ-#ANGLES').NE.0)THEN 1131 - GASOK(7)=.FALSE. 1132 - IWEXTR=1 1133 - JWEXTR=0 1134 - IWMETH=2 1135 - * Gas identifier. 1136 - ELSEIF(INPCMP(I,'GAS-ID#ENTIFIER').NE.0)THEN 1137 - GASID=' ' 1138 - * All tables. 1139 - ELSEIF(INPCMP(I,'TAB#LES').NE.0)THEN 1140 - NGAS=0 1141 - TAB2D=.FALSE. 1142 - GASOK(1)=.FALSE. 1143 - GASOK(2)=.FALSE. 1144 - GASOK(3)=.FALSE. 1145 - GASOK(4)=.FALSE. 1146 - GASOK(6)=.FALSE. 1147 - GASOK(7)=.FALSE. 1148 - GASOK(8)=.FALSE. 1149 - GASOK(9)=.FALSE. 1150 - GASOK(10)=.FALSE. 1151 - FCNTAB=' ' 1152 - NFTAB=1 1153 - IVEXTR=1 1154 - IXEXTR=1 1155 - IYEXTR=1 1156 - IDEXTR=1 1157 - IOEXTR=1 1158 - IAEXTR=1 1159 - IBEXTR=1 1160 - IMEXTR=1 1161 - IWEXTR=1 1162 - JVEXTR=0 1163 - JXEXTR=0 1164 - JYEXTR=0 1165 - JDEXTR=0 1166 - JOEXTR=0 1167 - JAEXTR=0 1168 - JBEXTR=0 1169 - JMEXTR=0 1170 - JWEXTR=0 1171 - IVMETH=2 1172 - IXMETH=2 1173 - IYMETH=2 1174 - IDMETH=2 1175 - IOMETH=2 1176 - IAMETH=2 1177 - IBMETH=2 1178 - IMMETH=2 1179 - IWMETH=2 1180 - * All the rest is not known. 1181 - ELSE 1182 - CALL INPMSG(I,'Is not known, can not be reset') 1183 - ENDIF 1184 - 60 CONTINUE 1185 - * Reset everything. 1186 - IF(NWORD.EQ.1)CALL GASINT 1187 - * Dump error messages. 1188 - CALL INPERR 1189 - *** Read gas table if TABLE is a keyword. 1190 - ELSEIF(INPCMP(1,'TAB#LE').NE.0)THEN 1191 - * Initialize the various pointers: the function data. 1192 - NFTAB=1 1193 - FCNTAB=' ' 1194 - IFCN=0 1195 - * The table data. 1196 - ITAB=0 1197 - IDIFF=0 1198 - ITRANS=0 1199 - IDRIFT=0 1200 - IVB=0 1201 - IVEXB=0 1202 - IEP=0 1203 - ITOWN=0 1204 - IATT=0 1205 - IMOBIL=0 1206 - ILOREN=0 1207 - * Table type. 1208 - TAB2D=.FALSE. 1209 - * E range. 1 518 P=GAS D=GASINP 13 PAGE 768 1210 - IRANGE=0 1211 - EPMIN=100.0/PGAS 1212 - EPMAX=100000.0/PGAS 1213 - EPLOG=.TRUE. 1214 - NGAS=20 1215 - * E-B angles. 1216 - IF(MAGOK)THEN 1217 - BANGMN=0 1218 - BANGMX=PI/2 1219 - NBANG=4 1220 - ELSE 1221 - BANGMN=PI/2 1222 - BANGMX=PI/2 1223 - NBANG=1 1224 - ENDIF 1225 - * B field magnitude. 1226 - IF(MAGOK)THEN 1227 - IF(ABS((BFMIN-BFMAX)*BSCALE).LT.0.0001)THEN 1228 - BTABMN=BFMIN*BSCALE 1229 - BTABMX=BFMAX*BSCALE 1230 - NBTAB=1 1231 - ELSE 1232 - BTABMN=BFMIN*BSCALE 1233 - BTABMX=BFMAX*BSCALE 1234 - NBTAB=6 1235 - ENDIF 1236 - ELSE 1237 - BTABMN=0 1238 - BTABMX=0 1239 - NBTAB=1 1240 - ENDIF 1241 - * Reset the relevant GASOK bits. 1242 - GASOK(1)=.FALSE. 1243 - GASOK(2)=.FALSE. 1244 - GASOK(3)=.FALSE. 1245 - GASOK(4)=.FALSE. 1246 - GASOK(6)=.FALSE. 1247 - GASOK(7)=.FALSE. 1248 - GASOK(8)=.FALSE. 1249 - GASOK(9)=.FALSE. 1250 - GASOK(10)=.FALSE. 1251 - ** Flag the words. 1252 - DO 600 I=1,NWORD+3 1253 - IF(I.GT.NWORD)THEN 1254 - FLAG(I)=.TRUE. 1255 - ELSE 1256 - IF(INPCMP(I,'E/P')+ 1257 - - INPCMP(I,'A#TTACHMENT-#COEFFICIENT')+ 1258 - - INPCMP(I,'DI#FFUSION-#COEFFICIENT')+ 1259 - - INPCMP(I,'LONG#ITUDINAL-'// 1260 - - 'DI#FFUSION-#COEFFICIENT')+ 1261 - - INPCMP(I,'TRANS#VERSE-'// 1262 - - 'DI#FFUSION-#COEFFICIENT')+ 1263 - - INPCMP(I,'DUM#MY')+ 1264 - - INPCMP(I,'DR#IFT-#VELOCITY')+ 1265 - - INPCMP(I,'E-VEL#OCITY')+ 1266 - - INPCMP(I,'B#TRANSVERSE-VEL#OCITY')+ 1267 - - INPCMP(I,'EXB-VEL#OCITY')+ 1268 - - INPCMP(I,'LOR#ENTZ-#ANGLE')+ 1269 - - INPCMP(I,'ION-MOB#ILITY')+ 1270 - - INPCMP(I,'T#OWNSEND-#COEFFICIENT')+ 1271 - - INPCMP(I,'N-E/P')+INPCMP(I,'E/P-R#ANGE')+ 1272 - - INPCMP(I,'LIN#EAR-#E/P-#SCALE')+ 1273 - - INPCMP(I,'LOG#ARITHMIC-#E/P-#SCALE')+ 1274 - - INPCMP(I,'N-B')+INPCMP(I,'B-R#ANGE')+ 1275 - - INPCMP(I,'B-F#IELD')+ 1276 - - INPCMP(I,'N-ANG#LE')+INPCMP(I,'ANG#LE-R#ANGE')+ 1277 - - INPCMP(I,'ANG#LE').NE.0)THEN 1278 - FLAG(I)=.TRUE. 1279 - ELSE 1280 - FLAG(I)=.FALSE. 1281 - ENDIF 1282 - ENDIF 1283 - 600 CONTINUE 1284 - ** Read the command string, segment by segment. 1285 - INEXT=2 1286 - OK=.TRUE. 1287 - DO 610 I=2,NWORD 1288 - IF(I.LT.INEXT)GOTO 610 1289 - * Skip dummy fields. 1290 - IF(INPCMP(I,'DUM#MY').NE.0)THEN 1291 - IF(FLAG(I+1))THEN 1292 - ITAB=ITAB+1 1293 - INEXT=I+1 1294 - ELSE 1295 - INEXT=I+2 1296 - ENDIF 1297 - * Check for E/p. 1298 - ELSEIF(INPCMP(I,'E/P').NE.0)THEN 1299 - IF(IEP.NE.0)THEN 1300 - CALL INPMSG(I,'Has already been entered. ') 1301 - OK=.FALSE. 1302 - ELSE 1303 - IF(FLAG(I+1))THEN 1304 - ITAB=ITAB+1 1305 - IEP=ITAB 1306 - INEXT=I+1 1307 - ELSEIF(I.LT.NWORD)THEN 1308 - CALL INPMSG(I, 1309 - - 'E/p cannot be a function. ') 1310 - OK=.FALSE. 1311 - ENDIF 1312 - ENDIF 1313 - * Check for the attachment coefficient. 1314 - ELSEIF(INPCMP(I,'A#TTACHMENT-#COEFFICIENT').NE.0)THEN 1315 - IF(IATT.NE.0)THEN 1 518 P=GAS D=GASINP 14 PAGE 769 1316 - CALL INPMSG(I,'Has already been entered. ') 1317 - OK=.FALSE. 1318 - ELSE 1319 - IF(FLAG(I+1))THEN 1320 - ITAB=ITAB+1 1321 - IATT=ITAB 1322 - ELSEIF(I.LT.NWORD)THEN 1323 - IFCN=IFCN+1 1324 - IATT=-IFCN 1325 - CALL INPSTR(I+1,I+1,STRING,NC) 1326 - FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' 1327 - NFTAB=NFTAB+NC+1 1328 - INEXT=I+2 1329 - ENDIF 1330 - GASOK(6)=.TRUE. 1331 - ENDIF 1332 - * Check for a longitudinal diffusion coefficient. 1333 - ELSEIF(INPCMP(I,'DI#FFUSION-#COEFFICIENT')+ 1334 - - INPCMP(I,'LONG#ITUDINAL-'// 1335 - - 'DI#FFUSION-#COEFFICIENT').NE.0)THEN 1336 - IF(IDIFF.NE.0)THEN 1337 - CALL INPMSG(I,'Has already been entered. ') 1338 - OK=.FALSE. 1339 - ELSE 1340 - IF(FLAG(I+1))THEN 1341 - ITAB=ITAB+1 1342 - IDIFF=ITAB 1343 - ELSEIF(I+1.LE.NWORD)THEN 1344 - IFCN=IFCN+1 1345 - IDIFF=-IFCN 1346 - CALL INPSTR(I+1,I+1,STRING,NC) 1347 - FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' 1348 - NFTAB=NFTAB+NC+1 1349 - INEXT=I+2 1350 - ENDIF 1351 - GASOK(3)=.TRUE. 1352 - ENDIF 1353 - * Check for a transverse diffusion coefficient. 1354 - ELSEIF(INPCMP(I,'TRANS#VERSE-'// 1355 - - 'DI#FFUSION-#COEFFICIENT').NE.0)THEN 1356 - IF(ITRANS.NE.0)THEN 1357 - CALL INPMSG(I,'Has already been entered. ') 1358 - OK=.FALSE. 1359 - ELSE 1360 - IF(FLAG(I+1))THEN 1361 - ITAB=ITAB+1 1362 - ITRANS=ITAB 1363 - ELSEIF(I+1.LE.NWORD)THEN 1364 - IFCN=IFCN+1 1365 - ITRANS=-IFCN 1366 - CALL INPSTR(I+1,I+1,STRING,NC) 1367 - FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' 1368 - NFTAB=NFTAB+NC+1 1369 - INEXT=I+2 1370 - ENDIF 1371 - GASOK(8)=.TRUE. 1372 - ENDIF 1373 - * Check for a drift velocity terms. 1374 - ELSEIF(INPCMP(I,'DR#IFT-#VELOCITY')+ 1375 - - INPCMP(I,'E-VEL#OCITY').NE.0)THEN 1376 - IF(IDRIFT.NE.0)THEN 1377 - CALL INPMSG(I,'Has already been entered. ') 1378 - OK=.FALSE. 1379 - ELSE 1380 - IF(FLAG(I+1))THEN 1381 - ITAB=ITAB+1 1382 - IDRIFT=ITAB 1383 - ELSEIF(I.LT.NWORD)THEN 1384 - IFCN=IFCN+1 1385 - IDRIFT=-IFCN 1386 - CALL INPSTR(I+1,I+1,STRING,NC) 1387 - FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' 1388 - NFTAB=NFTAB+NC+1 1389 - INEXT=I+2 1390 - ENDIF 1391 - GASOK(1)=.TRUE. 1392 - ENDIF 1393 - ELSEIF(INPCMP(I,'B#TRANSVERSE-VEL#OCITY')+ 1394 - - INPCMP(I,'B#TRANSVERSAL-VEL#OCITY').NE.0)THEN 1395 - IF(.NOT.MAGOK)THEN 1396 - CALL INPMSG(I,'There is no magnetic field.') 1397 - OK=.FALSE. 1398 - ELSEIF(IVB.NE.0)THEN 1399 - CALL INPMSG(I,'Has already been entered. ') 1400 - OK=.FALSE. 1401 - ELSE 1402 - IF(FLAG(I+1))THEN 1403 - ITAB=ITAB+1 1404 - IVB=ITAB 1405 - ELSEIF(I.LT.NWORD)THEN 1406 - IFCN=IFCN+1 1407 - IVB=-IFCN 1408 - CALL INPSTR(I+1,I+1,STRING,NC) 1409 - FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' 1410 - NFTAB=NFTAB+NC+1 1411 - INEXT=I+2 1412 - ENDIF 1413 - GASOK(9)=.TRUE. 1414 - ENDIF 1415 - ELSEIF(INPCMP(I,'EXB-VEL#OCITY').NE.0)THEN 1416 - IF(.NOT.MAGOK)THEN 1417 - CALL INPMSG(I,'There is no magnetic field.') 1418 - OK=.FALSE. 1419 - ELSEIF(IVEXB.NE.0)THEN 1420 - CALL INPMSG(I,'Has already been entered. ') 1421 - OK=.FALSE. 1 518 P=GAS D=GASINP 15 PAGE 770 1422 - ELSE 1423 - IF(FLAG(I+1))THEN 1424 - ITAB=ITAB+1 1425 - IVEXB=ITAB 1426 - ELSEIF(I.LT.NWORD)THEN 1427 - IFCN=IFCN+1 1428 - IVEXB=-IFCN 1429 - CALL INPSTR(I+1,I+1,STRING,NC) 1430 - FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' 1431 - NFTAB=NFTAB+NC+1 1432 - INEXT=I+2 1433 - ENDIF 1434 - GASOK(10)=.TRUE. 1435 - ENDIF 1436 - * Check for the Lorentz angle. 1437 - ELSEIF(INPCMP(I,'LOR#ENTZ-#ANGLE').NE.0)THEN 1438 - IF(.NOT.MAGOK)THEN 1439 - CALL INPMSG(I,'There is no magnetic field.') 1440 - OK=.FALSE. 1441 - ELSEIF(ILOREN.NE.0)THEN 1442 - CALL INPMSG(I,'Has already been entered.') 1443 - OK=.FALSE. 1444 - ELSE 1445 - IF(FLAG(I+1))THEN 1446 - ITAB=ITAB+1 1447 - ILOREN=ITAB 1448 - ELSEIF(I.LT.NWORD)THEN 1449 - IFCN=IFCN+1 1450 - ILOREN=-IFCN 1451 - CALL INPSTR(I+1,I+1,STRING,NC) 1452 - FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' 1453 - NFTAB=NFTAB+NC+1 1454 - INEXT=I+2 1455 - ENDIF 1456 - GASOK(7)=.TRUE. 1457 - ENDIF 1458 - * Check for the mobility. 1459 - ELSEIF(INPCMP(I,'ION-MOB#ILITY').NE.0)THEN 1460 - IF(IMOBIL.NE.0)THEN 1461 - CALL INPMSG(I,'Has already been entered. ') 1462 - OK=.FALSE. 1463 - ELSE 1464 - IF(FLAG(I+1))THEN 1465 - ITAB=ITAB+1 1466 - IMOBIL=ITAB 1467 - ELSEIF(I.LT.NWORD)THEN 1468 - IFCN=IFCN+1 1469 - IMOBIL=-IFCN 1470 - CALL INPSTR(I+1,I+1,STRING,NC) 1471 - FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' 1472 - NFTAB=NFTAB+NC+1 1473 - INEXT=I+2 1474 - ENDIF 1475 - GASOK(2)=.TRUE. 1476 - ENDIF 1477 - * Check for the Townsend coefficient. 1478 - ELSEIF(INPCMP(I,'T#OWNSEND-#COEFFICIENT').NE.0)THEN 1479 - IF(ITOWN.NE.0)THEN 1480 - CALL INPMSG(I,'Has already been entered. ') 1481 - OK=.FALSE. 1482 - ELSE 1483 - IF(FLAG(I+1))THEN 1484 - ITAB=ITAB+1 1485 - ITOWN=ITAB 1486 - ELSEIF(I.LT.NWORD)THEN 1487 - IFCN=IFCN+1 1488 - ITOWN=-IFCN 1489 - CALL INPSTR(I+1,I+1,STRING,NC) 1490 - FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' 1491 - NFTAB=NFTAB+NC+1 1492 - INEXT=I+2 1493 - ENDIF 1494 - GASOK(4)=.TRUE. 1495 - ENDIF 1496 - * Look for the E/P-RANGE parameter. 1497 - ELSEIF(INPCMP(I,'E/P-R#ANGE').NE.0)THEN 1498 - IF(FLAG(I+1))THEN 1499 - CALL INPMSG(I,'RANGE should have 2 arguments.') 1500 - OK=.FALSE. 1501 - INEXT=I+1 1502 - ELSEIF(.NOT.FLAG(I+1).AND.FLAG(I+2))THEN 1503 - CALL INPMSG(I,'RANGE should have 2 arguments.') 1504 - CALL INPMSG(I+1,'See the previous message. ') 1505 - INEXT=I+2 1506 - OK=.FALSE. 1507 - ELSE 1508 - CALL INPCHK(I+1,2,IFAIL1) 1509 - CALL INPCHK(I+2,2,IFAIL2) 1510 - CALL INPRDR(I+1,EPMINR,0.1) 1511 - CALL INPRDR(I+2,EPMAXR,100.0) 1512 - IF(IFAIL1.EQ.0.AND.EPMINR.LE.0.0)THEN 1513 - CALL INPMSG(I+1, 1514 - - 'The minimum E/P should be > 0.') 1515 - OK=.FALSE. 1516 - ELSEIF(IFAIL2.EQ.0.AND.EPMAXR.LE.0.0)THEN 1517 - CALL INPMSG(I+1, 1518 - - 'The maximum E/P should be > 0.') 1519 - OK=.FALSE. 1520 - ELSE 1521 - IF(EPMINR.EQ.EPMAXR)THEN 1522 - CALL INPMSG(I+1, 1523 - - 'A zero range not is permitted.') 1524 - CALL INPMSG(I+2, 1525 - - 'A zero range not is permitted.') 1526 - OK=.FALSE. 1527 - ELSE 1 518 P=GAS D=GASINP 16 PAGE 771 1528 - EPMIN=MIN(EPMINR,EPMAXR) 1529 - EPMAX=MAX(EPMINR,EPMAXR) 1530 - IRANGE=1 1531 - ENDIF 1532 - ENDIF 1533 - INEXT=I+3 1534 - ENDIF 1535 - * Look for the N-E/P parameter. 1536 - ELSEIF(INPCMP(I,'N-E/P').NE.0)THEN 1537 - IF(FLAG(I+1))THEN 1538 - CALL INPMSG(I,'N should have one argument. ') 1539 - INEXT=I+1 1540 - OK=.FALSE. 1541 - ELSE 1542 - CALL INPCHK(I+1,1,IFAIL1) 1543 - CALL INPRDI(I+1,NGASR,20) 1544 - IF(IFAIL1.EQ.0.AND.NGASR.LE.1)THEN 1545 - CALL INPMSG(I+1, 1546 - - 'Number of gas points is < 2. ') 1547 - OK=.FALSE. 1548 - ELSEIF(IFAIL1.EQ.0.AND.NGASR.GT.MXLIST)THEN 1549 - CALL INPMSG(I+1, 1550 - - 'Number of gas points > MXLIST.') 1551 - OK=.FALSE. 1552 - ELSEIF(IFAIL1.EQ.0)THEN 1553 - NGAS=NGASR 1554 - IRANGE=1 1555 - ENDIF 1556 - INEXT=I+2 1557 - ENDIF 1558 - * Kind of E/p scale. 1559 - ELSEIF(INPCMP(I,'LIN#EAR-#E/P-#SCALE').NE.0)THEN 1560 - EPLOG=.FALSE. 1561 - ELSEIF(INPCMP(I,'LOG#ARITHMIC-#E/P-#SCALE').NE.0)THEN 1562 - EPLOG=.TRUE. 1563 - * Look for the B-RANGE parameter. 1564 - ELSEIF(INPCMP(I,'B-R#ANGE').NE.0)THEN 1565 - IF(FLAG(I+1))THEN 1566 - CALL INPMSG(I,'RANGE should have 2 arguments.') 1567 - INEXT=I+1 1568 - OK=.FALSE. 1569 - ELSEIF(.NOT.FLAG(I+1).AND.FLAG(I+2))THEN 1570 - CALL INPMSG(I,'RANGE should have 2 arguments.') 1571 - CALL INPMSG(I+1,'See the previous message. ') 1572 - INEXT=I+2 1573 - OK=.FALSE. 1574 - ELSE 1575 - CALL INPCHK(I+1,2,IFAIL1) 1576 - CALL INPCHK(I+2,2,IFAIL2) 1577 - CALL INPRDR(I+1,BTMINR,BTABMN/100) 1578 - CALL INPRDR(I+2,BTMAXR,BTABMX/100) 1579 - IF(IFAIL1.EQ.0.AND.BTMINR.LE.0.0)THEN 1580 - CALL INPMSG(I+1, 1581 - - 'The minimum B should be > 0.') 1582 - OK=.FALSE. 1583 - ELSEIF(IFAIL2.EQ.0.AND.BTMAXR.LE.0.0)THEN 1584 - CALL INPMSG(I+1, 1585 - - 'The maximum B should be > 0.') 1586 - OK=.FALSE. 1587 - ELSE 1588 - IF(BTMINR.EQ.BTMAXR)THEN 1589 - CALL INPMSG(I+1, 1590 - - 'A zero range not is permitted.') 1591 - CALL INPMSG(I+2, 1592 - - 'A zero range not is permitted.') 1593 - OK=.FALSE. 1594 - ELSE 1595 - BTABMN=100*MIN(BTMINR,BTMAXR) 1596 - BTABMX=100*MAX(BTMINR,BTMAXR) 1597 - TAB2D=.TRUE. 1598 - ENDIF 1599 - ENDIF 1600 - INEXT=I+3 1601 - ENDIF 1602 - * Look for the N-B parameter. 1603 - ELSEIF(INPCMP(I,'N-B').NE.0)THEN 1604 - IF(FLAG(I+1))THEN 1605 - CALL INPMSG(I,'N should have one argument. ') 1606 - INEXT=I+1 1607 - OK=.FALSE. 1608 - ELSE 1609 - CALL INPCHK(I+1,1,IFAIL1) 1610 - CALL INPRDI(I+1,NBTABR,NBTAB) 1611 - IF(IFAIL1.EQ.0.AND.NBTABR.LE.1)THEN 1612 - CALL INPMSG(I+1, 1613 - - 'Number of B fields is < 2. ') 1614 - OK=.FALSE. 1615 - ELSEIF(IFAIL1.EQ.0.AND.NBTABR.GT.MXBTAB)THEN 1616 - CALL INPMSG(I+1, 1617 - - 'Number of B fields > MXBTAB.') 1618 - OK=.FALSE. 1619 - ELSEIF(IFAIL1.EQ.0)THEN 1620 - NBTAB=NBTABR 1621 - TAB2D=.TRUE. 1622 - ENDIF 1623 - INEXT=I+2 1624 - ENDIF 1625 - * Look for the B-field keyword. 1626 - ELSEIF(INPCMP(I,'B-F#IELD').NE.0)THEN 1627 - CALL INPCHK(I+1,2,IFAIL1) 1628 - CALL INPRDR(I+1,BTMINR,(BTABMN+BTABMX)/200) 1629 - IF(IFAIL1.EQ.0.AND.NWORD.GE.I+1)THEN 1630 - IF(BTMINR.LT.0)THEN 1631 - CALL INPMSG(I+1,'B field is not > 0.') 1632 - OK=.FALSE. 1633 - ELSE 1 518 P=GAS D=GASINP 17 PAGE 772 1634 - BTABMN=100*BTMINR 1635 - BTABMX=100*BTMINR 1636 - NBTAB=1 1637 - TAB2D=.TRUE. 1638 - ENDIF 1639 - ELSE 1640 - CALL INPMSG(I,'Missing or invalid arguments. ') 1641 - OK=.FALSE. 1642 - ENDIF 1643 - INEXT=I+2 1644 - * Look for the ANGLE-RANGE parameter. 1645 - ELSEIF(INPCMP(I,'ANG#LE-R#ANGE').NE.0)THEN 1646 - IF(FLAG(I+1))THEN 1647 - CALL INPMSG(I,'RANGE should have 2 arguments.') 1648 - INEXT=I+1 1649 - OK=.FALSE. 1650 - ELSEIF(.NOT.FLAG(I+1).AND.FLAG(I+2))THEN 1651 - CALL INPMSG(I,'RANGE should have 2 arguments.') 1652 - CALL INPMSG(I+1,'See the previous message. ') 1653 - INEXT=I+2 1654 - OK=.FALSE. 1655 - ELSE 1656 - CALL INPCHK(I+1,2,IFAIL1) 1657 - CALL INPCHK(I+2,2,IFAIL2) 1658 - CALL INPRDR(I+1,BAMINR,180*BANGMN/PI) 1659 - CALL INPRDR(I+2,BAMAXR,180*BANGMX/PI) 1660 - IF(IFAIL1.EQ.0.AND. 1661 - - (BAMINR.LT.0.OR.BAMINR.GT.90.0))THEN 1662 - CALL INPMSG(I+1, 1663 - - 'Min angle not in range [0,90].') 1664 - OK=.FALSE. 1665 - ELSEIF(IFAIL2.EQ.0.AND. 1666 - - (BAMAXR.LT.0.OR.BAMAXR.GT.90.0))THEN 1667 - CALL INPMSG(I+1, 1668 - - 'Max angle not in range [0,90].') 1669 - OK=.FALSE. 1670 - ELSE 1671 - IF(BAMINR.EQ.BAMAXR)THEN 1672 - CALL INPMSG(I+1, 1673 - - 'A zero range not is permitted.') 1674 - CALL INPMSG(I+2, 1675 - - 'A zero range not is permitted.') 1676 - OK=.FALSE. 1677 - ELSE 1678 - BANGMN=PI*MIN(BAMINR,BAMAXR)/180 1679 - BANGMX=PI*MAX(BAMINR,BAMAXR)/180 1680 - TAB2D=.TRUE. 1681 - ENDIF 1682 - ENDIF 1683 - INEXT=I+3 1684 - ENDIF 1685 - * Look for the N-ANGLE parameter. 1686 - ELSEIF(INPCMP(I,'N-ANG#LE').NE.0)THEN 1687 - IF(FLAG(I+1))THEN 1688 - CALL INPMSG(I,'N should have one argument. ') 1689 - INEXT=I+1 1690 - OK=.FALSE. 1691 - ELSE 1692 - CALL INPCHK(I+1,1,IFAIL1) 1693 - CALL INPRDI(I+1,NBANGR,NBANG) 1694 - IF(IFAIL1.EQ.0.AND.NBANGR.LE.1)THEN 1695 - CALL INPMSG(I+1, 1696 - - 'Number of angles is < 2. ') 1697 - OK=.FALSE. 1698 - ELSEIF(IFAIL1.EQ.0.AND.NBANGR.GT.MXBANG)THEN 1699 - CALL INPMSG(I+1, 1700 - - 'Number of angles > MXBANG.') 1701 - OK=.FALSE. 1702 - ELSEIF(IFAIL1.EQ.0)THEN 1703 - NBANG=NBANGR 1704 - TAB2D=.TRUE. 1705 - ENDIF 1706 - INEXT=I+2 1707 - ENDIF 1708 - * Look for the ANGLE keyword. 1709 - ELSEIF(INPCMP(I,'ANG#LE').NE.0)THEN 1710 - CALL INPCHK(I+1,2,IFAIL1) 1711 - CALL INPRDR(I+1,BAMINR,180*BANGMN/PI) 1712 - IF(IFAIL1.EQ.0.AND.NWORD.GE.I+1)THEN 1713 - IF(BAMINR.LT.0.OR.BAMINR.GT.90.0)THEN 1714 - CALL INPMSG(I+1,'Out of range [0,90].') 1715 - OK=.FALSE. 1716 - ELSE 1717 - BANGMN=PI*BAMINR/180 1718 - BANGMX=PI*BAMINR/180 1719 - NBANG=1 1720 - TAB2D=.TRUE. 1721 - ENDIF 1722 - ELSE 1723 - CALL INPMSG(I,'Missing or invalid arguments. ') 1724 - OK=.FALSE. 1725 - ENDIF 1726 - INEXT=I+2 1727 - * Unknown entry. 1728 - ELSE 1729 - CALL INPMSG(I,'Unknown table entry, ignored. ') 1730 - ITAB=ITAB+1 1731 - OK=.FALSE. 1732 - INEXT=I+1 1733 - ENDIF 1734 - * Next entry. 1735 - 610 CONTINUE 1736 - ** Dump the error messages. 1737 - CALL INPERR 1738 - * Check for B dependence in table. 1739 - IF(TAB2D.AND..NOT.MAGOK)THEN 1 518 P=GAS D=GASINP 18 PAGE 773 1740 - PRINT *,' !!!!!! GASINP WARNING : The table has'// 1741 - - ' a B dependence, but there is no B field;'// 1742 - - ' dependence reset.' 1743 - TAB2D=.FALSE. 1744 - OK=.FALSE. 1745 - ENDIF 1746 - ** Check whether we have to continue or not. 1747 - IF(JFAIL.EQ.2.AND..NOT.OK)THEN 1748 - PRINT *,' ###### GASINP ERROR : TABLE not'// 1749 - - ' executed because of the above errors.' 1750 - NGAS=0 1751 - GOTO 10 1752 - ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN 1753 - PRINT *,' ###### GASINP ERROR : Program terminated'// 1754 - - ' because of the above errors.' 1755 - NGAS=0 1756 - CALL QUIT 1757 - RETURN 1758 - ENDIF 1759 - ** Preset the OK flag again for the data processing. 1760 - OK=.TRUE. 1761 - ** Take care of defaults: no arguments provided. 1762 - IF(ITAB.EQ.0.AND.IFCN.EQ.0)THEN 1763 - IEP=1 1764 - IDRIFT=2 1765 - IVB=0 1766 - IVEXB=0 1767 - IDIFF=3 1768 - ITOWN=0 1769 - IATT=0 1770 - IMOBIL=0 1771 - ILOREN=0 1772 - ITRANS=0 1773 - ITAB=3 1774 - GASOK(1)=.TRUE. 1775 - GASOK(2)=.FALSE. 1776 - GASOK(3)=.TRUE. 1777 - GASOK(4)=.FALSE. 1778 - GASOK(6)=.FALSE. 1779 - GASOK(7)=.FALSE. 1780 - GASOK(8)=.FALSE. 1781 - GASOK(9)=.FALSE. 1782 - GASOK(10)=.FALSE. 1783 - ENDIF 1784 - * Table will follow: preset NGAS to 0. 1785 - IF(ITAB.NE.0)NGAS=0 1786 - * If there have not been any B or angle declarations, reset N. 1787 - IF(.NOT.TAB2D)THEN 1788 - NBTAB=1 1789 - NBANG=1 1790 - ENDIF 1791 - ** Warn if a RANGE or an N has been specified when not needed. 1792 - IF(IRANGE.NE.0.AND.(IEP.GT.0.OR. 1793 - - IDRIFT.GT.0.OR.IVB.GT.0.OR.IVEXB.GT.0.OR. 1794 - - IDIFF.GT.0.OR.ITOWN.GT.0.OR.IATT.GT.0.OR. 1795 - - IMOBIL.GT.0.OR.ILOREN.GT.0.OR.ITRANS.GT.0))THEN 1796 - PRINT *,' !!!!!! GASINP WARNING : RANGE and N'// 1797 - - ' ignored because a table is expected.' 1798 - OK=.FALSE. 1799 - ENDIF 1800 - ** Generate some debugging output. 1801 - IF(LDEBUG)THEN 1802 - WRITE(LUNOUT,'('' ++++++ GASINP DEBUG : TABLE '', 1803 - - ''debug output:''/26X,''Function: "'',A,''"''/26X, 1804 - - ''IEP='',I2,'', IDRIFT='',I2,'', IVB='',I2, 1805 - - '', IVEXB='',I2,'', IDIFF='',I2, 1806 - - '', ITOWN='',I2,'', IATT='',I2,'', IMOBIL='',I2, 1807 - - '', ILOREN='',I2,'', ITRANS='',I2)') 1808 - - FCNTAB(1:MAX(1,NFTAB-2)), 1809 - - IEP,IDRIFT,IVB,IVEXB,IDIFF,ITOWN,IATT, 1810 - - IMOBIL,ILOREN,ITRANS 1811 - WRITE(LUNOUT,'(26X,''EPMIN='',E10.3,'', EPMAX='',E10.3, 1812 - - '', NGAS='',I3)') EPMIN,EPMAX,NGAS 1813 - ENDIF 1814 - ** Check whether a function has been specified somewhere. 1815 - IENTRY=0 1816 - IF(IDRIFT.LT.0.OR.IVB.LT.0.OR.IVEXB.LT.0.OR. 1817 - - IDIFF.LT.0.OR.ITRANS.LT.0.OR.ITOWN.LT.0.OR. 1818 - - IATT.LT.0.OR.IMOBIL.LT.0.OR.ILOREN.LT.0)THEN 1819 - * Check for the presence of a function. 1820 - IF(NFTAB.LE.2)THEN 1821 - PRINT *,' !!!!!! GASINP WARNING : The function'// 1822 - - ' seems to be empty; rejected.' 1823 - NGAS=0 1824 - GOTO 10 1825 - ENDIF 1826 - * Remove the comma at the end of the string. 1827 - FCNTAB(NFTAB-1:NFTAB-1)=' ' 1828 - NFTAB=NFTAB-2 1829 - * Convert the string to an instruction list (via ALGEDT if @ appears). 1830 - IF(INDEX(FCNTAB(1:NFTAB),'@').NE.0)THEN 1831 - NRES=IFCN 1832 - CALL ALGEDT(VARTAB,7,IENTRY,USE,NRES) 1833 - ELSE 1834 - CALL ALGPRE(FCNTAB,NFTAB,VARTAB,7,NRES,USE,IENTRY, 1835 - - IFAIL1) 1836 - IF(IFAIL1.NE.0)THEN 1837 - PRINT *,' !!!!!! GASINP WARNING : Entries'// 1838 - - ' specified as functions are ignored:' 1839 - IF(IDRIFT.LT.0)PRINT *,' '// 1840 - - ' the drift velocity || E' 1841 - IF(IVB.LT.0)PRINT *,' '// 1842 - - ' the drift velocity || Btrans' 1843 - IF(IVEXB.LT.0)PRINT *,' '// 1844 - - ' the drift velocity || ExB' 1845 - IF(ILOREN.LT.0)PRINT *,' '// 1 518 P=GAS D=GASINP 19 PAGE 774 1846 - - ' the Lorentz angle' 1847 - IF(IDIFF.LT.0)PRINT *,' '// 1848 - - ' the longitudinal diffusion' 1849 - IF(ITRANS.LT.0)PRINT *,' '// 1850 - - ' the transverse diffusion' 1851 - IF(ITOWN.LT.0)PRINT *,' '// 1852 - - ' the Townsend coefficient' 1853 - IF(IATT.LT.0)PRINT *,' '// 1854 - - ' the attachment coefficient' 1855 - IF(IMOBIL.LT.0)PRINT *,' '// 1856 - - ' the ion mobility' 1857 - NGAS=0 1858 - CALL ALGCLR(IENTRY) 1859 - GOTO 10 1860 - ENDIF 1861 - ENDIF 1862 - IF(NRES.NE.IFCN)THEN 1863 - PRINT *,' !!!!!! GASINP WARNING : Number'// 1864 - - ' of functions being returned is wrong.' 1865 - NGAS=0 1866 - CALL ALGCLR(IENTRY) 1867 - GOTO 10 1868 - ENDIF 1869 - * Warn if the function does not depend explicitely on EP. 1870 - IF(.NOT.USE(1))PRINT *,' ------ GASINP MESSAGE : The'// 1871 - - ' function is independent of E/p, but accepted.' 1872 - * Ensure the function does not depend on B or angle if 1D. 1873 - IF((.NOT.TAB2D).AND.(USE(4).OR.USE(5)))THEN 1874 - PRINT *,' !!!!!! GASINP WARNING : The function'// 1875 - - ' depends on B or angle(E,B) but the table'// 1876 - - ' has no B part; rejected.' 1877 - NGAS=0 1878 - CALL ALGCLR(IENTRY) 1879 - GOTO 10 1880 - ENDIF 1881 - ENDIF 1882 - ** Read the cards if at least one item has been tabulated. 1883 - IF(IDRIFT.GT.0.OR.IVB.GT.0.OR.IVEXB.GT.0.OR. 1884 - - IDIFF.GT.0.OR.ITRANS.GT.0.OR.IMOBIL.GT.0.OR. 1885 - - ITOWN.GT.0.OR.IATT.GT.0.OR.ILOREN.GT.0.OR. 1886 - - IEP.GT.0)THEN 1887 - * Check that E/p has been specified. 1888 - IF(IEP.EQ.0)THEN 1889 - PRINT *,' !!!!!! GASINP WARNING : E/p has to be'// 1890 - - ' present in the table; table rejected.' 1891 - NGAS=0 1892 - IF(IENTRY.NE.0)CALL ALGCLR(IENTRY) 1893 - GOTO 10 1894 - ENDIF 1895 - * Prompt in interactive mode. 1896 - NGAS=0 1897 - IF(STDSTR('INPUT')) 1898 - - PRINT *,' ====== GASINP INPUT :'// 1899 - - ' Please enter the table, enter a'// 1900 - - ' blank line when ready.' 1901 - CALL INPPRM('Table','ADD-NOPRINT') 1902 - * And start an input loop. 1903 - 620 CONTINUE 1904 - CALL INPWRD(NWORD) 1905 - IF(NWORD.EQ.0)GOTO 660 1906 - CALL INPSTR(1,1,STRING,NC) 1907 - * Take appropriate action if a & is met. 1908 - IF(STRING(1:1).EQ.'&')THEN 1909 - PRINT *,' !!!!!! GASINP WARNING : You can not'// 1910 - - ' leave the section here ; line is ignored.' 1911 - GOTO 620 1912 - ENDIF 1913 - * Make sure each line contains the right number of items. 1914 - IF(NWORD.NE.ITAB)THEN 1915 - PRINT *,' !!!!!! GASINP WARNING : Gas tables'// 1916 - - ' must contain the number of items listed'// 1917 - - ' in the TABLE line.' 1918 - GOTO 620 1919 - ENDIF 1920 - * Preset error flag. 1921 - IFAIL1=0 1922 - * Read the items and check their syntax + validity. 1923 - NGAS=NGAS+1 1924 - DO 630 I=1,ITAB 1925 - CALL INPCHK(I,2,IFAIL2) 1926 - IF(IFAIL2.NE.0)IFAIL1=1 1927 - CALL INPRDR(I,DATAR,-1.0) 1928 - DO 631 J=1,NBANG 1929 - DO 632 K=1,NBTAB 1930 - IF(NGAS.LE.MXLIST.AND.IFAIL2.EQ.0)THEN 1931 - IF(I.EQ.IEP)THEN 1932 - EGAS(NGAS)=DATAR 1933 - ELSEIF(I.EQ.IDRIFT)THEN 1934 - VGAS(NGAS)=DATAR 1935 - VGAS2(NGAS,J,K)=DATAR 1936 - ELSEIF(I.EQ.IVB)THEN 1937 - XGAS(NGAS)=DATAR 1938 - XGAS2(NGAS,J,K)=DATAR 1939 - ELSEIF(I.EQ.IVEXB)THEN 1940 - YGAS(NGAS)=DATAR 1941 - YGAS2(NGAS,J,K)=DATAR 1942 - ELSEIF(I.EQ.ILOREN)THEN 1943 - IF(DATAR.LT.0.OR.DATAR.GT.90.0)THEN 1944 - PRINT *,' !!!!!! GASINP WARNING :'// 1945 - - ' Lorentz angle outside the'// 1946 - - ' range [0,90] degrees.' 1947 - IFAIL1=1 1948 - WGAS(NGAS)=0 1949 - ELSE 1950 - WGAS(NGAS)=PI*DATAR/180.0 1951 - ENDIF 1 518 P=GAS D=GASINP 20 PAGE 775 1952 - WGAS2(NGAS,J,K)=WGAS(NGAS) 1953 - ELSEIF(I.EQ.IDIFF)THEN 1954 - DGAS(NGAS)=DATAR 1955 - DGAS2(NGAS,J,K)=DATAR 1956 - ELSEIF(I.EQ.ITRANS)THEN 1957 - OGAS(NGAS)=DATAR 1958 - OGAS2(NGAS,J,K)=DATAR 1959 - ELSEIF(I.EQ.ITOWN)THEN 1960 - IF(DATAR.EQ.0)THEN 1961 - AGAS(NGAS)=-30 1962 - ELSEIF(DATAR.GT.0)THEN 1963 - AGAS(NGAS)=MAX(-30.0,LOG(DATAR)) 1964 - ELSE 1965 - PRINT *,' !!!!!! GASINP WARNING :'// 1966 - - ' Townsend coefficient < 0;'// 1967 - - ' data rejected.' 1968 - IFAIL1=1 1969 - AGAS(NGAS)=-30.0 1970 - ENDIF 1971 - AGAS2(NGAS,J,K)=AGAS(NGAS) 1972 - ELSEIF(I.EQ.IATT)THEN 1973 - IF(DATAR.EQ.0)THEN 1974 - BGAS(NGAS)=-30 1975 - ELSEIF(DATAR.GT.0)THEN 1976 - BGAS(NGAS)=MAX(-30.0,LOG(DATAR)) 1977 - ELSE 1978 - PRINT *,' !!!!!! GASINP WARNING :'// 1979 - - ' Attachment coefficient < 0;'// 1980 - - ' data rejected.' 1981 - IFAIL1=1 1982 - BGAS(NGAS)=-30.0 1983 - ENDIF 1984 - BGAS2(NGAS,J,K)=BGAS(NGAS) 1985 - ELSEIF(I.EQ.IMOBIL)THEN 1986 - MGAS(NGAS)=DATAR 1987 - MGAS2(NGAS,J,K)=DATAR 1988 - ENDIF 1989 - ENDIF 1990 - 632 CONTINUE 1991 - 631 CONTINUE 1992 - 630 CONTINUE 1993 - * Evaluate the function value, if needed. 1994 - IF(IDRIFT.LT.0.OR.IVB.LT.0.OR.IVEXB.LT.0.OR. 1995 - - IDIFF.LT.0.OR.ITRANS.LT.0.OR.ILOREN.LT.0.OR. 1996 - - ITOWN.LT.0.OR.IATT.LT.0.OR.IMOBIL.LT.0)THEN 1997 - DO 641 J=1,NBANG 1998 - IF(NBANG.GT.1)THEN 1999 - BANG(J)=BANGMN+REAL(J-1)*(BANGMX-BANGMN)/ 2000 - - REAL(NBANG-1) 2001 - ELSE 2002 - BANG(J)=(BANGMN+BANGMX)/2 2003 - ENDIF 2004 - DO 642 K=1,NBTAB 2005 - IF(NBTAB.GT.1)THEN 2006 - BTAB(K)=BTABMN+REAL(K-1)*(BTABMX-BTABMN)/ 2007 - - REAL(NBTAB-1) 2008 - ELSE 2009 - BTAB(K)=(BTABMN+BTABMX)/2 2010 - ENDIF 2011 - VAR(1)=EGAS(NGAS) 2012 - VAR(2)=BOLTZ 2013 - VAR(3)=ECHARG 2014 - VAR(4)=180*BANG(J)/PI 2015 - VAR(5)=BTAB(K)/100 2016 - VAR(6)=TGAS 2017 - VAR(7)=PGAS 2018 - MODVAR(1)=2 2019 - MODVAR(2)=2 2020 - MODVAR(3)=2 2021 - MODVAR(4)=2 2022 - MODVAR(5)=2 2023 - MODVAR(6)=2 2024 - MODVAR(7)=2 2025 - CALL ALGEXE(IENTRY,VAR,MODVAR,7, 2026 - - RES,MODRES,NRES,IFAIL2) 2027 - IF(IFAIL2.NE.0)THEN 2028 - PRINT *,' !!!!!! GASINP WARNING : Error'// 2029 - - ' evaluating the function.' 2030 - IFAIL1=1 2031 - ENDIF 2032 - DO 640 I=1,IFCN 2033 - IF(MODRES(I).NE.2)THEN 2034 - PRINT *,' !!!!!! GASINP WARNING : Function'// 2035 - - ' does not return a number.' 2036 - IFAIL1=1 2037 - RES(I)=0 2038 - ENDIF 2039 - IF(I.EQ.-IDRIFT)THEN 2040 - VGAS(NGAS)=RES(I) 2041 - VGAS2(NGAS,J,K)=RES(I) 2042 - ELSEIF(I.EQ.-IVB)THEN 2043 - XGAS(NGAS)=RES(I) 2044 - XGAS2(NGAS,J,K)=RES(I) 2045 - ELSEIF(I.EQ.-IVEXB)THEN 2046 - YGAS(NGAS)=RES(I) 2047 - YGAS2(NGAS,J,K)=RES(I) 2048 - ELSEIF(I.EQ.-ILOREN)THEN 2049 - IF(RES(I).LT.0.OR.RES(I).GT.90.0)THEN 2050 - PRINT *,' !!!!!! GASINP WARNING :'// 2051 - - ' Lorentz angle outside the'// 2052 - - ' range [0,90] degrees.' 2053 - IFAIL1=1 2054 - WGAS(NGAS)=0 2055 - ELSE 2056 - WGAS(NGAS)=PI*RES(I)/180.0 2057 - ENDIF 1 518 P=GAS D=GASINP 21 PAGE 776 2058 - WGAS2(NGAS,J,K)=WGAS(NGAS) 2059 - ELSEIF(I.EQ.-IDIFF)THEN 2060 - DGAS(NGAS)=RES(I) 2061 - DGAS2(NGAS,J,K)=RES(I) 2062 - ELSEIF(I.EQ.-ITRANS)THEN 2063 - OGAS(NGAS)=RES(I) 2064 - OGAS2(NGAS,J,K)=RES(I) 2065 - ELSEIF(I.EQ.-ITOWN)THEN 2066 - IF(RES(I).EQ.0)THEN 2067 - AGAS(NGAS)=-30.0 2068 - ELSEIF(RES(I).GT.0)THEN 2069 - AGAS(NGAS)=MAX(-30.0,LOG(RES(I))) 2070 - ELSE 2071 - AGAS(NGAS)=-30.0 2072 - PRINT *,' !!!!!! GASINP WARNING :'// 2073 - - ' Townsend coefficient < 0;'// 2074 - - ' data rejected.' 2075 - IFAIL1=1 2076 - ENDIF 2077 - AGAS2(NGAS,J,K)=AGAS(NGAS) 2078 - ELSEIF(I.EQ.-IATT)THEN 2079 - IF(RES(I).EQ.0)THEN 2080 - BGAS(NGAS)=-30.0 2081 - ELSEIF(RES(I).GT.0)THEN 2082 - BGAS(NGAS)=MAX(-30.0,LOG(RES(I))) 2083 - ELSE 2084 - BGAS(NGAS)=-30.0 2085 - PRINT *,' !!!!!! GASINP WARNING :'// 2086 - - ' Attachment coefficient < 0;'// 2087 - - ' data rejected.' 2088 - IFAIL1=1 2089 - ENDIF 2090 - BGAS2(NGAS,J,K)=BGAS(NGAS) 2091 - ELSEIF(I.EQ.-IMOBIL)THEN 2092 - MGAS(NGAS)=RES(I) 2093 - MGAS2(NGAS,J,K)=RES(I) 2094 - ENDIF 2095 - 640 CONTINUE 2096 - 642 CONTINUE 2097 - 641 CONTINUE 2098 - ENDIF 2099 - * Dump error messages. 2100 - CALL INPERR 2101 - IF(IFAIL1.NE.0)THEN 2102 - PRINT *,' !!!!!! GASINP WARNING : The input'// 2103 - - ' line is ignored, see preceding message.' 2104 - NGAS=NGAS-1 2105 - OK=.FALSE. 2106 - ENDIF 2107 - * Proceed with the next line. 2108 - GOTO 620 2109 - ** End of list, carry out a few checks. 2110 - 660 CONTINUE 2111 - * Reset the prompt. 2112 - CALL INPPRM(' ','BACK-PRINT') 2113 - * Warn if the table was empty. 2114 - IF(NGAS.LE.2)PRINT *,' !!!!!! GASINP WARNING : The'// 2115 - - ' gas table did not contain enough points (> 2).' 2116 - * Warn if parts of the table were omitted for lack of storage space. 2117 - IF(NGAS.GT.MXLIST)THEN 2118 - PRINT *,' !!!!!! GASINP WARNING : ',NGAS-MXLIST, 2119 - - ' data points could not be stored ; you'// 2120 - - ' could increase the MXLIST parameter.' 2121 - NGAS=MXLIST 2122 - OK=.FALSE. 2123 - ENDIF 2124 - ** If the table is presented as a pure function: 2125 - ELSEIF(IDRIFT.LT.0.OR.IVB.LT.0.OR.IVEXB.LT.0.OR. 2126 - - IDIFF.LT.0.OR.ITRANS.LT.0.OR.ILOREN.LT.0.OR. 2127 - - ITOWN.LT.0.OR.IATT.LT.0.OR.IMOBIL.LT.0)THEN 2128 - * Make the table using the function. 2129 - NNGAS=NGAS 2130 - DO 680 I=1,NNGAS 2131 - * Preset the error flag for this E/p. 2132 - IFAIL1=0 2133 - * Set E/p. 2134 - IF(EPLOG)THEN 2135 - EGAS(I)=EPMIN*(EPMAX/EPMIN)** 2136 - - (REAL(I-1)/REAL(NGAS-1)) 2137 - ELSE 2138 - EGAS(I)=EPMIN+(EPMAX-EPMIN)* 2139 - - (REAL(I-1)/REAL(NGAS-1)) 2140 - ENDIF 2141 - * Loop over angles and B field. 2142 - DO 681 J=1,NBANG 2143 - IF(NBANG.GT.1)THEN 2144 - BANG(J)=BANGMN+REAL(J-1)*(BANGMX-BANGMN)/ 2145 - - REAL(NBANG-1) 2146 - ELSE 2147 - BANG(J)=(BANGMN+BANGMX)/2 2148 - ENDIF 2149 - DO 682 K=1,NBTAB 2150 - IF(NBTAB.GT.1)THEN 2151 - BTAB(K)=BTABMN+REAL(K-1)*(BTABMX-BTABMN)/ 2152 - - REAL(NBTAB-1) 2153 - ELSE 2154 - BTAB(K)=(BTABMN+BTABMX)/2 2155 - ENDIF 2156 - * Evaluate the functions. 2157 - VAR(1)=EGAS(I) 2158 - VAR(2)=BOLTZ 2159 - VAR(3)=ECHARG 2160 - VAR(4)=180*BANG(J)/PI 2161 - VAR(5)=BTAB(K)/100 2162 - VAR(6)=TGAS 2163 - VAR(7)=PGAS 1 518 P=GAS D=GASINP 22 PAGE 777 2164 - MODVAR(1)=2 2165 - MODVAR(2)=2 2166 - MODVAR(3)=2 2167 - MODVAR(4)=2 2168 - MODVAR(5)=2 2169 - MODVAR(6)=2 2170 - MODVAR(7)=2 2171 - CALL ALGEXE(IENTRY,VAR,MODVAR,7,RES,MODRES,NRES,IFAIL2) 2172 - IF(IFAIL2.NE.0)THEN 2173 - PRINT *,' !!!!!! GASINP WARNING : Arithmetic'// 2174 - - ' error evaluating the function at E/p=', 2175 - - EGAS(I) 2176 - IFAIL1=1 2177 - ENDIF 2178 - * Assign the results. 2179 - DO 670 II=1,IFCN 2180 - IF(MODRES(II).NE.2)THEN 2181 - PRINT *,' !!!!!! GASINP WARNING : Function does'// 2182 - - ' not return a number for E/p=',EGAS(I) 2183 - IFAIL1=1 2184 - RES(II)=0 2185 - ENDIF 2186 - IF(II.EQ.-IDRIFT)THEN 2187 - VGAS(I)=RES(II) 2188 - VGAS2(I,J,K)=RES(II) 2189 - ELSEIF(II.EQ.-IVB)THEN 2190 - XGAS(I)=RES(II) 2191 - XGAS2(I,J,K)=RES(II) 2192 - ELSEIF(II.EQ.-IVEXB)THEN 2193 - YGAS(I)=RES(II) 2194 - YGAS2(I,J,K)=RES(II) 2195 - ELSEIF(II.EQ.-ILOREN)THEN 2196 - IF(RES(II).LT.0.OR.RES(II).GT.90.0)THEN 2197 - PRINT *,' !!!!!! GASINP WARNING : Lorentz'// 2198 - - ' angle outside the range [0,90]'// 2199 - - ' degrees for E/p=',EGAS(I) 2200 - IFAIL1=1 2201 - WGAS(I)=0 2202 - ELSE 2203 - WGAS(I)=PI*RES(II)/180.0 2204 - ENDIF 2205 - WGAS2(I,J,K)=WGAS(I) 2206 - ELSEIF(II.EQ.-IDIFF)THEN 2207 - DGAS(I)=RES(II) 2208 - DGAS2(I,J,K)=RES(II) 2209 - ELSEIF(II.EQ.-ITRANS)THEN 2210 - OGAS(I)=RES(II) 2211 - OGAS2(I,J,K)=RES(II) 2212 - ELSEIF(II.EQ.-ITOWN)THEN 2213 - IF(RES(II).EQ.0)THEN 2214 - AGAS(I)=-30.0 2215 - ELSEIF(RES(II).GT.0)THEN 2216 - AGAS(I)=MAX(-30.0,LOG(RES(II))) 2217 - ELSE 2218 - AGAS(I)=-30.0 2219 - PRINT *,' !!!!!! GASINP WARNING : Townsend'// 2220 - - ' coefficient < 0 for E/p=',EGAS(I) 2221 - IFAIL1=1 2222 - ENDIF 2223 - AGAS2(I,J,K)=AGAS(I) 2224 - ELSEIF(II.EQ.-IATT)THEN 2225 - IF(RES(II).EQ.0)THEN 2226 - BGAS(I)=-30.0 2227 - ELSEIF(RES(II).GT.0)THEN 2228 - BGAS(I)=MAX(-30.0,LOG(RES(II))) 2229 - ELSE 2230 - BGAS(I)=-30.0 2231 - PRINT *,' !!!!!! GASINP WARNING :'// 2232 - - ' Attachment coefficient < 0 for'// 2233 - - ' E/p=',EGAS(I) 2234 - IFAIL1=1 2235 - ENDIF 2236 - BGAS2(I,J,K)=BGAS(I) 2237 - ELSEIF(II.EQ.-IMOBIL)THEN 2238 - MGAS(I)=RES(II) 2239 - MGAS2(I,J,K)=RES(II) 2240 - ENDIF 2241 - 670 CONTINUE 2242 - * Next angle and B field. 2243 - 682 CONTINUE 2244 - 681 CONTINUE 2245 - * Check the errors for this E/p. 2246 - IF(IFAIL1.NE.0)THEN 2247 - PRINT *,' !!!!!! GASINP WARNING : The data'// 2248 - - ' for E/p=',EGAS(I),' is ignored, see'// 2249 - - ' preceding message.' 2250 - NGAS=NGAS-1 2251 - OK=.FALSE. 2252 - ENDIF 2253 - * Next E/p. 2254 - 680 CONTINUE 2255 - ENDIF 2256 - ** Release the algebra entry point, if used. 2257 - IF(IENTRY.NE.0)CALL ALGCLR(IENTRY) 2258 - ** Check whether we have to continue or not. 2259 - IF(JFAIL.EQ.2.AND..NOT.OK)THEN 2260 - PRINT *,' ###### GASINP ERROR : TABLE is'// 2261 - - ' rejected because of the above errors.' 2262 - NGAS=0 2263 - GOTO 10 2264 - ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN 2265 - PRINT *,' ###### GASINP ERROR : Program terminated'// 2266 - - ' because of the above errors.' 2267 - NGAS=0 2268 - CALL QUIT 2269 - RETURN 1 518 P=GAS D=GASINP 23 PAGE 778 2270 - ENDIF 2271 - *** If TEMPERATURE is a keyword, find the temperature. 2272 - ELSEIF(INPCMP(1,'TEMP#ERATURE').NE.0)THEN 2273 - IF(NWORD.EQ.1)THEN 2274 - CALL OUTFMT(TGAS,2,STRAUX,NCAUX,'LEFT') 2275 - WRITE(LUNOUT,'('' The temperature of the gas is '', 2276 - - A,'' K.'')') STRAUX(1:NCAUX) 2277 - ELSEIF(NWORD.EQ.2.OR.NWORD.EQ.3)THEN 2278 - IF(NWORD.EQ.3)THEN 2279 - CALL INPSTR(3,3,UNIT,NCUNIT) 2280 - ELSE 2281 - UNIT='K' 2282 - NCUNIT=1 2283 - ENDIF 2284 - CALL INPCHK(2,2,IFAIL1) 2285 - CALL INPRDR(2,TGASRR,300.0) 2286 - CALL UNITS(TGASRR,UNIT(1:NCUNIT),TGASR,'K',IFAIL2) 2287 - IF(IFAIL2.NE.0)THEN 2288 - CALL INPMSG(3,'Not a valid temperature unit.') 2289 - ELSEIF(TGASR.LE.0.0.AND.IFAIL1.EQ.0)THEN 2290 - CALL INPMSG(2,'The temperature is not > 0 K. ') 2291 - IFAIL1=1 2292 - ELSE 2293 - TGAS=TGASR 2294 - ENDIF 2295 - CALL INPERR 2296 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! GASINP WARNING : The', 2297 - - ' TEMPERATURE statement is ignored.' 2298 - ELSE 2299 - PRINT *,' !!!!!! GASINP WARNING : TEMPERATURE takes', 2300 - - ' a single argument ; statement ignored.' 2301 - ENDIF 2302 - *** If USER1 is a keyword call routine USER1 to transfer user gas data. 2303 - C ELSEIF(INPCMP(1,'US#ER-#GAS').NE.0)THEN 2304 - C CALL GASUSR abbreviation point in the keyword. 2305 - *** Call GASWRT to prepare writing the gas dataset. 2306 - ELSEIF(INPCMP(1,'WR#ITE').NE.0)THEN 2307 - CALL GASWRT(1) 2308 - LGASWR=.TRUE. 2309 - *** If normal intructions are used, it is not possible to get here. 2310 - ELSE 2311 - CALL INPSTR(1,1,STRING,NC) 2312 - PRINT *,' !!!!!! GASINP WARNING : '//STRING(1:NC)//' is'// 2313 - - ' not a valid instruction ; the line ignored.' 2314 - ENDIF 2315 - GOTO 10 2316 - END 519 GARFIELD ================================================== P=GAS D=GASINT 1 ============================ 0 + +DECK,GASINT. 1 - SUBROUTINE GASINT 2 - *----------------------------------------------------------------------- 3 - * GASINT - Initialises the gas data. 4 - * (Last changed on 9/ 3/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GASDATA. 9.- +SEQ,GASMIXDATA. 10 - INTEGER I,J,K 11 - *** Overall gas availability. 12 - GASSET=.FALSE. 13 - *** Gas bits. 14 - DO 10 I=1,14 15 - GASOK(I)=.FALSE. 16 - 10 CONTINUE 17 - *** Heed availability and Heed gas density. 18 - HEEDOK=.FALSE. 19 - GASDEN=0.0 20 - *** Initialise the tables. 21 - TAB2D=.FALSE. 22 - NGAS=0 23 - NBANG=1 24 - NBTAB=1 25 - DO 20 I=1,MXLIST 26 - EGAS(I)=0.0 27 - VGAS(I)=0.0 28 - XGAS(I)=0.0 29 - YGAS(I)=0.0 30 - DGAS(I)=0.0 31 - OGAS(I)=0.0 32 - AGAS(I)=0.0 33 - BGAS(I)=0.0 34 - MGAS(I)=0.0 35 - WGAS(I)=0.0 36 - CVGAS(I)=0.0 37 - CXGAS(I)=0.0 38 - CYGAS(I)=0.0 39 - CDGAS(I)=0.0 40 - COGAS(I)=0.0 41 - CAGAS(I)=0.0 42 - CBGAS(I)=0.0 43 - CMGAS(I)=0.0 44 - CWGAS(I)=0.0 45 - DO 30 J=1,MXBANG 46 - DO 40 K=1,MXBTAB 47 - VGAS2(I,J,K)=0.0 48 - XGAS2(I,J,K)=0.0 49 - YGAS2(I,J,K)=0.0 50 - DGAS2(I,J,K)=0.0 51 - OGAS2(I,J,K)=0.0 52 - AGAS2(I,J,K)=0.0 53 - BGAS2(I,J,K)=0.0 54 - MGAS2(I,J,K)=0.0 55 - WGAS2(I,J,K)=0.0 1 519 P=GAS D=GASINT 2 PAGE 779 56 - 40 CONTINUE 57 - 30 CONTINUE 58 - 20 CONTINUE 59 - *** Lower limits for alpha and eta. 60 - IATHR=1 61 - IBTHR=1 62 - *** Ion diffusions. 63 - DLION=0 64 - DTION=0 65 - *** Table function. 66 - FCNTAB=' ' 67 - NFTAB=1 68 - *** Gas identifier. 69 - GASID=' ' 70 - *** Extrapolation methods for small E/p. 71 - JVEXTR=0 72 - JXEXTR=0 73 - JYEXTR=0 74 - JDEXTR=0 75 - JOEXTR=0 76 - JAEXTR=0 77 - JBEXTR=0 78 - JMEXTR=0 79 - JWEXTR=0 80 - *** Extrapolation methods for large E/p. 81 - IVEXTR=1 82 - IXEXTR=1 83 - IYEXTR=1 84 - IDEXTR=1 85 - IOEXTR=1 86 - IAEXTR=1 87 - IBEXTR=1 88 - IMEXTR=1 89 - IWEXTR=1 90 - *** Interpolation methods. 91 - IVMETH=2 92 - IXMETH=2 93 - IYMETH=2 94 - IDMETH=2 95 - IOMETH=2 96 - IAMETH=2 97 - IBMETH=2 98 - IMMETH=2 99 - IWMETH=2 100 - *** Initialize the Landau data. 101 - A=0.0 102 - Z=0.0 103 - EMPROB=0.0 104 - CMEAN=0.0 105 - EPAIR=0.0 106 - RHO=0.0 107 - *** Initialise the cluster size distribution. 108 - FCNCLS=' ' 109 - NFCLS=1 110 - DO 50 I=1,MXPAIR 111 - CLSDIS(I)=0 112 - 50 CONTINUE 113 - CLSTYP='NOT SET' 114 - NCLS=0 115 - *** Initialise the plot types. 116 - DO 60 I=1,8 117 - GASOK(I) =.FALSE. 118 - GASOPT(I,1)=.TRUE. 119 - GASOPT(I,2)=.FALSE. 120 - GASOPT(I,3)=.TRUE. 121 - GASOPT(I,4)=.FALSE. 122 - GASRNG(I,1)=0 123 - GASRNG(I,2)=0 124 - 60 CONTINUE 125 - GASOPT(4,2)=.TRUE. 126 - GASOPT(5,1)=.FALSE. 127 - GASOPT(5,2)=.TRUE. 128 - *** Pressure and temperature. 129 - PGAS=760.0 130 - TGAS=300.0 131 - *** Initial data for the /GMXDAT/ common block. 132 - ESTEP=0.5 133 - END 520 GARFIELD ================================================== P=GAS D=GASMIX 1 ============================ 0 + +DECK,GASMIX. 1 - SUBROUTINE GASMIX 2 - *----------------------------------------------------------------------- 3 - * GASMIX - Calculates the drift velocity and diffusion coefficient 4 - * for various gas mixtures. 5 - * REFERENCES: G. Schultz, Thesis, Universite Louis Pasteur, 6 - * Strasbourg, No 1015 (1976). 7 - * G. Schultz and J. Gresser, NIM 151 (1978) 413-431. 8 - * (Last changed on 1/ 2/99.) 9 - *----------------------------------------------------------------------- 10.- +SEQ,DIMENSIONS. 11.- +SEQ,GASMIXDATA. 12.- +SEQ,GASDATA. 13.- +SEQ,CONSTANTS. 14.- +SEQ,PRINTPLOT. 15 - INTEGER INPCMP,INPTYP,MODVAR(MXVAR),MODRES(1) 16 - LOGICAL LDISPL,LOSSPL,LPTHPL,LCSPL,LTABPR,EPLOG,USE(MXVAR) 17 - REAL XPL(MXLIST),YPL1(MXLIST),YPL2(MXLIST),YPL3(MXLIST), 18 - - VAR(MXVAR),RES(1) 19 - DOUBLE PRECISION GASMG1,GASMG2,X(2),F0NORM,F0OK 20 - CHARACTER*(MXCHAR) STRMOB,STRTWN,STRATT 21 - CHARACTER*10 VARLIS(MXVAR) 22 - EXTERNAL INPCMP,INPTYP 23 - EXTERNAL FGAS1,FGAS2D,FGAS2N,FGAS2V,GASMG1,GASMG2 1 520 P=GAS D=GASMIX 2 PAGE 780 24-+ +SELF,IF=SAVE. 25 - SAVE LDISPL,LOSSPL,LPTHPL,LCSPL,LTABPR,EMIN,EMAX, 26 - - FRCRIT,EPMIN,EPMAX,EPLOG 0 27-+ +SELF. 28 - DATA LDISPL , LOSSPL , LPTHPL , LCSPL , LTABPR 29 - - /.TRUE. , .FALSE., .FALSE., .TRUE. , .FALSE./ 30 - DATA EMIN,EMAX,FRCRIT,EPMIN,EPMAX 31 - - /0.01,25.0,0.01 ,0.5 ,50.0 / 32 - DATA EPLOG /.TRUE./ 33 - *** Initial values. 34 - XLOSCH=2.687E19*(PGAS/760.0)*(273.0/TGAS) 35 - EPMIN=100.0/PGAS 36 - EPMAX=10000.0/PGAS 37 - NGAS=20 38 - DO 110 I=1,MXFRAC 39 - FRAC(I)=-1.0 40 - 110 CONTINUE 41 - VARLIS(1)='EP' 42 - NCMOB=0 43 - NCTWN=0 44 - NCATT=0 45 - *** Progress printing. 46 - CALL PROINT('MIX',1,6) 47 - CALL PROFLD(1,'Reading the command',-1.0) 48 - CALL PROSTA(1,0.0) 49 - *** Read the command line. 50 - CALL INPNUM(NWORD) 51 - INEXT=2 52 - DO 100 I=2,NWORD 53 - IF(I.LT.INEXT)GOTO 100 54 - *** Fractions, first Argon. 55 - IF(INPCMP(I,'AR#GON').NE.0)THEN 56 - IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN 57 - CALL INPMSG(I,'Argument invalid or missing. ') 58 - ELSE 59 - CALL INPCHK(I+1,2,IFAIL1) 60 - CALL INPRDR(I+1,FRAC(1),0.0) 61 - ENDIF 62 - INEXT=I+2 63 - * Methane 64 - ELSEIF(INPCMP(I,'METHA#NE')+INPCMP(I,'CH4').NE.0)THEN 65 - IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN 66 - CALL INPMSG(I,'Argument invalid or missing. ') 67 - ELSE 68 - CALL INPCHK(I+1,2,IFAIL1) 69 - CALL INPRDR(I+1,FRAC(2),0.0) 70 - ENDIF 71 - INEXT=I+2 72 - * Neon 73 - ELSEIF(INPCMP(I,'NE#ON').NE.0)THEN 74 - IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN 75 - CALL INPMSG(I,'Argument invalid or missing. ') 76 - ELSE 77 - CALL INPCHK(I+1,2,IFAIL1) 78 - CALL INPRDR(I+1,FRAC(3),0.0) 79 - ENDIF 80 - INEXT=I+2 81 - * Isobutane 82 - ELSEIF(INPCMP(I,'ISO#BUTANE')+INPCMP(I,'C4H10').NE.0)THEN 83 - IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN 84 - CALL INPMSG(I,'Argument invalid or missing. ') 85 - ELSE 86 - CALL INPCHK(I+1,2,IFAIL1) 87 - CALL INPRDR(I+1,FRAC(4),0.0) 88 - ENDIF 89 - INEXT=I+2 90 - * CO2 91 - ELSEIF(INPCMP(I,'CO2').NE.0)THEN 92 - IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN 93 - CALL INPMSG(I,'Argument invalid or missing. ') 94 - ELSE 95 - CALL INPCHK(I+1,2,IFAIL1) 96 - CALL INPRDR(I+1,FRAC(5),0.0) 97 - ENDIF 98 - INEXT=I+2 99 - * Helium 100 - ELSEIF(INPCMP(I,'HE#LIUM-#4').NE.0)THEN 101 - IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN 102 - CALL INPMSG(I,'Argument invalid or missing. ') 103 - ELSE 104 - CALL INPCHK(I+1,2,IFAIL1) 105 - CALL INPRDR(I+1,FRAC(6),0.0) 106 - ENDIF 107 - INEXT=I+2 108 - * Ethane 109 - ELSEIF(INPCMP(I,'ETH#ANE')+INPCMP(I,'C2H6').NE.0)THEN 110 - IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN 111 - CALL INPMSG(I,'Argument invalid or missing. ') 112 - ELSE 113 - CALL INPCHK(I+1,2,IFAIL1) 114 - CALL INPRDR(I+1,FRAC(7),0.0) 115 - ENDIF 116 - INEXT=I+2 117 - * Nitrogen 118 - ELSEIF(INPCMP(I,'NITR#OGEN').NE.0)THEN 119 - IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN 120 - CALL INPMSG(I,'Argument invalid or missing. ') 121 - ELSE 122 - CALL INPCHK(I+1,2,IFAIL1) 123 - CALL INPRDR(I+1,FRAC(8),0.0) 124 - ENDIF 125 - INEXT=I+2 126 - * Xenon 127 - ELSEIF(INPCMP(I,'XE#NON').NE.0)THEN 128 - IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN 1 520 P=GAS D=GASMIX 3 PAGE 781 129 - CALL INPMSG(I,'Argument invalid or missing. ') 130 - ELSE 131 - CALL INPCHK(I+1,2,IFAIL1) 132 - CALL INPRDR(I+1,FRAC(9),0.0) 133 - ENDIF 134 - INEXT=I+2 135 - * Methylal (dimethoxymethane). 136 - ELSEIF(INPCMP(I,'METHYL#AL')+INPCMP(I,'C3H8O2')+ 137 - - INPCMP(I,'DMM').NE.0)THEN 138 - IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN 139 - CALL INPMSG(I,'Argument invalid or missing. ') 140 - ELSE 141 - CALL INPCHK(I+1,2,IFAIL1) 142 - CALL INPRDR(I+1,FRAC(10),0.0) 143 - ENDIF 144 - INEXT=I+2 145 - * Krypton. 146 - ELSEIF(INPCMP(I,'KR#YPTON').NE.0)THEN 147 - IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN 148 - CALL INPMSG(I,'Argument invalid or missing. ') 149 - ELSE 150 - CALL INPCHK(I+1,2,IFAIL1) 151 - CALL INPRDR(I+1,FRAC(11),0.0) 152 - ENDIF 153 - INEXT=I+2 154 - * Ammonia. 155 - ELSEIF(INPCMP(I,'AMM#ONIA')+INPCMP(I,'NH3')+ 156 - - INPCMP(I,'H3N').NE.0)THEN 157 - IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN 158 - CALL INPMSG(I,'Argument invalid or missing. ') 159 - ELSE 160 - CALL INPCHK(I+1,2,IFAIL1) 161 - CALL INPRDR(I+1,FRAC(12),0.0) 162 - ENDIF 163 - INEXT=I+2 164 - * Test gas mixture. 165 - ELSEIF(INPCMP(I,'TEST').NE.0)THEN 166 - IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN 167 - CALL INPMSG(I,'Argument invalid or missing. ') 168 - ELSE 169 - CALL INPCHK(I+1,2,IFAIL1) 170 - CALL INPRDR(I+1,FRAC(13),0.0) 171 - ENDIF 172 - INEXT=I+2 173 - * Maximum energy for cross-section calculations and plots. 174 - ELSEIF(INPCMP(I,'MAX#IMUM-E#NERGY').NE.0)THEN 175 - IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN 176 - CALL INPMSG(I,'Argument invalid or missing. ') 177 - ELSE 178 - CALL INPCHK(I+1,2,IFAIL1) 179 - CALL INPRDR(I+1,EMAXR,50.0) 180 - IF(EMAXR.LE.0.0)THEN 181 - CALL INPMSG(I+1,'Maximum energy not > 0. ') 182 - ELSE 183 - EMAX=EMAXR 184 - ENDIF 185 - ENDIF 186 - INEXT=I+2 187 - * Minimum energy for cross-section plots. 188 - ELSEIF(INPCMP(I,'MIN#IMUM-E#NERGY').NE.0)THEN 189 - IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN 190 - CALL INPMSG(I,'Argument invalid or missing. ') 191 - ELSE 192 - CALL INPCHK(I+1,2,IFAIL1) 193 - CALL INPRDR(I+1,EMINR,0.01) 194 - IF(EMINR.LE.0.0)THEN 195 - CALL INPMSG(I+1,'Minimum energy not > 0. ') 196 - ELSE 197 - EMIN=EMINR 198 - ENDIF 199 - ENDIF 200 - INEXT=I+2 201 - * Energy step-size for integrations. 202 - ELSEIF(INPCMP(I,'STEP#SIZE-#ENERGY').NE.0)THEN 203 - IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN 204 - CALL INPMSG(I,'Argument invalid or missing. ') 205 - ELSE 206 - CALL INPCHK(I+1,2,IFAIL1) 207 - CALL INPRDR(I+1,ESTEPR,10.0) 208 - IF(ESTEPR.LE.0.0)THEN 209 - CALL INPMSG(I+1,'Stepsize is not larger than 0.') 210 - ELSE 211 - ESTEP=ESTEPR 212 - ENDIF 213 - ENDIF 214 - INEXT=I+2 215 - * Critical F0 fraction for warnings 216 - ELSEIF(INPCMP(I,'CRIT#ICAL-F0-FR#ACTION').NE.0)THEN 217 - IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN 218 - CALL INPMSG(I,'Argument invalid or missing. ') 219 - ELSE 220 - CALL INPCHK(I+1,2,IFAIL1) 221 - CALL INPRDR(I+1,FRCRIR,0.1) 222 - IF(FRCRIR.LE.0.0.OR.FRCRIR.GE.1.0)THEN 223 - CALL INPMSG(I+1,'Fraction not within <0,1>. ') 224 - ELSE 225 - FRCRIT=FRCRIR 226 - ENDIF 227 - ENDIF 228 - INEXT=I+2 229 - * Range of E/p. 230 - ELSEIF(INPCMP(I,'RAN#GE')+INPCMP(I,'E/P-RAN#GE').NE.0)THEN 231 - CALL INPCHK(I+1,2,IFAIL1) 232 - CALL INPCHK(I+2,2,IFAIL2) 233 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.NWORD.GE.I+2)THEN 234 - CALL INPRDR(I+1,EPMINR,EPMIN) 1 520 P=GAS D=GASMIX 4 PAGE 782 235 - CALL INPRDR(I+2,EPMAXR,EPMAX) 236 - IF(EPMINR.NE.EPMAXR.AND.EPMINR.GT.0.0.AND. 237 - - EPMAXR.GT.0.0)THEN 238 - EPMIN=MIN(EPMINR,EPMAXR) 239 - EPMAX=MAX(EPMINR,EPMAXR) 240 - ELSE 241 - CALL INPMSG(I+1,'Zero range and negative values') 242 - CALL INPMSG(I+2,'are not permitted in RANGE. ') 243 - ENDIF 244 - ELSE 245 - CALL INPMSG(I,'Missing or invalid arguments. ') 246 - ENDIF 247 - INEXT=I+3 248 - * Kind of E/p scale. 249 - ELSEIF(INPCMP(I,'LIN#EAR-#E/P-#SCALE').NE.0)THEN 250 - EPLOG=.FALSE. 251 - ELSEIF(INPCMP(I,'LOG#ARITHMIC-#E/P-#SCALE').NE.0)THEN 252 - EPLOG=.TRUE. 253 - * Number of points. 254 - ELSEIF(INPCMP(I,'N-#E/P').NE.0)THEN 255 - IF(INPTYP(I+1).NE.1.OR.I.GE.NWORD)THEN 256 - CALL INPMSG(I,'Argument invalid or missing. ') 257 - ELSE 258 - CALL INPCHK(I+1,1,IFAIL1) 259 - CALL INPRDI(I+1,NGASR,20) 260 - IF(NGASR.LE.0.OR.NGASR.GT.MXLIST)THEN 261 - CALL INPMSG(I+1,'Value is out of range. ') 262 - ELSE 263 - NGAS=NGASR 264 - ENDIF 265 - ENDIF 266 - INEXT=I+2 267 - * Plotting options. 268 - ELSEIF(INPCMP(I,'PL#OT-DIST#RIBUTION-#FUNCTIONS')+ 269 - - INPCMP(I,'PL#OT-F0').NE.0)THEN 270 - LDISPL=.TRUE. 271 - ELSEIF(INPCMP(I,'NOPL#OT-DIST#RIBUTION-#FUNCTIONS')+ 272 - - INPCMP(I,'NOPL#OT-F0').NE.0)THEN 273 - LDISPL=.FALSE. 274 - ELSEIF(INPCMP(I,'PL#OT-E#NERGY-#LOSS').NE.0)THEN 275 - LOSSPL=.TRUE. 276 - ELSEIF(INPCMP(I,'NOPL#OT-E#NERGY-#LOSS').NE.0)THEN 277 - LOSSPL=.FALSE. 278 - ELSEIF(INPCMP(I,'PL#OT-CR#OSS-#SECTION').NE.0)THEN 279 - LCSPL=.TRUE. 280 - ELSEIF(INPCMP(I,'NOPL#OT-CR#OSS-#SECTION').NE.0)THEN 281 - LCSPL=.FALSE. 282 - ELSEIF(INPCMP(I,'PL#OT-PATH').NE.0)THEN 283 - LPTHPL=.TRUE. 284 - ELSEIF(INPCMP(I,'NOPL#OT-PATH').NE.0)THEN 285 - LPTHPL=.FALSE. 286 - ELSEIF(INPCMP(I,'PR#INT-TAB#LES').NE.0)THEN 287 - LTABPR=.TRUE. 288 - ELSEIF(INPCMP(I,'NOPR#INT-TAB#LES').NE.0)THEN 289 - LTABPR=.FALSE. 290 - * Mobility. 291 - ELSEIF(INPCMP(I,'ION-MOB#ILITY')+ 292 - - INPCMP(I,'MOB#ILITY').NE.0)THEN 293 - IF(I.GE.NWORD)THEN 294 - CALL INPMSG(I,'Argument invalid or missing. ') 295 - ELSE 296 - CALL INPSTR(I+1,I+1,STRMOB,NCMOB) 297 - ENDIF 298 - INEXT=I+2 299 - * Townsend coefficient. 300 - ELSEIF(INPCMP(I,'TOWN#SEND-#COEFFICIENT').NE.0)THEN 301 - IF(I.GE.NWORD)THEN 302 - CALL INPMSG(I,'Argument invalid or missing. ') 303 - ELSE 304 - CALL INPSTR(I+1,I+1,STRTWN,NCTWN) 305 - ENDIF 306 - INEXT=I+2 307 - * Attachment coefficient. 308 - ELSEIF(INPCMP(I,'ATT#ACHMENT-#COEFFICIENT').NE.0)THEN 309 - IF(I.GE.NWORD)THEN 310 - CALL INPMSG(I,'Argument invalid or missing. ') 311 - ELSE 312 - CALL INPSTR(I+1,I+1,STRATT,NCATT) 313 - ENDIF 314 - INEXT=I+2 315 - * Other options not valid. 316 - ELSE 317 - CALL INPMSG(I,'Not a recognised keyword. ') 318 - ENDIF 319 - 100 CONTINUE 320 - *** Dump error messages. 321 - CALL INPERR 322 - *** Renormalise the fractions. 323 - FRTOT=0.0 324 - DO 120 I=1,MXFRAC 325 - IF(FRAC(I).LT.0)FRAC(I)=0.0 326 - FRTOT=FRTOT+FRAC(I) 327 - 120 CONTINUE 328 - IF(FRTOT.LE.0.0)THEN 329 - PRINT *,' !!!!!! GASMIX WARNING : Please have at least'// 330 - - ' gas in your mixture; nothing done.' 331 - NGAS=0 332 - CALL PROEND 333 - RETURN 334 - ELSE 335 - DO 130 I=1,MXFRAC 336 - FRAC(I)=FRAC(I)/FRTOT 337 - 130 CONTINUE 338 - ENDIF 339 - *** Break-point initialisation. 340 - CALL PROFLD(1,'Setting breakpoints',-1.0) 1 520 P=GAS D=GASMIX 5 PAGE 783 341 - CALL PROSTA(1,0.0) 342 - CALL GASMXB 343 - *** Debugging output. 344 - IF(LDEBUG)THEN 345 - WRITE(LUNOUT,'('' ++++++ GASMIX DEBUG : Mixing the'', 346 - - '' following gasses:''// 347 - - '' Argon '',F6.3,'' Methane '',F6.3/ 348 - - '' Neon '',F6.3,'' Isobutane '',F6.3/ 349 - - '' CO2 '',F6.3,'' Helium '',F6.3/ 350 - - '' Ethane '',F6.3,'' Nitrogen '',F6.3/ 351 - - '' Xenon '',F6.3,'' Methylal '',F6.3/ 352 - - '' Krypton '',F6.3,'' Ammonia '',F6.3/)') 353 - - (FRAC(I),I=1,12) 354 - WRITE(LUNOUT,'('' With the following parameters:''// 355 - - '' Lower plotting bound: '',F10.3,'' [eV]''/ 356 - - '' Upper integration bound: '',F10.3,'' [eV]''/ 357 - - '' Step size limit: '',F10.3,'' [eV]''/ 358 - - '' Onset of ionisation: '',F10.3,'' [eV]''/ 359 - - '' Warning level: '',F10.3/ 360 - - '' E/p range: '',2F10.3, 361 - - '' [V/cm.torr]''/ 362 - - '' Number of E/p points: '',I6/ 363 - - '' Pressure of the gas: '',F10.3,'' [torr]''/ 364 - - '' Temperature of the gas: '',F10.3,'' [K]'')') 365 - - EMIN,EMAX,ESTEP,ECRIT,FRCRIT,EPMIN,EPMAX,NGAS,PGAS,TGAS 366 - IF(NCMOB.GT.0)WRITE(LUNOUT,'('' ++++++ GASMIX DEBUG :'', 367 - - '' Mobility = '',A)') STRMOB(1:NCMOB) 368 - IF(NCTWN.GT.0)WRITE(LUNOUT,'('' ++++++ GASMIX DEBUG :'', 369 - - '' Townsend = '',A)') STRTWN(1:NCTWN) 370 - IF(NCATT.GT.0)WRITE(LUNOUT,'('' ++++++ GASMIX DEBUG :'', 371 - - '' Attachment = '',A)') STRATT(1:NCATT) 372 - ENDIF 373 - *** Some preliminary plots. 374 - IF(LOSSPL.OR.LCSPL.OR.LPTHPL.OR.LTABPR)THEN 375 - CALL PROFLD(1,'Plotting cs and mfp',-1.0) 376 - CALL PROSTA(1,0.0) 377 - IF(LTABPR)WRITE(LUNOUT,'('' TABLE OF INPUT GAS DATA''//5X, 378 - - '' Energy [eV] Free path [cm]'', 379 - - '' Energy loss Cross section [cm2]''//)') 380 - DO 200 I=1,MXLIST 381 - XPL(I)=EMIN*(EMAX/EMIN)**(REAL(I-1)/REAL(MXLIST-1)) 382 - CALL GASMXD(XPL(I),YPL1(I),YPL2(I)) 383 - YPL3(I)=1/(XLOSCH*YPL1(I)) 384 - IF(LTABPR)WRITE(LUNOUT,'(5X,4(5X,E15.8))') 385 - - XPL(I),YPL1(I),YPL2(I),YPL3(I) 386 - 200 CONTINUE 387 - CALL GRAOPT('LOG-X') 388 - CALL GRAOPT('LOG-Y') 389 - IF(LPTHPL)THEN 390 - CALL GRGRPH(XPL,YPL1,MXLIST,'Energy [eV]', 391 - - 'Mean path length [cm]','Mean path length') 392 - CALL GRCOMM(1,'Gas: '//GASID) 393 - CALL GRNEXT 394 - CALL GRALOG('Mean free path of electrons in the gas: ') 395 - ENDIF 396 - IF(LOSSPL)THEN 397 - CALL GRGRPH(XPL,YPL2,MXLIST,'Energy [eV]', 398 - - 'Fraction','Energy loss per collision') 399 - CALL GRCOMM(1,'Gas: '//GASID) 400 - CALL GRNEXT 401 - CALL GRALOG('Average energy loss per collision: ') 402 - ENDIF 403 - IF(LCSPL)THEN 404 - CALL GRGRPH(XPL,YPL3,MXLIST,'Energy [eV]', 405 - - 'Cross section [cm2]','Cross section') 406 - CALL GRCOMM(1,'Gas: '//GASID) 407 - CALL GRNEXT 408 - CALL GRALOG('Elastic cross section of the gas: ') 409 - ENDIF 410 - CALL GRAOPT('LIN-X') 411 - CALL GRAOPT('LIN-Y') 412 - ENDIF 413 - *** Translate the various functions if they have been specified. 414 - IF(NCMOB.GT.0)THEN 415 - CALL PROFLD(1,'Setting the mobility',-1.0) 416 - CALL PROSTA(1,0.0) 417 - * Call editor of specified as @. 418 - IF(INDEX(STRMOB(1:NCMOB),'@').NE.0)THEN 419 - NRES=1 420 - PRINT *,' ------ GASMIX MESSAGE : Please edit the'// 421 - - ' mobility, function of EP (= E/p).' 422 - CALL ALGEDT(VARLIS,1,IENMOB,USE,NRES) 423 - IFAIL1=0 424 - * Usual function translation if not. 425 - ELSE 426 - CALL ALGPRE(STRMOB,NCMOB,VARLIS,1,NRES,USE,IENMOB, 427 - - IFAIL1) 428 - ENDIF 429 - * Check return code of translation. 430 - IF(IFAIL1.NE.0)THEN 431 - PRINT *,' !!!!!! GASMIX WARNING : Ion mobility'// 432 - - ' function rejected; no ion mobility in table.' 433 - CALL ALGCLR(IENMOB) 434 - NCMOB=0 435 - ENDIF 436 - * Check number of results returned by the function. 437 - IF(NRES.NE.1)THEN 438 - PRINT *,' !!!!!! GASMIX WARNING : Number of'// 439 - - ' results returned by the mobility function'// 440 - - ' is not 1; rejected.' 441 - CALL ALGCLR(IENMOB) 442 - NCMOB=0 443 - ENDIF 444 - ENDIF 445 - ** Townsend coefficient. 446 - IF(NCTWN.GT.0)THEN 1 520 P=GAS D=GASMIX 6 PAGE 784 447 - CALL PROFLD(1,'Setting Townsend',-1.0) 448 - CALL PROSTA(1,0.0) 449 - * Call editor of specified as @. 450 - IF(INDEX(STRTWN(1:NCTWN),'@').NE.0)THEN 451 - NRES=1 452 - PRINT *,' ------ GASMIX MESSAGE : Please edit the'// 453 - - ' Townsend coefficient, function of EP (=E/p).' 454 - CALL ALGEDT(VARLIS,1,IENTWN,USE,NRES) 455 - IFAIL1=0 456 - * Usual function translation if not. 457 - ELSE 458 - CALL ALGPRE(STRTWN,NCTWN,VARLIS,1,NRES,USE,IENTWN, 459 - - IFAIL1) 460 - ENDIF 461 - * Check return code of translation. 462 - IF(IFAIL1.NE.0)THEN 463 - PRINT *,' !!!!!! GASMIX WARNING : Townsend function'// 464 - - ' rejected; no Townsend coefficient in table.' 465 - CALL ALGCLR(IENTWN) 466 - NCTWN=0 467 - ENDIF 468 - * Check number of results returned by the function. 469 - IF(NRES.NE.1)THEN 470 - PRINT *,' !!!!!! GASMIX WARNING : Number of'// 471 - - ' results returned by the Townsend function'// 472 - - ' is not 1; rejected.' 473 - CALL ALGCLR(IENTWN) 474 - NCTWN=0 475 - ENDIF 476 - ENDIF 477 - *** Attachment coefficient. 478 - IF(NCATT.GT.0)THEN 479 - CALL PROFLD(1,'Setting attachment',-1.0) 480 - CALL PROSTA(1,0.0) 481 - * Call editor of specified as @. 482 - IF(INDEX(STRATT(1:NCATT),'@').NE.0)THEN 483 - NRES=1 484 - PRINT *,' ------ GASMIX MESSAGE : Please edit the'// 485 - - ' attachment coefficient, function of EP (=E/p).' 486 - CALL ALGEDT(VARLIS,1,IENATT,USE,NRES) 487 - IFAIL1=0 488 - * Usual function translation if not. 489 - ELSE 490 - CALL ALGPRE(STRATT,NCATT,VARLIS,1,NRES,USE,IENATT, 491 - - IFAIL1) 492 - ENDIF 493 - * Check return code of translation. 494 - IF(IFAIL1.NE.0)THEN 495 - PRINT *,' !!!!!! GASMIX WARNING : Attachment'// 496 - - ' function rejected; no attachment in table.' 497 - CALL ALGCLR(IENATT) 498 - NCATT=0 499 - ENDIF 500 - * Check number of results returned by the function. 501 - IF(NRES.NE.1)THEN 502 - PRINT *,' !!!!!! GASMIX WARNING : Number of'// 503 - - ' results returned by the attachment function'// 504 - - ' is not 1; rejected.' 505 - CALL ALGCLR(IENATT) 506 - NCATT=0 507 - ENDIF 508 - ENDIF 509 - *** Loop over the electric field. 510 - EPCRIT=-1.0 511 - IF(LDISPL)CALL GRAOPT('LOG-X') 512 - CALL PROFLD(1,'Electric field',REAL(NGAS)) 513 - DO 10 I=1,NGAS 514 - CALL PROSTA(1,REAL(I)) 515 - *** Logarithmic or linear spacing of the E/p points. 516 - IF(EPLOG)THEN 517 - EGAS(I)=EPMIN*(EPMAX/EPMIN)**(REAL(I-1)/REAL(MAX(1,NGAS-1))) 518 - ELSE 519 - EGAS(I)=EPMIN+(EPMAX-EPMIN)*(REAL(I-1)/REAL(MAX(1,NGAS-1))) 520 - ENDIF 521 - *** Compute the mobility if requested. 522 - IF(NCMOB.GT.0)THEN 523 - VAR(1)=EGAS(I) 524 - MODVAR(1)=2 525 - CALL ALGEXE(IENMOB,VAR,MODVAR,1,RES,MODRES,1,IFAIL1) 526 - MGAS(I)=RES(1) 527 - ENDIF 528 - *** Compute the Townsend coefficient if requested. 529 - IF(NCTWN.GT.0)THEN 530 - VAR(1)=EGAS(I) 531 - MODVAR(1)=2 532 - CALL ALGEXE(IENTWN,VAR,MODVAR,1,RES,MODRES,1,IFAIL1) 533 - AGAS(I)=RES(1) 534 - ENDIF 535 - *** Compute the attachment coefficient if requested. 536 - IF(NCATT.GT.0)THEN 537 - VAR(1)=EGAS(I) 538 - MODVAR(1)=2 539 - CALL ALGEXE(IENATT,VAR,MODVAR,1,RES,MODRES,1,IFAIL1) 540 - BGAS(I)=RES(1) 541 - ENDIF 542 - *** Copy for the gas-mixing common block. 543 - EFLD=PGAS*EGAS(I) 544 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASMIX DEBUG : E='', 545 - - E10.3,'' V/cm'')') EFLD 546 - *** Find the maximum relevant energy. 547 - EEMAX=EMAX 548 - 40 CONTINUE 549 - ARG=GASMG1(FGAS1,DBLE(EEMAX),X) 550 - IF(ARG.LT.50.0)THEN 551 - EEMAX=EEMAX/0.9 552 - GOTO 30 1 520 P=GAS D=GASMIX 7 PAGE 785 553 - ELSE 554 - EEMAX=EEMAX*0.9 555 - GOTO 40 556 - ENDIF 557 - 30 CONTINUE 558 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASMIX DEBUG : Largest'', 559 - - '' relevant electron energy: '',F10.3,'' eV.'')') EEMAX 560 - *** Get the F0 normalisation straight. 561 - F0NORM=GASMG2(FGAS2N,DBLE(EEMAX),X) 562 - *** Monitor electron excitation. 563 - F0OK=GASMG2(FGAS2N,DBLE(ECRIT),X)/F0NORM 564 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASMIX DEBUG : Fraction'', 565 - - '' of F0 above ionisation: '',E10.3,''.'')') 1.0D0-F0OK 566 - *** Plot the distribution if requested. 567 - IF(LDISPL)THEN 568 - F0MAX=0 569 - DO 20 J=1,MXLIST 570 - XPL(J)=EMIN*(EMAX/EMIN)**(REAL(J-1)/REAL(MXLIST-1)) 571 - YPL1(J)=SQRT(XPL(J))*EXP(MAX(-60.0D0, 572 - - -GASMG1(FGAS1,DBLE(XPL(J)),X)))/F0NORM 573 - IF(YPL1(J).GT.F0MAX)F0MAX=YPL1(J) 574 - 20 CONTINUE 575 - IF(I.EQ.1)CALL GRCART(EMIN,0.0,EMAX,1.1*F0MAX, 576 - - 'Energy [eV]','F0 [1/eV]','Distribution function') 577 - IF(REAL(1.0D0-F0OK).LT.FRCRIT)THEN 578 - CALL GRATTS('FUNCTION-1','POLYLINE') 579 - ELSE 580 - CALL GRATTS('FUNCTION-2','POLYLINE') 581 - IF(EPCRIT.LE.0)EPCRIT=EGAS(I) 582 - ENDIF 583 - CALL GRLINE(MXLIST,XPL,YPL1) 584 - ENDIF 585 - *** Compute the drift velocity. 586 - VGAS(I)=1.0E-4*(2.0/3.0)*SQRT(0.5*ECHARG/EMASS)*EFLD* 587 - - GASMG2(FGAS2V,DBLE(EEMAX),X)/F0NORM 588 - *** Compute the diffusion coefficient. 589 - DGAS(I)=0.01*SQRT(2*PGAS*GASMG2(FGAS2D,DBLE(EEMAX),X)/ 590 - - (3*F0NORM*VGAS(I))) 591 - 10 CONTINUE 592 - *** Close the plot. 593 - IF(LDISPL)THEN 594 - CALL GRCOMM(1,'Gas: '//GASID) 595 - IF(EPCRIT.GT.0)CALL GRCOMM(2, 596 - - 'WARNING: F0 for high E/p is affected by ionisation.') 597 - CALL GRNEXT 598 - CALL GRALOG('Distribution function F0') 599 - CALL GRAOPT('LIN-X') 600 - ENDIF 601 - CALL PROEND 602 - *** Clear the mobility etc entry points - no longer needed. 603 - IF(NCMOB.GT.0)CALL ALGCLR(IENMOB) 604 - IF(NCTWN.GT.0)CALL ALGCLR(IENTWN) 605 - IF(NCATT.GT.0)CALL ALGCLR(IENATT) 606 - *** Dump algebra error messages. 607 - IF(NCMOB.GT.0.OR.NCTWN.GT.0.OR.NCATT.GT.0)CALL ALGERR 608 - *** Issue warnings if needed. 609 - IF(EPCRIT.GT.0.0)PRINT *,' !!!!!! GASMIX WARNING : Ionisation'// 610 - - ' effects play a role for E/p > ',EPCRIT 611 - *** Set the gas bits. 612 - GASOK(1)=.TRUE. 613 - IF(NCMOB.GT.0)GASOK(2)=.TRUE. 614 - GASOK(3)=.TRUE. 615 - IF(NCTWN.GT.0)GASOK(4)=.TRUE. 616 - IF(NCATT.GT.0)GASOK(6)=.TRUE. 617 - *** Register the amount of CPU time with TIMLOG. 618 - CALL TIMLOG('Computing a gas mixture: ') 619 - END 521 GARFIELD ================================================== P=GAS D=FGAS1 1 ============================ 0 + +DECK,FGAS1. 1 - SUBROUTINE FGAS1(M,U1,F1,X) 2 - *----------------------------------------------------------------------- 3 - * FGAS2V - Used by GASMIX and auxiliaries to compute F0. 4 - * (Last changed on 28/ 9/92.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,GASMIXDATA. 8.- +SEQ,GASDATA. 9.- +SEQ,CONSTANTS. 10 - DOUBLE PRECISION U1(*),F1(*),X(2) 11 - *** Loop over the points. 12 - DO 10 I=1,M 13 - X(1)=U1(I) 14 - E=X(1) 15 - *** Quick return for zero energy. 16 - IF(E.LE.0.0)THEN 17 - F1(I)=0.0 18 - ELSE 19 - *** Obtain the mean path and fraction of energy lost at this energy. 20 - CALL GASMXD(E,PATH,ELOSS) 21 - *** Compute the integrand. 22 - F1(I)=3*ELOSS*E/((EFLD*PATH)**2+3*ELOSS*E*BOLTZ*TGAS/ECHARG) 23 - ENDIF 24 - 10 CONTINUE 25 - END 522 GARFIELD ================================================== P=GAS D=FGAS2D 1 ============================ 0 + +DECK,FGAS2D. 1 - SUBROUTINE FGAS2D(M,U2,F2,X) 2 - *----------------------------------------------------------------------- 3 - * FGAS2V - Used by GASMIX to compute the diffusion integral. 4 - * (Last changed on 28/ 9/92.) 5 - *----------------------------------------------------------------------- 1 522 P=GAS D=FGAS2D 2 PAGE 786 6.- +SEQ,DIMENSIONS. 7.- +SEQ,GASMIXDATA. 8.- +SEQ,CONSTANTS. 9 - DOUBLE PRECISION U2(*),F2(*),X(2),GASMG1 10 - EXTERNAL GASMG1,FGAS1 11 - *** Loop over the points. 12 - DO 10 I=1,M 13 - X(2)=U2(I) 14 - E=X(2) 15 - *** Assign. 16 - CALL GASMXD(E,PATH,ELOSS) 17 - F2(I)=PATH*SQRT(2*ECHARG*E/EMASS)*SQRT(E)* 18 - - EXP(MAX(-60.0D0,-GASMG1(FGAS1,DBLE(E),X))) 19 - 10 CONTINUE 20 - END 523 GARFIELD ================================================== P=GAS D=FGAS2N 1 ============================ 0 + +DECK,FGAS2N. 1 - SUBROUTINE FGAS2N(M,U2,F2,X) 2 - *----------------------------------------------------------------------- 3 - * FGAS2V - Used by GASMIX to compute the F0 normalisation. 4 - * (Last changed on 28/ 9/92.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,GASMIXDATA. 8.- +SEQ,CONSTANTS. 9 - DOUBLE PRECISION U2(*),F2(*),X(2),GASMG1 10 - EXTERNAL GASMG1,FGAS1 11 - *** Loop over the points. 12 - DO 10 I=1,M 13 - X(2)=U2(I) 14 - E=X(2) 15 - *** Assign. 16 - F2(I)=SQRT(E)* 17 - - EXP(MAX(-60.0D0,-GASMG1(FGAS1,DBLE(E),X))) 18 - 10 CONTINUE 19 - END 524 GARFIELD ================================================== P=GAS D=FGAS2V 1 ============================ 0 + +DECK,FGAS2V. 1 - SUBROUTINE FGAS2V(M,U2,F2,X) 2 - *----------------------------------------------------------------------- 3 - * FGAS2V - Used by GASMIX to compute the drift velocity integral. 4 - * (Last changed on 28/ 9/92.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,GASMIXDATA. 8.- +SEQ,CONSTANTS. 9 - DOUBLE PRECISION U2(*),F2(*),X(2),GASMG1 10 - EXTERNAL GASMG1,FGAS1 11 - *** Loop over the points. 12 - DO 10 I=1,M 13 - X(2)=U2(I) 14 - E=X(2) 15 - *** Get derivative of the path. 16 - EPS=1.0E-3 17 - CALL GASMXD(E,PATH,ELOSS) 18 - IF(E.LE.EPS)THEN 19 - CALL GASMXD(EPS,PATH1,ELOSS1) 20 - CALL GASMXD(0.0,PATH2,ELOSS2) 21 - DLDE=(PATH1-PATH2)/EPS 22 - ELSE 23 - CALL GASMXD(E*(1+EPS),PATH1,ELOSS1) 24 - CALL GASMXD(E*(1-EPS),PATH2,ELOSS2) 25 - DLDE=(PATH1-PATH2)/(2*EPS*E) 26 - ENDIF 27 - *** Assign. 28 - F2(I)=(PATH+E*DLDE)* 29 - - EXP(MAX(-60.0D0,-GASMG1(FGAS1,DBLE(E),X))) 30 - 10 CONTINUE 31 - END 525 GARFIELD ================================================== P=GAS D=GASMXD 1 ============================ 0 + +DECK,GASMXD. 1 - SUBROUTINE GASMXD(E,PATH,ELOSS) 2 - *----------------------------------------------------------------------- 3 - * GASMXD - Returns literature values for the gas mixtures. 4 - * ORIGIN: Data taken from a program written by Fabio Sauli and 5 - * Anna Peisert, apparently based on Schultz & Gresser. 6 - * Data for Krypton, Argon and ammonia from Wircha. 7 - * (Last changed on 16/11/93.) 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,GASMIXDATA. 11 - REAL DIVDIF,ELOSS,SIGMA(MXFRAC),ELVECT(MXFRAC) 12 - EXTERNAL DIVDIF 13 - *** Gas data. 14 - REAL ENEON(31),SNEON(31) 15 - REAL EHEL(37),SHEL(37) 16 - REAL ENITR(24),SNITR(24) 17 - DATA ENEON/ 0.03 , 0.04 , 0.05 , 0.06 , 0.07 , 0.08 , 0.09 , 18 - - 0.1 , 0.12 , 0.15 , 0.18 , 0.2 , 0.25 , 0.3 , 19 - - 0.4 , 0.5 , 0.6 , 0.7 , 0.8 , 0.9 , 1.0 , 20 - - 1.2 , 1.5 , 1.8 , 2.0 , 2.5 , 3.0 , 4.0 , 21 - - 5.0 , 6.0 , 7.0 / 22 - DATA SNEON/ 0.469, 0.504, 0.536, 0.566, 0.601, 0.636, 0.669, 23 - - 0.701, 0.754, 0.828, 0.893, 0.930, 1.018, 1.091, 24 - - 1.225, 1.321, 1.402, 1.472, 1.528, 1.580, 1.619, 25 - - 1.685, 1.753, 1.793, 1.815, 1.860, 1.906, 1.984, 26 - - 2.070, 2.144, 2.213/ 27 - DATA EHEL / 0.008, 0.009, 0.01 , 0.013, 0.017, 0.02 , 0.025, 28 - - 0.03 , 0.04 , 0.05 , 0.06 , 0.07 , 0.08 , 0.09 , 29 - - 0.1 , 0.12 , 0.15 , 0.18 , 0.2 , 0.25 , 0.3 , 1 525 P=GAS D=GASMXD 2 PAGE 787 30 - - 0.4 , 0.5 , 0.6 , 0.7 , 0.8 , 0.9 , 1.0 , 31 - - 1.2 , 1.5 , 1.8 , 2.0 , 2.5 , 3.0 , 4.0 , 32 - - 5.0 , 6.0 / 33 - DATA SHEL / 5.18 , 5.19 , 5.21 , 5.26 , 5.31 , 5.35 , 5.41 , 34 - - 5.46 , 5.54 , 5.62 , 5.68 , 5.74 , 5.79 , 5.83 , 35 - - 5.86 , 5.94 , 6.04 , 6.12 , 6.16 , 6.27 , 6.35 , 36 - - 6.49 , 6.59 , 6.66 , 6.73 , 6.77 , 6.82 , 6.85 , 37 - - 6.91 , 6.96 , 6.98 , 6.99 , 6.96 , 6.89 , 6.6 , 38 - - 6.26 , 6.01 / 39 - DATA ENITR/0.0016,0.0036,0.0064,0.0103,0.0221, 0.040,0.0651, 40 - - 0.103, 0.15 , 0.332, 1.0 , 1.2 , 1.4 , 1.6 , 41 - - 1.8 , 2.0 , 2.6 , 3.0 , 3.6 , 4.5 ,10.0 , 42 - - 20.0 ,35.0 ,40.0 / 43 - DATA SNITR/ 1.43 , 1.69 , 1.94 , 2.2 , 2.94 , 3.86 , 4.9 , 44 - - 6.04 , 7.12 , 9.34 , 9.98 ,10.51 ,11.45 ,12.9 , 45 - - 16.95 ,24.01 ,29.88 ,21.63 ,14.66 ,11.52 , 9.51 , 46 - - 12.0 ,10.5 ,10.1 / 47 - *** Exceptions. 48 - IF(E.LE.0.0)THEN 49 - PATH=0.0 50 - ELOSS=0.0 51 - RETURN 52 - ENDIF 53 - *** Argon. 54 - IF(FRAC(1).GT.0.0)THEN 55 - IF(E.LT.0.3)THEN 56 - SIGMA(1)=1.46E-17+1.24E-12*(0.3-E)**6.5 57 - ELSEIF(E.LT.1.15)THEN 58 - SIGMA(1)=1.46E-17+1.9E-16*(E-0.3)**2 59 - ELSEIF(E.LT.11.5)THEN 60 - SIGMA(1)=1.52E-15*E/11.5 61 - ELSE 62 - SIGMA(1)=1.52E-15/SQRT(E/11.5) 63 - ENDIF 64 - ELVECT(1)=2.746E-5 65 - ENDIF 66 - *** Methane. 67 - IF(FRAC(2).GT.0.0)THEN 68 - IF(E.LE.0.3)THEN 69 - SIGMA(2)=5.77E-17/SQRT(E) 70 - ELSEIF(E.LE.2.0)THEN 71 - SIGMA(2)=4.468E-16*E**1.2 72 - ELSEIF(E.LE.8.)THEN 73 - SIGMA(2)=7.258E-16*SQRT(E) 74 - ELSE 75 - SIGMA(2)=2.05E-15/SQRT(E/8) 76 - ENDIF 77 - IF(E.LT.0.36)THEN 78 - ELVECT(2)=8.35E-5+5.E-17/SIGMA(2) 79 - ELSE 80 - ELVECT(2)=8.35E-5+1.8E-17/(E*SIGMA(2)) 81 - ENDIF 82 - ENDIF 83 - *** Neon. 84 - IF(FRAC(3).GT.0.0)THEN 85 - IF(E.LT.7)THEN 86 - SIGMA(3)=1.0E-16*DIVDIF(SNEON,ENEON,31,E,2) 87 - ELSE 88 - SIGMA(3)=1.0E-16*DIVDIF(SNEON,ENEON,31,E,1) 89 - ENDIF 90 - ELVECT(3)=5.44E-5 91 - ENDIF 92 - *** Isobutane. 93 - IF(FRAC(4).GT.0.0)THEN 94 - IF(E.LT.0.20)THEN 95 - SIGMA(4)=0.72E-15*SQRT(0.20/E) 96 - ELSEIF(E.LT.0.60)THEN 97 - SIGMA(4)=0.72E-15*(E/0.20)**0.3347 98 - ELSEIF(E.LT.8.00)THEN 99 - SIGMA(4)=(1.04E-15*(8-E)+4.8E-15*(E-0.60))/7.4 100 - ELSE 101 - SIGMA(4)=4.8E-15/SQRT(E/8) 102 - ENDIF 103 - IF(E.LT.0.36)THEN 104 - ELVECT(4)=8.E-17/SIGMA(4)+1.89E-5 105 - ELSE 106 - ELVECT(4)=1.89E-5+2.88E-17/(E*SIGMA(4)) 107 - ENDIF 108 - ENDIF 109 - *** CO2. 110 - IF(FRAC(5).GT.0.0)THEN 111 - IF(E.LT.0.2)THEN 112 - SIGMA(5)=1.7E-15*(1/E)**0.5 113 - ELSEIF(E.LT.1.32)THEN 114 - SIGMA(5)=7.6E-16/E 115 - ELSEIF(E.LT.3.25)THEN 116 - SIGMA(5)=1.E-15-3.66E-16*(3.25-E)**0.222 117 - ELSEIF(E.LT.4.2)THEN 118 - SIGMA(5)=1.53E-15-5.9E-16*(4.2-E)**2.09 119 - ELSEIF(E.LT.6.0)THEN 120 - SIGMA(5)=1.53E-15-4.84E-16*(E-4.2)**0.528 121 - ELSEIF(E.LT.25.)THEN 122 - SIGMA(5)=1.6E-15-1.75E-18*(25-E)**2.05 123 - ELSE 124 - SIGMA(5)=1.6E-15-2.94E-18*(E-25)**1.3 125 - ENDIF 126 - IF(E.LT.0.2)THEN 127 - ELVECT(5)=2.493E-5+4E-16/SIGMA(5) 128 - ELSE 129 - ELVECT(5)=2.493E-5+0.35E-16/(E**0.25*SIGMA(5)) 130 - ENDIF 131 - ENDIF 132 - *** Helium. 133 - IF(FRAC(6).GT.0.0)THEN 134 - SIGMA(6)=1.0E-16*DIVDIF(SHEL,EHEL,37,E,2) 135 - ELVECT(6)=27.4E-5 1 525 P=GAS D=GASMXD 3 PAGE 788 136 - ENDIF 137 - *** Ethane. 138 - IF(FRAC(7).GT.0.0)THEN 139 - IF(E.LT.0.025)THEN 140 - SIGMA(7)=25.E-16*(0.025/E)**0.7005 141 - ELSEIF(E.LT.0.035)THEN 142 - SIGMA(7)=3.5E-16*(0.035/E)**5.844 143 - ELSEIF(E.LT.0.07)THEN 144 - SIGMA(7)=1.9E-16*(0.07/E)**0.881 145 - ELSEIF(E.LT.0.09)THEN 146 - SIGMA(7)=1.8E-16*(0.09/E)**0.215 147 - ELSEIF(E.LT.0.2)THEN 148 - SIGMA(7)=1.8E-16*(E/0.09)**1.147 149 - ELSEIF(E.LT.0.3)THEN 150 - SIGMA(7)=4.5E-16*(E/0.2)**0.583 151 - ELSEIF(E.LT.0.6)THEN 152 - SIGMA(7)=5.7E-16*(E/0.3)**0.811 153 - ELSEIF(E.LT.1.)THEN 154 - SIGMA(7)=10.E-16*(E/0.6)**0.514 155 - ELSE 156 - SIGMA(7)=13.E-16 157 - ENDIF 158 - IF(E.LT.0.36)THEN 159 - ELVECT(7)=3.648E-5+6.E-17/SIGMA(7) 160 - ELSE 161 - ELVECT(7)=3.648E-5+2.16E-17/(E*SIGMA(7)) 162 - ENDIF 163 - ENDIF 164 - *** Nitrogen. 165 - IF(FRAC(8).GT.0.0)THEN 166 - SIGMA(8)=1.0E-16*DIVDIF(SNITR,ENITR,24,E,2) 167 - IF(E.LT.1.3)THEN 168 - ELVECT(8)=3.5E-19/SIGMA(8)+3.90E-5 169 - ELSEIF(E.LT.1.4)THEN 170 - ELVECT(8)=2.0E-18/SIGMA(8)+3.90E-5 171 - ELSEIF(E.LT.1.5)THEN 172 - ELVECT(8)=4.0E-18/SIGMA(8)+3.90E-5 173 - ELSEIF(E.LT.1.6)THEN 174 - ELVECT(8)=8.0E-18/SIGMA(8)+3.90E-5 175 - ELSEIF(E.LT.1.7)THEN 176 - ELVECT(8)=1.0E-17/SIGMA(8)+3.90E-5 177 - ELSEIF(E.LT.1.8)THEN 178 - ELVECT(8)=1.5E-17/SIGMA(8)+3.90E-5 179 - ELSEIF(E.LT.1.9)THEN 180 - ELVECT(8)=2.0E-17/SIGMA(8)+3.90E-5 181 - ELSEIF(E.LT.2.0)THEN 182 - ELVECT(8)=7.0E-17/SIGMA(8)+3.90E-5 183 - ELSEIF(E.LT.5.0)THEN 184 - ELVECT(8)=2.0E-16/SIGMA(8)+3.90E-5 185 - ELSE 186 - ELVECT(8)=1.0E-15/(E*SIGMA(8))+3.90E-5 187 - ENDIF 188 - ENDIF 189 - *** Xenon. 190 - IF(FRAC(9).GT.0.0)THEN 191 - IF(E.LT.0.010)THEN 192 - SIGMA(9)=100.E-16*(0.01/E)**0.176 193 - ELSEIF(E.LT.0.035)THEN 194 - SIGMA(9)=100.E-16*(0.01/E)**0.308 195 - ELSEIF(E.LT.0.1)THEN 196 - SIGMA(9)=68.E-16*(0.035/E)**1.166 197 - ELSEIF(E.LT.0.18)THEN 198 - SIGMA(9)=20.E-16*(0.1/E)**1.179 199 - ELSEIF(E.LT.0.5)THEN 200 - SIGMA(9)=10.E-16*(0.18/E)**1.997 201 - ELSEIF(E.LT.0.7)THEN 202 - SIGMA(9)=1.3E-16*(0.5/E)**0.238 203 - ELSEIF(E.LT.2.0)THEN 204 - SIGMA(9)=1.2E-16*(E/0.70)**2.019 205 - ELSEIF(E.LT.4.1)THEN 206 - SIGMA(9)=10.E-16*(E/2.)**1.823 207 - ELSEIF(E.LT.10.0)THEN 208 - SIGMA(9)=37.E-16*(10/E)**0.69 209 - ELSE 210 - SIGMA(9)=37.0E-16*(10/E)**0.69 211 - ENDIF 212 - ELVECT(9)=8.29E-6 213 - ENDIF 214 - *** Methylal. 215 - IF(FRAC(10).GT.0.0)THEN 216 - IF(E.LE.2.0)THEN 217 - SIGMA(10)=1.1E-15*SQRT(2/E) 218 - ELSEIF(E.LE.4.0)THEN 219 - SIGMA(10)=(1.1E-15*(10-E)+1.8E-15*(E-2))/8 220 - ELSE 221 - SIGMA(10)=1.275E-15*(E/4)**0.22 222 - ENDIF 223 - IF(E.LE.0.36)THEN 224 - ELVECT(10)=1.444E-5+12.E-17/SIGMA(10) 225 - ELSE 226 - ELVECT(10)=1.444E-5+4.32E-17/(E*SIGMA(10)) 227 - ENDIF 228 - ENDIF 229 - *** Krypton, Wircha typing mistake corrected. 230 - IF(FRAC(11).GT.0.0)THEN 231 - IF(E.LE.0.01)THEN 232 - SIGMA(11)=28.0 233 - ELSEIF(E.LE.0.02)THEN 234 - SIGMA(11)=10.0**(0.4763-0.4854*LOG10(E)) 235 - ELSEIF(E.LE.0.04)THEN 236 - SIGMA(11)=10.0**(0.2451-0.6215*LOG10(E)) 237 - ELSEIF(E.LE.0.07)THEN 238 - SIGMA(11)=10.0**(0.195-0.6571*LOG10(E)) 239 - ELSEIF(E.LE.0.1)THEN 240 - SIGMA(11)=10.0**(-0.05-0.8696*LOG10(E)) 241 - ELSEIF(E.LE.0.145)THEN 1 525 P=GAS D=GASMXD 4 PAGE 789 242 - SIGMA(11)=10.0**(-0.2112-1.0307*LOG10(E)) 243 - ELSEIF(E.LE.0.2)THEN 244 - SIGMA(11)=10.0**(-0.679-1.5885*LOG10(E)) 245 - ELSEIF(E.LE.0.3)THEN 246 - SIGMA(11)=10.0**(-1.2808-2.4497*LOG10(E)) 247 - ELSEIF(E.LE.0.4)THEN 248 - SIGMA(11)=10.0**(-0.9284-1.7757*LOG10(E)) 249 - ELSEIF(E.LE.0.5)THEN 250 - SIGMA(11)=10.0**(-0.547-0.8171*LOG10(E)) 251 - ELSEIF(E.LE.0.6)THEN 252 - SIGMA(11)=10.0**(-0.301) 253 - ELSEIF(E.LE.0.8)THEN 254 - SIGMA(11)=10.0**(-0.2708+0.1363*LOG10(E)) 255 - ELSEIF(E.LE.1.0)THEN 256 - SIGMA(11)=10.0**(-0.2007+0.8599*LOG10(E)) 257 - ELSEIF(E.LE.2.0)THEN 258 - SIGMA(11)=10.0**(-0.2006+1.8041*LOG10(E)) 259 - ELSEIF(E.LE.3.0)THEN 260 - SIGMA(11)=10.0**(-0.2521+1.975*LOG10(E)) 261 - ELSEIF(E.LE.4.0)THEN 262 - SIGMA(11)=10.0**(-0.1019+1.6603*LOG10(E)) 263 - ELSEIF(E.LE.5.0)THEN 264 - SIGMA(11)=10.0**(+0.1299+1.275*LOG10(E)) 265 - ELSEIF(E.LE.7.0)THEN 266 - SIGMA(11)=10.0**(0.28025+1.06004*LOG10(E)) 267 - ELSEIF(E.LE.10.0)THEN 268 - SIGMA(11)=10.0**(0.3789+0.9433*LOG10(E)) 269 - ELSE 270 - SIGMA(11)=21.0 271 - ENDIF 272 - SIGMA(11)=SIGMA(11)*1E-16 273 - ELVECT(11)=1.309E-5 274 - ENDIF 275 - *** Ammonia (NH3). 276 - IF(FRAC(12).GT.0.0)THEN 277 - IF(E.LE.0.01)THEN 278 - SIGMA(12)=1600. 279 - ELSEIF(E.LE.0.02)THEN 280 - SIGMA(12)=10.0**(1.5439-0.83007*LOG10(E)) 281 - ELSEIF(E.LE.0.04)THEN 282 - SIGMA(12)=10.0**(1.4135-0.9069*LOG10(E)) 283 - ELSEIF(E.LE.0.1)THEN 284 - SIGMA(12)=10.0**(1.0051-1.199*LOG10(E)) 285 - ELSEIF(E.LE.0.2)THEN 286 - SIGMA(12)=10.0**(0.7891-1.415*LOG10(E)) 287 - ELSEIF(E.LE.0.4)THEN 288 - SIGMA(12)=10.0**(0.9729-1.152*LOG10(E)) 289 - ELSEIF(E.GT.1.0)THEN 290 - SIGMA(12)=10.0**(1.0414-0.98*LOG10(E)) 291 - ELSEIF(E.GT.2.0)THEN 292 - SIGMA(12)=10.0**(1.0414-1.081*LOG10(E)) 293 - ELSEIF(E.GT.3.0)THEN 294 - SIGMA(12)=10.0**(0.716) 295 - ELSEIF(E.GT.5.0)THEN 296 - SIGMA(12)=10.0**(0.3615+0.74289*LOG10(E)) 297 - ELSEIF(E.GT.7.0)THEN 298 - SIGMA(12)=10.0**(0.4839+0.5678*LOG10(E)) 299 - ELSEIF(E.GT.10.0)THEN 300 - SIGMA(12)=10.0**(0.5404+0.501*LOG10(E)) 301 - ELSE 302 - SIGMA(12)=11.0 303 - ENDIF 304 - SIGMA(12)=SIGMA(12)*1E-16 305 - ELVECT(12)=6.442E-5 306 - ENDIF 307 - *** Test gas. 308 - IF(FRAC(13).GT.0.0)THEN 309 - SIGMA(13)=1E-16 310 - ELVECT(13)=1E-5 311 - ENDIF 312 - *** Take the sums. 313 - FRTOT=0.0 314 - CSTOT=0.0 315 - PRTOT=0.0 316 - DO 10 I=1,MXFRAC 317 - IF(FRAC(I).LE.0.0)GOTO 10 318 - FRTOT=FRTOT+FRAC(I) 319 - CSTOT=CSTOT+FRAC(I)*SIGMA(I) 320 - PRTOT=PRTOT+FRAC(I)*SIGMA(I)*ELVECT(I) 321 - 10 CONTINUE 322 - *** Normalise, provided things are not zero. 323 - IF(FRTOT.NE.0.AND.CSTOT.NE.0)THEN 324 - CSTOT=CSTOT/FRTOT 325 - PRTOT=PRTOT/FRTOT 326 - ELOSS=PRTOT/CSTOT 327 - PATH=1/(XLOSCH*CSTOT) 328 - ELSE 329 - ELOSS=0.0 330 - PATH=0.0 331 - ENDIF 332 - END 526 GARFIELD ================================================== P=GAS D=GASMXB 1 ============================ 0 + +DECK,GASMXB. 1 - SUBROUTINE GASMXB 2 - *----------------------------------------------------------------------- 3 - * GASMXB - Sets the break points for the integration routines, find 4 - * the lowest ionisation potential and store the gas name. 5 - * REFERENCE : Ionisation data from Handbook of Chemistry and Physics, 6 - * 72nd edition 1991-1992, CRC press, p 10-211 to 10-219, 7 - * Edited by David R. Lide. 8 - * (Last changed on 23/ 2/99.) 9 - *----------------------------------------------------------------------- 10.- +SEQ,DIMENSIONS. 1 526 P=GAS D=GASMXB 2 PAGE 790 11.- +SEQ,GASMIXDATA. 12.- +SEQ,GASDATA. 13.- +SEQ,PRINTPLOT. 14 - CHARACTER*169 AUX 15 - *** Initial value of the ionisation level. 16 - ECRIT=1.0E10 17 - *** Initial value of the break point list. 18 - NBREAK=1 19 - BREAK(1)=0.0 20 - *** Blank the gas name string. 21 - AUX=' ' 22 - GASID=' ' 23 - *** Argon (Ar). 24 - IF(FRAC(1).GT.0.0)THEN 25 - * Break points. 26 - BREAK(NBREAK+1)=0.3 27 - BREAK(NBREAK+2)=1.15 28 - BREAK(NBREAK+3)=11.5 29 - NBREAK=NBREAK+3 30 - * Name. 31 - WRITE(AUX(1:13),'(''Ar !'',I3,''%,!'')') 32 - - NINT(FRAC(1)*100.0) 33 - * Ionisation levels. 34 - ECRIT=MIN(15.759,ECRIT) 35 - ENDIF 36 - *** Methane (CH4). 37 - IF(FRAC(2).GT.0.0)THEN 38 - * Break points. 39 - BREAK(NBREAK+1)=0.3 40 - BREAK(NBREAK+2)=0.36 41 - BREAK(NBREAK+3)=2.0 42 - BREAK(NBREAK+4)=8.0 43 - NBREAK=NBREAK+4 44 - * Name. 45 - WRITE(AUX(14:26),'(''CH4 !'',I3,''%,!'')') 46 - - NINT(FRAC(2)*100.0) 47 - * Ionisation levels. 48 - ECRIT=MIN(12.6,ECRIT) 49 - ENDIF 50 - *** Neon (Ne). 51 - IF(FRAC(3).GT.0.0)THEN 52 - * Break points. 53 - BREAK(NBREAK+1)=7 54 - NBREAK=NBREAK+1 55 - * Name. 56 - WRITE(AUX(27:39),'(''Ne !'',I3,''%,!'')') 57 - - NINT(FRAC(3)*100.0) 58 - * Ionisation levels. 59 - ECRIT=MIN(21.564,ECRIT) 60 - ENDIF 61 - *** Isobutane (C4 H10). 62 - IF(FRAC(4).GT.0.0)THEN 63 - * Break points. 64 - BREAK(NBREAK+1)=0.20 65 - BREAK(NBREAK+2)=0.36 66 - BREAK(NBREAK+3)=0.60 67 - BREAK(NBREAK+4)=8.0 68 - NBREAK=NBREAK+4 69 - * Name. 70 - WRITE(AUX(40:52),'(''C4H10 !'',I3,''%,!'')') 71 - - NINT(FRAC(4)*100.0) 72 - * Ionisation levels (n-C4H10: 10.63 eV, iso: 10.57 eV). 73 - ECRIT=MIN(10.6,ECRIT) 74 - ENDIF 75 - *** CO2. 76 - IF(FRAC(5).GT.0.0)THEN 77 - * Break points. 78 - BREAK(NBREAK+1)=0.20 79 - BREAK(NBREAK+2)=1.32 80 - BREAK(NBREAK+3)=3.25 81 - BREAK(NBREAK+4)=4.2 82 - BREAK(NBREAK+5)=6.0 83 - BREAK(NBREAK+6)=25.0 84 - NBREAK=NBREAK+6 85 - * Name. 86 - WRITE(AUX(53:65),'(''CO2 !'',I3,''%,!'')') 87 - - NINT(FRAC(5)*100.0) 88 - * Ionisation levels. 89 - ECRIT=MIN(13.769,ECRIT) 90 - ENDIF 91 - *** Helium (He). 92 - IF(FRAC(6).GT.0.0)THEN 93 - * Break points. 94 - NBREAK=NBREAK 95 - * Name. 96 - WRITE(AUX(157:169),'(''He !'',I3,''%,!'')') 97 - - NINT(FRAC(6)*100.0) 98 - * Ionisation levels. 99 - ECRIT=MIN(24.587,ECRIT) 100 - ENDIF 101 - *** Ethane (C2 H6). 102 - IF(FRAC(7).GT.0.0)THEN 103 - * Break points. 104 - BREAK(NBREAK+1)=0.025 105 - BREAK(NBREAK+2)=0.035 106 - BREAK(NBREAK+3)=0.07 107 - BREAK(NBREAK+4)=0.09 108 - BREAK(NBREAK+5)=0.2 109 - BREAK(NBREAK+6)=0.3 110 - BREAK(NBREAK+7)=0.36 111 - BREAK(NBREAK+8)=0.6 112 - BREAK(NBREAK+9)=1.0 113 - NBREAK=NBREAK+9 114 - * Name. 115 - WRITE(AUX(66:78),'(''C2H6 !'',I3,''%,!'')') 116 - - NINT(FRAC(7)*100.0) 1 526 P=GAS D=GASMXB 3 PAGE 791 117 - * Ionisation levels. 118 - ECRIT=MIN(11.5,ECRIT) 119 - ENDIF 120 - *** Nitrogen (N). 121 - IF(FRAC(8).GT.0.0)THEN 122 - * Break points. 123 - BREAK(NBREAK+1)=1.3 124 - BREAK(NBREAK+2)=1.4 125 - BREAK(NBREAK+3)=1.5 126 - BREAK(NBREAK+4)=1.6 127 - BREAK(NBREAK+5)=1.7 128 - BREAK(NBREAK+6)=1.8 129 - BREAK(NBREAK+7)=1.9 130 - BREAK(NBREAK+8)=2.0 131 - BREAK(NBREAK+9)=5.0 132 - NBREAK=NBREAK+9 133 - * Name. 134 - WRITE(AUX(79:91),'(''N !'',I3,''%,!'')') 135 - - NINT(FRAC(8)*100.0) 136 - * Ionisation levels. 137 - ECRIT=MIN(14.534,ECRIT) 138 - ENDIF 139 - *** Xenon (Xe). 140 - IF(FRAC(9).GT.0.0)THEN 141 - * Break points. 142 - BREAK(NBREAK+1)=0.01 143 - BREAK(NBREAK+2)=0.035 144 - BREAK(NBREAK+3)=0.1 145 - BREAK(NBREAK+4)=0.18 146 - BREAK(NBREAK+5)=0.5 147 - BREAK(NBREAK+6)=0.7 148 - BREAK(NBREAK+7)=2.0 149 - BREAK(NBREAK+8)=4.1 150 - BREAK(NBREAK+9)=10.0 151 - NBREAK=NBREAK+9 152 - * Name. 153 - WRITE(AUX(92:104),'(''Xe !'',I3,''%,!'')') 154 - - NINT(FRAC(9)*100.0) 155 - * Ionisation levels. 156 - ECRIT=MIN(12.130,ECRIT) 157 - ENDIF 158 - *** Methylal (C3 H8 O2). 159 - IF(FRAC(10).GT.0.0)THEN 160 - * Break points. 161 - BREAK(NBREAK+1)=0.36 162 - BREAK(NBREAK+2)=2.0 163 - BREAK(NBREAK+3)=4.0 164 - NBREAK=NBREAK+3 165 - * Name. 166 - WRITE(AUX(105:117),'(''C3H8O2!'',I3,''%,!'')') 167 - - NINT(FRAC(10)*100.0) 168 - * Ionisation levels (n-C3H7OH: 10.1 eV, iso: 10.15 eV). 169 - ECRIT=MIN(10.1,ECRIT) 170 - ENDIF 171 - *** Krypton. 172 - IF(FRAC(11).GT.0.0)THEN 173 - * Break points. 174 - BREAK(NBREAK+1)=0.01 175 - BREAK(NBREAK+2)=0.02 176 - BREAK(NBREAK+3)=0.04 177 - BREAK(NBREAK+4)=0.07 178 - BREAK(NBREAK+5)=0.1 179 - BREAK(NBREAK+6)=0.145 180 - BREAK(NBREAK+7)=0.2 181 - BREAK(NBREAK+8)=0.3 182 - BREAK(NBREAK+9)=0.4 183 - BREAK(NBREAK+10)=0.5 184 - BREAK(NBREAK+11)=0.6 185 - BREAK(NBREAK+12)=0.8 186 - BREAK(NBREAK+13)=1.0 187 - BREAK(NBREAK+14)=2.0 188 - BREAK(NBREAK+15)=3.0 189 - BREAK(NBREAK+16)=4.0 190 - BREAK(NBREAK+17)=5.0 191 - BREAK(NBREAK+18)=7.0 192 - BREAK(NBREAK+19)=10.0 193 - NBREAK=NBREAK+19 194 - * Name. 195 - WRITE(AUX(118:130),'(''Kr !'',I3,''%,!'')') 196 - - NINT(FRAC(11)*100.0) 197 - * Ionisation levels. 198 - ECRIT=MIN(13.999961,ECRIT) 199 - ENDIF 200 - *** Ammonia. 201 - IF(FRAC(12).GT.0.0)THEN 202 - * Break points. 203 - BREAK(NBREAK+1)=0.01 204 - BREAK(NBREAK+2)=0.02 205 - BREAK(NBREAK+3)=0.04 206 - BREAK(NBREAK+4)=0.1 207 - BREAK(NBREAK+5)=0.2 208 - BREAK(NBREAK+6)=0.4 209 - BREAK(NBREAK+7)=1.0 210 - BREAK(NBREAK+8)=2.0 211 - BREAK(NBREAK+9)=3.0 212 - BREAK(NBREAK+10)=5.0 213 - BREAK(NBREAK+11)=7.0 214 - BREAK(NBREAK+12)=10.0 215 - NBREAK=NBREAK+12 216 - * Name. 217 - WRITE(AUX(131:143),'(''NH3 !'',I3,''%,!'')') 218 - - NINT(FRAC(12)*100.0) 219 - * Ionisation levels. 220 - ECRIT=MIN(10.16,ECRIT) 221 - ENDIF 222 - *** Test gas. 1 526 P=GAS D=GASMXB 4 PAGE 792 223 - IF(FRAC(13).GT.0.0)THEN 224 - * Break points. 225 - NBREAK=NBREAK 226 - * Name. 227 - WRITE(AUX(144:156),'(''Test !'',I3,''%,!'')') 228 - - NINT(FRAC(13)*100.0) 229 - * Ionisation levels. 230 - ECRIT=ECRIT 231 - ENDIF 232 - *** Sort the break points upwards. 233 - CALL FLPSOR(BREAK,NBREAK) 234 - *** List the break points if debugging has been requested. 235 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASMXB DEBUG : Number of'', 236 - - '' integration break points: '',I3/ 237 - - (26X,5(F10.3:)/))') NBREAK,(BREAK(I),I=1,NBREAK) 238 - *** Get rid of blanks in the gas name. 239 - NOUT=0 240 - DO 10 I=1,169 241 - IF(AUX(I:I).NE.' ')THEN 242 - NOUT=NOUT+1 243 - IF(NOUT.LE.80.AND.AUX(I:I).EQ.'!')THEN 244 - GASID(NOUT:NOUT)=' ' 245 - ELSEIF(NOUT.LE.80)THEN 246 - GASID(NOUT:NOUT)=AUX(I:I) 247 - ENDIF 248 - ENDIF 249 - 10 CONTINUE 250 - IF(NOUT.GT.80)THEN 251 - GASID(78:80)='...' 252 - NOUT=80 253 - ELSE 254 - GASID(NOUT-1:NOUT)='. ' 255 - NOUT=NOUT-1 256 - ENDIF 257 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASMXB DEBUG : Name: '', 258 - - A)') GASID(1:NOUT) 259 - *** Lowest ionisation level. 260 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASMXB DEBUG : Lowest'', 261 - - '' ionisation level at '',F10.3,'' eV.'')') ECRIT 262 - END 527 GARFIELD ================================================== P=GAS D=GASMG1 1 ============================ 0 + +DECK,GASMG1. 1 - DOUBLE PRECISION FUNCTION GASMG1(F,END,X) 2 - *----------------------------------------------------------------------- 3 - * GASMG2 - Called by the gas mixing routines for integrations. Breaks 4 - * the integration up into steps without discontinuitites so 5 - * that Gaussian integration by DGMLT works. 6 - * (Last changed on 28/ 9/92.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,GASMIXDATA. 11 - DOUBLE PRECISION A,B,END,X(*),DGMLT1 12 - INTEGER I,NPOINT 13 - EXTERNAL F,DGMLT1 14 - *** Initial value. 15 - GASMG1=0.0D0 16 - DO 10 I=1,MAX(1,NBREAK) 17 - IF(BREAK(I).GE.END)RETURN 18 - A=BREAK(I) 19 - IF(I.GE.NBREAK)THEN 20 - B=END 21 - ELSE 22 - B=MIN(END,DBLE(BREAK(I+1))) 23 - ENDIF 24 - NPOINT=MAX(1,NINT((B-A)/ESTEP)) 25 - GASMG1=GASMG1+DGMLT1(F,A,B,NPOINT,6,X) 26 - 10 CONTINUE 27 - END 528 GARFIELD ================================================== P=GAS D=GASMG2 1 ============================ 0 + +DECK,GASMG2. 1 - DOUBLE PRECISION FUNCTION GASMG2(F,END,X) 2 - *----------------------------------------------------------------------- 3 - * GASMG2 - Called by the gas mixing routines for integrations. Breaks 4 - * the integration up into steps without discontinuitites so 5 - * that Gaussian integration by DGMLT works. 6 - * (Last changed on 28/ 9/92.) 7 - *----------------------------------------------------------------------- 8.- +SEQ,DIMENSIONS. 9.- +SEQ,GASMIXDATA. 10 - EXTERNAL F,DGMLT2 11 - DOUBLE PRECISION A,B,END,X(*),DGMLT2 12 - *** Initial value. 13 - GASMG2=0.0D0 14 - DO 10 I=1,MAX(1,NBREAK) 15 - IF(BREAK(I).GE.END)RETURN 16 - A=BREAK(I) 17 - IF(I.GE.NBREAK)THEN 18 - B=END 19 - ELSE 20 - B=MIN(END,DBLE(BREAK(I+1))) 21 - ENDIF 22 - NPOINT=MAX(1,NINT((B-A)/ESTEP)) 23 - GASMG2=GASMG2+DGMLT2(F,A,B,NPOINT,6,X) 24 - 10 CONTINUE 25 - END 1 529 GARFIELD ================================================== P=GAS D=GASPLT 1 =================== PAGE 793 0 + +DECK,GASPLT. 1 - SUBROUTINE GASPLT 2 - *----------------------------------------------------------------------- 3 - * GASPLT - Routine plotting the drift velocity, the diffusion coeff 4 - * and the cluster size distribution. 5 - * VARIABLES : XPL, YPL : Arrays used for plotting. 6 - * (Last changed on 20/ 2/00.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,PARAMETERS. 11.- +SEQ,GASDATA. 12.- +SEQ,PRINTPLOT. 13.- +SEQ,BFIELD. 14.- +SEQ,CONSTANTS. 15 - REAL XPL(MXLIST),YPL(MXLIST),YPL3(0:MXPAIR+1),YPLMIN,YPLMAX, 16 - - GASATT,GASTWN,GASDFL,GASDFT,GASMOB,GASLOR,GASVEL,GASVT1, 17 - - GASVT2,EMIN,EMAX,AUX1(1),AUX2(1),DY 18 - CHARACTER*20 STR1,STR2,STR3 19 - INTEGER I,J,K,NC1,NC2,NC3 20 - EXTERNAL GASATT,GASTWN,GASDFL,GASDFT,GASMOB,GASLOR,GASVEL, 21 - - GASVT1,GASVT2 22 - *** Identify the routine. 23 - IF(LIDENT)PRINT *,' /// ROUTINE GASPLT ///' 24 - *** Check that logarithmic plotting is possible. 25 - IF((GASOK(1).OR.GASOK(2).OR.GASOK(3).OR.GASOK(4).OR. 26 - - GASOK(6).OR.GASOK(7).OR.GASOK(8).OR.GASOK(9).OR. 27 - - GASOK(10)).AND.EGAS(1).LE.0.0) 28 - - PRINT *,' !!!!!! GASPLT WARNING : First point in the gas'// 29 - - ' table is not > 0 ; logarithmic plotting impossible' 30 - *** Broaden the scale a little to show the extrapolation. 31 - IF(NGAS.LT.1)THEN 32 - PRINT *,' !!!!!! GASPLT WARNING : No gas data points; '// 33 - - ' no plots made.' 34 - RETURN 35 - ENDIF 36 - *** Plot the drift velocity. 37 - IF(GASOPT(1,3).AND.(GASOK(1).OR.GASOK(9).OR.GASOK(10)))THEN 38 - * Set the electric field range. 39 - IF(GASOPT(1,1))THEN 40 - EMIN=MAX(1.0,PGAS*EGAS(1)/1.5) 41 - EMAX=PGAS*EGAS(NGAS)*1.5 42 - DO 101 I=1,MXLIST 43 - XPL(I)=EMIN*(EMAX/EMIN)**(REAL(I-1)/REAL(MXLIST-1)) 44 - 101 CONTINUE 45 - ELSE 46 - EMIN=MAX(0.0,PGAS*(EGAS(1)-ABS(EGAS(NGAS)-EGAS(1))/20)) 47 - EMAX=PGAS*(EGAS(NGAS)+ABS(EGAS(NGAS)-EGAS(1))/20) 48 - DO 102 I=1,MXLIST 49 - XPL(I)=EMIN+REAL(I-1)*(EMAX-EMIN)/REAL(MXLIST-1) 50 - 102 CONTINUE 51 - ENDIF 52 - * Determine the scale of the graph. 53 - IF(GASOPT(1,4))THEN 54 - YPLMIN=GASRNG(1,1) 55 - YPLMAX=GASRNG(1,2) 56 - ELSEIF(TAB2D)THEN 57 - IF(GASOK(1))THEN 58 - YPLMIN=VGAS2(1,1,1) 59 - YPLMAX=VGAS2(1,1,1) 60 - ELSEIF(GASOK(9))THEN 61 - YPLMIN=XGAS2(1,1,1) 62 - YPLMAX=XGAS2(1,1,1) 63 - ELSE 64 - YPLMIN=YGAS2(1,1,1) 65 - YPLMAX=YGAS2(1,1,1) 66 - ENDIF 67 - DO 100 K=1,NBTAB 68 - DO 110 I=1,NGAS 69 - DO 120 J=1,NBANG 70 - IF(GASOK(1))THEN 71 - YPLMIN=MIN(YPLMIN,VGAS2(I,J,K)) 72 - YPLMAX=MAX(YPLMAX,VGAS2(I,J,K)) 73 - ENDIF 74 - IF(GASOK(9))THEN 75 - YPLMIN=MIN(YPLMIN,XGAS2(I,J,K)) 76 - YPLMAX=MAX(YPLMAX,XGAS2(I,J,K)) 77 - ENDIF 78 - IF(GASOK(10))THEN 79 - YPLMIN=MIN(YPLMIN,YGAS2(I,J,K)) 80 - YPLMAX=MAX(YPLMAX,YGAS2(I,J,K)) 81 - ENDIF 82 - 120 CONTINUE 83 - 110 CONTINUE 84 - 100 CONTINUE 85 - DY=(YPLMAX-YPLMIN)/20 86 - YPLMAX=YPLMAX+DY 87 - YPLMIN=YPLMIN-DY 88 - ELSE 89 - IF(GASOK(1))THEN 90 - YPLMIN=VGAS(1) 91 - YPLMAX=VGAS(1) 92 - ELSEIF(GASOK(9))THEN 93 - YPLMIN=XGAS(1) 94 - YPLMAX=XGAS(1) 95 - ELSE 96 - YPLMIN=YGAS(1) 97 - YPLMAX=YGAS(1) 98 - ENDIF 99 - DO 130 I=1,NGAS 100 - IF(GASOK(1))THEN 101 - YPLMIN=MIN(YPLMIN,VGAS(I)) 102 - YPLMAX=MAX(YPLMAX,VGAS(I)) 103 - ENDIF 104 - IF(GASOK(9))THEN 105 - YPLMIN=MIN(YPLMIN,XGAS(I)) 1 529 P=GAS D=GASPLT 2 PAGE 794 106 - YPLMAX=MAX(YPLMAX,XGAS(I)) 107 - ENDIF 108 - IF(GASOK(10))THEN 109 - YPLMIN=MIN(YPLMIN,YGAS(I)) 110 - YPLMAX=MAX(YPLMAX,YGAS(I)) 111 - ENDIF 112 - 130 CONTINUE 113 - DY=(YPLMAX-YPLMIN)/20 114 - YPLMAX=YPLMAX+DY 115 - YPLMIN=YPLMIN-DY 116 - ENDIF 117 - * Can be that the range is still nil or negative and log. 118 - IF(YPLMAX.LE.0)THEN 119 - PRINT *,' !!!!!! GASPLT WARNING : Drift velocity'// 120 - - ' is zero everywhere ; not plotted.' 121 - GOTO 199 122 - ENDIF 123 - IF(GASOPT(1,2))THEN 124 - IF(YPLMIN.LE.0)YPLMIN=1 125 - IF(YPLMAX.LE.YPLMIN)YPLMAX=100 126 - ELSE 127 - IF(YPLMIN.GT.0)YPLMIN=0 128 - IF(YPLMAX.LE.YPLMIN)YPLMAX=100 129 - ENDIF 130 - * Loop over the B fields. 131 - DO 140 K=1,NBTAB 132 - * Plot the frame. 133 - IF(GASOPT(1,1))THEN 134 - CALL GRAOPT('LOG-X') 135 - ELSE 136 - CALL GRAOPT('LIN-X') 137 - ENDIF 138 - IF(GASOPT(1,2))THEN 139 - CALL GRAOPT('LOG-Y') 140 - ELSE 141 - CALL GRAOPT('LIN-Y') 142 - ENDIF 143 - CALL GRCART(EMIN,YPLMIN,EMAX,YPLMAX, 144 - - 'E [V/cm]','Drift velocity [cm/microsec]', 145 - - 'Drift velocity vs E') 146 - IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) 147 - IF(TAB2D)THEN 148 - CALL OUTFMT(BTAB(K)/100,2,STR1,NC1,'LEFT') 149 - CALL GRCOMM(2,'B = '//STR1(1:NC1)//' T') 150 - CALL OUTFMT(180*BANG(1)/PI,2,STR1,NC1,'LEFT') 151 - CALL OUTFMT(180*BANG(NBANG)/PI,2,STR2,NC2,'LEFT') 152 - CALL OUTFMT(REAL(NBANG),2,STR3,NC3,'LEFT') 153 - CALL GRCOMM(4,STR1(1:NC1)//' < angle(E,B) < '// 154 - - STR2(1:NC2)//' degrees in '//STR3(1:NC3)// 155 - - ' steps') 156 - ENDIF 157 - * Plot and mark the various curves, first the E component. 158 - IF(GASOK(1))THEN 159 - CALL GRATTS('FUNCTION-1','POLYLINE') 160 - IF(TAB2D)THEN 161 - DO 150 I=1,NBANG 162 - DO 160 J=1,MXLIST 163 - YPL(J)=GASVEL(XPL(J),0.0,0.0,BTAB(K)*COS(BANG(I)), 164 - - BTAB(K)*SIN(BANG(I)),0.0) 165 - 160 CONTINUE 166 - CALL GRLINE(MXLIST,XPL,YPL) 167 - 150 CONTINUE 168 - ELSE 169 - DO 170 I=1,MXLIST 170 - YPL(I)=GASVEL(XPL(I),0.0,0.0,0.0,0.0,0.0) 171 - 170 CONTINUE 172 - CALL GRLINE(MXLIST,XPL,YPL) 173 - ENDIF 174 - CALL GRATTS('FUNCTION-1','POLYMARKER') 175 - DO 190 J=1,NGAS 176 - AUX1(1)=PGAS*EGAS(J) 177 - IF(TAB2D)THEN 178 - DO 180 I=1,NBANG 179 - AUX2(1)=VGAS2(J,I,K) 180 - CALL GRMARK(1,AUX1,AUX2) 181 - 180 CONTINUE 182 - ELSE 183 - AUX2(1)=VGAS(J) 184 - CALL GRMARK(1,AUX1,AUX2) 185 - ENDIF 186 - 190 CONTINUE 187 - ENDIF 188 - * Next the B component. 189 - IF(GASOK(9))THEN 190 - CALL GRATTS('FUNCTION-2','POLYLINE') 191 - IF(TAB2D)THEN 192 - DO 151 I=1,NBANG 193 - DO 161 J=1,MXLIST 194 - YPL(J)=GASVT1(XPL(J),0.0,0.0,BTAB(K)*COS(BANG(I)), 195 - - BTAB(K)*SIN(BANG(I)),0.0) 196 - 161 CONTINUE 197 - CALL GRLINE(MXLIST,XPL,YPL) 198 - 151 CONTINUE 199 - ELSE 200 - DO 171 I=1,MXLIST 201 - YPL(I)=GASVT1(XPL(I),0.0,0.0,0.0,0.0,0.0) 202 - 171 CONTINUE 203 - CALL GRLINE(MXLIST,XPL,YPL) 204 - ENDIF 205 - CALL GRATTS('FUNCTION-2','POLYMARKER') 206 - DO 191 J=1,NGAS 207 - AUX1(1)=PGAS*EGAS(J) 208 - IF(TAB2D)THEN 209 - DO 181 I=1,NBANG 210 - AUX2(1)=XGAS2(J,I,K) 211 - CALL GRMARK(1,AUX1,AUX2) 1 529 P=GAS D=GASPLT 3 PAGE 795 212 - 181 CONTINUE 213 - ELSE 214 - AUX2(1)=XGAS(J) 215 - CALL GRMARK(1,AUX1,AUX2) 216 - ENDIF 217 - 191 CONTINUE 218 - ENDIF 219 - * And finally the ExB component. 220 - IF(GASOK(10))THEN 221 - CALL GRATTS('FUNCTION-3','POLYLINE') 222 - IF(TAB2D)THEN 223 - DO 152 I=1,NBANG 224 - DO 162 J=1,MXLIST 225 - YPL(J)=GASVT2(XPL(J),0.0,0.0,BTAB(K)*COS(BANG(I)), 226 - - BTAB(K)*SIN(BANG(I)),0.0) 227 - 162 CONTINUE 228 - CALL GRLINE(MXLIST,XPL,YPL) 229 - 152 CONTINUE 230 - ELSE 231 - DO 172 I=1,MXLIST 232 - YPL(I)=GASVT2(XPL(I),0.0,0.0,0.0,0.0,0.0) 233 - 172 CONTINUE 234 - CALL GRLINE(MXLIST,XPL,YPL) 235 - ENDIF 236 - CALL GRATTS('FUNCTION-3','POLYMARKER') 237 - DO 192 J=1,NGAS 238 - AUX1(1)=PGAS*EGAS(J) 239 - IF(TAB2D)THEN 240 - DO 182 I=1,NBANG 241 - AUX2(1)=YGAS2(J,I,K) 242 - CALL GRMARK(1,AUX1,AUX2) 243 - 182 CONTINUE 244 - ELSE 245 - AUX2(1)=YGAS(J) 246 - CALL GRMARK(1,AUX1,AUX2) 247 - ENDIF 248 - 192 CONTINUE 249 - ENDIF 250 - CALL GRNEXT 251 - CALL GRALOG('Graph of the drift velocity vs E.') 252 - * Next B field. 253 - 140 CONTINUE 254 - ENDIF 255 - * Continue here if the plot was skipped. 256 - 199 CONTINUE 257 - *** Plot the ion mobility. 258 - IF(GASOPT(2,3).AND.GASOK(2))THEN 259 - * Set the electric field range. 260 - IF(GASOPT(2,1))THEN 261 - EMIN=MAX(1.0,PGAS*EGAS(1)/1.5) 262 - EMAX=PGAS*EGAS(NGAS)*1.5 263 - DO 201 I=1,MXLIST 264 - XPL(I)=EMIN*(EMAX/EMIN)**(REAL(I-1)/REAL(MXLIST-1)) 265 - 201 CONTINUE 266 - ELSE 267 - EMIN=MAX(0.0,PGAS*(EGAS(1)-ABS(EGAS(NGAS)-EGAS(1))/20)) 268 - EMAX=PGAS*(EGAS(NGAS)+ABS(EGAS(NGAS)-EGAS(1))/20) 269 - DO 202 I=1,MXLIST 270 - XPL(I)=EMIN+REAL(I-1)*(EMAX-EMIN)/REAL(MXLIST-1) 271 - 202 CONTINUE 272 - ENDIF 273 - * Determine the scale of the graph. 274 - IF(GASOPT(2,4))THEN 275 - YPLMIN=GASRNG(2,1) 276 - YPLMAX=GASRNG(2,2) 277 - ELSEIF(TAB2D)THEN 278 - YPLMIN=MGAS2(1,1,1) 279 - YPLMAX=MGAS2(1,1,1) 280 - DO 200 K=1,NBTAB 281 - DO 210 I=1,NGAS 282 - DO 220 J=1,NBANG 283 - YPLMIN=MIN(YPLMIN,MGAS2(I,J,K)) 284 - YPLMAX=MAX(YPLMAX,MGAS2(I,J,K)) 285 - 220 CONTINUE 286 - 210 CONTINUE 287 - 200 CONTINUE 288 - DY=(YPLMAX-YPLMIN)/20 289 - YPLMAX=YPLMAX+DY 290 - YPLMIN=YPLMIN-DY 291 - ELSE 292 - YPLMIN=MGAS(1) 293 - YPLMAX=MGAS(1) 294 - DO 230 I=2,NGAS 295 - YPLMIN=MIN(YPLMIN,MGAS(I)) 296 - YPLMAX=MAX(YPLMAX,MGAS(I)) 297 - 230 CONTINUE 298 - DY=(YPLMAX-YPLMIN)/20 299 - YPLMAX=YPLMAX+DY 300 - YPLMIN=YPLMIN-DY 301 - ENDIF 302 - * Loop over the B fields. 303 - DO 240 K=1,NBTAB 304 - * Plot the frame. 305 - IF(GASOPT(2,1))THEN 306 - CALL GRAOPT('LOG-X') 307 - ELSE 308 - CALL GRAOPT('LIN-X') 309 - ENDIF 310 - IF(GASOPT(2,2))THEN 311 - CALL GRAOPT('LOG-Y') 312 - ELSE 313 - CALL GRAOPT('LIN-Y') 314 - ENDIF 315 - CALL GRCART(EMIN,YPLMIN,EMAX,YPLMAX, 316 - - 'E [V/cm]','Ion mobility [cm2/V.microsec]', 317 - - 'Ion mobility vs E') 1 529 P=GAS D=GASPLT 4 PAGE 796 318 - IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) 319 - IF(TAB2D)THEN 320 - CALL OUTFMT(BTAB(K)/100,2,STR1,NC1,'LEFT') 321 - CALL GRCOMM(2,'B = '//STR1(1:NC1)//' T') 322 - CALL OUTFMT(180*BANG(1)/PI,2,STR1,NC1,'LEFT') 323 - CALL OUTFMT(180*BANG(NBANG)/PI,2,STR2,NC2,'LEFT') 324 - CALL OUTFMT(REAL(NBANG),2,STR3,NC3,'LEFT') 325 - CALL GRCOMM(4,STR1(1:NC1)//' < angle(E,B) < '// 326 - - STR2(1:NC2)//' degrees in '//STR3(1:NC3)// 327 - - ' steps') 328 - ENDIF 329 - * Plot the various curves. 330 - CALL GRATTS('FUNCTION-1','POLYLINE') 331 - IF(TAB2D)THEN 332 - DO 250 I=1,NBANG 333 - DO 260 J=1,MXLIST 334 - YPL(J)=GASMOB(XPL(J),0.0,0.0,BTAB(K)*COS(BANG(I)), 335 - - BTAB(K)*SIN(BANG(I)),0.0) 336 - 260 CONTINUE 337 - CALL GRLINE(MXLIST,XPL,YPL) 338 - 250 CONTINUE 339 - ELSE 340 - DO 270 I=1,MXLIST 341 - YPL(I)=GASMOB(XPL(I),0.0,0.0,0.0,0.0,0.0) 342 - 270 CONTINUE 343 - CALL GRLINE(MXLIST,XPL,YPL) 344 - ENDIF 345 - * Polymark the data, allowing a check on the interpolation. 346 - CALL GRATTS('FUNCTION-1','POLYMARKER') 347 - DO 290 J=1,NGAS 348 - AUX1(1)=PGAS*EGAS(J) 349 - IF(TAB2D)THEN 350 - DO 280 I=1,NBANG 351 - CALL GRMARK(1,AUX1,MGAS2(J,I,K)) 352 - 280 CONTINUE 353 - ELSE 354 - CALL GRMARK(1,AUX1,MGAS(J)) 355 - ENDIF 356 - 290 CONTINUE 357 - CALL GRNEXT 358 - CALL GRALOG('Graph of the ion mobility vs E.') 359 - * Next B field. 360 - 240 CONTINUE 361 - ENDIF 362 - *** Plot the diffusion coefficients. 363 - IF(GASOPT(3,3).AND.(GASOK(3).OR.GASOK(8)))THEN 364 - * Set the electric field range. 365 - IF(GASOPT(3,1))THEN 366 - EMIN=MAX(1.0,PGAS*EGAS(1)/1.5) 367 - EMAX=PGAS*EGAS(NGAS)*1.5 368 - DO 301 I=1,MXLIST 369 - XPL(I)=EMIN*(EMAX/EMIN)**(REAL(I-1)/REAL(MXLIST-1)) 370 - 301 CONTINUE 371 - ELSE 372 - EMIN=MAX(0.0,PGAS*(EGAS(1)-ABS(EGAS(NGAS)-EGAS(1))/20)) 373 - EMAX=PGAS*(EGAS(NGAS)+ABS(EGAS(NGAS)-EGAS(1))/20) 374 - DO 302 I=1,MXLIST 375 - XPL(I)=EMIN+REAL(I-1)*(EMAX-EMIN)/REAL(MXLIST-1) 376 - 302 CONTINUE 377 - ENDIF 378 - * Determine the scale of the graph. 379 - IF(GASOPT(3,4))THEN 380 - YPLMIN=GASRNG(3,1) 381 - YPLMAX=GASRNG(3,2) 382 - ELSEIF(TAB2D)THEN 383 - IF(GASOK(3))THEN 384 - YPLMIN=DGAS2(1,1,1)*10000/SQRT(PGAS) 385 - YPLMAX=DGAS2(1,1,1)*10000/SQRT(PGAS) 386 - ELSE 387 - YPLMIN=OGAS2(1,1,1)*10000/SQRT(PGAS) 388 - YPLMAX=OGAS2(1,1,1)*10000/SQRT(PGAS) 389 - ENDIF 390 - DO 300 K=1,NBTAB 391 - DO 310 I=1,NGAS 392 - DO 320 J=1,NBANG 393 - IF(GASOK(3))THEN 394 - YPLMIN=MIN(YPLMIN,DGAS2(I,J,K)*10000/SQRT(PGAS)) 395 - YPLMAX=MAX(YPLMAX,DGAS2(I,J,K)*10000/SQRT(PGAS)) 396 - ENDIF 397 - IF(GASOK(8))THEN 398 - YPLMIN=MIN(YPLMIN,OGAS2(I,J,K)*10000/SQRT(PGAS)) 399 - YPLMAX=MAX(YPLMAX,OGAS2(I,J,K)*10000/SQRT(PGAS)) 400 - ENDIF 401 - 320 CONTINUE 402 - 310 CONTINUE 403 - 300 CONTINUE 404 - DY=(YPLMAX-YPLMIN)/20 405 - YPLMAX=YPLMAX+DY 406 - YPLMIN=YPLMIN-DY 407 - ELSE 408 - IF(GASOK(3))THEN 409 - YPLMIN=DGAS(1)*10000/SQRT(PGAS) 410 - YPLMAX=DGAS(1)*10000/SQRT(PGAS) 411 - ELSE 412 - YPLMIN=OGAS(1) 413 - YPLMAX=OGAS(1) 414 - ENDIF 415 - DO 330 I=1,NGAS 416 - IF(GASOK(3))THEN 417 - YPLMIN=MIN(YPLMIN,DGAS(I)*10000/SQRT(PGAS)) 418 - YPLMAX=MAX(YPLMAX,DGAS(I)*10000/SQRT(PGAS)) 419 - ENDIF 420 - IF(GASOK(8))THEN 421 - YPLMIN=MIN(YPLMIN,OGAS(I)*10000/SQRT(PGAS)) 422 - YPLMAX=MAX(YPLMAX,OGAS(I)*10000/SQRT(PGAS)) 423 - ENDIF 1 529 P=GAS D=GASPLT 5 PAGE 797 424 - 330 CONTINUE 425 - DY=(YPLMAX-YPLMIN)/20 426 - YPLMAX=YPLMAX+DY 427 - YPLMIN=YPLMIN-DY 428 - ENDIF 429 - * Can be that the range is still nil or negative and log. 430 - IF(YPLMAX.LE.0)THEN 431 - PRINT *,' !!!!!! GASPLT WARNING : Diffusion'// 432 - - ' coefficients = 0 ; not plotted.' 433 - GOTO 399 434 - ENDIF 435 - IF(GASOPT(3,2))THEN 436 - IF(YPLMIN.LE.0)YPLMIN=1 437 - IF(YPLMAX.LE.YPLMIN)YPLMAX=1000 438 - ELSE 439 - YPLMIN=0 440 - IF(YPLMAX.LE.YPLMIN)YPLMAX=1000 441 - ENDIF 442 - * Loop over the B fields. 443 - DO 340 K=1,NBTAB 444 - * Plot the frame. 445 - IF(GASOPT(3,1))THEN 446 - CALL GRAOPT('LOG-X') 447 - ELSE 448 - CALL GRAOPT('LIN-X') 449 - ENDIF 450 - IF(GASOPT(3,2))THEN 451 - CALL GRAOPT('LOG-Y') 452 - ELSE 453 - CALL GRAOPT('LIN-Y') 454 - ENDIF 455 - CALL GRCART(EMIN,YPLMIN,EMAX,YPLMAX, 456 - - 'E [V/cm]','Diffusion [micron for 1 cm]', 457 - - 'Diffusion coefficients vs E') 458 - IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) 459 - IF(TAB2D)THEN 460 - CALL OUTFMT(BTAB(K)/100,2,STR1,NC1,'LEFT') 461 - CALL GRCOMM(2,'B = '//STR1(1:NC1)//' T') 462 - CALL OUTFMT(180*BANG(1)/PI,2,STR1,NC1,'LEFT') 463 - CALL OUTFMT(180*BANG(NBANG)/PI,2,STR2,NC2,'LEFT') 464 - CALL OUTFMT(REAL(NBANG),2,STR3,NC3,'LEFT') 465 - CALL GRCOMM(4,STR1(1:NC1)//' < angle(E,B) < '// 466 - - STR2(1:NC2)//' degrees in '//STR3(1:NC3)// 467 - - ' steps') 468 - ENDIF 469 - * Plot and mark the various curves. 470 - IF(GASOK(3))THEN 471 - CALL GRATTS('FUNCTION-1','POLYLINE') 472 - IF(TAB2D)THEN 473 - DO 350 I=1,NBANG 474 - DO 360 J=1,MXLIST 475 - YPL(J)=10000*GASDFL(XPL(J),0.0,0.0, 476 - - BTAB(K)*COS(BANG(I)), 477 - - BTAB(K)*SIN(BANG(I)),0.0) 478 - 360 CONTINUE 479 - CALL GRLINE(MXLIST,XPL,YPL) 480 - 350 CONTINUE 481 - ELSE 482 - DO 370 I=1,MXLIST 483 - YPL(I)=10000*GASDFL(XPL(I),0.0,0.0,0.0,0.0,0.0) 484 - 370 CONTINUE 485 - CALL GRLINE(MXLIST,XPL,YPL) 486 - ENDIF 487 - CALL GRATTS('FUNCTION-1','POLYMARKER') 488 - DO 390 J=1,NGAS 489 - AUX1(1)=PGAS*EGAS(J) 490 - IF(TAB2D)THEN 491 - DO 380 I=1,NBANG 492 - AUX2(1)=10000*DGAS2(J,I,K)/SQRT(PGAS) 493 - CALL GRMARK(1,AUX1,AUX2) 494 - 380 CONTINUE 495 - ELSE 496 - AUX2(1)=10000*DGAS(J)/SQRT(PGAS) 497 - CALL GRMARK(1,AUX1,AUX2) 498 - ENDIF 499 - 390 CONTINUE 500 - ENDIF 501 - IF(GASOK(8))THEN 502 - CALL GRATTS('FUNCTION-2','POLYLINE') 503 - IF(TAB2D)THEN 504 - DO 355 I=1,NBANG 505 - DO 365 J=1,MXLIST 506 - YPL(J)=10000*GASDFT(XPL(J),0.0,0.0, 507 - - BTAB(K)*COS(BANG(I)), 508 - - BTAB(K)*SIN(BANG(I)),0.0) 509 - 365 CONTINUE 510 - CALL GRLINE(MXLIST,XPL,YPL) 511 - 355 CONTINUE 512 - ELSE 513 - DO 375 I=1,MXLIST 514 - YPL(I)=10000*GASDFT(XPL(I),0.0,0.0,0.0,0.0,0.0) 515 - 375 CONTINUE 516 - CALL GRLINE(MXLIST,XPL,YPL) 517 - ENDIF 518 - CALL GRATTS('FUNCTION-2','POLYMARKER') 519 - DO 395 J=1,NGAS 520 - AUX1(1)=PGAS*EGAS(J) 521 - IF(TAB2D)THEN 522 - DO 385 I=1,NBANG 523 - AUX2(1)=10000*OGAS2(J,I,K)/SQRT(PGAS) 524 - CALL GRMARK(1,AUX1,AUX2) 525 - 385 CONTINUE 526 - ELSE 527 - AUX2(1)=10000*OGAS(J)/SQRT(PGAS) 528 - CALL GRMARK(1,AUX1,AUX2) 529 - ENDIF 1 529 P=GAS D=GASPLT 6 PAGE 798 530 - 395 CONTINUE 531 - ENDIF 532 - CALL GRNEXT 533 - CALL GRALOG('Graph of the diffusion coefficients vs E.') 534 - * Next B field. 535 - 340 CONTINUE 536 - ENDIF 537 - * Continue here if the plot was skipped. 538 - 399 CONTINUE 539 - *** Plot the Townsend and attachment coefficients. 540 - IF(GASOPT(4,3).AND.(GASOK(4).OR.GASOK(6)))THEN 541 - * Set the electric field range. 542 - IF(GASOPT(4,1))THEN 543 - EMIN=MAX(1.0,PGAS*EGAS(1)/1.5) 544 - EMAX=PGAS*EGAS(NGAS)*1.5 545 - DO 401 I=1,MXLIST 546 - XPL(I)=EMIN*(EMAX/EMIN)**(REAL(I-1)/REAL(MXLIST-1)) 547 - 401 CONTINUE 548 - ELSE 549 - EMIN=MAX(0.0,PGAS*(EGAS(1)-ABS(EGAS(NGAS)-EGAS(1))/20)) 550 - EMAX=PGAS*(EGAS(NGAS)+ABS(EGAS(NGAS)-EGAS(1))/20) 551 - DO 402 I=1,MXLIST 552 - XPL(I)=EMIN+REAL(I-1)*(EMAX-EMIN)/REAL(MXLIST-1) 553 - 402 CONTINUE 554 - ENDIF 555 - * Determine the scale of the graph. 556 - IF(GASOPT(4,4))THEN 557 - YPLMIN=GASRNG(4,1) 558 - YPLMAX=GASRNG(4,2) 559 - ELSEIF(TAB2D)THEN 560 - IF(GASOK(4))THEN 561 - YPLMIN=EXP(AGAS2(1,1,1))*PGAS 562 - YPLMAX=EXP(AGAS2(1,1,1))*PGAS 563 - ELSE 564 - YPLMIN=EXP(BGAS2(1,1,1))*PGAS 565 - YPLMAX=EXP(BGAS2(1,1,1))*PGAS 566 - ENDIF 567 - DO 400 K=1,NBTAB 568 - DO 410 I=1,NGAS 569 - DO 420 J=1,NBANG 570 - IF(GASOK(4))THEN 571 - YPLMIN=MIN(YPLMIN,EXP(AGAS2(I,J,K))*PGAS) 572 - YPLMAX=MAX(YPLMAX,EXP(AGAS2(I,J,K))*PGAS) 573 - ENDIF 574 - IF(GASOK(6))THEN 575 - YPLMIN=MIN(YPLMIN,EXP(BGAS2(I,J,K))*PGAS) 576 - YPLMAX=MAX(YPLMAX,EXP(BGAS2(I,J,K))*PGAS) 577 - ENDIF 578 - 420 CONTINUE 579 - 410 CONTINUE 580 - 400 CONTINUE 581 - DY=(YPLMAX-YPLMIN)/20 582 - YPLMAX=YPLMAX+DY 583 - YPLMIN=YPLMIN-DY 584 - ELSE 585 - IF(GASOK(4))THEN 586 - YPLMIN=EXP(AGAS(1))*PGAS 587 - YPLMAX=EXP(AGAS(1))*PGAS 588 - ELSE 589 - YPLMIN=EXP(BGAS(1))*PGAS 590 - YPLMAX=EXP(BGAS(1))*PGAS 591 - ENDIF 592 - DO 430 I=1,NGAS 593 - IF(GASOK(4))THEN 594 - YPLMIN=MIN(YPLMIN,EXP(AGAS(I))*PGAS) 595 - YPLMAX=MAX(YPLMAX,EXP(AGAS(I))*PGAS) 596 - ENDIF 597 - IF(GASOK(6))THEN 598 - YPLMIN=MIN(YPLMIN,EXP(BGAS(I))*PGAS) 599 - YPLMAX=MAX(YPLMAX,EXP(BGAS(I))*PGAS) 600 - ENDIF 601 - 430 CONTINUE 602 - DY=(YPLMAX-YPLMIN)/20 603 - YPLMAX=YPLMAX+DY 604 - YPLMIN=YPLMIN-DY 605 - ENDIF 606 - * Can be that the range is still nil or negative and log. 607 - IF(YPLMAX.LE.-20)THEN 608 - PRINT *,' !!!!!! GASPLT WARNING : Townsend and'// 609 - - ' attachment coefficients = 0 ; not plotted.' 610 - GOTO 499 611 - ENDIF 612 - IF(GASOPT(4,2))THEN 613 - IF(YPLMIN.LE.0.01)YPLMIN=0.01 614 - IF(YPLMAX.LE.YPLMIN)YPLMAX=YPLMIN*2 615 - ELSE 616 - YPLMIN=0 617 - IF(YPLMAX.LE.YPLMIN)YPLMAX=1000 618 - ENDIF 619 - * Loop over the B fields. 620 - DO 440 K=1,NBTAB 621 - * Plot the frame. 622 - IF(GASOPT(4,1))THEN 623 - CALL GRAOPT('LOG-X') 624 - ELSE 625 - CALL GRAOPT('LIN-X') 626 - ENDIF 627 - IF(GASOPT(4,2))THEN 628 - CALL GRAOPT('LOG-Y') 629 - ELSE 630 - CALL GRAOPT('LIN-Y') 631 - ENDIF 632 - CALL GRCART(EMIN,YPLMIN,EMAX,YPLMAX, 633 - - 'E [V/cm]','Townsend and attachment coeff. [1/cm]', 634 - - 'Townsend and attachment coeff. vs E') 635 - IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) 1 529 P=GAS D=GASPLT 7 PAGE 799 636 - IF(TAB2D)THEN 637 - CALL OUTFMT(BTAB(K)/100,2,STR1,NC1,'LEFT') 638 - CALL GRCOMM(2,'B = '//STR1(1:NC1)//' T') 639 - CALL OUTFMT(180*BANG(1)/PI,2,STR1,NC1,'LEFT') 640 - CALL OUTFMT(180*BANG(NBANG)/PI,2,STR2,NC2,'LEFT') 641 - CALL OUTFMT(REAL(NBANG),2,STR3,NC3,'LEFT') 642 - CALL GRCOMM(4,STR1(1:NC1)//' < angle(E,B) < '// 643 - - STR2(1:NC2)//' degrees in '//STR3(1:NC3)// 644 - - ' steps') 645 - ENDIF 646 - * Plot and mark the various curves. 647 - IF(GASOK(4))THEN 648 - CALL GRATTS('FUNCTION-1','POLYLINE') 649 - IF(TAB2D)THEN 650 - DO 450 I=1,NBANG 651 - DO 460 J=1,MXLIST 652 - YPL(J)=GASTWN(XPL(J),0.0,0.0, 653 - - BTAB(K)*COS(BANG(I)), 654 - - BTAB(K)*SIN(BANG(I)),0.0) 655 - 460 CONTINUE 656 - CALL GRLINE(MXLIST,XPL,YPL) 657 - 450 CONTINUE 658 - ELSE 659 - DO 470 I=1,MXLIST 660 - YPL(I)=GASTWN(XPL(I),0.0,0.0,0.0,0.0,0.0) 661 - 470 CONTINUE 662 - CALL GRLINE(MXLIST,XPL,YPL) 663 - ENDIF 664 - CALL GRATTS('FUNCTION-1','POLYMARKER') 665 - DO 490 J=1,NGAS 666 - AUX1(1)=PGAS*EGAS(J) 667 - IF(TAB2D)THEN 668 - DO 480 I=1,NBANG 669 - AUX2(1)=EXP(AGAS2(J,I,K))*PGAS 670 - CALL GRMARK(1,AUX1,AUX2) 671 - 480 CONTINUE 672 - ELSE 673 - AUX2(1)=EXP(AGAS(J))*PGAS 674 - CALL GRMARK(1,AUX1,AUX2) 675 - ENDIF 676 - 490 CONTINUE 677 - ENDIF 678 - IF(GASOK(6))THEN 679 - CALL GRATTS('FUNCTION-2','POLYLINE') 680 - IF(TAB2D)THEN 681 - DO 455 I=1,NBANG 682 - DO 465 J=1,MXLIST 683 - YPL(J)=GASATT(XPL(J),0.0,0.0, 684 - - BTAB(K)*COS(BANG(I)), 685 - - BTAB(K)*SIN(BANG(I)),0.0) 686 - 465 CONTINUE 687 - CALL GRLINE(MXLIST,XPL,YPL) 688 - 455 CONTINUE 689 - ELSE 690 - DO 475 I=1,MXLIST 691 - YPL(I)=GASATT(XPL(I),0.0,0.0,0.0,0.0,0.0) 692 - 475 CONTINUE 693 - CALL GRLINE(MXLIST,XPL,YPL) 694 - ENDIF 695 - CALL GRATTS('FUNCTION-2','POLYMARKER') 696 - DO 495 J=1,NGAS 697 - AUX1(1)=PGAS*EGAS(J) 698 - IF(TAB2D)THEN 699 - DO 485 I=1,NBANG 700 - AUX2(1)=EXP(BGAS2(J,I,K))*PGAS 701 - CALL GRMARK(1,AUX1,AUX2) 702 - 485 CONTINUE 703 - ELSE 704 - AUX2(1)=EXP(BGAS(J))*PGAS 705 - CALL GRMARK(1,AUX1,AUX2) 706 - ENDIF 707 - 495 CONTINUE 708 - ENDIF 709 - CALL GRNEXT 710 - CALL GRALOG('Graph of the Townsend and att. coeff.') 711 - * Next B field. 712 - 440 CONTINUE 713 - ENDIF 714 - * Continue here if the plot was skipped. 715 - 499 CONTINUE 716 - *** Plot the Lorentz angle. 717 - IF(GASOPT(7,3).AND.GASOK(7))THEN 718 - * Set the electric field range. 719 - IF(GASOPT(7,1))THEN 720 - EMIN=MAX(1.0,PGAS*EGAS(1)/1.5) 721 - EMAX=PGAS*EGAS(NGAS)*1.5 722 - DO 501 I=1,MXLIST 723 - XPL(I)=EMIN*(EMAX/EMIN)**(REAL(I-1)/REAL(MXLIST-1)) 724 - 501 CONTINUE 725 - ELSE 726 - EMIN=MAX(0.0,PGAS*(EGAS(1)-ABS(EGAS(NGAS)-EGAS(1))/20)) 727 - EMAX=PGAS*(EGAS(NGAS)+ABS(EGAS(NGAS)-EGAS(1))/20) 728 - DO 502 I=1,MXLIST 729 - XPL(I)=EMIN+REAL(I-1)*(EMAX-EMIN)/REAL(MXLIST-1) 730 - 502 CONTINUE 731 - ENDIF 732 - * Determine the scale of the graph. 733 - IF(GASOPT(7,4))THEN 734 - YPLMIN=180*GASRNG(7,1)/PI 735 - YPLMAX=180*GASRNG(7,2)/PI 736 - ELSEIF(TAB2D)THEN 737 - YPLMIN=180*WGAS2(1,1,1)/PI 738 - YPLMAX=180*WGAS2(1,1,1)/PI 739 - DO 500 K=1,NBTAB 740 - DO 510 I=1,NGAS 741 - DO 520 J=1,NBANG 1 529 P=GAS D=GASPLT 8 PAGE 800 742 - YPLMIN=MIN(YPLMIN,180*WGAS2(I,J,K)/PI) 743 - YPLMAX=MAX(YPLMAX,180*WGAS2(I,J,K)/PI) 744 - 520 CONTINUE 745 - 510 CONTINUE 746 - 500 CONTINUE 747 - DY=(YPLMAX-YPLMIN)/20 748 - YPLMAX=YPLMAX+DY 749 - YPLMIN=YPLMIN-DY 750 - ELSE 751 - YPLMIN=180*WGAS(1)/PI 752 - YPLMAX=180*WGAS(1)/PI 753 - DO 530 I=2,NGAS 754 - YPLMIN=MIN(YPLMIN,180*WGAS(I)/PI) 755 - YPLMAX=MAX(YPLMAX,180*WGAS(I)/PI) 756 - 530 CONTINUE 757 - DY=(YPLMAX-YPLMIN)/20 758 - YPLMAX=YPLMAX+DY 759 - YPLMIN=YPLMIN-DY 760 - ENDIF 761 - * Loop over the B fields. 762 - DO 540 K=1,NBTAB 763 - * Plot the frame. 764 - IF(GASOPT(7,1))THEN 765 - CALL GRAOPT('LOG-X') 766 - ELSE 767 - CALL GRAOPT('LIN-X') 768 - ENDIF 769 - IF(GASOPT(7,2))THEN 770 - CALL GRAOPT('LOG-Y') 771 - ELSE 772 - CALL GRAOPT('LIN-Y') 773 - ENDIF 774 - CALL GRCART(EMIN,YPLMIN,EMAX,YPLMAX, 775 - - 'E [V/cm]','Angle between v and E [degrees]', 776 - - 'Angle between v and E vs E') 777 - IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) 778 - IF(TAB2D)THEN 779 - CALL OUTFMT(BTAB(K)/100,2,STR1,NC1,'LEFT') 780 - CALL GRCOMM(2,'B = '//STR1(1:NC1)//' T') 781 - CALL OUTFMT(180*BANG(1)/PI,2,STR1,NC1,'LEFT') 782 - CALL OUTFMT(180*BANG(NBANG)/PI,2,STR2,NC2,'LEFT') 783 - CALL OUTFMT(REAL(NBANG),2,STR3,NC3,'LEFT') 784 - CALL GRCOMM(4,STR1(1:NC1)//' < angle(E,B) < '// 785 - - STR2(1:NC2)//' degress in '//STR3(1:NC3)// 786 - - ' steps') 787 - ENDIF 788 - * Plot the various curves. 789 - CALL GRATTS('FUNCTION-1','POLYLINE') 790 - IF(TAB2D)THEN 791 - DO 550 I=1,NBANG 792 - DO 560 J=1,MXLIST 793 - YPL(J)=180*GASLOR(XPL(J),0.0,0.0,BTAB(K)*COS(BANG(I)), 794 - - BTAB(K)*SIN(BANG(I)),0.0)/PI 795 - 560 CONTINUE 796 - CALL GRLINE(MXLIST,XPL,YPL) 797 - 550 CONTINUE 798 - ELSE 799 - DO 570 I=1,MXLIST 800 - YPL(I)=180*GASLOR(XPL(I),0.0,0.0,0.0,0.0,0.0)/PI 801 - 570 CONTINUE 802 - CALL GRLINE(MXLIST,XPL,YPL) 803 - ENDIF 804 - * Polymark the data, allowing a check on the interpolation. 805 - CALL GRATTS('FUNCTION-1','POLYMARKER') 806 - DO 590 J=1,NGAS 807 - AUX1(1)=PGAS*EGAS(J) 808 - IF(TAB2D)THEN 809 - DO 580 I=1,NBANG 810 - AUX2(1)=180*WGAS2(J,I,K)/PI 811 - CALL GRMARK(1,AUX1,AUX2) 812 - 580 CONTINUE 813 - ELSE 814 - AUX2(1)=180*WGAS(J)/PI 815 - CALL GRMARK(1,AUX1,AUX2) 816 - ENDIF 817 - 590 CONTINUE 818 - CALL GRNEXT 819 - CALL GRALOG('Graph of the (v,E) angle vs E.') 820 - * Next B field. 821 - 540 CONTINUE 822 - ENDIF 823 - *** Cluster size distribution. 824 - IF(GASOPT(5,3).AND.GASOK(5))THEN 825 - * Set log or linear axes, as requested. 826 - IF(GASOPT(5,1))THEN 827 - CALL GRAOPT('LOG-X') 828 - ELSE 829 - CALL GRAOPT('LIN-X') 830 - ENDIF 831 - IF(GASOPT(5,2))THEN 832 - CALL GRAOPT('LOG-Y') 833 - ELSE 834 - CALL GRAOPT('LIN-Y') 835 - ENDIF 836 - * Recover the cluster size distribution. 837 - YPL3(0)=0 838 - DO 60 I=1,MIN(MXPAIR,NCLS) 839 - IF(I.EQ.1)THEN 840 - YPL3(I)=CLSDIS(I) 841 - ELSE 842 - YPL3(I)=CLSDIS(I)-CLSDIS(I-1) 843 - ENDIF 844 - 60 CONTINUE 845 - YPL3(MIN(NCLS,MXPAIR)+1)=0 846 - * Plot the histogram. 847 - CALL GRHIST(YPL3,MIN(MXPAIR,NCLS), 1 529 P=GAS D=GASPLT 9 PAGE 801 848 - - 0.0,REAL(MIN(MXPAIR,NCLS)), 849 - - 'Number of pairs in a cluster', 850 - - 'Cluster size distribution',.TRUE.) 851 - * Add a bit of information to the plot. 852 - IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) 853 - CALL GRCOMM(2,'Origin: '//CLSTYP) 854 - CALL GRALOG('Graph of the cluster size distribution ') 855 - CALL GRNEXT 856 - ENDIF 857 - *** Restore the axes. 858 - CALL GRAOPT('LINEAR-X') 859 - CALL GRAOPT('LINEAR-Y') 860 - *** Call TIMLOG to register the amount of CPU time used. 861 - CALL TIMLOG('Making various gas plots: ') 862 - END 530 GARFIELD ================================================== P=GAS D=GASPRE 1 ============================ 0 + +DECK,GASPRE. 1 - SUBROUTINE GASPRE(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * GASPRE - Prepares the gas data for further use by other routines. 4 - * VARIABLES : IFAIL : 1 if routine failed 0 if succesful 5 - * (Last changed on 17/ 2/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,GASDATA. 10.- +SEQ,PRINTPLOT. 11 - DOUBLE PRECISION CLSSUM 12 - REAL DENLAN 13 - CHARACTER*20 AUX1 14 - INTEGER I,J,K,N,IFAIL,NFAIL,NC1 15 - LOGICAL OK 16 - EXTERNAL DENLAN 17 - *** Identify the routine if requested. 18 - IF(LIDENT)PRINT *,' /// ROUTINE GASPRE ///' 19 - *** For the time being assume this will work. 20 - IFAIL=0 21 - OK=.TRUE. 22 - *** Drift velocity preparation, start with a table of 1 point. 23 - IF(GASOK(1).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN 24 - IF(IVEXTR.NE.0.OR.JVEXTR.NE.0)THEN 25 - PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// 26 - - ' table, only constant extrapolation is valid.' 27 - IVEXTR=0 28 - JVEXTR=0 29 - OK=.FALSE. 30 - ENDIF 31 - * Calculate the spline coefficients for the drift speed, 32 - ELSEIF(GASOK(1).AND..NOT.TAB2D)THEN 33 - CALL SPLINE(EGAS,VGAS,CVGAS,NGAS,IFAIL) 34 - IF(IFAIL.EQ.1)THEN 35 - PRINT *,' !!!!!! GASPRE WARNING : The drift velocity'// 36 - - ' data can not be interpolated; data deleted.' 37 - GASOK(1)=.FALSE. 38 - OK=.FALSE. 39 - ENDIF 40 - * Calculate the H extrapolation parameters, using the last 2 points. 41 - IF(VGAS(NGAS).LE.0.OR.(IVEXTR.NE.1.AND.IVEXTR.NE.2))THEN 42 - VEXTR1=0.0 43 - VEXTR2=0.0 44 - ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN 45 - PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// 46 - - ' coincide; no v extrapolation to higher E/p.' 47 - IVEXTR=0 48 - OK=.FALSE. 49 - ELSEIF(IVEXTR.EQ.1)THEN 50 - VEXTR2=(VGAS(NGAS)-VGAS(NGAS-1))/ 51 - - (EGAS(NGAS)-EGAS(NGAS-1)) 52 - VEXTR1=VGAS(NGAS)-VEXTR2*EGAS(NGAS) 53 - IF(VEXTR2.LT.0.0)THEN 54 - CALL OUTFMT(-PGAS*VEXTR1/VEXTR2,2,AUX1,NC1,'LEFT') 55 - PRINT *,' ------ GASPRE MESSAGE : The linear'// 56 - - ' extrapolation of the drift velocity is'// 57 - - ' negative for E > '//AUX1(1:NC1)//' V/cm.' 58 - ENDIF 59 - ELSEIF(IVEXTR.EQ.2)THEN 60 - VEXTR2=LOG(VGAS(NGAS)/VGAS(NGAS-1))/ 61 - - (EGAS(NGAS)-EGAS(NGAS-1)) 62 - VEXTR1=LOG(VGAS(NGAS))-VEXTR2*EGAS(NGAS) 63 - ENDIF 64 - * Calculate the L extrapolation parameters, using the last 2 points. 65 - IF(VGAS(1).LE.0.OR.(JVEXTR.NE.1.AND.JVEXTR.NE.2))THEN 66 - VEXTR3=0.0 67 - VEXTR4=0.0 68 - ELSEIF(EGAS(2).LE.EGAS(1))THEN 69 - PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// 70 - - ' coincide; no v extrapolation to lower E/p.' 71 - JVEXTR=0 72 - OK=.FALSE. 73 - ELSEIF(JVEXTR.EQ.1)THEN 74 - VEXTR4=(VGAS(2)-VGAS(1))/(EGAS(2)-EGAS(1)) 75 - VEXTR3=VGAS(1)-VEXTR4*EGAS(1) 76 - IF(VEXTR4.GT.0.0.AND.VEXTR3.LT.0)THEN 77 - CALL OUTFMT(-PGAS*VEXTR3/VEXTR4,2,AUX1,NC1,'LEFT') 78 - PRINT *,' ------ GASPRE MESSAGE : The linear'// 79 - - ' extrapolation of the drift velocity is'// 80 - - ' negative for E < '//AUX1(1:NC1)//' V/cm.' 81 - ENDIF 82 - ELSEIF(JVEXTR.EQ.2)THEN 83 - VEXTR4=LOG(VGAS(2)/VGAS(1))/(EGAS(2)-EGAS(1)) 84 - VEXTR3=LOG(VGAS(1))-VEXTR4*EGAS(1) 85 - ENDIF 86 - * 2D interpolation. 87 - ELSEIF(GASOK(1).AND.(IVMETH.NE.1.AND.IVMETH.NE.2))THEN 1 530 P=GAS D=GASPRE 2 PAGE 802 88 - PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// 89 - - ' 2D tables can only be linear or quadratic;' 90 - PRINT *,' will use parabolic'// 91 - - ' interpolation for the drift velocity.' 92 - IVMETH=2 93 - OK=.FALSE. 94 - ENDIF 95 - *** Drift velocity B preparation, start with a table of 1 point. 96 - IF(GASOK(9).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN 97 - IF(IXEXTR.NE.0.OR.JXEXTR.NE.0)THEN 98 - PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// 99 - - ' table, only constant extrapolation is valid.' 100 - IXEXTR=0 101 - JXEXTR=0 102 - OK=.FALSE. 103 - ENDIF 104 - * Calculate the spline coefficients for the drift speed, 105 - ELSEIF(GASOK(9).AND..NOT.TAB2D)THEN 106 - CALL SPLINE(EGAS,XGAS,CXGAS,NGAS,IFAIL) 107 - IF(IFAIL.EQ.1)THEN 108 - PRINT *,' !!!!!! GASPRE WARNING : v || Btrans'// 109 - - ' can not be interpolated; data deleted.' 110 - GASOK(9)=.FALSE. 111 - OK=.FALSE. 112 - ENDIF 113 - * Calculate the H extrapolation parameters, using the last 2 points. 114 - IF(XGAS(NGAS).LE.0.OR.(IXEXTR.NE.1.AND.IXEXTR.NE.2))THEN 115 - XEXTR1=0.0 116 - XEXTR2=0.0 117 - ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN 118 - PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// 119 - - ' coincide; no v || Btrans extrapolation to'// 120 - - ' high E/p.' 121 - IXEXTR=0 122 - OK=.FALSE. 123 - ELSEIF(IXEXTR.EQ.1)THEN 124 - XEXTR2=(XGAS(NGAS)-XGAS(NGAS-1))/ 125 - - (EGAS(NGAS)-EGAS(NGAS-1)) 126 - XEXTR1=XGAS(NGAS)-XEXTR2*EGAS(NGAS) 127 - IF(XEXTR2.LT.0.0)THEN 128 - CALL OUTFMT(-PGAS*XEXTR1/XEXTR2,2,AUX1,NC1,'LEFT') 129 - PRINT *,' ------ GASPRE MESSAGE : The linear'// 130 - - ' extrapolation of v || Btrans is'// 131 - - ' negative for E > '//AUX1(1:NC1)//' V/cm.' 132 - ENDIF 133 - ELSEIF(IXEXTR.EQ.2)THEN 134 - XEXTR2=LOG(XGAS(NGAS)/XGAS(NGAS-1))/ 135 - - (EGAS(NGAS)-EGAS(NGAS-1)) 136 - XEXTR1=LOG(XGAS(NGAS))-XEXTR2*EGAS(NGAS) 137 - ENDIF 138 - * Calculate the L extrapolation parameters, using the last 2 points. 139 - IF(XGAS(1).LE.0.OR.(JXEXTR.NE.1.AND.JXEXTR.NE.2))THEN 140 - XEXTR3=0.0 141 - XEXTR4=0.0 142 - ELSEIF(EGAS(2).LE.EGAS(1))THEN 143 - PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// 144 - - ' coincide; no v || Btrans extrapolation to'// 145 - - ' low E/p.' 146 - JXEXTR=0 147 - OK=.FALSE. 148 - ELSEIF(JXEXTR.EQ.1)THEN 149 - XEXTR4=(XGAS(2)-XGAS(1))/(EGAS(2)-EGAS(1)) 150 - XEXTR3=XGAS(1)-XEXTR4*EGAS(1) 151 - IF(XEXTR4.GT.0.0.AND.XEXTR3.LT.0)THEN 152 - CALL OUTFMT(-PGAS*XEXTR3/XEXTR4,2,AUX1,NC1,'LEFT') 153 - PRINT *,' ------ GASPRE MESSAGE : The linear'// 154 - - ' extrapolation of v || Btrans is'// 155 - - ' negative for E < '//AUX1(1:NC1)//' V/cm.' 156 - ENDIF 157 - ELSEIF(JXEXTR.EQ.2)THEN 158 - XEXTR4=LOG(XGAS(2)/XGAS(1))/(EGAS(2)-EGAS(1)) 159 - XEXTR3=LOG(XGAS(1))-XEXTR4*EGAS(1) 160 - ENDIF 161 - * 2D interpolation. 162 - ELSEIF(GASOK(9).AND.(IXMETH.NE.1.AND.IXMETH.NE.2))THEN 163 - PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// 164 - - ' 2D tables can only be linear or quadratic;' 165 - PRINT *,' will use parabolic'// 166 - - ' interpolation for v || Btrans.' 167 - IXMETH=2 168 - OK=.FALSE. 169 - ENDIF 170 - *** Drift velocity ExB preparation, start with a table of 1 point. 171 - IF(GASOK(10).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN 172 - IF(IYEXTR.NE.0.OR.JYEXTR.NE.0)THEN 173 - PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// 174 - - ' table, only constant extrapolation is valid.' 175 - IYEXTR=0 176 - JYEXTR=0 177 - OK=.FALSE. 178 - ENDIF 179 - * Calculate the spline coefficients for the drift speed, 180 - ELSEIF(GASOK(10).AND..NOT.TAB2D)THEN 181 - CALL SPLINE(EGAS,YGAS,CYGAS,NGAS,IFAIL) 182 - IF(IFAIL.EQ.1)THEN 183 - PRINT *,' !!!!!! GASPRE WARNING : v || ExB'// 184 - - ' data can not be interpolated; data deleted.' 185 - GASOK(10)=.FALSE. 186 - OK=.FALSE. 187 - ENDIF 188 - * Calculate the H extrapolation parameters, using the last 2 points. 189 - IF(YGAS(NGAS).LE.0.OR.(IYEXTR.NE.1.AND.IYEXTR.NE.2))THEN 190 - YEXTR1=0.0 191 - YEXTR2=0.0 192 - ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN 193 - PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// 1 530 P=GAS D=GASPRE 3 PAGE 803 194 - - ' coincide; no v || ExB extrapolation to high'// 195 - - ' E/p.' 196 - IYEXTR=0 197 - OK=.FALSE. 198 - ELSEIF(IYEXTR.EQ.1)THEN 199 - YEXTR2=(YGAS(NGAS)-YGAS(NGAS-1))/ 200 - - (EGAS(NGAS)-EGAS(NGAS-1)) 201 - YEXTR1=YGAS(NGAS)-YEXTR2*EGAS(NGAS) 202 - IF(YEXTR2.LT.0.0)THEN 203 - CALL OUTFMT(-PGAS*YEXTR1/YEXTR2,2,AUX1,NC1,'LEFT') 204 - PRINT *,' ------ GASPRE MESSAGE : The linear'// 205 - - ' extrapolation of v || ExB is'// 206 - - ' negative for E > '//AUX1(1:NC1)//' V/cm.' 207 - ENDIF 208 - ELSEIF(IYEXTR.EQ.2)THEN 209 - YEXTR2=LOG(YGAS(NGAS)/YGAS(NGAS-1))/ 210 - - (EGAS(NGAS)-EGAS(NGAS-1)) 211 - YEXTR1=LOG(YGAS(NGAS))-YEXTR2*EGAS(NGAS) 212 - ENDIF 213 - * Calculate the L extrapolation parameters, using the last 2 points. 214 - IF(YGAS(1).LE.0.OR.(JYEXTR.NE.1.AND.JYEXTR.NE.2))THEN 215 - YEXTR3=0.0 216 - YEXTR4=0.0 217 - ELSEIF(EGAS(2).LE.EGAS(1))THEN 218 - PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// 219 - - ' coincide; no v || ExB extrapolation to low'// 220 - - ' E/p.' 221 - JYEXTR=0 222 - OK=.FALSE. 223 - ELSEIF(JYEXTR.EQ.1)THEN 224 - YEXTR4=(YGAS(2)-YGAS(1))/(EGAS(2)-EGAS(1)) 225 - YEXTR3=YGAS(1)-YEXTR4*EGAS(1) 226 - IF(YEXTR4.GT.0.0.AND.YEXTR3.LT.0)THEN 227 - CALL OUTFMT(-PGAS*YEXTR3/YEXTR4,2,AUX1,NC1,'LEFT') 228 - PRINT *,' ------ GASPRE MESSAGE : The linear'// 229 - - ' extrapolation of v || ExB is'// 230 - - ' negative for E < '//AUX1(1:NC1)//' V/cm.' 231 - ENDIF 232 - ELSEIF(JYEXTR.EQ.2)THEN 233 - YEXTR4=LOG(YGAS(2)/YGAS(1))/(EGAS(2)-EGAS(1)) 234 - YEXTR3=LOG(YGAS(1))-YEXTR4*EGAS(1) 235 - ENDIF 236 - * 2D interpolation. 237 - ELSEIF(GASOK(10).AND.(IYMETH.NE.1.AND.IYMETH.NE.2))THEN 238 - PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// 239 - - ' 2D tables can only be linear or quadratic;' 240 - PRINT *,' will use parabolic'// 241 - - ' interpolation for v || ExB.' 242 - IYMETH=2 243 - OK=.FALSE. 244 - ENDIF 245 - *** Calculate the spline coefficients for the ion mobility. 246 - IF(GASOK(2).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN 247 - IF(IMEXTR.NE.0.OR.JMEXTR.NE.0)THEN 248 - PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// 249 - - ' table, only constant extrapolation is valid.' 250 - IMEXTR=0 251 - JMEXTR=0 252 - OK=.FALSE. 253 - ENDIF 254 - ELSEIF(GASOK(2).AND..NOT.TAB2D)THEN 255 - CALL SPLINE(EGAS,MGAS,CMGAS,NGAS,IFAIL) 256 - IF(IFAIL.EQ.1)THEN 257 - PRINT *,' !!!!!! GASPRE WARNING : The ion mobility'// 258 - - ' data can not be interpolated; data deleted.' 259 - GASOK(2)=.FALSE. 260 - OK=.FALSE. 261 - ENDIF 262 - * Calculate the H extrapolation parameters, using the last 2 points. 263 - IF(MGAS(NGAS).LE.0.OR.(IMEXTR.NE.1.AND.IMEXTR.NE.2))THEN 264 - MEXTR1=0.0 265 - MEXTR2=0.0 266 - ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN 267 - PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// 268 - - ' coincide; no mu extrapolation to higher E/p.' 269 - IMEXTR=0 270 - OK=.FALSE. 271 - ELSEIF(IMEXTR.EQ.1)THEN 272 - MEXTR2=(MGAS(NGAS)-MGAS(NGAS-1))/ 273 - - (EGAS(NGAS)-EGAS(NGAS-1)) 274 - MEXTR1=MGAS(NGAS)-MEXTR2*EGAS(NGAS) 275 - IF(MEXTR2.LT.0.0)THEN 276 - CALL OUTFMT(-PGAS*MEXTR1/MEXTR2,2,AUX1,NC1,'LEFT') 277 - PRINT *,' ------ GASPRE MESSAGE : The linear'// 278 - - ' extrapolation of the ion mobility is'// 279 - - ' negative for E > '//AUX1(1:NC1)//' V/cm.' 280 - ENDIF 281 - ELSEIF(IMEXTR.EQ.2)THEN 282 - MEXTR2=LOG(MGAS(NGAS)/MGAS(NGAS-1))/ 283 - - (EGAS(NGAS)-EGAS(NGAS-1)) 284 - MEXTR1=LOG(MGAS(NGAS))-MEXTR2*EGAS(NGAS) 285 - ENDIF 286 - * Calculate the L extrapolation parameters, using the last 2 points. 287 - IF(MGAS(1).LE.0.OR.(JMEXTR.NE.1.AND.JMEXTR.NE.2))THEN 288 - MEXTR3=0.0 289 - MEXTR4=0.0 290 - ELSEIF(EGAS(2).LE.EGAS(1))THEN 291 - PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// 292 - - ' coincide; no mu extrapolation to lower E/p.' 293 - JMEXTR=0 294 - OK=.FALSE. 295 - ELSEIF(JMEXTR.EQ.1)THEN 296 - MEXTR4=(MGAS(2)-MGAS(1))/(EGAS(2)-EGAS(1)) 297 - MEXTR3=MGAS(1)-MEXTR4*EGAS(1) 298 - IF(MEXTR4.GT.0.0.AND.MEXTR3.LT.0)THEN 299 - CALL OUTFMT(-PGAS*MEXTR3/MEXTR4,2,AUX1,NC1,'LEFT') 1 530 P=GAS D=GASPRE 4 PAGE 804 300 - PRINT *,' ------ GASPRE MESSAGE : The linear'// 301 - - ' extrapolation of the ion mobility is'// 302 - - ' negative for E < '//AUX1(1:NC1)//' V/cm.' 303 - ENDIF 304 - ELSEIF(JMEXTR.EQ.2)THEN 305 - MEXTR4=LOG(MGAS(2)/MGAS(1))/(EGAS(2)-EGAS(1)) 306 - MEXTR3=LOG(MGAS(1))-MEXTR4*EGAS(1) 307 - ENDIF 308 - * 2D interpolation. 309 - ELSEIF(GASOK(2).AND.(IMMETH.NE.1.AND.IMMETH.NE.2))THEN 310 - PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// 311 - - ' 2D tables can only be linear or quadratic;' 312 - PRINT *,' will use parabolic'// 313 - - ' interpolation for the ion mobility.' 314 - IMMETH=2 315 - OK=.FALSE. 316 - ENDIF 317 - *** Calculate the spline coefficients for sigma L. 318 - IF(GASOK(3).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN 319 - IF(IDEXTR.NE.0.OR.JDEXTR.NE.0)THEN 320 - PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// 321 - - ' table, only constant extrapolation is valid.' 322 - IDEXTR=0 323 - JDEXTR=0 324 - OK=.FALSE. 325 - ENDIF 326 - ELSEIF(GASOK(3).AND..NOT.TAB2D)THEN 327 - CALL SPLINE(EGAS,DGAS,CDGAS,NGAS,IFAIL) 328 - IF(IFAIL.EQ.1)THEN 329 - PRINT *,' !!!!!! GASPRE WARNING : The long. diff.'// 330 - - ' data can not be interpolated; data deleted.' 331 - GASOK(3)=.FALSE. 332 - OK=.FALSE. 333 - ENDIF 334 - * Calculate the H extrapolation parameters, using the last 2 points. 335 - IF(DGAS(NGAS).LE.0.OR.(IDEXTR.NE.1.AND.IDEXTR.NE.2))THEN 336 - DEXTR1=0.0 337 - DEXTR2=0.0 338 - ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN 339 - PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// 340 - - ' coincide; no DL extrapolation to higher E/p.' 341 - IDEXTR=0 342 - OK=.FALSE. 343 - ELSEIF(IDEXTR.EQ.1)THEN 344 - DEXTR2=(DGAS(NGAS)-DGAS(NGAS-1))/ 345 - - (EGAS(NGAS)-EGAS(NGAS-1)) 346 - DEXTR1=DGAS(NGAS)-DEXTR2*EGAS(NGAS) 347 - IF(DEXTR2.LT.0.0)THEN 348 - CALL OUTFMT(-PGAS*DEXTR1/DEXTR2,2,AUX1,NC1,'LEFT') 349 - PRINT *,' ------ GASPRE MESSAGE : The linear'// 350 - - ' extrapolation of the long. diff. is'// 351 - - ' negative for E > '//AUX1(1:NC1)//' V/cm.' 352 - ENDIF 353 - ELSEIF(IDEXTR.EQ.2)THEN 354 - DEXTR2=LOG(DGAS(NGAS)/DGAS(NGAS-1))/ 355 - - (EGAS(NGAS)-EGAS(NGAS-1)) 356 - DEXTR1=LOG(DGAS(NGAS))-DEXTR2*EGAS(NGAS) 357 - ENDIF 358 - * Calculate the L extrapolation parameters, using the last 2 points. 359 - IF(DGAS(1).LE.0.OR.(JDEXTR.NE.1.AND.JDEXTR.NE.2))THEN 360 - DEXTR3=0.0 361 - DEXTR4=0.0 362 - ELSEIF(EGAS(2).LE.EGAS(1))THEN 363 - PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// 364 - - ' coincide; no DL extrapolation to lower E/p.' 365 - JDEXTR=0 366 - OK=.FALSE. 367 - ELSEIF(JDEXTR.EQ.1)THEN 368 - DEXTR4=(DGAS(2)-DGAS(1))/(EGAS(2)-EGAS(1)) 369 - DEXTR3=DGAS(1)-DEXTR4*EGAS(1) 370 - IF(DEXTR4.GT.0.0.AND.DEXTR3.LT.0)THEN 371 - CALL OUTFMT(-PGAS*DEXTR3/DEXTR4,2,AUX1,NC1,'LEFT') 372 - PRINT *,' ------ GASPRE MESSAGE : The linear'// 373 - - ' extrapolation of the long. diff. is'// 374 - - ' negative for E < '//AUX1(1:NC1)//' V/cm.' 375 - ENDIF 376 - ELSEIF(JDEXTR.EQ.2)THEN 377 - DEXTR4=LOG(DGAS(2)/DGAS(1))/(EGAS(2)-EGAS(1)) 378 - DEXTR3=LOG(DGAS(1))-DEXTR4*EGAS(1) 379 - ENDIF 380 - * 2D interpolation. 381 - ELSEIF(GASOK(3).AND.(IDMETH.NE.1.AND.IDMETH.NE.2))THEN 382 - PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// 383 - - ' 2D tables can only be linear or quadratic;' 384 - PRINT *,' will use parabolic'// 385 - - ' interpolation for the long. diff.' 386 - IDMETH=2 387 - OK=.FALSE. 388 - ENDIF 389 - *** Calculate the spline coefficients for the Townsend coefficient. 390 - IF(GASOK(4).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN 391 - IF(IAEXTR.NE.0.OR.JAEXTR.NE.0)THEN 392 - PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// 393 - - ' table, only constant extrapolation is valid.' 394 - IAEXTR=0 395 - JAEXTR=0 396 - OK=.FALSE. 397 - ENDIF 398 - IATHR=1 399 - ELSEIF(GASOK(4).AND..NOT.TAB2D)THEN 400 - * Set threshold. 401 - DO 100 I=1,NGAS 402 - IF(AGAS(I).LE.-20)GOTO 100 403 - IATHR=MIN(NGAS,I+1) 404 - GOTO 110 405 - 100 CONTINUE 1 530 P=GAS D=GASPRE 5 PAGE 805 406 - IATHR=1 407 - 110 CONTINUE 408 - * Prepare spline coefficients. 409 - CALL SPLINE(EGAS,AGAS,CAGAS,NGAS,IFAIL) 410 - IF(IFAIL.EQ.1)THEN 411 - PRINT *,' !!!!!! GASPRE WARNING : The Townsend'// 412 - - ' data can not be interpolated; data deleted.' 413 - GASOK(4)=.FALSE. 414 - OK=.FALSE. 415 - ENDIF 416 - * Calculate the H extrapolation parameters, using the last 2 points. 417 - IF(IAEXTR.NE.1.AND.IAEXTR.NE.2)THEN 418 - AEXTR1=0.0 419 - AEXTR2=0.0 420 - ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN 421 - PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// 422 - - ' coincide; no alpha extrapolation to higher E/p.' 423 - IAEXTR=0 424 - OK=.FALSE. 425 - ELSEIF(IAEXTR.EQ.1)THEN 426 - AEXTR2=(AGAS(NGAS)-AGAS(NGAS-1))/ 427 - - (EGAS(NGAS)-EGAS(NGAS-1)) 428 - AEXTR1=AGAS(NGAS)-AEXTR2*EGAS(NGAS) 429 - ELSEIF(IAEXTR.EQ.2)THEN 430 - AEXTR2=LOG(AGAS(NGAS)/AGAS(NGAS-1))/ 431 - - (EGAS(NGAS)-EGAS(NGAS-1)) 432 - AEXTR1=LOG(AGAS(NGAS))-AEXTR2*EGAS(NGAS) 433 - ENDIF 434 - * Calculate the L extrapolation parameters, using the last 2 points. 435 - IF(JAEXTR.NE.1.AND.JAEXTR.NE.2)THEN 436 - AEXTR3=0.0 437 - AEXTR4=0.0 438 - ELSEIF(EGAS(2).LE.EGAS(1))THEN 439 - PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// 440 - - ' coincide; no alpha extrapolation to lower E/p.' 441 - JAEXTR=0 442 - OK=.FALSE. 443 - ELSEIF(JAEXTR.EQ.1)THEN 444 - AEXTR4=(AGAS(2)-AGAS(1))/(EGAS(2)-EGAS(1)) 445 - AEXTR3=AGAS(1)-AEXTR4*EGAS(1) 446 - ELSEIF(JAEXTR.EQ.2)THEN 447 - AEXTR4=LOG(AGAS(2)/AGAS(1))/(EGAS(2)-EGAS(1)) 448 - AEXTR3=LOG(AGAS(1))-AEXTR4*EGAS(1) 449 - ENDIF 450 - * 2D interpolation. 451 - ELSEIF(GASOK(4))THEN 452 - * Set threshold. 453 - DO 120 I=1,NGAS 454 - DO 130 J=1,NBANG 455 - DO 140 K=1,NBTAB 456 - IF(AGAS2(I,J,K).LT.-20)GOTO 120 457 - 140 CONTINUE 458 - 130 CONTINUE 459 - IATHR=MIN(NGAS,I+1) 460 - GOTO 150 461 - 120 CONTINUE 462 - IATHR=1 463 - 150 CONTINUE 464 - * Check interpolation method. 465 - IF(IAMETH.NE.1.AND.IAMETH.NE.2)THEN 466 - PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// 467 - - ' 2D tables can only be linear or quadratic;' 468 - PRINT *,' will use parabolic'// 469 - - ' interpolation for the Townsend coeff.' 470 - IAMETH=2 471 - OK=.FALSE. 472 - ENDIF 473 - ENDIF 474 - *** Calculate the spline coefficients for the attachment. 475 - IF(GASOK(6).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN 476 - IF(IBEXTR.NE.0.OR.JBEXTR.NE.0)THEN 477 - PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// 478 - - ' table, only constant extrapolation is valid.' 479 - IBEXTR=0 480 - JBEXTR=0 481 - OK=.FALSE. 482 - ENDIF 483 - IBTHR=1 484 - ELSEIF(GASOK(6).AND..NOT.TAB2D)THEN 485 - * Set threshold. 486 - DO 200 I=1,NGAS 487 - IF(BGAS(I).LE.-20)GOTO 200 488 - IBTHR=MIN(NGAS,I+1) 489 - GOTO 210 490 - 200 CONTINUE 491 - IBTHR=1 492 - 210 CONTINUE 493 - * Prepare spline coefficients. 494 - CALL SPLINE(EGAS,BGAS,CBGAS,NGAS,IFAIL) 495 - IF(IFAIL.EQ.1)THEN 496 - PRINT *,' !!!!!! GASPRE WARNING : The attachment'// 497 - - ' data can not be interpolated; data deleted.' 498 - GASOK(6)=.FALSE. 499 - OK=.FALSE. 500 - ENDIF 501 - * Calculate the H extrapolation parameters, using the last 2 points. 502 - IF(IBEXTR.NE.1.AND.IBEXTR.NE.2)THEN 503 - BEXTR1=0.0 504 - BEXTR2=0.0 505 - ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN 506 - PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// 507 - - ' coincide; no eta extrapolation to higher E/p.' 508 - IBEXTR=0 509 - OK=.FALSE. 510 - ELSEIF(IBEXTR.EQ.1)THEN 511 - BEXTR2=(BGAS(NGAS)-BGAS(NGAS-1))/ 1 530 P=GAS D=GASPRE 6 PAGE 806 512 - - (EGAS(NGAS)-EGAS(NGAS-1)) 513 - BEXTR1=BGAS(NGAS)-BEXTR2*EGAS(NGAS) 514 - ELSEIF(IBEXTR.EQ.2)THEN 515 - BEXTR2=LOG(BGAS(NGAS)/BGAS(NGAS-1))/ 516 - - (EGAS(NGAS)-EGAS(NGAS-1)) 517 - BEXTR1=LOG(BGAS(NGAS))-BEXTR2*EGAS(NGAS) 518 - ENDIF 519 - * Calculate the L extrapolation parameters, using the last 2 points. 520 - IF(JBEXTR.NE.1.AND.JBEXTR.NE.2)THEN 521 - BEXTR3=0.0 522 - BEXTR4=0.0 523 - ELSEIF(EGAS(2).LE.EGAS(1))THEN 524 - PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// 525 - - ' coincide; no eta extrapolation to lower E/p.' 526 - JBEXTR=0 527 - OK=.FALSE. 528 - ELSEIF(JBEXTR.EQ.1)THEN 529 - BEXTR4=(BGAS(2)-BGAS(1))/(EGAS(2)-EGAS(1)) 530 - BEXTR3=BGAS(1)-BEXTR4*EGAS(1) 531 - ELSEIF(JBEXTR.EQ.2)THEN 532 - BEXTR4=LOG(BGAS(2)/BGAS(1))/(EGAS(2)-EGAS(1)) 533 - BEXTR3=LOG(BGAS(1))-BEXTR4*EGAS(1) 534 - ENDIF 535 - * 2D interpolation. 536 - ELSEIF(GASOK(6))THEN 537 - * Set threshold. 538 - DO 220 I=1,NGAS 539 - DO 230 J=1,NBANG 540 - DO 240 K=1,NBTAB 541 - IF(BGAS2(I,J,K).LE.-20)GOTO 220 542 - 240 CONTINUE 543 - 230 CONTINUE 544 - IBTHR=MIN(NGAS,I+1) 545 - GOTO 250 546 - 220 CONTINUE 547 - IBTHR=1 548 - 250 CONTINUE 549 - * Check interpolation method. 550 - IF(IBMETH.NE.1.AND.IBMETH.NE.2)THEN 551 - PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// 552 - - ' 2D tables can only be linear or quadratic;' 553 - PRINT *,' will use parabolic'// 554 - - ' interpolation for the attachment.' 555 - IBMETH=2 556 - OK=.FALSE. 557 - ENDIF 558 - ENDIF 559 - *** Calculate the spline coefficients for the Lorentz angle. 560 - IF(GASOK(7).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN 561 - IF(IWEXTR.NE.0.OR.JWEXTR.NE.0)THEN 562 - PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// 563 - - ' table, only constant extrapolation is valid.' 564 - IWEXTR=0 565 - JWEXTR=0 566 - OK=.FALSE. 567 - ENDIF 568 - ELSEIF(GASOK(7).AND..NOT.TAB2D)THEN 569 - CALL SPLINE(EGAS,WGAS,CWGAS,NGAS,IFAIL) 570 - IF(IFAIL.EQ.1)THEN 571 - PRINT *,' !!!!!! GASPRE WARNING : The (v,E) angle'// 572 - - ' data can not be interpolated; data deleted.' 573 - GASOK(7)=.FALSE. 574 - OK=.FALSE. 575 - ENDIF 576 - * Calculate the H extrapolation parameters, using the last 2 points. 577 - IF(WGAS(NGAS).LE.0.OR.(IWEXTR.NE.1.AND.IWEXTR.NE.2))THEN 578 - WEXTR1=0.0 579 - WEXTR2=0.0 580 - ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN 581 - PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// 582 - - ' coincide; no Lorentz extrapolation to higher'// 583 - - ' E/p.' 584 - IWEXTR=0 585 - OK=.FALSE. 586 - ELSEIF(IWEXTR.EQ.1)THEN 587 - WEXTR2=(WGAS(NGAS)-WGAS(NGAS-1))/ 588 - - (EGAS(NGAS)-EGAS(NGAS-1)) 589 - WEXTR1=WGAS(NGAS)-WEXTR2*EGAS(NGAS) 590 - IF(WEXTR2.LT.0.0)THEN 591 - CALL OUTFMT(-PGAS*WEXTR1/WEXTR2,2,AUX1,NC1,'LEFT') 592 - PRINT *,' ------ GASPRE MESSAGE : The linear'// 593 - - ' extrapolation of the (v,E) angle is'// 594 - - ' negative for E > '//AUX1(1:NC1)//' V/cm.' 595 - ENDIF 596 - ELSEIF(IWEXTR.EQ.2)THEN 597 - WEXTR2=LOG(WGAS(NGAS)/WGAS(NGAS-1))/ 598 - - (EGAS(NGAS)-EGAS(NGAS-1)) 599 - WEXTR1=LOG(WGAS(NGAS))-WEXTR2*EGAS(NGAS) 600 - ENDIF 601 - * Calculate the L extrapolation parameters, using the last 2 points. 602 - IF(WGAS(1).LE.0.OR.(JWEXTR.NE.1.AND.JWEXTR.NE.2))THEN 603 - WEXTR3=0.0 604 - WEXTR4=0.0 605 - ELSEIF(EGAS(2).LE.EGAS(1))THEN 606 - PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// 607 - - ' coincide; no Lorentz extrapolation to higher'// 608 - - ' E/p.' 609 - JWEXTR=0 610 - OK=.FALSE. 611 - ELSEIF(JWEXTR.EQ.1)THEN 612 - WEXTR4=(WGAS(2)-WGAS(1))/(EGAS(2)-EGAS(1)) 613 - WEXTR3=WGAS(1)-WEXTR4*EGAS(1) 614 - IF(WEXTR4.GT.0.0.AND.WEXTR3.LT.0)THEN 615 - CALL OUTFMT(-PGAS*WEXTR3/WEXTR4,2,AUX1,NC1,'LEFT') 616 - PRINT *,' ------ GASPRE MESSAGE : The linear'// 617 - - ' extrapolation of the (v,E) angle is'// 1 530 P=GAS D=GASPRE 7 PAGE 807 618 - - ' negative for E < '//AUX1(1:NC1)//' V/cm.' 619 - ENDIF 620 - ELSEIF(JWEXTR.EQ.2)THEN 621 - WEXTR4=LOG(WGAS(2)/WGAS(1))/(EGAS(2)-EGAS(1)) 622 - WEXTR3=LOG(WGAS(1))-WEXTR4*EGAS(1) 623 - ENDIF 624 - * 2D interpolation. 625 - ELSEIF(GASOK(7).AND.(IWMETH.NE.1.AND.IWMETH.NE.2))THEN 626 - PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// 627 - - ' 2D tables can only be linear or quadratic;' 628 - PRINT *,' will use parabolic'// 629 - - ' interpolation for the (v,E) angle.' 630 - IWMETH=2 631 - OK=.FALSE. 632 - ENDIF 633 - *** Calculate the spline coefficients for sigma T. 634 - IF(GASOK(8).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN 635 - IF(IOEXTR.NE.0.OR.JOEXTR.NE.0)THEN 636 - PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// 637 - - ' table, only constant extrapolation is valid.' 638 - IOEXTR=0 639 - JOEXTR=0 640 - OK=.FALSE. 641 - ENDIF 642 - ELSEIF(GASOK(8).AND..NOT.TAB2D)THEN 643 - CALL SPLINE(EGAS,OGAS,COGAS,NGAS,IFAIL) 644 - IF(IFAIL.EQ.1)THEN 645 - PRINT *,' !!!!!! GASPRE WARNING : The trans. diff.'// 646 - - ' data can not be interpolated; data deleted.' 647 - GASOK(8)=.FALSE. 648 - OK=.FALSE. 649 - ENDIF 650 - * Calculate the H extrapolation parameters, using the last 2 points. 651 - IF(OGAS(NGAS).LE.0.OR.(IOEXTR.NE.1.AND.IOEXTR.NE.2))THEN 652 - OEXTR1=0.0 653 - OEXTR2=0.0 654 - ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN 655 - PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// 656 - - ' coincide; no DT extrapolation to higher E/p.' 657 - IOEXTR=0 658 - OK=.FALSE. 659 - ELSEIF(IOEXTR.EQ.1)THEN 660 - OEXTR2=(OGAS(NGAS)-OGAS(NGAS-1))/ 661 - - (EGAS(NGAS)-EGAS(NGAS-1)) 662 - OEXTR1=OGAS(NGAS)-OEXTR2*EGAS(NGAS) 663 - IF(OEXTR2.LT.0.0)THEN 664 - CALL OUTFMT(-PGAS*OEXTR1/OEXTR2,2,AUX1,NC1,'LEFT') 665 - PRINT *,' ------ GASPRE MESSAGE : The linear'// 666 - - ' extrapolation of the trans. diff. is'// 667 - - ' negative for E > '//AUX1(1:NC1)//' V/cm.' 668 - ENDIF 669 - ELSEIF(IOEXTR.EQ.2)THEN 670 - OEXTR2=LOG(OGAS(NGAS)/OGAS(NGAS-1))/ 671 - - (EGAS(NGAS)-EGAS(NGAS-1)) 672 - OEXTR1=LOG(OGAS(NGAS))-OEXTR2*EGAS(NGAS) 673 - ENDIF 674 - * Calculate the L extrapolation parameters, using the last 2 points. 675 - IF(OGAS(1).LE.0.OR.(JOEXTR.NE.1.AND.JOEXTR.NE.2))THEN 676 - OEXTR3=0.0 677 - OEXTR4=0.0 678 - ELSEIF(EGAS(2).LE.EGAS(1))THEN 679 - PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// 680 - - ' coincide; no DT extrapolation to lower E/p.' 681 - JOEXTR=0 682 - OK=.FALSE. 683 - ELSEIF(JOEXTR.EQ.1)THEN 684 - OEXTR4=(OGAS(2)-OGAS(1))/(EGAS(2)-EGAS(1)) 685 - OEXTR3=OGAS(1)-OEXTR4*EGAS(1) 686 - IF(OEXTR4.GT.0.0.AND.OEXTR3.LT.0)THEN 687 - CALL OUTFMT(-PGAS*OEXTR3/OEXTR4,2,AUX1,NC1,'LEFT') 688 - PRINT *,' ------ GASPRE MESSAGE : The linear'// 689 - - ' extrapolation of the trans. diff. is'// 690 - - ' negative for E < '//AUX1(1:NC1)//' V/cm.' 691 - ENDIF 692 - ELSEIF(JOEXTR.EQ.2)THEN 693 - OEXTR4=LOG(OGAS(2)/OGAS(1))/(EGAS(2)-EGAS(1)) 694 - OEXTR3=LOG(OGAS(1))-OEXTR4*EGAS(1) 695 - ENDIF 696 - * 2D interpolation. 697 - ELSEIF(GASOK(8).AND.(IOMETH.NE.1.AND.IOMETH.NE.2))THEN 698 - PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// 699 - - ' 2D tables can only be linear or quadratic;' 700 - PRINT *,' will use parabolic'// 701 - - ' interpolation for the trans. diff.' 702 - IOMETH=2 703 - OK=.FALSE. 704 - ENDIF 705 - *** Reset the IFAIL's from the splines (they are now stored in GASOK). 706 - IFAIL=0 707 - *** Calculate the cluster size distr hist from parameters, call HISPRD. 708 - IF(CLSTYP.EQ.'LANDAU'.AND.GASOK(5))THEN 709 - IF(LDEBUG)PRINT *,' ++++++ GASPRE DEBUG : First order', 710 - - ' energy loss according to Bethe-Bloch: ', 711 - - (1.54E5*(Z/A)*RHO)-LOG(CMEAN) 712 - * Fix the maximum number of clusters. 713 - NCLS=MXPAIR 714 - NFAIL=0 715 - DO 10 N=1,NCLS 716 - * If the argument of DENLAN is smaller than -6, error 208 occurs. 717 - IF((CMEAN*(N-1.0)*EPAIR-EMPROB)/(1.54E5*(Z/A)*RHO)- 718 - - LOG(CMEAN).LT.-5.0)THEN 719 - CLSDIS(N)=0 720 - NFAIL=NFAIL+1 721 - * Otherwise, use the library function. 722 - ELSE 723 - CLSDIS(N)=(DENLAN((CMEAN*REAL(N-1)*EPAIR-EMPROB)/ 1 530 P=GAS D=GASPRE 8 PAGE 808 724 - - (1.54E5*(Z/A)*RHO)-LOG(CMEAN))+4* 725 - - DENLAN((CMEAN*(N-0.5)*EPAIR-EMPROB)/ 726 - - (1.54E5*(Z/A)*RHO)-LOG(CMEAN))+ 727 - - DENLAN((CMEAN*REAL(N)*EPAIR-EMPROB)/ 728 - - (1.54E5*(Z/A)*RHO)-LOG(CMEAN)))/6 729 - ENDIF 730 - 10 CONTINUE 731 - * Check there are some non-zero elements. 732 - IF(NFAIL.EQ.NCLS)THEN 733 - PRINT *,' !!!!!! GASPRE WARNING : Your parameters'// 734 - - ' are such that all cluster sizes up to ',NCLS 735 - PRINT *,' have probability'// 736 - - ' zero; cluster size distribution deleted.' 737 - GASOK(5)=.FALSE. 738 - ENDIF 739 - ENDIF 740 - *** Call HISPRD to prepare random number extraction. 741 - IF(GASOK(5).AND.(CLSTYP.EQ.'LANDAU'.OR.CLSTYP.EQ.'FUNCTION'.OR. 742 - - CLSTYP.EQ.'TABLE'.OR.CLSTYP.EQ.'OVERLAP'))THEN 743 - * Debugging output. 744 - IF(LDEBUG)THEN 745 - PRINT *,' ++++++ GASPRE DEBUG : HISPRD to be called', 746 - - ' for ',CLSTYP,', NCLS=',NCLS,', distribution:' 747 - PRINT *,(CLSDIS(I),I=1,NCLS) 748 - ENDIF 749 - * Compute average number of pairs per cluster. 750 - CLSAVE=0 751 - CLSSUM=0 752 - DO 20 I=1,NCLS 753 - CLSAVE=CLSAVE+I*CLSDIS(I) 754 - CLSSUM=CLSSUM+CLSDIS(I) 755 - 20 CONTINUE 756 - CLSAVE=CLSAVE/CLSSUM 757 - * Prepare the histogram for random number generation. 758 - CALL HISPRD(CLSDIS,NCLS) 759 - ENDIF 760 - *** Call TIMLOG to register the amount of CPU time used. 761 - CALL TIMLOG('Reading and preparing gas data: ') 762 - END 531 GARFIELD ================================================== P=GAS D=GASPRT 1 ============================ 0 + +DECK,GASPRT. 1 - SUBROUTINE GASPRT 2 - *----------------------------------------------------------------------- 3 - * GASPRT - Routine printing an overview of the gas information. 4 - * VARIABLES : none 5 - * (Last changed on 17/ 2/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,GASDATA. 10.- +SEQ,BFIELD. 11.- +SEQ,PRINTPLOT. 12.- +SEQ,CONSTANTS. 13 - CHARACTER*120 STRING,SYMBOL,UNIT 14 - CHARACTER*20 STR1,STR2,STR3,STR4,STR5,STR6,STR7,STR8 15 - INTEGER I,J,K,NC1,NC2,NC3,NC4,NC5,NC6,NC7,NC8, 16 - - IGASOK,IMETH,IEXTR,JEXTR, 17 - - NCSYMB,NCUNIT,ITEM,NC 18 - REAL EXTR1,EXTR2,EXTR3,EXTR4,VAL1,VALN 19 - *** Identify the routine, if requested. 20 - IF(LIDENT)PRINT *,' /// ROUTINE GASPRT ///' 21 - *** Print a suitable heading for the gas tables. 22 - WRITE(LUNOUT,'(''1 SUMMARY OF THE GAS DATA''/ 23 - - '' =======================''/)') 24 - IF(GASID.NE.' ')WRITE(LUNOUT,'('' Identification: '',A)') 25 - - GASID 26 - *** Check for transport tables. 27 - IF(.NOT.(GASOK(1).OR.GASOK(2).OR.GASOK(3).OR. 28 - - GASOK(4).OR.GASOK(6).OR.GASOK(7).OR.GASOK(8).OR. 29 - - GASOK(9).OR.GASOK(10)))THEN 30 - WRITE(LUNOUT,'('' Transport properties have not been''/ 31 - - '' entered.'')') 32 - GOTO 100 33 - ENDIF 34 - *** 2D tables. 35 - IF(TAB2D)THEN 36 - * Loop over angles and B fields. 37 - DO 10 J=1,NBANG 38 - DO 40 K=1,NBTAB 39 - * Print the header for this combination. 40 - STRING(1:25)='Transport properties for ' 41 - NC=25 42 - CALL OUTFMT(180*BANG(J)/PI,2,STR1,NC1,'LEFT') 43 - STRING(NC+1:NC+26+NC1)='angle(E,B) = '//STR1(1:NC1)// 44 - - ' degrees and ' 45 - NC=NC+26+NC1 46 - CALL OUTFMT(BTAB(K)/100,2,STR1,NC1,'LEFT') 47 - STRING(NC+1:NC+7+NC1)='B = '//STR1(1:NC1)//' T:' 48 - NC=NC+7+NC1 49 - WRITE(LUNOUT,'(/2X,A/)') STRING(1:NC) 50 - * Print the items to be shown in part 1. 51 - WRITE(LUNOUT,'('' E v || E'', 52 - - '' v || Btrans v || ExB angle(v,E)'', 53 - - '' Ion mobility Townsend Attachment'')') 54 - WRITE(LUNOUT,'('' [V/cm] [cm/microsec]'', 55 - - '' [cm/microsec] [cm/microsec] [degrees]'', 56 - - '' [cm2/V.musec] [1/cm] [1/cm]'')') 57 - DO 20 I=1,NGAS 58 - CALL OUTFMT(EGAS(I)*PGAS,2,STR1,NC1,'RIGHT') 59 - IF(GASOK(1))THEN 60 - CALL OUTFMT(VGAS2(I,J,K),2,STR2,NC2,'RIGHT') 61 - ELSE 62 - STR2=' not available' 63 - ENDIF 1 531 P=GAS D=GASPRT 2 PAGE 809 64 - IF(GASOK(9))THEN 65 - CALL OUTFMT(XGAS2(I,J,K),2,STR3,NC3,'RIGHT') 66 - ELSE 67 - STR3=' not available' 68 - ENDIF 69 - IF(GASOK(10))THEN 70 - CALL OUTFMT(YGAS2(I,J,K),2,STR4,NC4,'RIGHT') 71 - ELSE 72 - STR4=' not available' 73 - ENDIF 74 - IF(GASOK(7))THEN 75 - CALL OUTFMT(180*WGAS2(I,J,K)/PI,2,STR5,NC5,'RIGHT') 76 - ELSE 77 - STR5=' not available' 78 - ENDIF 79 - IF(GASOK(2))THEN 80 - CALL OUTFMT(MGAS2(I,J,K),2,STR6,NC6,'RIGHT') 81 - ELSE 82 - STR6=' not available' 83 - ENDIF 84 - IF(GASOK(4).AND.AGAS2(I,J,K).GT.-20)THEN 85 - CALL OUTFMT(EXP(AGAS2(I,J,K))*PGAS,2,STR7,NC7,'RIGHT') 86 - ELSEIF(GASOK(4))THEN 87 - STR7=' 0' 88 - ELSE 89 - STR7=' not available' 90 - ENDIF 91 - IF(GASOK(6).AND.BGAS2(I,J,K).GT.-20)THEN 92 - CALL OUTFMT(EXP(BGAS2(I,J,K))*PGAS,2,STR8,NC8,'RIGHT') 93 - ELSEIF(GASOK(6))THEN 94 - STR8=' 0' 95 - ELSE 96 - STR8=' not available' 97 - ENDIF 98 - WRITE(LUNOUT,'(8A)') STR1(11:20),STR2(7:20),STR3(7:20), 99 - - STR4(7:20),STR5(7:20),STR6(7:20),STR7(7:20),STR8(7:20) 100 - 20 CONTINUE 101 - * Print the items to be shown in part 2. 102 - WRITE(LUNOUT,'(/'' E'', 103 - - '' sigma || E sigma || Btr sigma || ExB'', 104 - - '' rho(E,B) rho(E,ExB) rho(B,ExB)'')') 105 - WRITE(LUNOUT,'('' [V/cm]'', 106 - - '' [micron for 1 cm]'', 107 - - '' [-]'')') 108 - DO 60 I=1,NGAS 109 - CALL OUTFMT(EGAS(I)*PGAS,2,STR1,NC1,'RIGHT') 110 - IF(GASOK(3))THEN 111 - CALL OUTFMT(10000*DGAS2(I,J,K)/SQRT(PGAS),2, 112 - - STR2,NC2,'RIGHT') 113 - ELSE 114 - STR2=' not available' 115 - ENDIF 116 - IF(GASOK(8))THEN 117 - CALL OUTFMT(10000*OGAS2(I,J,K)/SQRT(PGAS),2, 118 - - STR3,NC3,'RIGHT') 119 - ELSE 120 - STR3=' not available' 121 - ENDIF 122 - STR4=' ' 123 - STR5=' ' 124 - STR6=' ' 125 - STR7=' ' 126 - WRITE(LUNOUT,'(8A)') STR1(11:20),STR2(7:20),STR3(7:20), 127 - - STR4(7:20),STR5(7:20),STR6(7:20),STR7(7:20) 128 - 60 CONTINUE 129 - 40 CONTINUE 130 - 10 CONTINUE 131 - *** 1D tables. 132 - ELSE 133 - * Print the header for this combination. 134 - IF(MAGOK)THEN 135 - STRING(1:25)='Transport properties for ' 136 - NC=25 137 - CALL OUTFMT(180*BANG(1)/PI,2,STR1,NC1,'LEFT') 138 - STRING(NC+1:NC+26+NC1)='angle(E,B) = '//STR1(1:NC1)// 139 - - ' degrees and ' 140 - NC=NC+26+NC1 141 - CALL OUTFMT(BTAB(1)/100,2,STR1,NC1,'LEFT') 142 - STRING(NC+1:NC+7+NC1)='B = '//STR1(1:NC1)//' T:' 143 - NC=NC+7+NC1 144 - WRITE(LUNOUT,'(/2X,A/)') STRING(1:NC) 145 - ELSE 146 - WRITE(LUNOUT,'(/2X,''Transport properties:''/)') 147 - ENDIF 148 - * Print the table. 149 - WRITE(LUNOUT,'('' E Vdrift'', 150 - - '' Ion mobility Diffusion (long, trans)'', 151 - - '' Townsend Attachment Lorentz angle'')') 152 - WRITE(LUNOUT,'('' [V/cm] [cm/microsec]'', 153 - - '' [cm2/V.musec] [micron for 1 cm]'', 154 - - '' [1/cm] [1/cm] [degrees]'')') 155 - DO 30 I=1,NGAS 156 - CALL OUTFMT(EGAS(I)*PGAS,2,STR1,NC1,'RIGHT') 157 - IF(GASOK(1))THEN 158 - CALL OUTFMT(VGAS(I),2,STR2,NC2,'RIGHT') 159 - ELSE 160 - STR2=' not available' 161 - ENDIF 162 - IF(GASOK(2))THEN 163 - CALL OUTFMT(MGAS(I),2,STR3,NC3,'RIGHT') 164 - ELSE 165 - STR3=' not available' 166 - ENDIF 167 - IF(GASOK(3))THEN 168 - CALL OUTFMT(10000*DGAS(I)/SQRT(PGAS),2, 169 - - STR4,NC4,'RIGHT') 1 531 P=GAS D=GASPRT 3 PAGE 810 170 - ELSE 171 - STR4=' not available' 172 - ENDIF 173 - IF(GASOK(8))THEN 174 - CALL OUTFMT(10000*OGAS(I)/SQRT(PGAS),2, 175 - - STR5,NC5,'RIGHT') 176 - ELSE 177 - STR5=' not available' 178 - ENDIF 179 - IF(GASOK(4).AND.AGAS(I).GT.-20)THEN 180 - CALL OUTFMT(EXP(AGAS(I))*PGAS,2,STR6,NC6,'RIGHT') 181 - ELSEIF(GASOK(4))THEN 182 - STR6=' 0' 183 - ELSE 184 - STR6=' not available' 185 - ENDIF 186 - IF(GASOK(6).AND.BGAS(I).GT.-20)THEN 187 - CALL OUTFMT(EXP(BGAS(I))*PGAS,2,STR7,NC7,'RIGHT') 188 - ELSEIF(GASOK(6))THEN 189 - STR7=' 0' 190 - ELSE 191 - STR7=' not available' 192 - ENDIF 193 - IF(GASOK(7))THEN 194 - CALL OUTFMT(180*WGAS(I)/PI,2,STR8,NC8,'RIGHT') 195 - ELSE 196 - STR8=' not available' 197 - ENDIF 198 - WRITE(LUNOUT,'(8A)') STR1(11:20),STR2(7:20),STR3(7:20), 199 - - STR4(7:20),STR5(7:20),STR6(7:20),STR7(7:20),STR8(7:20) 200 - 30 CONTINUE 201 - ENDIF 202 - *** Print the extrapolation formulae. 203 - WRITE(LUNOUT,'(/'' Interpolations and extrapolations:''/)') 204 - * Loop over the items. 205 - DO 50 ITEM=1,9 206 - * Print a header. 207 - IF(ITEM.EQ.1)THEN 208 - WRITE(LUNOUT,'('' Drift velocity along E:'')') 209 - IGASOK=1 210 - IMETH=IVMETH 211 - IEXTR=IVEXTR 212 - JEXTR=JVEXTR 213 - EXTR1=VEXTR1 214 - EXTR2=VEXTR2 215 - EXTR3=VEXTR3 216 - EXTR4=VEXTR4 217 - VAL1=VGAS(1) 218 - VALN=VGAS(NGAS) 219 - SYMBOL='v' 220 - NCSYMB=1 221 - UNIT='[cm/microsec]' 222 - NCUNIT=13 223 - ELSEIF(ITEM.EQ.2)THEN 224 - WRITE(LUNOUT,'(/'' Drift velocity along Btrans:'')') 225 - IGASOK=9 226 - IMETH=IXMETH 227 - IEXTR=IXEXTR 228 - JEXTR=JXEXTR 229 - EXTR1=XEXTR1 230 - EXTR2=XEXTR2 231 - EXTR3=XEXTR3 232 - EXTR4=XEXTR4 233 - VAL1=XGAS(1) 234 - VALN=XGAS(NGAS) 235 - SYMBOL='v' 236 - NCSYMB=1 237 - UNIT='[cm/microsec]' 238 - NCUNIT=13 239 - ELSEIF(ITEM.EQ.3)THEN 240 - WRITE(LUNOUT,'(/'' Drift velocity along ExB:'')') 241 - IGASOK=10 242 - IMETH=IYMETH 243 - IEXTR=IYEXTR 244 - JEXTR=JYEXTR 245 - EXTR1=YEXTR1 246 - EXTR2=YEXTR2 247 - EXTR3=YEXTR3 248 - EXTR4=YEXTR4 249 - VAL1=YGAS(1) 250 - VALN=YGAS(NGAS) 251 - SYMBOL='v' 252 - NCSYMB=1 253 - UNIT='[cm/microsec]' 254 - NCUNIT=13 255 - ELSEIF(ITEM.EQ.4)THEN 256 - WRITE(LUNOUT,'(/'' Angle between v and E:'')') 257 - IGASOK=7 258 - IMETH=IWMETH 259 - IEXTR=IWEXTR 260 - JEXTR=JWEXTR 261 - EXTR1=WEXTR1 262 - EXTR2=WEXTR2 263 - EXTR3=WEXTR3 264 - EXTR4=WEXTR4 265 - VAL1=WGAS(1) 266 - VALN=WGAS(NGAS) 267 - SYMBOL='angle(v,E)' 268 - NCSYMB=10 269 - UNIT='[radian]' 270 - NCUNIT=13 271 - ELSEIF(ITEM.EQ.5)THEN 272 - WRITE(LUNOUT,'(/'' Ion mobility:'')') 273 - IGASOK=2 274 - IMETH=IMMETH 275 - IEXTR=IMEXTR 1 531 P=GAS D=GASPRT 4 PAGE 811 276 - JEXTR=JMEXTR 277 - EXTR1=MEXTR1 278 - EXTR2=MEXTR2 279 - EXTR3=MEXTR3 280 - EXTR4=MEXTR4 281 - VAL1=MGAS(1) 282 - VALN=MGAS(NGAS) 283 - SYMBOL='mu ion' 284 - NCSYMB=6 285 - UNIT='[cm^2/(microsec.V)]' 286 - NCUNIT=19 287 - ELSEIF(ITEM.EQ.6)THEN 288 - WRITE(LUNOUT,'(/'' Longitudinal diffusion:'')') 289 - IGASOK=3 290 - IMETH=IDMETH 291 - IEXTR=IDEXTR 292 - JEXTR=JDEXTR 293 - EXTR1=DEXTR1 294 - EXTR2=DEXTR2 295 - EXTR3=DEXTR3 296 - EXTR4=DEXTR4 297 - VAL1=DGAS(1) 298 - VALN=DGAS(NGAS) 299 - SYMBOL='sigma_L.sqrt(p)' 300 - NCSYMB=15 301 - UNIT='[cm.sqrt(Torr) for 1 cm]' 302 - NCUNIT=24 303 - ELSEIF(ITEM.EQ.7)THEN 304 - WRITE(LUNOUT,'(/'' Transverse diffusion:'')') 305 - IGASOK=8 306 - IMETH=IOMETH 307 - IEXTR=IOEXTR 308 - JEXTR=JOEXTR 309 - EXTR1=OEXTR1 310 - EXTR2=OEXTR2 311 - EXTR3=OEXTR3 312 - EXTR4=OEXTR4 313 - VAL1=OGAS(1) 314 - VALN=OGAS(NGAS) 315 - SYMBOL='sigma_T.sqrt(p)' 316 - NCSYMB=15 317 - UNIT='[cm.sqrt(Torr) for 1 cm]' 318 - NCUNIT=24 319 - ELSEIF(ITEM.EQ.8)THEN 320 - WRITE(LUNOUT,'(/'' Townsend coefficient:'')') 321 - IGASOK=4 322 - IMETH=IAMETH 323 - IEXTR=IAEXTR 324 - JEXTR=JAEXTR 325 - EXTR1=AEXTR1 326 - EXTR2=AEXTR2 327 - EXTR3=AEXTR3 328 - EXTR4=AEXTR4 329 - VAL1=AGAS(1) 330 - VALN=AGAS(NGAS) 331 - SYMBOL='log(alpha/p)' 332 - NCSYMB=12 333 - UNIT='[-log(cm.Torr)]' 334 - NCUNIT=15 335 - ELSEIF(ITEM.EQ.9)THEN 336 - WRITE(LUNOUT,'(/'' Attachment coefficient:'')') 337 - IGASOK=6 338 - IMETH=IBMETH 339 - IEXTR=IBEXTR 340 - JEXTR=JBEXTR 341 - EXTR1=BEXTR1 342 - EXTR2=BEXTR2 343 - EXTR3=BEXTR3 344 - EXTR4=BEXTR4 345 - VAL1=BGAS(1) 346 - VALN=BGAS(NGAS) 347 - SYMBOL='log(eta/p)' 348 - NCSYMB=10 349 - UNIT='[-log(cm.Torr)]' 350 - NCUNIT=15 351 - ENDIF 352 - ** Quickly done if there is no such data. 353 - IF(.NOT.GASOK(IGASOK))THEN 354 - WRITE(LUNOUT,'('' Not applicable.'')') 355 - ** Data on a (E,angle,B) grid. 356 - ELSEIF(TAB2D)THEN 357 - * Interpolation method. 358 - IF(IMETH.EQ.1)THEN 359 - WRITE(LUNOUT,'(7X,''Linear interpolation for:'')') 360 - ELSEIF(IMETH.EQ.2)THEN 361 - WRITE(LUNOUT,'(7X,''Quadratic interpolation for:'')') 362 - ELSEIF(IMETH.EQ.3)THEN 363 - WRITE(LUNOUT,'(7X,''Cubic interpolation for:'')') 364 - ELSE 365 - WRITE(LUNOUT,'(7X,''# Inapplicable'', 366 - - '' interpolation method for:'')') 367 - ENDIF 368 - * Range of applicability. 369 - CALL OUTFMT(EGAS(1)*PGAS,2,STR1,NC1,'LEFT') 370 - CALL OUTFMT(EGAS(NGAS)*PGAS,2,STR2,NC2,'LEFT') 371 - WRITE(LUNOUT,'(11X,A,'' < E < '',A,'' V/cm,'')') 372 - - STR1(1:NC1),STR2(1:NC2) 373 - IF(NBANG.EQ.1)THEN 374 - WRITE(LUNOUT,'(11X,''all angles between E and B,'')') 375 - ELSE 376 - CALL OUTFMT(180*BANG(1)/PI,2,STR1,NC1,'LEFT') 377 - CALL OUTFMT(180*BANG(NBANG)/PI,2,STR2,NC2, 378 - - 'LEFT') 379 - WRITE(LUNOUT,'(11X,A,'' < angle(E,B) < '', 380 - - A,'' degrees,'')') STR1(1:NC1),STR2(1:NC2) 381 - ENDIF 1 531 P=GAS D=GASPRT 5 PAGE 812 382 - IF(NBANG.EQ.1)THEN 383 - WRITE(LUNOUT,'(11X,''all magnetic field strengths.'')') 384 - ELSE 385 - CALL OUTFMT(BTAB(1)/100,2,STR1,NC1,'LEFT') 386 - CALL OUTFMT(BTAB(NBTAB)/100,2,STR2,NC2,'LEFT') 387 - WRITE(LUNOUT,'(11X,A,'' < B < '',A,'' T.'')') 388 - - STR1(1:NC1),STR2(1:NC2) 389 - ENDIF 390 - * Special case of alpha and eta. 391 - IF((ITEM.EQ.8.AND.IATHR.GT.1).OR. 392 - - (ITEM.EQ.9.AND.IBTHR.GT.1))THEN 393 - CALL OUTFMT(EGAS(1)*PGAS,2,STR1,NC1,'LEFT') 394 - IF(ITEM.EQ.8)THEN 395 - CALL OUTFMT(EGAS(IATHR)*PGAS,2,STR2,NC2,'LEFT') 396 - ELSE 397 - CALL OUTFMT(EGAS(IBTHR)*PGAS,2,STR2,NC2,'LEFT') 398 - ENDIF 399 - WRITE(LUNOUT,'(7X,''For numeric stability, linear'', 400 - - '' interpolation is used in the subrange:''/ 401 - - 11X,A,'' < E < '',A,'' V/cm,'')') 402 - - STR1(1:NC1),STR2(1:NC2) 403 - ENDIF 404 - * Extrapolation method. 405 - WRITE(LUNOUT,'(7X,''Constant extrapolation for:''/ 406 - - 11X,''values outside this range.'')') 407 - ** Data only having E dependence. 408 - ELSE 409 - * Range limits. 410 - CALL OUTFMT(EGAS(1)*PGAS,2,STR1,NC1,'LEFT') 411 - CALL OUTFMT(EGAS(NGAS)*PGAS,2,STR2,NC2,'LEFT') 412 - * Extrapolation towards lower E/p. 413 - IF(JEXTR.EQ.0)THEN 414 - CALL OUTFMT(VAL1,2,STR5,NC5,'LEFT') 415 - WRITE(LUNOUT,'('' for E < '',A,'' V/cm: '', 416 - - A,'' = '',A,'' '',A,'','')') STR1(1:NC1), 417 - - SYMBOL(1:NCSYMB),STR5(1:NC5),UNIT(1:NCUNIT) 418 - ELSEIF(JEXTR.EQ.1)THEN 419 - CALL OUTFMT(EXTR3,2,STR3,NC3,'LEFT') 420 - CALL OUTFMT(ABS(EXTR4/PGAS),2,STR4,NC4,'LEFT') 421 - IF(EXTR4.LT.0)THEN 422 - WRITE(LUNOUT,'('' for E < '',A, 423 - - '' V/cm: '',A,'' = '',A,'' - '',A, 424 - - '' * E '',A,'','')') 425 - - STR1(1:NC1),SYMBOL(1:NCSYMB), 426 - - STR3(1:NC3),STR4(1:NC4),UNIT(1:NCUNIT) 427 - ELSE 428 - WRITE(LUNOUT,'('' for E < '',A, 429 - - '' V/cm: '',A,'' = '',A,'' + '',A, 430 - - '' * E '',A,'','')') 431 - - STR1(1:NC1),SYMBOL(1:NCSYMB), 432 - - STR3(1:NC3),STR4(1:NC4),UNIT(1:NCUNIT) 433 - ENDIF 434 - ELSEIF(JEXTR.EQ.2)THEN 435 - CALL OUTFMT(EXTR3,2,STR3,NC3,'LEFT') 436 - CALL OUTFMT(ABS(EXTR4/PGAS),2,STR4,NC4,'LEFT') 437 - IF(EXTR4.LT.0)THEN 438 - WRITE(LUNOUT,'('' for E < '',A, 439 - - '' V/cm: '',A,'' = exp('',A,'' - '',A, 440 - - '' * E) '',A,'','')') 441 - - STR1(1:NC1),SYMBOL(1:NCSYMB), 442 - - STR3(1:NC3),STR4(1:NC4),UNIT(1:NCUNIT) 443 - ELSE 444 - WRITE(LUNOUT,'('' for E < '',A, 445 - - '' V/cm: '',A,'' = exp('',A,'' + '',A, 446 - - '' * E) '',A,'','')') 447 - - STR1(1:NC1),SYMBOL(1:NCSYMB), 448 - - STR3(1:NC3),STR4(1:NC4),UNIT(1:NCUNIT) 449 - ENDIF 450 - ELSE 451 - PRINT *,' !!!!!! GASPRT WARNING : Unknown'// 452 - - ' extrapolation method seen.' 453 - ENDIF 454 - * Interpolation. 455 - IF(IMETH.EQ.0)THEN 456 - WRITE(LUNOUT,'('' for '',A,'' < E < '',A, 457 - - '' V/cm: '',A,'' is interpolated with cubic'', 458 - - '' splines,'')') STR1(1:NC1),STR2(1:NC2), 459 - - SYMBOL(1:NCSYMB) 460 - ELSEIF(IMETH.EQ.1)THEN 461 - WRITE(LUNOUT,'('' for '',A,'' < E < '',A, 462 - - '' V/cm: '',A,'' is linearly interpolated,'')') 463 - - STR1(1:NC1),STR2(1:NC2),SYMBOL(1:NCSYMB) 464 - ELSEIF(IMETH.EQ.2)THEN 465 - WRITE(LUNOUT,'('' for '',A,'' < E < '',A, 466 - - '' V/cm: '',A,'' is quadratically'', 467 - - '' interpolated,'')') 468 - - STR1(1:NC1),STR2(1:NC2),SYMBOL(1:NCSYMB) 469 - ELSEIF(IMETH.EQ.3)THEN 470 - WRITE(LUNOUT,'('' for '',A,'' < E < '',A, 471 - - '' V/cm: '',A,'' is cubicly interpolated,'')') 472 - - STR1(1:NC1),STR2(1:NC2),SYMBOL(1:NCSYMB) 473 - ELSE 474 - CALL OUTFMT(REAL(IMETH),2,STR6,NC6,'LEFT') 475 - WRITE(LUNOUT,'('' for '',A,'' < E < '',A, 476 - - '' V/cm: '',A,'' is interpolated with Newton'', 477 - - '' polynomials of order '',A)') 478 - - STR1(1:NC1),STR2(1:NC2),SYMBOL(1:NCSYMB), 479 - - STR6(1:NC6) 480 - ENDIF 481 - * Special case of alpha and eta. 482 - IF((ITEM.EQ.8.AND.IATHR.GT.1).OR. 483 - - (ITEM.EQ.9.AND.IBTHR.GT.1))THEN 484 - CALL OUTFMT(EGAS(1)*PGAS,2,STR3,NC3,'LEFT') 485 - IF(ITEM.EQ.8)THEN 486 - CALL OUTFMT(EGAS(IATHR)*PGAS,2,STR4,NC4,'LEFT') 487 - ELSE 1 531 P=GAS D=GASPRT 6 PAGE 813 488 - CALL OUTFMT(EGAS(IBTHR)*PGAS,2,STR4,NC4,'LEFT') 489 - ENDIF 490 - WRITE(LUNOUT,'(7X,''but for '',A,'' < E < '',A, 491 - - '' V/cm, linear interpolation is used for'', 492 - - '' better numeric stability,'')') 493 - - STR3(1:NC3),STR4(1:NC4) 494 - ENDIF 495 - * Extrapolation towards higher E/p. 496 - IF(IEXTR.EQ.0)THEN 497 - CALL OUTFMT(VALN,2,STR5,NC5,'LEFT') 498 - WRITE(LUNOUT,'('' for E > '',A,'' V/cm: '', 499 - - A,'' = '',A,'' '',A,''.'')') STR2(1:NC2), 500 - - SYMBOL(1:NCSYMB),STR5(1:NC5),UNIT(1:NCUNIT) 501 - ELSEIF(IEXTR.EQ.1)THEN 502 - CALL OUTFMT(EXTR1,2,STR3,NC3,'LEFT') 503 - CALL OUTFMT(ABS(EXTR2/PGAS),2,STR4,NC4,'LEFT') 504 - IF(EXTR2.LT.0)THEN 505 - WRITE(LUNOUT,'('' for E > '',A, 506 - - '' V/cm: '',A,'' = '',A,'' - '',A, 507 - - '' * E '',A,''.'')') 508 - - STR1(1:NC1),SYMBOL(1:NCSYMB), 509 - - STR3(1:NC3),STR4(1:NC4),UNIT(1:NCUNIT) 510 - ELSE 511 - WRITE(LUNOUT,'('' for E > '',A, 512 - - '' V/cm: '',A,'' = '',A,'' + '',A, 513 - - '' * E '',A,''.'')') 514 - - STR1(1:NC1),SYMBOL(1:NCSYMB), 515 - - STR3(1:NC3),STR4(1:NC4),UNIT(1:NCUNIT) 516 - ENDIF 517 - ELSEIF(IEXTR.EQ.2)THEN 518 - CALL OUTFMT(EXTR1,2,STR3,NC3,'LEFT') 519 - CALL OUTFMT(ABS(EXTR2/PGAS),2,STR4,NC4,'LEFT') 520 - IF(EXTR2.LT.0)THEN 521 - WRITE(LUNOUT,'('' for E > '',A, 522 - - '' V/cm: '',A,'' = exp('',A,'' - '',A, 523 - - '' * E) '',A,''.'')') 524 - - STR1(1:NC1),SYMBOL(1:NCSYMB), 525 - - STR3(1:NC3),STR4(1:NC4),UNIT(1:NCUNIT) 526 - ELSE 527 - WRITE(LUNOUT,'('' for E > '',A, 528 - - '' V/cm: '',A,'' = exp('',A,'' + '',A, 529 - - '' * E) '',A,''.'')') 530 - - STR1(1:NC1),SYMBOL(1:NCSYMB), 531 - - STR3(1:NC3),STR4(1:NC4),UNIT(1:NCUNIT) 532 - ENDIF 533 - ELSE 534 - PRINT *,' !!!!!! GASPRT WARNING : Unknown'// 535 - - ' extrapolation method seen.' 536 - ENDIF 537 - ENDIF 538 - ** Next item. 539 - 50 CONTINUE 540 - *** Print some information about the clustersize information. 541 - 100 CONTINUE 542 - CALL OUTFMT(PGAS,2,STR1,NC1,'LEFT') 543 - CALL OUTFMT(TGAS,2,STR2,NC2,'LEFT') 544 - WRITE(LUNOUT,'(// 545 - - '' Other data:''// 546 - - '' Pressure of the gas : '',A,'' Torr''/ 547 - - '' Temperature of the gas : '',A,'' K''/)') 548 - - STR1(1:NC1),STR2(1:NC2) 549 - IF(CLSTYP.EQ.'LANDAU'.AND.GASOK(5))THEN 550 - CALL OUTFMT(Z,2,STR1,NC1,'LEFT') 551 - CALL OUTFMT(A,2,STR2,NC2,'LEFT') 552 - CALL OUTFMT(RHO,2,STR3,NC3,'LEFT') 553 - CALL OUTFMT(EMPROB,2,STR4,NC4,'LEFT') 554 - CALL OUTFMT(EPAIR,2,STR5,NC5,'LEFT') 555 - WRITE(LUNOUT,'( 556 - - '' Number of protons in one molecule : '',A/ 557 - - '' Atomic number of the gas : '',A/ 558 - - '' Density : '',A, 559 - - '' g/cm3''/ 560 - - '' Most probable energy loss per cm : '',A, 561 - - '' eV/cm''/ 562 - - '' Energy needed for one ion pair : '',A, 563 - - '' eV'')') STR1(1:NC1),STR2(1:NC2), 564 - - STR3(1:NC3),STR4(1:NC4),STR5(1:NC5) 565 - ENDIF 566 - IF(GASOK(5))THEN 567 - CALL OUTFMT(CMEAN,2,STR1,NC1,'LEFT') 568 - WRITE(LUNOUT,'( 569 - - '' Average number of clusters : '',A, 570 - - '' per cm'')') STR1(1:NC1) 571 - ENDIF 572 - CALL OUTFMT(10000*DLION,2,STR1,NC1,'LEFT') 573 - CALL OUTFMT(10000*DTION,2,STR2,NC2,'LEFT') 574 - WRITE(LUNOUT,'( 575 - - '' Longitudinal ion diffusion : '',A, 576 - - '' micron for 1 cm of drift''/ 577 - - '' Transverse ion diffusion : '',A, 578 - - '' micron for 1 cm of drift'')') STR1(1:NC1),STR2(1:NC2) 579 - *** Register the amount of CPU time used for printing, 580 - CALL TIMLOG('Printing of the gas data: ') 581 - END 532 GARFIELD ================================================== P=GAS D=GASWRT 1 ============================ 0 + +DECK,GASWRT. 1 - SUBROUTINE GASWRT(IMODE) 2 - *----------------------------------------------------------------------- 3 - * GASWRT - This routine writes all gas information on an external 4 - * dataset. 5 - * VARIABLES : IMODE : If 1 : find name, if 2 write gas data 6 - * IACC : If 0 no name specified, no write 7 - * If 1 name OK, write will be executed 8 - * (Last changed on 12/ 2/00.) 1 532 P=GAS D=GASWRT 2 PAGE 814 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,GASDATA. 13.- +SEQ,BFIELD. 14.- +SEQ,PRINTPLOT. 15 - CHARACTER*(MXCHAR) STRING 16 - CHARACTER*29 REMARK 17 - CHARACTER*8 TIME,DATE,MEMBER 18 - CHARACTER*(MXNAME) FILE 19 - LOGICAL EXMEMB 20 - INTEGER IACC,IMODE,NCFILE,NCMEMB,NCREM,INPCMP,NWORD,INEXT,I,J,K, 21 - - II,IOS,IFAIL 22 - EXTERNAL INPCMP 0 23-+ +SELF,IF=SAVE. 24 - SAVE IACC,FILE,NCFILE,MEMBER,NCMEMB,REMARK,NCREM 0 25-+ +SELF. 26 - DATA IACC/0/ 27 - *** Identify the routine, if requested. 28 - IF(LIDENT)PRINT *,' /// ROUTINE GASWRT ///' 29 - *** Goto 200 if a write is requested. 30 - IF(IMODE.EQ.2)GOTO 200 31 - * Set the file name etc. 32 - IACC=0 33 - FILE=' ' 34 - NCFILE=1 35 - MEMBER='< none >' 36 - NCMEMB=8 37 - REMARK='none' 38 - NCREM=4 39 - * First decode the argument string. 40 - CALL INPNUM(NWORD) 41 - * Make sure there is at least one argument. 42 - IF(NWORD.EQ.1)THEN 43 - PRINT *,' !!!!!! GASWRT WARNING : WRITE takes at least one', 44 - - ' argument (a dataset name); data will not be written.' 45 - RETURN 46 - * Check whether keywords have been used. 47 - ELSEIF(INPCMP(2,'D#ATASET')+INPCMP(2,'R#EMARK').NE.0)THEN 48 - INEXT=2 49 - DO 10 I=2,NWORD 50 - IF(I.LT.INEXT)GOTO 10 51 - IF(INPCMP(I,'D#ATASET').NE.0)THEN 52 - IF(INPCMP(I+1,'R#EMARK').NE.0.OR.I+1.GT.NWORD)THEN 53 - CALL INPMSG(I,'The dataset name is missing. ') 54 - INEXT=I+1 55 - ELSE 56 - CALL INPSTR(I+1,I+1,STRING,NCFILE) 57 - FILE=STRING 58 - INEXT=I+2 59 - IF(INPCMP(I+2,'R#EMARK').EQ.0.AND. 60 - - I+2.LE.NWORD)THEN 61 - CALL INPSTR(I+2,I+2,STRING,NCMEMB) 62 - MEMBER=STRING 63 - INEXT=I+3 64 - ENDIF 65 - ENDIF 66 - ELSEIF(INPCMP(I,'R#EMARK').NE.0)THEN 67 - IF(INPCMP(I+1,'D#ATASET').NE.0.OR.I+1.GT.NWORD)THEN 68 - CALL INPMSG(I,'The remark is missing. ') 69 - INEXT=I+1 70 - ELSE 71 - CALL INPSTR(I+1,I+1,STRING,NCREM) 72 - REMARK=STRING 73 - INEXT=I+2 74 - ENDIF 75 - ELSE 76 - CALL INPMSG(I,'The parameter is not known. ') 77 - ENDIF 78 - 10 CONTINUE 79 - * Otherwise the string is interpreted as a file name (+ member name). 80 - ELSE 81 - CALL INPSTR(2,2,STRING,NCFILE) 82 - FILE=STRING 83 - IF(NWORD.GE.3)THEN 84 - CALL INPSTR(3,3,STRING,NCMEMB) 85 - MEMBER=STRING 86 - ENDIF 87 - IF(NWORD.GE.4)THEN 88 - CALL INPSTR(4,NWORD,STRING,NCREM) 89 - REMARK=STRING 90 - ENDIF 91 - ENDIF 92 - * Print error messages. 93 - CALL INPERR 94 - IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! GASWRT WARNING : The file', 95 - - ' name is truncated to MXNAME (=',MXNAME,') characters.' 96 - IF(NCMEMB.GT.8)PRINT *,' !!!!!! GASWRT WARNING : The member', 97 - - ' name is shortened to ',MEMBER,', first 8 characters.' 98 - IF(NCREM.GT.29)PRINT *,' !!!!!! GASWRT WARNING : The remark', 99 - - ' shortened to ',REMARK,', first 29 characters.' 100 - NCFILE=MIN(NCFILE,MXNAME) 101 - NCMEMB=MIN(NCMEMB,8) 102 - NCREM=MIN(NCREM,29) 103 - * Check whether the member already exists. 104 - CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'GAS',EXMEMB) 105 - IF(JEXMEM.EQ.2.AND.EXMEMB)THEN 106 - PRINT *,' ------ GASWRT MESSAGE : A copy of the member'// 107 - - ' exists; new member will be appended.' 108 - ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN 109 - PRINT *,' !!!!!! GASWRT WARNING : A copy of the member'// 110 - - ' exists already; member will not be written.' 111 - RETURN 112 - ENDIF 1 532 P=GAS D=GASWRT 3 PAGE 815 113 - * Everything seems to be OK, the accept flag can be set to 'accept'. 114 - IACC=1 115 - * Print some debugging output if requested. 116 - IF(LDEBUG)THEN 117 - PRINT *,' ++++++ GASWRT DEBUG : File= ',FILE(1:NCFILE), 118 - - ', member= ',MEMBER(1:NCMEMB),' IACC=',IACC 119 - PRINT *,' Remark= ',REMARK(1:NCREM) 120 - ENDIF 121 - RETURN 122 - *** Execute write operation if a valid name is available. 123 - 200 CONTINUE 124 - IF(IACC.EQ.0)RETURN 125 - IACC=0 126 - * Open a dataset and inform DSNLOG. 127 - CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) 128 - IF(IFAIL.NE.0)THEN 129 - PRINT *,' !!!!!! GASWRT WARNING : Opening ',FILE(1:NCFILE), 130 - - ' failed ; gas data will not be written' 131 - RETURN 132 - ENDIF 133 - CALL DSNLOG(FILE,'Gas data ','Sequential','Write ') 134 - IF(LDEBUG)PRINT *,' ++++++ GASWRT DEBUG : Dataset ', 135 - - FILE(1:NCFILE),' opened on unit 12 for seq write.' 136 - * Now write a heading record to the file. 137 - CALL DATTIM(DATE,TIME) 138 - WRITE(STRING,'(''% Created '',A8,'' at '',A8,1X,A8,'' GAS '', 139 - - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK 140 - WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING 141 - * Write a version number. 142 - WRITE(12,'('' Version : 3'')') 143 - * Write the gas to the dataset. 144 - WRITE(12,'('' GASOK bits: '',10L1)',IOSTAT=IOS,ERR=2010) 145 - - (GASOK(I),I=1,10) 146 - WRITE(12,'('' Identifier: '',A)',IOSTAT=IOS,ERR=2010) GASID 147 - WRITE(12,'('' Clusters : '',A80)',IOSTAT=IOS,ERR=2010) FCNTAB 148 - WRITE(12,'('' Dimension : '',L1,3I10)',IOSTAT=IOS,ERR=2010) 149 - - TAB2D,NGAS,NBANG,NBTAB 150 - WRITE(12,'('' The gas tables follow:'')',IOSTAT=IOS,ERR=2010) 151 - IF(TAB2D)THEN 152 - WRITE(12,'('' E-B angles ''/(5E15.8))',IOSTAT=IOS,ERR=2010) 153 - - (BANG(I),I=1,NBANG) 154 - WRITE(12,'('' B fields ''/(5E15.8))',IOSTAT=IOS,ERR=2010) 155 - - (BTAB(I),I=1,NBTAB) 156 - DO 210 I=1,NGAS 157 - DO 220 J=1,NBANG 158 - DO 230 K=1,NBTAB 159 - WRITE(12,'(8E15.8/2E15.8)',IOSTAT=IOS,ERR=2010) 160 - - EGAS(I),VGAS2(I,J,K),XGAS2(I,J,K),YGAS2(I,J,K), 161 - - DGAS2(I,J,K),OGAS2(I,J,K), 162 - - AGAS2(I,J,K),BGAS2(I,J,K),MGAS2(I,J,K),WGAS2(I,J,K) 163 - 230 CONTINUE 164 - 220 CONTINUE 165 - 210 CONTINUE 166 - ELSE 167 - DO 240 I=1,NGAS 168 - WRITE(12,'(8E15.8/15X,7E15.8/15X,4E15.8)',IOSTAT=IOS, 169 - - ERR=2010) 170 - - EGAS(I), 171 - - VGAS(I),CVGAS(I),XGAS(I),CXGAS(I),YGAS(I),CYGAS(I), 172 - - DGAS(I),CDGAS(I),OGAS(I),COGAS(I), 173 - - AGAS(I),CAGAS(I),BGAS(I),CBGAS(I),MGAS(I),CMGAS(I), 174 - - WGAS(I),CWGAS(I) 175 - 240 CONTINUE 176 - WRITE(12,'('' H Extr: '',9(/I2,2E15.8))',IOSTAT=IOS, 177 - - ERR=2010) 178 - - IVEXTR,VEXTR1,VEXTR2, 179 - - IXEXTR,XEXTR1,XEXTR2,IYEXTR,YEXTR1,YEXTR2, 180 - - IDEXTR,DEXTR1,DEXTR2, 181 - - IAEXTR,AEXTR1,AEXTR2,IBEXTR,BEXTR1,BEXTR2, 182 - - IMEXTR,MEXTR1,MEXTR2,IWEXTR,WEXTR1,WEXTR2, 183 - - IOEXTR,OEXTR1,OEXTR2 184 - WRITE(12,'('' L Extr: '',9(/I2,2E15.8))',IOSTAT=IOS, 185 - - ERR=2010) 186 - - JVEXTR,VEXTR3,VEXTR4, 187 - - JXEXTR,XEXTR3,XEXTR4,JYEXTR,YEXTR3,YEXTR4, 188 - - JDEXTR,DEXTR3,DEXTR4, 189 - - JAEXTR,AEXTR3,AEXTR4,JBEXTR,BEXTR3,BEXTR4, 190 - - JMEXTR,MEXTR3,MEXTR4,JWEXTR,WEXTR3,WEXTR4, 191 - - JOEXTR,OEXTR3,OEXTR4 192 - ENDIF 193 - WRITE(12,'('' Thresholds: '',2I10)') IATHR,IBTHR 194 - WRITE(12,'('' Interp: '',9I10)',IOSTAT=IOS,ERR=2010) 195 - - IVMETH,IXMETH,IYMETH,IDMETH,IAMETH,IBMETH,IMMETH, 196 - - IWMETH,IOMETH 197 - WRITE(12,'('' A ='',E15.8,'', Z ='',E15.8, 198 - - '', EMPROB='',E15.8,'', EPAIR ='',E15.8)',IOSTAT=IOS, 199 - - ERR=2010) A,Z,EMPROB,EPAIR 200 - WRITE(12,'('' Ion diffusion: '',2E15.8)') DLION,DTION 201 - WRITE(12,'('' CMEAN ='',E15.8,'', RHO ='',E15.8, 202 - - '', PGAS ='',E15.8,'', TGAS ='',E15.8)',IOSTAT=IOS, 203 - - ERR=2010) CMEAN,RHO,PGAS,TGAS 204 - WRITE(12,'('' CLSTYP : '',A10)',IOSTAT=IOS,ERR=2010) CLSTYP 205 - WRITE(12,'('' FCNCLS : '',A80)',IOSTAT=IOS,ERR=2010) FCNCLS 206 - WRITE(12,'('' NCLS : '',2I10)',IOSTAT=IOS,ERR=2010) NCLS 207 - WRITE(12,'('' Average : '',D25.18)',IOSTAT=IOS,ERR=2010) CLSAVE 208 - DO 250 II=1,NCLS,5 209 - WRITE(12,'(5D25.18)',IOSTAT=IOS,ERR=2010) 210 - - (CLSDIS(I),I=II,MIN(II+4,NCLS)) 211 - 250 CONTINUE 212 - * Write the Heed data to the file. 213 - CALL GASHWR(IFAIL) 214 - IF(IFAIL.NE.0)PRINT *,' !!!!!! GASWRT WARNING : Writing the'// 215 - - ' Heed data failed ; gas data unuseable.' 216 - * Close the file after the operation. 217 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 218 - IACC=0 1 532 P=GAS D=GASWRT 4 PAGE 816 219 - CALL TIMLOG('Writing the gas data to a dataset: ') 220 - RETURN 221 - *** Handle the I/O error conditions. 222 - 2010 CONTINUE 223 - PRINT *,' ###### GASWRT ERROR : Error while writing'// 224 - - ' to '//FILE(1:NCFILE)//' via unit 12 ; gas data unuseable.' 225 - CALL INPIOS(IOS) 226 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 227 - RETURN 228 - 2030 CONTINUE 229 - PRINT *,' ###### GASWRT ERROR : Dataset '//FILE(1:NCFILE)// 230 - - ' on unit 12 cannot be closed ; results not predictable' 231 - CALL INPIOS(IOS) 232 - END 533 GARFIELD ================================================== P=GAS D=GASVEL 1 ============================ 0 + +DECK,GASVEL. 1 - REAL FUNCTION GASVEL(EX,EY,EZ,BX,BY,BZ) 2 - *----------------------------------------------------------------------- 3 - * GASVEL - Function calculating the drift speed along E. 4 - * VARIABLES : SPEED : The actual speed (=GASVEL) 5 - * (Last changed on 13/ 2/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,GASDATA. 10.- +SEQ,BFIELD. 11 - REAL EX,EY,EZ,E,BX,BY,BZ,B,EBANG,DIVDIF,SPEED 12 - INTEGER IFAIL 13 - EXTERNAL DIVDIF 14 - *** Obtain the magnitude of the electric field. 15 - E=SQRT(EX**2+EY**2+EZ**2) 16 - IF(E.LE.0.0)THEN 17 - GASVEL=0.0 18 - RETURN 19 - ENDIF 20 - *** Treat the case that the table is 2-dimensional. 21 - IF(TAB2D)THEN 22 - * B field magnitude. 23 - B=SQRT(BX**2+BY**2+BZ**2) 24 - * Obtain the angle between B field and E field. 25 - IF(E*B.EQ.0)THEN 26 - EBANG=BANG(1) 27 - ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN 28 - EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ 29 - - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) 30 - ELSE 31 - EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) 32 - ENDIF 33 - * Interpolate. 34 - CALL BOXIN3(VGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, 35 - - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,SPEED,IVMETH,IFAIL) 36 - GASVEL=SPEED 37 - * Verify error. 38 - IF(IFAIL.NE.0)GASVEL=0 39 - *** Treat the case that the table is 1-dimensional. 40 - ELSE 41 - * Extrapolation towards small E/p. 42 - IF(E/PGAS.LT.EGAS(1))THEN 43 - GASVEL=VGAS(1) 44 - IF(JVEXTR.EQ.1)GASVEL=VEXTR3+VEXTR4*E/PGAS 45 - IF(JVEXTR.EQ.2)GASVEL=EXP(MIN(50.0, 46 - - VEXTR3+VEXTR4*E/PGAS)) 47 - * Extrapolation towards large E/p. 48 - ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN 49 - GASVEL=VGAS(NGAS) 50 - IF(IVEXTR.EQ.1)GASVEL=VEXTR1+VEXTR2*E/PGAS 51 - IF(IVEXTR.EQ.2)GASVEL=EXP(MIN(50.0, 52 - - VEXTR1+VEXTR2*E/PGAS)) 53 - * Only one point. 54 - ELSEIF(NGAS.LE.1)THEN 55 - GASVEL=VGAS(1) 56 - * Intermediate points, spline interpolation. 57 - ELSEIF(IVMETH.EQ.0)THEN 58 - CALL INTERP(EGAS,VGAS,CVGAS,NGAS,E/PGAS,SPEED,IFAIL) 59 - GASVEL=SPEED 60 - * Intermediate points, Newton interpolation. 61 - ELSE 62 - GASVEL=DIVDIF(VGAS,EGAS,NGAS,E/PGAS,IVMETH) 63 - ENDIF 64 - ENDIF 65 - END 534 GARFIELD ================================================== P=GAS D=GASVT1 1 ============================ 0 + +DECK,GASVT1. 1 - REAL FUNCTION GASVT1(EX,EY,EZ,BX,BY,BZ) 2 - *----------------------------------------------------------------------- 3 - * GASVT1 - Function calculating the drift speed along Btrans. 4 - * VARIABLES : SPEED : The actual speed (=GASVT1) 5 - * (Last changed on 18/ 2/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,GASDATA. 10.- +SEQ,BFIELD. 11 - REAL EX,EY,EZ,E,BX,BY,BZ,B,EBANG,DIVDIF,SPEED 12 - INTEGER IFAIL 13 - EXTERNAL DIVDIF 14 - *** Obtain the magnitude of the electric field. 15 - E=SQRT(EX**2+EY**2+EZ**2) 16 - IF(E.LE.0.0)THEN 17 - GASVT1=0.0 18 - RETURN 19 - ENDIF 1 534 P=GAS D=GASVT1 2 PAGE 817 20 - *** Treat the case that the table is 2-dimensional. 21 - IF(TAB2D)THEN 22 - * B field magnitude. 23 - B=SQRT(BX**2+BY**2+BZ**2) 24 - * Obtain the angle between B field and E field. 25 - IF(E*B.EQ.0)THEN 26 - EBANG=BANG(1) 27 - ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN 28 - EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ 29 - - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) 30 - ELSE 31 - EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) 32 - ENDIF 33 - * Interpolate. 34 - CALL BOXIN3(XGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, 35 - - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,SPEED,IXMETH,IFAIL) 36 - GASVT1=SPEED 37 - * Verify error. 38 - IF(IFAIL.NE.0)GASVT1=0 39 - *** Treat the case that the table is 1-dimensional. 40 - ELSE 41 - * Extrapolation towards small E/p. 42 - IF(E/PGAS.LT.EGAS(1))THEN 43 - GASVT1=XGAS(1) 44 - IF(JXEXTR.EQ.1)GASVT1=XEXTR3+XEXTR4*E/PGAS 45 - IF(JXEXTR.EQ.2)GASVT1=EXP(MIN(50.0, 46 - - XEXTR3+XEXTR4*E/PGAS)) 47 - * Extrapolation towards large E/p. 48 - ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN 49 - GASVT1=XGAS(NGAS) 50 - IF(IXEXTR.EQ.1)GASVT1=XEXTR1+XEXTR2*E/PGAS 51 - IF(IXEXTR.EQ.2)GASVT1=EXP(MIN(50.0, 52 - - XEXTR1+XEXTR2*E/PGAS)) 53 - * Only one point. 54 - ELSEIF(NGAS.LE.1)THEN 55 - GASVT1=XGAS(1) 56 - * Intermediate points, spline interpolation. 57 - ELSEIF(IXMETH.EQ.0)THEN 58 - CALL INTERP(EGAS,XGAS,CXGAS,NGAS,E/PGAS,SPEED,IFAIL) 59 - GASVT1=SPEED 60 - * Intermediate points, Newton interpolation. 61 - ELSE 62 - GASVT1=DIVDIF(XGAS,EGAS,NGAS,E/PGAS,IXMETH) 63 - ENDIF 64 - ENDIF 65 - *** Get the sign right. 66 - IF(EX*BX+EY*BY+EZ*BZ.GT.0)THEN 67 - GASVT1=ABS(GASVT1) 68 - ELSE 69 - GASVT1=-ABS(GASVT1) 70 - ENDIF 71 - END 535 GARFIELD ================================================== P=GAS D=GASVT2 1 ============================ 0 + +DECK,GASVT2. 1 - REAL FUNCTION GASVT2(EX,EY,EZ,BX,BY,BZ) 2 - *----------------------------------------------------------------------- 3 - * GASVT2 - Function calculating the drift speed along ExB. 4 - * VARIABLES : SPEED : The actual speed (=GASVT2) 5 - * (Last changed on 13/ 2/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,GASDATA. 10.- +SEQ,BFIELD. 11 - REAL EX,EY,EZ,E,BX,BY,BZ,B,EBANG,DIVDIF,SPEED 12 - INTEGER IFAIL 13 - EXTERNAL DIVDIF 14 - *** Obtain the magnitude of the electric field. 15 - E=SQRT(EX**2+EY**2+EZ**2) 16 - IF(E.LE.0.0)THEN 17 - GASVT2=0.0 18 - RETURN 19 - ENDIF 20 - *** Treat the case that the table is 2-dimensional. 21 - IF(TAB2D)THEN 22 - * B field magnitude. 23 - B=SQRT(BX**2+BY**2+BZ**2) 24 - * Obtain the angle between B field and E field. 25 - IF(E*B.EQ.0)THEN 26 - EBANG=BANG(1) 27 - ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN 28 - EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ 29 - - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) 30 - ELSE 31 - EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) 32 - ENDIF 33 - * Interpolate. 34 - CALL BOXIN3(YGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, 35 - - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,SPEED,IYMETH,IFAIL) 36 - GASVT2=SPEED 37 - * Verify error. 38 - IF(IFAIL.NE.0)GASVT2=0 39 - *** Treat the case that the table is 1-dimensional. 40 - ELSE 41 - * Extrapolation towards small E/p. 42 - IF(E/PGAS.LT.EGAS(1))THEN 43 - GASVT2=YGAS(1) 44 - IF(JYEXTR.EQ.1)GASVT2=YEXTR3+YEXTR4*E/PGAS 45 - IF(JYEXTR.EQ.2)GASVT2=EXP(MIN(50.0, 46 - - YEXTR3+YEXTR4*E/PGAS)) 47 - * Extrapolation towards large E/p. 48 - ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN 49 - GASVT2=YGAS(NGAS) 50 - IF(IYEXTR.EQ.1)GASVT2=YEXTR1+YEXTR2*E/PGAS 1 535 P=GAS D=GASVT2 2 PAGE 818 51 - IF(IYEXTR.EQ.2)GASVT2=EXP(MIN(50.0, 52 - - YEXTR1+YEXTR2*E/PGAS)) 53 - * Only one point. 54 - ELSEIF(NGAS.LE.1)THEN 55 - GASVT2=YGAS(1) 56 - * Intermediate points, spline interpolation. 57 - ELSEIF(IYMETH.EQ.0)THEN 58 - CALL INTERP(EGAS,YGAS,CYGAS,NGAS,E/PGAS,SPEED,IFAIL) 59 - GASVT2=SPEED 60 - * Intermediate points, Newton interpolation. 61 - ELSE 62 - GASVT2=DIVDIF(YGAS,EGAS,NGAS,E/PGAS,IYMETH) 63 - ENDIF 64 - ENDIF 65 - END 536 GARFIELD ================================================== P=GAS D=GASLOR 1 ============================ 0 + +DECK,GASLOR. 1 - REAL FUNCTION GASLOR(EX,EY,EZ,BX,BY,BZ) 2 - *----------------------------------------------------------------------- 3 - * GASLOR - Function calculating the Lorentz angle in a gas. 4 - * (Last changed on 13/ 2/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GASDATA. 9.- +SEQ,BFIELD. 10 - REAL EX,EY,EZ,BX,BY,BZ,B,E,EBANG,DIVDIF,AUXLOR 11 - INTEGER IFAIL 12 - EXTERNAL DIVDIF 13 - *** Obtain the magnitude of the electric field. 14 - E=SQRT(EX**2+EY**2+EZ**2) 15 - IF(E.LE.0.0)THEN 16 - GASLOR=0.0 17 - RETURN 18 - ENDIF 19 - *** Treat the case that the table is 2-dimensional. 20 - IF(TAB2D)THEN 21 - * B field magnitude. 22 - B=SQRT(BX**2+BY**2+BZ**2) 23 - * Obtain the angle between B field and E field. 24 - IF(E*B.EQ.0)THEN 25 - EBANG=BANG(1) 26 - ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN 27 - EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ 28 - - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) 29 - ELSE 30 - EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) 31 - ENDIF 32 - * Interpolate. 33 - CALL BOXIN3(WGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, 34 - - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,AUXLOR,IWMETH,IFAIL) 35 - GASLOR=AUXLOR 36 - * Verify error. 37 - IF(IFAIL.NE.0)GASLOR=0 38 - *** Treat the case that the table is 1-dimensional. 39 - ELSE 40 - * Extrapolation towards small E/p. 41 - IF(E/PGAS.LT.EGAS(1))THEN 42 - GASLOR=WGAS(1) 43 - IF(JWEXTR.EQ.1)GASLOR=WEXTR3+WEXTR4*E/PGAS 44 - IF(JWEXTR.EQ.2)GASLOR=EXP(MIN(50.0, 45 - - WEXTR3+WEXTR4*E/PGAS)) 46 - * Extrapolation towards large E/p. 47 - ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN 48 - GASLOR=WGAS(NGAS) 49 - IF(IWEXTR.EQ.1)GASLOR=WEXTR1+WEXTR2*E/PGAS 50 - IF(IWEXTR.EQ.2)GASLOR=EXP(MIN(50.0, 51 - - WEXTR1+WEXTR2*E/PGAS)) 52 - * Only one point. 53 - ELSEIF(NGAS.LE.1)THEN 54 - GASLOR=WGAS(1) 55 - * Intermediate points, spline interpolation. 56 - ELSEIF(IWMETH.EQ.0)THEN 57 - CALL INTERP(EGAS,WGAS,CWGAS,NGAS,E/PGAS,AUXLOR,IFAIL) 58 - GASLOR=AUXLOR 59 - * Intermediate points, Newton interpolation. 60 - ELSE 61 - GASLOR=DIVDIF(WGAS,EGAS,NGAS,E/PGAS,IWMETH) 62 - ENDIF 63 - ENDIF 64 - END 537 GARFIELD ================================================== P=GAS D=GASMOB 1 ============================ 0 + +DECK,GASMOB. 1 - REAL FUNCTION GASMOB(EX,EY,EZ,BX,BY,BZ) 2 - *----------------------------------------------------------------------- 3 - * GASMOB - Function calculating the ion mobility in a gas. 4 - * (Last changed on 13/ 2/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GASDATA. 9.- +SEQ,BFIELD. 10 - REAL EX,EY,EZ,BX,BY,BZ,B,E,DIVDIF,EBANG,AUXMOB 11 - INTEGER IFAIL 12 - EXTERNAL DIVDIF 13 - *** Obtain the magnitude of the electric field. 14 - E=SQRT(EX**2+EY**2+EZ**2) 15 - IF(E.LE.0.0)THEN 16 - GASMOB=0.0 17 - RETURN 18 - ENDIF 19 - *** Treat the case that the table is 2-dimensional. 1 537 P=GAS D=GASMOB 2 PAGE 819 20 - IF(TAB2D)THEN 21 - * B field magnitude. 22 - B=SQRT(BX**2+BY**2+BZ**2) 23 - * Obtain the angle between B field and E field. 24 - IF(E*B.EQ.0)THEN 25 - EBANG=BANG(1) 26 - ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN 27 - EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ 28 - - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) 29 - ELSE 30 - EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) 31 - ENDIF 32 - * Interpolate. 33 - CALL BOXIN3(MGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, 34 - - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,AUXMOB,IMMETH,IFAIL) 35 - GASMOB=AUXMOB 36 - * Verify error. 37 - IF(IFAIL.NE.0)GASMOB=0 38 - *** Treat the case that the table is 1-dimensional. 39 - ELSE 40 - * Extrapolation towards small E/p. 41 - IF(E/PGAS.LT.EGAS(1))THEN 42 - GASMOB=MGAS(1) 43 - IF(JMEXTR.EQ.1)GASMOB=MEXTR3+MEXTR4*E/PGAS 44 - IF(JMEXTR.EQ.2)GASMOB=EXP(MIN(50.0, 45 - - MEXTR3+MEXTR4*E/PGAS)) 46 - * Extrapolation towards large E/p. 47 - ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN 48 - GASMOB=MGAS(NGAS) 49 - IF(IMEXTR.EQ.1)GASMOB=MEXTR1+MEXTR2*E/PGAS 50 - IF(IMEXTR.EQ.2)GASMOB=EXP(MIN(50.0, 51 - - MEXTR1+MEXTR2*E/PGAS)) 52 - * Only one point. 53 - ELSEIF(NGAS.LE.1)THEN 54 - GASMOB=MGAS(1) 55 - * Intermediate points, spline interpolation. 56 - ELSEIF(IMMETH.EQ.0)THEN 57 - CALL INTERP(EGAS,MGAS,CMGAS,NGAS,E/PGAS,AUXMOB,IFAIL) 58 - GASMOB=AUXMOB 59 - * Intermediate points, Newton interpolation. 60 - ELSE 61 - GASMOB=DIVDIF(MGAS,EGAS,NGAS,E/PGAS,IMMETH) 62 - ENDIF 63 - ENDIF 64 - END 538 GARFIELD ================================================== P=GAS D=GASDFT 1 ============================ 0 + +DECK,GASDFT. 1 - REAL FUNCTION GASDFT(EX,EY,EZ,BX,BY,BZ) 2 - *----------------------------------------------------------------------- 3 - * GASDFT - Function calculating the transverse diffusion. 4 - * VARIABLES : none 5 - * (Last changed on 13/ 2/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,GASDATA. 10.- +SEQ,BFIELD. 11 - REAL EX,EY,EZ,BX,BY,BZ,B,E,EBANG,DIVDIF,DIFF 12 - INTEGER IFAIL 13 - EXTERNAL DIVDIF 14 - *** Obtain the magnitude of the electric field. 15 - E=SQRT(EX**2+EY**2+EZ**2) 16 - IF(E.LE.0.0)THEN 17 - GASDFT=0.0 18 - RETURN 19 - ENDIF 20 - *** Treat the case that the table is 2-dimensional. 21 - IF(TAB2D)THEN 22 - * B field magnitude. 23 - B=SQRT(BX**2+BY**2+BZ**2) 24 - * Obtain the angle between B field and E field. 25 - IF(E*B.EQ.0)THEN 26 - EBANG=BANG(1) 27 - ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN 28 - EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ 29 - - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) 30 - ELSE 31 - EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) 32 - ENDIF 33 - * Interpolate. 34 - CALL BOXIN3(OGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, 35 - - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,DIFF,IOMETH,IFAIL) 36 - GASDFT=DIFF 37 - * Verify error. 38 - IF(IFAIL.NE.0)GASDFT=0 39 - *** Treat the case that the table is 1-dimensional. 40 - ELSE 41 - * Extrapolation towards small E/p. 42 - IF(E/PGAS.LT.EGAS(1))THEN 43 - GASDFT=OGAS(1) 44 - IF(JOEXTR.EQ.1)GASDFT=OEXTR3+OEXTR4*E/PGAS 45 - IF(JOEXTR.EQ.2)GASDFT=EXP(MIN(50.0, 46 - - OEXTR3+OEXTR4*E/PGAS)) 47 - * Extrapolation towards large E/p. 48 - ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN 49 - GASDFT=OGAS(NGAS) 50 - IF(IOEXTR.EQ.1)GASDFT=OEXTR1+OEXTR2*E/PGAS 51 - IF(IOEXTR.EQ.2)GASDFT=EXP(MIN(50.0, 52 - - OEXTR1+OEXTR2*E/PGAS)) 53 - * Only one point. 54 - ELSEIF(NGAS.LE.1)THEN 55 - GASDFT=OGAS(1) 56 - * Intermediate points, spline interpolation. 57 - ELSEIF(IOMETH.EQ.0)THEN 1 538 P=GAS D=GASDFT 2 PAGE 820 58 - CALL INTERP(EGAS,OGAS,COGAS,NGAS,E/PGAS,DIFF,IFAIL) 59 - GASDFT=DIFF 60 - * Intermediate points, Newton interpolation. 61 - ELSE 62 - GASDFT=DIVDIF(OGAS,EGAS,NGAS,E/PGAS,IOMETH) 63 - ENDIF 64 - ENDIF 65 - *** Verify value and scale by pressure. 66 - IF(GASDFT.LT.0.0)GASDFT=0.0 67 - GASDFT=GASDFT/SQRT(PGAS) 68 - END 539 GARFIELD ================================================== P=GAS D=GASDFL 1 ============================ 0 + +DECK,GASDFL. 1 - REAL FUNCTION GASDFL(EX,EY,EZ,BX,BY,BZ) 2 - *----------------------------------------------------------------------- 3 - * GASDFL - Function calculating the longitudinal diffusion. 4 - * VARIABLES : none 5 - * (Last changed on 13/ 2/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,GASDATA. 10.- +SEQ,BFIELD. 11 - REAL EX,EY,EZ,BX,BY,BZ,B,E,EBANG,DIVDIF,DIFF 12 - INTEGER IFAIL 13 - EXTERNAL DIVDIF 14 - *** Obtain the magnitude of the electric field. 15 - E=SQRT(EX**2+EY**2+EZ**2) 16 - IF(E.LE.0.0)THEN 17 - GASDFL=0.0 18 - RETURN 19 - ENDIF 20 - *** Treat the case that the table is 2-dimensional. 21 - IF(TAB2D)THEN 22 - * B field magnitude. 23 - B=SQRT(BX**2+BY**2+BZ**2) 24 - * Obtain the angle between B field and E field. 25 - IF(E*B.EQ.0)THEN 26 - EBANG=BANG(1) 27 - ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN 28 - EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ 29 - - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) 30 - ELSE 31 - EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) 32 - ENDIF 33 - * Interpolate. 34 - CALL BOXIN3(DGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, 35 - - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,DIFF,IDMETH,IFAIL) 36 - GASDFL=DIFF 37 - * Verify error. 38 - IF(IFAIL.NE.0)GASDFL=0 39 - *** Treat the case that the table is 1-dimensional. 40 - ELSE 41 - * Extrapolation towards small E/p. 42 - IF(E/PGAS.LT.EGAS(1))THEN 43 - GASDFL=DGAS(1) 44 - IF(JDEXTR.EQ.1)GASDFL=DEXTR3+DEXTR4*E/PGAS 45 - IF(JDEXTR.EQ.2)GASDFL=EXP(MIN(50.0, 46 - - DEXTR3+DEXTR4*E/PGAS)) 47 - * Extrapolation towards large E/p. 48 - ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN 49 - GASDFL=DGAS(NGAS) 50 - IF(IDEXTR.EQ.1)GASDFL=DEXTR1+DEXTR2*E/PGAS 51 - IF(IDEXTR.EQ.2)GASDFL=EXP(MIN(50.0, 52 - - DEXTR1+DEXTR2*E/PGAS)) 53 - * Only one point. 54 - ELSEIF(NGAS.LE.1)THEN 55 - GASDFL=DGAS(1) 56 - * Intermediate points, spline interpolation. 57 - ELSEIF(IDMETH.EQ.0)THEN 58 - CALL INTERP(EGAS,DGAS,CDGAS,NGAS,E/PGAS,DIFF,IFAIL) 59 - GASDFL=DIFF 60 - * Intermediate points, Newton interpolation. 61 - ELSE 62 - GASDFL=DIVDIF(DGAS,EGAS,NGAS,E/PGAS,IDMETH) 63 - ENDIF 64 - ENDIF 65 - *** Verify value and scale by pressure. 66 - IF(GASDFL.LT.0.0)GASDFL=0.0 67 - GASDFL=GASDFL/SQRT(PGAS) 68 - END 540 GARFIELD ================================================== P=GAS D=GASTWN 1 ============================ 0 + +DECK,GASTWN. 1 - REAL FUNCTION GASTWN(EX,EY,EZ,BX,BY,BZ) 2 - *----------------------------------------------------------------------- 3 - * GASTWN - Function calculating the Townsend coefficient for a field E 4 - * using a spline interpolation. 5 - * VARIABLES : AUX : The Townsend constant (=GASTWN). 6 - * (Last changed on 13/ 2/00.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,GASDATA. 11.- +SEQ,BFIELD. 12 - REAL EX,EY,EZ,BX,BY,BZ,B,E,EBANG,DIVDIF,AUXTWN 13 - INTEGER IFAIL 14 - EXTERNAL DIVDIF 15 - *** Obtain the magnitude of the electric field. 16 - E=SQRT(EX**2+EY**2+EZ**2) 17 - IF(E.LE.0.0)THEN 18 - GASTWN=0.0 19 - RETURN 1 540 P=GAS D=GASTWN 2 PAGE 821 20 - ENDIF 21 - *** Treat the case that the table is 2-dimensional. 22 - IF(TAB2D)THEN 23 - * B field magnitude. 24 - B=SQRT(BX**2+BY**2+BZ**2) 25 - * Obtain the angle between B field and E field. 26 - IF(E*B.EQ.0)THEN 27 - EBANG=BANG(1) 28 - ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN 29 - EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ 30 - - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) 31 - ELSE 32 - EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) 33 - ENDIF 34 - * Interpolate. 35 - IF(E/PGAS.LE.EGAS(IATHR))THEN 36 - CALL BOXIN3(AGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, 37 - - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,AUXTWN,1,IFAIL) 38 - ELSE 39 - CALL BOXIN3(AGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, 40 - - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,AUXTWN,IAMETH, 41 - - IFAIL) 42 - ENDIF 43 - GASTWN=AUXTWN 44 - * Verify error. 45 - IF(IFAIL.NE.0)GASTWN=0 46 - *** Treat the case that the table is 1-dimensional. 47 - ELSE 48 - * Extrapolation towards small E/p. 49 - IF(E/PGAS.LT.EGAS(1))THEN 50 - GASTWN=AGAS(1) 51 - IF(JAEXTR.EQ.1)GASTWN=AEXTR3+AEXTR4*E/PGAS 52 - IF(JAEXTR.EQ.2)GASTWN=EXP(MIN(50.0, 53 - - AEXTR3+AEXTR4*E/PGAS)) 54 - * Extrapolation towards large E/p. 55 - ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN 56 - GASTWN=AGAS(NGAS) 57 - IF(IAEXTR.EQ.1)GASTWN=AEXTR1+AEXTR2*E/PGAS 58 - IF(IAEXTR.EQ.2)GASTWN=EXP(MIN(50.0, 59 - - AEXTR1+AEXTR2*E/PGAS)) 60 - * Interpolation below threshold. 61 - ELSEIF(E/PGAS.LE.EGAS(IATHR))THEN 62 - GASTWN=DIVDIF(AGAS,EGAS,NGAS,E/PGAS,1) 63 - * Only one point. 64 - ELSEIF(NGAS.LE.1)THEN 65 - GASTWN=AGAS(1) 66 - * Intermediate points, spline interpolation. 67 - ELSEIF(IAMETH.EQ.0)THEN 68 - CALL INTERP(EGAS,AGAS,CAGAS,NGAS,E/PGAS,AUXTWN,IFAIL) 69 - GASTWN=AUXTWN 70 - * Intermediate points, Newton interpolation. 71 - ELSE 72 - GASTWN=DIVDIF(AGAS,EGAS,NGAS,E/PGAS,IAMETH) 73 - ENDIF 74 - ENDIF 75 - *** Verify value and scale by pressure. 76 - IF(GASTWN.LT.-20)THEN 77 - GASTWN=0 78 - ELSE 79 - GASTWN=EXP(GASTWN) 80 - ENDIF 81 - GASTWN=PGAS*GASTWN 82 - END 541 GARFIELD ================================================== P=GAS D=GASATT 1 ============================ 0 + +DECK,GASATT. 1 - REAL FUNCTION GASATT(EX,EY,EZ,BX,BY,BZ) 2 - *----------------------------------------------------------------------- 3 - * GASATT - Function calculating the attachment coefficient for a field 4 - * E using a Newton or spline interpolation. 5 - * VARIABLES : AUX : The attachment coefficient 6 - * (Last changed on 13/ 2/00.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,GASDATA. 11.- +SEQ,BFIELD. 12 - REAL EX,EY,EZ,BX,BY,BZ,B,E,EBANG,DIVDIF,AUXATT 13 - INTEGER IFAIL 14 - EXTERNAL DIVDIF 15 - *** Obtain the magnitude of the electric field. 16 - E=SQRT(EX**2+EY**2+EZ**2) 17 - IF(E.LE.0.0)THEN 18 - GASATT=0.0 19 - RETURN 20 - ENDIF 21 - *** Treat the case that the table is 2-dimensional. 22 - IF(TAB2D)THEN 23 - * B field magnitude. 24 - B=SQRT(BX**2+BY**2+BZ**2) 25 - * Obtain the angle between B field and E field. 26 - IF(E*B.EQ.0)THEN 27 - EBANG=BANG(1) 28 - ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN 29 - EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ 30 - - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) 31 - ELSE 32 - EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) 33 - ENDIF 34 - * Interpolate. 35 - IF(E/PGAS.LE.EGAS(IBTHR))THEN 36 - CALL BOXIN3(BGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, 37 - - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,AUXATT,1,IFAIL) 38 - ELSE 39 - CALL BOXIN3(BGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, 1 541 P=GAS D=GASATT 2 PAGE 822 40 - - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,AUXATT,IBMETH, 41 - - IFAIL) 42 - ENDIF 43 - GASATT=AUXATT 44 - * Verify error. 45 - IF(IFAIL.NE.0)GASATT=0 46 - *** Treat the case that the table is 1-dimensional. 47 - ELSE 48 - * Below the first table point. 49 - IF(E/PGAS.LT.EGAS(1))THEN 50 - GASATT=BGAS(1) 51 - IF(JBEXTR.EQ.1)GASATT=BEXTR3+BEXTR4*E/PGAS 52 - IF(JBEXTR.EQ.2)GASATT=EXP(MIN(50.0, 53 - - BEXTR3+BEXTR4*E/PGAS)) 54 - * Above the highest table point. 55 - ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN 56 - GASATT=BGAS(NGAS) 57 - IF(IBEXTR.EQ.1)GASATT=BEXTR1+BEXTR2*E/PGAS 58 - IF(IBEXTR.EQ.2)GASATT=EXP(MIN(50.0, 59 - - BEXTR1+BEXTR2*E/PGAS)) 60 - * Interpolation below threshold. 61 - ELSEIF(E/PGAS.LE.EGAS(IBTHR))THEN 62 - GASATT=DIVDIF(BGAS,EGAS,NGAS,E/PGAS,1) 63 - * Only one point. 64 - ELSEIF(NGAS.LE.1)THEN 65 - GASATT=BGAS(1) 66 - * Intermediate points, spline interpolation. 67 - ELSEIF(IBMETH.EQ.0)THEN 68 - CALL INTERP(EGAS,BGAS,CBGAS,NGAS,E/PGAS,AUXATT,IFAIL) 69 - GASATT=AUXATT 70 - * Intermediate points, Newton interpolation. 71 - ELSE 72 - GASATT=DIVDIF(BGAS,EGAS,NGAS,E/PGAS,IBMETH) 73 - ENDIF 74 - ENDIF 75 - *** Verify value and apply pressure scaling. 76 - IF(GASATT.LT.-20)THEN 77 - GASATT=0.0 78 - ELSE 79 - GASATT=EXP(GASATT) 80 - ENDIF 81 - GASATT=PGAS*GASATT 82 - END 542 GARFIELD ================================================== P=GAS D=A20E80 1 ============================ 0 + +DECK,A20E80. 1 - SUBROUTINE A20E80 2 - *----------------------------------------------------------------------- 3 - * A20E80 - Loads data for the gas mixture 20% Argon 80% Ethane. 4 - * Drift velocities taken from Jean-Marie et. al. (1979), 5 - * diffusion from Ramanantsizehena (1979). 6 - * Mobilitiy and most probable energy loss are questionable. 7 - * 8 - * AUTHOR: Matthias Grosse Perdekamp (Freiburg, Germany) 9 - * (Last changed on 17/ 5/94.) 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,GASDATA. 13.- +SEQ,PRINTPLOT. 14 - REAL EDAT(14),VDAT(14),DDAT(14),ADAT(14) 0 15-+ +SELF,IF=SAVE. 16 - SAVE EDAT,VDAT,DDAT,ADAT 0 17-+ +SELF. 18 - *** Tables. 19 - DATA EDAT/0.190 ,0.312 ,0.512 ,0.794 ,1.160 ,1.603 , 20 - - 1.979 ,2.417 ,2.826 ,3.285 ,3.699 ,4.176 , 21 - - 4.737 ,5.312 / 22 - DATA VDAT/2.559 ,3.630 ,4.523 ,4.988 ,5.268 ,5.392 , 23 - - 5.408 ,5.408 ,5.392 ,5.338 ,5.283 ,5.229 , 24 - - 5.136 ,5.066 / 25 - DATA DDAT/0.0224,0.0215,0.0209,0.0206,0.0199,0.0192, 26 - - 0.0188,0.0185,0.0184,0.0183,0.0182,0.0181, 27 - - 0.0179,0.0177/ 28 - DATA ADAT/0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 , 29 - - 0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 , 30 - - 0.0 ,0.0 / 31 - *** Identify the routine if requested. 32 - IF(LIDENT)PRINT *,' /// ROUTINE A20E80 ///' 33 - *** Copy them to the common block. 34 - NGAS=14 35 - DO 10 I=1,NGAS 36 - EGAS(I)=EDAT(I) 37 - VGAS(I)=VDAT(I) 38 - DGAS(I)=DDAT(I)*SQRT(760.0) 39 - AGAS(I)=ADAT(I) 40 - MGAS(I)=0.21E-05 41 - WGAS(I)=0.0 42 - 10 CONTINUE 43 - *** Next set the other gas data. 44 - A =32.05 45 - Z =18.0 46 - RHO =0.0014 47 - CMEAN =23.6 48 - EMPROB=1741 49 - EPAIR =25.2 50 - GASID='Argon 20% Ethane 80%' 51 - *** Set the GASOK bits. 52 - GASOK(1)=.TRUE. 53 - GASOK(2)=.TRUE. 54 - GASOK(3)=.TRUE. 55 - GASOK(4)=.FALSE. 56 - GASOK(5)=.TRUE. 57 - GASOK(6)=.FALSE. 1 542 P=GAS D=A20E80 2 PAGE 823 58 - GASOK(7)=.FALSE. 59 - GASOK(8)=.FALSE. 60 - CLSTYP='LANDAU' 61 - *** Set the extrapolation method. 62 - IVEXTR=0 63 - IDEXTR=0 64 - IOEXTR=0 65 - IAEXTR=0 66 - JVEXTR=0 67 - JDEXTR=0 68 - JOEXTR=0 69 - JAEXTR=0 70 - *** Call the timing routine TIMLOG to register the amount of CPU time. 71 - CALL TIMLOG('Loading argon 20% ethane 80%: ') 72 - END 543 GARFIELD ================================================== P=GAS D=A50E50 1 ============================ 0 + +DECK,A50E50. 1 - SUBROUTINE A50E50 2 - *----------------------------------------------------------------------- 3 - * A50E50 - Stores the gas data for the mixture argon 50% ethane 50% 4 - * in the common /GASDAT/. The data were stolen from Manfred 5 - * Guckes (table part) and provided by Giorgio Sartori and 6 - * Michela Giavedoni (parameters part). 7 - * (Last changed on 17/ 5/94.) 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,GASDATA. 11.- +SEQ,PRINTPLOT. 12 - REAL EDAT(16),VDAT(16),DDAT(16) 0 13-+ +SELF,IF=SAVE. 14 - SAVE EDAT,VDAT,DDAT 0 15-+ +SELF. 16 - *** Store the drift velocity and diffusion in temporary storage arrays. 17 - DATA EDAT/0.039 ,0.066 ,0.132 ,0.197 ,0.263 ,0.395 ,0.526 , 18 - - 0.829 ,1.07 ,1.32 ,1.83 ,2.58 ,3.32 ,4.13 , 19 - - 4.83 ,5.47 / 20 - DATA VDAT/0.61 ,1.08 ,2.25 ,3.14 ,3.75 ,4.39 ,4.75 , 21 - - 5.17 ,5.30 ,5.30 ,5.26 ,5.06 ,4.90 ,4.77 , 22 - - 4.69 ,4.63 / 23 - DATA DDAT/0.050 ,0.040 ,0.030 ,0.026 ,0.024 ,0.021 ,0.019 , 24 - - 0.017 ,0.0155,0.0152,0.0140,0.0131,0.0127,0.0122, 25 - - 0.0120,0.0120/ 26 - *** Identify the routine if requested. 27 - IF(LIDENT)PRINT *,' /// ROUTINE A50E50 ///' 28 - *** Copy them to the common block. 29 - NGAS=16 30 - DO 10 I=1,NGAS 31 - EGAS(I)=EDAT(I) 32 - VGAS(I)=VDAT(I) 33 - DGAS(I)=DDAT(I)*SQRT(760.0) 34 - MGAS(I)=0.18E-5 35 - WGAS(I)=0.0 36 - 10 CONTINUE 37 - *** Next set the other gas data. 38 - A =34.9 39 - Z =18.0 40 - RHO =0.00131 41 - CMEAN =31.0 42 - EMPROB=2175.0 43 - EPAIR =27.5 44 - GASID='Argon 50% Ethane 50%' 45 - *** Set the GASOK bits. 46 - GASOK(1)=.TRUE. 47 - GASOK(2)=.TRUE. 48 - GASOK(3)=.TRUE. 49 - GASOK(4)=.FALSE. 50 - GASOK(5)=.TRUE. 51 - GASOK(6)=.FALSE. 52 - GASOK(7)=.FALSE. 53 - GASOK(8)=.FALSE. 54 - CLSTYP='LANDAU' 55 - *** Set the extrapolation method. 56 - IVEXTR=0 57 - IDEXTR=0 58 - IOEXTR=0 59 - IAEXTR=0 60 - IBEXTR=0 61 - IWEXTR=0 62 - JVEXTR=0 63 - JDEXTR=0 64 - J0EXTR=0 65 - JAEXTR=0 66 - JBEXTR=0 67 - JWEXTR=0 68 - IVMETH=0 69 - IDMETH=0 70 - IOMETH=0 71 - IBMETH=0 72 - IWMETH=0 73 - *** Call the timing routine TIMLOG to register the amount of CPU time. 74 - CALL TIMLOG('Loading argon 50% ethane 50%: ') 75 - END 544 GARFIELD ================================================== P=GAS D=A80E20 1 ============================ 0 + +DECK,A80E20. 1 - SUBROUTINE A80E20 2 - *----------------------------------------------------------------------- 3 - * A80E20 - Loads data for the gas mixture 80% Argon 20% Ethane. 4 - * Drift velocities taken from Jean-Marie et.al. (1979), 5 - * diffusion from Ramanantsizehena (1979). 6 - * Mobility and most probable energy loss are questionable. 1 544 P=GAS D=A80E20 2 PAGE 824 7 - * 8 - * AUTHOR: Matthias Grosse Perdekamp (Freiburg, Germany) 9 - * (Last changed on 17/ 5/94.) 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,GASDATA. 13.- +SEQ,PRINTPLOT. 14 - REAL EDAT(14),VDAT(14),DDAT(14),ADAT(14) 0 15-+ +SELF,IF=SAVE. 16 - SAVE EDAT,VDAT,DDAT,ADAT 0 17-+ +SELF. 18 - *** Tables. 19 - DATA EDAT/0.195 ,0.336 ,0.502 ,0.658 ,0.941 ,1.316 , 20 - - 1.574 ,1.974 ,2.300 ,2.632 ,3.289 ,3.947 , 21 - - 4.605 ,5.263 / 22 - DATA VDAT/3.925 ,4.624 ,4.895 ,4.895 ,4.647 ,4.414 , 23 - - 4.290 ,4.127 ,4.018 ,3.894 ,3.793 ,3.746 , 24 - - 3.692 ,3.684 / 25 - DATA DDAT/0.0336,0.0335,0.0335,0.0335,0.0337,0.0345, 26 - - 0.0348,0.0351,0.0354,0.0359,0.0365,0.0369, 27 - - 0.0372,0.0377/ 28 - DATA ADAT/0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 , 29 - - 0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 , 30 - - 0.0 ,0.0 / 31 - *** Identify the routine if requested. 32 - IF(LIDENT)PRINT *,' /// ROUTINE A80E20 ///' 33 - *** Copy them to the common block. 34 - NGAS=14 35 - DO 10 I=1,NGAS 36 - EGAS(I)=EDAT(I) 37 - VGAS(I)=VDAT(I) 38 - DGAS(I)=DDAT(I)*SQRT(760.0) 39 - MGAS(I)=0.19E-05 40 - WGAS(I)=0.0 41 - AGAS(I)=ADAT(I) 42 - 10 CONTINUE 43 - *** Next set the other gas data. 44 - A =37.97 45 - Z =18.0 46 - RHO =0.0016 47 - CMEAN =28 48 - EMPROB=2268 49 - EPAIR =25.8 50 - GASID='Argon 80% Ethane 20%' 51 - *** Set the GASOK bits. 52 - GASOK(1)=.TRUE. 53 - GASOK(2)=.TRUE. 54 - GASOK(3)=.TRUE. 55 - GASOK(4)=.FALSE. 56 - GASOK(5)=.TRUE. 57 - GASOK(6)=.FALSE. 58 - GASOK(7)=.FALSE. 59 - GASOK(8)=.FALSE. 60 - CLSTYP='LANDAU' 61 - *** Set the extrapolation method. 62 - IVEXTR=0 63 - IDEXTR=0 64 - IAEXTR=0 65 - JVEXTR=0 66 - JDEXTR=0 67 - JAEXTR=0 68 - *** Call the timing routine TIMLOG to register the amount of CPU time. 69 - CALL TIMLOG('Loading argon 80% ethane 20%: ') 70 - END 545 GARFIELD ================================================== P=GAS D=A73M20 1 ============================ 0 + +DECK,A73M20. 1 - SUBROUTINE A73M20 2 - *----------------------------------------------------------------------- 3 - * A73M20P7 - Loads data for the gas mixture 73% Argon 20% Methane 4 - * 7% (CH3O)2CH2 (propanol). 5 - * Drift velocities and diffusion from F. Piuz Cern-EF 82-11 6 - * and Fehlmann et. al. (1983) 7 - * emprob, epair, cmean with big (unkown) errors. 8 - * AUTHOR: Matthias Grosse Perdekamp (Freiburg). 9 - * (Last changed on 17/ 5/94.) 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,GASDATA. 13.- +SEQ,PRINTPLOT. 14 - REAL EDAT(8),VDAT(8),DDAT(8),ADAT(8) 0 15-+ +SELF,IF=SAVE. 16 - SAVE EDAT,VDAT,DDAT,ADAT 0 17-+ +SELF. 18 - *** Tables. 19 - DATA EDAT/0.047,0.066,0.105,0.132, 20 - - 0.158,0.211,0.263,0.329/ 21 - DATA VDAT/0.295,0.469,0.797,1.031, 22 - - 1.266,1.852,2.367,3.070/ 23 - DATA DDAT/0.042,0.032,0.025,0.026, 24 - - 0.027,0.026,0.027,0.027/ 25 - DATA ADAT/0.0 ,0.0 ,0.0 ,0.0 , 26 - - 0.0 ,0.0 ,0.0 ,0.0 / 27 - *** Identify the routine if requested. 28 - IF(LIDENT)PRINT *,' /// ROUTINE A73M20 ///' 29 - *** Copy them to the common block. 30 - NGAS=8 31 - DO 10 I=1,NGAS 32 - EGAS(I)=EDAT(I) 33 - VGAS(I)=VDAT(I) 34 - DGAS(I)=DDAT(I)*SQRT(760.0) 1 545 P=GAS D=A73M20 2 PAGE 825 35 - MGAS(I)=0.183E-05 36 - WGAS(I)=0.0 37 - AGAS(I)=ADAT(I) 38 - 10 CONTINUE 39 - *** Next set the other gas data. 40 - A =40.5 41 - Z =20.8 42 - RHO =0.0018 43 - CMEAN =30.5 44 - EMPROB=2430 45 - EPAIR =25.5 46 - GASID='Argon 73% Methane 20% Propanol 7%' 47 - *** Set the GASOK bits. 48 - GASOK(1)=.TRUE. 49 - GASOK(2)=.TRUE. 50 - GASOK(3)=.TRUE. 51 - GASOK(4)=.FALSE. 52 - GASOK(5)=.TRUE. 53 - GASOK(6)=.FALSE. 54 - GASOK(7)=.FALSE. 55 - GASOK(8)=.FALSE. 56 - CLSTYP='LANDAU' 57 - *** Set the extrapolation method. 58 - IVEXTR=1 59 - IDEXTR=1 60 - IAEXTR=0 61 - JVEXTR=0 62 - JDEXTR=0 63 - JAEXTR=0 64 - *** Call the timing routine TIMLOG to register the amount of CPU time. 65 - CALL TIMLOG('Loading argon 73% meth. 20% propanol 7%:') 66 - END 546 GARFIELD ================================================== P=GAS D=CO2 1 ============================ 0 + +DECK,CO2. 1 - SUBROUTINE CO2 2 - *----------------------------------------------------------------------- 3 - * CO2 - Fills the common /GASDAT/ with CO2 data obtained from 4 - * Karl Dederichs and Francois Piuz (drift velocity and 5 - * diffusion) and from Francois Rohrbach (multiplication). 6 - * VARIABLES : See /GASDAT/ replacing 'GAS' by 'CO2'. 7 - * (Last changed on 17/ 5/94.) 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,GASDATA. 11.- +SEQ,PRINTPLOT. 12 - REAL ECO2(33),VCO2(33),DCO2(33),ACO2(33) 0 13-+ +SELF,IF=SAVE. 14 - SAVE ECO2,VCO2,DCO2,ACO2 0 15-+ +SELF. 16 - *** Initialise the CO2 data via DATA statements. 17 - DATA ECO2/ 0.15, 0.2 , 0.3 , 0.4 , 0.5 , 0.6 , 0.7 , 18 - - 0.8 , 0.9 , 1.0 , 1.5 , 2.0 , 3.0 , 4.0 , 19 - - 5.0 , 6.0 , 7.0 , 8.0 , 9.0 , 10.0 , 15.0 , 20 - - 20.0 , 30.0 , 32.0 , 34.0 , 36.0 , 38.0 , 40.0 , 21 - - 42.0 , 44.0 , 46.0 , 48.0 , 50.0 / 22 - DATA VCO2/ 0.075, 0.10 , 0.15 , 0.20 , 0.25 , 0.3 , 0.35 , 23 - - 0.4 , 0.45 , 0.5 , 0.76 , 1.1 , 1.7 , 3.0 , 24 - - 5.0 , 6.8 , 8.1 , 9.0 ,10.0 ,11.0 ,13.5 , 25 - - 13.5 ,12.5 ,12.6 ,12.8 ,13.1 ,13.5 ,14.0 , 26 - - 14.6 ,15.2 ,15.8 ,16.4 ,17.0 / 27 - DATA DCO2/0.021 ,0.018 ,0.015 ,0.0125,0.0115,0.0105,0.01 , 28 - - 0.0092,0.009 ,0.0088,0.0078,0.0074,0.0072,0.008 , 29 - - 0.0096,0.0115,0.013 ,0.015 ,0.0165,0.018 ,0.02 , 30 - - 0.02 ,0.02 ,0.02 ,0.02 ,0.02 ,0.02 ,0.02 , 31 - - 0.02 ,0.02 ,0.02 ,0.02 ,0.02 / 32 - DATA ACO2/0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 , 33 - - 0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 , 34 - - 0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 , 35 - - 0.0 ,0.016 ,0.0232,0.031 ,0.04 ,0.051 ,0.063 , 36 - - 0.074 ,0.088 ,0.102 ,0.115 ,0.124 / 37 - *** Identify the routine, if requested. 38 - IF(LIDENT)PRINT *,' /// ROUTINE CO2 ///' 39 - *** Transfer the CO2 data to the /GASDAT/ common block. 40 - NGAS=33 41 - DO 10 I=1,NGAS 42 - EGAS(I)=ECO2(I) 43 - VGAS(I)=VCO2(I) 44 - DGAS(I)=DCO2(I)*SQRT(760.0) 45 - AGAS(I)=ACO2(I) 46 - MGAS(I)=1.09E-6 47 - WGAS(I)=0.0 48 - 10 CONTINUE 49 - *** Copy the other data as well. 50 - GASID ='CO2' 51 - A =44.0 52 - Z =22.0 53 - RHO =1.86E-3 54 - CMEAN =31.0 55 - EMPROB=3010.0 56 - EPAIR =33.0 57 - *** Set the GASOK bits. 58 - GASOK(1)=.TRUE. 59 - GASOK(2)=.TRUE. 60 - GASOK(3)=.TRUE. 61 - GASOK(4)=.TRUE. 62 - GASOK(5)=.TRUE. 63 - GASOK(6)=.FALSE. 64 - GASOK(7)=.FALSE. 65 - GASOK(8)=.FALSE. 66 - CLSTYP='LANDAU' 67 - *** Set the extrapolation method. 68 - IVEXTR=1 1 546 P=GAS D=CO2 2 PAGE 826 69 - IDEXTR=0 70 - IAEXTR=1 71 - JVEXTR=0 72 - JDEXTR=0 73 - JAEXTR=0 74 - IVMETH=0 75 - IDMETH=0 76 - IAMETH=0 77 - *** Register the amount of CPU time used for transferring. 78 - CALL TIMLOG('Loading the description of pure CO2: ') 79 - END 547 GARFIELD ================================================== P=GAS D=C80E20 1 ============================ 0 + +DECK,C80E20. 1 - SUBROUTINE C80E20 2 - *----------------------------------------------------------------------- 3 - * C80E20 - Stores the gas data for the mixture CO2 80% ethane 20% 4 - * in the common /GASDAT/. The data were provided by Diego 5 - * Bettoni. 6 - * (Last changed on 17/ 5/94.) 7 - *----------------------------------------------------------------------- 8.- +SEQ,DIMENSIONS. 9.- +SEQ,GASDATA. 10.- +SEQ,PRINTPLOT. 11 - REAL EDAT(15),VDAT(15),DDAT(15) 0 12-+ +SELF,IF=SAVE. 13 - SAVE EDAT,VDAT,DDAT 0 14-+ +SELF. 15 - *** Store the drift velocity and diffusion in temporary storage arrays. 16 - DATA EDAT/ 0.00526, 0.01053, 0.01316, 0.02632, 0.05263, 17 - - 0.10526, 0.13158, 0.26316, 0.52632, 1.05263, 18 - - 1.31579, 2.63158, 5.26316, 10.5263 , 13.1579 / 19 - DATA VDAT/0.3472E-02,0.6945E-02,0.8681E-02,0.1736E-01,0.3472E-01, 20 - - 0.6945E-01,0.8681E-01,0.1736E-00,0.3473E-00,0.6949E-00, 21 - - 0.8690E-00,0.1764E+01,0.4417E+01,0.8179E+01,0.8639E+01/ 22 - DATA DDAT/0.1160E-00,0.0789E-00,0.0706E-00,0.0499E-00,0.0353E-00, 23 - - 0.0250E-00,0.0223E-00,0.0158E-00,0.0113E-00,0.0084E-00, 24 - - 0.0077E-00,0.0069E-00,0.0112E-00,0.0152E-00,0.0158E-00/ 25 - *** Identify the routine if requested. 26 - IF(LIDENT)PRINT *,' /// ROUTINE C80E20 ///' 27 - *** Copy them to the common block. 28 - NGAS=15 29 - DO 10 I=1,NGAS 30 - EGAS(I)=EDAT(I) 31 - VGAS(I)=VDAT(I) 32 - DGAS(I)=DDAT(I)*SQRT(760.0) 33 - MGAS(I)=0.12E-5 34 - WGAS(I)=0.0 35 - 10 CONTINUE 36 - *** Next set the other gas data. 37 - A =41.2 38 - Z =21.2 39 - RHO =0.00168 40 - CMEAN =30.0 41 - EMPROB=2790.0 42 - EPAIR =32.4 43 - GASID='CO2 80% C2H6 20%' 44 - *** Set the GASOK bits. 45 - GASOK(1)=.TRUE. 46 - GASOK(2)=.TRUE. 47 - GASOK(3)=.TRUE. 48 - GASOK(4)=.FALSE. 49 - GASOK(5)=.TRUE. 50 - GASOK(6)=.FALSE. 51 - GASOK(7)=.FALSE. 52 - GASOK(8)=.FALSE. 53 - CLSTYP='LANDAU' 54 - *** Set the extrapolation method. 55 - IVEXTR=1 56 - IDEXTR=1 57 - IAEXTR=0 58 - JVEXTR=0 59 - JDEXTR=0 60 - JAEXTR=0 61 - IVMETH=0 62 - IDMETH=0 63 - IAMETH=0 64 - *** Call the timing routine TIMLOG to register the amount of CPU time. 65 - CALL TIMLOG('Loading CO2 80 % ethane 20%. ') 66 - END 548 GARFIELD ================================================== P=GAS D=C90E10 1 ============================ 0 + +DECK,C90E10. 1 - SUBROUTINE C90E10 2 - *----------------------------------------------------------------------- 3 - * C90E10 - Stores the gas data for the mixture CO2 90% ethane 10% 4 - * in the common /GASDAT/. The data were provided by Diego 5 - * Bettoni, A and Z from Reyad Sawafti. 6 - * (Last changed on 17/ 5/94.) 7 - *----------------------------------------------------------------------- 8.- +SEQ,DIMENSIONS. 9.- +SEQ,GASDATA. 10.- +SEQ,PRINTPLOT. 11 - REAL EDAT(17),VDAT(17),DDAT(17) 0 12-+ +SELF,IF=SAVE. 13 - SAVE EDAT,VDAT,DDAT 1 548 P=GAS D=C90E10 2 PAGE 827 14-+ +SELF. 15 - *** Store the drift velocity and diffusion in temporary storage arrays. 16 - DATA EDAT/ 1.316E-03, 2.632E-03, 5.263E-03,10.526E-03,13.158E-03, 17 - - 26.316E-03,52.632E-03, 0.1053 , 0.1316 , 0.2632 , 18 - - 0.5263 , 1.0526 , 1.3158 , 2.6316 , 5.2632 , 19 - - 10.5263 ,13.1579 / 20 - DATA VDAT/0.8186E-03,0.1637E-02,0.3274E-02,0.6549E-02,0.8186E-02, 21 - - 0.1637E-01,0.3274E-01,0.6549E-01,0.8186E-01,0.1637 , 22 - - 0.3274 ,0.6547 ,0.8184 ,0.1657E01 ,0.4383E01 , 23 - - 0.9121E01 ,0.9635E01 / 24 - DATA DDAT/0.2231 ,0.1578 ,0.1116 ,0.0789 ,0.0706 , 25 - - 0.0499 ,0.0353 ,0.0250 ,0.0223 ,0.0158 , 26 - - 0.0113 ,0.0083 ,0.0076 ,0.0066 ,0.0108 , 27 - - 0.0153 ,0.0159 / 28 - *** Identify the routine if requested. 29 - IF(LIDENT)PRINT *,' /// ROUTINE C90E10 ///' 30 - *** Copy them to the common block. 31 - NGAS=17 32 - DO 10 I=1,NGAS 33 - EGAS(I)=EDAT(I) 34 - VGAS(I)=VDAT(I) 35 - DGAS(I)=DDAT(I)*SQRT(760.0) 36 - MGAS(I)=0.12E-5 37 - WGAS(I)=0.0 38 - 10 CONTINUE 39 - *** Next set the other gas data. 40 - A =45.4 41 - Z =23.2 42 - RHO =0.00177 43 - CMEAN =31.0 44 - EMPROB=2900.0 45 - EPAIR =32.6 46 - GASID='CO2 90% C2H6 10%' 47 - *** Set the GASOK bits. 48 - GASOK(1)=.TRUE. 49 - GASOK(2)=.TRUE. 50 - GASOK(3)=.TRUE. 51 - GASOK(4)=.FALSE. 52 - GASOK(5)=.TRUE. 53 - GASOK(6)=.FALSE. 54 - GASOK(7)=.FALSE. 55 - GASOK(8)=.FALSE. 56 - CLSTYP='LANDAU' 57 - *** Set the extrapolation method. 58 - IVEXTR=1 59 - IDEXTR=1 60 - IAEXTR=0 61 - JVEXTR=0 62 - JDEXTR=0 63 - JAEXTR=0 64 - IVMETH=0 65 - IDMETH=0 66 - IAMETH=0 67 - *** Call the timing routine TIMLOG to register the amount of CPU time. 68 - CALL TIMLOG('Loading CO2 90 % ethane 10%. ') 69 - END 549 GARFIELD ================================================== P=GAS D=C90I10 1 ============================ 0 + +DECK,C90I10. 1 - SUBROUTINE C90I10 2 - *----------------------------------------------------------------------- 3 - * C90I10 - Stores the gas data for the mixture CO2 90%, isobutane 10% 4 - * in the common /GASDAT/. The data were stolen from Manfred 5 - * Guckes. Parameters from Helmut Boettcher. 6 - * (Last changed on 17/ 5/94.) 7 - *----------------------------------------------------------------------- 8.- +SEQ,DIMENSIONS. 9.- +SEQ,GASDATA. 10.- +SEQ,PRINTPLOT. 11 - REAL EDAT(17),VDAT(17),DDAT(17) 0 12-+ +SELF,IF=SAVE. 13 - SAVE EDAT,VDAT,DDAT 0 14-+ +SELF. 15 - *** Store the drift velocity and diffusion in temporary storage arrays. 16 - DATA EDAT/0.026 ,0.039 ,0.065 ,0.13 ,0.26 ,0.53 ,0.92 , 17 - - 1.32 ,2.10 ,2.63 ,3.95 ,6.58 ,13.2 ,15.0 , 18 - - 17.1 ,21.0 ,26.3 / 19 - DATA VDAT/0.015 ,0.023 ,0.038 ,0.076 ,0.153 ,0.30 ,0.54 , 20 - - 0.76 ,1.22 ,1.6 ,2.8 ,6.6 ,10.0 ,10.2 , 21 - - 10.3 ,10.4 ,10.5 / 22 - DATA DDAT/0.0514,0.0420,0.0325,0.0230,0.0163,0.0115,0.0088, 23 - - 0.0077,0.0069,0.0072,0.0107,0.0130,0.0087,0.0086, 24 - - 0.0085,0.0086,0.0093/ 25 - *** Identify the routine if requested. 26 - IF(LIDENT)PRINT *,' /// ROUTINE C90I10 ///' 27 - *** Copy them to the common block. 28 - NGAS=17 29 - DO 10 I=1,NGAS 30 - EGAS(I)=EDAT(I) 31 - VGAS(I)=VDAT(I) 32 - DGAS(I)=DDAT(I)*SQRT(760.0) 33 - MGAS(I)=0.101E-5 34 - WGAS(I)=0.0 35 - 10 CONTINUE 36 - *** Next set the other gas data. 37 - A =45.4 38 - Z =23.2 39 - RHO =0.00192 40 - CMEAN =32.5 41 - EMPROB=3159.0 42 - EPAIR =32.0 43 - GASID='CO2 90% Isobutane 10%' 44 - *** Set the GASOK bits. 1 549 P=GAS D=C90I10 2 PAGE 828 45 - GASOK(1)=.TRUE. 46 - GASOK(2)=.TRUE. 47 - GASOK(3)=.TRUE. 48 - GASOK(4)=.FALSE. 49 - GASOK(5)=.FALSE. 50 - GASOK(6)=.FALSE. 51 - GASOK(7)=.FALSE. 52 - GASOK(8)=.FALSE. 53 - CLSTYP='NOT SET' 54 - *** Call the timing routine TIMLOG to register the amount of CPU time. 55 - CALL TIMLOG('Loading CO2 90% isobutane 10%. ') 56 - END 550 GARFIELD ================================================== P=GAS D=ETHANE 1 ============================ 0 + +DECK,ETHANE. 1 - SUBROUTINE ETHANE 2 - *----------------------------------------------------------------------- 3 - * ETHANE - A routine filling the common /GASDAT/ with ethane data 4 - * obtained from Ingo Herbst. 5 - * VARIABLES : See the /GASDAT/ common block and the gas routines; 6 - * the letters 'gas' are to be changed into 'eta'. 7 - * (Last changed on 17/ 5/94.) 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,GASDATA. 11.- +SEQ,PRINTPLOT. 12 - REAL EETA(34),VETA(34),DETA(34) 0 13-+ +SELF,IF=SAVE. 14 - SAVE EETA,VETA,DETA,AETA,ZETA,RHOETA,CMETA,EMETA,EPETA,GMETA 0 15-+ +SELF. 16 - *** Initialise the ethane data via DATA statements. 17 - DATA EETA/0.20,0.33,0.43,0.58,0.83,1.08,1.32,1.58,1.84,2.09, 18 - - 2.34,2.58,2.83,3.07,3.32,3.55,3.80,4.04,4.29,4.53,4.83,5.07, 19 - - 5.32,10.0,20.0,30.0,40.0,50.0,60.0,70.0,80.0,90.0,100.,130./ 20 - DATA VETA/2.42,3.46,4.08,4.46,4.85,5.08,5.23,5.31,5.39,5.42, 21 - - 5.46,5.48,5.50,5.50,5.48,5.46,5.44,5.40,5.38,5.36,5.34,5.32, 22 - - 5.30,5.00,6.00,7.10,8.40,10.0,12.0,14.5,17.0,20.0,23.0,32.0/ 23 - DATA DETA/.0218,.0214,.0212,.0207,.0201,.0195,.0188,.0182, 24 - - .0176,.0171,.0166,.0160,.0155,.0150,.0145,.0141,.0137,.0132, 25 - - .0128,.0124,.0120,.0116,.0112,.0100,.0117,.0150,.0200,.0200, 26 - - .0200,.0200,.0200,.0200,.0200,.0200/ 27 - DATA AETA,ZETA,RHOETA ,CMETA,EMETA,EPETA,GMETA / 28 - - 30.1,18.0,1.30E-3, 30.0,1600., 24.6,1.10E-6/ 29 - *** Identify the routine if requested. 30 - IF(LIDENT)PRINT *,' /// ROUTINE ETHANE ///' 31 - *** Transfer the ethane data to the /GASDAT/ common block. 32 - NGAS=34 33 - DO 10 I=1,34 34 - EGAS(I)=EETA(I) 35 - VGAS(I)=VETA(I) 36 - DGAS(I)=DETA(I)*SQRT(760.0) 37 - MGAS(I)=GMETA 38 - WGAS(I)=0.0 39 - 10 CONTINUE 40 - GASID ='Ethane (C2H6)' 41 - A =AETA 42 - Z =ZETA 43 - RHO =RHOETA 44 - CMEAN =CMETA 45 - EMPROB=EMETA 46 - EPAIR =EPETA 47 - *** Set the GASOK bits. 48 - GASOK(1)=.TRUE. 49 - GASOK(2)=.TRUE. 50 - GASOK(3)=.TRUE. 51 - GASOK(4)=.FALSE. 52 - GASOK(5)=.TRUE. 53 - GASOK(6)=.FALSE. 54 - GASOK(7)=.FALSE. 55 - GASOK(8)=.FALSE. 56 - CLSTYP='LANDAU' 57 - *** Register the amount of CPU time with TIMLOG. 58 - CALL TIMLOG('Loading the description of pure ethane: ') 59 - END 551 GARFIELD ================================================== P=GAS D=ISOBUT 1 ============================ 0 + +DECK,ISOBUT. 1 - SUBROUTINE ISOBUT 2 - *----------------------------------------------------------------------- 3 - * ISOBUT - A routine filling the common /GASDAT/ with isobutane data 4 - * obtained from Emile Schmoetter. Parameters obtained from 5 - * Helmut Boettcher. Mobility corrected (Guido Michelon). 6 - * VARIABLES : See /GASDAT/ replacing 'GAS' by 'ISO'. 7 - * (Last changed on 15/ 2/99.) 8 - *----------------------------------------------------------------------- 9 - implicit none 10.- +SEQ,DIMENSIONS. 11.- +SEQ,GASDATA. 12.- +SEQ,PRINTPLOT. 13 - REAL EISO(7),VISO(7),DISO(7),AISO,ZISO,RHOISO,CMISO,EMISO,EPISO, 14 - - GMISO 15 - INTEGER I 0 16-+ +SELF,IF=SAVE. 17 - SAVE EISO,VISO,DISO,AISO,ZISO,RHOISO,CMISO,EMISO,EPISO,GMISO 0 18-+ +SELF. 19 - *** Initialise the isobutane data via DATA statements. 20 - DATA EISO/0.263,0.526,0.789,1.053,1.316,2.132,10.00/ 21 - DATA VISO/0.612,1.408,2.082,2.694,3.306,5.000,5.300/ 22 - DATA DISO/0.427,0.353,0.342,0.334,0.327,0.336,0.400/ 23 - DATA AISO,ZISO,RHOISO ,CMISO,EMISO,EPISO,GMISO / 1 551 P=GAS D=ISOBUT 2 PAGE 829 24 - - 58.0,34.0,2.42E-3, 46.0,4500., 23.0,0.61E-6/ 25 - *** Identify the routine. 26 - IF(LIDENT)PRINT *,' /// ROUTINE ISOBUT ///' 27 - *** Transfer the isobutane data to the /GASDAT/ common block. 28 - NGAS=7 29 - DO 10 I=1,7 30 - EGAS(I)=EISO(I) 31 - VGAS(I)=VISO(I) 32 - DGAS(I)=DISO(I)*SQRT(760.0) 33 - MGAS(I)=GMISO 34 - WGAS(I)=0.0 35 - 10 CONTINUE 36 - GASID ='Isobutane (C4H10)' 37 - A =AISO 38 - Z =ZISO 39 - RHO =RHOISO 40 - CMEAN =CMISO 41 - EMPROB=EMISO 42 - EPAIR =EPISO 43 - *** Set the GASOK bits. 44 - GASOK(1)=.TRUE. 45 - GASOK(2)=.TRUE. 46 - GASOK(3)=.TRUE. 47 - GASOK(4)=.FALSE. 48 - GASOK(5)=.TRUE. 49 - GASOK(6)=.FALSE. 50 - GASOK(7)=.FALSE. 51 - GASOK(8)=.FALSE. 52 - CLSTYP='LANDAU' 53 - *** Register the amount of CPU time used for transferring the data. 54 - CALL TIMLOG('Loading the description of isobutane: ') 55 - END 552 GARFIELD ================================================== P=GAS D=METHAN 1 ============================ 0 + +DECK,METHAN. 1 - SUBROUTINE METHAN 2 - *----------------------------------------------------------------------- 3 - * METHAN - A routine filling the common /GASDAT/ with methane data 4 - * obtained from Ingo Herbst, for the drift velocity and the 5 - * diffusion and from "Basic data of plasma physics, 1966", 6 - * Sanborn C. Brown. 7 - * VARIABLES : See the /GASDAT/ common block, replacing 'GAS' by 'MET'. 8 - * (Last changed on 17/ 5/94.) 9 - *----------------------------------------------------------------------- 10.- +SEQ,DIMENSIONS. 11.- +SEQ,GASDATA. 12.- +SEQ,PRINTPLOT. 13 - REAL EMET(22),VMET(22),DMET(22),AMET(22) 0 14-+ +SELF,IF=SAVE. 15 - SAVE EMET,VMET,DMET,AMET 0 16-+ +SELF. 17 - *** Initialise the methane data via DATA statements. 18 - DATA EMET/ 0.1 , 0.25, 0.5 , 0.75, 1.0 , 1.25, 1.5 , 19 - - 1.75, 2.0 , 3.0 , 4.0 , 7.0 , 10.0 , 20.0 , 20 - - 30.0 , 40.0 , 50.0 , 60.0 , 70.0 , 80.0 , 90.0 , 21 - - 100.0 / 22 - DATA VMET/ 1.2 , 3.5 , 7.0 , 9.5 , 10.4 , 10.5 , 10.4 , 23 - - 9.8 , 9.2 , 7.7 , 7.0 , 6.3 , 6.0 , 5.8 , 24 - - 6.8 , 8.0 , 10.0 , 13.0 , 16.0 , 19.0 , 22.0 , 25 - - 25.0 / 26 - DATA DMET/ 0.033, 0.029, 0.025, 0.024, 0.023, 0.023, 0.024, 27 - - 0.025, 0.026, 0.028, 0.029,0.0298,0.0299, 0.03 , 28 - - 0.03 , 0.03 , 0.03 , 0.03 , 0.03 , 0.03 , 0.03 , 29 - - 0.03 / 30 - DATA AMET/ 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 31 - - 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 32 - - 0.0 , 0.0 , 0.0 , 0.2 , 0.4 , 0.6 , 0.8 , 33 - - 1.0 / 34 - *** Identify the routine, if requested. 35 - IF(LIDENT)PRINT *,' /// ROUTINE METHAN ///' 36 - *** Transfer the methane data to the /GASDAT/ common block. 37 - NGAS=22 38 - DO 10 I=1,NGAS 39 - EGAS(I)=EMET(I) 40 - VGAS(I)=VMET(I) 41 - DGAS(I)=DMET(I)*SQRT(760.0) 42 - AGAS(I)=AMET(I) 43 - MGAS(I)=2.26E-6 44 - WGAS(I)=0.0 45 - 10 CONTINUE 46 - GASID ='Methane (CH4)' 47 - A =16.1 48 - Z =10.0 49 - RHO =7.17E-4 50 - CMEAN =16.0 51 - EMPROB=910.0 52 - EPAIR =27.3 53 - *** Set the GASOK bits. 54 - GASOK(1)=.TRUE. 55 - GASOK(2)=.TRUE. 56 - GASOK(3)=.TRUE. 57 - GASOK(4)=.TRUE. 58 - GASOK(5)=.TRUE. 59 - GASOK(6)=.FALSE. 60 - GASOK(7)=.FALSE. 61 - GASOK(8)=.FALSE. 62 - CLSTYP='LANDAU' 63 - *** Set the extrapolation method. 64 - IVEXTR=1 65 - IDEXTR=1 66 - IAEXTR=1 67 - JVEXTR=0 68 - JDEXTR=0 1 552 P=GAS D=METHAN 2 PAGE 830 69 - JAEXTR=0 70 - IVMETH=0 71 - IDMETH=0 72 - IAMETH=0 73 - *** Register the amount of CPU time with TIMLOG. 74 - CALL TIMLOG('Loading the description of pure methane:') 75 - END 553 GARFIELD ================================================== P=FIELD D= 1 ============================ 0 + +PATCH,FIELD. 554 GARFIELD ================================================== P=FIELD D=FLDINP 1 ============================ 0 + +DECK,FLDINP. 1 - SUBROUTINE FLDINP 2 - *----------------------------------------------------------------------- 3 - * FLDINP - Routine reading and interpreting the instructions of the 4 - * field section. 5 - * Variables : NGRIDR : NGRID as read from input file 6 - * (Last changed on 14/11/98.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,PARAMETERS. 12.- +SEQ,CELLDATA. 13.- +SEQ,BFIELD. 14.- +SEQ,CONSTANTS. 15 - CHARACTER*(MXCHAR) STRING 16 - REAL XTEST,YTEST,ZTEST,EX,EY,EZ,ETOT,BX,BY,BZ,BTOT,VOLT,CPU,RNDM 17 - INTEGER ILOC,NC,IFAIL1,IFAIL2,IFAIL3,IFAIL, 18 - - NGRIDR,NGRDXR,NGRDYR,I,NTEST,NWORD,INPCMP 19 - EXTERNAL INPCMP,RNDM 0 20-+ +SELF,IF=AST. 21 - EXTERNAL ASTCCH 0 22-+ +SELF. 23 - *** Identify the routine. 24 - IF(LIDENT)PRINT *,' /// ROUTINE FLDINP ///' 25 - *** Print a header for this page. 26 - WRITE(*,'(''1'')') 27 - PRINT *,' ================================================' 28 - PRINT *,' ========== Start of field section ==========' 29 - PRINT *,' ================================================' 30 - PRINT *,' ' 31 - *** Start an input loop. 32 - CALL INPPRM('Field','NEW-PRINT') 33 - 10 CONTINUE 34 - CALL INPWRD(NWORD) 0 35-+ +SELF,IF=AST. 36 - *** Set up ASTCCH as the condition handler. 37 - CALL LIB$ESTABLISH(ASTCCH) 0 38-+ +SELF. 39 - CALL INPSTR(1,1,STRING,NC) 40 - *** Skip the line if blank. 41 - IF(NWORD.EQ.0)GOTO 10 42 - *** Return to main program if '&' is the first character. 43 - IF(STRING(1:1).EQ.'&')THEN 44 - RETURN 45 - *** Look for the AREA instruction. 46 - ELSEIF(INPCMP(1,'A#REA').NE.0)THEN 47 - CALL CELVIE(PXMIN,PYMIN,PZMIN,PXMAX,PYMAX,PZMAX) 48 - *** Look for the keyword CHECK. 49 - ELSEIF(INPCMP(1,'CH#ECK').NE.0)THEN 50 - CALL FLDCHK 51 - *** Look for the keyword GRID. 52 - ELSEIF(INPCMP(1,'G#RID').NE.0)THEN 53 - IF(NWORD.EQ.1)THEN 54 - WRITE(LUNOUT,'('' Current number of grid points is '', 55 - - I3,'' by '',I3,''.'')') NGRIDX,NGRIDY 56 - ELSEIF(NWORD.EQ.2)THEN 57 - CALL INPCHK(2,1,IFAIL1) 58 - CALL INPRDI(2,NGRIDR,25) 59 - IF(NGRIDR.LE.1.OR.NGRIDR.GT.MXGRID) 60 - - CALL INPMSG(2,'GRID out of range 2 -> MXGRID.') 61 - IF(IFAIL1.NE.0.OR.NGRIDR.LE.1.OR.NGRIDR.GT.MXGRID)THEN 62 - PRINT *,' !!!!!! FLDINP WARNING : GRID statement', 63 - - ' ignored because of syntax or value errors.' 64 - ELSE 65 - NGRIDX=NGRIDR 66 - NGRIDY=NGRIDR 67 - ENDIF 68 - ELSEIF(NWORD.EQ.3)THEN 69 - CALL INPCHK(2,1,IFAIL1) 70 - CALL INPCHK(3,1,IFAIL2) 71 - CALL INPRDI(2,NGRDXR,25) 72 - CALL INPRDI(3,NGRDYR,25) 73 - IF(NGRDXR.LE.1.OR.NGRDXR.GT.MXGRID) 74 - - CALL INPMSG(2,'out of the range 2 -> MXGRID. ') 75 - IF(NGRDYR.LE.1.OR.NGRDYR.GT.MXGRID) 76 - - CALL INPMSG(2,'out of the range 2 -> MXGRID. ') 77 - IF(IFAIL1.NE.0.OR.NGRDXR.LE.1.OR.NGRDXR.GT.MXGRID.OR. 78 - - NGRDYR.LE.1.OR.NGRDYR.GT.MXGRID)THEN 79 - PRINT *,' !!!!!! FLDINP WARNING : GRID statement', 80 - - ' ignored because of syntax or value errors.' 81 - ELSE 82 - NGRIDX=NGRDXR 83 - NGRIDY=NGRDYR 84 - ENDIF 85 - ELSE 86 - PRINT *,' !!!!!! FLDINP WARNING : GRID requires 1'// 87 - - ' or 2 arguments ; the instruction is ignored.' 1 554 P=FIELD D=FLDINP 2 PAGE 831 88 - ENDIF 89 - *** Dipole moments. 90 - ELSEIF(INPCMP(1,'MULT#IPOLE-#MOMENTS').NE.0)THEN 91 - CALL EFMWIR 92 - *** Look for the keyword OPTION, 93 - ELSEIF(INPCMP(1,'OPT#IONS').NE.0)THEN 94 - IF(NWORD.LE.1)WRITE(LUNOUT,'(/ 95 - - '' LOCAL OPTIONS CURRENTLY IN EFFECT: ''// 96 - - '' Check for multiple field map indices: '', 97 - - L1/ 98 - - '' Contour all media (T) or drift medium (F): '', 99 - - L1/ 100 - - '' Plot wires by markers (WIRE-MARKERS): '', 101 - - L1)') LMAPCH,LCNTAM,LWRMRK 102 - * Check for the various options. 103 - DO 11 I=2,NWORD 104 - * Detect multiple map indices. 105 - IF(INPCMP(I,'CH#ECK-MAP-#INDICES')+ 106 - - INPCMP(I,'CH#ECK-MAP-#INDEXING').NE.0)THEN 107 - LMAPCH=.TRUE. 108 - ELSEIF(INPCMP(I,'NOCH#ECK-MAP-#INDICES')+ 109 - - INPCMP(I,'NOCH#ECK-MAP-#INDEXING').NE.0)THEN 110 - LMAPCH=.FALSE. 111 - * Contours in other than drift media. 112 - ELSEIF(INPCMP(I,'CONT#OUR-ALL-#MEDIA').NE.0)THEN 113 - LCNTAM=.TRUE. 114 - ELSEIF(INPCMP(I,'CONT#OUR-DR#IFT-#MEDIUM')+ 115 - - INPCMP(I,'CONT#OUR-DR#IFT-#MEDIA').NE.0)THEN 116 - LCNTAM=.FALSE. 117 - * Wires drawn as markers. 118 - ELSEIF(INPCMP(I,'NOW#IRE-M#ARKERS').NE.0)THEN 119 - LWRMRK=.FALSE. 120 - ELSEIF(INPCMP(I,'W#IRE-M#ARKERS').NE.0)THEN 121 - LWRMRK=.TRUE. 122 - ELSE 123 - CALL INPMSG(I,'The option is not known. ') 124 - ENDIF 125 - 11 CONTINUE 126 - *** Make plots if PLOT is a keyword. 127 - ELSEIF(INPCMP(1,'PL#OT-#FIELD').NE.0)THEN 128 - CALL FLDPLT 129 - *** Look for the keyword PRINT. 130 - ELSEIF(INPCMP(1,'PR#INT-#FIELD').NE.0)THEN 131 - CALL FLDPRT 132 - *** Test field calculation. 133 - ELSEIF(INPCMP(1,'S#AMPLE').NE.0)THEN 134 - CALL INPCHK(2,2,IFAIL1) 135 - CALL INPCHK(3,2,IFAIL2) 136 - CALL INPCHK(4,2,IFAIL3) 137 - CALL INPRDR(2,XTEST,0.0) 138 - CALL INPRDR(3,YTEST,0.0) 139 - CALL INPRDR(4,ZTEST,0.0) 140 - PRINT *,' ++++++ FLDINP DEBUG : Sampling EFIELD + BFIELD' 141 - IF(.NOT.POLAR)PRINT 3020,XTEST,YTEST,ZTEST 142 - IF(POLAR)THEN 143 - PRINT 3025,XTEST,YTEST,ZTEST 144 - CALL CFMPTR(XTEST,YTEST,XTEST,YTEST,1,IFAIL) 145 - IF(IFAIL.NE.0)THEN 146 - PRINT *,' !!!!!! FLDINP WARNING : Illegal polar', 147 - - ' coordinates; command not executed.' 148 - CALL INPERR 149 - GOTO 10 150 - ENDIF 151 - PRINT *,' Internal coordinates:' 152 - PRINT 3020,XTEST,YTEST,ZTEST 153 - ENDIF 154 - CALL EFIELD(XTEST,YTEST,ZTEST,EX,EY,EZ,ETOT,VOLT,1,ILOC) 155 - PRINT *,' Location code for this point : ',ILOC 156 - IF(POLAR)THEN 157 - EX=EX/EXP(XTEST) 158 - EY=EY/EXP(XTEST) 159 - ETOT=ETOT/EXP(XTEST) 160 - ENDIF 161 - IF(.NOT.POLAR)PRINT 3030,EX,EY,EZ,ETOT,VOLT 162 - IF(POLAR)PRINT 3035,EX,EY,EZ,ETOT,VOLT 163 - IF(MAGOK)THEN 164 - CALL BFIELD(XTEST,YTEST,ZTEST,BX,BY,BZ,BTOT) 165 - PRINT 3040,BX,BY,BZ,BTOT 166 - ENDIF 167 - 3020 FORMAT(' At (x,y,z) = (',F10.3,2(',',F10.3),')') 168 - 3025 FORMAT(' At (r,phi,z) = (',F10.3,2(',',F10.3),')') 169 - 3030 FORMAT(' Ex=',F15.4,' Ey=',F15.4,' Ez=',F15.4, 170 - - ' Etot=',F15.4,' V=',F15.4) 171 - 3035 FORMAT(' Er=',F15.4,' Ephi=',F15.4,' Ez=',F15.4, 172 - - ' Etot=',F15.4,' V=',F15.4) 173 - 3040 FORMAT(' Bx=',F15.4,' By=',F15.4,' Bz=',F15.4, 174 - - ' Btot=',F15.4) 175 - PRINT *,' ++++++ FLDINP DEBUG : End of SAMPLE.' 176 - *** Search for the SELECT instruction. 177 - ELSEIF(INPCMP(1,'SEL#ECT').NE.0)THEN 178 - CALL CELSEL 179 - *** Perform a timing if TIME is a keyword. 180 - ELSEIF(INPCMP(1,'TIM#E').NE.0)THEN 181 - CALL INPCHK(2,1,IFAIL1) 182 - CALL INPRDI(2,NTEST,1000) 183 - IF(NTEST.LE.0)NTEST=1000 184 - CALL TIMED(CPU) 185 - DO 3050 I=1,NTEST 186 - XTEST=PXMIN+RNDM(I) *(PXMAX-PXMIN) 187 - YTEST=PYMIN+RNDM(I+1)*(PYMAX-PYMIN) 188 - CALL EFIELD(XTEST,YTEST,0.0,EX,EY,EZ,ETOT,VOLT,1,ILOC) 189 - 3050 CONTINUE 190 - CALL TIMED(CPU) 191 - CALL TIMLOG('< TIME: field evaluation > ') 192 - PRINT *,' ++++++ FLDINP DEBUG : CPU time required for', 193 - - NTEST,' field evaluations is ',CPU,' seconds.' 1 554 P=FIELD D=FLDINP 3 PAGE 832 194 - *** Look for the instruction TRACK. 195 - ELSEIF(INPCMP(1,'TR#ACK').NE.0)THEN 196 - CALL TRAREA 0 197-+ +SELF,IF=ZERO. 198 - *** Look for the ZERO instruction 199 - ELSEIF(INPCMP(1,'ZERO').NE.0)THEN 200 - PRINT *,' !!!!! FLDINP WARNING : This instruction is', 201 - - ' currently being debugged.' 202 - CALL ZROTST 0 203-+ +SELF. 204 - *** It is not possible to get here if the keyword is valid. 205 - ELSE 206 - CALL INPSTR(1,1,STRING,NC) 207 - PRINT *,' !!!!!! FLDINP WARNING : ',STRING(1:NC),' is', 208 - - ' not a valid instruction ; ignored' 209 - ENDIF 210 - CALL INPERR 211 - GOTO 10 212 - END 555 GARFIELD ================================================== P=FIELD D=FLDPLT 1 ============================ 0 + +DECK,FLDPLT. 1 - SUBROUTINE FLDPLT 2 - *----------------------------------------------------------------------- 3 - * FLDPLT - Subroutine plotting the electric field, the magnetic field 4 - * and the potential in a variety of ways: histograms, contour 5 - * plots, vector plots and surface plots. 6 - * Variables : XPL,YPL : Used for plotting lines 7 - * FUNCT. : Stores the function text the plots 8 - * VAR : Array of input values for ALGEXE 9 - * GRID : Array of 'heights' for surface plots 10 - * COORD : Contains the ordinate of the graph data 11 - * VALUE : Contains the function values of the graph 12 - * HIST : Stores the histogram 13 - * CMIN,CMAX : Range of contour heights 14 - * HMIN,HMAX : Range in the histogram 15 - * NCHA : Number of bins in the histogram. 16 - * FLAG : Logicals used for parsing the command 17 - * LHIST ... : Determines whether the plot will be made 18 - * PHI,THETA : Viewing angle for 3-dimensional plots. 19 - * (Last changed on 6/11/98.) 20 - *----------------------------------------------------------------------- 21 - implicit none 22.- +SEQ,DIMENSIONS. 23.- +SEQ,CONSTANTS. 24.- +SEQ,CELLDATA. 25.- +SEQ,PARAMETERS. 26.- +SEQ,GRAPHICS. 27.- +SEQ,PRINTPLOT. 28.- +SEQ,BFIELD. 29 - REAL COORD(MXLIST),VALUE(MXLIST),RES(5),VAR(MXVAR), 30 - - HMIN,HMAX,HMINR,HMAXR,CMIN,CMAX,CMINR,CMAXR,PHI,THETA, 31 - - XPOS,YPOS,ZPOS,FACNRM,RT0,RT1,PT0,PT1,XXPOS,YYPOS, 32 - - VXMIN,VYMIN,VXMAX,VYMAX,GMINR,GRSMIN,GMAXR,GRSMAX 33 - INTEGER MODVAR(MXVAR),MODRES(5),NCONT,NCONTR,NCONTP,I,J,II,INEXT, 34 - - NWORD,NC1,NC2,NC3,NC4,NC5,NCAUX,NCTOT,IFAIL,IFAIL1,IFAIL2, 35 - - NCHA,NCHAR,IOPT,NRES,NREXP,IENTRY,ICOORD,ILOC,IHIST, 36 - - IVECT1,IVECT2,IVECT3,ISURF,INPTYP,INPCMP,IHISRF,IENCON, 37 - - NCAUX1,NCAUX2,NCAUX3,NCAUX4,NGRPNT,NPNTR,NCFTRA,IENTRA 38 - CHARACTER*(MXCHAR) STRING,FUNCT1,FUNCT2,FUNCT3,FUNCT4,FUNCT5, 39 - - FUNTRA 40 - CHARACTER*20 AUX1,AUX2,AUX3,AUX4 41 - CHARACTER*10 VARLIS(MXVAR) 42 - LOGICAL USE(MXVAR),FLAG(MXWORD+5),EVALE,EVALB,LGRPRT, 43 - - LHIST,LVECT,LGRAPH,LCONT,LSURF,CAUTO,HAUTO,CLAB 44 - EXTERNAL INPCMP,INPTYP,FCONT 45 - COMMON /CNTDAT/ IOPT,IENCON,EVALE,EVALB 0 46-+ +SELF,IF=NAG. 47 - INTEGER ICHK,JCHK,IFLAT,IERR 48 - REAL CHEXP 49 - DOUBLE PRECISION WS,CHTS,DUM 50 - COMMON /MATRIX/ WS(MXWIRE,MXWIRE),CHTS(MXWIRE),DUM(3*MXWIRE+3) 0 51-+ +SELF,IF=HIGZ. 52 - INTEGER ICHK,JCHK,IFLAT 53 - REAL WS,PAR,DUM,SMIN,SMAX 54 - COMMON /MATRIX/ WS(MXWIRE,MXWIRE),PAR(37), 55 - - DUM(MXWIRE**2+8*MXWIRE-31) 0 56-+ +SELF,IF=SAVE. 57 - SAVE VARLIS,HMIN,HMAX,NCHA,PHI,THETA,NCONT 0 58-+ +SELF. 59 - DATA (VARLIS(I),I=5,13)/'E ','V ','BX ', 60 - - 'BY ','BZ ','B ', 61 - - 'Z ','EZ ','T '/ 62 - DATA HMIN,HMAX /0.0,10000.0/ 63 - DATA NCHA/100/ 64 - DATA NCONT/21/ 65 - DATA NGRPNT/MXLIST/,LGRPRT/.FALSE./ 66 - DATA PHI,THETA/30.0,60.0/ 67 - *** Define an output format. 68 - 1010 FORMAT(26X,A10,L2,3X,A20,2X,I2,2(2X,E10.3),2(2X,I6),2(2X,E10.3)) 69 - *** Identify the routine. 70 - IF(LIDENT)PRINT *,' /// ROUTINE FLDPLT ///' 71 - *** Set default area. 72 - CALL GRASET(PXMIN,PYMIN,PZMIN,PXMAX,PYMAX,PZMAX) 73 - *** Preset the options, function strings etc, 74 - FUNCT1=' ' 75 - FUNCT2=' ' 76 - FUNCT3=' ' 77 - FUNCT4=' ' 1 555 P=FIELD D=FLDPLT 2 PAGE 833 78 - FUNCT5=' ' 79 - LGRAPH=.FALSE. 80 - LSURF=.FALSE. 81 - LVECT=.FALSE. 82 - LHIST=.FALSE. 83 - LCONT=.FALSE. 84 - FUNTRA='?' 85 - NCFTRA=1 86 - CMIN=VMIN 87 - CMAX=VMAX 88 - CAUTO=.TRUE. 89 - CLAB=.TRUE. 90 - HAUTO=.TRUE. 91 - GRSMIN=1 92 - GRSMAX=-1 93 - *** Make sure the variables have appropriate names 94 - IF(POLAR)THEN 95 - VARLIS(1)='R ' 96 - VARLIS(2)='PHI ' 97 - VARLIS(3)='ER ' 98 - VARLIS(4)='EPHI ' 99 - ELSE 100 - VARLIS(1)='X ' 101 - VARLIS(2)='Y ' 102 - VARLIS(3)='EX ' 103 - VARLIS(4)='EY ' 104 - ENDIF 105 - *** Examine the input, first step is finding out where the keywords are. 106 - CALL INPNUM(NWORD) 107 - DO 10 I=1,MXWORD+5 108 - IF(I.EQ.1.OR.I.GT.NWORD)THEN 109 - FLAG(I)=.TRUE. 110 - ELSEIF(INPCMP(I,'A#NGLES')+INPCMP(I,'AUTO#MATIC')+ 111 - - INPCMP(I,'BI#NS')+INPCMP(I,'SC#ALE')+ 112 - - INPCMP(I,'PR#INT')+INPCMP(I,'NOPR#INT')+ 113 - - INPCMP(I,'C#ONTOUR')+INPCMP(I,'G#RAPH')+ 114 - - INPCMP(I,'H#ISTOGRAM')+INPCMP(I,'N')+ 115 - - INPCMP(I,'LAB#ELS')+INPCMP(I,'NOLAB#ELS')+ 116 - - INPCMP(I,'RA#NGE')+INPCMP(I,'S#URFACE')+ 117 - - INPCMP(I,'VE#CTOR')+INPCMP(I,'ON').NE.0)THEN 118 - FLAG(I)=.TRUE. 119 - ELSE 120 - FLAG(I)=.FALSE. 121 - ENDIF 122 - 10 CONTINUE 123 - *** Start a loop over the list, 124 - INEXT=1 125 - DO 20 I=2,NWORD 126 - IF(I.LT.INEXT)GOTO 20 127 - * warn if the user uses a sub-keyword out of context. 128 - IF(INPCMP(I,'RA#NGE')+INPCMP(I,'N')+INPCMP(I,'BI#NS')+ 129 - - INPCMP(I,'LAB#ELS')+INPCMP(I,'NOLAB#ELS')+ 130 - - INPCMP(I,'A#NGLES')+INPCMP(I,'AUTO#MATIC')+ 131 - - INPCMP(I,'PR#INT')+INPCMP(I,'NOPR#INT')+ 132 - - INPCMP(I,'ON')+INPCMP(I,'SC#ALE').NE.0)THEN 133 - CALL INPMSG(I,'Valid keyword out of context. ') 134 - IF(.NOT.FLAG(I+1))THEN 135 - CALL INPMSG(I+1,'See the previous message. ') 136 - INEXT=I+2 137 - IF(.NOT.FLAG(I+2))THEN 138 - CALL INPMSG(I+2,'See the previous messages. ') 139 - INEXT=I+3 140 - ENDIF 141 - ENDIF 142 - * warn if an unknown keywords appear, 143 - ELSEIF(.NOT.FLAG(I))THEN 144 - CALL INPMSG(I,'Item is not a known keyword. ') 145 - ** Find out whether a GRAPH is requested next, 146 - ELSEIF(INPCMP(I,'G#RAPH').NE.0)THEN 147 - IF(LGRAPH)PRINT *,' !!!!!! FLDPLT WARNING : Only one'// 148 - - ' graph per PLOT statement can be processed.' 149 - LGRAPH=.TRUE. 150 - IF(FLAG(I+1))THEN 151 - FUNCT1(1:1)='V' 152 - NC1=1 153 - INEXT=I+1 154 - ELSE 155 - CALL INPSTR(I+1,I+1,STRING,NC1) 156 - FUNCT1(1:NC1)=STRING(1:NC1) 157 - INEXT=I+2 158 - ENDIF 159 - * Look for sub-keywords with GRAPH. 160 - DO 230 II=I,NWORD 161 - IF(II.LT.INEXT)GOTO 230 162 - * Look for the subkeyword ON. 163 - IF(INPCMP(II,'ON').NE.0)THEN 164 - IF(FLAG(II+1))THEN 165 - CALL INPMSG(II,'The curve function is absent. ') 166 - ELSE 167 - CALL INPSTR(II+1,II+1,FUNTRA,NCFTRA) 168 - INEXT=II+2 169 - ENDIF 170 - * Look for the subkeyword N. 171 - ELSEIF(INPCMP(II,'N').NE.0)THEN 172 - IF(FLAG(II+1))THEN 173 - CALL INPMSG(II,'number of points is missing. ') 174 - ELSE 175 - CALL INPCHK(II+1,1,IFAIL1) 176 - CALL INPRDI(II+1,NPNTR,NGRPNT) 177 - IF(NPNTR.LT.2.AND.IFAIL1.EQ.0)CALL INPMSG(II+1, 178 - - 'number of point less than 2. ') 179 - IF(NPNTR.GT.MXLIST.AND.IFAIL1.EQ.0)CALL INPMSG 180 - - (II+1,'number of points > MXLIST. ') 181 - IF(NPNTR.GE.2.AND.NPNTR.LE.MXLIST)NGRPNT=NPNTR 182 - INEXT=II+2 183 - ENDIF 1 555 P=FIELD D=FLDPLT 3 PAGE 834 184 - * Look for print options. 185 - ELSEIF(INPCMP(II,'PR#INT').NE.0)THEN 186 - LGRPRT=.TRUE. 187 - INEXT=II+1 188 - ELSEIF(INPCMP(II,'NOPR#INT').NE.0)THEN 189 - LGRPRT=.FALSE. 190 - INEXT=II+1 191 - * Scale of the graph. 192 - ELSEIF(INPCMP(II,'SC#ALE')+INPCMP(II,'RA#NGE').NE.0)THEN 193 - IF(FLAG(II+1).OR.FLAG(II+2))THEN 194 - CALL INPMSG(II,'the arguments are missing. ') 195 - ELSE 196 - CALL INPCHK(II+1,2,IFAIL1) 197 - CALL INPRDR(II+1,GMINR,+1.0) 198 - CALL INPCHK(II+2,2,IFAIL2) 199 - CALL INPRDR(II+2,GMAXR,-1.0) 200 - IF(GMINR.EQ.GMAXR)THEN 201 - CALL INPMSG(II+1,'zero range in the') 202 - CALL INPMSG(II+2,'scale not permitted') 203 - ELSE 204 - GRSMIN=MIN(GMINR,GMAXR) 205 - GRSMAX=MAX(GMINR,GMAXR) 206 - ENDIF 207 - INEXT=II+3 208 - ENDIF 209 - * Otherwise skip to the next keyword. 210 - ELSE 211 - GOTO 20 212 - ENDIF 213 - 230 CONTINUE 214 - ** Find out whether a CONTOUR plot is requested next, 215 - ELSEIF(INPCMP(I,'C#ONTOUR').NE.0)THEN 216 - IF(LCONT)PRINT *,' !!!!!! FLDPLT WARNING : Only one'// 217 - - ' contour plot per PLOT statement can be processed.' 218 - LCONT=.TRUE. 219 - * Store the function string, using the default if absent. 220 - IF(FLAG(I+1))THEN 221 - FUNCT2(1:1)='V' 222 - NC2=1 223 - INEXT=I+1 224 - ELSE 225 - CALL INPSTR(I+1,I+1,STRING,NC2) 226 - FUNCT2(1:NC2)=STRING(1:NC2) 227 - INEXT=I+2 228 - ENDIF 229 - * Set default values for the range, depending on the function. 230 - IF(FUNCT2(1:NC2).EQ.'V')THEN 231 - CMIN=VMIN 232 - CMAX=VMAX 233 - ELSE 234 - CMIN=0.0 235 - CMAX=10000.0 236 - ENDIF 237 - * Look for sub-keywords with CONTOUR. 238 - DO 210 II=I+1,NWORD 239 - IF(II.LT.INEXT)GOTO 210 240 - * LABELing of the contours. 241 - IF(INPCMP(II,'LAB#ELS').NE.0)THEN 242 - CLAB=.TRUE. 243 - INEXT=II+1 244 - ELSEIF(INPCMP(II,'NOLAB#ELS').NE.0)THEN 245 - CLAB=.FALSE. 246 - INEXT=II+1 247 - * The RANGE subkeyword. 248 - ELSEIF(INPCMP(II,'RA#NGE').NE.0)THEN 249 - IF(INPCMP(II+1,'AUTO#MATIC').NE.0)THEN 250 - CMIN=0.0 251 - CMAX=0.0 252 - CAUTO=.TRUE. 253 - INEXT=II+2 254 - ELSEIF((.NOT.FLAG(II+1)).AND.FLAG(II+2))THEN 255 - CALL INPCHK(II+1,2,IFAIL1) 256 - CALL INPRDR(II+1,CMINR,CMIN) 257 - CMIN=CMINR 258 - CMAX=CMINR 259 - CAUTO=.FALSE. 260 - INEXT=II+2 261 - ELSEIF((.NOT.FLAG(II+1)).AND.(.NOT.FLAG(II+2)))THEN 262 - CALL INPCHK(II+1,2,IFAIL1) 263 - CALL INPCHK(II+2,2,IFAIL2) 264 - CALL INPRDR(II+1,CMINR,CMIN) 265 - CALL INPRDR(II+2,CMAXR,CMAX) 266 - CMIN=MIN(CMINR,CMAXR) 267 - CMAX=MAX(CMINR,CMAXR) 268 - CAUTO=.FALSE. 269 - INEXT=II+3 270 - ELSE 271 - CALL INPMSG(II,'RANGE takes two arguments. ') 272 - IF(FLAG(II+1))THEN 273 - INEXT=II+1 274 - ELSE 275 - CALL INPMSG(II+1, 276 - - 'Ignored, see previous message.') 277 - INEXT=II+2 278 - ENDIF 279 - ENDIF 280 - * Sub keyword N. 281 - ELSEIF(INPCMP(II,'N').NE.0)THEN 282 - IF(FLAG(II+1))THEN 283 - CALL INPMSG(II,'N must have an argument. ') 284 - INEXT=II+1 285 - ELSE 286 - CALL INPCHK(II+1,1,IFAIL1) 287 - CALL INPRDI(II+1,NCONTR,NCONT) 288 - IF(NCONTR.LT.1.AND.IFAIL1.EQ.0)CALL INPMSG(II+1, 289 - - 'number of contour steps is < 1') 1 555 P=FIELD D=FLDPLT 4 PAGE 835 290 - IF(NCONTR.GT.MXWIRE.AND.IFAIL1.EQ.0)CALL INPMSG 291 - - (II+1,'may not exceed MXWIRE. ') 292 - IF(NCONTR.GE.1.AND.NCONTR.LE.MXWIRE)NCONT=NCONTR 293 - INEXT=II+2 294 - ENDIF 295 - * Otherwise skip to the next keyword. 296 - ELSE 297 - GOTO 20 298 - ENDIF 299 - 210 CONTINUE 300 - ** A SURFACE (3 dimensional plot) has perhaps been requested, 301 - ELSEIF(INPCMP(I,'S#URFACE').NE.0)THEN 302 - IF(LSURF)PRINT *,' !!!!!! FLDPLT WARNING : Only one'// 303 - - ' surface per PLOT statement can be processed.' 304 - LSURF=.TRUE. 305 - IF(FLAG(I+1))THEN 306 - FUNCT3(1:1)='V' 307 - NC3=1 308 - INEXT=I+1 309 - ELSE 310 - CALL INPSTR(I+1,I+1,STRING,NC3) 311 - FUNCT3(1:NC3)=STRING(1:NC3) 312 - INEXT=I+2 313 - ENDIF 314 - * Look for sub-keywords with SURFACE. 315 - DO 220 II=I,NWORD 316 - IF(II.LT.INEXT)GOTO 220 317 - * Look for the subkeyword ANGLE. 318 - IF(INPCMP(II,'A#NGLES').NE.0)THEN 319 - IF(.NOT.FLAG(II+1).AND.FLAG(II+2))THEN 320 - CALL INPMSG(II,'ANGLE has 2 args: theta, phi. ') 321 - CALL INPMSG(II+1,'See the previous message. ') 322 - INEXT=II+2 323 - ELSEIF(FLAG(II+1))THEN 324 - CALL INPMSG(II,'ANGLE has 2 args: theta, phi. ') 325 - INEXT=II+1 326 - ELSE 327 - CALL INPCHK(II+1,2,IFAIL1) 328 - CALL INPRDR(II+1,PHI,30.0) 329 - CALL INPCHK(II+2,2,IFAIL1) 330 - CALL INPRDR(II+2,THETA,60.0) 331 - INEXT=II+3 332 - ENDIF 333 - * Otherwise skip to the next keyword. 334 - ELSE 335 - GOTO 20 336 - ENDIF 337 - 220 CONTINUE 338 - ** The next plot might be a VECTOR plot, 339 - ELSEIF(INPCMP(I,'VE#CTOR').NE.0)THEN 340 - IF(LVECT)PRINT *,' !!!!!! FLDPLT WARNING : Only one'// 341 - - ' vector plot per PLOT statement can be processed.' 342 - LVECT=.TRUE. 343 - IF(FLAG(I+1).OR.FLAG(I+2))THEN 344 - IF(.NOT.POLAR)THEN 345 - FUNCT4(1:8)='EX,EY,EZ' 346 - NC4=8 347 - ELSE 348 - FUNCT4(1:10)='ER,EPHI,EZ' 349 - NC4=10 350 - ENDIF 351 - IF(.NOT.FLAG(I+1).AND.FLAG(I+2))THEN 352 - CALL INPSTR(I+1,I+1,STRING,NCAUX) 353 - IF(INDEX(STRING(1:NCAUX),'@').NE.0)THEN 354 - FUNCT4(1:1)='@' 355 - NC4=1 356 - ELSE 357 - CALL INPMSG(I+1, 358 - - 'Has 2 or 3 args, default used.') 359 - ENDIF 360 - INEXT=I+2 361 - ELSE 362 - INEXT=I+1 363 - ENDIF 364 - ELSE 365 - CALL INPSTR(I+1,I+1,STRING,NC4) 366 - FUNCT4(1:NC4+1)=STRING(1:NC4)//',' 367 - CALL INPSTR(I+2,I+2,STRING,NCAUX) 368 - FUNCT4(NC4+2:NC4+NCAUX+2)=STRING(1:NCAUX)//',' 369 - NC4=NC4+NCAUX+2 370 - IF(.NOT.FLAG(I+3))THEN 371 - CALL INPSTR(I+3,I+3,STRING,NCAUX) 372 - FUNCT4(NC4+1:NC4+NCAUX)=STRING(1:NCAUX) 373 - NC4=NC4+NCAUX 374 - INEXT=I+4 375 - ELSE 376 - FUNCT4(NC4+1:NC4+1)='0' 377 - NC4=NC4+1 378 - INEXT=I+3 379 - ENDIF 380 - ENDIF 381 - ** Finally, find out whether the next plot is a HISTOGRAM. 382 - ELSEIF(INPCMP(I,'H#ISTOGRAM').NE.0)THEN 383 - IF(LHIST)PRINT *,' !!!!!! FLDPLT WARNING : Only one'// 384 - - ' histogram per PLOT statement can be processed.' 385 - LHIST=.TRUE. 386 - IF(FLAG(I+1))THEN 387 - FUNCT5(1:1)='E' 388 - NC5=1 389 - HMIN=0.0 390 - HMAX=10000.0 391 - INEXT=I+1 392 - ELSE 393 - CALL INPSTR(I+1,I+1,STRING,NC5) 394 - FUNCT5(1:NC5)=STRING(1:NC5) 395 - INEXT=I+2 1 555 P=FIELD D=FLDPLT 5 PAGE 836 396 - ENDIF 397 - * Look for subkeywords associated with HISTOGRAM. 398 - DO 200 II=I,NWORD 399 - IF(II.LT.INEXT)GOTO 200 400 - * The RANGE subkeyword. 401 - IF(INPCMP(II,'RA#NGE').NE.0)THEN 402 - IF(INPCMP(II+1,'AUTO#MATIC').NE.0)THEN 403 - HMIN=0.0 404 - HMAX=0.0 405 - HAUTO=.TRUE. 406 - INEXT=II+2 407 - ELSEIF(.NOT.FLAG(II+1).AND..NOT.FLAG(II+2))THEN 408 - CALL INPCHK(II+1,2,IFAIL1) 409 - CALL INPCHK(II+2,2,IFAIL2) 410 - CALL INPRDR(II+1,HMINR,HMIN) 411 - CALL INPRDR(II+2,HMAXR,HMAX) 412 - HAUTO=.FALSE. 413 - IF(HMINR.EQ.HMAXR)THEN 414 - CALL INPMSG(II+1, 415 - - 'Zero range not permitted. ') 416 - CALL INPMSG(II+2, 417 - - 'See the previous message. ') 418 - ELSE 419 - HMIN=MIN(HMINR,HMAXR) 420 - HMAX=MAX(HMINR,HMAXR) 421 - ENDIF 422 - INEXT=II+3 423 - ELSE 424 - CALL INPMSG(II,'RANGE takes two arguments. ') 425 - IF(FLAG(II+1))THEN 426 - INEXT=II+1 427 - ELSE 428 - CALL INPMSG(II+1, 429 - - 'Ignored, see previous message.') 430 - INEXT=II+2 431 - ENDIF 432 - ENDIF 433 - * The BINS subkeyword. 434 - ELSEIF(INPCMP(II,'BI#NS').NE.0)THEN 435 - IF(FLAG(II+1))THEN 436 - CALL INPMSG(II,'This keyword has one argument.') 437 - INEXT=II+1 438 - ELSE 439 - CALL INPCHK(II+1,1,IFAIL) 440 - CALL INPRDI(II+1,NCHAR,MXCHA) 441 - IF(NCHAR.LE.1.OR.NCHAR.GT.MXCHA)THEN 442 - CALL INPMSG(II+1, 443 - - 'Inacceptable number of bins. ') 444 - ELSE 445 - NCHA=NCHAR 446 - ENDIF 447 - INEXT=II+2 448 - ENDIF 449 - * Otherwise quit this loop. 450 - ELSE 451 - GOTO 20 452 - ENDIF 453 - 200 CONTINUE 454 - ** Warn if the user aks for an unknown plot type or makes an error, 455 - ELSE 456 - CALL INPMSG(I,'Should have been a plot type. ') 457 - ENDIF 458 - 20 CONTINUE 459 - *** Next print the list of plots if the DEBUG option is on. 460 - IF(LDEBUG)THEN 461 - PRINT *,' ++++++ FLDPLT DEBUG : List of requested plots:' 462 - PRINT *,' Type Y/N ', 463 - - 'Function (1:20) NC <--------Range-------> ', 464 - - '# cont # bins <-------Angle-------->' 465 - IF(LGRAPH)THEN 466 - PRINT '(26X,A10,L2,3X,A20,2X,I2)', 467 - - 'Graph ',LGRAPH,FUNCT1(1:20),NC1 468 - ELSE 469 - PRINT '(26X,A10,L2)','Graph ',LGRAPH 470 - ENDIF 471 - IF(LCONT.AND..NOT.CAUTO)THEN 472 - PRINT '(26X,A7,3X,L2,3X,A20,1X,I3,2(2X,E10.3),2X,I6)', 473 - - 'Contour',LCONT,FUNCT2(1:20),NC2,CMIN,CMAX,NCONT 474 - ELSEIF(LCONT.AND.CAUTO)THEN 475 - PRINT '(26X,A7,3X,L2,3X,A20,1X,I3, 476 - - '' Automatic scaling'',2X,I6)', 477 - - 'Contour',LCONT,FUNCT2(1:20),NC2,NCONT 478 - ELSE 479 - PRINT '(26X,A10,L2)','Contour ',LCONT 480 - ENDIF 481 - IF(LSURF)THEN 482 - PRINT '(26X,A10,L2,3X,A20,1X,I3,40X,2(2X,E10.3))', 483 - - 'Surface ',LSURF,FUNCT3(1:20),NC3,PHI,THETA 484 - ELSE 485 - PRINT '(26X,A10,L2)','Surface ',LSURF 486 - ENDIF 487 - IF(LVECT)THEN 488 - PRINT '(26X,A10,L2,3X,A20,1X,I3)', 489 - - 'Vector ',LVECT ,FUNCT4(1:20),NC4 490 - ELSE 491 - PRINT '(26X,A10,L2)','Vector ',LVECT 492 - ENDIF 493 - IF(LHIST.AND..NOT.HAUTO)THEN 494 - PRINT '(26X,A10,L2,3X,A20,1X,I3,2(2X,E10.3),10X,I6)', 495 - - 'Histogram ',LHIST ,FUNCT5(1:20),NC5, 496 - - HMIN,HMAX,NCHA 497 - ELSEIF(LHIST)THEN 498 - PRINT '(26X,A10,L2,3X,A20,1X,I3, 499 - - '' Automatic scaling'',10X,I6)', 500 - - 'Histogram ',LHIST ,FUNCT5(1:20),NC5,NCHA 501 - ELSE 1 555 P=FIELD D=FLDPLT 6 PAGE 837 502 - PRINT '(26X,A10,L2)','Histogram ',LHIST 503 - ENDIF 504 - PRINT *,' ' 505 - ENDIF 506 - *** Take care of the 'GRAPH' type plots, translate curve function. 507 - IF(LGRAPH.AND.FUNTRA(1:NCFTRA).NE.'?')THEN 508 - CALL ALGPRE(FUNTRA,NCFTRA,VARLIS(13),1,NRES,USE(13), 509 - - IENTRA,IFAIL) 510 - IF(IFAIL.NE.0)THEN 511 - PRINT *,' !!!!!! FLDPLT WARNING : Graph not made'// 512 - - ' because of an error in the track function.' 513 - CALL ALGCLR(IENTRA) 514 - GOTO 101 515 - ELSEIF(NRES.NE.3)THEN 516 - PRINT *,' !!!!!! FLDPLT WARNING : Graph not made'// 517 - - ' because the curve does not give 3 results.' 518 - CALL ALGCLR(IENTRA) 519 - GOTO 101 520 - ELSEIF(.NOT.USE(13))THEN 521 - PRINT *,' !!!!!! FLDPLT WARNING : Graph not made'// 522 - - ' because the track does not depend on T.' 523 - CALL ALGCLR(IENTRA) 524 - GOTO 101 525 - ENDIF 526 - * If no curve is defined, the track must be. 527 - ELSEIF(LGRAPH.AND..NOT.TRFLAG(1))THEN 528 - PRINT *,' !!!!!! FLDPLT WARNING : Neither a track nor'// 529 - - ' a curve has been defined ; graph not made.' 530 - GOTO 101 531 - ENDIF 532 - ** Parameters look reasonable. 533 - IF(LGRAPH)THEN 534 - * Transform the function into an instruction list, 535 - IF(INDEX(FUNCT1(1:NC1),'@').NE.0)THEN 536 - NRES=1 537 - CALL ALGEDT(VARLIS,12,IENTRY,USE,NRES) 538 - FUNCT1='Edited function' 539 - NC1=15 540 - ELSE 541 - CALL ALGPRE(FUNCT1,NC1,VARLIS,12,NRES,USE,IENTRY,IFAIL) 542 - IF(IFAIL.NE.0)THEN 543 - PRINT *,' !!!!!! FLDPLT WARNING : Graph not'// 544 - - ' produced because of syntax errors.' 545 - GOTO 100 546 - ENDIF 547 - ENDIF 548 - * Figure out which quatities are effectively used. 549 - EVALE=.FALSE. 550 - EVALB=.FALSE. 551 - IOPT=0 552 - IF(USE(3).OR.USE(4).OR.USE(5).OR.USE(6).OR.USE(12)) 553 - - EVALE=.TRUE. 554 - IF(USE(7).OR.USE(8).OR.USE(9).OR.USE(10))EVALB=.TRUE. 555 - IF(USE(6))IOPT=1 556 - * Be sure only one result is returned. 557 - IF(NRES.NE.1)THEN 558 - PRINT *,' !!!!!! FLDPLT WARNING : The function'// 559 - - ' does not return precisely 1 result; no graph.' 560 - GOTO 100 561 - ENDIF 562 - * check the use of magnetic field quantities, 563 - IF(EVALB.AND..NOT.MAGOK)THEN 564 - PRINT *,' !!!!!! FLDPLT WARNING : The function to be'// 565 - - ' plotted uses magnetic field quantities,' 566 - PRINT *,' no such field has'// 567 - - ' been defined however ; plot not made.' 568 - GOTO 100 569 - ENDIF 570 - IF((USE(7).OR.USE(8)).AND.POLAR)THEN 571 - PRINT *,' !!!!!! FLDPLT WARNING : Bx and By should'// 572 - - ' not be used with polar cells ; plot not made.' 573 - GOTO 100 574 - ENDIF 575 - * Select the axis with the largest range for ordinate. 576 - IF(FUNTRA(1:NCFTRA).NE.'?')THEN 577 - ICOORD=3 578 - ELSEIF(POLAR)THEN 579 - CALL CFMCTP(XT0,YT0,RT0,PT0,1) 580 - CALL CFMCTP(XT1,YT1,RT1,PT1,1) 581 - IF((ZT1-ZT0)**2.GT.(XT1-XT0)**2+(YT1-YT0)**2)THEN 582 - ICOORD=11 583 - ELSEIF(ABS(RT0-RT1).GT.ABS(PT0-PT1))THEN 584 - ICOORD=1 585 - ELSE 586 - ICOORD=2 587 - ENDIF 588 - ELSE 589 - IF((ZT1-ZT0)**2.GT.(XT1-XT0)**2+(YT1-YT0)**2)THEN 590 - ICOORD=11 591 - ELSEIF(ABS(XT0-XT1).GT.ABS(YT0-YT1))THEN 592 - ICOORD=1 593 - ELSE 594 - ICOORD=2 595 - ENDIF 596 - ENDIF 597 - * Print a heading for the numbers. 598 - IF(FUNTRA(1:NCFTRA).EQ.'?')THEN 599 - IF(LGRPRT)WRITE(LUNOUT,'(/'' GRAPH OF '',A, 600 - - '' ON '',A//2X,''Coordinate'',48X,''Function'')') 601 - - FUNCT1(1:NC1),'THE TRACK' 602 - ELSE 603 - IF(LGRPRT)WRITE(LUNOUT,'(/'' GRAPH OF '',A, 604 - - '' ON '',A//2X,''Coordinate'',48X,''Function'')') 605 - - FUNCT1(1:NC1),FUNTRA(1:NCFTRA) 606 - ENDIF 607 - * fill the vectors, 1 555 P=FIELD D=FLDPLT 7 PAGE 838 608 - DO 30 I=1,NGRPNT 609 - IF(ICOORD.NE.3)THEN 610 - XPOS=XT0+REAL(I-1)*(XT1-XT0)/REAL(NGRPNT-1) 611 - YPOS=YT0+REAL(I-1)*(YT1-YT0)/REAL(NGRPNT-1) 612 - ZPOS=ZT0+REAL(I-1)*(ZT1-ZT0)/REAL(NGRPNT-1) 613 - IF(POLAR)CALL CFMCTR(XPOS,YPOS,XPOS,YPOS,1) 614 - ELSE 615 - VAR(1)=REAL(I-1)/REAL(NGRPNT-1) 616 - MODVAR(1)=2 617 - CALL ALGEXE(IENTRA,VAR,MODVAR,1,RES,MODRES,3,IFAIL) 618 - XPOS=RES(1) 619 - YPOS=RES(2) 620 - ZPOS=RES(3) 621 - IF(POLAR)CALL CFMPTR(XPOS,YPOS,XPOS,YPOS,1,IFAIL1) 622 - IF(IFAIL1.NE.0)THEN 623 - XPOS=1.0 624 - YPOS=0.0 625 - ZPOS=0.0 626 - PRINT *,' !!!!!! FLDPLT WARNING : The curve'// 627 - - ' function returns invalid coordinates.' 628 - ENDIF 629 - ENDIF 630 - VAR(1)=XPOS 631 - VAR(2)=YPOS 632 - VAR(11)=ZPOS 633 - IF(EVALE)CALL EFIELD(VAR(1),VAR(2),VAR(11), 634 - - VAR(3),VAR(4),VAR(12),VAR(5),VAR(6),IOPT,ILOC) 635 - IF(EVALB)CALL BFIELD(VAR(1),VAR(2),VAR(11), 636 - - VAR(7),VAR(8),VAR(9),VAR(10)) 637 - IF(POLAR)THEN 638 - CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) 639 - VAR(3)=VAR(3)/VAR(1) 640 - VAR(4)=VAR(4)/VAR(1) 641 - VAR(5)=VAR(5)/VAR(1) 642 - ENDIF 643 - DO 35 II=1,12 644 - MODVAR(II)=2 645 - 35 CONTINUE 646 - CALL ALGEXE(IENTRY,VAR,MODVAR,12,RES,MODRES,1,IFAIL) 647 - IF(ICOORD.EQ.3)THEN 648 - COORD(I)=REAL(I-1)/REAL(NGRPNT-1) 649 - ELSE 650 - COORD(I)=VAR(ICOORD) 651 - ENDIF 652 - VALUE(I)=RES(1) 653 - * Print the point if this has been requested. 654 - IF(LGRPRT)WRITE(LUNOUT,'(4(2X,E15.8))') 655 - - XPOS,YPOS,ZPOS,VALUE(I) 656 - 30 CONTINUE 657 - * Plot the graph. 658 - IF(GRSMIN.LT.GRSMAX)CALL GRGRSC(GRSMIN,GRSMAX) 659 - IF(ICOORD.EQ.3)THEN 660 - CALL GRGRPH(COORD,VALUE,NGRPNT,'Curve parameter', 661 - - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), 662 - - 'GRAPH OF '//FUNCT1(1:31)) 663 - ELSEIF(POLAR.AND.ICOORD.EQ.1)THEN 664 - CALL GRGRPH(COORD,VALUE,NGRPNT,'Radius [cm]', 665 - - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), 666 - - 'Graph of '//FUNCT1(1:31)) 667 - ELSEIF(POLAR.AND.ICOORD.EQ.2)THEN 668 - CALL GRGRPH(COORD,VALUE,NGRPNT,'Angle [degrees]', 669 - - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), 670 - - 'Graph of '//FUNCT1(1:31)) 671 - ELSEIF(ICOORD.EQ.1)THEN 672 - CALL GRGRPH(COORD,VALUE,NGRPNT,'x-Axis [cm]', 673 - - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), 674 - - 'Graph of '//FUNCT1(1:31)) 675 - ELSEIF(ICOORD.EQ.2)THEN 676 - CALL GRGRPH(COORD,VALUE,NGRPNT,'y-Axis [cm]', 677 - - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), 678 - - 'Graph of '//FUNCT1(1:31)) 679 - ELSEIF(ICOORD.EQ.11)THEN 680 - CALL GRGRPH(COORD,VALUE,NGRPNT,'z-Axis [cm]', 681 - - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), 682 - - 'Graph of '//FUNCT1(1:31)) 683 - ELSE 684 - PRINT *,' ###### FLDPLT ERROR : Inconsistent axis'// 685 - - ' selection ; program bug - please report.' 686 - ENDIF 687 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 688 - * Log this frame and prepare for the next plot. 689 - CALL GRNEXT 690 - CALL GRALOG('Graph of '//FUNCT1(1:31)) 691 - CALL TIMLOG('Plotting the graph of '//FUNCT1(1:18)) 692 - * print the number of arithmetic errors. 693 - CALL ALGERR 694 - 100 CONTINUE 695 - * Release the entry point. 696 - CALL ALGCLR(IENTRY) 697 - IF(FUNTRA(1:NCFTRA).NE.'?')CALL ALGCLR(IENTRA) 698 - ENDIF 699 - * Continue here if the parameters were not acceptable. 700 - 101 CONTINUE 701 - *** Take care of the contours. 702 - IF(LCONT)THEN 703 - * Convert to an instruction list, 704 - IF(INDEX(FUNCT2(1:NC2),'@').NE.0)THEN 705 - NRES=1 706 - CALL ALGEDT(VARLIS,12,IENCON,USE,NRES) 707 - FUNCT2='Edited function' 708 - NC2=15 709 - ELSE 710 - CALL ALGPRE(FUNCT2,NC2,VARLIS,12,NRES,USE,IENCON,IFAIL) 711 - IF(IFAIL.NE.0)THEN 712 - PRINT *,' !!!!!! FLDPLT WARNING : No contour'// 713 - - ' plot because of function syntax errors.' 1 555 P=FIELD D=FLDPLT 8 PAGE 839 714 - GOTO 110 715 - ENDIF 716 - ENDIF 717 - * Be sure only one result is returned. 718 - IF(NRES.NE.1)THEN 719 - PRINT *,' !!!!!! FLDPLT WARNING : The function does'// 720 - - ' not return precisely 1 result; no contour.' 721 - GOTO 110 722 - ENDIF 723 - * Figure out which quantities are effectively used. 724 - EVALE=.FALSE. 725 - EVALB=.FALSE. 726 - IOPT=0 727 - IF(USE(3).OR.USE(4).OR.USE(5).OR.USE(6).OR.USE(12)) 728 - - EVALE=.TRUE. 729 - IF(USE(7).OR.USE(8).OR.USE(9).OR.USE(10))EVALB=.TRUE. 730 - IF(USE(6))IOPT=1 731 - * Check the use of magnetic field quantities. 732 - IF(EVALB.AND..NOT.MAGOK)THEN 733 - PRINT *,' !!!!!! FLDPLT WARNING : The function to be'// 734 - - ' plotted uses magnetic field quantities,' 735 - PRINT *,' no such field has'// 736 - - ' been defined however ; plot not made.' 737 - GOTO 110 738 - ENDIF 739 - IF((USE(7).OR.USE(8)).AND.POLAR)THEN 740 - PRINT *,' !!!!!! FLDPLT WARNING : Bx and By should'// 741 - - ' not be used with polar cells ; plot not made.' 742 - GOTO 110 743 - ENDIF 744 - * Plot the contours. 745 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 746 - - 'Contours of '//FUNCT2(1:NC2)) 747 - NCONTP=NCONT 748 - CALL GRCONT(FCONT,CMIN,CMAX,VXMIN,VYMIN,VXMAX,VYMAX, 749 - - NCONTP,CAUTO,POLAR,CLAB) 750 - CALL GRNEXT 751 - * Print the table of contour heights. 752 - CALL OUTFMT(CMIN,2,AUX1,NCAUX1,'LEFT') 753 - CALL OUTFMT(CMAX,2,AUX2,NCAUX2,'LEFT') 754 - CALL OUTFMT(REAL(NCONTP),2,AUX3,NCAUX3,'LEFT') 755 - CALL OUTFMT((CMAX-CMIN)/REAL(MAX(1,NCONTP)),2, 756 - - AUX4,NCAUX4,'LEFT') 757 - IF(NCONTP.GE.1)WRITE(LUNOUT,'(/'' The contours'', 758 - - '' correspond to '',A,'' = '',A,'' to '',A, 759 - - '' in '',A,'' steps.''/'' The interval between 2'', 760 - - '' contours is '',A,''.'')') 761 - - FUNCT2(1:NC2),AUX1(1:NCAUX1),AUX2(1:NCAUX2), 762 - - AUX3(1:NCAUX3),AUX4(1:NCAUX4) 763 - IF(NCONTP.EQ.0)WRITE(LUNOUT,'(/'' The contour'', 764 - - '' corresponds to '',A,'' = '',A,''.'')') 765 - - FUNCT2(1:NC2),AUX1(1:NCAUX1) 766 - * Keep track of the plots being made. 767 - CALL GRALOG('Contours of '//FUNCT2(1:NC2)//':') 768 - CALL TIMLOG('Plotting contours of '//FUNCT2(1:NC2)//':') 769 - * Print the number of arithmetic errors. 770 - CALL ALGERR 771 - 110 CONTINUE 772 - CALL ALGCLR(IENCON) 773 - ENDIF 774 - *** If one of the other plots is asked for, prepare the function string. 775 - IF(LHIST.OR.LSURF.OR.LVECT)THEN 776 - NCTOT=0 777 - IF(LSURF)THEN 778 - ISURF=1 779 - FUNCT1(1:NC3)=FUNCT3(1:NC3) 780 - NCTOT=NC3 781 - ENDIF 782 - IF(LVECT)THEN 783 - IF(LSURF)THEN 784 - IVECT1=2 785 - IVECT2=3 786 - IVECT3=4 787 - FUNCT1(NCTOT+1:NCTOT+NC4+1)=','//FUNCT4(1:NC4) 788 - NCTOT=NCTOT+NC4+1 789 - ELSE 790 - IVECT1=1 791 - IVECT2=2 792 - IVECT3=3 793 - FUNCT1(1:NC4)=FUNCT4(1:NC4) 794 - NCTOT=NC4 795 - ENDIF 796 - ENDIF 797 - IF(LHIST)THEN 798 - IF(LSURF.OR.LVECT)THEN 799 - IF(LSURF.AND..NOT.LVECT)IHIST=2 800 - IF(LVECT.AND..NOT.LSURF)IHIST=4 801 - IF(LSURF.AND. LVECT)IHIST=5 802 - FUNCT1(NCTOT+1:NCTOT+NC5+1)=','//FUNCT5(1:NC5) 803 - NCTOT=NCTOT+NC5+1 804 - ELSE 805 - IHIST=1 806 - FUNCT1(1:NC5)=FUNCT5(1:NC5) 807 - NCTOT=NC5 808 - ENDIF 809 - ENDIF 810 - * Turn it into an instruction list, 811 - NREXP=0 812 - IF(LHIST)NREXP=NREXP+1 813 - IF(LSURF)NREXP=NREXP+1 814 - IF(LVECT)NREXP=NREXP+3 815 - IF(INDEX(FUNCT1(1:NCTOT),'@').NE.0)THEN 816 - NRES=NREXP 817 - CALL ALGEDT(VARLIS,12,IENTRY,USE,NRES) 818 - FUNCT1='Edited function' 819 - NCTOT=15 1 555 P=FIELD D=FLDPLT 9 PAGE 840 820 - ELSE 821 - CALL ALGPRE(FUNCT1,NCTOT,VARLIS,12,NRES,USE,IENTRY, 822 - - IFAIL) 823 - IF(IFAIL.NE.0)THEN 824 - PRINT *,' !!!!!! FLDPLT WARNING : Plots not'// 825 - - ' produced because of syntax errors.' 826 - GOTO 120 827 - ENDIF 828 - ENDIF 829 - * Be sure only one result is returned. 830 - IF(NRES.NE.NREXP)THEN 831 - PRINT *,' !!!!!! FLDPLT WARNING : The function does'// 832 - - ' not return the correct number of results;'// 833 - - ' histogram, surface and vector plot skipped.' 834 - GOTO 120 835 - ENDIF 836 - * Figure out which quantities are effectively used. 837 - EVALE=.FALSE. 838 - EVALB=.FALSE. 839 - IOPT=0 840 - IF(USE(3).OR.USE(4).OR.USE(5).OR.USE(6).OR.USE(12)) 841 - - EVALE=.TRUE. 842 - IF(USE(7).OR.USE(8).OR.USE(9).OR.USE(10))EVALB=.TRUE. 843 - IF(USE(6))IOPT=1 844 - * check the use of magnetic field quantities, 845 - IF(EVALB.AND..NOT.MAGOK)THEN 846 - PRINT *,' !!!!!! FLDPLT WARNING : The function to be'// 847 - - ' plotted uses magnetic field quantities,' 848 - PRINT *,' no such field has'// 849 - - ' been defined however ; plot not made.' 850 - GOTO 120 851 - ENDIF 852 - IF((USE(7).OR.USE(8)).AND.POLAR)THEN 853 - PRINT *,' !!!!!! FLDPLT WARNING : Bx and By should'// 854 - - ' not be used with polar cells ; plot not made.' 855 - GOTO 120 856 - ENDIF 0 857-+ +SELF,IF=NAG,HIGZ. 858 - * Obtain the matrix for surface plotting. 859 - IF(LSURF)THEN 860 - CALL BOOK('BOOK','MATRIX','SURFACE',IFAIL) 861 - IF(IFAIL.NE.0)THEN 862 - PRINT *,' !!!!!! FLDPLT WARNING : Unable to'// 863 - - ' obtain storage for the surface plot.' 864 - PRINT *,' The plot'// 865 - - ' will not be made.' 866 - LSURF=.FALSE. 867 - ENDIF 868 - ENDIF 0 869-+ +SELF. 870 - * Open a plotting frame for a VECTOR plot, if requested. 871 - IF(LVECT)THEN 872 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 873 - - 'Vector plot of '//FUNCT4(1:NC4)) 874 - CALL GRALOG('Vector plot of '//FUNCT4(1:NC4)//':') 875 - * Otherwise, merely request the viewing area. 876 - ELSE 877 - CALL GRVIEW(VXMIN,VYMIN,VXMAX,VYMAX) 878 - ENDIF 879 - * Allocate an histogram, if needed. 880 - IF(LHIST)THEN 881 - CALL HISADM('ALLOCATE',IHISRF,NCHA,HMIN,HMAX, 882 - - HAUTO,IFAIL) 883 - IF(IFAIL.NE.0)THEN 884 - PRINT *,' !!!!!! FLDPLT WARNING : Unable to'// 885 - - ' allocate histogram storage; histogram'// 886 - - ' cancelled.' 887 - LHIST=.FALSE. 888 - ENDIF 889 - ENDIF 890 - * Fill all the arrays and matrices required for these plots. 891 - CALL GRATTS('FUNCTION-1','POLYLINE') 892 - DO 50 I=1,NGRIDX 893 - IF(.NOT.POLAR)THEN 894 - XXPOS=VXMIN+REAL(I-1)*(VXMAX-VXMIN)/REAL(NGRIDX-1) 895 - ELSE 896 - XXPOS=LOG(EXP(VXMIN)+REAL(I-1)*(EXP(VXMAX)-EXP(VXMIN))/ 897 - - REAL(NGRIDX-1)) 898 - ENDIF 899 - * set a normalisation factor, to get the arrows more or less right 900 - IF(.NOT.POLAR)THEN 901 - FACNRM=MIN(VYMAX-VYMIN,VXMAX-VXMIN)/REAL(NGRIDX) 902 - ELSE 903 - FACNRM=LOG((EXP(VXMIN)+REAL(I-1)*(EXP(VXMAX)- 904 - - EXP(VXMIN))/REAL(NGRIDX))/(EXP(VXMIN)+REAL(I)* 905 - - (EXP(VXMAX)-EXP(VXMIN))/REAL(NGRIDX))) 906 - ENDIF 907 - DO 60 J=1,NGRIDY 908 - YYPOS=VYMIN+REAL(J-1)*(VYMAX-VYMIN)/REAL(NGRIDY-1) 909 - * Coordinate transformation to the viewing plane. 910 - XPOS=FPROJ(1,1)*XXPOS+FPROJ(2,1)*YYPOS+FPROJ(3,1) 911 - YPOS=FPROJ(1,2)*XXPOS+FPROJ(2,2)*YYPOS+FPROJ(3,2) 912 - ZPOS=FPROJ(1,3)*XXPOS+FPROJ(2,3)*YYPOS+FPROJ(3,3) 913 - IF(XPOS.LT.PXMIN.OR.XPOS.GT.PXMAX.OR. 914 - - YPOS.LT.PYMIN.OR.YPOS.GT.PYMAX.OR. 915 - - ZPOS.LT.PZMIN.OR.ZPOS.GT.PZMAX)THEN 0 916-+ +SELF,IF=NAG,HIGZ. 917 - IF(LSURF)WS(I,J)=0.0 1 555 P=FIELD D=FLDPLT 10 PAGE 841 918-+ +SELF. 919 - GOTO 60 920 - ENDIF 921 - * Evaluate field. 922 - IF(EVALE)CALL EFIELD(XPOS,YPOS,ZPOS, 923 - - VAR(3),VAR(4),VAR(12),VAR(5),VAR(6),IOPT,ILOC) 924 - IF(EVALB)CALL BFIELD(XPOS,YPOS,ZPOS, 925 - - VAR(7),VAR(8),VAR(9),VAR(10)) 926 - IF(POLAR)THEN 927 - CALL CFMRTP(XPOS,YPOS,VAR(1),VAR(2),1) 928 - VAR(3)=VAR(3)/VAR(1) 929 - VAR(4)=VAR(4)/VAR(1) 930 - VAR(5)=VAR(5)/VAR(1) 931 - ELSE 932 - VAR(1)=XPOS 933 - VAR(2)=YPOS 934 - ENDIF 935 - VAR(11)=ZPOS 936 - DO 65 II=1,12 937 - MODVAR(II)=2 938 - 65 CONTINUE 939 - CALL ALGEXE(IENTRY,VAR,MODVAR,12,RES,MODRES,5,IFAIL) 940 - IF(LVECT)THEN 941 - IF(RES(IVECT1)**2+RES(IVECT2)**2+RES(IVECT3)**2.GT.0) 942 - - CALL PLAARR(XPOS,YPOS,ZPOS, 943 - - 0.5*FACNRM*RES(IVECT1)/SQRT(RES(IVECT1)**2+ 944 - - RES(IVECT2)**2+RES(IVECT3)**2), 945 - - 0.5*FACNRM*RES(IVECT2)/SQRT(RES(IVECT1)**2+ 946 - - RES(IVECT2)**2+RES(IVECT3)**2), 947 - - 0.5*FACNRM*RES(IVECT3)/SQRT(RES(IVECT1)**2+ 948 - - RES(IVECT2)**2+RES(IVECT3)**2)) 949 - ENDIF 0 950-+ +SELF,IF=NAG,HIGZ. 951 - IF(LSURF)WS(I,J)=RES(ISURF) 0 952-+ +SELF. 953 - * fill the histogram, if requested, 954 - IF(LHIST)CALL HISENT(IHISRF,RES(IHIST),1.0) 955 - 60 CONTINUE 956 - 50 CONTINUE 957 - CALL TIMLOG('Accumulating plot data on the grid: ') 958 - IF(LVECT)CALL GRNEXT 959 - * plot the 3-dimensional picture if requested 960 - IF(LSURF)THEN 0 961-+ +SELF,IF=NAG. 962 - * Check that the surface is not flat. 963 - IFLAT=1 964 - DO 80 ICHK=1,NGRIDX 965 - DO 70 JCHK=1,NGRIDY 966 - IF(ABS(WS(ICHK,JCHK)-WS(1,1)).GT.1.0E-5* 967 - - (1.0+ABS(WS(ICHK,JCHK))+ABS(WS(1,1))))IFLAT=0 968 - 70 CONTINUE 969 - 80 CONTINUE 970 - IF(IFLAT.NE.0)THEN 971 - PRINT *,' !!!!!! FLDPLT WARNING : The surface is', 972 - - ' not plotted because it is entirely flat.' 973 - CALL BOOK('RELEASE','MATRIX','SURFACE',IFAIL) 974 - GOTO 90 975 - ENDIF 976 - * Switch the screen to graphics mode. 977 - CALL GRGRAF(.TRUE.) 978 - * Store the CH eXPansion, NAG has the nasty habit of changing it. 979 - CALL GQCHXP(IERR,CHEXP) 980 - IF(IERR.NE.0)CHEXP=1.0 981 - * Initialize NAG. 982 - CALL X04AAF(1,10) 983 - CALL J06WAF 984 - CALL J06WCF(0.1D0,0.9D0,0.1D0,0.9D0) 985 - CALL J06WBF(0.0D0,1.0D0,0.0D0,1.0D0,1) 986 - IFAIL=0 987 - IF(POLAR)THEN 988 - CALL J06HCF(WS,MXWIRE,NGRIDX,NGRIDY,DBLE(THETA), 989 - - DBLE(PHI),'Along a radius', 990 - - 'Increasing angle',IFAIL) 991 - ELSE 992 - CALL J06HCF(WS,MXWIRE,NGRIDX,NGRIDY,DBLE(THETA), 993 - - DBLE(PHI),'u-axis','v-axis',IFAIL) 994 - ENDIF 995 - CALL GRNEXT 996 - * Reset the CH eXPension factor to the original value, 997 - CALL GSCHXP(CHEXP) 998 - CALL TIMLOG('Making a 3-dimensional plot: ') 999 - CALL GRALOG('3-D plot of '//FUNCT3(1:28)) 1000 - * Release the matrix. 1001 - CALL BOOK('RELEASE','MATRIX','SURFACE',IFAIL) 0 1002-+ +SELF,IF=HIGZ. 1003 - * Check that the surface is not flat. 1004 - IFLAT=1 1005 - SMIN=WS(1,1) 1006 - SMAX=WS(1,1) 1007 - DO 80 ICHK=1,NGRIDX 1008 - DO 70 JCHK=1,NGRIDY 1009 - IF(ABS(WS(ICHK,JCHK)-WS(1,1)).GT.1.0E-5* 1010 - - (1.0+ABS(WS(ICHK,JCHK))+ABS(WS(1,1))))IFLAT=0 1011 - SMIN=MIN(SMIN,WS(1,1)) 1012 - SMAX=MAX(SMAX,WS(1,1)) 1013 - 70 CONTINUE 1014 - 80 CONTINUE 1015 - IF(IFLAT.NE.0)THEN 1016 - PRINT *,' !!!!!! FLDPLT WARNING : The surface is', 1017 - - ' not plotted because it is entirely flat.' 1018 - CALL BOOK('RELEASE','MATRIX','SURFACE',IFAIL) 1019 - GOTO 90 1 555 P=FIELD D=FLDPLT 11 PAGE 842 1020 - ENDIF 1021 - * Switch the screen to graphics mode. 1022 - CALL GRGRAF(.TRUE.) 1023 - * Fill the PAR vector. 1024 - PAR(1)=THETA 1025 - PAR(2)=PHI 1026 - PAR(3)=VXMIN-0.5*(VXMAX-VXMIN)/REAL(NGRIDX-1) 1027 - PAR(4)=VXMAX+0.5*(VXMAX-VXMIN)/REAL(NGRIDX-1) 1028 - PAR(5)=VYMIN-0.5*(VYMAX-VYMIN)/REAL(NGRIDY-1) 1029 - PAR(6)=VYMAX+0.5*(VYMAX-VYMIN)/REAL(NGRIDY-1) 1030 - PAR(7)=SMIN 1031 - PAR(8)=SMAX 1032 - PAR(9)=1000+NGRIDX 1033 - PAR(10)=1000+NGRIDY 1034 - PAR(11)=510 1035 - PAR(12)=510 1036 - PAR(13)=510 1037 - PAR(14)=1 1038 - PAR(15)=1 1039 - PAR(16)=1 1040 - PAR(17)=0.02 1041 - PAR(18)=0.02 1042 - PAR(19)=0.02 1043 - PAR(20)=0.03 1044 - PAR(21)=2 1045 - PAR(22)=0.03 1046 - PAR(23)=0.03 1047 - PAR(24)=0.03 1048 - PAR(25)=7 1049 - PAR(26)=8 1050 - PAR(27)=9 1051 - PAR(28)=10 1052 - PAR(29)=11 1053 - PAR(30)=12 1054 - PAR(31)=13 1055 - PAR(32)=14 1056 - PAR(33)=15 1057 - PAR(34)=16 1058 - PAR(35)=17 1059 - PAR(36)=18 1060 - PAR(37)=19 1061 - * Plot the surface. 1062 - CALL ISVP(1,0.1,0.9,0.1,0.9) 1063 - CALL ISWN(1,0.0,1.0,0.0,1.0) 1064 - CALL ISELNT(1) 1065 - CALL IGTABL(MXWIRE,MXWIRE,WS,37,PAR,'S1') 1066 - * Close the plot. 1067 - CALL GRNEXT 1068 - * Record what happened. 1069 - CALL TIMLOG('Making a 3-dimensional plot: ') 1070 - CALL GRALOG('3-D plot of '//FUNCT3(1:28)) 1071 - * Release the matrix. 1072 - CALL BOOK('RELEASE','MATRIX','SURFACE',IFAIL) 0 1073-+ +SELF,IF=-NAG,IF=-HIGZ. 1074 - * No graphics system present to plot the surface. 1075 - PRINT *,' !!!!!! FLDPLT WARNING : The plotting system', 1076 - - ' used for this module has no SURFACE facilities.' 0 1077-+ +SELF. 1078 - 90 CONTINUE 1079 - ENDIF 1080 - * plot the histogram if requested, delete after use. 1081 - IF(LHIST)THEN 1082 - CALL HISPLT(IHISRF,FUNCT5(1:NC5), 1083 - - 'Histogram of '//FUNCT5(1:NC5),.TRUE.) 1084 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 1085 - CALL GRNEXT 1086 - CALL GRALOG('Histogram of '//FUNCT5(1:NC5)//':') 1087 - CALL TIMLOG('Plotting an histogram of '// 1088 - - FUNCT5(1:NC5)//':') 1089 - CALL HISADM('DELETE',IHISRF,0,0.0,0.0,.FALSE.,IFAIL) 1090 - ENDIF 1091 - * print the number of arithmetic errors. 1092 - CALL ALGERR 1093 - 120 CONTINUE 1094 - * release the algebra storage. 1095 - CALL ALGCLR(IENTRY) 1096 - ENDIF 1097 - END 556 GARFIELD ================================================== P=FIELD D=FCONT 1 ============================ 0 + +DECK,FCONT. 1 - SUBROUTINE FCONT(X0,Y0,FVAL,ILOC) 2 - *----------------------------------------------------------------------- 3 - * FCONT - Returns the function value of to the contour routine 4 - * (Last changed on 19/10/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,PARAMETERS. 10.- +SEQ,CONTDATA. 11.- +SEQ,PRINTPLOT. 12 - REAL RES(1),VAR(MXVAR),X0,Y0,FVAL 13 - INTEGER MODRES(1),MODVAR(MXVAR),ILOC,I,IFAIL 14 - LOGICAL EVALE,EVALB 15 - INTEGER IOPT,IENCON 16 - COMMON /CNTDAT/ IOPT,IENCON,EVALE,EVALB 17 - *** Return if we're far out the boundaries. 18 - IF(X0.LT.2*CXMIN-CXMAX.OR.X0.GT.2*CXMAX-CXMIN.OR. 19 - - Y0.LT.2*CYMIN-CYMAX.OR.Y0.GT.2*CYMAX-CYMIN)THEN 20 - FVAL=0.0 21 - ILOC=-4 22 - RETURN 1 556 P=FIELD D=FCONT 2 PAGE 843 23 - ENDIF 24 - *** Ensure the location code is defined, also if EVALE is false. 25 - ILOC=0 26 - *** Copy the positions into the algebra buffer. 27 - VAR(1)= FPROJ(1,1)*X0+FPROJ(2,1)*Y0+FPROJ(3,1) 28 - VAR(2)= FPROJ(1,2)*X0+FPROJ(2,2)*Y0+FPROJ(3,2) 29 - VAR(11)=FPROJ(1,3)*X0+FPROJ(2,3)*Y0+FPROJ(3,3) 30 - *** Check the location - could be outside volume for 3D plots. 31 - IF(VAR(1).LT.PXMIN.OR.VAR(1).GT.PXMAX.OR. 32 - - VAR(2).LT.PYMIN.OR.VAR(2).GT.PYMAX.OR. 33 - - VAR(11).LT.PZMIN.OR.VAR(11).GT.PZMAX)THEN 34 - ILOC=-4 35 - RETURN 36 - ENDIF 37 - *** Calculate the field, 38 - IF(EVALE)CALL EFIELD(VAR(1),VAR(2),VAR(11), 39 - - VAR(3),VAR(4),VAR(12),VAR(5),VAR(6),IOPT,ILOC) 40 - IF(EVALB)CALL BFIELD(VAR(1),VAR(2),VAR(11), 41 - - VAR(7),VAR(8),VAR(9),VAR(10)) 42 - * Location code -5 (in a material) is acceptable for contours. 43 - IF(ILOC.EQ.-5.AND.LCNTAM)ILOC=0 44 - * evaluate the function, 45 - IF(POLAR)THEN 46 - VAR(3)=VAR(3)/EXP(VAR(1)) 47 - VAR(4)=VAR(4)/EXP(VAR(1)) 48 - VAR(5)=VAR(5)/EXP(VAR(1)) 49 - ENDIF 50 - * assign modes. 51 - DO 10 I=1,12 52 - MODVAR(I)=2 53 - 10 CONTINUE 54 - * evaluate function. 55 - CALL ALGEXE(IENCON,VAR,MODVAR,12,RES,MODRES,1,IFAIL) 56 - * and return it to the contour routine. 57 - FVAL=RES(1) 58 - END 557 GARFIELD ================================================== P=FIELD D=FLDPRT 1 ============================ 0 + +DECK,FLDPRT. 1 - SUBROUTINE FLDPRT 2 - *----------------------------------------------------------------------- 3 - * FLDPRT - Subroutine printing any function of the electric field, the 4 - * the potential and the magnetic field on a grid of GRID **2 5 - * points in the area (PXMIN,PYMIN) (PXMAX,PYMAX). This 6 - * routine will not work for mappings other than polar. 7 - * VARIABLES : VECTOR : vector to be printed. 8 - * FUNCT, NF : string (and length) of the function. 9 - * USE : .TRUE. if the corresponding var is used. 10 - * EVALE, EVALB : .TRUE. if E resp B is used. 11 - *----------------------------------------------------------------------- 12.- +SEQ,DIMENSIONS. 13.- +SEQ,CONSTANTS. 14.- +SEQ,CELLDATA. 15.- +SEQ,PARAMETERS. 16.- +SEQ,PRINTPLOT. 17.- +SEQ,BFIELD. 18 - CHARACTER*10 VARLIS(MXVAR) 19 - CHARACTER*(MXCHAR) FUNCT,STRING 20 - REAL VECTOR(4,10),VAR(MXVAR) 21 - INTEGER MODVAR(MXVAR),MODRES(4) 22 - DOUBLE PRECISION SUMFLD(4) 23 - LOGICAL USE(MXVAR),EVALE,EVALB 0 24-+ +SELF,IF=SAVE. 25 - SAVE VARLIS 0 26-+ +SELF. 27 - DATA (VARLIS(I),I=5,10)/'E ','V ','BX ', 28 - - 'BY ','BZ ','B '/ 29 - *** Identify the routine. 30 - IF(LIDENT)PRINT *,' /// ROUTINE FLDPRT ///' 31 - *** Make sure the variables have appropriate names. 32 - IF(POLAR)THEN 33 - VARLIS(1)='R ' 34 - VARLIS(2)='PHI ' 35 - VARLIS(3)='ER ' 36 - VARLIS(4)='EPHI ' 37 - ELSE 38 - VARLIS(1)='X ' 39 - VARLIS(2)='Y ' 40 - VARLIS(3)='EX ' 41 - VARLIS(4)='EY ' 42 - ENDIF 43 - *** Get the number of words in the input string 44 - CALL INPNUM(NWORD) 45 - * Warn if the function is absent. 46 - IF(NWORD.EQ.1)THEN 47 - PRINT *,' !!!!!! FLDPRT WARNING : To obtain a table, a'// 48 - - ' (list of) function(s) should be given as argument.' 49 - RETURN 50 - ENDIF 51 - * Loop over the input string 52 - DO 70 IW=1,NWORD-1,4 53 - * Extract the function. 54 - NF=1 55 - FUNCT=' ' 56 - DO 10 JW=1,4 57 - IF(IW+JW.GT.NWORD)GOTO 10 58 - CALL INPSTR(IW+JW,IW+JW,STRING,NC) 59 - FUNCT(NF:NF+NC)=STRING(1:NC)//',' 60 - NF=NF+NC+1 61 - 10 CONTINUE 62 - FUNCT(NF-1:NF-1)=' ' 63 - NF=NF-2 64 - IF(NF.EQ.0)GOTO 70 1 557 P=FIELD D=FLDPRT 2 PAGE 844 65 - * Convert into an instruction list. 66 - IF(INDEX(FUNCT,'@').NE.0)THEN 67 - NRES=0 68 - CALL ALGEDT(VARLIS,10,IENTRY,USE,NRES) 69 - FUNCT='Edited function' 70 - NF=15 71 - IF(NRES.LE.0)THEN 72 - PRINT *,' !!!!!! FLDPRT WARNING : The edited'// 73 - - ' instruction list does not return results;'// 74 - - ' no printout.' 75 - GOTO 70 76 - ENDIF 77 - ELSE 78 - CALL ALGPRE(FUNCT,NF,VARLIS,10,NRES,USE,IENTRY,IFAIL) 79 - IF(IFAIL.NE.0)THEN 80 - PRINT *,' !!!!!! FLDPRT WARNING : Table of '// 81 - - FUNCT(1:NF)//' not printed because of'// 82 - - ' syntax error(s) in one of the functions.' 83 - GOTO 70 84 - ENDIF 85 - ENDIF 86 - * Determine which quantities are going to be used. 87 - EVALE=.FALSE. 88 - EVALB=.FALSE. 89 - IOPT=0 90 - IF(USE(3).OR.USE(4).OR.USE(5).OR.USE(6))EVALE=.TRUE. 91 - IF(USE(7).OR.USE(8).OR.USE(9).OR.USE(10))EVALB=.TRUE. 92 - IF(USE(6))IOPT=1 93 - * Make sure the function does not use B if MAGOK is .FALSE.. 94 - IF(EVALB.AND..NOT.MAGOK)THEN 95 - PRINT *,' !!!!!! FLDPRT WARNING : A magnetic field'// 96 - - ' quantity is used in '//FUNCT(1:NF) 97 - PRINT *,' no such field has'// 98 - - ' been defined however ; table not printed.' 99 - GOTO 70 100 - ENDIF 101 - *** Print a header for the table. 102 - WRITE(LUNOUT,'(''1 Printed table of the field''/ 103 - - '' ==========================''//)',IOSTAT=IOS,ERR=2010) 104 - WRITE(LUNOUT,'(A)',IOSTAT=IOS,ERR=2010) 105 - - ' Function being printed: '//FUNCT(1:NF) 106 - WRITE(LUNOUT,'(A55)',IOSTAT=IOS,ERR=2010) 107 - - ' where the symbolic variables stand for the following:' 108 - IF(USE(1).AND..NOT.POLAR) 109 - - WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) 110 - - ' X = x-coordinate [cm]' 111 - IF(USE(1).AND.POLAR) 112 - - WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) 113 - - ' R = radial coordinate [cm]' 114 - IF(USE(2).AND..NOT.POLAR) 115 - - WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) 116 - - ' Y = y-coordinate [cm]' 117 - IF(USE(2).AND.POLAR) 118 - - WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) 119 - - ' PHI = angular coordinate [degree]' 120 - IF(USE(3).AND..NOT.POLAR) 121 - - WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) 122 - - ' EX = x-component of the electric field [V/cm]' 123 - IF(USE(3).AND.POLAR) 124 - - WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) 125 - - ' ER = radial component of the electric field [V/cm]' 126 - IF(USE(4).AND..NOT.POLAR) 127 - - WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) 128 - - ' EY = y-component of the electric field [V/cm]' 129 - IF(USE(4).AND.POLAR)WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) 130 - - ' EPHI = angular component of the electric field [V/cm]' 131 - IF(USE(5))WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) 132 - - ' E = magnitude of the electric field [V/cm]' 133 - IF(USE(6))WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) 134 - - ' V = electrostatic potential [V]' 135 - IF(USE(7))WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) 136 - - ' BX = x-component of the magnetic field [V sec/cm2]' 137 - IF(USE(8))WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) 138 - - ' BY = y-component of the magnetic field [V sec/cm2]' 139 - IF(USE(9))WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) 140 - - ' BZ = z-component of the magnetic field [V sec/cm2]' 141 - IF(USE(10))WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) 142 - - ' B = magnitude of the magnetic field [V sec/cm2]' 143 - WRITE(LUNOUT,'(/'' The data apply to a rectangular grid of '', 144 - - I2,'' points in the area delimited by:'')') 145 - PXMIND=PXMIN 146 - PXMAXD=PXMAX 147 - PYMIND=PYMIN 148 - PYMAXD=PYMAX 149 - IF(POLAR)CALL CFMRTP(PXMIND,PYMIND,PXMIND,PYMIND,1) 150 - IF(POLAR)CALL CFMRTP(PXMAXD,PYMAXD,PXMAXD,PYMAXD,1) 151 - IF(POLAR)THEN 152 - WRITE(LUNOUT,'('' '',F10.3,'' < r < '',F10.3/ 153 - - '' '',F10.3,'' < phi < '',F10.3)', 154 - - ERR=2010,IOSTAT=IOS) PXMIND,PXMAXD,PYMIND,PYMAXD 155 - ELSE 156 - WRITE(LUNOUT,'('' '',F10.3,'' < x < '',F10.3/ 157 - - '' '',F10.3,'' < y < '',F10.3)', 158 - - ERR=2010,IOSTAT=IOS) PXMIND,PXMAXD,PYMIND,PYMAXD 159 - ENDIF 160 - *** Set the averaging variables to 0. 161 - DO 15 ISUM=1,NRES 162 - SUMFLD(ISUM)=0 163 - 15 CONTINUE 164 - NSUM=0 165 - *** Loop over the area, printing the field at the same time, 166 - DO 60 JJ=0,10*INT((NGRIDY-1)/10.0),10 167 - JMAX=MIN(NGRIDY-JJ,10) 168 - DO 50 II=0,10*INT((NGRIDX-1)/10.0),10 169 - IMAX=MIN(NGRIDX-II,10) 170 - WRITE(LUNOUT,'(''1 FIELD-PRINT'',109X,''PART '',I1,''.'',I1)', 1 557 P=FIELD D=FLDPRT 3 PAGE 845 171 - - ERR=2010,IOSTAT=IOS) 1+II/10,1+JJ/10 172 - WRITE(LUNOUT,'('' ==========='',109X,''========''/)', 173 - - IOSTAT=IOS,ERR=2010) 174 - IF(.NOT.POLAR)THEN 175 - WRITE(LUNOUT,'('' y x:'',10(E11.4,1X:)/)', 176 - - IOSTAT=IOS,ERR=2010) 177 - - (PXMIN+(PXMAX-PXMIN)*(II+I-1)/REAL(NGRIDX-1),I=1,IMAX) 178 - ELSE 179 - WRITE(LUNOUT,'('' phi r:'',10(E11.4,1X:)/)', 180 - - IOSTAT=IOS,ERR=2010) 181 - - (EXP(PXMIN)+(EXP(PXMAX)-EXP(PXMIN))*REAL(II+I-1)/ 182 - - REAL(NGRIDX-1),I=1,IMAX) 183 - ENDIF 184 - DO 40 J=1,JMAX 185 - YPOS=PYMIN+(PYMAX-PYMIN)*REAL(JJ+J-1)/REAL(NGRIDY-1) 186 - DO 20 I=1,IMAX 187 - IF(POLAR)THEN 188 - XPOS=LOG(EXP(PXMIN)+(EXP(PXMAX)-EXP(PXMIN))* 189 - - REAL(II+I-1)/REAL(NGRIDX-1)) 190 - ELSE 191 - XPOS=PXMIN+(PXMAX-PXMIN)*REAL(II+I-1)/REAL(NGRIDX-1) 192 - ENDIF 193 - * evaluate the field, 194 - IF(EVALE)CALL EFIELD(XPOS,YPOS,0.0, 195 - - VAR(3),VAR(4),EZ,VAR(5),VAR(6), 196 - - IOPT,ILOC) 197 - IF(EVALB)CALL BFIELD(XPOS,YPOS,0.0, 198 - - VAR(7),VAR(8),VAR(9),VAR(10)) 199 - * convert to polar coordinates if the cell is polar, 200 - IF(EVALE.AND.POLAR)THEN 201 - VAR(3)=VAR(3)/EXP(XPOS) 202 - VAR(4)=VAR(4)/EXP(XPOS) 203 - VAR(5)=VAR(5)/EXP(XPOS) 204 - ENDIF 205 - IF(POLAR)THEN 206 - VAR(1)=EXP(XPOS) 207 - VAR(2)=180.0*YPOS/PI 208 - ELSE 209 - VAR(1)=XPOS 210 - VAR(2)=YPOS 211 - ENDIF 212 - * Assign modes. 213 - DO 80 K=1,10 214 - MODVAR(K)=2 215 - 80 CONTINUE 216 - * Evaluate the field functions and store the results in VECTOR, 217 - CALL ALGEXE(IENTRY,VAR,MODVAR,10,VECTOR(1,I),MODRES,4,IFAIL) 218 - * And add the new values to the sum. 219 - DO 16 ISUM=1,NRES 220 - SUMFLD(ISUM)=SUMFLD(ISUM)+VECTOR(ISUM,I) 221 - 16 CONTINUE 222 - NSUM=NSUM+1 223 - 20 CONTINUE 224 - * Print VECTOR, 225 - WRITE(LUNOUT,'(1X,E10.3)',IOSTAT=IOS,ERR=2010) VAR(2) 226 - DO 30 K=1,NRES 227 - WRITE(LUNOUT,'(12X,10(E11.4,1X:))',IOSTAT=IOS,ERR=2010) 228 - - (VECTOR(K,I),I=1,IMAX) 229 - 30 CONTINUE 230 - 40 CONTINUE 231 - 50 CONTINUE 232 - 60 CONTINUE 233 - * Finally print the averages as well. 234 - WRITE(LUNOUT,'(''1 Number of sampling points on the grid: '',I5 235 - - /'' Averaging over this grid yields:'')',ERR=2010, 236 - - IOSTAT=IOS) NSUM 237 - DO 65 ISUM=1,NRES 238 - WRITE(LUNOUT,'(/'' Function '',I1,'': '',E15.8)',ERR=2010, 239 - - IOSTAT=IOS) ISUM,SUMFLD(ISUM)/NSUM 240 - 65 CONTINUE 241 - *** Proceed with the next group of functions. 242 - 70 CONTINUE 243 - * Release the algebra entry point. 244 - CALL ALGCLR(IENTRY) 245 - *** Register the amount of CPU time used in the step. 246 - CALL TIMLOG('Printing a table of the field: ') 247 - RETURN 248 - *** Handle I/O errors. 249 - 2010 CONTINUE 250 - PRINT *,' ###### FLDPRT ERROR : Error writing the field'// 251 - - ' table on unit ',LUNOUT,' ; output terminated.' 252 - CALL INPIOS(IOS) 253 - END 558 GARFIELD ================================================== P=FIELD D=FLDCHK 1 ============================ 0 + +DECK,FLDCHK. 1 - SUBROUTINE FLDCHK 2 - *----------------------------------------------------------------------- 3 - * FLDCHK - Subroutine printing the field and the potential at the 4 - * wire surface and at the plane surface. It checks also that 5 - * the Maxwell equations are satisfied. 6 - * VARIABLES : ERADS,E2RADS: Sum of fieldstrength at (twice) the radius 7 - * CHNUM : Charge calculated from the E-field 8 - * VRADS,V2RADS: Sum of potential at (twice) the radius 9 - * TABLE : Is used for extrapolating to the r=d/2 10 - * ..HIST : Histogram's for the 'Maxwell' option 11 - * DVDX ETC : Derivatives, self explanatory 12 - * LPLCHK : Checking potentials at the plane surface 13 - * LMWCHK : Checking that the Maxwell equations are 14 - * satisfied 15 - * LSWCHK : Checking the field at the s-wire surface 16 - * LTUCHK : Check the field at the tube surface. 17 - * (Last changed on 25/ 6/97.) 18 - *----------------------------------------------------------------------- 19 - implicit none 1 558 P=FIELD D=FLDCHK 2 PAGE 846 20.- +SEQ,DIMENSIONS. 21.- +SEQ,CELLDATA. 22.- +SEQ,CONSTANTS. 23.- +SEQ,PARAMETERS. 24.- +SEQ,BFIELD. 25.- +SEQ,PRINTPLOT. 26 - REAL DVDX(10),DVDY(10),DVDZ(10),DIVE(10),DIVB(10),PHVECT(20), 27 - - ETVECT(20), 28 - - VTVECT(20),EXVECT(20),EYVECT(20),EZVECT(20),TABLE(5,5), 29 - - XPL(MXLIST),YPL(MXLIST),EXPL1(MXLIST),EXPL2(MXLIST), 30 - - EYPL1(MXLIST),EYPL2(MXLIST),VPL1(MXLIST),VPL2(MXLIST), 31 - - EX,EY,EZ,BX,BY,BZ,EXX1,EXX2,EXY1,EXY2,EXZ1,EXZ2, 32 - - EYX1,EYX2,EYY1,EYY2,EYZ1,EYZ2,EZX1,EZX2,EZY1,EZY2, 33 - - EZZ1,EZZ2,BXX1,BXX2,BXY1,BXY2,BXZ1,BXZ2, 34 - - BYX1,BYX2,BYY1,BYY2,BYZ1,BYZ2,BZX1,BZX2,BZY1,BZY2, 35 - - BZZ1,BZZ2,DX,DY,DZ,EPSWIR,EPSMXW,EPSR,STEPA,STEPB,XPRT,YPRT, 36 - - ERADS,E2RADS,VRADS,V2RADS,CHNUM,CHERR,SURFTS,SURFTH,ANG, 37 - - EX1,EX2,EY1,EY2,EZ1,EZ2,V1,V2,ETOT,ETOT1,ETOT2,ETOT3,ETOT4, 38 - - ETOT5,ETOT6,ERSUM,EPSUM,V1SUM,PHI,BTOT,VOLT, 39 - - V2SUM,E2SUM,RLOC,PHIPRO,ER,EPHI,ERCHK,DR,VX1,VX2,VY1,VY2, 40 - - VZ1,VZ2,ESUM,XRNDM,YRNDM,ZRNDM,RRNDM,XPOS,YPOS,ZPOS, 41 - - VT,AUX,RNDM 42 - INTEGER ISIZ(1),IDIM(1),NCHA,I,II,J,JJ,NWORD,INEXT,NDATA, 43 - - ITAB,JTAB,NC, 44 - - KTAB,NRNDM,IHISEX,IHISEY,IHISEZ,IHISDE,IHISDB,NENTEX, 45 - - NENTEY,NENTEZ,NENTDE,NENTDB,IMAX,JMAX,NCHAR, 46 - - ILOC,ILOC1,ILOC2,ILOC3,ILOC4,ILOC5,ILOC6,ILOC7, 47 - - INPTYP,INPCMP,IFAIL,IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5 48 - CHARACTER*133 INFILE 49 - LOGICAL LPLCHK,LMWCHK,LSWCHK,LMTCHK,LTUCHK,LCHCHK,LKEEP, 50 - - FLAGEX(10),FLAGEY(10),FLAGEZ(10),FLAGDE(10),FLAGDB(10), 51 - - LMWPRT,LMWPLT 52 - EXTERNAL INPCMP,INPTYP,RNDM 0 53-+ +SELF,IF=SAVE. 54 - SAVE NCHA,EPSWIR,EPSMXW,LMWPRT,LMWPLT 0 55-+ +SELF. 56 - DATA NCHA/100/,EPSWIR/1.0E-5/,EPSMXW/1.0E-3/, 57 - - LMWPRT/.TRUE./,LMWPLT/.TRUE./ 58 - *** Define some output formats. 59 - 1010 FORMAT('1 Table of the field at the surface of wire ',I3/ 60 - - ' ============================================='// 61 - - ' Wire type : ',A1/ 62 - - ' The wire is located at : (',F9.2,',',F9.2,')'/ 63 - - ' The wire potential is : ',F10.2,' [V]'/ 64 - - ' SETUP calculated a charge of : ',F10.2// 65 - - ' Angle Surface field Field at 2*rad', 66 - - ' Surface pot. Pot. at 2*rad Surface angle'/ 67 - - ' [degree] [V/cm] [V/cm]', 68 - - ' [V] [V] [degree]'/) 69 - 1040 FORMAT('1 Table of the field at the surface of plane ',I3,/, 70 - - ' ==============================================',//, 71 - - ' ',A1,'-coordinate : ',F10.2/ 72 - - ' Potential as specified : ',F10.2,' [V]',/) 73 - 1050 FORMAT('1 Table of the field at the surface of the tube ',/, 74 - - ' ==============================================',//, 75 - - ' Radius : ',F10.2/ 76 - - ' Potential as specified : ',F10.2,' [V]',/) 77 - 1060 FORMAT('1 FIELD-CHECK',109X,'part ',I1,'.',I1/122X, 78 - - '========'//' y x:',10(F10.2,2X:)) 79 - 1100 FORMAT('1 Numerical check of the Maxwell relations for the', 80 - - ' fields used by the program'/ 81 - - ' ================================================', 82 - - '==========================='// 83 - - ' The data will be printed in blocks of 10 by 10', 84 - - ' points, in the format '// 85 - - ' dV/dx + Ex [V/cm]'/ 86 - - ' dV/dy + Ey [V/cm]'/ 87 - - ' dV/dz + Ez [V/cm]'/ 88 - - ' Divergence of the electric field [V/cm]') 89 - *** Identify the routine. 90 - IF(LIDENT)PRINT *,' /// ROUTINE FLDCHK ///' 91 - *** Find out which options have been selected. 92 - LSWCHK=.FALSE. 93 - LPLCHK=.FALSE. 94 - LMWCHK=.FALSE. 95 - LMTCHK=.FALSE. 96 - LTUCHK=.FALSE. 97 - LCHCHK=.FALSE. 98 - LKEEP=.FALSE. 99 - CALL INPNUM(NWORD) 100 - INEXT=2 101 - DO 70 I=2,NWORD 102 - IF(I.LT.INEXT)GOTO 70 103 - IF(INPCMP(I,'D#IELECTRICA').NE.0)THEN 104 - IF(NXMATT.GE.0.OR.NYMATT.GE.0)THEN 105 - LMTCHK=.TRUE. 106 - ELSE 107 - CALL INPMSG(I,'no dielectrica in the cell. ') 108 - ENDIF 109 - ELSEIF(INPCMP(I,'NOD#IELECTRICA').NE.0)THEN 110 - LMTCHK=.FALSE. 111 - ELSEIF(INPCMP(I,'P#LANES').NE.0)THEN 112 - IF(YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4))THEN 113 - LPLCHK=.TRUE. 114 - ELSE 115 - CALL INPMSG(I,'the cell does not have planes.') 116 - ENDIF 117 - ELSEIF(INPCMP(I,'NOP#LANES').NE.0)THEN 118 - LPLCHK=.FALSE. 119 - ELSEIF(INPCMP(I,'T#UBE').NE.0)THEN 120 - IF(TUBE)THEN 121 - LTUCHK=.TRUE. 122 - ELSE 123 - CALL INPMSG(I,'the cell does not have a tube.') 1 558 P=FIELD D=FLDCHK 3 PAGE 847 124 - ENDIF 125 - ELSEIF(INPCMP(I,'NOT#UBE').NE.0)THEN 126 - LTUCHK=.FALSE. 127 - ELSEIF(INPCMP(I,'W#IRES').NE.0)THEN 128 - LSWCHK=.TRUE. 129 - ELSEIF(INPCMP(I,'NOW#IRES').NE.0)THEN 130 - LSWCHK=.FALSE. 131 - ELSEIF(INPCMP(I,'CH#ARGES').NE.0)THEN 132 - LCHCHK=.TRUE. 133 - ELSEIF(INPCMP(I,'NOCH#ARGES').NE.0)THEN 134 - LCHCHK=.FALSE. 135 - ELSEIF(INPCMP(I,'M#AXWELL').NE.0)THEN 136 - LMWCHK=.TRUE. 137 - ELSEIF(INPCMP(I,'NOM#AXWELL').NE.0)THEN 138 - LMWCHK=.FALSE. 139 - ELSEIF(INPCMP(I,'F#ULL')+INPCMP(I,'A#LL').NE.0)THEN 140 - LPLCHK=YNPLAX.OR.YNPLAY 141 - LSWCHK=NSW.GT.0 142 - LMWCHK=.TRUE. 143 - LMTCHK=.TRUE. 144 - LTUCHK=TUBE 145 - LCHCHK=N3D.GT.0 146 - * The BINS keyword. 147 - ELSEIF(INPCMP(I,'B#INS').NE.0)THEN 148 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN 149 - CALL INPMSG(I,'Has one integer as argument. ') 150 - ELSE 151 - CALL INPCHK(I+1,1,IFAIL) 152 - CALL INPRDI(I+1,NCHAR,MXCHA) 153 - IF(NCHAR.LE.1.OR.NCHAR.GT.MXCHA)THEN 154 - CALL INPMSG(I+1,'Inacceptable number of bins. ') 155 - ELSE 156 - NCHA=NCHAR 157 - ENDIF 158 - ENDIF 159 - INEXT=I+2 160 - * The differentation epsilon for the wires. 161 - ELSEIF(INPCMP(I,'EPS#ILON-W#IRES').NE.0)THEN 162 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN 163 - CALL INPMSG(I,'Has one real as argument. ') 164 - ELSE 165 - CALL INPCHK(I+1,2,IFAIL) 166 - CALL INPRDR(I+1,EPSR,EPSWIR) 167 - IF(EPSR.LE.0.0)THEN 168 - CALL INPMSG(I+1,'Epsilon must be larger than 0.') 169 - ELSE 170 - EPSWIR=EPSR 171 - ENDIF 172 - ENDIF 173 - INEXT=I+2 174 - * The differentation epsilon for Maxwell. 175 - ELSEIF(INPCMP(I,'EPS#ILON-M#AXWELL').NE.0)THEN 176 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN 177 - CALL INPMSG(I,'Has one real as argument. ') 178 - ELSE 179 - CALL INPCHK(I+1,2,IFAIL) 180 - CALL INPRDR(I+1,EPSR,EPSMXW) 181 - IF(EPSR.LE.0.0)THEN 182 - CALL INPMSG(I+1,'Epsilon must be larger than 0.') 183 - ELSE 184 - EPSMXW=EPSR 185 - ENDIF 186 - ENDIF 187 - INEXT=I+2 188 - * Print and plot results. 189 - ELSEIF(INPCMP(I,'PR#INT').NE.0)THEN 190 - LMWPRT=.TRUE. 191 - ELSEIF(INPCMP(I,'NOPR#INT').NE.0)THEN 192 - LMWPRT=.FALSE. 193 - ELSEIF(INPCMP(I,'PL#OT').NE.0)THEN 194 - LMWPLT=.TRUE. 195 - ELSEIF(INPCMP(I,'NOPL#OT').NE.0)THEN 196 - LMWPLT=.FALSE. 197 - * Keep results or not. 198 - ELSEIF(INPCMP(I,'KEEP-#RESULTS').NE.0)THEN 199 - LKEEP=.TRUE. 200 - ELSEIF(INPCMP(I,'NOKEEP-#RESULTS').NE.0)THEN 201 - LKEEP=.FALSE. 202 - * Invalid keyword. 203 - ELSE 204 - CALL INPMSG(I,'the option is not known. ') 205 - ENDIF 206 - 70 CONTINUE 207 - CALL INPERR 208 - *** Check that at least one of the options is on. 209 - IF(.NOT.(LPLCHK.OR.LSWCHK.OR.LMWCHK.OR.LMTCHK.OR. 210 - - LTUCHK.OR.LCHCHK))THEN 211 - PRINT *,' !!!!!! FLDCHK WARNING : To obtain output from'// 212 - - ' CHECK, select at least one of the' 213 - PRINT *,' options (CHARGES,'// 214 - - ' DIELECTRICA, MAXWELL, PLANES, TUBE, WIRES or FULL).' 215 - RETURN 216 - ENDIF 217 - *** Handle the 'WIRE' option. 218 - IF(LSWCHK)THEN 219 - DO 60 I=1,NWIRE 220 - * Skip non sense wires. 221 - IF(INDSW(I).EQ.0)GOTO 60 222 - * Prepare the extrapolation stepsizes for this wire. 223 - STEPB=0.25*(1.0/(0.5+EPSWIR*MAX(ABS(X(I)),ABS(Y(I)), 224 - - D(I)/2.0)/D(I))-1.0) 225 - STEPA=1.0+5.0*STEPB 226 - IF(LDEBUG)PRINT *,' ++++++ FLDCHK DEBUG : The table'// 227 - - ' points are at D/(',STEPA,' - I * ',STEPB,')' 228 - * Extrapolation is impossible if STEPB .LE. 0 (numerically unstable). 229 - IF(STEPB.LE.0)THEN 1 558 P=FIELD D=FLDCHK 4 PAGE 848 230 - PRINT *,' !!!!!! FLDCHK WARNING : The field near the'// 231 - - ' surface of wire ',I,' can not be calculated' 232 - PRINT *,' to a reasonable'// 233 - - ' accuracy with single precision arithmetic.' 234 - GOTO 60 235 - ENDIF 236 - * Print a suitable heading. 237 - XPRT=X(I) 238 - YPRT=Y(I) 239 - IF(POLAR)CALL CFMRTP(XPRT,YPRT,XPRT,YPRT,1) 240 - WRITE(LUNOUT,1010) I,WIRTYP(I),XPRT,YPRT,V(I),E(I) 241 - * Make a table of the field at the wire surface. 242 - ERADS =0.0 243 - E2RADS=0.0 244 - VRADS =0.0 245 - V2RADS=0.0 246 - CHNUM =0.0 247 - SURFTS=0.0 248 - NDATA =0 249 - * Loop over the angle around the wire. 250 - DO 50 ANG=0.0,1.9*PI,PI/9.0 251 - * Set up a table for the extrapolation. 252 - DO 10 ITAB=1,5 253 - TABLE(1,ITAB)=D(I)/(STEPA-REAL(ITAB)*STEPB) 254 - XPOS=X(I)+COS(ANG)*TABLE(1,ITAB) 255 - YPOS=Y(I)+SIN(ANG)*TABLE(1,ITAB) 256 - CALL EFIELD(XPOS,YPOS,0.0,TABLE(2,ITAB),TABLE(3,ITAB),EZ, 257 - - TABLE(4,ITAB),TABLE(5,ITAB),1,ILOC) 258 - IF(ILOC.NE.0)THEN 259 - IF(ILOC.GT.0)WRITE(LUNOUT,'(1X,F10.1,'' Leaving'', 260 - - '' the wire at this angle, you enter wire '', 261 - - I3,'' very soon; no data printed.'')') 262 - - 180*ANG/PI,ILOC 263 - IF(ILOC.LT.0)WRITE(LUNOUT,'(1X,F10.1,'' Leaving'', 264 - - '' the wire at this angle, you get outside'', 265 - - '' a plane very soon; no data printed.'')') 266 - - 180*ANG/PI 267 - GOTO 50 268 - ENDIF 269 - IF(POLAR)THEN 270 - TABLE(2,ITAB)=TABLE(2,ITAB)/EXP(XPOS) 271 - TABLE(3,ITAB)=TABLE(3,ITAB)/EXP(XPOS) 272 - TABLE(4,ITAB)=TABLE(4,ITAB)/EXP(XPOS) 273 - ENDIF 274 - IF(TABLE(4,ITAB).EQ.0)PRINT *,' !!!!!! FLDCHK WARNING :'// 275 - - ' Field zero at ITAB=',ITAB,' (program bug) ;'// 276 - - ' extrapolation probably incorrect' 277 - 10 CONTINUE 278 - * Loop over the quantities to be extrapolated. 279 - DO 40 KTAB=2,5 280 - * Extrapolate using Neville polynomial extrapolation. 281 - DO 30 ITAB=1,5 282 - DO 20 JTAB=ITAB-1,1,-1 283 - TABLE(KTAB,JTAB)=TABLE(KTAB,JTAB+1)+ 284 - - (TABLE(KTAB,JTAB+1)-TABLE(KTAB,JTAB))* 285 - - (0.5*D(I)-TABLE(1,ITAB))/(TABLE(1,ITAB)-TABLE(1,JTAB)) 286 - 20 CONTINUE 287 - 30 CONTINUE 288 - 40 CONTINUE 289 - * Add new values at r and at 2 r to the sum. 290 - NDATA=NDATA+1 291 - ERADS=ERADS+TABLE(4,1) 292 - VRADS=VRADS+TABLE(5,1) 293 - E2RADS=E2RADS+TABLE(4,5) 294 - V2RADS=V2RADS+TABLE(5,5) 295 - * Store the results for a save later. 296 - PHVECT(NDATA)=ANG 297 - EXVECT(NDATA)=TABLE(2,1) 298 - EYVECT(NDATA)=TABLE(3,1) 299 - ETVECT(NDATA)=TABLE(4,1) 300 - VTVECT(NDATA)=TABLE(5,1) 301 - * Compute radial component of the electric field. 302 - CHNUM=CHNUM+TABLE(2,5)*COS(ANG)+TABLE(3,5)*SIN(ANG) 303 - * Compute the angle at the surface of the wire. 304 - SURFTH=TABLE(2,1)*COS(ANG)+TABLE(3,1)*SIN(ANG) 305 - IF(TABLE(4,1).EQ.0.0)SURFTH=1.0 306 - IF(TABLE(4,1).NE.0.0)SURFTH=SURFTH/TABLE(4,1) 307 - IF(ABS(SURFTH).GT.1.0)SURFTH=1.0 308 - SURFTH=90.0+(180.0/PI)*ACOS(SURFTH) 309 - SURFTS=SURFTS+SURFTH 310 - * Print values for this angle. 311 - WRITE(LUNOUT,'(1X,F10.1,5F15.4)') 312 - - 180*ANG/PI,TABLE(4,1),TABLE(4,5), 313 - - TABLE(5,1),TABLE(5,5),SURFTH 314 - 50 CONTINUE 315 - * Check data has been collected. 316 - IF(NDATA.EQ.0)THEN 317 - WRITE(LUNOUT,'(/'' No data collected for this'', 318 - - '' wire; no averages or check sums.''/)') 319 - GOTO 60 320 - ENDIF 321 - * Print averages. 322 - WRITE(LUNOUT,'(''0 Averages'',5F15.4,/)') 323 - - ERADS/NDATA,E2RADS/NDATA, 324 - - VRADS/NDATA,V2RADS/NDATA,SURFTS/NDATA 325 - * Print check-charge. 326 - CHNUM=CHNUM*D(I)/NDATA 327 - IF(POLAR)CHNUM=CHNUM*EXP(X(I)) 328 - IF(E(I).EQ.0.OR.CHNUM.EQ.0)THEN 329 - CHERR=0.0 330 - ELSE 331 - CHERR=100.0*ABS((CHNUM-E(I))/E(I)) 332 - ENDIF 333 - WRITE(LUNOUT,'(/'' Charge calculated using the electric'', 334 - - '' field '',E10.3,'' (relative error '',E10.3, 335 - - ''%)''/)') CHNUM,CHERR 1 558 P=FIELD D=FLDCHK 5 PAGE 849 336 - * Save the data if required, format the wire number. 337 - IF(LKEEP)THEN 338 - CALL OUTFMT(REAL(I),2,INFILE,NC,'LEFT') 339 - ISIZ(1)=NDATA 340 - IDIM(1)=20 341 - CALL MATSAV(EXVECT,1,IDIM,ISIZ, 342 - - 'EX_'//INFILE(1:NC),IFAIL1) 343 - CALL MATSAV(EYVECT,1,IDIM,ISIZ, 344 - - 'EY_'//INFILE(1:NC),IFAIL2) 345 - CALL MATSAV(ETVECT,1,IDIM,ISIZ, 346 - - 'E_'//INFILE(1:NC),IFAIL3) 347 - CALL MATSAV(VTVECT,1,IDIM,ISIZ, 348 - - 'V_'//INFILE(1:NC),IFAIL4) 349 - CALL MATSAV(PHVECT,1,IDIM,ISIZ, 350 - - 'PHI_'//INFILE(1:NC),IFAIL5) 351 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0.AND. 352 - - IFAIL4.EQ.0.AND.IFAIL5.EQ.0)THEN 353 - PRINT *,' ------ FLDCHK MESSAGE : Saving'// 354 - - ' EX_'//INFILE(1:NC)//', EY_'//INFILE(1:NC)// 355 - - ', E_'//INFILE(1:NC)//', V_'//INFILE(1:NC)// 356 - - ' and PHI_'//INFILE(1:NC)//' as surface'// 357 - - ' field on wire '//INFILE(1:NC)//'.' 358 - ELSE 359 - PRINT *,' !!!!!! FLDCHK WARNING : Unable to'// 360 - - ' save the surface field of wire '// 361 - - INFILE(1:NC)//'.' 362 - ENDIF 363 - ENDIF 364 - * Next wire, 365 - 60 CONTINUE 366 - * End of this step, register amount of CPU time. 367 - CALL TIMLOG('Check: field on the wire-surface: ') 368 - ENDIF 369 - *** Check of the planes. 370 - IF(LPLCHK)THEN 371 - DO 120 I=1,4 372 - IF(.NOT.YNPLAN(I))GOTO 120 373 - * Print a suitable heading. 374 - IF(.NOT.POLAR)THEN 375 - IF(I.LE.2)WRITE(LUNOUT,1040) I,'X',COPLAN(I),VTPLAN(I) 376 - IF(I.GE.3)WRITE(LUNOUT,1040) I,'Y',COPLAN(I),VTPLAN(I) 377 - ELSE 378 - IF(I.LE.2)WRITE(LUNOUT,1040) 379 - - I,'R',EXP(COPLAN(I)),VTPLAN(I) 380 - IF(I.GE.3)WRITE(LUNOUT,1040) 381 - - I,'P',180.0*COPLAN(I)/PI,VTPLAN(I) 382 - ENDIF 383 - IF(I.LE.2)THEN 384 - IF(POLAR)THEN 385 - WRITE(LUNOUT,'('' phi-coord. V inside'', 386 - - '' V outside Er inside E'', 387 - - ''r outside''/)') 388 - ELSE 389 - WRITE(LUNOUT,'('' y-coord. V left'', 390 - - '' V right Ex left '', 391 - - '' Ex right''/)') 392 - ENDIF 393 - DO 100 J=0,10 394 - CALL EFIELD(COPLAN(I)-(XMAX-XMIN)/1000.0, 395 - - YMIN+J*(YMAX-YMIN)/10.0,0.0, 396 - - EX1,EY1,EZ1,ETOT1,V1,1,ILOC) 397 - CALL EFIELD(COPLAN(I)+(XMAX-XMIN)/1000.0, 398 - - YMIN+J*(YMAX-YMIN)/10.0,0.0, 399 - - EX2,EY2,EZ2,ETOT2,V2,1,ILOC) 400 - IF(POLAR)THEN 401 - EX1=EX1/EXP(COPLAN(I)-(XMAX-XMIN)/1000.0) 402 - EX2=EX2/EXP(COPLAN(I)+(XMAX-XMIN)/1000.0) 403 - ENDIF 404 - IF(POLAR)WRITE(LUNOUT,'(1X,F10.1,4F15.4)') 405 - - 180.0*(YMIN+J*(YMAX-YMIN)/10.0)/PI,V1,V2,EX1,EX2 406 - IF(.NOT.POLAR)WRITE(LUNOUT,'(1X,F10.1,4F15.4)') 407 - - YMIN+J*(YMAX-YMIN)/10.0,V1,V2,EX1,EX2 408 - 100 CONTINUE 409 - ELSE 410 - IF(POLAR)THEN 411 - WRITE(LUNOUT,'('' r-coord. V above'', 412 - - '' V under Ephi above '', 413 - - '' Ephi under''/)') 414 - ELSE 415 - WRITE(LUNOUT,'('' x coord. V above'', 416 - - '' V under Ey above '', 417 - - '' Ey under''/)') 418 - ENDIF 419 - DO 110 J=0,10 420 - IF(POLAR)XPRT=LOG(EXP(XMIN)+ 421 - - J*(EXP(XMAX)-EXP(XMIN))/10.0) 422 - IF(.NOT.POLAR)XPRT=XMIN+J*(XMAX-XMIN)/10.0 423 - CALL EFIELD(XPRT,COPLAN(I)+(YMAX-YMIN)/1000.0,0.0, 424 - - EX1,EY1,EZ1,ETOT1,V1,1,ILOC) 425 - CALL EFIELD(XPRT,COPLAN(I)-(YMAX-YMIN)/1000.0,0.0, 426 - - EX2,EY2,EZ2,ETOT2,V2,1,ILOC) 427 - IF(POLAR)THEN 428 - EY1=EY1/EXP(XPRT) 429 - EY2=EY2/EXP(XPRT) 430 - ENDIF 431 - IF(POLAR)WRITE(LUNOUT,'(1X,F10.1,4F15.4)') 432 - - EXP(XPRT),V1,V2,EY1,EY2 433 - IF(.NOT.POLAR)WRITE(LUNOUT,'(1X,F10.1,4F15.4)') 434 - - XPRT,V1,V2,EY1,EY2 435 - 110 CONTINUE 436 - ENDIF 437 - 120 CONTINUE 438 - * Register the amount of CPU time spent on this operation. 439 - CALL TIMLOG('Check: field on the planes: ') 440 - ENDIF 441 - *** Check of the tube. 1 558 P=FIELD D=FLDCHK 6 PAGE 850 442 - IF(LTUCHK.AND..NOT.TUBE)THEN 443 - PRINT *,' !!!!!! FLDCHK WARNING : Tube checking requested'// 444 - - ' but the cell has no tube.' 445 - ELSEIF(LTUCHK)THEN 446 - * Print a heading. 447 - WRITE(LUNOUT,1050) COTUBE,VTTUBE 448 - WRITE(LUNOUT,'('' phi V inside V outside'', 449 - - '' Er inside Ephi inside E outside''/ 450 - - '' [degrees] [V] [V]'', 451 - - '' [V/cm] [V/cm] [V/cm]''/)') 452 - * Summing variables. 453 - ERSUM=0.0 454 - EPSUM=0.0 455 - V1SUM=0.0 456 - V2SUM=0.0 457 - E2SUM=0.0 458 - * Angular loop. 459 - DO 130 J=1,25 460 - IF(NTUBE.GT.2)THEN 461 - PHI=REAL(J-1)*2*PI/REAL(25*NTUBE) 462 - IF(COS(PI/REAL(NTUBE)-PHI).EQ.0)GOTO 130 463 - RLOC=COTUBE*COS(PI/REAL(NTUBE))/COS(PI/REAL(NTUBE)-PHI) 464 - PHIPRO=PI/REAL(NTUBE) 465 - ELSE 466 - PHI=REAL(J-1)*2*PI/REAL(25) 467 - RLOC=COTUBE 468 - PHIPRO=PHI 469 - ENDIF 470 - CALL EFIELD(0.999*RLOC*COS(PHI),0.999*RLOC*SIN(PHI), 471 - - 0.0,EX1,EY1,EZ1,ETOT1,V1,1,ILOC) 472 - CALL EFIELD(1.001*RLOC*COS(PHI),1.001*RLOC*SIN(PHI), 473 - - 0.0,EX2,EY2,EZ2,ETOT2,V2,1,ILOC) 474 - ER = COS(PHIPRO)*EX1+SIN(PHIPRO)*EY1 475 - EPHI=-SIN(PHIPRO)*EX1+COS(PHIPRO)*EY1 476 - ERSUM=ERSUM+ER 477 - EPSUM=EPSUM+EPHI 478 - V1SUM=V1SUM+V1 479 - V2SUM=V2SUM+V2 480 - E2SUM=E2SUM+ETOT2 481 - WRITE(LUNOUT,'(1X,F10.1,5(1X,F12.5))') 482 - - 180*PHI/PI,V1,V2,ER,EPHI,ETOT2 483 - 130 CONTINUE 484 - * Print averages. 485 - WRITE(LUNOUT,'(/2X,''Average: '',5(1X,F12.5))') 486 - - V1SUM/25.0,V2SUM/25.0,ERSUM/25.0, 487 - - EPSUM/25.0,E2SUM/25.0 488 - * Print summary. 489 - IF(NTUBE.GT.2)THEN 490 - ERSUM=ERSUM*0.999*SQRT(2*(1-COS(2*PI/REAL(NTUBE))))* 491 - - COTUBE*NTUBE/25.0 492 - ELSE 493 - ERSUM=ERSUM*0.999*COTUBE/25.0 494 - ENDIF 495 - ERCHK=0.0 496 - DO 140 J=1,NWIRE 497 - IF(MTUBE.EQ.0.OR.X(J)**2+Y(J)**2.LT.D(J)**2/4)THEN 498 - ERCHK=ERCHK+E(J) 499 - ELSE 500 - ERCHK=ERCHK+E(J)*MTUBE 501 - ENDIF 502 - 140 CONTINUE 503 - WRITE(LUNOUT,'(/'' Charge check: Tube : '',E12.5/16X, 504 - - ''Wires : '',E12.5)') ERSUM,ERCHK 505 - * Register the amount of CPU time spent on this operation. 506 - CALL TIMLOG('Check: field on the tube surface: ') 507 - ENDIF 508 - *** Check that the charges match the electric field around them. 509 - IF(LCHCHK.AND.N3D.EQ.0)THEN 510 - PRINT *,' !!!!!! FLDCHK WARNING : Charge checking has been', 511 - - ' requested but there are no charges.' 512 - ELSEIF(LCHCHK)THEN 513 - * Print a header. 514 - WRITE(LUNOUT,'(''1 Check of the three dimensional charges''/ 515 - - '' ======================================''// 516 - - '' No Charge given Charge found'')') 517 - * Loop over the charges. 518 - DO 410 I=1,N3D 519 - * Determine for each of the charges a radius. 520 - DR=1E-4*(1+ABS(X3D(I))+ABS(Y3D(I))+ABS(Z3D(I))) 521 - * Check that there are no other charges nearby. 522 - DO 420 J=1,N3D 523 - IF(I.EQ.J)GOTO 420 524 - IF((X3D(I)-X3D(J))**2+(Y3D(I)-Y3D(J))**2+ 525 - - (Z3D(I)-Z3D(J))**2.LT.DR**2)THEN 526 - PRINT *,' !!!!!! FLDCHK WARNING : Charge ',J,' is', 527 - - ' located too close to charge ',I,' to be able', 528 - - ' to verify the charges.' 529 - GOTO 410 530 - ENDIF 531 - 420 CONTINUE 532 - * Check that there are no wires nearby. 533 - DO 430 J=1,NWIRE 534 - IF((X3D(I)-X(J))**2+(Y3D(I)-Y(J))**2.LT.DR**2)THEN 535 - PRINT *,' !!!!!! FLDCHK WARNING : Wire ',J,' is', 536 - - ' located too close to charge ',I,' to be able', 537 - - ' to verify the charges.' 538 - GOTO 410 539 - ENDIF 540 - 430 CONTINUE 541 - * Determine the flow out of the sphere by MC integration. 542 - ESUM=0.0 543 - NRNDM=0 544 - DO 440 J=1,1000 545 - * Generate a random point on the unit circle. 546 - XRNDM=-1+2*RNDM(1*J) 547 - YRNDM=-1+2*RNDM(2*J) 1 558 P=FIELD D=FLDCHK 7 PAGE 851 548 - ZRNDM=-1+2*RNDM(3*J) 549 - RRNDM=SQRT(XRNDM**2+YRNDM**2+ZRNDM**2) 550 - IF(RRNDM.EQ.0)GOTO 440 551 - XRNDM=DR*XRNDM/RRNDM 552 - YRNDM=DR*YRNDM/RRNDM 553 - ZRNDM=DR*ZRNDM/RRNDM 554 - * Evaluate the field at that point. 555 - CALL EFIELD(X3D(I)+XRNDM,Y3D(I)+YRNDM,Z3D(I)+ZRNDM, 556 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 557 - IF(ILOC.NE.0)GOTO 440 558 - NRNDM=NRNDM+1 559 - * Project the field onto the out-bound vector. 560 - ESUM=ESUM+(EX*XRNDM+EY*YRNDM+EZ*ZRNDM)/DR 561 - * Next MC cycle. 562 - 440 CONTINUE 563 - * Print results for this charge. 564 - IF(NRNDM.EQ.0)THEN 565 - WRITE(LUNOUT,'(2X,I6,1X,''No data collected.'')') I 566 - ELSE 567 - WRITE(LUNOUT,'(2X,I6,1X,E15.8,1X,E15.8)') 568 - - I,E3D(I),ESUM*DR**2/NRNDM 569 - ENDIF 570 - * Next charge. 571 - 410 CONTINUE 572 - ENDIF 573 - *** Check that E and V are consistent ('MAXWELL' option). 574 - IF(LMWCHK)THEN 575 - * Print a suitable heading. 576 - IF(LMWPRT)THEN 577 - WRITE(LUNOUT,1100) 578 - IF(MAGOK)THEN 579 - WRITE(LUNOUT,'('' Divergence of the'', 580 - - '' magnetic field [V microsec/cm2]'')') 581 - ELSE 582 - WRITE(LUNOUT,'('' Potential '', 583 - - '' [V]'')') 584 - ENDIF 585 - IF(POLAR)WRITE(LUNOUT, 586 - - '('' WARNING: The coordinates are internal.'')') 587 - ENDIF 588 - * Allocate histograms. 589 - CALL HISADM('ALLOCATE',IHISEX,NCHA,0.0,0.0,.TRUE.,IFAIL1) 590 - CALL HISADM('ALLOCATE',IHISEY,NCHA,0.0,0.0,.TRUE.,IFAIL2) 591 - CALL HISADM('ALLOCATE',IHISEZ,NCHA,0.0,0.0,.TRUE.,IFAIL3) 592 - CALL HISADM('ALLOCATE',IHISDE,NCHA,0.0,0.0,.TRUE.,IFAIL4) 593 - CALL HISADM('ALLOCATE',IHISDB,NCHA,0.0,0.0,.TRUE.,IFAIL5) 594 - IF(IFAIL1+IFAIL2+IFAIL3+IFAIL4+IFAIL5.NE.0)THEN 595 - PRINT *,' !!!!!! FLDCHK WARNING : Unable to allocate'// 596 - - ' all required histograms.' 597 - ENDIF 598 - NENTEX=0 599 - NENTEY=0 600 - NENTEZ=0 601 - NENTDE=0 602 - NENTDB=0 603 - * Loop over the whole area. 604 - ZPOS=0.0 605 - DO 240 JJ=0,10*INT(REAL(NGRIDY-1)/10.0),10 606 - JMAX=MIN(NGRIDY-JJ,10) 607 - DO 230 II=0,10*INT(REAL(NGRIDX-1)/10.0),10 608 - IMAX=MIN(NGRIDX-II,10) 609 - IF(LMWPRT)WRITE(LUNOUT,1060) 1+II/10,1+JJ/10, 610 - - (PXMIN+(PXMAX-PXMIN)*REAL(II+I-1)/REAL(NGRIDX-1), 611 - - I=1,IMAX) 612 - IF(LMWPRT)WRITE(LUNOUT,'('' '')') 613 - DO 220 J=1,JMAX 614 - YPOS=PYMIN+(PYMAX-PYMIN)*REAL(JJ+J-1)/REAL(NGRIDY-1) 615 - DO 210 I=1,IMAX 616 - XPOS=PXMIN+(PXMAX-PXMIN)*REAL(II+I-1)/REAL(NGRIDX-1) 617 - * Preset the flags. 618 - FLAGEX(I)=.TRUE. 619 - FLAGEY(I)=.TRUE. 620 - FLAGEZ(I)=.TRUE. 621 - FLAGDE(I)=.TRUE. 622 - FLAGDB(I)=.TRUE. 623 - * Choose step sizes. 624 - DX=EPSMXW*(1.0+ABS(XPOS)) 625 - DY=EPSMXW*(1.0+ABS(YPOS)) 626 - DZ=EPSMXW*(1.0+ABS(ZPOS)) 627 - * Calculate the field. 628 - CALL EFIELD(XPOS ,YPOS ,ZPOS , 629 - - EX ,EY ,EZ ,ETOT ,VT ,1,ILOC1) 630 - CALL EFIELD(XPOS+DX,YPOS ,ZPOS , 631 - - EXX1,EYX1,EZX1,ETOT1,VX1,1,ILOC2) 632 - CALL EFIELD(XPOS-DX,YPOS ,ZPOS , 633 - - EXX2,EYX2,EZX2,ETOT2,VX2,1,ILOC3) 634 - CALL EFIELD(XPOS ,YPOS+DY,ZPOS , 635 - - EXY1,EYY1,EZY1,ETOT3,VY1,1,ILOC4) 636 - CALL EFIELD(XPOS ,YPOS-DY,ZPOS , 637 - - EXY2,EYY2,EZY2,ETOT4,VY2,1,ILOC5) 638 - CALL EFIELD(XPOS ,YPOS ,ZPOS+DZ, 639 - - EXZ1,EYZ1,EZZ1,ETOT5,VZ1,1,ILOC6) 640 - CALL EFIELD(XPOS ,YPOS ,ZPOS-DZ, 641 - - EXZ2,EYZ2,EZZ2,ETOT6,VZ2,1,ILOC7) 642 - EXVECT(I)=EX 643 - EYVECT(I)=EY 644 - EZVECT(I)=EZ 645 - VTVECT(I)=VT 646 - IF(MAGOK)THEN 647 - CALL BFIELD(XPOS ,YPOS ,ZPOS , 648 - - BX ,BY ,BZ ,BTOT) 649 - CALL BFIELD(XPOS+DX,YPOS ,ZPOS , 650 - - BXX1,BYX1,BZX1,BTOT) 651 - CALL BFIELD(XPOS-DX,YPOS ,ZPOS , 652 - - BXX2,BYX2,BZX2,BTOT) 653 - CALL BFIELD(XPOS ,YPOS+DY,ZPOS , 1 558 P=FIELD D=FLDCHK 8 PAGE 852 654 - - BXY1,BYY1,BZY1,BTOT) 655 - CALL BFIELD(XPOS ,YPOS-DY,ZPOS , 656 - - BXY2,BYY2,BZY2,BTOT) 657 - CALL BFIELD(XPOS ,YPOS ,ZPOS+DZ, 658 - - BXZ1,BYZ1,BZZ1,BTOT) 659 - CALL BFIELD(XPOS ,YPOS ,ZPOS-DZ, 660 - - BXZ2,BYZ2,BZZ2,BTOT) 661 - ENDIF 662 - * Skip histogramming if (XPOS,YPOS) lies within or near a wire. 663 - IF(ILOC1.NE.0.OR.ILOC2.NE.0.OR.ILOC3.NE.0.OR.ILOC4.NE.0.OR. 664 - - ILOC5.NE.0.OR.ILOC6.NE.0.OR.ILOC7.NE.0)THEN 665 - DVDX(I)=-EX 666 - DVDY(I)=-EY 667 - DVDZ(I)=-EZ 668 - DIVE(I)=0.0 669 - DIVB(I)=0.0 670 - FLAGEX(I)=.FALSE. 671 - FLAGEY(I)=.FALSE. 672 - FLAGEZ(I)=.FALSE. 673 - FLAGDE(I)=.FALSE. 674 - FLAGDB(I)=.FALSE. 675 - GOTO 210 676 - ENDIF 677 - * Calculate derivatives and divergence. 678 - IF((VX1-VT)*(VT-VX2).LT.0)FLAGEX(I)=.FALSE. 679 - DVDX(I)=(VX1-VX2)/(2*DX) 680 - IF((VY1-VT)*(VT-VY2).LT.0)FLAGEY(I)=.FALSE. 681 - DVDY(I)=(VY1-VY2)/(2*DY) 682 - IF((VZ1-VT)*(VT-VZ2).LT.0)FLAGEZ(I)=.FALSE. 683 - DVDZ(I)=(VZ1-VZ2)/(2*DZ) 684 - IF((EXX1-EX)*(EX-EXX2).LT.0.OR. 685 - - (EYY1-EY)*(EY-EYY2).LT.0.OR. 686 - - (EZZ1-EZ)*(EZ-EZZ2).LT.0)FLAGDE(I)=.FALSE. 687 - DIVE(I)=(EXX1-EXX2)/(2*DX)+(EYY1-EYY2)/(2*DY)+ 688 - - (EZZ1-EZZ2)/(2*DZ) 689 - IF(MAGOK)THEN 690 - IF((BXX1-BX)*(BX-BXX2).LT.0.OR. 691 - - (BYY1-BY)*(BY-BYY2).LT.0.OR. 692 - - (BZZ1-BZ)*(BZ-BZZ2).LT.0)FLAGDB(I)=.FALSE. 693 - DIVB(I)=(BXX1-BXX2)/(2*DX)+(BYY1-BYY2)/(2*DY)+ 694 - - (BZZ1-BZZ2)/(2*DZ) 695 - ENDIF 696 - * Fill histograms. 697 - IF(ABS(DVDX(I))+ABS(EX).NE.0.AND.FLAGEX(I))THEN 698 - CALL HISENT(IHISEX,(DVDX(I)+EX)/(ABS(DVDX(I))+ABS(EX)), 699 - - 1.0) 700 - NENTEX=NENTEX+1 701 - ENDIF 702 - IF(ABS(DVDY(I))+ABS(EY).NE.0.AND.FLAGEY(I))THEN 703 - CALL HISENT(IHISEY,(DVDY(I)+EY)/(ABS(DVDY(I))+ABS(EY)), 704 - - 1.0) 705 - NENTEY=NENTEY+1 706 - ENDIF 707 - IF(ABS(DVDZ(I))+ABS(EZ).NE.0.AND.FLAGEZ(I))THEN 708 - CALL HISENT(IHISEZ,(DVDZ(I)+EZ)/(ABS(DVDZ(I))+ABS(EZ)), 709 - - 1.0) 710 - NENTEZ=NENTEZ+1 711 - ENDIF 712 - IF(FLAGDE(I))THEN 713 - CALL HISENT(IHISDE,DIVE(I),1.0) 714 - NENTDE=NENTDE+1 715 - ENDIF 716 - IF(MAGOK.AND.FLAGDB(I))THEN 717 - CALL HISENT(IHISDB,DIVB(I),1.0) 718 - NENTDB=NENTDB+1 719 - ENDIF 720 - 210 CONTINUE 721 - * Print the quantities obtained. 722 - WRITE(INFILE,'(1X,F8.2,3X,10(F10.3,2X:))') 723 - - YPOS,(DVDX(I)+EXVECT(I),I=1,IMAX) 724 - DO 250 I=1,IMAX 725 - IF(.NOT.FLAGEX(I))INFILE(1+I*12:10+I*12)=' (invalid)' 726 - 250 CONTINUE 727 - IF(LMWPRT)WRITE(LUNOUT,'(A)') INFILE 728 - WRITE(INFILE,'(12X,10(F10.3,2X:))') 729 - - (DVDY(I)+EYVECT(I),I=1,IMAX) 730 - DO 260 I=1,IMAX 731 - IF(.NOT.FLAGEY(I))INFILE(1+I*12:10+I*12)=' (invalid)' 732 - 260 CONTINUE 733 - IF(LMWPRT)WRITE(LUNOUT,'(A)') INFILE 734 - WRITE(INFILE,'(12X,10(F10.3,2X:))') 735 - - (DVDZ(I)+EZVECT(I),I=1,IMAX) 736 - DO 265 I=1,IMAX 737 - IF(.NOT.FLAGEZ(I))INFILE(1+I*12:10+I*12)=' (invalid)' 738 - 265 CONTINUE 739 - IF(LMWPRT)WRITE(LUNOUT,'(A)') INFILE 740 - WRITE(INFILE,'(12X,10(F10.3,2X:))') (DIVE(I),I=1,IMAX) 741 - DO 270 I=1,IMAX 742 - IF(.NOT.FLAGDE(I))INFILE(1+I*12:10+I*12)=' (invalid)' 743 - 270 CONTINUE 744 - IF(LMWPRT)WRITE(LUNOUT,'(A)') INFILE 745 - IF(MAGOK)THEN 746 - WRITE(INFILE,'(12X,10(F10.3,2X:))') (DIVB(I),I=1,IMAX) 747 - DO 280 I=1,IMAX 748 - IF(.NOT.FLAGDB(I))INFILE(1+I*12:10+I*12)=' (invalid)' 749 - 280 CONTINUE 750 - IF(LMWPRT)WRITE(LUNOUT,'(A)') INFILE 751 - ELSE 752 - IF(LMWPRT)WRITE(LUNOUT,'(12X,10(F10.3,2X:))') 753 - - (VTVECT(I),I=1,IMAX) 754 - ENDIF 755 - IF(LMWPRT)WRITE(LUNOUT,'('' '')') 756 - 220 CONTINUE 757 - 230 CONTINUE 758 - 240 CONTINUE 759 - * Plot the histograms. 1 558 P=FIELD D=FLDCHK 9 PAGE 853 760 - IF(NENTEX.GT.0.AND.LMWPLT)THEN 761 - CALL HISPLT(IHISEX, 762 - - '(dV/dx + Ex) / (|dV/dx| + |Ex|)', 763 - - 'Relative error in Ex',.TRUE.) 764 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 765 - CALL GRNEXT 766 - CALL GRALOG('Relative error in Ex') 767 - ELSEIF(LMWPLT)THEN 768 - PRINT *,' !!!!!! FLDCHK WARNING : No useable data'// 769 - - ' collected for dV/dx + Ex; check epsilon.' 770 - ENDIF 771 - IF(NENTEY.GT.0.AND.LMWPLT)THEN 772 - CALL HISPLT(IHISEY, 773 - - '(dV/dy + Ey) / (|dV/dy| + |Ey|)', 774 - - 'Relative error in Ey',.TRUE.) 775 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 776 - CALL GRNEXT 777 - CALL GRALOG('Relative error in Ey') 778 - ELSEIF(LMWPLT)THEN 779 - PRINT *,' !!!!!! FLDCHK WARNING : No useable data'// 780 - - ' collected for dV/dy + Ey; check epsilon.' 781 - ENDIF 782 - IF(NENTEZ.GT.0.AND.LMWPLT)THEN 783 - CALL HISPLT(IHISEZ, 784 - - '(dV/dz + Ez) / (|dV/dz| + |Ez|)', 785 - - 'Relative error in Ez',.TRUE.) 786 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 787 - CALL GRNEXT 788 - CALL GRALOG('Relative error in Ez') 789 - ELSEIF(LMWPLT)THEN 790 - PRINT *,' !!!!!! FLDCHK WARNING : No useable data'// 791 - - ' collected for dV/dz + Ez; check epsilon.' 792 - ENDIF 793 - IF(NENTDE.GT.0.AND.LMWPLT)THEN 794 - CALL HISPLT(IHISDE, 795 - - 'dEx/dx+dEy/dy+dEz/dz [V/cm2]', 796 - - 'Divergence of the electric field',.TRUE.) 797 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 798 - CALL GRNEXT 799 - CALL GRALOG('Divergence of the E field') 800 - ELSEIF(LMWPLT)THEN 801 - PRINT *,' !!!!!! FLDCHK WARNING : No useable data'// 802 - - ' collected for div E; check epsilon.' 803 - ENDIF 804 - IF(MAGOK.AND.NENTDB.GT.0.AND.LMWPLT)THEN 805 - CALL HISPLT(IHISDB, 806 - - 'dBz/dz + dBz/dz', 807 - - 'Divergence of the magnetic field',.TRUE.) 808 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 809 - CALL GRNEXT 810 - CALL GRALOG('Divergence of the B field ') 811 - ELSEIF(MAGOK.AND.LMWPLT)THEN 812 - PRINT *,' !!!!!! FLDCHK WARNING : No useable data'// 813 - - ' collected for div B; check epsilon.' 814 - ENDIF 815 - * Delete histograms. 816 - IF(LKEEP)THEN 817 - CALL HISSAV(IHISEX,'EX_ERROR',IFAIL1) 818 - CALL HISSAV(IHISEY,'EY_ERROR',IFAIL2) 819 - CALL HISSAV(IHISEZ,'EZ_ERROR',IFAIL3) 820 - CALL HISSAV(IHISDE,'DIV_E',IFAIL4) 821 - CALL HISSAV(IHISDB,'DIV_B',IFAIL5) 822 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0.AND. 823 - - IFAIL4.EQ.0.AND.IFAIL5.EQ.0)THEN 824 - PRINT *,' ------ FLDCHK MESSAGE : Maxwell'// 825 - - ' histograms saved as EX_ERROR, EY_ERROR'// 826 - - ' EZ_ERROR, DIV_E (DIV_B).' 827 - ELSE 828 - PRINT *,' !!!!!! FLDCHK WARNING : Error saving'// 829 - - ' the Maxwell histograms.' 830 - ENDIF 831 - ELSE 832 - CALL HISADM('DELETE',IHISEX,0,0.0,0.0,.FALSE.,IFAIL1) 833 - CALL HISADM('DELETE',IHISEY,0,0.0,0.0,.FALSE.,IFAIL2) 834 - CALL HISADM('DELETE',IHISEZ,0,0.0,0.0,.FALSE.,IFAIL3) 835 - CALL HISADM('DELETE',IHISDE,0,0.0,0.0,.FALSE.,IFAIL4) 836 - CALL HISADM('DELETE',IHISDB,0,0.0,0.0,.FALSE.,IFAIL5) 837 - ENDIF 838 - * Register the amount of cpu time spent on this operation. 839 - CALL TIMLOG('Check: consistency of E and V: ') 840 - ENDIF 841 - *** Look for 'DIELECTRICA' option. 842 - IF(LMTCHK)THEN 843 - IF(YNMATX)THEN 844 - * Prepare a comment label. 845 - INFILE='Dielectric constant: ' 846 - CALL OUTFMT(XMATT(1,5),2,INFILE(22:),NC,'LEFT') 847 - * Walk along the boundary. 848 - DO 300 I=1,MXLIST 849 - XPL(I)=YMIN+REAL(I-1)*(YMAX-YMIN)/REAL(MXLIST-1) 850 - CALL EFIELD(COMATX-1.0E-3*(1+ABS(COMATX)),XPL(I),0.0, 851 - - EXPL1(I),EYPL1(I),EZ,ETOT,VPL1(I),1,ILOC1) 852 - CALL EFIELD(COMATX+1.0E-3*(1+ABS(COMATX)),XPL(I),0.0, 853 - - EXPL2(I),EYPL2(I),EZ,ETOT,VPL2(I),1,ILOC2) 854 - 300 CONTINUE 855 - * Plot the Ex ratio. 856 - DO 310 I=1,MXLIST 857 - IF(EXPL1(I).EQ.0.OR.EXPL2(I).EQ.0)THEN 858 - YPL(I)=0.0 859 - ELSE 860 - YPL(I)=EXPL1(I)/EXPL2(I) 861 - ENDIF 862 - 310 CONTINUE 863 - CALL GRGRPH(XPL,YPL,MXLIST,'y-axis [cm]', 864 - - 'Ex right / Ex left','CHECKING EX') 865 - AUX=XPL(2) 1 558 P=FIELD D=FLDCHK 10 PAGE 854 866 - XPL(2)=XPL(MXLIST) 867 - IF(XMATT(1,3).NE.0)THEN 868 - YPL(1)=XMATT(1,5) 869 - ELSE 870 - YPL(1)=1/XMATT(1,5) 871 - ENDIF 872 - YPL(2)=YPL(1) 873 - CALL GRATTS('COMMENT','POLYLINE') 874 - CALL GPL(2,XPL,YPL) 875 - XPL(2)=AUX 876 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 877 - CALL GRCOMM(3,INFILE(1:21+NC)) 878 - CALL GRNEXT 879 - CALL GRALOG('Check of Ex on a dielectric x-boundary. ') 880 - * Plot the Ey ratio. 881 - DO 320 I=1,MXLIST 882 - IF(EYPL1(I).EQ.0.OR.EYPL2(I).EQ.0)THEN 883 - YPL(I)=1.0 884 - ELSE 885 - YPL(I)=EYPL1(I)/EYPL2(I) 886 - ENDIF 887 - 320 CONTINUE 888 - CALL GRGRPH(XPL,YPL,MXLIST,'y-axis [cm]', 889 - - 'Ey right / Ey left','CHECKING EY') 890 - AUX=XPL(2) 891 - XPL(2)=XPL(MXLIST) 892 - YPL(1)=1.0 893 - YPL(2)=1.0 894 - CALL GRATTS('COMMENT','POLYLINE') 895 - CALL GPL(2,XPL,YPL) 896 - XPL(2)=AUX 897 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 898 - CALL GRCOMM(3,INFILE(1:21+NC)) 899 - CALL GRNEXT 900 - CALL GRALOG('Check of Ey on a dielectric x-boundary. ') 901 - * Plot the V ratio. 902 - DO 330 I=1,MXLIST 903 - IF(VPL1(I).EQ.0.OR.VPL2(I).EQ.0)THEN 904 - YPL(I)=1.0 905 - ELSE 906 - YPL(I)=VPL1(I)/VPL2(I) 907 - ENDIF 908 - 330 CONTINUE 909 - CALL GRGRPH(XPL,YPL,MXLIST,'y-axis [cm]', 910 - - 'V right / V left','CHECKING V') 911 - AUX=XPL(2) 912 - XPL(2)=XPL(MXLIST) 913 - YPL(1)=1.0 914 - YPL(2)=1.0 915 - CALL GRATTS('COMMENT','POLYLINE') 916 - CALL GPL(2,XPL,YPL) 917 - XPL(2)=AUX 918 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 919 - CALL GRCOMM(3,INFILE(1:21+NC)) 920 - CALL GRNEXT 921 - CALL GRALOG('Check of V on a dielectric x-boundary. ') 922 - ENDIF 923 - * Register the amount of CPU time spent on this operation. 924 - CALL TIMLOG('Check: dielectrica: ') 925 - ENDIF 926 - END 559 GARFIELD ================================================== P=FIELD D=FLDIN2 1 ============================ 0 + +DECK,FLDIN2. 1 - SUBROUTINE FLDIN2(XXC,YYC,RRC,QINT) 2 - *----------------------------------------------------------------------- 3 - * FLDIN2 - Integrates the charge in a circle with radius RC around 4 - * (XC,YC). 5 - * (Last changed on 8/ 4/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,CONSTANTS. 9 - REAL XXC,YYC,RRC,QINT 10 - DOUBLE PRECISION XAUX(6),XC,YC,ZC,RC,DGMLT1 11 - EXTERNAL FCHK3,DGMLT1 12 - COMMON /FCHDAT/ XC,YC,ZC,RC 13 - *** Generate double precision copies for the common block. 14 - XC=DBLE(XXC) 15 - YC=DBLE(YYC) 16 - ZC=0.0D0 17 - RC=DBLE(RRC) 18 - *** Perform the integration. 19 - QINT=REAL(DGMLT1(FCHK3,0.0D0,DBLE(2*PI),50,6,XAUX))/(2*PI) 20 - END 560 GARFIELD ================================================== P=FIELD D=FLDIN3 1 ============================ 0 + +DECK,FLDIN3. 1 - SUBROUTINE FLDIN3(XXC,YYC,ZZC,RRC,QINT) 2 - *----------------------------------------------------------------------- 3 - * FLDIN3 - Integrates the charge in a sphere with radius RC around 4 - * (XC,YC,ZC). 5 - * (Last changed on 8/ 4/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,CONSTANTS. 9 - REAL XXC,YYC,ZZC,RRC,QINT 10 - DOUBLE PRECISION XAUX(6),XC,YC,ZC,RC,DGMLT2 11 - EXTERNAL FCHK2,DGMLT2 12 - COMMON /FCHDAT/ XC,YC,ZC,RC 13 - *** Generate double precision copies for the common block. 14 - XC=DBLE(XXC) 15 - YC=DBLE(YYC) 16 - ZC=DBLE(ZZC) 17 - RC=DBLE(RRC) 1 560 P=FIELD D=FLDIN3 2 PAGE 855 18 - *** Perform the integration. 19 - QINT=REAL(DGMLT2(FCHK2,DBLE(-PI/2),DBLE(PI/2),20,6,XAUX))/(4*PI) 20 - END 561 GARFIELD ================================================== P=FIELD D=FLDIN4 1 ============================ 0 + +DECK,FLDIN4. 1 - SUBROUTINE FLDIN4(XX0,YY0,ZZ0,DDX1,DDY1,DDZ1,DDX2,DDY2,DDZ2,Q, 2 - - NNU,NNV) 3 - *----------------------------------------------------------------------- 4 - * FLDIN4 - Integrates the electric field flux through a parallelogram 5 - * with corners (X0,Y0,Z0), (X0+DX1,Y0+DY1,Z0+DZ1), 6 - * (X0+DX2,Y0+DY2,Z0+DZ2). 7 - * (Last changed on 28/ 5/98.) 8 - *----------------------------------------------------------------------- 9 - implicit none 10.- +SEQ,PRINTPLOT. 11.- +SEQ,CONSTANTS. 12 - REAL XX0,YY0,ZZ0,DDX1,DDY1,DDZ1,DDX2,DDY2,DDZ2,Q 13 - DOUBLE PRECISION X0,Y0,Z0,DX1,DY1,DZ1,DX2,DY2,DZ2,XN,YN,ZN, 14 - - XAUX(6),DGMLT2 15 - INTEGER NNU,NNV,NU,NV 16 - EXTERNAL FCHK4,DGMLT2 17 - COMMON /FCHDA4/ X0,Y0,Z0,DX1,DY1,DZ1,DX2,DY2,DZ2,XN,YN,ZN,NU,NV 18 - *** Create double precision copies of the coordinates. 19 - X0=DBLE(XX0) 20 - Y0=DBLE(YY0) 21 - Z0=DBLE(ZZ0) 22 - DX1=DBLE(DDX1) 23 - DY1=DBLE(DDY1) 24 - DZ1=DBLE(DDZ1) 25 - DX2=DBLE(DDX2) 26 - DY2=DBLE(DDY2) 27 - DZ2=DBLE(DDZ2) 28 - NU=NNU 29 - NV=NNV 30 - *** Check integration points. 31 - IF(NU.LE.1.OR.NV.LE.1)THEN 32 - PRINT *,' !!!!!! FLDIN4 WARNING : Number of points to'// 33 - - ' integrate over is not > 1 ; flux set to 0.' 34 - Q=0 35 - RETURN 36 - ENDIF 37 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ FLDIN4 DEBUG : Number'', 38 - - '' of integration points: '',2I5)') NU,NV 39 - *** Compute the normal vector. 40 - XN=DY1*DZ2-DZ1*DY2 41 - YN=DZ1*DX2-DX1*DZ2 42 - ZN=DX1*DY2-DY1*DX2 43 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ FLDIN4 DEBUG : Norm'', 44 - - '' vector = '',3E12.5)') XN,YN,ZN 45 - *** If this vector has zero norm, return 0 flux. 46 - IF(XN**2+YN**2+ZN**2.LT.1D-10* 47 - - SQRT((DX1**2+DY1**2+DZ1**2)*(DX2**2+DY2**2+DZ2**2)).OR. 48 - - DX1**2+DY1**2+DZ1**2.LT.1D-10*(DX2**2+DY2**2+DZ2**2).OR. 49 - - DX2**2+DY2**2+DZ2**2.LT.1D-10*(DX1**2+DY1**2+DZ1**2))THEN 50 - PRINT *,' !!!!!! FLDIN4 WARNING : Area is not a'// 51 - - ' parallelogram with non-zero area; flux set to 0.' 52 - Q=0 53 - RETURN 54 - ENDIF 55 - *** Perform the integration. 56 - Q=REAL(DGMLT2(FCHK4,0.0D0,1.0D0,NV,6,XAUX)) 57 - END 562 GARFIELD ================================================== P=FIELD D=FLDIN5 1 ============================ 0 + +DECK,FLDIN5. 1 - SUBROUTINE FLDIN5(XX0,YY0,ZZ0,XX1,YY1,ZZ1,XXP,YYP,ZZP,Q,NNU, 2 - - IISIGN) 3 - *----------------------------------------------------------------------- 4 - * FLDIN5 - Integrates the electric field flux through a line from 5 - * (X0,Y0,Z0) to (X1,Y1,Z1) along a direction (XP,YP,ZP). 6 - * (Last changed on 14/ 5/99.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,PRINTPLOT. 10.- +SEQ,CONSTANTS. 11 - REAL XX0,YY0,ZZ0,XX1,YY1,ZZ1,XXP,YYP,ZZP,Q 12 - DOUBLE PRECISION X0,Y0,Z0,X1,Y1,Z1,XP,YP,ZP,XAUX(6),DGMLT1 13 - INTEGER NNU,NU,IISIGN,ISIGN 14 - EXTERNAL FCHK6,DGMLT1 15 - COMMON /FCHDA6/ X0,Y0,Z0,X1,Y1,Z1,XP,YP,ZP,NU,ISIGN 16 - *** Create double precision copies of the coordinates. 17 - X0=DBLE(XX0) 18 - Y0=DBLE(YY0) 19 - Z0=DBLE(ZZ0) 20 - X1=DBLE(XX1) 21 - Y1=DBLE(YY1) 22 - Z1=DBLE(ZZ1) 23 - * Normalise the norm vector. 24 - IF(XXP**2+YYP**2+ZZP**2.GT.0)THEN 25 - XP=DBLE(XXP/SQRT(XXP**2+YYP**2+ZZP**2)) 26 - YP=DBLE(YYP/SQRT(XXP**2+YYP**2+ZZP**2)) 27 - ZP=DBLE(ZZP/SQRT(XXP**2+YYP**2+ZZP**2)) 28 - ELSE 29 - PRINT *,' !!!!!! FLDIN5 WARNING : Normal vector has zero'// 30 - - ' length; flux set to 0.' 31 - Q=0 32 - RETURN 33 - ENDIF 34 - * Copy number of integration intervals. 35 - NU=NNU 36 - * Copy the integration sign. 37 - ISIGN=IISIGN 38 - *** Check integration points. 1 562 P=FIELD D=FLDIN5 2 PAGE 856 39 - IF(NU.LE.1)THEN 40 - PRINT *,' !!!!!! FLDIN5 WARNING : Number of points to'// 41 - - ' integrate over is not > 1 ; flux set to 0.' 42 - Q=0 43 - RETURN 44 - ENDIF 45 - *** Ensure the segment has non-zero length. 46 - IF((X0-X1)**2+(Y0-Y1)**2+(Z0-Z1)**2.LE.0)THEN 47 - PRINT *,' !!!!!! FLDIN5 WARNING : Segment has zero'// 48 - - ' length; flux set to 0.' 49 - Q=0 50 - RETURN 51 - * Segment should be perpendicular to the norm vector. 52 - ELSEIF(ABS((X1-X0)*XP+(Y1-Y0)*YP+(Z1-Z0)*ZP).GT. 53 - - 1D-4*SQRT(((X0-X1)**2+(Y0-Y1)**2+(Z0-Z1)**2)* 54 - - (XP**2+YP**2+ZP**2)))THEN 55 - C print *,' product: ',ABS((X1-X0)*XP+(Y1-Y0)*YP+(Z1-Z0)*ZP) 56 - C print *,' length: ',SQRT((X0-X1)**2+(Y0-Y1)**2+(Z0-Z1)**2) 57 - C print *,' norm: ',sqrt(XP**2+YP**2+ZP**2) 58 - PRINT *,' !!!!!! FLDIN5 WARNING : Segment is not'// 59 - - ' perpendicular to norm vector; flux set to 0.' 60 - Q=0 61 - RETURN 62 - ENDIF 63 - *** Perform the integration. 64 - Q=REAL(DGMLT1(FCHK6,0.0D0,1.0D0,NU,6,XAUX))* 65 - - SQRT((X0-X1)**2+(Y0-Y1)**2+(Z0-Z1)**2) 66 - END 563 GARFIELD ================================================== P=FIELD D=FCHK1 1 ============================ 0 + +DECK,FCHK1. 1 - SUBROUTINE FCHK1(M,U1,F1,X) 2 - *----------------------------------------------------------------------- 3 - * FCHK1 - One of 2 auxiliary routines for verifying that space 4 - * charges indeed have the proper charge. 5 - * (Last changed on 8/ 4/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8 - DOUBLE PRECISION U1(*),F1(*),X(2),XC,YC,ZC,RC 9 - REAL XF,YF,ZF,EX,EY,EZ,ETOT,VOLT 10 - INTEGER ILOC,L,M 11 - COMMON /FCHDAT/ XC,YC,ZC,RC 12 - *** Loop over the positions. 13 - DO 10 L=1,M 14 - X(1)=U1(L) 15 - XF=XC+COS(X(1))*COS(X(2))*RC 16 - YF=YC+SIN(X(1))*COS(X(2))*RC 17 - ZF=ZC+ SIN(X(2))*RC 18 - CALL EFIELD(XF,YF,ZF,EX,EY,EZ,ETOT,VOLT,0,ILOC) 19 - F1(L)=DBLE((EX*COS(X(1))+EY*SIN(X(1)))*COS(X(2))+EZ*SIN(X(2))) 20 - 10 CONTINUE 21 - END 564 GARFIELD ================================================== P=FIELD D=FCHK2 1 ============================ 0 + +DECK,FCHK2. 1 - SUBROUTINE FCHK2(M,U2,F2,X) 2 - *----------------------------------------------------------------------- 3 - * FCHK2 - One of 2 auxiliary routines for verifying that space 4 - * charges indeed have the proper charge. 5 - * (Last changed on 8/ 4/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,CONSTANTS. 9 - DOUBLE PRECISION U2(*),F2(*),X(2),XC,YC,ZC,RC,DGMLT1 10 - INTEGER L,M 11 - EXTERNAL FCHK1,DGMLT1 12 - COMMON /FCHDAT/ XC,YC,ZC,RC 13 - *** Loop over the positions. 14 - DO 10 L=1,M 15 - X(2)=U2(L) 16 - F2(L)=RC**2*COS(X(2))*DGMLT1(FCHK1,0.0D0,DBLE(2*PI),20,6,X) 17 - 10 CONTINUE 18 - END 565 GARFIELD ================================================== P=FIELD D=FCHK3 1 ============================ 0 + +DECK,FCHK3. 1 - SUBROUTINE FCHK3(M,U1,F1,X) 2 - *----------------------------------------------------------------------- 3 - * FCHK3 - One of 2 auxiliary routines for verifying that space 4 - * charges indeed have the proper charge. 5 - * (Last changed on 8/ 4/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8 - DOUBLE PRECISION U1(*),F1(*),X(2),XC,YC,ZC,RC 9 - REAL XF,YF,EX,EY,EZ,ETOT,VOLT 10 - INTEGER ILOC,L,M 11 - COMMON /FCHDAT/ XC,YC,ZC,RC 12 - *** Loop over the positions. 13 - DO 10 L=1,M 14 - X(1)=U1(L) 15 - XF=XC+COS(X(1))*RC 16 - YF=YC+SIN(X(1))*RC 17 - CALL EFIELD(XF,YF,0.0,EX,EY,EZ,ETOT,VOLT,0,ILOC) 18 - F1(L)=RC*DBLE(EX*COS(X(1))+EY*SIN(X(1))) 19 - 10 CONTINUE 20 - END 566 GARFIELD ================================================== P=FIELD D=FCHK4 1 ============================ 0 + +DECK,FCHK4. 1 - SUBROUTINE FCHK4(M,U2,F2,X) 2 - *----------------------------------------------------------------------- 3 - * FCHK4 - One of 2 auxiliary routines for calculating a flux. 1 566 P=FIELD D=FCHK4 2 PAGE 857 4 - * (Last changed on 28/ 5/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,CONSTANTS. 8 - DOUBLE PRECISION U2(*),F2(*),X(2),DGMLT1, 9 - - X0,Y0,Z0,DX1,DY1,DZ1,DX2,DY2,DZ2,XN,YN,ZN 10 - INTEGER L,M,NU,NV 11 - EXTERNAL FCHK5,DGMLT1 12 - COMMON /FCHDA4/ X0,Y0,Z0,DX1,DY1,DZ1,DX2,DY2,DZ2,XN,YN,ZN,NU,NV 13 - *** Loop over the positions. 14 - DO 10 L=1,M 15 - X(2)=U2(L) 16 - F2(L)=DGMLT1(FCHK5,0.0D0,1.0D0,NU,6,X) 17 - 10 CONTINUE 18 - END 567 GARFIELD ================================================== P=FIELD D=FCHK5 1 ============================ 0 + +DECK,FCHK5. 1 - SUBROUTINE FCHK5(M,U1,F1,X) 2 - *----------------------------------------------------------------------- 3 - * FCHK5 - One of 2 auxiliary routines for calculating a flux. 4 - * (Last changed on 28/ 5/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - DOUBLE PRECISION U1(*),F1(*),X(2), 8 - - X0,Y0,Z0,DX1,DY1,DZ1,DX2,DY2,DZ2,XN,YN,ZN 9 - REAL XF,YF,ZF,EX,EY,EZ,ETOT,VOLT 10 - INTEGER ILOC,L,M,NU,NV 11 - COMMON /FCHDA4/ X0,Y0,Z0,DX1,DY1,DZ1,DX2,DY2,DZ2,XN,YN,ZN,NU,NV 12 - *** Loop over the positions. 13 - DO 10 L=1,M 14 - X(1)=U1(L) 15 - XF=X0+X(1)*DX1+X(2)*DX2 16 - YF=Y0+X(1)*DY1+X(2)*DY2 17 - ZF=Z0+X(1)*DZ1+X(2)*DZ2 18 - CALL EFIELD(XF,YF,ZF,EX,EY,EZ,ETOT,VOLT,0,ILOC) 19 - F1(L)=EX*XN+EY*YN+EZ*ZN 20 - 10 CONTINUE 21 - END 568 GARFIELD ================================================== P=FIELD D=FCHK6 1 ============================ 0 + +DECK,FCHK6. 1 - SUBROUTINE FCHK6(M,U1,F1,X) 2 - *----------------------------------------------------------------------- 3 - * FCHK6 - One of 2 auxiliary routines for calculating a flux. 4 - * (Last changed on 13/ 5/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7 - DOUBLE PRECISION U1(*),F1(*),X(2), 8 - - X0,Y0,Z0,X1,Y1,Z1,XP,YP,ZP 9 - REAL XF,YF,ZF,EX,EY,EZ,ETOT,VOLT 10 - INTEGER ILOC,L,M,NU,ISIGN 11 - COMMON /FCHDA6/ X0,Y0,Z0,X1,Y1,Z1,XP,YP,ZP,NU,ISIGN 12 - *** Loop over the positions. 13 - DO 10 L=1,M 14 - X(1)=U1(L) 15 - XF=X0+X(1)*(X1-X0) 16 - YF=Y0+X(1)*(Y1-Y0) 17 - ZF=Z0+X(1)*(Z1-Z0) 18 - CALL EFIELD(XF,YF,ZF,EX,EY,EZ,ETOT,VOLT,0,ILOC) 19 - IF(ISIGN.EQ.0)THEN 20 - F1(L)=EX*XP+EY*YP+EZ*ZP 21 - ELSEIF(ISIGN*(EX*XP+EY*YP+EZ*ZP).GT.0)THEN 22 - F1(L)=ABS(EX*XP+EY*YP+EZ*ZP) 23 - ELSE 24 - F1(L)=-1 25 - ENDIF 26 - 10 CONTINUE 27 - END 569 GARFIELD ================================================== P=ZERO D= 1 ============================ 0 + +PATCH,ZERO. 570 GARFIELD ================================================== P=ZERO D=ZROTST 1 ============================ 0 + +DECK,ZROTST. 1 - SUBROUTINE ZROTST 2.- +SEQ,DIMENSIONS. 3.- +SEQ,CELLDATA. 4.- +SEQ,PRINTPLOT. 5.- +SEQ,ZERODATA. 6 - 1010 FORMAT(' ',3F10.3) 7 - *** REST VAN DE PARAMETERS 8 - 10 CONTINUE 9 - PRINT *,' Please enter your next ZERO instruction:' 10 - CALL INPWRD(NWORD) 11 - IF(NWORD.EQ.0)GOTO 10 12 - IF(INPCMP(1,'ZOEK').NE.0)THEN 13 - CALL INPRDR(2,ZXMIN,PXMIN) 14 - CALL INPRDR(3,ZYMIN,PYMIN) 15 - CALL INPRDR(4,ZXMAX,PXMAX) 16 - CALL INPRDR(5,ZYMAX,PYMAX) 17 - CALL ZROFND(ZXMIN,ZYMIN,ZXMAX,ZYMAX,IFAIL) 18 - PRINT *,' # NULPUNTEN: ',NZ,' IFAIL=',IFAIL 19 - DO 20 I=1,NZ 20 - PRINT 1010,XZ(I),YZ(I),PZ(I) 21 - 20 CONTINUE 22 - ELSEIF(INPCMP(1,'F#IND').NE.0)THEN 23 - CALL INPRDR(2,ZXMIN,PXMIN) 24 - CALL INPRDR(3,ZYMIN,PYMIN) 25 - CALL INPRDR(4,ZXMAX,PXMAX) 26 - CALL INPRDR(5,ZYMAX,PYMAX) 27 - CALL ZROLOC(X0,Y0,ZXMIN,ZYMIN,ZXMAX,ZYMAX,IFAIL) 1 570 P=ZERO D=ZROTST 2 PAGE 858 28 - PRINT *,' (X0,Y0)=',X0,Y0,' IFAIL=',IFAIL 29 - ELSEIF(INPCMP(1,'ST#OP').NE.0)THEN 30 - RETURN 31 - ELSE 32 - PRINT *,' Unknown instruction.' 33 - ENDIF 34 - GOTO 10 35 - END 571 GARFIELD ================================================== P=ZERO D=ZROFND 1 ============================ 0 + +DECK,ZROFND. 1 - SUBROUTINE ZROFND(ZXMIN,ZYMIN,ZXMAX,ZYMAX,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * ZROFND - This routine tries to find all zeros of the driftfield, 4 - * provided they are located in the rectangle (ZXMIN,ZYMIN), 5 - * (ZXMAX,ZYMAX). It stores them in the vector XZ,YZ. 6 - * VARIABLES: XLST,YDST,XRST,YUST : Rectangle searched for zeros 7 - * IDIRST : -1: Rectangle cut into 2 along y-axis, 8 - * +1: as -1, but the 2 halves are finished, 9 - * -2, +2: as -1 and +1, cut along the x-axis 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,ZERODATA. 13.- +SEQ,PRINTPLOT. 14.- +SEQ,CELLDATA. 15 - DIMENSION XLST(MXZERO),XRST(MXZERO),YDST(MXZERO),YUST(MXZERO) 16 - INTEGER NZST(MXZERO),IDIRST(MXZERO),ZROCNT 17 - EXTERNAL ZROCNT 18 - *** Define some output formats. 19 - *** Identify the routine and start debugging output, if requested. 20 - IF(LIDENT)PRINT *,' /// ROUTINE ZROFND ///' 21 - IF(LDEBUG)PRINT *,' ++++++ ZROFND DEBUG : Start of debug', 22 - - ' output' 23 - *** Initialise some global parameters. 24 - NZ=0 25 - NFC=0 26 - EMIN=1.0E-5 27 - DAMIN=0.10 28 - DAMAX=0.30 29 - DPMIN=0.01 30 - DPMAX=0.20 31 - ZROSET=.FALSE. 32 - *** Initialise the search stack. 33 - IST=1 34 - NZ=0 35 - XLST(1)=ZXMIN 36 - XRST(1)=ZXMAX 37 - YDST(1)=ZYMIN 38 - YUST(1)=ZYMAX 39 - IDIRST(1)=-1 40 - JWARN=0 41 - IFAIL=0 42 - *** Begin of 'recursive' loop, find no of zeros in the rectangle. 43 - 10 CONTINUE 44 - IF(LDEBUG)WRITE(*,'(/26X,''IST='',I3,'' Area='',4F10.3)') 45 - - IST,XLST(IST),YDST(IST),XRST(IST),YUST(IST) 46 - NZST(IST)=ZROCNT(XLST(IST),YDST(IST),XRST(IST),YUST(IST),IFAIL) 47 - IF(IFAIL.NE.0)THEN 48 - PRINT *,' ###### ZROFND ERROR : Search abandoned because', 49 - - ' of a zero count error' 50 - RETURN 51 - ENDIF 52 - IF(NZST(IST).LT.0)THEN 53 - PRINT *,' ###### ZROFND ERROR : Number of zeros < 0', 54 - - ' (program bug) ; search abandoned' 55 - IFAIL=1 56 - RETURN 57 - ENDIF 58 - IF(LDEBUG)WRITE(*,'(34X,''The area contains '',I3,'' zeros.'')') 59 - - NZST(IST) 60 - *** Subtract the number of zeros from the number for the larger area. 61 - IF(IST.NE.1)NZST(IST-1)=NZST(IST-1)-NZST(IST) 62 - *** 1 zero in the rectangle, check there is space left to store it, 63 - IF(NZST(IST).EQ.1)THEN 64 - IF(NZ+1.GT.MXZERO)THEN 65 - PRINT *,' !!!!!! ZROFND WARNING : number of', 66 - - ' zeros exceeds MXZERO (=',MXZERO,');', 67 - - ' remaining zeros not considered.' 68 - PRINT *,' Increase the', 69 - - ' MXZERO parameter to at least ',NZST(1), 70 - - ' and recompile the program.' 71 - IFAIL=1 72 - RETURN 73 - ENDIF 74 - * and try to locate it. 75 - NZ=NZ+1 76 - CALL ZROLOC(XZ(NZ),YZ(NZ),XLST(IST),YDST(IST), 77 - - XRST(IST),YUST(IST),IFAIL) 78 - IF(IFAIL.NE.0)NZ=NZ-1 79 - ENDIF 80 - *** No zeros left, climb in the stack until an unfinished level is found 81 - IF((NZST(IST).EQ.0.OR.NZST(IST).EQ.1).AND.IFAIL.EQ.0)THEN 82 - 20 CONTINUE 83 - IST=IST-1 84 - IF(IST.LT.1)GOTO 200 85 - * warn if negative zero counts are found, 86 - IF(NZST(IST).LT.0)THEN 87 - IF(LDEBUG)WRITE(*,'(26X,''At IST='',I3,'' (flagged '', 88 - - I2,'') negative zero count: '',I3,''.'')') 89 - - IST,IDIRST(IST),NZST(IST) 90 - JWARN=JWARN+1 91 - * warn for inconsistent counts (flagged finished but zeros left), 92 - ELSEIF(IDIRST(IST).GT.0.AND.NZST(IST).NE.0)THEN 93 - IF(LDEBUG)WRITE(*,'(26X,''At IST='',I3,'' (flagged '', 94 - - ''finished) '',I3,'' zeros left.'')')IST,NZST(IST) 1 571 P=ZERO D=ZROFND 2 PAGE 859 95 - JWARN=JWARN+1 96 - ENDIF 97 - * continue going upwards if the level is finished. 98 - IF(IDIRST(IST).GT.0.OR.NZST(IST).LE.0)GOTO 20 99 - * Go one level deeper again setting a new search area. 100 - IST=IST+1 101 - IF(IDIRST(IST-1).EQ.-1)THEN 102 - IDIRST(IST-1)=+1 103 - XLST(IST)=XRST(IST) 104 - XRST(IST)=XRST(IST-1) 105 - ELSEIF(IDIRST(IST-1).EQ.-2)THEN 106 - IDIRST(IST-1)=+2 107 - YDST(IST)=YUST(IST) 108 - YUST(IST)=YUST(IST-1) 109 - ENDIF 110 - *** Handle the case there is more than one zero. 111 - ELSEIF(NZST(IST).GT.1.OR.IFAIL.NE.0)THEN 112 - * Make sure there is room in the stack, 113 - IF(IST+1.GT.MXZERO)THEN 114 - PRINT *,' !!!!!! ZROFND WARNING : Stack exhausted;', 115 - - ' search for zeros abandoned.' 116 - PRINT *,' Increase the', 117 - - ' MXZERO parameter and recompile the program.' 118 - IFAIL=1 119 - RETURN 120 - ENDIF 121 - * Split the area in 2, flag both halves as unfinished. 122 - IF(XRST(IST)-XLST(IST).GT.YUST(IST)-YDST(IST))THEN 123 - IDIRST(IST)=-1 124 - XLST(IST+1)=XLST(IST) 125 - XRST(IST+1)=0.5*(XLST(IST)+XRST(IST)) 126 - YDST(IST+1)=YDST(IST) 127 - YUST(IST+1)=YUST(IST) 128 - ELSE 129 - IDIRST(IST)=-2 130 - XLST(IST+1)=XLST(IST) 131 - XRST(IST+1)=XRST(IST) 132 - YDST(IST+1)=YDST(IST) 133 - YUST(IST+1)=0.5*(YDST(IST)+YUST(IST)) 134 - ENDIF 135 - IST=IST+1 136 - ENDIF 137 - GOTO 10 138 - * Normal end of this routine, warn for inconsistent zero counts. 139 - 200 CONTINUE 140 - IF(JWARN.NE.0)WRITE(*,'(/,'' !!!!!! ZROFND WARNING :'', 141 - - '' Number of detected inconsistent zero counts='',I3,/,25X, 142 - - '' zeros may well be missing and/or counted twice'')') JWARN 143 - IFAIL=0 144 - IF(LDEBUG)WRITE(*,'(/26X,''A total of '',I3,'' zeros has been'', 145 - - '' located,'',/,26X,''requiring '',I4,'' function calls.''// 146 - - '' ++++++ ZROFND DEBUG : End of debug output.'')') 147 - - NZ,NFC 148 - END 572 GARFIELD ================================================== P=ZERO D=ZROCNT 1 ============================ 0 + +DECK,ZROCNT. 1 - INTEGER FUNCTION ZROCNT(ZXMIN,ZYMIN,ZXMAX,ZYMAX,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * ZROCNT - Determines the number of zeros in the rectangle (ZXMIN, 4 - * ZYMIN) to (ZXMAX,ZYMAX), counting the rotation of (Ex,Ey). 5 - * Variables : DATOT : Total change in argument. 6 - * DA : Change in argument over the last step. 7 - * DP : Stepsize along the border of the area. 8 - * P : Current point on the border. 9 - *----------------------------------------------------------------------- 10.- +SEQ,DIMENSIONS. 11.- +SEQ,PRINTPLOT. 12.- +SEQ,CELLDATA. 13.- +SEQ,ZERODATA. 14 - LOGICAL OK,INWIRE 15 - *** Define statement functions. 16 - ARGMOD(ARG1,ARG2)=(ARG1-ARG2)-AINT(2.0*(ARG1-ARG2)) 17 - C PRINT*,' NZ ?' 18 - C READ*,ZROCNT 19 - C IFAIL=0 20 - C RETURN 21 - *** Initialise several variables. 22 - DATOT=0.0 23 - OK =.FALSE. 24 - P =0.0 25 - DP =0.1 26 - JWARN=0 27 - *** Count the zeros. 28 - 10 CONTINUE 29 - ARG2=ZROARG(P,ZXMIN,ZYMIN,ZXMAX,ZYMAX,INWIRE) 30 - IF(.NOT.INWIRE)THEN 31 - IF(OK)THEN 32 - DA=ARGMOD(ARG1,ARG2) 33 - IF(ABS(DA).GT.DAMAX)THEN 34 - DP=DP/2.0 35 - P=P-DP 36 - IF(DP.GT.DPMIN)GOTO 10 37 - JWARN=JWARN+1 38 - DP=DP*2.0 39 - ELSEIF(ABS(DA).LT.DAMIN)THEN 40 - DP=DP*2.0 41 - ENDIF 42 - DP=MIN(DP,DPMAX) 43 - DATOT=DATOT+DA 44 - ELSE 45 - ARG0=ARG2 46 - OK=.TRUE. 47 - ENDIF 48 - ARG1=ARG2 1 572 P=ZERO D=ZROCNT 2 PAGE 860 49 - ARG3=ARG2 50 - ENDIF 51 - P=P+DP 52 - IF(P.LE.4.0)GOTO 10 53 - IF(OK)DATOT=DATOT+ARGMOD(ARG3,ARG0) 54 - *** Count the number of wires in the rectangle. 55 - DO 20 I=1,NWIRE 56 - IF(X(I).GT.ZXMIN.AND.X(I).LE.ZXMAX.AND. 57 - - Y(I).GT.ZYMIN.AND.Y(I).LE.ZYMAX)DATOT=DATOT+1.0 58 - 20 CONTINUE 59 - *** And set the number of zeros. 60 - ZROCNT=INT(DATOT+0.5) 61 - *** Check that OK is true and that JWARN is 0. 62 - IFAIL=0 63 - IF(.NOT.OK)IFAIL=1 64 - IF(JWARN.NE.0)PRINT *,' !!!!!! ZROCNT WARNING : Step size ', 65 - - JWARN,' times too small; possibly incorrect zero count' 66 - IF(LDEBUG)WRITE(*,'(26X,''Change in argument='',F10.3, 67 - - '', number of zeros='',I3)') DATOT,ZROCNT 68 - END 573 GARFIELD ================================================== P=ZERO D=ZROLOC 1 ============================ 0 + +DECK,ZROLOC. 1 - SUBROUTINE ZROLOC(XMIN,YMIN,ZXMIN,ZYMIN,ZXMAX,ZYMAX,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * ZROLOC - Subroutine which tries to locate a zero accurately given 4 - * a search area. It starts picking points at random, then it 5 - * continues with the rank 2 Broyden, Fletcher, Goldfarb and 6 - * Shanno procedure. By changing the ZGAMMA and ZTHETA parms, 7 - * the DFP method (eg) can be obtained. This routine gives 8 - * reasonable results for analytic functions only. 9 - * VARIABLES : (XMIN,YMIN) : Position of the zero. 10 - * (Last changed on 4/ 4/95.) 11 - *----------------------------------------------------------------------- 12.- +SEQ,DIMENSIONS. 13.- +SEQ,ZERODATA. 14.- +SEQ,PRINTPLOT. 15 - REAL H(2,2),HNEW(2,2),P(2),Q(2) 16 - *** Preset some parameters. 17 - IFAIL=0 18 - *** Perform a random search to find a suitable starting point. 19 - EOLD=0.0 20 - DO 300 I=1,100 21 - XRNDM=ZXMIN+(ZXMAX-ZXMIN)*RNDM(I+1) 22 - YRNDM=ZYMIN+(ZYMAX-ZYMIN)*RNDM(I-1) 23 - CALL EFIELD(XRNDM,YRNDM,0.0,EX,EY,EZ,ERNDM,VOLT,0,ILOC) 24 - NFC=NFC+1 25 - IF(ERNDM.NE.0.0.AND.(INIT.EQ.0.OR.ERNDM.LT.EOLD))THEN 26 - XOLD=XRNDM 27 - YOLD=YRNDM 28 - EOLD=ERNDM 29 - INIT=1 30 - ENDIF 31 - 300 CONTINUE 32 - * Warn if no starting point has been found 33 - IF(INIT.EQ.0)THEN 34 - PRINT *,' !!!!!! ZROLOC WARNING : Unable to find a suitable', 35 - - ' random starting point' 36 - IFAIL=1 37 - RETURN 38 - ENDIF 39 - IF(LDEBUG)WRITE(*,'(/26X,''Search start '',2F11.4, 40 - - '' (Etot='',E10.3,'').''/)') XOLD,YOLD,EOLD 41 - *** Preset the matrix H to a surely pos. def. unity. 42 - H(1,1)=1.0 43 - H(1,2)=0.0 44 - H(2,1)=0.0 45 - H(2,2)=1.0 46 - *** Calculate the gradient of the function at the starting point. 47 - CALL EFIELD(XOLD+1.0E-4*(ABS(XOLD)+1.0),YOLD,0.0, 48 - - EX,EY,EZ,ETOTX1,VOLT,0,ILOC) 49 - CALL EFIELD(XOLD-1.0E-4*(ABS(XOLD)+1.0),YOLD,0.0, 50 - - EX,EY,EZ,ETOTX2,VOLT,0,ILOC) 51 - CALL EFIELD(XOLD,YOLD+1.0E-4*(ABS(YOLD)+1.0),0.0, 52 - - EX,EY,EZ,ETOTY1,VOLT,0,ILOC) 53 - CALL EFIELD(XOLD,YOLD-1.0E-4*(ABS(YOLD)+1.0),0.0, 54 - - EX,EY,EZ,ETOTY2,VOLT,0,ILOC) 55 - NFC=NFC+4 56 - G1=(ETOTX1-ETOTX2)/(2.0E-4*(ABS(XOLD)+1.0)) 57 - G2=(ETOTY1-ETOTY2)/(2.0E-4*(ABS(YOLD)+1.0)) 58 - IF(G1.EQ.0.0.AND.G2.EQ.0.0)THEN 59 - IF(LDEBUG)WRITE(*,'(26X,''Starting point is stationary.'')') 60 - XNEW=XOLD 61 - YNEW=YOLD 62 - ENEW=EOLD 63 - GOTO 500 64 - ENDIF 65 - *** Begin of the Newton-like search loop. 66 - NSTEPS=0 67 - 310 CONTINUE 68 - NSTEPS=NSTEPS+1 69 - * Set a suitable direction for the linear minimisation. 70 - S1=H(1,1)*G1+H(1,2)*G2 71 - S2=H(2,1)*G1+H(2,2)*G2 72 - IF(LDEBUG)WRITE(*,'(26X,''Search direction: '',2F11.4)') -S1,-S2 73 - ** Perform a linear minimisation, first check length of direction, 74 - IF(S1**2+S2**2.EQ.0.0)THEN 75 - IF(LDEBUG)WRITE(*,'(26X,''The step size is zero,'', 76 - - '' search aborted in step '',I2,''.''/)') NSTEPS 77 - IFAIL=1 78 - XNEW=XOLD 79 - YNEW=YOLD 80 - ENEW=EOLD 81 - GOTO 500 82 - ENDIF 1 573 P=ZERO D=ZROLOC 2 PAGE 861 83 - * copy current estimate to the variables used for linear minimisation, 84 - XLIN=XOLD 85 - YLIN=YOLD 86 - ELIN=EOLD 87 - * calculate in the neigbourhood of the present best point, 88 - EPS=0.1*(1.0+SQRT(XLIN**2+YLIN**2))/(S1**2+S2**2) 89 - CALL EFIELD (XLIN+EPS*S1,YLIN+EPS*S2,0.0, 90 - - EX,EY,EZ,ELINP,VOLT,0,ILOC) 91 - CALL EFIELD (XLIN-EPS*S1,YLIN-EPS*S2,0.0, 92 - - EX,EY,EZ,ELINM,VOLT,0,ILOC) 93 - NFC=NFC+2 94 - * find a rough estimate for a minimum, 95 - IF(ELINP+ELINM-2*ELIN.LE.0)THEN 96 - IF(LDEBUG)WRITE(*,'(26X,''Second derivative is zero, no'', 97 - - '' second order guess can be done.'')') 98 - IF(ELINP.EQ.ELINM)THEN 99 - IF(LDEBUG)WRITE(*,'(26X,''First derivative is also 0'', 100 - - '' minimum assumed.'')') 101 - GOTO 450 102 - ENDIF 103 - IF(LDEBUG)WRITE(*,'(26X,''A linear guess is attempted.'')') 104 - XLIN1=XLIN-S1*ELIN*EPS/(ELINP-ELINM) 105 - YLIN1=YLIN-S2*ELIN*EPS/(ELINP-ELINM) 106 - ELSE 107 - XLIN1=XLIN-S1*(EPS/2)*(ELINP-ELINM)/(ELINP-2*ELIN+ELINM) 108 - YLIN1=YLIN-S2*(EPS/2)*(ELINP-ELINM)/(ELINP-2*ELIN+ELINM) 109 - ENDIF 110 - IF(LDEBUG)WRITE(*,'(26X,''Rough estimate is ('',E10.3,'','', 111 - - E10.3,'').'')') XLIN1,YLIN1 112 - * make sure this point has indeed a amaller E than (XLIN,YLIN), 113 - NLIN=0 114 - 400 CONTINUE 115 - NLIN=NLIN+1 116 - IF(NLIN.GT.5)THEN 117 - IF(LDEBUG)WRITE(*,'(26X,''Maximum number of'', 118 - - '' contractions exceeded.'')') 119 - GOTO 450 120 - ENDIF 121 - CALL EFIELD(XLIN1,YLIN1,0.0,EX,EY,EZ,ELIN1,VOLT,0,ILOC) 122 - PRINT *,' ELIN1=',ELIN1 123 - NFC=NFC+1 124 - IF(ELIN1.GT.ELIN)THEN 125 - XLIN1=(XLIN+XLIN1)/2 126 - YLIN1=(YLIN+YLIN1)/2 127 - GOTO 400 128 - ENDIF 129 - IF(LDEBUG.AND.NLIN.GT.1)WRITE(*,'(26X,''Rough estimate'', 130 - - '' corrected '',I2,'' times.'')') NLIN 131 - * next set a point 'behind' the minimum, 132 - NLIN=0 133 - 410 CONTINUE 134 - NLIN=NLIN+1 135 - IF(NLIN.GT.5)THEN 136 - IF(LDEBUG)WRITE(*,'(26X,''Maximum number of'', 137 - - '' expansions exceeded.'')') 138 - GOTO 440 139 - ENDIF 140 - XLIN2=2*XLIN1-XLIN 141 - YLIN2=2*YLIN1-YLIN 142 - CALL EFIELD(XLIN2,YLIN2,0.0,EX,EY,EZ,ELIN2,VOLT,0,ILOC) 143 - PRINT *,' ELIN2=',ELIN2 144 - NFC=NFC+1 145 - IF(ELIN2.LT.ELIN1)THEN 146 - XLIN1=XLIN2 147 - YLIN1=YLIN2 148 - ELIN1=ELIN2 149 - GOTO 410 150 - ENDIF 151 - IF(LDEBUG.AND.NLIN.GT.1)WRITE(*,'(26X,''Over shoot point has'', 152 - - '' been corrected '',I2,'' times.'')') NLIN 153 - * perform a parabolic minimisation: first find improved minimum, 154 - NPAR=0 155 - 420 CONTINUE 156 - NPAR=NPAR+1 157 - IF(NPAR.GT.5)THEN 158 - IF(LDEBUG)WRITE(*,'(26X,''Maximum number of'', 159 - - '' parabolic loops exceeded.'')') 160 - XLIN=XPAR 161 - YLIN=YPAR 162 - ELIN=EPAR 163 - GOTO 450 164 - ENDIF 165 - C1=SQRT((XLIN1-XLIN)**2+(YLIN2-YLIN)**2) 166 - C2=SQRT((XLIN2-XLIN)**2+(YLIN2-YLIN)**2) 167 - CPAR=0.5*((C1**2-C2**2)*ELIN+C2**2*ELIN1-C1**2*ELIN2)/ 168 - - ((C1-C2)*ELIN+C2*ELIN1-C1*ELIN2) 169 - XPAR=XLIN+(XLIN2-XLIN)*(CPAR/C2) 170 - YPAR=YLIN+(YLIN2-YLIN)*(CPAR/C2) 171 - CALL EFIELD(XPAR,YPAR,0.0,EX,EY,EZ,EPAR,VOLT,0,ILOC) 172 - NFC=NFC+1 173 - IF(EPAR.GT.ELIN1)THEN 174 - IF(LDEBUG)WRITE(*,'(26X,''Parabolic minimum exceeds'', 175 - - '' current minimum.'')') 176 - XLIN=XLIN1 177 - YLIN=YLIN1 178 - ELIN=ELIN1 179 - GOTO 450 180 - ENDIF 181 - * check convergence criteria 182 - IF(ABS(EPAR-ELIN1).LT.1.0E-3*ELIN1.OR.EPAR.LT.EMIN)THEN 183 - IF(LDEBUG)WRITE(*,'(26X,''Convergence criteria satisfied'', 184 - - '' after '',I2,'' parabolic loops.'')') NPAR 185 - XLIN=XPAR 186 - YLIN=YPAR 187 - ELIN=EPAR 188 - GOTO 450 1 573 P=ZERO D=ZROLOC 3 PAGE 862 189 - ENDIF 190 - * shift the data points and perform a new parabolic minimastion, 191 - IF(CPAR.LT.C1)THEN 192 - XLIN=XLIN1 193 - YLIN=YLIN1 194 - ELIN=ELIN1 195 - ELSE 196 - XLIN2=XLIN1 197 - YLIN2=YLIN1 198 - ELIN2=ELIN1 199 - ENDIF 200 - XLIN1=XPAR 201 - YLIN1=YPAR 202 - ELIN1=EPAR 203 - GOTO 420 204 - * no convergence: abort the search loop and jump to the end, 205 - 440 CONTINUE 206 - IF(LDEBUG)WRITE(*,'(26X,''The linear search did not converge,'', 207 - - '' search aborted.''/)') 208 - IFAIL=1 209 - XNEW=XLIN 210 - YNEW=YLIN 211 - ENEW=ELIN 212 - GOTO 500 213 - * end of linear search loop. 214 - 450 CONTINUE 215 - * make sure the new point is in the right direction. 216 - IF(S1*(XLIN-XOLD).LE.0.0.AND.S2*(YLIN-YOLD).LE.0.0)THEN 217 - XNEW=XLIN 218 - YNEW=YLIN 219 - ENEW=ELIN 220 - ELSE 221 - IF(LDEBUG)WRITE(*,'(26X,''The result of the linear'', 222 - - '' minimisation is not accepted''/29X,''because'', 223 - - '' CFAC is negative. CFAC is replaced by 1.'')') 224 - XNEW=XOLD-S1 225 - YNEW=YOLD-S2 226 - CALL EFIELD(XNEW,YNEW,0.0,EX,EY,EZ,ENEW,VOLT,0,ILOC) 227 - NFC=NFC+1 228 - ENDIF 229 - IF(LDEBUG)WRITE(*,'(26X,''New estimate '',2F11.4,'' (Etot='', 230 - - E10.3,'').''/)') XNEW,YNEW,ENEW 231 - ** Before proceeding further, check whether we are satisfied. 232 - IF(ABS(EOLD-ENEW).LT.1.0E-4*(ABS(EOLD)+ABS(ENEW)))THEN 233 - IF(LDEBUG)WRITE(*,'(26X,''Change in E stop criterion'', 234 - - '' is satisfied in loop '',I2,''.'')') NSTEPS 235 - GOTO 500 236 - ENDIF 237 - IF(ABS(XOLD-XNEW)*1.0E4.LT.ABS(XOLD)+ABS(XNEW).AND. 238 - - ABS(YOLD-YNEW)*1.0E4.LT.ABS(YOLD)+ABS(YNEW))THEN 239 - IF(LDEBUG)WRITE(*,'(26X,''Position change stop criterion'', 240 - - '' is satisfied in loop '',I2,''.'')') NSTEPS 241 - GOTO 500 242 - ENDIF 243 - IF(ENEW.LT.EMIN)THEN 244 - IF(LDEBUG)WRITE(*,'(26X,''Absolute value of E criterion'', 245 - - '' is satisfied in loop '',I2,''.'')') NSTEPS 246 - GOTO 500 247 - ENDIF 248 - ** Update H, calculate the gradient of the function at (XNEW,YNEW), 249 - CALL EFIELD(XNEW+1.0E-4*(ABS(XNEW)+1.0),YNEW,0.0, 250 - - EX,EY,EZ,ETOTX1,VOLT,0,ILOC) 251 - CALL EFIELD(XNEW-1.0E-4*(ABS(XNEW)+1.0),YNEW,0.0, 252 - - EX,EY,EZ,ETOTX2,VOLT,0,ILOC) 253 - CALL EFIELD(XNEW,YNEW+1.0E-4*(ABS(YNEW)+1.0),0.0, 254 - - EX,EY,EZ,ETOTY1,VOLT,0,ILOC) 255 - CALL EFIELD(XNEW,YNEW-1.0E-4*(ABS(YNEW)+1.0),0.0, 256 - - EX,EY,EZ,ETOTY2,VOLT,0,ILOC) 257 - NFC=NFC+4 258 - G1NEW=(ETOTX1-ETOTX2)/(2.0E-4*(ABS(XNEW)+1.0)) 259 - G2NEW=(ETOTY1-ETOTY2)/(2.0E-4*(ABS(YNEW)+1.0)) 260 - IF(G1NEW.EQ.0.0.AND.G2NEW.EQ.0.0)THEN 261 - IF(LDEBUG)WRITE(*,'(26X,''Truly stationary point found in'', 262 - - '' step '',I2,''.'')') NSTEPS 263 - GOTO 500 264 - ENDIF 265 - * prepare some auxiliary variables, 266 - P(1)=XNEW-XOLD 267 - P(2)=YNEW-YOLD 268 - Q(1)=G1NEW-G1 269 - Q(2)=G2NEW-G2 270 - PQ=P(1)*Q(1)+P(2)*Q(2) 271 - 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)) 272 - * select ZGAMMA and ZTHETA 273 - ZGAMMA=1 274 - ZTHETA=1 275 - * the update itself. 276 - DO 360 K=1,2 277 - DO 350 L=1,2 278 - HNEW(K,L)=ZGAMMA*H(K,L)+ 279 - - (1+ZGAMMA*ZTHETA*QHQ/PQ)*P(K)*P(L)/PQ- 280 - - ZGAMMA*(1-ZTHETA)*(H(K,1)*Q(1)+H(K,2)*Q(2))* 281 - - (Q(1)*H(1,L)+Q(2)*H(2,L))/QHQ- 282 - - ZGAMMA*ZTHETA*(P(K)*Q(1)*H(1,L)+P(K)*Q(2)*H(2,L)+ 283 - - H(K,1)*Q(1)*P(L)+H(K,2)*Q(2)*P(L))/PQ 284 - 350 CONTINUE 285 - 360 CONTINUE 286 - ** Transfer variables from old to new storage places. 287 - DO 380 K=1,2 288 - DO 370 L=1,2 289 - H(K,L)=HNEW(K,L) 290 - 370 CONTINUE 291 - 380 CONTINUE 292 - G1=G1NEW 293 - G2=G2NEW 294 - XOLD=XNEW 1 573 P=ZERO D=ZROLOC 4 PAGE 863 295 - YOLD=YNEW 296 - EOLD=ENEW 297 - GOTO 310 298 - *** Final printing and checking of the results. 299 - 500 CONTINUE 300 - * Check whether the point lies in the area. 301 - IF(XNEW.LT.ZXMIN.OR.XNEW.GT.ZXMAX.OR. 302 - - YMIN.LT.ZYMIN.OR.YNEW.GT.ZYMAX)THEN 303 - IF(LDEBUG)WRITE(*,'(26X,''The minimum lies outside the'', 304 - - '' area.'')') 305 - IFAIL=1 306 - * Perhaps the point lies in the area, has E < EMIN but IFAIL=1. 307 - ELSEIF(IFAIL.NE.0.AND.ENEW.LT.EMIN)THEN 308 - IF(LDEBUG)WRITE(*,'(/26X,''Inspite of the failure'', 309 - - '' the result is E-acceptable.'')') 310 - IFAIL=0 311 - ENDIF 312 - * Print the end result. 313 - IF(LDEBUG)WRITE(*,'(26X,''Final (X,Y) '',2F11.4,'' (Etot='', 314 - - E10.3,'').''/26X,''IFAIL for the whole search '',I2,''.'')') 315 - - XNEW,YNEW,ENEW,IFAIL 316 - *** Make sure the result is stored in the proper place. 317 - XMIN=XNEW 318 - YMIN=YNEW 319 - END 574 GARFIELD ================================================== P=ZERO D=ZROARG 1 ============================ 0 + +DECK,ZROARG. 1 - FUNCTION ZROARG(P,ZXMIN,ZYMIN,ZXMAX,ZYMAX,INWIRE) 2.- +SEQ,DIMENSIONS. 3.- +SEQ,ZERODATA. 4.- +SEQ,CONSTANTS. 5 - LOGICAL INWIRE 6 - *** Find the coordinates corresponding with P. 7 - IF(P.GE.0.0.AND.P.LE.1.0)THEN 8 - X=ZXMIN+ P *(ZXMAX-ZXMIN) 9 - Y=ZYMIN 10 - ELSEIF(P.GT.1.0.AND.P.LE.2.0)THEN 11 - X=ZXMAX 12 - Y=ZYMIN+(P-1.0)*(ZYMAX-ZYMIN) 13 - ELSEIF(P.GT.2.0.AND.P.LE.3.0)THEN 14 - X=ZXMAX-(P-2.0)*(ZXMAX-ZXMIN) 15 - Y=ZYMAX 16 - ELSEIF(P.GT.3.0.AND.P.LE.4.0)THEN 17 - X=ZXMIN 18 - Y=ZYMAX-(P-3.0)*(ZYMAX-ZYMIN) 19 - ELSE 20 - ZROARG=0.0 21 - INWIRE=.TRUE. 22 - PRINT *,' ###### ZROARG ERROR : Argument P out of range', 23 - - ' (program bug); probably no serious effect.' 24 - RETURN 25 - ENDIF 26 - *** Calculate the field at (X,Y) and set inwire. 27 - INWIRE=.FALSE. 28 - CALL EFIELD(X,Y,0.0,EX,EY,EZ,ETOT,VOLT,0,ILOC) 29 - NFC=NFC+1 30 - IF(ILOC.NE.0)THEN 31 - ZROARG=0.0 32 - INWIRE=.TRUE. 33 - PRINT 1010,P,X,Y 34 - RETURN 35 - ENDIF 36 - *** Compute the argument. 37 - ZROARG=ACOS(EX/ETOT)/(2.0*PI) 38 - IF(EY.LT.0)ZROARG=1.0-ZROARG 39 - PRINT 1010,P,X,Y,ZROARG 40 - 1010 FORMAT(' P=',F10.3,' (X,Y)=',2F10.3:' ARG=',F10.3) 41 - END 575 GARFIELD ================================================== P=FIELDCAL D= 1 ============================ 0 + +PATCH,FIELDCAL. 576 GARFIELD ================================================== P=FIELDCAL D=SETUP 1 ============================ 0 + +DECK,SETUP. 1 - SUBROUTINE SETUP(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SETUP - Routine calling the appropriate setup routine. 4 - * (Last changed on 30/ 1/93.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,CELLDATA. 8.- +SEQ,PRINTPLOT. 9 - *** Try to obtain the storage used for the capacitance matrix. 10 - CALL BOOK('BOOK','MATRIX','CELL',IFAIL) 11 - IF(IFAIL.NE.0)THEN 12 - PRINT *,' !!!!!! SETUP WARNING : Unable to allocate'// 13 - - ' storage for the capacitance matrix; no charges.' 14 - IF(LDEBUG)CALL BOOK('LIST',' ',' ',IFAIL1) 15 - RETURN 16 - ENDIF 17 - *** Set a separate set of plane variables to avoid repeated loops. 18 - IF(YNPLAN(1))THEN 19 - COPLAX=COPLAN(1) 20 - YNPLAX=.TRUE. 21 - ELSEIF(YNPLAN(2))THEN 22 - COPLAX=COPLAN(2) 23 - YNPLAX=.TRUE. 24 - ELSE 25 - YNPLAX=.FALSE. 26 - ENDIF 27 - IF(YNPLAN(3))THEN 28 - COPLAY=COPLAN(3) 1 576 P=FIELDCAL D=SETUP 2 PAGE 864 29 - YNPLAY=.TRUE. 30 - ELSEIF(YNPLAN(4))THEN 31 - COPLAY=COPLAN(4) 32 - YNPLAY=.TRUE. 33 - ELSE 34 - YNPLAY=.FALSE. 35 - ENDIF 36 - *** Set the correction parameters for the planes. 37 - IF(TUBE)THEN 38 - CORVTA=0.0 39 - CORVTB=0.0 40 - CORVTC=VTTUBE 41 - ELSEIF((YNPLAN(1).AND.YNPLAN(2)).AND. 42 - - .NOT.(YNPLAN(3).OR.YNPLAN(4)))THEN 43 - CORVTA=(VTPLAN(1)-VTPLAN(2))/(COPLAN(1)-COPLAN(2)) 44 - CORVTB=0.0 45 - CORVTC=(VTPLAN(2)*COPLAN(1)-VTPLAN(1)*COPLAN(2))/ 46 - - (COPLAN(1)-COPLAN(2)) 47 - ELSEIF((YNPLAN(3).AND.YNPLAN(4)).AND. 48 - - .NOT.(YNPLAN(1).OR.YNPLAN(2)))THEN 49 - CORVTA=0.0 50 - CORVTB=(VTPLAN(3)-VTPLAN(4))/(COPLAN(3)-COPLAN(4)) 51 - CORVTC=(VTPLAN(4)*COPLAN(3)-VTPLAN(3)*COPLAN(4))/ 52 - - (COPLAN(3)-COPLAN(4)) 53 - ELSE 54 - CORVTA=0 55 - CORVTB=0 56 - CORVTC=0 57 - IF(YNPLAN(1))CORVTC=VTPLAN(1) 58 - IF(YNPLAN(2))CORVTC=VTPLAN(2) 59 - IF(YNPLAN(3))CORVTC=VTPLAN(3) 60 - IF(YNPLAN(4))CORVTC=VTPLAN(4) 61 - ENDIF 62 - *** Skip wire calculations if there aren't any. 63 - IF(NWIRE.LE.0)GOTO 10 64 - *** Call the set routine appropriate for the present cell type. 65 - IF(TYPE.EQ.'A '.AND.NXMATT.EQ.0.AND.NYMATT.EQ.0)THEN 66 - CALL SETA00(IFAIL) 67 - ELSEIF(TYPE.EQ.'A ')THEN 68 - CALL EFQA00(IFAIL) 69 - ENDIF 70 - IF(TYPE.EQ.'B1X')CALL SETB1X(IFAIL) 71 - IF(TYPE.EQ.'B1Y')CALL SETB1Y(IFAIL) 72 - IF(TYPE.EQ.'B2X')CALL SETB2X(IFAIL) 73 - IF(TYPE.EQ.'B2Y')CALL SETB2Y(IFAIL) 74 - IF(TYPE.EQ.'C1 ')CALL SETC10(IFAIL) 75 - IF(TYPE.EQ.'C2X')CALL SETC2X(IFAIL) 76 - IF(TYPE.EQ.'C2Y')CALL SETC2Y(IFAIL) 77 - IF(TYPE.EQ.'C3 ')CALL SETC30(IFAIL) 78 - IF(TYPE.EQ.'D1 ')CALL SETD10(IFAIL) 79 - IF(TYPE.EQ.'D2 ')CALL SETD20(IFAIL) 80 - IF(TYPE.EQ.'D3 ')CALL SETD30(IFAIL) 81 - C IF(TYPE.EQ.'D4 ')CALL SETD40(IFAIL) 82 - *** Check the error condition. 83 - IF(IFAIL.EQ.1)PRINT *,' ###### SETUP ERROR : Preparing the'// 84 - - ' the cell for field calculations did not succeed.' 85 - 10 CONTINUE 86 - *** Release the capacitance matrix. 87 - CALL BOOK('RELEASE','MATRIX','CELL',IFAIL1) 88 - *** Register the amount of CPU time used. 89 - CALL TIMLOG('Calculating the wire charges: ') 90 - END 577 GARFIELD ================================================== P=FIELDCAL D=SETNEW 1 ============================ 0 + +DECK,SETNEW. 1 - SUBROUTINE SETNEW(VNEW,VPLNEW,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SETNEW - Calculates charges when the potentials have changed. 4 - * (Last changed on 20/10/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,CAPACMATRIX. 10.- +SEQ,PRINTPLOT. 11 - REAL VNEW(MXWIRE),VPLNEW(5) 12 - INTEGER IFAIL,IFAIL1,I,J 13 - CHARACTER*10 USER 14 - *** Identify the routine, if requested. 15 - IF(LIDENT)PRINT *,' /// ROUTINE SETNEW ///' 16 - *** Assume the routine will be successful. 17 - IFAIL=0 18 - *** Figure out whether the capacitance matrix is still available. 19 - CALL BOOK('INQUIRE','MATRIX',USER,IFAIL1) 20 - IF(USER.NE.'CELL ')THEN 21 - IF(LDEBUG)PRINT *,' ++++++ SETNEW DEBUG : Recalculating'// 22 - - ' the capacitance matrix.' 23 - CALL SETUP(IFAIL) 24 - IF(IFAIL.NE.0)THEN 25 - PRINT *,' ###### SETNEW ERROR : Error computing'// 26 - - ' the charges; further cell computations useless.' 27 - NWIRE=0 28 - RETURN 29 - ENDIF 30 - ELSEIF(LDEBUG)THEN 31 - PRINT *,' ++++++ SETNEW DEBUG : Capacitance'// 32 - - ' matrix still available.' 33 - ENDIF 34 - *** Set the correction parameters for the planes. 35 - IF(TUBE)THEN 36 - CORVTA=0.0 37 - CORVTB=0.0 38 - CORVTC=VPLNEW(5) 39 - ELSEIF((YNPLAN(1).AND.YNPLAN(2)).AND. 40 - - .NOT.(YNPLAN(3).OR.YNPLAN(4)))THEN 1 577 P=FIELDCAL D=SETNEW 2 PAGE 865 41 - CORVTA=(VPLNEW(1)-VPLNEW(2))/(COPLAN(1)-COPLAN(2)) 42 - CORVTB=0.0 43 - CORVTC=(VPLNEW(2)*COPLAN(1)-VPLNEW(1)*COPLAN(2))/ 44 - - (COPLAN(1)-COPLAN(2)) 45 - ELSEIF((YNPLAN(3).AND.YNPLAN(4)).AND. 46 - - .NOT.(YNPLAN(1).OR.YNPLAN(2)))THEN 47 - CORVTA=0.0 48 - CORVTB=(VPLNEW(3)-VPLNEW(4))/(COPLAN(3)-COPLAN(4)) 49 - CORVTC=(VPLNEW(4)*COPLAN(3)-VPLNEW(3)*COPLAN(4))/ 50 - - (COPLAN(3)-COPLAN(4)) 51 - ELSE 52 - CORVTA=0 53 - CORVTB=0 54 - CORVTC=0 55 - IF(YNPLAN(1))CORVTC=VPLNEW(1) 56 - IF(YNPLAN(2))CORVTC=VPLNEW(2) 57 - IF(YNPLAN(3))CORVTC=VPLNEW(3) 58 - IF(YNPLAN(4))CORVTC=VPLNEW(4) 59 - ENDIF 0 60-+ +SELF,IF=VECTOR,IF=ESSL. 61 - *** Transfer the voltages to A, correcting for the equipotential planes. 62 - DO 10 I=1,NWIRE 63 - A(I,MXWIRE+3)=VNEW(I)-(CORVTA*X(I)+CORVTB*Y(I)+CORVTC) 64 - 10 CONTINUE 0 65-+ +SELF. 66 - *** Handle the case when the sum of the charges is zero autmatically. 67 - IF(YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4))THEN 0 68-+ +SELF,IF=VECTOR,IF=ESSL. 69 - CALL DGES(A,MXWIRE+1,NWIRE,A(1,MXWIRE+2),A(1,MXWIRE+3),0) 0 70-+ +SELF. 71 - V0=0.0 72 - *** Force sum charges =0 in case of absence of equipotential planes. 73 - ELSE 0 74-+ +SELF,IF=VECTOR,IF=ESSL. 75 - A(NWIRE+1,MXWIRE+3)=0.0 76 - CALL DGES(A,MXWIRE+1,NWIRE+1,A(1,MXWIRE+2),A(1,MXWIRE+3),0) 77 - V0=A(NWIRE+1,MXWIRE+3) 0 78-+ +SELF,IF=-VECTOR,-ESSL. 79 - V0=0 80 - DO 40 I=1,NWIRE 81 - V0=V0+A(NWIRE+1,I)*VNEW(I) 82 - 40 CONTINUE 0 83-+ +SELF. 84 - ENDIF 0 85-+ +SELF,IF=VECTOR,IF=ESSL. 86 - *** Copy the charges to E. 87 - DO 50 I=1,NWIRE 88 - E(I)=A(I,MXWIRE+3) 89 - 50 CONTINUE 0 90-+ +SELF,IF=-VECTOR,-ESSL. 91 - *** Next reconstruct the charges. 92 - DO 30 I=1,NWIRE 93 - E(I)=0 94 - DO 20 J=1,NWIRE 95 - E(I)=E(I)+A(I,J)*(VNEW(J)-V0-(CORVTA*X(J)+CORVTB*Y(J)+CORVTC)) 96 - 20 CONTINUE 97 - 30 CONTINUE 0 98-+ +SELF. 99 - *** Replace the potentials. 100 - DO 60 I=1,NWIRE 101 - V(I)=VNEW(I) 102 - 60 CONTINUE 103 - DO 70 I=1,4 104 - VTPLAN(I)=VPLNEW(I) 105 - 70 CONTINUE 106 - VTTUBE=VPLNEW(5) 107 - END 578 GARFIELD ================================================== P=FIELDCAL D=SETA00 1 ============================ 0 + +DECK,SETA00. 1 - SUBROUTINE SETA00(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SETA00 - Subroutine preparing the field calculations by calculating 4 - * the charges on the wires, for the cell with one charge and 5 - * not more than one plane in either x or y. 6 - * The potential used is log(r). 7 - * Variables : No local variables. 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,CAPACMATRIX. 12 - *** Loop over all wire combinations. 13 - DO 10 I=1,NWIRE 14 - A(I,I)=0.25*D(I)**2 15 - *** Take care of the equipotential planes. 16 - IF(YNPLAX)A(I,I)=A(I,I)/(2.0*(X(I)-COPLAX))**2 17 - IF(YNPLAY)A(I,I)=A(I,I)/(2.0*(Y(I)-COPLAY))**2 18 - *** Take care of combinations of equipotential planes. 19 - IF(YNPLAX.AND.YNPLAY)A(I,I)=4.0*A(I,I)*((X(I)-COPLAX)**2 20 - - +(Y(I)-COPLAY)**2) 21 - *** Define the final version of A(I,I). 22 - A(I,I)=-0.5*LOG(A(I,I)) 23 - *** Loop over all other wires for the off-diagonal elements. 24 - DO 20 J=I+1,NWIRE 25 - A(I,J)=(X(I)-X(J))**2+(Y(I)-Y(J))**2 1 578 P=FIELDCAL D=SETA00 2 PAGE 866 26 - *** Take care of equipotential planes. 27 - IF(YNPLAX)A(I,J)=A(I,J)/((X(I)+X(J)-2.*COPLAX)**2+(Y(I)-Y(J))**2) 28 - IF(YNPLAY)A(I,J)=A(I,J)/((X(I)-X(J))**2+(Y(I)+Y(J)-2.*COPLAY)**2) 29 - *** Take care of pairs of equipotential planes in different directions. 30 - IF(YNPLAX.AND.YNPLAY)A(I,J)= 31 - - A(I,J)*((X(I)+X(J)-2.*COPLAX)**2+(Y(I)+Y(J)-2.*COPLAY)**2) 32 - *** Define a final version of A(I,J). 33 - A(I,J)=-0.5*LOG(A(I,J)) 34 - *** Copy this to A(J,I) since the capacitance matrix is symmetric. 35 - A(J,I)=A(I,J) 36 - 20 CONTINUE 37 - 10 CONTINUE 38 - *** Call CHARGE to calculate the charges really. 39 - CALL CHARGE(IFAIL) 40 - END 579 GARFIELD ================================================== P=FIELDCAL D=SETB1X 1 ============================ 0 + +DECK,SETB1X. 1 - SUBROUTINE SETB1X(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SETB1X - Routine preparing the field calculations by filling the 4 - * c-matrix, the potential used is re(log(sin pi/s (z-z0))). 5 - * VARIABLES : XX : Difference in x of two wires * factor. 6 - * YY : Difference in y of two wires * factor. 7 - * YYMIRR : Difference in y of one wire and the mirror 8 - * image of another * factor. 9 - * R2PLAN : Periodic length of (XX,YYMIRR) 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13.- +SEQ,CONSTANTS. 14.- +SEQ,CAPACMATRIX. 15 - *** Loop over all wires and calculate the diagonal elements first. 16 - DO 10 I=1,NWIRE 17 - A(I,I)=-LOG(0.5*D(I)*PI/SX) 18 - *** Take care of a plane at constant y if it exist. 19 - IF(YNPLAY)THEN 20 - YY=(PI/SX)*2.0*(Y(I)-COPLAY) 21 - IF(ABS(YY).GT.20.0)A(I,I)=A(I,I)+ABS(YY)-CLOG2 22 - IF(ABS(YY).LE.20.0)A(I,I)=A(I,I)+LOG(ABS(SINH(YY))) 23 - ENDIF 24 - *** Loop over all other wires to obtain off-diagonal elements. 25 - DO 20 J=I+1,NWIRE 26 - XX=(PI/SX)*(X(I)-X(J)) 27 - YY=(PI/SX)*(Y(I)-Y(J)) 28 - IF(ABS(YY).GT.20.0)A(I,J)=-ABS(YY)+CLOG2 29 - IF(ABS(YY).LE.20.0)A(I,J)=-0.5*LOG(SINH(YY)**2+SIN(XX)**2) 30 - *** Take equipotential planes into account if they exist. 31 - IF(YNPLAY)THEN 32 - YYMIRR=(PI/SX)*(Y(I)+Y(J)-2.0*COPLAY) 33 - IF(ABS(YYMIRR).GT.20.0)R2PLAN=ABS(YYMIRR)-CLOG2 34 - IF(ABS(YYMIRR).LE.20.0) 35 - - R2PLAN=0.5*LOG(SINH(YYMIRR)**2+SIN(XX)**2) 36 - A(I,J)=A(I,J)+R2PLAN 37 - ENDIF 38 - *** Copy A(I,J) to A(J,I), the capactance matrix is symmetric. 39 - A(J,I)=A(I,J) 40 - *** Finish the wire loops. 41 - 20 CONTINUE 42 - 10 CONTINUE 43 - *** Call routine CHARGE calculating all kinds of useful things. 44 - CALL CHARGE(IFAIL) 45 - END 580 GARFIELD ================================================== P=FIELDCAL D=SETB1Y 1 ============================ 0 + +DECK,SETB1Y. 1 - SUBROUTINE SETB1Y(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SETB1Y - Routine preparing the field calculations by setting the 4 - * charges. The potential used is Re log(sinh pi/sy(z-z0)). 5 - * VARIABLES : YY : Difference in y of two wires * factor. 6 - * XXMIRR : Difference in x of one wire and the mirror 7 - * image of another * factor. 8 - * R2PLAN : Periodic length of (XXMIRR,YY). 9 - *----------------------------------------------------------------------- 10.- +SEQ,DIMENSIONS. 11.- +SEQ,CELLDATA. 12.- +SEQ,CONSTANTS. 13.- +SEQ,CAPACMATRIX. 14 - *** Loop over all wires and calculate the diagonal elements first. 15 - DO 10 I=1,NWIRE 16 - A(I,I)=-LOG(0.5*D(I)*PI/SY) 17 - *** Take care of planes 1 and 2 if present. 18 - IF(YNPLAX)THEN 19 - XX=(PI/SY)*2.0*(X(I)-COPLAX) 20 - IF(ABS(XX).GT.20.0)A(I,I)=A(I,I)+ABS(XX)-CLOG2 21 - IF(ABS(XX).LE.20.0)A(I,I)=A(I,I)+LOG(ABS(SINH(XX))) 22 - ENDIF 23 - *** Loop over all other wires to obtain off-diagonal elements. 24 - DO 20 J=I+1,NWIRE 25 - XX=(PI/SY)*(X(I)-X(J)) 26 - YY=(PI/SY)*(Y(I)-Y(J)) 27 - IF(ABS(XX).GT.20.0)A(I,J)=-ABS(XX)+CLOG2 28 - IF(ABS(XX).LE.20.0)A(I,J)=-0.5*LOG(SINH(XX)**2+SIN(YY)**2) 29 - *** Take care of a plane at constant x. 30 - IF(YNPLAX)THEN 31 - XXMIRR=(PI/SY)*(X(I)+X(J)-2.0*COPLAX) 32 - IF(ABS(XXMIRR).GT.20.0)R2PLAN=ABS(XXMIRR)-CLOG2 33 - IF(ABS(XXMIRR).LE.20.0) 34 - - R2PLAN=0.5*LOG(SINH(XXMIRR)**2+SIN(YY)**2) 35 - A(I,J)=A(I,J)+R2PLAN 36 - ENDIF 37 - *** Copy A(I,J) to A(J,I), the capacitance matrix is symmetric. 38 - A(J,I)=A(I,J) 1 580 P=FIELDCAL D=SETB1Y 2 PAGE 867 39 - *** Finish the wire loops. 40 - 20 CONTINUE 41 - 10 CONTINUE 42 - *** Call routine CHARGE calculating all kinds of useful things. 43 - CALL CHARGE(IFAIL) 44 - END 581 GARFIELD ================================================== P=FIELDCAL D=SETB2X 1 ============================ 0 + +DECK,SETB2X. 1 - SUBROUTINE SETB2X(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SETB2X - Routine preparing the field calculations by setting the 4 - * charges. 5 - * VARIABLES : XX : Difference in x of two wires * factor. 6 - * YY : Difference in y of two wires * factor. 7 - * XXNEG : Difference in x of one wire and the mirror 8 - * image in period direction of another * fac. 9 - * YYMIRR : Difference in y of one wire and the mirror 10 - * image of another * factor. 11 - *----------------------------------------------------------------------- 12.- +SEQ,DIMENSIONS. 13.- +SEQ,CELLDATA. 14.- +SEQ,CONSTANTS. 15.- +SEQ,CAPACMATRIX. 16 - *** Loop over all wires and calculate the diagonal elements first. 17 - DO 10 I=1,NWIRE 18 - XX=(PI/SX)*(X(I)-COPLAX) 19 - A(I,I)=(0.25*D(I)*PI/SX)/SIN(XX) 20 - *** Take care of a plane at constant y if it exists. 21 - IF(YNPLAY)THEN 22 - YYMIRR=(PI/SX)*(Y(I)-COPLAY) 23 - IF(ABS(YYMIRR).LE.20.0) A(I,I)=A(I,I)* 24 - - SQRT(SINH(YYMIRR)**2+SIN(XX)**2)/SINH(YYMIRR) 25 - ENDIF 26 - *** Store the true value of A(I,I). 27 - A(I,I)=-LOG(ABS(A(I,I))) 28 - *** Loop over all other wires to obtain off-diagonal elements. 29 - DO 20 J=I+1,NWIRE 30 - XX=0.5*PI*(X(I)-X(J))/SX 31 - YY=0.5*PI*(Y(I)-Y(J))/SX 32 - XXNEG=0.5*PI*(X(I)+X(J)-2.0*COPLAX)/SX 33 - IF(ABS(YY).LE.20.0) 34 - - A(I,J)=(SINH(YY)**2+SIN(XX)**2)/(SINH(YY)**2+SIN(XXNEG)**2) 35 - IF(ABS(YY).GT.20.0)A(I,J)=1.0 36 - *** Take an equipotential plane at constant y into account. 37 - IF(YNPLAY)THEN 38 - YYMIRR=0.5*PI*(Y(I)+Y(J)-2.0*COPLAY)/SX 39 - IF(ABS(YYMIRR).LE.20.0) A(I,J)=A(I,J)* 40 - - (SINH(YYMIRR)**2+SIN(XXNEG)**2)/(SINH(YYMIRR)**2+SIN(XX)**2) 41 - ENDIF 42 - *** Store the true value of A(I,J) in both A(I,J) and A(J,I). 43 - A(I,J)=-0.5*LOG(A(I,J)) 44 - A(J,I)=A(I,J) 45 - *** Finish the wire loops. 46 - 20 CONTINUE 47 - *** Set the B2SIN vector. 48 - B2SIN(I)=SIN(PI*(COPLAX-X(I))/SX) 49 - 10 CONTINUE 50 - *** Call routine CHARGE calculating all kinds of useful things. 51 - CALL CHARGE(IFAIL) 52 - END 582 GARFIELD ================================================== P=FIELDCAL D=SETB2Y 1 ============================ 0 + +DECK,SETB2Y. 1 - SUBROUTINE SETB2Y(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SETB2Y - Routine preparing the field calculations by setting the 4 - * charges. 5 - * VARIABLES : XX : Difference in x of two wires * factor. 6 - * YY : Difference in y of two wires * factor. 7 - * XXMIRR : Difference in x of one wire and the mirror 8 - * image of another * factor. 9 - * YYNEG : Difference in y of one wire and the mirror 10 - * image in period direction of another * fac. 11 - *----------------------------------------------------------------------- 12.- +SEQ,DIMENSIONS. 13.- +SEQ,CELLDATA. 14.- +SEQ,CONSTANTS. 15.- +SEQ,CAPACMATRIX. 16 - *** Loop over all wires and calculate the diagonal elements first. 17 - DO 10 I=1,NWIRE 18 - YY=(PI/SY)*(Y(I)-COPLAY) 19 - A(I,I)=(0.25*D(I)*PI/SY)/SIN(YY) 20 - *** Take care of a plane at constant x if present. 21 - IF(YNPLAX)THEN 22 - XXMIRR=(PI/SY)*(X(I)-COPLAX) 23 - IF(ABS(XXMIRR).LE.20.0)A(I,I)=A(I,I)* 24 - - SQRT(SINH(XXMIRR)**2+SIN(YY)**2)/SINH(XXMIRR) 25 - ENDIF 26 - *** Store the true value of A(I,I). 27 - A(I,I)=-LOG(ABS(A(I,I))) 28 - *** Loop over all other wires to obtain off-diagonal elements. 29 - DO 20 J=I+1,NWIRE 30 - XX=0.5*PI*(X(I)-X(J))/SY 31 - YY=0.5*PI*(Y(I)-Y(J))/SY 32 - YYNEG=0.5*PI*(Y(I)+Y(J)-2.0*COPLAY)/SY 33 - IF(ABS(XX).LE.20.0) 34 - - A(I,J)=(SINH(XX)**2+SIN(YY)**2)/(SINH(XX)**2+SIN(YYNEG)**2) 35 - IF(ABS(XX).GT.20.0)A(I,J)=1.0 36 - *** Take an equipotential plane at constant x into account. 37 - IF(YNPLAX)THEN 38 - XXMIRR=0.5*PI*(X(I)+X(J)-2.0*COPLAX)/SY 39 - IF(ABS(XXMIRR).LE.20.0)A(I,J)=A(I,J)* 40 - - (SINH(XXMIRR)**2+SIN(YYNEG)**2)/(SINH(XXMIRR)**2+SIN(YY)**2) 1 582 P=FIELDCAL D=SETB2Y 2 PAGE 868 41 - ENDIF 42 - *** Store the true value of A(I,J) in both A(I,J) and A(J,I). 43 - A(I,J)=-0.5*LOG(A(I,J)) 44 - A(J,I)=A(I,J) 45 - *** Finish the wire loops. 46 - 20 CONTINUE 47 - *** Set the B2SIN vector. 48 - B2SIN(I)=SIN(PI*(COPLAY-Y(I))/SY) 49 - 10 CONTINUE 50 - *** Call routine CHARGE calculating all kinds of useful things. 51 - CALL CHARGE(IFAIL) 52 - END 583 GARFIELD ================================================== P=FIELDCAL D=SETC10 1 ============================ 0 + +DECK,SETC10. 1 - SUBROUTINE SETC10(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SETC10 - This initialising routine computes the wire charges E and 4 - * sets certain constants in common. The wire are located at 5 - * (X(J),Y(J))+(LX*SX,LY*SY), J=1(1)NWIRE, 6 - * LX=-infinity(1)infinity, LY=-infinity(1)infinity. 7 - * Use is made of the routine PH2. 8 - * 9 - * (Written by G.A.Erskine/DD, 14.8.1984 modified to some extent) 10 - *----------------------------------------------------------------------- 11 - IMPLICIT COMPLEX (W,Z) 12.- +SEQ,DIMENSIONS. 13.- +SEQ,CELLDATA. 14.- +SEQ,CAPACMATRIX. 15.- +SEQ,CONSTANTS. 16 - *** Statement function returning XX if mode is 0, YY else. 17 - UTYPE(XX,YY)=(1-MODE)*XX+MODE*YY 18 - *** Set some of the constants used by PH2 and E2SUM. 19 - CONST=2.*PI/(SX*SY) 20 - IF(SX.LE.SY)THEN 21 - MODE=1 22 - IF(SY/SX.LT.8.0)THEN 23 - P=EXP(-PI*SY/SX) 24 - ELSE 25 - P=0.0 26 - ENDIF 27 - ZMULT=CMPLX(PI/SX,0.0) 28 - ELSE 29 - MODE=0 30 - IF(SX/SY.LT.8.0)THEN 31 - P=EXP(-PI*SX/SY) 32 - ELSE 33 - P=0.0 34 - ENDIF 35 - ZMULT=CMPLX(0.0,PI/SY) 36 - ENDIF 37 - P1=P**2 38 - P2=P**6 39 - *** Store the capacitance matrix. 40 - DO 20 I=1,NWIRE 41 - DO 10 J=1,NWIRE 42 - TEMP=CONST*UTYPE(X(I),Y(I))*UTYPE(X(J),Y(J)) 43 - IF(I.EQ.J)THEN 44 - A(I,I)=PH2LIM(0.5*D(I))-TEMP 45 - ELSE 46 - A(I,J)=PH2(X(I)-X(J),Y(I)-Y(J))-TEMP 47 - ENDIF 48 - 10 CONTINUE 49 - 20 CONTINUE 50 - *** Call CHARGE to find the charges. 51 - CALL CHARGE(IFAIL) 52 - IF(IFAIL.EQ.1)RETURN 53 - *** Calculate the non-logarithmic term in the potential. 54 - S=0.0 55 - DO 30 J=1,NWIRE 56 - S=S+E(J)*UTYPE(X(J),Y(J)) 57 - 30 CONTINUE 58 - C1=-CONST*S 59 - END 584 GARFIELD ================================================== P=FIELDCAL D=SETC2X 1 ============================ 0 + +DECK,SETC2X. 1 - SUBROUTINE SETC2X(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SETC2X - This initializing subroutine stores the capacitance matrix 4 - * for the configuration: 5 - * wires at zw(j)+cmplx(lx*2*sx,ly*sy), 6 - * j=1(1)n, lx=-infinity(1)infinity, ly=-infinity(1)infinity. 7 - * but the signs of the charges alternate in the x-direction 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,CAPACMATRIX. 12.- +SEQ,CONSTANTS. 13.- +SEQ,PRINTPLOT. 14 - *** Initialise the constants. 15 - P=0.0 16 - P1=0.0 17 - P2=0.0 18 - IF(2.0*SX.LE.SY)THEN 19 - MODE=1 20 - IF(SY/SX.LT.25.0)P=EXP(-0.5*PI*SY/SX) 21 - ZMULT=CMPLX(0.5*PI/SX,0.0) 22 - ELSE 23 - MODE=0 24 - IF(SX/SY.LT.6.0)P=EXP(-2.0*PI*SX/SY) 25 - ZMULT=CMPLX(0.0,PI/SY) 26 - ENDIF 27 - P1=P**2 1 584 P=FIELDCAL D=SETC2X 2 PAGE 869 28 - IF(P1.GT.1.0E-10)P2=P**6 29 - *** Produce some debugging output. 30 - IF(LDEBUG)THEN 31 - PRINT *,' ++++++ SETC2X DEBUG : P, P1, P2=',P,P1,P2 32 - PRINT *,' ZMULT=',ZMULT 33 - PRINT *,' MODE=',MODE 34 - ENDIF 35 - *** Fill the capacitance matrix. 36 - DO 10 I=1,NWIRE 37 - CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) 38 - DO 20 J=1,NWIRE 39 - IF(MODE.EQ.0)THEN 40 - TEMP=(X(I)-CX)*(X(J)-CX)*2.0*PI/(SX*SY) 41 - ELSE 42 - TEMP=0.0 43 - ENDIF 44 - IF(I.EQ.J)THEN 45 - A(I,I)=PH2LIM(0.5*D(I))- 46 - - PH2(2.0*(X(I)-CX),0.0)-TEMP 47 - ELSE 48 - A(I,J)=PH2(X(I)-X(J),Y(I)-Y(J))- 49 - - PH2(X(I)+X(J)-2.0*CX,Y(I)-Y(J))-TEMP 50 - ENDIF 51 - 20 CONTINUE 52 - 10 CONTINUE 53 - *** Call CHARGE to find the wire charges. 54 - CALL CHARGE(IFAIL) 55 - IF(IFAIL.EQ.1)RETURN 56 - *** Determine the non-logaritmic part of the potential (0 if MODE=1). 57 - IF(MODE.EQ.0)THEN 58 - S=0.0 59 - DO 30 I=1,NWIRE 60 - CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) 61 - S=S+E(I)*(X(I)-CX) 62 - 30 CONTINUE 63 - C1=-S*2.0*PI/(SX*SY) 64 - ELSE 65 - C1=0.0 66 - ENDIF 67 - RETURN 68 - END 585 GARFIELD ================================================== P=FIELDCAL D=SETC2Y 1 ============================ 0 + +DECK,SETC2Y. 1 - SUBROUTINE SETC2Y(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SETC2Y - This initializing subroutine stores the capacitance matrix 4 - * for the configuration: 5 - * wires at zw(j)+cmplx(lx*sx,ly*2*sy), 6 - * j=1(1)n, lx=-infinity(1)infinity, ly=-infinity(1)infinity. 7 - * but the signs of the charges alternate in the y-direction 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,CAPACMATRIX. 12.- +SEQ,CONSTANTS. 13.- +SEQ,PRINTPLOT. 14 - *** Initialise the constants. 15 - P=0 16 - P1=0 17 - P2=0 18 - IF(SX.LE.2.0*SY)THEN 19 - MODE=1 20 - IF(SY/SX.LE.6.0)P=EXP(-2.0*PI*SY/SX) 21 - ZMULT=CMPLX(PI/SX,0.0) 22 - ELSE 23 - MODE=0 24 - IF(SX/SY.LE.25.0)P=EXP(-0.5*PI*SX/SY) 25 - ZMULT=CMPLX(0.0,0.5*PI/SY) 26 - ENDIF 27 - P1=P**2 28 - IF(P1.GT.1.0E-10)P2=P**6 29 - *** Produce some debugging output. 30 - IF(LDEBUG)THEN 31 - PRINT *,' ++++++ SETC2Y DEBUG : P, P1, P2=',P,P1,P2 32 - PRINT *,' ZMULT=',ZMULT 33 - PRINT *,' MODE=',MODE 34 - ENDIF 35 - *** Fill the capacitance matrix. 36 - DO 10 I=1,NWIRE 37 - CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) 38 - DO 20 J=1,NWIRE 39 - IF(MODE.EQ.0)THEN 40 - TEMP=0.0 41 - ELSE 42 - TEMP=(Y(I)-CY)*(Y(J)-CY)*2.0*PI/(SX*SY) 43 - ENDIF 44 - IF(I.EQ.J)THEN 45 - A(I,I)=PH2LIM(0.5*D(I))- 46 - - PH2(0.0,2.0*(Y(J)-CY))-TEMP 47 - ELSE 48 - A(I,J)=PH2(X(I)-X(J),Y(I)-Y(J))- 49 - - PH2(X(I)-X(J),Y(I)+Y(J)-2.0*CY)-TEMP 50 - ENDIF 51 - 20 CONTINUE 52 - 10 CONTINUE 53 - *** Call CHARGE to find the wire charges. 54 - CALL CHARGE(IFAIL) 55 - IF(IFAIL.EQ.1)RETURN 56 - *** The non-logarithmic part of the potential is zero if MODE=0. 57 - IF(MODE.EQ.1)THEN 58 - S=0.0 59 - DO 30 I=1,NWIRE 60 - CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) 61 - S=S+E(I)*(Y(I)-CY) 1 585 P=FIELDCAL D=SETC2Y 2 PAGE 870 62 - 30 CONTINUE 63 - C1=-S*2.0*PI/(SX*SY) 64 - ELSE 65 - C1=0.0 66 - ENDIF 67 - END 586 GARFIELD ================================================== P=FIELDCAL D=SETC30 1 ============================ 0 + +DECK,SETC30. 1 - SUBROUTINE SETC30(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SETC30 - This initializing subroutine stores the capacitance matrix 4 - * for a configuration with 5 - * wires at zw(j)+cmplx(lx*2*sx,ly*2*sy), 6 - * j=1(1)n, lx=-infinity(1)infinity, ly=-infinity(1)infinity. 7 - * but the signs of the charges alternate in both directions. 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,CAPACMATRIX. 12.- +SEQ,PRINTPLOT. 13.- +SEQ,CONSTANTS. 14 - *** Initialise the constants. 15 - P=0.0 16 - P1=0.0 17 - P2=0.0 18 - IF(SX.LE.SY)THEN 19 - MODE=1 20 - IF(SY/SX.LE.13.0)P=EXP(-PI*SY/SX) 21 - ZMULT=CMPLX(0.5*PI/SX,0.0) 22 - ELSE 23 - MODE=0 24 - IF(SX/SY.LE.13.0)P=EXP(-PI*SX/SY) 25 - ZMULT=CMPLX(0.0,0.5*PI/SY) 26 - ENDIF 27 - P1=P**2 28 - IF(P1.GT.1.0E-10)P2=P**6 29 - *** Produce some debugging output. 30 - IF(LDEBUG)THEN 31 - PRINT *,' ++++++ SETC30 DEBUG : P, P1, P2=',P,P1,P2 32 - PRINT *,' ZMULT=',ZMULT 33 - PRINT *,' MODE=',MODE 34 - ENDIF 35 - *** Fill the capacitance matrix. 36 - DO 10 I=1,NWIRE 37 - CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) 38 - CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) 39 - DO 20 J=1,NWIRE 40 - IF(I.EQ.J)THEN 41 - A(I,I)=PH2LIM(0.5*D(I))- 42 - - PH2(0.0,2.0*(Y(I)-CY))- 43 - - PH2(2.0*(X(I)-CX),0.0)+ 44 - - PH2(2.0*(X(I)-CX),2.0*(Y(I)-CY)) 45 - ELSE 46 - A(I,J)=PH2(X(I)-X(J),Y(I)-Y(J))- 47 - - PH2(X(I)-X(J),Y(I)+Y(J)-2.0*CY)- 48 - - PH2(X(I)+X(J)-2.0*CX,Y(I)-Y(J))+ 49 - - PH2(X(I)+X(J)-2.0*CX,Y(I)+Y(J)-2.0*CY) 50 - ENDIF 51 - 20 CONTINUE 52 - 10 CONTINUE 53 - *** Call CHARGE to find the wire charges. 54 - CALL CHARGE(IFAIL) 55 - IF(IFAIL.EQ.1)RETURN 56 - *** The non-logarithmic part of the potential is zero in this case. 57 - C1=0.0 58 - END 587 GARFIELD ================================================== P=FIELDCAL D=SETD10 1 ============================ 0 + +DECK,SETD10,IF=NEVER. 1 - SUBROUTINE SETD10(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SETD10 - Subroutine preparing the field calculations by calculating 4 - * the charges on the wires, for cells with a tube. 5 - * VARIABLES : 6 - * (Last changed on 30/ 1/93.) 7 - *----------------------------------------------------------------------- 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,CAPACMATRIX. 11 - COMPLEX ZI,ZJ 12 - *** Loop over all wires. 13 - DO 10 I=1,NWIRE 14 - * Set the diagonal terms. 15 - A(I,I)=-LOG(0.5*D(I)/(COTUBE-(X(I)**2+Y(I)**2)/COTUBE)) 16 - * Set a complex wire-coordinate to make things a little easier. 17 - ZI=CMPLX(X(I),Y(I)) 18 - *** Loop over all other wires for the off-diagonal elements. 19 - DO 20 J=I+1,NWIRE 20 - * Set a complex wire-coordinate to make things a little easier. 21 - ZJ=CMPLX(X(J),Y(J)) 22 - A(I,J)=-LOG(ABS((1/COTUBE)*(ZI-ZJ)/(1-CONJG(ZI)*ZJ/COTUBE**2))) 23 - *** Copy this to A(J,I) since the capacitance matrix is symmetric. 24 - A(J,I)=A(I,J) 25 - 20 CONTINUE 26 - 10 CONTINUE 27 - *** Call CHARGE to calculate the charges really. 28 - CALL CHARGE(IFAIL) 29 - END 1 588 GARFIELD ================================================== P=FIELDCAL D=SETD10 1 =================== PAGE 871 0 + +DECK,SETD10. 1 - SUBROUTINE SETD10(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SETD10 - Subroutine preparing the field calculations by calculating 4 - * the charges on the wires, for cells with a tube. 5 - * VARIABLES : 6 - * (Last changed on 4/ 9/95.) 7 - *----------------------------------------------------------------------- 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,CAPACMATRIX. 11 - COMPLEX ZI,ZJ 12 - *** Loop over all wires. 13 - DO 10 I=1,NWIRE 14 - * Set the diagonal terms. 15 - A(I,I)=-LOG(0.5*D(I)*COTUBE/(COTUBE**2-(X(I)**2+Y(I)**2))) 16 - * Set a complex wire-coordinate to make things a little easier. 17 - ZI=CMPLX(X(I),Y(I)) 18 - *** Loop over all other wires for the off-diagonal elements. 19 - DO 20 J=I+1,NWIRE 20 - * Set a complex wire-coordinate to make things a little easier. 21 - ZJ=CMPLX(X(J),Y(J)) 22 - A(I,J)=-LOG(ABS(COTUBE*(ZI-ZJ)/(COTUBE**2-CONJG(ZI)*ZJ))) 23 - *** Copy this to A(J,I) since the capacitance matrix is symmetric. 24 - A(J,I)=A(I,J) 25 - 20 CONTINUE 26 - 10 CONTINUE 27 - *** Call CHARGE to calculate the charges really. 28 - CALL CHARGE(IFAIL) 29 - END 589 GARFIELD ================================================== P=FIELDCAL D=SETD20 1 ============================ 0 + +DECK,SETD20. 1 - SUBROUTINE SETD20(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SETD20 - Subroutine preparing the field calculations by calculating 4 - * the charges on the wires, for cells with a tube and a 5 - * phi periodicity. Assymetric capacitance matrix ! 6 - * VARIABLES : 7 - * (Last changed on 18/ 2/93.) 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,CAPACMATRIX. 12 - COMPLEX ZI,ZJ 13 - *** Loop over all wires. 14 - DO 10 I=1,NWIRE 15 - * Set a complex wire-coordinate to make things a little easier. 16 - ZI=CMPLX(X(I),Y(I)) 17 - *** Case of a wire near the centre. 18 - IF(ABS(ZI).LT.D(I)/2)THEN 19 - * Inner loop over the wires. 20 - DO 20 J=1,NWIRE 21 - * Set the diagonal terms. 22 - IF(I.EQ.J)THEN 23 - A(I,I)=-LOG(0.5*D(I)/ 24 - - (COTUBE-(X(I)**2+Y(I)**2)/COTUBE)) 25 - * Off-diagonal terms. 26 - ELSE 27 - ZJ=CMPLX(X(J),Y(J)) 28 - A(J,I)=-LOG(ABS((1/COTUBE)*(ZI-ZJ)/ 29 - - (1-CONJG(ZI)*ZJ/COTUBE**2))) 30 - ENDIF 31 - 20 CONTINUE 32 - *** Normal case. 33 - ELSE 34 - * Inner wire loop. 35 - DO 30 J=1,NWIRE 36 - * Diagonal elements. 37 - IF(I.EQ.J)THEN 38 - A(I,I)=-LOG(ABS(0.5*D(I)*MTUBE*ZI**(MTUBE-1)/ 39 - - ((COTUBE**MTUBE)*(1-(ABS(ZI)/COTUBE)** 40 - - (2*MTUBE))))) 41 - * Off-diagonal terms. 42 - ELSE 43 - ZJ=CMPLX(X(J),Y(J)) 44 - A(J,I)=-LOG(ABS((1/COTUBE**MTUBE)* 45 - - (ZJ**MTUBE-ZI**MTUBE)/ 46 - - (1-(ZJ*CONJG(ZI)/COTUBE**2)**MTUBE))) 47 - ENDIF 48 - 30 CONTINUE 49 - ENDIF 50 - *** Next wire. 51 - 10 CONTINUE 52 - *** Call CHARGE to calculate the charges really. 53 - CALL CHARGE(IFAIL) 54 - END 590 GARFIELD ================================================== P=FIELDCAL D=SETD30 1 ============================ 0 + +DECK,SETD30. 1 - SUBROUTINE SETD30(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SETD30 - Subroutine preparing the field calculations by calculating 4 - * the charges on the wires, for cells with wires inside a 5 - * polygon. 6 - * Variables : No local variables. 7 - * (Last changed on 21/ 2/94.) 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,CAPACMATRIX. 12 - COMPLEX WD 13 - *** Evaluate kappa, a constant needed by EFCMAP. 14 - KAPPA=GAMMA(REAL(NTUBE+1)/REAL(NTUBE))* 1 590 P=FIELDCAL D=SETD30 2 PAGE 872 15 - - GAMMA(REAL(NTUBE-2)/REAL(NTUBE))/ 16 - - GAMMA(REAL(NTUBE-1)/REAL(NTUBE)) 17 - *** Loop over all wire combinations. 18 - DO 10 I=1,NWIRE 19 - *** Compute wire mappings only once. 20 - CALL EFCMAP(CMPLX(X(I),Y(I))/COTUBE,WMAP(I),WD) 21 - * Diagonal elements. 22 - A(I,I)=-LOG(ABS((0.5*D(I)/COTUBE)*WD/(1-ABS(WMAP(I))**2))) 23 - *** Loop over all other wires for the off-diagonal elements. 24 - DO 20 J=1,I-1 25 - A(I,J)=-LOG(ABS((WMAP(I)-WMAP(J))/(1-CONJG(WMAP(I))*WMAP(J)))) 26 - *** Copy this to A(J,I) since the capacitance matrix is symmetric. 27 - A(J,I)=A(I,J) 28 - 20 CONTINUE 29 - 10 CONTINUE 30 - *** Call CHARGE to calculate the charges really. 31 - CALL CHARGE(IFAIL) 32 - END 591 GARFIELD ================================================== P=FIELDCAL D=CHARGE 1 ============================ 0 + +DECK,CHARGE. 1 - SUBROUTINE CHARGE(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * CHARGE - Routine actually inverting the capacitance matrix filled in 4 - * the SET... routines thereby providing the charges. 5 - * (Last changed on 30/ 1/93.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,CAPACMATRIX. 10.- +SEQ,PRINTPLOT. 11 - DOUBLE PRECISION T 12 - *** Identify the routine, if requested. 13 - IF(LIDENT)PRINT *,' /// ROUTINE CHARGE ///' 14 - *** Dump the capacitance matrix before inversion, if DEBUG is requested. 15 - IF(LDEBUG)THEN 16 - WRITE(LUNOUT,'(/'' ++++++ CHARGE DEBUG : Dump of the'', 17 - - '' capacitance matrix before inversion follows:''/)') 18 - DO 160 I=0,NWIRE-1,10 19 - DO 170 J=0,NWIRE-1,10 20 - WRITE(LUNOUT,'(''1 Block '',I2,''.'',I2/)') I/10,J/10 21 - DO 180 II=1,10 22 - IF(I+II.GT.NWIRE)GOTO 180 23 - WRITE(LUNOUT,'(2X,10(E12.5,1X:))') 24 - - (A(I+II,J+JJ),JJ=1,MIN(NWIRE-J,10)) 25 - 180 CONTINUE 26 - 170 CONTINUE 27 - 160 CONTINUE 28 - WRITE(LUNOUT,'(/'' ++++++ CHARGE DEBUG : End of the'', 29 - - '' uninverted capacitance matrix dump.''/)') 30 - ENDIF 31 - *** Transfer the voltages to A, correcting for the equipotential planes. 32 - DO 10 I=1,NWIRE 33 - A(I,MXWIRE+3)=V(I)-(CORVTA*X(I)+CORVTB*Y(I)+CORVTC) 34 - 10 CONTINUE 35 - *** Force sum charges =0 in case of absence of equipotential planes. 36 - IF(.NOT.(YNPLAN(1).OR.YNPLAN(2).OR. 37 - - YNPLAN(3).OR.YNPLAN(4).OR.TUBE))THEN 38 - * Add extra elements to A, acting as constraints. 39 - A(NWIRE+1,MXWIRE+3)=0.0 40 - DO 20 I=1,NWIRE 41 - A(I,NWIRE+1)=1.0 42 - A(NWIRE+1,I)=1.0 43 - 20 CONTINUE 44 - A(NWIRE+1,NWIRE+1)=0.0 0 45-+ +SELF,IF=VECTOR,IF=ESSL. 46 - * Solve equations to yield charges, using ESSL (IBM Vector). 47 - CALL DGEF(A,MXWIRE+1,NWIRE+1,A(1,MXWIRE+2)) 48 - CALL DGES(A,MXWIRE+1,NWIRE+1,A(1,MXWIRE+2),A(1,MXWIRE+3),0) 0 49-+ +SELF,IF=-VECTOR,-ESSL. 50 - * Solve equations to yield charges, using KERNLIB (scalar). 51 - CALL DEQINV(NWIRE+1,A,MXWIRE+1,A(1,NWIRE+2),IFAIL,1, 52 - - A(1,MXWIRE+3)) 53 - * Modify A to give true inverse of capacitance matrix. 54 - IF(A(NWIRE+1,NWIRE+1).NE.0.0)THEN 55 - T=1.0/A(NWIRE+1,NWIRE+1) 56 - DO 40 I=1,NWIRE 57 - DO 30 J=1,NWIRE 58 - A(I,J)=A(I,J)-T*A(I,NWIRE+1)*A(NWIRE+1,J) 59 - 30 CONTINUE 60 - 40 CONTINUE 61 - ELSE 62 - PRINT *,' !!!!!! CHARGE WARNING : True inverse of'// 63 - - ' the capacitance matrix could not be calculated.' 64 - PRINT *,' Use of the FACTOR'// 65 - - ' instruction should be avoided.' 66 - ENDIF 0 67-+ +SELF. 68 - * Store reference potential. 69 - V0=A(NWIRE+1,MXWIRE+3) 70 - ELSE 71 - *** Handle the case when the sum of the charges is zero automatically. 0 72-+ +SELF,IF=VECTOR,IF=ESSL. 73 - CALL DGEF(A,MXWIRE+1,NWIRE,A(1,MXWIRE+2)) 74 - CALL DGES(A,MXWIRE+1,NWIRE,A(1,MXWIRE+2),A(1,MXWIRE+3),0) 0 75-+ +SELF,IF=-VECTOR,-ESSL. 76 - CALL DEQINV(NWIRE,A,MXWIRE+1,A(1,NWIRE+2),IFAIL,1, 77 - - A(1,MXWIRE+3)) 1 591 P=FIELDCAL D=CHARGE 2 PAGE 873 78-+ +SELF. 79 - * Reference potential chosen to be zero. 80 - V0=0.0 81 - ENDIF 82 - *** Check the error condition flag. 83 - IF(IFAIL.NE.0)THEN 84 - PRINT *,' ###### CHARGE ERROR : Failure to solve the'// 85 - - ' capacitance equations; no charges are available.' 86 - IFAIL=1 87 - RETURN 88 - ENDIF 89 - *** Copy the charges to E. 90 - DO 50 I=1,NWIRE 91 - E(I)=A(I,MXWIRE+3) 92 - 50 CONTINUE 93 - *** If LDEBUG is on, print the capacitance matrix. 94 - IF(LDEBUG)THEN 95 - WRITE(LUNOUT,'(/'' ++++++ CHARGE DEBUG : Dump of the'', 96 - - '' capacitance matrix follows:''/)') 97 - DO 60 I=0,NWIRE-1,10 98 - DO 70 J=0,NWIRE-1,10 99 - WRITE(LUNOUT,'(''1 Block '',I2,''.'',I2/)') I/10,J/10 100 - DO 80 II=1,10 101 - IF(I+II.GT.NWIRE)GOTO 80 102 - WRITE(LUNOUT,'(2X,10(E12.5,1X:))') 103 - - (A(I+II,J+JJ),JJ=1,MIN(NWIRE-J,10)) 104 - 80 CONTINUE 105 - 70 CONTINUE 106 - 60 CONTINUE 107 - WRITE(LUNOUT,'(/'' ++++++ CHARGE DEBUG : End of the'', 108 - - '' capacitance matrix.''/)') 109 - ENDIF 0 110-+ +SELF,IF=-VECTOR,-ESSL. 111 - * And also check the quality of the matrix inversion. 112 - IF(LCHGCH)THEN 113 - WRITE(LUNOUT,'(/'' QUALITY CHECK'', 114 - - '' OF THE CHARGE CALCULATION.''// 115 - - '' wire E as obtained'', 116 - - '' E reconstructed''/)') 117 - DO 100 I=1,NWIRE 118 - A(I,MXWIRE+2)=0 119 - DO 110 J=1,NWIRE 120 - A(I,MXWIRE+2)=A(I,MXWIRE+2)+ 121 - - A(I,J)*(V(J)-V0-(CORVTA*X(J)+CORVTB*Y(J)+CORVTC)) 122 - 110 CONTINUE 123 - WRITE(LUNOUT,'(26X,I4,5X,E15.8,5X,E15.8)') 124 - - I,E(I),A(I,MXWIRE+2) 125 - 100 CONTINUE 126 - WRITE(LUNOUT,'('' '')') 127 - ENDIF 0 128-+ +SELF. 129 - END 592 GARFIELD ================================================== P=FIELDCAL D=EFIELD 1 ============================ 0 + +DECK,EFIELD. 1 - SUBROUTINE EFIELD(XIN,YIN,ZIN,EX,EY,EZ,ETOT,VOLT,IOPT,ILOC) 2 - *----------------------------------------------------------------------- 3 - * EFIELD - Subroutine calculating the electric field and the potential 4 - * at a given place. It makes use of the routines POT..., 5 - * depending on the type of the cell. 6 - * VARIABLES : XPOS : x-coordinate of the place where the field 7 - * is to be calculated. 8 - * YPOS, ZPOS : y- and z-coordinates 9 - * EX, EY, EZ : x-, y-, z-component of the electric field. 10 - * VOLT : potential at (XPOS,YPOS). 11 - * IOPT : 1 if both E and V are required, 0 if only E 12 - * is to be computed. 13 - * ILOC : Tells where the point is located (0: normal 14 - * I > 0: in wire I, -1: outside a plane, 15 - * -5: in a material, -6: outside the mesh, 16 - * -10: unknown potential). 17 - * (Last changed on 3/ 6/98.) 18 - *----------------------------------------------------------------------- 19 - implicit none 20.- +SEQ,DIMENSIONS. 21.- +SEQ,PARAMETERS. 22.- +SEQ,CELLDATA. 23.- +SEQ,PRINTPLOT. 24.- +SEQ,CONSTANTS. 25 - REAL XIN,YIN,ZIN,EX,EY,EZ,ETOT,VOLT,XPOS,YPOS,ZPOS,DXWIR,DYWIR, 26 - - AROT,EX3D,EY3D,EZ3D,V3D,EXBGF,EYBGF,EZBGF,VBGF,XAUX,YAUX 27 - INTEGER IOUT,ILOC,IOPT,I 28 - *** Initialise the field for returns without actual calculations. 29 - EX=0.0 30 - EY=0.0 31 - EZ=0.0 32 - ETOT=0.0 33 - VOLT=0.0 34 - ILOC=0 35 - *** In case of periodicity, move the point into the basic cell. 36 - IF(ICTYPE.NE.0)THEN 37 - IF(PERX)THEN 38 - XPOS=XIN-SX*ANINT(XIN/SX) 39 - ELSE 40 - XPOS=XIN 41 - ENDIF 42 - IF(PERY.AND.TUBE)THEN 43 - CALL CFMCTP(XIN,YIN,XPOS,YPOS,1) 44 - AROT=180*SY*ANINT((PI*YPOS)/(SY*180.0))/PI 45 - YPOS=YPOS-AROT 46 - CALL CFMPTC(XPOS,YPOS,XPOS,YPOS,1) 47 - ELSEIF(PERY)THEN 48 - YPOS=YIN-SY*ANINT(YIN/SY) 1 592 P=FIELDCAL D=EFIELD 2 PAGE 874 49 - ELSE 50 - YPOS=YIN 51 - ENDIF 52 - *** Move the point to the correct side of the plane. 53 - IF(PERX.AND.YNPLAN(1).AND.XPOS.LE.COPLAN(1))XPOS=XPOS+SX 54 - IF(PERX.AND.YNPLAN(2).AND.XPOS.GE.COPLAN(2))XPOS=XPOS-SX 55 - IF(PERY.AND.YNPLAN(3).AND.YPOS.LE.COPLAN(3))YPOS=YPOS+SY 56 - IF(PERY.AND.YNPLAN(4).AND.YPOS.GE.COPLAN(4))YPOS=YPOS-SY 57 - *** In case (XPOS,YPOS) is located behind a plane there is no field. 58 - IOUT=0 59 - IF(TUBE)THEN 60 - CALL INTUBE(XPOS,YPOS,COTUBE,NTUBE,IOUT) 61 - IF(IOUT.NE.0)VOLT=VTTUBE 62 - ELSE 63 - IF(YNPLAN(1).AND.XPOS.LT.COPLAN(1))IOUT=1 64 - IF(YNPLAN(2).AND.XPOS.GT.COPLAN(2))IOUT=2 65 - IF(YNPLAN(3).AND.YPOS.LT.COPLAN(3))IOUT=3 66 - IF(YNPLAN(4).AND.YPOS.GT.COPLAN(4))IOUT=4 67 - IF(IOUT.EQ.1)VOLT=VTPLAN(1) 68 - IF(IOUT.EQ.2)VOLT=VTPLAN(2) 69 - IF(IOUT.EQ.3)VOLT=VTPLAN(3) 70 - IF(IOUT.EQ.4)VOLT=VTPLAN(4) 71 - ENDIF 72 - IF(IOUT.NE.0)THEN 73 - ILOC=-4 74 - RETURN 75 - ENDIF 76 - *** If (XPOS,YPOS) is within a wire, there is no field either. 77 - DO 10 I=1,NWIRE 78 - * Correct for x-periodicity. 79 - IF(PERX)THEN 80 - DXWIR=(XPOS-X(I))-SX*ANINT((XPOS-X(I))/SX) 81 - ELSE 82 - DXWIR=XPOS-X(I) 83 - ENDIF 84 - * Correct for y-periodicity. 85 - IF(PERY.AND..NOT.TUBE)THEN 86 - DYWIR=(YPOS-Y(I))-SY*ANINT((YPOS-Y(I))/SY) 87 - ELSE 88 - DYWIR=YPOS-Y(I) 89 - ENDIF 90 - * Check the actual position. 91 - IF(DXWIR**2+DYWIR**2.LT.0.25*D(I)**2)THEN 92 - VOLT=V(I) 93 - ILOC=I 94 - RETURN 95 - ENDIF 96 - * Next wire. 97 - 10 CONTINUE 98 - ELSE 99 - XPOS=XIN 100 - YPOS=YIN 101 - ZPOS=ZIN 102 - ENDIF 103 - *** Call the appropriate potential calculation function. 104 - IF(ICTYPE.EQ.0)THEN 105 - CALL EFCFMP(XPOS,YPOS,ZPOS,EX,EY,EZ,VOLT,IOPT,ILOC) 106 - IF(ILOC.NE.0.AND.ILOC.NE.-5)RETURN 107 - ELSEIF(ICTYPE.EQ.1.AND.NXMATT.EQ.0.AND.NYMATT.EQ.0)THEN 108 - CALL EFCA00(XPOS,YPOS,EX,EY,VOLT,IOPT) 109 - ELSEIF(ICTYPE.EQ.1)THEN 110 - CALL EFDA00(XPOS,YPOS,EX,EY,VOLT,IOPT) 111 - ELSEIF(ICTYPE.EQ.2)THEN 112 - CALL EFCB1X(XPOS,YPOS,EX,EY,VOLT,IOPT) 113 - ELSEIF(ICTYPE.EQ.3)THEN 114 - CALL EFCB1Y(XPOS,YPOS,EX,EY,VOLT,IOPT) 115 - ELSEIF(ICTYPE.EQ.4)THEN 116 - CALL EFCB2X(XPOS,YPOS,EX,EY,VOLT,IOPT) 117 - ELSEIF(ICTYPE.EQ.5)THEN 118 - CALL EFCB2Y(XPOS,YPOS,EX,EY,VOLT,IOPT) 119 - ELSEIF(ICTYPE.EQ.6)THEN 120 - CALL EFCC10(XPOS,YPOS,EX,EY,VOLT,IOPT) 121 - ELSEIF(ICTYPE.EQ.7)THEN 122 - CALL EFCC2X(XPOS,YPOS,EX,EY,VOLT,IOPT) 123 - ELSEIF(ICTYPE.EQ.8)THEN 124 - CALL EFCC2Y(XPOS,YPOS,EX,EY,VOLT,IOPT) 125 - ELSEIF(ICTYPE.EQ.9)THEN 126 - CALL EFCC30(XPOS,YPOS,EX,EY,VOLT,IOPT) 127 - ELSEIF(ICTYPE.EQ.10)THEN 128 - CALL EFCD10(XPOS,YPOS,EX,EY,VOLT,IOPT) 129 - ELSEIF(ICTYPE.EQ.11)THEN 130 - CALL EFCD20(XPOS,YPOS,EX,EY,VOLT,IOPT) 131 - ELSEIF(ICTYPE.EQ.12)THEN 132 - CALL EFCD30(XPOS,YPOS,EX,EY,VOLT,IOPT) 133 - C ELSEIF(ICTYPE.EQ.13)THEN 134 - C CALL EFCD40(XPOS,YPOS,EX,EY,VOLT,IOPT) 135 - ELSE 136 - ILOC=-10 137 - RETURN 138 - ENDIF 139 - *** Rotate the field in some special cases. 140 - IF(ICTYPE.NE.0)THEN 141 - IF(PERY.AND.TUBE)THEN 142 - CALL CFMCTP(EX,EY,XAUX,YAUX,1) 143 - YAUX=YAUX+AROT 144 - CALL CFMPTC(XAUX,YAUX,EX,EY,1) 145 - ENDIF 146 - *** Correct for the equipotential planes. 147 - EX=EX-CORVTA 148 - EY=EY-CORVTB 149 - VOLT=VOLT+CORVTA*XPOS+CORVTB*YPOS+CORVTC 150 - ENDIF 151 - *** Add three dimensional point charges. 152 - IF(N3D.GT.0)THEN 153 - IF(ICTYPE.EQ.1.OR.ICTYPE.EQ.2.OR.ICTYPE.EQ.3)THEN 154 - CALL E3DA00(XIN,YIN,ZIN,EX3D,EY3D,EZ3D,V3D) 1 592 P=FIELDCAL D=EFIELD 3 PAGE 875 155 - ELSEIF(ICTYPE.EQ.4)THEN 156 - CALL E3DB2X(XIN,YIN,ZIN,EX3D,EY3D,EZ3D,V3D) 157 - ELSEIF(ICTYPE.EQ.5)THEN 158 - CALL E3DB2Y(XIN,YIN,ZIN,EX3D,EY3D,EZ3D,V3D) 159 - ELSEIF(ICTYPE.EQ.10)THEN 160 - CALL E3DD10(XIN,YIN,ZIN,EX3D,EY3D,EZ3D,V3D) 161 - ELSE 162 - EX3D=0.0 163 - EY3D=0.0 164 - EZ3D=0.0 165 - V3D=0.0 166 - CALL E3DA00(XIN,YIN,ZIN,EX3D,EY3D,EZ3D,V3D) 167 - ENDIF 168 - EX=EX+EX3D 169 - EY=EY+EY3D 170 - EZ=EZ+EZ3D 171 - VOLT=VOLT+V3D 172 - ENDIF 173 - *** Add a background field if present. 174 - IF(IENBGF.GT.0)THEN 175 - CALL EFCBGF(XIN,YIN,ZIN,EXBGF,EYBGF,EZBGF,VBGF) 176 - EX=EX+EXBGF 177 - EY=EY+EYBGF 178 - EZ=EZ+EZBGF 179 - VOLT=VOLT+VBGF 180 - ENDIF 181 - *** Finally calculate the value of ETOT (magnitude of the E-field). 182 - ETOT=SQRT(EX**2+EY**2+EZ**2) 183 - END 593 GARFIELD ================================================== P=FIELDCAL D=EFCA00SC 1 ============================ 0 + +DECK,EFCA00SC,IF=-VECTOR. 1 - SUBROUTINE EFCA00(XPOS,YPOS,EX,EY,VOLT,IOPT) 2 - *----------------------------------------------------------------------- 3 - * EFCA00 - Subroutine performing the actual field calculations in case 4 - * only one charge and not more than 1 mirror-charge in either 5 - * x or y is present. 6 - * The potential used is 1/2*pi*eps0 log(r). 7 - * VARIABLES : R2 : Potential before taking -log(sqrt(...)) 8 - * EX, EY : x,y-component of the electric field. 9 - * ETOT : Magnitude of electric field. 10 - * VOLT : Potential. 11 - * EXHELP etc : One term in the series to be summed. 12 - * (XPOS,YPOS): The position where the field is calculated. 13 - * (Last changed on 25/ 1/96.) 14 - *----------------------------------------------------------------------- 15.- +SEQ,DIMENSIONS. 16.- +SEQ,CELLDATA. 17 - *** Initialise the potential and the electric field. 18 - EX=0.0 19 - EY=0.0 20 - VOLT=V0 21 - *** Loop over all wires. 22 - DO 10 I=1,NWIRE 23 - *** Calculate the field in case there are no planes. 24 - R2=(XPOS-X(I))**2+(YPOS-Y(I))**2 25 - EXHELP=(XPOS-X(I))/R2 26 - EYHELP=(YPOS-Y(I))/R2 27 - *** Take care of a plane at constant x. 28 - IF(YNPLAX)THEN 29 - XXMIRR=X(I)+(XPOS-2.0*COPLAX) 30 - R2PLAN=XXMIRR**2+(YPOS-Y(I))**2 31 - EXHELP=EXHELP-XXMIRR/R2PLAN 32 - EYHELP=EYHELP-(YPOS-Y(I))/R2PLAN 33 - R2=R2/R2PLAN 34 - ENDIF 35 - *** Take care of a plane at constant y. 36 - IF(YNPLAY)THEN 37 - YYMIRR=Y(I)+(YPOS-2.0*COPLAY) 38 - R2PLAN=(XPOS-X(I))**2+YYMIRR**2 39 - EXHELP=EXHELP-(XPOS-X(I))/R2PLAN 40 - EYHELP=EYHELP-YYMIRR/R2PLAN 41 - R2=R2/R2PLAN 42 - ENDIF 43 - *** Take care of pairs of planes. 44 - IF(YNPLAX.AND.YNPLAY)THEN 45 - R2PLAN=XXMIRR**2+YYMIRR**2 46 - EXHELP=EXHELP+XXMIRR/R2PLAN 47 - EYHELP=EYHELP+YYMIRR/R2PLAN 48 - R2=R2*R2PLAN 49 - ENDIF 50 - *** Calculate the electric field and the potential. 51 - IF(IOPT.NE.0)VOLT=VOLT-0.5*E(I)*LOG(R2) 52 - EX=EX+E(I)*EXHELP 53 - EY=EY+E(I)*EYHELP 54 - *** Finish the loop over the wires. 55 - 10 CONTINUE 56 - END 594 GARFIELD ================================================== P=FIELDCAL D=EFCA00VF 1 ============================ 0 + +DECK,EFCA00VF,IF=VECTOR. 1 - SUBROUTINE EFCA00(XPOS,YPOS,EX,EY,VOLT,IOPT) 2 - *----------------------------------------------------------------------- 3 - * EFCA00 - Subroutine performing the actual field calculations in case 4 - * only one charge and not more than 1 mirror-charge in either 5 - * x or y is present. 6 - * IBM and Cray vectorisable version - IOPT ignored. 7 - * 8 - * VARIABLES : R2 : Potential before taking -log(sqrt(...)) 9 - * EX, EY : x,y-component of the electric field. 10 - * ETOT : Magnitude of electric field. 11 - * VOLT : Potential. 12 - * EXHELP etc : One term in the series to be summed. 13 - * (XPOS,YPOS): The position where the field is calculated. 1 594 P=FIELDCAL D=EFCA00VF 2 PAGE 876 14 - * (Last changed on 23/ 2/94.) 15 - *----------------------------------------------------------------------- 16.- +SEQ,DIMENSIONS. 17.- +SEQ,CELLDATA. 18 - DOUBLE PRECISION EXS,EYS,VOLTS,R2,R2PLX,R2PLY,R2PLXY,R2PLAN 19 - *** Initialise the potential and the electric field. 20 - EXS=0.0 21 - EYS=0.0 22 - VOLTS=V0 23 - *** Both an x and a y plane. 24 - IF(YNPLAX.AND.YNPLAY)THEN 25 - DO 10 I=1,NWIRE 26 - R2= (XPOS-X(I))**2+ (YPOS-Y(I))**2 27 - R2PLX= (XPOS+X(I)-2*COPLAX)**2+(YPOS-Y(I))**2 28 - R2PLY= (XPOS-X(I))**2+ (YPOS+Y(I)-2*COPLAY)**2 29 - R2PLXY=(XPOS+X(I)-2*COPLAX)**2+(YPOS+Y(I)-2*COPLAY)**2 30 - VOLTS=VOLTS-0.5*E(I)*LOG(R2*R2PLXY/(R2PLX*R2PLY)) 31 - EXS=EXS+E(I)*((XPOS-X(I))/R2-(XPOS+X(I)-2*COPLAX)/R2PLX- 32 - - (XPOS-X(I))/R2PLY+(XPOS+X(I)-2*COPLAX)/R2PLXY) 33 - EYS=EYS+E(I)*((YPOS-Y(I))/R2-(YPOS-Y(I))/R2PLX- 34 - - (YPOS+Y(I)-2*COPLAY)/R2PLY+(YPOS+Y(I)-2*COPLAY)/R2PLXY) 35 - 10 CONTINUE 36 - *** Only an x plane. 37 - ELSEIF(YNPLAX)THEN 38 - DO 20 I=1,NWIRE 39 - R2=(XPOS-X(I))**2+(YPOS-Y(I))**2 40 - R2PLAN=(X(I)+(XPOS-2*COPLAX))**2+(YPOS-Y(I))**2 41 - VOLTS=VOLTS-0.5*E(I)*LOG(R2/R2PLAN) 42 - EXS=EX+E(I)*((XPOS-X(I))/R2-(X(I)+(XPOS-2*COPLAX))/R2PLAN) 43 - EYS=EY+E(I)*((YPOS-Y(I))/R2-(YPOS-Y(I))/R2PLAN) 44 - 20 CONTINUE 45 - *** Only an y plane. 46 - ELSEIF(YNPLAY)THEN 47 - DO 30 I=1,NWIRE 48 - R2=(XPOS-X(I))**2+(YPOS-Y(I))**2 49 - R2PLAN=(XPOS-X(I))**2+(Y(I)+(YPOS-2*COPLAY))**2 50 - VOLTS=VOLTS-0.5*E(I)*LOG(R2/R2PLAN) 51 - EXS=EXS+E(I)*((XPOS-X(I))/R2-(XPOS-X(I))/R2PLAN) 52 - EYS=EYS+E(I)*((YPOS-Y(I))/R2-(Y(I)+(YPOS-2*COPLAY))/R2PLAN) 53 - 30 CONTINUE 54 - *** No planes at all. 55 - ELSE 56 - DO 40 I=1,NWIRE 57 - R2=(XPOS-X(I))**2+(YPOS-Y(I))**2 58 - VOLTS=VOLTS-0.5*E(I)*LOG(R2) 59 - EXS=EXS+E(I)*(XPOS-X(I))/R2 60 - EYS=EYS+E(I)*(YPOS-Y(I))/R2 61 - 40 CONTINUE 62 - ENDIF 63 - *** Reduce to single precision. 64 - EX=REAL(EXS) 65 - EY=REAL(EYS) 66 - VOLT=REAL(VOLTS) 67 - END 595 GARFIELD ================================================== P=FIELDCAL D=E3DA00 1 ============================ 0 + +DECK,E3DA00. 1 - SUBROUTINE E3DA00(XPOS,YPOS,ZPOS,EX,EY,EZ,VOLT) 2 - *----------------------------------------------------------------------- 3 - * E3DA00 - Subroutine adding 3-dimensional charges for A cells. 4 - * The potential used is 1/2*pi*eps0 1/r 5 - * VARIABLES : EX, EY : x,y-component of the electric field. 6 - * ETOT : Magnitude of electric field. 7 - * VOLT : Potential. 8 - * EXHELP etc : One term in the series to be summed. 9 - * (XPOS,YPOS): The position where the field is calculated. 10 - * (Last changed on 5/12/94.) 11 - *----------------------------------------------------------------------- 12.- +SEQ,DIMENSIONS. 13.- +SEQ,CELLDATA. 14 - *** Initialise the potential and the electric field. 15 - EX=0.0 16 - EY=0.0 17 - EZ=0.0 18 - VOLT=0.0 19 - *** Loop over all charges. 20 - DO 10 I=1,N3D 21 - *** Calculate the field in case there are no planes. 22 - R=SQRT((XPOS-X3D(I))**2+(YPOS-Y3D(I))**2+(ZPOS-Z3D(I))**2) 23 - IF(R.EQ.0)GOTO 10 24 - EXHELP=-(XPOS-X3D(I))/R**3 25 - EYHELP=-(YPOS-Y3D(I))/R**3 26 - EZHELP=-(ZPOS-Z3D(I))/R**3 27 - VHELP =1/R 28 - *** Take care of a plane at constant x. 29 - IF(YNPLAX)THEN 30 - XXMIRR=X3D(I)+(XPOS-2*COPLAX) 31 - RPLAN=SQRT(XXMIRR**2+(YPOS-Y3D(I))**2) 32 - IF(RPLAN.EQ.0)GOTO 10 33 - EXHELP=EXHELP+XXMIRR/RPLAN**3 34 - EYHELP=EYHELP+(YPOS-Y3D(I))/RPLAN**3 35 - EZHELP=EZHELP+(ZPOS-Z3D(I))/RPLAN**3 36 - VHELP =VHELP-1/RPLAN 37 - ENDIF 38 - *** Take care of a plane at constant y. 39 - IF(YNPLAY)THEN 40 - YYMIRR=Y3D(I)+(YPOS-2*COPLAY) 41 - RPLAN=SQRT((XPOS-X3D(I))**2+YYMIRR**2) 42 - IF(RPLAN.EQ.0)GOTO 10 43 - EXHELP=EXHELP+(XPOS-X3D(I))/RPLAN**3 44 - EYHELP=EYHELP+YYMIRR/RPLAN**3 45 - EZHELP=EZHELP+(ZPOS-Z3D(I))/RPLAN**3 46 - VHELP =VHELP-1/RPLAN 47 - ENDIF 48 - *** Take care of pairs of planes. 1 595 P=FIELDCAL D=E3DA00 2 PAGE 877 49 - IF(YNPLAX.AND.YNPLAY)THEN 50 - RPLAN=SQRT(XXMIRR**2+YYMIRR**2) 51 - IF(RPLAN.EQ.0)GOTO 10 52 - EXHELP=EXHELP-XXMIRR/RPLAN**3 53 - EYHELP=EYHELP-YYMIRR/RPLAN**3 54 - EZHELP=EZHELP-(ZPOS-Z3D(I))/RPLAN**3 55 - VHELP =VHELP+1/RPLAN 56 - ENDIF 57 - *** Add the terms to the electric field and the potential. 58 - EX=EX-E3D(I)*EXHELP 59 - EY=EY-E3D(I)*EYHELP 60 - EZ=EZ-E3D(I)*EZHELP 61 - VOLT=VOLT+E3D(I)*VHELP 62 - *** Finish the loop over the charges. 63 - 10 CONTINUE 64 - END 596 GARFIELD ================================================== P=FIELDCAL D=EFCB1XSC 1 ============================ 0 + +DECK,EFCB1XSC,IF=-VECTOR. 1 - SUBROUTINE EFCB1X(XPOS,YPOS,EX,EY,VOLT,IOPT) 2 - *----------------------------------------------------------------------- 3 - * EFCB1X - Routine calculating the potential for a row of positive 4 - * charges. The potential used is Re(Log(sin pi/s (z-z0))). 5 - * VARIABLES : See routine EFCA00 for most of the variables. 6 - * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 7 - * ECOMPL : EX + I*EY ; I**2=-1 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,CONSTANTS. 12 - COMPLEX ZZ,ECOMPL,ZZMIRR 13 - *** Initialise EX, EY and VOLT. 14 - EX=0.0 15 - EY=0.0 16 - VOLT=V0 17 - *** Loop over all wires. 18 - DO 10 I=1,NWIRE 19 - XX=(PI/SX)*(XPOS-X(I)) 20 - YY=(PI/SX)*(YPOS-Y(I)) 21 - ZZ=CMPLX(XX,YY) 22 - *** Calculate the field in case there are no equipotential planes. 23 - IF( YY.GT.+20.0)ECOMPL=-ICONS 24 - IF(ABS(YY).LE.20.0)ECOMPL= 25 - - ICONS*(EXP(2.0*ICONS*ZZ)+1.0)/(EXP(2.0*ICONS*ZZ)-1.0) 26 - IF( YY.LT.-20.0)ECOMPL=+ICONS 27 - IF(IOPT.NE.0)THEN 28 - IF(ABS(YY).GT.20.0)R2=-ABS(YY)+CLOG2 29 - IF(ABS(YY).LE.20.0)R2=-0.5*LOG(SINH(YY)**2+SIN(XX)**2) 30 - ENDIF 31 - *** Take care of a plane at constant y. 32 - IF(YNPLAY)THEN 33 - YYMIRR=(PI/SX)*(YPOS+Y(I)-2.0*COPLAY) 34 - ZZMIRR=CMPLX(XX,YYMIRR) 35 - IF( YYMIRR.GT.+20.0)ECOMPL=ECOMPL+ICONS 36 - IF(ABS(YYMIRR).LE.20.0)ECOMPL=ECOMPL-ICONS* 37 - - (EXP(2.0*ICONS*ZZMIRR)+1.0)/(EXP(2.0*ICONS*ZZMIRR)-1.0) 38 - IF( YYMIRR.LT.-20.0)ECOMPL=ECOMPL-ICONS 39 - IF(IOPT.NE.0.AND.ABS(YYMIRR).GT.20.0) 40 - - R2=R2+ABS(YYMIRR)-CLOG2 41 - IF(IOPT.NE.0.AND.ABS(YYMIRR).LE.20.0) 42 - - R2=R2+0.5*LOG(SINH(YYMIRR)**2+SIN(XX)**2) 43 - ENDIF 44 - *** Calculate the electric field and the potential. 45 - EX=EX+E(I)*(PI/SX)*REAL(ECOMPL) 46 - EY=EY-E(I)*(PI/SX)*AIMAG(ECOMPL) 47 - IF(IOPT.NE.0)VOLT=VOLT+E(I)*R2 48 - *** Finish loop over all wires. 49 - 10 CONTINUE 50 - END 597 GARFIELD ================================================== P=FIELDCAL D=EFCB1XVF 1 ============================ 0 + +DECK,EFCB1XVF,IF=VECTOR. 1 - SUBROUTINE EFCB1X(XPOS,YPOS,EX,EY,VOLT,IOPT) 2 - *----------------------------------------------------------------------- 3 - * EFCB1X - Routine calculating the potential for a row of positive 4 - * charges. The potential used is Re(Log(sin pi/s (z-z0))). 5 - * VARIABLES : See routine EFCA00 for most of the variables. 6 - * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 7 - * ECOMPL : EX + I*EY ; I**2=-1 8 - * (IBM and Cray vectorisable version - IOPT ignored.) 9 - *----------------------------------------------------------------------- 10.- +SEQ,DIMENSIONS. 11.- +SEQ,CELLDATA. 12.- +SEQ,CONSTANTS. 13 - COMPLEX ZZ,ECOMPL,ZZMIRR 14 - *** Initialise EX, EY and VOLT. 15 - EX=0.0 16 - EY=0.0 17 - VOLT=V0 18 - *** With a y plane. 19 - IF(YNPLAY)THEN 20 - DO 10 I=1,NWIRE 21 - XX=(PI/SX)*(XPOS-X(I)) 22 - YY=(PI/SX)*(YPOS-Y(I)) 23 - ZZ=CMPLX(XX,YY) 24 - IF(YY.GT.+20.0)THEN 25 - ECOMPL=-ICONS 26 - R2=-ABS(YY)+CLOG2 27 - ELSEIF(YY.LT.-20.0)THEN 28 - ECOMPL=+ICONS 29 - R2=-ABS(YY)+CLOG2 30 - ELSE 31 - ECOMPL=ICONS*(EXP(2*ICONS*ZZ)+1)/ 32 - - (EXP(2*ICONS*ZZ)-1) 1 597 P=FIELDCAL D=EFCB1XVF 2 PAGE 878 33 - R2=-LOG(SINH(YY)**2+SIN(XX)**2)/2 34 - ENDIF 35 - YYMIRR=(PI/SX)*(YPOS+Y(I)-2*COPLAY) 36 - ZZMIRR=CMPLX(XX,YYMIRR) 37 - IF(YYMIRR.GT.+20.0)THEN 38 - ECOMPL=ECOMPL+ICONS 39 - R2=R2+ABS(YYMIRR)-CLOG2 40 - ELSEIF(YYMIRR.LT.-20.0)THEN 41 - ECOMPL=ECOMPL-ICONS 42 - R2=R2+ABS(YYMIRR)-CLOG2 43 - ELSE 44 - ECOMPL=ECOMPL-ICONS*(EXP(2*ICONS*ZZMIRR)+1)/ 45 - - (EXP(2*ICONS*ZZMIRR)-1) 46 - R2=R2+LOG(SINH(YYMIRR)**2+SIN(XX)**2)/2 47 - ENDIF 48 - * Update the field. 49 - EX=EX+E(I)*(PI/SX)*REAL(ECOMPL) 50 - EY=EY-E(I)*(PI/SX)*AIMAG(ECOMPL) 51 - VOLT=VOLT+E(I)*R2 52 - 10 CONTINUE 53 - *** Without y plane. 54 - ELSE 55 - DO 20 I=1,NWIRE 56 - XX=(PI/SX)*(XPOS-X(I)) 57 - YY=(PI/SX)*(YPOS-Y(I)) 58 - ZZ=CMPLX(XX,YY) 59 - IF(YY.GT.+20.0)THEN 60 - ECOMPL=-ICONS 61 - R2=-ABS(YY)+CLOG2 62 - ELSEIF(YY.LT.-20.0)THEN 63 - ECOMPL=+ICONS 64 - R2=-ABS(YY)+CLOG2 65 - ELSE 66 - ECOMPL=ICONS*(EXP(2*ICONS*ZZ)+1)/ 67 - - (EXP(2*ICONS*ZZ)-1) 68 - R2=-LOG(SINH(YY)**2+SIN(XX)**2)/2 69 - ENDIF 70 - EX=EX+E(I)*(PI/SX)*REAL(ECOMPL) 71 - EY=EY-E(I)*(PI/SX)*AIMAG(ECOMPL) 72 - VOLT=VOLT+E(I)*R2 73 - 20 CONTINUE 74 - ENDIF 75 - END 598 GARFIELD ================================================== P=FIELDCAL D=EFCB1YSC 1 ============================ 0 + +DECK,EFCB1YSC,IF=-VECTOR. 1 - SUBROUTINE EFCB1Y(XPOS,YPOS,EX,EY,VOLT,IOPT) 2 - *----------------------------------------------------------------------- 3 - * EFCB1Y - Routine calculating the potential for a row of positive 4 - * charges. The potential used is Re(Log(sinh pi/sy(z-z0)). 5 - * VARIABLES : See routine EFCA00 for most of the variables. 6 - * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 7 - * ECOMPL : EX + I*EY ; I**2=-1 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,CONSTANTS. 12 - COMPLEX ZZ,ECOMPL,ZZMIRR 13 - *** Initialise EX, EY and VOLT. 14 - EX=0.0 15 - EY=0.0 16 - VOLT=V0 17 - *** Loop over all wires. 18 - DO 10 I=1,NWIRE 19 - XX=(PI/SY)*(XPOS-X(I)) 20 - YY=(PI/SY)*(YPOS-Y(I)) 21 - ZZ=CMPLX(XX,YY) 22 - *** Calculate the field in case there are no equipotential planes. 23 - IF( XX.GT.+20.0)ECOMPL=+1.0 24 - IF(ABS(XX).LE.20.0)ECOMPL=(EXP(2.0*ZZ)+1.0)/(EXP(2.0*ZZ)-1.0) 25 - IF( XX.LT.-20.0)ECOMPL=-1.0 26 - IF(IOPT.NE.0)THEN 27 - IF(ABS(XX).GT.20.0)R2=-ABS(XX)+CLOG2 28 - IF(ABS(XX).LE.20.0)R2=-0.5*LOG(SINH(XX)**2+SIN(YY)**2) 29 - ENDIF 30 - *** Take care of a plane at constant x. 31 - IF(YNPLAX)THEN 32 - XXMIRR=(PI/SY)*(XPOS+X(I)-2.0*COPLAX) 33 - ZZMIRR=CMPLX(XXMIRR,YY) 34 - IF(XXMIRR.GT.+20.0)ECOMPL=ECOMPL-1.0 35 - IF(XXMIRR.LT.-20.0)ECOMPL=ECOMPL+1.0 36 - IF(ABS(XXMIRR).LE.20.0)ECOMPL=ECOMPL- 37 - - (EXP(2.0*ZZMIRR)+1.0)/(EXP(2.0*ZZMIRR)-1.0) 38 - IF(IOPT.NE.0.AND.ABS(XXMIRR).GT.20.0) 39 - - R2=R2+ABS(XXMIRR)-CLOG2 40 - IF(IOPT.NE.0.AND.ABS(XXMIRR).LE.20.0) 41 - - R2=R2+0.5*LOG(SINH(XXMIRR)**2+SIN(YY)**2) 42 - ENDIF 43 - *** Calculate the electric field and the potential. 44 - EX=EX+E(I)*(PI/SY)*REAL(ECOMPL) 45 - EY=EY-E(I)*(PI/SY)*AIMAG(ECOMPL) 46 - IF(IOPT.NE.0)VOLT=VOLT+E(I)*R2 47 - *** Finish loop over the wires. 48 - 10 CONTINUE 49 - END 599 GARFIELD ================================================== P=FIELDCAL D=EFCB1YVF 1 ============================ 0 + +DECK,EFCB1YVF,IF=VECTOR. 1 - SUBROUTINE EFCB1Y(XPOS,YPOS,EX,EY,VOLT,IOPT) 2 - *----------------------------------------------------------------------- 3 - * EFCB1Y - Routine calculating the potential for a row of positive 4 - * charges. The potential used is Re(Log(sinh pi/sy(z-z0)). 5 - * VARIABLES : See routine EFCA00 for most of the variables. 6 - * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 1 599 P=FIELDCAL D=EFCB1YVF 2 PAGE 879 7 - * ECOMPL : EX + I*EY ; I**2=-1 8 - * (IBM and Cray vectorisable version.) 9 - *----------------------------------------------------------------------- 10.- +SEQ,DIMENSIONS. 11.- +SEQ,CELLDATA. 12.- +SEQ,CONSTANTS. 13 - COMPLEX ZZ,ECOMPL,ZZMIRR 14 - *** Initialise EX, EY and VOLT. 15 - EX=0.0 16 - EY=0.0 17 - VOLT=V0 18 - *** First the situation there is an x-plane. 19 - IF(YNPLAX)THEN 20 - DO 10 I=1,NWIRE 21 - XX=(PI/SY)*(XPOS-X(I)) 22 - YY=(PI/SY)*(YPOS-Y(I)) 23 - ZZ=CMPLX(XX,YY) 24 - IF(XX.GT.+20.0)THEN 25 - ECOMPL=+1.0 26 - R2=-ABS(XX)+CLOG2 27 - ELSEIF(XX.LT.-20.0)THEN 28 - ECOMPL=-1.0 29 - R2=-ABS(XX)+CLOG2 30 - ELSE 31 - ECOMPL=(EXP(2*ZZ)+1)/(EXP(2*ZZ)-1) 32 - R2=-LOG(SINH(XX)**2+SIN(YY)**2)/2 33 - ENDIF 34 - XXMIRR=(PI/SY)*(XPOS+X(I)-2.0*COPLAX) 35 - ZZMIRR=CMPLX(XXMIRR,YY) 36 - IF(XXMIRR.GT.+20.0)THEN 37 - ECOMPL=ECOMPL-1.0 38 - R2=R2+ABS(XXMIRR)-CLOG2 39 - ELSEIF(XXMIRR.LT.-20.0)THEN 40 - ECOMPL=ECOMPL+1.0 41 - R2=R2+ABS(XXMIRR)-CLOG2 42 - ELSE 43 - ECOMPL=ECOMPL-(EXP(2*ZZMIRR)+1)/(EXP(2*ZZMIRR)-1) 44 - R2=R2+LOG(SINH(XXMIRR)**2+SIN(YY)**2)/2 45 - ENDIF 46 - EX=EX+E(I)*(PI/SY)*REAL(ECOMPL) 47 - EY=EY-E(I)*(PI/SY)*AIMAG(ECOMPL) 48 - VOLT=VOLT+E(I)*R2 49 - 10 CONTINUE 50 - *** Case the is no plane. 51 - ELSE 52 - DO 20 I=1,NWIRE 53 - XX=(PI/SY)*(XPOS-X(I)) 54 - YY=(PI/SY)*(YPOS-Y(I)) 55 - ZZ=CMPLX(XX,YY) 56 - IF(XX.GT.+20.0)THEN 57 - ECOMPL=+1.0 58 - R2=-ABS(XX)+CLOG2 59 - ELSEIF(XX.LT.-20.0)THEN 60 - ECOMPL=-1.0 61 - R2=-ABS(XX)+CLOG2 62 - ELSE 63 - ECOMPL=(EXP(2*ZZ)+1)/(EXP(2*ZZ)-1) 64 - R2=-LOG(SINH(XX)**2+SIN(YY)**2)/2 65 - ENDIF 66 - EX=EX+E(I)*(PI/SY)*REAL(ECOMPL) 67 - EY=EY-E(I)*(PI/SY)*AIMAG(ECOMPL) 68 - VOLT=VOLT+E(I)*R2 69 - 20 CONTINUE 70 - ENDIF 71 - END 600 GARFIELD ================================================== P=FIELDCAL D=EFCB2X 1 ============================ 0 + +DECK,EFCB2X. 1 - SUBROUTINE EFCB2X(XPOS,YPOS,EX,EY,VOLT,IOPT) 2 - *----------------------------------------------------------------------- 3 - * EFCB2X - Routine calculating the potential for a row of alternating 4 - * + - charges. The potential used is re log(sin pi/sx (z-z0)) 5 - * VARIABLES : See routine EFCA00 for most of the variables. 6 - * Z, ZZMRR : X + i*Y , XXMIRR + i*YYMIRR ; i**2=-1 7 - * ECOMPL : EX + i*EY ; i**2=-1 8 - * (Cray vectorisable) 9 - *----------------------------------------------------------------------- 10.- +SEQ,DIMENSIONS. 11.- +SEQ,CELLDATA. 12.- +SEQ,CONSTANTS. 13 - COMPLEX ZZ,ECOMPL,ZZMIRR,ZZNEG,ZZNMIR 14 - *** Initialise EX, EY and VOLT. 15 - EX=0.0 16 - EY=0.0 17 - VOLT=V0 18 - *** Loop over all wires. 19 - DO 10 I=1,NWIRE 20 - XX=(0.5*PI/SX)*(XPOS-X(I)) 21 - YY=(0.5*PI/SX)*(YPOS-Y(I)) 22 - XXNEG=(0.5*PI/SX)*(XPOS+X(I)-2.0*COPLAX) 23 - ZZ=CMPLX(XX,YY) 24 - ZZNEG=CMPLX(XXNEG,YY) 25 - *** Calculate the field in case there are no equipotential planes. 26 - ECOMPL=0.0 27 - R2=1.0 28 - IF(ABS(YY).LE.20)ECOMPL=-B2SIN(I)/(SIN(ZZ)*SIN(ZZNEG)) 29 - IF(IOPT.NE.0.AND.ABS(YY).LE.20.0) 30 - - R2=(SINH(YY)**2+SIN(XX)**2)/(SINH(YY)**2+SIN(XXNEG)**2) 31 - *** Take care of a planes at constant y. 32 - IF(YNPLAY)THEN 33 - YYMIRR=(0.5*PI/SX)*(YPOS+Y(I)-2.0*COPLAY) 34 - ZZMIRR=CMPLX(XX,YYMIRR) 35 - ZZNMIR=CMPLX(XXNEG,YYMIRR) 36 - IF(ABS(YYMIRR).LE.20.0) 37 - - ECOMPL=ECOMPL+B2SIN(I)/(SIN(ZZMIRR)*SIN(ZZNMIR)) 1 600 P=FIELDCAL D=EFCB2X 2 PAGE 880 38 - IF(IOPT.NE.0.AND.ABS(YYMIRR).LE.20.0)THEN 39 - R2PLAN=(SINH(YYMIRR)**2+SIN(XX)**2)/ 40 - - (SINH(YYMIRR)**2+SIN(XXNEG)**2) 41 - R2=R2/R2PLAN 42 - ENDIF 43 - ENDIF 44 - *** Calculate the electric field and the potential. 45 - EX=EX+E(I)*(0.5*PI/SX)*REAL(ECOMPL) 46 - EY=EY-E(I)*(0.5*PI/SX)*AIMAG(ECOMPL) 47 - IF(IOPT.NE.0)VOLT=VOLT-0.5*E(I)*LOG(R2) 48 - *** Finish the wire loop. 49 - 10 CONTINUE 50 - END 601 GARFIELD ================================================== P=FIELDCAL D=E3DB2X 1 ============================ 0 + +DECK,E3DB2X. 1 - SUBROUTINE E3DB2X(XPOS,YPOS,ZPOS,EX,EY,EZ,VOLT) 2 - *----------------------------------------------------------------------- 3 - * E3DB2X - Routine calculating the potential for a 3 dimensional point 4 - * charge between two plates at constant x. 5 - * The series expansions for the modified Bessel functions 6 - * have been taken from Abramowitz and Stegun. 7 - * VARIABLES : See routine E3DA00 for most of the variables. 8 - * (Last changed on 5/12/94.) 9 - *----------------------------------------------------------------------- 10.- +SEQ,DIMENSIONS. 11.- +SEQ,CELLDATA. 12.- +SEQ,CONSTANTS. 13 - DOUBLE PRECISION EXSUM,EYSUM,EZSUM,VSUM, 14 - - I0S,I1S,K0S,K0L,K1S,K1L,K0R,K1R,K0RM,K1RM, 15 - - XX,RR,RRM,ZZP,ZZN,RR1,RR2,RM1,RM2,ERR,EZZ 16 - REAL XPOS,YPOS,ZPOS,EX,EY,EZ,VOLT,RCUT 17 - PARAMETER(RCUT=1.0) 18 - *** Statement functions for the modified Bessel functions: 19 - I0S(XX)=1 20 - - +3.5156229*(XX/3.75)**2 21 - - +3.0899424*(XX/3.75)**4 22 - - +1.2067492*(XX/3.75)**6 23 - - +0.2659732*(XX/3.75)**8 24 - - +0.0360768*(XX/3.75)**10 25 - - +0.0045813*(XX/3.75)**12 26 - I1S(XX)=XX*( 27 - - +0.5 28 - - +0.87890594*(XX/3.75)**2 29 - - +0.51498869*(XX/3.75)**4 30 - - +0.15084934*(XX/3.75)**6 31 - - +0.02658733*(XX/3.75)**8 32 - - +0.00301532*(XX/3.75)**10 33 - - +0.00032411*(XX/3.75)**12) 34 - K0S(XX)=-LOG(XX/2)*I0S(XX) 35 - - -0.57721566 36 - - +0.42278420*(XX/2)**2 37 - - +0.23069756*(XX/2)**4 38 - - +0.03488590*(XX/2)**6 39 - - +0.00262698*(XX/2)**8 40 - - +0.00010750*(XX/2)**10 41 - - +0.00000740*(XX/2)**12 42 - K0L(XX)=(EXP(-XX)/SQRT(XX))*( 43 - - +1.25331414 44 - - -0.07832358*(2/XX) 45 - - +0.02189568*(2/XX)**2 46 - - -0.01062446*(2/XX)**3 47 - - +0.00587872*(2/XX)**4 48 - - -0.00251540*(2/XX)**5 49 - - +0.00053208*(2/XX)**6) 50 - K1S(XX)=LOG(XX/2)*I1S(XX)+(1/XX)*( 51 - - +1 52 - - +0.15443144*(XX/2)**2 53 - - -0.67278579*(XX/2)**4 54 - - -0.18156897*(XX/2)**6 55 - - -0.01919402*(XX/2)**8 56 - - -0.00110404*(XX/2)**10 57 - - -0.00004686*(XX/2)**12) 58 - K1L(XX)=(EXP(-XX)/SQRT(XX))*( 59 - - +1.25331414 60 - - +0.23498619*(2/XX) 61 - - -0.03655620*(2/XX)**2 62 - - +0.01504268*(2/XX)**3 63 - - -0.00780353*(2/XX)**4 64 - - +0.00325614*(2/XX)**5 65 - - -0.00068245*(2/XX)**6) 66 - *** Initialise the sums for the field components. 67 - EX=0.0 68 - EY=0.0 69 - EZ=0.0 70 - VOLT=0.0 71 - *** Loop over all wires. 72 - DO 10 I=1,N3D 73 - * Skip wires that are on the charge. 74 - IF(XPOS.EQ.X3D(I).AND.YPOS.EQ.Y3D(I).AND.ZPOS.EQ.Z3D(I))GOTO 10 75 - *** In the far away zone, sum the modified Bessel function series. 76 - IF((YPOS-Y3D(I))**2+(ZPOS-Z3D(I))**2.GT.(RCUT*2*SX)**2)THEN 77 - * Initialise the per-wire sum. 78 - EXSUM=0.0 79 - EYSUM=0.0 80 - EZSUM=0.0 81 - VSUM=0.0 82 - * Loop over the terms in the series. 83 - DO 20 J=1,NTERMB 84 - * Obtain reduced coordinates. 85 - RR=PI*J*SQRT((YPOS-Y3D(I))**2+(ZPOS-Z3D(I))**2)/SX 86 - ZZP=PI*J*(XPOS-X3D(I))/SX 87 - ZZN=PI*J*(XPOS+X3D(I)-2*COPLAX)/SX 88 - * Evaluate the Bessel functions for this R. 89 - IF(RR.LT.2)THEN 1 601 P=FIELDCAL D=E3DB2X 2 PAGE 881 90 - K0R=K0S(RR) 91 - K1R=K1S(RR) 92 - ELSE 93 - K0R=K0L(RR) 94 - K1R=K1L(RR) 95 - ENDIF 96 - * Get the field components. 97 - VSUM=VSUM+(1/SX)*K0R*(COS(ZZP)-COS(ZZN)) 98 - ERR=(2*J*PI/SX**2)*K1R*(COS(ZZP)-COS(ZZN)) 99 - EZZ=(2*J*PI/SX**2)*K0R*(SIN(ZZP)-SIN(ZZN)) 100 - EXSUM=EXSUM+EZZ 101 - EYSUM=EYSUM+ERR*(YPOS-Y3D(I))/ 102 - - SQRT((YPOS-Y3D(I))**2+(ZPOS-Z3D(I))**2) 103 - EZSUM=EZSUM+ERR*(ZPOS-Z3D(I))/ 104 - - SQRT((YPOS-Y3D(I))**2+(ZPOS-Z3D(I))**2) 105 - 20 CONTINUE 106 - *** Direct polynomial summing, obtain reduced coordinates. 107 - ELSE 108 - * Loop over the terms. 109 - DO 30 J=0,NTERMP 110 - * Simplify the references to the distances. 111 - RR1=SQRT((XPOS-X3D(I)+J*2*SX)**2+(YPOS-Y3D(I))**2+ 112 - - (ZPOS-Z3D(I))**2) 113 - RR2=SQRT((XPOS-X3D(I)-J*2*SX)**2+(YPOS-Y3D(I))**2+ 114 - - (ZPOS-Z3D(I))**2) 115 - RM1=SQRT((XPOS+X3D(I)-J*2*SX-2*COPLAX)**2+ 116 - - (YPOS-Y3D(I))**2+(ZPOS-Z3D(I))**2) 117 - RM2=SQRT((XPOS+X3D(I)+J*2*SX-2*COPLAX)**2+ 118 - - (YPOS-Y3D(I))**2+(ZPOS-Z3D(I))**2) 119 - * Initialisation of the sum: only a charge and a mirror charge. 120 - IF(J.EQ.0)THEN 121 - VSUM=1/RR1-1/RM1 122 - EXSUM=(XPOS-X3D(I))/RR1**3- 123 - - (XPOS+X3D(I)-2*COPLAX)/RM1**3 124 - EYSUM=(YPOS-Y3D(I))*(1/RR1**3-1/RM1**3) 125 - EZSUM=(ZPOS-Z3D(I))*(1/RR1**3-1/RM1**3) 126 - * Further terms in the series: 2 charges and 2 mirror charges. 127 - ELSE 128 - VSUM=VSUM+1/RR1+1/RR2-1/RM1-1/RM2 129 - EXSUM=EXSUM+ 130 - - (XPOS-X3D(I)+J*2*SX)/RR1**3+ 131 - - (XPOS-X3D(I)-J*2*SX)/RR2**3- 132 - - (XPOS+X3D(I)-J*2*SX-2*COPLAX)/RM1**3- 133 - - (XPOS+X3D(I)+J*2*SX-2*COPLAX)/RM2**3 134 - EYSUM=EYSUM+(YPOS-Y3D(I))* 135 - - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) 136 - EZSUM=EZSUM+(ZPOS-Z3D(I))* 137 - - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) 138 - ENDIF 139 - 30 CONTINUE 140 - ENDIF 141 - *** Take care of a planes at constant y. 142 - IF(YNPLAY)THEN 143 - *** Bessel function series. 144 - IF((YPOS+Y3D(I)-2*COPLAY)**2+(ZPOS-Z3D(I))**2.GT. 145 - - (RCUT*2*SX)**2)THEN 146 - * Loop over the terms in the series. 147 - DO 40 J=1,NTERMB 148 - * Obtain reduced coordinates. 149 - RRM=PI*J*SQRT((YPOS+Y3D(I)-2*COPLAY)**2+ 150 - - (ZPOS-Z3D(I))**2)/SX 151 - ZZP=PI*J*(XPOS-X3D(I))/SX 152 - ZZN=PI*J*(XPOS+X3D(I)-2*COPLAX)/SX 153 - * Evaluate the Bessel functions for this R. 154 - IF(RRM.LT.2)THEN 155 - K0RM=K0S(RRM) 156 - K1RM=K1S(RRM) 157 - ELSE 158 - K0RM=K0L(RRM) 159 - K1RM=K1L(RRM) 160 - ENDIF 161 - * Get the field components. 162 - VSUM=VSUM+(1/SX)*K0RM*(COS(ZZP)-COS(ZZN)) 163 - ERR=(2*PI/SX**2)*K1RM*(COS(ZZP)-COS(ZZN)) 164 - EZZ=(2*PI/SX**2)*K0RM*(SIN(ZZP)-SIN(ZZN)) 165 - EXSUM=EXSUM+EZZ 166 - EYSUM=EYSUM+ERR*(YPOS+Y3D(I)-2*COPLAY)/ 167 - - SQRT((YPOS+Y3D(I)-2*COPLAY)**2+(ZPOS-Z3D(I))**2) 168 - EZSUM=EZSUM+ERR*(ZPOS-Z3D(I))/ 169 - - SQRT((YPOS+Y3D(I)-2*COPLAY)**2+(ZPOS-Z3D(I))**2) 170 - 40 CONTINUE 171 - *** Polynomial sum. 172 - ELSE 173 - * Loop over the terms. 174 - DO 50 J=0,NTERMP 175 - * Simplify the references to the distances. 176 - RR1=SQRT((XPOS-X3D(I)+J*2*SX)**2+ 177 - - (YPOS+Y3D(I)-2*COPLAY)**2+(ZPOS-Z3D(I))**2) 178 - RR2=SQRT((XPOS-X3D(I)-J*2*SX)**2+ 179 - - (YPOS+Y3D(I)-2*COPLAY)**2+(ZPOS-Z3D(I))**2) 180 - RM1=SQRT((XPOS+X3D(I)-J*2*SX-2*COPLAX)**2+ 181 - - (YPOS+Y3D(I)-2*COPLAY)**2+(ZPOS-Z3D(I))**2) 182 - RM2=SQRT((XPOS+X3D(I)+J*2*SX-2*COPLAX)**2+ 183 - - (YPOS+Y3D(I)-2*COPLAY)**2+(ZPOS-Z3D(I))**2) 184 - * Initialisation of the sum: only a charge and a mirror charge. 185 - IF(J.EQ.0)THEN 186 - VSUM=VSUM-1/RR1+1/RM1 187 - EXSUM=EXSUM-(XPOS-X3D(I))/RR1**3+ 188 - - (XPOS+X3D(I)-2*COPLAX)/RM1**3 189 - EYSUM=EYSUM-(YPOS+Y3D(I)-2*COPLAY)* 190 - - (1/RR1**3-1/RM1**3) 191 - EZSUM=EZSUM-(ZPOS-Z3D(I))*(1/RR1**3-1/RM1**3) 192 - * Further terms in the series: 2 charges and 2 mirror charges. 193 - ELSE 194 - VSUM=VSUM-1/RR1-1/RR2+1/RM1+1/RM2 195 - EXSUM=EXSUM- 1 601 P=FIELDCAL D=E3DB2X 3 PAGE 882 196 - - (XPOS-X3D(I)+J*2*SX)/RR1**3- 197 - - (XPOS-X3D(I)-J*2*SX)/RR2**3+ 198 - - (XPOS+X3D(I)-J*2*SX-2*COPLAX)/RM1**3+ 199 - - (XPOS+X3D(I)+J*2*SX-2*COPLAX)/RM2**3 200 - EYSUM=EYSUM-(YPOS+Y3D(I)-2*COPLAY)* 201 - - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) 202 - EZSUM=EZSUM-(ZPOS-Z3D(I))* 203 - - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) 204 - ENDIF 205 - 50 CONTINUE 206 - ENDIF 207 - ENDIF 208 - *** Convert the double precision sum to single precision. 209 - EX=EX+E3D(I)*REAL(EXSUM) 210 - EY=EY+E3D(I)*REAL(EYSUM) 211 - EZ=EZ+E3D(I)*REAL(EZSUM) 212 - VOLT=VOLT+E3D(I)*REAL(VSUM) 213 - *** Finish the loop over the charges. 214 - 10 CONTINUE 215 - END 602 GARFIELD ================================================== P=FIELDCAL D=EFCB2Y 1 ============================ 0 + +DECK,EFCB2Y. 1 - SUBROUTINE EFCB2Y(XPOS,YPOS,EX,EY,VOLT,IOPT) 2 - *----------------------------------------------------------------------- 3 - * EFCB2Y - Routine calculating the potential for a row of alternating 4 - * + - charges. The potential used is re log(sin pi/sx (z-z0)) 5 - * VARIABLES : See routine EFCA00 for most of the variables. 6 - * Z, ZMIRR : X + i*Y , XXMIRR + i*YYMIRR ; i**2=-1 7 - * ECOMPL : EX + i*EY ; i**2=-1 8 - * (Cray vectorisable) 9 - *----------------------------------------------------------------------- 10.- +SEQ,DIMENSIONS. 11.- +SEQ,CELLDATA. 12.- +SEQ,CONSTANTS. 13 - COMPLEX ZZ,ECOMPL,ZZMIRR,ZZNEG,ZZNMIR 14 - *** Initialise EX, EY and VOLT. 15 - EX=0.0 16 - EY=0.0 17 - VOLT=V0 18 - *** Loop over all wires. 19 - DO 10 I=1,NWIRE 20 - XX=(0.5*PI/SY)*(XPOS-X(I)) 21 - YY=(0.5*PI/SY)*(YPOS-Y(I)) 22 - YYNEG=(0.5*PI/SY)*(YPOS+Y(I)-2.0*COPLAY) 23 - ZZ=CMPLX(XX,YY) 24 - ZZNEG=CMPLX(XX,YYNEG) 25 - *** Calculate the field in case there are no equipotential planes. 26 - ECOMPL=0.0 27 - R2=1.0 28 - IF(ABS(XX).LE.20.0) 29 - - ECOMPL=ICONS*B2SIN(I)/(SIN(ICONS*ZZ)*SIN(ICONS*ZZNEG)) 30 - IF(IOPT.NE.0.AND.ABS(XX).LE.20.0) 31 - - R2=(SINH(XX)**2+SIN(YY)**2)/(SINH(XX)**2+SIN(YYNEG)**2) 32 - *** Take care of a plane at constant x. 33 - IF(YNPLAX)THEN 34 - XXMIRR=(0.5*PI/SY)*(XPOS+X(I)-2.0*COPLAX) 35 - ZZMIRR=CMPLX(XXMIRR,YY) 36 - ZZNMIR=CMPLX(XXMIRR,YYNEG) 37 - IF(ABS(XXMIRR).LE.20.0)ECOMPL=ECOMPL- 38 - - ICONS*B2SIN(I)/(SIN(ICONS*ZZMIRR)*SIN(ICONS*ZZNMIR)) 39 - IF(IOPT.NE.0.AND.ABS(XXMIRR).LE.20.0)THEN 40 - R2PLAN=(SINH(XXMIRR)**2+SIN(YY)**2)/ 41 - - (SINH(XXMIRR)**2+SIN(YYNEG)**2) 42 - R2=R2/R2PLAN 43 - ENDIF 44 - ENDIF 45 - *** Calculate the electric field and the potential. 46 - EX=EX+E(I)*(0.5*PI/SY)*REAL(ECOMPL) 47 - EY=EY-E(I)*(0.5*PI/SY)*AIMAG(ECOMPL) 48 - IF(IOPT.NE.0)VOLT=VOLT-0.5*E(I)*LOG(R2) 49 - *** Finish the wire loop. 50 - 10 CONTINUE 51 - END 603 GARFIELD ================================================== P=FIELDCAL D=E3DB2Y 1 ============================ 0 + +DECK,E3DB2Y. 1 - SUBROUTINE E3DB2Y(XPOS,YPOS,ZPOS,EX,EY,EZ,VOLT) 2 - *----------------------------------------------------------------------- 3 - * E3DB2Y - Routine calculating the potential for a 3 dimensional point 4 - * charge between two plates at constant y. 5 - * The series expansions for the modified Bessel functions 6 - * have been taken from Abramowitz and Stegun. 7 - * VARIABLES : See routine E3DA00 for most of the variables. 8 - * (Last changed on 5/12/94.) 9 - *----------------------------------------------------------------------- 10.- +SEQ,DIMENSIONS. 11.- +SEQ,CELLDATA. 12.- +SEQ,CONSTANTS. 13 - DOUBLE PRECISION EXSUM,EYSUM,EZSUM,VSUM, 14 - - I0S,I1S,K0S,K0L,K1S,K1L,K0R,K1R,K0RM,K1RM, 15 - - XX,RR,RRM,ZZP,ZZN,RR1,RR2,RM1,RM2,ERR,EZZ 16 - REAL XPOS,YPOS,ZPOS,EX,EY,EZ,VOLT,RCUT 17 - PARAMETER(RCUT=1.0) 18 - *** Statement functions for the modified Bessel functions: 19 - I0S(XX)=1 20 - - +3.5156229*(XX/3.75)**2 21 - - +3.0899424*(XX/3.75)**4 22 - - +1.2067492*(XX/3.75)**6 23 - - +0.2659732*(XX/3.75)**8 24 - - +0.0360768*(XX/3.75)**10 25 - - +0.0045813*(XX/3.75)**12 26 - I1S(XX)=XX*( 27 - - +0.5 1 603 P=FIELDCAL D=E3DB2Y 2 PAGE 883 28 - - +0.87890594*(XX/3.75)**2 29 - - +0.51498869*(XX/3.75)**4 30 - - +0.15084934*(XX/3.75)**6 31 - - +0.02658733*(XX/3.75)**8 32 - - +0.00301532*(XX/3.75)**10 33 - - +0.00032411*(XX/3.75)**12) 34 - K0S(XX)=-LOG(XX/2)*I0S(XX) 35 - - -0.57721566 36 - - +0.42278420*(XX/2)**2 37 - - +0.23069756*(XX/2)**4 38 - - +0.03488590*(XX/2)**6 39 - - +0.00262698*(XX/2)**8 40 - - +0.00010750*(XX/2)**10 41 - - +0.00000740*(XX/2)**12 42 - K0L(XX)=(EXP(-XX)/SQRT(XX))*( 43 - - +1.25331414 44 - - -0.07832358*(2/XX) 45 - - +0.02189568*(2/XX)**2 46 - - -0.01062446*(2/XX)**3 47 - - +0.00587872*(2/XX)**4 48 - - -0.00251540*(2/XX)**5 49 - - +0.00053208*(2/XX)**6) 50 - K1S(XX)=LOG(XX/2)*I1S(XX)+(1/XX)*( 51 - - +1 52 - - +0.15443144*(XX/2)**2 53 - - -0.67278579*(XX/2)**4 54 - - -0.18156897*(XX/2)**6 55 - - -0.01919402*(XX/2)**8 56 - - -0.00110404*(XX/2)**10 57 - - -0.00004686*(XX/2)**12) 58 - K1L(XX)=(EXP(-XX)/SQRT(XX))*( 59 - - +1.25331414 60 - - +0.23498619*(2/XX) 61 - - -0.03655620*(2/XX)**2 62 - - +0.01504268*(2/XX)**3 63 - - -0.00780353*(2/XX)**4 64 - - +0.00325614*(2/XX)**5 65 - - -0.00068245*(2/XX)**6) 66 - *** Initialise the sums for the field components. 67 - EX=0.0 68 - EY=0.0 69 - EZ=0.0 70 - VOLT=0.0 71 - *** Loop over all wires. 72 - DO 10 I=1,N3D 73 - * Skip wires that are on the charge. 74 - IF(XPOS.EQ.X3D(I).AND.YPOS.EQ.Y3D(I).AND.ZPOS.EQ.Z3D(I))GOTO 10 75 - *** In the far away zone, sum the modified Bessel function series. 76 - IF((XPOS-X3D(I))**2+(ZPOS-Z3D(I))**2.GT.(RCUT*2*SY)**2)THEN 77 - * Initialise the per-wire sum. 78 - EXSUM=0.0 79 - EYSUM=0.0 80 - EZSUM=0.0 81 - VSUM=0.0 82 - * Loop over the terms in the series. 83 - DO 20 J=1,NTERMB 84 - * Obtain reduced coordinates. 85 - RR=PI*J*SQRT((XPOS-X3D(I))**2+(ZPOS-Z3D(I))**2)/SY 86 - ZZP=PI*J*(YPOS-Y3D(I))/SY 87 - ZZN=PI*J*(YPOS+Y3D(I)-2*COPLAY)/SY 88 - * Evaluate the Bessel functions for this R. 89 - IF(RR.LT.2)THEN 90 - K0R=K0S(RR) 91 - K1R=K1S(RR) 92 - ELSE 93 - K0R=K0L(RR) 94 - K1R=K1L(RR) 95 - ENDIF 96 - * Get the field components. 97 - VSUM=VSUM+(1/SY)*K0R*(COS(ZZP)-COS(ZZN)) 98 - ERR=(2*J*PI/SY**2)*K1R*(COS(ZZP)-COS(ZZN)) 99 - EZZ=(2*J*PI/SY**2)*K0R*(SIN(ZZP)-SIN(ZZN)) 100 - EXSUM=EXSUM+ERR*(XPOS-X3D(I))/ 101 - - SQRT((XPOS-X3D(I))**2+(ZPOS-Z3D(I))**2) 102 - EYSUM=EYSUM+EZZ 103 - EZSUM=EZSUM+ERR*(ZPOS-Z3D(I))/ 104 - - SQRT((XPOS-X3D(I))**2+(ZPOS-Z3D(I))**2) 105 - 20 CONTINUE 106 - *** Direct polynomial summing, obtain reduced coordinates. 107 - ELSE 108 - * Loop over the terms. 109 - DO 30 J=0,NTERMP 110 - * Simplify the references to the distances. 111 - RR1=SQRT((XPOS-X3D(I))**2+(YPOS-Y3D(I)+J*2*SY)**2+ 112 - - (ZPOS-Z3D(I))**2) 113 - RR2=SQRT((XPOS-X3D(I))**2+(YPOS-Y3D(I)-J*2*SY)**2+ 114 - - (ZPOS-Z3D(I))**2) 115 - RM1=SQRT((XPOS-X3D(I))**2+ 116 - - (YPOS+Y3D(I)-J*2*SY-2*COPLAY)**2+(ZPOS-Z3D(I))**2) 117 - RM2=SQRT((XPOS-X3D(I))**2+ 118 - - (YPOS+Y3D(I)+J*2*SY-2*COPLAY)**2+(ZPOS-Z3D(I))**2) 119 - * Initialisation of the sum: only a charge and a mirror charge. 120 - IF(J.EQ.0)THEN 121 - VSUM=1/RR1-1/RM1 122 - EXSUM=(XPOS-X3D(I))*(1/RR1**3-1/RM1**3) 123 - EYSUM=(YPOS-Y3D(I))/RR1**3- 124 - - (YPOS+Y3D(I)-2*COPLAY)/RM1**3 125 - EZSUM=(ZPOS-Z3D(I))*(1/RR1**3-1/RM1**3) 126 - * Further terms in the series: 2 charges and 2 mirror charges. 127 - ELSE 128 - VSUM=VSUM+1/RR1+1/RR2-1/RM1-1/RM2 129 - EXSUM=EXSUM+(XPOS-X3D(I))* 130 - - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) 131 - EYSUM=EYSUM+ 132 - - (YPOS-Y3D(I)+J*2*SY)/RR1**3+ 133 - - (YPOS-Y3D(I)-J*2*SY)/RR2**3- 1 603 P=FIELDCAL D=E3DB2Y 3 PAGE 884 134 - - (YPOS+Y3D(I)-J*2*SY-2*COPLAY)/RM1**3- 135 - - (YPOS+Y3D(I)+J*2*SY-2*COPLAY)/RM2**3 136 - EZSUM=EZSUM+(ZPOS-Z3D(I))* 137 - - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) 138 - ENDIF 139 - 30 CONTINUE 140 - ENDIF 141 - *** Take care of a planes at constant x. 142 - IF(YNPLAX)THEN 143 - *** Bessel function series. 144 - IF((XPOS+X3D(I)-2*COPLAX)**2+(ZPOS-Z3D(I))**2.GT. 145 - - (RCUT*2*SY)**2)THEN 146 - * Loop over the terms in the series. 147 - DO 40 J=1,NTERMB 148 - * Obtain reduced coordinates. 149 - RRM=PI*J*SQRT((XPOS+X3D(I)-2*COPLAX)**2+ 150 - - (ZPOS-Z3D(I))**2)/SY 151 - ZZP=PI*J*(YPOS-Y3D(I))/SY 152 - ZZN=PI*J*(YPOS+Y3D(I)-2*COPLAY)/SY 153 - * Evaluate the Bessel functions for this R. 154 - IF(RRM.LT.2)THEN 155 - K0RM=K0S(RRM) 156 - K1RM=K1S(RRM) 157 - ELSE 158 - K0RM=K0L(RRM) 159 - K1RM=K1L(RRM) 160 - ENDIF 161 - * Get the field components. 162 - VSUM=VSUM+(1/SY)*K0RM*(COS(ZZP)-COS(ZZN)) 163 - ERR=(2*PI/SY**2)*K1RM*(COS(ZZP)-COS(ZZN)) 164 - EZZ=(2*PI/SY**2)*K0RM*(SIN(ZZP)-SIN(ZZN)) 165 - EXSUM=EXSUM+ERR*(XPOS+X3D(I)-2*COPLAX)/ 166 - - SQRT((XPOS+X3D(I)-2*COPLAX)**2+(ZPOS-Z3D(I))**2) 167 - EYSUM=EYSUM+EZZ 168 - EZSUM=EZSUM+ERR*(ZPOS-Z3D(I))/ 169 - - SQRT((XPOS+X3D(I)-2*COPLAX)**2+(ZPOS-Z3D(I))**2) 170 - 40 CONTINUE 171 - *** Polynomial sum. 172 - ELSE 173 - * Loop over the terms. 174 - DO 50 J=0,NTERMP 175 - * Simplify the references to the distances. 176 - RR1=SQRT((YPOS-Y3D(I)+J*2*SY)**2+ 177 - - (XPOS+X3D(I)-2*COPLAX)**2+(ZPOS-Z3D(I))**2) 178 - RR2=SQRT((YPOS-Y3D(I)-J*2*SY)**2+ 179 - - (XPOS+X3D(I)-2*COPLAX)**2+(ZPOS-Z3D(I))**2) 180 - RM1=SQRT((YPOS+Y3D(I)-J*2*SY-2*COPLAY)**2+ 181 - - (XPOS+X3D(I)-2*COPLAX)**2+(ZPOS-Z3D(I))**2) 182 - RM2=SQRT((YPOS+Y3D(I)+J*2*SY-2*COPLAY)**2+ 183 - - (XPOS+X3D(I)-2*COPLAX)**2+(ZPOS-Z3D(I))**2) 184 - * Initialisation of the sum: only a charge and a mirror charge. 185 - IF(J.EQ.0)THEN 186 - VSUM=VSUM-1/RR1+1/RM1 187 - EXSUM=EXSUM-(XPOS+X3D(I)-2*COPLAX)* 188 - - (1/RR1**3-1/RM1**3) 189 - EYSUM=EYSUM-(YPOS-Y3D(I))/RR1**3+ 190 - - (YPOS+Y3D(I)-2*COPLAY)/RM1**3 191 - EZSUM=EZSUM-(ZPOS-Z3D(I))*(1/RR1**3-1/RM1**3) 192 - * Further terms in the series: 2 charges and 2 mirror charges. 193 - ELSE 194 - VSUM=VSUM-1/RR1-1/RR2+1/RM1+1/RM2 195 - EXSUM=EXSUM-(XPOS+X3D(I)-2*COPLAX)* 196 - - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) 197 - EYSUM=EYSUM- 198 - - (YPOS-Y3D(I)+J*2*SY)/RR1**3- 199 - - (YPOS-Y3D(I)-J*2*SY)/RR2**3+ 200 - - (YPOS+Y3D(I)-J*2*SY-2*COPLAY)/RM1**3+ 201 - - (YPOS+Y3D(I)+J*2*SY-2*COPLAY)/RM2**3 202 - EZSUM=EZSUM-(ZPOS-Z3D(I))* 203 - - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) 204 - ENDIF 205 - 50 CONTINUE 206 - ENDIF 207 - ENDIF 208 - *** Convert the double precision sum to single precision. 209 - EX=EX+E3D(I)*REAL(EXSUM) 210 - EY=EY+E3D(I)*REAL(EYSUM) 211 - EZ=EZ+E3D(I)*REAL(EZSUM) 212 - VOLT=VOLT+E3D(I)*REAL(VSUM) 213 - *** Finish the loop over the charges. 214 - 10 CONTINUE 215 - END 604 GARFIELD ================================================== P=FIELDCAL D=EFCC10 1 ============================ 0 + +DECK,EFCC10. 1 - SUBROUTINE EFCC10(XPOS,YPOS,EX,EY,VOLT,IOPT) 2 - *----------------------------------------------------------------------- 3 - * EFCC10 - Routine returning the potential and electric field. It 4 - * calls the routines PH2 and E2SUM written by G.A.Erskine. 5 - * VARIABLES : No local variables. 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9 - *** Calculate voltage first, if needed. 10 - IF(IOPT.NE.0)THEN 11 - IF(MODE.EQ.0)VOLT=V0+C1*XPOS 12 - IF(MODE.EQ.1)VOLT=V0+C1*YPOS 13 - DO 10 I=1,NWIRE 14 - VOLT=VOLT+E(I)*PH2(XPOS-X(I),YPOS-Y(I)) 15 - 10 CONTINUE 16 - ENDIF 17 - *** And finally the electric field. 18 - CALL E2SUM(XPOS,YPOS,EX,EY) 19 - IF(MODE.EQ.0)EX=EX-C1 20 - IF(MODE.EQ.1)EY=EY-C1 1 604 P=FIELDCAL D=EFCC10 2 PAGE 885 21 - END 605 GARFIELD ================================================== P=FIELDCAL D=EFCC2X 1 ============================ 0 + +DECK,EFCC2X. 1 - SUBROUTINE EFCC2X(XPOS,YPOS,EX,EY,VOLT,IOPT) 2 - *----------------------------------------------------------------------- 3 - * EFCC2X - Routine returning the potential and electric field in a 4 - * configuration with 2 x planes and y periodicity. 5 - * VARIABLES : see the writeup 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,CONSTANTS. 10 - COMPLEX WSUM1,WSUM2,ZSIN,ZCOF,ZU,ZUNEW,ZTERM1,ZTERM2,ZETA 11 - *** Initial values. 12 - WSUM1=0 13 - WSUM2=0 14 - VOLT=0.0 15 - *** Wire loop. 16 - DO 10 I=1,NWIRE 17 - * Compute the direct contribution. 18 - ZETA=ZMULT*CMPLX(XPOS-X(I),YPOS-Y(I)) 19 - IF(AIMAG(ZETA).GT.+15.0)THEN 20 - WSUM1=WSUM1-E(I)*ICONS 21 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*(ABS(AIMAG(ZETA))-CLOG2) 22 - ELSEIF(AIMAG(ZETA).LT.-15.0)THEN 23 - WSUM1=WSUM1+E(I)*ICONS 24 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*(ABS(AIMAG(ZETA))-CLOG2) 25 - ELSE 26 - ZSIN=SIN(ZETA) 27 - ZCOF=4.0*ZSIN**2-2.0 28 - ZU=-P1-ZCOF*P2 29 - ZUNEW=1.0-ZCOF*ZU-P2 30 - ZTERM1=(ZUNEW+ZU)*ZSIN 31 - ZU=-3.0*P1-ZCOF*5.0*P2 32 - ZUNEW=1.0-ZCOF*ZU-5.0*P2 33 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 34 - WSUM1=WSUM1+E(I)*(ZTERM2/ZTERM1) 35 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(CABS(ZTERM1)) 36 - ENDIF 37 - * Find the plane nearest to the wire. 38 - CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) 39 - * Mirror contribution. 40 - ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),YPOS-Y(I)) 41 - IF(AIMAG(ZETA).GT.+15.0)THEN 42 - WSUM2=WSUM2-E(I)*ICONS 43 - IF(IOPT.NE.0)VOLT=VOLT+E(I)*(ABS(AIMAG(ZETA))-CLOG2) 44 - ELSEIF(AIMAG(ZETA).LT.-15.0)THEN 45 - WSUM2=WSUM2+E(I)*ICONS 46 - IF(IOPT.NE.0)VOLT=VOLT+E(I)*(ABS(AIMAG(ZETA))-CLOG2) 47 - ELSE 48 - ZSIN=SIN(ZETA) 49 - ZCOF=4.0*ZSIN**2-2.0 50 - ZU=-P1-ZCOF*P2 51 - ZUNEW=1.0-ZCOF*ZU-P2 52 - ZTERM1=(ZUNEW+ZU)*ZSIN 53 - ZU=-3.0*P1-ZCOF*5.0*P2 54 - ZUNEW=1.0-ZCOF*ZU-5.0*P2 55 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 56 - WSUM2=WSUM2+E(I)*(ZTERM2/ZTERM1) 57 - IF(IOPT.NE.0)VOLT=VOLT+E(I)*LOG(CABS(ZTERM1)) 58 - ENDIF 59 - * Correct the voltage, if needed (MODE). 60 - IF(IOPT.NE.0.AND.MODE.EQ.0)VOLT=VOLT- 61 - - 2*E(I)*PI*(XPOS-CX)*(X(I)-CX)/(SX*SY) 62 - 10 CONTINUE 63 - *** Convert the two contributions to a real field. 64 - EX=REAL(ZMULT*(WSUM1+WSUM2)) 65 - EY=-AIMAG(ZMULT*(WSUM1-WSUM2)) 66 - *** Constant correction terms. 67 - IF(MODE.EQ.0)EX=EX-C1 68 - END 606 GARFIELD ================================================== P=FIELDCAL D=EFCC2Y 1 ============================ 0 + +DECK,EFCC2Y. 1 - SUBROUTINE EFCC2Y(XPOS,YPOS,EX,EY,VOLT,IOPT) 2 - *----------------------------------------------------------------------- 3 - * EFCC2Y - Routine returning the potential and electric field in a 4 - * configuration with 2 y planes and x periodicity. 5 - * VARIABLES : see the writeup 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,CONSTANTS. 10 - COMPLEX WSUM1,WSUM2,ZSIN,ZCOF,ZU,ZUNEW,ZTERM1,ZTERM2,ZETA 11 - *** Initial values. 12 - WSUM1=0 13 - WSUM2=0 14 - VOLT=0.0 15 - *** Wire loop. 16 - DO 10 I=1,NWIRE 17 - * Compute the direct contribution. 18 - ZETA=ZMULT*CMPLX(XPOS-X(I),YPOS-Y(I)) 19 - IF(AIMAG(ZETA).GT.+15.0)THEN 20 - WSUM1=WSUM1-E(I)*ICONS 21 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*(ABS(AIMAG(ZETA))-CLOG2) 22 - ELSEIF(AIMAG(ZETA).LT.-15.0)THEN 23 - WSUM1=WSUM1+E(I)*ICONS 24 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*(ABS(AIMAG(ZETA))-CLOG2) 25 - ELSE 26 - ZSIN=SIN(ZETA) 27 - ZCOF=4.0*ZSIN**2-2.0 28 - ZU=-P1-ZCOF*P2 29 - ZUNEW=1.0-ZCOF*ZU-P2 1 606 P=FIELDCAL D=EFCC2Y 2 PAGE 886 30 - ZTERM1=(ZUNEW+ZU)*ZSIN 31 - ZU=-3.0*P1-ZCOF*5.0*P2 32 - ZUNEW=1.0-ZCOF*ZU-5.0*P2 33 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 34 - WSUM1=WSUM1+E(I)*(ZTERM2/ZTERM1) 35 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(CABS(ZTERM1)) 36 - ENDIF 37 - * Find the plane nearest to the wire. 38 - CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) 39 - * Mirror contribution from the y plane. 40 - ZETA=ZMULT*CMPLX(XPOS-X(I),2.0*CY-YPOS-Y(I)) 41 - IF(AIMAG(ZETA).GT.+15.0)THEN 42 - WSUM2=WSUM2-E(I)*ICONS 43 - IF(IOPT.NE.0)VOLT=VOLT+E(I)*(ABS(AIMAG(ZETA))-CLOG2) 44 - ELSEIF(AIMAG(ZETA).LT.-15.0)THEN 45 - WSUM2=WSUM2+E(I)*ICONS 46 - IF(IOPT.NE.0)VOLT=VOLT+E(I)*(ABS(AIMAG(ZETA))-CLOG2) 47 - ELSE 48 - ZSIN=SIN(ZETA) 49 - ZCOF=4.0*ZSIN**2-2.0 50 - ZU=-P1-ZCOF*P2 51 - ZUNEW=1.0-ZCOF*ZU-P2 52 - ZTERM1=(ZUNEW+ZU)*ZSIN 53 - ZU=-3.0*P1-ZCOF*5.0*P2 54 - ZUNEW=1.0-ZCOF*ZU-5.0*P2 55 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 56 - WSUM2=WSUM2+E(I)*(ZTERM2/ZTERM1) 57 - IF(IOPT.NE.0)VOLT=VOLT+E(I)*LOG(CABS(ZTERM1)) 58 - ENDIF 59 - * Correct the voltage, if needed (MODE). 60 - IF(IOPT.NE.0.AND.MODE.EQ.1)VOLT=VOLT- 61 - - 2*E(I)*PI*(YPOS-CY)*(Y(I)-CY)/(SX*SY) 62 - 10 CONTINUE 63 - *** Convert the two contributions to a real field. 64 - EX=REAL(ZMULT*(WSUM1-WSUM2)) 65 - EY=-AIMAG(ZMULT*(WSUM1+WSUM2)) 66 - *** Constant correction terms. 67 - IF(MODE.EQ.1)EY=EY-C1 68 - END 607 GARFIELD ================================================== P=FIELDCAL D=EFCC30 1 ============================ 0 + +DECK,EFCC30. 1 - SUBROUTINE EFCC30(XPOS,YPOS,EX,EY,VOLT,IOPT) 2 - *----------------------------------------------------------------------- 3 - * EFCC30 - Routine returning the potential and electric field in a 4 - * configuration with 2 y and 2 x planes. 5 - * VARIABLES : see the writeup 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,CONSTANTS. 10 - COMPLEX WSUM1,WSUM2,WSUM3,WSUM4,ZSIN,ZCOF,ZU,ZUNEW, 11 - - ZTERM1,ZTERM2,ZETA 12 - *** Initial values. 13 - WSUM1=0 14 - WSUM2=0 15 - WSUM3=0 16 - WSUM4=0 17 - VOLT=0.0 18 - *** Wire loop. 19 - DO 10 I=1,NWIRE 20 - * Compute the direct contribution. 21 - ZETA=ZMULT*CMPLX(XPOS-X(I),YPOS-Y(I)) 22 - IF(AIMAG(ZETA).GT.+15.0)THEN 23 - WSUM1=WSUM1-E(I)*ICONS 24 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*(ABS(AIMAG(ZETA))-CLOG2) 25 - ELSEIF(AIMAG(ZETA).LT.-15.0)THEN 26 - WSUM1=WSUM1+E(I)*ICONS 27 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*(ABS(AIMAG(ZETA))-CLOG2) 28 - ELSE 29 - ZSIN=SIN(ZETA) 30 - ZCOF=4.0*ZSIN**2-2.0 31 - ZU=-P1-ZCOF*P2 32 - ZUNEW=1.0-ZCOF*ZU-P2 33 - ZTERM1=(ZUNEW+ZU)*ZSIN 34 - ZU=-3.0*P1-ZCOF*5.0*P2 35 - ZUNEW=1.0-ZCOF*ZU-5.0*P2 36 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 37 - WSUM1=WSUM1+E(I)*(ZTERM2/ZTERM1) 38 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(CABS(ZTERM1)) 39 - ENDIF 40 - * Find the plane nearest to the wire. 41 - CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) 42 - * Mirror contribution from the x plane. 43 - ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),YPOS-Y(I)) 44 - IF(AIMAG(ZETA).GT.+15.0)THEN 45 - WSUM2=WSUM2-E(I)*ICONS 46 - IF(IOPT.NE.0)VOLT=VOLT+E(I)*(ABS(AIMAG(ZETA))-CLOG2) 47 - ELSEIF(AIMAG(ZETA).LT.-15.0)THEN 48 - WSUM2=WSUM2+E(I)*ICONS 49 - IF(IOPT.NE.0)VOLT=VOLT+E(I)*(ABS(AIMAG(ZETA))-CLOG2) 50 - ELSE 51 - ZSIN=SIN(ZETA) 52 - ZCOF=4.0*ZSIN**2-2.0 53 - ZU=-P1-ZCOF*P2 54 - ZUNEW=1.0-ZCOF*ZU-P2 55 - ZTERM1=(ZUNEW+ZU)*ZSIN 56 - ZU=-3.0*P1-ZCOF*5.0*P2 57 - ZUNEW=1.0-ZCOF*ZU-5.0*P2 58 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 59 - WSUM2=WSUM2+E(I)*(ZTERM2/ZTERM1) 60 - IF(IOPT.NE.0)VOLT=VOLT+E(I)*LOG(CABS(ZTERM1)) 61 - ENDIF 62 - * Find the plane nearest to the wire. 63 - CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) 1 607 P=FIELDCAL D=EFCC30 2 PAGE 887 64 - * Mirror contribution from the y plane. 65 - ZETA=ZMULT*CMPLX(XPOS-X(I),2.0*CY-YPOS-Y(I)) 66 - IF(AIMAG(ZETA).GT.+15.0)THEN 67 - WSUM3=WSUM3-E(I)*ICONS 68 - IF(IOPT.NE.0)VOLT=VOLT+E(I)*(ABS(AIMAG(ZETA))-CLOG2) 69 - ELSEIF(AIMAG(ZETA).LT.-15.0)THEN 70 - WSUM3=WSUM3+E(I)*ICONS 71 - IF(IOPT.NE.0)VOLT=VOLT+E(I)*(ABS(AIMAG(ZETA))-CLOG2) 72 - ELSE 73 - ZSIN=SIN(ZETA) 74 - ZCOF=4.0*ZSIN**2-2.0 75 - ZU=-P1-ZCOF*P2 76 - ZUNEW=1.0-ZCOF*ZU-P2 77 - ZTERM1=(ZUNEW+ZU)*ZSIN 78 - ZU=-3.0*P1-ZCOF*5.0*P2 79 - ZUNEW=1.0-ZCOF*ZU-5.0*P2 80 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 81 - WSUM3=WSUM3+E(I)*(ZTERM2/ZTERM1) 82 - IF(IOPT.NE.0)VOLT=VOLT+E(I)*LOG(CABS(ZTERM1)) 83 - ENDIF 84 - * Mirror contribution from both the x and the y plane. 85 - ZETA=ZMULT*CMPLX(2.0*CX-XPOS-X(I),2.0*CY-YPOS-Y(I)) 86 - IF(AIMAG(ZETA).GT.+15.0)THEN 87 - WSUM4=WSUM4-E(I)*ICONS 88 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*(ABS(AIMAG(ZETA))-CLOG2) 89 - ELSEIF(AIMAG(ZETA).LT.-15.0)THEN 90 - WSUM4=WSUM4+E(I)*ICONS 91 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*(ABS(AIMAG(ZETA))-CLOG2) 92 - ELSE 93 - ZSIN=SIN(ZETA) 94 - ZCOF=4.0*ZSIN**2-2.0 95 - ZU=-P1-ZCOF*P2 96 - ZUNEW=1.0-ZCOF*ZU-P2 97 - ZTERM1=(ZUNEW+ZU)*ZSIN 98 - ZU=-3.0*P1-ZCOF*5.0*P2 99 - ZUNEW=1.0-ZCOF*ZU-5.0*P2 100 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 101 - WSUM4=WSUM4+E(I)*(ZTERM2/ZTERM1) 102 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(CABS(ZTERM1)) 103 - ENDIF 104 - 10 CONTINUE 105 - *** Convert the two contributions to a real field. 106 - EX=+REAL(ZMULT*(WSUM1+WSUM2-WSUM3-WSUM4)) 107 - EY=-AIMAG(ZMULT*(WSUM1-WSUM2+WSUM3-WSUM4)) 108 - END 608 GARFIELD ================================================== P=FIELDCAL D=EFCD10 1 ============================ 0 + +DECK,EFCD10,IF=NEVER. 1 - SUBROUTINE EFCD10(XPOS,YPOS,EX,EY,VOLT,IOPT) 2 - *----------------------------------------------------------------------- 3 - * EFCD10 - Subroutine performing the actual field calculations for a 4 - * cell which has a one circular plane and some wires. 5 - * VARIABLES : EX, EY, VOLT:Electric field and potential. 6 - * ETOT, VOLT : Magnitude of electric field, potential. 7 - * (XPOS,YPOS): The position where the field is calculated. 8 - * ZI, ZPOS : Shorthand complex notations. 9 - * (Last changed on 30/ 1/93.) 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13 - COMPLEX ZI,ZPOS 14 - *** Initialise the potential and the electric field. 15 - EX=0.0 16 - EY=0.0 17 - VOLT=V0 18 - * Set the complex position coordinates. 19 - ZPOS=CMPLX(XPOS,YPOS) 20 - *** Loop over all wires. 21 - DO 10 I=1,NWIRE 22 - * Set the complex version of the wire-coordinate for simplicity. 23 - ZI=CMPLX(X(I),Y(I)) 24 - * Compute the contribution to the potential, if needed. 25 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(ABS((1/COTUBE)*(ZPOS-ZI)/ 26 - - (1-ZPOS*CONJG(ZI)/COTUBE**2))) 27 - * Compute the contribution to the electric field, always. 28 - EX=EX+E(I)*REAL(1/CONJG(ZPOS-ZI)+ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) 29 - EY=EY+E(I)*AIMAG(1/CONJG(ZPOS-ZI)+ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) 30 - *** Finish the loop over the wires. 31 - 10 CONTINUE 32 - END 609 GARFIELD ================================================== P=FIELDCAL D=EFCD10 1 ============================ 0 + +DECK,EFCD10. 1 - SUBROUTINE EFCD10(XPOS,YPOS,EX,EY,VOLT,IOPT) 2 - *----------------------------------------------------------------------- 3 - * EFCD10 - Subroutine performing the actual field calculations for a 4 - * cell which has a one circular plane and some wires. 5 - * VARIABLES : EX, EY, VOLT:Electric field and potential. 6 - * ETOT, VOLT : Magnitude of electric field, potential. 7 - * (XPOS,YPOS): The position where the field is calculated. 8 - * ZI, ZPOS : Shorthand complex notations. 9 - * (Last changed on 4/ 9/95.) 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13 - COMPLEX ZI,ZPOS 14 - *** Initialise the potential and the electric field. 15 - EX=0.0 16 - EY=0.0 17 - VOLT=V0 18 - * Set the complex position coordinates. 19 - ZPOS=CMPLX(XPOS,YPOS) 20 - *** Loop over all wires. 21 - DO 10 I=1,NWIRE 1 609 P=FIELDCAL D=EFCD10 2 PAGE 888 22 - * Set the complex version of the wire-coordinate for simplicity. 23 - ZI=CMPLX(X(I),Y(I)) 24 - * Compute the contribution to the potential, if needed. 25 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(ABS(COTUBE*(ZPOS-ZI)/ 26 - - (COTUBE**2-ZPOS*CONJG(ZI)))) 27 - * Compute the contribution to the electric field, always. 28 - EX=EX+E(I)*REAL(1/CONJG(ZPOS-ZI)+ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) 29 - EY=EY+E(I)*AIMAG(1/CONJG(ZPOS-ZI)+ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) 30 - *** Finish the loop over the wires. 31 - 10 CONTINUE 32 - END 610 GARFIELD ================================================== P=FIELDCAL D=E3DD10 1 ============================ 0 + +DECK,E3DD10. 1 - SUBROUTINE E3DD10(XXPOS,YYPOS,ZZPOS,EEX,EEY,EEZ,VOLT) 2 - *----------------------------------------------------------------------- 3 - * E3DD10 - Subroutine adding 3-dimensional charges to tubes with one 4 - * wire running down the centre. 5 - * The series expansions for the modified Bessel functions 6 - * have been taken from Abramowitz and Stegun. 7 - * VARIABLES : See routine E3DA00 for most of the variables. 8 - * (Last changed on 25/11/95.) 9 - *----------------------------------------------------------------------- 10.- +SEQ,DIMENSIONS. 11.- +SEQ,CELLDATA. 12.- +SEQ,CONSTANTS. 13 - DOUBLE PRECISION EXSUM,EYSUM,EZSUM,VSUM, 14 - - I0S,I1S,K0S,K0L,K1S,K1L,K0R,K1R, 15 - - XX,RR,ZZP,ZZN,RR1,RR2,RM1,RM2,ERR,EZZ 16 - REAL XPOS,YPOS,ZPOS,EX,EY,EZ,VOLT,RCUT 17 - PARAMETER(RCUT=1.0) 18 - *** Statement functions for the modified Bessel functions: 19 - I0S(XX)=1 20 - - +3.5156229*(XX/3.75)**2 21 - - +3.0899424*(XX/3.75)**4 22 - - +1.2067492*(XX/3.75)**6 23 - - +0.2659732*(XX/3.75)**8 24 - - +0.0360768*(XX/3.75)**10 25 - - +0.0045813*(XX/3.75)**12 26 - I1S(XX)=XX*( 27 - - +0.5 28 - - +0.87890594*(XX/3.75)**2 29 - - +0.51498869*(XX/3.75)**4 30 - - +0.15084934*(XX/3.75)**6 31 - - +0.02658733*(XX/3.75)**8 32 - - +0.00301532*(XX/3.75)**10 33 - - +0.00032411*(XX/3.75)**12) 34 - K0S(XX)=-LOG(XX/2)*I0S(XX) 35 - - -0.57721566 36 - - +0.42278420*(XX/2)**2 37 - - +0.23069756*(XX/2)**4 38 - - +0.03488590*(XX/2)**6 39 - - +0.00262698*(XX/2)**8 40 - - +0.00010750*(XX/2)**10 41 - - +0.00000740*(XX/2)**12 42 - K0L(XX)=(EXP(-XX)/SQRT(XX))*( 43 - - +1.25331414 44 - - -0.07832358*(2/XX) 45 - - +0.02189568*(2/XX)**2 46 - - -0.01062446*(2/XX)**3 47 - - +0.00587872*(2/XX)**4 48 - - -0.00251540*(2/XX)**5 49 - - +0.00053208*(2/XX)**6) 50 - K1S(XX)=LOG(XX/2)*I1S(XX)+(1/XX)*( 51 - - +1 52 - - +0.15443144*(XX/2)**2 53 - - -0.67278579*(XX/2)**4 54 - - -0.18156897*(XX/2)**6 55 - - -0.01919402*(XX/2)**8 56 - - -0.00110404*(XX/2)**10 57 - - -0.00004686*(XX/2)**12) 58 - K1L(XX)=(EXP(-XX)/SQRT(XX))*( 59 - - +1.25331414 60 - - +0.23498619*(2/XX) 61 - - -0.03655620*(2/XX)**2 62 - - +0.01504268*(2/XX)**3 63 - - -0.00780353*(2/XX)**4 64 - - +0.00325614*(2/XX)**5 65 - - -0.00068245*(2/XX)**6) 66 - *** Initialise the sums for the field components. 67 - EX=0.0 68 - EEX=0.0 69 - EY=0.0 70 - EEY=0.0 71 - EZ=0.0 72 - EEZ=0.0 73 - VOLT=0.0 74 - *** Ensure that the routine can actually work. 75 - IF(NWIRE.LT.1)THEN 76 - PRINT *,' Inappropriate potential function.' 77 - RETURN 78 - ENDIF 79 - *** Define a periodicity and one plane in the mapped frame. 80 - SSX=LOG(2*COTUBE/D(1)) 81 - CPL=LOG(D(1)/2) 82 - *** Transform the coordinates to the mapped frame. 83 - XPOS=0.5*LOG(XXPOS**2+YYPOS**2) 84 - YPOS=ATAN2(YYPOS,XXPOS) 85 - ZPOS=ZZPOS 86 - *** Loop over all point charges. 87 - DO 10 I=1,N3D 88 - DO 40 II=-1,1 89 - XX3D=0.5*LOG(X3D(I)**2+Y3D(I)**2) 90 - YY3D=ATAN2(Y3D(I),X3D(I))+II*2*PI 91 - ZZ3D=Z3D(I) 1 610 P=FIELDCAL D=E3DD10 2 PAGE 889 92 - * Skip wires that are on the charge. 93 - IF(XPOS.EQ.XX3D.AND.YPOS.EQ.YY3D.AND.ZPOS.EQ.ZZ3D)GOTO 40 94 - *** In the far away zone, sum the modified Bessel function series. 95 - IF((YPOS-YY3D)**2+(ZPOS-ZZ3D)**2.GT.(RCUT*2*SSX)**2)THEN 96 - * Initialise the per-wire sum. 97 - EXSUM=0.0 98 - EYSUM=0.0 99 - EZSUM=0.0 100 - VSUM=0.0 101 - * Loop over the terms in the series. 102 - DO 20 J=1,NTERMB 103 - * Obtain reduced coordinates. 104 - RR=PI*J*SQRT((YPOS-YY3D)**2+(ZPOS-ZZ3D)**2)/SSX 105 - ZZP=PI*J*(XPOS-XX3D)/SSX 106 - ZZN=PI*J*(XPOS+XX3D-2*CPL)/SSX 107 - * Evaluate the Bessel functions for this R. 108 - IF(RR.LT.2)THEN 109 - K0R=K0S(RR) 110 - K1R=K1S(RR) 111 - ELSE 112 - K0R=K0L(RR) 113 - K1R=K1L(RR) 114 - ENDIF 115 - * Get the field components. 116 - VSUM=VSUM+(1/SSX)*K0R*(COS(ZZP)-COS(ZZN)) 117 - ERR=(2*J*PI/SSX**2)*K1R*(COS(ZZP)-COS(ZZN)) 118 - EZZ=(2*J*PI/SSX**2)*K0R*(SIN(ZZP)-SIN(ZZN)) 119 - EXSUM=EXSUM+EZZ 120 - EYSUM=EYSUM+ERR*(YPOS-YY3D)/ 121 - - SQRT((YPOS-YY3D)**2+(ZPOS-ZZ3D)**2) 122 - EZSUM=EZSUM+ERR*(ZPOS-ZZ3D)/ 123 - - SQRT((YPOS-YY3D)**2+(ZPOS-ZZ3D)**2) 124 - 20 CONTINUE 125 - *** Direct polynomial summing, obtain reduced coordinates. 126 - ELSE 127 - * Loop over the terms. 128 - DO 30 J=0,NTERMP 129 - * Simplify the references to the distances. 130 - RR1=SQRT((XPOS-XX3D+J*2*SSX)**2+(YPOS-YY3D)**2+ 131 - - (ZPOS-ZZ3D)**2) 132 - RR2=SQRT((XPOS-XX3D-J*2*SSX)**2+(YPOS-YY3D)**2+ 133 - - (ZPOS-ZZ3D)**2) 134 - RM1=SQRT((XPOS+XX3D-J*2*SSX-2*CPL)**2+ 135 - - (YPOS-YY3D)**2+(ZPOS-ZZ3D)**2) 136 - RM2=SQRT((XPOS+XX3D+J*2*SSX-2*CPL)**2+ 137 - - (YPOS-YY3D)**2+(ZPOS-ZZ3D)**2) 138 - * Initialisation of the sum: only a charge and a mirror charge. 139 - IF(J.EQ.0)THEN 140 - VSUM=1/RR1-1/RM1 141 - EXSUM=(XPOS-XX3D)/RR1**3- 142 - - (XPOS+XX3D-2*CPL)/RM1**3 143 - EYSUM=(YPOS-YY3D)*(1/RR1**3-1/RM1**3) 144 - EZSUM=(ZPOS-ZZ3D)*(1/RR1**3-1/RM1**3) 145 - * Further terms in the series: 2 charges and 2 mirror charges. 146 - ELSE 147 - VSUM=VSUM+1/RR1+1/RR2-1/RM1-1/RM2 148 - EXSUM=EXSUM+ 149 - - (XPOS-XX3D+J*2*SSX)/RR1**3+ 150 - - (XPOS-XX3D-J*2*SSX)/RR2**3- 151 - - (XPOS+XX3D-J*2*SSX-2*CPL)/RM1**3- 152 - - (XPOS+XX3D+J*2*SSX-2*CPL)/RM2**3 153 - EYSUM=EYSUM+(YPOS-YY3D)* 154 - - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) 155 - EZSUM=EZSUM+(ZPOS-ZZ3D)* 156 - - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) 157 - ENDIF 158 - 30 CONTINUE 159 - ENDIF 160 - *** Convert the double precision sum to single precision. 161 - EX=EX+E3D(I)*REAL(EXSUM) 162 - EY=EY+E3D(I)*REAL(EYSUM) 163 - EZ=EZ+E3D(I)*REAL(EZSUM) 164 - VOLT=VOLT+E3D(I)*REAL(VSUM) 165 - *** Finish the loop over the charges. 166 - 40 CONTINUE 167 - 10 CONTINUE 168 - *** Transform the field vectors back to Cartesian coordinates. 169 - EEX=EXP(-XPOS)*(+EX*COS(YPOS)-EY*SIN(YPOS)) 170 - EEY=EXP(-XPOS)*(+EX*SIN(YPOS)+EY*COS(YPOS)) 171 - EEZ=EZ 172 - END 611 GARFIELD ================================================== P=FIELDCAL D=EFCD20 1 ============================ 0 + +DECK,EFCD20. 1 - SUBROUTINE EFCD20(XPOS,YPOS,EX,EY,VOLT,IOPT) 2 - *----------------------------------------------------------------------- 3 - * EFCD20 - Subroutine performing the actual field calculations for a 4 - * cell which has a tube and phi periodicity. 5 - * VARIABLES : EX, EY, VOLT:Electric field and potential. 6 - * ETOT, VOLT : Magnitude of electric field, potential. 7 - * (XPOS,YPOS): The position where the field is calculated. 8 - * ZI, ZPOS : Shorthand complex notations. 9 - * (Last changed on 10/ 2/93.) 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13 - COMPLEX ZI,ZPOS 14 - *** Initialise the potential and the electric field. 15 - EX=0.0 16 - EY=0.0 17 - VOLT=V0 18 - * Set the complex position coordinates. 19 - ZPOS=CMPLX(XPOS,YPOS) 20 - *** Loop over all wires. 21 - DO 10 I=1,NWIRE 1 611 P=FIELDCAL D=EFCD20 2 PAGE 890 22 - * Set the complex version of the wire-coordinate for simplicity. 23 - ZI=CMPLX(X(I),Y(I)) 24 - * Case of the wire which is not in the centre. 25 - IF(ABS(ZI).GT.D(I)/2)THEN 26 - * Compute the contribution to the potential, if needed. 27 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(ABS((1/COTUBE**MTUBE)* 28 - - (ZPOS**MTUBE-ZI**MTUBE)/ 29 - - (1-(ZPOS*CONJG(ZI)/COTUBE**2)**MTUBE))) 30 - * Compute the contribution to the electric field, always. 31 - EX=EX+E(I)*REAL(MTUBE*CONJG(ZPOS)**(MTUBE-1)* 32 - - (1/CONJG(ZPOS**MTUBE-ZI**MTUBE)+ZI**MTUBE/ 33 - - (COTUBE**(2*MTUBE)-(CONJG(ZPOS)*ZI)**MTUBE))) 34 - EY=EY+E(I)*AIMAG(MTUBE*CONJG(ZPOS)**(MTUBE-1)* 35 - - (1/CONJG(ZPOS**MTUBE-ZI**MTUBE)+ZI**MTUBE/ 36 - - (COTUBE**(2*MTUBE)-(CONJG(ZPOS)*ZI)**MTUBE))) 37 - ELSE 38 - * Case of the central wire. 39 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(ABS((1/COTUBE)*(ZPOS-ZI)/ 40 - - (1-ZPOS*CONJG(ZI)/COTUBE**2))) 41 - * Compute the contribution to the electric field, always. 42 - EX=EX+E(I)*REAL(1/CONJG(ZPOS-ZI)+ZI/ 43 - - (COTUBE**2-CONJG(ZPOS)*ZI)) 44 - EY=EY+E(I)*AIMAG(1/CONJG(ZPOS-ZI)+ZI/ 45 - - (COTUBE**2-CONJG(ZPOS)*ZI)) 46 - ENDIF 47 - *** Finish the loop over the wires. 48 - 10 CONTINUE 49 - END 612 GARFIELD ================================================== P=FIELDCAL D=EFCD30 1 ============================ 0 + +DECK,EFCD30. 1 - SUBROUTINE EFCD30(XPOS,YPOS,EX,EY,VOLT,IOPT) 2 - *----------------------------------------------------------------------- 3 - * EFCD30 - Subroutine performing the actual field calculations for a 4 - * cell which has a polygon as tube and some wires. 5 - * VARIABLES : EX, EY, VOLT:Electric field and potential. 6 - * ETOT, VOLT : Magnitude of electric field, potential. 7 - * (XPOS,YPOS): The position where the field is calculated. 8 - * ZI, ZPOS : Shorthand complex notations. 9 - * (Last changed on 19/ 2/94.) 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13 - COMPLEX WPOS,WDPOS 14 - *** Initialise the potential and the electric field. 15 - EX=0.0 16 - EY=0.0 17 - VOLT=V0 18 - * Get the mapping of the position. 19 - CALL EFCMAP(CMPLX(XPOS,YPOS)/COTUBE,WPOS,WDPOS) 20 - *** Loop over all wires. 21 - DO 10 I=1,NWIRE 22 - * Compute the contribution to the potential, if needed. 23 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(ABS((WPOS-WMAP(I))/ 24 - - (1-WPOS*CONJG(WMAP(I))))) 25 - * Compute the contribution to the electric field, always. 26 - EX=EX+(E(I)/COTUBE)*REAL(WDPOS*(1-ABS(WMAP(I))**2)/ 27 - - ((WPOS-WMAP(I))*(1-CONJG(WMAP(I))*WPOS))) 28 - EY=EY-(E(I)/COTUBE)*AIMAG(WDPOS*(1-ABS(WMAP(I))**2)/ 29 - - ((WPOS-WMAP(I))*(1-CONJG(WMAP(I))*WPOS))) 30 - *** Finish the loop over the wires. 31 - 10 CONTINUE 32 - END 613 GARFIELD ================================================== P=FIELDCAL D=EFCMAP 1 ============================ 0 + +DECK,EFCMAP. 1 - SUBROUTINE EFCMAP(Z,WW,WD) 2 - *----------------------------------------------------------------------- 3 - * EFCMAP - Maps a the interior part of a regular in the unit circle. 4 - * Variables: Z - point to be mapped 5 - * W - the image of Z 6 - * WD - derivative of the mapping at Z 7 - * CC1 - coefficients for expansion around centre 8 - * CC2 - coefficients for expansion around cornre 9 - * (Last changed on 19/ 2/94.) 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13.- +SEQ,CONSTANTS. 14 - COMPLEX Z,ZZ,WW,WSUM,WD,WDSUM,ZTERM 15 - REAL CC1(0:15,3:8),CC2(0:15,3:8) 16 - INTEGER NTERM1(3:8),NTERM2(3:8) 17 - *** Triangle: coefficients for centre and corner expansion. 18 - DATA (CC1(I,3),I=0,15) / 19 - - 0.1000000000E+01, -.1666666865E+00, 0.3174602985E-01, 20 - - -.5731921643E-02, 0.1040112227E-02, -.1886279933E-03, 21 - - 0.3421107249E-04, -.6204730198E-05, 0.1125329618E-05, 22 - - -.2040969207E-06, 0.3701631357E-07, -.6713513301E-08, 23 - - 0.1217605794E-08, -.2208327132E-09, 0.4005162868E-10, 24 - - -.7264017512E-11/ 25 - DATA (CC2(I,3),I=0,15) / 26 - - 0.3333333135E+00, -.5555555597E-01, 0.1014109328E-01, 27 - - -.1837154618E-02, 0.3332451452E-03, -.6043842586E-04, 28 - - 0.1096152027E-04, -.1988050826E-05, 0.3605655365E-06, 29 - - -.6539443120E-07, 0.1186035448E-07, -.2151069323E-08, 30 - - 0.3901317047E-09, -.7075676156E-10, 0.1283289534E-10, 31 - - -.2327455936E-11/ 32 - *** Square: coefficients for centre and corner expansion. 33 - DATA (CC1(I,4),I=0,15) / 34 - - 0.1000000000E+01, -.1000000238E+00, 0.8333332837E-02, 35 - - -.7051283028E-03, 0.5967194738E-04, -.5049648280E-05, 36 - - 0.4273189802E-06, -.3616123934E-07, 0.3060091514E-08, 37 - - -.2589557457E-09, 0.2191374859E-10, -.1854418528E-11, 38 - - 0.1569274224E-12, -.1327975205E-13, 0.1123779363E-14, 1 613 P=FIELDCAL D=EFCMAP 2 PAGE 891 39 - - -.9509817570E-16/ 40 - DATA (CC2(I,4),I=0,15) / 41 - - 0.1000000000E+01, -.5000000000E+00, 0.3000000119E+00, 42 - - -.1750000119E+00, 0.1016666889E+00, -.5916666612E-01, 43 - - 0.3442307562E-01, -.2002724260E-01, 0.1165192947E-01, 44 - - -.6779119372E-02, 0.3944106400E-02, -.2294691978E-02, 45 - - 0.1335057430E-02, -.7767395582E-03, 0.4519091453E-03, 46 - - -.2629216760E-03/ 47 - *** Pentagon: coefficients for centre and corner expansion. 48 - DATA (CC1(I,5),I=0,15) / 49 - - 0.1000000000E+01, -.6666666269E-01, 0.1212121220E-02, 50 - - -.2626262140E-03, -.3322110570E-04, -.9413293810E-05, 51 - - -.2570029210E-05, -.7695705904E-06, -.2422486887E-06, 52 - - -.7945993730E-07, -.2691839640E-07, -.9361642128E-08, 53 - - -.3327319087E-08, -.1204430555E-08, -.4428404310E-09, 54 - - -.1650302672E-09/ 55 - DATA (CC2(I,5),I=0,15) / 56 - - 0.1248050690E+01, -.7788147926E+00, 0.6355384588E+00, 57 - - -.4899077415E+00, 0.3713272810E+00, -.2838423252E+00, 58 - - 0.2174729109E+00, -.1663445234E+00, 0.1271933913E+00, 59 - - -.9728997946E-01, 0.7442557812E-01, -.5692918226E-01, 60 - - 0.4354400188E-01, -.3330700099E-01, 0.2547712997E-01, 61 - - -.1948769018E-01/ 62 - *** Hexagon: coefficients for centre and corner expansion. 63 - DATA (CC1(I,6),I=0,15) / 64 - - 0.1000000000E+01, -.4761904851E-01, -.1221001148E-02, 65 - - -.3753788769E-03, -.9415557724E-04, -.2862767724E-04, 66 - - -.9587882232E-05, -.3441659828E-05, -.1299798896E-05, 67 - - -.5103651119E-06, -.2066504408E-06, -.8578405186E-07, 68 - - -.3635090096E-07, -.1567239494E-07, -.6857355572E-08, 69 - - -.3038770346E-08/ 70 - DATA (CC2(I,6),I=0,15) / 71 - - 0.1333333015E+01, -.8888888955E+00, 0.8395061493E+00, 72 - - -.7242798209E+00, 0.6016069055E+00, -.5107235312E+00, 73 - - 0.4393203855E+00, -.3745460510E+00, 0.3175755739E+00, 74 - - -.2703750730E+00, 0.2308617830E+00, -.1966916919E+00, 75 - - 0.1672732830E+00, -.1424439549E+00, 0.1214511395E+00, 76 - - -.1034612656E+00/ 77 - *** Heptagon: coefficients for centre and corner expansion. 78 - DATA (CC1(I,7),I=0,15) / 79 - - 0.1000000000E+01, -.3571428731E-01, -.2040816238E-02, 80 - - -.4936389159E-03, -.1446709794E-03, -.4963850370E-04, 81 - - -.1877940667E-04, -.7600909157E-05, -.3232265954E-05, 82 - - -.1427365532E-05, -.6493634714E-06, -.3026190711E-06, 83 - - -.1438593245E-06, -.6953911225E-07, -.3409525462E-07, 84 - - -.1692310647E-07/ 85 - DATA (CC2(I,7),I=0,15) / 86 - - 0.1359752655E+01, -.9244638681E+00, 0.9593217969E+00, 87 - - -.8771237731E+00, 0.7490229011E+00, -.6677658558E+00, 88 - - 0.6196745634E+00, -.5591596961E+00, 0.4905325770E+00, 89 - - -.4393517375E+00, 0.4029803872E+00, -.3631100059E+00, 90 - - 0.3199430704E+00, -.2866140604E+00, 0.2627358437E+00, 91 - - -.2368256450E+00/ 92 - *** Octagon: coefficients for centre and corner expansion. 93 - DATA (CC1(I,8),I=0,15) / 94 - - 0.1000000000E+01, -.2777777612E-01, -.2246732125E-02, 95 - - -.5571441725E-03, -.1790652314E-03, -.6708275760E-04, 96 - - -.2766949183E-04, -.1219387286E-04, -.5640039490E-05, 97 - - -.2706697160E-05, -.1337270078E-05, -.6763995657E-06, 98 - - -.3488264610E-06, -.1828456675E-06, -.9718036154E-07, 99 - - -.5227070332E-07/ 100 - DATA (CC2(I,8),I=0,15) / 101 - - 0.1362840652E+01, -.9286670089E+00, 0.1035511017E+01, 102 - - -.9800255299E+00, 0.8315343261E+00, -.7592730522E+00, 103 - - 0.7612683773E+00, -.7132136226E+00, 0.6074471474E+00, 104 - - -.5554352999E+00, 0.5699443221E+00, -.5357525349E+00, 105 - - 0.4329345822E+00, -.3916820884E+00, 0.4401986003E+00, 106 - - -.4197303057E+00/ 107 - *** Number of terms in each expansion. 108 - DATA (NTERM1(I),I=3,8) /6*15/ 109 - DATA (NTERM2(I),I=3,8) /6*15/ 110 - *** Z coincides with the centre. 111 - IF(Z.EQ.0)THEN 112 - * Results are trivial. 113 - WW=0 114 - WD=KAPPA 115 - *** Z is close to the centre. 116 - ELSEIF(ABS(Z).LT.0.75)THEN 117 - * Series expansion. 118 - ZTERM=(KAPPA*Z)**NTUBE 119 - WDSUM=0.0 120 - WSUM=CC1(NTERM1(NTUBE),NTUBE) 121 - DO 10 I=NTERM1(NTUBE)-1,0,-1 122 - WDSUM=WSUM+ZTERM*WDSUM 123 - WSUM=CC1(I,NTUBE)+ZTERM*WSUM 124 - 10 CONTINUE 125 - * Return the results. 126 - WW=KAPPA*Z*WSUM 127 - WD=KAPPA*(WSUM+NTUBE*ZTERM*WDSUM) 128 - *** Z is close to the edge. 129 - ELSE 130 - * First rotate Z nearest to 1. 131 - AROT=-2*PI*NINT(0.5*ATAN2(AIMAG(Z),REAL(Z))*NTUBE/PI)/ 132 - - REAL(NTUBE) 133 - ZZ=Z*CMPLX(COS(AROT),SIN(AROT)) 134 - * Expand in a series. 135 - ZTERM=(KAPPA*(1-ZZ))**(REAL(NTUBE)/REAL(NTUBE-2)) 136 - WDSUM=0 137 - WSUM=CC2(NTERM2(NTUBE),NTUBE) 138 - DO 20 I=NTERM2(NTUBE)-1,0,-1 139 - WDSUM=WSUM+ZTERM*WDSUM 140 - WSUM=CC2(I,NTUBE)+ZTERM*WSUM 141 - 20 CONTINUE 142 - * And return the results. 143 - WW=CMPLX(COS(AROT),-SIN(AROT))*(1-ZTERM*WSUM) 144 - WD=REAL(NTUBE)*KAPPA*(KAPPA*(1-ZZ))**(2.0/REAL(NTUBE-2))* 1 613 P=FIELDCAL D=EFCMAP 3 PAGE 892 145 - - (WSUM+ZTERM*WDSUM)/REAL(NTUBE-2) 146 - ENDIF 147 - END 614 GARFIELD ================================================== P=FIELDCAL D=PH2 1 ============================ 0 + +DECK,PH2. 1 - REAL FUNCTION PH2(XPOS,YPOS) 2 - *----------------------------------------------------------------------- 3 - * PH2 - Logarithmic contribution to real single-wire potential, 4 - * for a doubly priodic wire array. 5 - * PH2LIM - Entry, PH2LIM(r) corresponds to z on the surface of a wire 6 - * of (small) radius r. 7 - * 8 - * Clenshaw's algorithm is used for the evaluation of the sum 9 - * ZTERM = SIN(ZETA) - P1*SIN(3*ZETA) + P2*SIN(5*ZETA). 10 - * 11 - * (G.A.Erskine/DD, 14.8.1984; some minor modifications (i) common block 12 - * /EV2COM/ incorporated in /CELDAT/ (ii) large AIMAG(ZETA) corrected) 13 - *----------------------------------------------------------------------- 14.- +SEQ,DIMENSIONS. 15.- +SEQ,CELLDATA. 16.- +SEQ,CONSTANTS. 17 - COMPLEX ZETA,ZSIN,ZCOF,ZU,ZUNEW,ZTERM 18 - REAL PH2LIM,RADIUS 19 - *** Start of the main subroutine, off diagonal elements. 20 - ZETA=ZMULT*CMPLX(XPOS,YPOS) 21 - IF(ABS(AIMAG(ZETA)).LT.10.0)THEN 22 - ZSIN=SIN(ZETA) 23 - ZCOF=4.0*ZSIN**2-2.0 24 - ZU=-P1-ZCOF*P2 25 - ZUNEW=1.0-ZCOF*ZU-P2 26 - ZTERM=(ZUNEW+ZU)*ZSIN 27 - PH2=-LOG(CABS(ZTERM)) 28 - ELSE 29 - PH2=-ABS(AIMAG(ZETA))+CLOG2 30 - ENDIF 31 - RETURN 32 - *** Start of the entry PH2LIM, used to calculate diagonal terms. 33 - ENTRY PH2LIM(RADIUS) 34 - PH2LIM=-LOG(ABS(ZMULT)*RADIUS*(1.0-3.0*P1+5.0*P2)) 35 - END 615 GARFIELD ================================================== P=FIELDCAL D=E2SUM 1 ============================ 0 + +DECK,E2SUM. 1 - SUBROUTINE E2SUM(XPOS,YPOS,EX,EY) 2 - *----------------------------------------------------------------------- 3 - * E2SUM - Components of the elecrostatic field intensity in a doubly 4 - * periodic wire array. 5 - * Clenshaw's algorithm is used for the evaluation of the sums 6 - * ZTERM1 = SIN(ZETA) - P1*SIN(3*ZETA) + P2*SIN(5*ZETA), 7 - * ZTERM2 = COS(ZETA)- 3 P1*COS(3*ZETA)+ 5P2*COS(5*ZETA) 8 - * VARIABLES : (XPOS,YPOS): Position in the basic cell at which the 9 - * field is to be computed. 10 - * (Essentially by G.A.Erskine/DD, 14.8.1984) 11 - *----------------------------------------------------------------------- 12.- +SEQ,DIMENSIONS. 13.- +SEQ,CELLDATA. 14.- +SEQ,CONSTANTS. 15 - COMPLEX WSUM,ZSIN,ZCOF,ZU,ZUNEW,ZTERM1,ZTERM2,ZETA 16 - WSUM=0 17 - DO 10 J=1,NWIRE 18 - ZETA=ZMULT*CMPLX(XPOS-X(J),YPOS-Y(J)) 19 - IF(AIMAG(ZETA).GT.+15.0)THEN 20 - WSUM=WSUM-E(J)*ICONS 21 - ELSEIF(AIMAG(ZETA).LT.-15.0)THEN 22 - WSUM=WSUM+E(J)*ICONS 23 - ELSE 24 - ZSIN=SIN(ZETA) 25 - ZCOF=4.0*ZSIN**2-2.0 26 - ZU=-P1-ZCOF*P2 27 - ZUNEW=1.0-ZCOF*ZU-P2 28 - ZTERM1=(ZUNEW+ZU)*ZSIN 29 - ZU=-3.0*P1-ZCOF*5.0*P2 30 - ZUNEW=1.0-ZCOF*ZU-5.0*P2 31 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 32 - WSUM=WSUM+E(J)*(ZTERM2/ZTERM1) 33 - ENDIF 34 - 10 CONTINUE 35 - EX=-REAL(-ZMULT*WSUM) 36 - EY=AIMAG(-ZMULT*WSUM) 37 - END 616 GARFIELD ================================================== P=FIELDCAL D=EFCMAT 1 ============================ 0 + +DECK,EFCMAT. 1 - SUBROUTINE EFCMAT(X0,Y0,X1,Y1,DX,DY) 2 - *----------------------------------------------------------------------- 3 - * EFCMAT - Computes the effective distance between points taking the 4 - * effects of dielectrica into account. 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,CELLDATA. 8 - *** Compute the dielectricum-weighed x-distance. 9 - DX=ABS(X1-X0) 10 - DO 10 I=1,NXMATT 11 - XM0=MAX(MIN(X0,X1),MIN(XMATT(I,1),XMATT(I,2))) 12 - XM1=MIN(MAX(X0,X1),MAX(XMATT(I,1),XMATT(I,2))) 13 - IF(XM1.GE.XM0)DX=DX+(XMATT(I,3)-1.0)*ABS(XM1-XM0) 14 - 10 CONTINUE 15 - DX=SIGN(DX,X1-X0) 16 - *** Compute the dielectricum-weighed x-distance. 17 - DY=ABS(Y1-Y0) 18 - DO 20 I=1,NYMATT 19 - YM0=MAX(MIN(Y0,Y1),MIN(YMATT(I,1),YMATT(I,2))) 1 616 P=FIELDCAL D=EFCMAT 2 PAGE 893 20 - YM1=MIN(MAX(Y0,Y1),MAX(YMATT(I,1),YMATT(I,2))) 21 - IF(YM1.GE.YM0)DY=DY+(YMATT(I,3)-1.0)*ABS(YM1-YM0) 22 - 20 CONTINUE 23 - DY=SIGN(DY,Y1-Y0) 24 - END 617 GARFIELD ================================================== P=FIELDCAL D=EFCFMP 1 ============================ 0 + +DECK,EFCFMP. 1 - SUBROUTINE EFCFMP(XIN,YIN,ZIN,EX,EY,EZ,VOLT,IOPT,ILOC) 2 - *----------------------------------------------------------------------- 3 - * EFCFMP - Interpolates the field map at (XPOS,YPOS,ZPOS). 4 - * (Last changed on 10/ 7/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,FIELDMAP. 9.- +SEQ,CELLDATA. 10.- +SEQ,CONSTANTS. 11 - REAL XIN,YIN,ZIN,XPOS,YPOS,ZPOS,EX,EY,EZ,VOLT,XNEW,YNEW,ZNEW, 12 - - T1,T2,T3,T4,AUXPHI,AUXR,AROT,XAUX,YAUX,ER,EAXIS,RCOOR,ZCOOR 13 - INTEGER IOPT,ILOC,IMAP,NX,NY,NZ 14 - LOGICAL MIRRX,MIRRY,MIRRZ 15 - *** Initial values. 16 - EX=0 17 - EY=0 18 - EZ=0 19 - VOLT=0 20 - ILOC=0 21 - XPOS=XIN 22 - YPOS=YIN 23 - ZPOS=ZIN 24 - *** First see whether we at all have a grid. 25 - IF(.NOT.MAPFLG(1))RETURN 26 - *** If chamber is periodic, reduce to the cell volume. 27 - MIRRX=.FALSE. 28 - IF(PERX)THEN 29 - XPOS=XMMIN+MOD(XPOS-XMMIN,XMMAX-XMMIN) 30 - IF(XPOS.LT.XMMIN)XPOS=XPOS+(XMMAX-XMMIN) 31 - ELSEIF(PERMX)THEN 32 - XNEW=XMMIN+MOD(XPOS-XMMIN,XMMAX-XMMIN) 33 - IF(XNEW.LT.XMMIN)XNEW=XNEW+(XMMAX-XMMIN) 34 - NX=NINT((XNEW-XPOS)/(XMMAX-XMMIN)) 35 - IF(NX.NE.2*(NX/2))THEN 36 - XNEW=XMMIN+XMMAX-XNEW 37 - MIRRX=.TRUE. 38 - ENDIF 39 - XPOS=XNEW 40 - ENDIF 41 - IF(PERAX.AND.(ZPOS.NE.0.OR.YPOS.NE.0))THEN 42 - AUXR=SQRT(ZPOS**2+YPOS**2) 43 - AUXPHI=ATAN2(ZPOS,YPOS) 44 - AROT=(XAMAX-XAMIN)*ANINT((AUXPHI-0.5*(XAMIN+XAMAX))/ 45 - - (XAMAX-XAMIN)) 46 - IF(AUXPHI-AROT.LT.XAMIN)AROT=AROT-(XAMAX-XAMIN) 47 - IF(AUXPHI-AROT.GT.XAMAX)AROT=AROT+(XAMAX-XAMIN) 48 - AUXPHI=AUXPHI-AROT 49 - YPOS=AUXR*COS(AUXPHI) 50 - ZPOS=AUXR*SIN(AUXPHI) 51 - ENDIF 52 - MIRRY=.FALSE. 53 - IF(PERY)THEN 54 - YPOS=YMMIN+MOD(YPOS-YMMIN,YMMAX-YMMIN) 55 - IF(YPOS.LT.YMMIN)YPOS=YPOS+(YMMAX-YMMIN) 56 - ELSEIF(PERMY)THEN 57 - YNEW=YMMIN+MOD(YPOS-YMMIN,YMMAX-YMMIN) 58 - IF(YNEW.LT.YMMIN)YNEW=YNEW+(YMMAX-YMMIN) 59 - NY=NINT((YNEW-YPOS)/(YMMAX-YMMIN)) 60 - IF(NY.NE.2*(NY/2))THEN 61 - YNEW=YMMIN+YMMAX-YNEW 62 - MIRRY=.TRUE. 63 - ENDIF 64 - YPOS=YNEW 65 - ENDIF 66 - IF(PERAY.AND.(XPOS.NE.0.OR.ZPOS.NE.0))THEN 67 - AUXR=SQRT(XPOS**2+ZPOS**2) 68 - AUXPHI=ATAN2(XPOS,ZPOS) 69 - AROT=(YAMAX-YAMIN)*ANINT((AUXPHI-0.5*(YAMIN+YAMAX))/ 70 - - (YAMAX-YAMIN)) 71 - IF(AUXPHI-AROT.LT.YAMIN)AROT=AROT-(YAMAX-YAMIN) 72 - IF(AUXPHI-AROT.GT.YAMAX)AROT=AROT+(YAMAX-YAMIN) 73 - AUXPHI=AUXPHI-AROT 74 - ZPOS=AUXR*COS(AUXPHI) 75 - XPOS=AUXR*SIN(AUXPHI) 76 - ENDIF 77 - MIRRZ=.FALSE. 78 - IF(PERZ)THEN 79 - ZPOS=ZMMIN+MOD(ZPOS-ZMMIN,ZMMAX-ZMMIN) 80 - IF(ZPOS.LT.ZMMIN)ZPOS=ZPOS+(ZMMAX-ZMMIN) 81 - ELSEIF(PERMZ)THEN 82 - ZNEW=ZMMIN+MOD(ZPOS-ZMMIN,ZMMAX-ZMMIN) 83 - IF(ZNEW.LT.ZMMIN)ZNEW=ZNEW+(ZMMAX-ZMMIN) 84 - NZ=NINT((ZNEW-ZPOS)/(ZMMAX-ZMMIN)) 85 - IF(NZ.NE.2*(NZ/2))THEN 86 - ZNEW=ZMMIN+ZMMAX-ZNEW 87 - MIRRZ=.TRUE. 88 - ENDIF 89 - ZPOS=ZNEW 90 - ENDIF 91 - IF(PERAZ.AND.(YPOS.NE.0.OR.XPOS.NE.0))THEN 92 - AUXR=SQRT(YPOS**2+XPOS**2) 93 - AUXPHI=ATAN2(YPOS,XPOS) 94 - AROT=(ZAMAX-ZAMIN)*ANINT((AUXPHI-0.5*(ZAMIN+ZAMAX))/ 95 - - (ZAMAX-ZAMIN)) 96 - IF(AUXPHI-AROT.LT.ZAMIN)AROT=AROT-(ZAMAX-ZAMIN) 97 - IF(AUXPHI-AROT.GT.ZAMAX)AROT=AROT+(ZAMAX-ZAMIN) 1 617 P=FIELDCAL D=EFCFMP 2 PAGE 894 98 - AUXPHI=AUXPHI-AROT 99 - XPOS=AUXR*COS(AUXPHI) 100 - YPOS=AUXR*SIN(AUXPHI) 101 - ENDIF 102 - *** If we have a rotationally symmetric field map, store coordinates. 103 - IF(PERRX)THEN 104 - RCOOR=SQRT(YPOS**2+ZPOS**2) 105 - ZCOOR=XPOS 106 - ELSEIF(PERRY)THEN 107 - RCOOR=SQRT(XPOS**2+ZPOS**2) 108 - ZCOOR=YPOS 109 - ELSEIF(PERRZ)THEN 110 - RCOOR=SQRT(XPOS**2+YPOS**2) 111 - ZCOOR=ZPOS 112 - ENDIF 113 - IF(PERRX.OR.PERRY.OR.PERRZ)THEN 114 - XPOS=RCOOR 115 - YPOS=ZCOOR 116 - ZPOS=0 117 - ENDIF 118 - *** Locate the point. 119 - CALL MAPIND(XPOS,YPOS,ZPOS,T1,T2,T3,T4,IMAP) 120 - IF(IMAP.LE.0.OR.IMAP.GT.NMAP)THEN 121 - ILOC=-6 122 - RETURN 123 - ENDIF 124 - *** Next perform a 3-dimensional interpolation, linear ... 125 - IF((MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13).AND. 126 - - MAPORD.EQ.1)THEN 127 - IF(MAPFLG(5).AND.IOPT.EQ.1)VOLT=VMAP(IMAP,1)*T1+ 128 - - VMAP(IMAP,2)*T2+VMAP(IMAP,3)*T3+VMAP(IMAP,4)*T4 129 - IF(MAPFLG(2))EX=EXMAP(IMAP,1)*T1+EXMAP(IMAP,2)*T2+ 130 - - EXMAP(IMAP,3)*T3+EXMAP(IMAP,4)*T4 131 - IF(MAPFLG(3))EY=EYMAP(IMAP,1)*T1+EYMAP(IMAP,2)*T2+ 132 - - EYMAP(IMAP,3)*T3+EYMAP(IMAP,4)*T4 133 - IF(MAPFLG(4))EZ=EZMAP(IMAP,1)*T1+EZMAP(IMAP,2)*T2+ 134 - - EZMAP(IMAP,3)*T3+EZMAP(IMAP,4)*T4 135 - * or quadratic. 136 - ELSEIF(MAPTYP.EQ.12.AND.MAPORD.EQ.2)THEN 137 - IF(MAPFLG(5).AND.IOPT.EQ.1)VOLT= 138 - - VMAP(IMAP,1)*T1*(2*T1-1)+VMAP(IMAP,2)*T2*(2*T2-1)+ 139 - - VMAP(IMAP,3)*T3*(2*T3-1)+VMAP(IMAP,4)*T4*(2*T4-1)+ 140 - - 4*VMAP(IMAP,5)*T1*T2+4*VMAP(IMAP,6)*T1*T3+ 141 - - 4*VMAP(IMAP,7)*T1*T4+4*VMAP(IMAP,8)*T2*T3+ 142 - - 4*VMAP(IMAP,9)*T2*T4+4*VMAP(IMAP,10)*T3*T4 143 - IF(MAPFLG(2))EX= 144 - - EXMAP(IMAP,1)*T1*(2*T1-1)+EXMAP(IMAP,2)*T2*(2*T2-1)+ 145 - - EXMAP(IMAP,3)*T3*(2*T3-1)+EXMAP(IMAP,4)*T4*(2*T4-1)+ 146 - - 4*EXMAP(IMAP,5)*T1*T2+4*EXMAP(IMAP,6)*T1*T3+ 147 - - 4*EXMAP(IMAP,7)*T1*T4+4*EXMAP(IMAP,8)*T2*T3+ 148 - - 4*EXMAP(IMAP,9)*T2*T4+4*EXMAP(IMAP,10)*T3*T4 149 - IF(MAPFLG(3))EY= 150 - - EYMAP(IMAP,1)*T1*(2*T1-1)+EYMAP(IMAP,2)*T2*(2*T2-1)+ 151 - - EYMAP(IMAP,3)*T3*(2*T3-1)+EYMAP(IMAP,4)*T4*(2*T4-1)+ 152 - - 4*EYMAP(IMAP,5)*T1*T2+4*EYMAP(IMAP,6)*T1*T3+ 153 - - 4*EYMAP(IMAP,7)*T1*T4+4*EYMAP(IMAP,8)*T2*T3+ 154 - - 4*EYMAP(IMAP,9)*T2*T4+4*EYMAP(IMAP,10)*T3*T4 155 - IF(MAPFLG(4))EZ= 156 - - EZMAP(IMAP,1)*T1*(2*T1-1)+EZMAP(IMAP,2)*T2*(2*T2-1)+ 157 - - EZMAP(IMAP,3)*T3*(2*T3-1)+EZMAP(IMAP,4)*T4*(2*T4-1)+ 158 - - 4*EZMAP(IMAP,5)*T1*T2+4*EZMAP(IMAP,6)*T1*T3+ 159 - - 4*EZMAP(IMAP,7)*T1*T4+4*EZMAP(IMAP,8)*T2*T3+ 160 - - 4*EZMAP(IMAP,9)*T2*T4+4*EZMAP(IMAP,10)*T3*T4 161 - *** Or perform a 2-dimensional interpolation, linear ... 162 - ELSEIF((MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3).AND. 163 - - MAPORD.EQ.1)THEN 164 - IF(MAPFLG(5).AND.IOPT.EQ.1)VOLT= 165 - - VMAP(IMAP,1)*T1+VMAP(IMAP,2)*T2+VMAP(IMAP,3)*T3 166 - IF(MAPFLG(2))EX= 167 - - EXMAP(IMAP,1)*T1+EXMAP(IMAP,2)*T2+EXMAP(IMAP,3)*T3 168 - IF(MAPFLG(3))EY= 169 - - EYMAP(IMAP,1)*T1+EYMAP(IMAP,2)*T2+EYMAP(IMAP,3)*T3 170 - IF(MAPFLG(4))EZ= 171 - - EZMAP(IMAP,1)*T1+EZMAP(IMAP,2)*T2+EZMAP(IMAP,3)*T3 172 - * or quadratic. 173 - ELSEIF(MAPTYP.EQ.2.AND.MAPORD.EQ.2)THEN 174 - IF(MAPFLG(5).AND.IOPT.EQ.1)VOLT= 175 - - VMAP(IMAP,1)*T1*(2*T1-1)+VMAP(IMAP,2)*T2*(2*T2-1)+ 176 - - VMAP(IMAP,3)*T3*(2*T3-1)+4*VMAP(IMAP,4)*T1*T2+ 177 - - 4*VMAP(IMAP,5)*T1*T3+4*VMAP(IMAP,6)*T2*T3 178 - IF(MAPFLG(2))EX= 179 - - EXMAP(IMAP,1)*T1*(2*T1-1)+EXMAP(IMAP,2)*T2*(2*T2-1)+ 180 - - EXMAP(IMAP,3)*T3*(2*T3-1)+4*EXMAP(IMAP,4)*T1*T2+ 181 - - 4*EXMAP(IMAP,5)*T1*T3+4*EXMAP(IMAP,6)*T2*T3 182 - IF(MAPFLG(3))EY= 183 - - EYMAP(IMAP,1)*T1*(2*T1-1)+EYMAP(IMAP,2)*T2*(2*T2-1)+ 184 - - EYMAP(IMAP,3)*T3*(2*T3-1)+4*EYMAP(IMAP,4)*T1*T2+ 185 - - 4*EYMAP(IMAP,5)*T1*T3+4*EYMAP(IMAP,6)*T2*T3 186 - IF(MAPFLG(4))EZ= 187 - - EZMAP(IMAP,1)*T1*(2*T1-1)+EZMAP(IMAP,2)*T2*(2*T2-1)+ 188 - - EZMAP(IMAP,3)*T3*(2*T3-1)+4*EZMAP(IMAP,4)*T1*T2+ 189 - - 4*EZMAP(IMAP,5)*T1*T3+4*EZMAP(IMAP,6)*T2*T3 190 - *** Or an interpolation on a regular hexahedron, linear. 191 - ELSEIF(MAPTYP.EQ.14)THEN 192 - IF(MAPFLG(5).AND.IOPT.EQ.1)VOLT= 193 - - VMAP(IMAP,1)*(1-T1)*(1-T2)*(1-T3)+ 194 - - VMAP(IMAP,2)* T1 *(1-T2)*(1-T3)+ 195 - - VMAP(IMAP,3)* T1 * T2 *(1-T3)+ 196 - - VMAP(IMAP,4)*(1-T1)* T2 *(1-T3)+ 197 - - VMAP(IMAP,5)*(1-T1)*(1-T2)* T3 + 198 - - VMAP(IMAP,6)* T1 *(1-T2)* T3 + 199 - - VMAP(IMAP,7)* T1 * T2 * T3 + 200 - - VMAP(IMAP,8)*(1-T1)* T2 * T3 201 - IF(MAPFLG(2))EX= 202 - - EXMAP(IMAP,1)*(1-T1)*(1-T2)*(1-T3)+ 203 - - EXMAP(IMAP,2)* T1 *(1-T2)*(1-T3)+ 1 617 P=FIELDCAL D=EFCFMP 3 PAGE 895 204 - - EXMAP(IMAP,3)* T1 * T2 *(1-T3)+ 205 - - EXMAP(IMAP,4)*(1-T1)* T2 *(1-T3)+ 206 - - EXMAP(IMAP,5)*(1-T1)*(1-T2)* T3 + 207 - - EXMAP(IMAP,6)* T1 *(1-T2)* T3 + 208 - - EXMAP(IMAP,7)* T1 * T2 * T3 + 209 - - EXMAP(IMAP,8)*(1-T1)* T2 * T3 210 - IF(MAPFLG(3))EY= 211 - - EYMAP(IMAP,1)*(1-T1)*(1-T2)*(1-T3)+ 212 - - EYMAP(IMAP,2)* T1 *(1-T2)*(1-T3)+ 213 - - EYMAP(IMAP,3)* T1 * T2 *(1-T3)+ 214 - - EYMAP(IMAP,4)*(1-T1)* T2 *(1-T3)+ 215 - - EYMAP(IMAP,5)*(1-T1)*(1-T2)* T3 + 216 - - EYMAP(IMAP,6)* T1 *(1-T2)* T3 + 217 - - EYMAP(IMAP,7)* T1 * T2 * T3 + 218 - - EYMAP(IMAP,8)*(1-T1)* T2 * T3 219 - IF(MAPFLG(4))EZ= 220 - - EZMAP(IMAP,1)*(1-T1)*(1-T2)*(1-T3)+ 221 - - EZMAP(IMAP,2)* T1 *(1-T2)*(1-T3)+ 222 - - EZMAP(IMAP,3)* T1 * T2 *(1-T3)+ 223 - - EZMAP(IMAP,4)*(1-T1)* T2 *(1-T3)+ 224 - - EZMAP(IMAP,5)*(1-T1)*(1-T2)* T3 + 225 - - EZMAP(IMAP,6)* T1 *(1-T2)* T3 + 226 - - EZMAP(IMAP,7)* T1 * T2 * T3 + 227 - - EZMAP(IMAP,8)*(1-T1)* T2 * T3 228 - *** Or an unknown case. 229 - ELSE 230 - ILOC=-10 231 - RETURN 232 - ENDIF 233 - *** Apply mirror imaging. 234 - IF(MIRRX)EX=-EX 235 - IF(MIRRY)EY=-EY 236 - IF(MIRRZ)EZ=-EZ 237 - *** Rotate the field. 238 - IF(PERAX)THEN 239 - CALL CFMCTP(EY,EZ,XAUX,YAUX,1) 240 - YAUX=YAUX+AROT*180/PI 241 - CALL CFMPTC(XAUX,YAUX,EY,EZ,1) 242 - ENDIF 243 - IF(PERAY)THEN 244 - CALL CFMCTP(EZ,EX,XAUX,YAUX,1) 245 - YAUX=YAUX+AROT*180/PI 246 - CALL CFMPTC(XAUX,YAUX,EZ,EX,1) 247 - ENDIF 248 - IF(PERAZ)THEN 249 - CALL CFMCTP(EX,EY,XAUX,YAUX,1) 250 - YAUX=YAUX+AROT*180/PI 251 - CALL CFMPTC(XAUX,YAUX,EX,EY,1) 252 - ENDIF 253 - *** And take care of symmetry. 254 - ER=EX 255 - EAXIS=EZ 256 - IF(PERRX)THEN 257 - IF(RCOOR.LE.0)THEN 258 - EX=EAXIS 259 - EY=0 260 - EZ=0 261 - ELSE 262 - EX=EAXIS 263 - EY=ER*YIN/RCOOR 264 - EZ=ER*ZIN/RCOOR 265 - ENDIF 266 - ENDIF 267 - IF(PERRY)THEN 268 - IF(RCOOR.LE.0)THEN 269 - EX=0 270 - EY=EAXIS 271 - EZ=0 272 - ELSE 273 - EX=ER*XIN/RCOOR 274 - EY=EAXIS 275 - EZ=ER*ZIN/RCOOR 276 - ENDIF 277 - ENDIF 278 - IF(PERRZ)THEN 279 - IF(RCOOR.LE.0)THEN 280 - EX=0 281 - EY=0 282 - EZ=EAXIS 283 - ELSE 284 - EX=ER*XIN/RCOOR 285 - EY=ER*YIN/RCOOR 286 - EZ=EAXIS 287 - ENDIF 288 - ENDIF 289 - *** And store material index. 290 - IF(MATMAP(IMAP).EQ.IDRMAT.OR..NOT.MAPFLG(9))THEN 291 - ILOC=0 292 - ELSE 293 - ILOC=-5 294 - ENDIF 295 - END 618 GARFIELD ================================================== P=FIELDCAL D=EFCBGF 1 ============================ 0 + +DECK,EFCBGF. 1 - SUBROUTINE EFCBGF(XIN,YIN,ZIN,EXBGF,EYBGF,EZBGF,VBGF) 2 - *----------------------------------------------------------------------- 3 - * EFCBGF - Computes the background field. 4 - * (Last changed on 6/ 4/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,PRINTPLOT. 10 - REAL VAR(MXVAR),RES(4),XIN,YIN,ZIN,EXBGF,EYBGF,EZBGF,VBGF, 1 618 P=FIELDCAL D=EFCBGF 2 PAGE 896 11 - - EXFMP,EYFMP,EZFMP,VFMP 12 - INTEGER MODVAR(MXVAR),MODRES(4),IFAIL,I,NREXP,NVAR,ILOC 13 - *** Check that there is an entry. 14 - IF(IENBGF.LE.0)RETURN 15 - *** Store the location in the variables. 16 - IF(POLAR)THEN 17 - CALL CFMRTP(XIN,YIN,VAR(1),VAR(2),1) 18 - VAR(3)=ZIN 19 - ELSE 20 - VAR(1)=XIN 21 - VAR(2)=YIN 22 - VAR(3)=ZIN 23 - ENDIF 24 - MODVAR(1)=2 25 - MODVAR(2)=2 26 - MODVAR(3)=2 27 - * Interpolate field map. 28 - IF(LBGFMP)THEN 29 - CALL EFCFMP(XIN,YIN,ZIN,EXFMP,EYFMP,EZFMP,VFMP,1,ILOC) 30 - IF(ILOC.NE.0.AND.ILOC.NE.-5)THEN 31 - VAR(4)=0 32 - VAR(5)=0 33 - VAR(6)=0 34 - VAR(7)=0 35 - ELSE 36 - VAR(4)=EXFMP 37 - VAR(5)=EYFMP 38 - VAR(6)=EZFMP 39 - VAR(7)=VFMP 40 - ENDIF 41 - MODVAR(4)=2 42 - MODVAR(5)=2 43 - MODVAR(6)=2 44 - MODVAR(7)=2 45 - ELSE 46 - VAR(4)=0 47 - VAR(5)=0 48 - VAR(6)=0 49 - VAR(7)=0 50 - MODVAR(4)=0 51 - MODVAR(5)=0 52 - MODVAR(6)=0 53 - MODVAR(7)=0 54 - ENDIF 55 - * Set number of variables. 56 - NVAR=7 57 - *** Compute the field. 58 - NREXP=4 59 - CALL AL2EXE(IENBGF,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL) 60 - * Check the error flag and variable types. 61 - IF(IFAIL.NE.0.OR.MODRES(1).NE.2.OR.MODRES(2).NE.2.OR. 62 - - MODRES(3).NE.2.OR.MODRES(4).NE.2)THEN 63 - EXBGF=0 64 - EYBGF=0 65 - EZBGF=0 66 - VBGF=0 67 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ EFCBGF DEBUG :'', 68 - - '' Invalid background field result:''/ 69 - - 26X,''IFAIL='',I2,'', modes: '',4I2)') 70 - - IFAIL,(MODRES(I),I=1,4) 71 - * Convert to polar internal field vectors if required. 72 - ELSEIF(POLAR)THEN 73 - VBGF=RES(1) 74 - EXBGF=RES(2)*EXP(XIN) 75 - EYBGF=RES(3)*EXP(XIN) 76 - EZBGF=RES(4) 77 - * Or simply store the results. 78 - ELSE 79 - VBGF=RES(1) 80 - EXBGF=RES(2) 81 - EYBGF=RES(3) 82 - EZBGF=RES(4) 83 - ENDIF 84 - END 619 GARFIELD ================================================== P=FIELDCAL D=FFDBG 1 ============================ 0 + +DECK,FFDBG. 1 - SUBROUTINE FFDBG(XPOS,YPOS,EX,EY) 2 - *----------------------------------------------------------------------- 3 - * FFDBG - Subroutine used for debugging force calculations. 4 - * VARIABLES : XPOS, YPOS : position 5 - * EX, EY : x- and y-component of the electric field. 6 - * (Last changed on 20/ 1/97.) 7 - *----------------------------------------------------------------------- 8.- +SEQ,DIMENSIONS. 9.- +SEQ,PARAMETERS. 10.- +SEQ,CELLDATA. 11.- +SEQ,PRINTPLOT. 12.- +SEQ,CONSTANTS. 13 - REAL EX,EY 14 - *** Initial values. 15 - EX=0 16 - EY=0 17 - *** Set the CNALSO flags appropriately. 18 - DO 10 I=1,NWIRE 19 - CNALSO(I)=.TRUE. 20 - 10 CONTINUE 21 - *** Call the appropriate potential calculation function. 22 - IF(ICTYPE.EQ.1) CALL FFCA00(XPOS,YPOS,EX,EY) 23 - IF(ICTYPE.EQ.2) CALL FFCB1X(XPOS,YPOS,EX,EY) 24 - IF(ICTYPE.EQ.3) CALL FFCB1Y(XPOS,YPOS,EX,EY) 25 - IF(ICTYPE.EQ.4) CALL FFCB2X(XPOS,YPOS,EX,EY) 26 - IF(ICTYPE.EQ.5) CALL FFCB2Y(XPOS,YPOS,EX,EY) 27 - IF(ICTYPE.EQ.6) CALL FFCC10(XPOS,YPOS,EX,EY) 28 - IF(ICTYPE.EQ.7) CALL FFCC2X(XPOS,YPOS,EX,EY) 1 619 P=FIELDCAL D=FFDBG 2 PAGE 897 29 - IF(ICTYPE.EQ.8) CALL FFCC2Y(XPOS,YPOS,EX,EY) 30 - IF(ICTYPE.EQ.9) CALL FFCC30(XPOS,YPOS,EX,EY) 31 - IF(ICTYPE.EQ.10)CALL FFCD10(XPOS,YPOS,EX,EY) 32 - IF(ICTYPE.EQ.11)CALL FFCD20(XPOS,YPOS,EX,EY) 33 - IF(ICTYPE.EQ.12)CALL FFCD30(XPOS,YPOS,EX,EY) 34 - C IF(ICTYPE.EQ.13)CALL FFCD40(XPOS,YPOS,EX,EY) 35 - *** Correct for the equipotential planes. 36 - EX=EX-CORVTA 37 - EY=EY-CORVTB 38 - END 620 GARFIELD ================================================== P=FIELDCAL D=FFIELD 1 ============================ 0 + +DECK,FFIELD. 1 - SUBROUTINE FFIELD(IW,EX,EY) 2 - *----------------------------------------------------------------------- 3 - * FFIELD - Subroutine calculating the electric field at a given wire 4 - * position, as if the wire itself were not there but with 5 - * the presence of its mirror images. 6 - * VARIABLES : IW : wire number 7 - * EX, EY : x- and y-component of the electric field. 8 - * (Last changed on 27/ 1/96.) 9 - *----------------------------------------------------------------------- 10.- +SEQ,DIMENSIONS. 11.- +SEQ,PARAMETERS. 12.- +SEQ,CELLDATA. 13.- +SEQ,PRINTPLOT. 14.- +SEQ,CONSTANTS. 15 - REAL EX,EY 16 - INTEGER IW 17 - *** Initial values. 18 - EX=0 19 - EY=0 20 - *** Check the wire number. 21 - IF(IW.LT.1.OR.IW.GT.NWIRE)THEN 22 - PRINT *,' !!!!!! FFIELD WARNING : Received an invalid'// 23 - - ' wire number; field set to zero.' 24 - RETURN 25 - ENDIF 26 - *** Set the CNALSO flags appropriately. 27 - DO 10 I=1,NWIRE 28 - CNALSO(I)=.TRUE. 29 - 10 CONTINUE 30 - CNALSO(IW)=.FALSE. 31 - *** Call the appropriate potential calculation function. 32 - IF(ICTYPE.EQ.1) CALL FFCA00(X(IW),Y(IW),EX,EY) 33 - IF(ICTYPE.EQ.2) CALL FFCB1X(X(IW),Y(IW),EX,EY) 34 - IF(ICTYPE.EQ.3) CALL FFCB1Y(X(IW),Y(IW),EX,EY) 35 - IF(ICTYPE.EQ.4) CALL FFCB2X(X(IW),Y(IW),EX,EY) 36 - IF(ICTYPE.EQ.5) CALL FFCB2Y(X(IW),Y(IW),EX,EY) 37 - IF(ICTYPE.EQ.6) CALL FFCC10(X(IW),Y(IW),EX,EY) 38 - IF(ICTYPE.EQ.7) CALL FFCC2X(X(IW),Y(IW),EX,EY) 39 - IF(ICTYPE.EQ.8) CALL FFCC2Y(X(IW),Y(IW),EX,EY) 40 - IF(ICTYPE.EQ.9) CALL FFCC30(X(IW),Y(IW),EX,EY) 41 - IF(ICTYPE.EQ.10)CALL FFCD10(X(IW),Y(IW),EX,EY) 42 - IF(ICTYPE.EQ.11)CALL FFCD20(X(IW),Y(IW),EX,EY) 43 - IF(ICTYPE.EQ.12)CALL FFCD30(X(IW),Y(IW),EX,EY) 44 - C IF(ICTYPE.EQ.13)CALL FFCD40(X(IW),Y(IW),EX,EY) 45 - *** Correct for the equipotential planes. 46 - EX=EX-CORVTA 47 - EY=EY-CORVTB 48 - C print *,' FFIELD - wire ',IW,' E=',EX,EY,' q=',E(IW) 49 - END 621 GARFIELD ================================================== P=FIELDCAL D=FFCA00 1 ============================ 0 + +DECK,FFCA00. 1 - SUBROUTINE FFCA00(XPOS,YPOS,EX,EY) 2 - *----------------------------------------------------------------------- 3 - * FFCA00 - Subroutine performing the actual field calculations in case 4 - * only one charge and not more than 1 mirror-charge in either 5 - * x or y is present. 6 - * The potential used is 1/2*pi*eps0 log(r). 7 - * VARIABLES : R2 : Potential before taking -log(sqrt(...)) 8 - * EX, EY : x,y-component of the electric field. 9 - * ETOT : Magnitude of electric field. 10 - * EXHELP etc : One term in the series to be summed. 11 - * (XPOS,YPOS): The position where the field is calculated. 12 - * (Last changed on 27/ 1/96.) 13 - *----------------------------------------------------------------------- 14.- +SEQ,DIMENSIONS. 15.- +SEQ,CELLDATA. 16 - *** Initialise the potential and the electric field. 17 - EX=0 18 - EY=0 19 - *** Loop over all wires. 20 - DO 10 I=1,NWIRE 21 - *** Calculate the field in case there are no planes. 22 - IF(CNALSO(I))THEN 23 - R2=(XPOS-X(I))**2+(YPOS-Y(I))**2 24 - EXHELP=(XPOS-X(I))/R2 25 - EYHELP=(YPOS-Y(I))/R2 26 - ELSE 27 - EXHELP=0 28 - EYHELP=0 29 - ENDIF 30 - *** Take care of a plane at constant x. 31 - IF(YNPLAX)THEN 32 - XXMIRR=X(I)+XPOS-2*COPLAX 33 - R2PLAN=XXMIRR**2+(YPOS-Y(I))**2 34 - EXHELP=EXHELP-XXMIRR/R2PLAN 35 - EYHELP=EYHELP-(YPOS-Y(I))/R2PLAN 36 - ENDIF 37 - *** Take care of a plane at constant y. 38 - IF(YNPLAY)THEN 39 - YYMIRR=Y(I)+YPOS-2*COPLAY 1 621 P=FIELDCAL D=FFCA00 2 PAGE 898 40 - R2PLAN=(XPOS-X(I))**2+YYMIRR**2 41 - EXHELP=EXHELP-(XPOS-X(I))/R2PLAN 42 - EYHELP=EYHELP-YYMIRR/R2PLAN 43 - ENDIF 44 - *** Take care of pairs of planes. 45 - IF(YNPLAX.AND.YNPLAY)THEN 46 - R2PLAN=XXMIRR**2+YYMIRR**2 47 - EXHELP=EXHELP+XXMIRR/R2PLAN 48 - EYHELP=EYHELP+YYMIRR/R2PLAN 49 - ENDIF 50 - *** Calculate the electric field and the potential. 51 - EX=EX+E(I)*EXHELP 52 - EY=EY+E(I)*EYHELP 53 - *** Finish the loop over the wires. 54 - 10 CONTINUE 55 - END 622 GARFIELD ================================================== P=FIELDCAL D=FFCB1X 1 ============================ 0 + +DECK,FFCB1X. 1 - SUBROUTINE FFCB1X(XPOS,YPOS,EX,EY) 2 - *----------------------------------------------------------------------- 3 - * FFCB1X - Routine calculating the potential for a row of positive 4 - * charges. The potential used is Re(Log(sin pi/s (z-z0))). 5 - * VARIABLES : See routine FFCA00 for most of the variables. 6 - * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 7 - * ECOMPL : EX + I*EY ; I**2=-1 8 - * (Last changed on 27/ 1/96.) 9 - *----------------------------------------------------------------------- 10.- +SEQ,DIMENSIONS. 11.- +SEQ,CELLDATA. 12.- +SEQ,CONSTANTS. 13 - COMPLEX ZZ,ECOMPL,ZZMIRR 14 - *** Initialise EX, EY. 15 - EX=0 16 - EY=0 17 - *** With a y plane. 18 - IF(YNPLAY)THEN 19 - DO 10 I=1,NWIRE 20 - XX=(PI/SX)*(XPOS-X(I)) 21 - YY=(PI/SX)*(YPOS-Y(I)) 22 - ZZ=CMPLX(XX,YY) 23 - IF(.NOT.CNALSO(I))THEN 24 - ECOMPL=0 25 - ELSEIF(YY.GT.+20)THEN 26 - ECOMPL=-ICONS 27 - ELSEIF(YY.LT.-20)THEN 28 - ECOMPL=+ICONS 29 - ELSE 30 - ECOMPL=ICONS*(EXP(2*ICONS*ZZ)+1)/(EXP(2*ICONS*ZZ)-1) 31 - ENDIF 32 - YYMIRR=(PI/SX)*(YPOS+Y(I)-2*COPLAY) 33 - ZZMIRR=CMPLX(XX,YYMIRR) 34 - IF(YYMIRR.GT.+20)THEN 35 - ECOMPL=ECOMPL+ICONS 36 - ELSEIF(YYMIRR.LT.-20)THEN 37 - ECOMPL=ECOMPL-ICONS 38 - ELSE 39 - ECOMPL=ECOMPL-ICONS*(EXP(2*ICONS*ZZMIRR)+1)/ 40 - - (EXP(2*ICONS*ZZMIRR)-1) 41 - ENDIF 42 - * Update the field. 43 - EX=EX+E(I)*(PI/SX)*REAL(ECOMPL) 44 - EY=EY-E(I)*(PI/SX)*AIMAG(ECOMPL) 45 - 10 CONTINUE 46 - *** Without y plane. 47 - ELSE 48 - DO 20 I=1,NWIRE 49 - IF(.NOT.CNALSO(I))GOTO 20 50 - XX=(PI/SX)*(XPOS-X(I)) 51 - YY=(PI/SX)*(YPOS-Y(I)) 52 - ZZ=CMPLX(XX,YY) 53 - IF(YY.GT.+20)THEN 54 - ECOMPL=-ICONS 55 - ELSEIF(YY.LT.-20)THEN 56 - ECOMPL=+ICONS 57 - ELSE 58 - ECOMPL=ICONS*(EXP(2*ICONS*ZZ)+1)/ 59 - - (EXP(2*ICONS*ZZ)-1) 60 - ENDIF 61 - EX=EX+E(I)*(PI/SX)*REAL(ECOMPL) 62 - EY=EY-E(I)*(PI/SX)*AIMAG(ECOMPL) 63 - 20 CONTINUE 64 - ENDIF 65 - END 623 GARFIELD ================================================== P=FIELDCAL D=FFCB1Y 1 ============================ 0 + +DECK,FFCB1Y. 1 - SUBROUTINE FFCB1Y(XPOS,YPOS,EX,EY) 2 - *----------------------------------------------------------------------- 3 - * FFCB1Y - Routine calculating the potential for a row of positive 4 - * charges. The potential used is Re(Log(sinh pi/sy(z-z0)). 5 - * VARIABLES : See routine FFCA00 for most of the variables. 6 - * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 7 - * ECOMPL : EX + I*EY ; I**2=-1 8 - * (IBM and Cray vectorisable version.) 9 - * (Last changed on 27/ 1/96.) 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13.- +SEQ,CONSTANTS. 14 - COMPLEX ZZ,ECOMPL,ZZMIRR 15 - *** Initialise EX, EY. 16 - EX=0 17 - EY=0 1 623 P=FIELDCAL D=FFCB1Y 2 PAGE 899 18 - *** First the situation there is an x-plane. 19 - IF(YNPLAX)THEN 20 - DO 10 I=1,NWIRE 21 - XX=(PI/SY)*(XPOS-X(I)) 22 - YY=(PI/SY)*(YPOS-Y(I)) 23 - ZZ=CMPLX(XX,YY) 24 - IF(.NOT.CNALSO(I))THEN 25 - ECOMPL=0 26 - ELSEIF(XX.GT.+20)THEN 27 - ECOMPL=+1 28 - ELSEIF(XX.LT.-20)THEN 29 - ECOMPL=-1 30 - ELSE 31 - ECOMPL=(EXP(2*ZZ)+1)/(EXP(2*ZZ)-1) 32 - ENDIF 33 - XXMIRR=(PI/SY)*(XPOS+X(I)-2*COPLAX) 34 - ZZMIRR=CMPLX(XXMIRR,YY) 35 - IF(XXMIRR.GT.+20)THEN 36 - ECOMPL=ECOMPL-1 37 - ELSEIF(XXMIRR.LT.-20)THEN 38 - ECOMPL=ECOMPL+1 39 - ELSE 40 - ECOMPL=ECOMPL-(EXP(2*ZZMIRR)+1)/(EXP(2*ZZMIRR)-1) 41 - ENDIF 42 - EX=EX+E(I)*(PI/SY)*REAL(ECOMPL) 43 - EY=EY-E(I)*(PI/SY)*AIMAG(ECOMPL) 44 - 10 CONTINUE 45 - *** Case the is no plane. 46 - ELSE 47 - DO 20 I=1,NWIRE 48 - IF(.NOT.CNALSO(I))GOTO 20 49 - XX=(PI/SY)*(XPOS-X(I)) 50 - YY=(PI/SY)*(YPOS-Y(I)) 51 - ZZ=CMPLX(XX,YY) 52 - IF(XX.GT.+20)THEN 53 - ECOMPL=+1 54 - ELSEIF(XX.LT.-20)THEN 55 - ECOMPL=-1 56 - ELSE 57 - ECOMPL=(EXP(2*ZZ)+1)/(EXP(2*ZZ)-1) 58 - ENDIF 59 - EX=EX+E(I)*(PI/SY)*REAL(ECOMPL) 60 - EY=EY-E(I)*(PI/SY)*AIMAG(ECOMPL) 61 - 20 CONTINUE 62 - ENDIF 63 - END 624 GARFIELD ================================================== P=FIELDCAL D=FFCB2X 1 ============================ 0 + +DECK,FFCB2X. 1 - SUBROUTINE FFCB2X(XPOS,YPOS,EX,EY) 2 - *----------------------------------------------------------------------- 3 - * FFCB2X - Routine calculating the potential for a row of alternating 4 - * + - charges. The potential used is re log(sin pi/sx (z-z0)) 5 - * VARIABLES : See routine FFCA00 for most of the variables. 6 - * Z, ZZMRR : X + i*Y , XXMIRR + i*YYMIRR ; i**2=-1 7 - * ECOMPL : EX + i*EY ; i**2=-1 8 - * (Cray vectorisable) 9 - * (Last changed on 21/ 1/97.) 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13.- +SEQ,CONSTANTS. 14 - COMPLEX ZZ,ECOMPL,ZZMIRR,ZZNEG,ZZNMIR 15 - *** Initialise EX, EY. 16 - EX=0 17 - EY=0 18 - *** Loop over all wires. 19 - DO 10 I=1,NWIRE 20 - XX=(0.5*PI/SX)*(XPOS-X(I)) 21 - YY=(0.5*PI/SX)*(YPOS-Y(I)) 22 - XXNEG=(0.5*PI/SX)*(XPOS+X(I)-2*COPLAX) 23 - ZZ=CMPLX(XX,YY) 24 - ZZNEG=CMPLX(XXNEG,YY) 25 - *** Calculate the field in case there are no equipotential planes. 26 - IF(CNALSO(I).AND.ABS(YY).LE.20)THEN 27 - ECOMPL=-B2SIN(I)/(SIN(ZZ)*SIN(ZZNEG)) 28 - ELSEIF(ABS(YY).LE.20)THEN 29 - ECOMPL=-ICONS*(EXP(2*ICONS*ZZNEG)+1)/(EXP(2*ICONS*ZZNEG)-1) 30 - ELSE 31 - ECOMPL=0 32 - ENDIF 33 - *** Take care of a planes at constant y. 34 - IF(YNPLAY)THEN 35 - YYMIRR=(0.5*PI/SX)*(YPOS+Y(I)-2*COPLAY) 36 - ZZMIRR=CMPLX(XX,YYMIRR) 37 - ZZNMIR=CMPLX(XXNEG,YYMIRR) 38 - IF(ABS(YYMIRR).LE.20) 39 - - ECOMPL=ECOMPL+B2SIN(I)/(SIN(ZZMIRR)*SIN(ZZNMIR)) 40 - ENDIF 41 - *** Calculate the electric field and the potential. 42 - EX=EX+E(I)*(0.5*PI/SX)*REAL(ECOMPL) 43 - EY=EY-E(I)*(0.5*PI/SX)*AIMAG(ECOMPL) 44 - *** Finish the wire loop. 45 - 10 CONTINUE 46 - END 625 GARFIELD ================================================== P=FIELDCAL D=FFCB2Y 1 ============================ 0 + +DECK,FFCB2Y. 1 - SUBROUTINE FFCB2Y(XPOS,YPOS,EX,EY) 2 - *----------------------------------------------------------------------- 3 - * FFCB2Y - Routine calculating the potential for a row of alternating 4 - * + - charges. The potential used is re log(sin pi/sx (z-z0)) 5 - * VARIABLES : See routine FFCA00 for most of the variables. 6 - * Z, ZMIRR : X + i*Y , XXMIRR + i*YYMIRR ; i**2=-1 1 625 P=FIELDCAL D=FFCB2Y 2 PAGE 900 7 - * ECOMPL : EX + i*EY ; i**2=-1 8 - * (Cray vectorisable) 9 - * (Last changed on 21/ 1/97.) 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13.- +SEQ,CONSTANTS. 14 - COMPLEX ZZ,ECOMPL,ZZMIRR,ZZNEG,ZZNMIR 15 - *** Initialise EX, EY. 16 - EX=0 17 - EY=0 18 - *** Loop over all wires. 19 - DO 10 I=1,NWIRE 20 - XX=(0.5*PI/SY)*(XPOS-X(I)) 21 - YY=(0.5*PI/SY)*(YPOS-Y(I)) 22 - YYNEG=(0.5*PI/SY)*(YPOS+Y(I)-2*COPLAY) 23 - ZZ=CMPLX(XX,YY) 24 - ZZNEG=CMPLX(XX,YYNEG) 25 - *** Calculate the field in case there are no equipotential planes. 26 - IF(CNALSO(I).AND.ABS(XX).LE.20)THEN 27 - ECOMPL=ICONS*B2SIN(I)/(SIN(ICONS*ZZ)*SIN(ICONS*ZZNEG)) 28 - ELSEIF(ABS(XX).LE.20)THEN 29 - ECOMPL=-(EXP(2*ZZNEG)+1)/(EXP(2*ZZNEG)-1) 30 - ELSE 31 - ECOMPL=0 32 - ENDIF 33 - *** Take care of a plane at constant x. 34 - IF(YNPLAX)THEN 35 - XXMIRR=(0.5*PI/SY)*(XPOS+X(I)-2*COPLAX) 36 - ZZMIRR=CMPLX(XXMIRR,YY) 37 - ZZNMIR=CMPLX(XXMIRR,YYNEG) 38 - IF(ABS(XXMIRR).LE.20)ECOMPL=ECOMPL- 39 - - ICONS*B2SIN(I)/(SIN(ICONS*ZZMIRR)*SIN(ICONS*ZZNMIR)) 40 - ENDIF 41 - *** Calculate the electric field and the potential. 42 - EX=EX+E(I)*(0.5*PI/SY)*REAL(ECOMPL) 43 - EY=EY-E(I)*(0.5*PI/SY)*AIMAG(ECOMPL) 44 - *** Finish the wire loop. 45 - 10 CONTINUE 46 - END 626 GARFIELD ================================================== P=FIELDCAL D=FFCC10 1 ============================ 0 + +DECK,FFCC10. 1 - SUBROUTINE FFCC10(XPOS,YPOS,EX,EY) 2 - *----------------------------------------------------------------------- 3 - * FFCC10 - Routine returning the potential and electric field. It 4 - * calls the routines PH2 and E2SUM written by G.A.Erskine. 5 - * VARIABLES : No local variables. 6 - * (Last changed on 27/ 1/96.) 7 - *----------------------------------------------------------------------- 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,CONSTANTS. 11 - COMPLEX WSUM,ZSIN,ZCOF,ZU,ZUNEW,ZTERM1,ZTERM2,ZETA 12 - *** Initial value. 13 - WSUM=0 14 - *** Loop over the wires. 15 - DO 10 J=1,NWIRE 16 - IF(.NOT.CNALSO(J))GOTO 10 17 - ZETA=ZMULT*CMPLX(XPOS-X(J),YPOS-Y(J)) 18 - IF(AIMAG(ZETA).GT.+15)THEN 19 - WSUM=WSUM-E(J)*ICONS 20 - ELSEIF(AIMAG(ZETA).LT.-15)THEN 21 - WSUM=WSUM+E(J)*ICONS 22 - ELSE 23 - ZSIN=SIN(ZETA) 24 - ZCOF=4*ZSIN**2-2 25 - ZU=-P1-ZCOF*P2 26 - ZUNEW=1-ZCOF*ZU-P2 27 - ZTERM1=(ZUNEW+ZU)*ZSIN 28 - ZU=-3*P1-ZCOF*5*P2 29 - ZUNEW=1-ZCOF*ZU-5*P2 30 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 31 - WSUM=WSUM+E(J)*(ZTERM2/ZTERM1) 32 - ENDIF 33 - 10 CONTINUE 34 - EX=-REAL(-ZMULT*WSUM) 35 - EY=AIMAG(-ZMULT*WSUM) 36 - *** Correction terms. 37 - IF(MODE.EQ.0)EX=EX-C1 38 - IF(MODE.EQ.1)EY=EY-C1 39 - END 627 GARFIELD ================================================== P=FIELDCAL D=FFCC2X 1 ============================ 0 + +DECK,FFCC2X. 1 - SUBROUTINE FFCC2X(XPOS,YPOS,EX,EY) 2 - *----------------------------------------------------------------------- 3 - * FFCC2X - Routine returning the potential and electric field in a 4 - * configuration with 2 x planes and y periodicity. 5 - * VARIABLES : see the writeup 6 - * (Last changed on 27/ 1/96.) 7 - *----------------------------------------------------------------------- 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,CONSTANTS. 11 - COMPLEX WSUM1,WSUM2,ZSIN,ZCOF,ZU,ZUNEW,ZTERM1,ZTERM2,ZETA 12 - *** Initial values. 13 - WSUM1=0 14 - WSUM2=0 15 - *** Wire loop. 16 - DO 10 I=1,NWIRE 17 - * Compute the direct contribution. 18 - IF(CNALSO(I))THEN 19 - ZETA=ZMULT*CMPLX(XPOS-X(I),YPOS-Y(I)) 1 627 P=FIELDCAL D=FFCC2X 2 PAGE 901 20 - IF(AIMAG(ZETA).GT.+15)THEN 21 - WSUM1=WSUM1-E(I)*ICONS 22 - ELSEIF(AIMAG(ZETA).LT.-15)THEN 23 - WSUM1=WSUM1+E(I)*ICONS 24 - ELSE 25 - ZSIN=SIN(ZETA) 26 - ZCOF=4*ZSIN**2-2 27 - ZU=-P1-ZCOF*P2 28 - ZUNEW=1-ZCOF*ZU-P2 29 - ZTERM1=(ZUNEW+ZU)*ZSIN 30 - ZU=-3*P1-ZCOF*5*P2 31 - ZUNEW=1-ZCOF*ZU-5*P2 32 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 33 - WSUM1=WSUM1+E(I)*(ZTERM2/ZTERM1) 34 - ENDIF 35 - ENDIF 36 - * Find the plane nearest to the wire. 37 - CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) 38 - * Mirror contribution. 39 - ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),YPOS-Y(I)) 40 - IF(AIMAG(ZETA).GT.+15)THEN 41 - WSUM2=WSUM2-E(I)*ICONS 42 - ELSEIF(AIMAG(ZETA).LT.-15)THEN 43 - WSUM2=WSUM2+E(I)*ICONS 44 - ELSE 45 - ZSIN=SIN(ZETA) 46 - ZCOF=4*ZSIN**2-2 47 - ZU=-P1-ZCOF*P2 48 - ZUNEW=1-ZCOF*ZU-P2 49 - ZTERM1=(ZUNEW+ZU)*ZSIN 50 - ZU=-3*P1-ZCOF*5*P2 51 - ZUNEW=1-ZCOF*ZU-5*P2 52 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 53 - WSUM2=WSUM2+E(I)*(ZTERM2/ZTERM1) 54 - ENDIF 55 - 10 CONTINUE 56 - *** Convert the two contributions to a real field. 57 - EX=REAL(ZMULT*(WSUM1+WSUM2)) 58 - EY=-AIMAG(ZMULT*(WSUM1-WSUM2)) 59 - *** Constant correction terms. 60 - IF(MODE.EQ.0)EX=EX-C1 61 - END 628 GARFIELD ================================================== P=FIELDCAL D=FFCC2Y 1 ============================ 0 + +DECK,FFCC2Y. 1 - SUBROUTINE FFCC2Y(XPOS,YPOS,EX,EY) 2 - *----------------------------------------------------------------------- 3 - * FFCC2Y - Routine returning the potential and electric field in a 4 - * configuration with 2 y planes and x periodicity. 5 - * VARIABLES : see the writeup 6 - * (Last changed on 27/ 1/96.) 7 - *----------------------------------------------------------------------- 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,CONSTANTS. 11 - COMPLEX WSUM1,WSUM2,ZSIN,ZCOF,ZU,ZUNEW,ZTERM1,ZTERM2,ZETA 12 - *** Initial values. 13 - WSUM1=0 14 - WSUM2=0 15 - *** Wire loop. 16 - DO 10 I=1,NWIRE 17 - * Compute the direct contribution. 18 - IF(CNALSO(I))THEN 19 - ZETA=ZMULT*CMPLX(XPOS-X(I),YPOS-Y(I)) 20 - IF(AIMAG(ZETA).GT.+15)THEN 21 - WSUM1=WSUM1-E(I)*ICONS 22 - ELSEIF(AIMAG(ZETA).LT.-15)THEN 23 - WSUM1=WSUM1+E(I)*ICONS 24 - ELSE 25 - ZSIN=SIN(ZETA) 26 - ZCOF=4*ZSIN**2-2 27 - ZU=-P1-ZCOF*P2 28 - ZUNEW=1-ZCOF*ZU-P2 29 - ZTERM1=(ZUNEW+ZU)*ZSIN 30 - ZU=-3*P1-ZCOF*5*P2 31 - ZUNEW=1-ZCOF*ZU-5*P2 32 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 33 - WSUM1=WSUM1+E(I)*(ZTERM2/ZTERM1) 34 - ENDIF 35 - ENDIF 36 - * Find the plane nearest to the wire. 37 - CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) 38 - * Mirror contribution from the y plane. 39 - ZETA=ZMULT*CMPLX(XPOS-X(I),2*CY-YPOS-Y(I)) 40 - IF(AIMAG(ZETA).GT.+15)THEN 41 - WSUM2=WSUM2-E(I)*ICONS 42 - ELSEIF(AIMAG(ZETA).LT.-15)THEN 43 - WSUM2=WSUM2+E(I)*ICONS 44 - ELSE 45 - ZSIN=SIN(ZETA) 46 - ZCOF=4*ZSIN**2-2 47 - ZU=-P1-ZCOF*P2 48 - ZUNEW=1-ZCOF*ZU-P2 49 - ZTERM1=(ZUNEW+ZU)*ZSIN 50 - ZU=-3*P1-ZCOF*5*P2 51 - ZUNEW=1-ZCOF*ZU-5*P2 52 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 53 - WSUM2=WSUM2+E(I)*(ZTERM2/ZTERM1) 54 - ENDIF 55 - 10 CONTINUE 56 - *** Convert the two contributions to a real field. 57 - EX=REAL(ZMULT*(WSUM1-WSUM2)) 58 - EY=-AIMAG(ZMULT*(WSUM1+WSUM2)) 59 - *** Constant correction terms. 60 - IF(MODE.EQ.1)EY=EY-C1 1 628 P=FIELDCAL D=FFCC2Y 2 PAGE 902 61 - END 629 GARFIELD ================================================== P=FIELDCAL D=FFCC30 1 ============================ 0 + +DECK,FFCC30. 1 - SUBROUTINE FFCC30(XPOS,YPOS,EX,EY) 2 - *----------------------------------------------------------------------- 3 - * FFCC30 - Routine returning the potential and electric field in a 4 - * configuration with 2 y and 2 x planes. 5 - * VARIABLES : see the writeup 6 - * (Last changed on 27/ 1/96.) 7 - *----------------------------------------------------------------------- 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,CONSTANTS. 11 - COMPLEX WSUM1,WSUM2,WSUM3,WSUM4,ZSIN,ZCOF,ZU,ZUNEW, 12 - - ZTERM1,ZTERM2,ZETA 13 - *** Initial values. 14 - WSUM1=0 15 - WSUM2=0 16 - WSUM3=0 17 - WSUM4=0 18 - *** Wire loop. 19 - DO 10 I=1,NWIRE 20 - * Compute the direct contribution. 21 - IF(CNALSO(I))THEN 22 - ZETA=ZMULT*CMPLX(XPOS-X(I),YPOS-Y(I)) 23 - IF(AIMAG(ZETA).GT.+15)THEN 24 - WSUM1=WSUM1-E(I)*ICONS 25 - ELSEIF(AIMAG(ZETA).LT.-15)THEN 26 - WSUM1=WSUM1+E(I)*ICONS 27 - ELSE 28 - ZSIN=SIN(ZETA) 29 - ZCOF=4*ZSIN**2-2 30 - ZU=-P1-ZCOF*P2 31 - ZUNEW=1-ZCOF*ZU-P2 32 - ZTERM1=(ZUNEW+ZU)*ZSIN 33 - ZU=-3*P1-ZCOF*5*P2 34 - ZUNEW=1-ZCOF*ZU-5*P2 35 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 36 - WSUM1=WSUM1+E(I)*(ZTERM2/ZTERM1) 37 - ENDIF 38 - ENDIF 39 - * Find the plane nearest to the wire. 40 - CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) 41 - * Mirror contribution from the x plane. 42 - ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),YPOS-Y(I)) 43 - IF(AIMAG(ZETA).GT.+15)THEN 44 - WSUM2=WSUM2-E(I)*ICONS 45 - ELSEIF(AIMAG(ZETA).LT.-15)THEN 46 - WSUM2=WSUM2+E(I)*ICONS 47 - ELSE 48 - ZSIN=SIN(ZETA) 49 - ZCOF=4*ZSIN**2-2 50 - ZU=-P1-ZCOF*P2 51 - ZUNEW=1-ZCOF*ZU-P2 52 - ZTERM1=(ZUNEW+ZU)*ZSIN 53 - ZU=-3*P1-ZCOF*5*P2 54 - ZUNEW=1-ZCOF*ZU-5*P2 55 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 56 - WSUM2=WSUM2+E(I)*(ZTERM2/ZTERM1) 57 - ENDIF 58 - * Find the plane nearest to the wire. 59 - CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) 60 - * Mirror contribution from the y plane. 61 - ZETA=ZMULT*CMPLX(XPOS-X(I),2*CY-YPOS-Y(I)) 62 - IF(AIMAG(ZETA).GT.+15)THEN 63 - WSUM3=WSUM3-E(I)*ICONS 64 - ELSEIF(AIMAG(ZETA).LT.-15)THEN 65 - WSUM3=WSUM3+E(I)*ICONS 66 - ELSE 67 - ZSIN=SIN(ZETA) 68 - ZCOF=4*ZSIN**2-2 69 - ZU=-P1-ZCOF*P2 70 - ZUNEW=1-ZCOF*ZU-P2 71 - ZTERM1=(ZUNEW+ZU)*ZSIN 72 - ZU=-3*P1-ZCOF*5*P2 73 - ZUNEW=1-ZCOF*ZU-5*P2 74 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 75 - WSUM3=WSUM3+E(I)*(ZTERM2/ZTERM1) 76 - ENDIF 77 - * Mirror contribution from both the x and the y plane. 78 - ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),2*CY-YPOS-Y(I)) 79 - IF(AIMAG(ZETA).GT.+15)THEN 80 - WSUM4=WSUM4-E(I)*ICONS 81 - ELSEIF(AIMAG(ZETA).LT.-15)THEN 82 - WSUM4=WSUM4+E(I)*ICONS 83 - ELSE 84 - ZSIN=SIN(ZETA) 85 - ZCOF=4*ZSIN**2-2 86 - ZU=-P1-ZCOF*P2 87 - ZUNEW=1-ZCOF*ZU-P2 88 - ZTERM1=(ZUNEW+ZU)*ZSIN 89 - ZU=-3*P1-ZCOF*5*P2 90 - ZUNEW=1-ZCOF*ZU-5*P2 91 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 92 - WSUM4=WSUM4+E(I)*(ZTERM2/ZTERM1) 93 - ENDIF 94 - 10 CONTINUE 95 - *** Convert the two contributions to a real field. 96 - EX=+REAL(ZMULT*(WSUM1+WSUM2-WSUM3-WSUM4)) 97 - EY=-AIMAG(ZMULT*(WSUM1-WSUM2+WSUM3-WSUM4)) 98 - END 1 630 GARFIELD ================================================== P=FIELDCAL D=FFCD10 1 =================== PAGE 903 0 + +DECK,FFCD10. 1 - SUBROUTINE FFCD10(XPOS,YPOS,EX,EY) 2 - *----------------------------------------------------------------------- 3 - * FFCD10 - Subroutine performing the actual field calculations for a 4 - * cell which has a one circular plane and some wires. 5 - * VARIABLES : EX, EY : Electric field. 6 - * ETOT : Magnitude of electric field. 7 - * (XPOS,YPOS): The position where the field is calculated. 8 - * ZI, ZPOS : Shorthand complex notations. 9 - * (Last changed on 2/ 3/97.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,CELLDATA. 14 - INTEGER I 15 - REAL XPOS,YPOS,EX,EY 16 - COMPLEX ZI,ZPOS 17 - *** Initialise the potential and the electric field. 18 - EX=0 19 - EY=0 20 - * Set the complex position coordinates. 21 - ZPOS=CMPLX(XPOS,YPOS) 22 - *** Loop over all wires. 23 - DO 10 I=1,NWIRE 24 - * Set the complex version of the wire-coordinate for simplicity. 25 - ZI=CMPLX(X(I),Y(I)) 26 - * First the case that the wire has to be taken fully. 27 - IF(CNALSO(I))THEN 28 - EX=EX+E(I)*REAL(1/CONJG(ZPOS-ZI)+ 29 - - ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) 30 - EY=EY+E(I)*AIMAG(1/CONJG(ZPOS-ZI)+ 31 - - ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) 32 - * Otherwise only take the mirror charge. 33 - ELSE 34 - EX=EX+E(I)*REAL(ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) 35 - EY=EY+E(I)*AIMAG(ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) 36 - ENDIF 37 - *** Finish the loop over the wires. 38 - 10 CONTINUE 39 - END 631 GARFIELD ================================================== P=FIELDCAL D=FFCD20 1 ============================ 0 + +DECK,FFCD20. 1 - SUBROUTINE FFCD20(XPOS,YPOS,EX,EY) 2 - *----------------------------------------------------------------------- 3 - * FFCD20 - Subroutine performing the actual field calculations for a 4 - * cell which has a tube and phi periodicity. 5 - * VARIABLES : EX, EY : Electric field. 6 - * ETOT : Magnitude of electric field. 7 - * (XPOS,YPOS): The position where the field is calculated. 8 - * ZI, ZPOS : Shorthand complex notations. 9 - * (Last changed on 2/ 3/97.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,CELLDATA. 14 - REAL XPOS,YPOS,EX,EY 15 - INTEGER I 16 - COMPLEX ZI,ZPOS 17 - *** Initialise the potential and the electric field. 18 - EX=0 19 - EY=0 20 - * Set the complex position coordinates. 21 - ZPOS=CMPLX(XPOS,YPOS) 22 - *** Loop over all wires. 23 - DO 10 I=1,NWIRE 24 - * Set the complex version of the wire-coordinate for simplicity. 25 - ZI=CMPLX(X(I),Y(I)) 26 - IF(CNALSO(I))THEN 27 - * Case of the wire which is not in the centre. 28 - IF(ABS(ZI).GT.D(I)/2)THEN 29 - EX=EX+E(I)*REAL(MTUBE*CONJG(ZPOS)**(MTUBE-1)* 30 - - (1/CONJG(ZPOS**MTUBE-ZI**MTUBE)+ZI**MTUBE/ 31 - - (COTUBE**(2*MTUBE)-(CONJG(ZPOS)*ZI)**MTUBE))) 32 - EY=EY+E(I)*AIMAG(MTUBE*CONJG(ZPOS)**(MTUBE-1)* 33 - - (1/CONJG(ZPOS**MTUBE-ZI**MTUBE)+ZI**MTUBE/ 34 - - (COTUBE**(2*MTUBE)-(CONJG(ZPOS)*ZI)**MTUBE))) 35 - * Regular case of the off-centre wire. 36 - ELSE 37 - EX=EX+E(I)*REAL(1/CONJG(ZPOS-ZI)+ZI/ 38 - - (COTUBE**2-CONJG(ZPOS)*ZI)) 39 - EY=EY+E(I)*AIMAG(1/CONJG(ZPOS-ZI)+ZI/ 40 - - (COTUBE**2-CONJG(ZPOS)*ZI)) 41 - ENDIF 42 - ELSE 43 - * Case of the wire which is not in the centre. 44 - IF(ABS(ZI).GT.D(I)/2)THEN 45 - EX=EX+E(I)*REAL(MTUBE*CONJG(ZPOS)**(MTUBE-1)* 46 - - (ZI**MTUBE/(COTUBE**(2*MTUBE)- 47 - - (CONJG(ZPOS)*ZI)**MTUBE))) 48 - EY=EY+E(I)*AIMAG(MTUBE*CONJG(ZPOS)**(MTUBE-1)* 49 - - (ZI**MTUBE/(COTUBE**(2*MTUBE)- 50 - - (CONJG(ZPOS)*ZI)**MTUBE))) 51 - * Regular case of the off-centre wire. 52 - ELSE 53 - EX=EX+E(I)*REAL(ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) 54 - EY=EY+E(I)*AIMAG(ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) 55 - ENDIF 56 - ENDIF 57 - *** Finish the loop over the wires. 58 - 10 CONTINUE 59 - END 1 632 GARFIELD ================================================== P=FIELDCAL D=FFCD30 1 =================== PAGE 904 0 + +DECK,FFCD30. 1 - SUBROUTINE FFCD30(XPOS,YPOS,EX,EY) 2 - *----------------------------------------------------------------------- 3 - * FFCD30 - Subroutine performing the actual field calculations for a 4 - * cell which has a polygon as tube and some wires. 5 - * VARIABLES : EX, EY : Electric field. 6 - * ETOT : Magnitude of electric field. 7 - * (XPOS,YPOS): The position where the field is calculated. 8 - * ZI, ZPOS : Shorthand complex notations. 9 - * (Last changed on 2/ 3/97.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,CELLDATA. 14 - REAL XPOS,YPOS,EX,EY 15 - INTEGER I 16 - COMPLEX WPOS,WDPOS 17 - *** Initialise the potential and the electric field. 18 - EX=0 19 - EY=0 20 - * Get the mapping of the position. 21 - CALL EFCMAP(CMPLX(XPOS,YPOS)/COTUBE,WPOS,WDPOS) 22 - *** Loop over all wires. 23 - DO 10 I=1,NWIRE 24 - * Full contribution. 25 - IF(CNALSO(I))THEN 26 - EX=EX+(E(I)/COTUBE)*REAL(WDPOS*(1-ABS(WMAP(I))**2)/ 27 - - ((WPOS-WMAP(I))*(1-CONJG(WMAP(I))*WPOS))) 28 - EY=EY-(E(I)/COTUBE)*AIMAG(WDPOS*(1-ABS(WMAP(I))**2)/ 29 - - ((WPOS-WMAP(I))*(1-CONJG(WMAP(I))*WPOS))) 30 - * Mirror charges only. 31 - ELSE 32 - EX=EX+(E(I)/COTUBE)*REAL(WDPOS*CONJG(WMAP(I))/ 33 - - (1-CONJG(WMAP(I))*WPOS)) 34 - EY=EY-(E(I)/COTUBE)*AIMAG(WDPOS*CONJG(WMAP(I))/ 35 - - (1-CONJG(WMAP(I))*WPOS)) 36 - ENDIF 37 - *** Finish the loop over the wires. 38 - 10 CONTINUE 39 - END 633 GARFIELD ================================================== P=FIELDCAL D=EFMWIR 1 ============================ 0 + +DECK,EFMWIR. 1 - SUBROUTINE EFMWIR 2 - *----------------------------------------------------------------------- 3 - * EFMWIR - Computes the dipole moment of a given wire. 4 - * (Last changed on 11/ 6/96.) 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,CELLDATA. 8.- +SEQ,CONSTANTS. 9.- +SEQ,PRINTPLOT. 10.- +SEQ,BFIELD. 11 - INTEGER NPOLE,NPOLER,NPOLES,NITMAX,I,IFAIL,INEXT,IW,NCFUN, 12 - - IWR 13 - COMMON /EFMDAT/ NPOLE 14 - PARAMETER(N=MXFPNT) 15 - CHARACTER*(MXCHAR) FUN 16 - CHARACTER*20 AUX 17 - CHARACTER*10 VARLIS(MXVAR) 18 - REAL PHI0(MXPOLE),POLE(MXPOLE),XPL(MXLIST),YPL(MXLIST), 19 - - VAR(MXVAR),RES(1),DRES,VLTMIN,VLTMAX,VLTAVE,RMULT, 20 - - RMULTR,EPSR 21 - DOUBLE PRECISION PAR(1+2*MXPOLE),ANGLE(N),VOLT(N),WEIGHT(N), 22 - - DIST,CHI2,EPS,DAUX,PARRES(1+2*MXPOLE),EPAR(1+2*MXPOLE) 23 - LOGICAL LFITPR,LFITPL,USE(MXVAR) 24 - INTEGER MODVAR(MXVAR),MODRES(1) 25 - EXTERNAL EFMFUN 0 26-+ +SELF,IF=SAVE. 27 - SAVE IW,RMULT,NPOLES,NITMAX,EPS,LFITPR,LFITPL,VARLIS 0 28-+ +SELF. 29 - DATA IW/0/, RMULT/1.0/, NPOLES/4/, NITMAX/20/, EPS/1.0E-4/, 30 - - LFITPR/.FALSE./, LFITPL/.FALSE./ 31 - DATA (VARLIS(I),I=1,9) / 32 - - 'ANGLE ','EX ','EY ','E ', 33 - - 'V ','BX ','BY ','BZ ', 34 - - 'B '/ 35 - *** Assume the routine fails. 36 - IFAIL=1 37 - *** Special default handling for NPOLE which is in common. 38 - NPOLE=NPOLES 39 - *** Default function. 40 - FUN='V' 41 - NCFUN=1 42 - *** Decode the argument string, get the number of words. 43 - CALL INPNUM(NWORD) 44 - INEXT=2 45 - * Loop over the string. 46 - DO 100 I=2,NWORD 47 - IF(I.LT.INEXT)GOTO 100 48 - * Epsilon for fitting purposes. 49 - IF(INPCMP(I,'EPS#ILON').NE.0)THEN 50 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN 51 - CALL INPMSG(I,'Should have an argument. ') 52 - ELSE 53 - CALL INPCHK(I+1,2,IFAIL) 54 - CALL INPRDR(I+1,EPSR,0.0) 55 - IF(EPSR.LE.0.0.AND.IFAIL.EQ.0)THEN 56 - CALL INPMSG(I,'Epsilon must be positive. ') 57 - ELSEIF(IFAIL.EQ.0)THEN 58 - EPS=EPSR 59 - ENDIF 60 - INEXT=I+2 1 633 P=FIELDCAL D=EFMWIR 2 PAGE 905 61 - ENDIF 62 - * Function to be treated. 63 - ELSEIF(INPCMP(I,'F#UNCTION').NE.0)THEN 64 - IF(NWORD.LT.I+1)THEN 65 - CALL INPMSG(I,'Should have an argument. ') 66 - ELSE 67 - CALL INPSTR(I+1,I+1,FUN,NCFUN) 68 - INEXT=I+2 69 - ENDIF 70 - * Maximum number of iterations. 71 - ELSEIF(INPCMP(I,'I#TERATE-#MAXIMUM').NE.0)THEN 72 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN 73 - CALL INPMSG(I,'Should have an argument. ') 74 - ELSE 75 - CALL INPCHK(I+1,1,IFAIL) 76 - CALL INPRDI(I+1,NITMAR,0) 77 - IF(NITMAR.LT.0.AND.IFAIL.EQ.0)THEN 78 - CALL INPMSG(I,'Number of iterations < 0. ') 79 - ELSEIF(IFAIL.EQ.0)THEN 80 - NITMAX=NITMAR 81 - ENDIF 82 - INEXT=I+2 83 - ENDIF 84 - * Highest multipole order. 85 - ELSEIF(INPCMP(I,'O#RDER').NE.0)THEN 86 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN 87 - CALL INPMSG(I,'Should have an argument. ') 88 - ELSE 89 - CALL INPCHK(I+1,1,IFAIL) 90 - CALL INPRDI(I+1,NPOLER,0) 91 - IF((NPOLER.LE.0.OR.NPOLER.GT.MXPOLE).AND. 92 - - IFAIL.EQ.0)THEN 93 - CALL INPMSG(I,'Multipole order out of range. ') 94 - ELSEIF(IFAIL.EQ.0)THEN 95 - NPOLE=NPOLER 96 - ENDIF 97 - INEXT=I+2 98 - ENDIF 99 - * Number of radii. 100 - ELSEIF(INPCMP(I,'R#ADIUS').NE.0)THEN 101 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN 102 - CALL INPMSG(I,'Should have an argument. ') 103 - ELSE 104 - CALL INPCHK(I+1,2,IFAIL) 105 - CALL INPRDR(I+1,RMULTR,0.0) 106 - IF(RMULTR.LE.0.0.AND.IFAIL.EQ.0)THEN 107 - CALL INPMSG(I,'Wire number out of range. ') 108 - ELSEIF(IFAIL.EQ.0)THEN 109 - RMULT=RMULTR 110 - ENDIF 111 - INEXT=I+2 112 - ENDIF 113 - * Print/Plot options. 114 - ELSEIF(INPCMP(I,'PL#OT').NE.0)THEN 115 - LFITPL=.TRUE. 116 - ELSEIF(INPCMP(I,'NOPL#OT').NE.0)THEN 117 - LFITPL=.FALSE. 118 - ELSEIF(INPCMP(I,'PR#INT').NE.0)THEN 119 - LFITPR=.TRUE. 120 - ELSEIF(INPCMP(I,'NOPR#INT').NE.0)THEN 121 - LFITPR=.FALSE. 122 - * Wire number. 123 - ELSEIF(INPCMP(I,'W#IRE').NE.0)THEN 124 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN 125 - CALL INPMSG(I,'Should have an argument. ') 126 - ELSE 127 - CALL INPCHK(I+1,1,IFAIL) 128 - CALL INPRDI(I+1,IWR,0) 129 - IF((IWR.LE.0.OR.IWR.GT.NWIRE).AND.IFAIL.EQ.0)THEN 130 - CALL INPMSG(I,'Wire number out of range. ') 131 - ELSEIF(IFAIL.EQ.0)THEN 132 - IW=IWR 133 - ENDIF 134 - INEXT=I+2 135 - ENDIF 136 - * Anything else. 137 - ELSE 138 - CALL INPMSG(I,'Not a known keyword; ignored. ') 139 - ENDIF 140 - 100 CONTINUE 141 - CALL INPERR 142 - *** Keep track of the default value for NPOLE. 143 - NPOLES=NPOLE 144 - *** Check the wire number again (cell change). 145 - IF(IW.LE.0.OR.IW.GT.NWIRE)THEN 146 - PRINT *,' !!!!!! EFMWIR WARNING : The wire number is not'// 147 - - ' within range (0 -> number of wires).' 148 - RETURN 149 - ENDIF 150 - *** Print the parameter settings. 151 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ EFMWIR DEBUG : Parameter'', 152 - - '' settings:'',// 153 - - 5X,''Fit will be done for wire: '',I3,/, 154 - - 5X,''Function to be fitted: '',A,/, 155 - - 5X,''Highest multipole term fitted: '',I3,/, 156 - - 5X,''Radius multiplication factor: '',E15.8,/, 157 - - 5X,''Maximum number of iterations: '',I3,/, 158 - - 5X,''Epsilon for fitting purposes: '',E15.8,/, 159 - - 5X,''Plotting: '',L1,'', Printing: '',L1,/)') 160 - - IW,FUN(1:NCFUN),NPOLE,RMULT,NITMAX,EPS,LFITPL,LFITPR 161 - *** Set the radius of the wire to 0. 162 - DRES=D(IW) 163 - D(IW)=0.0 164 - *** Translate the function. 165 - IF(INDEX(FUN(1:NCFUN),'@').NE.0)THEN 166 - NRES=0 1 633 P=FIELDCAL D=EFMWIR 3 PAGE 906 167 - CALL ALGEDT(VARLIS,9,IENTRY,USE,NRES) 168 - FUN='Edited function' 169 - NCFUN=15 170 - IF(NRES.NE.1)THEN 171 - PRINT *,' !!!!!! EFMWIR WARNING : The edited'// 172 - - ' instruction list does not return 1 result;'// 173 - - ' no fit.' 174 - CALL ALGCLR(IENTRY) 175 - RETURN 176 - ENDIF 177 - ELSE 178 - CALL ALGPRE(FUN,NCFUN,VARLIS,9,NRES,USE,IENTRY,IFAIL) 179 - IF(IFAIL.NE.0)THEN 180 - PRINT *,' !!!!!! EFMWIR WARNING : The function '// 181 - - FUN(1:NCFUN)//' is not fitted because of'// 182 - - ' syntax error(s).' 183 - CALL ALGCLR(IENTRY) 184 - RETURN 185 - ELSEIF(NRES.NE.1)THEN 186 - PRINT *,' !!!!!! EFMWIR WARNING : The function'// 187 - - ' does not return 1 result; no fit performed.' 188 - CALL ALGCLR(IENTRY) 189 - RETURN 190 - ENDIF 191 - ENDIF 192 - * Check use of variables. 193 - IF((.NOT.MAGOK).AND.(USE(6).OR.USE(7).OR.USE(8).OR.USE(9)))THEN 194 - PRINT *,' !!!!!! EFMWIR WARNING : The function relies on'// 195 - - ' a magnetic field, which is not defined.' 196 - CALL ALGCLR(IENTRY) 197 - RETURN 198 - ENDIF 199 - *** Loop around the wire. 200 - VLTMIN=0.0 201 - VLTMAX=0.0 202 - VLTAVE=0.0 203 - DO 10 I=1,N 204 - * Set angle around wire. 205 - ANGLE(I)=2*PI*REAL(I)/REAL(N) 206 - * Set up variable list. 207 - VAR(1)=ANGLE(I) 208 - * Compute E field, make sure the point is in a free region. 209 - IF(USE(2).OR.USE(3).OR.USE(4).OR.USE(5))THEN 210 - CALL EFIELD(REAL(X(IW)+RMULT*DRES*COS(ANGLE(I))/2), 211 - - REAL(Y(IW)+RMULT*DRES*SIN(ANGLE(I))/2),0.0, 212 - - VAR(2),VAR(3),EZ,VAR(4),VAR(5),1,ILOC) 213 - IF(ILOC.NE.0)THEN 214 - PRINT *,' !!!!!! EFMWIR WARNING : Unexpected'// 215 - - ' location code received from EFIELD ;'// 216 - - ' computation stopped.' 217 - GOTO 3000 218 - ENDIF 219 - ENDIF 220 - * Compute B field. 221 - IF(USE(6).OR.USE(7).OR.USE(8).OR.USE(9)) 222 - - CALL BFIELD(REAL(X(IW)+RMULT*DRES*COS(ANGLE(I))/2), 223 - - REAL(Y(IW)+RMULT*DRES*SIN(ANGLE(I))/2),0.0, 224 - - VAR(6),VAR(7),VAR(8),VAR(9)) 225 - * Assign the variable modes. 226 - DO 120 J=1,9 227 - MODVAR(J)=2 228 - 120 CONTINUE 229 - * Evaluate the function. 230 - CALL ALGEXE(IENTRY,VAR,MODVAR,9,RES,MODRES,1,IFAIL) 231 - IF(IFAIL.NE.0)THEN 232 - PRINT *,' !!!!!! EFMWIR WARNING : Algebra error'// 233 - - ' evaluating the function at the angle',ANGLE(I) 234 - GOTO 3000 235 - ELSEIF(MODVAR(1).NE.2)THEN 236 - PRINT *,' !!!!!! EFMWIR WARNING : The result of the'// 237 - - ' function is not a number at the angle',ANGLE(I) 238 - GOTO 3000 239 - ENDIF 240 - * Assign the result to the fitting array. 241 - VOLT(I)=RES(1) 242 - * Set weighting function to 1. 243 - WEIGHT(I)=1 244 - * Keep track of the maximum, minimum and average. 245 - IF(I.EQ.1)THEN 246 - VLTMAX=VOLT(I) 247 - VLTMIN=VOLT(I) 248 - ELSE 249 - IF(VLTMAX.LT.VOLT(I))VLTMAX=VOLT(I) 250 - IF(VLTMIN.GT.VOLT(I))VLTMIN=VOLT(I) 251 - ENDIF 252 - VLTAVE=VLTAVE+VOLT(I) 253 - 10 CONTINUE 254 - * Subtract the wire potential to put centre the data more or less. 255 - VLTAVE=VLTAVE/REAL(N) 256 - DO 50 I=1,N 257 - VOLT(I)=VOLT(I)-VLTAVE 258 - 50 CONTINUE 259 - VLTMAX=VLTMAX-VLTAVE 260 - VLTMIN=VLTMIN-VLTAVE 261 - *** Perform the fit. 262 - CHI2=1E-6*N*(ABS(VLTMIN)+ABS(VLTMAX))**2/4 263 - DIST=1E-3*(2.0+ABS(VLTMIN)+ABS(VLTMAX))/2 264 - PAR(1)=(VLTMAX+VLTMIN)/2 265 - DO 30 I=1,NPOLE 266 - PAR(2*I)=(VLTMAX-VLTMIN)/2 267 - PAR(2*I+1)=0.0 268 - 30 CONTINUE 269 - CALL LSQFIT(EFMFUN,PAR,EPAR,2*NPOLE+1,ANGLE,VOLT,WEIGHT,N, 270 - - NITMAX,DIST,CHI2,EPS,LFITPR,IFAIL) 271 - IF(IFAIL.NE.0)THEN 272 - PRINT *,' !!!!!! EFMWIR WARNING : The procedure fitting'// 1 633 P=FIELDCAL D=EFMWIR 4 PAGE 907 273 - - ' the multipole failed ; computation stopped.' 274 - GOTO 3000 275 - ENDIF 276 - *** Plot the result of the fit. 277 - IF(LFITPL)THEN 278 - * Frame with data curve. 279 - CALL GRGRP2(ANGLE,VOLT,N, 280 - - 'Angle around the wire [rad]', 281 - - FUN(1:NCFUN)//' - average', 282 - - 'MULTIPOLE FIT FOR A WIRE') 283 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 284 - CALL OUTFMT(REAL(IW),2,AUX,NC,'LEFT') 285 - CALL GRCOMM(3,'Wire '//AUX(1:NC)//', type '// 286 - - WIRTYP(IW)) 287 - CALL OUTFMT(RMULT,2,AUX,NC,'LEFT') 288 - CALL GRCOMM(4,'Distance: '//AUX(1:NC)//' radii') 289 - * Sum of contributions. 290 - DO 20 I=1,MXLIST 291 - XPL(I)=2*PI*REAL(I)/REAL(MXLIST) 292 - CALL EFMFUN(DBLE(XPL(I)),PAR,DAUX) 293 - YPL(I)=REAL(DAUX) 294 - 20 CONTINUE 295 - CALL GRATTS('FUNCTION-2','POLYLINE') 296 - CALL GRLINE(MXLIST,XPL,YPL) 297 - * Individual contributions. 298 - CALL GRATTS('FUNCTION-3','POLYLINE') 299 - DO 70 I=1,2*NPOLE+1 300 - PARRES(I)=PAR(I) 301 - IF(2*(I/2).EQ.I)PARRES(I)=0 302 - 70 CONTINUE 303 - DO 80 J=1,NPOLE 304 - PARRES(2*J)=PAR(2*J) 305 - DO 90 I=1,MXLIST 306 - CALL EFMFUN(DBLE(XPL(I)),PARRES,DAUX) 307 - YPL(I)=REAL(DAUX) 308 - 90 CONTINUE 309 - PARRES(2*J)=0 310 - CALL GRLINE(MXLIST,XPL,YPL) 311 - 80 CONTINUE 312 - CALL GRNEXT 313 - CALL GRALOG('Multipole fit around a wire: ') 314 - ENDIF 315 - *** Remove radial terms from the multipole moments. 316 - DO 40 I=1,NPOLE 317 - POLE(I)=(RMULT*DRES/2)**I*PAR(2*I) 318 - PHI0(I)=180*MOD(REAL(PAR(2*I+1)),PI)/PI 319 - 40 CONTINUE 320 - *** Print the results. 321 - WRITE(LUNOUT,'('' Multipole moments for wire '',I3,'':''// 322 - - '' Moment Value Angle''/ 323 - - '' - - [degree]''/)') IW 324 - WRITE(LUNOUT,'(2X,I6,2X,E15.8,8X,''Arbitrary'')') 0,VLTAVE 325 - DO 60 I=1,NPOLE 326 - WRITE(LUNOUT,'(2X,I6,2X,E15.8,2X,E15.8)') I,POLE(I),PHI0(I) 327 - 60 CONTINUE 328 - WRITE(LUNOUT,'('' '')') 329 - *** Restore the wire diameter. 330 - 3000 CONTINUE 331 - D(IW)=DRES 332 - CALL ALGERR 333 - CALL ALGCLR(IENTRY) 334 - END 634 GARFIELD ================================================== P=FIELDCAL D=EFMFUN 1 ============================ 0 + +DECK,EFMFUN. 1 - SUBROUTINE EFMFUN(ANGLE,PAR,VALUE) 2 - *----------------------------------------------------------------------- 3 - * EFMFUN - Function used by the dipole moment calculting routine, is 4 - * called from the LSQFIT routine. 5 - * (Last changed on 3/12/90.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8 - COMMON /EFMDAT/ NPOLE 9 - DOUBLE PRECISION ANGLE,PAR(1+2*MXPOLE),VALUE 10 - REAL P(0:MXPOLE) 11 - *** Sum the series, initial value is the monopole term. 12 - VALUE=PAR(1) 13 - DO 10 I=1,NPOLE 14 - * Obtain the Legendre polynomial of this order. 15 - CALL ASLGF(2,REAL(COS(ANGLE-PAR(2*I+1))),0,I,P) 16 - * Add to the series. 17 - VALUE=VALUE+PAR(2*I)*P(I) 18 - 10 CONTINUE 19 - END 635 GARFIELD ================================================== P=FIELDCAL D=BFIELD 1 ============================ 0 + +DECK,BFIELD. 1 - SUBROUTINE BFIELD(XIN,YIN,ZIN,BX,BY,BZ,BTOT) 2 - *----------------------------------------------------------------------- 3 - * BFIELD - Subroutine returning the magnetic field at (X1,Y1) 4 - * it calls -depending on the type of periodicity one of the 5 - * routines MAG00, MAGX0, MAG0Y or MAGXY. 6 - * VARIABLES : XIN,YIN,ZIN : Point where the B field is requested. 7 - * (Last changed on 25/ 2/00.) 8 - *----------------------------------------------------------------------- 9 - implicit none 10.- +SEQ,DIMENSIONS. 11.- +SEQ,CELLDATA. 12.- +SEQ,BFIELD. 13 - REAL XIN,YIN,ZIN,BX,BY,BZ,BTOT,XPOS,YPOS,VAR(3),RES(1) 14 - INTEGER ILOC,MODVAR(3),NVAR,MODRES(1),NREXP,IFAIL, 15 - - ISB0X,ISV0X,ISB0Y,ISV0Y,ISB0Z,ISV0Z 16 - *** Computed field (0: absent, 1: constant, 2: formula, 3: table) 17 - IF(MAGSRC.EQ.1)THEN 1 635 P=FIELDCAL D=BFIELD 2 PAGE 908 18 - ** Compute Bx. 19 - IF(POLAR)THEN 20 - BX=0 21 - ELSEIF(IBXTYP.EQ.0)THEN 22 - BX=0 23 - ELSEIF(IBXTYP.EQ.1)THEN 24 - BX=B0X 25 - ELSEIF(IBXTYP.EQ.2)THEN 26 - VAR(1)=XIN 27 - VAR(2)=YIN 28 - VAR(3)=ZIN 29 - MODVAR(1)=2 30 - MODVAR(2)=2 31 - MODVAR(3)=2 32 - NVAR=3 33 - NREXP=1 34 - CALL ALGEXE(IENB0X,VAR,MODVAR,NVAR,RES,MODRES,NREXP, 35 - - IFAIL) 36 - IF(IFAIL.EQ.0.AND.MODRES(1).EQ.2)THEN 37 - BX=RES(1) 38 - ELSE 39 - BX=0 40 - ENDIF 41 - ELSEIF(IBXTYP.EQ.3)THEN 42 - IF(IBXDIR.EQ.1)THEN 43 - VAR(1)=XIN 44 - ELSEIF(IBXDIR.EQ.2)THEN 45 - VAR(1)=YIN 46 - ELSEIF(IBXDIR.EQ.3)THEN 47 - VAR(1)=ZIN 48 - ENDIF 49 - ISB0X=0 50 - ISV0X=0 51 - CALL MATIN1(IRV0X,IRB0X,1,VAR,RES,ISV0X,ISB0X,2,IFAIL) 52 - IF(IFAIL.EQ.0)THEN 53 - BX=RES(1) 54 - ELSE 55 - BX=0 56 - ENDIF 57 - ENDIF 58 - ** Compute By. 59 - IF(POLAR)THEN 60 - BY=0 61 - ELSEIF(IBYTYP.EQ.0)THEN 62 - BY=0 63 - ELSEIF(IBYTYP.EQ.1)THEN 64 - BY=B0Y 65 - ELSEIF(IBYTYP.EQ.2)THEN 66 - VAR(1)=XIN 67 - VAR(2)=YIN 68 - VAR(3)=ZIN 69 - MODVAR(1)=2 70 - MODVAR(2)=2 71 - MODVAR(3)=2 72 - NVAR=3 73 - NREXP=1 74 - CALL ALGEXE(IENB0Y,VAR,MODVAR,NVAR,RES,MODRES,NREXP, 75 - - IFAIL) 76 - IF(IFAIL.EQ.0.AND.MODRES(1).EQ.2)THEN 77 - BY=RES(1) 78 - ELSE 79 - BY=0 80 - ENDIF 81 - ELSEIF(IBYTYP.EQ.3)THEN 82 - IF(IBYDIR.EQ.1)THEN 83 - VAR(1)=XIN 84 - ELSEIF(IBYDIR.EQ.2)THEN 85 - VAR(1)=YIN 86 - ELSEIF(IBYDIR.EQ.3)THEN 87 - VAR(1)=ZIN 88 - ENDIF 89 - ISB0Y=0 90 - ISV0Y=0 91 - CALL MATIN1(IRV0Y,IRB0Y,1,VAR,RES,ISV0Y,ISB0Y,2,IFAIL) 92 - IF(IFAIL.EQ.0)THEN 93 - BY=RES(1) 94 - ELSE 95 - BY=0 96 - ENDIF 97 - ENDIF 98 - ** Compute Bz. 99 - IF(IBZTYP.EQ.0)THEN 100 - BZ=0 101 - ELSEIF(IBZTYP.EQ.1)THEN 102 - BZ=B0Z 103 - ELSEIF(IBZTYP.EQ.2)THEN 104 - VAR(1)=XIN 105 - VAR(2)=YIN 106 - VAR(3)=ZIN 107 - MODVAR(1)=2 108 - MODVAR(2)=2 109 - MODVAR(3)=2 110 - NVAR=3 111 - NREXP=1 112 - CALL ALGEXE(IENB0Z,VAR,MODVAR,NVAR,RES,MODRES,NREXP, 113 - - IFAIL) 114 - IF(IFAIL.EQ.0.AND.MODRES(1).EQ.2)THEN 115 - BZ=RES(1) 116 - ELSE 117 - BZ=0 118 - ENDIF 119 - ELSEIF(IBZTYP.EQ.3)THEN 120 - IF(IBZDIR.EQ.1)THEN 121 - VAR(1)=XIN 122 - ELSEIF(IBZDIR.EQ.2)THEN 123 - VAR(1)=YIN 1 635 P=FIELDCAL D=BFIELD 3 PAGE 909 124 - ELSEIF(IBZDIR.EQ.3)THEN 125 - VAR(1)=ZIN 126 - ENDIF 127 - ISB0Z=0 128 - ISV0Z=0 129 - CALL MATIN1(IRV0Z,IRB0Z,1,VAR,RES,ISV0Z,ISB0Z,2,IFAIL) 130 - IF(IFAIL.EQ.0)THEN 131 - BZ=RES(1) 132 - ELSE 133 - BZ=0 134 - ENDIF 135 - ENDIF 136 - ** Combined treatment if the wire distortion is taken into account. 137 - IF(IBXTYP.EQ.1.AND.IBYTYP.EQ.1.AND.IBZTYP.EQ.1.AND. 138 - - ALFA.NE.0)THEN 139 - * Reduce the coordinates in case of a periodic cell. 140 - IF(PERX)THEN 141 - XPOS=XIN-SX*ANINT(XIN/SX) 142 - ELSE 143 - XPOS=XIN 144 - ENDIF 145 - IF(PERY)THEN 146 - YPOS=YIN-SY*ANINT(YIN/SY) 147 - ELSE 148 - YPOS=YIN 149 - ENDIF 150 - * Next have the components of the field calculated. 151 - IF(.NOT.PERX.AND..NOT.PERY)CALL MAG00(XPOS,YPOS,BX,BY) 152 - IF( PERX.AND..NOT.PERY)CALL MAGX0(XPOS,YPOS,BX,BY) 153 - IF(.NOT.PERX.AND. PERY)CALL MAG0Y(XPOS,YPOS,BX,BY) 154 - IF( PERX.AND. PERY)CALL MAGXY(XPOS,YPOS,BX,BY) 155 - ENDIF 156 - *** Field map: interpolation. 157 - ELSE 158 - CALL MAGFMP(XIN,YIN,ZIN,BX,BY,BZ,ILOC) 159 - ENDIF 160 - *** Scale to V.microsec/cm2. 161 - BX=BX*BSCALE 162 - BY=BY*BSCALE 163 - BZ=BZ*BSCALE 164 - *** Calculate the norm, 165 - BTOT=SQRT(BX**2+BY**2+BZ**2) 166 - END 636 GARFIELD ================================================== P=FIELDCAL D=MAG00 1 ============================ 0 + +DECK,MAG00. 1 - SUBROUTINE MAG00(XIN,YIN,BX,BY) 2 - *----------------------------------------------------------------------- 3 - * MAG00 - Routine for magnetic field calculations non-periodic cells 4 - * (Last changed on 9/ 2/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,BFIELD. 10 - INTEGER I 11 - REAL XIN,YIN,BX,BY,XPOS,YPOS,R4,B1,B2 12 - *** Loop over the wires. 13 - DO 10 I=1,NWIRE 14 - XPOS=XIN-X(I) 15 - YPOS=YIN-Y(I) 16 - R4 =(XPOS**2+YPOS**2)**2 17 - IF(R4.LT.(0.5*D(I))**4)THEN 18 - BX=BX+ALFA*B0X 19 - BY=BY+ALFA*B0Y 20 - ELSE 21 - B1=(D(I)/2)**2*(XPOS**2-YPOS**2)/R4 22 - B2=(D(I)/2)**2*(2*XPOS*YPOS)/R4 23 - BX=BX+ALFA*( B0X*B1+B0Y*B2) 24 - BY=BY+ALFA*(-B0Y*B1+B0X*B2) 25 - ENDIF 26 - 10 CONTINUE 27 - END 637 GARFIELD ================================================== P=FIELDCAL D=MAGX0 1 ============================ 0 + +DECK,MAGX0. 1 - SUBROUTINE MAGX0(XIN,YIN,BX,BY) 2 - *----------------------------------------------------------------------- 3 - * MAGX0 - Routine for magnetic field calculations x-periodic cells 4 - * (Last changed on 9/ 2/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,BFIELD. 10 - INTEGER I,J 11 - REAL XIN,YIN,BX,BY,XPOS,YPOS,R4,B1,B2 12 - *** Loop over the periods. 13 - DO 10 J=-2,2 14 - *** Loop over the wires. 15 - DO 20 I=1,NWIRE 16 - XPOS=XIN-X(I)+J*SX 17 - YPOS=YIN-Y(I) 18 - R4 =(XPOS**2+YPOS**2)**2 19 - IF(R4.LT.(0.5*D(I))**4)THEN 20 - BX=BX+ALFA*B0X 21 - BY=BY+ALFA*B0Y 22 - ELSE 23 - B1=(D(I)/2)**2*(XPOS**2-YPOS**2)/R4 24 - B2=(D(I)/2)**2*(2*XPOS*YPOS)/R4 25 - BX=BX+ALFA*( B0X*B1+B0Y*B2) 26 - BY=BY+ALFA*(-B0Y*B1+B0X*B2) 27 - ENDIF 28 - 20 CONTINUE 1 637 P=FIELDCAL D=MAGX0 2 PAGE 910 29 - 10 CONTINUE 30 - END 638 GARFIELD ================================================== P=FIELDCAL D=MAG0Y 1 ============================ 0 + +DECK,MAG0Y. 1 - SUBROUTINE MAG0Y(XIN,YIN,BX,BY) 2 - *----------------------------------------------------------------------- 3 - * MAG0Y - Routine for magnetic field calculations y-periodic cells 4 - * (Last changed on 9/ 2/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,BFIELD. 10 - INTEGER I,J 11 - REAL XIN,YIN,BX,BY,XPOS,YPOS,R4,B1,B2 12 - *** Loop over the periods. 13 - DO 10 J=-2,2 14 - *** Loop over the wires. 15 - DO 20 I=1,NWIRE 16 - XPOS=XIN-X(I) 17 - YPOS=YIN-Y(I)+J*SY 18 - R4 =(XPOS**2+YPOS**2)**2 19 - IF(R4.LT.(0.5*D(I))**4)THEN 20 - BX=BX+ALFA*B0X 21 - BY=BY+ALFA*B0Y 22 - ELSE 23 - B1=(D(I)/2)**2*(XPOS**2-YPOS**2)/R4 24 - B2=(D(I)/2)**2*(2*XPOS*YPOS)/R4 25 - BX=BX+ALFA*( B0X*B1+B0Y*B2) 26 - BY=BY+ALFA*(-B0Y*B1+B0X*B2) 27 - ENDIF 28 - 20 CONTINUE 29 - 10 CONTINUE 30 - END 639 GARFIELD ================================================== P=FIELDCAL D=MAGXY 1 ============================ 0 + +DECK,MAGXY. 1 - SUBROUTINE MAGXY(XIN,YIN,BX,BY) 2 - *----------------------------------------------------------------------- 3 - * MAGXY - Routine for magnetic field calculations (bi-periodic cells) 4 - * (Last changed on 9/ 2/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,BFIELD. 10 - INTEGER I,J,K 11 - REAL XIN,YIN,BX,BY,XPOS,YPOS,R4,B1,B2 12 - *** Loop over the periods. 13 - DO 10 K=-2,2 14 - DO 20 J=-2,2 15 - *** Loop over the wires. 16 - DO 30 I=1,NWIRE 17 - XPOS=XIN-X(I)+K*SX 18 - YPOS=YIN-Y(I)+J*SY 19 - R4 =(XPOS**2+YPOS**2)**2 20 - IF(R4.LT.(0.5*D(I))**4)THEN 21 - BX=BX+ALFA*B0X 22 - BY=BY+ALFA*B0Y 23 - ELSE 24 - B1=(D(I)/2)**2*(XPOS**2-YPOS**2)/R4 25 - B2=(D(I)/2)**2*(2*XPOS*YPOS)/R4 26 - BX=BX+ALFA*( B0X*B1+B0Y*B2) 27 - BY=BY+ALFA*(-B0Y*B1+B0X*B2) 28 - ENDIF 29 - 30 CONTINUE 30 - 20 CONTINUE 31 - 10 CONTINUE 32 - END 640 GARFIELD ================================================== P=FIELDCAL D=MAGFMP 1 ============================ 0 + +DECK,MAGFMP. 1 - SUBROUTINE MAGFMP(XIN,YIN,ZIN,BX,BY,BZ,ILOC) 2 - *----------------------------------------------------------------------- 3 - * MAGFMP - Interpolates the B field map at (XPOS,YPOS,ZPOS). 4 - * (Last changed on 30/ 4/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,FIELDMAP. 9.- +SEQ,CELLDATA. 10.- +SEQ,CONSTANTS. 11 - REAL XIN,YIN,ZIN,XPOS,YPOS,ZPOS,BX,BY,BZ,XNEW,YNEW,ZNEW, 12 - - T1,T2,T3,T4,AUXPHI,AUXR,AROT,XAUX,YAUX 13 - INTEGER ILOC,IMAP,NX,NY,NZ 14 - LOGICAL MIRRX,MIRRY,MIRRZ 15 - *** Initial values. 16 - BX=0 17 - BY=0 18 - BZ=0 19 - ILOC=0 20 - XPOS=XIN 21 - YPOS=YIN 22 - ZPOS=ZIN 23 - *** First see whether we at all have a grid. 24 - IF(.NOT.MAPFLG(1))RETURN 25 - *** If chamber is periodic, reduce to the cell volume. 26 - MIRRX=.FALSE. 27 - IF(PERX)THEN 28 - XPOS=XMMIN+MOD(XPOS-XMMIN,XMMAX-XMMIN) 29 - IF(XPOS.LT.XMMIN)XPOS=XPOS+(XMMAX-XMMIN) 30 - ELSEIF(PERMX)THEN 1 640 P=FIELDCAL D=MAGFMP 2 PAGE 911 31 - XNEW=XMMIN+MOD(XPOS-XMMIN,XMMAX-XMMIN) 32 - IF(XNEW.LT.XMMIN)XNEW=XNEW+(XMMAX-XMMIN) 33 - NX=NINT((XNEW-XPOS)/(XMMAX-XMMIN)) 34 - IF(NX.NE.2*(NX/2))THEN 35 - XNEW=XMMIN+XMMAX-XNEW 36 - MIRRX=.TRUE. 37 - ENDIF 38 - XPOS=XNEW 39 - ENDIF 40 - IF(PERAX.AND.(ZPOS.NE.0.OR.YPOS.NE.0))THEN 41 - AUXR=SQRT(ZPOS**2+YPOS**2) 42 - AUXPHI=ATAN2(ZPOS,YPOS) 43 - AROT=(XAMAX-XAMIN)*ANINT((AUXPHI-0.5*(XAMIN+XAMAX))/ 44 - - (XAMAX-XAMIN)) 45 - IF(AUXPHI-AROT.LT.XAMIN)AROT=AROT-(XAMAX-XAMIN) 46 - IF(AUXPHI-AROT.GT.XAMAX)AROT=AROT+(XAMAX-XAMIN) 47 - AUXPHI=AUXPHI-AROT 48 - YPOS=AUXR*COS(AUXPHI) 49 - ZPOS=AUXR*SIN(AUXPHI) 50 - ENDIF 51 - MIRRY=.FALSE. 52 - IF(PERY)THEN 53 - YPOS=YMMIN+MOD(YPOS-YMMIN,YMMAX-YMMIN) 54 - IF(YPOS.LT.YMMIN)YPOS=YPOS+(YMMAX-YMMIN) 55 - ELSEIF(PERMY)THEN 56 - YNEW=YMMIN+MOD(YPOS-YMMIN,YMMAX-YMMIN) 57 - IF(YNEW.LT.YMMIN)YNEW=YNEW+(YMMAX-YMMIN) 58 - NY=NINT((YNEW-YPOS)/(YMMAX-YMMIN)) 59 - IF(NY.NE.2*(NY/2))THEN 60 - YNEW=YMMIN+YMMAX-YNEW 61 - MIRRY=.TRUE. 62 - ENDIF 63 - YPOS=YNEW 64 - ENDIF 65 - IF(PERAY.AND.(XPOS.NE.0.OR.ZPOS.NE.0))THEN 66 - AUXR=SQRT(XPOS**2+ZPOS**2) 67 - AUXPHI=ATAN2(XPOS,ZPOS) 68 - AROT=(YAMAX-YAMIN)*ANINT((AUXPHI-0.5*(YAMIN+YAMAX))/ 69 - - (YAMAX-YAMIN)) 70 - IF(AUXPHI-AROT.LT.YAMIN)AROT=AROT-(YAMAX-YAMIN) 71 - IF(AUXPHI-AROT.GT.YAMAX)AROT=AROT+(YAMAX-YAMIN) 72 - AUXPHI=AUXPHI-AROT 73 - ZPOS=AUXR*COS(AUXPHI) 74 - XPOS=AUXR*SIN(AUXPHI) 75 - ENDIF 76 - MIRRZ=.FALSE. 77 - IF(PERZ)THEN 78 - ZPOS=ZMMIN+MOD(ZPOS-ZMMIN,ZMMAX-ZMMIN) 79 - IF(ZPOS.LT.ZMMIN)ZPOS=ZPOS+(ZMMAX-ZMMIN) 80 - ELSEIF(PERMZ)THEN 81 - ZNEW=ZMMIN+MOD(ZPOS-ZMMIN,ZMMAX-ZMMIN) 82 - IF(ZNEW.LT.ZMMIN)ZNEW=ZNEW+(ZMMAX-ZMMIN) 83 - NZ=NINT((ZNEW-ZPOS)/(ZMMAX-ZMMIN)) 84 - IF(NZ.NE.2*(NZ/2))THEN 85 - ZNEW=ZMMIN+ZMMAX-ZNEW 86 - MIRRZ=.TRUE. 87 - ENDIF 88 - ZPOS=ZNEW 89 - ENDIF 90 - IF(PERAZ.AND.(YPOS.NE.0.OR.XPOS.NE.0))THEN 91 - AUXR=SQRT(YPOS**2+XPOS**2) 92 - AUXPHI=ATAN2(YPOS,XPOS) 93 - AROT=(ZAMAX-ZAMIN)*ANINT((AUXPHI-0.5*(ZAMIN+ZAMAX))/ 94 - - (ZAMAX-ZAMIN)) 95 - IF(AUXPHI-AROT.LT.ZAMIN)AROT=AROT-(ZAMAX-ZAMIN) 96 - IF(AUXPHI-AROT.GT.ZAMAX)AROT=AROT+(ZAMAX-ZAMIN) 97 - AUXPHI=AUXPHI-AROT 98 - XPOS=AUXR*COS(AUXPHI) 99 - YPOS=AUXR*SIN(AUXPHI) 100 - ENDIF 101 - *** Locate the point. 102 - CALL MAPIND(XPOS,YPOS,ZPOS,T1,T2,T3,T4,IMAP) 103 - IF(IMAP.LE.0.OR.IMAP.GT.NMAP)THEN 104 - ILOC=-6 105 - RETURN 106 - ENDIF 107 - *** Nbxt perform a 3-dimensional interpolation, linear ... 108 - IF((MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13).AND. 109 - - MAPORD.EQ.1)THEN 110 - IF(MAPFLG(6))BX=BXMAP(IMAP,1)*T1+BXMAP(IMAP,2)*T2+ 111 - - BXMAP(IMAP,3)*T3+BXMAP(IMAP,4)*T4 112 - IF(MAPFLG(7))BY=BYMAP(IMAP,1)*T1+BYMAP(IMAP,2)*T2+ 113 - - BYMAP(IMAP,3)*T3+BYMAP(IMAP,4)*T4 114 - IF(MAPFLG(8))BZ=BZMAP(IMAP,1)*T1+BZMAP(IMAP,2)*T2+ 115 - - BZMAP(IMAP,3)*T3+BZMAP(IMAP,4)*T4 116 - * or quadratic. 117 - ELSEIF(MAPTYP.EQ.12.AND.MAPORD.EQ.2)THEN 118 - IF(MAPFLG(6))BX= 119 - - BXMAP(IMAP,1)*T1*(2*T1-1)+BXMAP(IMAP,2)*T2*(2*T2-1)+ 120 - - BXMAP(IMAP,3)*T3*(2*T3-1)+BXMAP(IMAP,4)*T4*(2*T4-1)+ 121 - - 4*BXMAP(IMAP,5)*T1*T2+4*BXMAP(IMAP,6)*T1*T3+ 122 - - 4*BXMAP(IMAP,7)*T1*T4+4*BXMAP(IMAP,8)*T2*T3+ 123 - - 4*BXMAP(IMAP,9)*T2*T4+4*BXMAP(IMAP,10)*T3*T4 124 - IF(MAPFLG(7))BY= 125 - - BYMAP(IMAP,1)*T1*(2*T1-1)+BYMAP(IMAP,2)*T2*(2*T2-1)+ 126 - - BYMAP(IMAP,3)*T3*(2*T3-1)+BYMAP(IMAP,4)*T4*(2*T4-1)+ 127 - - 4*BYMAP(IMAP,5)*T1*T2+4*BYMAP(IMAP,6)*T1*T3+ 128 - - 4*BYMAP(IMAP,7)*T1*T4+4*BYMAP(IMAP,8)*T2*T3+ 129 - - 4*BYMAP(IMAP,9)*T2*T4+4*BYMAP(IMAP,10)*T3*T4 130 - IF(MAPFLG(8))BZ= 131 - - BZMAP(IMAP,1)*T1*(2*T1-1)+BZMAP(IMAP,2)*T2*(2*T2-1)+ 132 - - BZMAP(IMAP,3)*T3*(2*T3-1)+BZMAP(IMAP,4)*T4*(2*T4-1)+ 133 - - 4*BZMAP(IMAP,5)*T1*T2+4*BZMAP(IMAP,6)*T1*T3+ 134 - - 4*BZMAP(IMAP,7)*T1*T4+4*BZMAP(IMAP,8)*T2*T3+ 135 - - 4*BZMAP(IMAP,9)*T2*T4+4*BZMAP(IMAP,10)*T3*T4 136 - *** Or perform a 2-dimensional interpolation, linear ... 1 640 P=FIELDCAL D=MAGFMP 3 PAGE 912 137 - ELSEIF((MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3).AND. 138 - - MAPORD.EQ.1)THEN 139 - IF(MAPFLG(6))BX= 140 - - BXMAP(IMAP,1)*T1+BXMAP(IMAP,2)*T2+BXMAP(IMAP,3)*T3 141 - IF(MAPFLG(7))BY= 142 - - BYMAP(IMAP,1)*T1+BYMAP(IMAP,2)*T2+BYMAP(IMAP,3)*T3 143 - IF(MAPFLG(8))BZ= 144 - - BZMAP(IMAP,1)*T1+BZMAP(IMAP,2)*T2+BZMAP(IMAP,3)*T3 145 - * or quadratic. 146 - ELSEIF(MAPTYP.EQ.2.AND.MAPORD.EQ.2)THEN 147 - IF(MAPFLG(6))BX= 148 - - BXMAP(IMAP,1)*T1*(2*T1-1)+BXMAP(IMAP,2)*T2*(2*T2-1)+ 149 - - BXMAP(IMAP,3)*T3*(2*T3-1)+4*BXMAP(IMAP,4)*T1*T2+ 150 - - 4*BXMAP(IMAP,5)*T1*T3+4*BXMAP(IMAP,6)*T2*T3 151 - IF(MAPFLG(7))BY= 152 - - BYMAP(IMAP,1)*T1*(2*T1-1)+BYMAP(IMAP,2)*T2*(2*T2-1)+ 153 - - BYMAP(IMAP,3)*T3*(2*T3-1)+4*BYMAP(IMAP,4)*T1*T2+ 154 - - 4*BYMAP(IMAP,5)*T1*T3+4*BYMAP(IMAP,6)*T2*T3 155 - IF(MAPFLG(8))BZ= 156 - - BZMAP(IMAP,1)*T1*(2*T1-1)+BZMAP(IMAP,2)*T2*(2*T2-1)+ 157 - - BZMAP(IMAP,3)*T3*(2*T3-1)+4*BZMAP(IMAP,4)*T1*T2+ 158 - - 4*BZMAP(IMAP,5)*T1*T3+4*BZMAP(IMAP,6)*T2*T3 159 - *** Or an interpolation on a regular hbxahedron, linear. 160 - ELSEIF(MAPTYP.EQ.14)THEN 161 - IF(MAPFLG(6))BX= 162 - - BXMAP(IMAP,1)*(1-T1)*(1-T2)*(1-T3)+ 163 - - BXMAP(IMAP,2)* T1 *(1-T2)*(1-T3)+ 164 - - BXMAP(IMAP,3)* T1 * T2 *(1-T3)+ 165 - - BXMAP(IMAP,4)*(1-T1)* T2 *(1-T3)+ 166 - - BXMAP(IMAP,5)*(1-T1)*(1-T2)* T3 + 167 - - BXMAP(IMAP,6)* T1 *(1-T2)* T3 + 168 - - BXMAP(IMAP,7)* T1 * T2 * T3 + 169 - - BXMAP(IMAP,8)*(1-T1)* T2 * T3 170 - IF(MAPFLG(7))BY= 171 - - BYMAP(IMAP,1)*(1-T1)*(1-T2)*(1-T3)+ 172 - - BYMAP(IMAP,2)* T1 *(1-T2)*(1-T3)+ 173 - - BYMAP(IMAP,3)* T1 * T2 *(1-T3)+ 174 - - BYMAP(IMAP,4)*(1-T1)* T2 *(1-T3)+ 175 - - BYMAP(IMAP,5)*(1-T1)*(1-T2)* T3 + 176 - - BYMAP(IMAP,6)* T1 *(1-T2)* T3 + 177 - - BYMAP(IMAP,7)* T1 * T2 * T3 + 178 - - BYMAP(IMAP,8)*(1-T1)* T2 * T3 179 - IF(MAPFLG(8))BZ= 180 - - BZMAP(IMAP,1)*(1-T1)*(1-T2)*(1-T3)+ 181 - - BZMAP(IMAP,2)* T1 *(1-T2)*(1-T3)+ 182 - - BZMAP(IMAP,3)* T1 * T2 *(1-T3)+ 183 - - BZMAP(IMAP,4)*(1-T1)* T2 *(1-T3)+ 184 - - BZMAP(IMAP,5)*(1-T1)*(1-T2)* T3 + 185 - - BZMAP(IMAP,6)* T1 *(1-T2)* T3 + 186 - - BZMAP(IMAP,7)* T1 * T2 * T3 + 187 - - BZMAP(IMAP,8)*(1-T1)* T2 * T3 188 - *** Or an unknown case. 189 - ELSE 190 - ILOC=-10 191 - RETURN 192 - ENDIF 193 - *** Apply mirror imaging. 194 - IF(MIRRX)BX=-BX 195 - IF(MIRRY)BY=-BY 196 - IF(MIRRZ)BZ=-BZ 197 - *** Rotate the field. 198 - IF(PERAX)THEN 199 - CALL CFMCTP(BY,BZ,XAUX,YAUX,1) 200 - YAUX=YAUX+AROT*180/PI 201 - CALL CFMPTC(XAUX,YAUX,BY,BZ,1) 202 - ENDIF 203 - IF(PERAY)THEN 204 - CALL CFMCTP(BZ,BX,XAUX,YAUX,1) 205 - YAUX=YAUX+AROT*180/PI 206 - CALL CFMPTC(XAUX,YAUX,BZ,BX,1) 207 - ENDIF 208 - IF(PERAZ)THEN 209 - CALL CFMCTP(BX,BY,XAUX,YAUX,1) 210 - YAUX=YAUX+AROT*180/PI 211 - CALL CFMPTC(XAUX,YAUX,BX,BY,1) 212 - ENDIF 213 - *** And store material index. 214 - IF(MATMAP(IMAP).EQ.IDRMAT.OR..NOT.MAPFLG(9))THEN 215 - ILOC=0 216 - ELSE 217 - ILOC=-5 218 - ENDIF 219 - END 641 GARFIELD ================================================== P=FIELDCAL D=EFQA00 1 ============================ 0 + +DECK,EFQA00. 1 - SUBROUTINE EFQA00(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * EFQA00 - Routine preparing the field calculations by filling the 4 - * capacitance matrix. This routines handles configurations 5 - * with not more than one plane in either x or y and not more 6 - * than one dielectricum in total. 7 - * VARIABLES : No local variables. 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,CAPACMATRIX. 12 - COMMON /TMPA00/ EPSMT1,EPSMT2 13 - *** Check the configuration of dielectrica is acceptable. 14 - IF(NXMATT+NYMATT.GT.1.OR. 15 - - (NXMATT.EQ.1.AND.XMATT(1,3).EQ.0.AND.XMATT(1,4).EQ.0).OR. 16 - - (NYMATT.EQ.1.AND.YMATT(1,3).EQ.0.AND.YMATT(1,4).EQ.0))THEN 17 - PRINT *,' ###### EFQA00 ERROR : The configuration of'// 18 - - ' dielectrica can not yet be handled ; cell rejected.' 19 - IFAIL=1 1 641 P=FIELDCAL D=EFQA00 2 PAGE 913 20 - RETURN 21 - ELSE 22 - PRINT *,' ------ EFQA00 MESSAGE : Potentials handled by'// 23 - - ' experimental routine.' 24 - ENDIF 25 - *** Prepare some auxilliary variables for dielectrica. 26 - YNMATX=.FALSE. 27 - YNMATY=.FALSE. 28 - COMATX=0.0 29 - COMATY=0.0 30 - EPSMT1=0.0 31 - EPSMT2=0.0 32 - IF(NXMATT.EQ.1)THEN 33 - YNMATX=.TRUE. 34 - IF(XMATT(1,3).NE.0)COMATX=XMATT(1,2) 35 - IF(XMATT(1,4).NE.0)COMATX=XMATT(1,1) 36 - EPSMT1=(1-XMATT(1,5))/(1+XMATT(1,5)) 37 - EPSMT2=2/(1+XMATT(1,5)) 38 - ELSEIF(NYMATT.EQ.1)THEN 39 - YNMATY=.TRUE. 40 - IF(YMATT(1,3).NE.0)COMATY=YMATT(1,2) 41 - IF(YMATT(1,4).NE.0)COMATY=YMATT(1,1) 42 - EPSMT1=(1-YMATT(1,5))/(1+YMATT(1,5)) 43 - EPSMT2=2/(1+YMATT(1,5)) 44 - ENDIF 45 - *** Loop over all wire combinations. 46 - DO 10 I=1,NWIRE 47 - A(I,I)=0.25*D(I)**2 48 - *** Take care of the equipotential planes. 49 - IF(YNPLAX)A(I,I)=A(I,I)/(2.0*(X(I)-COPLAX))**2 50 - IF(YNPLAY)A(I,I)=A(I,I)/(2.0*(Y(I)-COPLAY))**2 51 - *** Take care of combinations of equipotential planes. 52 - IF(YNPLAX.AND.YNPLAY)A(I,I)=4.0*A(I,I)*((X(I)-COPLAX)**2+ 53 - - (Y(I)-COPLAY)**2) 54 - *** Before adding dielectrica, take the log. 55 - A(I,I)=-0.5*LOG(A(I,I)) 56 - *** One x-dielectricum. 57 - IF(YNMATX)THEN 58 - * Dielectricum charge. 59 - A(I,I)=A(I,I)-EPSMT1*LOG(2*ABS(X(I)-COMATX)) 60 - * Add single plane reflected dielectricum charges. 61 - IF(YNPLAX)A(I,I)=A(I,I)+ 62 - - EPSMT1*LOG(ABS(2*COPLAX-2*COMATX+X(I))) 63 - IF(YNPLAY)A(I,I)=A(I,I)+ 64 - - EPSMT1*0.5*LOG((2*COMATX-X(I))**2+(2*COPLAY-Y(I))**2) 65 - * Add double plane reflected dielectricum charges. 66 - IF(YNPLAX.AND.YNPLAY)A(I,I)=A(I,I)- 67 - - EPSMT1*0.5*LOG((2*COPLAX-2*COMATX+X(I))**2+ 68 - - (2*COPLAY-Y(I))**2) 69 - *** One y-dielectricum. 70 - ELSEIF(YNMATY)THEN 71 - * Dielectricum charge. 72 - A(I,I)=A(I,I)-EPSMT1*LOG(2*ABS(Y(I)-COMATY)) 73 - * Add single plane reflected dielectricum charges. 74 - IF(YNPLAX)A(I,I)=A(I,I)+ 75 - - EPSMT1*0.5*LOG((2*COPLAX-X(I))**2+(2*COMATY-Y(I))**2) 76 - IF(YNPLAY)A(I,I)=A(I,I)+ 77 - - EPSMT1*LOG(ABS(2*COPLAY-2*COMATY+Y(I))) 78 - * Add double plane reflected dielectricum charges. 79 - IF(YNPLAX.AND.YNPLAY)A(I,I)=A(I,I)- 80 - - EPSMT1*0.5*LOG((2*COPLAX-X(I))**2+ 81 - - (2*COPLAY-2*COMATY+Y(I))**2) 82 - ENDIF 83 - *** Loop over all other wires for the off-diagonal elements. 84 - DO 20 J=I+1,NWIRE 85 - A(I,J)=(X(I)-X(J))**2+(Y(I)-Y(J))**2 86 - *** Take care of equipotential planes. 87 - IF(YNPLAX)A(I,J)=A(I,J)/((X(I)+X(J)-2.*COPLAX)**2+(Y(I)-Y(J))**2) 88 - IF(YNPLAY)A(I,J)=A(I,J)/((X(I)-X(J))**2+(Y(I)+Y(J)-2.*COPLAY)**2) 89 - *** Take care of pairs of equipotential planes in different directions. 90 - IF(YNPLAX.AND.YNPLAY)A(I,J)= 91 - - A(I,J)*((X(I)+X(J)-2.*COPLAX)**2+(Y(I)+Y(J)-2.*COPLAY)**2) 92 - *** Take the log before adding dielectrica. 93 - A(I,J)=-0.5*LOG(A(I,J)) 94 - *** One x-dielectricum. 95 - IF(YNMATX)THEN 96 - * Dielectricum charge. 97 - A(I,J)=A(I,J)-EPSMT1*0.5* 98 - - LOG((X(I)+X(J)-2*COMATX)**2+(Y(I)-Y(J))**2) 99 - * Add single plane reflected dielectricum charges. 100 - IF(YNPLAX)A(I,J)=A(I,J)+ 101 - - EPSMT1*0.5*LOG((2*COPLAX-2*COMATX+X(I)-X(J))**2+ 102 - - (Y(I)-Y(J))**2) 103 - IF(YNPLAY)A(I,J)=A(I,J)+ 104 - - EPSMT1*0.5*LOG((X(I)+X(J)-2*COMATX)**2+ 105 - - (Y(I)+Y(J)-2*COPLAY)**2) 106 - * Add double plane reflected dielectricum charges. 107 - IF(YNPLAX.AND.YNPLAY)A(I,J)=A(I,J)- 108 - - EPSMT1*0.5*LOG((2*COPLAX-2*COMATX+X(I)-X(J))**2+ 109 - - (Y(I)+Y(J)-2*COPLAY)**2) 110 - *** One y-dielectricum. 111 - ELSEIF(YNMATY)THEN 112 - * Dielectricum charge. 113 - A(I,J)=A(I,J)-EPSMT1*0.5* 114 - - LOG((X(I)-X(J))**2+(Y(I)+Y(J)-2*COMATY)**2) 115 - * Add single plane reflected dielectricum charges. 116 - IF(YNPLAX)A(I,J)=A(I,J)+ 117 - - EPSMT1*0.5*LOG((X(I)+X(J)-2*COPLAX)**2+ 118 - - (Y(I)+Y(J)-2*COMATY)**2) 119 - IF(YNPLAY)A(I,J)=A(I,J)+ 120 - - EPSMT1*0.5*LOG((X(I)-X(J))**2+ 121 - - (2*COPLAY-2*COMATY+Y(I)-Y(J))**2) 122 - * Add double plane reflected dielectricum charges. 123 - IF(YNPLAX.AND.YNPLAY)A(I,J)=A(I,J)- 124 - - EPSMT1*0.5*LOG((X(I)+X(J)-2*COPLAX)**2+ 125 - - (2*COPLAY-2*COMATY+Y(I)-Y(J))**2) 1 641 P=FIELDCAL D=EFQA00 3 PAGE 914 126 - ENDIF 127 - *** Copy this to A(J,I) since the capacitance matrix is symmetric. 128 - A(J,I)=A(I,J) 129 - 20 CONTINUE 130 - 10 CONTINUE 131 - *** Call CHARGE to calculate the charges really. 132 - CALL CHARGE(IFAIL) 133 - END 642 GARFIELD ================================================== P=FIELDCAL D=EFDA00 1 ============================ 0 + +DECK,EFDA00. 1 - SUBROUTINE EFDA00(XPOS,YPOS,EX,EY,VOLT,IOPT) 2 - *----------------------------------------------------------------------- 3 - * EFDA00 - Subroutine performing the actual field calculations in case 4 - * the charges have been prepared by EFQA00. 5 - * VARIABLES : R2 : Potential before taking -log(sqrt(...)) 6 - * EX, EY : x,y-component of the electric field. 7 - * ETOT : Magnitude of electric field. 8 - * VOLT : Potential. 9 - * EXHELP etc : One term in the series to be summed. 10 - * (XPOS,YPOS): The position where the field is calculated. 11 - *----------------------------------------------------------------------- 12.- +SEQ,DIMENSIONS. 13.- +SEQ,CELLDATA. 14 - COMMON /TMPA00/ EPSMT1,EPSMT2 15 - *** Initialise the potential and the electric field. 16 - EX=0.0 17 - EY=0.0 18 - VOLT=V0 19 - *** Loop over all wires. 20 - DO 10 I=1,NWIRE 21 - *** Calculate the field in case there are no planes. 22 - R2=(XPOS-X(I))**2+(YPOS-Y(I))**2 23 - EXHELP=(XPOS-X(I))/R2 24 - EYHELP=(YPOS-Y(I))/R2 25 - *** Take care of a plane at constant x. 26 - IF(YNPLAX)THEN 27 - XXMIRR=X(I)+(XPOS-2.0*COPLAX) 28 - R2PLAN=XXMIRR**2+(YPOS-Y(I))**2 29 - EXHELP=EXHELP-XXMIRR/R2PLAN 30 - EYHELP=EYHELP-(YPOS-Y(I))/R2PLAN 31 - R2=R2/R2PLAN 32 - ENDIF 33 - *** Take care of a plane at constant y. 34 - IF(YNPLAY)THEN 35 - YYMIRR=Y(I)+(YPOS-2.0*COPLAY) 36 - R2PLAN=(XPOS-X(I))**2+YYMIRR**2 37 - EXHELP=EXHELP-(XPOS-X(I))/R2PLAN 38 - EYHELP=EYHELP-YYMIRR/R2PLAN 39 - R2=R2/R2PLAN 40 - ENDIF 41 - *** Take care of pairs of planes. 42 - IF(YNPLAX.AND.YNPLAY)THEN 43 - R2PLAN=XXMIRR**2+YYMIRR**2 44 - EXHELP=EXHELP+XXMIRR/R2PLAN 45 - EYHELP=EYHELP+YYMIRR/R2PLAN 46 - R2=R2*R2PLAN 47 - ENDIF 48 - *** Calculate the electric field and the potential. 49 - IF((YNMATX.AND.((XPOS.LT.COMATX.AND.XMATT(1,3).NE.0).OR. 50 - - (XPOS.GT.COMATX.AND.XMATT(1,4).NE.0))).OR. 51 - - (YNMATY.AND.((YPOS.LT.COMATY.AND.YMATT(1,3).NE.0).OR. 52 - - (YPOS.GT.COMATY.AND.YMATT(1,4).NE.0))))THEN 53 - IF(IOPT.NE.0)VOLT=VOLT-0.5*E(I)*EPSMT2*LOG(R2) 54 - EX=EX+E(I)*EPSMT2*EXHELP 55 - EY=EY+E(I)*EPSMT2*EYHELP 56 - ELSE 57 - IF(IOPT.NE.0)VOLT=VOLT-0.5*E(I)*LOG(R2) 58 - EX=EX+E(I)*EXHELP 59 - EY=EY+E(I)*EYHELP 60 - ENDIF 61 - *** Dielectric mediums, no planes. 62 - IF(YNMATX.AND.((XPOS.GT.COMATX.AND.XMATT(1,3).NE.0).OR. 63 - - (XPOS.LT.COMATX.AND.XMATT(1,4).NE.0)))THEN 64 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*EPSMT1*0.5* 65 - - LOG((XPOS+X(I)-2*COMATX)**2+(YPOS-Y(I))**2) 66 - EX=EX-E(I)*EPSMT1*0.5*(XPOS+X(I)-2*COMATX)/ 67 - - SQRT((XPOS+X(I)-2*COMATX)**2+(YPOS-Y(I))**2) 68 - EY=EY-E(I)*EPSMT1*0.5*(YPOS-Y(I))/ 69 - - SQRT((XPOS+X(I)-2*COMATX)**2+(YPOS-Y(I))**2) 70 - ENDIF 71 - IF(YNMATY.AND.((YPOS.GT.COMATY.AND.YMATT(1,3).NE.0).OR. 72 - - (YPOS.LT.COMATY.AND.YMATT(1,4).NE.0)))THEN 73 - IF(IOPT.NE.0)VOLT=VOLT-E(I)*EPSMT1*0.5* 74 - - LOG((YPOS+Y(I)-2*COMATY)**2+(XPOS-X(I))**2) 75 - EX=EX-E(I)*EPSMT1*0.5*(YPOS+Y(I)-2*COMATY)/ 76 - - SQRT((YPOS+Y(I)-2*COMATY)**2+(XPOS-X(I))**2) 77 - EY=EY-E(I)*EPSMT1*0.5*(XPOS-X(I))/ 78 - - SQRT((YPOS+Y(I)-2*COMATY)**2+(XPOS-X(I))**2) 79 - ENDIF 80 - *** Finish the loop over the wires. 81 - 10 CONTINUE 82 - END 643 GARFIELD ================================================== P=FIELDCAL D=EFCCAL 1 ============================ 0 + +DECK,EFCCAL. 1 - SUBROUTINE EFCCAL(INSTR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * EFCCAL - Processes electric and magnetic field related procedure 4 - * calls. 5 - * (Last changed on 20/ 1/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 1 643 P=FIELDCAL D=EFCCAL 2 PAGE 915 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,ALGDATA. 11.- +SEQ,MATDATA. 12.- +SEQ,FIELDMAP. 13.- +SEQ,PARAMETERS. 14 - INTEGER INSTR,IFAIL,IFAIL1,IPROC,NARG,ISTR,ILOC,IAUX,NU,NV,NC, 15 - - IREF(9),ISLOT(9),NDAT,MATSLT,ISIZ(MXMDIM),IDIM,I,J,IMAP 16 - REAL BTOT,XPOS,YPOS,ZPOS,T1,T2,T3,T4,VXMIN,VYMIN,VXMAX,VYMAX 17 - CHARACTER*80 TITLE 18 - EXTERNAL MATSLT 19 - *** Assume the CALL will fail. 20 - IFAIL=1 21 - *** Make sure that a cell is available 22 - IF(.NOT.CELSET)THEN 23 - PRINT *,' !!!!!! EFCCAL WARNING : Cell data not available'// 24 - - ' ; call not executed.' 25 - RETURN 26 - ENDIF 27 - *** Some easy reference variables. 28 - NARG=INS(INSTR,3) 29 - IPROC=INS(INSTR,1) 30 - *** Electric field in 2 dimensions. 31 - IF(IPROC.EQ.-301)THEN 32 - * Check number of arguments. 33 - IF(NARG.LT.3.OR.NARG.GT.8)THEN 34 - PRINT *,' !!!!!! EFCCAL WARNING : Incorrect number'// 35 - - ' of arguments for ELECTRIC_FIELD.' 36 - RETURN 37 - * Check argument mode. 38 - ELSEIF((MODARG(1).NE.2.AND.MODARG(1).NE.5).OR. 39 - - (MODARG(2).NE.2.AND.MODARG(2).NE.5))THEN 40 - PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// 41 - - ' ELECTRIC_FIELD are of incorrect type.' 42 - RETURN 43 - * Check the the results can be transferred back. 44 - ELSEIF((NARG.GE.3.AND.ARGREF(3,1).GE.2).OR. 45 - - (NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. 46 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. 47 - - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. 48 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. 49 - - (NARG.GE.8.AND.ARGREF(8,1).GE.2))THEN 50 - PRINT *,' !!!!!! EFCCAL WARNING : Some arguments'// 51 - - ' of ELECTRIC_FIELD can not be modified.' 52 - RETURN 53 - ENDIF 54 - * Clear variables that will be overwritten. 55 - DO 200 ISTR=3,NARG 56 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 57 - 200 CONTINUE 58 - ** Carry out the calculation, first for all scalar arguments. 59 - IF(MODARG(1).EQ.2.AND.MODARG(2).EQ.2)THEN 60 - CALL EFIELD(ARG(1),ARG(2),0.0,ARG(3), 61 - - ARG(4),ARG(5),ARG(6),ARG(7),1,ILOC) 62 - MODARG(3)=2 63 - MODARG(4)=2 64 - MODARG(5)=2 65 - MODARG(6)=2 66 - MODARG(7)=2 67 - IF(NARG.GE.8)THEN 68 - IF(ILOC.EQ.-10)THEN 69 - CALL STRBUF('STORE',IAUX, 70 - - 'Unknown potential',17,IFAIL1) 71 - ELSEIF(ILOC.EQ.-5)THEN 72 - CALL STRBUF('STORE',IAUX, 73 - - 'In a material',13,IFAIL1) 74 - ELSEIF(ILOC.EQ.-6)THEN 75 - CALL STRBUF('STORE',IAUX, 76 - - 'Outside mesh',12,IFAIL1) 77 - ELSEIF(ILOC.LT.0)THEN 78 - CALL STRBUF('STORE',IAUX, 79 - - 'Outside plane',13,IFAIL1) 80 - ELSEIF(ILOC.EQ.0)THEN 81 - CALL STRBUF('STORE',IAUX, 82 - - 'Normal',6,IFAIL1) 83 - ELSEIF(ILOC.LE.NWIRE)THEN 84 - CALL STRBUF('STORE',IAUX,'In an '// 85 - - WIRTYP(ILOC)//' wire',12,IFAIL1) 86 - ELSE 87 - CALL STRBUF('STORE',IAUX,'Unknown',7,IFAIL1) 88 - ENDIF 89 - ARG(8)=REAL(IAUX) 90 - MODARG(8)=1 91 - * Error processing. 92 - IF(IFAIL1.NE.0) 93 - - PRINT *,' !!!!!! EFCCAL WARNING : '// 94 - - 'Error storing a string for ELECTRIC_FIELD.' 95 - ENDIF 96 - ** At least one of them is a matrix. 97 - ELSE 98 - * Figure out what the dimensions are. 99 - NDAT=-1 100 - DO 30 I=1,2 101 - IF(MODARG(I).EQ.5)THEN 102 - IREF(I)=NINT(ARG(I)) 103 - ISLOT(I)=MATSLT(IREF(I)) 104 - IF(ISLOT(I).LE.0)THEN 105 - PRINT *,' !!!!!! EFCCAL WARNING : Unable'// 106 - - ' locate a input matrix.' 107 - RETURN 108 - ELSEIF(MMOD(ISLOT(I)).NE.2)THEN 109 - PRINT *,' !!!!!! EFCCAL WARNING : x, y'// 110 - - ' Or z matrix of incorrect type.' 111 - RETURN 112 - ENDIF 113 - IF(NDAT.LT.0)THEN 1 643 P=FIELDCAL D=EFCCAL 3 PAGE 916 114 - NDAT=MLEN(ISLOT(I)) 115 - DO 10 J=1,MDIM(ISLOT(I)) 116 - ISIZ(J)=MSIZ(ISLOT(I),J) 117 - 10 CONTINUE 118 - IDIM=MDIM(ISLOT(I)) 119 - ELSEIF(NDAT.NE.MLEN(ISLOT(I)))THEN 120 - PRINT *,' !!!!!! EFCCAL WARNING : x, y'// 121 - - ' And z have inconsistent lengths.' 122 - RETURN 123 - ENDIF 124 - ENDIF 125 - 30 CONTINUE 126 - IF(NDAT.LT.1)THEN 127 - PRINT *,' !!!!!! EFCCAL WARNING : Unable'// 128 - - ' to find an x, y or z matrix.' 129 - RETURN 130 - ENDIF 131 - * Now book matrices for the missing elements and initialise them. 132 - DO 40 I=1,2 133 - IF(MODARG(I).NE.5)THEN 134 - CALL MATADM('ALLOCATE',IREF(I),IDIM,ISIZ,2,IFAIL1) 135 - IF(IFAIL1.NE.0)THEN 136 - PRINT *,' !!!!!! EFCCAL WARNING : Unable'// 137 - - ' to get a replacement matrix.' 138 - RETURN 139 - ENDIF 140 - ISLOT(I)=MATSLT(IREF(I)) 141 - IF(ISLOT(I).LE.0)THEN 142 - PRINT *,' !!!!!! EFCCAL WARNING : Unable'// 143 - - ' to locate a replacement matrix.' 144 - RETURN 145 - ENDIF 146 - DO 50 J=1,MLEN(ISLOT(I)) 147 - MVEC(MORG(ISLOT(I))+J)=ARG(I) 148 - 50 CONTINUE 149 - ENDIF 150 - 40 CONTINUE 151 - * Allocate the 6 output arrays (Ex, Ey, Ez, E, V, status). 152 - DO 20 I=4,9 153 - CALL MATADM('ALLOCATE',IREF(I),IDIM,ISIZ,2,IFAIL1) 154 - IF(IFAIL1.NE.0)THEN 155 - PRINT *,' !!!!!! EFCCAL WARNING : Unable'// 156 - - ' to get an output matrix.' 157 - RETURN 158 - ENDIF 159 - 20 CONTINUE 160 - * And finally locate all 9 matrices. 161 - DO 60 I=1,9 162 - IF(I.EQ.3)GOTO 60 163 - ISLOT(I)=MATSLT(IREF(I)) 164 - IF(ISLOT(I).LE.0)THEN 165 - PRINT *,' !!!!!! EFCCAL WARNING : Unable'// 166 - - ' to locate an input or output matrix.' 167 - RETURN 168 - ENDIF 169 - 60 CONTINUE 170 - * And compute the data. 171 - DO 70 I=1,NDAT 172 - CALL EFIELD(MVEC(MORG(ISLOT(1))+I), 173 - - MVEC(MORG(ISLOT(2))+I),0.0, 174 - - MVEC(MORG(ISLOT(4))+I),MVEC(MORG(ISLOT(5))+I), 175 - - MVEC(MORG(ISLOT(6))+I),MVEC(MORG(ISLOT(7))+I), 176 - - MVEC(MORG(ISLOT(8))+I),1,ILOC) 177 - MVEC(MORG(ISLOT(9))+I)=REAL(ILOC) 178 - 70 CONTINUE 179 - * Delete temporary input matrices. 180 - DO 80 I=1,2 181 - IF(MODARG(I).NE.5)THEN 182 - ISIZ(1)=NDAT 183 - CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL1) 184 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! EFCCAL WARNING'// 185 - - ' : Unable to delete a replacement matrix.' 186 - ENDIF 187 - 80 CONTINUE 188 - * And save the requested output matrices, delete the others. 189 - DO 90 I=4,9 190 - IF(NARG.GE.I-1)THEN 191 - ARG(I-1)=IREF(I) 192 - MODARG(I-1)=5 193 - ELSE 194 - ISIZ(1)=NDAT 195 - CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL1) 196 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! EFCCAL WARNING'// 197 - - ' : Unable to delete an unused output.' 198 - ENDIF 199 - 90 CONTINUE 200 - ENDIF 201 - *** Electric field in 3 dimensions. 202 - ELSEIF(IPROC.EQ.-302)THEN 203 - * Check number of arguments. 204 - IF(NARG.LT.4.OR.NARG.GT.9)THEN 205 - PRINT *,' !!!!!! EFCCAL WARNING : Incorrect number'// 206 - - ' of arguments for ELECTRIC_FIELD_3.' 207 - RETURN 208 - * Check argument mode. 209 - ELSEIF((MODARG(1).NE.2.AND.MODARG(1).NE.5).OR. 210 - - (MODARG(2).NE.2.AND.MODARG(2).NE.5).OR. 211 - - (MODARG(3).NE.2.AND.MODARG(3).NE.5))THEN 212 - PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// 213 - - ' ELECTRIC_FIELD_3 are of incorrect type.' 214 - RETURN 215 - * Check the the results can be transferred back. 216 - ELSEIF((NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. 217 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. 218 - - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. 219 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. 1 643 P=FIELDCAL D=EFCCAL 4 PAGE 917 220 - - (NARG.GE.8.AND.ARGREF(8,1).GE.2).OR. 221 - - (NARG.GE.9.AND.ARGREF(9,1).GE.2))THEN 222 - PRINT *,' !!!!!! EFCCAL WARNING : Some arguments'// 223 - - ' of ELECTRIC_FIELD_3 can not be modified.' 224 - RETURN 225 - ENDIF 226 - * Variables already in use ? 227 - DO 210 ISTR=4,9 228 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 229 - 210 CONTINUE 230 - ** Carry out the calculation, first for all scalar arguments. 231 - IF(MODARG(1).EQ.2.AND.MODARG(2).EQ.2.AND. 232 - - MODARG(3).EQ.2)THEN 233 - CALL EFIELD(ARG(1),ARG(2),ARG(3), 234 - - ARG(4),ARG(5),ARG(6),ARG(7),ARG(8),1,ILOC) 235 - MODARG(4)=2 236 - MODARG(5)=2 237 - MODARG(6)=2 238 - MODARG(7)=2 239 - MODARG(8)=2 240 - IF(NARG.GE.9)THEN 241 - IF(ILOC.EQ.-10)THEN 242 - CALL STRBUF('STORE',IAUX, 243 - - 'Unknown potential',17,IFAIL1) 244 - ELSEIF(ILOC.EQ.-5)THEN 245 - CALL STRBUF('STORE',IAUX, 246 - - 'In a material',13,IFAIL1) 247 - ELSEIF(ILOC.EQ.-6)THEN 248 - CALL STRBUF('STORE',IAUX, 249 - - 'Outside mesh',12,IFAIL1) 250 - ELSEIF(ILOC.LT.0)THEN 251 - CALL STRBUF('STORE',IAUX, 252 - - 'Outside plane',13,IFAIL1) 253 - ELSEIF(ILOC.EQ.0)THEN 254 - CALL STRBUF('STORE',IAUX, 255 - - 'Normal',6,IFAIL1) 256 - ELSEIF(ILOC.LE.NWIRE)THEN 257 - CALL STRBUF('STORE',IAUX,'In an '// 258 - - WIRTYP(ILOC)//' wire',12,IFAIL1) 259 - ELSE 260 - CALL STRBUF('STORE',IAUX,'Unknown',7,IFAIL1) 261 - ENDIF 262 - ARG(9)=REAL(IAUX) 263 - MODARG(9)=1 264 - * Error processing. 265 - IF(IFAIL1.NE.0) 266 - - PRINT *,' !!!!!! EFCCAL WARNING : '// 267 - - 'Error storing a string for'// 268 - - ' ELECTRIC_FIELD_3.' 269 - ENDIF 270 - ** At least one of them is a matrix. 271 - ELSE 272 - * Figure out what the dimensions are. 273 - NDAT=-1 274 - DO 130 I=1,3 275 - IF(MODARG(I).EQ.5)THEN 276 - IREF(I)=NINT(ARG(I)) 277 - ISLOT(I)=MATSLT(IREF(I)) 278 - IF(ISLOT(I).LE.0)THEN 279 - PRINT *,' !!!!!! EFCCAL WARNING : Unable'// 280 - - ' locate a input matrix.' 281 - RETURN 282 - ELSEIF(MMOD(ISLOT(I)).NE.2)THEN 283 - PRINT *,' !!!!!! EFCCAL WARNING : x, y'// 284 - - ' Or z matrix of incorrect type.' 285 - RETURN 286 - ENDIF 287 - IF(NDAT.LT.0)THEN 288 - NDAT=MLEN(ISLOT(I)) 289 - DO 110 J=1,MDIM(ISLOT(I)) 290 - ISIZ(J)=MSIZ(ISLOT(I),J) 291 - 110 CONTINUE 292 - IDIM=MDIM(ISLOT(I)) 293 - ELSEIF(NDAT.NE.MLEN(ISLOT(I)))THEN 294 - PRINT *,' !!!!!! EFCCAL WARNING : x, y'// 295 - - ' And z have inconsistent lengths.' 296 - RETURN 297 - ENDIF 298 - ENDIF 299 - 130 CONTINUE 300 - IF(NDAT.LT.1)THEN 301 - PRINT *,' !!!!!! EFCCAL WARNING : Unable'// 302 - - ' to find an x, y or z matrix.' 303 - RETURN 304 - ENDIF 305 - * Now book matrices for the missing elements and initialise them. 306 - DO 140 I=1,3 307 - IF(MODARG(I).NE.5)THEN 308 - CALL MATADM('ALLOCATE',IREF(I),IDIM,ISIZ,2,IFAIL1) 309 - IF(IFAIL1.NE.0)THEN 310 - PRINT *,' !!!!!! EFCCAL WARNING : Unable'// 311 - - ' to get a replacement matrix.' 312 - RETURN 313 - ENDIF 314 - ISLOT(I)=MATSLT(IREF(I)) 315 - IF(ISLOT(I).LE.0)THEN 316 - PRINT *,' !!!!!! EFCCAL WARNING : Unable'// 317 - - ' to locate a replacement matrix.' 318 - RETURN 319 - ENDIF 320 - DO 150 J=1,MLEN(ISLOT(I)) 321 - MVEC(MORG(ISLOT(I))+J)=ARG(I) 322 - 150 CONTINUE 323 - ENDIF 324 - 140 CONTINUE 325 - * Allocate the 6 output arrays (Ex, Ey, Ez, E, V, status). 1 643 P=FIELDCAL D=EFCCAL 5 PAGE 918 326 - DO 120 I=4,9 327 - CALL MATADM('ALLOCATE',IREF(I),IDIM,ISIZ,2,IFAIL1) 328 - IF(IFAIL1.NE.0)THEN 329 - PRINT *,' !!!!!! EFCCAL WARNING : Unable'// 330 - - ' to get an output matrix.' 331 - RETURN 332 - ENDIF 333 - 120 CONTINUE 334 - * And finally locate all 9 matrices. 335 - DO 160 I=1,9 336 - ISLOT(I)=MATSLT(IREF(I)) 337 - IF(ISLOT(I).LE.0)THEN 338 - PRINT *,' !!!!!! EFCCAL WARNING : Unable'// 339 - - ' to locate an input or output array.' 340 - RETURN 341 - ENDIF 342 - 160 CONTINUE 343 - * And compute the data. 344 - DO 170 I=1,NDAT 345 - CALL EFIELD(MVEC(MORG(ISLOT(1))+I), 346 - - MVEC(MORG(ISLOT(2))+I),MVEC(MORG(ISLOT(3))+I), 347 - - MVEC(MORG(ISLOT(4))+I),MVEC(MORG(ISLOT(5))+I), 348 - - MVEC(MORG(ISLOT(6))+I),MVEC(MORG(ISLOT(7))+I), 349 - - MVEC(MORG(ISLOT(8))+I),1,ILOC) 350 - MVEC(MORG(ISLOT(9))+I)=REAL(ILOC) 351 - 170 CONTINUE 352 - * Delete temporary input matrices. 353 - DO 180 I=1,3 354 - IF(MODARG(I).NE.5)THEN 355 - ISIZ(1)=NDAT 356 - CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL1) 357 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! EFCCAL WARNING'// 358 - - ' : Unable to delete a replacement array.' 359 - ENDIF 360 - 180 CONTINUE 361 - * And save the requested output matrices, delete the others. 362 - DO 190 I=4,9 363 - IF(NARG.GE.I)THEN 364 - ARG(I)=IREF(I) 365 - MODARG(I)=5 366 - ELSE 367 - ISIZ(1)=NDAT 368 - CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL1) 369 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! EFCCAL WARNING'// 370 - - ' : Unable to delete an unused output.' 371 - ENDIF 372 - 190 CONTINUE 373 - ENDIF 374 - *** Force field in 2 dimensions. 375 - ELSEIF(IPROC.EQ.-303)THEN 376 - * Check number of arguments. 377 - IF(NARG.NE.4)THEN 378 - PRINT *,' !!!!!! EFCCAL WARNING : Incorrect number'// 379 - - ' of arguments for FORCE_FIELD.' 380 - RETURN 381 - * Check argument mode. 382 - ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2)THEN 383 - PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// 384 - - ' FORCE_FIELD are of incorrect type.' 385 - RETURN 386 - * Check the the results can be transferred back. 387 - ELSEIF(ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2)THEN 388 - PRINT *,' !!!!!! EFCCAL WARNING : Some arguments'// 389 - - ' of FORCE_FIELD can not be modified.' 390 - RETURN 391 - ENDIF 392 - * Variables already in use ? 393 - CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) 394 - CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 395 - * Carry out the calculation. 396 - CALL FFDBG(ARG(1),ARG(2),ARG(3),ARG(4)) 397 - MODARG(3)=2 398 - MODARG(4)=2 399 - *** Magnetic field in 2 dimensions. 400 - ELSEIF(IPROC.EQ.-304)THEN 401 - * Check number of arguments. 402 - IF(NARG.LT.5.OR.NARG.GT.6)THEN 403 - PRINT *,' !!!!!! EFCCAL WARNING : Incorrect number'// 404 - - ' of arguments for MAGNETIC_FIELD.' 405 - RETURN 406 - * Check argument mode. 407 - ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2)THEN 408 - PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// 409 - - ' MAGNETIC_FIELD are of incorrect type.' 410 - RETURN 411 - * Check the the results can be transferred back. 412 - ELSEIF(ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2.OR. 413 - - ARGREF(5,1).GE.2.OR. 414 - - (NARG.GE.6.AND.ARGREF(6,1).GE.2))THEN 415 - PRINT *,' !!!!!! EFCCAL WARNING : Some arguments'// 416 - - ' of MAGNETIC_FIELD can not be modified.' 417 - RETURN 418 - ENDIF 419 - * Variables already in use ? 420 - DO 220 ISTR=3,NARG 421 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 422 - 220 CONTINUE 423 - * Carry out the calculation. 424 - CALL BFIELD(ARG(1),ARG(2),0.0,ARG(3),ARG(4),ARG(5),BTOT) 425 - MODARG(3)=2 426 - MODARG(4)=2 427 - MODARG(5)=2 428 - IF(NARG.GE.6)THEN 429 - ARG(6)=BTOT 430 - MODARG(6)=2 431 - ENDIF 1 643 P=FIELDCAL D=EFCCAL 6 PAGE 919 432 - *** Magnetic field in 3 dimensions. 433 - ELSEIF(IPROC.EQ.-305)THEN 434 - * Check number of arguments. 435 - IF(NARG.LT.6.OR.NARG.GT.7)THEN 436 - PRINT *,' !!!!!! EFCCAL WARNING : Incorrect number'// 437 - - ' of arguments for MAGNETIC_FIELD_3.' 438 - RETURN 439 - * Check argument mode. 440 - ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 441 - - MODARG(3).NE.2)THEN 442 - PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// 443 - - ' MAGNETIC_FIELD_3 are of incorrect type.' 444 - RETURN 445 - * Check the the results can be transferred back. 446 - ELSEIF(ARGREF(4,1).GE.2.OR.ARGREF(5,1).GE.2.OR. 447 - - ARGREF(6,1).GE.2.OR. 448 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2))THEN 449 - PRINT *,' !!!!!! EFCCAL WARNING : Some arguments'// 450 - - ' of MAGNETIC_FIELD_3 can not be modified.' 451 - RETURN 452 - ENDIF 453 - * Variables already in use ? 454 - DO 230 ISTR=4,NARG 455 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 456 - 230 CONTINUE 457 - * Carry out the calculation. 458 - CALL BFIELD(ARG(1),ARG(2),ARG(3),ARG(4),ARG(5),ARG(6),BTOT) 459 - MODARG(3)=2 460 - MODARG(4)=2 461 - MODARG(5)=2 462 - MODARG(6)=2 463 - IF(NARG.GE.7)THEN 464 - ARG(7)=BTOT 465 - MODARG(7)=2 466 - ENDIF 467 - *** Charge integration in 2 and 3 dimensions. 468 - ELSEIF(IPROC.EQ.-306)THEN 469 - * Check number of arguments. 470 - IF(NARG.LT.4.OR.NARG.GT.5)THEN 471 - PRINT *,' !!!!!! EFCCAL WARNING : Incorrect number'// 472 - - ' of arguments for INTEGRATE_CHARGE.' 473 - RETURN 474 - * Check argument mode. 475 - ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 476 - - (NARG.EQ.5.AND.MODARG(3).NE.2))THEN 477 - PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// 478 - - ' INTEGRATE_CHARGE are of incorrect type.' 479 - RETURN 480 - * Check the the results can be transferred back. 481 - ELSEIF(ARGREF(NARG,1).GE.2)THEN 482 - PRINT *,' !!!!!! EFCCAL WARNING : The result'// 483 - - ' of INTEGRATE_CHARGE can not be assigned.' 484 - RETURN 485 - ENDIF 486 - * Variables already in use ? 487 - CALL ALGREU(NINT(ARG(NARG)),MODARG(NARG),ARGREF(NARG,1)) 488 - * Carry out the calculation. 489 - IF(NARG.EQ.4)THEN 490 - CALL FLDIN2(ARG(1),ARG(2),ARG(3),ARG(4)) 491 - MODARG(4)=2 492 - ELSE 493 - CALL FLDIN3(ARG(1),ARG(2),ARG(3),ARG(4),ARG(5)) 494 - MODARG(5)=2 495 - ENDIF 496 - *** Flux integration over a parallelogram. 497 - ELSEIF(IPROC.EQ.-307)THEN 498 - * Check number of arguments. 499 - IF(NARG.LT.10.OR.NARG.GT.12)THEN 500 - PRINT *,' !!!!!! EFCCAL WARNING : Incorrect number'// 501 - - ' of arguments for INTEGRATE_FLUX.' 502 - RETURN 503 - * Check argument mode. 504 - ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 505 - - MODARG(3).NE.2.OR.MODARG(4).NE.2.OR. 506 - - MODARG(5).NE.2.OR.MODARG(6).NE.2.OR. 507 - - MODARG(7).NE.2.OR.MODARG(8).NE.2.OR. 508 - - MODARG(9).NE.2.OR. 509 - - (NARG.GE.11.AND.MODARG(11).NE.2).OR. 510 - - (NARG.GE.12.AND.MODARG(12).NE.2))THEN 511 - PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// 512 - - ' INTEGRATE_FLUX are of incorrect type.' 513 - RETURN 514 - * Check the the results can be transferred back. 515 - ELSEIF(ARGREF(10,1).GE.2)THEN 516 - PRINT *,' !!!!!! EFCCAL WARNING : The result'// 517 - - ' of INTEGRATE_FLUX can not be assigned.' 518 - RETURN 519 - ENDIF 520 - * Variables already in use ? 521 - CALL ALGREU(NINT(ARG(10)),MODARG(10),ARGREF(10,1)) 522 - * Fetch the number of integration points, if present. 523 - NU=20 524 - NV=20 525 - IF(NARG.GE.11)NU=NINT(ARG(11)) 526 - IF(NARG.GE.12)NV=NINT(ARG(12)) 527 - * Integrate the flux. 528 - CALL FLDIN4(ARG(1),ARG(2),ARG(3),ARG(4),ARG(5), 529 - - ARG(6),ARG(7),ARG(8),ARG(9),ARG(10),NU,NV) 530 - MODARG(10)=2 531 - *** Returns map indices. 532 - ELSEIF(IPROC.EQ.-310)THEN 533 - * See whether there is a field map at all. 534 - IF(NMAP.LE.0.OR..NOT.MAPFLG(1))THEN 535 - PRINT *,' !!!!!! EFCCAL WARNING : There is no'// 536 - - ' field map; MAP_INDEX not executed.' 537 - RETURN 1 643 P=FIELDCAL D=EFCCAL 7 PAGE 920 538 - * Check number of arguments. 539 - ELSEIF((MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3).AND. 540 - - NARG.NE.3.AND.NARG.NE.6)THEN 541 - PRINT *,' !!!!!! EFCCAL WARNING : The map is made of'// 542 - - ' triangles; provide 3 or 6 arguments.' 543 - RETURN 544 - ELSEIF((MAPTYP.EQ.4.OR.MAPTYP.EQ.5.OR.MAPTYP.EQ.6).AND. 545 - - NARG.NE.3.AND.NARG.NE.5)THEN 546 - PRINT *,' !!!!!! EFCCAL WARNING : The map is made of'// 547 - - ' parallelograms; provide 3 or 5 arguments.' 548 - RETURN 549 - ELSEIF((MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13).AND. 550 - - NARG.NE.4.AND.NARG.NE.8)THEN 551 - PRINT *,' !!!!!! EFCCAL WARNING : The map is made of'// 552 - - ' tetrahedrons; provide 4 or 8 arguments.' 553 - RETURN 554 - ELSEIF((MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16).AND. 555 - - NARG.NE.4.AND.NARG.NE.7)THEN 556 - PRINT *,' !!!!!! EFCCAL WARNING : The map is made of'// 557 - - ' parallelepipeds; provide 4 or 7 arguments.' 558 - RETURN 559 - ELSEIF(MAPTYP.LE.0.OR.(MAPTYP.GE.7.AND.MAPTYP.LE.10).OR. 560 - - MAPTYP.GE.17)THEN 561 - PRINT *,' !!!!!! EFCCAL WARNING : Unknown element'// 562 - - ' type; MAP_INDEX not executed.' 563 - RETURN 564 - * Check argument mode and return possibilities. 565 - ELSEIF( 566 - - (NARG.EQ.3.AND. 567 - - (MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 568 - - ARGREF(3,1).GE.2)).OR. 569 - - (NARG.EQ.4.AND. 570 - - (MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 571 - - MODARG(3).NE.2.OR.ARGREF(4,1).GE.2)).OR. 572 - - (NARG.EQ.6.AND. 573 - - (MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 574 - - ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2.OR. 575 - - ARGREF(5,1).GE.2.OR.ARGREF(6,1).GE.2)).OR. 576 - - (NARG.EQ.8.AND. 577 - - (MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 578 - - MODARG(3).NE.2.OR. 579 - - ARGREF(4,1).GE.2.OR.ARGREF(5,1).GE.2.OR. 580 - - ARGREF(6,1).GE.2.OR.ARGREF(7,1).GE.2.OR. 581 - - ARGREF(8,1).GE.2)))THEN 582 - PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// 583 - - ' MAP_INDEX are of incorrect type.' 584 - RETURN 585 - ENDIF 586 - * Find the map indices. 587 - XPOS=ARG(1) 588 - YPOS=ARG(2) 589 - IF(MAPTYP.GT.10)THEN 590 - ZPOS=ARG(3) 591 - ELSE 592 - ZPOS=0 593 - ENDIF 594 - CALL MAPIND(XPOS,YPOS,ZPOS,T1,T2,T3,T4,IMAP) 595 - IF(IMAP.LE.0)THEN 596 - PRINT *,' !!!!!! EFCCAL WARNING : Point is not'// 597 - - ' located in an element.' 598 - RETURN 599 - ENDIF 600 - * Variables already in use ? 601 - IF(MAPTYP.GT.10)THEN 602 - DO 240 I=4,NARG 603 - CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 604 - 240 CONTINUE 605 - ELSE 606 - DO 250 I=3,NARG 607 - CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 608 - 250 CONTINUE 609 - ENDIF 610 - * Return the results. 611 - IF(MAPTYP.GT.10)THEN 612 - ARG(4)=IMAP 613 - ARG(5)=T1 614 - ARG(6)=T2 615 - ARG(7)=T3 616 - ARG(8)=T4 617 - MODARG(4)=2 618 - MODARG(5)=2 619 - MODARG(6)=2 620 - MODARG(7)=2 621 - MODARG(8)=2 622 - ELSE 623 - ARG(3)=IMAP 624 - ARG(4)=T1 625 - ARG(5)=T2 626 - ARG(6)=T3 627 - MODARG(3)=2 628 - MODARG(4)=2 629 - MODARG(5)=2 630 - MODARG(6)=2 631 - ENDIF 632 - *** Return the volume element. 633 - ELSEIF(IPROC.EQ.-311)THEN 634 - * See whether there is a field map at all. 635 - IF(NMAP.LE.0.OR..NOT.MAPFLG(1))THEN 636 - PRINT *,' !!!!!! EFCCAL WARNING : There is no'// 637 - - ' field map; MAP_ELEMENT not executed.' 638 - RETURN 639 - * Check number of arguments. 640 - ELSEIF((MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3).AND. 641 - - NARG.NE.7)THEN 642 - PRINT *,' !!!!!! EFCCAL WARNING : The map is made of'// 643 - - ' triangles; provide 7 arguments.' 1 643 P=FIELDCAL D=EFCCAL 8 PAGE 921 644 - RETURN 645 - ELSEIF((MAPTYP.EQ.4.OR.MAPTYP.EQ.5.OR.MAPTYP.EQ.6).AND. 646 - - NARG.NE.7)THEN 647 - PRINT *,' !!!!!! EFCCAL WARNING : The map is made of'// 648 - - ' parallelograms; provide 7 arguments.' 649 - RETURN 650 - ELSEIF((MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13).AND. 651 - - NARG.NE.13)THEN 652 - PRINT *,' !!!!!! EFCCAL WARNING : The map is made of'// 653 - - ' tetrahedrons; provide 13 arguments.' 654 - RETURN 655 - ELSEIF((MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16).AND. 656 - - NARG.NE.13)THEN 657 - PRINT *,' !!!!!! EFCCAL WARNING : The map is made of'// 658 - - ' parallelepipeds; provide 13 arguments.' 659 - RETURN 660 - * Check argument mode and return possibilities. 661 - ELSEIF(MODARG(1).NE.2.OR. 662 - - (NARG.GE.2.AND.ARGREF(2,1).GE.2).OR. 663 - - (NARG.GE.3.AND.ARGREF(3,1).GE.2).OR. 664 - - (NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. 665 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. 666 - - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. 667 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. 668 - - (NARG.GE.8.AND.ARGREF(8,1).GE.2).OR. 669 - - (NARG.GE.9.AND.ARGREF(9,1).GE.2).OR. 670 - - (NARG.GE.10.AND.ARGREF(10,1).GE.2).OR. 671 - - (NARG.GE.11.AND.ARGREF(11,1).GE.2).OR. 672 - - (NARG.GE.12.AND.ARGREF(12,1).GE.2).OR. 673 - - (NARG.GE.13.AND.ARGREF(13,1).GE.2))THEN 674 - PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// 675 - - ' MAP_ELEMENT are of incorrect type.' 676 - RETURN 677 - * Verify map type. 678 - ELSEIF(MAPTYP.LE.0.OR.(MAPTYP.GE.7.AND.MAPTYP.LE.10).OR. 679 - - MAPTYP.GE.17)THEN 680 - PRINT *,' !!!!!! EFCCAL WARNING : Unknown element'// 681 - - ' type; MAP_ELEMENT not executed.' 682 - RETURN 683 - * Verify that the element is within range. 684 - ELSEIF(NINT(ARG(1)).LT.1.OR.NINT(ARG(1)).GT.NMAP)THEN 685 - PRINT *,' !!!!!! EFCCAL WARNING : MAP_ELEMENT not'// 686 - - ' executed, element is out of range.' 687 - RETURN 688 - ENDIF 689 - * Variables already in use ? 690 - DO 260 I=2,NARG 691 - CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 692 - 260 CONTINUE 693 - * Return the element. 694 - IF(MAPTYP.GE.1.AND.MAPTYP.LE.6)THEN 695 - ARG(2)= XMAP(NINT(ARG(1)),1) 696 - ARG(3)= YMAP(NINT(ARG(1)),1) 697 - ARG(4)= XMAP(NINT(ARG(1)),2) 698 - ARG(5)= YMAP(NINT(ARG(1)),2) 699 - ARG(6)= XMAP(NINT(ARG(1)),3) 700 - ARG(7)= YMAP(NINT(ARG(1)),3) 701 - ELSEIF(MAPTYP.GE.11.AND.MAPTYP.LE.16)THEN 702 - ARG(2)= XMAP(NINT(ARG(1)),1) 703 - ARG(3)= YMAP(NINT(ARG(1)),1) 704 - ARG(4)= ZMAP(NINT(ARG(1)),1) 705 - ARG(5)= XMAP(NINT(ARG(1)),2) 706 - ARG(6)= YMAP(NINT(ARG(1)),2) 707 - ARG(7)= ZMAP(NINT(ARG(1)),2) 708 - ARG(8)= XMAP(NINT(ARG(1)),3) 709 - ARG(9)= YMAP(NINT(ARG(1)),3) 710 - ARG(10)=ZMAP(NINT(ARG(1)),3) 711 - ARG(11)=XMAP(NINT(ARG(1)),4) 712 - ARG(12)=YMAP(NINT(ARG(1)),4) 713 - ARG(13)=ZMAP(NINT(ARG(1)),4) 714 - ENDIF 715 - DO 270 I=2,NARG 716 - MODARG(I)=2 717 - 270 CONTINUE 718 - *** Material index. 719 - ELSEIF(IPROC.EQ.-312)THEN 720 - * Check argument list. 721 - IF(NARG.LT.2.OR.NARG.GT.3.OR. 722 - - MODARG(1).NE.2.OR. 723 - - (NARG.GE.2.AND.ARGREF(2,1).GE.2).OR. 724 - - (NARG.GE.3.AND.ARGREF(3,1).GE.2))THEN 725 - PRINT *,' !!!!!! EFCCAL WARNING : Incorrect argument'// 726 - - ' list for MAP_MATERIAL' 727 - RETURN 728 - * Make sure the materials are known. 729 - ELSEIF(.NOT.MAPFLG(9))THEN 730 - PRINT *,' !!!!!! EFCCAL WARNING : Materials are not'// 731 - - ' defined; MAP_MATERIAL not executed.' 732 - RETURN 733 - * Make sure index is in range. 734 - ELSEIF(NINT(ARG(1)).LT.1.OR.NINT(ARG(1)).GT.NMAP)THEN 735 - PRINT *,' !!!!!! EFCCAL WARNING : Field map index is'// 736 - - ' out of range; MAP_MATERIAL not executed.' 737 - RETURN 738 - ENDIF 739 - * Clean up variables. 740 - DO 280 I=2,NARG 741 - CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 742 - 280 CONTINUE 743 - * Return the values. 744 - ARG(2)=REAL(MATMAP(NINT(ARG(1)))) 745 - IF(NINT(ARG(2)).GE.1.AND.NINT(ARG(2)).LE.NEPS)THEN 746 - ARG(3)=EPSMAT(NINT(ARG(2))) 747 - ELSE 748 - ARG(3)=-1 749 - ENDIF 1 643 P=FIELDCAL D=EFCCAL 9 PAGE 922 750 - MODARG(2)=2 751 - MODARG(3)=2 752 - *** Plot the field area. 753 - ELSEIF(IPROC.EQ.-320)THEN 754 - * Check arguments. 755 - IF((NARG.NE.0.AND.NARG.NE.1).OR. 756 - - (NARG.EQ.1.AND.MODARG(1).NE.1))THEN 757 - PRINT *,' !!!!!! EFCCAL WARNING : Incorrect list'// 758 - - ' of arguments for PLOT_FIELD_AREA; no plot.' 759 - RETURN 760 - ENDIF 761 - * See whether there is a title. 762 - IF(NARG.EQ.1)THEN 763 - CALL STRBUF('READ',NINT(ARG(1)),TITLE,NC,IFAIL1) 764 - ELSEIF(CELLID.EQ.' ')THEN 765 - TITLE='Layout of the cell' 766 - NC=18 767 - ELSE 768 - TITLE=CELLID 769 - NC=LEN(CELLID) 770 - ENDIF 771 - * Plot the frame. 772 - CALL GRASET(PXMIN,PYMIN,PZMIN,PXMAX,PYMAX,PZMAX) 773 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX,TITLE(1:NC)) 774 - *** Unknown electric field operation. 775 - ELSE 776 - PRINT *,' !!!!!! EFCCAL WARNING : Unknown procedure code'// 777 - - ' received; nothing done.' 778 - IFAIL=1 779 - RETURN 780 - ENDIF 781 - *** Seems to have worked. 782 - IFAIL=0 783 - END 644 GARFIELD ================================================== P=DRIFT D= 1 ============================ 0 + +PATCH,DRIFT. 645 GARFIELD ================================================== P=DRIFT D=DRFINP 1 ============================ 0 + +DECK,DRFINP. 1 - SUBROUTINE DRFINP 2 - *----------------------------------------------------------------------- 3 - * DRFINP - Routine reading instructions with regard to the drift line 4 - * and equal time contours and calling the appropriate routine 5 - * VARIABLES : STRING : (parts of) the instruction read by INPWRD 6 - * VTEST : Used for drift velocity printing. 7 - * (Last changed on 10/ 7/99.) 8 - *----------------------------------------------------------------------- 9 - implicit none 10.- +SEQ,DIMENSIONS. 11.- +SEQ,CELLDATA. 12.- +SEQ,BFIELD. 13.- +SEQ,DRIFTLINE. 14.- +SEQ,GASDATA. 15.- +SEQ,PRINTPLOT. 16.- +SEQ,PARAMETERS. 17.- +SEQ,CONSTANTS. 18 - CHARACTER*(MXCHAR) STRING 19 - DOUBLE PRECISION VTEST(3) 20 - INTEGER INPCMP,INPTYP,NWORD,IFAIL,IFAIL1,IFAIL2,IFAIL3,NLINER,NC, 21 - - NGRIDR,NGRDXR,NGRDYR,ILOC,ILOC1,ILOC2,I,INEXT,NLTR,NLTRR, 22 - - ITEST,NTEST 23 - REAL XTEST,YTEST,ZTEST,EXTEST,EYTEST,EZTEST,ETEST,VOLT,QTEST, 24 - - TMIN,TMAX,SMIN,SMAX,AMIN,AMAX,BMIN,BMAX,CPU,RNDM 25 - LOGICAL FLAG(MXWORD+3),LDIFF,LTOWN,LATTA 26 - EXTERNAL INPCMP,INPTYP,RNDM 0 27-+ +SELF,IF=AST. 28 - EXTERNAL ASTCCH 0 29-+ +SELF. 30 - *** Define some formats 31 - 1020 FORMAT(' Current number of grid points is ',I3,' by ',I3,'.') 32 - 1040 FORMAT(' Distance between equal time contours ',F10.3, 33 - - ' [microsec]') 34 - *** Identify the routine, if requested. 35 - IF(LIDENT)PRINT *,' /// ROUTINE DRFINP ///' 36 - *** Print a heading for the drift section. 37 - WRITE(LUNOUT,'(''1'')') 38 - PRINT *,' ================================================' 39 - PRINT *,' ========== Start of drift section ==========' 40 - PRINT *,' ================================================' 41 - PRINT *,' ' 42 - *** Check that valid gas data are present. 43 - IF(.NOT.GASOK(1))THEN 44 - PRINT *,' ###### DRFINP ERROR : The drift velocity data'// 45 - - ' are missing; this section can not be executed.' 46 - CALL SKIP 47 - RETURN 48 - ENDIF 49 - *** Set default area. 50 - CALL GRASET(DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX) 51 - *** Start an input loop. 52 - CALL INPPRM('Drift','NEW-PRINT') 53 - 10 CONTINUE 54 - CALL INPWRD(NWORD) 0 55-+ +SELF,IF=AST. 56 - *** Set up ASTCCH as the condition handler. 57 - CALL LIB$ESTABLISH(ASTCCH) 1 645 P=DRIFT D=DRFINP 2 PAGE 923 58-+ +SELF. 59 - CALL INPSTR(1,1,STRING,NC) 60 - *** Skip if the line is blank. 61 - IF(NWORD.EQ.0)GOTO 10 62 - *** Return to main program if & is the first character. 63 - IF(STRING(1:1).EQ.'&')THEN 64 - RETURN 65 - *** Look for the AREA instruction. 66 - ELSEIF(INPCMP(1,'AREA').NE.0)THEN 67 - CALL CELVIE(DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX) 68 - CALL INPERR 69 - *** ARRIVAL-TIME-DISTRIBUTION. 70 - ELSEIF(INPCMP(1,'ARR#IVAL-#TIME-#DISTRIBUTION').NE.0)THEN 71 - CALL DRFARR 72 - *** Cluster study. 73 - ELSEIF(INPCMP(1,'CL#USTERING-#HISTOGRAMS').NE.0)THEN 74 - CALL DRFCLS 75 - *** Look for the keyword DRIFT. 76 - ELSEIF(INPCMP(1,'DR#IFT').NE.0)THEN 77 - CALL DRFDRF 78 - *** Look for the EPSILON keyword. 79 - ELSEIF(INPCMP(1,'EPS#ILON').NE.0)THEN 80 - PRINT *,' !!!!!! DRFINP WARNING : This parameter should'// 81 - - ' be changed from INTEGRATION-PARAMETERS.' 82 - *** Look for the keyword GRAPHICS. 83 - ELSEIF(INPCMP(1,'GRA#PHICS-#INPUT').NE.0)THEN 84 - CALL DRFGRA 85 - *** Look for the keyword GRID. 86 - ELSEIF(INPCMP(1,'GRI#D').NE.0)THEN 87 - IF(NWORD.EQ.1)THEN 88 - WRITE(LUNOUT,1020) NGRIDX,NGRIDY 89 - ELSEIF(NWORD.EQ.2)THEN 90 - CALL INPCHK(2,1,IFAIL1) 91 - CALL INPRDI(2,NGRIDR,25) 92 - IF(NGRIDR.LE.1.OR.NGRIDR.GT.MXGRID) 93 - - CALL INPMSG(2,'GRID out of range 2 -> MXGRID.') 94 - IF(IFAIL1.NE.0.OR.NGRIDR.LE.1.OR.NGRIDR.GT.MXGRID)THEN 95 - PRINT *,' !!!!!! DRFINP WARNING : GRID statement', 96 - - ' ignored because of syntax or value errors.' 97 - ELSE 98 - NGRIDX=NGRIDR 99 - NGRIDY=NGRIDR 100 - ENDIF 101 - ELSEIF(NWORD.EQ.3)THEN 102 - CALL INPCHK(2,1,IFAIL1) 103 - CALL INPCHK(3,1,IFAIL2) 104 - CALL INPRDI(2,NGRDXR,25) 105 - CALL INPRDI(3,NGRDYR,25) 106 - IF(NGRDXR.LE.1.OR.NGRDXR.GT.MXGRID) 107 - - CALL INPMSG(2,'out of the range 2 -> MXGRID. ') 108 - IF(NGRDYR.LE.1.OR.NGRDYR.GT.MXGRID) 109 - - CALL INPMSG(2,'out of the range 2 -> MXGRID. ') 110 - IF(IFAIL1.NE.0.OR.NGRDXR.LE.1.OR.NGRDXR.GT.MXGRID.OR. 111 - - NGRDYR.LE.1.OR.NGRDYR.GT.MXGRID)THEN 112 - PRINT *,' !!!!!! DRFINP WARNING : GRID statement', 113 - - ' ignored because of syntax or value errors.' 114 - ELSE 115 - NGRIDX=NGRDXR 116 - NGRIDY=NGRDYR 117 - ENDIF 118 - ELSE 119 - PRINT *,' !!!!!! DRFINP WARNING : GRID requires 1'// 120 - - ' or 2 arguments ; the instruction is ignored.' 121 - ENDIF 122 - CALL INPERR 123 - *** Integration parameters. 124 - ELSEIF(INPCMP(1,'INT#EGRATION-#PARAMETERS').NE.0)THEN 125 - CALL DLCPAR 126 - *** Look for the keyword LINE and find NLINED. 127 - ELSEIF(INPCMP(1,'L#INES').NE.0)THEN 128 - IF(NWORD.EQ.1)THEN 129 - WRITE(LUNOUT,'('' Number of drift lines is '',I4, 130 - - ''.'')') NLINED 131 - ELSEIF(NWORD.EQ.2)THEN 132 - CALL INPCHK(2,1,IFAIL1) 133 - CALL INPRDI(2,NLINER,0) 134 - IF(IFAIL1.EQ.0.AND.NLINER.LE.0)CALL INPMSG(2, 135 - - 'number of drift lines not > 0 ') 136 - IF(IFAIL1.NE.0.OR.NLINER.LE.0)THEN 137 - PRINT *,' !!!!!! DRFINP WARNING : LINES is'// 138 - - ' ignored because of (syntax) errors.' 139 - ELSE 140 - NLINED=NLINER 141 - ENDIF 142 - ELSE 143 - PRINT *,' !!!!!! DRFINP WARNING : LINES needs one'// 144 - - ' argument ; instruction is ignored.' 145 - ENDIF 146 - CALL INPERR 147 - *** Print the Lorentz angle. 148 - ELSEIF(INPCMP(1,'LO#RENTZ-#ANGLE').NE.0)THEN 149 - IF(.NOT.MAGOK)THEN 150 - PRINT *,' ------ DRFINP MESSAGE : The magnetic field'// 151 - - ' is off; Lorentz angle by definition zero.' 152 - ELSEIF(NWORD.LT.3.OR.NWORD.GT.4)THEN 153 - PRINT *,' !!!!!! DRFINP WARNING : The LORENT-ANGLE'// 154 - - ' instruction takes 2 arguments; ignored.' 155 - ELSE 156 - CALL INPCHK(2,2,IFAIL1) 157 - CALL INPCHK(3,2,IFAIL2) 158 - CALL INPCHK(4,2,IFAIL3) 159 - CALL INPRDR(2,XTEST,0.0) 160 - CALL INPRDR(3,YTEST,0.0) 161 - CALL INPRDR(4,ZTEST,0.0) 162 - IF(IFAIL1+IFAIL2+IFAIL3.NE.0)THEN 163 - PRINT *,' !!!!!! DRFINP WARNING : LORENTZ-ANGLE'// 1 645 P=DRIFT D=DRFINP 3 PAGE 924 164 - - ' ignored because of syntax errors.' 165 - CALL INPERR 166 - GOTO 10 167 - ENDIF 168 - IF(POLAR)THEN 169 - CALL CFMPTR(XTEST,YTEST,XTEST,YTEST,1,IFAIL) 170 - IF(IFAIL.NE.0)THEN 171 - PRINT *,' ++++++ DRFINP DEBUG : Illegal'// 172 - - ' coordinates; no output.' 173 - CALL INPERR 174 - GOTO 10 175 - ENDIF 176 - ENDIF 177 - CALL EFIELD(XTEST,YTEST,ZTEST, 178 - - EXTEST,EYTEST,EZTEST,ETEST,VOLT, 179 - - 0,ILOC1) 180 - CALL DLCVEL(DBLE(XTEST),DBLE(YTEST),DBLE(ZTEST), 181 - - VTEST,-1.0,1,ILOC2) 182 - IF(ILOC1.NE.0.OR.ILOC2.NE.0.OR.ETEST.EQ.0.OR. 183 - - VTEST(1)**2+VTEST(2)**2.EQ.0)THEN 184 - PRINT *,' !!!!!! DRFINP WARNING : Lorentz angle'// 185 - - ' not computed (e.g. in a wire).' 186 - ELSE 187 - WRITE(LUNOUT,'(/'' Lorentz angle is: '',E15.8, 188 - - '' degrees.'')') 180.0*ACOS(MAX(-1.0,MIN(1.0, 189 - - REAL((EXTEST*VTEST(1)+EYTEST*VTEST(2)+ 190 - - EZTEST*VTEST(3))/(ETEST*(SQRT(VTEST(1)**2+ 191 - - VTEST(2)**2+VTEST(3)**2)))))))/PI 192 - ENDIF 193 - ENDIF 194 - CALL INPERR 195 - *** Minimisation. 196 - ELSEIF(INPCMP(1,'MIN#IMISE').NE.0)THEN 197 - CALL DRFMIN 198 - *** Look for the keyword OPTIONS: 199 - ELSEIF(INPCMP(1,'OPT#IONS').NE.0)THEN 200 - IF(NWORD.EQ.1)THEN 201 - WRITE(LUNOUT,'(/ 202 - - '' LOCAL OPTIONS CURRENTLY IN EFFECT:''// 203 - - '' Plotting of the drift lines'', 204 - - '' (DRIFT-PLOT): '',L1/ 205 - - '' Printing of drift line details'', 206 - - '' (DRIFT-PRINT): '',L1/ 207 - - '' Plotting of a table of contour'', 208 - - '' heights (KEY): '',L1/ 209 - - '' Contour all media (T) or drift'', 210 - - '' medium (F): '',L1/ 211 - - '' Plot wires by markers'', 212 - - '' (WIRE-MARKERS): '',L1/ 213 - - '' Check for multiple field map indices:'', 214 - - '' '',L1/)') 215 - - LDRPLT,LDRPRT,LKEYPL,LCNTAM,LWRMRK,LMAPCH 216 - ELSE 217 - DO 40 I=2,NWORD 218 - * search for plotting of drift lines option, 219 - IF(INPCMP(I,'NOD#RIFT-PL#OT').NE.0)THEN 220 - LDRPLT=.FALSE. 221 - ELSEIF(INPCMP(I,'D#RIFT-PL#OT').NE.0)THEN 222 - LDRPLT=.TRUE. 223 - * search for printing-of-drift lines option 224 - ELSEIF(INPCMP(I,'NOD#RIFT-PR#INT').NE.0)THEN 225 - LDRPRT=.FALSE. 226 - ELSEIF(INPCMP(I,'D#RIFT-PR#INT').NE.0)THEN 227 - LDRPRT=.TRUE. 228 - * Look for the contour key plotting option. 229 - ELSEIF(INPCMP(I,'NOK#EY-#PLOT').NE.0)THEN 230 - LKEYPL=.FALSE. 231 - ELSEIF(INPCMP(I,'K#EY-#PLOT').NE.0)THEN 232 - LKEYPL=.TRUE. 233 - * Contour drawing options. 234 - ELSEIF(INPCMP(I,'CONT#OUR-ALL-#MEDIA').NE.0)THEN 235 - LCNTAM=.TRUE. 236 - ELSEIF(INPCMP(I,'CONT#OUR-DR#IFT-#MEDIUM')+ 237 - - INPCMP(I,'CONT#OUR-DR#IFT-#MEDIA').NE.0)THEN 238 - LCNTAM=.FALSE. 239 - * Wires drawn as markers. 240 - ELSEIF(INPCMP(I,'NOW#IRE-M#ARKERS').NE.0)THEN 241 - LWRMRK=.FALSE. 242 - ELSEIF(INPCMP(I,'W#IRE-M#ARKERS').NE.0)THEN 243 - LWRMRK=.TRUE. 244 - * Detect multiple map indices. 245 - ELSEIF(INPCMP(I,'CH#ECK-MAP-#INDICES')+ 246 - - INPCMP(I,'CH#ECK-MAP-#INDEXING').NE.0)THEN 247 - LMAPCH=.TRUE. 248 - ELSEIF(INPCMP(I,'NOCH#ECK-MAP-#INDICES')+ 249 - - INPCMP(I,'NOCH#ECK-MAP-#INDEXING').NE.0)THEN 250 - LMAPCH=.FALSE. 251 - * Invalid option if not yet recognised. 252 - ELSE 253 - CALL INPMSG(I,'the option is not known. ') 254 - ENDIF 255 - 40 CONTINUE 256 - ENDIF 257 - CALL INPERR 258 - *** PLOT: plot various drift related items. 259 - ELSEIF(INPCMP(1,'PL#OT-#FIELD').NE.0)THEN 260 - CALL DRFPLT 261 - *** PREPARE-TRACK: Prepare a drifting information table. 262 - ELSEIF(INPCMP(1,'PR#EPARE-#TRACK').NE.0.AND..NOT.TRFLAG(1))THEN 263 - PRINT *,' !!!!!! DRFINP WARNING : Track preparation'// 264 - - ' must be done after track definition.' 265 - * Track has indeed been defined. 266 - ELSEIF(INPCMP(1,'PR#EPARE-#TRACK').NE.0)THEN 267 - * Initial option values. 268 - LDIFF=GASOK(3) 269 - LTOWN=GASOK(4) 1 645 P=DRIFT D=DRFINP 4 PAGE 925 270 - LATTA=GASOK(6) 271 - NLTR=NLINED 272 - * Flag recognised keywords. 273 - DO 30 I=1,NWORD+3 274 - FLAG(I)=.FALSE. 275 - IF(INPCMP(I,'A#TTACHMENT-#COEFFICIENT')+ 276 - - INPCMP(I,'D#IFFUSION-#COEFFICIENT')+ 277 - - INPCMP(I,'L#INES')+ 278 - - INPCMP(I,'NOA#TTACHMENT-#COEFFICIENT')+ 279 - - INPCMP(I,'NOD#IFFUSION-#COEFFICIENT')+ 280 - - INPCMP(I,'NOT#OWNSEND-#COEFFICIENT')+ 281 - - INPCMP(I,'T#OWNSEND-#COEFFICIENT').NE.0)FLAG(I)=.TRUE. 282 - 30 CONTINUE 283 - * Loop over the parameter string. 284 - INEXT=2 285 - DO 20 I=2,NWORD 286 - IF(I.LT.INEXT)GOTO 20 287 - * Check for the number of drift-lines to be used. 288 - IF(INPCMP(I,'L#INES').NE.0)THEN 289 - IF(I+1.GT.NWORD.OR.FLAG(I+1))THEN 290 - CALL INPMSG(I,'The argument is missing. ') 291 - ELSEIF(INPTYP(I+1).LE.0)THEN 292 - CALL INPMSG(I+1,'The argument is not numeric. ') 293 - INEXT=I+2 294 - ELSE 295 - CALL INPCHK(I+1,1,IFAIL) 296 - CALL INPRDI(I+1,NLTRR,NLTR) 297 - IF(IFAIL.EQ.0.AND.NLTRR.LT.4)THEN 298 - CALL INPMSG(I+1, 299 - - 'At least 4 lines are needed. ') 300 - ELSEIF(IFAIL.EQ.0.AND.NLTRR.GT.MXLIST-4)THEN 301 - CALL INPMSG(I+1, 302 - - 'Not more than MXLIST-4 lines. ') 303 - ELSEIF(IFAIL.EQ.0)THEN 304 - NLTR=NLTRR 305 - ENDIF 306 - INEXT=I+2 307 - ENDIF 308 - * Check for the diffusion options. 309 - ELSEIF(INPCMP(I,'D#IFFUSION-#COEFFICIENT').NE.0)THEN 310 - IF(.NOT.GASOK(3))THEN 311 - CALL INPMSG(I,'No diffusion data are present.') 312 - ELSE 313 - LDIFF=.TRUE. 314 - ENDIF 315 - ELSEIF(INPCMP(I,'NOD#IFFUSION-#COEFFICIENT').NE.0)THEN 316 - LDIFF=.FALSE. 317 - * Check for the Townsend options. 318 - ELSEIF(INPCMP(I,'T#OWNSEND-#COEFFICIENT').NE.0)THEN 319 - IF(.NOT.GASOK(4))THEN 320 - CALL INPMSG(I,'No Townsend data are present. ') 321 - ELSE 322 - LTOWN=.TRUE. 323 - ENDIF 324 - ELSEIF(INPCMP(I,'NOT#OWNSEND-#COEFFICIENT').NE.0)THEN 325 - LTOWN=.FALSE. 326 - * Check for the attachment options. 327 - ELSEIF(INPCMP(I,'A#TTACHMENT-#COEFFICIENT').NE.0)THEN 328 - IF(.NOT.GASOK(6))THEN 329 - CALL INPMSG(I,'No attachment data are present') 330 - ELSE 331 - LATTA=.TRUE. 332 - ENDIF 333 - ELSEIF(INPCMP(I,'NOA#TTACHMENT-#COEFFICIENT').NE.0)THEN 334 - LATTA=.FALSE. 335 - * Unrecognised option. 336 - ELSE 337 - CALL INPMSG(I,'Invalid option, ignored. ') 338 - ENDIF 339 - 20 CONTINUE 340 - * Dump error messages. 341 - CALL INPERR 342 - * Call the preparation routine with proper arguments. 343 - CALL DLCTRP(XT0,YT0,ZT0,XT1,YT1,ZT1,LDIFF,LTOWN,LATTA,NLTR, 344 - - TMIN,TMAX,SMIN,SMAX,AMIN,AMAX,BMIN,BMAX,IFAIL) 345 - *** Look for the SELECT instruction. 346 - ELSEIF(INPCMP(1,'SEL#ECT').NE.0)THEN 347 - CALL CELSEL 348 - *** Test drift line calculation. 349 - ELSEIF(INPCMP(1,'SIN#GLE').NE.0)THEN 350 - CALL DRFSIN 351 - *** Test drift speed calculation. 352 - ELSEIF(INPCMP(1,'SP#EED').NE.0)THEN 353 - PRINT *,' ++++++ DRFINP DEBUG : SPEED start.' 354 - QTEST=-1.0 355 - ITEST=1 356 - CALL INPCHK(2,2,IFAIL1) 357 - CALL INPCHK(3,2,IFAIL2) 358 - CALL INPCHK(4,2,IFAIL3) 359 - CALL INPRDR(2,XTEST,0.0) 360 - CALL INPRDR(3,YTEST,0.0) 361 - CALL INPRDR(4,ZTEST,0.0) 362 - DO 60 I=5,NWORD 363 - IF(INPCMP(I,'E#LECTRON').NE.0)THEN 364 - ITEST=1 365 - ELSEIF(INPCMP(I,'I#ON').NE.0)THEN 366 - IF(GASOK(2))THEN 367 - ITEST=2 368 - ELSE 369 - CALL INPMSG(I,'ion mobility data missing. ') 370 - ENDIF 371 - ELSEIF(INPCMP(I,'POS#ITIVE').NE.0)THEN 372 - QTEST=+1.0 373 - ELSEIF(INPCMP(I,'NEG#ATIVE').NE.0)THEN 374 - QTEST=-1.0 375 - ELSE 1 645 P=DRIFT D=DRFINP 5 PAGE 926 376 - CALL INPMSG(I,'The option is not known. ') 377 - ENDIF 378 - 60 CONTINUE 379 - CALL INPERR 380 - IF(IFAIL1+IFAIL2+IFAIL3.NE.0)GOTO 10 381 - IF(POLAR)THEN 382 - CALL CFMPTR(XTEST,YTEST,XTEST,YTEST,1,IFAIL) 383 - IF(IFAIL.NE.0)THEN 384 - PRINT *,' ++++++ DRFINP DEBUG : Illegal'// 385 - - ' coordinates; no output.' 386 - GOTO 10 387 - ENDIF 388 - ENDIF 389 - CALL DLCVEL(DBLE(XTEST),DBLE(YTEST),DBLE(ZTEST), 390 - - VTEST,QTEST,ITEST,ILOC) 391 - PRINT 3030,(VTEST(I),I=1,3),PGAS 392 - 3030 FORMAT(' Vx=',E15.8,' Vy=',E15.8,' Vz=',E15.8, 393 - - ' PGAS=',F10.1) 394 - IF(POLAR)PRINT *,' (These are internal velocity components)' 395 - PRINT *,' ++++++ DRFINP DEBUG : SPEED end.' 396 - *** Drift time table printing. 397 - ELSEIF(INPCMP(1,'TAB#LE').NE.0)THEN 398 - CALL DRFTAB 399 - *** Time drift line calculation. 400 - ELSEIF(INPCMP(1,'TIME').NE.0)THEN 401 - PRINT *,' ++++++ DRFINP DEBUG : TIME start.' 402 - CALL INPCHK(2,1,IFAIL1) 403 - CALL INPRDI(2,NTEST,10) 404 - CALL INPERR 405 - QTEST=-1.0 406 - PRINT *,' Drift line table:' 407 - PRINT *,' ' 408 - CALL TIMED(CPU) 409 - DO 3050 I=1,NTEST 410 - XTEST=DXMIN+RNDM(I) *(DXMAX-DXMIN) 411 - YTEST=DYMIN+RNDM(I+1)*(DYMAX-DYMIN) 412 - CALL DLCALC(XTEST,YTEST,0.0,QTEST,1) 413 - 3060 FORMAT(' Line ',I3,' steps=',I3,' start at (x,y)=',2F15.8, 414 - - ' drift time=',F15.8,' microsec') 415 - 3065 FORMAT(' Line ',I3,' steps=',I3,' start at (r,phi)=',2F15.8, 416 - - ' drift time=',F15.8,' microsec') 417 - IF(POLAR)THEN 418 - CALL CFMRTP(XTEST,YTEST,XTEST,YTEST,1) 419 - PRINT 3065,I,NU,XTEST,YTEST,TU(NU) 420 - ELSE 421 - PRINT 3060,I,NU,XTEST,YTEST,TU(NU) 422 - ENDIF 423 - 3050 CONTINUE 424 - CALL TIMED(CPU) 425 - PRINT *,' ' 426 - PRINT *,' Total CPU time used=',CPU,' seconds' 427 - CALL TIMLOG('< TIME: drift lines > ') 428 - PRINT *,' ++++++ DRFINP DEBUG : TIME end.' 429 - *** Timing distributions. 430 - ELSEIF(INPCMP(1,'TIMING-#HISTOGRAMS').NE.0)THEN 431 - CALL DRFTIM 432 - *** Look for the instruction TRACK. 433 - ELSEIF(INPCMP(1,'TR#ACK').NE.0)THEN 434 - CALL TRAREA 435 - *** Look for the TRAP instruction. 436 - ELSEIF(INPCMP(1,'TRAP').NE.0)THEN 437 - PRINT *,' !!!!!! DRFINP WARNING : This parameter should'// 438 - - ' changed from INTEGRATION-PARAMETERS.' 439 - *** Read track information from a dataset if GET is the command. 440 - ELSEIF(INPCMP(1,'GET-TR#ACK').NE.0)THEN 441 - CALL DLCTRG(IFAIL) 442 - *** Write the track data if WRITE-TRACK is a keyword. 443 - ELSEIF(INPCMP(1,'WR#ITE-T#RACK').NE.0)THEN 444 - CALL DLCTRW 445 - *** Search for the XTPLOT instruction. 446 - ELSEIF(INPCMP(1,'XT-#PLOT').NE.0)THEN 447 - IF(POLAR)THEN 448 - PRINT *,' !!!!!! DRFINP WARNING : This instruction'// 449 - - ' is not valid for polar cells; not executed.' 450 - ELSE 451 - CALL DRFXTP 452 - ENDIF 453 - *** Writing out of equal time contours. 454 - ELSEIF(INPCMP(1,'WR#ITE-EQ#UAL-TIM#E-#CONTOURS')+ 455 - - INPCMP(1,'WR#ITE-ISO#CHRONES').NE.0)THEN 456 - CALL DRFEQW 457 - *** It is not possible to get here if the keyword is recognised. 458 - ELSE 459 - CALL INPSTR(1,1,STRING,NC) 460 - PRINT *,' !!!!!! DRFINP WARNING : '//STRING(1:NC)//' is'// 461 - - ' not a valid instruction ; it is ignored.' 462 - ENDIF 463 - *** End of the loop; go for another iteration. 464 - GOTO 10 465 - END 646 GARFIELD ================================================== P=DRIFT D=DRFARR 1 ============================ 0 + +DECK,DRFARR. 1 - SUBROUTINE DRFARR 2 - *----------------------------------------------------------------------- 3 - * DRFARR - Computes the arrival time distribution of the M'th electron 4 - * from a given track. 5 - * VARIABLES : 6 - * (Last changed on 8/ 2/00.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,SOLIDS. 1 646 P=DRIFT D=DRFARR 2 PAGE 927 12.- +SEQ,GASDATA. 13.- +SEQ,DRIFTLINE. 14.- +SEQ,PARAMETERS. 15.- +SEQ,PRINTPLOT. 16.- +SEQ,CONSTANTS. 17 - INTEGER MXELEC 18 - PARAMETER(MXELEC=10) 19 - *** Declarations, start setting the max number of histogram channels. 20 - CHARACTER*(MXCHAR) STRING 21 - CHARACTER*(MXNAME) FILE 22 - CHARACTER*80 TITLE 23 - CHARACTER*29 REMARK 24 - CHARACTER*15 STR1,STR2,STR3,STR4,STRID 25 - CHARACTER*8 TIME,DATE,MEMBER 26 - CHARACTER*1 STEP,SCAN 27 - REAL ARRTIM(2,MXPART),XPL(MXLIST),YPL(MXLIST),THRESH,THRR, 28 - - ARRLIS(MXLIST,4+3*MXELEC),TSTEP,TEMIN,TEMAX,TGMIN,TGMAX, 29 - - UARMIN,UARMAX,VARMIN,VARMAX,UARMIR,UARMAR,VARMIR,VARMAR, 30 - - UAROFF,WAROFF,XW,YW,ZW, 31 - - USTEP,USTEPR,TANPHI,ANGLER,TFORC1,TFORC2,XCL,YCL,ZCL,ECL, 32 - - ACL,BCL,FCL,SCL,TCL,RNDNOR,HGMIN,HGMAX,HEMIN,HEMAX, 33 - - SMIN,SMAX,AMIN,AMAX,BMIN,BMAX,TMAX 34 - INTEGER ARRFLG(MXLIST),IRFTEL(MXELEC),IRFXEL(MXELEC), 35 - - IRFXGL,IRFTGL,IRFNCL,IRFNEL,NCLUS,NCHA,NCHAR,NPLOT, 36 - - MELEC(MXELEC),NELEC(MXELEC),ISIZ(1),IDIM(1),NCFILE,NCMEMB, 37 - - NCREM,NLTR,NLTRR,JSEL,JALL,JOVER, 38 - - INEXT,NWORD,NRNDM,NRNDMR,IORDER, 39 - - IORDR,KELEC,MR,IW,ISWCNT,IXM,IXP,IX,IFAIL,IFAIL1,IFAIL2, 40 - - IFAIL3,IFAIL4,IFAIL5,IFAIL6,NGLOB,NPART,IPRT,IRNDM,NPAIR, 41 - - ICL,ICLS,INPCMP,INPTYP,NGBIN,I,J,K,II, 42 - - NGENT,NEBIN,NEENT,NC1,NC2,NC3,NC4,NCID,NC,IOS,IPLANE,ISOLID 43 - LOGICAL FLAG(MXWORD+3),LARRWR,LGLBPL,LELEPL,LARRPL,TEAUTO,TGAUTO, 44 - - LGLBPR,LELEPR,LARRPR,WFORCE,LHISKP,LEXIST,LSET,LDIFF, 45 - - LATTAC,LARRKP,DONE,OK,EXMEMB 46 - EXTERNAL RNDNOR,INPCMP,INPTYP 0 47-+ +SELF,IF=SAVE. 48 - SAVE NRNDM,NCHA,KELEC,MELEC,TANPHI,LGLBPL,LELEPL,LARRPL,THRESH, 49 - - IORDER,LGLBPR,LELEPR,LARRPR,TEAUTO,TGAUTO,LHISKP, 50 - - LARRKP 0 51-+ +SELF. 52 - *** Initialise those variables that are kept across calls. 53 - DATA NRNDM /1000/, NCHA /100/, IORDER /2/ 54 - DATA KELEC /1/, MELEC /MXELEC*25/ 55 - DATA TANPHI /0.0/, THRESH /0.5 / 56 - DATA LGLBPL /.FALSE./, LELEPL /.FALSE./, LARRPL /.TRUE./ 57 - DATA LGLBPR /.FALSE./, LELEPR /.FALSE./, LARRPR /.FALSE./ 58 - DATA TEAUTO /.TRUE. /, TGAUTO /.FALSE./, LATTAC /.FALSE./ 59 - DATA LHISKP /.FALSE./, LARRKP /.FALSE./ 60 - *** Make sure the cell is not in polar coordinates. 61 - IF(POLAR)THEN 62 - PRINT *,' ###### DRFARR ERROR : The ARRIVAL function'// 63 - - ' can not be applied to polar geometries.' 64 - RETURN 65 - ENDIF 66 - *** Initialise various variables being reset at each call. 67 - FILE=' ' 68 - MEMBER='< none >' 69 - REMARK='None' 70 - NCFILE=1 71 - NCMEMB=8 72 - NCREM=4 73 - LARRWR=.FALSE. 74 - STEP='X' 75 - SCAN='Y' 76 - UARMIN=DXMIN 77 - UARMAX=DXMAX 78 - VARMIN=DYMIN 79 - VARMAX=DYMAX 80 - WAROFF=0 81 - CALL ROUND(UARMIN,UARMAX,20,'SMALLER,COARSER',USTEP) 82 - NLTR=NLINED 83 - WFORCE=.FALSE. 84 - TFORC1=-1.0 85 - TFORC2=-1.0 86 - JSEL=0 87 - JALL=0 88 - JOVER=0 89 - LDIFF=GASOK(3) 90 - OK=.TRUE. 91 - *** Examine the input line, flag the known words. 92 - CALL INPNUM(NWORD) 93 - DO 10 I=2,NWORD 94 - IF( INPCMP(I,'ATT#ACHMENT')+INPCMP(I,'NOATT#ACHMENT')+ 95 - - INPCMP(I,'BIN#S')+ 96 - - INPCMP(I,'DA#TASET')+INPCMP(I,'REM#ARK')+ 97 - - INPCMP(I,'DIFF#USION')+INPCMP(I,'NODIFF#USION')+ 98 - - INPCMP(I,'EL#ECTRONS')+ 99 - - INPCMP(I,'ITER#ATE')+INPCMP(I,'ITER#ATIONS')+ 100 - - INPCMP(I,'KEEP-HIST#OGRAMS')+INPCMP(I,'NOKEEP-HIST#OGRAMS')+ 101 - - INPCMP(I,'KEEP-RES#ULTS')+INPCMP(I,'NOKEEP-RES#ULTS')+ 102 - - INPCMP(I,'LIN#ES')+ 103 - - INPCMP(I,'PL#OT-ALL-#ELECTRONS')+ 104 - - INPCMP(I,'NOPL#OT-ALL-#ELECTRONS')+ 105 - - INPCMP(I,'PL#OT-SEL#ECTED-#ELECTRONS')+ 106 - - INPCMP(I,'NOPL#OT-SEL#ECTED-#ELECTRONS')+ 107 - - INPCMP(I,'OFF#SET')+ 108 - - INPCMP(I,'PL#OT-O#VERVIEW')+INPCMP(I,'NOPL#OT-O#VERVIEW')+ 109 - - INPCMP(I,'POL#YNOMIAL-ORD#ER')+ 110 - - INPCMP(I,'PR#INT-ALL-#ELECTRONS')+ 111 - - INPCMP(I,'NOPR#INT-ALL-#ELECTRONS')+ 112 - - INPCMP(I,'PR#INT-SEL#ECTED-#ELECTRONS')+ 113 - - INPCMP(I,'NOPR#INT-SEL#ECTED-#ELECTRONS')+ 114 - - INPCMP(I,'PR#INT-O#VERVIEW')+INPCMP(I,'NOPR#INT-O#VERVIEW')+ 115 - - INPCMP(I,'SC#AN')+INPCMP(I,'ST#EP')+ 1 646 P=DRIFT D=DRFARR 3 PAGE 928 116 - - INPCMP(I,'THR#ESHOLD')+INPCMP(I,'T#IME-WIN#DOW').NE.0)THEN 117 - FLAG(I)=.TRUE. 118 - ELSE 119 - FLAG(I)=.FALSE. 120 - ENDIF 121 - 10 CONTINUE 122 - FLAG(NWORD+1)=.TRUE. 123 - FLAG(NWORD+2)=.TRUE. 124 - FLAG(NWORD+3)=.TRUE. 125 - INEXT=2 126 - *** Read in detail. 127 - DO 20 I=2,NWORD 128 - IF(I.LT.INEXT)GOTO 20 129 - ** Time window. 130 - IF(INPCMP(I,'T#IME-WIN#DOW').NE.0)THEN 131 - IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN 132 - TEAUTO=.TRUE. 133 - WFORCE=.FALSE. 134 - INEXT=I+2 135 - ELSEIF(INPCMP(I+1,'FULL-#RANGE').NE.0)THEN 136 - TEAUTO=.FALSE. 137 - WFORCE=.FALSE. 138 - INEXT=I+2 139 - ELSEIF(I+2.GT.NWORD.OR.FLAG(I+1).OR.FLAG(I+2))THEN 140 - CALL INPMSG(I,'This keyword has 2 arguments. ') 141 - OK=.FALSE. 142 - INEXT=I+3 143 - ELSEIF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2)THEN 144 - CALL INPMSG(I+1,'This should be a real argument') 145 - OK=.FALSE. 146 - INEXT=I+3 147 - ELSEIF(INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2)THEN 148 - CALL INPMSG(I+2,'This should be a real argument') 149 - OK=.FALSE. 150 - INEXT=I+3 151 - ELSE 152 - CALL INPCHK(I+1,2,IFAIL1) 153 - CALL INPCHK(I+2,2,IFAIL2) 154 - CALL INPRDR(I+1,TFORC1,-1.0) 155 - CALL INPRDR(I+2,TFORC2,-1.0) 156 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR. 157 - - TFORC1.LT.0.0.OR.TFORC2.LT.0.0.OR. 158 - - TFORC1.EQ.TFORC2)THEN 159 - CALL INPMSG(I+1,'Window incorrectly specified. ') 160 - CALL INPMSG(I+2,'(See preceding message.) ') 161 - OK=.FALSE. 162 - ELSE 163 - WFORCE=.TRUE. 164 - TEAUTO=.FALSE. 165 - ENDIF 166 - INEXT=I+3 167 - ENDIF 168 - ** The BINS keyword. 169 - ELSEIF(INPCMP(I,'BIN#S').NE.0)THEN 170 - IF(I+1.GT.NWORD.OR.FLAG(I+1))THEN 171 - CALL INPMSG(I,'This keyword has one argument.') 172 - OK=.FALSE. 173 - ELSEIF(INPTYP(I+1).NE.1)THEN 174 - CALL INPMSG(I+1,'This is an integer argument. ') 175 - OK=.FALSE. 176 - ELSE 177 - CALL INPCHK(I+1,1,IFAIL) 178 - CALL INPRDI(I+1,NCHAR,MXCHA) 179 - IF(NCHAR.LE.1.OR.NCHAR.GT.MXCHA)THEN 180 - CALL INPMSG(I+1,'Inacceptable number of bins. ') 181 - OK=.FALSE. 182 - ELSE 183 - NCHA=NCHAR 184 - ENDIF 185 - ENDIF 186 - INEXT=I+2 187 - ** Histogram keeping option. 188 - ELSEIF(INPCMP(I,'KEEP-HIST#OGRAMS').NE.0)THEN 189 - LHISKP=.TRUE. 190 - ELSEIF(INPCMP(I,'NOKEEP-HIST#OGRAMS').NE.0)THEN 191 - LHISKP=.FALSE. 192 - ** Results keeping option. 193 - ELSEIF(INPCMP(I,'KEEP-RES#ULTS').NE.0)THEN 194 - LARRKP=.TRUE. 195 - ELSEIF(INPCMP(I,'NOKEEP-RES#ULTS').NE.0)THEN 196 - LARRKP=.FALSE. 197 - ** Read the output data set name. 198 - ELSEIF(INPCMP(I,'DA#TASET').NE.0)THEN 199 - IF(FLAG(I+1))THEN 200 - CALL INPMSG(I,'Should have an argument. ') 201 - OK=.FALSE. 202 - ELSE 203 - CALL INPSTR(I+1,I+1,STRING,NCFILE) 204 - FILE=STRING 205 - INEXT=I+2 206 - IF(.NOT.FLAG(I+2))THEN 207 - CALL INPSTR(I+2,I+2,STRING,NCMEMB) 208 - MEMBER=STRING 209 - INEXT=I+3 210 - ENDIF 211 - LARRWR=.TRUE. 212 - ENDIF 213 - ** Read the first and last particle to be considered. 214 - ELSEIF(INPCMP(I,'EL#ECTRONS').NE.0)THEN 215 - KELEC=0 216 - DO 21 J=I+1,NWORD 217 - IF(FLAG(J))THEN 218 - GOTO 22 219 - ELSEIF(KELEC.GE.MXELEC)THEN 220 - CALL INPMSG(J,'No room to store this electron') 221 - OK=.FALSE. 1 646 P=DRIFT D=DRFARR 4 PAGE 929 222 - GOTO 21 223 - ELSE 224 - KELEC=KELEC+1 225 - ENDIF 226 - IF(INPCMP(J,'L#AST').NE.0)THEN 227 - MELEC(KELEC)=0 228 - INEXT=J+1 229 - ELSEIF(INPCMP(J,'ONE-B#UT-#LAST').NE.0)THEN 230 - MELEC(KELEC)=-1 231 - INEXT=J+1 232 - ELSEIF(INPCMP(J,'TW#O-B#UT-#LAST').NE.0)THEN 233 - MELEC(KELEC)=-2 234 - INEXT=J+1 235 - ELSEIF(INPCMP(J,'TH#REE-B#UT-#LAST').NE.0)THEN 236 - MELEC(KELEC)=-3 237 - INEXT=J+1 238 - ELSEIF(INPTYP(J).NE.1)THEN 239 - CALL INPMSG(J,'This argument is an integer. ') 240 - OK=.FALSE. 241 - INEXT=J 242 - KELEC=KELEC-1 243 - ELSE 244 - CALL INPCHK(J,1,IFAIL) 245 - CALL INPRDI(J,MR,5) 246 - IF(MR.LT.1-MXPART.AND.IFAIL.EQ.0)THEN 247 - CALL INPMSG(J,'Smaller than 1-MXPART. ') 248 - OK=.FALSE. 249 - KELEC=KELEC-1 250 - ELSEIF(MR.GT.MXPART.AND.IFAIL.EQ.0)THEN 251 - CALL INPMSG(J,'Larger than MXPART. ') 252 - OK=.FALSE. 253 - KELEC=KELEC-1 254 - ELSEIF(IFAIL.EQ.0)THEN 255 - MELEC(KELEC)=MR 256 - ENDIF 257 - INEXT=J+1 258 - ENDIF 259 - 21 CONTINUE 260 - 22 CONTINUE 261 - IF(KELEC.LE.0)THEN 262 - CALL INPMSG(I,'Should have an argument. ') 263 - OK=.FALSE. 264 - KELEC=1 265 - MELEC(1)=5 266 - ENDIF 267 - ** Number of lines to be used for track preparation. 268 - ELSEIF(INPCMP(I,'LINE#S').NE.0)THEN 269 - IF(FLAG(I+1))THEN 270 - CALL INPMSG(I,'Specify number of drift-lines.') 271 - OK=.FALSE. 272 - ELSEIF(INPTYP(I+1).NE.1)THEN 273 - CALL INPMSG(I,'This is an integer argument. ') 274 - OK=.FALSE. 275 - ELSE 276 - CALL INPCHK(I+1,1,IFAIL) 277 - CALL INPRDI(I+1,NLTRR,NLTR) 278 - IF(NLTRR.LT.4.AND.IFAIL.EQ.0)THEN 279 - CALL INPMSG(I+1,'At least 4 lines are needed. ') 280 - OK=.FALSE. 281 - ELSEIF(NLTRR.GT.MXLIST.AND.IFAIL.EQ.0)THEN 282 - CALL INPMSG(I+1,'Not more than MXLIST lines. ') 283 - OK=.FALSE. 284 - ELSEIF(IFAIL.EQ.0)THEN 285 - NLTR=NLTRR 286 - ENDIF 287 - INEXT=I+2 288 - ENDIF 289 - ** The ITERATIONS keyword. 290 - ELSEIF(INPCMP(I,'ITER#ATIONS')+INPCMP(I,'ITER#ATE').NE.0)THEN 291 - IF(I+1.GT.NWORD)THEN 292 - CALL INPMSG(I,'This keyword has one argument.') 293 - OK=.FALSE. 294 - ELSEIF(INPTYP(I+1).NE.1)THEN 295 - CALL INPMSG(I,'This is an integer argument. ') 296 - OK=.FALSE. 297 - ELSE 298 - CALL INPCHK(I+1,1,IFAIL) 299 - CALL INPRDI(I+1,NRNDMR,NRNDM) 300 - IF(NRNDMR.LT.1)THEN 301 - CALL INPMSG(I+1,'At least 1 iteration needed. ') 302 - OK=.FALSE. 303 - ELSE 304 - NRNDM=NRNDMR 305 - ENDIF 306 - ENDIF 307 - INEXT=I+2 308 - ** Include diffusion and attachment, if required. 309 - ELSEIF(INPCMP(I,'DIFF#USION').NE.0)THEN 310 - IF(GASOK(3))THEN 311 - LDIFF=.TRUE. 312 - ELSE 313 - CALL INPMSG(I,'No diffusion data available.') 314 - OK=.FALSE. 315 - ENDIF 316 - ELSEIF(INPCMP(I,'NODIFF#USION').NE.0)THEN 317 - LDIFF=.FALSE. 318 - ELSEIF(INPCMP(I,'ATT#ACHMENT').NE.0)THEN 319 - IF(GASOK(6))THEN 320 - LATTAC=.TRUE. 321 - ELSE 322 - CALL INPMSG(I,'No attachment data available.') 323 - OK=.FALSE. 324 - ENDIF 325 - ELSEIF(INPCMP(I,'NOATT#ACHMENT').NE.0)THEN 326 - LATTAC=.FALSE. 327 - ** Plot options. 1 646 P=DRIFT D=DRFARR 5 PAGE 930 328 - ELSEIF(INPCMP(I,'PL#OT-ALL-#ELECTRONS').NE.0)THEN 329 - LGLBPL=.TRUE. 330 - ELSEIF(INPCMP(I,'NOPL#OT-ALL-#ELECTRONS').NE.0)THEN 331 - LGLBPL=.FALSE. 332 - ELSEIF(INPCMP(I,'PL#OT-SEL#ECTED-#ELECTRONS').NE.0)THEN 333 - LELEPL=.TRUE. 334 - ELSEIF(INPCMP(I,'NOPL#OT-SEL#ECTED-#ELECTRONS').NE.0)THEN 335 - LELEPL=.FALSE. 336 - ELSEIF(INPCMP(I,'PL#OT-O#VERVIEW').NE.0)THEN 337 - LARRPL=.TRUE. 338 - ELSEIF(INPCMP(I,'NOPL#OT-O#VERVIEW').NE.0)THEN 339 - LARRPL=.FALSE. 340 - ** Print options. 341 - ELSEIF(INPCMP(I,'PR#INT-ALL-#ELECTRONS').NE.0)THEN 342 - LGLBPR=.TRUE. 343 - ELSEIF(INPCMP(I,'NOPR#INT-ALL-#ELECTRONS').NE.0)THEN 344 - LGLBPR=.FALSE. 345 - ELSEIF(INPCMP(I,'PR#INT-SEL#ECTED-#ELECTRONS').NE.0)THEN 346 - LELEPR=.TRUE. 347 - ELSEIF(INPCMP(I,'NOPR#INT-SEL#ECTED-#ELECTRONS').NE.0)THEN 348 - LELEPR=.FALSE. 349 - ELSEIF(INPCMP(I,'PR#INT-O#VERVIEW').NE.0)THEN 350 - LARRPR=.TRUE. 351 - ELSEIF(INPCMP(I,'NOPR#INT-O#VERVIEW').NE.0)THEN 352 - LARRPR=.FALSE. 353 - ** The POLYNOMIAL-ORDER keyword. 354 - ELSEIF(INPCMP(I,'POL#YNOMIAL-ORD#ER').NE.0)THEN 355 - IF(I+1.GT.NWORD)THEN 356 - CALL INPMSG(I,'This keyword has one argument.') 357 - OK=.FALSE. 358 - ELSEIF(INPCMP(I+1,'LIN#EAR').NE.0)THEN 359 - IORDER=1 360 - INEXT=I+2 361 - ELSEIF(INPCMP(I+1,'QUAD#RATIC')+ 362 - - INPCMP(I+1,'PARA#BOLIC').NE.0)THEN 363 - IORDER=2 364 - INEXT=I+2 365 - ELSEIF(INPCMP(I+1,'CUB#IC').NE.0)THEN 366 - IORDER=3 367 - INEXT=I+2 368 - ELSEIF(INPTYP(I+1).NE.1)THEN 369 - CALL INPMSG(I,'This is an integer argument. ') 370 - OK=.FALSE. 371 - ELSE 372 - CALL INPCHK(I+1,1,IFAIL) 373 - CALL INPRDI(I+1,IORDR,IORDER) 374 - IF(IORDR.LT.1.OR.IORDR.GT.10)THEN 375 - CALL INPMSG(I+1,'Not in the range [1,10]. ') 376 - OK=.FALSE. 377 - ELSE 378 - IORDER=IORDR 379 - ENDIF 380 - INEXT=I+2 381 - ENDIF 382 - ** Read the remark to be added to the dataset. 383 - ELSEIF(INPCMP(I,'REM#ARK').NE.0)THEN 384 - IF(FLAG(I+1))THEN 385 - CALL INPMSG(I,'Should have an argument. ') 386 - OK=.FALSE. 387 - ELSE 388 - CALL INPSTR(I+1,I+1,STRING,NCREM) 389 - REMARK=STRING 390 - INEXT=I+2 391 - ENDIF 392 - ** Read the threshold value. 393 - ELSEIF(INPCMP(I,'THR#ESHOLD').NE.0)THEN 394 - IF(FLAG(I+1))THEN 395 - CALL INPMSG(I,'Should have an argument. ') 396 - OK=.FALSE. 397 - ELSE 398 - CALL INPCHK(I+1,2,IFAIL1) 399 - CALL INPRDR(I+1,THRR,THRESH) 400 - IF(IFAIL1.EQ.0.AND.(THRR.LE.0.0.OR.THRR.GE.1.0))THEN 401 - CALL INPMSG(I+1,'The threshold range is <0,1>. ') 402 - OK=.FALSE. 403 - ELSEIF(IFAIL1.EQ.0)THEN 404 - THRESH=THRR 405 - ENDIF 406 - INEXT=I+2 407 - ENDIF 408 - ** Stepping direction. 409 - ELSEIF(INPCMP(I,'ST#EP').NE.0)THEN 410 - * Find out direction. 411 - IF(INPCMP(I+1,'X').NE.0)THEN 412 - STEP='X' 413 - UARMIN=DXMIN 414 - UARMAX=DXMAX 415 - CALL ROUND(UARMIN,UARMAX,20,'SMALLER,COARSER',USTEP) 416 - ELSEIF(INPCMP(I+1,'Y').NE.0)THEN 417 - STEP='Y' 418 - UARMIN=DYMIN 419 - UARMAX=DYMAX 420 - CALL ROUND(UARMIN,UARMAX,20,'SMALLER,COARSER',USTEP) 421 - ELSEIF(INPCMP(I+1,'Z').NE.0)THEN 422 - STEP='Z' 423 - UARMIN=DZMIN 424 - UARMAX=DZMAX 425 - CALL ROUND(UARMIN,UARMAX,20,'SMALLER,COARSER',USTEP) 426 - ELSE 427 - CALL INPMSG(I,'Not followed by a direction.') 428 - OK=.FALSE. 429 - INEXT=I+1 430 - GOTO 20 431 - ENDIF 432 - INEXT=I+2 433 - * Scan the sub-keywords. 1 646 P=DRIFT D=DRFARR 6 PAGE 931 434 - DO 30 J=I+2,NWORD 435 - IF(J.LT.INEXT)GOTO 30 436 - IF(FLAG(J))THEN 437 - INEXT=J 438 - GOTO 20 439 - * Range. 440 - ELSEIF(INPCMP(J,'RAN#GE').NE.0)THEN 441 - IF(FLAG(J+1).OR.FLAG(J+2).OR. 442 - - (INPTYP(J+1).NE.1.AND.INPTYP(J+1).NE.2).OR. 443 - - (INPTYP(J+2).NE.1.AND.INPTYP(J+2).NE.2))THEN 444 - CALL INPMSG(J,'Should have 2 real arguments.') 445 - OK=.FALSE. 446 - ELSE 447 - CALL INPCHK(J+1,2,IFAIL1) 448 - CALL INPCHK(J+2,2,IFAIL2) 449 - IF(STEP.EQ.'X')THEN 450 - CALL INPRDR(J+1,UARMIR,DXMIN) 451 - CALL INPRDR(J+2,UARMAR,DXMAX) 452 - ELSEIF(STEP.EQ.'Y')THEN 453 - CALL INPRDR(J+1,UARMIR,DYMIN) 454 - CALL INPRDR(J+2,UARMAR,DYMAX) 455 - ELSEIF(STEP.EQ.'Z')THEN 456 - CALL INPRDR(J+1,UARMIR,DZMIN) 457 - CALL INPRDR(J+2,UARMAR,DZMAX) 458 - ENDIF 459 - IF(UARMIR.EQ.UARMAR)THEN 460 - CALL INPMSG(J+1,'Zero range not permitted.') 461 - CALL INPMSG(J+2,'See preceding message.') 462 - OK=.FALSE. 463 - ELSEIF((STEP.EQ.'X'.AND.( 464 - - MAX(UARMIR,UARMAR).LT.DXMIN.OR. 465 - - MIN(UARMIR,UARMAR).GT.DXMAX)).OR. 466 - - (STEP.EQ.'Y'.AND.( 467 - - MAX(UARMIR,UARMAR).LT.DYMIN.OR. 468 - - MIN(UARMIR,UARMAR).GT.DYMAX)).OR. 469 - - (STEP.EQ.'Z'.AND.( 470 - - MAX(UARMIR,UARMAR).LT.DZMIN.OR. 471 - - MIN(UARMIR,UARMAR).GT.DZMAX)))THEN 472 - CALL INPMSG(J+1,'Range not inside the area.') 473 - CALL INPMSG(J+2,'See preceding message.') 474 - OK=.FALSE. 475 - ELSE 476 - IF(STEP.EQ.'X')THEN 477 - UARMIN=MAX(DXMIN,MIN(UARMIR,UARMAR)) 478 - UARMAX=MIN(DXMAX,MAX(UARMIR,UARMAR)) 479 - ELSEIF(STEP.EQ.'Y')THEN 480 - UARMIN=MAX(DYMIN,MIN(UARMIR,UARMAR)) 481 - UARMAX=MIN(DYMAX,MAX(UARMIR,UARMAR)) 482 - ELSEIF(STEP.EQ.'Z')THEN 483 - UARMIN=MAX(DZMIN,MIN(UARMIR,UARMAR)) 484 - UARMAX=MIN(DZMAX,MAX(UARMIR,UARMAR)) 485 - ENDIF 486 - ENDIF 487 - INEXT=J+3 488 - ENDIF 489 - * Step size. 490 - ELSEIF(INPCMP(J,'INCR#EMENT').NE.0)THEN 491 - IF(FLAG(J+1).OR. 492 - - (INPTYP(J+1).NE.1.AND.INPTYP(J+1).NE.2))THEN 493 - CALL INPMSG(J,'Should have 1 real argument.') 494 - OK=.FALSE. 495 - ELSE 496 - CALL INPCHK(J+1,2,IFAIL) 497 - CALL INPRDR(J+1,USTEPR,USTEP) 498 - IF(USTEPR.LE.0)THEN 499 - CALL INPMSG(J+1, 500 - - 'The step size must be positive') 501 - OK=.FALSE. 502 - ELSE 503 - USTEP=USTEPR 504 - ENDIF 505 - INEXT=J+2 506 - ENDIF 507 - * Unknown sub-keyword. 508 - ELSE 509 - CALL INPMSG(J,'Not a sub-keyword of STEP.') 510 - ENDIF 511 - 30 CONTINUE 512 - ** Scanning direction. 513 - ELSEIF(INPCMP(I,'SC#AN').NE.0)THEN 514 - * Find out direction. 515 - IF(INPCMP(I+1,'X').NE.0)THEN 516 - SCAN='X' 517 - VARMIN=DXMIN 518 - VARMAX=DXMAX 519 - ELSEIF(INPCMP(I+1,'Y').NE.0)THEN 520 - SCAN='Y' 521 - VARMIN=DYMIN 522 - VARMAX=DYMAX 523 - ELSEIF(INPCMP(I+1,'Z').NE.0)THEN 524 - SCAN='Z' 525 - VARMIN=DZMIN 526 - VARMAX=DZMAX 527 - ELSE 528 - CALL INPMSG(I,'Not followed by a direction.') 529 - OK=.FALSE. 530 - INEXT=I+1 531 - GOTO 20 532 - ENDIF 533 - INEXT=I+2 534 - * Scan for sub-keywords. 535 - DO 40 J=I+2,NWORD 536 - IF(J.LT.INEXT)GOTO 40 537 - IF(FLAG(J))THEN 538 - INEXT=J 539 - GOTO 20 1 646 P=DRIFT D=DRFARR 7 PAGE 932 540 - * Range. 541 - ELSEIF(INPCMP(J,'RAN#GE').NE.0)THEN 542 - IF(FLAG(J+1).OR.FLAG(J+2).OR. 543 - - (INPTYP(J+1).NE.1.AND.INPTYP(J+1).NE.2).OR. 544 - - (INPTYP(J+2).NE.1.AND.INPTYP(J+2).NE.2))THEN 545 - CALL INPMSG(J,'Should have 2 real arguments.') 546 - OK=.FALSE. 547 - ELSE 548 - CALL INPCHK(J+1,2,IFAIL1) 549 - CALL INPCHK(J+2,2,IFAIL2) 550 - IF(STEP.EQ.'X')THEN 551 - CALL INPRDR(J+1,VARMIR,DXMIN) 552 - CALL INPRDR(J+2,VARMAR,DXMAX) 553 - ELSEIF(STEP.EQ.'Y')THEN 554 - CALL INPRDR(J+1,VARMIR,DYMIN) 555 - CALL INPRDR(J+2,VARMAR,DYMAX) 556 - ELSEIF(STEP.EQ.'Z')THEN 557 - CALL INPRDR(J+1,VARMIR,DZMIN) 558 - CALL INPRDR(J+2,VARMAR,DZMAX) 559 - ENDIF 560 - IF(VARMIR.EQ.VARMAR)THEN 561 - CALL INPMSG(J+1,'Zero range not permitted.') 562 - CALL INPMSG(J+2,'See preceding message.') 563 - OK=.FALSE. 564 - ELSEIF((SCAN.EQ.'X'.AND.( 565 - - MAX(VARMIR,VARMAR).LT.DXMIN.OR. 566 - - MIN(VARMIR,VARMAR).GT.DXMAX)).OR. 567 - - (SCAN.EQ.'Y'.AND.( 568 - - MAX(VARMIR,VARMAR).LT.DYMIN.OR. 569 - - MIN(VARMIR,VARMAR).GT.DYMAX)).OR. 570 - - (SCAN.EQ.'Z'.AND.( 571 - - MAX(VARMIR,VARMAR).LT.DZMIN.OR. 572 - - MIN(VARMIR,VARMAR).GT.DZMAX)))THEN 573 - CALL INPMSG(J+1,'Range not inside the area.') 574 - CALL INPMSG(J+2,'See preceding message.') 575 - OK=.FALSE. 576 - ELSE 577 - IF(SCAN.EQ.'X')THEN 578 - VARMIN=MAX(DXMIN,MIN(VARMIR,VARMAR)) 579 - VARMAX=MIN(DXMAX,MAX(VARMIR,VARMAR)) 580 - ELSEIF(SCAN.EQ.'Y')THEN 581 - VARMIN=MAX(DYMIN,MIN(VARMIR,VARMAR)) 582 - VARMAX=MIN(DYMAX,MAX(VARMIR,VARMAR)) 583 - ELSEIF(SCAN.EQ.'Z')THEN 584 - VARMIN=MAX(DZMIN,MIN(VARMIR,VARMAR)) 585 - VARMAX=MIN(DZMAX,MAX(VARMIR,VARMAR)) 586 - ENDIF 587 - ENDIF 588 - INEXT=J+3 589 - ENDIF 590 - * Angle. 591 - ELSEIF(INPCMP(J,'ANG#LE').NE.0)THEN 592 - IF(FLAG(J+1).OR. 593 - - (INPTYP(J+1).NE.1.AND.INPTYP(J+1).NE.2))THEN 594 - CALL INPMSG(J,'Should have 1 real argument.') 595 - OK=.FALSE. 596 - ELSE 597 - CALL INPCHK(J+1,2,IFAIL) 598 - CALL INPRDR(J+1,ANGLER,180.0*ATAN(TANPHI)/PI) 599 - IF(ABS(ANGLER).GE.80)THEN 600 - CALL INPMSG(J+1, 601 - - 'Not within the range [-80,80].') 602 - OK=.FALSE. 603 - ELSE 604 - TANPHI=TAN(PI*ANGLER/180.0) 605 - ENDIF 606 - INEXT=J+2 607 - ENDIF 608 - * Unknown sub-keywords. 609 - ELSE 610 - CALL INPMSG(J,'Not a sub-keyword of SCAN.') 611 - ENDIF 612 - 40 CONTINUE 613 - ** Offset of the plane. 614 - ELSEIF(INPCMP(I,'OFF#SET').NE.0)THEN 615 - IF(FLAG(I+1))THEN 616 - CALL INPMSG(I,'Should have an argument. ') 617 - OK=.FALSE. 618 - ELSE 619 - CALL INPCHK(I+1,2,IFAIL1) 620 - CALL INPRDR(I+1,WAROFF,0.0) 621 - INEXT=I+2 622 - ENDIF 623 - ** The option is not known to the program. 624 - ELSE 625 - CALL INPMSG(I,'The option is not known. ') 626 - OK=.FALSE. 627 - ENDIF 628 - 20 CONTINUE 629 - * Display error messages. 630 - CALL INPERR 631 - *** Check the presence of sufficient gas data. 632 - IF((.NOT.GASOK(1)).OR.(.NOT.(GASOK(5).OR.HEEDOK)).OR. 633 - - (LDIFF.AND..NOT.GASOK(3)).OR. 634 - - (LATTAC.AND..NOT.GASOK(6)))THEN 635 - PRINT *,' ###### DRFARR ERROR : Insufficient gas data'// 636 - - ' to perform the calculations; ARRIVAL not executed.' 637 - RETURN 638 - ENDIF 639 - *** Tell if diffusion is not taken into account. 640 - IF(.NOT.LDIFF)PRINT *,' ------ DRFARR MESSAGE : Diffusion will'// 641 - - ' not be taken into account.' 642 - *** Check the length of the various strings. 643 - IF(NCFILE.GT.MXNAME)THEN 644 - PRINT *,' !!!!!! DRFARR WARNING : The dataset name is too'// 645 - - ' long and is truncated to '//FILE//'.' 1 646 P=DRIFT D=DRFARR 8 PAGE 933 646 - OK=.FALSE. 647 - NCFILE=MXNAME 648 - ENDIF 649 - IF(NCMEMB.GT.8)THEN 650 - PRINT *,' !!!!!! DRFARR WARNING : The member name is too'// 651 - - ' long and is truncated to '//MEMBER//'.' 652 - OK=.FALSE. 653 - NCMEMB=8 654 - ENDIF 655 - IF(NCREM.GT.29)THEN 656 - PRINT *,' !!!!!! DRFARR WARNING : The remark is too'// 657 - - ' long and is truncated to '//REMARK//'.' 658 - OK=.FALSE. 659 - NCREM=29 660 - ENDIF 661 - * Check whether the member already exists. 662 - IF(LARRWR)THEN 663 - CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'ARRIVAL', 664 - - EXMEMB) 665 - IF(JEXMEM.EQ.2.AND.EXMEMB)THEN 666 - PRINT *,' ------ DRFARR MESSAGE : A copy of the'// 667 - - ' member exists; new member will be appended.' 668 - ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN 669 - PRINT *,' !!!!!! DRFARR WARNING : A copy of the'// 670 - - ' member exists already; member will not be'// 671 - - ' written.' 672 - LARRWR=.FALSE. 673 - OK=.FALSE. 674 - ENDIF 675 - ENDIF 676 - *** Print some debugging output, to check correct input handling. 677 - IF(LDEBUG)THEN 678 - WRITE(LUNOUT,'('' ++++++ DRFARR DEBUG : '', 679 - - ''Step in '',A,'' range: '',2E12.5,'' increment: '', 680 - - E12.5/26X, 681 - - ''Scan in '',A,'' range: '',2E12.5,'' tan(angle): '', 682 - - E12.5/26X,''Offset '',E12.5/ 683 - - 26X,''bins='',I3,'', lines='',I3,'', order='',I3/ 684 - - 26X,''threshold='',E12.5)') 685 - - STEP,UARMIN,UARMAX,USTEP, 686 - - SCAN,VARMIN,VARMAX,TANPHI, 687 - - NCHA,NLTR,IORDER,THRESH 688 - WRITE(LUNOUT,'(26X,''Selected electrons: '',100(I3:))') 689 - - (MELEC(I),I=1,KELEC) 690 - IF(LARRWR)THEN 691 - WRITE(LUNOUT,'(/26X,''Output dataset="'',A, 692 - - ''", member="'',A,''"''/26X,''Remark="'',A, 693 - - ''"'')') FILE(1:NCFILE),MEMBER(1:NCMEMB), 694 - - REMARK(1:NCREM) 695 - ELSE 696 - WRITE(LUNOUT,'(/26X,''No dataset output.'')') 697 - ENDIF 698 - ENDIF 699 - *** Quit now if OK is no longer true and if JFAIL is set. 700 - IF(JFAIL.EQ.2.AND..NOT.OK)THEN 701 - PRINT *,' ###### DRFARR ERROR : Instruction is not'// 702 - - ' carried out because of the above errors.' 703 - RETURN 704 - ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN 705 - PRINT *,' ###### DRFARR ERROR : Program terminated'// 706 - - ' because of the above errors.' 707 - CALL QUIT 708 - ENDIF 709 - *** Check the parameters, first orthogonality. 710 - IF(SCAN.EQ.STEP)THEN 711 - PRINT *,' !!!!!! DRFARR WARNING : The scanning and the'// 712 - - ' stepping direction coincide; not executed.' 713 - RETURN 714 - ELSEIF( 715 - - (((SCAN.EQ.'X'.AND.STEP.EQ.'Y').OR. 716 - - (SCAN.EQ.'Y'.AND.STEP.EQ.'X')).AND. 717 - - (DZMIN-WAROFF)*(WAROFF-DZMAX).LT.0).OR. 718 - - (((SCAN.EQ.'X'.AND.STEP.EQ.'Z').OR. 719 - - (SCAN.EQ.'Z'.AND.STEP.EQ.'X')).AND. 720 - - (DYMIN-WAROFF)*(WAROFF-DYMAX).LT.0).OR. 721 - - (((SCAN.EQ.'Y'.AND.STEP.EQ.'Y').OR. 722 - - (SCAN.EQ.'Z'.AND.STEP.EQ.'Z')).AND. 723 - - (DXMIN-WAROFF)*(WAROFF-DXMAX).LT.0))THEN 724 - PRINT *,' !!!!!! DRFARR WARNING : The plane offset'// 725 - - ' is located outside the area; not executed.' 726 - RETURN 727 - ENDIF 728 - *** Initialise progress printing. 729 - CALL PROINT('ARRIVAL',3,6) 730 - *** Loop over the electrodes by requested drift status code. 731 - CALL PROFLD(1,'Electrodes',REAL(5+NWIRE+NSOLID)) 732 - ISWCNT=0 733 - DO 100 IW=-15,2*MXWIRE+MXSOLI 734 - * References. 735 - IPLANE=0 736 - ISOLID=0 737 - * Skip the tube if non-existing / non-selected / out of area. 738 - IF(IW.EQ.-15)THEN 739 - ISWCNT=ISWCNT+1 740 - CALL PROSTA(1,REAL(ISWCNT)) 741 - IF((.NOT.TUBE).OR.INDPLA(5).EQ.0)GOTO 100 742 - IF((DXMIN-COTUBE)*(COTUBE-DXMAX).LT.0.OR. 743 - - (DYMIN-COTUBE)*(COTUBE-DYMAX).LT.0)GOTO 100 744 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFARR DEBUG :'', 745 - - '' Tube selected.'')') 746 - XW=0 747 - YW=0 748 - ZW=0 749 - STRID='the tube' 750 - NCID=8 751 - * Skip non-existing / non-selected / out of range planes. 1 646 P=DRIFT D=DRFARR 9 PAGE 934 752 - ELSEIF(IW.GE.-14.AND.IW.LE.-11)THEN 753 - ISWCNT=ISWCNT+1 754 - CALL PROSTA(1,REAL(ISWCNT)) 755 - IPLANE=-(IW+10) 756 - IF((.NOT.YNPLAN(IPLANE)).OR.INDPLA(IPLANE).EQ.0)GOTO 100 757 - IF(IPLANE.LE.2.AND. 758 - - (DXMIN-COPLAN(IPLANE))*(COPLAN(IPLANE)-DXMAX).LT.0) 759 - - GOTO 100 760 - IF(IPLANE.GT.2.AND. 761 - - (DYMIN-COPLAN(IPLANE))*(COPLAN(IPLANE)-DYMAX).LT.0) 762 - - GOTO 100 763 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFARR DEBUG :'', 764 - - '' Plane '',I1,'' selected.'')') IPLANE 765 - IF(IPLANE.LE.2)THEN 766 - XW=COPLAN(IPLANE) 767 - YW=0 768 - ELSE 769 - XW=0 770 - YW=COPLAN(IPLANE) 771 - ENDIF 772 - ZW=0 773 - CALL OUTFMT(REAL(IPLANE),2,STR1,NC1,'LEFT') 774 - STRID='plane '//STR1(1:NC1) 775 - NCID=6+NC1 776 - * Status codes between -10 and 0 are not of interest. 777 - ELSEIF(IW.GE.-10.AND.IW.LE.0)THEN 778 - GOTO 100 779 - * Skip non-existing / non-selected / out of range wires. 780 - ELSEIF(IW.GE.1.AND.IW.LE.NWIRE)THEN 781 - ISWCNT=ISWCNT+1 782 - CALL PROSTA(1,REAL(ISWCNT)) 783 - IF(INDSW(IW).EQ.0)GOTO 100 784 - IF((DXMIN-X(IW))*(X(IW)-DXMAX).LT.0.OR. 785 - - (DYMIN-Y(IW))*(Y(IW)-DYMAX).LT.0)GOTO 100 786 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFARR DEBUG :'', 787 - - '' Wire '',I1,'' selected.'')') IW 788 - XW=X(IW) 789 - YW=Y(IW) 790 - ZW=0 791 - CALL OUTFMT(REAL(IW),2,STR1,NC1,'LEFT') 792 - STRID='wire '//STR1(1:NC1) 793 - NCID=5+NC1 794 - * Non-existent wires and replicas are of no interest. 795 - ELSEIF(IW.GE.NWIRE+1.AND.IW.LE.2*MXWIRE)THEN 796 - GOTO 100 797 - * Skip solids that were not selected. 798 - ELSEIF(IW.GE.2*MXWIRE+1.AND.IW.LE.2*MXWIRE+NSOLID)THEN 799 - ISWCNT=ISWCNT+1 800 - CALL PROSTA(1,REAL(ISWCNT)) 801 - ISOLID=IW-2*MXWIRE 802 - IF(INDSOL(ISOLID).EQ.0)GOTO 100 803 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFARR DEBUG :'', 804 - - '' Solid '',I1,'' selected.'')') ISOLID 805 - IF(ISOLTP(ISOLID).EQ.1)THEN 806 - XW=REAL(CBUF(ISTART(J)+3)) 807 - YW=REAL(CBUF(ISTART(J)+4)) 808 - ZW=REAL(CBUF(ISTART(J)+5)) 809 - ELSEIF(ISOLTP(ISOLID).EQ.2)THEN 810 - XW=REAL(CBUF(ISTART(J)+6)) 811 - YW=REAL(CBUF(ISTART(J)+7)) 812 - ZW=REAL(CBUF(ISTART(J)+8)) 813 - ELSEIF(ISOLTP(ISOLID).EQ.3)THEN 814 - XW=REAL(CBUF(ISTART(J)+4)) 815 - YW=REAL(CBUF(ISTART(J)+5)) 816 - ZW=REAL(CBUF(ISTART(J)+6)) 817 - ELSEIF(ISOLTP(ISOLID).EQ.4)THEN 818 - XW=REAL(CBUF(ISTART(J)+2)) 819 - YW=REAL(CBUF(ISTART(J)+3)) 820 - ZW=REAL(CBUF(ISTART(J)+4)) 821 - ELSE 822 - PRINT *,' !!!!!! DLCARR WARNING : Found a solid of'// 823 - - ' unknown type; skipped.' 824 - GOTO 100 825 - ENDIF 826 - CALL OUTFMT(REAL(ISOLID),2,STR1,NC1,'LEFT') 827 - STRID='solid '//STR1(1:NC1) 828 - NCID=6+NC1 829 - * Non-existent solids are to be skipped. 830 - ELSEIF(IW.GT.2*MXWIRE+NSOLID)THEN 831 - GOTO 100 832 - ENDIF 833 - *** Compute a reasonable range, first set the reference. 834 - IF(STEP.EQ.'X')THEN 835 - UAROFF=XW 836 - ELSEIF(STEP.EQ.'Y')THEN 837 - UAROFF=YW 838 - ELSEIF(STEP.EQ.'Z')THEN 839 - UAROFF=ZW 840 - ENDIF 841 - * Compute a range of increments. 842 - IXM=NINT((UARMIN-UAROFF)/USTEP)-1 843 - IXP=NINT((UARMAX-UAROFF)/USTEP)+1 844 - * Fix for the case one is very near an edge. 845 - IF(UARMIN-USTEP*0.001.GT.UAROFF+IXM*USTEP)IXM=IXM+1 846 - IF(UARMAX+USTEP*0.001.LT.UAROFF+IXP*USTEP)IXP=IXP-1 847 - IF(UARMIN-USTEP*0.001.GT.UAROFF+IXM*USTEP)IXM=IXM+1 848 - IF(UARMAX+USTEP*0.001.LT.UAROFF+IXP*USTEP)IXP=IXP-1 849 - * Make sure that the number of steps doesn't exceed MXLIST. 850 - IF(IXP-IXM+1.GT.MXLIST)THEN 851 - PRINT *,' !!!!!! DRFARR WARNING : No arrival time plot'// 852 - - ' for electrode ',IW,' because MXLIST is too small.' 853 - PRINT *,' Consider making X-STEP'// 854 - - ' larger or choose a smaller X-RANGE.' 855 - GOTO 100 856 - ENDIF 857 - *** Loop over the x points. 1 646 P=DRIFT D=DRFARR 10 PAGE 935 858 - CALL PROFLD(2,'Steps',REAL(IXP-IXM+1)) 859 - DO 110 IX=IXM,IXP 860 - CALL PROSTA(2,REAL(IX-IXM+1)) 861 - * Initial values for the table. 862 - ARRLIS(IX-IXM+1,1)=UAROFF+IX*USTEP 863 - DO 111 I=2,4+3*MXELEC 864 - ARRLIS(IX-IXM+1,I)=0.0 865 - 111 CONTINUE 866 - ARRFLG(IX-IXM+1)=0 867 - *** Establish track begin and end points for this coordinate. 868 - IF(STEP.EQ.'X'.AND.SCAN.EQ.'Y')THEN 869 - XT0=UAROFF+IX*USTEP+TANPHI*(VARMIN-YW) 870 - XT1=UAROFF+IX*USTEP+TANPHI*(VARMAX-YW) 871 - YT0=VARMIN 872 - YT1=VARMAX 873 - ZT0=WAROFF 874 - ZT1=WAROFF 875 - CALL CLIP(XT0,YT0,XT1,YT1,DXMIN,MAX(DYMIN,VARMIN), 876 - - DXMAX,MIN(DYMAX,VARMAX),IFAIL) 877 - ELSEIF(STEP.EQ.'X'.AND.SCAN.EQ.'Z')THEN 878 - XT0=UAROFF+IX*USTEP+TANPHI*(VARMIN-ZW) 879 - XT1=UAROFF+IX*USTEP+TANPHI*(VARMAX-ZW) 880 - YT0=WAROFF 881 - YT1=WAROFF 882 - ZT0=VARMIN 883 - ZT1=VARMAX 884 - CALL CLIP(XT0,ZT0,XT1,ZT1,DXMIN,MAX(DZMIN,VARMIN), 885 - - DXMAX,MIN(DZMAX,VARMAX),IFAIL) 886 - ELSEIF(STEP.EQ.'Y'.AND.SCAN.EQ.'X')THEN 887 - XT0=VARMIN 888 - XT1=VARMAX 889 - YT0=UAROFF+IX*USTEP+TANPHI*(VARMIN-XW) 890 - YT1=UAROFF+IX*USTEP+TANPHI*(VARMAX-XW) 891 - ZT0=WAROFF 892 - ZT1=WAROFF 893 - CALL CLIP(YT0,XT0,YT1,XT1,DYMIN,MAX(DXMIN,VARMIN), 894 - - DYMAX,MIN(DXMAX,VARMAX),IFAIL) 895 - ELSEIF(STEP.EQ.'Y'.AND.SCAN.EQ.'Z')THEN 896 - XT0=WAROFF 897 - XT1=WAROFF 898 - YT0=UAROFF+IX*USTEP+TANPHI*(VARMIN-ZW) 899 - YT1=UAROFF+IX*USTEP+TANPHI*(VARMAX-ZW) 900 - ZT0=VARMIN 901 - ZT1=VARMAX 902 - CALL CLIP(YT0,ZT0,YT1,ZT1,DYMIN,MAX(DZMIN,VARMIN), 903 - - DYMAX,MIN(DZMAX,VARMAX),IFAIL) 904 - ELSEIF(STEP.EQ.'Z'.AND.SCAN.EQ.'X')THEN 905 - XT0=VARMIN 906 - XT1=VARMAX 907 - YT0=WAROFF 908 - YT1=WAROFF 909 - ZT0=UAROFF+IX*USTEP+TANPHI*(VARMIN-XW) 910 - ZT1=UAROFF+IX*USTEP+TANPHI*(VARMAX-XW) 911 - CALL CLIP(ZT0,XT0,ZT1,XT1,DZMIN,MAX(DXMIN,VARMIN), 912 - - DZMAX,MIN(DXMAX,VARMAX),IFAIL) 913 - ELSEIF(STEP.EQ.'Z'.AND.SCAN.EQ.'Y')THEN 914 - XT0=WAROFF 915 - XT1=WAROFF 916 - YT0=VARMIN 917 - YT1=VARMAX 918 - ZT0=UAROFF+IX*USTEP+TANPHI*(VARMIN-YW) 919 - ZT1=UAROFF+IX*USTEP+TANPHI*(VARMAX-YW) 920 - CALL CLIP(ZT0,YT0,ZT1,YT1,DZMIN,MAX(DYMIN,VARMIN), 921 - - DZMAX,MIN(DYMAX,VARMAX),IFAIL) 922 - ELSE 923 - PRINT *,' !!!!!! DRFARR WARNING : Unknown pair of'// 924 - - ' stepping and scanning directions; skipped.' 925 - GOTO 100 926 - ENDIF 927 - * Display the track. 928 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFARR DEBUG : From: '', 929 - - ''('',E15.8,'','',E15.8,'','',E15.8,'')''/26X,''To: '', 930 - - ''('',E15.8,'','',E15.8,'','',E15.8,'').'')') 931 - - XT0,YT0,ZT0,XT1,YT1,ZT1 932 - * Be sure the at least part of the track is located inside the area. 933 - IF(IFAIL.NE.0)THEN 934 - ARRFLG(IX-IXM+1)=-1 935 - PRINT *,' !!!!!! DRFARR WARNING : The track is located'// 936 - - ' outside the drift-area; no further computations.' 937 - GOTO 110 938 - ENDIF 939 - * Declare the track as set. 940 - TRFLAG(1)=.TRUE. 941 - *** Prepare the track for interpolation, prepare progress print. 942 - CALL PRORED(3) 943 - CALL PROFLD(3,'Track preparation',-1.0) 944 - CALL PROSTA(3,0.0) 945 - * Prepare the track, drift-time and diffusion needed only. 946 - CALL DLCTRP(XT0,YT0,ZT0,XT1,YT1,ZT1, 947 - - LDIFF,.FALSE.,LATTAC,NLTR,TGMIN,TGMAX, 948 - - SMIN,SMAX,AMIN,AMAX,BMIN,BMAX,IFAIL) 949 - IF(IFAIL.NE.0)THEN 950 - ARRFLG(IX-IXM+1)=-2 951 - PRINT *,' !!!!!! DRFARR WARNING : Track preparation has'// 952 - - ' failed; no further arrival time computations.' 953 - GOTO 110 954 - ELSEIF(TGMIN.GE.TGMAX)THEN 955 - ARRFLG(IX-IXM+1)=-3 956 - PRINT *,' !!!!!! DRFARR WARNING : The range of arrival'// 957 - - ' time for the track is nill; no further computations.' 958 - GOTO 110 959 - ENDIF 960 - * Round these values to obtain a sensible time scale. 961 - IF(LDIFF)THEN 962 - TGMIN=TGMIN-5*SMAX 963 - TGMAX=TGMAX+5*SMAX 1 646 P=DRIFT D=DRFARR 11 PAGE 936 964 - ENDIF 965 - CALL ROUND(TGMIN,TGMAX,NCHA,'LARGER',TSTEP) 966 - IF(TGMIN.LT.0.0)TGMIN=TGMIN+TSTEP*(1+INT(ABS(TGMIN/TSTEP))) 967 - TEMIN=TGMIN 968 - TEMAX=TGMAX 969 - *** Allocate histogram storage, tell that we do this. 970 - CALL PROFLD(3,'Histogram allocation',-1.0) 971 - CALL PROSTA(3,0.0) 972 - * Timing histograms with forced time window. 973 - IF(WFORCE)THEN 974 - CALL HISADM('ALLOCATE',IRFTGL,NCHA, 975 - - TFORC1,TFORC2,.FALSE.,IFAIL1) 976 - IF(IFAIL1.NE.0)THEN 977 - PRINT *,' ###### DRFARR ERROR : Unable to obtain'// 978 - - ' histogram space (all, t) ; end of calculations.' 979 - RETURN 980 - ENDIF 981 - DO 112 I=1,KELEC 982 - CALL HISADM('ALLOCATE',IRFTEL(I),NCHA, 983 - - TFORC1,TFORC2,.FALSE.,IFAIL2) 984 - IF(IFAIL2.NE.0)THEN 985 - PRINT *,' ###### DRFARR ERROR : Unable to obtain'// 986 - - ' histogram space (sel, t) ; end of calculations.' 987 - RETURN 988 - ENDIF 989 - 112 CONTINUE 990 - * Timing histograms with automatic time window. 991 - ELSE 992 - CALL HISADM('ALLOCATE',IRFTGL,NCHA, 993 - - TGMIN,TGMAX,TGAUTO,IFAIL1) 994 - IF(IFAIL1.NE.0)THEN 995 - PRINT *,' ###### DRFARR ERROR : Unable to obtain'// 996 - - ' histogram space (all, t) ; end of calculations.' 997 - RETURN 998 - ENDIF 999 - DO 113 I=1,KELEC 1000 - CALL HISADM('ALLOCATE',IRFTEL(I),NCHA, 1001 - - TEMIN,TEMAX,TEAUTO,IFAIL2) 1002 - IF(IFAIL2.NE.0)THEN 1003 - PRINT *,' ###### DRFARR ERROR : Unable to obtain'// 1004 - - ' histogram space (sel, t) ; end of calculations.' 1005 - RETURN 1006 - ENDIF 1007 - 113 CONTINUE 1008 - ENDIF 1009 - * Origin histograms, also reset the counter. 1010 - IF(SCAN.EQ.'X')THEN 1011 - CALL HISADM('ALLOCATE',IRFXGL,NCHA,XT0,XT1,.FALSE.,IFAIL3) 1012 - ELSEIF(SCAN.EQ.'Y')THEN 1013 - CALL HISADM('ALLOCATE',IRFXGL,NCHA,YT0,YT1,.FALSE.,IFAIL3) 1014 - ELSEIF(SCAN.EQ.'Z')THEN 1015 - CALL HISADM('ALLOCATE',IRFXGL,NCHA,ZT0,ZT1,.FALSE.,IFAIL3) 1016 - ENDIF 1017 - IF(IFAIL3.NE.0)THEN 1018 - PRINT *,' ###### DRFARR ERROR : Unable to allocate'// 1019 - - ' histogram (origin all) ; end of calculations.' 1020 - RETURN 1021 - ENDIF 1022 - DO 114 I=1,KELEC 1023 - IF(SCAN.EQ.'X')THEN 1024 - CALL HISADM('ALLOCATE',IRFXEL(I),NCHA,XT0,XT1,.FALSE., 1025 - - IFAIL4) 1026 - ELSEIF(SCAN.EQ.'Y')THEN 1027 - CALL HISADM('ALLOCATE',IRFXEL(I),NCHA,YT0,YT1,.FALSE., 1028 - - IFAIL4) 1029 - ELSEIF(SCAN.EQ.'Z')THEN 1030 - CALL HISADM('ALLOCATE',IRFXEL(I),NCHA,ZT0,ZT1,.FALSE., 1031 - - IFAIL4) 1032 - ENDIF 1033 - IF(IFAIL4.NE.0)THEN 1034 - PRINT *,' ###### DRFARR ERROR : Unable to allocate'// 1035 - - ' histogram (origin selected) ; end of calculations.' 1036 - RETURN 1037 - ENDIF 1038 - NELEC(I)=0 1039 - 114 CONTINUE 1040 - * Cluster count histograms and counter. 1041 - CALL HISADM('INTEGER',IRFNCL,NCHA,0.0,0.0,.TRUE.,IFAIL5) 1042 - CALL HISADM('INTEGER',IRFNEL,NCHA,0.0,0.0,.TRUE.,IFAIL6) 1043 - IF(IFAIL5.NE.0.OR.IFAIL6.NE.0)THEN 1044 - PRINT *,' ###### DRFARR ERROR : Unable to obtain'// 1045 - - ' histogram space (cluster) ; end of calculations.' 1046 - RETURN 1047 - ENDIF 1048 - NGLOB=0 1049 - * Debugging output. 1050 - IF(LDEBUG)PRINT *,' ++++++ DRFARR DEBUG : Time range: Tmin=', 1051 - - TGMIN,', Tmax=',TGMAX 1052 - IF(LDEBUG)PRINT *,' Autoscaling '// 1053 - - ' global=',TGAUTO,', selected=',TEAUTO 1054 - IF(LDEBUG)PRINT *,' Forced window: ', 1055 - - WFORCE,' Range: ',TFORC1,TFORC2 1056 - *** Loop over the tracks, start progress printing. 1057 - CALL PROFLD(3,'Tracks',REAL(NRNDM)) 1058 - CALL PROSTA(3,0.0) 1059 - IF(NRNDM.LE.10)THEN 1060 - IPRT=1 1061 - ELSE 1062 - IPRT=10**(INT(LOG10(REAL(2*NRNDM)))-1) 1063 - ENDIF 1064 - * Loop over the tracks. 1065 - DO 140 IRNDM=1,NRNDM 1066 - IF(IRNDM.EQ.IPRT*(IRNDM/IPRT))CALL PROSTA(3,REAL(IRNDM)) 1067 - * Initialise clustering. 1068 - CALL TRACLI 1069 - * Reset number of electrons accumulated. 1 646 P=DRIFT D=DRFARR 12 PAGE 937 1070 - NPART=0 1071 - NCLUS=0 1072 - ** Return to this point for a new cluster. 1073 - 150 CONTINUE 1074 - * Generate a new point on the track. 1075 - CALL TRACLS(XCL,YCL,ZCL,ECL,NPAIR,DONE,IFAIL1) 1076 - * Check whether there was a mistake. 1077 - IF(IFAIL1.NE.0)THEN 1078 - PRINT *,' !!!!!! DRFARR WARNING : Clustering error;'// 1079 - - ' point skipped.' 1080 - ARRFLG(IX-IXM+1)=-6 1081 - CALL HISADM('DELETE',IRFTGL,0,0.0,0.0,.TRUE.,IFAIL) 1082 - CALL HISADM('DELETE',IRFXGL,0,0.0,0.0,.TRUE.,IFAIL) 1083 - DO 155 I=1,KELEC 1084 - CALL HISADM('DELETE',IRFTEL(I),0,0.0,0.0,.TRUE.,IFAIL) 1085 - CALL HISADM('DELETE',IRFXEL(I),0,0.0,0.0,.TRUE.,IFAIL) 1086 - 155 CONTINUE 1087 - CALL HISADM('DELETE',IRFNCL,0,0.0,0.0,.TRUE.,IFAIL) 1088 - CALL HISADM('DELETE',IRFNEL,0,0.0,0.0,.TRUE.,IFAIL) 1089 - IF(LHISKP)PRINT *,' !!!!!! DRFARR WARNING : Histograms'// 1090 - - ' not kept - no entries.' 1091 - GOTO 110 1092 - * Check whether this was beyond the last cluster. 1093 - ELSEIF(DONE)THEN 1094 - GOTO 170 1095 - ENDIF 1096 - * Increment cluster count. 1097 - NCLUS=NCLUS+1 1098 - * Find the drift time and the diffusion coefficient for this point. 1099 - CALL DLCTRI(XCL,YCL,ZCL,TCL,ICL,SCL,ACL,BCL,FCL, 1100 - - LDIFF,.FALSE.,LATTAC,IFAIL) 1101 - * Skip the rest if the status code doesn't match. 1102 - IF(ICL.NE.IW.OR.IFAIL.NE.0)GOTO 150 1103 - * Apply the attachment coefficient if available. 1104 - IF(LATTAC.AND.GASOK(6))NPAIR=NINT(REAL(NPAIR)*BCL) 1105 - ** Generate the individual arrival times within the cluster. 1106 - DO 160 ICLS=1,NPAIR 1107 - * Increment counter. 1108 - IF(NPART.GE.MXPART)THEN 1109 - PRINT *,' !!!!!! DRFARR WARNING : Too many particles'// 1110 - - ' generated on the track; increase MXPART.' 1111 - GOTO 140 1112 - ENDIF 1113 - NPART=NPART+1 1114 - * Register the time. 1115 - IF(LDIFF)THEN 1116 - ARRTIM(1,NPART)=RNDNOR(TCL,SCL) 1117 - ELSE 1118 - ARRTIM(1,NPART)=TCL 1119 - ENDIF 1120 - CALL HISENT(IRFTGL,ARRTIM(1,NPART),1.0) 1121 - * Register the origin. 1122 - IF(SCAN.EQ.'X')THEN 1123 - ARRTIM(2,NPART)=XCL 1124 - ELSEIF(SCAN.EQ.'Y')THEN 1125 - ARRTIM(2,NPART)=YCL 1126 - ELSEIF(SCAN.EQ.'Z')THEN 1127 - ARRTIM(2,NPART)=ZCL 1128 - ENDIF 1129 - CALL HISENT(IRFXGL,ARRTIM(2,NPART),1.0) 1130 - * Increment overall electron counter. 1131 - NGLOB=NGLOB+1 1132 - 160 CONTINUE 1133 - * Next cluster. 1134 - GOTO 150 1135 - * Last cluster done. 1136 - 170 CONTINUE 1137 - ** Enter the electron count. 1138 - CALL HISENT(IRFNCL,REAL(NCLUS),1.0) 1139 - CALL HISENT(IRFNEL,REAL(NPART),1.0) 1140 - * Find the M'th particle to arrive and enter in a histogram. 1141 - IF(NPART.GE.1)THEN 1142 - CALL SORTRQ(ARRTIM,2,NPART,1) 1143 - DO 161 I=1,KELEC 1144 - IF(MELEC(I).GT.0.AND.MELEC(I).LE.NPART.AND.NPART.GT.0)THEN 1145 - CALL HISENT(IRFTEL(I),ARRTIM(1,MELEC(I)),1.0) 1146 - CALL HISENT(IRFXEL(I),ARRTIM(2,MELEC(I)),1.0) 1147 - NELEC(I)=NELEC(I)+1 1148 - ELSEIF(MELEC(I).LE.0.AND.MELEC(I)+NPART.GE.1)THEN 1149 - CALL HISENT(IRFTEL(I),ARRTIM(1,NPART+MELEC(I)),1.0) 1150 - CALL HISENT(IRFXEL(I),ARRTIM(2,NPART+MELEC(I)),1.0) 1151 - NELEC(I)=NELEC(I)+1 1152 - ENDIF 1153 - 161 CONTINUE 1154 - ENDIF 1155 - * Proceed with the next random cycle. 1156 - 140 CONTINUE 1157 - *** Check we did indeed collect something. 1158 - IF(NGLOB.LE.0)THEN 1159 - ARRFLG(IX-IXM+1)=-4 1160 - CALL HISADM('DELETE',IRFTGL,0,0.0,0.0,.TRUE.,IFAIL) 1161 - CALL HISADM('DELETE',IRFXGL,0,0.0,0.0,.TRUE.,IFAIL) 1162 - CALL HISADM('DELETE',IRFNCL,0,0.0,0.0,.TRUE.,IFAIL) 1163 - CALL HISADM('DELETE',IRFNEL,0,0.0,0.0,.TRUE.,IFAIL) 1164 - DO 142 I=1,KELEC 1165 - CALL HISADM('DELETE',IRFTEL(I),0,0.0,0.0,.TRUE.,IFAIL) 1166 - CALL HISADM('DELETE',IRFXEL(I),0,0.0,0.0,.TRUE.,IFAIL) 1167 - 142 CONTINUE 1168 - IF(LHISKP)PRINT *,' !!!!!! DRFARR WARNING : Histograms'// 1169 - - ' not kept - no entries.' 1170 - GOTO 110 1171 - ENDIF 1172 - * Inform about progress. 1173 - CALL PROFLD(3,'Extracting data',-1.0) 1174 - CALL PROSTA(3,0.0) 1175 - *** Obtain average, median and spread; first all electrons. 1 646 P=DRIFT D=DRFARR 13 PAGE 938 1176 - CALL HISINQ(IRFTGL,LEXIST,LSET,NGBIN,HGMIN,HGMAX,NGENT, 1177 - - ARRLIS(IX-IXM+1,2),ARRLIS(IX-IXM+1,4)) 1178 - IF(LEXIST.AND.NGENT*(HGMAX-HGMIN).GT.0)THEN 1179 - CALL HISSCL(IRFTGL,REAL(NGBIN)/REAL(NGENT*(HGMAX-HGMIN))) 1180 - CALL HISINV(IRFTGL,THRESH,ARRLIS(IX-IXM+1,3),IORDER,IFAIL1) 1181 - CALL HISSCL(IRFTGL,REAL(NGENT*(HGMAX-HGMIN))/REAL(NGBIN)) 1182 - ELSE 1183 - IFAIL1=1 1184 - ENDIF 1185 - * Same for selected electron. 1186 - IFAIL2=0 1187 - DO 141 I=1,KELEC 1188 - CALL HISINQ(IRFTEL(I),LEXIST,LSET,NEBIN,HEMIN,HEMAX,NEENT, 1189 - - ARRLIS(IX-IXM+1,2+3*I),ARRLIS(IX-IXM+1,4+3*I)) 1190 - IF(LEXIST.AND.NEENT*(HEMAX-HEMIN).GT.0)THEN 1191 - CALL HISSCL(IRFTEL(I),REAL(NEBIN)/REAL(NEENT*(HEMAX-HEMIN))) 1192 - CALL HISINV(IRFTEL(I),THRESH,ARRLIS(IX-IXM+1,3+3*I), 1193 - - IORDER,IFAIL2) 1194 - CALL HISSCL(IRFTEL(I),REAL(NEENT*(HEMAX-HEMIN))/REAL(NEBIN)) 1195 - ELSE 1196 - IFAIL2=1 1197 - ENDIF 1198 - 141 CONTINUE 1199 - * Keep track of error conditions. 1200 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)ARRFLG(IX-IXM+1)=-5 1201 - * Plot the curves. 1202 - IF(LELEPL)THEN 1203 - * Inform about progress. 1204 - CALL PROFLD(3,'Plot selected e-',-1.0) 1205 - CALL PROSTA(3,0.0) 1206 - CALL OUTFMT(UAROFF+IX*USTEP,2,STR1,NC1,'LEFT') 1207 - DO 143 I=1,KELEC 1208 - CALL OUTFMT(REAL(MELEC(I)),2,STR2,NC2,'LEFT') 1209 - IF(MELEC(I).GT.0)THEN 1210 - TITLE='Time electron '//STR2(1:NC2)//' to '// 1211 - - STRID(1:NCID)//' from '//STR1(1:NC1)//' cm' 1212 - NC=27+NC1+NC2+NCID 1213 - ELSEIF(MELEC(I).EQ.0)THEN 1214 - TITLE='Time last electron to '//STRID(1:NCID)// 1215 - - ' from '//STR1(1:NC1)//' cm' 1216 - NC=31+NC1+NCID 1217 - ELSE 1218 - TITLE='Time last'//STR2(1:NC2)//' electron'// 1219 - - ' to '//STRID(1:NCID)//' from '//STR1(1:NC1)// 1220 - - ' cm' 1221 - NC=31+NC1+NC2+NCID 1222 - ENDIF 1223 - CALL HISPLT(IRFTEL(I),'Arrival time [microsec]', 1224 - - TITLE(1:NC),.TRUE.) 1225 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 1226 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 1227 - CALL GRALOG(TITLE(1:NC)) 1228 - CALL GRNEXT 1229 - IF(MELEC(I).GT.0)THEN 1230 - TITLE='Origin electron '//STR2(1:NC2)//' to '// 1231 - - STRID(1:NCID)//' from '//STR1(1:NC1)//' cm' 1232 - NC=29+NC1+NC2+NCID 1233 - ELSEIF(MELEC(I).EQ.0)THEN 1234 - TITLE='Origin last electron to '//STRID(1:NCID)// 1235 - - ' from '//STR1(1:NC1)//' cm' 1236 - NC=33+NC1+NCID 1237 - ELSE 1238 - TITLE='Origin last'//STR2(1:NC2)//' electron'// 1239 - - ' to '//STRID(1:NCID)//' from '//STR1(1:NC1)// 1240 - - ' cm' 1241 - NC=33+NC1+NC2+NCID 1242 - ENDIF 1243 - CALL HISPLT(IRFXEL(I),'Origin [track coordinate]', 1244 - - TITLE(1:NC),.TRUE.) 1245 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 1246 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 1247 - CALL GRALOG(TITLE(1:NC)) 1248 - CALL GRNEXT 1249 - 143 CONTINUE 1250 - ENDIF 1251 - IF(LELEPR)THEN 1252 - * Inform about progress. 1253 - CALL PROFLD(3,'Print selected e-',-1.0) 1254 - CALL PROSTA(3,0.0) 1255 - CALL OUTFMT(UAROFF+IX*USTEP,2,STR1,NC1,'LEFT') 1256 - DO 144 I=1,KELEC 1257 - CALL OUTFMT(REAL(MELEC(I)),2,STR2,NC2,'LEFT') 1258 - IF(MELEC(I).GT.0)THEN 1259 - TITLE='Time electron '//STR2(1:NC2)//' to '// 1260 - - STRID(1:NCID)//' from '//STR1(1:NC1)//' cm' 1261 - NC=27+NC1+NC2+NCID 1262 - ELSEIF(MELEC(I).EQ.0)THEN 1263 - TITLE='Time last electron to '//STRID(1:NCID)// 1264 - - ' from '//STR1(1:NC1)//' cm' 1265 - NC=31+NC1+NCID 1266 - ELSE 1267 - TITLE='Time last'//STR2(1:NC2)//' electron'// 1268 - - ' to '//STRID(1:NCID)//' from '//STR1(1:NC1)// 1269 - - ' cm' 1270 - NC=31+NC1+NC2+NCID 1271 - ENDIF 1272 - CALL HISPRT(IRFTEL(I),'Arrival time [microsec]', 1273 - - TITLE(1:NC)) 1274 - IF(MELEC(I).GT.0)THEN 1275 - TITLE='Origin electron '//STR2(1:NC2)//' to '// 1276 - - STRID(1:NCID)//' from '//STR1(1:NC1)//' cm' 1277 - NC=29+NC1+NC2+NCID 1278 - ELSEIF(MELEC(I).EQ.0)THEN 1279 - TITLE='Origin last electron to '//STRID(1:NCID)// 1280 - - ' from '//STR1(1:NC1)//' cm' 1281 - NC=33+NC1+NCID 1 646 P=DRIFT D=DRFARR 14 PAGE 939 1282 - ELSE 1283 - TITLE='Origin last'//STR2(1:NC2)//' electron'// 1284 - - ' to '//STRID(1:NCID)//' from '//STR1(1:NC1)// 1285 - - ' cm' 1286 - NC=33+NC1+NC2+NCID 1287 - ENDIF 1288 - CALL HISPRT(IRFXEL(I),'Origin [track coordinate]', 1289 - - TITLE(1:NC)) 1290 - 144 CONTINUE 1291 - ENDIF 1292 - * Global plot. 1293 - IF(LGLBPL)THEN 1294 - * Inform about progress. 1295 - CALL PROFLD(3,'Plot all e-',-1.0) 1296 - CALL PROSTA(3,0.0) 1297 - CALL OUTFMT(UAROFF+IX*USTEP,2,STR1,NC1,'LEFT') 1298 - CALL HISPLT(IRFTGL,'Arrival time [microsec]', 1299 - - 'Time all electrons to '//STRID(1:NCID)//' from '// 1300 - - STR1(1:NC1)//' cm',.TRUE.) 1301 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 1302 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 1303 - CALL GRALOG('Overall arrival time distribution. ') 1304 - CALL GRNEXT 1305 - CALL HISPLT(IRFXGL,'Origin [cm]', 1306 - - 'Origin all electrons to '//STRID(1:NCID)//' from '// 1307 - - STR1(1:NC1)//' cm',.TRUE.) 1308 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 1309 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 1310 - CALL GRALOG('Origin of the electrons. ') 1311 - CALL GRNEXT 1312 - CALL HISPLT(IRFNCL,'Number of clusters', 1313 - - 'Clusters per track at '//STR1(1:NC1)//' cm', 1314 - - .TRUE.) 1315 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 1316 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 1317 - CALL GRALOG('Clusters per track. ') 1318 - CALL GRNEXT 1319 - CALL HISPLT(IRFNEL,'Number of electrons', 1320 - - 'Accepted electrons at '//STR1(1:NC1)//' cm', 1321 - - .TRUE.) 1322 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 1323 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 1324 - CALL GRALOG('Electrons per track. ') 1325 - CALL GRNEXT 1326 - ENDIF 1327 - IF(LGLBPR)THEN 1328 - * Inform about progress. 1329 - CALL PROFLD(3,'Print all e-',-1.0) 1330 - CALL PROSTA(3,0.0) 1331 - CALL OUTFMT(UAROFF+IX*USTEP,2,STR1,NC1,'LEFT') 1332 - CALL HISPRT(IRFTGL,'Arrival time [microsec]', 1333 - - 'Time all electrons to '//STRID(1:NCID)//' from '// 1334 - - STR1(1:NC1)//' cm') 1335 - CALL HISPRT(IRFXGL,'y-Origin [cm]', 1336 - - 'Origin all electrons to '//STRID(1:NCID)//' from '// 1337 - - STR1(1:NC1)//' cm') 1338 - ENDIF 1339 - *** Get rid of the histograms, unless KEEP has been specified. 1340 - IF(LHISKP)THEN 1341 - * Inform about progress. 1342 - CALL PROFLD(3,'Saving histograms',-1.0) 1343 - CALL PROSTA(3,0.0) 1344 - JALL=JALL+1 1345 - CALL OUTFMT(REAL(JALL),2,STR1,NC1,'LEFT') 1346 - CALL HISSAV(IRFTGL,'ALL_'//STR1(1:NC1),IFAIL1) 1347 - CALL OUTFMT(UAROFF+IX*USTEP,2,STR3,NC3,'LEFT') 1348 - IF(IFAIL1.EQ.0)THEN 1349 - PRINT *,' ------ DRFARR MESSAGE : Arrival time'// 1350 - - ' histogram of all electrons to '// 1351 - - STRID(1:NCID)//' from '//STR3(1:NC3)// 1352 - - ' cm is kept as ALL_'//STR1(1:NC1)//'.' 1353 - ELSE 1354 - PRINT *,' !!!!!! DRFARR WARNING : Arrival time'// 1355 - - ' histogram of all electrons to '// 1356 - - STRID(1:NCID)//' from '//STR3(1:NC3)// 1357 - - ' cm has not been saved.' 1358 - CALL HISADM('DELETE',IRFTGL,0,0.0,0.0,.TRUE.,IFAIL) 1359 - ENDIF 1360 - DO 401 II=1,KELEC 1361 - JSEL=JSEL+1 1362 - CALL OUTFMT(REAL(JSEL),2,STR4,NC4,'LEFT') 1363 - CALL HISSAV(IRFTEL(II),'SEL_'//STR4(1:NC4),IFAIL1) 1364 - CALL OUTFMT(REAL(MELEC(II)),2,STR1,NC1,'LEFT') 1365 - CALL OUTFMT(UAROFF+IX*USTEP,2,STR3,NC3,'LEFT') 1366 - IF(IFAIL1.EQ.0)THEN 1367 - PRINT *,' ------ DRFARR MESSAGE : Arrival time'// 1368 - - ' histogram of electron '//STR1(1:NC1)// 1369 - - ' to '//STRID(1:NCID)//' from '// 1370 - - STR3(1:NC3)//' cm is kept'// 1371 - - ' as SEL_'//STR4(1:NC4)//'.' 1372 - ELSE 1373 - PRINT *,' !!!!!! DRFARR WARNING : Arrival time'// 1374 - - ' histogram of electron '//STR1(1:NC1)// 1375 - - ' to '//STRID(1:NCID)//' from '// 1376 - - STR3(1:NC3)//' cm has not been saved.' 1377 - CALL HISADM('DELETE',IRFTEL(II),0,0.0,0.0,.TRUE.,IFAIL) 1378 - ENDIF 1379 - 401 CONTINUE 1380 - ELSE 1381 - CALL HISADM('DELETE',IRFTGL,0,0.0,0.0,.TRUE.,IFAIL) 1382 - DO 403 I=1,KELEC 1383 - CALL HISADM('DELETE',IRFTEL(I),0,0.0,0.0,.TRUE.,IFAIL) 1384 - 403 CONTINUE 1385 - ENDIF 1386 - CALL HISADM('DELETE',IRFXGL,0,0.0,0.0,.TRUE.,IFAIL) 1387 - CALL HISADM('DELETE',IRFNCL,0,0.0,0.0,.TRUE.,IFAIL) 1 646 P=DRIFT D=DRFARR 15 PAGE 940 1388 - CALL HISADM('DELETE',IRFNEL,0,0.0,0.0,.TRUE.,IFAIL) 1389 - DO 404 I=1,KELEC 1390 - CALL HISADM('DELETE',IRFXEL(I),0,0.0,0.0,.TRUE.,IFAIL) 1391 - 404 CONTINUE 1392 - *** Next x-coordinate. 1393 - 110 CONTINUE 1394 - *** End of full progress printing in 3 loops. 1395 - CALL PRORED(2) 1396 - *** Plot an overview for this wire. 1397 - IF(LARRPL)THEN 1398 - ** Inform about progress. 1399 - CALL PROFLD(2,'Overview plots',-1.0) 1400 - CALL PROSTA(2,0.0) 1401 - ** Plots of the average arrival time. 1402 - TMAX=-1.0 1403 - DO 210 I=1,IXP-IXM+1 1404 - IF(ARRFLG(I).NE.0)GOTO 210 1405 - DO 220 J=2,2+3*KELEC,3 1406 - TMAX=MAX(TMAX,ARRLIS(I,J)) 1407 - 220 CONTINUE 1408 - 210 CONTINUE 1409 - * No valid data. 1410 - IF(TMAX.LE.0.0)THEN 1411 - PRINT *,' !!!!!! DRFARR WARNING : Insufficient'// 1412 - - ' "average" data for '//STRID(1:NCID)// 1413 - - '; plot not made.' 1414 - ELSE 1415 - * Open frame. 1416 - CALL GRCART(ARRLIS(1,1),0.0,ARRLIS(IXP-IXM+1,1),TMAX, 1417 - - 'Distance from electrode centre [cm]', 1418 - - 'Drift time [microsec]', 1419 - - 'Average arrival times for '//STRID(1:NCID)) 1420 - * Add some comments. 1421 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 1422 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 1423 - IF(PARTID.NE.'Unknown') 1424 - - CALL GRCOMM(3,'Particle: '//PARTID) 1425 - CALL OUTFMT(180*ATAN(TANPHI)/PI,2,STR2,NC2,'LEFT') 1426 - CALL GRCOMM(4,'Angle: '//STR2(1:NC2)//' degrees') 1427 - * Plot each of the curves in turn. 1428 - DO 230 I=2,2+3*KELEC,3 1429 - IF(I.EQ.2)THEN 1430 - CALL GRATTS('FUNCTION-1','POLYLINE') 1431 - CALL GRATTS('FUNCTION-1','POLYMARKER') 1432 - ELSE 1433 - CALL GRATTS('FUNCTION-2','POLYLINE') 1434 - CALL GRATTS('FUNCTION-2','POLYMARKER') 1435 - ENDIF 1436 - NPLOT=0 1437 - DO 240 IX=1,IXP-IXM+1 1438 - IF(ARRFLG(IX).EQ.0)THEN 1439 - NPLOT=NPLOT+1 1440 - XPL(NPLOT)=ARRLIS(IX,1) 1441 - YPL(NPLOT)=ARRLIS(IX,I) 1442 - ELSE 1443 - IF(NPLOT.GT.1)THEN 1444 - CALL GPL(NPLOT,XPL,YPL) 1445 - ELSEIF(NPLOT.EQ.1)THEN 1446 - CALL GPM(1,XPL,YPL) 1447 - ENDIF 1448 - NPLOT=0 1449 - ENDIF 1450 - 240 CONTINUE 1451 - IF(NPLOT.GT.1)THEN 1452 - CALL GPL(NPLOT,XPL,YPL) 1453 - ELSEIF(NPLOT.EQ.1)THEN 1454 - CALL GPM(1,XPL,YPL) 1455 - ENDIF 1456 - 230 CONTINUE 1457 - * Close plot, record. 1458 - CALL GRALOG('Overview of average arrival times.') 1459 - CALL GRNEXT 1460 - ENDIF 1461 - ** Plots of the median arrival time. 1462 - TMAX=-1.0 1463 - DO 211 I=1,IXP-IXM+1 1464 - IF(ARRFLG(I).NE.0)GOTO 211 1465 - DO 221 J=3,3+3*KELEC,3 1466 - TMAX=MAX(TMAX,ARRLIS(I,J)) 1467 - 221 CONTINUE 1468 - 211 CONTINUE 1469 - * No valid data. 1470 - IF(TMAX.LE.0.0)THEN 1471 - PRINT *,' !!!!!! DRFARR WARNING : Insufficient'// 1472 - - ' "median" data for '//STRID(1:NCID)// 1473 - - '; plot not made.' 1474 - ELSE 1475 - * Open frame. 1476 - CALL GRCART(ARRLIS(1,1),0.0,ARRLIS(IXP-IXM+1,1),TMAX, 1477 - - 'Distance from electrode centre [cm]', 1478 - - 'Drift time [microsec]', 1479 - - 'Median arrival times for '//STRID(1:NCID)) 1480 - * Add some comments. 1481 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 1482 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 1483 - IF(PARTID.NE.'Unknown') 1484 - - CALL GRCOMM(3,'Particle: '//PARTID) 1485 - CALL OUTFMT(180*ATAN(TANPHI)/PI,2,STR2,NC2,'LEFT') 1486 - CALL GRCOMM(4,'Angle: '//STR2(1:NC2)//' degrees') 1487 - * Plot each of the curves in turn. 1488 - DO 231 I=3,3+3*KELEC,3 1489 - IF(I.EQ.3)THEN 1490 - CALL GRATTS('FUNCTION-1','POLYLINE') 1491 - CALL GRATTS('FUNCTION-1','POLYMARKER') 1492 - ELSE 1493 - CALL GRATTS('FUNCTION-2','POLYLINE') 1 646 P=DRIFT D=DRFARR 16 PAGE 941 1494 - CALL GRATTS('FUNCTION-2','POLYMARKER') 1495 - ENDIF 1496 - NPLOT=0 1497 - DO 241 IX=1,IXP-IXM+1 1498 - IF(ARRFLG(IX).EQ.0)THEN 1499 - NPLOT=NPLOT+1 1500 - XPL(NPLOT)=ARRLIS(IX,1) 1501 - YPL(NPLOT)=ARRLIS(IX,I) 1502 - ELSE 1503 - IF(NPLOT.GT.1)THEN 1504 - CALL GPL(NPLOT,XPL,YPL) 1505 - ELSEIF(NPLOT.EQ.1)THEN 1506 - CALL GPM(1,XPL,YPL) 1507 - ENDIF 1508 - NPLOT=0 1509 - ENDIF 1510 - 241 CONTINUE 1511 - IF(NPLOT.GT.1)THEN 1512 - CALL GPL(NPLOT,XPL,YPL) 1513 - ELSEIF(NPLOT.EQ.1)THEN 1514 - CALL GPM(1,XPL,YPL) 1515 - ENDIF 1516 - 231 CONTINUE 1517 - * Close plot, record. 1518 - CALL GRALOG('Overview of median arrival times.') 1519 - CALL GRNEXT 1520 - ENDIF 1521 - ** Plots of the arrival time spreads. 1522 - TMAX=-1.0 1523 - DO 212 I=1,IXP-IXM+1 1524 - IF(ARRFLG(I).NE.0)GOTO 212 1525 - DO 222 J=4,4+3*KELEC,3 1526 - TMAX=MAX(TMAX,ARRLIS(I,J)) 1527 - 222 CONTINUE 1528 - 212 CONTINUE 1529 - * No valid data. 1530 - IF(TMAX.LE.0.0)THEN 1531 - PRINT *,' !!!!!! DRFARR WARNING : Insufficient'// 1532 - - ' "spread" data for '//STRID(1:NCID)// 1533 - - '; plot not made.' 1534 - ELSE 1535 - * Open frame. 1536 - CALL GRCART(ARRLIS(1,1),0.0,ARRLIS(IXP-IXM+1,1),TMAX, 1537 - - 'Distance from electrode centre [cm]', 1538 - - 'RMS of arrival time [microsec]', 1539 - - 'Arrival time spread for '//STRID(1:NCID)) 1540 - * Add some comments. 1541 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 1542 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 1543 - IF(PARTID.NE.'Unknown') 1544 - - CALL GRCOMM(3,'Particle: '//PARTID) 1545 - CALL OUTFMT(180*ATAN(TANPHI)/PI,2,STR2,NC2,'LEFT') 1546 - CALL GRCOMM(4,'Angle: '//STR2(1:NC2)//' degrees') 1547 - * Plot each of the curves in turn. 1548 - DO 232 I=4,4+3*KELEC,3 1549 - IF(I.EQ.4)THEN 1550 - CALL GRATTS('FUNCTION-1','POLYLINE') 1551 - CALL GRATTS('FUNCTION-1','POLYMARKER') 1552 - ELSE 1553 - CALL GRATTS('FUNCTION-2','POLYLINE') 1554 - CALL GRATTS('FUNCTION-2','POLYMARKER') 1555 - ENDIF 1556 - NPLOT=0 1557 - DO 242 IX=1,IXP-IXM+1 1558 - IF(ARRFLG(IX).EQ.0)THEN 1559 - NPLOT=NPLOT+1 1560 - XPL(NPLOT)=ARRLIS(IX,1) 1561 - YPL(NPLOT)=ARRLIS(IX,I) 1562 - ELSE 1563 - IF(NPLOT.GT.1)THEN 1564 - CALL GPL(NPLOT,XPL,YPL) 1565 - ELSEIF(NPLOT.EQ.1)THEN 1566 - CALL GPM(1,XPL,YPL) 1567 - ENDIF 1568 - NPLOT=0 1569 - ENDIF 1570 - 242 CONTINUE 1571 - IF(NPLOT.GT.1)THEN 1572 - CALL GPL(NPLOT,XPL,YPL) 1573 - ELSEIF(NPLOT.EQ.1)THEN 1574 - CALL GPM(1,XPL,YPL) 1575 - ENDIF 1576 - 232 CONTINUE 1577 - * Close plot, record. 1578 - CALL GRALOG('Overview of arrival times spreads.') 1579 - CALL GRNEXT 1580 - ENDIF 1581 - ENDIF 1582 - *** Output the data to a dataset if requested. 1583 - IF(LARRWR)THEN 1584 - ** Inform about progress. 1585 - CALL PROFLD(2,'Dataset output',-1.0) 1586 - CALL PROSTA(2,0.0) 1587 - ** Open the dataset. 1588 - CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) 1589 - IF(IFAIL.NE.0)THEN 1590 - PRINT *,' !!!!!! DRFARR WARNING : Opening the file'// 1591 - - FILE(1:NCFILE)//' failed ; write flag cancelled.' 1592 - LARRWR=.FALSE. 1593 - ENDIF 1594 - CALL DSNLOG(FILE,'Arrival ','Sequential','Write ') 1595 - * Now write a heading record to the file. 1596 - CALL DATTIM(DATE,TIME) 1597 - IF(REMARK.NE.'None')THEN 1598 - WRITE(12,'(''% Created '',A8,'' At '',A8,1X,A8, 1599 - - '' ARRIVAL "'',A29,''"'')',ERR=2010,IOSTAT=IOS) 1 646 P=DRIFT D=DRFARR 17 PAGE 942 1600 - - DATE,TIME,MEMBER,REMARK 1601 - ELSE 1602 - WRITE(12,'(''% Created '',A8,'' At '',A8,1X,A8, 1603 - - '' ARRIVAL "'',A15,'' phi '',F9.2,''"'')', 1604 - - ERR=2010,IOSTAT=IOS) 1605 - - DATE,TIME,MEMBER,STRID,180*ATAN(TANPHI)/PI 1606 - ENDIF 1607 - * Specify the number of records to be written. 1608 - WRITE(12,'('' Threshold setting: '',E15.8/ 1609 - - '' Angle to vertical: '',E15.8/ 1610 - - '' Random cycles: '',I10/ 1611 - - '' Selected electrons:'',I10)',ERR=2010,IOSTAT=IOS) 1612 - - THRESH,180*ATAN(TANPHI)/PI,NRNDM,KELEC 1613 - * Indicate the columns. 1614 - WRITE(12,'('' Distance Electron Average time'', 1615 - - '' Threshold time Time spread Notes''/ 1616 - - '' [cm] [microsec]'', 1617 - - '' [microsec] [microsec]'')', 1618 - - ERR=2010,IOSTAT=IOS) 1619 - ** Write the data itself, interpreting the various flags. 1620 - DO 300 IX=1,IXP-IXM+1 1621 - * Prepare a string containing roughly the data. 1622 - IF(ARRFLG(IX).EQ.0)THEN 1623 - WRITE(12,'(1X,E15.8,1X,'' all'',3(1X,E15.8), 1624 - - 1X,''No problem'')',ERR=2010,IOSTAT=IOS) 1625 - - (ARRLIS(IX,I),I=1,4) 1626 - DO 301 K=1,KELEC 1627 - WRITE(12,'(17X,I8,3(1X,E15.8))',ERR=2010,IOSTAT=IOS) 1628 - - MELEC(K),(ARRLIS(IX,1+3*K+I),I=1,3) 1629 - 301 CONTINUE 1630 - ELSEIF(ARRFLG(IX).EQ.-1)THEN 1631 - WRITE(12,'(1X,E15.8,1X,'' all'', 1632 - - 3('' Not available''), 1633 - - 1X,''! Track located outside the area.'')', 1634 - - ERR=2010,IOSTAT=IOS) ARRLIS(IX,1) 1635 - ELSEIF(ARRFLG(IX).EQ.-2)THEN 1636 - WRITE(12,'(1X,E15.8,1X,'' all'', 1637 - - 3('' Not available''), 1638 - - 1X,''! Track preparation failed.'')', 1639 - - ERR=2010,IOSTAT=IOS) ARRLIS(IX,1) 1640 - ELSEIF(ARRFLG(IX).EQ.-3)THEN 1641 - WRITE(12,'(1X,E15.8,1X,'' all'', 1642 - - 3('' Not available''), 1643 - - 1X,''! Track has zero time range.'')', 1644 - - ERR=2010,IOSTAT=IOS) ARRLIS(IX,1) 1645 - ELSEIF(ARRFLG(IX).EQ.-4)THEN 1646 - WRITE(12,'(1X,E15.8,1X,'' all'', 1647 - - 3('' Not available''), 1648 - - 1X,''! No track data collected.'')', 1649 - - ERR=2010,IOSTAT=IOS) ARRLIS(IX,1) 1650 - ELSEIF(ARRFLG(IX).EQ.-5)THEN 1651 - WRITE(12,'(1X,E15.8,1X,'' all'',3(1X,E15.8), 1652 - - 1X,''! Poor statistics or data.'')', 1653 - - ERR=2010,IOSTAT=IOS) (ARRLIS(IX,I),I=1,4) 1654 - DO 302 K=1,KELEC 1655 - WRITE(12,'(17X,I8,3(1X,E15.8))',ERR=2010,IOSTAT=IOS) 1656 - - MELEC(K),(ARRLIS(IX,1+3*K+I),I=1,3) 1657 - 302 CONTINUE 1658 - ELSEIF(ARRFLG(IX).EQ.-6)THEN 1659 - WRITE(12,'(1X,E15.8,1X,'' all'', 1660 - - 3('' Not available''), 1661 - - 1X,''! Clustering error.'')', 1662 - - ERR=2010,IOSTAT=IOS) ARRLIS(IX,1) 1663 - ELSE 1664 - WRITE(12,'(1X,E15.8,1X,'' all'',3(1X,E15.8), 1665 - - 1X,''# Unknown status flag.'')', 1666 - - ERR=2010,IOSTAT=IOS) (ARRLIS(IX,I),I=1,4) 1667 - DO 303 K=1,KELEC 1668 - WRITE(12,'(17X,I8,3(1X,E15.8))',ERR=2010,IOSTAT=IOS) 1669 - - MELEC(K),(ARRLIS(IX,1+3*K+I),I=1,3) 1670 - 303 CONTINUE 1671 - ENDIF 1672 - 300 CONTINUE 1673 - * Close the file, if openend. 1674 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 1675 - ENDIF 1676 - *** Save the results, if desired. 1677 - IF(LARRKP)THEN 1678 - * Store the matrix dimensions for all matrix saves. 1679 - ISIZ(1)=IXP-IXM+1 1680 - IDIM(1)=MXLIST 1681 - * Format the output sequence number. 1682 - JOVER=JOVER+1 1683 - CALL OUTFMT(REAL(JOVER),2,STR1,NC1,'LEFT') 1684 - * Save the x-coordinates. 1685 - IF(STEP.EQ.'X')THEN 1686 - CALL MATSAV(ARRLIS(1,1),1,IDIM,ISIZ, 1687 - - 'X_'//STR1(1:NC1),IFAIL1) 1688 - ELSEIF(STEP.EQ.'Y')THEN 1689 - CALL MATSAV(ARRLIS(1,1),1,IDIM,ISIZ, 1690 - - 'Y_'//STR1(1:NC1),IFAIL1) 1691 - ELSEIF(STEP.EQ.'Z')THEN 1692 - CALL MATSAV(ARRLIS(1,1),1,IDIM,ISIZ, 1693 - - 'Z_'//STR1(1:NC1),IFAIL1) 1694 - ENDIF 1695 - * Save the all-electron x(t) relation. 1696 - CALL MATSAV(ARRLIS(1,2),1,IDIM,ISIZ, 1697 - - 'MEAN_'//STR1(1:NC1),IFAIL2) 1698 - CALL MATSAV(ARRLIS(1,3),1,IDIM,ISIZ, 1699 - - 'MEDIAN_'//STR1(1:NC1),IFAIL3) 1700 - CALL MATSAV(ARRLIS(1,4),1,IDIM,ISIZ, 1701 - - 'RMS_'//STR1(1:NC1),IFAIL4) 1702 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. 1703 - - IFAIL4.NE.0)PRINT *,' !!!!!! DRFARR WARNING :'// 1704 - - ' Error saving all-electron x(t) relation.' 1705 - * Save the selected electron sequence numbers. 1 646 P=DRIFT D=DRFARR 18 PAGE 943 1706 - DO 400 K=1,KELEC 1707 - CALL OUTFMT(REAL(K),2,STR2,NC2,'LEFT') 1708 - CALL NUMSAV(REAL(MELEC(K)),'E_'//STR2(1:NC2),IFAIL1) 1709 - 400 CONTINUE 1710 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DRFARR WARNING : Unable'// 1711 - - ' to save the electron sequence numbers.' 1712 - * Save the selected electron x(t) relations. 1713 - DO 410 K=1,KELEC 1714 - CALL OUTFMT(REAL(K),2,STR2,NC2,'LEFT') 1715 - CALL MATSAV(ARRLIS(1,2+3*K),1,IDIM,ISIZ, 1716 - - 'MEAN'//STR2(1:NC2)//'_'//STR1(1:NC1),IFAIL2) 1717 - CALL MATSAV(ARRLIS(1,3+3*K),1,IDIM,ISIZ, 1718 - - 'MEDIAN'//STR2(1:NC2)//'_'//STR1(1:NC1),IFAIL3) 1719 - CALL MATSAV(ARRLIS(1,4+3*K),1,IDIM,ISIZ, 1720 - - 'RMS'//STR2(1:NC2)//'_'//STR1(1:NC1),IFAIL4) 1721 - IF(IFAIL2.NE.0.OR.IFAIL3.NE.0.OR.IFAIL4.NE.0) 1722 - - PRINT *,' !!!!!! DRFARR WARNING : Error saving x(t)'// 1723 - - ' for selected electron '//STR2(1:NC2)//'.' 1724 - 410 CONTINUE 1725 - ENDIF 1726 - *** Proceed with the next wire. 1727 - 100 CONTINUE 1728 - *** End of progress printing. 1729 - CALL PROEND 1730 - *** Register the amount of CPU time used by this routine. 1731 - CALL TIMLOG('Calculating arrival times: ') 1732 - RETURN 1733 - *** Handle I/O problems. 1734 - 2010 CONTINUE 1735 - PRINT *,' ###### DRFARR ERROR : Error while'// 1736 - - ' writing the arrival data set ; attempt to close.' 1737 - CALL INPIOS(IOS) 1738 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 1739 - RETURN 1740 - 2030 CONTINUE 1741 - PRINT *,' ###### DRFARR ERROR : Unable to close the data set'// 1742 - - ' of the arrival times ; results not predictable.' 1743 - CALL INPIOS(IOS) 1744 - END 647 GARFIELD ================================================== P=DRIFT D=DRFDRF 1 ============================ 0 + +DECK,DRFDRF. 1 - SUBROUTINE DRFDRF 2 - *----------------------------------------------------------------------- 3 - * DRFDRF - This routine makes drift line plots. 4 - * VARIABLES : TSTEPR : Value of TSTEP as read from the input file. 5 - * START : Sort of call, should be obvious. 6 - * LEQTPL : Plot equal time contours or not. 7 - * LLINPL : Plotting of the drift lines. 8 - * LLINPR : Printing of the drift lines. 9 - * TSTEP : Distance between equal time contours. 10 - * MARKER : If .TRUE., markers (*) will be plotted 11 - * instead of a solid line. 12 - * (Last changed on 27/ 3/00.) 13 - *----------------------------------------------------------------------- 14 - implicit none 15.- +SEQ,DIMENSIONS. 16.- +SEQ,GASDATA. 17.- +SEQ,PARAMETERS. 18.- +SEQ,DRIFTLINE. 19.- +SEQ,PRINTPLOT. 20.- +SEQ,CONSTANTS. 21 - LOGICAL LLINPL,LLINPR,LEQTPL,LDIFPL,LTIMPL,LVELPL,LAVAPL, 22 - - LFUNPL,MARKER,SIDE(4),FLAG(MXWORD+3),LDRMC,OK, 23 - - LEQRTR,LEQRWI,LEQRED,LEQRSO,LEQRZE 24 - CHARACTER*5 START 25 - CHARACTER*(MXCHAR) FUNCT 26 - REAL TSTEP,TSTEPR,Q,ANGMIN,ANGMAX,AMINR,AMAXR 27 - INTEGER NLINEE,NLINEW,NLINEV,NLINER,NCF,ITYPE,I,J,NWORD,INEXT, 28 - - INPCMP,INPTYP,IFAIL,IFAIL1,IFAIL2,ISOREV 29 - EXTERNAL INPCMP,INPTYP 0 30-+ +SELF,IF=SAVE. 31 - SAVE LLINPL,LLINPR,LEQTPL,LDIFPL,LTIMPL,LVELPL,LAVAPL, 32 - - LFUNPL,SIDE,TSTEP,Q,START,ITYPE,FUNCT,LDRMC, 33 - - NLINEE,NLINEW,NLINEV, 34 - - LEQRTR,LEQRWI,LEQRED,LEQRSO,LEQRZE,ANGMIN,ANGMAX 0 35-+ +SELF. 36 - *** Initialise the parameters with DATA statements. 37 - DATA LLINPL , LLINPR , LEQTPL , LDRMC 38 - - /.TRUE. , .FALSE., .FALSE., .FALSE./ 39 - DATA LTIMPL , LVELPL , LDIFPL , LAVAPL , LFUNPL 40 - - /.FALSE., .FALSE., .FALSE., .FALSE., .FALSE./ 41 - DATA (SIDE(I),I=1,4) /.TRUE.,.TRUE.,.FALSE.,.FALSE./ 42 - DATA MARKER /.FALSE./ 43 - DATA START/' '/ 44 - DATA FUNCT/' '/ 45 - DATA NCF/1/ 46 - DATA ITYPE/1/ 47 - DATA NLINEE/20/,NLINEW/20/,NLINEV/20/ 48 - DATA Q,TSTEP/-1.0,0.5/ 49 - DATA ANGMIN/0/,ANGMAX/6.2831853/ 50 - DATA LEQRTR , LEQRWI , LEQRED , LEQRSO , LEQRZE 51 - - /.TRUE. , .FALSE., .TRUE. , .FALSE., .TRUE./ 52 - *** Decode the argument sring. 53 - CALL INPNUM(NWORD) 54 - *** First mark the keywords. 55 - DO 10 I=1,MXWORD+3 56 - IF(I.EQ.1.OR.I.GT.NWORD)THEN 57 - FLAG(I)=.TRUE. 58 - GOTO 10 59 - ENDIF 60 - FLAG(I)=.FALSE. 61 - IF(INPCMP(I,'ANG#LES-#RANGE')+ 1 647 P=DRIFT D=DRFDRF 2 PAGE 944 62 - - INPCMP(I,'A#VALANCHE-GR#APH')+ 63 - - INPCMP(I,'CONT#OUR-#INTERVAL')+ 64 - - INPCMP(I,'D#IFFUSION-GR#APH')+ INPCMP(I,'D#OWN')+ 65 - - INPCMP(I,'EDG#ES')+ INPCMP(I,'EL#ECTRON')+ 66 - - INPCMP(I,'F#UNCTION-GR#APH')+ INPCMP(I,'ISO#CHRONES')+ 67 - - INPCMP(I,'I#ON')+ 68 - - INPCMP(I,'L#EFT')+ INPCMP(I,'L#INE-PL#OT')+ 69 - - INPCMP(I,'L#INE-PR#INT')+ INPCMP(I,'MAR#KERS')+ 70 - - INPCMP(I,'M#ONTE-C#ARLO-#DRIFT')+INPCMP(I,'MC-#DRIFT')+ 71 - - INPCMP(I,'NEG#ATIVE')+ 72 - - INPCMP(I,'NOA#VALANCHE-GR#APH')+ 73 - - INPCMP(I,'NOCONT#OUR')+ 74 - - INPCMP(I,'NOD#IFFUSION-GR#APH')+ 75 - - INPCMP(I,'NOF#UNCTION-GR#APH')+INPCMP(I,'NOISO#CHRONES')+ 76 - - INPCMP(I,'NOL#INE-PL#OT')+ 77 - - INPCMP(I,'NOL#INE-PR#INT')+ INPCMP(I,'NOT#IME-GR#APH')+ 78 - - INPCMP(I,'NOM#ONTE-C#ARLO-#DRIFT')+ 79 - - INPCMP(I,'NOMC-#DRIFT')+ 80 - - INPCMP(I,'RUN#GE-K#UTTA-#DRIFT-#LINES')+ 81 - - INPCMP(I,'RKF-#DRIFT-#LINES')+ 82 - - INPCMP(I,'NOTD#OWN')+ INPCMP(I,'NOTL#EFT')+ 83 - - INPCMP(I,'NOTR#IGHT')+ INPCMP(I,'NOTU#P')+ 84 - - INPCMP(I,'NOV#ELOCITY-GR#APH')+INPCMP(I,'POS#ITIVE')+ 85 - - INPCMP(I,'REV#ERSE-#ISOCHRONES')+ 86 - - INPCMP(I,'R#IGHT')+ INPCMP(I,'SOL#ID')+ 87 - - INPCMP(I,'THR#ESHOLD')+ INPCMP(I,'LINE#S')+ 88 - - INPCMP(I,'T#IME-GR#APH')+ INPCMP(I,'TR#ACK')+ 89 - - INPCMP(I,'SOL#IDS')+ 90 - - INPCMP(I,'U#P')+ INPCMP(I,'V#ELOCITY-GR#APH')+ 91 - - INPCMP(I,'WIR#ES')+ 92 - - INPCMP(I,'ZER#OS').NE.0)FLAG(I)=.TRUE. 93 - 10 CONTINUE 94 - *** Initial settings. 95 - ISOREV=0 96 - *** Next figure out which options are effectively there. 97 - INEXT=2 98 - OK=.TRUE. 99 - DO 20 I=2,NWORD 100 - IF(I.LT.INEXT)GOTO 20 101 - ** Check whether drift-lines have to start from the edges. 102 - IF(INPCMP(I,'EDG#ES').NE.0)THEN 103 - START='EDGE' 104 - DO 30 J=I+1,NWORD 105 - * Look for the subkeyword RIGHT, 106 - IF(INPCMP(J,'NOTR#IGHT')+ 107 - - INPCMP(J,'NOR#IGHT').NE.0)THEN 108 - SIDE(1)=.FALSE. 109 - ELSEIF(INPCMP(J,'R#IGHT').NE.0)THEN 110 - SIDE(1)=.TRUE. 111 - * Look for the subkeyword LEFT, 112 - ELSEIF(INPCMP(J,'NOTL#EFT')+ 113 - - INPCMP(J,'NOL#EFT').NE.0)THEN 114 - SIDE(2)=.FALSE. 115 - ELSEIF(INPCMP(J,'L#EFT').NE.0)THEN 116 - SIDE(2)=.TRUE. 117 - * Look for the subkeyword UP, 118 - ELSEIF(INPCMP(J,'NOTU#P')+ 119 - - INPCMP(J,'NOU#P').NE.0)THEN 120 - SIDE(3)=.FALSE. 121 - ELSEIF(INPCMP(J,'U#P').NE.0)THEN 122 - SIDE(3)=.TRUE. 123 - * Look for the subkeyword DOWN, 124 - ELSEIF(INPCMP(J,'NOTD#OWN')+ 125 - - INPCMP(J,'NOD#OWN').NE.0)THEN 126 - SIDE(4)=.FALSE. 127 - ELSEIF(INPCMP(J,'D#OWN').NE.0)THEN 128 - SIDE(4)=.TRUE. 129 - * Look for the grouped options. 130 - ELSEIF(INPCMP(J,'ALL').NE.0)THEN 131 - SIDE(1)=.TRUE. 132 - SIDE(2)=.TRUE. 133 - SIDE(3)=.TRUE. 134 - SIDE(4)=.TRUE. 135 - ELSEIF(INPCMP(J,'NONE').NE.0)THEN 136 - SIDE(1)=.FALSE. 137 - SIDE(2)=.FALSE. 138 - SIDE(3)=.FALSE. 139 - SIDE(4)=.FALSE. 140 - ELSEIF(INPCMP(J,'HOR#IZONTAL').NE.0)THEN 141 - SIDE(1)=.TRUE. 142 - SIDE(2)=.TRUE. 143 - ELSEIF(INPCMP(J,'NOHOR#IZONTAL')+ 144 - - INPCMP(J,'NOTHOR#IZONTAL').NE.0)THEN 145 - SIDE(1)=.FALSE. 146 - SIDE(2)=.FALSE. 147 - ELSEIF(INPCMP(J,'VERT#ICAL').NE.0)THEN 148 - SIDE(3)=.TRUE. 149 - SIDE(4)=.TRUE. 150 - ELSEIF(INPCMP(J,'NOVERT#ICAL')+ 151 - - INPCMP(J,'NOTVERT#ICAL').NE.0)THEN 152 - SIDE(3)=.FALSE. 153 - SIDE(4)=.FALSE. 154 - * Perhaps a number of lines. 155 - ELSEIF(INPCMP(J,'LINE#S').NE.0)THEN 156 - IF(INPTYP(J+1).NE.1.OR.FLAG(J+1))THEN 157 - CALL INPMSG(J,'Misses an integer argument') 158 - OK=.FALSE. 159 - INEXT=J+1 160 - ELSE 161 - CALL INPCHK(J+1,1,IFAIL1) 162 - CALL INPRDI(J+1,NLINER,NLINEE) 163 - IF(NLINER.GT.0)THEN 164 - NLINEE=NLINER 165 - ELSE 166 - CALL INPMSG(J+1,'Should be at least 1') 167 - OK=.FALSE. 1 647 P=DRIFT D=DRFDRF 3 PAGE 945 168 - ENDIF 169 - INEXT=J+2 170 - ENDIF 171 - * Not known in this context, skip this processing. 172 - ELSE 173 - INEXT=J 174 - GOTO 20 175 - ENDIF 176 - * Next subkeyword. 177 - 30 CONTINUE 178 - INEXT=NWORD+1 179 - ** Check whether drift-lines have to start from the wire surfaces. 180 - ELSEIF(INPCMP(I,'WIR#ES').NE.0)THEN 181 - START='WIRE' 182 - DO 50 J=I+1,NWORD 183 - IF(J.LT.INEXT)GOTO 50 184 - * Perhaps a number of lines. 185 - IF(INPCMP(J,'LINE#S').NE.0)THEN 186 - IF(INPTYP(J+1).NE.1.OR.FLAG(J+1))THEN 187 - CALL INPMSG(J,'Misses an integer argument') 188 - INEXT=J+1 189 - OK=.FALSE. 190 - ELSE 191 - CALL INPCHK(J+1,1,IFAIL1) 192 - CALL INPRDI(J+1,NLINER,NLINEW) 193 - IF(NLINER.GT.0)THEN 194 - NLINEW=NLINER 195 - ELSE 196 - CALL INPMSG(J+1,'Should be at least 1') 197 - OK=.FALSE. 198 - ENDIF 199 - INEXT=J+2 200 - ENDIF 201 - ELSEIF(INPCMP(J,'ANG#LES-#RANGE').NE.0)THEN 202 - IF(FLAG(J+1).OR.FLAG(J+2))THEN 203 - CALL INPMSG(J,'Takes 2 real arguments') 204 - INEXT=J+1 205 - OK=.FALSE. 206 - ELSE 207 - CALL INPCHK(J+1,2,IFAIL1) 208 - CALL INPCHK(J+2,2,IFAIL2) 209 - CALL INPRDR(J+1,AMINR,ANGMIN*180/PI) 210 - CALL INPRDR(J+2,AMAXR,ANGMAX*180/PI) 211 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND. 212 - - AMINR.EQ.AMAXR)THEN 213 - CALL INPMSG(J+1,'Zero range not permitted.') 214 - CALL INPMSG(J+2,'See previous message.') 215 - OK=.FALSE. 216 - ELSEIF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN 217 - ANGMIN=AMINR*PI/180 218 - ANGMAX=AMAXR*PI/180 219 - ENDIF 220 - INEXT=J+3 221 - ENDIF 222 - * Not known in this context, skip this processing. 223 - ELSE 224 - INEXT=J 225 - GOTO 20 226 - ENDIF 227 - 50 CONTINUE 228 - ** Check whether drift-lines have to start from the wire surfaces. 229 - ELSEIF(INPCMP(I,'SOL#IDS').NE.0)THEN 230 - START='SOLID' 231 - DO 60 J=I+1,NWORD 232 - IF(J.LT.INEXT)GOTO 60 233 - * Perhaps a number of lines. 234 - IF(INPCMP(J,'LINE#S').NE.0)THEN 235 - IF(INPTYP(J+1).NE.1.OR.FLAG(J+1))THEN 236 - CALL INPMSG(J,'Misses an integer argument') 237 - OK=.FALSE. 238 - INEXT=J+1 239 - ELSE 240 - CALL INPCHK(J+1,1,IFAIL1) 241 - CALL INPRDI(J+1,NLINER,NLINEV) 242 - IF(NLINER.GT.0)THEN 243 - NLINEV=NLINER 244 - ELSE 245 - CALL INPMSG(J+1,'Should be at least 1') 246 - OK=.FALSE. 247 - ENDIF 248 - INEXT=J+2 249 - ENDIF 250 - * Not known in this context, skip this processing. 251 - ELSE 252 - INEXT=J 253 - GOTO 20 254 - ENDIF 255 - 60 CONTINUE 256 - ** Check whether drift-lines have to start from the track. 257 - ELSEIF(INPCMP(I,'TR#ACK').NE.0)THEN 258 - IF(TRFLAG(1))THEN 259 - START='TRACK' 260 - * Look for the subkeywords. 261 - DO 40 J=I+1,NWORD 262 - IF(J.LT.INEXT)GOTO 40 263 - * Look for the line type of the graphs. 264 - IF(INPCMP(J,'MARK#ERS').NE.0)THEN 265 - MARKER=.TRUE. 266 - ELSEIF(INPCMP(J,'SOL#ID').NE.0)THEN 267 - MARKER=.FALSE. 268 - * Look for the drift-time plotting option. 269 - ELSEIF(INPCMP(J,'T#IME-GR#APH').NE.0)THEN 270 - IF(.NOT.GASOK(1))THEN 271 - CALL INPMSG(J, 272 - - 'Drift velocity data absent. ') 273 - OK=.FALSE. 1 647 P=DRIFT D=DRFDRF 4 PAGE 946 274 - ELSE 275 - LTIMPL=.TRUE. 276 - ENDIF 277 - ELSEIF(INPCMP(J,'NOT#IME-GR#APH').NE.0)THEN 278 - LTIMPL=.FALSE. 279 - * Look for the drift-velocity plotting option. 280 - ELSEIF(INPCMP(J,'V#ELOCITY-GR#APH').NE.0)THEN 281 - IF(.NOT.GASOK(1))THEN 282 - CALL INPMSG(J, 283 - - 'Drift velocity data absent. ') 284 - OK=.FALSE. 285 - ELSE 286 - LVELPL=.TRUE. 287 - ENDIF 288 - ELSEIF(INPCMP(J,'NOV#ELOCITY-GR#APH').NE.0)THEN 289 - LVELPL=.FALSE. 290 - * Look for the diffusion plotting option. 291 - ELSEIF(INPCMP(J,'D#IFFUSION-GR#APH').NE.0)THEN 292 - IF(.NOT.GASOK(3))THEN 293 - CALL INPMSG(J, 294 - - 'The diffusion data are absent.') 295 - OK=.FALSE. 296 - ELSE 297 - LDIFPL=.TRUE. 298 - ENDIF 299 - ELSEIF(INPCMP(J,'NOD#IFFUSION-GR#APH').NE.0)THEN 300 - LDIFPL=.FALSE. 301 - * Look for the avalanche plotting option. 302 - ELSEIF(INPCMP(J,'A#VALANCHE-GR#APH').NE.0)THEN 303 - IF(.NOT.GASOK(4))THEN 304 - CALL INPMSG(J, 305 - - 'The avalanche data are absent.') 306 - OK=.FALSE. 307 - ELSE 308 - LAVAPL=.TRUE. 309 - ENDIF 310 - ELSEIF(INPCMP(J,'NOA#VALANCHE-GR#APH').NE.0)THEN 311 - LAVAPL=.FALSE. 312 - * Look for the function graph plotting option. 313 - ELSEIF(INPCMP(J,'F#UNCTION-GR#APH').NE.0)THEN 314 - IF(FLAG(J+1).AND. 315 - - (NCF.LT.1.OR.FUNCT(1:NCF).EQ.' '))THEN 316 - CALL INPMSG(J, 317 - - 'Function not specified. ') 318 - OK=.FALSE. 319 - ELSE 320 - CALL INPSTR(J+1,J+1,FUNCT,NCF) 321 - LFUNPL=.TRUE. 322 - INEXT=J+2 323 - ENDIF 324 - ELSEIF(INPCMP(J,'NOF#UNCTION-GR#APH').NE.0)THEN 325 - LFUNPL=.FALSE. 326 - FUNCT=' ' 327 - NCF=1 328 - * Skip this processing if the keyword is not recognised. 329 - ELSE 330 - INEXT=J 331 - GOTO 20 332 - ENDIF 333 - 40 CONTINUE 334 - INEXT=NWORD+1 335 - * Warn if no track has been defined. 336 - ELSE 337 - CALL INPMSG(I,'The track has not been set. ') 338 - OK=.FALSE. 339 - ENDIF 340 - * Check whether the drift-lines have to start from the zeros. 341 - ELSEIF(INPCMP(I,'Z#EROS').NE.0)THEN 342 - START='ZERO' 343 - * Search for particle type, 344 - ELSEIF(INPCMP(I,'EL#ECTRON').NE.0)THEN 345 - Q=-1 346 - ITYPE=1 347 - ELSEIF(INPCMP(I,'I#ON').NE.0)THEN 348 - IF(GASOK(2))THEN 349 - Q=+1 350 - ITYPE=2 351 - ELSE 352 - CALL INPMSG(I,'Ion mobility data are missing.') 353 - OK=.FALSE. 354 - ENDIF 355 - * Look for the keyword CONTOUR, 356 - ELSEIF(INPCMP(I,'CONT#OURS-#INTERVAL')+ 357 - - INPCMP(I,'ISO#CHRONES-#INTERVAL').NE.0)THEN 358 - IF(I+1.GT.NWORD)THEN 359 - CALL INPMSG(I,'Should have a delta t as arg. ') 360 - OK=.FALSE. 361 - ELSE 362 - CALL INPCHK(I+1,2,IFAIL) 363 - CALL INPRDR(I+1,TSTEPR,TSTEP) 364 - IF(TSTEPR.LE.0.0)THEN 365 - CALL INPMSG(I,'See the next message. ') 366 - CALL INPMSG(I+1,'Interval must be larger than 0') 367 - OK=.FALSE. 368 - ENDIF 369 - IF(IFAIL.EQ.0.AND.TSTEPR.GT.0)THEN 370 - LEQTPL=.TRUE. 371 - TSTEP=TSTEPR 372 - ENDIF 373 - INEXT=I+2 374 - ENDIF 375 - ELSEIF(INPCMP(I,'NOCONT#OURS')+ 376 - - INPCMP(I,'NOISO#CHRONES').NE.0)THEN 377 - LEQTPL=.FALSE. 378 - * Reverse isochrones. 379 - ELSEIF(INPCMP(I,'REV#ERSE-#ISOCHRONES').NE.0)THEN 1 647 P=DRIFT D=DRFDRF 5 PAGE 947 380 - ISOREV=1 381 - ELSEIF(INPCMP(I,'NOREV#ERSE-#ISOCHRONES').NE.0)THEN 382 - ISOREV=-1 383 - * Look for the drift-line plotting option. 384 - ELSEIF(INPCMP(I,'L#INE-PL#OT').NE.0)THEN 385 - LLINPL=.TRUE. 386 - ELSEIF(INPCMP(I,'NOL#INE-PL#OT').NE.0)THEN 387 - LLINPL=.FALSE. 388 - * Look for the drift-line printing option. 389 - ELSEIF(INPCMP(I,'L#INE-PR#INT').NE.0)THEN 390 - LLINPR=.TRUE. 391 - ELSEIF(INPCMP(I,'NOL#INE-PR#INT').NE.0)THEN 392 - LLINPR=.FALSE. 393 - * Look for the charge of the particles to be drifted. 394 - ELSEIF(INPCMP(I,'POS#ITIVE').NE.0)THEN 395 - Q=+1.0 396 - ELSEIF(INPCMP(I,'NEG#ATIVE').NE.0)THEN 397 - Q=-1.0 398 - * Look for the Monte-Carlo options. 399 - ELSEIF(INPCMP(I,'M#ONTE-C#ARLO-#DRIFT-#LINES')+ 400 - - INPCMP(I,'MC-#DRIFT-#LINES').NE.0)THEN 401 - LDRMC=.TRUE. 402 - ELSEIF(INPCMP(I,'NOM#ONTE-C#ARLO-#DRIFT-#LINES')+ 403 - - INPCMP(I,'NOMC-#DRIFT-#LINES')+ 404 - - INPCMP(I,'RUN#GE-K#UTTA-#DRIFT-#LINES')+ 405 - - INPCMP(I,'RKF-#DRIFT-#LINES').NE.0)THEN 406 - LDRMC=.FALSE. 407 - * Valid option out of context. 408 - ELSEIF(FLAG(I))THEN 409 - CALL INPMSG(I,'Valid option out of context. ') 410 - OK=.FALSE. 411 - * Option not known. 412 - ELSE 413 - CALL INPMSG(I,'The option is not known. ') 414 - OK=.FALSE. 415 - ENDIF 416 - 20 CONTINUE 417 - CALL INPERR 418 - *** Check for errors. 419 - IF(JFAIL.EQ.2.AND..NOT.OK)THEN 420 - PRINT *,' ###### DRFDRF ERROR : Instruction is not'// 421 - - ' carried out because of the above errors.' 422 - RETURN 423 - ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN 424 - PRINT *,' ###### DRFDRF ERROR : Program terminated'// 425 - - ' because of the above errors.' 426 - CALL QUIT 427 - ENDIF 428 - *** Check at least some output has been requested. 429 - IF(.NOT.(LEQTPL.OR.LLINPL.OR.LLINPR.OR.(START.EQ.'TRACK'.AND. 430 - - (LTIMPL.OR.LVELPL.OR.LDIFPL.OR.LAVAPL.OR.LFUNPL))))THEN 431 - PRINT *,' !!!!!! DRFDRF WARNING : DRIFT statement not', 432 - - ' executed because all output has been suppressed.' 433 - RETURN 434 - ENDIF 435 - * Carry out the drifting operation. 436 - IF(START.EQ.'WIRE')THEN 437 - IF(ISOREV.EQ.1)THEN 438 - LEQRWI=.TRUE. 439 - ELSEIF(ISOREV.EQ.-1)THEN 440 - LEQRWI=.FALSE. 441 - ENDIF 442 - IF(ITYPE.EQ.1)THEN 443 - CALL DRFWIR(-Q,ITYPE,TSTEP,LEQTPL,LEQRWI, 444 - - ANGMIN,ANGMAX,LLINPL,LLINPR,NLINEW) 445 - ELSE 446 - CALL DRFWIR(+Q,ITYPE,TSTEP,LEQTPL,LEQRWI, 447 - - ANGMIN,ANGMAX,LLINPL,LLINPR,NLINEW) 448 - ENDIF 449 - ELSEIF(START.EQ.'SOLID')THEN 450 - IF(ISOREV.EQ.1)THEN 451 - LEQRSO=.TRUE. 452 - ELSEIF(ISOREV.EQ.-1)THEN 453 - LEQRSO=.FALSE. 454 - ENDIF 455 - IF(ITYPE.EQ.1)THEN 456 - CALL DRFSOL(-Q,ITYPE,TSTEP,LEQTPL,LEQRSO, 457 - - LLINPL,LLINPR,NLINEV) 458 - ELSE 459 - CALL DRFSOL(+Q,ITYPE,TSTEP,LEQTPL,LEQRSO, 460 - - LLINPL,LLINPR,NLINEV) 461 - ENDIF 462 - ELSEIF(START.EQ.'EDGE')THEN 463 - IF(ISOREV.EQ.1)THEN 464 - LEQRED=.TRUE. 465 - ELSEIF(ISOREV.EQ.-1)THEN 466 - LEQRED=.FALSE. 467 - ENDIF 468 - CALL DRFEDG(Q,ITYPE,TSTEP,LEQTPL,LEQRED, 469 - - LLINPL,LLINPR,SIDE,NLINEE) 470 - ELSEIF(START.EQ.'TRACK')THEN 471 - IF(ISOREV.EQ.1)THEN 472 - LEQRTR=.TRUE. 473 - ELSEIF(ISOREV.EQ.-1)THEN 474 - LEQRTR=.FALSE. 475 - ENDIF 476 - CALL DRFTRA(Q,ITYPE,TSTEP,LDRMC,LEQTPL,LEQRTR, 477 - - LLINPL,LLINPR,LTIMPL,LVELPL,LDIFPL,LAVAPL,LFUNPL, 478 - - FUNCT,NCF,MARKER) 479 - ELSEIF(START.EQ.'ZERO')THEN 480 - IF(ISOREV.EQ.1)THEN 481 - LEQRZE=.TRUE. 482 - ELSEIF(ISOREV.EQ.-1)THEN 483 - LEQRZE=.FALSE. 484 - ENDIF 485 - CALL DRFZRO(Q,ITYPE,LLINPL,LLINPR,LEQTPL,LEQRZE) 1 647 P=DRIFT D=DRFDRF 6 PAGE 948 486 - ELSE 487 - PRINT *,' !!!!!! DRFDRF WARNING : Plot type has not been'// 488 - - ' specified; no drift plot.' 489 - ENDIF 490 - END 648 GARFIELD ================================================== P=DRIFT D=DRFEDG 1 ============================ 0 + +DECK,DRFEDG. 1 - SUBROUTINE DRFEDG(Q,ITYPE,TSTEP,LEQTPL,LEQREV, 2 - - LLINPL,LLINPR,SIDE,NLINEE) 3 - *----------------------------------------------------------------------- 4 - * DRFEDG - Subroutine calculating and plotting drift lines given an 5 - * electric field. It also plots some isochronous lines. 6 - * This routine lets the drift lines start at DXMIN and DXMAX 7 - * VARIABLES : 8 - * (Last changed on 16/ 3/00.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,PARAMETERS. 13.- +SEQ,CELLDATA. 14.- +SEQ,SOLIDS. 15.- +SEQ,GASDATA. 16.- +SEQ,CONSTANTS. 17.- +SEQ,PRINTPLOT. 18.- +SEQ,DRIFTLINE. 19 - DOUBLE PRECISION TRANSF 20 - INTEGER NLINEE,ITYPE,J,K,L,NC 21 - REAL Q,TSTEP,XSTART,YSTART,VXMIN,VYMIN,VXMAX,VYMAX 22 - CHARACTER*80 AUX 23 - LOGICAL LEQTPL,LLINPL,LLINPR,SIDE(4),LEQREV 24 - *** Define some formats. 25 - 1080 FORMAT('1 Table of edge drift lines :',/, 26 - - ' ===========================',//, 27 - - ' The equal time contours are separated by ',E10.3, 28 - - ' micro secs'/' The particles are ',A9,//, 29 - - ' x-start y-start steps drift time ', 30 - - ' remarks',/, 31 - - ' [cm] [cm] [microsec]'//) 32 - 1085 FORMAT('1 Table of edge drift lines :',/, 33 - - ' ===========================',//, 34 - - ' The equal time contours are separated by ',E10.3, 35 - - ' micro secs'/' The particles are ',A9,//, 36 - - ' r-start phi-start steps drift time ', 37 - - ' remarks',/, 38 - - ' [cm] [degrees] [microsec]'//) 39 - *** Print a heading, if requested. 40 - IF(LIDENT)PRINT *,' /// ROUTINE DRFEDG ///' 41 - *** Check that at least one side is left for edge drift lines. 42 - IF(.NOT.(SIDE(1).OR.SIDE(2).OR.SIDE(3).OR.SIDE(4)))THEN 43 - PRINT *,' !!!!!! DRFEDG WARNING : You ask for an'// 44 - - ' EDGE drift line plot but exclude all'// 45 - - ' edges ; no drift lines' 46 - RETURN 47 - ENDIF 48 - *** Print a heading for the table, depending on the coordinate system. 49 - IF(LLINPR)THEN 50 - IF(POLAR)THEN 51 - IF(ITYPE.EQ.1)WRITE(LUNOUT,1085) TSTEP,'electrons' 52 - IF(ITYPE.EQ.2)WRITE(LUNOUT,1085) TSTEP,'ions ' 53 - ELSE 54 - IF(ITYPE.EQ.1)WRITE(LUNOUT,1080) TSTEP,'electrons' 55 - IF(ITYPE.EQ.2)WRITE(LUNOUT,1080) TSTEP,'ions ' 56 - ENDIF 57 - ENDIF 58 - *** Prepare a plot (layout, frame number etc). 59 - IF(LEQTPL.OR.LLINPL)THEN 60 - IF(ITYPE.EQ.1.AND.Q.GT.0)THEN 61 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 62 - - 'Positron drift lines from edges') 63 - ELSEIF(ITYPE.EQ.1)THEN 64 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 65 - - 'Electron drift lines from edges') 66 - ELSEIF(Q.GT.0)THEN 67 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 68 - - 'Drift lines of positive ions from edges') 69 - ELSE 70 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 71 - - 'Drift lines of negative ions from edges') 72 - ENDIF 73 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 74 - IF(ITYPE.EQ.1)CALL GRCOMM(3,'Drifting: electrons') 75 - IF(ITYPE.EQ.2)CALL GRCOMM(3,'Drifting: ions') 76 - IF(LEQTPL)THEN 77 - CALL OUTFMT(TSTEP,2,AUX,NC,'LEFT') 78 - CALL GRCOMM(4,'Isochrone interval: '//AUX(1:NC)// 79 - - ' [microsec]') 80 - CALL DRFEQR 81 - ENDIF 82 - CALL GRALOG('Drift line and equal time plot ') 83 - ENDIF 84 - *** Start drift lines from the edges listed in the command. 85 - IF(ITYPE.EQ.2)THEN 86 - CALL GRATTS('ION-DRIFT-LINE','POLYLINE') 87 - ELSE 88 - CALL GRATTS('E-DRIFT-LINE','POLYLINE') 89 - ENDIF 90 - DO 20 K=0,NLINEE 91 - DO 30 L=0,NLINEE 92 - IF(K.NE.0.AND.K.NE.NLINEE.AND.L.NE.0.AND.L.NE.NLINEE)GOTO 30 93 - IF(L.NE.0.AND.L.NE.NLINEE.AND.((K.EQ.0.AND..NOT.SIDE(1)).OR. 94 - - (K.EQ.NLINEE.AND..NOT.SIDE(2))))GOTO 30 95 - IF(K.NE.0.AND.K.NE.NLINEE.AND.((L.EQ.0.AND..NOT.SIDE(3)).OR. 96 - - (L.EQ.NLINEE.AND..NOT.SIDE(4))))GOTO 30 97 - IF((K.EQ.0.AND.L.EQ.0.AND..NOT.(SIDE(1).OR.SIDE(3))).OR. 1 648 P=DRIFT D=DRFEDG 2 PAGE 949 98 - - (K.EQ.0.AND.L.EQ.NLINEE.AND..NOT.(SIDE(1).OR.SIDE(4))).OR. 99 - - (K.EQ.NLINEE.AND.L.EQ.0.AND..NOT.(SIDE(2).OR.SIDE(3))).OR. 100 - - (K.EQ.NLINEE.AND.L.EQ.NLINEE.AND. 101 - - .NOT.(SIDE(2).OR.SIDE(4))))GOTO 30 102 - IF(POLAR)THEN 103 - XSTART=LOG(EXP(DXMIN)+REAL(K)*(EXP(DXMAX)-EXP(DXMIN))/ 104 - - REAL(NLINEE)) 105 - ELSE 106 - XSTART=DXMIN+REAL(K)*(DXMAX-DXMIN)/REAL(NLINEE) 107 - ENDIF 108 - YSTART=DYMIN+REAL(L)*(DYMAX-DYMIN)/REAL(NLINEE) 109 - *** Calculate the drift line starting at (XSTART,YSTART) 110 - CALL DLCALC(XSTART,YSTART,0.0,Q,ITYPE) 111 - *** Print information on this drift line if requested. 112 - IF(LLINPR)THEN 113 - IF(POLAR)CALL CFMRTP(XSTART,YSTART,XSTART,YSTART,1) 114 - CALL DLCSTF(ISTAT,AUX,NC) 115 - WRITE(LUNOUT,'(1X,F10.2,F10.2,I10,2X,E15.8,2X,A)') 116 - - XSTART,YSTART,NU,TU(NU),AUX(1:NC) 117 - ENDIF 118 - *** Plot the drift line obtained, if this is requested. 119 - IF(LLINPL)CALL PLAGPL(NU,XU,YU,ZU) 120 - *** Invert TU in order to obtain the time distance from the sense wire. 121 - IF(LEQREV)THEN 122 - DO 80 J=1,NU 123 - TU(J)=TU(NU)-TU(J) 124 - 80 CONTINUE 125 - *** Reverse XU,YU and TU so that they can be treated as plot vectors. 126 - DO 90 J=1,INT(NU/2.0) 127 - TRANSF=TU(J) 128 - TU(J)=TU(NU-J+1) 129 - TU(NU-J+1)=TRANSF 130 - TRANSF=XU(J) 131 - XU(J)=XU(NU-J+1) 132 - XU(NU-J+1)=TRANSF 133 - TRANSF=YU(J) 134 - YU(J)=YU(NU-J+1) 135 - YU(NU-J+1)=TRANSF 136 - 90 CONTINUE 137 - *** Don't accept lines not leading to a wire. 138 - IF((ISTAT.GE.-15.AND.ISTAT.LE.-11).OR. 139 - - (ISTAT.GE.1.AND.ISTAT.LE.NWIRE).OR. 140 - - (ISTAT.GE.2*MXWIRE+1.AND.ISTAT.LE.2*MXWIRE+NSOLID)) 141 - - CALL DRFEQT(TSTEP,ISTAT) 142 - ELSE 143 - CALL DRFEQT(TSTEP,-20) 144 - ENDIF 145 - 30 CONTINUE 146 - 20 CONTINUE 147 - *** Register the amount of CPU time used for calculating drift lines. 148 - CALL TIMLOG('Making an edge drift-line plot: ') 149 - *** Plot the equal time contours. 150 - IF(LEQTPL)CALL DRFEQP 151 - *** End this page. 152 - IF(LEQTPL.OR.LLINPL)CALL GRNEXT 153 - *** And print any error messages that might have been generated. 154 - IF(LEQTPL)CALL DRFEQE 155 - END 649 GARFIELD ================================================== P=DRIFT D=DRFMIN 1 ============================ 0 + +DECK,DRFMIN. 1 - SUBROUTINE DRFMIN 2 - *----------------------------------------------------------------------- 3 - * DRFMIN - Minimises a function along a track segment. 4 - * (Last changed on 25/ 9/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,GASDATA. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,DRIFTLINE. 12.- +SEQ,BFIELD. 13 - CHARACTER*(MXCHAR) FUNMIN,FUNSEL,FUNTRA 14 - CHARACTER*(MXNAME) FILE 15 - CHARACTER*(MXINCH) STRING 16 - CHARACTER*10 VARLIS(MXVAR) 17 - CHARACTER*20 STATUS 18 - CHARACTER*29 REMARK 19 - CHARACTER*8 TIME,DATE,MEMBER 20 - DOUBLE PRECISION F0(3) 21 - REAL RES(2),VAR(MXVAR),XPOS,YPOS,ZPOS,EPST,EPSP,EPSTR,EPSPR, 22 - - TMIN,TMAX,TMINR,TMAXR,QMIN,EX,EY,EZ,BX,BY,BZ 23 - DOUBLE PRECISION TPARA,FTPARA,T1,FT1,T2,FT2,T3,FT3,XAUX1,YAUX1, 24 - - XAUX2,YAUX2,DRLENG 25 - INTEGER MODRES(2),MODVAR(MXVAR),INPCMP,INPTYP,I,NWORD,NCFMIN, 26 - - NCFSEL,NCFTRA,NCFILE,NCMEMB,NCREM,NSTEP,NSTEPR,NITMAX,NITR, 27 - - ITYPE,IFAIL,IFAIL1,IFAIL2,IENTRA,IENMIN,IENSEL,IU,ILOC, 28 - - NCSTAT,NREXP,NVAR,ISET1,ISET2,ISET3,I1,I2,I3,IAUX,IOS,NRES, 29 - - INEXT 30 - LOGICAL USE(MXVAR),LPRINT,LDIFF,LTOWN,LATTA,LLENG,LVELOC, 31 - - LFIELD,LMINWR,FLAG(MXWORD+3),EXMEMB,OK 32 - EXTERNAL INPCMP,INPTYP 33 - *** Initial values. 34 - FUNSEL='TRUE' 35 - NCFSEL=4 36 - FUNMIN='TIME' 37 - NCFMIN=4 38 - FUNTRA='?' 39 - NCFTRA=1 40 - LPRINT=.TRUE. 41 - EPST=1.0E-4 42 - EPSP=1.0E-4 43 - TMIN=0.0 44 - TMAX=0.0 1 649 P=DRIFT D=DRFMIN 2 PAGE 950 45 - NSTEP=20 46 - NITMAX=20 47 - QMIN=-1.0 48 - ITYPE=1 49 - OK=.TRUE. 50 - *** Dataset initial information. 51 - FILE=' ' 52 - NCFILE=1 53 - MEMBER='< none >' 54 - NCMEMB=8 55 - REMARK='none' 56 - NCREM=4 57 - LMINWR=.FALSE. 58 - *** Decode the command line. 59 - CALL INPNUM(NWORD) 60 - * The function to be minimised. 61 - IF(NWORD.GT.1)CALL INPSTR(2,2,FUNMIN,NCFMIN) 62 - * Flag keywords. 63 - DO 20 I=1,MXWORD+3 64 - IF(I.EQ.1.OR.I.GT.NWORD)THEN 65 - FLAG(I)=.TRUE. 66 - GOTO 20 67 - ENDIF 68 - FLAG(I)=.FALSE. 69 - IF(INPCMP(I,'SEL#ECTION-#FUNCTION')+INPCMP(I,'ON')+ 70 - - INPCMP(I,'PR#INT')+INPCMP(I,'NOPR#INT')+ 71 - - INPCMP(I,'F#UNCTION-PREC#ISION')+ 72 - - INPCMP(I,'POS#ITIONAL-RES#OLUTION')+ 73 - - INPCMP(I,'RANGE')+INPCMP(I,'N')+ 74 - - INPCMP(I,'ITER#ATE-#LIMIT')+ 75 - - INPCMP(I,'E#LECTRON')+INPCMP(I,'I#ON')+ 76 - - INPCMP(I,'POS#ITIVE')+INPCMP(I,'NEG#ATIVE')+ 77 - - INPCMP(I,'D#ATASET')+INPCMP(I,'REM#ARK').NE.0)FLAG(I)=.TRUE. 78 - 20 CONTINUE 79 - * Scan the input. 80 - INEXT=3 81 - DO 10 I=3,NWORD 82 - IF(I.LT.INEXT)GOTO 10 83 - * Drift line selection criteria. 84 - IF(INPCMP(I,'SEL#ECTION-#FUNCTION').NE.0)THEN 85 - IF(FLAG(I+1))THEN 86 - CALL INPMSG(I,'No selection function given. ') 87 - OK=.FALSE. 88 - ELSE 89 - CALL INPSTR(I+1,I+1,FUNSEL,NCFSEL) 90 - ENDIF 91 - INEXT=I+2 92 - * Printing of intermediate results. 93 - ELSEIF(INPCMP(I,'PR#INT').NE.0)THEN 94 - LPRINT=.TRUE. 95 - ELSEIF(INPCMP(I,'NOPR#INT').NE.0)THEN 96 - LPRINT=.FALSE. 97 - * Target accuracy. 98 - ELSEIF(INPCMP(I,'F#UNCTION-PREC#ISION').NE.0)THEN 99 - IF(FLAG(I+1))THEN 100 - CALL INPMSG(I,'No target precision given. ') 101 - OK=.FALSE. 102 - ELSEIF(INPTYP(I+1).LE.0)THEN 103 - CALL INPMSG(I+1,'Wrong data type. ') 104 - OK=.FALSE. 105 - ELSE 106 - CALL INPCHK(I+1,2,IFAIL1) 107 - CALL INPRDR(I+1,EPSTR,EPST) 108 - IF(IFAIL1.EQ.0.AND.EPSTR.LE.0.0.OR.EPSTR.GT.1.0)THEN 109 - CALL INPMSG(I+1,'Target precision out of range.') 110 - OK=.FALSE. 111 - ELSEIF(IFAIL1.EQ.0)THEN 112 - EPST=EPSTR 113 - ENDIF 114 - ENDIF 115 - INEXT=I+2 116 - * Positional accuracy. 117 - ELSEIF(INPCMP(I,'POS#ITIONAL-RES#OLUTION').NE.0)THEN 118 - IF(FLAG(I+1))THEN 119 - CALL INPMSG(I,'No resolution found. ') 120 - OK=.FALSE. 121 - ELSEIF(INPTYP(I+1).LE.0)THEN 122 - CALL INPMSG(I+1,'Wrong data type. ') 123 - OK=.FALSE. 124 - ELSE 125 - CALL INPCHK(I+1,2,IFAIL1) 126 - CALL INPRDR(I+1,EPSPR,EPSP) 127 - IF(IFAIL1.EQ.0.AND.EPSPR.LE.0.0.OR.EPSPR.GT.1.0)THEN 128 - CALL INPMSG(I+1,'Target precision out of range.') 129 - OK=.FALSE. 130 - ELSEIF(IFAIL1.EQ.0)THEN 131 - EPSP=EPSPR 132 - ENDIF 133 - ENDIF 134 - INEXT=I+2 135 - * Track selection. 136 - ELSEIF(INPCMP(I,'ON').NE.0)THEN 137 - IF(FLAG(I+1))THEN 138 - CALL INPMSG(I,'No track parameters given. ') 139 - OK=.FALSE. 140 - ELSE 141 - CALL INPSTR(I+1,I+1,FUNTRA,NCFTRA) 142 - ENDIF 143 - INEXT=I+2 144 - * Track range. 145 - ELSEIF(INPCMP(I,'RANGE').NE.0)THEN 146 - IF(FLAG(I+1).OR.FLAG(I+2))THEN 147 - CALL INPMSG(I,'No parameter range given. ') 148 - OK=.FALSE. 149 - ELSEIF(INPTYP(I+1).EQ.0)THEN 150 - CALL INPMSG(I+1,'Wrong data type. ') 1 649 P=DRIFT D=DRFMIN 3 PAGE 951 151 - OK=.FALSE. 152 - ELSEIF(INPTYP(I+2).EQ.0)THEN 153 - CALL INPMSG(I+2,'Wrong data type. ') 154 - OK=.FALSE. 155 - ELSE 156 - CALL INPCHK(I+1,2,IFAIL1) 157 - CALL INPCHK(I+2,2,IFAIL2) 158 - CALL INPRDR(I+1,TMINR,0.0) 159 - CALL INPRDR(I+2,TMAXR,0.0) 160 - IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN 161 - TMIN=TMINR 162 - TMAX=TMAXR 163 - ENDIF 164 - ENDIF 165 - INEXT=I+3 166 - * Number of steps. 167 - ELSEIF(INPCMP(I,'N').NE.0)THEN 168 - IF(FLAG(I+1))THEN 169 - CALL INPMSG(I,'No number of steps found. ') 170 - OK=.FALSE. 171 - ELSEIF(INPTYP(I+1).NE.1)THEN 172 - CALL INPMSG(I+1,'Wrong data type. ') 173 - OK=.FALSE. 174 - ELSE 175 - CALL INPCHK(I+1,1,IFAIL1) 176 - CALL INPRDI(I+1,NSTEPR,20) 177 - IF(IFAIL1.EQ.0.AND.NSTEPR.LE.0.OR.NSTEPR.GT.MXLIST)THEN 178 - CALL INPMSG(I+1,'Number of steps out of range. ') 179 - OK=.FALSE. 180 - ELSEIF(IFAIL1.EQ.0)THEN 181 - NSTEP=NSTEPR 182 - ENDIF 183 - ENDIF 184 - INEXT=I+2 185 - * Number of iterations. 186 - ELSEIF(INPCMP(I,'ITER#ATE-#LIMIT').NE.0)THEN 187 - IF(FLAG(I+1))THEN 188 - CALL INPMSG(I,'No iteration limit found. ') 189 - OK=.FALSE. 190 - ELSEIF(INPTYP(I+1).NE.1)THEN 191 - CALL INPMSG(I+1,'Wrong data type. ') 192 - OK=.FALSE. 193 - ELSE 194 - CALL INPCHK(I+1,1,IFAIL1) 195 - CALL INPRDI(I+1,NITR,20) 196 - IF(IFAIL1.EQ.0.AND.NITR.LE.0)THEN 197 - CALL INPMSG(I+1,'Iteration limit out of range. ') 198 - OK=.FALSE. 199 - ELSEIF(IFAIL1.EQ.0)THEN 200 - NITMAX=NITR 201 - ENDIF 202 - ENDIF 203 - INEXT=I+2 204 - * Particle type. 205 - ELSEIF(INPCMP(I,'E#LECTRON').NE.0)THEN 206 - ITYPE=1 207 - ELSEIF(INPCMP(I,'I#ON').NE.0)THEN 208 - IF(GASOK(2))THEN 209 - ITYPE=2 210 - ELSE 211 - CALL INPMSG(I,'Ion mobility data missing. ') 212 - OK=.FALSE. 213 - ENDIF 214 - * Particle charge. 215 - ELSEIF(INPCMP(I,'POS#ITIVE').NE.0)THEN 216 - QMIN=+1.0 217 - ELSEIF(INPCMP(I,'NEG#ATIVE').NE.0)THEN 218 - QMIN=-1.0 219 - * Look for a DATASET (and perhaps a member) receiving the data. 220 - ELSEIF(INPCMP(I,'D#ATASET').NE.0)THEN 221 - IF(FLAG(I+1))THEN 222 - CALL INPMSG(I,'the dataset name is missing. ') 223 - OK=.FALSE. 224 - ELSE 225 - CALL INPSTR(I+1,I+1,STRING,NCFILE) 226 - FILE=STRING 227 - IF(.NOT.FLAG(I+2))THEN 228 - CALL INPSTR(I+2,I+2,STRING,NCMEMB) 229 - MEMBER=STRING 230 - INEXT=I+3 231 - ELSE 232 - INEXT=I+2 233 - ENDIF 234 - LMINWR=.TRUE. 235 - ENDIF 236 - * Look for a REMARK replacing the default remark in the header, 237 - ELSEIF(INPCMP(I,'REM#ARK').NE.0)THEN 238 - IF(FLAG(I+1))THEN 239 - CALL INPMSG(I,'No remark has been found. ') 240 - OK=.FALSE. 241 - ELSE 242 - CALL INPSTR(I+1,I+1,STRING,NCREM) 243 - REMARK=STRING(1:NCREM) 244 - INEXT=I+2 245 - ENDIF 246 - * Anything else is not valid. 247 - ELSE 248 - CALL INPMSG(I,'Not a valid keyword. ') 249 - OK=.FALSE. 250 - ENDIF 251 - 10 CONTINUE 252 - *** Dump error messages. 253 - CALL INPERR 254 - *** Debug output. 255 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFMIN DEBUG : '', 256 - - ''Function to be minimised: '',A/ 1 649 P=DRIFT D=DRFMIN 4 PAGE 952 257 - - 26X,''Selection function: '',A/ 258 - - 26X,''Curve function: '',A/ 259 - - 26X,''Curve parameter range: '',2E15.8/ 260 - - 26X,''Number of curve points: '',I10/ 261 - - 26X,''Attempted function accuracy: '',E15.8/ 262 - - 26X,''Positional resolution: '',E15.8/ 263 - - 26X,''Iteration limit: '',I10/ 264 - - 26X,''Particle type and charge: '',I10,3X,F4.1)') 265 - - FUNMIN(1:NCFMIN),FUNSEL(1:NCFSEL),FUNTRA(1:NCFTRA), 266 - - TMIN,TMAX,NSTEP,EPST,EPSP,NITMAX,ITYPE,QMIN 267 - IF(LMINWR.AND.LDEBUG)THEN 268 - WRITE(LUNOUT,'('' ++++++ DRFMIN DEBUG : '', 269 - - ''Output data set: '',A/ 270 - - 26X,''Data set member: '',A/ 271 - - 26X,''Remark string: '',A)') 272 - - FILE(1:NCFILE),MEMBER(1:NCMEMB),REMARK(1:NCREM) 273 - ELSEIF(LDEBUG)THEN 274 - WRITE(LUNOUT,'('' ++++++ DRFMIN DEBUG : '', 275 - - ''No dataset output has been requested.'')') 276 - ENDIF 277 - * Check whether the member already exists. 278 - IF(LMINWR)THEN 279 - CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'MINIMUM', 280 - - EXMEMB) 281 - IF(JEXMEM.EQ.2.AND.EXMEMB)THEN 282 - PRINT *,' ------ DRFMIN MESSAGE : A copy of the'// 283 - - ' member exists; new member will be appended.' 284 - ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN 285 - PRINT *,' !!!!!! DRFMIN WARNING : A copy of the'// 286 - - ' member exists already; member will not be'// 287 - - ' written.' 288 - LMINWR=.FALSE. 289 - OK=.FALSE. 290 - ENDIF 291 - ENDIF 292 - *** Quit now if OK is no longer true and if JFAIL is set. 293 - IF(JFAIL.EQ.2.AND..NOT.OK)THEN 294 - PRINT *,' ###### DRFMIN ERROR : Instruction is not'// 295 - - ' carried out because of the above errors.' 296 - RETURN 297 - ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN 298 - PRINT *,' ###### DRFMIN ERROR : Program terminated'// 299 - - ' because of the above errors.' 300 - CALL QUIT 301 - ENDIF 302 - *** Check that the important things have been specified. 303 - IF(FUNTRA.EQ.'?')THEN 304 - PRINT *,' !!!!!! DRFMIN WARNING : The curve over which'// 305 - - ' the minimisation is to be done, is missing.' 306 - RETURN 307 - ENDIF 308 - *** Translate the various functions, first the track function. 309 - VARLIS(1)='T' 310 - NVAR=1 311 - CALL ALGPRE(FUNTRA,NCFTRA,VARLIS,NVAR,NRES,USE,IENTRA,IFAIL) 312 - IF(IFAIL.NE.0)THEN 313 - PRINT *,' !!!!!! DRFMIN WARNING : Translation of the'// 314 - - ' curve-function failed; nothing done.' 315 - CALL ALGCLR(IENTRA) 316 - RETURN 317 - ELSEIF(.NOT.USE(1))THEN 318 - PRINT *,' !!!!!! DRFMIN WARNING : The curve-function'// 319 - - ' does not depend on T; nothing done.' 320 - CALL ALGCLR(IENTRA) 321 - RETURN 322 - ELSEIF(NRES.NE.2)THEN 323 - PRINT *,' !!!!!! DRFMIN WARNING : The curve-function'// 324 - - ' does not return 2 results; nothing done.' 325 - CALL ALGCLR(IENTRA) 326 - RETURN 327 - ENDIF 328 - *** Next the selection function. 329 - VARLIS(1)='TIME' 330 - VARLIS(2)='LENGTH' 331 - VARLIS(3)='DIFFUSION' 332 - VARLIS(4)='AVALANCHE' 333 - VARLIS(5)='LOSS' 334 - VARLIS(6)='E' 335 - VARLIS(7)='V' 336 - VARLIS(8)='B' 337 - VARLIS(9)='VELOCITY' 338 - VARLIS(10)='STATUS' 339 - NVAR=10 340 - CALL ALGPRE(FUNSEL,NCFSEL,VARLIS,NVAR,NRES,USE,IENSEL,IFAIL) 341 - IF(IFAIL.NE.0)THEN 342 - PRINT *,' !!!!!! DRFMIN WARNING : Translation of the'// 343 - - ' selection-function failed; nothing done.' 344 - CALL ALGCLR(IENTRA) 345 - CALL ALGCLR(IENSEL) 346 - RETURN 347 - ELSEIF(USE(3).AND..NOT.GASOK(3))THEN 348 - PRINT *,' !!!!!! DRFMIN WARNING : The selection function'// 349 - - ' uses diffusion data which is absent; nothing done.' 350 - CALL ALGCLR(IENTRA) 351 - CALL ALGCLR(IENSEL) 352 - RETURN 353 - ELSEIF(USE(4).AND..NOT.GASOK(4))THEN 354 - PRINT *,' !!!!!! DRFMIN WARNING : The selection function'// 355 - - ' uses Townsend data which is absent; nothing done.' 356 - CALL ALGCLR(IENTRA) 357 - CALL ALGCLR(IENSEL) 358 - RETURN 359 - ELSEIF(USE(5).AND..NOT.GASOK(6))THEN 360 - PRINT *,' !!!!!! DRFMIN WARNING : The selection function'// 361 - - ' uses attachment data which is absent; nothing done.' 362 - CALL ALGCLR(IENTRA) 1 649 P=DRIFT D=DRFMIN 5 PAGE 953 363 - CALL ALGCLR(IENSEL) 364 - RETURN 365 - ELSEIF(USE(8).AND..NOT.MAGOK)THEN 366 - PRINT *,' !!!!!! DRFMIN WARNING : The selection function'// 367 - - ' uses the B field which is absent; nothing done.' 368 - CALL ALGCLR(IENTRA) 369 - CALL ALGCLR(IENSEL) 370 - RETURN 371 - ELSEIF(NRES.NE.1)THEN 372 - PRINT *,' !!!!!! DRFMIN WARNING : The selection function'// 373 - - ' does not return 1 result; nothing done.' 374 - CALL ALGCLR(IENTRA) 375 - CALL ALGCLR(IENSEL) 376 - RETURN 377 - ENDIF 378 - * Set flags for items to be computed. 379 - LLENG=USE(2) 380 - LDIFF=USE(3) 381 - LTOWN=USE(4) 382 - LATTA=USE(5) 383 - LFIELD=USE(6).OR.USE(7).OR.USE(8) 384 - LVELOC=USE(9) 385 - *** Next the function to be minimised. 386 - VARLIS(1)='TIME' 387 - VARLIS(2)='LENGTH' 388 - VARLIS(3)='DIFFUSION' 389 - VARLIS(4)='AVALANCHE' 390 - VARLIS(5)='LOSS' 391 - VARLIS(6)='E' 392 - VARLIS(7)='V' 393 - VARLIS(8)='B' 394 - VARLIS(9)='VELOCITY' 395 - NVAR=9 396 - CALL ALGPRE(FUNMIN,NCFMIN,VARLIS,NVAR,NRES,USE,IENMIN,IFAIL) 397 - IF(IFAIL.NE.0)THEN 398 - PRINT *,' !!!!!! DRFMIN WARNING : Translation of the'// 399 - - ' function to be minimised failed; nothing done.' 400 - GOTO 3000 401 - ELSEIF(USE(3).AND..NOT.GASOK(3))THEN 402 - PRINT *,' !!!!!! DRFMIN WARNING : The function to be'// 403 - - ' minimised uses absent diffusion data; nothing done.' 404 - GOTO 3000 405 - ELSEIF(USE(4).AND..NOT.GASOK(4))THEN 406 - PRINT *,' !!!!!! DRFMIN WARNING : The function to be'// 407 - - ' minimised uses absent Townsend data; nothing done.' 408 - GOTO 3000 409 - ELSEIF(USE(5).AND..NOT.GASOK(6))THEN 410 - PRINT *,' !!!!!! DRFMIN WARNING : The function to be'// 411 - - ' minimised uses absent attachment data; nothing done.' 412 - GOTO 3000 413 - ELSEIF(USE(8).AND..NOT.MAGOK)THEN 414 - PRINT *,' !!!!!! DRFMIN WARNING : The function to be'// 415 - - ' minimised uses absent B field data; nothing done.' 416 - GOTO 3000 417 - ELSEIF(NRES.NE.1)THEN 418 - PRINT *,' !!!!!! DRFMIN WARNING : The function to be'// 419 - - ' minimised does not return 1 result; nothing done.' 420 - GOTO 3000 421 - ENDIF 422 - * Update the flags. 423 - IF(USE(2))LLENG=.TRUE. 424 - IF(USE(3))LDIFF=.TRUE. 425 - IF(USE(4))LTOWN=.TRUE. 426 - IF(USE(5))LATTA=.TRUE. 427 - IF(USE(6).OR.USE(7).OR.USE(8))LFIELD=.TRUE. 428 - IF(USE(9))LVELOC=.TRUE. 429 - * Debugging information. 430 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFMIN DEBUG : '', 431 - - ''Evaluation flags: Diffusion='',L1,'' Townsend='',L1, 432 - - '' Length='',L1/26X,''Loss='',L1,'' Field='',L1, 433 - - '' Velocity='',L1,''.'')') 434 - - LDIFF,LTOWN,LLENG,LATTA,LFIELD,LVELOC 435 - *** Prepare dataset output. 436 - IF(LMINWR)THEN 437 - * Open the file. 438 - CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) 439 - IF(IFAIL.NE.0)THEN 440 - PRINT *,' !!!!!! DRFMIN WARNING : Opening '// 441 - - FILE(1:NCFILE)//'; minimisation data not written.' 442 - RETURN 443 - ENDIF 444 - * Record that the file has been opened. 445 - CALL DSNLOG(FILE,'Minimum ','Sequential','Write ') 446 - IF(LDEBUG)PRINT *,' ++++++ DRFMIN DEBUG : Dataset '// 447 - - FILE(1:NCFILE)//' opened on unit 12 for seq write.' 448 - * Write a heading record to the file. 449 - CALL DATTIM(DATE,TIME) 450 - WRITE(12,'(''% Created '',A8,'' At '',A8,1X,A8, 451 - - '' MINIMUM '',1X,''"'',A29,''"'')',IOSTAT=IOS,ERR=2010) 452 - - DATE,TIME,MEMBER,REMARK 453 - WRITE(12,'('' GENERAL INFORMATION:''// 454 - - '' Function to be minimised: '',A/ 455 - - '' Selection function: '',A/ 456 - - '' Curve function: '',A/ 457 - - '' Curve parameter range: '',2E15.8/ 458 - - '' Number of curve points: '',I10/ 459 - - '' Attempted function accuracy: '',E15.8/ 460 - - '' Positional resolution: '',E15.8/ 461 - - '' Iteration limit: '',I10/ 462 - - '' Particle type and charge: '',I10,3X,F4.1/)') 463 - - FUNMIN(1:NCFMIN),FUNSEL(1:NCFSEL),FUNTRA(1:NCFTRA), 464 - - TMIN,TMAX,NSTEP,EPST,EPSP,NITMAX,ITYPE,QMIN 465 - ENDIF 466 - *** Preset some parameters needed for minimisation. 467 - ISET1=0 468 - ISET2=0 1 649 P=DRIFT D=DRFMIN 6 PAGE 954 469 - ISET3=0 470 - I1=0 471 - I2=0 472 - I3=0 473 - T1=0 474 - T2=0 475 - T3=0 476 - FT1=0 477 - FT2=0 478 - FT3=0 479 - *** Start the minimisation procedure itself. 480 - DO 100 I=0,NSTEP 481 - * First calculate a position. 482 - VAR(1)=TMIN+REAL(I)*(TMAX-TMIN)/REAL(NSTEP) 483 - MODVAR(1)=2 484 - NVAR=1 485 - NREXP=2 486 - CALL ALGEXE(IENTRA,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL) 487 - * Then the drift-line from there. 488 - XPOS=RES(1) 489 - YPOS=RES(2) 490 - ZPOS=0 491 - IF(POLAR)THEN 492 - CALL CFMPTR(XPOS,YPOS,XPOS,YPOS,1,IFAIL1) 493 - IF(IFAIL1.NE.0)THEN 494 - PRINT *,' !!!!!! DRFMIN WARNING : Illegal polar'// 495 - - ' curve coordinate seen at T=',VAR(1), 496 - - '; no further minimisation.' 497 - IF(LMINWR)WRITE(12,'(/'' # Minimisation abandoned:'', 498 - - '' illegal polar coordinate seen.''/)') 499 - GOTO 3000 500 - ENDIF 501 - ENDIF 502 - CALL DLCALC(XPOS,YPOS,ZPOS,QMIN,ITYPE) 503 - * And the derived information. 504 - VAR(1)=TU(NU) 505 - VAR(2)=0.0 506 - VAR(3)=0.0 507 - VAR(4)=0.0 508 - VAR(5)=0.0 509 - VAR(6)=0.0 510 - VAR(7)=0.0 511 - VAR(8)=0.0 512 - VAR(9)=0.0 513 - VAR(10)=0 514 - IF(LLENG)THEN 515 - DRLENG=0.0 516 - DO 110 IU=2,NU 517 - IF(POLAR)THEN 518 - CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX1,YAUX1,1) 519 - CALL CF2RTC(XU(IU),YU(IU),XAUX2,YAUX2,1) 520 - DRLENG=DRLENG+ 521 - - SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 522 - - (ZU(IU)-ZU(IU-1))**2) 523 - ELSE 524 - DRLENG=DRLENG+ 525 - - SQRT((XU(IU)-XU(IU-1))**2+(YU(IU)-YU(IU-1))**2+ 526 - - (ZU(IU)-ZU(IU-1))**2) 527 - ENDIF 528 - 110 CONTINUE 529 - VAR(2)=DRLENG 530 - ENDIF 531 - IF(LDIFF)CALL DLCDIF(VAR(3)) 532 - IF(LTOWN)CALL DLCTWN(VAR(4)) 533 - IF(LATTA)CALL DLCATT(VAR(5)) 534 - IF(LFIELD)THEN 535 - CALL EFIELD(XPOS,YPOS,ZPOS,EX,EY,EZ,VAR(6),VAR(7),1,ILOC) 536 - IF(MAGOK)CALL BFIELD(XPOS,YPOS,ZPOS,BX,BY,BZ,VAR(8)) 537 - ENDIF 538 - IF(LVELOC)THEN 539 - CALL DLCVEL(DBLE(XPOS),DBLE(YPOS),DBLE(ZPOS), 540 - - F0,-1.0,1,ILOC) 541 - VAR(9)=REAL(SQRT(F0(1)**2+F0(2)**2+F0(3)**2)) 542 - ENDIF 543 - IF(ISTAT.EQ.-1)THEN 544 - STATUS='Left_Area' 545 - NCSTAT=9 546 - ELSEIF(ISTAT.EQ.-2)THEN 547 - STATUS='Too_Many_Steps' 548 - NCSTAT=14 549 - ELSEIF(ISTAT.EQ.-3)THEN 550 - STATUS='Abandoned' 551 - NCSTAT=9 552 - ELSEIF(ISTAT.EQ.-4)THEN 553 - STATUS='Hit_Plane' 554 - NCSTAT=9 555 - ELSEIF(ISTAT.EQ.-5)THEN 556 - STATUS='Left_Drift_Medium' 557 - NCSTAT=17 558 - ELSEIF(ISTAT.EQ.-6)THEN 559 - STATUS='Left_Mesh' 560 - NCSTAT=9 561 - ELSEIF(ISTAT.GT.0.AND.ISTAT.LE.MXWIRE)THEN 562 - STATUS='Hit_'//WIRTYP(ISTAT)//'_Wire' 563 - NCSTAT=10 564 - ELSEIF(ISTAT.GT.MXWIRE.AND.ISTAT.LE.2*MXWIRE)THEN 565 - STATUS='Hit_'//WIRTYP(ISTAT-MXWIRE)//'_Replica' 566 - NCSTAT=13 567 - ELSE 568 - STATUS='Unknown' 569 - NCSTAT=7 570 - ENDIF 571 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFMIN DEBUG : From ('', 572 - - 3E15.8,'') Status = '',A,'' ('',I4,'') Time ='',E15.8, 573 - - ''.'')') XPOS,YPOS,ZPOS,STATUS(1:NCSTAT),ISTAT,TU(NU) 574 - CALL STRBUF('STORE',IAUX,STATUS(1:NCSTAT),NCSTAT,IFAIL1) 1 649 P=DRIFT D=DRFMIN 7 PAGE 955 575 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DRFMIN WARNING : Unable to'// 576 - - ' store the status code string; trouble in case you use it.' 577 - VAR(10)=IAUX 578 - MODVAR(1)=2 579 - MODVAR(2)=2 580 - MODVAR(3)=2 581 - MODVAR(4)=2 582 - MODVAR(5)=2 583 - MODVAR(6)=2 584 - MODVAR(7)=2 585 - MODVAR(8)=2 586 - MODVAR(9)=2 587 - MODVAR(10)=1 588 - * Evaluate the selection function, skip the rest if FALSE. 589 - NREXP=1 590 - NVAR=10 591 - CALL ALGEXE(IENSEL,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL) 592 - IF(ABS(RES(1)).LT.1.0E-3)THEN 593 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Drift line rejected by'', 594 - - '' the selection function.'')') 595 - GOTO 100 596 - ENDIF 597 - * Evaluate the function to be minimised. 598 - NREXP=1 599 - NVAR=9 600 - CALL ALGEXE(IENMIN,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL) 601 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Function value: '',E15.8)') RES(1) 602 - * Get rid of the status string. 603 - CALL STRBUF('DELETE',IAUX,STATUS,NCSTAT,IFAIL1) 604 - * Keep track of the 3 smallest numbers. 605 - IF(RES(1).LT.FT1.OR.ISET1.EQ.0)THEN 606 - FT3=FT2 607 - T3=T2 608 - I3=I2 609 - IF(ISET2.EQ.1)ISET3=1 610 - FT2=FT1 611 - T2=T1 612 - I2=I1 613 - IF(ISET1.EQ.1)ISET2=1 614 - FT1=RES(1) 615 - T1=TMIN+REAL(I)*(TMAX-TMIN)/REAL(NSTEP) 616 - I1=I 617 - ISET1=1 618 - ELSEIF(RES(1).LT.FT2.OR.ISET2.EQ.0)THEN 619 - FT3=FT2 620 - T3=T2 621 - I3=I2 622 - IF(ISET2.EQ.1)ISET3=1 623 - FT2=RES(1) 624 - T2=TMIN+REAL(I)*(TMAX-TMIN)/REAL(NSTEP) 625 - I2=I 626 - ISET2=1 627 - ELSEIF(RES(1).LT.FT3.OR.ISET3.EQ.0)THEN 628 - FT3=RES(1) 629 - T3=TMIN+REAL(I)*(TMAX-TMIN)/REAL(NSTEP) 630 - I3=I 631 - ISET3=1 632 - ENDIF 633 - 100 CONTINUE 634 - *** Now make sure that we have 3 contiguous points. 635 - IF(ISET3.EQ.0)THEN 636 - PRINT *,' !!!!!! DRFMIN WARNING : Failed to find a set of'// 637 - - ' 3 initial points; no minimisation.' 638 - IF(LMINWR)WRITE(12,'(/'' # Minimisation not performed:'', 639 - - '' number of starting points < 3.''/)') 640 - GOTO 3000 641 - ELSEIF(MAX(I1,I2,I3).NE.MIN(I1,I2,I3)+2)THEN 642 - PRINT *,' !!!!!! DRFMIN WARNING : The initial set of 3'// 643 - - ' minimal points is not consecutive; no minimisation.' 644 - IF(LMINWR)WRITE(12,'(/'' # Minimisation not performed:'', 645 - - '' starting points are not consecutive.''/)') 646 - GOTO 3000 647 - ENDIF 648 - *** And make a few parabolic steps. 649 - DO 120 I=1,NITMAX 650 - * Estimate parabolic minimum. 651 - TPARA=( (FT1-FT2)*T3**2+(FT3-FT1)*T2**2+(FT2-FT3)*T1**2)/ 652 - - (2*((FT1-FT2)*T3 +(FT3-FT1)*T2 +(FT2-FT3)*T1)) 653 - FTPARA=-(4*((FT1*T2**2-FT2*T1**2)*T3-(FT1*T2-FT2*T1)*T3**2- 654 - - T2**2*FT3*T1+T2*FT3*T1**2)*((FT1-FT2)*T3-FT1*T2+ 655 - - T2*FT3+FT2*T1-FT3*T1)+((FT1-FT2)*T3**2-FT1*T2**2+T2**2*FT3+ 656 - - FT2*T1**2-FT3*T1**2)**2)/(4*((FT1-FT2)*T3-FT1*T2+ 657 - - T2*FT3+FT2*T1-FT3*T1)*(T3-T2)*(T3-T1)*(T2-T1)) 658 - * Debugging output. 659 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFMIN DEBUG : Iteration '', 660 - - I3//26X,''Point 1: T='',E15.8,'' F='',E15.8/ 661 - - 26X,''Point 2: T='',E15.8,'' F='',E15.8/ 662 - - 26X,''Point 3: T='',E15.8,'' F='',E15.8// 663 - - 26X,''Parabola: T='',E15.8,'' F='',E15.8)') 664 - - I,T1,FT1,T2,FT2,T3,FT3,TPARA,FTPARA 665 - * Check that the parabolic estimate is within range. 666 - IF((TMIN-TPARA)*(TPARA-TMAX).LT.0)THEN 667 - PRINT *,' !!!!!! DRFMIN WARNING : Estimated parabolic'// 668 - - ' minimum is located outside curve range.' 669 - IF(LMINWR)WRITE(12,'(/'' ! Minimisation abandoned:'', 670 - - '' parabolic minimum outside of T-range.''/)') 671 - GOTO 3000 672 - ENDIF 673 - * Check that the new estimate doesn't coincide with an old point. 674 - IF(ABS(TPARA-T1).LT.EPSP*(EPSP+ABS(TPARA)).OR. 675 - - ABS(TPARA-T2).LT.EPSP*(EPSP+ABS(TPARA)).OR. 676 - - ABS(TPARA-T3).LT.EPSP*(EPSP+ABS(TPARA)))THEN 677 - IF(LPRINT)WRITE(LUNOUT,'(/'' Parabolic minimum'', 678 - - '' coincides with a previous point.''/)') 679 - IF(LMINWR)WRITE(12,'(/'' Minimisation halted: parabolic'', 680 - - '' minimum coincides with a previous point.''/)') 1 649 P=DRIFT D=DRFMIN 8 PAGE 956 681 - GOTO 3000 682 - ENDIF 683 - * Evaluate things over there. 684 - VAR(1)=TPARA 685 - MODVAR(1)=2 686 - NVAR=1 687 - NREXP=2 688 - CALL ALGEXE(IENTRA,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL) 689 - * Then the drift-line from there. 690 - XPOS=RES(1) 691 - YPOS=RES(2) 692 - ZPOS=0 693 - IF(POLAR)THEN 694 - CALL CFMPTR(XPOS,YPOS,XPOS,YPOS,1,IFAIL1) 695 - IF(IFAIL1.NE.0)THEN 696 - PRINT *,' !!!!!! DRFMIN WARNING : Illegal polar'// 697 - - ' curve coordinate seen at T=',VAR(1), 698 - - '; no further minimisation.' 699 - IF(LMINWR)WRITE(12,'(/'' # Minimisation abandoned:'', 700 - - '' illegal polar coordinate seen.''/)') 701 - GOTO 3000 702 - ENDIF 703 - ENDIF 704 - CALL DLCALC(XPOS,YPOS,ZPOS,QMIN,ITYPE) 705 - XPOS=RES(1) 706 - YPOS=RES(2) 707 - * And the derived information. 708 - VAR(1)=TU(NU) 709 - VAR(2)=0.0 710 - VAR(3)=0.0 711 - VAR(4)=0.0 712 - VAR(5)=0.0 713 - VAR(6)=0.0 714 - VAR(7)=0.0 715 - VAR(8)=0.0 716 - VAR(9)=0.0 717 - VAR(10)=0 718 - IF(LLENG)THEN 719 - DRLENG=0.0 720 - DO 130 IU=2,NU 721 - IF(POLAR)THEN 722 - CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX1,YAUX1,1) 723 - CALL CF2RTC(XU(IU),YU(IU),XAUX2,YAUX2,1) 724 - DRLENG=DRLENG+ 725 - - SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 726 - - (ZU(IU)-ZU(IU-1))**2) 727 - ELSE 728 - DRLENG=DRLENG+ 729 - - SQRT((XU(IU)-XU(IU-1))**2+(YU(IU)-YU(IU-1))**2+ 730 - - (ZU(IU)-ZU(IU-1))**2) 731 - ENDIF 732 - 130 CONTINUE 733 - VAR(2)=DRLENG 734 - ENDIF 735 - IF(LDIFF)CALL DLCDIF(VAR(3)) 736 - IF(LTOWN)CALL DLCTWN(VAR(4)) 737 - IF(LATTA)CALL DLCATT(VAR(5)) 738 - IF(LFIELD)THEN 739 - CALL EFIELD(XPOS,YPOS,ZPOS,EX,EY,EZ,VAR(6),VAR(7),1,ILOC) 740 - IF(MAGOK)CALL BFIELD(XPOS,YPOS,ZPOS,BX,BY,BZ,VAR(8)) 741 - ENDIF 742 - IF(LVELOC)THEN 743 - CALL DLCVEL(DBLE(XPOS),DBLE(YPOS),DBLE(ZPOS), 744 - - F0,-1.0,1,ILOC) 745 - VAR(9)=REAL(SQRT(F0(1)**2+F0(2)**2+F0(3)**2)) 746 - ENDIF 747 - IF(ISTAT.EQ.-1)THEN 748 - STATUS='Left_Area' 749 - NCSTAT=9 750 - ELSEIF(ISTAT.EQ.-2)THEN 751 - STATUS='Too_Many_Steps' 752 - NCSTAT=14 753 - ELSEIF(ISTAT.EQ.-3)THEN 754 - STATUS='Abandoned' 755 - NCSTAT=9 756 - ELSEIF(ISTAT.EQ.-4)THEN 757 - STATUS='Hit_Plane' 758 - NCSTAT=9 759 - ELSEIF(ISTAT.EQ.-5)THEN 760 - STATUS='Left_Drift_Medium' 761 - NCSTAT=17 762 - ELSEIF(ISTAT.EQ.-6)THEN 763 - STATUS='Left_Mesh' 764 - NCSTAT=9 765 - ELSEIF(ISTAT.GT.0.AND.ISTAT.LE.MXWIRE)THEN 766 - STATUS='Hit_'//WIRTYP(ISTAT)//'_Wire' 767 - NCSTAT=10 768 - ELSEIF(ISTAT.GT.MXWIRE.AND.ISTAT.LE.2*MXWIRE)THEN 769 - STATUS='Hit_'//WIRTYP(ISTAT-MXWIRE)//'_Replica' 770 - NCSTAT=13 771 - ELSE 772 - STATUS='Unknown' 773 - NCSTAT=7 774 - ENDIF 775 - CALL STRBUF('STORE',IAUX,STATUS(1:NCSTAT),NCSTAT,IFAIL1) 776 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DRFMIN WARNING : Unable to'// 777 - - ' store the status code string; trouble in case you use it.' 778 - VAR(10)=IAUX 779 - MODVAR(1)=2 780 - MODVAR(2)=2 781 - MODVAR(3)=2 782 - MODVAR(4)=2 783 - MODVAR(5)=2 784 - MODVAR(6)=2 785 - MODVAR(7)=2 786 - MODVAR(8)=2 1 649 P=DRIFT D=DRFMIN 9 PAGE 957 787 - MODVAR(9)=2 788 - MODVAR(10)=1 789 - * Debugging output. 790 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFMIN DEBUG : From ('', 791 - - 3E15.8,'') Status = '',A,'' ('',I4,'') Time ='',E15.8, 792 - - ''.'')') XPOS,YPOS,ZPOS,STATUS(1:NCSTAT),ISTAT,TU(NU) 793 - * Evaluate the selection function, skip the rest if FALSE. 794 - NREXP=1 795 - NVAR=10 796 - CALL ALGEXE(IENSEL,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL) 797 - IF(ABS(RES(1)).LT.1.0E-3)THEN 798 - PRINT *,' !!!!!! DRFMIN WARNING : Estimated parabolic'// 799 - - ' minimum does not satisfy selection criterion.' 800 - WRITE(12,'(/'' ! Minimisation halted: parabolic'', 801 - - '' minimum does not satisfy selection criterion.''/)') 802 - CALL STRBUF('DELETE',IAUX,STATUS,NCSTAT,IFAIL1) 803 - GOTO 3000 804 - ENDIF 805 - * Evaluate the function to be minimised. 806 - NREXP=1 807 - NVAR=9 808 - CALL ALGEXE(IENMIN,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL) 809 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Function value: '',E15.8)') RES(1) 810 - FTPARA=RES(1) 811 - * Get rid of the status string. 812 - CALL STRBUF('DELETE',IAUX,STATUS,NCSTAT,IFAIL1) 813 - * Dataset output. 814 - IF(LMINWR)WRITE(12,'('' Iteration '',I3,'' T='',E15.8, 815 - - '': ('',E15.8,'','',E15.8,'','',E15.8,'') Function = '', 816 - - E15.8,''.'')') I,TPARA,XPOS,YPOS,ZPOS,FTPARA 817 - * Normal printout. 818 - IF(LPRINT)WRITE(LUNOUT,'('' Iteration '',I3,'' T='',E15.8, 819 - - '': ('',E15.8,'','',E15.8,'','',E15.8,'') Function = '', 820 - - E15.8,''.'')') I,TPARA,XPOS,YPOS,ZPOS,FTPARA 821 - * Check convergence. 822 - IF(ABS(FTPARA-FT1).LT.EPST*(ABS(FTPARA)+ABS(FT1)+EPST))THEN 823 - IF(LMINWR)WRITE(12,'(/'' Minimisation converged.''/)') 824 - IF(LPRINT)WRITE(LUNOUT,'(/'' Minimisation converged.''/)') 825 - GOTO 3000 826 - ENDIF 827 - * Store the value in the table. 828 - IF(FTPARA.LT.FT1)THEN 829 - FT3=FT2 830 - T3=T2 831 - FT2=FT1 832 - T2=T1 833 - FT1=FTPARA 834 - T1=TPARA 835 - ELSEIF(FTPARA.LT.FT2)THEN 836 - FT3=FT2 837 - T3=T2 838 - FT2=FTPARA 839 - T2=TPARA 840 - ELSEIF(FTPARA.LT.FT3)THEN 841 - FT3=FTPARA 842 - T3=TPARA 843 - ELSE 844 - IF(LMINWR)WRITE(12,'('' # Minimisation abandoned:'', 845 - - '' Estimated minimum is far from minimum found.'')') 846 - PRINT *,' !!!!!! DRFMIN WARNING : The estimated minimum'// 847 - - ' is too far from the minimum found sofar.' 848 - ENDIF 849 - 120 CONTINUE 850 - *** No convergence. 851 - PRINT *,' !!!!!! DRFMIN WARNING : No convergence after maximum'// 852 - - ' number of steps.' 853 - PRINT *,' Current minimum F=',FT1 854 - PRINT *,' Found for T=',T1 855 - IF(LMINWR)WRITE(12,'('' # Minimisation halted: maximum'', 856 - - '' number of iterations reached.''/'' Current minimum '', 857 - - '' at T='',E15.8,'', function= '',E15.8)') T1,FT1 858 - *** Clean up. 859 - 3000 CONTINUE 860 - * Close the dataset if open. 861 - IF(LMINWR)CLOSE(12,ERR=2030,IOSTAT=IOS) 862 - * Display number of algebra errors. 863 - CALL ALGERR 864 - * Kill algebra entry points. 865 - CALL ALGCLR(IENTRA) 866 - CALL ALGCLR(IENMIN) 867 - CALL ALGCLR(IENSEL) 868 - RETURN 869 - * Errors while writing the dataset. 870 - 2010 CONTINUE 871 - PRINT *,' ###### DRFMIN ERROR : Error error while writing'// 872 - - ' to ',FILE(1:NCFILE),' via unit 12.' 873 - CALL INPIOS(IOS) 874 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 875 - RETURN 876 - * Errors while closing the dataset. 877 - 2030 CONTINUE 878 - PRINT *,' ###### DRFMIN ERROR : Dataset '//FILE(1:NCFILE)// 879 - - ' unit 12 cannot be closed ; results not predictable' 880 - CALL INPIOS(IOS) 881 - END 650 GARFIELD ================================================== P=DRIFT D=DRFTIM 1 ============================ 0 + +DECK,DRFTIM. 1 - SUBROUTINE DRFTIM 2 - *----------------------------------------------------------------------- 3 - * DRFTIM - Computes the arrival time distribution of some selected 4 - * electrons from random tracks. 5 - * VARIABLES : 6 - * (Last changed on 1/ 2/99.) 7 - *----------------------------------------------------------------------- 1 650 P=DRIFT D=DRFTIM 2 PAGE 958 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,GASDATA. 12.- +SEQ,DRIFTLINE. 13.- +SEQ,PARAMETERS. 14.- +SEQ,PRINTPLOT. 15.- +SEQ,CONSTANTS. 16 - INTEGER MXELEC 17 - PARAMETER(MXELEC=10) 18 - *** Declarations, start setting the max number of histogram channels. 19 - CHARACTER*(MXCHAR) FCNWGT 20 - CHARACTER*80 TITLE 21 - CHARACTER*15 STR1,STR2,STR3 22 - CHARACTER*10 VARLIS(MXVAR) 23 - REAL ARRTIM(1,MXPART),VAR(MXVAR),ANGMIN,ANGMAX,ANGMIR,ANGMAR, 24 - - XARMIN,XARMAX,YARMIN,YARMAX,XARMIR,XARMAR,YARMIR,YARMAR, 25 - - TFORC1,TFORC2,RES(1),XRNDM,ARNDM,RMAX,WEIGHT,XCL,YCL,ZCL, 26 - - ECL,BCL,SCL,TCL,RNDM,RNDNOR 27 - INTEGER IRFTEL(MXELEC),IRFTGL,MELEC(MXELEC),MODVAR(MXVAR), 28 - - JSEL,JALL,IPAIR,NPAIR,NPART,NGLOB,NC1,NC2,NC3,NC,MR,NRES, 29 - - IRNDM,NRNDM,NRNDMR,NCHA,NCHAR,KELEC,NCWGT,I,J,IFAIL1,IFAIL2, 30 - - MODRES(1),IENWGT,IW,ISWCNT,INEXT,NWORD,NVAR,NREXP,IPRT, 31 - - INPTYP,INPCMP 32 - LOGICAL FLAG(MXWORD+3),LGLBPL,LELEPL,USE(MXVAR),LATTA, 33 - - LGLBPR,LELEPR,WFORCE,LKEEP,LDRMC,DONE,OK 34 - EXTERNAL RNDM,RNDNOR,DIVDIF,INPCMP,INPTYP 0 35-+ +SELF,IF=SAVE. 36 - SAVE NRNDM,NCHA,KELEC,MELEC,LGLBPL,LELEPL,LDRMC,LATTA, 37 - - LGLBPR,LELEPR,ANGMIN,ANGMAX,VARLIS 0 38-+ +SELF. 39 - *** Initialise those variables that are kept across calls. 40 - DATA NRNDM /1000/, NCHA /100/ 41 - DATA KELEC /1/, MELEC /MXELEC*5/ 42 - DATA LGLBPL /.TRUE./, LELEPL /.TRUE./ 43 - DATA LGLBPR /.FALSE./, LELEPR /.FALSE./ 44 - DATA LKEEP /.FALSE./ 45 - DATA LATTA /.FALSE./, LDRMC /.FALSE./ 46 - DATA (VARLIS(I),I=1,2) /'X ','ANGLE '/ 47 - *** Check the presence of sufficient gas data. 48 - IF(.NOT.(GASOK(1).AND.GASOK(3).AND.(GASOK(5).OR.HEEDOK)))THEN 49 - PRINT *,' ###### DRFTIM ERROR : Insufficient gas data'// 50 - - ' to perform the calculations.' 51 - PRINT *,' Required are velocity,'// 52 - - ' diffusion and cluster data.' 53 - RETURN 54 - ENDIF 55 - *** Make sure the cell is not in polar coordinates. 56 - IF(POLAR)THEN 57 - PRINT *,' ###### DRFTIM ERROR : The TIMING function'// 58 - - ' can not be applied to polar geometries.' 59 - RETURN 60 - ENDIF 61 - *** Initialise various variables being reset at each call. 62 - XARMIN=DXMIN 63 - XARMAX=DXMAX 64 - YARMIN=DYMIN 65 - YARMAX=DYMAX 66 - ANGMIN=0 67 - ANGMAX=0 68 - WFORCE=.FALSE. 69 - TFORC1=-1.0 70 - TFORC2=-1.0 71 - JSEL=0 72 - JALL=0 73 - FCNWGT='1' 74 - NCWGT=1 75 - *** Examine the input line, flag the known words. 76 - CALL INPNUM(NWORD) 77 - DO 10 I=2,NWORD 78 - IF(INPCMP(I,'X-R#ANGE')+INPCMP(I,'WEIGHT#ING-#FUNCTION')+ 79 - - INPCMP(I,'Y-R#ANGE')+INPCMP(I,'T#IME-WIN#DOW')+ 80 - - INPCMP(I,'BIN#S')+INPCMP(I,'ANG#LE-#RANGE')+ 81 - - INPCMP(I,'ATT#ACHMENT')+INPCMP(I,'NOATT#ACHMENT')+ 82 - - INPCMP(I,'EL#ECTRONS')+INPCMP(I,'ITER#ATIONS')+ 83 - - INPCMP(I,'ITER#ATE')+ 84 - - INPCMP(I,'M#ONTE-C#ARLO-DR#IFT')+ 85 - - INPCMP(I,'NOM#ONTE-C#ARLO-DR#IFT')+ 86 - - INPCMP(I,'PL#OT-O#VERALL')+INPCMP(I,'NOPL#OT-O#VERALL')+ 87 - - INPCMP(I,'PL#OT-SEL#ECTED-#ELECTRONS')+ 88 - - INPCMP(I,'NOPL#OT-SEL#ECTED-#ELECTRONS')+ 89 - - INPCMP(I,'PR#INT-O#VERALL')+INPCMP(I,'NOPR#INT-O#VERALL')+ 90 - - INPCMP(I,'PR#INT-SEL#ECTED-#ELECTRONS')+ 91 - - INPCMP(I,'NOPR#INT-SEL#ECTED-#ELECTRONS')+ 92 - - INPCMP(I,'KEEP-#HISTOGRAMS')+INPCMP(I,'NOKEEP-#HISTOGRAMS')+ 93 - - INPCMP(I,'SIN#GLE-CL#USTER')+ 94 - - INPCMP(I,'NOSIN#GLE-CL#USTER').NE.0)THEN 95 - FLAG(I)=.TRUE. 96 - ELSE 97 - FLAG(I)=.FALSE. 98 - ENDIF 99 - 10 CONTINUE 100 - FLAG(NWORD+1)=.TRUE. 101 - FLAG(NWORD+2)=.TRUE. 102 - FLAG(NWORD+3)=.TRUE. 103 - INEXT=2 104 - ** Read in detail. 105 - OK=.TRUE. 106 - DO 20 I=2,NWORD 107 - IF(I.LT.INEXT)GOTO 20 108 - * Read the angle range. 109 - IF(INPCMP(I,'ANG#LE-#RANGE').NE.0)THEN 110 - IF(FLAG(I+1))THEN 111 - CALL INPMSG(I,'Should have two arguments. ') 1 650 P=DRIFT D=DRFTIM 3 PAGE 959 112 - OK=.FALSE. 113 - ELSEIF(FLAG(I+2))THEN 114 - CALL INPCHK(I+1,2,IFAIL1) 115 - IF(IFAIL1.NE.0)OK=.FALSE. 116 - CALL INPRDR(I+1,ANGMIR,180*ANGMIN/PI) 117 - IF(IFAIL1.EQ.0.AND. 118 - - (ANGMIR.LT.-90.OR.ANGMIR.GT.+90))THEN 119 - CALL INPMSG(I+1,'Not within the range [-90,90].') 120 - OK=.FALSE. 121 - ELSEIF(ANGMIR.GE.-90.AND.ANGMIR.LE.+90.AND. 122 - - IFAIL1.EQ.0)THEN 123 - ANGMIN=PI*ANGMIR/180 124 - ANGMAX=PI*ANGMIR/180 125 - ENDIF 126 - INEXT=I+3 127 - ELSE 128 - CALL INPCHK(I+1,2,IFAIL1) 129 - CALL INPCHK(I+2,2,IFAIL2) 130 - CALL INPRDR(I+1,ANGMIR,180*ANGMIN/PI) 131 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)OK=.FALSE. 132 - IF(IFAIL1.EQ.0.AND. 133 - - (ANGMIR.LT.-90.OR.ANGMIR.GT.+90))THEN 134 - CALL INPMSG(I+1,'Not within the range [-90,90].') 135 - OK=.FALSE. 136 - ENDIF 137 - CALL INPRDR(I+2,ANGMAR,180*ANGMAX/PI) 138 - IF(IFAIL2.EQ.0.AND. 139 - - (ANGMAR.LT.-90.OR.ANGMAR.GT.+90))THEN 140 - CALL INPMSG(I+2,'Not within the range [-90,90].') 141 - OK=.FALSE. 142 - ELSEIF(ANGMIR.GE.-90.AND.ANGMIR.LE.+90.AND. 143 - - ANGMAR.GE.-90.AND.ANGMAR.LE.+90.AND. 144 - - IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN 145 - ANGMIN=PI*MIN(ANGMIR,ANGMAR)/180 146 - ANGMAX=PI*MAX(ANGMIR,ANGMAR)/180 147 - ENDIF 148 - INEXT=I+3 149 - ENDIF 150 - * Explicit time scale. 151 - ELSEIF(INPCMP(I,'T#IME-WIN#DOW').NE.0)THEN 152 - IF(I+2.GT.NWORD.OR.FLAG(I+1).OR.FLAG(I+2))THEN 153 - CALL INPMSG(I,'This keyword has 2 arguments. ') 154 - OK=.FALSE. 155 - ELSEIF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2)THEN 156 - CALL INPMSG(I+1,'This should be a real argument') 157 - OK=.FALSE. 158 - ELSEIF(INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2)THEN 159 - CALL INPMSG(I+2,'This should be a real argument') 160 - OK=.FALSE. 161 - ELSE 162 - CALL INPCHK(I+1,2,IFAIL1) 163 - CALL INPCHK(I+2,2,IFAIL2) 164 - CALL INPRDR(I+1,TFORC1,-1.0) 165 - CALL INPRDR(I+2,TFORC2,-1.0) 166 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR. 167 - - TFORC1.LT.0.0.OR.TFORC2.LT.0.0.OR. 168 - - TFORC1.EQ.TFORC2)THEN 169 - CALL INPMSG(I+1,'Window incorrectly specified. ') 170 - CALL INPMSG(I+2,'(See preceding message.) ') 171 - OK=.FALSE. 172 - ELSE 173 - WFORCE=.TRUE. 174 - ENDIF 175 - ENDIF 176 - INEXT=I+3 177 - * The BINS keyword. 178 - ELSEIF(INPCMP(I,'BIN#S').NE.0)THEN 179 - IF(I+1.GT.NWORD.OR.FLAG(I+1))THEN 180 - CALL INPMSG(I,'This keyword has one argument.') 181 - OK=.FALSE. 182 - ELSEIF(INPTYP(I+1).NE.1)THEN 183 - CALL INPMSG(I+1,'This is an integer argument. ') 184 - OK=.FALSE. 185 - ELSE 186 - CALL INPCHK(I+1,1,IFAIL1) 187 - CALL INPRDI(I+1,NCHAR,MXCHA) 188 - IF(NCHAR.LE.1.OR.NCHAR.GT.MXCHA)THEN 189 - CALL INPMSG(I+1,'Inacceptable number of bins. ') 190 - OK=.FALSE. 191 - ELSE 192 - NCHA=NCHAR 193 - ENDIF 194 - ENDIF 195 - INEXT=I+2 196 - * Histogram keeping option. 197 - ELSEIF(INPCMP(I,'KEEP-#HISTOGRAMS').NE.0)THEN 198 - LKEEP=.TRUE. 199 - ELSEIF(INPCMP(I,'NOKEEP-#HISTOGRAMS').NE.0)THEN 200 - LKEEP=.FALSE. 201 - * Read the first and last particle to be considered. 202 - ELSEIF(INPCMP(I,'EL#ECTRONS').NE.0)THEN 203 - KELEC=0 204 - DO 21 J=I+1,NWORD 205 - IF(FLAG(J))THEN 206 - GOTO 22 207 - ELSEIF(KELEC.GE.MXELEC)THEN 208 - CALL INPMSG(J,'No room to store this electron') 209 - OK=.FALSE. 210 - GOTO 21 211 - ELSE 212 - KELEC=KELEC+1 213 - ENDIF 214 - IF(INPCMP(J,'L#AST').NE.0)THEN 215 - MELEC(KELEC)=0 216 - INEXT=J+1 217 - ELSEIF(INPCMP(J,'ONE-B#UT-#LAST').NE.0)THEN 1 650 P=DRIFT D=DRFTIM 4 PAGE 960 218 - MELEC(KELEC)=-1 219 - INEXT=J+1 220 - ELSEIF(INPCMP(J,'TW#O-B#UT-#LAST').NE.0)THEN 221 - MELEC(KELEC)=-2 222 - INEXT=J+1 223 - ELSEIF(INPCMP(J,'TH#REE-B#UT-#LAST').NE.0)THEN 224 - MELEC(KELEC)=-3 225 - INEXT=J+1 226 - ELSEIF(INPTYP(J).NE.1)THEN 227 - CALL INPMSG(J,'This argument is an integer. ') 228 - OK=.FALSE. 229 - INEXT=J 230 - KELEC=KELEC-1 231 - ELSE 232 - CALL INPCHK(J,1,IFAIL1) 233 - CALL INPRDI(J,MR,5) 234 - IF(MR.LT.1-MXPART.AND.IFAIL1.EQ.0)THEN 235 - CALL INPMSG(J,'Smaller than 1-MXPART. ') 236 - OK=.FALSE. 237 - KELEC=KELEC-1 238 - ELSEIF(MR.GT.MXPART.AND.IFAIL1.EQ.0)THEN 239 - CALL INPMSG(J,'Larger than MXPART. ') 240 - OK=.FALSE. 241 - KELEC=KELEC-1 242 - ELSEIF(IFAIL1.EQ.0)THEN 243 - MELEC(KELEC)=MR 244 - ENDIF 245 - INEXT=J+1 246 - ENDIF 247 - 21 CONTINUE 248 - 22 CONTINUE 249 - IF(KELEC.LE.0)THEN 250 - CALL INPMSG(I,'Should have an argument. ') 251 - OK=.FALSE. 252 - KELEC=1 253 - MELEC(1)=5 254 - ENDIF 255 - * The ITERATIONS keyword. 256 - ELSEIF(INPCMP(I,'ITER#ATIONS')+INPCMP(I,'ITER#ATE').NE.0)THEN 257 - IF(I+1.GT.NWORD)THEN 258 - CALL INPMSG(I,'This keyword has one argument.') 259 - OK=.FALSE. 260 - ELSEIF(INPTYP(I+1).NE.1)THEN 261 - CALL INPMSG(I,'This is an integer argument. ') 262 - OK=.FALSE. 263 - ELSE 264 - CALL INPCHK(I+1,1,IFAIL1) 265 - CALL INPRDI(I+1,NRNDMR,NRNDM) 266 - IF(NRNDMR.LT.1)THEN 267 - CALL INPMSG(I+1,'At least 1 iteration needed. ') 268 - OK=.FALSE. 269 - ELSE 270 - NRNDM=NRNDMR 271 - ENDIF 272 - ENDIF 273 - INEXT=I+2 274 - * Monte Carlo drifting. 275 - ELSEIF(INPCMP(I,'M#ONTE-C#ARLO-DR#IFT-#LINES')+ 276 - - INPCMP(I,'MC-DR#IFT-#LINES').NE.0)THEN 277 - LDRMC=.TRUE. 278 - ELSEIF(INPCMP(I,'NOM#ONTE-C#ARLO-DR#IFT-#LINES')+ 279 - - INPCMP(I,'NOMC-DR#IFT-#LINES')+ 280 - - INPCMP(I,'RUN#GE-K#UTTA-DR#IFT-#LINES').NE.0)THEN 281 - LDRMC=.FALSE. 282 - * Take attachment into account. 283 - ELSEIF(INPCMP(I,'ATT#ACHMENT').NE.0)THEN 284 - LATTA=.TRUE. 285 - ELSEIF(INPCMP(I,'NOATT#ACHMENT').NE.0)THEN 286 - LATTA=.FALSE. 287 - * Plot options. 288 - ELSEIF(INPCMP(I,'PL#OT-O#VERALL').NE.0)THEN 289 - LGLBPL=.TRUE. 290 - ELSEIF(INPCMP(I,'NOPL#OT-O#VERALL').NE.0)THEN 291 - LGLBPL=.FALSE. 292 - ELSEIF(INPCMP(I,'PL#OT-SEL#ECTED-#ELECTRON').NE.0)THEN 293 - LELEPL=.TRUE. 294 - ELSEIF(INPCMP(I,'NOPL#OT-SEL#ECTED-#ELECTRON').NE.0)THEN 295 - LELEPL=.FALSE. 296 - * Print options. 297 - ELSEIF(INPCMP(I,'PR#INT-O#VERALL').NE.0)THEN 298 - LGLBPR=.TRUE. 299 - ELSEIF(INPCMP(I,'NOPR#INT-O#VERALL').NE.0)THEN 300 - LGLBPR=.FALSE. 301 - ELSEIF(INPCMP(I,'PR#INT-SEL#ECTED-#ELECTRON').NE.0)THEN 302 - LELEPR=.TRUE. 303 - ELSEIF(INPCMP(I,'NOPR#INT-SEL#ECTED-#ELECTRON').NE.0)THEN 304 - LELEPR=.FALSE. 305 - * Find the x-coordinate range on which this routine will work. 306 - ELSEIF(INPCMP(I,'X-R#ANGE').NE.0)THEN 307 - IF(FLAG(I+1).OR.FLAG(I+2))THEN 308 - CALL INPMSG(I,'Should have two arguments. ') 309 - OK=.FALSE. 310 - ELSE 311 - CALL INPCHK(I+1,2,IFAIL1) 312 - CALL INPCHK(I+2,2,IFAIL2) 313 - CALL INPRDR(I+1,XARMIR,DXMIN) 314 - CALL INPRDR(I+2,XARMAR,DXMAX) 315 - IF(XARMIR.EQ.XARMAR)THEN 316 - CALL INPMSG(I+1,'Zero range not permitted. ') 317 - CALL INPMSG(I+2,'See preceding message. ') 318 - OK=.FALSE. 319 - ELSEIF(MIN(XARMIR,XARMAR).LT.DXMIN.OR. 320 - - MAX(XARMIR,XARMAR).GT.DXMAX)THEN 321 - CALL INPMSG(I+1,'x-Range not inside the area. ') 322 - CALL INPMSG(I+2,'See preceding message. ') 323 - OK=.FALSE. 1 650 P=DRIFT D=DRFTIM 5 PAGE 961 324 - ELSE 325 - XARMIN=MAX(DXMIN,MIN(XARMIR,XARMAR)) 326 - XARMAX=MIN(DXMAX,MAX(XARMIR,XARMAR)) 327 - ENDIF 328 - INEXT=I+3 329 - ENDIF 330 - * Find the y-coordinate range on which this routine will work. 331 - ELSEIF(INPCMP(I,'Y-R#ANGE').NE.0)THEN 332 - IF(FLAG(I+1).OR.FLAG(I+2))THEN 333 - CALL INPMSG(I,'Should have two arguments. ') 334 - OK=.FALSE. 335 - ELSE 336 - CALL INPCHK(I+1,2,IFAIL1) 337 - CALL INPCHK(I+2,2,IFAIL2) 338 - CALL INPRDR(I+1,YARMIR,DYMIN) 339 - CALL INPRDR(I+2,YARMAR,DYMAX) 340 - IF(YARMIR.EQ.YARMAR)THEN 341 - CALL INPMSG(I+1,'Zero range not permitted. ') 342 - CALL INPMSG(I+2,'See preceding message. ') 343 - OK=.FALSE. 344 - ELSEIF(MIN(YARMIR,YARMAR).LT.DYMIN.OR. 345 - - MAX(YARMIR,YARMAR).GT.DYMAX)THEN 346 - CALL INPMSG(I+1,'y-Range not inside the area. ') 347 - CALL INPMSG(I+2,'See preceding message. ') 348 - OK=.FALSE. 349 - ELSE 350 - YARMIN=MAX(DYMIN,MIN(YARMIR,YARMAR)) 351 - YARMAX=MIN(DYMAX,MAX(YARMIR,YARMAR)) 352 - ENDIF 353 - INEXT=I+3 354 - ENDIF 355 - * Weighting function. 356 - ELSEIF(INPCMP(I,'WEIGHT#ING-#FUNCTION').NE.0)THEN 357 - IF(FLAG(I+1))THEN 358 - CALL INPMSG(I,'Should have one argument. ') 359 - OK=.FALSE. 360 - ELSE 361 - CALL INPSTR(I+1,I+1,FCNWGT,NCWGT) 362 - ENDIF 363 - * The option is not known to the program. 364 - ELSE 365 - CALL INPMSG(I,'The option is not known. ') 366 - OK=.FALSE. 367 - ENDIF 368 - 20 CONTINUE 369 - * Display error messages. 370 - CALL INPERR 371 - ** Print some debugging output, to check correct input handling. 372 - IF(LDEBUG)THEN 373 - WRITE(LUNOUT,'('' ++++++ DRFTIM DEBUG :'', 374 - - '' x-range=('',E12.5,'','',E12.5,''),''/25X, 375 - - '' y-range=('',E12.5,'','',E12.5,''),''/25X, 376 - - '' angles =('',E12.5,'','',E12.5,''),''/25X, 377 - - '' weight = '',A/25X, 378 - - '' MC drift = '',L1,'', attachment '',L1/25X, 379 - - '' iterations='',I5,'', bins='',I3)') 380 - - XARMIN,XARMAX,YARMIN,YARMAX,ANGMIN,ANGMAX, 381 - - FCNWGT(1:NCWGT),LDRMC,LATTA,NRNDM,NCHA 382 - WRITE(LUNOUT,'(26X,''Selected electrons: '',100(I3:))') 383 - - (MELEC(I),I=1,KELEC) 384 - ENDIF 385 - *** Quit now if OK is no longer true and if JFAIL is set. 386 - IF(JFAIL.EQ.2.AND..NOT.OK)THEN 387 - PRINT *,' ###### DRFTIM ERROR : Instruction is not'// 388 - - ' carried out because of the above errors.' 389 - RETURN 390 - ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN 391 - PRINT *,' ###### DRFTIM ERROR : Program terminated'// 392 - - ' because of the above errors.' 393 - CALL QUIT 394 - ENDIF 395 - *** Translate the weighting function. 396 - CALL ALGPRE(FCNWGT,NCWGT,VARLIS,2,NRES,USE,IENWGT,IFAIL1) 397 - IF(IFAIL1.NE.0)THEN 398 - PRINT *,' !!!!!! DRFTIM WARNING : Unable to translate'// 399 - - ' the weighting function ; no timing histograms.' 400 - RETURN 401 - ELSEIF(NRES.NE.1)THEN 402 - PRINT *,' !!!!!! DRFTIM WARNING : Timing histogram does'// 403 - - ' not return 1 result ; no timing histograms.' 404 - RETURN 405 - ENDIF 406 - *** Initialise progress printing. 407 - CALL PROINT('TIMING',2,6) 408 - *** Loop over the selected, attracting wires inside the AREA. 409 - CALL PROFLD(1,'Wires',REAL(NSW)) 410 - ISWCNT=0 411 - DO 100 IW=1,NWIRE 412 - * Check sense wire status. 413 - IF(INDSW(IW).NE.0)ISWCNT=ISWCNT+1 414 - CALL PROSTA(1,REAL(ISWCNT)) 415 - IF(INDSW(IW).EQ.0.OR.X(IW).LT.DXMIN.OR.X(IW).GT.DXMAX.OR. 416 - - Y(IW).LT.DYMIN.OR.Y(IW).GT.DYMAX.OR.E(IW).LT.0.0)GOTO 100 417 - IF(LDEBUG)PRINT *,' ++++++ DRFTIM DEBUG : Wire ',IW,' selected' 418 - * Inform what is going on. 419 - CALL PROFLD(2,'Histogram allocation',-1.0) 420 - CALL PROSTA(2,0.0) 421 - *** Open a plot frame of DRIFT-PLOT is on. 422 - IF(LDRPLT)THEN 423 - CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, 424 - - 'DRIFT LINES FOR THE TIMING PLOT') 425 - CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) 426 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 427 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 428 - ENDIF 429 - * Allocate histogram storage and reset the various counters. 1 650 P=DRIFT D=DRFTIM 6 PAGE 962 430 - IF(WFORCE)THEN 431 - CALL HISADM('ALLOCATE',IRFTGL,NCHA, 432 - - TFORC1,TFORC2,.FALSE.,IFAIL1) 433 - IF(IFAIL1.NE.0)THEN 434 - PRINT *,' ###### DRFTIM ERROR : Unable to obtain'// 435 - - ' histogram space (all, t) ; end of calculations.' 436 - RETURN 437 - ENDIF 438 - DO 112 I=1,KELEC 439 - CALL HISADM('ALLOCATE',IRFTEL(I),NCHA, 440 - - TFORC1,TFORC2,.FALSE.,IFAIL2) 441 - IF(IFAIL2.NE.0)THEN 442 - PRINT *,' ###### DRFTIM ERROR : Unable to obtain'// 443 - - ' histogram space (sel, t) ; end of calculations.' 444 - RETURN 445 - ENDIF 446 - 112 CONTINUE 447 - ELSE 448 - CALL HISADM('ALLOCATE',IRFTGL,NCHA, 449 - - 0.0,1.0,.TRUE.,IFAIL1) 450 - IF(IFAIL1.NE.0)THEN 451 - PRINT *,' ###### DRFTIM ERROR : Unable to obtain'// 452 - - ' histogram space (all, t) ; end of calculations.' 453 - RETURN 454 - ENDIF 455 - DO 113 I=1,KELEC 456 - CALL HISADM('ALLOCATE',IRFTEL(I),NCHA, 457 - - 0.0,1.0,.TRUE.,IFAIL2) 458 - IF(IFAIL2.NE.0)THEN 459 - PRINT *,' ###### DRFTIM ERROR : Unable to obtain'// 460 - - ' histogram space (sel, t) ; end of calculations.' 461 - RETURN 462 - ENDIF 463 - 113 CONTINUE 464 - ENDIF 465 - *** Initialise counter of all electrons. 466 - NGLOB=0 467 - * Carry out NRNDM global random cycles, resetting the counters. 468 - CALL PROFLD(2,'Tracks',REAL(NRNDM)) 469 - CALL PROSTA(2,0.0) 470 - IF(NRNDM.LE.10)THEN 471 - IPRT=1 472 - ELSE 473 - IPRT=10**(INT(LOG10(REAL(2*NRNDM)))-1) 474 - ENDIF 475 - *** Start of MC loop. 476 - DO 140 IRNDM=1,NRNDM 477 - IF(IRNDM.EQ.IPRT*(IRNDM/IPRT))CALL PROSTA(2,REAL(IRNDM)) 478 - *** Draw a track location. 479 - XRNDM=XARMIN+RNDM(+IRNDM)*(XARMAX-XARMIN) 480 - ARNDM=ANGMIN+RNDM(-IRNDM)*(ANGMAX-ANGMIN) 481 - RMAX=ABS(DXMAX-DXMIN)+ABS(DYMAX-DYMIN) 482 - XT0=XRNDM-RMAX*SIN(ARNDM) 483 - YT0=Y(IW)-RMAX*COS(ARNDM) 484 - ZT0=0 485 - XT1=XRNDM+RMAX*SIN(ARNDM) 486 - YT1=Y(IW)+RMAX*COS(ARNDM) 487 - ZT1=0 488 - TRFLAG(1)=.TRUE. 489 - * Compute weight for this track. 490 - VAR(1)=XRNDM 491 - VAR(2)=180*ARNDM/PI 492 - MODVAR(1)=2 493 - MODVAR(2)=2 494 - NVAR=2 495 - NREXP=1 496 - CALL ALGEXE(IENWGT,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL1) 497 - IF(IFAIL1.NE.0.OR.MODRES(1).NE.2)THEN 498 - WRITE(LUNOUT,'('' ++++++ DRFTIM DEBUG : Weight not'', 499 - - '' used, mode='',I1,'' IFAIL='',I2)') 500 - - MODRES(1),IFAIL1 501 - WEIGHT=1 502 - ELSE 503 - WEIGHT=RES(1) 504 - ENDIF 505 - * Clip the track to make sure it fits in the AREA. 506 - CALL CLIP(XT0,YT0,XT1,YT1,DXMIN,MAX(DYMIN,YARMIN), 507 - - DXMAX,MIN(DYMAX,YARMAX),IFAIL1) 508 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFTIM DEBUG : Track: '', 509 - - ''('',E15.8,'','',E15.8,'') to ('',E15.8,'','',E15.8, 510 - - '').'')') XT0,YT0,XT1,YT1 511 - * Be sure that at least part of the track is located inside the area. 512 - IF(IFAIL1.NE.0)THEN 513 - IF(LDEBUG)PRINT *,' ++++++ DRFTIM DEBUG : Track not'// 514 - - ' in area or zero length; no further computations.' 515 - GOTO 140 516 - ENDIF 517 - *** Start clustering on this track. 518 - CALL TRACLI 519 - * Reset number of electrons accumulated. 520 - NPART=0 521 - *** Get a new cluster. 522 - 150 CONTINUE 523 - CALL TRACLS(XCL,YCL,ZCL,ECL,NPAIR,DONE,IFAIL1) 524 - * Check whether there was a mistake. 525 - IF(IFAIL1.NE.0)THEN 526 - PRINT *,' !!!!!! DRFTIM WARNING : Clustering error;'// 527 - - ' no histograms.' 528 - CALL HISADM('DELETE',IRFTGL,0,0.0,0.0,.TRUE.,IFAIL1) 529 - DO 155 I=1,KELEC 530 - CALL HISADM('DELETE',IRFTEL(I),0,0.0,0.0,.TRUE.,IFAIL1) 531 - 155 CONTINUE 532 - IF(LDRPLT)THEN 533 - CALL TRAPLT 534 - CALL GRALOG('Aborted drift lines for TIMING plot:') 535 - CALL GRNEXT 1 650 P=DRIFT D=DRFTIM 7 PAGE 963 536 - ENDIF 537 - RETURN 538 - * Check whether this was beyond the last cluster. 539 - ELSEIF(DONE)THEN 540 - GOTO 170 541 - ENDIF 542 - *** Monte Carlo variant. 543 - IF(LDRMC)THEN 544 - * Loop over the pairs in the cluster. 545 - DO 200 IPAIR=1,NPAIR 546 - * Compute the drift line. 547 - CALL DLCMC(XCL,YCL,ZCL,-1.0,1) 548 - * Make sure it ends on the wire. 549 - IF(ISTAT.NE.IW.OR.NU.LT.2)GOTO 200 550 - * See whether it was lost by attachment. 551 - IF(GASOK(6).AND.LATTA)THEN 552 - CALL DLCATT(BCL) 553 - IF(BCL.LT.RNDM(I))GOTO 200 554 - ENDIF 555 - * Add the time to the table. 556 - IF(NPART.GE.MXPART)THEN 557 - PRINT *,' !!!!!! DRFTIM WARNING : Too many'// 558 - - ' electrons on the track; increase MXPART.' 559 - GOTO 140 560 - ENDIF 561 - NPART=NPART+1 562 - ARRTIM(1,NPART)=REAL(TU(NU)) 563 - * And to the overall timing histogram. 564 - CALL HISENT(IRFTGL,ARRTIM(1,NPART),WEIGHT) 565 - * Keep track of number of entries. 566 - NGLOB=NGLOB+1 567 - * Plot the drift line if required. 568 - IF(NU.GT.2.AND.LDRPLT)THEN 569 - IF(POLAR)CALL CF2RTC(XU,YU,XU,YU,NU) 570 - CALL GRATTS('E-DRIFT-LINE','POLYLINE') 571 - CALL GPL2(NU,XU,YU) 572 - ENDIF 573 - 200 CONTINUE 574 - *** Analytic variant. 575 - ELSE 576 - CALL DLCALC(XCL,YCL,ZCL,-1.0,1) 577 - * Make sure it ends on the wire. 578 - IF(ISTAT.NE.IW.OR.NU.LT.2)GOTO 150 579 - * Adjust number of pairs for attachment. 580 - IF(GASOK(6).AND.LATTA)THEN 581 - CALL DLCATT(BCL) 582 - NPAIR=BCL*NPAIR 583 - ENDIF 584 - * Compute diffusion and store time. 585 - TCL=REAL(TU(NU)) 586 - CALL DLCDIF(SCL) 587 - * And generate the correponding number of arrival times. 588 - DO 160 IPAIR=1,NPAIR 589 - IF(NPART.GE.MXPART)THEN 590 - PRINT *,' !!!!!! DRFTIM WARNING : Too many'// 591 - - ' electrons on the track; increase MXPART.' 592 - GOTO 140 593 - ENDIF 594 - NPART=NPART+1 595 - ARRTIM(1,NPART)=RNDNOR(TCL,SCL) 596 - * And to the overall timing histogram. 597 - CALL HISENT(IRFTGL,ARRTIM(1,NPART),WEIGHT) 598 - * Keep track of number of entries. 599 - NGLOB=NGLOB+1 600 - 160 CONTINUE 601 - * Plot the drift line if required. 602 - IF(NU.GT.2.AND.LDRPLT)THEN 603 - IF(POLAR)CALL CF2RTC(XU,YU,XU,YU,NU) 604 - CALL GRATTS('E-DRIFT-LINE','POLYLINE') 605 - CALL GPL2(NU,XU,YU) 606 - ENDIF 607 - ENDIF 608 - * Next cluster. 609 - GOTO 150 610 - *** All clusters done. 611 - 170 CONTINUE 612 - IF(LDRPLT)CALL TRAPLT 613 - *** Find the M'th particle to arrive and enter in a histogram. 614 - IF(NPART.GE.1)THEN 615 - CALL SORTRQ(ARRTIM,1,NPART,1) 616 - DO 180 I=1,KELEC 617 - IF(MELEC(I).GT.0.AND.MELEC(I).LE.NPART.AND.NPART.GT.0)THEN 618 - CALL HISENT(IRFTEL(I),ARRTIM(1,MELEC(I)),WEIGHT) 619 - ELSEIF(MELEC(I).LE.0.AND.MELEC(I)+NPART.GE.1)THEN 620 - CALL HISENT(IRFTEL(I),ARRTIM(1,NPART+MELEC(I)),WEIGHT) 621 - ENDIF 622 - 180 CONTINUE 623 - ENDIF 624 - *** Proceed with the next random cycle. 625 - 140 CONTINUE 626 - *** Check we did indeed collect something. 627 - IF(NGLOB.LE.0)THEN 628 - CALL HISADM('DELETE',IRFTGL,0,0.0,0.0,.TRUE.,IFAIL1) 629 - DO 210 I=1,KELEC 630 - CALL HISADM('DELETE',IRFTEL(I),0,0.0,0.0,.TRUE.,IFAIL1) 631 - 210 CONTINUE 632 - IF(LKEEP)PRINT *,' !!!!!! DRFTIM WARNING : Histograms'// 633 - - ' not kept - no entries.' 634 - GOTO 100 635 - ENDIF 636 - *** Close the plot, if open. 637 - IF(LDRPLT)THEN 638 - CALL GRALOG('Drift lines for a timing plot:') 639 - CALL GRNEXT 640 - ENDIF 641 - *** Plot the curves. 1 650 P=DRIFT D=DRFTIM 8 PAGE 964 642 - IF(LELEPL)THEN 643 - * Inform about progress. 644 - CALL PROFLD(2,'Plot selected e-',-1.0) 645 - CALL PROSTA(2,0.0) 646 - * Plot each of the electrons. 647 - DO 190 I=1,KELEC 648 - CALL OUTFMT(REAL(MELEC(I)),2,STR1,NC1,'LEFT') 649 - CALL OUTFMT(REAL(IW),2,STR2,NC2,'LEFT') 650 - IF(MELEC(I).GT.0)THEN 651 - TITLE='Arrival time of electron '//STR1(1:NC1)// 652 - - ' on wire '//STR2(1:NC2) 653 - NC=34+NC1+NC2 654 - ELSEIF(MELEC(I).EQ.0)THEN 655 - TITLE='Arrival time last electron'// 656 - - ' on wire '//STR2(1:NC2) 657 - NC=35+NC2 658 - ELSE 659 - TITLE='Arrival time last'//STR1(1:NC1)//' electron'// 660 - - ' on wire '//STR2(1:NC2) 661 - NC=35+NC1+NC2 662 - ENDIF 663 - CALL HISPLT(IRFTEL(I),'Arrival time [microsec]', 664 - - TITLE(1:NC),.TRUE.) 665 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 666 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 667 - CALL GRNEXT 668 - CALL GRALOG(TITLE(1:NC)) 669 - 190 CONTINUE 670 - ENDIF 671 - IF(LELEPR)THEN 672 - * Inform about progress. 673 - CALL PROFLD(2,'Print selected e-',-1.0) 674 - CALL PROSTA(2,0.0) 675 - * Print each of the electrons. 676 - DO 144 I=1,KELEC 677 - CALL OUTFMT(REAL(MELEC(I)),2,STR1,NC1,'LEFT') 678 - CALL OUTFMT(REAL(IW),2,STR2,NC2,'LEFT') 679 - IF(MELEC(I).GT.0)THEN 680 - TITLE='Arrival time of electron '//STR1(1:NC1)// 681 - - ' on wire '//STR2(1:NC2) 682 - NC=34+NC1+NC2 683 - ELSEIF(MELEC(I).EQ.0)THEN 684 - TITLE='Arrival time last electron'// 685 - - ' on wire '//STR2(1:NC2) 686 - NC=35+NC2 687 - ELSE 688 - TITLE='Arrival time last'//STR1(1:NC1)//' electron'// 689 - - ' on wire '//STR2(1:NC2) 690 - NC=35+NC1+NC2 691 - ENDIF 692 - CALL HISPRT(IRFTEL(I),'Arrival time [microsec]',TITLE(1:NC)) 693 - 144 CONTINUE 694 - ENDIF 695 - * Global plot. 696 - IF(LGLBPL)THEN 697 - * Inform about progress. 698 - CALL PROFLD(2,'Plot all e-',-1.0) 699 - CALL PROSTA(2,0.0) 700 - * Global plot. 701 - CALL OUTFMT(REAL(IW),2,STR2,NC2,'LEFT') 702 - CALL HISPLT(IRFTGL,'Arrival time [microsec]', 703 - - 'Arrival time of all electrons on wire '// 704 - - STR2(1:NC2),.TRUE.) 705 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 706 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 707 - CALL GRALOG('Overall arrival time distribution. ') 708 - CALL GRNEXT 709 - ENDIF 710 - IF(LGLBPR)THEN 711 - * Inform about progress. 712 - CALL PROFLD(2,'Print all e-',-1.0) 713 - CALL PROSTA(2,0.0) 714 - * Global printout. 715 - CALL OUTFMT(REAL(IW),2,STR2,NC2,'LEFT') 716 - CALL HISPRT(IRFTGL,'Arrival time [microsec]', 717 - - 'Arrival time of all electrons on wire '// 718 - - STR2(1:NC2)) 719 - ENDIF 720 - *** Get rid of the histograms, unless KEEP has been specified. 721 - IF(LKEEP)THEN 722 - * Inform about progress. 723 - CALL PROFLD(2,'Saving histograms',-1.0) 724 - CALL PROSTA(2,0.0) 725 - * Find names for the histograms and save them. 726 - JALL=JALL+1 727 - CALL OUTFMT(REAL(JALL),2,STR1,NC1,'LEFT') 728 - CALL HISSAV(IRFTGL,'ALL_'//STR1(1:NC1),IFAIL1) 729 - CALL OUTFMT(REAL(IW),2,STR2,NC2,'LEFT') 730 - IF(IFAIL1.EQ.0)THEN 731 - PRINT *,' ------ DRFTIM MESSAGE : Arrival time'// 732 - - ' histogram of all electrons for wire '// 733 - - STR2(1:NC2)//' is kept as ALL_'// 734 - - STR1(1:NC1)//'.' 735 - ELSE 736 - PRINT *,' !!!!!! DRFTIM WARNING : Arrival time'// 737 - - ' histogram of all electrons for wire '// 738 - - STR2(1:NC2)//' has not been saved.' 739 - CALL HISADM('DELETE',IRFTGL,0,0.0,0.0,.TRUE.,IFAIL1) 740 - ENDIF 741 - DO 401 I=1,KELEC 742 - JSEL=JSEL+1 743 - CALL OUTFMT(REAL(JSEL),2,STR1,NC1,'LEFT') 744 - CALL HISSAV(IRFTEL(I),'SEL_'//STR1(1:NC1),IFAIL1) 745 - CALL OUTFMT(REAL(MELEC(I)),2,STR2,NC2,'LEFT') 746 - CALL OUTFMT(REAL(IW),2,STR3,NC3,'LEFT') 747 - IF(IFAIL1.EQ.0)THEN 1 650 P=DRIFT D=DRFTIM 9 PAGE 965 748 - PRINT *,' ------ DRFTIM MESSAGE : Arrival time'// 749 - - ' histogram of electron '//STR2(1:NC2)// 750 - - ' for wire '//STR3(1:NC3)//' is kept as SEL_'// 751 - - STR1(1:NC1)//'.' 752 - ELSE 753 - PRINT *,' !!!!!! DRFTIM WARNING : Arrival time'// 754 - - ' histogram of electron '//STR2(1:NC2)// 755 - - ' for wire '//STR3(1:NC3)//' has not been saved.' 756 - CALL HISADM('DELETE',IRFTEL(I),0,0.0,0.0,.TRUE.,IFAIL1) 757 - ENDIF 758 - 401 CONTINUE 759 - ELSE 760 - CALL HISADM('DELETE',IRFTGL,0,0.0,0.0,.TRUE.,IFAIL1) 761 - DO 403 I=1,KELEC 762 - CALL HISADM('DELETE',IRFTEL(I),0,0.0,0.0,.TRUE.,IFAIL1) 763 - 403 CONTINUE 764 - ENDIF 765 - *** Proceed with the next wire. 766 - 100 CONTINUE 767 - *** End of progress printing. 768 - CALL PROEND 769 - *** Register the amount of CPU time used by this routine. 770 - CALL TIMLOG('Calculating arrival times: ') 771 - END 651 GARFIELD ================================================== P=DRIFT D=DRFTRA 1 ============================ 0 + +DECK,DRFTRA. 1 - SUBROUTINE DRFTRA(Q,ITYPE,TSTEP,LDRMC,LEQTPL,LEQREV, 2 - - LLINPL,LLINPR, 3 - - LTIMPL,LVELPL,LDIFPL,LAVAPL,LFUNPL,FUNCT,NCF,MARKER) 4 - *----------------------------------------------------------------------- 5 - * DRFTRA - Subroutine calculating and plotting drift lines given an 6 - * electric field, it optionally plots some isochronous lines 7 - * and graphs of the drift-time, velocity, diffusion and the 8 - * Townsend coefficient. Calculation starts from the track. 9 - * VARIABLES : ISTVEC : Vector of status codes. 10 - * TIMVEC : Vector of drift times. 11 - * VELVEC : Vector of the average drift velocity. 12 - * DIFVEC : Vector of the integrated diffusion. 13 - * AVAVEC : Vector of multiplication factor. 14 - * DRLENG : The length of the current drift line. 15 - * logicals : inherited from DRFDRF, see there. 16 - * (Last changed on 16/ 3/00.) 17 - *----------------------------------------------------------------------- 18 - implicit none 19.- +SEQ,DIMENSIONS. 20.- +SEQ,PARAMETERS. 21.- +SEQ,CELLDATA. 22.- +SEQ,SOLIDS. 23.- +SEQ,GASDATA. 24.- +SEQ,CONSTANTS. 25.- +SEQ,PRINTPLOT. 26.- +SEQ,DRIFTLINE. 27 - DOUBLE PRECISION TRANSF,DRLENG,XAUX1,XAUX2,YAUX1,YAUX2 28 - CHARACTER*133 STRING 29 - CHARACTER*80 FUNCT,STASTR 30 - CHARACTER*30 AUXSTR 31 - CHARACTER*10 VARLIS(MXVAR) 32 - LOGICAL LEQTPL,LLINPL,LLINPR,LTIMPL,LVELPL,LDIFPL,LAVAPL,LFUNPL, 33 - - MARKER,USE(MXVAR),DONE,LDRMC,LEQREV 34 - REAL TIMVEC(MXLIST),VELVEC(MXLIST),VAR(MXVAR), 35 - - DIFVEC(MXLIST),FUNVEC(MXLIST),AVAVEC(MXLIST),ATTVEC(MXLIST), 36 - - POSVEC(MXLIST), 37 - - RES(1),XSTART,YSTART,ZSTART,ESTART,XT0P,YT0P,XT1P,YT1P, 38 - - TSTEP,Q,XR0,YR0,XR1,YR1,VXMIN,VYMIN,VXMAX,VYMAX, 39 - - XT0AUX,YT0AUX,ZT0AUX,XT1AUX,YT1AUX,ZT1AUX 40 - INTEGER ISTVEC(MXLIST),MODVAR(MXVAR),MODRES(1),I,J,IPAIR,NPAIR, 41 - - NCSTAT,NRES,IENTRY,NCF,ITYPE,IFAIL,IU,NCAUX 0 42-+ +SELF,IF=SAVE. 43 - SAVE VARLIS 0 44-+ +SELF. 45 - *** Initialise the VARLIS list of function variables. 46 - DATA (VARLIS(I),I=1,11)/ 47 - - 'LENGTH ','TIME ','DIFFUSION ','AVALANCHE ', 48 - - 'LOSS ','X_END ','Y_END ','Z_END ', 49 - - 'X_START ','Y_START ','Z_START '/ 50 - *** Identify the routine if requested. 51 - IF(LIDENT)PRINT *,' /// ROUTINE DRFTRA ///' 52 - *** Perform preliminary checks, make sure the track has been set. 53 - IF(.NOT.TRFLAG(1))THEN 54 - PRINT *,' !!!!!! DRFTRA WARNING : The track has not been'// 55 - - ' set ; the plot is not made.' 56 - RETURN 57 - ENDIF 58 - * The track should be in the drift area. 59 - IF(POLAR)THEN 60 - IFAIL=0 61 - CALL CFMCTR(XT0,YT0,XR0,YR0,1) 62 - CALL CFMCTR(XT1,YT1,XR1,YR1,1) 63 - IF(XR0.LT.DXMIN.OR.XR0.GT.DXMAX.OR. 64 - - XR1.LT.DXMIN.OR.XR1.GT.DXMAX.OR. 65 - - YR0.LT.DYMIN.OR.YR0.GT.DYMAX.OR. 66 - - YR1.LT.DYMIN.OR.YR1.GT.DYMAX)IFAIL=1 67 - ELSE 68 - XT0AUX=XT0 69 - YT0AUX=YT0 70 - ZT0AUX=ZT0 71 - XT1AUX=XT1 72 - YT1AUX=YT1 73 - ZT1AUX=ZT1 74 - CALL CLIP3(XT0AUX,YT0AUX,ZT0AUX,XT1AUX,YT1AUX,ZT1AUX, 75 - - DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX,IFAIL) 76 - ENDIF 1 651 P=DRIFT D=DRFTRA 2 PAGE 966 77 - IF(IFAIL.NE.0.AND.POLAR)THEN 78 - PRINT *,' !!!!!! DRFTRA WARNING : The track lies at', 79 - - ' least partialy outside the drift area ;', 80 - - ' no drift lines.' 81 - RETURN 82 - ELSEIF(IFAIL.NE.0)THEN 83 - PRINT *,' !!!!!! DRFTRA WARNING : The track is not', 84 - - ' lying at least partially in the drift', 85 - - ' area or has length 0 ; no drift lines.' 86 - RETURN 87 - ENDIF 88 - *** Initialise the output vectores. 89 - DO 10 I=1,MXLIST 90 - ISTVEC(I)=0 91 - TIMVEC(I)=0.0 92 - VELVEC(I)=0.0 93 - DIFVEC(I)=0.0 94 - AVAVEC(I)=0.0 95 - ATTVEC(I)=0.0 96 - FUNVEC(I)=0.0 97 - POSVEC(I)=0.0 98 - 10 CONTINUE 99 - *** Translate the function if requested. 100 - IF(LFUNPL)THEN 101 - IF(POLAR)THEN 102 - VARLIS(6)='R_END' 103 - VARLIS(7)='PHI_END' 104 - VARLIS(9)='R_START' 105 - VARLIS(10)='PHI_START' 106 - ELSE 107 - VARLIS(6)='X_END' 108 - VARLIS(7)='Y_END' 109 - VARLIS(9)='X_START' 110 - VARLIS(10)='Y_START' 111 - ENDIF 112 - IF(INDEX(FUNCT(1:NCF),'@').NE.0)THEN 113 - NRES=1 114 - CALL ALGEDT(VARLIS,11,IENTRY,USE,NRES) 115 - ELSE 116 - CALL ALGPRE(FUNCT,NCF,VARLIS,11,NRES,USE,IENTRY,IFAIL) 117 - IF(IFAIL.NE.0)THEN 118 - PRINT *,' !!!!!! DRFTRA WARNING : The function '// 119 - - FUNCT(1:NCF)//' can not be used because'// 120 - - ' of the syntax errors (see above).' 121 - CALL ALGCLR(IENTRY) 122 - RETURN 123 - ELSEIF(((USE(1).OR.USE(2)).AND..NOT.GASOK(1)).OR. 124 - - (USE(3).AND..NOT.GASOK(3)).OR. 125 - - (USE(4).AND..NOT.GASOK(4)).OR. 126 - - (USE(5).AND..NOT.GASOK(6)))THEN 127 - PRINT *,' !!!!!! DRFTRA WARNING : The amount of'// 128 - - ' gas data is insufficient to calculate'// 129 - - ' the function '//FUNCT(1:NCF) 130 - CALL ALGCLR(IENTRY) 131 - RETURN 132 - ENDIF 133 - ENDIF 134 - IF(NRES.NE.1)THEN 135 - PRINT *,' !!!!!! DRFTRA WARNING : The function '// 136 - - FUNCT(1:NCF)//' does not return a single'// 137 - - ' result ; rejected.' 138 - CALL ALGCLR(IENTRY) 139 - RETURN 140 - ENDIF 141 - ENDIF 142 - *** Initialise clustering. 143 - CALL TRACLI 144 - *** Prepare for output: print a heading if printing is requested. 145 - IF(LLINPR)THEN 146 - XT0P=XT0 147 - YT0P=YT0 148 - XT1P=XT1 149 - YT1P=YT1 150 - IF(POLAR)CALL CFMCTP(XT0P,YT0P,XT0P,YT0P,1) 151 - IF(POLAR)CALL CFMCTP(XT1P,YT1P,XT1P,YT1P,1) 152 - WRITE(LUNOUT,'(''1 Track drift line plot :'',/, 153 - - '' ======================='',//)') 154 - IF(ITYPE.EQ.1)THEN 155 - WRITE(LUNOUT,'('' Drifting'', 156 - - '' electrons with charge '',F4.1)') Q 157 - ELSE 158 - WRITE(LUNOUT,'('' Drifting'', 159 - - '' ions with charge '',F4.1)') Q 160 - ENDIF 161 - WRITE(LUNOUT,'('' The particle begins at ('',F10.3,'','', 162 - - F10.3,'','',F10.3,'')''/ 163 - - '' and goes towards ('',F10.3,'','',F10.3,'','', 164 - - F10.3,'')''//)') XT0P,YT0P,ZT0,XT1P,YT1P,ZT1 165 - IF(.NOT.POLAR)THEN 166 - WRITE(LUNOUT,'('' x-start y-start'', 167 - - '' z-start Drift time Mean speed'', 168 - - '' Diffusion Avalanche'', 169 - - '' Status information'')') 170 - WRITE(LUNOUT,'('' [cm] [cm]'', 171 - - '' [cm] [musec] [cm/musec]'', 172 - - '' [musec] [numeric]'',//)') 173 - ELSE 174 - WRITE(LUNOUT,'('' r-start phi-start'', 175 - - '' z-start Drift time Mean speed'', 176 - - '' Diffusion Avalanche'', 177 - - '' Status information'')') 178 - WRITE(LUNOUT,'('' [cm] [degrees]'', 179 - - '' [cm] [musec] [cm/musec]'', 180 - - '' [musec] [numeric]'',//)') 181 - ENDIF 182 - ENDIF 1 651 P=DRIFT D=DRFTRA 3 PAGE 967 183 - * Open a plot frame for the drift-lines if plotting is requested. 184 - IF(LEQTPL.OR.LLINPL)THEN 185 - IF(ITYPE.EQ.1.AND.Q.LT.0)THEN 186 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 187 - - 'Electron drift lines from a track') 188 - ELSEIF(ITYPE.EQ.1)THEN 189 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 190 - - 'Positron drift lines from a track') 191 - ELSEIF(Q.LT.0)THEN 192 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 193 - - 'Drift lines of negative ions from a track') 194 - ELSE 195 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 196 - - 'Drift lines of positive ions from a track') 197 - ENDIF 198 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 199 - IF(PARTID.NE.'Unknown')CALL GRCOMM(3,'Particle: '//PARTID) 200 - IF(LEQTPL)THEN 201 - CALL OUTFMT(TSTEP,2,AUXSTR,NCAUX,'LEFT') 202 - CALL GRCOMM(4,'Isochrone interval: '//AUXSTR(1:NCAUX)// 203 - - ' [microsec]') 204 - CALL DRFEQR 205 - ENDIF 206 - CALL GRALOG('Track drift line plot. ') 207 - ENDIF 208 - *** Start drift lines from the track. 209 - I=0 210 - 20 CONTINUE 211 - * Generate a cluster. 212 - CALL TRACLS(XSTART,YSTART,ZSTART,ESTART,NPAIR,DONE,IFAIL) 213 - IF(DONE)GOTO 40 214 - * Loop over the electrons. 215 - DO 50 IPAIR=1,NPAIR 216 - * Convert position to internal in polar cells. 217 - IF(POLAR)CALL CFMCTR(XSTART,YSTART,XSTART,YSTART,1) 218 - * Calculate the drift line starting at (XSTART,YSTART) 219 - IF(LDRMC)THEN 220 - CALL DLCMC(XSTART,YSTART,ZSTART,Q,ITYPE) 221 - ELSE 222 - CALL DLCALC(XSTART,YSTART,ZSTART,Q,ITYPE) 223 - ENDIF 224 - * Skip if the line has no steps. 225 - IF(NU.LE.0.OR.NU.GT.MXLIST)THEN 226 - PRINT *,' !!!!!! DLCTRA WARNING : Drift line has no'// 227 - - ' steps or more than MXLIST steps; skipped.' 228 - GOTO 20 229 - ENDIF 230 - * Increment track counter. 231 - IF(I.GE.MXLIST)THEN 232 - PRINT *,' !!!!!! DLCTRA WARNING : Maximum number of'// 233 - - ' electrons reached ; rest is skipped.' 234 - GOTO 40 235 - ELSE 236 - I=I+1 237 - ENDIF 238 - * Convert position to cartesian in polar cells. 239 - IF(POLAR)CALL CFMRTC(XSTART,YSTART,XSTART,YSTART,1) 240 - * To be able to store the coordinate. 241 - POSVEC(I)=SQRT((XSTART-XT0)**2+(YSTART-YT0)**2+(ZSTART-ZT0)**2) 242 - * And convert position to polar in polar cells for printing. 243 - IF(POLAR)CALL CFMCTP(XSTART,YSTART,XSTART,YSTART,1) 244 - ** Calculate and store the derived information for the graphs. 245 - ISTVEC(I)=ISTAT 246 - TIMVEC(I)=TU(NU) 247 - IF(LVELPL.OR.(LFUNPL.AND.USE(1)))THEN 248 - DRLENG=0.0 249 - DO 30 IU=2,NU 250 - IF(POLAR)THEN 251 - CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX1,YAUX1,1) 252 - CALL CF2RTC(XU(IU),YU(IU),XAUX2,YAUX2,1) 253 - DRLENG=DRLENG+SQRT((XAUX2-XAUX1)**2+ 254 - - (YAUX2-YAUX1)**2+(ZU(IU)-ZU(IU-1))**2) 255 - ELSE 256 - DRLENG=DRLENG+SQRT((XU(IU)-XU(IU-1))**2+ 257 - - (YU(IU)-YU(IU-1))**2+(ZU(IU)-ZU(IU-1))**2) 258 - ENDIF 259 - 30 CONTINUE 260 - IF(TU(NU).GT.0.0)THEN 261 - VELVEC(I)=REAL(DRLENG/TU(NU)) 262 - ELSE 263 - VELVEC(I)=0.0 264 - ENDIF 265 - ENDIF 266 - IF(GASOK(3).AND.(LDIFPL.OR.(LFUNPL.AND.USE(3)))) 267 - - CALL DLCDIF(DIFVEC(I)) 268 - IF(GASOK(4).AND.(LAVAPL.OR.(LFUNPL.AND.USE(4)))) 269 - - CALL DLCTWN(AVAVEC(I)) 270 - IF(GASOK(6).AND.LFUNPL.AND.USE(5))CALL DLCATT(ATTVEC(I)) 271 - IF(LFUNPL)THEN 272 - VAR(1)=DRLENG 273 - VAR(2)=REAL(TU(NU)) 274 - VAR(3)=DIFVEC(I) 275 - VAR(4)=AVAVEC(I) 276 - VAR(5)=ATTVEC(I) 277 - IF(POLAR)THEN 278 - CALL CF2RTP(XU(1),YU(1),XAUX1,YAUX1,1) 279 - VAR(9)=REAL(XAUX1) 280 - VAR(10)=REAL(YAUX1) 281 - CALL CF2RTP(XU(NU),YU(NU),XAUX1,YAUX1,1) 282 - VAR(6)=REAL(XAUX1) 283 - VAR(7)=REAL(YAUX1) 284 - ELSE 285 - VAR(9)=REAL(XU(1)) 286 - VAR(10)=REAL(YU(1)) 287 - VAR(6)=REAL(XU(NU)) 288 - VAR(7)=REAL(YU(NU)) 1 651 P=DRIFT D=DRFTRA 4 PAGE 968 289 - ENDIF 290 - VAR(11)=REAL(ZU(1)) 291 - VAR(8)=REAL(ZU(NU)) 292 - MODVAR(1)=2 293 - MODVAR(2)=2 294 - MODVAR(3)=2 295 - MODVAR(4)=2 296 - MODVAR(5)=2 297 - MODVAR(6)=2 298 - MODVAR(7)=2 299 - MODVAR(8)=2 300 - MODVAR(9)=2 301 - MODVAR(10)=2 302 - MODVAR(11)=2 303 - CALL ALGEXE(IENTRY,VAR,MODVAR,11,RES,MODRES,1,IFAIL) 304 - IF(MODRES(1).NE.2)THEN 305 - PRINT *,' !!!!!! DLCTRA WARNING : Function does not'// 306 - - ' return a number; set to 0.' 307 - FUNVEC(I)=0 308 - ELSE 309 - FUNVEC(I)=RES(1) 310 - ENDIF 311 - ENDIF 312 - * Print information on this drift line if requested. 313 - IF(LLINPR)THEN 314 - CALL DLCSTF(ISTAT,STASTR,NCSTAT) 315 - WRITE(STRING,'(2X,7(E10.3,2X),A)') 316 - - XSTART,YSTART,ZSTART, 317 - - TIMVEC(I),VELVEC(I),DIFVEC(I),AVAVEC(I), 318 - - STASTR(1:MIN(45,NCSTAT)) 319 - IF(.NOT.LVELPL)STRING(49:60)=' unavailable' 320 - IF(.NOT.GASOK(3).OR..NOT.LDIFPL) 321 - - STRING(61:72)=' unavailable' 322 - IF(.NOT.GASOK(4).OR..NOT.LAVAPL) 323 - - STRING(73:84)=' unavailable' 324 - WRITE(LUNOUT,'(A133)') STRING 325 - ENDIF 326 - * Plot the drift line obtained - if this is requested. 327 - IF(LLINPL)CALL DLCPLT 328 - *** Invert TU in order to obtain the time-distance from the sense wire. 329 - IF(LEQREV.AND.LEQTPL)THEN 330 - DO 80 J=1,NU 331 - TU(J)=TU(NU)-TU(J) 332 - 80 CONTINUE 333 - * Reverse XU, YU and TU so that they can be treated as plot vectors. 334 - DO 90 J=1,INT(NU/2.0) 335 - TRANSF=TU(J) 336 - TU(J)=TU(NU-J+1) 337 - TU(NU-J+1)=TRANSF 338 - TRANSF=XU(J) 339 - XU(J)=XU(NU-J+1) 340 - XU(NU-J+1)=TRANSF 341 - TRANSF=YU(J) 342 - YU(J)=YU(NU-J+1) 343 - YU(NU-J+1)=TRANSF 344 - TRANSF=ZU(J) 345 - ZU(J)=ZU(NU-J+1) 346 - ZU(NU-J+1)=TRANSF 347 - 90 CONTINUE 348 - * Add to the equal time contour table, select appropriate drift-lines. 349 - IF((ISTAT.GE.-15.AND.ISTAT.LE.-11).OR. 350 - - (ISTAT.GE.1.AND.ISTAT.LE.NWIRE).OR. 351 - - (ISTAT.GE.2*MXWIRE+1.AND.ISTAT.LE.2*MXWIRE+NSOLID)) 352 - - CALL DRFEQT(TSTEP,ISTAT) 353 - ELSEIF(LEQTPL)THEN 354 - CALL DRFEQT(TSTEP,-20) 355 - ENDIF 356 - * Next electron in the cluster. 357 - 50 CONTINUE 358 - * Next cluster. 359 - GOTO 20 360 - * Last cluster processed. 361 - 40 CONTINUE 362 - * Plot the track. 363 - IF(LEQTPL.OR.LLINPL)CALL TRAPLT 364 - *** Register the amount of CPU time used for calculating drift lines. 365 - CALL TIMLOG('Making a track drift-line plot: ') 366 - *** Algebra stuff. 367 - IF(LFUNPL)THEN 368 - CALL ALGERR 369 - CALL ALGCLR(IENTRY) 370 - ENDIF 371 - *** Plot the equal time contours, if requested. 372 - IF(LEQTPL)CALL DRFEQP 373 - * Clear the screen if at least a plot has been made. 374 - IF(LEQTPL.OR.LLINPL)CALL GRNEXT 375 - * Print any error messages accumulated by DRFEQT. 376 - IF(LEQTPL)CALL DRFEQE 377 - *** Plot the various graphs as requested, first the drift time plot. 378 - IF(LTIMPL)CALL DRFTR2(TIMVEC,POSVEC,ISTVEC,I,MARKER, 379 - - 'Drift time [microsec]','Drift time') 380 - IF(LTIMPL) 381 - - CALL GRALOG('Graph of the drift-time ') 382 - * Next the average drift velocity plot. 383 - IF(LVELPL)CALL DRFTR2(VELVEC,POSVEC,ISTVEC,I,MARKER, 384 - - 'Mean drift speed [cm/microsec]', 385 - - 'Average drift speed') 386 - IF(LVELPL) 387 - - CALL GRALOG('Graph of the average drift-velocity ') 388 - * diffusion plot ... 389 - IF(LDIFPL)CALL DRFTR2(DIFVEC,POSVEC,ISTVEC,I,MARKER, 390 - - 'Integrated diffusion [microsec]', 391 - - 'Integrated diffusion') 392 - IF(LDIFPL) 393 - - CALL GRALOG('Graph of the integrated diffusion ') 394 - * the multiplication plot ... 1 651 P=DRIFT D=DRFTRA 5 PAGE 969 395 - IF(LAVAPL)CALL DRFTR2(AVAVEC,POSVEC,ISTVEC,I,MARKER, 396 - - 'Multiplication Factor [numeric]', 397 - - 'Multiplication factor') 398 - IF(LAVAPL) 399 - - CALL GRALOG('Graph of the multiplication factor ') 400 - * and the function plot. 401 - IF(LFUNPL)THEN 402 - STRING=' ' 403 - STRING(1:40)='Graph of '//FUNCT(1:MIN(31,NCF)) 404 - STRING(81-MIN(40,NCF):80)=FUNCT(1:MIN(40,NCF)) 405 - CALL DRFTR2(FUNVEC,POSVEC,ISTVEC,I,MARKER, 406 - - STRING(41:80),STRING(1:40)) 407 - STRING=' ' 408 - STRING(1:40)='Graph of '//FUNCT(1:MIN(31,NCF)) 409 - CALL GRALOG(STRING(1:40)) 410 - ENDIF 411 - ** Register the amount of CPU time used for plotting these curves. 412 - CALL TIMLOG('Plotting various drift related graphs: ') 413 - END 652 GARFIELD ================================================== P=DRIFT D=DRFTR2 1 ============================ 0 + +DECK,DRFTR2. 1 - SUBROUTINE DRFTR2(PLTVEC,POSVEC,ISTVEC,NVEC,MARKER,TEXT,TITLE) 2 - *----------------------------------------------------------------------- 3 - * DRFTR2 - Auxiliary routine to DRFTRA, it plots the various graphs 4 - * such as the mean velocity. 5 - * VARIABLES : PLTVEC : The vector to be plotted. 6 - * ISTVEC : Vector of status codes. 7 - * other args : Texts to be plotted along the axes. 8 - * (Last changed on 7/11/98.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13.- +SEQ,GASDATA. 14.- +SEQ,PARAMETERS. 15 - REAL PLTVEC(MXLIST),XPL(MXLIST),YPL(MXLIST),POSVEC(MXLIST), 16 - - PMIN,PMAX,PDEL,XEMIN,XEMAX,XDEL,AUX,XTXT,YTXT 17 - INTEGER ISTVEC(MXLIST),IND(MXLIST),IAUX,I,J,NVEC,NPL,NC,NCAUX 18 - CHARACTER*(*) TEXT,TITLE 19 - CHARACTER*20 AUXSTR 20 - LOGICAL MARKER,PSET 21 - CHARACTER*40 COMSTR 22 - *** Make sure NVEC is > 0. 23 - IF(NVEC.LE.1)THEN 24 - PRINT *,' !!!!!! DRFTR2 WARNING : Insufficient number'// 25 - - ' of points in the plot vector; no graph.' 26 - RETURN 27 - ENDIF 28 - *** Sort the coordinate vector and make the plot vectors follow. 29 - CALL SORTZV(POSVEC,IND,NVEC,1,0,0) 30 - DO 100 I=1,NVEC 31 - * Rearrange positions. 32 - AUX=POSVEC(I) 33 - POSVEC(I)=POSVEC(IND(I)) 34 - POSVEC(IND(I))=AUX 35 - * Rearrange plot vector. 36 - AUX=PLTVEC(I) 37 - PLTVEC(I)=PLTVEC(IND(I)) 38 - PLTVEC(IND(I))=AUX 39 - * Rearrange status codes. 40 - IAUX=ISTVEC(I) 41 - ISTVEC(I)=ISTVEC(IND(I)) 42 - ISTVEC(IND(I))=IAUX 43 - * Update sort vector. 44 - DO 110 J=I,NVEC 45 - IF(IND(J).EQ.I)IND(J)=IND(I) 46 - 110 CONTINUE 47 - 100 CONTINUE 48 - *** Determine the range of the plotted vector, excluding abnormal ends. 49 - PSET=.FALSE. 50 - DO 10 I=1,NVEC 51 - IF(ISTVEC(I).EQ.-2.OR.ISTVEC(I).EQ.-3)GOTO 10 52 - IF(PSET)THEN 53 - PMIN=MIN(PMIN,PLTVEC(I)) 54 - PMAX=MAX(PMAX,PLTVEC(I)) 55 - ELSE 56 - PMIN=PLTVEC(I) 57 - PMAX=PLTVEC(I) 58 - PSET=.TRUE. 59 - ENDIF 60 - 10 CONTINUE 61 - * Ensure that a range has been found. 62 - IF(.NOT.PSET)THEN 63 - PRINT *,' !!!!!! DRFTR2 WARNING : No complete drift lines'// 64 - - ' have been seen ; no useful plots can be made.' 65 - RETURN 66 - ENDIF 67 - * Slightly increase the range to get a reasonable plot. 68 - PDEL=ABS(PMAX-PMIN) 69 - IF(PMIN.LT.0)THEN 70 - PMIN=PMIN-0.1*PDEL 71 - ELSE 72 - PMIN=MAX(0.0,PMIN-0.1*PDEL) 73 - ENDIF 74 - PMAX=PMAX+0.1*PDEL 75 - XDEL=ABS(POSVEC(NVEC)-POSVEC(1)) 76 - XEMIN=POSVEC(1)-0.1*XDEL 77 - XEMAX=POSVEC(NVEC)+0.1*XDEL 78 - *** Open a frame following the coordinate along the track. 79 - CALL GRCART(XEMIN,PMIN,XEMAX,PMAX, 80 - - 'Distance from track start [cm]',TEXT,TITLE) 81 - * Add some comments to the plot. 82 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 83 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 1 652 P=DRIFT D=DRFTR2 2 PAGE 970 84 - *** Plot the curve, start by initialising the plot vector. 85 - NPL=1 86 - XPL(NPL)=POSVEC(1) 87 - YPL(NPL)=PLTVEC(1) 88 - * Loop over the points. 89 - DO 40 I=2,NVEC 90 - ** Change of status or end of line. 91 - IF(I.EQ.NVEC.OR.ISTVEC(I).NE.ISTVEC(I-1))THEN 92 - * End of line, but no change of status: add. 93 - IF(ISTVEC(I).EQ.ISTVEC(I-1))THEN 94 - IF(NPL.GE.MXLIST)THEN 95 - PRINT *,' ###### DRFTR2 ERROR : Plot buffer'// 96 - - ' overflow ; plot closed.' 97 - CALL GRNEXT 98 - RETURN 99 - ENDIF 100 - NPL=NPL+1 101 - XPL(NPL)=POSVEC(I) 102 - YPL(NPL)=PLTVEC(I) 103 - ENDIF 104 - * Unless abandoned or out of steps: draw the graph. 105 - IF(ISTVEC(I-1).NE.-2.AND.ISTVEC(I-1).NE.-3)THEN 106 - IF(NPL.EQ.1.OR.(MARKER.AND.NPL.GE.1))THEN 107 - CALL GRATTS('FUNCTION-1','POLYMARKER') 108 - CALL GPM(NPL,XPL,YPL) 109 - ELSEIF(NPL.GT.1)THEN 110 - CALL GRATTS('FUNCTION-1','POLYLINE') 111 - CALL GPL(NPL,XPL,YPL) 112 - ENDIF 113 - ENDIF 114 - * A string explaining where the particles ended. 115 - IF(ISTVEC(I-1).EQ.-6)THEN 116 - COMSTR='Left mesh' 117 - NC=9 118 - ELSEIF(ISTVEC(I-1).EQ.-5)THEN 119 - COMSTR='Left drift medium' 120 - NC=17 121 - ELSEIF(ISTVEC(I-1).EQ.-4)THEN 122 - COMSTR='Plane' 123 - NC=5 124 - ELSEIF(ISTVEC(I-1).EQ.-3)THEN 125 - COMSTR='Abnormal' 126 - NC=8 127 - ELSEIF(ISTVEC(I-1).EQ.-2)THEN 128 - COMSTR='Too many steps' 129 - NC=14 130 - ELSEIF(ISTVEC(I-1).EQ.-1)THEN 131 - COMSTR='Left the area' 132 - NC=13 133 - ELSEIF(ISTVEC(I-1).GT.0.AND. 134 - - ISTVEC(I-1).LE.MXWIRE)THEN 135 - CALL OUTFMT(REAL(ISTVEC(I-1)),2,AUXSTR,NCAUX,'LEFT') 136 - COMSTR='Wire '//AUXSTR(1:NCAUX) 137 - NC=5+NCAUX 138 - ELSEIF(ISTVEC(I-1).GT.MXWIRE.AND. 139 - - ISTVEC(I-1).LE.2*MXWIRE)THEN 140 - CALL OUTFMT(REAL(ISTVEC(I-1)-MXWIRE),2, 141 - - AUXSTR,NCAUX,'LEFT') 142 - COMSTR='Replica '//AUXSTR(1:NCAUX) 143 - NC=8+NCAUX 144 - ELSEIF(ISTVEC(I-1).GT.2*MXWIRE.AND. 145 - - ISTVEC(I-1).LE.2*MXWIRE+MXSOLI)THEN 146 - CALL OUTFMT(REAL(ISTVEC(I-1)-2*MXWIRE),2, 147 - - AUXSTR,NCAUX,'LEFT') 148 - COMSTR='Solid '//AUXSTR(1:NCAUX) 149 - NC=6+NCAUX 150 - ELSE 151 - COMSTR='Unknown' 152 - NC=7 153 - ENDIF 154 - XTXT=(XPL(1)+XPL(NPL))/2 155 - YTXT=PMIN+0.02*(PMAX-PMIN) 156 - CALL GRATTS('COMMENT','TEXT') 157 - CALL GSTXAL(2,5) 158 - CALL GRTEXT(XTXT,YTXT,COMSTR(1:NC)) 159 - CALL GSTXAL(0,0) 160 - * Change of status: plot a vertical bar indicating the separation, 161 - IF(ISTVEC(I).NE.ISTVEC(I-1))THEN 162 - XPL(1)=(POSVEC(I)+POSVEC(I-1))/2 163 - XPL(2)=(POSVEC(I)+POSVEC(I-1))/2 164 - YPL(1)=PMIN 165 - YPL(2)=PMAX 166 - CALL GRATTS('COMMENT','POLYLINE') 167 - CALL GPL(2,XPL,YPL) 168 - ENDIF 169 - * Start a new list or reset the list. 170 - IF(ISTVEC(I).NE.ISTVEC(I-1))THEN 171 - NPL=1 172 - XPL(NPL)=POSVEC(I) 173 - YPL(NPL)=PLTVEC(I) 174 - ELSE 175 - NPL=0 176 - ENDIF 177 - ** No change in status: add to buffer. 178 - ELSE 179 - IF(NPL.GE.MXLIST)THEN 180 - PRINT *,' ###### DRFTR2 ERROR : Plot buffer'// 181 - - ' overflow ; plot closed.' 182 - CALL GRNEXT 183 - RETURN 184 - ENDIF 185 - NPL=NPL+1 186 - XPL(NPL)=POSVEC(I) 187 - YPL(NPL)=PLTVEC(I) 188 - ENDIF 189 - 40 CONTINUE 1 652 P=DRIFT D=DRFTR2 3 PAGE 971 190 - *** Plot any data not yet plotted, if not abandoned or out of steps. 191 - IF(ISTVEC(NVEC).NE.-2.AND.ISTVEC(NVEC).NE.-3)THEN 192 - IF(NPL.EQ.1.OR.(MARKER.AND.NPL.GE.1))THEN 193 - CALL GRATTS('FUNCTION-1','POLYMARKER') 194 - CALL GPM(NPL,XPL,YPL) 195 - ELSEIF(NPL.GT.1)THEN 196 - CALL GRATTS('FUNCTION-1','POLYLINE') 197 - CALL GPL(NPL,XPL,YPL) 198 - ENDIF 199 - ENDIF 200 - * A string explaining where the particles ended. 201 - IF(NPL.GE.1)THEN 202 - IF(ISTVEC(NVEC).EQ.-6)THEN 203 - COMSTR='Left mesh' 204 - NC=9 205 - ELSEIF(ISTVEC(NVEC).EQ.-5)THEN 206 - COMSTR='Left drift medium' 207 - NC=17 208 - ELSEIF(ISTVEC(NVEC).EQ.-4)THEN 209 - COMSTR='Plane' 210 - NC=5 211 - ELSEIF(ISTVEC(NVEC).EQ.-3)THEN 212 - COMSTR='Abnormal' 213 - NC=8 214 - ELSEIF(ISTVEC(NVEC).EQ.-2)THEN 215 - COMSTR='Too many steps' 216 - NC=14 217 - ELSEIF(ISTVEC(NVEC).EQ.-1)THEN 218 - COMSTR='Left the area' 219 - NC=13 220 - ELSEIF(ISTVEC(NVEC).GT.0.AND. 221 - - ISTVEC(NVEC).LE.MXWIRE)THEN 222 - CALL OUTFMT(REAL(ISTVEC(NVEC)),2,AUXSTR,NCAUX,'LEFT') 223 - COMSTR='Wire '//AUXSTR(1:NCAUX) 224 - NC=5+NCAUX 225 - ELSEIF(ISTVEC(NVEC).GT.MXWIRE.AND. 226 - - ISTVEC(NVEC).LE.2*MXWIRE)THEN 227 - CALL OUTFMT(REAL(ISTVEC(NVEC)-MXWIRE),2, 228 - - AUXSTR,NCAUX,'LEFT') 229 - COMSTR='Replica '//AUXSTR(1:NCAUX) 230 - NC=8+NCAUX 231 - ELSEIF(ISTVEC(NVEC).GT.2*MXWIRE.AND. 232 - - ISTVEC(NVEC).LE.2*MXWIRE+MXSOLI)THEN 233 - CALL OUTFMT(REAL(ISTVEC(NVEC)-2*MXWIRE),2, 234 - - AUXSTR,NCAUX,'LEFT') 235 - COMSTR='Solid '//AUXSTR(1:NCAUX) 236 - NC=6+NCAUX 237 - ELSE 238 - COMSTR='Unknown' 239 - NC=7 240 - ENDIF 241 - XTXT=(XPL(1)+XPL(NPL))/2 242 - YTXT=PMIN+0.02*(PMAX-PMIN) 243 - CALL GRATTS('COMMENT','TEXT') 244 - CALL GSTXAL(2,5) 245 - CALL GRTEXT(XTXT,YTXT,COMSTR(1:NC)) 246 - CALL GSTXAL(0,0) 247 - ENDIF 248 - *** Close this frame etc. 249 - CALL GRNEXT 250 - END 653 GARFIELD ================================================== P=DRIFT D=DRFSIN 1 ============================ 0 + +DECK,DRFSIN. 1 - SUBROUTINE DRFSIN 2 - *----------------------------------------------------------------------- 3 - * DRFSIN - Prints and plots information on a single drift-line. 4 - * (Last changed on 6/ 2/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,DRIFTLINE. 9.- +SEQ,GASDATA. 10.- +SEQ,CELLDATA. 11.- +SEQ,PRINTPLOT. 12 - DOUBLE PRECISION F0(3) 13 - REAL XPL(MXLIST),YPL(MXLIST),YPR(MXLIST),VAR(MXVAR),RES(3), 14 - - GASDFL,GASTWN,GASATT,VOLT,XSTART,YSTART,ZSTART,QPART,PATH 15 - INTEGER MODVAR(MXVAR),MODRES(3),I,IFAIL1,IFAIL2,IFAIL3,IENTRY, 16 - - NRES,ILOC,NCSTAT,IFAIL,NCFPL1,NCFPL2,NCFPR,INPTYP, 17 - - INPCMP,IFROM,INEXT,IPART,NWORD 18 - LOGICAL KPLOT,KPRINT,USE(MXVAR) 19 - CHARACTER*(MXCHAR) FPL1,FPL2,FPR 20 - CHARACTER*80 STASTR 21 - CHARACTER*20 PARTID 22 - CHARACTER*10 VARLIS(MXVAR) 23 - EXTERNAL GASDFL,GASTWN,GASATT,INPTYP,INPCMP 24 - DATA (VARLIS(I),I=1,21) / 25 - - 'X ','Y ','PATH ','EX ', 26 - - 'EY ','E ','BX ','BY ', 27 - - 'BZ ','B ','VDX ','VDY ', 28 - - 'VDZ ','VD ','TIME ','DIFFUSION ', 29 - - 'TOWNSEND ','STATUS ','ATTACHMENT','EZ ', 30 - - 'Z '/ 31 - *** Defaults. 32 - IFROM=0 33 - FPL1='0' 34 - NCFPL1=1 35 - FPL2='0' 36 - NCFPL2=1 37 - KPLOT=.FALSE. 38 - FPR='0' 39 - NCFPR=1 40 - KPRINT=.FALSE. 41 - QPART=-1.0 1 653 P=DRIFT D=DRFSIN 2 PAGE 972 42 - IPART=1 43 - *** Decode the argument list. 44 - CALL INPNUM(NWORD) 45 - INEXT=2 46 - DO 10 I=2,NWORD 47 - IF(I.LT.INEXT)GOTO 10 48 - * FROM component. 49 - IF(INPCMP(I,'FR#OM').NE.0)THEN 50 - CALL INPCHK(I+1,2,IFAIL1) 51 - CALL INPCHK(I+2,2,IFAIL2) 52 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.NWORD.LT.I+2)THEN 53 - CALL INPMSG(I,'Invalid or incomplete args. ') 54 - ELSE 55 - CALL INPRDR(I+1,XSTART,0.0) 56 - CALL INPRDR(I+2,YSTART,0.0) 57 - IF(POLAR)THEN 58 - CALL CFMPTR(XSTART,YSTART,XSTART,YSTART,1,IFAIL3) 59 - IF(IFAIL3.NE.0)THEN 60 - CALL INPMSG(I, 61 - - 'Not a valid polar coordinate. ') 62 - IFROM=0 63 - ELSE 64 - IFROM=1 65 - ENDIF 66 - ELSE 67 - IFROM=1 68 - ENDIF 69 - IF(IFROM.EQ.1.AND. 70 - - (XSTART.LT.DXMIN.OR.XSTART.GT.DXMAX.OR. 71 - - YSTART.LT.DYMIN.OR.YSTART.GT.DYMAX))THEN 72 - CALL INPMSG(I,'Starting point outside AREA. ') 73 - IFROM=0 74 - ENDIF 75 - ENDIF 76 - IF(INPTYP(I+3).EQ.1.OR.INPTYP(I+3).EQ.2)THEN 77 - CALL INPCHK(I+3,2,IFAIL3) 78 - CALL INPRDR(I+3,ZSTART,0.0) 79 - INEXT=I+4 80 - IF(ZSTART.LT.DZMIN.OR.ZSTART.GT.DZMAX)THEN 81 - CALL INPMSG(I,'Starting point outside AREA') 82 - IFROM=0 83 - ENDIF 84 - ELSE 85 - IFAIL3=0 86 - ZSTART=0.0 87 - INEXT=I+3 88 - ENDIF 89 - * Functions to be plotted. 90 - ELSEIF(INPCMP(I,'PL#OT').NE.0)THEN 91 - IF(INPCMP(I+2,'VS').EQ.0.OR.I+3.GT.NWORD)THEN 92 - CALL INPMSG(I,'Invalid or incomplete args. ') 93 - ELSE 94 - CALL INPSTR(I+1,I+1,FPL2,NCFPL2) 95 - CALL INPSTR(I+3,I+3,FPL1,NCFPL1) 96 - KPLOT=.TRUE. 97 - INEXT=I+4 98 - ENDIF 99 - ELSEIF(INPCMP(I,'NOPL#OT').NE.0)THEN 100 - KPLOT=.FALSE. 101 - * Function to be printed. 102 - ELSEIF(INPCMP(I,'PR#INT').NE.0)THEN 103 - IF(I+1.GT.NWORD)THEN 104 - CALL INPMSG(I,'Invalid or incomplete args. ') 105 - ELSE 106 - CALL INPSTR(I+1,I+1,FPR,NCFPR) 107 - KPRINT=.TRUE. 108 - INEXT=I+2 109 - ENDIF 110 - ELSEIF(INPCMP(I,'NOPR#INT').NE.0)THEN 111 - KPRINT=.FALSE. 112 - * Particle type. 113 - ELSEIF(INPCMP(I,'E#LECTRON').NE.0)THEN 114 - IPART=1 115 - ELSEIF(INPCMP(I,'I#ON').NE.0)THEN 116 - IF(GASOK(2))THEN 117 - IPART=2 118 - ELSE 119 - CALL INPMSG(I,'Ion mobility data missing. ') 120 - ENDIF 121 - * Particle charge. 122 - ELSEIF(INPCMP(I,'POS#ITIVE').NE.0)THEN 123 - QPART=+1.0 124 - ELSEIF(INPCMP(I,'NEG#ATIVE').NE.0)THEN 125 - QPART=-1.0 126 - * Anything else is not valid. 127 - ELSE 128 - CALL INPMSG(I,'Not recognised as a keyword. ') 129 - ENDIF 130 - 10 CONTINUE 131 - *** Dump error messages. 132 - CALL INPERR 133 - *** Check completeness of the arguments. 134 - IF(IFROM.EQ.0.OR..NOT.(KPRINT.OR.KPLOT))THEN 135 - PRINT *,' !!!!!! DRFSIN WARNING : FROM component missing'// 136 - - ' or no output requested; not executed.' 137 - RETURN 138 - ENDIF 139 - *** Translate the functions, assign appropriate variable names. 140 - IF(POLAR)THEN 141 - VARLIS(1)='R ' 142 - VARLIS(2)='PHI ' 143 - VARLIS(4)='ER ' 144 - VARLIS(5)='EPHI ' 145 - VARLIS(11)='VDR ' 146 - VARLIS(12)='VDPHI ' 147 - ELSE 1 653 P=DRIFT D=DRFSIN 3 PAGE 973 148 - VARLIS(1)='X ' 149 - VARLIS(2)='Y ' 150 - VARLIS(4)='EX ' 151 - VARLIS(5)='EY ' 152 - VARLIS(11)='VDX ' 153 - VARLIS(12)='VDY ' 154 - ENDIF 155 - * Handle the case of user editor steps. 156 - IF(INDEX(FPL1(1:NCFPL1)//FPL2(1:NCFPL2)// 157 - - FPR(1:NCFPR),'@').NE.0)THEN 158 - NRES=3 159 - CALL ALGEDT(VARLIS,21,IENTRY,USE,NRES) 160 - FPL1=' ' 161 - NCFPL1=1 162 - FPL2='Edited function' 163 - NCFPL2=1 164 - FPR='Edited function' 165 - NCFPR=15 166 - * Ordinary formula translation. 167 - ELSE 168 - CALL ALGPRE(FPL1(1:NCFPL1)//','//FPL2(1:NCFPL2)//','// 169 - - FPR(1:NCFPR),NCFPL1+NCFPL2+NCFPR+2,VARLIS,21, 170 - - NRES,USE,IENTRY,IFAIL) 171 - IF(IFAIL.NE.0)THEN 172 - PRINT *,' !!!!!! DRFSIN WARNING : Graph and printed'// 173 - - ' table not produced because of syntax errors.' 174 - CALL ALGCLR(IENTRY) 175 - RETURN 176 - ELSEIF((USE(11).OR.USE(12).OR.USE(13).OR.USE(14)).AND. 177 - - .NOT.((IPART.EQ.1.AND.GASOK(1)).OR. 178 - - (IPART.EQ.2.AND.GASOK(2))))THEN 179 - PRINT *,' !!!!!! DRFSIN WARNING : Drift velocity'// 180 - - ' data used in formula, but data is absent.' 181 - CALL ALGCLR(IENTRY) 182 - RETURN 183 - ELSEIF(USE(16).AND..NOT.(GASOK(3).OR.GASOK(8)))THEN 184 - PRINT *,' !!!!!! DRFSIN WARNING : Diffusion'// 185 - - ' data used in formula, but data is absent.' 186 - CALL ALGCLR(IENTRY) 187 - RETURN 188 - ELSEIF(USE(17).AND..NOT.GASOK(4))THEN 189 - PRINT *,' !!!!!! DRFSIN WARNING : Townsend'// 190 - - ' data used in formula, but data is absent.' 191 - CALL ALGCLR(IENTRY) 192 - RETURN 193 - ELSEIF(USE(19).AND..NOT.GASOK(6))THEN 194 - PRINT *,' !!!!!! DRFSIN WARNING : Attachment'// 195 - - ' data used in formula, but data is absent.' 196 - CALL ALGCLR(IENTRY) 197 - RETURN 198 - ENDIF 199 - ENDIF 200 - * Check that there really are 3 results. 201 - IF(NRES.NE.3)THEN 202 - PRINT *,' !!!!!! DRFSIN WARNING : Graph and printed table'// 203 - - ' not produced: incorrect number of formula elements.' 204 - CALL ALGCLR(IENTRY) 205 - RETURN 206 - ENDIF 207 - *** Compute the drift line. 208 - CALL DLCALC(XSTART,YSTART,ZSTART,QPART,IPART) 209 - *** Zero the output variables. 210 - DO 30 I=1,21 211 - MODVAR(I)=2 212 - VAR(I)=0.0 213 - 30 CONTINUE 214 - *** Initialise the integrated path length. 215 - PATH=0.0 216 - *** Loop over the resulting drift-line, filling plot and print vectors. 217 - DO 20 I=1,NU 218 - * Position, time and status. 219 - VAR(1)=XU(I) 220 - VAR(2)=YU(I) 221 - VAR(21)=ZU(I) 222 - VAR(15)=TU(I) 223 - VAR(18)=ISTAT 224 - * Field. 225 - IF(USE(4).OR.USE(5).OR.USE(6).OR.USE(20).OR. 226 - - USE(16).OR.USE(17).OR.USE(19)) 227 - - CALL EFIELD(VAR(1),VAR(2),VAR(21), 228 - - VAR(4),VAR(5),VAR(20),VAR(6),VOLT,0,ILOC) 229 - IF(USE(7).OR.USE(8).OR.USE(9).OR.USE(10).OR. 230 - - USE(16).OR.USE(17).OR.USE(19)) 231 - - CALL BFIELD(VAR(1),VAR(2),VAR(21), 232 - - VAR(7),VAR(8),VAR(9),VAR(10)) 233 - * Drift velocity. 234 - IF(USE(11).OR.USE(12).OR.USE(13).OR.USE(14))THEN 235 - CALL DLCVEL(XU(I),YU(I),ZU(I),F0,QPART,IPART,ILOC) 236 - VAR(11)=REAL(F0(1)) 237 - VAR(12)=REAL(F0(2)) 238 - VAR(13)=REAL(F0(3)) 239 - ENDIF 240 - * Diffusion, Townsend and attachment coefficients. 241 - IF(POLAR)THEN 242 - IF(USE(16))VAR(16)= 243 - - GASDFL(VAR(4)/EXP(VAR(1)),VAR(5)/EXP(VAR(1)),VAR(20), 244 - - VAR(7),VAR(8),VAR(9)) 245 - IF(USE(17))VAR(17)= 246 - - GASTWN(VAR(4)/EXP(VAR(1)),VAR(5)/EXP(VAR(1)),VAR(20), 247 - - VAR(7),VAR(8),VAR(9)) 248 - IF(USE(19))VAR(19)= 249 - - GASATT(VAR(4)/EXP(VAR(1)),VAR(5)/EXP(VAR(1)),VAR(20), 250 - - VAR(7),VAR(8),VAR(9)) 251 - ELSE 252 - IF(USE(16))VAR(16)=GASDFL(VAR(4),VAR(5),VAR(20), 253 - - VAR(7),VAR(8),VAR(9)) 1 653 P=DRIFT D=DRFSIN 4 PAGE 974 254 - IF(USE(17))VAR(17)=GASTWN(VAR(4),VAR(5),VAR(20), 255 - - VAR(7),VAR(8),VAR(9)) 256 - IF(USE(19))VAR(19)=GASATT(VAR(4),VAR(5),VAR(20), 257 - - VAR(7),VAR(8),VAR(9)) 258 - ENDIF 259 - * Transform vectors and covectors to polar coordinates if needed. 260 - IF(POLAR)THEN 261 - CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) 262 - VAR(4)=VAR(4)/VAR(1) 263 - VAR(5)=VAR(5)/VAR(1) 264 - VAR(6)=VAR(6)/VAR(1) 265 - VAR(11)=VAR(11)*VAR(1) 266 - VAR(12)=VAR(12)*VAR(1) 267 - ENDIF 268 - * Store magnitude of drift velocity. 269 - IF(USE(14))VAR(14)=SQRT(VAR(11)**2+VAR(12)**2+VAR(13)**2) 270 - * Conversion of the location. 271 - IF(POLAR)CALL CF2RTC(XU(I),YU(I),XU(I),YU(I),1) 272 - * Path. 273 - IF(I.GT.1)PATH=PATH+SQRT((XU(I)-XU(I-1))**2+(YU(I)-YU(I-1))**2+ 274 - - (ZU(I)-ZU(I-1))**2) 275 - VAR(3)=PATH 276 - * Function evaluation. 277 - CALL ALGEXE(IENTRY,VAR,MODVAR,21,RES,MODRES,3,IFAIL) 278 - XPL(I)=RES(1) 279 - YPL(I)=RES(2) 280 - YPR(I)=RES(3) 281 - * Next point of the drift line. 282 - 20 CONTINUE 283 - *** Prepare output strings. 284 - CALL DLCSTF(ISTAT,STASTR,NCSTAT) 285 - IF(QPART.GT.0)THEN 286 - PARTID='Positive' 287 - ELSE 288 - PARTID='Negative' 289 - ENDIF 290 - IF(IPART.EQ.1)THEN 291 - PARTID(9:)=' electron' 292 - ELSE 293 - PARTID(9:)=' ion' 294 - ENDIF 295 - *** Remove the algebra entry point. 296 - CALL ALGCLR(IENTRY) 297 - *** Print the results if requested. 298 - IF(KPRINT)THEN 299 - IF(POLAR)THEN 300 - CALL CFMRTP(XSTART,YSTART,XSTART,YSTART,1) 301 - CALL CF2CTP(XU,YU,XU,YU,NU) 302 - WRITE(LUNOUT,'(/'' SINGLE DRIFT-LINE PRINT-OUT:''// 303 - - '' Starting point: ('',E10.3,2('','',E10.3), 304 - - '')''/'' Drifting: '',A/ 305 - - '' Status code: '',A/ 306 - - '' Function: '',A// 307 - - '' r [cm] phi [degree]'', 308 - - '' z [cm] time [microsec]'', 309 - - '' Function'')') XSTART,YSTART,ZSTART, 310 - - PARTID,STASTR(1:NCSTAT),FPR(1:NCFPR) 311 - ELSE 312 - WRITE(LUNOUT,'(/'' SINGLE DRIFT-LINE PRINT-OUT:''// 313 - - '' Starting point: ('',E10.3,2('','',E10.3), 314 - - '')''/'' Drifting: '',A/ 315 - - '' Status code: '',A/ 316 - - '' Function: '',A// 317 - - '' x [cm] y [cm]]'', 318 - - '' z [cm] time [microsec]'', 319 - - '' Function'')') XSTART,YSTART,ZSTART, 320 - - PARTID,STASTR(1:NCSTAT),FPR(1:NCFPR) 321 - ENDIF 322 - DO 40 I=1,NU 323 - WRITE(LUNOUT,'(5(2X,E15.8))') REAL(XU(I)),REAL(YU(I)), 324 - - REAL(ZU(I)),REAL(TU(I)),YPR(I) 325 - 40 CONTINUE 326 - ENDIF 327 - *** Plot the results if requested. 328 - IF(KPLOT)THEN 329 - CALL GRGRPH(XPL,YPL,NU,FPL1(1:NCFPL1),FPL2(1:NCFPL2), 330 - - 'SINGLE DRIFT-LINE GRAPH') 331 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 332 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 333 - CALL GRCOMM(3,'Drifting: '//PARTID) 334 - CALL GRCOMM(4,'Status: '//STASTR(1:NCSTAT)) 335 - CALL GRNEXT 336 - CALL GRALOG('Single drift line plot. ') 337 - ENDIF 338 - END 654 GARFIELD ================================================== P=DRIFT D=DRFSOL 1 ============================ 0 + +DECK,DRFSOL. 1 - SUBROUTINE DRFSOL(Q,ITYPE,TSTEP,LEQTPL,LEQREV, 2 - - LLINPL,LLINPR,NLINEV) 3 - *----------------------------------------------------------------------- 4 - * DRFSOL - Subroutine making a plot of the drift lines and the equal 5 - * time contours starting from solid that are specified in 6 - * the INDSOL selection. 7 - * VARIABLES : 8 - * (Last changed on 16/ 3/00.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,PARAMETERS. 13.- +SEQ,CELLDATA. 14.- +SEQ,SOLIDS. 15.- +SEQ,GASDATA. 16.- +SEQ,CONSTANTS. 1 654 P=DRIFT D=DRFSOL 2 PAGE 975 17.- +SEQ,PRINTPLOT. 18.- +SEQ,DRIFTLINE. 19 - CHARACTER*80 AUXSTR,STASTR 20 - INTEGER ISOL,ITYPE,NLINEV,NCSTAT,NCAUX,NPL,NPANEL,IPANEL, 21 - - IVOL,ICOL,IFAIL,I,J,IPL 22 - REAL Q,TSTEP,VXMIN,VYMIN,VXMAX,VYMAX,XSTART,YSTART,ZSTART 23 - DOUBLE PRECISION XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE),APL,BPL,CPL, 24 - - TOTAL,DTOTAL,TRANSF 25 - LOGICAL LEQTPL,LLINPL,LLINPR,LEQREV 26 - *** Define some formats. 27 - 1080 FORMAT('1 Table of drift lines from solids:',/, 28 - - ' =================================',//, 29 - - ' The equal time contours are separated by ',E10.3, 30 - - ' microsecs'/ 31 - - ' Drifting ',A,', charge=',I2// 32 - - ' Line Solid Steps Drift time Remarks'/ 33 - - ' [microsec] '//) 34 - *** Identify the routine, if requested. 35 - IF(LIDENT)PRINT *,' /// ROUTINE DRFSOL ///' 36 - *** Print a heading for the table 37 - IF(LLINPR.AND.ITYPE.EQ.1)WRITE(LUNOUT,1080) TSTEP,'electrons', 38 - - NINT(Q) 39 - IF(LLINPR.AND.ITYPE.EQ.2)WRITE(LUNOUT,1080) TSTEP,'ions', 40 - - NINT(Q) 41 - *** Prepare a plot (layout, frame number etc) 42 - IF(LEQTPL.OR.LLINPL)THEN 43 - IF(ITYPE.EQ.1.AND.Q.GT.0)THEN 44 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 45 - - 'Positron drift lines from solids') 46 - ELSEIF(ITYPE.EQ.1)THEN 47 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 48 - - 'Electron drift lines from solids') 49 - ELSEIF(Q.GT.0)THEN 50 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 51 - - 'Drift lines of positive ions from solids') 52 - ELSE 53 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 54 - - 'Drift lines of negative ions from solids') 55 - ENDIF 56 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 57 - IF(LEQTPL)THEN 58 - CALL OUTFMT(TSTEP,2,AUXSTR,NCAUX,'LEFT') 59 - CALL GRCOMM(4,'Isochrone interval: '//AUXSTR(1:NCAUX)// 60 - - ' [microsec]') 61 - CALL DRFEQR 62 - ENDIF 63 - CALL GRALOG('Drift lines from solids') 64 - ENDIF 65 - *** Set the appropriate representations. 66 - IF(ITYPE.EQ.2)THEN 67 - CALL GRATTS('ION-DRIFT-LINE','POLYLINE') 68 - ELSE 69 - CALL GRATTS('E-DRIFT-LINE','POLYLINE') 70 - ENDIF 71 - *** Loop over all solids in the plot frame attracting electrons. 72 - DO 10 ISOL=1,NSOLID 73 - * Ensure the solid is selected. 74 - IF(INDSOL(ISOL).EQ.0)GOTO 10 75 - * Reset the buffer of the panels. 76 - CALL PLABU1('RESET',ISOL,NPL,XPL,YPL,ZPL, 77 - - 0.0D0,0.0D0,0.0D0,ICOL,IVOL,IFAIL) 78 - * Compute the intersect with the viewing plane, cylinders ... 79 - IF(ISOLTP(ISOL).EQ.1)THEN 80 - CALL PLACYC(ISOL,FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 81 - - FPROJA,FPROJB,FPROJC,ICOL) 82 - * cylindrical holes. 83 - ELSEIF(ISOLTP(ISOL).EQ.2)THEN 84 - CALL PLACHC(ISOL,FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 85 - - FPROJA,FPROJB,FPROJC,ICOL) 86 - * boxes ... 87 - ELSEIF(ISOLTP(ISOL).EQ.3)THEN 88 - CALL PLABXC(ISOL,FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 89 - - FPROJA,FPROJB,FPROJC,ICOL) 90 - * spheres ... 91 - ELSEIF(ISOLTP(ISOL).EQ.4)THEN 92 - CALL PLASPC(ISOL,FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), 93 - - FPROJA,FPROJB,FPROJC,ICOL) 94 - * other things not known. 95 - ELSE 96 - PRINT *,' !!!!!! DRFSOL WARNING : Met a solid of unknown'// 97 - - ' type ',ISOLTP(IVOL),'; skipped.' 98 - GOTO 10 99 - ENDIF 100 - *** Loop over the various panels, first count them. 101 - CALL PLABU1('QUERY',NPANEL,NPL,XPL,YPL,ZPL,APL,BPL,CPL, 102 - - ICOL,IVOL,IFAIL) 103 - * Make sure that the buffer is OK. 104 - IF(IFAIL.NE.0)THEN 105 - PRINT *,' !!!!!! DRFSOL WARNING : Unable to count the'// 106 - - ' panels for the solid.' 107 - GOTO 10 108 - * Be sure that there is some intersect. 109 - ELSEIF(NPANEL.LE.0)THEN 110 - GOTO 10 111 - ENDIF 112 - * Pick up one panel at the time. 113 - DO 20 IPANEL=1,NPANEL 114 - * Read plane. 115 - CALL PLABU1('READ',IPANEL,NPL,XPL,YPL,ZPL,APL,BPL,CPL, 116 - - ICOL,IVOL,IFAIL) 117 - * Make sure that the panel was well read is OK. 118 - IF(IFAIL.NE.0)THEN 119 - PRINT *,' !!!!!! DRFSOL WARNING : Unable to read a panel'// 120 - - ' ; no drift lines for this panel.' 121 - GOTO 20 122 - ENDIF 1 654 P=DRIFT D=DRFSOL 3 PAGE 976 123 - * Compute total length. 124 - TOTAL=0 125 - DO 30 IPL=1,NPL 126 - TOTAL=TOTAL+SQRT((XPL(1+MOD(IPL,NPL))-XPL(IPL))**2+ 127 - - (YPL(1+MOD(IPL,NPL))-YPL(IPL))**2+ 128 - - (ZPL(1+MOD(IPL,NPL))-ZPL(IPL))**2) 129 - 30 CONTINUE 130 - DTOTAL=TOTAL/NLINEV 131 - * Distribute the drift lines. 132 - TOTAL=0 133 - IPL=1 134 - DO 40 I=0,NLINEV-1 135 - 50 CONTINUE 136 - IF(I*DTOTAL.GE.TOTAL.AND. 137 - - I*DTOTAL.LE.TOTAL+SQRT((XPL(1+MOD(IPL,NPL))-XPL(IPL))**2+ 138 - - (YPL(1+MOD(IPL,NPL))-YPL(IPL))**2+ 139 - - (ZPL(1+MOD(IPL,NPL))-ZPL(IPL))**2))THEN 140 - XSTART=XPL(IPL)+ 141 - - (I*DTOTAL-TOTAL)*(XPL(1+MOD(IPL,NPL))-XPL(IPL))/ 142 - - SQRT((XPL(1+MOD(IPL,NPL))-XPL(IPL))**2+ 143 - - (YPL(1+MOD(IPL,NPL))-YPL(IPL))**2+ 144 - - (ZPL(1+MOD(IPL,NPL))-ZPL(IPL))**2) 145 - YSTART=YPL(IPL)+ 146 - - (I*DTOTAL-TOTAL)*(YPL(1+MOD(IPL,NPL))-YPL(IPL))/ 147 - - SQRT((XPL(1+MOD(IPL,NPL))-XPL(IPL))**2+ 148 - - (YPL(1+MOD(IPL,NPL))-YPL(IPL))**2+ 149 - - (ZPL(1+MOD(IPL,NPL))-ZPL(IPL))**2) 150 - ZSTART=ZPL(IPL)+ 151 - - (I*DTOTAL-TOTAL)*(ZPL(1+MOD(IPL,NPL))-ZPL(IPL))/ 152 - - SQRT((XPL(1+MOD(IPL,NPL))-XPL(IPL))**2+ 153 - - (YPL(1+MOD(IPL,NPL))-YPL(IPL))**2+ 154 - - (ZPL(1+MOD(IPL,NPL))-ZPL(IPL))**2) 155 - ELSE 156 - TOTAL=TOTAL+SQRT((XPL(1+MOD(IPL,NPL))-XPL(IPL))**2+ 157 - - (YPL(1+MOD(IPL,NPL))-YPL(IPL))**2+ 158 - - (ZPL(1+MOD(IPL,NPL))-ZPL(IPL))**2) 159 - IPL=IPL+1 160 - IF(IPL.GT.NPL+1)THEN 161 - PRINT *,' !!!!!! DRFSOL WARNING : Unable to locate'// 162 - - ' side of panel from which to start a drift line.' 163 - GOTO 20 164 - ENDIF 165 - GOTO 50 166 - ENDIF 167 - *** Compute the drift line. 168 - CALL DLCALC(XSTART,YSTART,ZSTART,Q,ITYPE) 169 - *** Print data on this drift line if requested. 170 - IF(LLINPR)THEN 171 - CALL DLCSTF(ISTAT,STASTR,NCSTAT) 172 - WRITE(LUNOUT,'(2X,I5,2X,I5,2X,I5,2X,E15.8,2X,A)') 173 - - I,ISOL,NU,TU(NU),STASTR(1:NCSTAT) 174 - ENDIF 175 - *** Plot the drift line obtained. 176 - IF(LLINPL)CALL DLCPLT 177 - *** Invert TU in order to obtain the time distance from the sense wire. 178 - IF(LEQREV)THEN 179 - DO 80 J=1,NU 180 - TU(J)=TU(NU)-TU(J) 181 - 80 CONTINUE 182 - *** Reverse XU,YU and TU so that they can be treated as plot vectors. 183 - DO 90 J=1,INT(NU/2.0) 184 - TRANSF=TU(J) 185 - TU(J)=TU(NU-J+1) 186 - TU(NU-J+1)=TRANSF 187 - TRANSF=XU(J) 188 - XU(J)=XU(NU-J+1) 189 - XU(NU-J+1)=TRANSF 190 - TRANSF=YU(J) 191 - YU(J)=YU(NU-J+1) 192 - YU(NU-J+1)=TRANSF 193 - 90 CONTINUE 194 - *** Don't accept lines not leading to a wire. 195 - IF((ISTAT.GE.-15.AND.ISTAT.LE.-11).OR. 196 - - (ISTAT.GE.1.AND.ISTAT.LE.NWIRE).OR. 197 - - (ISTAT.GE.2*MXWIRE+1.AND.ISTAT.LE.2*MXWIRE+NSOLID)) 198 - - CALL DRFEQT(TSTEP,ISTAT) 199 - ELSE 200 - CALL DRFEQT(TSTEP,2*MXWIRE+ISOL) 201 - ENDIF 202 - * Next drift line. 203 - 40 CONTINUE 204 - * Next panel. 205 - 20 CONTINUE 206 - * Mext solid. 207 - 10 CONTINUE 208 - *** Register the amount of CPU time used for these steps. 209 - CALL TIMLOG('Making a wire drift-line plot: ') 210 - *** Plot the equal time contours. 211 - IF(LEQTPL)CALL DRFEQP 212 - *** End this page. 213 - IF(LEQTPL.OR.LLINPL)CALL GRNEXT 214 - *** And print any error messages accumulated by DRFEQ. 215 - IF(LEQTPL)CALL DRFEQE 216 - END 655 GARFIELD ================================================== P=DRIFT D=DRFWIR 1 ============================ 0 + +DECK,DRFWIR. 1 - SUBROUTINE DRFWIR(Q,ITYPE,TSTEP,LEQTPL,LEQREV,ANGMIN,ANGMAX, 2 - - LLINPL,LLINPR,NLINEW) 3 - *----------------------------------------------------------------------- 4 - * DRFWIR - Subroutine making a plot of the drift lines and the equal- 5 - * time contours in a given cell using a given gas. The actual 6 - * calculations are done in the routine DLCALC. 7 - * Lines are drawn from the wires that are specified by INDSW 8 - * VARIABLES : 1 655 P=DRIFT D=DRFWIR 2 PAGE 977 9 - * (Last changed on 27/ 3/00.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,PARAMETERS. 14.- +SEQ,CELLDATA. 15.- +SEQ,SOLIDS. 16.- +SEQ,GASDATA. 17.- +SEQ,CONSTANTS. 18.- +SEQ,PRINTPLOT. 19.- +SEQ,DRIFTLINE. 20 - CHARACTER*80 AUXSTR,STASTR 21 - INTEGER IANG,I,J,ITYPE,NLINEW,NCSTAT,NCAUX 22 - REAL RDIST,ANGLE,ANGMIN,ANGMAX,Q,TSTEP,VXMIN,VYMIN,VXMAX,VYMAX 23 - LOGICAL LEQTPL,LLINPL,LLINPR,LEQREV 24 - DOUBLE PRECISION TRANSF 25 - *** Define some formats. 26 - 1080 FORMAT('1 Table of wire drift lines :',/, 27 - - ' ===========================',//, 28 - - ' The equal time contours are separated by ',E10.3, 29 - - ' micro secs'/' Drifting ',A,', charge=',I2,//, 30 - - ' Angle wire steps drift time', 31 - - ' remarks',/, 32 - - ' [degrees] [microsec]'//) 33 - *** Identify the routine, if requested. 34 - IF(LIDENT)PRINT *,' /// ROUTINE DRFWIR ///' 35 - *** Check the the call is useful. 36 - IF(NSW.EQ.0)THEN 37 - PRINT *,' !!!!!! DRFWIR WARNING : No wires selected as', 38 - - ' starting wire for drift lines ; no plot is made.' 39 - RETURN 40 - ENDIF 41 - *** Print a heading for the table 42 - IF(LLINPR.AND.ITYPE.EQ.1)WRITE(LUNOUT,1080) TSTEP,'electrons', 43 - - NINT(Q) 44 - IF(LLINPR.AND.ITYPE.EQ.2)WRITE(LUNOUT,1080) TSTEP,'ions', 45 - - NINT(Q) 46 - *** Prepare a plot (layout, frame number etc) 47 - IF(LEQTPL.OR.LLINPL)THEN 48 - IF(ITYPE.EQ.1.AND.Q.GT.0)THEN 49 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 50 - - 'Positron drift lines from a wire') 51 - ELSEIF(ITYPE.EQ.1)THEN 52 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 53 - - 'Electron drift lines from a wire') 54 - ELSEIF(Q.GT.0)THEN 55 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 56 - - 'Drift lines of positive ions from a wire') 57 - ELSE 58 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 59 - - 'Drift lines of negative ions from a wire') 60 - ENDIF 61 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 62 - IF(LEQTPL)THEN 63 - CALL OUTFMT(TSTEP,2,AUXSTR,NCAUX,'LEFT') 64 - CALL GRCOMM(4,'Isochrone interval: '//AUXSTR(1:NCAUX)// 65 - - ' [microsec]') 66 - CALL DRFEQR 67 - ENDIF 68 - CALL GRALOG('Wire drift line plot. ') 69 - ENDIF 70 - *** Loop over all wires in the plot frame attracting electrons. 71 - IF(ITYPE.EQ.2)THEN 72 - CALL GRATTS('ION-DRIFT-LINE','POLYLINE') 73 - ELSE 74 - CALL GRATTS('E-DRIFT-LINE','POLYLINE') 75 - ENDIF 76 - DO 10 I=1,NWIRE 77 - IF(INDSW(I).EQ.0)GOTO 10 78 - IF(LREPSK.AND.Q*E(I).LT.0)THEN 79 - IF(LLINPR)WRITE(LUNOUT,'(1X,''All angles'',I10,29X, 80 - - ''The wire repels the selected particles.'')') I 81 - GOTO 10 82 - ENDIF 83 - IF(X(I).LE.DXMIN.OR.X(I).GE.DXMAX)GOTO 10 84 - IF(Y(I).LE.DYMIN.OR.Y(I).GE.DYMAX)GOTO 10 85 - *** Draw drift lines in all directions. 86 - DO 20 IANG=1,NLINEW 87 - IF(NLINEW.LE.1)THEN 88 - ANGLE=0.5*(ANGMIN+ANGMAX) 89 - ELSEIF(ABS(ANGMAX-ANGMIN-2*PI).LT.0.001)THEN 90 - ANGLE=ANGMIN+REAL(IANG-1)*(ANGMAX-ANGMIN)/REAL(NLINEW) 91 - ELSE 92 - ANGLE=ANGMIN+REAL(IANG-1)*(ANGMAX-ANGMIN)/REAL(NLINEW-1) 93 - ENDIF 94 - * Start a drift line at enough distance from the wire. 95 - IF(Q*E(I).LT.0)THEN 96 - RDIST=0.51*RTRAP*D(I) 97 - ELSE 98 - RDIST=0.51*D(I) 99 - ENDIF 100 - CALL DLCALC(X(I)+RDIST*COS(ANGLE),Y(I)+RDIST*SIN(ANGLE), 101 - - 0.0,Q,ITYPE) 102 - *** Print data on this drift line if requested. 103 - IF(LLINPR)THEN 104 - CALL DLCSTF(ISTAT,STASTR,NCSTAT) 105 - WRITE(LUNOUT,'(1X,F10.2,I10,I10,2X,E15.8,2X,A)') 106 - - 180*ANGLE/PI,I,NU,TU(NU),STASTR(1:NCSTAT) 107 - ENDIF 108 - *** Plot the drift line obtained. 109 - IF(LLINPL)CALL DLCPLT 110 - *** Invert TU in order to obtain the time distance from the sense wire. 111 - IF(LEQREV)THEN 112 - DO 80 J=1,NU 113 - TU(J)=TU(NU)-TU(J) 114 - 80 CONTINUE 1 655 P=DRIFT D=DRFWIR 3 PAGE 978 115 - *** Reverse XU,YU and TU so that they can be treated as plot vectors. 116 - DO 90 J=1,INT(NU/2.0) 117 - TRANSF=TU(J) 118 - TU(J)=TU(NU-J+1) 119 - TU(NU-J+1)=TRANSF 120 - TRANSF=XU(J) 121 - XU(J)=XU(NU-J+1) 122 - XU(NU-J+1)=TRANSF 123 - TRANSF=YU(J) 124 - YU(J)=YU(NU-J+1) 125 - YU(NU-J+1)=TRANSF 126 - 90 CONTINUE 127 - *** Don't accept lines not leading to a wire. 128 - IF((ISTAT.GE.-15.AND.ISTAT.LE.-11).OR. 129 - - (ISTAT.GE.1.AND.ISTAT.LE.NWIRE).OR. 130 - - (ISTAT.GE.2*MXWIRE+1.AND.ISTAT.LE.2*MXWIRE+NSOLID)) 131 - - CALL DRFEQT(TSTEP,ISTAT) 132 - ELSE 133 - CALL DRFEQT(TSTEP,I) 134 - ENDIF 135 - 20 CONTINUE 136 - 10 CONTINUE 137 - *** Register the amount of CPU time used for these steps. 138 - CALL TIMLOG('Making a wire drift-line plot: ') 139 - *** Plot the equal time contours. 140 - IF(LEQTPL)CALL DRFEQP 141 - *** End this page. 142 - IF(LEQTPL.OR.LLINPL)CALL GRNEXT 143 - *** And print any error messages accumulated by DRFEQ. 144 - IF(LEQTPL)CALL DRFEQE 145 - END 656 GARFIELD ================================================== P=DRIFT D=DRFZRO 1 ============================ 0 + +DECK,DRFZRO. 1 - SUBROUTINE DRFZRO(QDUM,ITYPE,LLINPL,LLINPR,LEQTPL,LEQREV) 2 - *----------------------------------------------------------------------- 3 - * DRFZRO - Subroutine making a plot of the drift lines in a given cell 4 - * using a given gas starting at the E=0 points. The actual 5 - * calculations are done in the routine DLCALC. 6 - * VARIABLES : LLINPL : Plotting of drift-lines en/disabled. 7 - * LLINPR : Printing of drift-lines en/disabled. 8 - * (Last changed on 16/ 3/00.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,PARAMETERS. 13.- +SEQ,CELLDATA. 14.- +SEQ,GASDATA. 15.- +SEQ,CONSTANTS. 16.- +SEQ,PRINTPLOT. 17.- +SEQ,DRIFTLINE. 18.- +SEQ,ZERODATA. 19.- +SEQ,BFIELD. 20 - LOGICAL LLINPR,LLINPL,LEQTPL,LEQREV 21 - REAL ZDIST,Q,ANGLE,QDUM,XZPRT,YZPRT 22 - INTEGER ITYPE,I,IQ,IANG 23 - *** Define some formats. 24 - 1010 FORMAT(2X,I5,4(1X,E12.5),2X,I5,' it hit wire ',I3) 25 - 1020 FORMAT(2X,I5,4(1X,E12.5),2X,I5,' more than ',I3,' steps') 26 - 1030 FORMAT(2X,I5,4(1X,E12.5),2X,I5,' left the drift area') 27 - 1040 FORMAT(2X,I5,4(1X,E12.5),2X,I5,' calculations abandoned') 28 - 1050 FORMAT(2X,I5,4(1X,E12.5),2X,I5,' it hit a plane') 29 - 1060 FORMAT(2X,I5,4(1X,E12.5),2X,I5,' it hit wire ',I3,',', 30 - - ' but not in the elementary cell') 31 - 1080 FORMAT('1 Table of drift lines from the E=0 points:',/, 32 - - ' =========================================',//, 33 - - ' Drifting ',A,', of both signs'// 34 - - ' Zero orientation location', 35 - - ' drift-time steps',/, 36 - - ' [degrees] [cm] [cm/degree]', 37 - - ' [microsec]',/) 38 - *** Identify the routine, if requested. 39 - IF(LIDENT)PRINT *,' /// ROUTINE DRFZRO ///' 40 - *** Check the the call is useful. 41 - IF(NZ.EQ.0.OR..NOT.ZROSET)THEN 42 - PRINT *,' !!!!!! DRFZRO WARNING : The zeros have not yet', 43 - - ' been located or there are none ; no plot is made.' 44 - RETURN 45 - ENDIF 46 - *** Print a heading for the table. 47 - IF(LLINPR.AND.ITYPE.EQ.1)WRITE(LUNOUT,1080) 'electrons' 48 - IF(LLINPR.AND.ITYPE.EQ.2)WRITE(LUNOUT,1080) 'ions' 49 - *** Prepare a plot (layout, frame number etc) 50 - IF(LLINPL)THEN 51 - CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, 52 - - 'DRIFT LINES FROM THE E=0 POINTS ') 53 - CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) 54 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 55 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 56 - IF(ITYPE.EQ.1)CALL GRCOMM(3,'Drifting: electrons') 57 - IF(ITYPE.EQ.2)CALL GRCOMM(3,'Drifting: ions') 58 - CALL GRALOG('Drift lines from the E=0 points. ') 59 - ENDIF 60 - *** Loop over all zeros in the plot frame attracting electrons. 61 - IF(ITYPE.EQ.2)THEN 62 - CALL GRATTS('ION-DRIFT-LINE','POLYLINE') 63 - ELSE 64 - CALL GRATTS('E-DRIFT-LINE','POLYLINE') 65 - ENDIF 66 - DO 10 I=1,NZ 67 - IF(XZ(I).LE.DXMIN.OR.XZ(I).GE.DXMAX.OR. 68 - - YZ(I).LE.DYMIN.OR.YZ(I).GE.DYMAX)GOTO 10 69 - *** Loop over the charges. 70 - DO 20 IQ=-1,1,2 71 - Q=REAL(IQ) 1 656 P=DRIFT D=DRFZRO 2 PAGE 979 72 - *** Draw drift lines in both directions. 73 - ZDIST=1.0E-4*(1+MAX(ABS(XZ(I)),ABS(YZ(I)))) 74 - DO 30 IANG=0,1 75 - IF(Q.LT.0)THEN 76 - ANGLE=PZ(I)+REAL(IANG)*PI 77 - ELSE 78 - ANGLE=PZ(I)+(REAL(IANG)-0.5)*PI 79 - ENDIF 80 - * Start a drift line at enough distance from the wire. 81 - CALL DLCALC(XZ(I)+ZDIST*COS(ANGLE), 82 - - YZ(I)+ZDIST*SIN(ANGLE),0.0,Q,ITYPE) 83 - *** Print data on this drift line if requested. 84 - IF(LLINPR)THEN 85 - XZPRT=XZ(I) 86 - YZPRT=YZ(I) 87 - IF(POLAR)CALL CFMRTP(XZPRT,YZPRT,XZPRT,YZPRT,1) 88 - IF(ISTAT.EQ.-1)WRITE(LUNOUT,1030) 89 - - I,180*ANGLE/PI,XZPRT,YZPRT,REAL(TU(NU)),NU 90 - IF(ISTAT.EQ.-2)WRITE(LUNOUT,1020) 91 - - I,180*ANGLE/PI,XZPRT,YZPRT,REAL(TU(NU)),NU,MXLIST 92 - IF(ISTAT.EQ.-3)WRITE(LUNOUT,1040) 93 - - I,180*ANGLE/PI,XZPRT,YZPRT,REAL(TU(NU)),NU 94 - IF(ISTAT.EQ.-4)WRITE(LUNOUT,1050) 95 - - I,180*ANGLE/PI,XZPRT,YZPRT,REAL(TU(NU)),NU 96 - IF(ISTAT.GT.0.AND.ISTAT.LE.MXWIRE) WRITE(LUNOUT,1010) 97 - - I,180*ANGLE/PI,XZPRT,YZPRT,REAL(TU(NU)),NU,ISTAT 98 - IF(ISTAT.GT.MXWIRE) WRITE(LUNOUT,1060) 99 - - I,180*ANGLE/PI,XZPRT,YZPRT,REAL(TU(NU)),NU,ISTAT-MXWIRE 100 - ENDIF 101 - *** Plot the drift line obtained. 102 - IF(POLAR)CALL CF2RTC(XU,YU,XU,YU,NU) 103 - IF(NU.GT.1.AND.LLINPL)CALL GPL2(NU,XU,YU) 104 - 30 CONTINUE 105 - 20 CONTINUE 106 - 10 CONTINUE 107 - *** Register the amount of CPU time used for these steps. 108 - CALL TIMLOG('Drift-lines from the E=0 points: ') 109 - *** End this page. 110 - IF(LLINPL)CALL GRNEXT 111 - END 657 GARFIELD ================================================== P=DRIFT D=DRFEQT 1 ============================ 0 + +DECK,DRFEQT. 1 - SUBROUTINE DRFEQT(TSTEP,ISTEQT) 2 - *----------------------------------------------------------------------- 3 - * DRFEQT - The main routine (DRFEQT) accumulates equal drift time data 4 - * DRFEQP which is plotted as a set of contours in the entry DRFEQP, 5 - * DRFEQR DRFEQR resets the (error) counters used in the rest and 6 - * DRFEQE finally DRFEQE prints the error messages. 7 - * VARIABLES : NSTORE : Number of drift lines currently stored 8 - * NFAIL : Registers the number of failures. 9 - * XPL,YPL,ZPL : Used for sorting + plotting. 10 - * IXYPL : Drift line which gave this point. 11 - * XYT : Stores all equal time contours. 12 - * BREAK : .TRUE. if the segment is interrupted by a 13 - * drift line and if it is too long. 14 - * FRSTBR : The BREAK flag for the first segment. 15 - * (Last changed on 19/ 6/00.) 16 - *----------------------------------------------------------------------- 17 - implicit none 18.- +SEQ,DIMENSIONS. 19.- +SEQ,DRIFTLINE. 20.- +SEQ,CELLDATA. 21.- +SEQ,SOLIDS. 22.- +SEQ,PRINTPLOT. 23.- +SEQ,PARAMETERS. 24.- +SEQ,GRAPHICS. 25 - REAL TSTEP,TSTREF 26 - INTEGER IXYT(MXLINE),NXYT(MXLINE),NFAIL(4),IXYPL(MXLINE+1),IOS, 27 - - NWORD,INPCMP,NCMEMB,NCREM,INEXT,NWRT,IWRT,IFAIL,IWIRE,IEQT, 28 - - IPL,IBEGIN,ISTORE,JSTORE,NCFILE,JEQ,J1,J2,I,NPL,ISTEP, 29 - - NSTORE,NSTEP,JSTART,IAUX,IMAX,ISTEQT,NCSTAT 30 - DOUBLE PRECISION DIVDF2,XYT(MXLINE,0:MXEQUT+1,3),XPL(MXLINE+1), 31 - - YPL(MXLINE+1),ZPL(MXLINE+1),APL(MXLINE+1),XCOG,YCOG, 32 - - XAUX,YAUX,ZAUX,AAUX,SXX,SXY,SYY,CT,ST,DISTOT,DISMAX, 33 - - EPSX,EPSY,EPSZ 34 - LOGICAL BREAK,FRSTBR,CROSSD,EXMEMB,CIRCLE,DONE(MXLINE) 35 - CHARACTER*(MXINCH) STRING 36 - CHARACTER*(MXNAME) FILE 37 - CHARACTER*80 STATUS 38 - CHARACTER*29 REMARK 39 - CHARACTER*8 TIME,DATE,MEMBER 40 - EXTERNAL CROSSD,DIVDF2,INPCMP 0 41-+ +SELF,IF=SAVE. 42 - SAVE XYT,IXYT,NXYT,NSTORE,NFAIL,TSTREF 0 43-+ +SELF. 44 - DATA NSTORE/0/,NFAIL/0,0,0,0/,TSTREF/-1.0/ 45 - *** Main routine, identify if requested. 46 - IF(LIDENT)PRINT *,' /// ROUTINE DRFEQT ///' 47 - * Check that the drift line has enough steps. 48 - IF(NU.LT.3)RETURN 49 - * Increment the number of stored lines if there is still space. 50 - IF(NSTORE.GE.MXLINE)THEN 51 - NFAIL(4)=NFAIL(4)+1 52 - RETURN 53 - ENDIF 54 - NSTORE=NSTORE+1 55 - * Store the step size. 56 - TSTREF=TSTEP 57 - * Find the number of points to be stored, limited by MXEQUT. 58 - NSTEP=MIN(INT(TU(NU)/TSTEP),MXEQUT) 59 - * Interpolate (time,position) at start, end and regular t intervals. 60 - CALL PLACO3(XU(1),YU(1),ZU(1), 1 657 P=DRIFT D=DRFEQT 2 PAGE 980 61 - - XYT(NSTORE,0,1),XYT(NSTORE,0,2),XYT(NSTORE,0,3)) 62 - DO 10 ISTEP=1,NSTEP 63 - CALL PLACO3( 64 - - DIVDF2(XU,TU,NU,DBLE(ISTEP*TSTEP),1), 65 - - DIVDF2(YU,TU,NU,DBLE(ISTEP*TSTEP),1), 66 - - DIVDF2(ZU,TU,NU,DBLE(ISTEP*TSTEP),1), 67 - - XYT(NSTORE,ISTEP,1),XYT(NSTORE,ISTEP,2),XYT(NSTORE,ISTEP,3)) 68 - 10 CONTINUE 69 - CALL PLACO3(XU(NU),YU(NU),ZU(NU),XYT(NSTORE,NSTEP+1,1), 70 - - XYT(NSTORE,NSTEP+1,2),XYT(NSTORE,NSTEP+1,3)) 71 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFEQT DEBUG : Found '', 72 - - I4,'' points for drift line '',I4)') NSTEP,NSTORE 73 - * Store the number of points on this spline and the d.l. return code. 74 - NXYT(NSTORE)=NSTEP 75 - IXYT(NSTORE)=ISTEQT 76 - * Keep track of the largest (unconstrained by MXEQUT) # of contours. 77 - NFAIL(3)=MAX(NFAIL(3),INT(TU(NU)/TSTEP)) 78 - RETURN 79 - *** Now plot the data: entry DRFEQP. 80 - ENTRY DRFEQP 81 - IF(LIDENT)PRINT *,' /// ENTRY DRFEQP ///' 82 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFEQP DEBUG : Drawing '', 83 - - I4,'' contours, '',I4,'' drift lines.''/ 84 - - 26X,''Connection threshold: '',F10.3/ 85 - - 26X,''Aspect ratio threshold: '',F10.3/ 86 - - 26X,''Loop closing threshold: '',F10.3/ 87 - - 26X,''Sort contours: '',L10/ 88 - - 26X,''Check for crossings: '',L10/ 89 - - 26X,''Mark isochrone points: '',L10)') 90 - - NFAIL(3),NSTORE,EQTTHR,EQTASP,EQTCLS,LEQSRT,LEQCRS,LEQMRK 91 - ** Switch to plotting mode for equal time contours. 92 - CALL GRATTS('ISOCHRONES','POLYLINE') 93 - CALL GRATTS('ISOCHRONES','POLYMARKER') 94 - * Set tolerances. 95 - EPSX=1D-6*ABS(USERX1-USERX0) 96 - EPSY=1D-6*ABS(USERY1-USERY0) 97 - IF(EPSX.LT.1D-6)EPSX=1D-6 98 - IF(EPSY.LT.1D-6)EPSY=1D-6 99 - EPSZ=1D-6 100 - CALL EPSSET('SET',EPSX,EPSY,EPSZ) 101 - ** Loop over the equal time contours. 102 - DO 1000 IEQT=1,NFAIL(3) 103 - * Loop over the wires and over the solids. 104 - DO 1010 IWIRE=-20,2*MXWIRE+NSOLID 105 - IF((IWIRE.GT.-20.AND.IWIRE.LT.-15).OR. 106 - - (IWIRE.GT.-11.AND.IWIRE.LT.1).OR. 107 - - (IWIRE.GT.NWIRE.AND.IWIRE.LE.2*MXWIRE))GOTO 1010 108 - * Initial number of stored points. 109 - NPL=0 110 - * Loop over the drift lines, picking up the points when OK. 111 - DO 1020 ISTORE=1,NSTORE 112 - * Reject any undesirable combinations. 113 - IF(IXYT(ISTORE).NE.IWIRE.OR.IEQT.GT.NXYT(ISTORE))GOTO 1020 114 - * Copy the data of this contour and this wire into the plot vector. 115 - NPL=NPL+1 116 - XPL(NPL)=XYT(ISTORE,IEQT,1) 117 - YPL(NPL)=XYT(ISTORE,IEQT,2) 118 - ZPL(NPL)=XYT(ISTORE,IEQT,3) 119 - IXYPL(NPL)=ISTORE 120 - 1020 CONTINUE 121 - ** Plot the contour, skip if there are no points. 122 - IF(NPL.EQ.0)GOTO 1010 123 - * Skip sorting if not requested, if using markers, if only 1 point. 124 - IF((.NOT.LEQSRT).OR.LEQMRK.OR.NPL.EQ.1)THEN 125 - CIRCLE=.FALSE. 126 - GOTO 1340 127 - ENDIF 128 - * Sort contours on angle, first compute centre of gravity. 129 - XCOG=0 130 - YCOG=0 131 - DO 1210 J1=1,NPL 132 - XCOG=XCOG+XPL(J1) 133 - YCOG=YCOG+YPL(J1) 134 - 1210 CONTINUE 135 - XCOG=XCOG/REAL(NPL) 136 - YCOG=YCOG/REAL(NPL) 137 - * Compute angles wrt to the centre of gravity and principal axes. 138 - SXX=0 139 - SXY=0 140 - SYY=0 141 - DO 1220 J1=1,NPL 142 - SXX=SXX+(XPL(J1)-XCOG)**2 143 - SXY=SXY+(XPL(J1)-XCOG)*(YPL(J1)-YCOG) 144 - SYY=SYY+(YPL(J1)-YCOG)**2 145 - 1220 CONTINUE 146 - CT=COS(0.5*ATAN2(2*SXY,SXX-SYY)) 147 - ST=SIN(0.5*ATAN2(2*SXY,SXX-SYY)) 148 - * Evaluate dispersions around the principal axes. 149 - SXX=0 150 - SYY=0 151 - DO 1230 J1=1,NPL 152 - SXX=SXX+ABS(+CT*(XPL(J1)-XCOG)+ST*(YPL(J1)-YCOG)) 153 - SYY=SYY+ABS(-ST*(XPL(J1)-XCOG)+CT*(YPL(J1)-YCOG)) 154 - 1230 CONTINUE 155 - * Decide whether this is more linear or more circular. 156 - IF( ABS(SXX).GT.EQTASP*ABS(SYY).OR. 157 - - ABS(SYY).GT.EQTASP*ABS(SXX))THEN 158 - CIRCLE=.FALSE. 159 - ELSE 160 - CIRCLE=.TRUE. 161 - ENDIF 162 - * Set a sorting coordinate accordingly. 163 - DO 1240 J1=1,NPL 164 - IF(CIRCLE)THEN 165 - APL(J1)=ATAN2(YPL(J1)-YCOG,XPL(J1)-XCOG) 166 - ELSE 1 657 P=DRIFT D=DRFEQT 3 PAGE 981 167 - APL(J1)=CT*(XPL(J1)-XCOG)+ST*(YPL(J1)-YCOG) 168 - ENDIF 169 - 1240 CONTINUE 170 - * Sort the points (bubble sort). 171 - DO 1250 J1=1,NPL 172 - DO 1260 J2=J1+1,NPL 173 - IF(APL(J2).LT.APL(J1))THEN 174 - IAUX=IXYPL(J1) 175 - XAUX=XPL(J1) 176 - YAUX=YPL(J1) 177 - ZAUX=ZPL(J1) 178 - AAUX=APL(J1) 179 - IXYPL(J1)=IXYPL(J2) 180 - XPL(J1)=XPL(J2) 181 - YPL(J1)=YPL(J2) 182 - ZPL(J1)=ZPL(J2) 183 - APL(J1)=APL(J2) 184 - IXYPL(J2)=IAUX 185 - XPL(J2)=XAUX 186 - YPL(J2)=YAUX 187 - ZPL(J2)=ZAUX 188 - APL(J2)=AAUX 189 - ENDIF 190 - 1260 CONTINUE 191 - 1250 CONTINUE 192 - * For circles, pperhaps add the first point to the end of the list. 193 - IF(CIRCLE)THEN 194 - * Compute breakpoint, total distance and maximum distance. 195 - DISTOT=0 196 - DISMAX=SQRT((XPL(1)-XPL(NPL))**2+(YPL(1)-YPL(NPL))**2) 197 - IMAX=1 198 - DO 1270 J1=2,NPL 199 - DISTOT=DISTOT+SQRT((XPL(J1)-XPL(J1-1))**2+ 200 - - (YPL(J1)-YPL(J1-1))**2) 201 - IF(DISMAX.LT.SQRT((XPL(J1)-XPL(J1-1))**2+ 202 - - (YPL(J1)-YPL(J1-1))**2))THEN 203 - DISMAX=SQRT((XPL(J1)-XPL(J1-1))**2+ 204 - - (YPL(J1)-YPL(J1-1))**2) 205 - IMAX=J1 206 - ENDIF 207 - 1270 CONTINUE 208 - * If a true loop, close it. 209 - IF(DISMAX.LT.EQTCLS*DISTOT)THEN 210 - NPL=NPL+1 211 - XPL(NPL)=XPL(1) 212 - YPL(NPL)=YPL(1) 213 - ZPL(NPL)=ZPL(1) 214 - IXYPL(NPL)=IXYPL(1) 215 - * Otherwise shift the points to make a line. 216 - ELSEIF(IMAX.GT.1)THEN 217 - DO 1280 J1=1,NPL 218 - DONE(J1)=.FALSE. 219 - 1280 CONTINUE 220 - 1290 CONTINUE 221 - DO 1300 J1=1,NPL 222 - IF(.NOT.DONE(J1))THEN 223 - JSTART=J1 224 - GOTO 1310 225 - ENDIF 226 - 1300 CONTINUE 227 - GOTO 1330 228 - 1310 CONTINUE 229 - J2=JSTART 230 - J1=1+MOD(J2+IMAX-2,NPL) 231 - XAUX=XPL(J2) 232 - YAUX=YPL(J2) 233 - ZAUX=ZPL(J2) 234 - IAUX=IXYPL(J2) 235 - DO 1320 I=1,NPL 236 - XPL(J2)=XPL(J1) 237 - YPL(J2)=YPL(J1) 238 - ZPL(J2)=ZPL(J1) 239 - IXYPL(J2)=IXYPL(J1) 240 - DONE(J2)=.TRUE. 241 - IF(J1.EQ.JSTART)THEN 242 - XPL(J2)=XAUX 243 - YPL(J2)=YAUX 244 - ZPL(J2)=ZAUX 245 - IXYPL(J2)=IAUX 246 - DONE(J2)=.TRUE. 247 - GOTO 1290 248 - ENDIF 249 - J2=J1 250 - J1=1+MOD(J2+IMAX-2,NPL) 251 - 1320 CONTINUE 252 - 1330 CONTINUE 253 - CIRCLE=.FALSE. 254 - ELSE 255 - CIRCLE=.FALSE. 256 - ENDIF 257 - ENDIF 258 - ** Plot this contour. 259 - 1340 CONTINUE 260 - * Simply mark the contours if this was requested. 261 - IF(LEQMRK)THEN 262 - DO 1350 I=1,NPL 263 - XAUX=FPROJ(1,1)*XPL(I)+FPROJ(2,1)*YPL(I)+ 264 - - ZPL(I)*FPROJA/FPROJN 265 - YAUX=FPROJ(1,2)*XPL(I)+FPROJ(2,2)*YPL(I)+ 266 - - ZPL(I)*FPROJB/FPROJN 267 - ZAUX=FPROJ(1,3)*XPL(I)+FPROJ(2,3)*YPL(I)+ 268 - - ZPL(I)*FPROJC/FPROJN 269 - XPL(I)=XAUX 270 - YPL(I)=YAUX 271 - ZPL(I)=ZAUX 272 - 1350 CONTINUE 1 657 P=DRIFT D=DRFEQT 4 PAGE 982 273 - CALL PLAGPM(NPL,XPL,YPL,ZPL) 274 - GOTO 1010 275 - ENDIF 276 - ** Regular plotting. 277 - IBEGIN=1 278 - FRSTBR=.FALSE. 279 - DO 1070 IPL=1,NPL-1 280 - BREAK=.FALSE. 281 - * Reject contour segments which are long compared with AREA. 282 - IF( ABS(XPL(IPL+1)-XPL(IPL)).GT.(USERX1-USERX0)*EQTTHR.OR. 283 - - ABS(YPL(IPL+1)-YPL(IPL)).GT.(USERY1-USERY0)*EQTTHR) 284 - - BREAK=.TRUE. 285 - * Set the BREAK flag if it crosses some stored drift line segment. 286 - IF(LEQCRS.AND..NOT.BREAK)THEN 287 - DO 1080 JSTORE=1,NSTORE 288 - DO 1090 JEQ=0,MXEQUT 289 - IF(JEQ.GT.NXYT(JSTORE))GOTO 1090 290 - IF((IXYPL(IPL).EQ.JSTORE.OR.IXYPL(IPL+1).EQ.JSTORE).AND. 291 - - (JEQ.EQ.IEQT.OR.JEQ+1.EQ.IEQT))GOTO 1090 292 - BREAK=CROSSD( 293 - - XYT(JSTORE,JEQ ,1),XYT(JSTORE,JEQ ,2), 294 - - XYT(JSTORE,JEQ+1,1),XYT(JSTORE,JEQ+1,2), 295 - - XPL( IPL ),YPL( IPL ), 296 - - XPL( IPL+1 ),YPL( IPL+1 )) 297 - IF(BREAK)GOTO 1100 298 - 1090 CONTINUE 299 - 1080 CONTINUE 300 - 1100 CONTINUE 301 - ENDIF 302 - * If there has been a break, plot what we have already. 303 - IF(BREAK)THEN 304 - DO 1110 I=IBEGIN,IPL 305 - XAUX=FPROJ(1,1)*XPL(I)+FPROJ(2,1)*YPL(I)+ 306 - - ZPL(I)*FPROJA/FPROJN 307 - YAUX=FPROJ(1,2)*XPL(I)+FPROJ(2,2)*YPL(I)+ 308 - - ZPL(I)*FPROJB/FPROJN 309 - ZAUX=FPROJ(1,3)*XPL(I)+FPROJ(2,3)*YPL(I)+ 310 - - ZPL(I)*FPROJC/FPROJN 311 - XPL(I)=XAUX 312 - YPL(I)=YAUX 313 - ZPL(I)=ZAUX 314 - 1110 CONTINUE 315 - IF(IPL-IBEGIN.GE.1)THEN 316 - CALL PLAGPL(IPL-IBEGIN+1,XPL(IBEGIN),YPL(IBEGIN), 317 - - ZPL(IBEGIN)) 318 - ELSEIF(IBEGIN.NE.1.OR..NOT.CIRCLE)THEN 319 - CALL PLAGPM(1,XPL(IBEGIN),YPL(IBEGIN),ZPL(IBEGIN)) 320 - ELSEIF(IBEGIN.EQ.1)THEN 321 - FRSTBR=.TRUE. 322 - ENDIF 323 - IBEGIN=IPL+1 324 - ENDIF 325 - 1070 CONTINUE 326 - * Plot the remainder; if there is a break, put a * if FRSTBR is on. 327 - DO 1120 I=IBEGIN,NPL 328 - XAUX=FPROJ(1,1)*XPL(I)+FPROJ(2,1)*YPL(I)+ZPL(I)*FPROJA/FPROJN 329 - YAUX=FPROJ(1,2)*XPL(I)+FPROJ(2,2)*YPL(I)+ZPL(I)*FPROJB/FPROJN 330 - ZAUX=FPROJ(1,3)*XPL(I)+FPROJ(2,3)*YPL(I)+ZPL(I)*FPROJC/FPROJN 331 - XPL(I)=XAUX 332 - YPL(I)=YAUX 333 - ZPL(I)=ZAUX 334 - 1120 CONTINUE 335 - IF(.NOT.BREAK.AND.NPL-IBEGIN.GT.0)THEN 336 - CALL PLAGPL(NPL-IBEGIN+1,XPL(IBEGIN),YPL(IBEGIN), 337 - - ZPL(IBEGIN)) 338 - ELSEIF((FRSTBR.OR..NOT.CIRCLE).AND.IBEGIN.EQ.NPL)THEN 339 - CALL PLAGPM(1,XPL(IBEGIN),YPL(IBEGIN),ZPL(IBEGIN)) 340 - ENDIF 341 - * Continue with the next combination of wire number and time. 342 - 1010 CONTINUE 343 - 1000 CONTINUE 344 - * Reset tolerances. 345 - CALL EPSSET('RESET',EPSX,EPSY,EPSZ) 346 - ** Log this plot. 347 - CALL TIMLOG('Plotting equal time contours: ') 348 - RETURN 349 - *** Write out the data: entry DRFEQW. 350 - ENTRY DRFEQW 351 - * Identify the entry. 352 - IF(LIDENT)PRINT *,' /// ENTRY DRFEQW ///' 353 - * Check contour data is present. 354 - IF(NSTORE.LE.0.OR.TSTREF.LE.0.0)THEN 355 - PRINT *,' !!!!!! DRFEQW WARNING : No equal time data in'// 356 - - ' store; no dataset written.' 357 - RETURN 358 - ENDIF 359 - * Warn if the error codes are non-zero. 360 - IF(NFAIL(1).GT.0.OR.NFAIL(2).GT.0.OR. 361 - - NFAIL(3).GT.0.OR.NFAIL(4).GT.0)THEN 362 - PRINT *,' ------ DRFEQW MESSAGE : Error messages have'// 363 - - ' been issued for the contours to be written out.' 364 - ENDIF 365 - * Initial dataset description. 366 - FILE=' ' 367 - NCFILE=1 368 - MEMBER='< none >' 369 - NCMEMB=8 370 - REMARK='none' 371 - NCREM=4 372 - * Make sure there is at least one argument. 373 - CALL INPNUM(NWORD) 374 - IF(NWORD.EQ.1)THEN 375 - PRINT *,' !!!!!! DRFEQW WARNING : WRITE takes at least one', 376 - - ' argument (a dataset name); data will not be written.' 377 - RETURN 378 - * Check whether keywords have been used. 1 657 P=DRIFT D=DRFEQT 5 PAGE 983 379 - ELSEIF(INPCMP(2,'D#ATASET')+INPCMP(2,'R#EMARK').NE.0)THEN 380 - INEXT=2 381 - DO 1560 I=2,NWORD 382 - IF(I.LT.INEXT)GOTO 1560 383 - IF(INPCMP(I,'D#ATASET').NE.0)THEN 384 - IF(INPCMP(I+1,'R#EMARK').NE.0.OR.I+1.GT.NWORD)THEN 385 - CALL INPMSG(I,'The dataset name is missing. ') 386 - INEXT=I+1 387 - ELSE 388 - CALL INPSTR(I+1,I+1,STRING,NCFILE) 389 - FILE=STRING 390 - INEXT=I+2 391 - IF(INPCMP(I+2,'R#EMARK').EQ.0.AND. 392 - - I+2.LE.NWORD)THEN 393 - CALL INPSTR(I+2,I+2,STRING,NCMEMB) 394 - MEMBER=STRING 395 - INEXT=I+3 396 - ENDIF 397 - ENDIF 398 - ELSEIF(INPCMP(I,'R#EMARK').NE.0)THEN 399 - IF(INPCMP(I+1,'D#ATASET').NE.0.OR.I+1.GT.NWORD)THEN 400 - CALL INPMSG(I,'The remark is missing. ') 401 - INEXT=I+1 402 - ELSE 403 - CALL INPSTR(I+1,I+1,STRING,NCREM) 404 - REMARK=STRING 405 - INEXT=I+2 406 - ENDIF 407 - ELSE 408 - CALL INPMSG(I,'The parameter is not known. ') 409 - ENDIF 410 - 1560 CONTINUE 411 - * Otherwise the string is interpreted as a file name (+ member name). 412 - ELSE 413 - CALL INPSTR(2,2,STRING,NCFILE) 414 - FILE=STRING 415 - IF(NWORD.GE.3)THEN 416 - CALL INPSTR(3,3,STRING,NCMEMB) 417 - MEMBER=STRING 418 - ENDIF 419 - IF(NWORD.GE.4)THEN 420 - CALL INPSTR(4,NWORD,STRING,NCREM) 421 - REMARK=STRING 422 - ENDIF 423 - ENDIF 424 - * Print error messages. 425 - CALL INPERR 426 - IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! DRFEQW WARNING : The file', 427 - - ' name is truncated to MXNAME (=',MXNAME,') characters.' 428 - IF(NCMEMB.GT.8)PRINT *,' !!!!!! DRFEQW WARNING : The member', 429 - - ' name is shortened to ',MEMBER,', first 8 characters.' 430 - IF(NCREM.GT.29)PRINT *,' !!!!!! DRFEQW WARNING : The remark', 431 - - ' shortened to ',REMARK,', first 29 characters.' 432 - NCFILE=MIN(NCFILE,MXNAME) 433 - NCMEMB=MIN(NCMEMB,8) 434 - NCREM=MIN(NCREM,29) 435 - * Check whether the member already exists. 436 - CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'ISOCHRON',EXMEMB) 437 - IF(JEXMEM.EQ.2.AND.EXMEMB)THEN 438 - PRINT *,' ------ DRFEQW MESSAGE : A copy of the member'// 439 - - ' exists; new member will be appended.' 440 - ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN 441 - PRINT *,' !!!!!! DRFEQW WARNING : A copy of the member'// 442 - - ' exists already; member will not be written.' 443 - RETURN 444 - ENDIF 445 - * Print some debugging output if requested. 446 - IF(LDEBUG)THEN 447 - PRINT *,' ++++++ DRFEQW DEBUG : File= '//FILE(1:NCFILE)// 448 - - ', member= '//MEMBER(1:NCMEMB) 449 - PRINT *,' Remark= '//REMARK(1:NCREM) 450 - ENDIF 451 - *** Open the dataset for sequential write and inform DSNLOG. 452 - CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) 453 - IF(IFAIL.NE.0)THEN 454 - PRINT *,' !!!!!! DRFEQW WARNING : Opening '//FILE(1:NCFILE), 455 - - ' failed ; the isochrones will not be written.' 456 - RETURN 457 - ENDIF 458 - CALL DSNLOG(FILE,'Isochrones','Sequential','Write ') 459 - IF(LDEBUG)PRINT *,' ++++++ DRFEQW DEBUG : Dataset '// 460 - - FILE(1:NCFILE)//' opened on unit 12 for sequential write.' 461 - * Now write a heading record to the file. 462 - CALL DATTIM(DATE,TIME) 463 - WRITE(STRING,'(''% Created '',A8,'' At '',A8,1X,A8,'' ISOCHRON'', 464 - - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK 465 - WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING 466 - WRITE(12,'(2X,''Note: The coordinates listed below'', 467 - - '' have been re-converted''/2X,''from the internal'', 468 - - '' representation in which they were stored.''/)', 469 - - IOSTAT=IOS,ERR=2010) 470 - * Loop over the wires and the drift lines. 471 - DO 1500 IEQT=1,NFAIL(3) 472 - DO 1510 IWIRE=-20,2*MXWIRE+NSOLID 473 - IF((IWIRE.GT.-20.AND.IWIRE.LT.-15).OR. 474 - - (IWIRE.GT.-11.AND.IWIRE.LT.1).OR. 475 - - (IWIRE.GT.NWIRE.AND.IWIRE.LE.2*MXWIRE))GOTO 1510 476 - * Initial number of stored points. 477 - NWRT=0 478 - * Loop over the drift lines, picking up the points when OK. 479 - DO 1520 ISTORE=1,NSTORE 480 - * Reject any undesirable combinations. 481 - IF(IXYT(ISTORE).NE.IWIRE.OR.IEQT.GT.NXYT(ISTORE))GOTO 1520 482 - * Copy the data of this contour and this wire into the output vector. 483 - NWRT=NWRT+1 484 - XPL(NWRT)=XYT(ISTORE,IEQT,1) 1 657 P=DRIFT D=DRFEQT 6 PAGE 984 485 - YPL(NWRT)=XYT(ISTORE,IEQT,2) 486 - ZPL(NWRT)=XYT(ISTORE,IEQT,3) 487 - * Transform back to the original coordinate system. 488 - XAUX=FPROJ(1,1)*XPL(NWRT)+FPROJ(2,1)*YPL(NWRT)+ 489 - - ZPL(NWRT)*FPROJA/FPROJN 490 - YAUX=FPROJ(1,2)*XPL(NWRT)+FPROJ(2,2)*YPL(NWRT)+ 491 - - ZPL(NWRT)*FPROJB/FPROJN 492 - ZAUX=FPROJ(1,3)*XPL(NWRT)+FPROJ(2,3)*YPL(NWRT)+ 493 - - ZPL(NWRT)*FPROJC/FPROJN 494 - XPL(NWRT)=XAUX 495 - YPL(NWRT)=YAUX 496 - ZPL(NWRT)=ZAUX 497 - 1520 CONTINUE 498 - * Header for this combination. 499 - CALL DLCSTF(IWIRE,STATUS,NCSTAT) 500 - WRITE(12,'('' Drift line status: '',A/ 501 - - '' Drift time: '',E12.5,'' [microsec].''/ 502 - - '' Data points: '',I12/)',IOSTAT=IOS,ERR=2010) 503 - - STATUS(1:NCSTAT),TSTREF*IEQT,NWRT 504 - IF(NWRT.GT.0)THEN 505 - * Write out the list of points. 506 - IF(POLAR)THEN 507 - WRITE(12,'(11X,''r [cm]'',4X,''phi [degrees]'',11X, 508 - - ''z [cm]''/)',IOSTAT=IOS,ERR=2010) 509 - ELSE 510 - WRITE(12,'(11X,''x [cm]'',11X,''y [cm]'',11X, 511 - - ''z [cm]''/)',IOSTAT=IOS,ERR=2010) 512 - ENDIF 513 - WRITE(12,'((3(2X,E15.8)))',IOSTAT=IOS,ERR=2010) 514 - - (XPL(IWRT),YPL(IWRT),ZPL(IWRT),IWRT=1,NWRT) 515 - WRITE(12,'('' '')',IOSTAT=IOS,ERR=2010) 516 - ENDIF 517 - * Continue with the next combination of wire number and time. 518 - 1510 CONTINUE 519 - 1500 CONTINUE 520 - * Close the file. 521 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 522 - * Log writing. 523 - CALL TIMLOG('Writing out equal time contours: ') 524 - RETURN 525 - *** Print error messages, entry DRFEQE. 526 - ENTRY DRFEQE 527 - IF(LIDENT)PRINT *,' /// ENTRY DRFEQE ///' 528 - IF(NFAIL(1).NE.0)PRINT *,' ###### DRFEQT ERROR : Preparing'// 529 - - ' an equal time interpolation failed ',NFAIL(1),' times.' 530 - IF(NFAIL(2).NE.0)PRINT *,' ###### DRFEQT ERROR : Obtaining'// 531 - - ' an equal time interpolation failed ',NFAIL(2),' times.' 532 - * Print some error message in case of memory overflow. 533 - IF(NFAIL(3).GT.0)THEN 534 - PRINT *,' !!!!!! DRFEQT WARNING : With the time interval'// 535 - - ' you specified, ',NFAIL(3),' contours are generated.' 536 - PRINT *,' Increase MXEQUT by this'// 537 - - ' value and recompile, to have them all plotted.' 538 - ENDIF 539 - IF(NFAIL(4).GT.0)THEN 540 - PRINT *,' !!!!!! DRFEQT WARNING : MXLINE is smaller than'// 541 - - ' the number of drift lines (',NFAIL(4),') to be' 542 - PRINT *,' stored for eqaul time'// 543 - - ' contour plotting, increase MXLINE by this value.' 544 - ENDIF 545 - RETURN 546 - *** Reset the drift lines: entry DRFEQR. 547 - ENTRY DRFEQR 548 - IF(LIDENT)PRINT *,' /// ENTRY DRFEQR ///' 549 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFEQR DEBUG : Reset of'', 550 - - '' isochrone buffer.'')') 551 - NSTORE=0 552 - DO 1900 I=1,4 553 - NFAIL(I)=0 554 - 1900 CONTINUE 555 - RETURN 556 - *** Handle the error conditions. 557 - 2010 CONTINUE 558 - PRINT *,' ###### DRFEQW ERROR : Error while writing'// 559 - - ' to ',FILE(1:NCFILE),' via unit 12 ; no contours written.' 560 - CALL INPIOS(IOS) 561 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 562 - RETURN 563 - 2030 CONTINUE 564 - PRINT *,' ###### DRFEQW ERROR : Dataset '//FILE(1:NCFILE)// 565 - - ' unit 12 cannot be closed ; results not predictable' 566 - CALL INPIOS(IOS) 567 - END 658 GARFIELD ================================================== P=DRIFT D=DRFGRA 1 ============================ 0 + +DECK,DRFGRA. 1 - SUBROUTINE DRFGRA 2 - *----------------------------------------------------------------------- 3 - * DRFGRA - Subroutine that uses interactive graphics to do some 4 - * drift-line calculations. 5 - * (Last changed on 24/ 4/92.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,DRIFTLINE. 9.- +SEQ,CELLDATA. 10.- +SEQ,PARAMETERS. 11.- +SEQ,CONSTANTS. 12.- +SEQ,PRINTPLOT. 13 - CHARACTER*80 AUXSTR 14 - CHARACTER*200 CHSTR 15 - REAL XPL(2),YPL(2),XPOS,YPOS,Q,XSING,YSING,ANGLE 16 - INTEGER ITYPE 17 - LOGICAL STDSTR 18 - EXTERNAL STDSTR,INPCMP,INPTYP 1 658 P=DRIFT D=DRFGRA 2 PAGE 985 19-+ +SELF,IF=SAVE. 20 - SAVE NRETRY 21 - SAVE ICPET,ILPET1,ILPET2,IVPET,IPPET 22 - SAVE IWKLC,IWKCH,IWKVL,IWKPK,IWK 23 - SAVE IDEVLC,IDEVCH,IDEVVL,IDEVPK 0 24-+ +SELF. 25 - *** Initial parameter values, number of retries. 26 - DATA NRETRY/2/ 27 - * Promp/echo types. 28 - DATA ICPET/1/, ILPET1/1/, ILPET2/4/, IVPET/1/, IPPET/1/ 29 - * Device. 30 - DATA IDEVLC/1/, IDEVCH/1/, IDEVVL/1/, IDEVPK/1/ 31 - *** Check we are in interactive mode. 32 - IF(.NOT.STDSTR('INPUT'))THEN 33 - PRINT *,' !!!!!! DRFGRA WARNING : This instruction can'// 34 - - ' only be carried out in interactive mode.' 35 - RETURN 36 - ENDIF 37 - *** Make sure the level of GKS is sufficient. 38 - CALL GQLVKS(IERR,ILEV) 39 - IF(ILEV.LT.4)THEN 40 - PRINT *,' !!!!!! DRFGRA WARNING : The program has been'// 41 - - ' linked with a GKS of too low a level.' 42 - RETURN 43 - ENDIF 44 - *** Find an in/out workstation, first check operating state. 45 - CALL GQOPS(IOPSTA) 46 - * No active workstations. 47 - IF(IOPSTA.LT.3)THEN 48 - PRINT *,' !!!!!! DRFGRA WARNING : No active workstations'// 49 - - ' ; not executed.' 50 - RETURN 51 - ENDIF 52 - * Determine number of active workstations. 53 - CALL GQACWK(0,IERR,NACT,IWK) 54 - IWKREQ=-1 55 - DO 2 I=1,NACT 56 - CALL GQACWK(I,IERR,IDUM,IWK) 57 - * Locate one that has input facilities. 58 - CALL GQWKC(IWK,IERR1,ICONID,IWKTYP) 59 - CALL GQWKCA(IWKTYP,IERR2,IWKCAT) 60 - IF(IWKCAT.EQ.2)IWKREQ=IWK 61 - 2 CONTINUE 62 - * Issue an string request to an input workstation. 63 - IF(IWKREQ.EQ.-1)THEN 64 - PRINT *,' !!!!!! DRFGRA WARNING : No active workstations'// 65 - - ' with in/out facilities ; not executed.' 66 - RETURN 67 - ENDIF 68 - * Set default parameters. 69 - IWKLC=IWKREQ 70 - IWKCH=IWKREQ 71 - IWKVL=IWKREQ 72 - IWKPK=IWKREQ 73 - IWK=IWKREQ 74 - * Debugging output. 75 - IF(LDEBUG)PRINT *,' ++++++ DRFGRA DEBUG : Default ws for'// 76 - - ' this command is ',IWKREQ 77 - *** Initial parameters. 78 - Q=-1.0 79 - ITYPE=1 80 - *** Decode the argument string, if present. 81 - CALL INPNUM(NWORD) 82 - INEXT=2 83 - DO 10 I=2,NWORD 84 - IF(INEXT.GT.I)GOTO 10 85 - * Prompt echo type for choice input. 86 - IF(INPCMP(I,'CH#OICE-PET').NE.0)THEN 87 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN 88 - CALL INPMSG(I,'No prompt/echo type specified.') 89 - ELSE 90 - CALL INPCHK(I+1,1,IFAIL1) 91 - CALL INPRDI(I+1,ICPET,ICPET) 92 - INEXT=I+2 93 - ENDIF 94 - * Prompt echo type for locator input. 95 - ELSEIF(INPCMP(I,'LOC#ATOR-PET').NE.0)THEN 96 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1.OR. 97 - - INPTYP(I+2).NE.1)THEN 98 - CALL INPMSG(I,'Two prompt/echo types needed. ') 99 - ELSE 100 - CALL INPCHK(I+1,1,IFAIL1) 101 - CALL INPRDI(I+1,ILPET1,ILPET1) 102 - CALL INPCHK(I+2,1,IFAIL2) 103 - CALL INPRDI(I+2,ILPET2,ILPET2) 104 - INEXT=I+3 105 - ENDIF 106 - * Prompt echo type for valuator input. 107 - ELSEIF(INPCMP(I,'VAL#UATOR-PET').NE.0)THEN 108 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN 109 - CALL INPMSG(I,'No prompt/echo type specified.') 110 - ELSE 111 - CALL INPCHK(I+1,1,IFAIL1) 112 - CALL INPRDI(I+1,IVPET,IVPET) 113 - INEXT=I+2 114 - ENDIF 115 - * Prompt echo type for pick input. 116 - ELSEIF(INPCMP(I,'PICK-PET').NE.0)THEN 117 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN 118 - CALL INPMSG(I,'No prompt/echo type specified.') 119 - ELSE 120 - CALL INPCHK(I+1,1,IFAIL1) 121 - CALL INPRDI(I+1,IPPET,IPPET) 122 - INEXT=I+2 123 - ENDIF 1 658 P=DRIFT D=DRFGRA 3 PAGE 986 124 - * Workstation. 125 - ELSEIF(INPCMP(I,'W#ORK-ST#ATION').NE.0)THEN 126 - IF(NWORD.LT.I+1)THEN 127 - CALL INPMSG(I,'No workstation id specified. ') 128 - ELSE 129 - CALL INPSTR(I+1,I+1,AUXSTR,NCAUX) 130 - CALL GRQIWK(AUXSTR(1:NCAUX),IWK,IFAIL) 131 - IF(IFAIL.NE.0)THEN 132 - CALL INPMSG(I+1,'Not a valid workstation name. ') 133 - ELSE 134 - IWKCH=IWK 135 - IWKLC=IWK 136 - IWKVL=IWK 137 - IWKPK=IWK 138 - ENDIF 139 - INEXT=I+2 140 - ENDIF 141 - * Choice device. 142 - ELSEIF(INPCMP(I,'CH#OICE-DEV#ICE').NE.0)THEN 143 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN 144 - CALL INPMSG(I,'No device has been specified. ') 145 - ELSE 146 - CALL INPCHK(I+1,1,IFAIL1) 147 - CALL INPRDI(I+1,IDEVCH,1) 148 - INEXT=I+2 149 - ENDIF 150 - * Locator device. 151 - ELSEIF(INPCMP(I,'LOC#ATOR-DEV#ICE').NE.0)THEN 152 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN 153 - CALL INPMSG(I,'No device has been specified. ') 154 - ELSE 155 - CALL INPCHK(I+1,1,IFAIL1) 156 - CALL INPRDI(I+1,IDEVLC,1) 157 - INEXT=I+2 158 - ENDIF 159 - * Pick device. 160 - ELSEIF(INPCMP(I,'PICK-DEV#ICE').NE.0)THEN 161 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN 162 - CALL INPMSG(I,'No device has been specified. ') 163 - ELSE 164 - CALL INPCHK(I+1,1,IFAIL1) 165 - CALL INPRDI(I+1,IDEVPK,1) 166 - INEXT=I+2 167 - ENDIF 168 - * Valuator device. 169 - ELSEIF(INPCMP(I,'VAL#UATOR-DEV#ICE').NE.0)THEN 170 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN 171 - CALL INPMSG(I,'No device has been specified. ') 172 - ELSE 173 - CALL INPCHK(I+1,1,IFAIL1) 174 - CALL INPRDI(I+1,IDEVVL,1) 175 - INEXT=I+2 176 - ENDIF 177 - * Number of retries. 178 - ELSEIF(INPCMP(I,'RETR#IES').NE.0)THEN 179 - IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN 180 - CALL INPMSG(I,'Number of retries absent. ') 181 - ELSE 182 - CALL INPCHK(I+1,1,IFAIL1) 183 - CALL INPRDI(I+1,NRETRY,5) 184 - INEXT=I+2 185 - ENDIF 186 - * Unknown argument. 187 - ELSE 188 - CALL INPMSG(I,'Not a known keyword. ') 189 - ENDIF 190 - 10 CONTINUE 191 - CALL INPERR 192 - * Debugging output. 193 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFGRA DEBUG : Flags'', 194 - - '' currently in effect:''// 195 - - '' Choice : PET='',I2,'' , device='',I2,'', ws='',I2/ 196 - - '' Locator : PET='',I2,1X,I2,'', device='',I2,'', ws='',I2/ 197 - - '' Pick : PET='',I2,'' , device='',I2,'', ws='',I2/ 198 - - '' Valuator: PET='',I2,'' , device='',I2,'', ws='',I2// 199 - - '' Number of retries: '',I2/)') 200 - - ICPET,IDEVCH,IWKCH,ILPET1,ILPET2,IDEVLC,IWKLC, 201 - - IPPET,IDEVPK,IWKPK,IVPET,IDEVVL,IWKVL,NRETRY 202 - *** Check the workstation and obtain some information about it. 203 - CALL GQWKS(IWK,IERR,ISTATE) 204 - IF(IERR.NE.0.OR.ISTATE.NE.1)THEN 205 - PRINT *,' !!!!!! DRFGRA WARNING : The workstation over'// 206 - - ' which this command is run is not active.' 207 - RETURN 208 - ENDIF 209 - CALL GQWKC(IWK,IERR,ICONID,IWKTYP) 210 - IF(IERR.NE.0)THEN 211 - PRINT *,' !!!!!! DRFGRA WARNING : Unable to determine the'// 212 - - ' workstation type ; command not executed.' 213 - RETURN 214 - ENDIF 215 - CALL GQWKCA(IWKTYP,IERR,IWKCAT) 216 - IF(IERR.NE.0.OR.IWKCAT.NE.2)THEN 217 - PRINT *,' !!!!!! DRFGRA WARNING : The workstation over'// 218 - - ' which this command is run' 219 - PRINT *,' doesn''t have both'// 220 - - ' output and input facilities.' 221 - IF(LDEBUG)PRINT *,' ++++++ DRFGRA DEBUG : Category'// 222 - - ' of WS ',IWK,' is ',IWKCAT,' type is ',IWKTYP,'.' 223 - RETURN 224 - ENDIF 225 - CALL GQDSP(IWKTYP,ISTAT,IUNIT,RX,RY,LX,LY) 226 - IF(ISTAT.NE.0)THEN 227 - PRINT *,' !!!!!! DRFGRA WARNING : Unable to determine the'// 228 - - ' workstation window size ; command not executed.' 229 - RETURN 1 658 P=DRIFT D=DRFGRA 4 PAGE 987 230 - ENDIF 231 - *** And use them to set the various display areas. 232 - IF(RX.LT.1.4*RY)RY=RX/1.4 233 - * Locator. 234 - XLMIN=0.01*RX 235 - XLMAX=0.99*RY 236 - YLMIN=0.01*RY 237 - YLMAX=0.99*RY 238 - * Choice. 239 - XCMIN=0.91*RY 240 - XCMAX=0.99*RX 241 - YCMIN=0.10*RY 242 - YCMAX=0.90*RY 243 - * Valuator. 244 - XVMIN=1.05*RY 245 - XVMAX=0.99*RX 246 - YVMIN=0.05*RY 247 - YVMAX=0.15*RY 248 - * Pick. 249 - XPMIN=0.01*RX 250 - XPMAX=0.99*RY 251 - YPMIN=0.01*RY 252 - YPMAX=0.99*RY 253 - *** Plot the frame. 254 - CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, 255 - - ' ') 256 - CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) 257 - XSING=0.5*(DXMIN+DXMAX) 258 - YSING=0.5*(DYMIN+DYMAX) 259 - *** Ask what the user wants via a menu. 260 - 100 CONTINUE 261 - ICHOIC=2 262 - CALL GRMENU('Quit$Smaller AREA$Larger AREA$Set a new track$'// 263 - - 'Single drift-line$Drift from a wire$Drift from track$'// 264 - - 'Clean screen$Parameter menu','$',XCMIN,YCMIN,XCMAX,YCMAX, 265 - - IWKCH,IDEVCH,ICPET,ICHOIC,IFAIL) 266 - * Check the outcome of the menu. 267 - IF(IFAIL.NE.0)THEN 268 - CALL GRALOG('< graphics input screen > ') 269 - CALL GRNEXT 270 - PRINT *,' !!!!!! DRFGRA WARNING : Unable to extract a'// 271 - - ' value from the menu.' 272 - CALL TIMLOG('Drift section with graphics input. ') 273 - RETURN 274 - ENDIF 275 - *** Act accordingly, first the quit. 276 - IF(ICHOIC.EQ.1)THEN 277 - CALL GMSG(IWK,' ') 278 - CALL GRALOG('< graphics input screen > ') 279 - CALL GRNEXT 280 - CALL TIMLOG('Drift section with graphics input. ') 281 - RETURN 282 - ** Next the smaller AREA. 283 - ELSEIF(ICHOIC.EQ.2)THEN 284 - * Prompt the user for one edge point. 285 - CALL GMSG(IWK,'Please point to one edge.') 286 - * Initialise the LOCATOR to get the point. 287 - LSTR=0 288 - PX=DXMIN 289 - PY=DYMIN 290 - IF(POLAR)CALL CFMRTC(PX,PY,PX,PY,1) 291 - CALL GINLC(IWKLC,IDEVLC,1,PX,PY,ILPET1, 292 - - XLMIN,XLMAX,YLMIN,YLMAX,LSTR,AUXSTR) 293 - * Get the point. 294 - IRETRY=0 295 - 210 CONTINUE 296 - IRETRY=IRETRY+1 297 - CALL GRQLC(IWKLC,IDEVLC,IERR,NT,PX,PY) 298 - DXMINN=PX 299 - DYMINN=PY 300 - IF(POLAR)CALL CFMCTR(DXMINN,DYMINN,DXMINN,DYMINN,1) 301 - IF(NT.NE.1.OR.IERR.NE.1.OR.DXMINN.LT.DXMIN.OR. 302 - - DXMINN.GT.DXMAX.OR.DYMINN.LT.DYMIN.OR. 303 - - DYMINN.GT.DYMAX)THEN 304 - CALL GMSG(IWK,'Please point in the current AREA.') 305 - IF(IRETRY.LE.NRETRY)GOTO 210 306 - GOTO 100 307 - ENDIF 308 - * Prompt the user for the other edge point. 309 - CALL GMSG(IWK,'Please point to the opposite edge.') 310 - * Initialise the LOCATOR to get the point. 311 - LSTR=0 312 - CALL GINLC(IWKLC,IDEVLC,1,PX,PY,ILPET2, 313 - - XLMIN,XLMAX,YLMIN,YLMAX,LSTR,AUXSTR) 314 - * Get the point. 315 - IRETRY=0 316 - 220 CONTINUE 317 - IRETRY=IRETRY+1 318 - CALL GRQLC(IWKLC,IDEVLC,IERR,NT,PX,PY) 319 - DXMAXN=PX 320 - DYMAXN=PY 321 - IF(POLAR)CALL CFMCTR(DXMAXN,DYMAXN,DXMAXN,DYMAXN,1) 322 - IF(NT.NE.1.OR.IERR.NE.1.OR.DXMAXN.LT.DXMIN.OR. 323 - - DXMAXN.GT.DXMAX.OR.DYMAXN.LT.DYMIN.OR. 324 - - DYMAXN.GT.DYMAX)THEN 325 - CALL GMSG(IWK,'Please point in the current AREA.') 326 - IF(IRETRY.LE.NRETRY)GOTO 220 327 - GOTO 100 328 - ENDIF 329 - * Determine the new AREA. 330 - IF(DXMINN.EQ.DXMAXN.OR.DYMINN.EQ.DYMAXN)THEN 331 - CALL GMSG(IWK,'The new AREA is not valid.') 332 - ELSE 333 - DXMIN=MIN(DXMINN,DXMAXN) 334 - DXMAX=MAX(DXMINN,DXMAXN) 335 - DYMIN=MIN(DYMINN,DYMAXN) 1 658 P=DRIFT D=DRFGRA 5 PAGE 988 336 - DYMAX=MAX(DYMINN,DYMAXN) 337 - CALL GMSG(IWK,'Redrawing the axes') 338 - CALL GRALOG('< graphics input screen > ') 339 - CALL GRNEXT 340 - CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, 341 - - ' ') 342 - CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) 343 - XSING=0.5*(DXMIN+DXMAX) 344 - YSING=0.5*(DYMIN+DYMAX) 345 - ENDIF 346 - ** Next the bigger AREA. 347 - ELSEIF(ICHOIC.EQ.3)THEN 348 - * Prompt the user for the zoom factor. 349 - CALL GMSG(IWK,'Please enter the magnification factor.') 350 - * Initialise the VALUATOR. 351 - LSTR=0 352 - CALL GINVL(IWKVL,IDEVVL,5.0,IVPET,XVMIN,XVMAX,YVMIN,YVMAX, 353 - - 0.01,100.0,LSTR,AUXSTR) 354 - * Obtain the zoom factor. 355 - IRETRY=0 356 - 270 CONTINUE 357 - IRETRY=IRETRY+1 358 - CALL GRQVL(IWKVL,IDEVVL,IERR,ZOOM) 359 - IF(IERR.NE.1.OR.ZOOM.LE.0.0)THEN 360 - CALL GMSG(IWK, 361 - - 'Not a valid magnification, please try again.') 362 - IF(IRETRY.LE.NRETRY)GOTO 270 363 - GOTO 100 364 - ELSEIF(ABS(ZOOM-1.0).GE.1.0E-3)THEN 365 - AUX1=DXMIN 366 - AUX2=DXMAX 367 - DXMIN=AUX1-ABS(AUX2-AUX1)*(ZOOM-1.0)/2.0 368 - DXMAX=AUX2+ABS(AUX2-AUX1)*(ZOOM-1.0)/2.0 369 - AUX1=DYMIN 370 - AUX2=DYMAX 371 - DYMIN=AUX1-ABS(AUX2-AUX1)*(ZOOM-1.0)/2.0 372 - DYMAX=AUX2+ABS(AUX2-AUX1)*(ZOOM-1.0)/2.0 373 - CALL GMSG(IWK,'Redrawing the axes') 374 - CALL GRALOG('< graphics input screen > ') 375 - CALL GRNEXT 376 - CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, 377 - - ' ') 378 - CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) 379 - XSING=0.5*(DXMIN+DXMAX) 380 - YSING=0.5*(DYMIN+DYMAX) 381 - ENDIF 382 - ** New track. 383 - ELSEIF(ICHOIC.EQ.4)THEN 384 - * Plot the current track in a segment. 385 - IF(TRFLAG(1))THEN 386 - XPL(1)=XT0 387 - YPL(1)=YT0 388 - XPL(2)=XT1 389 - YPL(2)=YT1 390 - CALL GCRSG(2) 391 - CALL GRATTS('TRACK','POLYLINE') 392 - CALL GPL(2,XPL,YPL) 393 - CALL GCLSG 394 - ENDIF 395 - * Prompt the user for one end point. 396 - CALL GMSG(IWK,'Please point to one end point.') 397 - * Initialise the LOCATOR to get the point. 398 - LSTR=0 399 - CALL GINLC(IWKLC,IDEVLC,1,XT0,YT0,ILPET1, 400 - - XLMIN,XLMAX,YLMIN,YLMAX,LSTR,AUXSTR) 401 - * Get the point. 402 - IRETRY=0 403 - 230 CONTINUE 404 - IRETRY=IRETRY+1 405 - CALL GRQLC(IWKLC,IDEVLC,IERR,NT,PX,PY) 406 - IF(NT.NE.1.OR.IERR.NE.1)THEN 407 - CALL GMSG(IWK,'Please point in the current AREA.') 408 - IF(IRETRY.LE.NRETRY)GOTO 230 409 - GOTO 100 410 - ENDIF 411 - XT0N=PX 412 - YT0N=PY 413 - * Prompt the user for the other edge point. 414 - CALL GMSG(IWK,'Please point to the other end.') 415 - * Initialise the LOCATOR to get the point. 416 - LSTR=0 417 - CALL GINLC(IWKLC,IDEVLC,1,PX,PY,ILPET2, 418 - - XLMIN,XLMAX,YLMIN,YLMAX,LSTR,AUXSTR) 419 - * Get the point. 420 - IRETRY=0 421 - 240 CONTINUE 422 - IRETRY=IRETRY+1 423 - CALL GRQLC(IWKLC,IDEVLC,IERR,NT,PX,PY) 424 - IF(NT.NE.1.OR.IERR.NE.1)THEN 425 - CALL GMSG(IWK,'Please point in the current AREA.') 426 - IF(IRETRY.LE.NRETRY)GOTO 240 427 - GOTO 100 428 - ENDIF 429 - * Update the track. 430 - XT0=XT0N 431 - YT0=YT0N 432 - XT1=PX 433 - YT1=PY 434 - * Drop the segment storing the old track. 435 - IF(TRFLAG(1))CALL GDSG(2) 436 - TRFLAG(1)=.TRUE. 437 - ** Single drift-line. 438 - ELSEIF(ICHOIC.EQ.5)THEN 439 - * Prompt the user for the starting point. 440 - CALL GMSG(IWK,'Please point to the starting point.') 441 - * Initialise the LOCATOR to get the point. 1 658 P=DRIFT D=DRFGRA 6 PAGE 989 442 - LSTR=0 443 - XPOS=XSING 444 - YPOS=YSING 445 - IF(POLAR)CALL CFMRTC(XPOS,YPOS,XPOS,YPOS,1) 446 - CALL GINLC(IWKLC,IDEVLC,1,XPOS,YPOS,ILPET1, 447 - - XLMIN,XLMAX,YLMIN,YLMAX,LSTR,AUXSTR) 448 - * Get the point. 449 - IRETRY=0 450 - 250 CONTINUE 451 - IRETRY=IRETRY+1 452 - CALL GRQLC(IWKLC,IDEVLC,IERR,NT,PX,PY) 453 - XPOS=PX 454 - YPOS=PY 455 - IF(POLAR)CALL CFMCTR(XPOS,YPOS,XPOS,YPOS,1) 456 - IF(NT.NE.1.OR.IERR.NE.1.OR.XPOS.LT.DXMIN.OR.XPOS.GT.DXMAX 457 - - .OR.YPOS.LT.DYMIN.OR.YPOS.GT.DYMAX)THEN 458 - CALL GMSG(IWK,'Please point in the current AREA.') 459 - IF(IRETRY.LE.NRETRY)GOTO 250 460 - GOTO 100 461 - ENDIF 462 - XSING=XPOS 463 - YSING=YPOS 464 - CALL DLCALC(XPOS,YPOS,0.0,Q,ITYPE) 465 - IF(POLAR)CALL CF2RTC(XU,YU,XU,YU,NU) 466 - IF(ITYPE.EQ.2)THEN 467 - CALL GRATTS('ION-DRIFT-LINE','POLYLINE') 468 - ELSE 469 - CALL GRATTS('E-DRIFT-LINE','POLYLINE') 470 - ENDIF 471 - IF(NU.GE.2)CALL GPL2(NU,XU,YU) 472 - ** Drift-lines from a wire. 473 - ELSEIF(ICHOIC.EQ.6)THEN 474 - * Invite the user to point to one of the wires. 475 - CALL GMSG(IWK,'Please select a wire.') 476 - * Initialise the PICK device. 477 - LSTR=0 478 - CALL GINPK(IWKPK,IDEVPK,1,1,1,IPPET, 479 - - XPMIN,XPMAX,YPMIN,YPMAX,LSTR,AUXSTR) 480 - * Get the wire number. 481 - IRETRY=0 482 - 260 CONTINUE 483 - IRETRY=IRETRY+1 484 - CALL GRQPK(IWKPK,IDEVPK,IERR,ISGNA,IPCID) 485 - * Check the choice is valid. 486 - IF(IERR.NE.1.OR.IPCID.LE.0.OR.IPCID.GT.NWIRE)THEN 487 - CALL GMSG(IWK,'Invalid choice, please try again.') 488 - IF(IRETRY.LE.NRETRY)GOTO 260 489 - GOTO 100 490 - ELSEIF(-Q*E(IPCID).LT.0.AND.LREPSK)THEN 491 - CALL GMSG(IWK, 492 - - 'This wire attracts the particles, try again.') 493 - IF(IRETRY.LE.NRETRY)GOTO 260 494 - GOTO 100 495 - ENDIF 496 - * Get a reasonable distance from the wire. 497 - IF(-Q*E(IPCID).LT.0)THEN 498 - RDIST=0.51*RTRAP*D(IPCID) 499 - ELSE 500 - RDIST=0.51*D(IPCID) 501 - ENDIF 502 - * Figure out how many periods are covered by the present AREA. 503 - NXMIN=0 504 - NXMAX=0 505 - NYMIN=0 506 - NYMAX=0 507 - IF(PERX)THEN 508 - NXMIN=INT(DXMIN/SX)-1 509 - NXMAX=INT(DXMAX/SX)+1 510 - ENDIF 511 - IF(PERY)THEN 512 - NYMIN=INT(DYMIN/SY)-1 513 - NYMAX=INT(DYMAX/SY)+1 514 - ENDIF 515 - * Loop over the periods. 516 - DO 330 NX=NXMIN,NXMAX 517 - XPOS=X(IPCID)+NX*SX 518 - IF(XPOS.LE.DXMIN.OR.XPOS.GE.DXMAX)GOTO 330 519 - DO 320 NY=NYMIN,NYMAX 520 - YPOS=Y(IPCID)+NY*SY 521 - IF(YPOS.LE.DYMIN.OR.YPOS.GE.DYMAX)GOTO 320 522 - * Loop over the angles. 523 - DO 340 IANG=1,NLINED 524 - ANGLE=REAL(IANG)*2*PI/REAL(NLINED) 525 - CALL DLCALC(XPOS+RDIST*COS(ANGLE),YPOS+RDIST*SIN(ANGLE), 526 - - 0.0,-Q,ITYPE) 527 - IF(POLAR)CALL CF2RTC(XU,YU,XU,YU,NU) 528 - IF(ITYPE.EQ.2)THEN 529 - CALL GRATTS('ION-DRIFT-LINE','POLYLINE') 530 - ELSE 531 - CALL GRATTS('E-DRIFT-LINE','POLYLINE') 532 - ENDIF 533 - IF(NU.GE.2)CALL GPL2(NU,XU,YU) 534 - 340 CONTINUE 535 - 320 CONTINUE 536 - 330 CONTINUE 537 - ** Drift from the track. 538 - ELSEIF(ICHOIC.EQ.7)THEN 539 - IF(.NOT.TRFLAG(1))THEN 540 - CALL GMSG(IWK,'No track defined sofar.') 541 - GOTO 100 542 - ENDIF 543 - * Plot the track. 544 - XPL(1)=XT0 545 - YPL(1)=YT0 546 - XPL(2)=XT1 547 - YPL(2)=YT1 1 658 P=DRIFT D=DRFGRA 7 PAGE 990 548 - CALL GRATTS('TRACK','POLYLINE') 549 - CALL GPL(2,XPL,YPL) 550 - * And plot drift-lines. 551 - DO 300 I=1,NLINED 552 - XPOS=XT0+REAL(I-1)*(XT1-XT0)/REAL(NLINED-1) 553 - YPOS=YT0+REAL(I-1)*(YT1-YT0)/REAL(NLINED-1) 554 - IF(POLAR)CALL CFMCTR(XPOS,YPOS,XPOS,YPOS,1) 555 - CALL DLCALC(XPOS,YPOS,0.0,Q,ITYPE) 556 - IF(POLAR)CALL CF2RTC(XU,YU,XU,YU,NU) 557 - IF(ITYPE.EQ.2)THEN 558 - CALL GRATTS('ION-DRIFT-LINE','POLYLINE') 559 - ELSE 560 - CALL GRATTS('E-DRIFT-LINE','POLYLINE') 561 - ENDIF 562 - IF(NU.GE.2)CALL GPL2(NU,XU,YU) 563 - 300 CONTINUE 564 - ** Clear the page. 565 - ELSEIF(ICHOIC.EQ.8)THEN 566 - CALL GMSG(IWK,'Redrawing the axes.') 567 - CALL GRALOG('< graphics input screen > ') 568 - CALL GRNEXT 569 - CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, 570 - - ' ') 571 - CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) 572 - XSING=0.5*(DXMIN+DXMAX) 573 - YSING=0.5*(DYMIN+DYMAX) 574 - ** The parameter menu. 575 - ELSEIF(ICHOIC.EQ.9)THEN 576 - * Initialise the menu. 577 - 400 CONTINUE 578 - NC=1 579 - * Back to main menu. 580 - CHSTR(NC:NC+4)='Quit$' 581 - NC=NC+5 582 - * Switch particle type. 583 - IF(ITYPE.EQ.1)THEN 584 - CHSTR(NC:NC+10)='Drift ions$' 585 - NC=NC+11 586 - ELSE 587 - CHSTR(NC:NC+15)='Drift electrons$' 588 - NC=NC+16 589 - ENDIF 590 - * Switch particle charge. 591 - IF(Q.LE.0)THEN 592 - CHSTR(NC:NC+16)='Set charge to +1$' 593 - NC=NC+17 594 - ELSE 595 - CHSTR(NC:NC+16)='Set charge to -1$' 596 - NC=NC+17 597 - ENDIF 598 - * Number of drift-lines. 599 - CALL OUTFMT(REAL(NLINED),2,AUXSTR,NCAUX,'LEFT') 600 - CHSTR(NC:NC+18+NCAUX)= 601 - - 'Number of lines ['//AUXSTR(1:NCAUX)//']$' 602 - NC=NC+19+NCAUX 603 - * Trap radius. 604 - CALL OUTFMT(RTRAP,2,AUXSTR,NCAUX,'LEFT') 605 - CHSTR(NC:NC+14+NCAUX)='Trap radius ['//AUXSTR(1:NCAUX)//']$' 606 - NC=NC+15+NCAUX 607 - * Epsilon. 608 - CALL OUTFMT(EPSDIF,2,AUXSTR,NCAUX,'LEFT') 609 - CHSTR(NC:NC+11+NCAUX)='Accuracy ['//AUXSTR(1:NCAUX)//']$' 610 - NC=NC+12+NCAUX 611 - * Checking options. 612 - IF(LREPSK)THEN 613 - CHSTR(NC:NC+20)='Skip repelling wires$' 614 - NC=NC+21 615 - ELSE 616 - CHSTR(NC:NC+15)='Check all wires$' 617 - NC=NC+16 618 - ENDIF 619 - * Read the user request from the menu. 620 - ICHOIC=2 621 - CALL GRMENU(CHSTR(1:NC-1),'$',XCMIN,YCMIN,XCMAX,YCMAX, 622 - - IWKCH,IDEVCH,ICPET,ICHOIC,IFAIL) 623 - * Check the return code. 624 - IF(IFAIL.NE.0)THEN 625 - CALL GRALOG('< graphics input screen > ') 626 - CALL GRNEXT 627 - PRINT *,' !!!!!! DRFGRA WARNING : Unable to read a'// 628 - - ' choice with secondary menu.' 629 - CALL TIMLOG('Drift section with graphics input. ') 630 - RETURN 631 - ENDIF 632 - * Act according to the choice, first back to the main menu. 633 - IF(ICHOIC.EQ.1)THEN 634 - GOTO 100 635 - * Particle type. 636 - ELSEIF(ICHOIC.EQ.2)THEN 637 - ITYPE=3-ITYPE 638 - * Charge. 639 - ELSEIF(ICHOIC.EQ.3)THEN 640 - Q=-Q 641 - * Number of drift-lines. 642 - ELSEIF(ICHOIC.EQ.4)THEN 643 - CALL GMSG(IWK, 644 - - 'Please enter the new number of drift-lines.') 645 - * Initialise the VALUATOR. 646 - LSTR=0 647 - CALL GINVL(IWKVL,IDEVVL,REAL(NLINED),IVPET, 648 - - XVMIN,XVMAX,YVMIN,YVMAX,2.0,100.0,LSTR,AUXSTR) 649 - * Obtain the NLINED number. 650 - CALL GRQVL(IWKVL,IDEVVL,IERR,AUX) 651 - IF(IERR.NE.1.OR.AUX.LE.2.0.OR.AUX.GE.100.0)THEN 652 - CALL GMSG(IWK, 653 - - 'Not a valid number of drift-lines.') 1 658 P=DRIFT D=DRFGRA 8 PAGE 991 654 - ELSE 655 - NLINED=INT(AUX) 656 - ENDIF 657 - * Trap radius. 658 - ELSEIF(ICHOIC.EQ.5)THEN 659 - CALL GMSG(IWK, 660 - - 'Please enter the new trapping radius.') 661 - * Initialise the VALUATOR. 662 - LSTR=0 663 - CALL GINVL(IWKVL,IDEVVL,RTRAP,IVPET, 664 - - XVMIN,XVMAX,YVMIN,YVMAX,1.0,100.0,LSTR,AUXSTR) 665 - * Obtain the trap radius. 666 - CALL GRQVL(IWKVL,IDEVVL,IERR,AUX) 667 - IF(IERR.NE.1.OR.AUX.LE.1.0.OR.AUX.GE.100.0)THEN 668 - CALL GMSG(IWK,'Not a valid trapping radius.') 669 - ELSE 670 - RTRAP=AUX 671 - ENDIF 672 - * Epsilon. 673 - ELSEIF(ICHOIC.EQ.6)THEN 674 - CALL GMSG(IWK, 675 - - 'Please enter the new accuracy.') 676 - * Initialise the VALUATOR. 677 - LSTR=0 678 - CALL GINVL(IWKVL,IDEVVL,EPSDIF,IVPET, 679 - - XVMIN,XVMAX,YVMIN,YVMAX,1.0E-10,1.0,LSTR,AUXSTR) 680 - * Obtain the accuracy parameter. 681 - CALL GRQVL(IWKVL,IDEVVL,IERR,AUX) 682 - IF(IERR.NE.1.OR.AUX.LE.0.0)THEN 683 - CALL GMSG(IWK,'Not a valid accuracy.') 684 - ELSE 685 - EPSDIF=AUX 686 - ENDIF 687 - * Skip/check of repelling wires. 688 - ELSEIF(ICHOIC.EQ.7)THEN 689 - LREPSK=.NOT.LREPSK 690 - * Any other choice. 691 - ELSE 692 - CALL GMSG(IWK,'Invalid choice, please try again.') 693 - ENDIF 694 - GOTO 400 695 - ** Something unknown. 696 - ELSE 697 - CALL GMSG(IWK,'Invalid choice, try again.') 698 - ENDIF 699 - *** Return for a new cycle. 700 - GOTO 100 701 - END 659 GARFIELD ================================================== P=DRIFT D=DRFPLT 1 ============================ 0 + +DECK,DRFPLT. 1 - SUBROUTINE DRFPLT 2 - *----------------------------------------------------------------------- 3 - * DRFPLT - Subroutine plotting the electric field, the magnetic field 4 - * and the potential in a variety of ways: histograms, contour 5 - * plots, vector plots and surface plots. 6 - * Variables : XPL,YPL : Used for plotting lines 7 - * FUNCT. : Stores the function text the plots 8 - * VAR : Array of input values for ALGEXE 9 - * GRID : Array of 'hights' for surface plots 10 - * COORD : Contains the ordinate of the graph data 11 - * VALUE : Contains the function values of the graph 12 - * HIST : Stores the histogram 13 - * CMIN,CMAX : Range of contour heights 14 - * HMIN,HMAX : Range in the histogram 15 - * NCHA : Number of bins in the histogram. 16 - * FLAG : Logicals used for parsing the command 17 - * LHIST ... : Determines whether the plot will be made 18 - * PHI,THETA : Viewing angle for 3-dimensional plots. 19 - * (Last changed on 12/ 2/99.) 20 - *----------------------------------------------------------------------- 21 - implicit none 22.- +SEQ,DIMENSIONS. 23.- +SEQ,CONSTANTS. 24.- +SEQ,CELLDATA. 25.- +SEQ,GASDATA. 26.- +SEQ,PARAMETERS. 27.- +SEQ,GRAPHICS. 28.- +SEQ,PRINTPLOT. 29.- +SEQ,BFIELD. 30.- +SEQ,DRIFTLINE. 31 - DOUBLE PRECISION F0(3),XPOS1,YPOS1,XPOS2,YPOS2 32 - REAL COORD(MXLIST),VALUE(MXLIST),RES(5),VAR(MXVAR), 33 - - HMIN,HMAX,GRSMIN,GRSMAX,RT0,RT1,PT0,PT1,XPOS,YPOS,ZPOS, 34 - - FACNRM,VOLT,CMIN,CMAX,QPLT,THETA,PHI,GMINR,GMAXR, 35 - - HMINR,HMAXR,CMINR,CMAXR,XXPOS,YYPOS,VXMIN,VYMIN,VXMAX,VYMAX 36 - INTEGER NCHA,NCONT,NGRPNT,MODVAR(MXVAR),MODRES(5),NCTOT,ILOC, 37 - - ISURF,IVECT1,IVECT2,IVECT3,IHIST,IFLAT,ICHK,JCHK,IHISRF, 38 - - NREXP,I,J, 39 - - INEXT,NWORD,IFAIL1,IFAIL2,NPNTR,NC1,NC2,NC3,NC4,NC5,II, 40 - - INPCMP,NCFTRA,ITYPE,IFAIL,IENTRA,ICOORD,NCHAR,NRES,NCAUX, 41 - - NCONTR,NCONTP,IENTRY,NCAUX1,NCAUX2,NCAUX3,NCAUX4 42 - CHARACTER*(MXCHAR) STRING,FUNCT1,FUNCT2,FUNCT3,FUNCT4,FUNCT5, 43 - - FUNTRA 44 - CHARACTER*20 AUX1,AUX2,AUX3,AUX4 45 - CHARACTER*10 VARLIS(MXVAR) 46 - LOGICAL USE(MXVAR),FLAG(MXWORD+5), 47 - - EVALE,EVALB,EVALV,EVALT,EVALD,EVALA,EVALL,EVALP, 48 - - LHIST,LVECT,LGRAPH,LCONT,LSURF,CAUTO,HAUTO,CLAB,LGRPRT, 49 - - LMCDR 50 - EXTERNAL INPCMP,DCONT 51 - COMMON /CN2DAT/ IENTRY,EVALE,EVALB,EVALV,EVALT,EVALD,EVALA,EVALL, 52 - - EVALP,QPLT,ITYPE,LMCDR 1 659 P=DRIFT D=DRFPLT 2 PAGE 992 53-+ +SELF,IF=NAG. 54 - DOUBLE PRECISION WS,DUM 55 - COMMON /MATRIX/ WS(MXWIRE,MXWIRE),CHTS(MXWIRE),DUM(3*MXWIRE+3) 0 56-+ +SELF,IF=HIGZ. 57 - REAL WS,PAR,DUM,SMIN,SMAX 58 - COMMON /MATRIX/ WS(MXWIRE,MXWIRE),PAR(37), 59 - - DUM(MXWIRE**2+8*MXWIRE-31) 0 60-+ +SELF,IF=SAVE. 61 - SAVE VARLIS,HMIN,HMAX,NCHA,NCONT,NGRPNT,PHI,THETA,LGRPRT 0 62-+ +SELF. 63 - DATA (VARLIS(I),I=1,24) /'X ','Y ','EX ', 64 - - 'EY ','EZ ','E ','BX ', 65 - - 'BY ','BZ ','B ','VDX ', 66 - - 'VDY ','VDZ ','VD ','LORENTZ ', 67 - - 'TIME ','PATH ','DIFFUSION ','AVALANCHE ', 68 - - 'LOSS ','STATUS ','P ','Z ', 69 - - 'T '/ 70 - DATA HMIN,HMAX /0.0,10000.0/ 71 - DATA NCONT/21/ 72 - DATA NGRPNT/MXLIST/,LGRPRT/.FALSE./ 73 - DATA NCHA/100/ 74 - DATA PHI,THETA/30.0,60.0/ 75 - *** Define an output format. 76 - 1010 FORMAT(26X,A10,L2,3X,A20,2X,I2,2(2X,E10.3),2(2X,I6),2(2X,E10.3)) 77 - *** Identify the routine. 78 - IF(LIDENT)PRINT *,' /// ROUTINE DRFPLT ///' 79 - *** Preset the options, function strings etc, 80 - FUNCT1=' ' 81 - FUNCT2=' ' 82 - FUNCT3=' ' 83 - FUNCT4=' ' 84 - FUNCT5=' ' 85 - LGRAPH=.FALSE. 86 - LSURF=.FALSE. 87 - LVECT=.FALSE. 88 - LHIST=.FALSE. 89 - LCONT=.FALSE. 90 - FUNTRA='?' 91 - NCFTRA=1 92 - CMIN=0.0 93 - CMAX=10000.0 94 - CAUTO=.TRUE. 95 - CLAB=.TRUE. 96 - HAUTO=.TRUE. 97 - GRSMIN=1 98 - GRSMAX=-1 99 - LMCDR=.FALSE. 100 - *** Drift line options. 101 - QPLT=-1.0 102 - ITYPE=1 103 - *** Make sure the variables have appropriate names 104 - IF(POLAR)THEN 105 - VARLIS(1)='R ' 106 - VARLIS(2)='PHI ' 107 - VARLIS(3)='ER ' 108 - VARLIS(4)='EPHI ' 109 - VARLIS(7)='BR ' 110 - VARLIS(8)='BPHI ' 111 - VARLIS(11)='VDR ' 112 - VARLIS(12)='VDPHI ' 113 - ELSE 114 - VARLIS(1)='X ' 115 - VARLIS(2)='Y ' 116 - VARLIS(3)='EX ' 117 - VARLIS(4)='EY ' 118 - VARLIS(7)='BX ' 119 - VARLIS(8)='BY ' 120 - VARLIS(11)='VDX ' 121 - VARLIS(12)='VDY ' 122 - ENDIF 123 - *** Examine the input, first step is finding out where the keywords are. 124 - CALL INPNUM(NWORD) 125 - DO 10 I=1,MXWORD+5 126 - IF(I.EQ.1.OR.I.GT.NWORD)THEN 127 - FLAG(I)=.TRUE. 128 - ELSEIF(INPCMP(I,'A#NGLES')+INPCMP(I,'AUTO#MATIC')+ 129 - - INPCMP(I,'BI#NS')+INPCMP(I,'SC#ALE')+ 130 - - INPCMP(I,'PR#INT')+INPCMP(I,'NOPR#INT')+ 131 - - INPCMP(I,'C#ONTOUR')+INPCMP(I,'G#RAPH')+ 132 - - INPCMP(I,'H#ISTOGRAM')+INPCMP(I,'N')+ 133 - - INPCMP(I,'LAB#ELS')+INPCMP(I,'NOLAB#ELS')+ 134 - - INPCMP(I,'RA#NGE')+INPCMP(I,'S#URFACE')+ 135 - - INPCMP(I,'VE#CTOR')+INPCMP(I,'ON')+ 136 - - INPCMP(I,'EL#ECTRON')+INPCMP(I,'ION')+ 137 - - INPCMP(I,'POS#ITIVE')+INPCMP(I,'NEG#ATIVE')+ 138 - - INPCMP(I,'M#ONTE-C#ARLO-#DRIFT-#LINES')+ 139 - - INPCMP(I,'MC-#DRIFT-#LINES')+ 140 - - INPCMP(I,'NOM#ONTE-C#ARLO-#DRIFT-#LINES')+ 141 - - INPCMP(I,'NOMC-#DRIFT-#LINES')+ 142 - - INPCMP(I,'RUN#GE-K#UTTA-#DRIFT-#LINES')+ 143 - - INPCMP(I,'RKF-#DRIFT-#LINES').NE.0)THEN 144 - FLAG(I)=.TRUE. 145 - ELSE 146 - FLAG(I)=.FALSE. 147 - ENDIF 148 - 10 CONTINUE 149 - *** Start a loop over the list, 150 - INEXT=1 151 - DO 20 I=2,NWORD 152 - IF(I.LT.INEXT)GOTO 20 153 - * warn if the user uses a sub-keyword out of context. 154 - IF(INPCMP(I,'RA#NGE')+INPCMP(I,'N')+INPCMP(I,'BI#NS')+ 155 - - INPCMP(I,'LAB#ELS')+INPCMP(I,'NOLAB#ELS')+ 1 659 P=DRIFT D=DRFPLT 3 PAGE 993 156 - - INPCMP(I,'A#NGLES')+INPCMP(I,'AUTO#MATIC')+ 157 - - INPCMP(I,'PR#INT')+INPCMP(I,'NOPR#INT')+ 158 - - INPCMP(I,'ON')+INPCMP(I,'SC#ALE').NE.0)THEN 159 - CALL INPMSG(I,'Valid option out of context. ') 160 - IF(.NOT.FLAG(I+1))THEN 161 - CALL INPMSG(I+1,'See the previous message. ') 162 - INEXT=I+2 163 - IF(.NOT.FLAG(I+2))THEN 164 - CALL INPMSG(I+2,'See the previous messages. ') 165 - INEXT=I+3 166 - ENDIF 167 - ENDIF 168 - * warn if an unknown keywords appear, 169 - ELSEIF(.NOT.FLAG(I))THEN 170 - CALL INPMSG(I,'Item is not a known keyword. ') 171 - ** Find out whether a GRAPH is requested next, 172 - ELSEIF(INPCMP(I,'G#RAPH').NE.0)THEN 173 - * Plot already requested ? 174 - IF(LGRAPH)PRINT *,' !!!!!! DRFPLT WARNING : Only one'// 175 - - ' graph per PLOT statement can be processed.' 176 - LGRAPH=.TRUE. 177 - * Store the function string. 178 - IF(FLAG(I+1))THEN 179 - FUNCT1(1:1)='VD' 180 - NC1=2 181 - INEXT=I+1 182 - ELSE 183 - CALL INPSTR(I+1,I+1,STRING,NC1) 184 - FUNCT1(1:NC1)=STRING(1:NC1) 185 - INEXT=I+2 186 - ENDIF 187 - * Look for sub-keywords with GRAPH. 188 - DO 230 II=I,NWORD 189 - IF(II.LT.INEXT)GOTO 230 190 - * Look for the subkeyword ON. 191 - IF(INPCMP(II,'ON').NE.0)THEN 192 - IF(FLAG(II+1))THEN 193 - CALL INPMSG(II,'The curve function is absent. ') 194 - ELSE 195 - CALL INPSTR(II+1,II+1,FUNTRA,NCFTRA) 196 - INEXT=II+2 197 - ENDIF 198 - * Look for the subkeyword N. 199 - ELSEIF(INPCMP(II,'N').NE.0)THEN 200 - IF(FLAG(II+1))THEN 201 - CALL INPMSG(II,'number of points is missing. ') 202 - ELSE 203 - CALL INPCHK(II+1,1,IFAIL1) 204 - CALL INPRDI(II+1,NPNTR,NGRPNT) 205 - IF(NPNTR.LT.2.AND.IFAIL1.EQ.0)CALL INPMSG(II+1, 206 - - 'number of point less than 2. ') 207 - IF(NPNTR.GT.MXLIST.AND.IFAIL1.EQ.0)CALL INPMSG 208 - - (II+1,'number of points > MXLIST. ') 209 - IF(NPNTR.GE.2.AND.NPNTR.LE.MXLIST)NGRPNT=NPNTR 210 - INEXT=II+2 211 - ENDIF 212 - * Look for print options. 213 - ELSEIF(INPCMP(II,'PR#INT').NE.0)THEN 214 - LGRPRT=.TRUE. 215 - INEXT=II+1 216 - ELSEIF(INPCMP(II,'NOPR#INT').NE.0)THEN 217 - LGRPRT=.FALSE. 218 - INEXT=II+1 219 - * Scale of the graph. 220 - ELSEIF(INPCMP(II,'SC#ALE')+INPCMP(II,'RA#NGE').NE.0)THEN 221 - IF(FLAG(II+1).OR.FLAG(II+2))THEN 222 - CALL INPMSG(II,'the arguments are missing. ') 223 - ELSE 224 - CALL INPCHK(II+1,2,IFAIL1) 225 - CALL INPRDR(II+1,GMINR,+1.0) 226 - CALL INPCHK(II+2,2,IFAIL2) 227 - CALL INPRDR(II+2,GMAXR,-1.0) 228 - IF(GMINR.EQ.GMAXR)THEN 229 - CALL INPMSG(II+1,'zero range in the') 230 - CALL INPMSG(II+2,'scale not permitted') 231 - ELSE 232 - GRSMIN=MIN(GMINR,GMAXR) 233 - GRSMAX=MAX(GMINR,GMAXR) 234 - ENDIF 235 - INEXT=II+3 236 - ENDIF 237 - * Otherwise skip to the next keyword. 238 - ELSE 239 - GOTO 20 240 - ENDIF 241 - 230 CONTINUE 242 - ** Find out whether a CONTOUR plot is requested next, 243 - ELSEIF(INPCMP(I,'C#ONTOUR').NE.0)THEN 244 - IF(LCONT)PRINT *,' !!!!!! DRFPLT WARNING : Only one'// 245 - - ' contour plot per PLOT statement can be processed.' 246 - LCONT=.TRUE. 247 - * Store the function string, using the default if absent. 248 - IF(FLAG(I+1))THEN 249 - FUNCT2(1:1)='VD' 250 - NC2=2 251 - INEXT=I+1 252 - ELSE 253 - CALL INPSTR(I+1,I+1,STRING,NC2) 254 - FUNCT2(1:NC2)=STRING(1:NC2) 255 - INEXT=I+2 256 - ENDIF 257 - * Set default values for the range, depending on the function. 258 - CMIN=0.0 259 - CMAX=10000.0 260 - * Look for sub-keywords with CONTOUR. 261 - DO 210 II=I+1,NWORD 1 659 P=DRIFT D=DRFPLT 4 PAGE 994 262 - IF(II.LT.INEXT)GOTO 210 263 - * LABELing of the contours. 264 - IF(INPCMP(II,'LAB#ELS').NE.0)THEN 265 - CLAB=.TRUE. 266 - INEXT=II+1 267 - ELSEIF(INPCMP(II,'NOLAB#ELS').NE.0)THEN 268 - CLAB=.FALSE. 269 - INEXT=II+1 270 - * The RANGE subkeyword. 271 - ELSEIF(INPCMP(II,'RA#NGE').NE.0)THEN 272 - IF(INPCMP(II+1,'AUTO#MATIC').NE.0)THEN 273 - CMIN=0.0 274 - CMAX=0.0 275 - CAUTO=.TRUE. 276 - INEXT=II+2 277 - ELSEIF((.NOT.FLAG(II+1)).AND.FLAG(II+2))THEN 278 - CALL INPCHK(II+1,2,IFAIL1) 279 - CALL INPRDR(II+1,CMINR,CMIN) 280 - CMIN=CMINR 281 - CMAX=CMINR 282 - CAUTO=.FALSE. 283 - INEXT=II+2 284 - ELSEIF((.NOT.FLAG(II+1)).AND.(.NOT.FLAG(II+2)))THEN 285 - CALL INPCHK(II+1,2,IFAIL1) 286 - CALL INPCHK(II+2,2,IFAIL2) 287 - CALL INPRDR(II+1,CMINR,CMIN) 288 - CALL INPRDR(II+2,CMAXR,CMAX) 289 - CMIN=MIN(CMINR,CMAXR) 290 - CMAX=MAX(CMINR,CMAXR) 291 - CAUTO=.FALSE. 292 - INEXT=II+3 293 - ELSE 294 - CALL INPMSG(II,'RANGE takes two arguments. ') 295 - IF(FLAG(II+1))THEN 296 - INEXT=II+1 297 - ELSE 298 - CALL INPMSG(II+1, 299 - - 'Ignored, see previous message.') 300 - INEXT=II+2 301 - ENDIF 302 - ENDIF 303 - * Sub keyword N. 304 - ELSEIF(INPCMP(II,'N').NE.0)THEN 305 - IF(FLAG(II+1))THEN 306 - CALL INPMSG(II,'N must have an argument. ') 307 - INEXT=II+1 308 - ELSE 309 - CALL INPCHK(II+1,1,IFAIL1) 310 - CALL INPRDI(II+1,NCONTR,NCONT) 311 - IF(NCONTR.LT.0.AND.IFAIL1.EQ.0)CALL INPMSG(II+1, 312 - - 'number of contour steps is < 0') 313 - IF(NCONTR.GT.MXWIRE.AND.IFAIL1.EQ.0)CALL INPMSG 314 - - (II+1,'may not exceed MXWIRE. ') 315 - IF(NCONTR.GE.0.AND.NCONTR.LE.MXWIRE)NCONT=NCONTR 316 - INEXT=II+2 317 - ENDIF 318 - * Otherwise skip to the next keyword. 319 - ELSE 320 - GOTO 20 321 - ENDIF 322 - 210 CONTINUE 323 - ** A SURFACE (3 dimensional plot) has perhaps been requested, 324 - ELSEIF(INPCMP(I,'S#URFACE').NE.0)THEN 325 - IF(LSURF)PRINT *,' !!!!!! DRFPLT WARNING : Only one'// 326 - - ' surface per PLOT statement can be processed.' 327 - LSURF=.TRUE. 328 - IF(FLAG(I+1))THEN 329 - FUNCT3(1:1)='VD' 330 - NC3=2 331 - INEXT=I+1 332 - ELSE 333 - CALL INPSTR(I+1,I+1,STRING,NC3) 334 - FUNCT3(1:NC3)=STRING(1:NC3) 335 - INEXT=I+2 336 - ENDIF 337 - * Look for sub-keywords with SURFACE. 338 - DO 220 II=I,NWORD 339 - IF(II.LT.INEXT)GOTO 220 340 - * Look for the subkeyword ANGLE. 341 - IF(INPCMP(II,'A#NGLES').NE.0)THEN 342 - IF(.NOT.FLAG(II+1).AND.FLAG(II+2))THEN 343 - CALL INPMSG(II,'ANGLE has 2 args: theta, phi. ') 344 - CALL INPMSG(II+1,'See the previous message. ') 345 - INEXT=II+2 346 - ELSEIF(FLAG(II+1))THEN 347 - CALL INPMSG(II,'ANGLE has 2 args: theta, phi. ') 348 - INEXT=II+1 349 - ELSE 350 - CALL INPCHK(II+1,2,IFAIL1) 351 - CALL INPRDR(II+1,PHI,30.0) 352 - CALL INPCHK(II+2,2,IFAIL1) 353 - CALL INPRDR(II+2,THETA,60.0) 354 - INEXT=II+3 355 - ENDIF 356 - * Otherwise skip to the next keyword. 357 - ELSE 358 - GOTO 20 359 - ENDIF 360 - 220 CONTINUE 361 - ** A vector plot. 362 - ELSEIF(INPCMP(I,'VE#CTOR').NE.0)THEN 363 - IF(LVECT)PRINT *,' !!!!!! DRFPLT WARNING : Only one'// 364 - - ' vector plot per PLOT statement can be processed.' 365 - LVECT=.TRUE. 366 - IF(FLAG(I+1).OR.FLAG(I+2))THEN 367 - IF(.NOT.POLAR)THEN 1 659 P=DRIFT D=DRFPLT 5 PAGE 995 368 - FUNCT4(1:11)='VDX,VDY,VDZ' 369 - NC4=11 370 - ELSE 371 - FUNCT4(1:13)='VDR,VDPHI,VDZ' 372 - NC4=13 373 - ENDIF 374 - IF(.NOT.FLAG(I+1).AND.FLAG(I+2))THEN 375 - CALL INPSTR(I+1,I+1,STRING,NCAUX) 376 - IF(INDEX(STRING(1:NCAUX),'@').NE.0)THEN 377 - FUNCT4(1:1)='@' 378 - NC4=1 379 - ELSE 380 - CALL INPMSG(I+1, 381 - - 'Has 2 or 3 args, default used.') 382 - ENDIF 383 - INEXT=I+2 384 - ELSE 385 - INEXT=I+1 386 - ENDIF 387 - ELSE 388 - CALL INPSTR(I+1,I+1,STRING,NC4) 389 - FUNCT4(1:NC4+1)=STRING(1:NC4)//',' 390 - CALL INPSTR(I+2,I+2,STRING,NCAUX) 391 - FUNCT4(NC4+2:NC4+NCAUX+2)=STRING(1:NCAUX)//',' 392 - NC4=NC4+NCAUX+2 393 - IF(.NOT.FLAG(I+3))THEN 394 - CALL INPSTR(I+3,I+3,STRING,NCAUX) 395 - FUNCT4(NC4+1:NC4+NCAUX)=STRING(1:NCAUX) 396 - NC4=NC4+NCAUX 397 - INEXT=I+4 398 - ELSE 399 - FUNCT4(NC4+1:NC4+1)='0' 400 - NC4=NC4+1 401 - INEXT=I+3 402 - ENDIF 403 - ENDIF 404 - ** Finally, find out whether the next plot is a HISTOGRAM. 405 - ELSEIF(INPCMP(I,'H#ISTOGRAM').NE.0)THEN 406 - IF(LHIST)PRINT *,' !!!!!! DRFPLT WARNING : Only one'// 407 - - ' histogram per PLOT statement can be processed.' 408 - LHIST=.TRUE. 409 - IF(FLAG(I+1))THEN 410 - FUNCT5(1:1)='VD' 411 - NC5=2 412 - HMIN=0.0 413 - HMAX=10000.0 414 - INEXT=I+1 415 - ELSE 416 - CALL INPSTR(I+1,I+1,STRING,NC5) 417 - FUNCT5(1:NC5)=STRING(1:NC5) 418 - INEXT=I+2 419 - ENDIF 420 - * Look for subkeywords associated with HISTOGRAM. 421 - DO 200 II=I,NWORD 422 - IF(II.LT.INEXT)GOTO 200 423 - * The RANGE subkeyword. 424 - IF(INPCMP(II,'RA#NGE').NE.0)THEN 425 - IF(INPCMP(II+1,'AUTO#MATIC').NE.0)THEN 426 - HMIN=0.0 427 - HMAX=0.0 428 - HAUTO=.TRUE. 429 - INEXT=II+2 430 - ELSEIF(.NOT.FLAG(II+1).AND..NOT.FLAG(II+2))THEN 431 - CALL INPCHK(II+1,2,IFAIL1) 432 - CALL INPCHK(II+2,2,IFAIL2) 433 - CALL INPRDR(II+1,HMINR,HMIN) 434 - CALL INPRDR(II+2,HMAXR,HMAX) 435 - HAUTO=.FALSE. 436 - IF(HMINR.EQ.HMAXR)THEN 437 - CALL INPMSG(II+1, 438 - - 'Zero range not permitted. ') 439 - CALL INPMSG(II+2, 440 - - 'See the previous message. ') 441 - ELSE 442 - HMIN=MIN(HMINR,HMAXR) 443 - HMAX=MAX(HMINR,HMAXR) 444 - ENDIF 445 - INEXT=II+3 446 - ELSE 447 - CALL INPMSG(II,'RANGE takes two arguments. ') 448 - IF(FLAG(II+1))THEN 449 - INEXT=II+1 450 - ELSE 451 - CALL INPMSG(II+1, 452 - - 'Ignored, see previous message.') 453 - INEXT=II+2 454 - ENDIF 455 - ENDIF 456 - * The BINS subkeyword. 457 - ELSEIF(INPCMP(II,'BI#NS').NE.0)THEN 458 - IF(FLAG(II+1))THEN 459 - CALL INPMSG(II,'This keyword has one argument.') 460 - INEXT=II+1 461 - ELSE 462 - CALL INPCHK(II+1,1,IFAIL) 463 - CALL INPRDI(II+1,NCHAR,MXCHA) 464 - IF(NCHAR.LE.1.OR.NCHAR.GT.MXCHA)THEN 465 - CALL INPMSG(II+1, 466 - - 'Inacceptable number of bins. ') 467 - ELSE 468 - NCHA=NCHAR 469 - ENDIF 470 - INEXT=II+2 471 - ENDIF 472 - * Otherwise quit this loop. 473 - ELSE 1 659 P=DRIFT D=DRFPLT 6 PAGE 996 474 - GOTO 20 475 - ENDIF 476 - 200 CONTINUE 477 - ** Drift parameters. 478 - ELSEIF(INPCMP(I,'EL#ECTRON').NE.0)THEN 479 - ITYPE=1 480 - ELSEIF(INPCMP(I,'ION').NE.0)THEN 481 - ITYPE=2 482 - ELSEIF(INPCMP(I,'POS#ITIVE').NE.0)THEN 483 - QPLT=+1 484 - ELSEIF(INPCMP(I,'NEG#ATIVE').NE.0)THEN 485 - QPLT=+1 486 - ELSEIF(INPCMP(I,'M#ONTE-C#ARLO-#DRIFT-#LINES')+ 487 - - INPCMP(I,'MC-#DRIFT-#LINES').NE.0)THEN 488 - LMCDR=.TRUE. 489 - ELSEIF(INPCMP(I,'NOM#ONTE-C#ARLO-#DRIFT-#LINES')+ 490 - - INPCMP(I,'NOMC-#DRIFT-#LINES')+ 491 - - INPCMP(I,'RUN#GE-K#UTTA-#DRIFT-#LINES')+ 492 - - INPCMP(I,'RKF-#DRIFT-#LINES').NE.0)THEN 493 - LMCDR=.FALSE. 494 - ** Warn if the user aks for an unknown plot type or makes an error, 495 - ELSE 496 - CALL INPMSG(I,'Should have been a plot type. ') 497 - ENDIF 498 - 20 CONTINUE 499 - ** Print error messages. 500 - CALL INPERR 501 - *** Next print the list of plots if the DEBUG option is on. 502 - IF(LDEBUG)THEN 503 - WRITE(LUNOUT,'( 504 - - '' ++++++ DRFPLT DEBUG : List of requested plots:''/ 505 - - '' Type Y/N '', 506 - - ''Function (1:20) NC <--------Range-------> '', 507 - - ''# cont # bins <-------Angle-------->'')') 508 - IF(LGRAPH)THEN 509 - WRITE(LUNOUT,'(26X,A10,L2,3X,A20,1X,I3,34X,I6)') 510 - - 'Graph ',LGRAPH,FUNCT1(1:20),NC1,NGRPNT 511 - ELSE 512 - WRITE(LUNOUT,'(26X,A10,L2)') 'Graph ',LGRAPH 513 - ENDIF 514 - IF(LCONT.AND..NOT.CAUTO)THEN 515 - WRITE(LUNOUT, 516 - - '(26X,A7,3X,L2,3X,A20,1X,I3,2(2X,E10.3),2X,I6)') 517 - - 'Contour',LCONT,FUNCT2(1:20),NC2,CMIN,CMAX,NCONT 518 - ELSEIF(LCONT.AND.CAUTO)THEN 519 - WRITE(LUNOUT,'(26X,A7,3X,L2,3X,A20,1X,I3, 520 - - '' Automatic scaling'',2X,I6)') 521 - - 'Contour',LCONT,FUNCT2(1:20),NC2,NCONT 522 - ELSE 523 - WRITE(LUNOUT,'(26X,A10,L2)') 'Contour ',LCONT 524 - ENDIF 525 - IF(LSURF)THEN 526 - WRITE(LUNOUT, 527 - - '(26X,A10,L2,3X,A20,1X,I3,40X,2(2X,E10.3))') 528 - - 'Surface ',LSURF,FUNCT3(1:20),NC3,PHI,THETA 529 - ELSE 530 - WRITE(LUNOUT,'(26X,A10,L2)') 'Surface ',LSURF 531 - ENDIF 532 - IF(LVECT)THEN 533 - WRITE(LUNOUT,'(26X,A10,L2,3X,A20,1X,I3)') 534 - - 'Vector ',LVECT ,FUNCT4(1:20),NC4 535 - ELSE 536 - PRINT '(26X,A10,L2)','Vector ',LVECT 537 - ENDIF 538 - IF(LHIST.AND..NOT.HAUTO)THEN 539 - WRITE(LUNOUT, 540 - - '(26X,A10,L2,3X,A20,1X,I3,2(2X,E10.3),10X,I6)') 541 - - 'Histogram ',LHIST ,FUNCT5(1:20),NC5, 542 - - HMIN,HMAX,NCHA 543 - ELSEIF(LHIST)THEN 544 - WRITE(LUNOUT,'(26X,A10,L2,3X,A20,1X,I3, 545 - - '' Automatic scaling'',10X,I6)') 546 - - 'Histogram ',LHIST ,FUNCT5(1:20),NC5,NCHA 547 - ELSE 548 - WRITE(LUNOUT,'(26X,A10,L2)') 'Histogram ',LHIST 549 - ENDIF 550 - WRITE(LUNOUT,'('' '')') 551 - ENDIF 552 - *** Take care of the 'GRAPH' type plots, translate curve function. 553 - IF(LGRAPH.AND.FUNTRA(1:NCFTRA).NE.'?')THEN 554 - CALL ALGPRE(FUNTRA,NCFTRA,VARLIS(24),1,NRES,USE(24), 555 - - IENTRA,IFAIL) 556 - IF(IFAIL.NE.0)THEN 557 - PRINT *,' !!!!!! DRFPLT WARNING : Graph not made'// 558 - - ' because of an error in the track function.' 559 - CALL ALGCLR(IENTRA) 560 - GOTO 101 561 - ELSEIF(NRES.NE.3)THEN 562 - PRINT *,' !!!!!! DRFPLT WARNING : Graph not made'// 563 - - ' because the curve does not give 3 results.' 564 - CALL ALGCLR(IENTRA) 565 - GOTO 101 566 - ELSEIF(.NOT.USE(24))THEN 567 - PRINT *,' !!!!!! DRFPLT WARNING : Graph not made'// 568 - - ' because the track does not depend on T.' 569 - CALL ALGCLR(IENTRA) 570 - GOTO 101 571 - ENDIF 572 - * If no curve is defined, the track must be. 573 - ELSEIF(LGRAPH.AND..NOT.TRFLAG(1))THEN 574 - PRINT *,' !!!!!! DRFPLT WARNING : Neither a track nor'// 575 - - ' a curve has been defined ; graph not made.' 576 - GOTO 101 577 - ENDIF 578 - * Parameters look a priori acceptable. 579 - IF(LGRAPH)THEN 1 659 P=DRIFT D=DRFPLT 7 PAGE 997 580 - * Transform the function into an instruction list, 581 - IF(INDEX(FUNCT1(1:NC1),'@').NE.0)THEN 582 - NRES=1 583 - CALL ALGEDT(VARLIS,23,IENTRY,USE,NRES) 584 - FUNCT1='Edited function' 585 - NC1=15 586 - ELSE 587 - CALL ALGPRE(FUNCT1,NC1,VARLIS,23,NRES,USE,IENTRY,IFAIL) 588 - IF(IFAIL.NE.0)THEN 589 - PRINT *,' !!!!!! DRFPLT WARNING : Graph not'// 590 - - ' produced because of syntax errors.' 591 - GOTO 100 592 - ENDIF 593 - ENDIF 594 - * Figure out which quatities are effectively used. 595 - EVALE=.FALSE. 596 - EVALB=.FALSE. 597 - EVALV=.FALSE. 598 - EVALT=.FALSE. 599 - EVALD=.FALSE. 600 - EVALA=.FALSE. 601 - EVALL=.FALSE. 602 - EVALP=.FALSE. 603 - IF(USE(3).OR.USE(4).OR.USE(5).OR.USE(6).OR.USE(15)) 604 - - EVALE=.TRUE. 605 - IF(USE(7).OR.USE(8).OR.USE(9).OR.USE(10))EVALB=.TRUE. 606 - IF(USE(11).OR.USE(12).OR.USE(13).OR.USE(14).OR. 607 - - USE(15))EVALV=.TRUE. 608 - IF(USE(16).OR.USE(17).OR.USE(18).OR.USE(19).OR. 609 - - USE(20).OR.USE(21))EVALT=.TRUE. 610 - IF(USE(17))EVALP=.TRUE. 611 - IF(USE(18))EVALD=.TRUE. 612 - IF(USE(19))EVALA=.TRUE. 613 - IF(USE(20))EVALL=.TRUE. 614 - * Be sure only one result is returned. 615 - IF(NRES.NE.1)THEN 616 - PRINT *,' !!!!!! DRFPLT WARNING : The function'// 617 - - ' does not return precisely 1 result; no graph.' 618 - GOTO 100 619 - ENDIF 620 - * check the use of magnetic field quantities, 621 - IF(EVALB.AND..NOT.MAGOK)THEN 622 - PRINT *,' !!!!!! DRFPLT WARNING : The function to be'// 623 - - ' plotted uses magnetic field quantities,' 624 - PRINT *,' no such field has'// 625 - - ' been defined however ; plot not made.' 626 - GOTO 100 627 - ENDIF 628 - IF((USE(7).OR.USE(8)).AND.POLAR)THEN 629 - PRINT *,' !!!!!! DRFPLT WARNING : Bx and By should'// 630 - - ' not be used with polar cells ; plot not made.' 631 - GOTO 100 632 - ENDIF 633 - * Check use of absent gas data. 634 - IF(EVALD.AND..NOT.GASOK(3))THEN 635 - PRINT *,' !!!!!! DRFPLT WARNING : The graph tries'// 636 - - ' to use absent diffusion data ; plot not made.' 637 - GOTO 100 638 - ENDIF 639 - IF(EVALA.AND..NOT.GASOK(4))THEN 640 - PRINT *,' !!!!!! DRFPLT WARNING : The graph tries'// 641 - - ' to use absent Townsend data ; plot not made.' 642 - GOTO 100 643 - ENDIF 644 - IF(EVALL.AND..NOT.GASOK(6))THEN 645 - PRINT *,' !!!!!! DRFPLT WARNING : The graph tries'// 646 - - ' to use absent attachment data ; plot not made.' 647 - GOTO 100 648 - ENDIF 649 - * Select the axis with the largest range for ordinate. 650 - IF(FUNTRA(1:NCFTRA).NE.'?')THEN 651 - ICOORD=3 652 - ELSEIF(POLAR)THEN 653 - CALL CFMCTP(XT0,YT0,RT0,PT0,1) 654 - CALL CFMCTP(XT1,YT1,RT1,PT1,1) 655 - IF((ZT1-ZT0)**2.GT.(XT1-XT0)**2+(YT1-YT0)**2)THEN 656 - ICOORD=11 657 - ELSEIF(ABS(RT0-RT1).GT.ABS(PT0-PT1))THEN 658 - ICOORD=1 659 - ELSE 660 - ICOORD=2 661 - ENDIF 662 - ELSE 663 - IF((ZT1-ZT0)**2.GT.(XT1-XT0)**2+(YT1-YT0)**2)THEN 664 - ICOORD=11 665 - ELSEIF(ABS(XT0-XT1).GT.ABS(YT0-YT1))THEN 666 - ICOORD=1 667 - ELSE 668 - ICOORD=2 669 - ENDIF 670 - ENDIF 671 - * Print a heading for the numbers. 672 - IF(FUNTRA(1:NCFTRA).EQ.'?')THEN 673 - IF(LGRPRT)WRITE(LUNOUT,'(/'' GRAPH OF '',A, 674 - - '' ON '',A//2X,''Coordinate'',48X,''Function'')') 675 - - FUNCT1(1:NC1),'THE TRACK' 676 - ELSE 677 - IF(LGRPRT)WRITE(LUNOUT,'(/'' GRAPH OF '',A, 678 - - '' ON '',A//2X,''Coordinate'',48X,''Function'')') 679 - - FUNCT1(1:NC1),FUNTRA(1:NCFTRA) 680 - ENDIF 681 - * Fill the vectors, 682 - DO 30 I=1,NGRPNT 683 - IF(ICOORD.NE.3)THEN 684 - XPOS=XT0+REAL(I-1)*(XT1-XT0)/REAL(NGRPNT-1) 685 - YPOS=YT0+REAL(I-1)*(YT1-YT0)/REAL(NGRPNT-1) 1 659 P=DRIFT D=DRFPLT 8 PAGE 998 686 - ZPOS=ZT0+REAL(I-1)*(ZT1-ZT0)/REAL(NGRPNT-1) 687 - IF(POLAR)CALL CFMCTR(XPOS,YPOS,XPOS,YPOS,1) 688 - ELSE 689 - VAR(1)=REAL(I-1)/REAL(NGRPNT-1) 690 - MODVAR(1)=2 691 - CALL ALGEXE(IENTRA,VAR,MODVAR,1,RES,MODRES,3,IFAIL) 692 - XPOS=RES(1) 693 - YPOS=RES(2) 694 - ZPOS=RES(3) 695 - IF(POLAR)CALL CFMPTR(XPOS,YPOS,XPOS,YPOS,1,IFAIL1) 696 - IF(IFAIL1.NE.0)THEN 697 - XPOS=1.0 698 - YPOS=0.0 699 - ZPOS=0.0 700 - PRINT *,' !!!!!! DRFPLT WARNING : The curve'// 701 - - ' function returns invalid coordinates.' 702 - ENDIF 703 - ENDIF 704 - CALL DCONT2(XPOS,YPOS,ZPOS,RES,ILOC) 705 - IF(ICOORD.EQ.3)THEN 706 - COORD(I)=REAL(I-1)/REAL(NGRPNT-1) 707 - ELSEIF(ICOORD.EQ.2)THEN 708 - COORD(I)=YPOS 709 - ELSEIF(ICOORD.EQ.11)THEN 710 - COORD(I)=ZPOS 711 - ELSE 712 - COORD(I)=XPOS 713 - ENDIF 714 - VALUE(I)=RES(1) 715 - * Print the point if this has been requested. 716 - IF(LGRPRT)WRITE(LUNOUT,'(4(2X,E15.8))') 717 - - XPOS,YPOS,ZPOS,VALUE(I) 718 - 30 CONTINUE 719 - * Plot the graph. 720 - IF(GRSMIN.LT.GRSMAX)CALL GRGRSC(GRSMIN,GRSMAX) 721 - IF(ICOORD.EQ.3)THEN 722 - CALL GRGRPH(COORD,VALUE,NGRPNT,'Curve parameter', 723 - - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), 724 - - 'GRAPH OF '//FUNCT1(1:31)) 725 - ELSEIF(POLAR.AND.ICOORD.EQ.1)THEN 726 - CALL GRGRPH(COORD,VALUE,NGRPNT,'Radius [cm]', 727 - - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), 728 - - 'GRAPH OF '//FUNCT1(1:31)) 729 - ELSEIF(POLAR.AND.ICOORD.EQ.2)THEN 730 - CALL GRGRPH(COORD,VALUE,NGRPNT,'Angle [degrees]', 731 - - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), 732 - - 'GRAPH OF '//FUNCT1(1:31)) 733 - ELSEIF((.NOT.POLAR).AND.ICOORD.EQ.1)THEN 734 - CALL GRGRPH(COORD,VALUE,NGRPNT,'x-Axis [cm]', 735 - - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), 736 - - 'GRAPH OF '//FUNCT1(1:31)) 737 - ELSEIF((.NOT.POLAR).AND.ICOORD.EQ.2)THEN 738 - CALL GRGRPH(COORD,VALUE,NGRPNT,'y-Axis [cm]', 739 - - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), 740 - - 'GRAPH OF '//FUNCT1(1:31)) 741 - ELSEIF((.NOT.POLAR).AND.ICOORD.EQ.11)THEN 742 - CALL GRGRPH(COORD,VALUE,NGRPNT,'z-Axis [cm]', 743 - - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), 744 - - 'GRAPH OF '//FUNCT1(1:31)) 745 - ELSE 746 - PRINT *,' ###### DRFPLT ERROR : Inconsistent axis'// 747 - - ' selection ; program bug - please report.' 748 - ENDIF 749 - * Log this frame and prepare for the next plot. 750 - CALL GRNEXT 751 - CALL GRALOG('Graph of '//FUNCT1(1:31)) 752 - CALL TIMLOG('Plotting the graph of '//FUNCT1(1:18)) 753 - * print the number of arithmetic errors. 754 - CALL ALGERR 755 - 100 CONTINUE 756 - * Release the entry points. 757 - CALL ALGCLR(IENTRY) 758 - IF(FUNTRA(1:NCFTRA).NE.'?')CALL ALGCLR(IENTRA) 759 - ENDIF 760 - * Continue here if the parameters were not acceptable. 761 - 101 CONTINUE 762 - *** Take care of the contours. 763 - IF(LCONT)THEN 764 - * Convert to an instruction list, 765 - IF(INDEX(FUNCT2(1:NC2),'@').NE.0)THEN 766 - NRES=1 767 - CALL ALGEDT(VARLIS,23,IENTRY,USE,NRES) 768 - FUNCT2='Edited function' 769 - NC2=15 770 - ELSE 771 - CALL ALGPRE(FUNCT2,NC2,VARLIS,23,NRES,USE,IENTRY,IFAIL) 772 - IF(IFAIL.NE.0)THEN 773 - PRINT *,' !!!!!! DRFPLT WARNING : No contour'// 774 - - ' plot because of function syntax errors.' 775 - GOTO 110 776 - ENDIF 777 - ENDIF 778 - * Be sure only one result is returned. 779 - IF(NRES.NE.1)THEN 780 - PRINT *,' !!!!!! DRFPLT WARNING : The function does'// 781 - - ' not return precisely 1 result; no contour.' 782 - GOTO 110 783 - ENDIF 784 - * Figure out which quantities are effectively used. 785 - EVALE=.FALSE. 786 - EVALB=.FALSE. 787 - EVALV=.FALSE. 788 - EVALT=.FALSE. 789 - EVALD=.FALSE. 790 - EVALA=.FALSE. 791 - EVALL=.FALSE. 1 659 P=DRIFT D=DRFPLT 9 PAGE 999 792 - EVALP=.FALSE. 793 - IF(USE(3).OR.USE(4).OR.USE(5).OR.USE(6).OR.USE(15)) 794 - - EVALE=.TRUE. 795 - IF(USE(7).OR.USE(8).OR.USE(9).OR.USE(10))EVALB=.TRUE. 796 - IF(USE(11).OR.USE(12).OR.USE(13).OR.USE(14).OR. 797 - - USE(15))EVALV=.TRUE. 798 - IF(USE(16).OR.USE(17).OR.USE(18).OR.USE(19).OR. 799 - - USE(20).OR.USE(21))EVALT=.TRUE. 800 - IF(USE(17))EVALP=.TRUE. 801 - IF(USE(18))EVALD=.TRUE. 802 - IF(USE(19))EVALA=.TRUE. 803 - IF(USE(20))EVALL=.TRUE. 804 - * Check the use of magnetic field quantities. 805 - IF(EVALB.AND..NOT.MAGOK)THEN 806 - PRINT *,' !!!!!! DRFPLT WARNING : The function to be'// 807 - - ' plotted uses magnetic field quantities,' 808 - PRINT *,' no such field has'// 809 - - ' been defined however ; plot not made.' 810 - GOTO 110 811 - ENDIF 812 - IF((USE(7).OR.USE(8)).AND.POLAR)THEN 813 - PRINT *,' !!!!!! DRFPLT WARNING : Bx and By should'// 814 - - ' not be used with polar cells ; plot not made.' 815 - GOTO 110 816 - ENDIF 817 - * Check use of absent gas data. 818 - IF(EVALD.AND..NOT.GASOK(3))THEN 819 - PRINT *,' !!!!!! DRFPLT WARNING : The contour tries'// 820 - - ' to use absent diffusion data ; plot not made.' 821 - GOTO 110 822 - ENDIF 823 - IF(EVALA.AND..NOT.GASOK(4))THEN 824 - PRINT *,' !!!!!! DRFPLT WARNING : The contour tries'// 825 - - ' to use absent Townsend data ; plot not made.' 826 - GOTO 110 827 - ENDIF 828 - IF(EVALL.AND..NOT.GASOK(6))THEN 829 - PRINT *,' !!!!!! DRFPLT WARNING : The contour tries'// 830 - - ' to use absent attachment data ; plot not made.' 831 - GOTO 110 832 - ENDIF 833 - * Plot the contours. 834 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 835 - - 'Contours of '//FUNCT2(1:NC2)) 836 - NCONTP=NCONT 837 - CALL GRCONT(DCONT,CMIN,CMAX,VXMIN,VYMIN,VXMAX,VYMAX, 838 - - NCONTP,CAUTO,POLAR,CLAB) 839 - CALL GRNEXT 840 - * Print the table of contour heights. 841 - CALL OUTFMT(CMIN,2,AUX1,NCAUX1,'LEFT') 842 - CALL OUTFMT(CMAX,2,AUX2,NCAUX2,'LEFT') 843 - CALL OUTFMT(REAL(NCONTP),2,AUX3,NCAUX3,'LEFT') 844 - CALL OUTFMT((CMAX-CMIN)/REAL(MAX(1,NCONTP)),2, 845 - - AUX4,NCAUX4,'LEFT') 846 - IF(NCONTP.GE.1)WRITE(LUNOUT,'(/'' The contours'', 847 - - '' correspond to '',A,'' = '',A,'' to '',A, 848 - - '' in '',A,'' steps.''/'' The interval between 2'', 849 - - '' contours is '',A,''.'')') 850 - - FUNCT2(1:NC2),AUX1(1:NCAUX1),AUX2(1:NCAUX2), 851 - - AUX3(1:NCAUX3),AUX4(1:NCAUX4) 852 - IF(NCONTP.EQ.0)WRITE(LUNOUT,'(/'' The contour'', 853 - - '' corresponds to '',A,'' = '',A,''.'')') 854 - - FUNCT2(1:NC2),AUX1(1:NCAUX1) 855 - * Keep track of the plots being made. 856 - CALL GRALOG('Contours of '//FUNCT2(1:NC2)//':') 857 - CALL TIMLOG('Plotting contours of '//FUNCT2(1:NC2)//':') 858 - * Print the number of arithmetic errors. 859 - CALL ALGERR 860 - 110 CONTINUE 861 - CALL ALGCLR(IENTRY) 862 - ENDIF 863 - *** If one of the other plots is asked for, prepare the function string. 864 - IF(LHIST.OR.LSURF.OR.LVECT)THEN 865 - NCTOT=0 866 - IF(LSURF)THEN 867 - ISURF=1 868 - FUNCT1(1:NC3)=FUNCT3(1:NC3) 869 - NCTOT=NC3 870 - ENDIF 871 - IF(LVECT)THEN 872 - IF(LSURF)THEN 873 - IVECT1=2 874 - IVECT2=3 875 - IVECT3=4 876 - FUNCT1(NCTOT+1:NCTOT+NC4+1)=','//FUNCT4(1:NC4) 877 - NCTOT=NCTOT+NC4+1 878 - ELSE 879 - IVECT1=1 880 - IVECT2=2 881 - IVECT3=3 882 - FUNCT1(1:NC4)=FUNCT4(1:NC4) 883 - NCTOT=NC4 884 - ENDIF 885 - ENDIF 886 - IF(LHIST)THEN 887 - IF(LSURF.OR.LVECT)THEN 888 - IF(LSURF.AND..NOT.LVECT)IHIST=2 889 - IF(LVECT.AND..NOT.LSURF)IHIST=4 890 - IF(LSURF.AND. LVECT)IHIST=5 891 - FUNCT1(NCTOT+1:NCTOT+NC5+1)=','//FUNCT5(1:NC5) 892 - NCTOT=NCTOT+NC5+1 893 - ELSE 894 - IHIST=1 895 - FUNCT1(1:NC5)=FUNCT5(1:NC5) 896 - NCTOT=NC5 897 - ENDIF 1 659 P=DRIFT D=DRFPLT 10 PAGE1000 898 - ENDIF 899 - * Turn it into an instruction list, 900 - NREXP=0 901 - IF(LHIST)NREXP=NREXP+1 902 - IF(LSURF)NREXP=NREXP+1 903 - IF(LVECT)NREXP=NREXP+3 904 - IF(INDEX(FUNCT1(1:NCTOT),'@').NE.0)THEN 905 - NRES=NREXP 906 - CALL ALGEDT(VARLIS,23,IENTRY,USE,NRES) 907 - FUNCT1='Edited function' 908 - NCTOT=15 909 - ELSE 910 - CALL ALGPRE(FUNCT1,NCTOT,VARLIS,23,NRES,USE,IENTRY, 911 - - IFAIL) 912 - IF(IFAIL.NE.0)THEN 913 - PRINT *,' !!!!!! DRFPLT WARNING : Plots not'// 914 - - ' produced because of syntax errors.' 915 - GOTO 120 916 - ENDIF 917 - ENDIF 918 - * Be sure only one result is returned. 919 - IF(NRES.NE.NREXP)THEN 920 - PRINT *,' !!!!!! DRFPLT WARNING : The function does'// 921 - - ' not return the correct number of results;'// 922 - - ' histogram, surface and vector plot skipped.' 923 - GOTO 120 924 - ENDIF 925 - * Figure out which quantities are effectively used. 926 - EVALE=.FALSE. 927 - EVALB=.FALSE. 928 - EVALV=.FALSE. 929 - EVALT=.FALSE. 930 - EVALD=.FALSE. 931 - EVALA=.FALSE. 932 - EVALL=.FALSE. 933 - EVALP=.FALSE. 934 - IF(USE(3).OR.USE(4).OR.USE(5).OR.USE(6).OR.USE(15)) 935 - - EVALE=.TRUE. 936 - IF(USE(7).OR.USE(8).OR.USE(9).OR.USE(10))EVALB=.TRUE. 937 - IF(USE(11).OR.USE(12).OR.USE(13).OR.USE(14).OR. 938 - - USE(15))EVALV=.TRUE. 939 - IF(USE(16).OR.USE(17).OR.USE(18).OR.USE(19).OR. 940 - - USE(20).OR.USE(21))EVALT=.TRUE. 941 - IF(USE(17))EVALP=.TRUE. 942 - IF(USE(18))EVALD=.TRUE. 943 - IF(USE(19))EVALA=.TRUE. 944 - IF(USE(20))EVALL=.TRUE. 945 - * check the use of magnetic field quantities, 946 - IF(EVALB.AND..NOT.MAGOK)THEN 947 - PRINT *,' !!!!!! DRFPLT WARNING : The function to be'// 948 - - ' plotted uses magnetic field quantities,' 949 - PRINT *,' no such field has'// 950 - - ' been defined however ; plot not made.' 951 - GOTO 120 952 - ENDIF 953 - IF((USE(7).OR.USE(8)).AND.POLAR)THEN 954 - PRINT *,' !!!!!! DRFPLT WARNING : Bx and By should'// 955 - - ' not be used with polar cells ; plot not made.' 956 - GOTO 120 957 - ENDIF 958 - * Check use of absent gas data. 959 - IF(EVALD.AND..NOT.GASOK(3))THEN 960 - PRINT *,' !!!!!! DRFPLT WARNING : The plot tries'// 961 - - ' to use absent diffusion data ; plot not made.' 962 - GOTO 120 963 - ENDIF 964 - IF(EVALA.AND..NOT.GASOK(4))THEN 965 - PRINT *,' !!!!!! DRFPLT WARNING : The plot tries'// 966 - - ' to use absent Townsend data ; plot not made.' 967 - GOTO 120 968 - ENDIF 969 - IF(EVALL.AND..NOT.GASOK(6))THEN 970 - PRINT *,' !!!!!! DRFPLT WARNING : The plot tries'// 971 - - ' to use absent attachment data ; plot not made.' 972 - GOTO 120 973 - ENDIF 0 974-+ +SELF,IF=NAG,HIGZ. 975 - * Obtain the matrix for surface plotting. 976 - IF(LSURF)THEN 977 - CALL BOOK('BOOK','MATRIX','SURFACE',IFAIL) 978 - IF(IFAIL.NE.0)THEN 979 - PRINT *,' !!!!!! DRFPLT WARNING : Unable to'// 980 - - ' obtain storage for the surface plot.' 981 - PRINT *,' The plot'// 982 - - ' will not be made.' 983 - LSURF=.FALSE. 984 - ENDIF 985 - ENDIF 0 986-+ +SELF. 987 - * Open a plotting frame for a VECTOR plot, if requested. 988 - IF(LVECT)THEN 989 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 990 - - 'Vector plot of '//FUNCT4(1:NC4)) 991 - CALL GRALOG('Vector plot of '//FUNCT4(1:NC4)//':') 992 - * Otherwise, merely request the viewing area. 993 - ELSE 994 - CALL GRVIEW(VXMIN,VYMIN,VXMAX,VYMAX) 995 - ENDIF 996 - * Allocate an histogram, if needed. 997 - IF(LHIST)THEN 998 - CALL HISADM('ALLOCATE',IHISRF,NCHA,HMIN,HMAX, 999 - - HAUTO,IFAIL) 1000 - IF(IFAIL.NE.0)THEN 1001 - PRINT *,' !!!!!! DRFPLT WARNING : Unable to'// 1 659 P=DRIFT D=DRFPLT 11 PAGE1001 1002 - - ' allocate histogram storage; histogram'// 1003 - - ' cancelled.' 1004 - LHIST=.FALSE. 1005 - ENDIF 1006 - ENDIF 1007 - * Fill all the arrays and matrices required for these plots. 1008 - CALL GRATTS('FUNCTION-1','POLYLINE') 1009 - DO 50 I=1,NGRIDX 1010 - IF(.NOT.POLAR)THEN 1011 - XXPOS=VXMIN+REAL(I-1)*(VXMAX-VXMIN)/REAL(NGRIDX-1) 1012 - ELSE 1013 - XXPOS=LOG(EXP(VXMIN)+REAL(I-1)*(EXP(VXMAX)-EXP(VXMIN))/ 1014 - - REAL(NGRIDX-1)) 1015 - ENDIF 1016 - * set a normalisation factor, to get the arrows more or less right 1017 - IF(.NOT.POLAR)THEN 1018 - FACNRM=MIN(VYMAX-VYMIN,VXMAX-VXMIN)/REAL(NGRIDX) 1019 - ELSE 1020 - FACNRM=LOG((EXP(VXMIN)+REAL(I-1)*(EXP(VXMAX)- 1021 - - EXP(VXMIN))/REAL(NGRIDX))/(EXP(VXMIN)+REAL(I)* 1022 - - (EXP(VXMAX)-EXP(VXMIN))/REAL(NGRIDX))) 1023 - ENDIF 1024 - DO 60 J=1,NGRIDY 1025 - YYPOS=VYMIN+REAL(J-1)*(VYMAX-VYMIN)/REAL(NGRIDY-1) 1026 - * Coordinate transformation to the viewing plane. 1027 - XPOS=FPROJ(1,1)*XXPOS+FPROJ(2,1)*YYPOS+FPROJ(3,1) 1028 - YPOS=FPROJ(1,2)*XXPOS+FPROJ(2,2)*YYPOS+FPROJ(3,2) 1029 - ZPOS=FPROJ(1,3)*XXPOS+FPROJ(2,3)*YYPOS+FPROJ(3,3) 1030 - IF(XPOS.LT.DXMIN.OR.XPOS.GT.DXMAX.OR. 1031 - - YPOS.LT.DYMIN.OR.YPOS.GT.DYMAX.OR. 1032 - - ZPOS.LT.DZMIN.OR.ZPOS.GT.DZMAX)THEN 0 1033-+ +SELF,IF=NAG,HIGZ. 1034 - IF(LSURF)WS(I,J)=0.0 0 1035-+ +SELF. 1036 - GOTO 60 1037 - ENDIF 1038 - * Evaluate the function. 1039 - VAR(1)=XPOS 1040 - VAR(2)=YPOS 1041 - VAR(23)=ZPOS 1042 - * Calculate the fields needed for the rest. 1043 - IF(EVALE)CALL EFIELD(VAR(1),VAR(2),VAR(23), 1044 - - VAR(3),VAR(4),VAR(5),VAR(6),VOLT,0,ILOC) 1045 - IF(EVALB)CALL BFIELD(VAR(1),VAR(2),VAR(23), 1046 - - VAR(7),VAR(8),VAR(9),VAR(10)) 1047 - * Get the local drift velocity. 1048 - IF(EVALV)THEN 1049 - CALL DLCVEL(DBLE(VAR(1)),DBLE(VAR(2)),DBLE(VAR(23)), 1050 - - F0,QPLT,ITYPE,ILOC) 1051 - VAR(11)=REAL(F0(1)) 1052 - VAR(12)=REAL(F0(2)) 1053 - VAR(13)=REAL(F0(3)) 1054 - VAR(14)=SQRT(VAR(11)**2+VAR(12)**2+VAR(13)**2) 1055 - ENDIF 1056 - * Lorentz angle. 1057 - IF(EVALE.AND.EVALV)VAR(15)=ACOS(MAX(-1.0,MIN(1.0, 1058 - - REAL((VAR(3)*VAR(11)+VAR(4)*VAR(12)+VAR(5)*VAR(13))/ 1059 - - (VAR(6)*VAR(14)))))) 1060 - * Store drift line related quantities. 1061 - IF(EVALT)THEN 1062 - CALL DLCALC(VAR(1),VAR(2),VAR(23),QPLT,ITYPE) 1063 - VAR(16)=TU(NU) 1064 - IF(EVALP)THEN 1065 - VAR(17)=0.0 1066 - DO 64 II=2,NU 1067 - IF(POLAR)THEN 1068 - CALL CF2RTC(XU(II-1),YU(II-1),XPOS1,YPOS1,1) 1069 - CALL CF2RTC(XU(II) ,YU(II) ,XPOS2,YPOS2,1) 1070 - VAR(17)=VAR(17)+SQRT((XPOS2-XPOS1)**2+ 1071 - - (YPOS2-YPOS1)**2+(ZU(II)-ZU(II-1))**2) 1072 - ELSE 1073 - VAR(17)=VAR(17)+SQRT((XU(II)-XU(II-1))**2+ 1074 - - (YU(II)-YU(II-1))**2+ 1075 - - (ZU(II)-ZU(II-1))**2) 1076 - ENDIF 1077 - 64 CONTINUE 1078 - ENDIF 1079 - IF(EVALD)CALL DLCDIF(VAR(18)) 1080 - IF(EVALA)CALL DLCTWN(VAR(19)) 1081 - IF(EVALL)CALL DLCATT(VAR(20)) 1082 - VAR(21)=ISTAT 1083 - ENDIF 1084 - * Store gas pressure. 1085 - VAR(22)=PGAS 1086 - * Transform vectors and covectors to polar coordinates if needed. 1087 - IF(POLAR)THEN 1088 - CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) 1089 - VAR(3)=VAR(3)/VAR(1) 1090 - VAR(4)=VAR(4)/VAR(1) 1091 - VAR(6)=SQRT(VAR(3)**2+VAR(4)**2+VAR(5)**2) 1092 - VAR(11)=VAR(11)*VAR(1) 1093 - VAR(12)=VAR(12)*VAR(1) 1094 - VAR(14)=SQRT(VAR(11)**2+VAR(12)**2+VAR(13)**2) 1095 - ENDIF 1096 - DO 65 II=1,23 1097 - MODVAR(II)=2 1098 - 65 CONTINUE 1099 - CALL ALGEXE(IENTRY,VAR,MODVAR,23,RES,MODRES,5,IFAIL) 1100 - * Vector plot plotting. 1101 - IF(LVECT)THEN 1102 - IF(RES(IVECT1)**2+RES(IVECT2)**2+RES(IVECT3)**2.GT.0) 1103 - - CALL PLAARR(XPOS,YPOS,ZPOS, 1104 - - 0.5*FACNRM*RES(IVECT1)/SQRT(RES(IVECT1)**2+ 1105 - - RES(IVECT2)**2+RES(IVECT3)**2), 1 659 P=DRIFT D=DRFPLT 12 PAGE1002 1106 - - 0.5*FACNRM*RES(IVECT2)/SQRT(RES(IVECT1)**2+ 1107 - - RES(IVECT2)**2+RES(IVECT3)**2), 1108 - - 0.5*FACNRM*RES(IVECT3)/SQRT(RES(IVECT1)**2+ 1109 - - RES(IVECT2)**2+RES(IVECT3)**2)) 1110 - ENDIF 0 1111-+ +SELF,IF=NAG,HIGZ. 1112 - IF(LSURF)WS(I,J)=RES(ISURF) 0 1113-+ +SELF. 1114 - * fill the histogram, if requested, 1115 - IF(LHIST)CALL HISENT(IHISRF,RES(IHIST),1.0) 1116 - 60 CONTINUE 1117 - 50 CONTINUE 1118 - CALL TIMLOG('Accumulating plot data on the grid: ') 1119 - IF(LVECT)CALL GRNEXT 1120 - * plot the 3-dimensional picture if requested 1121 - IF(LSURF)THEN 0 1122-+ +SELF,IF=NAG. 1123 - * Check that the surface is not flat. 1124 - IFLAT=1 1125 - DO 80 ICHK=1,NGRIDX 1126 - DO 70 JCHK=1,NGRIDY 1127 - IF(ABS(WS(ICHK,JCHK)-WS(1,1)).GT.1.0E-5* 1128 - - (1.0+ABS(WS(ICHK,JCHK))+ABS(WS(1,1))))IFLAT=0 1129 - 70 CONTINUE 1130 - 80 CONTINUE 1131 - IF(IFLAT.NE.0)THEN 1132 - PRINT *,' !!!!!! DRFPLT WARNING : The surface is', 1133 - - ' not plotted because it is entirely flat.' 1134 - CALL BOOK('RELEASE','MATRIX','SURFACE',IFAIL) 1135 - GOTO 90 1136 - ENDIF 1137 - * Switch the screen to graphics mode. 1138 - CALL GRGRAF(.TRUE.) 1139 - * Store the CH eXPansion, NAG has the nasty habit of changing it. 1140 - CALL GQCHXP(IERR,CHEXP) 1141 - IF(IERR.NE.0)CHEXP=1.0 1142 - * Initialize NAG. 1143 - CALL X04AAF(1,10) 1144 - CALL J06WAF 1145 - CALL J06WCF(0.1D0,0.9D0,0.1D0,0.9D0) 1146 - CALL J06WBF(0.0D0,1.0D0,0.0D0,1.0D0,1) 1147 - IFAIL=0 1148 - IF(POLAR)THEN 1149 - CALL J06HCF(WS,MXWIRE,NGRIDX,NGRIDY,DBLE(THETA), 1150 - - DBLE(PHI),'Along a radius', 1151 - - 'Increasing angle',IFAIL) 1152 - ELSE 1153 - CALL J06HCF(WS,MXWIRE,NGRIDX,NGRIDY,DBLE(THETA), 1154 - - DBLE(PHI),'u-axis','v-axis',IFAIL) 1155 - ENDIF 1156 - CALL GRNEXT 1157 - * Reset the CH eXPension factor to the original value, 1158 - CALL GSCHXP(CHEXP) 1159 - CALL TIMLOG('Making a 3-dimensional plot: ') 1160 - CALL GRALOG('3-D plot of '//FUNCT3(1:28)) 0 1161-+ +SELF,IF=HIGZ. 1162 - * Check that the surface is not flat. 1163 - IFLAT=1 1164 - SMIN=WS(1,1) 1165 - SMAX=WS(1,1) 1166 - DO 80 ICHK=1,NGRIDX 1167 - DO 70 JCHK=1,NGRIDY 1168 - IF(ABS(WS(ICHK,JCHK)-WS(1,1)).GT.1.0E-5* 1169 - - (1.0+ABS(WS(ICHK,JCHK))+ABS(WS(1,1))))IFLAT=0 1170 - SMIN=MIN(SMIN,WS(1,1)) 1171 - SMAX=MAX(SMAX,WS(1,1)) 1172 - 70 CONTINUE 1173 - 80 CONTINUE 1174 - IF(IFLAT.NE.0)THEN 1175 - PRINT *,' !!!!!! DRFPLT WARNING : The surface is', 1176 - - ' not plotted because it is entirely flat.' 1177 - CALL BOOK('RELEASE','MATRIX','SURFACE',IFAIL) 1178 - GOTO 90 1179 - ENDIF 1180 - * Switch the screen to graphics mode. 1181 - CALL GRGRAF(.TRUE.) 1182 - * Fill the PAR vector. 1183 - PAR(1)=THETA 1184 - PAR(2)=PHI 1185 - PAR(3)=VXMIN 1186 - PAR(4)=VXMAX 1187 - PAR(5)=VYMIN 1188 - PAR(6)=VYMAX 1189 - PAR(7)=SMIN 1190 - PAR(8)=SMAX 1191 - PAR(9)=1000+NGRIDX 1192 - PAR(10)=1000+NGRIDY 1193 - PAR(11)=510 1194 - PAR(12)=510 1195 - PAR(13)=510 1196 - PAR(14)=1 1197 - PAR(15)=1 1198 - PAR(16)=1 1199 - PAR(17)=0.02 1200 - PAR(18)=0.02 1201 - PAR(19)=0.02 1202 - PAR(20)=0.03 1203 - PAR(21)=2 1204 - PAR(22)=0.03 1205 - PAR(23)=0.03 1206 - PAR(24)=0.03 1207 - PAR(25)=7 1 659 P=DRIFT D=DRFPLT 13 PAGE1003 1208 - PAR(26)=8 1209 - PAR(27)=9 1210 - PAR(28)=10 1211 - PAR(29)=11 1212 - PAR(30)=12 1213 - PAR(31)=13 1214 - PAR(32)=14 1215 - PAR(33)=15 1216 - PAR(34)=16 1217 - PAR(35)=17 1218 - PAR(36)=18 1219 - PAR(37)=19 1220 - * Plot the surface. 1221 - CALL ISVP(1,0.1,0.9,0.1,0.9) 1222 - CALL ISWN(1,0.0,1.0,0.0,1.0) 1223 - CALL ISELNT(1) 1224 - CALL IGTABL(MXWIRE,MXWIRE,WS,37,PAR,'S1') 1225 - * Close the plot. 1226 - CALL GRNEXT 1227 - * Record what happened. 1228 - CALL TIMLOG('Making a 3-dimensional plot: ') 1229 - CALL GRALOG('3-D plot of '//FUNCT3(1:28)) 1230 - * Release the matrix. 1231 - CALL BOOK('RELEASE','MATRIX','SURFACE',IFAIL) 0 1232-+ +SELF,IF=-NAG,IF=-HIGZ. 1233 - * No graphics system present to plot the surface. 1234 - PRINT *,' !!!!!! DRFPLT WARNING : The plotting system', 1235 - - ' used for this module has no SURFACE facilities.' 0 1236-+ +SELF. 1237 - 90 CONTINUE 1238 - ENDIF 1239 - * plot the histogram if requested, delete after use. 1240 - IF(LHIST)THEN 1241 - CALL HISPLT(IHISRF,FUNCT5(1:NC5), 1242 - - 'Histogram of '//FUNCT5(1:NC5),.TRUE.) 1243 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 1244 - CALL GRNEXT 1245 - CALL GRALOG('Histogram of '//FUNCT5(1:NC5)//':') 1246 - CALL TIMLOG('Plotting an histogram of '// 1247 - - FUNCT5(1:NC5)) 1248 - CALL HISADM('DELETE',IHISRF,0,0.0,0.0,.FALSE.,IFAIL) 1249 - ENDIF 1250 - * print the number of arithmetic errors. 1251 - CALL ALGERR 1252 - 120 CONTINUE 1253 - * release the algebra storage. 1254 - CALL ALGCLR(IENTRY) 1255 - ENDIF 1256 - END 660 GARFIELD ================================================== P=DRIFT D=DCONT 1 ============================ 0 + +DECK,DCONT. 1 - SUBROUTINE DCONT(X0,Y0,FVAL,ILOC) 2 - *----------------------------------------------------------------------- 3 - * DCONT - Returns the function value of to the contour routine 4 - * (Last changed on 12/ 2/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,GASDATA. 10.- +SEQ,PARAMETERS. 11.- +SEQ,DRIFTLINE. 12.- +SEQ,PRINTPLOT. 13 - REAL RES(1),VAR(MXVAR),QPLT,X0,Y0,FVAL,VOLT 14 - INTEGER MODRES(1),MODVAR(MXVAR),ILOC,ILOC1,IENTRY,ITYPE,I,IFAIL 15 - DOUBLE PRECISION F0(3),XPOS1,YPOS1,XPOS2,YPOS2 16 - LOGICAL EVALE,EVALB,EVALV,EVALT,EVALD,EVALA,EVALL,EVALP,LMCDR 17 - COMMON /CN2DAT/ IENTRY,EVALE,EVALB,EVALV,EVALT,EVALD,EVALA,EVALL, 18 - - EVALP,QPLT,ITYPE,LMCDR 19 - *** Ensure the location code is defined, also if EVALE is false. 20 - ILOC=0 21 - *** Transform the coordinates. 22 - VAR(1)= FPROJ(1,1)*X0+FPROJ(2,1)*Y0+FPROJ(3,1) 23 - VAR(2)= FPROJ(1,2)*X0+FPROJ(2,2)*Y0+FPROJ(3,2) 24 - VAR(23)=FPROJ(1,3)*X0+FPROJ(2,3)*Y0+FPROJ(3,3) 25 - *** Calculate the fields needed for the rest. 26 - IF(EVALE)CALL EFIELD(VAR(1),VAR(2),VAR(23), 27 - - VAR(3),VAR(4),VAR(5),VAR(6),VOLT,0,ILOC) 28 - IF(EVALB)CALL BFIELD(VAR(1),VAR(2),VAR(23), 29 - - VAR(7),VAR(8),VAR(9),VAR(10)) 30 - * Location code -5 (in a material) is acceptable for contours. 31 - IF(ILOC.EQ.-5.AND.LCNTAM)ILOC=0 32 - * Get the local drift velocity. 33 - IF(EVALV)THEN 34 - CALL DLCVEL(DBLE(VAR(1)),DBLE(VAR(2)),DBLE(VAR(23)), 35 - - F0,QPLT,ITYPE,ILOC1) 36 - VAR(11)=REAL(F0(1)) 37 - VAR(12)=REAL(F0(2)) 38 - VAR(13)=REAL(F0(3)) 39 - VAR(14)=SQRT(VAR(11)**2+VAR(12)**2+VAR(13)**2) 40 - ENDIF 41 - * Lorentz angle. 42 - IF(EVALE.AND.EVALV)VAR(15)=ACOS(MAX(-1.0,MIN(1.0, 43 - - REAL((VAR(3)*VAR(11)+VAR(4)*VAR(12)+VAR(5)*VAR(13))/ 44 - - (VAR(6)*VAR(14)))))) 45 - * Store drift line related quantities. 46 - IF(EVALT)THEN 47 - CALL DLCALC(VAR(1),VAR(2),VAR(23),QPLT,ITYPE) 48 - VAR(16)=TU(NU) 49 - IF(EVALP)THEN 50 - VAR(17)=0.0 51 - DO 10 I=2,NU 1 660 P=DRIFT D=DCONT 2 PAGE1004 52 - IF(POLAR)THEN 53 - CALL CF2RTC(XU(I-1),YU(I-1),XPOS1,YPOS1,1) 54 - CALL CF2RTC(XU(I) ,YU(I) ,XPOS2,YPOS2,1) 55 - VAR(17)=VAR(17)+SQRT((XPOS2-XPOS1)**2+ 56 - - (YPOS2-YPOS1)**2+(ZU(I)-ZU(I-1))**2) 57 - ELSE 58 - VAR(17)=VAR(17)+SQRT((XU(I)-XU(I-1))**2+ 59 - - (YU(I)-YU(I-1))**2+(ZU(I)-ZU(I-1))**2) 60 - ENDIF 61 - 10 CONTINUE 62 - ENDIF 63 - IF(EVALD)CALL DLCDIF(VAR(18)) 64 - IF(EVALA)CALL DLCTWN(VAR(19)) 65 - IF(EVALL)CALL DLCATT(VAR(20)) 66 - VAR(21)=ISTAT 67 - ENDIF 68 - * Store gas pressure. 69 - VAR(22)=PGAS 70 - * Transform vectors and covectors to polar coordinates if needed. 71 - IF(POLAR)THEN 72 - CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) 73 - VAR(3)=VAR(3)/VAR(1) 74 - VAR(4)=VAR(4)/VAR(1) 75 - VAR(6)=SQRT(VAR(3)**2+VAR(4)**2+VAR(5)**2) 76 - VAR(11)=VAR(11)*VAR(1) 77 - VAR(12)=VAR(12)*VAR(1) 78 - VAR(14)=SQRT(VAR(11)**2+VAR(12)**2+VAR(13)**2) 79 - ENDIF 80 - * Assign modes. 81 - DO 20 I=1,23 82 - MODVAR(I)=2 83 - 20 CONTINUE 84 - *** Evaluate the function 85 - CALL ALGEXE(IENTRY,VAR,MODVAR,23,RES,MODRES,1,IFAIL) 86 - * and return it to the contour routine. 87 - FVAL=RES(1) 88 - END 661 GARFIELD ================================================== P=DRIFT D=DCONT2 1 ============================ 0 + +DECK,DCONT2. 1 - SUBROUTINE DCONT2(X0,Y0,Z0,FVAL,ILOC) 2 - *----------------------------------------------------------------------- 3 - * DCONT2 - Returns the function value for the graphs. 4 - * (Last changed on 12/ 2/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,GASDATA. 10.- +SEQ,PARAMETERS. 11.- +SEQ,DRIFTLINE. 12.- +SEQ,PRINTPLOT. 13 - REAL RES(1),VAR(MXVAR),QPLT,X0,Y0,Z0,FVAL,VOLT 14 - INTEGER MODRES(1),MODVAR(MXVAR),ILOC,ILOC1,IENTRY,ITYPE,I,IFAIL 15 - DOUBLE PRECISION F0(3),XPOS1,YPOS1,XPOS2,YPOS2 16 - LOGICAL EVALE,EVALB,EVALV,EVALT,EVALD,EVALA,EVALL,EVALP,LMCDR 17 - COMMON /CN2DAT/ IENTRY,EVALE,EVALB,EVALV,EVALT,EVALD,EVALA,EVALL, 18 - - EVALP,QPLT,ITYPE,LMCDR 19 - *** Ensure the location code is defined, also if EVALE is false. 20 - ILOC=0 21 - *** Transform the coordinates. 22 - VAR(1)= X0 23 - VAR(2)= Y0 24 - VAR(23)=Z0 25 - *** Calculate the fields needed for the rest. 26 - IF(EVALE)CALL EFIELD(VAR(1),VAR(2),VAR(23), 27 - - VAR(3),VAR(4),VAR(5),VAR(6),VOLT,0,ILOC) 28 - IF(EVALB)CALL BFIELD(VAR(1),VAR(2),VAR(23), 29 - - VAR(7),VAR(8),VAR(9),VAR(10)) 30 - * Location code -5 (in a material) is acceptable for contours. 31 - IF(ILOC.EQ.-5.AND.LCNTAM)ILOC=0 32 - * Get the local drift velocity. 33 - IF(EVALV)THEN 34 - CALL DLCVEL(DBLE(VAR(1)),DBLE(VAR(2)),DBLE(VAR(23)), 35 - - F0,QPLT,ITYPE,ILOC1) 36 - VAR(11)=REAL(F0(1)) 37 - VAR(12)=REAL(F0(2)) 38 - VAR(13)=REAL(F0(3)) 39 - VAR(14)=SQRT(VAR(11)**2+VAR(12)**2+VAR(13)**2) 40 - ENDIF 41 - * Lorentz angle. 42 - IF(EVALE.AND.EVALV)VAR(15)=ACOS(MAX(-1.0,MIN(1.0, 43 - - REAL((VAR(3)*VAR(11)+VAR(4)*VAR(12)+VAR(5)*VAR(13))/ 44 - - (VAR(6)*VAR(14)))))) 45 - * Store drift line related quantities. 46 - IF(EVALT)THEN 47 - IF(LMCDR)THEN 48 - CALL DLCMC(VAR(1),VAR(2),VAR(23),QPLT,ITYPE) 49 - ELSE 50 - CALL DLCALC(VAR(1),VAR(2),VAR(23),QPLT,ITYPE) 51 - ENDIF 52 - VAR(16)=TU(NU) 53 - IF(EVALP)THEN 54 - VAR(17)=0.0 55 - DO 10 I=2,NU 56 - IF(POLAR)THEN 57 - CALL CF2RTC(XU(I-1),YU(I-1),XPOS1,YPOS1,1) 58 - CALL CF2RTC(XU(I) ,YU(I) ,XPOS2,YPOS2,1) 59 - VAR(17)=VAR(17)+SQRT((XPOS2-XPOS1)**2+ 60 - - (YPOS2-YPOS1)**2+(ZU(I)-ZU(I-1))**2) 61 - ELSE 62 - VAR(17)=VAR(17)+SQRT((XU(I)-XU(I-1))**2+ 63 - - (YU(I)-YU(I-1))**2+(ZU(I)-ZU(I-1))**2) 64 - ENDIF 65 - 10 CONTINUE 1 661 P=DRIFT D=DCONT2 2 PAGE1005 66 - ENDIF 67 - IF(EVALD)CALL DLCDIF(VAR(18)) 68 - IF(EVALA)CALL DLCTWN(VAR(19)) 69 - IF(EVALL)CALL DLCATT(VAR(20)) 70 - VAR(21)=ISTAT 71 - ENDIF 72 - * Store gas pressure. 73 - VAR(22)=PGAS 74 - * Transform vectors and covectors to polar coordinates if needed. 75 - IF(POLAR)THEN 76 - CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) 77 - VAR(3)=VAR(3)/VAR(1) 78 - VAR(4)=VAR(4)/VAR(1) 79 - VAR(6)=SQRT(VAR(3)**2+VAR(4)**2+VAR(5)**2) 80 - VAR(11)=VAR(11)*VAR(1) 81 - VAR(12)=VAR(12)*VAR(1) 82 - VAR(14)=SQRT(VAR(11)**2+VAR(12)**2+VAR(13)**2) 83 - ENDIF 84 - * Assign modes. 85 - DO 20 I=1,23 86 - MODVAR(I)=2 87 - 20 CONTINUE 88 - *** Evaluate the function 89 - CALL ALGEXE(IENTRY,VAR,MODVAR,23,RES,MODRES,1,IFAIL) 90 - * and return it to the contour routine. 91 - FVAL=RES(1) 92 - END 662 GARFIELD ================================================== P=DRIFT D=DRFTAB 1 ============================ 0 + +DECK,DRFTAB. 1 - SUBROUTINE DRFTAB 2 - *----------------------------------------------------------------------- 3 - * DRFTAB - Subroutine calculating and plotting drift lines given an 4 - * electric field. This routine lets the drift lines start on 5 - * a grid between (DXMIN,DYMIN) and (DXMAX,DYMAX) 6 - * VARIABLES : DTT : The drift time table 7 - * LCONT : if .TRUE. plot contours 8 - * LTABLE : if .TRUE. print the drift time table 9 - * CHTS : used by NAG routine, contour heights 10 - * (Last changed on 5/11/97.) 11 - *----------------------------------------------------------------------- 12.- +SEQ,DIMENSIONS. 13.- +SEQ,PARAMETERS. 14.- +SEQ,CELLDATA. 15.- +SEQ,GASDATA. 16.- +SEQ,CONSTANTS. 17.- +SEQ,PRINTPLOT. 18.- +SEQ,DRIFTLINE. 19 - CHARACTER*80 STATUS 20 - LOGICAL LCONT,LTABLE 21 - INTEGER NC,ITYPE 22 - REAL Q,XSTART,YSTART 0 23-+ +SELF,IF=-HIGZ. 24 - DOUBLE PRECISION DTT(MXWIRE,MXWIRE),CHTS(MXWIRE),DUM(3*MXWIRE+3) 25 - COMMON /MATRIX/ DTT,CHTS,DUM 0 26-+ +SELF,IF=HIGZ. 27 - REAL DTT,PAR,DUM 28 - COMMON /MATRIX/ DTT(MXWIRE,MXWIRE),PAR(37), 29 - - DUM(MXWIRE**2+8*MXWIRE-31) 0 30-+ +SELF,IF=NAG. 31 - COMMON /LWSCOM/ LWS 32 - LOGICAL LWS(MXWIRE**2) 33 - EXTERNAL J06GBY,J06GBV 0 34-+ +SELF,IF=SAVE. 35 - SAVE ITYPE,Q,LCONT,LTABLE 0 36-+ +SELF. 37 - *** Preset the charge, particle type and the output options. 38 - DATA ITYPE / 1/ 39 - DATA Q / -1.0/ 40 - DATA LCONT /.FALSE./ 41 - DATA LTABLE/ .TRUE./ 42 - *** Define some formats. 43 - 1070 FORMAT('1DRIFT-TABLE',110X,'PART ',I1,'.',I1/122X,'========'// 44 - - ' Y X:',10(E11.4,1X:)) 45 - 1075 FORMAT('1DRIFT-TABLE',110X,'PART ',I1,'.',I1/122X,'========'// 46 - - ' Phi R:',10(E11.4,1X:)) 47 - 1080 FORMAT('1 List of drift lines used for the table:',/, 48 - - ' ======================================',//, 49 - - ' x-start y-start steps drift time', 50 - - ' remarks',/, 51 - - ' [cm] [cm] [microsec]'//) 52 - 1085 FORMAT('1 List of drift lines used for the table:',/, 53 - - ' ======================================',//, 54 - - ' r-start phi-start steps drift time', 55 - - ' remarks',/, 56 - - ' [cm] [degrees] [microsec]'//) 57 - *** Print a heading, if requested. 58 - IF(LIDENT)PRINT *,' /// ROUTINE DRFTAB ///' 59 - *** Have a look at the input string 60 - CALL INPNUM(NWORD) 61 - DO 10 I=2,NWORD 62 - IF(INPCMP(I,'NOCONT#OUR').NE.0)THEN 63 - LCONT=.FALSE. 64 - ELSEIF(INPCMP(I,'CONT#OUR').NE.0)THEN 65 - LCONT=.TRUE. 1 662 P=DRIFT D=DRFTAB 2 PAGE1006 66-+ +SELF,IF=-NAG,IF=-HIGZ. 67 - CALL INPMSG(I,'only in NAG/HIGZ compilations.') 68 - LCONT=.FALSE. 0 69-+ +SELF. 70 - ELSEIF(INPCMP(I,'NOTAB#LE').NE.0)THEN 71 - LTABLE=.FALSE. 72 - ELSEIF(INPCMP(I,'TAB#LE').NE.0)THEN 73 - LTABLE=.TRUE. 74 - ELSEIF(INPCMP(I,'I#ON').NE.0)THEN 75 - IF(GASOK(2))THEN 76 - ITYPE=2 77 - Q=+1 78 - ELSE 79 - CALL INPMSG(I,'ion mobility data missing. ') 80 - ENDIF 81 - ELSEIF(INPCMP(I,'E#LECTRON').NE.0)THEN 82 - ITYPE=1 83 - Q=-1 84 - ELSEIF(INPCMP(I,'POS#ITIVE').NE.0)THEN 85 - Q=+1 86 - ELSEIF(INPCMP(I,'NEG#ATIVE').NE.0)THEN 87 - Q=-1 88 - ELSE 89 - CALL INPMSG(I,'the option is not known. ') 90 - ENDIF 91 - 10 CONTINUE 92 - CALL INPERR 93 - *** Make sure there is at least some output. 94 - IF(.NOT.(LTABLE.OR.LCONT))THEN 95 - PRINT *,' !!!!!! DRFTAB WARNING : Neither TABLE nor'// 96 - - ' CONTOUR output requested; routine not executed.' 97 - RETURN 98 - ENDIF 99 - *** Allocate storage for the matrix. 100 - CALL BOOK('BOOK','MATRIX','DTT',IFAIL) 101 - IF(IFAIL.NE.0)THEN 102 - PRINT *,' !!!!!! DRFTAB WARNING : Unable to allocate'// 103 - - ' storage for the drift time table.' 104 - PRINT *,' Neither the table'// 105 - - ' nor the plot will be made.' 106 - RETURN 107 - ENDIF 108 - *** Print a heading for the table, depending on the coordinate system. 109 - IF(LDRPRT)THEN 110 - IF(.NOT.POLAR)WRITE(LUNOUT,1080) 111 - IF(POLAR)WRITE(LUNOUT,1085) 112 - ENDIF 113 - *** Prepare a plot (layout, frame number etc). 114 - IF(LDRPLT)THEN 115 - CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, 116 - - 'DRIFT LINES FOR A DRIFT TIME TABLE ') 117 - CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) 118 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 119 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 120 - CALL GRCOMM(3,'Drifting: electrons') 121 - CALL GRALOG('Drift lines for timing table. ') 122 - ENDIF 123 - *** Start drift lines from all over the grid, 124 - DO 20 I=1,NGRIDX 125 - DO 30 J=1,NGRIDY 126 - IF(POLAR)THEN 127 - XSTART=LOG(EXP(DXMIN)+REAL(I-1)*(EXP(DXMAX)-EXP(DXMIN))/ 128 - - REAL(NGRIDX-1)) 129 - ELSE 130 - XSTART=DXMIN+REAL(I-1)*(DXMAX-DXMIN)/REAL(NGRIDX-1) 131 - ENDIF 132 - YSTART=DYMIN+REAL(J-1)*(DYMAX-DYMIN)/REAL(NGRIDY-1) 133 - * calculate the drift line starting at (XSTART,YSTART), 134 - CALL DLCALC(XSTART,YSTART,0.0,Q,ITYPE) 135 - * and store the drift time in an array, 136 - DTT(I,J)=TU(NU) 137 - * print information on this drift line if requested, 138 - IF(LDRPRT)THEN 139 - IF(POLAR)CALL CFMRTP(XSTART,YSTART,XSTART,YSTART,1) 140 - CALL DLCSTF(ISTAT,STATUS,NC) 141 - WRITE(LUNOUT,'(1X,F10.3,1X,F10.3,I10,1X,E12.5,2X,A)') 142 - - XSTART,YSTART,NU,TU(NU),STATUS(1:NC) 143 - ENDIF 144 - * and plot the drift line obtained - if this is requested. 145 - IF(LDRPLT.AND.NU.GT.1)THEN 146 - IF(POLAR)CALL CF2RTC(XU,YU,XU,YU,NU) 147 - IF(NU.GT.1)CALL GPL2(NU,XU,YU) 148 - ENDIF 149 - 30 CONTINUE 150 - 20 CONTINUE 151 - *** Clear the screen if the drift lines have been plotted. 152 - IF(LDRPLT)CALL GRNEXT 153 - *** Print the table just obtained, if requested. 154 - IF(LTABLE)THEN 155 - DO 110 JJ=0,10*INT(REAL(NGRIDY-1)/10.0),10 156 - JMAX=MIN(NGRIDY-JJ,10) 157 - DO 120 II=0,10*INT(REAL(NGRIDX-1)/10.0),10 158 - IMAX=MIN(NGRIDX-II,10) 159 - IF(.NOT.POLAR)THEN 160 - WRITE(LUNOUT,1070) 1+II/10,1+JJ/10, 161 - - (DXMIN+(DXMAX-DXMIN)*REAL(II+I-1)/REAL(NGRIDX-1), 162 - - I=1,IMAX) 163 - ELSE 164 - WRITE(LUNOUT,1075) 1+II/10,1+JJ/10,(EXP(DXMIN)+ 165 - - (EXP(DXMAX)-EXP(DXMIN))*REAL(II+I-1)/ 166 - - REAL(NGRIDX-1),I=1,IMAX) 167 - ENDIF 168 - WRITE(LUNOUT,'('' '')') 169 - DO 130 J=1,JMAX 170 - YPOS=DYMIN+(DYMAX-DYMIN)*REAL(JJ+J-1)/REAL(NGRIDY-1) 1 662 P=DRIFT D=DRFTAB 3 PAGE1007 171 - IF(POLAR)THEN 172 - WRITE(LUNOUT,'(1X,E10.3)') YPOS*180.0/PI 173 - ELSE 174 - WRITE(LUNOUT,'(1X,E10.3)') YPOS 175 - ENDIF 176 - WRITE(LUNOUT,'(12X,10(E11.4,1X:))') 177 - - (REAL(DTT(II+I,JJ+J)),I=1,IMAX) 178 - 130 CONTINUE 179 - 120 CONTINUE 180 - 110 CONTINUE 181 - ENDIF 0 182-+ +SELF,IF=NAG. 183 - IF(LCONT)THEN 184 - * Store the CH eXPansion, NAG has the nasty habit of changing it. 185 - CALL GQCHXP(IERR,CHEXP) 186 - IF(IERR.NE.0)CHEXP=1.0 187 - * Initialize NAG. 188 - CALL X04AAF(1,10) 189 - CALL J06XAF 190 - IF(.NOT.POLAR)THEN 191 - CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, 192 - - 'CONTOURS OF THE DRIFT TIME ') 193 - CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) 194 - CALL J06WBF(DBLE(DXMIN),DBLE(DXMAX),DBLE(DYMIN), 195 - - DBLE(DYMAX),0) 196 - ELSE 197 - CALL CFMRTP(DXMIN,DYMIN,DXMINP,DYMINP,1) 198 - CALL CFMRTP(DXMAX,DYMAX,DXMAXP,DYMAXP,1) 199 - CALL GRCART(DXMINP,DYMINP,DXMAXP,DYMAXP, 200 - - ' Radial distance [cm]', 201 - - ' Angle [degrees]', 202 - - 'CONTOURS OF THE DRIFT TIME ') 203 - CALL J06WBF(DBLE(DXMINP),DBLE(DXMAXP),DBLE(DYMINP), 204 - - DBLE(DYMAXP),0) 205 - ENDIF 206 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 207 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 208 - CALL J06WCF(0.1D0,0.9D0,0.1D0,0.9D0) 209 - NCHTS=10 210 - IFAIL=1 211 - IF(LKEYPL)THEN 212 - ILAB=1 213 - ELSE 214 - ILAB=0 215 - ENDIF 216 - CALL J06GBF(DTT,MXWIRE,1,NGRIDX,1,NGRIDY,NCHTS,CHTS,0, 217 - - J06GBY,ILAB,0,J06GBV,0,LWS,IFAIL) 218 - CALL GRNEXT 219 - *** Check the error condition returned by J06GBF. 220 - IF(IFAIL.EQ.1.OR.IFAIL.EQ.2)THEN 221 - PRINT *,' !!!!!! DRFTAB WARNING : Incorect input'// 222 - - ' parameters to J06GBF (program bug).' 223 - ELSEIF(IFAIL.NE.0)THEN 224 - PRINT *,' !!!!!! DRFTAB WARNING : Unknown error flag', 225 - - IFAIL,' returned by NAG routine J06GBF.' 226 - ENDIF 227 - * plot a contour table, if this has been requested. 228 - IF(LKEYPL)THEN 229 - CALL GRGRAF(.TRUE.) 230 - CALL J06GZF(CHTS,NCHTS,1,10,3) 231 - CALL GRALOG('Legend of the contour heights. ') 232 - CALL GRNEXT 233 - ENDIF 234 - * Reset the CH eXPension factor to the original value, 235 - CALL GSCHXP(CHEXP) 236 - ENDIF 0 237-+ +SELF,IF=HIGZ. 238 - IF(LCONT)THEN 239 - * Check that the surface is not flat. 240 - IFLAT=1 241 - CZMIN=DTT(1,1) 242 - CZMAX=DTT(1,1) 243 - DO 80 ICHK=1,NGRIDX 244 - DO 70 JCHK=1,NGRIDY 245 - IF(ABS(DTT(ICHK,JCHK)-DTT(1,1)).GT.1.0E-5* 246 - - (1.0+ABS(DTT(ICHK,JCHK))+ABS(DTT(1,1))))IFLAT=0 247 - CZMIN=MIN(CZMIN,DTT(1,1)) 248 - CZMAX=MAX(CZMAX,DTT(1,1)) 249 - 70 CONTINUE 250 - 80 CONTINUE 251 - IF(IFLAT.NE.0)THEN 252 - PRINT *,' !!!!!! DRFTAB WARNING : Contours not'// 253 - - ' not plotted, all values identical.' 254 - GOTO 90 255 - ENDIF 256 - * Switch the screen to graphics mode. 257 - CALL GRGRAF(.TRUE.) 258 - * Fill the PAR vector. 259 - PAR(1)=20 260 - PAR(2)=0 261 - PAR(3)=DXMIN 262 - PAR(4)=DXMAX 263 - PAR(5)=DYMIN 264 - PAR(6)=DYMAX 265 - PAR(7)=CZMIN 266 - PAR(8)=CZMAX 267 - PAR(9)=1000+NGRIDX 268 - PAR(10)=1000+NGRIDY 269 - * Plot a frame for the contours. 270 - IF(.NOT.POLAR)THEN 271 - CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, 272 - - 'CONTOURS OF THE DRIFT TIME ') 273 - CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) 274 - PAR(3)=DXMIN 1 662 P=DRIFT D=DRFTAB 4 PAGE1008 275 - PAR(4)=DXMAX 276 - PAR(5)=DYMIN 277 - PAR(6)=DYMAX 278 - ELSE 279 - CALL CFMRTP(DXMIN,DYMIN,DXMINP,DYMINP,1) 280 - CALL CFMRTP(DXMAX,DYMAX,DXMAXP,DYMAXP,1) 281 - CALL GRCART(DXMINP,DYMINP,DXMAXP,DYMAXP, 282 - - ' Radial distance [cm]', 283 - - ' Angle [degrees]', 284 - - 'CONTOURS OF THE DRIFT TIME ') 285 - PAR(3)=DXMINP 286 - PAR(4)=DXMAXP 287 - PAR(5)=DYMINP 288 - PAR(6)=DYMAXP 289 - ENDIF 290 - * Plot the contours. 291 - CALL ISVP(1,0.1,0.9,0.1,0.9) 292 - CALL ISWN(1,0.0,1.0,0.0,1.0) 293 - CALL ISELNT(1) 294 - CALL IGTABL(MXWIRE,MXWIRE,DTT,10,PAR,'C') 295 - * Close the plot. 296 - CALL GRNEXT 297 - * Record what happened. 298 - CALL GRALOG('Drift time table contours.') 299 - * Continue here in case of a flat function. 300 - 90 CONTINUE 301 - ENDIF 0 302-+ +SELF. 303 - *** Deallocate the matrix. 304 - CALL BOOK('RELEASE','MATRIX','DTT',IFAIL) 305 - *** Register the amount of CPU time used for calculating drift lines. 306 - CALL TIMLOG('Drift lines for timing table: ') 307 - END 663 GARFIELD ================================================== P=DRIFT D=DRFXTP 1 ============================ 0 + +DECK,DRFXTP. 1 - SUBROUTINE DRFXTP 2 - *----------------------------------------------------------------------- 3 - * DRFXTP - Routine plotting and printing x(t) correlation plots for 4 - * all selected wires in the drift area. 5 - * VARIABLES : STRING : (Part of) the command; the header record. 6 - * INFILE : Used for producing comment strings. 7 - * LXTWRT : TRUE if the x(t) data are to be written. 8 - * FILE : Name of the x(t) data set, length NCFILE. 9 - * MEMBER : Member name, length NCMEMB. 10 - * REMARK : Remark field of the header, length NCREM. 11 - * DATE, TIME : Clock date and time (header record). 12 - * XSTEP : Sampling step size. 13 - * ANGLE : x(t) angle with the y-axis. 14 - * JUMP : Number of points to be interpolated. 15 - * ITERMX : Max number of minimisation loops. 16 - * A.L/R.MIN/MAX : Search angle limits. 17 - * P, Q, R(REF): Lines are represented as Px+Qy=R. 18 - * PRECIS : Tells whether an XT entry is enterpolated. 19 - * IXM, IXP : Sampling is done at X(I)+I*XSTEP I=IXM,IXP 20 - * XT( . , ) : 1-3: time, 4-6: C coordinate, 7: diffusion 21 - * TPARA, CPARA: Minimum of the fitted parabola. 22 - * (Last changed on 8/ 9/98.) 23 - *----------------------------------------------------------------------- 24 - implicit none 25.- +SEQ,DIMENSIONS. 26.- +SEQ,DRIFTLINE. 27.- +SEQ,CELLDATA. 28.- +SEQ,GASDATA. 29.- +SEQ,PRINTPLOT. 30.- +SEQ,PARAMETERS. 31.- +SEQ,CONSTANTS. 32 - REAL XT(7,MXLIST),XPL(MXLIST),YPL(MXLIST),ANG,QCHARG,P,Q,REF, 33 - - GRSMIN,GRSMAX,GMINR,GMAXR,XSTEP,XSTEPR,XXSTEP,XTXMIN,XTXMAX, 34 - - ANGLE,ANGLER,EPS,EPSR,CXTMIN,CXTMAX,RDIST,CPARA,TPARA, 35 - - CDRIFT,TDRIFT,ALMIN,ALMAX,ALMINR,ALMAXR,ARMIN,ARMAX, 36 - - ARMINR,ARMAXR,TMIN,TMAX,XTAUX,XTXMIR,XTXMAR,CSTEP 37 - INTEGER NXT(MXLIST),IXTFLG(MXLIST),NCFILE,NCMEMB,NCREM,KX,NWORD, 38 - - I,J,INEXT,ITERMX,ITERMR,JUMPR,JUMP,IFAIL,IFAIL1,IFAIL2,NDLC, 39 - - IXM,IXP,IIX,IX,JJX,JX,ISET,JSET,IANG,ITERSK,IMIN,ITAB,JTAB, 40 - - IOS,NPLOT,ITER,IFLAG,IIMIN,II,INPCMP,INXT 41 - LOGICAL XTSET(MXLIST),PRECIS(3),FLAG(MXWORD+3),LXTWRT,PRAUX, 42 - - LXTPRT,LXTPLT,EXMEMB 43 - CHARACTER*132 OUTSTR 44 - CHARACTER*80 STRING 45 - CHARACTER*30 INFILE 46 - CHARACTER*29 REMARK 47 - CHARACTER*(MXNAME) FILE 48 - CHARACTER*8 DATE,TIME,MEMBER 49 - EXTERNAL INPCMP 0 50-+ +SELF,IF=SAVE. 51 - SAVE ANGLE,JUMP,ITERMX,EPS,ALMIN,ALMAX,ARMIN,ARMAX 0 52-+ +SELF. 53 - *** Initialise the parameters to be remembered via DATA statements. 54 - DATA ANGLE /0.0/ 55 - DATA JUMP,ITERMX /1,5/ 56 - DATA EPS /1.0E-3/ 57 - DATA ALMIN,ALMAX,ARMIN,ARMAX /-90.0,90.0,-90.0,90.0/ 58 - DATA LXTPRT,LXTPLT /.TRUE.,.TRUE./ 59 - *** Define some formats. 60 - 1080 FORMAT('Angle to y =',F8.2,' degrees ') 61 - 1090 FORMAT('Wire no =',I3,' (type ',A1,') ') 62 - *** Identify the routine. 63 - IF(LIDENT)PRINT *,' /// ROUTINE DRFXTP ///' 64 - *** Preset some of the arguments. 65 - FILE=' ' 66 - MEMBER='< none >' 1 663 P=DRIFT D=DRFXTP 2 PAGE1009 67 - REMARK='None' 68 - NCFILE=1 69 - NCMEMB=8 70 - NCREM=4 71 - LXTWRT=.FALSE. 72 - GRSMIN=+1.0 73 - GRSMAX=-1.0 74 - * And obtain a rounded default value for the x-step. 75 - XSTEP=(DXMAX-DXMIN)/20.0 76 - KX=NINT(LOG10(XSTEP)) 77 - IF(KX.GE.0)THEN 78 - XSTEP=XSTEP/10.0**KX 79 - ELSE 80 - XSTEP=XSTEP*10.0**(-KX) 81 - ENDIF 82 - IF(XSTEP.GE.0.1.AND.XSTEP.LT.0.2)THEN 83 - XXSTEP=0.1 84 - ELSEIF(XSTEP.GE.0.2.AND.XSTEP.LT.0.5)THEN 85 - XXSTEP=0.2 86 - ELSEIF(XSTEP.GE.0.5.AND.XSTEP.LT.1.0)THEN 87 - XXSTEP=0.5 88 - ELSEIF(XSTEP.GE.1.0.AND.XSTEP.LT.2.0)THEN 89 - XXSTEP=1.0 90 - ELSEIF(XSTEP.GE.2.0.AND.XSTEP.LT.5.0)THEN 91 - XXSTEP=2.0 92 - ELSEIF(XSTEP.GE.5.0.AND.XSTEP.LT.10.0)THEN 93 - XXSTEP=5.0 94 - ELSE 95 - PRINT *,' !!!!!! DRFXTP WARNING : Unable to find a default', 96 - - ' x-step; set to 1.' 97 - XXSTEP=1.0 98 - ENDIF 99 - IF(KX.GE.0)THEN 100 - XSTEP=XXSTEP*10.0**KX 101 - ELSE 102 - XSTEP=XXSTEP/10.0**(-KX) 103 - ENDIF 104 - * Finally also set the range in x to the full range. 105 - XTXMIN=DXMIN 106 - XTXMAX=DXMAX 107 - *** Extract the parameters from the input. 108 - CALL INPNUM(NWORD) 109 - * Initialise the FLAG array. 110 - DO 10 I=1,MXWORD+3 111 - IF(I.LE.NWORD)THEN 112 - FLAG(I)=.FALSE. 113 - ELSE 114 - FLAG(I)=.TRUE. 115 - ENDIF 116 - 10 CONTINUE 117 - * Mark the keywords. 118 - DO 20 I=1,NWORD 119 - IF(INPCMP(I,'ANG#LE')+INPCMP(I,'D#ATASET')+INPCMP(I,'J#UMP')+ 120 - - INPCMP(I,'L#EFT-#ANGLE-#RANGE')+INPCMP(I,'NO#NE')+ 121 - - INPCMP(I,'IT#ERATIONS')+INPCMP(I,'OFF')+ 122 - - INPCMP(I,'PREC#ISION')+INPCMP(I,'RAN#GE')+ 123 - - INPCMP(I,'REM#ARK')+INPCMP(I,'RI#GHT-#ANGLE-#RANGE')+ 124 - - INPCMP(I,'ST#EP')+INPCMP(I,'SC#ALE')+ 125 - - INPCMP(I,'PR#INT-#XT-#RELATION')+ 126 - - INPCMP(I,'NOPR#INT-#XT-#RELATION')+ 127 - - INPCMP(I,'PL#OT-#XT-#RELATION')+ 128 - - INPCMP(I,'NOPL#OT-#XT-#RELATION')+ 129 - - INPCMP(I,'X-ST#EP')+ 130 - - INPCMP(I,'X-R#ANGE').NE.0)FLAG(I)=.TRUE. 131 - 20 CONTINUE 132 - ** Next interpret the words. 133 - INEXT=2 134 - DO 30 I=2,NWORD 135 - IF(I.LT.INEXT)GOTO 30 136 - * Look for the ANGLE at which the tracks are going to be. 137 - IF(INPCMP(I,'ANG#LE').NE.0)THEN 138 - IF(FLAG(I+1))THEN 139 - CALL INPMSG(I,'the argument is missing. ') 140 - ELSE 141 - CALL INPCHK(I+1,2,IFAIL) 142 - CALL INPRDR(I+1,ANGLER,0.0) 143 - IF(ABS(ANGLER).GT.90.0.AND.IFAIL.EQ.0)THEN 144 - CALL INPMSG(I+1,'Too large an angle (Max = 90).') 145 - ELSEIF(IFAIL.EQ.0)THEN 146 - ANGLE=ANGLER 147 - ENDIF 148 - INEXT=I+2 149 - ENDIF 150 - * Look for a DATASET (and perhaps a member) receiving the x(t)'s. 151 - ELSEIF(INPCMP(I,'D#ATASET').NE.0)THEN 152 - IF(FLAG(I+1))THEN 153 - CALL INPMSG(I,'the dataset name is missing. ') 154 - ELSE 155 - CALL INPSTR(I+1,I+1,STRING,NCFILE) 156 - FILE=STRING 157 - IF(.NOT.FLAG(I+2))THEN 158 - CALL INPSTR(I+2,I+2,STRING,NCMEMB) 159 - MEMBER=STRING 160 - INEXT=I+3 161 - ELSE 162 - INEXT=I+2 163 - ENDIF 164 - LXTWRT=.TRUE. 165 - ENDIF 166 - * Look for the number of ITERATION cycles. 167 - ELSEIF(INPCMP(I,'IT#ERATIONS').NE.0)THEN 168 - IF(INPCMP(I+1,'OFF')+INPCMP(I+1,'NO#NE').NE.0)THEN 169 - ITERMX=0 170 - INEXT=I+2 171 - ELSEIF(FLAG(I+1))THEN 172 - CALL INPMSG(I,'Argument (n or OFF) missing. ') 1 663 P=DRIFT D=DRFXTP 3 PAGE1010 173 - ELSE 174 - CALL INPCHK(I+1,1,IFAIL) 175 - CALL INPRDI(I+1,ITERMR,5) 176 - IF(IFAIL.EQ.0.AND.ITERMR.LT.0)THEN 177 - CALL INPMSG(I+1,'Should be a positive integer. ') 178 - ELSEIF(IFAIL.EQ.0)THEN 179 - ITERMX=ITERMR 180 - ENDIF 181 - INEXT=I+2 182 - ENDIF 183 - * Look for the number of intermediate points to be JUMPed. 184 - ELSEIF(INPCMP(I,'J#UMP').NE.0)THEN 185 - IF(FLAG(I+1))THEN 186 - CALL INPMSG(I,'the argument is missing. ') 187 - ELSE 188 - CALL INPCHK(I+1,1,IFAIL) 189 - CALL INPRDI(I+1,JUMPR,10) 190 - IF(JUMPR.LE.0.AND.IFAIL.EQ.0)THEN 191 - CALL INPMSG(I+1,'should be a positive number. ') 192 - ELSEIF(IFAIL.EQ.0)THEN 193 - JUMP=JUMPR 194 - ENDIF 195 - INEXT=I+2 196 - ENDIF 197 - * Look for the LEFT-ANGLE-RANGE. 198 - ELSEIF(INPCMP(I,'L#EFT-#ANGLE-#RANGE').NE.0)THEN 199 - IF(FLAG(I+1).OR.FLAG(I+2))THEN 200 - CALL INPMSG(I,'The angle-range is incomplete.') 201 - IF(.NOT.FLAG(I+1).AND.FLAG(I+2))INEXT=I+2 202 - ELSE 203 - CALL INPCHK(I+1,2,IFAIL1) 204 - CALL INPCHK(I+2,2,IFAIL2) 205 - CALL INPRDR(I+1,ALMINR,ALMIN) 206 - CALL INPRDR(I+2,ALMAXR,ALMAX) 207 - IF(ABS(ALMINR).GT.90.0.AND.IFAIL1.EQ.0)THEN 208 - CALL INPMSG(I,'See the next message. ') 209 - CALL INPMSG(I+1,'Not between -90 and +90 degr. ') 210 - ELSEIF(ABS(ALMAXR).GT.90.0.AND.IFAIL2.EQ.0)THEN 211 - CALL INPMSG(I,'See the next message. ') 212 - CALL INPMSG(I+2,'Not between -90 and +90 degr. ') 213 - ELSEIF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN 214 - ALMIN=MIN(ALMINR,ALMAXR) 215 - ALMAX=MAX(ALMINR,ALMAXR) 216 - ENDIF 217 - INEXT=I+3 218 - ENDIF 219 - * Look for the PRECISION (convergence parameter). 220 - ELSEIF(INPCMP(I,'PREC#ISION').NE.0)THEN 221 - IF(FLAG(I+1))THEN 222 - CALL INPMSG(I,'The argument is missing. ') 223 - ELSE 224 - CALL INPCHK(I+1,2,IFAIL) 225 - CALL INPRDR(I+1,EPSR,EPS) 226 - IF(EPSR.LE.0.AND.IFAIL.EQ.0)THEN 227 - CALL INPMSG(I+1,'Should be a positive number. ') 228 - ELSEIF(IFAIL.EQ.0)THEN 229 - EPS=EPSR 230 - ENDIF 231 - INEXT=I+2 232 - ENDIF 233 - * Look for a REMARK replacing the default remark in the header, 234 - ELSEIF(INPCMP(I,'REM#ARK').NE.0)THEN 235 - IF(FLAG(I+1))THEN 236 - CALL INPMSG(I,'No remark has been found. ') 237 - ELSE 238 - CALL INPSTR(I+1,I+1,STRING,NCREM) 239 - REMARK=STRING(1:NCREM) 240 - INEXT=I+2 241 - ENDIF 242 - * Look for the RIGHT-ANGLE-RANGE. 243 - ELSEIF(INPCMP(I,'RI#GHT-#ANGLE-#RANGE').NE.0)THEN 244 - IF(FLAG(I+1).OR.FLAG(I+2))THEN 245 - CALL INPMSG(I,'The angle-range is incomplete.') 246 - IF(.NOT.FLAG(I+1).AND.FLAG(I+2))INEXT=I+2 247 - ELSE 248 - CALL INPCHK(I+1,2,IFAIL1) 249 - CALL INPCHK(I+2,2,IFAIL2) 250 - CALL INPRDR(I+1,ARMINR,ARMIN) 251 - CALL INPRDR(I+2,ARMAXR,ARMAX) 252 - IF(ABS(ARMINR).GT.90.0.AND.IFAIL1.EQ.0)THEN 253 - CALL INPMSG(I,'See the next message. ') 254 - CALL INPMSG(I+1,'Not between -90 and +90 degr. ') 255 - ELSEIF(ABS(ARMAXR).GT.90.0.AND.IFAIL2.EQ.0)THEN 256 - CALL INPMSG(I,'See the next message. ') 257 - CALL INPMSG(I+2,'Not between -90 and +90 degr. ') 258 - ELSEIF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN 259 - ARMIN=MIN(ARMINR,ARMAXR) 260 - ARMAX=MAX(ARMINR,ARMAXR) 261 - ENDIF 262 - INEXT=I+3 263 - ENDIF 264 - * Look for the plotting scale. 265 - ELSEIF(INPCMP(I,'SC#ALE').NE.0)THEN 266 - IF(FLAG(I+1).OR.FLAG(I+2))THEN 267 - CALL INPMSG(I,'the arguments are missing. ') 268 - ELSE 269 - CALL INPCHK(I+1,2,IFAIL1) 270 - CALL INPRDR(I+1,GMINR,+1.0) 271 - CALL INPCHK(I+2,2,IFAIL2) 272 - CALL INPRDR(I+2,GMAXR,-1.0) 273 - IF(GMINR.EQ.GMAXR)THEN 274 - CALL INPMSG(I+1,'zero range in the') 275 - CALL INPMSG(I+2,'scale not permitted') 276 - ELSE 277 - GRSMIN=MIN(GMINR,GMAXR) 278 - GRSMAX=MAX(GMINR,GMAXR) 1 663 P=DRIFT D=DRFXTP 4 PAGE1011 279 - ENDIF 280 - INEXT=I+3 281 - ENDIF 282 - * Look for a X-STEP size, if the default is not suitable. 283 - ELSEIF(INPCMP(I,'X-ST#EP')+INPCMP(I,'ST#EP').NE.0)THEN 284 - IF(FLAG(I+1))THEN 285 - CALL INPMSG(I,'The argument is missing. ') 286 - ELSE 287 - CALL INPCHK(I+1,2,IFAIL) 288 - CALL INPRDR(I+1,XSTEPR,XSTEP) 289 - IF(XSTEPR.LE.0.0.AND.IFAIL.EQ.0)THEN 290 - CALL INPMSG(I+1,'Should be a positive number. ') 291 - ELSEIF(XSTEPR.LT.(DXMAX-DXMIN)/MXLIST.AND. 292 - - IFAIL.EQ.0)THEN 293 - CALL INPMSG(I+1,'Too small, increase MXLIST. ') 294 - ELSEIF(IFAIL.EQ.0)THEN 295 - XSTEP=XSTEPR 296 - ENDIF 297 - INEXT=I+2 298 - ENDIF 299 - * Look for an X-RANGE keyword. 300 - ELSEIF(INPCMP(I,'X-R#ANGE')+INPCMP(I,'RAN#GE').NE.0)THEN 301 - IF(FLAG(I+1))THEN 302 - CALL INPMSG(I,'Should have two arguments. ') 303 - ELSEIF(FLAG(I+2))THEN 304 - CALL INPMSG(I,'Should have two arguments. ') 305 - CALL INPMSG(I+1,'Argument can not be used. ') 306 - INEXT=I+2 307 - ELSE 308 - CALL INPCHK(I+1,2,IFAIL1) 309 - CALL INPCHK(I+2,2,IFAIL2) 310 - CALL INPRDR(I+1,XTXMIR,DXMIN) 311 - CALL INPRDR(I+2,XTXMAR,DXMAX) 312 - IF(XTXMIR.EQ.XTXMAR)THEN 313 - CALL INPMSG(I+1,'Zero range not permitted. ') 314 - CALL INPMSG(I+2,'See the preceding message. ') 315 - ELSEIF((XTXMIR.LT.DXMIN.AND.XTXMAR.LT.DXMIN).OR. 316 - - (XTXMIR.GT.DXMAX.AND.XTXMAR.GT.DXMAX))THEN 317 - CALL INPMSG(I+1,'Range falls outside the area. ') 318 - CALL INPMSG(I+2,'See the preceding message. ') 319 - ELSE 320 - XTXMIN=MAX(MIN(XTXMIR,XTXMAR),DXMIN) 321 - XTXMAX=MIN(MAX(XTXMIR,XTXMAR),DXMAX) 322 - ENDIF 323 - INEXT=I+3 324 - ENDIF 325 - * Printing options. 326 - ELSEIF(INPCMP(I,'PR#INT-#XT-#RELATION').NE.0)THEN 327 - LXTPRT=.TRUE. 328 - ELSEIF(INPCMP(I,'NOPR#INT-#XT-#RELATION').NE.0)THEN 329 - LXTPRT=.FALSE. 330 - * Plotting options. 331 - ELSEIF(INPCMP(I,'PL#OT-#XT-#RELATION').NE.0)THEN 332 - LXTPLT=.TRUE. 333 - ELSEIF(INPCMP(I,'NOPL#OT-#XT-#RELATION').NE.0)THEN 334 - LXTPLT=.FALSE. 335 - * OFF and NONE keywords out of sequence. 336 - ELSEIF(INPCMP(I,'OFF')+INPCMP(I,'NO#NE').NE.0)THEN 337 - CALL INPMSG(I,'Valid keyword out of sequence.') 338 - * Unknown keywords. 339 - ELSE 340 - CALL INPMSG(I,'The option is not known. ') 341 - ENDIF 342 - 30 CONTINUE 343 - * Print error messages. 344 - CALL INPERR 345 - * And check the length of the various identifiers. 346 - IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! DRFXTP WARNING : The file'// 347 - - ' name is truncated to MXNAME (=',MXNAME,') characters.' 348 - IF(NCMEMB.GT.8)PRINT *,' !!!!!! DRFXTP WARNING : The member'// 349 - - ' name is shortened to '//MEMBER//', first 8 characters.' 350 - IF(NCREM.GT.29)PRINT *,' !!!!!! DRFXTP WARNING : The remark'// 351 - - ' shortened to '//REMARK//', first 29 characters.' 352 - NCFILE=MIN(NCFILE,MXNAME) 353 - NCMEMB=MIN(NCMEMB,8) 354 - NCREM=MIN(NCREM,29) 355 - * Check whether the member already exists. 356 - IF(LXTWRT)THEN 357 - CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'XTPLOT',EXMEMB) 358 - IF(JEXMEM.EQ.2.AND.EXMEMB)THEN 359 - PRINT *,' ------ DRFXTP MESSAGE : A copy of the'// 360 - - ' member exists; new member will be appended.' 361 - ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN 362 - PRINT *,' !!!!!! DRFXTP WARNING : A copy of the'// 363 - - ' member exists already; member will not be'// 364 - - ' written.' 365 - LXTWRT=.FALSE. 366 - ENDIF 367 - ENDIF 368 - * Define the line parameters P and Q such that P*X + Q*Y = R. 369 - P=COS(-PI*ANGLE/180.0) 370 - Q=SIN(-PI*ANGLE/180.0) 371 - * Set the drift-line counter to 0 initially. 372 - NDLC=0 373 - *** Print some preliminary debugging output. 374 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFXTP DEBUG : Start of'', 375 - - '' debugging output''//26X,''Current driftline parameters''/ 376 - - 26X,''RTRAP ='',F10.3,'' EPSDIF= '',E10.3,'' NLINED= '',I10/ 377 - - 26X,''AREA = ('',E10.3,'','',E10.3,'') ('',E10.3,'','', 378 - - E10.3,'')''/)') RTRAP,EPSDIF,NLINED,DXMIN,DYMIN,DXMAX,DYMAX 379 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Current x(t) specific settings''/ 380 - - 26X,''ANGLE = '',F10.3,'' P = '',E10.3,'' Q = '',E10.3/ 381 - - 26X,''XSTEP = '',E10.3,'' ITERMX = '',I6,'' JUMP = '',I6/ 382 - - 26X,''XTXMIN = '',E10.3,'' XTXMAX = '',E10.3)') 383 - - ANGLE,P,Q,XSTEP,ITERMX,JUMP,XTXMIN,XTXMAX 384 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Angles left: '',2E10.3,/ 1 663 P=DRIFT D=DRFXTP 5 PAGE1012 385 - - 26X,''Angles right: '',2E10.3,/, 386 - - 26X,''EPS = '',E10.3)') ALMIN,ALMAX,ARMIN,ARMAX,EPS 387 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''LXTWRT='',L1,'', FILE='',A,'','', 388 - - /26X,''MEMBER='',A,'', REMARK='',A)') 389 - - LXTWRT,FILE(1:NCFILE),MEMBER(1:NCMEMB),REMARK(1:NCREM) 390 - *** Pick the wires located inside the drift area. 391 - DO 100 I=1,NWIRE 392 - IF(X(I).LT.DXMIN.OR.X(I).GT.DXMAX.OR. 393 - - Y(I).LT.DYMIN.OR.Y(I).GT.DYMAX.OR.INDSW(I).EQ.0)GOTO 100 394 - IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Wire '',I3,'' (type '',A1, 395 - - '') at '',2F10.3,'' selected.'')') I,WIRTYP(I),X(I),Y(I) 396 - * Set the IXM and IXP parameters to ensure that the area is not left. 397 - IXM=JUMP*ANINT((XTXMIN-X(I))/(JUMP*XSTEP)) 398 - IXP=JUMP*ANINT((XTXMAX-X(I))/(JUMP*XSTEP)) 399 - IF(X(I)+IXM*XSTEP.LT.XTXMIN)IXM=IXM+JUMP 400 - IF(X(I)+IXP*XSTEP.GT.XTXMAX)IXP=IXP-JUMP 401 - * Check we remain in the storage allocated for the list. 402 - IF(IXP-IXM+1.GT.MXLIST)THEN 403 - PRINT *,' !!!!!! DRFXTP WARNING : No x(t) for wire ',I, 404 - - ' because MXLIST is too small.' 405 - PRINT *,' Consider making X-STEP'// 406 - - ' larger or choose a smaller AREA.' 407 - GOTO 100 408 - ENDIF 409 - * Draw a set of axis if LDRPLT is on. 410 - IF(LDRPLT)THEN 411 - CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, 412 - - 'DRIFT LINES USED FOR THE X(T) PLOT ') 413 - CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) 414 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 415 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 416 - CALL GRATTS('E-DRIFT-LINE','POLYLINE') 417 - ENDIF 418 - *** Initialise the arrays for this wire. 419 - DO 110 ISET=1,MXLIST 420 - DO 105 JSET=1,7 421 - XT(JSET,ISET)=0.0 422 - 105 CONTINUE 423 - NXT(ISET)=0 424 - XTSET(ISET)=.FALSE. 425 - IXTFLG(ISET)=-11 426 - 110 CONTINUE 427 - *** Initialise the maximum and minimum of the C range. 428 - CXTMIN=Q*X(I)-P*Y(I) 429 - CXTMAX=Q*X(I)-P*Y(I) 430 - *** Loop around the wire to get a rough picture of the x(t) relation. 431 - QCHARG=1.0 432 - DO 120 IANG=-NLINED/2,NLINED/2 433 - * Translate into an angle taking the limits into account. 434 - IF(IANG.LT.0)THEN 435 - IF(NLINED.GT.2)THEN 436 - ANG=180.0+ALMIN+REAL(-IANG-1)*(ALMAX-ALMIN)/ 437 - - REAL(NLINED/2-1) 438 - ELSE 439 - ANG=180.0+0.5*(ALMIN+ALMAX) 440 - ENDIF 441 - ELSEIF(IANG.GT.0)THEN 442 - IF(NLINED.GT.2)THEN 443 - ANG=ARMIN+REAL(IANG-1)*(ARMAX-ARMIN)/REAL(NLINED/2-1) 444 - ELSE 445 - ANG=0.5*(ARMIN+ARMAX) 446 - ENDIF 447 - ELSE 448 - GOTO 120 449 - ENDIF 450 - * Convert to radians. 451 - ANG=ANG*PI/180.0 452 - * Calculate a radial drift-line. 453 - RDIST=D(I)*(0.5+1.0E-4*(1.0+MAX(ABS(X(I)),ABS(Y(I))))) 454 - IF(LDEBUG)PRINT *,' ++++++ DRFXTP DEBUG : RDIST/D=',RDIST/D(I) 455 - CALL DLCALC(X(I)+RDIST*COS(ANG),Y(I)+RDIST*SIN(ANG),0.0,QCHARG,1) 456 - * Plot and print data id requested. 457 - IF(LDRPLT.AND.NU.GT.1)CALL GPL2(NU,XU,YU) 458 - NDLC=NDLC+1 459 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Angle='',F10.3,'' ISTAT='',I3, 460 - - '' NU='',I3)') 180.0*ANG/PI,ISTAT,NU 461 - *** Loop over the points for which a t is to be found. 462 - DO 130 IIX=IXM,IXP,JUMP 463 - IX=IIX-IXM+1 464 - REF=P*(X(I)+IIX*XSTEP)+Q*Y(I) 465 - * Find the lowest t intersection for each x. 466 - CALL DRFXT1(P,Q,REF,CDRIFT,TDRIFT,IFAIL) 467 - IF(IFAIL.NE.0)GOTO 130 468 - * Keep track of the extrema of C. 469 - IF(CXTMIN.GT.CDRIFT)CXTMIN=CDRIFT 470 - IF(CXTMAX.LT.CDRIFT)CXTMAX=CDRIFT 471 - * And store it in its proper place in XT(,IX). 472 - IF(NXT(IX).EQ.0)THEN 473 - XT(1,IX)=TDRIFT 474 - XT(4,IX)=CDRIFT 475 - NXT(IX)=1 476 - ELSE 477 - DO 150 ITAB=1,NXT(IX) 478 - IF(ABS(TDRIFT-XT(ITAB,IX)).LE.1E-4*ABS(TDRIFT).AND. 479 - - ABS(CDRIFT-XT(ITAB+3,IX)).LE.1E-4*ABS(CDRIFT))THEN 480 - IF(LDEBUG)PRINT *,' ++++++ DRFXTP DEBUG : Not'// 481 - - ' storing this point (coincides).' 482 - GOTO 130 483 - ENDIF 484 - IF(TDRIFT.LT.XT(ITAB,IX))THEN 485 - DO 160 JTAB=3,ITAB+1,-1 486 - XT(JTAB,IX)=XT(JTAB-1,IX) 487 - XT(JTAB+3,IX)=XT(JTAB+2,IX) 488 - 160 CONTINUE 489 - XT(ITAB,IX)=TDRIFT 490 - XT(ITAB+3,IX)=CDRIFT 1 663 P=DRIFT D=DRFXTP 6 PAGE1013 491 - GOTO 170 492 - ENDIF 493 - 150 CONTINUE 494 - IF(NXT(IX).LT.3)THEN 495 - XT(NXT(IX)+1,IX)=TDRIFT 496 - XT(NXT(IX)+4,IX)=CDRIFT 497 - ENDIF 498 - 170 CONTINUE 499 - NXT(IX)=MIN(3,NXT(IX)+1) 500 - ENDIF 501 - XTSET(IX)=.TRUE. 502 - 130 CONTINUE 503 - 120 CONTINUE 504 - * Output the C extrema for debugging purposes, if requested. 505 - IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Extrema for C are: '',2E15.8)') 506 - - CXTMIN,CXTMAX 507 - * And set the C-stepping size. 508 - CSTEP=ABS(CXTMAX-CXTMIN)/2.0 509 - IF(CSTEP.LT.ABS(DYMAX-DYMIN)/(100.0*P))THEN 510 - CSTEP=(DYMAX-DYMIN)/(10.0*P) 511 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''CSTEP too small, replaced'', 512 - - '' by'',E15.8,''.'')') CSTEP 513 - ENDIF 514 - *** Find more accurate values for all data points. 515 - QCHARG=-1.0 516 - DO 200 IIX=IXM,IXP,JUMP 517 - * IX is a shorthand for the array indices corresponding with IIX. 518 - IX=IIX-IXM+1 519 - * Set the track parameter. 520 - REF=P*(X(I)+IIX*XSTEP)+Q*Y(I) 521 - * Take correct action in case this point coincides with the wire. 522 - IF(IIX.EQ.0)THEN 523 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Point '',I3,'' coincides'', 524 - - '' with the wire, no minimisation.'')') IX 525 - XTSET(IX)=.TRUE. 526 - XT(1,IX)=0.0 527 - XT(4,IX)=P*X(I)+Q*Y(I) 528 - XT(7,IX)=0.0 529 - IXTFLG(IX)=-1 530 - GOTO 200 531 - ENDIF 532 - * Print the crude infomation we have so far, if debugging is on. 533 - IF(LDEBUG)THEN 534 - WRITE(LUNOUT,'(/26X,''Start of minimisation for point '',I3, 535 - - '' XTSET='',L1,'' NXT='',I3,/)') IX,XTSET(IX),NXT(IX) 536 - DO 205 INXT=1,NXT(IX) 537 - WRITE(LUNOUT,'(26X,'' c'',I1,''='',E15.8,'', t'',I1,''='', 538 - - E15.8)') INXT,XT(INXT+3,IX),INXT,XT(INXT,IX) 539 - 205 CONTINUE 540 - WRITE(*,'('' '')') 541 - ENDIF 542 - ** Next try to find 3 points forming a parabola. Case 1: no points. 543 - IF(NXT(IX).EQ.0)THEN 544 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Crude information absent'', 545 - - '' for this data-point, it is skipped.'')') 546 - IXTFLG(IX)=-2 547 - GOTO 200 548 - ENDIF 549 - ** Suppose we already have 3 points, make sure iteration makes sense. 550 - ITERSK=0 551 - IF(NXT(IX).EQ.3)THEN 552 - CALL DRFXT2(XT(4,IX),XT(1,IX),XT(5,IX),XT(2,IX), 553 - - XT(6,IX),XT(3,IX),CPARA,TPARA,IFAIL,IFLAG) 554 - IF(IFLAG.EQ.+1.AND.IFAIL.EQ.0.AND. 555 - - ABS(TPARA-XT(1,IX)).LT.EPS*(TPARA+XT(1,IX)).AND. 556 - - (CPARA-MAX(XT(4,IX),XT(5,IX),XT(6,IX)))* 557 - - (CPARA-MIN(XT(4,IX),XT(5,IX),XT(6,IX))).LE.0)THEN 558 - ITERSK=1 559 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Minimisation is not'', 560 - - '' meaningful: TPARA='',E15.8)') TPARA 561 - ENDIF 562 - ENDIF 563 - ** If no iteration has been requested, simply recalculate. 564 - IF(ITERMX.EQ.0.OR.ITERSK.EQ.1)THEN 565 - CALL DLCALC(P*REF+Q*XT(4,IX),Q*REF-P*XT(4,IX),0.0,QCHARG,1) 566 - IF(LDRPLT.AND.NU.GT.1)CALL GPL2(NU,XU,YU) 567 - NDLC=NDLC+1 568 - IF(ISTAT.EQ.I)THEN 569 - XT(1,IX)=TU(NU) 570 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Precise value of t='', 571 - - E15.8,''.'')') XT(1,IX) 572 - IXTFLG(IX)=0 573 - GOTO 310 574 - ELSE 575 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Recalculation of'', 576 - - ''crude drift-line returns ISTAT='',I3)') ISTAT 577 - XTSET(IX)=.FALSE. 578 - IXTFLG(IX)=-3 579 - GOTO 200 580 - ENDIF 581 - ENDIF 582 - * Also initialise the PRECIS list. 583 - PRECIS(1)=.FALSE. 584 - PRECIS(2)=.FALSE. 585 - PRECIS(3)=.FALSE. 586 - ** In case there is a single crossing, add one new point. 587 - IF(NXT(IX).EQ.1)THEN 588 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''One data point, search'', 589 - - '' for one new point towards the C range middle.'')') 590 - ITER=0 591 - IF(XT(5,IX).GT.(CXTMAX-CXTMIN)/2.0)THEN 592 - XT(5,IX)=XT(4,IX)-CSTEP 593 - ELSE 594 - XT(5,IX)=XT(4,IX)+CSTEP 595 - ENDIF 596 - 210 CONTINUE 1 663 P=DRIFT D=DRFXTP 7 PAGE1014 597 - CALL DLCALC(P*REF+Q*XT(5,IX),Q*REF-P*XT(5,IX),0.0,QCHARG,1) 598 - IF(LDRPLT.AND.NU.GT.1)CALL GPL2(NU,XU,YU) 599 - NDLC=NDLC+1 600 - XT(2,IX)=TU(NU) 601 - PRECIS(2)=.TRUE. 602 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''ITER='',I2,'', C='',E15.8, 603 - - '', T='',E15.8,'', ISTAT='',I3)') 604 - - ITER,XT(5,IX),XT(2,IX),ISTAT 605 - IF(ISTAT.NE.I)THEN 606 - XT(5,IX)=0.5*(XT(4,IX)+XT(5,IX)) 607 - ITER=ITER+1 608 - IF(ITER.LE.ITERMX)GOTO 210 609 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''2nd point not found'')') 610 - IXTFLG(IX)=-4 611 - XTSET(IX)=.FALSE. 612 - GOTO 200 613 - ELSEIF(XT(2,IX).LT.XT(1,IX))THEN 614 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Second data point'', 615 - - '' has a T < T0, data points swapped.'')') 616 - XTAUX=XT(1,IX) 617 - XT(1,IX)=XT(2,IX) 618 - XT(2,IX)=XTAUX 619 - XTAUX=XT(4,IX) 620 - XT(4,IX)=XT(5,IX) 621 - XT(5,IX)=XTAUX 622 - PRAUX=PRECIS(1) 623 - PRECIS(1)=PRECIS(2) 624 - PRECIS(2)=PRAUX 625 - ENDIF 626 - NXT(IX)=2 627 - ENDIF 628 - * Add a third point in the event there are two data points. 629 - IF(NXT(IX).EQ.2)THEN 630 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Two data points so far,'', 631 - - '' adding a point at a mirrored C.'')') 632 - ITER=0 633 - XT(6,IX)=2*XT(4,IX)-XT(5,IX) 634 - 220 CONTINUE 635 - CALL DLCALC(P*REF+Q*XT(6,IX),Q*REF-P*XT(6,IX),0.0,QCHARG,1) 636 - IF(LDRPLT.AND.NU.GT.1)CALL GPL2(NU,XU,YU) 637 - NDLC=NDLC+1 638 - XT(3,IX)=TU(NU) 639 - PRECIS(3)=.TRUE. 640 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''ITER='',I2,'', C='',E15.8, 641 - - '', T='',E15.8,'', ISTAT='',I3)') 642 - - ITER,XT(6,IX),XT(3,IX),ISTAT 643 - IF(ISTAT.NE.I)THEN 644 - XT(6,IX)=0.5*(XT(4,IX)+XT(6,IX)) 645 - ITER=ITER+1 646 - IF(ITER.LE.ITERMX)GOTO 220 647 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''3rd point not found'')') 648 - XTSET(IX)=.FALSE. 649 - IXTFLG(IX)=-5 650 - GOTO 200 651 - ELSEIF(XT(3,IX).LT.XT(1,IX))THEN 652 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Third data point'', 653 - - '' has a T < T0, data points swapped.'')') 654 - XTAUX=XT(1,IX) 655 - XT(1,IX)=XT(3,IX) 656 - XT(3,IX)=XTAUX 657 - XTAUX=XT(4,IX) 658 - XT(4,IX)=XT(6,IX) 659 - XT(6,IX)=XTAUX 660 - PRAUX=PRECIS(1) 661 - PRECIS(1)=PRECIS(3) 662 - PRECIS(3)=PRAUX 663 - ENDIF 664 - NXT(IX)=3 665 - ENDIF 666 - ** Parabolic minimisation itself, first sort the XT array. 667 - IF(XT(4,IX).GT.XT(5,IX))THEN 668 - XTAUX=XT(2,IX) 669 - XT(2,IX)=XT(1,IX) 670 - XT(1,IX)=XTAUX 671 - XTAUX=XT(5,IX) 672 - XT(5,IX)=XT(4,IX) 673 - XT(4,IX)=XTAUX 674 - PRAUX=PRECIS(2) 675 - PRECIS(2)=PRECIS(1) 676 - PRECIS(1)=PRAUX 677 - ENDIF 678 - IF(XT(5,IX).GT.XT(6,IX))THEN 679 - XTAUX=XT(3,IX) 680 - XT(3,IX)=XT(2,IX) 681 - XT(2,IX)=XTAUX 682 - XTAUX=XT(6,IX) 683 - XT(6,IX)=XT(5,IX) 684 - XT(5,IX)=XTAUX 685 - PRAUX=PRECIS(3) 686 - PRECIS(3)=PRECIS(2) 687 - PRECIS(2)=PRAUX 688 - ENDIF 689 - IF(XT(4,IX).GT.XT(5,IX))THEN 690 - XTAUX=XT(2,IX) 691 - XT(2,IX)=XT(1,IX) 692 - XT(1,IX)=XTAUX 693 - XTAUX=XT(5,IX) 694 - XT(5,IX)=XT(4,IX) 695 - XT(4,IX)=XTAUX 696 - PRAUX=PRECIS(2) 697 - PRECIS(2)=PRECIS(1) 698 - PRECIS(1)=PRAUX 699 - ENDIF 700 - * Calculate exact drift time for one of the side points. 701 - IF(.NOT.PRECIS(1))THEN 702 - CALL DLCALC(P*REF+Q*XT(4,IX),Q*REF-P*XT(4,IX),0.0,QCHARG,1) 1 663 P=DRIFT D=DRFXTP 8 PAGE1015 703 - IF(LDRPLT.AND.NU.GT.1)CALL GPL2(NU,XU,YU) 704 - NDLC=NDLC+1 705 - XT(1,IX)=TU(NU) 706 - PRECIS(1)=.TRUE. 707 - ENDIF 708 - * Calculate exact drift time for the middle point, if not yet done. 709 - IF(.NOT.PRECIS(2))THEN 710 - CALL DLCALC(P*REF+Q*XT(5,IX),Q*REF-P*XT(5,IX),0.0,QCHARG,1) 711 - IF(LDRPLT.AND.NU.GT.1)CALL GPL2(NU,XU,YU) 712 - NDLC=NDLC+1 713 - XT(2,IX)=TU(NU) 714 - PRECIS(2)=.TRUE. 715 - ENDIF 716 - * Calculate exact drift time for the other side point. 717 - IF(.NOT.PRECIS(3))THEN 718 - CALL DLCALC(P*REF+Q*XT(6,IX),Q*REF-P*XT(6,IX),0.0,QCHARG,1) 719 - IF(LDRPLT.AND.NU.GT.1)CALL GPL2(NU,XU,YU) 720 - NDLC=NDLC+1 721 - XT(3,IX)=TU(NU) 722 - PRECIS(3)=.TRUE. 723 - ENDIF 724 - ** Starting point found, now proceed with parabolic minimisation. 725 - DO 300 J=1,ITERMX 726 - IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Parabolic search loop '',I2,/, 727 - - 29X,''C,T low ='',E15.8,'', '',E15.8,'', Prec='',L1,/, 728 - - 29X,''C,T middle='',E15.8,'', '',E15.8,'', Prec='',L1,/, 729 - - 29X,''C,T high ='',E15.8,'', '',E15.8,'', Prec='',L1,/)') 730 - - J,(XT(II+3,IX),XT(II,IX),PRECIS(II),II=1,3) 731 - * Fit a parabola to the three points. 732 - CALL DRFXT2(XT(4,IX),XT(1,IX),XT(5,IX),XT(2,IX), 733 - - XT(6,IX),XT(3,IX),CPARA,TPARA,IFAIL,IFLAG) 734 - IF(IFLAG.NE.+1.OR.IFAIL.NE.0)THEN 735 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''DRFXT2 returns on IFAIL='', 736 - - I2,'', IFLAG='',I2)') IFAIL,IFLAG 737 - XTSET(IX)=.FALSE. 738 - IXTFLG(IX)=-6 739 - GOTO 200 740 - ENDIF 741 - * Check whether the fit is at all acceptable. 742 - IF(XT(1,IX).GT.XT(2,IX).AND.XT(3,IX).GT.XT(2,IX).AND. 743 - - (CPARA-XT(4,IX))*(CPARA-XT(6,IX)).GE.0)THEN 744 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Inadequate fit.'')') 745 - IXTFLG(IX)=-10 746 - XTSET(IX)=.FALSE. 747 - GOTO 200 748 - ENDIF 749 - * Calculate a drift-line from the presumed minimum. 750 - CALL DLCALC(P*REF+Q*CPARA,Q*REF-P*CPARA,0.0,QCHARG,1) 751 - IF(LDRPLT.AND.NU.GT.1)CALL GPL2(NU,XU,YU) 752 - NDLC=NDLC+1 753 - IF(ISTAT.NE.I)THEN 754 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Wire lost ISTAT='',I3)')ISTAT 755 - XTSET(IX)=.FALSE. 756 - IXTFLG(IX)=-3 757 - GOTO 200 758 - ENDIF 759 - * Print some debugging output if requested about the minimum. 760 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''CPARA='',E15.8,'', TPARA='', 761 - - E15.8,'', TU(NU)='',E15.8)') CPARA,TPARA,TU(NU) 762 - * Stop if the change is very small, CPARA is internal. 763 - IF((CPARA-XT(4,IX))*(CPARA-XT(6,IX)).LT.0.0.AND. 764 - - ABS(TU(NU)-MIN(XT(1,IX),XT(2,IX),XT(3,IX))).LE. 765 - - EPS*(ABS(TU(NU)+MIN(XT(1,IX),XT(2,IX),XT(3,IX)))))THEN 766 - IF(TU(NU).LT.XT(2,IX))THEN 767 - XT(2,IX)=TU(NU) 768 - XT(5,IX)=CPARA 769 - ENDIF 770 - IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Convergence :'', 771 - - '' C='',E15.8,'', T='',E15.8)') XT(5,IX),XT(2,IX) 772 - IXTFLG(IX)=J 773 - GOTO 310 774 - * New point is worse but inside, replace outer point on same side. 775 - ELSEIF((CPARA-XT(4,IX))*(CPARA-XT(6,IX)).LT.0.0.AND. 776 - - TU(NU).GT.MIN(XT(1,IX),XT(2,IX),XT(3,IX)))THEN 777 - IF(CPARA.LT.XT(5,IX))THEN 778 - XT(1,IX)=TU(NU) 779 - XT(4,IX)=CPARA 780 - PRECIS(1)=.TRUE. 781 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 782 - - ''Lower C point is replaced by new minimum.'')') 783 - ELSE 784 - XT(3,IX)=TU(NU) 785 - XT(6,IX)=CPARA 786 - PRECIS(3)=.TRUE. 787 - IF(LDEBUG)WRITE(LUNOUT,'(26X, 788 - - ''Higher C point is replaced by new minimum.'')') 789 - ENDIF 790 - * The new point is better and inside, remove opposite outer point. 791 - ELSEIF((CPARA-XT(4,IX))*(CPARA-XT(5,IX)).LT.0.0)THEN 792 - XT(6,IX)=XT(5,IX) 793 - XT(5,IX)=CPARA 794 - XT(3,IX)=XT(2,IX) 795 - XT(2,IX)=TU(NU) 796 - PRECIS(3)=PRECIS(2) 797 - PRECIS(2)=.TRUE. 798 - ELSEIF((CPARA-XT(5,IX))*(CPARA-XT(6,IX)).LT.0.0)THEN 799 - XT(4,IX)=XT(5,IX) 800 - XT(5,IX)=CPARA 801 - XT(1,IX)=XT(2,IX) 802 - XT(2,IX)=TU(NU) 803 - PRECIS(1)=PRECIS(2) 804 - PRECIS(2)=.TRUE. 805 - * New point outside, non-parabolic, shift to add new point. 806 - ELSEIF(CPARA.LE.XT(4,IX))THEN 807 - XT(6,IX)=XT(5,IX) 808 - XT(5,IX)=XT(4,IX) 1 663 P=DRIFT D=DRFXTP 9 PAGE1016 809 - XT(4,IX)=CPARA 810 - XT(3,IX)=XT(2,IX) 811 - XT(2,IX)=XT(1,IX) 812 - XT(1,IX)=TU(NU) 813 - PRECIS(3)=PRECIS(2) 814 - PRECIS(2)=PRECIS(1) 815 - PRECIS(1)=.TRUE. 816 - ELSEIF(CPARA.GE.XT(6,IX))THEN 817 - XT(4,IX)=XT(5,IX) 818 - XT(5,IX)=XT(6,IX) 819 - XT(6,IX)=CPARA 820 - XT(1,IX)=XT(2,IX) 821 - XT(2,IX)=XT(3,IX) 822 - XT(3,IX)=TU(NU) 823 - PRECIS(1)=PRECIS(2) 824 - PRECIS(2)=PRECIS(3) 825 - PRECIS(3)=.TRUE. 826 - * Position not recognised (in view of some logic modifications ...). 827 - ELSE 828 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Unrecognised pos, quit'')') 829 - XTSET(IX)=.FALSE. 830 - IXTFLG(IX)=-8 831 - GOTO 200 832 - ENDIF 833 - * Warn if the process did not converge. 834 - 300 CONTINUE 835 - XTSET(IX)=.FALSE. 836 - IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Not converged.'')') 837 - IXTFLG(IX)=-9 838 - GOTO 200 839 - ** End of the minimisation process. 840 - 310 CONTINUE 841 - * Calculate the integrated diffusion coefficient. 842 - IF(GASOK(3))CALL DLCDIF(XT(7,IX)) 843 - * Find the intersections of the drift-line with the R=const lines. 844 - DO 430 JJX=IIX-JUMP+1,IIX+JUMP-1 845 - JX=JJX-IXM+1 846 - IF(JJX.LT.IXM.OR.JJX.GT.IXP.OR.JX.EQ.IX)GOTO 430 847 - REF=P*(X(I)+JJX*XSTEP)+Q*Y(I) 848 - CALL DRFXT1(P,Q,REF,CDRIFT,TDRIFT,IFAIL) 849 - IF(IFAIL.EQ.0)THEN 850 - XTSET(JX)=.TRUE. 851 - NXT(JX)=1 852 - XT(1,JX)=TU(NU)-TDRIFT 853 - XT(4,JX)=CDRIFT 854 - IXTFLG(JX)=0 855 - ENDIF 856 - 430 CONTINUE 857 - * Proceed with next point. 858 - 200 CONTINUE 859 - *** Close the plotframe for drift lines (if the plot is made). 860 - IF(LDRPLT)THEN 861 - CALL GRNEXT 862 - CALL GRALOG('Drift lines for an x(t)-plot ') 863 - ENDIF 864 - *** Plot the obtained x(t)-relation: store minimum in position 2. 865 - IF(LXTPLT)THEN 866 - DO 540 IIX=IXM,IXP 867 - IX=IIX-IXM+1 868 - IF(NXT(IX).EQ.0)GOTO 540 869 - IMIN=1 870 - DO 530 IIMIN=2,NXT(IX) 871 - IF(XT(IIMIN,IX).LT.XT(IMIN,IX))IMIN=IIMIN 872 - 530 CONTINUE 873 - XT(2,IX)=XT(IMIN,IX) 874 - XT(5,IX)=XT(IMIN+3,IX) 875 - 540 CONTINUE 876 - * Datermine maximum and minimum. 877 - IF(GRSMIN.GT.GRSMAX)THEN 878 - TMIN=0.0 879 - TMAX=0.0 880 - DO 500 IIX=IXM,IXP 881 - IF(XTSET(IIX-IXM+1).AND.NXT(IIX-IXM+1).GT.0)THEN 882 - TMIN=MIN(TMIN,XT(2,IIX-IXM+1)) 883 - TMAX=MAX(TMAX,XT(2,IIX-IXM+1)) 884 - ENDIF 885 - 500 CONTINUE 886 - TMIN=0.9*TMIN 887 - TMAX=1.1*TMAX 888 - ELSE 889 - TMIN=GRSMIN 890 - TMAX=GRSMAX 891 - ENDIF 892 - * Open a frame to plot the curves in. 893 - CALL GRCART(XTXMIN-X(I),TMIN,XTXMAX-X(I),TMAX, 894 - - ' x-Distance from the Wire [cm]', 895 - - ' Minimum Drift Time [microsec]', 896 - - 'x(t)-Correlation plot ') 897 - * Add some comments to the plot. 898 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 899 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 900 - WRITE(INFILE,1080) ANGLE 901 - CALL GRCOMM(3,INFILE) 902 - WRITE(INFILE,1090) I,WIRTYP(I) 903 - CALL GRCOMM(4,INFILE) 904 - * And plot the curves, first the minimum drift time itself. 905 - NPLOT=0 906 - CALL GRATTS('FUNCTION-1','POLYLINE') 907 - CALL GRATTS('FUNCTION-1','POLYMARKER') 908 - DO 510 IIX=IXM,IXP 909 - IX=IIX-IXM+1 910 - IF(XTSET(IX))THEN 911 - NPLOT=NPLOT+1 912 - XPL(NPLOT)=IIX*XSTEP 913 - YPL(NPLOT)=XT(2,IX) 914 - ELSE 1 663 P=DRIFT D=DRFXTP 10 PAGE1017 915 - IF(NPLOT.GT.1)THEN 916 - CALL GPL(NPLOT,XPL,YPL) 917 - ELSEIF(NPLOT.EQ.1)THEN 918 - CALL GPM(1,XPL,YPL) 919 - ENDIF 920 - NPLOT=0 921 - ENDIF 922 - 510 CONTINUE 923 - IF(NPLOT.GT.1)THEN 924 - CALL GPL(NPLOT,XPL,YPL) 925 - ELSEIF(NPLOT.EQ.1)THEN 926 - CALL GPM(1,XPL,YPL) 927 - ENDIF 928 - * next the diffusion coefficient, provided the data is present. 929 - IF(GASOK(3))THEN 930 - CALL GRATTS('FUNCTION-2','POLYLINE') 931 - CALL GRATTS('FUNCTION-2','POLYMARKER') 932 - NPLOT=0 933 - DO 520 IIX=IXM,IXP 934 - IX=IIX-IXM+1 935 - IF(XTSET(IX).AND.IIX.EQ.JUMP*(IIX/JUMP))THEN 936 - NPLOT=NPLOT+1 937 - XPL(NPLOT)=IIX*XSTEP 938 - YPL(NPLOT)=XT(7,IX) 939 - ELSE 940 - IF(NPLOT.GT.1)THEN 941 - CALL GPL(NPLOT,XPL,YPL) 942 - ELSEIF(NPLOT.EQ.1)THEN 943 - CALL GPM(1,XPL,YPL) 944 - ENDIF 945 - NPLOT=0 946 - ENDIF 947 - 520 CONTINUE 948 - IF(NPLOT.GT.1)THEN 949 - CALL GPL(NPLOT,XPL,YPL) 950 - ELSEIF(NPLOT.EQ.1)THEN 951 - CALL GPM(1,XPL,YPL) 952 - ENDIF 953 - CALL GSLN(1) 954 - ENDIF 955 - * Close the plotframe and register the plot. 956 - CALL GRNEXT 957 - WRITE(INFILE,'(''x(t) plot for wire '',I3,'', type '',A1)') 958 - - I,WIRTYP(I) 959 - CALL GRALOG(INFILE//' ') 960 - ENDIF 961 - *** Open a dataset for the x(t) if LXTWRT is .TRUE. 962 - IF(LXTWRT)THEN 963 - * Open the file and inform DSNLOG. 964 - CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) 965 - IF(IFAIL.NE.0)THEN 966 - PRINT *,' !!!!!! DRFXTP WARNING : Opening the file'// 967 - - FILE(1:NCFILE)//' failed ; write flag cancelled' 968 - LXTWRT=.FALSE. 969 - ENDIF 970 - CALL DSNLOG(FILE,'x(t)-plot ','Sequential','Write ') 971 - * Now write a heading record to the file. 972 - CALL DATTIM(DATE,TIME) 973 - WRITE(STRING,'(''% Created '',A8,'' At '',A8,1X,A8, 974 - - '' XTPLOT "Wire '',I3,'' type '',A1,'' angle '', 975 - - F7.1,''"'')') DATE,TIME,MEMBER,I,WIRTYP(I),ANGLE 976 - IF(REMARK.NE.'None')STRING(51:79)=REMARK 977 - WRITE(12,'(A80)') STRING 978 - * Specify the number of records to be written. 979 - WRITE(12,'('' This member contains '',I3,'' records.'')') 980 - - IXP-IXM+1 981 - ENDIF 982 - ** Print a heading for the x(t) table. 983 - IF(LXTPRT)THEN 984 - WRITE(LUNOUT,'('' x(t)-CORRELATION FOR WIRE '',I3, 985 - - '' (TYPE '',A1,'')'',/, 986 - - '' ======================================'')') 987 - - I,WIRTYP(I) 988 - WRITE(LUNOUT,'('' Wire location: ('',E15.8,'','', 989 - - E15.8,'')'',/,'' Convergence at: '',E15.8)') 990 - - X(I),Y(I),EPS 991 - IF(ITERMX.EQ.0)THEN 992 - WRITE(LUNOUT,'('' Minimisation has been disabled.'')') 993 - ELSE 994 - WRITE(LUNOUT,'('' Minimisation has been enabled.'')') 995 - ENDIF 996 - WRITE(LUNOUT,'(/'' x-value corresponding t'', 997 - - '' corresponding y diffusion Remarks''/ 998 - - '' [cm] [microsec]'', 999 - - '' [cm] [microsec]''//)') 1000 - ENDIF 1001 - ** Write the data itself, interpreting the various flags. 1002 - DO 620 JJX=IXM,IXP 1003 - J=JJX-IXM+1 1004 - REF=P*(X(I)+JJX*XSTEP)+Q*Y(I) 1005 - * Prepare a string containing roughly the data. 1006 - IF(IXTFLG(J).GT.0)THEN 1007 - WRITE(OUTSTR,'(2X,4(E15.8,2X),A,1X,I2,1X,A)') 1008 - - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), 1009 - - ' Minimisation converged in',IXTFLG(J),'steps.' 1010 - ELSEIF(IXTFLG(J).EQ.0)THEN 1011 - WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') 1012 - - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), 1013 - - ' Minimisation not requested or not meaningful.' 1014 - ELSEIF(IXTFLG(J).EQ.-1)THEN 1015 - WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') 1016 - - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), 1017 - - ' The wire is located at this x-value.' 1018 - ELSEIF(IXTFLG(J).EQ.-2)THEN 1019 - WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') 1020 - - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), 1 663 P=DRIFT D=DRFXTP 11 PAGE1018 1021 - - ' ! Drift-lines starting at this x, do not'// 1022 - - ' reach the wire.' 1023 - ELSEIF(IXTFLG(J).EQ.-3)THEN 1024 - WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') 1025 - - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), 1026 - - ' # Recalculation of the optimum drift-line'// 1027 - - ' failed.' 1028 - ELSEIF(IXTFLG(J).EQ.-4)THEN 1029 - WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') 1030 - - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), 1031 - - ' # Failure to add a 2nd data-point,'// 1032 - - ' increase LINES.' 1033 - ELSEIF(IXTFLG(J).EQ.-5)THEN 1034 - WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') 1035 - - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), 1036 - - ' # Failure to add a third data-point,'// 1037 - - ' increase LINES.' 1038 - ELSEIF(IXTFLG(J).EQ.-6)THEN 1039 - WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') 1040 - - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), 1041 - - ' ! The minimisation process diverged.' 1042 - ELSEIF(IXTFLG(J).EQ.-7)THEN 1043 - WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') 1044 - - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), 1045 - - ' ! The minimum does not look parabolic.' 1046 - ELSEIF(IXTFLG(J).EQ.-8)THEN 1047 - WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') 1048 - - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), 1049 - - ' # Internal error ; program bug - please report.' 1050 - ELSEIF(IXTFLG(J).EQ.-9)THEN 1051 - WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') 1052 - - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), 1053 - - ' ! Minimisation attempted, but no convergence.' 1054 - ELSEIF(IXTFLG(J).EQ.-10)THEN 1055 - WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') 1056 - - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), 1057 - - ' # Inadequate parabolic fit; program bug.' 1058 - ELSEIF(IXTFLG(J).EQ.-11)THEN 1059 - WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') 1060 - - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), 1061 - - ' ! No drift-line found which could'// 1062 - - ' be interpolated.' 1063 - ELSE 1064 - WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') 1065 - - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), 1066 - - ' # x(t) flag not recognised; program bug.' 1067 - ENDIF 1068 - * Remove irrelevant fields. 1069 - IF(.NOT.GASOK(3).OR..NOT.XTSET(J))OUTSTR(54:68)= 1070 - - ' Not available' 1071 - IF(NXT(J).EQ.0.AND.JJX.NE.0)OUTSTR(20:51)= 1072 - - ' Not available Not available' 1073 - IF(IXTFLG(J).EQ.0.AND.JJX.NE.JUMP*INT(REAL(JJX)/REAL(JUMP))) 1074 - - OUTSTR(54:)= 1075 - - ' Not available Interpolated data-point.' 1076 - * And output the string to the relevant units. 1077 - IF(LXTPRT)WRITE(LUNOUT,'(A)',IOSTAT=IOS,ERR=2010) OUTSTR 1078 - IF(LXTWRT)WRITE(12,'(L1,A)',IOSTAT=IOS,ERR=2010) 1079 - - XTSET(J),OUTSTR(2:) 1080 - * Next data point. 1081 - 620 CONTINUE 1082 - * Close the file, if openend. 1083 - IF(LXTWRT)CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 1084 - *** Proceed with next wire. 1085 - 100 CONTINUE 1086 - *** Normal end of this routine. 1087 - CALL TIMLOG('Calculating x(t) relations: ') 1088 - IF(LDEBUG)PRINT *,' ++++++ DRFXTP DEBUG : End of debug output.' 1089 - RETURN 1090 - *** Handle I/O problems. 1091 - 2010 CONTINUE 1092 - PRINT *,' ###### DRFXTP ERROR : Error while'// 1093 - - ' writing the x(t) data set ; attempt to close.' 1094 - CALL INPIOS(IOS) 1095 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 1096 - RETURN 1097 - 2030 CONTINUE 1098 - PRINT *,' ###### DRFXTP ERROR : Unable to close the data set'// 1099 - - ' of the x(t) relations ; results not predictable.' 1100 - CALL INPIOS(IOS) 1101 - END 664 GARFIELD ================================================== P=DRIFT D=DRFXT1 1 ============================ 0 + +DECK,DRFXT1. 1 - SUBROUTINE DRFXT1(P,Q,REF,C,T,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * DRFXT1 - Auxiliary routine to DRFXTP, locating intersections of 4 - * drift-lines with a straight line. 5 - * VARIABLES : P, Q, REF : P x + Q y = REF is the straight line. 6 - * C, T : Intersection parameters. 7 - * IFAIL : 1 if no intersection was found, 0 else. 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,DRIFTLINE. 11.- +SEQ,PRINTPLOT. 12.- +SEQ,CONSTANTS. 13 - DOUBLE PRECISION RD1,RD2 14 - REAL P,Q,REF,C,T 15 - *** Loop over the drift-line, starting at lower t. 16 - DO 10 IU=2,NU 17 - RD1=P*XU(IU-1)+Q*YU(IU-1) 18 - RD2=P*XU(IU)+Q*YU(IU) 19 - IF((RD1-REF)*(RD2-REF).LE.0.0)THEN 20 - * Few data-points before and after. 21 - IF(RD1.EQ.RD2)THEN 1 664 P=DRIFT D=DRFXT1 2 PAGE1019 22 - T=TU(IU-1) 23 - C=Q*XU(IU-1)-P*YU(IU-1) 24 - ELSE 25 - T=TU(IU-1)+(TU(IU)-TU(IU-1))*(REF-RD1)/(RD2-RD1) 26 - C=Q*(XU(IU-1)+(XU(IU)-XU(IU-1))*(REF-RD1)/ 27 - - (RD2-RD1))-P*(YU(IU-1)+(YU(IU)-YU(IU-1))* 28 - - (REF-RD1)/(RD2-RD1)) 29 - ENDIF 30 - IFAIL=0 31 - RETURN 32 - ENDIF 33 - 10 CONTINUE 34 - *** Apparently no intersection has been found, return on IFAIL=1. 35 - IFAIL=1 36 - END 665 GARFIELD ================================================== P=DRIFT D=DRFXT2 1 ============================ 0 + +DECK,DRFXT2. 1 - SUBROUTINE DRFXT2(U1,V1,U2,V2,U3,V3,UMIN,VMIN,IFAIL,IFLAG) 2 - *----------------------------------------------------------------------- 3 - * DRFXT2 - Determines the minimum of a parabola, the expressions have 4 - * been calculated using the Macsyma system. 5 - * VARIABLES : IFAIL : 1 if the parabola is degenerated. 6 - * IFLAG : -1 maximum, 0 failure, +1 minimum. 7 - *----------------------------------------------------------------------- 8 - DOUBLE PRECISION X1,Y1,X2,Y2,X3,Y3,DIV1,DIV2,XMIN,YMIN 9 - IFAIL=1 10 - IFLAG=0 11 - UMIN=0 12 - VMIN=0 13 - *** Make a double precision copy 14 - X1=U1 15 - Y1=V1 16 - X2=U2 17 - Y2=V2 18 - X3=U3 19 - Y3=V3 20 - *** Prevent divisions by zero. 21 - DIV1=2*(X1*(Y3-Y2)+X2*(Y1-Y3)+X3*(Y2-Y1)) 22 - DIV2=X1**2*(X2-X3)+X2**2*(X3-X1)+X3**2*(X1-X2) 23 - IF(DIV1.EQ.0.OR.DIV2.EQ.0)RETURN 24 - XMIN=(X1**2*(Y3-Y2)+X2**2*(Y1-Y3)+X3**2*(Y2-Y1))/DIV1 25 - YMIN=(X1**2*(X2*Y3-X3*Y2)+X2**2*(X3*Y1-X1*Y3)+ 26 - - X3**2*(X1*Y2-X2*Y1)-DIV1*XMIN**2/2)/DIV2 27 - IFAIL=0 28 - *** See whether it is a maximum or a minimum. 29 - IF(DIV1/DIV2.GT.0)THEN 30 - IFLAG=+1 31 - ELSE 32 - IFLAG=-1 33 - ENDIF 34 - *** Make a single precision copy. 35 - UMIN=XMIN 36 - VMIN=YMIN 37 - END 666 GARFIELD ================================================== P=DRIFT D=DRFCLS 1 ============================ 0 + +DECK,DRFCLS. 1 - SUBROUTINE DRFCLS 2 - *----------------------------------------------------------------------- 3 - * DRFCLS - Studies clustering 4 - * (Last changed on 12/ 6/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9 - INTEGER NNHIST 10 - PARAMETER(NNHIST=6) 11 - INTEGER NWORD,INEXT,I,IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5,IFAIL6, 12 - - NITER,NITERR,NCHA(NNHIST),NCHAR,NPAIR,IRSIZE,IRCLUS,IRDELT, 13 - - IRRANG,IRETOT,IRECLS,NCLUS,INPCMP,INPTYP,J 14 - REAL XCLS,YCLS,ZCLS,ECLS,RANGE,XINP0,XINP1,TRALEN,DIST,ETOT, 15 - - RANGEH(2,NNHIST),RMINR,RMAXR 16 - LOGICAL DONE,LKEEP,AUTO(NNHIST),LHISPL 17 - EXTERNAL INPCMP,INPTYP 0 18-+ +SELF,IF=SAVE. 19 - SAVE NITER,NCHA,LKEEP,LHISPL 0 20-+ +SELF. 21 - DATA NITER /200/, LKEEP /.FALSE./, LHISPL /.TRUE./ 22 - *** Initial binning settings. 23 - DO 20 I=1,NNHIST 24 - AUTO(I)=.TRUE. 25 - RANGEH(1,I)=0 26 - RANGEH(2,I)=0 27 - NCHA(I)=100 28 - 20 CONTINUE 29 - *** Count words. 30 - CALL INPNUM(NWORD) 31 - *** Loop over the words. 32 - INEXT=2 33 - DO 10 I=2,NWORD 34 - IF(I.LT.INEXT)GOTO 10 35 - * Number of iterations. 36 - IF(INPCMP(I,'ITER#ATIONS')+INPCMP(I,'ITER#ATE').NE.0)THEN 37 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN 38 - CALL INPMSG(I,'Has 1 integer argument.') 39 - ELSE 40 - CALL INPCHK(I+1,1,IFAIL1) 41 - CALL INPRDI(I+1,NITERR,NITER) 42 - IF(NITERR.GT.0)THEN 43 - NITER=NITERR 44 - ELSE 1 666 P=DRIFT D=DRFCLS 2 PAGE1020 45 - CALL INPMSG(I+1,'Must be > 0.') 46 - ENDIF 47 - INEXT=I+2 48 - ENDIF 49 - * Number of bins. 50 - ELSEIF(INPCMP(I,'BIN#S')+INPCMP(I,'CH#ANNELS').NE.0)THEN 51 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN 52 - CALL INPMSG(I,'Has 1 integer argument.') 53 - ELSE 54 - CALL INPCHK(I+1,1,IFAIL1) 55 - CALL INPRDI(I+1,NCHAR,100) 56 - IF(NCHAR.GT.0.AND.NCHAR.LE.MXCHA)THEN 57 - DO 30 J=1,NNHIST 58 - NCHA(J)=NCHAR 59 - 30 CONTINUE 60 - ELSE 61 - CALL INPMSG(I+1,'Not in [1,MXCHA].') 62 - ENDIF 63 - INEXT=I+2 64 - ENDIF 65 - ELSEIF(INPCMP(I,'CL#USTERS-S#IZE-BIN#S')+ 66 - - INPCMP(I,'CL#USTERS-S#IZE-CH#ANNELS').NE.0)THEN 67 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN 68 - CALL INPMSG(I,'Has 1 integer argument.') 69 - ELSE 70 - CALL INPCHK(I+1,1,IFAIL1) 71 - CALL INPRDI(I+1,NCHAR,100) 72 - IF(NCHAR.GT.0.AND.NCHAR.LE.MXCHA)THEN 73 - NCHA(1)=NCHAR 74 - ELSE 75 - CALL INPMSG(I+1,'Not in [1,MXCHA].') 76 - ENDIF 77 - INEXT=I+2 78 - ENDIF 79 - ELSEIF(INPCMP(I,'CL#USTERS-C#OUNT-BIN#S')+ 80 - - INPCMP(I,'CL#USTERS-C#OUNT-CH#ANNELS').NE.0)THEN 81 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN 82 - CALL INPMSG(I,'Has 1 integer argument.') 83 - ELSE 84 - CALL INPCHK(I+1,1,IFAIL1) 85 - CALL INPRDI(I+1,NCHAR,100) 86 - IF(NCHAR.GT.0.AND.NCHAR.LE.MXCHA)THEN 87 - NCHA(2)=NCHAR 88 - ELSE 89 - CALL INPMSG(I+1,'Not in [1,MXCHA].') 90 - ENDIF 91 - INEXT=I+2 92 - ENDIF 93 - ELSEIF(INPCMP(I,'DEL#TA-R#ANGE-BIN#S')+ 94 - - INPCMP(I,'DELTA-R#ANGE-CH#ANNELS').NE.0)THEN 95 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN 96 - CALL INPMSG(I,'Has 1 integer argument.') 97 - ELSE 98 - CALL INPCHK(I+1,1,IFAIL1) 99 - CALL INPRDI(I+1,NCHAR,100) 100 - IF(NCHAR.GT.0.AND.NCHAR.LE.MXCHA)THEN 101 - NCHA(3)=NCHAR 102 - ELSE 103 - CALL INPMSG(I+1,'Not in [1,MXCHA].') 104 - ENDIF 105 - INEXT=I+2 106 - ENDIF 107 - ELSEIF(INPCMP(I,'TR#ACK-R#ANGE-BIN#S')+ 108 - - INPCMP(I,'TR#ACK-R#ANGE-CH#ANNELS').NE.0)THEN 109 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN 110 - CALL INPMSG(I,'Has 1 integer argument.') 111 - ELSE 112 - CALL INPCHK(I+1,1,IFAIL1) 113 - CALL INPRDI(I+1,NCHAR,100) 114 - IF(NCHAR.GT.0.AND.NCHAR.LE.MXCHA)THEN 115 - NCHA(4)=NCHAR 116 - ELSE 117 - CALL INPMSG(I+1,'Not in [1,MXCHA].') 118 - ENDIF 119 - INEXT=I+2 120 - ENDIF 121 - ELSEIF(INPCMP(I,'CL#USTERS-E#NERGY-BIN#S')+ 122 - - INPCMP(I,'CL#USTERS-E#NERGY-CH#ANNELS').NE.0)THEN 123 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN 124 - CALL INPMSG(I,'Has 1 integer argument.') 125 - ELSE 126 - CALL INPCHK(I+1,1,IFAIL1) 127 - CALL INPRDI(I+1,NCHAR,100) 128 - IF(NCHAR.GT.0.AND.NCHAR.LE.MXCHA)THEN 129 - NCHA(5)=NCHAR 130 - ELSE 131 - CALL INPMSG(I+1,'Not in [1,MXCHA].') 132 - ENDIF 133 - INEXT=I+2 134 - ENDIF 135 - ELSEIF(INPCMP(I,'E#NERGY-L#OSS-BIN#S')+ 136 - - INPCMP(I,'E#NERGY-L#OSS-CH#ANNELS').NE.0)THEN 137 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN 138 - CALL INPMSG(I,'Has 1 integer argument.') 139 - ELSE 140 - CALL INPCHK(I+1,1,IFAIL1) 141 - CALL INPRDI(I+1,NCHAR,100) 142 - IF(NCHAR.GT.0.AND.NCHAR.LE.MXCHA)THEN 143 - NCHA(6)=NCHAR 144 - ELSE 145 - CALL INPMSG(I+1,'Not in [1,MXCHA].') 146 - ENDIF 147 - INEXT=I+2 148 - ENDIF 149 - * Ranges of the various histograms. 150 - ELSEIF(INPCMP(I,'CL#USTERS-S#IZE-RAN#GE').NE.0)THEN 1 666 P=DRIFT D=DRFCLS 3 PAGE1021 151 - IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN 152 - AUTO(1)=.TRUE. 153 - INEXT=I+2 154 - ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. 155 - - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. 156 - - I+2.GT.NWORD)THEN 157 - CALL INPMSG(I,'Has 2 real arguments.') 158 - ELSE 159 - CALL INPCHK(I+1,2,IFAIL1) 160 - CALL INPCHK(I+2,2,IFAIL2) 161 - CALL INPRDR(I+1,RMINR,RANGEH(1,1)) 162 - CALL INPRDR(I+2,RMAXR,RANGEH(2,1)) 163 - IF(RMINR.EQ.RMAXR)THEN 164 - CALL INPMSG(I,'Zero range not permitted.') 165 - ELSE 166 - RANGEH(1,1)=RMINR 167 - RANGEH(2,1)=RMAXR 168 - AUTO(1)=.FALSE. 169 - ENDIF 170 - INEXT=I+3 171 - ENDIF 172 - ELSEIF(INPCMP(I,'CL#USTERS-C#OUNT-RAN#GE').NE.0)THEN 173 - IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN 174 - AUTO(2)=.TRUE. 175 - INEXT=I+2 176 - ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. 177 - - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. 178 - - I+2.GT.NWORD)THEN 179 - CALL INPMSG(I,'Has 2 real arguments.') 180 - ELSE 181 - CALL INPCHK(I+1,2,IFAIL1) 182 - CALL INPCHK(I+2,2,IFAIL2) 183 - CALL INPRDR(I+1,RMINR,RANGEH(1,1)) 184 - CALL INPRDR(I+2,RMAXR,RANGEH(2,1)) 185 - IF(RMINR.EQ.RMAXR)THEN 186 - CALL INPMSG(I,'Zero range not permitted.') 187 - ELSE 188 - RANGEH(1,2)=RMINR 189 - RANGEH(2,2)=RMAXR 190 - AUTO(2)=.FALSE. 191 - ENDIF 192 - INEXT=I+3 193 - ENDIF 194 - ELSEIF(INPCMP(I,'DEL#TA-R#ANGE-RAN#GE').NE.0)THEN 195 - IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN 196 - AUTO(3)=.TRUE. 197 - INEXT=I+2 198 - ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. 199 - - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. 200 - - I+2.GT.NWORD)THEN 201 - CALL INPMSG(I,'Has 2 real arguments.') 202 - ELSE 203 - CALL INPCHK(I+1,2,IFAIL1) 204 - CALL INPCHK(I+2,2,IFAIL2) 205 - CALL INPRDR(I+1,RMINR,RANGEH(1,1)) 206 - CALL INPRDR(I+2,RMAXR,RANGEH(2,1)) 207 - IF(RMINR.EQ.RMAXR)THEN 208 - CALL INPMSG(I,'Zero range not permitted.') 209 - ELSE 210 - RANGEH(1,3)=RMINR 211 - RANGEH(2,3)=RMAXR 212 - AUTO(3)=.FALSE. 213 - ENDIF 214 - INEXT=I+3 215 - ENDIF 216 - ELSEIF(INPCMP(I,'TR#ACK-R#ANGE-RAN#GE').NE.0)THEN 217 - IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN 218 - AUTO(4)=.TRUE. 219 - INEXT=I+2 220 - ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. 221 - - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. 222 - - I+2.GT.NWORD)THEN 223 - CALL INPMSG(I,'Has 2 real arguments.') 224 - ELSE 225 - CALL INPCHK(I+1,2,IFAIL1) 226 - CALL INPCHK(I+2,2,IFAIL2) 227 - CALL INPRDR(I+1,RMINR,RANGEH(1,1)) 228 - CALL INPRDR(I+2,RMAXR,RANGEH(2,1)) 229 - IF(RMINR.EQ.RMAXR)THEN 230 - CALL INPMSG(I,'Zero range not permitted.') 231 - ELSE 232 - RANGEH(1,4)=RMINR 233 - RANGEH(2,4)=RMAXR 234 - AUTO(4)=.FALSE. 235 - ENDIF 236 - INEXT=I+3 237 - ENDIF 238 - ELSEIF(INPCMP(I,'CL#USTERS-E#NERGY-RAN#GE').NE.0)THEN 239 - IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN 240 - AUTO(5)=.TRUE. 241 - INEXT=I+2 242 - ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. 243 - - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. 244 - - I+2.GT.NWORD)THEN 245 - CALL INPMSG(I,'Has 2 real arguments.') 246 - ELSE 247 - CALL INPCHK(I+1,2,IFAIL1) 248 - CALL INPCHK(I+2,2,IFAIL2) 249 - CALL INPRDR(I+1,RMINR,RANGEH(1,1)) 250 - CALL INPRDR(I+2,RMAXR,RANGEH(2,1)) 251 - IF(RMINR.EQ.RMAXR)THEN 252 - CALL INPMSG(I,'Zero range not permitted.') 253 - ELSE 254 - RANGEH(1,5)=RMINR 255 - RANGEH(2,5)=RMAXR 256 - AUTO(5)=.FALSE. 1 666 P=DRIFT D=DRFCLS 4 PAGE1022 257 - ENDIF 258 - INEXT=I+3 259 - ENDIF 260 - ELSEIF(INPCMP(I,'E#NERGY-L#OSS-RAN#GE').NE.0)THEN 261 - IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN 262 - AUTO(6)=.TRUE. 263 - INEXT=I+2 264 - ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. 265 - - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. 266 - - I+2.GT.NWORD)THEN 267 - CALL INPMSG(I,'Has 2 real arguments.') 268 - ELSE 269 - CALL INPCHK(I+1,2,IFAIL1) 270 - CALL INPCHK(I+2,2,IFAIL2) 271 - CALL INPRDR(I+1,RMINR,RANGEH(1,1)) 272 - CALL INPRDR(I+2,RMAXR,RANGEH(2,1)) 273 - IF(RMINR.EQ.RMAXR)THEN 274 - CALL INPMSG(I,'Zero range not permitted.') 275 - ELSE 276 - RANGEH(1,6)=RMINR 277 - RANGEH(2,6)=RMAXR 278 - AUTO(6)=.FALSE. 279 - ENDIF 280 - INEXT=I+3 281 - ENDIF 282 - * Keep histograms or not. 283 - ELSEIF(INPCMP(I,'KEEP-#HISTOGRAMS').NE.0)THEN 284 - LKEEP=.TRUE. 285 - ELSEIF(INPCMP(I,'NOKEEP-#HISTOGRAMS').NE.0)THEN 286 - LKEEP=.FALSE. 287 - * Plot the histograms or not. 288 - ELSEIF(INPCMP(I,'PL#OT-#HISTOGRAMS').NE.0)THEN 289 - LHISPL=.TRUE. 290 - ELSEIF(INPCMP(I,'NOPL#OT-#HISTOGRAMS').NE.0)THEN 291 - LHISPL=.FALSE. 292 - * Other keywords are not known. 293 - ELSE 294 - CALL INPMSG(I,'Not a known keyword.') 295 - ENDIF 296 - 10 CONTINUE 297 - * Print error messages. 298 - CALL INPERR 299 - *** Set the progress print. 300 - CALL PROINT('CLUSTER',1,6) 301 - *** Book histograms. 302 - CALL HISADM('INTEGER',IRSIZE,NCHA(1),RANGEH(1,1),RANGEH(2,1), 303 - - AUTO(1),IFAIL1) 304 - CALL HISADM('INTEGER',IRCLUS,NCHA(2),RANGEH(1,2),RANGEH(2,2), 305 - - AUTO(2),IFAIL2) 306 - CALL HISADM('ALLOCATE',IRDELT,NCHA(3),RANGEH(1,3),RANGEH(2,3), 307 - - AUTO(3),IFAIL3) 308 - CALL HISADM('ALLOCATE',IRRANG,NCHA(4),RANGEH(1,4),RANGEH(2,4), 309 - - AUTO(4),IFAIL4) 310 - CALL HISADM('ALLOCATE',IRECLS,NCHA(5),RANGEH(1,5),RANGEH(2,5), 311 - - AUTO(5),IFAIL5) 312 - CALL HISADM('ALLOCATE',IRETOT,NCHA(6),RANGEH(1,6),RANGEH(2,6), 313 - - AUTO(6),IFAIL6) 314 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. 315 - - IFAIL4.NE.0.OR.IFAIL5.NE.0.OR.IFAIL6.NE.0)THEN 316 - PRINT *,' !!!!!! DRFCLS WARNING : Allocating one or more'// 317 - - ' histograms failed; no plots.' 318 - GOTO 500 319 - ENDIF 320 - *** Now generate the true sample. 321 - CALL PROFLD(1,'Tracks',REAL(NITER)) 322 - DO 200 I=1,NITER 323 - IF(I.EQ.10*(I/10))CALL PROSTA(1,REAL(I)) 324 - NCLUS=0 325 - RANGE=0 326 - ETOT=0 327 - * Prepare track. 328 - CALL TRACLI 329 - * Loop over clusters. 330 - 210 CONTINUE 331 - * Generate clusters. 332 - CALL TRACLS(XCLS,YCLS,ZCLS,ECLS,NPAIR,DONE,IFAIL1) 333 - * Check whether done. 334 - IF(DONE)THEN 335 - CALL HISENT(IRCLUS,REAL(NCLUS),1.0) 336 - CALL HISENT(IRRANG,RANGE,1.0) 337 - CALL HISENT(IRETOT,ETOT,1.0) 338 - GOTO 200 339 - * Check error status. 340 - ELSEIF(IFAIL1.NE.0)THEN 341 - PRINT *,' !!!!!! DRFCLS WARNING : Cluster generation'// 342 - - ' failed; no plots made.' 343 - GOTO 500 344 - ENDIF 345 - * Enter size in histogram. 346 - CALL HISENT(IRSIZE,REAL(NPAIR),1.0) 347 - * Enter energy in histogram. 348 - CALL HISENT(IRECLS,1E6*ECLS,1.0) 349 - * Keep range up to date. 350 - RANGE=MAX(RANGE,SQRT((XCLS-XT0)**2+(YCLS-YT0)**2+ 351 - - (ZCLS-ZT0)**2)) 352 - * Keep energy up to date. 353 - ETOT=ETOT+ECLS 354 - * Compute distance from track. 355 - TRALEN=(XT1-XT0)**2+(YT1-YT0)**2+(ZT1-ZT0)**2 356 - IF(TRALEN.LE.0.0)THEN 357 - DIST=SQRT((XT1-XCLS)**2+(YT1-YCLS)**2+(ZT1-ZCLS)**2) 358 - ELSE 359 - XINP0=(XT1-XT0)*(XCLS-XT0)+(YT1-YT0)*(YCLS-YT0)+ 360 - - (ZT1-ZT0)*(ZCLS-ZT0) 361 - XINP1=(XT0-XT1)*(XCLS-XT1)+(YT0-YT1)*(YCLS-YT1)+ 362 - - (ZT0-ZT1)*(ZCLS-ZT1) 1 666 P=DRIFT D=DRFCLS 5 PAGE1023 363 - IF(XINP1**2*((XCLS-XT0)**2+(YCLS-YT0)**2+ 364 - - (ZCLS-ZT0)**2).GT.XINP0**2*((XCLS-XT1)**2+ 365 - - (YCLS-YT1)**2+(ZCLS-ZT1)**2))THEN 366 - DIST=SQRT(MAX(0.0,(XCLS-XT0)**2+(YCLS-YT0)**2+ 367 - - (ZCLS-ZT0)**2-XINP0**2/TRALEN)) 368 - ELSE 369 - DIST=SQRT(MAX(0.0,(XCLS-XT1)**2+(YCLS-YT1)**2+ 370 - - (ZCLS-ZT1)**2-XINP1**2/TRALEN)) 371 - ENDIF 372 - ENDIF 373 - CALL HISENT(IRDELT,DIST,1.0) 374 - * Increment statistics. 375 - NCLUS=NCLUS+1 376 - GOTO 210 377 - 200 CONTINUE 378 - CALL PROEND 379 - *** Plot the histograms. 380 - IF(LHISPL)THEN 381 - CALL HISPLT(IRCLUS,'Number of deposits', 382 - - 'Number of clusters per track',.TRUE.) 383 - CALL GRNEXT 384 - CALL HISPLT(IRSIZE,'Number of electrons', 385 - - 'Number of electrons per cluster',.TRUE.) 386 - CALL GRNEXT 387 - CALL HISPLT(IRRANG,'Range [cm]', 388 - - 'Range of the track',.TRUE.) 389 - CALL GRNEXT 390 - CALL HISPLT(IRDELT,'Distance [cm]', 391 - - 'Distance between cluster and track',.TRUE.) 392 - CALL GRNEXT 393 - CALL HISPLT(IRECLS,'Energy [eV]', 394 - - 'Energy per cluster',.TRUE.) 395 - CALL GRNEXT 396 - CALL HISPLT(IRETOT,'Energy [MeV]', 397 - - 'Total energy loss',.TRUE.) 398 - CALL GRNEXT 399 - ENDIF 400 - *** Delete histograms. 401 - 500 CONTINUE 402 - IF(LKEEP)THEN 403 - CALL HISSAV(IRSIZE,'SIZE',IFAIL1) 404 - CALL HISSAV(IRCLUS,'CLUSTERS',IFAIL2) 405 - CALL HISSAV(IRDELT,'DELTA',IFAIL3) 406 - CALL HISSAV(IRRANG,'RANGE',IFAIL4) 407 - CALL HISSAV(IRETOT,'DE',IFAIL5) 408 - CALL HISSAV(IRECLS,'ECLUSTER',IFAIL6) 409 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. 410 - - IFAIL4.NE.0.OR.IFAIL5.NE.0.OR.IFAIL6.NE.0)THEN 411 - PRINT *,' !!!!!! DRFCLS WARNING : Saving one or'// 412 - - ' more histograms failed.' 413 - ELSE 414 - PRINT *,' ------ DRFCLS MESSAGE : Histograms saved'// 415 - - ' as SIZE, CLUSTERS, DELTA, RANGE, DE and'// 416 - - ' ECLUSTER.' 417 - ENDIF 418 - ELSE 419 - CALL HISADM('DELETE',IRSIZE,NCHA,0.0,0.0,.FALSE.,IFAIL1) 420 - CALL HISADM('DELETE',IRCLUS,NCHA,0.0,0.0,.FALSE.,IFAIL2) 421 - CALL HISADM('DELETE',IRDELT,NCHA,0.0,0.0,.FALSE.,IFAIL3) 422 - CALL HISADM('DELETE',IRRANG,NCHA,0.0,0.0,.FALSE.,IFAIL4) 423 - CALL HISADM('DELETE',IRECLS,NCHA,0.0,0.0,.FALSE.,IFAIL5) 424 - CALL HISADM('DELETE',IRETOT,NCHA,0.0,0.0,.FALSE.,IFAIL6) 425 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. 426 - - IFAIL4.NE.0.OR.IFAIL5.NE.0.OR.IFAIL6.NE.0) 427 - - PRINT *,' !!!!!! DRFCLS WARNING : Deleting one'// 428 - - ' or more histograms failed.' 429 - ENDIF 430 - END 667 GARFIELD ================================================== P=DRIFTCAL D= 1 ============================ 0 + +PATCH,DRIFTCAL. 668 GARFIELD ================================================== P=DRIFTCAL D=DLCALC 1 ============================ 0 + +DECK,DLCALC. 1 - SUBROUTINE DLCALC(X1,Y1,Z1,Q,ITYPE) 2 - *----------------------------------------------------------------------- 3 - * DLCALC - Subroutine doing the actual drift line calculations. It 4 - * communicates with the outside through sequence DRIFTLINE. 5 - * The calculations are based on a Runge-Kutta-Fehlberg method 6 - * which has the advantage of controlling the stepsize and the 7 - * error while needing only relatively few calls to EFIELD. 8 - * Full details are given in the reference quoted below. 9 - * VARIABLES : H : Current stepsize (it is in fact a delta t). 10 - * HPREV : Stores the previous value of H (comparison) 11 - * INITCH : Used for checking initial stepsize (1 = ok) 12 - * Other variables such as F0, F1, F2, F3, PHII, PHIII, 13 - * CI. ,CII. , BETA.. etc are explained in the reference. 14 - * REFERENCE : Stoer + Bulirsch, Einfuhrung in die Numerische 15 - * Mathematic II, chapter 7, page 122, 1978, HTB, Springer. 16 - * (Last changed on 30/11/98.) 17 - *----------------------------------------------------------------------- 18 - implicit none 19.- +SEQ,DIMENSIONS. 20.- +SEQ,CELLDATA. 21.- +SEQ,PARAMETERS. 22.- +SEQ,DRIFTLINE. 23.- +SEQ,PRINTPLOT. 24 - DOUBLE PRECISION F0(3),F1(3),F2(3),F3(3),PHII(3),PHIII(3), 25 - - X0,Y0,Z0,H,HPREV,CI0,CI1,CI2,CII0,CII2,CII3, 26 - - BETA10,BETA20,BETA21,BETA30,BETA31,BETA32, 27 - - DIST21,DIST22,DIST23,XST0,YST0,XST1,YST1 28 - INTEGER IPLANE,IFLAG1,IFLAG2,IFLAG3,ILOC,ILOC1,ILOC2,ILOC3, 29 - - INITCH,ITYPE,IOUT 30 - REAL Q,X1,Y1,Z1,EX,EY,EZ,ETOT,VOLT 1 668 P=DRIFTCAL D=DLCALC 2 PAGE1024 31 - *** Initialise the constants appearing in the RKF formulas. 32 - PARAMETER(CI0 =214.0D0/ 891.0D0,CI1 = 1.0D0/ 33.0D0, 33 - - CI2 =650.0D0/ 891.0D0,CII0 = 533.0D0/2106.0D0, 34 - - CII2 =800.0D0/1053.0D0,CII3 = -1.0D0/ 78.0D0, 35 - - BETA10= 1.0D0/ 4.0D0,BETA20=-189.0D0/ 800.0D0, 36 - - BETA21=729.0D0/ 800.0D0,BETA30= 214.0D0/ 891.0D0, 37 - - BETA31= 1.0D0/ 33.0D0,BETA32= 650.0D0/ 891.0D0) 38 - *** Use these lines if the compiler rejects the PARAMETER statements. 39 - C+SELF,IF=SAVE. 40 - C SAVE CI0,CI1,CI2,CII0,CII2,CII3 41 - C SAVE BETA10,BETA20,BETA21,BETA30,BETA31,BETA32 42 - C+SELF. 43 - C DATA CI0 ,CI1 ,CI2 /0.240179574, 0.030303030, 0.729517396/ 44 - C DATA CII0 ,CII2 ,CII3 /0.253086420, 0.759734093,-0.012820513/ 45 - C DATA BETA10,BETA20,BETA21/0.25, -0.23625, 0.91125 / 46 - C DATA BETA30,BETA31,BETA32/0.240179574, 0.030303030, 0.729517396/ 47 - *** Identify the routine if requested. 48 - IF(LIDENT)PRINT *,' /// ROUTINE DLCALC ///' 49 - *** Initialise the output position and time vectors. 50 - NU=1 51 - XU(1)=DBLE(X1) 52 - YU(1)=DBLE(Y1) 53 - ZU(1)=DBLE(Z1) 54 - TU(1)=0.0D0 55 - ISTAT=0 56 - IPTYPE=ITYPE 57 - IPTECH=1 58 - QPCHAR=Q 59 - *** Check the initial position, setting a status code if appropriate. 60 - CALL EFIELD(X1,Y1,Z1,EX,EY,EZ,ETOT,VOLT,0,ILOC) 61 - * In a wire. 62 - IF(ILOC.GT.0.AND.ILOC.LE.MXWIRE)THEN 63 - IF((X(ILOC)-X1)**2+(Y(ILOC)-Y1)**2.LE.0.25*D(ILOC)**2)THEN 64 - ISTAT=ILOC 65 - ELSE 66 - ISTAT=ILOC+MXWIRE 67 - ENDIF 68 - * Outside the planes. 69 - ELSEIF(ILOC.EQ.-1.OR.ILOC.EQ.-4)THEN 70 - IF(YNPLAN(1).AND.X1.LE.COPLAN(1))THEN 71 - ISTAT=-11 72 - ELSEIF(YNPLAN(2).AND.X1.GE.COPLAN(2))THEN 73 - ISTAT=-12 74 - ELSEIF(YNPLAN(3).AND.Y1.LE.COPLAN(3))THEN 75 - ISTAT=-13 76 - ELSEIF(YNPLAN(4).AND.Y1.GE.COPLAN(4))THEN 77 - ISTAT=-14 78 - ELSEIF(TUBE)THEN 79 - CALL INTUBE(X1,Y1,COTUBE,NTUBE,IOUT) 80 - IF(IOUT.EQ.1)ISTAT=-15 81 - ENDIF 82 - IF(ISTAT.EQ.0)THEN 83 - PRINT *,' !!!!!! DLCALC WARNING : Field location'// 84 - - ' code does not match geometry; please report.' 85 - ISTAT=-4 86 - ENDIF 87 - * In a material. 88 - ELSEIF(ILOC.EQ.-5)THEN 89 - ISTAT=-5 90 - * Outside the mesh. 91 - ELSEIF(ILOC.EQ.-6)THEN 92 - ISTAT=-6 93 - * Other bizarre codes. 94 - ELSEIF(ILOC.NE.0)THEN 95 - PRINT *,' ###### DLCALC ERROR : Unexpected ILOC=',ILOC, 96 - - ' received from EFIELD ; program bug, please report.' 97 - ISTAT=-3 98 - ENDIF 99 - * Always return if location code is non-zero. 100 - IF(ILOC.NE.0)RETURN 101 - *** Check the initial status, establishing eg the target wire. 102 - CALL DLCSTA(Q,ITYPE) 103 - IF(ISTAT.NE.0)RETURN 104 - *** Set the initial step-size, zero drift-field should be exceptional. 105 - CALL DLCVEL(DBLE(X1),DBLE(Y1),DBLE(Z1),F0,Q,ITYPE,ILOC) 106 - IF(F0(1)**2+F0(2)**2+F0(3)**2.EQ.0.0)THEN 107 - PRINT *,' !!!!!! DLCALC WARNING : Drift line starts from'// 108 - - ' a zero E-field point.' 109 - ISTAT=-3 110 - RETURN 111 - ELSE 112 - H=EPSDIF/SQRT(F0(1)**2+F0(2)**2+F0(3)**2) 113 - ENDIF 114 - * Allow INITCH cycles to adjust the initial step-size. 115 - INITCH=3 116 - 20 CONTINUE 117 - NU=1 118 - * And also store the initial point locally in scalar double precision. 119 - X0=DBLE(X1) 120 - Y0=DBLE(Y1) 121 - Z0=DBLE(Z1) 122 - *** Take steps of size H (adjusted every cycle). 123 - 30 CONTINUE 124 - CALL DLCVEL( 125 - - X0+H*BETA10*F0(1), 126 - - Y0+H*BETA10*F0(2), 127 - - Z0+H*BETA10*F0(3), 128 - - F1,Q,ITYPE,ILOC1) 129 - CALL DLCVEL( 130 - - X0+H*(BETA20*F0(1)+BETA21*F1(1)), 131 - - Y0+H*(BETA20*F0(2)+BETA21*F1(2)), 132 - - Z0+H*(BETA20*F0(3)+BETA21*F1(3)), 133 - - F2,Q,ITYPE,ILOC2) 134 - CALL DLCVEL( 135 - - X0+H*(BETA30*F0(1)+BETA31*F1(1)+BETA32*F2(1)), 136 - - Y0+H*(BETA30*F0(2)+BETA31*F1(2)+BETA32*F2(2)), 1 668 P=DRIFTCAL D=DLCALC 3 PAGE1025 137 - - Z0+H*(BETA30*F0(3)+BETA31*F1(3)+BETA32*F2(3)), 138 - - F3,Q,ITYPE,ILOC3) 139 - *** Check that the target wire is not crossed while exploring the field. 140 - IF(ITARG.GT.0)THEN 141 - CALL DLCMIN(XTARG,YTARG,X0,Y0, 142 - - X0+H*BETA10*F0(1),Y0+H*BETA10*F0(2), 143 - - DIST21,IFLAG1) 144 - CALL DLCMIN(XTARG,YTARG,X0,Y0, 145 - - X0+H*(BETA20*F0(1)+BETA21*F1(1)), 146 - - Y0+H*(BETA20*F0(2)+BETA21*F1(2)), 147 - - DIST22,IFLAG2) 148 - CALL DLCMIN(XTARG,YTARG,X0,Y0, 149 - - X0+H*(BETA30*F0(1)+BETA31*F1(1)+BETA32*F2(1)), 150 - - Y0+H*(BETA30*F0(2)+BETA31*F1(2)+BETA32*F2(2)), 151 - - DIST23,IFLAG3) 152 - * If it is, quit at this point after terminating via DLCWIR. 153 - IF(DIST21.LT.0.25*DTARG**2.OR.DIST22.LT.0.25*DTARG**2.OR. 154 - - DIST23.LT.0.25*DTARG**2)THEN 155 - IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : DLCWIR', 156 - - ' entered from DLCALC.' 157 - CALL DLCWIR(1,Q,ITYPE) 158 - RETURN 159 - ENDIF 160 - ENDIF 161 - *** Check that none of the planes was crossed during this computation. 162 - IF(YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4))THEN 163 - XST0=MIN(X0+H*BETA10*F0(1),X0+H*(BETA20*F0(1)+BETA21*F1(1)), 164 - - X0+H*(BETA30*F0(1)+BETA31*F1(1)+BETA32*F2(1))) 165 - YST0=MIN(Y0+H*BETA10*F0(2),Y0+H*(BETA20*F0(2)+BETA21*F1(2)), 166 - - Y0+H*(BETA30*F0(2)+BETA31*F1(2)+BETA32*F2(2))) 167 - XST1=MAX(X0+H*BETA10*F0(1),X0+H*(BETA20*F0(1)+BETA21*F1(1)), 168 - - X0+H*(BETA30*F0(1)+BETA31*F1(1)+BETA32*F2(1))) 169 - YST1=MAX(Y0+H*BETA10*F0(2),Y0+H*(BETA20*F0(2)+BETA21*F1(2)), 170 - - Y0+H*(BETA30*F0(2)+BETA31*F1(2)+BETA32*F2(2))) 171 - IPLANE=0 172 - IF(YNPLAN(1).AND.XST0.LE.COPLAN(1))IPLANE=1 173 - IF(YNPLAN(2).AND.XST1.GE.COPLAN(2))IPLANE=2 174 - IF(YNPLAN(3).AND.YST0.LE.COPLAN(3))IPLANE=3 175 - IF(YNPLAN(4).AND.YST1.GE.COPLAN(4))IPLANE=4 176 - IF(IPLANE.NE.0)THEN 177 - IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : Plane ', 178 - - IPLANE,' was crossed during the last step.' 179 - CALL DLCPLA(IPLANE,Q,ITYPE) 180 - RETURN 181 - ENDIF 182 - ENDIF 183 - *** Check that no dielectric was entered nor that the mesh was left. 184 - IF(ICTYPE.EQ.0.AND.(ILOC1.NE.0.OR.ILOC2.NE.0.OR.ILOC3.NE.0))THEN 185 - IF(ILOC1.NE.0)THEN 186 - CALL DLCFMP(X0,Y0,Z0, 187 - - X0+H*BETA10*F0(1), 188 - - Y0+H*BETA10*F0(2), 189 - - Z0+H*BETA10*F0(3), 190 - - ILOC1,Q,ITYPE) 191 - ELSEIF(ILOC2.NE.0)THEN 192 - CALL DLCFMP(X0,Y0,Z0, 193 - - X0+H*(BETA20*F0(1)+BETA21*F1(1)), 194 - - Y0+H*(BETA20*F0(2)+BETA21*F1(2)), 195 - - Z0+H*(BETA20*F0(3)+BETA21*F1(3)), 196 - - ILOC2,Q,ITYPE) 197 - ELSEIF(ILOC3.NE.0)THEN 198 - CALL DLCFMP(X0,Y0,Z0, 199 - - X0+H*(BETA30*F0(1)+BETA31*F1(1)+BETA32*F2(1)), 200 - - Y0+H*(BETA30*F0(2)+BETA31*F1(2)+BETA32*F2(2)), 201 - - Z0+H*(BETA30*F0(3)+BETA31*F1(3)+BETA32*F2(3)), 202 - - ILOC3,Q,ITYPE) 203 - ENDIF 204 - IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : Drift medium', 205 - - ' or mesh left at NU=',NU,' ILOC=',ILOC1,ILOC2,ILOC3 206 - RETURN 207 - ENDIF 208 - *** Now set up the correction for (X0,Y0,Z0). 209 - PHII(1)=CI0*F0(1)+CI1*F1(1)+CI2*F2(1) 210 - PHII(2)=CI0*F0(2)+CI1*F1(2)+CI2*F2(2) 211 - PHII(3)=CI0*F0(3)+CI1*F1(3)+CI2*F2(3) 212 - PHIII(1)=CII0*F0(1)+CII2*F2(1)+CII3*F3(1) 213 - PHIII(2)=CII0*F0(2)+CII2*F2(2)+CII3*F3(2) 214 - PHIII(3)=CII0*F0(3)+CII2*F2(3)+CII3*F3(3) 215 - *** Be sure that the step has non-zero length. 216 - IF(SQRT(PHII(1)**2+PHII(2)**2+PHII(3)**2).LE.0)THEN 217 - IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : Step ',NU, 218 - - ' has 0 length; abandoned.' 219 - ISTAT=-3 220 - RETURN 221 - *** Check step size. 222 - ELSEIF(LSTMAX.AND. 223 - - H*SQRT(PHII(1)**2+PHII(2)**2+PHII(3)**2).GT.STMAX)THEN 224 - H=0.5*STMAX/SQRT(PHII(1)**2+PHII(2)**2+PHII(3)**2) 225 - IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : Step ',NU, 226 - - ' is considered too long; H is reduced.' 227 - GOTO 30 228 - C*** Don't allow H to become too large in view of the time resolution. 229 - C ELSEIF(H*ABS(PHII(1)).GT.(DXMAX-DXMIN)/10.0.OR. 230 - C - H*ABS(PHII(2)).GT.(DYMAX-DYMIN)/10.0)THEN 231 - C H=H/2 232 - C IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : Step ',NU, 233 - C - ' is considered too long; H is divided by 2.' 234 - C GOTO 30 235 - *** Check bending angle. 236 - ELSEIF(LKINK.AND.NU.GT.1)THEN 237 - IF(PHII(1)*(XU(NU)-XU(NU-1))+ 238 - - PHII(2)*(YU(NU)-YU(NU-1))+ 239 - - PHII(3)*(ZU(NU)-ZU(NU-1)).LT.0)THEN 240 - ISTAT=-3 241 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCALC DEBUG :'', 242 - - '' Step '',I3,'': bending angle exceeds pi/2.''/ 1 668 P=DRIFTCAL D=DLCALC 4 PAGE1026 243 - - 26X,''Proposed step: '',3E15.8/ 244 - - 26X,''Previous step: '',3E15.8/ 245 - - 26X,''Inner product: '',E15.8)') 246 - - NU+1,PHII(1),PHII(2),PHII(3),XU(NU)-XU(NU-1), 247 - - YU(NU)-YU(NU-1),ZU(NU)-ZU(NU-1), 248 - - PHII(1)*(XU(NU)-XU(NU-1))+ 249 - - PHII(2)*(YU(NU)-YU(NU-1))+ 250 - - PHII(3)*(ZU(NU)-ZU(NU-1)) 251 - RETURN 252 - ENDIF 253 - ENDIF 254 - *** Redefine X0, Y0 and Z0. 255 - X0=X0+H*PHII(1) 256 - Y0=Y0+H*PHII(2) 257 - Z0=Z0+H*PHII(3) 258 - *** Copy new X0 and Y0 to XU and YU, add new TU. 259 - NU=NU+1 260 - XU(NU)=X0 261 - YU(NU)=Y0 262 - ZU(NU)=Z0 263 - TU(NU)=TU(NU-1)+H 264 - *** Check particle position. 265 - CALL DLCSTA(Q,ITYPE) 266 - IF(ISTAT.NE.0)RETURN 267 - *** Adjust step size according to the accuracy of the two estimates. 268 - HPREV=H 269 - IF(PHII(1).NE.PHIII(1).OR.PHII(2).NE.PHIII(2).OR. 270 - - PHII(3).NE.PHIII(3))THEN 271 - H=SQRT(H*EPSDIF/(ABS(PHII(1)-PHIII(1))+ 272 - - ABS(PHII(2)-PHIII(2))+ABS(PHII(3)-PHIII(3)))) 273 - ELSE 274 - IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : H increased by', 275 - - ' a factor of 2 in step ',NU,' (equal estimates).' 276 - H=H*2.0D0 277 - ENDIF 278 - *** Make sure that H is different from zero; this should always be ok. 279 - IF(H.EQ.0.0D0)THEN 280 - PRINT *,' ###### DLCALC ERROR : Step ',NU,' step size is', 281 - - ' zero (program bug) ; the calculation is abandoned.' 282 - ISTAT=-3 283 - RETURN 284 - ENDIF 285 - *** Check the initial step size. 286 - IF(INITCH.GT.0.AND.(H.LT.HPREV/5.0))THEN 287 - C IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : Stepsize', 288 - C - ' reinitialised, current value is ',H 289 - INITCH=INITCH-1 290 - GOTO 20 291 - ENDIF 292 - INITCH=0 293 - *** Don't allow H to grow too quickly. 294 - IF(H.GT.10.0*HPREV)THEN 295 - H=10.0*HPREV 296 - C IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : Step ',NU, 297 - C - ' H restricted to 10 times HPREV.' 298 - ENDIF 299 - *** Make sure we haven't got more than MXLIST points already. 300 - IF(NU.EQ.MXLIST)THEN 301 - ISTAT=-2 302 - RETURN 303 - ENDIF 304 - *** Stop in case H tends to become too small. 305 - IF(H*(ABS(PHII(1))+ABS(PHII(2))+ABS(PHII(3))).LT.EPSDIF)THEN 306 - IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : The step size', 307 - - ' has become smaller than EPSDIF; line abandoned.' 308 - ISTAT=-3 309 - RETURN 310 - ENDIF 311 - *** Remember: F0 equals F3 of the previous step. 312 - F0(1)=F3(1) 313 - F0(2)=F3(2) 314 - F0(3)=F3(3) 315 - GOTO 30 316 - END 669 GARFIELD ================================================== P=DRIFTCAL D=DLCMC 1 ============================ 0 + +DECK,DLCMC. 1 - SUBROUTINE DLCMC(X1,Y1,Z1,Q,ITYPE) 2 - *----------------------------------------------------------------------- 3 - * DLCMC - Subroutine that computes a drift line using a Monte-Carlo 4 - * technique to take account of diffusion. 5 - * VARIABLES : 6 - * REFERENCE : 7 - * (Last changed on 4/ 2/00.) 8 - *----------------------------------------------------------------------- 9 - implicit none 10.- +SEQ,DIMENSIONS. 11.- +SEQ,CELLDATA. 12.- +SEQ,GASDATA. 13.- +SEQ,PARAMETERS. 14.- +SEQ,DRIFTLINE. 15.- +SEQ,PRINTPLOT. 16.- +SEQ,CONSTANTS. 17 - DOUBLE PRECISION F0(3),X0,Y0,Z0,THETA,PHI,DIST,X0NEW,Y0NEW,Z0NEW, 18 - - DVEC(3) 19 - REAL Q,X1,Y1,Z1,EX,EY,EZ,ETOT,VOLT,GASDFT,GASDFL,DT,DL,RNDNOR, 20 - - TSTEP,RNDEXP,TCOLL,BX,BY,BZ,BTOT 21 - INTEGER IFLAG,ILOC,ITYPE,IPLANE,IOUT 22 - EXTERNAL GASDFT,GASDFL,RNDNOR,RNDEXP 23 - *** Identify the routine if requested. 24 - IF(LIDENT)PRINT *,' /// ROUTINE DLCMC ///' 25 - *** Initial debugging output. 26 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCMC DEBUG : MC drift'', 27 - - '' from ('',E15.8,'','',E15.8,'','',E15.8,''), Q='',E8.1, 28 - - '' type='',I2,''.'')') X1,Y1,Z1,Q,ITYPE 1 669 P=DRIFTCAL D=DLCMC 2 PAGE1027 29 - *** Initialise the output position and time vectors. 30 - NU=1 31 - XU(1)=DBLE(X1) 32 - YU(1)=DBLE(Y1) 33 - ZU(1)=DBLE(Z1) 34 - TU(1)=0.0D0 35 - ISTAT=0 36 - IPTYPE=ITYPE 37 - IPTECH=2 38 - QPCHAR=Q 39 - *** Check the initial position, setting a status code if appropriate. 40 - CALL EFIELD(X1,Y1,Z1,EX,EY,EZ,ETOT,VOLT,0,ILOC) 41 - CALL BFIELD(X1,Y1,Z1,BX,BY,BZ,BTOT) 42 - * In a wire. 43 - IF(ILOC.GT.0.AND.ILOC.LE.MXWIRE)THEN 44 - IF((X(ILOC)-X1)**2+(Y(ILOC)-Y1)**2.LE.0.25*D(ILOC)**2)THEN 45 - ISTAT=ILOC 46 - ELSE 47 - ISTAT=ILOC+MXWIRE 48 - ENDIF 49 - * Outside the planes. 50 - ELSEIF(ILOC.EQ.-1.OR.ILOC.EQ.-4)THEN 51 - IF(YNPLAN(1).AND.X1.LE.COPLAN(1))THEN 52 - ISTAT=-11 53 - ELSEIF(YNPLAN(2).AND.X1.GE.COPLAN(2))THEN 54 - ISTAT=-12 55 - ELSEIF(YNPLAN(3).AND.Y1.LE.COPLAN(3))THEN 56 - ISTAT=-13 57 - ELSEIF(YNPLAN(4).AND.Y1.GE.COPLAN(4))THEN 58 - ISTAT=-14 59 - ELSEIF(TUBE)THEN 60 - CALL INTUBE(X1,Y1,COTUBE,NTUBE,IOUT) 61 - IF(IOUT.EQ.1)ISTAT=-15 62 - ENDIF 63 - IF(ISTAT.EQ.0)THEN 64 - PRINT *,' !!!!!! DLCMC WARNING : Field location'// 65 - - ' code does not match geometry; please report.' 66 - ISTAT=-4 67 - ENDIF 68 - * In a material. 69 - ELSEIF(ILOC.EQ.-5)THEN 70 - ISTAT=-5 71 - * Outside the mesh. 72 - ELSEIF(ILOC.EQ.-6)THEN 73 - ISTAT=-6 74 - * Other bizarre codes. 75 - ELSEIF(ILOC.NE.0)THEN 76 - PRINT *,' ###### DLCMC ERROR : Unexpected ILOC=',ILOC, 77 - - ' received from EFIELD ; program bug, please report.' 78 - ISTAT=-3 79 - ENDIF 80 - * Always return if location code is non-zero. 81 - IF(ILOC.NE.0)RETURN 82 - *** Check the initial status, establishing eg the target wire. 83 - CALL DLCSTA(Q,ITYPE) 84 - IF(ISTAT.NE.0)RETURN 85 - *** Store the initial point locally in scalar double precision. 86 - X0=DBLE(X1) 87 - Y0=DBLE(Y1) 88 - Z0=DBLE(Z1) 89 - *** Start making steps. 90 - 30 CONTINUE 91 - * Compute drift velocity. 92 - CALL DLCVEL(X0,Y0,Z0,F0,Q,ITYPE,ILOC) 93 - * Ensure the norm is not zero. 94 - IF(SQRT(F0(1)**2+F0(2)**2+F0(3)**2).LE.0)THEN 95 - IF(LDEBUG)PRINT *,' ++++++ DLCMC DEBUG : Velocity'// 96 - - ' is zero at NU=',NU,'; returning with ISTAT=-3.' 97 - ISTAT=-3 98 - RETURN 99 - ENDIF 100 - * Compute the diffusion terms. 101 - IF(ITYPE.EQ.1)THEN 102 - IF(GASOK(8))THEN 103 - DT=GASDFT(EX,EY,EZ,BX,BY,BZ) 104 - ELSE 105 - DT=0 106 - ENDIF 107 - IF(GASOK(3))THEN 108 - DL=GASDFL(EX,EY,EZ,BX,BY,BZ) 109 - ELSE 110 - DL=0 111 - ENDIF 112 - ELSE 113 - DT=DTION 114 - DL=DLION 115 - ENDIF 116 - * If making fixed size time steps ... 117 - IF(MCMETH.EQ.0)THEN 118 - TSTEP=TMC 119 - * If making fixed distance steps ... 120 - ELSEIF(MCMETH.EQ.1)THEN 121 - TSTEP=DMC/SQRT(F0(1)**2+F0(2)**2+F0(3)**2) 122 - * If making steps based on collision time ... 123 - ELSE 124 - TCOLL=1E8*EMASS*SQRT(F0(1)**2+F0(2)**2+F0(3)**2)/ 125 - - (ECHARG*SQRT(EX**2+EY**2+EZ**2)) 126 - C PRINT *,' Collision time=',TCOLL*1000000,' psec' 127 - TSTEP=NMC*RNDEXP(TCOLL) 128 - ENDIF 129 - * Draw a random diffusion direction in the particle frame. 130 - DVEC(1)=SQRT(SQRT(F0(1)**2+F0(2)**2+F0(3)**2)*TSTEP)* 131 - - RNDNOR(0.0,DL) 132 - DVEC(2)=SQRT(SQRT(F0(1)**2+F0(2)**2+F0(3)**2)*TSTEP)* 133 - - RNDNOR(0.0,DT) 134 - DVEC(3)=SQRT(SQRT(F0(1)**2+F0(2)**2+F0(3)**2)*TSTEP)* 1 669 P=DRIFTCAL D=DLCMC 3 PAGE1028 135 - - RNDNOR(0.0,DT) 136 - * Compute rotation to align (1,0,0) with the drift velocity vector. 137 - IF(F0(1)**2+F0(2)**2.LE.0)THEN 138 - IF(F0(3).LT.0)THEN 139 - THETA=-PI/2 140 - ELSEIF(F0(3).GT.0)THEN 141 - THETA=+PI/2 142 - ELSE 143 - IF(LDEBUG)PRINT *,' ++++++ DLCMC DEBUG : Velocity', 144 - - ' vector of length = 0 seen; returning ISTAT=-3.' 145 - ISTAT=-3 146 - RETURN 147 - ENDIF 148 - PHI=0 149 - ELSE 150 - PHI=ATAN2(F0(2),F0(1)) 151 - THETA=ATAN2(F0(3),SQRT(F0(1)**2+F0(2)**2)) 152 - ENDIF 153 - * Compute the proposed end-point of this step. 154 - X0NEW=X0+TSTEP*F0(1)+COS(PHI)*COS(THETA)*DVEC(1)- 155 - - SIN(PHI)*DVEC(2)-COS(PHI)*SIN(THETA)*DVEC(3) 156 - Y0NEW=Y0+TSTEP*F0(2)+SIN(PHI)*COS(THETA)*DVEC(1)+ 157 - - COS(PHI)*DVEC(2)-SIN(PHI)*SIN(THETA)*DVEC(3) 158 - Z0NEW=Z0+TSTEP*F0(3)+SIN(THETA)*DVEC(1)+COS(THETA)*DVEC(3) 159 - *** Check that the target wire is not crossed while exploring the field. 160 - IF(ITARG.GT.0)THEN 161 - CALL DLCMIN(XTARG,YTARG,X0,Y0,X0NEW,Y0NEW,DIST,IFLAG) 162 - * If it is, quit at this point after terminating via DLCWIR. 163 - IF(DIST.LT.0.25*DTARG**2)THEN 164 - IF(LDEBUG)PRINT *,' ++++++ DLCMC DEBUG : DLCWIR', 165 - - ' entered from DLCMC.' 166 - CALL DLCWIR(1,Q,ITYPE) 167 - RETURN 168 - ENDIF 169 - ENDIF 170 - *** Check that none of the planes was crossed during this computation. 171 - IF(YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4))THEN 172 - IPLANE=0 173 - IF(YNPLAN(1).AND.X0NEW.LE.COPLAN(1))IPLANE=1 174 - IF(YNPLAN(2).AND.X0NEW.GE.COPLAN(2))IPLANE=2 175 - IF(YNPLAN(3).AND.Y0NEW.LE.COPLAN(3))IPLANE=3 176 - IF(YNPLAN(4).AND.Y0NEW.GE.COPLAN(4))IPLANE=4 177 - IF(IPLANE.NE.0)THEN 178 - IF(LDEBUG)PRINT *,' ++++++ DLCMC DEBUG : Plane ', 179 - - IPLANE,' was crossed during the last step.' 180 - CALL DLCPLA(IPLANE,Q,ITYPE) 181 - RETURN 182 - ENDIF 183 - ENDIF 184 - *** Compute the electric field for the next step. 185 - CALL EFIELD(REAL(X0NEW),REAL(Y0NEW),REAL(Z0NEW),EX,EY,EZ,ETOT, 186 - - VOLT,0,ILOC) 187 - CALL BFIELD(REAL(X0NEW),REAL(Y0NEW),REAL(Z0NEW),BX,BY,BZ,BTOT) 188 - *** Check that no dielectric was entered nor that the mesh was left. 189 - IF(ICTYPE.EQ.0.AND.ILOC.NE.0)THEN 190 - CALL DLCFMP(X0,Y0,Z0,X0NEW,Y0NEW,Z0NEW,ILOC,Q,ITYPE) 191 - IF(LDEBUG)PRINT *,' ++++++ DLCMC DEBUG : Drift', 192 - - ' medium or mesh left at NU=',NU,' ILOC=',ILOC 193 - RETURN 194 - ENDIF 195 - *** Redefine X0, Y0 and Z0. 196 - X0=X0NEW 197 - Y0=Y0NEW 198 - Z0=Z0NEW 199 - *** Copy new X0 and Y0 to XU and YU, add new TU. 200 - NU=NU+1 201 - XU(NU)=X0 202 - YU(NU)=Y0 203 - ZU(NU)=Z0 204 - TU(NU)=TU(NU-1)+TSTEP 205 - *** Check particle position. 206 - CALL DLCSTA(Q,ITYPE) 207 - IF(ISTAT.NE.0)RETURN 208 - *** Make sure all exceptions have been caught. 209 - IF(ILOC.NE.0)THEN 210 - IF(LDEBUG)PRINT *,' ++++++ DLCMC DEBUG : Received ILOC=', 211 - - ILOC,' from EFIELD, NU=',NU,'; returning ISTAT=-3.' 212 - ISTAT=-3 213 - RETURN 214 - * Make sure the field is not zero. 215 - ELSEIF(SQRT(EX**2+EY**2+EZ**2).LE.0)THEN 216 - IF(LDEBUG)PRINT *,' ++++++ DLCMC DEBUG : Electric field', 217 - - ' zero at NU=',NU,'; returning with ISTAT=-3.' 218 - ISTAT=-3 219 - RETURN 220 - * Make sure we haven't got more than MXLIST points already. 221 - ELSEIF(NU.EQ.MXLIST)THEN 222 - ISTAT=-2 223 - RETURN 224 - ENDIF 225 - *** And go for the next step. 226 - GOTO 30 227 - END 670 GARFIELD ================================================== P=DRIFTCAL D=DLCMCA 1 ============================ 0 + +DECK,DLCMCA. 1 - SUBROUTINE DLCMCA(X1,Y1,Z1,NETOT,NITOT,STAT, 2 - - NHIST,IHIST,ITYPE,IENTRY,OPTION) 3 - *----------------------------------------------------------------------- 4 - * DLCMCA - Subroutine that computes a drift line using a Monte-Carlo 5 - * technique to take account of diffusion and of avalanche 6 - * formation. 7 - * VARIABLES : 8 - * REFERENCE : 9 - * (Last changed on 22/ 1/01.) 1 670 P=DRIFTCAL D=DLCMCA 2 PAGE1029 10 - *----------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,CELLDATA. 14.- +SEQ,GASDATA. 15.- +SEQ,PARAMETERS. 16.- +SEQ,DRIFTLINE. 17.- +SEQ,PRINTPLOT. 18.- +SEQ,CONSTANTS. 19 - INTEGER MXVEC 20 - PARAMETER(MXVEC=10000) 21 - REAL XLIST(MXMCA),YLIST(MXMCA),ZLIST(MXMCA),TLIST(MXMCA), 22 - - Q,X1,Y1,Z1,GASTWN,GASATT,PROBTH,PALPHA,PETA,TOFF, 23 - - ALPHA(MXLIST),ETA(MXLIST),RVECU(MXVEC),RVECN(MXVEC) 24 - INTEGER IFAIL,NLIST(MXMCA),NMCA,IPART,I,J,K,L,IMCA,NINTER, 25 - - NELEC,NION,NETOT,NITOT,NHIST,IHIST(*),IENTRY(*),ITYPE(2,*), 26 - - IVECU,IVECN,NEW,NMAX 27 - LOGICAL LELEPL,LIONPL,LTOWN,LATTA,STAT(4) 28 - COMMON /MCAMAT/ XLIST,YLIST,ZLIST,TLIST,NLIST 29 - CHARACTER*(*) OPTION 30 - EXTERNAL GASTWN,GASATT 31 - *** Identify the routine if requested. 32 - IF(LIDENT)PRINT *,' /// ROUTINE DLCMCA ///' 33 - *** Initial debugging output. 34 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCMCA DEBUG : MC drift'', 35 - - '' from ('',E15.8,'','',E15.8,'','',E15.8,'')'')') X1,Y1,Z1 36 - *** Make sure that electron drift velocities are available. 37 - IF(.NOT.GASOK(1))THEN 38 - PRINT *,' !!!!!! DLCMCA WARNING : Electron drift velocity'// 39 - - ' data missing; no avalanche.' 40 - RETURN 41 - ENDIF 42 - *** Obtain the matrix to store the avalanche development. 43 - CALL BOOK('BOOK','MCAMAT','MCA',IFAIL) 44 - IF(IFAIL.NE.0)THEN 45 - PRINT *,' !!!!!! DLCMCA WARNING : Unable to obtain'// 46 - - ' storage for the avalanche; avalanche not computed.' 47 - RETURN 48 - ENDIF 49 - *** Default options. 50 - LELEPL=.FALSE. 51 - LIONPL=.FALSE. 52 - LTOWN=GASOK(4) 53 - LATTA=GASOK(6) 54 - NMAX=0 55 - *** Default settings of parameters. 56 - PROBTH=0.01 57 - *** Decode the options. 58 - IF(INDEX(OPTION,'NOPLOT-ELECTRON').NE.0)THEN 59 - LELEPL=.FALSE. 60 - ELSEIF(INDEX(OPTION,'PLOT-ELECTRON').NE.0)THEN 61 - LELEPL=.TRUE. 62 - ENDIF 63 - IF(INDEX(OPTION,'NOPLOT-ION').NE.0)THEN 64 - LIONPL=.FALSE. 65 - ELSEIF(INDEX(OPTION,'PLOT-ION').NE.0)THEN 66 - IF(.NOT.GASOK(2))THEN 67 - PRINT *,' !!!!!! DLCMCA WARNING : Ion mobilities are'// 68 - - ' absent; can not compute ion drift lines.' 69 - ELSE 70 - LIONPL=.TRUE. 71 - ENDIF 72 - ENDIF 73 - IF(INDEX(OPTION,'NOTOWNSEND').NE.0)THEN 74 - LTOWN=.FALSE. 75 - ELSEIF(INDEX(OPTION,'TOWNSEND').NE.0.AND..NOT.GASOK(4))THEN 76 - PRINT *,' !!!!!! DLCMCA WARNING : Townsend data is not'// 77 - - ' present; TOWNSEND option not valid.' 78 - ELSEIF(INDEX(OPTION,'TOWNSEND').NE.0)THEN 79 - LTOWN=.TRUE. 80 - ENDIF 81 - IF(INDEX(OPTION,'NOATTACHMENT').NE.0)THEN 82 - LATTA=.FALSE. 83 - ELSEIF(INDEX(OPTION,'ATTACHMENT').NE.0.AND..NOT.GASOK(6))THEN 84 - PRINT *,' !!!!!! DLCMCA WARNING : Attachment data is not'// 85 - - ' present; ATTACHMENT option not valid.' 86 - ELSEIF(INDEX(OPTION,'ATTACHMENT').NE.0)THEN 87 - LATTA=.TRUE. 88 - ENDIF 89 - IF(INDEX(OPTION,'ABORT-100000').NE.0)THEN 90 - NMAX=100000 91 - ELSEIF(INDEX(OPTION,'ABORT-10000').NE.0)THEN 92 - NMAX=10000 93 - ELSEIF(INDEX(OPTION,'ABORT-1000').NE.0)THEN 94 - NMAX=1000 95 - ELSEIF(INDEX(OPTION,'ABORT-100').NE.0)THEN 96 - NMAX=100 97 - ENDIF 98 - *** Make sure that some kind of output has been requested. 99 - IF(.NOT.(LATTA.OR.LTOWN))THEN 100 - PRINT *,' !!!!!! DLCMCA WARNING : Neither attachment not'// 101 - - ' multiplication to be included; no avalanche.' 102 - CALL BOOK('RELEASE','MCAMAT','MCA',IFAIL) 103 - RETURN 104 - ENDIF 105 - *** Initialise the avalanche table. 106 - NMCA=1 107 - XLIST(1)=X1 108 - YLIST(1)=Y1 109 - ZLIST(1)=Z1 110 - TLIST(1)=0 111 - NLIST(1)=1 112 - NETOT=1 113 - NITOT=0 114 - *** Loop over the table. 115 - IMCA=0 1 670 P=DRIFTCAL D=DLCMCA 3 PAGE1030 116 - 100 CONTINUE 117 - * Check we are still in the table. 118 - IMCA=IMCA+1 119 - IF(IMCA.GT.NMCA)THEN 120 - CALL BOOK('RELEASE','MCAMAT','MCA',IFAIL) 121 - RETURN 122 - ENDIF 123 - *** Loop over the electrons at this location. 124 - DO 40 J=1,NLIST(IMCA) 125 - * Compute an electron drift line. 126 - Q=-1 127 - IPART=1 128 - CALL DLCMC(XLIST(IMCA),YLIST(IMCA),ZLIST(IMCA),Q,IPART) 129 - * Compute alpha and eta vectors. 130 - CALL DLCEQU(ALPHA,ETA,IFAIL) 131 - * Offset the time of the electrons by the starting time. 132 - DO 10 I=1,NU 133 - TU(I)=TU(I)+TLIST(IMCA) 134 - 10 CONTINUE 135 - *** Follow the avalanche development 136 - DO 20 I=1,NU-1 137 - * Set initial number of electrons and ions. 138 - NELEC=1 139 - NION=0 140 - * Compute the number of subdivisions. 141 - NINTER=(ALPHA(I)+ETA(I))/PROBTH 142 - IF(NINTER.LT.1)NINTER=1 143 - *** Loop over the subdivisions. 144 - DO 50 K=1,NINTER 145 - * Probabilities for gain and loss. 146 - PALPHA=ALPHA(I)/REAL(NINTER) 147 - PETA=ETA(I)/REAL(NINTER) 148 - * Gaussian approximation. 149 - IF(NELEC.GT.100)THEN 150 - DATA IVECN/0/ 151 - IF(IVECN.EQ.0.OR.IVECN+2.GT.MXVEC)THEN 152 - CALL RNORML(RVECN,MXVEC) 153 - IVECN=1 154 - ENDIF 155 - IF(LTOWN)THEN 156 - NELEC=NELEC+NINT(REAL(NELEC)*PALPHA+RVECN(IVECN)* 157 - - SQRT(REAL(NELEC)*PALPHA*(1-PALPHA))) 158 - NION=NION+NINT(REAL(NELEC)*PALPHA+RVECN(IVECN)* 159 - - SQRT(REAL(NELEC)*PALPHA*(1-PALPHA))) 160 - IVECN=IVECN+1 161 - ENDIF 162 - IF(LATTA)THEN 163 - NELEC=NELEC-NINT(REAL(NELEC)*PETA+RVECN(IVECN)* 164 - - SQRT(REAL(NELEC)*PETA*(1-PETA))) 165 - IVECN=IVECN+1 166 - ENDIF 167 - * Binomial approximation. 168 - ELSE 169 - NEW=0 170 - DO 80 L=1,NELEC 171 - DATA IVECU/0/ 172 - IF(IVECU.EQ.0.OR.IVECU+2.GT.MXVEC)THEN 173 - CALL RANLUX(RVECU,MXVEC) 174 - IVECU=1 175 - ENDIF 176 - IF(LTOWN)THEN 177 - IF(RVECU(IVECU).LT.PALPHA)THEN 178 - NEW=NEW+1 179 - NION=NION+1 180 - ENDIF 181 - IVECU=IVECU+1 182 - ENDIF 183 - IF(LATTA)THEN 184 - IF(RVECU(IVECU).LT.PETA)NEW=NEW-1 185 - IVECU=IVECU+1 186 - ENDIF 187 - 80 CONTINUE 188 - NELEC=NELEC+NEW 189 - ENDIF 190 - * Verify that there still is an electron. 191 - IF(NELEC.LE.0)THEN 192 - NETOT=NETOT-1 193 - IF(STAT(2))CALL DLCMCF(REAL(XU(I)+XU(I+1))/2, 194 - - REAL(YU(I)+YU(I+1))/2,REAL(ZU(I)+ZU(I+1))/2, 195 - - REAL(TU(I)+TU(I+1))/2,1,NHIST,IHIST, 196 - - ITYPE,IENTRY,2) 197 - GOTO 60 198 - ENDIF 199 - * Next subdivision. 200 - 50 CONTINUE 201 - 60 CONTINUE 202 - *** If at least 1 new electron has been created, add to the table. 203 - IF(NELEC.GT.1)THEN 204 - * Ensure we do not pass the maximum permitted avalanche size. 205 - IF(NMCA+1.GT.NMAX.AND.NMAX.GT.0)THEN 206 - PRINT *,' !!!!!! DLCMCA WARNING : Avalanche exceeds'// 207 - - ' maximum permitted size; avalanche ended.' 208 - CALL BOOK('RELEASE','MCAMAT','MCA',IFAIL) 209 - RETURN 210 - * Ensure there is still space in the table. 211 - ELSEIF(NMCA+1.GT.MXMCA)THEN 212 - PRINT *,' !!!!!! DLCMCA WARNING : Overflow of'// 213 - - ' secondary electron table; avalanche ended.' 214 - CALL BOOK('RELEASE','MCAMAT','MCA',IFAIL) 215 - RETURN 216 - ENDIF 217 - * Add the point to the table, 218 - NMCA=NMCA+1 219 - XLIST(NMCA)=XU(I+1) 220 - YLIST(NMCA)=YU(I+1) 221 - ZLIST(NMCA)=ZU(I+1) 1 670 P=DRIFTCAL D=DLCMCA 4 PAGE1031 222 - TLIST(NMCA)=TU(I+1) 223 - NLIST(NMCA)=NELEC-1 224 - * And also enter in the overall statistics. 225 - NETOT=NETOT+NELEC-1 226 - * And enter the newly created electrons in the histograms. 227 - IF(STAT(1))CALL DLCMCF(REAL(XU(I)+XU(I+1))/2, 228 - - REAL(YU(I)+YU(I+1))/2,REAL(ZU(I)+ZU(I+1))/2, 229 - - REAL(TU(I)+TU(I+1))/2,NELEC-1,NHIST,IHIST, 230 - - ITYPE,IENTRY,1) 231 - ENDIF 232 - *** Also compute the newly produced ions if requested. 233 - IF(NION.GE.1.AND.(LIONPL.OR.STAT(4)))THEN 234 - * Store offset time. 235 - TOFF=TU(I+1) 236 - * Make a backup of the electron drift line. 237 - CALL DLCBCK('SAVE') 238 - DO 30 K=1,NION 239 - * Compute the ion drift lines. 240 - Q=+1 241 - IPART=2 242 - CALL DLCMC(XLIST(NMCA),YLIST(NMCA),ZLIST(NMCA),Q,IPART) 243 - * Offset the time of the ions by the starting time. 244 - DO 90 L=1,NU 245 - TU(L)=TU(L)+TOFF 246 - 90 CONTINUE 247 - * Enter the ion end point in the histograms if requested. 248 - IF(STAT(4))CALL DLCMCF(REAL(XU(NU)),REAL(YU(NU)), 249 - - REAL(ZU(NU)),REAL(TU(NU)),1, 250 - - NHIST,IHIST,ITYPE,IENTRY,4) 251 - * Plot the ion drift line. 252 - IF(LIONPL)CALL DLCPLT 253 - 30 CONTINUE 254 - * Restore electron drift line. 255 - CALL DLCBCK('RESTORE') 256 - ENDIF 257 - *** Keep track of ion statistics. 258 - NITOT=NITOT+NION 259 - *** Make sure the electron is still alive. 260 - IF(NELEC.LE.0)THEN 261 - NU=I 262 - GOTO 70 263 - ENDIF 264 - 20 CONTINUE 265 - * If electron survived, register its end point. 266 - IF(STAT(3))CALL DLCMCF(REAL(XU(NU)), 267 - - REAL(YU(NU)),REAL(ZU(NU)),REAL(TU(NU)),1, 268 - - NHIST,IHIST,ITYPE,IENTRY,3) 269 - * Plot the electron if requested. 270 - 70 CONTINUE 271 - IF(LELEPL)CALL DLCPLT 272 - * Proceed with next electron. 273 - 40 CONTINUE 274 - *** And proceed with the next table entry. 275 - GOTO 100 276 - END 671 GARFIELD ================================================== P=DRIFTCAL D=DLCMCF 1 ============================ 0 + +DECK,DLCMCF. 1 - SUBROUTINE DLCMCF(XPOS,YPOS,ZPOS,TPOS,N,NHIST,IHIST,ITYPE,IENTRY, 2 - - ISTAT) 3 - *----------------------------------------------------------------------- 4 - * DLCMCF - Takes care of histogramming for DLCMCA. 5 - * VARIABLES : 6 - * (Last changed on 27/ 9/97.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,PRINTPLOT. 12 - REAL XPOS,YPOS,ZPOS,TPOS,XXPOS,YYPOS,VAR(16),RES(2) 13 - INTEGER N,NHIST,IHIST(*),ITYPE(2,*),IENTRY(*),ISTAT,MODVAR(16), 14 - - MODRES(2),IFAIL,I,NREXP,IENTR 15 - *** For polar cells, convert to polar coordinates. 16 - IF(POLAR)THEN 17 - CALL CFMRTP(XPOS,YPOS,XXPOS,YYPOS,1) 18 - ELSE 19 - XXPOS=XPOS 20 - YYPOS=YPOS 21 - ENDIF 22 - *** Enter the values in the appropriate locations. 23 - DO 10 I=1,16 24 - VAR(I)=0 25 - MODVAR(I)=2 26 - 10 CONTINUE 27 - * Variables for pair creation. 28 - IF(ISTAT.EQ.1)THEN 29 - VAR(1)=XXPOS 30 - VAR(2)=YYPOS 31 - VAR(3)=ZPOS 32 - VAR(4)=TPOS 33 - * Electron attachment. 34 - ELSEIF(ISTAT.EQ.2)THEN 35 - VAR(5)=XXPOS 36 - VAR(6)=YYPOS 37 - VAR(7)=ZPOS 38 - VAR(8)=TPOS 39 - * Electron end of drift line. 40 - ELSEIF(ISTAT.EQ.3)THEN 41 - VAR(9)=XXPOS 42 - VAR(10)=YYPOS 43 - VAR(11)=ZPOS 44 - VAR(12)=TPOS 45 - * Ion end of drift line. 46 - ELSEIF(ISTAT.EQ.4)THEN 47 - VAR(13)=XXPOS 1 671 P=DRIFTCAL D=DLCMCF 2 PAGE1032 48 - VAR(14)=YYPOS 49 - VAR(15)=ZPOS 50 - VAR(16)=TPOS 51 - * Other (unknown) types. 52 - ELSE 53 - PRINT *,' ###### DLCMCF ERROR : Invalid statistics'// 54 - - ' code received; no histogram entry.' 55 - RETURN 56 - ENDIF 57 - *** Loop over the histograms. 58 - DO 20 I=1,NHIST 59 - IF(ISTAT.NE.ITYPE(1,I))GOTO 20 60 - * Preset results. 61 - RES(1)=0 62 - RES(2)=0 63 - * Evaluate formulae. 64 - NREXP=ITYPE(2,I) 65 - IENTR=IENTRY(I) 66 - CALL AL2EXE(IENTR,VAR,MODVAR,16,RES,MODRES,NREXP,IFAIL) 67 - * Check that there was no error. 68 - IF(IFAIL.NE.0)THEN 69 - PRINT *,' !!!!!! DLCMCF WARNING : Arithmetic error while'// 70 - - ' evaluating a histogram function.' 71 - * Make sure that the mode is correct. 72 - ELSEIF(MODRES(1).NE.2)THEN 73 - PRINT *,' !!!!!! DLCMCF WARNING : Formula resulted in'// 74 - - ' non-number type entry; no histogram entry.' 75 - * In case of conditional filling, check mode of condition. 76 - ELSEIF(ITYPE(2,I).EQ.2.AND.MODRES(2).NE.3)THEN 77 - PRINT *,' !!!!!! DLCMCF WARNING : Formula resulted in'// 78 - - ' non-logical type condition no histogram entry.' 79 - * Fill. 80 - ELSEIF(ITYPE(2,I).EQ.1.OR.NINT(RES(2)).EQ.1)THEN 81 - CALL HISENT(IHIST(I),RES(1),REAL(N)) 82 - ENDIF 83 - 20 CONTINUE 84 - END 672 GARFIELD ================================================== P=DRIFTCAL D=DLCMCT 1 ============================ 0 + +DECK,DLCMCT. 1 - SUBROUTINE DLCMCT(NE,NI) 2 - *----------------------------------------------------------------------- 3 - * DLCMCT - Generates a random avalanche development. 4 - * VARIABLES : 5 - * (Last changed on 4/ 2/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,GASDATA. 11.- +SEQ,PARAMETERS. 12.- +SEQ,DRIFTLINE. 13.- +SEQ,PRINTPLOT. 14.- +SEQ,CONSTANTS. 15 - INTEGER NE,NI,NEW,ILOC,NINTER,I,J,K,MXVEC,IVECU,IVECN 16 - PARAMETER(MXVEC=10000) 17 - REAL GASTWN,GASATT,XPOS1,YPOS1,XPOS2,YPOS2,EX,EY,EZ,ETOT, 18 - - VOLT,ALPHA(MXLIST),ETA(MXLIST),STEP,SCALE,SUB1,SUB2, 19 - - PROBTH,RVECU(MXVEC),RVECN(MXVEC),PALPHA,PETA,BX,BY,BZ,BTOT 20 - DOUBLE PRECISION VD(3),VTERM(3),WG6(6),TG6(6) 21 - LOGICAL TRY1,TRY2,DONE 22 - PARAMETER(PROBTH=0.01) 23 - LOGICAL LTOWN,LATTA 24 - EXTERNAL GASTWN,GASATT 0 25-+ +SELF,IF=SAVE. 26 - SAVE IVECU,IVECN,RVECU,RVECN 0 27-+ +SELF. 28 - *** Locations and weights for 6-point Gaussian integration. 29 - DATA (TG6(I),WG6(I),I=1,6) / 30 - - -0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0, 31 - - -0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0, 32 - - -0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0, 33 - - 0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0, 34 - - 0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0, 35 - - 0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0/ 36 - *** Identify the routine if requested. 37 - IF(LIDENT)PRINT *,' /// ROUTINE DLCMCT ///' 38 - *** Initial number of electrons. 39 - NE=1 40 - NI=0 41 - *** Make sure that electron drift velocities are available. 42 - IF(.NOT.(GASOK(1).AND.GASOK(4)))THEN 43 - PRINT *,' !!!!!! DLCMCT WARNING : Electron drift velocity'// 44 - - ' data / avalanche data missing; no avalanche.' 45 - RETURN 46 - ENDIF 47 - * Establish the flags. 48 - LTOWN=.FALSE. 49 - LATTA=.FALSE. 50 - IF(GASOK(4))LTOWN=.TRUE. 51 - IF(GASOK(6))LATTA=.TRUE. 52 - *** Check that a drift line exists. 53 - IF(IPTYPE.NE.1.OR.NU.LT.2)THEN 54 - PRINT *,' !!!!!! DLCMCT WARNING : Current drift line is'// 55 - - ' not for an electron or too short; no avalanche.' 56 - RETURN 57 - ENDIF 58 - *** Loop a first time over the drift line to check for returns. 59 - DO 100 I=1,NU-1 60 - * Scaling factor for projected length. 61 - IF(LAVPRO)THEN 62 - VD(1)=0 63 - VD(2)=0 1 672 P=DRIFTCAL D=DLCMCT 2 PAGE1033 64 - VD(3)=0 65 - DO 330 J=1,6 66 - CALL DLCVEL( 67 - - XU(I)+(1+TG6(J))/2*(XU(I+1)-XU(I)), 68 - - YU(I)+(1+TG6(J))/2*(YU(I+1)-YU(I)), 69 - - ZU(I)+(1+TG6(J))/2*(ZU(I+1)-ZU(I)), 70 - - VTERM,QPCHAR,IPTYPE,ILOC) 71 - VD(1)=VD(1)+WG6(J)*VTERM(1) 72 - VD(2)=VD(2)+WG6(J)*VTERM(2) 73 - VD(3)=VD(3)+WG6(J)*VTERM(3) 74 - 330 CONTINUE 75 - IF(((XU(I+1)-XU(I))**2+ 76 - - (YU(I+1)-YU(I))**2+ 77 - - (ZU(I+1)-ZU(I))**2)* 78 - - (VD(1)**2+VD(2)**2+VD(3)**2).LE.0)THEN 79 - SCALE=0 80 - ELSE 81 - SCALE=((XU(I+1)-XU(I))*VD(1)+ 82 - - (YU(I+1)-YU(I))*VD(2)+ 83 - - (ZU(I+1)-ZU(I))*VD(3))/ 84 - - SQRT(((XU(I+1)-XU(I))**2+ 85 - - (YU(I+1)-YU(I))**2+ 86 - - (ZU(I+1)-ZU(I))**2)* 87 - - (VD(1)**2+VD(2)**2+VD(3)**2)) 88 - ENDIF 89 - ELSE 90 - SCALE=1 91 - ENDIF 92 - * Length of the step. 93 - XPOS1=REAL(XU(I)) 94 - YPOS1=REAL(YU(I)) 95 - IF(POLAR)CALL CFMRTC(XPOS1,YPOS1,XPOS1,YPOS1,1) 96 - XPOS2=REAL(XU(I+1)) 97 - YPOS2=REAL(YU(I+1)) 98 - IF(POLAR)CALL CFMRTC(XPOS2,YPOS2,XPOS2,YPOS2,1) 99 - STEP=SQRT((XPOS1-XPOS2)**2+(YPOS1-YPOS2)**2+(ZU(I+1)-ZU(I))**2) 100 - * Compute the mean Townsend and attachment coefficients. 101 - ALPHA(I)=0 102 - ETA(I)=0 103 - DO 320 J=1,6 104 - CALL EFIELD( 105 - - REAL(XU(I)+(1+TG6(J))/2*(XU(I+1)-XU(I))), 106 - - REAL(YU(I)+(1+TG6(J))/2*(YU(I+1)-YU(I))), 107 - - REAL(ZU(I)+(1+TG6(J))/2*(ZU(I+1)-ZU(I))), 108 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 109 - CALL BFIELD( 110 - - REAL(XU(I)+(1+TG6(J))/2*(XU(I+1)-XU(I))), 111 - - REAL(YU(I)+(1+TG6(J))/2*(YU(I+1)-YU(I))), 112 - - REAL(ZU(I)+(1+TG6(J))/2*(ZU(I+1)-ZU(I))), 113 - - BX,BY,BZ,BTOT) 114 - IF(LTOWN)ALPHA(I)=ALPHA(I)+WG6(J)*GASTWN(EX,EY,EZ,BX,BY,BZ) 115 - IF(LATTA)ETA(I)=ETA(I)+WG6(J)*GASATT(EX,EY,EZ,BX,BY,BZ) 116 - 320 CONTINUE 117 - ALPHA(I)=ALPHA(I)*STEP*SCALE/2 118 - ETA(I)=ETA(I)*STEP*SCALE/2 119 - * Next point on the drift line. 120 - 100 CONTINUE 121 - *** Skip equilibration if there projection hasn't been requested. 122 - IF(.NOT.LAVPRO)GOTO 300 123 - *** Try to alpha-equilibrate the returning parts. 124 - DO 110 I=1,NU-1 125 - IF(ALPHA(I).LT.0)THEN 126 - * Targets for subtracting. 127 - SUB1=-ALPHA(I)/2 128 - SUB2=-ALPHA(I)/2 129 - TRY1=.TRUE. 130 - TRY2=.TRUE. 131 - * Try to subtract half in earlier points. 132 - DO 120 J=1,I-1 133 - IF(ALPHA(I-J).GT.SUB1)THEN 134 - ALPHA(I-J)=ALPHA(I-J)-SUB1 135 - ALPHA(I)=ALPHA(I)+SUB1 136 - SUB1=0 137 - GOTO 130 138 - ELSEIF(ALPHA(I-J).GT.0)THEN 139 - ALPHA(I)=ALPHA(I)+ALPHA(I-J) 140 - SUB1=SUB1-ALPHA(I-J) 141 - ALPHA(I-J)=0 142 - ENDIF 143 - 120 CONTINUE 144 - TRY1=.FALSE. 145 - 130 CONTINUE 146 - * Try to subtract the other half in later points. 147 - DO 140 J=1,NU-I-1 148 - IF(ALPHA(I+J).GT.SUB2)THEN 149 - ALPHA(I+J)=ALPHA(I+J)-SUB2 150 - ALPHA(I)=ALPHA(I)+SUB2 151 - SUB2=0 152 - GOTO 150 153 - ELSEIF(ALPHA(I+J).GT.0)THEN 154 - ALPHA(I)=ALPHA(I)+ALPHA(I+J) 155 - SUB2=SUB2-ALPHA(I+J) 156 - ALPHA(I+J)=0 157 - ENDIF 158 - 140 CONTINUE 159 - TRY2=.FALSE. 160 - 150 CONTINUE 161 - * Done if both sides have margin left. 162 - DONE=.FALSE. 163 - IF(TRY1.AND.TRY2)THEN 164 - DONE=.TRUE. 165 - * Try lower side again. 166 - ELSEIF(TRY1)THEN 167 - SUB1=-ALPHA(I) 168 - DO 160 J=1,I-1 169 - IF(ALPHA(I-J).GT.SUB1)THEN 1 672 P=DRIFTCAL D=DLCMCT 3 PAGE1034 170 - ALPHA(I-J)=ALPHA(I-J)-SUB1 171 - ALPHA(I)=ALPHA(I)+SUB1 172 - SUB1=0 173 - DONE=.TRUE. 174 - GOTO 170 175 - ELSEIF(ALPHA(I-J).GT.0)THEN 176 - ALPHA(I)=ALPHA(I)+ALPHA(I-J) 177 - SUB1=SUB1-ALPHA(I-J) 178 - ALPHA(I-J)=0 179 - ENDIF 180 - 160 CONTINUE 181 - 170 CONTINUE 182 - * Try upper side again. 183 - ELSEIF(TRY2)THEN 184 - SUB2=-ALPHA(I) 185 - DO 180 J=1,NU-I-1 186 - IF(ALPHA(I+J).GT.SUB2)THEN 187 - ALPHA(I+J)=ALPHA(I+J)-SUB2 188 - ALPHA(I)=ALPHA(I)+SUB2 189 - SUB2=0 190 - DONE=.TRUE. 191 - GOTO 190 192 - ELSEIF(ALPHA(I+J).GT.0)THEN 193 - ALPHA(I)=ALPHA(I)+ALPHA(I+J) 194 - SUB2=SUB2-ALPHA(I+J) 195 - ALPHA(I+J)=0 196 - ENDIF 197 - 180 CONTINUE 198 - 190 CONTINUE 199 - ENDIF 200 - * See whether we succeeded. 201 - IF(.NOT.DONE)THEN 202 - PRINT *,' !!!!!! DLCMCT WARNING : Unable to even out'// 203 - - ' backwards alpha steps; inaccurate avalanche.' 204 - GOTO 200 205 - ENDIF 206 - ENDIF 207 - 110 CONTINUE 208 - 200 CONTINUE 209 - *** Try to eta-equilibrate the returning parts. 210 - DO 210 I=1,NU-1 211 - IF(ETA(I).LT.0)THEN 212 - * Targets for subtracting. 213 - SUB1=-ETA(I)/2 214 - SUB2=-ETA(I)/2 215 - TRY1=.TRUE. 216 - TRY2=.TRUE. 217 - * Try to subtract half in earlier points. 218 - DO 220 J=1,I-1 219 - IF(ETA(I-J).GT.SUB1)THEN 220 - ETA(I-J)=ETA(I-J)-SUB1 221 - ETA(I)=ETA(I)+SUB1 222 - SUB1=0 223 - GOTO 230 224 - ELSEIF(ETA(I-J).GT.0)THEN 225 - ETA(I)=ETA(I)+ETA(I-J) 226 - SUB1=SUB1-ETA(I-J) 227 - ETA(I-J)=0 228 - ENDIF 229 - 220 CONTINUE 230 - TRY1=.FALSE. 231 - 230 CONTINUE 232 - * Try to subtract the other half in later points. 233 - DO 240 J=1,NU-I-1 234 - IF(ETA(I+J).GT.SUB2)THEN 235 - ETA(I+J)=ETA(I+J)-SUB2 236 - ETA(I)=ETA(I)+SUB2 237 - SUB2=0 238 - GOTO 250 239 - ELSEIF(ETA(I+J).GT.0)THEN 240 - ETA(I)=ETA(I)+ETA(I+J) 241 - SUB2=SUB2-ETA(I+J) 242 - ETA(I+J)=0 243 - ENDIF 244 - 240 CONTINUE 245 - TRY2=.FALSE. 246 - 250 CONTINUE 247 - * Done if both sides have margin left. 248 - DONE=.FALSE. 249 - IF(TRY1.AND.TRY2)THEN 250 - DONE=.TRUE. 251 - * Try lower side again. 252 - ELSEIF(TRY1)THEN 253 - SUB1=-ETA(I) 254 - DO 260 J=1,I-1 255 - IF(ETA(I-J).GT.SUB1)THEN 256 - ETA(I-J)=ETA(I-J)-SUB1 257 - ETA(I)=ETA(I)+SUB1 258 - SUB1=0 259 - DONE=.TRUE. 260 - GOTO 270 261 - ELSEIF(ETA(I-J).GT.0)THEN 262 - ETA(I)=ETA(I)+ETA(I-J) 263 - SUB1=SUB1-ETA(I-J) 264 - ETA(I-J)=0 265 - ENDIF 266 - 260 CONTINUE 267 - 270 CONTINUE 268 - * Try upper side again. 269 - ELSEIF(TRY2)THEN 270 - SUB2=-ETA(I) 271 - DO 280 J=1,NU-I-1 272 - IF(ETA(I+J).GT.SUB2)THEN 273 - ETA(I+J)=ETA(I+J)-SUB2 274 - ETA(I)=ETA(I)+SUB2 275 - SUB2=0 1 672 P=DRIFTCAL D=DLCMCT 4 PAGE1035 276 - DONE=.TRUE. 277 - GOTO 290 278 - ELSEIF(ETA(I+J).GT.0)THEN 279 - ETA(I)=ETA(I)+ETA(I+J) 280 - SUB2=SUB2-ETA(I+J) 281 - ETA(I+J)=0 282 - ENDIF 283 - 280 CONTINUE 284 - 290 CONTINUE 285 - ENDIF 286 - * See whether we succeeded. 287 - IF(.NOT.DONE)THEN 288 - PRINT *,' !!!!!! DLCMCT WARNING : Unable to even out'// 289 - - ' backwards eta steps; inaccurate avalanche.' 290 - GOTO 300 291 - ENDIF 292 - ENDIF 293 - 210 CONTINUE 294 - 300 CONTINUE 295 - *** Loop over the drift line. 296 - DO 10 I=1,NU-1 297 - * Compute the number of subdivisions. 298 - NINTER=(ALPHA(I)+ETA(I))/PROBTH 299 - IF(NINTER.LT.1)NINTER=1 300 - ** Loop over the subdivisions. 301 - DO 20 J=1,NINTER 302 - * Probabilities for gain and loss. 303 - PALPHA=ALPHA(I)/REAL(NINTER) 304 - PETA=ETA(I)/REAL(NINTER) 305 - * Gaussian approximation. 306 - IF(NE.GT.100)THEN 307 - DATA IVECN/0/ 308 - IF(IVECN.EQ.0.OR.IVECN+2.GT.MXVEC)THEN 309 - CALL RNORML(RVECN,MXVEC) 310 - IVECN=1 311 - ENDIF 312 - IF(LTOWN)THEN 313 - NE=NE+NINT(REAL(NE)*PALPHA+RVECN(IVECN)* 314 - - SQRT(REAL(NE)*PALPHA*(1-PALPHA))) 315 - NI=NI+NINT(REAL(NE)*PALPHA+RVECN(IVECN)* 316 - - SQRT(REAL(NE)*PALPHA*(1-PALPHA))) 317 - IVECN=IVECN+1 318 - ENDIF 319 - IF(LATTA)THEN 320 - NE=NE-NINT(REAL(NE)*PETA+RVECN(IVECN)* 321 - - SQRT(REAL(NE)*PETA*(1-PETA))) 322 - IVECN=IVECN+1 323 - ENDIF 324 - * Binomial approximation. 325 - ELSE 326 - NEW=0 327 - DO 30 K=1,NE 328 - DATA IVECU/0/ 329 - IF(IVECU.EQ.0.OR.IVECU+2.GT.MXVEC)THEN 330 - CALL RANLUX(RVECU,MXVEC) 331 - IVECU=1 332 - ENDIF 333 - IF(LTOWN)THEN 334 - IF(RVECU(IVECU).LT.PALPHA)THEN 335 - NEW=NEW+1 336 - NI=NI+1 337 - ENDIF 338 - IVECU=IVECU+1 339 - ENDIF 340 - IF(LATTA)THEN 341 - IF(RVECU(IVECU).LT.PETA)NEW=NEW-1 342 - IVECU=IVECU+1 343 - ENDIF 344 - 30 CONTINUE 345 - NE=NE+NEW 346 - ENDIF 347 - * Verify that there still is an electron. 348 - IF(NE.LE.0)THEN 349 - NE=0 350 - RETURN 351 - ENDIF 352 - * Next subdivision. 353 - 20 CONTINUE 354 - ** Next step of the drift line. 355 - 10 CONTINUE 356 - END 673 GARFIELD ================================================== P=DRIFTCAL D=DLCEQU 1 ============================ 0 + +DECK,DLCEQU. 1 - SUBROUTINE DLCEQU(ALPHA,ETA,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * DLCEQU - Computes equilibrated alpha's and eta's over the current 4 - * drift line. 5 - * VARIABLES : 6 - * (Last changed on 13/ 5/00.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,GASDATA. 12.- +SEQ,PARAMETERS. 13.- +SEQ,DRIFTLINE. 14.- +SEQ,PRINTPLOT. 15.- +SEQ,CONSTANTS. 16 - INTEGER ILOC,I,J,IFAIL,IRES 17 - REAL GASTWN,GASATT,XPOS1,YPOS1,XPOS2,YPOS2,EX,EY,EZ,ETOT, 18 - - VOLT,ALPHA(MXLIST),ETA(MXLIST),STEP,SCALE,SUB1,SUB2, 19 - - BX,BY,BZ,BTOT,DRES 20 - DOUBLE PRECISION VD(3),VTERM(3),WG6(6),TG6(6) 21 - LOGICAL TRY1,TRY2,DONE 1 673 P=DRIFTCAL D=DLCEQU 2 PAGE1036 22 - LOGICAL LTOWN,LATTA 23 - EXTERNAL GASTWN,GASATT 24 - *** Locations and weights for 6-point Gaussian integration. 25 - DATA (TG6(I),WG6(I),I=1,6) / 26 - - -0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0, 27 - - -0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0, 28 - - -0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0, 29 - - 0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0, 30 - - 0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0, 31 - - 0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0/ 32 - *** Identify the routine if requested. 33 - IF(LIDENT)PRINT *,' /// ROUTINE DLCEQU ///' 34 - *** Assume this will fail. 35 - IFAIL=1 36 - *** Make sure that electron drift velocities are available. 37 - IF(.NOT.(GASOK(1).AND.GASOK(4)))THEN 38 - PRINT *,' !!!!!! DLCEQU WARNING : Electron drift velocity'// 39 - - ' or avalanche data missing; avalanche not treated.' 40 - RETURN 41 - ENDIF 42 - * Establish the flags. 43 - LTOWN=.FALSE. 44 - LATTA=.FALSE. 45 - IF(GASOK(4))LTOWN=.TRUE. 46 - IF(GASOK(6))LATTA=.TRUE. 47 - *** Check that a drift line exists. 48 - IF(IPTYPE.NE.1)THEN 49 - PRINT *,' !!!!!! DLCEQU WARNING : Current drift line is'// 50 - - ' not for an electron; avalanche not processed.' 51 - RETURN 52 - ELSEIF(NU.LT.2)THEN 53 - RETURN 54 - ENDIF 55 - *** See whether the drift line ends in a wire. 56 - IF(ISTAT.GT.0)THEN 57 - IRES=MOD(ISTAT,MXWIRE) 58 - DRES=D(IRES) 59 - D(IRES)=DRES/2 60 - ELSE 61 - IRES=0 62 - ENDIF 63 - *** Loop a first time over the drift line to check for returns. 64 - DO 100 I=1,NU-1 65 - * Scaling factor for projected length. 66 - IF(LAVPRO)THEN 67 - VD(1)=0 68 - VD(2)=0 69 - VD(3)=0 70 - DO 330 J=1,6 71 - CALL DLCVEL( 72 - - XU(I)+(1+TG6(J))/2*(XU(I+1)-XU(I)), 73 - - YU(I)+(1+TG6(J))/2*(YU(I+1)-YU(I)), 74 - - ZU(I)+(1+TG6(J))/2*(ZU(I+1)-ZU(I)), 75 - - VTERM,QPCHAR,IPTYPE,ILOC) 76 - VD(1)=VD(1)+WG6(J)*VTERM(1) 77 - VD(2)=VD(2)+WG6(J)*VTERM(2) 78 - VD(3)=VD(3)+WG6(J)*VTERM(3) 79 - 330 CONTINUE 80 - IF(((XU(I+1)-XU(I))**2+ 81 - - (YU(I+1)-YU(I))**2+ 82 - - (ZU(I+1)-ZU(I))**2)* 83 - - (VD(1)**2+VD(2)**2+VD(3)**2).LE.0)THEN 84 - SCALE=0 85 - ELSE 86 - SCALE=((XU(I+1)-XU(I))*VD(1)+ 87 - - (YU(I+1)-YU(I))*VD(2)+ 88 - - (ZU(I+1)-ZU(I))*VD(3))/ 89 - - SQRT(((XU(I+1)-XU(I))**2+ 90 - - (YU(I+1)-YU(I))**2+ 91 - - (ZU(I+1)-ZU(I))**2)* 92 - - (VD(1)**2+VD(2)**2+VD(3)**2)) 93 - ENDIF 94 - ELSE 95 - SCALE=1 96 - ENDIF 97 - * Length of the step. 98 - XPOS1=REAL(XU(I)) 99 - YPOS1=REAL(YU(I)) 100 - IF(POLAR)CALL CFMRTC(XPOS1,YPOS1,XPOS1,YPOS1,1) 101 - XPOS2=REAL(XU(I+1)) 102 - YPOS2=REAL(YU(I+1)) 103 - IF(POLAR)CALL CFMRTC(XPOS2,YPOS2,XPOS2,YPOS2,1) 104 - STEP=SQRT((XPOS1-XPOS2)**2+(YPOS1-YPOS2)**2+(ZU(I+1)-ZU(I))**2) 105 - * Compute the mean Townsend and attachment coefficients. 106 - ALPHA(I)=0 107 - ETA(I)=0 108 - DO 320 J=1,6 109 - CALL EFIELD( 110 - - REAL(XU(I)+(1+TG6(J))/2*(XU(I+1)-XU(I))), 111 - - REAL(YU(I)+(1+TG6(J))/2*(YU(I+1)-YU(I))), 112 - - REAL(ZU(I)+(1+TG6(J))/2*(ZU(I+1)-ZU(I))), 113 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 114 - CALL BFIELD( 115 - - REAL(XU(I)+(1+TG6(J))/2*(XU(I+1)-XU(I))), 116 - - REAL(YU(I)+(1+TG6(J))/2*(YU(I+1)-YU(I))), 117 - - REAL(ZU(I)+(1+TG6(J))/2*(ZU(I+1)-ZU(I))), 118 - - BX,BY,BZ,BTOT) 119 - IF(LTOWN)ALPHA(I)=ALPHA(I)+WG6(J)*GASTWN(EX,EY,EZ,BX,BY,BZ) 120 - IF(LATTA)ETA(I)=ETA(I)+WG6(J)*GASATT(EX,EY,EZ,BX,BY,BZ) 121 - 320 CONTINUE 122 - ALPHA(I)=ALPHA(I)*STEP*SCALE/2 123 - ETA(I)=ETA(I)*STEP*SCALE/2 124 - * Next point on the drift line. 125 - 100 CONTINUE 126 - *** Skip equilibration if there projection hasn't been requested. 127 - IF(.NOT.LAVPRO)THEN 1 673 P=DRIFTCAL D=DLCEQU 3 PAGE1037 128 - IFAIL=0 129 - IF(IRES.GT.0)D(IRES)=DRES 130 - RETURN 131 - ENDIF 132 - *** Try to alpha-equilibrate the returning parts. 133 - DO 110 I=1,NU-1 134 - IF(ALPHA(I).LT.0)THEN 135 - * Targets for subtracting. 136 - SUB1=-ALPHA(I)/2 137 - SUB2=-ALPHA(I)/2 138 - TRY1=.TRUE. 139 - TRY2=.TRUE. 140 - * Try to subtract half in earlier points. 141 - DO 120 J=1,I-1 142 - IF(ALPHA(I-J).GT.SUB1)THEN 143 - ALPHA(I-J)=ALPHA(I-J)-SUB1 144 - ALPHA(I)=ALPHA(I)+SUB1 145 - SUB1=0 146 - GOTO 130 147 - ELSEIF(ALPHA(I-J).GT.0)THEN 148 - ALPHA(I)=ALPHA(I)+ALPHA(I-J) 149 - SUB1=SUB1-ALPHA(I-J) 150 - ALPHA(I-J)=0 151 - ENDIF 152 - 120 CONTINUE 153 - TRY1=.FALSE. 154 - 130 CONTINUE 155 - * Try to subtract the other half in later points. 156 - DO 140 J=1,NU-I-1 157 - IF(ALPHA(I+J).GT.SUB2)THEN 158 - ALPHA(I+J)=ALPHA(I+J)-SUB2 159 - ALPHA(I)=ALPHA(I)+SUB2 160 - SUB2=0 161 - GOTO 150 162 - ELSEIF(ALPHA(I+J).GT.0)THEN 163 - ALPHA(I)=ALPHA(I)+ALPHA(I+J) 164 - SUB2=SUB2-ALPHA(I+J) 165 - ALPHA(I+J)=0 166 - ENDIF 167 - 140 CONTINUE 168 - TRY2=.FALSE. 169 - 150 CONTINUE 170 - * Done if both sides have margin left. 171 - DONE=.FALSE. 172 - IF(TRY1.AND.TRY2)THEN 173 - DONE=.TRUE. 174 - * Try lower side again. 175 - ELSEIF(TRY1)THEN 176 - SUB1=-ALPHA(I) 177 - DO 160 J=1,I-1 178 - IF(ALPHA(I-J).GT.SUB1)THEN 179 - ALPHA(I-J)=ALPHA(I-J)-SUB1 180 - ALPHA(I)=ALPHA(I)+SUB1 181 - SUB1=0 182 - DONE=.TRUE. 183 - GOTO 170 184 - ELSEIF(ALPHA(I-J).GT.0)THEN 185 - ALPHA(I)=ALPHA(I)+ALPHA(I-J) 186 - SUB1=SUB1-ALPHA(I-J) 187 - ALPHA(I-J)=0 188 - ENDIF 189 - 160 CONTINUE 190 - 170 CONTINUE 191 - * Try upper side again. 192 - ELSEIF(TRY2)THEN 193 - SUB2=-ALPHA(I) 194 - DO 180 J=1,NU-I-1 195 - IF(ALPHA(I+J).GT.SUB2)THEN 196 - ALPHA(I+J)=ALPHA(I+J)-SUB2 197 - ALPHA(I)=ALPHA(I)+SUB2 198 - SUB2=0 199 - DONE=.TRUE. 200 - GOTO 190 201 - ELSEIF(ALPHA(I+J).GT.0)THEN 202 - ALPHA(I)=ALPHA(I)+ALPHA(I+J) 203 - SUB2=SUB2-ALPHA(I+J) 204 - ALPHA(I+J)=0 205 - ENDIF 206 - 180 CONTINUE 207 - 190 CONTINUE 208 - ENDIF 209 - * See whether we succeeded. 210 - IF(.NOT.DONE)THEN 211 - PRINT *,' !!!!!! DLCEQU WARNING : Unable to even out'// 212 - - ' backwards alpha steps; inaccurate avalanche.' 213 - IF(IRES.GT.0)D(IRES)=DRES 214 - RETURN 215 - ENDIF 216 - ENDIF 217 - 110 CONTINUE 218 - *** Try to eta-equilibrate the returning parts. 219 - DO 210 I=1,NU-1 220 - IF(ETA(I).LT.0)THEN 221 - * Targets for subtracting. 222 - SUB1=-ETA(I)/2 223 - SUB2=-ETA(I)/2 224 - TRY1=.TRUE. 225 - TRY2=.TRUE. 226 - * Try to subtract half in earlier points. 227 - DO 220 J=1,I-1 228 - IF(ETA(I-J).GT.SUB1)THEN 229 - ETA(I-J)=ETA(I-J)-SUB1 230 - ETA(I)=ETA(I)+SUB1 231 - SUB1=0 232 - GOTO 230 233 - ELSEIF(ETA(I-J).GT.0)THEN 1 673 P=DRIFTCAL D=DLCEQU 4 PAGE1038 234 - ETA(I)=ETA(I)+ETA(I-J) 235 - SUB1=SUB1-ETA(I-J) 236 - ETA(I-J)=0 237 - ENDIF 238 - 220 CONTINUE 239 - TRY1=.FALSE. 240 - 230 CONTINUE 241 - * Try to subtract the other half in later points. 242 - DO 240 J=1,NU-I-1 243 - IF(ETA(I+J).GT.SUB2)THEN 244 - ETA(I+J)=ETA(I+J)-SUB2 245 - ETA(I)=ETA(I)+SUB2 246 - SUB2=0 247 - GOTO 250 248 - ELSEIF(ETA(I+J).GT.0)THEN 249 - ETA(I)=ETA(I)+ETA(I+J) 250 - SUB2=SUB2-ETA(I+J) 251 - ETA(I+J)=0 252 - ENDIF 253 - 240 CONTINUE 254 - TRY2=.FALSE. 255 - 250 CONTINUE 256 - * Done if both sides have margin left. 257 - DONE=.FALSE. 258 - IF(TRY1.AND.TRY2)THEN 259 - DONE=.TRUE. 260 - * Try lower side again. 261 - ELSEIF(TRY1)THEN 262 - SUB1=-ETA(I) 263 - DO 260 J=1,I-1 264 - IF(ETA(I-J).GT.SUB1)THEN 265 - ETA(I-J)=ETA(I-J)-SUB1 266 - ETA(I)=ETA(I)+SUB1 267 - SUB1=0 268 - DONE=.TRUE. 269 - GOTO 270 270 - ELSEIF(ETA(I-J).GT.0)THEN 271 - ETA(I)=ETA(I)+ETA(I-J) 272 - SUB1=SUB1-ETA(I-J) 273 - ETA(I-J)=0 274 - ENDIF 275 - 260 CONTINUE 276 - 270 CONTINUE 277 - * Try upper side again. 278 - ELSEIF(TRY2)THEN 279 - SUB2=-ETA(I) 280 - DO 280 J=1,NU-I-1 281 - IF(ETA(I+J).GT.SUB2)THEN 282 - ETA(I+J)=ETA(I+J)-SUB2 283 - ETA(I)=ETA(I)+SUB2 284 - SUB2=0 285 - DONE=.TRUE. 286 - GOTO 290 287 - ELSEIF(ETA(I+J).GT.0)THEN 288 - ETA(I)=ETA(I)+ETA(I+J) 289 - SUB2=SUB2-ETA(I+J) 290 - ETA(I+J)=0 291 - ENDIF 292 - 280 CONTINUE 293 - 290 CONTINUE 294 - ENDIF 295 - * See whether we succeeded. 296 - IF(.NOT.DONE)THEN 297 - PRINT *,' !!!!!! DLCEQU WARNING : Unable to even out'// 298 - - ' backwards eta steps; inaccurate avalanche.' 299 - IF(IRES.GT.0)D(IRES)=DRES 300 - RETURN 301 - ENDIF 302 - ENDIF 303 - 210 CONTINUE 304 - *** Seems to have worked. 305 - IFAIL=0 306 - IF(IRES.GT.0)D(IRES)=DRES 307 - END 674 GARFIELD ================================================== P=DRIFTCAL D=DLCVAC 1 ============================ 0 + +DECK,DLCVAC. 1 - SUBROUTINE DLCVAC(X1,Y1,Z1,VX1,VY1,VZ1,Q,PMASS) 2 - *----------------------------------------------------------------------- 3 - * DLCVAC - Subroutine doing the actual drift line calculations in 4 - * vacuo. It communicates with the outside through sequence 5 - * DRIFTLINE. The calculations are based on a Runge Kutta 6 - * Nystroem method with step size control based on the 7 - * comparison of a 5th and a 2nd order estimate. 8 - * VARIABLES : H : Current stepsize (it is in fact a delta t). 9 - * HPREV : Stores the previous value of H (comparison) 10 - * INITCH : Used for checking initial stepsize (1 = ok) 11 - * (Last changed on 7/11/00.) 12 - *----------------------------------------------------------------------- 13 - implicit none 14.- +SEQ,DIMENSIONS. 15.- +SEQ,CELLDATA. 16.- +SEQ,PARAMETERS. 17.- +SEQ,DRIFTLINE. 18.- +SEQ,PRINTPLOT. 19.- +SEQ,CONSTANTS. 20 - DOUBLE PRECISION TIME,VEL(3),POS(3),ACC(3),H,HPREV, 21 - - WORK(18),OLDPOS(3),OLDVEL(3),OLDACC(3),TRAPEZ(3) 22 - INTEGER ILOC,INITCH,ITYPE,ILOCVF,I,IOUT 23 - REAL Q,PMASS,X1,Y1,Z1,VX1,VY1,VZ1,EX,EY,EZ,ETOT,VOLT,EOVERM 24 - COMMON /VFUCOM/ EOVERM,ILOCVF 25 - EXTERNAL DLCVFU 26 - *** Identify the routine if requested. 27 - IF(LIDENT)PRINT *,' /// ROUTINE DLCVAC ///' 28 - *** Initialise the output position and time vectors. 1 674 P=DRIFTCAL D=DLCVAC 2 PAGE1039 29 - NU=1 30 - XU(1)=DBLE(X1) 31 - YU(1)=DBLE(Y1) 32 - ZU(1)=DBLE(Z1) 33 - TU(1)=0.0D0 34 - ISTAT=0 35 - *** Set particle type according to mass and technique to vacuum. 36 - IF(ABS(PMASS-EMASS).LT.1E-4*(ABS(EMASS)+ABS(PMASS)))THEN 37 - IPTYPE=1 38 - ELSE 39 - IPTYPE=2 40 - ENDIF 41 - QPCHAR=Q 42 - IPTECH=3 43 - *** Set the charge over mass ratio. 44 - EOVERM=Q/PMASS 45 - *** Check the initial position, setting a status code if appropriate. 46 - CALL EFIELD(X1,Y1,Z1,EX,EY,EZ,ETOT,VOLT,0,ILOC) 47 - * In a wire. 48 - IF(ILOC.GT.0.AND.ILOC.LE.MXWIRE)THEN 49 - IF((X(ILOC)-X1)**2+(Y(ILOC)-Y1)**2.LE.0.25*D(ILOC)**2)THEN 50 - ISTAT=ILOC 51 - ELSE 52 - ISTAT=ILOC+MXWIRE 53 - ENDIF 54 - * Outside the planes. 55 - ELSEIF(ILOC.EQ.-1.OR.ILOC.EQ.-4)THEN 56 - IF(YNPLAN(1).AND.X1.LE.COPLAN(1))THEN 57 - ISTAT=-11 58 - ELSEIF(YNPLAN(2).AND.X1.GE.COPLAN(2))THEN 59 - ISTAT=-12 60 - ELSEIF(YNPLAN(3).AND.Y1.LE.COPLAN(3))THEN 61 - ISTAT=-13 62 - ELSEIF(YNPLAN(4).AND.Y1.GE.COPLAN(4))THEN 63 - ISTAT=-14 64 - ELSEIF(TUBE)THEN 65 - CALL INTUBE(X1,Y1,COTUBE,NTUBE,IOUT) 66 - IF(IOUT.EQ.1)ISTAT=-15 67 - ENDIF 68 - IF(ISTAT.EQ.0)THEN 69 - PRINT *,' !!!!!! DLCVAC WARNING : Field location'// 70 - - ' code does not match geometry; please report.' 71 - ISTAT=-4 72 - ENDIF 73 - * In a material. 74 - ELSEIF(ILOC.EQ.-5)THEN 75 - ISTAT=-5 76 - * Outside the mesh. 77 - ELSEIF(ILOC.EQ.-6)THEN 78 - ISTAT=-6 79 - * Other bizarre codes. 80 - ELSEIF(ILOC.NE.0)THEN 81 - PRINT *,' ###### DLCVAC ERROR : Unexpected ILOC=',ILOC, 82 - - ' received from EFIELD ; program bug, please report.' 83 - ISTAT=-3 84 - ENDIF 85 - * Always return if location code is non-zero. 86 - IF(ILOC.NE.0)RETURN 87 - *** Check the initial status, establishing eg the target wire. 88 - CALL DLCSTA(Q,ITYPE) 89 - IF(ISTAT.NE.0)RETURN 90 - *** Set the initial step-size, ensure that the particle will move. 91 - POS(1)=DBLE(X1) 92 - POS(2)=DBLE(Y1) 93 - POS(3)=DBLE(Z1) 94 - VEL(1)=DBLE(VX1) 95 - VEL(2)=DBLE(VY1) 96 - VEL(3)=DBLE(VZ1) 97 - CALL DLCVFU(0.0D0,POS,VEL,ACC) 98 - IF(ACC(1)**2+ACC(2)**2+ACC(3)**2.GT.0)THEN 99 - H=100*(-SQRT(VEL(1)**2+VEL(2)**2+VEL(3)**2)+ 100 - - SQRT(VEL(1)**2+VEL(2)**2+VEL(3)**2+ 101 - - 2*EPSDIF*SQRT(ACC(1)**2+ACC(2)**2+ACC(3)**2)))/ 102 - - SQRT(ACC(1)**2+ACC(2)**2+ACC(3)**2) 103 - ELSEIF(VEL(1)**2+VEL(2)**2+VEL(3)**2.GT.0)THEN 104 - H=100*EPSDIF/SQRT(VEL(1)**2+VEL(2)**2+VEL(3)**2) 105 - ELSE 106 - PRINT *,' !!!!!! DLCVAC WARNING : Drift line starts'// 107 - - ' with zero velocity and zero acceleration;'// 108 - - ' abandoned' 109 - ISTAT=-3 110 - RETURN 111 - ENDIF 112 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG : Initial'', 113 - - '' step size set to '',E10.3)') H 114 - *** Allow INITCH cycles to adjust the initial step-size. 115 - INITCH=3 116 - 20 CONTINUE 117 - NU=1 118 - *** Set the initial time, position, velocity and acceleration. 119 - TIME=0 120 - POS(1)=DBLE(X1) 121 - POS(2)=DBLE(Y1) 122 - POS(3)=DBLE(Z1) 123 - VEL(1)=DBLE(VX1) 124 - VEL(2)=DBLE(VY1) 125 - VEL(3)=DBLE(VZ1) 126 - CALL DLCVFU(0.0D0,POS,VEL,ACC) 127 - *** Next step. 128 - 30 CONTINUE 129 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG : Step '', 130 - - I4/26X,''(x,y,z)='',3E12.5,'' t='',E12.5)') 131 - - NU,(POS(I),I=1,3),TIME 132 - * Reset location code. 133 - ILOCVF=0 134 - * Save old position. 1 674 P=DRIFTCAL D=DLCVAC 3 PAGE1040 135 - DO 40 I=1,3 136 - OLDPOS(I)=POS(I) 137 - OLDVEL(I)=VEL(I) 138 - OLDACC(I)=ACC(I) 139 - 40 CONTINUE 140 - *** Take a Runge-Kutta-Nystroem step. 141 - CALL DRKNYS(3,H,TIME,POS,VEL,DLCVFU,WORK) 142 - *** Make a trapezoid estimate of the same step. 143 - CALL DLCVFU(0.0D0,POS,VEL,ACC) 144 - DO 50 I=1,3 145 - TRAPEZ(I)=OLDPOS(I)+H*(VEL(I)+OLDVEL(I))/2+ 146 - - H**2*(ACC(I)+OLDACC(I))/8 147 - 50 CONTINUE 148 - *** Check that the target wire is not crossed while exploring the field. 149 - IF(ITARG.GT.0.AND.ILOCVF.GT.0)THEN 150 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', 151 - - '' DLCWIR entered from DLCVAC for ILOCVF='',I5)') 152 - - ILOCVF 153 - CALL DLCWIR(1,Q,ITYPE) 154 - RETURN 155 - ENDIF 156 - *** Check that no dielectric was entered nor that the mesh was left. 157 - IF(ICTYPE.EQ.0.AND.ILOCVF.NE.0)THEN 158 - CALL DLCFMP(OLDPOS(1),OLDPOS(2),OLDPOS(3), 159 - - POS(1),POS(2),POS(3),ILOCVF,Q,ITYPE) 160 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', 161 - - '' Drift medium or mesh left at NU='',I4, 162 - - '' ILOC='',I5)') NU,ILOCVF 163 - RETURN 164 - ENDIF 165 - *** Check particle position for other termination conditions. 166 - CALL DLCSTA(Q,ITYPE) 167 - IF(ISTAT.NE.0)RETURN 168 - *** Check bending angle. 169 - IF(LKINK.AND.NU.GT.1)THEN 170 - IF(VEL(1)*(XU(NU)-XU(NU-1))+VEL(2)*(YU(NU)-YU(NU-1))+ 171 - - VEL(3)*(ZU(NU)-ZU(NU-1)).LT.0)THEN 172 - ISTAT=-3 173 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', 174 - - '' Step '',I3,'': bending angle exceeds pi/2.''/ 175 - - 26X,''Velocity vector: '',3E15.8/ 176 - - 26X,''Previous step: '',3E15.8/ 177 - - 26X,''Inner product: '',E15.8)') 178 - - NU+1,VEL(1),VEL(2),VEL(3),XU(NU)-XU(NU-1), 179 - - YU(NU)-YU(NU-1),ZU(NU)-ZU(NU-1), 180 - - VEL(1)*(XU(NU)-XU(NU-1))+ 181 - - VEL(2)*(YU(NU)-YU(NU-1))+ 182 - - VEL(3)*(ZU(NU)-ZU(NU-1)) 183 - RETURN 184 - ENDIF 185 - ENDIF 186 - *** Copy new X0 and Y0 to XU and YU, add new TU. 187 - NU=NU+1 188 - XU(NU)=POS(1) 189 - YU(NU)=POS(2) 190 - ZU(NU)=POS(3) 191 - TU(NU)=TIME 192 - *** Adjust step size by comparing trapezoid rule and RKN estimates. 193 - HPREV=H 194 - IF(POS(1).NE.TRAPEZ(1).OR.POS(2).NE.TRAPEZ(2).OR. 195 - - POS(3).NE.TRAPEZ(3))THEN 196 - H=H*SQRT(EPSDIF/(ABS(POS(1)-TRAPEZ(1))+ 197 - - ABS(POS(2)-TRAPEZ(2))+ABS(POS(3)-TRAPEZ(3)))) 198 - ELSE 199 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', 200 - - '' Step size increased by a factor 2 in step '',I4, 201 - - '' (1st order = RKN).'')') NU 202 - H=H*2.0D0 203 - ENDIF 204 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', 205 - - '' 1st order: '',3E12.5/26X,''RKN: '',3E12.5/26X, 206 - - ''Step size changed by a factor '',E12.5,'' to '',E12.5)') 207 - - (TRAPEZ(I),I=1,3),(POS(I),I=1,3),H/HPREV,H 208 - *** Don't allow H to become too large in view of the time resolution. 209 - IF(H*ABS(VEL(1)).GT.(DXMAX-DXMIN)/10.0.OR. 210 - - H*ABS(VEL(2)).GT.(DYMAX-DYMIN)/10.0.OR. 211 - - H*ABS(VEL(3)).GT.(DZMAX-DZMIN)/10.0)THEN 212 - H=H/2 213 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', 214 - - '' Step size reduced by a factor 2 in step '',I4, 215 - - '' (step too long).'')') NU 216 - ENDIF 217 - *** Make sure that H is different from zero; this should always be ok. 218 - IF(H.EQ.0.0D0)THEN 219 - PRINT *,' ###### DLCVAC ERROR : Step ',NU,' step size is', 220 - - ' zero (program bug) ; the calculation is abandoned.' 221 - ISTAT=-3 222 - RETURN 223 - ENDIF 224 - *** Check the initial step size. 225 - IF(INITCH.GT.0.AND.(H.LT.HPREV/5.0))THEN 226 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', 227 - - '' Step size reinitialised, current value is '', 228 - - E12.5)') H 229 - INITCH=INITCH-1 230 - GOTO 20 231 - ENDIF 232 - INITCH=0 233 - *** Don't allow H to grow too quickly. 234 - IF(H.GT.10.0*HPREV)THEN 235 - H=10.0*HPREV 236 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', 237 - - '' Step size restricted to 10 x previous in step '', 238 - - I4,''.'')') NU 239 - ENDIF 240 - *** Make sure we haven't got more than MXLIST points already. 1 674 P=DRIFTCAL D=DLCVAC 4 PAGE1041 241 - IF(NU.EQ.MXLIST)THEN 242 - ISTAT=-2 243 - RETURN 244 - ENDIF 245 - *** Stop in case H tends to become too small. 246 - IF(H*(ABS(VEL(1))+ABS(VEL(2))+ABS(VEL(3))).LT.EPSDIF)THEN 247 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', 248 - - '' Step size smaller than EPSDIF in step '',I4, 249 - - '' ; line abandoned.'')') NU 250 - ISTAT=-3 251 - RETURN 252 - ENDIF 253 - GOTO 30 254 - END 675 GARFIELD ================================================== P=DRIFTCAL D=DLCVFU 1 ============================ 0 + +DECK,DLCVFU. 1 - SUBROUTINE DLCVFU(TIME,POS,VEL,ACC) 2 - *----------------------------------------------------------------------- 3 - * DLCVFU - Computes the acceleration of a particle at time TIME, 4 - * location POS and initial velocity VEL. 5 - * (Last changed on 5/ 2/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,BFIELD. 11.- +SEQ,PARAMETERS. 12.- +SEQ,DRIFTLINE. 13.- +SEQ,PRINTPLOT. 14.- +SEQ,CONSTANTS. 15 - DOUBLE PRECISION TIME,POS(3),VEL(3),ACC(3),FACTOR 16 - REAL EX,EY,EZ,ETOT,VOLT,BX,BY,BZ,BTOT,EOVERM 17 - INTEGER ILOCVF,ILOC 18 - C INTEGER I 19 - COMMON /VFUCOM/ EOVERM,ILOCVF 20 - *** Compute the E and B fields. 21 - CALL EFIELD(REAL(POS(1)),REAL(POS(2)),REAL(POS(3)), 22 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 23 - CALL BFIELD(REAL(POS(1)),REAL(POS(2)),REAL(POS(3)), 24 - - BX,BY,BZ,BTOT) 25 - * If the point is located outside the drift area, set a flag. 26 - IF(ILOC.NE.0)THEN 27 - ILOCVF=ILOC 28 - ACC(1)=0 29 - ACC(2)=0 30 - ACC(3)=0 31 - RETURN 32 - ENDIF 33 - *** Compute the relativistic correction and other common factors. 34 - FACTOR=1E-8*EOVERM* 35 - - SQRT(1-(VEL(1)**2+VEL(2)**2+VEL(3)**2)/CLIGHT**2)**3 36 - *** Compute the force/mass acting on the particle. 37 - ACC(1)=FACTOR*(EX+VEL(2)*BZ-VEL(3)*BY) 38 - ACC(2)=FACTOR*(EY+VEL(3)*BX-VEL(1)*BZ) 39 - ACC(3)=FACTOR*(EZ+VEL(1)*BY-VEL(2)*BX) 40 - C IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVFU DEBUG : (x,y,z)='', 41 - C - 3E12.5/26X,''v ='',3E12.5/26X,''a ='',3E12.5)') 42 - C - (POS(I),I=1,3),(VEL(I),I=1,3),(ACC(I),I=1,3) 43 - END 676 GARFIELD ================================================== P=DRIFTCAL D=DLCCAL 1 ============================ 0 + +DECK,DLCCAL. 1 - SUBROUTINE DLCCAL(INSTR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * DLCCAL - Processes drift line related procedure calls. 4 - * (Last changed on 5/ 1/01.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,DRIFTLINE. 9.- +SEQ,CELLDATA. 10.- +SEQ,GASDATA. 11.- +SEQ,SOLIDS. 12.- +SEQ,ALGDATA. 13.- +SEQ,MATDATA. 14.- +SEQ,CONSTANTS. 15.- +SEQ,PRINTPLOT. 16 - INTEGER MXAHIS 17 - PARAMETER(MXAHIS=20) 18 - INTEGER INPCMX,ISIZ(MXMDIM),IRX,IRY,IRZ,IRT,ISX,ISY,ISZ,IST, 19 - - NCOPT,ISTR,NARG,IPROC,INSTR,IFAIL,IFAIL1,IFAIL2,IFAIL3, 20 - - IFAIL4,NPAIR,I,J,MATSLT,IAUX,NC,NREXP,ITYPE(2,MXAHIS),NHIST, 21 - - NETOT,NITOT,IENTRY(MXAHIS),IHIST(MXAHIS),ISW,ICL,ILOC,NC1, 22 - - NC2,NC3,NC4 23 - REAL XCLS,YCLS,ZCLS,ECLS,VXMIN,VYMIN,VXMAX,VYMAX 24 - DOUBLE PRECISION XPOS1,YPOS1,XPOS2,YPOS2,F0(3) 25 - LOGICAL DONE,USE(MXVAR),STAT(4) 26 - EXTERNAL INPCMX,MATSLT 27 - CHARACTER*(MXINCH) TITLE,OPT 28 - CHARACTER*15 AUX1,AUX2,AUX3,AUX4 29 - CHARACTER*10 VARLIS(16) 30 - *** Assume the CALL will fail. 31 - IFAIL=1 32 - *** Verify that we really have a cell and a gas. 33 - IF(.NOT.CELSET)THEN 34 - PRINT *,' !!!!!! DLCCAL WARNING : Cell data not available'// 35 - - ' ; call not executed.' 36 - RETURN 37 - ELSEIF(.NOT.GASSET)THEN 38 - PRINT *,' !!!!!! DLCCAL WARNING : Gas data not available'// 39 - - ' ; call not executed.' 40 - RETURN 41 - ENDIF 1 676 P=DRIFTCAL D=DLCCAL 2 PAGE1042 42 - *** Some easy reference variables. 43 - NARG=INS(INSTR,3) 44 - IPROC=INS(INSTR,1) 45 - *** Start a new track. 46 - IF(IPROC.EQ.-501)THEN 47 - * Warn if there are arguments. 48 - IF(NARG.NE.0)PRINT *,' !!!!!! DLCCAL WARNING : The'// 49 - - ' NEW_TRACK procedure has no arguments; ignored.' 50 - * Reinitialise the track. 51 - CALL TRACLI 52 - *** Get a new cluster. 53 - ELSEIF(IPROC.EQ.-502)THEN 54 - * Check the arguments. 55 - IF(NARG.NE.6.OR.ARGREF(1,1).GE.2.OR.ARGREF(2,1).GE.2.OR. 56 - - ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2.OR. 57 - - ARGREF(5,1).GE.2.OR.ARGREF(6,1).GE.2)THEN 58 - PRINT *,' !!!!!! DLCCAL WARNING : Incorrect set of'// 59 - - ' arguments for GET_CLUSTER; no cluster.' 60 - RETURN 61 - ENDIF 62 - * Clean up space associated with the arguments. 63 - DO 40 ISTR=1,NARG 64 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 65 - 40 CONTINUE 66 - * Ask for a new cluster. 67 - CALL TRACLS(XCLS,YCLS,ZCLS,ECLS,NPAIR,DONE,IFAIL1) 68 - * Return the cluster position. 69 - ARG(1)=XCLS 70 - ARG(2)=YCLS 71 - ARG(3)=ZCLS 72 - MODARG(1)=2 73 - MODARG(2)=2 74 - MODARG(3)=2 75 - * Return the cluster size. 76 - ARG(4)=REAL(NPAIR) 77 - MODARG(4)=2 78 - * Return the cluster energy. 79 - ARG(5)=ECLS 80 - MODARG(5)=2 81 - * Set the flag whether to continue or not. 82 - IF(DONE)THEN 83 - ARG(6)=1 84 - ELSE 85 - ARG(6)=0 86 - ENDIF 87 - MODARG(6)=3 88 - * Check the return flag for failure. 89 - IF(IFAIL1.EQ.0)THEN 90 - CALL LOGSAV(.TRUE.,'OK',IFAIL1) 91 - ELSE 92 - CALL LOGSAV(.FALSE.,'OK',IFAIL1) 93 - ENDIF 94 - *** Drift line calculation for electrons. 95 - ELSEIF(IPROC.EQ.-503)THEN 96 - * Check number of arguments. 97 - IF(NARG.LT.2.OR.NARG.GT.7)THEN 98 - PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// 99 - - ' of arguments for DRIFT_ELECTRON.' 100 - RETURN 101 - * Check argument mode. 102 - ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2)THEN 103 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// 104 - - ' DRIFT_ELECTRON are of incorrect type.' 105 - RETURN 106 - * Check the the results can be transferred back. 107 - ELSEIF((NARG.GE.3.AND.ARGREF(3,1).GE.2).OR. 108 - - (NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. 109 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. 110 - - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. 111 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2))THEN 112 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// 113 - - ' of DRIFT_ELECTRON can not be modified.' 114 - RETURN 115 - * Make sure there are drift velocities. 116 - ELSEIF(.NOT.GASOK(1))THEN 117 - PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// 118 - - ' for electrons is not defined ; not executed.' 119 - RETURN 120 - ENDIF 121 - * Variables already in use ? 122 - DO 270 ISTR=3,NARG 123 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 124 - 270 CONTINUE 125 - * Carry out the calculation. 126 - CALL DLCALC(ARG(1),ARG(2),0.0,-1.0,1) 127 - * Return status code. 128 - IF(NARG.GE.3)THEN 129 - CALL DLCSTF(ISTAT,OPT,NCOPT) 130 - CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) 131 - ARG(3)=REAL(IAUX) 132 - MODARG(3)=1 133 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// 134 - - ' Error storing the status for DRIFT_ELECTRON.' 135 - ENDIF 136 - * Compute and return requested numerical data. 137 - ARG(4)=TU(NU) 138 - IF(NARG.GE.5)CALL DLCDIF(ARG(5)) 139 - IF(NARG.GE.6)CALL DLCTWN(ARG(6)) 140 - IF(NARG.GE.7)CALL DLCATT(ARG(7)) 141 - MODARG(4)=2 142 - MODARG(5)=2 143 - MODARG(6)=2 144 - MODARG(7)=2 145 - *** Drift line calculation for positrons. 146 - ELSEIF(IPROC.EQ.-521)THEN 147 - * Check number of arguments. 1 676 P=DRIFTCAL D=DLCCAL 3 PAGE1043 148 - IF(NARG.LT.2.OR.NARG.GT.4)THEN 149 - PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// 150 - - ' of arguments for DRIFT_POSITRON.' 151 - RETURN 152 - * Check argument mode. 153 - ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2)THEN 154 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// 155 - - ' DRIFT_POSITRON are of incorrect type.' 156 - RETURN 157 - * Check the the results can be transferred back. 158 - ELSEIF((NARG.GE.3.AND.ARGREF(3,1).GE.2).OR. 159 - - (NARG.GE.4.AND.ARGREF(4,1).GE.2))THEN 160 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// 161 - - ' of DRIFT_POSITRON can not be modified.' 162 - RETURN 163 - * Make sure there are drift velocities. 164 - ELSEIF(.NOT.GASOK(1))THEN 165 - PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// 166 - - ' for electrons is not defined ; not executed.' 167 - RETURN 168 - ENDIF 169 - * Variables already in use ? 170 - DO 300 ISTR=3,NARG 171 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 172 - 300 CONTINUE 173 - * Carry out the calculation. 174 - CALL DLCALC(ARG(1),ARG(2),0.0,+1.0,1) 175 - * Return status code. 176 - IF(NARG.GE.3)THEN 177 - CALL DLCSTF(ISTAT,OPT,NCOPT) 178 - CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) 179 - ARG(3)=REAL(IAUX) 180 - MODARG(3)=1 181 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// 182 - - ' Error storing the status for DRIFT_POSITRON.' 183 - ENDIF 184 - * Compute and return requested numerical data. 185 - ARG(4)=TU(NU) 186 - MODARG(4)=2 187 - *** Drift line calculation for ions. 188 - ELSEIF(IPROC.EQ.-504.OR.IPROC.EQ.-514)THEN 189 - * Check number of arguments. 190 - IF(NARG.LT.2.OR.NARG.GT.4)THEN 191 - PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// 192 - - ' of arguments for DRIFT_ION.' 193 - RETURN 194 - * Check argument mode. 195 - ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2)THEN 196 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// 197 - - ' DRIFT_ION are of incorrect type.' 198 - RETURN 199 - * Check the the results can be transferred back. 200 - ELSEIF((NARG.GE.3.AND.ARGREF(3,1).GE.2).OR. 201 - - (NARG.GE.4.AND.ARGREF(4,1).GE.2))THEN 202 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// 203 - - ' of DRIFT_ION can not be modified.' 204 - RETURN 205 - * Make sure there are drift velocities. 206 - ELSEIF(.NOT.GASOK(2))THEN 207 - PRINT *,' !!!!!! DLCCAL WARNING : The mobility'// 208 - - ' for ions is not defined ; not executed.' 209 - RETURN 210 - ENDIF 211 - * Variables already in use ? 212 - IF(NARG.GE.3)CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) 213 - IF(NARG.GE.4)CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 214 - * Carry out the calculation. 215 - IF(IPROC.EQ.-504)THEN 216 - CALL DLCALC(ARG(1),ARG(2),0.0,+1.0,2) 217 - ELSE 218 - CALL DLCALC(ARG(1),ARG(2),0.0,-1.0,2) 219 - ENDIF 220 - * Return status code. 221 - IF(NARG.GE.3)THEN 222 - CALL DLCSTF(ISTAT,OPT,NCOPT) 223 - CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) 224 - ARG(3)=REAL(IAUX) 225 - MODARG(3)=1 226 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// 227 - - ' Error storing the status for DRIFT_ION.' 228 - ENDIF 229 - * Compute and return requested numerical data. 230 - ARG(4)=TU(NU) 231 - MODARG(4)=2 232 - *** 3D Drift line calculation for electrons. 233 - ELSEIF(IPROC.EQ.-505)THEN 234 - * Check number of arguments. 235 - IF(NARG.LT.3.OR.NARG.GT.8)THEN 236 - PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// 237 - - ' of arguments for DRIFT_ELECTRON_3.' 238 - RETURN 239 - * Check argument mode. 240 - ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 241 - - MODARG(3).NE.2)THEN 242 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// 243 - - ' DRIFT_ELECTRON_3 are of incorrect type.' 244 - RETURN 245 - * Check the the results can be transferred back. 246 - ELSEIF((NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. 247 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. 248 - - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. 249 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. 250 - - (NARG.GE.8.AND.ARGREF(8,1).GE.2))THEN 251 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// 252 - - ' of DRIFT_ELECTRON_3 can not be modified.' 253 - RETURN 1 676 P=DRIFTCAL D=DLCCAL 4 PAGE1044 254 - * Make sure there are drift velocities. 255 - ELSEIF(.NOT.GASOK(1))THEN 256 - PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// 257 - - ' for electrons is not defined ; not executed.' 258 - RETURN 259 - ENDIF 260 - * Variables already in use ? 261 - DO 280 ISTR=4,NARG 262 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 263 - 280 CONTINUE 264 - * Carry out the calculation. 265 - CALL DLCALC(ARG(1),ARG(2),ARG(3),-1.0,1) 266 - * Return status code. 267 - IF(NARG.GE.4)THEN 268 - CALL DLCSTF(ISTAT,OPT,NCOPT) 269 - CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) 270 - ARG(4)=REAL(IAUX) 271 - MODARG(4)=1 272 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// 273 - - ' Error storing the status for DRIFT_ELECTRON_3.' 274 - ENDIF 275 - * Compute and return requested numerical data. 276 - ARG(5)=TU(NU) 277 - IF(NARG.GE.6)CALL DLCDIF(ARG(6)) 278 - IF(NARG.GE.7)CALL DLCTWN(ARG(7)) 279 - IF(NARG.GE.8)CALL DLCATT(ARG(8)) 280 - MODARG(5)=2 281 - MODARG(6)=2 282 - MODARG(7)=2 283 - MODARG(8)=2 284 - *** 3D Drift line calculation for positrons. 285 - ELSEIF(IPROC.EQ.-522)THEN 286 - * Check number of arguments. 287 - IF(NARG.LT.3.OR.NARG.GT.5)THEN 288 - PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// 289 - - ' of arguments for DRIFT_POSITRON_3.' 290 - RETURN 291 - * Check argument mode. 292 - ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 293 - - MODARG(3).NE.2)THEN 294 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// 295 - - ' DRIFT_POSITRON_3 are of incorrect type.' 296 - RETURN 297 - * Check the the results can be transferred back. 298 - ELSEIF((NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. 299 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2))THEN 300 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// 301 - - ' of DRIFT_POSITRON_3 can not be modified.' 302 - RETURN 303 - * Make sure there are drift velocities. 304 - ELSEIF(.NOT.GASOK(1))THEN 305 - PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// 306 - - ' for electrons is not defined ; not executed.' 307 - RETURN 308 - ENDIF 309 - * Variables already in use ? 310 - DO 310 ISTR=4,NARG 311 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 312 - 310 CONTINUE 313 - * Carry out the calculation. 314 - CALL DLCALC(ARG(1),ARG(2),ARG(3),+1.0,1) 315 - * Return status code. 316 - IF(NARG.GE.4)THEN 317 - CALL DLCSTF(ISTAT,OPT,NCOPT) 318 - CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) 319 - ARG(4)=REAL(IAUX) 320 - MODARG(4)=1 321 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// 322 - - ' Error storing the status for DRIFT_POSITRON_3.' 323 - ENDIF 324 - * Compute and return requested numerical data. 325 - ARG(5)=TU(NU) 326 - MODARG(5)=2 327 - *** 3D Drift line calculation for ions. 328 - ELSEIF(IPROC.EQ.-506.OR.IPROC.EQ.-515)THEN 329 - * Check number of arguments. 330 - IF(NARG.LT.3.OR.NARG.GT.5)THEN 331 - PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// 332 - - ' of arguments for DRIFT_ION_3.' 333 - RETURN 334 - * Check argument mode. 335 - ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 336 - - MODARG(3).NE.2)THEN 337 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// 338 - - ' DRIFT_ION_3 are of incorrect type.' 339 - RETURN 340 - * Check the the results can be transferred back. 341 - ELSEIF((NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. 342 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2))THEN 343 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// 344 - - ' of DRIFT_ION_3 can not be modified.' 345 - RETURN 346 - * Make sure there are drift velocities. 347 - ELSEIF(.NOT.GASOK(2))THEN 348 - PRINT *,' !!!!!! DLCCAL WARNING : The mobility'// 349 - - ' for ions is not defined ; not executed.' 350 - RETURN 351 - ENDIF 352 - * Variables already in use ? 353 - IF(NARG.GE.4)CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 354 - IF(NARG.GE.5)CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) 355 - * Carry out the calculation. 356 - IF(IPROC.EQ.-506)THEN 357 - CALL DLCALC(ARG(1),ARG(2),ARG(3),+1.0,2) 358 - ELSE 359 - CALL DLCALC(ARG(1),ARG(2),ARG(3),-1.0,2) 1 676 P=DRIFTCAL D=DLCCAL 5 PAGE1045 360 - ENDIF 361 - * Return status code. 362 - IF(NARG.GE.4)THEN 363 - CALL DLCSTF(ISTAT,OPT,NCOPT) 364 - CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) 365 - ARG(4)=REAL(IAUX) 366 - MODARG(4)=1 367 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// 368 - - ' Error storing the status for DRIFT_ION_3.' 369 - ENDIF 370 - * Compute and return requested numerical data. 371 - ARG(5)=TU(NU) 372 - MODARG(5)=2 373 - *** Get the drift line. 374 - ELSEIF(IPROC.EQ.-507)THEN 375 - * Check the arguments. 376 - IF(NARG.LT.1.OR.NARG.GT.4.OR. 377 - - (NARG.GE.1.AND.ARGREF(1,1).GE.2).OR. 378 - - (NARG.GE.2.AND.ARGREF(2,1).GE.2).OR. 379 - - (NARG.GE.3.AND.ARGREF(3,1).GE.2).OR. 380 - - (NARG.GE.4.AND.ARGREF(4,1).GE.2))THEN 381 - PRINT *,' !!!!!! DLCCAL WARNING : Incorrect argument'// 382 - - ' list for GET_DRIFT_LINE.' 383 - RETURN 384 - ELSEIF(ISTAT.EQ.0.OR.NU.LT.1)THEN 385 - PRINT *,' !!!!!! DLCCAL WARNING : No drift line in'// 386 - - ' memory currently.' 387 - RETURN 388 - ENDIF 389 - * Clear the arguments. 390 - IF(NARG.GE.1)CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) 391 - IF(NARG.GE.2)CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) 392 - IF(NARG.GE.3)CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) 393 - IF(NARG.GE.4)CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 394 - * Allocate matrices. 395 - ISIZ(1)=NU 396 - IF(NARG.GE.1)THEN 397 - CALL MATADM('ALLOCATE',IRX,1,ISIZ,2,IFAIL1) 398 - ELSE 399 - IFAIL1=0 400 - ENDIF 401 - IF(NARG.GE.2)THEN 402 - CALL MATADM('ALLOCATE',IRY,1,ISIZ,2,IFAIL2) 403 - ELSE 404 - IFAIL2=0 405 - ENDIF 406 - IF(NARG.GE.3)THEN 407 - CALL MATADM('ALLOCATE',IRZ,1,ISIZ,2,IFAIL3) 408 - ELSE 409 - IFAIL3=0 410 - ENDIF 411 - IF(NARG.GE.4)THEN 412 - CALL MATADM('ALLOCATE',IRT,1,ISIZ,2,IFAIL4) 413 - ELSE 414 - IFAIL4=0 415 - ENDIF 416 - IF(NARG.GE.1)THEN 417 - ISX=MATSLT(IRX) 418 - ELSE 419 - ISX=1 420 - ENDIF 421 - IF(NARG.GE.2)THEN 422 - ISY=MATSLT(IRY) 423 - ELSE 424 - ISY=1 425 - ENDIF 426 - IF(NARG.GE.3)THEN 427 - ISZ=MATSLT(IRZ) 428 - ELSE 429 - ISZ=1 430 - ENDIF 431 - IF(NARG.GE.4)THEN 432 - IST=MATSLT(IRT) 433 - ELSE 434 - IST=1 435 - ENDIF 436 - IF(IFAIL1.NE.0.OR.ISX.LE.0.OR.IFAIL2.NE.0.OR.ISY.LE.0.OR. 437 - - IFAIL3.NE.0.OR.ISZ.LE.0.OR.IFAIL4.NE.0.OR.IST.LE.0)THEN 438 - PRINT *,' !!!!!! DLCCAL WARNING : Unable to allocate'// 439 - - ' output matrices for GET_DRIFT_LINE.' 440 - RETURN 441 - ENDIF 442 - * Copy the vectors. 443 - DO 10 I=1,NU 444 - IF(NARG.GE.1)MVEC(MORG(ISX)+I)=REAL(XU(I)) 445 - IF(NARG.GE.2)MVEC(MORG(ISY)+I)=REAL(YU(I)) 446 - IF(NARG.GE.3)MVEC(MORG(ISZ)+I)=REAL(ZU(I)) 447 - IF(NARG.GE.4)MVEC(MORG(IST)+I)=REAL(TU(I)) 448 - 10 CONTINUE 449 - * Save the vectors. 450 - IF(NARG.GE.1)THEN 451 - ARG(1)=IRX 452 - MODARG(1)=5 453 - ENDIF 454 - IF(NARG.GE.2)THEN 455 - ARG(2)=IRY 456 - MODARG(2)=5 457 - ENDIF 458 - IF(NARG.GE.3)THEN 459 - ARG(3)=IRZ 460 - MODARG(3)=5 461 - ENDIF 462 - IF(NARG.GE.4)THEN 463 - ARG(4)=IRT 464 - MODARG(4)=5 465 - ENDIF 1 676 P=DRIFTCAL D=DLCCAL 6 PAGE1046 466 - *** 3D MC drift line calculation for electrons. 467 - ELSEIF(IPROC.EQ.-508)THEN 468 - * Check number of arguments. 469 - IF(NARG.LT.3.OR.NARG.GT.7)THEN 470 - PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// 471 - - ' of arguments for DRIFT_ELECTRON_MC.' 472 - RETURN 473 - * Check argument mode. 474 - ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 475 - - MODARG(3).NE.2)THEN 476 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// 477 - - ' DRIFT_ELECTRON_MC are of incorrect type.' 478 - RETURN 479 - * Check the the results can be transferred back. 480 - ELSEIF((NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. 481 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. 482 - - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. 483 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2))THEN 484 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// 485 - - ' of DRIFT_ELECTRON_MC can not be modified.' 486 - RETURN 487 - * Make sure there are drift velocities. 488 - ELSEIF(.NOT.GASOK(1))THEN 489 - PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// 490 - - ' for electrons is not defined ; not executed.' 491 - RETURN 492 - ENDIF 493 - * Variables already in use ? 494 - DO 20 ISTR=4,NARG 495 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 496 - 20 CONTINUE 497 - * Carry out the calculation. 498 - CALL DLCMC(ARG(1),ARG(2),ARG(3),-1.0,1) 499 - * Return status code. 500 - IF(NARG.GE.4)THEN 501 - CALL DLCSTF(ISTAT,OPT,NCOPT) 502 - CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) 503 - ARG(4)=REAL(IAUX) 504 - MODARG(4)=1 505 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// 506 - - ' Error storing the status for DRIFT_ELECTRON_MC.' 507 - ENDIF 508 - * Compute and return requested numerical data. 509 - ARG(5)=TU(NU) 510 - IF(NARG.GE.6)CALL DLCTWN(ARG(6)) 511 - IF(NARG.GE.7)CALL DLCATT(ARG(7)) 512 - MODARG(5)=2 513 - MODARG(6)=2 514 - MODARG(7)=2 515 - *** 3D MC drift line calculation for electrons. 516 - ELSEIF(IPROC.EQ.-523)THEN 517 - * Check number of arguments. 518 - IF(NARG.LT.3.OR.NARG.GT.5)THEN 519 - PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// 520 - - ' of arguments for DRIFT_MC_POSITRON.' 521 - RETURN 522 - * Check argument mode. 523 - ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 524 - - MODARG(3).NE.2)THEN 525 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// 526 - - ' DRIFT_MC_POSITRON are of incorrect type.' 527 - RETURN 528 - * Check the the results can be transferred back. 529 - ELSEIF((NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. 530 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2))THEN 531 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// 532 - - ' of DRIFT_MC_POSITRON can not be modified.' 533 - RETURN 534 - * Make sure there are drift velocities. 535 - ELSEIF(.NOT.GASOK(1))THEN 536 - PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// 537 - - ' for electrons is not defined ; not executed.' 538 - RETURN 539 - ENDIF 540 - * Variables already in use ? 541 - DO 320 ISTR=4,NARG 542 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 543 - 320 CONTINUE 544 - * Carry out the calculation. 545 - CALL DLCMC(ARG(1),ARG(2),ARG(3),+1.0,1) 546 - * Return status code. 547 - IF(NARG.GE.4)THEN 548 - CALL DLCSTF(ISTAT,OPT,NCOPT) 549 - CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) 550 - ARG(4)=REAL(IAUX) 551 - MODARG(4)=1 552 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// 553 - - ' Error storing the status for DRIFT_MC_POSITRON.' 554 - ENDIF 555 - * Compute and return requested numerical data. 556 - ARG(5)=TU(NU) 557 - MODARG(5)=2 558 - *** 3D MC drift line calculation for ions. 559 - ELSEIF(IPROC.EQ.-509.OR.IPROC.EQ.-516)THEN 560 - * Check number of arguments. 561 - IF(NARG.LT.3.OR.NARG.GT.5)THEN 562 - PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// 563 - - ' of arguments for DRIFT_ION_MC.' 564 - RETURN 565 - * Check argument mode. 566 - ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 567 - - MODARG(3).NE.2)THEN 568 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// 569 - - ' DRIFT_ION_MC are of incorrect type.' 570 - RETURN 571 - * Check the the results can be transferred back. 1 676 P=DRIFTCAL D=DLCCAL 7 PAGE1047 572 - ELSEIF((NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. 573 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2))THEN 574 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// 575 - - ' of DRIFT_ION_MC can not be modified.' 576 - RETURN 577 - * Make sure there are drift velocities. 578 - ELSEIF(.NOT.GASOK(2))THEN 579 - PRINT *,' !!!!!! DLCCAL WARNING : The mobility'// 580 - - ' for ions is not defined ; not executed.' 581 - RETURN 582 - ENDIF 583 - * Variables already in use ? 584 - CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 585 - CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) 586 - * Carry out the calculation. 587 - IF(IPROC.EQ.-509)THEN 588 - CALL DLCMC(ARG(1),ARG(2),ARG(3),+1.0,2) 589 - ELSE 590 - CALL DLCMC(ARG(1),ARG(2),ARG(3),-1.0,2) 591 - ENDIF 592 - * Return status code. 593 - IF(NARG.GE.4)THEN 594 - CALL DLCSTF(ISTAT,OPT,NCOPT) 595 - CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) 596 - ARG(4)=REAL(IAUX) 597 - MODARG(4)=1 598 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// 599 - - ' Error storing the status for DRIFT_ION_MC.' 600 - ENDIF 601 - * Compute and return requested numerical data. 602 - ARG(5)=TU(NU) 603 - MODARG(5)=2 604 - *** Drift line calculation in vacuum for electrons. 605 - ELSEIF(IPROC.EQ.-517)THEN 606 - * Check number of arguments. 607 - IF(NARG.LT.6.OR.NARG.GT.8)THEN 608 - PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// 609 - - ' of arguments for DRIFT_VACUUM_ELECTRON.' 610 - RETURN 611 - * Check argument mode. 612 - ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. 613 - - MODARG(3).NE.2.OR.MODARG(4).NE.2.OR. 614 - - MODARG(5).NE.2.OR.MODARG(6).NE.2)THEN 615 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// 616 - - ' DRIFT_VACUUM_ELECTRON are of incorrect type.' 617 - RETURN 618 - * Check the the results can be transferred back. 619 - ELSEIF((NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. 620 - - (NARG.GE.8.AND.ARGREF(8,1).GE.2))THEN 621 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// 622 - - ' of DRIFT_VACUUM_ELECTRON can not be modified.' 623 - RETURN 624 - ENDIF 625 - * Variables already in use ? 626 - DO 290 ISTR=7,NARG 627 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 628 - 290 CONTINUE 629 - * Carry out the calculation. 630 - CALL DLCVAC(ARG(1),ARG(2),ARG(3),ARG(4),ARG(5),ARG(6), 631 - - -ECHARG,EMASS) 632 - * Return status code. 633 - IF(NARG.GE.7)THEN 634 - CALL DLCSTF(ISTAT,OPT,NCOPT) 635 - CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) 636 - ARG(7)=REAL(IAUX) 637 - MODARG(7)=1 638 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// 639 - - ' Error storing a string for'// 640 - - ' DRIFT_VACUUM_ELECTRON.' 641 - ENDIF 642 - * Return drift time. 643 - IF(NARG.GE.8)THEN 644 - ARG(8)=TU(NU) 645 - MODARG(8)=2 646 - ENDIF 647 - *** Plot the drift line. 648 - ELSEIF(IPROC.EQ.-510)THEN 649 - * There are no arguments for this procedure. 650 - IF(NARG.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// 651 - - ' PLOT_DRIFT_LINE has no arguments; ignored.' 652 - * Save the drift line. 653 - CALL DLCBCK('SAVE') 654 - * Plot the requested projection. 655 - CALL DLCPLT 656 - * Restore the drift line. 657 - CALL DLCBCK('RESTORE') 658 - *** Plot the track. 659 - ELSEIF(IPROC.EQ.-511)THEN 660 - * Warn if there are arguments. 661 - IF(NARG.NE.0)PRINT *,' !!!!!! DLCCAL WARNING : The'// 662 - - ' PLOT_TRACK procedure has no arguments; ignored.' 663 - * Plot the track. 664 - CALL TRAPLT 665 - *** 3D MC drift line calculation for electrons with avalanche. 666 - ELSEIF(IPROC.EQ.-512)THEN 667 - ** Check number of arguments. 668 - IF(NARG.LT.3.OR. 669 - - (NARG.GE.4.AND.MODARG(4).NE.1).OR. 670 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. 671 - - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. 672 - - (NARG.GE.7.AND.NARG.NE.2*(NARG/2)).OR. 673 - - NARG.GT.6+2*MXAHIS)THEN 674 - PRINT *,' !!!!!! DLCCAL WARNING : Incorrect list of'// 675 - - ' arguments for AVALANCHE; not executed' 676 - RETURN 677 - * Make sure there are drift velocities. 1 676 P=DRIFTCAL D=DLCCAL 8 PAGE1048 678 - ELSEIF(.NOT.GASOK(1))THEN 679 - PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// 680 - - ' for electrons is not defined ; not executed.' 681 - RETURN 682 - * Make sure there are Townsend coefficients. 683 - ELSEIF(.NOT.GASOK(4))THEN 684 - PRINT *,' !!!!!! DLCCAL WARNING : The Townsend'// 685 - - ' coefficient is not defined ; not executed.' 686 - RETURN 687 - ENDIF 688 - ** Fetch the option string. 689 - IF(NARG.GE.4)THEN 690 - CALL STRBUF('READ',NINT(ARG(4)),OPT,NCOPT,IFAIL1) 691 - CALL CLTOU(OPT(1:NCOPT)) 692 - ELSE 693 - OPT=' ' 694 - NCOPT=1 695 - ENDIF 696 - ** Liberate storage associated with the electron and ion count. 697 - IF(NARG.GE.5)CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) 698 - IF(NARG.GE.6)CALL ALGREU(NINT(ARG(6)),MODARG(6),ARGREF(6,1)) 699 - ** Create the entry point for the histogram formulae. 700 - IF(NARG.GE.7)THEN 701 - * Initialise the usage list. 702 - STAT(1)=.FALSE. 703 - STAT(2)=.FALSE. 704 - STAT(3)=.FALSE. 705 - STAT(4)=.FALSE. 706 - * Establish the variable list. 707 - IF(POLAR)THEN 708 - VARLIS(1)= 'R_CREATED' 709 - VARLIS(5)= 'R_LOST' 710 - VARLIS(9)= 'R_E' 711 - VARLIS(13)='R_ION' 712 - VARLIS(2)= 'PHI_CREATED' 713 - VARLIS(6)= 'PHI_LOST' 714 - VARLIS(10)='PHI_E' 715 - VARLIS(14)='PHI_ION' 716 - ELSE 717 - VARLIS(1)= 'X_CREATED' 718 - VARLIS(5)= 'X_LOST' 719 - VARLIS(9)= 'X_E' 720 - VARLIS(13)='X_ION' 721 - VARLIS(2)= 'Y_CREATED' 722 - VARLIS(6)= 'Y_LOST' 723 - VARLIS(10)='Y_E' 724 - VARLIS(14)='Y_ION' 725 - ENDIF 726 - VARLIS(3)= 'Z_CREATED' 727 - VARLIS(7)= 'Z_LOST' 728 - VARLIS(11)='Z_E' 729 - VARLIS(15)='Z_ION' 730 - VARLIS(4)= 'T_CREATED' 731 - VARLIS(8)= 'T_LOST' 732 - VARLIS(12)='T_E' 733 - VARLIS(16)='T_ION' 734 - * Number of histograms. 735 - NHIST=NARG/2-3 736 - * Loop over the histograms. 737 - DO 30 I=1,NHIST 738 - * Fetch the histogram string. 739 - CALL STRBUF('READ',NINT(ARG(5+2*I)),TITLE,NC,IFAIL1) 740 - IF(IFAIL1.NE.0.OR.NC.LT.1)THEN 741 - PRINT *,' !!!!!! DLCCAL WARNING : Unable to get'// 742 - - ' an histogram formula; no avalanche.' 743 - RETURN 744 - ENDIF 745 - CALL CLTOU(TITLE(1:NC)) 746 - * Translate the formula. 747 - CALL ALGPRE(TITLE(1:NC),NC,VARLIS,16,NREXP,USE, 748 - - IENTRY(I),IFAIL1) 749 - IF(IFAIL1.NE.0)THEN 750 - PRINT *,' !!!!!! DLCCAL WARNING : The histogram'// 751 - - ' function '//TITLE(1:NC)//' can not be'// 752 - - ' translated; no avalanche.' 753 - CALL ALGCLR(IENTRY(I)) 754 - RETURN 755 - ELSEIF(NREXP.LT.1.OR.NREXP.GT.2)THEN 756 - PRINT *,' !!!!!! DLCCAL WARNING : The histogram'// 757 - - ' function '//TITLE(1:NC)//' does not'// 758 - - ' return 1 or 2 results; no avalanche.' 759 - CALL ALGCLR(IENTRY(I)) 760 - RETURN 761 - ENDIF 762 - ITYPE(2,I)=NREXP 763 - * Work out which quantities are to be computed. 764 - ITYPE(1,I)=0 765 - IF((USE( 1).OR.USE( 2).OR.USE( 3).OR.USE( 4)).AND. 766 - - ITYPE(1,I).NE.0)THEN 767 - PRINT *,' !!!!!! DLCCAL WARNING : Histogram'// 768 - - ' function '//TITLE(1:NC)//' uses an'// 769 - - ' invalid mix of parameters; no avalanche.' 770 - CALL ALGCLR(IENTRY(I)) 771 - RETURN 772 - ELSEIF(USE( 1).OR.USE( 2).OR.USE( 3).OR.USE( 4))THEN 773 - ITYPE(1,I)=1 774 - ENDIF 775 - IF((USE( 5).OR.USE( 6).OR.USE( 7).OR.USE( 8)).AND. 776 - - ITYPE(1,I).NE.0)THEN 777 - PRINT *,' !!!!!! DLCCAL WARNING : Histogram'// 778 - - ' function '//TITLE(1:NC)//' uses an'// 779 - - ' invalid mix of parameters; no avalanche.' 780 - CALL ALGCLR(IENTRY(I)) 781 - RETURN 782 - ELSEIF(USE( 5).OR.USE( 6).OR.USE( 7).OR.USE( 8))THEN 783 - ITYPE(1,I)=2 1 676 P=DRIFTCAL D=DLCCAL 9 PAGE1049 784 - ENDIF 785 - IF((USE( 9).OR.USE(10).OR.USE(11).OR.USE(12)).AND. 786 - - ITYPE(1,I).NE.0)THEN 787 - PRINT *,' !!!!!! DLCCAL WARNING : Histogram'// 788 - - ' function '//TITLE(1:NC)//' uses an'// 789 - - ' invalid mix of parameters; no avalanche.' 790 - CALL ALGCLR(IENTRY(I)) 791 - RETURN 792 - ELSEIF(USE( 9).OR.USE(10).OR.USE(11).OR.USE(12))THEN 793 - ITYPE(1,I)=3 794 - ENDIF 795 - IF((USE(13).OR.USE(14).OR.USE(15).OR.USE(16)).AND. 796 - - ITYPE(1,I).NE.0)THEN 797 - PRINT *,' !!!!!! DLCCAL WARNING : Histogram'// 798 - - ' function '//TITLE(1:NC)//' uses an'// 799 - - ' invalid mix of parameters; no avalanche.' 800 - CALL ALGCLR(IENTRY(I)) 801 - RETURN 802 - ELSEIF(USE(13).OR.USE(14).OR.USE(15).OR.USE(16))THEN 803 - ITYPE(1,I)=4 804 - ENDIF 805 - IF(ITYPE(1,I).EQ.0)THEN 806 - PRINT *,' !!!!!! DLCCAL WARNING : Histogram'// 807 - - ' function '//TITLE(1:NC)//' uses no'// 808 - - ' variables; no avalanche.' 809 - CALL ALGCLR(IENTRY(I)) 810 - RETURN 811 - ENDIF 812 - STAT(1)=STAT(1).OR.(ITYPE(1,I).EQ.1) 813 - STAT(2)=STAT(2).OR.(ITYPE(1,I).EQ.2) 814 - STAT(3)=STAT(3).OR.(ITYPE(1,I).EQ.3) 815 - STAT(4)=STAT(4).OR.(ITYPE(1,I).EQ.4) 816 - * Generate the histogram index list and check the number. 817 - IF(ARGREF(6+2*I,1).GE.2)THEN 818 - PRINT *,' !!!!!! DLCCAL WARNING : Histogram'// 819 - - ' argument ',I,' can not be modified;'// 820 - - ' no avalanche.' 821 - CALL ALGCLR(IENTRY(I)) 822 - RETURN 823 - ELSEIF(MODARG(6+2*I).EQ.4)THEN 824 - IHIST(I)=NINT(ARG(6+2*I)) 825 - ELSE 826 - CALL ALGREU(NINT(ARG(6+2*I)),MODARG(6+2*I), 827 - - ARGREF(6+2*I,1)) 828 - CALL HISADM('ALLOCATE',IHIST(I),100,0.0,0.0, 829 - - .TRUE.,IFAIL1) 830 - ENDIF 831 - 30 CONTINUE 832 - * No histograms to be made. 833 - ELSE 834 - STAT(1)=.FALSE. 835 - STAT(2)=.FALSE. 836 - STAT(3)=.FALSE. 837 - STAT(4)=.FALSE. 838 - NHIST=0 839 - ENDIF 840 - ** Carry out the calculation. 841 - CALL DLCMCA(ARG(1),ARG(2),ARG(3),NETOT,NITOT, 842 - - STAT,NHIST,IHIST,ITYPE,IENTRY,OPT(1:NCOPT)) 843 - * Print algebra errors if there were any. 844 - CALL ALGERR 845 - ** Return the arguments and delete the instruction lists. 846 - IF(NARG.GE.5)THEN 847 - ARG(5)=REAL(NETOT) 848 - MODARG(5)=2 849 - ENDIF 850 - IF(NARG.GE.6)THEN 851 - ARG(6)=REAL(NITOT) 852 - MODARG(6)=2 853 - ENDIF 854 - DO 50 I=1,NHIST 855 - ARG(6+2*I)=REAL(IHIST(I)) 856 - MODARG(6+2*I)=4 857 - CALL ALGCLR(IENTRY(I)) 858 - 50 CONTINUE 859 - *** Plot the drift area. 860 - ELSEIF(IPROC.EQ.-513)THEN 861 - * Check arguments. 862 - IF((NARG.NE.0.AND.NARG.NE.1).OR. 863 - - (NARG.EQ.1.AND.MODARG(1).NE.1))THEN 864 - PRINT *,' !!!!!! DLCCAL WARNING : Incorrect list'// 865 - - ' of arguments for PLOT_DRIFT_AREA; no plot.' 866 - RETURN 867 - ENDIF 868 - * See whether there is a title. 869 - IF(NARG.EQ.1)THEN 870 - CALL STRBUF('READ',NINT(ARG(1)),TITLE,NC,IFAIL1) 871 - ELSEIF(CELLID.EQ.' ')THEN 872 - TITLE='Layout of the cell' 873 - NC=18 874 - ELSE 875 - TITLE=CELLID 876 - NC=LEN(CELLID) 877 - ENDIF 878 - * Plot the frame. 879 - CALL GRASET(DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX) 880 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX,TITLE(1:NC)) 881 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 882 - *** Return the status code and other pieces of information. 883 - ELSEIF(IPROC.EQ.-520)THEN 884 - IF(NARG.LT.2.OR.2*(NARG/2).NE.NARG)THEN 885 - PRINT *,' !!!!!! DLCCAL WARNING : DRIFT_INFORMATION'// 886 - - ' received an odd number of arguments;'// 887 - - ' procedure not called.' 888 - RETURN 889 - ELSEIF(NU.LT.1)THEN 1 676 P=DRIFTCAL D=DLCCAL 10 PAGE1050 890 - PRINT *,' !!!!!! DLCCAL WARNING : The current'// 891 - - ' drift line has no steps; DRIFT_INFORMATION'// 892 - - ' not executed.' 893 - RETURN 894 - ENDIF 895 - * Loop over the options. 896 - DO 80 I=1,NARG-1,2 897 - * Check the argument type. 898 - IF(MODARG(I).NE.1)THEN 899 - PRINT *,' !!!!!! DLCCAL WARNING : Argument ',I,' of', 900 - - ' DRIFT_INFORMATION is not of type String; no', 901 - - ' value returned.' 902 - GOTO 80 903 - ENDIF 904 - * Fetch option. 905 - CALL STRBUF('READ',NINT(ARG(I)),TITLE,NC,IFAIL1) 906 - IF(IFAIL1.NE.0)THEN 907 - PRINT *,' !!!!!! DLCCAL WARNING : Error retrieving'// 908 - - ' the DRIFT_INFORMATION option.' 909 - GOTO 80 910 - ENDIF 911 - IF(NC.GE.1)CALL CLTOU(TITLE(1:NC)) 912 - * Check we can return a value. 913 - IF(ARGREF(I+1,1).GE.2)THEN 914 - PRINT *,' !!!!!! DLCCAL WARNING : Can not return'// 915 - - ' a value for '//TITLE(1:NC)//' because the'// 916 - - ' following argument is not modifiable.' 917 - GOTO 80 918 - ENDIF 919 - * Delete old contents of return variable. 920 - CALL ALGREU(NINT(ARG(I+1)),MODARG(I+1),ARGREF(I+1,1)) 921 - * Total drift time. 922 - IF(INPCMX(TITLE(1:NC),'DR#IFT-T#IME')+ 923 - - INPCMX(TITLE(1:NC),'TIME').NE.0)THEN 924 - ARG(I+1)=REAL(TU(NU)) 925 - MODARG(I+1)=2 926 - * Charge of the particle. 927 - ELSEIF(INPCMX(TITLE(1:NC),'CHA#RGE').NE.0)THEN 928 - ARG(I+1)=QPCHAR 929 - MODARG(I+1)=2 930 - * Particle being drifted. 931 - ELSEIF(INPCMX(TITLE(1:NC),'PART#ICLE').NE.0)THEN 932 - IF(IPTYPE.EQ.1)THEN 933 - CALL STRBUF('STORE',IAUX,'electron',8,IFAIL1) 934 - ARG(I+1)=REAL(IAUX) 935 - MODARG(I+1)=1 936 - ELSEIF(IPTYPE.EQ.2)THEN 937 - CALL STRBUF('STORE',IAUX,'ion',3,IFAIL1) 938 - ARG(I+1)=REAL(IAUX) 939 - MODARG(I+1)=1 940 - ELSE 941 - CALL STRBUF('STORE',IAUX,'unknown',7,IFAIL1) 942 - ARG(I+1)=REAL(IAUX) 943 - MODARG(I+1)=1 944 - ENDIF 945 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// 946 - - ' Error storing the DRIFT_INFORMATION result.' 947 - * Integration technique used. 948 - ELSEIF(INPCMX(TITLE(1:NC),'TECH#IQUE').NE.0)THEN 949 - IF(IPTECH.EQ.1)THEN 950 - CALL STRBUF('STORE',IAUX,'Runge-Kutta-Fehlberg', 951 - - 20,IFAIL1) 952 - ARG(I+1)=REAL(IAUX) 953 - MODARG(I+1)=1 954 - ELSEIF(IPTECH.EQ.2)THEN 955 - CALL STRBUF('STORE',IAUX,'Monte-Carlo',11,IFAIL1) 956 - ARG(I+1)=REAL(IAUX) 957 - MODARG(I+1)=1 958 - ELSEIF(IPTECH.EQ.3)THEN 959 - CALL STRBUF('STORE',IAUX,'vacuum',6,IFAIL1) 960 - ARG(I+1)=REAL(IAUX) 961 - MODARG(I+1)=1 962 - ELSE 963 - CALL STRBUF('STORE',IAUX,'unknown',7,IFAIL1) 964 - ARG(I+1)=REAL(IAUX) 965 - MODARG(I+1)=1 966 - ENDIF 967 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// 968 - - ' Error storing the DRIFT_INFORMATION result.' 969 - * Numeric status code. 970 - ELSEIF(INPCMX(TITLE(1:NC),'STAT#US-#CODE').NE.0)THEN 971 - ARG(I+1)=REAL(ISTAT) 972 - MODARG(I+1)=2 973 - * Electrode group. 974 - ELSEIF(INPCMX(TITLE(1:NC),'ELEC#TRODE').NE.0)THEN 975 - CALL DLCISW(ISTAT,ISW) 976 - ARG(I+1)=REAL(ISW) 977 - MODARG(I+1)=2 978 - * String status code. 979 - ELSEIF(INPCMX(TITLE(1:NC),'STAT#US-#STRING').NE.0)THEN 980 - CALL DLCSTF(ISTAT,OPT,NCOPT) 981 - CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) 982 - ARG(I+1)=REAL(IAUX) 983 - MODARG(I+1)=1 984 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// 985 - - ' Error storing the DRIFT_INFORMATION result.' 986 - * Number of steps. 987 - ELSEIF(INPCMX(TITLE(1:NC),'STEP#S').NE.0)THEN 988 - ARG(I+1)=REAL(NU) 989 - MODARG(I+1)=2 990 - * Path length. 991 - ELSEIF(INPCMX(TITLE(1:NC),'PATH-#LENGTH')+ 992 - - INPCMX(TITLE(1:NC),'LENGTH').NE.0)THEN 993 - ARG(I+1)=0.0 994 - DO 70 J=2,NU 995 - IF(POLAR)THEN 1 676 P=DRIFTCAL D=DLCCAL 11 PAGE1051 996 - CALL CF2RTC(XU(J-1),YU(J-1),XPOS1,YPOS1,1) 997 - CALL CF2RTC(XU(J) ,YU(J) ,XPOS2,YPOS2,1) 998 - ARG(I+1)=ARG(I+1)+SQRT((XPOS2-XPOS1)**2+ 999 - - (YPOS2-YPOS1)**2+(ZU(J)-ZU(J-1))**2) 1000 - ELSE 1001 - ARG(I+1)=ARG(I+1)+SQRT((XU(J)-XU(J-1))**2+ 1002 - - (YU(J)-YU(J-1))**2+(ZU(J)-ZU(J-1))**2) 1003 - ENDIF 1004 - 70 CONTINUE 1005 - MODARG(I+1)=2 1006 - * Start/end points. 1007 - ELSEIF(INPCMX(TITLE(1:NC),'X-ST#ART')+ 1008 - - INPCMX(TITLE(1:NC),'X_ST#ART')+ 1009 - - INPCMX(TITLE(1:NC),'XST#ART').NE.0)THEN 1010 - ARG(I+1)=XU(1) 1011 - MODARG(I+1)=2 1012 - ELSEIF(INPCMX(TITLE(1:NC),'X-END')+ 1013 - - INPCMX(TITLE(1:NC),'X_END')+ 1014 - - INPCMX(TITLE(1:NC),'XEND').NE.0)THEN 1015 - ARG(I+1)=XU(NU) 1016 - MODARG(I+1)=2 1017 - ELSEIF(INPCMX(TITLE(1:NC),'Y-START')+ 1018 - - INPCMX(TITLE(1:NC),'Y_ST#ART')+ 1019 - - INPCMX(TITLE(1:NC),'YST#ART').NE.0)THEN 1020 - ARG(I+1)=YU(1) 1021 - MODARG(I+1)=2 1022 - ELSEIF(INPCMX(TITLE(1:NC),'Y-END')+ 1023 - - INPCMX(TITLE(1:NC),'Y_END')+ 1024 - - INPCMX(TITLE(1:NC),'YEND').NE.0)THEN 1025 - ARG(I+1)=YU(NU) 1026 - MODARG(I+1)=2 1027 - ELSEIF(INPCMX(TITLE(1:NC),'Z-START')+ 1028 - - INPCMX(TITLE(1:NC),'Z_ST#ART')+ 1029 - - INPCMX(TITLE(1:NC),'ZST#ART').NE.0)THEN 1030 - ARG(I+1)=ZU(1) 1031 - MODARG(I+1)=2 1032 - ELSEIF(INPCMX(TITLE(1:NC),'Z-END')+ 1033 - - INPCMX(TITLE(1:NC),'Z_END')+ 1034 - - INPCMX(TITLE(1:NC),'ZEND').NE.0)THEN 1035 - ARG(I+1)=ZU(NU) 1036 - MODARG(I+1)=2 1037 - * Unknown things. 1038 - ELSE 1039 - PRINT *,' !!!!!! DLCCAL WARNING : Unknown item "'// 1040 - - TITLE(1:NC)//'" received ; no return value.' 1041 - ENDIF 1042 - 80 CONTINUE 1043 - *** Interpolate in a track. 1044 - ELSEIF(IPROC.EQ.-524)THEN 1045 - * Check the arguments. 1046 - IF(NARG.LT.4.OR.NARG.GT.9.OR. 1047 - - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR.MODARG(3).NE.2.OR. 1048 - - (NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. 1049 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. 1050 - - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. 1051 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. 1052 - - (NARG.GE.8.AND.ARGREF(8,1).GE.2).OR. 1053 - - (NARG.GE.9.AND.ARGREF(9,1).GE.2))THEN 1054 - PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// 1055 - - ' INTERPOLATE_TRACK of wrong type or not'// 1056 - - ' modifiable; not executed.' 1057 - RETURN 1058 - ENDIF 1059 - * Variables already in use ? 1060 - DO 330 ISTR=4,NARG 1061 - CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 1062 - 330 CONTINUE 1063 - * Perform the interpolation. 1064 - CALL DLCTRI(ARG(1),ARG(2),ARG(3), 1065 - - ARG(5),ICL,ARG(6),ARG(7),ARG(8),ARG(9), 1066 - - NARG.GE.6,NARG.GE.7,NARG.GE.8,IFAIL) 1067 - IF(IFAIL.NE.0)THEN 1068 - PRINT *,' !!!!!! DLCCAL WARNING : Interpolating the'// 1069 - - ' track failed; no values returned.' 1070 - DO 340 ISTR=4,NARG 1071 - MODARG(ISTR)=0 1072 - 340 CONTINUE 1073 - RETURN 1074 - ENDIF 1075 - * Return status code. 1076 - IF(NARG.GE.4)THEN 1077 - CALL DLCSTF(ICL,OPT,NCOPT) 1078 - CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) 1079 - ARG(4)=REAL(IAUX) 1080 - MODARG(4)=1 1081 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// 1082 - - ' Error storing the status for INTERPOLATE_TRACK.' 1083 - ENDIF 1084 - * Set the modes of the arguments. 1085 - MODARG(5)=2 1086 - MODARG(6)=2 1087 - MODARG(7)=2 1088 - MODARG(8)=2 1089 - MODARG(9)=2 1090 - *** Avalanche. 1091 - ELSEIF(IPROC.EQ.-525)THEN 1092 - IF(NARG.LT.1.OR.NARG.GT.2.OR. 1093 - - (NARG.GE.1.AND.ARGREF(1,1).GE.2).OR. 1094 - - (NARG.GE.2.AND.ARGREF(2,1).GE.2))THEN 1095 - PRINT *,' !!!!!! DLCCAL WARNING : Incorrect set of'// 1096 - - ' arguments for RND_MULTIPLICATION; not executed.' 1097 - RETURN 1098 - ENDIF 1099 - * Call the routine. 1100 - CALL DLCMCT(NETOT,NITOT) 1101 - * Clear the return space. 1 676 P=DRIFTCAL D=DLCCAL 12 PAGE1052 1102 - DO 60 I=1,NARG 1103 - CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 1104 - 60 CONTINUE 1105 - * Return the results. 1106 - IF(NARG.GE.1)THEN 1107 - ARG(1)=REAL(NETOT) 1108 - MODARG(1)=2 1109 - ENDIF 1110 - IF(NARG.GE.2)THEN 1111 - ARG(2)=REAL(NITOT) 1112 - MODARG(2)=2 1113 - ENDIF 1114 - *** Velocity vector for electrons. 1115 - ELSEIF(IPROC.EQ.-526)THEN 1116 - IF(NARG.LT.6.OR.NARG.GT.7.OR. 1117 - - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR.MODARG(3).NE.2.OR. 1118 - - ARGREF(4,1).GE.2.OR.ARGREF(5,1).GE.2.OR. 1119 - - ARGREF(6,1).GE.2.OR. 1120 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2))THEN 1121 - PRINT *,' !!!!!! DLCCAL WARNING : Incorrect set of'// 1122 - - ' arguments for ELECTRON_VELOCITY; not executed.' 1123 - RETURN 1124 - * Make sure there are drift velocities. 1125 - ELSEIF(.NOT.GASOK(1))THEN 1126 - PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// 1127 - - ' for electrons is not defined ; not executed.' 1128 - RETURN 1129 - ENDIF 1130 - * Clear the return space. 1131 - CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 1132 - CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) 1133 - CALL ALGREU(NINT(ARG(6)),MODARG(6),ARGREF(6,1)) 1134 - IF(NARG.GE.7)CALL ALGREU(NINT(ARG(7)),MODARG(7),ARGREF(7,1)) 1135 - * Evaluate the velocity. 1136 - CALL DLCVEL(DBLE(ARG(1)),DBLE(ARG(2)),DBLE(ARG(3)), 1137 - - F0,-1.0,1,ILOC) 1138 - * Return the arguments. 1139 - ARG(4)=REAL(F0(1)) 1140 - ARG(5)=REAL(F0(2)) 1141 - ARG(6)=REAL(F0(3)) 1142 - MODARG(4)=2 1143 - MODARG(5)=2 1144 - MODARG(6)=2 1145 - IF(NARG.GE.7)THEN 1146 - IF(ILOC.EQ.-10)THEN 1147 - CALL STRBUF('STORE',IAUX, 1148 - - 'Unknown potential',17,IFAIL1) 1149 - ELSEIF(ILOC.EQ.-5)THEN 1150 - CALL STRBUF('STORE',IAUX, 1151 - - 'In a material',13,IFAIL1) 1152 - ELSEIF(ILOC.EQ.-6)THEN 1153 - CALL STRBUF('STORE',IAUX, 1154 - - 'Outside mesh',12,IFAIL1) 1155 - ELSEIF(ILOC.LT.0)THEN 1156 - CALL STRBUF('STORE',IAUX, 1157 - - 'Outside plane',13,IFAIL1) 1158 - ELSEIF(ILOC.EQ.0)THEN 1159 - CALL STRBUF('STORE',IAUX, 1160 - - 'Normal',6,IFAIL1) 1161 - ELSEIF(ILOC.LE.NWIRE)THEN 1162 - CALL STRBUF('STORE',IAUX,'In an '// 1163 - - WIRTYP(ILOC)//' wire',12,IFAIL1) 1164 - ELSE 1165 - CALL STRBUF('STORE',IAUX,'Unknown',7,IFAIL1) 1166 - ENDIF 1167 - ARG(7)=REAL(IAUX) 1168 - MODARG(7)=1 1169 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING : '// 1170 - - 'Error storing a string for ELECTRON_VELOCITY.' 1171 - ENDIF 1172 - *** Velocity vector for ions. 1173 - ELSEIF(IPROC.EQ.-527)THEN 1174 - IF(NARG.LT.6.OR.NARG.GT.7.OR. 1175 - - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR.MODARG(3).NE.2.OR. 1176 - - ARGREF(4,1).GE.2.OR.ARGREF(5,1).GE.2.OR. 1177 - - ARGREF(6,1).GE.2.OR. 1178 - - (NARG.GE.7.AND.ARGREF(7,1).GE.2))THEN 1179 - PRINT *,' !!!!!! DLCCAL WARNING : Incorrect set of'// 1180 - - ' arguments for ION_VELOCITY; not executed.' 1181 - RETURN 1182 - * Make sure there are drift velocities. 1183 - ELSEIF(.NOT.GASOK(2))THEN 1184 - PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// 1185 - - ' for ions is not defined ; not executed.' 1186 - RETURN 1187 - ENDIF 1188 - * Clear the return space. 1189 - CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 1190 - CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) 1191 - CALL ALGREU(NINT(ARG(6)),MODARG(6),ARGREF(6,1)) 1192 - IF(NARG.GE.7)CALL ALGREU(NINT(ARG(7)),MODARG(7),ARGREF(7,1)) 1193 - * Evaluate the velocity. 1194 - CALL DLCVEL(DBLE(ARG(1)),DBLE(ARG(2)),DBLE(ARG(3)), 1195 - - F0,+1.0,2,ILOC) 1196 - * Return the arguments. 1197 - ARG(4)=REAL(F0(1)) 1198 - ARG(5)=REAL(F0(2)) 1199 - ARG(6)=REAL(F0(3)) 1200 - MODARG(4)=2 1201 - MODARG(5)=2 1202 - MODARG(6)=2 1203 - IF(NARG.GE.7)THEN 1204 - IF(ILOC.EQ.-10)THEN 1205 - CALL STRBUF('STORE',IAUX, 1206 - - 'Unknown potential',17,IFAIL1) 1207 - ELSEIF(ILOC.EQ.-5)THEN 1 676 P=DRIFTCAL D=DLCCAL 13 PAGE1053 1208 - CALL STRBUF('STORE',IAUX, 1209 - - 'In a material',13,IFAIL1) 1210 - ELSEIF(ILOC.EQ.-6)THEN 1211 - CALL STRBUF('STORE',IAUX, 1212 - - 'Outside mesh',12,IFAIL1) 1213 - ELSEIF(ILOC.LT.0)THEN 1214 - CALL STRBUF('STORE',IAUX, 1215 - - 'Outside plane',13,IFAIL1) 1216 - ELSEIF(ILOC.EQ.0)THEN 1217 - CALL STRBUF('STORE',IAUX, 1218 - - 'Normal',6,IFAIL1) 1219 - ELSEIF(ILOC.LE.NWIRE)THEN 1220 - CALL STRBUF('STORE',IAUX,'In an '// 1221 - - WIRTYP(ILOC)//' wire',12,IFAIL1) 1222 - ELSE 1223 - CALL STRBUF('STORE',IAUX,'Unknown',7,IFAIL1) 1224 - ENDIF 1225 - ARG(7)=REAL(IAUX) 1226 - MODARG(7)=1 1227 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING : '// 1228 - - 'Error storing a string for ION_VELOCITY.' 1229 - ENDIF 1230 - *** Print the current drift line. 1231 - ELSEIF(IPROC.EQ.-528)THEN 1232 - * Check arguments. 1233 - IF(NARG.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// 1234 - - ' PRINT_DRIFT_LINE takes no arguments ; arguments'// 1235 - - ' ignored.' 1236 - * Print a header. 1237 - WRITE(LUNOUT,'('' CURRENT DRIFT LINE: ''/)') 1238 - IF(IPTYPE.EQ.1)THEN 1239 - WRITE(LUNOUT,'('' Particle: electron'')') 1240 - ELSEIF(IPTYPE.EQ.2)THEN 1241 - WRITE(LUNOUT,'('' Particle: ion'')') 1242 - ELSE 1243 - WRITE(LUNOUT,'('' Particle: not set'')') 1244 - ENDIF 1245 - CALL OUTFMT(QPCHAR,2,AUX1,NC1,'LEFT') 1246 - WRITE(LUNOUT,'('' Charge: '',A)') AUX1(1:NC1) 1247 - IF(IPTECH.EQ.1)THEN 1248 - WRITE(LUNOUT,'('' Technique: Runge Kutta Fehlberg'')') 1249 - ELSEIF(IPTECH.EQ.2)THEN 1250 - WRITE(LUNOUT,'('' Technique: Monte Carlo'')') 1251 - ELSEIF(IPTECH.EQ.3)THEN 1252 - WRITE(LUNOUT,'('' Technique: vacuum drift'')') 1253 - ELSE 1254 - WRITE(LUNOUT,'('' Technique: not set'')') 1255 - ENDIF 1256 - CALL DLCSTF(ISTAT,OPT,NCOPT) 1257 - WRITE(LUNOUT,'('' Status: '',A)') OPT(1:NCOPT) 1258 - CALL OUTFMT(REAL(NU),2,AUX1,NC1,'LEFT') 1259 - WRITE(LUNOUT,'('' Steps: '',A)') AUX1(1:NC1) 1260 - * Print also the path, if non-zero. 1261 - IF(NU.GT.0.AND.POLAR)THEN 1262 - WRITE(LUNOUT,'(/'' Path:''/ 1263 - - 16X,''r'',14X,''phi'',16X,''z'',13X,''time''/ 1264 - - 13X,''[cm]'',8X,''[degrees]'', 1265 - - 13X,''[cm]'',7X,''[microsec]''/)') 1266 - ELSEIF(NU.GT.0)THEN 1267 - WRITE(LUNOUT,'(/'' Path:''/ 1268 - - 16X,''x'',16X,''y'',16X,''z'',13X,''time''/ 1269 - - 13X,''[cm]'',13X,''[cm]'', 1270 - - 13X,''[cm]'',7X,''[microsec]''/)') 1271 - ENDIF 1272 - DO 100 I=1,NU 1273 - IF(POLAR)THEN 1274 - CALL CF2RTP(XU(I),YU(I),XPOS1,YPOS1,1) 1275 - ELSE 1276 - XPOS1=XU(I) 1277 - YPOS1=YU(I) 1278 - ENDIF 1279 - CALL OUTFMT(REAL(XPOS1),2,AUX1,NC1,'RIGHT') 1280 - CALL OUTFMT(REAL(YPOS1),2,AUX2,NC2,'RIGHT') 1281 - CALL OUTFMT(REAL(ZU(I)),2,AUX3,NC3,'RIGHT') 1282 - CALL OUTFMT(REAL(TU(I)),2,AUX4,NC4,'RIGHT') 1283 - WRITE(LUNOUT,'(4(2X,A15))') AUX1,AUX2,AUX3,AUX4 1284 - 100 CONTINUE 1285 - *** Unknown drift line operation. 1286 - ELSE 1287 - PRINT *,' !!!!!! DLCCAL WARNING : Unknown procedure code'// 1288 - - ' received; nothing done.' 1289 - IFAIL=1 1290 - RETURN 1291 - ENDIF 1292 - *** Seems to have worked. 1293 - IFAIL=0 1294 - END 677 GARFIELD ================================================== P=DRIFTCAL D=DLCFMP 1 ============================ 0 + +DECK,DLCFMP. 1 - SUBROUTINE DLCFMP(XX0,YY0,ZZ0,XX1,YY1,ZZ1,ILOC,Q,ITYPE) 2 - *----------------------------------------------------------------------- 3 - * DLCFMP - Terminates drift line calculation by making a last step 4 - * to the boundary of the mesh or the drift medium. 5 - * VARIABLES : (XX0,YY0,ZZ0): Last point in drift medium. 6 - * (XX1,YY1,ZZ1): Estimated step, outside drift medium. 7 - * (X0,Y0,Z0) : Final point just inside medium 8 - * (X1,Y1,Z1) : Final point just outside medium 9 - * FF0 : Drift velocity at (XX0,YY0,ZZ0) 10 - * F0 : Drift velocity at (X0,Y0,Z0) 11 - * (Last changed on 3/10/98.) 12 - *----------------------------------------------------------------------- 13 - implicit none 14.- +SEQ,DIMENSIONS. 1 677 P=DRIFTCAL D=DLCFMP 2 PAGE1054 15.- +SEQ,DRIFTLINE. 16.- +SEQ,CELLDATA. 17.- +SEQ,PRINTPLOT. 18 - INTEGER NBISEC 19 - PARAMETER(NBISEC=20) 20 - INTEGER ILOC,ITYPE,ILOC0,ILOC1,ILOCM,ILOCS,I,ILOCVF,IFAIL,IVOL 21 - REAL Q,EX,EY,EZ,ETOT,VOLT,EOVERM 22 - DOUBLE PRECISION XX0,YY0,ZZ0,XX1,YY1,ZZ1,X0,Y0,Z0,X1,Y1,Z1, 23 - - XM,YM,ZM,POS(3),FF0(3),F0(3),ACC(3),SPEED,ACCEL,STEP, 24 - - XOLD,YOLD,ZOLD 25 - COMMON /VFUCOM/ EOVERM,ILOCVF 26 - *** Identify this routine if requested. 27 - IF(LIDENT)PRINT *,' /// ROUTINE DLCFMP ///' 28 - *** Ensure there is a previous stored step. 29 - IF(NU.LE.0)THEN 30 - PRINT *,' ###### DLCFMP ERROR : Called at first step;'// 31 - - ' program bug, please report.' 32 - ISTAT=-3 33 - RETURN 34 - ENDIF 35 - *** Check we may still add points. 36 - IF(NU.GE.MXLIST)THEN 37 - ISTAT=-2 38 - IF(LDEBUG)PRINT *,' ++++++ DLCFMP DEBUG : Last point'// 39 - - ' not added because MXLIST is reached.' 40 - RETURN 41 - ENDIF 42 - *** Ensure we got an appropriate location code. 43 - IF(ILOC.NE.-5.AND.ILOC.NE.-6)THEN 44 - PRINT *,' ###### DLCFMP ERROR : Called for location'// 45 - - ' code ',ILOC,'; program bug, please report.' 46 - ISTAT=-3 47 - RETURN 48 - ENDIF 49 - *** Initialise the bisection loop. 50 - X0=XX0 51 - Y0=YY0 52 - Z0=ZZ0 53 - X1=XX1 54 - Y1=YY1 55 - Z1=ZZ1 56 - CALL EFIELD(REAL(X0),REAL(Y0),REAL(Z0),EX,EY,EZ,ETOT,VOLT,0, 57 - - ILOC0) 58 - CALL EFIELD(REAL(X1),REAL(Y1),REAL(Z1),EX,EY,EZ,ETOT,VOLT,0, 59 - - ILOC1) 60 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCFMP DEBUG : Starting'', 61 - - '' from (x,y,z)='',3E15.8,'' loc='',I5/34X, 62 - - '' to (x,y,z)='',3E15.8,'' loc='',I5)') X0,Y0,Z0,ILOC0, 63 - - X1,Y1,Z1,ILOC1 64 - IF(ILOC0.NE.0.OR.ILOC1.EQ.0)THEN 65 - IF(LDEBUG)PRINT *,' ++++++ DLCFMP DEBUG : Called but'// 66 - - ' ILOC=',ILOC0,ILOC1,' returning ISTAT=-3.' 67 - ISTAT=-3 68 - RETURN 69 - ENDIF 70 - *** Perform some bisections. 71 - ILOCS=ILOC1 72 - DO 10 I=1,NBISEC 73 - * Quit bisection when interval becomes too small. 74 - IF(ABS(X1-X0).LE.1D-6*(ABS(X0)+ABS(X1)).AND. 75 - - ABS(Y1-Y0).LE.1D-6*(ABS(Y0)+ABS(Y1)).AND. 76 - - ABS(Z1-Z0).LE.1D-6*(ABS(Z0)+ABS(Z1)))THEN 77 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCFMP DEBUG :'', 78 - - '' Bisection ended at loop '',I5,'' (interval'', 79 - - '' too small).'')') I 80 - GOTO 20 81 - ENDIF 82 - * Middle point. 83 - XM=0.5*(X0+X1) 84 - YM=0.5*(Y0+Y1) 85 - ZM=0.5*(Z0+Z1) 86 - * Evaluate field. 87 - CALL EFIELD(REAL(XM),REAL(YM),REAL(ZM),EX,EY,EZ,ETOT,VOLT,0, 88 - - ILOCM) 89 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCFMP DEBUG : Bisection'', 90 - - '' at (x,y,z)='',3E15.8,'' loc='',I5)') XM,YM,ZM,ILOCM 91 - * Shift limits of the bisection. 92 - IF(ILOCM.EQ.0)THEN 93 - X0=XM 94 - Y0=YM 95 - Z0=ZM 96 - ELSE 97 - X1=XM 98 - Y1=YM 99 - Z1=ZM 100 - ILOCS=ILOCM 101 - ENDIF 102 - 10 CONTINUE 103 - * Maximum number of iterations reached. 104 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCFMP DEBUG :'', 105 - - '' Bisection ended at loop '',I5,'' (maximum number'', 106 - - '' of iterations).'')') NBISEC 107 - *** Calculate the drift velocity over the last step. 108 - 20 CONTINUE 109 - ** Normal drift, not in vacuum. 110 - IF(ITYPE.EQ.1.OR.ITYPE.EQ.2)THEN 111 - * Compute drift velocity at begin and end of the step. 112 - CALL DLCVEL(XX0,YY0,ZZ0,FF0,Q,ITYPE,ILOC0) 113 - CALL DLCVEL(X0,Y0,Z0,F0,Q,ITYPE,ILOC1) 114 - * Average if both are in a free area. 115 - IF(ILOC0.EQ.0.AND.ILOC1.EQ.0)THEN 116 - SPEED=SQRT((FF0(1)+F0(1))**2+(FF0(2)+F0(2))**2+ 117 - - (FF0(3)+F0(3))**2)/4 118 - * Or approximate with the last step only. 119 - ELSEIF(ILOC0.EQ.0)THEN 120 - SPEED=SQRT(FF0(1)**2+FF0(2)**2+FF0(3)**2) 1 677 P=DRIFTCAL D=DLCFMP 3 PAGE1055 121 - PRINT *,' ------ DLCFMP MESSAGE : Unable to compute'// 122 - - ' mean drift speed at last step; approximated.' 123 - * At least one should be OK. 124 - ELSE 125 - PRINT *,' !!!!!! DLCFMP WARNING : Unable to compute'// 126 - - ' drift speed at last step; aborted.' 127 - ISTAT=-3 128 - RETURN 129 - ENDIF 130 - ** Vacuum drift. 131 - ELSE 132 - * If there are already steps, estimate speed from the last step. 133 - IF(NU.GT.1)THEN 134 - IF(TU(NU)-TU(NU-1).GT.0)THEN 135 - FF0(1)=(XU(NU)-XU(NU-1))/(TU(NU)-TU(NU-1)) 136 - FF0(2)=(YU(NU)-YU(NU-1))/(TU(NU)-TU(NU-1)) 137 - FF0(3)=(ZU(NU)-ZU(NU-1))/(TU(NU)-TU(NU-1)) 138 - ELSE 139 - PRINT *,' !!!!!! DLCFMP WARNING : Drift speed'// 140 - - ' over previous step is 0; aborted.' 141 - ISTAT=-3 142 - RETURN 143 - ENDIF 144 - * Otherwise set speed to 0. 145 - ELSE 146 - FF0(1)=0 147 - FF0(2)=0 148 - FF0(3)=0 149 - ENDIF 150 - * Use speed and location to compute the acceleration. 151 - POS(1)=XX0 152 - POS(2)=YY0 153 - POS(3)=ZZ0 154 - ILOCVF=0 155 - CALL DLCVFU(0.0D0,POS,FF0,ACC) 156 - IF(ILOCVF.NE.0)THEN 157 - PRINT *,' !!!!!! DLCFMP WARNING : Unable to compute'// 158 - - ' acceleration over last step; aborted.' 159 - ISTAT=-3 160 - RETURN 161 - ENDIF 162 - * Estimate from these what the average speed for the last step is. 163 - SPEED=SQRT(FF0(1)**2+FF0(2)**2+FF0(3)**2) 164 - ACCEL=SQRT(ACC(1)**2+ACC(2)**2+ACC(3)**2) 165 - STEP=SQRT((X0-XX0)**2+(Y0-YY0)**2+(Z0-ZZ0)**2) 166 - SPEED=SPEED/2+SQRT(SPEED**2+2*ACCEL*STEP)/2 167 - ENDIF 168 - ** Check velocity. 169 - IF(SPEED.LE.0)THEN 170 - PRINT *,' !!!!!! DLCFMP WARNING : Drift line not properly'// 171 - - ' terminated because of zero drift field.' 172 - ISTAT=-3 173 - RETURN 174 - ENDIF 175 - *** Add the last step to the boundary. 176 - NU=NU+1 177 - XU(NU)=X0 178 - YU(NU)=Y0 179 - ZU(NU)=Z0 180 - *** And fill in the time for the last step. 181 - TU(NU)=TU(NU-1)+SQRT((XU(NU)-XU(NU-1))**2+ 182 - - (YU(NU)-YU(NU-1))**2+(ZU(NU)-ZU(NU-1))**2)/SPEED 183 - *** Assign the status code. 184 - CALL DLCSOL(X0,Y0,Z0,IVOL) 185 - IF(IVOL.LE.0)THEN 186 - ISTAT=ILOCS 187 - ELSE 188 - ISTAT=2*MXWIRE+IVOL 189 - ENDIF 190 - *** Check that the particle is still inside the drift area, clip if not. 191 - IF(XU(NU).LT.DDXMIN)ISTAT=ISTAT1 192 - IF(XU(NU).GT.DDXMAX)ISTAT=ISTAT2 193 - IF(YU(NU).LT.DDYMIN)ISTAT=ISTAT3 194 - IF(YU(NU).GT.DDYMAX)ISTAT=ISTAT4 195 - IF(ZU(NU).LT.DDZMIN)ISTAT=ISTAT5 196 - IF(ZU(NU).GT.DDZMAX)ISTAT=ISTAT6 197 - IF(ISTAT.NE.ILOCS)THEN 198 - XOLD=XU(NU) 199 - YOLD=YU(NU) 200 - ZOLD=ZU(NU) 201 - CALL CLIP3D(XU(NU-1), YU(NU-1), ZU(NU-1), 202 - - XU(NU), YU(NU), ZU(NU), 203 - - DBLE(DDXMIN),DBLE(DDYMIN),DBLE(DDZMIN), 204 - - DBLE(DDXMAX),DBLE(DDYMAX),DBLE(DDZMAX),IFAIL) 205 - IF(IFAIL.NE.0.OR.(XOLD.EQ.XU(NU-1).AND. 206 - - YOLD.EQ.YU(NU-1).AND.ZOLD.EQ.ZU(NU-1)))THEN 207 - NU=NU-1 208 - ELSE 209 - TU(NU)=TU(NU-1)+(TU(NU)-TU(NU-1))*SQRT( 210 - - ((XU(NU)-XU(NU-1))**2+(YU(NU)-YU(NU-1))**2+ 211 - - (ZU(NU)-ZU(NU-1))**2)/ 212 - - ((XOLD-XU(NU-1))**2+(YOLD-YU(NU-1))**2+ 213 - - (ZOLD-ZU(NU-1))**2)) 214 - ENDIF 215 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCFMP DEBUG : Area'', 216 - - '' left or solid entered, ISTAT='',I5)') ISTAT 217 - ENDIF 218 - *** Debugging output. 219 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCFMP DEBUG : NU='',I5/ 220 - - 5X,''Old step: '',3E12.5,'' location: '',I10/ 221 - - 5X,''End : '',3E12.5,'' location: '',I10/ 222 - - 5X,''New step: '',3E12.5,'' status: '',I10/ 223 - - 5X,''Speed : '',E12.5)') 224 - - NU,XX0,YY0,ZZ0,ILOC0,XX1,YY1,ZZ1,ILOC1,X0,Y0,Z0,ISTAT,SPEED 225 - END 1 678 GARFIELD ================================================== P=DRIFTCAL D=DLCISW 1 =================== PAGE1056 0 + +DECK,DLCISW. 1 - SUBROUTINE DLCISW(ISTAT,ISW) 2 - *----------------------------------------------------------------------- 3 - * DLCISW - Returns the sense wire number of the electrode that was hit 4 - * by a drift line with status code ISTAT. 5 - * (Last changed on 4/ 9/99.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,FIELDMAP. 11.- +SEQ,SOLIDS. 12 - INTEGER ISTAT,ISW,I 13 - *** Drift line left the area. 14 - IF(ISTAT.EQ.-1)THEN 15 - ISW=0 16 - * Too many steps. 17 - ELSEIF(ISTAT.EQ.-2)THEN 18 - ISW=0 19 - * Calculations failed. 20 - ELSEIF(ISTAT.EQ.-3)THEN 21 - ISW=0 22 - * Plane hit (for backwards compatibility). 23 - ELSEIF(ISTAT.EQ.-4)THEN 24 - ISW=0 25 - * Left drift medium. 26 - ELSEIF(ISTAT.EQ.-5)THEN 27 - ISW=0 28 - * Left the mesh. 29 - ELSEIF(ISTAT.EQ.-6)THEN 30 - ISW=0 31 - * Plane or tube hit (replaces the ISTAT = -4 code). 32 - ELSEIF(ISTAT.EQ.-11)THEN 33 - ISW=INDPLA(1) 34 - ELSEIF(ISTAT.EQ.-12)THEN 35 - ISW=INDPLA(2) 36 - ELSEIF(ISTAT.EQ.-13)THEN 37 - ISW=INDPLA(3) 38 - ELSEIF(ISTAT.EQ.-14)THEN 39 - ISW=INDPLA(4) 40 - ELSEIF(ISTAT.EQ.-15)THEN 41 - ISW=INDPLA(5) 42 - * Original copy of a wire. 43 - ELSEIF(ISTAT.GT.0.AND.ISTAT.LE.MXWIRE)THEN 44 - ISW=INDSW(ISTAT) 45 - * Wire replicas. 46 - ELSEIF(ISTAT.GT.MXWIRE.AND.ISTAT.LE.2*MXWIRE)THEN 47 - ISW=0 48 - * Solids. 49 - ELSEIF(ISTAT.GT.2*MXWIRE.AND.ISTAT.LE.2*MXWIRE+MXSOLI)THEN 50 - ISW=0 51 - DO 10 I=1,NWMAP 52 - IF(EWSTYP(I).EQ.SOLTYP(ISTAT-2*MXWIRE))ISW=INDEWS(I) 53 - 10 CONTINUE 54 - * Invalid status code. 55 - ELSE 56 - ISW=0 57 - ENDIF 58 - END 679 GARFIELD ================================================== P=DRIFTCAL D=DLCMIN 1 ============================ 0 + +DECK,DLCMIN. 1 - SUBROUTINE DLCMIN(XW,YW,X0,Y0,X1,Y1,DIST2,IFLAG) 2 - *----------------------------------------------------------------------- 3 - * DLCMIN - Minimizes the distance between a line segment and a point. 4 - * VARIABLES: (XW,YW) : Coordinates of the 'point' 5 - * (X0,Y0)-(X1,Y1): The track. 6 - * IFLAG : -1 minimum is located before (X0,Y0), 7 - * 0 " " " at an interior point, 8 - * +1 " " " behind (X1,Y1). 9 - * XINP0,XINP1 : Inner products. 10 - *----------------------------------------------------------------------- 11 - implicit none 12 - DOUBLE PRECISION X0,Y0,X1,Y1,DIST2,STEP2,XINP0,XINP1,XW,YW 13 - INTEGER IFLAG 14 - *** Compute the step length and check it is non-zero. 15 - STEP2=(X1-X0)**2+(Y1-Y0)**2 16 - *** Check these two are non-zero. 17 - IF(STEP2.LE.0.0)THEN 18 - IFLAG=0 19 - DIST2=MAX(0.0D0,(X1-XW)**2+(Y1-YW)**2) 20 - RETURN 21 - ENDIF 22 - *** Find the precise location of the smallest distance. 23 - XINP0=((X1-X0)*(XW-X0)+(Y1-Y0)*(YW-Y0)) 24 - XINP1=((X0-X1)*(XW-X1)+(Y0-Y1)*(YW-Y1)) 25 - IF(XINP0.LT.0.0D0)THEN 26 - IFLAG=-1 27 - DIST2=(XW-X0)**2+(YW-Y0)**2 28 - ELSEIF(XINP1.LT.0.0D0)THEN 29 - IFLAG=+1 30 - DIST2=(XW-X1)**2+(YW-Y1)**2 31 - ELSEIF(XINP1**2*((XW-X0)**2+(YW-Y0)**2).GT. 32 - - XINP0**2*((XW-X1)**2+(YW-Y1)**2))THEN 33 - IFLAG=0 34 - DIST2=(XW-X0)**2+(YW-Y0)**2-XINP0**2/STEP2 35 - ELSE 36 - IFLAG=0 37 - DIST2=(XW-X1)**2+(YW-Y1)**2-XINP1**2/STEP2 38 - ENDIF 39 - END 1 680 GARFIELD ================================================== P=DRIFTCAL D=DLCPAR 1 =================== PAGE1057 0 + +DECK,DLCPAR. 1 - SUBROUTINE DLCPAR 2 - *----------------------------------------------------------------------- 3 - * DLCPAR - Routine taking care of drift line integration parameters. 4 - * VARIABLES : 5 - * (Last changed on 19/ 5/99.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,DRIFTLINE. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,PARAMETERS. 12 - CHARACTER*40 STRDF2,STRMC 13 - INTEGER INPCMP,NMCR,INEXT,MXSTR,I,INPTYP,NWORD,IFAIL1,NINORR 14 - REAL TMCR,DMCR,EPSR,RDF2R,RTRAPR,STMAXR,EQTTRR,EQTASR,EQTCLR 15 - EXTERNAL INPCMP 16 - *** Get the number of words on the line. 17 - CALL INPNUM(NWORD) 18 - *** If there is only one argument. 19 - IF(NWORD.EQ.1)THEN 20 - IF(MDF2.EQ.0)THEN 21 - STRDF2='No special treatment' 22 - ELSEIF(MDF2.EQ.1)THEN 23 - STRDF2='Integrate distance/velocity' 24 - ELSEIF(MDF2.EQ.2)THEN 25 - STRDF2='Integrate distance/central velocity' 26 - ELSEIF(MDF2.EQ.3)THEN 27 - STRDF2='Take longitudinal size.' 28 - ELSEIF(MDF2.EQ.4)THEN 29 - STRDF2='Take largest cloud axis.' 30 - ELSE 31 - STRDF2='# Method not known #' 32 - ENDIF 33 - IF(MCMETH.EQ.0)THEN 34 - STRMC='Take constant time steps.' 35 - ELSEIF(MCMETH.EQ.1)THEN 36 - STRMC='Take constant distance steps.' 37 - ELSEIF(MCMETH.EQ.2)THEN 38 - STRMC='Simulate collisions.' 39 - ELSE 40 - STRMC='# Method not known #' 41 - ENDIF 42 - WRITE(LUNOUT,'(/ 43 - - '' RUNGE-KUTTA DRIFT LINE INTEGRATION PARAMETERS:''/ 44 - - '' Absolute accuracy for drift line'', 45 - - '' integration: '',E15.8,'' [cm]'')') EPSDIF 46 - IF(LSTMAX)THEN 47 - WRITE(LUNOUT,'( 48 - - '' Maximum length of an integration step:'', 49 - - '' '',E15.8,'' [cm]'')') STMAX 50 - ELSE 51 - WRITE(LUNOUT,'( 52 - - '' Maximum length of an integration'', 53 - - '' step: Unlimited'')') 54 - ENDIF 55 - WRITE(LUNOUT,'(/ 56 - - '' MONTE CARLO DRIFT LINE INTEGRATION PARAMETERS:''/ 57 - - '' Monte Carlo integration method: '', 58 - - '' '',A/ 59 - - '' Time interval between steps for'', 60 - - '' MC integration: '',E15.8,'' [microsec]''/ 61 - - '' Space interval between steps for'', 62 - - '' MC integration: '',E15.8,'' [cm]''/ 63 - - '' Number of collisions to be averaged'', 64 - - '' over: '',I15// 65 - - '' DRIFT LINE TERMINATION PARAMETERS:''/ 66 - - '' Distance at which particles are caught'', 67 - - '' (TRAP-RADIUS): '',F15.3,'' [wire radii]''/ 68 - - '' Skip the capture check for'', 69 - - '' repelling wires: '',L15/ 70 - - '' Abandon drift line at sharp kinks'', 71 - - '' (REJECT-KINKS): '',L15)') 72 - - STRMC,TMC,DMC,NMC,RTRAP,LREPSK,LKINK 73 - WRITE(LUNOUT,'(/ 74 - - '' DRIFT LINE INTERPOLATION PARAMETERS:''/ 75 - - '' Interpolation order: '', 76 - - '' '',I15/ 77 - - '' Compute (T) or abandon (F) if'', 78 - - '' interpolation fails: '',L15)') NINORD,LINCAL 79 - WRITE(LUNOUT,'(/ 80 - - '' DIFFUSION, AVALANCHE AND ATTACHMENT SUMMING'', 81 - - '' PARAMETERS:''/ 82 - - '' Cloud projection method for electrons'', 83 - - '' hitting a wire: '',A/ 84 - - '' Switch L+T diffusion integration method:'', 85 - - '' '',F15.3,'' [wire radii]''/ 86 - - '' Maximum stack depth for the diffusion'', 87 - - '' integration: '',I15/ 88 - - '' Maximum stack depth for the Townsend'', 89 - - '' integration: '',I15/ 90 - - '' Maximum stack depth for the attachment'', 91 - - '' integration: '',I15/ 92 - - '' Relative accuracy tolerance diffusion'', 93 - - '' integration: '',E15.8/ 94 - - '' Relative accuracy tolerance Townsend'', 95 - - '' integration: '',E15.8/ 96 - - '' Relative accuracy tolerance attachment'', 97 - - '' integration: '',E15.8/ 98 - - '' Compute multiplication over projected'', 99 - - '' drift line: '',L15)') 100 - - STRDF2,RDF2,MXDIFS,MXTWNS,MXATTS,EPSDFI,EPSTWI,EPSATI, 101 - - LAVPRO 102 - WRITE(LUNOUT,'(/ 103 - - '' ISOCHRONE PARAMETERS:''/ 104 - - '' Maximum relative distance to connect'', 105 - - '' isochrone parts: '',E15.8/ 1 680 P=DRIFTCAL D=DLCPAR 2 PAGE1058 106 - - '' Curves considered circular up to an'', 107 - - '' aspect ratio of: '',E15.8/ 108 - - '' Circular curves closed up to a relative'', 109 - - '' distance of: '',E15.8/ 110 - - '' Sort points on isochrones: '', 111 - - '' '',L15/ 112 - - '' Avoid crossings between isochrones and'', 113 - - '' drift lines: '',L15/ 114 - - '' Mark (T) or Draw (F) isochrones: '', 115 - - '' '',L15)') 116 - - EQTTHR,EQTASP,EQTCLS,LEQSRT,LEQCRS,LEQMRK 117 - ELSE 118 - INEXT=2 119 - DO 10 I=2,NWORD 120 - IF(I.LT.INEXT)GOTO 10 121 - * Diffusion stack size. 122 - IF(INPCMP(I,'DIFF#USION-ST#ACK-#DEPTH').NE.0)THEN 123 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN 124 - CALL INPMSG(I,'Should have an integer as arg.') 125 - INEXT=I+1 126 - ELSE 127 - CALL INPCHK(I+1,1,IFAIL1) 128 - CALL INPRDI(I+1,MXSTR,MXSTCK) 129 - IF(MXSTR.GE.1.AND.MXSTR.LE.MXSTCK)THEN 130 - MXDIFS=MXSTR 131 - ELSE 132 - CALL INPMSG(I+1, 133 - - 'Value not in range 1 -> MXSTCK') 134 - ENDIF 135 - INEXT=I+2 136 - ENDIF 137 - * Townsend stack size. 138 - ELSEIF(INPCMP(I,'TOWN#SEND-ST#ACK-#DEPTH').NE.0)THEN 139 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN 140 - CALL INPMSG(I,'Should have an integer as arg.') 141 - INEXT=I+1 142 - ELSE 143 - CALL INPCHK(I+1,1,IFAIL1) 144 - CALL INPRDI(I+1,MXSTR,MXSTCK) 145 - IF(MXSTR.GE.1.AND.MXSTR.LE.MXSTCK)THEN 146 - MXTWNS=MXSTR 147 - ELSE 148 - CALL INPMSG(I+1, 149 - - 'Value not in range 1 -> MXSTCK') 150 - ENDIF 151 - INEXT=I+2 152 - ENDIF 153 - * Attachment stack size. 154 - ELSEIF(INPCMP(I,'ATT#ACHMENT-ST#ACK-#DEPTH').NE.0)THEN 155 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN 156 - CALL INPMSG(I,'Should have an integer as arg.') 157 - INEXT=I+1 158 - ELSE 159 - CALL INPCHK(I+1,1,IFAIL1) 160 - CALL INPRDI(I+1,MXSTR,MXSTCK) 161 - IF(MXSTR.GE.1.AND.MXSTR.LE.MXSTCK)THEN 162 - MXATTS=MXSTR 163 - ELSE 164 - CALL INPMSG(I+1, 165 - - 'Value not in range 1 -> MXSTCK') 166 - ENDIF 167 - INEXT=I+2 168 - ENDIF 169 - * Diffusion accuracy. 170 - ELSEIF(INPCMP(I,'DIFF#USION-ACC#URACY').NE.0)THEN 171 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN 172 - CALL INPMSG(I,'Should have a numeric argument') 173 - INEXT=I+1 174 - ELSE 175 - CALL INPCHK(I+1,2,IFAIL1) 176 - CALL INPRDR(I+1,EPSR,1.0E-3) 177 - IF(EPSR.GT.0.0.AND.IFAIL1.EQ.0)THEN 178 - EPSDFI=EPSR 179 - ELSE 180 - CALL INPMSG(I+1, 181 - - 'This value must be positive. ') 182 - ENDIF 183 - INEXT=I+2 184 - ENDIF 185 - * Townsend accuracy. 186 - ELSEIF(INPCMP(I,'TOWN#SEND-ACC#URACY').NE.0)THEN 187 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN 188 - CALL INPMSG(I,'Should have a numeric argument') 189 - INEXT=I+1 190 - ELSE 191 - CALL INPCHK(I+1,2,IFAIL1) 192 - CALL INPRDR(I+1,EPSR,1.0E-3) 193 - IF(EPSR.GT.0.0.AND.IFAIL1.EQ.0)THEN 194 - EPSTWI=EPSR 195 - ELSE 196 - CALL INPMSG(I+1, 197 - - 'This value must be positive. ') 198 - ENDIF 199 - INEXT=I+2 200 - ENDIF 201 - * Attachment accuracy. 202 - ELSEIF(INPCMP(I,'ATT#ACHMENT-ACC#URACY').NE.0)THEN 203 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN 204 - CALL INPMSG(I,'Should have a numeric argument') 205 - INEXT=I+1 206 - ELSE 207 - CALL INPCHK(I+1,2,IFAIL1) 208 - CALL INPRDR(I+1,EPSR,1.0E-3) 209 - IF(EPSR.GT.0.AND.IFAIL1.EQ.0)THEN 210 - EPSATI=EPSR 211 - ELSE 1 680 P=DRIFTCAL D=DLCPAR 3 PAGE1059 212 - CALL INPMSG(I+1, 213 - - 'This value must be positive.') 214 - ENDIF 215 - INEXT=I+2 216 - ENDIF 217 - * Projected or true drift line. 218 - ELSEIF(INPCMP(I,'PROJ#ECTED-#PATH-#INTEGRATION').NE.0)THEN 219 - LAVPRO=.TRUE. 220 - ELSEIF(INPCMP(I,'TRUE-PATH-#INTEGRATION').NE.0)THEN 221 - LAVPRO=.FALSE. 222 - * Integration accuracy. 223 - ELSEIF(INPCMP(I,'INT#EGRATION-ACC#URACY')+ 224 - - INPCMP(I,'EPS#ILON').NE.0)THEN 225 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN 226 - CALL INPMSG(I,'Should have a numeric argument') 227 - INEXT=I+1 228 - ELSE 229 - CALL INPCHK(I+1,2,IFAIL1) 230 - CALL INPRDR(I+1,EPSR,1.0E-6) 231 - IF(IFAIL1.EQ.0.AND.EPSR.LE.0.0)THEN 232 - CALL INPMSG(I+1, 233 - - 'Integration accuracy not > 0. ') 234 - ELSEIF(IFAIL1.EQ.0)THEN 235 - EPSDIF=EPSR 236 - ENDIF 237 - INEXT=I+2 238 - ENDIF 239 - * MC integration time interval. 240 - ELSEIF(INPCMP(I,'M#ONTE-C#ARLO-T#IME-#INTERVAL')+ 241 - - INPCMP(I,'MC-T#IME-#INTERVAL').NE.0)THEN 242 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN 243 - CALL INPMSG(I,'Should have a numeric argument') 244 - INEXT=I+1 245 - ELSE 246 - CALL INPCHK(I+1,2,IFAIL1) 247 - CALL INPRDR(I+1,TMCR,0.001) 248 - IF(IFAIL1.EQ.0.AND.TMCR.LE.0.0)THEN 249 - CALL INPMSG(I+1, 250 - - 'Integration interval not > 0. ') 251 - ELSEIF(IFAIL1.EQ.0)THEN 252 - TMC=TMCR 253 - ENDIF 254 - MCMETH=0 255 - INEXT=I+2 256 - ENDIF 257 - * MC integration distance interval. 258 - ELSEIF(INPCMP(I,'M#ONTE-C#ARLO-D#ISTANCE-#INTERVAL')+ 259 - - INPCMP(I,'M#ONTE-C#ARLO-SP#ACE-#INTERVAL')+ 260 - - INPCMP(I,'M#ONTE-C#ARLO-SP#ATIAL-#INTERVAL')+ 261 - - INPCMP(I,'MC-D#ISTANCE-#INTERVAL')+ 262 - - INPCMP(I,'MC-SP#ACE-#INTERVAL')+ 263 - - INPCMP(I,'MC-SP#ATIAL-#INTERVAL').NE.0)THEN 264 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN 265 - CALL INPMSG(I,'Should have a numeric argument') 266 - INEXT=I+1 267 - ELSE 268 - CALL INPCHK(I+1,2,IFAIL1) 269 - CALL INPRDR(I+1,DMCR,0.1) 270 - IF(IFAIL1.EQ.0.AND.DMCR.LE.0.0)THEN 271 - CALL INPMSG(I+1, 272 - - 'Integration interval not > 0. ') 273 - ELSEIF(IFAIL1.EQ.0)THEN 274 - DMC=DMCR 275 - ENDIF 276 - MCMETH=1 277 - INEXT=I+2 278 - ENDIF 279 - * MC integration step averaging. 280 - ELSEIF(INPCMP(I,'M#ONTE-C#ARLO-ST#EPS')+ 281 - - INPCMP(I,'M#ONTE-C#ARLO-C#OLLISIONS')+ 282 - - INPCMP(I,'MC-ST#EPS')+ 283 - - INPCMP(I,'MC-C#OLLISIONS').NE.0)THEN 284 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN 285 - CALL INPMSG(I,'Should have an integer arg.') 286 - INEXT=I+1 287 - ELSE 288 - CALL INPCHK(I+1,1,IFAIL1) 289 - CALL INPRDI(I+1,NMCR,100) 290 - IF(IFAIL1.EQ.0.AND.NMCR.LE.0)THEN 291 - CALL INPMSG(I+1, 292 - - 'Number of collisions not > 0.') 293 - ELSEIF(IFAIL1.EQ.0)THEN 294 - NMC=NMCR 295 - ENDIF 296 - MCMETH=2 297 - INEXT=I+2 298 - ENDIF 299 - * Trap radius. 300 - ELSEIF(INPCMP(I,'TRAP-#RADIUS').NE.0)THEN 301 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN 302 - CALL INPMSG(I,'Should have a numeric argument') 303 - INEXT=I+1 304 - ELSE 305 - CALL INPCHK(I+1,2,IFAIL1) 306 - CALL INPRDR(I+1,RTRAPR,0.0) 307 - IF(IFAIL1.EQ.0.AND.RTRAPR.LE.0.0)THEN 308 - CALL INPMSG(I+1, 309 - - 'Number of wire radii not > 0. ') 310 - ELSEIF(IFAIL1.EQ.0)THEN 311 - RTRAP=RTRAPR 312 - ENDIF 313 - INEXT=I+2 314 - ENDIF 315 - * Maximum step length. 316 - ELSEIF(INPCMP(I,'MAX#IMUM-ST#EP-#LENGTH').NE.0)THEN 317 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN 1 680 P=DRIFTCAL D=DLCPAR 4 PAGE1060 318 - CALL INPMSG(I,'Should have a numeric argument') 319 - INEXT=I+1 320 - ELSE 321 - CALL INPCHK(I+1,2,IFAIL1) 322 - CALL INPRDR(I+1,STMAXR,0.0) 323 - IF(IFAIL1.EQ.0.AND.STMAXR.LE.0.0)THEN 324 - CALL INPMSG(I+1, 325 - - 'Step length must be > 0.') 326 - ELSEIF(IFAIL1.EQ.0)THEN 327 - STMAX=STMAXR 328 - LSTMAX=.TRUE. 329 - ENDIF 330 - INEXT=I+2 331 - ENDIF 332 - ELSEIF(INPCMP(I,'NOMAX#IMUM-ST#EP-#LENGTH').NE.0)THEN 333 - LSTMAX=.FALSE. 334 - * Check of repelling wires. 335 - ELSEIF(INPCMP(I,'CH#ECK-ALL-#WIRES').NE.0)THEN 336 - LREPSK=.FALSE. 337 - ELSEIF(INPCMP(I,'CH#ECK-ATT#RACTING-#WIRES').NE.0)THEN 338 - LREPSK=.TRUE. 339 - * Check for kinks. 340 - ELSEIF(INPCMP(I,'CH#ECK-K#INKS')+ 341 - - INPCMP(I,'K#INKS-CH#ECK')+ 342 - - INPCMP(I,'REJ#ECT-K#INKS')+ 343 - - INPCMP(I,'K#INKS-REJ#ECT').NE.0)THEN 344 - LKINK=.TRUE. 345 - ELSEIF(INPCMP(I,'NOCH#ECK-K#INKS')+ 346 - - INPCMP(I,'NOK#INKS-CH#ECK')+ 347 - - INPCMP(I,'NOREJ#ECT-K#INKS')+ 348 - - INPCMP(I,'NOK#INKS-REJ#ECT').NE.0)THEN 349 - LKINK=.FALSE. 350 - * Interpolation order. 351 - ELSEIF(INPCMP(I,'INT#ERPOLATION-ORD#ER').NE.0)THEN 352 - IF(I+1.GT.NWORD)THEN 353 - CALL INPMSG(I,'Should have an argument') 354 - ELSEIF(INPCMP(I+1,'LIN#EAR').NE.0)THEN 355 - NINORD=1 356 - INEXT=I+2 357 - ELSEIF(INPCMP(I+1,'QUAD#RATIC')+ 358 - - INPCMP(I+1,'PARA#BOLIC').NE.0)THEN 359 - NINORD=2 360 - INEXT=I+2 361 - ELSEIF(INPCMP(I+1,'CUB#IC').NE.0)THEN 362 - NINORD=3 363 - INEXT=I+2 364 - ELSEIF(INPTYP(I+1).NE.1)THEN 365 - CALL INPMSG(I,'Should have 1 integer argument') 366 - ELSE 367 - CALL INPCHK(I+1,1,IFAIL1) 368 - CALL INPRDI(I+1,NINORR,NINORD) 369 - IF(IFAIL1.EQ.0.AND.(NINORR.LT.1.OR. 370 - - NINORR.GT.10))THEN 371 - CALL INPMSG(I+1,'Not in the range [1,10].') 372 - ELSEIF(IFAIL1.EQ.0)THEN 373 - NINORD=NINORR 374 - ENDIF 375 - INEXT=I+2 376 - ENDIF 377 - * Compute or abandon drift lines which can't be interpolated. 378 - ELSEIF(INPCMP(I,'ABANDON-#IF-#INTERPOLATION-#FAILS').NE. 379 - - 0)THEN 380 - LINCAL=.FALSE. 381 - ELSEIF(INPCMP(I,'COMP#UTE-#IF-#INTERPOLATION-#FAILS').NE. 382 - - 0)THEN 383 - LINCAL=.TRUE. 384 - * Switch integration method. 385 - ELSEIF(INPCMP(I,'CL#OUD-PROJ#ECTION-DIST#ANCE').NE.0)THEN 386 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN 387 - CALL INPMSG(I,'Should have a numeric argument') 388 - INEXT=I+1 389 - ELSE 390 - CALL INPCHK(I+1,2,IFAIL1) 391 - CALL INPRDR(I+1,RDF2R,2.0) 392 - IF(IFAIL1.EQ.0.AND.RDF2R.LT.0.0)THEN 393 - CALL INPMSG(I+1, 394 - - 'Number of wire radii not > 0. ') 395 - ELSEIF(IFAIL1.EQ.0)THEN 396 - RDF2=RDF2R 397 - ENDIF 398 - INEXT=I+2 399 - ENDIF 400 - * Cloud projection method. 401 - ELSEIF(INPCMP(I,'CL#OUD-PROJ#ECTION-METH#OD').NE.0)THEN 402 - INEXT=I+2 403 - IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN 404 - CALL INPMSG(I,'Should have a numeric argument.') 405 - INEXT=I+1 406 - ELSEIF(INPCMP(I+1,'NO-#PROJECTION').NE.0)THEN 407 - MDF2=0 408 - ELSEIF(INPCMP(I+1,'INT#EGRATION').NE.0)THEN 409 - MDF2=1 410 - ELSEIF(INPCMP(I+1,'CENT#RAL-#VELOCITY-#INTEGRATION') 411 - - .NE.0)THEN 412 - MDF2=2 413 - ELSEIF(INPCMP(I+1,'LONG#ITUDINAL-#DIMENSION').NE.0)THEN 414 - MDF2=3 415 - ELSEIF(INPCMP(I+1,'LARG#EST-#DIMENSION').NE.0)THEN 416 - MDF2=4 417 - ELSE 418 - CALL INPMSG(I+1,'Not a known method.') 419 - ENDIF 420 - * Isochrone connection threshold. 421 - ELSEIF(INPCMP(I,'ISO#CHRONE-CONN#ECTION-#THRESHOLD').NE. 422 - - 0)THEN 423 - IF(I+1.GT.NWORD)THEN 1 680 P=DRIFTCAL D=DLCPAR 5 PAGE1061 424 - CALL INPMSG(I,'Should have a numeric argument.') 425 - INEXT=I+1 426 - ELSE 427 - CALL INPCHK(I+1,2,IFAIL1) 428 - CALL INPRDR(I+1,EQTTRR,EQTTHR) 429 - IF(EQTTRR.LE.0.0.OR.EQTTRR.GT.1)THEN 430 - CALL INPMSG(I+1, 431 - - 'Threshold not between 0 and 1.') 432 - ELSEIF(IFAIL1.EQ.0)THEN 433 - EQTTHR=EQTTRR 434 - ENDIF 435 - INEXT=I+2 436 - ENDIF 437 - ELSEIF(INPCMP(I,'NOISO#CHRONE-CONN#ECTION-#THRESHOLD').NE. 438 - - 0)THEN 439 - EQTTHR=1.0 440 - * Isochrone aspect ratio switch. 441 - ELSEIF(INPCMP(I,'ISO#CHRONE-ASP#ECT-#RATIO-#SWITCH').NE. 442 - - 0)THEN 443 - IF(I+1.GT.NWORD)THEN 444 - CALL INPMSG(I,'Should have a numeric argument.') 445 - INEXT=I+1 446 - ELSE 447 - CALL INPCHK(I+1,2,IFAIL1) 448 - CALL INPRDR(I+1,EQTASR,EQTASP) 449 - IF(EQTASR.LE.0.0)THEN 450 - CALL INPMSG(I+1, 451 - - 'Ratio should be larger than 0.') 452 - ELSEIF(IFAIL1.EQ.0)THEN 453 - EQTASP=EQTASR 454 - ENDIF 455 - INEXT=I+2 456 - ENDIF 457 - * Isochrone loop closing threshold. 458 - ELSEIF(INPCMP(I,'ISO#CHRONE-LOOP-#THRESHOLD').NE.0)THEN 459 - IF(I+1.GT.NWORD)THEN 460 - CALL INPMSG(I,'Should have a numeric argument.') 461 - INEXT=I+1 462 - ELSE 463 - CALL INPCHK(I+1,2,IFAIL1) 464 - CALL INPRDR(I+1,EQTCLR,EQTCLS) 465 - IF(EQTCLR.LE.0.0.OR.EQTCLR.GT.1)THEN 466 - CALL INPMSG(I+1, 467 - - 'Threshold not between 0 and 1.') 468 - ELSEIF(IFAIL1.EQ.0)THEN 469 - EQTCLS=EQTCLR 470 - ENDIF 471 - INEXT=I+2 472 - ENDIF 473 - * Sort isochrones or not. 474 - ELSEIF(INPCMP(I,'SORT-ISO#CHRONES').NE.0)THEN 475 - LEQSRT=.TRUE. 476 - ELSEIF(INPCMP(I,'NOSORT-ISO#CHRONES').NE.0)THEN 477 - LEQSRT=.FALSE. 478 - * Check crossings between isochrones and drift lines. 479 - ELSEIF(INPCMP(I,'CH#ECK-ISO#CHRONE-#CROSSINGS').NE.0)THEN 480 - LEQCRS=.TRUE. 481 - ELSEIF(INPCMP(I,'NOCH#ECK-ISO#CHRONE-#CROSSINGS').NE.0)THEN 482 - LEQCRS=.FALSE. 483 - * Mark isochrones. 484 - ELSEIF(INPCMP(I,'MARK-ISO#CHRONES').NE.0)THEN 485 - LEQMRK=.TRUE. 486 - ELSEIF(INPCMP(I,'DRAW-ISO#CHRONES').NE.0)THEN 487 - LEQMRK=.FALSE. 488 - * Anything else. 489 - ELSE 490 - CALL INPMSG(I,'Not a valid keyword; ignored. ') 491 - ENDIF 492 - 10 CONTINUE 493 - ENDIF 494 - CALL INPERR 495 - END 681 GARFIELD ================================================== P=DRIFTCAL D=DLCPLA 1 ============================ 0 + +DECK,DLCPLA. 1 - SUBROUTINE DLCPLA(IPLANE,Q,ITYPE) 2 - *----------------------------------------------------------------------- 3 - * DLCPLA - Terminates drift line calculation by making a last linear 4 - * step to the boundary identified by IPLANE. 5 - * VARIABLES : F3 : Drift-velocity at the one but last point, 6 - * assumed to be constant over the step. 7 - * SPEED : Magitude of F3. 8 - * (Last changed on 10/11/90.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,DRIFTLINE. 13.- +SEQ,CELLDATA. 14.- +SEQ,PRINTPLOT. 15 - INTEGER ILOC,IFAIL,ITYPE,IPLANE 16 - REAL Q 17 - DOUBLE PRECISION F3(3),SPEED 18 - *** Identify this routine if requested. 19 - IF(LIDENT)PRINT *,' /// ROUTINE DLCPLA ///' 20 - *** Calculate the drift velocity at the current last point. 21 - CALL DLCVEL(XU(NU),YU(NU),ZU(NU),F3,Q,ITYPE,ILOC) 22 - SPEED=SQRT(F3(1)**2+F3(2)**2) 23 - IF(SPEED.EQ.0.0D0.OR.ILOC.NE.0)THEN 24 - PRINT *,' !!!!!! DLCPLA WARNING : Drift line not properly'// 25 - - ' terminated because of zero drift field.' 26 - ISTAT=-3 27 - IF(ILOC.NE.0)ISTAT=ILOC 28 - RETURN 29 - ENDIF 30 - *** Check we may still add points. 1 681 P=DRIFTCAL D=DLCPLA 2 PAGE1062 31 - IF(NU.GE.MXLIST)THEN 32 - ISTAT=-2 33 - IF(LDEBUG)PRINT *,' ++++++ DLCPLA DEBUG : Last point'// 34 - - ' not added because MXLIST is reached.' 35 - RETURN 36 - ENDIF 37 - *** Debugging output. 38 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCPLA DEBUG : Entered'', 39 - - '' at NU='',I3,'' for IPLANE='',I2,''.'')') NU,IPLANE 40 - *** Check the components. 41 - IF((IPLANE.EQ.1.AND.F3(1).GE.0.0D0).OR. 42 - - (IPLANE.EQ.2.AND.F3(1).LE.0.0D0).OR. 43 - - (IPLANE.EQ.3.AND.F3(2).GE.0.0D0).OR. 44 - - (IPLANE.EQ.4.AND.F3(2).LE.0.0D0))THEN 45 - PRINT *,' !!!!!! DLCPLA WARNING : The particle moves away'// 46 - - ' from the boundary it is supposed to hit ; abandoned.' 47 - ISTAT=-3 48 - RETURN 49 - ENDIF 50 - *** Add the last step towards the plane. 51 - NU=NU+1 52 - IF(IPLANE.EQ.1)THEN 53 - XU(NU)=DBLE(DDXMIN) 54 - YU(NU)=YU(NU-1)+(F3(2)/F3(1))*(XU(NU)-XU(NU-1)) 55 - ZU(NU)=ZU(NU-1)+(F3(3)/F3(1))*(XU(NU)-XU(NU-1)) 56 - ISTAT=ISTAT1 57 - ELSEIF(IPLANE.EQ.2)THEN 58 - XU(NU)=DBLE(DDXMAX) 59 - YU(NU)=YU(NU-1)+(F3(2)/F3(1))*(XU(NU)-XU(NU-1)) 60 - ZU(NU)=ZU(NU-1)+(F3(3)/F3(1))*(XU(NU)-XU(NU-1)) 61 - ISTAT=ISTAT2 62 - ELSEIF(IPLANE.EQ.3)THEN 63 - YU(NU)=DBLE(DDYMIN) 64 - XU(NU)=XU(NU-1)+(F3(1)/F3(2))*(YU(NU)-YU(NU-1)) 65 - ZU(NU)=ZU(NU-1)+(F3(3)/F3(2))*(YU(NU)-YU(NU-1)) 66 - ISTAT=ISTAT3 67 - ELSEIF(IPLANE.EQ.4)THEN 68 - YU(NU)=DBLE(DDYMAX) 69 - XU(NU)=XU(NU-1)+(F3(1)/F3(2))*(YU(NU)-YU(NU-1)) 70 - ZU(NU)=ZU(NU-1)+(F3(3)/F3(2))*(YU(NU)-YU(NU-1)) 71 - ISTAT=ISTAT4 72 - ELSE 73 - PRINT *,' ###### DLCPLA ERROR : Unrecognised IPLANE=', 74 - - IPLANE,' received (program bug - please report).' 75 - ISTAT=-3 76 - ENDIF 77 - *** Clip the step to the full set of boundaries. 78 - CALL CLIP2D(XU(NU-1),YU(NU-1),XU(NU),YU(NU), 79 - - DBLE(DDXMIN),DBLE(DDYMIN),DBLE(DDXMAX),DBLE(DDYMAX),IFAIL) 80 - *** And fill in the time for the last step. 81 - TU(NU)=TU(NU-1)+SQRT((XU(NU)-XU(NU-1))**2+ 82 - - (YU(NU)-YU(NU-1))**2)/SPEED 83 - END 682 GARFIELD ================================================== P=DRIFTCAL D=DLCPLT 1 ============================ 0 + +DECK,DLCPLT. 1 - SUBROUTINE DLCPLT 2 - *----------------------------------------------------------------------- 3 - * DLCPLT - Plots a drift line. 4 - * (Last changed on 7/11/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,DRIFTLINE. 9 - *** Set the proper type of particle for plotting, first electron. 10 - IF(IPTYPE.EQ.1)THEN 11 - CALL GRATTS('E-DRIFT-LINE','POLYLINE') 12 - * And ion. 13 - ELSEIF(IPTYPE.EQ.2)THEN 14 - CALL GRATTS('ION-DRIFT-LINE','POLYLINE') 15 - * Anything else. 16 - ELSE 17 - PRINT *,' !!!!!! DLCPLT WARNING : Current drift line'// 18 - - ' is of unknown type; selecting FUNCTION-1'// 19 - - ' representation.' 20 - CALL GRATTS('FUNCTION-1','POLYLINE') 21 - ENDIF 22 - *** Plot the drift line. 23 - CALL PLAGPL(NU,XU,YU,ZU) 24 - END 683 GARFIELD ================================================== P=DRIFTCAL D=DLCSOL 1 ============================ 0 + +DECK,DLCSOL. 1 - SUBROUTINE DLCSOL(XPOS,YPOS,ZPOS,IVOL) 2 - *----------------------------------------------------------------------- 3 - * PLASOL - Determines whether a point is located inside a solid. 4 - * (Last changed on 31/ 8/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,SOLIDS. 10.- +SEQ,PRINTPLOT. 11 - DOUBLE PRECISION XPOS,YPOS,ZPOS 12 - INTEGER IVOL,I 13 - LOGICAL INSIDE 14 - *** Initial volume setting (not inside a solid). 15 - IVOL=0 16 - *** Loop over the solids. 17 - DO 10 I=1,NSOLID 18 - * Cylinders. 19 - IF(ISOLTP(I).EQ.1)THEN 20 - CALL PLACYI(I,XPOS,YPOS,ZPOS,INSIDE) 21 - IF(INSIDE)THEN 1 683 P=DRIFTCAL D=DLCSOL 2 PAGE1063 22 - IVOL=I 23 - RETURN 24 - ENDIF 25 - * Holes. 26 - ELSEIF(ISOLTP(I).EQ.2)THEN 27 - CALL PLACHI(I,XPOS,YPOS,ZPOS,INSIDE) 28 - IF(INSIDE)THEN 29 - IVOL=I 30 - RETURN 31 - ENDIF 32 - * Boxes. 33 - ELSEIF(ISOLTP(I).EQ.3)THEN 34 - CALL PLABXI(I,XPOS,YPOS,ZPOS,INSIDE) 35 - IF(INSIDE)THEN 36 - IVOL=I 37 - RETURN 38 - ENDIF 39 - * Spheres. 40 - ELSEIF(ISOLTP(I).EQ.4)THEN 41 - CALL PLASPI(I,XPOS,YPOS,ZPOS,INSIDE) 42 - IF(INSIDE)THEN 43 - IVOL=I 44 - RETURN 45 - ENDIF 46 - * Other things. 47 - ELSE 48 - PRINT *,' !!!!!! DLCSOL WARNING : Found a solid of'// 49 - - ' unknown type; ignored.' 50 - ENDIF 51 - 10 CONTINUE 52 - END 684 GARFIELD ================================================== P=DRIFTCAL D=DLCSTA 1 ============================ 0 + +DECK,DLCSTA. 1 - SUBROUTINE DLCSTA(Q,ITYPE) 2 - *----------------------------------------------------------------------- 3 - * DLCSTA - Subroutine returning the status of a drift line. It checks 4 - * that the particle is not inside or near a wire or a plane. 5 - * If that is the case however, the drift line is finished and 6 - * a non-zero status code is returned. 7 - * VARIABLES : XLAST,YLAST: Last particle position in basic cell. 8 - * SHIFT : .TRUE. if we are not in the basic period. 9 - * XW,YW : Wire position moved to the particle period. 10 - * DIST2 : Minimum distance of particle during the 11 - * last step to a given wire squared. 12 - * (Last changed on 17/11/98.) 13 - *----------------------------------------------------------------------- 14 - implicit none 15.- +SEQ,DIMENSIONS. 16.- +SEQ,CELLDATA. 17.- +SEQ,PARAMETERS. 18.- +SEQ,DRIFTLINE. 19.- +SEQ,PRINTPLOT. 20 - DOUBLE PRECISION XOLD,YOLD,ZOLD,XW,YW,XDIST,YDIST,DIST2,DISMIN, 21 - - RAUX1,RAUX2 22 - REAL DCXMIN,DCXMAX,DCYMIN,DCYMAX,Q 23 - INTEGER IFAIL,I,IOUT,IFLAG,ITYPE 24 - LOGICAL SHIFT 25 - *** Identify the routine if requested. 26 - IF(LIDENT)PRINT *,' /// ROUTINE DLCSTA ///' 27 - *** Preset ISTAT to 0 (normal situation). 28 - ISTAT=0 29 - *** Handle the case NU=1 seperately. 30 - IF(NU.EQ.1)THEN 31 - * Define the area to be used for checks later on, when NU > 1 32 - DDXMIN=DXMIN 33 - DDYMIN=DYMIN 34 - DDZMIN=DZMIN 35 - DDXMAX=DXMAX 36 - DDYMAX=DYMAX 37 - DDZMAX=DZMAX 38 - * Check position with respect to the planes. 39 - ISTAT1=-1 40 - ISTAT2=-1 41 - ISTAT3=-1 42 - ISTAT4=-1 43 - ISTAT5=-1 44 - ISTAT6=-1 45 - IF(YNPLAN(1))THEN 46 - DCXMIN=COPLAN(1) 47 - IF(PERX)THEN 48 - DCXMIN=DCXMIN+AINT((REAL(XU(1))-COPLAN(1))/SX)*SX 49 - IF(XU(1).LT.COPLAN(1))DCXMIN=DCXMIN-SX 50 - ENDIF 51 - IF(DCXMIN.GT.DXMIN)ISTAT1=-11 52 - DDXMIN=MAX(DCXMIN,DXMIN) 53 - ENDIF 54 - IF(YNPLAN(2))THEN 55 - DCXMAX=COPLAN(2) 56 - IF(PERX)THEN 57 - DCXMAX=DCXMAX+AINT((REAL(XU(1))-COPLAN(2))/SX)*SX 58 - IF(XU(1).GT.COPLAN(2))DCXMAX=DCXMAX+SX 59 - ENDIF 60 - IF(DCXMAX.LT.DXMAX)ISTAT2=-12 61 - DDXMAX=MIN(DCXMAX,DXMAX) 62 - ENDIF 63 - IF(YNPLAN(3))THEN 64 - DCYMIN=COPLAN(3) 65 - IF(PERY)THEN 66 - DCYMIN=DCYMIN+AINT((REAL(YU(1))-COPLAN(3))/SY)*SY 67 - IF(YU(1).LT.COPLAN(3))DCYMIN=DCYMIN-SY 68 - ENDIF 69 - IF(DCYMIN.GT.DYMIN)ISTAT3=-13 70 - DDYMIN=MAX(DCYMIN,DYMIN) 71 - ENDIF 1 684 P=DRIFTCAL D=DLCSTA 2 PAGE1064 72 - IF(YNPLAN(4))THEN 73 - DCYMAX=COPLAN(4) 74 - IF(PERY)THEN 75 - DCYMAX=DCYMAX+AINT((REAL(YU(1))-COPLAN(4))/SY)*SY 76 - IF(YU(1).GT.COPLAN(4))DCYMAX=DCYMAX+SY 77 - ENDIF 78 - IF(DCYMAX.LT.DYMAX)ISTAT4=-14 79 - DDYMAX=MIN(DCYMAX,DYMAX) 80 - ENDIF 81 - * Check position with respect to the tube, if it exists. 82 - IF(TUBE)THEN 83 - CALL INTUBE(REAL(XU(1)),REAL(YU(1)),COTUBE,NTUBE,IOUT) 84 - IF(IOUT.EQ.1)THEN 85 - ISTAT=-15 86 - ELSEIF(IOUT.NE.0)THEN 87 - ISTAT=-3 88 - ENDIF 89 - ENDIF 90 - * particle outside the drift area right at the start, 91 - IF(XU(1).LT.DDXMIN)ISTAT=ISTAT1 92 - IF(XU(1).GT.DDXMAX)ISTAT=ISTAT2 93 - IF(YU(1).LT.DDYMIN)ISTAT=ISTAT3 94 - IF(YU(1).GT.DDYMAX)ISTAT=ISTAT4 95 - IF(ZU(1).LT.DDZMIN)ISTAT=ISTAT5 96 - IF(ZU(1).GT.DDZMAX)ISTAT=ISTAT6 97 - IF(ISTAT.NE.0)RETURN 98 - ** Check whether the particle is already very near a wire. 99 - ITARG=0 100 - DISMIN=0 101 - DO 10 I=1,NWIRE 102 - * Skip wires with the wrong charge. 103 - IF(LREPSK.AND.Q*E(I).GT.0.0)GOTO 10 104 - * First find the wire closest to where we are now. 105 - XW=DBLE(X(I)) 106 - YW=DBLE(Y(I)) 107 - SHIFT=.FALSE. 108 - IF(PERX)THEN 109 - XDIST=XU(1)-DBLE(X(I)) 110 - XW=DBLE(X(I))+SX*ANINT(XDIST/SX) 111 - IF(ABS(XDIST).GT.SX/2)SHIFT=.TRUE. 112 - ENDIF 113 - IF(PERY)THEN 114 - YDIST=YU(1)-DBLE(Y(I)) 115 - YW=DBLE(Y(I))+SY*ANINT(YDIST/SY) 116 - IF(ABS(YDIST).GT.SY/2)SHIFT=.TRUE. 117 - ENDIF 118 - DIST2=(XU(NU)-XW)**2+(YU(NU)-YW)**2 119 - * Keep track of which one is closest. 120 - IF(ITARG.EQ.0.OR.DIST2.LT.DISMIN)THEN 121 - DISMIN=DIST2 122 - IF(SHIFT)THEN 123 - ITARG=I+MXWIRE 124 - ELSE 125 - ITARG=I 126 - ENDIF 127 - XTARG=XW 128 - YTARG=YW 129 - DTARG=D(I) 130 - ENDIF 131 - * Next find out if we have to make some last step or not. 132 - IF(DIST2.LE.(0.5*RTRAP*D(I))**2)THEN 133 - IF(DIST2.LE.(0.5*D(I))**2)THEN 134 - IF(LDEBUG)PRINT *,' ++++++ DLCSTA DEBUG :', 135 - - ' Particle is inside the wire at NU=1.' 136 - ISTAT=I 137 - ELSE 138 - IF(LDEBUG)PRINT *,' ++++++ DLCSTA DEBUG :', 139 - - ' DLCWIR entered from DLCSTA at NU=1.' 140 - CALL DLCWIR(0,Q,ITYPE) 141 - ENDIF 142 - RETURN 143 - ENDIF 144 - 10 CONTINUE 145 - RETURN 146 - ENDIF 147 - *** Next handle the case of NU > 1, check crossing of a whole period. 148 - IF((PERX.AND.ABS(XU(NU)-XU(NU-1)).GE.SX).OR. 149 - - (PERY.AND.ABS(YU(NU)-YU(NU-1)).GE.SY))THEN 150 - PRINT *,' ###### DLCSTA ERROR : Particle crossed more'// 151 - - ' than one period ; calculation is abandoned.' 152 - ISTAT=-3 153 - RETURN 154 - ENDIF 155 - *** Check that the particle is still inside the drift area, clip if not. 156 - IF(XU(NU).LT.DDXMIN)ISTAT=ISTAT1 157 - IF(XU(NU).GT.DDXMAX)ISTAT=ISTAT2 158 - IF(YU(NU).LT.DDYMIN)ISTAT=ISTAT3 159 - IF(YU(NU).GT.DDYMAX)ISTAT=ISTAT4 160 - IF(ZU(NU).LT.DDZMIN)ISTAT=ISTAT5 161 - IF(ZU(NU).GT.DDZMAX)ISTAT=ISTAT6 162 - IF(ISTAT.NE.0)THEN 163 - XOLD=XU(NU) 164 - YOLD=YU(NU) 165 - ZOLD=ZU(NU) 166 - CALL CLIP3D(XU(NU-1), YU(NU-1), ZU(NU-1), 167 - - XU(NU), YU(NU), ZU(NU), 168 - - DBLE(DDXMIN),DBLE(DDYMIN),DBLE(DDZMIN), 169 - - DBLE(DDXMAX),DBLE(DDYMAX),DBLE(DDZMAX),IFAIL) 170 - IF(IFAIL.NE.0.OR.(XOLD.EQ.XU(NU-1).AND. 171 - - YOLD.EQ.YU(NU-1).AND.ZOLD.EQ.ZU(NU-1)))THEN 172 - NU=NU-1 173 - ELSE 174 - TU(NU)=TU(NU-1)+(TU(NU)-TU(NU-1))*SQRT( 175 - - ((XU(NU)-XU(NU-1))**2+(YU(NU)-YU(NU-1))**2+ 176 - - (ZU(NU)-ZU(NU-1))**2)/ 177 - - ((XOLD-XU(NU-1))**2+(YOLD-YU(NU-1))**2+ 1 684 P=DRIFTCAL D=DLCSTA 3 PAGE1065 178 - - (ZOLD-ZU(NU-1))**2)) 179 - ENDIF 180 - RETURN 181 - ENDIF 182 - *** Left the tube ? 183 - IF(TUBE)THEN 184 - CALL INTUBE(REAL(XU(NU)),REAL(YU(NU)),COTUBE,NTUBE,IOUT) 185 - IF(IOUT.NE.0)THEN 186 - RAUX1=SQRT(XU(NU-1)**2+YU(NU-1)**2) 187 - RAUX2=SQRT(XU(NU)**2+YU(NU)**2) 188 - IF(RAUX1.NE.RAUX2.AND.NTUBE.EQ.0)THEN 189 - XU(NU)=XU(NU-1)+(XU(NU)-XU(NU-1))* 190 - - (COTUBE-RAUX1)/(RAUX2-RAUX1) 191 - YU(NU)=YU(NU-1)+(YU(NU)-YU(NU-1))* 192 - - (COTUBE-RAUX1)/(RAUX2-RAUX1) 193 - ZU(NU)=ZU(NU-1)+(ZU(NU)-ZU(NU-1))* 194 - - (COTUBE-RAUX1)/(RAUX2-RAUX1) 195 - TU(NU)=TU(NU-1)+(TU(NU)-TU(NU-1))* 196 - - (COTUBE-RAUX1)/(RAUX2-RAUX1) 197 - ELSE 198 - NU=NU-1 199 - ENDIF 200 - ISTAT=-15 201 - IF(LDEBUG)PRINT *,' ++++++ DLCSTA DEBUG : Particle'// 202 - - ' is leaving the tube.' 203 - RETURN 204 - ENDIF 205 - ENDIF 206 - *** Find out whether a wire has been hit and remember the nearest wire. 207 - ITARG=0 208 - DISMIN=0 209 - DO 20 I=1,NWIRE 210 - * Skip wires with the wrong charge. 211 - IF(LREPSK.AND.Q*E(I).GT.0.0)GOTO 20 212 - * First find the wire closest to where we are now. 213 - XW=X(I) 214 - YW=Y(I) 215 - SHIFT=.FALSE. 216 - IF(PERX)THEN 217 - XDIST=(XU(NU)+XU(NU-1))/2-XW 218 - XW=XW+SX*ANINT(XDIST/SX) 219 - IF(ABS(XDIST).GT.SX/2)SHIFT=.TRUE. 220 - ENDIF 221 - IF(PERY)THEN 222 - YDIST=(YU(NU)+YU(NU-1))/2-YW 223 - YW=YW+SY*ANINT(YDIST/SY) 224 - IF(ABS(YDIST).GT.SY/2)SHIFT=.TRUE. 225 - ENDIF 226 - IF(XW+0.5*D(I).LT.DDXMIN.OR.XW-0.5*D(I).GT.DDXMAX.OR. 227 - - YW+0.5*D(I).LT.DDYMIN.OR.YW-0.5*D(I).GT.DDYMAX)GOTO 20 228 - * Compute distance of the last point to the (replica of) wire I. 229 - CALL DLCMIN(XW,YW,XU(NU-1),YU(NU-1),XU(NU),YU(NU),DIST2,IFLAG) 230 - * Keep track of which one is closest. 231 - IF(ITARG.EQ.0.OR.DIST2.LT.DISMIN)THEN 232 - DISMIN=DIST2 233 - IF(SHIFT)THEN 234 - ITARG=I+MXWIRE 235 - ELSE 236 - ITARG=I 237 - ENDIF 238 - XTARG=XW 239 - YTARG=YW 240 - DTARG=D(I) 241 - ENDIF 242 - * Next find out if we have to make some last step or not. 243 - IF(DIST2.LE.(0.5*RTRAP*D(I))**2)THEN 244 - IF(LDEBUG)PRINT *,' ++++++ DLCSTA DEBUG : Particle hit', 245 - - ' wire ',I,' at ',XW,YW 246 - IF(LDEBUG)PRINT *,' distance from', 247 - - ' centre is ',SQRT(DIST2),', wire radius is ',D(I)/2.0 248 - IF(DIST2.LE.(0.5*D(I))**2.OR.IFLAG.NE.+1)NU=NU-1 249 - IF(LDEBUG)PRINT *,' ++++++ DLCSTA DEBUG : DLCWIR', 250 - - ' entered from DLCSTA because the wire is hit.' 251 - CALL DLCWIR(0,Q,ITYPE) 252 - RETURN 253 - ENDIF 254 - 20 CONTINUE 255 - END 685 GARFIELD ================================================== P=DRIFTCAL D=DLCSTF 1 ============================ 0 + +DECK,DLCSTF. 1 - SUBROUTINE DLCSTF(ISTAT,STATUS,NCSTAT) 2 - *----------------------------------------------------------------------- 3 - * DLCSTF - Formats the status code into a string. 4 - * (Last changed on 23/ 2/01.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,SOLIDS. 10 - CHARACTER*(*) STATUS 11 - CHARACTER*80 AUX 12 - INTEGER ISTAT,NCSTAT,NC 13 - * Drift line left the area. 14 - IF(ISTAT.EQ.-1)THEN 15 - STATUS='Left the drift area' 16 - NCSTAT=19 17 - * Too many curvature. 18 - ELSEIF(ISTAT.EQ.-2)THEN 19 - STATUS='Too many steps' 20 - NCSTAT=14 21 - * Calculations failed. 22 - ELSEIF(ISTAT.EQ.-3)THEN 23 - STATUS='Calculations abandoned' 24 - NCSTAT=22 1 685 P=DRIFTCAL D=DLCSTF 2 PAGE1066 25 - * Plane hit. 26 - ELSEIF(ISTAT.EQ.-4)THEN 27 - STATUS='Hit a plane' 28 - NCSTAT=11 29 - * Left drift medium. 30 - ELSEIF(ISTAT.EQ.-5)THEN 31 - STATUS='Left the drift medium' 32 - NCSTAT=21 33 - * Left the mesh. 34 - ELSEIF(ISTAT.EQ.-6)THEN 35 - STATUS='Left the mesh' 36 - NCSTAT=13 37 - * Plane hit. 38 - ELSEIF(ISTAT.EQ.-11)THEN 39 - IF(POLAR)THEN 40 - STATUS='Hit the minimum r plane' 41 - ELSE 42 - STATUS='Hit the minimum x plane' 43 - ENDIF 44 - NCSTAT=23 45 - ELSEIF(ISTAT.EQ.-12)THEN 46 - IF(POLAR)THEN 47 - STATUS='Hit the maximum r plane' 48 - ELSE 49 - STATUS='Hit the maximum x plane' 50 - ENDIF 51 - NCSTAT=23 52 - ELSEIF(ISTAT.EQ.-13)THEN 53 - IF(POLAR)THEN 54 - STATUS='Hit the minimum phi plane' 55 - NCSTAT=25 56 - ELSE 57 - STATUS='Hit the minimum y plane' 58 - NCSTAT=23 59 - ENDIF 60 - ELSEIF(ISTAT.EQ.-14)THEN 61 - IF(POLAR)THEN 62 - STATUS='Hit the maximum phi plane' 63 - NCSTAT=25 64 - ELSE 65 - STATUS='Hit the maximum y plane' 66 - NCSTAT=23 67 - ENDIF 68 - ELSEIF(ISTAT.EQ.-15)THEN 69 - STATUS='Hit the tube' 70 - NCSTAT=12 71 - ELSEIF(ISTAT.EQ.-20)THEN 72 - STATUS='Started from a line or an edge' 73 - NCSTAT=30 74 - * Original copy of a wire. 75 - ELSEIF(ISTAT.GT.0.AND.ISTAT.LE.MXWIRE)THEN 76 - CALL OUTFMT(REAL(ISTAT),2,AUX,NC,'LEFT') 77 - STATUS='Hit '//WIRTYP(ISTAT)//' wire '//AUX(1:NC) 78 - NCSTAT=11+NC 79 - * Wire replicas. 80 - ELSEIF(ISTAT.GT.MXWIRE.AND.ISTAT.LE.2*MXWIRE)THEN 81 - CALL OUTFMT(REAL(ISTAT)-MXWIRE,2,AUX,NC,'LEFT') 82 - STATUS='Hit a replica of '//WIRTYP(ISTAT-MXWIRE)// 83 - - ' wire '//AUX(1:NC) 84 - NCSTAT=24+NC 85 - * Solids. 86 - ELSEIF(ISTAT.GT.2*MXWIRE.AND.ISTAT.LE.2*MXWIRE+MXSOLI)THEN 87 - CALL OUTFMT(REAL(ISTAT)-2*MXWIRE,2,AUX,NC,'LEFT') 88 - STATUS='Hit '//SOLTYP(ISTAT-2*MXWIRE)// 89 - - ' solid '//AUX(1:NC) 90 - NCSTAT=12+NC 91 - * Invalid status code. 92 - ELSE 93 - STATUS='Unknown' 94 - NCSTAT=7 95 - ENDIF 96 - *** Ensure that the string length does not become invalid. 97 - IF(NCSTAT.GT.LEN(STATUS))THEN 98 - PRINT *,' !!!!!! DLCSTF WARNING : Status string has been'// 99 - - ' truncated.' 100 - NCSTAT=LEN(STATUS) 101 - ENDIF 102 - END 686 GARFIELD ================================================== P=DRIFTCAL D=DLCVEL 1 ============================ 0 + +DECK,DLCVEL. 1 - SUBROUTINE DLCVEL(XPOS,YPOS,ZPOS,VD,Q,ITYPE,ILOC) 2 - *----------------------------------------------------------------------- 3 - * DLCVEL - Subroutine returning the (vector) speed of an electron or 4 - * ion, taking the electric (and magnetic) field into account. 5 - * VARIABLES : V : Speed of the electron or ion. 6 - * Q : Charge of the particle in units of E. 7 - * ITYPE : Particle type (1=e- ; else=ion). 8 - * PMU : Mobility of the electron/ion in the gas. 9 - * (Last changed on 5/ 3/00.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,GASDATA. 14.- +SEQ,BFIELD. 15.- +SEQ,CELLDATA. 16 - DOUBLE PRECISION XPOS,YPOS,ZPOS,VD(3),UB(3),UEXB(3),ENORM 17 - REAL EX,EY,EZ,BX,BY,BZ,VOLT,GASVEL,GASVT1,GASVT2,GASMOB,GASLOR, 18 - - PMU,ETOT,BTOT,ANGLE,Q,VE,VB,VEXB 19 - INTEGER ITYPE,ILOC 20 - EXTERNAL GASVEL,GASMOB,GASLOR 21 - *** Deal the with special case of vacuum drift - drift velocity unknown. 22 - IF(ITYPE.EQ.0)THEN 23 - PRINT *,' !!!!!! DLCVEL WARNING : Drift velocity for'// 24 - - ' vacuum drift requested ; not defined, set to 0.' 1 686 P=DRIFTCAL D=DLCVEL 2 PAGE1067 25 - VD(1)=0.0D0 26 - VD(2)=0.0D0 27 - VD(3)=0.0D0 28 - ILOC=-11 29 - RETURN 30 - ENDIF 31 - *** Calculate the electric field. 32 - CALL EFIELD(REAL(XPOS),REAL(YPOS),REAL(ZPOS), 33 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 34 - IF(POLAR)THEN 35 - EZ=0 36 - ETOT=SQRT(EX**2+EY**2) 37 - ENDIF 38 - IF(ILOC.NE.0.OR.ETOT.LE.0)THEN 39 - VD(1)=0.0D0 40 - VD(2)=0.0D0 41 - VD(3)=0.0D0 42 - RETURN 43 - ENDIF 44 - *** Electron without B field. 45 - IF(ITYPE.EQ.1.AND..NOT.MAGOK)THEN 46 - * Compute the mobility. 47 - IF(POLAR)THEN 48 - PMU=GASVEL(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, 49 - - BX,BY,BZ)/(EXP(XPOS)*ETOT) 50 - ELSE 51 - PMU=GASVEL(EX,EY,EZ,BX,BY,BZ)/ETOT 52 - ENDIF 53 - * Store the velocity vector. 54 - VD(1)=Q*PMU*EX 55 - VD(2)=Q*PMU*EY 56 - VD(3)=Q*PMU*EZ 57 - *** Electron with B field and velocity vector. 58 - ELSEIF(ITYPE.EQ.1.AND.GASOK(1).AND.GASOK(9).AND.GASOK(10))THEN 59 - * Compute the B field. 60 - CALL BFIELD(REAL(XPOS),REAL(YPOS),REAL(ZPOS),BX,BY,BZ,BTOT) 61 - * Compute unit vectors along Btrans and ExB. 62 - UEXB(1)=EY*BZ-EZ*BY 63 - UEXB(2)=EZ*BX-EX*BZ 64 - UEXB(3)=EX*BY-EY*BX 65 - ENORM=SQRT(UEXB(1)**2+UEXB(2)**2+UEXB(3)**2) 66 - IF(ENORM.GT.0)THEN 67 - UEXB(1)=UEXB(1)/ENORM 68 - UEXB(2)=UEXB(2)/ENORM 69 - UEXB(3)=UEXB(3)/ENORM 70 - ELSE 71 - UEXB(1)=EX/ETOT 72 - UEXB(2)=EY/ETOT 73 - UEXB(3)=EZ/ETOT 74 - ENDIF 75 - UB(1)=UEXB(2)*EZ-UEXB(3)*EY 76 - UB(2)=UEXB(3)*EX-UEXB(1)*EZ 77 - UB(3)=UEXB(1)*EY-UEXB(2)*EX 78 - ENORM=SQRT(UB(1)**2+UB(2)**2+UB(3)**2) 79 - IF(ENORM.GT.0)THEN 80 - UB(1)=UB(1)/ENORM 81 - UB(2)=UB(2)/ENORM 82 - UB(3)=UB(3)/ENORM 83 - ELSE 84 - UB(1)=EX/ETOT 85 - UB(2)=EY/ETOT 86 - UB(3)=EZ/ETOT 87 - ENDIF 88 - * Compute the velocities in all directions. 89 - IF(POLAR)THEN 90 - VE=GASVEL(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, 91 - - BX,BY,BZ)/EXP(XPOS) 92 - VB=GASVT1(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, 93 - - BX,BY,BZ)/EXP(XPOS) 94 - VEXB=GASVT2(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, 95 - - BX,BY,BZ)/EXP(XPOS) 96 - ELSE 97 - VE=GASVEL(EX,EY,EZ,BX,BY,BZ) 98 - VB=GASVT1(EX,EY,EZ,BX,BY,BZ) 99 - VEXB=GASVT2(EX,EY,EZ,BX,BY,BZ) 100 - ENDIF 101 - * Return the velocity vector. 102 - VD(1)=Q*(VE*EX/ETOT+VB*UB(1)+VEXB*UEXB(1)) 103 - VD(2)=Q*(VE*EY/ETOT+VB*UB(2)+VEXB*UEXB(2)) 104 - VD(3)=Q*(VE*EZ/ETOT+VB*UB(3)+VEXB*UEXB(3)) 105 - *** Electron with B field and Lorentz angle. 106 - ELSEIF(ITYPE.EQ.1.AND.GASOK(7))THEN 107 - * Compute the B field. 108 - CALL BFIELD(REAL(XPOS),REAL(YPOS),REAL(ZPOS),BX,BY,BZ,BTOT) 109 - * Compute a unit vector along ExB. 110 - UEXB(1)=EY*BZ-EZ*BY 111 - UEXB(2)=EZ*BX-EX*BZ 112 - UEXB(3)=EX*BY-EY*BX 113 - ENORM=SQRT(UEXB(1)**2+UEXB(2)**2+UEXB(3)**2) 114 - IF(ENORM.GT.0)THEN 115 - UEXB(1)=UEXB(1)/ENORM 116 - UEXB(2)=UEXB(2)/ENORM 117 - UEXB(3)=UEXB(3)/ENORM 118 - ELSE 119 - UEXB(1)=EX/ETOT 120 - UEXB(2)=EY/ETOT 121 - UEXB(3)=EZ/ETOT 122 - ENDIF 123 - * Compute the velocities and the angle. 124 - IF(POLAR)THEN 125 - VE=GASVEL(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, 126 - - BX,BY,BZ)/EXP(XPOS) 127 - ANGLE=GASLOR(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, 128 - - BX,BY,BZ) 129 - ELSE 130 - VE=GASVEL(EX,EY,EZ,BX,BY,BZ) 1 686 P=DRIFTCAL D=DLCVEL 3 PAGE1068 131 - ANGLE=GASLOR(EX,EY,EZ,BX,BY,BZ) 132 - ENDIF 133 - * Return the velocity. 134 - VD(1)=Q*VE*(COS(ANGLE)*EX/ETOT+SIN(ANGLE)*UEXB(1)) 135 - VD(2)=Q*VE*(COS(ANGLE)*EY/ETOT+SIN(ANGLE)*UEXB(2)) 136 - VD(3)=Q*VE*(COS(ANGLE)*EZ/ETOT+SIN(ANGLE)*UEXB(3)) 137 - *** Electron with B field and nothing else known. 138 - ELSEIF(ITYPE.EQ.1)THEN 139 - * Compute the B field. 140 - CALL BFIELD(REAL(XPOS),REAL(YPOS),REAL(ZPOS),BX,BY,BZ,BTOT) 141 - * Compute the velocity. 142 - IF(POLAR)THEN 143 - PMU=GASVEL(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, 144 - - BX,BY,BZ)/EXP(XPOS) 145 - ELSE 146 - PMU=GASVEL(EX,EY,EZ,BX,BY,BZ)/ETOT 147 - ENDIF 148 - * Return a velocity. 149 - VD(1)=Q*PMU*(EX+PMU*(EY*BZ-EZ*BY)+ 150 - - BX*((BX*EX+BY*EY+BZ*EZ)*PMU**2))/(1+(PMU*BTOT)**2) 151 - VD(2)=Q*PMU*(EY+PMU*(EZ*BX-EX*BZ)+ 152 - - BY*((BX*EX+BY*EY+BZ*EZ)*PMU**2))/(1+(PMU*BTOT)**2) 153 - VD(3)=Q*PMU*(EZ+PMU*(EX*BY-EY*BX)+ 154 - - BZ*((BX*EX+BY*EY+BZ*EZ)*PMU**2))/(1+(PMU*BTOT)**2) 155 - *** Ion without B field. 156 - ELSEIF(ITYPE.EQ.2.AND..NOT.MAGOK)THEN 157 - * Compute the mobility. 158 - IF(POLAR)THEN 159 - PMU=GASMOB(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, 160 - - BX,BY,BZ)/EXP(2*XPOS) 161 - ELSE 162 - PMU=GASMOB(EX,EY,EZ,BX,BY,BZ) 163 - ENDIF 164 - * Store the velocity vector. 165 - VD(1)=Q*PMU*EX 166 - VD(2)=Q*PMU*EY 167 - VD(3)=Q*PMU*EZ 168 - *** Ion with B field. 169 - ELSEIF(ITYPE.EQ.2)THEN 170 - * Compute the B field. 171 - CALL BFIELD(REAL(XPOS),REAL(YPOS),REAL(ZPOS),BX,BY,BZ,BTOT) 172 - * Compute the velocity. 173 - IF(POLAR)THEN 174 - PMU=GASMOB(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, 175 - - BX,BY,BZ)/EXP(2*XPOS) 176 - ELSE 177 - PMU=GASMOB(EX,EY,EZ,BX,BY,BZ) 178 - ENDIF 179 - * Return a velocity. 180 - VD(1)=Q*PMU*(EX+PMU*(EY*BZ-EZ*BY)+ 181 - - BX*((BX*EX+BY*EY+BZ*EZ)*PMU**2))/(1+(PMU*BTOT)**2) 182 - VD(2)=Q*PMU*(EY+PMU*(EZ*BX-EX*BZ)+ 183 - - BY*((BX*EX+BY*EY+BZ*EZ)*PMU**2))/(1+(PMU*BTOT)**2) 184 - VD(3)=Q*PMU*(EZ+PMU*(EX*BY-EY*BX)+ 185 - - BZ*((BX*EX+BY*EY+BZ*EZ)*PMU**2))/(1+(PMU*BTOT)**2) 186 - *** Other cases. 187 - ELSE 188 - PRINT *,' !!!!!! DLCVEL WARNING : Unable to deal with the'// 189 - - ' particle type / field combination; returning 0.' 190 - VD(1)=0.0D0 191 - VD(2)=0.0D0 192 - VD(3)=0.0D0 193 - RETURN 194 - ENDIF 195 - END 687 GARFIELD ================================================== P=DRIFTCAL D=DLCWIR 1 ============================ 0 + +DECK,DLCWIR. 1 - SUBROUTINE DLCWIR(ISKIP,Q,ITYPE) 2 - *----------------------------------------------------------------------- 3 - * DLCWIR - Terminates drift line calculation by making some last steps 4 - * towards the surface of the wire on which it is supposed to 5 - * end. The precision is controlled in order to obtain a 6 - * good estimate of the total remaining drift-time. 7 - * VARIABLES : (X1,Y1) : First point of an integration segment. 8 - * (XM,YM) : Middle point of an integration segment. 9 - * (X2,Y2) : Last point of an integration segment. 10 - * F1, FM, F2 : Velocities at (X1,Y1), (XM,YM), (X2,Y2). 11 - * ONWIRE : .TRUE. if the last point is on the wire. 12 - * ISKIP : Skip searching for the nearest wire and 13 - * use (XTARG,YTARG) instead. 14 - * (Last changed on 5/ 2/00.) 15 - *----------------------------------------------------------------------- 16 - implicit none 17.- +SEQ,DIMENSIONS. 18.- +SEQ,CELLDATA. 19.- +SEQ,DRIFTLINE. 20.- +SEQ,PRINTPLOT. 21 - INTEGER MXSPLT 22 - PARAMETER (MXSPLT=10) 23 - DOUBLE PRECISION F1(3),FM(3),F2(3),X1,XM,X2,Y1,YM,Y2, 24 - - Z1,ZM,Z2,T1,T2,DIST2,TCRUDE,XDIST,YDIST,DISMIN 25 - REAL Q,EX,EY,EZ,ETOT,VOLT,XWAUX,YWAUX 26 - INTEGER ITYPE,IFLAG,ILOC,ILOC1,ILOC2,ILOCM,I,ISKIP,ISPLIT,IWEND 27 - LOGICAL ONWIRE,SHIFT 28 - *** Identify the routine if requested. 29 - IF(LIDENT)PRINT *,' /// ROUTINE DLCWIR ///' 30 - IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : ITARG=',ITARG, 31 - - ' (x,y)=',XTARG,YTARG,', d=',DTARG 32 - *** Step backwards until we have a point where the field is non-zero. 33 - 10 CONTINUE 34 - CALL EFIELD(REAL(XU(NU)),REAL(YU(NU)),REAL(ZU(NU)), 35 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 36 - IF(ILOC.NE.0.OR.ETOT.EQ.0)THEN 37 - IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Last point at', 1 687 P=DRIFTCAL D=DLCWIR 2 PAGE1069 38 - - ' NU=',NU,' is at zero field ; NU lowered by 1.' 39 - IF(NU.GT.1)THEN 40 - NU=NU-1 41 - GOTO 10 42 - ELSE 43 - PRINT *,' !!!!!! DLCWIR WARNING : Unable to find a', 44 - - ' point on the drift-line where E is not zero.' 45 - ISTAT=-3 46 - ENDIF 47 - ENDIF 48 - *** Make sure space is left for the steps to come. 49 - IF(NU.GE.MXLIST)THEN 50 - IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : No storage', 51 - - ' left ; stepping to the wire not performed.' 52 - ISTAT=-2 53 - NU=MXLIST 54 - RETURN 55 - ENDIF 56 - *** Skip finding the wire if ISKIP=1. 57 - IF(ISKIP.EQ.1)THEN 58 - IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Wire search', 59 - - ' is skipped due to ISKIP=',ISKIP 60 - IF(ITARG.GT.MXWIRE)THEN 61 - IWEND=ITARG-MXWIRE 62 - ELSE 63 - IWEND=ITARG 64 - ENDIF 65 - GOTO 1000 66 - ENDIF 67 - *** Find out whether the diagnosis about the target wire is correct. 68 - ITARG=0 69 - DISMIN=0 70 - IWEND=0 71 - DO 20 I=1,NWIRE 72 - * First find the wire closest to where we are now. 73 - XWAUX=X(I) 74 - YWAUX=Y(I) 75 - SHIFT=.FALSE. 76 - IF(PERX)THEN 77 - XDIST=XU(NU)-DBLE(X(I)) 78 - IF(ABS(XDIST).GT.SX/2)SHIFT=.TRUE. 79 - XWAUX=X(I)+SX*ANINT(XDIST/SX) 80 - ENDIF 81 - IF(PERY)THEN 82 - YDIST=YU(NU)-DBLE(Y(I)) 83 - IF(ABS(YDIST).GT.SY/2)SHIFT=.TRUE. 84 - YWAUX=Y(I)+SY*ANINT(YDIST/SY) 85 - ENDIF 86 - DIST2=(XU(NU)-XWAUX)**2+(YU(NU)-YWAUX)**2 87 - * Keep track of which one is closest. 88 - IF(ITARG.EQ.0.OR.DIST2.LT.DISMIN)THEN 89 - DISMIN=DIST2 90 - XTARG=XWAUX 91 - YTARG=YWAUX 92 - DTARG=D(I) 93 - IWEND=I 94 - IF(SHIFT)THEN 95 - ITARG=I+MXWIRE 96 - ELSE 97 - ITARG=I 98 - ENDIF 99 - ENDIF 100 - 20 CONTINUE 101 - IF(IWEND.EQ.0)THEN 102 - PRINT *,' ###### DLCWIR ERROR : No target wire found'// 103 - - ' ; program bug - please report.' 104 - ISTAT=-3 105 - ENDIF 106 - *** Cheat with the target wire to avoid getting into it. 107 - 1000 CONTINUE 108 - D(IWEND)=DTARG/2 109 - ** Final stepping towards the wire starts. 110 - IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Stepping towards'// 111 - - ' the wire ',IWEND,' started at NU= ',NU 112 - X1=XU(NU) 113 - Y1=YU(NU) 114 - Z1=ZU(NU) 115 - T1=TU(NU) 116 - ** Make an estimate for a full step towards the wire. 117 - CALL DLCVEL(X1,Y1,Z1,F1,Q,ITYPE,ILOC1) 118 - IF(SQRT(F1(1)**2+F1(2)**2).LE.0.0)THEN 119 - IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Initial'// 120 - - ' drift-velocity zero; quit on ISTAT=-3.' 121 - ISTAT=-3 122 - D(IWEND)=DTARG 123 - RETURN 124 - ENDIF 125 - * Estimate the time needed to reach the wire. 126 - TCRUDE=(SQRT((X1-XTARG)**2+(Y1-YTARG)**2)-DTARG/2.0)/ 127 - - SQRT(F1(1)**2+F1(2)**2) 128 - IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Estimated time'// 129 - - ' needed to reach the wire: ',TCRUDE 130 - * Special handling for small TCRUDE. 131 - IF(TCRUDE.LT.1.0E-6*TU(NU))THEN 132 - IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Small TCRUDE'// 133 - - ' exception handling; no further processing.' 134 - ISTAT=ITARG 135 - D(IWEND)=DTARG 136 - RETURN 137 - ENDIF 138 - *** Iteration starts here: set the number of integration divisions to 0. 139 - ISPLIT=0 140 - 100 CONTINUE 141 - * Estimate where the drift-line will end up after this time. 142 - X2=X1+F1(1)*TCRUDE 143 - Y2=Y1+F1(2)*TCRUDE 1 687 P=DRIFTCAL D=DLCWIR 3 PAGE1070 144 - Z2=Z1+F1(3)*TCRUDE 145 - * Set the flag for being in the wire to .FALSE. 146 - ONWIRE=.FALSE. 147 - ** Take action depending on where we end up, first moving away. 148 - CALL DLCMIN(XTARG,YTARG,X1,Y1,X2,Y2,DIST2,IFLAG) 149 - IF(IFLAG.EQ.-1)THEN 150 - IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Particle moves', 151 - - ' away from the wire ; quit on ISTAT=-3.' 152 - ISTAT=-3 153 - D(IWEND)=DTARG 154 - RETURN 155 - * Next the case the wire has been crossed. 156 - ELSEIF(IFLAG.EQ.0.OR.DIST2.LE.(DTARG/2)**2)THEN 157 - X2=XTARG-0.5*DTARG*(XTARG-X1)/ 158 - - SQRT((X1-XTARG)**2+(Y1-YTARG)**2) 159 - Y2=YTARG-0.5*DTARG*(YTARG-Y1)/ 160 - - SQRT((X1-XTARG)**2+(Y1-YTARG)**2) 161 - TCRUDE=SQRT(((X2-X1)**2+(Y2-Y1)**2)/(F1(1)**2+F1(2)**2)) 162 - Z2=Z1+TCRUDE*F1(3) 163 - ONWIRE=.TRUE. 164 - ENDIF 165 - ** Calculate the drift-velocity at the end point. 166 - CALL DLCVEL(X2,Y2,Z2,F2,Q,ITYPE,ILOC2) 167 - ** Set a point halfway between 1 and 2 for an accuracy check. 168 - XM=0.5*(X1+X2) 169 - YM=0.5*(Y1+Y2) 170 - ZM=0.5*(Z1+Z2) 171 - CALL DLCVEL(XM,YM,ZM,FM,Q,ITYPE,ILOCM) 172 - ** Check the location codes. 173 - IF(ILOC1.NE.0.OR.ILOCM.NE.0.OR.ILOC2.NE.0)THEN 174 - IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : ILOC position'// 175 - - ' codes cause ISTAT=-3 quit: ',ILOC1,ILOCM,ILOC2 176 - ISTAT=-3 177 - D(IWEND)=DTARG 178 - RETURN 179 - ENDIF 180 - * Check the non-zeroness of the velocities. 181 - IF(SQRT(F1(1)**2+F1(2)**2).LE.0.0.OR. 182 - - SQRT(FM(1)**2+FM(2)**2).LE.0.0.OR. 183 - - SQRT(F2(1)**2+F2(2)**2).LE.0.0)THEN 184 - IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Intermediate'// 185 - - ' drift-velocity zero; quit on ISTAT=-3.' 186 - ISTAT=-3 187 - D(IWEND)=DTARG 188 - RETURN 189 - ENDIF 190 - ** Compare first and second order estimates. 191 - IF(ISPLIT.GE.MXSPLT.OR.SQRT((X2-X1)**2+(Y2-Y1)**2)* 192 - - ABS(1.0/SQRT(F1(1)**2+F1(2)**2)-2.0/SQRT(FM(1)**2+FM(2)**2)+ 193 - - 1.0/SQRT(F2(1)**2+F2(2)**2))/3.0.LT.1.0D-4*(1+ABS(T1)))THEN 194 - * Accurate enough: integrate the drift-time over this segment. 195 - T2=T1+SQRT((X2-X1)**2+(Y2-Y1)**2)* 196 - - (1.0/SQRT(F1(1)**2+F1(2)**2)+ 197 - - 4.0/SQRT(FM(1)**2+FM(2)**2)+ 198 - - 1.0/SQRT(F2(1)**2+F2(2)**2))/6.0 199 - * Add to the drift-line if there is space left. 200 - IF(NU.GE.MXLIST)THEN 201 - IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : No space'// 202 - - ' left for ; ISTAT=-2 return.' 203 - ISTAT=-2 204 - NU=MXLIST 205 - RETURN 206 - ELSE 207 - NU=NU+1 208 - XU(NU)=X2 209 - YU(NU)=Y2 210 - ZU(NU)=Z2 211 - TU(NU)=T2 212 - IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Adding'// 213 - - ' point ',NU,' at ',XU(NU),YU(NU),ZU(NU),TU(NU) 214 - IF(ONWIRE)THEN 215 - ISTAT=ITARG 216 - D(IWEND)=DTARG 217 - IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG :'// 218 - - ' This was the last step.' 219 - RETURN 220 - ENDIF 221 - IF(LDEBUG.AND.ISPLIT.GT.0)PRINT *,' ++++++ DLCWIR', 222 - - ' DEBUG : Adding at ISPLIT=',ISPLIT 223 - ENDIF 224 - * Proceed with the next step. 225 - X1=X2 226 - Y1=Y2 227 - Z1=Z2 228 - T1=T2 229 - ILOC1=ILOC2 230 - F1(1)=F2(1) 231 - F1(2)=F2(2) 232 - F1(3)=F2(3) 233 - GOTO 100 234 - ** Halve the step-size if the accuracy is insufficient. 235 - ELSE 236 - TCRUDE=TCRUDE/2 237 - ISPLIT=ISPLIT+1 238 - GOTO 100 239 - ENDIF 240 - END 688 GARFIELD ================================================== P=DRIFTCAL D=DLCATT 1 ============================ 0 + +DECK,DLCATT. 1 - SUBROUTINE DLCATT(FACTOR) 2 - *----------------------------------------------------------------------- 3 - * DLCATT - Routine returning the attachment losses for the current 4 - * drift line. Uses either DLCAT11 for drift lines that have 5 - * been computed with RKF or DLCAT22 for MC drift lines. 1 688 P=DRIFTCAL D=DLCATT 2 PAGE1071 6 - * integration. 7 - * VARIABLES : FACTOR : The attachment losses. 8 - * (Last changed on 17/ 9/99.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,DRIFTLINE. 13.- +SEQ,CELLDATA. 14.- +SEQ,PRINTPLOT. 15 - REAL FACTOR 16 - *** Projected integration ... 17 - IF(LAVPRO)THEN 18 - CALL DLCAT2(FACTOR) 19 - *** Integration over the true step length ... 20 - ELSE 21 - CALL DLCAT1(FACTOR) 22 - ENDIF 23 - END 689 GARFIELD ================================================== P=DRIFTCAL D=DLCAT1 1 ============================ 0 + +DECK,DLCAT1. 1 - SUBROUTINE DLCAT1(FACTOR) 2 - *----------------------------------------------------------------------- 3 - * DLCAT1 - Routine returning the attachment losses for the current 4 - * drift line. The routine uses an adaptive Simpson style 5 - * integration. 6 - * VARIABLES : BETA. : Attachment coefficients (1,2 end; M middle) 7 - * BETINT : Integral of the attachment coefficient. 8 - * FACTOR : The attachment losses 9 - * (Last changed on 5/ 2/00.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,DRIFTLINE. 14.- +SEQ,CELLDATA. 15.- +SEQ,PRINTPLOT. 16 - REAL ATTVEC(MXLIST),BETA1,BETA2,BETAM,FACTOR,EXM,EYM,EZM,ETOTM, 17 - - EX,EY,EZ,ETOT,VOLT,BX,BY,BZ,BTOT,BXM,BYM,BZM,BTOTM,GASATT, 18 - - DRES 19 - DOUBLE PRECISION XAUX1,XAUX2,YAUX1,YAUX2,STEP,BETINT, 20 - - XPOS1,XPOS2,XPOSM,YPOS1,YPOS2,YPOSM,ZPOSM,ZPOS1,ZPOS2, 21 - - TOTSTP,CRUDE,STACK(MXSTCK,4) 22 - INTEGER LOCVEC(MXLIST),ISTACK,NSTACK,ILOCRS,NFC,ILOCM,IU,ILOC 23 - EXTERNAL GASATT 24 - *** Identify the routine 25 - IF(LIDENT)PRINT *,' /// ROUTINE DLCAT1 ///' 26 - *** Return straight away if there is only one data point. 27 - IF(NU.LE.1)THEN 28 - FACTOR=1.0 29 - RETURN 30 - ENDIF 31 - *** Obtain a very rough estimate of the result. 32 - CRUDE=0.0 33 - DO 100 IU=1,NU 34 - CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 35 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 36 - CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 37 - - BX,BY,BZ,BTOT) 38 - * Cheat in case the point is located inside a wire. 39 - IF(ILOC.GT.0.AND.ILOC.LE.MXWIRE)THEN 40 - DRES=D(ILOC) 41 - ILOCRS=ILOC 42 - D(ILOCRS)=0.0 43 - CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 44 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 45 - CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 46 - - BX,BY,BZ,BTOT) 47 - D(ILOCRS)=DRES 48 - IF(LDEBUG)PRINT *,' ++++++ DLCAT1 DEBUG : Drift-line', 49 - - ' data point in wire ',ILOCRS,' detected; d=0 fix.' 50 - ENDIF 51 - * In case this didn't help, just log the failure. 52 - LOCVEC(IU)=ILOC 53 - IF(POLAR)THEN 54 - ATTVEC(IU)=GASATT(EX/EXP(REAL(XU(IU))),EY/EXP(REAL(XU(IU))), 55 - - EZ,BX,BY,BZ) 56 - IF(IU.GT.1)THEN 57 - CALL CF2RTC(XU(IU),YU(IU),XAUX1,YAUX1,1) 58 - CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX2,YAUX2,1) 59 - STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 60 - - (ZU(IU)-ZU(IU-1))**2) 61 - ENDIF 62 - ELSE 63 - ATTVEC(IU)=GASATT(EX,EY,EZ,BX,BY,BZ) 64 - IF(IU.GT.1)STEP=SQRT((XU(IU)-XU(IU-1))**2+ 65 - - (YU(IU)-YU(IU-1))**2+(ZU(IU)-ZU(IU-1))**2) 66 - ENDIF 67 - IF(IU.GT.1)CRUDE=CRUDE+STEP*(ATTVEC(IU)+ATTVEC(IU-1))/2.0 68 - 100 CONTINUE 69 - NFC=NU 70 - *** Print a heading for the debugging output. 71 - IF(LDEBUG)THEN 72 - PRINT *,' ++++++ DLCAT1 DEBUG : Attachment integration', 73 - - ' debugging output follows:' 74 - PRINT *,' ' 75 - PRINT *,' IU loc XU(IU)'// 76 - - ' YU(IU)'// 77 - - ' ZU(IU)'// 78 - - ' number of electrons' 79 - PRINT *,' [cm]'// 80 - - ' [cm]'// 81 - - ' [cm]'// 82 - - ' [numeric]' 83 - PRINT *,' ' 84 - PRINT '(2(2X,I3),3(5X,E15.8))',1,LOCVEC(1),XU(1),YU(1),ZU(1) 1 689 P=DRIFTCAL D=DLCAT1 2 PAGE1072 85 - ENDIF 86 - *** Initialise the sum BETINT 87 - BETINT=0.0 88 - *** Loop over the whole drift-line. 89 - ISTACK=0 90 - DO 10 IU=1,NU-1 91 - IF(LOCVEC(IU).NE.0.OR.LOCVEC(IU+1).NE.0)GOTO 30 92 - * Initial values for the position. 93 - XPOS1=XU(IU) 94 - YPOS1=YU(IU) 95 - ZPOS1=ZU(IU) 96 - BETA1=ATTVEC(IU) 97 - XPOS2=XU(IU+1) 98 - YPOS2=YU(IU+1) 99 - ZPOS2=ZU(IU+1) 100 - BETA2=ATTVEC(IU+1) 101 - * Calculate the total steplength, in Cartesian coordinates. 102 - IF(POLAR)THEN 103 - CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) 104 - CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) 105 - TOTSTP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 106 - - (ZPOS2-ZPOS1)**2) 107 - ELSE 108 - TOTSTP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ 109 - - (ZPOS2-ZPOS1)**2) 110 - ENDIF 111 - * Return at this point of further refinement is needed. 112 - NSTACK=0 113 - 20 CONTINUE 114 - * Set the new middle point, to be used for comparison. 115 - XPOSM=0.5*(XPOS1+XPOS2) 116 - YPOSM=0.5*(YPOS1+YPOS2) 117 - ZPOSM=0.5*(ZPOS1+ZPOS2) 118 - * Compute the field and the attachment coeff. at the middle point. 119 - CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 120 - - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) 121 - CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 122 - - BXM,BYM,BZM,BTOTM) 123 - NFC=NFC+1 124 - * Cheat in case the point is located inside a wire. 125 - IF(ILOCM.GT.0.AND.ILOCM.LE.MXWIRE)THEN 126 - DRES=D(ILOCM) 127 - ILOCRS=ILOCM 128 - D(ILOCRS)=0.0 129 - CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 130 - - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) 131 - CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 132 - - BXM,BYM,BZM,BTOTM) 133 - NFC=NFC+1 134 - D(ILOCRS)=DRES 135 - IF(LDEBUG)PRINT *,' ++++++ DLCAT1 DEBUG : Intermediate', 136 - - ' point in wire ',ILOCRS,' detected; d=0 fix.' 137 - ENDIF 138 - * Skip this step in case the ILOC is not due to a wire. 139 - IF(ILOCM.NE.0)GOTO 30 140 - IF(POLAR)THEN 141 - BETAM=GASATT(EXM/EXP(REAL(XPOSM)),EYM/EXP(REAL(XPOSM)),EZM, 142 - - BXM,BYM,BZM) 143 - ELSE 144 - BETAM=GASATT(EXM,EYM,EZM,BXM,BYM,BZM) 145 - ENDIF 146 - * Compare first and second order estimates, divide if too large. 147 - IF(NSTACK.LT.MIN(MXSTCK,MXATTS).AND.EPSATI*CRUDE.LT. 148 - - TOTSTP*ABS(BETA1-2.0*BETAM+BETA2)/3.0)THEN 149 - NSTACK=NSTACK+1 150 - ISTACK=MAX(ISTACK,NSTACK) 151 - STACK(NSTACK,1)=XPOS2 152 - STACK(NSTACK,2)=YPOS2 153 - STACK(NSTACK,3)=ZPOS2 154 - STACK(NSTACK,4)=BETA2 155 - XPOS2=XPOSM 156 - YPOS2=YPOSM 157 - ZPOS2=ZPOSM 158 - BETA2=BETAM 159 - GOTO 20 160 - * No further subdevision is required, transform polar coordinates. 161 - ELSE 162 - * Make sure the distances are measured in cartesian coordinates. 163 - IF(POLAR)THEN 164 - CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) 165 - CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) 166 - STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 167 - - (ZPOS2-ZPOS1)**2) 168 - ELSE 169 - STEP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ 170 - - (ZPOS2-ZPOS1)**2) 171 - ENDIF 172 - * Add the new term to the integral. 173 - BETINT=BETINT+STEP*(BETA1+4.0*BETAM+BETA2)/6.0 174 - * Continue with the next segment (if complete) or the next subsegment. 175 - XPOS1=XPOS2 176 - YPOS1=YPOS2 177 - ZPOS1=ZPOS2 178 - BETA1=BETA2 179 - IF(NSTACK.GT.0)THEN 180 - XPOS2=STACK(NSTACK,1) 181 - YPOS2=STACK(NSTACK,2) 182 - ZPOS2=STACK(NSTACK,3) 183 - BETA2=STACK(NSTACK,4) 184 - NSTACK=NSTACK-1 185 - GOTO 20 186 - ENDIF 187 - ENDIF 188 - * Continue with the next segment. 189 - 30 CONTINUE 190 - * Print some debugging output. 1 689 P=DRIFTCAL D=DLCAT1 3 PAGE1073 191 - IF(LDEBUG)PRINT '(2I5,4(5X,E15.8))',IU+1,LOCVEC(IU+1),XU(IU+1), 192 - - YU(IU+1),ZU(IU+1),EXP(-MIN(46.0D0,BETINT)) 193 - 10 CONTINUE 194 - *** Finally take the exponential. 195 - IF(BETINT.LT.0.0.OR.BETINT.GT.46.0)THEN 196 - FACTOR=1.0 197 - ELSE 198 - FACTOR=EXP(-BETINT) 199 - ENDIF 200 - IF(LDEBUG)THEN 201 - PRINT *,' ++++++ DLCAT2 DEBUG : EFIELD calls: ',NFC, 202 - - ', deepest stack: ',ISTACK 203 - PRINT *,' Final log estimate: ', 204 - - BETINT,' (crude estimate: ',CRUDE,').' 205 - ENDIF 206 - END 690 GARFIELD ================================================== P=DRIFTCAL D=DLCAT2 1 ============================ 0 + +DECK,DLCAT2. 1 - SUBROUTINE DLCAT2(FACTOR) 2 - *----------------------------------------------------------------------- 3 - * DLCAT2 - Routine returning the attachment losses for the current 4 - * drift line. The routine uses an adaptive Simpson style 5 - * integration. 6 - * VARIABLES : BETA. : Attachment coefficients (1,2 end; M middle) 7 - * BETINT : Integral of the attachment coefficient. 8 - * FACTOR : The attachment losses 9 - * (Last changed on 5/ 2/00.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,DRIFTLINE. 14.- +SEQ,CELLDATA. 15.- +SEQ,PRINTPLOT. 16 - REAL ATTVEC(MXLIST),BETA1,BETA2,BETAM,FACTOR,EXM,EYM,EZM,ETOTM, 17 - - EX,EY,EZ,ETOT,VOLT,GASATT,DRES,SCALE,BX,BY,BZ,BTOT, 18 - - BXM,BYM,BZM,BTOTM 19 - DOUBLE PRECISION XAUX1,XAUX2,YAUX1,YAUX2,STEP,BETINT, 20 - - XPOS1,XPOS2,XPOSM,YPOS1,YPOS2,YPOSM,ZPOSM,ZPOS1,ZPOS2, 21 - - TOTSTP,CRUDE,STACK(MXSTCK,4),VD(3) 22 - INTEGER LOCVEC(MXLIST),ISTACK,NSTACK,ILOCRS,NFC,ILOCM,IU,ILOC 23 - EXTERNAL GASATT 24 - *** Identify the routine 25 - IF(LIDENT)PRINT *,' /// ROUTINE DLCAT2 ///' 26 - *** Return straight away if there is only one data point. 27 - IF(NU.LE.1)THEN 28 - FACTOR=1.0 29 - RETURN 30 - ENDIF 31 - *** Obtain a very rough estimate of the result. 32 - CRUDE=0.0 33 - DO 100 IU=1,NU 34 - CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 35 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 36 - CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 37 - - BX,BY,BZ,BTOT) 38 - * Cheat in case the point is located inside a wire. 39 - IF(ILOC.GT.0.AND.ILOC.LE.MXWIRE)THEN 40 - DRES=D(ILOC) 41 - ILOCRS=ILOC 42 - D(ILOCRS)=0.0 43 - CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 44 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 45 - CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 46 - - BX,BY,BZ,BTOT) 47 - D(ILOCRS)=DRES 48 - IF(LDEBUG)PRINT *,' ++++++ DLCAT2 DEBUG : Drift-line', 49 - - ' data point in wire ',ILOCRS,' detected; d=0 fix.' 50 - ENDIF 51 - * In case this didn't help, just log the failure. 52 - LOCVEC(IU)=ILOC 53 - * Compute projection of the path. 54 - IF(IU.GT.1)THEN 55 - CALL DLCVEL((XU(IU-1)+XU(IU))/2,(YU(IU-1)+YU(IU))/2, 56 - - (ZU(IU-1)+ZU(IU))/2,VD,QPCHAR,IPTYPE,ILOC) 57 - IF(((XU(IU)-XU(IU-1))**2+(YU(IU)-YU(IU-1))**2+ 58 - - (ZU(IU)-ZU(IU-1))**2)* 59 - - (VD(1)**2+VD(2)**2+VD(3)**2).LE.0)THEN 60 - SCALE=0 61 - ELSE 62 - SCALE=((XU(IU)-XU(IU-1))*VD(1)+ 63 - - (YU(IU)-YU(IU-1))*VD(2)+(ZU(IU)-ZU(IU-1))*VD(3))/ 64 - - SQRT(((XU(IU)-XU(IU-1))**2+(YU(IU)-YU(IU-1))**2+ 65 - - (ZU(IU)-ZU(IU-1))**2)* 66 - - (VD(1)**2+VD(2)**2+VD(3)**2)) 67 - ENDIF 68 - C print *,' Scale = ',scale 69 - C print *,' x: ',xu(iu-1),xu(iu),vd(1) 70 - C print *,' y: ',yu(iu-1),yu(iu),vd(2) 71 - C print *,' z: ',zu(iu-1),zu(iu),vd(3) 72 - ENDIF 73 - * Compute attachment coefficients and step length. 74 - IF(POLAR)THEN 75 - ATTVEC(IU)=GASATT(EX/EXP(REAL(XU(IU))),EY/EXP(REAL(XU(IU))), 76 - - EZ,BX,BY,BZ) 77 - IF(IU.GT.1)THEN 78 - CALL CF2RTC(XU(IU),YU(IU),XAUX1,YAUX1,1) 79 - CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX2,YAUX2,1) 80 - STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 81 - - (ZU(IU)-ZU(IU-1))**2) 82 - ENDIF 83 - ELSE 84 - ATTVEC(IU)=GASATT(EX,EY,EZ,BX,BY,BZ) 85 - IF(IU.GT.1)STEP=SQRT((XU(IU)-XU(IU-1))**2+ 86 - - (YU(IU)-YU(IU-1))**2+(ZU(IU)-ZU(IU-1))**2) 1 690 P=DRIFTCAL D=DLCAT2 2 PAGE1074 87 - ENDIF 88 - IF(IU.GT.1)CRUDE=CRUDE+STEP*SCALE*(ATTVEC(IU)+ATTVEC(IU-1))/2.0 89 - 100 CONTINUE 90 - NFC=NU 91 - *** Ensure that the crude sum is positive. 92 - IF(CRUDE.LT.0)THEN 93 - PRINT *,' !!!!!! DLCAT2 WARNING : Negative attachment sum'// 94 - - ' in 1st order ; multiplication set to 1.' 95 - FACTOR=1 96 - RETURN 97 - ELSEIF(CRUDE.EQ.0)THEN 98 - FACTOR=1 99 - RETURN 100 - ENDIF 101 - *** Print a heading for the debugging output. 102 - IF(LDEBUG)THEN 103 - PRINT *,' ++++++ DLCAT2 DEBUG : Attachment integration', 104 - - ' debugging output follows:' 105 - PRINT *,' ' 106 - PRINT *,' IU loc XU(IU)'// 107 - - ' YU(IU)'// 108 - - ' ZU(IU)'// 109 - - ' number of electrons' 110 - PRINT *,' [cm]'// 111 - - ' [cm]'// 112 - - ' [cm]'// 113 - - ' [numeric]' 114 - PRINT *,' ' 115 - PRINT '(2(2X,I3),3(5X,E15.8))',1,LOCVEC(1),XU(1),YU(1),ZU(1) 116 - ENDIF 117 - *** Initialise the sum BETINT 118 - BETINT=0.0 119 - *** Loop over the whole drift-line. 120 - ISTACK=0 121 - DO 10 IU=1,NU-1 122 - IF(LOCVEC(IU).NE.0.OR.LOCVEC(IU+1).NE.0)GOTO 30 123 - * Initial values for the position. 124 - XPOS1=XU(IU) 125 - YPOS1=YU(IU) 126 - ZPOS1=ZU(IU) 127 - BETA1=ATTVEC(IU) 128 - XPOS2=XU(IU+1) 129 - YPOS2=YU(IU+1) 130 - ZPOS2=ZU(IU+1) 131 - BETA2=ATTVEC(IU+1) 132 - * Calculate the total steplength, in Cartesian coordinates. 133 - IF(POLAR)THEN 134 - CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) 135 - CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) 136 - TOTSTP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 137 - - (ZPOS2-ZPOS1)**2) 138 - ELSE 139 - TOTSTP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ 140 - - (ZPOS2-ZPOS1)**2) 141 - ENDIF 142 - * Compute projection of the path. 143 - CALL DLCVEL((XU(IU+1)+XU(IU))/2,(YU(IU+1)+YU(IU))/2, 144 - - (ZU(IU+1)+ZU(IU))/2,VD,QPCHAR,IPTYPE,ILOC) 145 - IF(((XU(IU+1)-XU(IU))**2+(YU(IU+1)-YU(IU))**2+ 146 - - (ZU(IU+1)-ZU(IU))**2)* 147 - - (VD(1)**2+VD(2)**2+VD(3)**2).LE.0)THEN 148 - SCALE=0 149 - ELSE 150 - SCALE=((XU(IU+1)-XU(IU))*VD(1)+ 151 - - (YU(IU+1)-YU(IU))*VD(2)+(ZU(IU+1)-ZU(IU))*VD(3))/ 152 - - SQRT(((XU(IU+1)-XU(IU))**2+(YU(IU+1)-YU(IU))**2+ 153 - - (ZU(IU+1)-ZU(IU))**2)* 154 - - (VD(1)**2+VD(2)**2+VD(3)**2)) 155 - ENDIF 156 - C print *,' Scale = ',scale 157 - * Return at this point of further refinement is needed. 158 - NSTACK=0 159 - 20 CONTINUE 160 - * Set the new middle point, to be used for comparison. 161 - XPOSM=0.5*(XPOS1+XPOS2) 162 - YPOSM=0.5*(YPOS1+YPOS2) 163 - ZPOSM=0.5*(ZPOS1+ZPOS2) 164 - * Compute the field and the attachment coeff. at the middle point. 165 - CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 166 - - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) 167 - CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 168 - - BXM,BYM,BZM,BTOTM) 169 - NFC=NFC+1 170 - * Cheat in case the point is located inside a wire. 171 - IF(ILOCM.GT.0.AND.ILOCM.LE.MXWIRE)THEN 172 - DRES=D(ILOCM) 173 - ILOCRS=ILOCM 174 - D(ILOCRS)=0.0 175 - CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 176 - - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) 177 - CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 178 - - BXM,BYM,BZM,BTOTM) 179 - NFC=NFC+1 180 - D(ILOCRS)=DRES 181 - IF(LDEBUG)PRINT *,' ++++++ DLCAT2 DEBUG : Intermediate', 182 - - ' point in wire ',ILOCRS,' detected; d=0 fix.' 183 - ENDIF 184 - * Skip this step in case the ILOC is not due to a wire. 185 - IF(ILOCM.NE.0)GOTO 30 186 - IF(POLAR)THEN 187 - BETAM=GASATT(EXM/EXP(REAL(XPOSM)),EYM/EXP(REAL(XPOSM)),EZM, 188 - - BXM,BYM,BZM) 189 - ELSE 190 - BETAM=GASATT(EXM,EYM,EZM,BXM,BYM,BZM) 191 - ENDIF 192 - * Compare first and second order estimates, divide if too large. 1 690 P=DRIFTCAL D=DLCAT2 3 PAGE1075 193 - IF(NSTACK.LT.MIN(MXSTCK,MXATTS).AND.EPSATI*CRUDE.LT. 194 - - TOTSTP*ABS(BETA1-2.0*BETAM+BETA2)/3.0)THEN 195 - NSTACK=NSTACK+1 196 - ISTACK=MAX(ISTACK,NSTACK) 197 - STACK(NSTACK,1)=XPOS2 198 - STACK(NSTACK,2)=YPOS2 199 - STACK(NSTACK,3)=ZPOS2 200 - STACK(NSTACK,4)=BETA2 201 - XPOS2=XPOSM 202 - YPOS2=YPOSM 203 - ZPOS2=ZPOSM 204 - BETA2=BETAM 205 - GOTO 20 206 - * No further subdevision is required, transform polar coordinates. 207 - ELSE 208 - * Make sure the distances are measured in cartesian coordinates. 209 - IF(POLAR)THEN 210 - CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) 211 - CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) 212 - STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 213 - - (ZPOS2-ZPOS1)**2) 214 - ELSE 215 - STEP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ 216 - - (ZPOS2-ZPOS1)**2) 217 - ENDIF 218 - * Add the new term to the integral. 219 - BETINT=BETINT+STEP*SCALE*(BETA1+4.0*BETAM+BETA2)/6.0 220 - * Continue with the next segment (if complete) or the next subsegment. 221 - XPOS1=XPOS2 222 - YPOS1=YPOS2 223 - ZPOS1=ZPOS2 224 - BETA1=BETA2 225 - IF(NSTACK.GT.0)THEN 226 - XPOS2=STACK(NSTACK,1) 227 - YPOS2=STACK(NSTACK,2) 228 - ZPOS2=STACK(NSTACK,3) 229 - BETA2=STACK(NSTACK,4) 230 - NSTACK=NSTACK-1 231 - GOTO 20 232 - ENDIF 233 - ENDIF 234 - * Continue with the next segment. 235 - 30 CONTINUE 236 - * Print some debugging output. 237 - IF(LDEBUG)PRINT '(2I5,4(5X,E15.8))',IU+1,LOCVEC(IU+1),XU(IU+1), 238 - - YU(IU+1),ZU(IU+1),EXP(-MIN(46.0D0,BETINT)) 239 - 10 CONTINUE 240 - *** Finally take the exponential. 241 - IF(BETINT.LT.0.0.OR.BETINT.GT.46.0)THEN 242 - FACTOR=1.0 243 - ELSE 244 - FACTOR=EXP(-BETINT) 245 - ENDIF 246 - IF(LDEBUG)THEN 247 - PRINT *,' ++++++ DLCAT2 DEBUG : EFIELD calls: ',NFC, 248 - - ', deepest stack: ',ISTACK 249 - PRINT *,' Final log estimate: ', 250 - - BETINT,' (crude estimate: ',CRUDE,').' 251 - ENDIF 252 - END 691 GARFIELD ================================================== P=DRIFTCAL D=DLCDIF 1 ============================ 0 + +DECK,DLCDIF. 1 - SUBROUTINE DLCDIF(SIGMA) 2 - *----------------------------------------------------------------------- 3 - * DLCDIF - Returns the diffusion. 4 - * (Last changed on 7/ 2/97.) 5 - *----------------------------------------------------------------------- 6 - C implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,GASDATA. 9.- +SEQ,DRIFTLINE. 10 - REAL SIGMA 11 - *** If the particle is an electron, compute as usual. 12 - IF(IPTYPE.EQ.1)THEN 13 - IF(GASOK(3).AND.GASOK(8))THEN 14 - CALL DLCDF2(SIGMA) 15 - ELSEIF(GASOK(3))THEN 16 - CALL DLCDF1(SIGMA) 17 - ELSE 18 - SIGMA=0.0 19 - ENDIF 20 - *** If the particle is an ion, return 0. 21 - ELSE 22 - SIGMA=0 23 - ENDIF 24 - END 692 GARFIELD ================================================== P=DRIFTCAL D=DLCDF1 1 ============================ 0 + +DECK,DLCDF1. 1 - SUBROUTINE DLCDF1(SIGMA) 2 - *----------------------------------------------------------------------- 3 - * DLCDF1 - Routine returning the integrated diffusion coefficient of 4 - * the current drift line. The routine uses an adaptive 5 - * Simpson integration. 6 - * VARIABLES : SIGMA. : Diffusion coefficients (1,2 end; M middle). 7 - * V. : Drift velocity (1,2: end points; M middle). 8 - * CRUDE : Crude estimate of SIGMA. 9 - * (Last changed on 4/ 2/00.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,DRIFTLINE. 1 692 P=DRIFTCAL D=DLCDF1 2 PAGE1076 14.- +SEQ,CELLDATA. 15.- +SEQ,PRINTPLOT. 16 - REAL SIGVEC(MXLIST),VELVEC(MXLIST),SIGMA,SIGMA1,SIGMA2, 17 - - SIGMAM,V1,V2,VM,EX,EY,EZ,ETOT,EXM,EYM,EZM,ETOTM,VOLT, 18 - - BX,BY,BZ,BTOT,BXM,BYM,BZM,BTOTM,DRES,GASDFL 19 - DOUBLE PRECISION XAUX1,XAUX2,YAUX1,YAUX2,STEP,SUM,XPOS1,XPOS2, 20 - - XPOSM,YPOS1,YPOS2,YPOSM,ZPOS1,ZPOS2,ZPOSM,TOTSTP,CRUDE, 21 - - STACK(MXSTCK,5),F1(3) 22 - INTEGER LOCVEC(MXLIST),ILOC,ILOC2,ILOCM,IU,ILOCRS,NSTACK,ISTACK, 23 - - NFC 24 - EXTERNAL GASDFL 25 - *** Identify the routine 26 - IF(LIDENT)PRINT *,' /// ROUTINE DLCDF1 ///' 27 - *** Return straight away if there is only one data point. 28 - IF(NU.LE.1)THEN 29 - SIGMA=0.0 30 - RETURN 31 - ENDIF 32 - *** Obtain a rough estimate of the result. 33 - CRUDE=0.0 34 - DO 100 IU=1,NU 35 - CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 36 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 37 - CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 38 - - BX,BY,BZ,BTOT) 39 - CALL DLCVEL(XU(IU),YU(IU),ZU(IU),F1,-1.0,1,ILOC2) 40 - * Cheat in case the point is located inside a wire. 41 - IF(ILOC.GT.0.AND.ILOC.LE.MXWIRE)THEN 42 - DRES=D(ILOC) 43 - ILOCRS=ILOC 44 - D(ILOCRS)=0.0 45 - CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 46 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 47 - CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 48 - - BX,BY,BZ,BTOT) 49 - CALL DLCVEL(XU(IU),YU(IU),ZU(IU),F1,-1.0,1,ILOC2) 50 - D(ILOCRS)=DRES 51 - IF(LDEBUG)PRINT *,' ++++++ DLCDF1 DEBUG : Drift-line', 52 - - ' data point in wire ',ILOCRS,' detected; d=0 fix.' 53 - ENDIF 54 - * Store the information for this point of the drift line. 55 - LOCVEC(IU)=ILOC 56 - IF(POLAR)THEN 57 - VELVEC(IU)=SQRT(F1(1)**2+F1(2)**2+F1(3)**2)*EXP(XU(IU)) 58 - SIGVEC(IU)=GASDFL(EX/EXP(REAL(XU(IU))), 59 - - EY/EXP(REAL(XU(IU))),EZ,BX,BY,BZ) 60 - IF(IU.GT.1)THEN 61 - CALL CF2RTC(XU(IU),YU(IU),XAUX1,YAUX1,1) 62 - CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX2,YAUX2,1) 63 - STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 64 - - (ZU(IU)-ZU(IU-1))**2) 65 - ENDIF 66 - ELSE 67 - VELVEC(IU)=SQRT(F1(1)**2+F1(2)**2+F1(3)**2) 68 - SIGVEC(IU)=GASDFL(EX,EY,EZ,BX,BY,BZ) 69 - IF(IU.GT.1)STEP=SQRT((XU(IU)-XU(IU-1))**2+ 70 - - (YU(IU)-YU(IU-1))**2+(ZU(IU)-ZU(IU-1))**2) 71 - ENDIF 72 - IF(IU.GT.1)THEN 73 - IF(VELVEC(IU)*VELVEC(IU-1).GT.0) 74 - - CRUDE=CRUDE+STEP*((SIGVEC(IU)/VELVEC(IU))**2+ 75 - - (SIGVEC(IU-1)/VELVEC(IU-1))**2)/2.0 76 - ENDIF 77 - 100 CONTINUE 78 - NFC=NU 79 - CRUDE=SQRT(CRUDE) 80 - *** Initialise the double precision copy of SIGMA: SUM. 81 - SUM=0.0 82 - *** Loop over the whole drift-line. 83 - ISTACK=0 84 - DO 10 IU=1,NU-1 85 - IF(LOCVEC(IU).NE.0.OR.LOCVEC(IU+1).NE.0)GOTO 10 86 - * Initial values for the position. 87 - XPOS1=XU(IU) 88 - YPOS1=YU(IU) 89 - ZPOS1=ZU(IU) 90 - V1=VELVEC(IU) 91 - SIGMA1=SIGVEC(IU) 92 - XPOS2=XU(IU+1) 93 - YPOS2=YU(IU+1) 94 - ZPOS2=ZU(IU+1) 95 - V2=VELVEC(IU+1) 96 - SIGMA2=SIGVEC(IU+1) 97 - * Calculate the total steplength, in Cartesian coordinates. 98 - IF(POLAR)THEN 99 - CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) 100 - CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) 101 - TOTSTP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 102 - - (ZPOS2-ZPOS1)**2) 103 - ELSE 104 - TOTSTP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ 105 - - (ZPOS2-ZPOS1)**2) 106 - ENDIF 107 - ** Return at this point of further refinement is needed. 108 - NSTACK=0 109 - 20 CONTINUE 110 - * Set the new middle point, to be used for comparison. 111 - XPOSM=0.5*(XPOS1+XPOS2) 112 - YPOSM=0.5*(YPOS1+YPOS2) 113 - ZPOSM=0.5*(ZPOS1+ZPOS2) 114 - * Compute field, diffusion and velocity at the middle point. 115 - CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 116 - - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) 117 - CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 118 - - BXM,BYM,BZM,BTOTM) 119 - CALL DLCVEL(XPOSM,YPOSM,ZPOSM,F1,-1.0,1,ILOC2) 1 692 P=DRIFTCAL D=DLCDF1 3 PAGE1077 120 - NFC=NFC+1 121 - * Cheat in case the point is located inside a wire. 122 - IF(ILOCM.GT.0.AND.ILOCM.LE.MXWIRE)THEN 123 - DRES=D(ILOCM) 124 - ILOCRS=ILOCM 125 - D(ILOCRS)=0.0 126 - CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 127 - - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) 128 - CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 129 - - BXM,BYM,BZM,BTOTM) 130 - CALL DLCVEL(XPOSM,YPOSM,ZPOSM,F1,-1.0,1,ILOC2) 131 - NFC=NFC+1 132 - D(ILOCRS)=DRES 133 - IF(LDEBUG)PRINT *,' ++++++ DLCDF1 DEBUG : Intermediate', 134 - - ' point in wire ',ILOCRS,' detected; d=0 fix.' 135 - ENDIF 136 - * In case this still didn't help, skip this step. 137 - IF(ILOCM.NE.0)GOTO 10 138 - * Otherwise compute drift speed and diffusion at intermediate point. 139 - IF(POLAR)THEN 140 - VM=SQRT(F1(1)**2+F1(2)**2+F1(3)**2)*EXP(XPOSM) 141 - SIGMAM=GASDFL(EXM/EXP(REAL(XPOSM)),EYM/EXP(REAL(XPOSM)),EZM, 142 - - BXM,BYM,BZM) 143 - ELSE 144 - VM=SQRT(F1(1)**2+F1(2)**2+F1(3)**2) 145 - SIGMAM=GASDFL(EXM,EYM,EZM,BXM,BYM,BZM) 146 - ENDIF 147 - * Prevent division by zero in the strange case the speed is 0. 148 - IF(V1*V2*VM.EQ.0.0.OR.SIGMA1*SIGMAM*SIGMA2.EQ.0.0)THEN 149 - PRINT *,' !!!!!! DLCDF1 WARNING : Drift velocity or', 150 - - ' diffusion = 0 detected; some points skipped.' 151 - GOTO 10 152 - ENDIF 153 - *** Compare first and second order estimates, divide if too large. 154 - IF(NSTACK.LT.MIN(MXSTCK,MXDIFS).AND.EPSDFI*CRUDE.LT. 155 - - ABS((SIGMA1/V1)**2-2.0*(SIGMAM/VM)**2+(SIGMA2/V2)**2)* 156 - - SQRT(TOTSTP*2.0/((SIGMA1/V1)**2+(SIGMA2/V2)**2))/6.0)THEN 157 - NSTACK=NSTACK+1 158 - ISTACK=MAX(ISTACK,NSTACK) 159 - STACK(NSTACK,1)=XPOS2 160 - STACK(NSTACK,2)=YPOS2 161 - STACK(NSTACK,5)=ZPOS2 162 - STACK(NSTACK,3)=V2 163 - STACK(NSTACK,4)=SIGMA2 164 - XPOS2=XPOSM 165 - YPOS2=YPOSM 166 - ZPOS2=ZPOSM 167 - V2=VM 168 - SIGMA2=SIGMAM 169 - GOTO 20 170 - ** No further subdevision is required, transform polar coordinates. 171 - ELSE 172 - * Make sure the distances are measured in cartesian coordinates. 173 - IF(POLAR)THEN 174 - CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) 175 - CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) 176 - STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 177 - - (ZPOS2-ZPOS1)**2) 178 - ELSE 179 - STEP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ 180 - - (ZPOS2-ZPOS1)**2) 181 - ENDIF 182 - * Add the new term to the integral. 183 - SUM=SUM+STEP* 184 - - ((SIGMA1/V1)**2+4.0*(SIGMAM/VM)**2+(SIGMA2/V2)**2)/6.0 185 - * Continue with the next segment (if complete) or the next subsegment. 186 - XPOS1=XPOS2 187 - YPOS1=YPOS2 188 - ZPOS1=ZPOS2 189 - V1=V2 190 - SIGMA1=SIGMA2 191 - IF(NSTACK.GT.0)THEN 192 - XPOS2=STACK(NSTACK,1) 193 - YPOS2=STACK(NSTACK,2) 194 - ZPOS2=STACK(NSTACK,5) 195 - V2=STACK(NSTACK,3) 196 - SIGMA2=STACK(NSTACK,4) 197 - NSTACK=NSTACK-1 198 - GOTO 20 199 - ENDIF 200 - ENDIF 201 - * Continue with the next segment. 202 - 10 CONTINUE 203 - *** Remember: we calculated the square of the diffusion coefficient. 204 - SIGMA=REAL(SQRT(SUM)) 205 - IF(LDEBUG)THEN 206 - PRINT *,' ++++++ DLCDF1 DEBUG : EFIELD calls: ',NFC, 207 - - ', deepest stack: ',ISTACK 208 - PRINT *,' Final estimate: ',SIGMA, 209 - - ' (crude estimate: ',CRUDE,').' 210 - ENDIF 211 - END 693 GARFIELD ================================================== P=DRIFTCAL D=DLCDF2 1 ============================ 0 + +DECK,DLCDF2. 1 - SUBROUTINE DLCDF2(DIFF) 2 - *----------------------------------------------------------------------- 3 - * DLCDF2 - Integrates both transverse and longitudinal diffusion over 4 - * the current drift line. 5 - * (Last changed on 4/ 2/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,DRIFTLINE. 1 693 P=DRIFTCAL D=DLCDF2 2 PAGE1078 10.- +SEQ,CONSTANTS. 11.- +SEQ,PRINTPLOT. 12.- +SEQ,CELLDATA. 13 - DOUBLE PRECISION COV(2,2),SUM(2,2),STEP,C,S,F1(3),F2(3),F3(3), 14 - - F4(3),SCL,SCT,EPS,TEMP,DL,DT,RHO2,SIZE,SLAST,SNOW,VLAST, 15 - - VNOW,SIGMA 16 - C double precision fl(3),templ 17 - REAL GASDFL,GASDFT,XWIRE,YWIRE,DWIRE,EX1,EY1,EZ1,E1, 18 - - BX1,BY1,BZ1,BTOT1,BX,BY,BZ,BTOT,DIFF, 19 - - EX2,EY2,EZ2,E2,BX2,BY2,BZ2,B2,EX,EY,EZ,ETOT,VOLT 20 - INTEGER ILOC,ILOC1,ILOC2,IWIRE,ILAST,I,IFAIL 21 - EXTERNAL GASDFL,GASDFT 22 - *** Identify the routine 23 - IF(LIDENT)PRINT *,' /// ROUTINE DLCDF2 ///' 24 - IF(LDEBUG)PRINT *,' ++++++ DLCDF2 DEBUG : Starting to sum'// 25 - - ' L&T diffusion, NU=',NU,' ISTAT=',ISTAT 26 - *** Assume the routine will fail. 27 - IFAIL=1 28 - *** Initialise some variables. 29 - DIFF=0 30 - TEMP=0 31 - SIZE=0 32 - ILAST=1 33 - F2(1)=0 34 - F2(2)=0 35 - F2(3)=0 36 - *** Verify that there are some steps. 37 - IF(NU.LT.2)THEN 38 - IF(LDEBUG)PRINT *,' ++++++ DLCDF2 DEBUG :'// 39 - - ' The drift line has no steps ; diffusion=0.' 40 - RETURN 41 - ENDIF 42 - *** Initialise the covariance matrix. 43 - SUM(1,1)=0 44 - SUM(1,2)=0 45 - SUM(2,1)=0 46 - SUM(2,2)=0 47 - *** Initialise the various quantities that are shifted through. 48 - CALL EFIELD(REAL(XU(1)),REAL(YU(1)),REAL(ZU(1)), 49 - - EX1,EY1,EZ1,E1,VOLT,0,ILOC1) 50 - CALL BFIELD(REAL(XU(1)),REAL(YU(1)),REAL(ZU(1)), 51 - - BX1,BY1,BZ1,BTOT1) 52 - CALL DLCVEL(XU(1),YU(1),ZU(1),F1,-1.0,1,ILOC2) 53 - IF(ILOC1.NE.0.OR.ILOC2.NE.0)THEN 54 - PRINT *,' !!!!!! DLCDF2 WARNING : Initial point on drift'// 55 - - ' line has unusual location codes ',ILOC1,ILOC2 56 - RETURN 57 - ENDIF 58 - *** Set the radius to zero temporarily for a drift line going to a wire. 59 - IF(ISTAT.GE.1.AND.ISTAT.LE.MXWIRE+NWIRE)THEN 60 - * Obtain the wire number. 61 - IF(ISTAT.GT.MXWIRE)THEN 62 - IWIRE=ISTAT-MXWIRE 63 - ELSE 64 - IWIRE=ISTAT 65 - ENDIF 66 - * Store the wire diameter and set temporarily to zero. 67 - DWIRE=D(IWIRE) 68 - D(IWIRE)=0.0 69 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', 70 - - '' Temporarily setting the diameter of wire '',I4, 71 - - '' to 0.'')') IWIRE 72 - * Locate the nearest replica of the wire. at the end point. 73 - XWIRE=X(IWIRE) 74 - IF(PERX)XWIRE=XWIRE-SX*ANINT((XWIRE-XU(NU))/SX) 75 - YWIRE=Y(IWIRE) 76 - IF(PERY)YWIRE=YWIRE-SY*ANINT((YWIRE-YU(NU))/SY) 77 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', 78 - - '' Wire replica nearest to end point: ('',E15.8,'','', 79 - - E15.8,'').'')') XWIRE,YWIRE 80 - ELSE 81 - IWIRE=0 82 - DWIRE=0 83 - XWIRE=0 84 - YWIRE=0 85 - ENDIF 86 - *** Loop over the steps 87 - C templ=0.0 88 - C call efield(real(xu(1)),real(yu(1)),real(zu(1)), 89 - C - ex,ey,ez,etot,volt,0,iloc) 90 - C call bfield(real(xu(1)),real(yu(1)),real(zu(1)), 91 - C - bx,by,bz,btot) 92 - C call dlcvel(xu(1),yu(1),zu(1),fl,-1.0,1,iloc2) 93 - C vlast=sqrt(fl(1)**2+fl(2)**2+fl(3)**2) 94 - C slast=gasdfl(ex,ey,ez,bx,by,bz) 95 - DO 10 I=1,NU-1 96 - * Get pure longitudinal diffusion. 97 - C call efield(real(xu(i+1)),real(yu(i+1)),real(zu(i+1)), 98 - C - ex,ey,ez,etot,volt,0,iloc) 99 - C call bfield(real(xu(i+1)),real(yu(i+1)),real(zu(i+1)), 100 - C - bx,by,bz,btot) 101 - C call dlcvel(xu(i+1),yu(i+1),zu(i+1),fl,-1.0,1,iloc2) 102 - C vnow=sqrt(fl(1)**2+fl(2)**2+fl(3)**2) 103 - C snow=gasdfl(ex,ey,ez,bx,by,bz) 104 - C step=sqrt((xu(i+1)-xu(i))**2+(yu(i+1)-yu(i))**2+ 105 - C - (zu(i+1)-zu(i))**2) 106 - C templ=templ+step*((snow/vnow)**2+(slast/vlast)**2)/2 107 - C vlast=vnow 108 - C slast=snow 109 - * Stop this integration if the cloud is less than n radii from a wire. 110 - IF(IWIRE.GT.0.AND.MDF2.NE.0.AND.RDF2*SIZE.GT.MAX(0.0D0, 111 - - SQRT((XU(I+1)-XWIRE)**2+(YU(I+1)-YWIRE)**2)-DWIRE/2))THEN 112 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', 113 - - '' n * Size > Distance at IU='',I3,''/'',I3/25X, 114 - - '' Size = '',E15.8,'' [cm],''/25X, 115 - - '' Distance = '',E15.8,'' [cm].'')') 1 693 P=DRIFTCAL D=DLCDF2 3 PAGE1079 116 - - I+1,NU,SIZE,SQRT((XU(I+1)-XWIRE)**2+(YU(I+1)-YWIRE)**2) 117 - GOTO 20 118 - ENDIF 119 - * Length and orientation of the step. 120 - STEP=SQRT((XU(I+1)-XU(I))**2+(YU(I+1)-YU(I))**2+ 121 - - (ZU(I+1)-ZU(I))**2) 122 - IF(STEP.LE.0.0.OR.STEP.LE.1.0E-6*DWIRE)THEN 123 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', 124 - - '' Skipping step '',I3,'' of length '',E15.8)') 125 - - I,STEP 126 - GOTO 10 127 - ENDIF 128 - C=(XU(I+1)-XU(I))/STEP 129 - S=(YU(I+1)-YU(I))/STEP 130 - * Transverse diffusion scaling factor. 131 - EPS=1.0E-3*(1+ABS(XU(I))+ABS(YU(I))) 132 - CALL DLCVEL(XU(I)-S*EPS,YU(I)+C*EPS,ZU(I),F3,-1.0,1,ILOC1) 133 - CALL DLCVEL(XU(I)+S*EPS,YU(I)-C*EPS,ZU(I),F4,-1.0,1,ILOC2) 134 - IF(ILOC1.NE.0.OR.ILOC2.NE.0)THEN 135 - PRINT *,' !!!!!! DLCDF2 WARNING : Unable to compute'// 136 - - ' transverse scaling factor; set to 1.' 137 - SCT=1.0 138 - ELSE 139 - SCT=1+(TU(I+1)-TU(I))*(-S*F3(1)+C*F3(2)+S*F4(1)-C*F4(2))/ 140 - - (2*EPS) 141 - ENDIF 142 - IF(SCT.LE.0)THEN 143 - PRINT *,' !!!!!! DLCDF2 WARNING : Transverse scaling'// 144 - - ' factor < 0 detected; set to 1.' 145 - SCT=1.0 146 - ENDIF 147 - * Longitudinal scaling factor. 148 - CALL DLCVEL(XU(I+1),YU(I+1),ZU(I+1),F2,-1.0,1,ILOC2) 149 - IF(ILOC2.NE.0)THEN 150 - PRINT *,' !!!!!! DLCDF2 WARNING : Final point has unusual'// 151 - - ' location code; summing terminated.' 152 - GOTO 20 153 - ELSEIF(SQRT(F1(1)**2+F1(2)**2+F1(3)**2).EQ.0.OR. 154 - - SQRT(F2(1)**2+F2(2)**2+F2(3)**2).EQ.0)THEN 155 - PRINT *,' !!!!!! DLCDF2 WARNING : Longitudinal velocity'// 156 - - ' of 0 detected.' 157 - SCL=1.0 158 - ELSE 159 - SCL=SQRT(F2(1)**2+F2(2)**2+F2(3)**2)/ 160 - - SQRT(F1(1)**2+F1(2)**2+F1(3)**2) 161 - ENDIF 162 - * Compute the field at the end point in view of getting diffusions. 163 - CALL EFIELD(REAL(XU(I+1)),REAL(YU(I+1)),REAL(ZU(I+1)), 164 - - EX2,EY2,EZ2,E2,VOLT,0,ILOC) 165 - CALL BFIELD(REAL(XU(I+1)),REAL(YU(I+1)),REAL(ZU(I+1)), 166 - - BX2,BY2,BZ2,B2) 167 - IF(ILOC.NE.0)THEN 168 - IF(I.EQ.NU-1)THEN 169 - GOTO 20 170 - ELSE 171 - PRINT *,' !!!!!! DLCDF2 WARNING : Intermediate point'// 172 - - ' has unusual location code ',ILOC 173 - GOTO 20 174 - ENDIF 175 - ENDIF 176 - * Obtain longitudinal and transverse diffusion at this step. 177 - DL=SQRT(0.5*(GASDFL(EX1,EY1,EZ1,BX1,BY1,BZ1)**2+ 178 - - (GASDFL(EX2,EY2,EZ2,BX2,BY2,BZ2)/SCL)**2)) 179 - DT=(GASDFT(EX1,EY1,EZ1,BX1,BY1,BZ1)+ 180 - - GASDFT(EX2,EY2,EZ2,BX2,BY2,BZ2))/2 181 - * Compensate diffusion for step length. 182 - DL=DL*SQRT(STEP) 183 - DT=DT*SQRT(STEP) 184 - * Add this step to the sum. 185 - SUM(1,1)=SUM(1,1)+C**2*DL**2+S**2*DT**2 186 - SUM(1,2)=SUM(1,2)+C*S*(DT**2-DL**2) 187 - SUM(2,1)=SUM(2,1)+C*S*(DT**2-DL**2) 188 - SUM(2,2)=SUM(2,2)+C**2*DT**2+S**2*DL**2 189 - * Align with the drift line, rotating inverted matrix. 190 - COV(1,1)=C**2*SUM(1,1)-C*S*SUM(1,2)-C*S*SUM(2,1)+S**2*SUM(2,2) 191 - COV(1,2)=C**2*SUM(2,1)-C*S*SUM(2,2)+C*S*SUM(1,1)-S**2*SUM(1,2) 192 - COV(2,1)=C**2*SUM(1,2)-C*S*SUM(2,2)+C*S*SUM(1,1)-S**2*SUM(2,1) 193 - COV(2,2)=C**2*SUM(2,2)+C*S*SUM(1,2)+C*S*SUM(2,1)+S**2*SUM(1,1) 194 - * Debugging output. 195 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', 196 - - '' Transverse scaling: '',E15.8/ 197 - - 26X,''Longitudinal scaling: '',E15.8)') SCT,SCL 198 - * Update the covariance matrix. 199 - COV(1,1)=COV(1,1)*SCL**2 200 - COV(1,2)=COV(1,2)*SCL*SCT 201 - COV(2,1)=COV(2,1)*SCT*SCL 202 - COV(2,2)=COV(2,2)*SCT**2 203 - * Evaluate the correlation coefficient. 204 - IF(COV(1,1)*COV(2,2).LT.COV(1,2)*COV(2,1))THEN 205 - RHO2=1.0 206 - PRINT *,' !!!!!! DLCDF2 WARNING : Correlation > 1 ; set'// 207 - - ' to 1.' 208 - ELSEIF(COV(1,1)*COV(2,2).EQ.0)THEN 209 - RHO2=0.0 210 - ELSE 211 - RHO2=(COV(1,2)*COV(2,1))/(COV(1,1)*COV(2,2)) 212 - ENDIF 213 - * Keep continuously track of longitudinal component. 214 - TEMP=COV(1,1)*(1-RHO2)/(F2(1)**2+F2(2)**2+F2(3)**2) 215 - * Realign the matrix with the coordinate system. 216 - SUM(1,1)=C**2*COV(1,1)+C*S*COV(1,2)+C*S*COV(2,1)+S**2*COV(2,2) 217 - SUM(1,2)=C**2*COV(2,1)+C*S*COV(2,2)-C*S*COV(1,1)-S**2*COV(1,2) 218 - SUM(2,1)=C**2*COV(1,2)+C*S*COV(2,2)-C*S*COV(1,1)-S**2*COV(2,1) 219 - SUM(2,2)=C**2*COV(2,2)-C*S*COV(1,2)-C*S*COV(2,1)+S**2*COV(1,1) 220 - * And monitor the size of the cloud. 221 - SIZE=SQRT(MAX(0.0D0,COV(1,1)*(1-RHO2),COV(2,2)*(1-RHO2))) 1 693 P=DRIFTCAL D=DLCDF2 4 PAGE1080 222 - * Debugging output: 223 - C IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG : Matrix'', 224 - C - '' at (x,y,z)='',3(E12.5,1X),'' step '',I3,'':''/ 225 - C - 26X,2E15.8/26X,2E15.8/ 226 - C - 26X,''Longitudinal size = '',E15.8,'' [cm]''/ 227 - C - 26X,''Transverse size = '',E15.8,'' [cm]''/ 228 - C - 26X,''Correlation = '',E15.8/ 229 - C - 26X,''Start speed = '',E15.8,'' [cm/microsec]''/ 230 - C - 26X,''End speed = '',E15.8,'' [cm/microsec]''/ 231 - C - 26X,''Diffusion L + T = '',E15.8,'' [microsec]''/ 232 - C - 26X,''Diffusion L only = '',E15.8,'' [microsec]'')') 233 - C - XU(I),YU(I),ZU(I),I,SUM(1,1),SUM(1,2),SUM(2,1),SUM(2,2), 234 - C - SQRT(MAX(0.0D0,COV(1,1)*(1-RHO2))), 235 - C - SQRT(MAX(0.0D0,COV(2,2)*(1-RHO2))), 236 - C - SQRT(RHO2),SQRT(F1(1)**2+F1(2)**2+F1(3)**2), 237 - C - SQRT(F2(1)**2+F2(2)**2+F2(3)**2),SQRT(TEMP),SQRT(TEMPL) 238 - * Shift some parameters for next iteration. 239 - EX1=EX2 240 - EY1=EY2 241 - EZ1=EZ2 242 - F1(1)=F2(1) 243 - F1(2)=F2(2) 244 - F1(3)=F2(3) 245 - * Remember that we carried this step out. 246 - ILAST=I+1 247 - 10 CONTINUE 248 - *** Continue here in case of aborted integration. 249 - 20 CONTINUE 250 - *** Drift line hits the wire, first no treatment (longitudinal). 251 - IF(IWIRE.GT.0.AND.(MDF2.EQ.0.OR.MDF2.EQ.3))THEN 252 - * Restore wire diameter. 253 - D(IWIRE)=DWIRE 254 - ** Integration over the cloud, either full or with constant velocity. 255 - ELSEIF(IWIRE.GT.0.AND.(MDF2.EQ.1.OR.MDF2.EQ.2))THEN 256 - * Output estimate sofar. 257 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', 258 - - '' Diffusion estimates before wire stepping''/25X, 259 - - '' Longitudinal component only: '',E15.8, 260 - - '' [microsec]'')') SQRT(MAX(0.0D0,TEMP)) 261 - * Estimate the spread in distances from the cloud. 262 - CALL DLCDIW(SUM,XU(ILAST),YU(ILAST),ZU(ILAST), 263 - - XWIRE,YWIRE,DWIRE,SIGMA,IFAIL) 264 - TEMP=SIGMA**2 265 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', 266 - - '' Diffusion estimates during wire stepping''/25X, 267 - - '' Standard deviation cloud size: '',E15.8, 268 - - '' [microsec]'')') SQRT(MAX(0.0D0,TEMP)) 269 - * Add the purely longitudinal term for the last step. 270 - CALL EFIELD(REAL(XU(ILAST)),REAL(YU(ILAST)),REAL(ZU(ILAST)), 271 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 272 - CALL BFIELD(REAL(XU(ILAST)),REAL(YU(ILAST)),REAL(ZU(ILAST)), 273 - - BX,BY,BZ,BTOT) 274 - CALL DLCVEL(XU(ILAST),YU(ILAST),ZU(ILAST),F1,-1.0,1,ILOC1) 275 - VLAST=SQRT(MAX(0.0D0,F1(1)**2+F1(2)**2+F1(3)**2)) 276 - SLAST=GASDFL(EX,EY,EZ,BX,BY,BZ) 277 - DO 30 I=ILAST,NU-1 278 - CALL EFIELD(REAL(XU(I+1)),REAL(YU(I+1)),REAL(ZU(I+1)), 279 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 280 - CALL BFIELD(REAL(XU(I+1)),REAL(YU(I+1)),REAL(ZU(I+1)), 281 - - BX,BY,BZ,BTOT) 282 - CALL DLCVEL(XU(I+1),YU(I+1),ZU(I+1),F2,-1.0,1,ILOC2) 283 - VNOW=SQRT(MAX(0.0D0,F2(1)**2+F2(2)**2+F2(3)**2)) 284 - SNOW=GASDFL(EX,EY,EZ,BX,BY,BZ) 285 - STEP=SQRT((XU(I+1)-XU(I))**2+(YU(I+1)-YU(I))**2+ 286 - - (ZU(I+1)-ZU(I))**2) 287 - IF(VNOW.GT.0.AND.VLAST.GT.0) 288 - - TEMP=TEMP+STEP*((SNOW/VNOW)**2+(SLAST/VLAST)**2)/2 289 - VLAST=VNOW 290 - SLAST=SNOW 291 - 30 CONTINUE 292 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', 293 - - '' Diffusion estimates after wire stepping''/25X, 294 - - '' Including long diff last step: '',E15.8, 295 - - '' [microsec]'')') SQRT(MAX(0.0D0,TEMP)) 296 - * Restore the wire diameter. 297 - D(IWIRE)=DWIRE 298 - ** Take the largest axis (useful if there is a B field). 299 - ELSEIF(IWIRE.GT.0.AND.MDF2.EQ.4)THEN 300 - * Output estimate sofar. 301 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', 302 - - '' Diffusion estimate from longitudinal''/25X, 303 - - '' component only: '',E15.8, 304 - - '' [microsec]'')') SQRT(MAX(0.0D0,TEMP)) 305 - * Compute largest dimension of the cloud, first align the cloud. 306 - IF((SUM(2,2)-SUM(1,1))**2+(SUM(1,2)+SUM(2,1))**2.GT.0)THEN 307 - C=SQRT(0.5*(1+(SUM(2,2)-SUM(1,1))/ 308 - - SQRT((SUM(2,2)-SUM(1,1))**2+ 309 - - (SUM(1,2)+SUM(2,1))**2))) 310 - S=SIGN(SQRT(1-C**2),SUM(1,2)+SUM(2,1)) 311 - ELSE 312 - C=1 313 - S=0 314 - ENDIF 315 - * Determine maximum cloud cross section. 316 - SIZE=MAX(SQRT(MAX(0.0D0,C**2*SUM(1,1)-C*S*SUM(1,2)- 317 - - C*S*SUM(2,1)+S**2*SUM(2,2))), 318 - - SQRT(MAX(0.0D0,C**2*SUM(2,2)+C*S*SUM(1,2)+ 319 - - C*S*SUM(2,1)+S**2*SUM(1,1)))) 320 - * Compute the drift velocity at the last point. 321 - CALL EFIELD(REAL(XU(ILAST)),REAL(YU(ILAST)),REAL(ZU(ILAST)), 322 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 323 - CALL BFIELD(REAL(XU(ILAST)),REAL(YU(ILAST)),REAL(ZU(ILAST)), 324 - - BX,BY,BZ,BTOT) 325 - CALL DLCVEL(XU(ILAST),YU(ILAST),ZU(ILAST),F1,-1.0,1,ILOC1) 326 - VLAST=SQRT(MAX(0.0D0,F1(1)**2+F1(2)**2+F1(3)**2)) 327 - SLAST=GASDFL(EX,EY,EZ,BX,BY,BZ) 1 693 P=DRIFTCAL D=DLCDF2 5 PAGE1081 328 - * Compensate size for speed. 329 - IF(VLAST.LE.0.0)THEN 330 - PRINT *,' !!!!!! DLCDF2 WARNING : End point speed'// 331 - - ' before wire stepping zero; diffusion=0.' 332 - TEMP=0 333 - ELSE 334 - TEMP=(SIZE/VLAST)**2 335 - ENDIF 336 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', 337 - - '' Diffusion estimates from largest cloud''/25X, 338 - - '' dimension: '',E15.8,'' [microsec]'')') 339 - - SQRT(MAX(0.0D0,TEMP)) 340 - * Add the purely longitudinal term for the last step. 341 - DO 40 I=ILAST,NU-1 342 - CALL EFIELD(REAL(XU(I+1)),REAL(YU(I+1)),REAL(ZU(I+1)), 343 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 344 - CALL BFIELD(REAL(XU(I+1)),REAL(YU(I+1)),REAL(ZU(I+1)), 345 - - BX,BY,BZ,BTOT) 346 - CALL DLCVEL(XU(I+1),YU(I+1),ZU(I+1),F2,-1.0,1,ILOC2) 347 - VNOW=SQRT(MAX(0.0D0,F2(1)**2+F2(2)**2+F2(3)**2)) 348 - SNOW=GASDFL(EX,EY,EZ,BX,BY,BZ) 349 - STEP=SQRT((XU(I+1)-XU(I))**2+(YU(I+1)-YU(I))**2+ 350 - - (ZU(I+1)-ZU(I))**2) 351 - IF(VNOW.GT.0.AND.VLAST.GT.0) 352 - - TEMP=TEMP+STEP*((SNOW/VNOW)**2+(SLAST/VLAST)**2)/2 353 - VLAST=VNOW 354 - SLAST=SNOW 355 - 40 CONTINUE 356 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', 357 - - '' Diffusion estimates after wire stepping''/25X, 358 - - '' Including long diff last step: '',E15.8, 359 - - '' [microsec]'')') SQRT(MAX(0.0D0,TEMP)) 360 - * Restore the wire diameter. 361 - D(IWIRE)=DWIRE 362 - ** Other termination codes, not valid. 363 - ELSEIF(IWIRE.GT.0)THEN 364 - * Issue warning. 365 - PRINT *,' !!!!!! DLCDF2 WARNING : Unknown integration'// 366 - - ' code (',MDF2,') received; program bug.' 367 - * Restore wire diameter. 368 - D(IWIRE)=DWIRE 369 - ENDIF 370 - *** Integration done, retrieve the result we accumulated. 371 - IF(TEMP.LT.0.0)THEN 372 - PRINT *,' !!!!!! DLCDF2 WARNING : Final longitudinal'// 373 - - ' component < 0 ; diffusion=0.' 374 - RETURN 375 - ENDIF 376 - DIFF=SQRT(TEMP) 377 - *** Things seem to have worked. 378 - IFAIL=0 379 - END 694 GARFIELD ================================================== P=DRIFTCAL D=DLCDIW 1 ============================ 0 + +DECK,DLCDIW. 1 - SUBROUTINE DLCDIW(COV,XC1,YC1,ZC1,XW1,YW1,DW1,SIGMA,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * DLCDIW - Integration of the time a cloud needs to reach a wire. 4 - * (Last changed on 8/11/95.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,DRIFTLINE. 10 - DOUBLE PRECISION X(2),COV(2,2),MAT(2,2),XW,YW,DW,XC,YC,ZC,SIGMA, 11 - - XC1,YC1,ZC1,C,S,FCENT,FC(3),ST0,ST1,ST2,DGMLT2,SIG1,SIG2,DET 12 - INTEGER IFAIL,ILOC 13 - REAL XW1,YW1,DW1 14 - EXTERNAL DGMLT2,FDIF2N,FDIF2L,FDIF2Q 15 - COMMON /DF2DAT/ MAT,SIG1,SIG2,DET,XW,YW,DW,XC,YC,ZC,C,S,FCENT 16 - *** Assume the routine will work. 17 - IFAIL=0 18 - *** Determine a rotation that aligns the cloud with the axes. 19 - IF(ABS(COV(1,2)+COV(2,1)).LE.1E-8*ABS(COV(2,2)-COV(1,1)))THEN 20 - C=1 21 - S=0 22 - ELSEIF((COV(2,2)-COV(1,1))**2+(COV(1,2)+COV(2,1))**2.GT.0)THEN 23 - C=SQRT(0.5*(1+(COV(2,2)-COV(1,1))/ 24 - - SQRT((COV(2,2)-COV(1,1))**2+(COV(1,2)+COV(2,1))**2))) 25 - S=SIGN(SQRT(1-C**2),COV(1,2)+COV(2,1)) 26 - ELSE 27 - C=1 28 - S=0 29 - ENDIF 30 - *** Rotate the covariance matrix. 31 - MAT(1,1)=C**2*COV(1,1)-C*S*COV(1,2)-C*S*COV(2,1)+S**2*COV(2,2) 32 - MAT(1,2)=C**2*COV(2,1)-C*S*COV(2,2)+C*S*COV(1,1)-S**2*COV(1,2) 33 - MAT(2,1)=C**2*COV(1,2)-C*S*COV(2,2)+C*S*COV(1,1)-S**2*COV(2,1) 34 - MAT(2,2)=C**2*COV(2,2)+C*S*COV(1,2)+C*S*COV(2,1)+S**2*COV(1,1) 35 - IF(MAT(1,1).LE.0.0.OR.MAT(2,2).LE.0.0)THEN 36 - PRINT *,' !!!!!! DLCDIW WARNING : Covariance matrix'// 37 - - ' (see below) is 1-dimensional; zero time spread.' 38 - PRINT *,' Aligned matrix: ',MAT(1,1),MAT(1,2) 39 - PRINT *,' ',MAT(2,1),MAT(2,2) 40 - print *,' Raw matrix: ',cov(1,1),cov(1,2) 41 - print *,' ',cov(2,1),cov(2,2) 42 - print *,' cos/sin: ',c,s 43 - print *,' Wire (x,y,d): ',xw1,yw1,dw1 44 - print *,' Cloud (x,y,z): ',xc1,yc1,zc1 45 - SIGMA=0 46 - IFAIL=1 47 - RETURN 48 - ENDIF 49 - *** Shift wire position to the rotated frame with cloud at (0,0), 50 - XW=+C*(XW1-XC1)+S*(YW1-YC1) 1 694 P=DRIFTCAL D=DLCDIW 2 PAGE1082 51 - YW=-S*(XW1-XC1)+C*(YW1-YC1) 52 - * simply transfer the wire diameter, 53 - DW=DW1 54 - * but keep the original cluster location for speed calculations. 55 - XC=XC1 56 - YC=YC1 57 - ZC=ZC1 58 - *** Prepare correlation and marginal distribution. 59 - SIG1=SQRT(MAT(1,1)) 60 - SIG2=SQRT(MAT(2,2)) 61 - DET=MAT(2,2)*MAT(1,1)-MAT(1,2)*MAT(2,1) 62 - IF(DET.EQ.0.0)THEN 63 - PRINT *,' DLCDIW WARNING : Covariance matrix is singular'// 64 - - ' ; time spread set to zero.' 65 - SIGMA=0 66 - IFAIL=1 67 - RETURN 68 - ENDIF 69 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDIW DEBUG : Rotation'', 70 - - '' angles: cos='',F10.3,'', sin='',F10.3/25X, 71 - - '' Cloud dimensions: ('',E15.8,'','',E15.8,'').'')') 72 - - C,S,SIG1,SIG2 73 - *** Compute central velocity. 74 - CALL DLCVEL(XC,YC,ZC,FC,-1.0,1,ILOC) 75 - FCENT=SQRT(FC(1)**2+FC(2)**2) 76 - IF(MDF2.EQ.2.AND.FCENT.LE.0)THEN 77 - PRINT *,' DLCDIW WARNING : Central velocity is zero;'// 78 - - ' time spread set to zero.' 79 - SIGMA=0 80 - IFAIL=1 81 - RETURN 82 - ENDIF 83 - *** Perform integration. 84 - ST0=DGMLT2(FDIF2N,-5*SIG2,+5*SIG2,5,6,X) 85 - ST1=DGMLT2(FDIF2L,-5*SIG2,+5*SIG2,5,6,X) 86 - ST2=DGMLT2(FDIF2Q,-5*SIG2,+5*SIG2,5,6,X) 87 - IF(LDEBUG)THEN 88 - WRITE(LUNOUT,'('' ++++++ DLCDIW DEBUG : S0='',E15.8, 89 - - '' S1='',E15.8,'' S2='',E15.8)') ST0,ST1,ST2 90 - ENDIF 91 - IF(ST1**2.LE.ST2*ST0)THEN 92 - SIGMA=SQRT(ST2-ST1**2/ST0)/ST0 93 - ELSE 94 - PRINT *,' DLCDIW WARNING : Time variance < 0'// 95 - - ' ; time spread set to zero.' 96 - SIGMA=0 97 - IFAIL=1 98 - ENDIF 99 - END 695 GARFIELD ================================================== P=DRIFTCAL D=FDIF2N 1 ============================ 0 + +DECK,FDIF2N. 1 - SUBROUTINE FDIF2N(M,U2,F2,X) 2 - *----------------------------------------------------------------------- 3 - * FDIF2N - One of 2 auxiliary routines for integrating W 4 - * (Last changed on 26/ 2/95.) 5 - *----------------------------------------------------------------------- 6 - C implicit none 7 - IMPLICIT DOUBLE PRECISION(A-H,O-Z) 8 - DOUBLE PRECISION U2(*),F2(*),X(2),MAT(2,2) 9 - COMMON /DF2DAT/ MAT,SIG1,SIG2,DET,XW,YW,DW,XC,YC,ZC,C,S,FCENT 10 - EXTERNAL FDIF1N,DGMLT1 11 - *** Loop over the positions. 12 - DO 10 L=1,M 13 - X(2)=U2(L) 14 - F2(L)=DGMLT1(FDIF1N,-5*SIG1,5*SIG1,5,6,X) 15 - 10 CONTINUE 16 - END 696 GARFIELD ================================================== P=DRIFTCAL D=FDIF1N 1 ============================ 0 + +DECK,FDIF1N. 1 - SUBROUTINE FDIF1N(M,U1,F1,X) 2 - *----------------------------------------------------------------------- 3 - * FDIF1N - One of 2 auxiliary routines for integrating t_mean 4 - * (Last changed on 26/ 2/95.) 5 - *----------------------------------------------------------------------- 6 - C implicit none 7 - IMPLICIT DOUBLE PRECISION(A-H,O-Z) 8.- +SEQ,CONSTANTS. 9 - DOUBLE PRECISION U1(*),F1(*),X(2),MAT(2,2) 10 - COMMON /DF2DAT/ MAT,SIG1,SIG2,DET,XW,YW,DW,XC,YC,ZC,C,S,FCENT 11 - *** Loop over the positions. 12 - DO 10 L=1,M 13 - X(1)=U1(L) 14 - ARG=-0.5*(X(1)**2*MAT(2,2)+X(2)**2*MAT(1,1)- 15 - - 2*X(1)*X(2)*MAT(1,2))/DET 16 - IF(ARG.LT.-50)THEN 17 - W=0.0 18 - ELSE 19 - W=EXP(ARG)/(2*PI*SQRT(DET)) 20 - ENDIF 21 - F1(L)=W 22 - 10 CONTINUE 23 - END 697 GARFIELD ================================================== P=DRIFTCAL D=FDIF2L 1 ============================ 0 + +DECK,FDIF2L. 1 - SUBROUTINE FDIF2L(M,U2,F2,X) 2 - *----------------------------------------------------------------------- 3 - * FDIF2L - One of 2 auxiliary routines for integrating t_mean 4 - * (Last changed on 25/ 2/95.) 5 - *----------------------------------------------------------------------- 6 - C implicit none 1 697 P=DRIFTCAL D=FDIF2L 2 PAGE1083 7 - IMPLICIT DOUBLE PRECISION(A-H,O-Z) 8 - DOUBLE PRECISION U2(*),F2(*),X(2),MAT(2,2) 9 - COMMON /DF2DAT/ MAT,SIG1,SIG2,DET,XW,YW,DW,XC,YC,ZC,C,S,FCENT 10 - EXTERNAL FDIF1L,DGMLT1 11 - *** Loop over the positions. 12 - DO 10 L=1,M 13 - * Copy the y component of the position. 14 - X(2)=U2(L) 15 - * Evaluate the integral over x. 16 - F2(L)=DGMLT1(FDIF1L,-5*SIG1,5*SIG1,5,6,X) 17 - 10 CONTINUE 18 - END 698 GARFIELD ================================================== P=DRIFTCAL D=FDIF1L 1 ============================ 0 + +DECK,FDIF1L. 1 - SUBROUTINE FDIF1L(M,U1,F1,X) 2 - *----------------------------------------------------------------------- 3 - * FDIF1L - One of 2 auxiliary routines for integrating t_mean 4 - * (Last changed on 23/ 5/95.) 5 - *----------------------------------------------------------------------- 6 - C implicit none 7 - IMPLICIT DOUBLE PRECISION(A-H,O-Z) 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CONSTANTS. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,DRIFTLINE. 12 - DOUBLE PRECISION U1(*),F1(*),X(2),MAT(2,2),FD(3) 13 - COMMON /DF2DAT/ MAT,SIG1,SIG2,DET,XW,YW,DW,XC,YC,ZC,C,S,FCENT 14 - *** Loop over the positions. 15 - DO 10 L=1,M 16 - * Copy the x component of the position. 17 - X(1)=U1(L) 18 - * Evaluate the Gaussian weight factor. 19 - ARG=-0.5*(X(1)**2*MAT(2,2)+X(2)**2*MAT(1,1)- 20 - - X(2)*X(1)*MAT(1,2)-X(1)*X(2)*MAT(2,1))/DET 21 - IF(ARG.LT.-50)THEN 22 - W=0.0 23 - ELSE 24 - W=EXP(ARG)/(2*PI*SQRT(DET)) 25 - ENDIF 26 - * Evaluate the drift velocity. 27 - IF(MDF2.EQ.1)THEN 28 - CALL DLCVEL(XC+C*X(1)-S*X(2),YC+S*X(1)+C*X(2),ZC, 29 - - FD,-1.0,1,ILOC) 30 - VD=SQRT(FD(1)**2+FD(2)**2) 31 - ELSE 32 - ILOC=0 33 - VD=FCENT 34 - ENDIF 35 - * Evaluate distance to the wire surface. 36 - DD=SQRT((X(1)-XW)**2+(X(2)-YW)**2)-DW/2 37 - * Evaluate the weighting function. 38 - IF(VD.GT.0.AND.DD.GT.0)THEN 39 - F1(L)=W*DD/VD 40 - ELSE 41 - IF(VD.LE.0.AND.LDEBUG)WRITE(LUNOUT,'('' ++++++ FDIF1L'', 42 - - '' DEBUG : (x,y)=('',E15.8,'','',E15.8,''), Vd='', 43 - - E15.8,'', loc='',I3)') 44 - - XC+C*X(1)-S*X(2),YC+S*X(1)+C*X(2),VD,ILOC 45 - IF(DD.LE.0.AND.LDEBUG)WRITE(LUNOUT,'('' ++++++ FDIF1L'', 46 - - '' DEBUG : (x,y)=('',E15.8,'','',E15.8,''), d='', 47 - - E15.8)') XC+C*X(1)-S*X(2),YC+S*X(1)+C*X(2),DD 48 - F1(L)=0 49 - ENDIF 50 - 10 CONTINUE 51 - END 699 GARFIELD ================================================== P=DRIFTCAL D=FDIF2Q 1 ============================ 0 + +DECK,FDIF2Q. 1 - SUBROUTINE FDIF2Q(M,U2,F2,X) 2 - *----------------------------------------------------------------------- 3 - * FDIF2Q - One of 2 auxiliary routines for integrating t**2_mean 4 - * (Last changed on 25/ 2/95.) 5 - *----------------------------------------------------------------------- 6 - C implicit none 7 - IMPLICIT DOUBLE PRECISION(A-H,O-Z) 8 - DOUBLE PRECISION U2(*),F2(*),X(2),MAT(2,2) 9 - COMMON /DF2DAT/ MAT,SIG1,SIG2,DET,XW,YW,DW,XC,YC,ZC,C,S,FCENT 10 - EXTERNAL FDIF1Q,DGMLT1 11 - *** Loop over the positions. 12 - DO 10 L=1,M 13 - * Copy the y component of the position. 14 - X(2)=U2(L) 15 - * Evaluate the integral over x. 16 - F2(L)=DGMLT1(FDIF1Q,-5*SIG1,5*SIG1,5,6,X) 17 - 10 CONTINUE 18 - END 700 GARFIELD ================================================== P=DRIFTCAL D=FDIF1Q 1 ============================ 0 + +DECK,FDIF1Q. 1 - SUBROUTINE FDIF1Q(M,U1,F1,X) 2 - *----------------------------------------------------------------------- 3 - * FDIF1Q - One of 2 auxiliary routines for integrating t**2_mean 4 - * (Last changed on 26/ 2/95.) 5 - *----------------------------------------------------------------------- 6 - C implicit none 7 - IMPLICIT DOUBLE PRECISION(A-H,O-Z) 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CONSTANTS. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,DRIFTLINE. 12 - DOUBLE PRECISION U1(*),F1(*),X(2),MAT(2,2),FD(3) 13 - COMMON /DF2DAT/ MAT,SIG1,SIG2,DET,XW,YW,DW,XC,YC,ZC,C,S,FCENT 1 700 P=DRIFTCAL D=FDIF1Q 2 PAGE1084 14 - *** Loop over the positions. 15 - DO 10 L=1,M 16 - * Copy the x component of the position. 17 - X(1)=U1(L) 18 - * Evaluate the Gaussian weight factor. 19 - ARG=-0.5*(X(1)**2*MAT(2,2)+X(2)**2*MAT(1,1)- 20 - - X(2)*X(1)*MAT(1,2)-X(1)*X(2)*MAT(2,1))/DET 21 - IF(ARG.LT.-50)THEN 22 - W=0.0 23 - ELSE 24 - W=EXP(ARG)/(2*PI*SQRT(DET)) 25 - ENDIF 26 - * Evaluate the drift velocity. 27 - IF(MDF2.EQ.1)THEN 28 - CALL DLCVEL(XC+C*X(1)-S*X(2),YC+S*X(1)+C*X(2),ZC, 29 - - FD,-1.0,1,ILOC) 30 - VD=SQRT(FD(1)**2+FD(2)**2) 31 - ELSE 32 - VD=FCENT 33 - ILOC=0 34 - ENDIF 35 - * Evaluate distance to the wire surface. 36 - DD=SQRT((X(1)-XW)**2+(X(2)-YW)**2)-DW/2 37 - * Evaluate the weighting function. 38 - IF(VD.GT.0.AND.DD.GT.0)THEN 39 - F1(L)=W*(DD/VD)**2 40 - ELSE 41 - IF(VD.LE.0.AND.LDEBUG)WRITE(LUNOUT,'('' ++++++ FDIF1Q'', 42 - - '' DEBUG : (x,y)=('',E15.8,'','',E15.8,''), Vd='', 43 - - E15.8,'', loc='',I3)') 44 - - XC+C*X(1)-S*X(2),YC+S*X(1)+C*X(2),VD,ILOC 45 - IF(DD.LE.0.AND.LDEBUG)WRITE(LUNOUT,'('' ++++++ FDIF1Q'', 46 - - '' DEBUG : (x,y)=('',E15.8,'','',E15.8,''), d='', 47 - - E15.8)') XC+C*X(1)-S*X(2),YC+S*X(1)+C*X(2),DD 48 - F1(L)=0 49 - ENDIF 50 - 10 CONTINUE 51 - END 701 GARFIELD ================================================== P=DRIFTCAL D=DLCTWN 1 ============================ 0 + +DECK,DLCTWN. 1 - SUBROUTINE DLCTWN(FACTOR) 2 - *----------------------------------------------------------------------- 3 - * DLCTWN - Routine returning the multiplication factor for the current 4 - * drift line. Uses either DLCDF1 for drift lines that have 5 - * been computed with RKF or DLCDF2 for MC drift lines. 6 - * integration. 7 - * VARIABLES : FACTOR : The multiplication factor. 8 - * (Last changed on 22/ 8/99.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,DRIFTLINE. 13.- +SEQ,CELLDATA. 14.- +SEQ,PRINTPLOT. 15 - REAL FACTOR 16 - *** Projected integration ... 17 - IF(LAVPRO)THEN 18 - CALL DLCTW2(FACTOR) 19 - *** Integration over the true step length ... 20 - ELSE 21 - CALL DLCTW1(FACTOR) 22 - ENDIF 23 - END 702 GARFIELD ================================================== P=DRIFTCAL D=DLCTW1 1 ============================ 0 + +DECK,DLCTW1. 1 - SUBROUTINE DLCTW1(FACTOR) 2 - *----------------------------------------------------------------------- 3 - * DLCTW1 - Routine returning the multiplication factor for the current 4 - * drift line. The routine uses an adaptive Simpson style 5 - * integration. 6 - * VARIABLES : ALFA. : Townsend coefficients (1,2 end; M middle). 7 - * ALFINT : Integral of the Townsend coefficient. 8 - * FACTOR : The multiplication factor. 9 - * (Last changed on 5/ 2/00.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,DRIFTLINE. 14.- +SEQ,CELLDATA. 15.- +SEQ,PRINTPLOT. 16 - REAL TWNVEC(MXLIST),ALFA1,ALFA2,ALFAM,FACTOR,EXM,EYM,EZM,ETOTM, 17 - - EX,EY,EZ,ETOT,BX,BY,BZ,BTOT,VOLT,GASTWN,DRES, 18 - - BXM,BYM,BZM,BTOTM 19 - DOUBLE PRECISION XAUX1,XAUX2,YAUX1,YAUX2,STEP,ALFINT, 20 - - XPOS1,XPOS2,XPOSM,YPOS1,YPOS2,YPOSM,ZPOSM,ZPOS1,ZPOS2, 21 - - TOTSTP,CRUDE,STACK(MXSTCK,4) 22 - INTEGER LOCVEC(MXLIST),ISTACK,NSTACK,ILOCRS,NFC,ILOCM,IU,ILOC 23 - EXTERNAL GASTWN 24 - *** Identify the routine 25 - IF(LIDENT)PRINT *,' /// ROUTINE DLCTW1 ///' 26 - *** Return straight away if there is only one data point. 27 - IF(NU.LE.1)THEN 28 - FACTOR=1.0 29 - RETURN 30 - ENDIF 31 - *** Obtain a very rough estimate of the result. 32 - CRUDE=0.0 33 - DO 100 IU=1,NU 34 - CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 35 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 36 - CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 37 - - BX,BY,BZ,BTOT) 1 702 P=DRIFTCAL D=DLCTW1 2 PAGE1085 38 - * Cheat in case the point is located inside a wire. 39 - IF(ILOC.GT.0.AND.ILOC.LE.MXWIRE)THEN 40 - DRES=D(ILOC) 41 - ILOCRS=ILOC 42 - D(ILOCRS)=0.0 43 - CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 44 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 45 - CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 46 - - BX,BY,BZ,BTOT) 47 - D(ILOCRS)=DRES 48 - IF(LDEBUG)PRINT *,' ++++++ DLCTW1 DEBUG : Drift-line', 49 - - ' data point in wire ',ILOCRS,' detected; d=0 fix.' 50 - ENDIF 51 - * In case this didn't help, just log the failure. 52 - LOCVEC(IU)=ILOC 53 - IF(POLAR)THEN 54 - TWNVEC(IU)=GASTWN(EX/EXP(REAL(XU(IU))),EY/EXP(REAL(XU(IU))), 55 - - EZ,BX,BY,BZ) 56 - IF(IU.GT.1)THEN 57 - CALL CF2RTC(XU(IU),YU(IU),XAUX1,YAUX1,1) 58 - CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX2,YAUX2,1) 59 - STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 60 - - (ZU(IU)-ZU(IU-1))**2) 61 - ENDIF 62 - ELSE 63 - TWNVEC(IU)=GASTWN(EX,EY,EZ,BX,BY,BZ) 64 - IF(IU.GT.1)STEP=SQRT((XU(IU)-XU(IU-1))**2+ 65 - - (YU(IU)-YU(IU-1))**2+(ZU(IU)-ZU(IU-1))**2) 66 - ENDIF 67 - IF(IU.GT.1)CRUDE=CRUDE+STEP*(TWNVEC(IU)+TWNVEC(IU-1))/2.0 68 - 100 CONTINUE 69 - NFC=NU 70 - *** Print a heading for the debugging output. 71 - IF(LDEBUG)THEN 72 - PRINT *,' ++++++ DLCTW1 DEBUG : Townsend integration', 73 - - ' debugging output follows:' 74 - PRINT *,' ' 75 - PRINT *,' IU loc XU(IU)'// 76 - - ' YU(IU)'// 77 - - ' ZU(IU)'// 78 - - ' number of electrons' 79 - PRINT *,' [cm]'// 80 - - ' [cm]'// 81 - - ' [cm]'// 82 - - ' [numeric]' 83 - PRINT *,' ' 84 - PRINT '(2(2X,I3),3(5X,E15.8))',1,LOCVEC(1),XU(1),YU(1),ZU(1) 85 - ENDIF 86 - *** Initialise the sum ALFINT 87 - ALFINT=0.0 88 - *** Loop over the whole drift-line. 89 - ISTACK=0 90 - DO 10 IU=1,NU-1 91 - IF(LOCVEC(IU).NE.0.OR.LOCVEC(IU+1).NE.0)GOTO 30 92 - * Initial values for the position. 93 - XPOS1=XU(IU) 94 - YPOS1=YU(IU) 95 - ZPOS1=ZU(IU) 96 - ALFA1=TWNVEC(IU) 97 - XPOS2=XU(IU+1) 98 - YPOS2=YU(IU+1) 99 - ZPOS2=ZU(IU+1) 100 - ALFA2=TWNVEC(IU+1) 101 - * Calculate the total steplength, in Cartesian coordinates. 102 - IF(POLAR)THEN 103 - CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) 104 - CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) 105 - TOTSTP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 106 - - (ZPOS2-ZPOS1)**2) 107 - ELSE 108 - TOTSTP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ 109 - - (ZPOS2-ZPOS1)**2) 110 - ENDIF 111 - * Return at this point of further refinement is needed. 112 - NSTACK=0 113 - 20 CONTINUE 114 - * Set the new middle point, to be used for comparison. 115 - XPOSM=0.5*(XPOS1+XPOS2) 116 - YPOSM=0.5*(YPOS1+YPOS2) 117 - ZPOSM=0.5*(ZPOS1+ZPOS2) 118 - * Compute the field and the Townsend coeff. at the middle point. 119 - CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 120 - - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) 121 - CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 122 - - BXM,BYM,BZM,BTOTM) 123 - NFC=NFC+1 124 - * Cheat in case the point is located inside a wire. 125 - IF(ILOCM.GT.0.AND.ILOCM.LE.MXWIRE)THEN 126 - DRES=D(ILOCM) 127 - ILOCRS=ILOCM 128 - D(ILOCRS)=0.0 129 - CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 130 - - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) 131 - CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 132 - - BXM,BYM,BZM,BTOTM) 133 - NFC=NFC+1 134 - D(ILOCRS)=DRES 135 - IF(LDEBUG)PRINT *,' ++++++ DLCTW1 DEBUG : Intermediate', 136 - - ' point in wire ',ILOCRS,' detected; d=0 fix.' 137 - ENDIF 138 - * Skip this step in case the ILOC is not due to a wire. 139 - IF(ILOCM.NE.0)GOTO 30 140 - IF(POLAR)THEN 141 - ALFAM=GASTWN(EXM/EXP(REAL(XPOSM)),EYM/EXP(REAL(XPOSM)),EZM, 142 - - BXM,BYM,BZM) 143 - ELSE 1 702 P=DRIFTCAL D=DLCTW1 3 PAGE1086 144 - ALFAM=GASTWN(EXM,EYM,EZM,BXM,BYM,BZM) 145 - ENDIF 146 - * Compare first and second order estimates, divide if too large. 147 - IF(NSTACK.LT.MIN(MXSTCK,MXTWNS).AND.EPSTWI*CRUDE.LT. 148 - - TOTSTP*ABS(ALFA1-2.0*ALFAM+ALFA2)/3.0)THEN 149 - NSTACK=NSTACK+1 150 - ISTACK=MAX(ISTACK,NSTACK) 151 - STACK(NSTACK,1)=XPOS2 152 - STACK(NSTACK,2)=YPOS2 153 - STACK(NSTACK,3)=ZPOS2 154 - STACK(NSTACK,4)=ALFA2 155 - XPOS2=XPOSM 156 - YPOS2=YPOSM 157 - ZPOS2=ZPOSM 158 - ALFA2=ALFAM 159 - GOTO 20 160 - * No further subdevision is required, transform polar coordinates. 161 - ELSE 162 - * Make sure the distances are measured in cartesian coordinates. 163 - IF(POLAR)THEN 164 - CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) 165 - CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) 166 - STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 167 - - (ZPOS2-ZPOS1)**2) 168 - ELSE 169 - STEP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ 170 - - (ZPOS2-ZPOS1)**2) 171 - ENDIF 172 - * Add the new term to the integral. 173 - ALFINT=ALFINT+STEP*(ALFA1+4.0*ALFAM+ALFA2)/6.0 174 - * Continue with the next segment (if complete) or the next subsegment. 175 - XPOS1=XPOS2 176 - YPOS1=YPOS2 177 - ZPOS1=ZPOS2 178 - ALFA1=ALFA2 179 - IF(NSTACK.GT.0)THEN 180 - XPOS2=STACK(NSTACK,1) 181 - YPOS2=STACK(NSTACK,2) 182 - ZPOS2=STACK(NSTACK,3) 183 - ALFA2=STACK(NSTACK,4) 184 - NSTACK=NSTACK-1 185 - GOTO 20 186 - ENDIF 187 - ENDIF 188 - * Continue with the next segment. 189 - 30 CONTINUE 190 - * Print some debugging output. 191 - IF(LDEBUG)PRINT '(2I5,4(5X,E15.8))',IU+1,LOCVEC(IU+1),XU(IU+1), 192 - - YU(IU+1),ZU(IU+1),EXP(MIN(50.0D0,ALFINT)) 193 - 10 CONTINUE 194 - *** Finally take the exponential. 195 - IF(ALFINT.LT.0.0)THEN 196 - FACTOR=1.0 197 - ELSEIF(ALFINT.LT.46.0)THEN 198 - FACTOR=EXP(ALFINT) 199 - ELSE 200 - PRINT *,' !!!!!! DLCTW1 WARNING : The Townsend coefficient', 201 - - ' can not be integrated without overflow; set to 1E20.' 202 - FACTOR=1.0E20 203 - ENDIF 204 - IF(LDEBUG)THEN 205 - PRINT *,' ++++++ DLCTW1 DEBUG : EFIELD calls: ',NFC, 206 - - ', deepest stack: ',ISTACK 207 - PRINT *,' Final log estimate: ', 208 - - ALFINT,' (crude estimate: ',CRUDE,').' 209 - ENDIF 210 - END 703 GARFIELD ================================================== P=DRIFTCAL D=DLCTW2 1 ============================ 0 + +DECK,DLCTW2. 1 - SUBROUTINE DLCTW2(FACTOR) 2 - *----------------------------------------------------------------------- 3 - * DLCTW2 - Routine returning the multiplication factor for the current 4 - * drift line projected over the locally mean path. The 5 - * routine uses an adaptive Simpson style integration. 6 - * VARIABLES : ALFA. : Townsend coefficients (1,2 end; M middle). 7 - * ALFINT : Integral of the Townsend coefficient. 8 - * FACTOR : The multiplication factor. 9 - * (Last changed on 5/ 2/00.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,DRIFTLINE. 14.- +SEQ,CELLDATA. 15.- +SEQ,PRINTPLOT. 16 - REAL TWNVEC(MXLIST),ALFA1,ALFA2,ALFAM,FACTOR,EXM,EYM,EZM,ETOTM, 17 - - EX,EY,EZ,ETOT,VOLT,GASTWN,DRES,SCALE,BX,BY,BZ,BTOT, 18 - - BXM,BYM,BZM,BTOTM 19 - DOUBLE PRECISION XAUX1,XAUX2,YAUX1,YAUX2,STEP,ALFINT, 20 - - XPOS1,XPOS2,XPOSM,YPOS1,YPOS2,YPOSM,ZPOSM,ZPOS1,ZPOS2, 21 - - TOTSTP,CRUDE,STACK(MXSTCK,4),VD(3) 22 - INTEGER LOCVEC(MXLIST),ISTACK,NSTACK,ILOCRS,NFC,ILOCM,IU,ILOC 23 - EXTERNAL GASTWN 24 - *** Identify the routine 25 - IF(LIDENT)PRINT *,' /// ROUTINE DLCTW2 ///' 26 - *** Return straight away if there is only one data point. 27 - IF(NU.LE.1)THEN 28 - FACTOR=1.0 29 - RETURN 30 - ENDIF 31 - *** Obtain a very rough estimate of the result. 32 - CRUDE=0.0 33 - DO 100 IU=1,NU 34 - CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 35 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 1 703 P=DRIFTCAL D=DLCTW2 2 PAGE1087 36 - CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 37 - - BX,BY,BZ,BTOT) 38 - * Cheat in case the point is located inside a wire. 39 - IF(ILOC.GT.0.AND.ILOC.LE.MXWIRE)THEN 40 - DRES=D(ILOC) 41 - ILOCRS=ILOC 42 - D(ILOCRS)=0.0 43 - CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 44 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 45 - CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 46 - - BX,BY,BZ,BTOT) 47 - D(ILOCRS)=DRES 48 - IF(LDEBUG)PRINT *,' ++++++ DLCTW2 DEBUG : Drift-line', 49 - - ' data point in wire ',ILOCRS,' detected; d=0 fix.' 50 - ENDIF 51 - * In case this didn't help, just log the failure. 52 - LOCVEC(IU)=ILOC 53 - * Compute projection of the path. 54 - IF(IU.GT.1)THEN 55 - CALL DLCVEL((XU(IU-1)+XU(IU))/2,(YU(IU-1)+YU(IU))/2, 56 - - (ZU(IU-1)+ZU(IU))/2,VD,QPCHAR,IPTYPE,ILOC) 57 - IF(((XU(IU)-XU(IU-1))**2+(YU(IU)-YU(IU-1))**2+ 58 - - (ZU(IU)-ZU(IU-1))**2)* 59 - - (VD(1)**2+VD(2)**2+VD(3)**2).LE.0)THEN 60 - SCALE=0 61 - ELSE 62 - SCALE=((XU(IU)-XU(IU-1))*VD(1)+ 63 - - (YU(IU)-YU(IU-1))*VD(2)+(ZU(IU)-ZU(IU-1))*VD(3))/ 64 - - SQRT(((XU(IU)-XU(IU-1))**2+(YU(IU)-YU(IU-1))**2+ 65 - - (ZU(IU)-ZU(IU-1))**2)* 66 - - (VD(1)**2+VD(2)**2+VD(3)**2)) 67 - ENDIF 68 - C print *,' Scale = ',scale 69 - C print *,' x: ',xu(iu-1),xu(iu),vd(1) 70 - C print *,' y: ',yu(iu-1),yu(iu),vd(2) 71 - C print *,' z: ',zu(iu-1),zu(iu),vd(3) 72 - ENDIF 73 - * Compute Townsend coefficients and step length. 74 - IF(POLAR)THEN 75 - TWNVEC(IU)=GASTWN(EX/EXP(REAL(XU(IU))),EY/EXP(REAL(XU(IU))), 76 - - EZ,BX,BY,BZ) 77 - IF(IU.GT.1)THEN 78 - CALL CF2RTC(XU(IU),YU(IU),XAUX1,YAUX1,1) 79 - CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX2,YAUX2,1) 80 - STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 81 - - (ZU(IU)-ZU(IU-1))**2) 82 - ENDIF 83 - ELSE 84 - TWNVEC(IU)=GASTWN(EX,EY,EZ,BX,BY,BZ) 85 - IF(IU.GT.1)STEP=SQRT((XU(IU)-XU(IU-1))**2+ 86 - - (YU(IU)-YU(IU-1))**2+(ZU(IU)-ZU(IU-1))**2) 87 - ENDIF 88 - IF(IU.GT.1)CRUDE=CRUDE+STEP*SCALE*(TWNVEC(IU)+TWNVEC(IU-1))/2.0 89 - 100 CONTINUE 90 - NFC=NU 91 - *** Ensure that the crude sum is positive. 92 - IF(CRUDE.LT.0)THEN 93 - PRINT *,' !!!!!! DLCTW2 WARNING : Negative Townsend sum'// 94 - - ' in 1st order ; multiplication set to 1.' 95 - FACTOR=1 96 - RETURN 97 - ELSEIF(CRUDE.EQ.0)THEN 98 - FACTOR=1 99 - RETURN 100 - ENDIF 101 - *** Print a heading for the debugging output. 102 - IF(LDEBUG)THEN 103 - PRINT *,' ++++++ DLCTW2 DEBUG : Townsend integration', 104 - - ' debugging output follows:' 105 - PRINT *,' ' 106 - PRINT *,' IU loc XU(IU)'// 107 - - ' YU(IU)'// 108 - - ' ZU(IU)'// 109 - - ' number of electrons' 110 - PRINT *,' [cm]'// 111 - - ' [cm]'// 112 - - ' [cm]'// 113 - - ' [numeric]' 114 - PRINT *,' ' 115 - PRINT '(2(2X,I3),3(5X,E15.8))',1,LOCVEC(1),XU(1),YU(1),ZU(1) 116 - ENDIF 117 - *** Initialise the sum ALFINT 118 - ALFINT=0.0 119 - *** Loop over the whole drift-line. 120 - ISTACK=0 121 - DO 10 IU=1,NU-1 122 - IF(LOCVEC(IU).NE.0.OR.LOCVEC(IU+1).NE.0)GOTO 30 123 - * Initial values for the position. 124 - XPOS1=XU(IU) 125 - YPOS1=YU(IU) 126 - ZPOS1=ZU(IU) 127 - ALFA1=TWNVEC(IU) 128 - XPOS2=XU(IU+1) 129 - YPOS2=YU(IU+1) 130 - ZPOS2=ZU(IU+1) 131 - ALFA2=TWNVEC(IU+1) 132 - * Calculate the total steplength, in Cartesian coordinates. 133 - IF(POLAR)THEN 134 - CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) 135 - CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) 136 - TOTSTP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 137 - - (ZPOS2-ZPOS1)**2) 138 - ELSE 139 - TOTSTP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ 140 - - (ZPOS2-ZPOS1)**2) 141 - ENDIF 1 703 P=DRIFTCAL D=DLCTW2 3 PAGE1088 142 - * Compute projection of the path. 143 - CALL DLCVEL((XU(IU+1)+XU(IU))/2,(YU(IU+1)+YU(IU))/2, 144 - - (ZU(IU+1)+ZU(IU))/2,VD,QPCHAR,IPTYPE,ILOC) 145 - IF(((XU(IU+1)-XU(IU))**2+(YU(IU+1)-YU(IU))**2+ 146 - - (ZU(IU+1)-ZU(IU))**2)* 147 - - (VD(1)**2+VD(2)**2+VD(3)**2).LE.0)THEN 148 - SCALE=0 149 - ELSE 150 - SCALE=((XU(IU+1)-XU(IU))*VD(1)+ 151 - - (YU(IU+1)-YU(IU))*VD(2)+(ZU(IU+1)-ZU(IU))*VD(3))/ 152 - - SQRT(((XU(IU+1)-XU(IU))**2+(YU(IU+1)-YU(IU))**2+ 153 - - (ZU(IU+1)-ZU(IU))**2)* 154 - - (VD(1)**2+VD(2)**2+VD(3)**2)) 155 - ENDIF 156 - C print *,' Scale = ',scale 157 - * Return at this point of further refinement is needed. 158 - NSTACK=0 159 - 20 CONTINUE 160 - * Set the new middle point, to be used for comparison. 161 - XPOSM=0.5*(XPOS1+XPOS2) 162 - YPOSM=0.5*(YPOS1+YPOS2) 163 - ZPOSM=0.5*(ZPOS1+ZPOS2) 164 - * Compute the field and the Townsend coeff. at the middle point. 165 - CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 166 - - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) 167 - CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 168 - - BXM,BYM,BZM,BTOTM) 169 - NFC=NFC+1 170 - * Cheat in case the point is located inside a wire. 171 - IF(ILOCM.GT.0.AND.ILOCM.LE.MXWIRE)THEN 172 - DRES=D(ILOCM) 173 - ILOCRS=ILOCM 174 - D(ILOCRS)=0.0 175 - CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 176 - - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) 177 - CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), 178 - - BXM,BYM,BZM,BTOTM) 179 - NFC=NFC+1 180 - D(ILOCRS)=DRES 181 - IF(LDEBUG)PRINT *,' ++++++ DLCTW2 DEBUG : Intermediate', 182 - - ' point in wire ',ILOCRS,' detected; d=0 fix.' 183 - ENDIF 184 - * Skip this step in case the ILOC is not due to a wire. 185 - IF(ILOCM.NE.0)GOTO 30 186 - IF(POLAR)THEN 187 - ALFAM=GASTWN(EXM/EXP(REAL(XPOSM)),EYM/EXP(REAL(XPOSM)),EZM, 188 - - BXM,BYM,BZM) 189 - ELSE 190 - ALFAM=GASTWN(EXM,EYM,EZM,BXM,BYM,BZM) 191 - ENDIF 192 - * Compare first and second order estimates, divide if too large. 193 - IF(NSTACK.LT.MIN(MXSTCK,MXTWNS).AND.EPSTWI*CRUDE.LT. 194 - - TOTSTP*ABS(ALFA1-2.0*ALFAM+ALFA2)/3.0)THEN 195 - NSTACK=NSTACK+1 196 - ISTACK=MAX(ISTACK,NSTACK) 197 - STACK(NSTACK,1)=XPOS2 198 - STACK(NSTACK,2)=YPOS2 199 - STACK(NSTACK,3)=ZPOS2 200 - STACK(NSTACK,4)=ALFA2 201 - XPOS2=XPOSM 202 - YPOS2=YPOSM 203 - ZPOS2=ZPOSM 204 - ALFA2=ALFAM 205 - GOTO 20 206 - * No further subdevision is required, transform polar coordinates. 207 - ELSE 208 - * Make sure the distances are measured in cartesian coordinates. 209 - IF(POLAR)THEN 210 - CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) 211 - CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) 212 - STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 213 - - (ZPOS2-ZPOS1)**2) 214 - ELSE 215 - STEP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ 216 - - (ZPOS2-ZPOS1)**2) 217 - ENDIF 218 - * Add the new term to the integral. 219 - ALFINT=ALFINT+STEP*SCALE*(ALFA1+4.0*ALFAM+ALFA2)/6.0 220 - * Continue with the next segment (if complete) or the next subsegment. 221 - XPOS1=XPOS2 222 - YPOS1=YPOS2 223 - ZPOS1=ZPOS2 224 - ALFA1=ALFA2 225 - IF(NSTACK.GT.0)THEN 226 - XPOS2=STACK(NSTACK,1) 227 - YPOS2=STACK(NSTACK,2) 228 - ZPOS2=STACK(NSTACK,3) 229 - ALFA2=STACK(NSTACK,4) 230 - NSTACK=NSTACK-1 231 - GOTO 20 232 - ENDIF 233 - ENDIF 234 - * Continue with the next segment. 235 - 30 CONTINUE 236 - * Print some debugging output. 237 - IF(LDEBUG)PRINT '(2I5,4(5X,E15.8))',IU+1,LOCVEC(IU+1),XU(IU+1), 238 - - YU(IU+1),ZU(IU+1),EXP(MIN(50.0D0,ALFINT)) 239 - 10 CONTINUE 240 - *** Finally take the exponential. 241 - IF(ALFINT.LT.0.0)THEN 242 - FACTOR=1.0 243 - ELSEIF(ALFINT.LT.46.0)THEN 244 - FACTOR=EXP(ALFINT) 245 - ELSE 246 - PRINT *,' !!!!!! DLCTW2 WARNING : The Townsend coefficient', 247 - - ' can not be integrated without overflow; set to 1E20.' 1 703 P=DRIFTCAL D=DLCTW2 4 PAGE1089 248 - FACTOR=1.0E20 249 - ENDIF 250 - IF(LDEBUG)THEN 251 - PRINT *,' ++++++ DLCTW2 DEBUG : EFIELD calls: ',NFC, 252 - - ', deepest stack: ',ISTACK 253 - PRINT *,' Final log estimate: ', 254 - - ALFINT,' (crude estimate: ',CRUDE,').' 255 - ENDIF 256 - END 704 GARFIELD ================================================== P=DRIFTCAL D=DLCPHI 1 ============================ 0 + +DECK,DLCPHI. 1 - SUBROUTINE DLCPHI(PHI) 2 - *----------------------------------------------------------------------- 3 - * DLCPHI - Computes the incidence angle of a drift line on an 4 - * electrode. 5 - * VARIABLES : PHI - Incidence angle. 6 - * (Last changed on 20/ 5/99.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,SOLIDS. 12.- +SEQ,PRINTPLOT. 13.- +SEQ,DRIFTLINE. 14 - REAL PHI,XW,YW 15 - DOUBLE PRECISION X0,Y0,Z0,CT,ST,CP,SP,UU,VV 16 - INTEGER IW,ISOLID,IREF 17 - *** Deal with wires. 18 - IF(ISTAT.GE.1.AND.ISTAT.LE.NWIRE)THEN 19 - IW=ISTAT 20 - PHI=ATAN2(REAL(YU(NU))-Y(IW),REAL(XU(NU)-X(IW))) 21 - *** Deal with wire replicas. 22 - ELSEIF(ISTAT.GE.MXWIRE+1.AND.ISTAT.LE.MXWIRE+NWIRE)THEN 23 - IW=ISTAT-MXWIRE 24 - XW=X(IW) 25 - IF(PERX)XW=XW+SX*ANINT((REAL(XU(NU))-XW)/SX) 26 - YW=Y(IW) 27 - IF(PERY)YW=YW+SY*ANINT((REAL(YU(NU))-YW)/SY) 28 - PHI=ATAN2(REAL(YU(NU))-YW,REAL(XU(NU))-XW) 29 - *** Deal with solids. 30 - ELSEIF(ISTAT.GE.2*MXWIRE+1.AND.ISTAT.LE.2*MXWIRE+NSOLID)THEN 31 - ISOLID=ISTAT-2*MXWIRE 32 - ** Cylinders can be processed in detail. 33 - IF(ISOLTP(ISOLID).EQ.1)THEN 34 - * Starting point in buffer. 35 - IREF=ISTART(ISOLID) 36 - IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN 37 - PRINT *,' !!!!!! DLCPHI WARNING : Solid address'// 38 - - ' is out of range ; returning reference.' 39 - RETURN 40 - ENDIF 41 - * Obtain parameters of the cylinder. 42 - X0=CBUF(IREF+3) 43 - Y0=CBUF(IREF+4) 44 - Z0=CBUF(IREF+5) 45 - CT=CBUF(IREF+10) 46 - ST=CBUF(IREF+11) 47 - CP=CBUF(IREF+12) 48 - SP=CBUF(IREF+13) 49 - * Compute the U and V coordinates. 50 - UU=+CP*CT*(XU(NU)-X0)+SP*CT*(YU(NU)-Y0)-ST*(ZU(NU)-Z0) 51 - VV=-SP *(XU(NU)-X0)+CP* (YU(NU)-Y0) 52 - * Compute the angle. 53 - IF(UU.NE.0.OR.VV.NE.0)THEN 54 - PHI=REAL(ATAN2(VV,UU)) 55 - ELSE 56 - PHI=0 57 - ENDIF 58 - ** Other shapes are not yet processed specially. 59 - ELSE 60 - PHI=0 61 - ENDIF 62 - *** Anything else. 63 - ELSE 64 - PHI=0 65 - ENDIF 66 - END 705 GARFIELD ================================================== P=DRIFTCAL D=DLCTRW 1 ============================ 0 + +DECK,DLCTRW. 1 - SUBROUTINE DLCTRW 2 - *----------------------------------------------------------------------- 3 - * DLCTRW - This routine writes the data on a track to an external 4 - * dataset for future use. This routine writes its data 5 - * instantly, not delayed like most other WRITE-routines. 6 - * VARIABLES : 7 - * (Last changed on 30/ 8/97.) 8 - *----------------------------------------------------------------------- 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,GASDATA. 12.- +SEQ,PRINTPLOT. 13.- +SEQ,SIGNALDATA. 14.- +SEQ,PARAMETERS. 15 - CHARACTER*(MXINCH) STRING 16 - CHARACTER*(MXNAME) FILE 17 - CHARACTER*29 REMARK 18 - CHARACTER*8 TIME,DATE,MEMBER 19 - LOGICAL EXMEMB 1 705 P=DRIFTCAL D=DLCTRW 2 PAGE1090 20-+ +SELF,IF=SAVE. 21 - SAVE FILE,NCFILE,MEMBER,NCMEMB,REMARK,NCREM 0 22-+ +SELF. 23 - *** Identify the routine. 24 - IF(LIDENT)PRINT *,' /// ROUTINE DLCTRW ///' 25 - *** Return right away if no track has been set. 26 - IF(.NOT.TRASET)THEN 27 - PRINT *,' !!!!!! DLCTRW WARNING : No track data present,'// 28 - - ' first call PREPARE-TRACK ; nothing written.' 29 - RETURN 30 - ENDIF 31 - *** Set the file name etc. 32 - FILE=' ' 33 - NCFILE=1 34 - MEMBER='< none >' 35 - NCMEMB=8 36 - REMARK='none' 37 - NCREM=4 38 - * First decode the argument string. 39 - CALL INPNUM(NWORD) 40 - * Make sure there is at least one argument. 41 - IF(NWORD.EQ.1)THEN 42 - PRINT *,' !!!!!! DLCTRW WARNING : WRITE takes at least 1'// 43 - - ' argument (a dataset name); data will not be written.' 44 - RETURN 45 - * Check whether keywords have been used. 46 - ELSEIF(INPCMP(2,'D#ATASET')+INPCMP(2,'R#EMARK').NE.0)THEN 47 - INEXT=2 48 - DO 10 I=2,NWORD 49 - IF(I.LT.INEXT)GOTO 10 50 - IF(INPCMP(I,'D#ATASET').NE.0)THEN 51 - IF(INPCMP(I+1,'R#EMARK').NE.0.OR.I+1.GT.NWORD)THEN 52 - CALL INPMSG(I,'The dataset name is missing. ') 53 - INEXT=I+1 54 - ELSE 55 - CALL INPSTR(I+1,I+1,STRING,NCFILE) 56 - FILE=STRING 57 - INEXT=I+2 58 - IF(INPCMP(I+2,'R#EMARK').EQ.0.AND. 59 - - I+2.LE.NWORD)THEN 60 - CALL INPSTR(I+2,I+2,STRING,NCMEMB) 61 - MEMBER=STRING 62 - INEXT=I+3 63 - ENDIF 64 - ENDIF 65 - ELSEIF(INPCMP(I,'R#EMARK').NE.0)THEN 66 - IF(INPCMP(I+1,'D#ATASET').NE.0.OR.I+1.GT.NWORD)THEN 67 - CALL INPMSG(I,'The remark is missing. ') 68 - INEXT=I+1 69 - ELSE 70 - CALL INPSTR(I+1,I+1,STRING,NCREM) 71 - REMARK=STRING 72 - INEXT=I+2 73 - ENDIF 74 - ELSE 75 - CALL INPMSG(I,'The parameter is not known. ') 76 - ENDIF 77 - 10 CONTINUE 78 - * Otherwise the string is interpreted as a file name (+ member name). 79 - ELSE 80 - CALL INPSTR(2,2,STRING,NCFILE) 81 - FILE=STRING 82 - IF(NWORD.GE.3)THEN 83 - CALL INPSTR(3,3,STRING,NCMEMB) 84 - MEMBER=STRING 85 - ENDIF 86 - IF(NWORD.GE.4)THEN 87 - CALL INPSTR(4,NWORD,STRING,NCREM) 88 - REMARK=STRING 89 - ENDIF 90 - ENDIF 91 - * Print error messages. 92 - CALL INPERR 93 - IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! DLCTRW WARNING : The file', 94 - - ' name is truncated to MXNAME (=',MXNAME,') characters.' 95 - IF(NCMEMB.GT.8)PRINT *,' !!!!!! DLCTRW WARNING : The member', 96 - - ' name is shortened to ',MEMBER,', first 8 characters.' 97 - IF(NCREM.GT.29)PRINT *,' !!!!!! DLCTRW WARNING : The remark', 98 - - ' shortened to ',REMARK,', first 29 characters.' 99 - NCFILE=MIN(NCFILE,MXNAME) 100 - NCMEMB=MIN(NCMEMB,8) 101 - NCREM=MIN(NCREM,29) 102 - * Check whether the member already exists. 103 - CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'TRACK',EXMEMB) 104 - IF(JEXMEM.EQ.2.AND.EXMEMB)THEN 105 - PRINT *,' ------ DLCTRW MESSAGE : A copy of the member'// 106 - - ' exists; new member will be appended.' 107 - ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN 108 - PRINT *,' !!!!!! DLCTRW WARNING : A copy of the member'// 109 - - ' exists already; member will not be written.' 110 - RETURN 111 - ENDIF 112 - * Print some debugging output if requested. 113 - IF(LDEBUG)THEN 114 - PRINT *,' ++++++ DLCTRW DEBUG : File= ',FILE(1:NCFILE), 115 - - ', member= ',MEMBER(1:NCMEMB) 116 - PRINT *,' Remark= ',REMARK(1:NCREM) 117 - ENDIF 118 - *** Open the dataset for sequential write and inform DSNLOG. 119 - CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) 120 - IF(IFAIL.NE.0)THEN 121 - PRINT *,' !!!!!! DLCTRW WARNING : Opening ',FILE(1:NCFILE), 122 - - ' failed ; the tracks data will not be written.' 123 - RETURN 124 - ENDIF 1 705 P=DRIFTCAL D=DLCTRW 3 PAGE1091 125 - CALL DSNLOG(FILE,'Track data','Sequential','Write ') 126 - IF(LDEBUG)PRINT *,' ++++++ DLCTRW DEBUG : Dataset ', 127 - - FILE(1:NCFILE),' opened on unit 12 for seq write.' 128 - * Now write a heading record to the file. 129 - CALL DATTIM(DATE,TIME) 130 - WRITE(STRING,'(''% Created '',A8,'' At '',A8,1X,A8,'' TRACK '', 131 - - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK 132 - WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING(1:80) 133 - IF(LDEBUG)THEN 134 - PRINT *,' ++++++ DLCTRW DEBUG : Dataset heading record:' 135 - PRINT *,STRING(1:80) 136 - ENDIF 137 - * Write some cell information to the dataset for future checks. 138 - WRITE(12,'('' Some cell data for checks follows'')',IOSTAT=IOS, 139 - - ERR=2010) 140 - WRITE(12,'('' CELLID: '',A)',IOSTAT=IOS,ERR=2010) CELLID 141 - WRITE(12,'('' NWIRE: '',I10,'' TYPE: '',A3,I2, 142 - - '' POLAR: '',L1,'' TUBE: '',L1)', 143 - - IOSTAT=IOS,ERR=2010) NWIRE,TYPE,ICTYPE,POLAR,TUBE 144 - * Write some gas information to the dataset for future checks. 145 - WRITE(12,'('' Some gas data for checks follows'')',IOSTAT=IOS, 146 - - ERR=2010) 147 - WRITE(12,'('' GASID : '',A)',IOSTAT=IOS,ERR=2010) GASID 148 - WRITE(12,'('' NGAS: '',I10,'' GASOK: '',8L1)',IOSTAT=IOS, 149 - - ERR=2010) NGAS,(GASOK(I),I=1,8) 150 - * Write the track to the dataset. 151 - WRITE(12,'('' TRACK: '',6E15.8)',IOSTAT=IOS,ERR=2010) 152 - - XT0,YT0,ZT0,XT1,YT1,ZT1 153 - WRITE(12,'('' Principal direction: '',I3)',IOSTAT=IOS,ERR=2010) 154 - - ITRMAJ 155 - * And write the drifting information to the dataset. 156 - WRITE(12,'('' Drifting information follows: '')') 157 - WRITE(12,'('' TRAFLG: '',9L1,'' NTRBNK: '',I10)',IOSTAT=IOS, 158 - - ERR=2010) (TRAFLG(J),J=1,9),NTRBNK 159 - WRITE(12,'('' x [cm] y [cm] z [cm]''/ 160 - - '' time [microsec] s [microsec] multiplication'', 161 - - '' attachment vector status'', 162 - - '' approach angle'')',IOSTAT=IOS,ERR=2010) 163 - DO 210 I=1,NTRBNK 164 - WRITE(12,'(1X,3E15.8/1X,5E15.8,I10,E15.8)',IOSTAT=IOS,ERR=2010) 165 - - (TRABNK(I,J),J=1,7),TRAVEC(I),NINT(TRABNK(I,8)),TRABNK(I,9) 166 - 210 CONTINUE 167 - *** Close the file after the operation. 168 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 169 - CALL TIMLOG('Writing track information to a dataset: ') 170 - RETURN 171 - *** Handle the error conditions. 172 - 2010 CONTINUE 173 - PRINT *,' ###### DLCTRW ERROR : I/O error while writing to '// 174 - - FILE(1:NCFILE)//' via unit 12 ; no track data written.' 175 - CALL INPIOS(IOS) 176 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 177 - RETURN 178 - 2030 CONTINUE 179 - PRINT *,' ###### DLCTRW ERROR : Dataset '//FILE(1:NCFILE)// 180 - - ' unit 12 cannot be closed ; results not predictable' 181 - CALL INPIOS(IOS) 182 - END 706 GARFIELD ================================================== P=DRIFTCAL D=DLCTRG 1 ============================ 0 + +DECK,DLCTRG. 1 - SUBROUTINE DLCTRG(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * DLCTRG - This routine retrieves drifting information for a track 4 - * from a dataset. It informs the user if the data don't seem 5 - * to belong to the present cell and gas information. 6 - * VARIABLES : STRING : Character string that should contain a 7 - * description of the dataset being read. 8 - * (Last changed on 21/ 4/96.) 9 - *----------------------------------------------------------------------- 10.- +SEQ,DIMENSIONS. 11.- +SEQ,CELLDATA. 12.- +SEQ,GASDATA. 13.- +SEQ,PARAMETERS. 14.- +SEQ,SIGNALDATA. 15.- +SEQ,PRINTPLOT. 16 - CHARACTER*(MXCHAR) STRING 17 - CHARACTER*80 CELIDR,GASIDR 18 - CHARACTER*8 MEMBER 19 - CHARACTER*3 TYPER 20 - CHARACTER*(MXNAME) FILE 21 - LOGICAL DSNCMP,EXIS,POLARR,TUBER,GASOKR(8) 22 - EXTERNAL DSNCMP 23 - *** Identify the routine, if requested. 24 - IF(LIDENT)PRINT *,' /// ROUTINE DLCTRG ///' 25 - *** Initialise IFAIL on 1 (i.e. fail). 26 - IFAIL=1 27 - FILE=' ' 28 - MEMBER='*' 29 - NCFILE=8 30 - NCMEMB=1 31 - *** First decode the argument string, setting file name + member name. 32 - CALL INPNUM(NWORD) 33 - * If there's only one argument, it's the dataset name. 34 - IF(NWORD.GE.2)THEN 35 - CALL INPSTR(2,2,STRING,NCFILE) 36 - FILE=STRING 37 - ENDIF 38 - * If there's a second argument, it is the member name. 39 - IF(NWORD.GE.3)THEN 40 - CALL INPSTR(3,3,STRING,NCMEMB) 41 - MEMBER=STRING 42 - ENDIF 43 - * Check the various lengths. 44 - IF(NCFILE.GT.MXNAME)THEN 1 706 P=DRIFTCAL D=DLCTRG 2 PAGE1092 45 - PRINT *,' !!!!!! DLCTRG WARNING : The file name is'// 46 - - ' truncated to MXNAME (=',MXNAME,') characters.' 47 - NCFILE=MIN(NCFILE,MXNAME) 48 - ENDIF 49 - IF(NCMEMB.GT.8)THEN 50 - PRINT *,' !!!!!! DLCTRG WARNING : The member name is'// 51 - - ' shortened to ',MEMBER,', first 8 characters.' 52 - NCMEMB=MIN(NCMEMB,8) 53 - ELSEIF(NCMEMB.LE.0)THEN 54 - PRINT *,' !!!!!! DLCTRG WARNING : The member'// 55 - - ' name has zero length, replaced by "*".' 56 - MEMBER='*' 57 - NCMEMB=1 58 - ENDIF 59 - * Reject the empty file name case. 60 - IF(FILE.EQ.' '.OR.NWORD.EQ.1)THEN 61 - PRINT *,' !!!!!! DLCTRG WARNING : GET must be at least'// 62 - - ' followed by a dataset name ; no data are read.' 63 - RETURN 64 - ENDIF 65 - * If there are even more args, warn they are ignored. 66 - IF(NWORD.GT.3)PRINT *,' !!!!!! DLCTRG WARNING : GET takes'// 67 - - ' at most two arguments (dataset and member); rest ignored.' 68 - *** Open the dataset and inform DSNLOG. 69 - CALL DSNOPN(FILE,NCFILE,12,'READ-LIBRARY',IFAIL1) 70 - IF(IFAIL1.NE.0)THEN 71 - PRINT *,' !!!!!! DLCTRG WARNING : Opening ',FILE(1:NCFILE), 72 - - ' failed ; track data are not read.' 73 - RETURN 74 - ENDIF 75 - CALL DSNLOG(FILE,'Track data','Sequential','Read only ') 76 - IF(LDEBUG)PRINT *,' ++++++ DLCTRG DEBUG : Dataset ', 77 - - FILE(1:NCFILE),' opened on unit 12 for seq read.' 78 - * Locate the pointer on the header of the requested member. 79 - CALL DSNLOC(MEMBER,NCMEMB,'TRACK ',12,EXIS,'RESPECT') 80 - IF(.NOT.EXIS)THEN 81 - CALL DSNLOC(MEMBER,NCMEMB,'TRACK ',12,EXIS,'IGNORE') 82 - IF(EXIS)THEN 83 - PRINT *,' ###### DLCTRG ERROR : Track information ', 84 - - MEMBER(1:NCMEMB),' has been deleted from ', 85 - - FILE(1:NCFILE),'; not read.' 86 - ELSE 87 - PRINT *,' ###### DLCTRG ERROR : Track information ', 88 - - MEMBER(1:NCMEMB),' not found on ',FILE(1:NCFILE) 89 - ENDIF 90 - CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 91 - RETURN 92 - ENDIF 93 - *** Check that the member is acceptable. 94 - READ(12,'(A80)',END=2000,IOSTAT=IOS,ERR=2010) STRING 95 - IF(LDEBUG)THEN 96 - PRINT *,' ++++++ DLCTRG DEBUG : Dataset header', 97 - - ' record follows:' 98 - PRINT *,STRING 99 - ENDIF 100 - IF(DSNCMP('02-04-96',STRING(11:18)))THEN 101 - PRINT *,' !!!!!! DLCTRG WARNING : Member ',STRING(32:39), 102 - - ' can not be read because of a change in format.' 103 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 104 - RETURN 105 - ENDIF 106 - WRITE(LUNOUT,'('' Member '',A8,'' was created on '',A8, 107 - - '' at '',A8/'' Remarks: '',A29)') 108 - - STRING(32:39),STRING(11:18),STRING(23:30),STRING(51:79) 109 - *** Read the member, start with the cell information. 110 - READ(12,'(/9X,A)',END=2000,IOSTAT=IOS,ERR=2010) CELIDR 111 - READ(12,'(9X,I10,7X,A3,I2,8X,L1,7X,L1)', 112 - - END=2000,IOSTAT=IOS,ERR=2010) 113 - - NWIRER,TYPER,ICTYPR,POLARR,TUBER 114 - * Compare this with the present cell data. 115 - IF(CELLID.NE.CELIDR.OR.NWIRE.NE.NWIRER.OR.TYPE.NE.TYPER.OR. 116 - - ICTYPE.NE.ICTYPR.OR. 117 - - (POLAR.AND..NOT.POLARR).OR. 118 - - (.NOT.POLAR.AND.POLARR).OR. 119 - - (TUBE.AND..NOT.TUBER).OR. 120 - - (.NOT.TUBE.AND.TUBER))THEN 121 - PRINT *,' !!!!!! DLCTRG WARNING : The track on the file'// 122 - - ' is not' 123 - PRINT *,' compatible with your'// 124 - - ' current cell.' 125 - ENDIF 126 - * Next read the gas information. 127 - READ(12,'(/9X,A)',END=2000,IOSTAT=IOS,ERR=2010) GASIDR 128 - READ(12,'(7X,I10,8X,8L1)',END=2000,IOSTAT=IOS,ERR=2010) 129 - - NGASR,(GASOKR(I),I=1,8) 130 - * Compare these bits of information with the present information. 131 - IGASCH=0 132 - DO 210 I=1,8 133 - IF((GASOK(I).AND..NOT.GASOKR(I)).OR. 134 - - (.NOT.GASOK(I).AND.GASOKR(I)))IGASCH=1 135 - 210 CONTINUE 136 - IF(GASID.NE.GASIDR.OR.NGAS.NE.NGASR.OR.IGASCH.NE.0)THEN 137 - PRINT *,' !!!!!! DLCTRG WARNING : The track on the file'// 138 - - ' is not' 139 - PRINT *,' compatible with your', 140 - - ' current gas.' 141 - ENDIF 142 - * Now reset the TRASET flag. 143 - TRASET=.FALSE. 144 - * Next pick up the track. 145 - READ(12,'(8X,6E15.8)',END=2000,IOSTAT=IOS,ERR=2010) 146 - - XT0,YT0,ZT0,XT1,YT1,ZT1 147 - READ(12,'(22X,I3/)',END=2000,IOSTAT=IOS,ERR=2010) ITRMAJ 148 - TRFLAG(1)=.TRUE. 149 - * And read the track bank information. 150 - READ(12,'(9X,9L1,9X,I10//)',END=2000,IOSTAT=IOS,ERR=2010) 1 706 P=DRIFTCAL D=DLCTRG 3 PAGE1093 151 - - (TRAFLG(J),J=1,9),NTRBNK 152 - DO 220 I=1,NTRBNK 153 - READ(12,'(1X,3E15.8/1X,5E15.8,I10,E15.8)',END=2000,IOSTAT=IOS, 154 - - ERR=2010) (TRABNK(I,J),J=1,7),TRAVEC(I),ISTAT,TRABNK(I,9) 155 - TRABNK(I,8)=REAL(ISTAT) 156 - 220 CONTINUE 157 - * Close the file after the operation. 158 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 159 - *** Things are probably OK, tell calling routine and common block. 160 - IFAIL=0 161 - TRASET=.TRUE. 162 - *** Register the amount of CPU time used for reading. 163 - CALL TIMLOG('Reading track data from a dataset: ') 164 - RETURN 165 - *** Handle the I/O error conditions. 166 - 2000 CONTINUE 167 - PRINT *,' ###### DLCTRG ERROR : EOF encountered while reading', 168 - - ' ',FILE(1:NCFILE),' from unit 12 ; no track data read.' 169 - CALL INPIOS(IOS) 170 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 171 - RETURN 172 - 2010 CONTINUE 173 - PRINT *,' ###### DLCTRG ERROR : I/O error while reading ', 174 - - FILE(1:NCFILE),' from unit 12 ; no track data read.' 175 - CALL INPIOS(IOS) 176 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 177 - RETURN 178 - 2030 CONTINUE 179 - PRINT *,' ###### DLCTRG ERROR : Dataset ',FILE(1:NCFILE),' on', 180 - - ' unit 12 cannot be closed ; results not predictable.' 181 - CALL INPIOS(IOS) 182 - END 707 GARFIELD ================================================== P=DRIFTCAL D=DLCTRP 1 ============================ 0 + +DECK,DLCTRP. 1 - SUBROUTINE DLCTRP(X0,Y0,Z0,X1,Y1,Z1,LDIFF,LTOWN,LATTA,NLTRIN, 2 - - TMIN,TMAX,SMIN,SMAX,AMIN,AMAX,BMIN,BMAX,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * DLCTRP - Prepares a track for interpolation by DLCTRI. 5 - * (Last changed on 20/ 5/99.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,SIGNALDATA. 10.- +SEQ,CELLDATA. 11.- +SEQ,GASDATA. 12.- +SEQ,PARAMETERS. 13.- +SEQ,DRIFTLINE. 14.- +SEQ,PRINTPLOT. 15 - C logical ldebug,lident,ldrplt 16 - C integer lunout 17 - C parameter(ldebug=.true.,lident=.false.,ldrplt=.true.,lunout=6) 18.- +SEQ,CONSTANTS. 19 - REAL XPL(MXLIST),YPL(MXLIST),X0,Y0,Z0,X1,Y1,Z1, 20 - - XX0,YY0,ZZ0,XX1,YY1,ZZ1,XSTART,YSTART,ZSTART,COORD(MXLIST), 21 - - TMIN,TMAX,SMIN,SMAX,AMIN,AMAX,BMIN,BMAX,DELTAT,XCL,YCL,ZCL, 22 - - TCL,SCL,ACL,BCL,FCL,VXMIN,VYMIN,VXMAX,VYMAX 23 - DOUBLE PRECISION XAUX(2),YAUX(2),ZAUX(2) 24 - INTEGER NLTRIN,IFAIL,IFAIL1,I,J,IL,ICL,IDMAX,JL,KL,NLTR 25 - LOGICAL LDIFF,LTOWN,LATTA 26 - *** Identify the routine if requested. 27 - IF(LIDENT)PRINT *,' /// ROUTINE DLCTRP ///' 28 - *** Assume failure, reset at the end. 29 - IFAIL=1 30 - *** Be sure not more than MXLIST tracks are requested. 31 - IF(NLTRIN.GT.MXLIST-4.OR.NLTRIN.LT.4)THEN 32 - PRINT *,' !!!!!! DLCTRP WARNING : Number of drift lines'// 33 - - ' is not in the range [4,MXLIST-4]; no preparation.' 34 - RETURN 35 - ENDIF 36 - *** Initialise the parameters. 37 - DO 1 I=1,9 38 - TRAFLG(I)=.TRUE. 39 - 1 CONTINUE 40 - TRAFLG(5)=LDIFF.AND.GASOK(3) 41 - TRAFLG(6)=LTOWN.AND.GASOK(4) 42 - TRAFLG(7)=LATTA.AND.GASOK(6) 43 - TRASET=.FALSE. 44 - NLTR=4*NINT(REAL(NLTRIN)/4.0) 45 - IF(NLTR.GT.MXLIST-4)NLTR=4*INT((MXLIST-4)/4.0) 46 - DO 2 I=1,MXLIST 47 - DO 3 J=1,9 48 - TRABNK(I,J)=0.0 49 - 3 CONTINUE 50 - 2 CONTINUE 51 - *** Cut the track if we're inside a tube. 52 - IF(TUBE)THEN 53 - CALL CRTUBE(X0,Y0,Z0,X1,Y1,Z1,XX0,YY0,ZZ0,XX1,YY1,ZZ1, 54 - - COTUBE,IFAIL1) 55 - IF(IFAIL1.NE.0)THEN 56 - PRINT *,' !!!!!! DLCTRP WARNING : Track not suitable'// 57 - - ' for preparation ; not done.' 58 - IFAIL=1 59 - RETURN 60 - ENDIF 61 - ELSE 62 - XX0=X0 63 - XX1=X1 64 - YY0=Y0 65 - YY1=Y1 66 - ZZ0=Z0 67 - ZZ1=Z1 68 - ENDIF 69 - *** Generate debugging output. 70 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRP DEBUG : TRAFLG='', 1 707 P=DRIFTCAL D=DLCTRP 2 PAGE1094 71 - - 9L1,'' NLTR='',I5)') (TRAFLG(I),I=1,9),NLTR 72 - *** Calculate drift lines from the equidistant points on the track. 73 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRP DEBUG : List of'', 74 - - '' drift-lines from equidistant track points.'')') 75 - ** Open a plot frame if the DRIFT-PLOT option is on. 76 - IF(LDRPLT)THEN 77 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 78 - - 'Drift lines for the track table') 79 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 80 - * Plot the accepting segment as a dashed line. 81 - XAUX(1)=X0 82 - YAUX(1)=Y0 83 - ZAUX(1)=Z0 84 - XAUX(2)=X1 85 - YAUX(2)=Y1 86 - ZAUX(2)=Z1 87 - IF(POLAR)CALL CF2CTR(XAUX,YAUX,XAUX,YAUX,2) 88 - CALL GRATTS('TRACK','POLYLINE') 89 - CALL PLAGPL(2,XAUX,YAUX,ZAUX) 90 - ENDIF 91 - ** Initialise the track bank with the track given and true start. 92 - NTRBNK=2 93 - TRABNK(1,1)=X0 94 - TRABNK(1,2)=Y0 95 - TRABNK(1,3)=Z0 96 - TRABNK(1,8)=-4 97 - TRABNK(2,1)=XX0 98 - TRABNK(2,2)=YY0 99 - TRABNK(2,3)=ZZ0 100 - TRABNK(2,8)=-4 101 - ** Loop along the segment, produce 3*NLTR/4 drift-lines. 102 - IF(LDRPLT)CALL GRATTS('E-DRIFT-LINE','POLYLINE') 103 - DO 300 IL=1,3*NLTR/4 104 - * Check number of drift-lines. 105 - IF(NTRBNK+1.GT.MXLIST)THEN 106 - IF(LDEBUG)PRINT *,' ++++++ DLCTRP DEBUG : NTRBNK=MXLIST.' 107 - GOTO 390 108 - ENDIF 109 - * Calculate a drift-line. 110 - XSTART=XX0+REAL(IL-1)*(XX1-XX0)/REAL(3*NLTR/4-1) 111 - YSTART=YY0+REAL(IL-1)*(YY1-YY0)/REAL(3*NLTR/4-1) 112 - ZSTART=ZZ0+REAL(IL-1)*(ZZ1-ZZ0)/REAL(3*NLTR/4-1) 113 - IF(POLAR)CALL CFMCTR(XSTART,YSTART,XSTART,YSTART,1) 114 - CALL DLCALC(XSTART,YSTART,ZSTART,-1.0,1) 115 - IF(POLAR)CALL CFMRTC(XSTART,YSTART,XSTART,YSTART,1) 116 - * Add the new drift-line to the table. 117 - NTRBNK=NTRBNK+1 118 - TRABNK(NTRBNK,1)=XSTART 119 - TRABNK(NTRBNK,2)=YSTART 120 - TRABNK(NTRBNK,3)=ZSTART 121 - TRABNK(NTRBNK,4)=REAL(TU(NU)) 122 - IF(TRAFLG(5))CALL DLCDIF(TRABNK(NTRBNK,5)) 123 - IF(TRAFLG(6))CALL DLCTWN(TRABNK(NTRBNK,6)) 124 - IF(TRAFLG(7))CALL DLCATT(TRABNK(NTRBNK,7)) 125 - TRABNK(NTRBNK,8)=REAL(ISTAT) 126 - CALL DLCPHI(TRABNK(NTRBNK,9)) 127 - IF(NINT(TRABNK(NTRBNK,8)).EQ.NINT(TRABNK(NTRBNK-1,8)))THEN 128 - IF(TRABNK(NTRBNK,9).GT.TRABNK(NTRBNK-1,9)+PI)THEN 129 - TRABNK(NTRBNK,9)=TRABNK(NTRBNK,9)-2*PI 130 - ELSEIF(TRABNK(NTRBNK,9).LT.TRABNK(NTRBNK-1,9)-PI)THEN 131 - TRABNK(NTRBNK,9)=TRABNK(NTRBNK,9)+2*PI 132 - ENDIF 133 - ENDIF 134 - IF(LDEBUG)WRITE(LUNOUT,'(2X,''(x,y,z)='',3E11.4,'', t='',E11.4, 135 - - '', sigma='',E11.4/'' avalanche='',E11.4,'', loss='',E11.4, 136 - - '', angle='',E11.4,'', ISTAT='',I4,'',NU='',I3)') 137 - - (TRABNK(NTRBNK,J),J=1,7),TRABNK(NTRBNK,9), 138 - - NINT(TRABNK(NTRBNK,8)),NU 139 - * Plot and print the data if requested. 140 - IF(LDRPLT)CALL DLCPLT 141 - * Proceed with the next drift-line. 142 - 300 CONTINUE 143 - ** Complete the bank with the given and true end point. 144 - IF(NTRBNK+2.GT.MXLIST)THEN 145 - IF(LDEBUG)PRINT *,' ++++++ DLCTRP DEBUG : NTRBNK=MXLIST.' 146 - GOTO 390 147 - ENDIF 148 - TRABNK(NTRBNK+1,1)=XX1 149 - TRABNK(NTRBNK+1,2)=YY1 150 - TRABNK(NTRBNK+1,3)=ZZ1 151 - TRABNK(NTRBNK+1,8)=-4 152 - TRABNK(NTRBNK+2,1)=X1 153 - TRABNK(NTRBNK+2,2)=Y1 154 - TRABNK(NTRBNK+2,3)=Z1 155 - TRABNK(NTRBNK+2,8)=-4 156 - NTRBNK=NTRBNK+2 157 - ** Next add the other NLTR/4 drift-lines where delta t is largest. 158 - IF(NTRBNK.LE.5)GOTO 390 159 - IF(LDEBUG)PRINT *,' ++++++ DLCTRP DEBUG : Adding intermediate', 160 - - ' drift-lines at largest t jumps.' 161 - DO 360 IL=1,NLTR/4 162 - * Check number of drift-lines. 163 - IF(NTRBNK+1.GT.MXLIST)THEN 164 - IF(LDEBUG)PRINT *,' ++++++ DLCTRP DEBUG : NTRBNK=MXLIST.' 165 - GOTO 390 166 - ENDIF 167 - * Locate the largest t jump. 168 - DELTAT=ABS(TRABNK(4,4)-TRABNK(3,4)) 169 - IDMAX=3 170 - DO 370 JL=4,NTRBNK-3 171 - IF(ABS(TRABNK(JL+1,4)-TRABNK(JL,4)).GT.DELTAT)THEN 172 - DELTAT=ABS(TRABNK(JL+1,4)-TRABNK(JL,4)) 173 - IDMAX=JL 174 - ENDIF 175 - 370 CONTINUE 176 - * Shift everything above by one place. 1 707 P=DRIFTCAL D=DLCTRP 3 PAGE1095 177 - DO 380 JL=NTRBNK,IDMAX+1,-1 178 - DO 385 KL=1,9 179 - TRABNK(JL+1,KL)=TRABNK(JL,KL) 180 - 385 CONTINUE 181 - 380 CONTINUE 182 - * Halve the gap between the two points. 183 - TRABNK(IDMAX+1,1)=(TRABNK(IDMAX,1)+TRABNK(IDMAX+2,1))/2 184 - TRABNK(IDMAX+1,2)=(TRABNK(IDMAX,2)+TRABNK(IDMAX+2,2))/2 185 - TRABNK(IDMAX+1,3)=(TRABNK(IDMAX,3)+TRABNK(IDMAX+2,3))/2 186 - * Calculate a drift-line from the half-way point. 187 - XSTART=TRABNK(IDMAX+1,1) 188 - YSTART=TRABNK(IDMAX+1,2) 189 - ZSTART=TRABNK(IDMAX+1,3) 190 - IF(POLAR)CALL CFMCTR(XSTART,YSTART,XSTART,YSTART,1) 191 - CALL DLCALC(XSTART,YSTART,ZSTART,-1.0,1) 192 - IF(POLAR)CALL CFMRTC(XSTART,YSTART,XSTART,YSTART,1) 193 - * Add the new drift-line to the table. 194 - NTRBNK=NTRBNK+1 195 - TRABNK(IDMAX+1,4)=REAL(TU(NU)) 196 - IF(TRAFLG(5))CALL DLCDIF(TRABNK(IDMAX+1,5)) 197 - IF(TRAFLG(6))CALL DLCTWN(TRABNK(IDMAX+1,6)) 198 - IF(TRAFLG(7))CALL DLCATT(TRABNK(IDMAX+1,7)) 199 - TRABNK(IDMAX+1,8)=REAL(ISTAT) 200 - CALL DLCPHI(TRABNK(IDMAX+1,9)) 201 - IF(NINT(TRABNK(IDMAX+1,8)).EQ.NINT(TRABNK(IDMAX,8)))THEN 202 - IF(TRABNK(IDMAX+1,9).GT.TRABNK(IDMAX,9)+PI)THEN 203 - TRABNK(IDMAX+1,9)=TRABNK(IDMAX+1,9)-2*PI 204 - ELSEIF(TRABNK(IDMAX+1,9).LT.TRABNK(IDMAX,9)-PI)THEN 205 - TRABNK(IDMAX+1,9)=TRABNK(IDMAX+1,9)+2*PI 206 - ENDIF 207 - ENDIF 208 - IF(LDEBUG)WRITE(LUNOUT,'(2X,''(x,y,z)='',3E11.4,'', t='',E11.4, 209 - - '', sigma='',E11.4/'' avalanche='',E11.4,'', loss='',E11.4, 210 - - '', angle='',E11.4,'', ISTAT='',I4,'',NU='',I3)') 211 - - (TRABNK(IDMAX+1,J),J=1,7),TRABNK(IDMAX+1,9), 212 - - NINT(TRABNK(IDMAX+1,8)),NU 213 - * Plot and print the data if requested. 214 - IF(LDRPLT)CALL DLCPLT 215 - * Add another line. 216 - 360 CONTINUE 217 - ** Jump to this point if the maximum number of drift-lines is reached. 218 - 390 CONTINUE 219 - ** Finish this plot, if plotting has been requested. 220 - IF(LDRPLT)THEN 221 - CALL GRNEXT 222 - CALL GRALOG('Drift-lines from the acceptance segment.') 223 - ENDIF 224 - *** Establish the tracks major direction. 225 - ITRMAJ=1 226 - IF(ABS(TRABNK(NTRBNK,2)-TRABNK(1,2)).GT. 227 - - ABS(TRABNK(NTRBNK,ITRMAJ)-TRABNK(1,ITRMAJ)))ITRMAJ=2 228 - IF(ABS(TRABNK(NTRBNK,3)-TRABNK(1,3)).GT. 229 - - ABS(TRABNK(NTRBNK,ITRMAJ)-TRABNK(1,ITRMAJ)))ITRMAJ=3 230 - *** Prepare the distance vector used in interpolations. 231 - DO 200 J=1,NTRBNK 232 - TRAVEC(J)=ABS(TRABNK(J,1)-TRABNK(1,1))+ 233 - - ABS(TRABNK(J,2)-TRABNK(1,2))+ 234 - - ABS(TRABNK(J,3)-TRABNK(1,3)) 235 - 200 CONTINUE 236 - *** Determine maxima and minima, initialise. 237 - TMIN=TRABNK(3,4) 238 - TMAX=TRABNK(3,4) 239 - IF(TRAFLG(5))THEN 240 - SMIN=TRABNK(3,5) 241 - SMAX=TRABNK(3,5) 242 - ELSE 243 - SMIN=0.0 244 - SMAX=0.0 245 - ENDIF 246 - IF(TRAFLG(6))THEN 247 - AMIN=TRABNK(3,6) 248 - AMAX=TRABNK(3,6) 249 - ELSE 250 - AMIN=0.0 251 - AMAX=0.0 252 - ENDIF 253 - IF(TRAFLG(7))THEN 254 - BMIN=TRABNK(3,7) 255 - BMAX=TRABNK(3,7) 256 - ELSE 257 - BMIN=0.0 258 - BMAX=0.0 259 - ENDIF 260 - * Loop over the points. 261 - DO 400 I=4,NTRBNK-2 262 - TMIN=MIN(TMIN,TRABNK(I,4)) 263 - TMAX=MAX(TMAX,TRABNK(I,4)) 264 - IF(TRAFLG(5))THEN 265 - SMIN=MIN(SMIN,TRABNK(I,5)) 266 - SMAX=MAX(SMAX,TRABNK(I,5)) 267 - ENDIF 268 - IF(TRAFLG(6))THEN 269 - AMIN=MIN(AMIN,TRABNK(I,6)) 270 - AMAX=MAX(AMAX,TRABNK(I,6)) 271 - ENDIF 272 - IF(TRAFLG(7))THEN 273 - BMIN=MIN(BMIN,TRABNK(I,7)) 274 - BMAX=MAX(BMAX,TRABNK(I,7)) 275 - ENDIF 276 - 400 CONTINUE 277 - *** The track is now prepared. 278 - TRASET=.TRUE. 279 - IF(LDEBUG)THEN 280 - WRITE(LUNOUT,'('' INTERPOLATION TABLE:''/ 281 - - '' i x [cm] y [cm] z [cm]'', 282 - - '' t [microsec] sigma [1 cm] avalanche'', 1 707 P=DRIFTCAL D=DLCTRP 4 PAGE1096 283 - - '' loss status'')') 284 - DO 500 I=3,NTRBNK-2 285 - WRITE(LUNOUT,'(2X,I5,7(2X,E12.5),2X,I6)') 286 - - I,(TRABNK(I,J),J=1,7),NINT(TRABNK(I,8)) 287 - 500 CONTINUE 288 - WRITE(LUNOUT,'(/'' Major axis: '',I5)') ITRMAJ 289 - ENDIF 290 - *** Plot the various distributions if the debugging is requested. 291 - IF(LDEBUG.OR.LDRPLT)THEN 292 - * Prepare coordinate vector. 293 - DO 410 I=1,NTRBNK 294 - COORD(I)=SQRT((TRABNK(I,1)-X0)**2+(TRABNK(I,2)-Y0)**2+ 295 - - (TRABNK(I,3)-Z0)**2)/SQRT((TRABNK(NTRBNK,1)-X0)**2+ 296 - - (TRABNK(NTRBNK,2)-Y0)**2+(TRABNK(NTRBNK,3)-Z0)**2) 297 - 410 CONTINUE 298 - * Drift time. 299 - CALL GRGRPH(COORD(3),TRABNK(3,4),NTRBNK-4, 300 - - 'Track coordinate', 301 - - 'Drift time [microsec]','Drift time') 302 - DO 420 I=1,MXLIST 303 - XCL=X0+REAL(I-1)*(X1-X0)/REAL(MXLIST-1) 304 - YCL=Y0+REAL(I-1)*(Y1-Y0)/REAL(MXLIST-1) 305 - ZCL=Z0+REAL(I-1)*(Z1-Z0)/REAL(MXLIST-1) 306 - XPL(I)=REAL(I-1)/REAL(MXLIST-1) 307 - CALL DLCTRI(XCL,YCL,ZCL,YPL(I),ICL,SCL,ACL,BCL,FCL, 308 - - .FALSE.,.FALSE.,.FALSE.,IFAIL) 309 - IF(IFAIL.NE.0)YPL(I)=-1.0 310 - 420 CONTINUE 311 - CALL GRATTS('FUNCTION-2','POLYLINE') 312 - CALL GPL(MXLIST,XPL,YPL) 313 - CALL GRATTS('FUNCTION-1','POLYMARKER') 314 - CALL GPM(NTRBNK-4,COORD(3),TRABNK(3,4)) 315 - CALL GRNEXT 316 - CALL GRALOG('Prepared track - drift time:') 317 - * Incidence angle. 318 - CALL GRGRPH(COORD(3),TRABNK(3,9),NTRBNK-4, 319 - - 'Track coordinate', 320 - - 'Incidence angle [radians]','Incidence angle') 321 - DO 425 I=1,MXLIST 322 - XCL=X0+REAL(I-1)*(X1-X0)/REAL(MXLIST-1) 323 - YCL=Y0+REAL(I-1)*(Y1-Y0)/REAL(MXLIST-1) 324 - ZCL=Z0+REAL(I-1)*(Z1-Z0)/REAL(MXLIST-1) 325 - XPL(I)=REAL(I-1)/REAL(MXLIST-1) 326 - CALL DLCTRI(XCL,YCL,ZCL,TCL,ICL,SCL,ACL,BCL,YPL(I), 327 - - .FALSE.,.FALSE.,.FALSE.,IFAIL) 328 - IF(IFAIL.NE.0)YPL(I)=-1.0 329 - 425 CONTINUE 330 - CALL GRATTS('FUNCTION-2','POLYLINE') 331 - CALL GPL(MXLIST,XPL,YPL) 332 - CALL GRATTS('FUNCTION-1','POLYMARKER') 333 - CALL GPM(NTRBNK-4,COORD(3),TRABNK(3,9)) 334 - CALL GRNEXT 335 - CALL GRALOG('Prepared track - angle:') 336 - * Status code. 337 - CALL GRGRPH(COORD(3),TRABNK(3,8),NTRBNK-4, 338 - - 'Track coordinate', 339 - - 'Status code','Status code') 340 - DO 430 I=1,MXLIST 341 - XCL=X0+REAL(I-1)*(X1-X0)/REAL(MXLIST-1) 342 - YCL=Y0+REAL(I-1)*(Y1-Y0)/REAL(MXLIST-1) 343 - ZCL=Z0+REAL(I-1)*(Z1-Z0)/REAL(MXLIST-1) 344 - XPL(I)=REAL(I-1)/REAL(MXLIST-1) 345 - CALL DLCTRI(XCL,YCL,ZCL,TCL,ICL,SCL,ACL,BCL,FCL, 346 - - .FALSE.,.FALSE.,.FALSE.,IFAIL) 347 - YPL(I)=REAL(ICL) 348 - IF(IFAIL.NE.0)YPL(I)=0 349 - 430 CONTINUE 350 - CALL GRATTS('FUNCTION-2','POLYLINE') 351 - CALL GPL(MXLIST,XPL,YPL) 352 - CALL GRATTS('FUNCTION-1','POLYMARKER') 353 - CALL GPM(NTRBNK-4,COORD(3),TRABNK(3,8)) 354 - CALL GRNEXT 355 - CALL GRALOG('Prepared track - status code:') 356 - ENDIF 357 - * Diffusion coefficient. 358 - IF((LDEBUG.OR.LDRPLT).AND.TRAFLG(5))THEN 359 - CALL GRGRPH(COORD(3),TRABNK(3,5),NTRBNK-4, 360 - - 'Track coordinate', 361 - - 'Diffusion [cm for 1 cm of drift]','Diffusion') 362 - DO 440 I=1,MXLIST 363 - XCL=X0+REAL(I-1)*(X1-X0)/REAL(MXLIST-1) 364 - YCL=Y0+REAL(I-1)*(Y1-Y0)/REAL(MXLIST-1) 365 - ZCL=Z0+REAL(I-1)*(Z1-Z0)/REAL(MXLIST-1) 366 - XPL(I)=REAL(I-1)/REAL(MXLIST-1) 367 - CALL DLCTRI(XCL,YCL,ZCL,TCL,ICL,YPL(I),ACL,BCL,FCL, 368 - - .TRUE.,.FALSE.,.FALSE.,IFAIL) 369 - IF(IFAIL.NE.0)YPL(I)=-1.0 370 - 440 CONTINUE 371 - CALL GRATTS('FUNCTION-2','POLYLINE') 372 - CALL GPL(MXLIST,XPL,YPL) 373 - CALL GRATTS('FUNCTION-1','POLYMARKER') 374 - CALL GPM(NTRBNK-4,COORD(3),TRABNK(3,5)) 375 - CALL GRNEXT 376 - CALL GRALOG('Prepared track - diffusion:') 377 - ENDIF 378 - * Townsend coefficient. 379 - IF((LDEBUG.OR.LDRPLT).AND.TRAFLG(6))THEN 380 - CALL GRGRPH(COORD(3),TRABNK(3,6),NTRBNK-4, 381 - - 'Track coordinate', 382 - - 'Townsend coefficient','Townsend coefficient') 383 - DO 450 I=1,MXLIST 384 - XCL=X0+REAL(I-1)*(X1-X0)/REAL(MXLIST-1) 385 - YCL=Y0+REAL(I-1)*(Y1-Y0)/REAL(MXLIST-1) 386 - ZCL=Z0+REAL(I-1)*(Z1-Z0)/REAL(MXLIST-1) 387 - XPL(I)=REAL(I-1)/REAL(MXLIST-1) 388 - CALL DLCTRI(XCL,YCL,ZCL,TCL,ICL,SCL,YPL(I),BCL,FCL, 1 707 P=DRIFTCAL D=DLCTRP 5 PAGE1097 389 - - .FALSE.,.TRUE.,.FALSE.,IFAIL) 390 - IF(IFAIL.NE.0)YPL(I)=-1.0 391 - 450 CONTINUE 392 - CALL GRATTS('FUNCTION-2','POLYLINE') 393 - CALL GPL(MXLIST,XPL,YPL) 394 - CALL GRATTS('FUNCTION-1','POLYMARKER') 395 - CALL GPM(NTRBNK-4,COORD(3),TRABNK(3,6)) 396 - CALL GRNEXT 397 - CALL GRALOG('Prepared track - Townsend coefficient:') 398 - ENDIF 399 - * Attachment coefficient. 400 - IF((LDEBUG.OR.LDRPLT).AND.TRAFLG(7))THEN 401 - CALL GRGRPH(COORD(3),TRABNK(3,7),NTRBNK-4, 402 - - 'Track coordinate', 403 - - 'Attachment coefficient','Attachment') 404 - DO 460 I=1,MXLIST 405 - XCL=X0+REAL(I-1)*(X1-X0)/REAL(MXLIST-1) 406 - YCL=Y0+REAL(I-1)*(Y1-Y0)/REAL(MXLIST-1) 407 - ZCL=Z0+REAL(I-1)*(Z1-Z0)/REAL(MXLIST-1) 408 - XPL(I)=REAL(I-1)/REAL(MXLIST-1) 409 - CALL DLCTRI(XCL,YCL,ZCL,TCL,ICL,SCL,ACL,YPL(I),FCL, 410 - - .FALSE.,.FALSE.,.TRUE.,IFAIL) 411 - IF(IFAIL.NE.0)YPL(I)=-1.0 412 - 460 CONTINUE 413 - CALL GRATTS('FUNCTION-2','POLYLINE') 414 - CALL GPL(MXLIST,XPL,YPL) 415 - CALL GRATTS('FUNCTION-1','POLYMARKER') 416 - CALL GPM(NTRBNK-4,COORD(3),TRABNK(3,7)) 417 - CALL GRNEXT 418 - CALL GRALOG('Prepared track - Attachment:') 419 - ENDIF 420 - *** Things seem to have worked properly, flag that things are OK. 421 - IFAIL=0 422 - *** Remember how much time this took. 423 - CALL TIMLOG('Preparing the track interpolation: ') 424 - END 708 GARFIELD ================================================== P=DRIFTCAL D=DLCTRR 1 ============================ 0 + +DECK,DLCTRR. 1 - SUBROUTINE DLCTRR 2 - *----------------------------------------------------------------------- 3 - * DLCTRR - Resets track preparation. 4 - * (Last changed on 25/ 3/96.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,SIGNALDATA. 9 - TRASET=.FALSE. 10 - END 709 GARFIELD ================================================== P=DRIFTCAL D=DLCTRI 1 ============================ 0 + +DECK,DLCTRI. 1 - SUBROUTINE DLCTRI(XCL,YCL,ZCL,TCL,ICL,SCL,ACL,BCL,FCL, 2 - - LDIFF,LAVAL,LATTA,IFAIL) 3 - *----------------------------------------------------------------------- 4 - * DLCTRI - Interpolates on a track prepared by DLCTRP. The main 5 - * objective of this method is to gain lots of speed. 6 - * VARIABLES : (XCL,YCL,ZCL): Position of the cluster. 7 - * TCL : Interpolated drift-time. 8 - * ICL : ISTAT code. 9 - * SCL,ACL,BCL : Diffusion, avalanche and loss 10 - * FCL : Incidence angle on the wire 11 - * (Last changed on 20/ 5/99.) 12 - *----------------------------------------------------------------------- 13 - implicit none 14.- +SEQ,DIMENSIONS. 15.- +SEQ,SIGNALDATA. 16.- +SEQ,CELLDATA. 17.- +SEQ,PARAMETERS. 18.- +SEQ,PRINTPLOT. 19 - C logical ldebug,lident 20 - C integer lunout 21 - C parameter(ldebug=.true.,lident=.false.,lunout=6) 22.- +SEQ,DRIFTLINE. 23 - REAL XCL,YCL,ZCL,ACL,BCL,SCL,TCL,FCL,DCLUST,VV,TT,VT,DIVDIF, 24 - - XSTART,YSTART,ZSTART 25 - INTEGER ICL,IFAIL,I,ISTART,ISTPRV,IFOUND,NVEC 26 - LOGICAL LDIFF,LAVAL,LATTA 27 - EXTERNAL DIVDIF 28 - *** Identify the routine if requested. 29 - IF(LIDENT)PRINT *,' /// ROUTINE DLCTRI ///' 30 - *** Debugging output. 31 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRI DEBUG : (x,y,z) '', 32 - - 3E15.8)') XCL,YCL,ZCL 33 - *** Initialise the IFAIL flag on 1, i.e. fail, set the output to zero. 34 - IFAIL=1 35 - TCL=0.0 36 - SCL=0.0 37 - ACL=0.0 38 - BCL=1.0 39 - FCL=0.0 40 - ICL=0 41 - *** Return if the track has not been properly prepared. 42 - IF(.NOT.TRASET.OR.NTRBNK.LE.1)THEN 43 - PRINT *,' ###### DLCTRI ERROR : Interpolation cannot be'// 44 - - ' performed because the track has not been prepared.' 45 - RETURN 46 - ENDIF 47 - *** Check whether the cluster is roughly on the stored track. 48 - IF(ABS(XCL-TRABNK(1,1))+ABS(YCL-TRABNK(1,2))+ 49 - - ABS(ZCL-TRABNK(1,3)).LT.ABS(XCL-TRABNK(NTRBNK,1))+ 50 - - ABS(YCL-TRABNK(NTRBNK,2))+ABS(ZCL-TRABNK(NTRBNK,3)))THEN 51 - VT=(XCL-TRABNK(1,1))*(TRABNK(NTRBNK,1)-TRABNK(1,1))+ 52 - - (YCL-TRABNK(1,2))*(TRABNK(NTRBNK,2)-TRABNK(1,2))+ 1 709 P=DRIFTCAL D=DLCTRI 2 PAGE1098 53 - - (ZCL-TRABNK(1,3))*(TRABNK(NTRBNK,3)-TRABNK(1,3)) 54 - VV=(XCL-TRABNK(1,1))**2+ 55 - - (YCL-TRABNK(1,2))**2+ 56 - - (ZCL-TRABNK(1,3))**2 57 - TT=(TRABNK(NTRBNK,1)-TRABNK(1,1))**2+ 58 - - (TRABNK(NTRBNK,2)-TRABNK(1,2))**2+ 59 - - (TRABNK(NTRBNK,3)-TRABNK(1,3))**2 60 - ELSE 61 - VT=(XCL-TRABNK(NTRBNK,1))*(TRABNK(NTRBNK,1)-TRABNK(1,1))+ 62 - - (YCL-TRABNK(NTRBNK,2))*(TRABNK(NTRBNK,2)-TRABNK(1,2))+ 63 - - (ZCL-TRABNK(NTRBNK,3))*(TRABNK(NTRBNK,3)-TRABNK(1,3)) 64 - VV=(XCL-TRABNK(NTRBNK,1))**2+ 65 - - (YCL-TRABNK(NTRBNK,2))**2+ 66 - - (ZCL-TRABNK(NTRBNK,3))**2 67 - TT=(TRABNK(NTRBNK,1)-TRABNK(1,1))**2+ 68 - - (TRABNK(NTRBNK,2)-TRABNK(1,2))**2+ 69 - - (TRABNK(NTRBNK,3)-TRABNK(1,3))**2 70 - ENDIF 71 - *** If it isn't, then compute the drift line explicitely. 72 - IF(VV*TT-VT**2.GT.(1E-2*TT)**2.OR. 73 - - (XCL.LT.MIN(TRABNK(3,1),TRABNK(NTRBNK-2,1)).OR. 74 - - XCL.GT.MAX(TRABNK(3,1),TRABNK(NTRBNK-2,1))).OR. 75 - - (YCL.LT.MIN(TRABNK(3,2),TRABNK(NTRBNK-2,2)).OR. 76 - - YCL.GT.MAX(TRABNK(3,2),TRABNK(NTRBNK-2,2))).OR. 77 - - (ZCL.LT.MIN(TRABNK(3,3),TRABNK(NTRBNK-2,3)).OR. 78 - - ZCL.GT.MAX(TRABNK(3,3),TRABNK(NTRBNK-2,3))))THEN 79 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRI ERROR :'', 80 - - '' Cluster at '',3E15.8/26X,'' is not located'', 81 - - '' on the track.'')') XCL,YCL,ZCL 82 - GOTO 1010 83 - *** Maybe the point is very close to the begin or end point ? 84 - ELSEIF(SQRT((XCL-TRABNK(3,1))**2+(YCL-TRABNK(3,2))**2+ 85 - - (ZCL-TRABNK(3,3))**2).LT. 86 - - 1.0E-4*(1+SQRT(XCL**2+YCL**2+ZCL**2)))THEN 87 - TCL=TRABNK(3,4) 88 - SCL=TRABNK(3,5) 89 - ACL=TRABNK(3,6) 90 - BCL=TRABNK(3,7) 91 - ICL=NINT(TRABNK(3,8)) 92 - FCL=TRABNK(3,9) 93 - IFAIL=0 94 - IF(LDEBUG)PRINT *,' ++++++ DLCTRI DEBUG : Cluster'// 95 - - ' coincides with track starting point.' 96 - RETURN 97 - ELSEIF(SQRT((XCL-TRABNK(NTRBNK-2,1))**2+ 98 - - (YCL-TRABNK(NTRBNK-2,2))**2+ 99 - - (ZCL-TRABNK(NTRBNK-2,3))**2).LT. 100 - - 1.0E-4*(1+SQRT(XCL**2+YCL**2+ZCL**2)))THEN 101 - TCL=TRABNK(NTRBNK-2,4) 102 - SCL=TRABNK(NTRBNK-2,5) 103 - ACL=TRABNK(NTRBNK-2,6) 104 - BCL=TRABNK(NTRBNK-2,7) 105 - FCL=TRABNK(NTRBNK-2,9) 106 - ICL=NINT(TRABNK(NTRBNK-2,8)) 107 - IFAIL=0 108 - IF(LDEBUG)PRINT *,' ++++++ DLCTRI DEBUG : Cluster'// 109 - - ' coincides with track end point.' 110 - RETURN 111 - *** Could also be that the cluster is in the end zones. 112 - ELSEIF((TRABNK(1,1)-XCL)*(XCL-TRABNK(3,1)).GE.0.AND. 113 - - (TRABNK(1,2)-YCL)*(YCL-TRABNK(3,2)).GE.0.AND. 114 - - (TRABNK(1,3)-ZCL)*(ZCL-TRABNK(3,3)).GE.0)THEN 115 - IF(LDEBUG)PRINT *,' ++++++ DLCTRI DEBUG : Cluster in'// 116 - - ' start zone.' 117 - GOTO 1010 118 - ELSEIF((TRABNK(NTRBNK-2,1)-XCL)*(XCL-TRABNK(NTRBNK,1)).GE.0.AND. 119 - - (TRABNK(NTRBNK-2,2)-YCL)*(YCL-TRABNK(NTRBNK,2)).GE.0.AND. 120 - - (TRABNK(NTRBNK-2,3)-ZCL)*(ZCL-TRABNK(NTRBNK,3)).GE.0)THEN 121 - IF(LDEBUG)PRINT *,' ++++++ DLCTRI DEBUG : Cluster in'// 122 - - ' end zone.' 123 - GOTO 1010 124 - ENDIF 125 - *** Only cases left of points on the track. 126 - ISTPRV=NINT(TRABNK(1,8)) 127 - IFOUND=0 128 - ISTART=3 129 - DO 10 I=4,NTRBNK-1 130 - * Check whether this step covers the cluster position. 131 - IF(ISTPRV.EQ.NINT(TRABNK(I,8)).AND. 132 - - ((ITRMAJ.EQ.1.AND. 133 - - (TRABNK(I-1,1)-XCL)*(TRABNK(I,1)-XCL).LE.0).OR. 134 - - (ITRMAJ.EQ.2.AND. 135 - - (TRABNK(I-1,2)-YCL)*(TRABNK(I,2)-YCL).LE.0).OR. 136 - - (ITRMAJ.EQ.3.AND. 137 - - (TRABNK(I-1,3)-ZCL)*(TRABNK(I,3)-ZCL).LE.0)))IFOUND=I 138 - * Change of ISTAT, check whether the cluster has been covered. 139 - IF(ISTPRV.EQ.NINT(TRABNK(I,8)).AND.I.NE.NTRBNK-1)GOTO 10 140 - * Interpolate if that is the case. 141 - IF(IFOUND.NE.0)THEN 142 - * Fix the number of points in the interpolation vector. 143 - NVEC=I-ISTART 144 - IF(I.EQ.NTRBNK-1.AND.ISTPRV.EQ.NINT(TRABNK(I,8)))NVEC=NVEC+1 145 - IF(ISTART+NVEC.GT.NTRBNK-1)NVEC=NTRBNK-ISTART-1 146 - * Interpolation is not meaningful on a single point, return abend. 147 - IF(NVEC.LT.NINORD)THEN 148 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRI DEBUG :'', 149 - - '' Too few points: '',I5)') NVEC 150 - GOTO 1010 151 - * Interpolate normally with 2 or more points, then return on IFAIL=0. 152 - ELSE 153 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRI DEBUG :'', 154 - - '' Interpolation from I='',I3,'' to '',I3)') 155 - - ISTART,ISTART+NVEC-1 156 - DCLUST=ABS(XCL-TRABNK(1,1))+ABS(YCL-TRABNK(1,2))+ 157 - - ABS(ZCL-TRABNK(1,3)) 158 - ICL=NINT(TRABNK(ISTART,8)) 1 709 P=DRIFTCAL D=DLCTRI 3 PAGE1099 159 - IF(TRAFLG(4))TCL=DIVDIF(TRABNK(ISTART,4), 160 - - TRAVEC(ISTART),NVEC,DCLUST,MIN(NINORD,NVEC)) 161 - IF(TRAFLG(5).AND.LDIFF)SCL=DIVDIF(TRABNK(ISTART,5), 162 - - TRAVEC(ISTART),NVEC,DCLUST,MIN(NINORD,NVEC)) 163 - IF(TRAFLG(6).AND.LAVAL)ACL=DIVDIF(TRABNK(ISTART,6), 164 - - TRAVEC(ISTART),NVEC,DCLUST,MIN(NINORD,NVEC)) 165 - IF(TRAFLG(7).AND.LATTA)BCL=DIVDIF(TRABNK(ISTART,7), 166 - - TRAVEC(ISTART),NVEC,DCLUST,MIN(NINORD,NVEC)) 167 - IF(TRAFLG(9))FCL=DIVDIF(TRABNK(ISTART,9), 168 - - TRAVEC(ISTART),NVEC,DCLUST,MIN(NINORD,NVEC)) 169 - ENDIF 170 - IFAIL=0 171 - RETURN 172 - * Reset the current interpolation vector if not. 173 - ELSE 174 - ISTPRV=NINT(TRABNK(I,8)) 175 - ISTART=I 176 - ENDIF 177 - 10 CONTINUE 178 - *** Interpolation failed because the cluster is outside the track. 179 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRI DEBUG : Unable to'', 180 - - '' interpolate an in-range, colinear cluster.'')') 181 - *** If something fails, compute an explicit drift line. 182 - 1010 CONTINUE 183 - IF(LINCAL)THEN 184 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRI DEBUG :'', 185 - - '' Computing a drift line from '',3E12.5)') XCL,YCL,ZCL 186 - ELSE 187 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRI DEBUG :'', 188 - - '' Drift line from '',3E12.5,'' abandoned.'')') 189 - - XCL,YCL,ZCL 190 - IFAIL=0 191 - ICL=-3 192 - RETURN 193 - ENDIF 194 - * Set the starting point. 195 - XSTART=XCL 196 - YSTART=YCL 197 - ZSTART=ZCL 198 - IF(POLAR)CALL CFMCTR(XSTART,YSTART,XSTART,YSTART,1) 199 - CALL DLCALC(XSTART,YSTART,ZSTART,-1.0,1) 200 - IF(POLAR)CALL CFMRTC(XSTART,YSTART,XSTART,YSTART,1) 201 - * Store drift time, diffusion, Townsend, attachment and status. 202 - TCL=REAL(TU(NU)) 203 - IF(TRAFLG(5).AND.LDIFF)CALL DLCDIF(SCL) 204 - IF(TRAFLG(6).AND.LAVAL)CALL DLCTWN(ACL) 205 - IF(TRAFLG(7).AND.LATTA)CALL DLCATT(BCL) 206 - ICL=ISTAT 207 - CALL DLCPHI(FCL) 208 - * End of this calculation. 209 - IFAIL=0 210 - END 710 GARFIELD ================================================== P=DRIFTCAL D=DLCBCK 1 ============================ 0 + +DECK,DLCBCK. 1 - SUBROUTINE DLCBCK(ACTION) 2 - *----------------------------------------------------------------------- 3 - * DLCBCK - Stores a drift lines or restores it. 4 - * (Last changed on 22/ 1/01.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,DRIFTLINE. 9 - DOUBLE PRECISION XUCOPY(MXLIST),YUCOPY(MXLIST),ZUCOPY(MXLIST), 10 - - TUCOPY(MXLIST) 11 - REAL QPCOPY 12 - INTEGER ISCOPY,NUCOPY,I,IPCOPY,ITCOPY 13 - CHARACTER*(*) ACTION 0 14-+ +SELF,IF=SAVE. 15 - SAVE XUCOPY,YUCOPY,ZUCOPY,TUCOPY,ISCOPY,NUCOPY,IPCOPY,ITCOPY, 16 - - QPCOPY 0 17-+ +SELF. 18 - DATA ISCOPY/0/, NUCOPY/0/ 19 - *** Save if requested. 20 - IF(ACTION.EQ.'SAVE')THEN 21 - * Verify current settings. 22 - IF(NU.LT.0.OR.NU.GT.MXLIST) 23 - - PRINT *,' !!!!!! DLCBCK WARNING : Invalid number of'// 24 - - ' drift line points found; limited save.' 25 - * Store the drift line. 26 - DO 10 I=1,MIN(MXLIST,MAX(0,NU)) 27 - XUCOPY(I)=XU(I) 28 - YUCOPY(I)=YU(I) 29 - ZUCOPY(I)=ZU(I) 30 - TUCOPY(I)=TU(I) 31 - 10 CONTINUE 32 - ISCOPY=ISTAT 33 - IPCOPY=IPTYPE 34 - ITCOPY=IPTECH 35 - QPCOPY=QPCHAR 36 - NUCOPY=NU 37 - *** Restore the drift line. 38 - ELSEIF(ACTION.EQ.'RESTORE')THEN 39 - * Verify current settings. 40 - IF(NUCOPY.LT.0.OR.NUCOPY.GT.MXLIST) 41 - - PRINT *,' !!!!!! DLCBCK WARNING : Invalid number of'// 42 - - ' drift line points found; limited restore.' 43 - * Store the drift line. 44 - DO 20 I=1,MIN(MXLIST,MAX(0,NUCOPY)) 45 - XU(I)=XUCOPY(I) 46 - YU(I)=YUCOPY(I) 47 - ZU(I)=ZUCOPY(I) 48 - TU(I)=TUCOPY(I) 1 710 P=DRIFTCAL D=DLCBCK 2 PAGE1100 49 - 20 CONTINUE 50 - ISTAT=ISCOPY 51 - IPTYPE=IPCOPY 52 - IPTECH=ITCOPY 53 - QPCHAR=QPCOPY 54 - NU=NUCOPY 55 - *** Other actions are not known. 56 - ELSE 57 - PRINT *,' !!!!!! DLCBCK WARNING : Unknown action ', 58 - - ACTION,' received ; nothing done.' 59 - ENDIF 60 - END 711 GARFIELD ================================================== P=SIGNAL D= 1 ============================ 0 + +PATCH,SIGNAL. 712 GARFIELD ================================================== P=SIGNAL D=SIGINP 1 ============================ 0 + +DECK,SIGINP. 1 - SUBROUTINE SIGINP 2 - *----------------------------------------------------------------------- 3 - * SIGINP - Routine looking at the instructions in the signal section. 4 - * The actual calculations are performed by other routines. 5 - * VARIABLES : CHANGE : .TRUE. when new ion tails have to be 6 - * calculated (due to a change in parameters) 7 - * OPEN : used for checking the the unit status 8 - * (Last changed on 12/10/00.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,PARAMETERS. 13.- +SEQ,CELLDATA. 14.- +SEQ,GASDATA. 15.- +SEQ,DRIFTLINE. 16.- +SEQ,PRINTPLOT. 17.- +SEQ,SIGNALDATA. 18.- +SEQ,CONSTANTS. 19 - CHARACTER*(MXCHAR) STRING 20 - CHARACTER*20 STR1,STR2,STR3,STR4 21 - LOGICAL CHANGE,OPEN,LDIFF,LTOWN,LATTA,FLAG(MXWORD+3) 22 - INTEGER NTIMER,IFAIL,IFAIL1,IFAIL2,IFAIL3, 23 - - I,J,K,INEXT,NGRDXR,NGRDYR,NGRIDR,NWORD,NC,NFOURR,MFR, 24 - - NLTR,NLTRR,IOS,INPTYP,INPCMP,NC1,NC2,NC3,NC4 25 - REAL TDEVR,TSTARR,FACTR,RELWID,THETAR,TMIN,TMAX,SMIN,SMAX, 26 - - AMIN,AMAX,BMIN,BMAX 27 - DOUBLE PRECISION DUMMY(1) 28 - EXTERNAL INPCMP,INPTYP 0 29-+ +SELF,IF=AST. 30 - EXTERNAL ASTCCH 0 31-+ +SELF. 32 - *** Define some formats. 33 - 1110 FORMAT(' The Fourier series will have ',I10,' terms.') 34 - *** Print a heading for the signal simulation pages. 35 - WRITE(*,'(''1'')') 36 - PRINT *,' ================================================' 37 - PRINT *,' ========== Start of signal section ==========' 38 - PRINT *,' ================================================' 39 - PRINT *,' ' 40 - *** Identify the routine 41 - IF(LIDENT)PRINT *,' /// ROUTINE SIGINP ///' 42 - *** Check that sufficient gas data have been read. 43 - IF(.NOT.(GASOK(1).AND.GASOK(2).AND.(GASOK(5).OR.HEEDOK)))THEN 44 - PRINT *,' ###### SIGINP ERROR : Insufficient gasdata', 45 - - ' (needed are the electron drift velocity,' 46 - PRINT *,' the ion mobility and', 47 - - ' cluster data); this section is skipped.' 48 - CALL SKIP 49 - RETURN 50 - ENDIF 51 - *** Set default area. 52 - CALL GRASET(DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX) 53 - *** Set SIGSET, CHANGE, RESSET and AVATYP to false. 54 - SIGSET=.FALSE. 55 - CHANGE=.TRUE. 56 - AVATYP='NOT SET' 57 - RESSET=.FALSE. 58 - *** Start a loop over the input file, searching for keywords. 59 - CALL INPPRM('Signal','NEW-PRINT') 60 - 10 CONTINUE 61 - CALL INPWRD(NWORD) 0 62-+ +SELF,IF=AST. 63 - *** Set up ASTCCH as the condition handler. 64 - CALL LIB$ESTABLISH(ASTCCH) 0 65-+ +SELF. 66 - CALL INPSTR(1,1,STRING,NC) 67 - *** Skip this line if it is blank. 68 - IF(NWORD.EQ.0)GOTO 10 69 - *** Return to the main program if & is the first character. 70 - IF(STRING(1:1).EQ.'&')THEN 71 - GOTO 60 72 - *** Add noise to the signals. 73 - ELSEIF(INPCMP(1,'ADD-N#OISE').NE.0)THEN 74 - CALL SIGNOI(IFAIL) 75 - *** Look for the AREA instruction. 76 - ELSEIF(INPCMP(1,'AREA').NE.0)THEN 77 - CALL CELVIE(DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX) 78 - CALL INPERR 79 - *** Read the avalanche parameters if AVALANCHE is a keyword. 80 - ELSEIF(INPCMP(1,'AV#ALANCHE').NE.0)THEN 81 - * Print the current setting, if entered without arguments. 82 - IF(NWORD.EQ.1)THEN 1 712 P=SIGNAL D=SIGINP 2 PAGE1101 83 - IF(AVATYP.EQ.'EXPONENTIAL')THEN 84 - CALL OUTFMT(AVALAN(1),2,STR1,NC1,'LEFT') 85 - WRITE(LUNOUT,'('' The multiplication factor'', 86 - - '' is exponentially distributed with an'', 87 - - '' average of '',A,''.'')') STR1(1:NC1) 88 - ELSEIF(AVATYP.EQ.'FIXED')THEN 89 - CALL OUTFMT(AVALAN(1),2,STR1,NC1,'LEFT') 90 - WRITE(LUNOUT,'('' The multiplication factor'', 91 - - '' is '',A,'' irrespective of the'', 92 - - '' drift line.'')') STR1(1:NC1) 93 - ELSEIF(AVATYP.EQ.'GAUSSIAN')THEN 94 - CALL OUTFMT(AVALAN(1),2,STR1,NC1,'LEFT') 95 - CALL OUTFMT(AVALAN(2),2,STR2,NC2,'LEFT') 96 - WRITE(LUNOUT,'('' The multiplication factor'', 97 - - '' distribution is Gaussian with''/ 98 - - '' mean '',A,'' and relative width '',A, 99 - - ''.'')') STR1(1:NC1),STR2(1:NC2) 100 - ELSEIF(AVATYP.EQ.'NOT SET')THEN 101 - WRITE(LUNOUT,'('' No avalanche specification'', 102 - - '' has been entered in this section.'')') 103 - ELSEIF(AVATYP.EQ.'POLYA-FIXED')THEN 104 - CALL OUTFMT(AVALAN(1),2,STR1,NC1,'LEFT') 105 - CALL OUTFMT(AVALAN(2),2,STR2,NC2,'LEFT') 106 - WRITE(LUNOUT,'('' The multiplication factor'', 107 - - '' is Polya distributed''/'' with fixed'', 108 - - '' mean '',A,'' and with a parameter '', 109 - - A,''.'')') STR1(1:NC1),STR2(1:NC2) 110 - ELSEIF(AVATYP.EQ.'POLYA-TOWN')THEN 111 - CALL OUTFMT(AVALAN(1),2,STR1,NC1,'LEFT') 112 - WRITE(LUNOUT,'('' The multiplication factor'', 113 - - '' is Polya distributed with a mean''/ 114 - - '' determined by the Townsend'', 115 - - '' coefficients and with a parameter '', 116 - - A,''.'')') STR1(1:NC1) 117 - ELSEIF(AVATYP.EQ.'TOWNSEND')THEN 118 - WRITE(LUNOUT,'('' The multiplication factor'', 119 - - '' is determined by the Townsend'', 120 - - '' coefficients with exponential'', 121 - - '' fluctuations.'')') 122 - ELSEIF(AVATYP.EQ.'TOWN-FIXED')THEN 123 - WRITE(LUNOUT,'('' The multiplication factor'', 124 - - '' is determined by the Townsend'', 125 - - '' coefficients without fluctuations.'')') 126 - ELSE 127 - PRINT *,' ###### SIGINP ERROR : Avalanche type ', 128 - - AVATYP,' not known.' 129 - ENDIF 130 - * The avalanche type might be EXPONENTIAL. 131 - ELSEIF(NWORD.EQ.3.AND.INPCMP(2,'E#XPONENTIAL').NE.0)THEN 132 - AVATYP='EXPONENTIAL' 133 - CALL INPCHK(3,2,IFAIL1) 134 - CALL INPRDR(3,FACTR,0.0) 135 - IF(FACTR.GT.0.0.AND.IFAIL1.EQ.0)THEN 136 - AVALAN(1)=FACTR 137 - ELSE 138 - CALL INPMSG(3,'Multiplication is not > 0.') 139 - AVALAN(1)=1 140 - ENDIF 141 - * The avalanche type might be FIXED. 142 - ELSEIF(NWORD.EQ.3.AND.INPCMP(2,'F#IXED').NE.0)THEN 143 - AVATYP='FIXED' 144 - CALL INPCHK(3,2,IFAIL1) 145 - CALL INPRDR(3,FACTR,0.0) 146 - IF(FACTR.GT.0.0.AND.IFAIL1.EQ.0)THEN 147 - AVALAN(1)=FACTR 148 - ELSE 149 - CALL INPMSG(3,'Multiplication is not > 0.') 150 - AVALAN(1)=1 151 - ENDIF 152 - * The avalanche type might be GAUSSIAN. 153 - ELSEIF(NWORD.EQ.4.AND.INPCMP(2,'G#AUSSIAN').NE.0)THEN 154 - AVATYP='GAUSSIAN' 155 - CALL INPCHK(3,2,IFAIL1) 156 - CALL INPCHK(4,2,IFAIL2) 157 - CALL INPRDR(3,FACTR,0.0) 158 - CALL INPRDR(4,RELWID,0.0) 159 - IF(FACTR.GT.0.0.AND.IFAIL1.EQ.0)THEN 160 - AVALAN(1)=FACTR 161 - ELSE 162 - CALL INPMSG(3,'Multiplication is not > 0.') 163 - AVALAN(1)=1 164 - ENDIF 165 - IF(RELWID.GE.0.0.AND.IFAIL2.EQ.0)THEN 166 - AVALAN(2)=RELWID 167 - ELSE 168 - CALL INPMSG(4,'Relative width must be >= 0.') 169 - AVALAN(2)=0 170 - ENDIF 171 - * The avalanche type might be POLYA-FIXED. 172 - ELSEIF(NWORD.GE.2.AND.NWORD.LE.4.AND. 173 - - INPCMP(2,'P#OLYA-F#IXED')+ 174 - - INPCMP(2,'F#IXED-P#OLYA').NE.0)THEN 175 - AVATYP='POLYA-FIXED' 176 - IF(NWORD.GE.3)THEN 177 - CALL INPCHK(3,2,IFAIL1) 178 - CALL INPRDR(3,FACTR,0.0) 179 - ELSE 180 - IFAIL1=0 181 - FACTR=1 182 - ENDIF 183 - IF(FACTR.GT.0.AND.IFAIL1.EQ.0)THEN 184 - AVALAN(1)=FACTR 185 - ELSE 186 - CALL INPMSG(3,'Multiplication is not > 0.') 187 - AVALAN(1)=1 188 - ENDIF 1 712 P=SIGNAL D=SIGINP 3 PAGE1102 189 - IF(NWORD.GE.4)THEN 190 - CALL INPCHK(4,2,IFAIL2) 191 - CALL INPRDR(4,THETAR,0.5) 192 - ELSE 193 - IFAIL2=0 194 - THETAR=0.5 195 - ENDIF 196 - IF(THETAR.GT.-1.AND.IFAIL2.EQ.0)THEN 197 - AVALAN(2)=THETAR 198 - ELSE 199 - CALL INPMSG(4,'Polya parameter must be > -1.') 200 - AVALAN(2)=0.5 201 - ENDIF 202 - * The avalanche type might be POLYA-TOWNSEND. 203 - ELSEIF(NWORD.GE.2.AND.NWORD.LE.3.AND. 204 - - INPCMP(2,'P#OLYA-T#OWNSEND')+ 205 - - INPCMP(2,'T#OWNSEND-P#OLYA').NE.0)THEN 206 - AVATYP='POLYA-TOWN' 207 - IF(NWORD.GE.3)THEN 208 - CALL INPCHK(3,2,IFAIL1) 209 - CALL INPRDR(3,THETAR,0.0) 210 - ELSE 211 - IFAIL1=0 212 - THETAR=0.5 213 - ENDIF 214 - IF(THETAR.GT.-1.AND.IFAIL1.EQ.0)THEN 215 - AVALAN(1)=THETAR 216 - ELSE 217 - CALL INPMSG(3,'Polya parameter must be > -1.') 218 - AVALAN(1)=0.5 219 - ENDIF 220 - * The avalanche type might be TOWNSEND. 221 - ELSEIF(NWORD.EQ.2.AND.INPCMP(2,'T#OWNSEND').NE.0)THEN 222 - IF(GASOK(4))THEN 223 - AVATYP='TOWNSEND' 224 - ELSE 225 - CALL INPMSG(2,'No Townsend data are present. ') 226 - ENDIF 227 - * The avalanche type might be TOWNSEND-FIXED. 228 - ELSEIF(NWORD.EQ.2.AND.INPCMP(2,'T#OWNSEND-FIX#ED')+ 229 - - INPCMP(2,'FIX#ED-T#OWNSEND').NE.0)THEN 230 - IF(GASOK(4))THEN 231 - AVATYP='TOWN-FIXED' 232 - ELSE 233 - CALL INPMSG(2,'No Townsend data are present. ') 234 - ENDIF 235 - * Apparently some incorrect format has been used. 236 - ELSE 237 - PRINT *,' !!!!!! SIGINP WARNING : Incorrect format'// 238 - - ' of an AVALANCHE statement; see the writeup.' 239 - ENDIF 240 - CALL INPERR 241 - *** Look for the CHECK command. 242 - ELSEIF(INPCMP(1,'CH#ECK').NE.0)THEN 243 - CALL SIGCHK 244 - *** Convolute signals with a transfer function. 245 - ELSEIF(INPCMP(1,'CON#VOLUTE-S#IGNALS').NE.0)THEN 246 - CALL SIGCNV(IFAIL) 247 - *** Look for the FOURIER instruction. 248 - ELSEIF(INPCMP(1,'F#OURIER').NE.0)THEN 249 - IF(NWORD.EQ.1)THEN 250 - PRINT 1110,NFOUR 251 - ELSEIF(NWORD.EQ.2)THEN 252 - CALL INPCHK(2,1,IFAIL1) 253 - CALL INPRDI(2,NFOURR,1) 254 - * check the new value, replace if acceptable. 255 - MFR=NINT(LOG(REAL(NFOURR))/LOG(2.0)) 256 - IF(IFAIL1.EQ.0.AND.NFOURR.NE.2**MFR)THEN 257 - CALL INPMSG(2,'Not an integral power of 2. ') 258 - ELSEIF(IFAIL1.EQ.0.AND.NFOURR.LE.0)THEN 259 - CALL INPMSG(2,'Not larger than 0. ') 260 - ELSEIF(IFAIL1.EQ.0.AND.NFOURR.GT.MXFOUR)THEN 261 - CALL INPMSG(2,'Larger than MXFOUR. ') 262 - ELSEIF(IFAIL1.EQ.0)THEN 263 - IF(NFOUR.NE.NFOURR)THEN 264 - CHANGE=.TRUE. 265 - SIGSET=.FALSE. 266 - ENDIF 267 - NFOUR=NFOURR 268 - ENDIF 269 - ELSE 270 - PRINT *,' !!!!!! SIGINP WARNING : FOURIER takes one'// 271 - - ' argument ; instruction is ignored.' 272 - ENDIF 273 - * Print error messages. 274 - CALL INPERR 275 - *** Read track information from a dataset if GET is the command. 276 - ELSEIF(INPCMP(1,'GET-TR#ACK').NE.0)THEN 277 - CALL DLCTRG(IFAIL) 278 - *** Look for the keyword GRID. 279 - ELSEIF(INPCMP(1,'G#RID').NE.0)THEN 280 - IF(NWORD.EQ.1)THEN 281 - WRITE(LUNOUT,'('' Current grid density: '', 282 - - I3,'' by '',I3,'' points.'')') NGRIDX,NGRIDY 283 - ELSEIF(NWORD.EQ.2)THEN 284 - CALL INPCHK(2,1,IFAIL1) 285 - CALL INPRDI(2,NGRIDR,25) 286 - IF(NGRIDR.LE.1.OR.NGRIDR.GT.MXGRID) 287 - - CALL INPMSG(2,'GRID out of range 2 -> MXGRID.') 288 - CALL INPERR 289 - IF(IFAIL1.NE.0.OR.NGRIDR.LE.1.OR.NGRIDR.GT.MXGRID)THEN 290 - PRINT *,' !!!!!! SIGINP WARNING : GRID statement', 291 - - ' ignored because of syntax or value errors.' 292 - ELSE 293 - NGRIDX=NGRIDR 294 - NGRIDY=NGRIDR 1 712 P=SIGNAL D=SIGINP 4 PAGE1103 295 - ENDIF 296 - ELSEIF(NWORD.EQ.3)THEN 297 - CALL INPCHK(2,1,IFAIL1) 298 - CALL INPCHK(3,1,IFAIL2) 299 - CALL INPRDI(2,NGRDXR,25) 300 - CALL INPRDI(3,NGRDYR,25) 301 - IF(NGRDXR.LE.1.OR.NGRDXR.GT.MXGRID) 302 - - CALL INPMSG(2,'out of the range 2 -> MXGRID. ') 303 - IF(NGRDYR.LE.1.OR.NGRDYR.GT.MXGRID) 304 - - CALL INPMSG(2,'out of the range 2 -> MXGRID. ') 305 - CALL INPERR 306 - IF(IFAIL1.NE.0.OR.NGRDXR.LE.1.OR.NGRDXR.GT.MXGRID.OR. 307 - - NGRDYR.LE.1.OR.NGRDYR.GT.MXGRID)THEN 308 - PRINT *,' !!!!!! SIGINP WARNING : GRID statement', 309 - - ' ignored because of syntax or value errors.' 310 - ELSE 311 - NGRIDX=NGRDXR 312 - NGRIDY=NGRDYR 313 - ENDIF 314 - ELSE 315 - PRINT *,' !!!!!! SIGINP WARNING : GRID requires 1'// 316 - - ' or 2 arguments ; the instruction is ignored.' 317 - ENDIF 318 - * Print error messages. 319 - CALL INPERR 320 - *** Integration parameters. 321 - ELSEIF(INPCMP(1,'INT#EGRATION-#PARAMETERS').NE.0)THEN 322 - CALL DLCPAR 323 - *** If OPTION is a keyword, try and identify them: 324 - ELSEIF(INPCMP(1,'OPT#IONS').NE.0)THEN 325 - IF(NWORD.EQ.1)WRITE(LUNOUT,'( 326 - - '' LOCAL OPTIONS CURRENTLY IN EFFECT:''// 327 - - '' Plotting of track, clusters and electrons: '', 328 - - L1/ 329 - - '' Printing of track, clusters and electrons: '', 330 - - L1/ 331 - - '' Contour all media (T) or drift medium (F): '', 332 - - L1/ 333 - - '' Plotting of the drift lines (DRIFT-PLOT): '', 334 - - L1/ 335 - - '' Printing of drift line details (DRIFT-PRINT): '', 336 - - L1/ 337 - - '' Plot wires by markers (WIRE-MARKERS): '', 338 - - L1/ 339 - - '' Check for multiple field map indices: '', 340 - - L1/)') LCLPLT,LCLPRT,LCNTAM,LDRPLT,LDRPRT,LWRMRK,LMAPCH 341 - DO 11 I=2,NWORD 342 - * look for clusterplot option, 343 - IF(INPCMP(I,'NOC#LUSTER-PL#OT').NE.0)THEN 344 - LCLPLT=.FALSE. 345 - ELSEIF(INPCMP(I,'C#LUSTER-PL#OT').NE.0)THEN 346 - LCLPLT=.TRUE. 347 - * look for cluster-print option, 348 - ELSEIF(INPCMP(I,'NOC#LUSTER-PR#INT').NE.0)THEN 349 - LCLPRT=.FALSE. 350 - ELSEIF(INPCMP(I,'C#LUSTER-PR#INT').NE.0)THEN 351 - LCLPRT=.TRUE. 352 - * search for plotting-of-drift lines option, 353 - ELSEIF(INPCMP(I,'NOD#RIFT-PL#OT').NE.0)THEN 354 - LDRPLT=.FALSE. 355 - ELSEIF(INPCMP(I,'D#RIFT-PL#OT').NE.0)THEN 356 - LDRPLT=.TRUE. 357 - * search for printing-of-drift lines option, 358 - ELSEIF(INPCMP(I,'NOD#RIFT-PR#INT').NE.0)THEN 359 - LDRPRT=.FALSE. 360 - ELSEIF(INPCMP(I,'DR#IFT-PR#INT').NE.0)THEN 361 - LDRPRT=.TRUE. 362 - * Contour drawing options. 363 - ELSEIF(INPCMP(I,'CONT#OUR-ALL-#MEDIA').NE.0)THEN 364 - LCNTAM=.TRUE. 365 - ELSEIF(INPCMP(I,'CONT#OUR-DR#IFT-#MEDIUM')+ 366 - - INPCMP(I,'CONT#OUR-DR#IFT-#MEDIA').NE.0)THEN 367 - LCNTAM=.FALSE. 368 - * Wires drawn as markers. 369 - ELSEIF(INPCMP(I,'NOW#IRE-M#ARKERS').NE.0)THEN 370 - LWRMRK=.FALSE. 371 - ELSEIF(INPCMP(I,'W#IRE-M#ARKERS').NE.0)THEN 372 - LWRMRK=.TRUE. 373 - * Detect multiple map indices. 374 - ELSEIF(INPCMP(I,'CH#ECK-MAP-#INDICES')+ 375 - - INPCMP(I,'CH#ECK-MAP-#INDEXING').NE.0)THEN 376 - LMAPCH=.TRUE. 377 - ELSEIF(INPCMP(I,'NOCH#ECK-MAP-#INDICES')+ 378 - - INPCMP(I,'NOCH#ECK-MAP-#INDEXING').NE.0)THEN 379 - LMAPCH=.FALSE. 380 - * option not known. 381 - ELSE 382 - CALL INPMSG(I,'The option is not known. ') 383 - ENDIF 384 - 11 CONTINUE 385 - * Print error messages. 386 - CALL INPERR 387 - *** Plot the signal field. 388 - ELSEIF(INPCMP(1,'PL#OT-F#IELD').NE.0)THEN 389 - CALL SIGWGT 390 - *** Plot signals if PLOT-SIGNALS is a keyword. 391 - ELSEIF(INPCMP(1,'PL#OT-S#IGNALS').NE.0)THEN 392 - CALL SIGPLT 393 - *** PREPARE-TRACK: Prepare a drifting information table. 394 - ELSEIF(INPCMP(1,'PR#EPARE-#TRACK').NE.0.AND..NOT.TRFLAG(1))THEN 395 - PRINT *,' !!!!!! SIGINP WARNING : Track preparation'// 396 - - ' must be done after track definition.' 397 - * Track has indeed been defined. 398 - ELSEIF(INPCMP(1,'PR#EPARE-#TRACK').NE.0)THEN 399 - * Initial option values. 400 - LDIFF=GASOK(3) 1 712 P=SIGNAL D=SIGINP 5 PAGE1104 401 - LTOWN=GASOK(4) 402 - LATTA=GASOK(6) 403 - NLTR=NLINED 404 - * Flag recognised keywords. 405 - DO 30 I=1,NWORD+3 406 - FLAG(I)=.FALSE. 407 - IF(INPCMP(I,'A#TTACHMENT-#COEFFICIENT')+ 408 - - INPCMP(I,'D#IFFUSION-#COEFFICIENT')+ 409 - - INPCMP(I,'L#INES')+ 410 - - INPCMP(I,'NOA#TTACHMENT-#COEFFICIENT')+ 411 - - INPCMP(I,'NOD#IFFUSION-#COEFFICIENT')+ 412 - - INPCMP(I,'NOT#OWNSEND-#COEFFICIENT')+ 413 - - INPCMP(I,'T#OWNSEND-#COEFFICIENT').NE.0)FLAG(I)=.TRUE. 414 - 30 CONTINUE 415 - * Loop over the parameter string. 416 - INEXT=2 417 - DO 20 I=2,NWORD 418 - IF(I.LT.INEXT)GOTO 20 419 - * Check for the number of drift-lines to be used. 420 - IF(INPCMP(I,'L#INES').NE.0)THEN 421 - IF(I+1.GT.NWORD.OR.FLAG(I+1))THEN 422 - CALL INPMSG(I,'The argument is missing. ') 423 - ELSEIF(INPTYP(I+1).LE.0)THEN 424 - CALL INPMSG(I+1,'The argument is not numeric. ') 425 - INEXT=I+2 426 - ELSE 427 - CALL INPCHK(I+1,1,IFAIL) 428 - CALL INPRDI(I+1,NLTRR,NLTR) 429 - IF(IFAIL.EQ.0.AND.NLTRR.LT.4)THEN 430 - CALL INPMSG(I+1, 431 - - 'At least 4 lines are needed. ') 432 - ELSEIF(IFAIL.EQ.0.AND.NLTRR.GT.MXLIST-4)THEN 433 - CALL INPMSG(I+1, 434 - - 'Not more than MXLIST-4 lines. ') 435 - ELSEIF(IFAIL.EQ.0)THEN 436 - NLTR=NLTRR 437 - ENDIF 438 - INEXT=I+2 439 - ENDIF 440 - * Check for the diffusion options. 441 - ELSEIF(INPCMP(I,'D#IFFUSION-#COEFFICIENT').NE.0)THEN 442 - IF(.NOT.GASOK(3))THEN 443 - CALL INPMSG(I,'No diffusion data are present.') 444 - ELSE 445 - LDIFF=.TRUE. 446 - ENDIF 447 - ELSEIF(INPCMP(I,'NOD#IFFUSION-#COEFFICIENT').NE.0)THEN 448 - LDIFF=.FALSE. 449 - * Check for the Townsend options. 450 - ELSEIF(INPCMP(I,'T#OWNSEND-#COEFFICIENT').NE.0)THEN 451 - IF(.NOT.GASOK(4))THEN 452 - CALL INPMSG(I,'No Townsend data are present. ') 453 - ELSE 454 - LTOWN=.TRUE. 455 - ENDIF 456 - ELSEIF(INPCMP(I,'NOT#OWNSEND-#COEFFICIENT').NE.0)THEN 457 - LTOWN=.FALSE. 458 - * Check for the attachment options. 459 - ELSEIF(INPCMP(I,'A#TTACHMENT-#COEFFICIENT').NE.0)THEN 460 - IF(.NOT.GASOK(6))THEN 461 - CALL INPMSG(I,'No attachment data are present') 462 - ELSE 463 - LATTA=.TRUE. 464 - ENDIF 465 - ELSEIF(INPCMP(I,'NOA#TTACHMENT-#COEFFICIENT').NE.0)THEN 466 - LATTA=.FALSE. 467 - * Unrecognised option. 468 - ELSE 469 - CALL INPMSG(I,'Invalid option, ignored. ') 470 - ENDIF 471 - 20 CONTINUE 472 - * Dump error messages. 473 - CALL INPERR 474 - * Call the preparation routine with proper arguments. 475 - CALL DLCTRP(XT0,YT0,ZT0,XT1,YT1,ZT1,LDIFF,LTOWN,LATTA,NLTR, 476 - - TMIN,TMAX,SMIN,SMAX,AMIN,AMAX,BMIN,BMAX,IFAIL) 477 - *** Reset various things. 478 - ELSEIF(INPCMP(1,'RESET').NE.0)THEN 479 - * No keywords, reset everything. 480 - IF(NWORD.EQ.1)THEN 481 - DO 110 K=1,MXSW 482 - DO 120 J=1,MXLIST 483 - SIGNAL(J,K,1)=0.0 484 - SIGNAL(J,K,2)=0.0 485 - 120 CONTINUE 486 - 110 CONTINUE 487 - RESSET=.FALSE. 488 - AVATYP='NOT SET' 489 - SIGSET=.FALSE. 490 - CALL SIGIST('CLOSE',0,DUMMY,DUMMY,0,0,0,0,IFAIL1) 491 - IF(TYPE.NE.'MAP')THEN 492 - CALL BOOK('RELEASE','MATRIX','SIGNAL',IFAIL1) 493 - IF(IFAIL1.NE.0) 494 - - PRINT *,' !!!!!! SIGINP WARNING : Unable '// 495 - - 'to release signal matrix storage.' 496 - ENDIF 497 - ELSE 498 - * Otherwise, loop over the keywords. 499 - DO 70 I=2,NWORD 500 - IF(INPCMP(I,'SIG#NALS').NE.0)THEN 501 - DO 80 K=1,MXSW 502 - DO 90 J=1,MXLIST 503 - SIGNAL(J,K,1)=0.0 504 - SIGNAL(J,K,2)=0.0 505 - 90 CONTINUE 506 - 80 CONTINUE 1 712 P=SIGNAL D=SIGINP 6 PAGE1105 507 - ELSEIF(INPCMP(I,'RES#OLUTION')+INPCMP(I,'WIN#DOW')+ 508 - - INPCMP(I,'TIME-WIN#DOW').NE.0)THEN 509 - RESSET=.FALSE. 510 - ELSEIF(INPCMP(I,'AVA#LANCHE-#MODEL').NE.0)THEN 511 - AVATYP='NOT SET' 512 - ELSEIF(INPCMP(I,'MAT#RICES').NE.0)THEN 513 - SIGSET=.FALSE. 514 - CALL SIGIST('CLOSE',0,DUMMY,DUMMY,0,0,0,0,IFAIL1) 515 - IF(TYPE.NE.'MAP')THEN 516 - CALL BOOK('RELEASE','MATRIX','SIGNAL',IFAIL1) 517 - IF(IFAIL1.NE.0) 518 - - PRINT *,' !!!!!! SIGINP WARNING :'// 519 - - ' Unable to release signal matrix'// 520 - - ' storage.' 521 - ENDIF 522 - ELSE 523 - CALL INPMSG(I,'Not a known option.') 524 - ENDIF 525 - 70 CONTINUE 526 - * Print error messages. 527 - CALL INPERR 528 - ENDIF 529 - *** Look for the time window. 530 - ELSEIF(INPCMP(1,'RES#OLUTION')+INPCMP(1,'WIN#DOW')+ 531 - - INPCMP(1,'T#IME-WIN#DOW').NE.0)THEN 532 - IF(NWORD.EQ.1)THEN 533 - IF(RESSET)THEN 534 - CALL OUTFMT(TSTART,2,STR1,NC1,'LEFT') 535 - CALL OUTFMT(TSTART+(NTIME-1)*TDEV,2,STR2,NC2, 536 - - 'LEFT') 537 - CALL OUTFMT(REAL(NTIME),2,STR3,NC3,'LEFT') 538 - CALL OUTFMT(TDEV,2,STR4,NC4,'LEFT') 539 - WRITE(LUNOUT,'('' Time window: ['',A, 540 - - '', '',A,''] microsec, in '',A, 541 - - '' steps of '',A,'' microsec.'')') 542 - - STR1(1:NC1),STR2(1:NC2),STR3(1:NC3), 543 - - STR4(1:NC4) 544 - ELSE 545 - WRITE(LUNOUT,'('' The time window has not'', 546 - - '' yet been set.'')') 547 - ENDIF 548 - ELSEIF(NWORD.LE.4)THEN 549 - CALL INPCHK(2,2,IFAIL1) 550 - CALL INPCHK(3,2,IFAIL2) 551 - CALL INPCHK(4,1,IFAIL3) 552 - CALL INPRDR(2,TSTARR,TSTART) 553 - CALL INPRDR(3,TDEVR,TDEV) 554 - CALL INPRDI(4,NTIMER,NTIME) 555 - IF(IFAIL1.EQ.0.AND.TSTARR.LT.0.0)THEN 556 - CALL INPMSG(2,'The starting time is not > 0 ') 557 - IFAIL1=1 558 - ENDIF 559 - IF(IFAIL2.EQ.0.AND.TDEVR.LE.0.0)THEN 560 - CALL INPMSG(3,'The time resolution is not > 0') 561 - IFAIL2=1 562 - ENDIF 563 - IF(IFAIL3.EQ.0.AND. 564 - - (NTIMER.LE.1.OR.NTIMER.GT.MXLIST))THEN 565 - CALL INPMSG(4,'Number of samples not in range') 566 - IFAIL3=1 567 - ENDIF 568 - * if the TSTART, TDEV read from input are > 0 transfer to TSTART, TDEV 569 - IF(IFAIL1.EQ.0)THEN 570 - IF(TSTART.NE.TSTARR)CHANGE=.TRUE. 571 - TSTART=TSTARR 572 - ELSE 573 - PRINT *,' !!!!!! SIGINP WARNING : Start time in'// 574 - - ' RESOLUTION is ignored because of errors' 575 - ENDIF 576 - IF(IFAIL2.EQ.0)THEN 577 - IF(TDEV.NE.TDEVR)CHANGE=.TRUE. 578 - TDEV=TDEVR 579 - ELSE 580 - PRINT *,' !!!!!! SIGINP WARNING : Resolution in'// 581 - - ' RESOLUTION is ignored because of errors.' 582 - ENDIF 583 - IF(IFAIL3.EQ.0)THEN 584 - IF(NTIMER.NE.NTIME)CHANGE=.TRUE. 585 - NTIME=NTIMER 586 - ELSE 587 - PRINT *,' !!!!!! SIGINP WARNING : Number of'// 588 - - ' samples in RESOLUTION ignored because'// 589 - - ' of errors.' 590 - ENDIF 591 - * Preset a vector of signal times. 592 - DO 40 I=1,MXLIST 593 - TIMSIG(I)=TSTART+(I-1)*TDEV 594 - DO 100 J=1,MXSW 595 - SIGNAL(I,J,1)=0.0 596 - SIGNAL(I,J,2)=0.0 597 - 100 CONTINUE 598 - 40 CONTINUE 599 - RESSET=.TRUE. 600 - * Incorrect number of arguments. 601 - ELSE 602 - PRINT *,' !!!!!! SIGINP WARNING : RESOLUTION takes'// 603 - - ' 1, 2 or 3 arguments ; instruction is ignored.' 604 - ENDIF 605 - * Print error messages. 606 - CALL INPERR 607 - *** Search for the SELECT instruction. 608 - ELSEIF(INPCMP(1,'SEL#ECT').NE.0)THEN 609 - CALL CELSEL 610 - CHANGE=.TRUE. 611 - *** Start simulation if SIGNAL is a keyword. 612 - ELSEIF(INPCMP(1,'SIG#NAL').NE.0)THEN 1 712 P=SIGNAL D=SIGINP 7 PAGE1106 613 - CALL SIGGEN(CHANGE) 0 614-+ +SELF,IF=NEVER. 615 - *** The THRESHOLD command. 616 - ELSEIF(INPCMP(1,'THR#ESHOLD').NE.0)THEN 617 - CALL SIGTHR 0 618-+ +SELF. 619 - *** Look for the instruction TRACK. 620 - ELSEIF(INPCMP(1,'TR#ACK').NE.0)THEN 621 - CALL TRAREA 622 - *** Write signals if WRITE-SIGNALS is a keyword. 623 - ELSEIF(INPCMP(1,'WR#ITE-S#IGNALS').NE.0)THEN 624 - CALL SIGWRT 625 - *** Write the track data if WRITE-TRACK is a keyword. 626 - ELSEIF(INPCMP(1,'WR#ITE-T#RACK').NE.0)THEN 627 - CALL DLCTRW 628 - *** The instruction is not known. 629 - ELSE 630 - CALL INPSTR(1,1,STRING,NC) 631 - PRINT *,' !!!!!! SIGINP WARNING : '//STRING(1:NC)//' is'// 632 - - ' not a valid instruction ; it is ignored.' 633 - ENDIF 634 - *** End loop over input. 635 - GOTO 10 636 - *** Normal end of this routine: close scratch units if open. 637 - 60 CONTINUE 638 - INQUIRE(UNIT=13,OPENED=OPEN) 639 - IF(OPEN)CLOSE(UNIT=13,IOSTAT=IOS,ERR=2030) 640 - IF(SIGSET)THEN 641 - CALL SIGIST('CLOSE',0,DUMMY,DUMMY,0,0,0,0,IFAIL1) 642 - IF(TYPE.NE.'MAP')THEN 643 - CALL BOOK('RELEASE','MATRIX','SIGNAL',IFAIL1) 644 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! SIGINP WARNING :'// 645 - - ' Unable to release signal matrix storage.' 646 - ENDIF 647 - SIGSET=.FALSE. 648 - ENDIF 649 - RETURN 650 - *** Handle error conditions. 651 - 2030 CONTINUE 652 - PRINT *,' !!!!!! SIGINP WARNING : Problems closing scratch'// 653 - - ' data set on unit 13 or 14 (used for intermediate'// 654 - - ' results);' 655 - PRINT *,' new simulations are'// 656 - - ' probably not possible.' 657 - CALL INPIOS(IOS) 658 - END 713 GARFIELD ================================================== P=SIGNAL D=SIGGEN 1 ============================ 0 + +DECK,SIGGEN. 1 - SUBROUTINE SIGGEN(CHANGE) 2 - *----------------------------------------------------------------------- 3 - * SIGGEN - Routine computing a single signal. 4 - * VARIABLES : CHANGE : see routine SIGINP 5 - * (Last changed on 14/11/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,GASDATA. 11.- +SEQ,PARAMETERS. 12.- +SEQ,PRINTPLOT. 13.- +SEQ,DRIFTLINE. 14.- +SEQ,SIGNALDATA. 15 - INTEGER NASIMR,NISIMR,NORIAR,JIORDR,IFAIL,IFAIL1, 16 - - INEXT,I,J,NWORD,INPTYP,INPCMP 17 - REAL PRSR,XT0P,YT0P,XT1P,YT1P,XR0,XR1,YR0,YR1 18 - DOUBLE PRECISION DUMMY(1) 19 - LOGICAL CHANGE,LSIGAD,LDIFF,LAVAL,LATTA,LTRACK,LTRMC,OK 20 - EXTERNAL INPTYP,INPCMP 0 21-+ +SELF,IF=SAVE. 22 - SAVE LDIFF ,LAVAL ,LATTA ,LTRACK ,LTRMC 0 23-+ +SELF. 24 - DATA LDIFF ,LAVAL ,LATTA ,LTRACK ,LTRMC 25 - - /.TRUE.,.TRUE.,.TRUE.,.FALSE.,.FALSE./ 26 - *** Identify the routine 27 - IF(LIDENT)PRINT *,' /// ROUTINE SIGGEN ///' 28 - *** Reset the addition flag each time. 29 - LSIGAD=.FALSE. 30 - *** Ensure that we can do this, assume for a start this is OK. 31 - OK=.TRUE. 32 - * Check location definition. 33 - IF(.NOT.TRFLAG(1))THEN 34 - PRINT *,' !!!!!! SIGGEN WARNING : The track location'// 35 - - ' has not been set.' 36 - OK=.FALSE. 37 - ELSE 38 - * Check that the track lies at least partially in the drift area. 39 - IF(POLAR)THEN 40 - IFAIL=0 41 - CALL CFMCTR(XT0,YT0,XR0,YR0,1) 42 - CALL CFMCTR(XT1,YT1,XR1,YR1,1) 43 - IF(XR0.LT.DXMIN.OR.XR0.GT.DXMAX.OR. 44 - - XR1.LT.DXMIN.OR.XR1.GT.DXMAX.OR. 45 - - YR0.LT.DYMIN.OR.YR0.GT.DYMAX.OR. 46 - - YR1.LT.DYMIN.OR.YR1.GT.DYMAX)THEN 47 - PRINT *,' !!!!!! SIGGEN WARNING : The track'// 48 - - ' is located at least partialy outside'// 49 - - ' the drift area.' 50 - OK=.FALSE. 51 - ENDIF 52 - ELSE 1 713 P=SIGNAL D=SIGGEN 2 PAGE1107 53 - CALL CLIP3(XT0,YT0,ZT0,XT1,YT1,ZT1, 54 - - DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX,IFAIL) 55 - IF(IFAIL.NE.0)THEN 56 - PRINT *,' !!!!!! SIGGEN WARNING : The track is'// 57 - - ' not located at least partially in the'// 58 - - ' drift area.' 59 - OK=.FALSE. 60 - ENDIF 61 - ENDIF 62 - ENDIF 63 - * Clustering model. 64 - IF(ITRTYP.EQ.0)THEN 65 - PRINT *,' !!!!!! SIGGEN WARNING : The clustering model'// 66 - - ' has yet not been set.' 67 - OK=.FALSE. 68 - ENDIF 69 - * Avalanche type. 70 - IF(AVATYP.EQ.'NOT SET')THEN 71 - PRINT *,' !!!!!! SIGGEN WARNING : The avalanche type has'// 72 - - ' not yet been set.' 73 - OK=.FALSE. 74 - ENDIF 75 - * Avalanche type. 76 - IF(.NOT.RESSET)THEN 77 - PRINT *,' !!!!!! SIGGEN WARNING : The time resolution has'// 78 - - ' not yet been set.' 79 - OK=.FALSE. 80 - DO 60 I=1,NTIME 81 - TIMSIG(I)=TSTART+(I-1)*TDEV 82 - 60 CONTINUE 83 - ENDIF 84 - * Return if not OK. 85 - IF(JFAIL.EQ.2.AND..NOT.OK)THEN 86 - PRINT *,' ###### SIGGEN ERROR : No signal simulation'// 87 - - ' because of the above warnings.' 88 - RETURN 89 - ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN 90 - PRINT *,' ###### SIGGEN ERROR : Program terminated'// 91 - - ' because of the above warnings.' 92 - CALL QUIT 93 - ELSEIF(.NOT.OK)THEN 94 - PRINT *,' !!!!!! SIGGEN WARNING : No signal simulation'// 95 - - ' because of the above warnings.' 96 - RETURN 97 - ENDIF 98 - *** Decode the argument string. 99 - CALL INPNUM(NWORD) 100 - INEXT=2 101 - DO 10 I=2,NWORD 102 - IF(I.LT.INEXT)GOTO 10 103 - * Look for the electron-pulse options. 104 - IF(INPCMP(I,'NOELE#CTRON-#PULSE').NE.0)THEN 105 - LEPULS=.FALSE. 106 - ELSEIF(INPCMP(I,'ELE#CTRON-#PULSE').NE.0)THEN 107 - LEPULS=.TRUE. 108 - * Look for the ion-pulse options. 109 - ELSEIF(INPCMP(I,'NOION-T#AIL').NE.0)THEN 110 - LITAIL=.FALSE. 111 - LDTAIL=.FALSE. 112 - LRTAIL=.FALSE. 113 - ELSEIF(INPCMP(I,'ION-T#AIL')+ 114 - - INPCMP(I,'SIMPLE-ION-T#AIL').NE.0)THEN 115 - LITAIL=.TRUE. 116 - LDTAIL=.FALSE. 117 - LRTAIL=.FALSE. 118 - ELSEIF(INPCMP(I,'DET#AILED-I#ON-#TAIL').NE.0)THEN 119 - LITAIL=.FALSE. 120 - LDTAIL=.TRUE. 121 - LRTAIL=.FALSE. 122 - ELSEIF(INPCMP(I,'NONSAMP#LED-I#ON-#TAIL').NE.0)THEN 123 - LITAIL=.FALSE. 124 - LDTAIL=.FALSE. 125 - LRTAIL=.TRUE. 126 - * Look for the cross-talk options. 127 - ELSEIF(INPCMP(I,'NOCR#OSS-#INDUCED-#SIGNAL').NE.0)THEN 128 - LCROSS=.FALSE. 129 - ELSEIF(INPCMP(I,'CR#OSS-#INDUCED-#SIGNAL').NE.0)THEN 130 - IF(.NOT.LCROSS)CHANGE=.TRUE. 131 - LCROSS=.TRUE. 132 - * Look for the diffusion options. 133 - ELSEIF(INPCMP(I,'NODIFF#USION').NE.0)THEN 134 - LDIFF=.FALSE. 135 - ELSEIF(INPCMP(I,'DIFF#USION').NE.0)THEN 136 - LDIFF=.TRUE. 137 - * Look for the track interpolation options. 138 - ELSEIF(INPCMP(I,'NOINT#ERPOLATE-TR#ACK').NE.0)THEN 139 - LTRACK=.FALSE. 140 - ELSEIF(INPCMP(I,'INT#ERPOLATE-TR#ACK').NE.0)THEN 141 - IF(.NOT.TRASET)THEN 142 - CALL INPMSG(I,'The track is not prepared.') 143 - ELSE 144 - LTRACK=.TRUE. 145 - ENDIF 146 - * Look for the Monte Carlo option. 147 - ELSEIF(INPCMP(I,'NOMC-DR#IFT-#LINES')+ 148 - - INPCMP(I,'NOM#ONTE-C#ARLO-DR#IFT-#LINES')+ 149 - - INPCMP(I,'RUN#GE-K#UTTA-DR#IFT-#LINES').NE.0)THEN 150 - LTRMC=.FALSE. 151 - ELSEIF(INPCMP(I,'MC-DR#IFT-#LINES')+ 152 - - INPCMP(I,'M#ONTE-C#ARLO-DR#IFT-#LINES').NE.0)THEN 153 - LTRMC=.TRUE. 154 - * Look for the avalanche options. 155 - ELSEIF(INPCMP(I,'NOAVAL#ANCHE').NE.0)THEN 156 - LAVAL=.FALSE. 157 - ELSEIF(INPCMP(I,'AVAL#ANCHE').NE.0)THEN 158 - IF(AVATYP.EQ.'NOT SET')PRINT *,' !!!!!! SIGGEN WARNING :', 1 713 P=SIGNAL D=SIGGEN 3 PAGE1108 159 - - ' No avalanche specification seen so far; fixed', 160 - - ' (perhaps default) factor used.' 161 - LAVAL=.TRUE. 162 - * Look for the attachment options. 163 - ELSEIF(INPCMP(I,'NOATT#ACHMENT').NE.0)THEN 164 - LATTA=.FALSE. 165 - ELSEIF(INPCMP(I,'ATT#ACHMENT').NE.0)THEN 166 - IF(.NOT.GASOK(6))THEN 167 - CALL INPMSG(I,'No attachment data') 168 - ELSE 169 - LATTA=.TRUE. 170 - ENDIF 171 - * Look for the ADD/NEW option. 172 - ELSEIF(INPCMP(I,'ADD').NE.0)THEN 173 - LSIGAD=.TRUE. 174 - ELSEIF(INPCMP(I,'NEW').NE.0)THEN 175 - LSIGAD=.FALSE. 176 - * Look for an angular spread function. 177 - ELSEIF(INPCMP(I,'ANG#ULAR-SP#READ').NE.0)THEN 178 - IF(NWORD.LT.I+1)THEN 179 - CALL INPMSG(I,'The function is missing.') 180 - ELSEIF(INPCMP(I+1,'FL#AT').NE.0)THEN 181 - NCANG=1 182 - FCNANG='1' 183 - IENANG=0 184 - LITAIL=.TRUE. 185 - ELSE 186 - IENANG=0 187 - LITAIL=.TRUE. 188 - CALL INPSTR(I+1,I+1,FCNANG,NCANG) 189 - ENDIF 190 - INEXT=I+2 191 - ELSEIF(INPCMP(I,'NOANG#ULAR-SP#READ').NE.0)THEN 192 - IENANG=0 193 - NCANG=0 194 - * Look for angular integration options. 195 - ELSEIF(INPCMP(I,'ANG#ULAR-INT#EGRATION-P#OINTS').NE.0)THEN 196 - IF(INPTYP(I+1).EQ.1)THEN 197 - CALL INPCHK(I+1,1,IFAIL1) 198 - CALL INPRDI(I+1,NASIMR,2) 199 - IF(NASIMR.GT.0)THEN 200 - NASIMP=NASIMR 201 - LITAIL=.TRUE. 202 - ELSE 203 - CALL INPMSG(I+1,'Number out of range.') 204 - ENDIF 205 - INEXT=I+2 206 - ELSEIF(INPTYP(I+1).EQ.4)THEN 207 - NASIMP=2 208 - INEXT=I+2 209 - LITAIL=.TRUE. 210 - ENDIF 211 - * Look for number of ion angles. 212 - ELSEIF(INPCMP(I,'ION-ANG#LES').NE.0)THEN 213 - IF(INPCMP(I+1,'NOSAMP#LING')+INPCMP(I+1,'NOSAMP#LES')+ 214 - - INPCMP(I+1,'INF#INITE').NE.0)THEN 215 - LRTAIL=.TRUE. 216 - ELSEIF(INPTYP(I+1).EQ.1)THEN 217 - CALL INPCHK(I+1,1,IFAIL1) 218 - CALL INPRDI(I+1,NORIAR,MXORIA) 219 - IF(NORIAR.GE.1.AND.NORIAR.LE.MXORIA)THEN 220 - IF(NORIAR.NE.NORIA)CHANGE=.TRUE. 221 - LITAIL=.TRUE. 222 - NORIA=NORIAR 223 - ELSE 224 - CALL INPMSG(I+1,'Number out of range.') 225 - ENDIF 226 - INEXT=I+2 227 - ELSEIF(INPTYP(I+1).EQ.4)THEN 228 - LITAIL=.TRUE. 229 - NORIA=MIN(50,MXORIA) 230 - INEXT=I+2 231 - ENDIF 232 - * Look for signal averaging / sampling options. 233 - ELSEIF(INPCMP(I,'SAMP#LE-#SIGNAL').NE.0)THEN 234 - NISIMP=0 235 - ELSEIF(INPCMP(I,'AVER#AGE-#SIGNAL').NE.0)THEN 236 - IF(INPTYP(I+1).EQ.1)THEN 237 - CALL INPCHK(I+1,1,IFAIL1) 238 - CALL INPRDI(I+1,NISIMR,2) 239 - IF(NISIMR.GT.0.AND.IFAIL1.EQ.0)THEN 240 - NISIMP=NISIMR 241 - ELSE 242 - CALL INPMSG(I+1,'Not a valid number.') 243 - ENDIF 244 - INEXT=I+2 245 - ELSEIF(INPTYP(I+1).EQ.4)THEN 246 - NISIMP=2 247 - INEXT=I+2 248 - ENDIF 249 - * Signal interpolation order. 250 - ELSEIF(INPCMP(I,'INT#ERPOLATION-ORD#ER').NE.0)THEN 251 - IF(INPTYP(I+1).EQ.1)THEN 252 - CALL INPCHK(I+1,1,IFAIL1) 253 - CALL INPRDI(I+1,JIORDR,2) 254 - IF(JIORDR.GT.0.AND.IFAIL1.EQ.0)THEN 255 - JIORD=JIORDR 256 - ELSE 257 - CALL INPMSG(I+1,'Not a valid number.') 258 - ENDIF 259 - INEXT=I+2 260 - ELSEIF(INPTYP(I+1).EQ.4)THEN 261 - JIORD=1 262 - INEXT=I+2 263 - ENDIF 264 - * Ion production threshold. 1 713 P=SIGNAL D=SIGGEN 4 PAGE1109 265 - ELSEIF(INPCMP(I,'ION-THR#ESHOLD').NE.0)THEN 266 - IF(INPTYP(I+1).EQ.1)THEN 267 - CALL INPCHK(I+1,2,IFAIL1) 268 - CALL INPRDR(I+1,PRSR,PRSTHR) 269 - IF(PRSR.GE.0.AND.PRSR.LT.1.AND.IFAIL1.EQ.0)THEN 270 - PRSTHR=PRSR 271 - LDTAIL=.TRUE. 272 - ELSE 273 - CALL INPMSG(I+1,'Not a valid number.') 274 - ENDIF 275 - INEXT=I+2 276 - ELSEIF(INPTYP(I+1).EQ.4)THEN 277 - PRSTHR=1.0E-4 278 - INEXT=I+2 279 - LDTAIL=.TRUE. 280 - ENDIF 281 - * The option is not known. 282 - ELSE 283 - CALL INPMSG(I,'The option is not known. ') 284 - ENDIF 285 - 10 CONTINUE 286 - *** Print the error messages. 287 - CALL INPERR 288 - *** Check consistency of options. 289 - IF(LTRACK.AND.LEPULS)THEN 290 - PRINT *,' !!!!!! SIGGEN WARNING : The INTERPOLATE-TRACK'// 291 - - ' and ELECTRON-PULSE options' 292 - PRINT *,' are mutually exclusive'// 293 - - ' ; INTERPOLATE-TRACK cancelled.' 294 - LTRACK=.FALSE. 295 - ENDIF 296 - IF(LTRACK.AND.LDTAIL)THEN 297 - PRINT *,' !!!!!! SIGGEN WARNING : The INTERPOLATE-TRACK'// 298 - - ' and DETAILED-ION-TAIL options' 299 - PRINT *,' are mutually exclusive'// 300 - - ' ; INTERPOLATE-TRACK cancelled.' 301 - LTRACK=.FALSE. 302 - ENDIF 303 - IF(LTRACK.AND.LTRMC)THEN 304 - PRINT *,' !!!!!! SIGGEN WARNING : The INTERPOLATE-TRACK'// 305 - - ' and MONTE-CARLO-TRACKS options' 306 - PRINT *,' are mutually exclusive'// 307 - - ' ; INTERPOLATE-TRACK cancelled.' 308 - LTRACK=.FALSE. 309 - ENDIF 310 - IF(LEPULS.AND..NOT.GASOK(4))THEN 311 - PRINT *,' !!!!!! SIGGEN WARNING : ELECTRON-PULSE has been'// 312 - - ' requested, but the Townsend' 313 - PRINT *,' coefficients are'// 314 - - ' missing ; ELECTRON-PULSE cancelled.' 315 - LEPULS=.FALSE. 316 - ENDIF 317 - IF(LTRMC.AND..NOT.LDIFF)THEN 318 - PRINT *,' !!!!!! SIGGEN WARNING : DIFFUSION is implied'// 319 - - ' by MC-DRIFT; diffusion included.' 320 - ENDIF 321 - *** Make sure we don't have LATTA on and the data absent. 322 - LATTA=LATTA.AND.GASOK(6) 323 - *** Check the correct use of ADD and NEW. 324 - IF(LSIGAD.AND.CHANGE)PRINT *,' !!!!!! SIGGEN WARNING : New'// 325 - - ' signal cannot be added to old one since you changed'// 326 - - ' a parameter.' 327 - IF((.NOT.LSIGAD).OR.CHANGE)THEN 328 - DO 30 I=1,MXSW 329 - DO 20 J=1,MXLIST 330 - SIGNAL(J,I,1)=0.0 331 - SIGNAL(J,I,2)=0.0 332 - 20 CONTINUE 333 - 30 CONTINUE 334 - ENDIF 335 - *** Make sure at least some signal output is requested. 336 - IF(.NOT.(LEPULS.OR.LITAIL.OR.LDTAIL.OR.LRTAIL))THEN 337 - PRINT *,' !!!!!! SIGGEN WARNING : Neither electron pulses'// 338 - - ' nor ion tails are to be included ; no simulation.' 339 - RETURN 340 - ENDIF 341 - IF(NSW.EQ.0)THEN 342 - PRINT *,' !!!!!! SIGGEN WARNING : No sense wires has been'// 343 - - ' selected ; no signals calculated.' 344 - RETURN 345 - ENDIF 346 - *** Initialise the matrices, cell type and signal storage. 347 - IF(.NOT.SIGSET)THEN 348 - CALL SIGINI(IFAIL) 349 - IF(IFAIL.NE.0)THEN 350 - PRINT *,' !!!!!! SIGGEN WARNING : Initialisation of'// 351 - - ' signal calculation failed; no signals.' 352 - RETURN 353 - ENDIF 354 - ENDIF 355 - *** Print a header, if cluster printing has been enabled. 356 - IF(LCLPRT)THEN 357 - IF(POLAR)THEN 358 - CALL CFMCTP(XT0,YT0,XT0P,YT0P,1) 359 - CALL CFMCTP(XT1,YT1,XT1P,YT1P,1) 360 - ELSE 361 - XT0P=XT0 362 - YT0P=YT0 363 - XT1P=XT1 364 - YT1P=YT1 365 - ENDIF 366 - WRITE(LUNOUT,'('' Signal simulation:''/ 367 - - '' ==================''// 368 - - '' The track begins at ('', 369 - - E15.8,2('','',E15.8),'')''/ 370 - - '' and ends at ('', 1 713 P=SIGNAL D=SIGGEN 5 PAGE1110 371 - - E15.8,2('','',E15.8),'')''/)') 372 - - XT0P,YT0P,ZT0,XT1P,YT1P,ZT1 373 - CALL CELPRC(LUNOUT,0) 374 - ENDIF 375 - *** Open/reset the storage file. 376 - IF(CHANGE)THEN 377 - CALL SIGIST('RESET',0,DUMMY,DUMMY,0,0,0,0,IFAIL) 378 - IF(IFAIL.NE.0)THEN 379 - PRINT *,' !!!!!! SIGGEN WARNING : Unable to'// 380 - - ' reset a signal storage file; no signals.' 381 - RETURN 382 - ENDIF 383 - ENDIF 384 - *** Start simulation by generating clusters, also add signals. 385 - CALL SIGCLS(LDIFF,LAVAL,LATTA,LTRACK,LTRMC,IFAIL) 386 - IF(IENANG.GT.0)CALL ALGCLR(IENANG) 387 - IF(IFAIL.EQ.1)THEN 388 - PRINT *,' !!!!!! SIGGEN WARNING : Cluster generation'// 389 - - ' failed ; no signal calculation.' 390 - RETURN 391 - ENDIF 392 - *** Reset the CHANGE flag. 393 - CHANGE=.FALSE. 394 - *** Register the amount of CPU time used. 395 - CALL TIMLOG('Generating a signal: ') 396 - END 714 GARFIELD ================================================== P=SIGNAL D=SIGINI 1 ============================ 0 + +DECK,SIGINI. 1 - SUBROUTINE SIGINI(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGINI - Initialises signal calculations. 4 - * (Last changed on 8/ 9/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,SIGNALDATA. 10.- +SEQ,PRINTPLOT. 11 - INTEGER IFAIL,IFAIL1 12 - DOUBLE PRECISION DUMMY(1) 13 - *** Assume that the routine will fail. 14 - IFAIL=1 15 - *** Determine the cell type after eliminating true periodicities. 16 - IF(TYPE.EQ.'A '.OR.TYPE.EQ.'B1X'.OR. 17 - - TYPE.EQ.'B1Y'.OR.TYPE.EQ.'C1 ')THEN 18 - FCELTP='A ' 19 - ELSEIF(TYPE.EQ.'B2X'.OR.TYPE.EQ.'C2X')THEN 20 - FCELTP='B2X' 21 - ELSEIF(TYPE.EQ.'B2Y'.OR.TYPE.EQ.'C2Y')THEN 22 - FCELTP='B2Y' 23 - ELSEIF(TYPE.EQ.'C3 ')THEN 24 - FCELTP='C3 ' 25 - ELSEIF(TYPE.EQ.'D1 ')THEN 26 - FCELTP='D1 ' 27 - ELSEIF(TYPE.EQ.'D3 ')THEN 28 - FCELTP='D3 ' 29 - ELSEIF(TYPE.EQ.'MAP')THEN 30 - FCELTP='MAP' 31 - ELSE 32 - PRINT *,' !!!!!! SIGINI WARNING : No potentials available'// 33 - - ' to handle cell type '//TYPE//'; no signals.' 34 - RETURN 35 - ENDIF 36 - *** Establish the directions in which convolutions occur. 37 - FPERX=.FALSE. 38 - FPERY=.FALSE. 39 - IF(TYPE.EQ.'B1X'.OR.TYPE.EQ.'C1 '.OR.TYPE.EQ.'C2Y')FPERX=.TRUE. 40 - IF(TYPE.EQ.'B1Y'.OR.TYPE.EQ.'C1 '.OR.TYPE.EQ.'C2X')FPERY=.TRUE. 41 - MFEXP=INT(0.1+LOG(1.0*NFOUR)/LOG(2.0)) 42 - IF(MFEXP.EQ.0)FPERX=.FALSE. 43 - IF(MFEXP.EQ.0)FPERY=.FALSE. 44 - *** Set maximum and minimum Fourier terms. 45 - MXMIN=0 46 - MYMIN=0 47 - MXMAX=0 48 - MYMAX=0 49 - IF(FPERX)MXMIN=MIN(0,-NFOUR/2+1) 50 - IF(FPERX)MXMAX=+NFOUR/2 51 - IF(FPERY)MYMIN=MIN(0,-NFOUR/2+1) 52 - IF(FPERY)MYMAX=+NFOUR/2 53 - *** Print some debugging output if requested. 54 - IF(LDEBUG)WRITE(LUNOUT,'( 55 - - '' ++++++ SIGINI DEBUG : Cell type = '',A3/ 56 - - 26X,''Fourier cell type = '',A3/ 57 - - 26X,''x convolutions = '',L1/ 58 - - 26X,''y convolutions = '',L1/ 59 - - 26X,''No of Fourier terms = '',I3,'' (= 2**'',I3,'')'')') 60 - - TYPE,FCELTP,FPERX,FPERY,NFOUR,MFEXP 61 - *** Prepare the signal matrices. 62 - IF(TYPE.NE.'MAP')THEN 63 - CALL SIGIPR(IFAIL1) 64 - IF(IFAIL1.NE.0)THEN 65 - PRINT *,' !!!!!! SIGINI WARNING : Preparing'// 66 - - ' wire signal capacitance matrices failed;'// 67 - - ' no signals.' 68 - RETURN 69 - ENDIF 70 - CALL SIGPLP(IFAIL1) 71 - IF(IFAIL1.NE.0)THEN 72 - PRINT *,' !!!!!! SIGINI WARNING : Preparing'// 73 - - ' plane charges failed; no signals.' 74 - RETURN 75 - ENDIF 76 - ENDIF 1 714 P=SIGNAL D=SIGINI 2 PAGE1111 77 - *** And open the signal file. 78 - CALL SIGIST('OPEN',0,DUMMY,DUMMY,0,0,0,0,IFAIL1) 79 - IF(IFAIL1.NE.0)THEN 80 - PRINT *,' !!!!!! SIGINI WARNING : Unable to'// 81 - - ' open a signal storage file; no signals.' 82 - RETURN 83 - ENDIF 84 - *** Seems to have worked. 85 - IFAIL=0 86 - SIGSET=.TRUE. 87 - END 715 GARFIELD ================================================== P=SIGNAL D=SIGIPR 1 ============================ 0 + +DECK,SIGIPR. 1 - SUBROUTINE SIGIPR(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGIPR - Prepares the ion tail calculation by filling the signal 4 - * matrices (ie non-periodic capacitance matrices), 5 - * Fourier transforming them if necessary, inverting them and 6 - * Fourier transforming them back. Because of the large number 7 - * of terms involved, a (scratch) external file on unit 13 is 8 - * used to store the intermediate and final results. This file 9 - * is handled by the routines IONBGN and IONIO. 10 - * VARIABLES : FFTMAT : Matrix used for Fourier transforms. 11 - * (Last changed on 5/ 4/00.) 12 - *----------------------------------------------------------------------- 13 - implicit none 14.- +SEQ,DIMENSIONS. 15.- +SEQ,CELLDATA. 16.- +SEQ,SIGNALDATA. 17.- +SEQ,PRINTPLOT. 18.- +SEQ,SIGNALMATRIX. 19 - COMPLEX FFTMAT(MXFOUR,MXWIRE) 20 - INTEGER IFAIL,MX,MY,I,J,II,JJ,M,IOS 21 - *** Identify the routine. 22 - IF(LIDENT)PRINT *,' /// ROUTINE SIGIPR ///' 23 - *** Set some parameters. 24 - IFAIL=0 25 - *** Book the signal matrices. 26 - CALL BOOK('BOOK','MATRIX','SIGNAL',IFAIL) 27 - IF(IFAIL.NE.0)THEN 28 - PRINT *,' !!!!!! SIGIPR WARNING : Unable to obtain'// 29 - - ' signal matrix storage; no induced currents.' 30 - RETURN 31 - ENDIF 32 - *** Open unit 13 for writing of matrices if Fourier transf. are needed. 33 - IF(FPERX.OR.FPERY)THEN 34 - CALL IONBGN(IFAIL) 35 - IF(IFAIL.EQ.1)THEN 36 - PRINT *,' !!!!!! SIGIPR WARNING : No storage'// 37 - - ' available for the signal matrices; no'// 38 - - ' induced currents.' 39 - RETURN 40 - ENDIF 41 - ENDIF 42 - *** Have the matrix/matrices filled (and stored). 43 - DO 10 MX=MXMIN,MXMAX 44 - DO 20 MY=MYMIN,MYMAX 45 - * Select layer to be produced. 46 - IF(FCELTP.EQ.'A ')CALL IPRA00(MX,MY) 47 - IF(FCELTP.EQ.'B2X')CALL IPRB2X(MY) 48 - IF(FCELTP.EQ.'B2Y')CALL IPRB2Y(MX) 49 - IF(FCELTP.EQ.'C3 ')CALL IPRC30 50 - IF(FCELTP.EQ.'D1 ')CALL IPRD10 51 - IF(FCELTP.EQ.'D3 ')CALL IPRD30 52 - IF(LDEBUG)PRINT *,' ++++++ SIGIPR DEBUG : Signal matrix MX=', 53 - - MX,' MY=',MY,' has been calculated.' 54 - * Store the matrix. 55 - IF(FPERX.OR.FPERY)CALL IONIO(MX,MY,1,0,IFAIL) 56 - * Quit if storing failed. 57 - IF(IFAIL.NE.0)GOTO 2010 58 - * Dump the signal matrix before inversion, if DEBUG is requested. 59 - IF(LDEBUG)THEN 60 - WRITE(LUNOUT,'(/'' ++++++ SIGIPR DEBUG : Dump of'', 61 - - '' signal matrix ('',I2,'','',I2,'') before'', 62 - - '' inversion follows:''/)') MX,MY 63 - DO 710 I=0,NWIRE-1,10 64 - DO 720 J=0,NWIRE-1,10 65 - WRITE(LUNOUT,'('' Re-Block '',I2,''.'',I2/)') I/10,J/10 66 - DO 730 II=1,10 67 - IF(I+II.GT.NWIRE)GOTO 730 68 - WRITE(LUNOUT,'(2X,10(E12.5,1X:))') 69 - - (REAL(SIGMAT(I+II,J+JJ)),JJ=1,MIN(NWIRE-J,10)) 70 - 730 CONTINUE 71 - WRITE(LUNOUT,'('' Im-Block '',I2,''.'',I2/)') I/10,J/10 72 - DO 740 II=1,10 73 - IF(I+II.GT.NWIRE)GOTO 740 74 - WRITE(LUNOUT,'(2X,10(E12.5,1X:))') 75 - - (AIMAG(SIGMAT(I+II,J+JJ)),JJ=1,MIN(NWIRE-J,10)) 76 - 740 CONTINUE 77 - 720 CONTINUE 78 - 710 CONTINUE 79 - WRITE(LUNOUT,'(/'' ++++++ SIGIPR DEBUG : End of the'', 80 - - '' uninverted capacitance matrix dump.''/)') 81 - ENDIF 82 - * Next layer. 83 - 20 CONTINUE 84 - 10 CONTINUE 85 - *** Have them fourier transformed (singly periodic case). 86 - IF((FPERX.AND..NOT.FPERY).OR.(FPERY.AND..NOT.FPERX))THEN 87 - DO 30 I=1,NWIRE 88 - DO 40 M=-NFOUR/2+1,NFOUR/2 89 - CALL IONIO(M,M,2,I,IFAIL) 90 - IF(IFAIL.NE.0)GOTO 2010 91 - DO 50 J=1,NWIRE 1 715 P=SIGNAL D=SIGIPR 2 PAGE1112 92 - FFTMAT(M+NFOUR/2,J)=SIGMAT(I,J) 93 - 50 CONTINUE 94 - 40 CONTINUE 95 - DO 60 J=1,NWIRE 96 - CALL CFFT(FFTMAT(1,J),MFEXP) 97 - 60 CONTINUE 98 - DO 70 M=-NFOUR/2+1,NFOUR/2 99 - CALL IONIO(M,M,2,I,IFAIL) 100 - IF(IFAIL.NE.0)GOTO 2010 101 - DO 80 J=1,NWIRE 102 - SIGMAT(I,J)=FFTMAT(M+NFOUR/2,J) 103 - 80 CONTINUE 104 - CALL IONIO(M,M,1,I,IFAIL) 105 - IF(IFAIL.NE.0)GOTO 2010 106 - 70 CONTINUE 107 - 30 CONTINUE 108 - ENDIF 109 - * have them fourier transformed (doubly periodic case). 110 - IF(FPERX.AND.FPERY)THEN 111 - DO 100 I=1,NWIRE 112 - DO 110 MX=MXMIN,MXMAX 113 - DO 120 MY=MYMIN,MYMAX 114 - CALL IONIO(MX,MY,2,I,IFAIL) 115 - IF(IFAIL.NE.0)GOTO 2010 116 - DO 130 J=1,NWIRE 117 - FFTMAT(MY+NFOUR/2,J)=SIGMAT(I,J) 118 - 130 CONTINUE 119 - 120 CONTINUE 120 - DO 140 J=1,NWIRE 121 - CALL CFFT(FFTMAT(1,J),MFEXP) 122 - 140 CONTINUE 123 - DO 150 MY=MYMIN,MYMAX 124 - CALL IONIO(MX,MY,2,I,IFAIL) 125 - IF(IFAIL.NE.0)GOTO 2010 126 - DO 160 J=1,NWIRE 127 - SIGMAT(I,J)=FFTMAT(MY+NFOUR/2,J) 128 - 160 CONTINUE 129 - CALL IONIO(MX,MY,1,I,IFAIL) 130 - IF(IFAIL.NE.0)GOTO 2010 131 - 150 CONTINUE 132 - 110 CONTINUE 133 - DO 170 MY=MYMIN,MYMAX 134 - DO 180 MX=MXMIN,MXMAX 135 - CALL IONIO(MX,MY,2,I,IFAIL) 136 - IF(IFAIL.NE.0)GOTO 2010 137 - DO 190 J=1,NWIRE 138 - FFTMAT(MX+NFOUR/2,J)=SIGMAT(I,J) 139 - 190 CONTINUE 140 - 180 CONTINUE 141 - DO 200 J=1,NWIRE 142 - CALL CFFT(FFTMAT(1,J),MFEXP) 143 - 200 CONTINUE 144 - DO 210 MX=MXMIN,MXMAX 145 - CALL IONIO(MX,MY,2,I,IFAIL) 146 - IF(IFAIL.NE.0)GOTO 2010 147 - DO 220 J=1,NWIRE 148 - SIGMAT(I,J)=FFTMAT(MX+NFOUR/2,J) 149 - 220 CONTINUE 150 - CALL IONIO(MX,MY,1,I,IFAIL) 151 - IF(IFAIL.NE.0)GOTO 2010 152 - 210 CONTINUE 153 - 170 CONTINUE 154 - 100 CONTINUE 155 - ENDIF 156 - *** Invert the matrices. 157 - DO 300 MX=MXMIN,MXMAX 158 - DO 310 MY=MYMIN,MYMAX 159 - * Retrieve the layer. 160 - IF(FPERX.OR.FPERY)THEN 161 - CALL IONIO(MX,MY,2,0,IFAIL) 162 - IF(IFAIL.NE.0)GOTO 2010 163 - ENDIF 164 - * Invert. 165 - IF(NWIRE.GE.1)CALL CINV(NWIRE,SIGMAT,MXWIRE,IWORK,IFAIL) 166 - IF(IFAIL.NE.0)THEN 167 - PRINT *,' !!!!!! SIGIPR WARNING : Inversion of signal', 168 - - ' matrix (',MX,',',MY,') failed; no reliable', 169 - - ' results; ion tail preparation is abandoned.' 170 - IFAIL=1 171 - RETURN 172 - ENDIF 173 - * Store the matrix back. 174 - IF(FPERX.OR.FPERY)THEN 175 - CALL IONIO(MX,MY,1,0,IFAIL) 176 - IF(IFAIL.NE.0)GOTO 2010 177 - ENDIF 178 - * Next layer. 179 - 310 CONTINUE 180 - 300 CONTINUE 181 - *** And transform the matrices back to the original domain. 182 - IF((FPERX.AND..NOT.FPERY).OR.(FPERY.AND..NOT.FPERX))THEN 183 - DO 410 I=1,NWIRE 184 - DO 420 M=-NFOUR/2+1,NFOUR/2 185 - CALL IONIO(M,M,2,I,IFAIL) 186 - IF(IFAIL.NE.0)GOTO 2010 187 - DO 430 J=1,NWIRE 188 - FFTMAT(M+NFOUR/2,J)=SIGMAT(I,J) 189 - 430 CONTINUE 190 - 420 CONTINUE 191 - DO 440 J=1,NWIRE 192 - CALL CFFT(FFTMAT(1,J),-MFEXP) 193 - 440 CONTINUE 194 - DO 450 M=-NFOUR/2+1,NFOUR/2 195 - CALL IONIO(M,M,2,I,IFAIL) 196 - IF(IFAIL.NE.0)GOTO 2010 197 - DO 460 J=1,NWIRE 1 715 P=SIGNAL D=SIGIPR 3 PAGE1113 198 - SIGMAT(I,J)=FFTMAT(M+NFOUR/2,J)/NFOUR 199 - 460 CONTINUE 200 - CALL IONIO(M,M,1,I,IFAIL) 201 - IF(IFAIL.NE.0)GOTO 2010 202 - 450 CONTINUE 203 - 410 CONTINUE 204 - ENDIF 205 - * have them transformed to the original domain (doubly periodic). 206 - IF(FPERX.AND.FPERY)THEN 207 - DO 500 I=1,NWIRE 208 - DO 510 MX=MXMIN,MXMAX 209 - DO 520 MY=MYMIN,MYMAX 210 - CALL IONIO(MX,MY,2,I,IFAIL) 211 - IF(IFAIL.NE.0)GOTO 2010 212 - DO 530 J=1,NWIRE 213 - FFTMAT(MY+NFOUR/2,J)=SIGMAT(I,J) 214 - 530 CONTINUE 215 - 520 CONTINUE 216 - DO 540 J=1,NWIRE 217 - CALL CFFT(FFTMAT(1,J),-MFEXP) 218 - 540 CONTINUE 219 - DO 550 MY=MYMIN,MYMAX 220 - CALL IONIO(MX,MY,2,I,IFAIL) 221 - IF(IFAIL.NE.0)GOTO 2010 222 - DO 560 J=1,NWIRE 223 - SIGMAT(I,J)=FFTMAT(MY+NFOUR/2,J)/NFOUR 224 - 560 CONTINUE 225 - CALL IONIO(MX,MY,1,I,IFAIL) 226 - IF(IFAIL.NE.0)GOTO 2010 227 - 550 CONTINUE 228 - 510 CONTINUE 229 - DO 570 MY=MYMIN,MYMAX 230 - DO 580 MX=MXMIN,MXMAX 231 - CALL IONIO(MX,MY,2,I,IFAIL) 232 - IF(IFAIL.NE.0)GOTO 2010 233 - DO 590 J=1,NWIRE 234 - FFTMAT(MX+NFOUR/2,J)=SIGMAT(I,J) 235 - 590 CONTINUE 236 - 580 CONTINUE 237 - DO 600 J=1,NWIRE 238 - CALL CFFT(FFTMAT(1,J),-MFEXP) 239 - 600 CONTINUE 240 - DO 610 MX=MXMIN,MXMAX 241 - CALL IONIO(MX,MY,2,I,IFAIL) 242 - IF(IFAIL.NE.0)GOTO 2010 243 - DO 620 J=1,NWIRE 244 - SIGMAT(I,J)=FFTMAT(MX+NFOUR/2,J)/NFOUR 245 - 620 CONTINUE 246 - CALL IONIO(MX,MY,1,I,IFAIL) 247 - IF(IFAIL.NE.0)GOTO 2010 248 - 610 CONTINUE 249 - 570 CONTINUE 250 - 500 CONTINUE 251 - ENDIF 252 - *** Dump the signal matrix after inversion, if DEBUG is requested. 253 - IF(LDEBUG)THEN 254 - DO 750 MX=MXMIN,MXMAX 255 - DO 760 MY=MYMIN,MYMAX 256 - WRITE(LUNOUT,'(/'' ++++++ SIGIPR DEBUG : Dump of'', 257 - - '' signal matrix ('',I2,'','',I2,'') after'', 258 - - '' inversion follows:''/)') MX,MY 259 - DO 770 I=0,NWIRE-1,10 260 - DO 780 J=0,NWIRE-1,10 261 - WRITE(LUNOUT,'('' Re-Block '',I2,''.'',I2/)') I/10,J/10 262 - DO 790 II=1,10 263 - IF(I+II.GT.NWIRE)GOTO 790 264 - WRITE(LUNOUT,'(2X,10(E12.5,1X:))') 265 - - (REAL(SIGMAT(I+II,J+JJ)),JJ=1,MIN(NWIRE-J,10)) 266 - 790 CONTINUE 267 - WRITE(LUNOUT,'('' Im-Block '',I2,''.'',I2/)') I/10,J/10 268 - DO 800 II=1,10 269 - IF(I+II.GT.NWIRE)GOTO 800 270 - WRITE(LUNOUT,'(2X,10(E12.5,1X:))') 271 - - (AIMAG(SIGMAT(I+II,J+JJ)),JJ=1,MIN(NWIRE-J,10)) 272 - 800 CONTINUE 273 - 780 CONTINUE 274 - 770 CONTINUE 275 - WRITE(LUNOUT,'(/'' ++++++ SIGIPR DEBUG : End of the'', 276 - - '' inverted capacitance matrix dump.''/)') 277 - 760 CONTINUE 278 - 750 CONTINUE 279 - ENDIF 280 - *** Register the amount of CPU time used for these manipulations. 281 - CALL TIMLOG('Preparing the ion tail calculation: ') 282 - RETURN 283 - *** Handle error conditions. 284 - 2010 CONTINUE 285 - PRINT *,' !!!!!! SIGIPR WARNING : Ion tail preparation stopped'// 286 - - ' because of an I/O error; resubmit or set'// 287 - - ' fourier to 1 (see writeup)' 288 - CALL INPIOS(IOS) 289 - CLOSE(UNIT=13,IOSTAT=IOS,ERR=2030) 290 - IFAIL=1 291 - RETURN 292 - 2030 CONTINUE 293 - PRINT *,' ###### SIGIPR ERROR : Problems closing scratch'// 294 - - ' data set on unit 13 (used for intermediate'// 295 - - ' results)' 296 - PRINT *,' CLOSE was attempted because'// 297 - - ' of a previous error condition' 298 - CALL INPIOS(IOS) 299 - IFAIL=1 300 - END 1 716 GARFIELD ================================================== P=SIGNAL D=IPRA00 1 =================== PAGE1114 0 + +DECK,IPRA00. 1 - SUBROUTINE IPRA00(MX,MY) 2 - *----------------------------------------------------------------------- 3 - * IPRA00 - Routine filling the (MX,MY) th layer of the signal matrix 4 - * for cells with non-periodic type A (see SIGIPR). 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,SIGNALMATRIX. 8.- +SEQ,CELLDATA. 9 - DX=MX*SX 10 - DY=MY*SY 11 - DO 10 I=1,NWIRE 12 - *** DIAGONAL TERMS 13 - IF(DX.NE.0.0.OR.DY.NE.0.0)THEN 14 - AA=DX**2+DY**2 15 - ELSE 16 - AA=0.25*D(I)**2 17 - ENDIF 18 - * Take care of single equipotential planes. 19 - IF(YNPLAX)AA=AA/((2.0*(X(I)-COPLAX))**2+DY**2) 20 - IF(YNPLAY)AA=AA/((2.0*(Y(I)-COPLAY))**2+DX**2) 21 - * Take care of pairs of equipotential planes. 22 - IF(YNPLAX.AND.YNPLAY)AA=AA*4.*((X(I)-COPLAX)**2+(Y(I)-COPLAY)**2) 23 - *** Define the final version of A(I,I). 24 - SIGMAT(I,I)=-0.5*LOG(AA) 25 - DO 20 J=I+1,NWIRE 26 - AA=(X(I)+DX-X(J))**2+(Y(I)+DY-Y(J))**2 27 - * Take care of single planes. 28 - IF(YNPLAX)AA=AA/((2.0*COPLAX-X(I)-DX-X(J))**2+(Y(I)+DY-Y(J))**2) 29 - IF(YNPLAY)AA=AA/((X(I)+DX-X(J))**2+(2.0*COPLAY-Y(I)-DY-Y(J))**2) 30 - * Take care of pairs of planes. 31 - IF(YNPLAX.AND.YNPLAY)AA=AA*((2.*COPLAX-X(I)-DX-X(J))**2+ 32 - - (2.*COPLAY-Y(I)-DY-Y(J))**2) 33 - * Store the true versions after taking LOGs and SQRT's. 34 - SIGMAT(I,J)=-0.5*LOG(AA) 35 - SIGMAT(J,I)=SIGMAT(I,J) 36 - 20 CONTINUE 37 - 10 CONTINUE 38 - END 717 GARFIELD ================================================== P=SIGNAL D=IPRB2X 1 ============================ 0 + +DECK,IPRB2X. 1 - SUBROUTINE IPRB2X(MY) 2 - *----------------------------------------------------------------------- 3 - * IPRB2X - Routine filling the MY th layer of the signal matrix 4 - * for cells with non-periodic type B2X (see SIGIPR). 5 - * (Last changed on 26/ 4/92.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,SIGNALMATRIX. 9.- +SEQ,CELLDATA. 10.- +SEQ,CONSTANTS. 11 - DY=MY*SY 12 - *** Loop over all wires and calculate the diagonal elements first. 13 - DO 10 I=1,NWIRE 14 - XX=(PI/SX)*(X(I)-COPLAN(1)) 15 - IF(DY.NE.0.0)THEN 16 - AA=(SINH(PI*DY/SX)/SIN(XX))**2 17 - ELSE 18 - AA=((0.25*D(I)*PI/SX)/SIN(XX))**2 19 - ENDIF 20 - * Take care of a planes at constant y (no dy in this case). 21 - IF(YNPLAY)THEN 22 - YYMIRR=(PI/SX)*(Y(I)-COPLAY) 23 - IF(ABS(YYMIRR).LE.20.0) AA=AA* 24 - - (SINH(YYMIRR)**2+SIN(XX)**2)/SINH(YYMIRR)**2 25 - ENDIF 26 - * Store the true value of A(I,I). 27 - SIGMAT(I,I)=-0.5*LOG(AA) 28 - *** Loop over all other wires to obtain off-diagonal elements. 29 - DO 20 J=I+1,NWIRE 30 - YY=0.5*PI*(Y(I)+DY-Y(J))/SX 31 - XX=0.5*PI*(X(I)-X(J))/SX 32 - XXNEG=0.5*PI*(X(I)+X(J)-2.0*COPLAN(1))/SX 33 - IF(ABS(YY).LT.20.0)THEN 34 - AA=(SINH(YY)**2+SIN(XX)**2)/(SINH(YY)**2+SIN(XXNEG)**2) 35 - ELSE 36 - AA=1.0 37 - ENDIF 38 - * Take equipotential planes into account (no dy anyhow). 39 - IF(YNPLAY)THEN 40 - YYMIRR=0.5*PI*(Y(I)+Y(J)-2.0*COPLAY)/SX 41 - IF(ABS(YYMIRR).LE.20.0) AA=AA* 42 - - (SINH(YYMIRR)**2+SIN(XXNEG)**2)/(SINH(YYMIRR)**2+SIN(XX)**2) 43 - ENDIF 44 - *** Store the true value of A(I,J) in both A(I,J) and A(J,I). 45 - SIGMAT(I,J)=-0.5*LOG(AA) 46 - SIGMAT(J,I)=SIGMAT(I,J) 47 - *** Finish the wire loops. 48 - 20 CONTINUE 49 - *** Fill the B2SIN vector. 50 - B2SIN(I)=SIN(PI*(COPLAN(1)-X(I))/SX) 51 - 10 CONTINUE 52 - END 718 GARFIELD ================================================== P=SIGNAL D=IPRB2Y 1 ============================ 0 + +DECK,IPRB2Y. 1 - SUBROUTINE IPRB2Y(MX) 2 - *----------------------------------------------------------------------- 3 - * IPRB2Y - Routine filling the MX th layer of the signal matrix 4 - * for cells with non-periodic type B2Y (see SIGIPR). 5 - * (Last changed on 26/ 4/92.) 6 - *----------------------------------------------------------------------- 1 718 P=SIGNAL D=IPRB2Y 2 PAGE1115 7.- +SEQ,DIMENSIONS. 8.- +SEQ,SIGNALMATRIX. 9.- +SEQ,CELLDATA. 10.- +SEQ,CONSTANTS. 11 - DX=MX*SX 12 - *** Loop over all wires and calculate the diagonal elements first. 13 - DO 10 I=1,NWIRE 14 - YY=(PI/SY)*(Y(I)-COPLAN(3)) 15 - IF(DX.NE.0.0)THEN 16 - AA=(SINH(PI*DX/SY)/SIN(YY))**2 17 - ELSE 18 - AA=((0.25*D(I)*PI/SY)/SIN(YY))**2 19 - ENDIF 20 - * Take care of a plane at constant x (no dx in this case). 21 - IF(YNPLAX)THEN 22 - XXMIRR=(PI/SY)*(X(I)-COPLAX) 23 - IF(ABS(XXMIRR).LE.20.0) AA=AA* 24 - - (SINH(XXMIRR)**2+SIN(YY)**2)/SINH(XXMIRR)**2 25 - ENDIF 26 - * Store the true value of A(I,I). 27 - SIGMAT(I,I)=-0.5*LOG(AA) 28 - *** Loop over all other wires to obtain off-diagonal elements. 29 - DO 20 J=I+1,NWIRE 30 - XX=0.5*PI*(X(I)+DX-X(J))/SY 31 - YY=0.5*PI*(Y(I)-Y(J))/SY 32 - YYNEG=0.5*PI*(Y(I)+Y(J)-2.0*COPLAN(3))/SY 33 - IF(ABS(XX).LE.20.0)THEN 34 - AA=(SINH(XX)**2+SIN(YY)**2)/(SINH(XX)**2+SIN(YYNEG)**2) 35 - ELSE 36 - AA=1.0 37 - ENDIF 38 - * Take equipotential planes into account (dx=0 anyhow). 39 - IF(YNPLAX)THEN 40 - XXMIRR=0.5*PI*(X(I)+X(J)-2.0*COPLAX)/SX 41 - IF(ABS(XXMIRR).LE.20.0) AA=AA* 42 - - (SINH(XXMIRR)**2+SIN(YYNEG)**2)/(SINH(XXMIRR)**2+SIN(YY)**2) 43 - ENDIF 44 - *** Store the true value of A(I,J) in both A(I,J) and A(J,I). 45 - SIGMAT(I,J)=-0.5*LOG(AA) 46 - SIGMAT(J,I)=SIGMAT(I,J) 47 - *** Finish the wire loops. 48 - 20 CONTINUE 49 - *** Fill the B2SIN vector. 50 - B2SIN(I)=SIN(PI*(COPLAN(3)-Y(I))/SY) 51 - 10 CONTINUE 52 - END 719 GARFIELD ================================================== P=SIGNAL D=IPRC30 1 ============================ 0 + +DECK,IPRC30. 1 - SUBROUTINE IPRC30 2 - *----------------------------------------------------------------------- 3 - * IPRC30 - Routine filling the signal matrix for cells of type C30. 4 - * Since the signal matrix equals the capacitance matrix for 5 - * this potential, the routine is identical to SETC30 except 6 - * for the C and P parameters. 7 - * (Last changed on 11/11/97.) 8 - *----------------------------------------------------------------------- 9 - implicit none 10.- +SEQ,DIMENSIONS. 11.- +SEQ,CELLDATA. 12.- +SEQ,SIGNALMATRIX. 13.- +SEQ,CONSTANTS. 14 - INTEGER I,J 15 - REAL CX,CY,PH2,PH2LIM 16 - EXTERNAL PH2,PH2LIM 17 - *** Fill the capacitance matrix. 18 - DO 10 I=1,NWIRE 19 - CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) 20 - CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) 21 - DO 20 J=1,NWIRE 22 - IF(I.EQ.J)THEN 23 - SIGMAT(I,I)=PH2LIM(0.5*D(I))- 24 - - PH2(0.0,2*(Y(I)-CY))- 25 - - PH2(2*(X(I)-CX),0.0)+ 26 - - PH2(2*(X(I)-CX),2*(Y(I)-CY)) 27 - ELSE 28 - SIGMAT(I,J)=PH2(X(I)-X(J),Y(I)-Y(J))- 29 - - PH2(X(I)-X(J),Y(I)+Y(J)-2*CY)- 30 - - PH2(X(I)+X(J)-2*CX,Y(I)-Y(J))+ 31 - - PH2(X(I)+X(J)-2*CX,Y(I)+Y(J)-2*CY) 32 - ENDIF 33 - 20 CONTINUE 34 - 10 CONTINUE 35 - END 720 GARFIELD ================================================== P=SIGNAL D=IPRD10 1 ============================ 0 + +DECK,IPRD10. 1 - SUBROUTINE IPRD10 2 - *----------------------------------------------------------------------- 3 - * IPRD10 - Signal matrix preparation for D1 cells. 4 - * VARIABLES : 5 - * (Last changed on 2/ 2/93.) 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,SIGNALMATRIX. 10 - COMPLEX ZI,ZJ 11 - *** Loop over all wires. 12 - DO 10 I=1,NWIRE 13 - * Set the diagonal terms. 14 - SIGMAT(I,I)=-LOG(0.5*D(I)/(COTUBE-(X(I)**2+Y(I)**2)/COTUBE)) 15 - * Set a complex wire-coordinate to make things a little easier. 16 - ZI=CMPLX(X(I),Y(I)) 17 - *** Loop over all other wires for the off-diagonal elements. 1 720 P=SIGNAL D=IPRD10 2 PAGE1116 18 - DO 20 J=I+1,NWIRE 19 - * Set a complex wire-coordinate to make things a little easier. 20 - ZJ=CMPLX(X(J),Y(J)) 21 - SIGMAT(I,J)=-LOG(ABS((1/COTUBE)*(ZI-ZJ)/ 22 - - (1-CONJG(ZI)*ZJ/COTUBE**2))) 23 - *** Copy this to A(J,I) since the capacitance matrix is symmetric. 24 - SIGMAT(J,I)=SIGMAT(I,J) 25 - 20 CONTINUE 26 - 10 CONTINUE 27 - END 721 GARFIELD ================================================== P=SIGNAL D=IPRD30 1 ============================ 0 + +DECK,IPRD30. 1 - SUBROUTINE IPRD30 2 - *----------------------------------------------------------------------- 3 - * IPRD30 - Signal matrix preparation for polygonal cells (type D3). 4 - * Variables : 5 - * (Last changed on 19/ 6/97.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,SIGNALMATRIX. 11 - INTEGER I,J 12 - COMPLEX WD 13 - *** Loop over all wire combinations. 14 - DO 10 I=1,NWIRE 15 - * We need to compute the wire mapping again to obtain WD. 16 - CALL EFCMAP(CMPLX(X(I),Y(I))/COTUBE,WMAP(I),WD) 17 - * Diagonal elements. 18 - SIGMAT(I,I)=-LOG(ABS((0.5*D(I)/COTUBE)*WD/(1-ABS(WMAP(I))**2))) 19 - *** Loop over all other wires for the off-diagonal elements. 20 - DO 20 J=1,I-1 21 - SIGMAT(I,J)=-LOG(ABS((WMAP(I)-WMAP(J))/ 22 - - (1-CONJG(WMAP(I))*WMAP(J)))) 23 - *** Copy this to A(J,I) since the capacitance matrix is symmetric. 24 - SIGMAT(J,I)=SIGMAT(I,J) 25 - 20 CONTINUE 26 - 10 CONTINUE 27 - END 722 GARFIELD ================================================== P=SIGNAL D=SIGPLP 1 ============================ 0 + +DECK,SIGPLP. 1 - SUBROUTINE SIGPLP(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGPLP - Computes the weighting field charges for the planes and 4 - * the tube. 5 - * (Last changed on 14/10/99.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,SIGNALDATA. 11.- +SEQ,SIGNALMATRIX. 12.- +SEQ,PRINTPLOT. 13 - REAL VW 14 - INTEGER MX,MY,IFAIL,IFAIL1,I,J 15 - *** Identify the routine if requested. 16 - IF(LIDENT)PRINT *,' /// ROUTINE SIGPLP ///' 17 - *** Assume this will fail. 18 - IFAIL=1 19 - *** Loop over the signal layers. 20 - DO 100 MX=MXMIN,MXMAX 21 - DO 110 MY=MYMIN,MYMAX 22 - *** Load the layers of the signal matrices. 23 - CALL IONIO(MX,MY,2,0,IFAIL1) 24 - IF(IFAIL1.NE.0)THEN 25 - PRINT *,' !!!!!! SIGPLP WARNING : Signal matrix'// 26 - - ' store error; field for planes not prepared.' 27 - RETURN 28 - ENDIF 29 - *** Initialise the plane matrices. 30 - DO 120 I=1,5 31 - DO 130 J=1,NWIRE 32 - QPLANE(I,J)=0 33 - 130 CONTINUE 34 - 120 CONTINUE 35 - *** Charges for plane 1, if present. 36 - IF(YNPLAN(1))THEN 37 - * Set the weighting field voltages. 38 - DO 10 I=1,NWIRE 39 - IF(YNPLAN(2))THEN 40 - VW=-(COPLAN(2)-X(I))/(COPLAN(2)-COPLAN(1)) 41 - ELSEIF(PERX)THEN 42 - VW=-(COPLAN(1)+SX-X(I))/SX 43 - ELSE 44 - VW=-1 45 - ENDIF 46 - * Multiply with the matrix. 47 - DO 20 J=1,NWIRE 48 - QPLANE(1,I)=QPLANE(1,I)+SIGMAT(I,J)*VW 49 - 20 CONTINUE 50 - 10 CONTINUE 51 - ENDIF 52 - *** Charges for plane 2, if present. 53 - IF(YNPLAN(2))THEN 54 - * Set the weighting field voltages. 55 - DO 30 I=1,NWIRE 56 - IF(YNPLAN(1))THEN 57 - VW=-(COPLAN(1)-X(I))/(COPLAN(1)-COPLAN(2)) 58 - ELSEIF(PERX)THEN 59 - VW=-(X(I)-COPLAN(2)+SX)/SX 60 - ELSE 61 - VW=-1 1 722 P=SIGNAL D=SIGPLP 2 PAGE1117 62 - ENDIF 63 - * Multiply with the matrix. 64 - DO 40 J=1,NWIRE 65 - QPLANE(2,I)=QPLANE(2,I)+SIGMAT(I,J)*VW 66 - 40 CONTINUE 67 - 30 CONTINUE 68 - ENDIF 69 - *** Charges for plane 3, if present. 70 - IF(YNPLAN(3))THEN 71 - * Set the weighting field voltages. 72 - DO 50 I=1,NWIRE 73 - IF(YNPLAN(4))THEN 74 - VW=-(COPLAN(4)-Y(I))/(COPLAN(4)-COPLAN(3)) 75 - ELSEIF(PERY)THEN 76 - VW=-(COPLAN(3)+SY-Y(I))/SY 77 - ELSE 78 - VW=-1 79 - ENDIF 80 - * Multiply with the matrix. 81 - DO 60 J=1,NWIRE 82 - QPLANE(3,I)=QPLANE(3,I)+SIGMAT(I,J)*VW 83 - 60 CONTINUE 84 - 50 CONTINUE 85 - ENDIF 86 - *** Charges for plane 4, if present. 87 - IF(YNPLAN(4))THEN 88 - * Set the weighting field voltages. 89 - DO 70 I=1,NWIRE 90 - IF(YNPLAN(3))THEN 91 - VW=-(COPLAN(3)-Y(I))/(COPLAN(3)-COPLAN(4)) 92 - ELSEIF(PERY)THEN 93 - VW=-(Y(I)-COPLAN(4)+SY)/SY 94 - ELSE 95 - VW=-1 96 - ENDIF 97 - * Multiply with the matrix. 98 - DO 80 J=1,NWIRE 99 - QPLANE(4,I)=QPLANE(4,I)+SIGMAT(I,J)*VW 100 - 80 CONTINUE 101 - 70 CONTINUE 102 - ENDIF 103 - *** Charges for the tube, if present. 104 - IF(TUBE)THEN 105 - DO 160 I=1,NWIRE 106 - DO 90 J=1,NWIRE 107 - QPLANE(5,I)=QPLANE(5,I)-SIGMAT(I,J) 108 - 90 CONTINUE 109 - 160 CONTINUE 110 - ENDIF 111 - *** Store the plane charges. 112 - CALL IPLIO(MX,MY,1,IFAIL1) 113 - IF(IFAIL1.NE.0)THEN 114 - PRINT *,' !!!!!! SIGPLP WARNING : Plane matrix'// 115 - - ' store error; field for planes not prepared.' 116 - RETURN 117 - ENDIF 118 - *** Next set of periodicities. 119 - 110 CONTINUE 120 - 100 CONTINUE 121 - *** Compute the background weighting fields, first in x. 122 - IF(YNPLAN(1).AND.YNPLAN(2))THEN 123 - EWXCOR(1)=1/(COPLAN(2)-COPLAN(1)) 124 - EWXCOR(2)=1/(COPLAN(1)-COPLAN(2)) 125 - ELSEIF(YNPLAN(1).AND.PERX)THEN 126 - EWXCOR(1)=1/SX 127 - EWXCOR(2)=0 128 - ELSEIF(YNPLAN(2).AND.PERX)THEN 129 - EWXCOR(1)=0 130 - EWXCOR(2)=-1/SX 131 - ELSE 132 - EWXCOR(1)=0 133 - EWXCOR(2)=0 134 - ENDIF 135 - EWXCOR(3)=0 136 - EWXCOR(4)=0 137 - EWXCOR(5)=0 138 - * Next also in y. 139 - EWYCOR(1)=0 140 - EWYCOR(2)=0 141 - IF(YNPLAN(3).AND.YNPLAN(4))THEN 142 - EWYCOR(3)=1/(COPLAN(4)-COPLAN(3)) 143 - EWYCOR(4)=1/(COPLAN(3)-COPLAN(4)) 144 - ELSEIF(YNPLAN(3).AND.PERY)THEN 145 - EWYCOR(3)=1/SY 146 - EWYCOR(4)=0 147 - ELSEIF(YNPLAN(4).AND.PERY)THEN 148 - EWYCOR(3)=0 149 - EWYCOR(4)=-1/SY 150 - ELSE 151 - EWYCOR(3)=0 152 - EWYCOR(4)=0 153 - ENDIF 154 - * The tube has no correction field. 155 - EWYCOR(5)=0 156 - *** Debugging output. 157 - IF(LDEBUG)THEN 158 - WRITE(LUNOUT,'('' ++++++ SIGPLP DEBUG : Charges for'', 159 - - '' currents induced in the planes:''/26X, 160 - - '' Wire x-Plane 1 x-Plane 2'', 161 - - '' y-Plane 1 y-Plane 2'', 162 - - '' Tube'')') 163 - DO 140 I=1,NWIRE 164 - WRITE(LUNOUT,'(26X,I5,5(2X,E15.8))') I,(QPLANE(J,I),J=1,5) 165 - 140 CONTINUE 166 - WRITE(LUNOUT,'('' ++++++ SIGPLP DEBUG : Bias fields:''/ 167 - - 26X,''Plane x-Bias [1/cm] y-Bias [1/cm]'')') 1 722 P=SIGNAL D=SIGPLP 3 PAGE1118 168 - DO 150 I=1,5 169 - WRITE(LUNOUT,'(26X,I5,2(2X,E15.8))') I,EWXCOR(I),EWYCOR(I) 170 - 150 CONTINUE 171 - ENDIF 172 - *** Seems to have worked. 173 - IFAIL=0 174 - END 723 GARFIELD ================================================== P=SIGNAL D=IONBGN 1 ============================ 0 + +DECK,IONBGN. 1 - SUBROUTINE IONBGN(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * IONBGN - Routine initialising the data set for the signal matrices. 4 - * VARIABLES : NPEREC : Number of columns per wire record. 5 - * NRECMT : Number of records per wire matrix. 6 - * IRECP0 : First plane record. 7 - * NRECS : Total number of records on unit 13. 8 - * OPEN : Used for checking the status of unit 13. 9 - * (Last changed on 9/11/98.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,CELLDATA. 14.- +SEQ,SIGNALMATRIX. 15.- +SEQ,SIGNALDATA. 16.- +SEQ,PRINTPLOT. 17 - INTEGER IFAIL,NPEREC,NRECMT,NRECS,IOS,IRECP0 18 - LOGICAL OPEN 19 - CHARACTER*(MXNAME) FILE 0 20-+ +SELF,IF=CMS. 21 - CHARACTER*80 FILDEF 0 22-+ +SELF. 23 - COMMON /FILE13/ NPEREC,NRECMT,IRECP0,NRECS 24 - IFAIL=0 25 - *** Identify the routine. 26 - IF(LIDENT)PRINT *,' /// ROUTINE IONBGN ///' 27 - *** Return if no file is needed. 28 - IF(.NOT.(FPERX.OR.FPERY))RETURN 29 - IFAIL=1 30 - *** Determine the number of wire columns fitting in a record. 31 - NPEREC=INT((MXRECL-4)/(8*NWIRE)) 32 - * Stop in case MXRECL is unacceptably small. 33 - IF(NPEREC.LE.0)THEN 34 - PRINT *,' ###### IONBGN ERROR : Unable to allocate', 35 - - ' storage space for the wire matrices, a MXRECL', 36 - - ' of at least ',8*NWIRE+4,' is needed;' 37 - PRINT *,' Increase MXRECL if', 38 - - ' possible or specify FOURIER 1.' 39 - RETURN 40 - ENDIF 41 - * Set NPEREC to NWIRE if the wire matrix fits in single record. 42 - IF(NPEREC.GT.NWIRE)NPEREC=NWIRE 43 - *** Ensure that the plane matrix fits in a single record. 44 - IF(20*NWIRE+4.GT.MXRECL)THEN 45 - PRINT *,' ###### IONBGN ERROR : Unable to allocate'// 46 - - ' storage space for the plane matrices, a MXRECL'// 47 - - ' of at least ',20*NWIRE+4,' is needed;' 48 - PRINT *,' Increase MXRECL if'// 49 - - ' possible or specify FOURIER 1.' 50 - RETURN 51 - ENDIF 52 - *** Determine number of records, first records per wire matrix. 53 - NRECMT=NWIRE/NPEREC 54 - IF(NPEREC*NRECMT.LT.NWIRE)NRECMT=NRECMT+1 55 - * Multiply by the number of Fourier copies of the matrix. 56 - IF(FPERX.AND.FPERY)THEN 57 - NRECS=NFOUR**2*NRECMT 58 - ELSEIF(FPERX.OR.FPERY)THEN 59 - NRECS=NFOUR*NRECMT 60 - ELSE 61 - NRECS=1 62 - ENDIF 63 - * Record the start of the plane records. 64 - IRECP0=NRECS+1 65 - * Add the plane records, each Fourier copy takes 1 record. 66 - IF(FPERX.AND.FPERY)THEN 67 - NRECS=NRECS+NFOUR**2 68 - ELSEIF(FPERX.OR.FPERY)THEN 69 - NRECS=NRECS+NFOUR 70 - ELSE 71 - NRECS=NRECS+1 72 - ENDIF 0 73-+ +SELF,IF=-CMS. 74 - * Check that it does not exceed 1000. 75 - IF(NRECS.GT.1000)THEN 76 - PRINT *,' ###### IONBGN ERROR : Unable to allocate'// 77 - - ' storage space for the plane matrices, maximum'// 78 - - ' number of records in a direct access' 79 - PRINT *,' file would be exceeded;'// 80 - - ' decrease the value of FOURIER or increase'// 81 - - ' MXRECL if the disks allow.' 82 - RETURN 83 - ENDIF 0 84-+ +SELF. 85 - *** Open the dataset, if it is not yet open. 86 - INQUIRE(UNIT=13,OPENED=OPEN) 87 - IF(OPEN)THEN 88 - PRINT *,' !!!!!! IONBGN WARNING : Unit 13 was still open'// 89 - - ' and is now being closed (program bug)' 90 - CLOSE(UNIT=13,IOSTAT=IOS,ERR=2030) 91 - ENDIF 1 723 P=SIGNAL D=IONBGN 2 PAGE1119 92-+ +SELF,IF=CMS. 93 - WRITE(FILDEF,'(''FILEDEF 13 DISK GARFTEMP SIGNAL A6'', 94 - - '' (CHANGE XTENT '',I4)') NRECS 95 - CALL VMCMS(FILDEF,IRC) 96 - IF(IRC.NE.0)THEN 97 - PRINT *,' !!!!!! IONBGN WARNING : Error issuing a'// 98 - - ' FILEDEF for the pure signal dataset.' 99 - GOTO 2020 100 - ENDIF 0 101-+ +SELF. 102 - OPEN(UNIT=13,STATUS='SCRATCH',FORM='UNFORMATTED', 103 - - ACCESS='DIRECT',RECL=NPEREC*8*NWIRE+4,IOSTAT=IOS,ERR=2020) 104 - FILE='' 105 - CALL DSNLOG(FILE,'Scratch ','Direct ','Read/Write') 106 - * and set IFAIL to 0, since it apparently worked. 107 - IFAIL=0 108 - IF(LDEBUG)PRINT *,' ++++++ IONBGN DEBUG : Unit 13 opened', 109 - - ' with columns/rec=',NPEREC,', rec/matrix=',NRECMT, 110 - - ', recl=',NPEREC*8*NWIRE+4,' byte, records=',NRECS 111 - RETURN 112 - *** Handle the error conditions. 113 - 2020 CONTINUE 114 - PRINT *,' ###### IONBGN ERROR : Unable to open scratch'// 115 - - ' data set on unit 13 (used for signal matrices);'// 116 - - ' ion tails cannot be calculated.' 117 - CALL INPIOS(IOS) 118 - CLOSE(UNIT=13,IOSTAT=IOS,ERR=2030) 119 - RETURN 120 - 2030 CONTINUE 121 - PRINT *,' ###### IONBGN ERROR : Unable to close scratch'// 122 - - ' data set on unit 13 (attempted because of previous'// 123 - - ' error condition).' 124 - CALL INPIOS(IOS) 125 - END 724 GARFIELD ================================================== P=SIGNAL D=IONIO 1 ============================ 0 + +DECK,IONIO. 1 - SUBROUTINE IONIO(MX,MY,IMODE,NCOL,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * IONIO - Performs the external I/O operations for the routine SIGIPR 4 - * VARIABLES : MX, MY : Fourier indices of the layers 5 - * IMODE : operation mode, 1=write, 2=read 6 - * NCOL : columns to be written/read (0 = all) 7 - * (see also routine IONBGN) 8 - * (Last changed on 12/11/98.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13.- +SEQ,SIGNALDATA. 14.- +SEQ,SIGNALMATRIX. 15.- +SEQ,PRINTPLOT. 16 - INTEGER MX,MY,IMODE,NCOL,IFAIL,NPEREC,NRECMT,IRECP0,NRECS,NREC1, 17 - - I,II,JJ,JMIN,JMAX,IOS 18 - COMMON /FILE13/ NPEREC,NRECMT,IRECP0,NRECS 19 - *** Assume the routine will fail. 20 - IFAIL=0 21 - *** Find the location of the first record. 22 - IF(FPERX.AND.FPERY)THEN 23 - NREC1=1+((MX+NFOUR/2-1)*NFOUR+(MY+NFOUR/2-1))*NRECMT 24 - ELSEIF(FPERX)THEN 25 - NREC1=1+(MX+NFOUR/2-1)*NRECMT 26 - ELSEIF(FPERY)THEN 27 - NREC1=1+(MY+NFOUR/2-1)*NRECMT 28 - ELSE 29 - RETURN 30 - ENDIF 31 - *** Find the relevant columns. 32 - DO 10 I=0,NRECMT-1 33 - JMIN=I*NPEREC+1 34 - JMAX=MIN((I+1)*NPEREC,NWIRE) 35 - IF(NCOL.NE.0.AND.(NCOL.LT.JMIN.OR.NCOL.GT.JMAX))GOTO 10 36 - IF(NREC1+I.LE.0.OR.NREC1+I.GT.NRECS)THEN 37 - PRINT *,' ###### IONIO ERROR : I/O request references', 38 - - ' a non existing record on unit 13 (program bug).' 39 - IFAIL=1 40 - RETURN 41 - ENDIF 42 - IF(IMODE.EQ.1)THEN 43 - WRITE(UNIT=13,REC=NREC1+I,IOSTAT=IOS,ERR=2010) 44 - - ((SIGMAT(II,JJ),II=1,NWIRE),JJ=JMIN,JMAX) 45 - ELSEIF(IMODE.EQ.2)THEN 46 - READ(UNIT=13,REC=NREC1+I,IOSTAT=IOS,ERR=2010) 47 - - ((SIGMAT(II,JJ),II=1,NWIRE),JJ=JMIN,JMAX) 48 - ENDIF 49 - 10 CONTINUE 50 - RETURN 51 - *** Handle the error condition. 52 - 2010 CONTINUE 53 - PRINT *,' ###### IONIO ERROR : Error during I/O'// 54 - - ' to scratch data set on unit 13 (signal matrices).' 55 - CALL INPIOS(IOS) 56 - IF(LDEBUG)PRINT *,' ++++++ IONIO DEBUG : Error occurred at'// 57 - - ' block ',I,' of matrix (',MX,',',MY,') REC=',NREC1+I 58 - IFAIL=1 59 - END 725 GARFIELD ================================================== P=SIGNAL D=IPLIO 1 ============================ 0 + +DECK,IPLIO. 1 - SUBROUTINE IPLIO(MX,MY,IMODE,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * IPLIO - Performs the I/O operations for the routine SIGIPR 4 - * storing and retrieving plane weighting charges. 1 725 P=SIGNAL D=IPLIO 2 PAGE1120 5 - * VARIABLES : MX, MY : Fourier indices of the layers 6 - * IMODE : operation mode, 1=write, 2=read 7 - * (see also routine IONBGN) 8 - * (Last changed on 9/11/98.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13.- +SEQ,SIGNALDATA. 14.- +SEQ,SIGNALMATRIX. 15.- +SEQ,PRINTPLOT. 16 - INTEGER MX,MY,IMODE,IFAIL,NPEREC,NRECMT,NRECS,I,J,IOS,NREC1, 17 - - IRECP0 18 - COMMON /FILE13/ NPEREC,NRECMT,IRECP0,NRECS 19 - *** Assume this will work. 20 - IFAIL=0 21 - *** Find the location of the first record. 22 - IF(FPERX.AND.FPERY)THEN 23 - NREC1=IRECP0+(MX+NFOUR/2-1)*NFOUR+MY+NFOUR/2-1 24 - ELSEIF(FPERX)THEN 25 - NREC1=IRECP0+MX+NFOUR/2-1 26 - ELSEIF(FPERY)THEN 27 - NREC1=IRECP0+MY+NFOUR/2-1 28 - ELSE 29 - RETURN 30 - ENDIF 31 - *** Read or write the matrix. 32 - IF(NREC1.LT.IRECP0.OR.NREC1.GT.NRECS)THEN 33 - PRINT *,' ###### IPLIO ERROR : I/O request references'// 34 - - ' an invalid record on unit 13 (program bug).' 35 - IFAIL=1 36 - RETURN 37 - ENDIF 38 - IF(IMODE.EQ.1)THEN 39 - WRITE(UNIT=13,REC=NREC1,IOSTAT=IOS,ERR=2010) 40 - - ((QPLANE(I,J),I=1,5),J=1,NWIRE) 41 - ELSEIF(IMODE.EQ.2)THEN 42 - READ(UNIT=13,REC=NREC1+I,IOSTAT=IOS,ERR=2010) 43 - - ((QPLANE(I,J),I=1,5),J=1,NWIRE) 44 - ENDIF 45 - 10 CONTINUE 46 - RETURN 47 - *** Handle the error condition. 48 - 2010 CONTINUE 49 - PRINT *,' ###### IPLIO ERROR : Error during I/O to scratch'// 50 - - ' data set on unit 13 (signal plane matrices).' 51 - CALL INPIOS(IOS) 52 - IF(LDEBUG)PRINT *,' ++++++ IPLIO DEBUG : Error occurred at'// 53 - - ' matrix (',MX,',',MY,') REC=',NREC1 54 - IFAIL=1 55 - END 726 GARFIELD ================================================== P=SIGNAL D=SIGANG 1 ============================ 0 + +DECK,SIGANG. 1 - SUBROUTINE SIGANG(ISOLID,ANGLE,XREF,YREF,ZREF, 2 - - XSTART,YSTART,ZSTART) 3 - *----------------------------------------------------------------------- 4 - * SIGANG - Returns a starting point at angle ANGLE on the surface of 5 - * volume ISOLID. 6 - * VARIABLES : 7 - * (Last changed on 20/ 5/99.) 8 - *----------------------------------------------------------------------- 9 - implicit none 10.- +SEQ,DIMENSIONS. 11.- +SEQ,SOLIDS. 12.- +SEQ,PRINTPLOT. 13 - DOUBLE PRECISION XREF,YREF,ZREF,R,X0,Y0,Z0,CT,ST,CP,SP,U,V,W 14 - REAL ANGLE,XSTART,YSTART,ZSTART 15 - INTEGER ISOLID,IREF 16 - *** Initial points. 17 - XSTART=REAL(XREF) 18 - YSTART=REAL(YREF) 19 - ZSTART=REAL(ZREF) 20 - *** See whether we got a valid solid. 21 - IF(ISOLID.LT.1.OR.ISOLID.GT.NSOLID)THEN 22 - PRINT *,' !!!!!! SIGANG WARNING : Invalid solid reference'// 23 - - ' received; returning reference point.' 24 - RETURN 25 - *** If this is not a cylinder, simply return. 26 - ELSEIF(ISOLTP(ISOLID).NE.1)THEN 27 - RETURN 28 - *** If a cylinder, process. 29 - ELSE 30 - * Starting point in buffer. 31 - IREF=ISTART(ISOLID) 32 - IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN 33 - PRINT *,' !!!!!! SIGANG WARNING : Solid address is'// 34 - - ' out of range ; returning reference.' 35 - RETURN 36 - ENDIF 37 - * Extract parameters. 38 - R =CBUF(IREF+1) 39 - X0=CBUF(IREF+3) 40 - Y0=CBUF(IREF+4) 41 - Z0=CBUF(IREF+5) 42 - CT=CBUF(IREF+10) 43 - ST=CBUF(IREF+11) 44 - CP=CBUF(IREF+12) 45 - SP=CBUF(IREF+13) 46 - * Compute thw local W coordinate of reference point. 47 - W=+CP*ST*(XREF-X0)+SP*ST*(YREF-Y0)+CT*(ZREF-Z0) 48 - * Compute the U and V coordinates. 49 - U=R*COS(ANGLE) 50 - V=R*SIN(ANGLE) 51 - * Transform to space coordinates. 1 726 P=SIGNAL D=SIGANG 2 PAGE1121 52 - XSTART=REAL(X0+CP*CT*U-SP*V+CP*ST*W) 53 - YSTART=REAL(Y0+SP*CT*U+CP*V+SP*ST*W) 54 - ZSTART=REAL(Z0 -ST*U +CT*W) 55 - ENDIF 56 - END 727 GARFIELD ================================================== P=SIGNAL D=SIGCLS 1 ============================ 0 + +DECK,SIGCLS. 1 - SUBROUTINE SIGCLS(LDIFF,LAVAL,LATTA,LTRACK,LTRMC,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGCLS - Subroutine describing the cluster formation, it generates 4 - * clusters along the track and assigns a number of secondary 5 - * pairs to each cluster. 6 - * VARIABLES : 7 - * (Last changed on 20/ 5/99.) 8 - *----------------------------------------------------------------------- 9 - implicit none 10.- +SEQ,DIMENSIONS. 11.- +SEQ,CELLDATA. 12.- +SEQ,GASDATA. 13.- +SEQ,PRINTPLOT. 14.- +SEQ,DRIFTLINE. 15.- +SEQ,PARAMETERS. 16.- +SEQ,SIGNALDATA. 17 - REAL XCLUST,YCLUST,ZCLUST,ECLUST,XCLPR,YCLPR,Q,RNDEXP, 18 - - VXMIN,VYMIN,VXMAX,VYMAX 19 - INTEGER I,NCLUST,ISW,IFAIL,IFAIL1,NCSTAT,NNPAIR 20 - CHARACTER*50 STATUS 21 - LOGICAL LDIFF,LAVAL,LATTA,LTRACK,LTRMC,DONE 22 - EXTERNAL RNDEXP 23 - *** Identify the routine. 24 - IF(LIDENT)PRINT *,' /// ROUTINE SIGCLS ///' 25 - *** Set the charge. 26 - Q=-1.0 27 - *** Usually this will work. 28 - IFAIL=0 29 - *** Check option compatibility. 30 - IF(LEPULS.AND.LTRACK)THEN 31 - PRINT *,' !!!!!! SIGCLS WARNING : ELECTRON-PULSE'// 32 - - ' is incompatible with INTERPOLATE-TRACK;'// 33 - - ' INTERPOLATE-TRACK cancelled.' 34 - LTRACK=.FALSE. 35 - ENDIF 36 - IF(LTRMC.AND.LTRACK)THEN 37 - PRINT *,' !!!!!! SIGCLS WARNING : MONTE-CARLO-TRACKS'// 38 - - ' is incompatible with INTERPOLATE-TRACK;'// 39 - - ' INTERPOLATE-TRACK cancelled.' 40 - LTRACK=.FALSE. 41 - ENDIF 42 - *** Initialise clustering. 43 - CALL TRACLI 44 - NCLUST=0 45 - *** Start a plot of the clusters -if this is requested. 46 - IF(LCLPLT)THEN 47 - IF(LTRACK)PRINT *,' ------ SIGCLS MESSAGE : Due to the'// 48 - - ' INTERPOLATE-TRACK, electrons will not be plotted.' 49 - * Layout. 50 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 51 - - 'Track, clusters and drift lines ') 52 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 53 - IF(PARTID.NE.'Unknown')CALL GRCOMM(3,'Particle: '//PARTID) 54 - ENDIF 55 - *** Print a table of the clusters not hitting a wire in the cell. 56 - IF(LCLPRT)THEN 57 - WRITE(LUNOUT,'('' Table of the clusters''/ 58 - - '' =====================''/)') 59 - IF(LTRACK)WRITE(LUNOUT,'('' Note: the data contained in '', 60 - - ''this table has been obtained via interpolation.''/)') 61 - IF(.NOT.POLAR)THEN 62 - WRITE(LUNOUT,'(/'' No x-start y-start'', 63 - - '' z-start Drift time Diffusion Pairs'', 64 - - '' Pair Arrival time Total charge'')') 65 - WRITE(LUNOUT,'( '' [cm] [cm]'', 66 - - '' [cm] [microsec] [microsec] '', 67 - - '' [microsec] [electrons]''/)') 68 - ELSE 69 - WRITE(LUNOUT,'('' No r-start phi-start'', 70 - - '' z-start Drift time Diffusion Pairs'', 71 - - '' Pair Arrival time Total charge'')') 72 - WRITE(LUNOUT,'( '' [cm] [degrees]'', 73 - - '' [cm] [microsec] [microsec] '', 74 - - '' [microsec] [electrons]''/)') 75 - ENDIF 76 - ENDIF 77 - *** Start drift lines from the track. 78 - 10 CONTINUE 79 - * Generate a cluster. 80 - CALL TRACLS(XCLUST,YCLUST,ZCLUST,ECLUST,NNPAIR,DONE,IFAIL1) 81 - IF(DONE)THEN 82 - GOTO 20 83 - ELSEIF(IFAIL1.NE.0)THEN 84 - PRINT *,' !!!!!! SIGCLS WARNING : Error generating a'// 85 - - ' cluster; clustering ended.' 86 - IFAIL=1 87 - GOTO 20 88 - ENDIF 89 - NCLUST=NCLUST+1 90 - * Convert cluster position from polar if needed. 91 - IF(POLAR)THEN 92 - CALL CFMCTP(XCLUST,YCLUST,XCLPR,YCLPR,1) 93 - CALL CFMCTR(XCLUST,YCLUST,XCLUST,YCLUST,1) 94 - ELSE 95 - XCLPR=XCLUST 96 - YCLPR=YCLUST 97 - ENDIF 1 727 P=SIGNAL D=SIGCLS 2 PAGE1122 98 - *** For MC calculation, calculate each electron separately. 99 - IF(LTRMC)THEN 100 - * Store the number of pairs as 1 (each is different). 101 - NPAIR=1 102 - * Print a line for this cluster. 103 - IF(LCLPRT)WRITE(LUNOUT,'(1X,I6,3(1X,E12.5),27X,I5)') 104 - - NCLUST,XCLPR,YCLPR,ZCLUST,NNPAIR 105 - * Loop over the electrons. 106 - DO 30 I=1,NNPAIR 107 - * Compute the drift line. 108 - CALL DLCMC(XCLUST,YCLUST,ZCLUST,Q,1) 109 - * Store arrival time, ISTAT code and integrated diff. for later use. 110 - TCLUST=TU(NU) 111 - ICLUST=ISTAT 112 - SCLUST=0 113 - IF(LAVAL.AND. 114 - - (AVATYP.EQ.'TOWNSEND'.OR. 115 - - AVATYP.EQ.'POLYA-TOWN'.OR. 116 - - AVATYP.EQ.'TOWN-FIXED'))CALL DLCTWN(ACLUST) 117 - IF(LATTA)CALL DLCATT(BCLUST) 118 - * Store incidence angle. 119 - CALL DLCPHI(FCLUST) 120 - * Print the information for this cluster if requested (MC format). 121 - IF(LCLPRT)THEN 122 - * Format the status code. 123 - CALL DLCSTF(ICLUST,STATUS,NCSTAT) 124 - CALL DLCISW(ICLUST,ISW) 125 - IF((ICLUST.GE.1.AND.ICLUST.LE.NWIRE).OR. 126 - - (ICLUST.GT.2*MXWIRE.AND. 127 - - ICLUST.LE.2*MXWIRE+MXSOLI).OR. 128 - - (ICLUST.LE.-11.AND.ICLUST.GE.-15))THEN 129 - IF(ISW.EQ.0)THEN 130 - STATUS=STATUS(1:NCSTAT)//', not read out' 131 - NCSTAT=MIN(LEN(STATUS),NCSTAT+14) 132 - ELSE 133 - STATUS=STATUS(1:NCSTAT)//', read out' 134 - NCSTAT=MIN(LEN(STATUS),NCSTAT+10) 135 - ENDIF 136 - ENDIF 137 - * Print a line for this cluster. 138 - WRITE(LUNOUT,'(84X,A)') STATUS(1:NCSTAT) 139 - ENDIF 140 - * Have the signal computed. 141 - CALL SIGETR(LDIFF,LAVAL,LATTA,IFAIL1) 142 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! SIGCLS WARNING : Error'// 143 - - ' tracing an electron; continuing.' 144 - * Plot this drift line, if requested - this may destroy (XU,YU). 145 - IF(LCLPLT.AND..NOT.LTRACK)CALL DLCPLT 146 - * Next pair in the cluster. 147 - 30 CONTINUE 148 - *** Analytic drifting with treatment of diffusion by Gauss propagation. 149 - ELSE 150 - * Store the number of pairs. 151 - NPAIR=NNPAIR 152 - ** In case of interpolation, request data for this cluster position. 153 - IF(LTRACK)THEN 154 - * Interpolate (also in Cartesian coordinates). 155 - CALL DLCTRI(XCLUST,YCLUST,ZCLUST,TCLUST,ICLUST, 156 - - SCLUST,ACLUST,BCLUST,FCLUST,LDIFF,LAVAL,LATTA, 157 - - IFAIL1) 158 - IF(IFAIL1.NE.0)THEN 159 - PRINT *,' !!!!!! SIGCLS WARNING : Interpolation'// 160 - - ' failure for a cluster; cluster skipped.' 161 - GOTO 10 162 - ENDIF 163 - ** Otherwise compute the average drift line now. 164 - ELSE 165 - * Compute the drift lines. 166 - CALL DLCALC(XCLUST,YCLUST,ZCLUST,Q,1) 167 - * Store arrival time, ISTAT code and integrated diff. for later use. 168 - TCLUST=TU(NU) 169 - ICLUST=ISTAT 170 - IF(LDIFF)CALL DLCDIF(SCLUST) 171 - IF(LAVAL.AND. 172 - - (AVATYP.EQ.'TOWNSEND'.OR. 173 - - AVATYP.EQ.'POLYA-TOWN'.OR. 174 - - AVATYP.EQ.'TOWN-FIXED'))CALL DLCTWN(ACLUST) 175 - IF(LATTA)CALL DLCATT(BCLUST) 176 - * Store incidence angle. 177 - CALL DLCPHI(FCLUST) 178 - ENDIF 179 - * Print the information for this cluster if requested (normal format). 180 - IF(LCLPRT)THEN 181 - * Format the status code. 182 - CALL DLCSTF(ICLUST,STATUS,NCSTAT) 183 - CALL DLCISW(ICLUST,ISW) 184 - IF((ICLUST.GE.1.AND.ICLUST.LE.NWIRE).OR. 185 - - (ICLUST.GT.2*MXWIRE.AND. 186 - - ICLUST.LE.2*MXWIRE+MXSOLI).OR. 187 - - (ICLUST.LE.-11.AND.ICLUST.GE.-15))THEN 188 - IF(ISW.EQ.0)THEN 189 - STATUS=STATUS(1:NCSTAT)//', not read out' 190 - NCSTAT=MIN(LEN(STATUS),NCSTAT+14) 191 - ELSE 192 - STATUS=STATUS(1:NCSTAT)//', read out' 193 - NCSTAT=MIN(LEN(STATUS),NCSTAT+14) 194 - ENDIF 195 - ENDIF 196 - * Print a line for this cluster. 197 - WRITE(LUNOUT,'(1X,I6,5(1X,E12.5),1X,I5,2X,A)') 198 - - NCLUST,XCLPR,YCLPR,ZCLUST,TCLUST,SCLUST,NPAIR, 199 - - STATUS(1:NCSTAT) 200 - ENDIF 201 - * Trace the electron and compute signals. 202 - CALL SIGETR(LDIFF,LAVAL,LATTA,IFAIL1) 203 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! SIGCLS WARNING : Error'// 1 727 P=SIGNAL D=SIGCLS 3 PAGE1123 204 - - ' tracing an electron; continuing.' 205 - * Plot this drift line, if requested - this may destroy (XU,YU). 206 - IF(LCLPLT.AND..NOT.LTRACK)CALL DLCPLT 207 - ENDIF 208 - *** Go for a new cluster. 209 - GOTO 10 210 - *** End of loop reached. 211 - 20 CONTINUE 212 - *** Finish the plot of the track and the electron drift lines. 213 - IF(LCLPLT)THEN 214 - * Draw the track. 215 - CALL TRAPLT 216 - * Register the plot. 217 - CALL GRALOG('Track, cluster and electron drift lines.') 218 - * Close the plot. 219 - CALL GRNEXT 220 - ENDIF 221 - *** Check that there is at least one cluster. 222 - IF(NCLUST.EQ.0)THEN 223 - PRINT *,' !!!!!! SIGCLS WARNING : No clusters have been'// 224 - - ' generated.' 225 - IFAIL=1 226 - ENDIF 227 - END 728 GARFIELD ================================================== P=SIGNAL D=SIGETR 1 ============================ 0 + +DECK,SIGETR. 1 - SUBROUTINE SIGETR(LDIFF,LAVAL,LATTA,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGETR - Computes ion tails and electron pulses. 4 - * (Last changed on 4/ 2/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,FIELDMAP. 10.- +SEQ,SOLIDS. 11.- +SEQ,GASDATA. 12.- +SEQ,DRIFTLINE. 13.- +SEQ,SIGNALDATA. 14.- +SEQ,PRINTPLOT. 15.- +SEQ,CONSTANTS. 16 - CHARACTER*10 VARLIS(MXVAR) 17 - DOUBLE PRECISION TIME(MXLIST),SIG(MXLIST), 18 - - VDRIFT(3,MXLIST),XAUX1,XAUX2,YAUX1,YAUX2,STEP 19 - REAL ORIION(MXLIST),AVAELE(MXLIST),PRSELE(MXLIST),PRSION(MXLIST), 20 - - DELION(MXLIST),ANGION(MXORIA),VAR(MXVAR),RES(1),PRSTOT, 21 - - SUM,SCALE,TPAIR,QPAIR,EX,EY,EZ,ETOT,VOLT,ANGLE, 22 - - GASTWN,GASATT,TWNVEC(MXLIST),DRES,XORIG(MXLIST), 23 - - YORIG(MXLIST),ZORIG(MXLIST),XSTART,YSTART,ZSTART, 24 - - BX,BY,BZ,BTOT 25 - INTEGER MODVAR(MXVAR),MODRES(1),IWION(MXLIST),IW,ISW,JSW,ISOLID, 26 - - I,J,IU,IA,IPAIR,IFAIL,IFAIL1,ILOC,ILOCRS,NSIG,NRES, 27 - - NERR 28 - LOGICAL USE(MXVAR),LDIFF,LAVAL,LATTA,START,OK 29 - EXTERNAL GASTWN,GASATT,GASVEL 30 - *** Indentify the routine. 31 - IF(LIDENT)PRINT *,' /// ROUTINE SIGETR ///' 32 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG : Called'', 33 - - '' for ion simple('',L1,'')/detailed('',L1, 34 - - '')/return('',L1,'')''/ 35 - - 26X,''electron('',L1,''), diff/aval/att: '',3L1)') 36 - - LITAIL,LDTAIL,LRTAIL,LEPULS,LDIFF,LAVAL,LATTA 37 - *** Assume that the routine will fail. 38 - IFAIL=1 39 - *** Compute wire and sense wire number if appropriate. 40 - IF((ICLUST.GE.1.AND.ICLUST.LE.NWIRE).OR. 41 - - (ICLUST.GT.2*MXWIRE.AND.ICLUST.LE.2*MXWIRE+MXSOLI).OR. 42 - - (ICLUST.LE.-11.AND.ICLUST.GE.-15))THEN 43 - IW=ICLUST 44 - ELSE 45 - IW=0 46 - ENDIF 47 - CALL DLCISW(ICLUST,ISW) 48 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', 49 - - '' Cluster status code '',I4,'' (electrode '', 50 - - I4,'')''/26X,''has '',I4,'' steps, total drift time '', 51 - - E12.5,'' microsec.'')') ICLUST,ISW,NU,TCLUST 52 - *** Verify that appropriate gas data is available. 53 - OK=.TRUE. 54 - IF(LEPULS.AND..NOT.GASOK(4))THEN 55 - PRINT *,' !!!!!! SIGETR WARNING : No Townsend tables'// 56 - - ' found; ELECTRON-PULSE cancelled.' 57 - LEPULS=.FALSE. 58 - OK=.FALSE. 59 - ENDIF 60 - IF(LDTAIL.AND..NOT.GASOK(4))THEN 61 - PRINT *,' !!!!!! SIGETR WARNING : No Townsend tables'// 62 - - ' found; DETAILED-ION-TAIL cancelled.' 63 - LDTAIL=.FALSE. 64 - OK=.FALSE. 65 - ENDIF 66 - *** Check that at least one of the flags is still on. 67 - IF(LITAIL.AND.LDTAIL)THEN 68 - PRINT *,' !!!!!! SIGETR WARNING : Both normal and'// 69 - - ' detailed ion tail requested; detailed kept.' 70 - LITAIL=.FALSE. 71 - OK=.FALSE. 72 - ENDIF 73 - IF(LITAIL.AND.LRTAIL)THEN 74 - PRINT *,' !!!!!! SIGETR WARNING : Both normal and'// 75 - - ' nonsampled ion tail requested; nonsampled kept.' 76 - LITAIL=.FALSE. 77 - OK=.FALSE. 78 - ENDIF 1 728 P=SIGNAL D=SIGETR 2 PAGE1124 79 - IF(LDTAIL.AND.LRTAIL)THEN 80 - PRINT *,' !!!!!! SIGETR WARNING : Both detailed and'// 81 - - ' nonsampled ion tail requested; detailed kept.' 82 - LRTAIL=.FALSE. 83 - OK=.FALSE. 84 - ENDIF 85 - IF(.NOT.(LEPULS.OR.LDTAIL.OR.LITAIL.OR.LRTAIL))THEN 86 - PRINT *,' !!!!!! SIGETR WARNING : Neither ion'// 87 - - ' tail, nor electron pulse remaining; no signal.' 88 - IFAIL=1 89 - RETURN 90 - ENDIF 91 - *** See whether we should proceed. 92 - IF(JFAIL.EQ.2.AND..NOT.OK)THEN 93 - PRINT *,' ###### SIGETR ERROR : Instruction is not'// 94 - - ' carried out because of the above errors.' 95 - IFAIL=1 96 - RETURN 97 - ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN 98 - PRINT *,' ###### SIGETR ERROR : Program terminated'// 99 - - ' because of the above errors.' 100 - IFAIL=1 101 - CALL QUIT 102 - ENDIF 103 - **** Don't proceed if the drift line has no steps or has zero length. 104 - IF((LEPULS.OR.LDTAIL).AND. 105 - - (NU.LE.1.OR.TU(MAX(1,NU)).LE.0))THEN 106 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', 107 - - '' Drift line not processed: NU='',I4,'' TU(NU)='', 108 - - E12.5,'' microsec.'')') NU,TU(MAX(1,NU)) 109 - IFAIL=0 110 - RETURN 111 - ENDIF 112 - *** Don't proceed if this is not a sense wire and CROSS-INDUCED is off. 113 - IF((IW.EQ.0.AND..NOT.(LCROSS.AND.(LEPULS.OR.LDTAIL))).OR. 114 - - (IW.NE.0.AND.ISW.EQ.0.AND.(.NOT.LCROSS)))THEN 115 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', 116 - - '' Drift line not processed: LCROSS='',L1,'', ISTAT='', 117 - - I4,'', ISW='',I4,''.'')') LCROSS,ICLUST,ISW 118 - IFAIL=0 119 - RETURN 120 - ENDIF 121 - *** See whether the angular spread function has been translated. 122 - IF(LITAIL.AND.IENANG.LE.0.AND.NCANG.GT.0)THEN 123 - * Translate the function. 124 - VARLIS(1)='PHI' 125 - CALL ALGPRE(FCNANG(1:NCANG),NCANG,VARLIS,1, 126 - - NRES,USE,IENANG,IFAIL1) 127 - * Check return code. 128 - IF(IFAIL1.NE.0)THEN 129 - PRINT *,' !!!!!! SIGETR WARNING : Unable to'// 130 - - ' translate the angular spread function;'// 131 - - ' ion origin not smeared.' 132 - CALL ALGCLR(IENANG) 133 - IENANG=0 134 - * Ensure that the function gives only 1 result. 135 - ELSEIF(NRES.NE.1)THEN 136 - PRINT *,' !!!!!! SIGETR WARNING : The angular'// 137 - - ' spread function does not give 1 result;'// 138 - - ' ion origin not smeared.' 139 - CALL ALGCLR(IENANG) 140 - IENANG=0 141 - ENDIF 142 - ENDIF 143 - *** Determine the angle of approach for this particular electron. 144 - IF(LITAIL)THEN 145 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', 146 - - '' Incidence angle is '',F10.3,'' degrees.'')') 147 - - FCLUST*180/PI 148 - ** Smear the angular distribution, if requested. 149 - IF(IENANG.NE.0)THEN 150 - * Mode of the angle is 2 (number). 151 - MODVAR(1)=2 152 - * Initialise the number of arithmetic, mode and value errors to 0. 153 - NERR=0 154 - * Initialise the sum of the bins. 155 - SUM=0 156 - * Loop over the bins. 157 - DO 330 I=1,NORIA 158 - * Newton-Raphson integration over the bin. 159 - DO 340 J=-NASIMP,+NASIMP 160 - IF(NASIMP.GT.0)THEN 161 - VAR(1)=2*PI*(REAL(I)+REAL(J)/REAL(2*NASIMP))/ 162 - - REAL(NORIA)-FCLUST 163 - ELSE 164 - VAR(1)=2*PI*REAL(I)/REAL(NORIA)-FCLUST 165 - ENDIF 166 - IF(VAR(1).GT.+PI)VAR(1)=VAR(1)-2*PI 167 - IF(VAR(1).LT.-PI)VAR(1)=VAR(1)+2*PI 168 - CALL ALGEXE(IENANG,VAR,MODVAR,1,RES,MODRES,1,IFAIL1) 169 - IF(IFAIL1.NE.0.OR.MODRES(1).NE.2.OR.RES(1).LT.0) 170 - - NERR=NERR+1 171 - IF(J.EQ.-NASIMP)THEN 172 - ANGION(I)=RES(1) 173 - ELSEIF(J.EQ.+NASIMP)THEN 174 - ANGION(I)=ANGION(I)+RES(1) 175 - ELSEIF(J+NASIMP.EQ.2*((J+NASIMP)/2))THEN 176 - ANGION(I)=ANGION(I)+2*RES(1) 177 - ELSE 178 - ANGION(I)=ANGION(I)+4*RES(1) 179 - ENDIF 180 - 340 CONTINUE 181 - * Keep track of the integral. 182 - SUM=SUM+ANGION(I) 183 - 330 CONTINUE 184 - * Check the error count. 1 728 P=SIGNAL D=SIGETR 3 PAGE1125 185 - CALL ALGERR 186 - IF(NERR.GT.0)THEN 187 - PRINT *,' !!!!!! SIGETR WARNING : Value, type'// 188 - - ' or arithmetic errors; no smearing.' 189 - IENANG=0 190 - ENDIF 191 - ENDIF 192 - ** If no smearing has been requested, then simply put all in one bin. 193 - IF(IENANG.EQ.0)THEN 194 - * Set the whole distribution to zero. 195 - DO 350 I=1,NORIA 196 - ANGION(I)=0 197 - 350 CONTINUE 198 - * Transform the angle into an angular bin. 199 - IA=NINT(NORIA*MOD(FCLUST-2*PI*ANINT(FCLUST/(2*PI))+ 200 - - 2*PI,2*PI)/(2*PI)) 201 - IF(IA.EQ.0)IA=NORIA 202 - * And set just this element to non-zero. 203 - ANGION(IA)=1 204 - SUM=1 205 - ENDIF 206 - ** Normalise the distribution. 207 - DO 360 I=1,NORIA 208 - ANGION(I)=ANGION(I)/SUM 209 - 360 CONTINUE 210 - ** Output the distribution if debugging has been requested. 211 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', 212 - - '' Angular distribution in %: ''/(2X,20I4/))') 213 - - (NINT(ANGION(I)*100),I=1,NORIA) 214 - ENDIF 215 - *** Follow the electron drift line for electron and detailed ion. 216 - IF(LEPULS.OR.LDTAIL)THEN 217 - START=.FALSE. 218 - * We;ll have to cheat in case the point is located inside a wire. 219 - IF(ISTAT.GT.0)THEN 220 - ILOCRS=MOD(ISTAT,MXWIRE) 221 - DRES=D(ILOCRS) 222 - ELSE 223 - ILOCRS=0 224 - ENDIF 225 - ** Loop over the drift line. 226 - DO 100 IU=1,NU 227 - * Various initialisations. 228 - TWNVEC(IU)=0 229 - AVAELE(IU)=0 230 - VDRIFT(1,IU)=0 231 - VDRIFT(2,IU)=0 232 - VDRIFT(3,IU)=0 233 - ORIION(IU)=0 234 - DELION(IU)=0 235 - XORIG(IU)=0 236 - YORIG(IU)=0 237 - ZORIG(IU)=0 238 - IWION(IU)=0 239 - ** First take care of charge integration. 240 - IF(ILOCRS.GT.0)D(ILOCRS)=DRES/2 241 - CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 242 - - EX,EY,EZ,ETOT,VOLT,0,ILOC) 243 - CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 244 - - BX,BY,BZ,BTOT,VOLT,0,ILOC) 245 - IF(ILOCRS.GT.0)D(ILOCRS)=DRES 246 - * Get Townsend and attachment coefficients and keep integrating. 247 - IF(POLAR)THEN 248 - IF(GASOK(4))TWNVEC(IU)=TWNVEC(IU)+ 249 - - GASTWN(EX/EXP(REAL(XU(IU))),EY/EXP(REAL(XU(IU))), 250 - - EZ,BX,BY,BZ) 251 - IF(GASOK(6))TWNVEC(IU)=TWNVEC(IU)- 252 - - GASATT(EX/EXP(REAL(XU(IU))),EY/EXP(REAL(XU(IU))), 253 - - EZ,BX,BY,BZ) 254 - IF(IU.GT.1)THEN 255 - CALL CF2RTC(XU(IU),YU(IU),XAUX1,YAUX1,1) 256 - CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX2,YAUX2,1) 257 - STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ 258 - - (ZU(IU)-ZU(IU-1))**2) 259 - ENDIF 260 - ELSE 261 - IF(GASOK(4))TWNVEC(IU)=TWNVEC(IU)+GASTWN(EX,EY,EZ, 262 - - BX,BY,BZ) 263 - IF(GASOK(6))TWNVEC(IU)=TWNVEC(IU)-GASATT(EX,EY,EZ, 264 - - BX,BY,BZ) 265 - IF(IU.GT.1)STEP=SQRT((XU(IU)-XU(IU-1))**2+ 266 - - (YU(IU)-YU(IU-1))**2+(ZU(IU)-ZU(IU-1))**2) 267 - ENDIF 268 - * Check whether the avalanche has started. 269 - IF(TWNVEC(IU).GT.1E-6.AND..NOT.START)THEN 270 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', 271 - - '' Avalanche starts at step '',I4)') IU 272 - START=.TRUE. 273 - ENDIF 274 - * Update the vector. 275 - IF(IU.GT.1)THEN 276 - AVAELE(IU)=AVAELE(IU-1)+ 277 - - STEP*(TWNVEC(IU)+TWNVEC(IU-1))/2 278 - ELSE 279 - AVAELE(IU)=0 280 - ENDIF 281 - ** Next compute and store the local electron drift velocity. 282 - IF(LEPULS)THEN 283 - IF(ILOCRS.GT.0)D(ILOCRS)=DRES/2 284 - CALL DLCVEL(XU(IU),YU(IU),ZU(IU),VDRIFT(1,IU), 285 - - -1.0,1,ILOC) 286 - IF(ILOCRS.GT.0)D(ILOCRS)=DRES 287 - ENDIF 288 - ** Compute the 'would have been' origin of the ions. 289 - IF(LDTAIL)THEN 290 - * In case we don't find any, we need the true starting point. 1 728 P=SIGNAL D=SIGETR 4 PAGE1126 291 - XORIG(IU)=XU(IU) 292 - YORIG(IU)=YU(IU) 293 - ZORIG(IU)=ZU(IU) 294 - ORIION(IU)=0 295 - * Save electron drift line. 296 - CALL DLCBCK('SAVE') 297 - * Compute the origin of the ion drift line. 298 - IF(IU.EQ.1.OR..NOT.START)THEN 299 - NU=1 300 - TU(NU)=0 301 - ISTAT=0 302 - ELSE 303 - CALL DLCALC(REAL(0.5*(XU(IU)+XU(IU-1))), 304 - - REAL(0.5*(YU(IU)+YU(IU-1))), 305 - - REAL(0.5*(ZU(IU)+ZU(IU-1))),-1.0,2) 306 - ENDIF 307 - * Store the data. 308 - IF(ISTAT.GE.1.AND.ISTAT.LE.NWIRE)THEN 309 - ORIION(IU)=ATAN2(REAL(YU(NU))-Y(ISTAT), 310 - - REAL(XU(NU)-X(ISTAT))) 311 - DELION(IU)=TU(NU) 312 - IWION(IU)=ISTAT 313 - XORIG(IU)=0 314 - YORIG(IU)=0 315 - ZORIG(IU)=0 316 - ELSEIF((ISTAT.GT.2*MXWIRE.AND. 317 - - ISTAT.LE.2*MXWIRE+MXSOLI).OR. 318 - - (ISTAT.LE.-11.AND.ISTAT.GE.-15))THEN 319 - ORIION(IU)=0 320 - DELION(IU)=0 321 - IWION(IU)=ISTAT 322 - ELSEIF(ISTAT.NE.-3.AND.ISTAT.NE.0.AND.NU.GT.1)THEN 323 - ORIION(IU)=0 324 - DELION(IU)=0 325 - IWION(IU)=-1 326 - ELSE 327 - IF(LDEBUG)WRITE(LUNOUT, 328 - - '('' ++++++ SIGETR DEBUG : Ion line for'', 329 - - '' IU='',I4,'' skipped, ISTAT='',I4)') 330 - - IU,ISTAT 331 - ORIION(IU)=0 332 - DELION(IU)=0 333 - IWION(IU)=0 334 - XORIG(IU)=0 335 - YORIG(IU)=0 336 - ZORIG(IU)=0 337 - ENDIF 338 - * Restore the drift line. 339 - CALL DLCBCK('RESTORE') 340 - ENDIF 341 - 100 CONTINUE 342 - ENDIF 343 - *** Loop over the clusters. 344 - DO 200 IPAIR=1,NPAIR 345 - * Generate electron arrival time and multiplication. 346 - CALL SIGCRN(LDIFF,LAVAL,LATTA,TPAIR,QPAIR) 347 - * Print pair data if requested. 348 - IF(LCLPRT)WRITE(LUNOUT,'(79X,I5,2(1X,E12.5))') IPAIR,TPAIR,QPAIR 349 - *** Compute simple ion currents in wires from the relevant angles. 350 - IF(LITAIL.AND.IW.GE.1.AND.IW.LE.NWIRE)THEN 351 - DO 480 I=1,NORIA 352 - ANGLE=2*PI*REAL(I)/REAL(NORIA) 353 - * Skip bins with very small contributions. 354 - IF(ANGION(I)*NORIA.LT.1E-3)GOTO 480 355 - ** Cross-induced signals requested, loop over all sense wires. 356 - IF(LCROSS)THEN 357 - DO 490 JSW=1,NSW 358 - * Get the ion tail. 359 - CALL SIGION(JSW,IW,ANGLE,NSIG,TIME,SIG,IFAIL1) 360 - * And add if it the tail is available. 361 - IF(IFAIL1.NE.0)THEN 362 - PRINT *,' !!!!!! SIGETR WARNING : Unable to'// 363 - - ' obtain an ion tail ; tail not added.' 364 - ELSE 365 - CALL SIGADD(JSW,ISW.NE.JSW,NSIG,TIME,SIG, 366 - - ANGION(I)*QPAIR,0.0,TPAIR,IFAIL1) 367 - ENDIF 368 - 490 CONTINUE 369 - ** For only direct signals, don't do the loop. 370 - ELSEIF(ISW.NE.0)THEN 371 - * Get the ion tail. 372 - CALL SIGION(ISW,IW,ANGLE,NSIG,TIME,SIG,IFAIL1) 373 - * And add if it the tail is available. 374 - IF(IFAIL1.NE.0)THEN 375 - PRINT *,' !!!!!! SIGETR WARNING : Unable to'// 376 - - ' obtain an ion tail ; tail not added.' 377 - ELSE 378 - CALL SIGADD(ISW,.FALSE.,NSIG,TIME,SIG, 379 - - ANGION(I)*QPAIR,0.0,TPAIR,IFAIL1) 380 - ENDIF 381 - ENDIF 382 - ** Next orientation and pair. 383 - 480 CONTINUE 384 - *** Compute simple ion currents in wires from the relevant angles. 385 - ELSEIF(LRTAIL.AND.IW.GE.1.AND.IW.LE.NWIRE)THEN 386 - * Starting point. 387 - XSTART=REAL(XU(NU)) 388 - YSTART=REAL(YU(NU)) 389 - ZSTART=REAL(ZU(NU)) 390 - ** Cross-induced signals requested, loop over all sense wires. 391 - IF(LCROSS)THEN 392 - DO 530 JSW=1,NSW 393 - * Get the ion tail. 394 - CALL SIGIOR(JSW,XSTART,YSTART,ZSTART, 395 - - NSIG,TIME,SIG,IFAIL1) 396 - * And add if it the tail is available. 1 728 P=SIGNAL D=SIGETR 5 PAGE1127 397 - IF(IFAIL1.NE.0)THEN 398 - PRINT *,' !!!!!! SIGETR WARNING : Unable to'// 399 - - ' compute an ion tail ; tail not added.' 400 - ELSE 401 - CALL SIGADD(JSW,ISW.NE.JSW,NSIG,TIME,SIG, 402 - - QPAIR,0.0,TPAIR,IFAIL1) 403 - ENDIF 404 - 530 CONTINUE 405 - ** For only direct signals, don't do the loop. 406 - ELSEIF(ISW.NE.0)THEN 407 - * Get the ion tail. 408 - CALL SIGIOR(ISW,XSTART,YSTART,ZSTART, 409 - - NSIG,TIME,SIG,IFAIL1) 410 - * And add if it the tail is available. 411 - IF(IFAIL1.NE.0)THEN 412 - PRINT *,' !!!!!! SIGETR WARNING : Unable to'// 413 - - ' compute an ion tail ; tail not added.' 414 - ELSE 415 - CALL SIGADD(ISW,.FALSE.,NSIG,TIME,SIG, 416 - - QPAIR,0.0,TPAIR,IFAIL1) 417 - ENDIF 418 - ENDIF 419 - *** Compute simple ion currents in solids from the relevant angles. 420 - ELSEIF(LITAIL.AND.IW.GE.2*MXWIRE+1.AND.IW.LE.2*MXWIRE+NSOLID)THEN 421 - * Find out which solid. 422 - ISOLID=IW-2*MXWIRE 423 - ** If a cylinder, take angular spread into account. 424 - IF(ISOLTP(ISOLID).EQ.1)THEN 425 - DO 500 I=1,NORIA 426 - ANGLE=2*PI*REAL(I)/REAL(NORIA) 427 - * Skip bins with very small contributions. 428 - IF(ANGION(I)*NORIA.LT.1E-3)GOTO 500 429 - * Compute origin for this angle. 430 - CALL SIGANG(ISOLID,ANGLE,XU(NU),YU(NU),ZU(NU), 431 - - XSTART,YSTART,ZSTART) 432 - * Cross-induced signals requested, loop over all sense wires. 433 - IF(LCROSS)THEN 434 - DO 510 JSW=1,NSW 435 - * Get the ion tail. 436 - CALL SIGIOR(JSW,XSTART,YSTART,ZSTART, 437 - - NSIG,TIME,SIG,IFAIL1) 438 - * And add if it the tail is available. 439 - IF(IFAIL1.NE.0)THEN 440 - PRINT *,' !!!!!! SIGETR WARNING : Unable'// 441 - - ' to obtain an ion tail ; tail not'// 442 - - ' added.' 443 - ELSE 444 - CALL SIGADD(JSW,ISW.NE.JSW,NSIG,TIME,SIG, 445 - - ANGION(I)*QPAIR,0.0,TPAIR,IFAIL1) 446 - ENDIF 447 - 510 CONTINUE 448 - * For only direct signals, don't do the loop. 449 - ELSEIF(ISW.NE.0)THEN 450 - * Get the ion tail. 451 - CALL SIGIOR(ISW,XSTART,YSTART,ZSTART, 452 - - NSIG,TIME,SIG,IFAIL1) 453 - * And add if it the tail is available. 454 - IF(IFAIL1.NE.0)THEN 455 - PRINT *,' !!!!!! SIGETR WARNING : Unable'// 456 - - ' to obtain an ion tail ; tail not'// 457 - - ' added.' 458 - ELSE 459 - CALL SIGADD(ISW,.FALSE.,NSIG,TIME,SIG, 460 - - ANGION(I)*QPAIR,0.0,TPAIR,IFAIL1) 461 - ENDIF 462 - ENDIF 463 - 500 CONTINUE 464 - ** For other solids, drift an ion backwards. 465 - ELSE 466 - * Establish end point. 467 - XSTART=REAL(XU(NU)) 468 - YSTART=REAL(YU(NU)) 469 - ZSTART=REAL(ZU(NU)) 470 - * Cross-induced signals requested, loop over all sense wires. 471 - IF(LCROSS)THEN 472 - DO 520 JSW=1,NSW 473 - * Get the ion tail. 474 - CALL SIGIOR(JSW,XSTART,YSTART,ZSTART, 475 - - NSIG,TIME,SIG,IFAIL1) 476 - * And add if it the tail is available. 477 - IF(IFAIL1.NE.0)THEN 478 - PRINT *,' !!!!!! SIGETR WARNING : Unable'// 479 - - ' to obtain an ion tail ; tail not'// 480 - - ' added.' 481 - ELSE 482 - CALL SIGADD(JSW,ISW.NE.JSW,NSIG,TIME,SIG, 483 - - QPAIR,0.0,TPAIR,IFAIL1) 484 - ENDIF 485 - 520 CONTINUE 486 - * For only direct signals, don't do the loop. 487 - ELSEIF(ISW.NE.0)THEN 488 - * Get the ion tail. 489 - CALL SIGIOR(ISW,XSTART,YSTART,ZSTART, 490 - - NSIG,TIME,SIG,IFAIL1) 491 - * And add if it the tail is available. 492 - IF(IFAIL1.NE.0)THEN 493 - PRINT *,' !!!!!! SIGETR WARNING : Unable'// 494 - - ' to obtain an ion tail ; tail not'// 495 - - ' added.' 496 - ELSE 497 - CALL SIGADD(ISW,.FALSE.,NSIG,TIME,SIG, 498 - - QPAIR,0.0,TPAIR,IFAIL1) 499 - ENDIF 500 - ENDIF 501 - ENDIF 502 - ENDIF 1 728 P=SIGNAL D=SIGETR 6 PAGE1128 503 - *** Compute scaling for the number of pairs. 504 - IF(LEPULS.OR.LDTAIL)THEN 505 - IF(IW.EQ.0)THEN 506 - SCALE=1 507 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', 508 - - '' Avalanche scaling = 1, no electrode hit.'')') 509 - ELSEIF(QPAIR.LE.0)THEN 510 - SCALE=0 511 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', 512 - - '' No avalanche, not scaled.'')') 513 - ELSEIF(NU.LE.0)THEN 514 - SCALE=1 515 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', 516 - - '' Avalanche scaling = 1, no steps.'')') 517 - ELSEIF(AVAELE(NU).LE.0)THEN 518 - SCALE=1 519 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', 520 - - '' Avalanche scaling = 1, no electrons left.'')') 521 - ELSE 522 - SCALE=LOG(QPAIR)/AVAELE(NU) 523 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', 524 - - '' Avalanche scaling = '',E12.5)') SCALE 525 - ENDIF 526 - * Debugging output. 527 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG : '', 528 - - ''Charge from Townsend integration: '',E12.5/ 529 - - 26X,''Requested total charge: '',E12.5/ 530 - - 26X,''Scaling factor: '',E12.5/ 531 - - 2X,''Avalanche development: ''/ 532 - - '' Time [microsec] Alpha int Electrons'', 533 - - '' Ions Ion origin Ion delay'', 534 - - '' Stat'')') EXP(MIN(50.0,AVAELE(NU))),QPAIR,SCALE 535 - * Loop over the electron drift line. 536 - PRSTOT=0 537 - DO 210 IU=1,NU 538 - * Make a table of the number of electrons (integral). 539 - IF(AVAELE(IU)*SCALE.LT.LOG(0.5))THEN 540 - PRSELE(IU)=0 541 - ELSEIF(AVAELE(IU)*SCALE.LT.LOG(1.5))THEN 542 - PRSELE(IU)=1 543 - ELSE 544 - PRSELE(IU)=1+EXP(MIN(50.0,AVAELE(IU)*SCALE)) 545 - ENDIF 546 - * Make a table of the number of ions (differential). 547 - IF(IU.EQ.1)THEN 548 - PRSION(IU)=0 549 - ELSE 550 - PRSION(IU)=MAX(0.0,PRSELE(IU)-PRSELE(IU-1)) 551 - ENDIF 552 - PRSTOT=PRSTOT+PRSION(IU) 553 - * Make a timing table. 554 - TIME(IU)=TU(IU)*TPAIR/TU(NU) 555 - * Debugging output. 556 - IF(LDEBUG)WRITE(LUNOUT,'(2X,I5,6(1X,E12.5),1X,I4)') 557 - - IU,TIME(IU),AVAELE(IU),PRSELE(IU),PRSION(IU), 558 - - ORIION(IU),DELION(IU),IWION(IU) 559 - 210 CONTINUE 560 - ENDIF 561 - *** Add the electron current. 562 - IF(LEPULS)THEN 563 - ** Cross induction: loop over all sense wires. 564 - IF(LCROSS)THEN 565 - * Loop over the sense wires. 566 - DO 240 JSW=1,NSW 567 - * Compute contribution of the current drift line to the signal 568 - DO 250 IU=1,NU 569 - CALL SIGFLS(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 570 - - EX,EY,EZ,JSW) 571 - SIG(IU)=PRSELE(IU)*(VDRIFT(1,IU)*EX+VDRIFT(2,IU)*EY+ 572 - - VDRIFT(3,IU)*EZ) 573 - 250 CONTINUE 574 - * Add this current to the total. 575 - CALL SIGADD(JSW,ISW.NE.JSW,NU,TIME,SIG, 576 - - -1.0,0.0,0.0,IFAIL1) 577 - * Finish loop over the sense wires, 578 - 240 CONTINUE 579 - ** Otherwise do not do the loop. 580 - ELSEIF(ISW.NE.0)THEN 581 - * Compute contribution of the current drift line to the signal 582 - DO 220 IU=1,NU 583 - CALL SIGFLS(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 584 - - EX,EY,EZ,ISW) 585 - SIG(IU)=PRSELE(IU)*(VDRIFT(1,IU)*EX+VDRIFT(2,IU)*EY+ 586 - - VDRIFT(3,IU)*EZ) 587 - 220 CONTINUE 588 - * Add this current to the total. 589 - CALL SIGADD(ISW,.FALSE.,NU,TIME,SIG, 590 - - -1.0,0.0,0.0,IFAIL1) 591 - ENDIF 592 - ENDIF 593 - *** Add the ion currents. 594 - IF(LDTAIL)THEN 595 - * Loop over the electron track. 596 - DO 260 IU=2,NU 597 - * Skip points where there are no ions yet. 598 - IF(PRSION(IU).LT.1.0)GOTO 260 599 - * Skip also points with a negligible contribution. 600 - IF(PRSION(IU).LT.PRSTHR*PRSTOT)GOTO 260 601 - * Skip points where the ions don't come from an electrode. 602 - IF(IWION(IU).EQ.0)GOTO 260 603 - ** Cross-induced signals requested, loop over all sense wires. 604 - IF(LCROSS)THEN 605 - DO 270 JSW=1,NSW 606 - * Get the ion tail. 607 - IF(IWION(IU).GE.1.AND.IWION(IU).LE.NWIRE)THEN 608 - CALL SIGION(JSW,IWION(IU),ORIION(IU), 1 728 P=SIGNAL D=SIGETR 7 PAGE1129 609 - - NSIG,TIME,SIG,IFAIL1) 610 - ELSE 611 - CALL SIGIOR(JSW,XORIG(IU),YORIG(IU),ZORIG(IU), 612 - - NSIG,TIME,SIG,IFAIL1) 613 - ENDIF 614 - * And add if it the tail is available. 615 - IF(IFAIL1.NE.0)THEN 616 - PRINT *,' !!!!!! SIGETR WARNING : Unable to'// 617 - - ' obtain an ion tail ; tail not added.' 618 - ELSE 619 - CALL SIGADD(JSW,ISW.NE.JSW,NSIG,TIME,SIG, 620 - - PRSION(IU),DELION(IU),TPAIR-DELION(IU), 621 - - IFAIL1) 622 - ENDIF 623 - 270 CONTINUE 624 - ** For only direct signals, only process ions from the same source, 625 - ELSEIF(IWION(IU).EQ.IW)THEN 626 - * Get the ion tail. 627 - IF(IWION(IU).GE.1.AND.IWION(IU).LE.NWIRE)THEN 628 - CALL SIGION(ISW,IWION(IU),ORIION(IU), 629 - - NSIG,TIME,SIG,IFAIL1) 630 - ELSE 631 - CALL SIGIOR(ISW,XORIG(IU),YORIG(IU),ZORIG(IU), 632 - - NSIG,TIME,SIG,IFAIL1) 633 - ENDIF 634 - * And add if it the tail is available. 635 - IF(IFAIL1.NE.0)THEN 636 - PRINT *,' !!!!!! SIGETR WARNING : Unable to'// 637 - - ' obtain an ion tail ; tail not added.' 638 - ELSE 639 - CALL SIGADD(ISW,.FALSE.,NSIG,TIME,SIG, 640 - - PRSION(IU),DELION(IU),TPAIR-DELION(IU), 641 - - IFAIL1) 642 - ENDIF 643 - ENDIF 644 - * Next point on the electron track. 645 - 260 CONTINUE 646 - ENDIF 647 - *** Next cluster. 648 - 200 CONTINUE 649 - *** Seems to have worked. 650 - IFAIL=0 651 - END 729 GARFIELD ================================================== P=SIGNAL D=SIGCRN 1 ============================ 0 + +DECK,SIGCRN. 1 - SUBROUTINE SIGCRN(LDIFF,LAVAL,LATTA,TPAIR,QPAIR) 2 - *----------------------------------------------------------------------- 3 - * SIGCRN - Generates single electron time and avalanches. 4 - * (Last changed on 11/ 6/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,SIGNALDATA. 9.- +SEQ,PRINTPLOT. 10 - REAL TPAIR,QPAIR,RNDNOR 11 - LOGICAL LDIFF,LAVAL,LATTA 12 - EXTERNAL RNDNOR 13 - *** Identify the routine if requested. 14 - IF(LIDENT)PRINT *,' /// ROUTINE SIGCRN ///' 15 - *** Generate electron-ion pairs using diffusion and energy loss data. 16 - IF(LDIFF)THEN 17 - TPAIR=RNDNOR(TCLUST,SCLUST) 18 - ELSE 19 - TPAIR=TCLUST 20 - ENDIF 21 - *** Avalanche: various distributions, handled by SIGAVA. 22 - IF(LAVAL)THEN 23 - CALL SIGAVA(QPAIR,ACLUST) 24 - ELSE 25 - QPAIR=1 26 - ENDIF 27 - *** Attachment: take the attachment factor into account. 28 - IF(LATTA)QPAIR=BCLUST*QPAIR 29 - *** Debugging output if requested. 30 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGCRN DEBUG : Generated'', 31 - - '' t='',E12.5,'', Q='',E12.5,'',''/ 32 - - 26X,''Diffusion: '',L1,'' avalanche '',L1, 33 - - '' attachment '',L1,''.'')') TPAIR,QPAIR,LDIFF,LAVAL,LATTA 34 - END 730 GARFIELD ================================================== P=SIGNAL D=SIGADD 1 ============================ 0 + +DECK,SIGADD. 1 - SUBROUTINE SIGADD(ISW,CROSS,NSIG,TIME,SIG,Q,TMIN,TSHIFT,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGADD - Adds a signal to the current signal banks. 4 - * (Last changed on 6/10/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CONSTANTS. 9.- +SEQ,CELLDATA. 10.- +SEQ,SIGNALDATA. 11.- +SEQ,PRINTPLOT. 12 - INTEGER ISW,NSIG,IFAIL,I,J,MSIG,KIORD 13 - REAL Q,TMIN,TSHIFT 14 - LOGICAL CROSS 15 - DOUBLE PRECISION TIME(*),SIG(*),TIMIN,TIMAX,TINT,SUM 0 16-+ +SELF,IF=ESSL. 17 - INTEGER MXSIMP 18 - PARAMETER(MXSIMP=20) 19 - DOUBLE PRECISION AUX(MXLIST+2*MXSIMP+1),TVEC(-MXSIMP:MXSIMP), 20 - - SVEC(-MXSIMP:MXSIMP) 1 730 P=SIGNAL D=SIGADD 2 PAGE1130 21-+ +SELF,IF=-ESSL. 22 - DOUBLE PRECISION DIVDF2,TSIMP 23 - EXTERNAL DIVDF2 0 24-+ +SELF. 25 - *** Identify the routine. 0 26-+ +SELF,IF=ESSL. 27 - IF(LIDENT)PRINT *,' /// ROUTINE SIGADD (ESSL) ///' 0 28-+ +SELF,IF=-ESSL. 29 - IF(LIDENT)PRINT *,' /// ROUTINE SIGADD (CERNLIB) ///' 0 30-+ +SELF. 31 - *** Don't do anything if there are no points on the signal. 32 - IF(NSIG.LT.2)THEN 33 - IFAIL=0 34 - RETURN 35 - ENDIF 36 - *** Assume that the routine will fail. 37 - IFAIL=1 0 38-+ +SELF,IF=ESSL. 39 - *** Check interpolation order. 40 - IF(NISIMP.GT.MXSIMP)THEN 41 - PRINT *,' !!!!!! SIGADD WARNING : Number of integration'// 42 - - ' points exceeds maximum ; set to ',MXSIMP,'.' 43 - NISIMP=MXSIMP 44 - ENDIF 0 45-+ +SELF. 46 - *** Debugging output. 47 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGADD DEBUG : Adding a '', 48 - - I4,''-vector to sense wire '',I4,'', terms='',I3,'',''/ 49 - - 26X,''order='',I3,'', charge='',F10.3,'', tmin='',F10.3, 50 - - '',''/26X,''shift='',F10.3)') 51 - - NSIG,ISW,NISIMP,JIORD,Q,TMIN,TSHIFT 52 - *** Ensure that the sense wire number is in range. 53 - IF(ISW.LE.0.OR.ISW.GT.NSW)THEN 54 - PRINT *,' !!!!!! SIGADD WARNING : Sense wire number out'// 55 - - ' of range; signals not added.' 56 - RETURN 57 - ENDIF 58 - *** Verify that the signal has no 2 equal times in succession. 59 - DO 100 I=2,NSIG 60 - IF(TIME(I).LE.TIME(I-1))THEN 61 - MSIG=I-1 62 - IF(MSIG.LT.NSIG-1)PRINT *,' !!!!!! SIGADD WARNING :'// 63 - - ' Cutting signal at step ',MSIG,' out of ',NSIG, 64 - - ' (equal time).' 65 - GOTO 110 66 - ENDIF 67 - 100 CONTINUE 68 - MSIG=NSIG 69 - 110 CONTINUE 70 - *** Store the interpolation order. 71 - KIORD=MIN(JIORD,MSIG-1) 72 - *** Add the signal to the signal bank. 73 - DO 10 I=1,NTIME 74 - TINT=TIMSIG(I)-TSHIFT 75 - ** Averageing mode: establish integration time window. 76 - IF(NISIMP.GT.0)THEN 77 - * Truncate the time window to overlap with the computed signal. 78 - TIMIN=MAX(TIME(1),TINT-DBLE(TDEV/2),DBLE(TMIN)) 79 - TIMAX=MIN(TIME(NSIG),TINT+DBLE(TDEV/2)) 80 - * Skip this point if there is no overlap. 81 - IF(TIMAX.LE.TIMIN)GOTO 10 82 - ** Sampling mode: just check the point is in the computed signal. 83 - ELSE 84 - IF(TINT.LT.TIME(1).OR.TINT.GT.TIME(NSIG))GOTO 10 85 - ENDIF 86 - * Newton-Raphson integration over this bin. 0 87-+ +SELF,IF=-ESSL. 88 - IF(NISIMP.LE.0)THEN 89 - SUM=DIVDF2(SIG,TIME,MSIG,TINT,JIORD) 90 - ELSE 91 - DO 20 J=-NISIMP,NISIMP 92 - TSIMP=TIMIN+DBLE(J+NISIMP)*(TIMAX-TIMIN)/DBLE(2*NISIMP) 93 - IF(J.EQ.-NISIMP)THEN 94 - SUM=DIVDF2(SIG,TIME,MSIG,TSIMP,KIORD) 95 - ELSEIF(J.EQ.NISIMP)THEN 96 - SUM=SUM+DIVDF2(SIG,TIME,MSIG,TSIMP,KIORD) 97 - ELSEIF(J+NISIMP.EQ.2*((J+NISIMP)/2))THEN 98 - SUM=SUM+2*DIVDF2(SIG,TIME,MSIG,TSIMP,KIORD) 99 - ELSE 100 - SUM=SUM+4*DIVDF2(SIG,TIME,MSIG,TSIMP,KIORD) 101 - ENDIF 102 - 20 CONTINUE 103 - ENDIF 0 104-+ +SELF,IF=ESSL. 105 - IF(NISIMP.LE.0)THEN 106 - TVEC(0)=TINT 107 - CALL DTPINT(TIME,SIG,MSIG,JIORD+1, 108 - - TVEC(0),SVEC(0),1,AUX,MXLIST+2*MXSIMP+1) 109 - SUM=SVEC(0) 110 - ELSE 111 - DO 20 J=-NISIMP,NISIMP 112 - TVEC(J)=TIMIN+DBLE(J+NISIMP)*(TIMAX-TIMIN)/DBLE(2*NISIMP) 113 - 20 CONTINUE 114 - CALL DTPINT(TIME,SIG,MSIG,KIORD+1, 115 - - TVEC(-NISIMP),SVEC(-NISIMP),2*NISIMP+1, 116 - - AUX,MXLIST+2*MXSIMP+1) 117 - DO 30 J=-NISIMP,NISIMP 118 - IF(J.EQ.-NISIMP)THEN 1 730 P=SIGNAL D=SIGADD 3 PAGE1131 119 - SUM=SVEC(J) 120 - ELSEIF(J.EQ.NISIMP)THEN 121 - SUM=SUM+SVEC(J) 122 - ELSEIF(J+NISIMP.EQ.2*((J+NISIMP)/2))THEN 123 - SUM=SUM+2*SVEC(J) 124 - ELSE 125 - SUM=SUM+4*SVEC(J) 126 - ENDIF 127 - 30 CONTINUE 128 - ENDIF 0 129-+ +SELF. 130 - * Normalise the integral if Simpson-Raphson was used. 131 - IF(NISIMP.GT.0)SUM=SUM*(TIMAX-TIMIN)/(6*NISIMP*TDEV) 132 - * Add the result to the signal. 133 - IF(CROSS)THEN 134 - SIGNAL(I,ISW,2)=SIGNAL(I,ISW,2)-ECHARG*1E12*Q*SUM 135 - ELSE 136 - SIGNAL(I,ISW,1)=SIGNAL(I,ISW,1)-ECHARG*1E12*Q*SUM 137 - ENDIF 138 - 10 CONTINUE 139 - *** Seems to have worked since we got here. 140 - IFAIL=0 141 - END 731 GARFIELD ================================================== P=SIGNAL D=SIGADS 1 ============================ 0 + +DECK,SIGADS. 1 - SUBROUTINE SIGADS(CROSS,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGADS - Adds the signals induced by the current drift line. 4 - * (Last changed on 6/ 1/01.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,DRIFTLINE. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,SIGNALDATA. 12.- +SEQ,CONSTANTS. 13 - LOGICAL CROSS 14 - INTEGER ISW,JSW,IU,ILOC,ILOCRS,IFAIL,IFAIL1 15 - REAL EX,EY,EZ,DRES 16 - DOUBLE PRECISION VDRIFT(3),TIME(MXLIST),SIG(MXLIST) 17 - *** Identification. 18 - IF(LIDENT)PRINT *,' /// ROUTINE SIGADS ///' 19 - *** Assume the procedure will fail. 20 - IFAIL=1 21 - *** Ensure there is a drift line. 22 - IF(ISTAT.EQ.0)THEN 23 - PRINT *,' !!!!!! SIGADS WARNING : The current drift'// 24 - - ' line has no steps; no signals computed.' 25 - RETURN 26 - ELSEIF(IPTYPE.NE.1.AND.IPTYPE.NE.2)THEN 27 - PRINT *,' !!!!!! SIGADS WARNING : Current drift line is'// 28 - - ' neither for an e- nor an ion; no signals computed.' 29 - RETURN 30 - ELSEIF(ABS(QPCHAR).LT.0.1)THEN 31 - PRINT *,' !!!!!! SIGADS WARNING : Current drift line is'// 32 - - ' for an uncharged particle; no signals computed.' 33 - RETURN 34 - ENDIF 35 - *** Make sure the time resolution has been set. 36 - IF(.NOT.RESSET)THEN 37 - PRINT *,' !!!!!! SIGADS WARNING : The time resolution has'// 38 - - ' not yet been set; no signals computed.' 39 - RETURN 40 - ENDIF 41 - *** Obtain the sense wire number. 42 - CALL DLCISW(ISTAT,ISW) 43 - * Cheat in case the point is located inside a wire. 44 - IF(ISTAT.GT.0)THEN 45 - ILOCRS=MOD(ISTAT,MXWIRE) 46 - DRES=D(ILOCRS) 47 - ELSE 48 - ILOCRS=0 49 - DRES=0 50 - ENDIF 51 - IF(ILOCRS.GT.0)D(ILOCRS)=DRES/2 52 - ** Cross induction: loop over all sense wires. 53 - IF(CROSS)THEN 54 - * Loop over the sense wires. 55 - DO 10 JSW=1,NSW 56 - * Compute contribution of the current drift line to the signal 57 - DO 20 IU=1,NU 58 - CALL SIGFLS(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 59 - - EX,EY,EZ,JSW) 60 - CALL DLCVEL(XU(IU),YU(IU),ZU(IU),VDRIFT,QPCHAR,IPTYPE,ILOC) 61 - SIG(IU)=(VDRIFT(1)*EX+VDRIFT(2)*EY+VDRIFT(3)*EZ) 62 - TIME(IU)=TU(IU) 63 - 20 CONTINUE 64 - * Add this current to the total. 65 - CALL SIGADD(JSW,ISW.NE.JSW,NU,TIME,SIG,QPCHAR,0.0,0.0, 66 - - IFAIL1) 67 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! SIGADS WARNING : Adding'// 68 - - ' the computed signal failed; signal incomplete.' 69 - * Finish loop over the sense wires, 70 - 10 CONTINUE 71 - * Make sure we will know cross induced signals have been computed. 72 - LCROSS=.TRUE. 73 - ** Otherwise do not do the loop. 74 - ELSEIF(ISW.NE.0)THEN 75 - * Compute contribution of the current drift line to the signal 76 - DO 30 IU=1,NU 77 - CALL SIGFLS(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 78 - - EX,EY,EZ,ISW) 1 731 P=SIGNAL D=SIGADS 2 PAGE1132 79 - CALL DLCVEL(XU(IU),YU(IU),ZU(IU),VDRIFT,QPCHAR,IPTYPE,ILOC) 80 - SIG(IU)=(VDRIFT(1)*EX+VDRIFT(2)*EY+VDRIFT(3)*EZ) 81 - TIME(IU)=TU(IU) 82 - 30 CONTINUE 83 - * Add this current to the total. 84 - CALL SIGADD(ISW,.FALSE.,NU,TIME,SIG,QPCHAR,0.0,0.0,IFAIL1) 85 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! SIGADS WARNING : Adding'// 86 - - ' the computed signal failed; signal incomplete.' 87 - * Make sure we will know cross induced signals have not been computed. 88 - LCROSS=.FALSE. 89 - ENDIF 90 - *** Restore the wire diameter. 91 - IF(ILOCRS.GT.0)D(ILOCRS)=DRES 92 - *** Things seem to have worked. 93 - IFAIL=0 94 - END 732 GARFIELD ================================================== P=SIGNAL D=SIGAVA 1 ============================ 0 + +DECK,SIGAVA. 1 - SUBROUTINE SIGAVA(QCL,ACL) 2 - *----------------------------------------------------------------------- 3 - * SIGAVA - Returns a random number for the cluster size. 4 - * (Last changed on 31/10/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,SIGNALDATA. 9 - REAL QCL,ACL,RNDEXP,RNDNOR,RNDPOL 10 - EXTERNAL RNDEXP,RNDNOR,RNDPOL 11 - *** Exponential type. 12 - IF(AVATYP.EQ.'EXPONENTIAL')THEN 13 - QCL=RNDEXP(AVALAN(1)) 14 - *** Fixed factor. 15 - ELSEIF(AVATYP.EQ.'FIXED')THEN 16 - QCL=AVALAN(1) 17 - *** Gaussian distribution. 18 - ELSEIF(AVATYP.EQ.'GAUSSIAN')THEN 19 - QCL=RNDNOR(AVALAN(1),AVALAN(1)*AVALAN(2)) 20 - *** Townsend based exponential distribution. 21 - ELSEIF(AVATYP.EQ.'TOWNSEND')THEN 22 - QCL=RNDEXP(ACL) 23 - *** Townsend without fluctuations. 24 - ELSEIF(AVATYP.EQ.'TOWN-FIXED')THEN 25 - QCL=ACL 26 - *** Polya distributed with fixed mean. 27 - ELSEIF(AVATYP.EQ.'POLYA-FIXED')THEN 28 - QCL=AVALAN(1)*RNDPOL(AVALAN(2)) 29 - *** Polya distributed with Townsend mean. 30 - ELSEIF(AVATYP.EQ.'POLYA-TOWN')THEN 31 - QCL=ACL*RNDPOL(AVALAN(1)) 32 - *** Anything else not known, take the (hopefully meanigful) default. 33 - ELSE 34 - PRINT *,' !!!!!! SIGAVA WARNING : Unknown avalanche type'// 35 - - ' received: '//AVATYP//'; program bug, please report.' 36 - QCL=AVALAN(1) 37 - ENDIF 38 - *** Never accept a multiplication smaller than 1. 39 - IF(QCL.LT.1.0)QCL=1.0 40 - END 733 GARFIELD ================================================== P=SIGNAL D=SIGION 1 ============================ 0 + +DECK,SIGION. 1 - SUBROUTINE SIGION(ISW,IW,ANGLE,NSIG,TIME,SIG,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGION - Routine computing the ion tail on sense wire ISW due to an 4 - * ion drifting at angle ANGLE from wire IW. 5 - * VARIABLES : VDRIFT : Vector storing the drift velocities. 6 - * TIME,SIG : Time and currents of the induced signal. 7 - * (Last changed on 28/ 4/99.) 8 - *----------------------------------------------------------------------- 9 - implicit none 10.- +SEQ,DIMENSIONS. 11.- +SEQ,PARAMETERS. 12.- +SEQ,CONSTANTS. 13.- +SEQ,CELLDATA. 14.- +SEQ,GASDATA. 15.- +SEQ,DRIFTLINE. 16.- +SEQ,SIGNALDATA. 17.- +SEQ,PRINTPLOT. 18 - DOUBLE PRECISION VDRIFT(3,MXLIST),TIME(*),SIG(*) 19 - INTEGER ISW,IW,IA,IQ,NSIG,IFAIL,IFAIL1,ITYPE,ILOC,I,JSW 20 - REAL ANGLE,Q,DRES,EX,EY,EZ 21 - *** Identify the routine 22 - IF(LIDENT)PRINT *,' /// ROUTINE SIGION ///' 23 - *** Assume that this will fail. 24 - IFAIL=1 25 - *** Verify the sense wire and wire number. 26 - IF(IW.LE.0.OR.NWIRE.GT.NWIRE.OR.ISW.LE.0.OR.ISW.GT.NSW)THEN 27 - PRINT *,' !!!!!! SIGION WARNING : Invalid wire or sense'// 28 - - ' wire number received ; no ion tail computed.' 29 - RETURN 30 - ENDIF 31 - *** Transform the angle into an angular bin. 32 - IA=NINT(NORIA*MOD(ANGLE-2*PI*ANINT(ANGLE/(2*PI))+2*PI, 33 - - 2*PI)/(2*PI)) 34 - IF(IA.EQ.0)IA=NORIA 35 - *** Set charge and part. type and reset the signals if change is .TRUE. 36 - Q=+1.0 37 - IQ=+1 38 - ITYPE=2 39 - *** See whether the signal is already in store. 40 - CALL SIGIST('READ',NSIG,TIME,SIG,ISW,IW,IA,IQ,IFAIL1) 41 - * Check that there was no storage error. 42 - IF(IFAIL1.NE.0)THEN 1 733 P=SIGNAL D=SIGION 2 PAGE1133 43 - PRINT *,' !!!!!! SIGION WARNING : Signal store error;'// 44 - - ' no ion tail calculated.' 45 - NSIG=0 46 - IFAIL=1 47 - RETURN 48 - * If it was in store, simply return it, otherwise compute the signals. 49 - ELSEIF(NSIG.GE.0)THEN 50 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGION DEBUG :'', 51 - - '' Signal for ISW/IW/IA/IQ='',4I5,'' was in store.'')') 52 - - ISW,IW,IA,IQ 53 - IFAIL=0 54 - RETURN 55 - ENDIF 56 - *** Compute ion drift line, first backup the current drift line. 57 - CALL DLCBCK('SAVE') 58 - * Make wire radius smaller to avoid trap. 59 - DRES=D(IW) 60 - D(IW)=0.25*D(IW)/RTRAP 61 - * Compute the ion drift line. 62 - CALL DLCALC(X(IW)+0.5*DRES*COS(ANGLE),Y(IW)+0.5*DRES*SIN(ANGLE), 63 - - 0.0,Q,ITYPE) 64 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGION DEBUG : Wire='',I4, 65 - - '', Angle='',E12.5,'' NU='',I4,'' ISTAT='',I5)') 66 - - IW,ANGLE,NU,ISTAT 67 - * Compute drift velocity. 68 - DO 50 I=1,NU 69 - CALL DLCVEL(XU(I),YU(I),ZU(I),VDRIFT(1,I),Q,ITYPE,ILOC) 70 - 50 CONTINUE 71 - * Restore the wire radius. 72 - D(IW)=DRES 73 - * Issue a warning if there is only one point. 74 - IF(NU.LE.2)THEN 75 - NSIG=0 76 - TIME(1)=0 77 - SIG(1)=0 78 - PRINT *,' !!!!!! SIGION WARNING : Zero-length ion drift'// 79 - - ' line from wire ',IW,' at angle ',ANGLE 80 - CALL SIGIST('STORE',NSIG,TIME,SIG,ISW,IW,IA,IQ,IFAIL1) 81 - IFAIL=1 82 - CALL DLCBCK('RESTORE') 83 - RETURN 84 - ENDIF 85 - *** Compute ion signal on all electrodes, but ... 86 - DO 80 JSW=1,NSW 87 - * ... save time if cross induction has not been requested. 88 - IF((.NOT.LCROSS).AND.(ISW.NE.JSW))GOTO 80 89 - * Compute contribution of the current drift line to the signal 90 - DO 90 I=1,NU 91 - CALL SIGFLS(REAL(XU(I)),REAL(YU(I)),REAL(ZU(I)),EX,EY,EZ,JSW) 92 - TIME(I)=TU(I) 93 - SIG(I)=VDRIFT(1,I)*EX+VDRIFT(2,I)*EY+VDRIFT(3,I)*EZ 94 - 90 CONTINUE 95 - * Store this signal. 96 - CALL SIGIST('STORE',NU,TIME,SIG,JSW,IW,IA,IQ,IFAIL1) 97 - IF(IFAIL1.NE.0)THEN 98 - PRINT *,' !!!!!! SIGION WARNING : Error storing an ion'// 99 - - ' tail; no ion tail returned.' 100 - NSIG=0 101 - IFAIL=1 102 - CALL DLCBCK('RESTORE') 103 - RETURN 104 - ENDIF 105 - * Finish loop over the sense wires, 106 - 80 CONTINUE 107 - *** Plot the drift line if this has been requested. 108 - IF(LCLPLT)CALL DLCPLT 109 - *** Restore the drift line that was in memory. 110 - CALL DLCBCK('RESTORE') 111 - *** Retrieve the signal we were asked for in the first place. 112 - CALL SIGIST('READ',NSIG,TIME,SIG,ISW,IW,IA,IQ,IFAIL1) 113 - IF(IFAIL1.NE.0)THEN 114 - PRINT *,' !!!!!! SIGION WARNING : Error retrieving'// 115 - - ' a computed ion tail; program bus - please report.' 116 - NSIG=0 117 - IFAIL=1 118 - RETURN 119 - ENDIF 120 - *** Seems to have worked correctly. 121 - IFAIL=0 122 - END 734 GARFIELD ================================================== P=SIGNAL D=SIGIOR 1 ============================ 0 + +DECK,SIGIOR. 1 - SUBROUTINE SIGIOR(ISW,XORIG,YORIG,ZORIG,NSIG,TIME,SIG,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGIOR - Routine computing the ion tail on sense wire ISW due to an 4 - * ion drifting from (XORIG,YORIG,ZORIG). 5 - * VARIABLES : VDRIFT : Vector storing the drift velocities. 6 - * TIME,SIG : Time and currents of the induced signal. 7 - * (Last changed on 16/11/99.) 8 - *----------------------------------------------------------------------- 9 - implicit none 10.- +SEQ,DIMENSIONS. 11.- +SEQ,PARAMETERS. 12.- +SEQ,CONSTANTS. 13.- +SEQ,CELLDATA. 14.- +SEQ,FIELDMAP. 15.- +SEQ,GASDATA. 16.- +SEQ,DRIFTLINE. 17.- +SEQ,SIGNALDATA. 18.- +SEQ,PRINTPLOT. 19 - DOUBLE PRECISION VDRIFT(3),TIME(*),SIG(*) 20 - INTEGER IW,ISW,IQ,NSIG,IFAIL,ITYPE,ILOC,I 21 - REAL Q,EX,EY,EZ,XORIG,YORIG,ZORIG,DRES 22 - *** Identify the routine 1 734 P=SIGNAL D=SIGIOR 2 PAGE1134 23 - IF(LIDENT)PRINT *,' /// ROUTINE SIGIOR ///' 24 - *** Assume that this will fail. 25 - IFAIL=1 26 - *** See whether we start from a wire. 27 - IF(ICLUST.GE.1.AND.ICLUST.LE.NWIRE)THEN 28 - IW=ICLUST 29 - ELSE 30 - IW=0 31 - ENDIF 32 - *** Tempotrarily reduce the wire diameter to avoid trap. 33 - IF(IW.GT.0)THEN 34 - DRES=D(IW) 35 - D(IW)=0.25*D(IW)/RTRAP 36 - ENDIF 37 - *** Set charge and part. type and reset the signals if change is .TRUE. 38 - Q=+1.0 39 - IQ=+1 40 - ITYPE=2 41 - *** Make a backup of the drift line. 42 - CALL DLCBCK('SAVE') 43 - *** Compute the ion drift line. 44 - CALL DLCALC(XORIG,YORIG,ZORIG,Q,ITYPE) 45 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIOR DEBUG : Origin =('', 46 - - 3E12.5,'') NU='',I4,'' ISTAT='',I5)') XORIG,YORIG,ZORIG, 47 - - NU,ISTAT 48 - *** Compute contribution of the current drift line to the signal 49 - NSIG=NU 50 - DO 70 I=1,NU 51 - CALL DLCVEL(XU(I),YU(I),ZU(I),VDRIFT,Q,ITYPE,ILOC) 52 - CALL SIGFLS(REAL(XU(I)),REAL(YU(I)),REAL(ZU(I)),EX,EY,EZ,ISW) 53 - SIG(I)=VDRIFT(1)*EX+VDRIFT(2)*EY+VDRIFT(3)*EZ 54 - TIME(I)=TU(I) 55 - 70 CONTINUE 56 - *** Restore the wire diameter. 57 - IF(IW.GT.0)D(IW)=DRES 58 - *** Plot the drift line if this has been requested. 59 - IF(LCLPLT)CALL DLCPLT 60 - *** Restore the drift line that was in memory. 61 - CALL DLCBCK('RESTORE') 62 - *** Seems to have worked correctly. 63 - IFAIL=0 64 - END 735 GARFIELD ================================================== P=SIGNAL D=SIGIST 1 ============================ 0 + +DECK,SIGIST,IF=MEMORY. 1 - SUBROUTINE SIGIST(ACTION,NSIG,TIME,SIG,ISW,IW,IA,IQ,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGIST - Routine keeping the various ion signals in a scratch file. 4 - * (Last changed on 24/ 2/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PRINTPLOT. 9.- +SEQ,SIGNALDATA. 10 - INTEGER MXIREC 11 - PARAMETER(MXIREC=250) 12 - DOUBLE PRECISION SIG(*),TIME(*), 13 - - SVEC(MXLIST,MXIREC),TVEC(MXLIST,MXIREC) 14 - INTEGER IADREF(MXIREC),NVEC(MXIREC),NREF,ISTATE,IFAIL,NSIG, 15 - - NUSED(MXIREC),IAGE(MXIREC),ILEAST,IA,IW,ISW,IQ,IREC,I, 16 - - IADDR,ISTORE 17 - CHARACTER*(*) ACTION 0 18-+ +SELF,IF=SAVE. 19 - SAVE IADREF,NREF,ISTATE,SVEC,TVEC,NVEC,NUSED,IAGE,ISTORE 0 20-+ +SELF. 21 - DATA NREF/0/, ISTATE/0/, ISTORE/0/ 22 - *** Identify the routine if required. 23 - IF(LIDENT)PRINT *,' /// ROUTINE SIGIST (Memory) ///' 24 - *** Assume the operation will fail. 25 - IFAIL=1 26 - *** Prepare the memory. 27 - IF(ACTION.EQ.'OPEN')THEN 28 - ISTATE=1 29 - NREF=0 30 - IFAIL=0 31 - ISTORE=0 32 - *** Reset memory. 33 - ELSEIF(ACTION.EQ.'RESET')THEN 34 - IF(ISTATE.EQ.0)THEN 35 - PRINT *,' !!!!!! SIGIST WARNING : No signal memory'// 36 - - ' currently active; not reset.' 37 - ELSE 38 - NREF=0 39 - IFAIL=0 40 - ISTORE=0 41 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', 42 - - '' Signal memory reset.'')') 43 - ENDIF 44 - *** Store a record. 45 - ELSEIF(ACTION.EQ.'STORE')THEN 46 - * Check the state of the file. 47 - IF(ISTATE.NE.1)THEN 48 - PRINT *,' !!!!!! SIGIST WARNING : Request to store'// 49 - - ' but signal memory not open; not stored.' 50 - RETURN 51 - ENDIF 52 - * Check address range validity. 53 - IF((IA.LT.1.OR.IA.GT.NORIA).OR. 54 - - (ISW.LT.1.OR.ISW.GT.MXSW).OR. 55 - - (IW.LT.1.OR.IW.GT.MXWIRE).OR. 56 - - ABS(IQ).NE.1)THEN 57 - PRINT *,' !!!!!! SIGIST WARNING : Signal address'// 58 - - ' out of range; not stored.' 1 735 P=SIGNAL D=SIGIST 2 PAGE1135 59 - RETURN 60 - ENDIF 61 - * Compute reference address. 62 - IADDR=IQ*(IA+MXORIA*(ISW-1+MXSW*(IW-1))) 63 - * Locate the reference in the tables. 64 - ILEAST=1 65 - DO 10 I=1,NREF 66 - IF(NUSED(I).LT.NUSED(ILEAST).OR. 67 - - (NUSED(I).EQ.NUSED(ILEAST).AND. 68 - - IAGE(I).LT.IAGE(ILEAST)))ILEAST=I 69 - IF(IADREF(I).EQ.IADDR)THEN 70 - IREC=I 71 - GOTO 20 72 - ENDIF 73 - 10 CONTINUE 74 - * New record, allocate space. 75 - IF(NREF.LT.MXIREC)THEN 76 - NREF=NREF+1 77 - IADREF(NREF)=IADDR 78 - IREC=NREF 79 - * Or re-use least used record. 80 - ELSE 81 - IREC=ILEAST 82 - IADREF(IREC)=IADDR 83 - ENDIF 84 - * In either case set the usage counter to 0. 85 - NUSED(IREC)=0 86 - * Store the record. 87 - 20 CONTINUE 88 - DO 25 I=1,NSIG 89 - TVEC(I,IREC)=TIME(I) 90 - SVEC(I,IREC)=SIG(I) 91 - 25 CONTINUE 92 - NVEC(IREC)=NSIG 93 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', 94 - - '' Stored record '',I6,'' for reference '',I6)') 95 - - IREC,IADDR 96 - * And keep track of the age. 97 - ISTORE=ISTORE+1 98 - IAGE(IREC)=ISTORE 99 - * Seems to have worked. 100 - IFAIL=0 101 - *** Retrieve a record. 102 - ELSEIF(ACTION.EQ.'READ')THEN 103 - * Check the state of the file. 104 - IF(ISTATE.NE.1)THEN 105 - PRINT *,' !!!!!! SIGIST WARNING : Request to read'// 106 - - ' but signal file not open; not read.' 107 - RETURN 108 - ENDIF 109 - * Check address range validity. 110 - IF((IA.LT.1.OR.IA.GT.NORIA).OR. 111 - - (ISW.LT.1.OR.ISW.GT.MXSW).OR. 112 - - (IW.LT.1.OR.IW.GT.MXWIRE).OR. 113 - - ABS(IQ).NE.1)THEN 114 - PRINT *,' !!!!!! SIGIST WARNING : Signal address'// 115 - - ' out of range; not read.' 116 - RETURN 117 - ENDIF 118 - * Compute reference address. 119 - IADDR=IQ*(IA+MXORIA*(ISW-1+MXSW*(IW-1))) 120 - * Locate the reference in the tables. 121 - DO 30 I=1,NREF 122 - IF(IADREF(I).EQ.IADDR)THEN 123 - IREC=I 124 - GOTO 40 125 - ENDIF 126 - 30 CONTINUE 127 - * Unknown record, signal this via NSIG. 128 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', 129 - - '' Record '',4I4,'' not known.'')') ISW,IW,IA,IQ 130 - NSIG=-1 131 - IFAIL=0 132 - RETURN 133 - * Read the record. 134 - 40 CONTINUE 135 - NSIG=NVEC(IREC) 136 - DO 45 I=1,NSIG 137 - TIME(I)=TVEC(I,IREC) 138 - SIG(I)=SVEC(I,IREC) 139 - 45 CONTINUE 140 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', 141 - - '' Read record '',I6,'' for reference '',I6)') 142 - - IREC,IADDR 143 - * Increment the usage counter. 144 - NUSED(IREC)=NUSED(IREC)+1 145 - * Seems to have worked. 146 - IFAIL=0 147 - *** List currently known records. 148 - ELSEIF(ACTION.EQ.'LIST')THEN 149 - * Print a header. 150 - WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG : Overview of'', 151 - - '' currently known records:''//'' Record Angle'', 152 - - '' Wire Sense Charge Usage Birth''/)') 153 - * Loop over the records. 154 - DO 50 I=1,NREF 155 - IADDR=IADREF(I) 156 - IQ=SIGN(1,IADDR) 157 - IADDR=ABS(IADDR) 158 - IA=MOD(IADDR,MXORIA) 159 - IF(IA.EQ.0)IA=MXORIA 160 - IADDR=(IADDR-IA)/MXORIA 161 - ISW=MOD(IADDR,MXSW)+1 162 - IF(ISW.EQ.0)ISW=MXSW 163 - IW=(IADDR-ISW+1)/MXSW+1 164 - WRITE(LUNOUT,'(5(2X,I6))') I,IA,IW,ISW,IQ,NUSED(I),IAGE(I) 1 735 P=SIGNAL D=SIGIST 3 PAGE1136 165 - 50 CONTINUE 166 - * Overview. 167 - WRITE(LUNOUT,'(/'' Total of '',I6,'' records.'')') NREF 168 - * This can not fail. 169 - IFAIL=0 170 - *** Close the memory. 171 - ELSEIF(ACTION.EQ.'CLOSE')THEN 172 - ISTATE=0 173 - NREF=0 174 - IFAIL=0 175 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', 176 - - '' Closed signal memory.'')') 177 - *** Other actions are not known. 178 - ELSE 179 - PRINT *,' !!!!!! SIGIST WARNING : Action not known;'// 180 - - ' nothing done.' 181 - ENDIF 182 - END 736 GARFIELD ================================================== P=SIGNAL D=SIGIST 1 ============================ 0 + +DECK,SIGIST,IF=-MEMORY. 1 - SUBROUTINE SIGIST(ACTION,NSIG,TIME,SIG,ISW,IW,IA,IQ,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGIST - Routine keeping the various ion signals in a scratch file. 4 - * (Last changed on 24/ 2/97.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,SIGNALDATA. 9.- +SEQ,PRINTPLOT. 10 - INTEGER LUNIST,MXIREC 11 - PARAMETER(MXIREC=1000,LUNIST=14) 12 - DOUBLE PRECISION SIG(*),TIME(*) 13 - INTEGER IADREF(MXIREC),NREF,ISTATE,IFAIL,NSIG,NVEC(MXIREC), 14 - - ISW,IW,IA,IQ,NUSED(MXIREC),ILEAST,IREC,I, 15 - - ISTORE,IAGE(MXIREC),IADDR,IOS 16 - LOGICAL OPEN 17 - CHARACTER*(*) ACTION 0 18-+ +SELF,IF=SAVE. 19 - SAVE IADREF,NREF,ISTATE,NVEC,NUSED,ISTORE,IAGE 0 20-+ +SELF. 21 - DATA NREF/0/, ISTATE/0/, ISTORE/0/ 22 - *** Identify the routine if required. 23 - IF(LIDENT)PRINT *,' /// ROUTINE SIGIST (File) ///' 24 - *** Assume the operation will fail. 25 - IFAIL=1 26 - *** Open the scratch file. 27 - IF(ACTION.EQ.'OPEN')THEN 28 - * Check that the file is not already open. 29 - INQUIRE(UNIT=LUNIST,OPENED=OPEN) 30 - * Close if it is. 31 - IF(OPEN)THEN 32 - PRINT *,' !!!!!! SIGIST WARNING : Ion signal unit'// 33 - - ' unexpectedly open; closed.' 34 - CLOSE(UNIT=LUNIST,ERR=2030,IOSTAT=IOS) 35 - ENDIF 36 - * Open the file. 0 37-+ +SELF,IF=VAX. 38 - OPEN(UNIT=LUNIST,STATUS='SCRATCH',ACCESS='DIRECT', 39 - - FORM='UNFORMATTED',ERR=2020,RECL=4*MXLIST, 40 - - MAXREC=MXIREC,IOSTAT=IOS) 0 41-+ +SELF,IF=CMS. 42 - CALL FILEINF(IRC,'MAXREC',MXIREC) 43 - OPEN(UNIT=LUNIST,STATUS='SCRATCH',ACCESS='DIRECT', 44 - - FORM='UNFORMATTED',ERR=2020,RECL=16*MXLIST, 45 - - IOSTAT=IOS) 0 46-+ +SELF,IF=-VAX,IF=-CMS. 47 - OPEN(UNIT=LUNIST,STATUS='SCRATCH',ACCESS='DIRECT', 48 - - FORM='UNFORMATTED',ERR=2020,RECL=16*MXLIST, 49 - - IOSTAT=IOS) 0 50-+ +SELF. 51 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', 52 - - '' Signal file opened on unit '',I6)') LUNIST 53 - * Keep track of this. 54 - ISTATE=1 55 - NREF=0 56 - * Reset the number of stores. 57 - ISTORE=0 58 - * Seems to have worked. 59 - IFAIL=0 60 - *** Reset the file. 61 - ELSEIF(ACTION.EQ.'RESET')THEN 62 - IF(ISTATE.EQ.0)THEN 63 - PRINT *,' !!!!!! SIGIST WARNING : No signal file'// 64 - - ' currently active; not reset.' 65 - ELSE 66 - NREF=0 67 - IFAIL=0 68 - ISTORE=0 69 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', 70 - - '' Signal file reset on unit '',I6)') LUNIST 71 - ENDIF 72 - *** Store a record. 73 - ELSEIF(ACTION.EQ.'STORE')THEN 74 - * Check the state of the file. 75 - IF(ISTATE.NE.1)THEN 76 - PRINT *,' !!!!!! SIGIST WARNING : Request to store'// 77 - - ' but signal file not open; not stored.' 78 - RETURN 1 736 P=SIGNAL D=SIGIST 2 PAGE1137 79 - ENDIF 80 - * Check address range validity. 81 - IF((IA.LT.1.OR.IA.GT.NORIA).OR. 82 - - (ISW.LT.1.OR.ISW.GT.MXSW).OR. 83 - - (IW.LT.1.OR.IW.GT.MXWIRE).OR. 84 - - ABS(IQ).NE.1)THEN 85 - PRINT *,' !!!!!! SIGIST WARNING : Signal address'// 86 - - ' out of range; not stored.' 87 - RETURN 88 - ENDIF 89 - * Compute reference address. 90 - IADDR=IQ*(IA+MXORIA*(ISW-1+MXSW*(IW-1))) 91 - * Locate the reference in the tables and also the least used record. 92 - ILEAST=1 93 - DO 10 I=1,NREF 94 - IF(NUSED(I).LT.NUSED(ILEAST).OR. 95 - - (NUSED(I).EQ.NUSED(ILEAST).AND. 96 - - IAGE(I).LT.IAGE(ILEAST)))ILEAST=I 97 - IF(IADREF(I).EQ.IADDR)THEN 98 - IREC=I 99 - GOTO 20 100 - ENDIF 101 - 10 CONTINUE 102 - * New record, allocate space. 103 - IF(NREF.LT.MXIREC)THEN 104 - NREF=NREF+1 105 - IADREF(NREF)=IADDR 106 - IREC=NREF 107 - * Or reuse the least used record sofar. 108 - ELSE 109 - IREC=ILEAST 110 - IADREF(IREC)=IADDR 111 - ENDIF 112 - * In either case set the usage counter to 0. 113 - NUSED(IREC)=0 114 - * Write the record. 115 - 20 CONTINUE 116 - NVEC(IREC)=NSIG 117 - WRITE(UNIT=LUNIST,REC=IREC,ERR=2010,IOSTAT=IOS) 118 - - (TIME(I),I=1,NSIG),(SIG(I),I=1,NSIG) 119 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', 120 - - '' Stored record '',I6,'' for reference '',I6)') 121 - - IREC,IADDR 122 - * And keep track of the age. 123 - ISTORE=ISTORE+1 124 - IAGE(IREC)=ISTORE 125 - * Seems to have worked. 126 - IFAIL=0 127 - *** Retrieve a record. 128 - ELSEIF(ACTION.EQ.'READ')THEN 129 - * Check the state of the file. 130 - IF(ISTATE.NE.1)THEN 131 - PRINT *,' !!!!!! SIGIST WARNING : Request to read'// 132 - - ' but signal file not open; not read.' 133 - RETURN 134 - ENDIF 135 - * Check address range validity. 136 - IF((IA.LT.1.OR.IA.GT.NORIA).OR. 137 - - (ISW.LT.1.OR.ISW.GT.MXSW).OR. 138 - - (IW.LT.1.OR.IW.GT.MXWIRE).OR. 139 - - ABS(IQ).NE.1)THEN 140 - PRINT *,' !!!!!! SIGIST WARNING : Signal address'// 141 - - ' out of range; not read.' 142 - RETURN 143 - ENDIF 144 - * Compute reference address. 145 - IADDR=IQ*(IA+MXORIA*(ISW-1+MXSW*(IW-1))) 146 - * Locate the reference in the tables. 147 - DO 30 I=1,NREF 148 - IF(IADREF(I).EQ.IADDR)THEN 149 - IREC=I 150 - GOTO 40 151 - ENDIF 152 - 30 CONTINUE 153 - * Unknown record, signal this via NSIG. 154 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', 155 - - '' Record '',4I4,'' not known.'')') ISW,IW,IA,IQ 156 - NSIG=-1 157 - IFAIL=0 158 - RETURN 159 - * Read the record. 160 - 40 CONTINUE 161 - NSIG=NVEC(IREC) 162 - READ(UNIT=LUNIST,REC=IREC,ERR=2010,IOSTAT=IOS) 163 - - (TIME(I),I=1,NSIG),(SIG(I),I=1,NSIG) 164 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', 165 - - '' Read record '',I6,'' for reference '',I6)') 166 - - IREC,IADDR 167 - * Increment the usage counter. 168 - NUSED(IREC)=NUSED(IREC)+1 169 - * Seems to have worked. 170 - IFAIL=0 171 - *** List currently known records. 172 - ELSEIF(ACTION.EQ.'LIST')THEN 173 - * Print a header. 174 - WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG : Overview of'', 175 - - '' currently known records:''//'' Record Angle'', 176 - - '' Wire Sense Charge Usage Birth''/)') 177 - * Loop over the records. 178 - DO 50 I=1,NREF 179 - IADDR=IADREF(I) 180 - IQ=SIGN(1,IADDR) 181 - IADDR=ABS(IADDR) 182 - IA=MOD(IADDR,MXORIA) 183 - IF(IA.EQ.0)IA=MXORIA 184 - IADDR=(IADDR-IA)/MXORIA 1 736 P=SIGNAL D=SIGIST 3 PAGE1138 185 - ISW=MOD(IADDR,MXSW)+1 186 - IF(ISW.EQ.0)ISW=MXSW 187 - IW=(IADDR-ISW+1)/MXSW+1 188 - WRITE(LUNOUT,'(5(2X,I6))') I,IA,IW,ISW,IQ,NUSED(I),IAGE(I) 189 - 50 CONTINUE 190 - * Overview. 191 - WRITE(LUNOUT,'(/'' Total of '',I6,'' records.'')') NREF 192 - * This can not fail. 193 - IFAIL=0 194 - *** Close the file. 195 - ELSEIF(ACTION.EQ.'CLOSE')THEN 196 - * Check that the file is indeed open. 197 - INQUIRE(UNIT=LUNIST,OPENED=OPEN) 198 - * Close if open. 199 - IF(.NOT.OPEN)THEN 200 - PRINT *,' !!!!!! SIGIST WARNING : Ion signal unit'// 201 - - ' is already closed; not closed again.' 202 - ELSE 203 - CLOSE(UNIT=LUNIST,ERR=2030,IOSTAT=IOS) 204 - ENDIF 205 - * Keep track of the state. 206 - ISTATE=0 207 - NREF=0 208 - * Seems to have worked. 209 - IFAIL=0 210 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', 211 - - '' Closed signal unit '',I6)') LUNIST 212 - *** Other actions are not known. 213 - ELSE 214 - PRINT *,' !!!!!! SIGIST WARNING : Action not known;'// 215 - - ' nothing done.' 216 - ENDIF 217 - *** I/O error handling. 218 - RETURN 219 - 2010 CONTINUE 220 - PRINT *,' !!!!!! SIGIST WARNING : Read/write error to'// 221 - - ' signal file ; action not completed.' 222 - CALL INPIOS(IOS) 223 - RETURN 224 - 2020 CONTINUE 225 - PRINT *,' !!!!!! SIGIST WARNING : Open error on'// 226 - - ' signal file ; action not completed.' 227 - CALL INPIOS(IOS) 228 - RETURN 229 - 2030 CONTINUE 230 - PRINT *,' !!!!!! SIGIST WARNING : Close error on'// 231 - - ' signal file ; action not completed.' 232 - CALL INPIOS(IOS) 233 - END 737 GARFIELD ================================================== P=SIGNAL D=SIGFLD 1 ============================ 0 + +DECK,SIGFLD. 1 - SUBROUTINE SIGFLD(XPOS,YPOS,ZPOS,EX,EY,EZ,MX,MY,IW) 2 - *----------------------------------------------------------------------- 3 - * SIGFLD - Routine redirecting the calls for reduced periodicity field 4 - * vectors. 5 - * (Last changed on 4/11/97.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,SIGNALDATA. 10 - REAL XPOS,YPOS,ZPOS,EX,EY,EZ 11 - INTEGER IW,MX,MY 12 - *** Initial settings. 13 - EX=0 14 - EY=0 15 - EZ=0 16 - *** Various cell types. 17 - IF(FCELTP.EQ.'A ')THEN 18 - CALL IONA00(XPOS,YPOS,EX,EY,MX,MY,IW) 19 - ELSEIF(FCELTP.EQ.'B2X')THEN 20 - CALL IONB2X(XPOS,YPOS,EX,EY ,MY,IW) 21 - ELSEIF(FCELTP.EQ.'B2Y')THEN 22 - CALL IONB2Y(XPOS,YPOS,EX,EY,MX ,IW) 23 - ELSEIF(FCELTP.EQ.'C3 ')THEN 24 - CALL IONC30(XPOS,YPOS,EX,EY ,IW) 25 - ELSEIF(FCELTP.EQ.'D1 ')THEN 26 - CALL IOND10(XPOS,YPOS,EX,EY ,IW) 27 - ELSEIF(FCELTP.EQ.'D3 ')THEN 28 - CALL IOND30(XPOS,YPOS,EX,EY ,IW) 29 - ELSEIF(FCELTP.EQ.'MAP')THEN 30 - CALL IONFMP(XPOS,YPOS,ZPOS,EX,EY,EZ,IW) 31 - ELSE 32 - PRINT *,' ###### SIGFLD ERROR : Unknown signal field'// 33 - - ' type ',FCELTP,' received; program error.' 34 - ENDIF 35 - END 738 GARFIELD ================================================== P=SIGNAL D=SIGFLS 1 ============================ 0 + +DECK,SIGFLS. 1 - SUBROUTINE SIGFLS(XPOS,YPOS,ZPOS,EXSUM,EYSUM,EZSUM,ISW) 2 - *----------------------------------------------------------------------- 3 - * SIGFLS - Sums the weighting field components at (XPOS,YPOS,ZPOS). 4 - * (Last changed on 7/12/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,FIELDMAP. 10.- +SEQ,SIGNALDATA. 11.- +SEQ,SIGNALMATRIX. 12 - REAL XPOS,YPOS,ZPOS,EX,EY,EZ,EXSUM,EYSUM,EZSUM 13 - INTEGER MX,MY,IFAIL,IW,ISW,IPLANE,IWMAP,ISTRIP 14 - *** Preset the sums. 1 738 P=SIGNAL D=SIGFLS 2 PAGE1139 15 - EXSUM=0 16 - EYSUM=0 17 - EZSUM=0 18 - *** Make sure that the signal matrices are present. 19 - IF(.NOT.SIGSET)THEN 20 - PRINT *,' !!!!!! SIGFLS WARNING : Initialisation of'// 21 - - ' signal calculation not yet done; no field.' 22 - RETURN 23 - ENDIF 24 - *** Loop over the signal layers. 25 - DO 10 MX=MXMIN,MXMAX 26 - DO 20 MY=MYMIN,MYMAX 27 - *** Load the layers of the wire matrices. 28 - CALL IONIO(MX,MY,2,0,IFAIL) 29 - IF(IFAIL.NE.0)THEN 30 - PRINT *,' !!!!!! SIGFLS WARNING : Wire matrix'// 31 - - ' store error; no weighting field returned.' 32 - EXSUM=0 33 - EYSUM=0 34 - EZSUM=0 35 - RETURN 36 - ENDIF 37 - *** Loop over all wires. 38 - DO 30 IW=1,NWIRE 39 - * Pick out those wires that are part of this read out group. 40 - IF(INDSW(IW).EQ.ISW)THEN 41 - IF(FCELTP.EQ.'A ')THEN 42 - CALL IONA00(XPOS,YPOS,EX,EY,MX,MY,IW) 43 - ELSEIF(FCELTP.EQ.'B2X')THEN 44 - CALL IONB2X(XPOS,YPOS,EX,EY ,MY,IW) 45 - ELSEIF(FCELTP.EQ.'B2Y')THEN 46 - CALL IONB2Y(XPOS,YPOS,EX,EY,MX ,IW) 47 - ELSEIF(FCELTP.EQ.'C3 ')THEN 48 - CALL IONC30(XPOS,YPOS,EX,EY ,IW) 49 - ELSEIF(FCELTP.EQ.'D1 ')THEN 50 - CALL IOND10(XPOS,YPOS,EX,EY ,IW) 51 - ELSEIF(FCELTP.EQ.'D3 ')THEN 52 - CALL IOND30(XPOS,YPOS,EX,EY ,IW) 53 - ELSE 54 - PRINT *,' ###### SIGFLS ERROR : Unknown signal'// 55 - - ' field type ',FCELTP,' received; program error.' 56 - EXSUM=0 57 - EYSUM=0 58 - EZSUM=0 59 - RETURN 60 - ENDIF 61 - EXSUM=EXSUM+EX 62 - EYSUM=EYSUM+EY 63 - EZSUM=EZSUM+EZ 64 - ENDIF 65 - 30 CONTINUE 66 - *** Load the layers of the plane matrices. 67 - CALL IPLIO(MX,MY,2,IFAIL) 68 - IF(IFAIL.NE.0)THEN 69 - PRINT *,' !!!!!! SIGFLS WARNING : Plane matrix'// 70 - - ' store error; no weighting field returned.' 71 - EXSUM=0 72 - EYSUM=0 73 - EZSUM=0 74 - RETURN 75 - ENDIF 76 - *** Loop over all planes. 77 - DO 40 IPLANE=1,5 78 - * Pick out those wires that are part of this read out group. 79 - IF(INDPLA(IPLANE).EQ.ISW)THEN 80 - IF(FCELTP.EQ.'A ')THEN 81 - CALL IPLA00(XPOS,YPOS,EX,EY,MX,MY,IPLANE) 82 - ELSEIF(FCELTP.EQ.'B2X')THEN 83 - CALL IPLB2X(XPOS,YPOS,EX,EY ,MY,IPLANE) 84 - ELSEIF(FCELTP.EQ.'B2Y')THEN 85 - CALL IPLB2Y(XPOS,YPOS,EX,EY,MX ,IPLANE) 86 - ELSEIF(FCELTP.EQ.'C3 ')THEN 87 - CALL IPLC30(XPOS,YPOS,EX,EY ,IPLANE) 88 - ELSEIF(FCELTP.EQ.'D1 ')THEN 89 - CALL IPLD10(XPOS,YPOS,EX,EY ,IPLANE) 90 - ELSEIF(FCELTP.EQ.'D3 ')THEN 91 - CALL IPLD30(XPOS,YPOS,EX,EY ,IPLANE) 92 - ELSE 93 - PRINT *,' ###### SIGFLS ERROR : Unknown signal'// 94 - - ' field type ',FCELTP,' received; program error.' 95 - EXSUM=0 96 - EYSUM=0 97 - EZSUM=0 98 - RETURN 99 - ENDIF 100 - EXSUM=EXSUM+EX 101 - EYSUM=EYSUM+EY 102 - EZSUM=EZSUM+EZ 103 - ENDIF 104 - 40 CONTINUE 105 - *** Next signal layer. 106 - 20 CONTINUE 107 - 10 CONTINUE 108 - *** Add the field due to the planes themselves. 109 - DO 50 IPLANE=1,5 110 - IF(INDPLA(IPLANE).EQ.ISW)THEN 111 - EXSUM=EXSUM+EWXCOR(IPLANE) 112 - EYSUM=EYSUM+EWYCOR(IPLANE) 113 - ENDIF 114 - 50 CONTINUE 115 - *** Add the field map, if appropriate. 116 - DO 60 IWMAP=1,NWMAP 117 - IF(INDEWS(IWMAP).EQ.ISW)THEN 118 - CALL IONFMP(XPOS,YPOS,ZPOS,EX,EY,EZ,IWMAP) 119 - EXSUM=EXSUM+EX 120 - EYSUM=EYSUM+EY 1 738 P=SIGNAL D=SIGFLS 3 PAGE1140 121 - EZSUM=EZSUM+EZ 122 - ENDIF 123 - 60 CONTINUE 124 - *** Add strips, if there are any. 125 - DO 70 IPLANE=1,5 126 - DO 80 ISTRIP=1,NPSTR1(IPLANE) 127 - IF(INDST1(IPLANE,ISTRIP).EQ.ISW)THEN 128 - CALL IONEST(XPOS,YPOS,ZPOS,EX,EY,EZ,IPLANE,ISTRIP,1) 129 - EXSUM=EXSUM+EX 130 - EYSUM=EYSUM+EY 131 - EZSUM=EZSUM+EZ 132 - ENDIF 133 - 80 CONTINUE 134 - DO 90 ISTRIP=1,NPSTR2(IPLANE) 135 - IF(INDST2(IPLANE,ISTRIP).EQ.ISW)THEN 136 - CALL IONEST(XPOS,YPOS,ZPOS,EX,EY,EZ,IPLANE,ISTRIP,2) 137 - EXSUM=EXSUM+EX 138 - EYSUM=EYSUM+EY 139 - EZSUM=EZSUM+EZ 140 - ENDIF 141 - 90 CONTINUE 142 - 70 CONTINUE 143 - END 739 GARFIELD ================================================== P=SIGNAL D=IONA00 1 ============================ 0 + +DECK,IONA00. 1 - SUBROUTINE IONA00(XPOS,YPOS,EX,EY,MX,MY,ISW) 2 - *----------------------------------------------------------------------- 3 - * IONA00 - Routine returning the A I,J [MX,MY] * E terms for A cells. 4 - * VARIABLES : R2 : Potential before taking -Log(Sqrt(...)) 5 - * EX,EY : x,y-Component of the electric field. 6 - * ETOT : Magnitude of the electric field. 7 - * VOLT : Potential. 8 - * EXHELP ETC : One term in the summing series. 9 - * (XPOS,YPOS): Position where the field is needed. 10 - * (Last changed on 14/ 8/98.) 11 - *----------------------------------------------------------------------- 12 - implicit none 13.- +SEQ,DIMENSIONS. 14.- +SEQ,CELLDATA. 15.- +SEQ,SIGNALMATRIX. 16 - REAL XPOS,YPOS,EX,EY,XX,XXMIRR,YY,YYMIRR,R2,R2PLAN,EXHELP,EYHELP 17 - INTEGER MX,MY,ISW,I 18 - *** Initialise the potential and the electric field. 19 - EX=0.0 20 - EY=0.0 21 - *** Loop over all wires. 22 - DO 10 I=1,NWIRE 23 - *** Define a few reduced variables. 24 - XX=XPOS-X(I)-MX*SX 25 - YY=YPOS-Y(I)-MY*SY 26 - *** Calculate the field in case there are no planes. 27 - R2=XX**2+YY**2 28 - IF(R2.LE.0)GOTO 10 29 - EXHELP=XX/R2 30 - EYHELP=YY/R2 31 - *** Take care of a planes at constant x. 32 - IF(YNPLAX)THEN 33 - XXMIRR=XPOS+X(I)-2.0*COPLAX 34 - R2PLAN=XXMIRR**2+YY**2 35 - IF(R2PLAN.LE.0)GOTO 10 36 - EXHELP=EXHELP-XXMIRR/R2PLAN 37 - EYHELP=EYHELP-YY/R2PLAN 38 - ENDIF 39 - *** Take care of a plane at constant y. 40 - IF(YNPLAY)THEN 41 - YYMIRR=YPOS+Y(I)-2.0*COPLAY 42 - R2PLAN=XX**2+YYMIRR**2 43 - IF(R2PLAN.LE.0)GOTO 10 44 - EXHELP=EXHELP-XX/R2PLAN 45 - EYHELP=EYHELP-YYMIRR/R2PLAN 46 - ENDIF 47 - *** Take care of pairs of planes. 48 - IF(YNPLAX.AND.YNPLAY)THEN 49 - R2PLAN=XXMIRR**2+YYMIRR**2 50 - IF(R2PLAN.LE.0)GOTO 10 51 - EXHELP=EXHELP+XXMIRR/R2PLAN 52 - EYHELP=EYHELP+YYMIRR/R2PLAN 53 - ENDIF 54 - *** Calculate the electric field and the potential. 55 - EX=EX+REAL(SIGMAT(ISW,I))*EXHELP 56 - EY=EY+REAL(SIGMAT(ISW,I))*EYHELP 57 - *** Finish the loop over the wires. 58 - 10 CONTINUE 59 - END 740 GARFIELD ================================================== P=SIGNAL D=IONB2X 1 ============================ 0 + +DECK,IONB2X. 1 - SUBROUTINE IONB2X(XPOS,YPOS,EX,EY,MY,ISW) 2 - *----------------------------------------------------------------------- 3 - * IONB2X - Routine calculating the MY contribution to the signal on 4 - * wire ISW due to a charge at (XPOS,YPOS) for F-B2Y cells. 5 - * VARIABLES : See routine EFCA00 for most of the variables. 6 - * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 7 - * ECOMPL : EX + I*EY ; I**2=-1 8 - * (Last changed on 20/ 2/90.) 9 - *----------------------------------------------------------------------- 10.- +SEQ,DIMENSIONS. 11.- +SEQ,CELLDATA. 12.- +SEQ,CONSTANTS. 13.- +SEQ,SIGNALMATRIX. 14 - COMPLEX ZZ,ECOMPL,ZZMIRR,ZZNEG,ZZNMIR 15 - *** Initialise EX and EY. 16 - EX=0.0 1 740 P=SIGNAL D=IONB2X 2 PAGE1141 17 - EY=0.0 18 - *** Loop over all wires. 19 - DO 10 I=1,NWIRE 20 - XX=0.5*PI*(XPOS-X(I))/SX 21 - YY=0.5*PI*(YPOS-Y(I)-MY*SY)/SX 22 - XXNEG=0.5*PI*(XPOS+X(I)-2.0*COPLAN(1))/SX 23 - ZZ=CMPLX(XX,YY) 24 - ZZNEG=CMPLX(XXNEG,YY) 25 - *** Calculate the field in case there are no equipotential planes. 26 - ECOMPL=0.0 27 - IF(ABS(YY).LE.20)ECOMPL=-B2SIN(I)/(SIN(ZZ)*SIN(ZZNEG)) 28 - *** Take care of a plane at constant y. 29 - IF(YNPLAY)THEN 30 - YYMIRR=(0.5*PI/SX)*(YPOS+Y(I)-2.0*COPLAY) 31 - ZZMIRR=CMPLX(XX,YYMIRR) 32 - ZZNMIR=CMPLX(XXNEG,YYMIRR) 33 - IF(ABS(YYMIRR).LE.20.0) 34 - - ECOMPL=ECOMPL+B2SIN(I)/(SIN(ZZMIRR)*SIN(ZZNMIR)) 35 - ENDIF 36 - *** Calculate the electric field and the potential. 37 - EX=EX+REAL(SIGMAT(ISW,I))*(0.5*PI/SX)*REAL(ECOMPL) 38 - EY=EY-REAL(SIGMAT(ISW,I))*(0.5*PI/SX)*AIMAG(ECOMPL) 39 - *** Finish the wire loop 40 - 10 CONTINUE 41 - END 741 GARFIELD ================================================== P=SIGNAL D=IONB2Y 1 ============================ 0 + +DECK,IONB2Y. 1 - SUBROUTINE IONB2Y(XPOS,YPOS,EX,EY,MX,ISW) 2 - *----------------------------------------------------------------------- 3 - * IONB2Y - Routine calculating the MX contribution to the signal on 4 - * wire ISW due to a charge at (XPOS,YPOS) for F-B2X cells. 5 - * VARIABLES : See routine EFCA00 for most of the variables. 6 - * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 7 - * ECOMPL : EX + I*EY ; I**2=-1 8 - * (Last changed on 20/ 2/90.) 9 - *----------------------------------------------------------------------- 10.- +SEQ,DIMENSIONS. 11.- +SEQ,CELLDATA. 12.- +SEQ,CONSTANTS. 13.- +SEQ,SIGNALMATRIX. 14 - COMPLEX ZZ,ECOMPL,ZZMIRR,ZZNEG,ZZNMIR 15 - *** Initialise EX and EY. 16 - EX=0.0 17 - EY=0.0 18 - *** Loop over all wires. 19 - DO 10 I=1,NWIRE 20 - XX=0.5*PI*(XPOS-X(I)-MX*SX)/SY 21 - YY=0.5*PI*(YPOS-Y(I))/SY 22 - YYNEG=0.5*PI*(YPOS+Y(I)-2.0*COPLAN(3))/SY 23 - ZZ=CMPLX(XX,YY) 24 - ZZNEG=CMPLX(XX,YYNEG) 25 - *** Calculate the field in case there are no equipotential planes. 26 - ECOMPL=0.0 27 - IF(ABS(XX).LE.20.0) 28 - - ECOMPL=ICONS*B2SIN(I)/(SIN(ICONS*ZZ)*SIN(ICONS*ZZNEG)) 29 - *** Take care of a plane at constant y. 30 - IF(YNPLAX)THEN 31 - XXMIRR=(0.5*PI/SY)*(XPOS+X(I)-2.0*COPLAX) 32 - ZZMIRR=CMPLX(XXMIRR,YY) 33 - ZZNMIR=CMPLX(XXMIRR,YYNEG) 34 - IF(ABS(XXMIRR).LE.20.0)ECOMPL=ECOMPL- 35 - - ICONS*B2SIN(I)/(SIN(ICONS*ZZMIRR)*SIN(ICONS*ZZNMIR)) 36 - ENDIF 37 - *** Calculate the electric field and the potential.. 38 - EX=EX+REAL(SIGMAT(ISW,I))*(0.5*PI/SY)*REAL(ECOMPL) 39 - EY=EY-REAL(SIGMAT(ISW,I))*(0.5*PI/SY)*AIMAG(ECOMPL) 40 - *** Finish the wire loop. 41 - 10 CONTINUE 42 - END 742 GARFIELD ================================================== P=SIGNAL D=IONC30 1 ============================ 0 + +DECK,IONC30. 1 - SUBROUTINE IONC30(XPOS,YPOS,EX,EY,ISW) 2 - *----------------------------------------------------------------------- 3 - * IONC30 - Routine returning the weighting field field in a 4 - * configuration with 2 y and 2 x planes. This routine is 5 - * basically the same as EFCC30. 6 - * (Last changed on 11/11/97.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,CONSTANTS. 12.- +SEQ,SIGNALMATRIX. 13 - COMPLEX WSUM1,WSUM2,WSUM3,WSUM4,ZSIN,ZCOF,ZU,ZUNEW, 14 - - ZTERM1,ZTERM2,ZETA 15 - REAL XPOS,YPOS,EX,EY,CX,CY 16 - INTEGER I,ISW 17 - *** Initial values. 18 - WSUM1=0 19 - WSUM2=0 20 - WSUM3=0 21 - WSUM4=0 22 - *** Wire loop. 23 - DO 10 I=1,NWIRE 24 - * Compute the direct contribution. 25 - ZETA=ZMULT*CMPLX(XPOS-X(I),YPOS-Y(I)) 26 - IF(AIMAG(ZETA).GT.+15)THEN 27 - WSUM1=WSUM1-REAL(SIGMAT(ISW,I))*ICONS 28 - ELSEIF(AIMAG(ZETA).LT.-15)THEN 29 - WSUM1=WSUM1+REAL(SIGMAT(ISW,I))*ICONS 30 - ELSE 31 - ZSIN=SIN(ZETA) 1 742 P=SIGNAL D=IONC30 2 PAGE1142 32 - ZCOF=4*ZSIN**2-2 33 - ZU=-P1-ZCOF*P2 34 - ZUNEW=1-ZCOF*ZU-P2 35 - ZTERM1=(ZUNEW+ZU)*ZSIN 36 - ZU=-3*P1-ZCOF*5*P2 37 - ZUNEW=1-ZCOF*ZU-5*P2 38 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 39 - WSUM1=WSUM1+REAL(SIGMAT(ISW,I))*(ZTERM2/ZTERM1) 40 - ENDIF 41 - * Find the plane nearest to the wire. 42 - CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) 43 - * Mirror contribution from the x plane. 44 - ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),YPOS-Y(I)) 45 - IF(AIMAG(ZETA).GT.+15)THEN 46 - WSUM2=WSUM2-REAL(SIGMAT(ISW,I))*ICONS 47 - ELSEIF(AIMAG(ZETA).LT.-15)THEN 48 - WSUM2=WSUM2+REAL(SIGMAT(ISW,I))*ICONS 49 - ELSE 50 - ZSIN=SIN(ZETA) 51 - ZCOF=4*ZSIN**2-2 52 - ZU=-P1-ZCOF*P2 53 - ZUNEW=1-ZCOF*ZU-P2 54 - ZTERM1=(ZUNEW+ZU)*ZSIN 55 - ZU=-3*P1-ZCOF*5*P2 56 - ZUNEW=1-ZCOF*ZU-5*P2 57 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 58 - WSUM2=WSUM2+REAL(SIGMAT(ISW,I))*(ZTERM2/ZTERM1) 59 - ENDIF 60 - * Find the plane nearest to the wire. 61 - CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) 62 - * Mirror contribution from the y plane. 63 - ZETA=ZMULT*CMPLX(XPOS-X(I),2*CY-YPOS-Y(I)) 64 - IF(AIMAG(ZETA).GT.+15)THEN 65 - WSUM3=WSUM3-REAL(SIGMAT(ISW,I))*ICONS 66 - ELSEIF(AIMAG(ZETA).LT.-15)THEN 67 - WSUM3=WSUM3+REAL(SIGMAT(ISW,I))*ICONS 68 - ELSE 69 - ZSIN=SIN(ZETA) 70 - ZCOF=4*ZSIN**2-2 71 - ZU=-P1-ZCOF*P2 72 - ZUNEW=1-ZCOF*ZU-P2 73 - ZTERM1=(ZUNEW+ZU)*ZSIN 74 - ZU=-3*P1-ZCOF*5*P2 75 - ZUNEW=1-ZCOF*ZU-5*P2 76 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 77 - WSUM3=WSUM3+REAL(SIGMAT(ISW,I))*(ZTERM2/ZTERM1) 78 - ENDIF 79 - * Mirror contribution from both the x and the y plane. 80 - ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),2*CY-YPOS-Y(I)) 81 - IF(AIMAG(ZETA).GT.+15)THEN 82 - WSUM4=WSUM4-REAL(SIGMAT(ISW,I))*ICONS 83 - ELSEIF(AIMAG(ZETA).LT.-15)THEN 84 - WSUM4=WSUM4+REAL(SIGMAT(ISW,I))*ICONS 85 - ELSE 86 - ZSIN=SIN(ZETA) 87 - ZCOF=4*ZSIN**2-2 88 - ZU=-P1-ZCOF*P2 89 - ZUNEW=1-ZCOF*ZU-P2 90 - ZTERM1=(ZUNEW+ZU)*ZSIN 91 - ZU=-3*P1-ZCOF*5*P2 92 - ZUNEW=1-ZCOF*ZU-5*P2 93 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 94 - WSUM4=WSUM4+REAL(SIGMAT(ISW,I))*(ZTERM2/ZTERM1) 95 - ENDIF 96 - 10 CONTINUE 97 - *** Convert the two contributions to a real field. 98 - EX=+REAL(ZMULT*(WSUM1+WSUM2-WSUM3-WSUM4)) 99 - EY=-AIMAG(ZMULT*(WSUM1-WSUM2+WSUM3-WSUM4)) 100 - END 743 GARFIELD ================================================== P=SIGNAL D=IOND10 1 ============================ 0 + +DECK,IOND10. 1 - SUBROUTINE IOND10(XPOS,YPOS,EX,EY,ISW) 2 - *----------------------------------------------------------------------- 3 - * IOND10 - Subroutine computing the signal on wire ISW due to a charge 4 - * at (XPOS,YPOS). This is effectively routine EFCD10. 5 - * VARIABLES : EX, EY, VOLT:Electric field and potential. 6 - * ETOT, VOLT : Magnitude of electric field, potential. 7 - * (XPOS,YPOS): The position where the field is calculated. 8 - * ZI, ZPOS : Shorthand complex notations. 9 - * (Last changed on 2/ 2/93.) 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13.- +SEQ,SIGNALMATRIX. 14 - COMPLEX ZI,ZPOS 15 - *** Initialise the potential and the electric field. 16 - EX=0.0 17 - EY=0.0 18 - * Set the complex position coordinates. 19 - ZPOS=CMPLX(XPOS,YPOS) 20 - *** Loop over all wires. 21 - DO 10 I=1,NWIRE 22 - * Set the complex version of the wire-coordinate for simplicity. 23 - ZI=CMPLX(X(I),Y(I)) 24 - * Compute the contribution to the electric field, always. 25 - EX=EX+REAL(SIGMAT(ISW,I))*REAL(1/CONJG(ZPOS-ZI)+ 26 - - ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) 27 - EY=EY+REAL(SIGMAT(ISW,I))*AIMAG(1/CONJG(ZPOS-ZI)+ 28 - - ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) 29 - *** Finish the loop over the wires. 30 - 10 CONTINUE 31 - END 1 744 GARFIELD ================================================== P=SIGNAL D=IOND30 1 =================== PAGE1143 0 + +DECK,IOND30. 1 - SUBROUTINE IOND30(XPOS,YPOS,EX,EY,ISW) 2 - *----------------------------------------------------------------------- 3 - * IOND30 - Subroutine computing the weighting field for a polygonal 4 - * cells without periodicities, type D3. 5 - * VARIABLES : EX, EY :Electric field 6 - * (XPOS,YPOS): The position where the field is calculated. 7 - * ZI, ZPOS : Shorthand complex notations. 8 - * (Last changed on 19/ 6/97.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13.- +SEQ,SIGNALMATRIX. 14 - REAL EX,EY,XPOS,YPOS 15 - INTEGER I,ISW 16 - COMPLEX WPOS,WDPOS 17 - *** Initialise electric field. 18 - EX=0.0 19 - EY=0.0 20 - * Get the mapping of the position. 21 - CALL EFCMAP(CMPLX(XPOS,YPOS)/COTUBE,WPOS,WDPOS) 22 - *** Loop over all wires. 23 - DO 10 I=1,NWIRE 24 - * Compute the contribution to the electric field. 25 - EX=EX+(SIGMAT(ISW,I)/COTUBE)*REAL(WDPOS*(1-ABS(WMAP(I))**2)/ 26 - - ((WPOS-WMAP(I))*(1-CONJG(WMAP(I))*WPOS))) 27 - EY=EY-(SIGMAT(ISW,I)/COTUBE)*AIMAG(WDPOS*(1-ABS(WMAP(I))**2)/ 28 - - ((WPOS-WMAP(I))*(1-CONJG(WMAP(I))*WPOS))) 29 - *** Finish the loop over the wires. 30 - 10 CONTINUE 31 - END 745 GARFIELD ================================================== P=SIGNAL D=SIGPLA 1 ============================ 0 + +DECK,SIGPLA. 1 - SUBROUTINE SIGPLA(XPOS,YPOS,ZPOS,EX,EY,EZ,MX,MY,IPLANE) 2 - *----------------------------------------------------------------------- 3 - * SIGPLA - Routine redirecting the calls for reduced periodicity field 4 - * vectors. 5 - * (Last changed on 12/11/98.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,SIGNALDATA. 10.- +SEQ,SIGNALMATRIX. 11 - REAL XPOS,YPOS,ZPOS,EX,EY,EZ 12 - INTEGER IPLANE,MX,MY 13 - *** Initial settings. 14 - EX=0 15 - EY=0 16 - EZ=0 17 - *** Various cell types. 18 - IF(FCELTP.EQ.'A ')THEN 19 - CALL IPLA00(XPOS,YPOS,EX,EY,MX,MY,IPLANE) 20 - ELSEIF(FCELTP.EQ.'B2X')THEN 21 - CALL IPLB2X(XPOS,YPOS,EX,EY ,MY,IPLANE) 22 - ELSEIF(FCELTP.EQ.'B2Y')THEN 23 - CALL IPLB2Y(XPOS,YPOS,EX,EY,MX ,IPLANE) 24 - ELSEIF(FCELTP.EQ.'C3 ')THEN 25 - CALL IPLC30(XPOS,YPOS,EX,EY ,IPLANE) 26 - ELSEIF(FCELTP.EQ.'D1 ')THEN 27 - CALL IPLD10(XPOS,YPOS,EX,EY ,IPLANE) 28 - ELSEIF(FCELTP.EQ.'D3 ')THEN 29 - CALL IPLD30(XPOS,YPOS,EX,EY ,IPLANE) 30 - ELSE 31 - PRINT *,' ###### SIGPLA ERROR : Unknown signal field'// 32 - - ' type ',FCELTP,' received; program error.' 33 - ENDIF 34 - *** Add the field due to the planes themselves. 35 - EX=EX+EWXCOR(IPLANE) 36 - EY=EY+EWYCOR(IPLANE) 37 - END 746 GARFIELD ================================================== P=SIGNAL D=IPLA00 1 ============================ 0 + +DECK,IPLA00. 1 - SUBROUTINE IPLA00(XPOS,YPOS,EX,EY,MX,MY,IPLANE) 2 - *----------------------------------------------------------------------- 3 - * IPLA00 - Routine returning the A I,J [MX,MY] * E terms for A cells. 4 - * VARIABLES : R2 : Potential before taking -Log(Sqrt(...)) 5 - * EX,EY : x,y-Component of the electric field. 6 - * EXHELP ETC : One term in the summing series. 7 - * (XPOS,YPOS): Position where the field is needed. 8 - * (Last changed on 9/11/98.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13.- +SEQ,SIGNALMATRIX. 14 - REAL XPOS,YPOS,EX,EY,XX,XXMIRR,YY,YYMIRR,R2,R2PLAN,EXHELP,EYHELP 15 - INTEGER MX,MY,IPLANE,I 16 - *** Initialise the electric field. 17 - EX=0 18 - EY=0 19 - *** Loop over all wires. 20 - DO 10 I=1,NWIRE 21 - *** Define a few reduced variables. 22 - XX=XPOS-X(I)-MX*SX 23 - YY=YPOS-Y(I)-MY*SY 24 - *** Calculate the field in case there are no planes. 25 - R2=XX**2+YY**2 26 - IF(R2.LE.0)GOTO 10 27 - EXHELP=XX/R2 28 - EYHELP=YY/R2 29 - *** Take care of a planes at constant x. 1 746 P=SIGNAL D=IPLA00 2 PAGE1144 30 - IF(YNPLAX)THEN 31 - XXMIRR=XPOS+X(I)-2.0*COPLAX 32 - R2PLAN=XXMIRR**2+YY**2 33 - IF(R2PLAN.LE.0)GOTO 10 34 - EXHELP=EXHELP-XXMIRR/R2PLAN 35 - EYHELP=EYHELP-YY/R2PLAN 36 - ENDIF 37 - *** Take care of a plane at constant y. 38 - IF(YNPLAY)THEN 39 - YYMIRR=YPOS+Y(I)-2.0*COPLAY 40 - R2PLAN=XX**2+YYMIRR**2 41 - IF(R2PLAN.LE.0)GOTO 10 42 - EXHELP=EXHELP-XX/R2PLAN 43 - EYHELP=EYHELP-YYMIRR/R2PLAN 44 - ENDIF 45 - *** Take care of pairs of planes. 46 - IF(YNPLAX.AND.YNPLAY)THEN 47 - R2PLAN=XXMIRR**2+YYMIRR**2 48 - IF(R2PLAN.LE.0)GOTO 10 49 - EXHELP=EXHELP+XXMIRR/R2PLAN 50 - EYHELP=EYHELP+YYMIRR/R2PLAN 51 - ENDIF 52 - *** Calculate the electric field. 53 - EX=EX+QPLANE(IPLANE,I)*EXHELP 54 - EY=EY+QPLANE(IPLANE,I)*EYHELP 55 - *** Finish the loop over the wires. 56 - 10 CONTINUE 57 - END 747 GARFIELD ================================================== P=SIGNAL D=IPLB2X 1 ============================ 0 + +DECK,IPLB2X. 1 - SUBROUTINE IPLB2X(XPOS,YPOS,EX,EY,MY,IPLANE) 2 - *----------------------------------------------------------------------- 3 - * IPLB2X - Routine calculating the MY contribution to the signal on 4 - * wire IPLANE due to a charge at (XPOS,YPOS) for F-B2Y cells. 5 - * VARIABLES : See routine EFCA00 for most of the variables. 6 - * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 7 - * ECOMPL : EX + I*EY ; I**2=-1 8 - * (Last changed on 12/11/98.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13.- +SEQ,CONSTANTS. 14.- +SEQ,SIGNALMATRIX. 15 - REAL XPOS,YPOS,EX,EY,XX,YY,XXNEG,YYMIRR 16 - INTEGER I,MY,IPLANE 17 - COMPLEX ZZ,ECOMPL,ZZMIRR,ZZNEG,ZZNMIR 18 - *** Initialise EX and EY. 19 - EX=0 20 - EY=0 21 - *** Loop over all wires. 22 - DO 10 I=1,NWIRE 23 - XX=0.5*PI*(XPOS-X(I))/SX 24 - YY=0.5*PI*(YPOS-Y(I)-MY*SY)/SX 25 - XXNEG=0.5*PI*(XPOS+X(I)-2*COPLAN(1))/SX 26 - ZZ=CMPLX(XX,YY) 27 - ZZNEG=CMPLX(XXNEG,YY) 28 - *** Calculate the field in case there are no equipotential planes. 29 - IF(ABS(YY).LE.20)THEN 30 - ECOMPL=-B2SIN(I)/(SIN(ZZ)*SIN(ZZNEG)) 31 - ELSE 32 - ECOMPL=0 33 - ENDIF 34 - *** Take care of a plane at constant y. 35 - IF(YNPLAY)THEN 36 - YYMIRR=(0.5*PI/SX)*(YPOS+Y(I)-2.0*COPLAY) 37 - ZZMIRR=CMPLX(XX,YYMIRR) 38 - ZZNMIR=CMPLX(XXNEG,YYMIRR) 39 - IF(ABS(YYMIRR).LE.20) 40 - - ECOMPL=ECOMPL+B2SIN(I)/(SIN(ZZMIRR)*SIN(ZZNMIR)) 41 - ENDIF 42 - *** Calculate the electric field. 43 - EX=EX+QPLANE(IPLANE,I)*(0.5*PI/SX)*REAL(ECOMPL) 44 - EY=EY-QPLANE(IPLANE,I)*(0.5*PI/SX)*AIMAG(ECOMPL) 45 - *** Finish the wire loop 46 - 10 CONTINUE 47 - END 748 GARFIELD ================================================== P=SIGNAL D=IPLB2Y 1 ============================ 0 + +DECK,IPLB2Y. 1 - SUBROUTINE IPLB2Y(XPOS,YPOS,EX,EY,MX,IPLANE) 2 - *----------------------------------------------------------------------- 3 - * IPLB2Y - Routine calculating the MX contribution to the signal on 4 - * wire IPLANE due to a charge at (XPOS,YPOS) for F-B2X cells. 5 - * VARIABLES : See routine EFCA00 for most of the variables. 6 - * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 7 - * ECOMPL : EX + I*EY ; I**2=-1 8 - * (Last changed on 12/11/98.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13.- +SEQ,CONSTANTS. 14.- +SEQ,SIGNALMATRIX. 15 - REAL XPOS,YPOS,EX,EY,XX,YY,YYNEG,XXMIRR 16 - INTEGER I,MX,IPLANE 17 - COMPLEX ZZ,ECOMPL,ZZMIRR,ZZNEG,ZZNMIR 18 - *** Initialise EX and EY. 19 - EX=0 20 - EY=0 21 - *** Loop over all wires. 22 - DO 10 I=1,NWIRE 23 - XX=0.5*PI*(XPOS-X(I)-MX*SX)/SY 1 748 P=SIGNAL D=IPLB2Y 2 PAGE1145 24 - YY=0.5*PI*(YPOS-Y(I))/SY 25 - YYNEG=0.5*PI*(YPOS+Y(I)-2*COPLAN(3))/SY 26 - ZZ=CMPLX(XX,YY) 27 - ZZNEG=CMPLX(XX,YYNEG) 28 - *** Calculate the field in case there are no equipotential planes. 29 - IF(ABS(XX).LE.20)THEN 30 - ECOMPL=ICONS*B2SIN(I)/(SIN(ICONS*ZZ)*SIN(ICONS*ZZNEG)) 31 - ELSE 32 - ECOMPL=0 33 - ENDIF 34 - *** Take care of a plane at constant y. 35 - IF(YNPLAX)THEN 36 - XXMIRR=(0.5*PI/SY)*(XPOS+X(I)-2.0*COPLAX) 37 - ZZMIRR=CMPLX(XXMIRR,YY) 38 - ZZNMIR=CMPLX(XXMIRR,YYNEG) 39 - IF(ABS(XXMIRR).LE.20)ECOMPL=ECOMPL- 40 - - ICONS*B2SIN(I)/(SIN(ICONS*ZZMIRR)*SIN(ICONS*ZZNMIR)) 41 - ENDIF 42 - *** Calculate the electric field. 43 - EX=EX+QPLANE(IPLANE,I)*(0.5*PI/SY)*REAL(ECOMPL) 44 - EY=EY-QPLANE(IPLANE,I)*(0.5*PI/SY)*AIMAG(ECOMPL) 45 - *** Finish the wire loop. 46 - 10 CONTINUE 47 - END 749 GARFIELD ================================================== P=SIGNAL D=IPLC30 1 ============================ 0 + +DECK,IPLC30. 1 - SUBROUTINE IPLC30(XPOS,YPOS,EX,EY,IPLANE) 2 - *----------------------------------------------------------------------- 3 - * IPLC30 - Routine returning the weighting field field in a 4 - * configuration with 2 y and 2 x planes. This routine is 5 - * basically the same as EFCC30. 6 - * (Last changed on 9/11/98.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,CONSTANTS. 12.- +SEQ,SIGNALMATRIX. 13 - COMPLEX WSUM1,WSUM2,WSUM3,WSUM4,ZSIN,ZCOF,ZU,ZUNEW, 14 - - ZTERM1,ZTERM2,ZETA 15 - REAL XPOS,YPOS,EX,EY,CX,CY 16 - INTEGER I,IPLANE 17 - *** Initial values. 18 - WSUM1=0 19 - WSUM2=0 20 - WSUM3=0 21 - WSUM4=0 22 - *** Wire loop. 23 - DO 10 I=1,NWIRE 24 - * Compute the direct contribution. 25 - ZETA=ZMULT*CMPLX(XPOS-X(I),YPOS-Y(I)) 26 - IF(AIMAG(ZETA).GT.+15)THEN 27 - WSUM1=WSUM1-ICONS 28 - ELSEIF(AIMAG(ZETA).LT.-15)THEN 29 - WSUM1=WSUM1+ICONS 30 - ELSE 31 - ZSIN=SIN(ZETA) 32 - ZCOF=4*ZSIN**2-2 33 - ZU=-P1-ZCOF*P2 34 - ZUNEW=1-ZCOF*ZU-P2 35 - ZTERM1=(ZUNEW+ZU)*ZSIN 36 - ZU=-3*P1-ZCOF*5*P2 37 - ZUNEW=1-ZCOF*ZU-5*P2 38 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 39 - WSUM1=WSUM1+ZTERM2/ZTERM1 40 - ENDIF 41 - * Find the plane nearest to the wire. 42 - CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) 43 - * Mirror contribution from the x plane. 44 - ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),YPOS-Y(I)) 45 - IF(AIMAG(ZETA).GT.+15)THEN 46 - WSUM2=WSUM2-ICONS 47 - ELSEIF(AIMAG(ZETA).LT.-15)THEN 48 - WSUM2=WSUM2+ICONS 49 - ELSE 50 - ZSIN=SIN(ZETA) 51 - ZCOF=4*ZSIN**2-2 52 - ZU=-P1-ZCOF*P2 53 - ZUNEW=1-ZCOF*ZU-P2 54 - ZTERM1=(ZUNEW+ZU)*ZSIN 55 - ZU=-3*P1-ZCOF*5*P2 56 - ZUNEW=1-ZCOF*ZU-5*P2 57 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 58 - WSUM2=WSUM2+ZTERM2/ZTERM1 59 - ENDIF 60 - * Find the plane nearest to the wire. 61 - CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) 62 - * Mirror contribution from the y plane. 63 - ZETA=ZMULT*CMPLX(XPOS-X(I),2*CY-YPOS-Y(I)) 64 - IF(AIMAG(ZETA).GT.+15)THEN 65 - WSUM3=WSUM3-ICONS 66 - ELSEIF(AIMAG(ZETA).LT.-15)THEN 67 - WSUM3=WSUM3+ICONS 68 - ELSE 69 - ZSIN=SIN(ZETA) 70 - ZCOF=4*ZSIN**2-2 71 - ZU=-P1-ZCOF*P2 72 - ZUNEW=1-ZCOF*ZU-P2 73 - ZTERM1=(ZUNEW+ZU)*ZSIN 74 - ZU=-3*P1-ZCOF*5*P2 75 - ZUNEW=1-ZCOF*ZU-5*P2 76 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 77 - WSUM3=WSUM3+ZTERM2/ZTERM1 78 - ENDIF 1 749 P=SIGNAL D=IPLC30 2 PAGE1146 79 - * Mirror contribution from both the x and the y plane. 80 - ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),2*CY-YPOS-Y(I)) 81 - IF(AIMAG(ZETA).GT.+15)THEN 82 - WSUM4=WSUM4-ICONS 83 - ELSEIF(AIMAG(ZETA).LT.-15)THEN 84 - WSUM4=WSUM4+ICONS 85 - ELSE 86 - ZSIN=SIN(ZETA) 87 - ZCOF=4*ZSIN**2-2 88 - ZU=-P1-ZCOF*P2 89 - ZUNEW=1-ZCOF*ZU-P2 90 - ZTERM1=(ZUNEW+ZU)*ZSIN 91 - ZU=-3*P1-ZCOF*5*P2 92 - ZUNEW=1-ZCOF*ZU-5*P2 93 - ZTERM2=(ZUNEW-ZU)*COS(ZETA) 94 - WSUM4=WSUM4+ZTERM2/ZTERM1 95 - ENDIF 96 - 10 CONTINUE 97 - *** Convert the two contributions to a real field. 98 - EX=+QPLANE(IPLANE,I)*REAL(ZMULT*(WSUM1+WSUM2-WSUM3-WSUM4)) 99 - EY=-QPLANE(IPLANE,I)*AIMAG(ZMULT*(WSUM1-WSUM2+WSUM3-WSUM4)) 100 - END 750 GARFIELD ================================================== P=SIGNAL D=IPLD10 1 ============================ 0 + +DECK,IPLD10. 1 - SUBROUTINE IPLD10(XPOS,YPOS,EX,EY,IPLANE) 2 - *----------------------------------------------------------------------- 3 - * IPLD10 - Subroutine computing the signal on wire IPLANE due to a 4 - * charge at (XPOS,YPOS). This is effectively routine EFCD10. 5 - * VARIABLES : EX, EY : Electric field. 6 - * (XPOS,YPOS): The position where the field is calculated. 7 - * ZI, ZPOS : Shorthand complex notations. 8 - * (Last changed on 9/11/98.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13.- +SEQ,SIGNALMATRIX. 14 - REAL XPOS,YPOS,EX,EY 15 - INTEGER IPLANE,I 16 - COMPLEX ZI,ZPOS 17 - *** Initialise the electric field. 18 - EX=0 19 - EY=0 20 - * Set the complex position coordinates. 21 - ZPOS=CMPLX(XPOS,YPOS) 22 - *** Loop over all wires. 23 - DO 10 I=1,NWIRE 24 - * Set the complex version of the wire-coordinate for simplicity. 25 - ZI=CMPLX(X(I),Y(I)) 26 - * Compute the contribution to the electric field, always. 27 - EX=EX+QPLANE(IPLANE,I)*REAL(1/CONJG(ZPOS-ZI)+ 28 - - ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) 29 - EY=EY+QPLANE(IPLANE,I)*AIMAG(1/CONJG(ZPOS-ZI)+ 30 - - ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) 31 - *** Finish the loop over the wires. 32 - 10 CONTINUE 33 - END 751 GARFIELD ================================================== P=SIGNAL D=IPLD30 1 ============================ 0 + +DECK,IPLD30. 1 - SUBROUTINE IPLD30(XPOS,YPOS,EX,EY,IPLANE) 2 - *----------------------------------------------------------------------- 3 - * IPLD30 - Subroutine computing the weighting field for a polygonal 4 - * cells without periodicities, type D3. 5 - * VARIABLES : EX, EY : Electric field 6 - * (XPOS,YPOS): The position where the field is calculated. 7 - * ZI, ZPOS : Shorthand complex notations. 8 - * (Last changed on 9/11/98.) 9 - *----------------------------------------------------------------------- 10 - implicit none 11.- +SEQ,DIMENSIONS. 12.- +SEQ,CELLDATA. 13.- +SEQ,SIGNALMATRIX. 14 - REAL EX,EY,XPOS,YPOS 15 - INTEGER I,IPLANE 16 - COMPLEX WPOS,WDPOS 17 - *** Initialise weighting field. 18 - EX=0.0 19 - EY=0.0 20 - * Get the mapping of the position. 21 - CALL EFCMAP(CMPLX(XPOS,YPOS)/COTUBE,WPOS,WDPOS) 22 - *** Loop over all wires. 23 - DO 10 I=1,NWIRE 24 - * Compute the contribution to the electric field. 25 - EX=EX+QPLANE(IPLANE,I)*REAL(WDPOS*(1-ABS(WMAP(I))**2)/ 26 - - ((WPOS-WMAP(I))*(1-CONJG(WMAP(I))*WPOS)))/COTUBE 27 - EY=EY-QPLANE(IPLANE,I)*AIMAG(WDPOS*(1-ABS(WMAP(I))**2)/ 28 - - ((WPOS-WMAP(I))*(1-CONJG(WMAP(I))*WPOS)))/COTUBE 29 - *** Finish the loop over the wires. 30 - 10 CONTINUE 31 - END 752 GARFIELD ================================================== P=SIGNAL D=IONEST 1 ============================ 0 + +DECK,IONEST. 1 - SUBROUTINE IONEST(XPOS,YPOS,ZPOS,EX,EY,EZ,IP,IS,IT) 2 - *----------------------------------------------------------------------- 3 - * IONEST - Weighting field for strips. 4 - * (Last changed on 6/12/00.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 1 752 P=SIGNAL D=IONEST 2 PAGE1147 8.- +SEQ,CELLDATA. 9.- +SEQ,CONSTANTS. 10 - REAL XPOS,YPOS,ZPOS,EX,EY,EZ,GAP,WIDTH,S,C,E1,E2,XW,YW,EWX,EWY 11 - INTEGER IP,IS,IT 12 - *** Initialise weighting field. 13 - EX=0.0 14 - EY=0.0 15 - EZ=0.0 16 - *** Transform to normalised coordinates. 17 - IF(IP.EQ.1)THEN 18 - IF(IT.EQ.1)THEN 19 - XW=-YPOS+(PLSTR1(IP,IS,1)+PLSTR1(IP,IS,2))/2 20 - YW=XPOS-COPLAN(IP) 21 - ELSE 22 - XW=-ZPOS+(PLSTR2(IP,IS,1)+PLSTR2(IP,IS,2))/2 23 - YW=XPOS-COPLAN(IP) 24 - ENDIF 25 - ELSEIF(IP.EQ.2)THEN 26 - IF(IT.EQ.1)THEN 27 - XW=YPOS-(PLSTR1(IP,IS,1)+PLSTR1(IP,IS,2))/2 28 - YW=COPLAN(IP)-XPOS 29 - ELSE 30 - XW=ZPOS-(PLSTR2(IP,IS,1)+PLSTR2(IP,IS,2))/2 31 - YW=COPLAN(IP)-XPOS 32 - ENDIF 33 - ELSEIF(IP.EQ.3)THEN 34 - IF(IT.EQ.1)THEN 35 - XW=XPOS-(PLSTR1(IP,IS,1)+PLSTR1(IP,IS,2))/2 36 - YW=YPOS-COPLAN(IP) 37 - ELSE 38 - XW=ZPOS-(PLSTR2(IP,IS,1)+PLSTR2(IP,IS,2))/2 39 - YW=YPOS-COPLAN(IP) 40 - ENDIF 41 - ELSEIF(IP.EQ.4)THEN 42 - IF(IT.EQ.1)THEN 43 - XW=-XPOS+(PLSTR1(IP,IS,1)+PLSTR1(IP,IS,2))/2 44 - YW=COPLAN(IP)-YPOS 45 - ELSE 46 - XW=-ZPOS+(PLSTR2(IP,IS,1)+PLSTR2(IP,IS,2))/2 47 - YW=COPLAN(IP)-YPOS 48 - ENDIF 49 - ELSE 50 - RETURN 51 - ENDIF 52 - *** Store the gap and strip width. 53 - IF(IT.EQ.1)THEN 54 - WIDTH=ABS(PLSTR1(IP,IS,2)-PLSTR1(IP,IS,1)) 55 - GAP=PLSTR1(IP,IS,3) 56 - ELSE 57 - WIDTH=ABS(PLSTR2(IP,IS,2)-PLSTR2(IP,IS,1)) 58 - GAP=PLSTR2(IP,IS,3) 59 - ENDIF 60 - *** Make sure we're in the fiducial part of the weighting map. 61 - IF(YW.LE.0.OR.YW.GT.GAP)THEN 62 - EX=0 63 - EY=0 64 - EZ=0 65 - RETURN 66 - ENDIF 67 - *** Evaluate the weighting field, define shorthand notations. 68 - S=SIN(PI*YW/GAP) 69 - C=COS(PI*YW/GAP) 70 - E1=EXP( PI*(WIDTH/2-XW)/GAP) 71 - E2=EXP(-PI*(WIDTH/2+XW)/GAP) 72 - * Check for singularities. 73 - IF(C.EQ.E1.OR.C.EQ.E2)THEN 74 - EWX=0 75 - EWY=0 76 - * Evaluate the field. 77 - ELSE 78 - EWX=E1*S/(GAP*(C-E1)**2*(1+S**2/(C-E1)**2))- 79 - - E2*S/(GAP*(C-E2)**2*(1+S**2/(C-E2)**2)) 80 - EWY=((C/(C-E2)+S**2/(C-E2)**2)/(1+S**2/(C-E2)**2)- 81 - - (C/(C-E1)+S**2/(C-E1)**2)/(1+S**2/(C-E1)**2))/GAP 82 - ENDIF 83 - *** Rotate the field back to the original coordinates. 84 - IF(IP.EQ.1)THEN 85 - IF(IT.EQ.1)THEN 86 - EX=EWY 87 - EY=-EWX 88 - EZ=0 89 - ELSE 90 - EX=EWY 91 - EY=0 92 - EZ=-EWX 93 - ENDIF 94 - ELSEIF(IP.EQ.2)THEN 95 - IF(IT.EQ.1)THEN 96 - EX=-EWY 97 - EY=EWX 98 - EZ=0 99 - ELSE 100 - EX=-EWY 101 - EY=0 102 - EZ=EWX 103 - ENDIF 104 - ELSEIF(IP.EQ.3)THEN 105 - IF(IT.EQ.1)THEN 106 - EX=EWX 107 - EY=EWY 108 - EZ=0 109 - ELSE 110 - EX=0 111 - EY=EWY 112 - EZ=EWX 113 - ENDIF 1 752 P=SIGNAL D=IONEST 3 PAGE1148 114 - ELSEIF(IP.EQ.4)THEN 115 - IF(IT.EQ.1)THEN 116 - EX=-EWX 117 - EY=-EWY 118 - EZ=0 119 - ELSE 120 - EX=0 121 - EY=-EWY 122 - EZ=-EWX 123 - ENDIF 124 - ELSE 125 - EX=0 126 - EY=0 127 - EZ=0 128 - ENDIF 129 - END 753 GARFIELD ================================================== P=SIGNAL D=IONFMP 1 ============================ 0 + +DECK,IONFMP. 1 - SUBROUTINE IONFMP(XIN,YIN,ZIN,EX,EY,EZ,ISW) 2 - *----------------------------------------------------------------------- 3 - * IONFMP - Interpolates the weighting field map at (XPOS,YPOS,ZPOS). 4 - * (Last changed on 4/ 9/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,FIELDMAP. 9.- +SEQ,CELLDATA. 10.- +SEQ,CONSTANTS. 11 - REAL XIN,YIN,ZIN,XPOS,YPOS,ZPOS,EX,EY,EZ,XNEW,YNEW,ZNEW, 12 - - T1,T2,T3,T4,AUXR,AUXPHI,AROT,XAUX,YAUX,ER,EAXIS,RCOOR,ZCOOR 13 - INTEGER IMAP,NX,NY,NZ,ISW 14 - LOGICAL MIRRX,MIRRY,MIRRZ 15 - *** Initial values. 16 - EX=0 17 - EY=0 18 - EZ=0 19 - XPOS=XIN 20 - YPOS=YIN 21 - ZPOS=ZIN 22 - *** First see whether we at all have a grid. 23 - IF(.NOT.MAPFLG(1))RETURN 24 - *** If chamber is periodic, reduce to the cell volume. 25 - MIRRX=.FALSE. 26 - IF(PERX)THEN 27 - XPOS=XMMIN+MOD(XPOS-XMMIN,XMMAX-XMMIN) 28 - IF(XPOS.LT.XMMIN)XPOS=XPOS+(XMMAX-XMMIN) 29 - ELSEIF(PERMX)THEN 30 - XNEW=XMMIN+MOD(XPOS-XMMIN,XMMAX-XMMIN) 31 - IF(XNEW.LT.XMMIN)XNEW=XNEW+(XMMAX-XMMIN) 32 - NX=NINT((XNEW-XPOS)/(XMMAX-XMMIN)) 33 - IF(NX.NE.2*(NX/2))THEN 34 - XNEW=XMMIN+XMMAX-XNEW 35 - MIRRX=.TRUE. 36 - ENDIF 37 - XPOS=XNEW 38 - ENDIF 39 - IF(PERAX.AND.(ZPOS.NE.0.OR.YPOS.NE.0))THEN 40 - AUXR=SQRT(ZPOS**2+YPOS**2) 41 - AUXPHI=ATAN2(ZPOS,YPOS) 42 - AROT=(XAMAX-XAMIN)*ANINT((AUXPHI-0.5*(XAMIN+XAMAX))/ 43 - - (XAMAX-XAMIN)) 44 - IF(AUXPHI-AROT.LT.XAMIN)AROT=AROT-(XAMAX-XAMIN) 45 - IF(AUXPHI-AROT.GT.XAMAX)AROT=AROT+(XAMAX-XAMIN) 46 - AUXPHI=AUXPHI-AROT 47 - YPOS=AUXR*COS(AUXPHI) 48 - ZPOS=AUXR*SIN(AUXPHI) 49 - ENDIF 50 - MIRRY=.FALSE. 51 - IF(PERY)THEN 52 - YPOS=YMMIN+MOD(YPOS-YMMIN,YMMAX-YMMIN) 53 - IF(YPOS.LT.YMMIN)YPOS=YPOS+(YMMAX-YMMIN) 54 - ELSEIF(PERMY)THEN 55 - YNEW=YMMIN+MOD(YPOS-YMMIN,YMMAX-YMMIN) 56 - IF(YNEW.LT.YMMIN)YNEW=YNEW+(YMMAX-YMMIN) 57 - NY=NINT((YNEW-YPOS)/(YMMAX-YMMIN)) 58 - IF(NY.NE.2*(NY/2))THEN 59 - YNEW=YMMIN+YMMAX-YNEW 60 - MIRRY=.TRUE. 61 - ENDIF 62 - YPOS=YNEW 63 - ENDIF 64 - IF(PERAY.AND.(XPOS.NE.0.OR.ZPOS.NE.0))THEN 65 - AUXR=SQRT(XPOS**2+ZPOS**2) 66 - AUXPHI=ATAN2(XPOS,ZPOS) 67 - AROT=(YAMAX-YAMIN)*ANINT((AUXPHI-0.5*(YAMIN+YAMAX))/ 68 - - (YAMAX-YAMIN)) 69 - IF(AUXPHI-AROT.LT.YAMIN)AROT=AROT-(YAMAX-YAMIN) 70 - IF(AUXPHI-AROT.GT.YAMAX)AROT=AROT+(YAMAX-YAMIN) 71 - AUXPHI=AUXPHI-AROT 72 - ZPOS=AUXR*COS(AUXPHI) 73 - XPOS=AUXR*SIN(AUXPHI) 74 - ENDIF 75 - MIRRZ=.FALSE. 76 - IF(PERZ)THEN 77 - ZPOS=ZMMIN+MOD(ZPOS-ZMMIN,ZMMAX-ZMMIN) 78 - IF(ZPOS.LT.ZMMIN)ZPOS=ZPOS+(ZMMAX-ZMMIN) 79 - ELSEIF(PERMZ)THEN 80 - ZNEW=ZMMIN+MOD(ZPOS-ZMMIN,ZMMAX-ZMMIN) 81 - IF(ZNEW.LT.ZMMIN)ZNEW=ZNEW+(ZMMAX-ZMMIN) 82 - NZ=NINT((ZNEW-ZPOS)/(ZMMAX-ZMMIN)) 83 - IF(NZ.NE.2*(NZ/2))THEN 84 - ZNEW=ZMMIN+ZMMAX-ZNEW 85 - MIRRZ=.TRUE. 86 - ENDIF 1 753 P=SIGNAL D=IONFMP 2 PAGE1149 87 - ZPOS=ZNEW 88 - ENDIF 89 - IF(PERAZ.AND.(YPOS.NE.0.OR.XPOS.NE.0))THEN 90 - AUXR=SQRT(YPOS**2+XPOS**2) 91 - AUXPHI=ATAN2(YPOS,XPOS) 92 - AROT=(ZAMAX-ZAMIN)*ANINT((AUXPHI-0.5*(ZAMIN+ZAMAX))/ 93 - - (ZAMAX-ZAMIN)) 94 - IF(AUXPHI-AROT.LT.ZAMIN)AROT=AROT-(ZAMAX-ZAMIN) 95 - IF(AUXPHI-AROT.GT.ZAMAX)AROT=AROT+(ZAMAX-ZAMIN) 96 - AUXPHI=AUXPHI-AROT 97 - XPOS=AUXR*COS(AUXPHI) 98 - YPOS=AUXR*SIN(AUXPHI) 99 - ENDIF 100 - *** If we have a rotationally symmetric field map, store coordinates. 101 - IF(PERRX)THEN 102 - RCOOR=SQRT(YPOS**2+ZPOS**2) 103 - ZCOOR=XPOS 104 - ELSEIF(PERRY)THEN 105 - RCOOR=SQRT(XPOS**2+ZPOS**2) 106 - ZCOOR=YPOS 107 - ELSEIF(PERRZ)THEN 108 - RCOOR=SQRT(XPOS**2+YPOS**2) 109 - ZCOOR=ZPOS 110 - ENDIF 111 - IF(PERRX.OR.PERRY.OR.PERRZ)THEN 112 - XPOS=RCOOR 113 - YPOS=ZCOOR 114 - ZPOS=0 115 - ENDIF 116 - *** Locate the point. 117 - CALL MAPIND(XPOS,YPOS,ZPOS,T1,T2,T3,T4,IMAP) 118 - IF(IMAP.LE.0.OR.IMAP.GT.NMAP)RETURN 119 - *** Next perform a linear 3-dimensional interpolation. 120 - IF((MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13).AND. 121 - - MAPORD.EQ.1)THEN 122 - IF(MAPFLG(10+3*ISW-2))EX= 123 - - EWXMAP(IMAP,1,ISW)*T1+EWXMAP(IMAP,2,ISW)*T2+ 124 - - EWXMAP(IMAP,3,ISW)*T3+EWXMAP(IMAP,4,ISW)*T4 125 - IF(MAPFLG(11+3*ISW-2))EY= 126 - - EWYMAP(IMAP,1,ISW)*T1+EWYMAP(IMAP,2,ISW)*T2+ 127 - - EWYMAP(IMAP,3,ISW)*T3+EWYMAP(IMAP,4,ISW)*T4 128 - IF(MAPFLG(12+3*ISW-2))EZ= 129 - - EWZMAP(IMAP,1,ISW)*T1+EWZMAP(IMAP,2,ISW)*T2+ 130 - - EWZMAP(IMAP,3,ISW)*T3+EWZMAP(IMAP,4,ISW)*T4 131 - * Or a 3-dimensional quadratic interpolation. 132 - ELSEIF(MAPTYP.EQ.12.AND.MAPORD.EQ.2)THEN 133 - IF(MAPFLG(10+3*ISW-2))EX= 134 - - EWXMAP(IMAP,1,ISW)*T1*(2*T1-1)+ 135 - - EWXMAP(IMAP,2,ISW)*T2*(2*T2-1)+ 136 - - EWXMAP(IMAP,3,ISW)*T3*(2*T3-1)+ 137 - - EWXMAP(IMAP,4,ISW)*T4*(2*T4-1)+ 138 - - 4*EWXMAP(IMAP,5,ISW)*T1*T2+4*EWXMAP(IMAP,6,ISW)*T1*T3+ 139 - - 4*EWXMAP(IMAP,7,ISW)*T1*T4+4*EWXMAP(IMAP,8,ISW)*T2*T3+ 140 - - 4*EWXMAP(IMAP,9,ISW)*T2*T4+4*EWXMAP(IMAP,10,ISW)*T3*T4 141 - IF(MAPFLG(11+3*ISW-2))EY= 142 - - EWYMAP(IMAP,1,ISW)*T1*(2*T1-1)+ 143 - - EWYMAP(IMAP,2,ISW)*T2*(2*T2-1)+ 144 - - EWYMAP(IMAP,3,ISW)*T3*(2*T3-1)+ 145 - - EWYMAP(IMAP,4,ISW)*T4*(2*T4-1)+ 146 - - 4*EWYMAP(IMAP,5,ISW)*T1*T2+4*EWYMAP(IMAP,6,ISW)*T1*T3+ 147 - - 4*EWYMAP(IMAP,7,ISW)*T1*T4+4*EWYMAP(IMAP,8,ISW)*T2*T3+ 148 - - 4*EWYMAP(IMAP,9,ISW)*T2*T4+4*EWYMAP(IMAP,10,ISW)*T3*T4 149 - IF(MAPFLG(12+3*ISW-2))EZ= 150 - - EWZMAP(IMAP,1,ISW)*T1*(2*T1-1)+ 151 - - EWZMAP(IMAP,2,ISW)*T2*(2*T2-1)+ 152 - - EWZMAP(IMAP,3,ISW)*T3*(2*T3-1)+ 153 - - EWZMAP(IMAP,4,ISW)*T4*(2*T4-1)+ 154 - - 4*EWZMAP(IMAP,5,ISW)*T1*T2+4*EWZMAP(IMAP,6,ISW)*T1*T3+ 155 - - 4*EWZMAP(IMAP,7,ISW)*T1*T4+4*EWZMAP(IMAP,8,ISW)*T2*T3+ 156 - - 4*EWZMAP(IMAP,9,ISW)*T2*T4+4*EWZMAP(IMAP,10,ISW)*T3*T4 157 - *** Or a linear 2-dimensional interpolation. 158 - ELSEIF((MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3).AND. 159 - - MAPORD.EQ.1)THEN 160 - IF(MAPFLG(10+3*ISW-2))EX=EWXMAP(IMAP,1,ISW)*T1+ 161 - - EWXMAP(IMAP,2,ISW)*T2+EWXMAP(IMAP,3,ISW)*T3 162 - IF(MAPFLG(11+3*ISW-2))EY=EWYMAP(IMAP,1,ISW)*T1+ 163 - - EWYMAP(IMAP,2,ISW)*T2+EWYMAP(IMAP,3,ISW)*T3 164 - IF(MAPFLG(12+3*ISW-2))EZ=EWZMAP(IMAP,1,ISW)*T1+ 165 - - EWZMAP(IMAP,2,ISW)*T2+EWZMAP(IMAP,3,ISW)*T3 166 - * Or a 2-dimensional quadratic interpolation. 167 - ELSEIF(MAPTYP.EQ.2.AND.MAPORD.EQ.2)THEN 168 - IF(MAPFLG(10+3*ISW-2))EX= 169 - - EWXMAP(IMAP,1,ISW)*T1*(2*T1-1)+ 170 - - EWXMAP(IMAP,2,ISW)*T2*(2*T2-1)+ 171 - - EWXMAP(IMAP,3,ISW)*T3*(2*T3-1)+ 172 - - 4*EWXMAP(IMAP,4,ISW)*T1*T2+ 173 - - 4*EWXMAP(IMAP,5,ISW)*T1*T3+ 174 - - 4*EWXMAP(IMAP,6,ISW)*T2*T3 175 - IF(MAPFLG(11+3*ISW-2))EY= 176 - - EWYMAP(IMAP,1,ISW)*T1*(2*T1-1)+ 177 - - EWYMAP(IMAP,2,ISW)*T2*(2*T2-1)+ 178 - - EWYMAP(IMAP,3,ISW)*T3*(2*T3-1)+ 179 - - 4*EWYMAP(IMAP,4,ISW)*T1*T2+ 180 - - 4*EWYMAP(IMAP,5,ISW)*T1*T3+ 181 - - 4*EWYMAP(IMAP,6,ISW)*T2*T3 182 - IF(MAPFLG(12+3*ISW-2))EZ= 183 - - EWZMAP(IMAP,1,ISW)*T1*(2*T1-1)+ 184 - - EWZMAP(IMAP,2,ISW)*T2*(2*T2-1)+ 185 - - EWZMAP(IMAP,3,ISW)*T3*(2*T3-1)+ 186 - - 4*EWZMAP(IMAP,4,ISW)*T1*T2+ 187 - - 4*EWZMAP(IMAP,5,ISW)*T1*T3+ 188 - - 4*EWZMAP(IMAP,6,ISW)*T2*T3 189 - * Other elements. 190 - ELSE 191 - PRINT *,' !!!!!! IONFMP WARNING : Unknown element ',MAPTYP 192 - RETURN 1 753 P=SIGNAL D=IONFMP 3 PAGE1150 193 - ENDIF 194 - *** Apply mirror imaging. 195 - IF(MIRRX)EX=-EX 196 - IF(MIRRY)EY=-EY 197 - IF(MIRRZ)EZ=-EZ 198 - *** Rotate the field. 199 - IF(PERAX)THEN 200 - CALL CFMCTP(EY,EZ,XAUX,YAUX,1) 201 - YAUX=YAUX+AROT*180/PI 202 - CALL CFMPTC(XAUX,YAUX,EY,EZ,1) 203 - ENDIF 204 - IF(PERAY)THEN 205 - CALL CFMCTP(EZ,EX,XAUX,YAUX,1) 206 - YAUX=YAUX+AROT*180/PI 207 - CALL CFMPTC(XAUX,YAUX,EZ,EX,1) 208 - ENDIF 209 - IF(PERAZ)THEN 210 - CALL CFMCTP(EX,EY,XAUX,YAUX,1) 211 - YAUX=YAUX+AROT*180/PI 212 - CALL CFMPTC(XAUX,YAUX,EX,EY,1) 213 - ENDIF 214 - *** And take care of symmetry. 215 - ER=EX 216 - EAXIS=EZ 217 - IF(PERRX)THEN 218 - IF(RCOOR.LE.0)THEN 219 - EX=EAXIS 220 - EY=0 221 - EZ=0 222 - ELSE 223 - EX=EAXIS 224 - EY=ER*YIN/RCOOR 225 - EZ=ER*ZIN/RCOOR 226 - ENDIF 227 - ENDIF 228 - IF(PERRY)THEN 229 - IF(RCOOR.LE.0)THEN 230 - EX=0 231 - EY=EAXIS 232 - EZ=0 233 - ELSE 234 - EX=ER*XIN/RCOOR 235 - EY=EAXIS 236 - EZ=ER*ZIN/RCOOR 237 - ENDIF 238 - ENDIF 239 - IF(PERRZ)THEN 240 - IF(RCOOR.LE.0)THEN 241 - EX=0 242 - EY=0 243 - EZ=EAXIS 244 - ELSE 245 - EX=ER*XIN/RCOOR 246 - EY=ER*YIN/RCOOR 247 - EZ=EAXIS 248 - ENDIF 249 - ENDIF 250 - END 754 GARFIELD ================================================== P=SIGNAL D=SIGPLT 1 ============================ 0 + +DECK,SIGPLT. 1 - SUBROUTINE SIGPLT 2 - *----------------------------------------------------------------------- 3 - * SIGPLT - Routine plotting the signal induced on the sense wires 4 - * VARIABLES : 5 - * (Last changed on 21/ 1/01.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,CELLDATA. 10.- +SEQ,GASDATA. 11.- +SEQ,SIGNALDATA. 12.- +SEQ,PARAMETERS. 13.- +SEQ,PRINTPLOT. 14.- +SEQ,DRIFTLINE. 15 - CHARACTER*50 AUX 16 - REAL TPLMIN,TPLMAX,TMIN,TMAX,SPLMIN,SPLMAX,SIGMIN,SIGMAX, 17 - - TMINR,TMAXR,SMINR,SMAXR 18 - INTEGER INPCMP,INPTYP,I,J,INEXT,ISW,JSW,JW,NC,NPLOT,NWORD, 19 - - IFAIL1,IFAIL2,NFOUND,ITMIN,ITMAX 20 - LOGICAL FLAT,PLOT(MXSW),TAUTO,SAUTO,LPLCR,LPLDIR,FLAG(MXWORD) 21 - EXTERNAL INPCMP,INPTYP 22 - *** Identify the routine. 23 - IF(LIDENT)PRINT *,' /// ROUTINE SIGPLT ///' 24 - *** Initialise the time window. 25 - TMIN=TIMSIG(1) 26 - TMAX=TIMSIG(NTIME) 27 - TAUTO=.FALSE. 28 - * Preset the signal range. 29 - SAUTO=.TRUE. 30 - * The wire plot flags (sense wires with non-flat signal). 31 - DO 10 ISW=1,MXSW 32 - PLOT(ISW)=.FALSE. 33 - IF(ISW.LE.NSW)THEN 34 - DO 20 J=1,NTIME 35 - IF(SIGNAL(J,ISW,1).NE.0.OR. 36 - - (LCROSS.AND.SIGNAL(J,ISW,2).NE.0))PLOT(ISW)=.TRUE. 37 - 20 CONTINUE 38 - ENDIF 39 - 10 CONTINUE 40 - * Plotting options. 41 - LPLCR=LCROSS 42 - LPLDIR=.TRUE. 43 - *** Read the command line arguments. 44 - CALL INPNUM(NWORD) 1 754 P=SIGNAL D=SIGPLT 2 PAGE1151 45 - * Mark keyword. 46 - DO 25 I=1,MXWORD 47 - IF(I.GT.NWORD)THEN 48 - FLAG(I)=.TRUE. 49 - ELSEIF(INPCMP(I,'TIME-#WINDOW')+INPCMP(I,'WIN#DOW')+ 50 - - INPCMP(I,'RAN#GE')+INPCMP(I,'SC#ALE')+ 51 - - INPCMP(I+1,'AUTO#MATIC')+INPCMP(I,'WIRE#S')+ 52 - - INPCMP(I,'CR#OSS-#INDUCED-#SIGNALS')+ 53 - - INPCMP(I,'NOCR#OSS-#INDUCED-#SIGNALS')+ 54 - - INPCMP(I,'DIR#ECT-#SIGNALS')+INPCMP(I,'NODIR#ECT-#SIGNALS')+ 55 - - INPCMP(I,'ALL')+INPCMP(I,'ACT#IVE').NE.0)THEN 56 - FLAG(I)=.TRUE. 57 - ELSE 58 - FLAG(I)=.FALSE. 59 - ENDIF 60 - 25 CONTINUE 61 - * Loop over the words. 62 - INEXT=2 63 - DO 30 I=2,NWORD 64 - IF(I.LT.INEXT)GOTO 30 65 - ** Time window. 66 - IF(INPCMP(I,'TIME-#WINDOW')+INPCMP(I,'WIN#DOW').NE.0)THEN 67 - * Automatic window. 68 - IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN 69 - TAUTO=.TRUE. 70 - INEXT=I+2 71 - * No arguments. 72 - ELSEIF(NWORD.LT.I+2.OR.FLAG(I+1).OR.FLAG(I+2))THEN 73 - CALL INPMSG(I,'Arguments missing') 74 - * Arguments, but not integer, real or *. 75 - ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.AND. 76 - - INPTYP(I+1).NE.4).OR.(INPTYP(I+2).NE.1.AND. 77 - - INPTYP(I+2).NE.2.AND.INPTYP(I+2).NE.4))THEN 78 - CALL INPMSG(I,'Arguments of wrong type') 79 - * Two arguments: establish the range. 80 - ELSE 81 - CALL INPCHK(I+1,2,IFAIL1) 82 - CALL INPCHK(I+2,2,IFAIL2) 83 - CALL INPRDR(I+1,TMINR,TMIN) 84 - CALL INPRDR(I+2,TMAXR,TMAX) 85 - IF(TMINR.EQ.TMAXR.OR. 86 - - IFAIL1.NE.0.OR.IFAIL2.NE.0.OR. 87 - - MIN(TMINR,TMAXR).GT.TIMSIG(NTIME).OR. 88 - - MAX(TMINR,TMAXR).LT.TIMSIG(1))THEN 89 - CALL INPMSG(I+1,'Invalid range') 90 - CALL INPMSG(I+2,'Invalid range') 91 - ELSE 92 - TMIN=MIN(TMINR,TMAXR) 93 - TMAX=MAX(TMINR,TMAXR) 94 - TAUTO=.FALSE. 95 - ENDIF 96 - INEXT=I+3 97 - ENDIF 98 - ** Signal range. 99 - ELSEIF(INPCMP(I,'RAN#GE')+INPCMP(I,'SC#ALE').NE.0)THEN 100 - * Automatic window. 101 - IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN 102 - SAUTO=.TRUE. 103 - INEXT=I+2 104 - * No arguments. 105 - ELSEIF(NWORD.LT.I+2.OR.FLAG(I+1).OR.FLAG(I+2))THEN 106 - CALL INPMSG(I,'Arguments missing') 107 - * Arguments, but not integer, real or *. 108 - ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. 109 - - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2))THEN 110 - CALL INPMSG(I,'Arguments of wrong type') 111 - * Two arguments: establish the range. 112 - ELSE 113 - CALL INPCHK(I+1,2,IFAIL1) 114 - CALL INPCHK(I+2,2,IFAIL2) 115 - CALL INPRDR(I+1,SMINR,0.0) 116 - CALL INPRDR(I+2,SMAXR,0.0) 117 - IF(SMINR.EQ.SMAXR.OR. 118 - - IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN 119 - CALL INPMSG(I+1,'Invalid range') 120 - CALL INPMSG(I+2,'Invalid range') 121 - ELSE 122 - SPLMIN=MIN(SMINR,SMAXR) 123 - SPLMAX=MAX(SMINR,SMAXR) 124 - SAUTO=.FALSE. 125 - ENDIF 126 - INEXT=I+3 127 - ENDIF 128 - ** Direct / Cross-induced / both. 129 - ELSEIF(INPCMP(I,'CR#OSS-#INDUCED-#SIGNALS').NE.0)THEN 130 - IF(.NOT.LCROSS)THEN 131 - CALL INPMSG(I,'Option CROSS-INDUCED is off') 132 - ELSE 133 - LPLCR=.TRUE. 134 - ENDIF 135 - ELSEIF(INPCMP(I,'NOCR#OSS-#INDUCED-#SIGNALS').NE.0)THEN 136 - LPLCR=.FALSE. 137 - ELSEIF(INPCMP(I,'DIR#ECT-#SIGNALS').NE.0)THEN 138 - LPLDIR=.TRUE. 139 - ELSEIF(INPCMP(I,'NODIR#ECT-#SIGNALS').NE.0)THEN 140 - LPLDIR=.FALSE. 141 - ** Wire selections. 142 - ELSEIF(INPCMP(I,'WIRE#S').NE.0)THEN 143 - * All wires are selected. 144 - IF(INPCMP(I+1,'ALL').NE.0)THEN 145 - DO 40 ISW=1,NSW 146 - PLOT(ISW)=.TRUE. 147 - 40 CONTINUE 148 - INEXT=I+2 149 - * All wires which have a signal. 150 - ELSEIF(INPCMP(I+1,'ACT#IVE').NE.0)THEN 1 754 P=SIGNAL D=SIGPLT 3 PAGE1152 151 - DO 50 ISW=1,NSW 152 - DO 60 J=1,NTIME 153 - IF(SIGNAL(J,ISW,1).NE.0.OR. 154 - - (LCROSS.AND.SIGNAL(J,ISW,2).NE.0))PLOT(ISW)=.TRUE. 155 - 60 CONTINUE 156 - 50 CONTINUE 157 - INEXT=I+2 158 - ELSE 159 - DO 70 J=I+1,NWORD 160 - * Leave when hitting a keyword. 161 - IF(FLAG(J))THEN 162 - INEXT=J 163 - GOTO 90 164 - * Selection by wire number. 165 - ELSEIF(INPTYP(J).EQ.1)THEN 166 - CALL INPCHK(J,1,IFAIL1) 167 - CALL INPRDI(J,JW,0) 168 - IF(JW.GE.1.AND.JW.LE.NWIRE)THEN 169 - JSW=INDSW(JW) 170 - IF(JSW.NE.0)PLOT(JSW)=.TRUE. 171 - ELSE 172 - CALL INPMSG(J,'Not a valid wire number') 173 - ENDIF 174 - * Selection by wire code. 175 - ELSEIF(INPTYP(J).EQ.0)THEN 176 - CALL INPSTR(J,J,AUX,NC) 177 - NFOUND=0 178 - DO 80 JW=1,NWIRE 179 - IF(WIRTYP(JW).EQ.AUX(1:1))THEN 180 - JSW=INDSW(JW) 181 - IF(JSW.NE.0)THEN 182 - PLOT(JSW)=.TRUE. 183 - NFOUND=NFOUND+1 184 - ENDIF 185 - ENDIF 186 - 80 CONTINUE 187 - IF(NFOUND.EQ.0)CALL INPMSG(J, 188 - - 'Not a known sense-wire code.') 189 - ELSE 190 - INEXT=J 191 - GOTO 90 192 - ENDIF 193 - 70 CONTINUE 194 - INEXT=NWORD+1 195 - 90 CONTINUE 196 - ENDIF 197 - * Other keywords are not known. 198 - ELSEIF(FLAG(I))THEN 199 - CALL INPMSG(I,'Valid keyword out of context') 200 - ELSE 201 - CALL INPMSG(I,'Not a known keyword') 202 - ENDIF 203 - 30 CONTINUE 204 - *** Print error messages. 205 - CALL INPERR 206 - *** Make sure at least a bit of plotting is requested. 207 - IF(.NOT.(LPLCR.OR.LPLDIR))THEN 208 - PRINT *,' !!!!!! SIGPLT WARNING : No plot output has'// 209 - - ' been requested ; no plot made.' 210 - RETURN 211 - ENDIF 212 - *** Loop over all (groups of) sense wires, count the number of plots. 213 - NPLOT=0 214 - DO 100 ISW=1,NSW 215 - IF(.NOT.PLOT(ISW))GOTO 100 216 - * Find a proper time range. 217 - IF(TAUTO)THEN 218 - DO 120 J=1,NTIME 219 - IF((LPLDIR.AND.SIGNAL(J,ISW,1).NE.0).OR. 220 - - (LCROSS.AND.LPLCR.AND.SIGNAL(J,ISW,2).NE.0))THEN 221 - ITMIN=J 222 - TMIN=TIMSIG(J) 223 - GOTO 130 224 - ENDIF 225 - 120 CONTINUE 226 - PRINT *,' !!!!!! SIGPLT WARNING : Start time of signal'// 227 - - ' not found ; program bug, please report.' 228 - GOTO 100 229 - 130 CONTINUE 230 - DO 140 J=NTIME,1,-1 231 - IF((LPLDIR.AND.SIGNAL(J,ISW,1).NE.0).OR. 232 - - (LCROSS.AND.LPLCR.AND.SIGNAL(J,ISW,2).NE.0))THEN 233 - ITMAX=J 234 - TMAX=TIMSIG(J) 235 - GOTO 150 236 - ENDIF 237 - 140 CONTINUE 238 - PRINT *,' !!!!!! SIGPLT WARNING : End time of signal'// 239 - - ' not found ; program bug, please report.' 240 - GOTO 100 241 - 150 CONTINUE 242 - TPLMIN=TMIN-0.1*(TMAX-TMIN) 243 - TPLMAX=TMAX+0.1*(TMAX-TMIN) 244 - ELSE 245 - TPLMIN=TMIN 246 - TPLMAX=TMAX 247 - ITMIN=1 248 - ITMAX=NTIME 249 - DO 160 J=1,NTIME 250 - IF(TIMSIG(J).LT.TMIN)ITMIN=J 251 - IF(TIMSIG(NTIME-J+1).GT.TMAX)ITMAX=NTIME-J+1 252 - 160 CONTINUE 253 - ENDIF 254 - * Make sure the signal is not flat and find default signal range. 255 - FLAT=.TRUE. 256 - IF(LPLDIR)THEN 1 754 P=SIGNAL D=SIGPLT 4 PAGE1153 257 - SIGMIN=SIGNAL(ITMIN,ISW,1) 258 - SIGMAX=SIGNAL(ITMIN,ISW,1) 259 - ELSE 260 - SIGMIN=SIGNAL(ITMIN,ISW,2) 261 - SIGMAX=SIGNAL(ITMIN,ISW,2) 262 - ENDIF 263 - DO 110 J=ITMIN,ITMAX 264 - IF((LPLDIR.AND.SIGNAL(J,ISW,1).NE.0).OR. 265 - - (LCROSS.AND.LPLCR.AND.SIGNAL(J,ISW,2).NE.0))FLAT=.FALSE. 266 - IF(LPLDIR)SIGMIN=MIN(SIGMIN,SIGNAL(J,ISW,1)) 267 - IF(LPLCR.AND.LCROSS)SIGMIN=MIN(SIGMIN,SIGNAL(J,ISW,2)) 268 - IF(LPLDIR)SIGMAX=MAX(SIGMAX,SIGNAL(J,ISW,1)) 269 - IF(LPLCR.AND.LCROSS)SIGMAX=MAX(SIGMAX,SIGNAL(J,ISW,2)) 270 - 110 CONTINUE 271 - * Print a warning if the signal is flat. 272 - IF(FLAT)THEN 273 - PRINT *,' !!!!!! SIGPLT WARNING : The signal on group ', 274 - - ISW,' is zero within time window; not plotted.' 275 - GOTO 100 276 - ENDIF 277 - * Set the signal plot range. 278 - IF(SAUTO)THEN 279 - SPLMIN=SIGMIN-0.1*(SIGMAX-SIGMIN) 280 - SPLMAX=SIGMAX+0.1*(SIGMAX-SIGMIN) 281 - ENDIF 282 - * Open a frame for the plot. 283 - CALL OUTFMT(REAL(ISW),2,AUX,NC,'LEFT') 284 - CALL GRCART(TPLMIN,SPLMIN,TPLMAX,SPLMAX, 285 - - 'Time [microsec]','Current [microamp]', 286 - - 'Induced currents on group '//AUX(1:NC)) 287 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 288 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 289 - IF(PARTID.NE.'Unknown') 290 - - CALL GRCOMM(3,'Particle: '//PARTID) 291 - AUX(1:10)='Ion tail: ' 292 - NC=10 293 - IF(LITAIL)THEN 294 - AUX(NC+1:NC+9)='present, ' 295 - NC=NC+9 296 - ELSEIF(LRTAIL)THEN 297 - AUX(NC+1:NC+13)='not sampled, ' 298 - NC=NC+13 299 - ELSEIF(LDTAIL)THEN 300 - AUX(NC+1:NC+10)='detailed, ' 301 - NC=NC+10 302 - ELSE 303 - AUX(NC+1:NC+8)='absent, ' 304 - NC=NC+8 305 - ENDIF 306 - AUX(NC+1:NC+16)='electron pulse: ' 307 - NC=NC+16 308 - IF(LEPULS)THEN 309 - AUX(NC+1:NC+7)='present' 310 - NC=NC+7 311 - ELSE 312 - AUX(NC+1:NC+6)='absent' 313 - NC=NC+6 314 - ENDIF 315 - CALL GRCOMM(4,AUX(1:NC)) 316 - * Plot the direct signal of the wire. 317 - IF(LPLDIR)THEN 318 - CALL GRATTS('FUNCTION-1','POLYLINE') 319 - CALL GRLINE(ITMAX-ITMIN+1,TIMSIG(ITMIN),SIGNAL(ITMIN,ISW,1)) 320 - ENDIF 321 - * Plot the cross induced signal for the wire. 322 - IF(LCROSS.AND.LPLCR)THEN 323 - CALL GRATTS('FUNCTION-2','POLYLINE') 324 - CALL GRLINE(ITMAX-ITMIN+1,TIMSIG(ITMIN),SIGNAL(ITMIN,ISW,2)) 325 - ENDIF 326 - * Remember that we plotted a signal. 327 - NPLOT=NPLOT+1 328 - * Close the plot. 329 - CALL GRNEXT 330 - * Log the plot, 331 - CALL OUTFMT(REAL(ISW),2,AUX,NC,'LEFT') 332 - CALL GRALOG('Signals on group '//AUX(1:NC)//'.') 333 - 100 CONTINUE 334 - *** Print a warning if no plot was made. 335 - IF(NPLOT.EQ.0)PRINT *,' !!!!!! SIGPLT WARNING : No signal'// 336 - - ' eligible for plotting found.' 337 - *** Register the amount of CPU time used. 338 - CALL TIMLOG('Plotting the signals: ') 339 - END 755 GARFIELD ================================================== P=SIGNAL D=SIGCNV 1 ============================ 0 + +DECK,SIGCNV. 1 - SUBROUTINE SIGCNV(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGCNV - Convolutes the signals with a transfer function. 4 - * VARIABLES : 5 - * (Last changed on 1/ 2/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,SIGNALDATA. 10.- +SEQ,CELLDATA. 11.- +SEQ,GLOBALS. 12.- +SEQ,PRINTPLOT. 13 - CHARACTER*(MXCHAR) FCNCNV,FCNADD 14 - CHARACTER*10 VAR(MXVAR),NAME 15 - LOGICAL USE(MXVAR) 16 - INTEGER MODVAR(MXVAR),MODRES(1),IENTRY,IENADD,NCCNV,NCADD,IORD, 17 - - IORDR,I,J,K,IFAIL,IRTRAN,ISTRAN,IRTIME,ISTIME,MATSLT,NCNAME, 18 - - NERR,NRES,ISW,IFAIL1,IFAIL2,INEXT,NWORD,INPCMP 19 - REAL RES(1),AUX(MXLIST),CNVTAB(1-MXLIST:MXLIST-1), 1 755 P=SIGNAL D=SIGCNV 2 PAGE1154 20 - - VAL(MXVAR),CNVMIN,CNVMAX,CNVMIR,CNVMAR 21 - EXTERNAL MATSLT,INPCMP 0 22-+ +SELF,IF=SAVE. 23 - SAVE FCNCNV,NCCNV,CNVMIN,CNVMAX,IENTRY,IRTRAN,IRTIME,IORD 0 24-+ +SELF. 25 - DATA FCNCNV(1:1)/' '/ 26 - DATA NCCNV /1/, CNVMIN /0.0/, CNVMAX /1.0E10/, IENTRY /0/, 27 - - IRTRAN /0/, IRTIME /0/, IORD /2/ 28 - *** Identify the routine. 29 - IF(LIDENT)PRINT *,' /// ROUTINE SIGCNV ///' 30 - *** Reset the add-on function each time. 31 - NCADD=1 32 - IENADD=0 33 - FCNADD=' ' 34 - *** Reset matrix slot numbers. 35 - ISTIME=0 36 - ISTRAN=0 37 - *** Get hold of the number of words. 38 - CALL INPNUM(NWORD) 39 - *** Read the words. 40 - INEXT=1 41 - DO 100 I=2,NWORD 42 - IF(INEXT.GT.I)GOTO 100 43 - * Check for TRANSFER-FUNCTION. 44 - IF(INPCMP(I,'TR#ANSFER-F#UNCTION').NE.0)THEN 45 - IF(I+1.GT.NWORD)THEN 46 - CALL INPMSG(I,'The function is not specified.') 47 - ELSEIF(INPCMP(I+2,'VS').NE.0.AND.I+3.LE.NWORD)THEN 48 - IRTIME=0 49 - IRTRAN=0 50 - CALL INPSTR(I+1,I+1,NAME,NCNAME) 51 - DO 110 J=1,NGLB 52 - IF(GLBMOD(J).EQ.5.AND.GLBVAR(J).EQ.NAME(1:NCNAME)) 53 - - IRTRAN=NINT(GLBVAL(J)) 54 - 110 CONTINUE 55 - ISTRAN=MATSLT(IRTRAN) 56 - CALL INPSTR(I+3,I+3,NAME,NCNAME) 57 - DO 120 J=1,NGLB 58 - IF(GLBMOD(J).EQ.5.AND.GLBVAR(J).EQ.NAME(1:NCNAME)) 59 - - IRTIME=NINT(GLBVAL(J)) 60 - 120 CONTINUE 61 - ISTIME=MATSLT(IRTIME) 62 - IF(ISTIME.EQ.0)CALL INPMSG(I+1,'Not a known matrix') 63 - IF(ISTRAN.EQ.0)CALL INPMSG(I+3,'Not a known matrix') 64 - INEXT=I+4 65 - IF(IENTRY.GT.0)THEN 66 - CALL ALGCLR(IENTRY) 67 - IENTRY=0 68 - ENDIF 69 - ELSE 70 - CALL INPSTR(I+1,I+1,FCNCNV,NCCNV) 71 - IF(NCCNV.GT.0.AND.IENTRY.GT.0)THEN 72 - CALL ALGCLR(IENTRY) 73 - IENTRY=0 74 - ENDIF 75 - INEXT=I+2 76 - IRTIME=0 77 - IRTRAN=0 78 - ENDIF 79 - * Check for ADD. 80 - ELSEIF(INPCMP(I,'ADD-#ON-#FUNCTION').NE.0)THEN 81 - IF(I+1.GT.NWORD)THEN 82 - CALL INPMSG(I,'The function is not specified.') 83 - ELSE 84 - CALL INPSTR(I+1,I+1,FCNADD,NCADD) 85 - ENDIF 86 - INEXT=I+2 87 - * Check for RANGE. 88 - ELSEIF(INPCMP(I,'RAN#GE').NE.0)THEN 89 - IF(I+2.GT.NWORD)THEN 90 - CALL INPMSG(I,'RANGE incompletely specified.') 91 - ELSE 92 - CALL INPCHK(I+1,2,IFAIL1) 93 - CALL INPCHK(I+2,2,IFAIL2) 94 - CALL INPRDR(I+1,CNVMIR,0.0) 95 - CALL INPRDR(I+2,CNVMAR,1.0E10) 96 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN 97 - CNVMIN=0.0 98 - CNVMAX=1.0E10 99 - ELSEIF(CNVMIR.EQ.CNVMAR)THEN 100 - CALL INPMSG(I+1,'Zero range not permitted.') 101 - CALL INPMSG(I+2,'See previous message.') 102 - CNVMIN=0.0 103 - CNVMAX=1.0E10 104 - ELSE 105 - CNVMIN=MIN(CNVMIR,CNVMAR) 106 - CNVMAX=MAX(CNVMIR,CNVMAR) 107 - ENDIF 108 - ENDIF 109 - INEXT=I+3 110 - * Check for ORDER. 111 - ELSEIF(INPCMP(I,'ORD#ER').NE.0)THEN 112 - IF(I+1.GT.NWORD)THEN 113 - CALL INPMSG(I,'ORDER incompletely specified.') 114 - ELSE 115 - CALL INPCHK(I+1,1,IFAIL1) 116 - CALL INPRDI(I+1,IORDR,IORD) 117 - IF(IFAIL1.EQ.0.AND.IORDR.GE.1)THEN 118 - IORD=IORDR 119 - ELSEIF(IFAIL1.EQ.0)THEN 120 - CALL INPMSG(I+1,'Should be 1 or larger.') 121 - ENDIF 122 - ENDIF 123 - INEXT=I+2 1 755 P=SIGNAL D=SIGCNV 3 PAGE1155 124 - * Other keywords are not recognised. 125 - ELSE 126 - CALL INPMSG(I,'Unknown keyword.') 127 - ENDIF 128 - 100 CONTINUE 129 - *** Print error messages. 130 - CALL INPERR 131 - *** Debugging output. 132 - IF(LDEBUG)THEN 133 - IF(NCCNV.LE.0)THEN 134 - WRITE(LUNOUT,'('' ++++++ SIGCNV DEBUG : No'', 135 - - '' transfer function, IENTRY='',I5)') IENTRY 136 - ELSE 137 - WRITE(LUNOUT,'('' ++++++ SIGCNV DEBUG :'', 138 - - '' Transfer function: '',A/26X,''Valid for '', 139 - - E15.8,'' <= t <= '',E15.8,'' [microsec]''/26X, 140 - - ''Add-on function: '',A/26X, 141 - - ''Interpolate global '',I5,'' vs '',I5/26X, 142 - - ''Entry point transfer function: '',I5)') 143 - - FCNCNV(1:MAX(1,NCCNV)),CNVMIN,CNVMAX, 144 - - FCNADD(1:MAX(1,NCADD)),IRTRAN,IRTIME,IENTRY 145 - ENDIF 146 - ENDIF 147 - *** Ensure that there is a transfer function. 148 - IF(IENTRY.LE.0.AND. 149 - - (ISTIME.LE.0.OR.ISTRAN.LE.0).AND. 150 - - (NCCNV.LE.0.OR.FCNCNV.EQ.' '))THEN 151 - PRINT *,' !!!!!! SIGCNV WARNING : No transfer function'// 152 - - ' available ; no convolution done.' 153 - IFAIL=1 154 - RETURN 155 - ENDIF 156 - *** Test for the time range. 157 - IF(.NOT.RESSET)THEN 158 - PRINT *,' !!!!!! SIGCNV WARNING : The time window has'// 159 - - ' not yet been set; no convolution done.' 160 - IFAIL=1 161 - RETURN 162 - ENDIF 163 - *** Translate the transfer function, if there is no entry point yet. 164 - IF(IENTRY.LE.0.AND.(ISTIME.LE.0.OR.ISTRAN.LE.0))THEN 165 - VAR(1)='T ' 166 - CALL ALGPRE(FCNCNV(1:NCCNV),NCCNV,VAR,1, 167 - - NRES,USE,IENTRY,IFAIL1) 168 - * Verify that the translation worked correctly. 169 - IF(IFAIL1.NE.0)THEN 170 - PRINT *,' !!!!!! SIGCNV WARNING : Transfer function'// 171 - - ' could not be translated ; no convolutions done.' 172 - CALL ALGCLR(IENTRY) 173 - IENTRY=0 174 - NCCNV=0 175 - IFAIL=1 176 - RETURN 177 - * Make sure that there is only one result coming back. 178 - ELSEIF(NRES.NE.1)THEN 179 - PRINT *,' !!!!!! SIGCNV WARNING : The transfer'// 180 - - ' function does not return 1 result ; no'// 181 - - ' convolutions done.' 182 - CALL ALGCLR(IENTRY) 183 - IENTRY=0 184 - NCCNV=0 185 - IFAIL=1 186 - RETURN 187 - * Ensure there is a time dependence. 188 - ELSEIF(.NOT.USE(1))THEN 189 - PRINT *,' ------ SIGCNV MESSAGE : The transfer'// 190 - - ' function does not depend on T.' 191 - ENDIF 192 - ENDIF 193 - *** Translate the add function, if there is no entry point yet. 194 - IF(FCNADD.NE.' ')THEN 195 - VAR(1)='T ' 196 - VAR(2)='SIGNAL ' 197 - CALL ALGPRE(FCNADD(1:NCADD),NCADD,VAR,2, 198 - - NRES,USE,IENADD,IFAIL1) 199 - * Verify that the translation worked correctly. 200 - IF(IFAIL1.NE.0)THEN 201 - PRINT *,' !!!!!! SIGCNV WARNING : The add function'// 202 - - ' could not be translated ; nothing added.' 203 - CALL ALGCLR(IENADD) 204 - IENADD=0 205 - NCADD=0 206 - * Make sure that there is only one result coming back. 207 - ELSEIF(NRES.NE.1)THEN 208 - PRINT *,' !!!!!! SIGCNV WARNING : The add-on'// 209 - - ' function does not return 1 result ; nothing'// 210 - - ' added.' 211 - CALL ALGCLR(IENADD) 212 - IENADD=0 213 - NCADD=0 214 - ENDIF 215 - ELSE 216 - IENADD=0 217 - ENDIF 218 - *** Reset the error counter. 219 - NERR=0 220 - *** Evaluate the transfer function. 221 - ISTIME=0 222 - ISTRAN=0 223 - DO 90 I=1,NTIME 224 - * Negative time part. 225 - VAL(1)=TIMSIG(1)-TIMSIG(I) 226 - MODVAR(1)=2 227 - IF(VAL(1).LT.CNVMIN.OR.VAL(1).GT.CNVMAX)THEN 228 - CNVTAB(1-I)=0 229 - ELSEIF(IENTRY.GT.0)THEN 1 755 P=SIGNAL D=SIGCNV 4 PAGE1156 230 - CALL ALGEXE(IENTRY,VAL,MODVAR,1,RES,MODRES,1,IFAIL1) 231 - IF(IFAIL1.EQ.0.AND.MODRES(1).EQ.2)THEN 232 - CNVTAB(1-I)=RES(1) 233 - ELSE 234 - CNVTAB(1-I)=0 235 - NERR=NERR+1 236 - ENDIF 237 - ELSE 238 - IF(NERR.EQ.0)THEN 239 - CALL MATIN1(IRTIME,IRTRAN,1,VAL(1),CNVTAB(1-I), 240 - - ISTIME,ISTRAN,IORD,IFAIL1) 241 - IF(IFAIL1.NE.0)NERR=NERR+1 242 - ELSE 243 - CNVTAB(1-I)=0 244 - NERR=NERR+1 245 - ENDIF 246 - ENDIF 247 - * Positive time part. 248 - IF(I.EQ.1)GOTO 90 249 - VAL(1)=TIMSIG(I)-TIMSIG(1) 250 - MODVAR(1)=2 251 - IF(VAL(1).LT.CNVMIN.OR.VAL(1).GT.CNVMAX)THEN 252 - CNVTAB(I-1)=0 253 - ELSEIF(IENTRY.GT.0)THEN 254 - CALL ALGEXE(IENTRY,VAL,MODVAR,1,RES,MODRES,1,IFAIL1) 255 - IF(IFAIL1.EQ.0.AND.MODRES(1).EQ.2)THEN 256 - CNVTAB(I-1)=RES(1) 257 - ELSE 258 - CNVTAB(I-1)=0 259 - NERR=NERR+1 260 - ENDIF 261 - ELSE 262 - IF(NERR.EQ.0)THEN 263 - CALL MATIN1(IRTIME,IRTRAN,1,VAL(1),CNVTAB(I-1), 264 - - ISTIME,ISTRAN,IORD,IFAIL1) 265 - IF(IFAIL1.NE.0)NERR=NERR+1 266 - ELSE 267 - NERR=NERR+1 268 - CNVTAB(I-1)=0 269 - ENDIF 270 - ENDIF 271 - 90 CONTINUE 272 - *** Print error messages, if applicable. 273 - IF(NERR.NE.0)PRINT *,' !!!!!! SIGCNV WARNING : In total ',NERR, 274 - - ' terms skipped in convolutions for arithmetic/mode errors.' 275 - CALL ALGERR 276 - NERR=0 277 - *** Loop over all (groups of) sense wires. 278 - DO 10 ISW=1,NSW 279 - DO 20 J=1,NTIME 280 - * Add the add-on function. 281 - IF(IENADD.GT.0)THEN 282 - VAL(1)=TIMSIG(J) 283 - MODVAR(1)=2 284 - VAL(2)=SIGNAL(J,ISW,1) 285 - MODVAR(2)=2 286 - CALL ALGEXE(IENADD,VAL,MODVAR,2,RES,MODRES,1,IFAIL1) 287 - IF(IFAIL1.NE.0.OR.MODRES(1).NE.2)THEN 288 - AUX(J)=0 289 - NERR=NERR+1 290 - ELSE 291 - AUX(J)=RES(1) 292 - ENDIF 293 - ELSE 294 - AUX(J)=0 295 - ENDIF 296 - * Do the actual convolution. 297 - DO 30 K=1,NTIME 298 - AUX(J)=AUX(J)+TDEV*CNVTAB(J-K)*SIGNAL(K,ISW,1) 299 - 30 CONTINUE 300 - 20 CONTINUE 301 - DO 70 J=1,NTIME 302 - SIGNAL(J,ISW,1)=AUX(J) 303 - 70 CONTINUE 304 - ** Cross induced signals. 305 - IF(LCROSS)THEN 306 - DO 40 J=1,NTIME 307 - * Add the add-on function. 308 - IF(IENADD.GT.0)THEN 309 - VAL(1)=TIMSIG(J) 310 - MODVAR(1)=2 311 - VAL(2)=SIGNAL(J,ISW,2) 312 - MODVAR(2)=2 313 - CALL ALGEXE(IENADD,VAL,MODVAR,2,RES,MODRES,1,IFAIL1) 314 - IF(IFAIL1.NE.0.OR.MODRES(1).NE.2)THEN 315 - AUX(J)=0 316 - NERR=NERR+1 317 - ELSE 318 - AUX(J)=RES(1) 319 - ENDIF 320 - ELSE 321 - AUX(J)=0 322 - ENDIF 323 - * Do the actual convolutions. 324 - DO 50 K=1,NTIME 325 - AUX(J)=AUX(J)+TDEV*CNVTAB(J-K)*SIGNAL(K,ISW,2) 326 - 50 CONTINUE 327 - 40 CONTINUE 328 - ENDIF 329 - DO 60 J=1,NTIME 330 - SIGNAL(J,ISW,2)=AUX(J) 331 - 60 CONTINUE 332 - 10 CONTINUE 333 - *** Print error messages. 334 - IF(NERR.NE.0)PRINT *,' !!!!!! SIGCNV WARNING : In total ',NERR, 335 - - ' add-on terms skipped for arithmetic/mode errors.' 1 755 P=SIGNAL D=SIGCNV 5 PAGE1157 336 - CALL ALGERR 337 - *** Get rid of add function. 338 - IF(IENADD.GT.0)CALL ALGCLR(IENADD) 339 - *** Things seem to have worked. 340 - IFAIL=0 341 - *** Register the amount of CPU time used. 342 - CALL TIMLOG('Convoluting with transfer function: ') 343 - END 756 GARFIELD ================================================== P=SIGNAL D=SIGNOI 1 ============================ 0 + +DECK,SIGNOI. 1 - SUBROUTINE SIGNOI(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGNOI - Adds noise to the signals, 4 - * VARIABLES : 5 - * (Last changed on 16/ 1/00.) 6 - *----------------------------------------------------------------------- 7 - implicit none 8.- +SEQ,DIMENSIONS. 9.- +SEQ,SIGNALDATA. 10.- +SEQ,CELLDATA. 11.- +SEQ,PRINTPLOT. 12 - CHARACTER*(MXCHAR) FCNNOI 13 - CHARACTER*10 VAR(MXVAR) 14 - LOGICAL USE(MXVAR) 15 - INTEGER MODVAR(MXVAR),MODRES(1),IENTRY,NCNOI,I,J,INEXT,IFAIL, 16 - - IFAIL1,NRES,NWORD,ISW,NERR,INPCMP 17 - REAL RES(1),AUX(MXLIST),VAL(MXVAR) 18 - EXTERNAL INPCMP 0 19-+ +SELF,IF=SAVE. 20 - SAVE FCNNOI,NCNOI,IENTRY 0 21-+ +SELF. 22 - DATA FCNNOI(1:1)/' '/ 23 - DATA NCNOI /1/, IENTRY /0/ 24 - *** Identify the routine. 25 - IF(LIDENT)PRINT *,' /// ROUTINE SIGNOI ///' 26 - *** Get hold of the number of words. 27 - CALL INPNUM(NWORD) 28 - *** Read the words. 29 - INEXT=1 30 - DO 100 I=2,NWORD 31 - IF(INEXT.GT.I)GOTO 100 32 - * Check for NOISE-FUNCTION. 33 - IF(INPCMP(I,'NOISE-#FUNCTION').NE.0)THEN 34 - IF(I+1.GT.NWORD)THEN 35 - CALL INPMSG(I,'The function is not specified.') 36 - ELSE 37 - CALL INPSTR(I+1,I+1,FCNNOI,NCNOI) 38 - IF(NCNOI.GT.0.AND.IENTRY.GT.0)THEN 39 - CALL ALGCLR(IENTRY) 40 - IENTRY=0 41 - ENDIF 42 - ENDIF 43 - INEXT=I+2 44 - * Other keywords are not known. 45 - ELSE 46 - CALL INPMSG(I,'Unknown keyword.') 47 - ENDIF 48 - 100 CONTINUE 49 - *** Print error messages. 50 - CALL INPERR 51 - *** Debugging output. 52 - IF(LDEBUG)THEN 53 - IF(NCNOI.LE.0)THEN 54 - WRITE(LUNOUT,'('' ++++++ SIGNOI DEBUG : No'', 55 - - '' noise function, IENTRY='',I5)') IENTRY 56 - ELSE 57 - WRITE(LUNOUT,'('' ++++++ SIGNOI DEBUG :'', 58 - - '' Noise function: '',A/26X,''Entry='',I5)') 59 - - FCNNOI(1:NCNOI),IENTRY 60 - ENDIF 61 - ENDIF 62 - *** Ensure that there is a noise function. 63 - IF(IENTRY.LE.0.AND.(NCNOI.LE.0.OR.FCNNOI.EQ.' '))THEN 64 - PRINT *,' !!!!!! SIGNOI WARNING : No noise function'// 65 - - ' available ; no noise added.' 66 - IFAIL=1 67 - RETURN 68 - ENDIF 69 - *** Test for the time range. 70 - IF(.NOT.RESSET)THEN 71 - PRINT *,' !!!!!! SIGNOI WARNING : The time window has'// 72 - - ' not yet been set; no noise added.' 73 - IFAIL=1 74 - RETURN 75 - ENDIF 76 - *** Translate the noise function, if there is no entry point yet. 77 - IF(IENTRY.LE.0)THEN 78 - VAR(1)='T ' 79 - CALL ALGPRE(FCNNOI(1:NCNOI),NCNOI,VAR,1, 80 - - NRES,USE,IENTRY,IFAIL1) 81 - * Verify that the translation worked correctly. 82 - IF(IFAIL1.NE.0)THEN 83 - PRINT *,' !!!!!! SIGNOI WARNING : Noise function'// 84 - - ' could not be translated ; no noise added.' 85 - CALL ALGCLR(IENTRY) 86 - IENTRY=0 87 - NCNOI=0 88 - IFAIL=1 89 - RETURN 90 - * Make sure that there is only one result coming back. 91 - ELSEIF(NRES.NE.1)THEN 92 - PRINT *,' !!!!!! SIGNOI WARNING : The noise'// 1 756 P=SIGNAL D=SIGNOI 2 PAGE1158 93 - - ' function does not return 1 result ; no'// 94 - - ' noise added.' 95 - CALL ALGCLR(IENTRY) 96 - IENTRY=0 97 - NCNOI=0 98 - IFAIL=1 99 - RETURN 100 - * Ensure there is a time dependence. 101 - C ELSEIF(.NOT.USE(1))THEN 102 - C PRINT *,' ------ SIGNOI WARNING : The noise'// 103 - C - ' function does not depend on T.' 104 - ENDIF 105 - ENDIF 106 - *** Reset the error counter. 107 - NERR=0 108 - *** Loop over all (groups of) sense wires. 109 - DO 10 ISW=1,NSW 110 - DO 20 J=1,NTIME 111 - VAL(1)=TIMSIG(J) 112 - MODVAR(1)=2 113 - CALL ALGEXE(IENTRY,VAL,MODVAR,1,RES,MODRES,1,IFAIL1) 114 - IF(IFAIL1.EQ.0.AND.MODRES(1).EQ.2)THEN 115 - AUX(J)=RES(1) 116 - ELSE 117 - AUX(J)=0 118 - NERR=NERR+1 119 - ENDIF 120 - 20 CONTINUE 121 - DO 30 J=1,NTIME 122 - SIGNAL(J,ISW,1)=SIGNAL(J,ISW,1)+AUX(J) 123 - IF(LCROSS)SIGNAL(J,ISW,2)=SIGNAL(J,ISW,2)+AUX(J) 124 - 30 CONTINUE 125 - 10 CONTINUE 126 - *** Print error messages, if applicable. 127 - IF(NERR.NE.0)PRINT *,' !!!!!! SIGNOI WARNING : In total ',NERR, 128 - - ' noise terms skipped for arithmetic/mode errors.' 129 - CALL ALGERR 130 - *** Things seem to have worked. 131 - IFAIL=0 132 - *** Register the amount of CPU time used. 133 - CALL TIMLOG('Adding noise to the signals: ') 134 - END 757 GARFIELD ================================================== P=SIGNAL D=SIGTHC 1 ============================ 0 + +DECK,SIGTHC. 1 - SUBROUTINE SIGTHC(ISW,SCR,OPTION,NCR,TCR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGTHC - Computes threshold crossings 4 - * (Last changed on 8/ 9/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,SIGNALDATA. 10.- +SEQ,PRINTPLOT. 11.- +SEQ,PARAMETERS. 12 - REAL TCR(MXLIST),SCR,VEC(MXLIST),VNEW,XPL(2),YPL(2),VECMIN, 13 - - VECMAX,DIVDIF 14 - INTEGER ISW,NCR,IDIR,IORD,JORD,I,IFAIL,NC,IORG,NVEC 15 - LOGICAL LPLOT 16 - CHARACTER*(*) OPTION 17 - CHARACTER*20 AUX 18 - EXTERNAL DIVDIF 19 - *** Assume this will fail. 20 - IFAIL=1 21 - *** Initial settings. 22 - NCR=0 23 - *** Check the sense wire group. 24 - IF(ISW.LE.0.OR.ISW.GT.NSW)THEN 25 - PRINT *,' !!!!!! SIGTRC WARNING : Electrode group is'// 26 - - ' out of range; no crossings computed.' 27 - RETURN 28 - ENDIF 29 - *** Decode the option string. 30 - IDIR=+1 31 - LPLOT=.FALSE. 32 - JORD=1 33 - IF(INDEX(OPTION,'RISING').NE.0) IDIR=+1 34 - IF(INDEX(OPTION,'UP').NE.0) IDIR=+1 35 - IF(INDEX(OPTION,'TRAILING').NE.0) IDIR=-1 36 - IF(INDEX(OPTION,'FALLING').NE.0) IDIR=-1 37 - IF(INDEX(OPTION,'DOWN').NE.0) IDIR=-1 38 - IF(INDEX(OPTION,'PLOT').NE.0) LPLOT=.TRUE. 39 - IF(INDEX(OPTION,'NOPLOT').NE.0) LPLOT=.FALSE. 40 - IF(INDEX(OPTION,'LINEAR').NE.0) JORD=1 41 - IF(INDEX(OPTION,'PARABOLA').NE.0) JORD=2 42 - IF(INDEX(OPTION,'PARABOLIC').NE.0)JORD=2 43 - IF(INDEX(OPTION,'QUADRATIC').NE.0)JORD=2 44 - IF(INDEX(OPTION,'CUBIC').NE.0) JORD=3 45 - *** Debugging output. 46 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGTHC DEBUG : Computing'', 47 - - '' threshold crossings for''/ 48 - - 26X,''sense wire number '',I3/ 49 - - 26X,''polynomial order '',I3/ 50 - - 26X,''rising/falling '',I3/ 51 - - 26X,''plot interpolation '',L3)') ISW,JORD,IDIR,LPLOT 52 - *** Prepare the plot frame if required. 53 - IF(LPLOT)THEN 54 - * Prepare vectors, establish range. 55 - DO 100 I=1,NTIME 56 - VEC(I)=SIGNAL(I,ISW,1) 57 - IF(LCROSS)VEC(I)=VEC(I)+SIGNAL(I,ISW,2) 58 - IF(I.EQ.1)THEN 59 - VECMAX=VEC(1) 60 - VECMIN=VEC(1) 1 757 P=SIGNAL D=SIGTHC 2 PAGE1159 61 - ELSE 62 - VECMAX=MAX(VECMAX,VEC(I)) 63 - VECMIN=MIN(VECMIN,VEC(I)) 64 - ENDIF 65 - 100 CONTINUE 66 - * Plot the frame. 67 - CALL GRCART(TIMSIG(1),VECMIN-0.1*(VECMAX-VECMIN), 68 - - TIMSIG(NTIME),VECMAX+0.1*(VECMAX-VECMIN), 69 - - 'Time [microsec]','Signal [microamp]', 70 - - 'Check on threshold crossings') 71 - * Plot the signal. 72 - CALL GRATTS('FUNCTION-1','POLYLINE') 73 - CALL GRLINE(NTIME,TIMSIG,VEC) 74 - * Next are the signal segments, plotted as FUNCTION-2. 75 - CALL GRATTS('FUNCTION-2','POLYLINE') 76 - ENDIF 77 - *** Scan the signal vectors, initialise. 78 - NVEC=1 79 - IORG=1 80 - VEC(1)=SIGNAL(1,ISW,1) 81 - IF(LCROSS)VEC(1)=VEC(1)+SIGNAL(1,ISW,2) 82 - * Loop over the elements. 83 - DO 10 I=2,NTIME 84 - * Compute the vector element. 85 - VNEW=SIGNAL(I,ISW,1) 86 - IF(LCROSS)VNEW=VNEW+SIGNAL(I,ISW,2) 87 - * If still increasing or decreasing, add to the vector. 88 - IF((IDIR.GT.0.AND.VNEW.GT.VEC(NVEC)).OR. 89 - - (IDIR.LT.0.AND.VNEW.LT.VEC(NVEC)))THEN 90 - NVEC=NVEC+1 91 - VEC(NVEC)=VNEW 92 - * Otherwise see whether we crossed the threshold level. 93 - ELSEIF((VEC(1)-SCR)*(SCR-VEC(NVEC)).GE.0.AND. 94 - - NVEC.GT.1.AND. 95 - - ((IDIR.GT.0.AND.VEC(NVEC).GT.VEC(1)).OR. 96 - - (IDIR.LT.0.AND.VEC(NVEC).LT.VEC(1))))THEN 97 - NCR=NCR+1 98 - IORD=MIN(NVEC-1,JORD) 99 - TCR(NCR)=DIVDIF(TIMSIG(IORG),VEC,NVEC,SCR,IORD) 100 - IF(LPLOT)CALL GRLINE(NVEC,TIMSIG(IORG),VEC) 101 - NVEC=1 102 - IORG=I 103 - VEC(NVEC)=VNEW 104 - * No crossing, simply reset the vector. 105 - ELSE 106 - NVEC=1 107 - IORG=I 108 - VEC(NVEC)=VNEW 109 - ENDIF 110 - 10 CONTINUE 111 - *** Check the final vector. 112 - IF((VEC(1)-SCR)*(SCR-VEC(NVEC)).GE.0.AND. 113 - - NVEC.GT.1.AND. 114 - - ((IDIR.GT.0.AND.VEC(NVEC).GT.VEC(1)).OR. 115 - - (IDIR.LT.0.AND.VEC(NVEC).LT.VEC(1))))THEN 116 - NCR=NCR+1 117 - IORD=MIN(NVEC-1,JORD) 118 - TCR(NCR)=DIVDIF(TIMSIG(IORG),VEC,NVEC,SCR,IORD) 119 - IF(LPLOT)CALL GRLINE(NVEC,TIMSIG(IORG),VEC) 120 - ENDIF 121 - *** Finish the plot if required. 122 - IF(LPLOT)THEN 123 - CALL GRATTS('FUNCTION-3','POLYLINE') 124 - * Plot the threshold level. 125 - XPL(1)=TIMSIG(1) 126 - XPL(2)=TIMSIG(NTIME) 127 - YPL(1)=SCR 128 - YPL(2)=SCR 129 - CALL GRLINE(2,XPL,YPL) 130 - * Plot each of the times. 131 - DO 120 I=1,NCR 132 - XPL(1)=TCR(I) 133 - XPL(2)=TCR(I) 134 - YPL(1)=VECMIN-0.1*(VECMAX-VECMIN) 135 - YPL(2)=SCR 136 - CALL GRLINE(2,XPL,YPL) 137 - 120 CONTINUE 138 - * And add some comment strings. 139 - CALL OUTFMT(REAL(NCR),2,AUX,NC,'LEFT') 140 - CALL GRCOMM(1,'Crossings: '//AUX(1:NC)) 141 - CALL OUTFMT(REAL(JORD),2,AUX,NC,'LEFT') 142 - CALL GRCOMM(3,'Interpolation order: '//AUX(1:NC)) 143 - IF(IDIR.EQ.+1)THEN 144 - CALL GRCOMM(2,'Hunting: rising edges') 145 - ELSE 146 - CALL GRCOMM(2,'Hunting: falling edges') 147 - ENDIF 148 - IF(PARTID.NE.'Unknown') 149 - - CALL GRCOMM(4,'Particle: '//PARTID) 150 - * Close the frame. 151 - CALL GRNEXT 152 - ENDIF 153 - *** Things seem to have worked. 154 - IFAIL=0 155 - END 758 GARFIELD ================================================== P=SIGNAL D=SIGMCA 1 ============================ 0 + +DECK,SIGMCA. 1 - SUBROUTINE SIGMCA(X1,Y1,Z1,NETOT,NITOT,STAT, 2 - - NHIST,IHIST,ITYPE,IENTRY,OPTION) 3 - *----------------------------------------------------------------------- 4 - * SIGMCA - Subroutine that computes a drift line using a Monte-Carlo 5 - * technique to take account of diffusion and of avalanche 6 - * formation. Adds optionally the induced currents. 7 - * VARIABLES : 1 758 P=SIGNAL D=SIGMCA 2 PAGE1160 8 - * REFERENCE : 9 - * (Last changed on 7/ 3/01.) 10 - *----------------------------------------------------------------------- 11 - implicit none 12.- +SEQ,DIMENSIONS. 13.- +SEQ,CELLDATA. 14.- +SEQ,GASDATA. 15.- +SEQ,PARAMETERS. 16.- +SEQ,DRIFTLINE. 17.- +SEQ,PRINTPLOT. 18.- +SEQ,CONSTANTS. 19 - INTEGER MXVEC 20 - PARAMETER(MXVEC=10000) 21 - REAL XLIST(MXMCA),YLIST(MXMCA),ZLIST(MXMCA),TLIST(MXMCA), 22 - - Q,X1,Y1,Z1,GASTWN,GASATT,PROBTH,PALPHA,PETA,TOFF, 23 - - ALPHA(MXLIST),ETA(MXLIST),RVECU(MXVEC),RVECN(MXVEC) 24 - INTEGER IFAIL,NLIST(MXMCA),NMCA,IPART,I,J,K,L,IMCA,NINTER, 25 - - NELEC,NION,NETOT,NITOT,NHIST,IHIST(*),IENTRY(*),ITYPE(2,*), 26 - - IVECU,IVECN,NEW,NMAX 27 - LOGICAL LELEPL,LIONPL,LTOWN,LATTA,STAT(4),CROSS,LESIG,LISIG, 28 - - LPRINT 29 - COMMON /MCAMAT/ XLIST,YLIST,ZLIST,TLIST,NLIST 30 - CHARACTER*(*) OPTION 31 - EXTERNAL GASTWN,GASATT 32 - *** Identify the routine if requested. 33 - IF(LIDENT)PRINT *,' /// ROUTINE SIGMCA ///' 34 - *** Initial debugging output. 35 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGMCA DEBUG : MC drift'', 36 - - '' from ('',E15.8,'','',E15.8,'','',E15.8,'')'')') X1,Y1,Z1 37 - *** Make sure that electron drift velocities are available. 38 - IF(.NOT.GASOK(1))THEN 39 - PRINT *,' !!!!!! SIGMCA WARNING : Electron drift velocity'// 40 - - ' data missing; no avalanche.' 41 - RETURN 42 - ENDIF 43 - *** Obtain the matrix to store the avalanche development. 44 - CALL BOOK('BOOK','MCAMAT','MCA',IFAIL) 45 - IF(IFAIL.NE.0)THEN 46 - PRINT *,' !!!!!! SIGMCA WARNING : Unable to obtain'// 47 - - ' storage for the avalanche; avalanche not computed.' 48 - RETURN 49 - ENDIF 50 - *** Default options. 51 - LELEPL=.FALSE. 52 - LIONPL=.FALSE. 53 - LTOWN=GASOK(4) 54 - LATTA=GASOK(6) 55 - NMAX=0 56 - LESIG=.FALSE. 57 - LISIG=.TRUE. 58 - CROSS=.TRUE. 59 - LPRINT=.FALSE. 60 - *** Default settings of parameters. 61 - PROBTH=0.01 62 - *** Decode the options. 63 - IF(INDEX(OPTION,'NOION-TAIL').NE.0)THEN 64 - LISIG=.FALSE. 65 - ELSEIF(INDEX(OPTION,'ION-TAIL').NE.0)THEN 66 - LISIG=.TRUE. 67 - ENDIF 68 - IF(INDEX(OPTION,'NOELECTRON-PULSE').NE.0)THEN 69 - LESIG=.FALSE. 70 - ELSEIF(INDEX(OPTION,'ELECTRON-PULSE').NE.0)THEN 71 - LESIG=.TRUE. 72 - ENDIF 73 - IF(INDEX(OPTION,'NOCROSS')+INDEX(OPTION,'DIRECT').NE.0)THEN 74 - CROSS=.FALSE. 75 - ELSEIF(INDEX(OPTION,'CROSS').NE.0)THEN 76 - CROSS=.TRUE. 77 - ENDIF 78 - IF(INDEX(OPTION,'NOPLOT-ELECTRON').NE.0)THEN 79 - LELEPL=.FALSE. 80 - ELSEIF(INDEX(OPTION,'PLOT-ELECTRON').NE.0)THEN 81 - LELEPL=.TRUE. 82 - ENDIF 83 - IF(INDEX(OPTION,'NOPLOT-ION').NE.0)THEN 84 - LIONPL=.FALSE. 85 - ELSEIF(INDEX(OPTION,'PLOT-ION').NE.0)THEN 86 - IF(.NOT.GASOK(2))THEN 87 - PRINT *,' !!!!!! SIGMCA WARNING : Ion mobilities are'// 88 - - ' absent; can not compute ion drift lines.' 89 - ELSE 90 - LIONPL=.TRUE. 91 - ENDIF 92 - ENDIF 93 - IF(INDEX(OPTION,'NOTOWNSEND').NE.0)THEN 94 - LTOWN=.FALSE. 95 - ELSEIF(INDEX(OPTION,'TOWNSEND').NE.0.AND..NOT.GASOK(4))THEN 96 - PRINT *,' !!!!!! SIGMCA WARNING : Townsend data is not'// 97 - - ' present; TOWNSEND option not valid.' 98 - ELSEIF(INDEX(OPTION,'TOWNSEND').NE.0)THEN 99 - LTOWN=.TRUE. 100 - ENDIF 101 - IF(INDEX(OPTION,'NOATTACHMENT').NE.0)THEN 102 - LATTA=.FALSE. 103 - ELSEIF(INDEX(OPTION,'ATTACHMENT').NE.0.AND..NOT.GASOK(6))THEN 104 - PRINT *,' !!!!!! SIGMCA WARNING : Attachment data is not'// 105 - - ' present; ATTACHMENT option not valid.' 106 - ELSEIF(INDEX(OPTION,'ATTACHMENT').NE.0)THEN 107 - LATTA=.TRUE. 108 - ENDIF 109 - IF(INDEX(OPTION,'ABORT-100000').NE.0)THEN 110 - NMAX=100000 111 - ELSEIF(INDEX(OPTION,'ABORT-10000').NE.0)THEN 112 - NMAX=10000 113 - ELSEIF(INDEX(OPTION,'ABORT-1000').NE.0)THEN 1 758 P=SIGNAL D=SIGMCA 3 PAGE1161 114 - NMAX=1000 115 - ELSEIF(INDEX(OPTION,'ABORT-100').NE.0)THEN 116 - NMAX=100 117 - ENDIF 118 - IF(INDEX(OPTION,'NOPRINT').NE.0)THEN 119 - LPRINT=.FALSE. 120 - ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN 121 - LPRINT=.TRUE. 122 - ENDIF 123 - *** Make sure that some kind of output has been requested. 124 - IF(.NOT.(LATTA.OR.LTOWN))THEN 125 - PRINT *,' !!!!!! SIGMCA WARNING : Neither attachment not'// 126 - - ' multiplication to be included; no avalanche.' 127 - CALL BOOK('RELEASE','MCAMAT','MCA',IFAIL) 128 - RETURN 129 - ENDIF 130 - *** Initialise the avalanche table. 131 - NMCA=1 132 - XLIST(1)=X1 133 - YLIST(1)=Y1 134 - ZLIST(1)=Z1 135 - TLIST(1)=0 136 - NLIST(1)=1 137 - NETOT=1 138 - NITOT=0 139 - *** Loop over the table. 140 - IMCA=0 141 - 100 CONTINUE 142 - * Check we are still in the table. 143 - IMCA=IMCA+1 144 - IF(IMCA.GT.NMCA)THEN 145 - CALL BOOK('RELEASE','MCAMAT','MCA',IFAIL) 146 - RETURN 147 - ENDIF 148 - *** Loop over the electrons at this location. 149 - DO 40 J=1,NLIST(IMCA) 150 - * Compute an electron drift line. 151 - Q=-1 152 - IPART=1 153 - CALL DLCMC(XLIST(IMCA),YLIST(IMCA),ZLIST(IMCA),Q,IPART) 154 - * Compute alpha and eta vectors. 155 - CALL DLCEQU(ALPHA,ETA,IFAIL) 156 - * Offset the time of the electrons by the starting time. 157 - DO 10 I=1,NU 158 - TU(I)=TU(I)+TLIST(IMCA) 159 - 10 CONTINUE 160 - *** Follow the avalanche development 161 - DO 20 I=1,NU-1 162 - * Set initial number of electrons and ions. 163 - NELEC=1 164 - NION=0 165 - * Compute the number of subdivisions. 166 - NINTER=(ALPHA(I)+ETA(I))/PROBTH 167 - IF(NINTER.LT.1)NINTER=1 168 - *** Loop over the subdivisions. 169 - DO 50 K=1,NINTER 170 - * Probabilities for gain and loss. 171 - PALPHA=ALPHA(I)/REAL(NINTER) 172 - PETA=ETA(I)/REAL(NINTER) 173 - * Gaussian approximation. 174 - IF(NELEC.GT.100)THEN 175 - DATA IVECN/0/ 176 - IF(IVECN.EQ.0.OR.IVECN+2.GT.MXVEC)THEN 177 - CALL RNORML(RVECN,MXVEC) 178 - IVECN=1 179 - ENDIF 180 - IF(LTOWN)THEN 181 - NELEC=NELEC+NINT(REAL(NELEC)*PALPHA+RVECN(IVECN)* 182 - - SQRT(REAL(NELEC)*PALPHA*(1-PALPHA))) 183 - NION=NION+NINT(REAL(NELEC)*PALPHA+RVECN(IVECN)* 184 - - SQRT(REAL(NELEC)*PALPHA*(1-PALPHA))) 185 - IVECN=IVECN+1 186 - ENDIF 187 - IF(LATTA)THEN 188 - NELEC=NELEC-NINT(REAL(NELEC)*PETA+RVECN(IVECN)* 189 - - SQRT(REAL(NELEC)*PETA*(1-PETA))) 190 - IVECN=IVECN+1 191 - ENDIF 192 - * Binomial approximation. 193 - ELSE 194 - NEW=0 195 - DO 80 L=1,NELEC 196 - DATA IVECU/0/ 197 - IF(IVECU.EQ.0.OR.IVECU+2.GT.MXVEC)THEN 198 - CALL RANLUX(RVECU,MXVEC) 199 - IVECU=1 200 - ENDIF 201 - IF(LTOWN)THEN 202 - IF(RVECU(IVECU).LT.PALPHA)THEN 203 - NEW=NEW+1 204 - NION=NION+1 205 - ENDIF 206 - IVECU=IVECU+1 207 - ENDIF 208 - IF(LATTA)THEN 209 - IF(RVECU(IVECU).LT.PETA)NEW=NEW-1 210 - IVECU=IVECU+1 211 - ENDIF 212 - 80 CONTINUE 213 - NELEC=NELEC+NEW 214 - ENDIF 215 - * Verify that there still is an electron. 216 - IF(NELEC.LE.0)THEN 217 - NETOT=NETOT-1 218 - IF(STAT(2))CALL DLCMCF(REAL(XU(I)+XU(I+1))/2, 219 - - REAL(YU(I)+YU(I+1))/2,REAL(ZU(I)+ZU(I+1))/2, 1 758 P=SIGNAL D=SIGMCA 4 PAGE1162 220 - - REAL(TU(I)+TU(I+1))/2,1,NHIST,IHIST, 221 - - ITYPE,IENTRY,2) 222 - IF(LPRINT)WRITE(LUNOUT,'('' Electron '',I5,''/'',I5, 223 - - '' attached at t='',E15.8)') 224 - - J,IMCA,REAL(TU(I)+TU(I+1))/2 225 - GOTO 60 226 - ENDIF 227 - * Next subdivision. 228 - 50 CONTINUE 229 - 60 CONTINUE 230 - *** If at least 1 new electron has been created, add to the table. 231 - IF(NELEC.GT.1)THEN 232 - * Ensure we do not pass the maximum permitted avalanche size. 233 - IF(NMCA+1.GT.NMAX.AND.NMAX.GT.0)THEN 234 - PRINT *,' !!!!!! SIGMCA WARNING : Avalanche exceeds'// 235 - - ' maximum permitted size; avalanche ended.' 236 - CALL BOOK('RELEASE','MCAMAT','MCA',IFAIL) 237 - RETURN 238 - * Ensure there is still space in the table. 239 - ELSEIF(NMCA+1.GT.MXMCA)THEN 240 - PRINT *,' !!!!!! SIGMCA WARNING : Overflow of'// 241 - - ' secondary electron table; avalanche ended.' 242 - CALL BOOK('RELEASE','MCAMAT','MCA',IFAIL) 243 - RETURN 244 - ENDIF 245 - * Add the point to the table, 246 - NMCA=NMCA+1 247 - XLIST(NMCA)=XU(I+1) 248 - YLIST(NMCA)=YU(I+1) 249 - ZLIST(NMCA)=ZU(I+1) 250 - TLIST(NMCA)=TU(I+1) 251 - NLIST(NMCA)=NELEC-1 252 - * And also enter in the overall statistics. 253 - NETOT=NETOT+NELEC-1 254 - * And enter the newly created electrons in the histograms. 255 - IF(STAT(1))CALL DLCMCF(REAL(XU(I)+XU(I+1))/2, 256 - - REAL(YU(I)+YU(I+1))/2,REAL(ZU(I)+ZU(I+1))/2, 257 - - REAL(TU(I)+TU(I+1))/2,NELEC-1,NHIST,IHIST, 258 - - ITYPE,IENTRY,1) 259 - IF(LPRINT)WRITE(LUNOUT,'('' Electron '',I5,''/'',I5, 260 - - '' creates '',I5,'' pairs called '',I5, 261 - - '' at t='',E15.8)') 262 - - J,IMCA,NLIST(NMCA),NMCA,TLIST(NMCA) 263 - ENDIF 264 - *** Also compute the newly produced ions if requested. 265 - IF(NION.GE.1.AND.(LIONPL.OR.STAT(4).OR.LISIG))THEN 266 - * Store offset time. 267 - TOFF=TU(I+1) 268 - * Make a backup of the electron drift line. 269 - CALL DLCBCK('SAVE') 270 - DO 30 K=1,NION 271 - * Compute the ion drift lines. 272 - Q=+1 273 - IPART=2 274 - CALL DLCMC(XLIST(NMCA),YLIST(NMCA),ZLIST(NMCA),Q,IPART) 275 - * Offset the time of the ions by the starting time. 276 - DO 90 L=1,NU 277 - TU(L)=TU(L)+TOFF 278 - 90 CONTINUE 279 - * Add the signals. 280 - IF(LISIG)CALL SIGADS(CROSS,IFAIL) 281 - * Enter the ion end point in the histograms if requested. 282 - IF(STAT(4))CALL DLCMCF(REAL(XU(NU)),REAL(YU(NU)), 283 - - REAL(ZU(NU)),REAL(TU(NU)),1, 284 - - NHIST,IHIST,ITYPE,IENTRY,4) 285 - IF(LPRINT)WRITE(LUNOUT,'('' Ion '',I5,''/'',I5, 286 - - '' stops at t='',E15.8)') J,IMCA,TU(NU) 287 - * Plot the ion drift line. 288 - IF(LIONPL)CALL DLCPLT 289 - 30 CONTINUE 290 - * Restore electron drift line. 291 - CALL DLCBCK('RESTORE') 292 - ENDIF 293 - *** Keep track of ion statistics. 294 - NITOT=NITOT+NION 295 - *** Make sure the electron is still alive. 296 - IF(NELEC.LE.0)THEN 297 - NU=I 298 - GOTO 70 299 - ENDIF 300 - 20 CONTINUE 301 - * If electron survived, register its end point. 302 - IF(STAT(3))CALL DLCMCF(REAL(XU(NU)), 303 - - REAL(YU(NU)),REAL(ZU(NU)),REAL(TU(NU)),1, 304 - - NHIST,IHIST,ITYPE,IENTRY,3) 305 - IF(LPRINT)WRITE(LUNOUT,'('' Electron '',I5,''/'',I5, 306 - - '' stops at t='',E15.8)') J,IMCA,TU(NU) 307 - 70 CONTINUE 308 - * Add the signals. 309 - IF(LESIG)CALL SIGADS(CROSS,IFAIL) 310 - * Plot the electron if requested. 311 - IF(LELEPL)CALL DLCPLT 312 - * Proceed with next electron. 313 - 40 CONTINUE 314 - *** And proceed with the next table entry. 315 - GOTO 100 316 - END 759 GARFIELD ================================================== P=SIGNAL D=SIGCAL 1 ============================ 0 + +DECK,SIGCAL. 1 - SUBROUTINE SIGCAL(INSTR,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGCAL - Processes signal related procedure calls. 4 - * (Last changed on 6/ 1/01.) 5 - *----------------------------------------------------------------------- 1 759 P=SIGNAL D=SIGCAL 2 PAGE1163 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,SIGNALDATA. 9.- +SEQ,CELLDATA. 10.- +SEQ,GASDATA. 11.- +SEQ,MATDATA. 12.- +SEQ,ALGDATA. 13.- +SEQ,CONSTANTS. 14.- +SEQ,DRIFTLINE. 15 - INTEGER MXAHIS 16 - PARAMETER(MXAHIS=20) 17 - INTEGER MATSLT,IPROC,IWRONG,NC,NARG,IFAIL,IFAIL1,IFAIL2,IFAIL3, 18 - - NCR,IQ,IA,IW,ISW,ISIZ(MXMDIM),INSTR,IRTIM,ISTIM,IRDIR,ISDIR, 19 - - IRCROS,ISCROS,NSIG,IREF(6),ISLOT(6),NDAT,IDIM, 20 - - I,J,JTYPE,NCOPT,NREXP,ITYPE(2,MXAHIS),NHIST, 21 - - NETOT,NITOT,IENTRY(MXAHIS),IHIST(MXAHIS) 22 - LOGICAL USE(MXVAR),STAT(4) 23 - CHARACTER*(MXINCH) TITLE,OPT 24 - CHARACTER*10 VARLIS(16) 25 - REAL TCR(MXLIST),EX,EY,EZ,QDRIFT 26 - DOUBLE PRECISION TIME(MXLIST),SIG(MXLIST),TMIN,TMAX 27 - EXTERNAL MATSLT 28 - *** Assume the CALL will fail. 29 - IFAIL=1 30 - *** Check the signal initialisation has been done. 31 - IF(.NOT.CELSET)THEN 32 - PRINT *,' !!!!!! SIGCAL WARNING : Cell data not'// 33 - - ' available ; procedure not executed.' 34 - RETURN 35 - ELSEIF(.NOT.GASSET)THEN 36 - PRINT *,' !!!!!! SIGCAL WARNING : Gas data not'// 37 - - ' available ; procedure not executed.' 38 - RETURN 39 - ELSEIF(.NOT.SIGSET)THEN 40 - CALL SIGINI(IFAIL1) 41 - IF(IFAIL1.NE.0)THEN 42 - PRINT *,' !!!!!! SIGCAL WARNING : Initialisation of'// 43 - - ' signal calculation failed; no signals.' 44 - RETURN 45 - ENDIF 46 - ENDIF 47 - *** Some easy reference variables. 48 - NARG=INS(INSTR,3) 49 - IPROC=INS(INSTR,1) 50 - *** Threshold crossings. 51 - IF(IPROC.EQ.-70)THEN 52 - * Check number and type of arguments. 53 - IWRONG=0 54 - DO 150 I=4,NARG 55 - IF(ARGREF(I,1).GE.2)IWRONG=1 56 - 150 CONTINUE 57 - IF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR.MODARG(3).NE.1.OR. 58 - - NARG.LT.5.OR.IWRONG.EQ.1)THEN 59 - PRINT *,' !!!!!! SIGCAL WARNING : Incorrect argument'// 60 - - ' list provided for THRESHOLD_CROSSING.' 61 - RETURN 62 - ENDIF 63 - * Fetch the option string. 64 - CALL STRBUF('READ',NINT(ARG(3)),TITLE,NC,IFAIL1) 65 - CALL CLTOU(TITLE(1:NC)) 66 - * Clear previous use of storage for the results. 67 - DO 160 I=4,NARG 68 - CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 69 - 160 CONTINUE 70 - * Get the threshold crossings. 71 - CALL SIGTHC(NINT(ARG(1)),ARG(2), 72 - - TITLE(1:NC),NCR,TCR,IFAIL1) 73 - ARG(4)=REAL(NCR) 74 - MODARG(4)=2 75 - DO 170 I=1,MIN(NCR,MXARG-4) 76 - ARG(4+I)=TCR(I) 77 - MODARG(4+I)=2 78 - 170 CONTINUE 79 - * Check the error flag. 80 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! SIGCAL WARNING : Error'// 81 - - ' computing threshold crossings.' 82 - *** Return a signal. 83 - ELSEIF(IPROC.EQ.-71)THEN 84 - * Check argument list validity. 85 - IF(NARG.LT.3.OR.NARG.GT.4.OR. 86 - - MODARG(1).NE.2.OR. 87 - - ARGREF(2,1).GE.2.OR.ARGREF(3,1).GE.2.OR. 88 - - (NARG.GE.4.AND.ARGREF(4,1).GE.2))THEN 89 - PRINT *,' !!!!!! SIGCAL WARNING : Incorrect argument'// 90 - - ' list given to GET_SIGNAL; no signal returned.' 91 - RETURN 92 - ENDIF 93 - * Verify the electrode number. 94 - ISW=NINT(ARG(1)) 95 - IF(ISW.LT.0.OR.ISW.GT.NSW)THEN 96 - PRINT *,' !!!!!! SIGCAL WARNING : Invalid electrode'// 97 - - ' number given to GET_SIGNAL; no signal returned.' 98 - RETURN 99 - ENDIF 100 - * De-allocate the current arguments. 101 - CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) 102 - CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) 103 - IF(NARG.GE.4)CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 104 - * Allocate matrices. 105 - ISIZ(1)=NTIME 106 - CALL MATADM('ALLOCATE',IRTIM,1,ISIZ,2,IFAIL1) 107 - CALL MATADM('ALLOCATE',IRDIR,1,ISIZ,2,IFAIL2) 108 - IF(NARG.GE.4)THEN 109 - CALL MATADM('ALLOCATE',IRCROS,1,ISIZ,2,IFAIL3) 110 - ELSE 111 - IRCROS=0 1 759 P=SIGNAL D=SIGCAL 3 PAGE1164 112 - IFAIL3=0 113 - ENDIF 114 - ISTIM=MATSLT(IRTIM) 115 - ISDIR=MATSLT(IRDIR) 116 - IF(NARG.GE.4)THEN 117 - ISCROS=MATSLT(IRCROS) 118 - ELSE 119 - ISCROS=0 120 - ENDIF 121 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. 122 - - ISTIM.LE.0.OR.ISDIR.LE.0.OR. 123 - - (NARG.GE.4.AND.ISCROS.LE.0))THEN 124 - PRINT *,' !!!!!! SIGCAL WARNING : Failure to'// 125 - - ' allocate output matrices; signal not returned.' 126 - RETURN 127 - ENDIF 128 - * Copy the signals. 129 - DO 10 I=1,NTIME 130 - MVEC(MORG(ISTIM)+I)=TIMSIG(I) 131 - MVEC(MORG(ISDIR)+I)=SIGNAL(I,ISW,1) 132 - IF(NARG.GE.4)MVEC(MORG(ISCROS)+I)=SIGNAL(I,ISW,2) 133 - 10 CONTINUE 134 - * And save the matrices. 135 - ARG(2)=IRTIM 136 - MODARG(2)=5 137 - ARG(3)=IRDIR 138 - MODARG(3)=5 139 - IF(NARG.GE.4)THEN 140 - ARG(4)=IRCROS 141 - MODARG(4)=5 142 - ENDIF 143 - *** Store a signal. 144 - ELSEIF(IPROC.EQ.-72)THEN 145 - * Check argument list validity. 146 - IF(NARG.LT.2.OR.NARG.GT.3.OR. 147 - - MODARG(1).NE.2.OR.MODARG(2).NE.5.OR. 148 - - (NARG.GE.3.AND.MODARG(3).NE.5))THEN 149 - PRINT *,' !!!!!! SIGCAL WARNING : Incorrect argument'// 150 - - ' list given to STORE_SIGNAL; no signal saved.' 151 - RETURN 152 - ENDIF 153 - * Verify the wire number. 154 - ISW=NINT(ARG(1)) 155 - IF(ISW.LE.0.OR.ISW.GT.NSW)THEN 156 - PRINT *,' !!!!!! SIGCAL WARNING : Invalid electrode'// 157 - - ' number given to STORE_SIGNAL; no signal saved.' 158 - RETURN 159 - ENDIF 160 - * Locate the matrices. 161 - ISDIR=MATSLT(NINT(ARG(2))) 162 - IF(NARG.GE.3)THEN 163 - ISCROS=MATSLT(NINT(ARG(3))) 164 - ELSE 165 - ISCROS=0 166 - ENDIF 167 - IF(ISDIR.LE.0.OR.(NARG.GE.3.AND.ISCROS.LE.0))THEN 168 - PRINT *,' !!!!!! SIGCAL WARNING : Failure to'// 169 - - ' locate a signal vector; signal not saved.' 170 - RETURN 171 - ELSEIF(MLEN(ISDIR).NE.NTIME.OR. 172 - - (NARG.GE.3.AND.MLEN(ISCROS).NE.NTIME))THEN 173 - PRINT *,' !!!!!! SIGCAL WARNING : Signal vector'// 174 - - ' has wrong length; signal not saved.' 175 - RETURN 176 - ENDIF 177 - * Copy the signals. 178 - DO 20 I=1,NTIME 179 - SIGNAL(I,ISW,1)=MVEC(MORG(ISDIR)+I) 180 - IF(NARG.GE.3)SIGNAL(I,ISW,2)=MVEC(MORG(ISCROS)+I) 181 - TIMSIG(I)=TSTART+(I-1)*TDEV 182 - 20 CONTINUE 183 - *** Extract a raw signal. 184 - ELSEIF(IPROC.EQ.-73)THEN 185 - * Check argument list validity. 186 - IF(NARG.NE.6.OR.MODARG(1).NE.1.OR.MODARG(2).NE.2.OR. 187 - - MODARG(3).NE.2.OR.MODARG(4).NE.2.OR. 188 - - ARGREF(5,1).GE.2.OR.ARGREF(6,1).GE.2)THEN 189 - PRINT *,' !!!!!! SIGCAL WARNING : Incorrect argument'// 190 - - ' list for GET_RAW_SIGNAL; no signal returned.' 191 - RETURN 192 - ENDIF 193 - * Get the type. 194 - CALL STRBUF('READ',NINT(ARG(1)),TITLE,NC,IFAIL1) 195 - CALL CLTOU(TITLE(1:NC)) 196 - IF(TITLE(1:NC).EQ.'E-'.OR.TITLE(1:NC).EQ.'-'.OR. 197 - - TITLE(1:NC).EQ.'ELECTRON')THEN 198 - IQ=-1 199 - ELSEIF(TITLE(1:NC).EQ.'ION'.OR.TITLE(1:NC).EQ.'+')THEN 200 - IQ=+1 201 - ELSE 202 - PRINT *,' !!!!!! SIGCAL WARNING : Signal type '// 203 - - TITLE(1:NC)//' not known; assuming ION.' 204 - IQ=+1 205 - ENDIF 206 - * Verify the sense wire number. 207 - ISW=NINT(ARG(2)) 208 - IF(ISW.LE.0.OR.ISW.GT.NSW)THEN 209 - PRINT *,' !!!!!! SIGCAL WARNING : Invalid electrode'// 210 - - ' number given to GET_RAW_SIGNAL;'// 211 - - ' no signal returned.' 212 - RETURN 213 - ENDIF 214 - * Verify the avalanche wire number. 215 - IW=NINT(ARG(3)) 216 - IF(IW.LE.0.OR.IW.GT.NWIRE)THEN 217 - PRINT *,' !!!!!! SIGCAL WARNING : Invalid avalanche'// 1 759 P=SIGNAL D=SIGCAL 4 PAGE1165 218 - - ' wire number given to GET_RAW_SIGNAL;'// 219 - - ' no signal returned.' 220 - RETURN 221 - ENDIF 222 - * Get the incidence angle. 223 - IA=NINT(NORIA*MOD(ARG(4)-2*PI*ANINT(ARG(4)/(2*PI))+2*PI, 224 - - 2*PI)/(2*PI)) 225 - IF(IA.EQ.0)IA=NORIA 226 - * Fetch the signal. 227 - CALL SIGIST('READ',NSIG,TIME,SIG,ISW,IW,IA,IQ,IFAIL1) 228 - IF(IFAIL1.NE.0.OR.NSIG.LE.0)THEN 229 - PRINT *,' !!!!!! SIGCAL WARNING : Requested signal'// 230 - - ' is not in store; no signal returned.' 231 - RETURN 232 - ENDIF 233 - * De-allocate the current arguments. 234 - CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) 235 - CALL ALGREU(NINT(ARG(6)),MODARG(6),ARGREF(6,1)) 236 - * Allocate matrices. 237 - ISIZ(1)=NSIG 238 - CALL MATADM('ALLOCATE',IRTIM,1,ISIZ,2,IFAIL1) 239 - CALL MATADM('ALLOCATE',IRDIR,1,ISIZ,2,IFAIL2) 240 - ISTIM=MATSLT(IRTIM) 241 - ISDIR=MATSLT(IRDIR) 242 - IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. 243 - - ISTIM.LE.0.OR.ISDIR.LE.0)THEN 244 - PRINT *,' !!!!!! SIGCAL WARNING : Failure to'// 245 - - ' allocate output matrices; signal not returned.' 246 - RETURN 247 - ENDIF 248 - * Copy the signals. 249 - DO 40 I=1,NSIG 250 - MVEC(MORG(ISTIM)+I)=TIME(I) 251 - MVEC(MORG(ISDIR)+I)=SIG(I) 252 - 40 CONTINUE 253 - * And save the matrices. 254 - ARG(5)=IRTIM 255 - MODARG(5)=5 256 - ARG(6)=IRDIR 257 - MODARG(6)=5 258 - *** List the raw signals. 259 - ELSEIF(IPROC.EQ.-74)THEN 260 - IF(NARG.NE.0)PRINT *,' !!!!!! SIGCAL WARNING :'// 261 - - ' LIST_RAW_SIGNALS doesn''t have arguments.' 262 - CALL SIGIST('LIST',NSIG,TIME,SIG,ISW,IW,IA,IQ,IFAIL1) 263 - *** Compute the weighting field. 264 - ELSEIF(IPROC.EQ.-75)THEN 265 - * Check number of arguments. 266 - IF(NARG.NE.6)THEN 267 - PRINT *,' !!!!!! SIGCAL WARNING : Incorrect number'// 268 - - ' of arguments for WEIGHTING_FIELD.' 269 - RETURN 270 - * Check argument mode. 271 - ELSEIF((MODARG(1).NE.2.AND.MODARG(1).NE.5).OR. 272 - - (MODARG(2).NE.2.AND.MODARG(2).NE.5).OR. 273 - - MODARG(6).NE.2)THEN 274 - PRINT *,' !!!!!! SIGCAL WARNING : Some arguments of'// 275 - - ' WEIGHTING_FIELD are of incorrect type.' 276 - RETURN 277 - * Check the the results can be transferred back. 278 - ELSEIF(ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2.OR. 279 - - ARGREF(5,1).GE.2)THEN 280 - PRINT *,' !!!!!! SIGCAL WARNING : Some arguments'// 281 - - ' of WEIGHTING_FIELD can not be modified.' 282 - RETURN 283 - ENDIF 284 - * Get sense wire number etc. 285 - ISW=NINT(ARG(6)) 286 - IF(ISW.LE.0.OR.ISW.GT.NSW)THEN 287 - PRINT *,' !!!!!! SIGCAL WARNING : Sense wire'// 288 - - ' number out of range.' 289 - RETURN 290 - ENDIF 291 - * Variables already in use ? 292 - CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) 293 - CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 294 - CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) 295 - ** Carry out the calculation for scalar coordinates. 296 - IF(MODARG(1).EQ.2.AND.MODARG(2).EQ.2)THEN 297 - CALL SIGFLS(ARG(1),ARG(2),0.0,EX,EY,EZ,ISW) 298 - ARG(3)=EX 299 - ARG(4)=EY 300 - ARG(5)=EZ 301 - MODARG(3)=2 302 - MODARG(4)=2 303 - MODARG(5)=2 304 - ** At least one of them is a matrix. 305 - ELSE 306 - * Figure out what the dimensions are. 307 - NDAT=-1 308 - DO 30 I=1,2 309 - IF(MODARG(I).EQ.5)THEN 310 - IREF(I)=NINT(ARG(I)) 311 - ISLOT(I)=MATSLT(IREF(I)) 312 - IF(ISLOT(I).LE.0)THEN 313 - PRINT *,' !!!!!! SIGCAL WARNING : Unable'// 314 - - ' locate a input matrix.' 315 - RETURN 316 - ELSEIF(MMOD(ISLOT(I)).NE.2)THEN 317 - PRINT *,' !!!!!! SIGCAL WARNING : x Or y'// 318 - - ' matrix is of incorrect type.' 319 - RETURN 320 - ENDIF 321 - IF(NDAT.LT.0)THEN 322 - NDAT=MLEN(ISLOT(I)) 323 - DO 130 J=1,MDIM(ISLOT(I)) 1 759 P=SIGNAL D=SIGCAL 5 PAGE1166 324 - ISIZ(J)=MSIZ(ISLOT(I),J) 325 - 130 CONTINUE 326 - IDIM=MDIM(ISLOT(I)) 327 - ELSEIF(NDAT.NE.MLEN(ISLOT(I)))THEN 328 - PRINT *,' !!!!!! SIGCAL WARNING : x And y'// 329 - - ' have inconsistent lengths.' 330 - RETURN 331 - ENDIF 332 - ENDIF 333 - 30 CONTINUE 334 - IF(NDAT.LT.1)THEN 335 - PRINT *,' !!!!!! SIGCAL WARNING : Unable'// 336 - - ' to find an x or y matrix.' 337 - RETURN 338 - ENDIF 339 - * Now book matrices for the missing elements and initialise them. 340 - DO 60 I=1,2 341 - IF(MODARG(I).NE.5)THEN 342 - CALL MATADM('ALLOCATE',IREF(I),IDIM,ISIZ,2,IFAIL1) 343 - IF(IFAIL1.NE.0)THEN 344 - PRINT *,' !!!!!! SIGCAL WARNING : Unable'// 345 - - ' to get a replacement matrix.' 346 - RETURN 347 - ENDIF 348 - ISLOT(I)=MATSLT(IREF(I)) 349 - IF(ISLOT(I).LE.0)THEN 350 - PRINT *,' !!!!!! SIGCAL WARNING : Unable'// 351 - - ' to locate a replacement matrix.' 352 - RETURN 353 - ENDIF 354 - DO 70 J=1,MLEN(ISLOT(I)) 355 - MVEC(MORG(ISLOT(I))+J)=ARG(I) 356 - 70 CONTINUE 357 - ENDIF 358 - 60 CONTINUE 359 - * Allocate the output arrays (Ewx, Ewy, Ewz). 360 - DO 140 I=4,6 361 - CALL MATADM('ALLOCATE',IREF(I),IDIM,ISIZ,2,IFAIL1) 362 - IF(IFAIL1.NE.0)THEN 363 - PRINT *,' !!!!!! SIGCAL WARNING : Unable'// 364 - - ' to get an output matrix.' 365 - RETURN 366 - ENDIF 367 - 140 CONTINUE 368 - * And finally locate all matrices. 369 - DO 180 I=1,6 370 - IF(I.EQ.3)GOTO 180 371 - ISLOT(I)=MATSLT(IREF(I)) 372 - IF(ISLOT(I).LE.0)THEN 373 - PRINT *,' !!!!!! SIGCAL WARNING : Unable'// 374 - - ' to locate an input or output matrix.' 375 - RETURN 376 - ENDIF 377 - 180 CONTINUE 378 - * And compute the data. 379 - DO 90 I=1,NDAT 380 - CALL SIGFLS(MVEC(MORG(ISLOT(1))+I), 381 - - MVEC(MORG(ISLOT(2))+I),0.0,EX,EY,EZ,ISW) 382 - MVEC(MORG(ISLOT(4))+I)=EX 383 - MVEC(MORG(ISLOT(5))+I)=EY 384 - MVEC(MORG(ISLOT(6))+I)=EZ 385 - 90 CONTINUE 386 - ARG(3)=IREF(4) 387 - ARG(4)=IREF(5) 388 - ARG(5)=IREF(6) 389 - MODARG(3)=5 390 - MODARG(4)=5 391 - MODARG(5)=5 392 - * Delete temporary input matrices. 393 - DO 120 I=1,2 394 - IF(MODARG(I).NE.5)THEN 395 - ISIZ(1)=NDAT 396 - CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL1) 397 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! SIGCAL WARNING'// 398 - - ' : Unable to delete a replacement matrix.' 399 - ENDIF 400 - 120 CONTINUE 401 - ENDIF 402 - *** Compute the weighting field in 3 dimensions. 403 - ELSEIF(IPROC.EQ.-76)THEN 404 - * Check number of arguments. 405 - IF(NARG.NE.7)THEN 406 - PRINT *,' !!!!!! SIGCAL WARNING : Incorrect number'// 407 - - ' of arguments for WEIGHTING_FIELD_3.' 408 - RETURN 409 - * Check argument mode. 410 - ELSEIF((MODARG(1).NE.2.AND.MODARG(1).NE.5).OR. 411 - - (MODARG(2).NE.2.AND.MODARG(2).NE.5).OR. 412 - - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. 413 - - MODARG(7).NE.2)THEN 414 - PRINT *,' !!!!!! SIGCAL WARNING : Some arguments of'// 415 - - ' WEIGHTING_FIELD_3 are of incorrect type.' 416 - RETURN 417 - * Check the the results can be transferred back. 418 - ELSEIF(ARGREF(4,1).GE.2.OR.ARGREF(5,1).GE.2.OR. 419 - - ARGREF(6,1).GE.2)THEN 420 - PRINT *,' !!!!!! SIGCAL WARNING : Some arguments'// 421 - - ' of WEIGHTING_FIELD_3 can not be modified.' 422 - RETURN 423 - ENDIF 424 - * Get sense wire number etc. 425 - ISW=NINT(ARG(7)) 426 - IF(ISW.LE.0.OR.ISW.GT.NSW)THEN 427 - PRINT *,' !!!!!! SIGCAL WARNING : Sense wire'// 428 - - ' number out of range.' 429 - RETURN 1 759 P=SIGNAL D=SIGCAL 6 PAGE1167 430 - ENDIF 431 - * Variables already in use ? 432 - CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) 433 - CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) 434 - CALL ALGREU(NINT(ARG(6)),MODARG(6),ARGREF(6,1)) 435 - ** Carry out the calculation for scalar coordinates. 436 - IF(MODARG(1).EQ.2.AND.MODARG(2).EQ.2.AND.MODARG(3).EQ.2)THEN 437 - CALL SIGFLS(ARG(1),ARG(2),ARG(3),EX,EY,EZ,ISW) 438 - ARG(4)=EX 439 - ARG(5)=EY 440 - ARG(6)=EZ 441 - MODARG(4)=2 442 - MODARG(5)=2 443 - MODARG(6)=2 444 - ** At least one of them is a matrix. 445 - ELSE 446 - * Figure out what the dimensions are. 447 - NDAT=-1 448 - DO 220 I=1,3 449 - IF(MODARG(I).EQ.5)THEN 450 - IREF(I)=NINT(ARG(I)) 451 - ISLOT(I)=MATSLT(IREF(I)) 452 - IF(ISLOT(I).LE.0)THEN 453 - PRINT *,' !!!!!! SIGCAL WARNING : Unable'// 454 - - ' locate a input matrix.' 455 - RETURN 456 - ELSEIF(MMOD(ISLOT(I)).NE.2)THEN 457 - PRINT *,' !!!!!! SIGCAL WARNING : x, y'// 458 - - ' Or z matrix is of incorrect type.' 459 - RETURN 460 - ENDIF 461 - IF(NDAT.LT.0)THEN 462 - NDAT=MLEN(ISLOT(I)) 463 - DO 230 J=1,MDIM(ISLOT(I)) 464 - ISIZ(J)=MSIZ(ISLOT(I),J) 465 - 230 CONTINUE 466 - IDIM=MDIM(ISLOT(I)) 467 - ELSEIF(NDAT.NE.MLEN(ISLOT(I)))THEN 468 - PRINT *,' !!!!!! SIGCAL WARNING : x, y'// 469 - - ' And z have inconsistent lengths.' 470 - RETURN 471 - ENDIF 472 - ENDIF 473 - 220 CONTINUE 474 - IF(NDAT.LT.1)THEN 475 - PRINT *,' !!!!!! SIGCAL WARNING : Unable'// 476 - - ' to find an x, y or z matrix.' 477 - RETURN 478 - ENDIF 479 - * Now book matrices for the missing elements and initialise them. 480 - DO 240 I=1,3 481 - IF(MODARG(I).NE.5)THEN 482 - CALL MATADM('ALLOCATE',IREF(I),IDIM,ISIZ,2,IFAIL1) 483 - IF(IFAIL1.NE.0)THEN 484 - PRINT *,' !!!!!! SIGCAL WARNING : Unable'// 485 - - ' to get a replacement matrix.' 486 - RETURN 487 - ENDIF 488 - ISLOT(I)=MATSLT(IREF(I)) 489 - IF(ISLOT(I).LE.0)THEN 490 - PRINT *,' !!!!!! SIGCAL WARNING : Unable'// 491 - - ' to locate a replacement matrix.' 492 - RETURN 493 - ENDIF 494 - DO 250 J=1,MLEN(ISLOT(I)) 495 - MVEC(MORG(ISLOT(I))+J)=ARG(I) 496 - 250 CONTINUE 497 - ENDIF 498 - 240 CONTINUE 499 - * Allocate the output arrays (Ewx, Ewy, Ewz). 500 - DO 260 I=4,6 501 - CALL MATADM('ALLOCATE',IREF(I),IDIM,ISIZ,2,IFAIL1) 502 - IF(IFAIL1.NE.0)THEN 503 - PRINT *,' !!!!!! SIGCAL WARNING : Unable'// 504 - - ' to get an output matrix.' 505 - RETURN 506 - ENDIF 507 - 260 CONTINUE 508 - * And finally locate all matrices. 509 - DO 270 I=1,6 510 - ISLOT(I)=MATSLT(IREF(I)) 511 - IF(ISLOT(I).LE.0)THEN 512 - PRINT *,' !!!!!! SIGCAL WARNING : Unable'// 513 - - ' to locate an input or output matrix.' 514 - RETURN 515 - ENDIF 516 - 270 CONTINUE 517 - * And compute the data. 518 - DO 280 I=1,NDAT 519 - CALL SIGFLS(MVEC(MORG(ISLOT(1))+I), 520 - - MVEC(MORG(ISLOT(2))+I), 521 - - MVEC(MORG(ISLOT(3))+I), 522 - - EX,EY,EZ,ISW) 523 - MVEC(MORG(ISLOT(4))+I)=EX 524 - MVEC(MORG(ISLOT(5))+I)=EY 525 - MVEC(MORG(ISLOT(6))+I)=EZ 526 - 280 CONTINUE 527 - ARG(4)=IREF(4) 528 - ARG(5)=IREF(5) 529 - ARG(6)=IREF(6) 530 - MODARG(4)=5 531 - MODARG(5)=5 532 - MODARG(6)=5 533 - * Delete temporary input matrices. 534 - DO 310 I=1,3 535 - IF(MODARG(I).NE.5)THEN 1 759 P=SIGNAL D=SIGCAL 7 PAGE1168 536 - ISIZ(1)=NDAT 537 - CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL1) 538 - IF(IFAIL1.NE.0)PRINT *,' !!!!!! SIGCAL WARNING'// 539 - - ' : Unable to delete a replacement matrix.' 540 - ENDIF 541 - 310 CONTINUE 542 - ENDIF 543 - *** Induced charge. 544 - ELSEIF(IPROC.EQ.-77)THEN 545 - IF((NARG.NE.6.AND.NARG.NE.8).OR. 546 - - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR.MODARG(3).NE.2.OR. 547 - - (NARG.EQ.8.AND.(MODARG(6).NE.2.OR.MODARG(7).NE.2)).OR. 548 - - MODARG(4).NE.1.OR.MODARG(5).NE.2)THEN 549 - PRINT *,' !!!!!! SIGCAL WARNING : Incorrect argument'// 550 - - ' list for INDUCED_CHARGE; not executed.' 551 - RETURN 552 - ELSEIF(ARGREF(NARG,1).GE.2)THEN 553 - PRINT *,' !!!!!! SIGCAL WARNING : An argument of'// 554 - - ' INDUCED_CHARGE can not be modified.' 555 - RETURN 556 - ENDIF 557 - * Fetch particle type. 558 - CALL STRBUF('READ',NINT(ARG(4)),TITLE,NC,IFAIL1) 559 - IF(IFAIL1.NE.0)THEN 560 - PRINT *,' !!!!!! SIGCAL WARNING : Error retrieving'// 561 - - ' the INDUCED_CHARGE particle type.' 562 - RETURN 563 - ENDIF 564 - IF(NC.GE.1)CALL CLTOU(TITLE(1:NC)) 565 - * Decode it. 566 - IF(TITLE(1:NC).EQ.'ELECTRON'.OR.TITLE(1:NC).EQ.'E-')THEN 567 - JTYPE=1 568 - QDRIFT=-1 569 - ELSEIF(TITLE(1:NC).EQ.'POSITRON'.OR.TITLE(1:NC).EQ.'E+')THEN 570 - JTYPE=1 571 - QDRIFT=+1 572 - ELSEIF(TITLE(1:NC).EQ.'ION'.OR.TITLE(1:NC).EQ.'ION+')THEN 573 - JTYPE=2 574 - QDRIFT=+1 575 - ELSEIF(TITLE(1:NC).EQ.'ION-')THEN 576 - JTYPE=2 577 - QDRIFT=-1 578 - ELSE 579 - PRINT *,' !!!!!! SIGCAL WARNING : Unknown particle'// 580 - - ' type received by INDUCED_CHARGE.' 581 - RETURN 582 - ENDIF 583 - * Pick up the electrode number. 584 - ISW=NINT(ARG(5)) 585 - IF(ISW.LE.0.OR.ISW.GT.NSW)THEN 586 - PRINT *,' !!!!!! SIGCAL WARNING : INDUCED_CHARGE'// 587 - - ' received an invalid group number.' 588 - RETURN 589 - ENDIF 590 - * Delete old contents of return variable. 591 - CALL ALGREU(NINT(ARG(NARG)),MODARG(NARG),ARGREF(NARG,1)) 592 - * Compute the drift line. 593 - CALL DLCALC(ARG(1),ARG(2),ARG(3),QDRIFT,JTYPE) 594 - * Time limits. 595 - IF(NARG.EQ.6)THEN 596 - TMIN=TU(1) 597 - TMAX=TU(NU) 598 - ELSE 599 - TMIN=ARG(6) 600 - TMAX=ARG(7) 601 - ENDIF 602 - * Compute the induced charge. 603 - CALL SIGQIN(ARG(NARG),ISW,TMIN,TMAX) 604 - MODARG(NARG)=2 605 - *** Add a signal. 606 - ELSEIF(IPROC.EQ.-78)THEN 607 - * Check argument list. 608 - IF(NARG.GE.2.OR.(NARG.EQ.1.AND.MODARG(1).NE.1))THEN 609 - PRINT *,' !!!!!! SIGCAL WARNING : Incorrect argument'// 610 - - ' list received for ADD_SIGNALS; not called.' 611 - RETURN 612 - ENDIF 613 - * Fetch options. 614 - IF(NARG.GE.1)THEN 615 - CALL STRBUF('READ',NINT(ARG(1)),TITLE,NC,IFAIL1) 616 - IF(IFAIL1.NE.0)THEN 617 - PRINT *,' !!!!!! SIGCAL WARNING : Error'// 618 - - ' retrieving the ADD_SIGNALS options.' 619 - RETURN 620 - ENDIF 621 - IF(NC.GE.1)CALL CLTOU(TITLE(1:NC)) 622 - ELSE 623 - TITLE='CROSS' 624 - NC=5 625 - ENDIF 626 - * Call the procedure. 627 - IF(INDEX(TITLE(1:NC),'DIRECT')+ 628 - - INDEX(TITLE(1:NC),'NOCROSS').NE.0)THEN 629 - CALL SIGADS(.FALSE.,IFAIL1) 630 - ELSE 631 - CALL SIGADS(.TRUE.,IFAIL1) 632 - ENDIF 633 - * Check return code. 634 - IF(IFAIL1.NE.0)THEN 635 - PRINT *,' !!!!!! SIGCAL WARNING : Error computing'// 636 - - ' or adding a signal; signal incomplete.' 637 - RETURN 638 - ENDIF 639 - *** 3D MC drift line calculation for electrons with avalanche. 640 - ELSEIF(IPROC.EQ.-79)THEN 641 - ** Check number of arguments. 1 759 P=SIGNAL D=SIGCAL 8 PAGE1169 642 - IF(NARG.LT.3.OR. 643 - - (NARG.GE.4.AND.MODARG(4).NE.1).OR. 644 - - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. 645 - - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. 646 - - (NARG.GE.7.AND.NARG.NE.2*(NARG/2)).OR. 647 - - NARG.GT.6+2*MXAHIS)THEN 648 - PRINT *,' !!!!!! SIGCAL WARNING : Incorrect list of'// 649 - - ' arguments for AVALANCHE; not executed' 650 - RETURN 651 - * Make sure there are drift velocities. 652 - ELSEIF(.NOT.GASOK(1))THEN 653 - PRINT *,' !!!!!! SIGCAL WARNING : The drift velocity'// 654 - - ' for electrons is not defined ; not executed.' 655 - RETURN 656 - * Make sure there are Townsend coefficients. 657 - ELSEIF(.NOT.GASOK(4))THEN 658 - PRINT *,' !!!!!! SIGCAL WARNING : The Townsend'// 659 - - ' coefficient is not defined ; not executed.' 660 - RETURN 661 - ENDIF 662 - ** Fetch the option string. 663 - IF(NARG.GE.4)THEN 664 - CALL STRBUF('READ',NINT(ARG(4)),OPT,NCOPT,IFAIL1) 665 - CALL CLTOU(OPT(1:NCOPT)) 666 - ELSE 667 - OPT=' ' 668 - NCOPT=1 669 - ENDIF 670 - ** Liberate storage associated with the electron and ion count. 671 - IF(NARG.GE.5)CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) 672 - IF(NARG.GE.6)CALL ALGREU(NINT(ARG(6)),MODARG(6),ARGREF(6,1)) 673 - ** Create the entry point for the histogram formulae. 674 - IF(NARG.GE.7)THEN 675 - * Initialise the usage list. 676 - STAT(1)=.FALSE. 677 - STAT(2)=.FALSE. 678 - STAT(3)=.FALSE. 679 - STAT(4)=.FALSE. 680 - * Establish the variable list. 681 - IF(POLAR)THEN 682 - VARLIS(1)= 'R_CREATED' 683 - VARLIS(5)= 'R_LOST' 684 - VARLIS(9)= 'R_E' 685 - VARLIS(13)='R_ION' 686 - VARLIS(2)= 'PHI_CREATED' 687 - VARLIS(6)= 'PHI_LOST' 688 - VARLIS(10)='PHI_E' 689 - VARLIS(14)='PHI_ION' 690 - ELSE 691 - VARLIS(1)= 'X_CREATED' 692 - VARLIS(5)= 'X_LOST' 693 - VARLIS(9)= 'X_E' 694 - VARLIS(13)='X_ION' 695 - VARLIS(2)= 'Y_CREATED' 696 - VARLIS(6)= 'Y_LOST' 697 - VARLIS(10)='Y_E' 698 - VARLIS(14)='Y_ION' 699 - ENDIF 700 - VARLIS(3)= 'Z_CREATED' 701 - VARLIS(7)= 'Z_LOST' 702 - VARLIS(11)='Z_E' 703 - VARLIS(15)='Z_ION' 704 - VARLIS(4)= 'T_CREATED' 705 - VARLIS(8)= 'T_LOST' 706 - VARLIS(12)='T_E' 707 - VARLIS(16)='T_ION' 708 - * Number of histograms. 709 - NHIST=NARG/2-3 710 - * Loop over the histograms. 711 - DO 100 I=1,NHIST 712 - * Fetch the histogram string. 713 - CALL STRBUF('READ',NINT(ARG(5+2*I)),TITLE,NC,IFAIL1) 714 - IF(IFAIL1.NE.0.OR.NC.LT.1)THEN 715 - PRINT *,' !!!!!! SIGCAL WARNING : Unable to get'// 716 - - ' an histogram formula; no avalanche.' 717 - RETURN 718 - ENDIF 719 - CALL CLTOU(TITLE(1:NC)) 720 - * Translate the formula. 721 - CALL ALGPRE(TITLE(1:NC),NC,VARLIS,16,NREXP,USE, 722 - - IENTRY(I),IFAIL1) 723 - IF(IFAIL1.NE.0)THEN 724 - PRINT *,' !!!!!! SIGCAL WARNING : The histogram'// 725 - - ' function '//TITLE(1:NC)//' can not be'// 726 - - ' translated; no avalanche.' 727 - CALL ALGCLR(IENTRY(I)) 728 - RETURN 729 - ELSEIF(NREXP.LT.1.OR.NREXP.GT.2)THEN 730 - PRINT *,' !!!!!! SIGCAL WARNING : The histogram'// 731 - - ' function '//TITLE(1:NC)//' does not'// 732 - - ' return 1 or 2 results; no avalanche.' 733 - CALL ALGCLR(IENTRY(I)) 734 - RETURN 735 - ENDIF 736 - ITYPE(2,I)=NREXP 737 - * Work out which quantities are to be computed. 738 - ITYPE(1,I)=0 739 - IF((USE( 1).OR.USE( 2).OR.USE( 3).OR.USE( 4)).AND. 740 - - ITYPE(1,I).NE.0)THEN 741 - PRINT *,' !!!!!! SIGCAL WARNING : Histogram'// 742 - - ' function '//TITLE(1:NC)//' uses an'// 743 - - ' invalid mix of parameters; no avalanche.' 744 - CALL ALGCLR(IENTRY(I)) 745 - RETURN 746 - ELSEIF(USE( 1).OR.USE( 2).OR.USE( 3).OR.USE( 4))THEN 747 - ITYPE(1,I)=1 1 759 P=SIGNAL D=SIGCAL 9 PAGE1170 748 - ENDIF 749 - IF((USE( 5).OR.USE( 6).OR.USE( 7).OR.USE( 8)).AND. 750 - - ITYPE(1,I).NE.0)THEN 751 - PRINT *,' !!!!!! SIGCAL WARNING : Histogram'// 752 - - ' function '//TITLE(1:NC)//' uses an'// 753 - - ' invalid mix of parameters; no avalanche.' 754 - CALL ALGCLR(IENTRY(I)) 755 - RETURN 756 - ELSEIF(USE( 5).OR.USE( 6).OR.USE( 7).OR.USE( 8))THEN 757 - ITYPE(1,I)=2 758 - ENDIF 759 - IF((USE( 9).OR.USE(10).OR.USE(11).OR.USE(12)).AND. 760 - - ITYPE(1,I).NE.0)THEN 761 - PRINT *,' !!!!!! SIGCAL WARNING : Histogram'// 762 - - ' function '//TITLE(1:NC)//' uses an'// 763 - - ' invalid mix of parameters; no avalanche.' 764 - CALL ALGCLR(IENTRY(I)) 765 - RETURN 766 - ELSEIF(USE( 9).OR.USE(10).OR.USE(11).OR.USE(12))THEN 767 - ITYPE(1,I)=3 768 - ENDIF 769 - IF((USE(13).OR.USE(14).OR.USE(15).OR.USE(16)).AND. 770 - - ITYPE(1,I).NE.0)THEN 771 - PRINT *,' !!!!!! SIGCAL WARNING : Histogram'// 772 - - ' function '//TITLE(1:NC)//' uses an'// 773 - - ' invalid mix of parameters; no avalanche.' 774 - CALL ALGCLR(IENTRY(I)) 775 - RETURN 776 - ELSEIF(USE(13).OR.USE(14).OR.USE(15).OR.USE(16))THEN 777 - ITYPE(1,I)=4 778 - ENDIF 779 - IF(ITYPE(1,I).EQ.0)THEN 780 - PRINT *,' !!!!!! SIGCAL WARNING : Histogram'// 781 - - ' function '//TITLE(1:NC)//' uses no'// 782 - - ' variables; no avalanche.' 783 - CALL ALGCLR(IENTRY(I)) 784 - RETURN 785 - ENDIF 786 - STAT(1)=STAT(1).OR.(ITYPE(1,I).EQ.1) 787 - STAT(2)=STAT(2).OR.(ITYPE(1,I).EQ.2) 788 - STAT(3)=STAT(3).OR.(ITYPE(1,I).EQ.3) 789 - STAT(4)=STAT(4).OR.(ITYPE(1,I).EQ.4) 790 - * Generate the histogram index list and check the number. 791 - IF(ARGREF(6+2*I,1).GE.2)THEN 792 - PRINT *,' !!!!!! SIGCAL WARNING : Histogram'// 793 - - ' argument ',I,' can not be modified;'// 794 - - ' no avalanche.' 795 - CALL ALGCLR(IENTRY(I)) 796 - RETURN 797 - ELSEIF(MODARG(6+2*I).EQ.4)THEN 798 - IHIST(I)=NINT(ARG(6+2*I)) 799 - ELSE 800 - CALL ALGREU(NINT(ARG(6+2*I)),MODARG(6+2*I), 801 - - ARGREF(6+2*I,1)) 802 - CALL HISADM('ALLOCATE',IHIST(I),100,0.0,0.0, 803 - - .TRUE.,IFAIL1) 804 - ENDIF 805 - 100 CONTINUE 806 - * No histograms to be made. 807 - ELSE 808 - STAT(1)=.FALSE. 809 - STAT(2)=.FALSE. 810 - STAT(3)=.FALSE. 811 - STAT(4)=.FALSE. 812 - NHIST=0 813 - ENDIF 814 - ** Carry out the calculation. 815 - CALL SIGMCA(ARG(1),ARG(2),ARG(3),NETOT,NITOT, 816 - - STAT,NHIST,IHIST,ITYPE,IENTRY,OPT(1:NCOPT)) 817 - * Print algebra errors if there were any. 818 - CALL ALGERR 819 - ** Return the arguments and delete the instruction lists. 820 - IF(NARG.GE.5)THEN 821 - ARG(5)=REAL(NETOT) 822 - MODARG(5)=2 823 - ENDIF 824 - IF(NARG.GE.6)THEN 825 - ARG(6)=REAL(NITOT) 826 - MODARG(6)=2 827 - ENDIF 828 - DO 110 I=1,NHIST 829 - ARG(6+2*I)=REAL(IHIST(I)) 830 - MODARG(6+2*I)=4 831 - CALL ALGCLR(IENTRY(I)) 832 - 110 CONTINUE 833 - *** Other signal calls not known. 834 - ELSE 835 - PRINT *,' !!!!!! SIGCAL WARNING : Invalid signal'// 836 - - ' procedure code received; nothing done.' 837 - RETURN 838 - ENDIF 839 - *** Seems to have worked. 840 - IFAIL=0 841 - END 760 GARFIELD ================================================== P=SIGNAL D=SIGWGT 1 ============================ 0 + +DECK,SIGWGT. 1 - SUBROUTINE SIGWGT 2 - *----------------------------------------------------------------------- 3 - * SIGWGT - Subroutine plotting the electric field, the magnetic field 4 - * and the potential in a variety of ways: histograms, contour 5 - * plots, vector plots and surface plots. 6 - * Variables : XPL,YPL : Used for plotting lines 7 - * FUNCT. : Stores the function text the plots 8 - * VAR : Array of input values for ALGEXE 1 760 P=SIGNAL D=SIGWGT 2 PAGE1171 9 - * GRID : Array of 'heights' for surface plots 10 - * COORD : Contains the ordinate of the graph data 11 - * VALUE : Contains the function values of the graph 12 - * HIST : Stores the histogram 13 - * CMIN,CMAX : Range of contour heights 14 - * HMIN,HMAX : Range in the histogram 15 - * NCHA : Number of bins in the histogram. 16 - * FLAG : Logicals used for parsing the command 17 - * LHIST ... : Determines whether the plot will be made 18 - * PHI,THETA : Viewing angle for 3-dimensional plots. 19 - * (Last changed on 29/ 3/01.) 20 - *----------------------------------------------------------------------- 21 - implicit none 22.- +SEQ,DIMENSIONS. 23.- +SEQ,CONSTANTS. 24.- +SEQ,CELLDATA. 25.- +SEQ,GASDATA. 26.- +SEQ,PARAMETERS. 27.- +SEQ,GRAPHICS. 28.- +SEQ,PRINTPLOT. 29.- +SEQ,BFIELD. 30.- +SEQ,DRIFTLINE. 31.- +SEQ,SIGNALDATA. 32 - DOUBLE PRECISION QTMIN,QTMAX 33 - REAL COORD(MXLIST),VALUE(MXLIST),RES(5),VAR(MXVAR), 34 - - HMIN,HMAX,GRSMIN,GRSMAX,RT0,RT1,PT0,PT1,XPOS,YPOS,ZPOS, 35 - - FACNRM,CMIN,CMAX,QPLT,THETA,PHI,GMINR,GMAXR,QTMINR,QTMAXR, 36 - - HMINR,HMAXR,CMINR,CMAXR,XXPOS,YYPOS,VXMIN,VYMIN,VXMAX,VYMAX 37 - INTEGER NCHA,NCONT,NGRPNT,MODVAR(MXVAR),MODRES(5),NCTOT,ILOC, 38 - - ISURF,IVECT1,IVECT2,IVECT3,IHIST,IFLAT,ICHK,JCHK,IHISRF, 39 - - NREXP,I,J,ISW,ISWR,JSW, 40 - - INEXT,NWORD,IFAIL1,IFAIL2,NPNTR,NC1,NC2,NC3,NC4,NC5,II, 41 - - INPCMP,NCFTRA,ITYPE,IFAIL,IENTRA,ICOORD,NCHAR,NRES,NCAUX, 42 - - NCONTR,IENTRY,NCAUX1,NCAUX2,NCAUX3,NCAUX4,INPTYP,NDATA, 43 - - NCONTP,NCGR 44 - CHARACTER*(MXCHAR) STRING,FUNCT1,FUNCT2,FUNCT3,FUNCT4,FUNCT5, 45 - - FUNTRA 46 - CHARACTER*20 AUX1,AUX2,AUX3,AUX4,GROUP 47 - CHARACTER*10 VARLIS(MXVAR) 48 - LOGICAL USE(MXVAR),FLAG(MXWORD+5),EVALW,EVALB,EVALV,EVALE,EVALI, 49 - - EVALQ,EVALP,LHIST,LVECT,LGRAPH,LCONT,LSURF,CAUTO,HAUTO,CLAB, 50 - - LGRPRT,OK,LMCDR 51 - EXTERNAL INPCMP,INPTYP,SCONT1 52 - COMMON /CN3DAT/ QTMIN,QTMAX,IENTRY,EVALW,EVALB,EVALV,EVALE,EVALI, 53 - - EVALQ,EVALP,QPLT,ITYPE,JSW,LMCDR 0 54-+ +SELF,IF=NAG. 55 - DOUBLE PRECISION WS,DUM 56 - COMMON /MATRIX/ WS(MXWIRE,MXWIRE),CHTS(MXWIRE),DUM(3*MXWIRE+3) 0 57-+ +SELF,IF=HIGZ. 58 - REAL WS(MXGRID,MXGRID),PAR(37),SMIN,SMAX 0 59-+ +SELF,IF=SAVE. 60 - SAVE VARLIS,HMIN,HMAX,NCHA,NCONT,NGRPNT,PHI,THETA,LGRPRT 0 61-+ +SELF. 62 - DATA (VARLIS(I),I=1,26) /'X ','Y ','EX ', 63 - - 'EY ','EZ ','E ','BX ', 64 - - 'BY ','BZ ','B ','VDX ', 65 - - 'VDY ','VDZ ','VD ','TIME_E ', 66 - - 'TIME_ION ','EWX ','EWY ','EWZ ', 67 - - 'EW ','Q_E ','Q_ION ','Z ', 68 - - 'STATUS_E ','STATUS_ION','T '/ 69 - DATA HMIN,HMAX /0.0,10000.0/ 70 - DATA NCONT/21/ 71 - DATA NGRPNT/MXLIST/,LGRPRT/.FALSE./ 72 - DATA NCHA/100/ 73 - DATA PHI,THETA/30.0,60.0/ 74 - *** Define an output format. 75 - 1010 FORMAT(26X,A10,L2,3X,A20,2X,I2,2(2X,E10.3),2(2X,I6),2(2X,E10.3)) 76 - *** Identify the routine. 77 - IF(LIDENT)PRINT *,' /// ROUTINE SIGWGT ///' 78 - *** If the first call, then we still have to prepare signal matrices. 79 - IF(.NOT.SIGSET)THEN 80 - CALL SIGINI(IFAIL1) 81 - IF(IFAIL1.NE.0)THEN 82 - PRINT *,' !!!!!! SIGWGT WARNING : Initialisation of'// 83 - - ' signal calculation failed; no signals.' 84 - RETURN 85 - ENDIF 86 - ENDIF 87 - *** Preset the options, function strings etc, 88 - FUNCT1=' ' 89 - FUNCT2=' ' 90 - FUNCT3=' ' 91 - FUNCT4=' ' 92 - FUNCT5=' ' 93 - LGRAPH=.FALSE. 94 - LSURF=.FALSE. 95 - LVECT=.FALSE. 96 - LHIST=.FALSE. 97 - LCONT=.FALSE. 98 - FUNTRA='?' 99 - NCFTRA=1 100 - CMIN=VMIN 101 - CMAX=VMAX 102 - CAUTO=.TRUE. 103 - CLAB=.TRUE. 104 - HAUTO=.TRUE. 105 - GRSMIN=1 106 - GRSMAX=-1 107 - OK=.TRUE. 108 - LMCDR=.FALSE. 109 - QTMIN=-1.0D0 110 - QTMAX=-1.0D0 1 760 P=SIGNAL D=SIGWGT 3 PAGE1172 111 - *** Default sense wire number. 112 - ISW=-1 113 - *** Make sure the variables have appropriate names 114 - IF(POLAR)THEN 115 - VARLIS(1)= 'R ' 116 - VARLIS(2)= 'PHI ' 117 - VARLIS(3)= 'ER ' 118 - VARLIS(4)= 'EPHI ' 119 - VARLIS(7)= 'BR ' 120 - VARLIS(8)= 'BPHI ' 121 - VARLIS(11)='VDR ' 122 - VARLIS(12)='VDPHI ' 123 - VARLIS(17)='EWR ' 124 - VARLIS(18)='EWPHI ' 125 - ELSE 126 - VARLIS(1)= 'X ' 127 - VARLIS(2)= 'Y ' 128 - VARLIS(3)= 'EX ' 129 - VARLIS(4)= 'EY ' 130 - VARLIS(7)= 'BX ' 131 - VARLIS(8)= 'BY ' 132 - VARLIS(11)='VDX ' 133 - VARLIS(12)='VDY ' 134 - VARLIS(17)='EWX ' 135 - VARLIS(18)='EWY ' 136 - ENDIF 137 - *** Examine the input, first step is finding out where the keywords are. 138 - CALL INPNUM(NWORD) 139 - DO 10 I=1,MXWORD+5 140 - IF(I.EQ.1.OR.I.GT.NWORD)THEN 141 - FLAG(I)=.TRUE. 142 - ELSEIF(INPCMP(I,'A#NGLES')+INPCMP(I,'AUTO#MATIC')+ 143 - - INPCMP(I,'BI#NS')+INPCMP(I,'SC#ALE')+ 144 - - INPCMP(I,'PR#INT')+INPCMP(I,'NOPR#INT')+ 145 - - INPCMP(I,'C#ONTOUR')+INPCMP(I,'GR#APH')+ 146 - - INPCMP(I,'H#ISTOGRAM')+INPCMP(I,'N')+ 147 - - INPCMP(I,'LAB#ELS')+INPCMP(I,'NOLAB#ELS')+ 148 - - INPCMP(I,'RA#NGE')+INPCMP(I,'S#URFACE')+ 149 - - INPCMP(I,'VE#CTOR')+INPCMP(I,'ON')+ 150 - - INPCMP(I,'GROUP')+INPCMP(I,'S#ENSE-W#IRE')+ 151 - - INPCMP(I,'ELEC#TRODE')+ 152 - - INPCMP(I,'TIME-WIND#OW').NE.0)THEN 153 - FLAG(I)=.TRUE. 154 - ELSE 155 - FLAG(I)=.FALSE. 156 - ENDIF 157 - 10 CONTINUE 158 - *** Start a loop over the list, 159 - INEXT=1 160 - DO 20 I=2,NWORD 161 - IF(I.LT.INEXT)GOTO 20 162 - * warn if the user uses a sub-keyword out of context. 163 - IF(INPCMP(I,'RA#NGE')+INPCMP(I,'N')+INPCMP(I,'BI#NS')+ 164 - - INPCMP(I,'LAB#ELS')+INPCMP(I,'NOLAB#ELS')+ 165 - - INPCMP(I,'A#NGLES')+INPCMP(I,'AUTO#MATIC')+ 166 - - INPCMP(I,'PR#INT')+INPCMP(I,'NOPR#INT')+ 167 - - INPCMP(I,'ON')+INPCMP(I,'SC#ALE')+ 168 - - INPCMP(I,'M#ONTE-C#ARLO-#DRIFT-#LINES')+ 169 - - INPCMP(I,'MC-#DRIFT-#LINES')+ 170 - - INPCMP(I,'NOM#ONTE-C#ARLO-#DRIFT-#LINES')+ 171 - - INPCMP(I,'NOMC-#DRIFT-#LINES')+ 172 - - INPCMP(I,'RUN#GE-K#UTTA-#DRIFT-#LINES')+ 173 - - INPCMP(I,'RKF-#DRIFT-#LINES')+ 174 - - INPCMP(I,'S#ENSE-W#IRE')+INPCMP(I,'ELEC#TRODE')+ 175 - - INPCMP(I,'GROUP').NE.0)THEN 176 - CALL INPMSG(I,'Valid option out of context. ') 177 - OK=.FALSE. 178 - IF(.NOT.FLAG(I+1))THEN 179 - CALL INPMSG(I+1,'See the previous message. ') 180 - INEXT=I+2 181 - IF(.NOT.FLAG(I+2))THEN 182 - CALL INPMSG(I+2,'See the previous messages. ') 183 - INEXT=I+3 184 - ENDIF 185 - ENDIF 186 - * warn if an unknown keywords appear, 187 - ELSEIF(.NOT.FLAG(I))THEN 188 - CALL INPMSG(I,'Item is not a known keyword. ') 189 - OK=.FALSE. 190 - ** Find out whether a GRAPH is requested next, 191 - ELSEIF(INPCMP(I,'GR#APH').NE.0)THEN 192 - * Plot already requested ? 193 - IF(LGRAPH)PRINT *,' !!!!!! SIGWGT WARNING : Only one'// 194 - - ' graph per PLOT statement can be processed.' 195 - LGRAPH=.TRUE. 196 - * Store the function string. 197 - IF(FLAG(I+1))THEN 198 - FUNCT1(1:3)='Q_E' 199 - NC1=3 200 - INEXT=I+1 201 - ELSE 202 - CALL INPSTR(I+1,I+1,STRING,NC1) 203 - FUNCT1(1:NC1)=STRING(1:NC1) 204 - INEXT=I+2 205 - ENDIF 206 - * Look for sub-keywords with GRAPH. 207 - DO 230 II=I,NWORD 208 - IF(II.LT.INEXT)GOTO 230 209 - * Look for the subkeyword ON. 210 - IF(INPCMP(II,'ON').NE.0)THEN 211 - IF(FLAG(II+1))THEN 212 - CALL INPMSG(II,'The curve function is absent. ') 213 - OK=.FALSE. 214 - ELSE 215 - CALL INPSTR(II+1,II+1,FUNTRA,NCFTRA) 216 - INEXT=II+2 1 760 P=SIGNAL D=SIGWGT 4 PAGE1173 217 - ENDIF 218 - * Look for the subkeyword N. 219 - ELSEIF(INPCMP(II,'N').NE.0)THEN 220 - IF(FLAG(II+1))THEN 221 - CALL INPMSG(II,'number of points is missing. ') 222 - OK=.FALSE. 223 - ELSE 224 - CALL INPCHK(II+1,1,IFAIL1) 225 - CALL INPRDI(II+1,NPNTR,NGRPNT) 226 - IF(NPNTR.LT.2.AND.IFAIL1.EQ.0)CALL INPMSG(II+1, 227 - - 'number of point less than 2. ') 228 - IF(NPNTR.GT.MXLIST.AND.IFAIL1.EQ.0)CALL INPMSG 229 - - (II+1,'number of points > MXLIST. ') 230 - IF(NPNTR.GE.2.AND.NPNTR.LE.MXLIST)THEN 231 - NGRPNT=NPNTR 232 - ELSE 233 - OK=.FALSE. 234 - ENDIF 235 - INEXT=II+2 236 - ENDIF 237 - * Look for print options. 238 - ELSEIF(INPCMP(II,'PR#INT').NE.0)THEN 239 - LGRPRT=.TRUE. 240 - INEXT=II+1 241 - ELSEIF(INPCMP(II,'NOPR#INT').NE.0)THEN 242 - LGRPRT=.FALSE. 243 - INEXT=II+1 244 - * Scale of the graph. 245 - ELSEIF(INPCMP(II,'SC#ALE')+INPCMP(II,'RA#NGE').NE.0)THEN 246 - IF(FLAG(II+1).OR.FLAG(II+2))THEN 247 - CALL INPMSG(II,'the arguments are missing. ') 248 - OK=.FALSE. 249 - ELSE 250 - CALL INPCHK(II+1,2,IFAIL1) 251 - CALL INPRDR(II+1,GMINR,+1.0) 252 - CALL INPCHK(II+2,2,IFAIL2) 253 - CALL INPRDR(II+2,GMAXR,-1.0) 254 - IF(GMINR.EQ.GMAXR)THEN 255 - CALL INPMSG(II+1,'zero range in the') 256 - CALL INPMSG(II+2,'scale not permitted') 257 - OK=.FALSE. 258 - ELSE 259 - GRSMIN=MIN(GMINR,GMAXR) 260 - GRSMAX=MAX(GMINR,GMAXR) 261 - ENDIF 262 - INEXT=II+3 263 - ENDIF 264 - * Otherwise skip to the next keyword. 265 - ELSE 266 - GOTO 20 267 - ENDIF 268 - 230 CONTINUE 269 - ** Find out whether a CONTOUR plot is requested next, 270 - ELSEIF(INPCMP(I,'C#ONTOUR').NE.0)THEN 271 - IF(LCONT)PRINT *,' !!!!!! SIGWGT WARNING : Only one'// 272 - - ' contour plot per PLOT statement can be processed.' 273 - LCONT=.TRUE. 274 - * Store the function string, using the default if absent. 275 - IF(FLAG(I+1))THEN 276 - FUNCT2(1:3)='Q_E' 277 - NC2=3 278 - INEXT=I+1 279 - ELSE 280 - CALL INPSTR(I+1,I+1,STRING,NC2) 281 - FUNCT2(1:NC2)=STRING(1:NC2) 282 - INEXT=I+2 283 - ENDIF 284 - * Set default values for the range, depending on the function. 285 - CMIN=0.0 286 - CMAX=10000.0 287 - * Look for sub-keywords with CONTOUR. 288 - DO 210 II=I+1,NWORD 289 - IF(II.LT.INEXT)GOTO 210 290 - * LABELing of the contours. 291 - IF(INPCMP(II,'LAB#ELS').NE.0)THEN 292 - CLAB=.TRUE. 293 - INEXT=II+1 294 - ELSEIF(INPCMP(II,'NOLAB#ELS').NE.0)THEN 295 - CLAB=.FALSE. 296 - INEXT=II+1 297 - * The RANGE subkeyword. 298 - ELSEIF(INPCMP(II,'RA#NGE').NE.0)THEN 299 - IF(INPCMP(II+1,'AUTO#MATIC').NE.0)THEN 300 - CMIN=0.0 301 - CMAX=0.0 302 - CAUTO=.TRUE. 303 - INEXT=II+2 304 - ELSEIF((.NOT.FLAG(II+1)).AND.FLAG(II+2))THEN 305 - CALL INPCHK(II+1,2,IFAIL1) 306 - CALL INPRDR(II+1,CMINR,CMIN) 307 - CMIN=CMINR 308 - CMAX=CMINR 309 - CAUTO=.FALSE. 310 - INEXT=II+2 311 - ELSEIF((.NOT.FLAG(II+1)).AND.(.NOT.FLAG(II+2)))THEN 312 - CALL INPCHK(II+1,2,IFAIL1) 313 - CALL INPCHK(II+2,2,IFAIL2) 314 - CALL INPRDR(II+1,CMINR,CMIN) 315 - CALL INPRDR(II+2,CMAXR,CMAX) 316 - CMIN=MIN(CMINR,CMAXR) 317 - CMAX=MAX(CMINR,CMAXR) 318 - CAUTO=.FALSE. 319 - INEXT=II+3 320 - ELSE 321 - CALL INPMSG(II,'RANGE takes two arguments. ') 322 - OK=.FALSE. 1 760 P=SIGNAL D=SIGWGT 5 PAGE1174 323 - IF(FLAG(II+1))THEN 324 - INEXT=II+1 325 - ELSE 326 - CALL INPMSG(II+1, 327 - - 'Ignored, see previous message.') 328 - INEXT=II+2 329 - ENDIF 330 - ENDIF 331 - * Sub keyword N. 332 - ELSEIF(INPCMP(II,'N').NE.0)THEN 333 - IF(FLAG(II+1))THEN 334 - CALL INPMSG(II,'N must have an argument. ') 335 - OK=.FALSE. 336 - INEXT=II+1 337 - ELSE 338 - CALL INPCHK(II+1,1,IFAIL1) 339 - CALL INPRDI(II+1,NCONTR,NCONT) 340 - IF(NCONTR.LT.0.AND.IFAIL1.EQ.0)CALL INPMSG(II+1, 341 - - 'number of contour steps is < 0') 342 - IF(NCONTR.GT.MXWIRE.AND.IFAIL1.EQ.0)CALL INPMSG 343 - - (II+1,'may not exceed MXWIRE. ') 344 - IF(NCONTR.GE.0.AND.NCONTR.LE.MXWIRE)THEN 345 - NCONT=NCONTR 346 - ELSE 347 - OK=.FALSE. 348 - ENDIF 349 - INEXT=II+2 350 - ENDIF 351 - * Otherwise skip to the next keyword. 352 - ELSE 353 - GOTO 20 354 - ENDIF 355 - 210 CONTINUE 356 - ** A SURFACE (3 dimensional plot) has perhaps been requested, 357 - ELSEIF(INPCMP(I,'S#URFACE').NE.0)THEN 358 - IF(LSURF)PRINT *,' !!!!!! SIGWGT WARNING : Only one'// 359 - - ' surface per PLOT statement can be processed.' 360 - LSURF=.TRUE. 361 - IF(FLAG(I+1))THEN 362 - FUNCT3(1:3)='Q_E' 363 - NC3=3 364 - INEXT=I+1 365 - ELSE 366 - CALL INPSTR(I+1,I+1,STRING,NC3) 367 - FUNCT3(1:NC3)=STRING(1:NC3) 368 - INEXT=I+2 369 - ENDIF 370 - * Look for sub-keywords with SURFACE. 371 - DO 220 II=I,NWORD 372 - IF(II.LT.INEXT)GOTO 220 373 - * Look for the subkeyword ANGLE. 374 - IF(INPCMP(II,'A#NGLES').NE.0)THEN 375 - IF(.NOT.FLAG(II+1).AND.FLAG(II+2))THEN 376 - CALL INPMSG(II,'ANGLE has 2 args: theta, phi. ') 377 - CALL INPMSG(II+1,'See the previous message. ') 378 - INEXT=II+2 379 - OK=.FALSE. 380 - ELSEIF(FLAG(II+1))THEN 381 - CALL INPMSG(II,'ANGLE has 2 args: theta, phi. ') 382 - INEXT=II+1 383 - OK=.FALSE. 384 - ELSE 385 - CALL INPCHK(II+1,2,IFAIL1) 386 - CALL INPRDR(II+1,PHI,30.0) 387 - CALL INPCHK(II+2,2,IFAIL1) 388 - CALL INPRDR(II+2,THETA,60.0) 389 - INEXT=II+3 390 - ENDIF 391 - * Otherwise skip to the next keyword. 392 - ELSE 393 - GOTO 20 394 - ENDIF 395 - 220 CONTINUE 396 - ** A vector plot. 397 - ELSEIF(INPCMP(I,'VE#CTOR').NE.0)THEN 398 - IF(LVECT)PRINT *,' !!!!!! SIGWGT WARNING : Only one'// 399 - - ' vector plot per PLOT statement can be processed.' 400 - LVECT=.TRUE. 401 - IF(FLAG(I+1).OR.FLAG(I+2))THEN 402 - IF(.NOT.POLAR)THEN 403 - FUNCT4(1:11)='EWX,EWY,EWZ' 404 - NC4=11 405 - ELSE 406 - FUNCT4(1:13)='EWR,EWPHI,EWZ' 407 - NC4=13 408 - ENDIF 409 - IF(.NOT.FLAG(I+1).AND.FLAG(I+2))THEN 410 - CALL INPSTR(I+1,I+1,STRING,NCAUX) 411 - IF(INDEX(STRING(1:NCAUX),'@').NE.0)THEN 412 - FUNCT4(1:1)='@' 413 - NC4=1 414 - ELSE 415 - CALL INPMSG(I+1, 416 - - 'Has 2 or 3 args, default used.') 417 - OK=.FALSE. 418 - ENDIF 419 - INEXT=I+2 420 - ELSE 421 - INEXT=I+1 422 - ENDIF 423 - ELSE 424 - CALL INPSTR(I+1,I+1,STRING,NC4) 425 - FUNCT4(1:NC4+1)=STRING(1:NC4)//',' 426 - CALL INPSTR(I+2,I+2,STRING,NCAUX) 427 - FUNCT4(NC4+2:NC4+NCAUX+2)=STRING(1:NCAUX)//',' 428 - NC4=NC4+NCAUX+2 1 760 P=SIGNAL D=SIGWGT 6 PAGE1175 429 - IF(.NOT.FLAG(I+3))THEN 430 - CALL INPSTR(I+3,I+3,STRING,NCAUX) 431 - FUNCT4(NC4+1:NC4+NCAUX)=STRING(1:NCAUX) 432 - NC4=NC4+NCAUX 433 - INEXT=I+4 434 - ELSE 435 - FUNCT4(NC4+1:NC4+1)='0' 436 - NC4=NC4+1 437 - INEXT=I+3 438 - ENDIF 439 - ENDIF 440 - ** Finally, find out whether the next plot is a HISTOGRAM. 441 - ELSEIF(INPCMP(I,'H#ISTOGRAM').NE.0)THEN 442 - IF(LHIST)PRINT *,' !!!!!! SIGWGT WARNING : Only one'// 443 - - ' histogram per PLOT statement can be processed.' 444 - LHIST=.TRUE. 445 - IF(FLAG(I+1))THEN 446 - FUNCT5(1:3)='Q_E' 447 - NC5=3 448 - HMIN=0.0 449 - HMAX=10000.0 450 - INEXT=I+1 451 - ELSE 452 - CALL INPSTR(I+1,I+1,STRING,NC5) 453 - FUNCT5(1:NC5)=STRING(1:NC5) 454 - INEXT=I+2 455 - ENDIF 456 - * Look for subkeywords associated with HISTOGRAM. 457 - DO 200 II=I,NWORD 458 - IF(II.LT.INEXT)GOTO 200 459 - * The RANGE subkeyword. 460 - IF(INPCMP(II,'RA#NGE').NE.0)THEN 461 - IF(INPCMP(II+1,'AUTO#MATIC').NE.0)THEN 462 - HMIN=0.0 463 - HMAX=0.0 464 - HAUTO=.TRUE. 465 - INEXT=II+2 466 - ELSEIF(.NOT.FLAG(II+1).AND..NOT.FLAG(II+2))THEN 467 - CALL INPCHK(II+1,2,IFAIL1) 468 - CALL INPCHK(II+2,2,IFAIL2) 469 - CALL INPRDR(II+1,HMINR,HMIN) 470 - CALL INPRDR(II+2,HMAXR,HMAX) 471 - HAUTO=.FALSE. 472 - IF(HMINR.EQ.HMAXR)THEN 473 - CALL INPMSG(II+1, 474 - - 'Zero range not permitted. ') 475 - CALL INPMSG(II+2, 476 - - 'See the previous message. ') 477 - OK=.FALSE. 478 - ELSE 479 - HMIN=MIN(HMINR,HMAXR) 480 - HMAX=MAX(HMINR,HMAXR) 481 - ENDIF 482 - INEXT=II+3 483 - ELSE 484 - CALL INPMSG(II,'RANGE takes two arguments. ') 485 - OK=.FALSE. 486 - IF(FLAG(II+1))THEN 487 - INEXT=II+1 488 - ELSE 489 - CALL INPMSG(II+1, 490 - - 'Ignored, see previous message.') 491 - INEXT=II+2 492 - ENDIF 493 - ENDIF 494 - * The BINS subkeyword. 495 - ELSEIF(INPCMP(II,'BI#NS').NE.0)THEN 496 - IF(FLAG(II+1))THEN 497 - CALL INPMSG(II,'This keyword has one argument.') 498 - INEXT=II+1 499 - ELSE 500 - CALL INPCHK(II+1,1,IFAIL) 501 - CALL INPRDI(II+1,NCHAR,MXCHA) 502 - IF(NCHAR.LE.1.OR.NCHAR.GT.MXCHA)THEN 503 - CALL INPMSG(II+1, 504 - - 'Inacceptable number of bins. ') 505 - OK=.FALSE. 506 - ELSE 507 - NCHA=NCHAR 508 - ENDIF 509 - INEXT=II+2 510 - ENDIF 511 - * Otherwise quit this loop. 512 - ELSE 513 - GOTO 20 514 - ENDIF 515 - 200 CONTINUE 516 - * Sense wire number. 517 - ELSEIF(INPCMP(I,'S#ENSE-W#IRE')+ 518 - - INPCMP(I,'ELEC#TRODE')+ 519 - - INPCMP(I,'GROUP').NE.0)THEN 520 - IF(INPCMP(I+1,'ALL').NE.0)THEN 521 - ISW=-1 522 - ELSEIF(INPTYP(I+1).NE.1)THEN 523 - CALL INPMSG(I,'Has an integer argument.') 524 - OK=.FALSE. 525 - ELSE 526 - CALL INPCHK(I+1,1,IFAIL1) 527 - CALL INPRDI(I+1,ISWR,1) 528 - IF(ISWR.LE.0.OR.ISWR.GT.NSW)THEN 529 - CALL INPMSG(I+1,'Not a valid sense wire') 530 - OK=.FALSE. 531 - ELSE 532 - ISW=ISWR 533 - ENDIF 534 - INEXT=I+2 1 760 P=SIGNAL D=SIGWGT 7 PAGE1176 535 - ENDIF 536 - * Time window. 537 - ELSEIF(INPCMP(I,'TIME-WIND#OW').NE.0)THEN 538 - IF(FLAG(I+1).OR.FLAG(I+2))THEN 539 - CALL INPMSG(I,'the arguments are missing. ') 540 - OK=.FALSE. 541 - ELSE 542 - IF(INPCMP(I+1,'START').NE.0)THEN 543 - QTMINR=-1.0 544 - ELSE 545 - CALL INPCHK(I+1,2,IFAIL1) 546 - CALL INPRDR(I+1,QTMINR,-1.0) 547 - IF(IFAIL1.NE.0)THEN 548 - OK=.FALSE. 549 - QTMINR=-1.0 550 - ELSEIF(QTMINR.LT.0)THEN 551 - CALL INPMSG(I+1,'Start time is < 0.') 552 - OK=.FALSE. 553 - QTMINR=-1.0 554 - ENDIF 555 - ENDIF 556 - IF(INPCMP(I+2,'INF#INITY')+INPCMP(I+2,'END').NE.0)THEN 557 - QTMAXR=-1.0 558 - ELSE 559 - CALL INPCHK(I+2,2,IFAIL2) 560 - CALL INPRDR(I+2,QTMAXR,-1.0) 561 - IF(IFAIL2.NE.0)THEN 562 - OK=.FALSE. 563 - QTMAXR=-1.0 564 - ELSEIF(QTMAXR.LT.0)THEN 565 - CALL INPMSG(I+2,'End time is < 0.') 566 - QTMAXR=-1.0 567 - OK=.FALSE. 568 - ELSEIF(QTMINR.GE.0.AND.QTMAXR.LE.QTMINR)THEN 569 - CALL INPMSG(I+2,'Is ahead of start time.') 570 - QTMAXR=-1.0 571 - OK=.FALSE. 572 - ENDIF 573 - ENDIF 574 - QTMIN=QTMINR 575 - QTMAX=QTMAXR 576 - INEXT=I+3 577 - ENDIF 578 - * Drift algorithm. 579 - ELSEIF(INPCMP(I,'M#ONTE-C#ARLO-#DRIFT-#LINES')+ 580 - - INPCMP(I,'MC-#DRIFT-#LINES').NE.0)THEN 581 - LMCDR=.TRUE. 582 - ELSEIF(INPCMP(I,'NOM#ONTE-C#ARLO-#DRIFT-#LINES')+ 583 - - INPCMP(I,'NOMC-#DRIFT-#LINES')+ 584 - - INPCMP(I,'RUN#GE-K#UTTA-#DRIFT-#LINES')+ 585 - - INPCMP(I,'RKF-#DRIFT-#LINES').NE.0)THEN 586 - LMCDR=.FALSE. 587 - ** Warn if the user aks for an unknown plot type or makes an error, 588 - ELSE 589 - CALL INPMSG(I,'Should have been a plot type. ') 590 - OK=.FALSE. 591 - ENDIF 592 - 20 CONTINUE 593 - *** Print error messages. 594 - CALL INPERR 595 - * Ensure that we got some reasonable settings. 596 - IF(NSW.LE.0)THEN 597 - PRINT *,' !!!!!! SIGWGT WARNING : No sense wire has'// 598 - - ' been selected.' 599 - RETURN 600 - ENDIF 601 - * Proceed or not ? 602 - IF(JFAIL.EQ.2.AND..NOT.OK)THEN 603 - PRINT *,' !!!!!! SIGWGT WARNING : Instruction is not'// 604 - - ' carried out because of the above errors.' 605 - RETURN 606 - ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN 607 - PRINT *,' ###### SIGWGT ERROR : Program terminated'// 608 - - ' because of the above errors.' 609 - CALL QUIT 610 - ENDIF 611 - *** Next print the list of plots if the DEBUG option is on. 612 - IF(LDEBUG)THEN 613 - WRITE(LUNOUT,'( 614 - - '' ++++++ SIGWGT DEBUG : List of requested plots:''/ 615 - - '' Type Y/N '', 616 - - ''Function (1:20) NC <--------Range-------> '', 617 - - ''# cont # bins <-------Angle-------->'')') 618 - IF(LGRAPH)THEN 619 - WRITE(LUNOUT,'(26X,A10,L2,3X,A20,1X,I3,34X,I6)') 620 - - 'Graph ',LGRAPH,FUNCT1(1:20),NC1,NGRPNT 621 - ELSE 622 - WRITE(LUNOUT,'(26X,A10,L2)') 'Graph ',LGRAPH 623 - ENDIF 624 - IF(LCONT.AND..NOT.CAUTO)THEN 625 - WRITE(LUNOUT, 626 - - '(26X,A7,3X,L2,3X,A20,1X,I3,2(2X,E10.3),2X,I6)') 627 - - 'Contour',LCONT,FUNCT2(1:20),NC2,CMIN,CMAX,NCONT 628 - ELSEIF(LCONT.AND.CAUTO)THEN 629 - WRITE(LUNOUT,'(26X,A7,3X,L2,3X,A20,1X,I3, 630 - - '' Automatic scaling'',2X,I6)') 631 - - 'Contour',LCONT,FUNCT2(1:20),NC2,NCONT 632 - ELSE 633 - WRITE(LUNOUT,'(26X,A10,L2)') 'Contour ',LCONT 634 - ENDIF 635 - IF(LSURF)THEN 636 - WRITE(LUNOUT, 637 - - '(26X,A10,L2,3X,A20,1X,I3,40X,2(2X,E10.3))') 638 - - 'Surface ',LSURF,FUNCT3(1:20),NC3,PHI,THETA 639 - ELSE 640 - WRITE(LUNOUT,'(26X,A10,L2)') 'Surface ',LSURF 1 760 P=SIGNAL D=SIGWGT 8 PAGE1177 641 - ENDIF 642 - IF(LVECT)THEN 643 - WRITE(LUNOUT,'(26X,A10,L2,3X,A20,1X,I3)') 644 - - 'Vector ',LVECT ,FUNCT4(1:20),NC4 645 - ELSE 646 - PRINT '(26X,A10,L2)','Vector ',LVECT 647 - ENDIF 648 - IF(LHIST.AND..NOT.HAUTO)THEN 649 - WRITE(LUNOUT, 650 - - '(26X,A10,L2,3X,A20,1X,I3,2(2X,E10.3),10X,I6)') 651 - - 'Histogram ',LHIST ,FUNCT5(1:20),NC5, 652 - - HMIN,HMAX,NCHA 653 - ELSEIF(LHIST)THEN 654 - WRITE(LUNOUT,'(26X,A10,L2,3X,A20,1X,I3, 655 - - '' Automatic scaling'',10X,I6)') 656 - - 'Histogram ',LHIST ,FUNCT5(1:20),NC5,NCHA 657 - ELSE 658 - WRITE(LUNOUT,'(26X,A10,L2)') 'Histogram ',LHIST 659 - ENDIF 660 - WRITE(LUNOUT,'('' ++++++ SIGWGT DEBUG : Selected sense'', 661 - - '' wire: '',I4/)') ISW 662 - WRITE(LUNOUT,'('' ++++++ SIGWGT DEBUG : Time window '', 663 - - 2E15.8)') QTMIN,QTMAX 664 - ENDIF 665 - *** Loop over the sense wires. 666 - DO 40 JSW=1,NSW 667 - IF(ISW.NE.-1.AND.ISW.NE.JSW)GOTO 40 668 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGWGT DEBUG : Sense'', 669 - - '' wire group '',I3)') JSW 670 - * Prepare a group label. 671 - CALL OUTFMT(REAL(JSW),2,AUX1,NCAUX1,'LEFT') 672 - GROUP=' (Group '//AUX1(1:NCAUX1)//')' 673 - NCGR=9+NCAUX1 674 - *** Take care of the 'GRAPH' type plots, translate curve function. 675 - IF(LGRAPH.AND.FUNTRA(1:NCFTRA).NE.'?')THEN 676 - CALL ALGPRE(FUNTRA,NCFTRA,VARLIS(26),1,NRES,USE(26), 677 - - IENTRA,IFAIL) 678 - IF(IFAIL.NE.0)THEN 679 - PRINT *,' !!!!!! SIGWGT WARNING : Graph not made'// 680 - - ' because of an error in the track function.' 681 - CALL ALGCLR(IENTRA) 682 - GOTO 101 683 - ELSEIF(NRES.NE.3)THEN 684 - PRINT *,' !!!!!! SIGWGT WARNING : Graph not made'// 685 - - ' because the curve does not give 3 results.' 686 - CALL ALGCLR(IENTRA) 687 - GOTO 101 688 - ELSEIF(.NOT.USE(26))THEN 689 - PRINT *,' !!!!!! SIGWGT WARNING : Graph not made'// 690 - - ' because the track does not depend on T.' 691 - CALL ALGCLR(IENTRA) 692 - GOTO 101 693 - ENDIF 694 - * If no curve is defined, the track must be. 695 - ELSEIF(LGRAPH.AND..NOT.TRFLAG(1))THEN 696 - PRINT *,' !!!!!! SIGWGT WARNING : Neither a track nor'// 697 - - ' a curve has been defined ; graph not made.' 698 - GOTO 101 699 - ENDIF 700 - * Parameters look a priori acceptable. 701 - IF(LGRAPH)THEN 702 - * Transform the function into an instruction list, 703 - IF(INDEX(FUNCT1(1:NC1),'@').NE.0)THEN 704 - NRES=1 705 - CALL ALGEDT(VARLIS,25,IENTRY,USE,NRES) 706 - FUNCT1='Edited function' 707 - NC1=15 708 - ELSE 709 - CALL ALGPRE(FUNCT1,NC1,VARLIS,25,NRES,USE,IENTRY,IFAIL) 710 - IF(IFAIL.NE.0)THEN 711 - PRINT *,' !!!!!! SIGWGT WARNING : Graph not'// 712 - - ' produced because of syntax errors.' 713 - GOTO 100 714 - ENDIF 715 - ENDIF 716 - * Be sure only one result is returned. 717 - IF(NRES.NE.1)THEN 718 - PRINT *,' !!!!!! SIGWGT WARNING : The function'// 719 - - ' does not return precisely 1 result; no graph.' 720 - GOTO 100 721 - ENDIF 722 - * Figure out which quatities are effectively used. 723 - EVALW=.FALSE. 724 - EVALB=.FALSE. 725 - EVALV=.FALSE. 726 - EVALE=.FALSE. 727 - EVALI=.FALSE. 728 - EVALQ=.FALSE. 729 - EVALP=.FALSE. 730 - IF(USE(17).OR.USE(18).OR.USE(19).OR.USE(20))EVALW=.TRUE. 731 - IF(USE( 7).OR.USE( 8).OR.USE( 9).OR.USE(10))EVALB=.TRUE. 732 - IF(USE(11).OR.USE(12).OR.USE(13).OR.USE(14))EVALV=.TRUE. 733 - IF(USE(15).OR.USE(21).OR.USE(24))EVALE=.TRUE. 734 - IF(USE(16).OR.USE(22).OR.USE(25))EVALI=.TRUE. 735 - IF(USE(21))EVALQ=.TRUE. 736 - IF(USE(22))EVALP=.TRUE. 737 - * check the use of magnetic field quantities, 738 - IF(EVALB.AND..NOT.MAGOK)THEN 739 - PRINT *,' !!!!!! SIGWGT WARNING : The function to be'// 740 - - ' plotted uses magnetic field quantities,' 741 - PRINT *,' no such field has'// 742 - - ' been defined however ; plot not made.' 743 - GOTO 100 744 - ENDIF 745 - IF((USE(7).OR.USE(8)).AND.POLAR)THEN 746 - PRINT *,' !!!!!! SIGWGT WARNING : Bx and By should'// 1 760 P=SIGNAL D=SIGWGT 9 PAGE1178 747 - - ' not be used with polar cells ; plot not made.' 748 - GOTO 100 749 - ENDIF 750 - * Select the axis with the largest range for ordinate. 751 - IF(FUNTRA(1:NCFTRA).NE.'?')THEN 752 - ICOORD=3 753 - ELSEIF(POLAR)THEN 754 - CALL CFMCTP(XT0,YT0,RT0,PT0,1) 755 - CALL CFMCTP(XT1,YT1,RT1,PT1,1) 756 - IF((ZT1-ZT0)**2.GT.(XT1-XT0)**2+(YT1-YT0)**2)THEN 757 - ICOORD=11 758 - ELSEIF(ABS(RT0-RT1).GT.ABS(PT0-PT1))THEN 759 - ICOORD=1 760 - ELSE 761 - ICOORD=2 762 - ENDIF 763 - ELSE 764 - IF((ZT1-ZT0)**2.GT.(XT1-XT0)**2+(YT1-YT0)**2)THEN 765 - ICOORD=11 766 - ELSEIF(ABS(XT0-XT1).GT.ABS(YT0-YT1))THEN 767 - ICOORD=1 768 - ELSE 769 - ICOORD=2 770 - ENDIF 771 - ENDIF 772 - * Print a heading for the numbers. 773 - IF(FUNTRA(1:NCFTRA).EQ.'?')THEN 774 - IF(LGRPRT)WRITE(LUNOUT,'(/'' GRAPH OF '',A, 775 - - '' ON '',A//2X,''Coordinate'',48X,''Function'')') 776 - - FUNCT1(1:NC1),'THE TRACK' 777 - ELSE 778 - IF(LGRPRT)WRITE(LUNOUT,'(/'' GRAPH OF '',A, 779 - - '' ON '',A//2X,''Coordinate'',48X,''Function'')') 780 - - FUNCT1(1:NC1),FUNTRA(1:NCFTRA) 781 - ENDIF 782 - * Fill the vectors, 783 - ITYPE=1 784 - QPLT=-1.0 785 - DO 30 I=1,NGRPNT 786 - IF(ICOORD.NE.3)THEN 787 - XPOS=XT0+REAL(I-1)*(XT1-XT0)/REAL(NGRPNT-1) 788 - YPOS=YT0+REAL(I-1)*(YT1-YT0)/REAL(NGRPNT-1) 789 - ZPOS=ZT0+REAL(I-1)*(ZT1-ZT0)/REAL(NGRPNT-1) 790 - IF(POLAR)CALL CFMCTR(XPOS,YPOS,XPOS,YPOS,1) 791 - ELSE 792 - VAR(1)=REAL(I-1)/REAL(NGRPNT-1) 793 - MODVAR(1)=2 794 - CALL ALGEXE(IENTRA,VAR,MODVAR,1,RES,MODRES,3,IFAIL) 795 - XPOS=RES(1) 796 - YPOS=RES(2) 797 - ZPOS=RES(3) 798 - IF(POLAR)CALL CFMPTR(XPOS,YPOS,XPOS,YPOS,1,IFAIL1) 799 - IF(IFAIL1.NE.0)THEN 800 - XPOS=1.0 801 - YPOS=0.0 802 - ZPOS=0.0 803 - PRINT *,' !!!!!! SIGWGT WARNING : The curve'// 804 - - ' function returns invalid coordinates.' 805 - ENDIF 806 - ENDIF 807 - CALL SCONT2(XPOS,YPOS,ZPOS,RES,MODRES,1,ILOC) 808 - IF(ICOORD.EQ.3)THEN 809 - COORD(I)=REAL(I-1)/REAL(NGRPNT-1) 810 - ELSEIF(ICOORD.EQ.2)THEN 811 - COORD(I)=YPOS 812 - ELSEIF(ICOORD.EQ.11)THEN 813 - COORD(I)=ZPOS 814 - ELSE 815 - COORD(I)=XPOS 816 - ENDIF 817 - VALUE(I)=RES(1) 818 - * Print the point if this has been requested. 819 - IF(LGRPRT)WRITE(LUNOUT,'(4(2X,E15.8))') 820 - - XPOS,YPOS,ZPOS,VALUE(I) 821 - 30 CONTINUE 822 - * Plot the graph. 823 - IF(GRSMIN.LT.GRSMAX)CALL GRGRSC(GRSMIN,GRSMAX) 824 - IF(ICOORD.EQ.3)THEN 825 - CALL GRGRPH(COORD,VALUE,NGRPNT,'Curve parameter', 826 - - FUNCT1(1:NC1),'Graph of '//FUNCT1(1:NC1)// 827 - - GROUP(1:NCGR)) 828 - ELSEIF(POLAR.AND.ICOORD.EQ.1)THEN 829 - CALL GRGRPH(COORD,VALUE,NGRPNT,'Radius [cm]', 830 - - FUNCT1(1:NC1),'Graph of '//FUNCT1(1:NC1)// 831 - - GROUP(1:NCGR)) 832 - ELSEIF(POLAR.AND.ICOORD.EQ.2)THEN 833 - CALL GRGRPH(COORD,VALUE,NGRPNT,'Angle [degrees]', 834 - - FUNCT1(1:NC1),'Graph of '//FUNCT1(1:NC1)// 835 - - GROUP(1:NCGR)) 836 - ELSEIF((.NOT.POLAR).AND.ICOORD.EQ.1)THEN 837 - CALL GRGRPH(COORD,VALUE,NGRPNT,'x-Axis [cm]', 838 - - FUNCT1(1:NC1),'Graph of '//FUNCT1(1:NC1)// 839 - - GROUP(1:NCGR)) 840 - ELSEIF((.NOT.POLAR).AND.ICOORD.EQ.2)THEN 841 - CALL GRGRPH(COORD,VALUE,NGRPNT,'y-Axis [cm]', 842 - - FUNCT1(1:NC1),'Graph of '//FUNCT1(1:NC1)// 843 - - GROUP(1:NCGR)) 844 - ELSEIF((.NOT.POLAR).AND.ICOORD.EQ.11)THEN 845 - CALL GRGRPH(COORD,VALUE,NGRPNT,'z-Axis [cm]', 846 - - FUNCT1(1:NC1),'Graph of '//FUNCT1(1:NC1)// 847 - - GROUP(1:NCGR)) 848 - ELSE 849 - PRINT *,' ###### SIGWGT ERROR : Inconsistent axis'// 850 - - ' selection ; program bug - please report.' 851 - ENDIF 852 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 1 760 P=SIGNAL D=SIGWGT 10 PAGE1179 853 - * Log this frame and prepare for the next plot. 854 - CALL GRNEXT 855 - CALL GRALOG('Graph of '//FUNCT1(1:NC1)//GROUP(1:NCGR)//':') 856 - CALL TIMLOG('Plotting the graph of '//FUNCT1(1:NC1)// 857 - - GROUP(1:NCGR)//':') 858 - * print the number of arithmetic errors. 859 - CALL ALGERR 860 - 100 CONTINUE 861 - * Release the entry points. 862 - CALL ALGCLR(IENTRY) 863 - IF(FUNTRA(1:NCFTRA).NE.'?')CALL ALGCLR(IENTRA) 864 - ENDIF 865 - * Continue here if the parameters were not acceptable. 866 - 101 CONTINUE 867 - *** Take care of the contours. 868 - IF(LCONT)THEN 869 - * Convert to an instruction list, 870 - IF(INDEX(FUNCT2(1:NC2),'@').NE.0)THEN 871 - NRES=1 872 - CALL ALGEDT(VARLIS,25,IENTRY,USE,NRES) 873 - FUNCT2='Edited function' 874 - NC2=15 875 - ELSE 876 - CALL ALGPRE(FUNCT2,NC2,VARLIS,25,NRES,USE,IENTRY,IFAIL) 877 - IF(IFAIL.NE.0)THEN 878 - PRINT *,' !!!!!! SIGWGT WARNING : No contour'// 879 - - ' plot because of function syntax errors.' 880 - GOTO 110 881 - ENDIF 882 - ENDIF 883 - * Be sure only one result is returned. 884 - IF(NRES.NE.1)THEN 885 - PRINT *,' !!!!!! SIGWGT WARNING : The function does'// 886 - - ' not return precisely 1 result; no contour.' 887 - GOTO 110 888 - ENDIF 889 - * Figure out which quatities are effectively used. 890 - EVALW=.FALSE. 891 - EVALB=.FALSE. 892 - EVALV=.FALSE. 893 - EVALE=.FALSE. 894 - EVALI=.FALSE. 895 - EVALQ=.FALSE. 896 - EVALP=.FALSE. 897 - IF(USE(17).OR.USE(18).OR.USE(19).OR.USE(20))EVALW=.TRUE. 898 - IF(USE( 7).OR.USE( 8).OR.USE( 9).OR.USE(10))EVALB=.TRUE. 899 - IF(USE(11).OR.USE(12).OR.USE(13).OR.USE(14))EVALV=.TRUE. 900 - IF(USE(15).OR.USE(21).OR.USE(24))EVALE=.TRUE. 901 - IF(USE(16).OR.USE(22).OR.USE(25))EVALI=.TRUE. 902 - IF(USE(21))EVALQ=.TRUE. 903 - IF(USE(22))EVALP=.TRUE. 904 - * Check the use of magnetic field quantities. 905 - IF(EVALB.AND..NOT.MAGOK)THEN 906 - PRINT *,' !!!!!! SIGWGT WARNING : The function to be'// 907 - - ' plotted uses magnetic field quantities,' 908 - PRINT *,' no such field has'// 909 - - ' been defined however ; plot not made.' 910 - GOTO 110 911 - ENDIF 912 - IF((USE(7).OR.USE(8)).AND.POLAR)THEN 913 - PRINT *,' !!!!!! SIGWGT WARNING : Bx and By should'// 914 - - ' not be used with polar cells ; plot not made.' 915 - GOTO 110 916 - ENDIF 917 - * Set electrons. 918 - ITYPE=1 919 - QPLT=-1.0 920 - * Plot the contours. 921 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 922 - - 'Contours of '//FUNCT2(1:NC2)//GROUP(1:NCGR)) 923 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 924 - NCONTP=NCONT 925 - CALL GRCONT(SCONT1,CMIN,CMAX,VXMIN,VYMIN,VXMAX,VYMAX, 926 - - NCONTP,CAUTO,POLAR,CLAB) 927 - CALL GRNEXT 928 - * Print the table of contour heights. 929 - CALL OUTFMT(CMIN,2,AUX1,NCAUX1,'LEFT') 930 - CALL OUTFMT(CMAX,2,AUX2,NCAUX2,'LEFT') 931 - CALL OUTFMT(REAL(NCONTP),2,AUX3,NCAUX3,'LEFT') 932 - CALL OUTFMT((CMAX-CMIN)/REAL(MAX(1,NCONTP)),2, 933 - - AUX4,NCAUX4,'LEFT') 934 - IF(NCONTP.GE.1)WRITE(LUNOUT,'(/'' The contours'', 935 - - '' correspond to '',A,'' = '',A,'' to '',A, 936 - - '' in '',A,'' steps.''/'' The interval between 2'', 937 - - '' contours is '',A,''.'')') 938 - - FUNCT2(1:NC2),AUX1(1:NCAUX1),AUX2(1:NCAUX2), 939 - - AUX3(1:NCAUX3),AUX4(1:NCAUX4) 940 - IF(NCONTP.EQ.0)WRITE(LUNOUT,'(/'' The contour'', 941 - - '' corresponds to '',A,'' = '',A,''.'')') 942 - - FUNCT2(1:NC2),AUX1(1:NCAUX1) 943 - * Keep track of the plots being made. 944 - CALL GRALOG('Contours of '//FUNCT2(1:NC2)// 945 - - GROUP(1:NCGR)//':') 946 - CALL TIMLOG('Plotting contours of '//FUNCT2(1:NC2)// 947 - - GROUP(1:NCGR)//':') 948 - * Print the number of arithmetic errors. 949 - CALL ALGERR 950 - 110 CONTINUE 951 - CALL ALGCLR(IENTRY) 952 - ENDIF 953 - *** If one of the other plots is asked for, prepare the function string. 954 - IF(LHIST.OR.LSURF.OR.LVECT)THEN 955 - NCTOT=0 956 - IF(LSURF)THEN 957 - ISURF=1 958 - FUNCT1(1:NC3)=FUNCT3(1:NC3) 1 760 P=SIGNAL D=SIGWGT 11 PAGE1180 959 - NCTOT=NC3 960 - ENDIF 961 - IF(LVECT)THEN 962 - IF(LSURF)THEN 963 - IVECT1=2 964 - IVECT2=3 965 - IVECT3=4 966 - FUNCT1(NCTOT+1:NCTOT+NC4+1)=','//FUNCT4(1:NC4) 967 - NCTOT=NCTOT+NC4+1 968 - ELSE 969 - IVECT1=1 970 - IVECT2=2 971 - IVECT3=3 972 - FUNCT1(1:NC4)=FUNCT4(1:NC4) 973 - NCTOT=NC4 974 - ENDIF 975 - ENDIF 976 - IF(LHIST)THEN 977 - IF(LSURF.OR.LVECT)THEN 978 - IF(LSURF.AND..NOT.LVECT)IHIST=2 979 - IF(LVECT.AND..NOT.LSURF)IHIST=4 980 - IF(LSURF.AND. LVECT)IHIST=5 981 - FUNCT1(NCTOT+1:NCTOT+NC5+1)=','//FUNCT5(1:NC5) 982 - NCTOT=NCTOT+NC5+1 983 - ELSE 984 - IHIST=1 985 - FUNCT1(1:NC5)=FUNCT5(1:NC5) 986 - NCTOT=NC5 987 - ENDIF 988 - ENDIF 989 - * Turn it into an instruction list, 990 - NREXP=0 991 - IF(LHIST)NREXP=NREXP+1 992 - IF(LSURF)NREXP=NREXP+1 993 - IF(LVECT)NREXP=NREXP+3 994 - IF(INDEX(FUNCT1(1:NCTOT),'@').NE.0)THEN 995 - NRES=NREXP 996 - CALL ALGEDT(VARLIS,25,IENTRY,USE,NRES) 997 - FUNCT1='Edited function' 998 - NCTOT=15 999 - ELSE 1000 - CALL ALGPRE(FUNCT1,NCTOT,VARLIS,25,NRES,USE,IENTRY, 1001 - - IFAIL) 1002 - IF(IFAIL.NE.0)THEN 1003 - PRINT *,' !!!!!! SIGWGT WARNING : Plots not'// 1004 - - ' produced because of syntax errors.' 1005 - GOTO 120 1006 - ENDIF 1007 - ENDIF 1008 - * Be sure the right number of result is returned. 1009 - IF(NRES.NE.NREXP)THEN 1010 - PRINT *,' !!!!!! SIGWGT WARNING : The function does'// 1011 - - ' not return the correct number of results;'// 1012 - - ' histogram, surface and vector plot skipped.' 1013 - GOTO 120 1014 - ENDIF 1015 - * Figure out which quatities are effectively used. 1016 - EVALW=.FALSE. 1017 - EVALB=.FALSE. 1018 - EVALV=.FALSE. 1019 - EVALE=.FALSE. 1020 - EVALI=.FALSE. 1021 - EVALQ=.FALSE. 1022 - EVALP=.FALSE. 1023 - IF(USE(17).OR.USE(18).OR.USE(19).OR.USE(20))EVALW=.TRUE. 1024 - IF(USE( 7).OR.USE( 8).OR.USE( 9).OR.USE(10))EVALB=.TRUE. 1025 - IF(USE(11).OR.USE(12).OR.USE(13).OR.USE(14))EVALV=.TRUE. 1026 - IF(USE(15).OR.USE(21).OR.USE(24))EVALE=.TRUE. 1027 - IF(USE(16).OR.USE(22).OR.USE(25))EVALI=.TRUE. 1028 - IF(USE(21))EVALQ=.TRUE. 1029 - IF(USE(22))EVALP=.TRUE. 1030 - * check the use of magnetic field quantities, 1031 - IF(EVALB.AND..NOT.MAGOK)THEN 1032 - PRINT *,' !!!!!! SIGWGT WARNING : The function to be'// 1033 - - ' plotted uses magnetic field quantities,' 1034 - PRINT *,' no such field has'// 1035 - - ' been defined however ; plot not made.' 1036 - GOTO 120 1037 - ENDIF 1038 - IF((USE(7).OR.USE(8)).AND.POLAR)THEN 1039 - PRINT *,' !!!!!! SIGWGT WARNING : Bx and By should'// 1040 - - ' not be used with polar cells ; plot not made.' 1041 - GOTO 120 1042 - ENDIF 0 1043-+ +SELF,IF=NAG. 1044 - * Obtain the matrix for surface plotting. 1045 - IF(LSURF)THEN 1046 - CALL BOOK('BOOK','MATRIX','SURFACE',IFAIL) 1047 - IF(IFAIL.NE.0)THEN 1048 - PRINT *,' !!!!!! SIGWGT WARNING : Unable to'// 1049 - - ' obtain storage for the surface plot.' 1050 - PRINT *,' The plot'// 1051 - - ' will not be made.' 1052 - LSURF=.FALSE. 1053 - ENDIF 1054 - ENDIF 0 1055-+ +SELF. 1056 - * Open a plotting frame for a VECTOR plot, if requested. 1057 - IF(LVECT)THEN 1058 - CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, 1059 - - 'Vector plot of '//FUNCT4(1:NC4)//GROUP(1:NCGR)) 1060 - CALL GRALOG('Vector plot of '//FUNCT4(1:NC4)// 1061 - - GROUP(1:NCGR)//':') 1062 - * Otherwise, merely request the viewing area. 1 760 P=SIGNAL D=SIGWGT 12 PAGE1181 1063 - ELSE 1064 - CALL GRVIEW(VXMIN,VYMIN,VXMAX,VYMAX) 1065 - ENDIF 1066 - * Add labels. 1067 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 1068 - * Allocate an histogram, if needed. 1069 - IF(LHIST)THEN 1070 - CALL HISADM('ALLOCATE',IHISRF,NCHA,HMIN,HMAX, 1071 - - HAUTO,IFAIL) 1072 - IF(IFAIL.NE.0)THEN 1073 - PRINT *,' !!!!!! SIGWGT WARNING : Unable to'// 1074 - - ' allocate histogram storage; histogram'// 1075 - - ' cancelled.' 1076 - LHIST=.FALSE. 1077 - ENDIF 1078 - ENDIF 1079 - * Set representation for the vector plot. 1080 - IF(LVECT)CALL GRATTS('FUNCTION-1','POLYLINE') 1081 - * Set electrons. 1082 - ITYPE=1 1083 - QPLT=-1.0 1084 - * Fill all the arrays and matrices required for these plots. 1085 - NDATA=0 1086 - DO 50 I=1,NGRIDX 1087 - IF(.NOT.POLAR)THEN 1088 - XXPOS=VXMIN+REAL(I-1)*(VXMAX-VXMIN)/REAL(NGRIDX-1) 1089 - ELSE 1090 - XXPOS=LOG(EXP(VXMIN)+REAL(I-1)*(EXP(VXMAX)-EXP(VXMIN))/ 1091 - - REAL(NGRIDX-1)) 1092 - ENDIF 1093 - * set a normalisation factor, to get the arrows more or less right 1094 - IF(.NOT.POLAR)THEN 1095 - FACNRM=MIN(VYMAX-VYMIN,VXMAX-VXMIN)/REAL(NGRIDX) 1096 - ELSE 1097 - FACNRM=LOG((EXP(VXMIN)+REAL(I-1)*(EXP(VXMAX)- 1098 - - EXP(VXMIN))/REAL(NGRIDX))/(EXP(VXMIN)+REAL(I)* 1099 - - (EXP(VXMAX)-EXP(VXMIN))/REAL(NGRIDX))) 1100 - ENDIF 1101 - DO 60 J=1,NGRIDY 1102 - YYPOS=VYMIN+REAL(J-1)*(VYMAX-VYMIN)/REAL(NGRIDY-1) 1103 - * Coordinate transformation to the viewing plane. 1104 - XPOS=FPROJ(1,1)*XXPOS+FPROJ(2,1)*YYPOS+FPROJ(3,1) 1105 - YPOS=FPROJ(1,2)*XXPOS+FPROJ(2,2)*YYPOS+FPROJ(3,2) 1106 - ZPOS=FPROJ(1,3)*XXPOS+FPROJ(2,3)*YYPOS+FPROJ(3,3) 1107 - * Compute the formulae. 1108 - CALL SCONT2(XPOS,YPOS,ZPOS,RES,MODRES,5,ILOC) 0 1109-+ +SELF,IF=NAG,HIGZ. 1110 - * Preset the surface to 0. 1111 - IF(LSURF)WS(I,J)=0.0 0 1112-+ +SELF. 1113 - * Check location code. 1114 - IF(ILOC.NE.0)GOTO 60 1115 - NDATA=NDATA+1 1116 - * Vector plot plotting. 1117 - IF(LVECT)THEN 1118 - IF(RES(IVECT1)**2+RES(IVECT2)**2+RES(IVECT3)**2.GT.0) 1119 - - CALL PLAARR(XPOS,YPOS,ZPOS, 1120 - - 0.5*FACNRM*RES(IVECT1)/SQRT(RES(IVECT1)**2+ 1121 - - RES(IVECT2)**2+RES(IVECT3)**2), 1122 - - 0.5*FACNRM*RES(IVECT2)/SQRT(RES(IVECT1)**2+ 1123 - - RES(IVECT2)**2+RES(IVECT3)**2), 1124 - - 0.5*FACNRM*RES(IVECT3)/SQRT(RES(IVECT1)**2+ 1125 - - RES(IVECT2)**2+RES(IVECT3)**2)) 1126 - ENDIF 1127 - * Fill the histogram, if requested, 1128 - IF(LHIST)CALL HISENT(IHISRF,RES(IHIST),1.0) 0 1129-+ +SELF,IF=NAG,HIGZ. 1130 - * Fill the surface plot, if requested. 1131 - IF(LSURF)WS(I,J)=RES(ISURF) 0 1132-+ +SELF. 1133 - 60 CONTINUE 1134 - 50 CONTINUE 1135 - * Close the vector plot. 1136 - CALL TIMLOG('Accumulating plot data on the grid: ') 1137 - IF(LVECT)CALL GRNEXT 1138 - * Verify data count. 1139 - IF(NDATA.EQ.0)THEN 1140 - CALL ALGERR 1141 - PRINT *,' !!!!!! SIGWGT WARNING : Viewing plane grid'// 1142 - - ' has no points in the drift medium; no surface'// 1143 - - ' or histogram.' 1144 - GOTO 120 1145 - ENDIF 1146 - * Plot the 3-dimensional picture if requested 1147 - IF(LSURF)THEN 0 1148-+ +SELF,IF=NAG. 1149 - * Check that the surface is not flat. 1150 - IFLAT=1 1151 - DO 80 ICHK=1,NGRIDX 1152 - DO 70 JCHK=1,NGRIDY 1153 - IF(ABS(WS(ICHK,JCHK)-WS(1,1)).GT.1.0E-5* 1154 - - (1.0+ABS(WS(ICHK,JCHK))+ABS(WS(1,1))))IFLAT=0 1155 - 70 CONTINUE 1156 - 80 CONTINUE 1157 - IF(IFLAT.NE.0)THEN 1158 - PRINT *,' !!!!!! SIGWGT WARNING : The surface is', 1159 - - ' not plotted because it is entirely flat.' 1160 - CALL BOOK('RELEASE','MATRIX','SURFACE',IFAIL) 1161 - GOTO 90 1162 - ENDIF 1163 - * Switch the screen to graphics mode. 1 760 P=SIGNAL D=SIGWGT 13 PAGE1182 1164 - CALL GRGRAF(.TRUE.) 1165 - * Store the CH eXPansion, NAG has the nasty habit of changing it. 1166 - CALL GQCHXP(IERR,CHEXP) 1167 - IF(IERR.NE.0)CHEXP=1.0 1168 - * Initialize NAG. 1169 - CALL X04AAF(1,10) 1170 - CALL J06WAF 1171 - CALL J06WCF(0.1D0,0.9D0,0.1D0,0.9D0) 1172 - CALL J06WBF(0.0D0,1.0D0,0.0D0,1.0D0,1) 1173 - IFAIL=0 1174 - IF(POLAR)THEN 1175 - CALL J06HCF(WS,MXWIRE,NGRIDX,NGRIDY,DBLE(THETA), 1176 - - DBLE(PHI),'Along a radius', 1177 - - 'Increasing angle',IFAIL) 1178 - ELSE 1179 - CALL J06HCF(WS,MXWIRE,NGRIDX,NGRIDY,DBLE(THETA), 1180 - - DBLE(PHI),'u-axis','v-axis',IFAIL) 1181 - ENDIF 1182 - CALL GRNEXT 1183 - * Reset the CH eXPension factor to the original value, 1184 - CALL GSCHXP(CHEXP) 1185 - CALL TIMLOG('Making a 3D plot of '//FUNCT3(1:NC3)// 1186 - - GROUP(1:NCGR)//':') 1187 - CALL GRALOG('3-D plot of '//FUNCT3(1:NC3)// 1188 - - GROUP(1:NCGR)//':') 0 1189-+ +SELF,IF=HIGZ. 1190 - * Check that the surface is not flat. 1191 - IFLAT=1 1192 - SMIN=WS(1,1) 1193 - SMAX=WS(1,1) 1194 - DO 80 ICHK=1,NGRIDX 1195 - DO 70 JCHK=1,NGRIDY 1196 - IF(ABS(WS(ICHK,JCHK)-WS(1,1)).GT.1.0E-5* 1197 - - (1.0+ABS(WS(ICHK,JCHK))+ABS(WS(1,1))))IFLAT=0 1198 - SMIN=MIN(SMIN,WS(1,1)) 1199 - SMAX=MAX(SMAX,WS(1,1)) 1200 - 70 CONTINUE 1201 - 80 CONTINUE 1202 - IF(IFLAT.NE.0)THEN 1203 - PRINT *,' !!!!!! SIGWGT WARNING : The surface is', 1204 - - ' not plotted because it is entirely flat.' 1205 - GOTO 90 1206 - ENDIF 1207 - * Switch the screen to graphics mode. 1208 - CALL GRGRAF(.TRUE.) 1209 - * Fill the PAR vector. 1210 - PAR(1)=THETA 1211 - PAR(2)=PHI 1212 - PAR(3)=VXMIN 1213 - PAR(4)=VXMAX 1214 - PAR(5)=VYMIN 1215 - PAR(6)=VYMAX 1216 - PAR(7)=SMIN 1217 - PAR(8)=SMAX 1218 - PAR(9)=1000+NGRIDX 1219 - PAR(10)=1000+NGRIDY 1220 - PAR(11)=510 1221 - PAR(12)=510 1222 - PAR(13)=510 1223 - PAR(14)=1 1224 - PAR(15)=1 1225 - PAR(16)=1 1226 - PAR(17)=0.02 1227 - PAR(18)=0.02 1228 - PAR(19)=0.02 1229 - PAR(20)=0.03 1230 - PAR(21)=2 1231 - PAR(22)=0.03 1232 - PAR(23)=0.03 1233 - PAR(24)=0.03 1234 - PAR(25)=7 1235 - PAR(26)=8 1236 - PAR(27)=9 1237 - PAR(28)=10 1238 - PAR(29)=11 1239 - PAR(30)=12 1240 - PAR(31)=13 1241 - PAR(32)=14 1242 - PAR(33)=15 1243 - PAR(34)=16 1244 - PAR(35)=17 1245 - PAR(36)=18 1246 - PAR(37)=19 1247 - * Plot the surface. 1248 - CALL ISVP(1,0.1,0.9,0.1,0.9) 1249 - CALL ISWN(1,0.0,1.0,0.0,1.0) 1250 - CALL ISELNT(1) 1251 - CALL IGTABL(MXGRID,MXGRID,WS,37,PAR,'S1') 1252 - * Add labels. 1253 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 1254 - * Plot the title. 1255 - CALL GSELNT(0) 1256 - CALL GSTXAL(0,0) 1257 - CALL GSCHUP(0.0,1.0) 1258 - CALL GRATTS('TITLE','TEXT') 1259 - CALL GRTX(0.1,0.95,'Surface of '//FUNCT3(1:NC3)// 1260 - - GROUP(1:NCGR)) 1261 - * Close the plot. 1262 - CALL GRNEXT 1263 - * Record what happened. 1264 - CALL TIMLOG('Making a 3D plot of '//FUNCT3(1:NC3)// 1265 - - GROUP(1:NCGR)//':') 1266 - CALL GRALOG('3-D plot of '//FUNCT3(1:NC3)// 1267 - - GROUP(1:NCGR)//':') 1 760 P=SIGNAL D=SIGWGT 14 PAGE1183 1268-+ +SELF,IF=-NAG,IF=-HIGZ. 1269 - * No graphics system present to plot the surface. 1270 - PRINT *,' !!!!!! SIGWGT WARNING : The plotting system', 1271 - - ' used for this module has no SURFACE facilities.' 0 1272-+ +SELF. 1273 - 90 CONTINUE 1274 - ENDIF 1275 - * plot the histogram if requested, delete after use. 1276 - IF(LHIST)THEN 1277 - CALL HISPLT(IHISRF,FUNCT5(1:NC5), 1278 - - 'Histogram of '//FUNCT5(1:NC5)// 1279 - - GROUP(1:NCGR),.TRUE.) 1280 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 1281 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 1282 - CALL GRNEXT 1283 - CALL GRALOG('Histogram of '//FUNCT5(1:NC5)// 1284 - - GROUP(1:NCGR)//':') 1285 - CALL TIMLOG('Plotting an histogram of '// 1286 - - FUNCT5(1:NC5)//GROUP(1:NCGR)//':') 1287 - CALL HISADM('DELETE',IHISRF,0,0.0,0.0,.FALSE.,IFAIL) 1288 - ENDIF 1289 - * print the number of arithmetic errors. 1290 - CALL ALGERR 1291 - 120 CONTINUE 1292 - * release the algebra storage. 1293 - CALL ALGCLR(IENTRY) 1294 - ENDIF 1295 - *** Next sense wire. 1296 - 40 CONTINUE 1297 - END 761 GARFIELD ================================================== P=SIGNAL D=SCONT1 1 ============================ 0 + +DECK,SCONT1. 1 - SUBROUTINE SCONT1(X0,Y0,FVAL,ILOC) 2 - *----------------------------------------------------------------------- 3 - * SCONT1 - Returns the function value to the contour routine 4 - * (Last changed on 4/11/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,PARAMETERS. 9 - REAL RES(1),X0,Y0,FVAL,XPOS,YPOS,ZPOS 10 - INTEGER MODRES(1),ILOC,NRES 11 - *** Compute the true space coordinates. 12 - XPOS=FPROJ(1,1)*X0+FPROJ(2,1)*Y0+FPROJ(3,1) 13 - YPOS=FPROJ(1,2)*X0+FPROJ(2,2)*Y0+FPROJ(3,2) 14 - ZPOS=FPROJ(1,3)*X0+FPROJ(2,3)*Y0+FPROJ(3,3) 15 - *** Set expected number of results. 16 - NRES=1 17 - *** Evaluate the function. 18 - CALL SCONT2(XPOS,YPOS,ZPOS,RES,MODRES,NRES,ILOC) 19 - *** Return the result. 20 - FVAL=RES(1) 21 - END 762 GARFIELD ================================================== P=SIGNAL D=SCONT2 1 ============================ 0 + +DECK,SCONT2. 1 - SUBROUTINE SCONT2(X0,Y0,Z0,RES,MODRES,NRES,ILOC) 2 - *----------------------------------------------------------------------- 3 - * SCONT2 - Performs formula evaluations for the signal field plots. 4 - * (Last changed on 14/ 6/99.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,CELLDATA. 9.- +SEQ,DRIFTLINE. 10.- +SEQ,PRINTPLOT. 11 - INTEGER NRES,MODRES(NRES),MODVAR(MXVAR),ILOC,ILOC1, 12 - - IENTRY,ITYPE,I,IFAIL,JSW 13 - REAL RES(NRES),VAR(MXVAR),QPLT,X0,Y0,Z0,VOLT,EX,EY,EZ 14 - DOUBLE PRECISION F0(3),QTMIN,QTMAX,QQTMIN,QQTMAX 15 - LOGICAL EVALW,EVALB,EVALV,EVALE,EVALI,EVALQ,EVALP,LMCDR 16 - COMMON /CN3DAT/ QTMIN,QTMAX,IENTRY,EVALW,EVALB,EVALV,EVALE,EVALI, 17 - - EVALQ,EVALP,QPLT,ITYPE,JSW,LMCDR 18 - *** Verify that we are in the drift area. 19 - IF(X0.LT.DXMIN.OR.X0.GT.DXMAX.OR. 20 - - Y0.LT.DYMIN.OR.Y0.GT.DYMAX.OR. 21 - - Z0.LT.DZMIN.OR.Z0.GT.DZMAX)THEN 22 - ILOC=-1 23 - RETURN 24 - ENDIF 25 - *** Store the coordinates. 26 - VAR(1)= X0 27 - VAR(2)= Y0 28 - VAR(23)=Z0 29 - *** Always calculate the E field for verification purposes. 30 - CALL EFIELD(VAR(1),VAR(2),VAR(23),VAR(3),VAR(4),VAR(5),VAR(6), 31 - - VOLT,0,ILOC) 32 - * Location code -5 (in a material) can be acceptable. 33 - IF(ILOC.EQ.-5.AND.LCNTAM)ILOC=0 34 - * For other non-zero locations return. 35 - IF(ILOC.NE.0)THEN 36 - DO 10 I=1,NRES 37 - RES(I)=0 38 - MODRES(I)=0 39 - 10 CONTINUE 40 - RETURN 41 - ENDIF 42 - *** Calculate the B field. 43 - IF(EVALB)CALL BFIELD(VAR(1),VAR(2),VAR(23), 44 - - VAR(7),VAR(8),VAR(9),VAR(10)) 45 - *** Compute the local drift velocity. 46 - IF(EVALV)THEN 1 762 P=SIGNAL D=SCONT2 2 PAGE1184 47 - CALL DLCVEL(DBLE(VAR(1)),DBLE(VAR(2)),DBLE(VAR(23)), 48 - - F0,QPLT,ITYPE,ILOC1) 49 - VAR(11)=REAL(F0(1)) 50 - VAR(12)=REAL(F0(2)) 51 - VAR(13)=REAL(F0(3)) 52 - VAR(14)=REAL(SQRT(F0(1)**2+F0(2)**2+F0(3)**2)) 53 - ENDIF 54 - *** Calculate the Ew field. 55 - IF(EVALW)THEN 56 - CALL SIGFLS(VAR(1),VAR(2),VAR(23),EX,EY,EZ,JSW) 57 - * Assign the results. 58 - VAR(17)=EX 59 - VAR(18)=EY 60 - VAR(19)=EZ 61 - VAR(20)=SQRT(EX**2+EY**2+EZ**2) 62 - ENDIF 63 - *** Electron drift line related quantities. 64 - IF(EVALE)THEN 65 - * Set electron parameters. 66 - QPLT=-1.0 67 - ITYPE=1 68 - * Compute the drift line. 69 - IF(LMCDR)THEN 70 - CALL DLCMC(VAR(1),VAR(2),VAR(23),QPLT,ITYPE) 71 - ELSE 72 - CALL DLCALC(VAR(1),VAR(2),VAR(23),QPLT,ITYPE) 73 - ENDIF 74 - * Time and status. 75 - VAR(15)=TU(NU) 76 - VAR(24)=ISTAT 77 - * Induced charge. 78 - IF(EVALQ)THEN 79 - IF(QTMIN.LT.0)THEN 80 - QQTMIN=TU(1) 81 - ELSE 82 - QQTMIN=QTMIN 83 - ENDIF 84 - IF(QTMAX.LT.0)THEN 85 - QQTMAX=TU(NU) 86 - ELSE 87 - QQTMAX=QTMAX 88 - ENDIF 89 - CALL SIGQIN(VAR(21),JSW,QQTMIN,QQTMAX) 90 - ENDIF 91 - ENDIF 92 - *** Ion drift line related quantities. 93 - IF(EVALI)THEN 94 - * Set ion parameters. 95 - QPLT=+1.0 96 - ITYPE=2 97 - * Compute the drift line. 98 - CALL DLCALC(VAR(1),VAR(2),VAR(23),QPLT,ITYPE) 99 - * Time and status. 100 - VAR(16)=TU(NU) 101 - VAR(25)=ISTAT 102 - * Induced charge. 103 - IF(EVALP)CALL SIGQIN(VAR(22),JSW,TU(1),TU(NU)) 104 - ENDIF 105 - *** Transform vectors and covectors to polar coordinates if needed. 106 - IF(POLAR)THEN 107 - CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) 108 - VAR(3)=VAR(3)/VAR(1) 109 - VAR(4)=VAR(4)/VAR(1) 110 - VAR(6)=SQRT(VAR(3)**2+VAR(4)**2+VAR(5)**2) 111 - VAR(17)=VAR(17)/VAR(1) 112 - VAR(18)=VAR(18)/VAR(1) 113 - VAR(20)=SQRT(VAR(17)**2+VAR(18)**2+VAR(19)**2) 114 - VAR(11)=VAR(11)*VAR(1) 115 - VAR(12)=VAR(12)*VAR(1) 116 - VAR(14)=SQRT(VAR(11)**2+VAR(12)**2+VAR(13)**2) 117 - ENDIF 118 - *** Assign modes. 119 - DO 100 I=1,25 120 - MODVAR(I)=2 121 - 100 CONTINUE 122 - *** Evaluate the function 123 - CALL ALGEXE(IENTRY,VAR,MODVAR,25,RES,MODRES,NRES,IFAIL) 124 - END 763 GARFIELD ================================================== P=SIGNAL D=SIGQIN 1 ============================ 0 + +DECK,SIGQIN. 1 - SUBROUTINE SIGQIN(QTOT,ISW,TMIN,TMAX) 2 - *----------------------------------------------------------------------- 3 - * SIGQIN - Integrates the induced charge over a drift line. 4 - * (Last changed on 18/11/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,DRIFTLINE. 9.- +SEQ,CELLDATA. 10 - DOUBLE PRECISION F1(3),F2(3),F3(3),AUX(1),DGMLT1, 11 - - DMEAN,XMID,YMID,ZMID,TABTIM,TABLAM,TMIN,TMAX,TIMIN,TIMAX 12 - REAL QTOT,DRES,EX1,EY1,EZ1,EX2,EY2,EZ2,EX3,EY3,EZ3 13 - INTEGER ILOC1,ILOC2,ILOC3,IU,IWIRE,NTAB,ISW,JSW,I 14 - PARAMETER(NTAB=10) 15 - EXTERNAL DGMLT1,FSCONT 16 - COMMON /SQIDAT/ TABTIM(NTAB),TABLAM(NTAB),IU,JSW 17 - *** Copy the sense wire number to the common. 18 - JSW=ISW 19 - *** Set the wire diameter to 0, if a wire was hit. 20 - IF(ISTAT.GE.1.AND.ISTAT.LE.NWIRE)THEN 21 - IWIRE=ISTAT 22 - ELSEIF(ISTAT.GT.MXWIRE.AND.ISTAT.LE.2*MXWIRE)THEN 23 - IWIRE=ISTAT-MXWIRE 24 - ELSE 1 763 P=SIGNAL D=SIGQIN 2 PAGE1185 25 - IWIRE=0 26 - ENDIF 27 - IF(IWIRE.GT.0)THEN 28 - DRES=D(IWIRE) 29 - D(IWIRE)=0 30 - ENDIF 31 - *** Initial value for the induced charge. 32 - QTOT=0 33 - CALL DLCVEL(XU(1),YU(1),ZU(1),F1,QPCHAR,IPTYPE,ILOC1) 34 - CALL SIGFLS(REAL(XU(1)),REAL(YU(1)),REAL(ZU(1)),EX1,EY1,EZ1,JSW) 35 - IF(ILOC1.NE.0)THEN 36 - PRINT *,' !!!!!! SIGQIN WARNING : Ran into non-free'// 37 - - ' zone at first step ; Q=0.' 38 - QTOT=0 39 - IF(IWIRE.GT.0)D(IWIRE)=DRES 40 - RETURN 41 - ENDIF 42 - *** Loop over the drift line. 43 - DO 10 IU=2,NU 44 - * Evaluate end-point. 45 - CALL DLCVEL(XU(IU),YU(IU),ZU(IU),F3,QPCHAR,IPTYPE,ILOC3) 46 - * Abandon if this fails. 47 - IF(ILOC3.NE.0)THEN 48 - PRINT *,' !!!!!! SIGQIN WARNING : Ran into non-free'// 49 - - ' zone at end of regular step ; Q=0.' 50 - QTOT=0 51 - IF(IWIRE.GT.0)D(IWIRE)=DRES 52 - RETURN 53 - ENDIF 54 - CALL SIGFLS(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), 55 - - EX3,EY3,EZ3,JSW) 56 - * Avoid integration outside the time limits. 57 - IF(TMIN.GT.TU(IU).OR.TMAX.LT.TU(IU-1))GOTO 30 58 - * Try a parabolic weighted mean of the average position. 59 - XMID=XU(IU-1)+(TU(IU)-TU(IU-1))*(3*F1(1)+F3(1))/8 60 - YMID=YU(IU-1)+(TU(IU)-TU(IU-1))*(3*F1(2)+F3(2))/8 61 - ZMID=ZU(IU-1)+(TU(IU)-TU(IU-1))*(3*F1(3)+F3(3))/8 62 - CALL DLCVEL(XMID,YMID,ZMID,F2,QPCHAR,IPTYPE,ILOC2) 63 - * If this fails, try a straight mean. 64 - IF(ILOC2.NE.0)THEN 65 - XMID=(XU(IU)+XU(IU-1))/2 66 - YMID=(YU(IU)+YU(IU-1))/2 67 - ZMID=(ZU(IU)+ZU(IU-1))/2 68 - CALL DLCVEL(XMID,YMID,ZMID,F2,QPCHAR,IPTYPE,ILOC2) 69 - * If this too fails, abandon. 70 - IF(ILOC2.NE.0)THEN 71 - PRINT *,' !!!!!! SIGQIN WARNING : Ran into non-free'// 72 - - ' zone in middle of regular step ; Q=0.' 73 - QTOT=0 74 - IF(IWIRE.GT.0)D(IWIRE)=DRES 75 - RETURN 76 - ENDIF 77 - ENDIF 78 - CALL SIGFLS(REAL(XMID),REAL(YMID),REAL(ZMID),EX2,EY2,EZ2,JSW) 79 - * Compare 1st and 2nd order. 80 - IF((TU(IU)-TMIN)*(TMIN-TU(IU-1)).LE.0.AND. 81 - - (TU(IU)-TMAX)*(TMAX-TU(IU-1)).LE.0.AND. 82 - - ABS((TU(IU)-TU(IU-1))*( 83 - - (EX1*F1(1)+EY1*F1(2)+EZ1*F1(3))- 84 - - 2*(EX2*F2(1)+EY2*F2(2)+EZ2*F2(3))+ 85 - - (EX3*F3(1)+EY3*F3(2)+EZ3*F3(3))))/3.LT.1D-6)THEN 86 - * If they agree, use Simpsons formula. 87 - QTOT=QTOT+QPCHAR*(TU(IU)-TU(IU-1))*( 88 - - (EX1*F1(1)+EY1*F1(2)+EZ1*F1(3))+ 89 - - 4*(EX2*F2(1)+EY2*F2(2)+EZ2*F2(3))+ 90 - - (EX3*F3(1)+EY3*F3(2)+EZ3*F3(3)))/6 91 - * Otherwise use 6-point Gaussian integration. 92 - ELSE 93 - * Prepare an interpolation table for the time-lambda relation. 94 - TABTIM(1)=0 95 - TABLAM(1)=0 96 - DMEAN=SQRT((XU(IU)-XU(IU-1))**2+(YU(IU)-YU(IU-1))**2+ 97 - - (ZU(IU)-ZU(IU-1))**2)/DBLE(NTAB-1) 98 - DO 20 I=2,NTAB 99 - CALL DLCVEL( 100 - - XU(IU-1)+(I-2.0D0)*(XU(IU)-XU(IU-1))/DBLE(NTAB-1), 101 - - YU(IU-1)+(I-2.0D0)*(YU(IU)-YU(IU-1))/DBLE(NTAB-1), 102 - - ZU(IU-1)+(I-2.0D0)*(ZU(IU)-ZU(IU-1))/DBLE(NTAB-1), 103 - - F1,QPCHAR,IPTYPE,ILOC1) 104 - CALL DLCVEL( 105 - - XU(IU-1)+(I-1.5D0)*(XU(IU)-XU(IU-1))/DBLE(NTAB-1), 106 - - YU(IU-1)+(I-1.5D0)*(YU(IU)-YU(IU-1))/DBLE(NTAB-1), 107 - - ZU(IU-1)+(I-1.5D0)*(ZU(IU)-ZU(IU-1))/DBLE(NTAB-1), 108 - - F2,QPCHAR,IPTYPE,ILOC2) 109 - CALL DLCVEL( 110 - - XU(IU-1)+(I-1.0D0)*(XU(IU)-XU(IU-1))/DBLE(NTAB-1), 111 - - YU(IU-1)+(I-1.0D0)*(YU(IU)-YU(IU-1))/DBLE(NTAB-1), 112 - - ZU(IU-1)+(I-1.0D0)*(ZU(IU)-ZU(IU-1))/DBLE(NTAB-1), 113 - - F3,QPCHAR,IPTYPE,ILOC3) 114 - IF(SQRT(F1(1)**2+F1(2)**2+F1(3)**2).LE.0.OR. 115 - - SQRT(F2(1)**2+F2(2)**2+F2(3)**2).LE.0.OR. 116 - - SQRT(F3(1)**2+F3(2)**2+F3(3)**2).LE.0.OR. 117 - - ILOC1.NE.0.OR.ILOC2.NE.0.OR.ILOC3.NE.0)THEN 118 - PRINT *,' !!!!!! SIGQIN WARNING : Ran into non'// 119 - - ' free area in a Gauss step ; Qe set to 0.' 120 - QTOT=0 121 - IF(IWIRE.GT.0)D(IWIRE)=DRES 122 - RETURN 123 - ENDIF 124 - TABTIM(I)=TABTIM(I-1)+DMEAN*( 125 - - 1/SQRT(F1(1)**2+F1(2)**2+F1(3)**2)+ 126 - - 4/SQRT(F2(1)**2+F2(2)**2+F2(3)**2)+ 127 - - 1/SQRT(F3(1)**2+F3(2)**2+F3(3)**2))/6 128 - TABLAM(I)=DBLE(I-1)/DBLE(NTAB-1) 129 - 20 CONTINUE 130 - * Set integration limits. 1 763 P=SIGNAL D=SIGQIN 3 PAGE1186 131 - TIMIN=MAX(TMIN-TU(IU-1),TABTIM(1)) 132 - TIMAX=MIN(TMAX-TU(IU-1),TABTIM(NTAB)) 133 - * Add the contribution. 134 - QTOT=QTOT+QPCHAR*DGMLT1(FSCONT,TIMIN,TIMAX,1,8,AUX) 135 - ENDIF 136 - * Shift the field for the end-point to the starting point. 137 - 30 CONTINUE 138 - EX1=EX3 139 - EY1=EY3 140 - EZ1=EZ3 141 - F1(1)=F3(1) 142 - F1(2)=F3(2) 143 - F1(3)=F3(3) 144 - 10 CONTINUE 145 - *** Restore the wire diameter. 146 - IF(IWIRE.GT.0)D(IWIRE)=DRES 147 - *** Invert sign of the induced charge. 148 - QTOT=-QTOT 149 - END 764 GARFIELD ================================================== P=SIGNAL D=FSCONT 1 ============================ 0 + +DECK,FSCONT. 1 - SUBROUTINE FSCONT(M,U1,F1,XTIM) 2 - *----------------------------------------------------------------------- 3 - * FSCONT - Integrates the induced charge over a drift line segment. 4 - * (Last changed on 4/11/98.) 5 - *----------------------------------------------------------------------- 6 - implicit none 7.- +SEQ,DIMENSIONS. 8.- +SEQ,DRIFTLINE. 9.- +SEQ,CELLDATA. 10 - REAL EX,EY,EZ 11 - INTEGER L,M,JSW,ILOC,IU,NTAB 12 - PARAMETER(NTAB=10) 13 - DOUBLE PRECISION U1(*),F1(*),XTIM(1),F0(3),DIVDF2,XPOS,YPOS,ZPOS, 14 - - TABTIM,TABLAM,XLAM 15 - COMMON /SQIDAT/ TABTIM(NTAB),TABLAM(NTAB),IU,JSW 16 - EXTERNAL DIVDF2 17 - *** Loop over the positions. 18 - DO 10 L=1,M 19 - * Copy the time coordinate. 20 - XTIM(1)=U1(L) 21 - * Compute space coordinate. 22 - XLAM=DIVDF2(TABLAM,TABTIM,NTAB,XTIM(1),2) 23 - * Position. 24 - XPOS=XU(IU-1)+XLAM*(XU(IU)-XU(IU-1)) 25 - YPOS=YU(IU-1)+XLAM*(YU(IU)-YU(IU-1)) 26 - ZPOS=ZU(IU-1)+XLAM*(ZU(IU)-ZU(IU-1)) 27 - ** Compute Ew. 28 - CALL SIGFLS(REAL(XPOS),REAL(YPOS),REAL(ZPOS),EX,EY,EZ,JSW) 29 - ** Compute drift velocity. 30 - CALL DLCVEL(XPOS,YPOS,ZPOS,F0,QPCHAR,IPTYPE,ILOC) 31 - ** Set the return value. 32 - F1(L)=F0(1)*EX+F0(2)*EY+F0(3)*EZ 33 - 10 CONTINUE 34 - END 765 GARFIELD ================================================== P=SIGNAL D=SIGWRT 1 ============================ 0 + +DECK,SIGWRT. 1 - SUBROUTINE SIGWRT 2 - *----------------------------------------------------------------------- 3 - * SIGWRT - A routine that writes the signals to a file 4 - * VARIABLES : VALID : Valid dataset available, if set to .TRUE. 5 - * FILE etc : Data on the file to be written. 6 - * (Last changed on 1/12/98.) 7 - *----------------------------------------------------------------------- 8 - implicit none 9.- +SEQ,DIMENSIONS. 10.- +SEQ,CELLDATA. 11.- +SEQ,SIGNALDATA. 12.- +SEQ,PRINTPLOT. 13 - CHARACTER*(MXCHAR) STRING 14 - CHARACTER*(MXNAME) FILE 15 - CHARACTER*80 FCNWRC,UNIT 16 - CHARACTER*29 REMARK 17 - CHARACTER*10 VARLIS(MXVAR) 18 - CHARACTER*8 TIME,DATE,MEMBER,FORMAT 19 - LOGICAL FLAG(MXWORD+3),VALID,IFWRT(MXLIST),USE(MXVAR) 20 - C LOGICAL EXMEMB 21 - INTEGER INPCMP,IENTRY,NCWRC,I,NWORD,INEXT,NCFILE,NCMEMB,NCREM, 22 - - ISW,IOS,NWRITE,J,MODVAR(MXVAR),IFAIL,MODRES(1),NRES,NOUT, 23 - - NCUNIT 24 - REAL RES(1),VAR(MXVAR),SCALET,SCALEI 25 - EXTERNAL INPCMP 0 26-+ +SELF,IF=SAVE. 27 - SAVE VALID,FILE,NCFILE,MEMBER,NCMEMB,REMARK,NCREM,FORMAT, 28 - - IENTRY,NCWRC,SCALET,SCALEI 0 29-+ +SELF. 30 - *** Initialise the various parameters. 31 - DATA VALID /.FALSE./ 32 - DATA FILE /' '/ 33 - DATA MEMBER /'< none >'/ 34 - DATA REMARK /'none'/ 35 - DATA FORMAT /'SPICE '/ 36 - DATA NCFILE,NCMEMB,NCREM /1,8,4/ 37 - DATA IENTRY /0/ 38 - DATA SCALET /1.0/, SCALEI /1.0/ 39 - FCNWRC=' ' 40 - NCWRC=0 41 - *** Identify the routine. 42 - IF(LIDENT)PRINT *,' /// ROUTINE SIGWRT ///' 43 - *** Get the number of words, return if there is only one. 1 765 P=SIGNAL D=SIGWRT 2 PAGE1187 44 - CALL INPNUM(NWORD) 45 - IF(NWORD.LE.1)THEN 46 - PRINT *,' !!!!!! SIGWRT WARNING : WRITE takes at least 1'// 47 - - ' argument (a dataset name); data will not be written.' 48 - RETURN 49 - ENDIF 50 - ** Mark keywords. 51 - DO 10 I=1,NWORD+3 52 - FLAG(I)=.TRUE. 53 - IF(I.GT.NWORD)GOTO 10 54 - IF(INPCMP(I,'D#ATASET')+INPCMP(I,'R#EMARK')+ 55 - - INPCMP(I,'WR#ITE-IF')+INPCMP(I,'F#ORMAT')+ 56 - - INPCMP(I,'U#NITS').EQ.0)FLAG(I)=.FALSE. 57 - 10 CONTINUE 58 - ** Loop over the words. 59 - INEXT=2 60 - DO 20 I=2,NWORD 61 - IF(I.LT.INEXT)GOTO 20 62 - * Look for a DATASET. 63 - IF(INPCMP(I,'D#ATASET').NE.0)THEN 64 - IF(FLAG(I+1))THEN 65 - CALL INPMSG(I,'The dataset name is missing. ') 66 - INEXT=I+1 67 - ELSE 68 - CALL INPSTR(I+1,I+1,STRING,NCFILE) 69 - FILE=STRING 70 - INEXT=I+2 71 - IF(.NOT.FLAG(I+2))THEN 72 - CALL INPSTR(I+2,I+2,STRING,NCMEMB) 73 - MEMBER=STRING 74 - INEXT=I+3 75 - ENDIF 76 - VALID=.TRUE. 77 - ENDIF 78 - * FORMAT specification, either SPICE or SCEPTRE. 79 - ELSEIF(INPCMP(I,'F#ORMAT').NE.0)THEN 80 - IF(FLAG(I+1))THEN 81 - CALL INPMSG(I,'No format specification found.') 82 - INEXT=I+1 83 - ELSE 84 - IF(INPCMP(I+1,'SC#EPTRE').NE.0)THEN 85 - FORMAT='SCEPTRE ' 86 - ELSEIF(INPCMP(I+1,'SP#ICE').NE.0)THEN 87 - FORMAT='SPICE ' 88 - ELSE 89 - CALL INPMSG(I+1,'Not a known dataset format. ') 90 - ENDIF 91 - INEXT=I+2 92 - ENDIF 93 - * Remark. 94 - ELSEIF(INPCMP(I,'REM#ARK').NE.0)THEN 95 - IF(FLAG(I+1))THEN 96 - CALL INPMSG(I,'The remark is missing. ') 97 - INEXT=I+1 98 - ELSE 99 - CALL INPSTR(I+1,I+1,STRING,NCREM) 100 - REMARK=STRING 101 - INEXT=I+2 102 - ENDIF 103 - * Look for a write condition. 104 - ELSEIF(INPCMP(I,'WR#ITE-IF').NE.0)THEN 105 - IF(I+1.GT.NWORD)THEN 106 - CALL INPMSG(I,'The function is not specified.') 107 - ELSE 108 - CALL INPSTR(I+1,I+1,FCNWRC,NCWRC) 109 - IF(NCWRC.GT.0.AND.IENTRY.GT.0)THEN 110 - CALL ALGCLR(IENTRY) 111 - IENTRY=0 112 - ENDIF 113 - ENDIF 114 - INEXT=I+2 115 - * Units. 116 - ELSEIF(INPCMP(I,'U#NITS').NE.0)THEN 117 - DO 30 J=I+1,NWORD 118 - IF(FLAG(J))THEN 119 - INEXT=J 120 - GOTO 20 121 - ELSEIF(INPCMP(J,'SEC#ONDS').NE.0)THEN 122 - SCALET=1E-6 123 - ELSEIF(INPCMP(J,'MIL#LI-SEC#ONDS')+ 124 - - INPCMP(J,'MILLISEC#ONDS')+ 125 - - INPCMP(J,'MSEC#ONDS').NE.0)THEN 126 - SCALET=1E-3 127 - ELSEIF(INPCMP(J,'MIC#RO-SEC#ONDS')+ 128 - - INPCMP(J,'MICROSEC#ONDS')+ 129 - - INPCMP(J,'MUSEC#ONDS').NE.0)THEN 130 - SCALET=1 131 - ELSEIF(INPCMP(J,'N#ANO-SEC#ONDS')+ 132 - - INPCMP(J,'NANOSEC#ONDS')+ 133 - - INPCMP(J,'NSEC#ONDS').NE.0)THEN 134 - SCALET=1E+3 135 - ELSEIF(INPCMP(J,'P#ICO-SEC#ONDS')+ 136 - - INPCMP(J,'PICOSEC#ONDS')+ 137 - - INPCMP(J,'PSEC#ONDS').NE.0)THEN 138 - SCALET=1E+6 139 - ELSEIF(INPCMP(J,'F#EMTO-SEC#ONDS')+ 140 - - INPCMP(J,'F#EMTOSEC#ONDS')+ 141 - - INPCMP(J,'FSEC#ONDS').NE.0)THEN 142 - SCALET=1E+9 143 - ELSEIF(INPCMP(J,'A#TTO-SEC#ONDS')+ 144 - - INPCMP(J,'ATTOSEC#ONDS')+ 145 - - INPCMP(J,'ASEC#ONDS').NE.0)THEN 146 - SCALET=1E+12 147 - ELSEIF(INPCMP(J,'KI#LO-A#MPERES')+ 148 - - INPCMP(J,'KILOA#MPERES')+ 149 - - INPCMP(J,'KA#MPERES').NE.0)THEN 1 765 P=SIGNAL D=SIGWRT 3 PAGE1188 150 - SCALEI=1E-9 151 - ELSEIF(INPCMP(J,'A#MPERES').NE.0)THEN 152 - SCALEI=1E-6 153 - ELSEIF(INPCMP(J,'MIL#LI-A#MPERES')+ 154 - - INPCMP(J,'MILLIA#MPERES')+ 155 - - INPCMP(J,'MA#MPERES').NE.0)THEN 156 - SCALEI=1E-3 157 - ELSEIF(INPCMP(J,'MIC#RO-A#MPERES')+ 158 - - INPCMP(J,'MICROA#MPERES')+ 159 - - INPCMP(J,'MUA#MPERES').NE.0)THEN 160 - SCALEI=1 161 - ELSEIF(INPCMP(J,'N#ANO-A#MPERES')+ 162 - - INPCMP(J,'NANOA#MPERES')+ 163 - - INPCMP(J,'NA#MPERES').NE.0)THEN 164 - SCALEI=1E+3 165 - ELSEIF(INPCMP(J,'P#ICO-A#MPERES')+ 166 - - INPCMP(J,'PICOA#MPERES')+ 167 - - INPCMP(J,'PA#MPERES').NE.0)THEN 168 - SCALEI=1E+6 169 - ELSEIF(INPCMP(J,'F#EMTO-A#MPERES')+ 170 - - INPCMP(J,'F#EMTOA#MPERES')+ 171 - - INPCMP(J,'FA#MPERES').NE.0)THEN 172 - SCALEI=1E+9 173 - ELSEIF(INPCMP(J,'A#TTO-A#MPERES')+ 174 - - INPCMP(J,'ATTOA#MPERES')+ 175 - - INPCMP(J,'AA#MPERES').NE.0)THEN 176 - SCALEI=1E+12 177 - ELSE 178 - CALL INPMSG(J,'Not a known unit.') 179 - ENDIF 180 - 30 CONTINUE 181 - INEXT=NWORD+1 182 - * Invalid keyword. 183 - ELSE 184 - CALL INPMSG(I,'Invalid as a keyword. ') 185 - ENDIF 186 - 20 CONTINUE 187 - ** Print error messages. 188 - CALL INPERR 189 - ** Check the dataset name length, if such a name will be needed. 190 - IF(VALID)THEN 191 - IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! SIGWRT WARNING : File', 192 - - ' name truncated to MXNAME (=',MXNAME,') characters.' 193 - IF(NCMEMB.GT.8)PRINT *,' !!!!!! SIGWRT WARNING : Member', 194 - - ' name shortened to ',MEMBER,', first 8 characters.' 195 - IF(NCREM.GT.29)PRINT *,' !!!!!! SIGWRT WARNING : Remark', 196 - - ' shortened to ',REMARK,', first 29 characters.' 197 - NCFILE=MIN(NCFILE,MXNAME) 198 - NCMEMB=MIN(NCMEMB,8) 199 - NCREM=MIN(NCREM,29) 200 - ELSE 201 - PRINT *,' !!!!!! SIGWRT WARNING : No dataset name found;'// 202 - - ' signals not written.' 203 - RETURN 204 - ENDIF 205 - * Check whether the member already exists. 206 - C CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'SIGNAL',EXMEMB) 207 - C IF(JEXMEM.EQ.2.AND.EXMEMB)THEN 208 - C PRINT *,' ------ SIGWRT MESSAGE : A copy of the member'// 209 - C - ' exists; new member will be appended.' 210 - C ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN 211 - C PRINT *,' !!!!!! SIGWRT WARNING : A copy of the member'// 212 - C - ' exists already; member will not be written.' 213 - C RETURN 214 - C ENDIF 215 - * Print some debugging output if requested. 216 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGWRT DEBUG : File= '',A, 217 - - '', member='',A/26X,''remark='',A,'', format='',A)') 218 - - FILE(1:NCFILE),MEMBER(1:NCMEMB),REMARK(1:NCREM),FORMAT 219 - IF(LDEBUG)WRITE(LUNOUT,'(26X,''Write condition: '',A)') 220 - - FCNWRC(1:MAX(1,NCWRC)) 221 - *** Translate the write condition, if there is no entry point yet. 222 - IF(IENTRY.LE.0.AND.NCWRC.GT.0)THEN 223 - VARLIS(1)='TIME ' 224 - VARLIS(2)='SIGNAL ' 225 - VARLIS(3)='SAMPLE ' 226 - CALL ALGPRE(FCNWRC(1:NCWRC),NCWRC,VARLIS,3, 227 - - NRES,USE,IENTRY,IFAIL) 228 - * Verify that the translation worked correctly. 229 - IF(IFAIL.NE.0)THEN 230 - PRINT *,' !!!!!! SIGWRT WARNING : Write condition'// 231 - - ' could not be translated ; set to True.' 232 - CALL ALGCLR(IENTRY) 233 - IENTRY=0 234 - NCWRC=0 235 - RETURN 236 - * Make sure that there is only one result coming back. 237 - ELSEIF(NRES.NE.1)THEN 238 - PRINT *,' !!!!!! SIGWRT WARNING : The write'// 239 - - ' condition does not return 1 result ;'// 240 - - ' set to True.' 241 - CALL ALGCLR(IENTRY) 242 - IENTRY=0 243 - NCWRC=0 244 - RETURN 245 - ENDIF 246 - ENDIF 247 - *** Format the description of the units. 248 - UNIT='time in ' 249 - NCUNIT=8 250 - IF(NINT(LOG10(SCALET)).EQ.12)THEN 251 - UNIT(NCUNIT+1:NCUNIT+11)='atto second' 252 - NCUNIT=NCUNIT+11 253 - ELSEIF(NINT(LOG10(SCALET)).EQ.9)THEN 254 - UNIT(NCUNIT+1:NCUNIT+12)='femto second' 255 - NCUNIT=NCUNIT+12 1 765 P=SIGNAL D=SIGWRT 4 PAGE1189 256 - ELSEIF(NINT(LOG10(SCALET)).EQ.6)THEN 257 - UNIT(NCUNIT+1:NCUNIT+11)='pico second' 258 - NCUNIT=NCUNIT+11 259 - ELSEIF(NINT(LOG10(SCALET)).EQ.3)THEN 260 - UNIT(NCUNIT+1:NCUNIT+11)='nano second' 261 - NCUNIT=NCUNIT+11 262 - ELSEIF(NINT(LOG10(SCALET)).EQ.0)THEN 263 - UNIT(NCUNIT+1:NCUNIT+12)='micro second' 264 - NCUNIT=NCUNIT+12 265 - ELSEIF(NINT(LOG10(SCALET)).EQ.-3)THEN 266 - UNIT(NCUNIT+1:NCUNIT+12)='milli second' 267 - NCUNIT=NCUNIT+12 268 - ELSEIF(NINT(LOG10(SCALET)).EQ.-6)THEN 269 - UNIT(NCUNIT+1:NCUNIT+6)='second' 270 - NCUNIT=NCUNIT+6 271 - ELSE 272 - UNIT(NCUNIT+1:NCUNIT+16)=' second' 273 - NCUNIT=NCUNIT+16 274 - ENDIF 275 - UNIT(NCUNIT+1:NCUNIT+13)=', current in ' 276 - NCUNIT=NCUNIT+13 277 - IF(NINT(LOG10(SCALEI)).EQ.12)THEN 278 - UNIT(NCUNIT+1:NCUNIT+11)='atto Ampere' 279 - NCUNIT=NCUNIT+11 280 - ELSEIF(NINT(LOG10(SCALEI)).EQ.9)THEN 281 - UNIT(NCUNIT+1:NCUNIT+12)='femto Ampere' 282 - NCUNIT=NCUNIT+12 283 - ELSEIF(NINT(LOG10(SCALEI)).EQ.6)THEN 284 - UNIT(NCUNIT+1:NCUNIT+11)='pico Ampere' 285 - NCUNIT=NCUNIT+11 286 - ELSEIF(NINT(LOG10(SCALEI)).EQ.3)THEN 287 - UNIT(NCUNIT+1:NCUNIT+11)='nano Ampere' 288 - NCUNIT=NCUNIT+11 289 - ELSEIF(NINT(LOG10(SCALEI)).EQ.0)THEN 290 - UNIT(NCUNIT+1:NCUNIT+12)='micro Ampere' 291 - NCUNIT=NCUNIT+12 292 - ELSEIF(NINT(LOG10(SCALEI)).EQ.-3)THEN 293 - UNIT(NCUNIT+1:NCUNIT+12)='milli Ampere' 294 - NCUNIT=NCUNIT+12 295 - ELSEIF(NINT(LOG10(SCALEI)).EQ.-6)THEN 296 - UNIT(NCUNIT+1:NCUNIT+6)='Ampere' 297 - NCUNIT=NCUNIT+6 298 - ELSEIF(NINT(LOG10(SCALEI)).EQ.-9)THEN 299 - UNIT(NCUNIT+1:NCUNIT+11)='kilo Ampere' 300 - NCUNIT=NCUNIT+11 301 - ELSE 302 - UNIT(NCUNIT+1:NCUNIT+16)=' Ampere' 303 - NCUNIT=NCUNIT+16 304 - ENDIF 305 - *** Write the information to the dataset, start opening it. 306 - CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) 307 - IF(IFAIL.NE.0)THEN 308 - PRINT *,' !!!!!! SIGWRT WARNING : Opening ',FILE(1:NCFILE), 309 - - ' failed ; no signal data written.' 310 - RETURN 311 - ENDIF 312 - CALL DSNLOG(FILE,'Signals ','Sequential','Write ') 313 - *** Loop over all sense wires. 314 - DO 240 ISW=1,NSW 315 - * Now write a heading record to the file, 316 - CALL DATTIM(DATE,TIME) 317 - WRITE(STRING,'(''% Created '',A8,'' At '',A8, 318 - - '' < none > SIGNAL "Direct signal, group '',I3, 319 - - '' "'')') DATE,TIME,ISW 320 - IF(REMARK.NE.'none')STRING(51:79)=REMARK 321 - IF(MEMBER.NE.'< none >')STRING(32:39)=MEMBER 322 - WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING 323 - * Inform the user about the conductors in this group. 324 - CALL CELPRC(12,ISW) 325 - * Evaluate the function. 326 - NWRITE=0 327 - IF(IENTRY.NE.0)THEN 328 - DO 205 J=1,NTIME 329 - VAR(1)=TIMSIG(J) 330 - MODVAR(1)=2 331 - VAR(2)=SIGNAL(J,ISW,1) 332 - MODVAR(2)=2 333 - VAR(3)=REAL(J) 334 - MODVAR(3)=2 335 - CALL ALGEXE(IENTRY,VAR,MODVAR,3,RES,MODRES,1,IFAIL) 336 - IF(IFAIL.EQ.0.AND.MODRES(1).EQ.3)THEN 337 - IF(ABS(RES(1)).LT.1E-3)THEN 338 - IFWRT(J)=.FALSE. 339 - ELSE 340 - IFWRT(J)=.TRUE. 341 - NWRITE=NWRITE+1 342 - ENDIF 343 - ELSE 344 - PRINT *,' !!!!!! SIGWRT WARNING : WRITE-IF does not'// 345 - - ' evaluate to a valid logical; set to True.' 346 - IFWRT(J)=.TRUE. 347 - NWRITE=NWRITE+1 348 - ENDIF 349 - 205 CONTINUE 350 - ELSE 351 - DO 206 J=1,NTIME 352 - IFWRT(J)=.TRUE. 353 - NWRITE=NWRITE+1 354 - 206 CONTINUE 355 - ENDIF 356 - * Check there is something to be written. 357 - IF(NWRITE.LE.0)THEN 358 - WRITE(12,'('' No signal data selected by WRITE-IF'')') 359 - ELSE 360 - WRITE(12,'('' Number of signal records: '',I5)') NWRITE 361 - ENDIF 1 765 P=SIGNAL D=SIGWRT 5 PAGE1190 362 - * Write the name of the units. 363 - WRITE(12,'('' Units used: '',A,''.'')') UNIT(1:NCUNIT) 364 - * Write the data at the end of the file. 365 - NOUT=0 366 - DO 210 J=1,NTIME 367 - IF(.NOT.IFWRT(J))GOTO 210 368 - NOUT=NOUT+1 369 - IF(FORMAT.EQ.'SPICE ')THEN 370 - IF(NOUT.EQ.NWRITE.AND.NOUT.EQ.1)THEN 371 - WRITE(12,'('' .STIMULUS signal PWL''/ 372 - - '' + TIME_SCALE_FACTOR = '',E10.3/ 373 - - '' + VALUE_SCALE_FACTOR = '',E10.3/ 374 - - '' + ( '',E15.8,2X,E15.8,'' )'')', 375 - - IOSTAT=IOS,ERR=2010) 1.0E-6*SCALET,1.0E-6*SCALEI, 376 - - TIMSIG(J)*SCALET,SIGNAL(J,ISW,1)*SCALEI 377 - ELSEIF(NOUT.EQ.1)THEN 378 - WRITE(12,'('' .STIMULUS signal PWL''/ 379 - - '' + TIME_SCALE_FACTOR = '',E10.3/ 380 - - '' + VALUE_SCALE_FACTOR = '',E10.3/ 381 - - '' + ( '',E15.8,2X,E15.8)',IOSTAT=IOS, 382 - - ERR=2010) 1.0E-6*SCALET,1.0E-6*SCALEI, 383 - - TIMSIG(J)*SCALET,SIGNAL(J,ISW,1)*SCALEI 384 - ELSEIF(NOUT.GT.1.AND.NOUT.LT.NWRITE)THEN 385 - WRITE(12,'('' +'',4X,E15.8,2X,E15.8)',IOSTAT=IOS, 386 - - ERR=2010) 387 - - TIMSIG(J)*SCALET,SIGNAL(J,ISW,1)*SCALEI 388 - ELSEIF(NOUT.EQ.NWRITE)THEN 389 - WRITE(12,'('' +'',4X,E15.8,2X,E15.8,'' )'')', 390 - - IOSTAT=IOS,ERR=2010) 391 - - TIMSIG(J)*SCALET,SIGNAL(J,ISW,1)*SCALEI 392 - ENDIF 393 - ELSEIF(FORMAT.EQ.'SCEPTRE ')THEN 394 - WRITE(12,'(2X,E15.8,'' , '',E15.8)',IOSTAT=IOS,ERR=2010) 395 - - TIMSIG(J)*SCALET,SIGNAL(J,ISW,1)*SCALEI 396 - ELSE 397 - PRINT *,' ###### SIGWRT ERROR : Signal dataset'// 398 - - ' format not known ('//FORMAT//'); respecify.' 399 - RETURN 400 - ENDIF 401 - 210 CONTINUE 402 - ** Same procedure for the cross induced signals. 403 - IF(LCROSS)THEN 404 - WRITE(STRING,'(''% Created '',A8,'' At '',A8, 405 - - '' < none > SIGNAL "Cross-talk, group '',I3, 406 - - '' "'')') DATE,TIME,ISW 407 - IF(REMARK.NE.'none')STRING(51:79)=REMARK 408 - IF(MEMBER.NE.'< none >')STRING(32:39)=MEMBER 409 - WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING 410 - * Inform the user about the wires in this group. 411 - CALL CELPRC(12,ISW) 412 - * Evaluate the function. 413 - NWRITE=0 414 - IF(IENTRY.NE.0)THEN 415 - DO 270 J=1,NTIME 416 - VAR(1)=TIMSIG(J) 417 - MODVAR(1)=2 418 - VAR(2)=SIGNAL(J,ISW,2) 419 - MODVAR(2)=2 420 - VAR(3)=REAL(J) 421 - MODVAR(3)=2 422 - CALL ALGEXE(IENTRY,VAR,MODVAR,3,RES,MODRES,1,IFAIL) 423 - IF(IFAIL.EQ.0.AND.MODRES(1).EQ.3)THEN 424 - IF(ABS(RES(1)).LT.1E-3)THEN 425 - IFWRT(J)=.FALSE. 426 - ELSE 427 - IFWRT(J)=.TRUE. 428 - NWRITE=NWRITE+1 429 - ENDIF 430 - ELSE 431 - PRINT *,' !!!!!! SIGWRT WARNING : WRITE-IF does'// 432 - - ' not evaluate to a valid logical;'// 433 - - ' set to True.' 434 - IFWRT(J)=.TRUE. 435 - NWRITE=NWRITE+1 436 - ENDIF 437 - 270 CONTINUE 438 - ELSE 439 - DO 280 J=1,NTIME 440 - IFWRT(J)=.TRUE. 441 - NWRITE=NWRITE+1 442 - 280 CONTINUE 443 - ENDIF 444 - * Check there is something to be written. 445 - IF(NWRITE.LE.0)THEN 446 - WRITE(12,'('' No signal data selected by WRITE-IF'')') 447 - ELSE 448 - WRITE(12,'('' Number of signal records: '',I5)') NWRITE 449 - ENDIF 450 - * Write the name of the units. 451 - WRITE(12,'('' Units used: '',A,''.'')') UNIT(1:NCUNIT) 452 - * Write the data at the end of the file. 453 - NOUT=0 454 - DO 220 J=1,NTIME 455 - IF(.NOT.IFWRT(J))GOTO 220 456 - NOUT=NOUT+1 457 - IF(FORMAT.EQ.'SPICE ')THEN 458 - IF(NOUT.EQ.NWRITE.AND.NOUT.EQ.1)THEN 459 - WRITE(12,'('' .STIMULUS signal PWL''/ 460 - - '' + TIME_SCALE_FACTOR = '',E10.3/ 461 - - '' + VALUE_SCALE_FACTOR = '',E10.3/ 462 - - '' + ( '',E15.8,2X,E15.8,'' )'')', 463 - - IOSTAT=IOS,ERR=2010) 464 - - 1.0E-6*SCALET,1.0E-6*SCALEI, 465 - - TIMSIG(J)*SCALET,SIGNAL(J,ISW,2)*SCALEI 466 - ELSEIF(NOUT.EQ.1)THEN 467 - WRITE(12,'('' .STIMULUS signal PWL''/ 1 765 P=SIGNAL D=SIGWRT 6 PAGE1191 468 - - '' + TIME_SCALE_FACTOR = '',E10.3/ 469 - - '' + VALUE_SCALE_FACTOR = '',E10.3/ 470 - - '' + ( '',E15.8,2X,E15.8)',IOSTAT=IOS, 471 - - ERR=2010) 1.0E-6*SCALET,1.0E-6*SCALEI, 472 - - TIMSIG(J)*SCALET,SIGNAL(J,ISW,2)*SCALEI 473 - ELSEIF(NOUT.GT.1.AND.NOUT.LT.NWRITE)THEN 474 - WRITE(12,'('' +'',4X,E15.8,2X,E15.8)',IOSTAT=IOS, 475 - - ERR=2010) 476 - - TIMSIG(J)*SCALET,SIGNAL(J,ISW,2)*SCALEI 477 - ELSEIF(NOUT.EQ.NWRITE)THEN 478 - WRITE(12,'('' +'',4X,E15.8,2X,E15.8,'' )'')', 479 - - IOSTAT=IOS,ERR=2010) 480 - - TIMSIG(J)*SCALET,SIGNAL(J,ISW,2)*SCALEI 481 - ENDIF 482 - ELSEIF(FORMAT.EQ.'SCEPTRE ')THEN 483 - WRITE(12,'(2X,E15.8,'' , '',E15.8)', 484 - - IOSTAT=IOS,ERR=2010) 485 - - TIMSIG(J)*SCALET,SIGNAL(J,ISW,2)*SCALEI 486 - ELSE 487 - PRINT *,' ###### SIGWRT ERROR : Signal dataset'// 488 - - ' format not known ('//FORMAT//'); respecify.' 489 - RETURN 490 - ENDIF 491 - 220 CONTINUE 492 - ENDIF 493 - 240 CONTINUE 494 - *** Normal end of the routine, return after closing the file. 495 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 496 - RETURN 497 - *** Handle error conditions. 498 - 2010 CONTINUE 499 - PRINT *,' ###### SIGWRT ERROR : Error while writing'// 500 - - ' to the file ',FILE(1:NCFILE),' on unit 12.' 501 - CALL INPIOS(IOS) 502 - CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) 503 - RETURN 504 - 2030 CONTINUE 505 - PRINT *,' ###### SIGWRT ERROR : '//FILE(1:NCFILE)// 506 - - ' could not be closed properly ; results not predictable.' 507 - CALL INPIOS(IOS) 508 - END 766 GARFIELD ================================================== P=SIGNAL D=SIGCHK 1 ============================ 0 + +DECK,SIGCHK. 1 - SUBROUTINE SIGCHK 2 - *----------------------------------------------------------------------- 3 - * SIGCHK - Performs some simple checks on the performance of the 4 - * signal routines. 5 - * VARIABLES : LAVACH : if .TRUE.: check avalanche calculation. 6 - * (Last changed on 21/ 5/96.) 7 - *----------------------------------------------------------------------- 8.- +SEQ,DIMENSIONS. 9.- +SEQ,SIGNALDATA. 10.- +SEQ,CELLDATA. 11.- +SEQ,GASDATA. 12.- +SEQ,DRIFTLINE. 13.- +SEQ,PRINTPLOT. 14.- +SEQ,PARAMETERS. 15 - LOGICAL LAVACH,LDIFCH,LCLSCH,LKEEP,USE(MXVAR),EXIST,RSET 16 - INTEGER NRNDM,NCHA,MODVAR(MXVAR),MODRES(1) 17 - REAL XPL(MXLIST),YPL(MXLIST),AVER,SIGMA,SDIFF,XSTART,YSTART 18 - DOUBLE PRECISION XRAN 19 - CHARACTER*20 AUX,AUX2 20 - CHARACTER*10 VARCLS(MXVAR) 0 21-+ +SELF,IF=SAVE. 22 - SAVE LAVACH,LDIFCH,LCLSCH,NRNDM,XSTART,YSTART,FMIN,FMAX,NCHA, 23 - - LKEEP 0 24-+ +SELF. 25 - DATA VARCLS(1)/'N '/ 26 - DATA LAVACH,LDIFCH,LCLSCH,LKEEP /.FALSE.,.FALSE.,.FALSE.,.FALSE./ 27 - DATA NRNDM /100000/ 28 - DATA XSTART,YSTART /0.0,0.0/ 29 - DATA FMIN,FMAX /1.0,1.0E10/ 30 - DATA NCHA /100/ 31 - *** Identify the routine if requested. 32 - IF(LIDENT)PRINT *,' /// ROUTINE SIGCHK ///' 33 - *** Decode the argument string. 34 - CALL INPNUM(NWORD) 35 - INEXT=2 36 - DO 10 I=2,NWORD 37 - IF(I.LT.INEXT)GOTO 10 38 - * The AVALANCHE options. 39 - IF(INPCMP(I,'AVA#LANCHE').NE.0)THEN 40 - IF(AVATYP.EQ.'NOT SET')THEN 41 - CALL INPMSG(I,'No avalanche type has been set') 42 - ELSE 43 - LAVACH=.TRUE. 44 - ENDIF 45 - ELSEIF(INPCMP(I,'NOAVA#LANCHE').NE.0)THEN 46 - LAVACH=.FALSE. 47 - * The BINS keyword. 48 - ELSEIF(INPCMP(I,'BIN#S').NE.0)THEN 49 - IF(I+1.GT.NWORD)THEN 50 - CALL INPMSG(I,'This keyword has one argument.') 51 - ELSE 52 - CALL INPCHK(I+1,1,IFAIL) 53 - CALL INPRDI(I+1,NCHAR,MXCHA) 54 - IF(NCHAR.LE.1.OR.NCHAR.GT.MXCHA)THEN 55 - CALL INPMSG(I+1,'Inacceptable number of bins. ') 56 - ELSE 57 - NCHA=NCHAR 58 - ENDIF 59 - ENDIF 1 766 P=SIGNAL D=SIGCHK 2 PAGE1192 60 - INEXT=I+2 61 - * The CLUSTER options. 62 - ELSEIF(INPCMP(I,'CL#USTER').NE.0)THEN 63 - TRKLEN=SQRT((XT0-XT1)**2+(YT0-YT1)**2) 64 - IF(.NOT.GASOK(5))THEN 65 - CALL INPMSG(I,'No cluster data available. ') 66 - ELSEIF(TRKLEN*CMEAN.LT.0.1)THEN 67 - CALL INPMSG(I,'The track is too short. ') 68 - ELSE 69 - LCLSCH=.TRUE. 70 - ENDIF 71 - ELSEIF(INPCMP(I,'NOCL#USTER').NE.0)THEN 72 - LCLSCH=.FALSE. 73 - * The diffusion options. 74 - ELSEIF(INPCMP(I,'DIFF#USION').NE.0)THEN 75 - IF(.NOT.GASOK(3))THEN 76 - CALL INPMSG(I,'No diffusion data available. ') 77 - ELSE 78 - LDIFCH=.TRUE. 79 - ENDIF 80 - ELSEIF(INPCMP(I,'NODIFF#USION').NE.0)THEN 81 - LDIFCH=.FALSE. 82 - * Starting point of the drift line (if needed). 83 - ELSEIF(INPCMP(I,'FR#OM').NE.0)THEN 84 - IF(I+2.GT.NWORD)THEN 85 - CALL INPMSG(I,'This keyword has 2 arguments. ') 86 - ELSE 87 - CALL INPCHK(I+1,2,IFAIL1) 88 - CALL INPCHK(I+2,2,IFAIL2) 89 - IF(POLAR)CALL CFMRTP(XSTART,YSTART,XSTART,YSTART,1) 90 - CALL INPRDR(I+1,XSTART,XSTART) 91 - CALL INPRDR(I+2,YSTART,XSTART) 92 - IF(POLAR)THEN 93 - CALL CFMPTR(XSTART,YSTART,XSTART,YSTART,1,IFAIL) 94 - IF(IFAIL.NE.0)THEN 95 - CALL INPMSG(I+1, 96 - - 'Illegal polar coordinate. ') 97 - XSTART=0.0 98 - YSTART=0.0 99 - ENDIF 100 - ENDIF 101 - ENDIF 102 - INEXT=I+3 103 - * Histogram keeping option. 104 - ELSEIF(INPCMP(I,'KEEP-#HISTOGRAMS').NE.0)THEN 105 - LKEEP=.TRUE. 106 - ELSEIF(INPCMP(I,'NOKEEP-#HISTOGRAMS').NE.0)THEN 107 - LKEEP=.FALSE. 108 - * The RANGE for the avalanche multiplication histogram. 109 - ELSEIF(INPCMP(I,'R#ANGE').NE.0)THEN 110 - IF(I+2.GT.NWORD)THEN 111 - CALL INPMSG(I,'This keyword has 2 arguments. ') 112 - ELSE 113 - CALL INPCHK(I+1,2,IFAIL1) 114 - CALL INPCHK(I+2,2,IFAIL2) 115 - CALL INPRDR(I+1,FMINR,FMIN) 116 - CALL INPRDR(I+2,FMAXR,FMAX) 117 - IF(FMINR.LE.0.OR.FMAXR.LE.0)THEN 118 - CALL INPMSG(I,'Both arguments must be > 0. ') 119 - ELSEIF(FMINR.EQ.FMAXR)THEN 120 - CALL INPMSG(I,'A zero range is not permitted.') 121 - ELSE 122 - FMIN=MIN(FMINR,FMAXR) 123 - FMAX=MAX(FMINR,FMAXR) 124 - ENDIF 125 - ENDIF 126 - INEXT=I+3 127 - * The repeat counter. 128 - ELSEIF(INPCMP(I,'REP#EAT')+INPCMP(I,'N').NE.0)THEN 129 - IF(I+1.GT.NWORD)THEN 130 - CALL INPMSG(I,'this keyword has one argument.') 131 - ELSE 132 - CALL INPCHK(I+1,1,IFAIL) 133 - CALL INPRDI(I+1,NRNDMR,100000) 134 - IF(NRNDMR.LE.0)THEN 135 - CALL INPMSG(I+1,'The repeat counter is not > 0.') 136 - ELSE 137 - NRNDM=NRNDMR 138 - ENDIF 139 - ENDIF 140 - INEXT=I+2 141 - * Unknown option. 142 - ELSE 143 - CALL INPMSG(I,'The option is not known. ') 144 - ENDIF 145 - 10 CONTINUE 146 - CALL INPERR 147 - *** Carry out the AVALANCHE test, if requested. 148 - IF(LAVACH.AND.AVATYP.NE.'NOT SET')THEN 149 - CALL PROINT('Avalanche check',1,6) 150 - * Print some general information. 151 - WRITE(LUNOUT,'(''1 CHECK OF THE AVALANCHE CALCULATION''// 152 - - '' The avalanche type has been set to '',A)') AVATYP 153 - WRITE(LUNOUT,'('' The avalanche will be simulated '',I7, 154 - - '' times in this test.'')') NRNDM 155 - * For Townsend, print extra information and calculate a drift line. 156 - IF(AVATYP.EQ.'TOWNSEND'.OR.AVATYP.EQ.'POLYA-TOWN'.OR. 157 - - AVATYP.EQ.'TOWN-FIXED')THEN 158 - CALL PROFLD(1,'Computing drift line',-1.0) 159 - CALL PROSTA(1,0.0) 160 - CALL DLCALC(XSTART,YSTART,0.0,-1.0,1) 161 - CALL DLCTWN(ACLUST) 162 - XPRT=XSTART 163 - YPRT=YSTART 164 - IF(POLAR)CALL CFMRTP(XSTART,YSTART,XPRT,YPRT,1) 165 - WRITE(LUNOUT,'(/'' The drift-line over which the'', 1 766 P=SIGNAL D=SIGCHK 3 PAGE1193 166 - - '' Townsend coefficient is integrated'')') 167 - WRITE(LUNOUT,'('' starts at ('',E15.8,'','',E15.8, 168 - - ''). Its ISTAT code is '',I3,''.'')') 169 - - XPRT,YPRT,ISTAT 170 - WRITE(LUNOUT,'('' The drift-time is expected to be '', 171 - - E15.8,'' microsec. The calculation'')') TU(NU) 172 - WRITE(LUNOUT,'('' needed '',I3,'' steps. An average'', 173 - - '' avalanche should create '',E15.8,'' pairs.'')') 174 - - NU,ACLUST 175 - IF(NU.LE.2.OR.ISTAT.EQ.-2.OR.ISTAT.EQ.-3)THEN 176 - WRITE(LUNOUT,'(/'' There is no point in perfor'', 177 - - ''ming the test under these conditions.'')') 178 - RETURN 179 - ENDIF 180 - ELSE 181 - ACLUST=1.0 182 - ENDIF 183 - * Initialize the histogram. 184 - CALL PROFLD(1,'Histogram allocation',-1.0) 185 - CALL PROSTA(1,0.0) 186 - CALL HISADM('ALLOCATE',IHIST,NCHA,FMIN,FMAX,.FALSE.,IFAIL1) 187 - * Generate entries. 188 - CALL PROFLD(1,'MC cycles',REAL(NRNDM)) 189 - DO 30 I=1,NRNDM 190 - IF(I.EQ.(NRNDM/20)*(I/(NRNDM/20)))CALL PROSTA(1,REAL(I)) 191 - CALL SIGAVA(FACTOR,ACLUST) 192 - CALL HISENT(IHIST,FACTOR,1.0) 193 - 30 CONTINUE 194 - * Plot the histogram. 195 - CALL PROFLD(1,'Histogram plotting',-1.0) 196 - CALL PROSTA(1,0.0) 197 - CALL HISPLT(IHIST,'Multiplication factor', 198 - - 'CHECK ON THE GENERATION OF AVALANCHES',.TRUE.) 199 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 200 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 201 - * Get information about the histogram. 202 - CALL HISINQ(IHIST,EXIST,RSET, 203 - - NNCHA,XXMIN,XXMAX,NNENT,AVER,SIGMA) 204 - CALL OUTFMT(AVER,2,AUX,NC,'LEFT') 205 - CALL OUTFMT(SIGMA,2,AUX2,NC2,'LEFT') 206 - CALL GRCOMM(4,'Mean: '//AUX(1:NC)//', width: '//AUX2(1:NC2)) 207 - * Close the plot. 208 - CALL GRNEXT 209 - CALL GRALOG('Check: Avalanche multiplication.') 210 - * Keep the histogram if requested. 211 - IF(LKEEP)THEN 212 - CALL PROFLD(1,'Histogram saving',-1.0) 213 - CALL PROSTA(1,0.0) 214 - CALL HISSAV(IHIST,'AVALANCHE',IFAIL1) 215 - IF(IFAIL1.EQ.0)THEN 216 - PRINT *,' ------ SIGCHK MESSAGE : Avalanche'// 217 - - ' histogram kept as AVALANCHE.' 218 - ELSE 219 - PRINT *,' !!!!!! SIGCHK WARNING : Avalanche'// 220 - - ' histogram not saved.' 221 - CALL HISADM('DELETE',IHIST,0,0.0,0.0,.TRUE., 222 - - IFAIL2) 223 - ENDIF 224 - * Otherwise delete it. 225 - ELSE 226 - CALL PROFLD(1,'Histogram deletion',-1.0) 227 - CALL PROSTA(1,0.0) 228 - CALL HISADM('DELETE',IHIST,0,0.0,0.0,.TRUE.,IFAIL2) 229 - ENDIF 230 - * End of progress printing. 231 - CALL PROEND 232 - ENDIF 233 - *** Carry out the DIFFUSION test, if requested. 234 - IF(LDIFCH.AND.GASOK(3))THEN 235 - * Print some general information. 236 - WRITE(LUNOUT,'(''1 CHECK OF THE DIFFUSION CALCULATION''// 237 - - '' The longitudinal diffusion process will be'', 238 - - '' simulated '',I7/'' times in this test, by'', 239 - - '' repeatedly drawing an arrival time. '')') NRNDM 240 - CALL PROINT('Diffusion check',1,6) 241 - CALL PROFLD(1,'Computing drift line',-1.0) 242 - CALL PROSTA(1,0.0) 243 - XPRT=XSTART 244 - YPRT=YSTART 245 - IF(POLAR)CALL CFMRTP(XSTART,YSTART,XPRT,YPRT,1) 246 - CALL DLCALC(XSTART,YSTART,0.0,-1.0,1) 247 - CALL DLCDIF(SDIFF) 248 - WRITE(LUNOUT,'(/'' The drift-line over which the'', 249 - - '' diffusion coefficient is to be integrated'')') 250 - WRITE(LUNOUT,'('' starts at ('',E15.8,'','',E15.8, 251 - - ''). Its ISTAT code is '',I3,''.'')') XPRT,YPRT,ISTAT 252 - WRITE(LUNOUT,'('' The drift-time and the estimate'', 253 - - '' for the average diffusion are '',E15.8)') TU(NU) 254 - WRITE(LUNOUT,'('' and '',E15.5,''. The drift line was'', 255 - - '' calculated in '',I3,'' steps.'')') SDIFF,NU 256 - IF(NU.LE.2.OR.ISTAT.EQ.-2.OR.ISTAT.EQ.-3)THEN 257 - WRITE(LUNOUT,'(/'' There is no point in performing'', 258 - - '' the test under these conditions.'')') 259 - RETURN 260 - ENDIF 261 - * Initialize the histogram. 262 - CALL PROFLD(1,'Histogram allocation',-1.0) 263 - CALL PROSTA(1,0.0) 264 - CALL HISADM('ALLOCATE',IHIST,NCHA,0.0,0.0,.TRUE.,IFAIL1) 265 - * Generate entries. 266 - CALL PROFLD(1,'MC cycles',REAL(NRNDM)) 267 - DO 50 I=1,NRNDM 268 - IF(I.EQ.(NRNDM/20)*(I/(NRNDM/20)))CALL PROSTA(1,REAL(I)) 269 - DIFF=RNDNOR(REAL(TU(NU)),SDIFF) 270 - CALL HISENT(IHIST,DIFF,1.0) 271 - 50 CONTINUE 1 766 P=SIGNAL D=SIGCHK 4 PAGE1194 272 - * Plot the histogram. 273 - CALL HISPLT(IHIST,'Arrival time [microsec]', 274 - - 'CHECK ON THE DIFFUSION',.TRUE.) 275 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 276 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 277 - * Get information about the histogram. 278 - CALL HISINQ(IHIST,EXIST,RSET, 279 - - NNCHA,XXMIN,XXMAX,NNENT,AVER,SIGMA) 280 - CALL OUTFMT(AVER,2,AUX,NC,'LEFT') 281 - CALL OUTFMT(SIGMA,2,AUX2,NC2,'LEFT') 282 - CALL GRCOMM(4,'Mean: '//AUX(1:NC)//', width: '//AUX2(1:NC2)) 283 - * Close the plot. 284 - CALL GRNEXT 285 - CALL GRALOG('Check: spread due to diffusion. ') 286 - * Keep the histogram if requested. 287 - IF(LKEEP)THEN 288 - CALL PROFLD(1,'Histogram saving',-1.0) 289 - CALL PROSTA(1,0.0) 290 - CALL HISSAV(IHIST,'DIFFUSION',IFAIL1) 291 - IF(IFAIL1.EQ.0)THEN 292 - PRINT *,' ------ SIGCHK MESSAGE : Diffusion'// 293 - - ' histogram kept as DIFFUSION.' 294 - ELSE 295 - PRINT *,' !!!!!! SIGCHK WARNING : Diffusion'// 296 - - ' histogram not saved.' 297 - CALL HISADM('DELETE',IHIST,0,0.0,0.0,.TRUE., 298 - - IFAIL2) 299 - ENDIF 300 - * Otherwise delete it. 301 - ELSE 302 - CALL PROFLD(1,'Histogram deletion',-1.0) 303 - CALL PROSTA(1,0.0) 304 - CALL HISADM('DELETE',IHIST,0,0.0,0.0,.TRUE.,IFAIL2) 305 - ENDIF 306 - * End of progress printing. 307 - CALL PROEND 308 - ENDIF 309 - *** Carry out the CLUSTER test, if requested. 310 - IF(LCLSCH.AND.GASOK(5))THEN 311 - * Prepare for progress printing. 312 - CALL PROINT('Clustering check',1,6) 313 - * Obtain track length and set range. 314 - TRKLEN=SQRT((XT0-XT1)**2+(YT0-YT1)**2) 315 - * Print some general information. 316 - WRITE(LUNOUT,'(''1 CHECK OF THE CLUSTER FORMATION''// 317 - - '' Clusters will be generated '',I7,'' times on the'', 318 - - '' current track, their number''/'' is counted each'', 319 - - '' time and the distribution is plotted.'')') NRNDM 320 - WRITE(LUNOUT,'('' The track has a length of '',E12.4, 321 - - '' cm; the average number of clusters per''/ 322 - - '' cm for this gas is '',E12.4,''.'')') TRKLEN,CMEAN 323 - * Initialize the histogram. 324 - CALL PROFLD(1,'Histogram allocation',-1.0) 325 - CALL PROSTA(1,0.0) 326 - NAUX=NINT(2*TRKLEN*CMEAN)+1 327 - IF(NAUX.GT.MXCHA)THEN 328 - CALL HISADM('ALLOCATE',ICLUS,MXCHA, 329 - - -0.5,-0.5+MXCHA*(((NAUX-1)/MXCHA)+1), 330 - - .FALSE.,IFAIL1) 331 - ELSE 332 - CALL HISADM('ALLOCATE',ICLUS,NAUX,-0.5,NAUX-0.5, 333 - - .FALSE.,IFAIL1) 334 - ENDIF 335 - NAUX=NINT(2*TRKLEN*CMEAN*CLSAVE)+1 336 - IF(NAUX.GT.MXCHA)THEN 337 - CALL HISADM('ALLOCATE',IELEC,MXCHA, 338 - - -0.5,-0.5+MXCHA*(((NAUX-1)/MXCHA)+1), 339 - - .FALSE.,IFAIL1) 340 - ELSE 341 - CALL HISADM('ALLOCATE',IELEC,NAUX,-0.5,NAUX-0.5, 342 - - .FALSE.,IFAIL1) 343 - ENDIF 344 - * Generate entries. 345 - CALL PROFLD(1,'Tracks',REAL(NRNDM)) 346 - DO 90 I=1,NRNDM 347 - IF(I.EQ.(NRNDM/20)*(I/(NRNDM/20)))CALL PROSTA(1,REAL(I)) 348 - NCLSCH=0 349 - NELECH=0 350 - DIST=0 351 - 70 CONTINUE 352 - DIST=DIST+RNDEXP(REAL(1)/CMEAN) 353 - IF(DIST.GT.TRKLEN)GOTO 80 354 - NCLSCH=NCLSCH+1 355 - CALL HISRAD(CLSDIS,NCLS,0.0D0,1.0D0,XRAN) 356 - NELECH=NELECH+INT(XRAN) 357 - GOTO 70 358 - 80 CONTINUE 359 - CALL HISENT(ICLUS,REAL(NCLSCH),1.0) 360 - CALL HISENT(IELEC,REAL(NELECH),1.0) 361 - 90 CONTINUE 362 - * Plot the histograms. 363 - CALL PROFLD(1,'Histogram plotting',-1.0) 364 - CALL PROSTA(1,0.0) 365 - CALL HISPLT(ICLUS,'Number of clusters on the track', 366 - - 'CHECK ON THE CLUSTER GENERATION',.TRUE.) 367 - IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) 368 - CALL HISINQ(ICLUS,EXIST,RSET, 369 - - NNCHA,XXMIN,XXMAX,NNENT,AVER,SIGMA) 370 - CALL OUTFMT(AVER,2,AUX,NC,'LEFT') 371 - CALL OUTFMT(SIGMA,2,AUX2,NC2,'LEFT') 372 - CALL GRCOMM(4,'Mean: '//AUX(1:NC)//', width: '//AUX2(1:NC2)) 373 - CALL GRNEXT 374 - CALL GRALOG('Check: cluster generation, cluster count') 375 - CALL HISPLT(IELEC,'Number of electrons on the track', 376 - - 'CHECK ON THE CLUSTER GENERATION',.TRUE.) 377 - IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) 1 766 P=SIGNAL D=SIGCHK 5 PAGE1195 378 - CALL HISINQ(IELEC,EXIST,RSET, 379 - - NNCHA,XXMIN,XXMAX,NNENT,AVER,SIGMA) 380 - IF(AVER.GT.0)THEN 381 - CALL OUTFMT(SIGMA**2/AVER,2,AUX,NC,'LEFT') 382 - CALL GRCOMM(2,'Sigma**2/Mean: '//AUX(1:NC)) 383 - ELSE 384 - CALL GRCOMM(2,'Sigma**2/Mean: < mean zero>') 385 - ENDIF 386 - CALL OUTFMT(AVER,2,AUX,NC,'LEFT') 387 - CALL OUTFMT(SIGMA,2,AUX2,NC2,'LEFT') 388 - CALL GRCOMM(4,'Mean: '//AUX(1:NC)//', width: '//AUX2(1:NC2)) 389 - CALL GRNEXT 390 - CALL GRALOG('Check: cluster generation, e- count ') 391 - * Keep the histograms if requested. 392 - IF(LKEEP)THEN 393 - CALL PROFLD(1,'Histogram saving',-1.0) 394 - CALL PROSTA(1,0.0) 395 - CALL HISSAV(ICLUS,'CLUSTERS',IFAIL1) 396 - IF(IFAIL1.EQ.0)THEN 397 - PRINT *,' ------ SIGCHK MESSAGE : Cluster'// 398 - - ' count histogram kept as CLUSTERS.' 399 - ELSE 400 - PRINT *,' !!!!!! SIGCHK WARNING : Cluster'// 401 - - ' count histogram not saved.' 402 - CALL HISADM('DELETE',ICLUS,0,0.0,0.0,.TRUE., 403 - - IFAIL2) 404 - ENDIF 405 - CALL HISSAV(IELEC,'ELECTRONS',IFAIL1) 406 - IF(IFAIL1.EQ.0)THEN 407 - PRINT *,' ------ SIGCHK MESSAGE : Electron'// 408 - - ' count histogram kept as ELECTRONS.' 409 - ELSE 410 - PRINT *,' !!!!!! SIGCHK WARNING : Electron'// 411 - - ' count histogram not saved.' 412 - CALL HISADM('DELETE',IELEC,0,0.0,0.0,.TRUE., 413 - - IFAIL2) 414 - ENDIF 415 - * Otherwise delete it. 416 - ELSE 417 - CALL PROFLD(1,'Histogram deletion',-1.0) 418 - CALL PROSTA(1,0.0) 419 - CALL HISADM('DELETE',ICLUS,0,0.0,0.0,.TRUE.,IFAIL2) 420 - CALL HISADM('DELETE',IELEC,0,0.0,0.0,.TRUE.,IFAIL2) 421 - ENDIF 422 - ** Sample the cluster size distribution and plot a histogram. 423 - WRITE(LUNOUT,'(/'' In the next test, a cluster size will'', 424 - - '' be drawn '',I7,'' times.'')') NRNDM 425 - IF(CLSTYP.EQ.'FUNCTION'.OR.CLSTYP.EQ.'LANDAU')WRITE(LUNOUT, 426 - - '('' The dotted curve represents the function'', 427 - - '' the histogram is expected to follow.'')') 428 - * Initialise the histogram. 429 - CALL PROFLD(1,'Histogram allocation',-1.0) 430 - CALL PROSTA(1,0.0) 431 - CALL HISADM('ALLOCATE',IHIST,MIN(MXCHA,MXPAIR,NCLS), 432 - - -0.5,-0.5+MIN(MXCHA,MXPAIR,NCLS),.FALSE.,IFAIL1) 433 - * Generate pairs. 434 - CALL PROFLD(1,'Clusters',REAL(NRNDM)) 435 - DO 110 I=1,NRNDM 436 - IF(I.EQ.(NRNDM/20)*(I/(NRNDM/20)))CALL PROSTA(1,REAL(I)) 437 - CALL HISRAD(CLSDIS,NCLS,0.0D0,1.0D0,XRAN) 438 - CALL HISENT(IHIST,REAL(XRAN),1.0) 439 - 110 CONTINUE 440 - * Plot the histogram with GRHIST, 441 - CALL PROFLD(1,'Histogram plotting',-1.0) 442 - CALL PROSTA(1,0.0) 443 - CALL GRAOPT('LIN-X, LOG-Y') 444 - CALL HISPLT(IHIST,'Cluster Size', 445 - - 'CHECK ON THE CLUSTER SIZE DISTRIBUTION',.TRUE.) 446 - IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) 447 - CALL HISINQ(IHIST,EXIST,RSET, 448 - - NNCHA,XXMIN,XXMAX,NNENT,AVER,SIGMA) 449 - CALL OUTFMT(AVER,2,AUX,NC,'LEFT') 450 - CALL OUTFMT(SIGMA,2,AUX2,NC2,'LEFT') 451 - CALL GRCOMM(4,'Mean: '//AUX(1:NC)//', width: '//AUX2(1:NC2)) 452 - * Get rid of the histogram. 453 - IF(LKEEP)THEN 454 - CALL PROFLD(1,'Histogram saving',-1.0) 455 - CALL PROSTA(1,0.0) 456 - CALL HISSAV(IHIST,'PAIRS',IFAIL1) 457 - IF(IFAIL1.EQ.0)THEN 458 - PRINT *,' ------ SIGCHK MESSAGE : Pair'// 459 - - ' count histogram kept as PAIRS.' 460 - ELSE 461 - PRINT *,' !!!!!! SIGCHK WARNING : Pair'// 462 - - ' count histogram not saved.' 463 - CALL HISADM('DELETE',IHIST,0,0.0,0.0,.TRUE., 464 - - IFAIL1) 465 - ENDIF 466 - ELSE 467 - CALL PROFLD(1,'Histogram deletion',-1.0) 468 - CALL PROSTA(1,0.0) 469 - CALL HISADM('DELETE',IHIST,0,0.0,0.0,.TRUE.,IFAIL2) 470 - ENDIF 471 - ** Skip plotting the function if of inappropriate type. 472 - IENTRY=0 473 - IF(CLSTYP.NE.'FUNCTION'.AND.CLSTYP.NE.'LANDAU')GOTO 150 474 - * Pass the cluster function through ALGPRE. 475 - IF(CLSTYP.EQ.'FUNCTION')THEN 476 - CALL PROFLD(1,'Function plotting',-1.0) 477 - CALL PROSTA(1,0.0) 478 - IF(INDEX(FCNCLS(1:NFCLS),'@').NE.0)THEN 479 - GOTO 150 480 - ELSE 481 - CALL ALGPRE(FCNCLS,NFCLS,VARCLS,1,NRES,USE, 482 - - IENTRY,IFAIL1) 483 - IF(IFAIL1.NE.0.OR.NRES.NE.1)THEN 1 766 P=SIGNAL D=SIGCHK 6 PAGE1196 484 - CALL ALGCLR(IENTRY) 485 - GOTO 150 486 - ENDIF 487 - ENDIF 488 - ENDIF 489 - * And calculate it. 490 - SUM=0.0 491 - NTERM=MAX(3,2*INT(MXLIST/2)-1) 492 - DO 130 I=1,NTERM 493 - XPL(I)=(I-1)*REAL(NCLS)/REAL(NTERM-1) 494 - XVAL=(I-0.5)*REAL(NCLS)/REAL(NTERM-1) 495 - IF(CLSTYP.EQ.'FUNCTION')THEN 496 - MODVAR(1)=2 497 - CALL ALGEXE(IENTRY,XVAL,MODVAR,1, 498 - - YPL(I),MODRES,1,IFAIL1) 499 - ELSEIF(CLSTYP.EQ.'LANDAU')THEN 500 - IF((CMEAN*XVAL*EPAIR-EMPROB)/(1.54E5*(Z/A)*RHO)- 501 - - LOG(CMEAN).LT.-5.0)THEN 502 - YPL(I)=0.0 503 - ELSE 504 - YPL(I)=DENLAN((CMEAN*XVAL*EPAIR-EMPROB)/ 505 - - (1.54E5*(Z/A)*RHO)-LOG(CMEAN)) 506 - ENDIF 507 - ENDIF 508 - * integrate the cluster function to be able to plot it to scale, 509 - IF(I.EQ.2*INT(I/2))SUM=SUM+4.0*YPL(I) 510 - IF(I.NE.2*INT(I/2))SUM=SUM+2.0*YPL(I) 511 - 130 CONTINUE 512 - SUM=NCLS*(SUM-YPL(1)-YPL(NTERM))/(3.0*(NTERM-1)) 513 - * normalise the calculated distribution and clip above MAXHST, 514 - DO 140 I=1,NTERM 515 - YPL(I)=YPL(I)*REAL(NRNDM)/SUM 516 - 140 CONTINUE 517 - * and finally plot the cluster function on top of the histogram. 518 - CALL GRATTS('FUNCTION-2','POLYLINE') 519 - CALL GRLINE(NTERM,XPL,YPL) 520 - * Jump to this lable if no function is to be plotted. 521 - 150 CONTINUE 522 - * Print number of algebra error messages. 523 - CALL ALGERR 524 - * Clear the function used for plotting the cluster distribution. 525 - IF(CLSTYP.EQ.'FUNCTION'.AND.IENTRY.NE.0)CALL ALGCLR(IENTRY) 526 - * Close the graphics output. 527 - CALL GRNEXT 528 - CALL GRALOG('Check: cluster size distribution. ') 529 - CALL GRAOPT('LIN-X, LIN-Y') 530 - * End of progress printing. 531 - CALL PROEND 532 - ENDIF 533 - *** Logging of CPU time used for these checks. 534 - CALL TIMLOG('Various signal related checks: ') 535 - END 767 GARFIELD ================================================== P=SIGNAL D=SIGTHR 1 ============================ 0 + +DECK,SIGTHR,IF=NEVER. 1 - SUBROUTINE SIGTHR 2 - *----------------------------------------------------------------------- 3 - * SIGTHR - Computes the arrival time distribution of the M'th electron 4 - * from a given track. It has a set of auxilliray routines 5 - * SIGTH1, SIGTH2 etc 6 - * VARIABLES : AUXSPL : Auxilliary array for interpolations. 7 - * LTHWRT : Write the data to a dataset, if .TRUE. 8 - * LMCCHK : Perform an additional MC check. 9 - * TIMSCL : Vector storing the time scale. 10 - * FGLOB : Time distribution for all electrons. 11 - * STACK : Stack used for integrating. 12 - * MFIRST,MLAST: First and last electron to be handled. 13 - *----------------------------------------------------------------------- 14.- +SEQ,DIMENSIONS. 15.- +SEQ,CELLDATA. 16.- +SEQ,GASDATA. 17.- +SEQ,THRESHDATA. 18.- +SEQ,DRIFTLINE. 19.- +SEQ,PARAMETERS. 20.- +SEQ,PRINTPLOT. 21.- +SEQ,CONSTANTS. 22 - *** Declarations, start setting the max number of histogram channels. 23 - CHARACTER*(MXCHAR) STRING 24 - CHARACTER*(MXNAME) FILE 25 - CHARACTER*40 TITLE 26 - CHARACTER*29 REMARK 27 - CHARACTER*8 MEMBER 28 - REAL TIMDIF(MXLIST,3),TIMSCL(MXLIST),FGLOB(MXLIST),FK(MXLIST), 29 - - FAUX(MXLIST),FM(MXLIST),ARRTIM(MXCLUS*MXPAIR), 30 - - XPL(MXLIST),YPL(MXLIST),STACK(MXSTCK,3), 31 - - CONT1(0:MXCHA+1),CONT2(0:MXCHA+1),XTHR,YSTART 32 - DOUBLE PRECISION CLSRND 33 - LOGICAL FLAG(MXWORD+3),LTHWRT,LMCCHK,LANTHR 34 - EXTERNAL RNDNOR,DIVDIF 0 35-+ +SELF,IF=SAVE. 36 - SAVE MAXOPT,MFIRST,MLAST,NRNDM,NCHA,LMCCHK,LANTHR 0 37-+ +SELF. 38 - *** Initialise those variables that are kept across calls. 39 - DATA MAXOPT/10/ 40 - DATA MFIRST,MLAST/1,10/ 41 - DATA LMCCHK,LANTHR/.FALSE.,.TRUE./ 42 - DATA NRNDM/10000/ 43 - DATA NCHA/MXCHA/ 44 - *** Check the presence of sufficient gas data. 45 - IF(.NOT.(GASOK(1).AND.GASOK(3).AND.GASOK(5)))THEN 46 - PRINT *,' ###### SIGTHR ERROR : Insufficient gas data to', 47 - - ' perform the calculations.' 48 - PRINT *,' Required are velocity,', 1 767 P=SIGNAL D=SIGTHR 2 PAGE1197 49 - - ' diffusion and cluster data.' 50 - RETURN 51 - ENDIF 52 - *** Make sure the cell is not in polar coordinates. 53 - IF(POLAR)THEN 54 - PRINT *,' ###### SIGTHR ERROR : The THRESHOLD function', 55 - - ' can not be applied to polar geometries.' 56 - RETURN 57 - ENDIF 58 - ** Set NLINTH to the next higher multiple of 8. 59 - NLINTH=8*INT(1+NLINED/8.0) 60 - *** Initialise various other variables being reset at each call. 61 - FILE=' ' 62 - MEMBER='< none >' 63 - REMARK='none' 64 - NCFILE=1 65 - NCMEMB=8 66 - NCREM=4 67 - LTHWRT=.FALSE. 68 - IYSET=0 69 - XTHR=DXMAX-(DXMAX-DXMIN)/100.0 70 - *** Examine the input line, flag the known words. 71 - CALL INPNUM(NWORD) 72 - DO 10 I=2,NWORD 73 - IF(INPCMP(I,'X-#START')+INPCMP(I,'OPT#IMISE')+ 74 - - INPCMP(I,'D#ATASET')+INPCMP(I,'R#EMARK')+ 75 - - INPCMP(I,'ARR#IVALS')+INPCMP(I,'BIN#S')+ 76 - - INPCMP(I,'ANA#LYTIC')+INPCMP(I,'NOANA#LYTIC')+ 77 - - INPCMP(I,'Y-#SEGMENT')+INPCMP(I,'M#ONTE-C#ARLO').NE.0)THEN 78 - FLAG(I)=.TRUE. 79 - ELSE 80 - FLAG(I)=.FALSE. 81 - ENDIF 82 - 10 CONTINUE 83 - FLAG(NWORD+1)=.TRUE. 84 - FLAG(NWORD+2)=.TRUE. 85 - FLAG(NWORD+3)=.TRUE. 86 - INEXT=2 87 - ** Read in detail. 88 - DO 20 I=2,NWORD 89 - IF(I.LT.INEXT)GOTO 20 90 - * The ANALYTIC/NOANALYTIC options. 91 - IF(INPCMP(I,'ANA#LYTIC').NE.0)THEN 92 - LANTHR=.TRUE. 93 - ELSEIF(INPCMP(I,'NOANA#LYTIC').NE.0)THEN 94 - LANTHR=.FALSE. 95 - * Read the first and last particle to be considered. 96 - ELSEIF(INPCMP(I,'ARR#IVALS').NE.0)THEN 97 - IF(FLAG(I+1))THEN 98 - CALL INPMSG(I,'Should have 1 or 2 arguments. ') 99 - ELSE 100 - CALL INPCHK(I+1,1,IFAIL) 101 - CALL INPRDI(I+1,MFR,MFIRST) 102 - IF(MFR.LE.0.AND.IFAIL.EQ.0)THEN 103 - CALL INPMSG(I+1,'The serial numbers start at 1.') 104 - ELSEIF(MFR.GT.MXLIST.AND.IFAIL.EQ.0)THEN 105 - CALL INPMSG(I+1,'This parameter exceeds MXLIST.') 106 - ELSEIF(IFAIL.EQ.0)THEN 107 - MFIRST=MFR 108 - ENDIF 109 - INEXT=I+2 110 - IF(.NOT.FLAG(I+2))THEN 111 - CALL INPCHK(I+2,1,IFAIL) 112 - CALL INPRDI(I+2,MLR,MLAST) 113 - IF(MLR.LE.0.AND.IFAIL.EQ.0)THEN 114 - CALL INPMSG(I+1, 115 - - 'The serial numbers start at 1.') 116 - ELSEIF(MLR.GT.MXLIST.AND.IFAIL.EQ.0)THEN 117 - CALL INPMSG(I+1, 118 - - 'This parameter exceeds MXLIST.') 119 - ELSEIF(MLR.LT.MFIRST.AND.IFAIL.EQ.0)THEN 120 - CALL INPMSG(I+1, 121 - - 'Has been set to the minimum. ') 122 - MLAST=MFIRST 123 - ELSEIF(IFAIL.EQ.0)THEN 124 - MLAST=MLR 125 - ENDIF 126 - INEXT=I+3 127 - ELSE 128 - MLAST=MFIRST 129 - ENDIF 130 - ENDIF 131 - * The BINS keyword. 132 - ELSEIF(INPCMP(I,'BIN#S').NE.0)THEN 133 - IF(I+1.GT.NWORD)THEN 134 - CALL INPMSG(I,'This keyword has one argument.') 135 - ELSE 136 - CALL INPCHK(I+1,1,IFAIL) 137 - CALL INPRDI(I+1,NCHAR,MXCHA) 138 - IF(NCHAR.LE.1.OR.NCHAR.GT.MXCHA)THEN 139 - CALL INPMSG(I+1,'Inacceptable number of bins. ') 140 - ELSE 141 - NCHA=NCHAR 142 - ENDIF 143 - ENDIF 144 - INEXT=I+2 145 - * Read the output data set name. 146 - ELSEIF(INPCMP(I,'D#ATASET').NE.0)THEN 147 - IF(FLAG(I+1))THEN 148 - CALL INPMSG(I,'Should have an argument. ') 149 - ELSE 150 - CALL INPSTR(I+1,I+1,STRING,NCFILE) 151 - FILE=STRING 152 - INEXT=I+2 153 - IF(.NOT.FLAG(I+2))THEN 154 - CALL INPSTR(I+2,I+2,STRING,NCMEMB) 1 767 P=SIGNAL D=SIGTHR 3 PAGE1198 155 - MEMBER=STRING 156 - INEXT=I+3 157 - ENDIF 158 - LTHWRT=.TRUE. 159 - ENDIF 160 - * Check for the Monte-Carlo option 161 - ELSEIF(INPCMP(I,'M#ONTE-C#ARLO').NE.0)THEN 162 - IF(FLAG(I+1))THEN 163 - LMCCHK=.TRUE. 164 - ELSEIF(INPCMP(I+1,'OFF')+INPCMP(I+1,'NO#NE').NE.0)THEN 165 - LMCCHK=.FALSE. 166 - ELSE 167 - CALL INPCHK(I+1,1,IFAIL) 168 - CALL INPRDI(I+1,NRNDMR,NRNDM) 169 - IF(NRNDMR.LT.0)THEN 170 - CALL INPMSG(I+1,'The number of cycles is < 0. ') 171 - ELSE 172 - NRNDM=NRNDMR 173 - IF(NRNDM.GT.0)THEN 174 - LMCCHK=.TRUE. 175 - ELSE 176 - LMCCHK=.FALSE. 177 - ENDIF 178 - ENDIF 179 - INEXT=I+2 180 - ENDIF 181 - ELSEIF(INPCMP(I,'NOM#ONTE-C#ARLO').NE.0)THEN 182 - LMCCHK=.FALSE. 183 - * Read the maximum number of optimising cycles. 184 - ELSEIF(INPCMP(I,'OPT#IMISE').NE.0)THEN 185 - IF(FLAG(I+1))THEN 186 - CALL INPMSG(I,'Should have an argument. ') 187 - ELSEIF(INPCMP(I+1,'OFF')+INPCMP(I+1,'NO#NE').NE.0)THEN 188 - MAXOPT=0 189 - ELSE 190 - CALL INPCHK(I+1,1,IFAIL) 191 - CALL INPRDI(I+1,MAXOPR,MAXOPT) 192 - IF(MAXOPR.LT.0)THEN 193 - CALL INPMSG(I+1,'The number of cycles is < 0. ') 194 - ELSE 195 - MAXOPT=MAXOPR 196 - ENDIF 197 - INEXT=I+2 198 - ENDIF 199 - * Read the remark to be added to the dataset. 200 - ELSEIF(INPCMP(I,'R#EMARK').NE.0)THEN 201 - IF(FLAG(I+1))THEN 202 - CALL INPMSG(I,'Should have an argument. ') 203 - ELSE 204 - CALL INPSTR(I+1,I+1,STRING,NCREM) 205 - REMARK=STRING 206 - INEXT=I+2 207 - ENDIF 208 - * Find the x-coordinate on which this routine will work. 209 - ELSEIF(INPCMP(I,'X-#START').NE.0)THEN 210 - IF(FLAG(I+1))THEN 211 - CALL INPMSG(I,'Should have an argument. ') 212 - ELSE 213 - CALL INPCHK(I+1,2,IFAIL) 214 - CALL INPRDR(I+1,XTHRR,XTHR) 215 - IF(XTHRR.LE.DXMIN.OR.XTHRR.GE.DXMAX)THEN 216 - CALL INPMSG(I+1,'This x lies outside the AREA. ') 217 - ELSE 218 - XTHR=XTHRR 219 - ENDIF 220 - INEXT=I+2 221 - ENDIF 222 - * Find the y-segment to be used. 223 - ELSEIF(INPCMP(I,'Y-#SEGMENT').NE.0)THEN 224 - IF(FLAG(I+1).OR.FLAG(I+2))THEN 225 - CALL INPMSG(I,'Should have two arguments. ') 226 - IF(.NOT.FLAG(I+1))THEN 227 - INEXT=I+2 228 - CALL INPMSG(I+1,'See the preceding message. ') 229 - ENDIF 230 - ELSE 231 - CALL INPCHK(I+1,2,IFAIL) 232 - CALL INPRDR(I+1,YTHMIR,DYMIN) 233 - CALL INPCHK(I+2,2,IFAIL) 234 - CALL INPRDR(I+2,YTHMAR,DYMAX) 235 - YTHMIN=MIN(YTHMIR,YTHMAR) 236 - YTHMAX=MAX(YTHMIR,YTHMAR) 237 - IYSET=1 238 - INEXT=I+3 239 - ENDIF 240 - * The option is not known to the program. 241 - ELSE 242 - CALL INPMSG(I,'The option is not known. ') 243 - ENDIF 244 - 20 CONTINUE 245 - CALL INPERR 246 - ** Check the length of the various strings. 247 - IF(NCFILE.GT.MXNAME)THEN 248 - PRINT *,' !!!!!! SIGTHR WARNING : The dataset name is too', 249 - - ' long and is truncated to ',FILE,'.' 250 - NCFILE=MXNAME 251 - ENDIF 252 - IF(NCMEMB.GT.8)THEN 253 - PRINT *,' !!!!!! SIGTHR WARNING : The member name is too', 254 - - ' long and is truncated to ',MEMBER,'.' 255 - NCMEMB=8 256 - ENDIF 257 - IF(NCREM.GT.29)THEN 258 - PRINT *,' !!!!!! SIGTHR WARNING : The remark is too', 259 - - ' long and is truncated to ',REMARK,'.' 260 - NCREM=29 1 767 P=SIGNAL D=SIGTHR 4 PAGE1199 261 - ENDIF 262 - ** Print some debugging output, to check correct input handling. 263 - IF(LDEBUG)THEN 264 - PRINT *,' ++++++ SIGTHR DEBUG : Requested action: MC: ', 265 - - LMCCHK,', analytic: ',LANTHR,', dataset: ',LTHWRT 266 - IF(LTHWRT)WRITE(*,'(26X,''Dataset: '',A,'' member: '',A/ 267 - - 26X,''Remark: '',A29)') 268 - - FILE(1:NCFILE),MEMBER(1:NCMEMB),REMARK 269 - WRITE(*,'(26X,''First electron to be handled: '',I3, 270 - - '', last electron: '',I3)') MFIRST,MLAST 271 - WRITE(*,'(26X,''Calculations apply to x='',E15.8)') XTHR 272 - WRITE(*,'(26X,''Maximum number of iterations: '',I3/ 273 - - 26X,''Random cycles: '',I6,'', bins: '',I3)') 274 - - MAXOPT,NRNDM,NCHA 275 - ENDIF 276 - ** Check that at least some output has been requested. 277 - IF(.NOT.(LANTHR.OR.LMCCHK.OR.LTHWRT))THEN 278 - PRINT *,' !!!!!! SIGTHR WARNING : All output of has been', 279 - - ' suppressed; routine not executed.' 280 - RETURN 281 - ENDIF 282 - *** Loop over the selected, attracting wires inside the AREA. 283 - DO 1000 IW=1,NWIRE 284 - IF(INDSW(IW).EQ.0.OR.X(IW).LT.DXMIN.OR.X(IW).GT.DXMAX.OR. 285 - - Y(IW).LT.DYMIN.OR.Y(IW).GT.DYMAX.OR.E(IW).LT.0.0)GOTO 1000 286 - IF(LDEBUG)PRINT *,' ++++++ SIGTHR DEBUG : Wire ',IW,' selected' 287 - ** Find the y-segment from where the particles reach the wire. 288 - IF(IYSET.NE.1)THEN 289 - CALL SIGTH3(IW,MAXOPT,IFAIL) 290 - IF(IFAIL.NE.0)GOTO 1000 291 - ENDIF 292 - ** Store distribution of number of clusters and of cluster sizes. 293 - IF(LANTHR)THEN 294 - CALL SIGTH4(IFAIL) 295 - IF(IFAIL.NE.0)GOTO 1000 296 - ENDIF 297 - *** Calculate drift lines from the given x coordinate in the y range. 298 - IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGTHR DEBUG : List of'', 299 - - '' drift-lines from the accepting segments.'')') 300 - ** Open a plot frame if the DRIFTPLOT option is on. 301 - IF(LDRPLT)THEN 302 - CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, 303 - - 'DRIFT LINES USED FOR THE INTERPOLATION ') 304 - CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) 305 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 306 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 307 - * Plot the accepting segment as a dashed line. 308 - XPL(1)=XTHR 309 - YPL(1)=YTHMIN 310 - XPL(2)=XTHR 311 - YPL(2)=YTHMAX 312 - CALL GRATTS('TRACK','POLYLINE') 313 - CALL GPL(2,XPL,YPL) 314 - ENDIF 315 - ** Loop along the segment, produce 3*NLINTH/4 drift-lines. 316 - NLINE=0 317 - IF(LDRPLT)CALL GRATTS('E-DRIFT-LINE','POLYLINE') 318 - DO 300 IL=1,3*NLINTH/4 319 - * Check number of drift-lines. 320 - IF(NLINE+1.GT.MXLIST)THEN 321 - IF(LDEBUG)PRINT *,' ++++++ SIGTHR DEBUG : NLINE = MXLIST.' 322 - GOTO 390 323 - ENDIF 324 - * Calculate a drift-line. 325 - YSTART=YTHMIN+REAL(IL-1)*(YTHMAX-YTHMIN)/REAL(3*NLINTH/4-1) 326 - CALL DLCALC(XTHR,YSTART,0.0,-1.0,1) 327 - * Plot and print the data if requested. 328 - IF(NU.GT.2.AND.LDRPLT)CALL GPL2(NU,XU,YU) 329 - * Add the new drift-line to the table if it leads to the wire. 330 - IF(ISTAT.EQ.IW)THEN 331 - NLINE=NLINE+1 332 - TIMDIF(NLINE,1)=YSTART 333 - TIMDIF(NLINE,2)=TU(NU) 334 - CALL DLCDIF(TIMDIF(NLINE,3)) 335 - IF(LDEBUG)WRITE(LUNOUT,'(2X,''y='',E15.8,'', t='', 336 - - E15.8,'', s='',E10.3,'', ISTAT='',I4,'',NU='', 337 - - I3)') YSTART,TU(NU),TIMDIF(NLINE,3),ISTAT,NU 338 - ELSE 339 - PRINT *,' !!!!!! SIGTHR WARNING : Wire ',IW,' lost; fix', 340 - - ' via interpolation attempted, this may result in a', 341 - - ' degraded accuracy.' 342 - ENDIF 343 - * Proceed with the next drift-line. 344 - 300 CONTINUE 345 - *** Skip this wire if less than 4 drift-lines have been found. 346 - IF(NLINE.LT.4)THEN 347 - PRINT *,' !!!!!! SIGTHR WARNING : Insufficient data for', 348 - - ' wire ',IW,', 4 points are needed ; wire skipped.' 349 - IF(LDRPLT)THEN 350 - CALL GRNEXT 351 - CALL GRALOG('Drift-lines from the acceptance segment.') 352 - ENDIF 353 - GOTO 1000 354 - ENDIF 355 - ** Next add the other NLINTH/4 drift-lines where delta t is largest. 356 - IF(LDEBUG)PRINT *,' ++++++ SIGTHR DEBUG : Adding intermediate', 357 - - ' drift-lines at largest t jumps.' 358 - DO 360 IL=1,NLINTH/4 359 - * Check number of drift-lines. 360 - IF(NLINE+1.GT.MXLIST)THEN 361 - IF(LDEBUG)PRINT *,' ++++++ SIGTHR DEBUG : NLINE = MXLIST.' 362 - GOTO 390 363 - ENDIF 364 - * Locate the largest t jump. 365 - DELTAT=ABS(TIMDIF(2,2)-TIMDIF(1,2)) 366 - IDMAX=1 1 767 P=SIGNAL D=SIGTHR 5 PAGE1200 367 - DO 370 JL=2,NLINE-1 368 - IF(ABS(TIMDIF(JL+1,2)-TIMDIF(JL,2)).GT.DELTAT)THEN 369 - DELTAT=ABS(TIMDIF(JL+1,2)-TIMDIF(JL,2)) 370 - IDMAX=JL 371 - ENDIF 372 - 370 CONTINUE 373 - * Shift everything above by one place. 374 - DO 380 JL=NLINE,IDMAX+1,-1 375 - DO 385 KL=1,3 376 - TIMDIF(JL+1,KL)=TIMDIF(JL,KL) 377 - 385 CONTINUE 378 - 380 CONTINUE 379 - * Halve the y-step. 380 - TIMDIF(IDMAX+1,1)=(TIMDIF(IDMAX,1)+TIMDIF(IDMAX+2,1))/2.0 381 - * Calculate a drift-line from the half-way point. 382 - YSTART=TIMDIF(IDMAX+1,1) 383 - CALL DLCALC(XTHR,YSTART,0.0,-1.0,1) 384 - * Plot and print the data if requested. 385 - IF(NU.GT.2.AND.LDRPLT)CALL GPL2(NU,XU,YU) 386 - * Add the new drift-line to the table if it leads to the wire. 387 - IF(ISTAT.EQ.IW)THEN 388 - NLINE=NLINE+1 389 - TIMDIF(IDMAX+1,2)=TU(NU) 390 - CALL DLCDIF(TIMDIF(IDMAX+1,3)) 391 - IF(LDEBUG)WRITE(LUNOUT,'(2X,''y='',E15.8,'', t='', 392 - - E15.8,'', s='',E10.3,'', ISTAT='',I4,'',NU='', 393 - - I3)') YSTART,TU(NU),TIMDIF(IDMAX+1,3),ISTAT,NU 394 - ELSE 395 - PRINT *,' !!!!!! SIGTHR WARNING : Wire ',IW,' lost; fix', 396 - - ' via interpolation attempted, this may result in a', 397 - - ' degraded accuracy.' 398 - ENDIF 399 - * Add another line. 400 - 360 CONTINUE 401 - ** Jump to this point if the maximum number of drift-lines is reached. 402 - 390 CONTINUE 403 - ** Finish this plot, if plotting has been requested. 404 - IF(LDRPLT)THEN 405 - CALL GRNEXT 406 - CALL GRALOG('Drift-lines from the acceptance segment.') 407 - ENDIF 408 - * Plot the arrival time distribution. 409 - IF(LDEBUG.AND..FALSE.)THEN 410 - DO 301 IPL=1,MXLIST 411 - XPL(IPL)=TIMDIF(1,1)+REAL(IPL-1)* 412 - - (TIMDIF(NLINE,1)-TIMDIF(1,1))/REAL(MXLIST-1) 413 - YPL(IPL)=DIVDIF(TIMDIF(1,2),TIMDIF(1,1),NLINE,XPL(IPL),2) 414 - 301 CONTINUE 415 - CALL GRGRPH(XPL,YPL,MXLIST, 416 - - ' y-Axis [cm]', 417 - - ' Drift time [microsec]', 418 - - 'DRIFT TIME AS A FUNCTION OF Y ') 419 - CALL GRATTS('FUNCTION-1','POLYMARKER') 420 - CALL GPM(NLINE,TIMDIF(1,1),TIMDIF(1,2)) 421 - CALL GRALOG('Drift-time as a function of y. ') 422 - CALL GRNEXT 423 - DO 302 IPL=1,MXLIST 424 - XPL(IPL)=TIMDIF(1,1)+REAL(IPL-1)* 425 - - (TIMDIF(NLINE,1)-TIMDIF(1,1))/REAL(MXLIST-1) 426 - YPL(IPL)=DIVDIF(TIMDIF(1,3),TIMDIF(1,1),NLINE,XPL(IPL),2) 427 - 302 CONTINUE 428 - CALL GRGRPH(XPL,YPL,MXLIST, 429 - - ' y-Axis [cm]', 430 - - ' Integrated Diffusion [microsec]', 431 - - 'DIFFUSION AS A FUNCTION OF Y ') 432 - CALL GRATTS('FUNCTION-1','POLYMARKER') 433 - CALL GPM(NLINE,TIMDIF(1,1),TIMDIF(1,3)) 434 - CALL GRALOG('Diffusion as a function of y. ') 435 - CALL GRNEXT 436 - ENDIF 437 - ** Find maximum and minimum arrival time. 438 - TMIN=TIMDIF(1,2) 439 - TMAX=TIMDIF(1,2) 440 - DO 310 I=1,NLINE 441 - TMIN=MIN(TMIN,TIMDIF(I,2)-5.0*TIMDIF(I,3)) 442 - TMAX=MAX(TMAX,TIMDIF(I,2)+5.0*TIMDIF(I,3)) 443 - 310 CONTINUE 444 - * Round these values to obtain a sensible time scale. 445 - CALL ROUND(TMIN,TMAX,MXLIST,'LARGER',THRSTP) 446 - IF(LDEBUG)PRINT *,' ++++++ SIGTHR DEBUG : TMIN=',TMIN, 447 - - ', TMAX=',TMAX 448 - *** Prepare the analytic calc, integrate the Gaussian diffusion spread. 449 - IF(LANTHR)THEN 450 - * Initialise the output array and the time scale vectors. 451 - DO 320 IT=1,MXLIST 452 - FGLOB(IT)=0.0 453 - TIMSCL(IT)=TMIN+REAL(IT-1)*(TMAX-TMIN)/REAL(MXLIST-1) 454 - 320 CONTINUE 455 - * Interpolate for the first y point. 456 - YPOS1=TIMDIF(1,1) 457 - TIM1=DIVDIF(TIMDIF(1,2),TIMDIF(1,1),NLINE,YPOS1,2) 458 - SIG1=DIVDIF(TIMDIF(1,3),TIMDIF(1,1),NLINE,YPOS1,2) 459 - * Loop over the remaining points, set the initial stacksize to 0. 460 - NSTACK=0 461 - DO 350 IY=1,MXLIST-1 462 - YPOS2=TIMDIF(1,1)+REAL(IY)*(TIMDIF(NLINE,1)-TIMDIF(1,1))/ 463 - - REAL(MXLIST-1) 464 - TIM2=DIVDIF(TIMDIF(1,2),TIMDIF(1,1),NLINE,YPOS2,2) 465 - SIG2=DIVDIF(TIMDIF(1,3),TIMDIF(1,1),NLINE,YPOS2,2) 466 - * Establish the middle point. 467 - 330 CONTINUE 468 - YPOSM=0.5*(YPOS1+YPOS2) 469 - TIMM=DIVDIF(TIMDIF(1,2),TIMDIF(1,1),NLINE,YPOSM,2) 470 - SIGM=DIVDIF(TIMDIF(1,3),TIMDIF(1,1),NLINE,YPOSM,2) 471 - * Subdivide if needed, provided storage is available. 472 - IF((SIG1**2+4*SIGM**2+SIGM**2)/6.0.LT.10*(TIM1-TIM2)**2.AND. 1 767 P=SIGNAL D=SIGTHR 6 PAGE1201 473 - - NSTACK.LT.MXSTCK)THEN 474 - NSTACK=NSTACK+1 475 - STACK(NSTACK,1)=YPOS2 476 - STACK(NSTACK,2)=TIM2 477 - STACK(NSTACK,3)=SIG2 478 - YPOS2=YPOSM 479 - TIM2=TIMM 480 - SIG2=SIGM 481 - GOTO 330 482 - * Add the new segment, without further subdivision. 483 - ELSE 484 - DO 340 IT=1,MXLIST 485 - IF((TIMSCL(IT)-(TIM1-5.0*SIG1))* 486 - - (TIMSCL(IT)-(TIM2+5.0*SIG2)).GT.0)GOTO 340 487 - FGLOB(IT)=FGLOB(IT)+(YPOS2-YPOS1)* 488 - - (EXP(-0.5*((TIM1-TIMSCL(IT))/SIG1)**2)/SIG1+ 489 - - 4.0*EXP(-0.5*((TIMM-TIMSCL(IT))/SIGM)**2)/SIGM+ 490 - - EXP(-0.5*((TIM2-TIMSCL(IT))/SIG2)**2)/SIG2)/ 491 - - (6*SQRT(2*PI)*(YTHMAX-YTHMIN)) 492 - 340 CONTINUE 493 - * Move on to the next subsegment. 494 - YPOS1=YPOS2 495 - TIM1=TIM2 496 - SIG1=SIG2 497 - * Return one level in the stack, provided it is not empty. 498 - IF(NSTACK.GT.0)THEN 499 - YPOS2=STACK(NSTACK,1) 500 - TIM2=STACK(NSTACK,2) 501 - SIG2=STACK(NSTACK,3) 502 - NSTACK=NSTACK-1 503 - GOTO 330 504 - ENDIF 505 - ENDIF 506 - * Proceed with the next couple of points. 507 - 350 CONTINUE 508 - ** Open the dataset for storing the FK distributions. 509 - CALL SIGTH6('OPEN',FK,0,IFAIL) 510 - IF(IFAIL.NE.0)THEN 511 - PRINT *,' !!!!!! SIGTHR WARNING : The ANALYTIC flag', 512 - - ' is cancelled as a result of the OPEN failure.' 513 - LANTHR=.FALSE. 514 - GOTO 490 515 - ENDIF 516 - * Loop over the clusters. 517 - DO 440 K=1,NCMAX 518 - * Initialise the distribution for cluster K. 519 - DO 410 IFK=1,MXLIST 520 - FK(IFK)=0 521 - 410 CONTINUE 522 - * Loop over the numbers of clusters. 523 - DO 450 N=MAX(K,NCMIN),NCMAX 524 - IF(PRCLUS(N).LT.1.0E-10)GOTO 450 525 - * Obtain the K'th cluster out of N clusters in all. 526 - CALL SIGTH5(FGLOB,N,K,FAUX) 527 - * Add this distribution to the sum. 528 - DO 420 IFK=1,MXLIST 529 - FK(IFK)=FK(IFK)+PRCLUS(N)*FAUX(IFK) 530 - 420 CONTINUE 531 - * Next number of clusters. 532 - 450 CONTINUE 533 - * Dump the distribution in external storage. 534 - CALL SIGTH6('WRITE',FK,K,IFAIL) 535 - IF(IFAIL.NE.0)THEN 536 - PRINT *,' !!!!!! SIGTHR WARNING : The ANALYTIC flag', 537 - - ' is cancelled as a result of the WRITE failure.' 538 - LANTHR=.FALSE. 539 - GOTO 490 540 - ENDIF 541 - * Next cluster. 542 - 440 CONTINUE 543 - * Error exit. 544 - 490 CONTINUE 545 - ENDIF 546 - *** Preset the over-all arrival time histogram. 547 - DO 730 ICONT=0,MXCHA+1 548 - CONT2(ICONT)=0 549 - 730 CONTINUE 550 - NENTR2=0 551 - *** Calculate the arrival time distribution of the M'th electron. 552 - DO 700 M=MFIRST,MLAST 553 - * Prepare a title for the plots. 554 - WRITE(TITLE,'(''ARRIVAL TIME DISTRIBUTION (ELECTRON '',I3, 555 - - '')'')') M 556 - ** Perform the calculation in Monte-Carlo style. 557 - IF(LMCCHK)THEN 558 - * Reset the histogram to zero. 559 - DO 650 I=0,MXCHA+1 560 - CONT1(I)=0 561 - 650 CONTINUE 562 - NENTR1=0 563 - * Carry out NRNDM global random cycles, resetting the counters. 564 - IF(LDEBUG)WRITE(*,'('' '')') 565 - DO 640 IRNDM=1,NRNDM 566 - IF(LDEBUG.AND.IRNDM.EQ.1000*INT(REAL(IRNDM)/1000.0)) 567 - - WRITE(*,'(''+ At random cycle '',I5)') IRNDM 568 - YPOS=YTHMIN 569 - NPART=0 570 - * Return to this point to process the y=YPOS point. 571 - 610 CONTINUE 572 - * Generate a new point on the track. 573 - YPOS=YPOS+RNDEXP(1.0/CMEAN) 574 - IF(YPOS.GT.YTHMAX)GOTO 630 575 - * Find the drift time and the diffusion coefficient for this point. 576 - TIMRND=DIVDIF(TIMDIF(1,2),TIMDIF(1,1),NLINE,YPOS,2) 577 - SIGRND=DIVDIF(TIMDIF(1,3),TIMDIF(1,1),NLINE,YPOS,2) 578 - * Generate a cluster size. 1 767 P=SIGNAL D=SIGTHR 7 PAGE1202 579 - CALL HISRAD(CLSDIS,NCLS,0.0D0,1.0D0,CLSRND) 580 - * And generate the correponding number of arrival times. 581 - DO 620 ICLS=1,INT(CLSRND) 582 - IF(NPART.GE.MXCLUS*MXPAIR)THEN 583 - PRINT *,' !!!!!! SIGTHR WARNING : Too many particles', 584 - - ' have been generated on a track in' 585 - PRINT *,' the MC check,', 586 - - ' the track is left out of the histograms.' 587 - GOTO 640 588 - ENDIF 589 - NPART=NPART+1 590 - ARRTIM(NPART)=RNDNOR(TIMRND,SIGRND) 591 - * Enter this arrival time in the global histogram. 592 - IND=1+INT(REAL(NCHA)*(ARRTIM(NPART)-TMIN)/(TMAX-TMIN)) 593 - IF(IND.LT.1)THEN 594 - CONT2(0)=CONT2(0)+1 595 - ELSEIF(IND.GT.NCHA)THEN 596 - CONT2(NCHA+1)=CONT2(NCHA+1)+1 597 - ELSE 598 - CONT2(IND)=CONT2(IND)+1 599 - NENTR2=NENTR2+1 600 - ENDIF 601 - 620 CONTINUE 602 - ** Perform a new distance cycle. 603 - GOTO 610 604 - ** End of the track generating loops, now sort the arrival times. 605 - 630 CONTINUE 606 - ** Find the M'th particle to arrive and enter in a histogram. 607 - IF(M.GT.NPART.OR.NPART.EQ.0)THEN 608 - IND=0 609 - NENTR1=NENTR1+1 610 - ELSE 611 - CALL FLPSOR(ARRTIM,NPART) 612 - IND=1+INT(REAL(NCHA)*(ARRTIM(M)-TMIN)/(TMAX-TMIN)) 613 - ENDIF 614 - IF(IND.LE.0)THEN 615 - CONT1(0)=CONT1(0)+1 616 - ELSEIF(IND.GT.NCHA)THEN 617 - CONT1(NCHA+1)=CONT1(NCHA+1) 618 - ELSE 619 - CONT1(IND)=CONT1(IND)+1 620 - NENTR1=NENTR1+1 621 - ENDIF 622 - * Proceed with the next random cycle. 623 - 640 CONTINUE 624 - * Scale the curve to a unity surface. 625 - DO 660 ISCL=1,NCHA 626 - CONT1(ISCL)=CONT1(ISCL)*REAL(NCHA)/(NENTR1*(TMAX-TMIN)) 627 - 660 CONTINUE 628 - * Plot the curve. 629 - CALL GRHIST(CONT1,NCHA,TMIN,TMAX, 630 - - 'Arrival time [microsec]',TITLE,.TRUE.) 631 - CALL GRALOG('Cluster size distribution (Monte-Carlo).') 632 - IF(.NOT.LANTHR)CALL GRNEXT 633 - ENDIF 634 - ** Perform the calculation analytically, if requested. 635 - IF(LANTHR)THEN 636 - * Preset the electron origin probabilities CMIK. 637 - CALL SIGTH1(M,IFAIL) 638 - IF(IFAIL.NE.0)GOTO 890 639 - * Preset the output distribution to 0. 640 - DO 800 IFM=1,MXLIST 641 - FM(IFM)=0 642 - 800 CONTINUE 643 - * Loop over the clusters. 644 - DO 810 K=1,NCMAX 645 - * Set the fetch flag to 0, i.e. not yet fetched. 646 - IFETCH=0 647 - * Loop over the total number of electrons in the cluster. 648 - DO 820 NELEC=1,NCSMAX 649 - IF(PRSIZE(NELEC).LT.1.0E-10)GOTO 820 650 - * Loop over the electrons inside the cluster. 651 - DO 830 IELEC=1,NELEC 652 - * See whether this combination of K and IELEC contributes. 653 - IF(CMIK(IELEC,K).LT.1.0E-10)GOTO 830 654 - WRITE(*,'('' contribution from I='',I3,'', N='',I3, 655 - - '', M='',I3,'', K='',I3)') IELEC,NELEC,M,K 656 - * Fetch the arrival time distribution of the K'th cluster. 657 - IF(IFETCH.EQ.0)THEN 658 - CALL SIGTH6('READ',FK,K,IFAIL) 659 - IF(IFAIL.NE.0)THEN 660 - PRINT *,' !!!!!! SIGTHR WARNING : This wire', 661 - - ' is skipped for the analytic part.' 662 - GOTO 890 663 - ENDIF 664 - IFETCH=1 665 - ENDIF 666 - * Extract the IELEC'th electron out of NELEC from FK. 667 - CALL SIGTH5(FK,NELEC,IELEC,FAUX) 668 - * Add this contribution to FM with the relevant factors. 669 - DO 840 IFM=1,MXLIST 670 - FM(IFM)=FM(IFM)+PRSIZE(NELEC)*CMIK(IELEC,K)*FAUX(IFM) 671 - 840 CONTINUE 672 - * Next electron from this cluster. 673 - 830 CONTINUE 674 - * Next number of electrons in the cluster. 675 - 820 CONTINUE 676 - * Next cluster to arrive. 677 - 810 CONTINUE 678 - * Plot the curve. 679 - IF(.NOT.LMCCHK)THEN 680 - CALL GRGRPH(TIMSCL,FM,MXLIST, 681 - - ' Arrival time [microsec]', 682 - - ' Probability', 683 - - TITLE) 684 - CALL GRALOG('Arrival time distribution (analytic). ') 1 767 P=SIGNAL D=SIGTHR 8 PAGE1203 685 - CALL GRNEXT 686 - ENDIF 687 - * Overlayed plots (also error exit). 688 - 890 CONTINUE 689 - IF(LMCCHK)THEN 690 - CALL GRATTS('FUNCTION-2','POLYLINE') 691 - CALL GPL(MXLIST,TIMSCL,FM) 692 - CALL GRALOG('Arrival time distribution (MC + anal). ') 693 - CALL GRNEXT 694 - ENDIF 695 - ENDIF 696 - ** Proceed with the electron arriving next globally (M). 697 - 700 CONTINUE 698 - ** Output the over-all arrival time histogram. 699 - IF(LDEBUG.AND.LMCCHK)THEN 700 - DO 710 ISCL=1,NCHA 701 - CONT2(ISCL)=CONT2(ISCL)*REAL(NCHA)/(NENTR2*(TMAX-TMIN)) 702 - 710 CONTINUE 703 - CALL GRHIST(CONT2,NCHA,TMIN,TMAX, 704 - - 'Arrival time [microsec]', 705 - - 'OVER-ALL ARRIVAL TIME DISTRIBUTION',.TRUE.) 706 - ENDIF 707 - * Perhaps overlay this histogram with the calculated distribution. 708 - IF(LDEBUG.AND.LANTHR)THEN 709 - IF(LMCCHK)THEN 710 - CALL GRATTS('FUNCTION-1','POLYLINE') 711 - CALL GPL(MXLIST,TIMSCL,FGLOB) 712 - ELSE 713 - CALL GRGRPH(TIMSCL,FGLOB,MXLIST, 714 - - ' Arrival time [microsec]', 715 - - ' Probability', 716 - - 'OVER-ALL ARRIVAL TIME DISTRIBUTION ') 717 - ENDIF 718 - ENDIF 719 - * Log the plot and move to the next frame, if it has been made. 720 - IF(LDEBUG.AND.(LMCCHK.OR.LANTHR))THEN 721 - CALL GRALOG('Over-all arrival time distribution. ') 722 - CALL GRNEXT 723 - ENDIF 724 - *** Close the dataset for FK. 725 - IF(LANTHR)CALL SIGTH6('CLOSE',FK,0,IFAIL) 726 - *** Proceed with the next wire. 727 - 1000 CONTINUE 728 - *** Register the amount of CPU time used by this routine. 729 - CALL TIMLOG('Calculating thresholds: ') 730 - END 768 GARFIELD ================================================== P=SIGNAL D=SIGTH1 1 ============================ 0 + +DECK,SIGTH1,IF=NEVER. 1 - SUBROUTINE SIGTH1(M,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGTH1 - Auxilliary routine to SIGTHR storing the matrix CMK and 4 - * various other variables in /THRDAT/. 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,GASDATA. 8.- +SEQ,THRESHDATA. 9.- +SEQ,PRINTPLOT. 10 - REAL PROB(2,0:MXCLUS*MXPAIR) 11 - *** Identify the routine, if requested. 12 - IF(LIDENT)PRINT *,' /// ROUTINE SIGTH1 ///' 13 - *** Preset IFAIL to 1, i.e. failure. 14 - IFAIL=1 15 - *** Preset the convoluted distribution. 16 - DO 10 I=0,MXPAIR*MXCLUS 17 - IF(I.EQ.0)THEN 18 - PROB(1,I)=1 19 - ELSE 20 - PROB(1,I)=0 21 - ENDIF 22 - PROB(2,I)=0 23 - 10 CONTINUE 24 - *** Preset the output array to zero. 25 - DO 30 I=1,MXPAIR 26 - DO 20 K=1,MXCLUS 27 - CMIK(I,K)=0 28 - 20 CONTINUE 29 - 30 CONTINUE 30 - *** And preset the largest and smallest non-zero value in PROB. 31 - NPRMIN=0 32 - NPRMAX=0 33 - *** Loop over the cluster sizes. 34 - DO 170 K=1,NCMAX 35 - * Loop over the electrons. 36 - DO 120 I=1,NCSMAX 37 - * Simple case that I > M, probability is 0. 38 - IF(I.GT.M)GOTO 120 39 - * Figure out what C(M,I,K) looks like in the other case. 40 - PSUM=0 41 - DO 100 J=I,NCSMAX 42 - PSUM=PSUM+PRSIZE(J) 43 - 100 CONTINUE 44 - CMIK(I,K)=PSUM*PROB(1,M-I) 45 - * Next electron. 46 - 120 CONTINUE 47 - * Skip convoluting in the last loop. 48 - IF(K.EQ.NCMAX)GOTO 170 49 - * Convolute once more. 50 - DO 140 I=0,MIN(NPRMAX+NCSMAX,MXCLUS*MXPAIR) 51 - PROB(2,I)=0 52 - DO 130 J=MAX(0,I-NPRMAX),MIN(I,NCSMAX,I-NPRMIN) 53 - PROB(2,I)=PROB(2,I)+PRSIZE(J)*PROB(1,I-J) 54 - 130 CONTINUE 55 - 140 CONTINUE 56 - * Move the convoluted distribution to PROB(1, ... ). 1 768 P=SIGNAL D=SIGTH1 2 PAGE1204 57 - NPRMIN=-1 58 - NPRMAX=-1 59 - PSUM=0 60 - DO 150 I=0,MXCLUS*MXPAIR 61 - PROB(1,I)=PROB(2,I) 62 - IF(PROB(1,I).GT.1.0E-10)THEN 63 - IF(NPRMIN.EQ.-1)NPRMIN=I 64 - NPRMAX=I 65 - ELSE 66 - PROB(1,I)=0.0 67 - ENDIF 68 - PSUM=PSUM+PROB(1,I) 69 - 150 CONTINUE 70 - * Check that some probability is left. 71 - IF(NPRMIN.EQ.-1.OR.NPRMAX.EQ.-1)THEN 72 - PRINT *,' !!!!!! SIGTH1 WARNING : Distribution vanished', 73 - - ' at convolution loop ',K,'.' 74 - RETURN 75 - ENDIF 76 - * And normalise the distribution again. 77 - IF(ABS(PSUM-1.0).GT.1.0E-5.AND.LDEBUG)PRINT *,' ++++++ SIGTH1', 78 - - ' DEBUG : Normalisation deviation, PSUM=',PSUM,'.' 79 - DO 160 INORM=0,MXPAIR*MXCLUS 80 - PROB(1,INORM)=PROB(1,INORM)/PSUM 81 - 160 CONTINUE 82 - * Next cluster size. 83 - 170 CONTINUE 84 - *** Convolution completed, set IFAIL to 0 and return. 85 - IFAIL=0 86 - END 769 GARFIELD ================================================== P=SIGNAL D=SIGTH3 1 ============================ 0 + +DECK,SIGTH3,IF=NEVER. 1 - SUBROUTINE SIGTH3(IW,MAXOPT,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGTH3 - Searches for the y segment at x=XTHR from where particles 4 - * reach the wire IW. 5 - *----------------------------------------------------------------------- 6.- +SEQ,DIMENSIONS. 7.- +SEQ,CELLDATA. 8.- +SEQ,GASDATA. 9.- +SEQ,DRIFTLINE. 10.- +SEQ,THRESHDATA. 11.- +SEQ,PRINTPLOT. 12.- +SEQ,CONSTANTS. 13.- +SEQ,PARAMETERS. 14 - LOGICAL CROSS 15 - EXTERNAL CROSS 16 - REAL XTHR,YTHR,QTHR 17 - *** Identify the routine if requested. 18 - IF(LIDENT)PRINT *,' /// ROUTINE SIGTH3 ///' 19 - *** Initialise the IFAIL flag to 1, i.e. failure. 20 - IFAIL=1 21 - *** Open a plot frame if the DRIFT-PLOT option is on. 22 - IF(LDRPLT)THEN 23 - CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, 24 - - 'SEARCH FOR THE ACCEPTANCE SEGMENT ') 25 - CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) 26 - IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) 27 - IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) 28 - ENDIF 29 - *** Start with a rather pessimistic guess of the y range. 30 - YTHMAX=Y(IW) 31 - YTHMIN=Y(IW) 32 - ICROSS=0 33 - QTHR=+1.0 34 - DO 20 IL=1,NLINED 35 - CALL DLCALC(X(IW)+0.51*D(IW)*COS(REAL(IL)*2.0*PI/REAL(NLINED)), 36 - - Y(IW)+0.51*D(IW)*SIN(REAL(IL)*2.0*PI/REAL(NLINED)),0.0, 37 - - QTHR,1) 38 - IF(NU.GT.2.AND.LDRPLT)CALL GPL2(NU,XU,YU) 39 - DO 10 IU=1,NU-1 40 - IF(CROSS(REAL(XU(IU)),REAL(YU(IU)),REAL(XU(IU+1)),REAL(YU(IU+1)), 41 - - XTHR,DYMIN,XTHR,DYMAX))THEN 42 - YTHMIN=MIN(REAL(MAX(YU(IU),YU(IU+1))),YTHMIN) 43 - YTHMAX=MAX(REAL(MIN(YU(IU),YU(IU+1))),YTHMAX) 44 - ICROSS=1 45 - ENDIF 46 - 10 CONTINUE 47 - 20 CONTINUE 48 - * Check the y-range is non-zero. 49 - IF(YTHMIN.GE.YTHMAX.OR.ICROSS.EQ.0)THEN 50 - IF(LDRPLT)THEN 51 - CALL GRNEXT 52 - CALL GRALOG('Failed search for the acceptance region.') 53 - ENDIF 54 - PRINT *,' !!!!!! SIGTH3 WARNING : x=',XTHR,' seems to be', 55 - - ' unreachable from wire ',IW,' ; the wire is skipped.' 56 - RETURN 57 - ENDIF 58 - * Debug output. 59 - IF(LDEBUG)PRINT *,' ++++++ SIGTH3 DEBUG : Raw y-range : ', 60 - - YTHMIN,YTHMAX 61 - *** Refine this estimate, first for the upper boundary. 62 - IF(LDEBUG)PRINT *,' ++++++ SIGTH3 DEBUG : Refinement of the', 63 - - ' upper bound of the y-range.' 64 - * Set the initial step size for the success-failure algorithm. 65 - STEP=MIN((YTHMAX-YTHMIN)/2.0,1.1*(DYMAX-YTHMAX)) 66 - * Set the charge for the normal drift-lines. 67 - QTHR=-1.0 68 - * Carry out at most MAXOPT refinement loops. 69 - ICONV=0 70 - DO 30 IOPT=1,MAXOPT 71 - YTHR=YTHMAX+STEP 72 - * Set a flag in case the point to be sampled lies outside the area. 1 769 P=SIGNAL D=SIGTH3 2 PAGE1205 73 - IF(YTHR.GT.DYMAX)THEN 74 - YTHR=DYMAX-(DYMAX-DYMIN)/1000.0 75 - IBOUND=1 76 - ELSE 77 - IBOUND=0 78 - ENDIF 79 - * Calculate a drift-line from the sample point. 80 - CALL DLCALC(XTHR,YTHR,0.0,QTHR,1) 81 - IF(NU.GT.2.AND.LDRPLT)CALL GPL2(NU,XU,YU) 82 - IF(LDEBUG)PRINT '('' ++++++ SIGTH3 DEBUG : IOPT='',I2, 83 - - '' y='',E12.5,'', ISTAT='',I4,'', NU='',I3,'', IBOUND='', 84 - - I1)',IOPT,YTHR,ISTAT,NU,IBOUND 85 - * Extra check of ISTAT if the boundary flag has been set. 86 - IF(IBOUND.EQ.1.AND.ISTAT.EQ.IW)THEN 87 - IF(LDEBUG)PRINT *,' ++++++ SIGTH3 DEBUG : The upper', 88 - - ' AREA boundary is satisfactory.' 89 - ICONV=1 90 - YTHMAX=YTHR 91 - GOTO 40 92 - ENDIF 93 - * Otherwise modify YTHMAX or STEP, depending on the status. 94 - IF(ISTAT.EQ.IW)THEN 95 - YTHMAX=YTHR 96 - ELSE 97 - ICONV=1 98 - ENDIF 99 - STEP=STEP/2.0 100 - 30 CONTINUE 101 - * Check the process has converged to some extent. 102 - 40 CONTINUE 103 - IF(ICONV.EQ.0.AND.MAXOPT.GT.0)THEN 104 - PRINT *,' !!!!!! SIGTH3 WARNING : The refinement process', 105 - - ' for the upper y bound failed; wire ',IW,' skipped.' 106 - IF(LDRPLT)THEN 107 - CALL GRNEXT 108 - CALL GRALOG('Failed search for the acceptance region.') 109 - ENDIF 110 - RETURN 111 - ENDIF 112 - *** Refine the estimate for the lower y boundary. 113 - IF(LDEBUG)PRINT *,' ++++++ SIGTH3 DEBUG : Refinement of the', 114 - - ' lower bound of the y-range.' 115 - * Set the initial step size for the success-failure algorithm. 116 - STEP=MIN((YTHMAX-YTHMIN)/2.0,1.1*(YTHMIN-DYMIN)) 117 - * Carry out at most MAXOPT refinement loops. 118 - ICONV=0 119 - DO 50 IOPT=1,MAXOPT 120 - YTHR=YTHMIN-STEP 121 - * Set a flag in case the point to be sampled lies outside the area. 122 - IF(YTHR.LT.DYMIN)THEN 123 - YTHR=DYMIN+(DYMAX-DYMIN)/1000.0 124 - IBOUND=1 125 - ELSE 126 - IBOUND=0 127 - ENDIF 128 - * Calculate a drift-line from the sample point. 129 - CALL DLCALC(XTHR,YTHR,0.0,QTHR,1) 130 - IF(NU.GT.2.AND.LDRPLT)CALL GPL2(NU,XU,YU) 131 - IF(LDEBUG)PRINT '('' ++++++ SIGTH3 DEBUG : IOPT='',I2, 132 - - '' y='',E12.5,'', ISTAT='',I4,'', NU='',I3,'', IBOUND='', 133 - - I1)',IOPT,YTHR,ISTAT,NU,IBOUND 134 - * Extra check of ISTAT if the boundary flag has been set. 135 - IF(IBOUND.EQ.1.AND.ISTAT.EQ.IW)THEN 136 - IF(LDEBUG)PRINT *,' ++++++ SIGTH3 DEBUG : The lower', 137 - - ' AREA boundary is satisfactory.' 138 - ICONV=1 139 - YTHMIN=YTHR 140 - GOTO 60 141 - ENDIF 142 - * Otherwise modify YTHMIN or STEP, depending on the status. 143 - IF(ISTAT.EQ.IW)THEN 144 - YTHMIN=YTHR 145 - ELSE 146 - ICONV=1 147 - ENDIF 148 - STEP=STEP/2.0 149 - 50 CONTINUE 150 - * Check the process has converged to some extent. 151 - 60 CONTINUE 152 - IF(ICONV.EQ.0.AND.MAXOPT.GT.0)THEN 153 - PRINT *,' !!!!!! SIGTH3 WARNING : The refinement process', 154 - - ' for the lower y bound failed; wire ',IW,' skipped.' 155 - IF(LDRPLT)THEN 156 - CALL GRNEXT 157 - CALL GRALOG('Failed search for the acceptance region.') 158 - ENDIF 159 - RETURN 160 - ENDIF 161 - *** Make the y-range a fraction smaller to avoid boundary problems. 162 - DY=YTHMAX-YTHMIN 163 - YTHMIN=YTHMIN+0.001*DY 164 - YTHMAX=YTHMAX-0.001*DY 165 - *** Debug output. 166 - IF(LDEBUG)PRINT *,' ++++++ SIGTH3 DEBUG : Refined y-range : ', 167 - - YTHMIN,YTHMAX 168 - *** Finish this plot, if plotting has been requested. 169 - IF(LDRPLT)THEN 170 - CALL GRNEXT 171 - CALL GRALOG('Searching the acceptance region. ') 172 - ENDIF 173 - *** Things apparently worked well. 174 - IFAIL=0 175 - END 1 770 GARFIELD ================================================== P=SIGNAL D=SIGTH4 1 =================== PAGE1206 0 + +DECK,SIGTH4,IF=NEVER. 1 - SUBROUTINE SIGTH4(IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGTH4 - Auxilliary routine to SIGTHR calculating the probability 4 - * that a given total number of clusters is formed and to 5 - * compute the cluster-size distribution. 6 - *----------------------------------------------------------------------- 7.- +SEQ,DIMENSIONS. 8.- +SEQ,THRESHDATA. 9.- +SEQ,GASDATA. 10.- +SEQ,CONSTANTS. 11.- +SEQ,PRINTPLOT. 12 - REAL XPL(MXLIST),YPL(MXLIST) 13 - *** Identify the routine if requested. 14 - IF(LIDENT)PRINT *,' /// ROUTINE SIGTH4 ///' 15 - *** Preset IFAIL to 1, i.e. fail. 16 - IFAIL=1 17 - *** Calculate the distribution of the number of clusters, debug output. 18 - IF(LDEBUG)PRINT *,' ++++++ SIGTH4 DEBUG : Mean number', 19 - - ' of clusters on the segment: ',CMEAN*(YTHMAX-YTHMIN) 20 - IF(CMEAN*(YTHMAX-YTHMIN).LT.50.0)THEN 21 - ** Use the Poisson distribution, if the number of particles is small. 22 - IF(LDEBUG)PRINT *,' ++++++ SIGTH4 DEBUG : The', 23 - - ' Poisson distribution is applied directly.' 24 - DO 20 N=0,MXCLUS 25 - PRCLUS(N)=EXP(-CMEAN*(YTHMAX-YTHMIN)) 26 - DO 10 M=1,N 27 - IF(REAL(M).GT.CMEAN*(YTHMAX-YTHMIN).AND. 28 - - PRCLUS(N).LT.1.0E-10)THEN 29 - PRCLUS(N)=0.0 30 - GOTO 20 31 - ENDIF 32 - PRCLUS(N)=PRCLUS(N)*CMEAN*(YTHMAX-YTHMIN)/FLOAT(M) 33 - 10 CONTINUE 34 - 20 CONTINUE 35 - ELSE 36 - ** Use the Gaussian approximation instead if there are many particles. 37 - IF(LDEBUG)PRINT *,' ++++++ SIGTH4 DEBUG : The', 38 - - ' Gaussian approximation is used.' 39 - DO 30 N=0,MXCLUS 40 - ARG=0.5*(REAL(N)-CMEAN*(YTHMAX-YTHMIN))**2/ 41 - - (CMEAN*(YTHMAX-YTHMIN)) 42 - IF(ARG.LT.50.0)THEN 43 - PRCLUS(N)=EXP(-ARG)/SQRT(2*PI*CMEAN*(YTHMAX-YTHMIN)) 44 - ELSE 45 - PRCLUS(N)=0.0 46 - ENDIF 47 - 30 CONTINUE 48 - ENDIF 49 - ** Find out in which range this distribution is effectively non-zero. 50 - NCMIN=-1 51 - NCMAX=-1 52 - PSUM=0.0 53 - DO 40 I=0,MXCLUS 54 - IF(PRCLUS(I).GT.1.0E-10)THEN 55 - IF(NCMIN.EQ.-1)NCMIN=I 56 - NCMAX=I 57 - ENDIF 58 - PSUM=PSUM+PRCLUS(I) 59 - 40 CONTINUE 60 - * Check whether there are non-zero values. 61 - IF(NCMIN.EQ.-1.OR.NCMAX.EQ.-1)THEN 62 - PRINT *,' !!!!!! SIGTH4 WARNING : The particle number', 63 - - ' distribution is flat; the wire is skipped.' 64 - IFAIL=1 65 - RETURN 66 - ENDIF 67 - * Warn if the integral differs significantly from 1. 68 - IF(ABS(PSUM-1.0).GT.1.0E-4)THEN 69 - PRINT *,' !!!!!! SIGTH4 WARNING : The distribution of the', 70 - - ' number of clusters doesn''t integrate to 1.' 71 - PRINT *,' (Integral=',PSUM,')', 72 - - ' increasing MXCLUS might help.' 73 - ENDIF 74 - ** Debugging output. 75 - IF(.FALSE..AND.LDEBUG)THEN 76 - * Print the range of the distribution. 77 - WRITE(*,'('' ++++++ SIGTH4 DEBUG : Effective range'', 78 - - '' particle number distr: '',I3,'' to '',I3)') 79 - - NCMIN,NCMAX 80 - * And plot the distribution. 81 - NPL=0 82 - DO 50 I=NCMIN,NCMAX 83 - IF(NPL.LT.MXLIST)THEN 84 - NPL=NPL+1 85 - XPL(NPL)=I 86 - YPL(NPL)=PRCLUS(I) 87 - ENDIF 88 - 50 CONTINUE 89 - CALL GRGRPH(XPL,YPL,NPL, 90 - - ' Number of clusters', 91 - - ' Probability', 92 - - 'DISTRIBUTION OF THE NUMBER OF CLUSTERS ') 93 - CALL GRALOG('Plot of the cluster number probabilities') 94 - CALL GRNEXT 95 - ENDIF 96 - *** Set the cluster-size probabilities. 97 - NCSMAX=-1 98 - PSUM=0 99 - DO 60 I=0,MXPAIR 100 - IF(I.EQ.0)THEN 101 - PRSIZE(0)=CLSDIS(1) 102 - ELSEIF(I.LT.NCLS)THEN 103 - PRSIZE(I)=CLSDIS(I+1)-CLSDIS(I) 104 - ELSE 105 - PRSIZE(I)=0.0 1 770 P=SIGNAL D=SIGTH4 2 PAGE1207 106 - ENDIF 107 - PSUM=PSUM+PRSIZE(I) 108 - IF(PRSIZE(I).GT.1.0E-10)NCSMAX=I 109 - 60 CONTINUE 110 - * Check that non-zero probabilities are present. 111 - IF(NCSMAX.EQ.-1)THEN 112 - PRINT *,' !!!!!! SIGTH4 WARNING : No non-zero cluster-size', 113 - - ' probabilities found.' 114 - RETURN 115 - ENDIF 116 - * Check that probabilities add up to 1. 117 - IF(ABS(PSUM-1.0).GT.1.0E-5)THEN 118 - PRINT *,' !!!!!! SIGTH4 WARNING : Total cluster-size', 119 - - ' probability ',PSUM 120 - RETURN 121 - ENDIF 122 - * Generate some debugging output. 123 - IF(LDEBUG)PRINT *,' ++++++ SIGTH4 DEBUG : Maximum', 124 - - ' cluster-size contributing: ',NCSMAX 125 - *** Apparently things worked well. 126 - IFAIL=0 127 - END 771 GARFIELD ================================================== P=SIGNAL D=SIGTH5 1 ============================ 0 + +DECK,SIGTH5,IF=NEVER. 1 - SUBROUTINE SIGTH5(FALL,N,K,FNK) 2 - *----------------------------------------------------------------------- 3 - * SIGTH5 - Auxiliary routine tyo SIGTHR extracting the K'th electron 4 - * from a distribution of N electrons. The relevant formulae 5 - * are explained in the writeup. 6 - * VARIABLES : FALL : The over-all distribution 7 - * FNK : The distribution of electron K out of N. 8 - * SUMLOW : Integral over FALL from -inf to t. 9 - * SUMUP : Integral over FALL from t to +inf. 10 - *----------------------------------------------------------------------- 11.- +SEQ,DIMENSIONS. 12.- +SEQ,THRESHDATA. 13 - EXTERNAL KBINOM 14 - REAL FALL(MXLIST),FNK(MXLIST) 15 - *** Loop over all points in the distribution. 16 - DO 30 I=1,MXLIST 17 - * Initialise with the K * (N over K) * F overall part. 18 - FNK(I)=FALL(I)*REAL(K)*KBINOM(N,K) 19 - * Approximate the F- integral. 20 - IF(K.GT.1)THEN 21 - SUMLOW=FALL(I)/2.0 22 - DO 10 J=1,I-1 23 - SUMLOW=SUMLOW+FALL(J) 24 - 10 CONTINUE 25 - SUMLOW=SUMLOW*(TMAX-TMIN)/REAL(MXLIST-1) 26 - IF(SUMLOW.LE.0.0)THEN 27 - FNK(I)=0.0 28 - ELSEIF(LOG10(SUMLOW)*REAL(K-1).LT.-25.0)THEN 29 - FNK(I)=0.0 30 - ELSE 31 - FNK(I)=FNK(I)*SUMLOW**(K-1) 32 - ENDIF 33 - ENDIF 34 - * Approximate the F+ integral. 35 - IF(N.GT.K)THEN 36 - SUMUP=FALL(I)/2.0 37 - DO 20 J=I+1,MXLIST 38 - SUMUP=SUMUP+FALL(J) 39 - 20 CONTINUE 40 - SUMUP=SUMUP*(TMAX-TMIN)/REAL(MXLIST-1) 41 - IF(SUMUP.LE.0.0)THEN 42 - FNK(I)=0.0 43 - ELSEIF(LOG10(SUMUP)*REAL(N-K).LT.-25.0)THEN 44 - FNK(I)=0.0 45 - ELSE 46 - FNK(I)=FNK(I)*SUMUP**(N-K) 47 - ENDIF 48 - ENDIF 49 - * Next data-point. 50 - 30 CONTINUE 51 - END 772 GARFIELD ================================================== P=SIGNAL D=SIGTH6 1 ============================ 0 + +DECK,SIGTH6,IF=NEVER. 1 - SUBROUTINE SIGTH6(ACTION,DIST,NUMBER,IFAIL) 2 - *----------------------------------------------------------------------- 3 - * SIGTH5 - Auxilliary routine to SIGTHR handling an auxiliary file on 4 - * unit 15 storing probability distributions. 5 - * compute the cluster-size distribution. 6 - * VARIABLES : ACTION : Dataset operation to be performed. 7 - * DIST : The distribution to be written/read. 8 - * NUMBER : Reference number for the distribution. 9 - * OPEN : Keeps track of the unit status. 10 - * OPENED : Used with INQUIRE to find the unit status. 11 - *----------------------------------------------------------------------- 12.- +SEQ,DIMENSIONS. 13.- +SEQ,PRINTPLOT. 14 - REAL DIST(MXLIST) 15 - CHARACTER*(*) ACTION 16 - LOGICAL OPEN,OPENED 0 17-+ +SELF,IF=CMS. 18 - CHARACTER*80 FILDEF 0 19-+ +SELF,IF=SAVE. 20 - SAVE OPEN 1 772 P=SIGNAL D=SIGTH6 2 PAGE1208 21-+ +SELF. 22 - DATA OPEN /.FALSE./ 23 - *** Identify the routine if requested. 24 - IF(LIDENT)PRINT *,' /// ROUTINE SIGTH6 ///' 25 - *** Initialise IFAIL to 1, i.e. fail. 26 - IFAIL=1 27 - *** Open the dataset if ACTION='OPEN'. 28 - IF(ACTION.EQ.'OPEN')THEN 29 - * Check that the maximum record-length will not be exceeded. 30 - IF(4+MXLIST*4.GT.MXRECL)THEN 31 - PRINT *,' ###### SIGTH6 ERROR : Unable to allocate', 32 - - ' storage space ; increase MXRECL' 33 - PRINT *,' or decrease MXLIST', 34 - - ' such that MXRECL > 4 + 4*MXLIST.' 35 - RETURN 36 - ENDIF 37 - * Check that the dataset is not already opened. 38 - INQUIRE(UNIT=15,OPENED=OPENED) 39 - IF(OPENED)THEN 40 - PRINT *,' !!!!!! SIGTH6 WARNING : Unit 15 is open', 41 - - ' while it should be closed ; attempt to close.' 42 - CLOSE(UNIT=15,IOSTAT=IOS,ERR=2030) 43 - ENDIF 44 - * Open the dataset. 0 45-+ +SELF,IF=CMS. 46 - WRITE(FILDEF,'(''FILEDEF 15 DISK GARFTEMP THRESH A6'', 47 - - '' (CHANGE XTENT '',I4)') MXLIST 48 - CALL VMCMS(FILDEF,IRC) 49 - IF(IRC.NE.0)THEN 50 - PRINT *,' !!!!!! SIGTH6 WARNING : Error issuing a', 51 - - ' FILEDEF for the threshold dataset.' 52 - GOTO 2020 53 - ENDIF 0 54-+ +SELF. 55 - OPEN(UNIT=15,STATUS='SCRATCH',ACCESS='DIRECT', 56 - - RECL=4+MXLIST*4,FORM='UNFORMATTED',IOSTAT=IOS,ERR=2020) 57 - IF(LDEBUG)PRINT *,' ++++++ SIGTH6 DEBUG : Dataset opened', 58 - - ' on unit 15 with RECL=',4+MXLIST*4 59 - * Keep track of opening. 60 - OPEN=.TRUE. 61 - *** Close the dataset if ACTION='CLOSE'. 62 - ELSEIF(ACTION.EQ.'CLOSE')THEN 63 - * Check that the dataset is really opened. 64 - INQUIRE(UNIT=15,OPENED=OPENED) 65 - * And close if it is, otherwise print an error message. 66 - IF(OPENED)THEN 67 - CLOSE(UNIT=15,IOSTAT=IOS,ERR=2030) 68 - IF(LDEBUG)PRINT *,' ++++++ SIGTH6 DEBUG : Dataset', 69 - - ' on unit 15 has been closed.' 70 - ELSE 71 - PRINT *,' !!!!!! SIGTH6 WARNING : Unit 15 is already', 72 - - ' closed ; program bug - please report.' 73 - ENDIF 74 - OPEN=.FALSE. 75 - *** Write the record if ACTION='WRITE'. 76 - ELSEIF(ACTION.EQ.'WRITE')THEN 77 - * Check the reference number. 78 - IF(NUMBER.LT.1.OR.NUMBER.GT.1000)THEN 79 - PRINT *,' ###### SIGTH6 ERROR : Record reference', 80 - - ' number (',NUMBER,') out of range ; program bug.' 81 - RETURN 82 - * Check the dataset status. 83 - ELSEIF(.NOT.OPEN)THEN 84 - PRINT *,' ###### SIGTH6 ERROR : No dataset has been', 85 - - ' opened ; program bug - please report.' 86 - RETURN 87 - ENDIF 88 - * Perform the write operation. 89 - WRITE(UNIT=15,REC=NUMBER,IOSTAT=IOS,ERR=2010) DIST 90 - *** Retrieve the record if ACTION='READ'. 91 - ELSEIF(ACTION.EQ.'READ')THEN 92 - * Check the reference number. 93 - IF(NUMBER.LT.1.OR.NUMBER.GT.1000)THEN 94 - PRINT *,' ###### SIGTH6 ERROR : Record reference', 95 - - ' number (',NUMBER,') out of range ; program bug.' 96 - RETURN 97 - * Check the dataset status. 98 - ELSEIF(.NOT.OPEN)THEN 99 - PRINT *,' ###### SIGTH6 ERROR : No dataset has been', 100 - - ' opened ; program bug - please report.' 101 - RETURN 102 - ENDIF 103 - * Preset the record to 0, in case of errors. 104 - DO 10 I=1,MXLIST 105 - DIST(I)=0 106 - 10 CONTINUE 107 - * Perform the read operation. 108 - READ(UNIT=15,REC=NUMBER,IOSTAT=IOS,ERR=2010) DIST 109 - *** Unknown instruction. 110 - ELSE 111 - PRINT *,' ###### SIGTH6 ERROR : Invalid instruction ', 112 - - ACTION,' received; program bug - please report.' 113 - RETURN 114 - ENDIF 115 - *** Apparently things worked. 116 - IFAIL=0 117 - RETURN 118 - *** Handle I/O problems. 119 - 2010 CONTINUE 120 - PRINT *,' !!!!!! SIGTH6 ERROR : I/O error on the dataset for'// 121 - - ' storing THRESHOLD probability distributions.' 122 - PRINT *,' Probably attempt to retrieve'// 123 - - ' a non-existing record.' 124 - CALL INPIOS(IOS) 1 772 P=SIGNAL D=SIGTH6 3 PAGE1209 125 - RETURN 126 - 2020 CONTINUE 127 - PRINT *,' !!!!!! SIGTH6 ERROR : Unable to open a dataset for'// 128 - - ' storing THRESHOLD probability distributions on unit 15.' 129 - CALL INPIOS(IOS) 130 - RETURN 131 - 2030 CONTINUE 132 - PRINT *,' !!!!!! SIGTH6 ERROR : Unable to close a dataset for', 133 - - ' storing THRESHOLD probability distributions on unit 15.' 134 - CALL INPIOS(IOS) 135 - RETURN 136 - END 773 GARFIELD ================================================== P=AUXILIAR D= 1 ============================ 0 + +PATCH,AUXILIARY,T=DATA. 774 GARFIELD ================================================== P=AUXILIAR D=CLD 1 ============================ 0 + +DECK,CLD,IF=VAX. 0 1-+ +SELF,IF=FRONTEND. 2 - DECK ID>, GARFRUNCLD.CLD 0 3-+ +SELF,IF=-FRONTEND. 4 - DECK ID>, GARFIELDCLD.CLD 0 5-+ +SELF. 6 - !==============================================================================! 7 - ! Garfield command language definition file for Vax computers. ! 8 - ! Valid for versions 5.12 and higher, can be used with version 4. ! 9 - ! Since version 5.12, there is one common CLD file for all graphics systems. ! 10 - ! ! 11 - ! This file is to be compiled with the command: ! 12 - ! ! 13 - ! SET COMMAND GARFIELDCLD.CLD /OBJECT=GARFIELDCLD.OBJ ! 14 - ! ! 15 - ! and should then be linked with the main program and with the front-end ! 16 - ! program. ! 17 - ! ! 18 - ! The advice from Bert Driehuis /VNG and C.W. Hobbs /DEC is gratefully ! 19 - ! acknowledged. ! 20 - ! ! 21 - ! Gopyright: Rob Veenhof, 2000. ! 22 - !==============================================================================! 23 - module GARFCLD 24 - 25 - define type TERMINAL_GTS 26 - keyword TYPE ! Terminal type chosen from list 27 - label=TERM_TYPE ! 28 - value(type=TERM_TYPE_GTS,required) ! 29 - keyword GKS_IDENTIFIER ! Terminal specified by identifier 30 - label=TERM_GKSID ! 31 - value(type=$number,required) ! 32 - keyword CONNECTION_IDENTIFIER ! Connection identifier 33 - label=TERM_CONID ! 34 - value(type=$number,required) ! 35 - 36 - define type TERM_TYPE_GTS 37 - ! Digital GTS-GRAL workstation 38 - keyword VT100_RETROGRAPHICS ! 1001 39 - keyword VT100_SELENAR ! 1002 40 - keyword VT125_REGIS ! 1010 41 - keyword VT240_REGIS ! 1020 42 - keyword VT241_REGIS ! 1021 43 - keyword VT340 ! 1030 44 - keyword VAXSTATION ! 8601 45 - ! Pericom 46 - keyword PG7800, default ! 7878 47 - keyword MG600 ! 7800 48 - keyword MX2000 ! 221 49 - keyword MX7000 ! 221 50 - keyword MX8000 ! 227 51 - ! Tektronix 52 - keyword 4010 ! 101 53 - keyword 4012 ! 102 54 - keyword 4014 ! 101 55 - keyword 4015 ! 103 56 - keyword 4105 ! 110 57 - keyword 4107 ! 121 58 - keyword 4207 ! 121 59 - keyword 4109 ! 122 60 - keyword 4209 ! 122 61 - keyword 4111 ! 123 62 - keyword 4113 ! 125 63 - keyword 4114 ! 127 64 - keyword 4115 ! 127 65 - ! Falco 66 - keyword Falco ! 114 67 - ! X-windows 68 - keyword X_windows ! 32120 69 - keyword X_windows_0 ! 32120 70 - keyword X_windows_1 ! 32121 71 - keyword X_windows_2 ! 32122 72 - keyword X_windows_3 ! 32123 73 - keyword X_windows_4 ! 32124 74 - keyword X_windows_5 ! 32125 75 - keyword X_windows_6 ! 32126 76 - keyword X_windows_7 ! 32127 77 - keyword X_windows_8 ! 32128 78 - keyword X_windows_9 ! 32129 79 - 80 - define type TERMINAL_DEC 81 - keyword TYPE ! Terminal type chosen from list 82 - label=TERM_TYPE ! 83 - value(type=TERM_TYPE_DEC,required) ! 1 774 P=AUXILIAR D=CLD 2 PAGE1210 84 - keyword GKS_IDENTIFIER ! Terminal specified by identifier 85 - label=TERM_GKSID ! 86 - value(type=$number,required) ! 87 - keyword CONNECTION_IDENTIFIER ! Connection identifier 88 - label=TERM_CONID ! 89 - value(type=$number,required) ! 90 - 91 - define type TERM_TYPE_DEC 92 - ! Logical DEC GKS workstation type 93 - keyword Logical ! 0 94 - ! Digital 95 - keyword VT125_COLOUR ! 11 96 - keyword VT125_BW ! 12 97 - keyword VT240_COLOUR ! 13 98 - keyword VT240_BW ! 14 99 - keyword VT330 ! 16 100 - keyword VT340 ! 17 101 - keyword VAXSTATION_1 ! 42 102 - keyword VAXSTATION_2 ! 41 103 - keyword VS_1 ! 42 104 - keyword VS_2 ! 41 105 - keyword VS_2000 ! 41 106 - keyword DECWINDOWS ! 211 107 - ! Tektronix 108 - keyword 4014 ! 72 109 - keyword 4017 ! 82 110 - 111 - define type TERMINAL_ATC 112 - keyword TYPE ! Terminal type chosen from list 113 - label=TERM_TYPE ! 114 - value(type=TERM_TYPE_ATC,required) ! 115 - keyword GKS_IDENTIFIER ! Terminal specified by identifier 116 - label=TERM_GKSID ! 117 - value(type=$number,required) ! 118 - keyword CONNECTION_IDENTIFIER ! Connection identifier 119 - label=TERM_CONID ! 120 - value(type=$number,required) ! 121 - 122 - define type TERM_TYPE_ATC 123 - ! Digital ATC_GKS workstation type 124 - keyword VT125_REGIS ! 2600 125 - keyword VT240_REGIS ! 2601 126 - keyword VT241_REGIS ! 2602 127 - keyword VT330 ! 2603 128 - keyword VT340 ! 2604 129 - keyword VT340_COLOUR ! 2605 130 - ! Tektronix 131 - keyword 4010 ! 2500 132 - keyword COMP_4010 ! 2501 133 - keyword 4014 ! 2400 134 - keyword 4105 ! 2300 135 - keyword PIX_4105 ! 2301 136 - keyword COMP_4105 ! 2302 137 - keyword 4107 ! 3100 138 - keyword 12B_4107 ! 3101 139 - keyword 4205 ! 3102 140 - keyword 12B_4205 ! 3103 141 - keyword 4208 ! 3104 142 - keyword 12B_4208 ! 3105 143 - keyword 4111 ! 3200 144 - keyword 32B_4111 ! 3201 145 - keyword 4115 ! 3202 146 - keyword 32B_4115 ! 3203 147 - keyword 4125 ! 3204 148 - keyword 32B_4125 ! 3205 149 - ! C-ITOH 414A 150 - keyword CIT_414A ! 2502 151 - ! Graphon 140, 230 152 - keyword GRAPHON ! 2506 153 - ! Imagen 154 - keyword LAND_IMG ! 6300 155 - keyword PORT_IMG ! 6301 156 - ! Retrographics VT640 157 - keyword RETRO ! 3203 158 - ! X11 159 - keyword X11 ! 5300 160 - ! X11 (back and store) 161 - keyword BS_X11 ! 5350 162 - 163 - define type TERMINAL_HIGZ 164 - keyword TYPE ! Terminal type chosen from list 165 - label=TERM_TYPE ! 166 - value(type=TERM_TYPE_HIGZ,required) ! 167 - keyword GKS_IDENTIFIER ! Terminal specified by identifier 168 - label=TERM_GKSID ! 169 - value(type=$number,required) ! 170 - keyword CONNECTION_IDENTIFIER ! Connection identifier 171 - label=TERM_CONID ! 172 - value(type=$number,required) ! 173 - 174 - define type TERM_TYPE_HIGZ 175 - keyword 0 ! No terminal graphics output 176 - keyword inquire, default ! Request terminal inquiry 177 - keyword 1 ! From HIGZ_WINDOWS.DAT 178 - keyword 2 ! From HIGZ_WINDOWS.DAT 179 - keyword 3 ! From HIGZ_WINDOWS.DAT 180 - keyword 4 ! From HIGZ_WINDOWS.DAT 181 - keyword 5 ! From HIGZ_WINDOWS.DAT 182 - keyword 6 ! From HIGZ_WINDOWS.DAT 183 - keyword 7 ! From HIGZ_WINDOWS.DAT 184 - keyword 8 ! From HIGZ_WINDOWS.DAT 185 - keyword 9 ! From HIGZ_WINDOWS.DAT 186 - keyword FALCO ! Falco terminal 187 - keyword XTERM ! X-terminal 188 - 189 - define type METAFILE_GTS 1 774 P=AUXILIAR D=CLD 3 PAGE1211 190 - keyword TYPE ! Metafile type chosen from list 191 - label=META_TYPE ! 192 - value(type=META_TYPE_GTS,required) ! 193 - keyword GKS_IDENTIFIER ! Metafile type via GKS identifier 194 - label=META_GKSID ! 195 - value(type=$number,required) ! 196 - keyword NAME ! File name of the metafile 197 - label=META_NAME ! 198 - value(type=$outfile,required) ! 199 - keyword OFFSET ! Logical unit offset 200 - label=META_OFFSET ! 201 - value(type=$number,required) ! 202 - 203 - define type META_TYPE_GTS 204 - keyword APPENDIX_E ! 4 205 - keyword POSTSCRIPT, default ! 12203 206 - keyword PS_PORTRAIT_COLOUR ! 12201 207 - keyword PS_LANDSCAPE_COLOUR ! 12202 208 - keyword PS_PORTRAIT_BW ! 12203 209 - keyword PS_LANDSCAPE_BW ! 12204 210 - keyword ENCAPSULATED_PS ! 12203 211 - keyword EPS_PORTRAIT_COLOUR ! 12201 212 - keyword EPS_LANDSCAPE_COLOUR ! 12202 213 - keyword EPS_PORTRAIT_BW ! 12203 214 - keyword EPS_LANDSCAPE_BW ! 12204 215 - 216 - define type METAFILE_DEC 217 - keyword TYPE ! Metafile type chosen from list 218 - label=META_TYPE ! 219 - value(type=META_TYPE_DEC,required) ! 220 - keyword GKS_IDENTIFIER ! Metafile type via GKS identifier 221 - label=META_GKSID ! 222 - value(type=$number,required) ! 223 - keyword NAME ! File name of the metafile 224 - label=META_NAME ! 225 - value(type=$outfile,required) ! 226 - keyword OFFSET ! Logical unit offset 227 - label=META_OFFSET ! 228 - value(type=$number,required) ! 229 - 230 - define type META_TYPE_DEC 231 - keyword POSTSCRIPT, default ! 61 232 - keyword PS ! 61 233 - keyword METAFILE ! 2 234 - keyword DECGKS_MO ! 2 235 - keyword CGM ! 7 236 - keyword LCP01 ! 15 237 - keyword LCG01 ! 15 238 - keyword LN03 ! 38 239 - ! Hewlett-Packard 240 - keyword HP7475 ! 51 241 - keyword HP7550 ! 53 242 - keyword HP7580 ! 54 243 - keyword HP7585 ! 56 244 - ! Canon 245 - keyword LBP8A2 ! 531 246 - ! Kyocera 247 - keyword L880 ! 532 248 - 249 - define type METAFILE_ATC 250 - keyword TYPE ! Metafile type chosen from list 251 - label=META_TYPE ! 252 - value(type=META_TYPE_ATC,required) ! 253 - keyword GKS_IDENTIFIER ! Metafile type via GKS identifier 254 - label=META_GKSID ! 255 - value(type=$number,required) ! 256 - keyword NAME ! File name of the metafile 257 - label=META_NAME ! 258 - value(type=$outfile,required) ! 259 - keyword OFFSET ! Logical unit offset 260 - label=META_OFFSET ! 261 - value(type=$number,required) ! 262 - 263 - define type META_TYPE_ATC 264 - keyword CGM_BIN ! 10100 265 - keyword CGM_MBIN ! 10101 266 - keyword CGM_CHAR ! 10110 267 - keyword CGM_TEXT ! 10120 268 - keyword CGM_LBIN ! 10150 269 - keyword CGM_LCHAR ! 10160 270 - keyword CGM_LTEXT ! 10170 271 - ! ATC Postscript 272 - keyword POSTSCRIPT, default ! 1900 273 - keyword PS_PORTRAIT_COLOUR ! 1900 274 - keyword PS_LANDSCAPE_COLOUR ! 1901 275 - keyword PS_PORTRAIT_BW ! 1900 276 - keyword PS_LANDSCAPE_BW ! 1901 277 - keyword ENCAPSULATED_PS ! 1900 278 - keyword EPS_PORTRAIT_COLOUR ! 1900 279 - keyword EPS_LANDSCAPE_COLOUR ! 1901 280 - keyword EPS_PORTRAIT_BW ! 1900 281 - keyword EPS_LANDSCAPE_BW ! 1901 282 - 283 - define type METAFILE_HIGZ 284 - keyword TYPE ! Metafile type chosen from list 285 - label=META_TYPE ! 286 - value(type=META_TYPE_HIGZ,required) ! 287 - keyword GKS_IDENTIFIER ! Metafile type via GKS identifier 288 - label=META_GKSID ! 289 - value(type=$number,required) ! 290 - keyword NAME ! File name of the metafile 291 - label=META_NAME ! 292 - value(type=$outfile,required) ! 293 - keyword OFFSET ! Logical unit offset 294 - label=META_OFFSET ! 295 - value(type=$number,required) ! 1 774 P=AUXILIAR D=CLD 4 PAGE1212 296 - 297 - define type META_TYPE_HIGZ 298 - keyword POSTSCRIPT, default ! PostScript 299 - keyword PS_LANDSCAPE ! 300 - keyword PS_PORTRAIT ! 301 - keyword EPS ! Encapsulated PS 302 - keyword ENCAPSULATED_PS ! 303 - keyword ENCAPSULATED_POSTSCRIPT ! 304 - keyword LATEX ! LaTeX 305 - 306 - define verb GARFIELD 307 - qualifier OLD 308 - placement=global 309 - nonnegatable 310 - qualifier PRO 311 - placement=global 312 - nonnegatable 313 - qualifier NEW 314 - placement=global 315 - nonnegatable 316 - qualifier EXP 317 - placement=global 318 - nonnegatable 319 - qualifier DEBUG 320 - placement=global 321 - negatable 322 - qualifier IDENTIFICATION 323 - placement=global 324 - negatable 325 - qualifier INPUT_LISTING 326 - placement=global 327 - negatable 328 - qualifier RNDM_INITIALISATION 329 - placement=global 330 - negatable 331 - default 332 - qualifier RECORDING 333 - placement=global 334 - negatable 335 - default 336 - qualifier PROGRESS_PRINT 337 - placement=global 338 - negatable 339 - default 340 - qualifier PROFILE 341 - placement=global 342 - negatable 343 - default 344 - qualifier SYNCHRONISE 345 - placement=global 346 - negatable 347 - disallow any2(GKS, GTS_GRAL, DEC_GKS, ATC_GKS, HIGZ) 348 - qualifier HIGZ 349 - placement=global 350 - syntax=GARFIELD_HIGZ 351 - default 352 - qualifier GKS 353 - placement=global 354 - syntax=GARFIELD_GTS 355 - qualifier GTS_GRAL 356 - placement=global 357 - syntax=GARFIELD_GTS 358 - qualifier DEC_GKS 359 - placement=global 360 - syntax=GARFIELD_DEC 361 - qualifier ATC_GKS 362 - placement=global 363 - syntax=GARFIELD_ATC 364 - 365 - define syntax GARFIELD_GTS 366 - qualifier OLD 367 - placement=global 368 - nonnegatable 369 - qualifier PRO 370 - placement=global 371 - nonnegatable 372 - qualifier NEW 373 - placement=global 374 - nonnegatable 375 - qualifier EXP 376 - placement=global 377 - nonnegatable 378 - qualifier DEBUG 379 - placement=global 380 - negatable 381 - qualifier IDENTIFICATION 382 - placement=global 383 - negatable 384 - qualifier INPUT_LISTING 385 - placement=global 386 - negatable 387 - qualifier RNDM_INITIALISATION 388 - placement=global 389 - negatable 390 - default 391 - qualifier RECORDING 392 - placement=global 393 - negatable 394 - default 395 - qualifier PROGRESS_PRINT 396 - placement=global 397 - negatable 398 - default 399 - qualifier PROFILE 400 - placement=global 401 - negatable 1 774 P=AUXILIAR D=CLD 5 PAGE1213 402 - default 403 - qualifier SYNCHRONISE 404 - placement=global 405 - negatable 406 - qualifier TERMINAL 407 - placement=global 408 - value(list,type=TERMINAL_GTS) 409 - negatable 410 - default 411 - qualifier METAFILE 412 - placement=global 413 - value(list,type=METAFILE_GTS) 414 - negatable 415 - default 416 - qualifier HIGZ 417 - qualifier GKS 418 - qualifier GTS_GRAL, default 419 - qualifier DEC_GKS 420 - qualifier ATC_GKS 421 - disallow(TERM_TYPE and (TERM_GKSID or TERM_CONID)) 422 - disallow(META_TYPE and (META_GKSID or META_OFFSET)) 423 - 424 - define syntax GARFIELD_DEC 425 - qualifier OLD 426 - placement=global 427 - nonnegatable 428 - qualifier PRO 429 - placement=global 430 - nonnegatable 431 - qualifier NEW 432 - placement=global 433 - nonnegatable 434 - qualifier EXP 435 - placement=global 436 - nonnegatable 437 - qualifier DEBUG 438 - placement=global 439 - negatable 440 - qualifier IDENTIFICATION 441 - placement=global 442 - negatable 443 - qualifier INPUT_LISTING 444 - placement=global 445 - negatable 446 - qualifier RNDM_INITIALISATION 447 - placement=global 448 - negatable 449 - default 450 - qualifier RECORDING 451 - placement=global 452 - negatable 453 - default 454 - qualifier PROGRESS_PRINT 455 - placement=global 456 - negatable 457 - default 458 - qualifier PROFILE 459 - placement=global 460 - negatable 461 - default 462 - qualifier SYNCHRONISE 463 - placement=global 464 - negatable 465 - qualifier TERMINAL 466 - placement=global 467 - value(list,type=TERMINAL_DEC) 468 - negatable 469 - default 470 - qualifier METAFILE 471 - placement=global 472 - value(list,type=METAFILE_DEC) 473 - negatable 474 - default 475 - qualifier HIGZ 476 - qualifier GKS 477 - qualifier GTS_GRAL 478 - qualifier DEC_GKS, default 479 - qualifier ATC_GKS 480 - disallow(TERM_TYPE and (TERM_GKSID or TERM_CONID)) 481 - disallow(META_TYPE and (META_GKSID or META_OFFSET)) 482 - 483 - define syntax GARFIELD_ATC 484 - qualifier OLD 485 - placement=global 486 - nonnegatable 487 - qualifier PRO 488 - placement=global 489 - nonnegatable 490 - qualifier NEW 491 - placement=global 492 - nonnegatable 493 - qualifier EXP 494 - placement=global 495 - nonnegatable 496 - qualifier DEBUG 497 - placement=global 498 - negatable 499 - qualifier IDENTIFICATION 500 - placement=global 501 - negatable 502 - qualifier INPUT_LISTING 503 - placement=global 504 - negatable 505 - qualifier RNDM_INITIALISATION 506 - placement=global 507 - negatable 1 774 P=AUXILIAR D=CLD 6 PAGE1214 508 - default 509 - qualifier RECORDING 510 - placement=global 511 - negatable 512 - default 513 - qualifier PROGRESS_PRINT 514 - placement=global 515 - negatable 516 - default 517 - qualifier PROFILE 518 - placement=global 519 - negatable 520 - default 521 - qualifier SYNCHRONISE 522 - placement=global 523 - negatable 524 - qualifier TERMINAL 525 - placement=global 526 - value(list,type=TERMINAL_ATC) 527 - negatable 528 - default 529 - qualifier METAFILE 530 - placement=global 531 - value(list,type=METAFILE_ATC) 532 - negatable 533 - default 534 - qualifier HIGZ 535 - qualifier GKS 536 - qualifier GTS_GRAL 537 - qualifier DEC_GKS 538 - qualifier ATC_GKS, default 539 - disallow(TERM_TYPE and (TERM_GKSID or TERM_CONID)) 540 - disallow(META_TYPE and (META_GKSID or META_OFFSET)) 541 - 542 - define syntax GARFIELD_HIGZ 543 - qualifier OLD 544 - placement=global 545 - nonnegatable 546 - qualifier PRO 547 - placement=global 548 - nonnegatable 549 - qualifier NEW 550 - placement=global 551 - nonnegatable 552 - qualifier EXP 553 - placement=global 554 - nonnegatable 555 - qualifier DEBUG 556 - placement=global 557 - negatable 558 - qualifier IDENTIFICATION 559 - placement=global 560 - negatable 561 - qualifier INPUT_LISTING 562 - placement=global 563 - negatable 564 - qualifier RNDM_INITIALISATION 565 - placement=global 566 - negatable 567 - default 568 - qualifier RECORDING 569 - placement=global 570 - negatable 571 - default 572 - qualifier PROGRESS_PRINT 573 - placement=global 574 - negatable 575 - default 576 - qualifier PROFILE 577 - placement=global 578 - negatable 579 - default 580 - qualifier SYNCHRONISE 581 - placement=global 582 - negatable 583 - qualifier TERMINAL 584 - placement=global 585 - value(list,type=TERMINAL_HIGZ) 586 - negatable 587 - default 588 - qualifier METAFILE 589 - placement=global 590 - value(list,type=METAFILE_HIGZ) 591 - negatable 592 - default 593 - qualifier HIGZ, default 594 - qualifier GKS 595 - qualifier GTS_GRAL 596 - qualifier DEC_GKS 597 - qualifier ATC_GKS 598 - disallow(TERM_TYPE and (TERM_GKSID or TERM_CONID)) 599 - disallow(META_TYPE and (META_GKSID or META_OFFSET)) 775 GARFIELD ================================================== P=AUXILIAR D=MANPAGE 1 ============================ 0 + +DECK,MANPAGE,IF=UNIX. 1 - DECK ID>, garfield.l 2 - .TH garfield 1 "97/02/05" "CERN Program Library" "Drift chamber simulation" 3 - .DS )H Cern Program Library 4 - .DS ]W garfield 5 - .SH NAME 6 - garfield \- Simulation of 2\-dimensional drift chambers 7 - .SH DESCRIPTION 8 - Garfield is a program for the detailed simulation of 2-dimensional wire 9 - chambers consisting of thin wires and equipotential planes. 10 - Its main use is in the area of field, drift\-line and signal 1 775 P=AUXILIAR D=MANPAGE 2 PAGE1215 11 - calculations as well as the electrostatic optimisation of a chamber. 12 - .sp 13 - Garfield provides a convenient interface to the Magboltz program of 14 - Steve Biagi which computes electron transport properties for nearly 15 - arbitrary gas mixtures. 16 - Also the Heed program of Igor Smirnov, which simulates ionisation of 17 - gas molecules due to particles traversing the chamber, is interfaced 18 - with Garfield. 19 - .sp 20 - Garfield is of the 'slow' Monte\-Carlo type in the sense that it never 21 - uses, e.g. to save CPU time, a poor approximation if a better 22 - approximation is known to the author. 23 - That is not to say that no efforts have been made to make the program 24 - reasonably fast. 25 - Rather, it's not a program normally used to accumulate large 26 - statistics of drift-chamber responses. 27 - .sp 28 - The program can be used both in batch and in interactive mode 29 - on Unix systems. 30 - The program has a comprehensive built-in help facility. 31 - .SH FORMAT 32 - Garfield is started by typing: 33 - .sp 34 - .nf 35 - .nj 36 - $ garfield [-terminal {type T | GKS_id G connection_id C} ] 37 - [-noterminal] 38 - [-metafile {type T | GKS_id G offset O name F} ] 39 - [-nometafile] 40 - [-nodebug | -debug] 41 - [-noidentification | -identification] 42 - [-RNDM_initialisation | -noRNDMinitialisation] 43 - [-recording | -norecording ] 44 - [-progress_print | -noprogress_print ] 45 - [-profile | noprofile ] 46 - .ju 47 - .fi 48 - .sp 49 - Case is significant for all arguments. 50 - .SH ARGUMENTS 51 - .fo 52 - .sp 53 - -debug 54 - .in 15 55 - Requests that debugging mode is initially on, that is, also during 56 - the initialisation phase. 57 - The information displayed is of hardly any use to the casual user. 58 - .sp 59 - By default debugging mode is initially off. 60 - .sp 61 - Debugging mode can be switched off and on at any time during program 62 - execution. 63 - .in 2 64 - .sp 65 - -identification 66 - .in 15 67 - Tracing information will be displayed from the start of program 68 - execution. 69 - The information displayed is of hardly any use to the casual user. 70 - .sp 71 - By default tracing is initially off. 72 - .sp 73 - Tracing can be switched off and on at any time during program 74 - execution. 75 - .in 2 76 - .sp 77 - -RNDM_initialisation 78 - .in 15 79 - This switch controls whether or not the random number generators 80 - are called a number of times (determined by the hour of the day) 81 - at the job initialisation phase. 82 - If switched off, instructions using Monte Carlo techniques will 83 - produce identical results in different runs. 84 - .sp 85 - By default the random number generators are initialised. 86 - .in 2 87 - .sp 88 - -recording 89 - .in 15 90 - Garfield usually records on a file the input entered from the terminal 91 - during an interactive run. 92 - Use -norecording to disable this feature. 93 - .in 2 94 - .sp 95 - -progress_print 96 - .in 15 97 - Some routines use considerable CPU time. 98 - This option enables you to follow their progress. 99 - .in 2 100 - .sp 101 - -profile 102 - .in 15 103 - By default, Garfield tries to read on startup a file called 104 - garfinit or .garfinit. 105 - Specify -noprofile if do not wish this to happen. 106 - .in 2 107 - .sp 108 - -terminal 109 - .in 15 110 - Specifies the kind of screen you're sitting behind. 111 - .sp 112 - When you run an executable linked with GKS or PHIGS, 113 - you can either specify the screen by the type, 114 - or by the GKS identifier and a suitable connection 115 - identifier of the workstation. 116 - The list of workstation types depends on the GKS with 1 775 P=AUXILIAR D=MANPAGE 3 PAGE1216 117 - which Garfield has been linked. 118 - .sp 119 - When you run an executable linked with HIGZ, you have 120 - to specify the screen by the type. 121 - The list of workstations types can be found in the 122 - HIGZ manual. 123 - .sp 124 - Note that you have to type the type in the proper case. 125 - You may abbreviate the string down to its shortest unambiguous form. 126 - .in 2 127 - .sp 128 - -noterminal 129 - .in 15 130 - Requests that no graphics be displayed on the terminal. 131 - .in 2 132 - .sp 133 - -metafile 134 - .in 15 135 - Requests a metafile to be written and specifies 136 - the format (e.g. PostScript, Appendix_E). 137 - .sp 138 - When you run an executable linked with GKS or PHIGS, 139 - you can either specify this by the type, or by the GKS identifier, 140 - the offset between the connection identifier and the logical unit 141 - of the metafile and the file name of the metafile. 142 - The list of workstation types depends on the GKS with which 143 - Garfield has been linked. 144 - .sp 145 - When you run an executable linked with HIGZ, 146 - you have to specify the screen by the type. 147 - The list of workstation types can be found in the HIGZ manual. 148 - .sp 149 - Note that you have to type the type in the proper case. 150 - You may abbreviate the string down to its shortest unambiguous form. 151 - .in 2 152 - .sp 153 - -nometafile 154 - .in 15 155 - Suppresses metafile output. 156 - .in 2 157 - .SH DOCUMENTATION 158 - An extensive printed manual exists which contains information about 159 - the program, instructions for compilation, input format, background 160 - of the model etc. It can be obtained from the CERN program library, 161 - from the author or from the person responsible locally for the 162 - program. The manual is frequently updated and you have to make sure 163 - yours is not more than, say, half a year old. 164 - The manual is also available via WWW: 165 - .B http://consult.cern.ch/writeup/garfield 166 - .sp 167 - Inside the program you can type HELP (or ?) at almost any time. The 168 - help facility gives detailed information about the instructions with 169 - examples. 170 - .SH CONDITIONS FOR USE 171 - Garfield is provided to you under the condition that it shall be 172 - used only for scientific purposes. 173 - The use of the program and its auxilliary files is free of charge. 174 - The program and associated files shall not be sold 175 - or otherwise made available to third parties without the consent 176 - of the author. The writeup and other parts of the documentation 177 - shall not be copied, reproduced other than for private use. 178 - .sp 179 - The author appreciates receiving a copy of any note, 180 - internal or published, for which Garfield has been used. 776 GARFIELD ================================================== P=AUXILIAR D=HELPCMS 1 ============================ 0 + +DECK,HELPCMS,IF=CMS. 1 - DECK ID>, GARFIELD.SHLPCMS 2 - .cm CAT: CMS 3 - .cm NAM: GARFIELD 4 - .cm EXP: Runs Garfield, a drift-chamber simulation program 5 - .cm DAT: 12/02/97 6 - .cm A/R: Rob Veenhof (Rob.Veenhof@cern.ch) 7 - .cm KEY: GARFIELD DRIFT-CHAMBER DRIFT CHAMBER SIMULATION FIELD POTENTIAL 8 - .cm KEY: ELECTROSTATICS CONTOUR VECTOR GAS DRIFT-LINE SIGNAL MAXWELL 9 - .cm KEY: OPTIMISATION CHARGE WIRE MWPC ISOCHRONY ISOCHRONOUS ISOCHRONE 10 - .cm KEY: TWO-DIMENSIONAL EQUIPOTENTIAL X(T)-RELATION X(T) X-T ARRIVAL 11 - .cm KEY: TIME ARRIVAL-TIME 2D NQS W5050 ELECTRON ION MAGBOLTZ MIX 12 - .cm KEY: MIXING ARGON HELIUM XENON KRYPTON ETHANE METHANE METHYLAL 13 - .cm KEY: NITROGEN WATER CO2 NEON ISOBUTANE PROPANE NEOPENTANE CF4 14 - .cm KEY: NO NO2 NITRIC NITROUS OXIDE CALIBRATION 15 - .cm KEY: FREON OXYGEN DME ETHENE ACETYLENE HEXAGON OCTAGON TRIANGLE 16 - .cm KEY: TUBE PRESSURE TEMPERATURE FORCE FORCES SAG DISPLACEMENT 17 - .cm KEY: HEED IONISATION ENERGY LOSS CLUSTER 18 - .cm ABS: This help file describes how to use Garfield on VM/CMS and 19 - .cm ABS: how to submit an NQS batch job from VM/CMS. Garfield is a 20 - .cm ABS: drift chamber simulation program, registered as item W5050 21 - .cm ABS: in the CERN program library and described in a long writeup 22 - .cm ABS: available from the CERN program library office. 23 - .cm ABS: 24 - .cm ABS: (Valid for Garfield version 7.04.) 25 - .cm WEB: http://consult.cern.ch/writeup/garfield 26 - .cm END: 27 - .cm Copyright: Rob Veenhof, 2001. 28 - .tr % 40 29 - GARFIELD 30 - .sp 31 - Note: the CMS version of this program has not been updated since 32 - October 1995. 33 - .sp 34 - Garfield tries to simulate drift-chambers made up of (thin) wires and 35 - infinite equipotential planes. 36 - The program can also handle sets of wires enclosed in round and 37 - polygonal tubes. 38 - The chambers may be periodic and magnetic fields can be taken into 1 776 P=AUXILIAR D=HELPCMS 2 PAGE1217 39 - account. 40 - The electrostatics of the program are inherently two dimensional. 41 - .sp 42 - For input, the program needs a listing of the wires, planes and 43 - periodicities (either in Cartesian or in polar coordinates) and 44 - a detailed description of the gas: ion mobility, 45 - electron drift velocity, diffusion coefficient(s), 46 - Townsend coefficient and attachment coefficient (as a function 47 - of the field strength) and also1 parameters related to the 48 - interaction with fast particles. 49 - .sp 50 - Descriptions for some commonly used gasses and gas mixtures 51 - are built into the program, and the electron transport properties 52 - of other gas mixtures can be computed via an interface with the 53 - Magboltz program. 54 - .sp 55 - Examples of tasks the program can carry out are: 56 - .of 2 57 - .sp 58 - *%Computing the field, the potential (and any function thereof) 59 - in the chamber and plotting it in a variety of ways: histogram, 60 - vector plot, contours, surface. 61 - Garfield can also output the field in the form of printed tables; 62 - .of 2 63 - .sp 64 - *%Computing transport properties in nearly arbitrary gas mixtures 65 - via a transparent interface to Magboltz; 66 - .of 2 67 - .sp 68 - *%Computing, plotting and tabulating of drift-lines of electrons 69 - and ions in the chamber; 70 - .of 2 71 - .sp 72 - *%Calculating arrival time spectra and space-time relations; 73 - .of 2 74 - .sp 75 - *%Simulation of the signal, effects which can be accounted for are: 76 - cluster formation, cluster size distribution, longitudinal and 77 - transversal diffusion, avalanche, current induced by moving ions. 78 - The program has also facilities to compute the arrival time 79 - distribution of the first, second etc. electron from a given track; 80 - .of 2 81 - .sp 82 - *%Electrostatic optimisation under various constraints such as 83 - homogenous drift-field, equal gain on various wires. 84 - .of 2 85 - .sp 86 - *%Computation of the force acting on a wire, and the displacement 87 - that results from it. 88 - .of 89 - .sp 90 - Garfield is a self-contained program and very little knowledge of VM/CMS 91 - is required to run it; no knowledge at all of programming languages is 92 - needed. 93 - The program has an extensive built-in help facility and is described in a 94 - writeup which is available from the program library office. 95 - .sp 96 - The program is available on several CERN central computers: VM/CMS, Vax 97 - and various Unix systems such as CSF. 98 - The program can be run on a remote Unix system via NQS from VM. 99 - Little use of machine specific features is made. 100 - .sp 101 - FORMAT: 102 - .sp 103 - The format for normal VM use and for job submission via NQS is: 104 - .sp 105 - .bx 1 79 106 - GARFIELD [input file] [/ output file] [(options] 107 - 108 - options: TERMINAL(TYPE type GKS_ID gksid CONNECTION_ID conid) 109 - NOTERMINAL 110 - METAFILE(TYPE type GKS_ID gksid OFFSET offset NAME name) 111 - NOMETAFILE 112 - GKS | HIGZ 113 - DISPLAY_NODE display 114 - NODEBUG | DEBUG 115 - NOIDENTIFICATION | IDENTIFICATION 116 - RNDM_INITIALISATION | NORNDM_INITIALISATION 117 - RECORDING | NORECORDING 118 - PFKEYS | NOPFKEYS | USERPFKEYS 119 - VM/CMS | NQS 120 - PRO | EXP | NEW | OLD 121 - SCALAR | VECTOR 122 - LIST | SET 123 - PANEL | NOPANEL 124 - TIME_LIMIT min[:sec] 125 - NQS_ACCOUNT nqs_userid 126 - NQS_SYSTEM nqs_system 127 - NQS_QUEUE nqs_queue 128 - RECIPIENT recipient 129 - PASSWORD password 130 - .bx off 131 - .sp 132 - The job is submitted in batch if an input file is given. 133 - An explicit BATCH SUBMIT should only be used in exceptional cases. 134 - .sp 135 - .of 20 136 - input%file%%%%%%%%%%The dataset from which Garfield is to read its input. 137 - The name should be specified in the usual VM/CMS format: fn%ft%fm. 138 - Equal signs (=) in the file name are replaced by the corresponding 139 - defaults. 140 - Initially, the file-type defaults to "INPUT", the file-mode to "*"; 141 - you are free to change these settings via DEFAULTS%SET%GARFIELD. 142 - .sp 143 - Garfield will be run in batch if you choose the first format 144 - and specify an input file. 1 776 P=AUXILIAR D=HELPCMS 3 PAGE1218 145 - The file will be sent to the batch machine at submission 146 - time; hence you can freely change it after submission. 147 - Garfield will be run interactively if this argument is omitted. 148 - .sp 149 - If you choose the second format, the job reads the input file if you 150 - specify one, otherwise it will look for GARFIELD%INPUT%* (or another 151 - default you may have defined). 152 - .sp 153 - .of 20 154 - output%file%%%%%%%%%The dataset to which Garfield writes its output. 155 - The name should be specified in the usual VM/CMS format: fn%ft, 156 - without file mode. 157 - .sp 158 - Equal signs (=) in the file name are replaced by the corresponding 159 - defaults, if these are also equal signs, the corresponding fields 160 - of the input file are used. 161 - .sp 162 - The initial default is "GARFIELD OUTPUT", this default can be changed 163 - with DEFAULTS%SET%GARFIELD. 164 - .sp 165 - .of 20 166 - type%%%%%%%%%%%%%%%%The type of graphics terminal or metafile that 167 - you wish to use. 168 - Examples of terminals are MG600 (for a Pericom Monterey), 4014 169 - (Tektronix) and PG7800 (Pericom). 170 - Known metafile types include APPENDIX_E, POSTSCRIPT and EPS. 171 - Please send a message to RJD@CERNVM if your favourite type 172 - is not recognised. 173 - .sp 174 - If you use the same type all the time, you may wish to make it 175 - the default. 176 - Use the DEFAULTS%SET%GARFIELD command for this purpose. 177 - The initial defaults are PG7800 (terminal) and POSTSCRIPT (metafile). 178 - .sp 179 - .of 20 180 - gksid%%%%%%%%%%%%%%%Workstations that are not known to Garfield can 181 - be accessed by specifying the GKS identifier of the driver, an 182 - appropriate connection identifier and perhaps a file name. 183 - .sp 184 - .of 20 185 - conid%%%%%%%%%%%%%%%This is the connection identifier of the 186 - workstation. 187 - This parameter depends on the kind of GKS you're using. 188 - .sp 189 - You need to specify this parameter only if you're using a workstation 190 - that is not known to Garfield. 191 - .sp 192 - .of 20 193 - offset%%%%%%%%%%%%%%In the case of a file oriented workstation, 194 - Garfield chooses the logical unit on which the file is opened but 195 - you have to specify the difference between the logical unit number 196 - and the connection identifier. 197 - .sp 198 - You need to specify this parameter only if you're using a workstation 199 - that is not known to Garfield. 200 - .sp 201 - .of 20 202 - name%%%%%%%%%%%%%%%%The name of the picture file. 203 - The file name should be specified in the format fn.ft.fm or fn.ft, 204 - the file type is compulsory. 205 - An equal sign may be used for the file name, to indicate that the 206 - name of the input file is to be used; an asterisk as file type 207 - will be replaced by 'METAFILE', 'PS' or 'EPS' as appropriate. 208 - .sp 209 - .of 20 210 - DEBUG%%%%%%%%%%%%%%%Requests debugging during the initialisation phase. 211 - In addition to switching on the DEBUG option inside the program, this 212 - enables printing of underflow, overflow and divide-by-zero messages 213 - during the entire program execution time. 214 - .sp 215 - .of 20 216 - GKS%%%%%%%%%%%%%%%%%Asks for a version of the program that has been 217 - linked with GKS. 218 - When using the GKS version, you may in addition specify the terminal 219 - and metafile type. 220 - This is currently the default. 221 - .sp 222 - .of 20 223 - HIGZ%%%%%%%%%%%%%%%%Asks for a version of the program that has been 224 - linked with HIGZ. 225 - When the HIGZ version is used, X-windows output is assumed and a 226 - PostScript file is generated automatically. 227 - The location of the workstation for X-windows output can be 228 - specified with DISPLAY_NODE. 229 - Currently, the default is GKS. 230 - .sp 231 - .of 20 232 - display%%%%%%%%%%%%%Tells HIGZ where it should send the X-windows 233 - output. 234 - This parameter can be given the value '*' in which case the currently 235 - set DISPLAY parameter will not be changed. 236 - .sp 237 - .of 20 238 - IDENTIFICATION%%%%%%Requests tracing output during the initialisation 239 - phase. 240 - .sp 241 - .of 20 242 - RNDM_INITIALISATION%To ensure the program produces different results 243 - in different runs using Monte-Carlo techniques (signal section), the 244 - random number generator is called a number of times (the number is 245 - derived from the time of the day) at the start of program execution. 246 - To suppress this initialisation, specify NORNDM_INITIALISATION. 247 - .sp 248 - .of 20 249 - RECORDING%%%%%%%%%%%All terminal input is recorded in a file if this 250 - option is specified. 1 776 P=AUXILIAR D=HELPCMS 4 PAGE1219 251 - This option is not meaningful and hence ignored in batch. 252 - .sp 253 - .of 20 254 - PFKEYS%%%%%%%%%%%%%%Sets the PF keys to section names in Garfield. 255 - They are reset on normal program termination. 256 - If you specify this option while setting defaults (SET option), you 257 - will be shown a further panel in which you can edit the PF key settings. 258 - The initial setting is as follows: 259 - .sp 260 - .fo off 261 - +------------+------------+-------------------+-----------+ 262 - | & Cell | & Gas | Retrieve forward | Interrupt | 263 - +------------+------------+-------------------+-----------+ 264 - | & Field | & Optimise | Retrieve backward | Clear | 265 - +------------+------------+-------------------+-----------+ 266 - | Help | & Drift | & Quit | | 267 - +------------+------------+-------------------+ Undefined | 268 - | & Signal | Subset | | 269 - +-------------------------+-------------------+-----------+ 270 - .fo on 271 - .sp 272 - .of 20 273 - USERPFKEYS%%%%%%%%%%Calls the USERPF EXEC to set the PF key 274 - definitions. 275 - When you choose this option, you can customise the PF key settings by 276 - making a private copy of the EXEC and applying the changes you wish. 277 - Choosing USERPF doesn't make you loose the PF key settings you may 278 - have entered as part of the Garfield defaults. 279 - The latter are simply not used when you select USERPF. 280 - The options PFKEYS and USERPFKEYS are mutually exclusive. 281 - .sp 282 - .of 20 283 - VM/CMS%%%%%%%%%%%%%%Requests VM/CMS processing, either interactively 284 - or in batch depending on the command format. 285 - This is the initial default. 286 - .sp 287 - .of 20 288 - NQS%%%%%%%%%%%%%%%%%Requests the job to be submitted via NQS to a 289 - remote host. 290 - When Garfield has finished, the output log file, the metafile and 291 - any file you have created during the job are returned to your reader. 292 - You have to specify the name of the remote system (see NQS_SYSTEM), 293 - a user-identifier on the remote system (see NQS_ACCOUNT), 294 - optionally also the queue on the remote system in which the job 295 - is to be run (see NQS_QUEUE) and optionally the VM user identifier 296 - to which the job output is to be sent back (see RECIPIENT). 297 - .sp 298 - .of 20 299 - PRO%%%%%%%%%%%%%%%%%Selects the current 'official' version. 300 - These files are not changed during a CERN program library update cycle 301 - unless major bugs are found. 302 - The printed writeup and the on-line help refer to this program. 303 - This is the default version. 304 - .sp 305 - .of 20 306 - EXP%%%%%%%%%%%%%%%%%Selects the experimental program version on the 307 - authors' disk. 308 - You are free to use if but keep in mind that your results may change 309 - from one run to another ! 310 - The disk is password protected - the password should be easy to 311 - guess for readers of the comics. 312 - .sp 313 - .of 20 314 - NEW%%%%%%%%%%%%%%%%%Selects the program which will become the default 315 - at the next major program library update. 316 - This program may not always be available; this version changes 317 - occasionally but it should be fairly stable on the whole. 318 - .sp 319 - .of 20 320 - OLD%%%%%%%%%%%%%%%%%Selects the previous PRO version of the program. 321 - It is provided for backwards compatibility purposes only. 322 - .sp 323 - .of 20 324 - SCALAR%%%%%%%%%%%%%%Takes the regular copy of the module. 325 - .sp 326 - .of 20 327 - VECTOR%%%%%%%%%%%%%%Computations on chambers with a very large number of 328 - wires (several thousands) require considerable storage and 329 - consume prohibitive amounts of CPU time. 330 - This options gives access to a module that runs (only) in VM/XA mode 331 - and makes effective use of the IBM 900 vector processors available 332 - at CERN. 333 - Running it, requires 99 Mbyte of storage and permission to use the 334 - vector facilities. 335 - The former is available in batch class V at CERN, the latter has to 336 - be obtained from the DD division. 337 - .sp 338 - The accuracy of computations with large numbers of wires has to be 339 - checked carefully, contact the author for more information. 340 - .sp 341 - .of 20 342 - LIST%%%%%%%%%%%%%%%%Displays the default values for the terminal type, 343 - the various run-time options, the program version 344 - and the three fields of the input file name. 345 - Garfield is not run if you select this option; furthermore, no other 346 - options should be specified along with LIST. 347 - Specifying this option is equivalent to DEFAULTS%LIST%GARFIELD. 348 - .sp 349 - .of 20 350 - SET%%%%%%%%%%%%%%%%%Allows you to change the default terminal type, 351 - the various run-time options, the program version 352 - and the three fields of the input file name. 353 - Garfield is not run if you select this option. 354 - Specifying this option is equivalent to DEFAULTS%SET%GARFIELD. 355 - .sp 356 - .of 20 1 776 P=AUXILIAR D=HELPCMS 5 PAGE1220 357 - PANEL%%%%%%%%%%%%%%%Requests that the defaults are entered via a panel. 358 - The IOS3270 facility must be available for this to work. 359 - .sp 360 - .of 20 361 - NOPANEL%%%%%%%%%%%%%Reads the options you specify and stores them as new 362 - defaults without displaying a panel. 363 - The default file name can not be changed this way. 364 - .sp 365 - .of 20 366 - min,%sec%%%%%%%%%%%%The maximum amount of time the job is allowed 367 - to run in the format min[:sec]. 368 - Example: TIME 10 means that the job can run for 10 minutes, 369 - type TIME 0:15 to have the job stopped after 15 seconds. 370 - Separate defaults for VM and NQS are remembered, both can be set 371 - via DEFAULTS%SET%GARFIELD. 372 - .sp 373 - .of 20 374 - nqs_system%%%%%%%%%%The remote system on which the job is to be run. 375 - This is by default csf. 376 - .sp 377 - .of 20 378 - nqs_userid%%%%%%%%%%The remote account to be used to run the job. 379 - .sp 380 - .of 20 381 - nqs_queue%%%%%%%%%%%The queue on the remote system in which the 382 - jobs is to be run. 383 - The queue is by default set to "any", meaning that the system is free 384 - to choose a class depending on the CPU time you request. 385 - .sp 386 - .of 20 387 - recipient%%%%%%%%%%%The user on VM who should receive the files 388 - left in the directory on the remote system when the job terminates. 389 - This is by default the account from which the job is submitted. 390 - .sp 391 - .of 20 392 - password%%%%%%%%%%%%The read password for the RJD 192 disk. 393 - This password is needed only if you wish to use the EXP version of 394 - the module on VM/CMS at CERN. 395 - .sp 396 - .of 397 - EXAMPLE 1: GETTING STARTED ON VM 398 - .sp 399 - .in 11 400 - Assume you have never used the program before and are sitting behind 401 - a VT100 Selenar terminal. 402 - The best thing to do then (apart from obtaining a copy of the printed 403 - manual) is to start the program interactively: 404 - .sp 405 - GARFIELD (TERM(TYPE VT100_SEL) 406 - .sp 407 - and to browse through the introductory part of the help file: 408 - .sp 409 - ? information 410 - .sp 411 - The getting started subtopic will give you some suggestions on what to 412 - do next. 413 - The help file is organised like on the Vax; to get out, hit the return 414 - key a couple of times until you see '(Main)' behind the prompt. 415 - To leave the program altogether, type: 416 - .sp 417 - &QUIT 418 - .sp 419 - You will probably quickly start to construct input files. 420 - They can easily be read-in when running interactively via the < command. 421 - You may also wish to have some paper output. 422 - Running in batch allows you to do that: one of the files you will find 423 - in your reader after the job has completed is called GARFIELD%METAFILE. 424 - After RECEIVEing this file on your disk, you can look at the metafile 425 - on a terminal with GKSTV or send it to a plotter using GRPLOT. 426 - .sp 427 - The command to send a job to VM batch is: 428 - .sp 429 - GARFIELD DC1 (VM 430 - .sp 431 - assuming the input is called DC1%INPUT, on any of the disks you are 432 - currently linked to. 433 - .sp 434 - .in 435 - EXAMPLE 2: SUBMITTING THE SAME JOB VIA NQS 436 - .sp 437 - .in 11 438 - The same input file is submitted via NQS with the command: 439 - .sp 440 - GARFIELD DC1 (NQS 441 - (You may be asked to provide a password or an access code.) 442 - .sp 443 - When you run frequently jobs in batch, you may find it convenient to 444 - set defaults - both for NQS submission and for VM/CMS: 445 - .sp 446 - DEFAULTS SET GARFIELD 447 - .sp 448 - Be sure to check the spelling and case of your NQS user identifier. 449 - You may also find it convenient to modify the CPU time limits. 450 - .sp 451 - .in 452 - EXAMPLE 3: USING DATASETS 453 - .sp 454 - .in 11 455 - You have made an input file called CHAMBER INPUT: 456 - .sp 457 - .bx 12 79 458 - & Cell 459 - If vax Then 460 - $ cop cernvm::[rjd]cell.garflib cell.garflib 461 - get cell.garflib DC1 462 - Elseif cms Then 1 776 P=AUXILIAR D=HELPCMS 6 PAGE1221 463 - get cell.garflib DC1 464 - Elseif cray Then 465 - $ fetch cell.garflib -t'fn=CELL,ft=GARFLIB' 466 - get "cell.garflib" DC1 467 - Else 468 - Say "No idea where to get the input ... bye." 469 - & Stop 470 - Endif 471 - & Field 472 - > field.print 473 - print ex,ey,e,v 474 - > 475 - 476 - & Stop 477 - .bx off 478 - .sp 479 - This input file is designed to run on VM/CMS, NQS and Vax without 480 - modification - only the job submission command differs. 481 - .sp 482 - The input file first reads, if running on the Cray, the file 483 - CELL%GARFLIB from your VM/CMS 191 disk and stores it on the Cray as 484 - cell.garflib in your working directory. 485 - The job then goes on to read a member from this file and 486 - writes a field map to a dataset. 487 - When the job completes, the cell library (which is unchanged but which 488 - might have been modified) and the field map are sent back to you along 489 - with the metafile and the normal job output. 490 - .in 491 - .sp 492 - REMARKS 493 - .sp 494 - .of 11 495 - Storage:%%%Garfield needs about 12 Mbyte of storage for the scalar 496 - module and 99 Mbyte for the vectorised module. 497 - A message will be printed if your machine is not big enough. 498 - .of 499 - .sp 500 - .of 11 501 - CPU%usage:%The program eats as much CPU time as the most famous cat on 502 - earth eats lasagne. 503 - .of 504 - .sp 505 - .of 11 506 - Batch%use:%When you submit Garfield for the first time, a file called 507 - GARFIELD%BATCHID is written on one of your RW disks, e.g. the A disk. 508 - Feel free to modify this file, but stick to the rules for 509 - such files: one line, 8 characters, at least the last 3 must be 510 - numeric. 511 - If Garfield encounters an invalid file, the file is removed and 512 - a file in default format is created instead. 777 GARFIELD ================================================== P=AUXILIAR D=GARFRUNM 1 ============================ 0 + +DECK,GARFRUNM,IF=VAX. 1 - DECK ID>, GARFRUNMSG.MSG 2 - .title Garfield user interface program error messages 3 - .ident 'Version 7.04' 4 - .facility Garfield, 1234 /prefix=Garfield_ 5 - .severity INFORMATION 6 - ARGLIST <+++ Argument list: !AS.> /fao_count=1 7 - LOGDEFINE <+++ Defining logical !AS as !AS.> /fao_count=2 8 - MACHINE <+++ Running on !AS.> /fao_count=1 9 - NOHELP /fao_count=1 10 - NOLSE /fao_count=1 11 - SYMDEFINE <+++ Defining symbol !AS as !AS.> /fao_count=2 12 - VERSION <+++ Going to call the !AS version.> /fao_count=1 13 - GRAPHICS <+++ Assuming !AS for graphics system.> /fao_count=1 14 - .severity WARNING 15 - NOMACHINE /fao_count=0 16 - NOGRAPHICS /fao_count=0 17 - .severity ERROR 18 - ARGDECODE /fao_count=0 19 - ARGFETCH /fao_count=0 20 - CALLFAIL /fao_count=0 21 - NOSYMBOL /fao_count=0 22 - NOLOGICAL /fao_count=1 23 - NOMODULE /fao_count=1 24 - NOSUCHVERS /fao_count=1 25 - .severity FATAL 26 - .end 27 + +QUIT. HOLD 'PAM ' AFTER FILE 1 WITH 2967 RCRDS, 2967 TOTAL. EOI ON PAM REWIND 'PAM ' -------------- LINES PER PAGE ACTIVE: 110 THE OPTIONS 0, 1, 2, 3 SELECT: 56 62 84 110