C       Version TrimSp7L  ----> 7Layer
C
C       erstellt Juni 2000 ---- Testversion               
C
C   ***
C  * C *  COPYRIGHT  W.ECKSTEIN, IPP GARCHING, FRG
C   ***
C
C
C
C     PROGRAM TRVMC95   VERSION AT IPP GARCHING  NOVEMBER 1995
C             MOMENTS OF DISTRIBUTIONS (RANGE, ENERGY AND 
C             ANGLE OF BACKSCATTERED AND SPUTTERED ATOMS)
C             INTRODUCTION OF TAUPSI, TAUPSIR
C
C     (PROGRAM TRVMC     VERSION AT IPP GARCHING  MARCH 1993)
C
C     VECTORIZED TRIM FOR SPUTTERING, MULTI-COMPONENT TARGET
C                         3 LAYERS A 5 COMPONENTS
C                         BACKWARD AND TRANSMISSION SPUTTERING
C
C     W.ECKSTEIN          IPP/PWW   GARCHING   CRAY-XMP
C                                              WORKSTATIONS
C
C     BASED ON TRSP1CN, TRIMSP3D (W.ECKSTEIN AND J.P.BIERSACK)
C     VECTORIZATION BASED ON TRIM.VEC (M.BASKES SANDIA LIVERMORE)
C
C     BACKSCATTERING AND TRANSMISSION OF PROJECTILES
C     BACKWARD AND TRANSMISSION SPUTTERING
C     ENERGY DISTRIBUTIONS IN SPECIFIC DIRECTIONS
C     ENERGY DISTRIBUTIONS IN 100 STEPS UP TO INCIDENT ENERGY
C     ANGULAR DISTRIBUTIONS IN STEPS OF COS = 0.05 (CONST. SOLID ANGLE)
C
C     MAJOR CHANGES:
C
C     Sep 1998: to create an executable for PC running under WIN95 
C                         using the DIGITAL VISUAL FORTRAN compiler (ed. Aug. 97)
C               Insertion of !DEC$REAL:8 (all REAL are REAL*8)
C               Conversion of function to double precession
C               Conversion of function to integer*4
C               Conversion of random number generator from DRAND48()
C               to DBLE(RAN(ISEED))
C               UNIT 17 (data to tape) disabled
C               UNIT 11 (input data) changed to file name EINGABE1.inp
C               UNIT 21 (output.data) changed to file name AUSGABE1.out
C               Insertion of UNIT 22 (only range data), file name AUSGABE1.rge
C     Dec 1998: Introduction of gaussian distributed projectile energies 
C               new variable RI2 = random number initializer for gaussian energy distribution
C                         new variable ISEED2 = random number for gaussian energy distribution                  
C               new variable Esig = sigma of the energy distribution
C                   if Esig=0. then fixed projectile energy 
C               new variable Epar = projectile energy 
C               new subroutine ENERGGAUSS = for the gaussian distribution
C               new variables in subroutine p1,p2,p3, necessary for calculation of
C                                                     the gaussian energy distribution
C     Mar 1999: LOGICAL FUNCTION EQUAL inserted. This function is used for comparision
C               of REAL*8 variables with 0.               
C               OUTPUT to files AUSGABE1:
C               bug fixed for the output of the CH(i), bug was also present
C               in the original and the older version of TRIMSPP*C
C               if OUTPUT file exists then program asks for new OUTPUT filename
C               all variables are now defined as REAL*8 or INTEGER*4
C               for variable conversion from REAL to INTEGER or INTEGER to REAL
C               conversion function inserted (IDINT, DFLOTJ)
C               use of correct MIN or MAX functions
C               data initialization for all variables (like in BHam) but without
C               DATA ier/102*0/ give an error in calculation of ions stopped in layer 2 - 3
C               Unit 99 for file ausgabe1.err inserted, if and IF... (see below is true
C               then a message is included into this file
C               IF's inserted - can be found by using find WRITE(99,
C               DABS inserted for DLOG and DLOG10 arguments
C       Mai 1999: Version h
C               for TRIMSP simulations running in batch mode (i.e. to calculate
C               a serie of different range profiles using the same target an output
C               file FOR33 is created. In this file the following parameters are
C               written:
C               E0,Esig,NH,IIM,IB,IT,IRPL(1),IRPL(2),IRPL(3),fix0,sigmax
C               the FILE open statement is inserted after label 1502
C               new variable column(100)*104 and colcount inserted.
C     Mai 1999: Version i
C               tried to fix bug for variable C2 (in Do 65 loop). 
C               Sometimes this variable becames smaller then 10-10 (an underflow occurs,
C               the variable C2 is NaN, variables S2 and DENS, which are directly calculated
C               from C2 are also NaN. If variable C2 is less then 10-10 then C2 is 10-10.
C               S2 and DENS are calculated with the resetted value of C2.
C               Range file (output to unit 22) slightly changed. Now the midth of a channel
C               is calculated and only the number of particles is written to the file
C
C
C       Jun 1999: Version j1
C                         changed calculation of Firsoc screening length according to the IRCU 49 report.
C               the Andersen-Ziegler tables (file stopping.dat) are revised,i.e. the coefficients
C               from the ICRU 49 report are included for all elements (file stopicru.dat)
C
C               PROGRAM DATMAK2c: this program creates the input files for TRIMSPP4*.
C                                 with this program one can change the energy,
C                                 the energy distribution, the number of muons, and the
C                                 layer thickness easily. This is for making different
C                                 simulations (i.e. energy scan, sigma scan, particle
C                                 number scan, layer thickness scan). A corresponding
C                                 batch file is created with this program too.
C     Nov 1999: Version j1a
C               UNIT33: now Etrans, sigmaEtrans, Eback, sigmaEback included
C               Bug fixed in line 2084, location of 'write to unit33' changed.              
C     Dec 1999: Version k
C                         inclusion of variables
C                         tryE :how often a random energy is calculated by the random generator
C               for large E0 this number should be the same as the number of projectiles nh
C               negE :how often a negative energy is calculated by the random generator
C               tryE - negE should be nh
C               both variables are type integer, both variables included in the output file
C               and in the fort33.file 
C               inclusion of alphasig: one dimensional distribution of the angle of incidence
C               if alphasig .NE. 0 THEN a gaussian distribution of alpha will be calculated
C               in the subroutine ALPHAGAUSS
C               if the calculated angle is < 0 then the absolute value is taken because of
C               the options alpha = -1 or  alpha = -2 (see file TRVMC95-v4k.txt)
C               inclusion of RI3: random seed for the calculation of the gaussian distribution
C               of alpha.
C               Header line for file for33 included.
C       Jan 2000: no new version but
C                         included energy scaling of particle reflection coefficients after Thomas et al.
C               NIM B69 (1992) 427
C               the calculated particle reflection coefficients prcoeff are written to the fort.33 file
C               prc is calculated if 1st layer consists only one element !
C               included constants prc(1) - prc(6)
C               Thomas-Fermi reduced energy: epsilon
C               output of E0 and Esig now in keV
C     Apr 2000: BUG fixed, Var CHM2 removed, i.e. stopping power for energies below 10 keV
C               was a little bit overestimated. now version TrimSpP4L
C               Prg Datmak4L creates input files.                 
C     Jun 2000: Source code enlarged to simulate implantation profiles in up to 7 layers. 
C               Each layer can have up to  5 different elements.
C               BUG fixed in line 1470,i.e. in calculation of scattering angle for the
C               Moliere potential the variable rrr1 was not handled correct. The length of
C               line 1470 was too long, RRR1 was read as RRR which has the value 0.
C               Due to the fact, that all calculation based on the other interaction potentials
C               (Krypton Carbon and ZBL) give more or less the same inplantation profiles, this
C               bug has a minor influence to the implantation profile.
C               Variables DateTime(8) = Integer array and
C               Real_Clock(3) = Character array included for date and time output to file
C               Changes for output file to UNIT 33:
C               Size of character variable column enlarged from 214 to 246
C               Program datmak7a creates input files for this TrimSp release.
C               true calculation, i.e. indendent of bin width, of particles stopped
C               in layers - see UpTiefe,LowTiefe,number_in_layer(7)
C               INTEGER check_layer_flag : IF 1 then calculated implantation profile
C                                          in the 100 depth intervals agrees with
C                                          number of particles stopped in the different layers
C                                          IF 0 not, message will be written in the range file
C                                          UNIT 21 and UNIT22
c       November 2000. Tanya Riseman 
c	Starts porting program to Open VMS and DEC UNIX.
c       Compile options: f90/list/warn/ext
c               Minor problems with continuation characters in wrong column and
c               with a few variables undeclared, mostly functions.
c	Make code fit on 72 columns, because -extend_source
c		does not appear to work on DEC Unix.
c	Start changing strings in format and write statments so that 
c		strings don't straddle continuation character in 
c		column 6. Straddling can be non-portable!
c       Comment out       !DEC$REAL:8 because all
c               reals are already declared REAL*8. Add implicit none.
c
c	June 2002.	Thomas Prokscha PSI
c	Stopped porting to f90, use f77 only.
c	replaced all non-standard f77 function by standard functions.
c	use ranlux random number generator from the CERN library (libmathlib.a must
c	be installed) to get rid of machine specific random number generators.
c	Add pre-compiler instructions for making different output for the .rge files
c	on Windows and Unix.
c
c	October 2002	Thomas Prokscha PSI
c	corrected error in the calculation of the Thomas-Fermi reduced energy:
c	it was 1/(Z1 Z2 * sqrt( Z1**2/3 + Z2**2/3))
c	it must be:
c              1/(Z1 Z2 * sqrt( Z1**(2/3) + Z2**(2/3)))
c
c
CDIR$ NOLIST
C
cTR      !DEC$REAL:8
C
C       IMPLICIT INTEGER (i-j)
C       IMPLICIT REAL*8 (a-h,k-z)
C
c-------------------------------------------
c       check OS
c
#if defined( _WIN32 )
#define OS_WIN
#else
#define OS_UNIX
#endif
c
        IMPLICIT NONE
        LOGICAL   TEST(64),TESTR(2000),TEST1(2000)
        LOGICAL   EQUAL
        INTEGER*4 ISRCHEQ,ISRCHFGT,ISRCHFGE,ILLZ
        INTEGER   N,L,LL,NH,NUM,KK
        INTEGER   I,J,IV
        INTEGER   tryE,negE
        INTEGER   COLCOUNT
        INTEGER   Date_time(8)
        INTEGER   days_total_stop 		!! TR
        INTEGER   depth_interval_flag
        INTEGER*4 days_start_total,days_stop_total
        INTEGER*4 seconds_start_total,seconds_stop_total   
        INTEGER*4 NREC1,NREC2,NE1,K,NGIK,ICW
        INTEGER*4 ISEED,ISEED2,ISEED3
        INTEGER*4 JJR(2000,2),INOUT(2000,2),LRR(2000,2) 
        INTEGER*4 IDMAX(2000),IKR(2000)
        INTEGER*4 number_in_layer(7),laufzahl
        INTEGER*4 IRP(0:101),IPL(100),IPLB(100),IPLT(100)
        INTEGER*4 ICD(100,35),ICDT(100),ICDJT(35),ICDIRJ(35,35)
     #          ,ICDR(100,35),ICDTR(100),ICDJTR(35)
     #          ,ICDIRI(100,35,35),ICDIRN(100,35),ICDITR(35)
      INTEGER*4 KADB(20),KADT(20),KADS(20),KADST(20)
     #          ,KADRIP(20,30),KADRIS(20,30),KADROP(20,30),KADROS(20,30)
     #          ,KADSJ(20,30),KADSL(20,6),KDSTJ(20,30),KDSTL(20,6)
        INTEGER*4 IBSP(35),ISPAL(7),IBSPL(35)
     #          ,ISPIP(35),ISPIS(35),ISPOP(35),ISPOS(35)        
        INTEGER*4 ITSP(35),ISPALT(7)
     #          ,ISPIPT(35),ISPIST(35),ISPOPT(35),ISPOST(35)
        INTEGER*4 KO(600,35,2)
      INTEGER*4 MEAB(102,22),MAGB(62,22),MEAGB(102,36,22)
     #          ,MEABL(75,21),MEPB(102,102)
      INTEGER*4 MEAT(102,22),MAGT(62,22),MEAGT(102,36,22),
     #          MEATL(75,21),MEPT(102,102)
      INTEGER*4 MEAS(102,22,30),MAGS(62,22,30),MAGSA(62,32,30)
     #          ,MEAGS(102,12,22,30)
     #          ,MEASL(75,21,30)
      INTEGER*4 MEAST(102,22,30),MAGST(62,22,30)
CC   #          ,MEAGST(102,36,22,10) von Eckstein herauskommentiert
     #          ,MEASTL(75,21,30)
CC    REAL*8 MEAGSL(75,36,21),EAGSL(75) von Eckstein herauskommentiert
        INTEGER*4 NJ(7),JT(7),ILD(7)
      INTEGER*4 LLL(64),JJJ(64),IK(64)
      INTEGER*4 me(5000),nli(0:7),irpl(7)
        INTEGER*4 IT,NPROJ
      INTEGER*4 IB,IBL
      INTEGER*4 IIRP,IIPL,ICDTT,ICDTTR
      INTEGER*4 ICSUM,ICSUMS,ICDI,ISPA,ISPAT 
        INTEGER*4 KK0,KK0R,KK2,KKR,KDEE1,KDEE2
        INTEGER*4 NE,NA,NG,NA1,NG1
        INTEGER*4 LMAX,JMAX,LJ,INEL,IH,IH1,IY,IY2,IY3
        INTEGER*4 JL,KK1,IVMIN,IVMAX,NPA,IREC1,IREC,MAXA,NALL,NSA,KIS
        INTEGER*4 IA,IAG,IAGS,IG,IESP,IESLOG
        INTEGER*4 IPOT,IPOTR,IRL,ICDIR,ICSBR,ICSUMR,KOI,IGG,KIST
        INTEGER*4 JRT,IESPT,IP,I1,IPB
        INTEGER*4 IPB1,KIB,IPT,IE,IERLOG,IAGB,KIT,IMA,IIM
        INTEGER*4 im1,im2,im3,IG2,ies,ias
        INTEGER*4 JE,JA,JG,JTJ,JTK,JTL
C       REAL Variablen
      REAL*8  CVMGT
        REAL*8  X(64),Y(64),Z(64),E(64),PL(64)
     #          ,COSX(64),COSY(64),COSZ(64),SINE(64)
      REAL*8  EPS(64),DEN(64),DEE(64),DENS(64),DEES(64)
     #          ,CX(64),CY(64),CZ(64),SX(64),X1(64),ASIGT(64),EM(64)
      REAL*8  EX1(64),EX2(64),EX3(64),P(64),TAU(64),EX4(64)
     #          ,B(64),R(64),C2(64),S2(64),CT(64),ST(64),V(64),V1(64)
     #          ,CPHI(64),SPHI(64),CPSI(64),SPSI(64),TAUPSI(64)
     #          ,ENUCL(64),EINEL(64),ENUCL2(64),EINEL2(64)
      REAL*8  ER(2000,2),XR(2000,2),YR(2000,2),ZR(2000,2)
     #          ,CSXR(2000,2),CSYR(2000,2),CSZR(2000,2),TAUR(2000)
     #          ,SNXR(2000,2),CPSIR(2000,2),SPSIR(2000,2),CPHIR(2000,2)
     #          ,SPHIR(2000,2),TAUPSR(2000,2)
      REAL*8  EPSR(2000),T(2000),TS(2000),DEER(2000),DEERS(2000)
     #          ,PR(2000),BR(2000),EX1R(2000),EX2R(2000),EX3R(2000)
     #          ,CTR(2000),STR(2000),ASIGTR(2000),EX4R(2000)
     #          ,X2(2000),RR(2000),VR(2000)
     #          ,V1R(2000),CXR(2000),CYR(2000),CZR(2000)
     #          ,SXR(2000),C2R(2000),S2R(2000),CUR(2000)
      REAL*8  RIRP(0:101)
     #          ,CASMOT(100),PHON(100),DENT(100),ION(100),DMGN(100)
     #          ,CASMOTR(100),PHONR(100),DENTR(100),IONR(100),DMGNR(100)
     #          ,ELGD(100),ELGDR(100)
      REAL*8  ELE(100,35),ELI(100,35),ELP(100,35),ELD(100,35)
     #          ,ELET(35),ELIT(35),ELPT(35),ELDT(35)
     #          ,ELER(100,35),ELIR(100,35),ELPR(100,35),ELDR(100,35)
     #          ,ELETR(35),ELITR(35),ELPTR(35),ELDTR(35)         
      REAL*8  AI(20),RKADB(20),RKADT(20)
     #          ,RKADS(20),RKADST(20)
     #          ,RKADSJ(20,30),RKADSL(20,7)
     #          ,RKDSTJ(20,30),RKDSTL(20,7)
      REAL*8  EBSP(35),ESPAL(7)
     #          ,SPY(35),SPE(35),REY(35),EMSP(35)
     #          ,ESPIP(35),ESPIS(35),ESPOP(35),ESPOS(35)
     #          ,RIP(35),RIS(35),ROP(35),ROS(35)
     #          ,REIP(35),REIS(35),REOP(35),REOS(35)
     #          ,ESPMIP(35),ESPMIS(35),ESPMOP(35),ESPMOS(35)
     #          ,RIPJ(35),RISJ(35),ROPJ(35),ROSJ(35)
     #          ,REIPJ(35),REISJ(35),REOPJ(35),REOSJ(35)
      REAL*8 ETSP(35),ESPALT(7)
     #          ,SPYT(35),SPET(35),REYT(35),EMSPT(35)
     #          ,ESPIPT(35),ESPIST(35),ESPOPT(35),ESPOST(35)
     #          ,RIPT(35),RIST(35),ROPT(35),ROST(35)
     #          ,REIPT(35),REIST(35),REOPT(35),REOST(35)
     #          ,ESPMIPT(35),ESPMIST(35),ESPMOPT(35),ESPMOST(35)
      REAL*8 SPEM(35),SPE2S(35),SPE3S(35),SPE4S(35),SPE5S(35)
     #          ,SPE6S(35),VSPE(35),SSPE(35),GSPE(35),BSPE(35)
      REAL*8 SPE1SL(35),SPE2SL(35),SPE3SL(35),SPE4SL(35),SPE5SL(35)
     #          ,SPE6SL(35)
        REAL*8 ELOG(75),EMA(62,22),EABL(75)
        REAL*8 EMAT(62,22),EATL(75),EASL(75,30),EASTL(75,30)
      REAL*8 FG(128),FFG(64)
      REAL*8 XX(7),DX(7),RHO(7),Z2(7),M2(7),LM(7),PDMAX(7)
     #          ,ARHO(7),AM(7),FM(7),EPS0(7),ASIG(7),K2(7),CK(7)
     #          ,KLM1(7),SB(7),DLI(7)
        REAL*8 UpTiefe,LowTiefe
      REAL*8 ZT(7,5),MT(7,5),CO(7,5),SBE(7,5),ED(7,5),BE(7,5)
     #          ,COM(5,7)
      REAL*8 MU(35,35),EC(35,35),A(35,35),F(35,35)
     #          ,KL(35,35),KOR(35,35),KLM(7,35)
      REAL*8 MU1(35),EC1(35),A1(35),F1(35),KL1(35),KOR1(35)
     #          ,DI(35),EP(35),ZZ(35),TM(35)
CC    REAL*8 SL(64,5),SM(64,5),SH(64,5),CH(92,12),CHE(92,9)
      REAL*8 CH1(7,5),CH2(7,5),CH3(7,5),CH4(7,5),CH5(7,5)
        REAL*8 CHM1(7)
      REAL*8 SM(64),SH(64,5)
      REAL*8 FIESB(30),SEESB(30),THESB(30),FOESB(30)
     #          ,SGMESB(30),DFIESB(30),DSEESB(30),DTHESB(30)
CC    REAL*8 ESVDL(2000)      
      REAL*8 pi,c,E0,de,alfa,z1,rtheta,cu,enot,esb,est,esp
        REAL*8 E2,AB,FP,AN
      REAL*8 Esig,Epar
        REAL*8 E0keV,EsigkeV
c fuer part. reflec. coeff. Berechnung
        REAL*8 epsilon, prcoeff,PRC(6)
      REAL*8 cossin,rphi,vanlb,vailb,vanlt,vailt,phip,ta,ta2
      REAL*8 exir,phipr,u,rq,es,vanli,vaili
      REAL*8 M1,MOT
      REAL*8 ET,PLST,PL2ST,PL3ST
      REAL*8 PL4ST,PL5ST,PL6ST
      REAL*8 SEM,TDMENR
      REAL*8 TION,TIONR,TDENT,TDENTR
      REAL*8 TELGD,TPHON,TCASMO,TELGDR
      REAL*8 TPHONR,TRIRP,TDMGN,TDMGNR
      REAL*8 ET2SUM,ET3SUM,ET4SUM,ET5SUM,ET6SUM
      REAL*8 EB2SUM,EB3SUM,EB4SUM,EB5SUM,EB6SUM,EB
      REAL*8 EB1SUL,EB2SUL,EB3SUL,EB4SUL,EB5SUL,EB6SUL      
      REAL*8 EINELB,EIL2B
      REAL*8 EXI,exi1s,exi2s,exi3s,exi4s,exi5s,exi6s,exiq,exic
      REAL*8 cossq,cosst,coss1s,coss2s,coss3s,coss4s,coss5s,coss6s
      REAL*8 X2SUM,X3SUM,X4SUM,X5SUM,X6SUM,XSUM
      REAL*8 R2SUM,R3SUM,R4SUM,R5SUM,R6SUM,RSUM
      REAL*8 PL2SUM,PL3SUM,PL4SUM,PL5SUM,PL6SUM,PLSUM
      REAL*8 ENL2B,ENUCLB,EINELI,EIL2I
      REAL*8 ENUCLI,ENL2I
      REAL*8 PLSB,PL2SB,PL3SB,PL4SB,PL5SB,PL6SB
      REAL*8 EELWC,EELWC2,EELWC3,EELWC4,EELWC5,EELWC6
      REAL*8 EIL,EIL2,EIL3,EIL4,EIL5,EIL6
      REAL*8 EPL,EPL2,EPL3,EPL4,EPL5,EPL6
      REAL*8 EEL,EEL2,EEL3,EEL4,EEL5,EEL6
      REAL*8 EN2LT
      REAL*8 EMX,ESPAT,ESPA
        REAL*8 ALPHA,ALPHASIG,ALPHAPAR
        REAL*8 EF,SHEATH,ERC,RI,RI2,RI3,X0,RD,CW,CA
        REAL*8 DA,DG,DGI,BW,DAW,DGW,E0DE,DGIK,PI2,ABC
        REAL*8 TT,HLM,HLMT
        REAL*8 SU1,SU2,SUR,SU,SUT1,SUT2,SUTR,SUT
        REAL*8 CALFA,SALFA,SFE,XC,RT,TI,SINA
        REAL*8 ZARG,VELC,RA,RR1,FR,FR1,Q,FE
        REAL*8 ROCINV,SQE,CC,AA,FF,DELTA,DEEOR,DEEORR,DELR,FHE,DEL
        REAL*8 G,DEN2,DEN3,DEE2,DEE3,DEWC,DEWC2,DEWC3
        REAL*8 TAR,TAR2,RRR1,T1,TEL,TR,TR1,EI,ENOR,ACS,AC
        REAL*8 SPE2,SPE3,SPE2L,SPE3L
        REAL*8 ENORT,ESPT,EXIRT,EINELT,EIL2T
        REAL*8 PL2,PL3,XQ,XQ3,RQW,RQ3,ENO,ESQ,ES3
        REAL*8 ESQL,ES3L,PLQB,PL3B,PLQT,PL3T
        REAL*8 ETQ,ET3,ENUCLT,ENL2T
        REAL*8 RA1,ALPHAM,EMV,EIM
        REAL*8 CSUM,CSUMS,CSUMR,AVCSUM,AVCSMS,AVCDIS
        REAL*8 AVNLI,SIGNLI,DFINLI,SIGILI,DFIILI,AVILI
        REAL*8 TIT,TE,TMEANR,EMEANT,AVNLT,SIGNLT,DFINLT,AVILT
        REAL*8 TN,SIGILT,DFIILT
        REAL*8 FIX0,SEX,THX,FOX,FIX,SIX,SIGMAX,DFIX0,DSEX,DTHX
        REAL*8 FIR0,SER,THR,FOR,FIR,SIR,SIGMAR,DFIR0,DSER,DTHR
        REAL*8 FIP0,SEP,THP,FOP,FIP,SIP,SIGMAP,DFIP0,DSEP,DTHP
        REAL*8 FIE0,SEE,THE,FOE,FIE,SIE,SIGMAE,DFIE0,DSEE,DTHE
        REAL*8 FIW0,SEW,THW,FOW,FIW,SIW,SIGMAW,DFIW0,DSEW,DTHW
        REAL*8 FII0,SEI,THI,FOI,FII,SII,SIGMAI,DFII0,DSEI,DTHI
        REAL*8 FIS0,SES,THS,FOS,FIS,SIS,SIGMAS,DFIS0,DSES,DTHS
        REAL*8 FIB0,SEB,THB,FOB,FIB,SIB,SIGMAB,DFIB0,DSEB,DTHB
        REAL*8 FIPB0,SEPB,THPB,FOPB,FIPB,SIPB,SIGMPB,DFIPB0,DSEPB,DTHPB
        REAL*8 FIT0,SET,THT,FOT,FIT,SIT,SIGMAT,DFIT0,DSET,DTHT
        REAL*8 FIPT0,SEPT,THPT,FOPT,FIPT,SIPT,SIGMPT,DFIPT0,DSEPT,DTHPT
        REAL*8 FIES0,SEES,THES,FOES,FIES,SIES,SIGMES,DFIES0,DSEES,DTHES
        REAL*8 FIES0L,SEESL,THESL,FOESL,FIESL,SIESL,SIGMSL,
     #         DFIESL,DSEESL,DTHESL
        REAL*8 X1SD,X2SD,X3SD,X4SD,X5SD,X6SD
        REAL*8 ACSUMR,ACDISR,ACSBER,ACSUR,ACDIR,ACSBR
        REAL*8 ACDR11,ACDR12,ACDR21,ACDR22
        REAL*8 D1,D2,Dmid,RN,RE,EMEANR,EMEAN,AVEB,AVNLB,SIGNLB
        REAL*8 DFINLB,AVILB,SIGILB,DFIILB,TEMP,TEMPNH
        REAL*8 EB1B,EB2B,EB3B,EB4B,EB5B,EB6B
        REAL*8 EB1BL,EB2BL,EB3BL,EB4BL,EB5BL,EB6BL
        REAL*8 EBSP1,EBSP2,EBSP3,EBSP4,EBSP5,EBSP6
        REAL*8 EBSP1L,EBSP2L,EBSP3L,EBSP4L,EBSP5L,EBSP6L
        REAL*8 PL1S,PL2S,PL3S,PL4S,PL5S,PL6S
        REAL*8 YH,HN,CST,BI,BIL,YSP,YSPL,EEE
        real*4 random,ran2(2)
C       CHARACTER Variablen
        CHARACTER*18 DPOT,DPOTR,DKDEE1,DKDEE2
        CHARACTER filein*8,inext*4,fileout*8,outext*4,innam*12,outnam*12
        CHARACTER rgenam*12,rgeext*4,errnam*12,errext*4
        CHARACTER errcom*72
        CHARACTER COLUMN(100)*246
        CHARACTER Real_Clock(3)*12
        CHARACTER month_start*4,month_stop*4,day_start*2,day_stop*2
        CHARACTER year_start*4,year_stop*4,hour_start*2,hour_stop*2
        CHARACTER min_start*2,min_stop*2,sec_start*2,sec_stop*2
C
      COMMON    /A/ M1,VELC,ZARG
      COMMON    /B/ TI,SHEATH,CALFA
C
      DATA  PI/3.14159265358979D0/, ICW/100/, E2/14.399651D0/
      DATA  AB/0.52917725D0/, FP/0.885341377D0/, AN/0.60221367D0/
      DATA  inext/'.inp'/,outext/'.out'/,rgeext/'.rge'/
        DATA  errext/'.err'/
      DATA  filein/'eingabe1'/,fileout/'ausgabe1'/

      DATA  ET/0.D0/,PLST/0.D0/,PL2ST/0.D0/,PL3ST/0.D0/
      DATA  PL4ST/0.D0/,PL5ST/0.D0/,PL6ST/0.D0/
      DATA  SEM/0.D0/,IT/0/,NPROJ/0/,NREC1/0/,NREC2/0/
      DATA  NH/0/,IB/0/,IBL/0/,NJ/7*0/,NLI/8*0/,DLI/7*0.D0/
        DATA  tryE/0/,negE/0/
      DATA  IIRP/0/,IIPL/0/,ICDTT/0/,ICDTTR/0/,TDMENR/0.D0/
      DATA  TION/0.D0/,TIONR/0.D0/,TDENT/0.D0/,TDENTR/0.D0/
      DATA  TELGD/0.D0/,TPHON/0.D0/,TCASMO/0.D0/,TELGDR/0.D0/
      DATA  TPHONR/0.D0/,TDMENR/0.D0/,TRIRP/0.D0/,TDMGN/0.D0/
      DATA  TDMGNR/0.D0/
      DATA  ET2SUM/0.D0/,ET3SUM/0.D0/,ET4SUM/0.D0/,ET5SUM/0.D0/
      DATA  ET6SUM/0.D0/ 
      DATA  EB2SUM/0.D0/,EB3SUM/0.D0/,EB4SUM/0.D0/,EB5SUM/0.D0/
      DATA  EB6SUM/0.D0/,EB/0.D0/   
      DATA  EB1SUL/0.D0/,EB2SUL/0.D0/,EB2SUL/0.D0/,EB3SUL/0.D0/
      DATA  EB4SUL/0.D0/,EB5SUL/0.D0/,EB6SUL/0.D0/
      DATA  EINELB/0.D0/,EIL2B/0.D0/
      DATA  exi1s/0.D0/,exi2s/0.D0/,exi3s/0.D0/,exi4s/0.D0/
      DATA  exi5s/0.D0/,exi6s/0.D0/  
      DATA  KADB/20*0/
      DATA  coss1s/0.D0/,coss2s/0.D0/,coss3s/0.D0/,coss4s/0.D0/
      DATA  coss5s/0.D0/,coss6s/0.D0/
      DATA  MEAB/2244*0/,MEABL/1575*0/,MAGB/1364*0/
      DATA  MEPB/10404*0/,MEAGB/80784*0/,EMA/1364*0.D0/       
      DATA  X2SUM/0.D0/,X3SUM/0.D0/,X4SUM/0.D0/,X5SUM/0.D0/
      DATA  X6SUM/0.D0/,XSUM/0.D0/
      DATA  R2SUM/0.D0/,R3SUM/0.D0/,R4SUM/0.D0/,R5SUM/0.D0/
      DATA  R6SUM/0.D0/,RSUM/0.D0/
      DATA  PL2SUM/0.D0/,PL3SUM/0.D0/,PL4SUM/0.D0/,PL5SUM/0.D0/
      DATA  PL6SUM/0.D0/,PLSUM/0.D0/
      DATA  ENL2B/0.D0/,ENUCLB/0.D0/,EINELI/0.D0/,EIL2I/0.D0/
      DATA  ENUCLI/0.D0/,ENL2I/0.D0/
      DATA  PLSB/0.D0/,PL2SB/0.D0/,PL3SB/0.D0/,PL4SB/0.D0/
      DATA  PL5SB/0.D0/,PL6SB/0.D0/
      DATA  EELWC/0.D0/,EELWC2/0.D0/,EELWC3/0.D0/,EELWC4/0.D0/
      DATA  EELWC5/0.D0/,EELWC6/0.D0/        
      DATA  EIL/0.D0/,EIL2/0.D0/,EIL3/0.D0/,EIL4/0.D0/
      DATA  EIL5/0.D0/,EIL6/0.D0/ 
      DATA  EPL/0.D0/,EPL2/0.D0/,EPL3/0.D0/,EPL4/0.D0/
      DATA  EPL5/0.D0/,EPL6/0.D0/ 
      DATA  EEL/0.D0/,EEL2/0.D0/,EEL3/0.D0/,EEL4/0.D0/
      DATA  EEL5/0.D0/,EEL6/0.D0/ 
      DATA  ENUCL/64*0.D0/,EN2LT/0.D0/,TAUPSI/64*0.D0/
      DATA  EINEL/64*0.D0/,CASMOT/100*0.D0/,DENT/100*0.D0/
      DATA  DMGN/100*0.D0/,ION/100*0.D0/,PHON/100*0.D0/
      DATA  PHONR/100*0.D0/
      DATA  ELGD/100*0.D0/,ELGDR/100*0.D0/
      DATA  ICDT/100*0/,ICDTR/100*0/
      DATA  ICDR/3500*0/,ICDIRN/3500*0/,IONR/100*0.D0/
      DATA  DENTR/100*0.D0/,DMGNR/100*0.D0/
      DATA  IPL/100*0/,IPLB/100*0/,IPLT/100*0/
c       DATA  IRP/102*0/ gibt witzigweise einen Fehler, aber warum????
      DATA  IRPL/7*0/
      DATA  ICDJT/35*0/,ICDJTR/35*0/,ICDITR/35*0/ 
      DATA  ICD/3500*0/,ELP/3500*0.D0/,ELD/3500*0.D0/
      DATA  ELE/3500*0.D0/,ELI/3500*0.D0/ 
      DATA  ICDIRI/122500*0/
      DATA  ICSUM/0/,ICSUMS/0/,ICDI/0/,ISPA/0/,ISPAT/0/ 
      DATA  Z2/7*0.D0/,M2/7*0.D0/
      DATA  KLM1/7*0.D0/,CHM1/7*0.D0/,SB/7*0.D0/,KLM/245*0.D0/
      DATA  ME/5000*0/,EMX/0.D0/,ESPAT/0.D0/,ESPA/0.D0/
      DATA  IBSP/35*0/,IBSPL/35*0/,EBSP/35*0.D0/,ISPAL/7*0/ 
      DATA  ITSP/35*0/,ETSP/35*0.D0/
      DATA  ESPAL/7*0.D0/,ESPALT/7*0.D0/,ISPALT/7*0/
      DATA  SPE2S/35*0.D0/,SPE3S/35*0.D0/,SPE4S/35*0.D0/
      DATA  SPE5S/35*0.D0/,SPE6S/35*0.D0/
      DATA  SPE1SL/35*0.D0/,SPE2SL/35*0.D0/,SPE3SL/35*0.D0/
      DATA  SPE4SL/35*0.D0/,SPE5SL/35*0.D0/,SPE6SL/35*0.D0/  
      DATA  ELET/35*0.D0/,ELPT/35*0.D0/,ELDT/35*0.D0/,ELIT/35*0.D0/
      DATA  ELETR/35*0.D0/,ELITR/35*0.D0/,ELPTR/35*0.D0/
      DATA  ELDTR/35*0.D0/ 
      DATA  Epar/0.D0/
c     part. refl. coeff. from Thomas et al.
        DATA  PRC/0.825D0,21.41D0,8.606D0,0.6425D0,1.907D0,1.927D0/
        DATA  number_in_layer /7*0/
C
CC    EXTERNAL CVMGT,ILLZ,SCOPY,ISRCHEQ,ISRCHFGE,ISRCHFGT
C
	innam=filein//inext 
	outnam=fileout//outext
	rgenam=fileout//rgeext
        errnam=fileout//errext
C
        OPEN(UNIT=99,file=errnam,STATUS='new')
	OPEN(UNIT=11,file=innam,STATUS='unknown',ERR=13591)
C       OPEN(UNIT=31,NAME='energ.dat',STATUS='new')
C
        READ(11,100) Z1,M1,E0,Esig,ALPHA,ALPHASIG,EF,ESB,SHEATH,ERC
        READ(11,101) NH,RI,RI2,RI3,X0,RD,CW,CA,KK0,KK0R,KDEE1,KDEE2
     #                ,IPOT,IPOTR,IRL
        READ(11,102) DX(1),DX(2),DX(3),DX(4),DX(5),DX(6),DX(7),
     #                RHO(1),RHO(2),RHO(3),RHO(4),RHO(5),RHO(6),RHO(7),
     #                CK(1),CK(2),CK(3),CK(4),CK(5),CK(6),CK(7)
        DO 135 I=1,7
          READ(11,103) ZT(I,1),ZT(I,2),ZT(I,3),ZT(I,4),ZT(I,5)
          READ(11,103) MT(I,1),MT(I,2),MT(I,3),MT(I,4),MT(I,5)
          READ(11,103) CO(I,1),CO(I,2),CO(I,3),CO(I,4),CO(I,5)
          READ(11,103) SBE(I,1),SBE(I,2),SBE(I,3),SBE(I,4),SBE(I,5)
          READ(11,103) ED(I,1),ED(I,2),ED(I,3),ED(I,4),ED(I,5)
          READ(11,103) BE(I,1),BE(I,2),BE(I,3),BE(I,4),BE(I,5)
          READ(11,107) CH1(I,1),CH1(I,2),CH1(I,3),CH1(I,4),CH1(I,5)
          READ(11,107) CH2(I,1),CH2(I,2),CH2(I,3),CH2(I,4),CH2(I,5)
          READ(11,107) CH3(I,1),CH3(I,2),CH3(I,3),CH3(I,4),CH3(I,5)
          READ(11,107) CH4(I,1),CH4(I,2),CH4(I,3),CH4(I,4),CH4(I,5)
          READ(11,107) CH5(I,1),CH5(I,2),CH5(I,3),CH5(I,4),CH5(I,5)
  135   CONTINUE
 
13591     CLOSE(UNIT=21) 
 
          WRITE(*,100) Z1,M1,E0,Esig,ALPHA,ALPHASIG,EF,ESB,SHEATH,ERC
          WRITE(*,101) NH,RI,RI2,RI3,X0,RD,CW,CA,KK0,KK0R,KDEE1,KDEE2
     #                ,IPOT,IPOTR,IRL
          WRITE(*,102) DX(1),DX(2),DX(3),DX(4),DX(5),DX(6),DX(7),
     #                RHO(1),RHO(2),RHO(3),RHO(4),RHO(5),RHO(6),RHO(7),
     #                CK(1),CK(2),CK(3),CK(4),CK(5),CK(6),CK(7)
          DO 1359 I=1,7
            WRITE(*,'(1x,I2,A7)')i,'. Layer'
          WRITE(*,103) ZT(I,1),ZT(I,2),ZT(I,3),ZT(I,4),ZT(I,5)
          WRITE(*,103) MT(I,1),MT(I,2),MT(I,3),MT(I,4),MT(I,5)
          WRITE(*,103) CO(I,1),CO(I,2),CO(I,3),CO(I,4),CO(I,5)
c          WRITE(*,103) SBE(I,1),SBE(I,2),SBE(I,3),SBE(I,4),SBE(I,5)
c          WRITE(*,103) ED(I,1),ED(I,2),ED(I,3),ED(I,4),ED(I,5)
c          WRITE(*,103) BE(I,1),BE(I,2),BE(I,3),BE(I,4),BE(I,5)
c          WRITE(*,107) CH1(I,1),CH1(I,2),CH1(I,3),CH1(I,4),CH1(I,5)
c          WRITE(*,107) CH2(I,1),CH2(I,2),CH2(I,3),CH2(I,4),CH2(I,5)
c          WRITE(*,107) CH3(I,1),CH3(I,2),CH3(I,3),CH3(I,4),CH3(I,5)
c          WRITE(*,107) CH4(I,1),CH4(I,2),CH4(I,3),CH4(I,4),CH4(I,5)
c          WRITE(*,107) CH5(I,1),CH5(I,2),CH5(I,3),CH5(I,4),CH5(I,5)
 1359     CONTINUE
C
  100     FORMAT(2F7.2,1F12.2,7F9.2)
  101     FORMAT(I9,3F8.0,1F7.2,1F7.0,2F7.2,6I4,I3)
  102     FORMAT(7F9.2,14F7.2)
  103     FORMAT(5F9.4)
  107     FORMAT(5F12.6)
C
C open statement for output files, removed from line 2449 ff to here
C
      OPEN(UNIT=21,FILE=outnam,STATUS='new',ERR=6000)
        GOTO 6001
 6000   WRITE(*,*)' File schon vorhanden, Gib neue Ausgabedatei an (A8)'
        READ(*,'(A8)') fileout
        outnam=fileout//outext
        rgenam=fileout//rgeext
        OPEN(UNIT=21,FILE=outnam,STATUS='new',ERR=6000)
 6001 OPEN(UNIT=22,FILE=rgenam,STATUS='new')
      WRITE(21,1000)
 1000 FORMAT(1H1/,6X,'* PROGRAM TRVMC95 - V TrimSP7L 17.Oct.02 TP *')
cTP 1000 FORMAT(1H1/,6X,'* PROGRAM TRVMC95 - Vers. TrimSP7L 22.Nov.00 *')
cTR 1000 FORMAT(1H1/,6X,'** PROGRAM TRVMC95 - V TrimSP7L 26.06.00 **')
C
C     1st CALL DATE_AND_TIME
      CALL DATE_AND_TIME(Real_Clock(1),Real_Clock(2),Real_Clock(3),
     1                   Date_Time)
C
        IF(Date_Time(2).EQ.1) THEN
                month_start='Jan.'
            days_start_total=Date_Time(3)
        ELSEIF(Date_Time(2).EQ.2) THEN
            month_start='Feb.'
            days_start_total=31+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.3) THEN
            month_start='Mar.'
                days_start_total=31+28+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.4) THEN
            month_start='Apr.'
                days_start_total=31+28+31+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.5) THEN
            month_start='May '
                days_start_total=31+28+31+30+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.6) THEN
            month_start='Jun.'
                days_start_total=31+28+31+30+31+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.7) THEN
            month_start='Jul.'
                days_start_total=31+28+31+30+31+30+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.8) THEN
            month_start='Aug.'
                days_start_total=31+28+31+30+31+30+31+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.9) THEN
            month_start='Sep.'
                days_start_total=31+28+31+30+31+30+31+31+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.10) THEN
            month_start='Oct.'
                days_start_total=31+28+31+30+31+30+31+31+30+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.11) THEN
          month_start='Nov.'
          days_start_total=31+28+31+30+31+30+31+31+30+31+Date_Time(3)
        ELSE
          month_start='Dec.'
          days_start_total=31+28+31+30+31+30+31+31+30+31+30+Date_Time(3)
        ENDIF
C in seconds from beginning of year
        seconds_start_total=Date_Time(7)+(Date_Time(6)*60)+
     1         (Date_Time(5)*3600)+(days_start_total-1)*86400
C
        READ(Real_Clock(1)(1:4),'(A4)')year_start
        READ(Real_Clock(1)(7:8),'(A2)')day_start
        READ(Real_Clock(2)(1:2),'(A2)')hour_start
        READ(Real_Clock(2)(3:4),'(A2)')min_start
        READ(Real_Clock(2)(5:6),'(A2)')sec_start
C
        WRITE(21,*)
        WRITE(21,10050)day_start,month_start,year_start,
     1               hour_start,min_start,sec_start
10050 FORMAT(1x,' TrimSp simulation started at: ',A2,'.',A4,1x,A4,
     1       1x,A2,':',A2,':',A2)

C     SET INTERVAL CONSTANTS FOR OUTPUT
C
          DE   = 1.D0
          DA   = 3.D0
          DG   = 3.D0
          DGI  = 15.D0
          NE   = IDINT(100.D0/DE + 2.00001D0)
          NA   = IDINT(90.D0/DA  + 2.00001D0)
          NG   = IDINT(180.D0/DG + 2.00001D0)
          NG   = NA +NA -2
          NGIK = IDINT(180.D0/DGI+ 0.001D0)
          NE1  = NE -1
          NA1  = NA -1
          NG1  = NG -1
          IF(E0.LT.0.) GO TO 2
          E0DE = 100.0D0/(E0*DE)
          GO TO 3
  2       E0DE = 10.0D0/(DABS(E0)*DE)
  3       BW   = 180.D0/PI
          DAW  = BW/DA
          DGW  = BW/DG
          DGIK = BW/DGI
C
C     CALCULATION OF CHARGE AND MASS DEPENDENT CONSTANTS
C
          PI2=2.D0*PI
          ABC=AB*FP
          LMAX=7
          JMAX=5
          L=ISRCHEQ(LMAX,DX(1),1,0.D0)-1
C
C     Checks wether depth interval is an integer denominator of layer thickness or not
C     If not, calculated implantation profile is not correct.
C
          depth_interval_flag = 1
          LOOP_Check_layer_thick : DO K=1,L-1                     
            IF(.NOT.EQUAL(DX(K)/CW-DBLE(IDINT(DX(K)/CW)),0.D0)) THEN
                                depth_interval_flag = 0
                                EXIT LOOP_Check_layer_thick
            ENDIF
          ENDDO LOOP_Check_layer_thick
C
          DO 165 I=1,L
          DO 155 J=1,JMAX
            IF(EQUAL(CO(I,J),0.D0)) GOTO 156
C          IF(CO(I,J).D0EQ.D00.D000) GO TO 156
  155     CONTINUE
          J=JMAX+1
  156     NJ(I)=J-1
  165     CONTINUE
          JT(1) = 0
          JT(2) = NJ(1)
          JT(3) = NJ(1)+NJ(2)
          JT(4) = JT(3)+NJ(3)
          JT(5) = JT(4)+NJ(4)
          JT(6) = JT(5)+NJ(5)
          JT(7) = JT(6)+NJ(6)
          LJ = NJ(1)+NJ(2)+NJ(3)+NJ(4)+NJ(5)+NJ(6)+NJ(7)
          XX(1)=DX(1)
          DO 170 I=2,L
  170     XX(I)=XX(I-1)+DX(I)
          DO 180 I=1,L
          DO 180 J=1,NJ(I)
          Z2(I)=Z2(I)+CO(I,J)*ZT(I,J)
          M2(I)=M2(I)+CO(I,J)*MT(I,J)
  180     CONTINUE
          DO 185 LL=1,L
          ARHO(LL)  = RHO(LL)*AN/M2(LL)
          LM(LL)    = ARHO(LL)**(-1.D0/3.D0)
          ASIG(LL)  = LM(LL)*ARHO(LL)
          PDMAX(LL)  = LM(LL)/DSQRT(PI)
          K2(LL)    = .133743D0*Z2(LL)**(2.D0/3.D0)/DSQRT(M2(LL))
          AM(LL)    = CA*ABC*(Z2(LL)**(-1.D0/3.D0))
          FM(LL)    = AM(LL)*M2(LL)/(Z1*Z2(LL)*E2*(M1+M2(LL)))
          EPS0(LL)  = FM(LL)*E0
  185     CONTINUE
          DO 186 J = 1,NJ(1)
          ZZ(J) = ZT(1,J)
          TM(J) = MT(1,J)
          DI(J) = ED(1,J)
  186     EP(J) = BE(1,J)
          DO 187 J = 1,NJ(2)
          ZZ(NJ(1)+J) = ZT(2,J)
          TM(NJ(1)+J) = MT(2,J)
          DI(NJ(1)+J) = ED(2,J)
  187     EP(NJ(1)+J) = BE(2,J)
          DO 188 J = 1,NJ(3)
          ZZ(NJ(1)+NJ(2)+J) = ZT(3,J)
          TM(NJ(1)+NJ(2)+J) = MT(3,J)
          DI(NJ(1)+NJ(2)+J) = ED(3,J)
  188     EP(NJ(1)+NJ(2)+J) = BE(3,J)
          DO 1880 J = 1,NJ(4)
          ZZ(NJ(1)+NJ(2)+NJ(3)+J) = ZT(4,J)
          TM(NJ(1)+NJ(2)+NJ(3)+J) = MT(4,J)
          DI(NJ(1)+NJ(2)+NJ(3)+J) = ED(4,J)
 1880     EP(NJ(1)+NJ(2)+NJ(3)+J) = BE(4,J)
          DO 1881 J = 1,NJ(5)
          ZZ(NJ(1)+NJ(2)+NJ(3)+NJ(4)+J) = ZT(5,J)
          TM(NJ(1)+NJ(2)+NJ(3)+NJ(4)+J) = MT(5,J)
          DI(NJ(1)+NJ(2)+NJ(3)+NJ(4)+J) = ED(5,J)
 1881     EP(NJ(1)+NJ(2)+NJ(3)+NJ(4)+J) = BE(5,J)
          DO 1882 J = 1,NJ(6)
          ZZ(NJ(1)+NJ(2)+NJ(3)+NJ(4)+NJ(5)+J) = ZT(6,J)
          TM(NJ(1)+NJ(2)+NJ(3)+NJ(4)+NJ(5)+J) = MT(6,J)
          DI(NJ(1)+NJ(2)+NJ(3)+NJ(4)+NJ(5)+J) = ED(6,J)
 1882     EP(NJ(1)+NJ(2)+NJ(3)+NJ(4)+NJ(5)+J) = BE(6,J)
          DO 18803 J = 1,NJ(7)
          ZZ(NJ(1)+NJ(2)+NJ(3)+NJ(4)+NJ(5)+NJ(6)+J) = ZT(7,J)
          TM(NJ(1)+NJ(2)+NJ(3)+NJ(4)+NJ(5)+NJ(6)+J) = MT(7,J)
          DI(NJ(1)+NJ(2)+NJ(3)+NJ(4)+NJ(5)+NJ(6)+J) = ED(7,J)
18803     EP(NJ(1)+NJ(2)+NJ(3)+NJ(4)+NJ(5)+NJ(6)+J) = BE(7,J)
          DO 189 I=1,L
          COM(1,I) = CO(I,1)
          DO 189 J=1,NJ(I)-1
          COM(J+1,I) = COM(J,I)+CO(I,J+1)
  189     CONTINUE
          DO 190  J = 1,LJ
          MU1(J)  = M1/TM(J)
          EC1(J) = 4.D0*MU1(J)/((1.D0+MU1(J))*(1.D0+MU1(J)))
C         KR-C (IPOT=1), MOLIERE (IPOT=2), ZBL POTENTIAL (IPOT=3)
          A1(J)  = CVMGT(CA*ABC*(ZZ(J)**(-1.D0/3.D0)),
     #                   CA*ABC/(Z1**0.23D0+ZZ(J)**0.23D0),IPOT.LT.3)
          F1(J)  = A1(J)*TM(J)/(Z1*ZZ(J)*E2*(M1+TM(J)))
          KL1(J) = 1.212D0*Z1**(7.D0/6.D0)*ZZ(J)/
     #           ((Z1**(2.D0/3.D0)+ZZ(J)**(2.D0/3.D0))**1.5D0*DSQRT(M1))
  190     CONTINUE
          IF(IPOT.EQ.1) THEN
C         KR-C POTENTIAL (IPOT=1)
          DO 194 J=1,LJ
          KOR1(J) = 0.0389205D0*KL1(J)/(PI*A1(J)*A1(J))
  194     CONTINUE
          ELSEIF (IPOT.EQ.2) THEN
C         MOLIERE POTENTIAL (IPOT=2)
          DO 195 J=1,LJ
          KOR1(J) = 0.045D0*KL1(J)/(PI*A1(J)*A1(J))
  195     CONTINUE
          ELSEIF (IPOT.EQ.3) THEN
C         ZBL POTENTIAL
          DO 196 J=1,LJ
          KOR1(J) = 0.0203253D0*KL1(J)/(PI*A1(J)*A1(J))
  196     CONTINUE
          ENDIF
          DO 191  I = 1,LJ
          DO 191  J = 1,LJ
          MU(I,J)  = TM(I)/TM(J)
          EC(I,J)  = 4.D0*MU(I,J)/((1.D0+MU(I,J))*(1.D0+MU(I,J)))
C         KR-C , MOLIERE , ZBL POTENTIAL
          A(I,J)= CVMGT(CA*ABC/(DSQRT(ZZ(I))+DSQRT(ZZ(J)))**(2.D0/3.D0)
     #                 ,CA*ABC/(ZZ(I)**0.23D0+ZZ(J)**0.23D0),IPOTR.LT.3)
C         ZBL POTENTIAL
          F(I,J)   = A(I,J)*TM(J)/(ZZ(I)*ZZ(J)*E2*(TM(I)+TM(J)))
          KL(I,J)  = 1.212D0*ZZ(I)**(7.D0/6.D0)*ZZ(J)/
     #     ((ZZ(I)**(2.D0/3.D0)+ZZ(J)**(2.D0/3.D0))**1.5D0*DSQRT(TM(I)))
  191     CONTINUE
          IF (IPOTR.EQ.1) THEN
C         KR-C POTENTIAL (IPOTR=1)
          DO 197  I = 1,LJ
          DO 197  J = 1,LJ
          KOR(I,J) = 0.0389205D0*KL(I,J)/(PI*A(I,J)*A(I,J))
  197     CONTINUE
          ELSEIF (IPOTR.EQ.2) THEN
C         MOLIERE POTENTIAL (IPOTR=2)
          DO 198  I = 1,LJ
          DO 198  J = 1,LJ
          KOR(I,J) = 0.045D0*KL(I,J)/(PI*A(I,J)*A(I,J))
  198     CONTINUE
          ELSEIF (IPOTR.EQ.3) THEN
C         ZBL POTENTIAL (IPOTR=3)
          DO 184  I = 1,LJ
          DO 184  J = 1,LJ
          KOR(I,J) = 0.0203253D0*KL(I,J)/(PI*A(I,J)*A(I,J))
  184     CONTINUE
          ENDIF
          DO 192 LL=1,L
          DO 192 J=1,NJ(LL)
          KLM1(LL) = KLM1(LL)+CO(LL,J)*KL1(J+JT(LL))*CK(LL)
          CHM1(LL) = CHM1(LL)+CO(LL,J)*CH1(LL,J)
          SB(LL) = SB(LL)+CO(LL,J)*SBE(LL,J)
  192     CONTINUE
          DO 193 I=1,LJ
          DO 193 LL = 1,L
          DO 193 J=1,NJ(LL)
C         KLM(LL,I) = KLM(LL,I)+CK(LL)*CO(LL,J)*KL(I,J+JT(LL))
          KLM(LL,I) = KLM(LL,I)+CO(LL,J)*KL(I,J+JT(LL))
  193     CONTINUE
C
C          ALPHA = CVMGT( .001,    ALPHA, ALPHA.EQ.0.  )
C          ALPHA = CVMGT( 179.999, ALPHA, ALPHA.EQ.180.)
          ALPHA = CVMGT( .001D0,    ALPHA, EQUAL(ALPHA,0.D0))
                ALPHA = CVMGT( 179.999D0, ALPHA, EQUAL(ALPHA,180.D0))

          IF(ALPHA.GE.90.0.AND.X0.LE.0.0) GO TO 8881
          GO TO 8882
 8881     WRITE(6,8883)
 8883     FORMAT(1X,'ERROR : IF ALPHA.GE.90. THEN IT MUST BE X0.LE.0.')
          GO TO 8000
 8882     CONTINUE
C
C     SET CONSTANT DISTANCES
C
          TT   = XX(L)
          INEL = 0
          HLM  = CVMGT( 0.D0, -.5D0*LM(1), INEL.EQ.0)
          HLMT = CVMGT( TT, TT+.5D0*LM(L), INEL.EQ.0)
          SU1  = PDMAX(1) + PDMAX(1)
          SU2  = PDMAX(1)*(1.D0+KK0)
          SUR  = PDMAX(1)*(1.D0+KK0R)
          SU   = DMAX1(SUR,DMAX1(SU1,SU2))
          SUT1 = TT + PDMAX(L) + PDMAX(L)
          SUT2 = TT + PDMAX(L)*(1.D0+KK0) 
          SUTR = TT + PDMAX(L)*(1.D0+KK0R)
          SUT  = DMAX1(SUTR,DMAX1(SUT1,SUT2))
          XC   = CVMGT( X0, -SU, X0.GT.0.D0)
          RT   = TT-RD
C
          IF(E0.GE.0.D0) GO TO 51
C
C     SET CONSTANTS FOR MAXWELLIAN DISTRIBUTION
C
          TI   = -1.D0*E0
          ZARG = DSQRT(TI/(M1*2.D0))
          VELC = SHEATH/M1
C
C     NUMBERS FOR VECTORIZED LOOPS
C
   51     NUM  = MIN( 64, NH)
          IH   = NUM
          IH1  = NUM
C
C     RANDOM START CONDITIONS
C
          IY   = IDINT(RI)
          IY2  = IDINT(RI2)
          IY3  = IDINT(RI3)
CC    ANFANG   = RANSET(IY)
CC    ANFANG   = SRAND48(IY)
       ISEED   = IY
       ISEED2  = IY2
         ISEED3  = IY3
C      WRITE(*,*)ISEED
C
          IF ( E0.GT.0.D0 )    GO TO 47
          IF ( ALPHA.GE.0.D0 ) THEN
C
C     MAXWELLIAN VELOCITY DISTRIBUTION
C
          CALL VELOCV(FG,FFG,E,COSX,COSY,COSZ,SINE,NUM)
            DO 49 IV=1,NUM
            EMX = EMX+E(IV)
   49       CONTINUE
      DO iv=1,num
      ne = IDINT(DMIN1(5000.D0,e(iv)+1.D0))
      me(ne) = me(ne)+1
      ENDDO
c
            GO TO 56
C
C     MAXWELLIAN ENERGY DISTRIBUTION
C
          ELSE
C
            CALL ENERGV(FE,E,COSX,COSY,COSZ,SINE,NUM)
            DO 48 IV=1,NUM
            EMX = EMX+E(IV)
   48       CONTINUE
            GO TO 56
          ENDIF
C
   47     CONTINUE
C
          IF(EQUAL(Esig,0.D0)) THEN
C     FIXED PROJECTILE ENERGY
              DO IV=1,NUM
                                E(IV) = E0
C                 WRITE(*,*)' Da Esig=0 ist E=E0'
                        ENDDO
                ELSE
C     GAUSSIAN ENERGY DISTRIBUTION
                        DO IV=1,NUM
5200                            CALL ENERGGAUSS(ISEED2,Esig,Epar,E0)
                                tryE = tryE+1
                                IF(Epar.LE.0.0D0) THEN
                                        negE = negE+1
                                        GO TO 5200
                                ENDIF
                                E(IV)=Epar
C                               WRITE(*,*)E(IV),Epar,E0
                        ENDDO
         ENDIF
C
C die nachfolgende Zeile wurden von Linie 633 hier hin verschoben
C
      SFE   = DMIN1(SB(1),SB(L))
C
      IF ( ALPHA.GE.0.D0 ) THEN
C
                IF(EQUAL(ALPHASIG,0.D0))THEN
C
C     FIXED PROJECTILE ANGLE
C
C nachfolgende drei Zeilen waren vorher bei LINIE 633
                        ALFA  = ALPHA /BW
                        CALFA = DCOS(ALFA)
                        SALFA = DSIN(ALFA)
                        DO IV=1,NUM                             
                                COSX(IV) = CALFA
                                COSY(IV) = SALFA
                                COSZ(IV) = 0.D0
                                SINE(IV) = COSY(IV)
C                               WRITE(88,*)ALPHA,ALPHASIG,CALFA,SALFA
                        ENDDO
                ELSE
C
C     1-D GAUSSIAN DISTRIBUTION OF ANGLE
C
                  DO IV=1,NUM
                    CALL ALPHAGAUSS(ISEED3,ALPHASIG,ALPHA,ALFA,ALPHApar,
     +                   CALFA,SALFA,BW)
                      COSX(IV) = CALFA
                      COSY(IV) = SALFA
                      COSZ(IV) = 0.D0
                      SINE(IV) = COSY(IV)
C                     WRITE(88,'(5(F12.5))')ALPHA,ALPHASIG,
C     +                  ALPHApar,CALFA,SALFA
                  ENDDO
                ENDIF          
C
        ELSEIF (EQUAL(ALPHA,-2.D0)) THEN
C      ELSEIF ( ALPHA.EQ.-2. ) THEN
C
C     COSINE ANGLE DISTRIBUTION (THREE-DIMENSIONAL)
C
CDIR$ IVDEP
              DO 53  IV=1,NUM
CC              RPHI     = PI2*RANF()
CC              RPHI     = PI2*DRAND48()
CC              RPHI     = PI2*DBLE(RAN(ISEED))
                call ranlux(ran2,2)
                RPHI     = PI2*DBLE(ran2(1))
CC              RTHETA   = RANF()
CC              RTHETA   = DRAND48()
CC              RTHETA   = DBLE(RAN(ISEED))
                RTHETA   = DBLE(ran2(2))
                COSX(IV) = DSQRT(RTHETA)
                SINE(IV) = DSQRT(1.D0-RTHETA)
                COSY(IV) = SINE(IV)*DCOS(RPHI)
                COSZ(IV) = SINE(IV)*DSIN(RPHI)
   53         CONTINUE
C
        ELSEIF (EQUAL(ALPHA,-1.D0).AND.X0.GT.0.D0) THEN
C      ELSEIF ( ALPHA.EQ.-1. AND. X0.GT.0. )    THEN
C
C     RANDOM DISTRIBUTION
C
CDIR$ IVDEP
              DO 50  IV=1,NUM
CC              RPHI     = PI2*RANF()
CC              RPHI     = PI2*DRAND48()
CC              RPHI     = PI2*DBLE(RAN(ISEED))
                call ranlux(ran2,2)
                RPHI     = PI2*DBLE(ran2(1))
CC              RTHETA   = RANF()
CC              RTHETA   = DRAND48()
CC              RTHETA   = DBLE(RAN(ISEED))
                RTHETA   = DBLE(ran2(2))
                COSX(IV) = 1.D0 -2.D0*RTHETA
                SINE(IV) = DSQRT( 1.D0 -COSX(IV)*COSX(IV))
                COSY(IV) = SINE(IV) *DSIN(RPHI)
                COSZ(IV) = SINE(IV) *DCOS(RPHI)
   50         CONTINUE
C
C      ELSEIF ( ALPHA.EQ.-1. AND. X0.LE.0. )    THEN
        ELSEIF (EQUAL(ALPHA,-1.D0).AND.X0.LE.0.D0) THEN
C
CDIR$ IVDEP
              DO 55  IV=1,NUM
CC              RPHI     = PI2*RANF()
CC              RPHI     = PI2*DRAND48()
CC              RPHI     = PI2*DBLE(RAN(ISEED))
                call ranlux(ran2,2)
                RPHI     = PI2*DBLE(ran2(1))
CC              RTHETA   = RANF()
CC              RTHETA   = DRAND48()
CC              RTHETA   = DBLE(RAN(ISEED))
                RTHETA   = DBLE(ran2(2))
                COSX(IV) = 1.D0 -RTHETA
                SINE(IV) = DSQRT( 1.D0 -COSX(IV)*COSX(IV))
                COSY(IV) = SINE(IV) *DSIN(RPHI)
                COSZ(IV) = SINE(IV) *DCOS(RPHI)
   55         CONTINUE
C
      ENDIF
C
   56     IF ( X0.GT.0.D0 )   GO TO 59
C
C     EXTERNAL START
C
            DO 57  IV=1,NUM
              SINA     = SINE(IV)
              COSX(IV) = DSQRT( ( E(IV)*COSX(IV)*COSX(IV) +ESB)
     &                        /( E(IV) +ESB))
              SINE(IV) = DSQRT( 1.D0 -COSX(IV)*COSX(IV))
              COSY(IV) = COSY(IV) *SINE(IV) /SINA
              COSZ(IV) = COSZ(IV) *SINE(IV) /SINA
              E(IV)    = E(IV) + ESB
   57       CONTINUE
C
C     LOCUS OF FIRST COLLISION
C
   59     JL = ISRCHFGT(L,XX(1),1,X0)
C            WRITE(*,*)X0
            DO 58  IV=1,NUM
CC            RA     = CVMGT(RANF(),1.0,X0.LE.0.0)
CC            RA     = CVMGT(DRAND48(),1.0,X0.LE.0.0)
CC            RA     = CVMGT(DBLE(RAN(ISEED)),1.D0,X0.LE.0.0D0)
	      call ranlux(random, 1)
              RA     = CVMGT(DBLE(random),1.D0,X0.LE.0.0D0)
              X(IV)  = XC + LM(JL) *RA *COSX(IV)
              Y(IV)  = LM(JL) *RA *COSY(IV)
              Z(IV)  = LM(JL) *RA *COSZ(IV)
              PL(IV) = CVMGT(0.D0,LM(JL)*RA,X0.LE.0.0)
   58       CONTINUE
C
           DO 199 IV=1,NUM
           LLL(IV) = JL
  199      CONTINUE
C
C     PROJECTILE LOOP
C
    1     CONTINUE
C
      NPROJ=NPROJ+1
C
      DO 63 IV=1,IH1
      CX(IV)=COSX(IV)
      CY(IV)=COSY(IV)
      CZ(IV)=COSZ(IV)
      SX(IV)=SINE(IV)
      DEES(IV)=0.D0
      DENS(IV)=0.D0
      DEN(IV)=0.D0
   63 CONTINUE
      KK1=KK0
C
C     COLLISION LOOP (INCLUDES WEAK SIMULTANEOUS COLL. FOR KK1.LT.4)
C
      DO 245 KK=KK1,0,-1
C
C     CHOICE OF COLLISION PARTNERS
C
      DO 298 IV=1,IH1
      call ranlux(random, 1)
      JJJ(IV) = ISRCHFGE(NJ(LLL(IV)),COM(1,LLL(IV)),1
CC   #          ,RANF())+JT(LLL(IV))
CC   #          ,DRAND48())+JT(LLL(IV))
CC   #          ,DBLE(RAN(ISEED)))+JT(LLL(IV))
     #          ,DBLE(random))+JT(LLL(IV))
  298 CONTINUE
      DO 67 IV=1,IH1
      EPS(IV)=E(IV)*F1(JJJ(IV))
   67 CONTINUE
C
CDIR$ IVDEP
      DO 64 IV=1,IH1
C
C     RANDOM AZIMUTHAL ANGLE AND IMPACT PARAMETER
C
CC    PHIP=PI2*RANF()
CC    PHIP=PI2*DRAND48()
CC    PHIP=PI2*DBLE(RAN(ISEED))
      call ranlux(ran2, 2)
      PHIP=PI2*DBLE(ran2(1))
      CPHI(IV)=DCOS(PHIP)
      SPHI(IV)=DSIN(PHIP)
CC    P(IV)=PDMAX(LLL(IV))*DSQRT(RANF()+KK)
CC    P(IV)=PDMAX(LLL(IV))*DSQRT(DRAND48()+KK)
CC    P(IV)=PDMAX(LLL(IV))*DSQRT(DBLE(RAN(ISEED))+KK)
      P(IV)=PDMAX(LLL(IV))*DSQRT(DBLE(ran2(2))+KK)
C
C     POSITION OF TARGET ATOM
C
      X1(IV)=X(IV)-P(IV)*CPHI(IV)*SX(IV)
      P(IV)=CVMGT(1.D10,P(IV),X1(IV).LT.0.D0.OR.X1(IV).GT.TT)
C       IF(A1(JJJ(IV)).EQ.0.) WRITE(99,'(A50)')' A1 vor Label 64 '
      B(IV)=P(IV)/A1(JJJ(IV))
   64 CONTINUE
      CALL SCOPY(IH1,B,1,R,1)
C       WRITE(99,*)IH1,B(IV),R(IV)
C     CALL MAGICKRC(C2(1),S2(1),B(1),R(1),EPS(1),IH1)
      IVMIN=1
      IVMAX=IH1
C
C     MAGIC (DETERMINATION OF SCATTERING ANGLE : KRYPTON-CARBON POT.)
C
      IF(IPOT.NE.1) GO TO 4101
C     KRYPTON-CARBON POTENTIAL
C     CALL MAGICKRC(C2(1),S2(1),B(1),R(1),EPS(1),IH1)

  104 DO 105 IV=IVMIN,IVMAX 
      IF(R(IV).LT.1.D-20)THEN 
        WRITE(99,'(A70)')'in DO 104 R(IV)<1.D-20 -> 0.00001D0 gesetzt'
        R(IV)=0.00001D0
        ENDIF
      EX1(IV)=DEXP(-.278544D0*R(IV))
      EX2(IV)=DEXP(-.637174D0*R(IV))
      EX3(IV)=DEXP(-1.919249D0*R(IV))

      RR1=1.D0/R(IV)
C       IF(R(IV).EQ.0.D0)WRITE(99,'(1x,F15.7,1x,A50)')R(IV),' Label 104 '
      V(IV)=(.190945D0*EX1(IV)+.473674D0*EX2(IV)+.335381D0*EX3(IV))*RR1
      FR=B(IV)*B(IV)*RR1+V(IV)*R(IV)/EPS(IV)-R(IV)
      V1(IV)=-(V(IV)+.05318658408D0*EX1(IV)+.301812757276D0*EX2(IV)+
     1         .643679648869D0*EX3(IV))*RR1
      FR1=-B(IV)*B(IV)*RR1*RR1+(V(IV)+V1(IV)*R(IV))/EPS(IV)-1.D0
      Q=FR/FR1
      R(IV)=R(IV)-Q
      TEST(IV)=DABS(Q/R(IV)).GT.0.001D0
  105 CONTINUE
C     GET MAX AND MIN INDEX OF TEST FAILURES
      IVMIN=IVMIN+ILLZ(IVMAX-IVMIN+1,TEST(IVMIN),1)
      IF(IVMIN.GT.IVMAX) GO TO 106
      IVMAX=IVMAX-ILLZ(IVMAX-IVMIN+1,TEST(IVMIN),-1)
      IF(IVMIN.GT.IVMAX) GO TO 106
      GO TO 104
  106 DO 108 IV=1,IH1
      ROCINV=-0.5D0*V1(IV)/(EPS(IV)-V(IV))
      SQE=DSQRT(DABS(EPS(IV)))
      CC=(.235809D0+SQE)/(.126000D0+SQE)
      AA=2.D0*EPS(IV)*(1.D0+(1.0144D0/SQE))*B(IV)**CC
      FF=(DSQRT(AA*AA+1.)-AA)*((69350.D0+EPS(IV))/(83550.D0+EPS(IV)))
      DELTA=(R(IV)-B(IV))*AA*FF/(FF+1.D0)
      C=(ROCINV*(B(IV)+DELTA)+1.D0)/(ROCINV*R(IV)+1.D0)
      C2(IV)=DMIN1(1.0D0,C*C)
  108 S2(IV)=1.D0-(1.D0*C2(IV))
      GO TO 4103
C
 4101 IF(IPOT.NE.2) GO TO 4102
C     MOLIERE POTENTIAL
C     CALL MAGICMOL(C2(1),S2(1),B(1),R(1),EPS(1),IH1)
 4104 DO 4105 IV=IVMIN,IVMAX
      IF(R(IV).LT.1.D-20)THEN 
        WRITE(99,'(A70)')'in DO 4104 R(IV)<1.D-20 -> 0.00001D0 gesetzt'
        R(IV)=0.00001D0
        ENDIF
      EX1(IV)=DEXP(-.3D0*R(IV))
      EX2(IV)=DEXP(-1.2D0*R(IV))
      EX3(IV)=DEXP(-6.0D0*R(IV))
C       IF(R(IV).EQ.0.D0)WRITE(99,'(A50)')' R nach Label 4104 '
      RR1=1.D0/R(IV)
      V(IV)=(.35D0*EX1(IV)+.55D0*EX2(IV)+.10D0*EX3(IV))*RR1
      FR=B(IV)*B(IV)*RR1+V(IV)*R(IV)/EPS(IV)-R(IV)
      V1(IV)=-(V(IV)+.105D0*EX1(IV)+.66D0*EX2(IV)+.6D0*EX3(IV))*RR1
      FR1=-B(IV)*B(IV)*RR1*RR1+(V(IV)+V1(IV)*R(IV))/EPS(IV)-1.D0
      Q=FR/FR1
      R(IV)=R(IV)-Q
      TEST(IV)=DABS(Q/R(IV)).GT.0.001D0
 4105 CONTINUE
C     GET MAX AND MIN INDEX OF TEST FAILURES
      IVMIN=IVMIN+ILLZ(IVMAX-IVMIN+1,TEST(IVMIN),1)
      IF(IVMIN.GT.IVMAX) GO TO 4106
      IVMAX=IVMAX-ILLZ(IVMAX-IVMIN+1,TEST(IVMIN),-1)
      IF(IVMIN.GT.IVMAX) GO TO 4106
      GO TO 4104
 4106 DO 4108 IV=1,IH1
C      IF((EPS(IV)-V(IV)).EQ.0.D0)WRITE(99,'(A50)')' nach Label 4106 '
      ROCINV=-0.5D0*V1(IV)/(EPS(IV)-V(IV))
      SQE=DSQRT(EPS(IV))
      CC=(.009611D0+SQE)/(.005175D0+SQE)
      AA=2.D0*EPS(IV)*(1.D0+(0.6743D0/SQE))*B(IV)**CC
      FF=(DSQRT(AA*AA+1.D0)-AA)*((6.314D0+EPS(IV))/(10.D0+EPS(IV)))
      DELTA=(R(IV)-B(IV))*AA*FF/(FF+1.D0)
      C=(ROCINV*(B(IV)+DELTA)+1.D0)/(ROCINV*R(IV)+1.D0)
      C2(IV)=DMIN1(1.0D0,C*C)
 4108 S2(IV)=1.D0-(1.D0*C2(IV))
      GO TO 4103
C
 4102 IF(IPOT.NE.3) GO TO 4103
C     ZBL POTENTIAL
C     CALL MAGICZBL(C2(1),S2(1),B(1),R(1),EPS(1),IH1)
 5104 DO 5105 IV=IVMIN,IVMAX
      IF(R(IV).LT.1.D-20)THEN 
        WRITE(99,'(A70)')'in DO 5104 R(IV)<1.D-20 -> 0.00001D0 gesetzt'
        R(IV)=0.00001D0
        ENDIF
      EX1(IV)=DEXP(-.20162D0*R(IV))
      EX2(IV)=DEXP(-.4029D0*R(IV))
      EX3(IV)=DEXP(-.94229D0*R(IV))
      EX4(IV)=DEXP(-3.1998D0*R(IV))
C       IF(R(IV).EQ.0.D0)WRITE(99,'(A50)')' R nach Label 5104 '
      RR1=1.D0/R(IV)
      V(IV)=(.02817D0*EX1(IV)+.28022D0*EX2(IV)+.50986D0*EX3(IV)+
     1       .18175D0*EX4(IV))*RR1
      FR=B(IV)*B(IV)*RR1+V(IV)*R(IV)/EPS(IV)-R(IV)
      V1(IV)=-(V(IV)+.0056796354D0*EX1(IV)+.112900638D0*EX2(IV)+
     1         .4804359794D0*EX3(IV)+.58156365D0*EX4(IV))*RR1
      FR1=-B(IV)*B(IV)*RR1*RR1+(V(IV)+V1(IV)*R(IV))/EPS(IV)-1.D0
      Q=FR/FR1
      R(IV)=R(IV)-Q
      TEST(IV)=DABS(Q/R(IV)).GT.0.001D0
 5105 CONTINUE

C     GET MAX AND MIN INDEX OF TEST FAILURES
      IVMIN=IVMIN+ILLZ(IVMAX-IVMIN+1,TEST(IVMIN),1)
      IF(IVMIN.GT.IVMAX) GO TO 5106
      IVMAX=IVMAX-ILLZ(IVMAX-IVMIN+1,TEST(IVMIN),-1)
      IF(IVMIN.GT.IVMAX) GO TO 5106
      GO TO 5104
 5106 DO 5108 IV=1,IH1
      IF((EPS(IV)-V(IV)).EQ.0.D0)WRITE(99,'(A50)')' nach Label 5106 '
      ROCINV=-0.5D0*V1(IV)/(EPS(IV)-V(IV))
      SQE=DSQRT(EPS(IV))
      CC=(.011615D0+SQE)/(.0071222D0+SQE)
      AA=2.D0*EPS(IV)*(1.D0+(0.99229D0/SQE))*B(IV)**CC
      FF=(DSQRT(AA*AA+1.D0)-AA)*((9.3066D0+EPS(IV))/(14.813D0+EPS(IV)))
      DELTA=(R(IV)-B(IV))*AA*FF/(FF+1.D0)
      C=(ROCINV*(B(IV)+DELTA)+1.D0)/(ROCINV*R(IV)+1.D0)
      C2(IV)=DMIN1(1.0D0,C*C)
 5108 S2(IV)=1.D0-(1.D0*C2(IV))
 4103 CONTINUE
C
C     END OF MAGIC
C
      DO 65 IV=1,IH1
      DEN(IV)=EC1(JJJ(IV))*E(IV)*S2(IV)
C     TAU(IV)=CVMGT(P(IV)*DSQRT(S2(IV)/C2(IV)),0.,KK.EQ.4)
        IF(C2(IV).LT.1.D-10) THEN
c               WRITE(*,*)C2(IV),S2(IV)
                WRITE(99,'(A50)')' C2 < 10^-10, C2,S2,DEN resettet '
                C2(IV)=1.D-10
                S2(IV)=1.D0-(1.D0*C2(IV))
            DEN(IV)=EC1(JJJ(IV))*E(IV)*S2(IV)
c               WRITE(*,*)C2(IV),S2(IV)
        ENDIF
      TAU(IV)=CVMGT(P(IV)*DSQRT(DABS(S2(IV)/C2(IV))),0.D0,KK.EQ.0)
      TAU(IV)=DMIN1(TAU(IV),LM(LLL(IV)))
      CT(IV)=C2(IV)+C2(IV)-1.D0
      ST(IV)=DSQRT(DABS(1.D0-CT(IV)*CT(IV)))
      CU=CT(IV)+MU1(JJJ(IV))
      CU=CVMGT(CU,1.0D-8,DABS(CU).GE.1.0D-8)
      TA=ST(IV)/CU
      TA2=1.D0/DSQRT(DABS(1.D0+TA*TA))
      CPSI(IV)=CVMGT(TA2,-TA2,CU.GT.0.D0)
      SPSI(IV)=DABS(TA)*TA2
      DEEOR=CVMGT(KOR1(JJJ(IV))*DSQRT(DABS(E(IV)))*EX1(IV),0.D0,
     #            KDEE1.EQ.2.OR.KDEE1.EQ.3)
      DENS(IV)=DENS(IV)+DEN(IV)
      DEES(IV)=DEES(IV)+DEEOR
   65 CONTINUE
C
C     DETERMINATION OF NEW FLIGHT DIRECTIONS
C
      CALL DIRCOS(COSX(1),COSY(1),COSZ(1),SINE(1),CPSI(1),SPSI(1)
     *            ,CPHI(1),SPHI(1),IH1)
  245 CONTINUE
C
C     END OF COLLISION LOOP
C
C     INELASTIC ENERGY LOSS( 5 POSSIBILITIES)
C
      DO 14 IV=1,IH1
      ASIGT(IV)=(LM(LLL(IV))-TAU(IV)+TAUPSI(IV))*ARHO(LLL(IV))
      TAUPSI(IV)=TAU(IV)*DABS(CPSI(IV))
   14 CONTINUE
      GO TO(15,16,17,18,19),KDEE1
   15 DO 26 IV=1,IH1
      DEE(IV)=CVMGT(0.D0,KLM1(LLL(IV))*ASIGT(IV)*DSQRT(E(IV)),
     #              X(IV).LT.HLM.OR.X(IV).GT.HLMT)
   26 CONTINUE
      GO TO 40
   16 DO 21 IV=1,IH1
      DEE(IV)=DEES(IV)
   21 CONTINUE
      GO TO 40
   17 DO 22 IV=1,IH1
      DEE(IV)=CVMGT(DEES(IV),0.5D0*(KLM1(LLL(IV))*ASIGT(IV)*
     #            DSQRT(E(IV))+DEES(IV)),X(IV).LT.HLM.OR.X(IV).GT.HLMT)
   22 CONTINUE
      GO TO 40
   18 DO 23 IV=1,IH1
      SM(IV)=0.D0
      EM(IV)=E(IV)*0.001D0/M1
   23 CONTINUE
      DO 66 IV=1,IH1
      DO 66 J=1,NJ(LLL(IV))
      SH(IV,J)=CVMGT(CH1(LLL(IV),J)*DSQRT(EM(IV))
     #          ,CH2(LLL(IV),J)*EM(IV)**0.45D0*(CH3(LLL(IV),J)/EM(IV))
     #          *DLOG(DABS(1.D0+(CH4(LLL(IV),J)/
     #           EM(IV))+CH5(LLL(IV),J)*EM(IV)))
     #          /(CH2(LLL(IV),J)*EM(IV)**0.45D0+(CH3(LLL(IV),J)/EM(IV))
     #          *DLOG(DABS(1.D0+(CH4(LLL(IV),J)/
     #           EM(IV))+CH5(LLL(IV),J)*EM(IV))))
     #          ,EM(IV).LT.10.D0)
   66 CONTINUE
      DO 73 IV=1,IH1
      DO 73 J=1,NJ(LLL(IV))
      SM(IV)=SM(IV)+SH(IV,J)*CO(LLL(IV),J)
   73 CONTINUE
      DO 78 IV=1,IH1
      DEE(IV)=CVMGT(CHM1(LLL(IV))*DSQRT(EM(IV)),SM(IV),EM(IV).LE.10.D0)
   78 CONTINUE
      DO 69 IV=1,IH1
      DEE(IV)=10.D0*ASIGT(IV)*
     #        CVMGT(0.D0,DEE(IV),X(IV).LT.HLM.OR.X(IV).GT.HLMT)
   69 CONTINUE
      GO TO 40
   19 FHE=CVMGT(1.3333D0,1.D0,M1.LT.4.00D0)
      DO 25 IV=1,IH1
      SM(IV)=0.D0
      EM(IV)=E(IV)*0.001D0*FHE
   25 CONTINUE
      DO 74 IV=1,IH1
      DO 74 J=1,NJ(LLL(IV))
      SH(IV,J)=CH1(LLL(IV),J)*EM(IV)**CH2(LLL(IV),J)*
     #          (CH3(LLL(IV),J)/(EM(IV)*0.001D0))
     #          *DLOG(DABS(1.D0+(CH4(LLL(IV),J)/(EM(IV)*0.001D0))+
     #          CH5(LLL(IV),J)*EM(IV)*0.001D0))
     #          /(CH1(LLL(IV),J)*EM(IV)**CH2(LLL(IV),J)+
     #          (CH3(LLL(IV),J)/(EM(IV)*0.001D0))
     #          *DLOG(DABS(1.D0+(CH4(LLL(IV),J)/(EM(IV)*0.001D0))+
     #          CH5(LLL(IV),J)*EM(IV)*0.001D0)))
   74 CONTINUE
      DO 92 IV=1,IH1
      DO 92 J=1,NJ(LLL(IV))
      SM(IV)=SM(IV)+SH(IV,J)*CO(LLL(IV),J)
   92 CONTINUE
      DO 79 IV=1,IH1
      DEE(IV)=10.D0*ASIGT(IV)*
     #        CVMGT(0.D0,SM(IV),X(IV).LT.HLM.OR.X(IV).GT.HLMT)
   79 CONTINUE
   40 CONTINUE
C
      DO 44 IV=1,IH1
      DEL=DMAX1(1.0D-20,DENS(IV)+DEE(IV))
      DENS(IV)=CVMGT(E(IV)*DENS(IV)/DEL,DENS(IV),DEL.GT.E(IV))
      DEE(IV)=CVMGT(E(IV)*DEE(IV)/DEL,DEE(IV),DEL.GT.E(IV))
   44 CONTINUE
C
C     INCREMENT OF DAMAGE, CASCADE AND PHONON ENERGY
C
      DO 70 IV=1,IH1
C     IF(X(IV).LT.0.OR.X(IV).GT.TT) GO TO 70
      I=MAX0(MIN0(IDINT(X1(IV)/CW+1.D0),100),1)
      DENT(I)=DENT(I)+DENS(IV)
      DMGN(I)=DMGN(I)+DEN(IV)
      ION(I)=ION(I)+DEE(IV)
      ELE(I,JJJ(IV))=ELE(I,JJJ(IV))+DEN(IV)
      ELI(I,JJJ(IV))=ELI(I,JJJ(IV))+DEE(IV)
      IF(DEN(IV).LE.DI(JJJ(IV))) GO TO 28
      EPS(IV)=F1(JJJ(IV))*DEN(IV)
      G=EPS(IV)+.40244D0*EPS(IV)**.75D0+3.4008D0*EPS(IV)**.16667D0
      MOT=DEN(IV)/(1.D0+K2(LLL(IV))*G)
      CASMOT(I)=CASMOT(I)+MOT
      ELGD(I)=ELGD(I)+DEN(IV)
      ELD(I,JJJ(IV))=ELD(I,JJJ(IV))+DEN(IV)
      ICD(I,JJJ(IV))=ICD(I,JJJ(IV))+1
      GO TO 70
   28 PHON(I)=PHON(I)+DEN(IV)
      ELP(I,JJJ(IV))=ELP(I,JJJ(IV))+DEN(IV)
   70 CONTINUE
      DO 80 IV=1,IH1
      ICDI=ICDI+IDINT(CVMGT(1.D0,0.D0,DEN(IV).GT.DI(JJJ(IV))))
      ICSUMS=ICSUMS+IDINT(CVMGT(1.D0,0.D0,DEN(IV).GT.SB(1)))
      ICSUM=ICSUM+IDINT(CVMGT(1.D0,0.D0,DENS(IV).GT.0.D0))
   80 CONTINUE
      DO 72 IV=1,IH1
      DEN2=DEN(IV)*DEN(IV)
      DEN3=DEN2*DEN(IV)
      EEL=EEL+DEN(IV)
      EEL2=EEL2+DEN2
      EEL3=EEL3+DEN3
      EEL4=EEL4+DEN2*DEN2
      EEL5=EEL5+DEN3*DEN2
      EEL6=EEL6+DEN3*DEN3
      DEE2=DEE(IV)*DEE(IV)
      DEE3=DEE2*DEE(IV)
      EIL=EIL+DEE(IV)
      EIL2=EIL2+DEE2
      EIL3=EIL3+DEE3
      EIL4=EIL4+DEE2*DEE2
      EIL5=EIL5+DEE3*DEE2
      EIL6=EIL6+DEE3*DEE3
      EPL=EPL+CVMGT(DEN(IV),0.D0,DEN(IV).LT.DI(JJJ(IV)))
      EPL2=EPL2+CVMGT(DEN2,0.D0,DEN(IV).LT.DI(JJJ(IV)))
      EPL3=EPL3+CVMGT(DEN3,0.D0,DEN(IV).LT.DI(JJJ(IV)))
      EPL4=EPL4+CVMGT(DEN2*DEN2,0.D0,DEN(IV).LT.DI(JJJ(IV)))
      EPL5=EPL5+CVMGT(DEN3*DEN2,0.D0,DEN(IV).LT.DI(JJJ(IV)))
      EPL6=EPL6+CVMGT(DEN3*DEN3,0.D0,DEN(IV).LT.DI(JJJ(IV)))
      ENUCL(IV)=ENUCL(IV)+DENS(IV)
      EINEL(IV)=EINEL(IV)+DEE(IV)
   72 CONTINUE
      IF(KK0.EQ.0) GO TO 89
      DO 71 IV=1,IH1
      DEWC=DENS(IV)-DEN(IV)
      DEWC2=DEWC*DEWC
      DEWC3=DEWC2*DEWC
      EELWC=EELWC+DEWC
      EELWC2=EELWC2+DEWC2
      EELWC3=EELWC3+DEWC3
      EELWC4=EELWC4+DEWC2*DEWC2
      EELWC5=EELWC5+DEWC3*DEWC2
      EELWC6=EELWC6+DEWC3*DEWC3
   71 CONTINUE
   89 CONTINUE
C
C     IF IRL=0 NO RECOILS ARE FOLLOWED
      IF(IRL.EQ.0) GO TO 27
C
C     VECTORIZED RECOIL LOOP
C
C     TARGET RECOIL ATOM SECTION
C
C     PRIMARY KNOCK-ON ATOMS
C
      DO 6 IV=1,IH1
cc    IF(DEN(IV).LE.SFE) GO TO 6
      IF(DEN(IV).LE.ERC) GO TO 6
      IF(X1(IV).GT.RD.AND.X1(IV).LT.RT) GO TO 6
C
C     CALL NEWREC(NREC1,DEN(IV),X(IV),Y(IV),Z(IV),
C    1            CX(IV),CY(IV),CZ(IV),SX(IV),
C    2            CT(IV),ST(IV),PHI(IV),P(IV),
C    3            ER(1,1),XR(1,1),YR(1,1),ZR(1,1),PHIR(1,1),PSIR(1,1),
C    4            CSXR(1,1),CSYR(1,1),CSZR(1,1),SNXR(1,1),L(1,1)
      NREC1=NREC1+1
      ER(NREC1,1)=DEN(IV)-EP(JJJ(IV))
      XR(NREC1,1)=X1(IV)
      YR(NREC1,1)=Y(IV)-P(IV)*(SPHI(IV)*CZ(IV)
     *            -CPHI(IV)*CY(IV)*CX(IV))/SX(IV)
      ZR(NREC1,1)=Z(IV)+P(IV)*(SPHI(IV)*CY(IV)
     *            +CPHI(IV)*CX(IV)*CZ(IV))/SX(IV)
      CSXR(NREC1,1)=CX(IV)
      CSYR(NREC1,1)=CY(IV)
      CSZR(NREC1,1)=CZ(IV)
      SNXR(NREC1,1)=SX(IV)
      CPHIR(NREC1,1)=-CPHI(IV)
      SPHIR(NREC1,1)=-SPHI(IV)
      CT(IV)=DMIN1(CT(IV),.99999999D0)
      TAR=ST(IV)/(1.D0-CT(IV))
      TAR2=1./DSQRT(1.D0+TAR*TAR)
      CPSIR(NREC1,1)=TAR2
      SPSIR(NREC1,1)=TAR*TAR2
      TAUPSR(NREC1,1)=0.D0
      JJR(NREC1,1)=JJJ(IV)
      KO(NREC1,JJR(NREC1,1),1)=1
      INOUT(NREC1,1)=SIGN(1.D0,CX(IV))
      NPA=NPA+1
    6 CONTINUE
C
      IF(NREC1.LT.NUM) GO TO 27
C
C     START PROCESSING THE TARGET RECOIL ATOMS
C
   83 CONTINUE
C
      CALL DIRCOS(CSXR(1,1),CSYR(1,1),CSZR(1,1),SNXR(1,1)
     1            ,CPSIR(1,1),SPSIR(1,1),CPHIR(1,1),SPHIR(1,1),NREC1)
C
C     MOVE TARGET RECOIL ATOMS TO LIST 2
CDIR$ IVDEP
      DO 91 IREC1=1,NREC1
      IREC=IREC1+NREC2
      ER(IREC,2)=ER(IREC1,1)
      XR(IREC,2)=XR(IREC1,1)
      YR(IREC,2)=YR(IREC1,1)
      ZR(IREC,2)=ZR(IREC1,1)
      CSXR(IREC,2)=CSXR(IREC1,1)
      CSYR(IREC,2)=CSYR(IREC1,1)
      CSZR(IREC,2)=CSZR(IREC1,1)
      SNXR(IREC,2)=SNXR(IREC1,1)
      TAUPSR(IREC,2)=TAUPSR(IREC1,1)
      CPSIR(IREC,2)=CPSIR(IREC1,1)
      JJR(IREC,2)=JJR(IREC1,1)
      KO(IREC,JJR(IREC,2),2)=KO(IREC1,JJR(IREC1,1),1)
      INOUT(IREC,2)=INOUT(IREC1,1)
   91 CONTINUE
C
      NREC2=NREC2+NREC1
      MAXA=MAX0(MAXA,NREC2)
      NALL=NALL+NREC2
      NREC1=0
      IF(NREC2.GT.2000) GO TO 8885
      GO TO 8886
 8885 WRITE(6,8887)
 8887 FORMAT(1X,'ERROR : DIMENSION IN THE RECOIL LOOP ', 
     1           'MUST BE INCREASED')
cTR 8887 FORMAT(1X,'ERROR : DIMENSION IN THE RECOIL LOOP MUST BE
cTR     1           INCREASED')
 8886 CONTINUE
C
C     PROCESS THE PARTICLES IN LIST 2
C
C     FIND LAYER
C
      DO 68 IREC1=1,NREC2
      LRR(IREC1,2)=MIN0(ISRCHFGT(L,XX(1),1,XR(IREC1,2)),L)
   68 CONTINUE
C
C     MOVE PARTICLES
C
      DO 60 IREC1=1,NREC2
      XR(IREC1,2)=XR(IREC1,2)+(LM(LRR(IREC1,2))
     *               +TAUPSR(IREC1,2))*CSXR(IREC1,2)
      YR(IREC1,2)=YR(IREC1,2)+(LM(LRR(IREC1,2))
     *               +TAUPSR(IREC1,2))*CSYR(IREC1,2)
      ZR(IREC1,2)=ZR(IREC1,2)+(LM(LRR(IREC1,2))
     *               +TAUPSR(IREC1,2))*CSZR(IREC1,2)
   60 CONTINUE
C
      DO 81 IREC1=1,NREC2
      CXR(IREC1)=CSXR(IREC1,2)
      CYR(IREC1)=CSYR(IREC1,2)
      CZR(IREC1)=CSZR(IREC1,2)
      SXR(IREC1)=SNXR(IREC1,2)
      DEERS(IREC1)=0.D0
      TS(IREC1)=0.D0
   81 CONTINUE
C
      KK2=KK0R
      DO 235 KKR=KK2,0,-1
C
C     CHOICE OF COLLISION PARTNERS
C
      DO 303 IREC1=1,NREC2
      call ranlux(random, 1)
      JJR(IREC1,1) = ISRCHFGE(NJ(LRR(IREC1,2)),COM(1,LRR(IREC1,2))
CC   1                        ,1,RANF())+JT(LRR(IREC1,2))
CC   1                        ,1,DRAND48())+JT(LRR(IREC1,2))
CC   1                        ,1,DBLE(RAN(ISEED)))+JT(LRR(IREC1,2))
     1                        ,1,DBLE(random))+JT(LRR(IREC1,2))
  303 CONTINUE
C
CDIR$ IVDEP
      DO 236 IREC1=1,NREC2
CC    PHIPR=PI2*RANF()
CC    PHIPR=PI2*DRAND48()
CC    PHIPR=PI2*DBLE(RAN(ISEED))
      call ranlux(ran2, 2)
      PHIPR=PI2*DBLE(ran2(1))
      CPHIR(IREC1,2)=DCOS(PHIPR)
      SPHIR(IREC1,2)=DSIN(PHIPR)
CC    PR(IREC1)=PDMAX(LRR(IREC1,2))*DSQRT(RANF()+KKR)
CC    PR(IREC1)=PDMAX(LRR(IREC1,2))*DSQRT(DRAND48()+KKR)
CC    PR(IREC1)=PDMAX(LRR(IREC1,2))*DSQRT(DBLE(RAN(ISEED))+KKR)
      PR(IREC1)=PDMAX(LRR(IREC1,2))*DSQRT(DBLE(ran2(2))+KKR)
      X2(IREC1)=XR(IREC1,2)-PR(IREC1)*CPHIR(IREC1,2)*SXR(IREC1)
      PR(IREC1)=CVMGT(1.D10,PR(IREC1),X2(IREC1).LT.0.0D0
     1                            .OR.X2(IREC1).GT.TT)
      BR(IREC1)=PR(IREC1)/A(JJR(IREC1,2),JJR(IREC1,1))
      EPSR(IREC1)=F(JJR(IREC1,2),JJR(IREC1,1))*ER(IREC1,2)
  236 CONTINUE
C
      CALL SCOPY(NREC2,BR,1,RR,1)
      IVMIN=1
      IVMAX=NREC2
C
C     MAGIC (DETERMINATION OF SCATTERING ANGLE : KRYPTON-CARBON POT.)
C
      IF(IPOTR.NE.1) GO TO 4201
C     KR-C POTENTIAL
C     CALL MAGICKRC(C2R(1),S2R(1),BR(1),RR(1),EPSR(1),NREC2)
  205 DO 206 IV=IVMIN,IVMAX
      IF(RR(IV).LT.1.D-20)THEN 
        WRITE(99,'(A70)')'in DO 205 R(IV)<1.D-20 -> 0.00001D0 gesetzt'
        RR(IV)=0.00001D0
        ENDIF
      EX1R(IV)=DEXP(-.278544D0*RR(IV))
      EX2R(IV)=DEXP(-.637174D0*RR(IV))
      EX3R(IV)=DEXP(-1.919249D0*RR(IV))
      RRR1=1./RR(IV)
      VR(IV)=(.190945D0*EX1R(IV)+.473674D0*EX2R(IV)
     #    +.335381D0*EX3R(IV))*RRR1
      FR=BR(IV)*BR(IV)*RRR1+VR(IV)*RR(IV)/EPSR(IV)-RR(IV)
      V1R(IV)=-(VR(IV)+.053186584080D0*EX1R(IV)
     #    +.301812757276D0*EX2R(IV)+.643679648869D0*EX3R(IV))*RRR1
      FR1=-BR(IV)*BR(IV)*RRR1*RRR1+(VR(IV)+V1R(IV)*RR(IV))/
     1    EPSR(IV)-1.D0
      Q=FR/FR1
      RR(IV)=RR(IV)-Q
      TEST1(IV)=DABS(Q/RR(IV)).GT.0.001D0
  206 CONTINUE
C     GET MAX AND MIN INDEX OF TEST FAILURES
      IVMIN=IVMIN+ILLZ(IVMAX-IVMIN+1,TEST1(IVMIN),1)
      IF(IVMIN.GT.IVMAX) GO TO 207
      IVMAX=IVMAX-ILLZ(IVMAX-IVMIN+1,TEST1(IVMIN),-1)
      IF(IVMIN.GT.IVMAX) GO TO 207
      GO TO 205
  207 DO 208 IV=1,NREC2
      ROCINV=-.5D0*V1R(IV)/(EPSR(IV)-VR(IV))
      SQE=DSQRT(EPSR(IV))
      CC=(.235800D0+SQE)/(.126000D0+SQE)
      AA=2.D0*EPSR(IV)*(1.D0+(1.0144D0/SQE))*BR(IV)**CC
      FF=(DSQRT(AA*AA+1.D0)-AA)*((69350.D0+EPSR(IV))
     #          /(83550.D0+EPSR(IV)))
      DELTA=(RR(IV)-BR(IV))*AA*FF/(FF+1.D0)
      C=(ROCINV*(BR(IV)+DELTA)+1.D0)/(ROCINV*RR(IV)+1.D0)
      C2R(IV)=DMIN1(1.0D0,C*C)
  208 S2R(IV)=1.D0-C2R(IV)
      GO TO 4203
C
 4201 IF(IPOTR.NE.2) GO TO 4202
C     MOLIERE POTENTIAL
C     CALL MAGICMOL(C2R(1),S2R(1),BR(1),RR(1),EPSR(1),NREC2)
 4205 DO 4206 IV=IVMIN,IVMAX
      IF(RR(IV).LT.1.D-20)THEN 
        WRITE(99,'(A70)')'in DO 4205 R(IV)<1.D-20 -> 0.00001D0 gesetzt'
        RR(IV)=0.00001D0
        ENDIF
      EX1R(IV)=DEXP(-.3D0*RR(IV))
      EX2R(IV)=DEXP(-1.2D0*RR(IV))
      EX3R(IV)=DEXP(-6.0D0*RR(IV))
      RRR1=1.D0/RR(IV)
      VR(IV)=(.35D0*EX1R(IV)+.55D0*EX2R(IV)+.10D0*EX3R(IV))*RRR1
      FR=BR(IV)*BR(IV)*RRR1+VR(IV)*RR(IV)/EPSR(IV)-RR(IV)
      V1R(IV)=-(VR(IV)+.105D0*EX1R(IV)+
     #  .66D0*EX2R(IV)+.6D0*EX3R(IV))*RRR1
      FR1=-BR(IV)*BR(IV)*RRR1*RRR1+(VR(IV)+V1R(IV)*RR(IV))/
     1    EPSR(IV)-1.D0
      Q=FR/FR1
      RR(IV)=RR(IV)-Q
      TEST1(IV)=DABS(Q/RR(IV)).GT.0.001D0
 4206 CONTINUE
C     GET MAX AND MIN INDEX OF TEST FAILURES
      IVMIN=IVMIN+ILLZ(IVMAX-IVMIN+1,TEST1(IVMIN),1)
      IF(IVMIN.GT.IVMAX) GO TO 4207
      IVMAX=IVMAX-ILLZ(IVMAX-IVMIN+1,TEST1(IVMIN),-1)
      IF(IVMIN.GT.IVMAX) GO TO 4207
      GO TO 4205
 4207 DO 4208 IV=1,NREC2
      ROCINV=-.5D0*V1R(IV)/(EPSR(IV)-VR(IV))
      SQE=DSQRT(EPSR(IV))
      CC=(.009611D0+SQE)/(.005175D0+SQE)
      AA=2.D0*EPSR(IV)*(1.D0+(0.6743D0/SQE))*BR(IV)**CC
      FF=(DSQRT(AA*AA+1.D0)-AA)*((6.314D0+EPSR(IV))/(10.+EPSR(IV)))
      DELTA=(RR(IV)-BR(IV))*AA*FF/(FF+1.D0)
      C=(ROCINV*(BR(IV)+DELTA)+1.D0)/(ROCINV*RR(IV)+1.D0)
      C2R(IV)=DMIN1(1.0D0,C*C)
 4208 S2R(IV)=1.D0-C2R(IV)
      GO TO 4203
C
 4202 IF(IPOTR.NE.3) GO TO 4203
C     ZBL POTENTIAL
C     CALL MAGICZBL(C2R(1),S2R(1),BR(1),RR(1),EPSR(1),NREC2)
 5205 DO 5206 IV=IVMIN,IVMAX
      IF(RR(IV).LT.1.D-20)THEN 
        WRITE(99,'(A70)')'in DO 5205 R(IV)<1.D-20 -> 0.00001D0 gesetzt'
        RR(IV)=0.00001D0
        ENDIF
      EX1R(IV)=DEXP(-.20162D0*RR(IV))
      EX2R(IV)=DEXP(-.40290D0*RR(IV))
      EX3R(IV)=DEXP(-.94229D0*RR(IV))
      EX4R(IV)=DEXP(-3.1998D0*RR(IV))
      RRR1=1./RR(IV)
      VR(IV)=(.02817D0*EX1R(IV)+.28022D0*EX2R(IV)+.50986D0*EX3R(IV)+
     1        .18175D0*EX4R(IV))*RRR1
      FR=BR(IV)*BR(IV)*RRR1+VR(IV)*RR(IV)/EPSR(IV)-RR(IV)
      V1R(IV)=-(VR(IV)+.0056796354D0*EX1R(IV)+.112900638D0*EX2R(IV)+
     1                .4804359794D0*EX3R(IV)+.581563650D0*EX4R(IV))*RRR1
      FR1=-BR(IV)*BR(IV)*RRR1*RRR1+(VR(IV)+V1R(IV)*RR(IV))/
     1    EPSR(IV)-1.D0
      Q=FR/FR1
      RR(IV)=RR(IV)-Q
      TEST1(IV)=DABS(Q/RR(IV)).GT.0.001D0
 5206 CONTINUE
C     GET MAX AND MIN INDEX OF TEST FAILURES
      IVMIN=IVMIN+ILLZ(IVMAX-IVMIN+1,TEST1(IVMIN),1)
      IF(IVMIN.GT.IVMAX) GO TO 5207
      IVMAX=IVMAX-ILLZ(IVMAX-IVMIN+1,TEST1(IVMIN),-1)
      IF(IVMIN.GT.IVMAX) GO TO 5207
      GO TO 5205
 5207 DO 5208 IV=1,NREC2
      ROCINV=-.5D0*V1R(IV)/(EPSR(IV)-VR(IV))
      SQE=DSQRT(EPSR(IV))
      CC=(.011615D0+SQE)/(.0071222D0+SQE)
      AA=2.*EPSR(IV)*(1.D0+(0.99229D0/SQE))*BR(IV)**CC
      FF=(DSQRT(AA*AA+1.D0)-AA)*((9.3066D0+EPSR(IV))
     #             /(14.813D0+EPSR(IV)))
      DELTA=(RR(IV)-BR(IV))*AA*FF/(FF+1.D0)
      C=(ROCINV*(BR(IV)+DELTA)+1.D0)/(ROCINV*RR(IV)+1.D0)
      C2R(IV)=DMIN1(1.0D0,C*C)
 5208 S2R(IV)=1.D0-C2R(IV)
 4203 CONTINUE
C
      DO 237 IREC1=1,NREC2
      T(IREC1)=ER(IREC1,2)*S2R(IREC1)*EC(JJR(IREC1,2),JJR(IREC1,1))
      TS(IREC1)=TS(IREC1)+T(IREC1)
      T1=CVMGT(T(IREC1),0.D0,KKR.EQ.3)
      TR1=TR1+T1
      DEEORR=CVMGT(0.D0,KOR(JJR(IREC1,2),JJR(IREC1,1))*
     #             DSQRT(ER(IREC1,2))*EX1R(IREC1),KDEE2.EQ.1)
      DEERS(IREC1)=DEERS(IREC1)+DEEORR
      TAUR(IREC1)=CVMGT(PR(IREC1)*DSQRT(S2R(IREC1)/C2R(IREC1)),0.D0,
     1                    KKR.EQ.0)
      TAUR(IREC1)=DMIN1(TAUR(IREC1),LM(LRR(IREC1,2)))
      CTR(IREC1)=C2R(IREC1)+C2R(IREC1)-1.D0
      STR(IREC1)=DSQRT(1.D0-CTR(IREC1)*CTR(IREC1))
      CUR(IREC1) = CTR(IREC1)+MU(JJR(IREC1,2),JJR(IREC1,1))
      CUR(IREC1) = CVMGT(CUR(IREC1),1.0D-8,DABS(CUR(IREC1)).GE.1.0D-8)
      TAR=STR(IREC1)/CUR(IREC1)
      TAR2=1./DSQRT(1.D0+TAR*TAR)
      CPSIR(IREC1,2)=TAR2
      SPSIR(IREC1,2)=TAR*TAR2
  237 CONTINUE
C
      CALL DIRCOS(CSXR(1,2),CSYR(1,2),CSZR(1,2),SNXR(1,2),
     1            CPSIR(1,2),SPSIR(1,2),CPHIR(1,2),SPHIR(1,2),NREC2)
C
  235 CONTINUE
C
C     CREATE SECONDARY KNOCK-ON ATOMS
C
      DO 246 IREC1=1,NREC2
cc    IF(T(IREC1).LE.SFE) GO TO 246
      IF(T(IREC1).LE.ERC) GO TO 246
      IF(X2(IREC1).GT.RD.AND.X2(IREC1).LT.RT) GO TO 246
C
C     CALL NEWREC(NREC1,T(IREC1),XR(IREC1,2),YR(IREC1,2),ZR(IREC1,2),
C    1            CXR(IREC1),CYR(IREC1),CZR(IREC1),SXR(IREC1),
C    2            CTR(IREC1),STR(IREC1),PHIR(IREC1,2),PR(IREC1),
C    3            ER(I,1),XR(1,1),YR(1,1),ZR(1,1),PHIR(1,1),PSIR(1,1)
C    4            ,CSXR(1,1),CSYR(1,1),CSZR(1,1),SNXR(1,1),L(1,1)
      NREC1=NREC1+1
      ER(NREC1,1)=T(IREC1)-EP(JJR(IREC1,1))
      XR(NREC1,1)=X2(IREC1)
      YR(NREC1,1)=YR(IREC1,2)-PR(IREC1)*(SPHIR(IREC1,2)*CZR(IREC1)-
     1            CPHIR(IREC1,2)*CYR(IREC1)*CXR(IREC1))/SXR(IREC1)
      ZR(NREC1,1)=ZR(IREC1,2)+PR(IREC1)*(SPHIR(IREC1,2)*CYR(IREC1)+
     1            CPHIR(IREC1,2)*CXR(IREC1)*CZR(IREC1))/SXR(IREC1)
      CSXR(NREC1,1)=CXR(IREC1)
      CSYR(NREC1,1)=CYR(IREC1)
      CSZR(NREC1,1)=CZR(IREC1)
      SNXR(NREC1,1)=SXR(IREC1)
      CPHIR(NREC1,1)=-CPHIR(IREC1,2)
      SPHIR(NREC1,1)=-SPHIR(IREC1,2)
      CTR(NREC1)=DMIN1(CTR(IREC1),.99999999D0)
      TAR=STR(IREC1)/(1.D0-CTR(NREC1))
      TAR2=1./DSQRT(1.D0+TAR*TAR)
      CPSIR(NREC1,1)=TAR2
      SPSIR(NREC1,1)=TAR*TAR2
      TAUPSR(NREC1,1)=0.D0
      KO(NREC1,JJR(IREC1,1),1)=0
      INOUT(NREC1,1)=INOUT(IREC1,2)
      JJR(NREC1,1)=JJR(IREC1,1)
      NSA=NSA+1
  246 CONTINUE
C
C     INELASTIC ENERGY LOSS
C
      DO 238 IREC1=1,NREC2
      ASIGTR(IREC1)=(LM(LRR(IREC1,2))-TAUR(IREC1)+
     #               TAUPSR(IREC1,2))*ARHO(LRR(IREC1,2))
      TAUPSR(IREC1,2)=TAUR(IREC1)*DABS(CPSIR(IREC1,2))
  238 CONTINUE
      GO TO(115,116,117),KDEE2
  115 DO 241 IREC1=1,NREC2
        DEER(IREC1)=CVMGT(0.D0,KLM(LRR(IREC1,2),
     &		JJR(IREC1,2))*ASIGTR(IREC1)*DSQRT(ER(IREC1,2)),
     #          XR(IREC1,2).LT.HLM.OR.XR(IREC1,2).GT.HLMT)
cTR      DEER(IREC1)=CVMGT(0.,KLM(LRR(IREC1,2),JJR(IREC1,2))*ASIGTR(IREC1)*
cTR     #     DSQRT(ER(IREC1,2)),XR(IREC1,2).LT.HLM.OR.XR(IREC1,2).GT.HLMT)
  241 CONTINUE
      GO TO 242
  116 DO 243 IREC1=1,NREC2
      DEER(IREC1)=DEERS(IREC1)
  243 CONTINUE
      GO TO 242
  117 DO 244 IREC1=1,NREC2
      DEER(IREC1)=CVMGT(DEERS(IREC1),.5*(KLM(LRR(IREC1,2),JJR(IREC1,2))*
     1                  ASIGTR(IREC1)*DSQRT(ER(IREC1,2))+DEERS(IREC1)),
     2                  XR(IREC1,2).LT.HLM.OR.XR(IREC1,2).GT.HLMT)
  244 CONTINUE
  242 CONTINUE
C
      DO 344 IREC1=1,NREC2
      DELR=DMAX1(1.0D-20,TS(IREC1)+DEER(IREC1))
      TS(IREC1)=CVMGT(ER(IREC1,2)*TS(IREC1)/DELR,TS(IREC1)
     1                ,DELR.GT.ER(IREC1,2))
      DEER(IREC1)=CVMGT(ER(IREC1,2)*DEER(IREC1)/DELR,DEER(IREC1)
     1                  ,DELR.GT.ER(IREC1,2))
  344 CONTINUE
C
      DO 252 IREC1=1,NREC2
C     IF(XR(IREC1,2).LT.0.0.OR.XR(IREC1,2).GT.TT) GO TO 252
      I=MAX0(MIN0(IDINT(X2(IREC1)/CW+1.D0),100),1)
C     I=DMAX(MIN(INT(XR(IREC1,2)/CW+1.),100),1)
      DENTR(I)=DENTR(I)+TS(IREC1)
      DMGNR(I)=DMGNR(I)+T(IREC1)
      IONR(I)=IONR(I)+DEER(IREC1)
C     ELER(I,JJR(IREC1,2))=ELER(I,JJR(IREC1,2))+T(IREC1)
C     ELIR(I,JJR(IREC1,2))=ELIR(I,JJR(IREC1,2))+DEER(IREC1)
      IF(T(IREC1).LE.DI(JJR(IREC1,1))) GO TO 84
CC    EPS(IV)=F1(JJJ(IV))*DEN(IV)
CC    G=EPS(IV)+.40244*EPS(IV)**.75+3.4008*EPS(IV)**.16667
CC    MOT=DEN(IV)/(1.+K2(LLL(IV))*G)
CC    CASMOT(I)=CASMOT(I)+MOT
      ELGDR(I)=ELGDR(I)+T(IREC1)
C     ELDR(I,JJR(IREC1,2))=ELDR(I,JJR(IREC1,2))+T(IREC1)
      ICDR(I,JJR(IREC1,2))=ICDR(I,JJR(IREC1,2))+1
      ICDIRI(I,JJR(IREC1,2),JJR(IREC1,1))=
     1       ICDIRI(I,JJR(IREC1,2),JJR(IREC1,1))+1
      GO TO 252
   84 PHONR(I)=PHONR(I)+T(IREC1)
C     ELPR(I,JJJ(IREC1,2))=ELPR(I,JJJ(IREC1,2))+T(IREC1)
  252 CONTINUE
      DO 82 IREC1=1,NREC2
      ICDIR=ICDIR+IDINT(CVMGT(1.D0,0.D0,T(IREC1).GT.DI(JJR(IREC1,1))))
      ICSBR=ICSBR+IDINT(CVMGT(1.D0,0.D0,T(IREC1).GT.SB(1)))
      ICSUMR=ICSUMR+IDINT(CVMGT(1.D0,0.D0,TS(IREC1).GT.0.D0))
      ICDIRJ(JJR(IREC1,2),JJR(IREC1,1))=
     1      ICDIRJ(JJR(IREC1,2),JJR(IREC1,1))
     2      +IDINT(CVMGT(1.D0,0.D0,T(IREC1).GT.DI(JJR(IREC1,1))))
   82 CONTINUE
      DO 253 IREC1=1,NREC2
      TEL=TEL+TS(IREC1)
      TR=TR+T(IREC1)
      EI=EI+DEER(IREC1)
      ER(IREC1,2)=ER(IREC1,2)-DEER(IREC1)-TS(IREC1)+1.0D-10
      XR(IREC1,2)=XR(IREC1,2)-TAUR(IREC1)*CXR(IREC1)
      YR(IREC1,2)=YR(IREC1,2)-TAUR(IREC1)*CYR(IREC1)
      ZR(IREC1,2)=ZR(IREC1,2)-TAUR(IREC1)*CZR(IREC1)
      TESTR(IREC1)=ER(IREC1,2).LE.SFE.OR.XR(IREC1,2).LT.(-SU)
     1             .OR.XR(IREC1,2).GT.SUT
     2             .OR.(XR(IREC1,2).GT.RD.AND.XR(IREC1,2).LT.RT)
  253 CONTINUE
C
C     CHECK TO SEE IF ANY RECOIL ATOM IS SPUTTERED OR
C     IF THE ENERGY OF ANY RECOIL ATOM IS TOO LOW
C
      IVMIN=1+ILLZ(NREC2,TESTR,1)
      IF(IVMIN.GT.NREC2) GO TO 247
      IVMAX=NREC2-ILLZ(NREC2,TESTR,-1)
C
      DO 248 IREC1=IVMIN,IVMAX
  249 IF(IREC1.GT.NREC2) GO TO 247
      IF(XR(IREC1,2).LT.(-SU)) GO TO 251
      IF(XR(IREC1,2).GT.SUT) GO TO 250
cc    IF(ER(IREC1,2).LE.SFE) GO TO 255
      IF(ER(IREC1,2).LE.ERC) GO TO 255
      IF(XR(IREC1,2).GT.RD.AND.XR(IREC1,2).LT.RT) GO TO 255
      GO TO 248
  251 ENOR=ER(IREC1,2)*CXR(IREC1)*CXR(IREC1)
      IF(ENOR.GT.SB(1)) GO TO 254
C
C     RECOIL ATOM IS REFLECTED BACK INTO THE SOLID BY THE
C     POTENTIAL BARRIER
C
      XR(IREC1,2)=-1.D0*SU
      CSXR(IREC1,2)=-1.D0*CSXR(IREC1,2)
      KIS=KIS+1
      GO TO 248
C
C     RECOIL ATOM IS SPUTTERED (BACKWARD)
C
  254 ESP=ER(IREC1,2)-SB(1)
CC254 ESP=ER(IREC1,2)-SB(LRR(IREC1,2))
C
C     NUMBER, ENERGY AND MOMENTS OF ALL SPUTTERED PARTICLES
C
      IBSP(JJR(IREC1,2))=IBSP(JJR(IREC1,2))+1
      EBSP(JJR(IREC1,2))=EBSP(JJR(IREC1,2))+ESP
      SPE2=ESP*ESP
      SPE3=SPE2*ESP
      SPE2S(JJR(IREC1,2))=SPE2S(JJR(IREC1,2))+SPE2
      SPE3S(JJR(IREC1,2))=SPE3S(JJR(IREC1,2))+SPE3
      SPE4S(JJR(IREC1,2))=SPE4S(JJR(IREC1,2))+SPE2*SPE2
      SPE5S(JJR(IREC1,2))=SPE5S(JJR(IREC1,2))+SPE3*SPE2
      SPE6S(JJR(IREC1,2))=SPE6S(JJR(IREC1,2))+SPE3*SPE3
      IF(ESP.LT.0.1) GO TO 256
      IBSPL(JJR(IREC1,2))=IBSPL(JJR(IREC1,2))+1
      SPE1SL(JJR(IREC1,2))=SPE1SL(JJR(IREC1,2))+DLOG10(DABS(ESP))
      SPE2L=(DLOG10(DABS(ESP)))**2.D0
      SPE3L=SPE2L*DLOG10(DABS(ESP))
      SPE2SL(JJR(IREC1,2))=SPE2SL(JJR(IREC1,2))+SPE2L
      SPE3SL(JJR(IREC1,2))=SPE3SL(JJR(IREC1,2))+SPE3L
      SPE4SL(JJR(IREC1,2))=SPE4SL(JJR(IREC1,2))+SPE2L*SPE2L
      SPE5SL(JJR(IREC1,2))=SPE5SL(JJR(IREC1,2))+SPE3L*SPE2L
      SPE6SL(JJR(IREC1,2))=SPE6SL(JJR(IREC1,2))+SPE3L*SPE3L
  256 CONTINUE
C
C     SURFACE REFRACTION
C
      EXIR=DSQRT((ENOR-SB(1))/ESP)
      IF  ( EXIR .GE. 1.D0 )    EXIR  = .999999D0
C
C     TOTAL ANGULAR DISTRIBUTIONS
C
      IAG=IDINT(EXIR*20.D0+1.D0)
      KADS(IAG)=KADS(IAG)+1
      KADSJ(IAG,JJR(IREC1,2))=KADSJ(IAG,JJR(IREC1,2))+1
C
C     4 GROUPS:ION IN , PKA ;ION IN , SKA ;ION OUT, PKA ;ION OUT, SKA
C
      KOI=KO(IREC1,JJR(IREC1,2),2)
      IF(INOUT(IREC1,2).EQ.-1) GO TO 61
      IF(KOI.EQ.0) GO TO 62
      ISPIP(JJR(IREC1,2))=ISPIP(JJR(IREC1,2))+1
      ESPIP(JJR(IREC1,2))=ESPIP(JJR(IREC1,2))+ESP
      KADRIP(IAG,JJR(IREC1,2))=KADRIP(IAG,JJR(IREC1,2))+1
      GO TO 164
   62 ISPIS(JJR(IREC1,2))=ISPIS(JJR(IREC1,2))+1
      ESPIS(JJR(IREC1,2))=ESPIS(JJR(IREC1,2))+ESP
      KADRIS(IAG,JJR(IREC1,2))=KADRIS(IAG,JJR(IREC1,2))+1
      GO TO 164
   61 IF(KOI.EQ.0) GO TO 163
      ISPOP(JJR(IREC1,2))=ISPOP(JJR(IREC1,2))+1
      ESPOP(JJR(IREC1,2))=ESPOP(JJR(IREC1,2))+ESP
      KADROP(IAG,JJR(IREC1,2))=KADROP(IAG,JJR(IREC1,2))+1
      GO TO 164
  163 ISPOS(JJR(IREC1,2))=ISPOS(JJR(IREC1,2))+1
      ESPOS(JJR(IREC1,2))=ESPOS(JJR(IREC1,2))+ESP
      KADROS(IAG,JJR(IREC1,2))=KADROS(IAG,JJR(IREC1,2))+1
  164 CONTINUE
C
C     OUTPUT MATRICES OF BACKWARD SPUTTERED ATOMS
C
      IF(JJR(IREC1,2).GT.JT(3)) GO TO 255
      IESP = IDINT(ESP*E0DE+2.0D0)
      IESP = MIN0(101,IESP)
      IESLOG=2
      IF(ESP.LE.0.1D0) GO TO 75
      IESLOG=IDINT(12.D0*DLOG10(DABS(10.D0*ESP))+3.D0)
      IESLOG=MIN0(IESLOG,75)
   75 CONTINUE
      IF(EXIR.GT.1.0D0)WRITE(99,'(A50)')' EXIR nach Label 75'
      IA=IDINT(DAW*DACOS(EXIR)+2.D0)
      IAGS = IAG+1
      IG=2
C     IF(SXR(I).EQ.0.) GO TO 182
C     SXR(I)=DMAX1(SXR(I),1.0E-12)
      SXR(IREC1)=DMAX1(SXR(IREC1),1.0D-12)
      U=CYR(IREC1)/SXR(IREC1)
      IF(DABS(U).GT.1.D0) U = SIGN(1.D0,U)
        IF(U.GT.1.0D0)WRITE(99,'(A50)')' U vor Label 182 CON..'
      ACS=DACOS(U)
      IG=IDINT(DGW*ACS+2.D0)
C 182 CONTINUE
      IGG=IDINT(DGIK*ACS+1.D0)
      IGG=MAX0(MIN0(NGIK,IGG),1)
      MAGS(IG,IAGS,JJR(IREC1,2)) = MAGS(IG,IAGS,JJR(IREC1,2))+1
      MAGS(IG,22,JJR(IREC1,2))   = MAGS(IG,22,JJR(IREC1,2))+1
      MAGS(NG,IAGS,JJR(IREC1,2)) = MAGS(NG,IAGS,JJR(IREC1,2))+1
      MAGS(NG,22,JJR(IREC1,2))   = MAGS(NG,22,JJR(IREC1,2))+1
      MEAS(IESP,IAGS,JJR(IREC1,2)) = MEAS(IESP,IAGS,JJR(IREC1,2))+1
      MEAS(102,IAGS,JJR(IREC1,2))  = MEAS(102,IAGS,JJR(IREC1,2))+1
      MEAS(IESP,22,JJR(IREC1,2))   = MEAS(IESP,22,JJR(IREC1,2))+1
      MEAS(102,22,JJR(IREC1,2))    = MEAS(102,22,JJR(IREC1,2))+1
      MEASL(IESLOG,IAG,JJR(IREC1,2)) = MEASL(IESLOG,IAG,JJR(IREC1,2))+1
      MEASL(IESLOG,21,JJR(IREC1,2))  = MEASL(IESLOG,21,JJR(IREC1,2))+1
      MEASL(75,IAG,JJR(IREC1,2))     = MEASL(75,IAG,JJR(IREC1,2))+1
      MEASL(75,21,JJR(IREC1,2))      = MEASL(75,21,JJR(IREC1,2))+1
      IF(ALPHA.LT.1.0) GO TO 181
      MEAGS(IESP,IGG,IAGS,JJR(IREC1,2)) =
     *                         MEAGS(IESP,IGG,IAGS,JJR(IREC1,2))+1
      MEAGS(102,IGG,IAGS,JJR(IREC1,2))  =
     *                         MEAGS(102,IGG,IAGS,JJR(IREC1,2))+1
      MEAGS(IESP,IGG,22,JJR(IREC1,2))   =
     *                         MEAGS(IESP,IGG,22,JJR(IREC1,2))+1
      MEAGS(102,IGG,22,JJR(IREC1,2))    =
     *                         MEAGS(102,IGG,22,JJR(IREC1,2))+1
C     MEAGSL(IESLOG,IGG,IAG)=MEAGSL(IESLOG,IGG,IAG)+1
C     MEAGSL(IESLOG,IGG,21)=MEAGSL(IESLOG,IGG,21)+1
C     MEAGSL(75,IGG,IAG)=MEAGSL(75,IGG,IAG)+1
      MAGSA(IG,IA,JJR(IREC1,2)) = MAGSA(IG,IA,JJR(IREC1,2))+1
      MAGSA(IG,32,JJR(IREC1,2)) = MAGSA(IG,32,JJR(IREC1,2))+1
      MAGSA(NG,IA,JJR(IREC1,2)) = MAGSA(NG,IA,JJR(IREC1,2))+1
      MAGSA(NG,32,JJR(IREC1,2)) = MAGSA(NG,32,JJR(IREC1,2))+1
  181 CONTINUE
      GO TO 255
C
  250 ENORT=ER(IREC1,2)*CXR(IREC1)*CXR(IREC1)
      IF(ENORT.GT.SB(L)) GO TO 257
C
C     RECOIL ATOM IS REFLECTED BACK INTO THE SOLID BY THE
C     POTENTIAL BARRIER
C
      XR(IREC1,2)=SUT
      CSXR(IREC1,2)=-1.D0*CSXR(IREC1,2)
      KIST=KIST+1
      GO TO 248
C
C     RECOIL ATOM IS SPUTTERED (TRANSMISSION)
C
  257 ESPT=ER(IREC1,2)-SB(L)
C
C     NUMBER AND ENERGY OF ALL SPUTTERED PARTICLES
C
      ITSP(JJR(IREC1,2))=ITSP(JJR(IREC1,2))+1
      ETSP(JJR(IREC1,2))=ETSP(JJR(IREC1,2))+ESPT
C
C     SURFACE REFRACTION
C
      EXIRT=DSQRT((ENORT-SB(L))/ESPT)
      IF  ( EXIRT .GE. 1.D0 )    EXIRT  = .999999D0
C
C     TOTAL ANGULAR DISTRIBUTIONS
C
      IAG=IDINT(EXIRT*20.D0+1.D0)
      KADST(IAG)=KADST(IAG)+1
      KDSTJ(IAG,JJR(IREC1,2))=KDSTJ(IAG,JJR(IREC1,2))+1
C
C     4 GROUPS:ION IN , PKA ;ION IN , SKA ;ION OUT, PKA ;ION OUT, SKA
C
      KOI=KO(IREC1,JJR(IREC1,2),2)
      IF(INOUT(IREC1,2).EQ.-1) GO TO 85
      IF(KOI.EQ.0) GO TO 86
      ISPIPT(JJR(IREC1,2))=ISPIPT(JJR(IREC1,2))+1
      ESPIPT(JJR(IREC1,2))=ESPIPT(JJR(IREC1,2))+ESPT
C     KADRIP(IAG,JJR(IREC1,2))=KADRIP(IAG,JJR(IREC1,2))+1
      GO TO 88
   86 ISPIST(JJR(IREC1,2))=ISPIST(JJR(IREC1,2))+1
      ESPIST(JJR(IREC1,2))=ESPIST(JJR(IREC1,2))+ESPT
C     KADRIS(IAG,JJR(IREC1,2))=KADRIS(IAG,JJR(IREC1,2))+1
      GO TO 88
   85 IF(KOI.EQ.0) GO TO 87
      ISPOPT(JJR(IREC1,2))=ISPOPT(JJR(IREC1,2))+1
      ESPOPT(JJR(IREC1,2))=ESPOPT(JJR(IREC1,2))+ESPT
C     KADROP(IAG,JJR(IREC1,2))=KADROP(IAG,JJR(IREC1,2))+1
      GO TO 88
   87 ISPOST(JJR(IREC1,2))=ISPOST(JJR(IREC1,2))+1
      ESPOST(JJR(IREC1,2))=ESPOST(JJR(IREC1,2))+ESPT
C     KADROS(IAG,JJR(IREC1,2))=KADROS(IAG,JJR(IREC1,2))+1
   88 CONTINUE
C
C     OUTPUT MATRICES OF FORWARD SPUTTERED ATOMS
C
      JRT=JJR(IREC1,2)
      IF(L.EQ.3) JRT=JJR(IREC1,2)-NJ(1)
      IF(JRT.LT.1) GO TO 255
      IESPT = IDINT(ESPT*E0DE+2.0D0)
      IESPT = MIN0(101,IESPT)
      IESLOG=2
      IF(ESPT.LE.0.1D0) GO TO 76
      IESLOG=IDINT(12.D0*DLOG10(DABS(10.D0*ESPT))+3.D0)
      IESLOG=MIN0(IESLOG,75)
   76 CONTINUE
      IAGS = IAG+1
      MAGST(IG,IAGS,JRT) = MAGST(IG,IAGS,JRT)+1
      MAGST(IG,22,JRT)   = MAGST(IG,22,JRT)+1
      MAGST(NG,IAGS,JRT) = MAGST(NG,IAGS,JRT)+1
      MAGST(NG,22,JRT)   = MAGST(NG,22,JRT)+1
      MEAST(IESPT,IAGS,JRT) = MEAST(IESPT,IAGS,JRT)+1
      MEAST(102,IAGS,JRT)  = MEAST(102,IAGS,JRT)+1
      MEAST(IESPT,22,JRT)   = MEAST(IESPT,22,JRT)+1
      MEAST(102,22,JRT)    = MEAST(102,22,JRT)+1
      MEASTL(IESLOG,IAG,JRT) = MEASTL(IESLOG,IAG,JRT)+1
      MEASTL(IESLOG,21,JRT)  = MEASTL(IESLOG,21,JRT)+1
      MEASTL(75,IAG,JRT)     = MEASTL(75,IAG,JRT)+1
      MEASTL(75,21,JRT)      = MEASTL(75,21,JRT)+1
C     IF(ALPHA.LT.1.0) GO TO 181
C     MEAGS(IESPT,IGG,IAGS) = MEAGS(IESPT,IGG,IAGS)+1
C     MEAGS(102,IGG,IAGS) = MEAGS(102,IGG,IAGS)+1
C     MEAGS(IESPT,IGG,22) = MEAGS(IESPT,IGG,22)+1
C     MEAGSL(IESLOG,IGG,IAG)=MEAGSL(IESLOG,IGG,IAG)+1
C     MEAGSL(IESLOG,IGG,21)=MEAGSL(IESLOG,IGG,21)+1
C     MEAGSL(75,IGG,IAG)=MEAGSL(75,IGG,IAG)+1
C 181 CONTINUE
C
C     REARRANGEMENT OF PARTICLES IN LIST 2
C
  255 ER(IREC1,2)=ER(NREC2,2)
      XR(IREC1,2)=XR(NREC2,2)
      YR(IREC1,2)=YR(NREC2,2)
      ZR(IREC1,2)=ZR(NREC2,2)
      CSXR(IREC1,2)=CSXR(NREC2,2)
      CSYR(IREC1,2)=CSYR(NREC2,2)
      CSZR(IREC1,2)=CSZR(NREC2,2)
      SNXR(IREC1,2)=SNXR(NREC2,2)
      CPHIR(IREC1,2)=CPHIR(NREC2,2)
      SPHIR(IREC1,2)=SPHIR(NREC2,2)
      CPSIR(IREC1,2)=CPSIR(NREC2,2)
      SPSIR(IREC1,2)=SPSIR(NREC2,2)
      TAUPSR(IREC1,2)=TAUPSR(NREC2,2)
      JJR(IREC1,2)=JJR(NREC2,2)
      KO(IREC1,JJR(IREC1,2),2)=KO(NREC2,JJR(NREC2,2),2)
      INOUT(IREC1,2)=INOUT(NREC2,2)
      NREC2=NREC2-1
C
      IF(IREC1.EQ.NREC2+1) GO TO 247
C     THE NREC2 PARTICLE FAILS THE TEST
      IF(NREC2+1.GT.IVMAX) GO TO 248
      GO TO 249
  248 CONTINUE
C
  247 CONTINUE
C
      IF(NREC1+NREC2.EQ.0) GO TO 27
      IF(NREC2.GE.NUM.OR.IH1.EQ.0) GO TO 83
C
C     END OF RECOIL ATOM SECTION
C
   27 CONTINUE
C
      IF(IH1.EQ.0.AND.IH.EQ.NH) GO TO 140
C
C     PROJECTILE CANDIDATE FOR REFLECTION
C
      DO 29 IV=1,IH1
      E(IV)=E(IV)-DEE(IV)-DENS(IV)+1.0D-10
      X(IV)=X(IV)-TAU(IV)*CX(IV)
      Y(IV)=Y(IV)-TAU(IV)*CY(IV)
      Z(IV)=Z(IV)-TAU(IV)*CZ(IV)
      PL(IV)=PL(IV)-TAU(IV)
      TEST(IV)=E(IV).LE.EF.OR.X(IV).LT.-1.D0*SU.OR.X(IV).GT.SUT
   29 CONTINUE
      IVMIN=1+ILLZ(IH1,TEST,1)
      IF(IVMIN.GT.IH1) GO TO 90
      IVMAX=IH1-ILLZ(IH1,TEST,-1)
      DO 120 IV=IVMIN,IVMAX
  160 IF(IV.GT.IH1) GO TO 90
      IF(X(IV).LT.-SU) GO TO 8
      IF(X(IV).GT.SUT) GO TO 9
      IF(E(IV).GT.EF) GO TO 125
      IF(E(IV).GT.ESB.AND.X(IV).LT.0.D0) GO TO 125
      IF(E(IV).GT.ESB.AND.X(IV).GT.TT) GO TO 125
C
C     PROJECTILE HAS STOPPED (PATHLENGTH,RANGE,SPREAD AND MOMENTS)
C
C     IF(X(IV).LT.0..OR.X(IV).GT.TT) GO TO 110
      IP  = MAX0( MIN0( IDINT(PL(IV)/CW+1.D0), 100), 1)
      IPL(IP)=IPL(IP)+1
      I1  = MAX0( MIN0( IDINT(X(IV)/CW+1.D0), 101), 0)
      IRP(I1)=IRP(I1)+1
c
c Berechnung der gestoppten Teilchen im jeweiligen Layer
c
        LowTiefe = 0.D0
        UpTiefe  = DX(1)
c
        DO laufzahl=1,l
                IF(X(IV).GT.LowTiefe.AND.X(IV).LE.UpTiefe) THEN
                  Number_in_Layer(laufzahl)=Number_in_Layer(laufzahl)+1
                ENDIF
                LowTiefe = UpTiefe
                UpTiefe  = UpTiefe+DX(laufzahl+1)
        ENDDO
c
      PL2=PL(IV)*PL(IV)
      PL3=PL2*PL(IV)
      PLSUM=PLSUM+PL(IV)
      PL2SUM=PL2SUM+PL2
      PL3SUM=PL3SUM+PL3
      PL4SUM=PL4SUM+PL2*PL2
      PL5SUM=PL5SUM+PL3*PL2
      PL6SUM=PL6SUM+PL3*PL3
      IF(X(IV).LT.0.D0.OR.X(IV).GT.TT) GO TO 111
      XQ=X(IV)*X(IV)
      XQ3=XQ*X(IV)
      XSUM=XSUM+X(IV)
      X2SUM=X2SUM+XQ
      X3SUM=X3SUM+XQ3
      X4SUM=X4SUM+XQ*XQ
      X5SUM=X5SUM+XQ3*XQ
      X6SUM=X6SUM+XQ3*XQ3
      RQ=Y(IV)*Y(IV)+Z(IV)*Z(IV)
      RQW=DSQRT(RQ)
      RQ3=RQ*RQW
      RSUM=RSUM+RQW
      R2SUM=R2SUM+RQ
      R3SUM=R3SUM+RQ3
      R4SUM=R4SUM+RQ*RQ
      R5SUM=R5SUM+RQ3*RQ
      R6SUM=R6SUM+RQ3*RQ3
  111 CONTINUE
      ENUCLI=ENUCLI+ENUCL(IV)
      ENL2I=ENL2I+ENUCL(IV)*ENUCL(IV)
      ENUCL(IV)=0.D0
      EINELI=EINELI+EINEL(IV)
      EIL2I=EIL2I+EINEL(IV)*EINEL(IV)
      EINEL(IV)=0.D0
      GO TO 110
    8 ENO=E(IV)*CX(IV)*CX(IV)
      IF(ENO.LE.ESB) GO TO 24
C
C     PROJECTILE IS BACKSCATTERED
C
      IB=IB+1
      ES=E(IV)-ESB
C     IJKLMN=IJKLMN+1
C     ESVDL(IJKLMN)=ES
      ESQ=ES*ES
      ES3=ESQ*ES
      EB=EB+ES
      EB2SUM=EB2SUM+ESQ
      EB3SUM=EB3SUM+ES3
      EB4SUM=EB4SUM+ESQ*ESQ
      EB5SUM=EB5SUM+ES3*ESQ
      EB6SUM=EB6SUM+ES3*ES3
      IF(ES.LT.0.1D0) GO TO 112
      IBL=IBL+1
      ESQL=(DLOG10(DABS(ES)))**2.D0
      ES3L=ESQL*DLOG10(DABS(ES))
      EB1SUL=EB1SUL+DLOG10(DABS(ES))
      EB2SUL=EB2SUL+ESQL
      EB3SUL=EB3SUL+ES3L
      EB4SUL=EB4SUL+ESQL*ESQL
      EB5SUL=EB5SUL+ES3L*ESQL
      EB6SUL=EB6SUL+ES3L*ES3L
  112 CONTINUE
      IPB  = MAX0( MIN0( IDINT(PL(IV)/CW+1.D0), 100), 1)
      IPLB(IPB)=IPLB(IPB)+1
      PLQB=PL(IV)*PL(IV)
      PL3B=PLQB*PL(IV)
      PLSB=PLSB+PL(IV)
      PL2SB=PL2SB+PLQB
      PL3SB=PL3SB+PL3B
      PL4SB=PL4SB+PLQB*PLQB
      PL5SB=PL5SB+PL3B*PLQB
      PL6SB=PL6SB+PL3B*PL3B
      ENUCLB=ENUCLB+ENUCL(IV)
      ENL2B=ENL2B+ENUCL(IV)*ENUCL(IV)
      ENUCL(IV)=0.D0
      EINELB=EINELB+EINEL(IV)
      EIL2B=EIL2B+EINEL(IV)*EINEL(IV)
      EINEL(IV)=0.D0
C
C     SURFACE REFRACTION
C
      EXI=DSQRT((ENO-ESB)/ES)
      exi1s=exi1s+exi
      exiq=exi*exi
      exic=exiq*exi
      exi2s=exi2s+exiq
      exi3s=exi3s+exic
      exi4s=exi4s+exiq*exiq
      exi5s=exi5s+exic*exiq
      exi6s=exi6s+exic*exic
C
C     DIVISIONS FOR VECTORS AND MATRICES
C
      IE = IDINT(E0DE*ES+2.D0)
      IE = MAX0( MIN0( IE,NE1), 2)
      IERLOG = 2
      IF(ES.LE.0.1D0) GO TO 4
      IERLOG = IDINT(12.D0*DLOG10(DABS(10.D0*ES))+3.D0)
      IERLOG=MIN0(IERLOG,75)
    4 CONTINUE
      IAG=IDINT(EXI*20.D0+1.D0)
      IAG  = MIN0( IAG, 20)
      IAGB = IAG+1
      KADB(IAG)=KADB(IAG)+1
      IG=2
      COSSIN=CY(IV)/SX(IV)
      COSSIN=DMIN1(COSSIN,1.D0)
      COSSIN=DMAX1(COSSIN,-1.D0)
      coss1s=coss1s+cossin
      cossq=cossin*cossin
      cosst=cossq*cossin
      coss2s=coss2s+cossq
      coss3s=coss3s+cosst
      coss4s=coss4s+cossq*cossq
      coss5s=coss5s+cosst*cossq
      coss6s=coss6s+cosst*cosst
        IF(COSSIN.GT.1.0D0)WRITE(99,'(A50)')' nach coss6s'
      AC=DACOS(COSSIN)
      IG=IDINT(DAW*AC+2.D0)
      IGG=IDINT(DGIK*AC+1.D0)
      IF(IGG.GT.NGIK) IGG=NGIK
      IPB1=IPB+1
      MEABL(IERLOG,IAG) = MEABL(IERLOG,IAG)+1
      MEABL(IERLOG,21)  = MEABL(IERLOG,21)+1
      MEABL(75,IAG)     = MEABL(75,IAG)+1
      MAGB(IG,IAGB) = MAGB(IG,IAGB)+1
      MAGB(NG,IAGB) = MAGB(NG,IAGB)+1
      MAGB(IG,22)   = MAGB(IG,22)+1
      MEAB(IE,IAGB) = MEAB(IE,IAGB)+1
      MEAB(NE,IAGB) = MEAB(NE,IAGB)+1
      MEAB(IE,22)   = MEAB(IE,22)+1
C     IF(ALPHA.LT.1.0) GO TO 183
      MEAGB(IE,IGG,IAGB)  = MEAGB(IE,IGG,IAGB)+1
      MEAGB(102,IGG,IAGB) = MEAGB(102,IGG,IAGB)+1
      MEAGB(IE,IGG,22)    = MEAGB(IE,IGG,22)+1
      MEAGB(102,IGG,22)   = MEAGB(102,IGG,22)+1
C 183 CONTINUE
      MEPB(IE,IPB1) = MEPB(IE,IPB1)+1
      MEPB(NE,IPB1) = MEPB(NE,IPB1)+1
      MEPB(IE,102) = MEPB(IE,102)+1
      EMA(IG,IAGB) = EMA(IG,IAGB)+ES
      EMA(IG,22)   = EMA(IG,22)+ES
      EMA(NG,IAGB) = EMA(NG,IAGB)+ES
      GO TO 110
C
C     PROJECTILE IS REFLECTED BACK INTO THE TARGET BY THE SURF. BARRIER
C
   24 X(IV)=-1.D0*SU
      COSX(IV)=-1.D0*COSX(IV)
      KIB=KIB+1
      GO TO 125
C
C     PROJECTILE IS TRANSMITTED
C
    9 ENOT=E(IV)*CX(IV)*CX(IV)
      IF(ENOT.LE.ESB) GO TO 517
      IT=IT+1
      EST=E(IV)-ESB
      ET=ET+EST
      ETQ=EST*EST
      ET3=ETQ*EST
      ET2SUM=ET2SUM+ETQ
      ET3SUM=ET3SUM+ET3
      ET4SUM=ET4SUM+ETQ*ETQ
      ET5SUM=ET5SUM+ET3*ETQ
      ET6SUM=ET6SUM+ET3*ET3
      IPT  = MAX0( MIN0( IDINT(PL(IV)/CW+1.D0), 100), 1)
      IPLT(IP)=IPLT(IP)+1
      PLQT=PL(IV)*PL(IV)
      PL3T=PLQT*PL(IV)
      PLST=PLST+PL(IV)
      PL2ST=PL2ST+PLQT
      PL3ST=PL3ST+PL3T
      PL4ST=PL4ST+PLQT*PLQT
      PL5ST=PL5ST+PL3T*PLQT
      PL6ST=PL6ST+PL3T*PL3T
      ENUCLT=ENUCLT+ENUCL(IV)
      ENL2T=ENL2T+ENUCL(IV)*ENUCL(IV)
      ENUCL(IV)=0.D0
      EINELT=EINELT+EINEL(IV)
      EIL2T=EIL2T+EINEL(IV)*EINEL(IV)
      EINEL(IV)=0.D0
C
C     SURFACE REFRACTION
C
      EXI=DSQRT((ENOT-ESB)/EST)
C
C     DIVISIONS FOR VECTORS AND MATRICES
C
      IE=IDINT(E0DE*EST+2.D0)
      IERLOG = 2
      IF(EST.LE.0.1D0) GO TO 5
      IERLOG = IDINT(12.D0*DLOG10(DABS(10.D0*EST))+3.D0)
      IERLOG=MIN0(IERLOG,75)
    5 CONTINUE
      IAG=IDINT(EXI*20.D0+1.D0)
      IAG  = MIN0( IAG, 20)
      IAGB = IAG+1
      KADT(IAG)=KADT(IAG)+1
      IG=2
      COSSIN=CY(IV)/SX(IV)
      COSSIN=DMIN1(COSSIN,1.D0)
      COSSIN=DMAX1(COSSIN,-1.D0)
        IF(COSSIN.GT.1.0D0) WRITE(99,'(A50)')' nach COSSIN'
      AC=DACOS(COSSIN)
      IG=IDINT(DAW*AC+2.D0)
      IGG=IDINT(DGIK*AC+1.D0)
      IF(IGG.GT.NGIK) IGG=NGIK
      MEATL(IERLOG,IAG) = MEATL(IERLOG,IAG)+1
      MEATL(IERLOG,21)  = MEATL(IERLOG,21)+1
      MEATL(75,IAG)     = MEATL(75,IAG)+1
      MAGT(IG,IAGB) = MAGT(IG,IAGB)+1
      MAGT(NG,IAGB) = MAGT(NG,IAGB)+1
      MAGT(IG,22)   = MAGT(IG,22)+1
      MEAT(IE,IAGB) = MEAT(IE,IAGB)+1
      MEAT(NE,IAGB) = MEAT(NE,IAGB)+1
      MEAT(IE,22)   = MEAT(IE,22)+1
C     IF(ALPHA.LT.1.0) GO TO 183
      MEAGT(IE,IGG,IAGB)  = MEAGT(IE,IGG,IAGB)+1
      MEAGT(102,IGG,IAGB) = MEAGT(102,IGG,IAGB)+1
      MEAGT(IE,IGG,22)    = MEAGT(IE,IGG,22)+1
      MEAGT(102,IGG,22)   = MEAGT(102,IGG,22)+1
C 183 CONTINUE
      MEPT(IE,IPT) = MEPT(IE,IPT)+1
      MEPT(NE,IPT) = MEPT(NE,IPT)+1
      MEPT(IE,102) = MEPT(IE,102)+1
      EMAT(IG,IAGB) = EMAT(IG,IAGB)+ES
      EMAT(IG,22)   = EMAT(IG,22)+ES
      EMAT(NG,IAGB) = EMAT(NG,IAGB)+ES
      GO TO 110
C
C     PROJECTILE IS REFLECTED BACK INTO THE TARGET BY THE SURF. BARRIER
C
  517 X(IV)=SUT
      COSX(IV)=-1.D0*COSX(IV)
      KIT=KIT+1
      GO TO 125
C
  110 IF(IH.EQ.NH) GO TO 130
C
      IH=IH+1
      IF(E0.GE.0.D0) GO TO 702
      IF(ALPHA.LT.0.D0) GO TO 703
C
C     MAXWELLIAN VELOCITY  DISTRIBUTION
C
      CALL VELOC(E(IV),COSX(IV),COSY(IV),COSZ(IV),SINE(IV))
         EMX = EMX+E(IV)
      ne = IDINT(DMIN1(5000.D0,e(iv)+1.D0))
      me(ne) = me(ne)+1
      GO TO 707
C
C     MAXWELLIAN ENERGY  DISTRIBUTION
C
  703 CALL ENERG(E(IV),COSX(IV),COSY(IV),COSZ(IV),SINE(IV))
CC703 CALL ENERGV(FE,E,COSX,COSY,COSZ,SINE,1)
         EMX = EMX+E(IV)
CC       WRITE(6,*) E(IV)
      GO TO 707
C
  702 IF (EQUAL(Esig,0.D0)) THEN
C     FIXED PROJECTILE ENERGY
C      WRITE(*,*)' Da Esig=0 ist E=E0'
                E(IV)=E0
C     GAUSSIAN ENERGY DISTRIBUTION
        ELSE
7020            CALL ENERGGAUSS(ISEED2,Esig,Epar,E0)
                tryE = tryE+1
                IF (Epar.LE.0.D0) THEN
                        negE = negE+1
                        GO TO 7020
                ENDIF
                E(IV)=Epar
C        WRITE(*,*)E(IV),Epar,E0
        ENDIF
C
      TAUPSI(IV)=0.D0
C
C      IF(ALPHA.EQ.-2.) GO TO 705
C      IF(ALPHA.EQ.-1.) GO TO 706
      IF(EQUAL(ALPHA,-2.D0)) GO TO 705
      IF(EQUAL(ALPHA,-1.D0)) GO TO 706
C
        IF(EQUAL(ALPHASIG,0.D0))THEN
C     FIXED PROJECTILE ANGLE
C               WRITE(88,*)ALPHA,CALFA,SALFA
                COSX(IV)=CALFA
                COSY(IV)=SALFA
                COSZ(IV)=0.D0
                SINE(IV)=COSY(IV)
        ELSE
C
C     1D-GAUSSIAN DISTRIBUTION PROJECTILE ANGLE
C
                CALL ALPHAGAUSS(ISEED3,ALPHASIG,ALPHA,ALFA,ALPHApar,
     +               CALFA,SALFA,BW)
C               WRITE(88,'(5(F12.5))')ALPHA,ALPHASIG,ALPHApar,CALFA,SALFA
                COSX(IV) = CALFA
                COSY(IV) = SALFA
                COSZ(IV) = 0.D0
                SINE(IV) = COSY(IV)
        ENDIF
C
      GO TO 707
C
C     COSINE ANGLE DISTRIBUTION
C
CC705 RPHI=PI2*RANF()
CC705 RPHI=PI2*DRAND48()
CC705 RPHI=PI2*DBLE(RAN(ISEED))
705   call ranlux(ran2, 2)
      RPHI=PI2*DBLE(ran2(1))
CC    RTHETA=RANF()
CC    RTHETA=DRAND48()
CC    RTHETA=DBLE(RAN(ISEED))
      RTHETA=DBLE(ran2(1))
      COSX(IV)=DSQRT(RTHETA)
      SINE(IV)=DSQRT(1.D0-RTHETA)
      COSY(IV)=SINE(IV)*DCOS(RPHI)
      COSZ(IV)=SINE(IV)*DSIN(RPHI)
      GO TO 707
C
C     RANDOM DISTRIBUTION
C
  706 IF(X0.GT.0.D0) GO TO 709
C
CC    RPHI=PI2*RANF()
CC    RPHI=PI2*DRAND48()
CC    RPHI=PI2*DBLE(RAN(ISEED))
      call ranlux(ran2, 2)
      RPHI=PI2*DBLE(ran2(1))
CC    RTHETA=RANF()
CC    RTHETA=DRAND48()
cc    RTHETA=DBLE(RAN(ISEED))
      RTHETA=DBLE(ran2(2))
      COSX(IV)=1.D0-RTHETA
      SINE(IV)=DSQRT(1.D0-COSX(IV)*COSX(IV))
      COSY(IV)=SINE(IV)*DSIN(RPHI)
      COSZ(IV)=SINE(IV)*DCOS(RPHI)
      GO TO 707
C
CC709 RPHI=PI2*RANF()
CC709 RPHI=PI2*DRAND48()
CC709 RPHI=PI2*DBLE(RAN(ISEED))
  709 call ranlux(ran2, 2)
      RPHI=PI2*DBLE(ran2(1))
CC    RTHETA=RANF()
CC    RTHETA=DRAND48()
CC    RTHETA=DBLE(RAN(ISEED))
      RTHETA=DBLE(ran2(2))
      COSX(IV)=1.D0-2.D0*RTHETA
      SINE(IV)=DSQRT(1.D0-COSX(IV)*COSX(IV))
      COSY(IV)=SINE(IV)*DSIN(RPHI)
      COSZ(IV)=SINE(IV)*DCOS(RPHI)
      GO TO 708
C
  707 IF(X0.GT.0.D0) GO TO 708
C
C     EXTERNAL START
C
      SINA=SINE(IV)
      COSX(IV)=DSQRT((E(IV)*COSX(IV)*COSX(IV)+ESB)/(E(IV)+ESB))
      SINE(IV)=DSQRT(1.D0-COSX(IV)*COSX(IV))
      COSY(IV)=COSY(IV)*SINE(IV)/SINA
      COSZ(IV)=COSZ(IV)*SINE(IV)/SINA
      E(IV)=E(IV)+ESB
C
C     LOCUS OF FIRST COLLISION
C
  708 LLL(IV)=ISRCHFGT(L,XX(1),1,X0)
CC    RA1=CVMGT(RANF(),1.,X0.LE.0.)
CC    RA1=CVMGT(DRAND48(),1.,X0.LE.0.)
CC    RA1=CVMGT(DBLE(RAN(ISEED)),1.D0,X0.LE.0.D0)
      call ranlux(random, 1)
      RA1=CVMGT(DBLE(random),1.D0,X0.LE.0.D0)
      X(IV)=XC+LM(LLL(IV))*RA1*COSX(IV)
      Y(IV)=LM(LLL(IV))*RA1*COSY(IV)
      Z(IV)=LM(LLL(IV))*RA1*COSZ(IV)
      PL(IV)=CVMGT(0.D0,LM(LLL(IV))*RA1,X0.LE.0.D0)
      GO TO 120
C
C     COUNTING DOWN IH1 , ONLY LESS THAN (NH-IH) HAVE TO BE PROCESSED
C
  130 CONTINUE
      E(IV)=E(IH1)
      COSX(IV)=COSX(IH1)
      COSY(IV)=COSY(IH1)
      COSZ(IV)=COSZ(IH1)
      SINE(IV)=SINE(IH1)
      X(IV)=X(IH1)
      Y(IV)=Y(IH1)
      Z(IV)=Z(IH1)
      PL(IV)=PL(IH1)
      TAU(IV)=TAU(IH1)
      TAUPSI(IV)=TAUPSI(IH1)
      CPSI(IV)=CPSI(IH1)
      ENUCL(IV)=ENUCL(IH1)
      EINEL(IV)=EINEL(IH1)
      IH1=IH1-1
      IF(IV.EQ.IH1+1) GO TO 90
      IF(IH1+1.GT.IVMAX) GO TO 125
      GO TO 160
  125 CONTINUE
      X(IV)=X(IV)+(LM(LLL(IV))+TAUPSI(IV))*COSX(IV)
      Y(IV)=Y(IV)+(LM(LLL(IV))+TAUPSI(IV))*COSY(IV)
      Z(IV)=Z(IV)+(LM(LLL(IV))+TAUPSI(IV))*COSZ(IV)
      PL(IV)=CVMGT(PL(IV),PL(IV)+LM(LLL(IV))+TAUPSI(IV)
     *             ,X(IV).LE.0.D0)
      LLL(IV)=MIN0(ISRCHFGT(L,XX(1),1,X(IV)),L)
  120 CONTINUE
   90 CONTINUE
C
C     INCREMENT OF PROJECTILE ENERGY AND POSITION
C               OF PARTICLES NOT HANDLED IN LOOP 120
C
CC    IF(IVMIN.LE.1) GO TO 134
      DO 128 IV=1,IVMIN-1
      LLL(IV) = MIN0(ISRCHFGT(L,XX(1),1,X(IV)),L)
  128 CONTINUE
      DO 129 IV=1,IVMIN-1
      X(IV)=X(IV)+(LM(LLL(IV))+TAUPSI(IV))*COSX(IV)
      Y(IV)=Y(IV)+(LM(LLL(IV))+TAUPSI(IV))*COSY(IV)
      Z(IV)=Z(IV)+(LM(LLL(IV))+TAUPSI(IV))*COSZ(IV)
      PL(IV)=CVMGT(PL(IV),PL(IV)+LM(LLL(IV))+TAUPSI(IV)
     *             ,X(IV).LE.0.D0)
  129 CONTINUE
  134 CONTINUE
C
      IF(IVMAX.LT.IVMIN) GO TO 132
CC    IF(IVMAX.LT.IH1) GO TO 132
      DO 133 IV=IVMAX+1,IH1
      LLL(IV) = MIN0(ISRCHFGT(L,XX(1),1,X(IV)),L)
  133 CONTINUE
      DO 131 IV=IVMAX+1,IH1
      X(IV)=X(IV)+(LM(LLL(IV))+TAUPSI(IV))*COSX(IV)
      Y(IV)=Y(IV)+(LM(LLL(IV))+TAUPSI(IV))*COSY(IV)
      Z(IV)=Z(IV)+(LM(LLL(IV))+TAUPSI(IV))*COSZ(IV)
      PL(IV)=CVMGT(PL(IV),PL(IV)+LM(LLL(IV))+TAUPSI(IV)
     *             ,X(IV).LE.0.D0)
  131 CONTINUE
  132 CONTINUE
C
      GO TO 1
C
  140 IF(NREC1+NREC2.GT.0) GO TO 83
C
C
C     PRINTOUT
C
C
      do ima = 5000,1,-1
        if(me(ima).ne.0) goto 1010
      enddo
      ima = 1
 1010 ima = MIN0(ima+2,5000)
      open(20,file='edist')
      do ne=1,ima
        write(20,1020) ne,me(ne)
      enddo
 1020 format(1x,2i6)
      close(20)
c
c Berechnung der part. reflec. coeff. nach Thomas et al.
c
        E0keV=E0/1.D3
        EsigkeV=Esig/1.D3
c
        IF(ZT(1,2).LT.1.0D-3) THEN
          epsilon = 32.55D0*(MT(1,1)/M1)/(1.D0+(MT(1,1)/M1))*
     1    1.D0/(Z1*ZT(1,1)*DSQRT(Z1**(2.D0/3.D0)+ZT(1,1)**(2.D0/3.D0)))*
     2                  E0keV
cTR  1    1.D0/(Z1*ZT(1,1)*DSQRT(Z1**2.D0/3.D0+ZT(1,1)**2.D0/3.D0))*
cTR  2                  E0keV
            prcoeff = prc(1)*DLOG(prc(2)*epsilon+DEXP(1.D0))/
     1          (1.D0+(PRC(3)*epsilon**PRC(4))+(PRC(5)*epsilon**PRC(6)))
        ELSE
                epsilon = 0.D0
                prcoeff = 0.D0
      ENDIF

C     2nd CALL DATE_AND_TIME
      CALL DATE_AND_TIME(Real_Clock(1),Real_Clock(2),Real_Clock(3),
     1                   Date_Time)
C                
        IF(Date_Time(2).EQ.1) THEN
                month_stop='Jan.'
            days_total_stop=Date_Time(3)
        ELSEIF(Date_Time(2).EQ.2) THEN
            month_stop='Feb.'
            days_stop_total=31+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.3) THEN
            month_stop='Mar.'
                days_stop_total=31+28+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.4) THEN
            month_stop='Apr.'
                days_stop_total=31+28+31+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.5) THEN
            month_stop='May '
                days_stop_total=31+28+31+30+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.6) THEN
            month_stop='Jun.'
                days_stop_total=31+28+31+30+31+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.7) THEN
            month_stop='Jul.'
                days_stop_total=31+28+31+30+31+30+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.8) THEN
            month_stop='Aug.'
                days_stop_total=31+28+31+30+31+30+31+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.9) THEN
            month_stop='Sep.'
                days_stop_total=31+28+31+30+31+30+31+31+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.10) THEN
            month_stop='Oct.'
                days_stop_total=31+28+31+30+31+30+31+31+30+Date_Time(3)
        ELSEIF(Date_Time(2).EQ.11) THEN
          month_stop='Nov.'
          days_stop_total=31+28+31+30+31+30+31+31+30+31+Date_Time(3)
        ELSE
          month_stop='Dec.'
          days_stop_total=31+28+31+30+31+30+31+31+30+31+30+Date_Time(3)
        ENDIF
C
        READ(Real_Clock(1)(1:4),'(A4)')year_stop
        READ(Real_Clock(1)(7:8),'(A2)')day_stop
        READ(Real_Clock(2)(1:2),'(A2)')hour_stop
        READ(Real_Clock(2)(3:4),'(A2)')min_stop
        READ(Real_Clock(2)(5:6),'(A2)')sec_stop
C
C how many seconds are needed for the simulation ??
C
        seconds_stop_total=Date_Time(7)+(Date_Time(6)*60)+
     1         (Date_Time(5)*3600)+(days_stop_total-1)*86400
C
        WRITE(21,*)
        WRITE(21,10051)day_stop,month_stop,year_stop,
     1               hour_stop,min_stop,sec_stop
10051 FORMAT(1x,' TrimSp simulation ended at:   ',A2,'.',A4,1x,A4,
     1       1x,A2,':',A2,':',A2)
        WRITE(21,*)
        WRITE(21,10052)nh,(seconds_stop_total-seconds_start_total)
10052 FORMAT(1x,' Simulation needed for ',I7,' muons ',I7,' seconds')
C
      WRITE(21,1402)innam
 1402 FORMAT(//30X,'* INPUT DATA *',5X,A12)
      WRITE(21,1404) Z1,M1,E0,Esig,ALPHA,ALPHASIG,EF,ESB,SHEATH,ERC
 1404 FORMAT(//,7X,2HZ1,8X,2HM1,10X,2HE0,6X,4HEsig,7X,5HALPHA,7X
     1 ,8HALPHASIG,7X,2HEF,7X
     2 ,3HESB,6X,6HSHEATH,5X,3HERC/2F10.2,1F13.2,7F10.2)
      WRITE(21,1406) NH,RI,RI2,RI3,X0,RD,CW,CA,KK0,KK0R,KDEE1,KDEE2,IPOT
     1              ,IPOTR,IRL
 1406 FORMAT(/7X,2HNH,8X,2HRI,5X,3HRI2,5X,3HRI3,11X,2HX0,8X,2HRD,8X,2HCW
     1 ,8X,2HCA
     1 ,7X,3HKK0,3X,4HKK0R,3X,5HKDEE1,2X,5HKDEE2,2X,4HIPOT,3X,5HIPOTR
     2 ,3X,3HIRL/I10,3F10.2,1F13.2,3F10.2,1X,7I7)
      WRITE(21,1408)
 1408 FORMAT(//13X,2HDX,6X,3HRHO,4X,2HCK,2X
     1 ,5HZ(,1),1X,5HZ(,2),1X,5HZ(,3),1X,5HZ(,4),1X,5HZ(,5),2X
     2 ,5HM(,1),2X,5HM(,2),2X,5HM(,3),2X,5HM(,4),2X,5HM(,5),1X
     3 ,5HC(,1),1X,5HC(,2),1X,5HC(,3),1X,5HC(,4),1X,5HC(,5))
      DO 1410 I=1,L
      WRITE(21,1412) I,DX(I),RHO(I),CK(I),(ZT(I,J),J=1,5)
     1 ,(MT(I,J),J=1,5),(CO(I,J),J=1,5)
 1412 FORMAT(/1X,I1,6H.LAYER,1X,1F8.2,2F7.2,5F6.0,5F7.2,5F6.3)
 1410 CONTINUE
      WRITE(21,1414)
 1414 FORMAT(//27X,'***',2X,'SBE(LAYER,ELEMENT)',2X,'***',5X
     1           ,'***',5X,'ED(LAYER,ELEMENT)',5X,'***',5X
     2           ,'***',3X,'BE(LAYER,ELEMENT)',2X,'***')
      DO 1416 I=1,L
      WRITE(21,1418) I,(SBE(I,J),J=1,5),(ED(I,J),J=1,5),(BE(I,J),J=1,5)
 1418 FORMAT(/1X,I1,6H.LAYER,17X,5F6.2,3X,5F7.2,3X,5F6.2)
 1416 CONTINUE
      IF(KDEE1.LT.4) GO TO 1421
      WRITE(21,1419)
 1419 FORMAT(//30X,'CH1',10X,'CH2',10X,'CH3',10X,'CH4',10X,'CH5')
      DO 1417 I=1,L
      WRITE(21,1415) I,CH1(I,1),CH2(I,1),CH3(I,1),CH4(I,1),CH5(I,1)
      IF(NJ(I).LT.2) GO TO 1417
      WRITE(21,1423) CH1(I,2),CH2(I,2),CH3(I,2),CH4(I,2),CH5(I,2)
      IF(NJ(I).LT.3) GO TO 1417
      WRITE(21,1423) CH1(I,3),CH2(I,3),CH3(I,3),CH4(I,3),CH5(I,3)
      IF(NJ(I).LT.4) GO TO 1417
      WRITE(21,1423) CH1(I,4),CH2(I,4),CH3(I,4),CH4(I,4),CH5(I,4)
      IF(NJ(I).LT.5) GO TO 1417
      WRITE(21,1423) CH1(I,5),CH2(I,5),CH3(I,5),CH4(I,5),CH5(I,5)
 1417 CONTINUE
 1415 FORMAT(/1X,I1,6H.LAYER,17X,5F13.6)
 1423 FORMAT(/25X,5F13.6)
 1421 CONTINUE
      IF(IPOT.EQ.1) DPOT='KR-C POTENTIAL'
      IF(IPOT.EQ.2) DPOT='mod. MOLIERE '
      IF(IPOT.EQ.3) DPOT='ZBL POTENTIAL'
      IF(IPOTR.EQ.1) DPOTR='KR-C POTENTIAL'
      IF(IPOTR.EQ.2) DPOTR='MOLIERE POTENTIAL'
      IF(IPOTR.EQ.3) DPOTR='ZBL POTENTIAL'
      WRITE(21,1411) DPOT,DPOTR
 1411 FORMAT(//7X,'INTERACTION POTENTIAL : PROJECTILE-TARGET : ',A18,'
     1 TARGET-TARGET : ',A18)
      IF(KDEE1.EQ.1) DKDEE1='LINDHARD-SCHARFF'
      IF(KDEE1.EQ.2) DKDEE1='OEN-ROBINSON'
      IF(KDEE1.EQ.3) DKDEE1='50% LS 50% OR'
      IF(KDEE1.EQ.4) DKDEE1='AZ nach ICRU49'
      IF(KDEE1.EQ.5) DKDEE1='ZIEGLER'
      IF(KDEE2.EQ.1) DKDEE2='LINDHARD-SCHARFF'
      IF(KDEE2.EQ.2) DKDEE2='OEN-ROBINSON'
      IF(KDEE2.EQ.3) DKDEE2='50% LS 50% OR'
      WRITE(21,1413) DKDEE1,DKDEE2
 1413 FORMAT(//7X,'INELASTIC LOSS MODEL  : PROJECTILE-TARGET : ',A18,'
     1 TARGET-TARGET : ',A18)
      IF(E0.GT.0.D0) GO TO 1420
      IF(ALPHA.LT.0.D0) GO TO 1405
      WRITE(21,1422) TI,ZARG,VELC,EMX
 1422 FORMAT(//6X,'MAXWELLIAN DISTRIBUTION',7X,2HTI,5X,4HZARG,5X
     1 ,4HVELC,8X,3HEMX/29X,1F10.2,2F9.4,1E14.6)
      GO TO 1427
 1405 ALPHAM=-ALPHA
      WRITE(21,1407) TI,SHEATH,ALPHAM,EMX
 1407 FORMAT(//6X,'MAXWELLIAN DISTRIBUTION (ENERGY)',7X,'TI',5X
     1 ,'SHEATH',5X,'ALPHAM',8X,'EMX'/38X,3F10.2,2X,1E14.6)
      GO TO 1427
 1420 IF(ALPHA.EQ.-1.) WRITE(21,1424)
 1424 FORMAT(//6X,'RANDOM DISTRIBUTION'/)
      IF(ALPHA.EQ.-2.) WRITE(21,1426)
 1426 FORMAT(//6X,'COSINE DISTRIBUTION'/)
 1427 CONTINUE
        IF(EQUAL(Esig,0.D0)) THEN
                WRITE(21,14271)
14271       FORMAT(//6X,'fixed PROJECTILE ENERGY'/)
        ELSE
                WRITE(21,14272)
14272       FORMAT(//6X,'PROJECTILE ENERGY has GAUSSIAN DISTRIBUTION '/)
        ENDIF
        IF(EQUAL(ALPHASIG,0.D0)) THEN
          WRITE(21,14273)
14273     FORMAT(//6X,'fixed PROJECTILE ANGLE'/)
        ELSE
          WRITE(21,14274)
14274     FORMAT(//6X,'PROJECTILE ANGLE has 1D GAUSSIAN DISTRIBUTION '/)
        ENDIF
      WRITE(21,1428)outnam
 1428 FORMAT(1H1,//30X,'* OUTPUT DATA *',5X,A12)
#if defined (OS_WIN)
      WRITE(22,14280)rgenam
14280 FORMAT(1H1,//30X,'* RANGE DATA *',5X,A12)
#endif
      WRITE(21,1430) HLM,HLMT,SU,SUT,XC,RT,SFE,INEL,L,LJ
 1430 FORMAT(//17X,'HLM',7X,'HLMT',8X,'SU',7X,'SUT',8X,'XC',8X,'RT',7X
     1       ,'SFE',6X,'INEL',9X,'L',8X,'LJ'/
     2       10X,1F11.4,1F10.3,1F10.4,1F10.3,1F10.4,1F10.3,1F10.2,3I10)
      WRITE(21,1432) NPROJ,KIB,KIT,MAXA,NALL,NPA,NSA,KIS,KIST
 1432 FORMAT(//16X,'NPROJ',7X,'KIB',7X,'KIT',6X,'MAXA',6X,'NALL',7X
     1 ,'NPA',7X,'NSA',7X,'KIS',6X,'KIST'/11X,9I10)
      WRITE(21,470)
  470 FORMAT(//12X,'EPS0(I)',7X,'Z2(I)',7X,'M2(I)',5X,'ARHO(I)'
     1 ,7X,'LM(I)',5X,'PDMAX(I)',5X,'ASIG(I)',7X,'SB(I)',7X,'XX(I)'
     2 ,8X,'NJ(I)')
      DO 472 I=1,L
      WRITE(21,473) I,EPS0(I),Z2(I),M2(I),ARHO(I),LM(I),PDMAX(I),ASIG(I)
     1 ,SB(I),XX(I),NJ(I)
  473 FORMAT(/1X,I1,6H.LAYER,1X,9E12.4,I10)
  472 CONTINUE
      WRITE(21,474)
  474 FORMAT(//13X,
     1 'A1(1)',3X,'A1(2)',3X,'A1(3)',3X,'A1(4)',3X,'A1(5)',3X,
     1 'A1(6)',3X,'A1(7)',3X,'A1(8)',3X,'A1(9)',2X,'A1(10)',2X,
     1 'A1(11)',2X,'A1(12)',2X,'A1(13)',2X,'A1(14)',2X,'A1(15)',2X,
     1 'A1(16)',2X,'A1(17)',2X,'A1(18)',2X,'A1(19)',2X,'A1(20)',2X,
     1 'A1(21)',2X,'A1(22)',2X,'A1(23)',2X,'A1(24)',2X,'A1(25)',2X,
     1 'A1(26)',2X,'A1(27)',2X,'A1(28)',2X,'A1(29)',2X,'A1(30)',2X,
     1 'A1(31)',2X,'A1(32)',2X,'A1(33)',2X,'A1(34)',2X,'A1(35)')
cTR        1 'A1(21)',2X,'A1(22)',2X,'A1(23)',2X,'A1(24)',2X,'A1(25)',2X,
cTR        1 'A1(26)',2X,'A1(27)',2X,'A1(28)',2X,'A1(29)',2X,'A1(30)',2X,
cTR        1 'A1(31)',2X,'A1(32)',2X,'A1(33)',2X,'A1(34)',2X,'A1(35)')
      DO 475 I=1,LJ
      WRITE(21,471) A1(I)
  471 FORMAT(/1X,9X,35F8.5)
  475 CONTINUE
      WRITE(21,484)
  484 FORMAT(//11X,
     1 'KOR1(1)',1X,'KOR1(2)',1X,'KOR1(3)',1X,'KOR1(4)',1X,'KOR1(5)',
     2 1X,'KOR1(6)',1X,'KOR1(7)',1X,'KOR1(8)',1X,'KOR1(9)',1X,'KOR1(A)',
     3 1X,'KOR1(B)',1X,'KOR1(C)',1X,'KOR1(D)',1X,'KOR1(E)',1X,'KOR1(F)',
     4 1X,'KOR1(G)',1X,'KOR1(H)',1X,'KOR1(I)',1X,'KOR1(J)',1X,'KOR1(K)',
     5 1X,'KOR1(L)',1X,'KOR1(M)',1X,'KOR1(N)',1X,'KOR1(O)',1X,'KOR1(P)',
     6 1X,'KOR1(Q)',1X,'KOR1(R)',1X,'KOR1(S)',1X,'KOR1(T)',1X,'KOR1(U)',
     7 1X,'KOR1(V)',1X,'KOR1(W)',1X,'KOR1(X)',1X,'KOR1(Y)',1X,'KOR1(Z)')
cTR        6 1X,'KOR1(Q)',1X,'KOR1(R)',1X,'KOR1(S)',1X,'KOR1(T)',1X,'KOR1(U)',
cTR        7 1X,'KOR1(V)',1X,'KOR1(W)',1X,'KOR1(X)',1X,'KOR1(Y)',1X,'KOR1(Z)')
      DO 486 I=1,LJ
      WRITE(21,489) KOR1(I)
  489 FORMAT(/1X,9X,35F8.5)
  486 CONTINUE
      WRITE(21,476)
  476 FORMAT(//12X,
     1 'A(I,1)',2X,'A(I,2)',2X,'A(I,3)',2X,'A(I,4)',2X,'A(I,5)',2X,
     2 'A(I,6)',2X,'A(I,7)',2X,'A(I,8)',2X,'A(I,9)',1X,'A(I,10)',1X,
     3 'A(I,11)',1X,'A(I,12)',1X,'A(I,13)',1X,'A(I,14)',1X,'A(I,15)',1X,
     4 'A(I,16)',1X,'A(I,17)',1X,'A(I,18)',1X,'A(I,19)',1X,'A(I,20)',1X,
     5 'A(I,21)',1X,'A(I,22)',1X,'A(I,23)',1X,'A(I,24)',1X,'A(I,25)',1X,
     6 'A(I,26)',1X,'A(I,27)',1X,'A(I,28)',1X,'A(I,29)',1X,'A(I,30)',1X,
     7 'A(I,31)',1X,'A(I,32)',1X,'A(I,33)',1X,'A(I,34)',1X,'A(I,35)')
cTR        4 'A(I,16)',1X,'A(I,17)',1X,'A(I,18)',1X,'A(I,19)',1X,'A(I,20)',1X,
cTR        5 'A(I,21)',1X,'A(I,22)',1X,'A(I,23)',1X,'A(I,24)',1X,'A(I,25)',1X,
cTR        6 'A(I,26)',1X,'A(I,27)',1X,'A(I,28)',1X,'A(I,29)',1X,'A(I,30)',1X,
cTR        7 'A(I,31)',1X,'A(I,32)',1X,'A(I,33)',1X,'A(I,34)',1X,'A(I,35)')     
      DO 478 I=1,LJ
      WRITE(21,477) (A(I,J),J=1,LJ)
  477 FORMAT(/1X,9X,35F8.5)
  478 CONTINUE
      WRITE(21,490)
  490 FORMAT(//11X,
     1 'KOR(,1)',1X,'KOR(,2)',1X,'KOR(,3)',1X,'KOR(,4)',1X,'KOR(,5)',1X,
     2 'KOR(,6)',1X,'KOR(,7)',1X,'KOR(,8)',1X,'KOR(,9)',1X,'KOR(,A)',1X,
     3 'KOR(,B)',1X,'KOR(,C)',1X,'KOR(,D)',1X,'KOR(,E)',1X,'KOR(,F)',1X,
     4 'KOR(,G)',1X,'KOR(,H)',1X,'KOR(,I)',1X,'KOR(,J)',1X,'KOR(,K)',1X,
     5 'KOR(,L)',1X,'KOR(,M)',1X,'KOR(,N)',1X,'KOR(,O)',1X,'KOR(,P)',1X,
     6 'KOR(,Q)',1X,'KOR(,R)',1X,'KOR(,S)',1X,'KOR(,T)',1X,'KOR(,U)',1X,
     7 'KOR(,V)',1X,'KOR(,W)',1X,'KOR(,X)',1X,'KOR(,Y)',1X,'KOR(,Z)')
cTR        4 'KOR(,G)',1X,'KOR(,H)',1X,'KOR(,I)',1X,'KOR(,J)',1X,'KOR(,K)',1X,
cTR        5 'KOR(,L)',1X,'KOR(,M)',1X,'KOR(,N)',1X,'KOR(,O)',1X,'KOR(,P)',1X,
cTR        6 'KOR(,Q)',1X,'KOR(,R)',1X,'KOR(,S)',1X,'KOR(,T)',1X,'KOR(,U)',1X,
cTR        7 'KOR(,V)',1X,'KOR(,W)',1X,'KOR(,X)',1X,'KOR(,Y)',1X,'KOR(,Z)')
      DO 491 I=1,LJ
      WRITE(21,492) (KOR(I,J),J=1,LJ)
  492 FORMAT(/1X,9X,35F8.5)
  491 CONTINUE
C     WRITE(6,479)
C 479 FORMAT(//13X,
C    1 'F(I,1)',6X,'F(I,2)',6X,'F(I,3)',6X,'F(I,4)',6X,'F(I,5)',5X,
C    2 'KOR(I,1)',4X,'KOR(I,2)',4X,'KOR(I,3)',4X,'KOR(I,4)',4X,
C    3 'KOR(I,5)')
C     DO 480 I=1,L
C     WRITE(6,481) I,(F(I,J),J=1,5),(KOR(I,J),J=1,5)
C 481 FORMAT(/1X,I1,6H.LAYER,1X,10E12.4)
C 480 CONTINUE
C     WRITE(6,483)
C 483 FORMAT(//12X,
C    1 'KL(I,1)',5X,'KL(I,2)',5X,'KL(I,3)',5X,'KL(I,4)',5X,'KL(I,5)',6X,
C    2 'K(I,1)',6X,'K(I,2)',6X,'K(I,3)',6X,'K(I,4)',6X,'K(I,5)')
C     DO 482 I=1,L
C     WRITE(6,485) I,(KL(I,J),J=1,5),(K(I,J),J=1,5)
C 485 FORMAT(/1X,I1,6H.LAYER,1X,10E12.4)
C 482 CONTINUE
C
C     INTEGRAL IMPLANTATION , SPUTTERING , BACKSCATTERING , TRANSMISSION
C
      IIM=NH-IB-IT
      YH=DBLE(IIM)
      HN=DBLE(NH)
      EMV=CVMGT(EMX/HN,E0,E0.LE.0.D0)
      EIM=DBLE(IIM)*EMV
      DO 1550 J=1,LJ
      ISPA = ISPA+IBSP(J)
 1550 ESPA = ESPA+EBSP(J)
      DO 1702 J=1,LJ
      ISPAT = ISPAT+ITSP(J)
 1702 ESPAT = ESPAT+ETSP(J)
      WRITE(21,1500) IIM,EIM,IB,EB,IT,ET,ISPA,ESPA,ISPAT,ESPAT,
     1  tryE,negE,epsilon,prcoeff
 1500 FORMAT(1H1,//11X,20HIMPLANTED PARTICLES=,I7,5X,7HENERGY=,E10.4,
     1 3H EV/7X,24HBACKSCATTERED PARTICLES=,I7,5X,7HENERGY=,E10.4,
     2 3H EV/9X,22HTRANSMITTED PARTICLES=,I7,5X,7HENERGY=,E10.4,
     3 3H EV/7X,24HBACKSPUTTERED PARTICLES=,I7,5X,7HENERGY=,E10.4,
     4 3H EV/6X,'TRANSM. SPUTT. PARTICLES=',I7,5X,7HENERGY=,E10.4,
     5 3H EV/15X,16HTRIED PARTICLES=,I7
     6      /9X,22HPARTICLES with neg. E=,I7,
     7      /6X,25HTHOMAS FERMI RED. ENERGY=,2X,E10.4,
     8      /6X,25HSCALED PART. REFL. COEFF=,2x,E10.4)
      if(l.gt.1) then
          do i=1,l
            nli(i)=IDINT(xx(i)/cw+0.01)
          enddo
          do i=1,l
            do j=nli(i-1)+1,nli(i)
               irpl(i)=irpl(i)+irp(j)
            enddo
          enddo
                WRITE(21,15001)
15001           FORMAT(/33x,'FROM BIN WIDTH',2x,'FROM LAYER THICKNESS')
                IF(depth_interval_flag.EQ.0) WRITE(21,'(36x,5HWRONG)')

          do i=1,l
            WRITE(21,1501) i,irpl(i),number_in_layer(i)
          enddo
 1501     FORMAT(/1x,'IMPLANTED PARTICLES (LAYER ',i1,')=',i16,2x,i16)
      endif
      CSUM=ICSUM
      CSUMS=ICSUMS
      AVCSUM=CSUM/HN
      AVCSMS=CSUMS/HN
      AVCDIS=DBLE(ICDI)/HN
      CST=DBLE(ICSUM-ICDI)
      WRITE(21,1511) AVCSUM,AVCDIS,AVCSMS
 1511 FORMAT(//2X,'PROJECTILES :   ',
     1            'MEAN NUMBER OF ELASTIC COLLISIONS = ',1F8.1,3X,
     2            'MEAN NUMBER OF EL.COLL.(E > EDISPL.) = ',F8.3/65X,
     3            'MEAN NUMBER OF EL.COLL.(E > SB(1))   = ',F8.3)
      IF(YH.LE.1.D0) GO TO 1502
      AVNLI=ENUCLI/YH
      VANLI=ENL2I/YH-AVNLI*AVNLI
      SIGNLI=DSQRT(VANLI)
      DFINLI=SIGNLI/YH
      AVILI=EINELI/YH
      VAILI=EIL2I/YH-AVILI*AVILI
      SIGILI=DSQRT(VAILI)
      DFIILI=SIGILI/YH
      CALL MOMENTS(FIX0,SEX,THX,FOX,FIX,SIX,SIGMAX,DFIX0,DSEX,DTHX,
     1             XSUM,X2SUM,X3SUM,X4SUM,X5SUM,X6SUM,YH)
      CALL MOMENTS(FIR0,SER,THR,FOR,FIR,SIR,SIGMAR,DFIR0,DSER,DTHR,
     1             RSUM,R2SUM,R3SUM,R4SUM,R5SUM,R6SUM,YH)
      CALL MOMENTS(FIP0,SEP,THP,FOP,FIP,SIP,SIGMAP,DFIP0,DSEP,DTHP,
     1             PLSUM,PL2SUM,PL3SUM,PL4SUM,PL5SUM,PL6SUM,YH)
      CALL MOMENTS(FIE0,SEE,THE,FOE,FIE,SIE,SIGMAE,DFIE0,DSEE,DTHE,
     1             EEL,EEL2,EEL3,EEL4,EEL5,EEL6,CSUM)
      CALL MOMENTS(FIW0,SEW,THW,FOW,FIW,SIW,SIGMAW,DFIW0,DSEW,DTHW,
     1             EELWC,EELWC2,EELWC3,EELWC4,EELWC5,EELWC6,CSUM)
      CALL MOMENTS(FII0,SEI,THI,FOI,FII,SII,SIGMAI,DFII0,DSEI,DTHI,
     1             EIL,EIL2,EIL3,EIL4,EIL5,EIL6,CSUM)
      CALL MOMENTS(FIS0,SES,THS,FOS,FIS,SIS,SIGMAS,DFIS0,DSES,DTHS,
     1             EPL,EPL2,EPL3,EPL4,EPL5,EPL6,CST)
      WRITE(21,7117)
 7117 FORMAT(/20X,'   MEAN   ',4X,' VARIANCE ',4X,' SKEWNESS ',4X,
     1 ' KURTOSIS ',5X,'  SIGMA   ',3X,' ERROR 1.M ',3X,' ERROR 2.M ',
     2 3X,' ERROR 3.M ')
      WRITE(21,7227) FIX0,SEX,THX,FOX,SIGMAX,DFIX0,DSEX,DTHX
 7227 FORMAT(1X,' PENETRATION',5X,1P1E12.4,7E14.4)
      WRITE(21,7228) FIR0,SER,THR,FOR,SIGMAR,DFIR0,DSER,DTHR
 7228 FORMAT(1X,'      SPREAD',5X,1P1E12.4,7E14.4)
      WRITE(21,7229) FIP0,SEP,THP,FOP,SIGMAP,DFIP0,DSEP,DTHP
 7229 FORMAT(1X,'  PATHLENGTH',5X,1P1E12.4,7E14.4)
      WRITE(21,7237) AVNLI,VANLI,SIGNLI,DFINLI
 7237 FORMAT(1X,'ELASTIC LOSS',5X,1P1E12.4,1E14.4,28X,2E14.4)
      WRITE(21,7238) AVILI,VAILI,SIGILI,DFIILI
 7238 FORMAT(1X,'  INEL. LOSS',5X,1P1E12.4,1E14.4,28X,2E14.4)
      WRITE(21,7117)
      WRITE(21,7231) FIE0,SEE,THE,FOE,SIGMAE,DFIE0,DSEE,DTHE
 7231 FORMAT(1X,'  ELAST.LOSS',5X,1P1E12.4,7E14.4)
      WRITE(21,7232) FIW0,SEW,THW,FOW,SIGMAW,DFIW0,DSEW,DTHW
 7232 FORMAT(1X,'WEAK EL.LOSS',5X,1P1E12.4,7E14.4)
      WRITE(21,7233) FII0,SEI,THI,FOI,SIGMAI,DFII0,DSEI,DTHI
 7233 FORMAT(1X,'INELAST.LOSS',5X,1P1E12.4,7E14.4)
      WRITE(21,7234) FIS0,SES,THS,FOS,SIGMAS,DFIS0,DSES,DTHS
 7234 FORMAT(1X,' SUBTHR.LOSS',5X,1P1E12.4,7E14.4)
 1502 CONTINUE
c
      IF(YH.LT.1.D0) GO TO 7235
      CALL MOMENT(X1SD,X2SD,X3SD,X4SD,X5SD,X6SD
     1            ,XSUM,X2SUM,X3SUM,X4SUM,X5SUM,X6SUM,YH)
      WRITE(21,7118)
      WRITE(21,1513) X1SD,X2SD,X3SD,X4SD,X5SD,X6SD
 1513 FORMAT(1X,' PENETRATION',5X,1P1E12.4,5E14.4)
 7235 continue
      if(irl.eq.0) goto 1453
      CSUMR=DBLE(ICSUMR)
      ACSUMR=CSUMR/HN
      ACDISR=DBLE(ICDIR)/HN
      ACSBER=DBLE(ICSBR)/HN
      WRITE(21,1599) ACSUMR,ACDISR,ACSBER
 1599 FORMAT(///2X,'RECOILES (PER PROJ.)   :   ',
     1             'MEAN NUMBER OF ELASTIC COLLISIONS = ',1F8.1,3X,
     2             'MEAN NUMBER OF EL.COLL.(E > EDISPL.) = ',F10.3/76X,
     3             'MEAN NUMBER OF EL.COLL.(E > SB(1))   = ',F10.3)
      IF(NPA+NSA.EQ.0) GO TO 1453
      ACSUR=CSUMR/(DBLE(NPA+NSA))
      ACDIR=DBLE(ICDIR)/(NPA+NSA)
      ACSBR=DBLE(ICSBR)/(NPA+NSA)
      WRITE(21,1598) ACSUR,ACDIR,ACSBR
 1598 FORMAT(/2X,'RECOILES (PER KNOCKON) :   ',
     1             'MEAN NUMBER OF ELASTIC COLLISIONS = ',1F8.3,3X,
     2             'MEAN NUMBER OF EL.COLL.(E > EDISPL.) = ',F10.3/,76X,
     3             'MEAN NUMBER OF EL.COLL.(E > SB(1))   = ',F10.3/)
      IF(NJ(1).LT.2) GO TO 1453
      ACDR11=DBLE(ICDIRJ(1,1))/(NPA+NSA)
      ACDR12=DBLE(ICDIRJ(1,2))/(NPA+NSA)
      ACDR21=DBLE(ICDIRJ(2,1))/(NPA+NSA)
      ACDR22=DBLE(ICDIRJ(2,2))/(NPA+NSA)
      WRITE(21,1451) ACDR11,ACDR12,ACDR21,ACDR22
 1451 FORMAT(76X,'MEAN NR OF EL.COLL.(E > EDISPL.) 1-1 = ',F10.3/
     1      ,76X,'MEAN NR OF EL.COLL.(E > EDISPL.) 1-2 = ',F10.3/
     2      ,76X,'MEAN NR OF EL.COLL.(E > EDISPL.) 2-1 = ',F10.3/
     3      ,76X,'MEAN NR OF EL.COLL.(E > EDISPL.) 2-2 = ',F10.3)
 1453 CONTINUE
  590 WRITE(21,600)
  600 FORMAT(1H1,///,5X,8HDEPTH(A),2X,9HPARTICLES,2X,10HNORM.DEPTH,1X,
     110HPATHLENGTH,3X,10HINLOSS(EV),2X,10HTELOSS(EV),2X,10HELLOSS(EV),
     22X,10HDAMAGE(EV),2X,10HPHONON(EV),2X,10HCASCAD(EV),5X,3HDPA/)
C
      IF(depth_interval_flag.EQ.0) THEN
        WRITE(22,*)' CALCULATED IMPLANTATION PROFILE DID NOT ', 
     &     'AGREE WITH LAYER THICKNESS'
        WRITE(21,*)' CALCULATED IMPLANTATION PROFILE DID NOT ', 
     &          'AGREE WITH LAYER THICKNESS'
c        WRITE(22,*)' CALCULATED IMPLANTATION PROFILE DID NOT AGREE WIT
c     1H LAYER THICKNESS'
c        WRITE(21,*)' CALCULATED IMPLANTATION PROFILE DID NOT AGREE WIT
c     1H LAYER THICKNESS'
        ENDIF
C
#if defined (OS_WIN)
      WRITE(22,6002)
 6002   FORMAT(1H1,///,5X,8HDEPTH(A),2X,9HPARTICLES)
#else
      write(22,'(a)') ' DEPTH      PARTICLES' 
#endif
      IF(YH.LT.1.D0) GO TO 603
      DO 602 I=0,101
      RIRP(I) = DBLE(IRP(I))/YH
  602 CONTINUE
  603 D1=0.
      D2=CW
      WRITE(21,601) D1,IRP(0),RIRP(0)
  601 FORMAT(4X,3H-SU,1H-,F6.0,I10,E12.4)
c     DO 1441 J=1,NJ(1)
      DO 1441 J=1,LJ
      DO 1441 I=1,100
      ICDT(I)=ICDT(I)+ICD(I,J)
      ICDTR(I)=ICDTR(I)+ICDR(I,J)
 1441 CONTINUE
      DO 1442 K=1,NJ(1)
      DO 1442 J=1,NJ(1)
      DO 1442 I=1,100
      ICDIRN(I,J)=ICDIRN(I,J)+ICDIRI(I,K,J)
 1442 CONTINUE
      DO 35 I=0,101
      IIRP=IIRP+IRP(I)
      TRIRP=TRIRP+RIRP(I)
   35 CONTINUE
      DO 36 I=1,100
      IIPL=IIPL+IPL(I)
      TION=TION+ION(I)
      TDENT=TDENT+DENT(I)
      TDMGN=TDMGN+DMGN(I)
      TELGD=TELGD+ELGD(I)
      TPHON=TPHON+PHON(I)
      TCASMO=TCASMO+CASMOT(I)
      ICDTT=ICDTT+ICDT(I)
      TIONR=TIONR+IONR(I)
      TDENTR=TDENTR+DENTR(I)
      TELGDR=TELGDR+ELGDR(I)
      TDMGNR=TDMGNR+DMGNR(I)
      TPHONR=TPHONR+PHONR(I)
C     TCASMOR=TCASMOR+CASMOTR(I)
      ICDTTR=ICDTTR+ICDTR(I)
   36 CONTINUE
      do im1=100,1,-1
C         if(ipl(im1).ne.0.or.ion(im1).ne.0.) go to 20
           if(ipl(im1).ne.0.or.(.NOT.EQUAL(ion(im1),0.D0))) goto 20
      enddo
      im1=1
   20 im1=min0(im1+2,100)
      DO 11 I=1,im1
      WRITE(21,700) D1,D2,IRP(I),RIRP(I),IPL(I),ION(I),DENT(I),DMGN(I)
     1 ,ELGD(I),PHON(I),CASMOT(I),ICDT(I)
        Dmid=(D2-D1)/2+D1
      WRITE(22,701) Dmid,IRP(I)
  700 FORMAT(1X,F6.0,1H-,F6.0,I10,E12.4,I10,1P1E14.4,5E12.4,I8)
  701 FORMAT(1X,F6.0,2x,I10)
      D1=D2
   11 D2=D2+CW
      WRITE(21,604) D2-CW,IRP(101),RIRP(101)
  604 FORMAT(1X,F6.0,1H-,3X,3HSUT,I10,E12.4)
      WRITE(21,710) IIRP,TRIRP,IIPL,TION,TDENT,TDMGN,TELGD,TPHON,TCASMO
     1             ,ICDTT
  710 FORMAT(/14X,I10,1P1E12.4,I10,1E14.4,5E12.4,I8)
      DO 1531 J=1,NJ(1)
      DO 1531 I=1,100
      ELET(J)=ELET(J)+ELE(I,J)
      ELIT(J)=ELIT(J)+ELI(I,J)
      ELPT(J)=ELPT(J)+ELP(I,J)
      ELDT(J)=ELDT(J)+ELD(I,J)
      ICDJT(J)=ICDJT(J)+ICD(I,J)
      ICDJTR(J)=ICDJTR(J)+ICDR(I,J)
      ICDITR(J)=ICDITR(J)+ICDIRN(I,J)
C     ELETR(J)=ELETR(J)+ELE(I,J)
C     ELITR(J)=ELITR(J)+ELI(I,J)
C     ELPTR(J)=ELPTR(J)+ELP(I,J)
C     ELDTR(J)=ELDTR(J)+ELD(I,J)
 1531 CONTINUE
c     IF(NJ(1).LT.2) GO TO 1455
      WRITE(21,1521)
 1521 FORMAT(1H1,4X,'DEPTH(A)'
     1  ,3X,' INLOSS(1)',3X,'ELLOSS(1)',3X,'DAMAGE(1)',3X,'PHONON(1)'
     2  ,2X,' INLOSS(2)',3X,'ELLOSS(2)',3X,'DAMAGE(2)',3X,'PHONON(2)'
     3  ,2X,'DPA(1)',2X,'DPA(2)'/)
      D1=0.
      D2=CW
      do im2=100,1,-1
C         if(eli(im2,1).ne.0..or.eli(im2,2).ne.0.) go to 30
           if(.NOT.EQUAL(eli(im2,1),0.D0).or.
     #    (.NOT.EQUAL(eli(im2,2),0.D0))) goto 30

      enddo
      im2=1
   30 im2=MIN0(im2+2,100)
      DO 1525 I=1,im2
      WRITE(21,1523) D1,D2,ELI(I,1),ELE(I,1),ELD(I,1),ELP(I,1)
     1       ,ELI(I,2),ELE(I,2),ELD(I,2),ELP(I,2),ICD(I,1),ICD(I,2)
 1523 FORMAT(1X,F6.0,1H-,F6.0,1P8E12.4,2I8)
      D1=D2
      D2=D2+CW
 1525 CONTINUE
      WRITE(21,1533) ELIT(1),ELET(1),ELDT(1),ELPT(1)
     1             ,ELIT(2),ELET(2),ELDT(2),ELPT(2),ICDJT(1),ICDJT(2)
 1533 FORMAT(/14X,1P8E12.4,2I8///)
C     WRITE(21,1481)
C1481 FORMAT(1H1,2X,'D(A)'
C    1       ,2X,'  DAMAGE(1)',3X,'   DAMAGE(2)',1X,'    DAMAGE(3)'
C    2       ,2X,'  DAMAGE(4)',3X,'   DAMAGE(5)'/)
C     DO 1482 I=1,100
C     WRITE(6,1483) I,ELD(I,1),ELD(I,2),ELD(I,3),ELD(I,4),ELD(I,5)
C1482 CONTINUE
C1483 FORMAT(1X,I5,1P5E14.4)
C     WRITE(6,1484) ELDT(1),ELDT(2),ELDT(3),ELDT(4),ELDT(5)
C1484 FORMAT(/1X,5X,1P5E14.4///)
      DO 1491 I=1,L-1
      ILD(I)=IDINT(XX(I)/CW+0.01D0)
      IF(ILD(I).GT.100) ILD(I)=100
      DO 1492 J=1,ILD(I)
      DLI(I)=DLI(I)+DMGN(J)
 1492 CONTINUE
 1491 CONTINUE
      DLI(L)=TDMGN
C     WRITE(21,*) 'L=',L,' XX=',XX,' DLI=',DLI
      DO 1493 I=L,2,-1
      DLI(I)=DLI(I)-DLI(I-1)
 1493 CONTINUE
      DO 1494 I=1,L
      WRITE(21,1495) I,DLI(I)
 1495 FORMAT(/5X,'DAMAGE IN LAYER ',I1,' :  ',1P1E12.4)
 1494 CONTINUE
 1455 CONTINUE
      if(irl.eq.0) goto 1497
      WRITE(21,1496)
 1496 FORMAT(1H1,/,5X,'RECOILS')
      WRITE(21,1597)
 1597 FORMAT(///,5X,8HDEPTH(A),
     1 5X,10HINLOSS(EV),3X,10HTELOSS(EV),3X,10HELLOSS(EV),
     2 3X,10HDAMAGE(EV),3X,10HPHONON(EV),5X,3HDPA,
c    3 2X,6HDPA(1),2X,6HDPA(2)/)
     3 2X,6HDPA(1),2X,6HDPA(2),
     4 1X,5H(1-1),1X,5H(1-2),1X,5H(2-1),1X,5H(2-2)/)
      D1=0.D0
      D2=CW
      do im3=100,1,-1
         if (.not.equal(ionr(im3),0.D0)) go to 31   
C         if(ionr(im3).ne.0.) goto 31
      enddo
      im3=1
   31 im3=MIN0(im3+2,100)
      DO 1594 I=1,im3
      WRITE(21,1595) D1,D2,IONR(I),DENTR(I),DMGNR(I),ELGDR(I),PHONR(I)
     1              ,ICDTR(I),ICDIRN(I,1),ICDIRN(I,2)
     2     ,ICDIRI(I,1,1),ICDIRI(I,1,2),ICDIRI(I,2,1),ICDIRI(I,2,2)
c1595 FORMAT(1X,F6.0,1H-,F6.0,1P1E14.4,4E13.4,3I8)
 1595 FORMAT(1X,F6.0,1H-,F6.0,1P1E14.4,4E13.4,3I8,4I6)
      D1=D2
 1594 D2=D2+CW
      WRITE(21,1596) TIONR,TDENTR,TDMGNR,TELGDR,TPHONR
     1,ICDTTR,ICDITR(1),ICDITR(2)
 1596 FORMAT(/14X,1P1E14.4,4E13.4,3I8)
 1497 continue
C
C     BACKSCATTERING
C
      IF(IB.EQ.0) GO TO 1512
      WRITE(21,1527)
 1527 FORMAT(1H1,//5X,'BACKSCATTERING OF PROJECTILES'/)
      BI=DBLE(IB)
      BIL=DBLE(IBL)
      RN=BI/HN
      RE=EB/(HN*EMV)
      EMEANR=RE/RN
      EMEAN=EB/BI
      AVEB=EMEAN
      IF (equal(BI,1.0d0))GO TO 1506
C      IF(BI.EQ.1.) GO TO 1506
      AVNLB=ENUCLB/BI
      VANLB=ENL2B/BI-AVNLB*AVNLB
      SIGNLB=DSQRT(VANLB)
      DFINLB=SIGNLB/BI
      AVILB=EINELB/BI
      VAILB=EIL2B/BI-AVILB*AVILB
      SIGILB=DSQRT(VAILB)
      DFIILB=SIGILB/BI
 1506 WRITE(21,1508) RN,RE,EMEANR,EMEAN
 1508 FORMAT(/5X,'PART.REFL.COEF.=',1PE11.4,'  ENERGY REFL.COEF.='
     1       ,1E11.4,'  REL.MEAN ENERGY =',1E11.4,'  MEAN ENERGY ='
     2       ,1E11.4)
      IF(IB.EQ.0) GO TO 1512
      CALL MOMENT(EB1B,EB2B,EB3B,EB4B,EB5B,EB6B
     1            ,EB,EB2SUM,EB3SUM,EB4SUM,EB5SUM,EB6SUM,BI)
      CALL MOMENT(EB1BL,EB2BL,EB3BL,EB4BL,EB5BL,EB6BL
     1            ,EB1SUL,EB2SUL,EB3SUL,EB4SUL,EB5SUL,EB6SUL,BIL)
      CALL MOMENTS(FIB0,SEB,THB,FOB,FIB,SIB,SIGMAB,DFIB0,DSEB,DTHB,
     1             EB,EB2SUM,EB3SUM,EB4SUM,EB5SUM,EB6SUM,BI)
      CALL MOMENT(PL1S,PL2S,PL3S,PL4S,PL5S,PL6S
     1            ,PLSB,PL2SB,PL3SB,PL4SB,PL5SB,PL6SB,BI)
      CALL MOMENTS(FIPB0,SEPB,THPB,FOPB,FIPB,SIPB,SIGMPB
     1             ,DFIPB0,DSEPB,DTHPB,
     2             PLSB,PL2SB,PL3SB,PL4SB,PL5SB,PL6SB,BI)
      WRITE(21,7117)
      WRITE(21,7241) FIB0,SEB,THB,FOB,SIGMAB,DFIB0,DSEB,DTHB
 7241 FORMAT(1X,'      ENERGY',5X,1P1E12.4,7E14.4)
      WRITE(21,7242) FIPB0,SEPB,THPB,FOPB,SIGMPB,DFIPB0,DSEPB,DTHPB
 7242 FORMAT(1X,'  PATHLENGTH',5X,1P1E12.4,7E14.4)
      WRITE(21,7237) AVNLB,VANLB,SIGNLB,DFINLB
      WRITE(21,7238) AVILB,VAILB,SIGILB,DFIILB
      WRITE(21,7118)
      WRITE(21,1541) EB1B,EB2B,EB3B,EB4B,EB5B,EB6B
 1541 FORMAT(1X,'      ENERGY',5X,1P1E12.4,5E14.4)
      WRITE(21,1543) EB1BL,EB2BL,EB3BL,EB4BL,EB5BL,EB6BL
 1543 FORMAT(1X,'   LOGENERGY',5X,1P1E12.4,5E14.4)
      WRITE(21,1545) PL1S,PL2S,PL3S,PL4S,PL5S,PL6S
 1545 FORMAT(1X,'  PATHLENGTH',5X,1P1E12.4,7E14.4)
      DO 1510 I=1,20
 1510 AI(I)=0.05D0*DBLE(I)
      IF(IB.EQ.0) GO TO 1512
      WRITE(21,1514)
 1514 FORMAT(//5X,'POLAR ANGULAR DISTRIBUTION OF BACKSCATTERED ', 
     1   'PROJECTILES'//)
cTR 1514 FORMAT(//5X,'POLAR ANGULAR DISTRIBUTION OF BACKSCATTERED PROJECTIL
cTR     1ES'//)
      DO 1516 I=1,20
 1516 RKADB(I)=DBLE(KADB(I))*20.D0/DBLE(IB)
      WRITE(21,1518)(AI(I),I=1,20),(KADB(I),I=1,20),(RKADB(I),I=1,20)
 1518 FORMAT(5X,20F6.2//,5X,20I6/5X,20F6.3)
 1512 CONTINUE
C
C     TRANSMISSION
C
      IF(IT.EQ.0) GO TO 1524
      WRITE(21,1529)
 1529 FORMAT(///5X,' TRANSMISSION OF PROJECTILES'/)
      TIT=DBLE(IT)
      TN=TIT/HN
      TE=ET/(HN*E0)
      TMEANR=TE/TN
      EMEANT=TMEANR*E0
      IF (equal(TIT,1.0D0)) GO TO 1520
C      IF(TIT.EQ.1.) GO TO 1520
      AVNLT=ENUCLT/TIT
      VANLT=ENL2T/TIT-AVNLT*AVNLT
      SIGNLT=DSQRT(VANLT)
      DFINLT=SIGNLT/TIT
      AVILT=EINELT/TIT
      VAILT=EIL2T/TIT-AVILT*AVILT
      SIGILT=DSQRT(VAILT)
      DFIILT=SIGILT/TIT
 1520 WRITE(21,1522) TN,TE,TMEANR,EMEANT
 1522 FORMAT(//5X,'PART.TRANSM.COEF.=',1PE11.4,'  ENERGY TRANSM.COEF.='
     1       ,1E11.4,'  REL.MEAN ENERGY =',1E11.4,'  MEAN ENERGY ='
     2       ,1E11.4)
      CALL MOMENTS(FIT0,SET,THT,FOT,FIT,SIT,SIGMAT,DFIT0,DSET,DTHT,
     1             ET,ET2SUM,ET3SUM,ET4SUM,ET5SUM,ET6SUM,TIT)
      CALL MOMENTS(FIPT0,SEPT,THPT,FOPT,FIPT,SIPT,SIGMPT
     1             ,DFIPT0,DSEPT,DTHPT,
     2             PLST,PL2ST,PL3ST,PL4ST,PL5ST,PL6ST,TIT)
      WRITE(21,7117)
      WRITE(21,7241) FIT0,SET,THT,FOT,SIGMAT,DFIT0,DSET,DTHT
      WRITE(21,7242) FIPT0,SEPT,THPT,FOPT,SIGMPT,DFIPT0,DSEPT,DTHPT
      WRITE(21,7237) AVNLT,VANLT,SIGNLT,DFINLT
      WRITE(21,7238) AVILT,VAILT,SIGILT,DFIILT
      WRITE(21,1526)
 1526 FORMAT(//5X,'POLAR ANGULAR DISTRIBUTION OF TRANSMITTED ', 
     1   'PARTICLES'//)
cTR 1526 FORMAT(//5X,'POLAR ANGULAR DISTRIBUTION OF TRANSMITTED PARTICLES'
cTR     1//)
      DO 1528 I=1,20
 1528 RKADT(I)=DBLE(KADT(I))*20.D0/DBLE(IT)
      WRITE(21,1530) (AI(I),I=1,20),(KADT(I),I=1,20),(RKADT(I),I=1,20)
 1530 FORMAT(5X,20F6.2//,5X,20I6/5X,20F6.3)
 1524 CONTINUE
C
C     BACKWARD SPUTTERING : YIELDS AND ENERGIES
C
      IF(ISPA.EQ.0) GO TO 1700
      WRITE(21,1548)
 1548 FORMAT(1H1,5X,'BACKWARD SPUTTERING')
      DO 1552 J=1,NJ(1)
      ISPAL(1) = ISPAL(1)+IBSP(J)
 1552 ESPAL(1) = ESPAL(1)+EBSP(J)
      DO 1554 J=NJ(1)+1,JT(3)
      ISPAL(2) = ISPAL(2)+IBSP(J)
 1554 ESPAL(2) = ESPAL(2)+EBSP(J)
      DO 1556 J=JT(3)+1,LJ
      ISPAL(3) = ISPAL(3)+IBSP(J)
 1556 ESPAL(3) = ESPAL(3)+EBSP(J)
      WRITE(21,1558) ISPA,ESPA
 1558 FORMAT(///,8X,'ALL SPUTTERED PARTICLES = ',I7,3X
     1       ,'TOTAL SPUTTERED ENERGY = ',E10.4,3H EV//)
      DO 1557 J=1,L
      WRITE(21,1559) J,ISPAL(J),ESPAL(J)
 1559 FORMAT(8X,'SPUTTERED PARTICLES (',I1,'.LAYER) = ',I7,3X
     1       ,'SPUTTERED ENERGY = ',E10.4,3H EV)
 1557 CONTINUE
      WRITE(21,1560)
 1560 FORMAT(//1X,'1.LAYER')
      DO 1562 J=1,NJ(1)
      WRITE(21,1564) J,IBSP(J),J,EBSP(J)
 1564 FORMAT(9X,'SPUTTERED PARTICLES(',I1,') = ',I7,5X
     1       ,'SPUTTERED ENERGY(',I1,') = ',E10.4,' EV')
 1562 CONTINUE
      IF(ISPA.EQ.0) GO TO 1700
      DO 1572 J=1,LJ
      RIP(J)=DBLE(ISPIP(J))/DBLE(ISPA)
      RIS(J)=DBLE(ISPIS(J))/DBLE(ISPA)
      ROP(J)=DBLE(ISPOP(J))/DBLE(ISPA)
      ROS(J)=DBLE(ISPOS(J))/DBLE(ISPA)
      REIP(J)=ESPIP(J)/ESPA
      REIS(J)=ESPIS(J)/ESPA
      REOP(J)=ESPOP(J)/ESPA
      REOS(J)=ESPOS(J)/ESPA
 1572 CONTINUE
      DO 1584 J=1,LJ
      IF(IBSP(J).EQ.0) GO TO 1584
      RIPJ(J)=DBLE(ISPIP(J))/DBLE(IBSP(J))
      RISJ(J)=DBLE(ISPIS(J))/DBLE(IBSP(J))
      ROPJ(J)=DBLE(ISPOP(J))/DBLE(IBSP(J))
      ROSJ(J)=DBLE(ISPOS(J))/DBLE(IBSP(J))
      REIPJ(J)=ESPIP(J)/EBSP(J)
      REISJ(J)=ESPIS(J)/EBSP(J)
      REOPJ(J)=ESPOP(J)/EBSP(J)
      REOSJ(J)=ESPOS(J)/EBSP(J)
 1584 CONTINUE
      DO 1571 J=1,LJ
      IF(ISPIP(J).EQ.0) GO TO 3571
      ESPMIP(J)=ESPIP(J)/DBLE(ISPIP(J))
 3571 IF(ISPIS(J).EQ.0) GO TO 3572
      ESPMIS(J)=ESPIS(J)/DBLE(ISPIS(J))
 3572 IF(ISPOP(J).EQ.0) GO TO 3573
      ESPMOP(J)=ESPOP(J)/DBLE(ISPOP(J))
 3573 IF(ISPOS(J).EQ.0) GO TO 1571
      ESPMOS(J)=ESPOS(J)/DBLE(ISPOS(J))
 1571 CONTINUE
 1573 CONTINUE
      DO 1578 J=1,LJ
      SPY(J)=DBLE(IBSP(J))/HN
 1578 SPE(J)=EBSP(J)/(HN*EMV)
      DO 1579 J=1,LJ
      IF (equal(SPY(J),0.0D0))GO TO 1579
C      IF(SPY(J).EQ.0.0) GO TO 1579
      REY(J)=SPE(J)/SPY(J)
      EMSP(J)=EBSP(J)/IBSP(J)
 1579 CONTINUE
      IF(ISPAL(1).EQ.0) GO TO 1575
      DO 1574 J=1,NJ(1)
      WRITE(21,1576) J,ISPIP(J),RIP(J),RIPJ(J),ESPIP(J),REIP(J),REIPJ(J)
     1             ,ESPMIP(J)
     2             ,J,ISPIS(J),RIS(J),RISJ(J),ESPIS(J),REIS(J),REISJ(J)
     3             ,ESPMIS(J)
     4             ,J,ISPOP(J),ROP(J),ROPJ(J),ESPOP(J),REOP(J),REOPJ(J)
     5             ,ESPMOP(J)
     6             ,J,ISPOS(J),ROS(J),ROSJ(J),ESPOS(J),REOS(J),REOSJ(J)
     7             ,ESPMOS(J)
 1576  FORMAT(/9X,'ION IN , PRIMARY KO(',I1,') = ',I7,2F9.4,4X
     1        ,'ENERGY = ',E10.4,' EV',2F9.4,4X,'MEAN ENERGY = ',E10.4/
     2      9X,'ION IN , SECOND. KO(',I1,') = ',I7,2F9.4,4X
     3        ,'ENERGY = ',E10.4,' EV',2F9.4,4X,'MEAN ENERGY = ',E10.4/
     4      8X,'ION OUT , PRIMARY KO(',I1,') = ',I7,2F9.4,4X
     5        ,'ENERGY = ',E10.4,' EV',2F9.4,4X,'MEAN ENERGY = ',E10.4/
     6      8X,'ION OUT , SECOND. KO(',I1,') = ',I7,2F9.4,4X
     7        ,'ENERGY = ',E10.4,' EV',2F9.4,4X,'MEAN ENERGY = ',E10.4)
 1574 CONTINUE
 1575 CONTINUE
      WRITE(21,1577)
 1577 FORMAT(/)
      DO 1580 J=1,NJ(1)
      WRITE(21,1582) J,SPY(J),J,SPE(J),J,REY(J),J,EMSP(J)
 1582 FORMAT(5X,'SPUTTERING YIELD(',I1,') = ',1PE10.3,
     1         '  SPUTTERED ENERGY(',I1,') = ',1E10.3,
     2          '  REL.MEAN ENERGY(',I1,') = ',1E10.3,
     3              '  MEAN ENERGY(',I1,') = ',1E10.3)
 1580 CONTINUE
      DO 7260 J=1,NJ(1)
      IF(IBSP(J).LE.1) GO TO 7260
      YSP=IBSP(J)
      YSPL=IBSPL(J)
      CALL MOMENTN(FIES0,SEES,THES,FOES,FIES,SIES,SIGMES
     1             ,DFIES0,DSEES,DTHES,
     2             EBSP1,EBSP2,EBSP3,EBSP4,EBSP5,EBSP6
     3             ,EBSP(J),SPE2S(J),SPE3S(J),SPE4S(J),SPE5S(J)
     4             ,SPE6S(J),YSP)
      CALL MOMENTN(FIES0L,SEESL,THESL,FOESL,FIESL,SIESL,SIGMSL
     1             ,DFIESL,DSEESL,DTHESL,
     2             EBSP1L,EBSP2L,EBSP3L,EBSP4L,EBSP5L,EBSP6L
     3             ,SPE1SL(J),SPE2SL(J),SPE3SL(J),SPE4SL(J),SPE5SL(J)
     4             ,SPE6SL(J),YSPL)
      WRITE(21,7117)
      WRITE(21,7261) J,FIES0,SEES,THES,FOES,SIGMES,DFIES0,DSEES,DTHES
 7261 FORMAT(1X,'   ENERGY(',I1,')',5X,1P1E12.4,7E14.4)
      WRITE(21,7263) J,FIES0L,SEESL,THESL,FOESL,SIGMSL
     1              ,DFIESL,DSEESL,DTHESL
 7263 FORMAT(1X,'LOGENERGY(',I1,')',5X,1P1E12.4,7E14.4)
      WRITE(21,7118)
 7118 FORMAT(/20X,' 1.MOMENT ',4X,' 2.MOMENT ',4X,' 3.MOMENT '
     1        ,4X,' 4.MOMENT ',4X,' 5.MOMENT ',4X,' 6.MOMENT ')
      WRITE(21,7265) J,EBSP1,EBSP2,EBSP3,EBSP4,EBSP5,EBSP6
 7265 FORMAT(1X,'   ENERGY(',I1,')',5X,1P1E12.4,5E14.4)
      WRITE(21,7267) J,EBSP1L,EBSP2L,EBSP3L,EBSP4L,EBSP5L,EBSP6L
 7267 FORMAT(1X,'LOGENERGY(',I1,')',5X,1P1E12.4,5E14.4)
      FIESB(J)=FIES0
      SEESB(J)=SEES
      THESB(J)=THES
      FOESB(J)=FOES
      SGMESB(J)=SIGMES
      DFIESB(J)=DFIES0
      DSEESB(J)=DSEES
      DTHESB(J)=DTHES
 7260 CONTINUE
      IF(L.EQ.1) GO TO 1593
      IF(ISPAL(2).EQ.0) GO TO 1593
      WRITE(21,1566)
 1566 FORMAT(//1X,'2.LAYER')
      DO 1568 J=NJ(1)+1,JT(3)
      WRITE(21,1570) J-NJ(1),IBSP(J),J-NJ(1),EBSP(J)
 1570 FORMAT(9X,'SPUTTERED PARTICLES(',I1,') = ',I7,5X
     1       ,'SPUTTERED ENERGY(',I1,') = ',E10.4,' EV')
 1568 CONTINUE
      DO 1586 J=NJ(1)+1,JT(3)
      WRITE(21,1576) J-NJ(1),ISPIP(J),RIP(J),RIPJ(J),ESPIP(J),REIP(J)
     1             ,REIPJ(J),ESPMIP(J)
     2             ,J-NJ(1),ISPIS(J),RIS(J),RISJ(J),ESPIS(J),REIS(J)
     3             ,REISJ(J),ESPMIS(J)
     4             ,J-NJ(1),ISPOP(J),ROP(J),ROPJ(J),ESPOP(J),REOP(J)
     5             ,REOPJ(J),ESPMOP(J)
     6             ,J-NJ(1),ISPOS(J),ROS(J),ROSJ(J),ESPOS(J),REOS(J)
     7             ,REOSJ(J),ESPMOS(J)
 1586 CONTINUE
      WRITE(21,1577)
      DO 1592 J=NJ(1)+1,JT(3)
      WRITE(21,1582) J-NJ(1),SPY(J),J,SPE(J),J,REY(J),J,EMSP(J)
 1592 CONTINUE
 1593 CONTINUE
      DO 7262 J=NJ(1)+1,JT(3)
      IF(IBSP(J).LE.1) GO TO 7262
      YSP=IBSP(J)
      CALL MOMENTS(FIES0,SEES,THES,FOES,FIES,SIES,SIGMES
     1             ,DFIES0,DSEES,DTHES,
     2             EBSP(J),SPE2S(J),SPE3S(J),SPE4S(J),SPE5S(J)
     3             ,SPE6S(J),YSP)
      WRITE(21,7117)
      WRITE(21,7261) J,FIES0,SEES,THES,FOES,SIGMES,DFIES0,DSEES,DTHES
      FIESB(J)=FIES0
      SEESB(J)=SEES
      THESB(J)=THES
      FOESB(J)=FOES
      SGMESB(J)=SIGMES
      DFIESB(J)=DFIES0
      DSEESB(J)=DSEES
      DTHESB(J)=DTHES
 7262 CONTINUE
      IF(L.EQ.2) GO TO 1532
      IF(ISPAL(3).EQ.0) GO TO 1532
      WRITE(21,1534)
 1534 FORMAT(//1X,'3.LAYER')
      DO 1536 J=JT(3)+1,LJ
      WRITE(21,1538) J-JT(3),IBSP(J),J-JT(3),EBSP(J)
 1538 FORMAT(10X,'SPUTTERED PARTICLES(',I1,') = ',I7,6X
     1       ,'SPUTTERED ENERGY(',I1,') = ',E10.4,' EV')
 1536 CONTINUE
      DO 1540 J=JT(3)+1,LJ
      WRITE(21,1576) J-JT(3),ISPIP(J),RIP(J),RIPJ(J),ESPIP(J),REIP(J)
     1             ,REIPJ(J),ESPMIP(J)
     2             ,J-JT(3),ISPIS(J),RIS(J),RISJ(J),ESPIS(J),REIS(J)
     3             ,REISJ(J),ESPMIS(J)
     4             ,J-JT(3),ISPOP(J),ROP(J),ROPJ(J),ESPOP(J),REOP(J)
     5             ,REOPJ(J),ESPMOP(J)
     6             ,J-JT(3),ISPOS(J),ROS(J),ROSJ(J),ESPOS(J),REOS(J)
     7             ,REOSJ(J),ESPMOS(J)
 1540 CONTINUE
      WRITE(21,1577)
      DO 1542 J=JT(3)+1,LJ
      WRITE(21,1582) J-JT(3),SPY(J),J-JT(3),SPE(J),J-JT(3),REY(J)
     1              ,J-JT(3),EMSP(J)
 1542 CONTINUE
 1532 CONTINUE
C
C     BACKWARD SPUTTERING : ANGULAR DISTRIBUTIONS
C
      WRITE(21,1601)
 1601 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF ALL BACKWARD ',
     1 'SPUTTERED PARTICLES'//)
cTR 1601 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF ALL BACKWARD SPUTTERED
cTR     1 PARTICLES'//)
      DO 1603 I=1,20
 1603 RKADS(I)=KADS(I)*20.D0/ISPA
      WRITE(21,1518) (AI(I),I=1,20),(KADS(I),I=1,20),(RKADS(I),I=1,20)
      DO 1602 I=1,20
      DO 1602 J=1,NJ(1)
 1602 KADSL(I,1)=KADSL(I,1)+KADSJ(I,J)
      DO 1604 I=1,20
      DO 1604 J=NJ(1)+1,JT(3)
 1604 KADSL(I,2)=KADSL(I,2)+KADSJ(I,J)
      IF(ISPAL(1).EQ.0) GO TO 1614
      IF(NJ(1).EQ.1) GO TO 1614
      WRITE(21,1606)
 1606 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED ',
     1   'PARTICLES ; LAYER 1'//)
cTR 1606 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED PARTICLES ;
cTR     1LAYER 1'//)
      DO 1608 I=1,20
 1608 RKADSL(I,1)=KADSL(I,1)*20.D0/ISPAL(1)
      WRITE(21,1518) (AI(I),I=1,20),(KADSL(I,1),I=1,20)
     1              ,(RKADSL(I,1),I=1,20)
      DO 1618 J=1,NJ(1)
      IF(IBSP(J).EQ.0) GO TO 1618
      WRITE(21,1616) J
 1616 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED ', 
     1  'PARTICLES ; LAYER 1 ; SPECIES ',I1//)
cTR 1616 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED PARTICLES ;
cTR     1LAYER 1 ; SPECIES ',I1//)
      DO 1620 I=1,20
 1620 RKADSJ(I,J)=KADSJ(I,J)*20.D0/IBSP(J)
      WRITE(21,1518) (AI(I),I=1,20),(KADSJ(I,J),I=1,20)
     1              ,(RKADSJ(I,J),I=1,20)
 1618 CONTINUE
 1614 IF(L.EQ.1) GO TO 1622
      IF(ISPAL(2).EQ.0) GO TO 1622
      WRITE(21,1610)
 1610 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED ', 
     1   'PARTICLES ; LAYER 2'//)
c 1610 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED PARTICLES ;
c     1LAYER 2'//)
      DO 1612 I=1,20
 1612 RKADSL(I,2)=KADSL(I,2)*20.D0/ISPAL(2)
      WRITE(21,1518) (AI(I),I=1,20),(KADSL(I,2),I=1,20)
     1              ,(RKADSL(I,2),I=1,20)
      IF(NJ(2).EQ.1) GO TO 1622
      DO 1624 J=NJ(1)+1,JT(3)
      IF(IBSP(J).EQ.0) GO TO 1624
      WRITE(21,1626) J-NJ(1)
 1626 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED ', 
     1  'PARTICLES ; LAYER 2 ; SPECIES ',I1//)
cTR 1626 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED PARTICLES ;
cTR     1LAYER 2 ; SPECIES ',I1//)
      DO 1628 I=1,20
 1628 RKADSJ(I,J)=KADSJ(I,J)*20.D0/IBSP(J)
      WRITE(21,1518) (AI(I),I=1,20),(KADSJ(I,J),I=1,20)
     1              ,(RKADSJ(I,J),I=1,20)
 1624 CONTINUE
 1622 CONTINUE
C
C     TRANSMISSION SPUTTERING : YIELDS AND ENERGIES
C
 1700 IF(ISPAT.EQ.0) GO TO 1800
      WRITE(21,1704)
 1704 FORMAT(1H1,5X,'TRANSMISSION SPUTTERING')
      DO 1706 J=1,NJ(1)
      ISPALT(1) = ISPALT(1)+ITSP(J)
 1706 ESPALT(1) = ESPALT(1)+ETSP(J)
      DO 1708 J=NJ(1)+1,JT(3)
      ISPALT(2) = ISPALT(2)+ITSP(J)
 1708 ESPALT(2) = ESPALT(2)+ETSP(J)
      DO 1710 J=JT(3)+1,LJ
      ISPALT(3) = ISPALT(3)+ITSP(J)
 1710 ESPALT(3) = ESPALT(3)+ETSP(J)
      WRITE(21,1712) ISPAT,ESPAT
 1712 FORMAT(///,8X,'ALL SPUTTERED PARTICLES = ',I7,3X
     1       ,'TOTAL SPUTTERED ENERGY = ',E10.4,3H EV//)
      DO 1711 J=1,L
      WRITE(21,1713) J,ISPALT(J),ESPALT(J)
 1713 FORMAT(8X,'SPUTTERED PARTICLES (LAYER ',I1,') = ',I7,3X
     1       ,'SPUTTERED ENERGY = ',E10.4,3H EV)
 1711 CONTINUE
      DO 1732 J=1,LJ
      RIPT(J)=DBLE(ISPIPT(J))/DBLE(ISPAT)
      RIST(J)=DBLE(ISPIST(J))/DBLE(ISPAT)
      ROPT(J)=DBLE(ISPOPT(J))/DBLE(ISPAT)
      ROST(J)=DBLE(ISPOST(J))/DBLE(ISPAT)
      REIPT(J)=ESPIPT(J)/ESPAT
      REIST(J)=ESPIST(J)/ESPAT
      REOPT(J)=ESPOPT(J)/ESPAT
 1732 REOST(J)=ESPOST(J)/ESPAT
 1715 CONTINUE
      DO 1717 J=1,LJ
      IF(ISPIPT(J).EQ.0) GO TO 4571
      ESPMIPT(J)=ESPIPT(J)/DBLE(ISPIPT(J))
 4571 IF(ISPIST(J).EQ.0) GO TO 4572
      ESPMIST(J)=ESPIST(J)/DBLE(ISPIST(J))
 4572 IF(ISPOPT(J).EQ.0) GO TO 4573
      ESPMOPT(J)=ESPOPT(J)/DBLE(ISPOPT(J))
 4573 IF(ISPOST(J).EQ.0) GO TO 1717
      ESPMOST(J)=ESPOST(J)/DBLE(ISPOST(J))
 1717 CONTINUE
      DO 1736 J=1,LJ
      SPYT(J)=DBLE(ITSP(J))/DBLE(NH)
 1736 SPET(J)=ETSP(J)/(NH*E0)
      DO 1737 J=1,LJ
      IF (equal(SPYT(J),0.0D0))GO TO 1737
C      IF(SPYT(J).EQ.0.0) GO TO 1737
      REYT(J)=SPET(J)/SPYT(J)
      EMSPT(J)=REYT(J)*E0
 1737 CONTINUE
      IF(ISPALT(1).EQ.0) GO TO 1719
      WRITE(21,1714)
 1714 FORMAT(//1X,'1.LAYER')
      DO 1716 J=1,NJ(1)
      WRITE(21,1564) J,ITSP(J),J,ETSP(J)
 1716 CONTINUE
      DO 1734 J=1,NJ(1)
      WRITE(21,1581) J,ISPIPT(J),RIPT(J),ESPIPT(J),REIPT(J),ESPMIPT(J)
     1             ,J,ISPIST(J),RIST(J),ESPIST(J),REIST(J),ESPMIST(J)
     2             ,J,ISPOPT(J),ROPT(J),ESPOPT(J),REOPT(J),ESPMOPT(J)
     3             ,J,ISPOST(J),ROST(J),ESPOST(J),REOST(J),ESPMOST(J)
 1734 CONTINUE
 1581  FORMAT(/9X,'ION IN , PRIMARY KO(',I1,') = ',I7,1F9.4,4X
     1        ,'ENERGY = ',E10.4,' EV',1F9.4,4X,'MEAN ENERGY = ',E10.4/
     2      9X,'ION IN , SECOND. KO(',I1,') = ',I7,1F9.4,4X
     3        ,'ENERGY = ',E10.4,' EV',1F9.4,4X,'MEAN ENERGY = ',E10.4/
     4      8X,'ION OUT , PRIMARY KO(',I1,') = ',I7,1F9.4,4X
     5        ,'ENERGY = ',E10.4,' EV',1F9.4,4X,'MEAN ENERGY = ',E10.4/
     6      8X,'ION OUT , SECOND. KO(',I1,') = ',I7,1F9.4,4X
     7        ,'ENERGY = ',E10.4,' EV',1F9.4,4X,'MEAN ENERGY = ',E10.4)
      WRITE(21,1577)
      DO 1738 J=1,NJ(1)
      WRITE(21,1582) J,SPYT(J),J,SPET(J),J,REYT(J),J,EMSPT(J)
 1738 CONTINUE
 1719 IF(L.EQ.1) GO TO 1749
      IF(ISPALT(2).EQ.0) GO TO 1744
      WRITE(21,1720)
 1720 FORMAT(/1X,'2.LAYER')
      DO 1722 J=NJ(1)+1,JT(3)
      WRITE(21,1564) J-NJ(1),ITSP(J),J-NJ(1),ETSP(J)
 1722 CONTINUE
      DO 1746 J=NJ(1)+1,JT(3)
      WRITE(21,1581) J-NJ(1),ISPIPT(J),RIPT(J),ESPIPT(J),REIPT(J)
     1             ,ESPMIPT(J)
     2             ,J-NJ(1),ISPIST(J),RIST(J),ESPIST(J),REIST(J)
     3             ,ESPMIST(J)
     4             ,J-NJ(1),ISPOPT(J),ROPT(J),ESPOPT(J),REOPT(J)
     5             ,ESPMOPT(J)
     6             ,J-NJ(1),ISPOST(J),ROST(J),ESPOST(J),REOST(J)
     7             ,ESPMOST(J)
 1746 CONTINUE
      WRITE(21,1577)
      DO 1748 J=NJ(1)+1,JT(3)
      WRITE(21,1582) J-NJ(1),SPYT(J),J-NJ(1),SPET(J),J-NJ(1),REYT(J)
     1              ,J-NJ(1),EMSPT(J)
 1748 CONTINUE
 1744 IF(L.EQ.2) GO TO 1749
      IF(ISPALT(3).EQ.0) GO TO 1749
      WRITE(21,1726)
 1726 FORMAT(/1X,'3.LAYER')
      DO 1728 J=JT(3)+1,LJ
      WRITE(21,1564) J-JT(3),ITSP(J),J-JT(3),ETSP(J)
 1728 CONTINUE
      DO 1750 J=JT(3)+1,LJ
      WRITE(21,1581) J-JT(3),ISPIPT(J),RIPT(J),ESPIPT(J),REIPT(J)
     1             ,ESPMIPT(J)
     2             ,J-JT(3),ISPIST(J),RIST(J),ESPIST(J),REIST(J)
     3             ,ESPMIST(J)
     4             ,J-JT(3),ISPOPT(J),ROPT(J),ESPOPT(J),REOPT(J)
     5             ,ESPMOPT(J)
     6             ,J-JT(3),ISPOST(J),ROST(J),ESPOST(J),REOST(J)
     7             ,ESPMOST(J)
 1750 CONTINUE
      WRITE(21,1577)
      DO 1752 J=JT(3)+1,LJ
      WRITE(21,1582) J-JT(3),SPYT(J),J-JT(3),SPET(J),J-JT(3),REYT(J)
     1              ,J-JT(3),EMSPT(J)
 1752 CONTINUE
 1749 CONTINUE
C
C     TRANSMISSION SPUTTERING : ANGULAR DISTRIBUTIONS
C
      WRITE(21,1760)
 1760 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF ALL TRANSMISSION '//
     1   'SPUTTERED PARTICLES'//)
cTR 1760 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF ALL TRANSMISSION SPUTT
cTR     1ERED PARTICLES'//)
      DO 1762 I=1,20
 1762 RKADST(I)=KADST(I)*20.D0/ISPAT
      WRITE(21,1518) (AI(I),I=1,20),(KADST(I),I=1,20),(RKADST(I),I=1,20)
      IF(L.EQ.3) GO TO 1764
      DO 1766 I=1,20
      DO 1768 J=1,NJ(1)
 1768 KDSTL(I,1)=KDSTL(I,1)+KDSTJ(I,J)
      DO 1770 J=NJ(1)+1,JT(3)
 1770 KDSTL(I,2)=KDSTL(I,2)+KDSTJ(I,J)
 1766 CONTINUE
      DO 1753 J=1,2
      IF(ISPAL(J).EQ.0) GO TO 1754
      DO 1772 I=1,20
 1772 RKDSTL(I,J)=KDSTL(I,J)*20.D0/ISPAL(J)
 1754 CONTINUE
 1753 CONTINUE
      DO 1755 J=1,JT(3)
      IF(ITSP(J).EQ.0) GO TO 1756
      DO 1774 I=1,20
 1774 RKDSTJ(I,J)=KDSTJ(I,J)*20.D0/ITSP(J)
 1756 CONTINUE
 1755 CONTINUE
      WRITE(21,1776)
 1776 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED ', 
     1  'PARTICLES ; LAYER 1'//)
cTR 1776 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED PARTICLES ;
cTR     1LAYER 1'//)
      WRITE(21,1518) (AI(I),I=1,20),(KDSTL(I,1),I=1,20)
     1              ,(RKDSTL(I,1),I=1,20)
      IF(NJ(1).EQ.1) GO TO 1778
      DO 1780 J=1,NJ(1)
      IF(ITSP(J).EQ.0) GO TO 1780
      WRITE(21,1782) J
 1782 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED ', 
     1  'PARTICLES ; LAYER 1 , SPECIES ',I1//)
cTR 1782 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED PARTICLES ;
cTR     1LAYER 1 , SPECIES ',I1//)
      WRITE(21,1518) (AI(I),I=1,20),(KDSTJ(I,J),I=1,20)
     1              ,(RKDSTJ(I,J),I=1,20)
 1780 CONTINUE
 1778 IF(L.EQ.1) GO TO 1800
      WRITE(21,1786)
 1786 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED ', 
     1   'PARTICLES ; LAYER 2'//)
cTR 1786 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED PARTICLES ;
cTR     1LAYER 2'//)
      WRITE(21,1518) (AI(I),I=1,20),(KDSTL(I,2),I=1,20)
     1              ,(RKDSTL(I,2),I=1,20)
      IF(NJ(2).EQ.1) GO TO 1800
      DO 1788 J=NJ(1)+1,JT(3)
      WRITE(21,1790) J-NJ(1)
 1790 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED ', 
     1  'PARTICLES ; LAYER 2 , SPECIES ',I1//)
cTR 1790 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED PARTICLES ;
cTR     1LAYER 2 , SPECIES ',I1//)
      WRITE(21,1518) (AI(I),I=1,20),(KDSTJ(I,J),I=1,20)
     1              ,(RKDSTJ(I,J),I=1,20)
 1788 CONTINUE
      GO TO 1800
 1764 DO 1761 I=1,20
      DO 1763 J=1,NJ(2)
 1763 KDSTL(I,1)=KDSTL(I,1)+KDSTJ(I,J)
      DO 1765 J=NJ(2)+1,LJ-NJ(1)
 1765 KDSTL(I,2)=KDSTL(I,2)+KDSTJ(I,J)
 1761 CONTINUE
      DO 1799 J=1,2
      IF(ISPALT(J+1).EQ.0) GO TO 1799
      DO 1767 I=1,20
 1767 RKDSTL(I,J)=KDSTL(I,J)*20.D0/ISPALT(J+1)
 1799 CONTINUE
      DO 1797 J=1,LJ-NJ(1)
      IF(ITSP(J+NJ(1)).EQ.0) GO TO 1797
      DO 1769 I=1,20
 1769 RKDSTJ(I,J)=KDSTJ(I,J)*20.D0/ITSP(J+NJ(1))
 1797 CONTINUE
      WRITE(21,1771)
 1771 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED ', 
     1  'PARTICLES ; LAYER 2'//)
cTR 1771 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED PARTICLES ;
cTR     1LAYER 2'//)
      WRITE(21,1518) (AI(I),I=1,20),(KDSTL(I,1),I=1,20)
     1              ,(RKDSTL(I,1),I=1,20)
      IF(NJ(2).EQ.1) GO TO 1773
      DO 1775 J=1,NJ(2)
      IF(ITSP(J+NJ(1)).EQ.0) GO TO 1775
      WRITE(21,1777) J
 1777 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED ', 
     1  'PARTICLES ; LAYER 2 ; SPECIES ',I1//)
cTR 1777 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED PARTICLES ;
cTR     1LAYER 2 ; SPECIES ',I1//)
      WRITE(21,1518) (AI(I),I=1,20),(KDSTJ(I,J),I=1,20)
     1              ,(RKDSTJ(I,J),I=1,20)
 1775 CONTINUE
 1773 CONTINUE
      WRITE(21,1779)
 1779 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED ', 
     1  'PARTICLES ; LAYER 3'//)
cTR 1779 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED PARTICLES ;
cTR     1LAYER 3'//)
      WRITE(21,1518) (AI(I),I=1,20),(KDSTL(I,2),I=1,20)
     1              ,(RKDSTL(I,2),I=1,20)
      IF(NJ(2).EQ.1) GO TO 1800
      DO 1781 J=NJ(2)+1,LJ-NJ(1)
      WRITE(21,1783) J-NJ(2)
 1783 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED ', 
     1  'PARTICLES ; LAYER 3 ; SPECIES ',I1//)
cTR 1783 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED PARTICLES ;
cTR     1LAYER 3 ; SPECIES ',I1//)
      WRITE(21,1518) (AI(I),I=1,20),(KDSTJ(I,J),I=1,20)
     1              ,(RKDSTJ(I,J),I=1,20)
 1781 CONTINUE
 1800 CONTINUE
c 
c hier wird der File for33 erzeugt
c
        DO i=1,100
                READ(33,'(A246)',ERR=7800,END=7800)COLUMN(i)
        ENDDO
 7800 COLCOUNT=i-1
        CLOSE(33,STATUS='DELETE')
        WRITE(33,7802)  
 7802 FORMAT(6x,'Energy',4x,'SigmaE',5x,'Alpha',2x,'SigAlpha',4x,'ntot',
     1   5x,'imp',2x,'backsc',3x,'trans',3x,'tried',4x,'negE',3x,
     2   'impL1',3x,'impL2',3x,'impL3',3x,'impL4',3x,'impL5',3x,'impL6',
     3   3x,'impL7',3x,
     4   'range',6x,'straggeling',2x,
     5   'Eback',7x,'sigEback',4x,'Etrans',6x,'SigEtrans',3x,
     6   'red. E',6x,'PRC')
        DO i=2,COLCOUNT
                WRITE(33,'(A246)')COLUMN(i)
        ENDDO
        IF(l.EQ.1) THEN
            number_in_layer(1)=IIM
            DO k=2,7
                number_in_layer(k)=0
                ENDDO           
        ELSEIF(l.EQ.2) THEN
            DO k=3,7
                number_in_layer(k)=0
                ENDDO           
        ELSEIF(l.EQ.3) THEN
            DO k=4,7
                number_in_layer(k)=0
                ENDDO           
        ELSEIF(l.EQ.4) THEN
            DO k=5,7
                number_in_layer(k)=0
                ENDDO           
        ELSEIF(l.EQ.5) THEN
            DO k=6,7
                number_in_layer(k)=0
                ENDDO           
        ELSEIF(l.EQ.6) THEN
                number_in_layer(7)=0
        ENDIF
        WRITE(33,7801)E0keV,EsigkeV,ALPHA,ALPHASIG,
     1              NH,IIM,IB,IT,tryE,negE,
     2              (number_in_layer(k),k=1,7),     
     3              FIX0,SIGMAX,FIB0,SIGMAB,FIT0,SIGMAT,epsilon,prcoeff
 7801 FORMAT(F12.2,3(1x,F9.2),1x,13(I7,1x),6(E12.4),2(E12.4))
      CLOSE(33)
c
c hier endet File for33
C
C     TOP AND FRONT LINES FOR MATRICES
C
      JE=DE
      JA=DA
      JG=DG
      DO 32 J=2,NG1
      MAGB(J,1) = (J-1)*JG
      MAGT(J,1) = (J-1)*JG
      EMA(J,1)=DBLE(J-1)*DG
      EMAT(J,1)=DBLE(J-1)*DG
   32 CONTINUE
      DO 77 J=2,21
      MEAB(1,J) = J-1
      MEAT(1,J) = J-1
      MAGB(1,J) = J-1
      MAGT(1,J) = J-1
      EMA(1,J)  = J-1
      EMAT(1,J) = J-1
   77 CONTINUE
      DO 1828 J=2,101
      MEAB(J,1) = J-1
      MEAT(J,1) = J-1
      MEPB(J,1) = J-1
      MEPB(1,J) = J-1
      MEPT(J,1) = J-1
      MEPT(1,J) = J-1
 1828 CONTINUE
      DO 1830 K=1,JT(3)
      DO 1832 J=2,NG1
      MAGS(J,1,K) = (J-1)*JG
      MAGST(J,1,K) = (J-1)*JG
      MAGSA(J,1,K) = (J-1)*JG
 1832 CONTINUE
      DO 1826 J=2,NA1
      MAGSA(1,J,K) = (J-1)*JA
 1826 CONTINUE
      DO 1834 J=2,21
      MEAS(1,J,K) = J-1
      MEAST(1,J,K) = J-1
      MAGS(1,J,K) = J-1
      MAGST(1,J,K) = J-1
 1834 CONTINUE
      DO 1836 J=2,101
      MEAS(J,1,K) = J-1
      MEAST(J,1,K) = J-1
 1836 CONTINUE
      DO 1838 J=1,20
      MEASL(1,J,K)=J
      MEASTL(1,J,K)=J
 1838 CONTINUE
      DO 1841 IG2=1,NGIK,1
      DO 1843 J=2,21
      MEAGS(1,IG2,J,K) = J-1
 1843 CONTINUE
      DO 1845 J=2,101
      MEAGS(J,IG2,1,K) = J-1
 1845 CONTINUE
 1841 CONTINUE
 1830 CONTINUE
      DO 1840 IG2=1,NGIK,1
      DO 1842 J=2,21
      MEAGB(1,IG2,J) = J-1
 1842 MEAGT(1,IG2,J) = J-1
      DO 1844 J=2,101
      MEAGB(J,IG2,1) = J-1
 1844 MEAGT(J,IG2,1) = J-1
 1840 CONTINUE
      DO 1846 I=2,74
 1846 ELOG(I)=10.D0**(I/12.D0)*10.D0**(-7.D0/6.D0)
      TEMP=(10.D0**(1.D0/12.D0)-1.D0)*10.D0**(-7.D0/6.D0)
      TEMPNH=TEMP*DBLE(NH)
C
C     BACKWARD SPUTTERING : MATRICES , ENERGY - ANGLE CORRELATIONS
C
      IF(ISPA.LT.10000) GO TO 1900
      DO 1850 J=1,JT(3)
      EASL(2,J)=DBLE(MEASL(2,21,J))/(DBLE(NH)*0.1)
      DO 1850 IESLOG=3,74
 1850 EASL(IESLOG,J)=DBLE(MEASL(IESLOG,21,J))/(TEMPNH*
     1               10.D0**((IESLOG-1)/12.D0))
      DO 1852 J=1,NJ(1)
      WRITE(21,1854) J
 1854 FORMAT(//,' LOG ENERGY - COS OF EMISSION ANGLE (0.05 STEPS)   (BAC
     1KWARD SPUTTERED PARTICLES) ; 1. LAYER ; SPECIES',I2/)
            do ima = 74,2,-1
              if(measl(ima,21,j).ne.0) goto 1855
            enddo
            ima = 1
 1855       ima = min(ima+2,74)
            do ies = 1, ima
               write (6, 1858) elog(ies), (measl(ies,ias,j),ias=1,21),
     1            easl(ies,j)
            end do
               write (6, 1858) elog(75), (measl(75,ias,j),ias=1,21),
     1            easl(75,j)
c     DO 1856 IES=1,75
c1856 WRITE(6,1858) ELOG(IES),(MEASL(IES,IAS,J),IAS=1,21),EASL(IES,J)
 1858 FORMAT(1X,1E12.4,20I5,I6,1E12.4)
      WRITE(21,1884) J
 1884 FORMAT(//,' ENERGY(E/E0 IN %) - ', 
     1    'POLAR ANGLE IN COS-INTERVALS (0.05)  ', 
     2    '(BACKWARD SPUTTERED PARTICLES) , 1.LAYER , SPECIES',I2/)
cTR 1884 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS (0.05
cTR     1)  (BACKWARD SPUTTERED PARTICLES) , 1.LAYER , SPECIES',I2/)
                  do ima = 101,1,-1
                    if(meas(ima,22,j).ne.0) goto 1883
                  enddo
                  ima = 1
 1883             ima = min(ima+2,101)
            write (6, 1886) ((meas(iesp,iags,j),iags=1,22),iesp=1,ima)
            write (6, 1886) (meas(102,iags,j),iags=1,22)
 1886 FORMAT(1X,I3,20I6,I8)
c     WRITE(6,1886) ((MEAS(IESP,IAGS,J),IAGS=1,22),IESP=1,102)
c1886 FORMAT(1X,21I5,I7)
      IF(ALPHA.LT.1.) GO TO 1878
       DO 1870 IG2=1,NGIK,1
       EEE = IG2*DGI
       WRITE(21,1872) EEE,J
 1872 FORMAT(//,' ENERGY(E/E0 IN %) - ', 
     &   'POLAR ANGLE IN COS-INTERVALS (0.05) ', 
     1   'AT AZIMUTHAL ANGLE =',F5.1,
     2   ' (BACKWARD SPUTTERED ATOMS) , 1.LAYER , SPECIES',I2/)
cTR 1872 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS (0.05
cTR     1) AT AZIMUTHAL ANGLE =',F5.1,' (BACKWARD SPUTTERED ATOMS) , 1.LAYE
CTR     2R , SPECIES',I2/)
                  do ima = 101,1,-1
                    if(meags(ima,ig2,22,j).ne.0) goto 1885
                  enddo
                  ima = 1
 1885             ima = min(ima+2,101)
                  do iesp = 1, ima
                     write (6, 1886) (meags(iesp,ig2,iags,j),iags=1,22)
                  end do
                     write (6, 1886) (meags(102,ig2,iags,j),iags=1,22)
c      DO 1870 IE=1,102
c      WRITE(6,1886) (MEAGS(IE,IG2,IAGS,J),IAGS=1,22)
 1870 CONTINUE
      WRITE(21,1889) J
 1889 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN DEGREES     ', 
     1  '(BACKWARD SPUTTERED PARTICLES) , 1.LAYER , SPECIES',I2/)
c 1889 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN DEGREES     (BACKWARD
c     1 SPUTTERED PARTICLES) , 1.LAYER , SPECIES',I2/)
      WRITE(21,1887) ((MAGSA(IG,IA,J),IA=1,32),IG=1,62)
 1887 FORMAT(1X,31I4,I6)
 1878 CONTINUE
      WRITE(21,1888) J
 1888 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS ', 
     &  '(0.05) ', 
     1  ' (BACKWARD SPUTTERED PARTICLES) , 1.LAYER , SPECIES',I2/)
      WRITE(21,1886) ((MAGS(IG,IAGS,J),IAGS=1,22),IG=1,62)
cTR 1888 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS (0.05)
cTR     1 (BACKWARD SPUTTERED PARTICLES) , 1.LAYER , SPECIES',I2/)
cTR      WRITE(21,1886) ((MAGS(IG,IAGS,J),IAGS=1,22),IG=1,62)
 1852 CONTINUE
      IF(L.EQ.1) GO TO 1900
      if(ispal(2).eq.0) goto 1900
      DO 1862 J=NJ(1)+1,JT(3)
      WRITE(21,1864) J-NJ(1)
 1864 FORMAT(//,' LOG ENERGY - COS OF EMISSION ANGLE (0.05 STEPS)   ', 
     1  '(BACKWARD SPUTTERED PARTICLES) , 2. LAYER , SPECIES',I2/)
cTR 1864 FORMAT(//,' LOG ENERGY - COS OF EMISSION ANGLE (0.05 STEPS)   (BAC
cTR     1KWARD SPUTTERED PARTICLES) , 2. LAYER , SPECIES',I2/)
                do ima = 74,1,-1
                  if(measl(ima,21,j).ne.0) goto 1865
                enddo
                ima = 1
 1865          ima = min(ima+2,74)
               do ies = 1, ima
                  write (6, 1858) elog(ies), (measl(ies,ias,j),ias=1,21)
     1               , easl(ies,j)
               end do
                  write (6, 1858) elog(75), (measl(75,ias,j),ias=1,21)
     1               , easl(75,j)
c     DO 1866 IES=1,75
c1866 WRITE(6,1858) ELOG(IES),(MEASL(IES,IAS,J),IAS=1,21),EASL(IES,J)
      WRITE(21,1894) J-NJ(1)
 1894 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS ', 
     1  '(0.05)  (BACKWARD SPUTTERED PARTICLES) , 2.LAYER , SPECIES',
     2   I2/)
cTR 1894 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS (0.05
cTR     1)  (BACKWARD SPUTTERED PARTICLES) , 2.LAYER , SPECIES',I2/)
                  do ima = 101,1,-1
                    if(meas(ima,22,j).ne.0) goto 1895
                  enddo
                  ima = 1
 1895             ima = min(ima+2,101)
               WRITE(21,1886)((meas(iesp,iags,j),iags=1,22),iesp=1,ima)
               WRITE(21,1886)(meas(102,iags,j),iags=1,22)
c     WRITE(6,1886) ((MEAS(IESP,IAGS,J),IAGS=1,22),IESP=1,102)
      WRITE(21,1898) J-NJ(1)
 1898 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS ', 
     &  '(0.05) ', 
     1  ' (BACKWARD SPUTTERED PARTICLES) , 2.LAYER , SPECIES',I2/)
cTR 1898 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS (0.05)
cTR     1 (BACKWARD SPUTTERED PARTICLES) , 2.LAYER , SPECIES',I2/)
      WRITE(21,1886) ((MAGS(IG,IAGS,J),IAGS=1,22),IG=1,62)
 1862 CONTINUE
 1900 CONTINUE
C
C     FORWARD SPUTTERING : MATRICES , ENERGY - ANGLE CORRELATIONS
C
      IF(ISPAT.LT.10000) GO TO 2000
      JTJ=JT(3)
      IF(L.EQ.3) JTJ=LJ-NJ(1)
      DO 1950 J=1,JTJ
      EASTL(2,J)=DBLE(MEASTL(2,21,J))/(DBLE(NH)*0.1D0)
      DO 1950 IESLOG=3,74
 1950 EASTL(IESLOG,J)=DBLE(MEASTL(IESLOG,21,J))/(TEMPNH*
     1               10.D0**((IESLOG-1)/12.D0))
      IF(L.EQ.3) GO TO 1953
      DO 1952 J=1,NJ(1)
      WRITE(21,1954) J
 1954 FORMAT(//,' LOG ENERGY - COS OF EMISSION ANGLE (0.05 STEPS)   ', 
     &   '(FORWARD SPUTTERED PARTICLES) ', 
     1   ', 1. LAYER , SPECIES',I2/)
cTR 1954 FORMAT(//,' LOG ENERGY - COS OF EMISSION ANGLE (0.05 STEPS)   (FOR
cTR     1WARD SPUTTERED PARTICLES) , 1. LAYER , SPECIES',I2/)
            do ima = 74,2,-1
              if(meastl(ima,21,j).ne.0) goto 1955
            enddo
            ima = 1
 1955       ima = min(ima+2,74)
            do ies = 1, ima
               write (6, 1858) elog(ies), (meastl(ies,ias,j),ias=1,21),
     1            eastl(ies,j)
            end do
               write (6, 1858) elog(75), (meastl(75,ias,j),ias=1,21),
     1            eastl(75,j)
c     DO 1956 IES=1,75
c1956 WRITE(6,1858) ELOG(IES),(MEASTL(IES,IAS,J),IAS=1,21),EASTL(IES,J)
      WRITE(21,1984) J
 1984 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS ', 
     &  '(0.05)  ',
     1  '(FORWARD SPUTTERED PARTICLES) , 1.LAYER , SPECIES',I2/)
cTR 1984 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS (0.05
cTR     1)  (FORWARD SPUTTERED PARTICLES) , 1.LAYER , SPECIES',I2/)
                  do ima = 101,1,-1
                    if(meast(ima,22,j).ne.0) goto 1983
                  enddo
                  ima = 1
 1983             ima = min(ima+2,101)
            write (6, 1886) ((meast(iesp,iags,j),iags=1,22),iesp=1,ima)
            write (6, 1886) (meast(102,iags,j),iags=1,22)
c     WRITE(6,1886) ((MEAST(IESP,IAGS,J),IAGS=1,22),IESP=1,102)
      WRITE(21,1988) J
 1988 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS ', 
     &  '(0.05) ', 
     1  ' (FORWARD SPUTTERED PARTICLES) , 1.LAYER , SPECIES',I2/)
cTR 1988 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS (0.05)
cTR     1 (FORWARD SPUTTERED PARTICLES) , 1.LAYER , SPECIES',I2/)
      WRITE(21,1886) ((MAGST(IG,IAGS,J),IAGS=1,22),IG=1,62)
 1952 CONTINUE
 1953 CONTINUE
      IF(L.EQ.1) GO TO 2000
      IF(L.EQ.3) GO TO 1961
      JTK=NJ(1)+1
      JTL=JT(3)
      GO TO 1963
 1961 JTK=1
      JTL=NJ(2)
 1963 DO 1962 J=JTK,JTL
      WRITE(21,1964) J-JTK+1
 1964 FORMAT(//,' LOG ENERGY - COS OF EMISSION ANGLE (0.05 STEPS)   ', 
     & '(FORWARD SPUTTERED PARTICLES) ,', 
     1 ' 2. LAYER , SPECIES',I2/)
cTR 1964 FORMAT(//,' LOG ENERGY - COS OF EMISSION ANGLE (0.05 STEPS)   (FOR
cTR     1WARD SPUTTERED PARTICLES) , 2. LAYER , SPECIES',I2/)
               do ima = 74,1,-1
                 if(meastl(ima,21,j).ne.0) goto 1965
               enddo
               ima = 1
 1965         ima = min(ima+2,74)
              do ies = 1, ima
                 write (6, 1858) elog(ies), (meastl(ies,ias,j),ias=1,21)
     1              , eastl(ies,j)
              end do
                 write (6, 1858) elog(75), (meastl(75,ias,j),ias=1,21)
     1              , eastl(75,j)
c     DO 1966 IES=1,75
c1966 WRITE(6,1858) ELOG(IES),(MEASTL(IES,IAS,J),IAS=1,21),EASTL(IES,J)
      WRITE(21,1994) J-JTK+1
 1994 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS ', 
     1  '(0.05)  (FORWARD SPUTTERED PARTICLES) , 2.LAYER , SPECIES',I2/)
cTR 1994 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS (0.05
cTR     1)  (FORWARD SPUTTERED PARTICLES) , 2.LAYER , SPECIES',I2/)
                  do ima = 101,1,-1
                    if(meast(ima,22,j).ne.0) goto 1995
                  enddo
                  ima = 1
 1995             ima = min(ima+2,101)
               WRITE(21,1886)((meast(iesp,iags,j),iags=1,22),iesp=1,ima)
               WRITE(21,1886)(meast(102,iags,j),iags=1,22)
c     WRITE(6,1886) ((MEAST(IESP,IAGS,J),IAGS=1,22),IESP=1,102)
      WRITE(21,1998) J-JTK+1
 1998 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS ', 
     1 '(0.05)  (FORWARD SPUTTERED PARTICLES) , 2.LAYER , SPECIES',I2/)
cTR 1998 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS (0.05)
cTR     1 (FORWARD SPUTTERED PARTICLES) , 2.LAYER , SPECIES',I2/)
      WRITE(21,1886) ((MAGST(IG,IAGS,J),IAGS=1,22),IG=1,62)
 1962 CONTINUE
      IF(L.LT.3) GO TO 2000
      DO 1972 J=NJ(2)+1,LJ-NJ(1)
      WRITE(21,1974) J-NJ(2)
 1974 FORMAT(//,' LOG ENERGY - COS OF EMISSION ANGLE (0.05 STEPS)   ', 
     1  '(FORWARD SPUTTERED PARTICLES) , 3. LAYER , SPECIES',I2/)
cTR 1974 FORMAT(//,' LOG ENERGY - COS OF EMISSION ANGLE (0.05 STEPS)   (FOR
cTR     1WARD SPUTTERED PARTICLES) , 3. LAYER , SPECIES',I2/)
               do ima = 74,1,-1
                 if(meastl(ima,21,j).ne.0) goto 1973
               enddo
               ima = 1
 1973         ima = min(ima+2,74)
              do ies = 1, ima
                 write (6, 1858) elog(ies), (meastl(ies,ias,j),ias=1,21)
     1              , eastl(ies,j)
              end do
                 write (6, 1858) elog(75), (meastl(75,ias,j),ias=1,21)
     1              , eastl(75,j)
c     DO 1976 IES=1,75
c1976 WRITE(6,1858) ELOG(IES),(MEASTL(IES,IAS,J),IAS=1,21),EASTL(IES,J)
      WRITE(21,1975) J-NJ(2)
 1975 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS ', 
     1  '(0.05)  (FORWARD SPUTTERED PARTICLES) , 3.LAYER , SPECIES',I2/)
cTR 1975 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS (0.05
cTR     1)  (FORWARD SPUTTERED PARTICLES) , 3.LAYER , SPECIES',I2/)
                  do ima = 101,1,-1
                    if(meast(ima,22,j).ne.0) goto 1977
                  enddo
                  ima = 1
 1977             ima = min(ima+2,101)
               WRITE(21,1886)((meast(iesp,iags,j),iags=1,22),iesp=1,ima)
               WRITE(21,1886)(meast(102,iags,j),iags=1,22)
c     WRITE(6,1886) ((MEAST(IESP,IAGS,J),IAGS=1,22),IESP=1,102)
      WRITE(21,1978) J-NJ(2)
 1978 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS ', 
     1 '(0.05)  (FORWARD SPUTTERED PARTICLES) , 3.LAYER , SPECIES',I2/)
cTR 1978 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS (0.05)
cTR     1 (FORWARD SPUTTERED PARTICLES) , 3.LAYER , SPECIES',I2/)
      WRITE(21,1886) ((MAGST(IG,IAGS,J),IAGS=1,22),IG=1,62)
 1972 CONTINUE
C      DO 34 IG2=1,NGIK,1
C      EEE = IG2*DGI
C      WRITE(6,912) EEE
C 912 FORMAT(1H1,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS (0.0
C    15) AT AZIMUTHAL ANGLE =',F5.1,' (SPUTTERED ATOMS)'//)
C      DO 42 IE=2,101
C  42  MEAGS(102,IG2,22) = MEAGS(102,IG2,22)+MEAGS(IE,IG2,22)
C      DO 34 IE=1,102
C      WRITE(6,980) (MEAGS(IE,IG2,IAGS),IAGS=1,22)
C  34 CONTINUE
C     IF(ALPHA.LT.1.) GO TO 8009
C      DO 8001 IG3=1,NGIK,1
C      EE1 = IG3*DGI
C      WRITE(6,8002) EE1
C8002 FORMAT(1H1,' LOG ENERGY - POLAR ANGLE IN COS-INTERVALS (0.05)  AT
C    1 AZIMUTHAL ANGLE =',F5.1,' (SPUTTERED ATOMS)'//)
C     DO 8003 J=1,20
C8003 MEAGSL(1,IG3,J)=J
C     IF(MEAGS(102,IG3,22).EQ.0) MEAGS(102,IG3,22)=1
C     EAGSL(2)=DFLOAT(MEAGSL(2,IG3,21))/(DFLOAT(MEAGS(102,IG3,22))*0.1)
C     DO 8004 IESLOG=3,74
C8004 EAGSL(IESLOG)=DFLOAT(MEAGSL(IESLOG,IG3,21))/(DFLOAT(MEAGS(102,IG3,22
C    ?))*TEMP*10.**((IESLOG-1)/12.))
C      DO 8005 IES=1,75
C8005 WRITE(6,8600) ELOG(IES),(MEAGSL(IES,IG3,IAS),IAS=1,21),EAGSL(IES)
C8001 CONTINUE
 2000 CONTINUE
C
C     BACKSCATTERING : MATRICES , ENERGY - ANGULAR CORRELATIONS
C
      IF(IB.LT.10000) GO TO 2100
      DO 2002 J=1,20
 2002 MEABL(1,J)=J
      EABL(2)=DBLE(MEABL(2,21))/(DBLE(NH)*0.1D0)
      DO 2004 IERLOG=3,74
 2004 EABL(IERLOG)=DBLE(MEABL(IERLOG,21))/(TEMPNH*
     #10.D0**((IERLOG-1)/12.D0))
      WRITE(21,2006)
 2006 FORMAT(//,' LOG ENERGY - COS OF EMISSION ANGLE (0.05 STEPS)   ', 
     1  '(BACKSCATTERED PROJECTILES)'/)
cTR 2006 FORMAT(//,' LOG ENERGY - COS OF EMISSION ANGLE (0.05 STEPS)   (BAC
cTR     1KSCATTERED PROJECTILES)'/)
            do ima = 74,1,-1
              if(meabl(ima,21).ne.0) goto 2005
            enddo
            ima = 1
 2005       ima = min(ima+2,74)
          do ies = 1, ima
            WRITE(21,1858)elog(ies),(meabl(ies,iag),iag=1,21),eabl(ies)
         end do
            WRITE(21,1858)elog(75),(meabl(75,iag),iag=1,21),eabl(75)
c     DO 2008 IES=1,75
c2008 WRITE(6,1858) ELOG(IES),(MEABL(IES,IAG),IAG=1,21),EABL(IES)
      IF(ALPHA.LT.1.) GO TO 2010
      DO 2012 IG2=1,NGIK,1
      EEE = IG2*DGI
      WRITE(21,2014) EEE
 2014 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS ', 
     1  '(0.05) AT AZIMUTHAL ANGLE =',F5.1,
     2  ' (BACKSCATTERED PROJECTILES)'/)
cTR 2014 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS (0.05
cTR     1) AT AZIMUTHAL ANGLE =',F5.1,' (BACKSCATTERED PROJECTILES)'/)
                  do ima = 101,1,-1
                    if(meagb(ima,ig2,22).ne.0) goto 2015
                  enddo
                  ima = 1
 2015             ima = min(ima+2,101)
               write (6, 1886) ((meagb(ie,ig2,iagb),iagb=1,22),ie=1,ima)
               write (6, 1886) (meagb(102,ig2,iagb),iagb=1,22)
c2012 WRITE(6,1886) ((MEAGB(IE,IG2,IAGB),IAGB=1,22),IE=1,102)
 2012 continue
 2010 CONTINUE
      IF(E0.LT.0.) GO TO 2052
      WRITE(21,2016)
 2016 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS ', 
     1  '(0.05)  (BACKSCATTERED PROJECTILES)'/)
cTR 2016 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS (0.05
cTR     1)  (BACKSCATTERED PROJECTILES)'/)
      GO TO 2054
 2052 WRITE(21,2056)
 2056 FORMAT(//,' ENERGY(E IN 0.1*TI) - POLAR ANGLE IN COS-INTERVALS ', 
     1  '(0.05)  (BACKSCATTERED PROJECTILES)'/)
cTR 2056 FORMAT(//,' ENERGY(E IN 0.1*TI) - POLAR ANGLE IN COS-INTERVALS (0.
cTR     105)  (BACKSCATTERED PROJECTILES)'/)
                  do ima = 101,1,-1
                    if(meab(ima,22).ne.0) goto 2017
                  enddo
                  ima = 1
 2017             ima = min(ima+2,101)
          write (6, 1886) ((meab(ie,iagb),iagb=1,22),ie=1,ima)
          write (6, 1886) (meab(102,iagb),iagb=1,22)
c2054 WRITE(6,1886) ((MEAB(IE,IAGB),IAGB=1,22),IE=1,NE)
 2054 continue
      WRITE(21,2018)
 2018 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS ', 
     1  '(0.05)  (BACKSCATTERED PROJECTILES)'/)
cTR 2018 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS (0.05)
cTR     1 (BACKSCATTERED PROJECTILES)'/)
      WRITE(21,1886) ((MAGB(IG,IAGB),IAGB=1,22),IG=1,62)
      WRITE(21,2022)
 2022 FORMAT(//,' AZIMUTH.ANGLE - POLAR ANGLE IN COS-INTERVALS ', 
     1 '(0.05)   (BACKSCATTERED ENERGY)'/)
cTR 2022 FORMAT(//,' AZIMUTH.ANGLE - POLAR ANGLE IN COS-INTERVALS (0.05)
cTR     1 (BACKSCATTERED ENERGY)'/)
      WRITE(21,2027)  (EMA(01,IAGB),IAGB=1,11)
      WRITE(21,2025) ((EMA(IG,IAGB),IAGB=1,11),IG=2,NG)
      WRITE(21,2028)
      WRITE(21,2031)   EMA(1,1),(EMA(1,IAGB),IAGB=12,22)
      DO 2029 IG=2,NG
      WRITE(21,2026)  EMA(IG,1),(EMA(IG,IAGB),IAGB=12,22)
 2029 CONTINUE
 2025 FORMAT(1X,1F5.0,10E11.4)
 2026 FORMAT(1X,1F5.0,11E11.4)
 2027 FORMAT(1X,1F5.0,10F11.0)
 2028 FORMAT(/)
 2031 FORMAT(1H1,1X,1F5.0,11F11.0)
C     IF(E0.LT.0.) GO TO 2058
C     WRITE(6,2032)
C2032 FORMAT(1H1,1X,'ENERGY(IN % OF E0) - PATHLENGTH(IN UNITS OF CW)
C    1 (BACKSCATTERED PROJECTILES)'/)
C     GO TO 2060
C2058 WRITE(6,2062)
C2062 FORMAT(1H1,1X,'ENERGY(E IN 0.1*TI) - PATHLENGTH(IN UNITS OF CW)
C    1 (BACKSCATTERED PROJECTILES)'/)
C2060 DO 2034 II=1,3
C     INE=II*25+1
C     INA=INE-24
C     DO 2040 IE=1,NE
C     WRITE(6,2036) MEPB(IE,1),(MEPB(IE,IPB),IPB=INA,INE)
C2040 CONTINUE
C     WRITE(6,2028)
C2034 CONTINUE
C     DO 2042 IE=1,NE
C     WRITE(6,2038) MEPB(IE,1),(MEPB(IE,IPB),IPB=77,102)
C2042 CONTINUE
 2036 FORMAT(1X,26I4)
 2038 FORMAT(1X,26I4,I6)
 2100 CONTINUE
C
C     TRANSMISSION : MATRICES , ENERGY - ANGULAR CORRELATIONS
C
      IF(IT.LT.10000) GO TO 9000
      DO 2102 J=1,20
 2102 MEATL(1,J)=J
      EATL(2)=DBLE(MEATL(2,21))/(DBLE(NH)*0.1D0)
      DO 2104 IERLOG=3,74
 2104 EATL(IERLOG)=DBLE(MEATL(IERLOG,21))/(TEMPNH*
     1              10.D0**((IERLOG-1)/12.D0))
      WRITE(21,2106)
 2106 FORMAT(//,' LOG ENERGY - COS OF EMISSION ANGLE (0.05 STEPS)   ', 
     1  '(TRANSMITTED PROJECTILES)'/)
cTR 2106 FORMAT(//,' LOG ENERGY - COS OF EMISSION ANGLE (0.05 STEPS)   (TRA
cTR     1NSMITTED PROJECTILES)'/)
            do ima = 74,1,-1
              if(meatl(ima,21).ne.0) goto 2105
            enddo
            ima = 1
 2105       ima = min(ima+2,74)
          do ies = 1, ima
            WRITE(21,1858)elog(ies),(meatl(ies,iag),iag=1,21),eatl(ies)
         end do
            WRITE(21,1858)elog(75),(meatl(75,iag),iag=1,21),eatl(75)
c     DO 2108 IES=1,75
c2108 WRITE(21,1858) ELOG(IES),(MEATL(IES,IAG),IAG=1,21),EATL(IES)
      IF(ALPHA.LT.1.) GO TO 2110
      DO 2112 IG2=1,NGIK,1
      EEE = IG2*DGI
      WRITE(21,2114) EEE
 2114 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS ', 
     1  '(0.05) AT AZIMUTHAL ANGLE =',F5.1,
     2  ' (TRANSMITTED  PROJECTILES)'/)
cTR 2114 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS (0.05
cTR     1) AT AZIMUTHAL ANGLE =',F5.1,' (TRANSMITTED  PROJECTILES)'/)
                  do ima = 101,1,-1
                    if(meagt(ima,ig2,22).ne.0) goto 2115
                  enddo
                  ima = 1
 2115             ima = min(ima+2,101)
               write (21,1886) ((meagt(ie,ig2,iagb),iagb=1,22),ie=1,ima)
               write (21,1886) (meagt(102,ig2,iagb),iagb=1,22)
c2112 WRITE(6,1886) ((MEAGT(IE,IG2,IAGB),IAGB=1,22),IE=1,102)
 2112 continue
 2110 CONTINUE
      WRITE(21,2116)
 2116 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS ', 
     1  '(0.05)  (TRANSMITTED PROJECTILES)'/)
cTR 2116 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS (0.05
cTR     1)  (TRANSMITTED PROJECTILES)'/)
                  do ima = 101,1,-1
                    if(meat(ima,22).ne.0) goto 2117
                  enddo
                  ima = 1
 2117             ima = min(ima+2,101)
          write (6, 1886) ((meat(ie,iagb),iagb=1,22),ie=1,ima)
          write (6, 1886) (meat(102,iagb),iagb=1,22)
c     WRITE(6,1886) ((MEAT(IE,IAGB),IAGB=1,22),IE=1,NE)
      WRITE(21,2118)
 2118 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS ', 
     1  '(0.05)  (TRANSMITTED PROJECTILES)'/)
cTR 2118 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS (0.05)
cTR     1 (TRANSMITTED PROJECTILES)'/)
      WRITE(21,1886) ((MAGT(IG,IAGB),IAGB=1,22),IG=1,62)
      WRITE(21,2122)
 2122 FORMAT(//,' AZIMUTH.ANGLE - POLAR ANGLE IN COS-INTERVALS ', 
     1  '(0.05)   (TRANSMITTED ENERGY)'/)
cTR 2122 FORMAT(//,' AZIMUTH.ANGLE - POLAR ANGLE IN COS-INTERVALS (0.05)
cTR     1 (TRANSMITTED ENERGY)'/)
      WRITE(21,2127)  (EMAT(01,IAGB),IAGB=1,11)
      WRITE(21,2125) ((EMAT(IG,IAGB),IAGB=1,11),IG=2,NG)
      WRITE(21,2028)
      WRITE(21,2131)   EMAT(1,1),(EMAT(1,IAGB),IAGB=12,22)
      DO 2129 IG=2,NG
      WRITE(21,2126)  EMAT(IG,1),(EMAT(IG,IAGB),IAGB=12,22)
 2129 CONTINUE
 2125 FORMAT(1X,1F5.0,10E11.4)
 2126 FORMAT(1X,1F5.0,11E11.4)
 2127 FORMAT(1X,1F5.0,10F11.0)
 2131 FORMAT(1H1,1X,1F5.0,11F11.0)
      GO TO 9000
C     WRITE(6,2132)
C2132 FORMAT(1H1,1X,'ENERGY(IN % OF E0) - PATHLENGTH(IN UNITS OF CW)
C    1 (TRANSMITTED PROJECTILES)'/)
C     DO 2134 II=1,3
C     INE=II*25+1
C     INA=INE-24
C     DO 2140 IE=1,NE
C     WRITE(6,2036) MEPT(IE,1),(MEPT(IE,IPT),IPT=INA,INE)
C2140 CONTINUE
C     WRITE(6,2028)
C2134 CONTINUE
C     DO 2142 IE=1,NE
C     WRITE(6,2038) MEPT(IE,1),(MEPT(IE,IPT),IPT=77,102)
C2142 CONTINUE
 9000 CONTINUE
C     WRITE(6,*) INEL,L,LJ
C     DO 9875 J=1,180
C     IANF=J*7-6
C     IEND=(J+1)*7-7
C     WRITE(6,9876) (ESVDL(I),I=IANF,IEND)
C9876 FORMAT(1X,7E11.4)
C9875 CONTINUE
CC
CC    DATA ON DISC
CC
c      WRITE(17) Z1,M1,E0,ALPHA,EF,ESB,SHEATH
c     1          ,NH,RI,X0,RD,CW,CA,KK0,KK0R,KDEE1,KDEE2
c      WRITE(17) (DX(I),I=1,3),(RHO(I),I=1,3),(CK(I),I=1,3)
c     1          ,((ZT(I,J),J=1,5),I=1,3),((MT(I,J),J=1,5),I=1,3)
c     2          ,((CO(I,J),J=1,5),I=1,3),((SBE(I,J),J=1,5),I=1,3)
c     3          ,((ED(I,J),J=1,5),I=1,3),((BE(I,J),J=1,5),I=1,3)
c      WRITE(17) TI,ZARG,VELC
c     1          ,HLM,HLMT,SU,SUT,XC,RT,INEL,L,LJ
c     2          ,NPROJ,KIB,KIT,MAXA,NALL,NPA,NSA,KIS,KIST
c     3          ,IIM,EIM,IB,EB,IT,ET,ISPA,ESPA,ISPAT,ESPAT
c     4          ,FIX0,SEX,THX,FOX,SIGMAX,DFIX0,DSEX,DTHX
c     5          ,FIR0,SER,THR,FOR,SIGMAR,DFIR0,DSER,DTHR
c     6          ,FIP0,SEP,THP,FOP,SIGMAP,DFIP0,DSEP,DTHP
c     7          ,AVNLI,VANLI,SIGNLI,DFINLI
c     8          ,AVILI,VAILI,SIGILI,DFIILI
c      WRITE(17) AVCSUM,AVCDIS
c     1          ,FIE0,SEE,THE,FOE,SIGMAE,DFIE0,DSEE,DTHE
c     2          ,FIW0,SEW,THW,FOW,SIGMAW,DFIW0,DSEW,DTHW
c     3          ,FII0,SEI,THI,FOI,SIGMAI,DFII0,DSEI,DTHI
c     4          ,FIS0,SES,THS,FOS,SIGMAS,DFIS0,DSES,DTHS
c     5          ,IIRP,TRIRP,IIPL,TION,TDMGN,TCASMO,TPHON,TDENT
c      WRITE(17) RN,RE,EMEANR,EMEAN,TN,TE,TMEANR,EMEANT
c     1          ,FIB0,SEB,THB,FOB,SIGMAB,DFIB0,DSEB,DTHB
c     2          ,FIPB0,SEPB,THPB,FOPB,SIGMPB,DFIPB0,DSEPB,DTHPB
c     3          ,AVNLB,VANLB,SIGNLB,DFINLB
c     4          ,AVILB,VAILB,SIGILB,DFIILB
c      WRITE(17) FIT0,SET,THT,FOT,SIGMAT,DFIT0,DSET,DTHT
c     1          ,FIPT0,SEPT,THPT,FOPT,SIGMPT,DFIPT0,DSEPT,DTHPT
c     2          ,AVNLT,VANLT,SIGNLT,DFINLT
c     3          ,AVILT,VAILT,SIGILT,DFIILT
c      WRITE(17) (IRP(I),I=0,100),(RIRP(I),I=0,100)
c     1          ,(IPL(I),I=1,100),(ION(I),I=1,100),(DMGN(I),I=1,100)
c     2          ,(CASMOT(I),I=1,100),(PHON(I),I=1,100),(DENT(I),I=1,100)
c      WRITE(17) (FIESB(J),J=1,10),(SEESB(J),J=1,10),(THESB(J),J=1,10)
c     1          ,(FOESB(J),J=1,10),(SGMESB(J),J=1,10)
c     2          ,(DFIESB(J),J=1,10),(DSEESB(J),J=1,10)
c     3          ,(DTHESB(J),J=1,10)
c      WRITE(17) ((ELE(I,J),J=1,15),I=1,100),((ELI(I,J),J=1,15),I=1,100)
c     1          ,((ELP(I,J),J=1,15),I=1,100)
c     2          ,(ELET(J),J=1,15),(ELIT(J),J=1,15),(ELPT(J),J=1,15)
c      WRITE(17) (AI(I),I=1,20),(KADB(I),I=1,20),(KADT(I),I=1,20)
c     1          ,(RKADB(I),I=1,20),(RKADT(I),I=1,20)
c      WRITE(17) (KADS(I),I=1,20),(KADST(I),I=1,20)
c     1          ,(RKADS(I),I=1,20),(RKADST(I),I=1,20)
c      WRITE(17) ((KADRIP(I,J),J=1,10),I=1,20)
c     1          ,((KADRIS(I,J),J=1,10),I=1,20)
c     2          ,((KADROP(I,J),J=1,10),I=1,20)
c     3          ,((KADROS(I,J),J=1,10),I=1,20)
cC   4          ,RKDRIP(20),RKDRIS(20),RKDROP(20),RKDROS(20)
c      WRITE(17) ((KADSJ(I,J),J=1,10),I=1,20)
c     1          ,((RKADSJ(I,J),J=1,10),I=1,20)
c     2          ,((KADSL(I,J),J=1,2),I=1,20)
c     3          ,((RKADSL(I,J),J=1,2),I=1,20)
c      WRITE(17) ((KDSTJ(I,J),J=1,10),I=1,20)
c     1          ,((RKDSTJ(I,J),J=1,10),I=1,20)
c     2          ,((KDSTL(I,J),J=1,2),I=1,20)
c     3          ,((RKDSTL(I,J),J=1,2),I=1,20)
c      WRITE(17) (IBSP(I),I=1,15),(EBSP(I),I=1,15)
c     1          ,(SPY(I),I=1,15),(SPE(I),I=1,15)
c     2          ,(REY(I),I=1,15),(EMSP(I),I=1,15)
c     3          ,(ISPAL(I),I=1,3),(ESPAL(I),I=1,3)
c      WRITE(17) (ISPIP(I),I=1,15),(ISPIS(I),I=1,15)
c     1          ,(ISPOP(I),I=1,15),(ISPOS(I),I=1,15)
c     2          ,(ESPIP(I),I=1,15),(ESPIS(I),I=1,15)
c     3          ,(ESPOP(I),I=1,15),(ESPOS(I),I=1,15)
c     4          ,(RIP(I),I=1,15),(RIS(I),I=1,15)
c     5          ,(ROP(I),I=1,15),(ROS(I),I=1,15)
c     6          ,(REIP(I),I=1,15),(REIS(I),I=1,15)
c     7          ,(REOP(I),I=1,15),(REOS(I),I=1,15)
c      WRITE(17) (ITSP(I),I=1,15),(ETSP(I),I=1,15)
c     1          ,(SPYT(I),I=1,15),(SPET(I),I=1,15)
c     2          ,(REYT(I),I=1,15),(EMSPT(I),I=1,15)
c     3          ,(ISPALT(I),I=1,3),(ESPALT(I),I=1,3)
c      WRITE(17) (ISPIPT(I),I=1,15),(ISPIST(I),I=1,15)
c     1          ,(ISPOPT(I),I=1,15),(ISPOST(I),I=1,15)
c     2          ,(ESPIPT(I),I=1,15),(ESPIST(I),I=1,15)
c     3          ,(ESPOPT(I),I=1,15),(ESPOST(I),I=1,15)
c     4          ,(RIPT(I),I=1,15),(RIST(I),I=1,15)
c     5          ,(ROPT(I),I=1,15),(ROST(I),I=1,15)
c     6          ,(REIPT(I),I=1,15),(REIST(I),I=1,15)
c     7          ,(REOPT(I),I=1,15),(REOST(I),I=1,15)
c      WRITE(17) ((MEAB(I,J),J=1,22),I=1,102)
c     1          ,((MAGB(I,J),J=1,22),I=1,62)
c     2          ,(((MEAGB(I,J,K),K=1,22),J=1,36),I=1,102)
c     3          ,((EMA(I,J),J=1,22),I=1,62),(ELOG(I),I=1,75)
c     4          ,(EABL(I),I=1,75),((MEABL(I,J),J=1,21),I=1,75)
c     5          ,((MEPB(I,J),J=1,102),I=1,102)
c      WRITE(17) ((MEAT(I,J),J=1,22),I=1,102)
c     1          ,((MAGT(I,J),J=1,22),I=1,62)
c     2          ,(((MEAGT(I,J,K),K=1,22),J=1,36),I=1,102)
c     3          ,((EMAT(I,J),J=1,22),I=1,62)
c     4          ,(EATL(I),I=1,75),((MEATL(I,J),J=1,21),I=1,75)
c     5          ,((MEPT(I,J),J=1,102),I=1,102)
c      WRITE(17) (((MEAS(I,J,K),K=1,10),J=1,22),I=1,102)
c     1          ,(((MAGS(I,J,K),K=1,10),J=1,22),I=1,62)
c     2          ,((EASL(I,J),J=1,10),I=1,75)
c     3          ,(((MEASL(I,J,K),K=1,10),J=1,21),I=1,75)
c      WRITE(17) (((MEAST(I,J,K),K=1,10),J=1,22),I=1,102)
c     1          ,(((MAGST(I,J,K),K=1,10),J=1,22),I=1,62)
c     2          ,((EASTL(I,J),J=1,10),I=1,75)
c     3          ,(((MEASTL(I,J,K),K=1,10),J=1,21),I=1,75)
c      WRITE(17) ((((MEAGS(I,J,K,MN),MN=1,10),K=1,22),J=1,12),I=1,102)
c     1          ,(((MAGSA(I,J,K),K=1,10),J=1,32),I=1,62)
CC   1          ,((((MEAGST(I,J,K,L),L=1,10),K=1,22),J=1,36),I=1,102)
c      WRITE(17) ((ELD(I,J),I=1,100),J=1,15)
c      WRITE(17) XSUM,X2SUM,X3SUM,X4SUM,X5SUM,X6SUM
c      WRITE(17) EB,EB2SUM,EB3SUM,EB4SUM,EB5SUM,EB6SUM
c     1          ,EB1SUL,EB2SUL,EB3SUL,EB4SUL,EB5SUL,EB6SUL
c      WRITE(17) (EBSP(J),J=1,15),(SPE2S(J),J=1,15),(SPE3S(J),J=1,15)
c     1          ,(SPE4S(J),J=1,15),(SPE5S(J),J=1,15),(SPE6S(J),J=1,15)
c      WRITE(17) (SPE1SL(J),J=1,15),(SPE2SL(J),J=1,15),(SPE3SL(J),J=1,15)
c     1          ,(SPE4SL(J),J=1,15),(SPE5SL(J),J=1,15)
c     2          ,(SPE6SL(J),J=1,15)
c      WRITE(17) ((ICD(I,J),J=1,15),I=1,100),((ICDR(I,J),J=1,15),I=1,100)
c      WRITE(17) (((ICDIRI(I,J,K),K=1,15),J=1,15),I=1,100)
c     1          ,((ICDIRN(I,J),J=1,15),I=1,100)
c      write(17) exi1s,exi2s,exi3s,exi4s,exi5s,exi6s
c     1          ,coss1s,coss2s,coss3s,coss4s,coss5s,coss6s
c      write(17) ibl,(ibsp(i),i=1,15)
C      
      CLOSE(UNIT=21) 
      CLOSE(UNIT=22)
        CLOSE(UNIT=99)   
 8000 STOP
      END
C
C     SUBROUTINE MAGICKRC(C2,S2,B,R,EPS,N)
C     DIMENSION C2(N),S2(N),B(N),R(N),EPS(N),V(N),V1(N),TEST(N)
C     DIMENSION EX1(N),EX2(N),EX3(N)
C     IVMIN=1
C     IVMAX=N
C
C     MAGIC (DETERMINATION OF SCATTERING ANGLE : KRYPTON-CARBON POT.)
C
C     DO 105 IV=IVMIN,IVMAX
C     KRYPTON-CARBON POTENTIAL
C       EX1(IV)=DEXP(-.278544*R(IV))
C       EX2(IV)=DEXP(-.637174*R(IV))
C       EX3(IV)=DEXP(-1.919249*R(IV))
C       RR1=1./R(IV)
C       V(IV)=(.190945*EX1(IV)+.473674*EX2(IV)+.335381*EX3(IV))*RR1
C       V1(IV)=-(V(IV)+.053186584080*EX1(IV)+.301812757276*EX2(IV)+
C    1                 .643679648869*EX3(IV))*RR1
C     FR=B(IV)*B(IV)*RR1+V(IV)*R(IV)/EPS(IV)-R(IV)
C     FR1=-B(IV)*B(IV)*RR1*RR1+(V(IV)+V1(IV)*R(IV))/EPS(IV)-1.
C     Q=FR/FR1
C     R(IV)=R(IV)-Q
C     TEST(IV)=DABS(Q/R(IV)).GT.0.001
C 105 CONTINUE
C     GET MAX AND MIN INDEX OF TEST FAILURES
C     IVMIN=IVMIN+ILLZ(IVMAX-IVMIN+1,TEST(IVMIN),1)
C     IF(IVMIN.GT.IVMAX) GO TO 106
C     IVMAX=IVMAX-ILLZ(IVMAX-IVMIN+1,TEST(IVMIN),-1)
C     IF(IVMIN.GT.IVMAX) GO TO 106
C     GO TO 104
C 106 DO 108 IV=1,IH1
C     ROCINV=-0.5*V1(IV)/(EPS(IV)-V(IV))
C     SQE=DSQRT(EPS(IV))
C       CC=(.235800+SQE)/(.126000+SQE)
C       AA=2.*EPS(IV)*(1.+(1.0144/SQE))*B(IV)**CC
C       FF=(DSQRT(AA*AA+1.)-AA)*((69350.+EPS(IV))/(83550.+EPS(IV)))
C     DELTA=(R(IV)-B(IV))*AA*FF/(FF+1.)
C     C=(ROCINV*(B(IV)+DELTA)+1.)/(ROCINV*R(IV)+1.)
C     C2(IV)=DMIN1(1.0,C*C)
C 108 S2(IV)=1.-C2(IV)
C     RETURN
C     END
C
C     SUBROUTINE MAGICMOL(C2,S2,B,R,EPS,N)
C     DIMENSION C2(N),S2(N),B(N),R(N),EPS(N),V(N),V1(N),TEST(N)
C     DIMENSION EX1(N),EX2(N),EX3(N)
C     IVMIN=1
C     IVMAX=N
C
C     MAGIC (DETERMINATION OF SCATTERING ANGLE : MOLIERE POT.)
C
C     DO 105 IV=IVMIN,IVMAX
C     MOLIERE POTENTIAL
C       EX1(IV)=DEXP(-.3*R(IV))
C       EX2(IV)=DEXP(-1.2*R(IV))
C       EX3(IV)=DEXP(-6.0*R(IV))
C       RR1=1./R(IV)
C       V(IV)=(.35*EX1(IV)+.55*EX2(IV)+.10*EX3(IV))*RR1
C       V1(IV)=-(V(IV)+.105*EX1(IV)+.66*EX2(IV)+.6*EX3(IV))*RR1
C     FR=B(IV)*B(IV)*RR1+V(IV)*R(IV)/EPS(IV)-R(IV)
C     FR1=-B(IV)*B(IV)*RR1*RR1+(V(IV)+V1(IV)*R(IV))/EPS(IV)-1.
C     Q=FR/FR1
C     R(IV)=R(IV)-Q
C     TEST(IV)=DABS(Q/R(IV)).GT.0.001
C 105 CONTINUE
C     GET MAX AND MIN INDEX OF TEST FAILURES
C     IVMIN=IVMIN+ILLZ(IVMAX-IVMIN+1,TEST(IVMIN),1)
C     IF(IVMIN.GT.IVMAX) GO TO 106
C     IVMAX=IVMAX-ILLZ(IVMAX-IVMIN+1,TEST(IVMIN),-1)
C     IF(IVMIN.GT.IVMAX) GO TO 106
C     GO TO 104
C 106 DO 108 IV=1,IH1
C     ROCINV=-0.5*V1(IV)/(EPS(IV)-V(IV))
C     SQE=DSQRT(EPS(IV))
C       CC=(.009611+SQE)/(.005175+SQE)
C       AA=2.*EPS(IV)*(1.+(0.6743/SQE))*B(IV)**CC
C       FF=(DSQRT(AA*AA+1.)-AA)*((6.314+EPS(IV))/(10.+EPS(IV)))
C     DELTA=(R(IV)-B(IV))*AA*FF/(FF+1.)
C     C=(ROCINV*(B(IV)+DELTA)+1.)/(ROCINV*R(IV)+1.)
C     C2(IV)=DMIN1(1.0,C*C)
C 108 S2(IV)=1.-C2(IV)
C     RETURN
C     END
C
C     SUBROUTINE MAGICZBL(C2,S2,B,R,EPS,N)
C     DIMENSION C2(N),S2(N),B(N),R(N),EPS(N),V(N),V1(N),TEST(N)
C     DIMENSION EX1(N),EX2(N),EX3(N),EX4(N)
C     IVMIN=1
C     IVMAX=N
C
C     MAGIC (DETERMINATION OF SCATTERING ANGLE : ZBL POT.)
C
C     DO 105 IV=IVMIN,IVMAX
C     ZBL POTENTIAL
C       EX1(IV)=DEXP(-.20162*R(IV))
C       EX2(IV)=DEXP(-.4029*R(IV))
C       EX3(IV)=DEXP(-.94229*R(IV))
C       EX4(IV)=DEXP(-3.1998*R(IV))
C       RR1=1./R(IV)
C       V(IV)=(.02817*EX1(IV)+.28022*EX2(IV)+.50986*EX3(IV)+
C    1         .18175*EX4(IV))*RR1
C       V1(IV)=-(V(IV)+.0056796354*EX1(IV)+.112900638*EX2(IV)+
C    1                 .4804359794*EX3(IV)+.581563650*EX4(IV))*RR1
C     FR=B(IV)*B(IV)*RR1+V(IV)*R(IV)/EPS(IV)-R(IV)
C     FR1=-B(IV)*B(IV)*RR1*RR1+(V(IV)+V1(IV)*R(IV))/EPS(IV)-1.
C     Q=FR/FR1
C     R(IV)=R(IV)-Q
C     TEST(IV)=DABS(Q/R(IV)).GT.0.001
C 105 CONTINUE
C     GET MAX AND MIN INDEX OF TEST FAILURES
C     IVMIN=IVMIN+ILLZ(IVMAX-IVMIN+1,TEST(IVMIN),1)
C     IF(IVMIN.GT.IVMAX) GO TO 106
C     IVMAX=IVMAX-ILLZ(IVMAX-IVMIN+1,TEST(IVMIN),-1)
C     IF(IVMIN.GT.IVMAX) GO TO 106
C     GO TO 104
C 106 DO 108 IV=1,IH1
C     ROCINV=-0.5*V1(IV)/(EPS(IV)-V(IV))
C     SQE=DSQRT(EPS(IV))
C       CC=(.011615+SQE)/(.0071222+SQE)
C       AA=2.*EPS(IV)*(1.+(0.99229/SQE))*B(IV)**CC
C       FF=(DSQRT(AA*AA+1.)-AA)*((9.3066+EPS(IV))/(14.813+EPS(IV)))
C     DELTA=(R(IV)-B(IV))*AA*FF/(FF+1.)
C     C=(ROCINV*(B(IV)+DELTA)+1.)/(ROCINV*R(IV)+1.)
C     C2(IV)=DMIN1(1.0,C*C)
C 108 S2(IV)=1.-C2(IV)
C     RETURN
C     END
C
      SUBROUTINE MOMENTS(FIM0,SEM,THM,FOM,FIM,SIM,SIGMA,DFIM0,DSEM,DTHM,
     #                   X1S,X2S,X3S,X4S,X5S,X6S,Y)
cTR      !DEC$REAL:8
        IMPLICIT NONE
        REAL*8 FIM0,SEM,THM,FOM,FIM,SIM,SIGMA,DFIM0,DSEM,DTHM,
     #       X1S,X2S,X3S,X4S,X5S,X6S,Y    
        REAL*8 U,U2,U3,U4,SIGMA3
        REAL*8 X3SP,X4SP,X5SP,X6SP
        LOGICAL EQUAL
C
C      IF(Y.EQ.0.D0.OR.Y.EQ.1.D0) GO TO 10
      IF(EQUAL(Y,0.D0))GOTO 10
        IF(EQUAL(Y,1.D0))GOTO 10
      FIM0=X1S/Y
      SEM=X2S/Y-FIM0*FIM0
      SIGMA=DSQRT(SEM)
      SIGMA3=SEM*SIGMA
      U=FIM0/SIGMA
      U2=U*U
      U3=U2*U
      U4=U3*U
      X3SP=X3S/(Y*SIGMA3)
      X4SP=X4S/(Y*SEM*SEM)
      X5SP=X5S/(Y*SEM*SIGMA3)
      X6SP=X6S/(Y*SIGMA3*SIGMA3)
      THM=X3SP-U*(3.D0+U2)
      FOM=X4SP-4.D0*U*X3SP+3.D0*U2*(2.D0+U2)
      FIM=X5SP-5.D0*U*X4SP+10.D0*U2*X3SP-2.D0*U3*(5.D0+3.D0*U2)
      SIM=X6SP-6.D0*U*X5SP+15.D0*U2*X4SP-20.D0*U3*X3SP+
     #                                   5.D0*U4*(3.D0+2.D0*U2)
      DFIM0=SIGMA/DSQRT(Y)
      DSEM=SEM*DSQRT(DMAX1(1.D-20,FOM-1.D0)/(Y))
      DTHM=DSQRT(DMAX1(1.D-20,
     #     (9.D0+8.75D0*THM*THM+2.25D0*THM*THM*FOM-
     #      6.D0*FOM-3.D0*THM*FIM+SIM))/Y)
   10 CONTINUE
      RETURN
      END
C
      SUBROUTINE MOMENTN(FIM0,SEM,THM,FOM,FIM,SIM,SIGMA,DFIM0,DSEM,DTHM,
     #         X1SY,X2SY,X3SY,X4SY,X5SY,X6SY,X1S,X2S,X3S,X4S,X5S,X6S,Y)
cTR      !DEC$REAL:8
        IMPLICIT NONE
        REAL*8 FIM0,SEM,THM,FOM,FIM,SIM,SIGMA,DFIM0,DSEM,DTHM,
     #       X1SY,X2SY,X3SY,X4SY,X5SY,X6SY,X1S,X2S,X3S,X4S,X5S,X6S,Y
      REAL*8 X3SP,X4SP,X5SP,X6SP
        REAL*8 U,U2,U3,U4,SIGMA3
        LOGICAL EQUAL
C      IF(Y.EQ.0.D0.OR.Y.EQ.1.D0) GO TO 10
        IF(EQUAL(Y,0.D0))GOTO 10
        IF(EQUAL(Y,1.D0))GOTO 10
      X1SY=X1S/Y
      X2SY=X2S/Y
      X3SY=X3S/Y
      X4SY=X4S/Y
      X5SY=X5S/Y
      X6SY=X6S/Y
      FIM0=X1SY
      SEM=X2SY-X1SY*X1SY
      SIGMA=DSQRT(SEM)
      SIGMA3=SEM*SIGMA
      U=X1SY/SIGMA
      U2=U*U
      U3=U2*U
      U4=U3*U
      X3SP=X3SY/SIGMA3
      X4SP=X4SY/(SEM*SEM)
      X5SP=X5SY/(SEM*SIGMA3)
      X6SP=X6SY/(SIGMA3*SIGMA3)
      THM=X3SP-U*(3.D0+U2)
      FOM=X4SP-4.D0*U*X3SP+3.D0*U2*(2.D0+U2)
      FIM=X5SP-5.D0*U*X4SP+10.D0*U2*X3SP-2.D0*U3*(5.D0+3.D0*U2)
      SIM=X6SP-6.D0*U*X5SP+15.D0*U2*X4SP-20.D0*U3*X3SP+
     #                                   5.D0*U4*(3.D0+2.D0*U2)
      DFIM0=SIGMA/DSQRT(Y)
      DSEM=SEM*DSQRT(DMAX1(1.D-20,FOM-1.D0)/(Y))
      DTHM=DSQRT(DMAX1(1.D-20,
     #     (9.D0+8.75D0*THM*THM+2.25D0*THM*THM*FOM-
     #                  6.D0*FOM-3.D0*THM*FIM+SIM))/Y)
   10 CONTINUE
      RETURN
      END
C
      SUBROUTINE MOMENT(X1SY,X2SY,X3SY,X4SY,X5SY,X6SY
     #                  ,X1S,X2S,X3S,X4S,X5S,X6S,Y)
cTR      !DEC$REAL:8
        IMPLICIT NONE
        REAL*8 X1SY,X2SY,X3SY,X4SY,X5SY,X6SY,X1S,X2S,X3S,X4S,X5S,X6S,Y
        LOGICAL EQUAL
C      IF(Y.EQ.0.0D0) GO TO 10
      IF(EQUAL(Y,0.D0))GOTO 10
      X1SY=X1S/Y
      X2SY=X2S/Y
      X3SY=X3S/Y
      X4SY=X4S/Y
      X5SY=X5S/Y
      X6SY=X6S/Y
   10 RETURN
      END
C
      SUBROUTINE DIRCOS(COSX,COSY,COSZ,SINE,CPSI,SPSI,CPHI,SPHI,N)
cTR      !DEC$REAL:8
        IMPLICIT NONE
        INTEGER N,IV
      REAL*8 COSX(N),COSY(N),COSZ(N),SINE(N),CPSI(N),SPSI(N)
     #          ,CPHI(N),SPHI(N)
        REAL*8 SRAT,CX2,CY2,CZ2,UNIT
C
      DO 1 IV=1,N
      SRAT=SPSI(IV)/SINE(IV)
      CX2=CPSI(IV)*COSX(IV)+SPSI(IV)*SINE(IV)*CPHI(IV)
      CY2=CPSI(IV)*COSY(IV)-SRAT*(COSY(IV)*COSX(IV)*CPHI(IV)
     #                            -COSZ(IV)*SPHI(IV))
      CZ2=CPSI(IV)*COSZ(IV)-SRAT*(COSZ(IV)*COSX(IV)*CPHI(IV)
     #                            +COSY(IV)*SPHI(IV))
      UNIT = 1.0D0/DSQRT(CX2**2+CY2**2+CZ2**2)
      COSX(IV)=CX2*UNIT
      COSY(IV)=CY2*UNIT
C   MAKE SURE COSZ.NE.0.
      COSZ(IV)=DSIGN(DABS(CZ2*UNIT)+1.D-12,CZ2)
      SINE(IV)=DSQRT(COSY(IV)*COSY(IV)+COSZ(IV)*COSZ(IV))
    1 CONTINUE
      RETURN
      END
C
      SUBROUTINE VELOCV(FG,FFG,E,COSX,COSY,COSZ,SINE,N)
cTR      !DEC$REAL:8
        IMPLICIT NONE
      INTEGER n,I
C
C  FETCH A NEW VELOCITY FROM A MAXWELLIAN FLUX AT A SURFACE
C
      REAL*8 FG(2*N),FFG(N),E(N),COSX(N),COSY(N),COSZ(N),SINE(N)
C     DIMENSIOM E(N),COSX(N),COSY(N),COSZ(N),SINE(N)
      REAL*8 M1,VELC,ZARG
        REAL*8 VELX,VELY,VELZ,VELQ,VEL
      COMMON/A/ M1,VELC,ZARG
C
      CALL FGAUSS(FG,2*N,N,FFG,N)
C
      DO 10 I=1,N
      VELX=DSQRT((FFG(I)*ZARG)**2+VELC)
      VELY=FG(I)*ZARG
      VELZ=FG(I+N)*ZARG
C
      VELQ=VELX*VELX+VELY*VELY+VELZ*VELZ
      VEL=DSQRT(VELQ)
      COSX(I)=VELX/VEL
      COSY(I)=VELY/VEL
      COSZ(I)=VELZ/VEL
      SINE(I)=DSQRT(1.D0-COSX(I)*COSX(I))
      E(I)=M1*VELQ
   10 CONTINUE
      RETURN
      END
C
      SUBROUTINE VELOC(E,COSX,COSY,COSZ,SINE)
C
C  FETCH A NEW VELOCITY FROM A MAXWELLIAN FLUX AT A SURFACE
C
cTR      !DEC$REAL:8
        IMPLICIT NONE
        INTEGER INIV1,INIV3
      REAL*8 FG(128),FFG(64)
        REAL*8 COSX,COSY,COSZ,SINE
      REAL*8 M1,VELC,ZARG
        REAL*8 VELX,VELY,VELZ,VELQ,VEL,E
      COMMON/A/ M1,VELC,ZARG
C
      IF (INIV1.EQ.0) CALL FGAUSS(FG,INIV1,64,FFG,INIV3)
C
      VELX=FFG(INIV3)*ZARG
      VELY=FG(INIV1)*ZARG
      VELZ=FG(INIV1-1)*ZARG
C  SHEATH CONTRIBUTION
      IF (VELC.GT.0.) THEN
         VELX=DSQRT(VELC+VELX**2)
      ENDIF
      INIV1=INIV1-2
      INIV3=INIV3-1
C
      VELQ=VELX*VELX+VELY*VELY+VELZ*VELZ
      VEL=DSQRT(VELQ)
      COSX=VELX/VEL
      COSY=VELY/VEL
      COSZ=VELZ/VEL
      SINE=DSQRT(1.D0-COSX*COSX)
      E=M1*VELQ
C
      RETURN
      END
C
      SUBROUTINE FGAUSS (FG,IND,IANZ,FFG,IND2)
cTR      !DEC$REAL:8
C
C  RETURN IANZ PAIRS OF RANDOM NUMBER FROM A GAUSSIAN, I.E. IANZ*2
C  NUMBERS, AND RETURN THEM IN THE ARRAY FG
C
C       THIS FUNCTION SAMPLES FROM A GAUSSIAN OF THE
C       FORM DEXP(-(X-ZA)**2/(2.*ZS**2))/(ZS*DSQRT(2*PI))
C       ZA=0.
C       ZS=1.
C
C       IT IS THE BOX-MUELLER METHOD
C
        IMPLICIT NONE
        INTEGER IND,IND2,IANZ,JJ
        INTEGER*4 ISEED
        REAL*8 PI2,ZZ,ZSIN,ZCOS,AR,ZT
        REAL*8 FG(1),FFG(1)
        real*4 random, ran2(2)
        DATA PI2/6.28318530717598D0/
          IND=IANZ+IANZ
C
CDIR$ IVDEP
        DO 1 JJ=1,IANZ
C       1. COMPUTE THE SINE AND COSINE OF 2*PI*RAN(1)
C
CC      ZZ=PI2*RANF()
CC      ZZ=PI2*DRAND48()
CC      ZZ=PI2*DBLE(RAN(ISEED))
	call ranlux(ran2, 2)
        ZZ=PI2*DBLE(ran2(1))
        ZSIN=DSIN(ZZ)
        ZCOS=DCOS(ZZ)
C
CC      AR=DLOG(RANF())
CC      AR=DLOG(DRAND48())
CC      AR=DLOG(DBLE(RAN(ISEED)))
        AR=DLOG(DBLE(ran2(2)))
        ZT=DSQRT(-1.0D0*(AR+AR))
        FG(JJ+IANZ)=ZT*ZSIN
        FG(JJ)=ZT*ZCOS
  1     CONTINUE
C
C  RETURN IANZ RANDOM NUMBERS FROM A GAUSSIAN FLUX IN THE ARRAY FFG
C
        IND2=IANZ
        DO 2 JJ=1,IANZ
CC      AR=DLOG(RANF())
CC      AR=DLOG(DRAND48())
CC      AR=DLOG(DBLE(RAN(ISEED)))
	call ranlux(random, 1)
	AR=DLOG(DBLE(random))

  2     FFG(JJ)=DSQRT(-1.D0*(AR+AR))
       RETURN
        END
C
      SUBROUTINE ENERGV(FE,E,COSX,COSY,COSZ,SINE,N)
cTR    !DEC$REAL:8
C
C  FETCH A NEW ENERGY FROM A MAXWELLIAN FLUX AT A SURFACE
C
        IMPLICIT NONE
      INTEGER N,I
        REAL*8 FE(N),E(N),COSX(N),COSY(N),COSZ(N),SINE(N)
      REAL*8 M1,EMT
        REAL*8 TI,SHEATH,CALFA
      COMMON/B/ TI,SHEATH,CALFA
C
      CALL EMAXW(FE,N)
C
      DO 10 I=1,N
      EMT=TI*FE(I)**2
      COSX(I) = DSQRT((EMT*CALFA*CALFA +SHEATH)/(EMT +SHEATH))
      SINE(I) = DSQRT( 1.D0 -COSX(I)*COSX(I))
      COSY(I) = SINE(I)
      COSZ(I) = 0.D0
      E(I)    = EMT + SHEATH
   10 CONTINUE
CC    WRITE(6,*) (E(I),I=1,N),(COSX(I),I=1,N)
      RETURN
      END
C
      SUBROUTINE ENERG(E,COSX,COSY,COSZ,SINE)
cTR    !DEC$REAL:8
C
C  FETCH A NEW ENERGY FROM A MAXWELLIAN FLUX AT A SURFACE
C
        IMPLICIT NONE
      REAL*8 FE(16)
      REAL*8 M1,COSX,SINE,COSY,COSZ,E,EMT
        REAL*8 TI,SHEATH,CALFA

      COMMON/B/ TI,SHEATH,CALFA
C
      CALL EMAXW(FE,16)
C
      EMT=TI*FE(9)**2
      COSX = DSQRT((EMT*CALFA*CALFA +SHEATH)/(EMT +SHEATH))
      SINE = DSQRT( 1.D0 -COSX*COSX)
      COSY = SINE
      COSZ = 0.D0
      E    = EMT + SHEATH
   10 CONTINUE
CC    WRITE(6,*) E,COSX
      RETURN
      END
C
      SUBROUTINE EMAXW (FE,NUMB)
cTR    !DEC$REAL:8
C
C       THIS FUNCTION SAMPLES FROM A MAXWELLIAN (ENERGY) OF THE
C       FORM X**2*DEXP(-X**2)*4/DSQRT(PI))
C
C       MONTE CARLO SAMPLER C29 (EVERETT, CASHWELL)
C
	implicit none
        INTEGER NUMB,I
        INTEGER*4 ISEED
        REAL*8 FE(1)
        REAL*8 PI,AR1,AR2
	real*4 random(3)
        DATA PI/3.14159265358979D0/
C
CDIR$ IVDEP
        DO 1 I=1,NUMB
CC      AR1=DLOG(RANF())
CC      AR1=DLOG(DRAND48())
CC      AR1=DLOG(DBLE(RAN(ISEED)))
	call ranlux(random, 3)
	AR1=DLOG(DBLE(random(1)))
CC      AR2=DLOG(RANF())*(DCOS(PI*0.5*RANF()))**2
CC      AR2=DLOG(DRAND48())*(DCOS(PI*0.5*DRAND48()))**2
CC      AR2=DLOG(DBLE(RAN(ISEED)))*(DCOS(PI*0.5*DBLE(RAN(ISEED))))**2
	AR2=DLOG(DBLE(random(2)))*(DCOS(PI*0.5*DBLE(random(3))))**2
        FE(I)=DSQRT(-1.D0*(AR1+AR2))
  1     CONTINUE
        RETURN
        END
C
      REAL*8 FUNCTION CVMGT(A, B, C)
cTR      FUNCTION CVMGT(A, B, C)
cTR      !DEC$REAL:8
        IMPLICIT NONE
        REAL*8 A,B
      LOGICAL C
      CVMGT = B
      IF ( C ) CVMGT = A
      RETURN
      END
C
      SUBROUTINE SCOPY(IM,A,INCA,B,INCB)
        IMPLICIT NONE
      INTEGER*4 INCA,INCB,IM,JA,JB
        INTEGER   J
      REAL*8 A(*),B(*)
      JA = IM * IABS(INCA)
      IF (INCA .GT. 0) JA = 1
      JB = IM * IABS(INCB)
      IF (INCB .GT. 0) JB = 1
      DO 10 J = 1,IM
         B(JB) = A(JA)
         JA = JA + INCA
         JB = JB + INCB
   10 CONTINUE
      RETURN
      END
C
       FUNCTION ILLZ(N,A,K)
cTR      !DEC$REAL:8
        IMPLICIT NONE
       LOGICAL A(*)
         INTEGER K,L,N,I
         INTEGER*4 ILLZ
       IF(K.GT.0) THEN
       L=N+1
       DO 100 I=N,1,-1
  100  IF(A(I)) L=I
       ELSE
       L=0
       DO 200 I=1,N
  200  IF(A(I)) L=I
       L=N+1-L
       ENDIF
       ILLZ=L-1
       RETURN
       END
C
       INTEGER FUNCTION ISRCHFGE(N,ARRAY,INC,TARGT)
cTR       FUNCTION ISRCHFGE(N,ARRAY,INC,TARGT)
cTR       !DEC$REAL:8
        IMPLICIT NONE
         INTEGER I,N,J,INC
       REAL*8 ARRAY(N)
         REAL*8 TARGT

       J=1
       IF(INC.LT.0) J=N*(-INC)
       DO 100 I=1,N
         IF(ARRAY(J).GE.TARGT) GO TO 200
         J=J+INC
  100  CONTINUE
  200  ISRCHFGE=I
       RETURN
       END
C
       INTEGER FUNCTION ISRCHFGT(N,ARRAY,INC,TARGT)
cTR       FUNCTION ISRCHFGT(N,ARRAY,INC,TARGT)
cTR       !DEC$REAL:8
        IMPLICIT NONE
       INTEGER I,N,J,INC
       REAL*8 ARRAY(N),TARGT
C        WRITE(*,*)targt
       J=1
       IF(INC.LT.0) J=N*(-INC)
       DO 100 I=1,N
         IF(ARRAY(J).GT.TARGT) GO TO 200
         J=J+INC
  100  CONTINUE
  200  ISRCHFGT=I
       RETURN
       END
C
       INTEGER FUNCTION ISRCHEQ(N,ARRAY,INC,TARGT)
cTR       FUNCTION ISRCHEQ(N,ARRAY,INC,TARGT)
cTR       !DEC$REAL:8
        IMPLICIT NONE
       INTEGER I,N,J,INC
       REAL*8 ARRAY(N),TARGT
C        WRITE(*,*)targt
         J=1
       IF(INC.LT.0) J=N*(-INC)
       DO 100 I=1,N
         IF(ARRAY(J).EQ.TARGT) GO TO 200
         J=J+INC
  100  CONTINUE
  200  ISRCHEQ=I
       RETURN
       END
C
       SUBROUTINE ENERGGAUSS(ISEED2,Esig,Epar,E0)
cTR       !DEC$REAL:8
       IMPLICIT NONE
       INTEGER*4 ISEED2
       REAL*8 E0,Esig,Epar
       REAL*8 p1,p2,p3,pi
       real*4 random(2)
       DATA pi/3.14159265358979D0/
       call ranlux(random, 2)
       p1  = Esig*DSQRT(-2.D0*DLOG(1.D0-DBLE(random(1)))) 
       p2  = 2.D0*pi*DBLE(random(2))
       p3  = p1*DCOS(p2)
       Epar= E0-p3
C       WRITE(*,*)E0,Esig,Epar
C       WRITE(31,100)E0,Esig,Epar
C100    FORMAT(1x,F12.5,2x,F12.5,2x,F12.5)
       RETURN
       END
C
       SUBROUTINE ALPHAGAUSS(ISEED3,ALPHASIG,ALPHA,ALFA,ALPHApar,
     +            CALFA,SALFA,BW)
cTR       !DEC$REAL:8
        IMPLICIT NONE
       INTEGER*4 ISEED3
       REAL*8 ALPHA,ALPHASIG,ALPHApar
       REAL*8 BW,ALFA,CALFA,SALFA
       REAL*8 p1,p2,p3,pi
       real*4 random(2)
       DATA pi/3.14159265358979D0/
       call ranlux(random, 2)	
       p1  = ALPHASIG*DSQRT(-2.D0*DLOG(1.D0-DBLE(random(1)))) 
       p2  = 2.D0*pi*DBLE(random(2))
       p3  = p1*DCOS(p2)
       ALPHApar= ALPHA-p3
         IF(ALPHApar.LT.0.D0) THEN
                ALPHApar=DABS(ALPHApar)
         ENDIF
         ALFA  = ALPHApar/BW
         CALFA = DCOS(ALFA)
         SALFA = DSIN(ALFA)
C       WRITE(*,*)ALPHA,ALPHASIG,ALPHApar
C       WRITE(31,100)ALPHA,ALPHASIG,ALPHApar
C100    FORMAT(1x,F12.5,2x,F12.5,2x,F12.5)
       RETURN
       END
C
       LOGICAL FUNCTION EQUAL(F1,F2)
       IMPLICIT NONE
       REAL*8 F1,F2
       REAL*8 TINY
       PARAMETER  (TINY = 1.0D-10)
       IF (DABS(F1-F2).LE.TINY) THEN
         EQUAL = .TRUE.
       ELSE
         EQUAL = .FALSE.
       ENDIF
       RETURN
         END

