C Version TrimSpNL ----> N Layer C C Created 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------------------------------------------- c check OS c #if defined( _WIN32 ) #define OS_WIN #else #define OS_UNIX #endif IMPLICIT NONE C These parameters are related to the maximum number of layers MAXNL C and maximum number of points in the depth distribution MAXD INTEGER MAXD,MAXD1,MAXD2,MAXD5,MAXDNL5,MAXD2p2,MAXD2meagb & ,MAXD2meab INTEGER MAXNL,MAXNL5,MAXNLp25,MAXNL5p2,MAXNLm15 C This is the only point where the number of layers and depth C profile are changed. All other parameters shouold be changed C accordingly. PARAMETER (MAXD=500) PARAMETER (MAXNL=100) PARAMETER (MAXD1=MAXD+1) PARAMETER (MAXD2=MAXD+2) PARAMETER (MAXD5=MAXD*5) PARAMETER (MAXD2p2=MAXD2*MAXD2) PARAMETER (MAXD2meagb=MAXD2*36*22) PARAMETER (MAXD2meab=MAXD2*22) PARAMETER (MAXNL5=MAXNL*5) PARAMETER (MAXNLp25=MAXNL*MAXNL5) PARAMETER (MAXDNL5=MAXNL*MAXD5) PARAMETER (MAXNL5p2=MAXNL5*MAXNL5*MAXD) PARAMETER (MAXNLm15=(MAXNL-1)*5) 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 depth_interval_flag INTEGER OldNew 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(MAXNL),laufzahl INTEGER*4 IRP(0:MAXD1),IPL(MAXD),IPLB(MAXD),IPLT(MAXD) INTEGER*4 ICD(MAXD,MAXNL5),ICDT(MAXD),ICDJT(MAXNL5) & ,ICDIRJ(MAXNL5,MAXNL5),ICDR(MAXD,MAXNL5),ICDTR(MAXD) & ,ICDJTR(MAXNL5),ICDIRI(MAXD,MAXNL5,MAXNL5) & ,ICDIRN(MAXD,MAXNL5),ICDITR(MAXNL5) INTEGER*4 KADB(20),KADT(20),KADS(20),KADST(20) ,KADRIP(20,MAXNLm15 & ),KADRIS(20,MAXNLm15),KADROP(20,MAXNLm15),KADROS(20,MAXNLm15) & ,KADSJ(20,MAXNLm15),KADSL(20,6),KDSTJ(20,MAXNLm15),KDSTL(20,6 & ) INTEGER*4 IBSP(MAXNL5),ISPAL(MAXNL),IBSPL(MAXNL5),ISPIP(MAXNL5) & ,ISPIS(MAXNL5),ISPOP(MAXNL5),ISPOS(MAXNL5) INTEGER*4 ITSP(MAXNL5),ISPALT(MAXNL) & ,ISPIPT(MAXNL5),ISPIST(MAXNL5),ISPOPT(MAXNL5),ISPOST(MAXNL5) INTEGER*4 KO(600,MAXNL5,2) INTEGER*4 MEAB(MAXD2,22),MAGB(62,22),MEAGB(MAXD2,36,22) & ,MEABL(75,21),MEPB(MAXD2,MAXD2) INTEGER*4 MEAT(MAXD2,22),MAGT(62,22),MEAGT(MAXD2,36,22), & MEATL(75,21),MEPT(MAXD2,MAXD2) INTEGER*4 MEAS(MAXD2,22,MAXNLm15),MAGS(62,22,MAXNLm15),MAGSA(62,32 & ,MAXNLm15),MEAGS(MAXD2,12,22,MAXNLm15) ,MEASL(75,21,MAXNLm15) INTEGER*4 MEAST(MAXD2,22,MAXNLm15),MAGST(62,22,MAXNLm15),MEASTL(75 & ,21,MAXNLm15) INTEGER*4 NJ(MAXNL),JT(MAXNL),ILD(MAXNL),NJJ INTEGER*4 LLL(64),JJJ(64),IK(64) INTEGER*4 me(5000),nli(MAXNL),irpl(MAXNL) 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 INTEGER*4 NLayers C REAL Variables 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:MAXD1),CASMOT(MAXD),PHON(MAXD),DENT(MAXD),ION(MAXD) & ,DMGN(MAXD),CASMOTR(MAXD),PHONR(MAXD),DENTR(MAXD),IONR(MAXD) & ,DMGNR(MAXD),ELGD(MAXD),ELGDR(MAXD) REAL*8 ELE(MAXD,MAXNL5),ELI(MAXD,MAXNL5),ELP(MAXD,MAXNL5) & ,ELD(MAXD,MAXNL5) ,ELET(MAXNL5),ELIT(MAXNL5),ELPT(MAXNL5) & ,ELDT(MAXNL5),ELER(MAXD,MAXNL5),ELIR(MAXD,MAXNL5),ELPR(MAXD & ,MAXNL5),ELDR(MAXD,MAXNL5) ,ELETR(MAXNL5),ELITR(MAXNL5) & ,ELPTR(MAXNL5),ELDTR(MAXNL5) REAL*8 AI(20),RKADB(20),RKADT(20) ,RKADS(20),RKADST(20) & ,RKADSJ(20,MAXNLm15),RKADSL(20,MAXNL),RKDSTJ(20,MAXNLm15) & ,RKDSTL(20,MAXNL) REAL*8 EBSP(MAXNL5),ESPAL(MAXNL) ,SPY(MAXNL5),SPE(MAXNL5) & ,REY(MAXNL5),EMSP(MAXNL5),ESPIP(MAXNL5),ESPIS(MAXNL5) & ,ESPOP(MAXNL5),ESPOS(MAXNL5) ,RIP(MAXNL5),RIS(MAXNL5) & ,ROP(MAXNL5),ROS(MAXNL5) ,REIP(MAXNL5),REIS(MAXNL5) & ,REOP(MAXNL5),REOS(MAXNL5),ESPMIP(MAXNL5),ESPMIS(MAXNL5) & ,ESPMOP(MAXNL5),ESPMOS(MAXNL5) ,RIPJ(MAXNL5),RISJ(MAXNL5) & ,ROPJ(MAXNL5),ROSJ(MAXNL5) ,REIPJ(MAXNL5),REISJ(MAXNL5) & ,REOPJ(MAXNL5),REOSJ(MAXNL5) REAL*8 ETSP(MAXNL5),ESPALT(MAXNL) ,SPYT(MAXNL5),SPET(MAXNL5) & ,REYT(MAXNL5),EMSPT(MAXNL5),ESPIPT(MAXNL5),ESPIST(MAXNL5) & ,ESPOPT(MAXNL5),ESPOST(MAXNL5),RIPT(MAXNL5),RIST(MAXNL5) & ,ROPT(MAXNL5),ROST(MAXNL5) ,REIPT(MAXNL5),REIST(MAXNL5) & ,REOPT(MAXNL5),REOST(MAXNL5) ,ESPMIPT(MAXNL5),ESPMIST(MAXNL5) & ,ESPMOPT(MAXNL5),ESPMOST(MAXNL5) REAL*8 SPEM(MAXNL5),SPE2S(MAXNL5),SPE3S(MAXNL5),SPE4S(MAXNL5) & ,SPE5S(MAXNL5) ,SPE6S(MAXNL5),VSPE(MAXNL5),SSPE(MAXNL5) & ,GSPE(MAXNL5),BSPE(MAXNL5) REAL*8 SPE1SL(MAXNL5),SPE2SL(MAXNL5),SPE3SL(MAXNL5),SPE4SL(MAXNL5) & ,SPE5SL(MAXNL5),SPE6SL(MAXNL5) REAL*8 ELOG(75),EMA(62,22),EABL(75) REAL*8 EMAT(62,22),EATL(75),EASL(75,MAXNLm15),EASTL(75,MAXNLm15) REAL*8 FG(128),FFG(64) REAL*8 XX(MAXNL),DX(MAXNL),RHO(MAXNL) REAL*8 Z2(MAXNL),M2(MAXNL),LM(MAXNL) REAL*8 PDMAX(MAXNL),ARHO(MAXNL),AM(MAXNL) REAL*8 FM(MAXNL),EPS0(MAXNL),ASIG(MAXNL) REAL*8 K2(MAXNL),CK(MAXNL),KLM1(MAXNL) REAL*8 SB(MAXNL),DLI(MAXNL) REAL*8 UpTiefe,LowTiefe REAL*8 ZT(MAXNL,5),MT(MAXNL,5),CO(MAXNL,5) & ,SBE(MAXNL,5),ED(MAXNL,5),BE(MAXNL,5), & COM(5,MAXNL) REAL*8 MU(MAXNL5,MAXNL5),EC(MAXNL5,MAXNL5),A(MAXNL5,MAXNL5) & ,F(MAXNL5,MAXNL5) ,KL(MAXNL5,MAXNL5),KOR(MAXNL5,MAXNL5) & ,KLM(MAXNL,MAXNL5) REAL*8 MU1(MAXNL5),EC1(MAXNL5),A1(MAXNL5),F1(MAXNL5),KL1(MAXNL5) & ,KOR1(MAXNL5) ,DI(MAXNL5),EP(MAXNL5),ZZ(MAXNL5),TM(MAXNL5) REAL*8 CH1(MAXNL,5),CH2(MAXNL,5),CH3(MAXNL,5) & ,CH4(MAXNL,5),CH5(MAXNL,5) REAL*8 CHM1(MAXNL) REAL*8 SM(64),SH(64,5) REAL*8 FIESB(MAXNLm15),SEESB(MAXNLm15),THESB(MAXNLm15) & ,FOESB(MAXNLm15) ,SGMESB(MAXNLm15),DFIESB(MAXNLm15) & ,DSEESB(MAXNLm15),DTHESB(MAXNLm15) 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 Variables 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 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 COMMON /A/ M1,VELC,ZARG COMMON /B/ TI,SHEATH,CALFA 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 KIT/0/,KIS/0/,KIST/0/,NALL/0/,NPA/0/,NSA/0/,KIB/0/,MAXA/0/ DATA SEM/0.D0/,IT/0/,NPROJ/0/,NREC1/0/,NREC2/0/ DATA NH/0/,IB/0/,IBL/0/,NJ/MAXNL*0/,NLI/MAXNL*0/ DATA DLI/MAXNL*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/MAXD2meab*0/,MEABL/1575*0/,MAGB/1364*0/ DATA MEPB/MAXD2p2*0/,MEAGB/MAXD2meagb*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/MAXD*0.D0/,DENT/MAXD*0.D0/ DATA DMGN/MAXD*0.D0/,ION/MAXD*0.D0/,PHON/MAXD*0.D0/ DATA PHONR/MAXD*0.D0/ DATA ELGD/MAXD*0.D0/,ELGDR/MAXD*0.D0/ DATA ICDT/MAXD*0/,ICDTR/MAXD*0/ DATA ICDR/MAXDNL5*0/,ICDIRN/MAXDNL5*0/,IONR/MAXD*0.D0/ DATA DENTR/MAXD*0.D0/,DMGNR/MAXD*0.D0/ DATA IPL/MAXD*0/,IPLB/MAXD*0/,IPLT/MAXD*0/,IRP/MAXD2*0/ DATA IRPL/MAXNL*0/ DATA ICDJT/MAXNL5*0/,ICDJTR/MAXNL5*0/,ICDITR/MAXNL5*0/ DATA ICD/MAXDNL5*0/,ELP/MAXDNL5*0.D0/,ELD/MAXDNL5*0.D0/ DATA ELE/MAXDNL5*0.D0/,ELI/MAXDNL5*0.D0/ DATA ICDIRI/MAXNL5p2*0/ DATA ICSUM/0/,ICSUMS/0/,ICDI/0/,ISPA/0/,ISPAT/0/ DATA Z2/MAXNL*0.D0/,M2/MAXNL*0.D0/ DATA KLM1/MAXNL*0.D0/,CHM1/MAXNL*0.D0/ DATA SB/MAXNL*0.D0/,KLM/MAXNLp25*0.D0/ DATA ME/5000*0/,EMX/0.D0/,ESPAT/0.D0/,ESPA/0.D0/ DATA IBSP/MAXNL5*0/,IBSPL/MAXNL5*0/,EBSP/MAXNL5*0.D0/ DATA ISPAL/MAXNL*0/ DATA ITSP/MAXNL5*0/,ETSP/MAXNL5*0.D0/ DATA ESPAL/MAXNL*0.D0/,ESPALT/MAXNL*0.D0/ DATA ISPALT/MAXNL*0/ DATA SPE2S/MAXNL5*0.D0/,SPE3S/MAXNL5*0.D0/,SPE4S/MAXNL5*0.D0/ DATA SPE5S/MAXNL5*0.D0/,SPE6S/MAXNL5*0.D0/ DATA SPE1SL/MAXNL5*0.D0/,SPE2SL/MAXNL5*0.D0/,SPE3SL/MAXNL5*0.D0/ DATA SPE4SL/MAXNL5*0.D0/,SPE5SL/MAXNL5*0.D0/,SPE6SL/MAXNL5*0.D0/ DATA ELET/MAXNL5*0.D0/,ELPT/MAXNL5*0.D0/,ELDT/MAXNL5*0.D0/ DATA ELIT/MAXNL5*0.D0/ DATA ELETR/MAXNL5*0.D0/,ELITR/MAXNL5*0.D0/,ELPTR/MAXNL5*0.D0/ DATA ELDTR/MAXNL5*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/MAXNL*0/ innam=filein//inext outnam=fileout//outext rgenam=fileout//rgeext errnam=fileout//errext C LMAX is maximum number of layers and JMAX is maximum number of C elements per layer. Assume these values for old files and change C LMAX as needed for the new format. LMAX=7 JMAX=5 if (OldNew(innam).eq.1) then OPEN(UNIT=99,file=errnam,STATUS='replace') OPEN(UNIT=11,file=innam,STATUS='unknown',ERR=1359) C This part reads the input file (new format) C First line: properties of projectile READ(11,*) Z1,M1,E0,Esig,ALPHA,ALPHASIG,EF,ESB,SHEATH,ERC C Second line: simulation related parameters READ(11,*) NH,RI,RI2,RI3,X0,RD,CW,CA,KK0,KK0R,KDEE1,KDEE2,IPOT & ,IPOTR,IRL C Third line: Number of layers read(11,66) NLayers 66 format(9x,I4) LMAX=NLayers C Here we read the NLayers structure DO I=1,NLayers C Thickness (DX), density (RHO), and correction factor (CK, it is C always 1.0??) Atomic numbers READ(11,*) DX(I),RHO(I),CK(I) C Atomic numbers READ(11,*) ZT(I,1),ZT(I,2),ZT(I,3),ZT(I,4),ZT(I,5) C Mass numbers (amu) READ(11,*) MT(I,1),MT(I,2),MT(I,3),MT(I,4),MT(I,5) C Concentration READ(11,*) CO(I,1),CO(I,2),CO(I,3),CO(I,4),CO(I,5) C Surface binding energy READ(11,*) SBE(I,1),SBE(I,2),SBE(I,3),SBE(I,4),SBE(I,5) C Displacement energy READ(11,*) ED(I,1),ED(I,2),ED(I,3),ED(I,4),ED(I,5) C Bulk binding energy READ(11,*) BE(I,1),BE(I,2),BE(I,3),BE(I,4),BE(I,5) C value A-1 of the ziegler tables READ(11,*) CH1(I,1),CH1(I,2),CH1(I,3),CH1(I,4),CH1(I,5) C value A-2 of the ziegler tables READ(11,*) CH2(I,1),CH2(I,2),CH2(I,3),CH2(I,4),CH2(I,5) C value A-3 of the ziegler tables READ(11,*) CH3(I,1),CH3(I,2),CH3(I,3),CH3(I,4),CH3(I,5) C value A-4 of the ziegler tables READ(11,*) CH4(I,1),CH4(I,2),CH4(I,3),CH4(I,4),CH4(I,5) C value A-5 of the ziegler tables READ(11,*) CH5(I,1),CH5(I,2),CH5(I,3),CH5(I,4),CH5(I,5) ENDDO else OPEN(UNIT=99,file=errnam,STATUS='replace') OPEN(UNIT=11,file=innam,STATUS='unknown',ERR=1359) C This part reads the input file (old format, 7 layers) C First line: properties of projectile READ(11,*) Z1,M1,E0,Esig,ALPHA,ALPHASIG,EF,ESB,SHEATH,ERC C Second line: simulation related parameters READ(11,*) NH,RI,RI2,RI3,X0,RD,CW,CA,KK0,KK0R,KDEE1,KDEE2,IPOT & ,IPOTR,IRL C Third line: layer structure. To be replaced by number of layers C and then each layer with its properties: Thickness (DX), density C (RHO), and correction factor (CK, it is always 1.0??) READ(11,*) 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) C Here we read the 7 layer structure DO I=1,7 C Atomic numbers READ(11,*) ZT(I,1),ZT(I,2),ZT(I,3),ZT(I,4),ZT(I,5) C Mass numbers (amu) READ(11,*) MT(I,1),MT(I,2),MT(I,3),MT(I,4),MT(I,5) C Concentration READ(11,*) CO(I,1),CO(I,2),CO(I,3),CO(I,4),CO(I,5) C Surface binding energy READ(11,*) SBE(I,1),SBE(I,2),SBE(I,3),SBE(I,4),SBE(I,5) C Displacement energy READ(11,*) ED(I,1),ED(I,2),ED(I,3),ED(I,4),ED(I,5) C Bulk binding energy READ(11,*) BE(I,1),BE(I,2),BE(I,3),BE(I,4),BE(I,5) C value A-1 of the ziegler tables READ(11,*) CH1(I,1),CH1(I,2),CH1(I,3),CH1(I,4),CH1(I,5) C value A-2 of the ziegler tables READ(11,*) CH2(I,1),CH2(I,2),CH2(I,3),CH2(I,4),CH2(I,5) C value A-3 of the ziegler tables READ(11,*) CH3(I,1),CH3(I,2),CH3(I,3),CH3(I,4),CH3(I,5) C value A-4 of the ziegler tables READ(11,*) CH4(I,1),CH4(I,2),CH4(I,3),CH4(I,4),CH4(I,5) C value A-5 of the ziegler tables READ(11,*) CH5(I,1),CH5(I,2),CH5(I,3),CH5(I,4),CH5(I,5) ENDDO endif 1359 CLOSE(UNIT=11) C open statement for output files, removed from line 2449 ff to here OPEN(UNIT=21,FILE=outnam) GOTO 6001 READ(*,'(A8)') fileout outnam=fileout//outext rgenam=fileout//rgeext OPEN(UNIT=21,FILE=outnam,STATUS='new') 6001 OPEN(UNIT=22,FILE=rgenam,STATUS='new') WRITE(21,1000) 1000 FORMAT(1H1/,6X,'* TrimSPNL 02.Apr.13 *') C Get simulation start time CALL TimeStamp(day_start,month_start,year_start,hour_start & ,min_start,sec_start,seconds_start_total) WRITE(21,*) WRITE(21,1050)day_start,month_start,year_start,hour_start & ,min_start,sec_start WRITE(*,1050)day_start,month_start,year_start,hour_start & ,min_start,sec_start 1050 FORMAT(1x,' TrimSp simulation started at: ',A2,'.',A4,1x,A4,1x,A2 & ,':',A2,':',A2) C SET INTERVAL CONSTANTS FOR OUTPUT 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 CALCULATION OF CHARGE AND MASS DEPENDENT CONSTANTS PI2=2.D0*PI ABC=AB*FP C This function is used only once to get the number of defined C layers. It should be replaced! L=ISRCHEQ(LMAX,DX(1),1,0.D0)-1 C Checks wether depth interval is an integer denominator of layer thickness or not C If not, calculated implantation profile is not correct. depth_interval_flag = 1 DO K=1,L-1 IF(.NOT.EQUAL(DX(K)/CW-DBLE(IDINT(DX(K)/CW)),0.D0)) THEN depth_interval_flag = 0 GO TO 44 ENDIF ENDDO 44 CONTINUE DO I=1,L DO J=1,JMAX IF(EQUAL(CO(I,J),0.D0)) GOTO 156 ENDDO J=JMAX+1 C I am guessing NJ(I) is the number of elements in layer I 156 NJ(I)=J-1 ENDDO JT(1) = 0 JT(2) = NJ(1) LJ= NJ(1)+NJ(2) do I=3,L JT(I)=JT(I-1)+NJ(I-1) LJ=LJ+NJ(I) enddo XX(1)=DX(1) DO I=2,L XX(I)=XX(I-1)+DX(I) ENDDO DO I=1,L DO J=1,NJ(I) Z2(I)=Z2(I)+CO(I,J)*ZT(I,J) M2(I)=M2(I)+CO(I,J)*MT(I,J) ENDDO ENDDO DO 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 ENDDO C Loop over all defined layers NJJ=0 do I=1,L C For each layer calculate the following do J=1,NJ(I) ZZ(NJJ+J) = ZT(I,J) TM(NJJ+J) = MT(I,J) DI(NJJ+J) = ED(I,J) EP(NJJ+J) = BE(I,J) enddo NJJ=NJJ+NJ(I) enddo DO I=1,L COM(1,I) = CO(I,1) DO J=1,NJ(I)-1 COM(J+1,I) = COM(J,I)+CO(I,J+1) ENDDO ENDDO DO 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)) ENDDO IF(IPOT.EQ.1) THEN C KR-C POTENTIAL (IPOT=1) DO J=1,LJ KOR1(J) = 0.0389205D0*KL1(J)/(PI*A1(J)*A1(J)) ENDDO ELSEIF (IPOT.EQ.2) THEN C MOLIERE POTENTIAL (IPOT=2) DO J=1,LJ KOR1(J) = 0.045D0*KL1(J)/(PI*A1(J)*A1(J)) ENDDO ELSEIF (IPOT.EQ.3) THEN C ZBL POTENTIAL DO J=1,LJ KOR1(J) = 0.0203253D0*KL1(J)/(PI*A1(J)*A1(J)) ENDDO ENDIF DO I = 1,LJ DO 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))) ENDDO ENDDO IF (IPOTR.EQ.1) THEN C KR-C POTENTIAL (IPOTR=1) DO I = 1,LJ DO J = 1,LJ KOR(I,J) = 0.0389205D0*KL(I,J)/(PI*A(I,J)*A(I,J)) ENDDO ENDDO ELSEIF (IPOTR.EQ.2) THEN C MOLIERE POTENTIAL (IPOTR=2) DO I = 1,LJ DO J = 1,LJ KOR(I,J) = 0.045D0*KL(I,J)/(PI*A(I,J)*A(I,J)) ENDDO ENDDO ELSEIF (IPOTR.EQ.3) THEN C ZBL POTENTIAL (IPOTR=3) DO I = 1,LJ DO J = 1,LJ KOR(I,J) = 0.0203253D0*KL(I,J)/(PI*A(I,J)*A(I,J)) ENDDO ENDDO ENDIF DO LL=1,L DO 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) ENDDO ENDDO DO I=1,LJ DO LL = 1,L DO J=1,NJ(LL) KLM(LL,I) = KLM(LL,I)+CO(LL,J)*KL(I,J+JT(LL)) ENDDO ENDDO ENDDO 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 SET CONSTANT DISTANCES 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 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) ISEED = IY ISEED2 = IY2 ISEED3 = IY3 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 IV=1,NUM EMX = EMX+E(IV) ENDDO DO iv=1,num ne = IDINT(DMIN1(5000.D0,e(iv)+1.D0)) me(ne) = me(ne)+1 ENDDO GO TO 56 C C MAXWELLIAN ENERGY DISTRIBUTION C ELSE CALL ENERGV(FE,E,COSX,COSY,COSZ,SINE,NUM) DO IV=1,NUM EMX = EMX+E(IV) ENDDO GO TO 56 ENDIF 47 CONTINUE IF(EQUAL(Esig,0.D0)) THEN C FIXED PROJECTILE ENERGY DO IV=1,NUM E(IV) = 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 ENDDO ENDIF SFE = DMIN1(SB(1),SB(L)) IF ( ALPHA.GE.0.D0 ) THEN IF(EQUAL(ALPHASIG,0.D0))THEN C C FIXED PROJECTILE ANGLE C 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) 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) ENDDO ENDIF ELSEIF (EQUAL(ALPHA,-2.D0)) THEN C C COSINE ANGLE DISTRIBUTION (THREE-DIMENSIONAL) C DO IV=1,NUM call ranlux(ran2,2) RPHI = PI2*DBLE(ran2(1)) 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) ENDDO ELSEIF (EQUAL(ALPHA,-1.D0).AND.X0.GT.0.D0) THEN C C RANDOM DISTRIBUTION C DO IV=1,NUM call ranlux(ran2,2) RPHI = PI2*DBLE(ran2(1)) 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) ENDDO ELSEIF (EQUAL(ALPHA,-1.D0).AND.X0.LE.0.D0) THEN DO IV=1,NUM call ranlux(ran2,2) RPHI = PI2*DBLE(ran2(1)) 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) ENDDO ENDIF 56 IF ( X0.GT.0.D0 ) GO TO 59 C C EXTERNAL START C DO 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 ENDDO C C LOCUS OF FIRST COLLISION C 59 JL = ISRCHFGT(L,XX(1),1,X0) DO IV=1,NUM 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) ENDDO DO IV=1,NUM LLL(IV) = JL ENDDO C C PROJECTILE LOOP C 1 CONTINUE NPROJ=NPROJ+1 DO 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 ENDDO 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 IV=1,IH1 call ranlux(random, 1) JJJ(IV) = ISRCHFGE(NJ(LLL(IV)),COM(1,LLL(IV)),1,DBLE(random)) & +JT(LLL(IV)) ENDDO DO IV=1,IH1 EPS(IV)=E(IV)*F1(JJJ(IV)) ENDDO DO IV=1,IH1 C C RANDOM AZIMUTHAL ANGLE AND IMPACT PARAMETER C call ranlux(ran2, 2) PHIP=PI2*DBLE(ran2(1)) CPHI(IV)=DCOS(PHIP) SPHI(IV)=DSIN(PHIP) 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) B(IV)=P(IV)/A1(JJJ(IV)) ENDDO CALL SCOPY(IH1,B,1,R,1) 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 104 DO 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) 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)+ & .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 ENDDO 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 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) S2(IV)=1.D0-(1.D0*C2(IV)) ENDDO GO TO 4103 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 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)) 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 ENDDO 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 IV=1,IH1 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) S2(IV)=1.D0-(1.D0*C2(IV)) ENDDO GO TO 4103 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 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)) RR1=1.D0/R(IV) V(IV)=(.02817D0*EX1(IV)+.28022D0*EX2(IV)+.50986D0*EX3(IV)+ & .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)+ & .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 ENDDO 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 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) S2(IV)=1.D0-(1.D0*C2(IV)) ENDDO 4103 CONTINUE C C END OF MAGIC C DO IV=1,IH1 DEN(IV)=EC1(JJJ(IV))*E(IV)*S2(IV) IF(C2(IV).LT.1.D-10) THEN 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) 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 ENDDO 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 IV=1,IH1 ASIGT(IV)=(LM(LLL(IV))-TAU(IV)+TAUPSI(IV))*ARHO(LLL(IV)) TAUPSI(IV)=TAU(IV)*DABS(CPSI(IV)) ENDDO GO TO(15,16,17,18,19),KDEE1 15 DO 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) ENDDO GO TO 40 16 DO IV=1,IH1 DEE(IV)=DEES(IV) ENDDO GO TO 40 17 DO 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) ENDDO GO TO 40 18 DO IV=1,IH1 SM(IV)=0.D0 EM(IV)=E(IV)*0.001D0/M1 ENDDO DO IV=1,IH1 DO 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) ENDDO ENDDO DO IV=1,IH1 DO J=1,NJ(LLL(IV)) SM(IV)=SM(IV)+SH(IV,J)*CO(LLL(IV),J) ENDDO ENDDO DO IV=1,IH1 DEE(IV)=CVMGT(CHM1(LLL(IV))*DSQRT(EM(IV)),SM(IV),EM(IV).LE.10 & .D0) ENDDO DO IV=1,IH1 DEE(IV)=10.D0*ASIGT(IV)*CVMGT(0.D0,DEE(IV),X(IV).LT.HLM.OR & .X(IV).GT.HLMT) ENDDO GO TO 40 19 FHE=CVMGT(1.3333D0,1.D0,M1.LT.4.00D0) DO IV=1,IH1 SM(IV)=0.D0 EM(IV)=E(IV)*0.001D0*FHE ENDDO DO IV=1,IH1 DO 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))) ENDDO ENDDO DO IV=1,IH1 DO J=1,NJ(LLL(IV)) SM(IV)=SM(IV)+SH(IV,J)*CO(LLL(IV),J) ENDDO ENDDO DO IV=1,IH1 DEE(IV)=10.D0*ASIGT(IV)* CVMGT(0.D0,SM(IV),X(IV).LT.HLM.OR.X(IV & ).GT.HLMT) ENDDO 40 CONTINUE C DO 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)) ENDDO C C INCREMENT OF DAMAGE, CASCADE AND PHONON ENERGY C DO 70 IV=1,IH1 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 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)) ENDDO DO 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) ENDDO IF(KK0.EQ.0) GO TO 89 DO 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 ENDDO 89 CONTINUE 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 IF(DEN(IV).LE.ERC) GO TO 6 IF(X1(IV).GT.RD.AND.X1(IV).LT.RT) GO TO 6 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 DO 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) ENDDO 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 ', & 'MUST BE INCREASED') 8886 CONTINUE C C PROCESS THE PARTICLES IN LIST 2 C C FIND LAYER C DO IREC1=1,NREC2 LRR(IREC1,2)=MIN0(ISRCHFGT(L,XX(1),1,XR(IREC1,2)),L) ENDDO C C MOVE PARTICLES C DO 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) ENDDO DO 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 ENDDO KK2=KK0R DO KKR=KK2,0,-1 C C CHOICE OF COLLISION PARTNERS C DO IREC1=1,NREC2 call ranlux(random, 1) JJR(IREC1,1) = ISRCHFGE(NJ(LRR(IREC1,2)),COM(1,LRR(IREC1,2)) & ,1,DBLE(random))+JT(LRR(IREC1,2)) ENDDO DO IREC1=1,NREC2 call ranlux(ran2, 2) PHIPR=PI2*DBLE(ran2(1)) CPHIR(IREC1,2)=DCOS(PHIPR) SPHIR(IREC1,2)=DSIN(PHIPR) 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 .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) ENDDO 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 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))/EPSR(IV & )-1.D0 Q=FR/FR1 RR(IV)=RR(IV)-Q TEST1(IV)=DABS(Q/RR(IV)).GT.0.001D0 ENDDO 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 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) S2R(IV)=1.D0-C2R(IV) ENDDO GO TO 4203 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 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))/ & EPSR(IV)-1.D0 Q=FR/FR1 RR(IV)=RR(IV)-Q TEST1(IV)=DABS(Q/RR(IV)).GT.0.001D0 ENDDO 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 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) S2R(IV)=1.D0-C2R(IV) ENDDO GO TO 4203 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 & )+.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 & )+.4804359794D0*EX3R(IV)+.581563650D0*EX4R(IV))*RRR1 FR1=-BR(IV)*BR(IV)*RRR1*RRR1+(VR(IV)+V1R(IV)*RR(IV))/ & 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 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) S2R(IV)=1.D0-C2R(IV) ENDDO 4203 CONTINUE C DO 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,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 ENDDO CALL DIRCOS(CSXR(1,2),CSYR(1,2),CSZR(1,2),SNXR(1,2), CPSIR(1,2) & ,SPSIR(1,2),CPHIR(1,2),SPHIR(1,2),NREC2) ENDDO C C CREATE SECONDARY KNOCK-ON ATOMS C DO 246 IREC1=1,NREC2 IF(T(IREC1).LE.ERC) GO TO 246 IF(X2(IREC1).GT.RD.AND.X2(IREC1).LT.RT) GO TO 246 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)- & CPHIR(IREC1,2)*CYR(IREC1)*CXR(IREC1))/SXR(IREC1) ZR(NREC1,1)=ZR(IREC1,2)+PR(IREC1)*(SPHIR(IREC1,2)*CYR(IREC1)+ & 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 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)) ENDDO GO TO(115,116,117),KDEE2 115 DO 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) ENDDO GO TO 242 116 DO IREC1=1,NREC2 DEER(IREC1)=DEERS(IREC1) ENDDO GO TO 242 117 DO IREC1=1,NREC2 DEER(IREC1)=CVMGT(DEERS(IREC1),.5*(KLM(LRR(IREC1,2),JJR(IREC1,2 & ))*ASIGTR(IREC1)*DSQRT(ER(IREC1,2))+DEERS(IREC1)),XR(IREC1 & ,2).LT.HLM.OR.XR(IREC1,2).GT.HLMT) ENDDO 242 CONTINUE C DO IREC1=1,NREC2 DELR=DMAX1(1.0D-20,TS(IREC1)+DEER(IREC1)) TS(IREC1)=CVMGT(ER(IREC1,2)*TS(IREC1)/DELR,TS(IREC1) ,DELR.GT & .ER(IREC1,2)) DEER(IREC1)=CVMGT(ER(IREC1,2)*DEER(IREC1)/DELR,DEER(IREC1) & ,DELR.GT.ER(IREC1,2)) ENDDO DO 252 IREC1=1,NREC2 I=MAX0(MIN0(IDINT(X2(IREC1)/CW+1.D0),100),1) DENTR(I)=DENTR(I)+TS(IREC1) DMGNR(I)=DMGNR(I)+T(IREC1) IONR(I)=IONR(I)+DEER(IREC1) IF(T(IREC1).LE.DI(JJR(IREC1,1))) GO TO 84 ELGDR(I)=ELGDR(I)+T(IREC1) ICDR(I,JJR(IREC1,2))=ICDR(I,JJR(IREC1,2))+1 ICDIRI(I,JJR(IREC1,2),JJR(IREC1,1))= ICDIRI(I,JJR(IREC1,2) & ,JJR(IREC1,1))+1 GO TO 252 84 PHONR(I)=PHONR(I)+T(IREC1) 252 CONTINUE DO 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))= ICDIRJ(JJR(IREC1,2) & ,JJR(IREC1,1)) +IDINT(CVMGT(1.D0,0.D0,T(IREC1).GT & .DI(JJR(IREC1,1)))) ENDDO DO 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) .OR & .XR(IREC1,2).GT.SUT .OR.(XR(IREC1,2).GT.RD.AND.XR(IREC1,2) & .LT.RT) ENDDO 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 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 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) 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 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 GO TO 88 86 ISPIST(JJR(IREC1,2))=ISPIST(JJR(IREC1,2))+1 ESPIST(JJR(IREC1,2))=ESPIST(JJR(IREC1,2))+ESPT 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 GO TO 88 87 ISPOST(JJR(IREC1,2))=ISPOST(JJR(IREC1,2))+1 ESPOST(JJR(IREC1,2))=ESPOST(JJR(IREC1,2))+ESPT 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 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 247 CONTINUE 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 IF(IH1.EQ.0.AND.IH.EQ.NH) GO TO 140 C C PROJECTILE CANDIDATE FOR REFLECTION C DO 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 ENDDO 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 IP = MAX0( MIN0( IDINT(PL(IV)/CW+1.D0), MAXD), 1) IPL(IP)=IPL(IP)+1 I1 = MAX0( MIN0( IDINT(X(IV)/CW+1.D0), MAXD1), 0) IRP(I1)=IRP(I1)+1 C C Berechnung der gestoppten Teilchen im jeweiligen Layer C LowTiefe = 0.D0 UpTiefe = DX(1) 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 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 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 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 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 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 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 110 IF(IH.EQ.NH) GO TO 130 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)) EMX = EMX+E(IV) GO TO 707 702 IF (EQUAL(Esig,0.D0)) THEN C FIXED PROJECTILE ENERGY 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 ENDIF TAUPSI(IV)=0.D0 IF(EQUAL(ALPHA,-2.D0)) GO TO 705 IF(EQUAL(ALPHA,-1.D0)) GO TO 706 IF(EQUAL(ALPHASIG,0.D0))THEN C FIXED PROJECTILE ANGLE 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) COSX(IV) = CALFA COSY(IV) = SALFA COSZ(IV) = 0.D0 SINE(IV) = COSY(IV) ENDIF GO TO 707 C C COSINE ANGLE DISTRIBUTION C 705 call ranlux(ran2, 2) RPHI=PI2*DBLE(ran2(1)) 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 call ranlux(ran2, 2) RPHI=PI2*DBLE(ran2(1)) 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 709 call ranlux(ran2, 2) RPHI=PI2*DBLE(ran2(1)) 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 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) 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 DO 128 IV=1,IVMIN-1 LLL(IV) = MIN0(ISRCHFGT(L,XX(1),1,X(IV)),L) 128 CONTINUE DO 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) ENDDO 134 CONTINUE C IF(IVMAX.LT.IVMIN) GO TO 132 DO IV=IVMAX+1,IH1 LLL(IV) = MIN0(ISRCHFGT(L,XX(1),1,X(IV)),L) ENDDO DO 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) ENDDO 132 CONTINUE GO TO 1 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 IF(ZT(1,2).LT.1.0D-3) THEN epsilon = 32.55D0*(MT(1,1)/M1)/(1.D0+(MT(1,1)/M1))* 1.D0/(Z1 & *ZT(1,1)*DSQRT(Z1**(2.D0/3.D0)+ZT(1,1)**(2.D0/3.D0))) & * E0keV prcoeff = prc(1)*DLOG(prc(2)*epsilon+DEXP(1.D0))/ (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 C C how many seconds are needed for the simulation ?? C CALL TimeStamp(day_stop,month_stop,year_stop, hour_stop,min_stop & ,sec_stop,seconds_stop_total) WRITE(21,*) WRITE(21,10051)day_stop,month_stop,year_stop, hour_stop,min_stop & ,sec_stop WRITE(*,10051)day_stop,month_stop,year_stop, hour_stop,min_stop & ,sec_stop 10051 FORMAT(1x,' TrimSp simulation ended at: ',A2,'.',A4,1x,A4, 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') 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 & ,8HALPHASIG,7X,2HEF,7X ,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 & ,IPOTR,IRL 1406 FORMAT(/7X,2HNH,8X,2HRI,5X,3HRI2,5X,3HRI3,11X,2HX0,8X,2HRD,8X,2HCW & ,8X,2HCA ,7X,3HKK0,3X,4HKK0R,3X,5HKDEE1,2X,5HKDEE2,2X,4HIPOT & ,3X,5HIPOTR ,3X,3HIRL/I10,3F10.2,1F13.2,3F10.2,1X,7I7) WRITE(21,1408) 1408 FORMAT(//13X,2HDX,6X,3HRHO,4X,2HCK,2X & ,5HZ(,1),1X,5HZ(,2),1X,5HZ(,3),1X,5HZ(,4),1X,5HZ(,5),2X & ,5HM(,1),2X,5HM(,2),2X,5HM(,3),2X,5HM(,4),2X,5HM(,5),1X & ,5HC(,1),1X,5HC(,2),1X,5HC(,3),1X,5HC(,4),1X,5HC(,5)) DO I=1,L WRITE(21,1412) I,DX(I),RHO(I),CK(I),(ZT(I,J),J=1,5) ,(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) ENDDO WRITE(21,1414) 1414 FORMAT(//27X,'***',2X,'SBE(LAYER,ELEMENT)',2X,'***',5X & ,'***',5X,'ED(LAYER,ELEMENT)',5X,'***',5X & ,'***',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 & ,' 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 & ,' 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 ,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 & ,'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 & ,'SFE',6X,'INEL',9X,'L',8X,'LJ'/ & 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 & ,'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)' ,7X & ,'LM(I)',5X,'PDMAX(I)',5X,'ASIG(I)',7X,'SB(I)',7X,'XX(I)' ,8X & ,'NJ(I)') DO I=1,L WRITE(21,473) I,EPS0(I),Z2(I),M2(I),ARHO(I),LM(I),PDMAX(I) & ,ASIG(I),SB(I),XX(I),NJ(I) 473 FORMAT(/1X,I1,6H.LAYER,1X,9E12.4,I10) ENDDO WRITE(21,474) 474 FORMAT(//13X, & 'A1(1)',3X,'A1(2)',3X,'A1(3)',3X,'A1(4)',3X,'A1(5)',3X, & 'A1(6)',3X,'A1(7)',3X,'A1(8)',3X,'A1(9)',2X,'A1(10)',2X, & 'A1(11)',2X,'A1(12)',2X,'A1(13)',2X,'A1(14)',2X,'A1(15)',2X, & 'A1(16)',2X,'A1(17)',2X,'A1(18)',2X,'A1(19)',2X,'A1(20)',2X, & 'A1(21)',2X,'A1(22)',2X,'A1(23)',2X,'A1(24)',2X,'A1(25)',2X, & 'A1(26)',2X,'A1(27)',2X,'A1(28)',2X,'A1(29)',2X,'A1(30)',2X, & '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, & 'KOR1(1)',1X,'KOR1(2)',1X,'KOR1(3)',1X,'KOR1(4)',1X,'KOR1(5)', & 1X,'KOR1(6)',1X,'KOR1(7)',1X,'KOR1(8)',1X,'KOR1(9)',1X,'KOR1(A)', & 1X,'KOR1(B)',1X,'KOR1(C)',1X,'KOR1(D)',1X,'KOR1(E)',1X,'KOR1(F)', & 1X,'KOR1(G)',1X,'KOR1(H)',1X,'KOR1(I)',1X,'KOR1(J)',1X,'KOR1(K)', & 1X,'KOR1(L)',1X,'KOR1(M)',1X,'KOR1(N)',1X,'KOR1(O)',1X,'KOR1(P)', & 1X,'KOR1(Q)',1X,'KOR1(R)',1X,'KOR1(S)',1X,'KOR1(T)',1X,'KOR1(U)', & 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, & 'A(I,1)',2X,'A(I,2)',2X,'A(I,3)',2X,'A(I,4)',2X,'A(I,5)',2X, & 'A(I,6)',2X,'A(I,7)',2X,'A(I,8)',2X,'A(I,9)',1X,'A(I,10)',1X, & 'A(I,11)',1X,'A(I,12)',1X,'A(I,13)',1X,'A(I,14)',1X,'A(I,15)',1X, & 'A(I,16)',1X,'A(I,17)',1X,'A(I,18)',1X,'A(I,19)',1X,'A(I,20)',1X, & 'A(I,21)',1X,'A(I,22)',1X,'A(I,23)',1X,'A(I,24)',1X,'A(I,25)',1X, & 'A(I,26)',1X,'A(I,27)',1X,'A(I,28)',1X,'A(I,29)',1X,'A(I,30)',1X, & 'A(I,31)',1X,'A(I,32)',1X,'A(I,33)',1X,'A(I,34)',1X,'A(I,35)') DO I=1,LJ WRITE(21,477) (A(I,J),J=1,LJ) 477 FORMAT(/1X,9X,35F8.5) ENDDO WRITE(21,490) 490 FORMAT(//11X, & 'KOR(,1)',1X,'KOR(,2)',1X,'KOR(,3)',1X,'KOR(,4)',1X,'KOR(,5)',1X, & 'KOR(,6)',1X,'KOR(,7)',1X,'KOR(,8)',1X,'KOR(,9)',1X,'KOR(,A)',1X, & 'KOR(,B)',1X,'KOR(,C)',1X,'KOR(,D)',1X,'KOR(,E)',1X,'KOR(,F)',1X, & 'KOR(,G)',1X,'KOR(,H)',1X,'KOR(,I)',1X,'KOR(,J)',1X,'KOR(,K)',1X, & 'KOR(,L)',1X,'KOR(,M)',1X,'KOR(,N)',1X,'KOR(,O)',1X,'KOR(,P)',1X, & 'KOR(,Q)',1X,'KOR(,R)',1X,'KOR(,S)',1X,'KOR(,T)',1X,'KOR(,U)',1X, & 'KOR(,V)',1X,'KOR(,W)',1X,'KOR(,X)',1X,'KOR(,Y)',1X,'KOR(,Z)') DO I=1,LJ WRITE(21,492) (KOR(I,J),J=1,LJ) 492 FORMAT(/1X,9X,35F8.5) ENDDO 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 J=1,LJ ISPA = ISPA+IBSP(J) ESPA = ESPA+EBSP(J) ENDDO DO J=1,LJ ISPAT = ISPAT+ITSP(J) ESPAT = ESPAT+ETSP(J) ENDDO WRITE(21,1500) IIM,EIM,IB,EB,IT,ET,ISPA,ESPA,ISPAT,ESPAT, tryE & ,negE,epsilon,prcoeff 1500 FORMAT(1H1,//11X,20HIMPLANTED PARTICLES=,I7,5X,7HENERGY=,E10.4, & 3H EV/7X,24HBACKSCATTERED PARTICLES=,I7,5X,7HENERGY=,E10.4, & 3H EV/9X,22HTRANSMITTED PARTICLES=,I7,5X,7HENERGY=,E10.4, & 3H EV/7X,24HBACKSPUTTERED PARTICLES=,I7,5X,7HENERGY=,E10.4, & 3H EV/6X,'TRANSM. SPUTT. PARTICLES=',I7,5X,7HENERGY=,E10.4, & 3H EV/15X,16HTRIED PARTICLES=,I7 & /9X,22HPARTICLES with neg. E=,I7, & /6X,25HTHOMAS FERMI RED. ENERGY=,2X,E10.4, & /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 : ', & 'MEAN NUMBER OF ELASTIC COLLISIONS = ',1F8.1,3X, & 'MEAN NUMBER OF EL.COLL.(E > EDISPL.) = ',F8.3/65X, & '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, XSUM & ,X2SUM,X3SUM,X4SUM,X5SUM,X6SUM,YH) CALL MOMENTS(FIR0,SER,THR,FOR,FIR,SIR,SIGMAR,DFIR0,DSER,DTHR, RSUM & ,R2SUM,R3SUM,R4SUM,R5SUM,R6SUM,YH) CALL MOMENTS(FIP0,SEP,THP,FOP,FIP,SIP,SIGMAP,DFIP0,DSEP,DTHP, & PLSUM,PL2SUM,PL3SUM,PL4SUM,PL5SUM,PL6SUM,YH) CALL MOMENTS(FIE0,SEE,THE,FOE,FIE,SIE,SIGMAE,DFIE0,DSEE,DTHE, EEL & ,EEL2,EEL3,EEL4,EEL5,EEL6,CSUM) CALL MOMENTS(FIW0,SEW,THW,FOW,FIW,SIW,SIGMAW,DFIW0,DSEW,DTHW, & EELWC,EELWC2,EELWC3,EELWC4,EELWC5,EELWC6,CSUM) CALL MOMENTS(FII0,SEI,THI,FOI,FII,SII,SIGMAI,DFII0,DSEI,DTHI, EIL & ,EIL2,EIL3,EIL4,EIL5,EIL6,CSUM) CALL MOMENTS(FIS0,SES,THS,FOS,FIS,SIS,SIGMAS,DFIS0,DSES,DTHS, EPL & ,EPL2,EPL3,EPL4,EPL5,EPL6,CST) WRITE(21,7117) 7117 FORMAT(/20X,' MEAN ',4X,' VARIANCE ',4X,' SKEWNESS ',4X, & ' KURTOSIS ',5X,' SIGMA ',3X,' ERROR 1.M ',3X & ,' ERROR 2.M ', 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 IF(YH.LT.1.D0) GO TO 7235 CALL MOMENT(X1SD,X2SD,X3SD,X4SD,X5SD,X6SD ,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.) : ', & 'MEAN NUMBER OF ELASTIC COLLISIONS = ',1F8.1,3X, & 'MEAN NUMBER OF EL.COLL.(E > EDISPL.) = ',F10.3/76X, & '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) : ', & 'MEAN NUMBER OF ELASTIC COLLISIONS = ',1F8.3,3X, & 'MEAN NUMBER OF EL.COLL.(E > EDISPL.) = ',F10.3/,76X, & '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/ & ,76X,'MEAN NR OF EL.COLL.(E > EDISPL.) 1-2 = ',F10.3/ & ,76X,'MEAN NR OF EL.COLL.(E > EDISPL.) 2-1 = ',F10.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, & 10HPATHLENGTH,3X,10HINLOSS(EV),2X,10HTELOSS(EV),2X & ,10HELLOSS(EV), 2X,10HDAMAGE(EV),2X,10HPHONON(EV),2X & ,10HCASCAD(EV),5X,3HDPA/) 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' ENDIF #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 I=0,MAXD1 C This normalization of the implantation profile is wrong if the C simulation does not account for all implanted projectiles, C e.g. when the number of points in the profile is not enough to C reach the maximum implantation depth. RIRP(I) = DBLE(IRP(I))/YH C To resolve this issue we need to check whether we reached maximum C implantation or not. If not rerun calculation with larger step C size! ENDDO 603 D1=0. D2=CW WRITE(21,601) D1,IRP(0),RIRP(0) 601 FORMAT(4X,3H-SU,1H-,F6.0,I10,E12.4) DO J=1,LJ DO I=1,MAXD ICDT(I)=ICDT(I)+ICD(I,J) ICDTR(I)=ICDTR(I)+ICDR(I,J) ENDDO ENDDO DO K=1,NJ(1) DO J=1,NJ(1) DO I=1,MAXD ICDIRN(I,J)=ICDIRN(I,J)+ICDIRI(I,K,J) ENDDO ENDDO ENDDO DO I=0,MAXD1 IIRP=IIRP+IRP(I) TRIRP=TRIRP+RIRP(I) ENDDO DO I=1,MAXD 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) ICDTTR=ICDTTR+ICDTR(I) ENDDO do im1=MAXD,1,-1 if(ipl(im1).ne.0.or.(.NOT.EQUAL(ion(im1),0.D0))) goto 20 enddo im1=1 20 im1=min0(im1+2,MAXD) DO 11 I=1,im1 WRITE(21,700) D1,D2,IRP(I),RIRP(I),IPL(I),ION(I),DENT(I), & DMGN(I),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(MAXD1),RIRP(MAXD1) 604 FORMAT(1X,F6.0,1H-,3X,3HSUT,I10,E12.4) WRITE(21,710) IIRP,TRIRP,IIPL,TION,TDENT,TDMGN,TELGD,TPHON,TCASMO & ,ICDTT 710 FORMAT(/14X,I10,1P1E12.4,I10,1E14.4,5E12.4,I8) DO J=1,NJ(1) DO I=1,MAXD 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) ENDDO ENDDO WRITE(21,1521) 1521 FORMAT(1H1,4X,'DEPTH(A)' & ,3X,' INLOSS(1)',3X,'ELLOSS(1)',3X,'DAMAGE(1)',3X,'PHONON(1)' & ,2X,' INLOSS(2)',3X,'ELLOSS(2)',3X,'DAMAGE(2)',3X,'PHONON(2)' & ,2X,'DPA(1)',2X,'DPA(2)'/) D1=0. D2=CW do im2=MAXD,1,-1 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,MAXD) DO 1525 I=1,im2 WRITE(21,1523) D1,D2,ELI(I,1),ELE(I,1),ELD(I,1),ELP(I,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),ELIT(2),ELET(2) & ,ELDT(2),ELPT(2),ICDJT(1),ICDJT(2) 1533 FORMAT(/14X,1P8E12.4,2I8///) DO I=1,L-1 ILD(I)=IDINT(XX(I)/CW+0.01D0) IF(ILD(I).GT.MAXD) ILD(I)=MAXD DO J=1,ILD(I) DLI(I)=DLI(I)+DMGN(J) ENDDO ENDDO DLI(L)=TDMGN 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), 5X,10HINLOSS(EV),3X,10HTELOSS(EV),3X & ,10HELLOSS(EV), 3X,10HDAMAGE(EV),3X,10HPHONON(EV),5X,3HDPA, & 2X,6HDPA(1),2X,6HDPA(2), 1X,5H(1-1),1X,5H(1-2),1X,5H(2-1),1X & ,5H(2-2)/) D1=0.D0 D2=CW do im3=MAXD,1,-1 if (.not.equal(ionr(im3),0.D0)) go to 31 enddo im3=1 31 im3=MIN0(im3+2,MAXD) DO I=1,im3 WRITE(21,1595) D1,D2,IONR(I),DENTR(I),DMGNR(I),ELGDR(I), & PHONR(I),ICDTR(I),ICDIRN(I,1),ICDIRN(I,2) & ,ICDIRI(I,1,1),ICDIRI(I,1,2),ICDIRI(I,2,1),ICDIRI(I,2,2) 1595 FORMAT(1X,F6.0,1H-,F6.0,1P1E14.4,4E13.4,3I8,4I6) D1=D2 D2=D2+CW ENDDO WRITE(21,1596) TIONR,TDENTR,TDMGNR,TELGDR,TPHONR & ,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 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.=' & ,1E11.4,' REL.MEAN ENERGY =',1E11.4,' MEAN ENERGY =' & ,1E11.4) IF(IB.EQ.0) GO TO 1512 CALL MOMENT(EB1B,EB2B,EB3B,EB4B,EB5B,EB6B,EB,EB2SUM,EB3SUM,EB4SUM & ,EB5SUM,EB6SUM,BI) CALL MOMENT(EB1BL,EB2BL,EB3BL,EB4BL,EB5BL,EB6BL,EB1SUL,EB2SUL & ,EB3SUL,EB4SUL,EB5SUL,EB6SUL,BIL) CALL MOMENTS(FIB0,SEB,THB,FOB,FIB,SIB,SIGMAB,DFIB0,DSEB,DTHB,EB & ,EB2SUM,EB3SUM,EB4SUM,EB5SUM,EB6SUM,BI) CALL MOMENT(PL1S,PL2S,PL3S,PL4S,PL5S,PL6S,PLSB,PL2SB,PL3SB,PL4SB & ,PL5SB,PL6SB,BI) CALL MOMENTS(FIPB0,SEPB,THPB,FOPB,FIPB,SIPB,SIGMPB,DFIPB0,DSEPB & ,DTHPB, 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 ', & 'PROJECTILES'//) DO I=1,20 RKADB(I)=DBLE(KADB(I))*20.D0/DBLE(IB) ENDDO 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 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.=' & ,1E11.4,' REL.MEAN ENERGY =',1E11.4,' MEAN ENERGY =' & ,1E11.4) CALL MOMENTS(FIT0,SET,THT,FOT,FIT,SIT,SIGMAT,DFIT0,DSET,DTHT,ET & ,ET2SUM,ET3SUM,ET4SUM,ET5SUM,ET6SUM,TIT) CALL MOMENTS(FIPT0,SEPT,THPT,FOPT,FIPT,SIPT,SIGMPT,DFIPT0,DSEPT & ,DTHPT, 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 ', & 'PARTICLES'//) DO I=1,20 RKADT(I)=DBLE(KADT(I))*20.D0/DBLE(IT) ENDDO 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 J=1,NJ(1) ISPAL(1) = ISPAL(1)+IBSP(J) ESPAL(1) = ESPAL(1)+EBSP(J) ENDDO DO J=NJ(1)+1,JT(3) ISPAL(2) = ISPAL(2)+IBSP(J) ESPAL(2) = ESPAL(2)+EBSP(J) ENDDO DO J=JT(3)+1,LJ ISPAL(3) = ISPAL(3)+IBSP(J) ESPAL(3) = ESPAL(3)+EBSP(J) ENDDO WRITE(21,1558) ISPA,ESPA 1558 FORMAT(///,8X,'ALL SPUTTERED PARTICLES = ',I7,3X & ,'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 & ,'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 & ,'SPUTTERED ENERGY(',I1,') = ',E10.4,' EV') 1562 CONTINUE IF(ISPA.EQ.0) GO TO 1700 DO 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 ENDDO 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 J=1,LJ SPY(J)=DBLE(IBSP(J))/HN SPE(J)=EBSP(J)/(HN*EMV) ENDDO DO 1579 J=1,LJ IF (equal(SPY(J),0.0D0))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 J=1,NJ(1) WRITE(21,1576) J,ISPIP(J),RIP(J),RIPJ(J),ESPIP(J),REIP(J) & ,REIPJ(J),ESPMIP(J) ,J,ISPIS(J),RIS(J),RISJ(J),ESPIS(J) & ,REIS(J),REISJ(J) ,ESPMIS(J) ,J,ISPOP(J),ROP(J),ROPJ(J) & ,ESPOP(J),REOP(J),REOPJ(J) ,ESPMOP(J) ,J,ISPOS(J),ROS(J) & ,ROSJ(J),ESPOS(J),REOS(J),REOSJ(J) ,ESPMOS(J) 1576 FORMAT(/9X,'ION IN , PRIMARY KO(',I1,') = ',I7,2F9.4,4X & ,'ENERGY = ',E10.4,' EV',2F9.4,4X,'MEAN ENERGY = ',E10.4/ & 9X,'ION IN , SECOND. KO(',I1,') = ',I7,2F9.4,4X & ,'ENERGY = ',E10.4,' EV',2F9.4,4X,'MEAN ENERGY = ',E10.4/ & 8X,'ION OUT , PRIMARY KO(',I1,') = ',I7,2F9.4,4X & ,'ENERGY = ',E10.4,' EV',2F9.4,4X,'MEAN ENERGY = ',E10.4/ & 8X,'ION OUT , SECOND. KO(',I1,') = ',I7,2F9.4,4X & ,'ENERGY = ',E10.4,' EV',2F9.4,4X,'MEAN ENERGY = ',E10.4) ENDDO 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, & ' SPUTTERED ENERGY(',I1,') = ',1E10.3, & ' REL.MEAN ENERGY(',I1,') = ',1E10.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 ,DFIES0 & ,DSEES,DTHES, EBSP1,EBSP2,EBSP3,EBSP4,EBSP5,EBSP6 ,EBSP(J) & ,SPE2S(J),SPE3S(J),SPE4S(J),SPE5S(J) ,SPE6S(J),YSP) CALL MOMENTN(FIES0L,SEESL,THESL,FOESL,FIESL,SIESL,SIGMSL & ,DFIESL,DSEESL,DTHESL, EBSP1L,EBSP2L,EBSP3L,EBSP4L,EBSP5L & ,EBSP6L ,SPE1SL(J),SPE2SL(J),SPE3SL(J),SPE4SL(J),SPE5SL(J) & ,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,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 ' & ,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 & ,'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) & ,REIPJ(J),ESPMIP(J),J-NJ(1),ISPIS(J),RIS(J),RISJ(J) & ,ESPIS(J),REIS(J),REISJ(J),ESPMIS(J),J-NJ(1),ISPOP(J) & ,ROP(J),ROPJ(J),ESPOP(J),REOP(J) ,REOPJ(J),ESPMOP(J),J & -NJ(1),ISPOS(J),ROS(J),ROSJ(J),ESPOS(J),REOS(J),REOSJ(J) & ,ESPMOS(J) 1586 CONTINUE WRITE(21,1577) DO J=NJ(1)+1,JT(3) WRITE(21,1582) J-NJ(1),SPY(J),J,SPE(J),J,REY(J),J,EMSP(J) ENDDO 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 ,DFIES0 & ,DSEES,DTHES, EBSP(J),SPE2S(J),SPE3S(J),SPE4S(J),SPE5S(J) & ,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 & ,'SPUTTERED ENERGY(',I1,') = ',E10.4,' EV') 1536 CONTINUE DO J=JT(3)+1,LJ WRITE(21,1576) J-JT(3),ISPIP(J),RIP(J),RIPJ(J),ESPIP(J),REIP(J) & ,REIPJ(J),ESPMIP(J),J-JT(3),ISPIS(J),RIS(J),RISJ(J) & ,ESPIS(J),REIS(J),REISJ(J),ESPMIS(J),J-JT(3),ISPOP(J) & ,ROP(J),ROPJ(J),ESPOP(J),REOP(J),REOPJ(J),ESPMOP(J), & J-JT(3),ISPOS(J),ROS(J),ROSJ(J),ESPOS(J),REOS(J),REOSJ(J) & ,ESPMOS(J) ENDDO WRITE(21,1577) DO J=JT(3)+1,LJ WRITE(21,1582) J-JT(3),SPY(J),J-JT(3),SPE(J),J-JT(3),REY(J), & J-JT(3),EMSP(J) ENDDO 1532 CONTINUE C C BACKWARD SPUTTERING : ANGULAR DISTRIBUTIONS C WRITE(21,1601) 1601 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF ALL BACKWARD ', & 'SPUTTERED 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 I=1,20 DO J=1,NJ(1) KADSL(I,1)=KADSL(I,1)+KADSJ(I,J) ENDDO ENDDO DO I=1,20 DO J=NJ(1)+1,JT(3) KADSL(I,2)=KADSL(I,2)+KADSJ(I,J) ENDDO ENDDO 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 ', & 'PARTICLES ; LAYER 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),(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 ', & 'PARTICLES ; LAYER 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),(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 ', & 'PARTICLES ; LAYER 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) & ,(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 ', & 'PARTICLES ; LAYER 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) & ,(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 J=1,NJ(1) ISPALT(1) = ISPALT(1)+ITSP(J) ESPALT(1) = ESPALT(1)+ETSP(J) ENDDO DO J=NJ(1)+1,JT(3) ISPALT(2) = ISPALT(2)+ITSP(J) ESPALT(2) = ESPALT(2)+ETSP(J) ENDDO DO J=JT(3)+1,LJ ISPALT(3) = ISPALT(3)+ITSP(J) ESPALT(3) = ESPALT(3)+ETSP(J) ENDDO WRITE(21,1712) ISPAT,ESPAT 1712 FORMAT(///,8X,'ALL SPUTTERED PARTICLES = ',I7,3X & ,'TOTAL SPUTTERED ENERGY = ',E10.4,3H EV//) DO J=1,L WRITE(21,1713) J,ISPALT(J),ESPALT(J) 1713 FORMAT(8X,'SPUTTERED PARTICLES (LAYER ',I1,') = ',I7,3X & ,'SPUTTERED ENERGY = ',E10.4,3H EV) ENDDO DO 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 REOST(J)=ESPOST(J)/ESPAT ENDDO 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 J=1,LJ SPYT(J)=DBLE(ITSP(J))/DBLE(NH) SPET(J)=ETSP(J)/(NH*E0) ENDDO DO 1737 J=1,LJ IF (equal(SPYT(J),0.0D0))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 J=1,NJ(1) WRITE(21,1564) J,ITSP(J),J,ETSP(J) ENDDO DO 1734 J=1,NJ(1) WRITE(21,1581) J,ISPIPT(J),RIPT(J),ESPIPT(J),REIPT(J) & ,ESPMIPT(J),J,ISPIST(J),RIST(J),ESPIST(J),REIST(J) & ,ESPMIST(J),J,ISPOPT(J),ROPT(J),ESPOPT(J),REOPT(J) & ,ESPMOPT(J),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 & ,'ENERGY = ',E10.4,' EV',1F9.4,4X,'MEAN ENERGY = ',E10.4/ & 9X,'ION IN , SECOND. KO(',I1,') = ',I7,1F9.4,4X & ,'ENERGY = ',E10.4,' EV',1F9.4,4X,'MEAN ENERGY = ',E10.4/ & 8X,'ION OUT , PRIMARY KO(',I1,') = ',I7,1F9.4,4X & ,'ENERGY = ',E10.4,' EV',1F9.4,4X,'MEAN ENERGY = ',E10.4/ & 8X,'ION OUT , SECOND. KO(',I1,') = ',I7,1F9.4,4X & ,'ENERGY = ',E10.4,' EV',1F9.4,4X,'MEAN ENERGY = ',E10.4) WRITE(21,1577) DO J=1,NJ(1) WRITE(21,1582) J,SPYT(J),J,SPET(J),J,REYT(J),J,EMSPT(J) ENDDO 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 J=NJ(1)+1,JT(3) WRITE(21,1564) J-NJ(1),ITSP(J),J-NJ(1),ETSP(J) ENDDO DO J=NJ(1)+1,JT(3) WRITE(21,1581) J-NJ(1),ISPIPT(J),RIPT(J),ESPIPT(J),REIPT(J) & ,ESPMIPT(J) ,J-NJ(1),ISPIST(J),RIST(J),ESPIST(J),REIST(J) & ,ESPMIST(J) ,J-NJ(1),ISPOPT(J),ROPT(J),ESPOPT(J),REOPT(J) & ,ESPMOPT(J) ,J-NJ(1),ISPOST(J),ROST(J),ESPOST(J),REOST(J) & ,ESPMOST(J) ENDDO WRITE(21,1577) DO J=NJ(1)+1,JT(3) WRITE(21,1582) J-NJ(1),SPYT(J),J-NJ(1),SPET(J),J-NJ(1),REYT(J) & ,J-NJ(1),EMSPT(J) ENDDO 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 J=JT(3)+1,LJ WRITE(21,1564) J-JT(3),ITSP(J),J-JT(3),ETSP(J) ENDDO DO J=JT(3)+1,LJ WRITE(21,1581) J-JT(3),ISPIPT(J),RIPT(J),ESPIPT(J),REIPT(J) & ,ESPMIPT(J) ,J-JT(3),ISPIST(J),RIST(J),ESPIST(J),REIST(J) & ,ESPMIST(J) ,J-JT(3),ISPOPT(J),ROPT(J),ESPOPT(J),REOPT(J) & ,ESPMOPT(J) ,J-JT(3),ISPOST(J),ROST(J),ESPOST(J),REOST(J) & ,ESPMOST(J) ENDDO WRITE(21,1577) DO J=JT(3)+1,LJ WRITE(21,1582) J-JT(3),SPYT(J),J-JT(3),SPET(J),J-JT(3),REYT(J) & ,J-JT(3),EMSPT(J) ENDDO 1749 CONTINUE C C TRANSMISSION SPUTTERING : ANGULAR DISTRIBUTIONS C WRITE(21,1760) 1760 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF ALL TRANSMISSION '// & 'SPUTTERED PARTICLES'//) DO I=1,20 RKADST(I)=KADST(I)*20.D0/ISPAT ENDDO 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 I=1,20 DO J=1,NJ(1) KDSTL(I,1)=KDSTL(I,1)+KDSTJ(I,J) ENDDO ENDDO DO J=NJ(1)+1,JT(3) KDSTL(I,2)=KDSTL(I,2)+KDSTJ(I,J) ENDDO 1766 CONTINUE DO J=1,2 IF(ISPAL(J).EQ.0) GO TO 1754 DO I=1,20 RKDSTL(I,J)=KDSTL(I,J)*20.D0/ISPAL(J) ENDDO 1754 CONTINUE ENDDO DO J=1,JT(3) IF(ITSP(J).EQ.0) GO TO 1756 DO I=1,20 RKDSTJ(I,J)=KDSTJ(I,J)*20.D0/ITSP(J) ENDDO 1756 CONTINUE ENDDO WRITE(21,1776) 1776 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED ', & 'PARTICLES ; LAYER 1'//) WRITE(21,1518) (AI(I),I=1,20),(KDSTL(I,1),I=1,20) & ,(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 ', & 'PARTICLES ; LAYER 1 , SPECIES ',I1//) WRITE(21,1518) (AI(I),I=1,20),(KDSTJ(I,J),I=1,20) & ,(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 ', & 'PARTICLES ; LAYER 2'//) WRITE(21,1518) (AI(I),I=1,20),(KDSTL(I,2),I=1,20) & ,(RKDSTL(I,2),I=1,20) IF(NJ(2).EQ.1) GO TO 1800 DO J=NJ(1)+1,JT(3) WRITE(21,1790) J-NJ(1) 1790 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED ', & 'PARTICLES ; LAYER 2 , SPECIES ',I1//) WRITE(21,1518) (AI(I),I=1,20),(KDSTJ(I,J),I=1,20) & ,(RKDSTJ(I,J),I=1,20) ENDDO GO TO 1800 1764 DO I=1,20 DO J=1,NJ(2) KDSTL(I,1)=KDSTL(I,1)+KDSTJ(I,J) ENDDO DO J=NJ(2)+1,LJ-NJ(1) KDSTL(I,2)=KDSTL(I,2)+KDSTJ(I,J) ENDDO ENDDO DO 1799 J=1,2 IF(ISPALT(J+1).EQ.0) GO TO 1799 DO I=1,20 RKDSTL(I,J)=KDSTL(I,J)*20.D0/ISPALT(J+1) ENDDO 1799 CONTINUE DO 1797 J=1,LJ-NJ(1) IF(ITSP(J+NJ(1)).EQ.0) GO TO 1797 DO I=1,20 RKDSTJ(I,J)=KDSTJ(I,J)*20.D0/ITSP(J+NJ(1)) ENDDO 1797 CONTINUE WRITE(21,1771) 1771 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED ', & 'PARTICLES ; LAYER 2'//) WRITE(21,1518) (AI(I),I=1,20),(KDSTL(I,1),I=1,20) & ,(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 ', & 'PARTICLES ; LAYER 2 ; SPECIES ',I1//) WRITE(21,1518) (AI(I),I=1,20),(KDSTJ(I,J),I=1,20) & ,(RKDSTJ(I,J),I=1,20) 1775 CONTINUE 1773 CONTINUE WRITE(21,1779) 1779 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED ', & 'PARTICLES ; LAYER 3'//) WRITE(21,1518) (AI(I),I=1,20),(KDSTL(I,2),I=1,20) & ,(RKDSTL(I,2),I=1,20) IF(NJ(2).EQ.1) GO TO 1800 DO J=NJ(2)+1,LJ-NJ(1) WRITE(21,1783) J-NJ(2) 1783 FORMAT(///5X,'POLAR ANGULAR DISTRIBUTION OF SPUTTERED ', & 'PARTICLES ; LAYER 3 ; SPECIES ',I1//) WRITE(21,1518) (AI(I),I=1,20),(KDSTJ(I,J),I=1,20) & ,(RKDSTJ(I,J),I=1,20) ENDDO 1800 CONTINUE c c The file for33 is created here 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', & 5x,'imp',2x,'backsc',3x,'trans',3x,'tried',4x,'negE',3x, & 'impL1',3x,'impL2',3x,'impL3',3x,'impL4',3x,'impL5',3x & ,'impL6', 3x,'impL7',3x, 'range',6x,'straggeling',2x, 'Eback' & ,7x,'sigEback',4x,'Etrans',6x,'SigEtrans',3x, 'red. E',6x & ,'PRC') DO i=2,COLCOUNT WRITE(33,'(A246)')COLUMN(i) ENDDO WRITE(33,7801)E0keV,EsigkeV,ALPHA,ALPHASIG,NH,IIM,IB,IT,tryE,negE & ,(number_in_layer(k),k=1,7),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 End of file for33 C C TOP AND FRONT LINES FOR MATRICES C JE=DE JA=DA JG=DG DO 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 ENDDO DO 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 ENDDO DO J=2,MAXD1 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 ENDDO DO K=1,JT(3) DO J=2,NG1 MAGS(J,1,K) = (J-1)*JG MAGST(J,1,K) = (J-1)*JG MAGSA(J,1,K) = (J-1)*JG ENDDO DO J=2,NA1 MAGSA(1,J,K) = (J-1)*JA ENDDO DO 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 ENDDO DO J=2,MAXD1 MEAS(J,1,K) = J-1 MEAST(J,1,K) = J-1 ENDDO DO J=1,20 MEASL(1,J,K)=J MEASTL(1,J,K)=J ENDDO DO IG2=1,NGIK,1 DO J=2,21 MEAGS(1,IG2,J,K) = J-1 ENDDO DO J=2,MAXD1 MEAGS(J,IG2,1,K) = J-1 ENDDO ENDDO ENDDO DO IG2=1,NGIK,1 DO J=2,21 MEAGB(1,IG2,J) = J-1 MEAGT(1,IG2,J) = J-1 ENDDO DO J=2,MAXD1 MEAGB(J,IG2,1) = J-1 MEAGT(J,IG2,1) = J-1 ENDDO ENDDO DO I=2,74 ELOG(I)=10.D0**(I/12.D0)*10.D0**(-7.D0/6.D0) ENDDO 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*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 &KWARD 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), & easl(ies,j) enddo write (6, 1858) elog(75), (measl(75,ias,j),ias=1,21),easl(75,j) 1858 FORMAT(1X,1E12.4,20I5,I6,1E12.4) WRITE(21,1884) J 1884 FORMAT(//,' ENERGY(E/E0 IN %) - ', & 'POLAR ANGLE IN COS-INTERVALS (0.05) ', & '(BACKWARD SPUTTERED PARTICLES) , 1.LAYER , SPECIES',I2/) do ima = MAXD1,1,-1 if(meas(ima,22,j).ne.0) goto 1883 enddo ima = 1 1883 ima = min(ima+2,MAXD1) 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) 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) ', & 'AT AZIMUTHAL ANGLE =',F5.1, & ' (BACKWARD SPUTTERED ATOMS) , 1.LAYER , SPECIES',I2/) do ima = MAXD1,1,-1 if(meags(ima,ig2,22,j).ne.0) goto 1885 enddo ima = 1 1885 ima = min(ima+2,MAXD1) 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) 1870 CONTINUE WRITE(21,1889) J 1889 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN DEGREES ', & '(BACKWARD 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) ', & ' (BACKWARD SPUTTERED PARTICLES) , 1.LAYER , SPECIES',I2/) 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) ', & '(BACKWARD 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), & easl(ies,j) enddo write (6, 1858) elog(75),(measl(75,ias,j),ias=1,21),easl(75,j) WRITE(21,1894) J-NJ(1) 1894 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS ', & '(0.05) (BACKWARD SPUTTERED PARTICLES) , 2.LAYER , SPECIES', & I2/) do ima = MAXD1,1,-1 if(meas(ima,22,j).ne.0) goto 1895 enddo ima = 1 1895 ima = min(ima+2,MAXD1) WRITE(21,1886)((meas(iesp,iags,j),iags=1,22),iesp=1,ima) WRITE(21,1886)(meas(102,iags,j),iags=1,22) 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/) 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*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. 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), & eastl(ies,j) enddo write (6, 1858) elog(75), (meastl(75,ias,j),ias=1,21),eastl(75,j) WRITE(21,1984) J 1984 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS ', & '(0.05) ', & '(FORWARD SPUTTERED PARTICLES) , 1.LAYER , SPECIES',I2/) do ima = MAXD1,1,-1 if(meast(ima,22,j).ne.0) goto 1983 enddo ima = 1 1983 ima = min(ima+2,MAXD1) write (6, 1886) ((meast(iesp,iags,j),iags=1,22),iesp=1,ima) write (6, 1886) (meast(102,iags,j),iags=1,22) WRITE(21,1988) J 1988 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS ', & '(0.05) ', & ' (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) ,', & ' 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), & eastl(ies,j) enddo write (6, 1858) elog(75), (meastl(75,ias,j),ias=1,21) , & eastl(75,j) WRITE(21,1994) J-JTK+1 1994 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS ', & '(0.05) (FORWARD SPUTTERED PARTICLES) , 2.LAYER , SPECIES',I2/) do ima = MAXD1,1,-1 if(meast(ima,22,j).ne.0) goto 1995 enddo ima = 1 1995 ima = min(ima+2,MAXD1) WRITE(21,1886)((meast(iesp,iags,j),iags=1,22),iesp=1,ima) WRITE(21,1886)(meast(102,iags,j),iags=1,22) WRITE(21,1998) J-JTK+1 1998 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS ', & '(0.05) (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) ', & '(FORWARD 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) , & eastl(ies,j) end do write (6, 1858) elog(75), (meastl(75,ias,j),ias=1,21) , & eastl(75,j) WRITE(21,1975) J-NJ(2) 1975 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS ', & '(0.05) (FORWARD SPUTTERED PARTICLES) , 3.LAYER , SPECIES',I2/) do ima = MAXD1,1,-1 if(meast(ima,22,j).ne.0) goto 1977 enddo ima = 1 1977 ima = min(ima+2,MAXD1) WRITE(21,1886)((meast(iesp,iags,j),iags=1,22),iesp=1,ima) WRITE(21,1886)(meast(102,iags,j),iags=1,22) WRITE(21,1978) J-NJ(2) 1978 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS ', & '(0.05) (FORWARD SPUTTERED PARTICLES) , 3.LAYER , SPECIES',I2/) WRITE(21,1886) ((MAGST(IG,IAGS,J),IAGS=1,22),IG=1,62) 1972 CONTINUE 2000 CONTINUE C C BACKSCATTERING : MATRICES , ENERGY - ANGULAR CORRELATIONS C IF(IB.LT.10000) GO TO 2100 DO J=1,20 MEABL(1,J)=J ENDDO EABL(2)=DBLE(MEABL(2,21))/(DBLE(NH)*0.1D0) DO IERLOG=3,74 EABL(IERLOG)=DBLE(MEABL(IERLOG,21))/(TEMPNH*10.D0**((IERLOG-1) & /12.D0)) ENDDO WRITE(21,2006) 2006 FORMAT(//,' LOG ENERGY - COS OF EMISSION ANGLE (0.05 STEPS) ', & '(BACKSCATTERED 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) IF(ALPHA.LT.1.) GO TO 2010 DO IG2=1,NGIK,1 EEE = IG2*DGI WRITE(21,2014) EEE 2014 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS ', & '(0.05) AT AZIMUTHAL ANGLE =',F5.1, & ' (BACKSCATTERED PROJECTILES)'/) do ima = MAXD1,1,-1 if(meagb(ima,ig2,22).ne.0) goto 2015 enddo ima = 1 2015 ima = min(ima+2,MAXD1) write (6, 1886) ((meagb(ie,ig2,iagb),iagb=1,22),ie=1,ima) write (6, 1886) (meagb(102,ig2,iagb),iagb=1,22) ENDDO 2010 CONTINUE IF(E0.LT.0.) GO TO 2052 WRITE(21,2016) 2016 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS ', & '(0.05) (BACKSCATTERED PROJECTILES)'/) GO TO 2054 2052 WRITE(21,2056) 2056 FORMAT(//,' ENERGY(E IN 0.1*TI) - POLAR ANGLE IN COS-INTERVALS ', & '(0.05) (BACKSCATTERED PROJECTILES)'/) do ima = MAXD1,1,-1 if(meab(ima,22).ne.0) goto 2017 enddo ima = 1 2017 ima = min(ima+2,MAXD1) write (6, 1886) ((meab(ie,iagb),iagb=1,22),ie=1,ima) write (6, 1886) (meab(102,iagb),iagb=1,22) 2054 continue WRITE(21,2018) 2018 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS ', & '(0.05) (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 ', & '(0.05) (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 IG=2,NG WRITE(21,2026) EMA(IG,1),(EMA(IG,IAGB),IAGB=12,22) ENDDO 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) 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 J=1,20 MEATL(1,J)=J ENDDO EATL(2)=DBLE(MEATL(2,21))/(DBLE(NH)*0.1D0) DO IERLOG=3,74 EATL(IERLOG)=DBLE(MEATL(IERLOG,21))/(TEMPNH* 10.D0**((IERLOG-1) & /12.D0)) ENDDO WRITE(21,2106) 2106 FORMAT(//,' LOG ENERGY - COS OF EMISSION ANGLE (0.05 STEPS) ', & '(TRANSMITTED 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) enddo WRITE(21,1858)elog(75),(meatl(75,iag),iag=1,21),eatl(75) IF(ALPHA.LT.1.) GO TO 2110 DO IG2=1,NGIK,1 EEE = IG2*DGI WRITE(21,2114) EEE 2114 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS ', & '(0.05) AT AZIMUTHAL ANGLE =',F5.1, & ' (TRANSMITTED PROJECTILES)'/) do ima = MAXD1,1,-1 if(meagt(ima,ig2,22).ne.0) goto 2115 enddo ima = 1 2115 ima = min(ima+2,MAXD1) write (21,1886) ((meagt(ie,ig2,iagb),iagb=1,22),ie=1,ima) write (21,1886) (meagt(102,ig2,iagb),iagb=1,22) ENDDO 2110 CONTINUE WRITE(21,2116) 2116 FORMAT(//,' ENERGY(E/E0 IN %) - POLAR ANGLE IN COS-INTERVALS ', & '(0.05) (TRANSMITTED PROJECTILES)'/) do ima = MAXD1,1,-1 if(meat(ima,22).ne.0) goto 2117 enddo ima = 1 2117 ima = min(ima+2,MAXD1) write (6, 1886) ((meat(ie,iagb),iagb=1,22),ie=1,ima) write (6, 1886) (meat(102,iagb),iagb=1,22) WRITE(21,2118) 2118 FORMAT(//,' AZIMUTHAL ANGLE - POLAR ANGLE IN COS-INTERVALS ', & '(0.05) (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 ', & '(0.05) (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 IG=2,NG WRITE(21,2126) EMAT(IG,1),(EMAT(IG,IAGB),IAGB=12,22) ENDDO 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) 9000 CONTINUE CLOSE(UNIT=21) CLOSE(UNIT=22) CLOSE(UNIT=99) 8000 STOP END SUBROUTINE MOMENTS(FIM0,SEM,THM,FOM,FIM,SIM,SIGMA,DFIM0,DSEM,DTHM, # X1S,X2S,X3S,X4S,X5S,X6S,Y) 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 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 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) 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 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 SUBROUTINE MOMENT(X1SY,X2SY,X3SY,X4SY,X5SY,X6SY ,X1S,X2S,X3S,X4S & ,X5S,X6S,Y) IMPLICIT NONE REAL*8 X1SY,X2SY,X3SY,X4SY,X5SY,X6SY,X1S,X2S,X3S,X4S,X5S,X6S,Y LOGICAL EQUAL 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 SUBROUTINE DIRCOS(COSX,COSY,COSZ,SINE,CPSI,SPSI,CPHI,SPHI,N) 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 DO 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)) ENDDO RETURN END SUBROUTINE VELOCV(FG,FFG,E,COSX,COSY,COSZ,SINE,N) 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 CALL FGAUSS(FG,2*N,N,FFG,N) DO I=1,N VELX=DSQRT((FFG(I)*ZARG)**2+VELC) VELY=FG(I)*ZARG VELZ=FG(I+N)*ZARG 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 ENDDO RETURN END SUBROUTINE VELOC(E,COSX,COSY,COSZ,SINE) C C FETCH A NEW VELOCITY FROM A MAXWELLIAN FLUX AT A SURFACE C 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 IF (INIV1.EQ.0) CALL FGAUSS(FG,INIV1,64,FFG,INIV3) VELX=FFG(INIV3)*ZARG VELY=FG(INIV1)*ZARG VELZ=FG(INIV1-1)*ZARG IF (VELC.GT.0.) THEN VELX=DSQRT(VELC+VELX**2) ENDIF INIV1=INIV1-2 INIV3=INIV3-1 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 RETURN END SUBROUTINE FGAUSS (FG,IND,IANZ,FFG,IND2) 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 DO JJ=1,IANZ C 1. COMPUTE THE SINE AND COSINE OF 2*PI*RAN(1) C call ranlux(ran2, 2) ZZ=PI2*DBLE(ran2(1)) ZSIN=DSIN(ZZ) ZCOS=DCOS(ZZ) AR=DLOG(DBLE(ran2(2))) ZT=DSQRT(-1.0D0*(AR+AR)) FG(JJ+IANZ)=ZT*ZSIN FG(JJ)=ZT*ZCOS ENDDO C C RETURN IANZ RANDOM NUMBERS FROM A GAUSSIAN FLUX IN THE ARRAY FFG C IND2=IANZ DO JJ=1,IANZ call ranlux(random, 1) AR=DLOG(DBLE(random)) FFG(JJ)=DSQRT(-1.D0*(AR+AR)) ENDDO RETURN END SUBROUTINE ENERGV(FE,E,COSX,COSY,COSZ,SINE,N) 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 CALL EMAXW(FE,N) DO 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 ENDDO RETURN END SUBROUTINE ENERG(E,COSX,COSY,COSZ,SINE) 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 CALL EMAXW(FE,16) 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 RETURN END SUBROUTINE EMAXW (FE,NUMB) 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/ DO I=1,NUMB call ranlux(random, 3) AR1=DLOG(DBLE(random(1))) AR2=DLOG(DBLE(random(2)))*(DCOS(PI*0.5*DBLE(random(3))))**2 FE(I)=DSQRT(-1.D0*(AR1+AR2)) ENDDO RETURN END REAL*8 FUNCTION CVMGT(A, B, C) IMPLICIT NONE REAL*8 A,B LOGICAL C CVMGT = B IF ( C ) CVMGT = A RETURN END 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 J = 1,IM B(JB) = A(JA) JA = JA + INCA JB = JB + INCB ENDDO RETURN END FUNCTION ILLZ(N,A,K) IMPLICIT NONE LOGICAL A(*) INTEGER K,L,N,I INTEGER*4 ILLZ IF(K.GT.0) THEN L=N+1 DO I=N,1,-1 IF(A(I)) L=I ENDDO ELSE L=0 DO I=1,N IF(A(I)) L=I ENDDO L=N+1-L ENDIF ILLZ=L-1 RETURN END INTEGER FUNCTION ISRCHFGE(N,ARRAY,INC,TARGT) IMPLICIT NONE INTEGER I,N,J,INC REAL*8 ARRAY(N) REAL*8 TARGT J=1 IF(INC.LT.0) J=N*(-INC) DO I=1,N IF(ARRAY(J).GE.TARGT) GO TO 200 J=J+INC ENDDO 200 ISRCHFGE=I RETURN END INTEGER FUNCTION ISRCHFGT(N,ARRAY,INC,TARGT) IMPLICIT NONE INTEGER I,N,J,INC REAL*8 ARRAY(N),TARGT J=1 IF(INC.LT.0) J=N*(-INC) DO I=1,N IF(ARRAY(J).GT.TARGT) GO TO 200 J=J+INC ENDDO 200 ISRCHFGT=I RETURN END INTEGER FUNCTION ISRCHEQ(N,ARRAY,INC,TARGT) IMPLICIT NONE INTEGER I,N,J,INC REAL*8 ARRAY(N),TARGT J=1 IF(INC.LT.0) J=N*(-INC) DO I=1,N IF(ARRAY(J).EQ.TARGT) GO TO 200 J=J+INC ENDDO 200 ISRCHEQ=I RETURN END SUBROUTINE ENERGGAUSS(ISEED2,Esig,Epar,E0) 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 RETURN END SUBROUTINE ALPHAGAUSS(ISEED3,ALPHASIG,ALPHA,ALFA,ALPHApar, CALFA & ,SALFA,BW) 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) RETURN END 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 SUBROUTINE TimeStamp(day,month,year,hour,min,sec,seconds_total) C Subroutine to return date and time for start/stop of simulation IMPLICIT NONE INTEGER Date_Time(8) INTEGER*4 days_total INTEGER*4 seconds_total CHARACTER Real_Clock(3)*12 CHARACTER month*4,day*2 CHARACTER year*4,hour*2 CHARACTER min*2,sec*2 CALL DATE_AND_TIME(Real_Clock(1),Real_Clock(2),Real_Clock(3), & Date_Time) IF(Date_Time(2).EQ.1) THEN month='Jan.' days_total=Date_Time(3) ELSEIF(Date_Time(2).EQ.2) THEN month='Feb.' days_total=31+Date_Time(3) ELSEIF(Date_Time(2).EQ.3) THEN month='Mar.' days_total=31+28+Date_Time(3) ELSEIF(Date_Time(2).EQ.4) THEN month='Apr.' days_total=31+28+31+Date_Time(3) ELSEIF(Date_Time(2).EQ.5) THEN month='May ' days_total=31+28+31+30+Date_Time(3) ELSEIF(Date_Time(2).EQ.6) THEN month='Jun.' days_total=31+28+31+30+31+Date_Time(3) ELSEIF(Date_Time(2).EQ.7) THEN month='Jul.' days_total=31+28+31+30+31+30+Date_Time(3) ELSEIF(Date_Time(2).EQ.8) THEN month='Aug.' days_total=31+28+31+30+31+30+31+Date_Time(3) ELSEIF(Date_Time(2).EQ.9) THEN month='Sep.' days_total=31+28+31+30+31+30+31+31+Date_Time(3) ELSEIF(Date_Time(2).EQ.10) THEN month='Oct.' days_total=31+28+31+30+31+30+31+31+30+Date_Time(3) ELSEIF(Date_Time(2).EQ.11) THEN month='Nov.' days_total=31+28+31+30+31+30+31+31+30+31+Date_Time(3) ELSE month='Dec.' days_total=31+28+31+30+31+30+31+31+30+31+30+Date_Time(3) ENDIF C in seconds from beginning of year seconds_total=Date_Time(7)+(Date_Time(6)*60)+(Date_Time(5) *3600) & +(days_total-1)*86400 READ(Real_Clock(1)(1:4),'(A4)')year READ(Real_Clock(1)(7:8),'(A2)')day READ(Real_Clock(2)(1:2),'(A2)')hour READ(Real_Clock(2)(3:4),'(A2)')min READ(Real_Clock(2)(5:6),'(A2)')sec RETURN END INTEGER FUNCTION OldNew(filename) C This funnction returns 0 for old input format and 1 for new input C format CHARACTER filename*12 REAL dummy(21) INTEGER idummy C Assume old format OldNew = 0 C Read first three lines, the third line differs between the two C format OPEN(UNIT=11,file=filename,STATUS='unknown') READ(11,*) READ(11,*) READ(11,*,ERR=10) dummy(1),dummy(2),dummy(3),dummy(4),dummy(5) & ,dummy(6),dummy(7),dummy(8),dummy(9),dummy(10),dummy(11) & ,dummy(12),dummy(13),dummy(14),dummy(15),dummy(16),dummy(17) & ,dummy(18),dummy(19),dummy(20),dummy(21) GOTO 20 C If you got here it means that the file in in the old format 10 OldNew = 1 20 CLOSE(11) if (OldNew.eq.1) then write(*,*) "The input file is in the new format" else write(*,*) "The input file is in the old format" endif RETURN END SUBROUTINE RANLUX(RVEC,LENV) C Subtract-and-borrow random number generator proposed by C Marsaglia and Zaman, implemented by F. James with the name C RCARRY in 1991, and later improved by Martin Luescher C in 1993 to produce "Luxury Pseudorandom Numbers". C Fortran 77 coded by F. James, 1993 C C LUXURY LEVELS. C ------ ------ The available luxury levels are: C C level 0 (p=24): equivalent to the original RCARRY of Marsaglia C and Zaman, very long period, but fails many tests. C level 1 (p=48): considerable improvement in quality over level 0, C now passes the gap test, but still fails spectral test. C level 2 (p=97): passes all known tests, but theoretically still C defective. C level 3 (p=223): DEFAULT VALUE. Any theoretically possible C correlations have very small chance of being observed. C level 4 (p=389): highest possible luxury, all 24 bits chaotic. C C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C!!! Calling sequences for RANLUX: ++ C!!! CALL RANLUX (RVEC, LEN) returns a vector RVEC of LEN ++ C!!! 32-bit random floating point numbers between ++ C!!! zero (not included) and one (also not incl.). ++ C!!! CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from ++ C!!! one 32-bit integer INT and sets Luxury Level LUX ++ C!!! which is integer between zero and MAXLEV, or if ++ C!!! LUX .GT. 24, it sets p=LUX directly. K1 and K2 ++ C!!! should be set to zero unless restarting at a break++ C!!! point given by output of RLUXAT (see RLUXAT). ++ C!!! CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++ C!!! which can be used to restart the RANLUX generator ++ C!!! at the current point by calling RLUXGO. K1 and K2++ C!!! specify how many numbers were generated since the ++ C!!! initialization with LUX and INT. The restarting ++ C!!! skips over K1+K2*E9 numbers, so it can be long.++ C!!! A more efficient but less convenient way of restarting is by: ++ C!!! CALL RLUXIN(ISVEC) restarts the generator from vector ++ C!!! ISVEC of 25 32-bit integers (see RLUXUT) ++ C!!! CALL RLUXUT(ISVEC) outputs the current values of the 25 ++ C!!! 32-bit integer seeds, to be used for restarting ++ C!!! ISVEC must be dimensioned 25 in the calling program ++ C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ DIMENSION RVEC(LENV) DIMENSION SEEDS(24), ISEEDS(24), ISDEXT(25) PARAMETER (MAXLEV=4, LXDFLT=3) DIMENSION NDSKIP(0:MAXLEV) DIMENSION NEXT(24) PARAMETER (TWOP12=4096., IGIGA=1000000000,JSDFLT=314159265) PARAMETER (ITWO24=2**24, ICONS=2147483563) SAVE NOTYET, I24, J24, CARRY, SEEDS, TWOM24, TWOM12, LUXLEV SAVE NSKIP, NDSKIP, IN24, NEXT, KOUNT, MKOUNT, INSEED INTEGER LUXLEV LOGICAL NOTYET DATA NOTYET, LUXLEV, IN24, KOUNT, MKOUNT /.TRUE., LXDFLT, 0,0,0/ DATA I24,J24,CARRY/24,10,0./ C default C Luxury Level 0 1 2 *3* 4 DATA NDSKIP/0, 24, 73, 199, 365 / Corresponds to p=24 48 97 223 389 C time factor 1 2 3 6 10 on slow workstation C 1 1.5 2 3 5 on fast mainframe C C NOTYET is .TRUE. if no initialization has been performed yet. C Default Initialization by Multiplicative Congruential IF (NOTYET) THEN NOTYET = .FALSE. JSEED = JSDFLT INSEED = JSEED LUXLEV = LXDFLT NSKIP = NDSKIP(LUXLEV) LP = NSKIP + 24 IN24 = 0 KOUNT = 0 MKOUNT = 0 TWOM24 = 1. DO 25 I= 1, 24 TWOM24 = TWOM24 * 0.5 K = JSEED/53668 JSEED = 40014*(JSEED-K*53668) -K*12211 IF (JSEED .LT. 0) JSEED = JSEED+ICONS ISEEDS(I) = MOD(JSEED,ITWO24) 25 CONTINUE TWOM12 = TWOM24 * 4096. DO 50 I= 1,24 SEEDS(I) = REAL(ISEEDS(I))*TWOM24 NEXT(I) = I-1 50 CONTINUE NEXT(1) = 24 I24 = 24 J24 = 10 CARRY = 0. IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24 ENDIF C C The Generator proper: "Subtract-with-borrow", C as proposed by Marsaglia and Zaman, C Florida State University, March, 1989 C DO 100 IVEC= 1, LENV UNI = SEEDS(J24) - SEEDS(I24) - CARRY IF (UNI .LT. 0.) THEN UNI = UNI + 1.0 CARRY = TWOM24 ELSE CARRY = 0. ENDIF SEEDS(I24) = UNI I24 = NEXT(I24) J24 = NEXT(J24) RVEC(IVEC) = UNI C small numbers (with less than 12 "significant" bits) are "padded". IF (UNI .LT. TWOM12) THEN RVEC(IVEC) = RVEC(IVEC) + TWOM24*SEEDS(J24) C and zero is forbidden in case someone takes a logarithm IF (RVEC(IVEC) .EQ. 0.) RVEC(IVEC) = TWOM24*TWOM24 ENDIF C Skipping to luxury. As proposed by Martin Luscher. IN24 = IN24 + 1 IF (IN24 .EQ. 24) THEN IN24 = 0 KOUNT = KOUNT + NSKIP DO 90 ISK= 1, NSKIP UNI = SEEDS(J24) - SEEDS(I24) - CARRY IF (UNI .LT. 0.) THEN UNI = UNI + 1.0 CARRY = TWOM24 ELSE CARRY = 0. ENDIF SEEDS(I24) = UNI I24 = NEXT(I24) J24 = NEXT(J24) 90 CONTINUE ENDIF 100 CONTINUE KOUNT = KOUNT + LENV IF (KOUNT .GE. IGIGA) THEN MKOUNT = MKOUNT + 1 KOUNT = KOUNT - IGIGA ENDIF RETURN C C Entry to input and float integer seeds from previous run ENTRY RLUXIN(ISDEXT) NOTYET = .FALSE. TWOM24 = 1. DO 195 I= 1, 24 NEXT(I) = I-1 195 TWOM24 = TWOM24 * 0.5 NEXT(1) = 24 TWOM12 = TWOM24 * 4096. WRITE(6,'(A)') ' FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS:' WRITE(6,'(5X,5I12)') ISDEXT DO 200 I= 1, 24 SEEDS(I) = REAL(ISDEXT(I))*TWOM24 200 CONTINUE CARRY = 0. IF (ISDEXT(25) .LT. 0) CARRY = TWOM24 ISD = IABS(ISDEXT(25)) I24 = MOD(ISD,100) ISD = ISD/100 J24 = MOD(ISD,100) ISD = ISD/100 IN24 = MOD(ISD,100) ISD = ISD/100 LUXLEV = ISD IF (LUXLEV .LE. MAXLEV) THEN NSKIP = NDSKIP(LUXLEV) WRITE (6,'(A,I2)') ' RANLUX LUXURY LEVEL SET BY RLUXIN TO: ', + LUXLEV ELSE IF (LUXLEV .GE. 24) THEN NSKIP = LUXLEV - 24 WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXIN TO:',LUXLEV ELSE NSKIP = NDSKIP(MAXLEV) WRITE (6,'(A,I5)') ' RANLUX ILLEGAL LUXURY RLUXIN: ',LUXLEV LUXLEV = MAXLEV ENDIF INSEED = -1 RETURN C C Entry to ouput seeds as integers ENTRY RLUXUT(ISDEXT) DO 300 I= 1, 24 ISDEXT(I) = INT(SEEDS(I)*TWOP12*TWOP12) 300 CONTINUE ISDEXT(25) = I24 + 100*J24 + 10000*IN24 + 1000000*LUXLEV IF (CARRY .GT. 0.) ISDEXT(25) = -ISDEXT(25) RETURN C C Entry to output the "convenient" restart point ENTRY RLUXAT(LOUT,INOUT,K1,K2) LOUT = LUXLEV INOUT = INSEED K1 = KOUNT K2 = MKOUNT RETURN C C Entry to initialize from one or three integers ENTRY RLUXGO(LUX,INS,K1,K2) IF (LUX .LT. 0) THEN LUXLEV = LXDFLT ELSE IF (LUX .LE. MAXLEV) THEN LUXLEV = LUX ELSE IF (LUX .LT. 24 .OR. LUX .GT. 2000) THEN LUXLEV = MAXLEV WRITE (6,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ',LUX ELSE LUXLEV = LUX DO 310 ILX= 0, MAXLEV IF (LUX .EQ. NDSKIP(ILX)+24) LUXLEV = ILX 310 CONTINUE ENDIF IF (LUXLEV .LE. MAXLEV) THEN NSKIP = NDSKIP(LUXLEV) WRITE(6,'(A,I2,A,I4)') ' RANLUX LUXURY LEVEL SET BY RLUXGO :', + LUXLEV,' P=', NSKIP+24 ELSE NSKIP = LUXLEV - 24 WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXGO TO:',LUXLEV ENDIF IN24 = 0 IF (INS .LT. 0) WRITE (6,'(A)') + ' Illegal initialization by RLUXGO, negative input seed' IF (INS .GT. 0) THEN JSEED = INS WRITE(6,'(A,3I12)') ' RANLUX INITIALIZED BY RLUXGO FROM SEEDS', + JSEED, K1,K2 ELSE JSEED = JSDFLT WRITE(6,'(A)')' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED' ENDIF INSEED = JSEED NOTYET = .FALSE. TWOM24 = 1. DO 325 I= 1, 24 TWOM24 = TWOM24 * 0.5 K = JSEED/53668 JSEED = 40014*(JSEED-K*53668) -K*12211 IF (JSEED .LT. 0) JSEED = JSEED+ICONS ISEEDS(I) = MOD(JSEED,ITWO24) 325 CONTINUE TWOM12 = TWOM24 * 4096. DO 350 I= 1,24 SEEDS(I) = REAL(ISEEDS(I))*TWOM24 NEXT(I) = I-1 350 CONTINUE NEXT(1) = 24 I24 = 24 J24 = 10 CARRY = 0. IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24 C If restarting at a break point, skip K1 + IGIGA*K2 C Note that this is the number of numbers delivered to C the user PLUS the number skipped (if luxury .GT. 0). KOUNT = K1 MKOUNT = K2 IF (K1+K2 .NE. 0) THEN DO 500 IOUTER= 1, K2+1 INNER = IGIGA IF (IOUTER .EQ. K2+1) INNER = K1 DO 450 ISK= 1, INNER UNI = SEEDS(J24) - SEEDS(I24) - CARRY IF (UNI .LT. 0.) THEN UNI = UNI + 1.0 CARRY = TWOM24 ELSE CARRY = 0. ENDIF SEEDS(I24) = UNI I24 = NEXT(I24) J24 = NEXT(J24) 450 CONTINUE 500 CONTINUE C Get the right value of IN24 by direct calculation IN24 = MOD(KOUNT, NSKIP+24) IF (MKOUNT .GT. 0) THEN IZIP = MOD(IGIGA, NSKIP+24) IZIP2 = MKOUNT*IZIP + IN24 IN24 = MOD(IZIP2, NSKIP+24) ENDIF C Now IN24 had better be between zero and 23 inclusive IF (IN24 .GT. 23) THEN WRITE (6,'(A/A,3I11,A,I5)') + ' Error in RESTARTING with RLUXGO:',' The values', INS, + K1, K2, ' cannot occur at luxury level', LUXLEV IN24 = 0 ENDIF ENDIF RETURN END