+TITLE. HEED 1.01 /00 960118 00.00 * * HEED, written by Igor Smirnov (St Petersburg) with an * interface for use with Garfield. * +PATCH,*HEEDGARF. Pilot patch +USE,HEEDCOM. +USE,HEEDINT. +USE,HEEDSUB. +USE,EHEED. +PATCH,DOC,IF=DOC. +DECK,DOC,IF=DOC. -------------------------------------------------- HEED, an ionization loss simulation program User's guide Version 1.01 (preliminary) -------------------------------------------------- Igor Smirnov 06.02.97 Introduction ------------ The program HEED is intended for detailed calculations of the ionization energy loss of fast charged particles in gases. The program works for solids also, but with less accuracy. The program can also simulate the absorption of the photons in the detector. The program can be applied to simulations of the detectors of the high energy charged particles which register ionization produced by particles in the gases. The algorithm is based on a Monte-Carlo simulation of the energy transfers from the incident particle to atomic electrons. After knocking out of a primary delta-electron a vacancy remains in the atomic shell. The number of shell with vacancy and the type of atom in the gas mixture are specified for every energy transfer. It allows to calculate the delta-electron energy and generate a cascade of secondary particles emitted by the excited atom (the Auger electrons and the fluorescence photons). The calculations include simulation of both absorption of them in the matter and creation of conduction electrons. The program is written in fortran-77. It is tested on several UNIX platforms. The program can be run as a stand-alone program and as subroutines There are two variants: subroutine calculating an average ionization and a cluster-sizes distribution and subroutine for generation of the track, i.e. electron positions. In the both subroutine-forms the program is restricted in choice of geometry and others. Interface to the subroutines is much simpler, therefore we begin from explanation of how to call them, all the following text being almost unnecessary for that users who exploit only the subroutines. The user's guide followes by two additional chapters expounding how to build the executable program from CMZ source text, and giving a test results. -------------------------------------------------------- Copyright notice ---------------- Copyright Igor Smirnov, 1995, all rights reserved. HEED, an ionization loss simulation program. Copyright and any other appropriate legal protection of this computer program and associated documentation reserved in all countries of the world. This program or documentation may not be reproduced and/or redistributed by any method without prior written consent of the author. Permission for the scientific usage of the program described herein is granted apriori to all institution of Russian Academy of Scienses and to those scientific institutes associated with the CERN experimental program or with whom CERN has concluded a scientific collaboration agreement. Commercial utilisation requires explicit a priory permission from the author and will be subjected to payment of a license fee. ------------------------------------------------------ The author can not warrant correct functioning of any part of the program, it is the duty of the user to check that the accuracy of the results is adequate for his/her purposes. Any messages about errors, inaccuracies, and any other problems are welcome. Suggestions for improvement are welcome. Author are looking for any data on photoabsorption cross section, especially for molecules and will be appreciate for sending him any such data or references to them. Author greatly appreciate receiving a copy of any note or publication for which this program has been used. Author's e-mails: Igor.Smirnov@cern.ch ismirnov@hep486.pnpi.spb.ru Igor Smirnov, High Energy Physics Division, Petersburg Nuclear Physics Institute. Gatchina, 188350 St.-Petersburg Russia -------------------------------------------------------- Installation and compilation of CMZ-version ------------------------------------------- For CMZ the HEED program is placed into a car-file, a CMZ Ascii Readable file. For installation we recommend the following sequence of steps. First run the CMZ. Then type the next commands: create heed import/arc heed.car seq -O //heed/PROGRAM There are seven possible ways of using the program HEED. 1. Run it as a stand-alone program with users subroutines IniHeed, UBegEvent, UEndEvent. 2. Run the example of stand-alone program HEED. 3. Calling the subroutine SHEED. 4. Run the program PSHEED which is designed as an example of call of SHEED and serves for testing of SHEED. 5. Calling the HEED from another user's program. The HEED is called as subroutines 6. Run the program PEHEED which is designed as an example of call of HEED in the form of subroutines and serves for testing of HEED. 7. Somebody can want to extract text documentation. To ensure this possibilities some of the decks were equipped with select control options, which allow to extract, compile and link only that decks which is relevant for given task without explicit enumerating of their names. The next options have to be swiched on for each mentioned above case: 1. E 2. E,E1 3. SHEED 4. PSHEED, SHEED 5. EHEED 6. PEHEED, EHEED 7. DOC This can be done by the command select option_name The compilation is executed by commands cc * ,after that all the necessary object files are in a temporary file, and the link can be executed by usual command depening on operating system. For example, on our computer IBM RISC with operating system AIX the temporary files is cmfor.f and cmfor.o, the program is linked by command xlf -O -g -C -o HEED.e cmfor.o -L$CRNLIB -lpacklib -lkernlib where the environment variable CRNLIB points to libraries. Test results: average ionization loss ------------------------------------- Although the calculation of mean ionization loss (KeV and number of pairs) and number of clusters does not involve all the routines of this package, it uses a range of very important routines, results are numbers and all these numbers can be compared with another calculation and experimental values. This allows partially to check the program both from principal and from technical point of view. Below are the table listing for all predefined gases another calculation by simular model [U.A.Budagov et al. Ionization effects in high energy physics, Energoatomizdat, Moscow, 1988, Russian.](the first line in each item), some experimental data (the second line in each item), and our results (the third line in each item) calculated by subroutine SHEED. The table illustrates the extent of exactness of the program and can serve as a pattern of its results when testing proper execution of the program on another computer. ------------------------------------------ Molecule dE/dx Npairs Nclusters (KeV) ------------------------------------------ He 0.322 7.6 3.3 calc. of U.A.Budagov et al - - 3.57 - 5.02 experimental data 0.2847 6.943 3.38 our calculation Ne 1.452 39.9 10.9 so on - - 11.7 - 12.4 1.446 40.84 11.7 Ar 2.541 96.6 24.8 - - 22 - 28 2.517 96.81 26.1 Kr 4.750 197.5 33.0 - - 34.65 4.611 192.1 24.5 Xe 6.862 313.3 44.8 - - 48.41 6.947 315.8 52.3 H2 0.342 9.4 4.7 - - 4.7 0.3362 9.087 7.85 N2 2.097 60.5 20.8 - - - 2.004 57.25 27.4 O2 2.360 76.5 23.2 - - - 2.285 73.7 24.3 NH3 1.586 59.8 - - - - 1.518 57.08 30.1 N2O 3.275 100.6 - - - - 3.146 96.5 39.8 CO2 3.280 100.0 33.6 - - 33 3.133 94.95 34.7 CF4 - - - - - 51 6.049 176.4 59.7 CH4 1.608 59.3 24.8 - - 25 - 26 1.537 56.3 31.6 C2H2 2.339 90.8 31.5 - - - 2.046 79.3 33 C2H4 2.696 104.5 40.4 - - - 2.388 92.58 42.9 C2H6 2.870 117.7 40.5 - - 41 - 51 2.731 109.2 53 C3H8 4.138 176.5 67.6 - - 63 - 74 3.925 163.5 75 i-C4H10 5.402 232.8 83.6 - - 84 - 93 5.119 218.8 96 ---------------------------------------- The subroutine SHEED -------------------- The subroutine SHEED is created on the base of the program HEED for solution of one particular but very important task: calculation of cluster size distribution, and so as to do it in the form of a subroutine calling from another program and receiving all the entering data in the form of subroutine parameters. Therefore the main program MainHEED, and the subroutine IniHeed was converted into the subroutine SHEED. There is no need for user to provide any additional subroutines as it must be done in the case of standart applications of program HEED. The form of calling is: call SHEED + (qmol, nmol, wmol, pres, temp, + tkener, mas, maxnum, soo, oo, debug, + density,dedx, ntotal, nclust, clprob, ierror) Input parameters: integer qmol ! Quantity of different molecules ! in the gas mixture. integer nmol(pqMol) ! Their numbers from molecules.inc. ! Use only the named constants ! for compartibility with future versions. real wmol(pqMol) ! Their weights ! (relative quantities of molecules). real pres ! Pressure in Torr. real temp ! Temperature in K. real tkener ! Kinetic energy of incident particle (MeV) real mas ! Mass of incident particle(MeV) integer maxnum ! Maximum size of cluster(not used now). integer soo ! Flag allowing to write. integer oo ! Output stream number. integer debug ! Flag allowing to write ! more amount of information. Output parameters: real density ! Density of the gas. ! It calculates for ideal gas. real dedx ! Mean dE/dx, mean energy loss, KeV/cm. real ntotal ! Average total number of ! liberated conduction electrons. real nclust ! number of clusters per cm. real clprob(msize) ! Probability of the clusters, ! Size=index. integer ierror ! Sign of error( 0 -- no error ). For pointing to molecules the user is suggested to use the named constants (only in symbolic form) defined in the file molecules.inc The named constant pqMol is defined into the file molecules.inc. The weights may not be nolmalized. The subroutine does this itself. Some of the weights may be zero. The subroutine excludes such items. If pres=0, the standart atmosferic pressure, 760 Torr is substituted. If temp=0, the standart atmosferic temperature, 293 K is substituted. If pmas=0, the proton mass, 938 MeV is substituted If tkener=0, the 'mip' is generated, gamma=4, tkener=pmas*3. The named constant msize is defined into file hs.inc, now it is 10000, that is the maximum cluster size, for which the probability is calculated. This is just a formal approach, in real life such a big cluster either will be like to a big cloud of ionization, or to a track going to outside of the gas volume. The probabilities for the clusters up to 20 electrons are calculated by method Monte-Carlo with 1000 events. The probabilities for more large clusters is calculated by an analitical approach, taking into account only the cross section of energy transfers and dividing the transferred energy on the mean work per pair production. The mean energy loss and total electron number are computed analitically from integral of cross section. The number of clusters is restored from Monte-Carlo and it may be affected by a little statistical fluctuations, as soon as probabilities of the first 20 clusters. Note, all of this is related only to SHEED subroutine, solving the partial problem. The output parameter ierror is 1 if error is detected. All the other output results is to be eliminated in this case. Any error messages are printed to stream 'oo' regardless of value of the flag 'soo'. The usual HEED listing is printed to the same stream provided that soo=1. A little listing is printed if debug=0 or 1 and a very big listing useful only for developers is printed if debug>=2. The subroutine can be called several times from one program. Calling HEED in the form of subroutines --------------------------------------- The program was developed for using as a stand-alone program. However, generating initial ionization it can not watch for its drift to electrodes, and it may be necessary to combine it with another chamber-simulation package. There are three ways of doing this: to link a drift-simulation subroutine to HEED, to link the HEED in the form of subroutines to a drift-simulation program, or to connect two separate programs through intermediate file or stream. The first and the last way are opened for user, while the second requires some little changes in the program. Moreover, the process of initialization may seem not enough simple for a user who wants to solve a simplest task with one-layer geometry. To make the second way available and simple we developed some interface subroutines, which get all setup information as simple parameters. The generated ionization can be taken from well discribed common blocks. Unfortunately, it is difficult to return the output information through the parameters, becouse of large amount of it. The user has to extract what he needs from common blocks. Therefore he may need to get familiar with the following general manual. Only one gas can be initialized when using HEED by this way. The work is naturally divided into initialization stage and event processing stage. So as to reduce the number of the parameters of the initializating subroutine, we split the subroutine into several ones. Initialization of the matter: call IMHEED + (qmol, nmol, wmol, pres, temp, soo, oo, debug, + density, ierror) All these parameters have the same type and sense as for SHEED: Input parameters: integer qmol ! Quantity of different molecules ! in the gas mixture. integer nmol(pqMol) ! Their numbers from molecules.inc. ! Use only the named constants ! for compartibility with future versions. real wmol(pqMol) ! Their weights ! (relative quantities of molecules). real pres ! Pressure in Torr. real temp ! Temperature in K. integer soo ! Flag allowing to write to stream oo. integer oo ! Output stream number. integer debug ! Flag allowing to write ! more amount of information. Output parameters: real density ! Density of the gas. ! It calculates for ideal gas. integer ierror ! Sign of error( 0 -- no error ). For pointing to molecules user is sugested to use the named constants (only in symbolic form) defined in the file molecules.inc The named constant pqMol is defined into the file molecules.inc. The weights may not be nolmalized. The subroutine does this itself. Some of the weights may be zero. The subroutine excludes such items. If pres=0, the standart atmosferic pressure, 760 Torr is substituted. If temp=0, the standart atmosferic temperature, 293 K is substituted. Initialization of the volume: It is doing by standart routines from HEED. User can build any number of volumes, but since only one gas can be initalized, usually only one volume can be necessary (there is no any restrictions in stand-alone form). It is initialized by: call IniFVolume(0, 1, 1, 1, left_borber, width ) where left_borber and widt are real amd measured in cm. Initialization of the particle: call IPHEED + (tkener, mas, debug, + ierror) real tkener ! Kinetic energy of incident particle (MeV) real mas ! Mass of incident particle(MeV) If pmas=0, the proton mass, 938 MeV is substituted If tkener=0, the 'mip' is generated, gamma=4, tkener=pmas*3. This subroutine defines the parameters of the particle which is automatically generated later at the begin of simulation of each event. Initialization of the track: The track can be initialized by the program IniRTrack. call IniRTrack(ystart1, ystart2, pang, pphiang) real ystart1 and ystart2 - bounds of interval on y-axis, where the start point can be. The start point is randomly placed inside these bounds. They can be equal and the point will be fixed. real pang - theta angle between the traectory and the z - axis real pphiang - phi angle (turn around z-axis relativaly x-axis) The track can be initialised one or more times. The next track initialization deletes the old track. The output parameter ierror is 1 if error is detected. All the other output results is to be eliminated in this case. Any error messages are printed to stream 'oo' regardless of value of the flag 'soo'. The usual HEED listing is printed to the same stream provided that soo=1. A little listing is printed if debug=0 or 1 and a very big listing useful only for developers is printed if debug>=2. The subroutines can be called several times from one program. The simulation of the events is done by call GoEventn(nevt,qevt) ! Simulation of one event Here nevt is number of the current event and qevt is the number of the events ordered. In principal the standart GoEvent can be called, if to include into user's program GoEvent.inc The GoEvent must know the number of the current event and the total ordered event number. If there was an overflow of any controlled array - arrays with delta-electrons, conduction electrons, real photons, virtual photons, the GoEvent prints the wornings and auxiliary information to the 'oo' after the last event generated. Therefore it must know which event is last. So as to avoid including of GoEvent.inc , where the event number nevt and quantity of events qevt are stored, user can call GoEventn ,that takes nevt and qevt as arguments and simulates ONE event. So as to reduce the required memory, it is sensible to reduce the maximal numbers of volumes of every kind (see volume.inc) to 1. To have a possibility to treat volume woth more width, the number of the conduction electrons (pqcel in cel.inc) can be increased. The major comsumer of the memory is cel.inc. This is the end of the manual of calling of HEED in the form of subroutines. Geometry -------- The detector is represented by a structure of geometrical volumes. The volumes is filled with different materials. Each volume represents a part of the detector. Having considered the practical applications we formulated a simple geometrical model, ensuring simple and fast tracking. The allowed geometrical configuration is a 3-dimensional space divided by a parallel planes into a sequence of volumes. The widths and the number of the volumes are arbitrary. Their dimensions along the planes are infinite. The first and the last plane are the borders of the detector. For example, the detector may consist of one or several multiwire proportional chambers with insensitive solid plates and a sensitive gas between them. The coordinate system is oriented by such a way that z-axis is perpendicular to the planes. Thus the volumes are considered to be infinite along x- and y-directions. The angle between z-axis and the direction of moving of the incident particle is denoted theta. The polar angle is measured relatively x-axis (around z-axis) and denoted phi. The theta angle must be less than pi/2. The phi-angle is arbitrary. Thus the incoming particle comes from z=-infinity and traverses the layers consequently from left to right. The incident particle can move by a straight trajectory or by a broken line determined by the multiple scattering. The photons (primary or secondary) and all the secondary particles are thoroughly tracked through the multi-layer structure. Structure of the program ------------------------ Logically, there are three phases of the algorithm: -Initialization -Event processing -Termination The initialization phase consists of computing and storing of some auxiliary data, which are necessary during event processing. The source text of the program does not imply a concrete geometry, materials and any other conditions related to particular problems. These data must be allocated in common blocks during the initialization phase. To do this the program calls the subroutine IniHeed. This subroutine has to be provided by the user. It has to consist of the following steps, most of them performed through calls to another HEED subroutines: - set general parameters - parameters for HBOOK - output - energy mesh - atoms - molecules - materials - incident particle - cross sections - track All the data recorded to the common blocks during this phase are kept there till end of run. The processing of every event is also divided into three simular phases: - Event initialization - Event processing - Termination During the event initialisation phase the information about the previous event is deleted and the memory is prepared to record the new event. The standart event initialisation does not require user interventions. For non-standart cases the subroutine UBegEvent is called after the standart initialisation have been done. This subroutine has to be provided by the user. For example, it can initialize another user's common blocks or generate an external photons or delta-electrons. For trivial applications this subroutine may be empty. Having simulated each event the program fills the predefined histograms and calls the subroutine UEndEvent. This subroutine has to be provided by the user. Any treatment of the information about the event can be carried out in it, all the information being accessible here. The user defined histograms are to be filled in this subroutine. For trivial applications this subroutine may also be empty. During the program termination phase all the histograms are written into disk file. Thus, the user has to prepare 3 subroutines: IniHeed, UBegEvent, UEndEvent. The last two ones may be empty. The program makes use two output streams and no input stream. The text data, wornings, messages about errors and debug information are directed to stream with logical number denoted 'oo', which has to be determined by the user. There is possibility to ban all the output except the messages about errors. Another output stream has the number 34 and it is used only for saving of the histograms. This number is determined via the parameter statament and it can be changed by the user. The filling and saving of the histograms can be forbiden. In case of errors the program prints a message and either continues working or stops through the STOP operator. The program is linked with the program libraries packlib and kernlib. Allocation of data ------------------ All the important information is stored in common blocks. Data base systems are not used. Dimensions of arrays is usually specified as named constants, i.e. by names which are given to constants by the PARAMETER statements. In the case of problems the values of these constants can be changed by the user. Each common block together with declarations of types of variables is decribed in an only place. Before beginning of the compilation they have to be included in the subroutines by a text processor. At the developing phase, the INCLUDE compiler directive is used, it makes the fortran compiler include the external file into the source text. This directive is provided in majority of contemporary fortran compilers, although it is not provided by the standart. The common blocks are placed in separate files and included in relevant places of the text. To ensure a maximum mobility, the program is converted into CMZ car-file, and in that form it is presented for applications. The convertion is executed by specially developed utulite, that provides copying every source file into CMZ-deck with changing INCLUDE compiler directives to +SEQ CMZ-directives and every included file is copying into a sequence. However we continue to use the terms 'source file' and 'included file' in this manual and in comments in program. Working with CMS-version it need to remember that instead of included file, for example, 'myfilename.inc' one should operate with sequence with the same, no more than 8-characters name without extension '.inc': 'myfilena'. Analogously, 'myfilename.f' would turn to deck 'myfilena'. The IMPLICIT NONE statament is used in every routine. The types of names are determined explicitly. There are some rules we attempt to follow choosing the names. Two of them need to be mentioned here, since they differ from conventional ones and they are used throughout the program: -Variables with first character 'q' mean usially quantity(number) of somethings and they are integer. -Variables with first characters 'pq' mean usially maximum allowed quantity of something, they are names of integer constant, their values are determined by the PARAMETER statements, they are usually used as the dimensions of the arrays. The sense of common blocks variables and arrays is explaned in comments placed near the type declarations. Values of all these variables can be printed out in a readable form by special subroutines, each common block being printed by separate subroutine. Also there are separate subroutines for initialization of common blocks. The Dimensional Units --------------------- Unless otherwise specified, the following units are used throughout the program: GRAMM, CENTIMETER, MEV, MEV/C, RADIAN, TORR, K The included files ------------------ The included files contain the text of the definitions of the common blocks followed by the specifications of the types of the incoming variables and the specifications of types and values of the named constants. Usually all these variables are kept in one common block, rarely in two, the named constants do not allocated in common blocks at all. Since the common block names are not mentioned in the source text of the program, they are only of technical importance (they must not coincide one with another and so on). Therefore speaking about the common blocks we will mean rather groups of defined in one include file variables and constants, and we will denote them by the names of the included files, where they are defined. If such a file is included in subroutine, all the variables, arrays and constants discribed there become accessible, and no matter where and how they are allocated. The following table contains the included file names and the their destination. The character 'i' means that the contents are changed (initialized) during initialisation phase. The character 'e' means that the program recordes data there during the event processing. The character 'w' means that the user have to assing values to some variables from this included file using the assignment statement (=). ----------------------------------------------------------------- The included files ----------------------------------------------------------------- w i e r | GoEvent.inc Main control variables | LibAtMat.inc Numbers of atoms e | abs.inc Photons which is ready to absorb i | atoms.inc Atomic data i e | bdel.inc information about delta electrons tracking | cbdeldat.inc fit of elastic electron cross sections | cconst.inc world constants e r | cel.inc conduction electrons information i | crosec.inc cross sections of energy transfer of ionization loss e | del.inc delta-electrons information i | ener.inc energy mesh for ionization loss and photon absorbtion w i | hist.inc histograms e | lsgvga.inc ionization energy transfers | (used only for filling of histograms) w i | matters.inc matters data i | molecdef.inc molecular information r | molecules.inc list of molecular numbers i r | part.inc primary particle data e | raffle.inc auxiliary common for the ionization loss simulation w i e | random.inc auxiliary data for random number generator e | rga.inc real photons i | shellfi.inc auxiliary, for communication Iniatom with shellfi i | shl.inc shell information - probability of channels and | energies of secondary particles | i | tpasc.inc auxiliary, for communication Iniatom with tpasc.f i e | track.inc primary particle track information i r | volume.inc information about volumes ------------------------------------------------------------------ There are four included files with several variables needed to be asigned and this required only at initialisation of the program. --------------------------------------------------------------------- GoEvent.inc: integer soo ! Flag, allowing to print ! to stream 'oo' ! If it is 0, no print will be at all, ! except the case of serious problems. integer oo ! The output stream logical number. integer qevt ! Quantity of events to produce. integer ssimioni ! Sign to simulate ionization loss, ! 0 - no ionization, ! 1 - normal ionization. hist.inc: integer sHist ! Sign to fill histograms character*100 HistFile ! File name for file ! with histograms. real maxhisampl ! maximum amplitude for histograms real maxhisampl2 ! reduced maximum amplitude for histograms real maxhisample ! maximum amplitude for histograms ! in units of numbers of the electrons. integer pqhisampl ! quantity for histograms with amplitude. integer shfillrang ! sign to fill special histogram nh2_rd ! with practical range of delta electron ! It takes some computer time. random.inc: integer sseed ! Sign to start first event ! from seed point of random number generator. integer seed(2) ! Form for writting and inputting ! without modification during ! binary to demical transformation. matters.inc: real Cur_Pressure ! Current pressure for initializing medium. ! During gas initialization ! subroutine gasdens uses it for ! calculating of density. real Cur_Temper ! Current temperature for initializing medium. ! During gas initialization ! subroutine gasdens uses it for ! calculating of density. ----------------------------------------------------------------------- All the other common blocks are filled automatically and allowed for reading only. There are two reasons why user may need to be familiar with them: - to check the initialisation and working of the program - to obtain the results of calculations. However, so as to avoid updating the manual after each little modification in them, we do not want to include their listings into this manual so far. Users are invited to print the common blocks marked with character 'r' from his/her current version, they are of the first interest, all the variables being thoroughly explained in the comments. Simplified Program Flow Chart ----------------------------- program MainHEED call IniHeed ! User's subroutine, ! initialization of the detector. do nevt=1,qevt ! Loop over events. call GoEvent ! Simulation of one event. enddo end subroutine GoEvent call UBegEvent ! User's subroutine. ... ! Simulation of event. call UEndEvent ! User's subroutine, ! any treatment of ! the event information. end The main program ---------------- ------------------------------------------------------------------------ Listing . The main program, file MainHEED.f ------------------------------------------------------------------------ program HEED c c The main program for HEED package c implicit none integer NPW PARAMETER (NPW = 2000000) real H COMMON /PAWC/ H(NPW) include 'GoEvent.inc' include 'volume.inc' include 'hist.inc' CALL HLIMIT(NPW) call Iniranfl ! Initialization of the counter of ! random number generator calls call IniHeed ! User's subroutine, ! Initialization of the detector if(sHist.eq.1)then call IniHist ! Initialization of inbilt histograms endif do nevt=1,qevt ! Loop over events call GoEvent ! Simulation of one event enddo if(sHist.eq.1)then call WHist ! Writting of histograms endif call Priranfl ! Print the number of calls of ! random number generator end ----------------------------------------------------------------------- The event processor ------------------- ----------------------------------------------------------------------- Listing 2. The event processor, file GoEvent.f ----------------------------------------------------------------------- subroutine GoEvent c c Event processor. It is called from MainHEED. c implicit none include 'GoEvent.inc' include 'abs.inc' include 'rga.inc' include 'volume.inc' include 'hist.inc' include 'random.inc' integer iempty c if(nevt.le.ninfo)then if(soo.eq.1)then write(oo,*) write(oo,*)' Event number ',nevt endif if(nevt.eq.1.and.sseed.eq.1)then call randset ! Set the start point of endif ! the random number generator. if(soo.eq.1)then call randget call randpri(oo) ! Print the current point of endif ! the random number generator. c endif call IniNTrack ! Generate the next track. if(nevt.le.ninfo)then call PriMTrack(0) ! Print debug information call PriMTrack(1) call PriMTrack(2) call PriMTrack(3) call PriMTrack(4) endif call IniLsgvga ! Initialize gvga.inc call Iniabs ! Initialize abs.inc call Inirga ! Initialize rga.inc call Inidel ! Initialize del.inc call Inicel ! Initialize cel.inc call UBegEvent ! User's subroutine if(ssimioni.eq.1)call rafflev ! Generate the primary energy transfers ! from incoming particle if(soo.eq.1)then if(nevt.le.ninfo)then write(oo,*) call PriLsgvga ! Print debug information endif endif do iempty=1,10000 if(soo.eq.1)then if(nevt.le.ninfo)then write(oo,*) write(oo,*)' before absorption of virtual photons:' call Priabs ! Print debug information endif endif call AbsGam ! Absorb the virtual photons if(soo.eq.1)then if(nevt.le.ninfo)then ! Print debug information write(oo,*) write(oo,*)' after absorption of virtual photons:' c call Priabs call Prirga call Pridel endif endif call GoGam ! Absorb the photons if(soo.eq.1)then if(nevt.le.ninfo)then ! Print debug information write(oo,*) write(oo,*)' after absorption of photons:' call Priabs c call Prirga call PrirgaF endif endif if(ctagam.gt.qtagam.and.crga.gt.qrga)then ! There are neither real no ! virtual photons to trace. goto 50 ! Exit the loop. endif enddo 50 continue call treatdel ! Track the delta-electrons ! and generate the conduction electrons. call treatcel ! Treat the cel.inc if(soo.eq.1)then if(nevt.le.ninfo)then ! since there are calculation of ranges ! which in wroute to del inside treatdel write(oo,*) call Pridel endif endif if(sHist.eq.1)then call Fhist ! Fill predetermined histograms endif call UEndEvent ! User's subroutine if(soo.eq.1)then if(nevt.eq.qevt)then write(oo,*) write(oo,*)nevt,' events is done' ! Printing the wornings about overful call WorPrirga call WorPriabs call WorPridel call WorPricel endif endif end Initialization -------------- As was said above the duty to provide the initialization subroutine is imposed upon the user. We can present here only an example of such subroutine and we hope that it is enough clear for understanding and the user will not meet troubles making use it as a 'fish' for preparation of his own analogous subroutine. --------------------------------------------------------------------------- listing 1 Example of IniHeed --------------------------------------------------------------------------- subroutine IniHeed c c implicit none include 'GoEvent.inc' include 'hist.inc' include 'ener.inc' include 'atoms.inc' include 'matters.inc' include 'cconst.inc' include 'volume.inc' include 'part.inc' include 'h31.inc' include 'random.inc' real tkener,mas,momentum integer i integer j real wid real amc integer na soo=1 ! To allow (1) or to ban (0) printing to stream oo. oo=10 ! set logical number of output stream. open(oo,FILE='heed.out') ! open output disk file. sret_err = 0 ! Stop if error is detected c Auxiliary variables for histograms (from hist.inc) sHist=1 ! To allow (1) or to ban (0) dealing with histograms. HistFile='heed.hist' ! File name, where they are written to. maxhisampl=40.0e-3 ! Maximum aplitude. maxhisampl2=20.0e-3 ! Reduced maximum aplitude. maxhisample=150 ! Maximum aplitude in unit of number of elect. pqhisampl=100 ! Number of bins. shfillrang=1 ! To allow (1) or to ban (0) filling histogram nh2_rd. c Random number genarator sseed=0 ! To make the generator start from seed point (1) ! or from default point (0). seed(1)=1121517854 ! this is example for sseed=1 seed(2)=612958528 qevt=1000 ! Quantity of events to generate ssimioni=1 ! To allow ionization loss (1) or to ban it (0) ninfo=0 ! Number of first events with output listing call Inishl ! Cascade from excited atom call IniEner(150,3e-6,0.2) ! Energy mesh c call PriEner call AtomsByDefault ! Library of atoms c call PriAtoms(0) Cur_Pressure=Atm_Pressure Cur_Temper=Atm_Temper call CO250CF420Ar30(1) ! Material from LibAtMat c call PriMatter(0) wid=0.5 call IniFVolume(1, 1, 1, 0, 0.0, wid ) ! Volume c call PriVolume mas=105.0 ! muon momentum=100000.0 tkener=sqrt(mas*mas+momentum*momentum)-mas call IniPart(tkener,mas) ! Particle call PriPart call IniRTrack(0.0, 0.0, 0.0, 0.0) ! Track call PriTrack call IniCrosec ! Cross sections c call PriCrosec(1,4) call InisBdel ! Data for tracking of delta-electrons call PriBdel(0) end --------------------------------------------------------------------------- This example is so simple that subroutins UBegEvent and UEndEvent do not need to do anything. They can be just empty. Therefore they are not printed here. The results of calculations are histograms contained in the file 'heed.hist'. The program is using some information about the secondary radiation from exited atom. It is saved in the common block from "shl.inc". This information has a difficulte structure, which is initialized by special program "Inishl". One should just call the subroutine "Inishl" before any others. Users are strongly recommended to begin their simulation with the parameters as stored by Inishl. Users who want to modify any of these parameters must be sure they understand their function in the program and the implications of a change. The subroutine IniEne initializes the energy mesh for internal calculations. It is used in calculations of ionization loss and photon absorption. The points are equally spaced on a logarifmic scale. call IniEne(q,emin,emax) int q - quantity of the points. 100-200 is recomended. real emin - the minimum energy. It must be less than minimum for photo absorbtion cross section. 5 eV is recomended. real emax - the maximum energy. It must be several times more than maximum of the shell energies. 200 KeV is recomended. This subroutine initializes the common block from file "ener.inc" . Almost all the arrays with atomic, matters, cross-section information corresponds to the centers of the energy intervals, each value being the overage of a parameter on this interval. Initialisation of the atoms --------------------------- The atomic information is allocated in the file atom.inc. The atoms are assigned numbers. The numbers are indexes of array elements, where the atomic information is saved. These numbers are used as the pointers to the atoms throughout the program. The atoms can be initialized in arbitrary order. The empty places are allowed. The program uses the variable Zat (charge of atomic nucleus) as a sign of whethere the atom is initialized, the atom being initialized if it is positive, nonzero. An attempt to refere to an empty place or to initialize the atom twice usually causes the program stop immediately, the error message being printed. There is a list of the predetermined atoms, it contains all the most often used atoms, see LibAtMat.inc. It is initialized by call AtomsByDefault . If the necessary atom is not included in this list, it need to increase parameter pQAt (atoms.inc) and initialize the new atoms in free places, calling the subroutine IniAtom. (The IniAtom knows the atom numbers from LibAtMat.inc and it carried out a special algorithms for some of them. Thus, even if AtomsByDefault is not called, the new atoms have to be initializaed on different places.) The subroutine IniAtom initializes the atomic data. call IniAtom(num,z,a) int num - internal number of the atom. It can not be less than zero and larger than pQAt-maximun quantity of the atoms. pQAt is set in atoms.inc and can be changed. There are no possibility to define atom with the same number second time. The program terminates if one of these errors are occured. int z - charge real a - atomic weight The information is writting to the 'atoms.inc'. Use subroutine PriAtoms so as to print all the atoms to the standart unit 'oo'. Initialisation of the materials -------------------------------- The information about materials is allocated in the file matters.inc. The matters are assigned numbers by the user. The numbers have the same meaning as the atom numbers. These numbers are used as the pointers to the matters throughout the program. The matters can be initialized in arbitrary order. The empty places are allowed. The program uses the variable QAtMat as a sign of whethere the matter is initialized, the matter being initialized if it is positive. An attempt to refere to an empty place or to initialize the atom twice usually causes the program stop immediately, the error message being printed. There is a library of subroutines initializing various matters, mainly gases. They are placed in the file LibAtMat.f. The only argument of these subroutines is matter number. They use the atoms initialized by call AtomsByDefault. There is a special package intended for initialisation of an arbitrary gas mixture. There are a list of predeterminated molecules in file molecules.inc. This list will be increased in the future. The gas mixture can be arbitrary mixture of these molecules. The subroutine molecdef initializes these molecules. The information is allocated in molecdef.inc and can be printed by call Primolec. The subroutine Inigas initializes a gas mixture: subroutine Inigas( nmat, qmol, nmol, pwmol, pres, temp) integer nmat ! Number of material integer qmol ! Quantity of different molecules ! in the gas mixture. integer nmol(pqMol) ! Their numbers in molecdef.inc ! accordingly with molecules.inc real pwmol(pqMol) ! Their weights ! (relative quantities of molecules). real pres ! Pressure in Torr. real temp ! Temperature in K. Finnally there is a basical subroutine IniMatter, capable to create any solid or gas. The subroutine IniMatter initializes the material. call IniMatter(num,Atom,Weight,q,dens) int num - internal number of the matter. It can not be less than zero and larger than pQMat-maximun quantity of the matters. pQMat is set in matters.inc and can be changed. There are no possibility to define matter with the same number second time. The program terminates if one of these error are occured. int Atom(*) - array of the atomic numbers(internal-see above). real Weight(*) - quantity of the atoms in the mixture. The sum may be not equal to one. int q - quantity of atoms. real dens - density of the matter. The information is writting to the 'matters.inc'. Use subr. PriMatter so as to print all the matters to the standart unit oo. The weights of atoms stored in matters.inc are corrected by the subr. IniMatter so as their sum is equal to 1. The function gasdens calculates the density of the gas. Pressure and temperature is taken from variables Cur_Pressure and Cur_Temper placed in matters.inc. The density is calculated by law of ideal gas. dens=gasdens(A,Weight,q) real dens - density in g/sm**3 real A(*) - array of the molecular weights real Weight(*) - quantity of the molecules in the gase mixture The sum may be not equal to one. int q - quantity of the molecules Initialization of the Geometry ------------------------------ The geometrical model and the coordinate system is defined in section geometry at the begin of this document. The volumes is initialised consequently from right to left. There are three types of volumes here. There are two keys to define it, one combination is not allowed. They are: sSens - sign that it is sensitive volume i.e. proportional chamber. sIon - sign that the ionization loss must be here. Some of these sorts of volumes could refer to 0 as number of the matter. The following combinations are allowed: --------------------------------- matter number sSens sIon --------------------------------- 0,any 0 0 not 0 0 1 not 0 1 1 --------------------------------- Ionization loss may not be calculated anywhere since it can be too long. It is sensible to calculate them only in chamber gas and in special cases in the poliethilene or mylar around it. Zero matter number in all cases except last means vacuum. Therefore ionization or sensitive volume can not include vacuum. The subroutine IniVolume initializes the first or the next volume on the right of the previous. The next two subroutins are more convinient. call IniVolume(nmat,sSens,sIon,sTran,cwall1,cwall2,wide) int nmat - number of the material int sSens - sign of the sesitivity. int sIon - sign of ionization loss. int sTran - sign of the transition radiator. Not using in LSG. real cwall1 - z-coordinate of the left side of the volume. It using only for the first volume. real cwall2 - z-coordinate of the right side of the volume. real wide - wide. Not using now. Initialization of the first volume: call IniFVolume(nmat,sSens,sIon,sTran,cwall1,wide) Initialization of the next volume: call IniNVolume(nmat,sSens,sIon,sTran,wide) The quantity of the volumes can't be more than pqvol - max. quantity of the volumes. pqvol is defined in volume.inc and can be changed. All the volume parameters are saved in the volume.inc. You can print all the volume parameters by the program PriVolume. The convinuent possibility to calculate of the total radiation lenght is take a look into output listing. But for LST output must be done after IniLst so as to take into account radiator. Other Initializations --------------------- The particle is initialized by call IniPart(tkener,mas) real tkener - kinetic energy (MeV) real mas - mass (MeV) Particle can be initialized one or more times. After each initialization the call IniCrosec is needed. The calculations of the energy transfer cross sections are made by subr. IniCrosec. call IniCrosec It calculates the cross section only for those matter, which are contined in the sensitive volumes and only for initialized particle. If you initialize the new particle you must call IniCrosec again. The initializations of data for delta-electrons tracing must be done by call InisBdel. The track can be initialized by the program IniRTrack. call IniRTrack(ystart1, ystart2, pang, pphiang) real ystart1 and ystart2 - bounds of interval on y-axis, where the start point can be. The start point is randomly placed inside these bounds. They can be equal and the point will be fixed. real pang - theta angle between the traectory and the z - axis real pphiang - phi angle (turn around z-axis relativaly x-axis) The track can be initialised one or more times. The next track initialization deletes the old track. Call IniCrosec is not need again. Initialization of the Histograms -------------------------------- There are several predefined histograms, described in files hist.inc and hist.f. They are treated automatically. The user program can define and fill any additional histograms, calling relevant HBOOK subroutines. Random Numbers Generators ------------------------- The only uniform random number generator is called throughout the program: function ranfl. It is just intermediate function intended for connection with one of the standart random number generators and allows to change it in case of need. But one ought to be careful, the correlations between the current and the next rundom numbers are found to worse the results. To pass from current generator to another one it need only to change the call of it inside the body of the function ranfl and to change three auxiliary functions in the same file: randset - set start point randget - get current point randpri - print current point. Since all the generators of the non-uniform numbers use uniform random number generator as well, we extracted all the necessary routines from CERNLIB and modified them inserting the call of ranfl: lranor - random numbers following Gauss distribution (modified rannor) lspois - Poisson distribution (modified poissn),(also a little error is corrected) hisran - random numbers following histogram (the same name as in CERNLIB) All of them is contined in file random.inc. Thus there is the only random number sequence used in all the program. Therefore the program can repeat the simulations starting from any event. For this purpose, at the begin of each event the program prints the seed numbers. Files With Text of Program -------------------------- PSHEED.f # check of SHEED SHEED.f # the main subroutine instead of program, # cluster size distibution UEventS.f # subroutine for SHEED MainHEED.f # main program GoEvent.f # generate one event IniHeed1.f # users routine for setup initialization UEvent1.f # users routine for work with event IniEner.f # energy net initialization logscale.f # function for logariphmic scale generation Inishl.f # atomic channels genaration LibAtMat.f # library of some atoms and matters molecdef.f Inigas.f IniAtom.f # atomic data initialization tpasc.f shellfi.f # subroutines for atomic data files reading line.f # auxiliary functions for straight line integration # and steps integration IniMatter.f # matter data initialization gasdens.f # gas density calculation IniVolume.f # volumes initialization IniTrack.f # track initializatin IniPart.f # particle initialization IniCrosec.f # ionization cross section initialization IniLsgvga.f # common lsgvga.inc initialization Inirga.f # common rga.inc initialization Iniabs.f # common abs.inc initialization raffle.f # ionization loss generator, filling abs.inc and lsgvga.inc GoGam.f # photons tracing till absorbtion, fills abs.inc AbsGam.f # photons absorbtion, fills del.inc and rga.inc IniBdel5.f # common bdel.inc initialization lstrel1.f Inidel.f # common del.inc initialization treatdel.f # treat delta-electrons and fill cel.inc Inicel.f # common cel.inc initialization treatcel.f # treat current electrons SourcePhot.f # auxiliary source of photons SourceDelEl.f # auxiliary source of delta-electrons vectors.f # vector algebra subroutins random.f # random number generators hist.f # histogram initialization and fill +PATCH,HEEDCOM. +KEEP,molecule. integer pqMol ! Quantity of sorts of molecules. parameter (pqMol=25) integer numm_He parameter (numm_He= 1) integer numm_Ne parameter (numm_Ne= 2) integer numm_Ar parameter (numm_Ar= 3) integer numm_Kr parameter (numm_Kr= 4) integer numm_Xe parameter (numm_Xe= 5) integer numm_H2 parameter (numm_H2= 6) integer numm_N2 parameter (numm_N2= 7) integer numm_O2 parameter (numm_O2= 8) integer numm_NH3 parameter (numm_NH3= 9) integer numm_N2O parameter (numm_N2O= 10) integer numm_CO2 parameter (numm_CO2= 11) integer numm_CF4 parameter (numm_CF4= 12) integer numm_CH4 parameter (numm_CH4= 13) integer numm_C2H2 parameter (numm_C2H2= 14) integer numm_C2H4 parameter (numm_C2H4= 15) integer numm_C2H6 parameter (numm_C2H6= 16) integer numm_C3H8 parameter (numm_C3H8= 17) integer numm_iC4H10 parameter (numm_iC4H10= 18) integer numm_C ! for debug parameter (numm_C = 19) *** Additions (RV 4/9/98). integer numm_DME parameter (numm_DME= 20) integer numm_H2O parameter (numm_H2O= 21) *** Additions (RV 20/9/99). integer numm_SF6 parameter (numm_SF6= 22) integer numm_C2F4H2 parameter (numm_C2F4H2= 23) *** Addition (RV 14/1/00). integer numm_C5H12 parameter (numm_C5H12= 24) *** Addition (RV 25/2/00). integer numm_C2F5H parameter (numm_C2F5H= 25) *** End of additions. c integer numm_CClF3 c parameter (numm_CClF3= 19) c integer numm_CClF2 c parameter (numm_CClF2= 20) c integer numm_CBrF3 c parameter (numm_CBrF3= 21) c integer numm_SF6 c parameter (numm_SF6= 22) +KEEP,molecdef. integer pqSAtMol ! Max. allowed quantity of sorts of atoms ! in a molecule. parameter (pqSAtMol=3) integer qSAtMol ! Quantity of sorts of atoms in a molecules. integer nAtMol ! Number of atom in atoms.inc, ! see LibAtMat.inc. integer qAtMol ! Quantity of atoms of given sort in molecule real weiMol ! Molecular weight real WWWMol ! Mean work for pair production real FFFMol ! Parammeter Fano common / cmodef / + qSAtMol(pqMol), + nAtMol(pqSAtMol,pqMol), + qAtMol(pqSAtMol,pqMol), + weiMol(pqMol), + WWWMol(pqMol), + FFFMol(pqMol) save / cmodef / +KEEP,hs. integer msize parameter (msize=10000) real prob,meanprob,meanvga,meanvgal real prob1 integer qe common / h31 / + prob(msize),meanprob,meanvga,meanvgal, + prob1(msize) +KEEP,GoEvent. c Main control variables integer soo ! Flag, allowing to print ! to stream 'oo' ! If it is 0, no print will be at all, ! except the case of serious problems. integer oo ! The output stream logical number. integer qevt ! Quantity of events to produce. integer nevt ! Current number of the event. integer ninfo ! Quantity of the first events ! to print debug info. integer ssimioni ! Flag to simulate ionization loss, ! 0 - no ionization, ! 1 - to simulate ionization. ! ! ! integer srandoff ! Flag to swich off the randomization ! in function treatdel. ! It is for debug and without guarantee. parameter (srandoff=0) ! Normal regim with randommization. integer pqup ! dimensions of arrays of auxiliary ! parameters in abs.inc, rga.inc, ! del.inc parameter (pqup=1) integer sret_err ! Sign to return the control from current ! subroutine to which is called it if error is occured. ! 1 - to return, 0 - to stop. ! It is intended for handling with subroutine SHEED. ! In the case of error it can return the control instead of ! stop. But not for every possible errors return is done. ! Some of the most original errors could lead to stop. ! When working with HEED program, sret_err must be zero. integer s_err ! Sign of error. ! 1 - error, 0 - no error character*9 TaskName ! Name of task, using for generating ! file names. character*40 OutputFile ! Name of file with output listing. ! Using only in IniHeed. common / cGoEve / + soo, oo, + qevt,nevt,ninfo, + ssimioni, + sret_err, s_err, + TaskName, + OutputFile save / cGoEve / +KEEP,ener. c Energy mesh integer pqener,qener ! Max. quantity and quantity of bins. ! Quantity must not be more than pqener - 1. PARAMETER (pqener=501) real ener,enerc ! The left edges and the centers ! of the energy intervals. ! ener(qener+1) is the right edge ! of the last interval. C COMMON / coEner / + qener, ener(pqener), enerc(pqener) save / coEner / +KEEP,atoms. integer pQAt ! Max. quantity of atoms. parameter (pQAt=19) integer KeyTeor ! Key to use only theor. photo-absorbtion ! cross section with thresholds and ! weights from the subroutine shteor. ! If 0 then they are used only for ! the atoms which are absent ! in the subroutine readPas and ! in the subroutine shellfi. integer Zat ! Atomic number (charge of atomic nucleus). real Aat ! Atomic weight. integer pQShellAt ! Max. quantity of atomic shells. parameter (pQShellAt=17) integer QShellAt ! Quantity of atomic shells. real cphoAt ! Integral of photo-absorbtion ! cross secton for one atom. real ThresholdAt ! Threshold and real WeightShAt ! Weight of atomic shells for the ! photo-absorbtion cross secton ! relatively cphoAt. real PWeightShAt ! Initial integral of ! photo-absorbtion cross secton. real PhotAt ! Photo-absorbtion cross secton. real PhotIonAt ! Photo-ionization cross secton. c The physical definition of two previous arrays of values: c mean values of cross sections for each energy interval. real RLenAt ! Radiation lengt*density for dens=1 real RuthAt ! Const for Rutherford cross cection ! (dimensionless). c integer num_at_mol ! Number for atoms in several special c ! molecules, now obsolete. real ISPhotBAt ! Shell integral of cs before normalization real IAPhotBAt ! Atomic integral of cs before normalization real ISPhotAt ! Shell integral of cs real IAPhotAt ! Atomic integral of cs real ISPhotIonAt ! Shell integral of cs real IAPhotIonAt ! Atomic integral of cs real MinThresholdAt ! Minimal ionization potential of atom. integer NshMinThresholdAt ! Number of shell with minimal energy, ! it must be the last shell ( see AbsGam.f) integer Min_ind_E_At, Max_ind_E_At ! Indexes of energy intervals ! where program adds excitation to cs ! They placed in common only to print and check. integer nseqAt ! Sequensed pointer in order of increasing Zat ! atom number nsAt(1) is least charged. integer QseqAt ! Quantity of initialized atoms common / catoms / + KeyTeor, + Zat(pQAt), Aat(pQAt), + QShellAt(pQAt), cphoAt(pQAt), + ThresholdAt(pQShellAt,pQAt), WeightShAt(pQShellAt,pQAt), + PWeightShAt(pQShellAt,pQAt), + PhotAt(pqener,pQShellAt,pQAt), + PhotIonAt(pqener,pQShellAt,pQAt), + ISPhotBAt(pQShellAt,pQAt), + IAPhotBAt(pQAt), + ISPhotAt(pQShellAt,pQAt), + IAPhotAt(pQAt), + ISPhotIonAt(pQShellAt,pQAt), + IAPhotIonAt(pQAt), + MinThresholdAt(pQAt), + NshMinThresholdAt(pQAt), + Min_ind_E_At(pQAt), Max_ind_E_At(pQAt), + RLenAt(pQAt), + RuthAt(pQAt), + nseqAt(pQAt), + QseqAt save / catoms / +KEEP,matters. integer pQMat ! Max. quantity of matters. parameter (pQMat=10) integer QAtMat ! Quantity of atoms in matter. integer AtMAt ! Number of atom in matter ! (the pointer to atoms.inc). real WeightAtMat ! Weight of atom in matter. real A_Mean ! Average A. real Z_Mean ! Average Z. real DensMat ! Density (g/cm3). real DensMatDL ! Density (g/cm3) for energy loss of deltaelect. real DensMatDS ! Density (g/cm3) for mult. scat. of deltaelect. real ElDensMat ! Electron density(MeV3). real XElDensMat ! Longitud. Electron Dens. for x=1cm(MeV2/cm) real wplaMat ! Plasm frequancy. real RLenMat ! Radiation Lengt. real RuthMat ! Const for Rutherford cross section (1/cm3). real PhotMat ! Photoabsirbtion cross section per one atom. real PhotIonMat ! Photoionization cross section per one atom. real epsip ! plasm dielectric constant. real epsi1 ! real part of dielectric constant. real epsi2 ! imaginary part of dielectric constant. real min_ioniz_pot ! Minimum ionization potential, ! it is using only for switching off ! the Cherenkov radiation below it. real Atm_Pressure ! Standart atmosferic pressure. parameter (Atm_Pressure=760.0) real Cur_Pressure ! Current pressure for initialized medium. ! During gas initialization ! the subroutine gasdens uses it for ! calculating of density. real Pressure ! Pressure for given medium. real Atm_Temper ! Standart atmosferic temperature. parameter (Atm_Temper=293.0) real Cur_Temper ! Current temperature for initialized medium. ! During gas initialization ! the subroutine gasdens uses it for ! calculating of density. real Temper ! Temperature for given medium. real WWW ! The mean work per pair production. real FFF ! Fano parameter. common / cmatte / + QAtMat(pQMat), + AtMat(pQAt,pQMat), + WeightAtMat(pQAt,pQMat), + A_Mean(pQMat),Z_Mean(pQMat), + DensMat(pQMat),ElDensMat(pQMat),XElDensMat(pQMat), + DensMatDL(pQMat),DensMatDS(pQMat), + wplaMat(pQMat), + RLenMat(pQMat), + RuthMat(pQMat), + PhotMat(pqener,pQMat), + PhotIonMat(pqener,pQMat), + epsip(pqener,pQMat), + epsi1(pqener,pQMat), + epsi2(pqener,pQMat), + min_ioniz_pot(pQMat), + Cur_Pressure,Pressure(pQMat), + Cur_Temper,Temper(pQMat), + WWW(pQMat),FFF(pQMat) save / cmatte / +KEEP,crosec. integer pQShellC ! Max quantity of shells for all atoms ! in one material parameter (pQShellC=20) c integer MatC ! Matter number integer sMatC ! Sign to calculate sross section ! for this matter integer QShellC ! Quantity of shells for all atoms ! in this matter c real ksi ! Help Landau constant c ! (it seems it is't used) real log1C ! first log real log2C ! second log real chereC real chereCangle real addaC ! energy tranfer cross section real quanC ! it's integral, ! or quantity of energy transfers, ! or primary cluster number. real meanC ! first moment, ! or restricted mean energy loss, Mev. real meanC1 ! first moment with whole additional tail ! to emax - kinematically allowed transition. ! Now it is calculated only for heavy particles ! because the integral for electrons is not ! trivial, ! or mean energy loss, Mev. real meaneleC ! expected restricted quantity of ! secondary ionization. real meaneleC1 ! expected quantity of secondary ionization. integer NAtMC ! number of atom in the matter ! for shell with corr. index integer NAtAC ! number of atom integer NSheC ! number of shell real flog1 real flog2 real cher real rezer real frezer real adda real fadda real quan real mean complex*16 pocaz ! it is help ! coefficient at y ! the value of imajinary part ! corresponsd to with of wave front common / ccrosec / + pocaz(pqener,pQMat), + sMatC(pQMat), + QShellC(pQMat), c + ksi(pQMat), + log1C(pqener,pQMat), + log2C(pqener,pQMat), + chereC(pqener,pQMat), + chereCangle(pqener,pQMat), + addaC(pqener,pQMat), + quanC(pQMat), + meanC(pQMat), + meanC1(pQMat), + meaneleC(pQMat), + meaneleC1(pQMat), c + NAtMC(pQShellC,pQMat), + NAtAC(pQShellC,pQMat), + NSheC(pQShellC,pQMat), c + flog1(pqener,pQShellC,pQMat), + flog2(pqener,pQShellC,pQMat), + cher(pqener,pQShellC,pQMat), + rezer(pqener,pQShellC,pQMat), + frezer(pqener,pQShellC,pQMat), + adda(pqener,pQShellC,pQMat), + fadda(pqener,pQShellC,pQMat), + quan(pQShellC,pQMat), + mean(pQShellC,pQMat) save / ccrosec / +KEEP,cconst. real*8 ELMAS ! Electron mass (MeV) parameter (ELMAS=0.51099906) real*8 FSCON ! Fine ctructure constant parameter (FSCON=137.0359895) real*8 ELRAD ! Electron radius (1/MeV) parameter (ELRAD=1.0/(FSCON*ELMAS)) real*8 PI parameter (PI=3.14159265358979323846) real*8 PI2 parameter (PI2=PI*PI) real*8 AVOGADRO parameter (AVOGADRO=6.0221367e23) real*8 PLANK ! Plank constant (J*sec) parameter (PLANK=6.6260755e-34) real*8 ELCHARGE ! Electron charge (C) parameter (ELCHARGE=1.60217733e-19) real*8 CLIGHT ! Light vel.(sm/sec) parameter (CLIGHT=2.99792458e10) c real pionener c parameter (pionener=0.000026) +KEEP,volume. c descriptions of the geometry of the setup integer pqvol ! Max. quantity of volumes parameter (pqvol=150) integer pQSVol ! Max. quantity of sensitive volumes parameter (pQSVol=130) integer pQIVol ! Max. quantity of ionization volumes parameter (pQIVol=130) integer QSVol integer QIVol integer qvol ! quantity of volumes integer upVol ! user's volume parameter integer nMatVol ! Material number for volume integer sSensit ! Sign of sensitivity integer sIonizat ! Sign of ionization real*8 wall1,wall2,wide ! Left, right side and wide of volume integer numSensVol,numVolSens ! pass from Volume number ! to Sensitive volume number integer numIoniVol,numVolIoni ! The same for ionization real RLenRVol, RLenRAVol ! Radiation lengt for each volumes ! and for whole detector. integer xxxVol ! dummy, for efficient alignment common / cvolum / + qvol, + QSVol,QIVol, xxxVol, + upVol(pqvol), nMatVol(pqvol), sSensit(pqvol), + sIonizat(pqvol), + wall1(pqvol),wall2(pqvol),wide(pqvol), + numSensVol(pqvol),numVolSens(pQSVol), + numIoniVol(pqvol),numVolIoni(pQIVol), + RLenRVol(pqvol),RLenRAVol save / cvolum / +KEEP,part. c The incoming particle. c After changing the particle you have c to recalculate crossec real tkin,mass ! Kin.energy real*8 beta2,beta12 ! Beta**2 and 1.0-Beta**2 real emax ! Max. energy of delta electron real bem ! beta2/emax real coefPa ! help const c It is in energy transfer cross sections: c Alpha c ---------- c beta2 * pi real partgamma ! gamma factor real partmom,partmom2 ! momentum and momentum**2 integer s_pri_elec ! Sign that primary particle is electron. ! It is recognized by mass near to 0.511 ! In some parts of program the direct condition ! like mass < 0.512 is used. common / cpart / + tkin,mass, + beta2,beta12, + partgamma, + partmom,partmom2, + emax, c + ecut, + bem , + coefPa, + s_pri_elec save / cpart / +KEEP,hist. integer sHist ! Sign to fill histograms character*100 HistFile ! File name for file ! with histograms. integer HistLun ! Logical number of stream to write ! this file. parameter (HistLun=34) real maxhisampl ! maximum amplitude for histograms real maxhisample ! maximum amplitude for histograms ! in units of electrons real maxhisampl2 ! reduced maximum amplitude for histograms integer pqhisampl ! quantity for histograms with amplitude. integer pqh parameter (pqh=100) ! usual number of divisions integer pqh2 parameter (pqh2=200) ! increased number of divisions integer shfillrang ! sign to fill special histogram nh2_rd ! with practical range of delta electron ! It spends some computer time. integer MaxHistQSVol parameter (MaxHistQSVol=50) ! Maximum number of volumes, ! used at initilisation of histograms. ! If the number of the sensitive volumes ! is more, ! only MaxHistQSVol histograms will be created ! and they will represent ! the first MaxHistQSVol volumes integer hQSVol ! working number -- minimum of ! MaxHistQSVol end QSVol ! Defined in Inihist c Determination of histogram numbers: c Notation nh1 is number of 1-dimension histogram c Notation nh2 is number of 2-dimension histogram integer nh1_ampK parameter (nh1_ampK=100) ! amplitude (KeV) ! Some fluctuations may be here if ! each single bin of this histogram corresponds ! to differrent numbers of bins of ! nh1_ampN histogram. integer nh1_ampKR parameter (nh1_ampKR=150) ! amplitude (KeV) ! Special treatment is applyed to smooth ! the fluctuations mentioned above. ! It increases the mean square dispersion ! on a little value sqrt(1/12)* w . integer nh1_ampN parameter (nh1_ampN=200)! amplitude in numbers of conduction electrons. integer nh1_cdx ! charge distribution along x parameter (nh1_cdx=300) integer nh1_cdy ! charge distribution along y parameter (nh1_cdy=500) integer nh1_cdz ! charge distribution along z parameter (nh1_cdz=700) integer nh2_ard ! Actual range of delta-electron(cm) parameter (nh2_ard=900) ! vs energy(MeV). integer nh2_rd ! Range along initial direction of parameter (nh2_rd=901) ! delta-electron vs energy. integer nh1_rd ! Range along initial direction of parameter (nh1_rd=902) ! delta-electron (cm). common / chist / + sHist, + maxhisampl, + maxhisample, + maxhisampl2, + pqhisampl, + shfillrang, + hQSVol save / chist / common / chhist / + HistFile save / chhist / +KEEP,random. real*8 iranfl integer sseed ! Flag to start first event ! from seed point of random number generator. real*8 rseed ! Place for seed. integer seed(2) ! Form for writting and inputting ! without modification during ! binary to demical transformation. equivalence (rseed,seed(1)) common / comran / + iranfl, + rseed, sseed save / comran / +KEEP,del. c Delta electrons integer pqdel ! Max. q. of electrons parameter (pqdel=120000) integer qdel ! Q. of electrons C integer cdel ! Current electron (not used, RV 27/2/97) ! number of el. which must be treated next real veldel ! direction of the velocity real*8 pntdel ! point real zdel, edel ! charge of current electrons ! which must be produced and energy of Delta integer Stdel ! Generation number integer Ptdel ! pointer to parent virtual photon integer updel ! additional parameters integer SOdel ! 1 for ouger electrons 0 for other integer nVoldel ! Number of volume real*8 rangedel ! range real*8 rangepdel ! practical range integer qstepdel ! quantity of steps of simulation ! of stopping integer sOverflowDel ! sign of overflow in the current event integer qsOverflowDel ! quantity of the overflows in all events integer qOverflowDel ! quantity of the lossed electrons ! in all events integer ii1del ! not used. only for alingment. common / comdel / + qdel, ii1del, + pntdel(3,pqdel), veldel(3,pqdel), + rangedel(pqdel),rangepdel(pqdel), qstepdel(pqdel), + zdel(pqdel), edel(pqdel), nVoldel(pqdel), + Stdel(pqdel), Ptdel(pqdel), updel(pqup,pqdel), SOdel(pqdel), + sOverflowDel, qsOverflowDel,qOverflowDel save / comdel / +KEEP,cel. c Conductin electrons in sensitive volumes c Currently each the electron is considered as cluster integer pqcel ! Max. q of clusters parameter (pqcel=5000) c parameter (pqcel=1000000) ! If this, reduce numbers of volumes c parameter (pqcel=100000) ! If this, reduce numbers of volumes integer qcel ! Q. of clusters real*8 pntcel ! point of cluster real zcel ! charge in unit of quantity of electron ! in this cluster (now it is always 1) real szcel ! sum quantity of charge in the volume integer Ndelcel ! number of parent delta electron integer sOverflowCel ! sign of overflow in the current event integer qsOverflowCel ! quantity of the overflows in all events integer qOverflowCel ! quantity of the lossed electrons ! in all events integer sactcel ! auxiliary sing. ! It set to one if the delta-electron either ! was born in an insensitive lawer or ! after it had flied through an insensitive lawer. common / comcel / + pntcel(3,pqcel,pQSVol), + qcel(pQSVol), + zcel(pqcel,pQSVol), + szcel(pQSVol), + Ndelcel(pqcel,pQSVol), + sactcel(pqcel,pQSVol), + sOverflowCel(pQSVol), qsOverflowCel(pQSVol),qOverflowCel(pQSVol) save / comcel / +KEEP,lsgvga. c Results of ionization loss calculations c It is used only for hist filling integer pqgvga parameter (pqgvga=1000) integer qgvga,ganumat,ganumshl real esgvga,egvga,velgvga real*8 pntgvga common / clsgva / + qgvga(pQIVol), + esgvga(pQIVol), + egvga(pqgvga,pQIVol), + pntgvga(3,pqgvga,pQIVol), + velgvga(3,pqgvga,pQIVol), + ganumat(pqgvga,pQIVol), + ganumshl(pqgvga,pQIVol) save / clsgva / +KEEP,abs. c Gamma which is ready to absorb c There are two sorts of gamma c Real gamma after their absorbtion points are known and c virtual gamma from ionization loss integer pqtagam ! Max quantity of absorbtion gamma parameter (pqtagam=100000) integer qtagam, ctagam ! Full quantity and current number ! of gamma which will be treat next. ! If ctagam>qtagam then ! there is no gamma to treat. real etagam, vtagam ! Energy, and velocity ! direction of absorbtion gamma real*8 rtagam ! position of absorbtion gamma integer nVolagam ! Volume number for this point integer nAtagam,nshlagam ! Number of atom and shell ! which absorbe this photon integer Stagam ! Generation number integer upagam ! additional parameters integer sOverflowagam ! sign of overflow in the current event integer qsOverflowagam ! quantity of the overflows in all events integer qOverflowagam ! quantity of the lossed electrons ! in all events common / comabs / + qtagam, ctagam, etagam(pqtagam), + rtagam(3,pqtagam), vtagam(3,pqtagam), + nVolagam(pqtagam),nAtagam(pqtagam),nShlagam(pqtagam), + Stagam(pqtagam), upagam(pqup,pqtagam), + sOverflowagam, qsOverflowagam,qOverflowagam save / comabs / +KEEP,rga. c Real photons integer pqrga parameter (pqrga=1000) integer qrga, crga real velrga, erga real*8 pntrga integer Strga ! generation integer Ptrga ! pointer to parent integer uprga ! number of trans vol integer SFrga ! sign of fly out integer nVolrga integer sOverflowrga ! sign of overflow in the current event integer qsOverflowrga ! quantity of the overflows in all events integer qOverflowrga ! quantity of the lossed photons ! in all events common / comrga / + qrga, crga, + pntrga(3,pqrga), velrga(3,pqrga), erga(pqrga), + nVolrga(pqrga), Strga(pqrga), Ptrga(pqrga), uprga(pqup,pqrga), + SFrga(pqrga), + sOverflowrga, qsOverflowrga,qOverflowrga save / comrga / +KEEP,h1. integer qhis ! Quantity of the divisions in ! the additional histograms ! with numbers started from 30000 parameter (qhis=500) real hhis ! step by coordinate real mhis ! maximal coordinate shift parameter (mhis=200.0) integer pqamp ! maximal quantity of the amplitude cuts parameter (pqamp=11) integer qamp ! real quantity of the amplitude cuts real amp real ampc ! values of the amplitude cuts integer npp ! number of events passed through cuts ! The following two arrays: ! During event processing ! pp1 - sum of the coordinates of the centers ! pp2 - sum of the square of ! the coordinates of the centers ! After the last event processed ! they become: ! pp1 - mean coordinate ! pp2 - mean square deviation real*8 pp1 real*8 pp2 ! The following two arrays are filled after ! the last event processed and they have the same ! meaning, but different type. ! They are intended for filling of histograms real rpp1 real rpp2 real prob ! probability of the clusters real meanprob ! mean number of ionization real meanvga ! mean number of the energy transfers real meanvgal ! mean energy loss, KeV integer qe common / h31 / + pp1(1000,2,pqamp), pp2(1000,2,pqamp),hhis, npp(1000,2,pqamp), + rpp1(1000,2,pqamp), rpp2(1000,2,pqamp), + amp(pqamp),ampc(pqamp),qamp, + prob(1000),meanprob,meanvga,meanvgal, + qe +KEEP,shl. integer pqschl,pqshl,pqatm,pqsel,pqsga parameter (pqschl=3) ! Max. q. of channels parameter (pqshl=7) ! Max. q. of shells parameter (pqatm=20) ! Max. q. of atoms parameter (pqsel=3) ! Max. q. of secondary electrons in ! one channel parameter (pqsga=3) ! Max. q. of secondary photons in ! one channel integer qschl,qshl,qatm,qsel,qsga real charge ! charge of atom real eshell ! energy of shells ! The distanse must be bigger the ! threshold in the atom.inc ! if secondary photons is generated real secprobch ! Probubility function for channels ! Attention!!! - Probubility function ! i.e. last channel prob must be 1 real secenel ! Energies of secondary electrons real secenga ! Energies of secondary photons common / comshl / + charge(pqatm), + qschl(pqshl,pqatm),qshl(pqatm),qatm, + qsel(pqschl,pqshl,pqatm),qsga(pqschl,pqshl,pqatm), + eshell(pqshl,pqatm),secprobch(pqschl,pqshl,pqatm), + secenel(pqsel,pqschl,pqshl,pqatm), + secenga(pqsga,pqschl,pqshl,pqatm) save / comshl / +KEEP,LibAtMat. c Numbers(pointers) of atoms in atom.inc. c Since for some of them a special treatment is provided c in subroutine Iniatom and this subroutine recognize them by number, c the user must not initialize another atoms on these places, c even if subroutine AtomsByDefault is not called. c Another atoms can be initialized on free places. integer num_H integer num_H3 integer num_H4 integer num_He integer num_Li integer num_C integer num_C1 integer num_C2 integer num_C3 c integer num_C4 integer num_N integer num_O integer num_F integer num_Ne integer num_Al integer num_Si integer num_Ar integer num_Kr integer num_Xe parameter (num_H = 1 ) parameter (num_H3 = 2 ) parameter (num_H4 = 3 ) parameter (num_He = 4 ) parameter (num_Li = 5 ) parameter (num_C = 6 ) parameter (num_N = 7 ) parameter (num_O = 8 ) parameter (num_F = 9 ) parameter (num_Ne =10 ) parameter (num_Al = 11 ) parameter (num_Si = 12 ) parameter (num_Ar = 13 ) parameter (num_Kr = 14 ) parameter (num_Xe = 15 ) parameter (num_C1 = 16 ) ! C in CO2 parameter (num_C2 = 17 ) ! C in CF4 parameter (num_C3 = 18 ) ! C in CH4 *** Additions (RV 20/9/99). integer num_S parameter (num_S = 19) *** End of additions. +KEEP,shellfi. integer pqash ! Max. q. of shells parameter (pqash=7) integer zato ! Z of atom integer qash ! quantity of shells real athreshold,aweight ! threshold and weight of shells integer pqaener,qaener ! Max. and just q. of shell energy parameter (pqaener=500) real aener ! Energy real aphot ! Photoabsorbtion crossection ! for this point of energy common / cshellfi / + zato, + qash, + athreshold(pqash),aweight(pqash), + qaener(pqash), + aener(pqaener,pqash),aphot(pqaener,pqash) save / cshellfi / +KEEP,tpasc. integer pqshPas parameter (pqshPas=5) integer qshPas integer lPas real E0Pas,EthPas,ywPas,yaPas,PPas,sigma0Pas common / Pascom / + qshPas(pQAt), + lPas(pqshPas,pQAt), + E0Pas(pqshPas,pQAt),EthPas(pqshPas,pQAt),ywPas(pqshPas,pQAt), + yaPas(pqshPas,pQAt),PPas(pqshPas,pQAt),sigma0Pas(pqshPas,pQAt) save / Pascom / +KEEP,henke6. qash=2 qaener(1)=10 athreshold(1)=291 aener(1,1)=311.7 aphot(1,1)=0.839895 aener(2,1)=392.4 aphot(2,1)=0.49875 aener(3,1)=452.2 aphot(3,1)=0.35112 aener(4,1)=676.8 aphot(4,1)=0.127082 aener(5,1)=776.2 aphot(5,1)=0.0887775 aener(6,1)=1011.7 aphot(6,1)=0.0428925 aener(7,1)=2984.3 aphot(7,1)=0.00183341 aener(8,1)=5414.7 aphot(8,1)=0.000293265 aener(9,1)=9886.4 aphot(9,1)=4.2693e-05 aener(10,1)=29779 aphot(10,1)=1.04339e-06 qaener(2)=13 athreshold(2)=8.9 aener(1,2)=10.2 aphot(1,2)=5.9052 aener(2,2)=13 aphot(2,2)=11.97 aener(3,2)=15 aphot(3,2)=13.965 aener(4,2)=21.2 aphot(4,2)=12.0299 aener(5,2)=30.5 aphot(5,2)=6.00495 aener(6,2)=49.3 aphot(6,2)=2.0349 aener(7,2)=72.4 aphot(7,2)=0.96558 aener(8,2)=108.5 aphot(8,2)=0.408975 aener(9,2)=114 aphot(9,2)=0.369075 aener(10,2)=132.8 aphot(10,2)=0.265335 aener(11,2)=192.6 aphot(11,2)=0.112119 aener(12,2)=220.1 aphot(12,2)=0.0776055 aener(13,2)=277 aphot(13,2)=0.039102 +KEEP,track. c The track information about the primary particle integer sign_ang ! sign to run the part. with effective angle real ang ! teta real phiang ! phi real ystart ! start Y coordinate integer srandtrack ! sign to randomize the Y coordinate ! between ystart1 and ystart2 ! It is done by call IniNTrack from GoEvent ! if the track initialization was done by ! call IniRTrack real ystart1 real ystart2 real sigmaang ! sigma of begin angle distribution !Currently, if sigmaang>0, the rundomization ! is doing around the 0 angle. ! So the values of pang and pphiang are ignored ! It can be changed by modernization ! of IniNTrack real e1ang,e2ang,e3ang ! coordinates of new orts in the old integer sigmtk ! sign of multiple scatering integer pQmtk ! max. quantity of the break point of the track ! plus one parameter (pQmtk=10000) integer Qmtk ! actual quantity for current event real*8 pntmtk ! break point coordinates real velmtk ! directions of velocity real*8 lenmtk ! lengt of way for straight till next break real Tetamtk ! turn angle integer nVolmtk ! number of volume for given point, ! the point on the frantier is correspond ! to next volume of zero for end. real*8 vlenmtk ! lengt of way inside the volume integer nmtkvol1,nmtkvol2 ! numbers of first point in volume ! and the previous for end point real*8 xdvmtk,ydvmtk ! deviations from strate line ! using only for histograms ! service data. They are using at initialization of the track. integer sruthmtk ! key to use Rutherford cross section integer nmtk ! current number of point. ! After initialization it must be equal to Qmtk+1 integer sgnmtk ! sign to go to next volume integer sturnmtk ! sign to turn real*8 lammtk ! mean free path real mlammtk ! minimum mean lengt of range ! multiplied by density. sm*gr/sm**3 = gr/sm**2 real mTetacmtk ! minimum threshold turn angle real Tetacmtk ! threshold turn angle real rTetacmtk ! restiction due to atomic shell real*8 CosTetac12mtk ! cos(tetac/2) real*8 SinTetac12mtk ! sin(tetac/2) c real CosTetac12mtk ! cos(tetac/2) c real SinTetac12mtk ! sin(tetac/2) real msigmtk ! msig without sqrt(x) real e1mtk,e2mtk,e3mtk common / ctrack / + sign_ang, ang, phiang, ystart, srandtrack, ystart1, ystart2, + e1ang(3),e2ang(3),e3ang(3), + sigmtk, + sruthmtk, + Qmtk, nmtk, + pntmtk(3,pQmtk), velmtk(3,pQmtk), lenmtk(pQmtk), Tetamtk(pQmtk), + nVolmtk(pQmtk), vlenmtk(pQVol), + nmtkvol1(pQVol), nmtkvol2(pQVol), + xdvmtk(pQSVol),ydvmtk(pQSVol), + sgnmtk, sturnmtk, + lammtk(pQMat), mlammtk, mTetacmtk, + Tetacmtk(pQMat), + rTetacmtk(pQMat), + CosTetac12mtk(pQMat), SinTetac12mtk(pQMat), msigmtk, + e1mtk(3,pQmtk),e2mtk(3,pQmtk),e3mtk(3,pQmtk), + sigmaang save / ctrack / +KEEP,raffle. integer pQGRaf ! Max. quantity of energy transfer parameter (pQGRaf=10000) integer QGRaf ! Quantity of energy transfers integer NAtGRaf,NShAtGRaf ! Numbers of atom and shell real ESGRaf,EGRaf ! Cumulative energy and just energy real pntraf,velraf common / craffle / + QGRaf, + ESGRaf, + EGRaf(pQGRaf), + NAtGRaf(pQGRaf), + NShAtGRaf(pQGRaf) , + pntraf(3,pQGRaf), velraf(3,pQGRaf) save / craffle / +KEEP,bdel. c Information about tracing of current delta-electron c real eMinBdel ! some condition step by energy ! (the name is obsolete) ! If step is larger than eMinBdel and 0.1*eBdel ! the step is equate to 0.1*eBdel ! In this case step can not be less than eMinBdel ! and larger than eBdel integer iMinBdel ! not using now real eLossBdel ! array with energy loss for ! all the matters real betaBdel real beta2Bdel real momentumBdel real momentum2Bdel real*8 lamaBdel real msigBdel integer nBdel ! number of the delta-electron ! in the del.inc, which is ! traced now real eBdel ! the current energy real*8 pntBdel,npntBdel ! current point and next point ! Next is calc. in ! subroutine SstepBdel ! and moved to current in ! subroutine treatdel real*8 stepBdel ! step - sm real estepBdel ! and MeV real velBdel ! direction of the velocity real e1Bdel, e2Bdel, e3Bdel ! coordinate axises, ! e3Bdel is along to velocity ! e2Bdel is perpend. to e3Bdel and x ! e1Bdel is perpend to e2Bdel and e3Bdel integer nVolBdel,sgonextBdel ! number of current volume ! and sign to go to next volume integer sturnBdel ! sign of turn real TetacBdel,TetaBdel ! threshold turn angle and ! actual angle real CosTetac12Bdel,SinTetac12Bdel real rTetacBdel ! restiction due to atomic shell real*8 lamBdel ! mean lengt of range real mlamBdel ! minimum mean lengt of range ! multiplied by density. sm*gr/sm**3 = gr/sm**2 real mTetacBdel ! minimum threshold turn angle ! For Rutherford: ! The interactions with less angle will not take ! into account. The actual threshold angle can be ! larger. The second restriction is going ! from restriction of atomic shell. ! The third one is from mlamBdel. ! For usial multiple scatering: ! Assuming that sigma = mTetacBdel ! the paht lengt is calculating. ! If mlamBdel/density is less then the last is using. integer iBdel ! index of current energy ! in the enerc array integer StBdel ! Origin and generation sign ! <10000 - origin is ionization loss ! >=10000 - origin is transition radiation ! 1 or 10000 first generation ! 2 or 10001 second generation ! 3 or 10002 third, et al. integer NtvBdel ! Only for transition gammas: ! number of transition volume, where it was born integer SOBdel ! 1 for ouger electrons 0 for other real*8 rangBdel ! whole delta-electron range real*8 rangpBdel ! mean projection of delta-electron range ! The maximum projection lengt of ! current electron point on the ! primary velocity. integer sruthBdel ! sign of use ! 1 - Rutherford cross-section ! 0 - usial multiple scatering formula integer sisferBdel ! sign that the mean or the cut turn angle ! is so big that there are no sense to turn ! the particle. Insterd that the sferical simmetric ! velocity is genegating. It is much more faster. integer sisferaBdel real cuteneBdel integer nstepBdel parameter (cuteneBdel=1.0e-3) common / cbdel / + lamaBdel(pqener,pQMat), + pntBdel(3),npntBdel(3), + stepBdel, lamBdel, + rangBdel,rangpBdel, + eMinBdel, iMinBdel, + eLossBdel(pqener,pQMat), + betaBdel(pqener), beta2Bdel(pqener), + momentumBdel(pqener), momentum2Bdel(pqener), + msigBdel(pqener), + rTetacBdel(pqener,pQMat), + nBdel,eBdel, + estepBdel, + velBdel(3), + e1Bdel(3),e2Bdel(3),e3Bdel(3), + nVolBdel,sgonextBdel,sturnBdel, + TetacBdel(pqener,pQMat), + CosTetac12Bdel(pqener,pQMat), + SinTetac12Bdel(pqener,pQMat), + TetaBdel, + mlamBdel,mTetacBdel, + iBdel, + StBdel,NtvBdel,SOBdel, + sruthBdel, + sisferBdel, + sisferaBdel(pqener,pQMat), + nstepBdel save / cbdel / c below there are the values for exact elastic c scatering integer pqanCBdel parameter (pqanCBdel=31) integer qanCBdel parameter (qanCBdel=30) real anCBdel real ancCBdel integer pqeaCBdel parameter (pqeaCBdel=10) integer qeaCBdel parameter (qeaCBdel=9) real enerCBdel, enercCBdel real sign_ACBdel ! sign that the parameters are read real ACBdel ! parameters real CCBdel real BCBdel real sCBdel ! cross section, Angstrem**2 / strd real sRCBdel ! Rutherford cross section for comparison real sRmCBdel ! maximum of Rutherford die to cut real sRcmCBdel ! the cut angle again real smaCBdel ! cross section for material per one av. atom, ! in MeV**-2/rad real smatCBdel ! cross section for material per one av. atom, ! in MeV**-2/rad, for working energy mesh real ismatCBdel ! normalized integral real tsmatCBdel ! integral real gammaCBdel real beta2CBdel real momentum2CBdel real rrCBdel ! range by usual formula real koefredCBdel ! koef for derivation of step ! from usual formula parameter (koefredCBdel=0.02) common / cbdel1 / + anCBdel(pqanCBdel), ancCBdel(pqanCBdel), + enerCBdel(pqeaCBdel), enercCBdel(pqeaCBdel), + sign_ACBdel(pqAt), + ACBdel(4,pqeaCBdel,pqAt), CCBdel(0:6,pqeaCBdel,pqAt), + BCBdel(pqeaCBdel,pqAt), + sCBdel(pqanCBdel,pqeaCBdel,pqAt), + sRCBdel(pqanCBdel,pqeaCBdel,pqAt), + sRmCBdel(pqeaCBdel,pqAt), + sRcmCBdel(pqeaCBdel,pqAt), + smaCBdel(pqanCBdel,pqeaCBdel,pQMat), + smatCBdel(pqanCBdel,pqener,pQMat), + ismatCBdel(pqanCBdel,pqener,pQMat), + tsmatCBdel(pqener,pQMat), + gammaCBdel(pqeaCBdel), beta2CBdel(pqeaCBdel), + momentum2CBdel(pqeaCBdel), + rrCBdel(pqener,pQMat) save / cbdel1 / real MagForFBdel real EleForFBdel real veloBdel common / cbdel2 / + MagForFBdel(3), EleForFBdel(3), + veloBdel(3) save / cbdel2 / +KEEP,cbdeldat. data ZsCBdel(1)/ 1 / data (AsCBdel( 1 , i, 1 ),i=1,9)/ + -0.9007, -0.6539, -0.3655, -0.5499, -0.0196, + 0.04526, -0.658, 0.008393, -0.3739 / data (AsCBdel( 2 , i, 1 ),i=1,9)/ + 0.3975, 0.338, 0.2884, 0.3151, 0.2809, + 0.2774, 0.3126, 0.2787, 0.2928 / data (AsCBdel( 3 , i, 1 ),i=1,9)/ + 0.002344, 0.003208, 0.00294, 0.001429, 0.0009329, + 0.00041, 3.017e-05, 0.0001038, 1.757e-05 / data (AsCBdel( 4 , i, 1 ),i=1,9)/ + -3.534e-05, -1.59e-05, -5.392e-06, 9.522e-06, 8.538e-07, + -4.278e-08, 7.506e-07, 4.492e-09, 3.551e-08 / data (CsCBdel( 0 , i, 1 ),i=1,9)/ + 1.105, 0.8986, 0.6487, 0.8062, 0.01901, + -0.09682, 0.9669, -0.1011, 0.4769 / data (CsCBdel( 1 , i, 1 ),i=1,9)/ + 1.172, 1.05, 0.9256, 0.9955, 0.02643, + -0.1263, 1.229, -0.141, 0.6287 / data (CsCBdel( 2 , i, 1 ),i=1,9)/ + 0.7611, 0.7519, 0.8045, 0.751, 0.02258, + -0.1017, 0.9513, -0.1224, 0.5042 / data (CsCBdel( 3 , i, 1 ),i=1,9)/ + 0.4001, 0.4377, 0.5676, 0.4597, 0.01605, + -0.06736, 0.5969, -0.08834, 0.3282 / data (CsCBdel( 4 , i, 1 ),i=1,9)/ + 0.1718, 0.2092, 0.3277, 0.2304, 0.009861, + -0.03748, 0.3072, -0.05421, 0.176 / data (CsCBdel( 5 , i, 1 ),i=1,9)/ + 0.05558, 0.07568, 0.1426, 0.08723, 0.004891, + -0.0164, 0.1202, -0.02652, 0.07261 / data (CsCBdel( 6 , i, 1 ),i=1,9)/ + 0.01031, 0.01571, 0.03491, 0.01878, 0.00171, + -0.004697, 0.02774, -0.008267, 0.0182 / data (BsCBdel( i, 1 ),i=1,9)/ + 0.008057, 0.004506, 0.002592, 0.001872, 0.0008431, + 0.0003444, 0.0003049, 8.926e-05, 6.648e-05 / data ZsCBdel(2)/ 2 / data (AsCBdel( 1 , i, 2 ),i=1,9)/ + 0.0327, -0.4242, -0.6746, -0.6343, -0.2289, + -0.3277, -0.2001, -1.227, -0.3022 / data (AsCBdel( 2 , i, 2 ),i=1,9)/ + 0.3427, 0.3746, 0.363, 0.3388, 0.2998, + 0.298, 0.2891, 0.3407, 0.2914 / data (AsCBdel( 3 , i, 2 ),i=1,9)/ + -0.00727, -0.002397, -0.001851, -0.0009558, 0.001271, + 0.0006719, 0.000343, -9.27e-05, 7.883e-05 / data (AsCBdel( 4 , i, 2 ),i=1,9)/ + 5.556e-05, 2.941e-06, 3.477e-06, 9.459e-07, 1.384e-11, + 1.73e-07, -7.566e-14, 6.887e-07, 4.899e-08 / data (CsCBdel( 0 , i, 2 ),i=1,9)/ + -0.09725, 0.4519, 0.8681, 0.8734, 0.3088, + 0.4817, 0.2759, 1.81, 0.3546 / data (CsCBdel( 1 , i, 2 ),i=1,9)/ + -0.1434, 0.4205, 0.9635, 1.028, 0.3654, + 0.6172, 0.3678, 2.294, 0.4574 / data (CsCBdel( 2 , i, 2 ),i=1,9)/ + -0.1141, 0.2335, 0.6551, 0.7411, 0.2638, + 0.4836, 0.3015, 1.763, 0.3535 / data (CsCBdel( 3 , i, 2 ),i=1,9)/ + -0.06887, 0.1, 0.3606, 0.4342, 0.1544, + 0.3089, 0.2039, 1.09, 0.2158 / data (CsCBdel( 4 , i, 2 ),i=1,9)/ + -0.03233, 0.03143, 0.1606, 0.2074, 0.07401, + 0.1633, 0.1164, 0.5456, 0.1024 / data (CsCBdel( 5 , i, 2 ),i=1,9)/ + -0.01082, 0.00537, 0.05227, 0.0725, 0.0269, + 0.0664, 0.05306, 0.2027, 0.0328 / data (CsCBdel( 6 , i, 2 ),i=1,9)/ + -0.00182, -0.000404, 0.008547, 0.01166, 0.005736, + 0.01634, 0.01557, 0.04167, 0.006162 / data (BsCBdel( i, 2 ),i=1,9)/ + 0.01206, 0.007727, 0.00318, 0.001359, 0.001657, + 0.0008551, 0.0004051, 0.0003179, 0.0001234 / data ZsCBdel(3)/ 3 / data (AsCBdel( 1 , i, 3 ),i=1,9)/ + 1.427, 1.875, 1.99, 1.699, 1.07, + 0.6406, -0.4004, -0.3638, -1.191 / data (AsCBdel( 2 , i, 3 ),i=1,9)/ + 0.05527, 0.09522, 0.1452, 0.1939, 0.2375, + 0.2604, 0.3007, 0.2984, 0.3292 / data (AsCBdel( 3 , i, 3 ),i=1,9)/ + -0.0002502, -0.0006965, -0.0008232, -0.000703, -0.0005227, + -0.0003072, -0.0002339, -0.0001217, -0.0001381 / data (AsCBdel( 4 , i, 3 ),i=1,9)/ + 2.705e-05, 1.05e-05, 4.396e-06, 1.701e-06, 6.296e-07, + 1.826e-07, 7.576e-08, 2.354e-08, 3.617e-08 / data (CsCBdel( 0 , i, 3 ),i=1,9)/ + -1.541, -2.386, -2.805, -2.555, -1.683, + -1.062, 0.5774, 0.4788, 1.77 / data (CsCBdel( 1 , i, 3 ),i=1,9)/ + -1.472, -2.601, -3.317, -3.176, -2.153, + -1.397, 0.7406, 0.6022, 2.303 / data (CsCBdel( 2 , i, 3 ),i=1,9)/ + -0.8666, -1.737, -2.391, -2.401, -1.672, + -1.115, 0.5758, 0.4548, 1.815 / data (CsCBdel( 3 , i, 3 ),i=1,9)/ + -0.4155, -0.9407, -1.395, -1.469, -1.047, + -0.718, 0.3605, 0.2727, 1.152 / data (CsCBdel( 4 , i, 3 ),i=1,9)/ + -0.1638, -0.4176, -0.6643, -0.7343, -0.5343, + -0.3768, 0.1825, 0.1288, 0.5931 / data (CsCBdel( 5 , i, 3 ),i=1,9)/ + -0.04905, -0.1403, -0.2385, -0.2776, -0.2048, + -0.1487, 0.06829, 0.04247, 0.2284 / data (CsCBdel( 6 , i, 3 ),i=1,9)/ + -0.00851, -0.02708, -0.04885, -0.06059, -0.04461, + -0.03362, 0.01358, 0.006216, 0.05031 / data (BsCBdel( i, 3 ),i=1,9)/ + 0.004125, 0.002188, 0.001189, 0.0006433, 0.000348, + 0.0001781, 9.893e-05, 5.406e-05, 5.406e-05 / data ZsCBdel(4)/ 6 / data (AsCBdel( 1 , i, 4 ),i=1,9)/ + -0.2288, -0.158, -0.002296, 0.1188, -0.113, + -0.1099, -0.2114, -0.321, -0.3712 / data (AsCBdel( 2 , i, 4 ),i=1,9)/ + 0.1755, 0.1774, 0.1813, 0.1927, 0.2573, + 0.2617, 0.2751, 0.2829, 0.286 / data (AsCBdel( 3 , i, 4 ),i=1,9)/ + -0.000567, 0.001007, 0.0005522, -0.0002222, -0.0006304, + -0.0003796, -0.0002618, -0.0001435, -7.271e-05 / data (AsCBdel( 4 , i, 4 ),i=1,9)/ + -2.822e-06, -6.323e-06, -1.751e-06, 8.23e-08, 7.391e-06, + 2.077e-06, 6.244e-07, 1.488e-07, 3.304e-08 / data (CsCBdel( 0 , i, 4 ),i=1,9)/ + 0.5481, 0.5514, 0.4277, 0.2874, 0.4173, + 0.4084, 0.4764, 0.5723, 0.5971 / data (CsCBdel( 1 , i, 4 ),i=1,9)/ + 0.7001, 0.8468, 0.8727, 0.8116, 0.7996, + 0.8204, 0.8368, 0.9077, 0.9267 / data (CsCBdel( 2 , i, 4 ),i=1,9)/ + 0.5164, 0.6987, 0.8691, 0.9514, 0.8364, + 0.9003, 0.8566, 0.8596, 0.8603 / data (CsCBdel( 3 , i, 4 ),i=1,9)/ + 0.3055, 0.4423, 0.6429, 0.7965, 0.6723, + 0.7587, 0.695, 0.6525, 0.6395 / data (CsCBdel( 4 , i, 4 ),i=1,9)/ + 0.1493, 0.2224, 0.3722, 0.5125, 0.4275, + 0.5034, 0.4532, 0.3989, 0.381 / data (CsCBdel( 5 , i, 4 ),i=1,9)/ + 0.05661, 0.08288, 0.1587, 0.2398, 0.2002, + 0.2435, 0.2194, 0.1783, 0.1645 / data (CsCBdel( 6 , i, 4 ),i=1,9)/ + 0.01273, 0.01736, 0.03764, 0.06171, 0.05196, + 0.06335, 0.05949, 0.04171, 0.0395 / data (BsCBdel( i, 4 ),i=1,9)/ + 0.005592, 0.003821, 0.0019, 0.0004467, 0.00118, + 0.0005983, 0.0003049, 0.0001453, 6.647e-05 / data ZsCBdel(5)/ 7 / data (AsCBdel( 1 , i, 5 ),i=1,9)/ + -0.2683, -0.1095, -0.2076, 1.155, 1.192, + 1.083, 0.6177, 0.6945, 0.1072 / data (AsCBdel( 2 , i, 5 ),i=1,9)/ + 0.1794, 0.1917, 0.2207, 0.1476, 0.1849, + 0.2177, 0.2517, 0.2517, 0.2784 / data (AsCBdel( 3 , i, 5 ),i=1,9)/ + -0.002106, -0.001189, 0.001094, 0.001768, 0.0006366, + 0.0001047, -0.0001064, -1.845e-05, -5.791e-05 / data (AsCBdel( 4 , i, 5 ),i=1,9)/ + 8.363e-06, 2.424e-06, 6.217e-05, 4.937e-07, 3.26e-06, + 1.638e-06, 7.072e-07, 8.12e-08, 4.488e-08 / data (CsCBdel( 0 , i, 5 ),i=1,9)/ + 0.587, 0.3883, 0.5649, -1.409, -1.614, + -1.596, -0.9572, -1.143, -0.2718 / data (CsCBdel( 1 , i, 5 ),i=1,9)/ + 0.7239, 0.5554, 0.865, -1.48, -1.836, + -1.934, -1.17, -1.441, -0.327 / data (CsCBdel( 2 , i, 5 ),i=1,9)/ + 0.5231, 0.4279, 0.73, -0.9541, -1.274, + -1.429, -0.8647, -1.105, -0.2408 / data (CsCBdel( 3 , i, 5 ),i=1,9)/ + 0.2991, 0.2539, 0.4765, -0.4998, -0.7137, + -0.8552, -0.5104, -0.6825, -0.1421 / data (CsCBdel( 4 , i, 5 ),i=1,9)/ + 0.1378, 0.1199, 0.2486, -0.2148, -0.3255, + -0.419, -0.2401, -0.3423, -0.06744 / data (CsCBdel( 5 , i, 5 ),i=1,9)/ + 0.0478, 0.04201, 0.09691, -0.06986, -0.1112, + -0.1557, -0.08076, -0.1293, -0.02457 / data (CsCBdel( 6 , i, 5 ),i=1,9)/ + 0.00979, 0.008339, 0.02151, -0.01307, -0.02128, + -0.03377, -0.01323, -0.02937, -0.006507 / data (BsCBdel( i, 5 ),i=1,9)/ + 0.005535, 0.002575, 0.005228, 0.002104, 0.00129, + 0.0007012, 0.0003761, 0.0001529, 8.43e-05 / data ZsCBdel(6)/ 8 / data (AsCBdel( 1 , i, 6 ),i=1,9)/ + -0.3151, -0.4143, -0.3378, 0.775, 1.151, + 1.043, 0.8495, 0.6484, 0.6268 / data (AsCBdel( 2 , i, 6 ),i=1,9)/ + 0.1565, 0.2123, 0.228, 0.1668, 0.1769, + 0.2119, 0.2388, 0.2526, 0.2555 / data (AsCBdel( 3 , i, 6 ),i=1,9)/ + 0.005179, 0.0008074, 0.002091, 0.00213, 0.001118, + 0.0003669, 5.394e-05, 5.051e-06, 1.052e-05 / data (AsCBdel( 4 , i, 6 ),i=1,9)/ + -7.102e-05, -1.079e-05, 5.928e-05, 6.685e-12, 7.192e-07, + 1.642e-06, 7.253e-07, 1.528e-07, 1.002e-08 / data (CsCBdel( 0 , i, 6 ),i=1,9)/ + 0.6907, 0.8183, 0.7333, -0.8508, -1.514, + -1.489, -1.311, -1.053, -1.081 / data (CsCBdel( 1 , i, 6 ),i=1,9)/ + 0.8607, 1.068, 1.04, -0.8104, -1.685, + -1.755, -1.622, -1.305, -1.363 / data (CsCBdel( 2 , i, 6 ),i=1,9)/ + 0.6281, 0.8144, 0.8428, -0.4708, -1.148, + -1.259, -1.224, -0.9807, -1.045 / data (CsCBdel( 3 , i, 6 ),i=1,9)/ + 0.3597, 0.4966, 0.5392, -0.2198, -0.6336, + -0.728, -0.7484, -0.5893, -0.6437 / data (CsCBdel( 4 , i, 6 ),i=1,9)/ + 0.1652, 0.2472, 0.28, -0.08269, -0.2864, + -0.3417, -0.3747, -0.2827, -0.3206 / data (CsCBdel( 5 , i, 6 ),i=1,9)/ + 0.05686, 0.09356, 0.11, -0.02291, -0.09803, + -0.1195, -0.1422, -0.09731, -0.1192 / data (CsCBdel( 6 , i, 6 ),i=1,9)/ + 0.01108, 0.02049, 0.02459, -0.003431, -0.01939, + -0.02313, -0.03158, -0.01668, -0.02626 / data (BsCBdel( i, 6 ),i=1,9)/ + 0.01527, 0.006677, 0.006234, 0.002632, 0.001398, + 0.0008426, 0.0004476, 0.0002062, 7.411e-05 / data ZsCBdel(7)/ 9 / data (AsCBdel( 1 , i, 7 ),i=1,9)/ + -0.271, -0.1705, -0.4203, -0.08103, 0.847, + 1.032, 0.9064, 0.737, 0.7296 / data (AsCBdel( 2 , i, 7 ),i=1,9)/ + 0.06297, 0.1982, 0.2525, 0.2293, 0.1892, + 0.2059, 0.2323, 0.247, 0.251 / data (AsCBdel( 3 , i, 7 ),i=1,9)/ + 0.0192, -0.001907, 0.001649, -0.0005853, 0.001314, + 0.0006477, 0.0002021, 6.899e-05, 2.812e-05 / data (AsCBdel( 4 , i, 7 ),i=1,9)/ + -1.458e-05, 6.353e-06, 0.0001059, 4.938e-07, 1.198e-13, + 1e-06, 7.184e-07, 1.568e-07, 3.663e-09 / data (CsCBdel( 0 , i, 7 ),i=1,9)/ + 0.8256, 0.4602, 0.7589, 0.3443, -1.043, + -1.44, -1.373, -1.174, -1.261 / data (CsCBdel( 1 , i, 7 ),i=1,9)/ + 1.154, 0.6192, 0.9765, 0.5852, -1.093, + -1.665, -1.676, -1.445, -1.601 / data (CsCBdel( 2 , i, 7 ),i=1,9)/ + 0.92, 0.4733, 0.7312, 0.5192, -0.6998, + -1.174, -1.249, -1.08, -1.243 / data (CsCBdel( 3 , i, 7 ),i=1,9)/ + 0.5763, 0.2837, 0.4353, 0.3475, -0.3624, + -0.6677, -0.7544, -0.6459, -0.7811 / data (CsCBdel( 4 , i, 7 ),i=1,9)/ + 0.2949, 0.1363, 0.2107, 0.1826, -0.1537, + -0.3085, -0.3728, -0.309, -0.3993 / data (CsCBdel( 5 , i, 7 ),i=1,9)/ + 0.1166, 0.04879, 0.07714, 0.07063, -0.04901, + -0.1063, -0.1396, -0.1066, -0.1488 / data (CsCBdel( 6 , i, 7 ),i=1,9)/ + 0.0272, 0.009832, 0.01628, 0.01543, -0.009001, + -0.02032, -0.0305, -0.01865, -0.03074 / data (BsCBdel( i, 7 ),i=1,9)/ + 0.02583, 0.004772, 0.007849, 0.001104, 0.001634, + 0.0009459, 0.0005241, 0.0002429, 7.913e-05 / data ZsCBdel(8)/ 13 / data (AsCBdel( 1 , i, 8 ),i=1,9)/ + -0.4378, -0.3167, -0.2708, -0.212, -0.2487, + -0.2509, -0.234, -0.265, -0.2887 / data (AsCBdel( 2 , i, 8 ),i=1,9)/ + 0.0923, 0.1454, 0.1968, 0.2238, 0.244, + 0.2547, 0.2598, 0.2632, 0.2677 / data (AsCBdel( 3 , i, 8 ),i=1,9)/ + -0.001988, -0.003033, -0.00252, -0.001545, -0.0008717, + -0.0004561, -0.0002297, -0.0001108, -5.184e-05 / data (AsCBdel( 4 , i, 8 ),i=1,9)/ + 3.912e-05, 3.749e-05, 1.642e-05, 5.325e-06, 1.526e-06, + 3.975e-07, 9.745e-08, 2.235e-08, 4.724e-09 / data (CsCBdel( 0 , i, 8 ),i=1,9)/ + 0.9154, 0.7984, 0.7195, 0.6202, 0.6319, + 0.6121, 0.571, 0.5794, 0.5696 / data (CsCBdel( 1 , i, 8 ),i=1,9)/ + 1.089, 1.079, 1.064, 1.001, 1.008, + 0.9975, 0.9718, 0.9775, 0.9695 / data (CsCBdel( 2 , i, 8 ),i=1,9)/ + 0.8455, 0.8439, 0.8883, 0.9071, 0.9025, + 0.9105, 0.9213, 0.9188, 0.9192 / data (CsCBdel( 3 , i, 8 ),i=1,9)/ + 0.5493, 0.5267, 0.5759, 0.645, 0.6283, + 0.6424, 0.6721, 0.6653, 0.6698 / data (CsCBdel( 4 , i, 8 ),i=1,9)/ + 0.3033, 0.2718, 0.2962, 0.3698, 0.3493, + 0.3588, 0.3856, 0.3802, 0.3813 / data (CsCBdel( 5 , i, 8 ),i=1,9)/ + 0.1342, 0.1092, 0.1121, 0.1589, 0.1442, + 0.1474, 0.1612, 0.1593, 0.1552 / data (CsCBdel( 6 , i, 8 ),i=1,9)/ + 0.03585, 0.02589, 0.02376, 0.03845, 0.03347, + 0.03359, 0.0368, 0.03715, 0.03315 / data (BsCBdel( i, 8 ),i=1,9)/ + 0.006753, 0.004403, 0.002434, 0.001282, 0.0006546, + 0.0003271, 0.0001599, 7.58e-05, 3.417e-05 / data ZsCBdel(9)/ 14 / data (AsCBdel( 1 , i, 9 ),i=1,9)/ + -0.482, -0.3436, 1.032, 1.099, -0.2834, + 0.7271, 0.4975, -0.3009, -0.3203 / data (AsCBdel( 2 , i, 9 ),i=1,9)/ + 0.1315, 0.1377, 0.1022, 0.1591, 0.2496, + 0.2229, 0.2438, 0.2875, 0.2946 / data (AsCBdel( 3 , i, 9 ),i=1,9)/ + -0.005324, -0.002923, -0.0008502, -0.000928, -0.001066, + -0.0003526, -0.000212, -0.0002344, -0.0001483 / data (AsCBdel( 4 , i, 9 ),i=1,9)/ + 0.0001555, 4.879e-05, 9.499e-06, 4.498e-06, 2.597e-06, + 3.532e-07, 1.095e-07, 1.34e-07, 5.275e-08 / data (CsCBdel( 0 , i, 9 ),i=1,9)/ + 0.7947, 0.8286, -1.163, -1.429, 0.6795, + -1.002, -0.6834, 0.5116, 0.4764 / data (CsCBdel( 1 , i, 9 ),i=1,9)/ + 0.7724, 1.09, -1.231, -1.651, 1.068, + -1.165, -0.7525, 0.7734, 0.7112 / data (CsCBdel( 2 , i, 9 ),i=1,9)/ + 0.5181, 0.8414, -0.8242, -1.192, 0.9573, + -0.8474, -0.5102, 0.6779, 0.6173 / data (CsCBdel( 3 , i, 9 ),i=1,9)/ + 0.2907, 0.5252, -0.4605, -0.7067, 0.6767, + -0.5094, -0.2811, 0.4676, 0.4236 / data (CsCBdel( 4 , i, 9 ),i=1,9)/ + 0.1401, 0.2746, -0.2163, -0.3463, 0.3866, + -0.2545, -0.1267, 0.257, 0.2332 / data (CsCBdel( 5 , i, 9 ),i=1,9)/ + 0.05502, 0.1131, -0.0786, -0.1295, 0.1657, + -0.09712, -0.04289, 0.1034, 0.09503 / data (CsCBdel( 6 , i, 9 ),i=1,9)/ + 0.01353, 0.02768, -0.01661, -0.02797, 0.03978, + -0.02127, -0.008133, 0.02257, 0.02181 / data (BsCBdel( i, 9 ),i=1,9)/ + 0.009832, 0.005141, 0.002487, 0.001379, 0.0008077, + 0.0003422, 0.0001768, 0.0001453, 8.163e-05 / data ZsCBdel(10)/ 18 / data (AsCBdel( 1 , i, 10 ),i=1,9)/ + 0.07435, -0.5446, -0.4682, 0.7745, 0.7001, + 0.3434, 0.5462, 0.5349, 0.7525 / data (AsCBdel( 2 , i, 10 ),i=1,9)/ + 0.1468, 0.2051, 0.1962, 0.1519, 0.2065, + 0.2461, 0.244, 0.2528, 0.2519 / data (AsCBdel( 3 , i, 10 ),i=1,9)/ + -0.0171, -0.009645, -0.004136, -0.001032, -0.001017, + -0.0007181, -0.0002647, -0.0001264, -4.787e-05 / data (AsCBdel( 4 , i, 10 ),i=1,9)/ + 0.001165, 0.0003634, 9.998e-05, 2.092e-05, 8.324e-06, + 2.704e-06, 4.327e-07, 8.662e-08, 1.365e-08 / data (CsCBdel( 0 , i, 10 ),i=1,9)/ + -0.1127, 0.7818, 0.9303, -0.8353, -0.8852, + -0.4207, -0.7605, -0.7908, -1.209 / data (CsCBdel( 1 , i, 10 ),i=1,9)/ + -0.3553, 0.6983, 1.183, -0.8358, -0.9938, + -0.4465, -0.8634, -0.901, -1.464 / data (CsCBdel( 2 , i, 10 ),i=1,9)/ + -0.2223, 0.3838, 0.8746, -0.525, -0.7013, + -0.3085, -0.6144, -0.6357, -1.093 / data (CsCBdel( 3 , i, 10 ),i=1,9)/ + -0.1378, 0.1706, 0.515, -0.2731, -0.4069, + -0.1814, -0.3613, -0.365, -0.661 / data (CsCBdel( 4 , i, 10 ),i=1,9)/ + -0.06122, 0.06301, 0.2496, -0.1187, -0.1946, + -0.0904, -0.1764, -0.171, -0.3252 / data (CsCBdel( 5 , i, 10 ),i=1,9)/ + -0.02011, 0.01852, 0.09367, -0.03974, -0.07045, + -0.03483, -0.0657, -0.05986, -0.1192 / data (CsCBdel( 6 , i, 10 ),i=1,9)/ + -0.003889, 0.003374, 0.02073, -0.00764, -0.0145, + -0.007855, -0.01405, -0.01164, -0.02465 / data (BsCBdel( i, 10 ),i=1,9)/ + 0.02169, 0.01125, 0.005761, 0.002826, 0.001516, + 0.0007845, 0.0003452, 0.0001566, 6.648e-05 / data ZsCBdel(11)/ 54 / data (AsCBdel( 1 , i, 11 ),i=1,9)/ + 0.2544, 0.004937, 0.4132, 0.6066, 1.275, + 1.901, 2.456, 2.576, 2.764 / data (AsCBdel( 2 , i, 11 ),i=1,9)/ + -0.01013, 0.01016, 0.007881, 0.03123, 0.03961, + 0.06741, 0.1035, 0.1455, 0.1742 / data (AsCBdel( 3 , i, 11 ),i=1,9)/ + 0.0004744, -3.434e-05, 0.0001231, -5.982e-05, -2.316e-05, + -3.843e-05, -4.707e-05, -4.937e-05, -2.956e-05 / data (AsCBdel( 4 , i, 11 ),i=1,9)/ + 8.157e-07, 4.271e-08, 6.323e-08, 8.043e-07, 1.212e-08, + 1.6e-08, 1.522e-08, 1.106e-08, 2.676e-09 / data (CsCBdel( 0 , i, 11 ),i=1,9)/ + -0.299, 0.1747, -0.3684, -0.5942, -1.543, + -2.5, -3.457, -3.721, -4.118 / data (CsCBdel( 1 , i, 11 ),i=1,9)/ + -0.4626, 0.1589, -0.5238, -0.7772, -1.885, + -3.017, -4.248, -4.562, -5.088 / data (CsCBdel( 2 , i, 11 ),i=1,9)/ + -0.2444, 0.3334, -0.2262, -0.5135, -1.412, + -2.28, -3.275, -3.508, -3.943 / data (CsCBdel( 3 , i, 11 ),i=1,9)/ + -0.3055, 0.08116, -0.1946, -0.3306, -0.8995, + -1.426, -2.084, -2.212, -2.495 / data (CsCBdel( 4 , i, 11 ),i=1,9)/ + -0.04217, 0.1795, -0.07936, -0.178, -0.4912, + -0.7426, -1.099, -1.146, -1.288 / data (CsCBdel( 5 , i, 11 ),i=1,9)/ + -0.154, 0.05137, -0.02414, -0.07568, -0.2145, + -0.2989, -0.4425, -0.4457, -0.4933 / data (CsCBdel( 6 , i, 11 ),i=1,9)/ + -0.01718, 0.02234, -0.004597, -0.01957, -0.05626, + -0.07006, -0.1017, -0.09934, -0.1057 / data (BsCBdel( i, 11 ),i=1,9)/ + 0.009027, 0.001564, 0.002333, 0.001623, 0.0004254, + 0.0002607, 0.000166, 0.0001006, 4.482e-05 / +PATCH,HEEDINT. +DECK,GASHEE. SUBROUTINE GASHEE(IFAIL) *----------------------------------------------------------------------- * GASHEE - Sets the gas composition for HEED * (Last changed on 14/ 1/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,PRINTPLOT. +SEQ,molecule. +SEQ,goevent. REAL pwmol(pqmol),FRTOT,AUX INTEGER qmol,nmol(pqmol),IFAIL,INPTYP,INPCMP,IFAIL1,IERROR, - INEXT,NWORD,I,IOS LOGICAL USED(pqmol) EXTERNAL INPTYP,INPCMP +SELF,IF=SAVE. SAVE qmol,nmol,pwmol +SELF. *** Identify. IF(LIDENT)PRINT *,' /// ROUTINE GASHEE ///' PRINT *,' ------ GASHEE MESSAGE : Heed version 1.01,'// - ' interface last changed on 14/1/00.' *** Assume the routine will fail. IFAIL=1 *** Initialise the gas mix. DO 20 I=1,pqmol USED(I)=.FALSE. 20 CONTINUE qmol=0 *** Determine number of words. CALL INPNUM(NWORD) *** Loop over the input. INEXT=2 DO 10 I=2,NWORD IF(I.LT.INEXT)GOTO 10 *** Fractions, first Argon. IF(INPCMP(I,'AR#GON').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_Ar))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_Ar pwmol(qmol)=AUX USED(numm_Ar)=.TRUE. ENDIF INEXT=I+2 * Methane. ELSEIF(INPCMP(I,'METHA#NE')+INPCMP(I,'CH4').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_CH4))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_CH4 pwmol(qmol)=AUX USED(numm_CH4)=.TRUE. ENDIF INEXT=I+2 * Nitrogen. ELSEIF(INPCMP(I,'NI#TROGEN')+INPCMP(I,'N2').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_N2))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_N2 pwmol(qmol)=AUX USED(numm_N2)=.TRUE. ENDIF INEXT=I+2 * CO2. ELSEIF(INPCMP(I,'CO2')+ - INPCMP(I,'CARB#ON-DIOX#IDE').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_CO2))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_CO2 pwmol(qmol)=AUX USED(numm_CO2)=.TRUE. ENDIF INEXT=I+2 * Helium 4. ELSEIF(INPCMP(I,'HE#LIUM-#4').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_He))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_He pwmol(qmol)=AUX USED(numm_He)=.TRUE. ENDIF INEXT=I+2 * Helium 3. ELSEIF(INPCMP(I,'HE#LIUM-3').NE.0)THEN CALL INPMSG(I,'Not yet in HEED.') INEXT=I+2 * Neon. ELSEIF(INPCMP(I,'NEON').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_Ne))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_Ne pwmol(qmol)=AUX USED(numm_Ne)=.TRUE. ENDIF INEXT=I+2 * Ethane. ELSEIF(INPCMP(I,'ETHA#NE')+INPCMP(I,'C2H6').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_C2H6))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_C2H6 pwmol(qmol)=AUX USED(numm_C2H6)=.TRUE. ENDIF INEXT=I+2 * Propane. ELSEIF(INPCMP(I,'PROPA#NE')+INPCMP(I,'C3H8').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_C3H8))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_C3H8 pwmol(qmol)=AUX USED(numm_C3H8)=.TRUE. ENDIF INEXT=I+2 * Isobutane. ELSEIF(INPCMP(I,'ISO#BUTANE')+INPCMP(I,'C4H10').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_iC4H10))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_iC4H10 pwmol(qmol)=AUX USED(numm_iC4H10)=.TRUE. ENDIF INEXT=I+2 * Pentane. ELSEIF(INPCMP(I,'PENT#ANE')+INPCMP(I,'C5H12')+ - INPCMP(I,'N#EO-PENT#ANE')+INPCMP(I,'N#EO-C5H12').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_C5H12))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_C5H12 pwmol(qmol)=AUX USED(numm_C5H12)=.TRUE. ENDIF INEXT=I+2 * Methylal. ELSEIF(INPCMP(I,'METHY#LAL')+INPCMP(I,'C3H8O2').NE.0)THEN CALL INPMSG(I,'Not yet in HEED.') INEXT=I+2 * Xenon. ELSEIF(INPCMP(I,'XE#NON').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_Xe))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_Xe pwmol(qmol)=AUX USED(numm_Xe)=.TRUE. ENDIF INEXT=I+2 * Krypton. ELSEIF(INPCMP(I,'KR#YPTON').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_Kr))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_Kr pwmol(qmol)=AUX USED(numm_Kr)=.TRUE. ENDIF INEXT=I+2 * CF4. ELSEIF(INPCMP(I,'CF4').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_CF4))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_CF4 pwmol(qmol)=AUX USED(numm_CF4)=.TRUE. ENDIF INEXT=I+2 * Oxygen. ELSEIF(INPCMP(I,'OX#YGEN')+INPCMP(I,'O2').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_O2))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_O2 pwmol(qmol)=AUX USED(numm_O2)=.TRUE. ENDIF INEXT=I+2 * DME. ELSEIF(INPCMP(I,'DME').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_DME))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_DME pwmol(qmol)=AUX USED(numm_DME)=.TRUE. ENDIF INEXT=I+2 * Ethene. ELSEIF(INPCMP(I,'ETHE#NE')+INPCMP(I,'C2H4').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_C2H4))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_C2H4 pwmol(qmol)=AUX USED(numm_C2H4)=.TRUE. ENDIF INEXT=I+2 * Acetylene. ELSEIF(INPCMP(I,'ACETYL#ENE')+INPCMP(I,'C2H2').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_C2H2))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_C2H2 pwmol(qmol)=AUX USED(numm_C2H2)=.TRUE. ENDIF INEXT=I+2 * Nitric oxide (NO). ELSEIF(INPCMP(I,'NITRI#C-OX#IDE')+INPCMP(I,'NO').NE.0)THEN CALL INPMSG(I,'Not yet in HEED.') INEXT=I+2 * Nitrous oxide (N2O). ELSEIF(INPCMP(I,'NITRO#US-OX#IDE')+INPCMP(I,'N2O').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_N2O))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_N2O pwmol(qmol)=AUX USED(numm_N2O)=.TRUE. ENDIF INEXT=I+2 * Hydrogen gas. ELSEIF(INPCMP(I,'HYDR#OGEN')+INPCMP(I,'H2').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_H2))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_H2 pwmol(qmol)=AUX USED(numm_H2)=.TRUE. ENDIF INEXT=I+2 * Ammonia gas. ELSEIF(INPCMP(I,'AMMO#NIA')+INPCMP(I,'NH3').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_NH3))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_NH3 pwmol(qmol)=AUX USED(numm_NH3)=.TRUE. ENDIF INEXT=I+2 * Water vapour. ELSEIF(INPCMP(I,'H2O')+INPCMP(I,'WAT#ER').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_H2O))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_H2O pwmol(qmol)=AUX USED(numm_H2O)=.TRUE. ENDIF INEXT=I+2 * SF6. ELSEIF(INPCMP(I,'SF6').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_SF6))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_SF6 pwmol(qmol)=AUX USED(numm_SF6)=.TRUE. ENDIF INEXT=I+2 * C2F4H2 (1,1,1,2 tetrafluoroethane, HFC-134a). ELSEIF(INPCMP(I,'C2F4H2')+INPCMP(I,'C2H2F4')+ - INPCMP(I,'CH2FCF3')+ - INPCMP(I,'HFC-134A').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_C2F4H2))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_C2F4H2 pwmol(qmol)=AUX USED(numm_C2F4H2)=.TRUE. ENDIF INEXT=I+2 * C2F5H (?). ELSEIF(INPCMP(I,'C2F5H')+INPCMP(I,'C2HF5').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSEIF(USED(numm_C2F5H))THEN CALL INPMSG(I,'Gas already referenced.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,0.0) qmol=qmol+1 nmol(qmol)=numm_C2F5H pwmol(qmol)=AUX USED(numm_C2F5H)=.TRUE. ENDIF INEXT=I+2 * All the rest is not known. ELSE CALL INPMSG(I,'Not a known keyword.') ENDIF 10 CONTINUE *** Print the error messages accumulated sofar. CALL INPERR *** Renormalise the fractions. FRTOT=0.0 DO 120 I=1,qmol IF(pwmol(I).LT.0)pwmol(I)=0.0 FRTOT=FRTOT+pwmol(I) 120 CONTINUE IF(FRTOT.LE.0.0)THEN PRINT *,' !!!!!! GASHEE WARNING : Please have at least'// - ' one gas in your mixture; nothing done.' IFAIL=1 RETURN ELSE DO 130 I=1,qmol pwmol(I)=pwmol(I)/FRTOT 130 CONTINUE ENDIF *** Debugging information. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ GASHEE DEBUG : Gas mix'', - '' composed as follows:'')') DO 30 I=1,qmol IF(nmol(i).eq.numm_He)THEN WRITE(LUNOUT,'(26X,''Helium '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_Ne)THEN WRITE(LUNOUT,'(26X,''Neon '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_Ar)THEN WRITE(LUNOUT,'(26X,''Argon '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_Kr)THEN WRITE(LUNOUT,'(26X,''Krypton '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_Xe)THEN WRITE(LUNOUT,'(26X,''Xenon '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_H2)THEN WRITE(LUNOUT,'(26X,''H2 '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_N2)THEN WRITE(LUNOUT,'(26X,''N2 '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_O2)THEN WRITE(LUNOUT,'(26X,''O2 '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_NH3)THEN WRITE(LUNOUT,'(26X,''NH3 '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_N2O)THEN WRITE(LUNOUT,'(26X,''N2O '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_CO2)THEN WRITE(LUNOUT,'(26X,''CO2 '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_CF4)THEN WRITE(LUNOUT,'(26X,''CF4 '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_CH4)THEN WRITE(LUNOUT,'(26X,''CH4 '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_C2H2)THEN WRITE(LUNOUT,'(26X,''C2H2 '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_C2H4)THEN WRITE(LUNOUT,'(26X,''C2H4 '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_C2H6)THEN WRITE(LUNOUT,'(26X,''C2H6 '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_C3H8)THEN WRITE(LUNOUT,'(26X,''C3H8 '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_iC4H10)THEN WRITE(LUNOUT,'(26X,''iC4H10 '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_C5H12)THEN WRITE(LUNOUT,'(26X,''C5H12 '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_DME)THEN WRITE(LUNOUT,'(26X,''DME '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_H2O)THEN WRITE(LUNOUT,'(26X,''H2O '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_SF6)THEN WRITE(LUNOUT,'(26X,''SF6 '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_C2F4H2)THEN WRITE(LUNOUT,'(26X,''C2F4H2 '',F10.3,'' %'')') - 100*pwmol(I) ELSEIF(nmol(i).eq.numm_C2F5H)THEN WRITE(LUNOUT,'(26X,''C2F5H '',F10.3,'' %'')') - 100*pwmol(I) ELSE WRITE(LUNOUT,'(26X,''# Unknown # '',F10.3,'' %'')') - 100*pwmol(I) ENDIF 30 CONTINUE WRITE(LUNOUT,'(26X,''Pressure: '',F10.3,'' torr''/ - 26X,''Temperature: '',F10.3,'' K'')') PGAS,TGAS ENDIF *** Set HEED printing and error monitoring flags. IF(LDEBUG)THEN soo=1 ELSE soo=0 ENDIF oo=LUNOUT s_err=0 *** Call the HEED gas routine. ierror=0 CALL imheed( - qmol, ! Different gas components - nmol, ! Names of gasses present in mixture - pwmol, ! Gas fractions - PGAS, ! Pressure [torr] - TGAS, ! Temperature [K] - 1, ! 0 or 1: Do/don't generate output - 6, ! Output logical unit - 1, ! 1/2 Short/Medium listing - GASDEN, ! (Output) computed density - ierror) ! Error indicator. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASHEE DEBUG :'', - '' HEED density: '',F10.3,'' g/l, error code: '',I3)') - 1000*GASDEN,ierror *** Return error code. IF(ierror.NE.0)THEN PRINT *,' !!!!!! GASHEE WARNING : Gas preparation by'// - ' HEED failed ; tracks can not be generated.' IFAIL=1 HEEDOK=.FALSE. ELSE IFAIL=0 HEEDOK=.TRUE. ENDIF RETURN *** Write the tables. ENTRY GASHWR(IFAIL) * Assume for the moment that writing will work. IFAIL=0 * See whether iniialisation has been performed. WRITE(12,'('' Heed initialisation done: '',L1)',ERR=2010, - IOSTAT=IOS) HEEDOK IF(HEEDOK)THEN * Write the composition. WRITE(12,'('' Gas components: '',I5)',ERR=2010, - IOSTAT=IOS) qmol DO 200 I=1,qmol WRITE(12,'(2X,I10,E15.8)',ERR=2010,IOSTAT=IOS) - nmol(I),pwmol(I) 200 CONTINUE ENDIF RETURN * Errors during I/O. 2010 CONTINUE PRINT *,' !!!!!! GASHWR WARNING : I/O error occurred while'// - ' writing Heed initialisation data.' CALL INPIOS(IOS) IFAIL=1 RETURN *** Retrieve initialisation data. ENTRY GASHGT(IFAIL) * Assume for the moment that reading will work. IFAIL=0 * See whether initialisation should be performed. READ(12,'(28X,L1)',ERR=2015,IOSTAT=IOS) HEEDOK IF(HEEDOK)THEN * Read the composition. READ(12,'(18X,I5)',ERR=2015,IOSTAT=IOS) qmol IF(qmol.LT.0.OR.qmol.GT.pqmol)THEN PRINT *,' !!!!!! GASHGT WARNING : Number of gas'// - ' components < 0 or > current maximum; Heed'// - ' initialisation not performed.' RETURN ENDIF DO 210 I=1,qmol READ(12,'(2X,I10,E15.8)',ERR=2015,IOSTAT=IOS) - nmol(I),pwmol(I) 210 CONTINUE * Perform the initialisation. ierror=0 CALL imheed( - qmol, ! Different gas components - nmol, ! Names of gasses present in mixture - pwmol, ! Gas fractions - PGAS, ! Pressure [torr] - TGAS, ! Temperature [K] - 1, ! 0 or 1: Do/don't generate output - 6, ! Output logical unit - 1, ! 1/2 Short/Medium listing - GASDEN, ! (Output) computed density - ierror) ! Error indicator. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASHEE DEBUG :'', - '' HEED density: '',F10.3,'' g/l, error code: '',I3)') - 1000*GASDEN,ierror * Return error code. IF(ierror.NE.0)THEN PRINT *,' !!!!!! GASHGT WARNING : Gas preparation by'// - ' HEED failed ; tracks can not be generated.' IFAIL=1 HEEDOK=.FALSE. ELSE IFAIL=0 HEEDOK=.TRUE. ENDIF ENDIF RETURN * Errors during I/O. 2015 CONTINUE PRINT *,' !!!!!! GASHGT WARNING : I/O error occurred while'// - ' retrieving Heed initialisation data.' CALL INPIOS(IOS) IFAIL=1 END +DECK,TRAINT SUBROUTINE TRAINT *----------------------------------------------------------------------- * TRAINT - Initialises the track. * (Last changed on 14/ 5/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. INTEGER I *** Reset all the track flags. DO 10 I=1,10 TRFLAG(I)=.FALSE. 10 CONTINUE *** Set the track type (fixed number of points). ITRTYP=0 *** Set default number of lines. NTRLIN=20 TRFLAG(3)=.TRUE. *** Default number of samples. NTRSAM=100 TRFLAG(5)=.TRUE. *** Default number of flux lines. NTRFLX=20 TRFLAG(6)=.TRUE. *** Default flux interval. TRFLUX=10 TRFLAG(7)=.TRUE. *** Set some track. XT0=0.0 YT0=0.0 ZT0=0.0 XT1=0.0 YT1=0.0 ZT1=0.0 TRTH=0 TRPHI=0 *** Reset the options. LTRMS =.FALSE. LTRDEL=.TRUE. LTRINT=.FALSE. LTREXB=.TRUE. *** Reset the track interpolation table. CALL DLCTRR *** Set a default particle type and energy (a 1 GeV mu-) TRMASS=105.658389 TRCHAR=-1.0 TRENER=1000.0 *** Particle identifier. PARTID='Unknown' PNAME='Unknown' NCPNAM=7 END +DECK,TRACLS. SUBROUTINE TRACLS(XCLS,YCLS,ZCLS,ECLS,NPAIR,DONE,IFAIL) *----------------------------------------------------------------------- * TRACLS - Generates new clusters along the track. * TRACLI - Initialisation. * (Last changed on 24/ 9/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. +SEQ,volume. +SEQ,goevent. +SEQ,del. +SEQ,cel. +SEQ,abs. +SEQ,rga. +SEQ,lsgvga. REAL XCLS,YCLS,ZCLS,ECLS,TRALEN,DIST,RNDEXP,RNDM,XAUX,YAUX,ZAUX, - DISVGA(pqgvga),EDELTA,ETOT,XP,YP,ZP,Q,FLXSUM,FLXCOO(MXLIST), - FLXTAB(MXLIST),DIVDIF,XL,XL0FLX,XL1FLX DOUBLE PRECISION XRAN INTEGER NPAIR,NTOT,NDELTA,IVGA,ICEL,I,J,IERROR,IFAIL,IPRINT, - NCAUX,NV,ISIGN,JPRINT LOGICAL DONE,OK CHARACTER*20 AUX EXTERNAL RNDEXP,RNDM +SELF,IF=SAVE. SAVE NTOT,TRALEN,DIST,OK,IVGA,ICEL,ETOT,FLXCOO,FLXTAB,FLXSUM, - XL0FLX,XL1FLX +SELF. DATA OK/.FALSE./ *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE TRACLS ///' *** Initial settings. XCLS=0 YCLS=0 ZCLS=0 ECLS=0 NPAIR=0 DONE=.TRUE. IFAIL=1 *** Make sure the routine is in the proper state. IF(.NOT.OK)THEN PRINT *,' !!!!!! TRACLS WARNING : Track initialisation'// - ' not done or track complete; no clusters.' RETURN *** Verify that track parameters are available. ELSEIF(.NOT.TRFLAG(1))THEN PRINT *,' !!!!!! TRACLS WARNING : Track location is not'// - ' set; no clusters.' RETURN ENDIF *** Handle the case of a fixed number of clusters. IF(ITRTYP.EQ.1)THEN * Ensure that the number is reasonable. IF(.NOT.TRFLAG(3))THEN PRINT *,' !!!!!! TRACLS WARNING : Number of points'// - ' on the track not defined; no clusters.' RETURN ENDIF * Increment cluster counter. NTOT=NTOT+1 * Compute new cluster position. IF(NTRLIN.GT.1)THEN XCLS=XT0+REAL(NTOT-1)*(XT1-XT0)/REAL(NTRLIN-1) YCLS=YT0+REAL(NTOT-1)*(YT1-YT0)/REAL(NTRLIN-1) ZCLS=ZT0+REAL(NTOT-1)*(ZT1-ZT0)/REAL(NTRLIN-1) ELSE XCLS=0.5*(XT0+XT1) YCLS=0.5*(YT0+YT1) ZCLS=0.5*(ZT0+ZT1) ENDIF * Set cluster size and energy. NPAIR=1 ECLS=-1 * See whether we were already done. IF(NTOT.GT.NTRLIN)THEN DONE=.TRUE. OK=.FALSE. ELSE DONE=.FALSE. ENDIF *** Fixed number of clusters at weighted positions. ELSEIF(ITRTYP.EQ.5)THEN * Ensure that the number is reasonable. IF(.NOT.TRFLAG(4))THEN PRINT *,' !!!!!! TRACLS WARNING : Weighting function'// - ' on the track not defined; no clusters.' RETURN ELSEIF(.NOT.TRFLAG(5))THEN PRINT *,' !!!!!! TRACLS WARNING : Number of points'// - ' on the track not defined; no clusters.' RETURN ENDIF * Increment cluster counter. NTOT=NTOT+1 * Compute new cluster position. CALL HISRAD(WGT,MXLIST,0.0D0,1.0D0/MXLIST,XRAN) XCLS=XT0+REAL(XRAN)*(XT1-XT0) YCLS=YT0+REAL(XRAN)*(YT1-YT0) ZCLS=ZT0+REAL(XRAN)*(ZT1-ZT0) * Set cluster size and energy. NPAIR=1 ECLS=-1 * See whether we were already done. IF(NTOT.GT.NTRSAM)THEN DONE=.TRUE. OK=.FALSE. ELSE DONE=.FALSE. ENDIF *** One cluster at a random location. ELSEIF(ITRTYP.EQ.6)THEN * Increment cluster counter. NTOT=NTOT+1 * Compute new cluster position. XRAN=DBLE(RNDM(NTOT)) XCLS=XT0+REAL(XRAN)*(XT1-XT0) YCLS=YT0+REAL(XRAN)*(YT1-YT0) ZCLS=ZT0+REAL(XRAN)*(ZT1-ZT0) * Set the cluster size and energy. IF(GASOK(5))THEN CALL HISRAD(CLSDIS,NCLS,0.0D0,1.0D0,XRAN) NPAIR=INT(XRAN) ECLS=NPAIR*EPAIR ELSE NPAIR=1 ECLS=0 ENDIF * See whether we were already done. IF(NTOT.GT.1)THEN DONE=.TRUE. OK=.FALSE. ELSE DONE=.FALSE. ENDIF *** Handle the case of equally spaced clusters according to CMEAN. ELSEIF(ITRTYP.EQ.2)THEN * Ensure that the appropriate gas data is present. IF(.NOT.GASOK(5))THEN PRINT *,' !!!!!! TRACLS WARNING : Clustering data'// - ' from gas section missing; track not set.' RETURN ENDIF * Store track length. IF(NTOT.EQ.0) - TRALEN=SQRT((XT1-XT0)**2+(YT1-YT0)**2+(ZT1-ZT0)**2) * Increment cluster counter. NTOT=NTOT+1 * Generate new cluster position. IF(TRALEN.GT.0)THEN XCLS=XT0+(REAL(NTOT-1)/CMEAN)*(XT1-XT0)/TRALEN YCLS=YT0+(REAL(NTOT-1)/CMEAN)*(YT1-YT0)/TRALEN ZCLS=ZT0+(REAL(NTOT-1)/CMEAN)*(ZT1-ZT0)/TRALEN ELSE XCLS=0.5*(XT0+XT1) YCLS=0.5*(YT0+YT1) ZCLS=0.5*(ZT0+ZT1) ENDIF * See whether we're ready. IF((XT0-XCLS)*(XCLS-XT1).LT.0.OR. - (YT0-YCLS)*(YCLS-YT1).LT.0.OR. - (ZT0-ZCLS)*(ZCLS-ZT1).LT.0.OR. - (TRALEN.LE.0.AND.NTOT.GT.1))THEN DONE=.TRUE. OK=.FALSE. ELSE DONE=.FALSE. ENDIF * Set the cluster size and energy. CALL HISRAD(CLSDIS,NCLS,0.0D0,1.0D0,XRAN) NPAIR=INT(XRAN) ECLS=NPAIR*EPAIR *** Handle the case of exponentially spaced clusters. ELSEIF(ITRTYP.EQ.3)THEN * Ensure that the appropriate gas data is present. IF(.NOT.GASOK(5))THEN PRINT *,' !!!!!! TRACLS WARNING : Clustering data'// - ' from gas section missing; track not set.' RETURN ENDIF * Store track length. IF(NTOT.EQ.0)THEN TRALEN=SQRT((XT1-XT0)**2+(YT1-YT0)**2+(ZT1-ZT0)**2) DIST=0 ENDIF * Increment cluster counter. NTOT=NTOT+1 * Generate new cluster position. IF(TRALEN.GT.0)THEN DIST=DIST+RNDEXP(1.0/CMEAN) XCLS=XT0+DIST*(XT1-XT0)/TRALEN YCLS=YT0+DIST*(YT1-YT0)/TRALEN ZCLS=ZT0+DIST*(ZT1-ZT0)/TRALEN ELSE XCLS=0.5*(XT0+XT1) YCLS=0.5*(YT0+YT1) ZCLS=0.5*(ZT0+ZT1) ENDIF * See whether we're ready. IF((XT0-XCLS)*(XCLS-XT1).LT.0.OR. - (YT0-YCLS)*(YCLS-YT1).LT.0.OR. - (ZT0-ZCLS)*(ZCLS-ZT1).LT.0.OR. - (TRALEN.LE.0.AND.NTOT.GT.1))THEN DONE=.TRUE. OK=.FALSE. ELSE DONE=.FALSE. ENDIF * Set the cluster size and energy. CALL HISRAD(CLSDIS,NCLS,0.0D0,1.0D0,XRAN) NPAIR=INT(XRAN) ECLS=EPAIR*NPAIR *** And finally deal with the case of HEED generated clusters. ELSEIF(ITRTYP.EQ.4)THEN ** Check for zero charge tracks. IF(TRCHAR.EQ.0)THEN DONE=.TRUE. XCLS=0 YCLS=0 ZCLS=0 ECLS=0 NPAIR=0 OK=.FALSE. IFAIL=0 RETURN ENDIF ** If this is a request for the first cluster ... IF(IVGA.EQ.0)THEN * Ensure that proper data is available. IF(.NOT.HEEDOK)THEN PRINT *,' !!!!!! TRACLS WARNING : HEED gas'// - ' mix not defined; track not set.' RETURN ELSEIF(.NOT.TRFLAG(2))THEN PRINT *,' !!!!!! TRACLS WARNING : Particle'// - ' properties not present; no clusters.' RETURN ENDIF * Store track length and rotation angles. IF((XT1-XT0)**2+(ZT1-ZT0)**2.LE.0)THEN IF(YT1-YT0.LT.0)THEN TRTH=-PI/2 ELSEIF(YT1-YT0.GT.0)THEN TRTH=+PI/2 ELSE TRTH=0 ENDIF TRPHI=0 ELSE TRPHI=ATAN2(XT1-XT0,ZT1-ZT0) TRTH=ATAN2(YT1-YT0,SQRT((XT1-XT0)**2+ - (ZT1-ZT0)**2)) ENDIF TRALEN=SQRT((XT1-XT0)**2+(YT1-YT0)**2+(ZT1-ZT0)**2) IF(TRALEN.LE.0)THEN PRINT *,' !!!!!! TRACLS WARNING : Track length'// - ' 0 not compatible with HEED; no clusters.' RETURN ENDIF IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ TRACLS DEBUG :'', - '' Transformation matrix:'',3(/26X,3F10.3)/ - 26X,''Track length: '',E15.8,'' cm.'')') - COS(TRPHI),-SIN(TRPHI)*SIN(TRTH), - +SIN(TRPHI)*COS(TRTH),0,COS(TRTH), - +SIN(TRTH),-SIN(TRPHI),-COS(TRPHI)*SIN(TRTH), - +COS(TRPHI)*COS(TRTH),TRALEN ENDIF * Set the HEED error flag to false. IF(LDEBUG)THEN soo=1 ELSE soo=0 ENDIF oo=LUNOUT s_err=0 * Set the tracking volume. CALL IniFVolume(0,1,1,1,0.0,TRALEN) * Set the particle type. IF(LDEBUG)THEN IPRINT=2 ELSE IPRINT=1 ENDIF IERROR=0 CALL ipheed( - TRENER, ! Particle kinetic energy [MeV] - TRMASS, ! Particle mass [MeV] - IPRINT, ! 1/2 Short/Medium listing - IERROR) ! Error indicator. IF(IERROR.NE.0)THEN PRINT *,' !!!!!! TRACLS WARNING : Setting the'// - ' particle properties in HEED failed.' RETURN ENDIF * Set the track. CALL IniRTrack( - 0.0,0.0, ! Starting interval, HEED y [cm] - 0.0,0.0) ! Track orientation * Optionally add multiple scattering. IF(LTRMS)CALL IniMTrack( - 1, ! Sign of Rutherford angle - 0.01*GASDEN, ! Step - 0.001) ! Minimum angle * Generate a track. CALL GoEventn(1,1) * Check for overflow. IF(qsOverflowagam.GT.0) - PRINT *,' !!!!!! TRACLS WARNING : Overflow of'// - ' energy deposition buffer in HEED; no clusters.' IF(qsOverflowrga.GT.0) - PRINT *,' !!!!!! TRACLS WARNING : Overflow of'// - ' real photon buffer in HEED; no clusters.' IF(qsOverflowDel.GT.0) - PRINT *,' !!!!!! TRACLS WARNING : Overflow of'// - ' delta electron buffer in HEED; no clusters.' IF(qsOverflowCel(1).GT.0) - PRINT *,' !!!!!! TRACLS WARNING : Overflow of'// - ' deposited electron buffer in HEED; no clusters.' IF(qsOverflowagam.GT.0.OR.qsOverflowrga.GT.0.OR. - qsOverflowDel.GT.0.OR.qsOverflowagam.GT.0)THEN OK=.FALSE. DONE=.TRUE. RETURN ENDIF * Sort the virtual gamma's by location. DO 50 I=1,qgvga(1) DISVGA(I)=pntgvga(3,I,1) 50 CONTINUE CALL SORTZV(DISVGA,INDPOS,qgvga(1),1,0,0) * If debugging is on, print the Virtual GAmma's. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ TRACLS DEBUG :'', - '' Virtual gammas: '',I5,'' total dE='', - E15.8,'' MeV:''/'' Index'', - '' x [cm] y [cm]'', - '' z [cm] dE [MeV]'', - '' order'')') - qgvga(1),esgvga(1) DO 10 I=1,qgvga(1) JPRINT=0 DO 80 J=1,qgvga(1) IF(INDPOS(J).EQ.I)JPRINT=J 80 CONTINUE WRITE(LUNOUT,'(2X,I5,4(1X,E15.8),I6)') - I,(pntgvga(J,I,1),J=1,3),egvga(I,1),JPRINT 10 CONTINUE * Same for the delta's. WRITE(LUNOUT,'('' ++++++ TRACLS DEBUG :'', - '' Delta + Auger electrons: '',I5/ - '' Index'', - '' x [cm] y [cm]'', - '' z [cm] energy [MeV]'', - '' charge gamma type'')') qdel DO 20 I=1,qdel IF(SOdel(I).EQ.0)THEN WRITE(LUNOUT,'(2X,I5,4(1X,E15.8),F7.1,I6, - '' delta'')') I,(pntdel(j,i),j=1,3), - edel(i),zdel(i),ptdel(i) ELSE WRITE(LUNOUT,'(2X,I5,4(1X,E15.8),F7.1,I6, - '' Auger'')') I,(pntdel(j,i),j=1,3), - edel(i),zdel(i),ptdel(i) ENDIF 20 CONTINUE * Same for the real photons. WRITE(LUNOUT,'('' ++++++ TRACLS DEBUG :'', - '' Real photons: '',I5/'' Index'', - '' x [cm] y [cm]'', - '' z [cm] energy [MeV]'', - '' gamma'')') qrga DO 30 I=1,qrga WRITE(LUNOUT,'(2X,I5,4(1X,E15.8),I6)') - I,(pntrga(j,i),j=1,3),erga(i), - ptrga(i) 30 CONTINUE * And finally also the electrons. WRITE(LUNOUT,'('' ++++++ TRACLS DEBUG :'', - '' Electrons: '',I5/'' Index'', - '' x [cm] y [cm]'', - '' z [cm]'', - '' charge delta'')') qcel(1) DO 40 I=1,qcel(1) WRITE(LUNOUT,'(2X,I5,3(1X,E15.8),F7.1,I6)') - I,(pntcel(j,i,1),j=1,3),zcel(i,1), - ndelcel(i,1) 40 CONTINUE ENDIF * Store first virtual gamma and electron to deal with. IVGA=1 ICEL=0 * Reset total energy. ETOT=0 ENDIF ** If delta's have to be taken into account. IF(LTRDEL)THEN 70 CONTINUE * Increment the electron counter. ICEL=ICEL+1 * Check whether we've reached the last electron. IF(ICEL.GT.qcel(1))THEN * If so, increment the virtual gamma counter. IVGA=IVGA+1 ICEL=1 * Check whether we've reached the last virtual gamma. IF(IVGA.GT.qgvga(1))THEN DONE=.TRUE. XCLS=0 YCLS=0 ZCLS=0 ECLS=0 NPAIR=0 OK=.FALSE. IFAIL=0 RETURN ELSE DONE=.FALSE. ENDIF ELSE DONE=.FALSE. ENDIF * See whether this electron belongs to the right gamma. IF(ptdel(ndelcel(ICEL,1)).NE.INDPOS(IVGA))GOTO 70 * Fetch the location of this electron. XAUX=pntcel(1,ICEL,1) YAUX=pntcel(2,ICEL,1) ZAUX=pntcel(3,ICEL,1) C print *,' Taking electron ',icel,' from gamma ',ivga * Compute the energy deposited in this electron. EDELTA=edel(ndelcel(ICEL,1)) NDELTA=0 DO 60 I=1,qcel(1) IF(ndelcel(I,1).EQ.ndelcel(ICEL,1))NDELTA=NDELTA+1 60 CONTINUE IF(NDELTA.LE.0)THEN ECLS=-1 ELSE ECLS=EDELTA/NDELTA ENDIF * Check whether we exceeded the total energy. ETOT=ETOT+ECLS IF(ETOT.GT.TRENER)THEN PRINT *,' ------ TRACLS MESSAGE : Track'// - ' truncated because the deposited'// - ' energy exceeds the particle energy.' DONE=.TRUE. XCLS=0 YCLS=0 ZCLS=0 ECLS=0 NPAIR=0 OK=.FALSE. IFAIL=0 RETURN ENDIF * There is only 1 electron in this case. NPAIR=1 ** If we don't want deltas ... ELSE * Check whether we've already had all energy deposits. IF(IVGA.GT.qgvga(1))THEN DONE=.TRUE. XCLS=0 YCLS=0 ZCLS=0 ECLS=0 NPAIR=0 OK=.FALSE. IFAIL=0 RETURN ELSE DONE=.FALSE. ENDIF * Fetch the location of this deposit. XAUX=pntgvga(1,INDPOS(IVGA),1) YAUX=pntgvga(2,INDPOS(IVGA),1) ZAUX=pntgvga(3,INDPOS(IVGA),1) * Count the number of electrons associated with it. NPAIR=0 DO 100 I=1,qcel(1) IF(ptdel(ndelcel(I,1)).EQ.INDPOS(IVGA))NPAIR=NPAIR+1 100 CONTINUE * Store energy, checking the total energy. IF(ETOT+egvga(INDPOS(IVGA),1).GT.TRENER)THEN ECLS=TRENER-ETOT IVGA=qgvga(1)+1 ELSE ECLS=egvga(INDPOS(IVGA),1) ENDIF ETOT=ETOT+ECLS * Increment the cluster counter. IVGA=IVGA+1 ENDIF ** Rotate the cluster position so that it matches the track. XCLS=XT0+COS(TRPHI)*XAUX-SIN(TRPHI)*SIN(TRTH)*YAUX+ - SIN(TRPHI)*COS(TRTH)*ZAUX YCLS=YT0+COS(TRTH)*YAUX+SIN(TRTH)*ZAUX ZCLS=ZT0-SIN(TRPHI)*XAUX-COS(TRPHI)*SIN(TRTH)*YAUX+ - COS(TRPHI)*COS(TRTH)*ZAUX *** Fixed number of flux intervals. ELSEIF(ITRTYP.EQ.7)THEN * Verify that the number of flux lines has been set. IF(.NOT.TRFLAG(6))THEN PRINT *,' !!!!!! TRACLS WARNING : Number of flux'// - ' lines has not been set; no clusters.' RETURN ENDIF ** On first call, compute the flux intervals. IF(NTOT.EQ.0)THEN * Set integration intervals. NV=5 * Compute the inplane vector normal to the track. XP=(YT1-YT0)*FPROJC-(ZT1-ZT0)*FPROJB YP=(ZT1-ZT0)*FPROJA-(XT1-XT0)*FPROJC ZP=(XT1-XT0)*FPROJB-(YT1-YT0)*FPROJA * Compute the total flux, accepting positive and negative parts. CALL FLDIN5(XT0,YT0,ZT1,XT1,YT1,ZT1,XP,YP,ZP,Q, - 20*NV,0) IF(Q.GT.0)THEN ISIGN=+1 ELSE ISIGN=-1 ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ TRACLS DEBUG :'', - '' Total flux: '',E15.8,'', selected sign '',I1)') - Q,ISIGN * Compute the 1-sided flux in a number of steps. FLXSUM=0 IERROR=0 XL0FLX=-1 XL1FLX=-1 DO 110 I=1,MXLIST CALL FLDIN5( - XT0+REAL(I-1)*(XT1-XT0)/REAL(MXLIST), - YT0+REAL(I-1)*(YT1-YT0)/REAL(MXLIST), - ZT0+REAL(I-1)*(ZT1-ZT0)/REAL(MXLIST), - XT0+REAL(I)*(XT1-XT0)/REAL(MXLIST), - YT0+REAL(I)*(YT1-YT0)/REAL(MXLIST), - ZT0+REAL(I)*(ZT1-ZT0)/REAL(MXLIST), - XP,YP,ZP,Q,NV,ISIGN) FLXCOO(I)=REAL(I)/REAL(MXLIST) IF(Q.GT.0)THEN FLXSUM=FLXSUM+Q IF(XL0FLX.LT.-0.5)XL0FLX=REAL(I-1)/REAL(MXLIST) XL1FLX=REAL(I)/REAL(MXLIST) ENDIF IF(Q.LT.0)IERROR=IERROR+1 FLXTAB(I)=FLXSUM 110 CONTINUE * Make sure that the sum is positive. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ TRACLS DEBUG :'', - '' Used flux: '',E15.8,'' V''/26X,''Start: '', - F10.3,'' End: '',F10.3)') FLXSUM,XL0FLX,XL1FLX IF(FLXSUM.LE.0)THEN PRINT *,' !!!!!! TRACLS WARNING : 1-Sided flux'// - ' integral is not > 0; no clusters.' RETURN ELSEIF(XL0FLX.LT.-0.5.OR.XL1FLX.LT.-0.5.OR. - XL1FLX.LE.XL0FLX)THEN PRINT *,' !!!!!! TRACLS WARNING : No flux'// - ' interval without sign change found.' RETURN ELSEIF(IERROR.NE.0)THEN PRINT *,' ------ TRACLS MESSAGE : The flux'// - ' changes sign over the track; part of'// - ' the track not used.' ENDIF * Normalise the flux. DO 120 I=1,MXLIST FLXTAB(I)=REAL(NTRFLX-1)*FLXTAB(I)/FLXSUM 120 CONTINUE ENDIF ** Increment cluster counter. NTOT=NTOT+1 * Compute new cluster position. IF(NTOT.EQ.1)THEN XL=XL0FLX ELSEIF(NTOT.GE.1.AND.NTOT.LT.NTRFLX)THEN XL=MIN(XL1FLX,MAX(XL0FLX, - DIVDIF(FLXCOO,FLXTAB,MXLIST,REAL(NTOT-1),1))) ELSEIF(NTOT.EQ.NTRFLX)THEN XL=XL1FLX ELSE XL=0.5*(XL1FLX-XL0FLX) ENDIF XCLS=XT0+XL*(XT1-XT0) YCLS=YT0+XL*(YT1-YT0) ZCLS=ZT0+XL*(ZT1-ZT0) * Set the cluster size and energy. NPAIR=1 ECLS=0 * See whether we were already done. IF(NTOT.GT.NTRFLX)THEN DONE=.TRUE. OK=.FALSE. ELSE DONE=.FALSE. ENDIF *** Fixed flux interval. ELSEIF(ITRTYP.EQ.8)THEN * Verify that the number of flux lines has been set. IF(.NOT.TRFLAG(7))THEN PRINT *,' !!!!!! TRACLS WARNING : The flux interval'// - ' has not been set; no clusters.' RETURN ENDIF ** On first call, compute the flux intervals. IF(NTOT.EQ.0)THEN * Set integration intervals. NV=5 * Compute the inplane vector normal to the track. XP=(YT1-YT0)*FPROJC-(ZT1-ZT0)*FPROJB YP=(ZT1-ZT0)*FPROJA-(XT1-XT0)*FPROJC ZP=(XT1-XT0)*FPROJB-(YT1-YT0)*FPROJA * Compute the total flux, accepting positive and negative parts. CALL FLDIN5(XT0,YT0,ZT1,XT1,YT1,ZT1,XP,YP,ZP,Q, - NTRFLX*NV,0) IF(Q.GT.0)THEN ISIGN=+1 ELSE ISIGN=-1 ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ TRACLS DEBUG :'', - '' Total flux: '',E15.8,'' V, sign '',I1)') - Q,ISIGN * Compute the 1-sided flux in a number of steps. FLXSUM=0 IERROR=0 XL0FLX=-1 DO 130 I=1,MXLIST CALL FLDIN5( - XT0+REAL(I-1)*(XT1-XT0)/REAL(MXLIST), - YT0+REAL(I-1)*(YT1-YT0)/REAL(MXLIST), - ZT0+REAL(I-1)*(ZT1-ZT0)/REAL(MXLIST), - XT0+REAL(I)*(XT1-XT0)/REAL(MXLIST), - YT0+REAL(I)*(YT1-YT0)/REAL(MXLIST), - ZT0+REAL(I)*(ZT1-ZT0)/REAL(MXLIST), - XP,YP,ZP,Q,NV,ISIGN) FLXCOO(I)=REAL(I)/REAL(MXLIST) IF(Q.GT.0)THEN FLXSUM=FLXSUM+Q IF(XL0FLX.LT.-0.5)XL0FLX=REAL(I-1)/REAL(MXLIST) ENDIF IF(Q.LT.0)IERROR=IERROR+1 FLXTAB(I)=FLXSUM 130 CONTINUE * Make sure that the sum is positive. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ TRACLS DEBUG :'', - '' Used flux: '',E15.8,'' V ''/26X, - ''Start offset: '',F10.3)') FLXSUM,XL0FLX IF(FLXSUM.LE.0)THEN PRINT *,' !!!!!! TRACLS WARNING : 1-Sided flux'// - ' integral is not > 0; no clusters.' RETURN ELSEIF(XL0FLX.LT.-0.5)THEN PRINT *,' !!!!!! TRACLS WARNING : No flux'// - ' interval without sign change found.' RETURN ELSEIF(IERROR.NE.0)THEN PRINT *,' ------ TRACLS MESSAGE : The flux'// - ' changes sign over the track; part of'// - ' the track not used.' ENDIF ENDIF ** Increment cluster counter. NTOT=NTOT+1 * Compute new cluster position. IF(NTOT.EQ.1)THEN XL=XL0FLX DONE=.FALSE. ELSEIF((NTOT-1)*TRFLUX.LE.FLXSUM)THEN XL=DIVDIF(FLXCOO,FLXTAB,MXLIST,REAL(NTOT-1)*TRFLUX,1) DONE=.FALSE. ELSE XL=XL0FLX DONE=.TRUE. OK=.FALSE. ENDIF XCLS=XT0+XL*(XT1-XT0) YCLS=YT0+XL*(YT1-YT0) ZCLS=ZT0+XL*(ZT1-ZT0) * Set the cluster size and energy. NPAIR=1 ECLS=0 *** Other track types. ELSE PRINT *,' !!!!!! TRACLS WARNING : Unknown track type'// - ' requested; no clusters' XCLS=0 YCLS=0 ZCLS=0 ECLS=0 NPAIR=0 DONE=.TRUE. OK=.FALSE. IFAIL=1 RETURN ENDIF *** Seems to have worked, set the IFAIL flag. IFAIL=0 RETURN *** Entry point for initialisation. ENTRY TRACLI IF(LIDENT)PRINT *,' /// ENTRY TRACLI ///' * Reset the number of clusters generated sofar. NTOT=0 IVGA=0 ETOT=0 * Set flag that clustering can proceed. OK=.TRUE. *** Set the particle identifier, fixed number. IF(ITRTYP.EQ.1)THEN CALL OUTFMT(REAL(NTRLIN),2,AUX,NCAUX,'LEFT') PARTID=AUX(1:NCAUX)//' equally spaced points' * Equal. ELSEIF(ITRTYP.EQ.2)THEN PARTID='Equally spaced clusters' * Exponential. ELSEIF(ITRTYP.EQ.3)THEN PARTID='Exponentially spaced clusters' * Heed. ELSEIF(ITRTYP.EQ.4)THEN IF(TRENER.LT.0.001)THEN CALL OUTFMT(TRENER*1000000,2,AUX,NCAUX,'LEFT') PARTID=PNAME(1:NCPNAM)//', Ekin='//AUX(1:NCAUX)//' eV' ELSEIF(TRENER.LT.1)THEN CALL OUTFMT(TRENER*1000,2,AUX,NCAUX,'LEFT') PARTID=PNAME(1:NCPNAM)//', Ekin='//AUX(1:NCAUX)//' keV' ELSEIF(TRENER.LT.1000)THEN CALL OUTFMT(TRENER,2,AUX,NCAUX,'LEFT') PARTID=PNAME(1:NCPNAM)//', Ekin='//AUX(1:NCAUX)//' MeV' ELSEIF(TRENER.LT.1000000)THEN CALL OUTFMT(TRENER/1000,2,AUX,NCAUX,'LEFT') PARTID=PNAME(1:NCPNAM)//', Ekin='//AUX(1:NCAUX)//' GeV' ELSE CALL OUTFMT(TRENER/1000000,2,AUX,NCAUX,'LEFT') PARTID=PNAME(1:NCPNAM)//', Ekin='//AUX(1:NCAUX)//' TeV' ENDIF qgvga(1)=0 qdel=0 qcel(1)=0 qrga=0 * Weighted. ELSEIF(ITRTYP.EQ.5)THEN CALL OUTFMT(REAL(NTRSAM),2,AUX,NCAUX,'LEFT') PARTID=AUX(1:NCAUX)//' samples of '//FCNTRW(1:NCTRW) * Single cluster. ELSEIF(ITRTYP.EQ.6)THEN PARTID='Single cluster' * Fixed number of flux lines. ELSEIF(ITRTYP.EQ.7)THEN CALL OUTFMT(REAL(NTRFLX),2,AUX,NCAUX,'LEFT') PARTID=AUX(1:NCAUX)//' flux lines' * Constant flux intervals. ELSEIF(ITRTYP.EQ.8)THEN CALL OUTFMT(TRFLUX,2,AUX,NCAUX,'LEFT') PARTID='Flux intervals of '//AUX(1:NCAUX)//' V' * Anything else. ELSE PARTID='Unknown' ENDIF END +DECK,TRAPLT. SUBROUTINE TRAPLT *----------------------------------------------------------------------- * TRAPLT - Plots the track with the delta electrons. * (Last changed on 3/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,GASDATA. +SEQ,CELLDATA. +SEQ,volume. +SEQ,goevent. +SEQ,del. +SEQ,cel. +SEQ,abs. +SEQ,rga. +SEQ,lsgvga. REAL XCLS,YCLS,ZCLS DOUBLE PRECISION XPLDEL(pqcel),YPLDEL(pqcel),ZPLDEL(pqcel), - XPLVGA(pqgvga),YPLVGA(pqgvga),ZPLVGA(pqgvga), - XPL(2),YPL(2),ZPL(2),ETOT INTEGER NELEC,I,J,K,NPL *** Apparently a HEED generated track. IF(HEEDOK.AND.ITRTYP.EQ.4)THEN ** Pick up relevant portion of the virtual gamma's. ETOT=0 NPL=0 DO 20 I=1,qgvga(1) XCLS=XT0+COS(TRPHI)*pntgvga(1,INDPOS(I),1)- - SIN(TRPHI)*SIN(TRTH)*pntgvga(2,INDPOS(I),1)+ - SIN(TRPHI)*COS(TRTH)*pntgvga(3,INDPOS(I),1) YCLS=YT0+COS(TRTH)*pntgvga(2,INDPOS(I),1)+ - SIN(TRTH)*pntgvga(3,INDPOS(I),1) ZCLS=ZT0-SIN(TRPHI)*pntgvga(1,INDPOS(I),1)- - COS(TRPHI)*SIN(TRTH)*pntgvga(2,INDPOS(I),1)+ - COS(TRPHI)*COS(TRTH)*pntgvga(3,INDPOS(I),1) ETOT=ETOT+egvga(INDPOS(I),1) NPL=NPL+1 XPLVGA(NPL)=XCLS YPLVGA(NPL)=YCLS ZPLVGA(NPL)=ZCLS IF(ETOT.GE.TRENER)GOTO 25 20 CONTINUE * All relevant virtual photons taken. 25 CONTINUE * Set the appropriate representations. CALL GRATTS('TRACK','POLYLINE') CALL GRATTS('TRACK','POLYMARKER') * Plot the particle trajectory. IF(POLAR)CALL CF2CTR(XPLVGA,YPLVGA,XPLVGA,YPLVGA,NPL) IF(NPL.GT.1)THEN CALL PLAGPL(NPL,XPLVGA,YPLVGA,ZPLVGA) ELSEIF(NPL.EQ.1)THEN CALL PLAGPM(NPL,XPLVGA,YPLVGA,ZPLVGA) ENDIF ** Next plot each of the deltas and Auger electrons. ETOT=0 * Loop over the virtual photons. DO 50 K=1,qgvga(1) * Loop over the associated delta's. DO 30 I=1,qdel IF(ptdel(I).NE.INDPOS(K).OR.edel(I).LE.0)GOTO 30 * Set the attributes depending on the type. IF(sodel(I).EQ.0)THEN CALL GRATTS('DELTA-ELECTRON','POLYLINE') CALL GRATTS('DELTA-ELECTRON','POLYMARKER') ELSE CALL GRATTS('AUGER-ELECTRON','POLYLINE') CALL GRATTS('AUGER-ELECTRON','POLYMARKER') ENDIF * Store the starting point. XCLS=XT0+COS(TRPHI)*pntgvga(1,INDPOS(K),1)- - SIN(TRPHI)*SIN(TRTH)*pntgvga(2,INDPOS(K),1)+ - SIN(TRPHI)*COS(TRTH)*pntgvga(3,INDPOS(K),1) YCLS=YT0+COS(TRTH)*pntgvga(2,INDPOS(K),1)+ - SIN(TRTH)*pntgvga(3,INDPOS(K),1) ZCLS=ZT0-SIN(TRPHI)*pntgvga(1,INDPOS(K),1)- - COS(TRPHI)*SIN(TRTH)*pntgvga(2,INDPOS(K),1)+ - COS(TRPHI)*COS(TRTH)*pntgvga(3,INDPOS(K),1) NELEC=1 XPLDEL(NELEC)=XCLS YPLDEL(NELEC)=YCLS ZPLDEL(NELEC)=ZCLS nelec=0 * Find the associated electrons. DO 40 J=1,qcel(1) IF(ndelcel(J,1).EQ.I)THEN NELEC=NELEC+1 XCLS=XT0+COS(TRPHI)*pntcel(1,J,1)- - SIN(TRPHI)*SIN(TRTH)*pntcel(2,J,1)+ - SIN(TRPHI)*COS(TRTH)*pntcel(3,J,1) YCLS=YT0+COS(TRTH)*pntcel(2,J,1)+ - SIN(TRTH)*pntcel(3,J,1) ZCLS=ZT0-SIN(TRPHI)*pntcel(1,J,1)- - COS(TRPHI)*SIN(TRTH)*pntcel(2,J,1)+ - COS(TRPHI)*COS(TRTH)*pntcel(3,J,1) XPLDEL(NELEC)=XCLS YPLDEL(NELEC)=YCLS ZPLDEL(NELEC)=ZCLS ENDIF 40 CONTINUE * Keep track of total energy. IF(ETOT+edel(I).GT.TRENER)THEN NELEC=NELEC*(TRENER-ETOT)/edel(I) ETOT=TRENER+1 ELSE ETOT=ETOT+edel(I) ENDIF * Plot the particle trajectory. IF(POLAR)CALL CF2CTR(XPLDEL,YPLDEL,XPLDEL,YPLDEL,NELEC) IF(NELEC.GT.1)THEN CALL PLAGPL(NELEC,XPLDEL,YPLDEL,ZPLDEL) ELSEIF(NELEC.EQ.1)THEN CALL PLAGPM(NELEC,XPLDEL,YPLDEL,ZPLDEL) ENDIF * Quit if energy limit reached. IF(ETOT.GE.TRENER)GOTO 60 * Next delta. 30 CONTINUE * Next virtual gamma. 50 CONTINUE * Energy limit. 60 CONTINUE ** Next plot the real photons. ETOT=0 * Set attributes. CALL GRATTS('PHOTON','POLYLINE') CALL GRATTS('PHOTON','POLYMARKER') * Loop over virtual gamma's. DO 150 K=1,qgvga(1) XCLS=XT0+COS(TRPHI)*pntgvga(1,INDPOS(K),1)- - SIN(TRPHI)*SIN(TRTH)*pntgvga(2,INDPOS(K),1)+ - SIN(TRPHI)*COS(TRTH)*pntgvga(3,INDPOS(K),1) YCLS=YT0+COS(TRTH)*pntgvga(2,INDPOS(K),1)+ - SIN(TRTH)*pntgvga(3,INDPOS(K),1) ZCLS=ZT0-SIN(TRPHI)*pntgvga(1,INDPOS(K),1)- - COS(TRPHI)*SIN(TRTH)*pntgvga(2,INDPOS(K),1)+ - COS(TRPHI)*COS(TRTH)*pntgvga(3,INDPOS(K),1) XPL(1)=XCLS YPL(1)=YCLS ZPL(1)=ZCLS * Find the corresponding real photons and plot them. DO 130 I=1,qrga IF(ptrga(I).NE.INDPOS(K))GOTO 130 XCLS=XT0+COS(TRPHI)*pntrga(1,I)- - SIN(TRPHI)*SIN(TRTH)*pntrga(2,I)+ - SIN(TRPHI)*COS(TRTH)*pntrga(3,I) YCLS=YT0+COS(TRTH)*pntrga(2,I)+ - SIN(TRTH)*pntrga(3,I) ZCLS=ZT0-SIN(TRPHI)*pntrga(1,I)- - COS(TRPHI)*SIN(TRTH)*pntrga(2,I)+ - COS(TRPHI)*COS(TRTH)*pntrga(3,I) XPL(2)=XCLS YPL(2)=YCLS ZPL(2)=ZCLS IF(POLAR)CALL CF2CTR(XPL,YPL,XPL,YPL,2) CALL PLAGPL(2,XPL,YPL,ZPL) * Keep track of total energy. ETOT=ETOT+erga(I) * Quit if energy limit reached. IF(ETOT.GE.TRENER)GOTO 160 * Next real photon. 130 CONTINUE * Next virtual gamma. 150 CONTINUE * Energy limit. 160 CONTINUE *** Any other kind of track. ELSE * Set the appropriate representations. CALL GRATTS('TRACK','POLYLINE') CALL GRATTS('TRACK','POLYMARKER') * And plot the track as a straight line. XPL(1)=XT0 YPL(1)=YT0 ZPL(1)=ZT0 XPL(2)=XT1 YPL(2)=YT1 ZPL(2)=ZT1 IF(POLAR)CALL CF2CTR(XPL,YPL,XPL,YPL,2) CALL PLAGPL(2,XPL,YPL,ZPL) ENDIF END +DECK,TRAREA. SUBROUTINE TRAREA *----------------------------------------------------------------------- * TRAREA - Reads a track definition * (Last changed on 14/ 5/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,GLOBALS. INTEGER NWORD,INPCMP,INPTYP,IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5, - IFAIL6,NLINR,I,J,INEXT,NCAUX,NRES,NVAR,IENWGT,NCNAME, - MODVAR(1),NREXP,MODRES(1),NSAMR,IRCOOR,IRWGT,ISCOOR,ISWGT, - MATSLT,IORD,NC1,NC2,NC3,NC4,NC5,NC6,NFLXR REAL XMASS,XENER,XDIST,XCHAR,XNORM,XT0D,XT1D,YT0D,YT1D,ZT0D,ZT1D, - FACT,XDIR,YDIR,ZDIR,RES(1),VAR(1),WGTSUM,FLXR LOGICAL START,END,DIST,DIR,ENER,MASS,CHARGE,USE(1),OK EXTERNAL INPCMP,INPTYP,MATSLT CHARACTER*10 VARLIS(1),NAME CHARACTER*13 AUX1,AUX2,AUX3,AUX4,AUX5,AUX6 CHARACTER*20 AUX *** Identify the procedure if requested. IF(LIDENT)PRINT *,' /// ROUTINE TRAREA ///' *** Count words. CALL INPNUM(NWORD) *** Perhaps only printing has been requested. IF(NWORD.EQ.1)THEN * Track location. IF(TRFLAG(1))THEN XT0D=XT0 YT0D=YT0 ZT0D=ZT0 XT1D=XT1 YT1D=YT1 ZT1D=ZT1 IF(POLAR)THEN CALL CFMCTP(XT0D,YT0D,XT0D,YT0D,1) CALL CFMCTP(XT1D,YT1D,XT1D,YT1D,1) ENDIF CALL OUTFMT(XT0D,2,AUX1,NC1,'LEFT') CALL OUTFMT(YT0D,2,AUX2,NC2,'LEFT') CALL OUTFMT(ZT0D,2,AUX3,NC3,'LEFT') CALL OUTFMT(XT1D,2,AUX4,NC4,'LEFT') CALL OUTFMT(YT1D,2,AUX5,NC5,'LEFT') CALL OUTFMT(ZT1D,2,AUX6,NC6,'LEFT') WRITE(LUNOUT,'('' The current track runs from '', - ''('',A,'','',A,'','',A,'') to '', - ''('',A,'','',A,'','',A,'').'')') - AUX1(1:NC1),AUX2(1:NC2),AUX3(1:NC3), - AUX4(1:NC4),AUX5(1:NC5),AUX6(1:NC6) ELSE WRITE(LUNOUT,'('' The location of the track is'', - '' not yet defined.'')') ENDIF * Particle type. IF(TRFLAG(2))THEN CALL OUTFMT(TRMASS,2,AUX1,NC1,'LEFT') CALL OUTFMT(TRENER,2,AUX2,NC2,'LEFT') CALL OUTFMT(TRCHAR,2,AUX3,NC3,'LEFT') WRITE(LUNOUT,'('' The particle is a '',A,'' with a'', - '' mass of '',A,'' MeV,''/'' an energy of '',A, - '' MeV and a charge of '',A, - '' proton charges.'')') PNAME(1:NCPNAM), - AUX1(1:NC1),AUX2(1:NC2),AUX3(1:NC3) ENDIF * Clustering type: fixed. IF(ITRTYP.EQ.1.AND.TRFLAG(3))THEN CALL OUTFMT(REAL(NTRLIN),2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' There will be '',A,'' equally'', - '' spaced clusters on the track.'')') AUX1(1:NC1) ELSEIF(ITRTYP.EQ.1.AND..NOT.TRFLAG(3))THEN WRITE(LUNOUT,'('' There will be equally'', - '' spaced clusters on the track.'')') * Clustering type: equal spacing. ELSEIF(ITRTYP.EQ.2)THEN WRITE(LUNOUT,'('' Clusters will be equally spaced'', - '' respecting the mean from the gas section.'')') * Clustering type: exponential spacing. ELSEIF(ITRTYP.EQ.3)THEN WRITE(LUNOUT,'('' Clusters will be exponentially'', - '' spaced with a mean distance as entered'', - '' in the gas section.'')') * Clustering type: processing by HEED. ELSEIF(ITRTYP.EQ.4)THEN WRITE(LUNOUT,'('' Clusters will be generated by'', - '' HEED,'')') IF(LTRMS)THEN WRITE(LUNOUT,'('' the incoming particle'', - '' undergoes multiple scattering,'')') ELSE WRITE(LUNOUT,'('' the incoming particle does'', - '' not undergo multiple scattering,'')') ENDIF IF(LTRDEL)THEN WRITE(LUNOUT,'('' delta electrons have a'', - '' spatial extent.'')') ELSE WRITE(LUNOUT,'('' delta electrons are'', - '' compactified onto the main track.'')') ENDIF * Weighted cluster location distribution. ELSEIF(ITRTYP.EQ.5)THEN CALL OUTFMT(REAL(NTRSAM),2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' There will be '',A,'' clusters'', - '' at positions weighted according to '',A)') - AUX1(1:NC1),FCNTRW(1:NCTRW) * Single cluster. ELSEIF(ITRTYP.EQ.6)THEN WRITE(LUNOUT,'('' There will be a single cluster'', - '' at a random position.'')') * Equal flux lines. ELSEIF(ITRTYP.EQ.7)THEN CALL OUTFMT(REAL(NTRFLX),2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' There will be '',A,'' clusters'', - '' at equal flux intervals.'')') AUX1(1:NC1) * Flux intervals. ELSEIF(ITRTYP.EQ.8)THEN CALL OUTFMT(TRFLUX,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' Clusters will be spaced by a'', - '' flux of '',A,'' V.'')') AUX1(1:NC1) ENDIF RETURN ENDIF *** Preset flags. START =.FALSE. END =.FALSE. DIST =.FALSE. DIR =.FALSE. ENER =.FALSE. MASS =.FALSE. CHARGE=.FALSE. *** Compute default track parameters. XT0D=XT0 YT0D=YT0 ZT0D=ZT0 XT1D=XT1 YT1D=YT1 ZT1D=ZT1 IF(POLAR)THEN CALL CFMCTP(XT0D,YT0D,XT0D,YT0D,1) CALL CFMCTP(XT1D,YT1D,XT1D,YT1D,1) ENDIF *** Format: (x0,y0,z0) (x1,y1,z1) IF(NWORD.GE.7.AND.INPTYP(2).GE.1.AND.INPTYP(3).GE.1.AND. - INPTYP(4).GE.1.AND.INPTYP(5).GE.1.AND. - INPTYP(6).GE.1.AND.INPTYP(7).GE.1)THEN CALL INPCHK(2,2,IFAIL1) CALL INPCHK(3,2,IFAIL2) CALL INPCHK(4,2,IFAIL3) CALL INPCHK(5,2,IFAIL4) CALL INPCHK(6,2,IFAIL5) CALL INPCHK(7,2,IFAIL6) CALL INPRDR(2,XT0D,XT0D) CALL INPRDR(3,YT0D,YT0D) CALL INPRDR(4,ZT0D,ZT0D) CALL INPRDR(5,XT1D,XT1D) CALL INPRDR(6,YT1D,YT1D) CALL INPRDR(7,ZT1D,ZT1D) START=.TRUE. END=.TRUE. INEXT=8 *** Format: (x0,y0) (x1,y1) ELSEIF(NWORD.GE.5.AND.INPTYP(2).GE.1.AND.INPTYP(3).GE.1.AND. - INPTYP(4).GE.1.AND.INPTYP(5).GE.1)THEN CALL INPCHK(2,2,IFAIL1) CALL INPCHK(3,2,IFAIL2) CALL INPCHK(4,2,IFAIL3) CALL INPCHK(5,2,IFAIL4) CALL INPRDR(2,XT0D,XT0D) CALL INPRDR(3,YT0D,YT0D) ZT0D=0 CALL INPRDR(4,XT1D,XT1D) CALL INPRDR(5,YT1D,YT1D) ZT1D=0 START=.TRUE. END=.TRUE. INEXT=6 *** Format: (x0,y0,z0) ELSEIF(NWORD.GE.4.AND.INPTYP(2).GE.1.AND.INPTYP(3).GE.1.AND. - INPTYP(4).GE.1)THEN CALL INPCHK(2,2,IFAIL1) CALL INPCHK(3,2,IFAIL2) CALL INPCHK(4,2,IFAIL3) CALL INPRDR(2,XT0D,XT0D) CALL INPRDR(3,YT0D,YT0D) CALL INPRDR(4,ZT0D,ZT0D) START=.TRUE. INEXT=5 *** Format: (x0,y0) ELSEIF(NWORD.GE.3.AND.INPTYP(2).GE.1.AND.INPTYP(3).GE.1)THEN CALL INPCHK(2,2,IFAIL1) CALL INPCHK(3,2,IFAIL2) CALL INPRDR(2,XT0D,XT0D) CALL INPRDR(3,YT0D,YT0D) ZT0D=0 START=.TRUE. INEXT=4 ELSE INEXT=2 ENDIF *** Now scan from here on for further arguments. DO 10 I=1,NWORD IF(I.LT.INEXT)GOTO 10 * Could be a starting point. IF(INPCMP(I,'FR#OM')+INPCMP(I,'START#ING-#POINT').NE.0)THEN IF(NWORD.LT.I+2.OR. - INPTYP(I+1).LE.0.OR.INPTYP(I+2).LE.0)THEN CALL INPMSG(I,'Has 2 or 3 real arguments.') ELSEIF(INPTYP(I+3).LE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,XT0D,XT0D) CALL INPRDR(I+2,YT0D,YT0D) ZT0D=0 START=.TRUE. INEXT=I+3 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPCHK(I+3,2,IFAIL3) CALL INPRDR(I+1,XT0D,XT0D) CALL INPRDR(I+2,YT0D,YT0D) CALL INPRDR(I+3,ZT0D,ZT0D) START=.TRUE. INEXT=I+4 ENDIF * Could be an end point. ELSEIF(INPCMP(I,'TO')+INPCMP(I,'END-#POINT').NE.0)THEN IF(NWORD.LT.I+2.OR. - INPTYP(I+1).LE.0.OR.INPTYP(I+2).LE.0)THEN CALL INPMSG(I,'Has 2 or 3 real arguments.') ELSEIF(INPTYP(I+3).LE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,XT1D,XT1D) CALL INPRDR(I+2,YT1D,YT1D) ZT1D=0 END=.TRUE. INEXT=I+3 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPCHK(I+3,2,IFAIL3) CALL INPRDR(I+1,XT1D,XT1D) CALL INPRDR(I+2,YT1D,YT1D) CALL INPRDR(I+3,ZT1D,ZT1D) END=.TRUE. INEXT=I+4 ENDIF * Could be a direction vector. ELSEIF(INPCMP(I,'DIR#ECTION').NE.0)THEN IF(INPCMP(I+1,'X')+INPCMP(I+1,'POS#ITIVE-X').NE.0)THEN TRXDIR=+1 TRYDIR= 0 TRZDIR= 0 DIR=.TRUE. INEXT=I+2 ELSEIF(INPCMP(I+1,'NEG#ATIVE-X').NE.0)THEN TRXDIR=-1 TRYDIR= 0 TRZDIR= 0 DIR=.TRUE. INEXT=I+2 ELSEIF(INPCMP(I+1,'Y')+INPCMP(I+1,'POS#ITIVE-Y').NE.0)THEN TRXDIR= 0 TRYDIR=+1 TRZDIR= 0 DIR=.TRUE. INEXT=I+2 ELSEIF(INPCMP(I+1,'NEG#ATIVE-Y').NE.0)THEN TRXDIR= 0 TRYDIR=-1 TRZDIR= 0 DIR=.TRUE. INEXT=I+2 ELSEIF(INPCMP(I+1,'Z')+INPCMP(I+1,'POS#ITIVE-Z').NE.0)THEN TRXDIR= 0 TRYDIR= 0 TRZDIR=+1 DIR=.TRUE. INEXT=I+2 ELSEIF(INPCMP(I+1,'NEG#ATIVE-Z').NE.0)THEN TRXDIR= 0 TRYDIR= 0 TRZDIR=-1 DIR=.TRUE. INEXT=I+2 ELSEIF(NWORD.LT.I+2.OR. - INPTYP(I+1).LE.0.OR.INPTYP(I+2).LE.0)THEN CALL INPMSG(I,'Has 2 or 3 real arguments.') ELSEIF(INPTYP(I+3).LE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,XDIR,0.0) CALL INPRDR(I+2,YDIR,0.0) ZDIR=0.0 DIR=.TRUE. INEXT=I+3 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPCHK(I+3,2,IFAIL3) CALL INPRDR(I+1,XDIR,0.0) CALL INPRDR(I+2,YDIR,0.0) CALL INPRDR(I+3,ZDIR,0.0) DIR=.TRUE. INEXT=I+4 ENDIF IF(DIR)THEN XNORM=SQRT(XDIR**2+YDIR**2+ZDIR**2) IF(XNORM.LE.0)THEN CALL INPMSG(I,'Vector has norm 0') DIR=.FALSE. ELSE XDIR=XDIR/XNORM YDIR=YDIR/XNORM ZDIR=ZDIR/XNORM ENDIF ENDIF * Could be a range. ELSEIF(INPCMP(I,'DIST#ANCE').NE.0.OR. - INPCMP(I,'RANGE').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Has 1 real argument.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,XDIST,-1.0) IF(XDIST.LT.0)THEN CALL INPMSG(I+1,'Range is not >= 0.') ELSE TRDIST=XDIST DIST=.TRUE. ENDIF INEXT=I+2 ENDIF * Could be a particle identifier [PDG, Phys Rev D 54 (1996)] ELSEIF(INPCMP(I,'ELE#CTRON')+INPCMP(I,'E-M#INUS').NE.0)THEN TRMASS=0.51099907 TRCHAR=-1 MASS=.TRUE. CHARGE=.TRUE. PNAME='electron-' NCPNAM=9 ITRTYP=4 ELSEIF(INPCMP(I,'POS#ITRON')+INPCMP(I,'E-P#LUS')+ - INPCMP(I,'E+').NE.0)THEN TRMASS=0.51099907 TRCHAR=+1 MASS=.TRUE. CHARGE=.TRUE. PNAME='electron+' NCPNAM=9 ITRTYP=4 ELSEIF(INPCMP(I,'MU#ON-#MINUS').NE.0)THEN TRMASS=105.658389 TRCHAR=-1 MASS=.TRUE. CHARGE=.TRUE. PNAME='mu-' NCPNAM=3 ITRTYP=4 ELSEIF(INPCMP(I,'MU#ON-P#LUS')+INPCMP(I,'MU+').NE.0)THEN TRMASS=105.658389 TRCHAR=+1 MASS=.TRUE. CHARGE=.TRUE. PNAME='mu+' NCPNAM=3 ITRTYP=4 ELSEIF(INPCMP(I,'TAU-#MINUS').NE.0)THEN TRMASS=1777.00 TRCHAR=-1 MASS=.TRUE. CHARGE=.TRUE. PNAME='tau-' NCPNAM=4 ITRTYP=4 ELSEIF(INPCMP(I,'TAU-P#LUS')+INPCMP(I,'TAU+').NE.0)THEN TRMASS=1777.00 TRCHAR=+1 MASS=.TRUE. CHARGE=.TRUE. PNAME='tau+' NCPNAM=4 ITRTYP=4 ELSEIF(INPCMP(I,'GAMMA')+INPCMP(I,'PHOTON').NE.0)THEN CALL INPMSG(I,'Photons not yet available.') ELSEIF(INPCMP(I,'PI#ON-#MINUS').NE.0)THEN TRMASS=139.56995 TRCHAR=-1 MASS=.TRUE. CHARGE=.TRUE. PNAME='pi-' NCPNAM=3 ITRTYP=4 ELSEIF(INPCMP(I,'PI#ON-0')+INPCMP(I,'PI#ON-Z#ERO')+ - INPCMP(I,'PI0').NE.0)THEN TRMASS=134.9764 TRCHAR= 0 MASS=.TRUE. CHARGE=.TRUE. PNAME='pi0' NCPNAM=3 ITRTYP=4 ELSEIF(INPCMP(I,'PI#ON-PLUS')+INPCMP(I,'PI+').NE.0)THEN TRMASS=139.56995 TRCHAR=+1 MASS=.TRUE. CHARGE=.TRUE. PNAME='pi+' NCPNAM=3 ITRTYP=4 ELSEIF(INPCMP(I,'K#AON-#MINUS').NE.0)THEN TRMASS=493.677 TRCHAR=-1 MASS=.TRUE. CHARGE=.TRUE. PNAME='K-' NCPNAM=2 ITRTYP=4 ELSEIF(INPCMP(I,'K#AON-0-#SHORT')+INPCMP(I,'K#AON-0-#LONG')+ - INPCMP(I,'K0-#SHORT')+INPCMP(I,'K0-#LONG')+ - INPCMP(I,'K#AON-Z#ERO-#SHORT')+ - INPCMP(I,'K#AON-Z#ERO-#LONG')+ - INPCMP(I,'K0-#SHORT')+INPCMP(I,'K0-#LONG').NE.0)THEN TRMASS=497.672 TRCHAR= 0 MASS=.TRUE. CHARGE=.TRUE. PNAME='K0' NCPNAM=2 ITRTYP=4 ELSEIF(INPCMP(I,'K#AON-P#LUS')+INPCMP(I,'K+').NE.0)THEN TRMASS=493.677 TRCHAR=-1 MASS=.TRUE. CHARGE=.TRUE. PNAME='K+' NCPNAM=2 ITRTYP=4 ELSEIF(INPCMP(I,'PR#OTON').NE.0)THEN TRMASS=938.27231 TRCHAR=+1 MASS=.TRUE. CHARGE=.TRUE. PNAME='proton' NCPNAM=6 ITRTYP=4 ELSEIF(INPCMP(I,'ANTI-PR#OTON').NE.0)THEN TRMASS=938.27231 TRCHAR=-1 MASS=.TRUE. CHARGE=.TRUE. PNAME='antiproton' NCPNAM=10 ITRTYP=4 ELSEIF(INPCMP(I,'N#EUTRON')+INPCMP(I,'ANTI-N#EUTRON').NE.0)THEN TRMASS=939.56563 TRCHAR= 0 MASS=.TRUE. CHARGE=.TRUE. PNAME='neutron' NCPNAM=7 ITRTYP=4 * Manually described particle, first mass. ELSEIF(INPCMP(I,'MASS').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Must have 1 real argument') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,XMASS,TRMASS) IF(I+2.LE.NWORD.AND.INPCMP(I+2,'EV').NE.0)THEN FACT=1E-6 INEXT=I+3 ELSEIF(I+2.LE.NWORD.AND.INPCMP(I+2,'KEV').NE.0)THEN FACT=1E-3 INEXT=I+3 ELSEIF(I+2.LE.NWORD.AND.INPCMP(I+2,'MEV').NE.0)THEN FACT=1 INEXT=I+3 ELSEIF(I+2.LE.NWORD.AND.INPCMP(I+2,'GEV').NE.0)THEN FACT=1E+3 INEXT=I+3 ELSEIF(I+2.LE.NWORD.AND.INPCMP(I+2,'TEV').NE.0)THEN FACT=1E+6 INEXT=I+3 ELSE FACT=1 INEXT=I+2 ENDIF IF(XMASS.LT.0)THEN CALL INPMSG(I+1,'Mass is not >= 0.') ELSE TRMASS=FACT*XMASS MASS=.TRUE. ITRTYP=4 IF(TRMASS.LE.1)THEN CALL OUTFMT(ANINT(TRMASS*1000)/1000,2, - AUX,NCAUX,'LEFT') ELSE CALL OUTFMT(ANINT(TRMASS),2, - AUX,NCAUX,'LEFT') ENDIF PNAME='m('//AUX(1:NCAUX)//')' NCPNAM=MIN(LEN(PNAME),NCAUX+3) ENDIF ENDIF * Charge. ELSEIF(INPCMP(I,'CH#ARGE').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Must have 1 real argument') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,XCHAR,TRCHAR) IF(ABS(XCHAR).LT.0.99.OR.ABS(XCHAR).GT.1.01)THEN CALL INPMSG(I,'Currently only +1 or -1.') ELSE TRCHAR=XCHAR CHARGE=.TRUE. ITRTYP=4 ENDIF INEXT=I+2 ENDIF * Energy of the particle. ELSEIF(INPCMP(I,'ENE#RGY').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Must have 1 real argument') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,XENER,TRENER) IF(I+2.LE.NWORD.AND.INPCMP(I+2,'EV').NE.0)THEN FACT=1E-6 INEXT=I+3 ELSEIF(I+2.LE.NWORD.AND.INPCMP(I+2,'KEV').NE.0)THEN FACT=1E-3 INEXT=I+3 ELSEIF(I+2.LE.NWORD.AND.INPCMP(I+2,'MEV').NE.0)THEN FACT=1 INEXT=I+3 ELSEIF(I+2.LE.NWORD.AND.INPCMP(I+2,'GEV').NE.0)THEN FACT=1E+3 INEXT=I+3 ELSEIF(I+2.LE.NWORD.AND.INPCMP(I+2,'TEV').NE.0)THEN FACT=1E+6 INEXT=I+3 ELSE FACT=1 INEXT=I+2 ENDIF IF(XENER.LE.0)THEN CALL INPMSG(I+1,'Energy is not > 0.') ELSE TRENER=FACT*XENER ENER=.TRUE. ITRTYP=4 ENDIF ENDIF * Delta electrons or not. ELSEIF(INPCMP(I,'DELTA-#ELECTRONS').NE.0)THEN LTRDEL=.TRUE. ITRTYP=4 ELSEIF(INPCMP(I,'NODELTA-#ELECTRONS').NE.0)THEN LTRDEL=.FALSE. * Trace delta electrons or not. ELSEIF(INPCMP(I,'TR#ACE-DELTA-#ELECTRONS').NE.0)THEN LTREXB=.TRUE. ITRTYP=4 ELSEIF(INPCMP(I,'NOTR#ACE-DELTA-#ELECTRONS').NE.0)THEN LTREXB=.FALSE. * Multiple scattering or not. ELSEIF(INPCMP(I,'MULT#IPLE-SC#ATTERING').NE.0)THEN LTRMS=.TRUE. ITRTYP=4 ELSEIF(INPCMP(I,'NOMULT#IPLE-SC#ATTERING').NE.0)THEN LTRMS=.FALSE. * Track interpolation or not. ELSEIF(INPCMP(I,'INT#ERPOLATE-TR#ACK').NE.0)THEN LTRINT=.TRUE. ELSEIF(INPCMP(I,'NOINT#ERPOLATE-TR#ACK').NE.0)THEN LTRINT=.FALSE. * Number of points on the track. ELSEIF(INPCMP(I,'LINE#S')+INPCMP(I,'POINT#S').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Must have 1 integer argument') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NLINR,NTRLIN) IF(NLINR.LT.0)THEN CALL INPMSG(I+1,'Number is not > 0.') ELSE NTRLIN=NLINR TRFLAG(3)=.TRUE. ITRTYP=1 ENDIF INEXT=I+2 ENDIF * Number of sampling points on the track. ELSEIF(INPCMP(I,'SAMP#LING')+INPCMP(I,'SAMP#LES').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Must have 1 integer argument') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NSAMR,NTRSAM) IF(NLINR.LT.0)THEN CALL INPMSG(I+1,'Number is not > 0.') ELSE NTRSAM=NSAMR TRFLAG(5)=.TRUE. ITRTYP=5 ENDIF INEXT=I+2 ENDIF ** Weighting function. ELSEIF(INPCMP(I,'WEIGHT#ING-F#UNCTION').NE.0)THEN IF(NWORD.LT.I+1)THEN CALL INPMSG(I,'Should have an argument') * In the form of matrices. ELSEIF(INPCMP(I+2,'VS').NE.0.AND.I+3.LE.NWORD)THEN * Locate the matrices. IRCOOR=0 IRWGT=0 CALL INPSTR(I+1,I+1,NAME,NCNAME) DO 110 J=1,NGLB IF(GLBMOD(J).EQ.5.AND.GLBVAR(J).EQ.NAME(1:NCNAME)) - IRWGT=NINT(GLBVAL(J)) 110 CONTINUE ISWGT=MATSLT(IRWGT) CALL INPSTR(I+3,I+3,NAME,NCNAME) DO 120 J=1,NGLB IF(GLBMOD(J).EQ.5.AND.GLBVAR(J).EQ.NAME(1:NCNAME)) - IRCOOR=NINT(GLBVAL(J)) 120 CONTINUE ISCOOR=MATSLT(IRCOOR) IF(ISWGT.EQ.0)CALL INPMSG(I+1,'Not a known matrix.') IF(ISCOOR.EQ.0)CALL INPMSG(I+3,'Not a known matrix.') * Carry out interpolation. IF(ISCOOR.NE.0.AND.ISWGT.NE.0)THEN IORD=2 WGTSUM=0 OK=.TRUE. DO 130 J=1,MXLIST VAR(1)=REAL(J-1)/REAL(MXLIST-1) CALL MATIN1(IRCOOR,IRWGT,1,VAR(1),RES(1), - ISCOOR,ISWGT,IORD,IFAIL1) WGT(J)=MAX(0.0,RES(1)) IF(RES(1).LT.0)OK=.FALSE. WGTSUM=WGTSUM+WGT(J) 130 CONTINUE IF(WGTSUM.GT.0.AND.OK)THEN CALL HISPRD(WGT,MXLIST) ITRTYP=5 CALL INPSTR(I+1,I+3,FCNTRW,NCTRW) TRFLAG(4)=.TRUE. ELSEIF(.NOT.OK)THEN CALL INPMSG(I+1,'Sometimes < 0.') ELSE CALL INPMSG(I+1,'Has a zero norm.') ENDIF ENDIF INEXT=I+4 * In the form of a function. ELSE CALL INPSTR(I+1,I+1,FCNTRW,NCTRW) VARLIS(1)='T' NVAR=1 CALL ALGPRE(FCNTRW(1:NCTRW),NCTRW,VARLIS,NVAR, - NRES,USE,IENWGT,IFAIL1) IF(IFAIL1.NE.0)THEN CALL INPMSG(I+1,'Not a valid function.') ELSE WGTSUM=0 OK=.TRUE. DO 30 J=1,MXLIST VAR(1)=REAL(J-1)/REAL(MXLIST-1) MODVAR(1)=2 NVAR=1 NREXP=1 CALL ALGEXE(IENWGT,VAR,MODVAR,NVAR,RES, - MODRES,NREXP,IFAIL1) WGT(J)=MAX(0.0,RES(1)) IF(RES(1).LT.0)OK=.FALSE. WGTSUM=WGTSUM+WGT(J) 30 CONTINUE CALL ALGCLR(IENWGT) CALL ALGERR IF(WGTSUM.GT.0.AND.OK)THEN CALL HISPRD(WGT,MXLIST) ITRTYP=5 TRFLAG(4)=.TRUE. ELSEIF(.NOT.OK)THEN CALL INPMSG(I+1,'Sometimes < 0.') ELSE CALL INPMSG(I+1,'Has a zero norm.') ENDIF ENDIF INEXT=I+2 ENDIF * Number of sampling points on the track. ELSEIF(INPCMP(I,'FL#UX-L#INES').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Must have 1 integer argument') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NFLXR,NTRFLX) IF(NFLXR.LT.2)THEN CALL INPMSG(I+1,'Number is not > 1.') ELSE NTRFLX=NFLXR TRFLAG(6)=.TRUE. ITRTYP=7 ENDIF INEXT=I+2 ENDIF * Number of sampling points on the track. ELSEIF(INPCMP(I,'FL#UX-INT#ERVALS').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Must have 1 real argument') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,FLXR,TRFLUX) IF(FLXR.LE.0)THEN CALL INPMSG(I+1,'Interval is not > 0.') ELSE TRFLUX=FLXR TRFLAG(7)=.TRUE. ITRTYP=8 ENDIF INEXT=I+2 ENDIF * Kind of cluster generation. ELSEIF(INPCMP(I,'FIX#ED-#NUMBER').NE.0)THEN ITRTYP=1 ELSEIF(INPCMP(I,'EQ#UAL-SP#ACING').NE.0)THEN ITRTYP=2 ELSEIF(INPCMP(I,'EXP#ONENTIAL-#SPACING').NE.0)THEN ITRTYP=3 ELSEIF(INPCMP(I,'HEED').NE.0)THEN ITRTYP=4 ELSEIF(INPCMP(I,'WEIGHT#ED-D#ISTRIBUTION').NE.0)THEN ITRTYP=5 ELSEIF(INPCMP(I,'SIN#GLE-#CLUSTER').NE.0)THEN ITRTYP=6 IF(.NOT.GASOK(5))PRINT *,' ------ TRAREA MESSAGE :'// - ' No cluster size distribution; cluster will'// - ' have size 1.' ELSEIF(INPCMP(I,'EQ#UAL-FL#UX-#INTERVALS').NE.0)THEN ITRTYP=7 ELSEIF(INPCMP(I,'CONS#TANT-FL#UX-#INTERVALS').NE.0)THEN ITRTYP=8 * Not a known keyword. ELSE CALL INPMSG(I,'Not a known keyword.') ENDIF 10 CONTINUE * Print the error messages. CALL INPERR *** If the cell is polar, then reconvert coordinates. IF(POLAR)THEN CALL CFMPTC(XT0D,YT0D,XT0,YT0,1) CALL CFMPTC(XT1D,YT1D,XT1,YT1,1) ZT0=ZT0D ZT1=ZT1D ELSE XT0=XT0D XT1=XT1D YT0=YT0D YT1=YT1D ZT0=ZT0D ZT1=ZT1D ENDIF *** Check completeness, first geometry. IF(START.AND.END.AND.DIST)THEN PRINT *,' ------ TRAREA MESSAGE : Both end point'// - ' and range specified; ignoring range.' XDIR=XT1-XT0 YDIR=YT1-YT0 ZDIR=ZT1-ZT0 TRDIST=SQRT(XDIR**2+YDIR**2+ZDIR**2) IF(TRDIST.GT.0)THEN XDIR=XDIR/TRDIST YDIR=YDIR/TRDIST ZDIR=ZDIR/TRDIST ELSE XDIR=0 YDIR=0 ZDIR=0 ENDIF * If neither end point nor direction and distance: assume point. ELSEIF(START.AND.(.NOT.END).AND.(.NOT.(DIST.AND.DIR)))THEN PRINT *,' ------ TRAREA MESSAGE : Only start point'// - ' specified; assuming single point track.' XT1=XT0 YT1=YT0 ZT1=ZT0 XDIR=0 YDIR=0 ZDIR=0 TRDIST=0 * If end point missing, compute from direction and range. ELSEIF(START.AND..NOT.END)THEN XT1=XT0+XDIR*TRDIST YT1=YT0+YDIR*TRDIST ZT1=ZT0+ZDIR*TRDIST * If direction and range missing, compute from end point. ELSEIF(START)THEN XDIR=XT1-XT0 YDIR=YT1-YT0 ZDIR=ZT1-ZT0 TRDIST=SQRT(XDIR**2+YDIR**2+ZDIR**2) IF(TRDIST.GT.0)THEN XDIR=XDIR/TRDIST YDIR=YDIR/TRDIST ZDIR=ZDIR/TRDIST ELSE XDIR=0 YDIR=0 ZDIR=0 ENDIF ENDIF * Set the track location flag if appropriate, reset preparation. IF(START)THEN TRFLAG(1)=.TRUE. CALL DLCTRR ENDIF * Check mass etc. IF(MASS.OR.CHARGE.OR.ENER)THEN IF(.NOT.CHARGE)THEN TRCHAR=-1.0 PRINT *,' ------ TRAREA MESSAGE : Charge not'// - ' specified; assuming negative charge.' ENDIF IF(.NOT.MASS)THEN TRMASS=105.658389 IF(TRCHAR.LT.0)THEN PNAME='mu-' ELSE PNAME='mu-' ENDIF NCPNAM=3 PRINT *,' ------ TRAREA MESSAGE : Mass not'// - ' specified; assuming a muon.' ENDIF IF(.NOT.ENER)THEN TRENER=1000.0 PRINT *,' ------ TRAREA MESSAGE : Energy not'// - ' specified; assuming 1 GeV.' ENDIF TRFLAG(2)=.TRUE. ENDIF *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ TRAREA DEBUG : '', - ''Start ('',E15.8,'','',E15.8,'','',E15.8,'')''/26X, - ''To ('',E15.8,'','',E15.8,'','',E15.8,'')''/26X, - ''Direction ('',E15.8,'','',E15.8,'','',E15.8,'')''/26X, - ''Range ='',E15.8,'' cm''/26X, - ''Mass ='',E15.8,'' MeV''/26X, - ''Energy ='',E15.8,'' MeV''/26X, - ''Charge ='',E15.8,'' electron charges''/26X, - ''Lines ='',I5/26X, - ''Type ='',I5,'' (1=fixed, 2=equal, 3=exp, 4=HEED,'', - '' 5=weighted, 6=single, 7=flux)''/26X, - ''Location '',L1,'', particle '',L1,'', lines '',L1/26X, - ''weighting function '',L1,'', samples '',L1/26X, - ''flux lines '',L1/26X, - ''MS '',L1,'', delta '',L1,'', trace delta '',L1, - '', interpolate '',L1)') - XT0,YT0,ZT0,XT1,YT1,ZT1,XDIR,YDIR,ZDIR, - TRDIST,TRMASS,TRENER,TRCHAR,NTRLIN,ITRTYP, - (TRFLAG(I),I=1,5),LTRMS,LTRDEL,LTREXB,LTRINT END +DECK,TRAEXB. SUBROUTINE TRAEXB(XIN,VIN,XOUT,VOUT,ENERGY,STEP,IFAIL) *----------------------------------------------------------------------- * TRAEXB - Traces an electron through an E and B field. * (Last changed on 10/ 2/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. DOUBLE PRECISION XIN(3),XOUT(3),VEL(3), - DT,T,WORK(18),SPEED,VNORM,STEP,RADIUS,GAMMA REAL BX,BY,BZ,BTOT,XPOS,YPOS,ZPOS,VIN(3),VOUT(3),ENERGY INTEGER I,IFAIL,NSTEP EXTERNAL TRASUB COMMON /EXBCOM/ GAMMA *** For now, assume that the routine will fail. IFAIL=1 *** Ensure that the energy is larger than 0. IF(ENERGY.LE.0)THEN PRINT *,' !!!!!! TRAEXB WARNING : Energy is not > 0;'// - ' not traced.' RETURN ENDIF *** Compute particle's speed (eV gives m/sec, need MeV to cm/microsec) SPEED=CLIGHT*SQRT(1-1/(1+(ECHARG*ENERGY)/ - (100*EMASS*CLIGHT**2))**2) *** Compute gamma factor which we'll need for the trajectory. GAMMA=1/SQRT(1-(SPEED/CLIGHT)**2) *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ TRAEXB DEBUG : Energy: '', - E15.8,'' MeV''/26X,''Speed: '',E15.8,'' cm/microsec''/ - 26X,''Gamma: '',E15.8)') ENERGY,SPEED,GAMMA *** Establish the speed vector. VNORM=SQRT(VIN(1)**2+VIN(2)**2+VIN(3)**2) IF(VNORM.LE.0)THEN PRINT *,' !!!!!! TRAEXB WARNING : Speed vector has norm'// - ' 0; not traced.' RETURN ENDIF VEL(1)=SPEED*VIN(1)/VNORM VEL(2)=SPEED*VIN(2)/VNORM VEL(3)=SPEED*VIN(3)/VNORM *** First estimate of the step size to be taken. NSTEP=10 DT=STEP/(10*SPEED) *** Estimate bending radius so as to get the scale for integration. XPOS=XT0+COS(TRPHI)*XIN(1)- - SIN(TRPHI)*SIN(TRTH)*XIN(2)+ - SIN(TRPHI)*COS(TRTH)*XIN(3) YPOS=YT0+COS(TRTH)*XIN(2)+ - SIN(TRTH)*XIN(3) ZPOS=ZT0-SIN(TRPHI)*XIN(1)- - COS(TRPHI)*SIN(TRTH)*XIN(2)+ - COS(TRPHI)*COS(TRTH)*XIN(3) CALL BFIELD(XPOS,YPOS,ZPOS,BX,BY,BZ,BTOT) IF(BTOT.GT.0)THEN RADIUS=1.0D8*(EMASS*SPEED)/(ECHARG*BTOT) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ TRAEXB DEBUG :'', - '' Bending radius: '',E15.8,'' cm.'')') RADIUS IF(RADIUS.LT.STEP)THEN NSTEP=NSTEP*2*NINT(STEP/RADIUS) DT=DT/(2*NINT(STEP/RADIUS)) ENDIF ENDIF *** Starting conditions. T=0 *** Make steps. XOUT(1)=XIN(1) XOUT(2)=XIN(2) XOUT(3)=XIN(3) DO 10 I=1,NSTEP CALL DRKNYS(3,DT,T,XOUT,VEL,TRASUB,WORK) 10 CONTINUE *** At the end, return the new velocity vector. VNORM=SQRT(VEL(1)**2+VEL(2)**2+VEL(3)**2) VOUT(1)=VEL(1)/VNORM VOUT(2)=VEL(2)/VNORM VOUT(3)=VEL(3)/VNORM *** Things seem to have worked properly. IFAIL=0 END +DECK,TRASUB. SUBROUTINE TRASUB(T,X,V,F) *----------------------------------------------------------------------- * TRASUB - Called when integrating the orbit of an electron. * (Last changed on 11/ 2/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. DOUBLE PRECISION T,X(3),V(3),F(3),GAMMA REAL EX,EY,EZ,ETOT,VOLT,BX,BY,BZ,BTOT,XPOS,YPOS,ZPOS, - EHX,EHY,EHZ,BHX,BHY,BHZ INTEGER ILOC COMMON /EXBCOM/ GAMMA *** Transform from Heed to Garfield coordinates. XPOS=XT0+COS(TRPHI)*X(1)- - SIN(TRPHI)*SIN(TRTH)*X(2)+ - SIN(TRPHI)*COS(TRTH)*X(3) YPOS=YT0+COS(TRTH)*X(2)+SIN(TRTH)*X(3) ZPOS=ZT0-SIN(TRPHI)*X(1)- - COS(TRPHI)*SIN(TRTH)*X(2)+ - COS(TRPHI)*COS(TRTH)*X(3) *** Compute the E and B field at the current position. CALL EFIELD(XPOS,YPOS,ZPOS,EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(XPOS,YPOS,ZPOS,BX,BY,BZ,BTOT) *** Transform the E and B field to Heed coordinates. EHX= COS(TRPHI)* EX -SIN(TRPHI)* EZ EHY=-SIN(TRPHI)*SIN(TRTH)*EX+COS(TRTH)*EY-COS(TRPHI)*SIN(TRTH)*EZ EHZ= SIN(TRPHI)*COS(TRTH)*EX+SIN(TRTH)*EY+COS(TRPHI)*COS(TRTH)*EZ BHX= COS(TRPHI)* BX -SIN(TRPHI)* BZ BHY=-SIN(TRPHI)*SIN(TRTH)*BX+COS(TRTH)*BY-COS(TRPHI)*SIN(TRTH)*BZ BHZ= SIN(TRPHI)*COS(TRTH)*BX+SIN(TRTH)*BY+COS(TRPHI)*COS(TRTH)*BZ *** Compute the force/mass [from C*V/cm to cm/microsec**2] F(1)=-1.0D-8*ECHARG*(EHX+V(2)*BHZ-V(3)*BHY)/(EMASS*GAMMA) F(2)=-1.0D-8*ECHARG*(EHY+V(3)*BHX-V(1)*BHZ)/(EMASS*GAMMA) F(3)=-1.0D-8*ECHARG*(EHZ+V(1)*BHY-V(2)*BHX)/(EMASS*GAMMA) END +PATCH,HEEDSUB. +DECK,PSHEED,IF=PSHEED. program PSHEED implicit none c include 'molecules.inc' +SEQ,molecule. c include 'molecdef.inc' +SEQ,molecdef. c include 'hs.inc' +SEQ,hs. integer qmol ! Quantity of different molecules ! in the gas mixture. integer nmol(pqMol) ! Their numbers from molecules.inc. ! Use only the named constants ! for compartibility with future versions. real wmol(pqMol) ! Their weights ! (relative quantities of molecules). real pres ! Pressure in Torr. real temp ! Temperature in K. real tkener ! Kinetic energy of incident particle(MeV). real mas ! Mass of incident particle(MeV) integer maxnum ! Maximum size of cluster(not used now). integer soo ! Flag allowed for writting. integer oo ! Output stream number. integer debug ! Flag allowed for writting of ! more amount of information. c Output parameters: real density ! Density, calculated as for ideal gas, gr/cm3 real dedx ! Mean dE/dx, mean energy loss, KeV/cm. real ntotal ! Average total number. real nclust ! number of clusters per cm. real clprob(msize) ! Probability of the clusters, ! Size=index. integer ierror ! Sign of error( 0 -- no error ). integer n c qmol=1 c nmol(1)=numm_Ar c wmol(1)=1.0 c nmol(1)=numm_CF4 c wmol(1)=1.0 qmol=3 nmol(1)=numm_Ar wmol(1)=0.30 nmol(2)=numm_CO2 wmol(2)=0.50 nmol(3)=numm_CF4 wmol(3)=0.20 pres=0.0 temp=0.0 tkener=0.0 mas=0.0 maxnum=0.0 soo=0 oo=10 open(oo,FILE='Heed.out') debug=0 call SHEED + (qmol, nmol, wmol, pres, temp, + tkener, mas, maxnum, soo, oo, debug, + dedx, ntotal, nclust, clprob, ierror) write(oo,*)' mean energy loss(KeV/cm)=',dedx write(oo,*)' total electron-ion pair number=',ntotal write(oo,*)' mean cluster number=',nclust do n=1,msize write(oo,*)n,clprob(n) enddo end +DECK,SHEED,IF=SHEED. subroutine SHEED + (qmol, nmol, pwmol, ppres, ptemp, + ptkener, pmas, maxnum, psoo, poo, debug, + density, dedx, ntotal, nclust, clprob, ierror) c c The subroutine for calculation of cluster size table by HEED package c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'molecules.inc' +SEQ,molecule. c include 'molecdef.inc' +SEQ,molecdef. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'crosec.inc' +SEQ,crosec. c include 'cconst.inc' +SEQ,cconst. c include 'volume.inc' +SEQ,volume. c include 'part.inc' +SEQ,part. c include 'hist.inc' +SEQ,hist. c include 'random.inc' +SEQ,random. c include 'hs.inc' +SEQ,hs. integer qmol ! Quantity of different molecules ! in the gas mixture. integer nmol(pqMol) ! Their numbers from molecules.inc. ! Use only the named constants ! for compartibility with the future versions real pwmol(pqMol) ! Their weights ! (relative quantities of molecules). real ppres ! Pressure in Torr. real ptemp ! Temperature in K. real ptkener ! Kinetic energy of incident particle(MeV) real pmas ! Mass of incident particle(MeV) integer maxnum ! Maximum size of cluster(not used now). integer psoo ! Flag allowing to write. integer poo ! Output stream number. integer debug ! Flag allowing to write ! more amount of information. c Output parameters: real density ! Density, calculated as for ideal gas, gr/cm3 real dedx ! Mean dE/dx, mean energy loss, KeV/cm. real ntotal ! Average total number. real nclust ! number of clusters per cm. real clprob(msize) ! Probability of the clusters, ! Size=index. integer ierror ! Sign of error( 0 -- no error ). real wmol(pqMol) integer n,nc,i real s real pres ! Pressure in Torr. real temp ! Temperature in K. real tkener ! Kinetic energy of incident particle. real mas ! Mass of incident particle. real step_integ_ar integer tresh parameter (tresh=20) real e1,e2 integer nmat integer nat c restore after previous run do nat=1,pQAt Zat(nat)=0 enddo nmat=1 QAtMat(nmat)=0 c go ahead s=0.0 do n=1,qmol s=s+pwmol(n) enddo do n=1,qmol wmol(n)=pwmol(n)/s enddo call Iniranfl soo=psoo oo=poo sret_err=1 sHist=0 ! To ban operating with historgams HistFile='heed.hist' ! To make sure. Histograms must not be filled ! and written here. maxhisampl=40.0e-3 maxhisampl2=20.0e-3 pqhisampl=100 shfillrang=0 c Random number genarator sseed=0 seed(1)=1121517854 ! this is example seed(2)=612958528 qevt=1000 ! Quantity of events to generate ssimioni=1 ! Simulate ionization loss ninfo=3 ! Number of first events with output listing call Inishl ! Cascade from excited atom call IniEner(150,3e-6,0.2) ! Energy mesh if(debug.ge.2)call PriEner call AtomsByDefault ! Library of atoms *** Added argument to PriAtoms (RV 13/4/99) if(debug.ge.2)call PriAtoms(0) *** End of modification. if(ppres.eq.0)then pres=Atm_Pressure else pres=ppres endif if(ptemp.eq.0)then temp=Atm_Temper else temp=ptemp endif call molecdef if(debug.ge.2)call Primolec call Inigas(nmat, qmol, nmol, wmol, pres, temp) *** Added argument to PriMatter (RV 13/4/99). if(debug.ge.2)call PriMatter(0) *** End of modification. if(s_err.eq.1)then ierror=1 return endif density=DensMat(nmat) call IniFVolume(0, nmat, 1, 1, 0.0, 1.0 ) if(debug.ge.2)call PriVolume if(pmas.eq.0)then mas=938 else mas=pmas endif if(ptkener.eq.0)then tkener=mas*(4-1) ! 'mip' else tkener=ptkener endif call IniPart(tkener,mas) ! Particle if(debug.ge.2)call Pripart if(s_err.eq.1)then ierror=1 return endif call IniRTrack(0.0, 0.0, 0.0, 0.0) call IniCrosec ! Cross sections if(debug.ge.2)call PriCrosec(1,1) call InisBdel ! Data for tracing of delta-electrons meanprob=0.0 meanvga=0.0 meanvgal=0.0 do i=1,msize prob(i)=0.0 enddo do nevt=1,qevt call GoEvent enddo s=step_integ_ar + (ener,addaC(1,nmat),qener,0.0,ener(qener+1)) s=s*XElDensMat(nmat) do nc=1,msize e1=WWW(nmat)*(nc-0.5) e2=WWW(nmat)*(nc+0.5) prob1(nc)=step_integ_ar + (ener,addaC(1,nmat),qener,e1,e2) prob1(nc)=prob1(nc)*XElDensMat(nmat)/s enddo dedx=meanC1(1)*1000.0 ntotal=meaneleC1(1) nclust=meanvga do nc=1,tresh clprob(nc)=prob(nc) enddo do nc=tresh+1,msize clprob(nc)=prob1(nc) enddo end +DECK,UEventS,IF=SHEED. subroutine UBegEvent implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'volume.inc' +SEQ,volume. end subroutine UEndEvent implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'volume.inc' +SEQ,volume. c include 'del.inc' +SEQ,del. c include 'cel.inc' +SEQ,cel. c include 'hs.inc' +SEQ,hs. c include 'lsgvga.inc' +SEQ,lsgvga. integer i,j,k,n,nb integer nc,na,nq real s n=0 if(qcel(1).eq.0)then goto 10 endif nb=Ptdel(Ndelcel(1,1)) k=0 do nc=1,qcel(1)+1 k=0 if(nc.eq.qcel(1)+1)then k=1 else if(nc.gt.1.and.Ptdel(Ndelcel(nc,1)).ne.nb)then k=1 endif endif if(k.eq.1)then if(n.le.0)then write(oo,*)' n=',n n=1 endif if(n.ge.msize+1)then write(oo,*)' n=',n n=msize endif prob(n)=prob(n)+1 n=1 if(nc.le.qcel(1))then nb=Ptdel(Ndelcel(nc,1)) endif else n=n+1 endif enddo meanprob=meanprob+qcel(1) meanvga=meanvga+qgvga(1) meanvgal=meanvgal+esgvga(1) c write(oo,*) c + ' mean quantity of energy transfers from inc. part.= ',meanvga c write(oo,*) c + ' mean energy loss, Kev = ', c + meanvgal*1000.0 c write(oo,*) c + ' mean number of conduction electrons = ',meanprob 10 continue if(nevt.eq.qevt)then meanprob=meanprob/qevt meanvga=meanvga/qevt meanvgal=meanvgal/qevt s=0.0 do n=1,msize s = s + prob(n) enddo do n=1,msize prob(n) = prob(n) / s enddo c write(oo,*) c + ' mean quantity of energy transfers from inc. part.= ',meanvga c write(oo,*) c + ' mean energy loss, Kev = ', c + meanvgal*1000.0 c write(oo,*) c + ' mean number of conduction electrons = ',meanprob c write(oo,*) c + ' number of conduction electrons in cluster vs probability:' c do n=1,200 c write(oo,*)n,prob(n) c enddo endif end +DECK,PEHEED,IF=PEHEED. program PEHEED c Checking the package EHEED implicit none c include 'molecules.inc' +SEQ,molecule. c include 'molecdef.inc' +SEQ,molecdef. integer qmol ! Quantity of different molecules ! in the gas mixture. integer nmol(pqMol) ! Their numbers from molecules.inc. ! Use only the named constants ! for compartibility with future versions. real wmol(pqMol) ! Their weights ! (relative quantities of molecules). real pres ! Pressure in Torr. real temp ! Temperature in K. real tkener ! Kinetic energy of incident particle(MeV). real mas ! Mass of incident particle(MeV) integer soo ! Flag allowed for writting. integer oo ! Output stream number. integer debug ! Flag allowed for writting of ! more amount of information. integer qevt ! quantity of events to generate integer nevt ! current number of events ! (see comment in EHEED before GoEventn) c Output parameters: real density ! Density, calculated as for ideal gas, gr/cm3 integer ierror ! Sign of error( 0 -- no error ). integer n write(6,*)' PEHEED started' c qmol=1 c nmol(1)=numm_Ar c wmol(1)=1.0 c nmol(1)=numm_CF4 c wmol(1)=1.0 qmol=3 nmol(1)=numm_Ar wmol(1)=0.30 nmol(2)=numm_CO2 wmol(2)=0.50 nmol(3)=numm_CF4 wmol(3)=0.20 pres=0.0 temp=0.0 tkener=0.0 mas=0.0 soo=0 oo=10 open(oo,FILE='heed.out') debug=2 call IMHEED + (qmol, nmol, wmol, pres, temp, soo, oo, debug, + density, ierror) if(ierror.ne.0)then write(oo,*)' Error in IMHEED' stop endif call IniFVolume(0, 1, 1, 1, 0.0, 1.0 ) ! Volume call IPHEED + (tkener, mas, debug, + ierror) if(ierror.ne.0)then write(oo,*)' Error in IMHEED' stop endif call IniRTrack(0.0, 0.0, 0.0, 0.0) ! Track write(oo,*)' density=',density qevt=10 c End of initialization c Now the GoEvent subroutine can be called c from any place of user's program. c For example we just run several events and print ionization positions. do nevt=1,qevt ! Loop over events call GoEventn(nevt,qevt) ! Simulation of one event call PriCel ! Print to 'oo' device enddo end +DECK,EHEED,IF=EHEED. c Initialization of HEED for simulation event by event c with calls of HEED from another program. c Volumes and tracks are to be initialized by usual HEED routines: c IniFVolume, IniNVolume, and IniRTrack subroutine IMHEED + (qmol, nmol, pwmol, ppres, ptemp, psoo, poo, debug, + density, ierror) c c The subroutine for initialization of the medium. c Required are only information about matter. c Cross sections are to be initialized later, when the particle c velosity is fixed. c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'molecules.inc' +SEQ,molecule. c include 'molecdef.inc' +SEQ,molecdef. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'crosec.inc' +SEQ,crosec. c include 'cconst.inc' +SEQ,cconst. c include 'volume.inc' +SEQ,volume. c include 'part.inc' +SEQ,part. c include 'hist.inc' +SEQ,hist. c include 'random.inc' +SEQ,random. +SEQ,PRINTPLOT. integer qmol ! Quantity of different molecules ! in the gas mixture. integer nmol(pqMol) ! Their numbers from molecules.inc. ! Use only the named constants ! for compartibility with the future versions real pwmol(pqMol) ! Their weights ! (relative quantities of molecules). real ppres ! Pressure in Torr. real ptemp ! Temperature in K. integer psoo ! Flag allowing to write. integer poo ! Output stream number. integer debug ! Flag allowing to write ! more amount of information. c Output parameters: real density ! Density, calculated as for ideal gas, gr/cm3 integer ierror ! Sign of error( 0 -- no error ). real wmol(pqMol) C integer nc integer n,i real s real pres ! Pressure in Torr. real temp ! Temperature in K. c real step_integ_ar integer tresh parameter (tresh=20) c real e1,e2 integer nmat integer nat *** Additional debug output (RV 13/8/98). IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ IMHEED DEBUG : '', - ''Pressure: '',F10.3,'' Torr''/26X, - ''Temperature: '',F10.3,'' K''/26X, - ''Gas components: '',I5/26X, - ''Identifier Fraction'')') ppres,ptemp,qmol DO I=1,qmol WRITE(LUNOUT,'(26X,I10,F12.4)') nmol(i),pwmol(i) ENDDO ENDIF *** End of modification. c restore after previous run do nat=1,pQAt Zat(nat)=0 enddo nmat=1 QAtMat(nmat)=0 c go ahead s=0.0 do n=1,qmol s=s+pwmol(n) enddo do n=1,qmol wmol(n)=pwmol(n)/s enddo call Iniranfl soo=psoo oo=poo sret_err=1 sHist=0 ! To ban operating with historgams HistFile='heed.hist' ! To make sure. Histograms must not be filled ! and written here. maxhisampl=40.0e-3 maxhisampl2=20.0e-3 maxhisample=200 pqhisampl=100 shfillrang=0 c Random number genarator sseed=0 seed(1)=1121517854 ! this is example seed(2)=612958528 qevt=1 ! Quantity of events to generate ssimioni=1 ! Simulate ionization loss ninfo=0 ! Number of first events with output listing call Inishl ! Cascade from excited atom call IniEner(150,3e-6,0.2) ! Energy mesh if(debug.ge.2)call PriEner call AtomsByDefault ! Library of atoms *** Added argument to PriAtoms (RV 13/4/99) if(debug.ge.2)call PriAtoms(0) *** End of modification. if(ppres.eq.0)then pres=Atm_Pressure else pres=ppres endif if(ptemp.eq.0)then temp=Atm_Temper else temp=ptemp endif call molecdef if(debug.ge.2)call Primolec call Inigas(nmat, qmol, nmol, wmol, pres, temp) *** Added argument to PriMatter (RV 13/4/99). if(debug.ge.2)call PriMatter(0) *** End of modification. if(s_err.eq.1)then ierror=1 return endif density=DensMat(nmat) end subroutine IPHEED + (ptkener, pmas, debug, + ierror) c Initialization of particle, cross sections, c and tracing of delta-electrons. c The volume(s) have to be initialized before! implicit none c include 'GoEvent.inc' +SEQ,GoEvent. real ptkener ! Kinetic energy of incident particle. real pmas ! Mass of incident particle. ! In the case of zero in two above var. the following ! two ones will be sensible (see text). real tkener ! Kinetic energy of incident particle. real mas ! Mass of incident particle. integer debug ! Flag allowing to write ! more amount of information. c Output parameters: integer ierror ! Sign of error( 0 -- no error ). if(pmas.eq.0)then mas=938 else mas=pmas endif if(ptkener.eq.0)then tkener=mas*(4-1) ! 'mip' else tkener=ptkener endif call IniPart(tkener,mas) ! Particle if(debug.ge.2)call Pripart if(s_err.eq.1)then ierror=1 return endif call IniCrosec ! Cross sections if(debug.ge.2)call PriCrosec(1,1) call InisBdel ! Data for tracing of delta-electrons end c After that the track must still be initialized by IniRTrack. c The UBegEvent end UEndEvent subroutine can be empty in this case. subroutine UBegEvent end subroutine UEndEvent end c The GoEvent must know the number of the current event c and the total ordered event number. If there was an overflow c of any controlled array - arrays with delta-electrons, c conduction electrons, real photons, virtual photons, c the GoEvent prints the wornings and auxiliary information c to the 'oo' after the last event generated. c So as avoid of including of GoEvent.inc , where the event number c nevt and quantity of events qevt are stored, user can call GoEventn , c that takes nevt and qevt as arguments and simulates ONE event. subroutine GoEventn(pnevt, pqevt) implicit none c include 'GoEvent.inc' +SEQ,GoEvent. integer pnevt, pqevt nevt = pnevt qevt = pqevt call GoEvent end +DECK,MainHEED,IF=E. program HEED c c The main program for HEED package c implicit none integer NPW PARAMETER (NPW = 2000000) real H COMMON /PAWC/ H(NPW) c include 'GoEvent.inc' +SEQ,GoEvent. c include 'volume.inc' +SEQ,volume. c include 'hist.inc' +SEQ,hist. CALL HLIMIT(NPW) call Iniranfl ! Initialization of the counter of ! random number generator calls call IniHeed ! User's subroutine, ! Initialization of the detector if(sHist.eq.1)then call IniHist ! Initialization of inbilt histograms endif do nevt=1,qevt ! Loop over events call GoEvent ! Simulation of one event enddo if(sHist.eq.1)then call WHist ! Writting of histograms endif call Priranfl ! Print the number of calls of ! random number generator end +DECK,GoEvent. subroutine GoEvent c c Event processor. It is called from MainHEED. c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'abs.inc' +SEQ,abs. c include 'rga.inc' +SEQ,rga. c include 'volume.inc' +SEQ,volume. c include 'hist.inc' +SEQ,hist. c include 'random.inc' +SEQ,random. integer iempty c if(nevt.le.ninfo)then if(soo.eq.1)then write(oo,*) write(oo,*)' Event number ',nevt endif if(nevt.eq.1.and.sseed.eq.1)then call randset ! Set the start point of endif ! the random number generator. if(soo.eq.1)then call randget call randpri(oo) ! Print the current point of endif ! the random number generator. c endif call IniNTrack ! Generate the next track. if(nevt.le.ninfo)then call PriMTrack(0) ! Print debug information call PriMTrack(1) call PriMTrack(2) call PriMTrack(3) call PriMTrack(4) endif call IniLsgvga ! Initialize gvga.inc call Iniabs ! Initialize abs.inc call Inirga ! Initialize rga.inc call Inidel ! Initialize del.inc call Inicel ! Initialize cel.inc call UBegEvent ! User's subroutine if(ssimioni.eq.1)call rafflev ! Generate the primary energy transfers ! from incoming particle if(soo.eq.1)then if(nevt.le.ninfo)then write(oo,*) call PriLsgvga ! Print debug information endif endif do iempty=1,10000 if(soo.eq.1)then if(nevt.le.ninfo)then write(oo,*) write(oo,*)' before absorption of virtual photons:' call Priabs ! Print debug information endif endif call AbsGam ! Absorb the virtual photons if(soo.eq.1)then if(nevt.le.ninfo)then ! Print debug information write(oo,*) write(oo,*)' after absorption of virtual photons:' c call Priabs call Prirga call Pridel endif endif call GoGam ! Absorb the photons if(soo.eq.1)then if(nevt.le.ninfo)then ! Print debug information write(oo,*) write(oo,*)' after absorption of photons:' call Priabs c call Prirga call PrirgaF endif endif if(ctagam.gt.qtagam.and.crga.gt.qrga)then ! There are neither real no ! virtual photons to trace. goto 50 ! Exit the loop. endif enddo 50 continue call treatdel ! Trace the delta-electrons ! and generate the conduction electrons. call treatcel ! Treat the cel.inc if(soo.eq.1)then if(nevt.le.ninfo)then ! since there are calculation of ranges ! which in wroute to del inside treatdel write(oo,*) call Pridel c call Pricel endif endif if(sHist.eq.1)then call Fhist ! Fill predetermined histograms endif call UEndEvent ! User's routine if(soo.eq.1)then if(nevt.eq.qevt)then write(oo,*) write(oo,*)nevt,' events is done' ! Printing the wornings about overful call WorPrirga call WorPriabs call WorPridel call WorPricel endif endif end +DECK,IniHeed1,IF=E1. subroutine IniHeed c c The program for estimation of the c ultimate coordinate resolution of the proportional chamber c c Also the table of clusters number distribution may be generated. c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'hist.inc' +SEQ,hist. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'molecules.inc' +SEQ,molecule. c include 'cconst.inc' +SEQ,cconst. c include 'volume.inc' +SEQ,volume. c include 'part.inc' +SEQ,part. c include 'h1.inc' +SEQ,h1. c include 'random.inc' +SEQ,random. real tkener,mas,momentum integer qmol,nmol(3) real wmol(3) integer i integer j real ystart, an, wid ! the last is widht of the chamber ! the angle ! it is calculated from two next values so as ! the middle was on zero real amc integer na write(6,*)' Initialization started' soo=1 ! To allow (1) or to ban (0) printing to stream oo. oo=10 ! set logical number of output stream. TaskName='heed01_2.' OutputFile=TaskName//'out' open(oo,FILE=OutputFile) ! open output disk file. sret_err = 0 ! Stop if error is detected c Auxiliary variables for histograms (from hist.inc) sHist=1 ! To allow (1) or to ban (0) dealing with histograms. HistFile=TaskName//'hist' ! File name, where they are written to. maxhisampl=40.0e-3 ! Maximum aplitude. maxhisampl2=20.0e-3 ! Reduced maximum aplitude. maxhisample=150 ! Maximum aplitude in unit of number of elect. pqhisampl=100 ! Number of bins. shfillrang=1 ! To allow (1) or to ban (0) filling histogram nh2_rd. c Random number genarator sseed=0 ! To make the generator start from seed point (1) ! or from default point (0). seed(1)=1121517854 ! this is example for sseed=1 seed(2)=612958528 qevt=1000 ! Quantity of events to generate ssimioni=1 ! To allow ionization loss (1) or to ban it (0) ninfo=0 ! Number of first events with output listing call Inishl ! Cascade from excited atom call IniEner(150,3e-6,0.2) ! Energy mesh c call PriEner call AtomsByDefault ! Library of atoms c call PriAtoms(0) Cur_Pressure=Atm_Pressure Cur_Temper=Atm_Temper c call Xenon_dens_Ar (1) ! Materials from LibAtMat c call Textolite (2) c call CF4 (1) c call CF4_without_cor (1) c call lCO2 (1) c call CO2_without_cor (1) c call CO250CF420Ar30(1) c call Ar80C2H620(1) c call lArgon (1) c call Ar93CH407 (1) c call Oxigen (1) c call Kripton (1) call molecdef c call Primolec qmol=3 nmol(1)=numm_Ar wmol(1)=0.30 nmol(2)=numm_CO2 wmol(2)=0.50 nmol(3)=numm_CF4 wmol(3)=0.20 call Inigas( 1, qmol, nmol, wmol, Cur_Pressure, Cur_Temper) c call PriMatter(0) wid=1.0 ! width of layer. call IniFVolume(0, 1, 1, 1, 0.0, wid ) call PriVolume c mas=105.0 ! muon mas=938 ! proton c momentum=100000.0 c tkener=sqrt(mas*mas+momentum*momentum)-mas tkener = mas * (4-1) ! 'mip' call IniPart(tkener,mas) ! Particle call PriPart c The special iinitialization for track c an=30.0 an=0.0 an=an * 2.0 * PI / 360.0 ! go from grad to radians ystart = wid*tan(an)/2 call IniRTrack(-ystart, -ystart, an, real(PI/2.0)) ! Track c call PriTrack call IniCrosec ! Cross sections call PriCrosec(1,1) call InisBdel ! Data for tracing of delta-electrons c Additional histograms hhis=mhis/qhis qamp=5 c ampc(1)=10.0 c ampc(2)=30.0 c ampc(3)=100.0 c ampc(4)=300.0 c ampc(5)=10000000.0 c amc=19.82 amc=22.29 c amc=49.32 c amc=49.32 * 2 ampc(1)=amc ampc(2)=2*amc ampc(3)=3*amc ampc(4)=5*amc ampc(5)=10000000.0 write(oo,*)' ampc=',ampc qe=0 do na=1,qamp do j=1,qhis do i=1,2 npp(j,i,na)=0 pp1(j,i,na)=0.0 pp2(j,i,na)=0.0 enddo enddo enddo do na=1,qamp do i=1,2 ! distribution of the centers of gravity ! of ionization along x (1) and y (2) call hbook1(30000+10*na+(i-1)+1,' $', + 2*qhis,-mhis,mhis,0.0) enddo do i=3,6 call hbook1(30000+10*na+(i-1)+1,' $', + qhis,0.0,mhis,0.0) enddo enddo meanprob=0.0 meanvga=0.0 meanvgal=0.0 do i=1,1000 prob(i)=0.0 enddo write(6,*)' Initialization finished' end +DECK,UEvent1,IF=E1. subroutine UBegEvent implicit none c include 'GoEvent.inc' +SEQ,GoEvent. end subroutine UEndEvent implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'volume.inc' +SEQ,volume. c include 'del.inc' +SEQ,del. c include 'cel.inc' +SEQ,cel. c include 'h1.inc' +SEQ,h1. c include 'lsgvga.inc' +SEQ,lsgvga. integer i,j,k,n,nb integer nc,na,nq real s,sz real*8 p(2) ! coordinates of center of gravity ! along x and y for current event. real x do i=1,2 p(i)=0.0 enddo nq=0 sz=0.0 do nc=1,qcel(1) nq=nq+1 sz=sz+1 do i=1,2 p(i)=p(i)+pntcel(i,nc,1)*10000.0 enddo enddo if(nq.gt.0)then qe=qe+1 do i=1,2 p(i)=p(i)/nq enddo do na=1,qamp if(sz.le.ampc(na))then call hfill(30000+10*na+1,real(p(1)),0.0,1.0) call hfill(30000+10*na+2,real(p(2)),0.0,1.0) endif enddo do na=1,qamp if(sz.le.ampc(na))then ! amplitude cut do j=1,qhis x=hhis*j do i=1,2 if(abs(p(i)).le.x)then ! coordinate cut npp(j,i,na)=npp(j,i,na)+1 pp1(j,i,na)=pp1(j,i,na)+p(i) pp2(j,i,na)=pp2(j,i,na)+p(i)*p(i) endif enddo enddo endif enddo endif n=0 if(qcel(1).eq.0)then goto 10 endif nb=Ptdel(Ndelcel(1,1)) k=0 do nc=1,qcel(1)+1 k=0 if(nc.eq.qcel(1)+1)then k=1 else if(nc.gt.1.and.Ptdel(Ndelcel(nc,1)).ne.nb)then k=1 endif endif if(k.eq.1)then if(n.le.0)then write(oo,*)' n=',n n=1 endif if(n.ge.1001)then write(oo,*)' n=',n n=1000 endif prob(n)=prob(n)+1 n=1 if(nc.le.qcel(1))then nb=Ptdel(Ndelcel(nc,1)) endif else n=n+1 endif enddo meanprob=meanprob+qcel(1) meanvga=meanvga+qgvga(1) meanvgal=meanvgal+esgvga(1) 10 continue if(nevt.eq.qevt)then meanprob=meanprob/qevt meanvga=meanvga/qevt meanvgal=meanvgal/qevt s=0.0 do n=1,1000 s = s + prob(n) enddo do n=1,1000 prob(n) = prob(n) / s enddo write(oo,*) + ' mean quantity of energy transfers from inc. part.= ',meanvga write(oo,*) + ' mean energy loss, Kev = ', + meanvgal*1000.0 write(oo,*) + ' mean number of conduction electrons = ',meanprob write(oo,*) + ' number of conduction electrons in cluster vs probability:' do n=1,200 write(oo,*)n,prob(n) enddo c do na=1,qamp c do j=1,qhis c do i=1,2 c write(oo,*)' pp:',j,i,na,npp(j,i,na),pp1(j,i,na),pp2(j,i,na) c enddo c enddo c enddo do na=1,qamp do j=1,qhis do i=1,2 if(npp(j,i,na).gt.0)then pp1(j,i,na)=pp1(j,i,na)/npp(j,i,na) pp2(j,i,na)=pp2(j,i,na)/npp(j,i,na) pp1(j,i,na)=sqrt(pp2(j,i,na)-pp1(j,i,na)*pp1(j,i,na)) else pp1(j,i,na)=0.0 endif enddo enddo enddo do na=1,qamp do j=1,qhis do i=1,2 rpp1(j,i,na)=pp1(j,i,na) enddo enddo enddo do na=1,qamp do i=1,2 call hpak(30002+10*na+i,rpp1(1,i,na)) enddo enddo do na=1,qamp do j=1,qhis do i=1,2 rpp2(j,i,na)=qe-npp(j,i,na) enddo enddo enddo do na=1,qamp do i=1,2 call hpak(30004+10*na+i,rpp2(1,i,na)) enddo enddo write(6,*)' The program finished' endif end +DECK,IniEner. SUBROUTINE IniEner(q,emin,emax) C c define the energy mesh for ionization loss c and photoabsorbtion c implicit none c include 'ener.inc' +SEQ,ener. C integer q real emin,emax qener=q call logscale(q,emin,emax,ener,enerc) END subroutine PriEner c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. integer i if(soo.eq.0)return write(oo,*) write(oo,*)' PriEner: Energy mesh' write(oo,*)' qener=',qener write(oo,*)' ener, left edges enerc, the centers (MeV)' do i=1,qener write(oo,*)ener(i),enerc(i) enddo end +DECK,logscale. subroutine logscale(q,xmin,xmax,x,xc) c c Make a logariphmic mesh. c implicit none integer q real xmin,xmax real x(*),xc(*) real rk,xr integer i rk=(xmax/xmin)**(1.0/q) xr=xmin x(1)=xr do i=2,q+1 x(i)=xr*rk xc(i-1)=(x(i-1)+x(i))*0.5 xr=x(i) enddo end subroutine logscale0(q,xmin,xmax,x,xc) c c Make a logariphmic mesh with linear begin. c First, the logariohmic scale is calculated. c Second, the program tries to prolong it to zero c with the same number of points. c So several points of begin of logariphmic scale will be recalculeted. c implicit none integer q real xmin,xmax real x(*),xc(*) integer i,j real r,h call logscale(q,xmin,xmax,x,xc) if(q.ge.2)then do i=2,q r = x(i) / ( x(i+1) - x(i) ) if( r .le. i-1 )then h = x(i) / ( i - 1 ) x(1) = 0.0 do j = 2,i x(j) = h * ( j - 1 ) xc(j-1) = (x(j) + x(j-1))*0.5 enddo go to 10 endif enddo write(6,*)' error in logscale0' stop else write(6,*)' error in logscale0' stop endif 10 end +DECK,Inishl. subroutine Inishl c Initialize common comshl c It will be very difficult c Modifying is the best way to loss your temper c Description of channels of getting exiting from atom c after photoabsorbtion and electron emission implicit none c include 'shl.inc' +SEQ,shl. integer n c qatm=0 !nahui! qatm=2 c Argon charge(1)=18 qshl(1)=5 eshell(1,1)=.3178E-2 eshell(2,1)=.3135E-3 eshell(3,1)=.2479E-3 eshell(4,1)=.2892E-4 eshell(5,1)=.1449E-4 qschl(1,1)=2 qschl(2,1)=2 qschl(3,1)=2 qschl(4,1)=0 qschl(5,1)=0 secprobch(1,1,1)=0.878 secprobch(2,1,1)=1.0 secprobch(1,2,1)=0.999 secprobch(2,2,1)=1.0 secprobch(1,3,1)=0.999 secprobch(2,3,1)=1.0 qsel(1,1,1)=1 qsga(1,1,1)=0 qsel(2,1,1)=0 qsga(2,1,1)=1 qsel(1,2,1)=1 qsga(1,2,1)=0 qsel(2,2,1)=0 qsga(2,2,1)=1 qsel(1,3,1)=1 qsga(1,3,1)=0 qsel(2,3,1)=0 qsga(2,3,1)=1 secenel(1,1,1,1)=eshell(1,1)-2.0*eshell(5,1) secenga(1,2,1,1)=eshell(1,1)-eshell(5,1) secenel(1,1,2,1)=eshell(2,1)-2.0*eshell(5,1) secenga(1,2,2,1)=eshell(2,1)-eshell(5,1) secenel(1,1,3,1)=eshell(3,1)-2.0*eshell(5,1) secenga(1,2,3,1)=eshell(3,1)-eshell(5,1) c Xenon n=2 charge(n)=54 qshl(n)=6 eshell(1,n)=0.041328 c eshell(2,n)=0.006199 eshell(2,n)=0.0041 eshell(3,n)=0.000827 eshell(4,n)=0.00031 eshell(5,n)=8.265694e-05 eshell(6,n)=1.239854e-05 qschl(1,n)=2 qschl(2,n)=2 qschl(3,n)=0 qschl(4,n)=0 qschl(5,n)=0 qschl(6,n)=0 secprobch(1,1,n)=0.106 secprobch(2,1,n)=1.0 secprobch(1,2,n)=0.897 secprobch(2,2,n)=1.0 qsel(1,1,n)=1 qsga(1,1,n)=0 qsel(2,1,n)=0 qsga(2,1,n)=1 qsel(1,2,n)=1 qsga(1,2,n)=0 qsel(2,2,n)=0 qsga(2,2,n)=1 secenel(1,1,1,n)=eshell(1,n)-2.0*eshell(6,n) secenga(1,2,1,n)=eshell(1,n)-eshell(6,n) secenel(1,1,2,n)=eshell(2,n)-2.0*eshell(6,n) secenga(1,2,2,n)=eshell(2,n)-eshell(6,n) end subroutine Prishl c print the featcher of the mater implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'shl.inc' +SEQ,shl. integer iatm, ishl, ischl, isel, isga if(soo.eq.0)return write(oo,*) write(oo,*)' Prishl: print materials ' write(oo,*)' qatm=',qatm do iatm=1,qatm write(oo,*)' ****atom=',iatm write(oo,*)' charge()=',charge(iatm), + ' qshl(iatm)= ',qshl(iatm) do ishl=1,qshl(iatm) write(oo,*)' ----number of shell=',ishl write(oo,*)' eshell(ishl,iatm)=',eshell(ishl,iatm), + ' qschl(ishl,iatm)=',qschl(ishl,iatm) do ischl=1,qschl(ishl,iatm) write(oo,*)' ------number of channel=',ischl write(oo,*)' qsel(ischl,ishl,iatm)=',qsel(ischl,ishl,iatm), + ' qsga(ischl,ishl,iatm)=',qsga(ischl,ishl,iatm) do isel=1,qsel(ischl,ishl,iatm) write(oo,*)' -------- electron number ',isel write(oo,*)' secenel(isel,ischl,ishl,iatm)=', + secenel(isel,ischl,ishl,iatm) enddo do isga=1,qsga(ischl,ishl,iatm) write(oo,*)' -------- photon number ',isga write(oo,*)' secenga(isga,ischl,ishl,iatm)=', + secenga(isga,ischl,ishl,iatm) enddo enddo enddo enddo end +DECK,LibAtMat. subroutine AtomsByDefault c c Initializations of several atoms c implicit none c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'LibAtMat.inc' +SEQ,LibAtMat. c integer na KeyTeor=0 QseqAt=0 ! It is necessary before run IniAtom ! ( if memory is not cleaned automatically). c do na=1,pQAt c num_at_mol(na)=0 c enddo call IniAtom(num_H , 1, 1.0 ) ! H call IniAtom(num_H3 , 1, 1.0 ) ! H in CH4 call IniAtom(num_H4 , 1, 1.0 ) ! H in NH3 call IniAtom(num_He , 2, 4.0 ) ! He call IniAtom(num_Li , 3, 6.94) ! Li call IniAtom(num_C , 6, 12.01) ! C c num_at_mol(num_C1)=1 call IniAtom(num_C1 , 6, 12.01) ! C in CO2 c num_at_mol(num_C2)=2 call IniAtom(num_C2 , 6, 12.01) ! C in CF4 call IniAtom(num_C3 , 6, 12.01) ! C in CH4 call IniAtom(num_N , 7, 14.01) ! N call IniAtom(num_O , 8, 16.0 ) ! O call IniAtom(num_F , 9, 19.0 ) ! F call IniAtom(num_Ne , 10, 20.2 ) ! Ne call IniAtom(num_Al , 13, 26.98) ! Al call IniAtom(num_Si , 14, 28.09) ! Si call IniAtom(num_Ar , 18, 40.0 ) ! Ar call IniAtom(num_Kr , 36, 84.0 ) ! Kr call IniAtom(num_Xe , 54, 131.3 ) ! Xe *** Additions (RV, 20/9/99). call IniAtom(num_S , 16, 32.066) ! S end +DECK,HELIUM,IF=NEVER. subroutine Helium(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=1 ! Helium A(1)=num_He AW(1)=1 qd=1 Ad(1)=4.0 AWd(1)=1 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19) end +DECK,AIR,IF=NEVER. subroutine Air(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=2 ! Air A(1)=num_N ! N AW(1)=0.7 A(2)=num_O ! O AW(1)=0.3 qd=2 Ad(1)=28.02 AWd(1)=0.7 Ad(2)=32 AWd(2)=0.3 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19) end +DECK,LDME,IF=NEVER. SUBROUTINE LDME(NM) *----------------------------------------------------------------------- * LDME - Initialises DME data * (Last changed on 18/ 2/97.) *----------------------------------------------------------------------- implicit none +SEQ,LibAtMat. INTEGER A(10),Q,NM REAL AW(10),WORK,FANO,DENS *** Composition. Q=3 A(1)=num_H AW(1)=6 A(2)=num_O AW(2)=1 A(3)=num_C3 AW(3)=2 *** Density. DENS=0.00191 *** Work for a pair [MeV]. WORK=30E-6 *** Fano factor. FANO=0.19 *** Initialise. CALL IniMatter(NM,A,AW,Q,DENS,WORK,FANO) END +DECK,N2O69,IF=NEVER. subroutine N2_0_69Torr(nm) c c N2 with presure 0.69 Torr c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=1 ! N A(1)=num_N ! N2 AW(1)=1 qd=1 Ad(1)=2*14.0 AWd(1)=1.0 dens = gasdens(Ad,AWd,qd) dens = dens * (0.69/760.0) c dens = dens * (2.8/760.0) call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19) end +DECK,OXIGEN,IF=NEVER. subroutine Oxigen(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=1 ! O A(1)=num_O ! O2 AW(1)=1 qd=1 Ad(1)=2*16.0 AWd(1)=1.0 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19) end +DECK,LCO2,IF=NEVER. subroutine lCO2(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=2 ! CO2 A(1)=num_C1 ! C AW(1)=0.30 A(2)=num_O ! O2 AW(2)=0.60 qd=1 Ad(1) = 12.01 + 2*16.0 AWd(1)= 1 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,33.0e-6,0.19) end +DECK,CO2WITHOUT,IF=NEVER. subroutine CO2_without_cor(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=2 ! CO2 A(1)=num_C ! C AW(1)=0.30 A(2)=num_O ! O2 AW(2)=0.60 qd=1 Ad(1) = 12.01 + 2*16.0 AWd(1)= 1 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,33.0e-6,0.19) end +DECK,CF4,IF=NEVER. subroutine CF4(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=2 ! CF4 A(1)=num_C2 ! C AW(1)=0.30 A(2)=num_F ! F AW(2)=1.20 qd=1 Ad(1) = 12.01 + 4*19.0 AWd(1)= 1 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,34.3e-6,0.19) end +DECK,CF4WITHOUT,IF=NEVER. subroutine CF4_without_cor(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=2 ! CF4 A(1)=num_C ! C AW(1)=0.30 A(2)=num_F ! F AW(2)=1.20 qd=1 Ad(1) = 12.01 + 4*19.0 AWd(1)= 1 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,34.3e-6,0.19) end +DECK,CO250CF420,IF=NEVER. subroutine CO250CF420Ar30(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens real w q=4 ! CO2 50% CF4 20% Ar 30% A(1)=num_C1 ! C AW(1)=0.50 A(2)=num_O ! O AW(2)=1.00 A(1)=num_C2 ! C AW(1)=0.20 A(3)=num_F ! F AW(3)=0.8 A(4)=num_Ar ! Ar AW(4)=0.30 qd=3 Ad(1)=12.0+2*16.0 ! CO2 AWd(1)=0.50 Ad(2)=12.0+4*19.0 ! CF4 AWd(2)=0.20 Ad(3)=40.0 ! Ar AWd(3)=0.30 dens=gasdens(Ad,AWd,qd) w=AWd(1)*33.0e-6 + AWd(2)*34.3e-6 + AWd(3)*26.4e-6 call IniMatter(nm,A,AW,q,dens,w,0.19) end +DECK,LARGON,IF=NEVER. subroutine lArgon(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=1 ! Ar A(1)=num_Ar ! Ar AW(1)=1.0 qd=1 Ad(1)=40.0 AWd(1)=1.0 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,26.4e-6,0.19) end +DECK,AR95CH405,IF=NEVER. subroutine Ar95CH405(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=3 ! Ar A(1)=num_Ar ! Ar AW(1)=0.95 A(2)=num_C ! C AW(2)=0.05 A(3)=num_H ! H AW(3)=0.20 qd=2 Ad(1)=40.0 AWd(1)=0.95 Ad(2)=12+4*1 AWd(2)=0.05 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,26.4e-6,0.19) end +DECK,AR93CH407,IF=NEVER. subroutine Ar93CH407(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=3 ! Ar A(1)=num_Ar ! Ar AW(1)=0.93 A(2)=num_C ! C AW(2)=0.07 A(3)=num_H ! H AW(3)=0.28 qd=2 Ad(1)=40.0 AWd(1)=0.93 Ad(2)=12+4*1 AWd(2)=0.07 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,26.4e-6,0.19) end +DECK,AR90CH410,IF=NEVER. subroutine Ar90CH410(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=3 ! Ar A(1)=num_Ar ! Ar AW(1)=0.90 A(2)=num_C ! C AW(2)=0.10 A(3)=num_H ! H AW(3)=0.40 qd=2 Ad(1)=40.0 AWd(1)=0.90 Ad(2)=12+4*1 AWd(2)=0.10 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,26.4e-6,0.19) end +DECK,AR80C2H620,IF=NEVER. subroutine Ar80C2H620(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=3 ! Ar A(1)=num_Ar ! Ar AW(1)=0.80 A(2)=num_C ! C AW(2)=0.20*2 A(3)=num_H ! H AW(3)=0.20*6 qd=2 Ad(1)=40.0 AWd(1)=0.80 Ad(2)=2*12.0+6*1.0 AWd(2)=0.20 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,26.4e-6,0.19) end +DECK,KRIPTON,IF=NEVER. subroutine Kripton(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=1 ! Kr A(1)=num_Kr ! Kr AW(1)=1.0 qd=1 Ad(1)=84.0 AWd(1)=1.0 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,24.4e-6,0.19) end +DECK,XENON,IF=NEVER. subroutine Xenon(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=1 ! Xe A(1)=num_Xe ! Xe AW(1)=1.0 qd=1 Ad(1)=131.3 AWd(1)=1.0 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,21.9e-6,0.19) end +DECK,XE90CH410,IF=NEVER. subroutine Xe90CH410(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=3 ! 90% Xe + 10% CH4 A(1)=num_Xe ! Xe AW(1)=0.90 A(2)=num_C ! C AW(2)=0.10 A(3)=num_H ! H4 AW(3)=0.40 qd=2 Ad(1)=131.3 AWd(1)=0.90 Ad(2) = 12.01 + 4*1.0 AWd(2)= 0.10 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,21.9e-6,0.19) end +DECK,XE95CH405,IF=NEVER. subroutine Xe95CH405(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=3 ! 95% Xe + 05% CH4 A(1)=num_Xe ! Xe AW(1)=0.95 A(2)=num_C ! C AW(2)=0.05 A(3)=num_H ! H4 AW(3)=0.20 qd=2 Ad(1)=131.3 AWd(1)=0.95 Ad(2) = 12.01 + 4*1.0 AWd(2)= 0.05 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,21.9e-6,0.19) end +DECK,XE70,CH430,IF=NEVER. subroutine Xe70CH430(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=3 ! 70% Xe + 30% CH4 A(1)=num_Xe ! Xe AW(1)=0.70 A(2)=num_C ! C AW(2)=0.30 A(3)=num_H ! H4 AW(3)=1.2 qd=2 Ad(1)=131.3 AWd(1)=0.70 Ad(2) = 12.01 + 4*1.0 AWd(2)= 0.30 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,21.9e-6,0.19) end +DECK,XE875CH4,IF=NEVER. subroutine Xe875CH4075C3H805(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=3 ! 87.5% Xe + 7.5% CH4 + 5% C3H8 A(1)=num_Xe ! Xe AW(1)=0.875 A(2)=num_C ! C AW(2)=0.05*3 + 0.075 A(3)=num_H ! H AW(3)=0.05*8 + 0.075*4 qd=3 Ad(1)=131.3 AWd(1)=0.875 Ad(2) = 12.01 + 4*1.0 AWd(2)= 0.075 Ad(3) = 3*12.01 + 8*1.0 AWd(3)= 0.05 dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,21.9e-6,0.19) end +DECK,XE70CO2230,IF=NEVER. subroutine Xe70CO230(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens real w q=3 ! 70% Xe + 30% CO2 A(1)=num_Xe ! Xe AW(1)=0.70 A(2)=num_C1 ! C AW(2)=0.30 A(3)=num_O ! O2 AW(3)=0.60 qd=2 Ad(1)=131.3 AWd(1)=0.70 Ad(2) = 12.01 + 2*16.0 AWd(2)= 0.30 dens=gasdens(Ad,AWd,qd) w=AWd(1)*21.9e-6 + 0.30*33.0e-6 call IniMatter(nm,A,AW,q,dens,w,0.19) end +DECK,XENONAR,IF=NEVER. subroutine Xenon_dens_Ar(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=1 ! Xe with density of Ar A(1)=num_Xe ! Xe AW(1)=1.0 qd=1 Ad(1)=40.0 AWd(1)=1.0 dens=gasdens(Ad,AWd,qd) c qd=1 c Ad(1)=131.3 c AWd(1)=1.0 c dens=gasdens(Ad,AWd,qd) call IniMatter(nm,A,AW,q,dens,21.9e-6,0.19) end +DECK,LITHIUM,IF=NEVER. subroutine Lithium(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=1 ! Lithium A(1)=num_Li AW(1)=1 dens=0.53 call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19) *** Added argument to PriMatter (RV 13/4/99). c call PriMatter(0) *** End of modification. end +DECK,POLYETHYL,IF=NEVER. subroutine Polyethylene(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=2 ! Polyethylene CH2 A(1)=num_H ! H2 AW(1)=2 A(2)=num_C ! C AW(2)=1 dens=0.925 call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19) end +DECK,MYLAR,IF=NEVER. subroutine Mylar(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=3 ! mylar C5H4O2 A(1)=num_C ! C5 AW(1)=5 A(2)=num_H ! H4 AW(2)=4 A(3)=num_O ! O2 AW(3)=2 dens=1.38 call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19) end +DECK,ALUMINIUM,IF=NEVER. subroutine Aluminium(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real Ad(10),AWd(10) integer qd real dens real gasdens q=1 ! aluminium A(1)=num_Al ! Al AW(1)=1 dens=2.7 call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19) end +DECK,TEXTOLITE,IF=NEVER. subroutine Textolite(nm) c c Initialization of Matter c implicit none integer nm c include 'LibAtMat.inc' +SEQ,LibAtMat. integer A(10) real AW(10) integer q real dens c textolite is SiO2 + epoxidka. The density is 1.7 g/sm**3. c We know also the density of SiO2 - 2.5 g/sm**3 and the typical c density of the carbone polimers is 1 g/sm**3. c "epoxidka"( I don not know its right english name) is c a class of polimers. One of them is O-3, C-18, H-20. c We did't know c the ratio of the components in textolite, but knowing data above c we can calculate it. c DATA WTEX/12., 27.0, 18. ,20./ c later comments c 05.04.95 c If Wi is weight coef. by volume and Di is density than c W1*D1+(1-W1)*D2=D => W1=(D-D2)/(D1-D2)=0.466 c W2=(D1-D)/(D1-D2)=0.534 c If WKi is weight coef. by volume than c WK1=D1/A1 * W1=2.5/60 * 0.466 = 0.0194 c WK2=D2/A2 * W2=1.0/284 * 0.534 = 0.00188 c WK1/WK2 = 10.3 c DATA WTEX/10.3, 23.6, 18. ,20./ q=4 ! textolite A(1)=num_Si AW(1)=10.3 A(2)=num_O AW(2)=23.6 A(3)=num_C AW(3)=18. A(4)=num_H AW(4)=20. dens=1.7 call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19) end +DECK,molecdef. subroutine molecdef implicit none c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'molecules.inc' +SEQ,molecule. c include 'molecdef.inc' +SEQ,molecdef. c include 'LibAtMat.inc' +SEQ,LibAtMat. integer n,na real s c Mean work per pair production is accordingly with c ICRU REPORT 31, Average Energy Required To Produce An Ion Pair, 1979. qSAtMol( numm_He)=1 nAtMol(1,numm_He)=num_He qAtMol(1,numm_He)=1 WWWMol( numm_He)=41.0e-6 FFFMol( numm_He)=0.19 qSAtMol( numm_Ne)=1 nAtMol(1,numm_Ne)=num_Ne qAtMol(1,numm_Ne)=1 WWWMol( numm_Ne)=35.4e-6 FFFMol( numm_Ne)=0.19 qSAtMol( numm_Ar)=1 nAtMol(1,numm_Ar)=num_Ar qAtMol(1,numm_Ar)=1 WWWMol( numm_Ar)=26.0e-6 FFFMol( numm_Ar)=0.19 qSAtMol( numm_Kr)=1 nAtMol(1,numm_Kr)=num_Kr qAtMol(1,numm_Kr)=1 WWWMol( numm_Kr)=24.0e-6 FFFMol( numm_Kr)=0.19 qSAtMol( numm_Xe)=1 nAtMol(1,numm_Xe)=num_Xe qAtMol(1,numm_Xe)=1 WWWMol( numm_Xe)=22.0e-6 FFFMol( numm_Xe)=0.19 qSAtMol( numm_H2)=1 nAtMol(1,numm_H2)=num_H qAtMol(1,numm_H2)=2 WWWMol( numm_H2)=37.0e-6 FFFMol( numm_H2)=0.19 qSAtMol( numm_N2)=1 nAtMol(1,numm_N2)=num_N qAtMol(1,numm_N2)=2 WWWMol( numm_N2)=35.0e-6 FFFMol( numm_N2)=0.19 qSAtMol( numm_O2)=1 nAtMol(1,numm_O2)=num_O qAtMol(1,numm_O2)=2 WWWMol( numm_O2)=31.0e-6 FFFMol( numm_O2)=0.19 qSAtMol( numm_NH3)=2 nAtMol(1,numm_NH3)=num_N qAtMol(1,numm_NH3)=1 nAtMol(2,numm_NH3)=num_H4 qAtMol(2,numm_NH3)=3 WWWMol( numm_NH3)=26.6e-6 FFFMol( numm_NH3)=0.19 qSAtMol( numm_N2O)=2 nAtMol(1,numm_N2O)=num_N qAtMol(1,numm_N2O)=2 nAtMol(2,numm_N2O)=num_O qAtMol(2,numm_N2O)=1 WWWMol( numm_N2O)=32.6e-6 FFFMol( numm_N2O)=0.19 qSAtMol( numm_CO2)=2 nAtMol(1,numm_CO2)=num_C1 qAtMol(1,numm_CO2)=1 nAtMol(2,numm_CO2)=num_O qAtMol(2,numm_CO2)=2 WWWMol( numm_CO2)=33.0e-6 FFFMol( numm_CO2)=0.19 qSAtMol( numm_CF4)=2 nAtMol(1,numm_CF4)=num_C2 qAtMol(1,numm_CF4)=1 nAtMol(2,numm_CF4)=num_F qAtMol(2,numm_CF4)=4 WWWMol( numm_CF4)=34.3e-6 FFFMol( numm_CF4)=0.19 qSAtMol( numm_CH4)=2 nAtMol(1,numm_CH4)=num_C3 qAtMol(1,numm_CH4)=1 nAtMol(2,numm_CH4)=num_H3 qAtMol(2,numm_CH4)=4 WWWMol( numm_CH4)=27.3e-6 FFFMol( numm_CH4)=0.19 qSAtMol( numm_C2H2)=2 nAtMol(1,numm_C2H2)=num_C3 qAtMol(1,numm_C2H2)=2 nAtMol(2,numm_C2H2)=num_H3 qAtMol(2,numm_C2H2)=2 WWWMol( numm_C2H2)=25.8e-6 FFFMol( numm_C2H2)=0.19 qSAtMol( numm_C2H4)=2 nAtMol(1,numm_C2H4)=num_C3 qAtMol(1,numm_C2H4)=2 nAtMol(2,numm_C2H4)=num_H3 qAtMol(2,numm_C2H4)=4 WWWMol( numm_C2H4)=25.8e-6 FFFMol( numm_C2H4)=0.19 qSAtMol( numm_C2H6)=2 nAtMol(1,numm_C2H6)=num_C3 qAtMol(1,numm_C2H6)=2 nAtMol(2,numm_C2H6)=num_H3 qAtMol(2,numm_C2H6)=6 WWWMol( numm_C2H6)=25.0e-6 FFFMol( numm_C2H6)=0.19 qSAtMol( numm_C3H8)=2 nAtMol(1,numm_C3H8)=num_C3 qAtMol(1,numm_C3H8)=3 nAtMol(2,numm_C3H8)=num_H3 qAtMol(2,numm_C3H8)=8 WWWMol( numm_C3H8)=24.0e-6 FFFMol( numm_C3H8)=0.19 qSAtMol( numm_iC4H10)=2 nAtMol(1,numm_iC4H10)=num_C3 qAtMol(1,numm_iC4H10)=4 nAtMol(2,numm_iC4H10)=num_H3 qAtMol(2,numm_iC4H10)=10 WWWMol( numm_iC4H10)=23.4e-6 FFFMol( numm_iC4H10)=0.19 *** Addition (RV 14/1/00). qSAtMol( numm_C5H12)=2 nAtMol(1,numm_C5H12)=num_C3 qAtMol(1,numm_C5H12)=5 nAtMol(2,numm_C5H12)=num_H3 qAtMol(2,numm_C5H12)=12 WWWMol( numm_C5H12)=23.2e-6 ! ICRU report 31 FFFMol( numm_C5H12)=0.19 *** End of addition. qSAtMol( numm_C)=1 ! for debug nAtMol(1,numm_C)=num_C qAtMol(1,numm_C)=1 WWWMol( numm_C)=31.0e-6 FFFMol( numm_C)=0.19 *** Additions (RV 4/9/98). qSAtMol( numm_DME)=3 nAtMol(1,numm_DME)=num_C3 qAtMol(1,numm_DME)=2 nAtMol(2,numm_DME)=num_H qAtMol(2,numm_DME)=6 nAtMol(3,numm_DME)=num_O qAtMol(3,numm_DME)=1 WWWMol( numm_DME)=45.4e-6 FFFMol( numm_DME)=0.19 qSAtMol( numm_H2O)=2 nAtMol(1,numm_H2O)=num_H qAtMol(1,numm_H2O)=2 nAtMol(2,numm_H2O)=num_O qAtMol(2,numm_H2O)=1 WWWMol( numm_H2O)=29.6e-6 ! ICRU 31 (1/5/79) FFFMol( numm_H2O)=0.19 *** Additions (RV 20/9/99). qSAtMol( numm_SF6)=2 nAtMol(1,numm_SF6)=num_S qAtMol(1,numm_SF6)=1 nAtMol(2,numm_SF6)=num_F qAtMol(2,numm_SF6)=6 WWWMol( numm_SF6)=35.75e-6 ! ICRU 31 (1/5/79) FFFMol( numm_SF6)=0.19 qSAtMol( numm_C2F4H2)=3 nAtMol(1,numm_C2F4H2)=num_C3 qAtMol(1,numm_C2F4H2)=2 nAtMol(2,numm_C2F4H2)=num_F qAtMol(2,numm_C2F4H2)=4 nAtMol(3,numm_C2F4H2)=num_H qAtMol(3,numm_C2F4H2)=2 WWWMol( numm_C2F4H2)=24.0e-6 ! Guess FFFMol( numm_C2F4H2)=0.19 qSAtMol( numm_C2F5H)=3 nAtMol(1,numm_C2F5H)=num_C3 qAtMol(1,numm_C2F5H)=2 nAtMol(2,numm_C2F5H)=num_F qAtMol(2,numm_C2F5H)=5 nAtMol(3,numm_C2F5H)=num_H qAtMol(3,numm_C2F5H)=1 WWWMol( numm_C2F5H)=24.0e-6 ! Guess FFFMol( numm_C2F5H)=0.19 *** End of additions. c qSAtMol( numm_CClF3)=2 c nAtMol(1,numm_CClF3)=num_C3 c qAtMol(1,numm_CClF3)=1 c nAtMol(1,numm_CClF3)=num_Cl c qAtMol(1,numm_CClF3)=1 c nAtMol(2,numm_CClF3)=num_F c qAtMol(2,numm_CClF3)=3 c WWWMol( numm_CClF3)=24.0e-6 c FFFMol( numm_CClF3)=0.19 do n=1,pqMol s=0.0 do na=1,qSAtMol(n) s=s+Aat(nAtMol(na,n))*qAtMol(na,n) enddo weiMol(n)=s enddo end subroutine Primolec implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'molecules.inc' +SEQ,molecule. c include 'molecdef.inc' +SEQ,molecdef. c include 'LibAtMat.inc' +SEQ,LibAtMat. integer n,na if(soo.eq.0)return write(oo,*) write(oo,*)' Primolec' write(oo,*)' pqMol=',pqMol do n=1,pqMol write(oo,*)' n=',n,' qSAtMol(n)=',qSAtMol(n) write(oo,*)' weiMol=',weiMol(n) write(oo,*)' WWWMol=',WWWMol(n) write(oo,*)' FFFMol=',FFFMol(n) do na=1,qSAtMol(n) write(oo,*)' nAtMol=',nAtMol(na,n),' qAtMol=',qAtMol(na,n) enddo enddo end +DECK,Inigas. subroutine Inigas( nmat, pqmole, pnmole, pwmole, pres, temp) c c initialization of the gas c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'volume.inc' +SEQ,volume. c include 'molecules.inc' +SEQ,molecule. c include 'molecdef.inc' +SEQ,molecdef. integer nmat ! Number of material integer pqmole ! Quantity of different molecules ! in the gas mixture. integer pnmole(pqMol) ! Their numbers in molecdef.inc ! accordingly with molecules.inc real pwmole(pqMol) ! Their weights ! (relative quantities of molecules). real pres ! Pressure in Torr. real temp ! Temperature in K. integer qmol, qold integer nmol(pqMol) real wmol(pqMol) integer n real s integer na,nm,i integer A(pqAt) real AW(pqAt) integer q real Ad(pqMol) real dens real gasdens real w real f c write(oo,*)' nmat=',nmat c write(oo,*)' qmol=',qmol c do n=1,qmol c write(oo,*)nmol(n),pwmol(n) c enddo c write(oo,*)' temp=',temp c write(oo,*)' pres=',pres c Copy everything qmol=pqmole do n=1,qmol nmol(n)=pnmole(n) wmol(n)=pwmole(n) enddo do n=1,qmol ! Check for negative weights if(wmol(n).lt.0)then write(oo,*)' error in Inigas: negative weight: wmol=', - wmol(n) if(sret_err.eq.0) stop s_err=1 return endif enddo s=0.0 ! Compute the sun of weights do n=1,qmol s=s+wmol(n) enddo if(s.eq.0)then ! Check zero sum write(oo,*)' error in Inigas: all weights are zero' if(sret_err.eq.0) stop s_err=1 return endif do n=1,qmol ! Normalize the weights wmol(n)=wmol(n)/s enddo *** Remove components with zero weight, rewritten (RV 9/6/99). qold=qmol qmol=0 do n=1,qold if(wmol(n).gt.0)then qmol=qmol+1 nmol(qmol)=nmol(n) wmol(qmol)=wmol(n) endif enddo if(qmol.le.0)then print *,' !!!!!! INIGAS WARNING : No non-zero weight'// - ' gas components found; mixture rejected.' if(sret_err.eq.0) stop s_err=1 return endif *** End of modification. c fill material q=0 do n=1,qmol ! Take the next molecule nm=nmol(n) ! Its number in molecdef.inc c write(oo,*)' nm=',nm,' qSAtMol(nm)=',qSAtMol(nm) c Check that this molecule exists in list. if(nm.le.0.or.nm.gt.pqMol)then write(oo,*)' error in Inigas: the wrong molecule number' if(sret_err.eq.0) stop s_err=1 return endif do na=1,qSAtMol(nm) ! Loop over atoms of current molecule do i=1,q ! Loop over enrolled atoms ! Check if the atom is already enrolled if(A(i).eq.nAtMol(na,nm))then goto 10 endif enddo q=q+1 ! To enroll it A(q)=nAtMol(na,nm) AW(q)=qAtMol(na,nm) * wmol(n) ! The weight of the atom c write(oo,*)' q=',q,' A(q)=',A(q),' AW(q)=',AW(q) goto 20 10 continue AW(i)=AW(i) + qAtMol(na,nm) * wmol(n) c write(oo,*)' q=',q,' A(q)=',A(q),' AW(q)=',AW(q) 20 continue enddo enddo do n=1,qmol nm=nmol(n) Ad(n)=weiMol(nm) enddo c pressure, temperature Cur_Pressure=pres Cur_Temper=temp c density of the ideal gas dens = gasdens(Ad, wmol, qmol) if(s_err.eq.1) return w=0.0 f=0.0 do n=1,qmol nm=nmol(n) w = w + WWWMol(nm) * wmol(n) f = f + FFFMol(nm) * wmol(n) enddo call IniMatter(nmat,A,AW,q,dens,w,f) if(s_err.eq.1) return *** Added argument to PriMatter (RV 13/4/99). c call PriMatter(0) end +DECK,IniAtom. subroutine IniAtom(num,z,a) c c The special cases incorporated by fortran code: c Ar and O : with including exp. data c and change of part of 3p and 2p shell corespondently. c C for CO2 (C1) : 2p sift from 8.9 to 13.79 c C for CF4 (C2) : 2p sift from 8.9 to 16.23 c C for CH4 : 2p sift c c for C2H10 : 2p sift c implicit none save c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'shellfi.inc' +SEQ,shellfi. c include 'atoms.inc' +SEQ,atoms. c include 'cconst.inc' +SEQ,cconst. c include 'shl.inc' +SEQ,shl. c include 'tpasc.inc' +SEQ,tpasc. c include 'LibAtMat.inc' +SEQ,LibAtMat. integer num !number of atom in the bank integer z !charge real a !atomic weight real w,sw,s integer qbener parameter (qbener=138) real aenerc(qbener),epa(qbener) integer qbener1 parameter (qbener1=5) real aenerc1(qbener1),epa1(qbener1) real e c integer num_at_mol c parameter (num_at_mol=2) real interp_linep_arr c include 'shellescar.inc' data aenerc(1) / 15.83 / data epa(1) / 29.2 / data aenerc(2) / 15.89 / data epa(2) / 29.5 / data aenerc(3) / 16.1 / data epa(3) / 30.3 / data aenerc(4) / 16.31 / data epa(4) / 31.1 / data aenerc(5) / 16.53 / data epa(5) / 31.8 / data aenerc(6) / 16.75 / data epa(6) / 32.5 / data aenerc(7) / 16.98 / data epa(7) / 33.1 / data aenerc(8) / 17.22 / data epa(8) / 33.7 / data aenerc(9) / 17.46 / data epa(9) / 34.2 / data aenerc(10) / 17.71 / data epa(10) / 34.7 / data aenerc(11) / 17.97 / data epa(11) / 35.1 / data aenerc(12) / 18.23 / data epa(12) / 35.5 / data aenerc(13) / 18.5 / data epa(13) / 35.8 / data aenerc(14) / 18.78 / data epa(14) / 36.1 / data aenerc(15) / 19.07 / data epa(15) / 36.3 / data aenerc(16) / 19.37 / data epa(16) / 36.5 / data aenerc(17) / 19.68 / data epa(17) / 36.3 / data aenerc(18) / 20 / data epa(18) / 36.7 / data aenerc(19) / 20.32 / data epa(19) / 36.8 / data aenerc(20) / 20.66 / data epa(20) / 36.7 / data aenerc(21) / 21.01 / data epa(21) / 36.7 / data aenerc(22) / 21.38 / data epa(22) / 36.5 / data aenerc(23) / 21.75 / data epa(23) / 36.3 / data aenerc(24) / 22.14 / data epa(24) / 36.1 / data aenerc(25) / 22.54 / data epa(25) / 35.7 / data aenerc(26) / 22.96 / data epa(26) / 35.4 / data aenerc(27) / 23.39 / data epa(27) / 34.9 / data aenerc(28) / 23.84 / data epa(28) / 34.4 / data aenerc(29) / 24.31 / data epa(29) / 33.8 / data aenerc(30) / 24.8 / data epa(30) / 33.1 / data aenerc(31) / 25.3 / data epa(31) / 32.3 / data aenerc(32) / 25.83 / data epa(32) / 31.4 / data aenerc(33) / 26.38 / data epa(33) / 30.5 / data aenerc(34) / 26.95 / data epa(34) / 29.5 / data aenerc(35) / 27.55 / data epa(35) / 28.3 / data aenerc(36) / 28.18 / data epa(36) / 27.1 / data aenerc(37) / 28.83 / data epa(37) / 25.7 / data aenerc(38) / 29.52 / data epa(38) / 24.3 / data aenerc(39) / 30.24 / data epa(39) / 22.7 / data aenerc(40) / 30.99 / data epa(40) / 21 / data aenerc(41) / 31.79 / data epa(41) / 19.1 / data aenerc(42) / 32.63 / data epa(42) / 17.1 / data aenerc(43) / 33.51 / data epa(43) / 15 / data aenerc(44) / 34.44 / data epa(44) / 12.8 / data aenerc(45) / 35.42 / data epa(45) / 10.3 / data aenerc(46) / 36.46 / data epa(46) / 7.77 / data aenerc(47) / 37.57 / data epa(47) / 6.1 / data aenerc(48) / 38.74 / data epa(48) / 4.62 / data aenerc(49) / 39.99 / data epa(49) / 3.41 / data aenerc(50) / 41.33 / data epa(50) / 2.47 / data aenerc(51) / 42.75 / data epa(51) / 1.77 / data aenerc(52) / 44.28 / data epa(52) / 1.3 / data aenerc(53) / 45.92 / data epa(53) / 1.03 / data aenerc(54) / 47.68 / data epa(54) / 0.914 / data aenerc(55) / 49.59 / data epa(55) / 0.916 / data aenerc(56) / 51.66 / data epa(56) / 1 / data aenerc(57) / 53.9 / data epa(57) / 1.13 / data aenerc(58) / 56.35 / data epa(58) / 1.28 / data aenerc(59) / 59.04 / data epa(59) / 1.36 / data aenerc(60) / 61.99 / data epa(60) / 1.42 / data aenerc(61) / 65.25 / data epa(61) / 1.45 / data aenerc(62) / 68.88 / data epa(62) / 1.48 / data aenerc(63) / 72.93 / data epa(63) / 1.48 / data aenerc(64) / 77.49 / data epa(64) / 1.47 / data aenerc(65) / 82.65 / data epa(65) / 1.45 / data aenerc(66) / 88.56 / data epa(66) / 1.41 / data aenerc(67) / 95.37 / data epa(67) / 1.36 / data aenerc(68) / 103.3 / data epa(68) / 1.29 / data aenerc(69) / 112.7 / data epa(69) / 1.2 / data aenerc(70) / 124 / data epa(70) / 1.1 / data aenerc(71) / 130.5 / data epa(71) / 1.05 / data aenerc(72) / 137.8 / data epa(72) / 0.987 / data aenerc(73) / 145.9 / data epa(73) / 0.923 / data aenerc(74) / 155 / data epa(74) / 0.856 / data aenerc(75) / 165.3 / data epa(75) / 0.785 / data aenerc(76) / 177.1 / data epa(76) / 0.709 / data aenerc(77) / 190.7 / data epa(77) / 0.63 / data aenerc(78) / 206.6 / data epa(78) / 0.547 / data aenerc(79) / 225.4 / data epa(79) / 0.461 / data aenerc(80) / 245 / data epa(80) / 0.381 / data aenerc(81) / 248 / data epa(81) / 4.66 / data aenerc(82) / 258.3 / data epa(82) / 4.23 / data aenerc(83) / 269.5 / data epa(83) / 3.83 / data aenerc(84) / 281.8 / data epa(84) / 3.45 / data aenerc(85) / 295.2 / data epa(85) / 3.1 / data aenerc(86) / 310 / data epa(86) / 2.76 / data aenerc(87) / 326.3 / data epa(87) / 2.45 / data aenerc(88) / 344.4 / data epa(88) / 2.16 / data aenerc(89) / 364.7 / data epa(89) / 1.89 / data aenerc(90) / 387.4 / data epa(90) / 1.64 / data aenerc(91) / 413.3 / data epa(91) / 1.41 / data aenerc(92) / 442.8 / data epa(92) / 1.2 / data aenerc(93) / 476.9 / data epa(93) / 1.01 / data aenerc(94) / 516.6 / data epa(94) / 0.836 / data aenerc(95) / 563.6 / data epa(95) / 0.682 / data aenerc(96) / 619.9 / data epa(96) / 0.546 / data aenerc(97) / 652.5 / data epa(97) / 0.484 / data aenerc(98) / 688.8 / data epa(98) / 0.426 / data aenerc(99) / 729.3 / data epa(99) / 0.373 / data aenerc(100) / 774.9 / data epa(100) / 0.324 / data aenerc(101) / 826.5 / data epa(101) / 0.278 / data aenerc(102) / 885.6 / data epa(102) / 0.237 / data aenerc(103) / 953.7 / data epa(103) / 0.199 / data aenerc(104) / 1044 / data epa(104) / 0.165 / data aenerc(105) / 1127 / data epa(105) / 0.135 / data aenerc(106) / 1240 / data epa(106) / 0.108 / data aenerc(107) / 1305 / data epa(107) / 0.0955 / data aenerc(108) / 1378 / data epa(108) / 0.0842 / data aenerc(109) / 1459 / data epa(109) / 0.0736 / data aenerc(110) / 1550 / data epa(110) / 0.0639 / data aenerc(111) / 1653 / data epa(111) / 0.0549 / data aenerc(112) / 1771 / data epa(112) / 0.0467 / data aenerc(113) / 1907 / data epa(113) / 0.0393 / data aenerc(114) / 2066 / data epa(114) / 0.0326 / data aenerc(115) / 2254 / data epa(115) / 0.0266 / data aenerc(116) / 2480 / data epa(116) / 0.0213 / data aenerc(117) / 2755 / data epa(117) / 0.0166 / data aenerc(118) / 3100 / data epa(118) / 0.0126 / data aenerc(119) / 3204 / data epa(119) / 0.0117 / data aenerc(120) / 3263 / data epa(120) / 0.0959 / data aenerc(121) / 3444 / data epa(121) / 0.0827 / data aenerc(122) / 3646 / data epa(122) / 0.0706 / data aenerc(123) / 3874 / data epa(123) / 0.0598 / data aenerc(124) / 4133 / data epa(124) / 0.0501 / data aenerc(125) / 4428 / data epa(125) / 0.0414 / data aenerc(126) / 4768 / data epa(126) / 0.0338 / data aenerc(127) / 5166 / data epa(127) / 0.0271 / data aenerc(128) / 5635 / data epa(128) / 0.0213 / data aenerc(129) / 6199 / data epa(129) / 0.0164 / data aenerc(130) / 6888 / data epa(130) / 0.0123 / data aenerc(131) / 7749 / data epa(131) / 0.00889 / data aenerc(132) / 8856 / data epa(132) / 0.00616 / data aenerc(133) / 10330 / data epa(133) / 0.00403 / data aenerc(134) / 12400 / data epa(134) / 0.00244 / data aenerc(135) / 15500 / data epa(135) / 0.00132 / data aenerc(136) / 20660 / data epa(136) / 0.000599 / data aenerc(137) / 31000 / data epa(137) / 0.000196 / data aenerc(138) / 61990 / data epa(138) / 2.9e-05 / c include 'shellesco.inc' data aenerc1(1) / 14.2 / data epa1(1) / 2.51 / data aenerc1(2) / 16.2 / data epa1(2) / 3.98 / data aenerc1(3) / 17.4 / data epa1(3) / 12.59 / data aenerc1(4) / 25.1 / data epa1(4) / 10.72 / data aenerc1(5) / 31.6 / data epa1(5) / 10 / integer pqnpasc parameter(pqnpasc=20) integer nnpasc integer pqnene parameter(pqnene=100) integer nnene real Tresh_npasc real nene,npasc common / comasc / + nnpasc,Tresh_npasc(pqnpasc),nnene(pqnpasc), + nene(pqnene,pqnpasc),npasc(pqnene,pqnpasc) save / comasc / integer i,iener,n,ne,j,ns,k,nn c integer ios real glin_integ_ar, step_integ_ar, sigma_nl c real lin_integ_ar c real interp_line_arr c real alog,sqrt if(num.le.0.or.num.gt.pQAt)then write(oo,*)' Error in IniAtom: Wrong Atom number ',num stop endif if(Zat(num).ne.0)then write(oo,*)' Error in IniAtom: Atom number ',num, + 'is initialized already' stop endif do n=1,QseqAt ! fill sequensed number if(Zat(n).gt.z)then do nn=QseqAt,n,-1 nseqAt(nn+1)=nseqAt(nn) enddo nseqAt(n)=num QseqAt=QseqAt+1 go to 4 endif enddo QseqAt=QseqAt+1 nseqAt(QseqAt)=num 4 continue Zat(num)=z Aat(num)=a cphoAt(num)=2.0*PI2*Zat(num)/(FSCON*ELMAS) RLenAt(num)=716.4*Aat(num)/ + (Zat(num)*(Zat(num)+1)*alog(287/sqrt(float(Zat(num))))) RuthAt(num)=4.0*PI*Zat(num)*Zat(num)*ELRAD*ELRAD*ELMAS*ELMAS zato=zat(num) if(KeyTeor.eq.0)then if(Zat(num).eq.1)then ! H QShellAt(num)=1 ThresholdAt(1,num)=16.4e-6 ! ionization potential of H2 c accordingly with At.Data.Nucl.Data.Tables 24,323-371(1979) if(num.eq.num_H3)then ! for CH4 c ThresholdAt(1,num)=15.2e-06 ThresholdAt(1,num)=12.0e-06 endif if(num.eq.num_H4)then ! for NH4 ThresholdAt(1,num)=10.0e-06 endif do ne=1,qener if(ener(ne+1).gt.ThresholdAt(1,num))then c PhotAt(ne,1,num)=1.51*0.0535* PhotAt(ne,1,num)=0.0535* + ((100.0e-6/ + (enerc(ne) + 16.4e-6 - ThresholdAt(1,num)))**3.228) if(ener(ne).lt.ThresholdAt(1,num))then PhotAt(ne,1,num)=PhotAt(ne,1,num)* + (ThresholdAt(1,num)-ener(ne))/ + (ener(ne+1)-ener(ne)) endif endif enddo c Now the cross section is generated in Mega-barns. c Calc. coef for going from 10**-18 sm**2 to Mev-2 s=1.e-18 * 5.07e10 * 5.07e10 do ne=1,qener do ns=1,QShellAt(num) PhotAt(ne,ns,num)=PhotAt(ne,ns,num)*s enddo enddo do ns=1,QShellAt(num) WeightShAt(ns,num)=step_integ_ar(ener,PhotAt(1,ns,num),qener, + ener(1),ener(qener+1))/cphoAt(num) enddo go to 100 endif if(Zat(num).eq.6)then call henke QShellAt(num)=qash do ns=1,QShellAt(num) ThresholdAt(ns,num)=athreshold(ns) if(ns.eq.QShellAt(num))then if(num.eq.num_C1)then ThresholdAt(ns,num)=13.79e-6 ! CO2 endif if(num.eq.num_C2)then ThresholdAt(ns,num)=16.23e-6 ! CF4 endif if(num.eq.num_C3)then c ThresholdAt(ns,num)=15.2e-6 ! CH4 ThresholdAt(ns,num)=12.0e-6 ! CH4 and so on endif endif do ne=1,qener PhotAt(ne,ns,num)= + interp_linep_arr(aener(1,ns),aphot(1,ns),qaener(ns), + athreshold(ns), + (enerc(ne) - (ThresholdAt(ns,num) - athreshold(ns))) ) enddo enddo c Now the cross section is generated in Mega-barns. c Calc. coef for going from 10**-18 sm**2 to Mev-2 s=1.e-18 * 5.07e10 * 5.07e10 do ne=1,qener do ns=1,QShellAt(num) PhotAt(ne,ns,num)=PhotAt(ne,ns,num)*s enddo enddo do ns=1,QShellAt(num) WeightShAt(ns,num)=step_integ_ar(ener,PhotAt(1,ns,num),qener, + ener(1),ener(qener+1))/cphoAt(num) enddo go to 100 endif qshPas(num)=0 call readPas(num) if(qshPas(num).gt.0)then QShellAt(num)=qshPas(num) do ns=1,qshPas(num) ThresholdAt(ns,num)=EthPas(ns,num)*1.e-6 if(Zat(num).eq.6.and.ns.eq.3.and. + num.eq.num_C1)then c + num_at_mol(num).eq.1)then ThresholdAt(ns,num)=13.79*1.e-6 ! for CO2 endif if(Zat(num).eq.6.and.ns.eq.3.and. + num.eq.num_C2)then c + num_at_mol(num).eq.2)then ThresholdAt(ns,num)=16.23*1.e-6 ! for CF4 endif if(Zat(num).eq.6.and.ns.eq.3.and. + num.eq.num_C3)then ThresholdAt(ns,num)=15.2*1.e-6 ! for CH4 endif if(ThresholdAt(ns,num).lt.ener(1))then write(oo,*)' error in IniAtom:' write(oo,*)' too high ener(1)=',ener(1) write(oo,*)' ThresholdAt(ns,num)=', + ThresholdAt(ns,num) stop endif enddo do ne=1,qener do i=1,qshPas(num) s=0.0 c do i=5,5 if(Zat(num).eq.18.and. + i.eq.5.and. + enerc(ne)*1.e6.gt.EthPas(i,num).and.enerc(ne)*1.e6.le.40)then j=qbener do k=2,qbener if(aenerc(k).ge.enerc(ne)*1.e6)then j=k-1 go to 5 endif enddo 5 s=s+ epa(j)+(enerc(ne)*1.e6-aenerc(j))* + (epa(j+1)-epa(j))/(aenerc(j+1)-aenerc(j)) elseif(Zat(num).eq.8.and. + i.eq.3.and. + enerc(ne)*1.e6.gt.EthPas(i,num).and.enerc(ne)*1.e6.le.25.1)then j=qbener1 do k=2,qbener1 if(aenerc1(k).ge.enerc(ne)*1.e6)then j=k-1 go to 6 endif enddo 6 s=s+ epa1(j)+(enerc(ne)*1.e6-aenerc1(j))* + (epa1(j+1)-epa1(j))/(aenerc1(j+1)-aenerc1(j)) else if(Zat(num).eq.6.and.i.eq.3)then c if(num.eq.num_C1)then cc if(num_at_mol(num).eq.1)then c e=enerc(ne)*1.e6-(13.79-.8987E+01) c elseif(num.eq.num_C2)then cc elseif(num_at_mol(num).eq.2)then c e=enerc(ne)*1.e6-(16.23-.8987E+01) c else c e=enerc(ne)*1.e6 c endif e=enerc(ne) - ThresholdAt(i,num) + .8987E+01*1.0e-6 e=e*1.e6 else e=enerc(ne)*1.e6 endif s=s + sigma_nl + (e , E0Pas(i,num),EthPas(i,num), + ywPas(i,num),lPas(i,num), + yaPas(i,num),PPas(i,num),sigma0Pas(i,num)) endif PhotAt(ne,i,num)=s enddo enddo c Now the cross section is generated in Mega-barns. c Calc. coef for going from 10**-18 sm**2 to Mev-2 s=1.e-18 * 5.07e10 * 5.07e10 do ne=1,qener do i=1,qshPas(num) PhotAt(ne,i,num)=PhotAt(ne,i,num)*s enddo enddo do ns=1,qshPas(num) WeightShAt(ns,num)=step_integ_ar(ener,PhotAt(1,ns,num),qener, + ener(1),ener(qener+1))/cphoAt(num) enddo go to 100 endif ! continuing of old algorithm call shellfi c call prishellfi endif if(qash.eq.0.or.KeyTeor.ne.0)then call shteor(num) if(qash.eq.0)then write(oo,*)' Error in IniAtom:', + 'can not find atom with z=',z stop endif call GenTheorPhot c call prishellfi endif call shellfico c call prishellfi QShellAt(num)=qash do i=1,qatm if(ZAt(num).eq.charge(i))then if(QShellAt(num).ne.qshl(i))then write(oo,*)' Worning of IniAtom:' write(oo,*)' Quantity of shell is different for shl' write(oo,*)' In may lead to error' endif goto 10 endif enddo 10 continue do i=1,QShellAt(num) ThresholdAt(i,num)=athreshold(i) if(ThresholdAt(i,num).lt.ener(1))then write(oo,*)' error in IniAtom:' write(oo,*)' too high ener(1)=',ener(1) write(oo,*)' ThresholdAt(ns,num)=', + ThresholdAt(i,num) stop endif WeightShAt(i,num)=aweight(i) do iener=1,qener PhotAt(iener,i,num)= + glin_integ_ar(aener(1,i),aphot(1,i),qaener(i), + ener(iener),ener(iener+1),ThresholdAt(i,num))/ + (ener(iener+1)-ener(iener)) enddo enddo *** Added argument to PriAtoms (RV 13/4/99) c call PriAtoms(0) *** End of modification. w=0.0 do i=1,QShellAt(num) w=w+WeightShAt(i,num) enddo do i=1,QShellAt(num) WeightShAt(i,num)=WeightShAt(i,num)/w enddo sw=0.0 do i=1,QShellAt(num) w=step_integ_ar(ener,PhotAt(1,i,num),qener, + ener(1),ener(qener+1)) PWeightShAt(i,num)=w sw=sw+w if(w.lt.0.0)then do n=1,qener PhotAt(n,i,num)=0.0 enddo else do n=1,qener PhotAt(n,i,num)=PhotAt(n,i,num)*cphoAt(num)* + WeightShAt(i,num)/w enddo ******* write(oo,*)' koef=',cphoAt(num)*WeightShAt(i,num)/w endif enddo do i=1,QShellAt(num) PWeightShAt(i,num)=PWeightShAt(i,num)/sw enddo 100 continue do i=1,qatm if(ZAt(num).eq.charge(i))then if(QShellAt(num).ne.qshl(i))then write(oo,*)' Worning of IniAtom:' write(oo,*)' Quantity of shell is different for shl' write(oo,*)' In may lead to error' endif goto 20 endif enddo 20 continue s=0.0 do ns=1,QShellAt(num) c write(oo,*)' start integration' ISPhotBAt(ns,num)=step_integ_ar + (ener,PhotAt(1,ns,num),qener,ener(1),ener(qener+1)) s=s+ISPhotBAt(ns,num) enddo IAPhotBAt(num)=s MinThresholdAt(num)=ThresholdAt(QShellAt(num),num) NshMinThresholdAt(num)=QShellAt(num) Min_ind_E_At(num)=0 Max_ind_E_At(num)=0 if(IAPhotBAt(num).gt.cphoAt(num))then c reduce all shells s=cphoAt(num)/IAPhotBAt(num) do ne=1,qener do ns=1,QShellAt(num) PhotAt(ne,ns,num)=PhotAt(ne,ns,num)*s enddo enddo c copy absorbtion to ionization do ne=1,qener do ns=1,QShellAt(num) PhotIonAt(ne,ns,num)=PhotAt(ne,ns,num) enddo enddo c reduce weights do ns=1,QShellAt(num) WeightShAt(ns,num)=WeightShAt(ns,num)*s enddo elseif(IAPhotBAt(num).lt.cphoAt(num))then c copy absorbtion to ionzation do ne=1,qener do ns=1,QShellAt(num) PhotIonAt(ne,ns,num)=PhotAt(ne,ns,num) enddo enddo c add excitation part to absorption j=qener do ne=3,qener if(ener(ne).gt.MinThresholdAt(num))then j=ne-1 ! ener(j) in the last point ! So the last interval has number j-1 go to 25 endif enddo 25 continue if(j.le.2)then write(oo,*)' Error in IniAtom:' write(oo,*)' cannot insert excitation' write(oo,*)' too large ener(1)=',ener(1) write(oo,*)' MinThresholdAt(num)=', + MinThresholdAt(num) stop endif nn=1 do ne=j-1,1,-1 if(enerc(ne).lt. 0.7*MinThresholdAt(num))then nn=ne go to 30 endif enddo 30 continue s=(-IAPhotBAt(num)+cphoAt(num))/ + (ener(j) - ener(nn)) do ne=nn,j-1 PhotAt(ne,NshMinThresholdAt(num),num)= + PhotAt(ne,NshMinThresholdAt(num),num)+s enddo Min_ind_E_At(num)=nn Max_ind_E_At(num)=j-1 else c copy absorbtion to ionzation do ne=1,qener do ns=1,QShellAt(num) PhotIonAt(ne,ns,num)=PhotAt(ne,ns,num) enddo enddo c add excitation part to absorption endif s=0.0 do ns=1,QShellAt(num) ISPhotAt(ns,num)=step_integ_ar + (ener,PhotAt(1,ns,num),qener,ener(1),ener(qener+1)) s=s+ISPhotAt(ns,num) enddo IAPhotAt(num)=s s=0.0 do ns=1,QShellAt(num) ISPhotIonAt(ns,num)=step_integ_ar + (ener,PhotIonAt(1,ns,num),qener, + ener(1),ener(qener+1)) s=s+ISPhotIonAt(ns,num) enddo IAPhotIonAt(num)=s end subroutine GenTheorPhot implicit none c include 'ener.inc' +SEQ,ener. c include 'shellfi.inc' +SEQ,shellfi. integer nsh,nen do nsh=1,qash qaener(nsh)=qener do nen=1,qener aener(nen,nsh)=enerc(nen) if(athreshold(nsh).lt.ener(nen+1))then aphot(nen,nsh)=1.0/(enerc(nen)**2.5) if(athreshold(nsh).gt.ener(nen))then aphot(nen,nsh)=aphot(nen,nsh)* + (ener(nen+1)-athreshold(nsh))/ + (ener(nen+1)-ener(nen)) endif else aphot(nen,nsh)=0.0 endif enddo enddo end subroutine shellfico implicit none c include 'ener.inc' +SEQ,ener. c include 'shellfi.inc' +SEQ,shellfi. integer is,iaen,iaens,ien,iens real np np=2.5 c the prolongation is needed only for first shell do is=1,qash c is=1 do iaen=qaener(is),1,-1 if(aphot(iaen,is).gt.0)then iaens=iaen go to 10 endif enddo 10 continue if(is.ne.1)then if(aener(iaens,is).eq.aener(1,is-1))then go to 30 endif endif c same strange empty place in file in some atoms if(aener(iaens,is).lt.enerc(qener))then do ien=1,qener if(enerc(ien).gt.aener(iaens,is))then iens=ien goto 20 endif enddo 20 continue iaen=iaens do ien=iens,qener iaen=iaen+1 aener(iaen,is)=enerc(ien) aphot(iaen,is)=aphot(iaens,is)* + (aener(iaens,is)/enerc(ien))**np enddo qaener(is)=iaen endif 30 continue enddo c if(zato.eq.18)then c call prishellfi c endif end subroutine priatoms(n) implicit none integer n ! n = 0,1 short output ! n >= 2 long output c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. integer nat, nsh, nen, nat1 if(soo.eq.0)return write(oo,*) write(oo,*)' priatoms: Atomic data' write(oo,*)' KeyTeor=',KeyTeor do nat=1,pQAt if(Zat(nat).gt.0)then write(oo,*) write(oo,*)' nat=',nat,' Zat=',Zat(nat),' Aat=',Aat(nat), + ' QShellAt=',QShellAt(nat) c write(oo,*)' num_at_mol=',num_at_mol(nat) write(oo,*)' cphoAt=',cphoAt(nat) write(oo,*)' RLenAt=',RLenAt(nat) write(oo,*)' RuthAt=',RuthAt(nat) do nsh=1,QShellAt(nat) write(oo,*)' ThresholdAt=',ThresholdAt(nsh,nat), + ' WeightShAt=',WeightShAt(nsh,nat) write(oo,*)' PWeightShAt=',PWeightShAt(nsh,nat) enddo write(oo,*)' IAPhotBAt IAPhotAt IAPhotIonAt ' write(oo,*)IAPhotBAt(nat), IAPhotAt(nat), IAPhotIonAt(nat) do nsh=1,QShellAt(nat) write(oo,*)nsh, + ISPhotBAt(nsh,nat), ISPhotAt(nsh,nat), ISPhotIonAt(nsh,nat) enddo write(oo,*)' MinThresholdAt=',MinThresholdAt(nat) write(oo,*)' NshMinThresholdAt=',NshMinThresholdAt(nat) write(oo,*)' Min_ind_E_At=',Min_ind_E_At(nat), + ' Max_ind_E_At=',Max_ind_E_At(nat) if(n.ge.2)then write(oo,*)' energy and photoabs cross sections' c do nen=1,qener c write(oo,'(10e12.3)') c + enerc(nen),(PhotAt(nen,nsh,nat),nsh=1,QShellAt(nat)) c enddo do nsh=1,QShellAt(nat) write(oo,*)' shell number=',nsh write(oo,*)' enerc, PhotAt, PhotIonAt' do nen=1,qener write(oo,'(3e10.3)') + enerc(nen),PhotAt(nen,nsh,nat),PhotIonAt(nen,nsh,nat) enddo ! nen=1,qener enddo ! nsh=1,QShellAt(nat) endif ! if(n.ge.2) endif ! if(Zat(nat).gt.0) enddo ! nat=1,pQAt write(oo,*)' Sequenced numbers:' write(oo,*)' nat Zat(nat) nseqAt(nat)' do nat=1,QseqAt write(oo,*) nat, Zat(nat), nseqAt(nat) enddo write(oo,*) + ' nat1 nat Zat(nat)' do nat1=1,QseqAt nat=nseqAt(nat1) write(oo,*) nat1, nat, Zat(nat) enddo end +DECK,henke. subroutine henke c c include Henke's data implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'shellfi.inc' +SEQ,shellfi. integer nae,ns qash=0 !sign of absence c The next code is generated by a computer program c on the basis of data file 'henke.dat'. if(zato.eq.6)then c include 'henke6.inc' +SEQ,henke6. endif c end of computer code do ns=1,qash athreshold(ns)=athreshold(ns)*1.e-6 do nae=1,qaener(ns) aener(nae,ns)=aener(nae,ns)*1.e-6 enddo enddo if(soo.eq.1)then if(qash.eq.0)then write(oo,*)' Worning of henke: atom z=',zato,' is not found.' write(oo,*) + ' The data will be seached by readPAS, accuracy will be lower.' endif endif c call prishellfi end +DECK,tpasc. subroutine readPas(na) implicit none integer na c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'tpasc.inc' +SEQ,tpasc. integer Za,npas integer i c include 'shelltsc.inc' integer pq parameter (pq=10) integer z(pq) integer n(pq) integer pmaxn parameter (pmaxn=5) integer l(pq,pmaxn) real p(pq,pmaxn,6) data z(1) / 2 / data n(1) / 1 / data l(1,1) / 0 / data p(1,1,1) / 23.42 / data p(1,1,2) / 2.024 / data p(1,1,3) / 2578 / data p(1,1,4) / 9.648 / data p(1,1,5) / 6.218 / data p(1,1,6) / 0 / data z(2) / 3 / data n(2) / 2 / data l(2,1) / 0 / data p(2,1,1) / 59.85 / data p(2,1,2) / 29.51 / data p(2,1,3) / 125.2 / data p(2,1,4) / 73020 / data p(2,1,5) / 0.9438 / data p(2,1,6) / 0 / data l(2,2) / 0 / data p(2,2,1) / 5.495 / data p(2,2,2) / 3.466 / data p(2,2,3) / 47.74 / data p(2,2,4) / 20.35 / data p(2,2,5) / 4.423 / data p(2,2,6) / 0 / data z(3) / 6 / data n(3) / 3 / data l(3,1) / 0 / data p(3,1,1) / 291 / data p(3,1,2) / 86.55 / data p(3,1,3) / 74.21 / data p(3,1,4) / 54.98 / data p(3,1,5) / 1.503 / data p(3,1,6) / 0 / data l(3,2) / 0 / data p(3,2,1) / 17.55 / data p(3,2,2) / 10.26 / data p(3,2,3) / 4564 / data p(3,2,4) / 1.568 / data p(3,2,5) / 10.85 / data p(3,2,6) / 0 / data l(3,3) / 1 / data p(3,3,1) / 8.987 / data p(3,3,2) / 9.435 / data p(3,3,3) / 1152 / data p(3,3,4) / 5.687 / data p(3,3,5) / 6.336 / data p(3,3,6) / 0.4474 / data z(4) / 7 / data n(4) / 3 / data l(4,1) / 0 / data p(4,1,1) / 404.8 / data p(4,1,2) / 127 / data p(4,1,3) / 47.48 / data p(4,1,4) / 138 / data p(4,1,5) / 1.252 / data p(4,1,6) / 0 / data l(4,2) / 0 / data p(4,2,1) / 23.1 / data p(4,2,2) / 14.82 / data p(4,2,3) / 772.2 / data p(4,2,4) / 2.306 / data p(4,2,5) / 9.139 / data p(4,2,6) / 0 / data l(4,3) / 1 / data p(4,3,1) / 11.49 / data p(4,3,2) / 11.64 / data p(4,3,3) / 10290 / data p(4,3,4) / 2.361 / data p(4,3,5) / 8.821 / data p(4,3,6) / 0.4239 / data z(5) / 8 / data n(5) / 3 / data l(5,1) / 0 / data p(5,1,1) / 537.3 / data p(5,1,2) / 177.4 / data p(5,1,3) / 32.37 / data p(5,1,4) / 381.2 / data p(5,1,5) / 1.083 / data p(5,1,6) / 0 / data l(5,2) / 0 / data p(5,2,1) / 29.22 / data p(5,2,2) / 19.94 / data p(5,2,3) / 241.5 / data p(5,2,4) / 3.241 / data p(5,2,5) / 8.037 / data p(5,2,6) / 0 / data l(5,3) / 1 / data p(5,3,1) / 14.16 / data p(5,3,2) / 13.91 / data p(5,3,3) / 122000 / data p(5,3,4) / 1.364 / data p(5,3,5) / 11.4 / data p(5,3,6) / 0.4103 / data z(6) / 9 / data n(6) / 3 / data l(6,1) / 0 / data p(6,1,1) / 688.3 / data p(6,1,2) / 239 / data p(6,1,3) / 22.95 / data p(6,1,4) / 1257 / data p(6,1,5) / 0.9638 / data p(6,1,6) / 0 / data l(6,2) / 0 / data p(6,2,1) / 35.93 / data p(6,2,2) / 25.68 / data p(6,2,3) / 109.7 / data p(6,2,4) / 4.297 / data p(6,2,5) / 7.303 / data p(6,2,6) / 0 / data l(6,3) / 1 / data p(6,3,1) / 17 / data p(6,3,2) / 16.58 / data p(6,3,3) / 277500 / data p(6,3,4) / 1.242 / data p(6,3,5) / 12.49 / data p(6,3,6) / 0.3857 / data z(7) / 10 / data n(7) / 3 / data l(7,1) / 0 / data p(7,1,1) / 858.2 / data p(7,1,2) / 314.4 / data p(7,1,3) / 16.64 / data p(7,1,4) / 204200 / data p(7,1,5) / 0.845 / data p(7,1,6) / 0 / data l(7,2) / 0 / data p(7,2,1) / 43.24 / data p(7,2,2) / 32.04 / data p(7,2,3) / 56.15 / data p(7,2,4) / 5.808 / data p(7,2,5) / 6.678 / data p(7,2,6) / 0 / data l(7,3) / 1 / data p(7,3,1) / 20 / data p(7,3,2) / 20 / data p(7,3,3) / 16910 / data p(7,3,4) / 2.442 / data p(7,3,5) / 10.43 / data p(7,3,6) / 0.3345 / data z(8) / 13 / data n(8) / 5 / data l(8,1) / 0 / data p(8,1,1) / 1550 / data p(8,1,2) / 367 / data p(8,1,3) / 22.06 / data p(8,1,4) / 44.05 / data p(8,1,5) / 1.588 / data p(8,1,6) / 0 / data l(8,2) / 0 / data p(8,2,1) / 119 / data p(8,2,2) / 55.94 / data p(8,2,3) / 14.25 / data p(8,2,4) / 30.94 / data p(8,2,5) / 4.399 / data p(8,2,6) / 0 / data l(8,3) / 1 / data p(8,3,1) / 80.87 / data p(8,3,2) / 64.45 / data p(8,3,3) / 173.5 / data p(8,3,4) / 11310 / data p(8,3,5) / 2.762 / data p(8,3,6) / 0.02337 / data l(8,4) / 0 / data p(8,4,1) / 10.16 / data p(8,4,2) / 12.04 / data p(8,4,3) / 5.384 / data p(8,4,4) / 434.1 / data p(8,4,5) / 4.088 / data p(8,4,6) / 0 / data l(8,5) / 1 / data p(8,5,1) / 4.878 / data p(8,5,2) / 18.6 / data p(8,5,3) / 182.8 / data p(8,5,4) / 2.797 / data p(8,5,5) / 10.84 / data p(8,5,6) / 0.3076 / data z(9) / 14 / data n(9) / 5 / data l(9,1) / 0 / data p(9,1,1) / 1828 / data p(9,1,2) / 532.2 / data p(9,1,3) / 11.84 / data p(9,1,4) / 258 / data p(9,1,5) / 1.102 / data p(9,1,6) / 0 / data l(9,2) / 0 / data p(9,2,1) / 151.5 / data p(9,2,2) / 70.17 / data p(9,2,3) / 11.66 / data p(9,2,4) / 47.42 / data p(9,2,5) / 3.933 / data p(9,2,6) / 0 / data l(9,3) / 1 / data p(9,3,1) / 108.2 / data p(9,3,2) / 78.08 / data p(9,3,3) / 153.2 / data p(9,3,4) / 5.765e+06 / data p(9,3,5) / 2.639 / data p(9,3,6) / 0.0002774 / data l(9,4) / 0 / data p(9,4,1) / 13.61 / data p(9,4,2) / 14.13 / data p(9,4,3) / 11.66 / data p(9,4,4) / 22.88 / data p(9,4,5) / 5.334 / data p(9,4,6) / 0 / data l(9,5) / 1 / data p(9,5,1) / 6.542 / data p(9,5,2) / 22.12 / data p(9,5,3) / 184.5 / data p(9,5,4) / 3.849 / data p(9,5,5) / 9.721 / data p(9,5,6) / 0.2921 / data z(10) / 18 / data n(10) / 5 / data l(10,1) / 0 / data p(10,1,1) / 3178 / data p(10,1,2) / 1135 / data p(10,1,3) / 4.28 / data p(10,1,4) / 3.285e+07 / data p(10,1,5) / 0.7631 / data p(10,1,6) / 0 / data l(10,2) / 0 / data p(10,2,1) / 313.5 / data p(10,2,2) / 130.2 / data p(10,2,3) / 9.185 / data p(10,2,4) / 26.93 / data p(10,2,5) / 4.021 / data p(10,2,6) / 0 / data l(10,3) / 1 / data p(10,3,1) / 247.9 / data p(10,3,2) / 164.7 / data p(10,3,3) / 83.72 / data p(10,3,4) / 54.52 / data p(10,3,5) / 3.328 / data p(10,3,6) / 0.627 / data l(10,4) / 0 / data p(10,4,1) / 28.92 / data p(10,4,2) / 25.25 / data p(10,4,3) / 6.394 / data p(10,4,4) / 170 / data p(10,4,5) / 4.223 / data p(10,4,6) / 0 / data l(10,5) / 1 / data p(10,5,1) / 14.49 / data p(10,5,2) / 38.54 / data p(10,5,3) / 48.72 / data p(10,5,4) / 26.4 / data p(10,5,5) / 6.662 / data p(10,5,6) / 0.2355 / Za=Zat(na) do i=1,pq if(z(i).eq.Za)then qshPas(na)=n(i) do npas=1,qshPas(na) lPas(npas,na)=l(i,npas) EthPas(npas,na)=p(i,npas,1) E0Pas(npas,na)=p(i,npas,2) sigma0Pas(npas,na)=p(i,npas,3) yaPas(npas,na)=p(i,npas,4) PPas(npas,na)=p(i,npas,5) ywPas(npas,na)=p(i,npas,6) enddo go to 110 endif enddo *** Warning message commented out (RV 29/6/98). C if(soo.eq.1)then C write(oo,*) C + ' Worning of readPas: atom z=',Za,' is not found.' C write(oo,*) C + ' The data will be seached by shellfi, accuracy will be lower.' C endif *** End of modification. 110 continue end function sigma_nl(E,E0,Eth,yw,l,ya,P,sigma0) implicit none real sigma_nl,Fpasc real E,E0,Eth,yw,ya,P,sigma0 integer l real Q,y if(E.ge.Eth)then Q=5.5+l-0.5*P y=E/E0 Fpasc=((y-1)*(y-1) + yw*yw) * y**(-Q) * (1.0 + sqrt(y/ya))**(-P) Fpasc=Fpasc*sigma0 else Fpasc=0.0 endif sigma_nl=Fpasc end subroutine Pripasc implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'tpasc.inc' +SEQ,tpasc. integer na,ns if(soo.eq.0)return write(oo,*) write(oo,*)' Pripasc:' do na=1,PQat if(Zat(na).gt.0)then write(oo,*)' qshPas(na)=',qshPas(na) write(oo,*)' l,E0,Eth,yw, ya,P,sigma0:' do ns=1,qshPas(na) write(oo,'(1X,i3,6e10.3)')lPas(ns,na),E0Pas(ns,na), + EthPas(ns,na),ywPas(ns,na),yaPas(ns,na),PPas(ns,na), + sigma0Pas(ns,na) enddo endif enddo end +DECK,shellfi. subroutine shellfi c c read shellfi.dat implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'shellfi.inc' +SEQ,shellfi. c integer i,z,n,k,j integer k1,l c character*1 a c integer ios qash=0 !sign of absence c The next code is generated by a computer program c on the basis of data file 'shellfi.dat'. if(zato.eq.3)then qash=2 athreshold(1)=5.44515e-05 aweight(1)=0.666667 qaener(1)=36 aener(1,1)=45.9 aphot(1,1)=0 aener(2,1)=50.4 aphot(2,1)=809 aener(3,1)=55.4 aphot(3,1)=6080 aener(4,1)=60.9 aphot(4,1)=8810 aener(5,1)=66.9 aphot(5,1)=8700 aener(6,1)=73.5 aphot(6,1)=7210 aener(7,1)=80.8 aphot(7,1)=5530 aener(8,1)=88.8 aphot(8,1)=4420 aener(9,1)=97.6 aphot(9,1)=3840 aener(10,1)=107 aphot(10,1)=3090 aener(11,1)=118 aphot(11,1)=2520 aener(12,1)=129 aphot(12,1)=2040 aener(13,1)=142 aphot(13,1)=1820 aener(14,1)=156 aphot(14,1)=1460 aener(15,1)=172 aphot(15,1)=1050 aener(16,1)=189 aphot(16,1)=866 aener(17,1)=207 aphot(17,1)=717 aener(18,1)=228 aphot(18,1)=594 aener(19,1)=275 aphot(19,1)=407 aener(20,1)=303 aphot(20,1)=337 aener(21,1)=500 aphot(21,1)=25.0178 aener(22,1)=700 aphot(22,1)=10.0856 aener(23,1)=900 aphot(23,1)=5.11698 aener(24,1)=1100 aphot(24,1)=2.97651 aener(25,1)=1300 aphot(25,1)=1.89593 aener(26,1)=1600 aphot(26,1)=1.08229 aener(27,1)=2000 aphot(27,1)=0.592498 aener(28,1)=4000 aphot(28,1)=0.0888748 aener(29,1)=6000 aphot(29,1)=0.0296249 aener(30,1)=8000 aphot(30,1)=0.0148125 aener(31,1)=10000 aphot(31,1)=0.00888748 aener(32,1)=20000 aphot(32,1)=0.00503624 aener(33,1)=30000 aphot(33,1)=0.00444374 aener(34,1)=40000 aphot(34,1)=0.00414749 aener(35,1)=50000 aphot(35,1)=0.00399937 aener(36,1)=80000 aphot(36,1)=0.00355499 athreshold(2)=1e-05 aweight(2)=0.333333 qaener(2)=29 aener(1,2)=8.4 aphot(1,2)=0 aener(2,2)=9.23 aphot(2,2)=2100 aener(3,2)=10.1 aphot(3,2)=16900 aener(4,2)=11.1 aphot(4,2)=25500 aener(5,2)=12.2 aphot(5,2)=22900 aener(6,2)=13.5 aphot(6,2)=17600 aener(7,2)=14.8 aphot(7,2)=15000 aener(8,2)=16.2 aphot(8,2)=10700 aener(9,2)=17.9 aphot(9,2)=8880 aener(10,2)=19.6 aphot(10,2)=7360 aener(11,2)=21.6 aphot(11,2)=6090 aener(12,2)=23.7 aphot(12,2)=5040 aener(13,2)=26 aphot(13,2)=4180 aener(14,2)=28.6 aphot(14,2)=3460 aener(15,2)=31.5 aphot(15,2)=2860 aener(16,2)=34.6 aphot(16,2)=2370 aener(17,2)=38 aphot(17,2)=1960 aener(18,2)=41.7 aphot(18,2)=1630 aener(19,2)=45.9 aphot(19,2)=1350 aener(20,2)=50.4 aphot(20,2)=1110 aener(21,2)=55.4 aphot(21,2)=923 aener(22,2)=60.9 aphot(22,2)=764 aener(23,2)=66.9 aphot(23,2)=633 aener(24,2)=73.5 aphot(24,2)=524 aener(25,2)=80.8 aphot(25,2)=434 aener(26,2)=88.8 aphot(26,2)=359 aener(27,2)=97.6 aphot(27,2)=0.298 aener(28,2)=107 aphot(28,2)=0.00246 aener(29,2)=118 aphot(29,2)=0.000204 endif if(zato.eq.6)then qash=2 athreshold(1)=0.000309 aweight(1)=0.423871 qaener(1)=24 aener(1,1)=228 aphot(1,1)=16900 aener(2,1)=251 aphot(2,1)=23300 aener(3,1)=275 aphot(3,1)=30700 aener(4,1)=303 aphot(4,1)=38600 aener(5,1)=333 aphot(5,1)=37200 aener(6,1)=365 aphot(6,1)=31200 aener(7,1)=402 aphot(7,1)=24900 aener(8,1)=441 aphot(8,1)=20900 aener(9,1)=485 aphot(9,1)=18000 aener(10,1)=533 aphot(10,1)=14800 aener(11,1)=586 aphot(11,1)=11400 aener(12,1)=644 aphot(12,1)=8620 aener(13,1)=707 aphot(13,1)=7090 aener(14,1)=777 aphot(14,1)=5440 aener(15,1)=854 aphot(15,1)=3960 aener(16,1)=939 aphot(16,1)=3080 aener(17,1)=1030 aphot(17,1)=2400 aener(18,1)=3500 aphot(18,1)=60 aener(19,1)=4000 aphot(19,1)=33 aener(20,1)=10000 aphot(20,1)=2 aener(21,1)=20000 aphot(21,1)=0.4 aener(22,1)=30000 aphot(22,1)=0.27 aener(23,1)=50000 aphot(23,1)=0.2 aener(24,1)=100000 aphot(24,1)=0.17 athreshold(2)=1.03321e-05 aweight(2)=0.576129 qaener(2)=14 aener(1,2)=6.19927 aphot(1,2)=0 aener(2,2)=8.26569 aphot(2,2)=0 aener(3,2)=10.3321 aphot(3,2)=12.6 aener(4,2)=12.3985 aphot(4,2)=11.2 aener(5,2)=15.4982 aphot(5,2)=9.1 aener(6,2)=20.6642 aphot(6,2)=7.3 aener(7,2)=30.9964 aphot(7,2)=4.4 aener(8,2)=41.3285 aphot(8,2)=2.9 aener(9,2)=61.9927 aphot(9,2)=1.45 aener(10,2)=82.6569 aphot(10,2)=0.88 aener(11,2)=103.321 aphot(11,2)=0.59 aener(12,2)=123.985 aphot(12,2)=0.4 aener(13,2)=154.982 aphot(13,2)=0.24 aener(14,2)=206.642 aphot(14,2)=0.108 endif if(zato.eq.7)then qash=2 athreshold(1)=0.000413 aweight(1)=0.318257 qaener(1)=8 aener(1,1)=309.964 aphot(1,1)=0.07 aener(2,1)=413.285 aphot(2,1)=0.68 aener(3,1)=619.927 aphot(3,1)=0.255 aener(4,1)=826.569 aphot(4,1)=0.125 aener(5,1)=1033.21 aphot(5,1)=0.075 aener(6,1)=1239.85 aphot(6,1)=0.047 aener(7,1)=1549.82 aphot(7,1)=0.026 aener(8,1)=2066.42 aphot(8,1)=0.012 athreshold(2)=1.23985e-05 aweight(2)=0.681743 qaener(2)=15 aener(1,2)=6.19927 aphot(1,2)=0 aener(2,2)=8.26569 aphot(2,2)=0 aener(3,2)=10.3321 aphot(3,2)=0 aener(4,2)=12.3985 aphot(4,2)=11.95 aener(5,2)=15.4982 aphot(5,2)=11.9 aener(6,2)=20.6642 aphot(6,2)=9.65 aener(7,2)=30.9964 aphot(7,2)=7.8 aener(8,2)=41.3285 aphot(8,2)=5.4 aener(9,2)=61.9927 aphot(9,2)=2.9 aener(10,2)=82.6569 aphot(10,2)=1.75 aener(11,2)=103.321 aphot(11,2)=1.1 aener(12,2)=123.985 aphot(12,2)=0.65 aener(13,2)=154.982 aphot(13,2)=0.39 aener(14,2)=206.642 aphot(14,2)=0.208 aener(15,2)=309.964 aphot(15,2)=0.07 endif if(zato.eq.8)then qash=2 athreshold(1)=0.00062 aweight(1)=0.240404 qaener(1)=20 aener(1,1)=586 aphot(1,1)=13300 aener(2,1)=644 aphot(2,1)=14200 aener(3,1)=707 aphot(3,1)=11800 aener(4,1)=777 aphot(4,1)=9270 aener(5,1)=854 aphot(5,1)=7100 aener(6,1)=939 aphot(6,1)=5880 aener(7,1)=1030 aphot(7,1)=4660 aener(8,1)=1130 aphot(8,1)=3690 aener(9,1)=1250 aphot(9,1)=2790 aener(10,1)=1370 aphot(10,1)=2260 aener(11,1)=1500 aphot(11,1)=1740 aener(12,1)=1650 aphot(12,1)=1340 aener(13,1)=1820 aphot(13,1)=1060 aener(14,1)=3500 aphot(14,1)=187.5 aener(15,1)=4000 aphot(15,1)=118.125 aener(16,1)=10000 aphot(16,1)=6.75 aener(17,1)=20000 aphot(17,1)=0.9 aener(18,1)=30000 aphot(18,1)=0.39375 aener(19,1)=50000 aphot(19,1)=0.255 aener(20,1)=100000 aphot(20,1)=0.19875 athreshold(2)=2.06642e-05 aweight(2)=0.759596 qaener(2)=16 aener(1,2)=6.19927 aphot(1,2)=0 aener(2,2)=8.26569 aphot(2,2)=0 aener(3,2)=10.3321 aphot(3,2)=0 aener(4,2)=12.3985 aphot(4,2)=0 aener(5,2)=15.4982 aphot(5,2)=9 aener(6,2)=20.6642 aphot(6,2)=9.65 aener(7,2)=30.9964 aphot(7,2)=8.75 aener(8,2)=41.3285 aphot(8,2)=7.42 aener(9,2)=61.9927 aphot(9,2)=4.65 aener(10,2)=82.6569 aphot(10,2)=2.7 aener(11,2)=103.321 aphot(11,2)=1.77 aener(12,2)=123.985 aphot(12,2)=1.12 aener(13,2)=154.982 aphot(13,2)=0.7 aener(14,2)=206.642 aphot(14,2)=0.385 aener(15,2)=309.964 aphot(15,2)=0.16 aener(16,2)=413.285 aphot(16,2)=0.065 endif if(zato.eq.9)then qash=2 athreshold(1)=0.000827 aweight(1)=0.185727 qaener(1)=6 aener(1,1)=619.927 aphot(1,1)=0.05 aener(2,1)=826.569 aphot(2,1)=0.305 aener(3,1)=1033.21 aphot(3,1)=0.17 aener(4,1)=1239.85 aphot(4,1)=0.115 aener(5,1)=1549.82 aphot(5,1)=0.067 aener(6,1)=2066.42 aphot(6,1)=0.03 athreshold(2)=3.09964e-05 aweight(2)=0.814273 qaener(2)=17 aener(1,2)=6.19927 aphot(1,2)=0 aener(2,2)=8.26569 aphot(2,2)=0 aener(3,2)=10.3321 aphot(3,2)=0 aener(4,2)=12.3985 aphot(4,2)=0 aener(5,2)=15.4982 aphot(5,2)=0 aener(6,2)=20.6642 aphot(6,2)=0 aener(7,2)=30.9964 aphot(7,2)=10.6 aener(8,2)=41.3285 aphot(8,2)=10.1 aener(9,2)=61.9927 aphot(9,2)=6.7 aener(10,2)=82.6569 aphot(10,2)=4.1 aener(11,2)=103.321 aphot(11,2)=2.6 aener(12,2)=123.985 aphot(12,2)=1.8 aener(13,2)=154.982 aphot(13,2)=1.3 aener(14,2)=206.642 aphot(14,2)=0.59 aener(15,2)=309.964 aphot(15,2)=0.245 aener(16,2)=413.285 aphot(16,2)=0.124 aener(17,2)=619.927 aphot(17,2)=0.05 endif if(zato.eq.10)then qash=2 athreshold(1)=0.001033 aweight(1)=0.117826 qaener(1)=5 aener(1,1)=826.569 aphot(1,1)=0.03 aener(2,1)=1033.21 aphot(2,1)=0.205 aener(3,1)=1239.85 aphot(3,1)=0.135 aener(4,1)=1549.82 aphot(4,1)=0.077 aener(5,1)=2066.42 aphot(5,1)=0.039 athreshold(2)=3.09964e-05 aweight(2)=0.882174 qaener(2)=18 aener(1,2)=6.19927 aphot(1,2)=0 aener(2,2)=8.26569 aphot(2,2)=0 aener(3,2)=10.3321 aphot(3,2)=0 aener(4,2)=12.3985 aphot(4,2)=0 aener(5,2)=15.4982 aphot(5,2)=0 aener(6,2)=20.6642 aphot(6,2)=5.85 aener(7,2)=30.9964 aphot(7,2)=8.8 aener(8,2)=41.3285 aphot(8,2)=8.7 aener(9,2)=61.9927 aphot(9,2)=7.3 aener(10,2)=82.6569 aphot(10,2)=5.6 aener(11,2)=103.321 aphot(11,2)=4 aener(12,2)=123.985 aphot(12,2)=2.8 aener(13,2)=154.982 aphot(13,2)=1.75 aener(14,2)=206.642 aphot(14,2)=0.91 aener(15,2)=309.964 aphot(15,2)=0.36 aener(16,2)=413.285 aphot(16,2)=0.17 aener(17,2)=619.927 aphot(17,2)=0.063 aener(18,2)=826.569 aphot(18,2)=0.03 endif if(zato.eq.17)then qash=4 athreshold(1)=0.003485 aweight(1)=0.117088 qaener(1)=69 aener(1,1)=3365.37 aphot(1,1)=0 aener(2,1)=3536.21 aphot(2,1)=0.050227 aener(3,1)=3715.72 aphot(3,1)=0.0574 aener(4,1)=3904.35 aphot(4,1)=0.051988 aener(5,1)=4102.55 aphot(5,1)=0.047086 aener(6,1)=4310.81 aphot(6,1)=0.042647 aener(7,1)=4529.65 aphot(7,1)=0.038625 aener(8,1)=4759.59 aphot(8,1)=0.034983 aener(9,1)=5001.2 aphot(9,1)=0.031685 aener(10,1)=5255.08 aphot(10,1)=0.028697 aener(11,1)=5521.85 aphot(11,1)=0.025992 aener(12,1)=5802.16 aphot(12,1)=0.023541 aener(13,1)=6096.71 aphot(13,1)=0.021321 aener(14,1)=6406.2 aphot(14,1)=0.019311 aener(15,1)=6731.4 aphot(15,1)=0.01749 aener(16,1)=7073.12 aphot(16,1)=0.015841 aener(17,1)=7432.17 aphot(17,1)=0.014347 aener(18,1)=7809.46 aphot(18,1)=0.012995 aener(19,1)=8205.9 aphot(19,1)=0.011769 aener(20,1)=8622.46 aphot(20,1)=0.01066 aener(21,1)=9060.17 aphot(21,1)=0.009654 aener(22,1)=9520.11 aphot(22,1)=0.008744 aener(23,1)=10003.4 aphot(23,1)=0.00792 aener(24,1)=10511.2 aphot(24,1)=0.007173 aener(25,1)=11044.8 aphot(25,1)=0.006497 aener(26,1)=11605.5 aphot(26,1)=0.005884 aener(27,1)=12194.6 aphot(27,1)=0.005329 aener(28,1)=12813.6 aphot(28,1)=0.004827 aener(29,1)=13464.1 aphot(29,1)=0.004372 aener(30,1)=14147.6 aphot(30,1)=0.003959 aener(31,1)=14865.8 aphot(31,1)=0.003586 aener(32,1)=15620.4 aphot(32,1)=0.003248 aener(33,1)=16413.4 aphot(33,1)=0.002942 aener(34,1)=17246.6 aphot(34,1)=0.002664 aener(35,1)=18122.1 aphot(35,1)=0.002413 aener(36,1)=19042.1 aphot(36,1)=0.002186 aener(37,1)=20008.7 aphot(37,1)=0.00198 aener(38,1)=21024.4 aphot(38,1)=0.001793 aener(39,1)=22091.7 aphot(39,1)=0.001624 aener(40,1)=23213.2 aphot(40,1)=0.001471 aener(41,1)=24391.6 aphot(41,1)=0.001332 aener(42,1)=25629.8 aphot(42,1)=0.001206 aener(43,1)=26930.9 aphot(43,1)=0.001093 aener(44,1)=28298 aphot(44,1)=0.00099 aener(45,1)=29734.5 aphot(45,1)=0.000896 aener(46,1)=31243.9 aphot(46,1)=0.000812 aener(47,1)=32830 aphot(47,1)=0.000735 aener(48,1)=34496.6 aphot(48,1)=0.000666 aener(49,1)=36247.8 aphot(49,1)=0.000603 aener(50,1)=38087.9 aphot(50,1)=0.000546 aener(51,1)=40021.3 aphot(51,1)=0.000495 aener(52,1)=42053 aphot(52,1)=0.000448 aener(53,1)=44187.8 aphot(53,1)=0.000406 aener(54,1)=46430.9 aphot(54,1)=0.000368 aener(55,1)=48787.9 aphot(55,1)=0.000333 aener(56,1)=51264.6 aphot(56,1)=0.000302 aener(57,1)=53867 aphot(57,1)=0.000273 aener(58,1)=56601.5 aphot(58,1)=0.000247 aener(59,1)=59474.8 aphot(59,1)=0.000224 aener(60,1)=62494 aphot(60,1)=0.000203 aener(61,1)=65666.4 aphot(61,1)=0.000184 aener(62,1)=68999.9 aphot(62,1)=0.000166 aener(63,1)=72502.6 aphot(63,1)=0.000151 aener(64,1)=76183.1 aphot(64,1)=0.000137 aener(65,1)=80050.5 aphot(65,1)=0.000124 aener(66,1)=84114.2 aphot(66,1)=0.000112 aener(67,1)=88384.1 aphot(67,1)=0.000101 aener(68,1)=92870.9 aphot(68,1)=9.18846e-05 aener(69,1)=97585.4 aphot(69,1)=8.32209e-05 athreshold(2)=0.000207 aweight(2)=0.635323 qaener(2)=10 aener(1,2)=154.982 aphot(1,2)=0.6 aener(2,2)=206.642 aphot(2,2)=6.4 aener(3,2)=309.964 aphot(3,2)=2.45 aener(4,2)=413.285 aphot(4,2)=1.4 aener(5,2)=619.927 aphot(5,2)=0.45 aener(6,2)=826.569 aphot(6,2)=0.22 aener(7,2)=1033.21 aphot(7,2)=0.123 aener(8,2)=1239.85 aphot(8,2)=0.079 aener(9,2)=1549.82 aphot(9,2)=0.047 aener(10,2)=2066.42 aphot(10,2)=0.0195 athreshold(3)=6.19927e-05 aweight(3)=0.061546 qaener(3)=6 aener(1,3)=41.3285 aphot(1,3)=1.07 aener(2,3)=61.9927 aphot(2,3)=1.35 aener(3,3)=82.6569 aphot(3,3)=1.22 aener(4,3)=103.321 aphot(4,3)=1 aener(5,3)=123.985 aphot(5,3)=0.82 aener(6,3)=154.982 aphot(6,3)=0.6 athreshold(4)=1.54982e-05 aweight(4)=0.186043 qaener(4)=8 aener(1,4)=6.19927 aphot(1,4)=0 aener(2,4)=8.26569 aphot(2,4)=0 aener(3,4)=10.3321 aphot(3,4)=0 aener(4,4)=12.3985 aphot(4,4)=0 aener(5,4)=15.4982 aphot(5,4)=59 aener(6,4)=20.6642 aphot(6,4)=11 aener(7,4)=30.9964 aphot(7,4)=1.35 aener(8,4)=41.3285 aphot(8,4)=1.07 endif if(zato.eq.18)then qash=4 athreshold(1)=0.003934 aweight(1)=0.114211 qaener(1)=67 aener(1,1)=3715.72 aphot(1,1)=0 aener(2,1)=3904.35 aphot(2,1)=0.020435 aener(3,1)=4102.55 aphot(3,1)=0.053399 aener(4,1)=4310.81 aphot(4,1)=0.048364 aener(5,1)=4529.65 aphot(5,1)=0.043804 aener(6,1)=4759.59 aphot(6,1)=0.039674 aener(7,1)=5001.2 aphot(7,1)=0.035933 aener(8,1)=5255.08 aphot(8,1)=0.032545 aener(9,1)=5521.85 aphot(9,1)=0.029476 aener(10,1)=5802.16 aphot(10,1)=0.026697 aener(11,1)=6096.71 aphot(11,1)=0.02418 aener(12,1)=6406.2 aphot(12,1)=0.0219 aener(13,1)=6731.4 aphot(13,1)=0.019835 aener(14,1)=7073.12 aphot(14,1)=0.017965 aener(15,1)=7432.17 aphot(15,1)=0.016271 aener(16,1)=7809.46 aphot(16,1)=0.014737 aener(17,1)=8205.9 aphot(17,1)=0.013347 aener(18,1)=8622.46 aphot(18,1)=0.012089 aener(19,1)=9060.17 aphot(19,1)=0.010949 aener(20,1)=9520.11 aphot(20,1)=0.009917 aener(21,1)=10003.4 aphot(21,1)=0.008982 aener(22,1)=10511.2 aphot(22,1)=0.008135 aener(23,1)=11044.8 aphot(23,1)=0.007368 aener(24,1)=11605.5 aphot(24,1)=0.006673 aener(25,1)=12194.6 aphot(25,1)=0.006044 aener(26,1)=12813.6 aphot(26,1)=0.005474 aener(27,1)=13464.1 aphot(27,1)=0.004958 aener(28,1)=14147.6 aphot(28,1)=0.00449 aener(29,1)=14865.8 aphot(29,1)=0.004067 aener(30,1)=15620.4 aphot(30,1)=0.003683 aener(31,1)=16413.4 aphot(31,1)=0.003336 aener(32,1)=17246.6 aphot(32,1)=0.003022 aener(33,1)=18122.1 aphot(33,1)=0.002737 aener(34,1)=19042.1 aphot(34,1)=0.002479 aener(35,1)=20008.7 aphot(35,1)=0.002245 aener(36,1)=21024.4 aphot(36,1)=0.002033 aener(37,1)=22091.7 aphot(37,1)=0.001842 aener(38,1)=23213.2 aphot(38,1)=0.001668 aener(39,1)=24391.6 aphot(39,1)=0.001511 aener(40,1)=25629.8 aphot(40,1)=0.001368 aener(41,1)=26930.9 aphot(41,1)=0.001239 aener(42,1)=28298 aphot(42,1)=0.001122 aener(43,1)=29734.5 aphot(43,1)=0.001017 aener(44,1)=31243.9 aphot(44,1)=0.000921 aener(45,1)=32830 aphot(45,1)=0.000834 aener(46,1)=34496.6 aphot(46,1)=0.000755 aener(47,1)=36247.8 aphot(47,1)=0.000684 aener(48,1)=38087.9 aphot(48,1)=0.00062 aener(49,1)=40021.3 aphot(49,1)=0.000561 aener(50,1)=42053 aphot(50,1)=0.000508 aener(51,1)=44187.8 aphot(51,1)=0.00046 aener(52,1)=46430.9 aphot(52,1)=0.000417 aener(53,1)=48787.9 aphot(53,1)=0.000378 aener(54,1)=51264.6 aphot(54,1)=0.000342 aener(55,1)=53867 aphot(55,1)=0.00031 aener(56,1)=56601.5 aphot(56,1)=0.000281 aener(57,1)=59474.8 aphot(57,1)=0.000254 aener(58,1)=62494 aphot(58,1)=0.00023 aener(59,1)=65666.4 aphot(59,1)=0.000208 aener(60,1)=68999.9 aphot(60,1)=0.000189 aener(61,1)=72502.6 aphot(61,1)=0.000171 aener(62,1)=76183.1 aphot(62,1)=0.000155 aener(63,1)=80050.5 aphot(63,1)=0.00014 aener(64,1)=84114.2 aphot(64,1)=0.000127 aener(65,1)=88384.1 aphot(65,1)=0.000115 aener(66,1)=92870.9 aphot(66,1)=0.000104 aener(67,1)=97585.4 aphot(67,1)=9.43788e-05 athreshold(2)=0.00031 aweight(2)=0.438551 qaener(2)=10 aener(1,2)=206.642 aphot(1,2)=0.55 aener(2,2)=309.964 aphot(2,2)=2.52 aener(3,2)=413.285 aphot(3,2)=1.66 aener(4,2)=619.927 aphot(4,2)=0.62 aener(5,2)=826.569 aphot(5,2)=0.29 aener(6,2)=1033.21 aphot(6,2)=0.16 aener(7,2)=1239.85 aphot(7,2)=0.1 aener(8,2)=1549.82 aphot(8,2)=0.06 aener(9,2)=2066.42 aphot(9,2)=0.026 aener(10,2)=3099.64 aphot(10,2)=0.0085 athreshold(3)=6.19927e-05 aweight(3)=0.092874 qaener(3)=7 aener(1,3)=41.3285 aphot(1,3)=1 aener(2,3)=61.9927 aphot(2,3)=1.52 aener(3,3)=82.6569 aphot(3,3)=1.52 aener(4,3)=103.321 aphot(4,3)=1.33 aener(5,3)=123.985 aphot(5,3)=1.1 aener(6,3)=154.982 aphot(6,3)=0.85 aener(7,3)=206.642 aphot(7,3)=0.55 athreshold(4)=1.54982e-05 aweight(4)=0.354364 qaener(4)=8 aener(1,4)=6.19927 aphot(1,4)=0 aener(2,4)=8.26569 aphot(2,4)=0 aener(3,4)=10.3321 aphot(3,4)=0 aener(4,4)=12.3985 aphot(4,4)=0 aener(5,4)=15.4982 aphot(5,4)=60 aener(6,4)=20.6642 aphot(6,4)=52.5 aener(7,4)=30.9964 aphot(7,4)=2 aener(8,4)=41.3285 aphot(8,4)=1 endif if(zato.eq.36)then qash=4 athreshold(1)=0.015498 aweight(1)=0.04453 qaener(1)=4 aener(1,1)=12398.5 aphot(1,1)=0.0032 aener(2,1)=15498.2 aphot(2,1)=0.0205 aener(3,1)=20664.2 aphot(3,1)=0.0079 aener(4,1)=30996.4 aphot(4,1)=0.0022 athreshold(2)=0.00155 aweight(2)=0.262277 qaener(2)=9 aener(1,2)=1239.85 aphot(1,2)=0.22 aener(2,2)=1549.82 aphot(2,2)=0.7 aener(3,2)=2066.42 aphot(3,2)=0.41 aener(4,2)=3099.64 aphot(4,2)=0.14 aener(5,2)=4132.85 aphot(5,2)=0.061 aener(6,2)=6199.27 aphot(6,2)=0.02 aener(7,2)=8265.69 aphot(7,2)=0.0096 aener(8,2)=10332.1 aphot(8,2)=0.0053 aener(9,2)=12398.5 aphot(9,2)=0.0032 athreshold(3)=0.000207 aweight(3)=0.594165 qaener(3)=11 aener(1,3)=82.6569 aphot(1,3)=0.7 aener(2,3)=103.321 aphot(2,3)=1.2 aener(3,3)=123.985 aphot(3,3)=3.4 aener(4,3)=154.982 aphot(4,3)=6.1 aener(5,3)=206.642 aphot(5,3)=6.8 aener(6,3)=309.964 aphot(6,3)=4.4 aener(7,3)=413.285 aphot(7,3)=2.65 aener(8,3)=619.927 aphot(8,3)=0.95 aener(9,3)=826.569 aphot(9,3)=0.54 aener(10,3)=1033.21 aphot(10,3)=0.34 aener(11,3)=1239.85 aphot(11,3)=0.22 athreshold(4)=1.54982e-05 aweight(4)=0.099027 qaener(4)=10 aener(1,4)=6.19927 aphot(1,4)=0 aener(2,4)=8.26569 aphot(2,4)=0 aener(3,4)=10.3321 aphot(3,4)=0 aener(4,4)=12.3985 aphot(4,4)=0 aener(5,4)=15.4982 aphot(5,4)=60 aener(6,4)=20.6642 aphot(6,4)=7.2 aener(7,4)=30.9964 aphot(7,4)=1.75 aener(8,4)=41.3285 aphot(8,4)=1.05 aener(9,4)=61.9927 aphot(9,4)=0.75 aener(10,4)=82.6569 aphot(10,4)=0.7 endif if(zato.eq.54)then qash=6 athreshold(1)=0.041328 aweight(1)=0.017971 qaener(1)=3 aener(1,1)=30996.4 aphot(1,1)=0.0013 aener(2,1)=41328.5 aphot(2,1)=0.0046 aener(3,1)=61992.7 aphot(3,1)=0.0015 athreshold(2)=0.006199 aweight(2)=0.114379 qaener(2)=7 aener(1,2)=4132.85 aphot(1,2)=0.071 aener(2,2)=6199.27 aphot(2,2)=0.11 aener(3,2)=8265.69 aphot(3,2)=0.051 aener(4,2)=12398.5 aphot(4,2)=0.017 aener(5,2)=15498.2 aphot(5,2)=0.009 aener(6,2)=20664.2 aphot(6,2)=0.004 aener(7,2)=30996.4 aphot(7,2)=0.0013 athreshold(3)=0.000827 aweight(3)=0.411049 qaener(3)=8 aener(1,3)=619.927 aphot(1,3)=0.63 aener(2,3)=826.569 aphot(2,3)=2.3 aener(3,3)=1033.21 aphot(3,3)=1.8 aener(4,3)=1239.85 aphot(4,3)=1.37 aener(5,3)=1549.82 aphot(5,3)=0.86 aener(6,3)=2066.42 aphot(6,3)=0.42 aener(7,3)=3099.64 aphot(7,3)=0.15 aener(8,3)=4132.85 aphot(8,3)=0.071 athreshold(4)=0.00031 aweight(4)=0.075061 qaener(4)=4 aener(1,4)=206.642 aphot(1,4)=1 aener(2,4)=309.964 aphot(2,4)=1.15 aener(3,4)=413.285 aphot(3,4)=1 aener(4,4)=619.927 aphot(4,4)=0.63 athreshold(5)=8.26569e-05 aweight(5)=0.273675 qaener(5)=6 aener(1,5)=61.9927 aphot(1,5)=0.67 aener(2,5)=82.6569 aphot(2,5)=48 aener(3,5)=103.321 aphot(3,5)=14 aener(4,5)=123.985 aphot(4,5)=2.5 aener(5,5)=154.982 aphot(5,5)=1.1 aener(6,5)=206.642 aphot(6,5)=1 athreshold(6)=1.23985e-05 aweight(6)=0.107866 qaener(6)=9 aener(1,6)=6.19927 aphot(1,6)=0 aener(2,6)=8.26569 aphot(2,6)=0 aener(3,6)=10.3321 aphot(3,6)=0 aener(4,6)=12.3985 aphot(4,6)=110 aener(5,6)=15.4982 aphot(5,6)=37 aener(6,6)=20.6642 aphot(6,6)=10 aener(7,6)=30.9964 aphot(7,6)=2.2 aener(8,6)=41.3285 aphot(8,6)=1.1 aener(9,6)=61.9927 aphot(9,6)=0.67 endif c end of computer code do k1=1,qash do l=1,qaener(k1) aener(l,k1)=aener(l,k1)*1.e-6 enddo enddo if(soo.eq.1)then if(qash.eq.0)then write(oo,*)' Worning of shellfi: atom z=',zato,' is not found.' write(oo,*) + ' The data will be seached by shteor, accuracy will be lower.' endif endif c call prishellfi end subroutine shteor(num) c read shteor.dat implicit none c include 'shellfi.inc' +SEQ,shellfi. c include 'LibAtMat.inc' +SEQ,LibAtMat. integer num c character*1 a c integer i,z,n,k qash=0 c The next code is generated c by a computer program c using a readable data file if(zato.eq.1)then c if(num.eq.num_H)then qash=1 athreshold(1)=1e-05 aweight(1)=1 c endif if(num.eq.num_H3)then ! for CH4 qash=1 athreshold(1)=15.2e-06 aweight(1)=1 endif endif if(zato.eq.2)then qash=1 athreshold(1)=1.36129e-05 aweight(1)=1 endif if(zato.eq.3)then qash=2 athreshold(1)=5.44515e-05 aweight(1)=0.666667 athreshold(2)=1e-05 aweight(2)=0.333333 endif if(zato.eq.4)then qash=2 athreshold(1)=0.000123 aweight(1)=0.5 athreshold(2)=1e-05 aweight(2)=0.5 endif if(zato.eq.5)then qash=2 athreshold(1)=0.000218 aweight(1)=0.4 athreshold(2)=1e-05 aweight(2)=0.6 endif if(zato.eq.6)then qash=2 athreshold(1)=0.00034 aweight(1)=0.333333 athreshold(2)=1.36129e-05 aweight(2)=0.666667 endif if(zato.eq.7)then qash=2 athreshold(1)=0.00049 aweight(1)=0.285714 athreshold(2)=2.12701e-05 aweight(2)=0.714286 endif if(zato.eq.8)then qash=2 athreshold(1)=0.000667 aweight(1)=0.25 athreshold(2)=3.0629e-05 aweight(2)=0.75 endif if(zato.eq.9)then qash=2 athreshold(1)=0.000871 aweight(1)=0.222222 athreshold(2)=4.16894e-05 aweight(2)=0.777778 endif if(zato.eq.10)then qash=2 athreshold(1)=0.001103 aweight(1)=0.2 athreshold(2)=5.44515e-05 aweight(2)=0.8 endif if(zato.eq.11)then qash=3 athreshold(1)=0.001361 aweight(1)=0.181818 athreshold(2)=8.50804e-05 aweight(2)=0.727273 athreshold(3)=1e-05 aweight(3)=0.090909 endif if(zato.eq.12)then qash=3 athreshold(1)=0.001647 aweight(1)=0.166667 athreshold(2)=0.000123 aweight(2)=0.666667 athreshold(3)=1e-05 aweight(3)=0.166667 endif if(zato.eq.13)then qash=3 athreshold(1)=0.00196 aweight(1)=0.153846 athreshold(2)=0.000167 aweight(2)=0.615385 athreshold(3)=1e-05 aweight(3)=0.230769 endif if(zato.eq.14)then qash=3 athreshold(1)=0.002301 aweight(1)=0.142857 athreshold(2)=0.000218 aweight(2)=0.571429 athreshold(3)=1e-05 aweight(3)=0.285714 endif if(zato.eq.15)then qash=3 athreshold(1)=0.002668 aweight(1)=0.133333 athreshold(2)=0.000276 aweight(2)=0.533333 athreshold(3)=1e-05 aweight(3)=0.333333 endif if(zato.eq.16)then qash=3 athreshold(1)=0.003063 aweight(1)=0.125 athreshold(2)=0.00034 aweight(2)=0.5 athreshold(3)=1.36129e-05 aweight(3)=0.375 endif if(zato.eq.17)then qash=3 athreshold(1)=0.003485 aweight(1)=0.117647 athreshold(2)=0.000412 aweight(2)=0.470588 athreshold(3)=1.85286e-05 aweight(3)=0.411765 endif if(zato.eq.18)then qash=3 athreshold(1)=0.003934 aweight(1)=0.111111 athreshold(2)=0.00049 aweight(2)=0.444444 athreshold(3)=2.42007e-05 aweight(3)=0.444444 endif if(zato.eq.19)then qash=4 athreshold(1)=0.004411 aweight(1)=0.105263 athreshold(2)=0.000575 aweight(2)=0.421053 athreshold(3)=3.78135e-05 aweight(3)=0.421053 athreshold(4)=1e-05 aweight(4)=0.052632 endif if(zato.eq.20)then qash=4 athreshold(1)=0.004914 aweight(1)=0.1 athreshold(2)=0.000667 aweight(2)=0.4 athreshold(3)=5.44515e-05 aweight(3)=0.4 athreshold(4)=1e-05 aweight(4)=0.1 endif if(zato.eq.21)then qash=4 athreshold(1)=0.005445 aweight(1)=0.095238 athreshold(2)=0.000766 aweight(2)=0.380952 athreshold(3)=7.41145e-05 aweight(3)=0.380952 athreshold(4)=1e-05 aweight(4)=0.142857 endif if(zato.eq.22)then qash=4 athreshold(1)=0.006003 aweight(1)=0.090909 athreshold(2)=0.000871 aweight(2)=0.363636 athreshold(3)=9.68026e-05 aweight(3)=0.363636 athreshold(4)=1e-05 aweight(4)=0.181818 endif if(zato.eq.23)then qash=4 athreshold(1)=0.006589 aweight(1)=0.086957 athreshold(2)=0.000984 aweight(2)=0.347826 athreshold(3)=0.000123 aweight(3)=0.347826 athreshold(4)=1e-05 aweight(4)=0.217391 endif if(zato.eq.24)then qash=4 athreshold(1)=0.007201 aweight(1)=0.083333 athreshold(2)=0.001103 aweight(2)=0.333333 athreshold(3)=0.000151 aweight(3)=0.333333 athreshold(4)=1e-05 aweight(4)=0.25 endif if(zato.eq.25)then qash=4 athreshold(1)=0.007841 aweight(1)=0.08 athreshold(2)=0.001229 aweight(2)=0.32 athreshold(3)=0.000183 aweight(3)=0.32 athreshold(4)=1.04224e-05 aweight(4)=0.28 endif if(zato.eq.26)then qash=4 athreshold(1)=0.008508 aweight(1)=0.076923 athreshold(2)=0.001361 aweight(2)=0.307692 athreshold(3)=0.000218 aweight(3)=0.307692 athreshold(4)=1.36129e-05 aweight(4)=0.307692 endif if(zato.eq.27)then qash=4 athreshold(1)=0.009202 aweight(1)=0.074074 athreshold(2)=0.001501 aweight(2)=0.296296 athreshold(3)=0.000256 aweight(3)=0.296296 athreshold(4)=1.72288e-05 aweight(4)=0.333333 endif if(zato.eq.28)then qash=4 athreshold(1)=0.009924 aweight(1)=0.071429 athreshold(2)=0.001647 aweight(2)=0.285714 athreshold(3)=0.000296 aweight(3)=0.285714 athreshold(4)=2.12701e-05 aweight(4)=0.357143 endif if(zato.eq.29)then qash=4 athreshold(1)=0.010672 aweight(1)=0.068966 athreshold(2)=0.0018 aweight(2)=0.275862 athreshold(3)=0.00034 aweight(3)=0.275862 athreshold(4)=2.57368e-05 aweight(4)=0.37931 endif if(zato.eq.30)then qash=4 athreshold(1)=0.011448 aweight(1)=0.066667 athreshold(2)=0.00196 aweight(2)=0.266667 athreshold(3)=0.000387 aweight(3)=0.266667 athreshold(4)=3.0629e-05 aweight(4)=0.4 endif if(zato.eq.31)then qash=4 athreshold(1)=0.012252 aweight(1)=0.064516 athreshold(2)=0.002127 aweight(2)=0.258065 athreshold(3)=0.000437 aweight(3)=0.258065 athreshold(4)=3.59465e-05 aweight(4)=0.419355 endif if(zato.eq.32)then qash=4 athreshold(1)=0.013082 aweight(1)=0.0625 athreshold(2)=0.002301 aweight(2)=0.25 athreshold(3)=0.00049 aweight(3)=0.25 athreshold(4)=4.16894e-05 aweight(4)=0.4375 endif if(zato.eq.33)then qash=4 athreshold(1)=0.01394 aweight(1)=0.060606 athreshold(2)=0.002481 aweight(2)=0.242424 athreshold(3)=0.000546 aweight(3)=0.242424 athreshold(4)=4.78577e-05 aweight(4)=0.454545 endif if(zato.eq.34)then qash=4 athreshold(1)=0.014824 aweight(1)=0.058824 athreshold(2)=0.002668 aweight(2)=0.235294 athreshold(3)=0.000605 aweight(3)=0.235294 athreshold(4)=5.44515e-05 aweight(4)=0.470588 endif if(zato.eq.35)then qash=4 athreshold(1)=0.015736 aweight(1)=0.057143 athreshold(2)=0.002862 aweight(2)=0.228571 athreshold(3)=0.000667 aweight(3)=0.228571 athreshold(4)=6.14706e-05 aweight(4)=0.485714 endif if(zato.eq.36)then qash=4 athreshold(1)=0.016676 aweight(1)=0.055556 athreshold(2)=0.003063 aweight(2)=0.222222 athreshold(3)=0.000732 aweight(3)=0.222222 athreshold(4)=6.89152e-05 aweight(4)=0.5 endif if(zato.eq.37)then qash=5 athreshold(1)=0.017642 aweight(1)=0.054054 athreshold(2)=0.00327 aweight(2)=0.216216 athreshold(3)=0.0008 aweight(3)=0.216216 athreshold(4)=8.50804e-05 aweight(4)=0.486486 athreshold(5)=1e-05 aweight(5)=0.027027 endif if(zato.eq.38)then qash=5 athreshold(1)=0.018636 aweight(1)=0.052632 athreshold(2)=0.003485 aweight(2)=0.210526 athreshold(3)=0.000871 aweight(3)=0.210526 athreshold(4)=0.000103 aweight(4)=0.473684 athreshold(5)=1e-05 aweight(5)=0.052632 endif if(zato.eq.39)then qash=5 athreshold(1)=0.019657 aweight(1)=0.051282 athreshold(2)=0.003706 aweight(2)=0.205128 athreshold(3)=0.000945 aweight(3)=0.205128 athreshold(4)=0.000123 aweight(4)=0.461538 athreshold(5)=1e-05 aweight(5)=0.076923 endif if(zato.eq.40)then qash=5 athreshold(1)=0.020705 aweight(1)=0.05 athreshold(2)=0.003934 aweight(2)=0.2 athreshold(3)=0.001022 aweight(3)=0.2 athreshold(4)=0.000144 aweight(4)=0.45 athreshold(5)=1e-05 aweight(5)=0.1 endif if(zato.eq.41)then qash=5 athreshold(1)=0.021781 aweight(1)=0.04878 athreshold(2)=0.004169 aweight(2)=0.195122 athreshold(3)=0.001103 aweight(3)=0.195122 athreshold(4)=0.000167 aweight(4)=0.439024 athreshold(5)=1e-05 aweight(5)=0.121951 endif if(zato.eq.42)then qash=5 athreshold(1)=0.022883 aweight(1)=0.047619 athreshold(2)=0.004411 aweight(2)=0.190476 athreshold(3)=0.001186 aweight(3)=0.190476 athreshold(4)=0.000191 aweight(4)=0.428571 athreshold(5)=1e-05 aweight(5)=0.142857 endif if(zato.eq.43)then qash=5 athreshold(1)=0.024013 aweight(1)=0.046512 athreshold(2)=0.004659 aweight(2)=0.186047 athreshold(3)=0.001272 aweight(3)=0.186047 athreshold(4)=0.000218 aweight(4)=0.418605 athreshold(5)=1e-05 aweight(5)=0.162791 endif if(zato.eq.44)then qash=5 athreshold(1)=0.02517 aweight(1)=0.045455 athreshold(2)=0.004914 aweight(2)=0.181818 athreshold(3)=0.001361 aweight(3)=0.181818 athreshold(4)=0.000246 aweight(4)=0.409091 athreshold(5)=1e-05 aweight(5)=0.181818 endif if(zato.eq.45)then qash=5 athreshold(1)=0.026355 aweight(1)=0.044444 athreshold(2)=0.005176 aweight(2)=0.177778 athreshold(3)=0.001454 aweight(3)=0.177778 athreshold(4)=0.000276 aweight(4)=0.4 athreshold(5)=1.10264e-05 aweight(5)=0.2 endif if(zato.eq.46)then qash=5 athreshold(1)=0.027566 aweight(1)=0.043478 athreshold(2)=0.005445 aweight(2)=0.173913 athreshold(3)=0.001549 aweight(3)=0.173913 athreshold(4)=0.000307 aweight(4)=0.391304 athreshold(5)=1.36129e-05 aweight(5)=0.217391 endif if(zato.eq.47)then qash=5 athreshold(1)=0.028805 aweight(1)=0.042553 athreshold(2)=0.005721 aweight(2)=0.170213 athreshold(3)=0.001647 aweight(3)=0.170213 athreshold(4)=0.00034 aweight(4)=0.382979 athreshold(5)=1.64716e-05 aweight(5)=0.234043 endif if(zato.eq.48)then qash=5 athreshold(1)=0.030071 aweight(1)=0.041667 athreshold(2)=0.006003 aweight(2)=0.166667 athreshold(3)=0.001748 aweight(3)=0.166667 athreshold(4)=0.000375 aweight(4)=0.375 athreshold(5)=1.96025e-05 aweight(5)=0.25 endif if(zato.eq.49)then qash=5 athreshold(1)=0.031364 aweight(1)=0.040816 athreshold(2)=0.006293 aweight(2)=0.163265 athreshold(3)=0.001853 aweight(3)=0.163265 athreshold(4)=0.000412 aweight(4)=0.367347 athreshold(5)=2.30058e-05 aweight(5)=0.265306 endif if(zato.eq.50)then qash=5 athreshold(1)=0.032685 aweight(1)=0.04 athreshold(2)=0.006589 aweight(2)=0.16 athreshold(3)=0.00196 aweight(3)=0.16 athreshold(4)=0.00045 aweight(4)=0.36 athreshold(5)=2.66812e-05 aweight(5)=0.28 endif if(zato.eq.51)then qash=5 athreshold(1)=0.034032 aweight(1)=0.039216 athreshold(2)=0.006892 aweight(2)=0.156863 athreshold(3)=0.002071 aweight(3)=0.156863 athreshold(4)=0.00049 aweight(4)=0.352941 athreshold(5)=3.0629e-05 aweight(5)=0.294118 endif if(zato.eq.52)then qash=5 athreshold(1)=0.035407 aweight(1)=0.038462 athreshold(2)=0.007201 aweight(2)=0.153846 athreshold(3)=0.002184 aweight(3)=0.153846 athreshold(4)=0.000532 aweight(4)=0.346154 athreshold(5)=3.48489e-05 aweight(5)=0.307692 endif if(zato.eq.53)then qash=5 athreshold(1)=0.036809 aweight(1)=0.037736 athreshold(2)=0.007518 aweight(2)=0.150943 athreshold(3)=0.002301 aweight(3)=0.150943 athreshold(4)=0.000575 aweight(4)=0.339623 athreshold(5)=3.93412e-05 aweight(5)=0.320755 endif if(zato.eq.54)then qash=5 athreshold(1)=0.038239 aweight(1)=0.037037 athreshold(2)=0.007841 aweight(2)=0.148148 athreshold(3)=0.00242 aweight(3)=0.148148 athreshold(4)=0.00062 aweight(4)=0.333333 athreshold(5)=4.41057e-05 aweight(5)=0.333333 endif if(zato.eq.55)then qash=5 athreshold(1)=0.039695 aweight(1)=0.036364 athreshold(2)=0.008171 aweight(2)=0.145455 athreshold(3)=0.002543 aweight(3)=0.145455 athreshold(4)=0.000667 aweight(4)=0.327273 athreshold(5)=4.91425e-05 aweight(5)=0.345455 endif if(zato.eq.56)then qash=5 athreshold(1)=0.041179 aweight(1)=0.035714 athreshold(2)=0.008508 aweight(2)=0.142857 athreshold(3)=0.002668 aweight(3)=0.142857 athreshold(4)=0.000716 aweight(4)=0.321429 athreshold(5)=5.44515e-05 aweight(5)=0.357143 endif if(zato.eq.57)then qash=5 athreshold(1)=0.04269 aweight(1)=0.035088 athreshold(2)=0.008852 aweight(2)=0.140351 athreshold(3)=0.002797 aweight(3)=0.140351 athreshold(4)=0.000766 aweight(4)=0.315789 athreshold(5)=6.00328e-05 aweight(5)=0.368421 endif if(zato.eq.58)then qash=5 athreshold(1)=0.044228 aweight(1)=0.034483 athreshold(2)=0.009202 aweight(2)=0.137931 athreshold(3)=0.002928 aweight(3)=0.137931 athreshold(4)=0.000818 aweight(4)=0.310345 athreshold(5)=6.58863e-05 aweight(5)=0.37931 endif if(zato.eq.59)then qash=6 athreshold(1)=0.045794 aweight(1)=0.033898 athreshold(2)=0.00956 aweight(2)=0.135593 athreshold(3)=0.003063 aweight(3)=0.135593 athreshold(4)=0.000871 aweight(4)=0.305085 athreshold(5)=7.84101e-05 aweight(5)=0.372881 athreshold(6)=1e-05 aweight(6)=0.016949 endif if(zato.eq.60)then qash=6 athreshold(1)=0.047386 aweight(1)=0.033333 athreshold(2)=0.009924 aweight(2)=0.133333 athreshold(3)=0.003201 aweight(3)=0.133333 athreshold(4)=0.000927 aweight(4)=0.3 athreshold(5)=9.2023e-05 aweight(5)=0.366667 athreshold(6)=1e-05 aweight(6)=0.033333 endif if(zato.eq.61)then qash=6 athreshold(1)=0.049006 aweight(1)=0.032787 athreshold(2)=0.010295 aweight(2)=0.131148 athreshold(3)=0.003341 aweight(3)=0.131148 athreshold(4)=0.000984 aweight(4)=0.295082 athreshold(5)=0.000107 aweight(5)=0.360656 athreshold(6)=1e-05 aweight(6)=0.04918 endif if(zato.eq.62)then qash=6 athreshold(1)=0.050653 aweight(1)=0.032258 athreshold(2)=0.010672 aweight(2)=0.129032 athreshold(3)=0.003485 aweight(3)=0.129032 athreshold(4)=0.001042 aweight(4)=0.290323 athreshold(5)=0.000123 aweight(5)=0.354839 athreshold(6)=1e-05 aweight(6)=0.064516 endif if(zato.eq.63)then qash=6 athreshold(1)=0.052328 aweight(1)=0.031746 athreshold(2)=0.011057 aweight(2)=0.126984 athreshold(3)=0.003632 aweight(3)=0.126984 athreshold(4)=0.001103 aweight(4)=0.285714 athreshold(5)=0.000139 aweight(5)=0.349206 athreshold(6)=1e-05 aweight(6)=0.079365 endif if(zato.eq.64)then qash=6 athreshold(1)=0.054029 aweight(1)=0.03125 athreshold(2)=0.011448 aweight(2)=0.125 athreshold(3)=0.003781 aweight(3)=0.125 athreshold(4)=0.001165 aweight(4)=0.28125 athreshold(5)=0.000157 aweight(5)=0.34375 athreshold(6)=1e-05 aweight(6)=0.09375 endif if(zato.eq.65)then qash=6 athreshold(1)=0.055758 aweight(1)=0.030769 athreshold(2)=0.011847 aweight(2)=0.123077 athreshold(3)=0.003934 aweight(3)=0.123077 athreshold(4)=0.001229 aweight(4)=0.276923 athreshold(5)=0.000176 aweight(5)=0.338462 athreshold(6)=1e-05 aweight(6)=0.107692 endif if(zato.eq.66)then qash=6 athreshold(1)=0.057514 aweight(1)=0.030303 athreshold(2)=0.012252 aweight(2)=0.121212 athreshold(3)=0.00409 aweight(3)=0.121212 athreshold(4)=0.001294 aweight(4)=0.272727 athreshold(5)=0.000197 aweight(5)=0.333333 athreshold(6)=1e-05 aweight(6)=0.121212 endif if(zato.eq.67)then qash=6 athreshold(1)=0.059298 aweight(1)=0.029851 athreshold(2)=0.012663 aweight(2)=0.119403 athreshold(3)=0.004249 aweight(3)=0.119403 athreshold(4)=0.001361 aweight(4)=0.268657 athreshold(5)=0.000218 aweight(5)=0.328358 athreshold(6)=1e-05 aweight(6)=0.134328 endif if(zato.eq.68)then qash=6 athreshold(1)=0.061108 aweight(1)=0.029412 athreshold(2)=0.013082 aweight(2)=0.117647 athreshold(3)=0.004411 aweight(3)=0.117647 athreshold(4)=0.00143 aweight(4)=0.264706 athreshold(5)=0.00024 aweight(5)=0.323529 athreshold(6)=1e-05 aweight(6)=0.147059 endif if(zato.eq.69)then qash=6 athreshold(1)=0.062946 aweight(1)=0.028986 athreshold(2)=0.013507 aweight(2)=0.115942 athreshold(3)=0.004575 aweight(3)=0.115942 athreshold(4)=0.001501 aweight(4)=0.26087 athreshold(5)=0.000264 aweight(5)=0.318841 athreshold(6)=1.14386e-05 aweight(6)=0.15942 endif if(zato.eq.70)then qash=6 athreshold(1)=0.064811 aweight(1)=0.028571 athreshold(2)=0.01394 aweight(2)=0.114286 athreshold(3)=0.004743 aweight(3)=0.114286 athreshold(4)=0.001573 aweight(4)=0.257143 athreshold(5)=0.000288 aweight(5)=0.314286 athreshold(6)=1.36129e-05 aweight(6)=0.171429 endif if(zato.eq.71)then qash=6 athreshold(1)=0.066703 aweight(1)=0.028169 athreshold(2)=0.014379 aweight(2)=0.112676 athreshold(3)=0.004914 aweight(3)=0.112676 athreshold(4)=0.001647 aweight(4)=0.253521 athreshold(5)=0.000314 aweight(5)=0.309859 athreshold(6)=1.59762e-05 aweight(6)=0.183099 endif if(zato.eq.72)then qash=6 athreshold(1)=0.068622 aweight(1)=0.027778 athreshold(2)=0.014824 aweight(2)=0.111111 athreshold(3)=0.005088 aweight(3)=0.111111 athreshold(4)=0.001723 aweight(4)=0.25 athreshold(5)=0.00034 aweight(5)=0.305556 athreshold(6)=1.85286e-05 aweight(6)=0.194444 endif if(zato.eq.73)then qash=6 athreshold(1)=0.070569 aweight(1)=0.027397 athreshold(2)=0.015277 aweight(2)=0.109589 athreshold(3)=0.005265 aweight(3)=0.109589 athreshold(4)=0.0018 aweight(4)=0.246575 athreshold(5)=0.000368 aweight(5)=0.30137 athreshold(6)=2.12701e-05 aweight(6)=0.205479 endif if(zato.eq.74)then qash=6 athreshold(1)=0.072543 aweight(1)=0.027027 athreshold(2)=0.015736 aweight(2)=0.108108 athreshold(3)=0.005445 aweight(3)=0.108108 athreshold(4)=0.001879 aweight(4)=0.243243 athreshold(5)=0.000397 aweight(5)=0.297297 athreshold(6)=2.42007e-05 aweight(6)=0.216216 endif if(zato.eq.75)then qash=6 athreshold(1)=0.074544 aweight(1)=0.026667 athreshold(2)=0.016203 aweight(2)=0.106667 athreshold(3)=0.005628 aweight(3)=0.106667 athreshold(4)=0.00196 aweight(4)=0.24 athreshold(5)=0.000427 aweight(5)=0.293333 athreshold(6)=2.73203e-05 aweight(6)=0.226667 endif if(zato.eq.76)then qash=6 athreshold(1)=0.076572 aweight(1)=0.026316 athreshold(2)=0.016676 aweight(2)=0.105263 athreshold(3)=0.005814 aweight(3)=0.105263 athreshold(4)=0.002043 aweight(4)=0.236842 athreshold(5)=0.000458 aweight(5)=0.289474 athreshold(6)=3.0629e-05 aweight(6)=0.236842 endif if(zato.eq.77)then qash=6 athreshold(1)=0.078628 aweight(1)=0.025974 athreshold(2)=0.017156 aweight(2)=0.103896 athreshold(3)=0.006003 aweight(3)=0.103896 athreshold(4)=0.002127 aweight(4)=0.233766 athreshold(5)=0.00049 aweight(5)=0.285714 athreshold(6)=3.41267e-05 aweight(6)=0.246753 endif if(zato.eq.78)then qash=6 athreshold(1)=0.080711 aweight(1)=0.025641 athreshold(2)=0.017642 aweight(2)=0.102564 athreshold(3)=0.006195 aweight(3)=0.102564 athreshold(4)=0.002213 aweight(4)=0.230769 athreshold(5)=0.000523 aweight(5)=0.282051 athreshold(6)=3.78135e-05 aweight(6)=0.25641 endif if(zato.eq.79)then qash=6 athreshold(1)=0.082821 aweight(1)=0.025316 athreshold(2)=0.018136 aweight(2)=0.101266 athreshold(3)=0.00639 aweight(3)=0.101266 athreshold(4)=0.002301 aweight(4)=0.227848 athreshold(5)=0.000558 aweight(5)=0.278481 athreshold(6)=4.16894e-05 aweight(6)=0.265823 endif if(zato.eq.80)then qash=6 athreshold(1)=0.084958 aweight(1)=0.025 athreshold(2)=0.018636 aweight(2)=0.1 athreshold(3)=0.006589 aweight(3)=0.1 athreshold(4)=0.00239 aweight(4)=0.225 athreshold(5)=0.000593 aweight(5)=0.275 athreshold(6)=4.57544e-05 aweight(6)=0.275 endif if(zato.eq.81)then qash=6 athreshold(1)=0.087122 aweight(1)=0.024691 athreshold(2)=0.019143 aweight(2)=0.098765 athreshold(3)=0.00679 aweight(3)=0.098765 athreshold(4)=0.002481 aweight(4)=0.222222 athreshold(5)=0.000629 aweight(5)=0.271605 athreshold(6)=5.00084e-05 aweight(6)=0.283951 endif if(zato.eq.82)then qash=6 athreshold(1)=0.089314 aweight(1)=0.02439 athreshold(2)=0.019657 aweight(2)=0.097561 athreshold(3)=0.006994 aweight(3)=0.097561 athreshold(4)=0.002574 aweight(4)=0.219512 athreshold(5)=0.000667 aweight(5)=0.268293 athreshold(6)=5.44515e-05 aweight(6)=0.292683 endif if(zato.eq.83)then qash=6 athreshold(1)=0.091533 aweight(1)=0.024096 athreshold(2)=0.020178 aweight(2)=0.096386 athreshold(3)=0.007201 aweight(3)=0.096386 athreshold(4)=0.002668 aweight(4)=0.216867 athreshold(5)=0.000706 aweight(5)=0.26506 athreshold(6)=5.90836e-05 aweight(6)=0.301205 endif if(zato.eq.84)then qash=6 athreshold(1)=0.093779 aweight(1)=0.02381 athreshold(2)=0.020705 aweight(2)=0.095238 athreshold(3)=0.007411 aweight(3)=0.095238 athreshold(4)=0.002764 aweight(4)=0.214286 athreshold(5)=0.000745 aweight(5)=0.261905 athreshold(6)=6.39049e-05 aweight(6)=0.309524 endif if(zato.eq.85)then qash=6 athreshold(1)=0.096052 aweight(1)=0.023529 athreshold(2)=0.021239 aweight(2)=0.094118 athreshold(3)=0.007625 aweight(3)=0.094118 athreshold(4)=0.002862 aweight(4)=0.211765 athreshold(5)=0.000786 aweight(5)=0.258824 athreshold(6)=6.89152e-05 aweight(6)=0.317647 endif if(zato.eq.86)then qash=6 athreshold(1)=0.098353 aweight(1)=0.023256 athreshold(2)=0.021781 aweight(2)=0.093023 athreshold(3)=0.007841 aweight(3)=0.093023 athreshold(4)=0.002962 aweight(4)=0.209302 athreshold(5)=0.000828 aweight(5)=0.255814 athreshold(6)=7.41145e-05 aweight(6)=0.325581 endif if(zato.eq.87)then qash=6 athreshold(1)=0.100681 aweight(1)=0.022989 athreshold(2)=0.022329 aweight(2)=0.091954 athreshold(3)=0.00806 aweight(3)=0.091954 athreshold(4)=0.003063 aweight(4)=0.206897 athreshold(5)=0.000871 aweight(5)=0.252874 athreshold(6)=7.9503e-05 aweight(6)=0.333333 endif if(zato.eq.88)then qash=6 athreshold(1)=0.103036 aweight(1)=0.022727 athreshold(2)=0.022883 aweight(2)=0.090909 athreshold(3)=0.008283 aweight(3)=0.090909 athreshold(4)=0.003166 aweight(4)=0.204545 athreshold(5)=0.000915 aweight(5)=0.25 athreshold(6)=8.50804e-05 aweight(6)=0.340909 endif if(zato.eq.89)then qash=6 athreshold(1)=0.105418 aweight(1)=0.022472 athreshold(2)=0.023445 aweight(2)=0.089888 athreshold(3)=0.008508 aweight(3)=0.089888 athreshold(4)=0.00327 aweight(4)=0.202247 athreshold(5)=0.000961 aweight(5)=0.247191 athreshold(6)=9.0847e-05 aweight(6)=0.348315 endif if(zato.eq.90)then qash=6 athreshold(1)=0.107828 aweight(1)=0.022222 athreshold(2)=0.024013 aweight(2)=0.088889 athreshold(3)=0.008736 aweight(3)=0.088889 athreshold(4)=0.003377 aweight(4)=0.2 athreshold(5)=0.001007 aweight(5)=0.244444 athreshold(6)=9.68026e-05 aweight(6)=0.355556 endif if(zato.eq.91)then qash=7 athreshold(1)=0.110264 aweight(1)=0.021978 athreshold(2)=0.024588 aweight(2)=0.087912 athreshold(3)=0.008968 aweight(3)=0.087912 athreshold(4)=0.003485 aweight(4)=0.197802 athreshold(5)=0.001054 aweight(5)=0.241758 athreshold(6)=0.000109 aweight(6)=0.351648 athreshold(7)=1e-05 aweight(7)=0.010989 endif if(zato.eq.92)then qash=7 athreshold(1)=0.112728 aweight(1)=0.021739 athreshold(2)=0.02517 aweight(2)=0.086957 athreshold(3)=0.009202 aweight(3)=0.086957 athreshold(4)=0.003595 aweight(4)=0.195652 athreshold(5)=0.001103 aweight(5)=0.23913 athreshold(6)=0.000123 aweight(6)=0.347826 athreshold(7)=1e-05 aweight(7)=0.021739 endif if(zato.eq.93)then qash=7 athreshold(1)=0.115219 aweight(1)=0.021505 athreshold(2)=0.025759 aweight(2)=0.086022 athreshold(3)=0.00944 aweight(3)=0.086022 athreshold(4)=0.003706 aweight(4)=0.193548 athreshold(5)=0.001152 aweight(5)=0.236559 athreshold(6)=0.000137 aweight(6)=0.344086 athreshold(7)=1e-05 aweight(7)=0.032258 endif if(zato.eq.94)then qash=7 athreshold(1)=0.117738 aweight(1)=0.021277 athreshold(2)=0.026355 aweight(2)=0.085106 athreshold(3)=0.00968 aweight(3)=0.085106 athreshold(4)=0.003819 aweight(4)=0.191489 athreshold(5)=0.001203 aweight(5)=0.234043 athreshold(6)=0.000151 aweight(6)=0.340426 athreshold(7)=1e-05 aweight(7)=0.042553 endif if(zato.eq.95)then qash=7 athreshold(1)=0.120283 aweight(1)=0.021053 athreshold(2)=0.026957 aweight(2)=0.084211 athreshold(3)=0.009924 aweight(3)=0.084211 athreshold(4)=0.003934 aweight(4)=0.189474 athreshold(5)=0.001255 aweight(5)=0.231579 athreshold(6)=0.000167 aweight(6)=0.336842 athreshold(7)=1e-05 aweight(7)=0.052632 endif if(zato.eq.96)then qash=7 athreshold(1)=0.122856 aweight(1)=0.020833 athreshold(2)=0.027566 aweight(2)=0.083333 athreshold(3)=0.01017 aweight(3)=0.083333 athreshold(4)=0.004051 aweight(4)=0.1875 athreshold(5)=0.001307 aweight(5)=0.229167 athreshold(6)=0.000183 aweight(6)=0.333333 athreshold(7)=1e-05 aweight(7)=0.0625 endif if(zato.eq.97)then qash=7 athreshold(1)=0.125456 aweight(1)=0.020619 athreshold(2)=0.028182 aweight(2)=0.082474 athreshold(3)=0.01042 aweight(3)=0.082474 athreshold(4)=0.004169 aweight(4)=0.185567 athreshold(5)=0.001361 aweight(5)=0.226804 athreshold(6)=0.0002 aweight(6)=0.329897 athreshold(7)=1e-05 aweight(7)=0.072165 endif if(zato.eq.98)then qash=7 athreshold(1)=0.128084 aweight(1)=0.020408 athreshold(2)=0.028805 aweight(2)=0.081633 athreshold(3)=0.010672 aweight(3)=0.081633 athreshold(4)=0.004289 aweight(4)=0.183673 athreshold(5)=0.001416 aweight(5)=0.22449 athreshold(6)=0.000218 aweight(6)=0.326531 athreshold(7)=1e-05 aweight(7)=0.081633 endif if(zato.eq.99)then qash=7 athreshold(1)=0.130738 aweight(1)=0.020202 athreshold(2)=0.029434 aweight(2)=0.080808 athreshold(3)=0.010928 aweight(3)=0.080808 athreshold(4)=0.004411 aweight(4)=0.181818 athreshold(5)=0.001472 aweight(5)=0.222222 athreshold(6)=0.000236 aweight(6)=0.323232 athreshold(7)=1e-05 aweight(7)=0.090909 endif if(zato.eq.100)then qash=7 athreshold(1)=0.13342 aweight(1)=0.02 athreshold(2)=0.030071 aweight(2)=0.08 athreshold(3)=0.011187 aweight(3)=0.08 athreshold(4)=0.004534 aweight(4)=0.18 athreshold(5)=0.00153 aweight(5)=0.22 athreshold(6)=0.000256 aweight(6)=0.32 athreshold(7)=1e-05 aweight(7)=0.1 endif c end of genetared code c call prishellfi end subroutine prishellfi implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'shellfi.inc' +SEQ,shellfi. integer i,j if(soo.eq.0)return write(oo,*) write(oo,*)' prishellfi:' write(oo,*)' zato=',zato,' qash=',qash do i=1,qash write(oo,*)' number of shell=',i write(oo,*)' aweight=',aweight(i),' athreshold=',athreshold(i), + ' qaener=',qaener(i) write(oo,*)' aener aphot' do j=1,qaener(i) write(oo,*)aener(j,i),aphot(j,i) enddo enddo end +DECK,line. c Package for integration and interpolation c of a function, defined by array. function glin_integ_ar(x,y,q,x1,x2,thresh) c c It makes the same work as lin_integ_ar c but at some conditions it interpolates no the line c but power function. c implicit none real glin_integ_ar real x(*),y(*),x1,x2,thresh integer q integer nr,nrr,n1,i real xt1,xt2 real xr1,xr2 real a,b real k,p real s s=0 glin_integ_ar=0.0 if(q.le.0)return if(x2.lt.x1 .or. x2.lt.x(1) .or. x1.gt.x(q))return if(x1.lt.x(1))then xt1=x(1) else xt1=x1 endif do i=2,q if(x(i).gt.xt1)then n1=i goto 10 endif enddo 10 continue nr=n1-1 if(x2.gt.x(q))then ! it is not necessary xt2=x(q) else xt2=x2 endif xr2=xt1 c write(6,*)' x1=',x1,' x2=',x2,' xt1=',xt1,' xt2=',xt2 c write(6,*)' n1=',n1,' n2=',n2,' n1=',n1,' nr=',nr do nrr=nr,q-1 if(x(nrr).gt.x2)go to 20 xr1=xr2 if(xt2.lt.x(nrr+1))then xr2=xt2 else xr2=x(nrr+1) endif if(x(nrr).gt.500.0e-6.and.x(nrr).gt.2*thresh.and. + y(nrr+1).lt.y(nrr).and.y(nrr+1).gt.0.0)then p=dlog(dble(y(nrr))/y(nrr+1))/ + dlog(dble(x(nrr+1))/x(nrr)) k=y(nrr)*x(nrr)**p s=s+ + k/(1-p)*(1.0/xr2**(p-1)-1.0/xr1**(p-1)) c write(6,*)' nrr=',nrr,' p=',p,' k=',k,' s=',s else a = (y(nrr+1) - y(nrr))/(x(nrr+1) - x(nrr)) b = y(nrr) s = s+ + 0.5*a*(xr2*xr2 - xr1*xr1) + (b - a*x(nrr))*(xr2 - xr1) endif c write(6,*)' nrr=',nrr c write(6,*)' y(nrr)=',y(nrr),' y(nrr+1)=',y(nrr+1) c write(6,*)' xr1=',xr1,' xr2=',xr2 c write(6,*)' x(nrr)=',x(nrr),' x(nrr+1)=',x(nrr+1) c write(6,*)' s=',s enddo 20 glin_integ_ar=s end function lin_integ_ar(x,y,q,x1,x2) implicit none real lin_integ_ar real x(*),y(*),x1,x2 integer q integer nr,nrr,n1,i real xt1,xt2 real xr1,xr2 real a,b real s s=0 lin_integ_ar=0.0 if(q.le.0)return if(x2.lt.x1 .or. x2.lt.x(1) .or. x1.gt.x(q))return if(x1.lt.x(1))then xt1=x(1) else xt1=x1 endif do i=2,q if(x(i).gt.xt1)then n1=i goto 10 endif enddo 10 continue nr=n1-1 if(x2.gt.x(q))then ! it is not necessary xt2=x(q) else xt2=x2 endif xr2=xt1 c write(6,*)' x1=',x1,' x2=',x2,' xt1=',xt1,' xt2=',xt2 c write(6,*)' n1=',n1,' n2=',n2,' n1=',n1,' nr=',nr do nrr=nr,q-1 if(x(nrr).gt.x2)go to 20 xr1=xr2 if(xt2.lt.x(nrr+1))then xr2=xt2 else xr2=x(nrr+1) endif a = (y(nrr+1) - y(nrr))/(x(nrr+1) - x(nrr)) b = y(nrr) s = s+ + 0.5*a*(xr2*xr2 - xr1*xr1) + (b - a*x(nrr))*(xr2 - xr1) c write(6,*)' nrr=',nrr c write(6,*)' y(nrr)=',y(nrr),' y(nrr+1)=',y(nrr+1) c write(6,*)' xr1=',xr1,' xr2=',xr2 c write(6,*)' x(nrr)=',x(nrr),' x(nrr+1)=',x(nrr+1) c write(6,*)' s=',s enddo 20 lin_integ_ar=s end function step_integ_ar(x,y,q,x1,x2) c c dimension of y must be q c dimension of x must be q+1 c the last point means the end of last interval. c implicit none real step_integ_ar real x(*),y(*),x1,x2 integer q integer nr,nrr,n1,i real xt1,xt2 real xr1,xr2 c real a,b real s s=0 step_integ_ar=0.0 c write(6,*)' step:',q,x1,x2,x(1),x(q+1) if(q.le.0)return if(x2.lt.x1 .or. x2.lt.x(1) .or. x1.gt.x(q+1))return if(x1.lt.x(1))then xt1=x(1) else xt1=x1 endif do i=2,q+1 if(x(i).gt.xt1)then n1=i goto 10 endif enddo 10 continue nr=n1-1 if(x2.gt.x(q+1))then ! it is not necessary xt2=x(q+1) else xt2=x2 endif xr2=xt1 do nrr=nr,q if(x(nrr).gt.x2)go to 20 xr1=xr2 if(xt2.lt.x(nrr+1))then xr2=xt2 else xr2=x(nrr+1) endif s = s+ y(nrr)*(xr2-xr1) c write(6,*)' nrr=',nrr,' xr=',xr1,xr2 c write(6,*)' y(nrr)=',y(nrr),' s=',s enddo 20 step_integ_ar=s end function interp_line_arr(x,y,q,tr,x0) c c special code c If x0 0 c If trx(q) exponential interp., if it go down c implicit none real interp_line_arr integer q ! quantity of elements real x(*) ! abscissa real y(*) ! ordin. real tr ! low treshold real x0 ! point integer n,n1,n2 real p,k real s if(x0.lt.tr)then interp_line_arr=0.0 return endif if(x0.gt.x(q))then if(y(q-1).le.y(q))then interp_line_arr=0.0 return endif p = alog(y(q-1)/y(q)) / alog(x(q-1)/x(q)) k = y(q) / (x(q)**p) s = k * (x0 ** p) interp_line_arr = s return endif do n=2,q if(x0.le.x(n))then n1=n-1 go to 10 endif enddo 10 n2=n1+1 k = (y(n2)-y(n1)) / (x(n2)-x(n1)) s = y(n1) + k * ( x0-x(n1)) interp_line_arr = s c write(6,*)' n1,n2=',n1,n2 c write(6,*)' x=',x(n1),x(n2) c write(6,*)' y=',y(n1),y(n2) c write(6,*)' k,s=',k,s c stop return end function interp_linep_arr(x,y,q,tr,x0) c c special code c If x0 0 c If trx(q) exponential interp., if it go down c If x(i+1).lt.x(i) then power line c implicit none real interp_linep_arr integer q ! quantity of elements real x(*) ! abscissa real y(*) ! ordin. real tr ! low treshold real x0 ! point integer n,n1,n2 real p,k real s if(x0.lt.tr)then interp_linep_arr=0.0 return endif if(x0.gt.x(q))then * if(y(q-1).le.y(q))then * interp_linep_arr=0.0 * return * endif * p = alog(y(q-1)/y(q)) / alog(x(q-1)/x(q)) p=-3.22 k = y(q) / (x(q)**p) s = k * (x0 ** p) interp_linep_arr = s return endif do n=2,q if(x0.le.x(n))then n1=n-1 go to 10 endif enddo 10 n2=n1+1 if(y(n2).ge.y(n1))then k = (y(n2)-y(n1)) / (x(n2)-x(n1)) s = y(n1) + k * ( x0-x(n1)) else p = alog(y(n1)/y(n2)) / alog(x(n1)/x(n2)) k = y(n1) / (x(n1)**p) s = k * (x0 ** p) endif interp_linep_arr = s c write(6,*)' n1,n2=',n1,n2 c write(6,*)' x=',x(n1),x(n2) c write(6,*)' y=',y(n1),y(n2) c write(6,*)' p,k,s=',p,k,s c stop return end +DECK,IniMatte. subroutine IniMatter(num,Atom,Weight,q,dens,pw,pf) c c Initialization of the Matter c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'cconst.inc' +SEQ,cconst. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. integer num,Atom(*),q real Weight(*),dens,pw,pf integer nat,nsh,nen,i,j real rms,rm(pQAt) real sw,ph,ph1 real E,E2,S,EE1,EE2,EP1,EP2 if(num.le.0.or.num.gt.pQMat)then write(oo,*)' Error in IniMatter: Wrong matter number',num if(sret_err.eq.0) stop s_err=1 return endif if(QAtMat(num).gt.0)then write(oo,*)' Error in IniMatter: matter number',num, + ' is initialized already' if(sret_err.eq.0) stop s_err=1 return endif if(q.le.0)then write(oo,*)' Error in IniMatter: empty list of atoms', + ' for matter number ',num if(sret_err.eq.0) stop s_err=1 return endif QAtMat(num)=q sw=0.0 if(q.eq.1)then Weight(1)=1.0 endif do nat=1,q if(Zat(Atom(nat)).le.0)then write(oo,*)' Error in IniMatter: Atom number', + nat,' is not initialized' if(sret_err.eq.0) stop s_err=1 return endif if(Weight(nat).lt.0.0)then write(oo,*)' Error in IniMatter: Weight is negative' if(sret_err.eq.0) stop s_err=1 return endif AtMat(nat,num)=Atom(nat) WeightAtMat(nat,num)=Weight(nat) sw=sw+Weight(nat) enddo do nat=1,q WeightAtMat(nat,num)=WeightAtMat(nat,num)/sw enddo A_Mean(num)=0.0 Z_Mean(num)=0.0 do nat=1,q A_Mean(num)=A_Mean(num)+Aat(Atom(nat))*WeightAtMat(nat,num) Z_Mean(num)=Z_Mean(num)+Zat(Atom(nat))*WeightAtMat(nat,num) enddo DensMat(num)=dens DensMatDL(num)=DensMat(num) DensMatDS(num)=DensMat(num) ! if it is not equal ! than the multiple scatering of the ! insident particle will be calculated wrongly c DensMatDS(num)=0.2*DensMat(num) Pressure(num)=Cur_Pressure ! It is never used, only for printing WWW(num)=pw FFF(num)=pf do nen=1,qener ph=0.0 do nat=1,q ph1=0.0 do nsh=1,QShellAt(Atom(nat)) ph1=ph1+PhotAt(nen,nsh,Atom(nat)) enddo ph=ph+ph1*WeightAtMat(nat,num) enddo PhotMat(nen,num)=ph enddo do nen=1,qener ! the same but with ionization potential ph=0.0 do nat=1,q ph1=0.0 do nsh=1,QShellAt(Atom(nat)) ph1=ph1+PhotIonAt(nen,nsh,Atom(nat)) enddo ph=ph+ph1*WeightAtMat(nat,num) enddo PhotIonMat(nen,num)=ph enddo ElDensMat(num)=Z_Mean(num)/A_Mean(num)*AVOGADRO*DensMat(num)/ + ((5.07**3)*1.0e30) XElDensMat(num)=ElDensMat(num)*5.07e10 wplaMat(num)=ElDensMat(num)*4.0*PI/(ELMAS*FSCON) RLenMat(num)=0.0 rms=0.0 do nat=1,QAtMat(num) rms=rms+Aat(AtMat(nat,num))*WeightAtMat(nat,num) enddo do nat=1,QAtMat(num) rm(nat)=Aat(AtMat(nat,num))*WeightAtMat(nat,num)/rms enddo c write(oo,*)' rm(1)=',rm(1) do nat=1,QAtMat(num) RLenMat(num)=RLenMat(num)+rm(nat)/RLenAt(AtMat(nat,num)) enddo RLenMat(num)=1.0/(DensMatDS(num)*RLenMat(num)) c RLenMat(num)=1.0/RLenMat(num) RuthMat(num)=0.0 do nat=1,QAtMat(num) RuthMat(num)=RuthMat(num)+ + WeightAtMat(nat,num)*RuthAt(AtMat(nat,num)) enddo RuthMat(num)=RuthMat(num)*DensMatDS(num)*AVOGADRO/A_Mean(num) DO nen=1,qener epsi2(nen,num)= + (PhotMat(nen,num)/enerc(nen))*ElDensMat(num)/Z_Mean(num) enddo min_ioniz_pot(num)=1.0e30 do nat=1,QAtMat(num) do nsh=1,QShellAt(Atom(nat)) if(min_ioniz_pot(num).gt.ThresholdAt(nsh,Atom(nat)))then min_ioniz_pot(num)=ThresholdAt(nsh,Atom(nat)) endif enddo enddo do i=1,qener E=ENERC(I) E2=E*E EPSIP(I,num)=-WPLAMat(num)/E2 S=0.0 do j=1,qener IF(J.NE.I)THEN S=S+EPSI2(J,num)*ENERC(J)*(ENER(J+1)-ENER(J))/ + (ENERC(J)*ENERC(J)-E2) ELSE EE1=(ENER(J)+ENERC(J))/2.0 EE2=(ENER(J+1)+ENERC(J))/2.0 IF(J.GT.1)THEN EP1=EPSI2(J-1,num)+(EE1-ENERC(J-1))* + (EPSI2(J,num)-EPSI2(J-1,num))/ + (ENERC(J)-ENERC(J-1)) ELSE EP1=EPSI2(J,num)+(EE1-ENERC(J))* + (EPSI2(J+1,num)-EPSI2(J,num))/ + (ENERC(J+1)-ENERC(J)) END IF IF(J.LT.qener)THEN EP2=EPSI2(J,num)+(EE2-ENERC(J))* + (EPSI2(J+1,num)-EPSI2(J,num))/ + (ENERC(J+1)-ENERC(J)) ELSE EP2=EPSI2(J,num)+(EE2-ENERC(J))* + (EPSI2(J,num)-EPSI2(J-1,num))/ + (ENERC(J)-ENERC(J-1)) END IF S=S+EP1*EE1*(ENERC(J)-ENER(J))/ + (EE1*EE1-E2) S=S+EP2*EE2*(ENER(J+1)-ENERC(J))/ + (EE2*EE2-E2) END IF epsi1(i,num)=(2.0/PI)*S enddo enddo end +DECK,PRIMATT. subroutine PriMatter(p) implicit none integer p ! p = 0,1 short output ! p >= 2 long output c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. integer nat integer nmat,nen if(soo.eq.0)return write(oo,*) write(oo,*)' PriMatter:' do nmat=1,pQMat if(qAtMat(nmat).gt.0)then write(oo,*)' matter number ',nmat, ' qAtMat=',qAtMat(nmat) do nat=1,qAtMat(nmat) write(oo,*)' number of atom is ',AtMat(nat,nmat), + ' weight=', WeightAtMat(nat,nmat) enddo write(oo,*)' A_Mean=',A_Mean(nmat),' Z_mean=',Z_Mean(nmat) write(oo,*)' DensMat=',DensMat(nmat), + ' ElDensMat=',ElDensMat(nmat), + ' XElDensMat=',XElDensMat(nmat) write(oo,*)' wplaMat=',wplaMat(nmat) write(oo,*)' plasm energy(sqrt(wplaMat))=',sqrt(wplaMat(nmat)) write(oo,*)' RLenMat=',RLenMat(nmat) write(oo,*)' RuthMat=',RuthMat(nmat) write(oo,*)' min_ioniz_pot=',min_ioniz_pot(nmat) write(oo,*)' Pressure=',Pressure(nmat) write(oo,*)' WWW=',WWW(nmat),' FFF=',FFF(nmat) if(p.ge.2)then write(oo,*)' enerc PhotMat PhotIonMat epsip ', + ' epsi1 epsi2' do nen=1,qener write(oo,'(6E10.3)')enerc(nen), + PhotMat(nen,nmat),PhotIonMat(nen,nmat),epsip(nen,nmat), + epsi1(nen,nmat),epsi2(nen,nmat) enddo ! nen=1,qener endif endif ! if(qAtMat(nmat).gt.0) enddo ! nmat=1,pQMat end +DECK,GRAPHMAT,IF=NEVER. subroutine GraphMatter(num) c c input the data for showing the graphic by PAW c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'cconst.inc' +SEQ,cconst. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. integer num integer k,n real r real s c Calc. coef for going from 10**-18 sm**2 to Mev-2 s=1.e-18 * 5.07e10 * 5.07e10 n=0 open(2,file='matter.grp') do k=1,qener if(PhotMat(k,num).gt.0.0)then c write(2,'(E10.3)')enerc(k) n=n+1 endif enddo do k=1,qener if(PhotMat(k,num).gt.0.0)then c r=PhotMat(k,num)*ElDensMat(num)/Z_Mean(num)*5.07E10 c r=1/r c r=r/DensMat(num) c write(2,'(2E10.3)')r c write(2,'(2E10.3)')enerc(k)*1.e6,r c write(2,'(2E10.3)')enerc(k),alog(r) write(2,*)enerc(k)*1.0e6, PhotMat(k,num)/s endif enddo close(2) write(oo,*)' GraphMatter: ', + 'file matter.grp is writen,n=',n end +DECK,gasdens. function gasdens(A,Weight,q) c c Calc. gas density c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. real gasdens,A(*),Weight(*) integer q real powat real temp real ridberg real d,s integer i c powat=101325.0 c powat=Cur_Pressure *** Ensure that an initial value is set (RV 12/2/97) gasdens=-1 *** End of modification. if(Cur_Pressure.le.0 .or. Cur_Temper.le.0)then write(oo,*) ' error in gasdens: negative or', + ' zero Cur_Pressure or Cur_Temper' write(oo,*)' Cur_Pressure=',Cur_Pressure write(oo,*)' Cur_Temper=',Cur_Temper if(sret_err.eq.0) stop s_err=1 return endif if(q.le.0)then write(oo,*)' error in gasdens: q<=0' write(oo,*)' q=',q if(sret_err.eq.0) stop s_err=1 return endif do i=1,q if(A(i).le.0 .or. Weight(i).le.0)then write(oo,*) ' error in gasdens: negative or', + ' zero A or Weight' write(oo,*)' i=',i write(oo,*)' A(i)=',A(i) write(oo,*)' Weight(i)=',Weight(i) if(sret_err.eq.0) stop s_err=1 return endif enddo powat=101325.0/760 * Cur_Pressure c temp=293 temp=Cur_Temper ridberg=8.314 d=0 do i=1,q d=d+Weight(i) enddo s=0 do i=1,q s=s+A(i)*Weight(i) enddo s=s*powat/(ridberg*temp*d) s=s*1.e-3*1.e-3 gasdens=s return end +DECK,IniVolum. subroutine IniFVolume(up,nmat,sSens,sIon,cwall1,cwide) c c Init. first volume c implicit none integer up,nmat,sSens,sIon c integer sTran real cwall1,cwide c include 'volume.inc' +SEQ,volume. qvol=0 RLenRAVol=0.0 call IniVolume(up,nmat,sSens,sIon,cwall1,cwall1+cwide,cwide) end subroutine IniNVolume(up,nmat,sSens,sIon,cwide) c c Init. next (not the first) volume c implicit none integer up,nmat,sSens,sIon c integer sTran real cwall1,cwide c include 'volume.inc' +SEQ,volume. cwall1=wall2(qvol) call IniVolume(up,nmat,sSens,sIon,cwall1,cwall1+cwide,cwide) end subroutine IniVolume(up,nmat,sSens,sIoni,cwall1,cwall2,cwide) c c Init. any volume c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'volume.inc' +SEQ,volume. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. integer up,nmat,sSens,sIoni c integer sTran real cwall1,cwall2,cwide if(qvol.ge.pqvol)then write(oo,*)' Error in IniVolume: memory is over' stop endif if(qvol.eq.0)then QSVol=0 QIVol=0 endif qvol=qvol+1 if(nmat.eq.0.and.sSens.eq.1)then write(oo,*)' Error in IniVolume: nmat=0 and sSens =1', + ' simultaniously' stop endif if(sIoni.eq.0.and.sSens.eq.1)then write(oo,*)' Error in IniVolume: sIoni=0 and sSens =1', + ' simultaniously' stop endif if(nmat.ne.0)then if(qAtMat(nmat).eq.0)then write(oo,*)' Error in IniVolume: matter number',nmat, + ' is not initialized yet' stop endif endif upVol(qvol)=up nMatVol(qvol)=nmat sSensit(qvol)=sSens sIonizat(qvol)=sIoni if(sSens.ne.0)then QSVol=QSVol+1 if(QSVol.gt.pQSVol)then write(oo,*)' Error in IniVolume: too much sens. volumes' stop endif numVolSens(QSVol)=qvol numSensVol(qvol)=QSVol else numSensVol(qvol)=0 endif if(sIoni.ne.0)then QIVol=QIVol+1 if(QIVol.gt.pQIVol)then write(oo,*)' Error in IniVolume: too much ioniz. volumes' stop endif numVolIoni(QIVol)=qvol numIoniVol(qvol)=QIVol else numIoniVol(qvol)=0 endif if(qvol.eq.1)then wall1(qvol)=cwall1 else wall1(qvol)=wall2(qvol-1) endif wide(qvol)=cwide if(wide(qvol).le.0.0)then write(oo,*)' Error in IniVolume: wide is negative or zero' stop endif wall2(qvol)=wall1(qvol)+wide(qvol) c wall2(qvol)=cwall2 c if(qvol.eq.1)then c wall1(qvol)=cwall1 c else c wall1(qvol)=wall2(qvol-1) c endif c wide(qvol)=wall2(qvol)-wall1(qvol) c if(wide(qvol).le.0.0)then c write(oo,*)' Error in IniVolume: wide is negative or zero' c stop c endif if(nmat.gt.0)then RLenRVol(qvol)=wide(qvol)/RLenMat(nmat) RLenRAVol=RLenRAVol+RLenRVol(qvol) endif end +DECK,VOLPATHL. subroutine VolPathLeng(zcoor,veloc, num, mleng) c Find path leng in the current mat c zcoor - z coordinate c num - number of volume c veloc - velocity(cosine) implicit none c include 'volume.inc' +SEQ,volume. real veloc(3) real*8 zcoor,mleng real*8 z integer num c write(oo,*)' zcoor=',zcoor c write(oo,*)' veloc=',veloc c write(oo,*)' num=',num z=zcoor if(veloc(3).eq.0.0)then mleng=1.e30 else if(veloc(3).gt.0.0)then mleng=(wall2(num)-z)/veloc(3) else mleng=(wall1(num)-z)/veloc(3) endif end +DECK,VOLNUMZC. subroutine VolNumZcoor(zcoor,veloc,num) c Find number of material for this coor. c zcoor - z coordinate c veloc - z velocity c num - number of volume c if(num.ne.0) particle go to next lay c correspodently with its velocity c if without of vol, returns 0 c if num!=0 at call, go to next mat. implicit none c include 'volume.inc' +SEQ,volume. real veloc real*8 zcoor integer num integer i if(num.ne.0)then if(veloc.gt.0)then if(num.lt.qvol)then num=num+1 return else num=0 return endif else if(num.gt.1)then num=num-1 return else num=0 return endif endif endif num=0 if(zcoor.lt.wall1(1))then return else if(zcoor.eq.wall1(1))then if(veloc.gt.0)then num=1 else num=0 endif return endif endif do i=1,qvol if(zcoor.lt.wall2(i))then num=i return elseif(zcoor.eq.wall2(i))then if(veloc.gt.0)then if(i.lt.qvol)then num=i return else num=0 return endif else if(i.gt.1)then num=i-1 return else num=0 return endif endif endif enddo return end +DECK,PRIVOLUM. subroutine PriVolume implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'volume.inc' +SEQ,volume. integer i if(soo.eq.0)return write(oo,*) write(oo,*)' PriVolume: qvol=',qvol write(oo,*) + ' nvol upVol nMatVol sSensit sIonizat ', + 'wall1 wall2 wide RLenRVol' do i=1,qvol write(oo,'(I4,4I8,3F10.4,F10.6)')i, upVol(i),nMatVol(i), + sSensit(i), + sIonizat(i), + wall1(i),wall2(i),wide(i),RLenRVol(i) if(sSensit(i).ne.0)then write(oo,*)' numSensVol(i)=',numSensVol(i) write(oo,*)' numVolSens(numSensVol(i))=', + numVolSens(numSensVol(i)) endif if(sIonizat(i).ne.0)then write(oo,*)' numIoniVol(i)=',numIoniVol(i) write(oo,*)' numVolIoni(numIoniVol(i))=', + numVolIoni(numIoniVol(i)) endif enddo ! qvol write(oo,*) + ' ', + ' RLenRAVol=',RLenRAVol end +DECK,IniTrack. c This package deals with tracks of incident charged particles. c The particle goes from left plane of the detector to c the right plane. c It starts from some starting point and goes to some direction. c The energy of the particle is constant. subroutine IniRATrack(pystart1, pystart2, + psigmaang) c Randomization of the origin point c with uniform distribution with y-coordinate between c pystart1 and pystart2 , x=0.0 c and initial direction around theta = 0.0 c with Gauss distribution with sigma = psigmaang implicit none real pystart1, pystart2, pang, pphiang, psigmaang c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'volume.inc' +SEQ,volume. c include 'track.inc' +SEQ,track. ystart1=pystart1 ystart2=pystart2 sigmaang=psigmaang ystart=0.0 pang=0.0 pphiang=0.0 call IniTrack(ystart, pang, pphiang) sign_ang=1 srandtrack=1 sigmtk = 0 end +DECK,INIRTRAC. subroutine IniRTrack(pystart1, pystart2, pang, pphiang) c Randomization of the origin point c with uniform distribution with y-coordinate between c pystart1 and pystart2 , x=0.0. c Initial direction is defined by theta = pang, phi = pphiang implicit none real pystart1, pystart2, pang, pphiang c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'volume.inc' +SEQ,volume. c include 'track.inc' +SEQ,track. ystart1=pystart1 ystart2=pystart2 sigmaang=0.0 ystart=0.0 call IniTrack(ystart, pang, pphiang) sign_ang=1 srandtrack=1 sigmtk = 0 end +DECK,ININTRAC. subroutine IniNTrack c c Generate the next track c It calls from GoEvent c If there are no randomization of the track requried c and the are no multiple scattering, it does nothing c except filling of some data structure. implicit none c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'volume.inc' +SEQ,volume. c include 'track.inc' +SEQ,track. c include 'cconst.inc' +SEQ,cconst. real r real ranfl real pang,pphiang,pystart real yy,dimmy integer n,nv,i if(srandtrack.eq.1)then r=ranfl() ystart=ystart1+(ystart2-ystart1)*r if(sigmaang.gt.0.0)then 10 call lranor(yy,dimmy) if(yy.lt.0.0) yy=-yy yy=yy*sigmaang if(yy.gt.1.0)goto 10 ang=yy yy=ranfl() phiang=yy*2.0*PI pang=ang pphiang=phiang pystart=ystart call IniTrack(pystart, pang, pphiang) srandtrack=1 ! it falled in IniTrack endif endif if(sigmtk.eq.1)then call TTrack else do nv=1,QVol pntmtk(3,nv)=wall1(nv) pntmtk(1,nv)=(wall1(nv)-wall1(1))*e3ang(1)/e3ang(3) pntmtk(2,nv)=(wall1(nv)-wall1(1))*e3ang(2)/e3ang(3)+ystart velmtk(1,nv)=e3ang(1) velmtk(2,nv)=e3ang(2) velmtk(3,nv)=e3ang(3) do i=1,3 e1mtk(i,nv)=e1ang(i) e2mtk(i,nv)=e2ang(i) e3mtk(i,nv)=e3ang(i) enddo enddo pntmtk(3,qVol+1)=wall2(qVol) pntmtk(1,qVol+1)=(wall2(qVol)-wall1(1))*e3ang(1)/e3ang(3) pntmtk(2,qVol+1)=(wall2(qVol)-wall1(1)) + *e3ang(2)/e3ang(3)+ystart velmtk(1,qVol+1)=e3ang(1) velmtk(2,qVol+1)=e3ang(2) velmtk(3,qVol+1)=e3ang(3) do i=1,3 e1mtk(i,qVol+1)=e1ang(i) e2mtk(i,qVol+1)=e2ang(i) e3mtk(i,qVol+1)=e3ang(i) enddo Qmtk=qVol nmtk=Qmtk+1 do n=1,Qmtk lenmtk(n)=sqrt((pntmtk(1,n+1)-pntmtk(1,n))**2+ + (pntmtk(2,n+1)-pntmtk(2,n))**2+ + (pntmtk(3,n+1)-pntmtk(3,n))**2 ) enddo do n=1,Qmtk Tetamtk(n)=0.0 enddo do n=1,Qmtk nVolmtk(n)=n enddo nVolmtk(Qmtk+1)=qVol do n=1,Qmtk vlenmtk(n)=lenmtk(n) nmtkvol1(n)=n nmtkvol2(n)=n xdvmtk(n)=0.0 ydvmtk(n)=0.0 enddo endif end +DECK,INITRACK. subroutine IniTrack(pystart, pang, pphiang) c c Simple initialization of the track c implicit none real pystart, pang, pphiang c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'volume.inc' +SEQ,volume. c include 'track.inc' +SEQ,track. ystart=pystart srandtrack=0 if(pystart.eq.0.and.pang.eq.0.and.pphiang.eq.0)then sign_ang=0 e1ang(1)=1 e1ang(2)=0 e1ang(3)=0 e2ang(1)=0 e2ang(2)=1 e2ang(3)=0 e3ang(1)=0 e3ang(2)=0 e3ang(3)=1 else sign_ang=1 ang=pang phiang=pphiang c xstart=pxstart c this is for geometry without angle phi c e1ang(1)=cos(ang) c e1ang(2)=0 c e1ang(3)=-sin(ang) c e2ang(1)=0 c e2ang(2)=1 c e2ang(3)=0 c e3ang(1)=sin(ang) c e3ang(2)=0 c e3ang(3)=cos(ang) c this is for complete geometry e1ang(1)=cos(ang)*cos(phiang) e1ang(2)=cos(ang)*sin(phiang) e1ang(3)=-sin(ang) e2ang(1)=-sin(phiang) e2ang(2)=cos(phiang) e2ang(3)=0 e3ang(1)=sin(ang)*cos(phiang) e3ang(2)=sin(ang)*sin(phiang) e3ang(3)=cos(ang) endif end +DECK,INIMTRAC. subroutine IniMTrack(psruthmtk, pmlammtk, pmTetacmtk) c c initialization of the axiliary variables for multiple c scatering of the incident particle. c It have to be called after each initialization of the c new particle if the multiple scatering is desirable. c If it is not needed, the subroutine must not be called at all. c psruthmtk - sign of Rutherford scattering (1) c 1 is recomended c pmlammtk - minimum mean lengt of range c multiplied by density. sm*gr/sm**3 = gr/sm**2 c pmTetacmtk - minimum threshold turn angle c The program find the maximum of pmTetacmtk and c the same angle calculated from pmlammtk, and then, c the program recalculates mlammtk. c For psruthmtk = 0 there is another algorithm. c To have right results pmlammtk have to be c 10-100 times lower than widht of the detector. c The pmTetacmtk have to correspont detector resolution. c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'crosec.inc' +SEQ,crosec. c include 'volume.inc' +SEQ,volume. c include 'cconst.inc' +SEQ,cconst. c include 'track.inc' +SEQ,track. c include 'part.inc' +SEQ,part. integer psruthmtk real pmlammtk, pmTetacmtk integer nm real lam,mT,A real*8 B real msig,x real*8 r sigmtk=1 sruthmtk=psruthmtk mlammtk=pmlammtk mTetacmtk=pmTetacmtk do nm=1,pQMat if(qAtMat(nm).gt.0)then if(sruthmtk.eq.1)then lam=mlammtk/DensMat(nm) * write(oo,*)' lam=',lam c Calculate the minimum angle for restriction of field by c atomic shell mT=2.0*asin(1.0/ + (2.0*partmom*Z_Mean(nm)*5.07e2)) rTetacmtk(nm)=mT * write(oo,*)' mT=',mT if(mT.lt.mTetacmtk)then mT=mTetacmtk ! Throw out too slow interaction. They ! do not influent to anything endif c Calculate the cut angle due to mean free part A=RuthMat(nm)/(partmom2*beta2)/(5.07e10)**2 * B=1.0/(lam*A) ! B is double precision B=(lam*A) ! B is double precision * Tetacmtk(nm)=acos( (B-1.0) / (B+1.0) ) * B = sqrt( 1.0 / (B+1.0) ) B = sqrt( B / (B+1.0) ) Tetacmtk(nm)=2.0 * asin(B) c If it too little, reset it. It will lead to increasing c of lamBdel and decriasing of calculation time. * write(oo,*)' A=',A,' B=',B,' Tetacmtk(nm)=',Tetacmtk(nm) if(Tetacmtk(nm).lt.mT)then Tetacmtk(nm)=mT B=mT ! B is double precision c r=cos(B) ! r is double precision c lam=A*(1.0+r)/(1.0-r) c lam=1.0/lam r=sin(B/2.0) lam=1/A * 2.0 * r*r / ( 1 + cos(B) ) c lam=(partmom2*beta2*sin(Tetacmtk(nm)/2.0)**2) / A endif * write(oo,*)' lam=',lam lammtk(nm)=lam B=Tetacmtk(nm) CosTetac12mtk(nm)=cos(B/2.0) SinTetac12mtk(nm)=sin(B/2.0) else c gauss formula msig=mTetacmtk x=msig/(sqrt(2.0)*13.6/(sqrt(beta2)*partmom)) x=x*x c x=x/DensMat(nm) x=x*RLenMat(nm) lam=mlammtk/DensMat(nm) c write(oo,*)' x=',x,' rleng=',rleng c reset if it is too large if(lam.lt.x)lam=x lammtk(nm)=lam msigmtk=sqrt(2.0)*13.6/(sqrt(beta2)*partmom) endif endif enddo nmtk=1 Qmtk=0 nVolmtk(1)=0 end +DECK,TTRACK. subroutine TTrack implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'volume.inc' +SEQ,volume. c include 'track.inc' +SEQ,track. real*8 mleng,rleng integer nsv real*8 rst(3),rl integer j if(qVol.le.0)then write(oo,*)' error in TTrack: there are not volumes' stop endif 1 nmtk=1 pntmtk(1,1)=0.0 pntmtk(2,1)=ystart pntmtk(3,1)=wall1(1) velmtk(1,1)=e3ang(1) velmtk(2,1)=e3ang(2) velmtk(3,1)=e3ang(3) sgnmtk=1 sturnmtk=0 nmtkvol1(1)=1 vlenmtk(1)=0.0 nVolmtk(nmtk)=0 10 if(sgnmtk.eq.1)then call VolNumZcoor(pntmtk(3,nmtk),velmtk(3,nmtk),nVolmtk(nmtk)) sgnmtk=0 if(nVolmtk(nmtk).ne.0)then vlenmtk(nVolmtk(nmtk))=0.0 endif endif if(nVolmtk(nmtk).eq.0)then go to 100 endif call MakeNewSys + (e1mtk(1,nmtk),e2mtk(1,nmtk),e3mtk(1,nmtk),velmtk(1,nmtk)) if(sturnmtk.eq.1)then call TurnTrack sturnmtk=0 if(velmtk(3,nmtk).le.0.0)then write(oo,*)' worning in TTrack: particle goes back' go to 1 endif endif call VolPathLeng + (pntmtk(3,nmtk),velmtk(1,nmtk),nVolmtk(nmtk),mleng) if(nMatVol(nVolmtk(nmtk)).eq.0)then ! empty volume: no interaction lenmtk(nmtk)=mleng sgnmtk=1 sturnmtk=0 else if(sruthmtk.eq.1)then !lengt to coulomb interaction call SRLengmtk(rleng) else call SMLengmtk(rleng) endif if(rleng.le.mleng)then lenmtk(nmtk)=rleng sturnmtk=1 sgnmtk=0 else lenmtk(nmtk)=mleng sgnmtk=1 if(sruthmtk.eq.1)then sturnmtk=0 else sturnmtk=1 endif endif endif do j=1,3 pntmtk(j,nmtk+1)= + pntmtk(j,nmtk)+lenmtk(nmtk)*velmtk(j,nmtk) velmtk(j,nmtk+1)=velmtk(j,nmtk) enddo vlenmtk(nVolmtk(nmtk))=vlenmtk(nVolmtk(nmtk))+lenmtk(nmtk) nVolmtk(nmtk+1)=nVolmtk(nmtk) if(sgnmtk.eq.1)then nmtkvol2(nVolmtk(nmtk))=nmtk nmtkvol1(nVolmtk(nmtk)+1)=nmtk+1 if(sSensit(nVolmtk(nmtk)).eq.1)then nsv=numSensVol(nVolmtk(nmtk)) rst(3)=(wall2(nVolmtk(nmtk))-wall1(1)) ! it was error here rl=rst(3)/e3ang(3) rst(1)=e3ang(1)*rl rst(2)=e3ang(2)*rl xdvmtk(nsv)=pntmtk(1,nmtk+1)-rst(1) ydvmtk(nsv)=pntmtk(2,nmtk+1)-rst(2) endif endif if(nmtk.ge.pQmtk-2)then write(oo,*)' worning of TTrack: ' write(oo,*) + ' Overflow of mtk. You have increase the common blok' go to 1 endif nmtk=nmtk+1 go to 10 100 Qmtk=nmtk-1 end +DECK,SRLENGMT. subroutine SRLengmtk(rleng) c c Step lenght limit due to multiple scatering c The method with Rutherford cross section c implicit none real ranfl real*8 rleng c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'crosec.inc' c include 'volume.inc' +SEQ,volume. c include 'track.inc' +SEQ,track. real r r=ranfl() if(r.gt.0.99999)then rleng=1.0e30 return endif rleng=-lammtk(nMatVol(nVolmtk(nmtk)))*alog(1.0-r) c write(oo,*)' SRLengBdel' c write(oo,*)' r,lamBdel,rleng',r,lamBdel,rleng end subroutine SMLengmtk(rleng) c c Step lenght limit due to multiple scatering c The method with mean multiple scatering angle form c implicit none real*8 rleng c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'volume.inc' +SEQ,volume. c include 'track.inc' +SEQ,track. rleng=lammtk(nMatVol(nVolmtk(nmtk))) end +DECK,TURNTRAC. subroutine TurnTrack implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'crosec.inc' c include 'volume.inc' +SEQ,volume. c include 'part.inc' +SEQ,part. c include 'track.inc' +SEQ,track. c include 'cconst.inc' +SEQ,cconst. real ranfl real*8 r,rs,rsin12,rcos12 real*8 x,msig real rra,rrb if(sruthmtk.eq.1)then r=ranfl() c rs=cos(Tetacmtk(nMatVol(nVolmtk(nmtk-1)))) c rs=CosTetacmtk(nMatVol(nVolmtk(nmtk-1))) c rs=1.0-(1.0-rs)/(1.0-r*0.5*(1.0+rs)) rsin12=SinTetac12mtk(nMatVol(nVolmtk(nmtk-1))) rcos12=CosTetac12mtk(nMatVol(nVolmtk(nmtk-1))) rs = 1.0 - r * rcos12 * rcos12 if(rs.eq.0.0)then Tetamtk(nmtk-1)=PI else rs=rsin12 / sqrt( rs ) rs=2.0 * asin(rs) Tetamtk(nmtk-1)=rs endif else x=lenmtk(nmtk-1)/RLenMat(nMatVol(nVolmtk(nmtk-1))) c it can not be called for first step c msig=sqrt(2.0)*13.6/(sqrt(beta2)*partmom)* c + sqrt(x) msig=msigmtk* + sqrt(x) call lranor(rra,rrb) Tetamtk(nmtk-1)=rra*msig c write(oo,*)' msig,TetaBdel,rra=',msig,TetaBdel,rra endif call turnvec + (e1mtk(1,nmtk-1),e2mtk(1,nmtk-1),e3mtk(1,nmtk-1),Tetamtk(nmtk-1), + velmtk(1,nmtk)) end +DECK,PRITRACK. subroutine PriTrack implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'volume.inc' +SEQ,volume. c include 'track.inc' +SEQ,track. if(soo.eq.0)return write(oo,*) write(oo,*)' PriTrack:' write(oo,*)' ystart1,2, ystart=',ystart1,ystart2,ystart write(oo,*)' srandtrack=',srandtrack if(sign_ang.eq.0)then write(oo,*)' parallel track' else write(oo,*)' ang=',ang,' phiang=',phiang, + ' sigmaang=',sigmaang write(oo,*)' e1ang()=',e1ang(1),e1ang(2),e1ang(3) write(oo,*)' e2ang()=',e2ang(1),e2ang(2),e2ang(3) write(oo,*)' e3ang()=',e3ang(1),e3ang(2),e3ang(3) endif end +DECK,PRIMTRAC. subroutine PriMTrack(k) c c k can be equal to 0,1,2,3,4 c implicit none integer k c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'volume.inc' +SEQ,volume. c include 'track.inc' +SEQ,track. integer nm,n,i,j,nv,nsv if(soo.eq.0)return write(oo,*) write(oo,*)' PriMTrack: k=',k write(oo,*)' sigmtk=',sigmtk c if(sigmtk.eq.1)then if(sigmtk.eq.1)then write(oo,*)' sruthmtk=',sruthmtk write(oo,*)' mlammtk=',mlammtk,' mTetacmtk=',mTetacmtk endif write(oo,*)' qmtk=',qmtk,' nmtk=',nmtk if(k.eq.1)then write(oo,*)' way of particle' do n=1,nmtk write(oo,*)' n=',n write(oo,*)' pntmtk(1,2,3 ', + ' velmtk(1,2,3' write(oo,'(6(1X,e12.6))')(pntmtk(j,n),j=1,3),(velmtk(j,n),j=1,3) write(oo,*)' lenmtk, Tetamtk, nVolmtk' write(oo,'(1X,e12.6,1X,e12.6,1X,i7)') + lenmtk(n),Tetamtk(n),nVolmtk(n) write(oo,*)' e1mtk=',(e1mtk(i,n),i=1,3) write(oo,*)' e2mtk=',(e2mtk(i,n),i=1,3) write(oo,*)' e3mtk=',(e3mtk(i,n),i=1,3) enddo endif if(sigmtk.eq.1)then if(k.eq.2)then write(oo,*)' material constants:' write(oo,*)' msigmtk=',msigmtk write(oo,*)' nm, lammtk(nmat), Tetacmtk(nmat)', + ' CosTetac12mtk(nmat), SinTetac12mtk(nmat)' do nm=1,pQMat if(qAtMat(nm).gt.0)then write(oo,*)nm,lammtk(nm),Tetacmtk(nm),rTetacmtk(nm), + CosTetac12mtk(nm),SinTetac12mtk(nm) endif enddo endif endif if(sigmtk.eq.1)then if(k.eq.3)then if(nVolmtk(nmtk).ne.0)then write(oo,*)' given point:' write(oo,*)' pntmtk(1,2,3, ', + ' velmtk(1,2,3' write(oo,'(6(1X,e12.6))') + (pntmtk(j,nmtk),j=1,3),(velmtk(j,nmtk),j=1,3) write(oo,*)' lenmtk, Tetamtk, nVolmtk' write(oo,'(1X,e12.6,1X,e12.6,1X,i7)') + lenmtk(nmtk),Tetamtk(nmtk),nVolmtk(nmtk) write(oo,*)' e1mtk=',(e1mtk(i,nmtk),i=1,3) write(oo,*)' e2mtk=',(e2mtk(i,nmtk),i=1,3) write(oo,*)' e3mtk=',(e3mtk(i,nmtk),i=1,3) endif endif endif if(k.eq.4)then if(qmtk.ge.1)then write(oo,*)' volimes info:' write(oo,*) + ' nv, ', + ' vlenmtk(pQVol), nmtkvol1(pQVol), nmtkvol2(pQVol)' c write(oo,*)' if sensitive, nsv,xdvmtk(nsv),ydvmtk(nsv)' do nv=1,qVol write(oo,*)nv, vlenmtk(nv), nmtkvol1(nv), nmtkvol2(nv) if(sSensit(nv).eq.1)then write(oo,*)' sensitive: nsv,xdvmtk(nsv),ydvmtk(nsv)' nsv=numSensVol(nv) write(oo,*)' ',nsv,xdvmtk(nsv),ydvmtk(nsv) endif enddo endif endif c endif end +DECK,IniPart. subroutine IniPart(ptkin,pmass) c c Initialize the incident particle c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'cconst.inc' +SEQ,cconst. c include 'part.inc' +SEQ,part. real ptkin,pmass real*8 gamma,r,rm2,rme if(ptkin.le.0.0.or.pmass.le.0.0.or.ptkin.lt.1e-3*pmass)then write(oo,*)' error in IniPart: wrong parameters:' write(oo,*)' ptkin=',ptkin,' pmass=',pmass if(sret_err.eq.0) stop s_err=1 return endif tkin=ptkin mass=pmass gamma=tkin/mass+1.0 partgamma=gamma beta2=1.0-1.0/(gamma*gamma) r=mass/(tkin+mass) beta12=r*r partmom2=tkin*tkin+2.0*tkin*mass partmom=sqrt(partmom2) if(mass.ge.0.500.and.mass.le.0.515)then emax=tkin s_pri_elec=1 else s_pri_elec=0 rm2=mass*mass rme=ELMAS if(1.0-beta2 .gt. 1.0e-10)then emax=2.0*rm2*ELMAS*beta2/ + ((rm2+rme*rme+2.0*rme*gamma*mass)*(1.0-beta2)) if(emax.gt.tkin)emax=tkin else emax=tkin endif endif bem=beta2/emax coefPa=1.0/(FSCON*beta2*PI) end +DECK,PRIPART. subroutine PriPart implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'part.inc' +SEQ,part. if(soo.eq.0)return write(oo,*) write(oo,*)' Particle: tkin=',tkin,' mass=',mass write(oo,*)' beta2=',beta2,' beta12=',beta12 write(oo,*)' emax=',emax,' bem=',bem,' coefPa=',coefPa end +DECK,IniCrose. Subroutine IniCrosec c c Initialization of ionization cross section for all the c matters which are in "ionization" volumes c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'crosec.inc' +SEQ,crosec. c include 'volume.inc' +SEQ,volume. integer nv,nm if(qvol.le.0)then write(oo,*)' You forgot to initialize volumes' stop endif if(QIVol.le.0)then write(oo,*)' You forgot to initialize ioniz. volumes' stop endif do nm=1,pQMat sMatC(nm)=0 enddo do nv=1,QIVol sMatC(nMatVol(numVolIoni(nv)))=1 enddo do nm=1,pQMat if(sMatC(nm).eq.1)then call IniCrosecm(nm) endif enddo end +DECK,INICROSM. Subroutine IniCrosecm(nmat) c c Initialization of ionization cross section for given matter c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'part.inc' +SEQ,part. c include 'crosec.inc' +SEQ,crosec. c include 'cconst.inc' +SEQ,cconst. integer nmat c real spa,sio integer i real*8 r,R0,R1,R2,R3,RR12,RR22 real*8 s,sa integer k c real ALOG,SQRT,ATAN real fquan,fmean,fmean1 integer nen,nat,nsh,nshc,ne c integer nat0,nat1,iat c real spa(pqener) ! sum of photoabsorption c ! It is luzy to put it to matter. real*8 delta,pg,pg2 complex*16 eeee real*8 eee(2) equivalence (eeee,eee(1)) c MatC=nmat c ksi=0.1534*DensMat(nmat)*Z_Mean(nmat)/(beta2*A_Mean(nmat)) DO 100 I=1,qener R=-EPSI1(I,nmat)+(1.0+EPSI1(I,nmat))*BETA12 R=R*R+beta2*beta2*EPSI2(I,nmat)*EPSI2(I,nmat) R=1.0/SQRT(R) R=DLOG(R) LOG1C(I,nmat)=R 100 CONTINUE C DO 200 I=1,qener R=2.0*0.511*beta2/ENERC(I) if(R.gt.1.0)then R=DLOG(R) else R=0.0 endif LOG2C(I,nmat)=R 200 continue c DO 300 I=1,qener R0=1.0+EPSI1(I,nmat) R=-EPSI1(I,nmat)+R0*BETA12 RR12=R0*R0 RR22=EPSI2(I,nmat)*EPSI2(I,nmat) R1=(-R0*R+beta2*RR22)/(RR12+RR22) R2=EPSI2(I,nmat)*Beta2/R R3=ATAN(R2) IF(R.LT.0.0) R3=3.14159+R3 c R2=R/(EPSI2(I,nmat)*Beta2) ! it is the same as c previous three lines but less exactly c if EPSI2 --> 0 c R3=PI/2.0 - ATAN(R2) chereCangle(I,nmat)=R3 CHEREC(I,nmat)=(COEFPa/ElDENSMat(nmat))*R1*R3 c spa=0.0 c sio=0.0 c c do nat=1,QAtMat(nmat) c do nsh=1,QShellAt(AtMat(nat,nmat)) c c spa=spa+PhotAt(I,nsh,nat) c sio=sio+PhotIonAt(I,nsh,nat) c c enddo c enddo c if(spa.gt.0.0)then c CHEREC(I,nmat)=CHEREC(I,nmat)*sio/spa c endif 300 continue c debug: c write(oo,*)' probb' c do nen=1,qener c c R=log1C(nen,nmat)*coefPa*PhotIonMat(nen,nmat) c + /(enerc(nen)*Z_Mean(nmat)) c if(PhotMat(nen,nmat).gt.0.0)then c R1= R + PhotIonMat(nen,nmat)/PhotMat(nen,nmat)*CHEREC(nen,nmat) c endif c r2=r1+log2C(nen,nmat)*coefPa*PhotIonMat(nen,nmat) c + /(enerc(nen)*Z_Mean(nmat)) c write(oo,'(5E10.3)')enerc(nen),R,CHEREC(nen,nmat),R1,r2 c c enddo c end debug nshc=0 do 800 nat=1,QAtMat(nmat) do 700 nsh=1,QShellAt(AtMat(nat,nmat)) nshc=nshc+1 NAtMC(nshc,nmat)=nat NAtAC(nshc,nmat)=AtMat(nat,nmat) NSheC(nshc,nmat)=nsh do 400 nen=1,qener flog1(nen,nshc,nmat)= + WeightAtMat(nat,nmat)*log1C(nen,nmat)*coefPa* + PhotIonAt(nen,nsh,AtMat(nat,nmat))/ + (enerc(nen)*Z_Mean(nmat)) flog2(nen,nshc,nmat)= + WeightAtMat(nat,nmat)*log2C(nen,nmat)*coefPa* + PhotIonAt(nen,nsh,AtMat(nat,nmat))/ + (enerc(nen)*Z_Mean(nmat)) if(PhotMat(nen,nmat).gt.0.0)then cher(nen,nshc,nmat)= chereC(nen,nmat)* + WeightAtMat(nat,nmat)* + PhotIonAt(nen,nsh,AtMat(nat,nmat))/ + PhotMat(nen,nmat) c + WeightAtMat(nat,nmat)*chereC(nen,nmat)* c + WeightShAt(nsh,AtMat(nat,nmat)) else cher(nen,nshc,nmat)=0.0 endif 400 continue s=0 do 500 nen=1,qener r=PhotAt(nen,nsh,AtMat(nat,nmat))*WeightAtMat(nat,nmat)* + (ener(nen+1)-ener(nen)) rezer(nen,nshc,nmat)=s+0.5*r if(enerc(nen).gt.MinThresholdAt(AtMat(nat,nmat)) + .and. + enerc(nen).lt.emax)then ! kinematical limit if(s_pri_elec.eq.0)then frezer(nen,nshc,nmat)=(s+0.5*r)*coefPa/ + (enerc(nen)*enerc(nen)*Z_Mean(nmat))* + (1.0-beta2*enerc(nen)/emax + + enerc(nen)*enerc(nen)/ + (2.0*(tkin+mass)*(tkin+mass))) else delta=enerc(nen)/mass pg=partgamma pg2=pg*pg frezer(nen,nshc,nmat)=(s+0.5*r)*coefPa/ + Z_Mean(nmat) * beta2/mass * + 1.0/(pg2-1) * + ((pg-1)**2 * pg2 / ((delta*(pg-1-delta))**2) + - + (2*pg2 + 2*pg - 1)/ + (delta*(pg-1-delta)) + + 1 ) endif else frezer(nen,nshc,nmat)=0.0 endif s=s+r 500 continue 700 continue 800 continue QShellC(nmat)=nshc r=0.0 c add cherenkov radiation to lowest energy level shell c nat0=NAtAC(1) c iat=1 c nat1=nat0 c nsh=NSheC(1) c i=1 c850 do nshc=1,QShellC c if(NAtAC(nshc).eq.nat0)then c if(NSheC(nshc).gt.nsh)then c nsh=NSheC(nshc) c i=nshc c endif c else c if(nshc.gt.iat.and.nat1.eq.nat0)then c iat=nshc c nat1=NAtAC(nshc) c endif c endif c enddo c write(oo,*)' crosec: i,nat0,nat1,nmat,iat=' c write(oo,*)i,nat0,nat1,nmat,iat c if(nat1.gt.nat0)then c nat=nat1 c go to 850 c endif c The cherenkov is added to last shell c i=0 c do nat=1,QAtMat(nmat) c i=i+QShellAt(AtMat(nat,nmat)) c do nen=1,qener c cher(nen,i,nmat)= c + WeightAtMat(nat,nmat)*chereC(nen,nmat) cc write(oo,*)cher(nen,i),WeightAtMat(nat,nmat), cc + chereC(nen) c enddo c enddo do 1000 nen=1,qener s=0.0 sa=0.0 k=0.0 DO nshc=1,QShellC(nmat) ADDA(nen,nshc,nmat)=FLOG1(nen,nshc,nmat)+ + FLOG2(nen,nshc,nmat)+FREZER(nen,nshc,nmat) c ADDA(nen,nshc,nmat)=FLOG1(nen,nshc,nmat)+ c + FLOG2(nen,nshc,nmat) s=s+ADDA(nen,nshc,nmat) if(enerc(nen).gt.min_ioniz_pot(nmat))then ADDA(nen,nshc,nmat)=ADDA(nen,nshc,nmat)+ + cher(nen,nshc,nmat) if(ADDA(nen,nshc,nmat).lt.0.0)then write(oo,*)' worning of IniCrosec: negative ADDA' write(oo,*)' nmat=',nmat,' nshc=',nshc,' nen=',nen ADDA(nen,nshc,nmat)=0.0 endif endif enddo c if(enerc(nen).gt.min_ioniz_pot(nmat))then c if(s.lt.-chereC(nen,nmat))then c DO nshc=1,QShellC(nmat) c ADDA(nen,nshc,nmat)=0.0 c enddo c else c s=1.0+chereC(nen,nmat)/s c DO nshc=1,QShellC(nmat) c ADDA(nen,nshc,nmat)=ADDA(nen,nshc,nmat)*s c enddo c endif c endif s=0.0 DO nshc=1,QShellC(nmat) s=s+ADDA(nen,nshc,nmat) enddo ADDAC(nen,nmat)=s c DO 900 nshc=1,QShellC(nmat) c R=FLOG1(nen,nshc,nmat)+FLOG2(nen,nshc,nmat)+ c + FREZER(nen,nshc,nmat) cc IF(CHER(nen,nshc).LT.0.0)THEN c R=R+CHER(nen,nshc,nmat) cc END IF c IF(R.LT.0.0)THEN c K=1 c SA=SA+R c ELSE c S=S+R c ENDIF c ADDA(nen,nshc,nmat)=R c900 ADDAC(nen,nmat)=ADDAC(nen,nmat)+ADDA(nen,nshc,nmat) c c IF(K.EQ.1)THEN c IF(ABS(SA).LT.S)THEN c DO 906 nshc=1,QShellC(nmat) c IF(ADDA(nen,nshc,nmat).GT.0.0)THEN c ADDA(nen,nshc,nmat)=ADDA(nen,nshc,nmat)*(1.0+SA/S) c ELSE c ADDA(nen,nshc,nmat)=0.0 c END IF c906 CONTINUE c ELSE c DO 907 nshc=1,QShellC(nmat) c ADDA(nen,nshc,nmat)=0.0 c907 CONTINUE c ADDAC(nen,nmat)=0.0 c END IF c END IF 1000 continue DO nshc=1,QShellC(nmat) do nen=1,qener fadda(nen,nshc,nmat)=adda(nen,nshc,nmat)* + (ener(nen+1)-ener(nen)) enddo call lhispre(fadda(1,nshc,nmat),qener) enddo quanC(nmat)=fquan(addaC(1,nmat),1.0,nmat) meanC(nmat)=fmean(addaC(1,nmat),1.0,nmat) if(s_pri_elec.eq.0)then meanC1(nmat)=fmean1(addaC(1,nmat),1.0,nmat) else meanC1(nmat)=0.0 ! for electrons it is not calculated endif meaneleC(nmat)=meanC(nmat)/WWW(nmat) meaneleC1(nmat)=meanC1(nmat)/WWW(nmat) do nshc=1,QShellC(nmat) c quan(nshc)=fquan(adda(1,nshc,nmat), c + WeightAtMat(NAtMC(nshc),nmat),nmat) c mean(nshc)=fmean(adda(1,nshc,nmat), c +WeightAtMat(NAtMC(nshc),nmat),nmat) quan(nshc,nmat)=fquan(adda(1,nshc,nmat),1.0,nmat) mean(nshc,nmat)=fmean(adda(1,nshc,nmat),1.0,nmat) enddo do ne=1,qener eee(1)=dble(1.)+dble(epsi1(ne,nmat)) eee(2)=dble(epsi2(ne,nmat)) c write(oo,*)enerc(ne),eeee eeee=beta2*eeee - 1.0 c write(oo,*)enerc(ne),eeee eeee=sqrt(eeee) c write(oo,*)enerc(ne),eeee eeee=enerc(ne)/sqrt(beta2) * eeee c write(oo,*)enerc(ne),eeee pocaz(ne,nmat)=eeee * 5.07e10 c write(oo,*)enerc(ne),pocaz(ne,nmat) enddo end +DECK,FQUAN. function fquan(ad,weig,nmat) c c Calc. mean quantity of energy transfer for 1 sm c implicit none c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. real fquan,ad(*),weig integer nmat real step_integ_ar fquan=step_integ_ar(ener,ad,qener,ener(1),ener(qener+1)) fquan=fquan*weig*XElDensMat(nmat) end +DECK,FMEAN. function fmean(ad,weig,nmat) c c Calc. mean energy loss for 1 sm c implicit none c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. real fmean,ad(*),weig integer nmat real step_integ_ar real addd(pqener) integer nen do nen=1,qener addd(nen)=ad(nen)*enerc(nen) enddo fmean=step_integ_ar(ener,addd,qener,ener(1),ener(qener+1)) fmean=fmean*weig*XElDensMat(nmat) end +DECK,FMEAN1. function fmean1(ad,weig,nmat) c c Calc. mean energy loss for 1 sm c implicit none c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'part.inc' +SEQ,part. c include 'cconst.inc' +SEQ,cconst. real fmean1,ad(*),weig integer nmat real step_integ_ar real addd(pqener) real e1,e2 integer nen do nen=1,qener addd(nen)=ad(nen)*enerc(nen) enddo fmean1=step_integ_ar(ener,addd,qener,ener(1),ener(qener+1)) fmean1=fmean1*weig*XElDensMat(nmat) if(emax.gt.ener(qener+1))then e1=ener(qener+1) e2=emax fmean1 = fmean1 + + 2.0 * PI / (FSCON**2 * ELMAS * beta2) + * weig * XElDensMat(nmat) * + ( log(e2/e1) - bem * (e2-e1) + + (e2*e2-e1*e1)/(4.0 * (tkin+mass) * (tkin+mass) ) ) endif end +DECK,PRICROSE. subroutine PriCrosec(nmat,lev) implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'part.inc' c include 'crosec.inc' +SEQ,crosec. integer nmat integer lev integer nen integer nshc if(soo.eq.0)return if(lev.ge.1)then write(oo,*) write(oo,*)' PriCrosec:' write(oo,*)' material number ',nmat, + ' Quantity of shells is',QShellC(nmat) if(sMatC(nmat).ne.1)then write(oo,*)' This cross sect. was not initialized' return endif c write(oo,*)' ksi=',ksi write(oo,*)' quanC=',quanC(nmat) write(oo,*)' meanC=',meanC(nmat),' meaneleC=',meaneleC(nmat) write(oo,*)' meanC1=',meanC1(nmat),' meaneleC1=',meaneleC1(nmat) do nshc=1,QShellC(nmat) write(oo,*)' NAtMC=',NAtMC(nshc,nmat),' NAtAC=',NAtAC(nshc,nmat), + ' NSheC=',NSheC(nshc,nmat) write(oo,*)' quan=',quan(nshc,nmat),' mean=',mean(nshc,nmat) enddo c write(oo,*)' ener,pocaz' c do nen=1,qener c write(oo,*)enerc(nen),pocaz(nen,nmat) c enddo if(lev.ge.2)then write(oo,*)' enerc, log1C, log2C', + ' chereC, addaC, chereCangle' do nen=1,qener write(oo,'(6e10.3)')enerc(nen),log1C(nen,nmat),log2C(nen,nmat), + chereC(nen,nmat),addaC(nen,nmat),chereCangle(nen,nmat) enddo if(lev.ge.3)then do nshc=1,QShellC(nmat) write(oo,*)' enerc, flog1, flog2, cher, ', + ' rezer, frezer, adda, fadda' do nen=1,qener write(oo,'(8e10.3)')enerc(nen),flog1(nen,nshc,nmat), + flog2(nen,nshc,nmat), + cher(nen,nshc,nmat),rezer(nen,nshc,nmat), + frezer(nen,nshc,nmat), + adda(nen,nshc,nmat),fadda(nen,nshc,nmat) enddo enddo endif endif endif end +DECK,IniLsgvg. subroutine IniLsgvga c Initialize the virt. ioniz. photons implicit none c include 'volume.inc' +SEQ,volume. c include 'lsgvga.inc' +SEQ,lsgvga. integer n do n=1,QSVol qgvga(n)=0 enddo end +DECK,PRILSGVG. subroutine PriLsgvga c print the virt. ioniz. photons implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'volume.inc' +SEQ,volume. c include 'lsgvga.inc' +SEQ,lsgvga. integer k,i,j if(soo.eq.0)return write(oo,*) write(oo,*)' PriLsgvga: virtual ionization photons' do k=1,QSVol write(oo,*)' number of lay =',k write(oo,*)' qgvga()= ',qgvga(k),' esgvga()=',esgvga(k) if(qgvga(k).gt.0)then write(oo,*)' egvga(i,k) ganumat(i,k) ganumshl(i.k)' write(oo,*) + ' pntgvga(1,i,k) pntgvga(2,i,k) pntgvga(3,i,k) ', + ' velgvga(1,i,k) velgvga(2,i,k) velgvga(3,i,k) ' do i=1,qgvga(k) write(oo,'(1X,e12.5,2(i12))') + egvga(i,k),ganumat(i,k),ganumshl(i,k) write(oo,'(6(1X,e12.5))')(pntgvga(j,i,k),j=1,3), + (velgvga(j,i,k),j=1,3) enddo endif enddo end +DECK,Inirga. subroutine Inirga c c Init. common with real photons c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'rga.inc' +SEQ,rga. qrga=0 crga=1 sOverflowrga=0 if(nevt.eq.qevt)then qOverflowrga=0 qsOverflowrga=0 endif end +DECK,WORPRIRG. subroutine WorPrirga implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'rga.inc' +SEQ,rga. c integer i,j if(nevt.eq.qevt)then if(qOverflowrga.gt.0)then write(oo,*) write(oo,*)' WorPrirga: overflow of real photons arrays ' write(oo,*)' sOverflowrga qsOverflowrga qOverflowrga' write(oo,*)sOverflowrga,qsOverflowrga,qOverflowrga endif endif end +DECK,PRIRGA. subroutine Prirga c print the real photons implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'rga.inc' +SEQ,rga. integer i,j if(soo.eq.0)return write(oo,*) write(oo,*)' Prirga: real photons' write(oo,*)' sOverflowrga qsOverflowrga qOverflowrga' write(oo,*)sOverflowrga,qsOverflowrga,qOverflowrga write(oo,*)' qrga= ',qrga,' crga=',crga if(crga.le.qrga)then write(oo,*)' erga() nVolrga Strga uprga(1) Ptrga' write(oo,*) + ' pntrga(1,i) pntrga(2,i) pntrga(3,i) ', + ' velrga(1,i) velrga(2,i) velrga(3,i) ' do i=crga,qrga write(oo,'(1X,e12.5,4(1X,I5))') + erga(i),nVolrga(i),Strga(i),uprga(1,i),Ptrga(i) write(oo,'(6(1X,e12.5))')(pntrga(j,i),j=1,3), + (velrga(j,i),j=1,3) enddo endif end +DECK,PRIRGAF. subroutine PrirgaF c print the real photons which fly out implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'rga.inc' +SEQ,rga. integer i,j if(soo.eq.0)return write(oo,*) write(oo,*)' Prirga: real photons which go out' write(oo,*)' qrga= ',qrga,' crga=',crga c if(crga.le.qrga)then write(oo,*)' erga() nVolrga Strga Ptrga' write(oo,*) + ' pntrga(1,i) pntrga(2,i) pntrga(3,i) ', + ' velrga(1,i) velrga(2,i) velrga(3,i) ' do i=1,qrga if(SFrga(i).eq.1)then write(oo,'(1X,e12.5,3(1X,I5))') + erga(i),nVolrga(i),Strga(i),Ptrga(i) write(oo,'(6(1X,e12.5))')(pntrga(j,i),j=1,3), + (velrga(j,i),j=1,3) endif enddo c endif end +DECK,Iniabs. subroutine Iniabs c c Initialize absorbed photons c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'abs.inc' +SEQ,abs. qtagam=0 ctagam=1 sOverflowagam=0 if(nevt.eq.1)then qOverflowagam=0 qsOverflowagam=0 endif end +DECK,WORPRIAB. subroutine WorPriabs implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'abs.inc' +SEQ,abs. c integer i,j if(nevt.eq.qevt)then if(qOverflowagam.gt.0)then write(oo,*) write(oo,*)' WorPriabs: overflow of absorbtion photons arrays ' write(oo,*)' sOverflowagam qsOverflowagam qOverflowagam' write(oo,*)sOverflowagam,qsOverflowagam,qOverflowagam endif endif end +DECK,PRIABS. subroutine Priabs implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'abs.inc' +SEQ,abs. integer i,j if(soo.eq.0)return write(oo,*) write(oo,*)' Priabs: virtual photons' write(oo,*)' sOverflowagam qsOverflowagam qOverflowagam' write(oo,*)sOverflowagam,qsOverflowagam,qOverflowagam write(oo,*)' qtagam= ',qtagam,' ctagam=',ctagam if(ctagam.le.qtagam)then write(oo,*)' etagam() nVolagam() nAtagam() ', + 'nShlagam() stagam() upagam()' write(oo,*) + ' rtagam(1,i) rtagam(2,i) rtagam(3,i) ', + ' vtagam(1,i) vtagam(2,i) vtagam(3,i) ' do i=ctagam,qtagam write(oo,'(1(1X,e12.5),10(1X,i5))') + etagam(i), nVolagam(i),nAtagam(i), + nShlagam(i),Stagam(i),(upagam(j,i),j=1,pqup) write(oo,'(6(1X,e12.5))')(rtagam(j,i),j=1,3), + (vtagam(j,i),j=1,3) enddo endif end +DECK,rafflev. subroutine rafflev c c The main subroutine of ionization loss generator c implicit none c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'crosec.inc' +SEQ,crosec. c include 'raffle.inc' +SEQ,raffle. c include 'volume.inc' +SEQ,volume. c include 'track.inc' +SEQ,track. c include 'lsgvga.inc' c include 'GoEvent.inc' +SEQ,GoEvent. integer nv,niv,nm real e do niv=1,QIVol nv=numVolIoni(niv) nm=nMatVol(nv) if(sign_ang.eq.0)then call raffle(nm,real(wide(nv)),e) call rafflevirt(nv,niv) else c if(sigmtk.eq.0)then c call raffle(nm,real(wide(nv)/e3ang(3)),e) c call rafflevirt1(nv,niv) c else call raffle(nm,real(vlenmtk(nv)),e) call rafflevirt2(nv,niv) c endif endif enddo end +DECK,RAFFLEVI. subroutine rafflevirt(nv,niv) implicit none integer nv,niv c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'crosec.inc' +SEQ,crosec. c include 'raffle.inc' +SEQ,raffle. c include 'volume.inc' +SEQ,volume. c include 'lsgvga.inc' +SEQ,lsgvga. c include 'abs.inc' +SEQ,abs. integer i,j real ranfl real F,rr esgvga(niv)=ESGRaf do i=1,QGRaf egvga(i,niv)=EGRaf(i) pntraf(1,i)=0.0 pntraf(2,i)=0.0 rr=ranfl() pntraf(3,i)=wall1(nv)+rr*wide(nv) F=3.14159*2.0*ranfl() velraf(1,i)=cos(F) velraf(2,i)=sin(F) velraf(3,i)=0.0 if(i.le.pqgvga)then egvga(i,niv)=EGRaf(i) do j=1,3 pntgvga(j,i,niv)=pntraf(j,i) velgvga(j,i,niv)=velraf(j,i) enddo ganumat(i,niv)=NAtGRaf(i) ganumshl(i,niv)=NShAtGRaf(i) endif if(qtagam .eq. pqtagam)then qOverflowagam=qOverflowagam+1 if(sOverflowagam.eq.0)then qsOverflowagam=qsOverflowagam+1 sOverflowagam=1 endif else qtagam=qtagam+1 etagam(qtagam)=EGRaf(i) do j=1,3 rtagam(j,qtagam)=pntraf(j,i) vtagam(j,qtagam)=velraf(j,i) enddo nVolagam(qtagam)=nv nAtagam(qtagam)=NAtGRaf(i) nShlagam(qtagam)=NShAtGRaf(i) Stagam(qtagam)=1 endif enddo end +DECK,RAFFLEV2. subroutine rafflevirt2(nv,niv) implicit none integer nv,niv c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'crosec.inc' +SEQ,crosec. c include 'raffle.inc' +SEQ,raffle. c include 'volume.inc' +SEQ,volume. c include 'track.inc' +SEQ,track. c include 'lsgvga.inc' +SEQ,lsgvga. c include 'abs.inc' +SEQ,abs. integer i,j,nmt,nmta real ranfl real*8 rr real*8 rrr esgvga(niv)=ESGRaf if(QGRaf.le.pqgvga)then qgvga(niv)=QGRaf else qgvga(niv)=pqgvga endif do i=1,QGRaf rr=ranfl() rr=rr*vlenmtk(nv) rrr=rr do nmt=nmtkvol1(nv),nmtkvol2(nv) if(rrr.le.lenmtk(nmt))then do j=1,3 pntraf(j,i)=pntmtk(j,nmt)+rrr*velmtk(j,nmt) enddo nmta=nmt go to 10 else rrr=rrr-lenmtk(nmt) endif enddo write(oo,*)' worning in rafflevirt2: strange step' nmta=nmtkvol2(nv) do j=1,3 pntraf(j,i)=pntmtk(j,nmta)+ + vlenmtk(nv)*velmtk(j,nmta) enddo 10 continue call Ncirclesim( + e1mtk(1,nmta),e2mtk(1,nmta),e3mtk(1,nmta), + velraf(1,i)) if(i.le.pqgvga)then egvga(i,niv)=EGRaf(i) do j=1,3 pntgvga(j,i,niv)=pntraf(j,i) velgvga(j,i,niv)=velraf(j,i) enddo ganumat(i,niv)=NAtGRaf(i) ganumshl(i,niv)=NShAtGRaf(i) endif c write(oo,*)' rafflevirt1:' c write(oo,*)(rst(j),j=1,3) c write(oo,*)(wid(j),j=1,3) c write(oo,*)(pntgvga(j,i,nsv),j=1,3) c write(oo,*)(vel(j),j=1,3) c write(oo,*)(velgvga(j,i,nsv),j=1,3) c ganumat(i,niv)=NAtGRaf(i) c ganumshl(i,niv)=NShAtGRaf(i) if(qtagam .eq. pqtagam)then qOverflowagam=qOverflowagam+1 if(sOverflowagam.eq.0)then qsOverflowagam=qsOverflowagam+1 sOverflowagam=1 endif else qtagam=qtagam+1 etagam(qtagam)=EGRaf(i) do j=1,3 rtagam(j,qtagam)=pntraf(j,i) vtagam(j,qtagam)=velraf(j,i) enddo nVolagam(qtagam)=nv nAtagam(qtagam)=NAtGRaf(i) nShlagam(qtagam)=NShAtGRaf(i) Stagam(qtagam)=1 endif enddo !i=1,QGRaf end +DECK,RAFFLE. subroutine raffle(nm,x,e) implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'crosec.inc' +SEQ,crosec. c include 'raffle.inc' +SEQ,raffle. integer nm real x real e integer nshc,n,ierror real eran real xran,dran integer iran integer rquan QGRaf=0 e=0.0 do nshc=1,QShellC(nm) call lspois(quan(nshc,nm)*x,rquan,ierror) if(ierror.ne.0)then write(oo,*)' error in raffle: lspois returned ', + 'sign of error,' write(oo,*)' quan(nshc,nm)*x=',quan(nshc,nm)*x write(oo,*)' quan(nshc,nm)=',quan(nshc,nm) write(oo,*)' x=',x write(oo,*)' nshc=',nshc,' nm=',nm stop 'error in poisson' endif do n=1,rquan if(QGRaf.eq.pQGRaf)then write(oo,*)' Worning og raffle: too much ', + ' photons: QGRaf=',QGRaf write(oo,*)' other wiil be ignored' go to 10 endif QGRaf=QGRaf+1 call lhisran(fadda(1,nshc,nm),qener,1.0,1.0,xran) iran=xran if(iran.lt.1.or.iran.gt.qener)then write(oo,*)' Worning of raffle: iran=',iran, + ' xran=',xran if(iran.lt.1)then iran=1 else iran=qener endif endif dran=xran-iran eran=ener(iran)+(ener(iran+1)-ener(iran))*dran c if(nshc.eq.1)then c write(oo,*)' xran,iran,dran=',xran,iran,dran c write(oo,*)' ener(iran),ener(iran+1),eran=', c + ener(iran),ener(iran+1),eran c endif e=e+eran EGRaf(QGRaf)=eran NAtGRaf(QGRaf)=NAtAC(nshc,nm) NShAtGRaf(QGRaf)=NSheC(nshc,nm) enddo enddo 10 continue ESGraf=e end +DECK,PRIRAFFL. subroutine PriRaffle c print the virt. ioniz. photons implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'raffle.inc' +SEQ,raffle. integer i if(soo.eq.0)return write(oo,*) write(oo,*)' PriRaffle: virt. ioniz. photons' write(oo,*)' QGRaf= ',QGRaf,' ESGRaf=',ESGRaf if(QGRaf.gt.0)then write(oo,*)' EGRaf(i) NAtGRaf(i) NShAtGRaf(i)' do i=1,QGRaf write(oo,'(1X,e12.5,2(i12))') + EGRaf(i), NAtGRaf(i), NShAtGRaf(i) enddo endif end +DECK,GoGam. subroutine GOGam c make absorption of the real photon c and pass it to the virt photon implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'abs.inc' +SEQ,abs. c include 'rga.inc' +SEQ,rga. integer i,j integer isabs,nmat,nmshl c real*8 curpnt(3) c real dnst integer num do i=crga,qrga c do j=1,3 c curpnt(j)=pntrga(j,i) c enddo num=nVolrga(i) call lsta_abs1 + (erga(i),i,pntrga(1,i),velrga(1,i),num, + isabs,nmat,nmshl) if(isabs.eq.1)then if(qtagam .eq. pqtagam)then qOverflowagam=qOverflowagam+1 if(sOverflowagam.eq.0)then qsOverflowagam=qsOverflowagam+1 sOverflowagam=1 endif else qtagam=qtagam+1 etagam(qtagam)=erga(i) do j=1,3 c rtagam(j,qtagam)=curpnt(j) rtagam(j,qtagam)=pntrga(j,i) vtagam(j,qtagam)=velrga(j,i) enddo nVolagam(qtagam)=num nAtagam(qtagam)=nmat nShlagam(qtagam)=nmshl Stagam(qtagam)=Strga(i) c densi(qtagam)=dnst endif else SFrga(i)=1 endif enddo crga=qrga+1 end +DECK,LSTAABS1. subroutine lsta_abs1(eg,nrga,curpnt,veloc,num,isabs,nmat,nmshl) c make step to end of matter or to absorption point c curpnt - current point of photon c veloc - cosine c num - number of volume c isabs - sign of absorbtion implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'abs.inc' +SEQ,abs. real eg,veloc(3) real*8 curpnt(3) integer num integer nrga,isabs,nmat,nmshl c real dnst integer i real*8 mleng,xleng do i=1,1000 ! number of mat is about 10 isabs=0 if(i.eq.1.and.num.ne.0)goto 10 call VolNumZcoor(curpnt(3),veloc(3),num) 10 if(num.eq.0)return call VolPathLeng(curpnt(3),veloc,num,mleng) c write(oo,*)' num=',num,' mleng=',mleng call lsta_abs(eg,nrga,num,mleng,isabs,xleng,nmat,nmshl) curpnt(1)=curpnt(1)+xleng*veloc(1) curpnt(2)=curpnt(2)+xleng*veloc(2) curpnt(3)=curpnt(3)+xleng*veloc(3) if(isabs.eq.1)return enddo end subroutine lsta_abs(eg,nrga,nvol,mleng, + isabs,xleng,nm_at,nmshl) c Raffle the absorbtion in volume number nvol c eg - energy of the photon c isabs - sign of absorbtion c xleng - coord of point of absorbtion c nm_at and nmshl - numbes of the atom and the shell implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'volume.inc' +SEQ,volume. c include 'rga.inc' +SEQ,rga. c include 'shl.inc' +SEQ,shl. real eg real*8 xleng,mleng integer nrga,nvol,isabs,nm_at,nmshl integer nmat c real dnst real rrr(100) integer iarrr(100),isrrr(100) integer ia,is real r,s real ranfl integer i,j,k c integer n real thr integer iatm,natm nmat=nMatVol(nvol) if(nmat.eq.0)then isabs=0 xleng=mleng return endif r=ranfl() if(r.gt.0.99999)then isabs=0 xleng=mleng return endif j=qener+1 do i=2,qener+1 if(eg.lt.ener(i))then j=i-1 go to 10 endif enddo if(j.eq.qener+1)then isabs=0 xleng=mleng return endif 10 k=0 s=0 do ia=1,QAtMat(nmat) do iatm=1,qatm if(Zat(AtMat(ia,nmat)).eq.charge(iatm))then natm=iatm go to 15 endif enddo natm=0 15 do is=1,QShellAt(AtMat(ia,nmat)) c write(oo,*) c + ' ia,AtMat(ia,nmat),is,ThresholdAt(is,AtMat(ia,nmat))=' c write(oo,*) c + ia,AtMat(ia,nmat),is,ThresholdAt(is,AtMat(ia,nmat)) if(natm.eq.0)then thr=ThresholdAt(is,AtMat(ia,nmat)) else thr=eshell(natm,is) endif if(eg.gt.thr)then k=k+1 rrr(k)=PhotAt(j,is,AtMat(ia,nmat)) + *WeightAtMat(ia,nmat) iarrr(k)=ia isrrr(k)=is s=s+rrr(k) c write(oo,*)' PhotAt(j,is,AtMat(ia,nmat))=', c + PhotAt(j,is,AtMat(ia,nmat)) c write(oo,*)' WeightAtMat(ia,nmat)=', c + WeightAtMat(ia,nmat) c write(oo,*)' s=',s endif enddo enddo c write(oo,*)(rrr(i),i=1,3) if(k.eq.0)then isabs=0 xleng=mleng return endif s=s* ElDensMat(nmat)/Z_Mean(nmat) *5.07E10 xleng=-alog(1.0-r)/s c write(oo,*)' xleng=',xleng,' r=',r,' j=',j,' nmat=',nmat c write(oo,*)' k=',k,' eg=',eg,' s=',s if(xleng.gt.mleng)then isabs=0 xleng=mleng else isabs=1 c r=ranfl() call lhispre(rrr,k) c write(oo,*)(rrr(i),i=1,3) call lhisran(rrr,k,1.0,1.0,r) c write(oo,*)' r=',r i=r if(i.lt.1) i=1 if(i.gt.k)i=k nm_at=AtMat(iarrr(i),nmat) nmshl=isrrr(i) c write(oo,*)' i=',i c write(oo,*)' nm_at=',nm_at,' nmshl=',nmshl c dnst=densit(nmat) endif end +DECK,AbsGam. subroutine AbsGam c make absorption in the knowing point c of the all photons in the abs.inc c All of them are transferred to the real photons rga.inc c and to the delta electrons del.inc implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'abs.inc' +SEQ,abs. c real eg,veloc(3),abspnt(3) c integer numat,numshl integer i do i=ctagam,100000 if(i.gt.qtagam)go to 10 call lsta_abs3 + (i,etagam(i),rtagam(1,i),vtagam(1,i), + nVolagam(i),nAtagam(i),nShlagam(i),Stagam(i),upagam(1,i)) enddo 10 ctagam=qtagam+1 end subroutine lsta_abs3(iagam,eg,abspnt,veloc, + nVolagam,nAtagam,nShlagam,Stagam,upagam) c make absorption in the knowing point c and generate secondaries photons and delta electrons c eg - enegy of photon c abspnt - point of absorbtion c nVolagam - number of matter c nAtagam - number of atom c nShlagam - number of shell c Stagam - sign of source of this photon c veloc - direction of veloc. implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'rga.inc' +SEQ,rga. c include 'del.inc' +SEQ,del. c include 'shl.inc' +SEQ,shl. integer iagam real eg,veloc(3) real*8 abspnt(3) integer nVolagam,nAtagam,nShlagam,Stagam,upagam(pqup) real eedel(pqsel),velocdel(3,pqsel) real eedga(pqsga),velocdga(3,pqsga) integer nndel,nndga integer i,j real s call lsta_abs2(eg,abspnt,veloc,nVolagam,nAtagam,nShlagam, + nndel,eedel,velocdel,nndga,eedga,velocdga) if(nndga.gt.0.and.Stagam.eq.9999)then write(oo,*)' Worning of lsta_abs3:' write(oo,*)' too many generetion of secondary ', + ' photons, Stagam=',Stagam,' nndga=',nndga write(oo,*)' Others will be ignored' go to 10 endif s=0.0 do i=1,nndel s=s+eedel(i) enddo do i=1,nndga s=s+eedga(i) enddo c if(s.gt.eg)then if( (s-eg) .gt. 1.0e-6 * (s+eg) )then write(oo,*)'worning of lsta_abs3:', + ' break of energy preservation' write(oo,*)' eg=',eg,' s=',s write(oo,*)' nAtagam=',nAtagam,' nShlagam',nShlagam write(oo,*)' nndel=',nndel do i=1,nndel write(oo,*)' eedel(i)=',eedel(i) enddo do i=1,nndga write(oo,*)' eedga(i)=',eedga(i) enddo endif do i=1,nndga if(qrga .eq. pqrga)then qOverflowrga=qOverflowrga+1 if(sOverflowrga.eq.0)then qsOverflowrga=qsOverflowrga+1 sOverflowrga=1 endif else qrga=qrga+1 c if(qrga.eq.pqrga)then c write(oo,*)' wroning lsta_abs3:', c + ' too much of real photons' c write(oo,*)' other will be ignored' c go to 10 c endif Strga(qrga)=Stagam+1 Ptrga(qrga)=iagam do j=1,pqup uprga(j,qrga)=upagam(j) enddo SFrga(qrga)=0 do j=1,3 pntrga(j,qrga)=abspnt(j) enddo do j=1,3 velrga(j,qrga)=velocdga(j,i) enddo erga(qrga)=eedga(i) nVolrga(qrga)=nVolagam endif enddo 10 continue c write(oo,*)' nndel=',nndel do i=1,nndel if(qdel .eq. pqdel)then qOverflowDel=qOverflowDel+1 if(sOverflowDel.eq.0)then qsOverflowDel=qsOverflowDel+1 sOverflowDel=1 endif else c if(qdel.eq.pqdel)then c write(oo,*)' wroning lsta_abs3:', c + ' too much of delta electr.' c write(oo,*)' other will not be taken into account' c go to 20 c endif qdel=qdel+1 Stdel(qdel)=Stagam Ptdel(qdel)=iagam do j=1,pqup updel(j,qdel)=upagam(j) enddo if(i.eq.1)then SOdel(qdel)=0 else SOdel(qdel)=1 endif do j=1,3 pntdel(j,qdel)=abspnt(j) enddo do j=1,3 veldel(j,qdel)=velocdel(j,i) enddo edel(qdel)=eedel(i) nVoldel(qdel)=nVolagam rangepdel(qdel)=0.0 rangedel(qdel)=0.0 endif enddo 20 end subroutine lsta_abs2(eg,abspnt,veloc,nVolagam,nAtagam,nShlagam, + nndel,eedel,velocdel,nndga,eedga,velocdga) c make absorption in the knowing point c and generate secondaries photons and delta electrons c eg - enegy of photon c abspnt - point of absorbtion c veloc - direction of veloc. c nVolagam - number of matter c nAtagam - number of atom c nShlagam - number of shell c output: c nndel - quantity of delta-electrons c eedel - enegies of the delta-electrons c velocdel - enegies of the delta-electrons c nndga,eedga,velocdga - the same for secondary photons implicit none c include 'shl.inc' +SEQ,shl. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. real eg,veloc(3) real*8 abspnt(3) integer nVolagam,nAtagam,nShlagam real eedel(pqsel),velocdel(3,pqsel) real eedga(pqsga),velocdga(3,pqsga) integer nndel,nndga integer num integer numat,numshl integer i,j real r real hdist real ranfl hdist=0.0 c if(numat.lt.0.or.numat.gt.qatm)then c stop 'wrong numat' c endif c if(numat.gt.0)then c if(numshl.lt.1.or.numshl.gt.qshl(numat))then c stop 'wrong numshl' c endif c endif num=0 c call lsta_fmat(abspnt(3),veloc(3),num) nndel=0 nndga=0 c write(oo,*)' num=',num if(nVolagam.eq.0)then return endif nndel=1 do i=1,3 velocdel(i,nndel)=veloc(i) enddo do i=1,qatm c write(oo,*)' Zat(nAtagam)',Zat(nAtagam) c write(oo,*)' charge(i)',charge(i) if(Zat(nAtagam).eq.charge(i))then numat=i go to 5 endif enddo c The place of question c Several lines was commented eedel(nndel)=eg-ThresholdAt(nShlagam,nAtagam) if(eedel(nndel).le.0.0)then hdist=-eedel(nndel) eedel(nndel)=0.0 endif c c write(oo,*)' nShlagam=',nShlagam, c + ' QShellAt(nAtagam)=',QShellAt(nAtagam) if(nShlagam.lt.QShellAt(nAtagam))then nndel=nndel+1 eedel(nndel)=ThresholdAt(nShlagam,nAtagam)-hdist- + 2.0*ThresholdAt(QShellAt(nAtagam),nAtagam) c eedel(nndel)=ThresholdAt(nShlagam,nAtagam)-hdist if(eedel(nndel).le.0.0)then nndel=nndel-1 goto 2 endif call sfersim(velocdel(1,nndel)) endif 2 continue return 5 continue c asumed that the last shell is zero energy or 1 eV c if(nAtagam.ne.0)then eedel(nndel)=eg-eshell(nShlagam,numat) c write(oo,*)' eg=',eg,' nShlagam=',nShlagam,' numat=',numat c write(oo,*)' eedel(nndel)=',eedel(nndel) c else c eedel(nndel)=eg-20.0e-6 !avarege energy of last shell c endif if(eedel(nndel).le.0.0)then hdist=-eedel(nndel) eedel(nndel)=0.0 endif c if(numat.gt.0)then numshl=nShlagam if(qschl(numshl,numat).gt.0)then r=ranfl() j=qschl(numshl,numat) if(j.gt.0)then j=qschl(numshl,numat) do i=1, qschl(numshl,numat) if(r.lt.secprobch(i,numshl,numat))then j=i go to 10 endif enddo 10 continue c write(oo,*)' prob: r=',r,' j=',j do i=1,qsel(j,numshl,numat) nndel=nndel+1 eedel(nndel)=secenel(i,j,numshl,numat) + -hdist if(eedel(nndel).lt.0)then hdist=-eedel(nndel) eedel(nndel)=0.0 else hdist=0.0 endif call sfersim(velocdel(1,nndel)) enddo do i=1,qsga(j,numshl,numat) nndga=nndga+1 eedga(nndga)=secenga(i,j,numshl,numat) + -hdist if(eedga(nndga).lt.0)then hdist=-eedga(nndga) eedga(nndga)=0.0 else hdist=0.0 endif call sfersim(velocdga(1,nndga)) enddo endif else if(nShlagam.lt.QShellAt(nAtagam))then nndel=nndel+1 eedel(nndel)=eshell(nShlagam,numat)-hdist- + 2.0*eshell(qshl(numat),numat) if(eedel(nndel).le.0.0)then nndel=nndel-1 goto 20 endif call sfersim(velocdel(1,nndel)) endif 20 continue endif c endif end +DECK,IniBdel5. c c Package for tracing of delta-electrons. c subroutine InisBdel c c This is routine for standart initialization. c It is strictly recommended. c c call IniBdel(1,0.0001, 0.00005*4.0e-3, 0.1) call IniBdel(2,0.0001, 0.001*4.0e-3, 0.1) end subroutine IniBdel(psruthBdel,peMinBdel,pmlamBdel,pmTetacBdel) c c Initialization of the delta-eleectron tracing package c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'crosec.inc' +SEQ,crosec. c include 'volume.inc' +SEQ,volume. c include 'bdel.inc' +SEQ,bdel. c include 'cconst.inc' +SEQ,cconst. integer psruthBdel real peMinBdel,pmlamBdel,pmTetacBdel integer n,nm,na,na1,nen real dedx1,sde,sde2 c real dedx,dedx2 real rms,rm(pQAt),adens real mT,A real*8 B,r real msig,x integer sienred real rr,ek,cor real fcalcsCBdel c real s integer nang integer nprev, nnext, qempt integer nempt(pqAt),nqe real*8 k,c real*8 f1,f2,z1,z2 integer nam real*8 sd,st,st1 integer n1,n2,nener sruthBdel=psruthBdel eMinBdel=peMinBdel mlamBdel=pmlamBdel mTetacBdel=pmTetacBdel if(eMinBdel.lt.ener(1))then write(oo,*)' eMinBdel is too small, eMinBdel=',eMinBdel stop endif c do n=2,qener c if(eMinBdel.lt.ener(n))then c iMinBdel=n-1 c go to 10 c endif c enddo c write(oo,*)' worning: eMinBdel is too hige, eMinBdel=',eMinBdel c iMinBdel=qener+1 c10 continue do n=1,3 e1Bdel(n)=0.0 e2Bdel(n)=0.0 e3Bdel(n)=0.0 enddo sturnBdel=0.0 do nm=1,pQMat do nen=1,qener TetacBdel(nen,nm)=0.0 enddo enddo TetaBdel=0.0 c do n=iMinBdel,qener c call IniPart(enerc(n),0.511) c call IniCrosec do nm=1,pQMat if(qAtMat(nm).gt.0)then c if(sMatC(nm).gt.0)then rms=0.0 do na=1,QAtMat(nm) rms=rms+Aat(AtMat(na,nm))*WeightAtMat(na,nm) enddo do na=1,QAtMat(nm) rm(na)=Aat(AtMat(na,nm))*WeightAtMat(na,nm)/rms enddo sienred=0 do n=qener+1,1,-1 if(sienred.eq.0)then sde=0.0 sde2=0.0 do na=1,QAtMat(nm) adens=DensMat(nm)*rm(na) c write(oo,*)' adens=',adens * call lsrelp( * + Aat(AtMat(na,nm)),float(Zat(AtMat(na,nm))),adens, * + 2000.0*ener(n)/1000.0,dedx) * if(dedx.lt.0.0)dedx=0.0 * call lsrelm( * + Aat(AtMat(na,nm)),float(Zat(AtMat(na,nm))),adens, * + 105.65/0.511*ener(n)/1000.0,dedx2) * if(dedx2.lt.0.0)dedx2=0.0 * sde=sde+dedx*adens * sde2=sde2+dedx2*adens enddo * sde=sde*1000.0 * sde2=sde2*1000.0 c call lsrelp( c + A_Mean(nm),Z_Mean(nm),DensMat(nm), c + 2000.0*enerc(n)/1000.0,dedx) c dedx=dedx*DensMat(nm)*1000.0 c eLossBdel(n,nm)=sde call lstREL1(ener(n)/1000.0, -1.0, nm, dedx1) dedx1=dedx1*1000.0 eLossBdel(n,nm)=dedx1 c write(oo,*)' n=',n,' nm=',nm,' ener(n)=',ener(n) c write(oo,*)' sde=',sde, c + ' dedx1=',dedx1 ,' sde2=',sde2 if(n.lt.qener)then if(eLossBdel(n,nm).lt.0.5*eLossBdel(n+1,nm))then sienred=1 eLossBdel(n,nm)=0.5*eLossBdel(n+1,nm) endif endif else eLossBdel(n,nm)=eLossBdel(n+1,nm) endif enddo c endif endif enddo c stop do nen=1,qener beta2Bdel(nen)= + (2.0*ELMAS*enerc(nen) + enerc(nen)*enerc(nen)) / + ((ELMAS + enerc(nen)) * (ELMAS + enerc(nen))) betaBdel(nen) = sqrt(beta2Bdel(nen)) momentum2Bdel(nen)= enerc(nen)*enerc(nen) + 2.0*ELMAS*enerc(nen) momentumBdel(nen) = sqrt(momentum2Bdel(nen)) enddo if(sruthBdel.ne.2)then do nm=1,pQMat if(qAtMat(nm).gt.0)then do nen=1,qener ek=enerc(nen)*1000.0 if(ek.le.10.0)then rr=1.0e-3 * A_Mean(nm)/Z_Mean(nm) * 3.872e-3 * ek ** 1.492 rr=rr/DensMat(nm) else rr=1.0e-3 * 6.97e-3 * ek ** 1.6 rr=rr/DensMat(nm) endif rr=rr*0.1 call correctBdel(enerc(nen),cor) if(sruthBdel.eq.1)then lamBdel=mlamBdel/DensMatDS(nm) if(lamBdel.lt.rr) lamBdel=rr lamBdel=lamBdel*cor c if(sisferBdel.eq.1)then c go to 10 c endif c Calculate the minimum angle for restriction of field by c atomic shell mT=2.0*asin(1.0/ + (2.0*momentumBdel(nen)*Z_Mean(nm)*5.07e2)) rTetacBdel(nen,nm)=mT c write(oo,*)' mT=',mT if(mT.lt.mTetacBdel)then mT=mTetacBdel ! Throw out too slow interaction. They ! do not influent to anything endif c Calculate the cut angle due to mean free part A = RuthMat(nm)/cor/ + (momentum2Bdel(nen)*beta2Bdel(nen))/(5.07e10)**2 B = (lamBdel*A) B = sqrt( B / (B+1.0) ) TetacBdel(nen,nm) = 2.0 * asin(B) c TetacBdel = acos( (B-1.0) / (B+1.0) ) c TetacBdel=2.0*asin(sqrt(lamBdel*A)) c if(TetacBdel.lt.0.2)then c TetacBdel=0.2 c If it too little, reset it. It will lead to increasing c of lamBdel and decriasing of calculation time. if(TetacBdel(nen,nm) .lt. mT)then TetacBdel(nen,nm)=mT B=mT ! B is double precision r=sin(B/2.0) lamBdel=1/A * 2.0 * r*r / ( 1 + cos(B) ) * r=cos(TetacBdel(nen,nm)) * lamBdel=A*(1.0+r)/(1.0-r) * lamBdel=1.0/lamBdel c lamBdel=(p2*bet2*sin(TetacBdel/2.0)**2) / A endif lamaBdel(nen,nm)=lamBdel B=TetacBdel(nen,nm) CosTetac12Bdel(nen,nm)=cos(B/2.0) SinTetac12Bdel(nen,nm)=sin(B/2.0) if(TetacBdel(nen,nm).gt.1.5)then sisferaBdel(nen,nm)=1 else sisferaBdel(nen,nm)=0 endif c debug mode: c lamaBdel(nen,nm)=2.0*lamaBdel(nen,nm) elseif( sruthBdel.eq.0)then ! gaus formula c calculate paht lengt from mTetacBdel msig=mTetacBdel x=msig / ( sqrt(2.0) * 13.6/(betaBdel(nen)*momentumBdel(nen))) x=x*x c x=x/DensMatDS(nMatVol(nVolBdel)) x=x*RLenMat(nm)*cor lamBdel = mlamBdel/DensMatDS(nm) if(lamBdel.lt.rr) lamBdel=rr lamBdel=lamBdel*cor c write(oo,*)' x=',x,' rleng=',rleng c reset if it is too large if(lamBdel.lt.x)lamBdel=x lamaBdel(nen,nm)=lamBdel msigBdel(nen)=sqrt(2.0)*13.6/ + (betaBdel(nen)*momentumBdel(nen)) c debug mode: c lamaBdel(nen,nm)=2.0*lamaBdel(nen,nm) c msigBdel(nen)=0.5*msigBdel(nen) endif enddo ! end of nen endif ! end of if(qAtMat(nm).gt.0)then enddo ! end of nm endif ! if(sruthBdel.ne.2) if(sruthBdel.eq.2)then call logscale0(qanCBdel,0.03,real(PI),anCBdel,ancCBdel) c call readCBdel call read1CBdel enerCBdel( 1) = 0.5E-3 enerCBdel( 2) = 1.5E-3 enerCBdel( 3) = 2.5E-3 enerCBdel( 4) = 5.5E-3 enerCBdel( 5) = 10.5E-3 enerCBdel( 6) = 21.5E-3 enerCBdel( 7) = 42.5E-3 enerCBdel( 8) = 85.5E-3 enerCBdel( 9) = 170.5E-3 enerCBdel(10) = 341.1E-3 enercCBdel( 1) = 1 E-3 enercCBdel( 2) = 2E-3 enercCBdel( 3) = 4E-3 enercCBdel( 4) = 8E-3 enercCBdel( 5) = 16E-3 enercCBdel( 6) = 32E-3 enercCBdel( 7) = 64E-3 enercCBdel( 8) = 128E-3 enercCBdel( 9) = 256E-3 do nen=1,qeaCBdel gammaCBdel(nen) = 1.0 + enercCBdel(nen)/ELMAS beta2CBdel(nen) = ( 2.0 * enercCBdel(nen)/ELMAS + + (enercCBdel(nen)/ELMAS)**2 ) / + gammaCBdel(nen)**2 momentum2CBdel(nen) = + enercCBdel(nen)*enercCBdel(nen) + + 2.0*ELMAS*enercCBdel(nen) enddo do na=1,pqAt if(Zat(na).gt.0)then ! atom is meant initialized do nen=1,qeaCBdel mT=1.0/ + (2.0*sqrt(momentum2CBdel(nen))*Zat(na)*5.07e2) sRcmCBdel(nen,nm)=2.0*asin(mT) sRmCBdel(nen,na)= 1/4. * + Zat(na)*Zat(na)*ELRAD*ELRAD*ELMAS*ELMAS/ + ( momentum2CBdel(nen) * beta2CBdel(nen) * mT**4 ) / + ( 5.07E10 ** 2 ) * 1.E16 do nang=1,qanCBdel sRCBdel(nang,nen,na)= 1/4. * + Zat(na)*Zat(na)*ELRAD*ELRAD*ELMAS*ELMAS/ + ( momentum2CBdel(nen) * beta2CBdel(nen) * + sin(ancCBdel(nang)/2.0)**4 ) / + ( 5.07E10 ** 2 ) * 1.E16 enddo enddo if(sign_ACBdel(na).eq.1)then do nen=1,qeaCBdel do nang=1,qanCBdel sCBdel(nang,nen,na)=fcalcsCBdel(nang,nen,na) enddo enddo endif endif enddo ! Fill an empty places nnext = 0 qempt = 0 ! quantity of the empty places is zero do na1=1,QseqAt na=nseqAt(na1) if(Zat(na).eq.0)then ! atom is meant not initialized write(oo,*)' error in IniBdel' stop endif if(sign_ACBdel(na).eq.1)then nprev=nnext nnext=na endif if(sign_ACBdel(na).eq.0)then qempt=qempt+1 ! add pointer of empty place nempt(qempt)=na endif if(sign_ACBdel(na).eq.1 .and. qempt.ne.0)then if(nprev.eq.0)then ! first filled atom ! fit by k*Z**2 do nen=1,qeaCBdel do nang=1,qanCBdel k=sCBdel(nang,nen,nnext) / Zat(nnext)**2 do nqe=1,qempt sCBdel(nang,nen,nempt(nqe)) = + k *Zat(nempt(nqe))**2 enddo ! nqe=1,qempt enddo ! nang=1,qanCBdel enddo ! nen=1,qeaCBdel qempt=0 else ! fit by previous and this filled atom ! f = k*Z*(Z+c) do nen=1,qeaCBdel do nang=1,qanCBdel f1=sCBdel(nang,nen,nprev) f2=sCBdel(nang,nen,nnext) z1=Zat(nprev) z2=Zat(nnext) c = (f1 * z2**2 - f2 * z1**2 ) / + (f2 * z1 - f1 * z2 ) k = f1 / (z1 * ( z1 + c ) ) do nqe=1,qempt sCBdel(nang,nen,nempt(nqe)) = + k*Zat(nempt(nqe))*(Zat(nempt(nqe)) + c) if(sCBdel(nang,nen,nempt(nqe)).lt.0.) + sCBdel(nang,nen,nempt(nqe)) = 0. enddo enddo enddo qempt=0 endif endif enddo if(qempt.ne.0)then if(nprev.eq.0)then write(oo,*)' error in IniBdel: wrong nprev' stop endif nnext=nprev ! so as to use the same lines as above do nen=1,qeaCBdel do nang=1,qanCBdel k=sCBdel(nang,nen,nnext) / Zat(nnext)**2 do nqe=1,qempt sCBdel(nang,nen,nempt(nqe)) = + k *Zat(nempt(nqe))**2 enddo ! nqe=1,qempt enddo ! nang=1,qanCBdel enddo ! nen=1,qeaCBdel qempt=0 endif c On this point all the atomic cross sections are generated. c Now it is a high time to generate cross sections c for initialized materials. do nm=1,pQMat if(qAtMat(nm).gt.0)then lamBdel=mlamBdel/DensMat(nm) c write(oo,*)' lamBdel=',lamBdel,' mlamBdel=',mlamBdel do nen=1,qeaCBdel do nang=1,qanCBdel sd=0. do nam=1,qAtMat(nm) na=AtMAt(nam,nm) sd = sd + sCBdel(nang,nen,na) * WeightAtMat(nam,nm) enddo sd = sd * 1.0E-16 * 5.07E10 * 5.07E10 c Angstrem**2 -> sm**2 c sm**2 -> MeV**-2 sd=sd * 2.0 * PI * sin(ancCBdel(nang)) smaCBdel(nang,nen,nm)=sd enddo ! nang=1,qanCBdel enddo ! nen=1,qeaCBdel do nener=1,qener ! go to working mesh ! ( The enercCBdel is to rare ) if(enerc(nener).lt.500.0e-6)then do nang=1,qanCBdel smatCBdel(nang,nener,nm)=0.0 enddo lamaBdel(nener,nm)=0.0 tsmatCBdel(nener,nm)=0.0 else ek=enerc(nener)*1000.0 ! Calculate step lenght by usual formula if(ek.le.10.0)then rr = 1.0e-3 * A_Mean(nm)/Z_Mean(nm) * + 3.872e-3 * ek ** 1.492 rr=rr/DensMat(nm) else rr=1.0e-3 * 6.97e-3 * ek ** 1.6 rr=rr/DensMat(nm) endif rrCBdel(nener,nm)=rr rr=rr*koefredCBdel if(rr.lt.lamBdel) rr=lamBdel do nen=2,qeaCBdel if(enercCBdel(nen).gt.enerc(nener))then n2=nen goto 100 endif enddo n2=qeaCBdel 100 continue n1=n2-1 do nang=1,qanCBdel ! Linear interpolation smatCBdel(nang,nener,nm)=smaCBdel(nang,n1,nm) + + (smaCBdel(nang,n2,nm) - smaCBdel(nang,n1,nm)) * + (enerc(nener) - enercCBdel(n1)) / + (enercCBdel(n2) - enercCBdel(n1)) ismatCBdel(nang,nener,nm)= + smatCBdel(nang,nener,nm) + * (anCBdel(nang+1) - anCBdel(nang)) enddo ! nang=1,qanCBdel rr=1.0/ + (rr*(AVOGADRO/(5.07E10 * 5.07E10)) + *DensMat(nm)/A_mean(nm)) st=0.0 ! restrict low angles st1=0.0 do nang=qanCBdel,1,-1 st = st + ismatCBdel(nang,nener,nm) if(st.gt.rr)then goto 110 else st1=st endif enddo ! nang=qanCBdel,1,-1 nang=0 110 continue nang=nang+1 TetacBdel(nener,nm)=anCBdel(nang) tsmatCBdel(nener,nm)=st1 lamaBdel(nener,nm)=1.0/ + (tsmatCBdel(nener,nm)*(AVOGADRO/(5.07E10 * 5.07E10)) + *DensMat(nm)/A_mean(nm)) do n=1,nang-1 ismatCBdel(n,nener,nm)=0.0 enddo call lhispre(ismatCBdel(1,nener,nm),qanCBdel) if(TetacBdel(nener,nm).gt.1.0)then sisferaBdel(nener,nm)=1 endif endif enddo ! nener=1,qener endif enddo c All done ! endif ! if(sruthBdel.eq.2) end subroutine readCBdel implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'crosec.inc' +SEQ,crosec. c include 'volume.inc' +SEQ,volume. c include 'bdel.inc' +SEQ,bdel. character*1 a integer ios integer na,z,i,n,j open(1,FILE='cbdel.dat',IOSTAT=ios,STATUS='OLD') if(ios.ne.0)then write(oo,*)' readCBdel: can not open file readCBdel.dat' stop endif do na=1,pqAt if(Zat(na).gt.0)then ! atom is meant initialized sign_ACBdel(na)=0 ! cleaning do n=1,100000 read(1,'(A1)',END=100)a c write (6,*)a if(a.eq.'$')then backspace (1) read(1,'(A1,I3)')a,z if(z.eq.Zat(na))then write(oo,*)a,z do i=1,4 read(1,*)(ACBdel(i,j,na),j=1,qeaCBdel) enddo do i=0,6 read(1,*)(CCBdel(i,j,na),j=1,qeaCBdel) enddo read(1,*)(BCBdel(j,na),j=1,qeaCBdel) sign_ACBdel(na)=1 ! sign of reading go to 100 endif endif enddo 100 rewind(1) endif enddo close(1) end subroutine read1CBdel c c This subroutine must copy data not from external file c but from internal data arrays (so as to avoid input which c is often machine-dependent) c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'crosec.inc' +SEQ,crosec. c include 'volume.inc' +SEQ,volume. c include 'bdel.inc' +SEQ,bdel. c character*1 a c integer ios integer na,i,n,j c integer z integer psqAt parameter (psqAt=11) ! Now only 11 atoms included integer ZsCBdel(psqAt) ! atomic charge real AsCBdel(4,pqeaCBdel,psqAt) real CsCBdel(0:6,pqeaCBdel,psqAt) real BsCBdel(pqeaCBdel,psqAt) *** Modified on 6/2/97 RV C save /ZsCBdel/,/AsCBdel/,/CsCBdel/,/BsCBdel/ save ZsCBdel,AsCBdel,CsCBdel,BsCBdel *** End of modification. c include 'cbdeldat.inc' +SEQ,cbdeldat. do na=1,pqAt if(Zat(na).gt.0)then ! atom is meant initialized sign_ACBdel(na)=0 ! cleaning do n=1,psqAt if(ZsCBdel(n).eq.Zat(na))then c write(oo,*)a,z do i=1,4 do j=1,qeaCBdel ACBdel(i,j,na)=AsCBdel(i,j,n) enddo enddo do i=0,6 do j=1,qeaCBdel CCBdel(i,j,na)=CsCBdel(i,j,n) enddo enddo do j=1,qeaCBdel BCBdel(j,na)=BsCBdel(j,n) enddo sign_ACBdel(na)=1 ! sign of reading go to 100 endif enddo 100 continue endif enddo end function fcalcsCBdel(nang,nen,na) c c calculates elastic cross section per one atom by fit formula c in Angstrem**2/Srad. (10**-16 sm2 /Srad) c implicit none real fcalcsCBdel integer nang,nen,na c include 'GoEvent.inc' +SEQ,GoEvent. c include 'cconst.inc' +SEQ,cconst. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'volume.inc' +SEQ,volume. c include 'part.inc' +SEQ,part. c include 'bdel.inc' +SEQ,bdel. real*8 ang,cang,cang2,cang3,cang4,cang5,cang6,s,r real*8 coe c integer n integer i ang=ancCBdel(nang) c ang=0.0 cang=cos(ang) cang2=cang *cang cang3=cang2*cang cang4=cang3*cang cang5=cang4*cang cang6=cang5*cang c write(oo,*)' A=',(ACBdel(i,nen,na),i=1,4) c write(oo,*)' C=',(CCBdel(i,nen,na),i=0,6) c write(oo,*)' B=',BCBdel(nen,na) r=0.0 do i=1,4 r=r+ACBdel(i,nen,na) / + (1.0-cang+2.0*dble(BCBdel(nen,na)))**i c write(oo,*)' r=',r enddo r=r+dble(CCBdel(0,nen,na))* + 1.0 c write(oo,*)' r=',r r=r+dble(CCBdel(1,nen,na))* + cang c write(oo,*)' r=',r r=r+dble(CCBdel(2,nen,na))* + 0.5*(3.0*cang2-1.0) c write(oo,*)' r=',r r=r+dble(CCBdel(3,nen,na))* + 0.5*(5.0*cang3 - 3*cang) c write(oo,*)' r=',r r=r+dble(CCBdel(4,nen,na))* + 1.0/8.0 * (35.0*cang4 - 30.0*cang2 + 3.0) c write(oo,*)' r=',r r=r+dble(CCBdel(5,nen,na))* + 1.0/8.0 * (63.0*cang5 - 70.0*cang3 + 15.0*cang) c write(oo,*)' r=',r r=r+dble(CCBdel(6,nen,na))* + 1.0/16.0 * (231.0*cang6 - 315.0*cang4 + 105.0*cang2 -5.0) c write(oo,*)' r=',r s=r c beneath is coefficient from erratum. coe=Zat(na)/(FSCON*FSCON)/(gammaCBdel(nen)*beta2CBdel(nen)) s=s*coe*coe fcalcsCBdel=s end function fcalcsmCBdel(nang,nen,nm) implicit none real fcalcsmCBdel integer nang,nen,nm c include 'GoEvent.inc' +SEQ,GoEvent. c include 'cconst.inc' +SEQ,cconst. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'volume.inc' +SEQ,volume. c include 'part.inc' +SEQ,part. c include 'bdel.inc' +SEQ,bdel. real*8 ang,cang,cang2,cang3,cang4,cang5,cang6,s,r real*8 coe integer n,na,i ang=ancCBdel(nang) c ang=0.0 cang=cos(ang) cang2=cang *cang cang3=cang2*cang cang4=cang3*cang cang5=cang4*cang cang6=cang5*cang s=0.0 do n=1,QAtMat(nm) na=AtMat(n,nm) c write(oo,*)' A=',(ACBdel(i,nen,na),i=1,4) c write(oo,*)' C=',(CCBdel(i,nen,na),i=0,6) c write(oo,*)' B=',BCBdel(nen,na) r=0.0 do i=1,4 r=r+ACBdel(i,nen,na) / + (1.0-cang+2.0*dble(BCBdel(nen,na)))**i write(oo,*)' r=',r enddo r=r+dble(CCBdel(0,nen,na))* + 1.0 write(oo,*)' r=',r r=r+dble(CCBdel(1,nen,na))* + cang write(oo,*)' r=',r r=r+dble(CCBdel(2,nen,na))* + 0.5*(3.0*cang2-1.0) write(oo,*)' r=',r r=r+dble(CCBdel(3,nen,na))* + 0.5*(5.0*cang3 - 3*cang) write(oo,*)' r=',r r=r+dble(CCBdel(4,nen,na))* + 1.0/8.0 * (35.0*cang4 - 30.0*cang2 + 3.0) write(oo,*)' r=',r r=r+dble(CCBdel(5,nen,na))* + 1.0/8.0 * (63.0*cang5 - 70.0*cang3 + 15.0*cang) write(oo,*)' r=',r r=r+dble(CCBdel(6,nen,na))* + 1.0/16.0 * (231.0*cang6 - 315.0*cang4 + 105.0*cang2 -5.0) write(oo,*)' r=',r r=r*WeightAtMat(n,nm) write(oo,*)' r=',r s=s+r enddo coe=Z_Mean(nm)/(FSCON*FSCON)/(gammaCBdel(nen)*beta2CBdel(nen)) s=s*coe*coe fcalcsmCBdel=s end subroutine SeLossBdel(nm,e,i,el) c c Calculation of the energy loss in 1 sm c implicit none c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'volume.inc' +SEQ,volume. c include 'bdel.inc' +SEQ,bdel. integer nm real e,el integer i,i1 ! i is start index i1 is new integer n c if(e.lt.eMinBdel)then c el=0.0 c i1=0 c return c endif if(i.le.0.or.i.gt.qener)then i=qener endif c do n=i,iMinBdel,-1 do n=i,1,-1 if(e.ge.ener(n))then i1=n go to 10 endif enddo c write(oo,*)' Error in FeLossBdel' c stop el=eLossBdel(1,nm) i=1 return 10 continue i=i1 el=eLossBdel(i,nm)+(e-ener(i))* + (eLossBdel(i+1,nm)-eLossBdel(i,nm))/(ener(i+1)-ener(i)) c write(oo,*)' nm,e,i,el=',nm,e,i,el end subroutine SstepBdel c c Calc. of step lenght c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'crosec.inc' +SEQ,crosec. c include 'volume.inc' +SEQ,volume. c include 'bdel.inc' +SEQ,bdel. c real pntBdel(3),velBdel(3),step c integer nv,sgonext integer i real*8 mleng real lossmean real*8 rleng real rr,ek,r,ranfl integer nm if(nVolBdel.eq.0.or.sgonextBdel.eq.1)then !first find the volume c sisferBdel=0 ! obsolete call VolNumZcoor(pntBdel(3),velBdel(3),nVolBdel) if(nVolBdel.eq.0)return !out of geometry c if(sMatC(nMatVol(nVolBdel)).eq.0)return endif c write(oo,*)' pntBdel(3)=',pntBdel(3) c write(oo,*)' velBdel=',velBdel c write(oo,*)' nVolBdel=',nVolBdel c write(oo,*)' mleng=',mleng call VolPathLeng(pntBdel(3),velBdel,nVolBdel,mleng) if(nMatVol(nVolBdel).eq.0)then ! empty volume: no interaction estepBdel=0.0 stepBdel=mleng sgonextBdel=1 sturnBdel=0 go to 10 endif if(eBdel.le.cuteneBdel)then ! the same number in treatdel.f nm=nMatVol(nVolBdel) ek=eBdel*1000.0 if(ek.le.10.0)then rr=1.0e-3 * A_Mean(nm)/Z_Mean(nm) * 3.872e-3 * ek ** 1.492 rr=rr/DensMat(nm) else rr=1.0e-3 * 6.97e-3 * ek ** 1.6 rr=rr/DensMat(nm) endif c rr=rr*0.6 r=ranfl() c rr = rr * (0.3 + 0.8*r) c rr = rr * (0.4 + 1.0*r) rr = rr * (0.3 + 0.8*r) stepBdel=rr if(stepBdel.lt.mleng)then estepBdel=eBdel sgonextBdel=0 else estepBdel=eBdel*mleng/stepBdel sgonextBdel=1 endif sturnBdel=0 go to 10 endif call SeLossBdel(nMatVol(nVolBdel),eBdel,iBdel,lossmean) c if(nevt.eq.1.and.(nBdel.eq.8.or.nBdel.eq.9))then c write(oo,*)' mleng,lossmean=',mleng,lossmean c endif estepBdel=mleng*lossmean stepBdel=mleng sgonextBdel=1 sturnBdel=0 c if(srandoff.ne.1)then if(sruthBdel.eq.1.or.sruthBdel.eq.2)then !lengt to coulomb interaction call SRLengBdel(rleng) else call SMLengBdel(rleng) c rleng=mlamBdel/DensMatDS(nMatVol(nVolBdel)) endif if(stepBdel.gt.rleng)then !reduce step to point of turn stepBdel=rleng estepBdel=rleng*lossmean sgonextBdel=0 sturnBdel=1 endif c endif c if(nevt.eq.1.and.(nBdel.eq.8.or.nBdel.eq.9))then c write(oo,*)' rleng,estepBdel=',rleng,estepBdel c endif if(estepBdel.gt.eMinBdel)then if(estepBdel.gt.0.1*eBdel)then ! reduce the step ... estepBdel=0.1*eBdel ! Maximum ! but not too much: if(estepBdel.lt.eMinBdel)estepBdel=eMinBdel ! For the case when eBdelX+0.5*LOG((273+T C)/(273*P ATM)) C in the function GDRELE C ------------------------ C IF(CON3.LE.12.25)THEN IP=INT((CON3-10.)/0.5)+1 IF(IP.LT.0) IP=0 IF(IP.GT.4) IP=4 CON4=1.6+0.1*FLOAT(IP) CON5=4. ELSE IF(CON3.LE.13.804)THEN CON4=2. CON5=5. ELSE CON4=0.326*CON3-2.5 CON5=5. ENDIF ENDIF ENDIF C XA=CON3/4.606 CON6=4.606*(XA-CON4)/(CON5-CON4)**3. X0=CON4 X1=CON5 AA=CON6 C X=LOG(GAM2-1.)/4.606 DEL=0. IF(X.GT.X0)THEN DEL=4.606*X+C IF(X.LE.X1)DEL=DEL+AA*(X1-X)**3. ENDIF C DEDX=CONS*FAC*(LOG(2.*T+4.)-2.*POTL+F-DEL)/BET2 IF(DEDX.LT.0.)DEDX=0. C 99 RETURN END +DECK,Inidel. subroutine Inidel c c Initialize the delta eleectrons c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'del.inc' +SEQ,del. qdel=0 sOverflowDel=0 if(nevt.eq.1)then qOverflowDel=0 qsOverflowDel=0 endif end subroutine WorPridel implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'del.inc' +SEQ,del. c integer i,j if(nevt.eq.qevt)then if(qOverflowDel.gt.0)then write(oo,*) write(oo,*)' WorPridel: overflow of delta electrons arrays ' write(oo,*)' sOverflowDel qsOverflowDel qOverflowDel' write(oo,*)sOverflowDel,qsOverflowDel,qOverflowDel endif endif end subroutine Pridel c print the delta electrons implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'del.inc' +SEQ,del. integer i,j if(soo.eq.0)return write(oo,*) write(oo,*)' Pridel: delta electron' write(oo,*)' sOverflowDel qsOverflowDel qOverflowDel' write(oo,*)sOverflowDel,qsOverflowDel,qOverflowDel write(oo,*)' qdel= ',qdel if(qdel.gt.0)then write(oo,*) + ' ndel zdel edel nVoldel Stdel ', + 'Ptdel updel(1) SOdel', + ' rangepdel rangedel qstep' write(oo,*) + ' pntdel(1,i) pntdel(2,i) pntdel(3,i) ', + ' veldel(1,i) veldel(2,i) veldel(3,i) ' do i=1,qdel write(oo, + '(1X,I5,2(1X,e10.5),1(1X,I3),1(1X,I5),3(1X,I3),2(1X,E9.4),I6)') + i,zdel(i),edel(i),nVoldel(i),Stdel(i),Ptdel(i), + updel(1,i), + SOdel(i),rangepdel(i),rangedel(i),qstepdel(i) write(oo,'(6(1X,e12.5))')(pntdel(j,i),j=1,3), + (veldel(j,i),j=1,3) enddo endif end +DECK,treatdel. subroutine treatdel c c make absorbtion af delta electrons c write it to the cel.inc implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'hist.inc' +SEQ,hist. c include 'del.inc' +SEQ,del. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'crosec.inc' +SEQ,crosec. c include 'volume.inc' +SEQ,volume. c include 'cel.inc' +SEQ,cel. c include 'bdel.inc' +SEQ,bdel. c include 'cconst.inc' +SEQ,cconst. c include 'hconst.inc' *** Added TRACK common to select tracing of delta's (RV 21/2/97). +SEQ,DIMENSIONS. +SEQ,PARAMETERS. *** End of modification. integer id integer k integer q integer j integer ti *** Modification for tracking delta's (RV 10/2/97) INTEGER IFAIL *** End of modification. real*8 h real rra,rrb c integer cV integer cSV integer qn c real e,rr(4) integer sact real v3 c integer s_change_dir, n_change_dir * c data n_change_dir/1/ real*8 s c real mod_add c real add(3) c real ranfl c real bet,p,x real msig c real alog,sqrt real WW,FF ti=0 c if(srandoff.eq.1)then c n_change_dir=10000 c endif c s_change_dir=n_change_dir c next 3 lines must be done in Inicel called from GoEvent c do k=1,QSVol c qcel(k)=0 c enddo do id=1,qdel ! main loop c call IniIonen c write(oo,*)' id=',id c write(oo,*)' rionener=', rionener nBdel=id ti=0 rangBdel=0.0 rangpBdel=0.0 nstepBdel=0 nVolBdel=nVoldel(id) if(sSensit(nVolBdel) .eq. 0)then sact=1 else sact=0 endif c if(srandoff.eq.1)then c nVolBdel=6 c eBdel=esimtran c edel(id)=eBdel c pntBdel(1)=0.0 c pntBdel(2)=0.0 cc pntBdel(3)=wall1(nVolBdel)+ cc + (wall2(nVolBdel)-wall1(nVolBdel))*0.5 c pntBdel(3)=29.0 c velBdel(1)=0.0 c velBdel(2)=0.0 c velBdel(3)=1.0 c do j=1,3 c pntdel(j,id)=pntBdel(j) c veldel(j,id)=velBdel(j) c enddo c c else eBdel=edel(id) do j=1,3 pntBdel(j)=pntdel(j,id) velBdel(j)=veldel(j,id) enddo if(eBdel.le.2.0*cuteneBdel)then c call PriBdel(1) c make the turn if the energy is too small c the electron must be traced by simple formula c for range without multiple scatering c so as it could be sensible if(eBdel.le.cuteneBdel)then msig=0.4 else if(eBdel.le.2.0*cuteneBdel)then msig=0.2 endif endif call lranor(rra,rrb) TetaBdel=rra*msig call MakeNewSys(e1Bdel,e2Bdel,e3Bdel,velBdel) call turnvec(e1Bdel,e2Bdel,e3Bdel,TetaBdel,velBdel) c call PriBdel(1) endif c endif sgonextBdel=0 sturnBdel=0 sisferBdel=0 iBdel=0 stepBdel=0.0 c call MakeNewSys(e1Bdel,e2Bdel,e3Bdel,velBdel) if(nVolBdel.eq.0)then c call lstdelo go to 20 endif if(eBdel.le.0.000001)then c if(eBdel.le.eMinBdel)then c call lstdelo go to 20 endif c if(sMatC(nMatVol(nVolBdel)).eq.0)then c call lstdelo c go to 20 c endif 10 continue *** Moved next statement after CALL SSTEPBDEL (RV 16/2/99) C nstepBdel=nstepBdel+1 *** End of modification. c call PriBdel(1) * if(s_change_dir.eq.1)then * if(sgonextBdel.eq.0.and.stepBdel.gt.0.0)then ** c e=eBdel c cV=nVolBdel c rr(1)=(1.0E-5/DensMat(nMatVol(cV))) c + *1.0E4*(e*1.0E3)**1.5 c rr(1)=rr(1)/10000.0 c rr(2)=0.71*(e**1.72)/DensMat(nMatVol(cV)) c rr(3)=0.2115*(Z_Mean(nMatVol(cV))**0.26)* c + e**(1.265-0.0954*alog(e))/DensMat(nMatVol(cV)) c c e=e*1000 c rr(4)=1.225e-3*e**1.912/DensMat(nMatVol(cV)) c e=e/1000 c write(oo,*)' rr=',rr c stop c bet=1.0-ELMAS*ELMAS/((ELMAS+eBdel)*(ELMAS+eBdel)) c bet=sqrt(bet) c p=eBdel*eBdel+2.0*ELMAS*eBdel c p=sqrt(p) c x=stepBdel/RLenMat(nMatVol(nVolBdel)) c msig=sqrt(2.0)*13.6/(bet*p)* c + sqrt(x) *cc msig=sqrt(2.0)*13.6/(bet*p)* *cc + sqrt(x)* *cc + (1.0 + 0.20*alog(x)) c write(oo,*)' eBdel,stepBdel=',eBdel,stepBdel c write(oo,*)' msig=',msig * *c call PriBdel(1) *c write(oo,*)' bet,p=',bet,p *c write(oo,*)' x,msig=',x,msig * mod_add=0.1*abs(ranfl()) * if(srandoff.eq.1)then * mod_add=mod_add*0.001 * endif * if(mod_add.gt.0.9)mod_add=0.9 * call sfersim(add) * s=0.0 * do j=1,3 * velBdel(j)=velBdel(j)+mod_add*add(j) * s=s+velBdel(j)*velBdel(j) * enddo * s=sqrt(s) * do j=1,3 * velBdel(j)=velBdel(j)/s * enddo *cc write(oo,*)' next velBdel=',velBdel * s_change_dir=n_change_dir *cc irnc=n_change_dir * endif * else * s_change_dir=s_change_dir-1 * endif *** Modified the following line, original follows (RV 16/2/99). C call SstepBdel C if(nVolBdel.eq.0)then ! this is current numbers C go to 20 C endif *** New lines, forcing volume search when tracing deltas. IF(LTREXB)NVOLBDEL=0 CALL SSTEPBDEL IF(NVOLBDEL.EQ.0)THEN PRINT *,' !!!!!! TREATD WARNING : Delta electron'// - ' has left tracking area; delta incomplete.' GOTO 20 ENDIF NSTEPBDEL=NSTEPBDEL+1 *** End of modification. if(sSensit(nVolBdel) .eq. 0)then c if(sgonextBdel.eq.1)then sact=1 endif if(estepBdel.gt.0)then c if(sMatC(nMatVol(nVolBdel)).eq.0)then c call lstdelo c go to 20 c endif if(srandoff.ne.1)then if(eBdel.gt.cuteneBdel)then if(estepBdel.lt.eBdel)then call lranor(rra,rrb) if(rra.lt.-2.0)rra=-2.0 if(rra.gt. 2.0)rra= 2.0 estepBdel=estepBdel+0.33333*estepBdel*rra if(estepBdel.gt.eBdel)estepBdel=eBdel endif endif endif if(sSensit(nVolBdel).eq.1)then if(nMatVol(nVolBdel).gt.0)then ! not a vacuum if(WWW(nMatVol(nVolBdel)).gt.0)then WW=WWW(nMatVol(nVolBdel)) FF=FFF(nMatVol(nVolBdel)) if(estepBdel.gt.0)then if(estepBdel.ne.eBdel)then call lsgcele(estepBdel,WW,FF,q) else call lsgcele1(estepBdel,WW,FF,q) c call lsgcele(estepBdel,WW,FF,q) endif if(q.gt.0)then h=stepBdel/q cSV=numSensVol(nVolBdel) c if(cSV.gt.0)then if((qcel(cSV)+q) .gt. pqcel)then qOverflowCel(cSV)=qOverflowCel(cSV)+q if(sOverflowCel(cSV).eq.0)then qsOverflowCel(cSV)=qsOverflowCel(cSV)+1 sOverflowCel(cSV)=1 endif else do k=1,q qcel(cSV)=qcel(cSV)+1 *** Modification to trace delta's in E and B fields (RV 21/2/97). IF(LTREXB.AND.LTRDEL)THEN IF(K.EQ.1)THEN CALL TRAEXB(pntBdel,velBdel, ! Start - pntcel(1,qcel(csV),csV),velBdel, ! End - eBdel,h,IFAIL) ! Energy, step ELSE CALL TRAEXB( - pntcel(1,qcel(csV)-1,csV),velBdel, ! Start - pntcel(1,qcel(csV),csV),velBdel, ! End - eBdel-(k-1)*estepBdel/q,h,IFAIL) ! Energy, step ENDIF ELSE do j=1,3 pntcel(j,qcel(cSV),cSV)= + pntBdel(j)+velBdel(j)*k*h enddo ENDIF *** End of modification. zcel(qcel(cSV),cSV)=1 Ndelcel(qcel(cSV),cSV)=id sactcel(qcel(cSV),cSV)=sact enddo *** Addition: update the location and reference frame (RV 11/2/97) IF(LTREXB)THEN DO J=1,3 npntBdel(j)=pntcel(j,qcel(csV),csV) ENDDO call MakeNewSys(e1Bdel,e2Bdel,e3Bdel,velBdel) ENDIF *** End of addition. if(shfillrang.eq.1)then c make the change only for first and last electrons s=0.0 qn=q-1 do j=1,3 s = s + + (pntcel(j,(qcel(cSV)-qn),cSV) + - pntdel(j,nBdel)) * veldel(j,nBdel) enddo if(s.gt.rangpBdel)then rangpBdel=s endif if(q.gt.1)then s=0.0 do j=1,3 s = s + + (pntcel(j,qcel(cSV),cSV) + - pntdel(j,nBdel)) * veldel(j,nBdel) enddo if(s.gt.rangpBdel)then rangpBdel=s endif endif endif endif c call Pricel c if(nevt.eq.17.or.nevt.eq.18)then c call PriBdel(1) c write(oo,*)' q=',q,' rangpBdel=',rangpBdel c endif endif endif endif endif endif endif do j=1,3 pntBdel(j)=npntBdel(j) enddo eBdel=eBdel-estepBdel rangBdel=rangBdel+stepBdel * if(shfillrang.eq.1)then c It is enouph to do at the end of each step! c It was wrong algorithm becouse c the electrons are created not on the each step * s=0.0 * do j=1,3 * s=s+(pntBdel(j)-pntdel(j,nBdel))*veldel(j,nBdel) * enddo * if(s.gt.rangpBdel)then * rangpBdel=s * endif * endif c if(eBdel.le.eMinBdel)then if(eBdel.le.0.000001)then c call lstdelo go to 20 endif c The treatment of the electric and magnetic field c Now it will be very preliminary. c Calculate the actual velocity if(sturnBdel.eq.1)then c if(ti.le.1)then ti=ti+1 v3=velBdel(3) call TurnBdel if(sgonextBdel.eq.1)then if(v3.lt.0.and.velBdel(3).gt.0)then sgonextBdel=0 else if(v3.gt.0.and.velBdel(3).lt.0)then sgonextBdel=0 endif endif endif c endif endif go to 10 20 continue *** Changed (RV 13/5/97). C call hfill(nh2_ard,rangBdel,edel(id),1.0) call hfill(nh2_ard,real(rangBdel),edel(id),1.0) *** End of change. rangedel(nBdel)=rangBdel if(shfillrang.eq.1)then call hfill(nh2_rd,real(rangpBdel),edel(id),1.0) call hfill(nh1_rd,real(rangpBdel),0.0,1.0) rangepdel(nBdel)=rangpBdel endif qstepdel(nBdel)=nstepBdel enddo end subroutine lsgcele(e,WW,FF,irn) implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'hconst.inc' c include 'lsmabs.inc' real wmabs,fmabs,e,RN,SIGMA,YY,DIMMY,w,wr real WW,FF real r integer irn,i real ranfl wmabs=WW c wmabs=rionener c wmabs=0.000026 fmabs=FF c fmabs=0.19 c write(oo,*)' srandoff=',srandoff,' wmabs=',wmabs if(srandoff.eq.1)then fmabs=0.0 endif if(e.gt.0.0)then RN=E/wmabs SIGMA=SQRT(fmabs*RN) CALL LRANOR(YY,DIMMY) c RN=RN+YY*SIGMA+0.4999 r=YY*SIGMA ! so as to prevent shift if(r.lt.-RN)then r=-RN elseif(r.gt.RN)then r=RN endif c if(r.lt.-1.0)then c r=-1.0 c elseif(r.gt.1.0)then c r=1.0 c endif RN=RN+r if(rn.le.0.0)then irn=0 return endif i=rn w=1.0-(rn-i) wr=ranfl() ! this is very small random. ! I don't want to swich it off c write(oo,*)' e,rn,i,w,wr=' c write(oo,*)e,rn,i,w,wr if(wr.lt.w)then rn=i else rn=i+1 endif IF(RN.LT.0.0)RN=0.0 else RN=0.0 endif irn=rn end subroutine lsgcele1(e,WW,FF,irn) implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'hconst.inc' c include 'lsmabs.inc' real wmabs,fmabs,e,RN,SIGMA,YY,DIMMY,w,wr real WW,FF real vmabs real r integer irn,i real ranfl wmabs=WW c wmabs=rionener c vmabs=0.000028 c vmabs=wmabs*1.5 c vmabs=wmabs vmabs=wmabs*0.5 c vmabs=0.0000266 if(e.le.vmabs)then irn=1 return endif c wmabs=0.000026 fmabs=FF c fmabs=0.19 c write(oo,*)' srandoff=',srandoff if(srandoff.eq.1)then fmabs=0.0 endif if(e.gt.0.0)then RN=(E-vmabs)/wmabs SIGMA=SQRT(fmabs*RN) CALL LRANOR(YY,DIMMY) c RN=RN+YY*SIGMA+0.4999 r=YY*SIGMA ! so as to prevent shift if(r.lt.-RN)then r=-RN elseif(r.gt.RN)then r=RN endif c if(r.lt.-1.0)then c r=-1.0 c elseif(r.gt.1.0)then c r=1.0 c endif RN=RN+r if(rn.le.0.0)then irn=1 return endif i=rn w=1.0-(rn-i) wr=ranfl() ! this is very small random. ! I don't want to swich it off c write(oo,*)' e,rn,i,w,wr=' c write(oo,*)e,rn,i,w,wr if(wr.lt.w)then rn=i else rn=i+1 endif IF(RN.LT.0.0)RN=0.0 else RN=0.0 endif c IF(RN.LT.1.0)RN=1.0 rn=rn+1 irn=rn end +DECK,Inicel. subroutine Inicel c Initialize the current electrons implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'volume.inc' +SEQ,volume. c include 'cel.inc' +SEQ,cel. integer k do k=1,QSVol qcel(k)=0 sOverflowCel(k)=0 enddo if(nevt.eq.1)then do k=1,QSVol qOverflowCel(k)=0 qsOverflowCel(k)=0 enddo endif end subroutine WorPricel c print the current electrons implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'volume.inc' +SEQ,volume. c include 'cel.inc' +SEQ,cel. integer k if(nevt.eq.qevt)then do k=1,QSVol if(qOverflowCel(k).gt.0)then go to 10 endif enddo return 10 continue write(oo,*) write(oo,*)' WorPricel: overflow of curren electrons arrays ' write(oo,*)' QSVol=',QSVol do k=1,QSVol write(oo,*)' number of lay =',k write(oo,*)' sOverflowCel qsOverflowCel qOverflowCel' write(oo,*)sOverflowCel(k),qsOverflowCel(k),qOverflowCel(k) enddo endif end subroutine Pricel c print the current electrons implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'volume.inc' +SEQ,volume. c include 'cel.inc' +SEQ,cel. integer k,i,j if(soo.eq.0)return write(oo,*) write(oo,*)' Pricel: curren electrons ' write(oo,*)' QSVol=',QSVol do k=1,QSVol write(oo,*)' number of lay =',k write(oo,*)' sOverflowCel qsOverflowCel qOverflowCel' write(oo,*)sOverflowCel(k),qsOverflowCel(k),qOverflowCel(k) if(qcel(k).gt.0)then write(oo,*)' qcel(k)= ',qcel(k) write(oo,*)' szcel(k)= ',szcel(k) write(oo,*) + ' ncel zcel Ndelcel sactcel' write(oo,*) + ' pntcel(1,i,k) pntcel(2,i,k) pntcel(3,i,k) ' do i=1,qcel(k) write(oo,'(i5,1(1X,e12.5),5(1X,I5))') + i,zcel(i,k), + Ndelcel(i,k),sactcel(i,k) write(oo,'(3(1X,e15.8))')(pntcel(j,i,k),j=1,3) enddo endif enddo end +DECK,treatcel. subroutine treatcel c c Calculate the total charge c implicit none c include 'volume.inc' +SEQ,volume. c include 'cel.inc' +SEQ,cel. integer i,j real s c real r,cr do i=1,QSVol s=0 do j=1,qcel(i) s=s+zcel(j,i) enddo szcel(i)=s enddo end +DECK,SourcePh. subroutine SourcePhot(pnt,vel,e) c c Source of the photons c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'rga.inc' +SEQ,rga. real vel(3),e real*8 pnt(3) integer i,nv,nqup nv=0 call VolNumZcoor(pnt(3),vel(3),nv) if(nv.eq.0)then write(oo,*) + ' worning of SourcePhot: the source can not light out of set' return endif if(qrga .eq. pqrga)then qOverflowrga=qOverflowrga+1 if(sOverflowrga.eq.0)then qsOverflowrga=qsOverflowrga+1 sOverflowrga=1 endif else qrga=qrga+1 erga(qrga)=e do i=1,3 pntrga(i,qrga)=pnt(i) velrga(i,qrga)=vel(i) enddo nVolrga(qrga)=nv c Strga(qrga)=10000 in this case it need to settle c the number of transition volume c It is used in lsta_abs Strga(qrga)=1 Ptrga(qrga)=0 do nqup=1,pqup uprga(nqup,qrga)=0 enddo SFrga(qrga)=0 endif end +DECK,SourceDe. subroutine SourceDelEl(pnt,vel,e) c c Auxiliary generator of delta-electron. c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'del.inc' +SEQ,del. real e,vel(3) real*8 pnt(3) integer nv,j,nqup c integer i nv=0 call VolNumZcoor(pnt(3),vel(3),nv) if(nv.eq.0)then write(oo,*) + ' worning of SourceDelEl: the source can not light out of set' return endif if(qdel .eq. pqdel)then qOverflowDel=qOverflowDel+1 if(sOverflowDel.eq.0)then qsOverflowDel=qsOverflowDel+1 sOverflowDel=1 endif else qdel=qdel+1 Ptdel(qdel)=0 Stdel(qdel)=1 do nqup=1,pqup updel(nqup,qdel)=0 enddo SOdel(qdel)=0 do j=1,3 pntdel(j,qdel)=pnt(j) enddo do j=1,3 veldel(j,qdel)=vel(j) enddo zdel(qdel)=1 edel(qdel)=e nVoldel(qdel)=nv rangepdel(qdel)=0.0 rangedel(qdel)=0.0 endif end +DECK,vectors. c several subroutines for vector algebra c single accuracy subroutine GoOldSys(e1,e2,e3,v,ov) c c Go to old system c implicit none real e1(3),e2(3),e3(3) ! coordinates of new orts in the old real v(3) ! vector in the new system real ov(3) ! vector in the old system c real s c integer i ov(1)=v(1)*e1(1) + v(2)*e2(1) + v(3)*e3(1) ov(2)=v(1)*e1(2) + v(2)*e2(2) + v(3)*e3(2) ov(3)=v(1)*e1(3) + v(2)*e2(3) + v(3)*e3(3) c write(6,*)' GoOldSys' c write(6,*)' v=',v c write(6,*)' ov=',ov c write(6,*)' e1=',e1 c write(6,*)' e2=',e2 c write(6,*)' e3=',e3 c s=0.0 c do i=1,3 c s=s+e1(i)*e1(i) c enddo c write(6,*)' abs(e1)=',s c s=0.0 c do i=1,3 c s=s+e2(i)*e2(i) c enddo c write(6,*)' abs(e2)=',s c s=0.0 c do i=1,3 c s=s+e3(i)*e3(i) c enddo c write(6,*)' abs(e3)=',s c s=0.0 c do i=1,3 c s=s+ov(i)*ov(i) c enddo c write(6,*)' abs(ov)=',s end subroutine MakeNewSys(e1,e2,e3,v) c c Make new system c implicit none real e1(3),e2(3),e3(3) ! coordinates of new orts in the old real v(3) ! vector (equal) real s integer i do i=1,3 e3(i)=v(i) enddo if(e3(2).eq.0.0.and.e3(3).eq.0.0)then e1(1)=0.0 e1(2)=0.0 e1(3)=-1.0 e2(1)=0.0 e2(2)=1.0 e2(3)=0.0 c write(6,*)' v=',v c write(6,*)' e1=',e1 c write(6,*)' e2=',e2 c write(6,*)' e3=',e3 return endif e2(1)=0.0 e2(2)=e3(3) e2(3)=-e3(2) s=0.0 do i=1,3 s=s+e2(i)*e2(i) enddo s=sqrt(s) do i=1,3 e2(i)=e2(i)/s enddo e1(1)=e2(2)*e3(3)-e3(2)*e2(3) e1(2)=e3(1)*e2(3)-e2(1)*e3(3) e1(3)=e2(1)*e3(2)-e3(1)*e2(2) s=0.0 do i=1,3 s=s+e1(i)*e1(i) enddo s=sqrt(s) do i=1,3 e1(i)=e1(i)/s enddo c write(6,*)' MakeNewSys' c write(6,*)' v=',v c write(6,*)' e1=',e1 c write(6,*)' e2=',e2 c write(6,*)' e3=',e3 c s=0.0 c do i=1,3 c s=s+e1(i)*e1(i) c enddo c write(6,*)' abs(e1)=',s c s=0.0 c do i=1,3 c s=s+e2(i)*e2(i) c enddo c write(6,*)' abs(e2)=',s c s=0.0 c do i=1,3 c s=s+e3(i)*e3(i) c enddo c write(6,*)' abs(e3)=',s c s=0.0 c do i=1,3 c s=s+e1(i)*e2(i) c enddo c write(6,*)' e1*e2=',s c s=0.0 c do i=1,3 c s=s+e2(i)*e3(i) c enddo c write(6,*)' e2*e3=',s c s=0.0 c do i=1,3 c s=s+e3(i)*e1(i) c enddo c write(6,*)' e3*e1=',s c s=0.0 c do i=1,3 c s=s+v(i)*v(i) c enddo c write(6,*)' abs(v)=',s end subroutine Ncirclesim(e1,e2,e3,v) c c generate vector with circle simmetry in the system c around e3 axis implicit none real e1(3),e2(3),e3(3) ! coordinates of new orts in the old real v(3) ! vector (equal) c real ranfl real r(3) c real s c integer i call circlesim(r) c write(6,*)' Ncirclesim' c s=0.0 c do i=1,3 c s=s+r(i)*r(i) c enddo c write(6,*)' s=',s call GoOldSys(e1,e2,e3,r,v) c write(6,*)' Ncirclesim' c s=0.0 c do i=1,3 c s=s+e3(i)*v(i) c enddo c write(6,*)' s=',s c s=0.0 c do i=1,3 c s=s+v(i)*v(i) c enddo c write(6,*)' s=',s c write(6,*)' e3=',e3 c write(6,*)' v=',v end subroutine circlesim(v) c c generate vector with circle simmetry around e3 c around z axis implicit none real v(3) ! vector (equal) real ranfl real F F=3.14159*2.0*ranfl() v(1)=cos(F) v(2)=sin(F) v(3)=0.0 end subroutine sfersim(r) c c generate vector with sferical simmetry c implicit none real r(3) real costeta,sinteta,F real RANFL c real RANFL,COS,SIN,sqrt C SFERICAL SIMMETRY costeta=1.0-2.0*RANFL() sinteta=sqrt(1.0-costeta*costeta) F=3.14159*2.0*RANFL() r(1)=COS(F)*sinteta r(2)=SIN(F)*sinteta r(3)=costeta end subroutine turnvec(e1,e2,e3,teta, v) c c turn the vector c assumed that old vector is along e3 axis c the angle phi is rundom implicit none c include 'cconst.inc' +SEQ,cconst. real e1(3),e2(3),e3(3) ! coordinates of current orts in the old real v(3) ! vector (equal) real teta integer n,i real rad(3),rss c real sqrt if(Teta.lt.0.0)Teta=-Teta if(Teta.gt.4.0*PI)then n=Teta/(4.0*PI) Teta=Teta-n*4.0*PI endif if(Teta.gt.2.0*PI)then Teta=4.0*PI-Teta endif if(Teta.eq.PI)then do i=1,3 v(i)=-e3(i) enddo elseif(Teta.eq.0.0)then do i=1,3 v(i)=e3(i) enddo else call Ncirclesim(e1,e2,e3,rad) rss=tan(Teta) if(rss.lt.0.0)then rss=-rss n=-1 else n=1 endif do i=1,3 rad(i)=rad(i)*rss v(i)=n*e3(i)+rad(i) enddo rss=0.0 do i=1,3 rss=rss+v(i)*v(i) enddo rss=sqrt(rss) do i=1,3 v(i)=v(i)/rss enddo endif c write(6,*)' turnvec' c write(6,*)' teta=',teta c write(6,*)' e1=',e1 c write(6,*)' e2=',e2 c write(6,*)' e3=',e3 c write(6,*)' v=',v c rss=0.0 c do i=1,3 c rss=rss+e3(i)*v(i) c enddo c rss=acos(rss) c write(6,*)' rss=',rss end +DECK,random. subroutine Iniranfl c c Initialize the random numbers generator c iranfl is intent for calc. of number of call of geenerator c It is so as it can be possible to figer out, where the c new circle starts, if the user knows the period. c implicit none c include 'random.inc' +SEQ,random. c real*8 iranfl c common / comran / iranfl c save / comran / iranfl=0 end function ranfl() c c Random numbers generator c implicit none real ranfl,ranf real x c include 'random.inc' +SEQ,random. c real*8 iranfl c common / comran / iranfl c save / comran / iranfl=iranfl+3 c The several preliminary calls to avoid correlations c between the previous and the next value. x=ranf() x=ranf() ranfl=ranf() ! CERNLIB return end subroutine randset c c set the start point c implicit none c include 'random.inc' +SEQ,random. call ranset(rseed) end subroutine randget c c get the current point c implicit none c include 'random.inc' +SEQ,random. call ranget(rseed) end subroutine randpri(oo) c c print the current point c implicit none integer oo c include 'random.inc' +SEQ,random. write(oo,*)'seed=',seed end subroutine Priranfl c It is called at the end of program implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'random.inc' +SEQ,random. c real*8 iranfl c common / comran / iranfl c save / comran / if(soo.eq.0)return write(oo,*) write(oo,*)' Priranfl: iranfl=',iranfl end SUBROUTINE LRANOR(A,B) C. c Copy of the geant321 routine GRANOR for ranfl generator C. ****************************************************************** C. * * C. * To generate 2 numbers A and B following a NORMAL * C. * distribution (mean=0 sigma=1.) * C. * Copy of the CERN Library routine RANNOR * C. * * C. * ==>Called by : , many GEANT routines * C. * Author F.Carminati ********* * C. * * C. ****************************************************************** C. * DIMENSION RNDM(2) * * CALL GRNDM(RNDM,2) Y=ranfl() Z=ranfl() X=6.283185*Z A1=SQRT (-2.0*LOG(Y)) A=A1*SIN (X) B=A1*COS (X) RETURN END SUBROUTINE LSPOIS (AMU,N,IERROR) C c This is modified library routine poissn. c One or two errors was corrected here. c C POISSON GENERATOR C CODED FROM LOS ALAMOS REPORT LA-5061-MS C PROB(N)=EXP(-AMU)*AMU**N/FACT(N) C WHERE FACT(N) STANDS FOR FACTORIAL OF N C ON RETURN IERROR.EQ.0 NORMALLY C IERROR.EQ.1 IF AMU.LE.0. C SAVE !my correction DATA AMUOL/-1./ DATA AMAX/100./ c write(6,*)' amu=',amu IERROR=0 !my correction IF(AMU.GT.AMAX) GO TO 500 IF(AMU.EQ.AMUOL) GO TO 200 IF(AMU.GT.0.) GO TO 100 C MEAN SHOULD BE POSITIVE IERROR=1 N = 0 RETURN C SAVE EXPONENTIAL FOR FURTHER IDENTICAL REQUESTS 100 IERROR=0 AMUOL=AMU EXPMA=EXP(-AMU) 200 PIR=1. c write(6,*)' ierror=',ierror N=-1 300 N=N+1 c PIR=PIR*RNDM(N) PIR=PIR*ranfl() IF(PIR.GT.EXPMA) GO TO 300 RETURN C NORMAL APPROXIMATION FOR AMU.GT.AMAX 500 CALL LRANOR(RAN,DUMMY) N=RAN*SQRT(AMU)+AMU+.5 RETURN C ENTRY FOR USER TO SET AMAX, SWITCHOVER POINT TO NORMAL APPROXIMATION ENTRY lPOISET(AMU) PRINT 1001,AMU 1001 FORMAT(77H POISSON RANDOM NUMBER GENERATOR TO SWITCH TO NORMAL APP CROXIMATION ABOVE AMU= ,F12.2) AMAX=AMU RETURN END SUBROUTINE lHISRAN(Y,N,XLO,XWID,XRAN) c corrected for working with program HEED C SUBROUTINE TO GENERATE RANDOM NUMBERS C ACCORDING TO AN EMPIRICAL DISTRIBUTION C SUPPLIED BY THE USER IN THE FORM OF A HISTOGRAM C F. JAMES, MAY, 1976 DIMENSION Y(*) DATA IERR,NTRY,NXHRAN,NXHPRE/0,3HRAN,3HRAN,3HPRE/ IF(Y(N).EQ.1.0) GOTO 200 WRITE(6,1001) Y(N) 1001 FORMAT('0SUBROUTINE HISRAN FINDS Y(N) NOT EQUAL TO 1.0 Y(N)=' +,E15.6/' ASSUMES USER HAS SUPPLIED HISTOGRAM RATHER THAN CUMUL', +'ATIVE DISTRIBUTION AND HAS FORGOTTEN TO CALL lHISPRE'/) NTRY=NXHRAN GOTO 50 C INITIALIZE HISTOGRAM TO FORM CUMULATIVE DISTRIBUTION C+SELF,IF=CDC,IF=F4. C ENTRY lHISPRE C+SELF,IF=-CDC,-F4. ENTRY lHISPRE(Y,N) C+SELF. NTRY=NXHPRE 50 CONTINUE YTOT = 0. DO 100 I= 1, N IF(Y(I).LT.0.) GOTO 900 YTOT = YTOT + Y(I) 100 Y(I) = YTOT IF(YTOT.LE.0.) GOTO 900 YINV = 1.0/YTOT DO 110 I= 1, N 110 Y(I) = Y(I) * YINV Y(N) = 1.0 IF(NTRY.EQ.NXHPRE) RETURN C NOW GENERATE RANDOM NUMBER BETWEEN 0 AND ONE 200 CONTINUE c YR = RNDM(-1) YR=ranfl() C AND TRANSFORM IT INTO THE CORRESPONDING X-VALUE L = LOCATF(Y,N,YR) IF(L.EQ.0) GOTO 240 IF(L.GT.0) GOTO 250 C USUALLY COME HERE. L = ABS(L) XRAN = XLO + XWID * (L +((YR-Y(L))/(Y(L+1)-Y(L)))) RETURN C POINT FALLS IN FIRST BIN. SPECIAL CASE 240 XRAN = XLO + XWID * (YR/Y(1)) RETURN C GUARD AGAINST SPECIAL CASE OF FALLING ON EMPTY BIN 250 XRAN = XLO + L * XWID RETURN 900 CONTINUE IERR = IERR + 1 IF(IERR.LT.6) WRITE(6,1000)NTRY IF(L.GT.0) GOTO 250 IF(NTRY.EQ.NXHPRE) RETURN 1000 FORMAT('0ERROR IN INPUT DATA FOR HIS',A3,' VALUES NOT ALL >=0'/) WRITE(6,1002) (Y(K),K=1,N) 1002 FORMAT(1X,10F13.7) XRAN = 0. RETURN END +DECK,hist. subroutine IniHist c initialize common histograms c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'hist.inc' +SEQ,hist. c include 'volume.inc' +SEQ,volume. integer nsv integer imaxhisample imaxhisample=maxhisample if(QSVol.le.MaxHistQSVol)then hQSVol=QSVol else hQSVol=MaxHistQSVol endif do nsv=1,hQSVol ! circle over the sensitive volumes CALL HBOOK1( + nh1_ampK + nsv, + ' amplitude (KeV)$', + pqhisampl, 0.0, maxhisampl*1.0e3, 0.0) ! it is defined in MeV CALL HBOOK1( + nh1_ampKR + nsv, + ' amplitude (KeV)$', + pqhisampl, 0.0, maxhisampl*1.0e3, 0.0) ! it is defined in MeV CALL HBOOK1( + nh1_ampN+nsv, + ' amplitude in numbers of conduction electrons$', + imaxhisample, 0.0, maxhisample, 0.0) CALL HBOOK1( + nh1_cdx + nsv, + ' charge distribution along x$', + pqh2,-0.02,0.02,0.0) CALL HBOOK1( + nh1_cdy + nsv, + ' charge distribution along y$', + pqh2,-0.02,0.02,0.0) CALL HBOOK1( + nh1_cdz + nsv, + ' charge distribution along z$', + pqh2, + real(wall1(numVolSens(nsv))), + real(wall2(numVolSens(nsv))),0.0) enddo CALL HBOOK2( + nh2_ard, + ' Actual range of delta-electron(cm) vs energy(MeV).$', + pqh,0.0,1.0, + pqh,0.0,0.002,0.0) CALL HBOOK2( + nh2_rd, + 'Range along initial direction of delta-electron vs energy.$', + pqh,0.0,0.01, + pqh,0.0,0.002,0.0) CALL HBOOK1( + nh1_rd, + ' Range along initial direction of delta-electron (cm). $', + pqh,0.0,0.01,0.0) end subroutine FHist c fill histograms c implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'hist.inc' +SEQ,hist. c include 'volume.inc' +SEQ,volume. c include 'cel.inc' +SEQ,cel. c include 'del.inc' +SEQ,del. c include 'rga.inc' +SEQ,rga. c include 'abs.inc' +SEQ,abs. c include 'lsgvga.inc' +SEQ,lsgvga. c include 'ener.inc' +SEQ,ener. c include 'atoms.inc' +SEQ,atoms. c include 'matters.inc' +SEQ,matters. c include 'track.inc' +SEQ,track. integer nsv,ncel,nv,nm real ranfl real r do nsv=1,hqSVol nv=numVolSens(nsv) nm=nMatVol(nv) call hf1(nh1_ampK + nsv,szcel(nsv)*WWW(nm)*1.0e3,1.0) r=ranfl()-0.5 r=(szcel(nsv)+r)*WWW(nm)*1.0e3 if(r.lt.0)r=0 call hf1(nh1_ampKR + nsv, r, 1.0) call hf1(nh1_ampN + nsv,szcel(nsv),1.0) do ncel=1,qcel(nsv) ! circle on conduction electrons call hf1( + nh1_cdx + nsv, + real(pntcel(1,ncel,nsv)), zcel(ncel,nsv)) call hf1( + nh1_cdy + nsv, + real(pntcel(2,ncel,nsv)), zcel(ncel,nsv)) call hf1( + nh1_cdz + nsv, + real(pntcel(3,ncel,nsv)), zcel(ncel,nsv)) enddo enddo end SUBROUTINE WHist C C----------------------------------------------------------------- C| | C| TERMINATION ROUTINE TO PRINT HISTOGRAMS | C| | C| | C| | C----------------------------------------------------------------| implicit none c include 'GoEvent.inc' +SEQ,GoEvent. c include 'hist.inc' +SEQ,hist. c Integer*4 i,j,k,l,m,n Integer*4 istat,icycle C call hropen(HistLun,'mybook',HistFile,'nq',1024,istat) ! rz file if (istat.ne.0) go to 999 ! if error call hcdir('//PAWC',' ') ! root directory in memory call hcdir('//mybook',' ') ! root directory on disk CALL HROUT(0,icycle,' ') ! write all on disk C CALL HREND('mybook') C goto 1000 999 continue write (oo,100)istat 100 format(1x,//,1x,'*** UGLAST: error of writing, ISTAT= ',i6) 1000 continue CLOSE(HistLun) RETURN END +QUIT.