C TM MODIFICATIONS C **************** C*IN OPINIT ROUTINE : C WRITE(LJOBLO,70) L,ML C 70 FORMAT(' OPINIT: L=',I4,' ML=',I4) => I7 I7 C*IN (OPAC, TABINI, INJON, INABS, ELMCMP, ABSKO, C TABS, JON, MOL, DETABS, ELMCLL, INTERV, C HSEINT, RDBMET, WRBMET, OPINIT) ROUTINES : C ML=1500 => ML=30000 C*IN (OPAC, INJON, INABS, INLIN, TABS, JON, DETABS) ROUTINES : ADD OF C ADD TM C WRITE(*,*)'***** ROUTINE EXECUTED.' C END ADD TM C*IN INABS ROUTINE : C NABDIM=200000 => NABDIM=3000000 C*IN (OPAC, TABINI, INABS, ABSKO, TABS, C DETABS, RDBMET, WRBET, OPINIT) ROUTINES : C ABKOF(200000) => ABKOF(3000000) C*IN INABS ROUTINE C 205 FORMAT(' DIMENSION ALLOWED =',I5,5X,'TOO SMALL ***INABS***') => I7 C ADD TM C WRITE(IWRIT,'(A,I10)')'NABKOF= ', NABKOF C END ADD TM C: 09-09-24 MODIFICATIONS: (MATS CARLSSON) C: CORRECTED ERROR IN ABMIN, ABMAX PRINTOUT TO JOBLOG C: C: 09-09-24 MODIFICATIONS: (MATS CARLSSON) C: EXCLUDE LINE OPACITIES FROM ABSLIN IF IWIDE.EQ.0 C* IN GENCOL MODIFICATION OF CI FORMULA: C TM MODIFICATION: SEATON FORMULA FOR IONISATION RATE C CUP = NE(K) * CT * EXP(-DEKT) * SQRT(TEMP(K)) C IF(ION(ILO).EQ.1) GBAR_TM = 0.1 C IF(ION(ILO).EQ.2) GBAR_TM = 0.2 C IF(ION(ILO).GE.3) GBAR_TM = 0.3 C CUP = NE(K)*CT*1.55E13*GBAR_TM*EXP(-DEKT)/TEMP(K)**0.5/DEKT C END TM MODIFICATION C I COMMENT FOLLOWING LINES C IF(K.EQ.1) THEN C X55=5.5 C M=4 C CALL TAUTSP(TGRID,CGRID,NTEMP,X55,WORK,TGRD, C * CGRD,NTMP,M,IFLAG) C ENDIF C*IN OPACU, TO CHECK THAT THE CONTINUOUS OPACITY IS NOT COUNTED TWICE CC ADD TM C WRITE(*,*)'LVNAME = ',LVNAME(L), 'LABEL = ',LABEL(IRAD(KR)) CC END ADD TM CC ADD TM C READ(*,*) C END ADD TM C C***FOR FEI/II C* IN (OPAC, TABINI, INJON, INABS, ELMCMP, ABSKO, C TABS, JON, MOL, DETABS, ELMCLL, INTERV, C HSEINT, RDBMET, WRBMET, OPINIT) ROUTINES : C ML=30000 => ML=50000 C*IN (OPAC, TABINI, INABS, ABSKO, TABS, C DETABS, RDBMET, WRBET, OPINIT) ROUTINES : C ABKOF(3000000) => ABKOF(30000000) C*IN INABS ROUTINE : C NABDIM=3000000 => NABDIM=30000000 C C CHANGE IN GENCOL OF THE POSITION OF NTEMP = 1 => PUT OUTSIDE THE LOOP C OTHERWISE, NO INTERPOLATION C USE OF CSPLINE RATHER THAN PPVALU FOR INTERPOLATION (PB WITH PPVALU) C C COMMENT OF 'CI' KEY IN INTERPOLATION TO AVOID ERROR IN MULTI C (TEMPORARY SOLUTION) NEED TO IMPROVE FORMATO C C*********************************************************************** C SUBROUTINE OPAC(ICALL) C C GIVES STANDARD AND BACKGROUND OPACITIES C C XNORM : STANDARD OPACITY, UNIT CM**2 PER CM**3 C XCONT : CONTINUUM OPACITY, RELATIVE TO STANDARD OPACITY C TOTN : TOTAL POPULATION DENSITY OF ATOM C C ROUTINES OPINIT AND ABSKO ARE TO BE FOUND IN OPACITY PACKAGE C C BACKGROUND SOURCE FUNCTIONS ARE INITIALIZED WITH THE ASSUMPTION C J=0 FOR THE SCATTERING. CONTINUA CALCULATED IN DETAIL ARE NOT C INCLUDED IN THE BACKGROUND OPACITY C C: C: OPAC 88-01-21 MODIFICATIONS: (MATS CARLSSON) C: THIS IS A VERSION USING THE UPPSALA BACKGROUND OPACITY PACKAGE C: MODIFIED FOR THE INCLUSION OF NON-LTE EFFECTS C: C: 90-12-28 MODIFICATIONS: (MATS CARLSSON) C: INITIALIZING JNY, XCONT, SCAT AND SC (NDEP+1:MDEP) C: TO ZERO TO ENABLE I/O OF WHOLE ARRAY C: C: 91-02-04 MODIFICATIONS: (MATS CARLSSON) C: RECORD LENGTH OF JNY CHANGED TO MDEP TO SPEED UP I/O C: C: 95-08-21 MODIFICATIONS: (MATS CARLSSON) C: WARNING MESSAGE TO JOBLOG IF ABUNDANCE AFFECTED BY MOLECULES C: OR IF ABUNDANCE IS TAKEN FROM FILE ABUND AND NOT EQUAL TO C: VALUE IN FILE ATOM C: C: 09-09-24 MODIFICATIONS: (MATS CARLSSON) C: CORRECTED ERROR IN ABMIN, ABMAX PRINTOUT TO JOBLOG C: C: 09-09-24 MODIFICATIONS: (MATS CARLSSON) C: EXCLUDE LINE OPACITIES FROM ABSLIN IF IWIDE.EQ.0 C: INCLUDE 'PREC' INCLUDE 'PARAM' INCLUDE 'CATOM' INCLUDE 'CATMOS' INCLUDE 'CATMO2' INCLUDE 'CSLINE' INCLUDE 'CCONST' INCLUDE 'CINPUT' INCLUDE 'CLU' C PARAMETER (MT=300,MKOMP=150,ML=50000,MSET=1,MLATB=50,MTETB=30, * MELMAX=2,MKOMPR=MKOMP,MKOMPT=10, * KFADIM=MKOMPR*MT+MKOMPT*MT*3,IFADIM=MKOMPT*MT) COMMON/CA2/ABKOF(30000000),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP INCLUDE 'CALIN' C CHARACTER*20 ABNAME,LVNAME COMMON/CNAME/ ABNAME(MKOMP),LVNAME(MKOMP) C C* C* 88-06-20 ADDITION (P. JUDGE): GET UNIT NUMBERS TO DELETE LARGE WORK FILES COMMON/CFIL/IRESET(MSET),ISLASK,IREAT C* 88-06-20 END C* C LOGICAL HLTE REAL NHYD,NPIN COMMON/CIN/ NHYD(MT,5),NPIN(MT),HLTE C COMMON/COUT/ TOTH(MT),TOTHI(MT),TOTH2(MT), * TOTCH(MT),TOTCO(MT),TOTCN(MT), * TOTC(MT),TOTNIT(MT),TOTO(MT), * BHYD(MT,5),GRPH C COMMON/CABSB/ ABSLTE(MT),KMPEXC REAL PE(MT),ABSK(MT),SPRID(MT) C CHARACTER*4 ELEMID LOGICAL LABUND C C ADD TM WRITE(*,*)'OPAC ROUTINE STARTS NOW.' C END ADD TM C C INITIALIZE JNY,XCONT,SCAT,SC (NDEP+1:MDEP) TO ZERO C DO 5 K=NDEP+1,MDEP JNY(K)=0.0 XCONT(K)=0.0 SC(K)=0.0 SCAT(K)=0.0 5 CONTINUE C C INITIALIZE OPACITY ROUTINES AND JNY C IF(ICALL.EQ.0) THEN CALL OPINIT CALL OPEN(LJNY,'JNY',MDEP,'UNKNOWN') DO 10 K=1,NDEP JNY(K)=0.0 TOTH(K)=0.0 10 CONTINUE IREC=0 DO 30 KR=1,NRAD DO 20 NY=1,NQ(KR) IREC=IREC+1 CALL WRITEJ(IREC) 20 CONTINUE 30 CONTINUE C C READ RHO,TOTN,XNORM,BH FROM FILE INIT IF IOPAC=0 C CTM THIS BLOCK IS MOVED LOWER CTM CTM IF(IOPAC.EQ.0) THEN CTM CALL OPEN(LOPC,'OPC',0,'OLD') CTM CALL OPEN(LINIT,'INIT',0,'OLD') CTM READ(LINIT) (RHO(K),K=1,NDEP),(TOTN(K),K=1,NDEP),(XNORM(K), CTM * K=1,NDEP),((BH(I,K),I=1,5),K=1,NDEP) CTM CALL CLOSE(LINIT) CTM RETURN CTM ELSE CTM CALL OPEN(LOPC,'OPC',0,'UNKNOWN') CTM ENDIF CTM ENDIF CTM CALL CPUTIME('OPAC ',0,0,1) C C SET KMPEXC TO 0 (INDICATES WHICH ABSORBER TO EXCLUDE) C KMPEXC=0 C C FILL HYDROGEN POPULATIONS IN ARRAYS NHYD AND NPIN C FILL ELECTRON PRESSURES IN ARRAY PE C HLTE=NH(1,1).EQ.0.0 IF(.NOT.HLTE) THEN DO 150 I=1,5 DO 110 K=1,NDEP NHYD(K,I)=NH(I,K) 110 CONTINUE 150 CONTINUE DO 160 K=1,NDEP NPIN(K)=NH(6,K) 160 CONTINUE ENDIF DO 190 K=1,NDEP PE(K)=NE(K)*BK*TEMP(K) 190 CONTINUE C C CALCULATE STANDARD OPACITY, POPULATIONS, DENSITIES C NOTE THAT ALL OPACITIES FROM ABSKO ARE IN PER GRAM C CONVERSION TO PER CM**3 FOR XNORM IS DONE AT END OF ROUTINE C C STORE NLL IN NLL0, SET TO ZERO TO AVOID LINE OPACITIES TO BE INCLUDED C NLL0=NLL CALL ABSKO(2,NDEP,TEMP,PE,1,1,ABSK,SPRID) DO 200 K=1,NDEP XNORM(K)=ABSK(K)+SPRID(K) 200 CONTINUE C C STORE DEPARTURE COEFFICIENTS AND RE-STORE HYDROGEN POPULATIONS C (IF H-POPULATIONS ARE 0 ON INPUT THE LTE VALUES ARE RETURNED AND C MUST BE STORED IN NH) C IF(HLTE) THEN DO 380 I=1,5 DO 360 K=1,NDEP NH(I,K)=NHYD(K,I) 360 CONTINUE 380 CONTINUE DO 390 K=1,NDEP NH(6,K)=NPIN(K) 390 CONTINUE ENDIF CTM CTM COMMENTED ABOVE BOCK MOVED HERE CTM IF(IOPAC.EQ.0) THEN CALL OPEN(LOPC,'OPC',0,'OLD') CALL OPEN(LINIT,'INIT',0,'OLD') READ(LINIT) (RHO(K),K=1,NDEP),(TOTN(K),K=1,NDEP),(XNORM(K), * K=1,NDEP),((BH(I,K),I=1,5),K=1,NDEP) CALL CLOSE(LINIT) RETURN ELSE CALL OPEN(LOPC,'OPC',0,'UNKNOWN') ENDIF ENDIF CALL CPUTIME('OPAC ',0,0,1) CTM CTM END CTM DO 410 I=1,5 DO 400 K=1,NDEP BH(I,K)=BHYD(K,I) 400 CONTINUE 410 CONTINUE C C STORE DENSITIES AND TOTAL POPULATION DENSITIES OF ATOM C NOTE THAT IF ATOM IS HYDROGEN, SOME OF TOTH MIGHT BE IN C THE FORM OF MOLECULES C THIS IS ALSO THE CASE IF ATOM IS CARBON, NITROGEN OR OXYGEN C ATOM STUDIED IS DETERMINED BY LOOKING AT FIRST WORD IN C ATOMID C DO 500 K=1,NDEP RHO(K)=TOTH(K)*GRPH 500 CONTINUE CALL GETWRD(ATOMID,1,K1,K2) ELEMID=ATOMID(K1:K2) IF(ELEMID.EQ.'H') THEN DO 510 K=1,NDEP TOTN(K)=TOTHI(K)+NH(6,K) 510 CONTINUE LABUND=.TRUE. ELSE IF(ELEMID.EQ.'C') THEN DO 520 K=1,NDEP TOTN(K)=TOTC(K) 520 CONTINUE LABUND=.TRUE. ELSE IF(ELEMID.EQ.'N') THEN DO 530 K=1,NDEP TOTN(K)=TOTNIT(K) 530 CONTINUE LABUND=.TRUE. ELSE IF(ELEMID.EQ.'O') THEN DO 540 K=1,NDEP TOTN(K)=TOTO(K) 540 CONTINUE LABUND=.TRUE. ELSE IF(ELEMID.EQ.'CH') THEN DO 550 K=1,NDEP TOTN(K)=TOTCH(K) 550 CONTINUE LABUND=.TRUE. ELSE IF(ELEMID.EQ.'CO') THEN DO 560 K=1,NDEP TOTN(K)=TOTCO(K) 560 CONTINUE LABUND=.TRUE. ELSE IF(ELEMID.EQ.'CN') THEN DO 570 K=1,NDEP TOTN(K)=TOTCN(K) 570 CONTINUE LABUND=.TRUE. ELSE DO 580 K=1,NDEP TOTN(K)=10.0**(ABND-12.0)*TOTH(K) 580 CONTINUE LABUND=.FALSE. ENDIF C C CHECK MAX AND MIN ABUNDANCE AND EQUIVALENCE BETWEEN C ABUNDANCE IN FILES ABUND AND ATOM C IF(LABUND) THEN ABATOM=10.0**(ABND-12.0) ABMAX=TOTN(1)/TOTH(1) ABMIN=ABMAX DO 590 K=2,NDEP ABMAX=MAX(ABMAX,TOTN(K)/TOTH(K)) ABMIN=MIN(ABMIN,TOTN(K)/TOTH(K)) 590 CONTINUE IF(ABMAX.NE.ABMIN .OR. ABMAX.NE.ABATOM) THEN WRITE(LJOBLO,595) ABATOM,ABMIN,ABMAX 595 FORMAT('OPAC: ABUNDANCE FROM FILE ATOM=',1P,E10.2/ * ' ABUNDANCE TAKEN FROM FILE ABUND WITH MOLECULES CONSIDERED'/ * ' MIN AND MAX ABUNDANCE:',2E12.2,0P) ENDIF ENDIF C C CALCULATE BACKGROUND OPACITIES AT OTHER WAVELENGTHS C JP=2 CALL REWIND(LOPC) DO 800 KR=1,NRAD IF(.NOT.IWIDE(KR)) THEN NLL=0 CALL ABSKO(0,NDEP,TEMP,PE,1,JP,ABSK,SPRID) JP=JP+1 DO 600 K=1,NDEP XCONT(K)=(ABSK(K)+SPRID(K))/XNORM(K) SC(K)=ABSLTE(K)/(ABSK(K)+SPRID(K))*BP(K,KR) SCAT(K)=SPRID(K)/(ABSK(K)+SPRID(K)) 600 CONTINUE DO 610 NY=1,NQ(KR) CALL WRITEX 610 CONTINUE ELSE NLL=NLL0 C C FOR CONTINUA IN DETAIL. CHECK TO SEE IF ANY BACKGROUND ABSORBER C SHOULD BE EXCLUDED C DO 650 L=2,NKOMP-6 IF(LVNAME(L).EQ.LABEL(IRAD(KR))) THEN C ADD TM WRITE(*,*)'LVNAME = ',LVNAME(L), ' LABEL = ',LABEL(IRAD(KR)) C END ADD TM KMPEXC=L ENDIF 650 CONTINUE KT=KTRANS(KR) DO 750 NY=1,NQ(KR) WAVE=CC/FRQ(NY,KT)*1.E8 CALL ABSKO(0,NDEP,TEMP,PE,1,JP,ABSK,SPRID) JP=JP+1 DO 700 K=1,NDEP XCONT(K)=(ABSK(K)+SPRID(K))/XNORM(K) SC(K)=ABSLTE(K)/(ABSK(K)+SPRID(K))* * PLANCK(FRQ(NY,KT),TEMP(K)) SCAT(K)=SPRID(K)/(ABSK(K)+SPRID(K)) 700 CONTINUE CALL WRITEX 750 CONTINUE ENDIF KMPEXC=0 800 CONTINUE C C CONVERT XNORM TO CM**2 PER CM**3 C DO 900 K=1,NDEP XNORM(K)=XNORM(K)*RHO(K) 900 CONTINUE C C OUTPUT TO FILE INIT C IF(ICALL.EQ.0) THEN CALL OPEN(LINIT,'INIT',0,'UNKNOWN') WRITE(LINIT) (RHO(K),K=1,NDEP),(TOTN(K),K=1,NDEP),(XNORM(K), * K=1,NDEP),((BH(I,K),I=1,5),K=1,NDEP) CALL CLOSE(LINIT) ENDIF C* C* 88-06-20 ADDITION (P. JUDGE) C* CLOSE WORK FILES WITH STATUS 'DELETE' TO FREE DISK SPACE C* IF (IHSE .EQ. 0) THEN CLOSE(UNIT=ISLASK,STATUS='DELETE') CLOSE(UNIT=IRESET(1),STATUS='DELETE') ENDIF C* 88-06-20 END C* CALL CPUTIME('OPAC ',0,1,1) C C ADD TM WRITE(*,*)'OPAC ROUTINE EXECUTED.' C END ADD TM C RETURN END C C*********************************************************************** C SUBROUTINE TABINI(W,LOOPMX) C C INITIALIZES OPACITY PACKAGE FOR OPCTAB PROGRAM C INCLUDE 'PREC' REAL W(LOOPMX) C PARAMETER (MEL=16,MJMAX=90,MKMAX=140,MLMAX=400,MJ=5) PARAMETER (MT=300,MKOMP=150,ML=50000,MSET=1,MLATB=50,MTETB=30, * MELMAX=2,MKOMPR=MKOMP,MKOMPT=10, * KFADIM=MKOMPR*MT+MKOMPT*MT*3,IFADIM=MKOMPT*MT) C COMMON/CA2/ABKOF(30000000),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP C COMMON/UTPUT/ IREAD, IWRIT C COMMON/CFIL/IRESET(MSET),ISLASK,IREAT C COMMON/COUTR/ NTO,NTPO(MT),IWOPTN C COMMON/CXLSET/NSET,NL(MSET),XL(ML,MSET) C COMMON/CBMET/ BMET(MT,MKOMP-23),BMETP(MT,MKOMP-23), * FRCION(MEL,MJ,MT),ZNLTE(MEL,MJ,MT) C CHARACTER*20 ABNAME,LVNAME COMMON/CNAME/ ABNAME(MKOMP),LVNAME(MKOMP) SAVE ICALL DATA ICALL/0/ C ICALL=ICALL+1 C C OPEN ABSORPTION DATA INPUT FILE AND TEMPORARY FILES C ASSIGN OUTPUT TO OUT FILE C IF(ICALL.EQ.1) THEN CALL OPEN(IREAD,'ABSDAT',1,'OLD') CALL OPEN(IWRIT,'OUT',1,'NEW') IREAT=IREAD CALL OPEN(ISLASK,'DUMO1',0,'NEW') CALL OPEN(IRESET(1),'DUMO2',0,'NEW') ELSE REWIND IREAD REWIND ISLASK REWIND IRESET(1) ENDIF C C FILL WAVELENGTH ARRAY C NSET=1 DO 200 L=1,LOOPMX XL(L,1)=W(L) 200 CONTINUE NL(1)=LOOPMX C IOUTS=0 CALL INJON(IOUTS) CALL INABS(IOUTS) C C FILL ARRAY WITH INDICES WHERE PRINTOUT IS WANTED C NTO=0 C C INITIALIZE BMET AND BMETP ARRAYS TO 1.0 C DO 500 KOMP=17,NKOMP-6 DO 400 K=1,20 BMET(K,KOMP-16)=1.0 BMETP(K,KOMP-16)=1.0 400 CONTINUE 500 CONTINUE C END C C******************************************************************** C SUBROUTINE INJON(IOUTS) C C C THIS ROUTINE READS DATA NECESSARY FOR THE COMPUTATION OF IONIZATION C EQUILIBRIA ETC. (IN SUBR. JON). C 1. NEL= THE NUMBER OF CHEMICAL ELEMENTS CONSIDERED. C A= THE RATIO OF THE NUMBER OF HYDROGEN NUCLEI TO THE NUMBER OF C NUCLEI OF METALLIC ELEMENTS. C NMET=THE NUMBER OF METALLIC ELEMENTS IN THE LIST OF CHEMICAL C ELEMENTS CONSIDERED. THE LAST NMET ELEMENTS OF THE LIST ARE C CONSIDERED TO BE METALLIC, FOR THE CALCULATION OF THE C QUANTITY A (DEFINED ABOVE). C 2. CEL IS THE ARRAY WHICH WILL CONTAIN THE SYMBOLS FOR THE CHEMICAL C ELEMENTS CONSIDERED. C ABUND IS THE ARRAY WHICH WILL CONTAIN THE PREVAILING ABUNDANCES OF C THE CHEMICAL ELEMENTS CONSIDERED AT INPUT. THESE ABUNDANCES C ARE EXPRESSED ON A LOGARITHMIC SCALE (BASE 10) AND NEED NOT BE C NORMALIZED. THE ABUNDANCES ARE MODIFIED IN THIS SUBROUTINE C SO THAT THE RIGHT VALUE OF A (DEFINED ABOVE) IS OBTAINED. C 3. AI IS THE ARRAY WHICH WILL CONTAIN THE ATOMIC WEIGHTS OF THE C ELEMENTS CONSIDERED. C 4. DATA FOR THE COMPUTATION OF THE PARTITION FUNCTIONS IS READ NEXT. C NJ(I)= THE NUMBER OF STAGES OF IONIZATION CONSIDERED FOR ELEMENT I. C FOR EACH STAGE OF IONIZATION JA THE FOLLOWING QUANTITIES ARE READ C G0(JA)=THE STATISTICAL WEIGHT OF THE GROUND LEVEL, C NK(JA)=THE NUMBER OF ELECTRON CONFIGURATIONS CONSIDERED. C FOR EACH ELECTRON CONFIGURATION JB THE FOLLOWING QUANTITIES ARE READ C XION(JB)=THE IONIZATION ENERGY IN ELECTRON VOLTS, C G2(JB)=THE STATISTICAL WEIGHT (2L+1)*(2J+1) C XL(JB)=THE LOWEST QUANTUM NUMBER OF THE ASYMPTOTIC (HYDROGENIC) PART C OF THE PARTITION FUNCTION, C NL(JB)=THE NUMBER OF TERMS IN THE (APPROXIMATE) EXPRESSION FOR THE C 'MIDDLE PART' OF THE PARTITION FUNCTION ('QPRIME'). C ALFA IS AN ARRAY WHICH WILL CONTAIN THE 'STATISTICAL WEIGHTS' OF C THE (APPROXIMATE) EXPRESSIONS FOR THE 'MIDDLE PARTS' OF THE C PARTITION FUNCTIONS. C GAMMA IS AN ARRAY CONTAINING THE CORRESPONDING 'EXCITATION C POTENTIALS' (EXPRESSED IN ELECTRON VOLTS). C FOR THE METHOD USED SEE TRAVING ET AL., ABH. HAMB. VIII, I (1966). C 5. ELEMENTS AND STAGES OF IONIZATION THAT SHOULD BE DISREGARDED ARE C INDICATED BY IELEM(I)=0 FOR ELEMENT I AND BY ION(I,J)=0 FOR C IONIZATION STAGE J. OTHERWISE INDICATORS SHOULD BE = 1. C 6. NQFIX IS THE NUMBER OF PARTITION FUNCTIONS THAT SHOULD BE CONSTANT. C THE VALUES ARE READ INTO THE VECTOR PARCO AND AN INDICATION IS C MADE IN IQFIX. IQFIX(I,J)=0 MEANS THAT THE PARTITION FUNCTION C FOR ELEMENT I, STAGE OF IONIZATION J, IS CONSIDERED TO BE C CONSTANT. C NQTEMP IS THE NUMBER OF PARTITION FUNCTIONS THAT SHOULD BE C PRESSURE-INDEPENDENT AND INTERPOLATED IN T. VALUES OF FOUR C TEMPERATURES (TPARF, THE SAME FOR ALL ELEMENTS) AND C CORRESPONDING PARTITION FUNCTIONS (PARF) ARE READ. IQFIX(I,J)=1 C MEANS THAT A PRESSURE-INDEPENDENT PARTITION FUNCTION FOR INTER- C POLATION IN T IS GIVEN. C 7. IFISH IS A PARAMETER FOR THE CHOICE OF THE ASYMPTOTIC PARTITION C FUNCTION. IFISH=0 MEANS THAT THE ASYMPTOTIC PART WILL BE EVALU- C ATED FOLLOWING BASCHEK ET AL., ABH. HAMB. VIII,26 (1966). IFISH C =1 MEANS THAT IT WILL BE EVALUATED FOLLOWING FISCHEL AND SPARKS C ASTROPHYS. J. 164, 356 (1971). C 8. TMOLIM IS THE HIGHER TEMPERATURE LIMIT BEYOND WHICH MOLECULES WILL C NOT BE CONSIDERED C C MOREOVER SOME INITIATING WORK IS DONE FOR SUBR. JON. UNLOGARITHMIC C ABUNDANCES ARE NORMALIZED ON HYDROGEN, XMY AND SUMH (DEFINED BELOW) C ARE COMPUTED AND SOME FURTHER QUANTITIES ARE EVALUATED AT THE END. C A DETAILED PRINTOUT IS GIVEN IF IOUTS IS EQUAL TO ONE. AFTER INJON C HAS BEEN CALLED ONCE, A NEW DETAILED PRINTOUT IS OBTAINED IF C INJON IS CALLED WITH IOUTS GREATER THAN ONE. C C DIMENSIONS NECESSARY C ABUND(NEL),AI(NEL),ALFA(LMAX),ANJON(NEL,MAX(NJ)),FL2(5),F1Q(3),F2Q(2), C GAMMA(LMAX),G0(JMAX),G2(KMAX),H(5),CEL(NEL),IELEM(NEL), C ION(NEL,MAX(NJ)),IQFIX(NEL,MAX(NJ)),JAMEM(NEL,MAX(NJ)),JBBEG(JMAX), C JCBEG(JMAX),NJ(NEL),NK(JMAX),NL(KMAX),PARCO(JMAX),PARF(4*JMAX), C PARPP(4),PARPT(4),PARQ(4*JMAX),PART(NEL,MAX(NJ)),SHXIJ(5),TPARF(4), C XION(KMAX),XIONG(NEL,MAX(NJ)),XL(KMAX) C THE DIMENSIONS ARE LOWER LIMITS C JMAX IS THE TOTAL NUMBER OF STAGES OF IONIZATION, INCLUDING NEUTRAL C ATOMS. C KMAX IS THE TOTAL NUMBER OF ELECTRON CONFIGURATIONS. C LMAX IS THE TOTAL NUMBER OF TERMS IN THE (APPROXIMATE) EXPRESSIONS C FOR THE MIDDLE PART OF THE PARTITION FUNCTIONS ('QPRIME'), C ACCORDING TO TRAVING ET AL., CITED ABOVE. C NEL IS THE NUMBER OF CHEMICAL ELEMENTS. C NJ(I) IS THE NUMBER OF STAGES OF IONIZATION, INCLUDING THE NEUTRAL C STAGE, FOR ELEMENT I. C C: C: INJON 87-10-16 MODIFICATIONS: (MATS CARLSSON): C: ABUNDANCES ARE READ FROM FILE 'ABUND' WHERE THEY ARE GIVEN C: EITHER RELATIVE TO HYDROGEN A(H)=1.0 OR ON A LOGARITHMIC SCALE C: A(H)=12.0. THE FORMAT IS (ID,ABUNDANCE) (A3,E15.0). THE ID C: SHOULD CORRESPOND TO THE ID IN THE ABSDAT FILE C: GRPH, SUMABN AND SUMMY ARE STORED FOR USE IN MULTI ROUTINES C: C: 88-04-25 MODIFICATIONS (PHILIP JUDGE) C: INPUT CORONAL APPROXIMATION IONIZATION FRACTIONS FROM C: SHULL AND VAN STEENBERG (1982)- SEE ROUTINES CORONA AND RCORON C: C: 89-03-24 MODIFICATIONS (MATS CARLSSON) C: FORMATION OF MOLECULES WAS NOT TAKEN INTO ACCOUNT WHEN CALCULATING C: XNENH AND OPACITIES. THIS HAS BEEN CORRECTED. TOTAL NUMBER C: ABUNDANCES OF ATOMS AFTER MOLECULE FORMATION HAS BEEN TAKEN INTO C: ACCOUNT ARE STORED IN NEW VARIABLE ABUNDM C: C: 92-07-05 MODIFICATIONS (MATS CARLSSON) C: POTENTIAL PROBLEM WITH OVERINDEXING IN C: READ(LABUND,310,END=320) CELIN(I),ABIN(I) C: CORRECTED C: C: 92-07-20 MODIFICATIONS (MATS CARLSSON) C: INTEGER ARRAYS WITH ELEMENT NAME CHANGED TO CHARACTER ARRAYS C: INCLUDE 'PREC' PARAMETER (MEL=16,MJMAX=90,MKMAX=140,MLMAX=400,MJ=5) PARAMETER (MT=300,MKOMP=150,ML=50000,MSET=1,MLATB=50,MTETB=30, * MELMAX=2,MKOMPR=MKOMP,MKOMPT=10, * KFADIM=MKOMPR*MT+MKOMPT*MT*3,IFADIM=MKOMPT*MT) DIMENSION AI(MEL),F1Q(3),F2Q(2),PARF(4*MJMAX),PARPP(4),PARPT(4) DIMENSION JAMEM(MEL,MJ) C COMMON/CI1/FL2(5),PARCO(MJMAX),PARQ(4*MJMAX),SHXIJ(5),TPARF(4), *XIONG(MEL,MJ),EEV,ENAMN,SUMH,XKBOL,SUMM,NJ(MEL),NEL CHARACTER*3 CEL COMMON/CC1/CEL(MEL) C COMMON/CI9/AI C COMMON/CI3/ALFA(MLMAX),GAMMA(MLMAX),G0(MJMAX),G2(MKMAX), * XION(MKMAX),XL(MKMAX),JBBEG(MJMAX),JCBEG(MJMAX),NK(MJMAX), * NL(MKMAX),IFISH C COMMON/CI4/ IELEM(16),ION(16,5),TMOLIM,MOLH C COMMON/CI5/ABUND(MEL),ANJON(MEL,MJ),H(5),PART(MEL,MJ),DXI, * F1,F2,F3,F4,F5,XKHM,XMH,XMY C COMMON/CI6/TP,IQFIX(MEL,MJ),NQTEMP C COMMON/UTPUT/ IREAD, IWRIT C* C* 87-05-30, 87-10-16, 89-03-24, 92-07-20 MODIFICATIONS START C COMMON/COUT/ TOTH(MT),TOTHI(MT),TOTH2(MT), * TOTCH(MT),TOTCO(MT),TOTCN(MT), * TOTC(MT),TOTNIT(MT),TOTO(MT), * BHYD(MT,5),GRPH COMMON/ELMSUM/ SUMABN,SUMMY,NELM,NELME DIMENSION ABIN(MEL) CHARACTER*3 CELIN(MEL),CELIN0 COMMON/CABNDM/ ABUNDM(MEL) C* 87-05-30, 87-10-16, 89-03-24, 92-07-20 MODIFICATIONS END C IF(IOUTS.GT.1) GO TO 25 C C READING OF THE ABUNDANCES AND THEIR ASSOCIATED QUANTITIES C **** 1 **** C READ(IREAD,100) NEL,A,NMET C* 92-07-20 MODIFICATIONS START READ(IREAD,110)(CEL(I),I=1,NEL) DO 50 I=1,NEL CALL LJUST(CEL(I)) 50 CONTINUE C* C* 87-05-30 MODIFICATIONS START C* MAKE POSSIBLE INPUT OF MULTI ABUNDANCE FILE C* 92-07-20 MODIFIED IEL.. TO CEL.. CALL OPEN(LABUND,'DUMS3',1,'NEW') CALL CSTRI2(LDUMS2,LABUND,'ABUND') I=1 300 CONTINUE READ(LABUND,310,END=320) CELIN0,ABIN0 IF(I.GT.MEL) * CALL STOP('INJON: TOO MANY ELEMENTS IN ABUNDANCE FILE') 310 FORMAT(A3,E15.0) CELIN(I)=CELIN0 ABIN(I)=ABIN0 I=I+1 GOTO 300 320 CONTINUE CALL CLOSE(LABUND) NELIN=I-1 DO 370 I=1,NEL ABUND(I)=0.0 DO 330 M=1,NELIN IF(CEL(I).EQ.CELIN(M)) THEN ABUND(I)=ABIN(M) ENDIF 330 CONTINUE 370 CONTINUE IF(ABUND(1).EQ.1.0) THEN DO 380 I=1,NEL ABUND(I)=LOG10(ABUND(I))+12.0 380 CONTINUE ENDIF C* C* 87-05-30, 92-07-20 MODIFICATIONS END C C **** 3 **** C READ(IREAD,102)(AI(I),I=1,NEL) NU=NEL SUM=0. SUMM=0. FAKT=1. C C THE ABUNDANCES ARE CONVERTED FROM A LOGARITHMIC SCALE TO A DIRECT C SCALE, AND ARE THEN NORMALIZED ON HYDROGEN. XMY=GRAMS OF STELLAR MATTER C /GRAMS OF HYDROGEN. SUMH=NUMBER OF OTHER NUCLEI/NUMBER OF HYDROGEN C NUCLEI. C SUMM=NUMBER OF NUCLEI OTHER THAN H, C, N, O / NUMBER OF HYDROGEN NUCLEI C IF(NMET.LE.0)GO TO 22 NU=NEL-NMET+1 DO1 I=NU,NEL ABUND(I)=10.**ABUND(I) 1 SUM=ABUND(I)+SUM C FAKT=SUM*A/10.**ABUND(1) NU=NU-1 22 DO2 I=1,NU ABUND(I)=10.**ABUND(I)*FAKT 2 SUM=SUM+ABUND(I) XMY=0. AHA=ABUND(1) DO3 I=1,NEL ABUND(I)=ABUND(I)/AHA SUMM=SUMM+ABUND(I) 3 XMY=XMY+ABUND(I)*AI(I) XMY=XMY/AI(1) SUMH=SUM/AHA-1. SUMM=SUMM-ABUND(1)-ABUND(3)-ABUND(4)-ABUND(5) C* C* 89-03-24 START C STORE ABUNDANCES IN ABUNDM C DO 390 I=1,NEL ABUNDM(I)=ABUND(I) 390 CONTINUE C C* 89-03-24 END C* C C **** 4 **** C C READING OF DATA FOR THE PARTITION FUNCTIONS. C FOR THE SYMBOLS, SEE ABOVE. C READ(IREAD,103)(NJ(I),I=1,NEL) JA=1 JB=1 JC1=1 DO11 I=1,NEL NJP=NJ(I) DO11 J=1,NJP JAMEM(I,J)=JA JBBEG(JA)=JB JCBEG(JA)=JC1 C JBBEG AND JCBEG ARE INDICATORS USED BY FUNCTION QTRAV C READ(IREAD,104)G0(JA),NK(JA) NKP=NK(JA) IQFIX(I,J)=2 C IQFIX(I,J)=2 MEANS THAT A 'FULL' PARTITION FUNCTION SHOULD BE C COMPUTED. THIS MAY BE CHANGED UNDER **** 7 ****. C JA=JA+1 DO11 K=1,NKP READ(IREAD,105)XION(JB),G2(JB),XL(JB),NL(JB) IF(K.GT.1)GO TO 9 XIONG(I,J)=XION(JB) C XIONG IS THE IONIZATION ENERGY IN ELECTRON VOLTS FOR THE GROUND STATE, C USED IN THE COMPUTATION OF IONIZATION EQUILIBRIA IN C SUBROUTINE JON. C 9 CONTINUE JC2=NL(JB)+JC1-1 JBM=JB JB=JB+1 IF(NL(JBM).LE.0)GO TO 10 READ(IREAD,106)(GAMMA(L),ALFA(L),L=JC1,JC2) 10 JC1=JC2+1 11 CONTINUE C C **** 5 **** C C READING OF THE INDICATORS OF THE ELEMENTS AND THE STAGES OF IONIZATION C TO BE DISREGARDED. DO12 I=1,NEL NJP=NJ(I) READ(IREAD,107)IELEM(I),(ION(I,J),J=1,NJP) 12 CONTINUE C C **** 6 **** C C SPECIFICATION OF THOSE PARTITION FUNCTIONS GIVEN AS CONSTANTS. C INDICATION IN IQFIX. READ(IREAD,103)NQFIX IF(NQFIX.LE.0)GO TO 15 13 DO14 I=1,NQFIX READ(IREAD,109)I1,J1,PARCOP JA=JAMEM(I1,J1) PARCO(JA)=PARCOP 14 IQFIX(I1,J1)=0 15 CONTINUE C C SPECIFICATION OF THOSE PARTITION FUNCTIONS TO BE INTERPOLATED IN T. C INDICATION IN IQFIX. READ(IREAD,103)NQTEMP IF(NQTEMP.EQ.0)GO TO 20 READ(IREAD,101)TPARF DO17 I=1,NQTEMP READ(IREAD,109)I1,J1,(PARPP(K),K=1,4) IQFIX(I1,J1)=1 C C PREPARATION FOR INTERPOLATION OF PARTITION FUNCTIONS IN T (CONCLUDED C IN SUBROUTINE JON). DO16 K=1,3 16 F1Q(K)=(PARPP(K+1)-PARPP(K))/(TPARF(K+1)-TPARF(K)) DO161 K=1,2 161 F2Q(K)=(F1Q(K+1)-F1Q(K))/(TPARF(K+2)-TPARF(K)) F3Q=(F2Q(2)-F2Q(1))/(TPARF(4)-TPARF(1)) PARPT(1)=PARPP(1) PARPT(2)=F1Q(1) PARPT(3)=F2Q(1) PARPT(4)=F3Q JA=JAMEM(I1,J1) DO17 K=1,4 JK=(JA-1)*4+K PARQ(JK)=PARPT(K) 17 PARF(JK)=PARPP(K) C PARQ IS IN COMMON/CI1/ AND IS USED IN SUBROUTINE JON. PARF IS JUST C USED BELOW. C 20 CONTINUE C C **** 7, 8 **** C C THE PARAMETERS IFISH AND TMOLIM. INITIATING WORK FOR SUBROUTINE C JON. C WHEN MOLH IS GREATER THAN ZERO THE MOLECULAR FORMATION WILL BE COMPUTED C IN SUBR. MOLEQ (ONLY H2 AND H2+), ELSE MORE COMPLETE MOLECULAR C FORMATION WILL BE EVALUATED IN SUBR. MOL. C READ(IREAD,100)IFISH READ(IREAD,4528) TMOLIM,MOLH 4528 FORMAT(F10.0,I5) C* C* 88-04-25 MODIFICATIONS (PHILIP JUDGE) C* READ CORONAL ION BALANCE DATA: C* CALL RCORON(IREAD) C* END 88-04-25 MODIFICATIONS C* DO21 J=1,5 FLJ=J FL2(J)=31.321*FLJ*FLJ 21 SHXIJ(J)=SQRT(13.595*FLJ) C C EEV=THE ELECTRON VOLT (EXPRESSED IN TERMS OF ERGS) C XMH=THE MASS OF THE HYDROGEN ATOM (EXPRESSED IN GRAMS) C XKBOL=BOLTZMANN'S CONSTANT (EXPRESSED IN ERGS PER DEGREE KELVIN) EEV=1.602095E-12 XMH=1.67339E-24 XKBOL=1.38053E-16 ENAMN=EEV/(XMH*XMY) C C* 87-10-16 MODIFICATIONS START C* STORE GRPH, SUMABN AND SUMMY FOR COMMUNICATION WITH MULTI PROGRAMS GRPH=XMY*XMH SUMMY=XMY/(1.0+SUMH)*1.008 SUMABN=SUMH C* 87-10-16 MODIFICATIONS END C* TP=0. C TP IS THE TEMPERATURE AT THE 'PRECEDING' CALL OF JON. C C **** PRINT-OUT **** C IF(IOUTS.LE.0)GO TO 40 25 CONTINUE WRITE(IWRIT,201) WRITE(IWRIT,202) WRITE(IWRIT,203) DO33 I=1,NEL NJP=NJ(I) C* 92-07-20 MODIFICATIONS START. CHANGED IEL(I) TO CEL(I)(1:2) WRITE(IWRIT,204)CEL(I)(1:2),ABUND(I),IELEM(I),(ION(I,J), * IQFIX(I,J),J=1,NJP) 33 CONTINUE WRITE(IWRIT,207) WRITE(IWRIT,208) IF(IFISH.EQ.1)WRITE(IWRIT,211) IF(IFISH.EQ.0)WRITE(IWRIT,210) IF(NQTEMP.GT.0.OR.NQFIX.GT.0)WRITE(IWRIT,214) IF(NQTEMP.GT.0)WRITE(IWRIT,209)TPARF JA=1 DO32 I=1,NEL NJP=NJ(I) DO32 J=1,NJP JP=J-1 IF(IQFIX(I,J).EQ.0)WRITE(IWRIT,205)CEL(I)(1:2),JP,PARCO(JA) JK1=(JA-1)*4+1 JK2=(JA-1)*4+4 IF(IQFIX(I,J).EQ.1)WRITE(IWRIT,206)CEL(I)(1:2),JP, * (PARF(JK),JK=JK1,JK2) C* 92-07-20 MODIFICATIONS END 32 JA=JA+1 IF(NQTEMP.GT.0)WRITE(IWRIT,215) WRITE(IWRIT,212)TMOLIM IF(MOLH.LE.0) WRITE(IWRIT,216) IF(MOLH.GT.0) WRITE(IWRIT,217) WRITE(IWRIT,213)XMY,SUMH 40 CONTINUE C ADD TM WRITE(*,*)' INJON ROUTINE EXECUTED.' C END ADD TM RETURN C 100 FORMAT(I10,F10.4,I10) 101 FORMAT(6F10.4) 102 FORMAT(6F10.4) 103 FORMAT(12I5) 104 FORMAT(F5.0,I5) 105 FORMAT(F6.3,F4.0,F5.1,I5) 106 FORMAT(4(F10.3,F10.4)) 107 FORMAT(I10,5I5) 108 FORMAT(2F10.4) 109 FORMAT(2I5,4F10.4) 110 FORMAT(16A3) 201 FORMAT(1H1,'D A T A F R O M S U B R O U T I N E I N J O N') 202 FORMAT(1H0,30X,1HI,14X,2HII,13X,3HIII,12X,2HIV) 203 FORMAT(1H ,' ABUNDANCE IELEM ION PF ION PF * ION PF ION PF') 204 FORMAT(1H ,A2,E12.4,I5,5X,5(I5,I5,5X)) 205 FORMAT(1H ,A2,', STAGE OF IONIZATION=',I2,' PARTITION FUNCTION (CO *NSTANT)=',F10.3) 206 FORMAT(1H ,A2,', STAGE OF IONIZATION=',I2,' PART.FUNC. (T-DEP.) =' *,4F10.3) 207 FORMAT(1H0,'IELEM AND ION = 1 OR 0 MEANS ELEMENT AND IONIZATION *STAGE SHOULD BE CONSIDERED OR DISREGARDED RESP.') 208 FORMAT(1H0,'PF=2 FULL PART. FUNC., =1 PART. FUNC. TO BE INTERPOLAT *ED IN T, =0 CONSTANT PART. FUNC.') 209 FORMAT(1H ,'T-DEPENDENT PARTITION FUNCTIONS GIVEN FOR T = ',4F10. *0) 210 FORMAT(1H ,'ASYMPTOTIC PARTS OF PART. FUNC. FOLLOWING BASCHEK ET A *L. 1966') 211 FORMAT(1H ,'ASYMPTOTIC PARTS OF PART. FUNC. FOLLOWING FISCHEL AND *SPARKS 1971') 212 FORMAT(1H0,'MOLECULES CONSIDERED BELOW T=',F7.0,' DEGREES KELVIN') 213 FORMAT(1H0,'XMY=GRAMS STELLAR MATTER/GRAMS OF HYDROGEN=',F7.4,5X, *'SUMH=NUMBER OF OTHER ATOMS/NUMBER OF H=',F8.5) 214 FORMAT(1H0,'PARTITION FUNCTIONS SUPPLIED BY THE USER') 215 FORMAT(1H ,'IF T OUTSIDE RANGE FOR INTERPOLATIONS DETAILED PART. F *UNCTIONS ARE COMPUTED') 216 FORMAT(1H0,'MOLECULES CONSIDERED: H2, H2+, H2O, OH, CH, CO, CN, C *2, N2, O2, NO, NH') 217 FORMAT(1H0,'MOLECULES CONSIDERED: H2, H2+') END C C ************************************************************************** C SUBROUTINE CSTRI2(IUNIT,LDUMS2,FILE) C C STRIPS COMMENT LINES (LINES WITH * IN POSITION 1) FROM INPUT FILE C UNIT IUNIT. THE FILE IS OPENED AND THE NON-COMMENT LINES ARE C WRITTEN TO UNIT LDUMS2 C INCLUDE 'PREC' CHARACTER*132 TEXT CHARACTER*(*) FILE C CALL OPEN(IUNIT,FILE,1,'OLD') CALL REWIND(LDUMS2) 100 CONTINUE READ(IUNIT,200,END=900) TEXT IF(TEXT(1:1).NE.'*') WRITE(LDUMS2,200) TEXT 200 FORMAT(A) GOTO 100 C 900 CONTINUE CALL REWIND(LDUMS2) CALL CLOSE(IUNIT) RETURN END C C*********************************************************************** C SUBROUTINE INABS(IOUTS) C C THIS ROUTINE READS ABSORPTION COEFFICIENT TABLES AND INTER/EXTRA- C POLATES THEM TO OUR WAVELENGTHS GIVEN IN XL. THE INTERPOLATION IS C PERFORMED SEPARATELY FOR EACH WAVELENGTH SET. C C NKOMP IS THE NUMBER OF COMPONENTS IN THE FULL TABLE. C NEXTL SHOULD BE GREATER THAN ZERO IF A PRINT-OUT IS WANTED ON EXTRA- C POLATION IN WAVELENGTH, C NUTZL IF PRINT-OUT IS WANTED WHEN WE PUT THE COEFFICIENT =0 OUTSIDE THE C WAVELENGTH REGION OF THE TABLES. C NEXTT AND NUTZL ARE THE CORRESPONDING QUANTITIES ON INTERPOLATION IN C T, MADE IN SUBROUTINE TABS. C NULL SHOULD BE GREATER THAN ZERO IF A PRINT-OUT IS WANTED (FROM SUB- C ROUTINE ABSKO) WHEN A COEFFICIENT IS FOUND TO BE LESS THAN ZERO C ON INTERPOLATION IN T AND THEREFORE PUT EQUAL TO ZERO. C C FOR EACH COMPONENT THE FOLLOWING PARAMETERS MUST BE SPECIFIED C ABNAME IS THE NAME OF, OR A SYMBOL FOR, THE ABSORPTION MECHANISM. C SOURCE INDICATES THE SOURCE OR REFERENCE OF THE DATA C 1. PARAMETERS FOR THE WAVELENGTH INTERPOLATION. C ILOGL SHOULD BE GREATER THAN ZERO IF INTERPOLATION IN WAVELENGTH IS C TO BE PERFORMED ON THE LOGARITHMIC ABSORPTION COEFFICIENTS C (WITH SUBSEQUENT EXPONENTIATION OF THE RESULTS - HERE IF ILOGT C IS EQUAL TO ZERO OR IN SUBROUTINE ABSKO IF ILOGT IS GREATER C THAN ZERO). OTHERWISE INTERPOLATION IN WAVELENGTH IS MADE C DIRECTLY ON THE ABSORPTION COEFFICIENTS THEMSELVES. C KVADL SHOULD BE GREATER THAN ZERO IF QUADRATIC INTERPOLATION IN C WAVELENGTH IS WANTED. OTHERWISE INTERPOLATION WILL BE LINEAR. C MINEX SHOULD BE GT 0 IF LINEAR EXTRAPOLATION (INSTEAD OF PUTTING THE C COEFFICIENT = 0) IS WANTED TOWARDS SHORTER WAVELENGTHS. C MAXEX, CORRESPONDING TOWARDS LONGER WAVELENGTHS. C NLATB IS THE NUMBER OF WAVELENGTH POINTS OF THE ABSORPTION COEFFI- C CIENT TABLE TO BE READ. C XLATB ARE THOSE WAVELENGTHS. THEY SHOULD BE GIVEN IN INCREASING ORDER C 2. PARAMETERS FOR THE TEMPERATURE INTERPOLATION. C ILOGT, KVADT, MINET, MAXET AND NTETB ARE THE T-INTERPOLATION C ANALOGUES TO ILOGL-NLATB. C ITETA IS PUT GREATER THAN ZERO WHEN TETA VALUES (TETA=5040./T) ARE C GIVEN IN XTET INSTEAD OF TEMPERATURES. C XTET ARE THE TEMPERATURE (TETA) VALUES OF THE ABSORPTION C COEFFICIENT TABLE TO BE READ. THE XTET VALUES SHOULD BE GIVEN C IN INCREASING ORDER AND EQUIDISTANTLY, HOWEVER (IELMAX-1) C CHANGES OF THE INTERVAL ARE ALLOWED. THE PROGRAM CHECKS THAT C THIS NUMBER IS NOT EXCEEDED. C XKAP IS THE ABSORPTION COEFFICIENT TABLE FOR THE ACTUAL COMPONENT. THE C WAVELENGTHS INCREASES MORE RAPIDLY THAN T (TETA). C C THE TABLES FOR T E M P E R A T U R E - I N D E P E N D E N T C C O M P O N E N T S S H O U L D B E P U T F I R S T . C THE RESULTING TABLE IS PUT IN ABKOF. HERE T (TETA) INCREASES MORE C RAPIDLY THAN XLA, WHICH INCREASES MORE RAPIDLY THAN KOMP. IF THE RESULT C OF THE INTERPOLATION IS ZERO FOR A CERTAIN XLA(J) AND KOMP, THIS IS NOT C PUT IN ABKOF. INSTEAD A NOTE IS MADE IN KOMPLA (KOMPLA(NLB*(KOMP- C 1)+J) IS PUT EQUAL TO ZERO). OTHERWISE THE KOMPLA VALUE TELLS WHERE IN C ABKOF THE TABLE FOR THE COMPONENT KOMP AND THE WAVELENGTH J BEGINS. C C A DETAILED PRINT-OUT IS GIVEN IF IOUTS IS GREATER THAN ZERO. C C C DIMENSIONS NECESSARY C ABKOF(NABDIM),ABNAME(NKOMP),DELT(NKOMP,IELMAX),IDEL(NKOMP), C IDISKV(MAX(NLATB)),ILOGTA(NKOMP),IRESET(NSET),ISVIT(NKOMP),ITETA(NKOMP) C KOMPLA(MAX(NL)*NKOMP),KVADT(NKOMP),MAXET(NKOMP),MINET(NKOMP), C NL(NSET),NTAET(NKOMP),NTM(NKOMP,IELMAX),SOURCE(NKOMP), C TBOLT(NKOMP,IELMAX),XKAP(MAX(NLATB),MAX(NTETB)),XL(MAX(NL),NSET), C XLA(MAX(NL)),XLA3(MAX(NL)),XLATB(MAX(NLATB)),XTET(MAX(NTETB)), C XTETP(MAX(NTETB)) C C THE DIMENSIONS ARE LOWER LIMITS C IELMAX IS THE MAXIMUM NUMBER OF DIFFERENT T INTERVALS (GIVEN BELOW) IN C ANY ABSORPTION COEFFICIENT TABLE. C NABDIM IS THE DIMENSION OF THE ABKOF ARRAY (GIVEN BELOW). C NKOMP IS THE NUMBER OF 'COMPONENTS', I.E. EQUAL TO THE NUMBER OF C DIFFERENT ABSORPTION COEFFICIENT TABLES TO BE READ. C NL(I) IS THE NUMBER OF WAVELENGTHS IN THE WAVELENGTH SET I. C NLATB(KOMP) IS THE NUMBER OF WAVELENGTH POINTS IN THE TABLE TO BE READ C FOR THE COMPONENT KOMP. C NSET IS THE NUMBER OF WAVELENGTH SETS. C NTETB IS THE NUMBER OF TEMPERATURE POINTS IN THE TABLE FOR THE COM- C PONENT BEING CONSIDERED. C C: C: INABS 87-05-30 MODIFICATIONS: (MATS CARLSSON) C: ABNAME AND SOURCE CHANGED FROM DOUBLE PRECISION TO C: CHARACTER*20 C: FORMATS 105 AND 211 CHANGED ACCORDINGLY C: ABNAME CONTAINED IN COMMON BLOCK /CNAME/ C: C: POSSIBILITY OF INPUT DATA WITH PHOTOIONIZATION CROSSECTIONS C: GIVEN LEVEL BY LEVEL. THIS IS INDICATED WITH THE CHARACTER / C: AS THE FIRST CHARACTER IN ABNAME. IN THAT CASE AN EXTRA LINE C: IS READ (FREE FORMAT) CONTAINING IONIZATION STAGE (1=NEUTRAL), C: EXCITATION ENERGY IN CM-1 AND THE STATISTICAL WEIGHT OF THE C: LEVEL. THE ELEMENT NAME IS FOUND BY EXTRACTING THE TEXT C: BETWEEN / AND THE FIRST BLANK IN ABNAME. THIS NAME IS COMPARED C: WITH ARRAY CEL READ BY INJON TO FIND ELEMENT NUMBER THE C: INFORMATION IS STORED IN COMMON BLOCK /CLEVD/. THE COMPARISON C: IS CARRIED OUT IN ROUTINE ELMCMP C: C: 90-11-08 MODIFICATIONS: (MATS CARLSSON) C: ABNAME CHANGED TO NOT INCLUDE LEADING / C: INCLUDE 'PREC' PARAMETER (MEL=16,MJMAX=90,MKMAX=140,MLMAX=400,MJ=5) PARAMETER (MT=300,MKOMP=150,ML=50000,MSET=1,MLATB=50,MTETB=30, * MELMAX=2,MKOMPR=MKOMP,MKOMPT=10, * KFADIM=MKOMPR*MT+MKOMPT*MT*3,IFADIM=MKOMPT*MT) DIMENSION IDISKV(MLATB),XLATB(MLATB),XTET(MTETB), *NTAET(MKOMP),XKAP(MLATB,MTETB),XLA3(ML),XLA(ML),XTETP(MTETB) C COMMON/UTPUT/ IREAD, IWRIT C COMMON/CA1/DELT(MKOMP,MELMAX),TBOT(MKOMP,MELMAX),IDEL(MKOMP), * ISVIT(MKOMP),ITETA(MKOMP),KVADT(MKOMP),MAXET(MKOMP), * MINET(MKOMP),NTM(MKOMP,MELMAX),NEXTT,NUTZT C COMMON/CA2/ABKOF(30000000),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP C COMMON/CA3/ILOGTA(MKOMP),NULL C COMMON/CFIL/IRESET(MSET),ISLASK,IREAT C COMMON/CXLSET/NSET,NL(MSET),XL(ML,MSET) C CHARACTER*20 ABNAME,LVNAME CHARACTER*41 TEXT COMMON/CNAME/ ABNAME(MKOMP),LVNAME(MKOMP) C COMMON/CLEVD/ IONL(MKOMP),CHIL(MKOMP),G2L(MKOMP),IELL(MKOMP) CHARACTER*20 SOURCE(MKOMP) SAVE SMALL DATA SMALL/1.E-37/ C C IELMAX IS THE MAXIMUM NUMBER OF DIFFERENT T INTERVALS IN THE XKAP- C TABLE. THE DIMENSIONS OF TBOT, DELT AND NTM ARE AFFECTED BY THIS NUMBER IELMAX=2 C THE DIMENSION OF THE ABKOF ARRAY NABDIM=30000000 DO705 L=1,30 705 XTETP(L)=0. IF(IOUTS.GT.0)WRITE(IWRIT,229) C READ(IREAT,101)NKOMP,NEXTL,NUTZL,NEXTT,NUTZT,NULL C KOMPR=0 REWIND ISLASK C C LOOP OVER COMPONENTS STARTS (THE 'FIRST KOMP-LOOP') DO720 KOMP=1,NKOMP C*90-11-08 START OF MODIFICATION READ(IREAT,105) TEXT CALL LJUST(TEXT) IF(TEXT(1:1).EQ.'/') THEN ABNAME(KOMP)=TEXT(2:21) SOURCE(KOMP)=TEXT(22:41) CALL LJUST(ABNAME(KOMP)) READ(IREAT,*) IONL(KOMP),CHIL(KOMP),G2L(KOMP) CALL ELMCMP(KOMP) ELSE ABNAME(KOMP)=TEXT(1:20) SOURCE(KOMP)=TEXT(21:40) ENDIF LVNAME(KOMP)=ABNAME(KOMP) C*90-11-08 END OF MODIFICATION READ(IREAT,102)ILOGL,KVADL,MINEX,MAXEX,NLATB READ(IREAT,103)(XLATB(J),J=1,NLATB) C C WE FIND THE DISCONTINUITIES IN WAVELENGTH C A DISCONTINUITY IN A TABLE IS DEFINED BY TWO WAVELENGTH POINTS C WITHIN LESS THAN TWO ANGSTROEMS. IDISK=0 IDISKV(1)=0 DO700 J=2,NLATB IDISKV(J)=0 IF((XLATB(J)-XLATB(J-1)).GE.2.)GO TO 700 IDISKV(J-1)=1 IDISKV(J)=1 IDISK=1 700 CONTINUE C C CONTINUE READING READ(IREAT,102)ILOGT,KVADT(KOMP),MINET(KOMP),MAXET(KOMP),NTETB, * ITETA(KOMP) ILOGTA(KOMP)=ILOGT IF(NTETB.GT.1)GO TO 702 701 KOMPR=KOMPR+1 GO TO 703 702 READ(IREAT,103)(XTET(L),L=1,NTETB) C C FINALLY THE ABSORPTION COEFFICIENT TABLE IS READ 703 DO 704 K=1,NTETB 704 READ(IREAT,104)(XKAP(JJ,K),JJ=1,NLATB) C C WE TAKE THE LOGARITHMS BEFORE THE WAVELENGTH INTERPOLATION C IF ILOGL IS GREATER THAN ZERO. IF(ILOGL.LT.1)GO TO 712 710 DO 711 K=1,NTETB DO 711 JJ=1,NLATB IF(XKAP(JJ,K).GT.0.)GO TO 711 C C A COEFFICIENT FOR WHICH THE LOGARITHM SHOULD BE TAKEN IS ZERO C WRITE(IWRIT,207)KOMP,JJ,K,XKAP(JJ,K),SMALL XKAP(JJ,K)=SMALL 711 XKAP(JJ,K)=LOG(XKAP(JJ,K)) 712 CONTINUE C C PREPARATION OF THE T-INTERPOLATION IN SUBROUTINE TABS C C WE FIND OUT WHETHER ISVIT(KOMP) CAN BE CHOSEN GREATER THAN ZERO. THIS C IS THE CASE IF THE T SCALE AND MAXET, MINET AND KVADT ARE IDENTICAL C WITH THOSE OF THE PREVIOUS COMPONENT. IF ISVIT IS GREATER THAN ZERO, C THE TIME SPENT IN SUBR. TABS WILL BE DECREASED. ISVIT(KOMP)=0 IF(NTETB.LE.1)GO TO 719 DO 721 L=1,NTETB IF(XTET(L).NE.XTETP(L))GO TO 722 721 CONTINUE IF(NTETB.NE.NTETBP)GO TO 722 IF(MAXET(KOMP).NE.MAXETP) GO TO 722 IF(MINET(KOMP).NE.MINETP) GO TO 722 IF(KVADT(KOMP).NE.KVADTP)GO TO 722 ISVIT(KOMP)=1 722 CONTINUE C C WE REMEMBER TEMPERATURES ETC. FOR NEXT COMPONENT DO723 L=1,NTETB 723 XTETP(L)=XTET(L) NTETBP=NTETB MAXETP=MAXET(KOMP) MINETP=MINET(KOMP) KVADTP=KVADT(KOMP) C C WE FIND THE INTERVALS IN THE T (TETA) SCALE TBOT(KOMP,1)=XTET(1) DELT(KOMP,1)=XTET(2)-XTET(1) NTM(KOMP,1)=1 IDEL(KOMP)=1 IF(NTETB.EQ.2)GO TO 719 C J=1 LF=1 DO714 L=3,NTETB DIFF=XTET(L)-XTET(L-1) IF(ABS(1.-DIFF/DELT(KOMP,J)).LT.1.E-4)GO TO 714 J=J+1 IF(J.GT.IELMAX)GO TO 715 TBOT(KOMP,J)=XTET(L-1) DELT(KOMP,J)=DIFF NTM(KOMP,J-1)=LF LF=0 714 LF=LF+1 NTM(KOMP,J)=LF IDEL(KOMP)=J GO TO 719 C TOO MANY DIFFERENT INTERVALS IN THE T-TABLE FOR THIS COMPONENT 715 WRITE(IWRIT,203)KOMP,IELMAX WRITE(IWRIT,206)(XTET(L),L=1,NTETB) STOP C 719 NTAET(KOMP)=NTETB C ALL DATA NECESSARY BELOW FOR THIS COMPONENT ARE STORED ON UNIT C ISLASK WRITE(ISLASK)KVADL,MINEX,MAXEX,NLATB,ILOGL,IDISK,(IDISKV(J),J=1, *NLATB),(XLATB(J),J=1,NLATB),NTETB,ILOGT,(XTET(L),L=1,NTETB) *,((XKAP(JJ,K),JJ=1,NLATB),K=1,NTETB) C C **** PRINT-OUT **** IF(IOUTS.LE.0)GO TO 7 WRITE(IWRIT,211)KOMP,ABNAME(KOMP),SOURCE(KOMP) WRITE(IWRIT,212) WRITE(IWRIT,213)XLATB(1),XLATB(NLATB) IF(MINEX.EQ.0)WRITE(IWRIT,214) IF(MINEX.GT.0)WRITE(IWRIT,215) IF(KVADL.EQ.0)WRITE(IWRIT,216) IF(KVADL.GT.0)WRITE(IWRIT,217) IF(ILOGL.EQ.0)WRITE(IWRIT,218) IF(ILOGL.GT.0)WRITE(IWRIT,219) IF(MAXEX.EQ.0)WRITE(IWRIT,220) IF(MAXEX.GT.0)WRITE(IWRIT,221) IF(IDISK.GT.0)WRITE(IWRIT,222) IF(NTETB-1)8,8,9 8 WRITE(IWRIT,230) GO TO 7 9 CONTINUE WRITE(IWRIT,223) WRITE(IWRIT,213)XTET(1),XTET(NTETB) IF(MINET(KOMP).EQ.0)WRITE(IWRIT,214) IF(MINET(KOMP).GT.0)WRITE(IWRIT,215) IF(KVADT(KOMP).EQ.0)WRITE(IWRIT,216) IF(KVADT(KOMP).GT.0)WRITE(IWRIT,217) IF(ILOGTA(KOMP).EQ.0)WRITE(IWRIT,218) IF(ILOGTA(KOMP).GT.0)WRITE(IWRIT,219) IF(MAXET(KOMP).EQ.0)WRITE(IWRIT,220) IF(MAXET(KOMP).GT.0)WRITE(IWRIT,221) IF(ISVIT(KOMP).GT.0)WRITE(IWRIT,224) WRITE(IWRIT,231) 7 CONTINUE 720 CONTINUE C END OF 'THE FIRST KOMP-LOOP' C KOMPS=KOMPR+1 C C C WE BUILD THE ABKOF ARRAY. INTERPOLATION IN WAVELENGTH. C C LOOP OVER WAVELENGTH SETS ('THE ISET-LOOP') DO 70 ISET=1,NSET REWIND ISLASK NLB=NL(ISET) DO1 J=1,NLB XLA(J)=XL(J,ISET) 1 XLA3(J)=XLA(J)**3 INDEX=1 C C LOOP OVER COMPONENTS STARTS ('THE SECOND KOMP-LOOP') DO60 KOMP=1,NKOMP READ(ISLASK)KVADL,MINEX,MAXEX,NLATB,ILOGL,IDISK,(IDISKV(J),J=1, *NLATB),(XLATB(J),J=1,NLATB),NTETB,ILOGT,(XTET(L),L=1,NTETB) *,((XKAP(JJ,K),JJ=1,NLATB),K=1,NTETB) JI=1 LAMBI=1 C C LOOP OVER WAVELENGTHS ('THE J-LOOP') STARTS DO60 J=1,NLB C* BUG FIX (BG 950331): C* LAMBI=1 C SEARCHING IN WAVELENGTH IU=NLB*(KOMP-1)+J KOMPLA(IU)=INDEX DO24 JJ=1,NLATB IHELP=JJ IF(XLA(J)-XLATB(JJ))25,24,24 24 LAMBI=JJ 25 CONTINUE IF(IHELP-1)45,45,26 26 IF(KVADL)33,33,27 33 IF(NLATB-LAMBI-1)41,31,31 27 IF(NLATB-LAMBI-1)41,28,29 C C QUADRATIC INTERPOLATION 28 LAMBI=LAMBI-1 29 CONTINUE C ARE DISCONTINUITIES PRESENT IF(IDISK.LE.0)GO TO 299 IF(IDISKV(LAMBI+1).LE.0)GO TO 299 IF(XLA(J).GT.XLATB(LAMBI+1))GO TO 292 291 IF(IDISKV(LAMBI).GT.0)GO TO 31 IF(LAMBI.EQ.1)GO TO 31 LAMBI=LAMBI-1 GO TO 299 292 LAMBI=LAMBI+1 IF(IDISKV(LAMBI+1).GT.0)GO TO 31 IF(LAMBI+1.EQ.NLATB)GO TO 31 299 CONTINUE DXX1=XLA(J)-XLATB(LAMBI) DXX2=XLA(J)-XLATB(LAMBI+1) DXX3=XLA(J)-XLATB(LAMBI+2) DX21=XLATB(LAMBI+1)-XLATB(LAMBI) DX32=XLATB(LAMBI+2)-XLATB(LAMBI+1) DX31=XLATB(LAMBI+2)-XLATB(LAMBI) A1=DXX2*DXX3/(DX21*DX31) A2=DXX1*DXX3/(DX21*DX32) A3=DXX1*DXX2/(DX31*DX32) C DO30 K=1,NTETB ABKOF(INDEX)=A1*XKAP(LAMBI,K)-A2*XKAP(LAMBI+1,K)+A3*XKAP(LAMBI+2,K *) 30 INDEX=INDEX+1 GO TO 59 C C LINEAR INTER- AND EXTRAPOLATION 31 A2=(XLA(J)-XLATB(LAMBI))/(XLATB(LAMBI+1)-XLATB(LAMBI)) A1=1.-A2 DO32 K=1,NTETB ABKOF(INDEX)=A1*XKAP(LAMBI,K)+A2*XKAP(LAMBI+1,K) 32 INDEX=INDEX+1 GO TO 59 C C TOO GREAT A WAVELENGTH - OUTSIDE THE TABLE 41 IF(MAXEX)50,50,42 42 LAMBI=LAMBI-1 IF(NEXTL.GT.0)WRITE(IWRIT,201) KOMP,XLA(J) GO TO 31 C C TOO SMALL A WAVELENGTH - OUTSIDE THE TABLE 45 IF(MINEX)50,50,46 46 IF(NEXTL.GT.0)WRITE(IWRIT,201)KOMP,XLA(J) GO TO 31 C C ABS. COEFF. IS PUT = ZERO 50 KOMPLA(IU)=0 IF(NUTZL.GT.0)WRITE(IWRIT,202)KOMP,XLA(J) GO TO 60 C 59 IF(ILOGL.LT.1)GO TO 592 IF(ILOGT.GT.0)GO TO 60 C C LOGARITHMIC INTERPOLATION ONLY IN WAVELENGTH LIP=INDEX-NTETB LAP=INDEX-1 DO 591 LL=LIP,LAP 591 ABKOF(LL)=EXP(ABKOF(LL)) C 592 CONTINUE C IF(ILOGT.LE.0)GO TO 60 C WE TAKE THE LOGARITHM BEFORE THE T INTERPOLATION IF ILOGT GT 0 LIP=INDEX-NTETB LAP=INDEX-1 DO593 LL=LIP,LAP IF(ABKOF(LL).GT.0.)GO TO 593 C C IMPOSSIBLE TO TAKE THE LOGARITHM OF A NEGATIVE COEFFICIENT LUS=LL-LIP+1 WRITE(IWRIT,208)LL,ABKOF(LL),KOMP,J,ISET,LUS,SMALL ABKOF(LL)=SMALL 593 ABKOF(LL)=LOG(ABKOF(LL)) 60 CONTINUE C END OF 'THE J-LOOP' C END OF 'THE SECOND KOMP-LOOP' C C WRITE THE DATA OF THE SET ISET ON UNIT IRESET(ISET) NABKOF=INDEX-1 NKOMPL=IU IREADP=IRESET(ISET) WRITE(IREADP)ISET,NLB,XLA,XLA3,NABKOF,ABKOF,NKOMPL,KOMPLA C END FILE IREADP BACKSPACE IREADP C C CHECK DIMENSION OF ABKOF IF(IOUTS.GT.0) WRITE(IWRIT,204)NABKOF,ISET IF(NABKOF.LE.NABDIM)GO TO 70 C TOO SMALL DIMENSION FOR ABKOF WRITE(IWRIT,205)NABDIM C ADD TM WRITE(IWRIT,'(A,I10)')'NABKOF= ', NABKOF C END ADD TM STOP 70 CONTINUE C C END OF 'THE ISET-LOOP' C C C* C* 89-03-11 MODIFICATIONS (PHILIP JUDGE) C* CLOSE THE ABSDAT FILE: C* CALL CLOSE(IREAT) C* C* 89-03-11 END MODIFICATIONS (PHILIP JUDGE) C* DO 71 ISET=1,NSET IREADP=IRESET(ISET) REWIND IREADP 71 CONTINUE IF(IOUTS.LE.0) GOTO 74 C C **** PRINT-OUT **** C ON WAVELENGTH SETS AND FILES WRITE(IWRIT,225)IREAT,ISLASK WRITE(IWRIT,226) DO73 M=1,NSET NP=NL(M) WRITE(IWRIT,227)M,IRESET(M) WRITE(IWRIT,228)(XL(J,M),J=1,NP) 73 CONTINUE 74 CONTINUE WRITE(IWRIT,232) 101 FORMAT(7X,I3,5(9X,I1)) 102 FORMAT(4(9X,I1),8X,I2,9X,I1) 103 FORMAT(6F10.0) 104 FORMAT(6E10.3) 105 FORMAT(2A) 201 FORMAT(' EXTRAPOLATION FOR COMPONENT',I5,5X,'AND WAVELENGTH=',F10. *3,5X,'***INABS***') 202 FORMAT(' ABS.COEFF. PUT =0 AT WAVELENGTH-INTER/EXTRAPOLATION FOR *COMPONENT',I5,5X,'AND WAVELENGTH=',F10.3,5X,'***INABS***') 203 FORMAT(' TOO MANY DIFFERENT INTERVALS IN THE T-(TETA-)TABLE FOR CO *MPONENT ',I5,5X,'MAX IS',I5,5X,'***INABS***') 204 FORMAT(' NECESSARY DIMENSION FOR ABKOF=',I5,5X,'IN SET',I5,5X,'*** *INABS***') 205 FORMAT(' DIMENSION ALLOWED =',I7,5X,'TOO SMALL ***INABS***') 206 FORMAT(6H XTET=,10E12.4) 207 FORMAT(' INABS: KOMP=',I3,' XKAP(',I2,',',I2,')=',E12.5,' PUT = ', * 1P,E7.0,' BEFORE LOG HAS BEEN TAKEN.') 208 FORMAT(' ABKOF(',I4,')=',E12.5,' FOR COMPONENT ',I3,' WAVELENGTH', *I3,' SET ',I2,' XTET NR ',I2,' ABKOF PUT=',1P,E17.0,'***INABS***') 211 FORMAT('0********** COMPONENT NO',I3,', ',A,' SOURCE ',A,' ***********') 212 FORMAT('0 I N T E R P O L A T I O N I N W A V E L E N G T H' *) 213 FORMAT(1H ,15X,F10.2,25X,F10.2) 214 FORMAT(1H+,' KAPPA=0 - ') 215 FORMAT(1H+,' LIN. EXTRAP.- ') 216 FORMAT(1H+,25X,' -LIN. INT. ') 217 FORMAT(1H+,25X,' -QUAD. INT.') 218 FORMAT(1H+,37X,' KAPPA - ') 219 FORMAT(1H+,37X,' LOG(KAPPA)- ') 220 FORMAT(1H+,60X,' - KAPPA=0') 221 FORMAT(1H+,60X,' -LIN. EXTRAP.') 222 FORMAT(1H0,' DISCONTINUITIES PRESENT.') 223 FORMAT('0 I N T E R P O L A T I O N I N T ( T E T A )') 224 FORMAT('0 T SCALE ETC. IDENTICAL WITH PRECEEDING COMPONENT') 225 FORMAT(1H0,'F I L E S U S E D B Y T H E A B S - B L O C K'//' * INITIAL FILE ',I3,', PRELIMINARY FILE',I3) 226 FORMAT(1H0,'SET WAVELENGTHS',81X,'FILE') 227 FORMAT (1H ,I2,105X,I2) 228 FORMAT(1H ,5X,10F10.2) 229 FORMAT(1H1,'D A T A F R O M S U B R O U T I N E I N A B S') 230 FORMAT(1H0,' N O T- ( T E T A - ) D E P E N D E N C E') 231 FORMAT(1H0) 232 FORMAT(1H1) C ADD TM WRITE(*,*)' INABS ROUTINE EXECUTED.' C END ADD TM RETURN END C C ************************************************************************** C SUBROUTINE ELMCMP(KOMP) C C FINDS ELEMENT NUMBER CORRESPONDING TO ABSORPTION COMPONENT C ABNAME(KOMP). THIS IS DONE BY COMPARING THE FIRST TWO LETTERS C IN ABNAME WITH THE ARRAY CEL READ BY INJON C C 1987-05-21 MATS CARLSSON C: C: ELMCMP 90-11-08 MODIFICATIONS: (MATS CARLSSON) C: ABNAME CHANGED TO NOT INCLUDE LEADING / C: C: 92-07-20 MODIFICATIONS (MATS CARLSSON) C: INTEGER ARRAYS WITH ELEMENT NAME CHANGED TO CHARACTER ARRAYS C: INCLUDE 'PREC' PARAMETER (MEL=16,MJMAX=90,MKMAX=140,MLMAX=400,MJ=5) PARAMETER (MT=300,MKOMP=150,ML=50000,MSET=1,MLATB=50,MTETB=30, * MELMAX=2,MKOMPR=MKOMP,MKOMPT=10, * KFADIM=MKOMPR*MT+MKOMPT*MT*3,IFADIM=MKOMPT*MT) C COMMON/CI1/FL2(5),PARCO(MJMAX),PARQ(4*MJMAX),SHXIJ(5),TPARF(4), *XIONG(MEL,MJ),EEV,ENAMN,SUMH,XKBOL,SUMM,NJ(MEL),NEL CHARACTER*3 CEL COMMON/CC1/CEL(MEL) C CHARACTER*20 ABNAME,LVNAME COMMON/CNAME/ ABNAME(MKOMP),LVNAME(MKOMP) C COMMON/CLEVD/ IONL(MKOMP),CHIL(MKOMP),G2L(MKOMP),IELL(MKOMP) C COMMON /CLU/ LINPUT,LATOM,LATOM2,LATMOS,LDSCAL,LABUND,LOUT, * LTIME,LRSTRT,LDSCA2,LWMAT,LNIIT,LDUMS,LDUMI,LDUMC,LOPC, * LJNY,LINIT,LPHI,LJOBLO,LATHSE C CHARACTER*20 TEXT C TEXT=ABNAME(KOMP) CALL LJUST(TEXT) DO 200 I=1,NEL IF(TEXT(1:2).EQ.CEL(I)(1:2)) GOTO 300 200 CONTINUE WRITE(LJOBLO,210) TEXT(1:2) 210 FORMAT(' ELMCMP: ELEMENT ',A,' NOT FOUND') CALL STOP(' ') C 300 CONTINUE IELL(KOMP)=I C END C C ************************************************************************** C SUBROUTINE ABSKO(NEWT,NT,TSKAL,PESKAL,ISETA,J,ABSK,SPRID) C C THE ROUTINE ADMINISTERS THE COMPUTATION OF ABSORPTION C COEFFICIENTS. IT CALLS THE ROUTINES, GIVING THE PROPER THERMO- C DYNAMIC INFORMATION ( J O N ) , THE DETAILS OF THE ABSORPTION C MECHANISMS ( D E T A B S ) AND THE FACTORS FOR THE INTERPOLATION C IN T ( T A B S ) . IT CHOOSES (IF NECESSARY READS) THE RIGHT SET C OF ABSORPTION-COEFFICIENT DATA (ISETA), STATEMENT NO. 5 AND MAKES C THE INTERPOLATION IN T, STATEMENTS NOS. 10-18, AND THE SUMMATION C OF A ROSSELAND MEAN, IF INDICATED BY J = 0, STATEMENTS NOS. 25-28. C C NEWT SHOULD BE GT 1 THE FIRST TIME THIS ROUTINE IS USED, C EQ 1 WHEN A NEW SET OF T-PE IS USED, C EQ 0 OTHERWISE. C C NT IS THE NUMBER OF T-PE POINTS. THE TEMPERATURES T SHOULD BE EX- C PRESSED IN DEGREES KELVIN, THE ELECTRON PRESSURES PE IN DYNES PER CM2. C ISETA IS THE WAVELENGTH-SET NUMBER, J THE WAVELENGTH NUMBER IN THAT C SET. J EQUAL TO ZERO INDICATES THAT A ROSSELAND MEAN IS WANTED. C THIS MEAN IS COMPUTED USING THE WAVELENGTH POINTS OF THE ACTUAL C SET (ISETA) AND THE QUADRATURE WEIGHTS GIVEN IN ROSW. C IN ABSK AND SPRID THE ABSORPTION AND SCATTERING COEFFICIENTS PER GRAM C OF STELLAR MATTER ARE STORED. C C DIMENSIONS NECESSARY C AB(NKOMP),ABSK(1),FAKT(NKOMP),FAKTP(500),NTPO(NTO),PE(NT),PESKAL(1), C ROSW(MAX(NL)),SPRID(1),SUMW(NT),T(NT),TSKAL(1),XLA(MAX(NL)), C XLA3(MAX(NL)) C THE DIMENSIONS ARE LOWER LIMITS. C DIMENSIONS OF ARRAYS IN COMMONS /CA2/,/CA3/ AND /CFIL/ ARE COMMENTED C ON IN SUBROUTINE INABS, THOSE OF ARRAYS IN COMMON /CA4/ IN SUBROUTINE C TABS. C NKOMP IS THE NUMBER OF 'COMPONENTS' C NL(I) IS THE NUMBER OF WAVELENGTHS IN WAVELENGTH SET I C NT IS THE NUMBER OF T-PE POINTS SUPPLIED IN TSKAL AND PESKAL C NTO IS THE NUMBER OF POINTS IN THOSE SCALES FOR WHICH A DETAILED C PRINT-OUT IS WANTED. C C: C: ABSKO 87-05-30 MODIFICATIONS: (MATS CARLSSON) C: NTP IS INCLUDED IN THE ARGUMENT-LIST TO JON TO MAKE NON-LTE C: INCLUSION AND INTERFACE TO MULTI PROGRAM EASIER C: C: 92-11-27 MODIFICATIONS: (MATS CARLSSON) C: SAVE STATEMENT ADDED C: INCLUDE 'PREC' PARAMETER (MEL=16,MJMAX=90,MKMAX=140,MLMAX=400,MJ=5) PARAMETER (MT=300,MKOMP=150,ML=50000,MSET=1,MLATB=50,MTETB=30, * MELMAX=2,MKOMPR=MKOMP,MKOMPT=10, * KFADIM=MKOMPR*MT+MKOMPT*MT*3,IFADIM=MKOMPT*MT) DIMENSION TSKAL(NT),PESKAL(NT),ABSK(NT),SPRID(NT) DIMENSION FAKTP(MKOMPT*MT) DIMENSION SUMW(MT) C COMMON/UTPUT/ IREAD, IWRIT C COMMON/CA2/ABKOF(30000000),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP C COMMON/CA3/ILOGTA(MKOMP),NULL C COMMON/CA4/AFAK(KFADIM),NOFAK(IFADIM),NPLATS(IFADIM) C COMMON/CA5/AB(MKOMP),FAKT(MKOMP),PE(MT),T(MT),XLA(ML),XLA3(ML),RO, *SUMABS,SUMSCA,VIKTR,ISET,NLB C COMMON/CFIL/IRESET(MSET),ISLASK,IREAT C COMMON/COUTR/ NTO,NTPO(MT),IWOPTN C COMMON/CROS/ROSW(ML) C SAVE C C ADD TM C WRITE(*,*)' ABSKO ROUTINE STARTS NOW.' C END ADD TM ISET=ISETA IF(NEWT.GT.1)ISETP=-1 IF(NEWT.EQ.0)GO TO 5 C C FACTORS ONLY DEPENDENT ON T-PE C CALL TABS(NT,TSKAL) IFAK=1 KFAK=1 JP=0 KP=1 C C LOOP OVER THE T-PE POINTS ('THE FIRST NTP-LOOP') DO4 NTP=1,NT T(NTP)=TSKAL(NTP) PE(NTP)=PESKAL(NTP) C IS PRINT-OUT WANTED FOR T-PE POINT NO. NTP IOUTR=0 IF(KP.GT.NTO)GO TO 3 IF(NTP.EQ.NTPO(KP))GO TO 1 GO TO 3 1 IOUTR=1 KP=KP+1 3 CONTINUE C CALL JON(NTP,T(NTP),PE(NTP),1,PG,RO,DUM,IOUTR) CALL DETABS(J,0,NTP,IOUTR) C C WE STORE THE FAKT ARRAY, MADE IN JON-DETABS IN LONGER ARRAYS NAMELY C IN AFAK FOR TEMPERATURE-INDEPENDENT COMPONENTS C IN FAKTP FOR TEMPERATURE-DEPENDENT ONES DO2 KOMP=1,KOMPR AFAK(KFAK)=FAKT(KOMP) 2 KFAK=KFAK+1 DO4 KOMP=KOMPS,NKOMP FAKTP(IFAK)=FAKT(KOMP) KFAK=KFAK+NOFAK(IFAK) 4 IFAK=IFAK+1 C END OF 'THE FIRST NTP-LOOP' C C READING OF A NEW WAVELENGTH SET IF INDICATED BY ISET 5 IF(ISET.EQ.ISETP)GO TO 6 IREADP=IRESET(ISET) 51 READ(IREADP,END=52)ISETP,NLB,XLA,XLA3,NABKOF,ABKOF,NKOMPL,KOMPLA GO TO 5 52 REWIND IREADP GO TO 51 C ROSSELAND MEAN OR NOT 6 IF(J.GT.0)GO TO 9 7 J1=1 J2=NLB DO8 NTP=1,NT SUMW(NTP)=0. 8 ABSK(NTP)=0. GO TO 10 9 J1=J J2=J C C INTERPOLATION IN T C LOOP OVER ALL THE WAVELENGTHS IN A POSSIBLE ROSSELAND MEAN. THIS C LOOP ENDS IN STATEMENT NO. 26 10 DO26 JP=J1,J2 KFAK=1 IFAK=1 KP=1 C C LOOP OVER THE T-PE POINTS ('THE SECOND NTP-LOOP') DO26 NTP=1,NT C C IS PRINT-OUT WANTED FOR T-PE POINT NO. NTP IOUTR=0 IF(KP.GT.NTO)GO TO 93 IF(NTP.EQ.NTPO(KP))GO TO 92 GO TO 93 92 IOUTR=1 KP=KP+1 IF(KP.EQ.2)IOUTR=2 93 CONTINUE IU=JP C C COMPONENTS WITH ABSORPTION COEFFICIENTS INDEPENDENT OF THE C TEMPERATURE C DO14 KOMP=1,KOMPR IF(KOMPLA(IU).LE.0)GO TO 12 C THE VECTOR KOMPLA IS DETERMINED IN SUBROUTINE INABS. C KOMPLA GREATER THAN ZERO GIVES THE INDEX IN ABKOF, WHERE THE TABLE FOR C THIS COMPONENT AND WAVELENGTH BEGINS. C KOMPLA LESS THAN OR EQUAL TO ZERO INDICATES THAT THE ACTUAL ABSORPTION C COEFFICIENT FOR THIS COMPONENT AND WAVELENGTH IS ZERO, AS FOUND IN SUB- C ROUTINE INABS. C 11 INDEX=KOMPLA(IU) AB(KOMP)=AFAK(KFAK)*ABKOF(INDEX) GO TO 13 12 AB(KOMP)=0. 13 KFAK=KFAK+1 14 IU=IU+NLB C C COMPONENTS WITH T-DEPENDENT ABSORPTION COEFFICIENTS DO19 KOMP=KOMPS,NKOMP NOP=NOFAK(IFAK) IF(NOP.EQ.0)GO TO 17 IF(KOMPLA(IU).LE.0)GO TO 17 15 INDEX=NPLATS(IFAK)-1+KOMPLA(IU) C THE VECTOR NPLATS IS DETERMINED BY SUBROUTINE TABS. IT GIVES THE ARRAY C INDEX OF THE TEMPERATURE AT WHICH THE INTERPOLATION IN ABKOF C BEGINS. NOFAK, GIVING INFORMATION ON THE T-INTERPOLATION AND C POSSIBLY INDICATING THAT AB=0 (NOFAK=0) IS ALSO DETERMINED BY TABS. C C INTERPOLATION DELSUM=0. DO16 NP=1,NOP DELSUM=DELSUM+AFAK(KFAK)*ABKOF(INDEX) KFAK=KFAK+1 16 INDEX=INDEX+1 C C HAS THE INTERPOLATION BEEN MADE ON THE LOGARITHM IF(ILOGTA(KOMP).GT.0)DELSUM=EXP(DELSUM) C MULTIPLICATION BY FACTOR FROM JON-DETABS DELSUM=DELSUM*FAKTP(IFAK) IF(DELSUM.GE.0)GO TO 162 C C A NEGATIVE INTERPOLATION RESULT 161 IF(NULL.GT.0)WRITE(IWRIT,200)KOMP,DELSUM,JP,ISET,T(NTP) 200 FORMAT(4H AB(,I4,11H) NEGATIVE=,E12.4,5X,17HFOR WAVELENGTH NO,I5, *5X,6HSET NO,I5,5X,2HT=,F10.4,' AND THEREFORE PUT =0 ***ABSKO***') AB(KOMP)=0. GO TO 18 162 AB(KOMP)=DELSUM GO TO 18 17 AB(KOMP)=0. KFAK=KFAK+NOP 18 IU=IU+NLB 19 IFAK=IFAK+1 C C WE MULTIPLY BY WAVELENGTH-DEPENDENT FACTORS AND ADD UP. THIS IS C DONE IN DETABS. CALL DETABS(J,JP,NTP,IOUTR) C IF(J.LE.0)GO TO 25 24 ABSK(NTP)=SUMABS SPRID(NTP)=SUMSCA GO TO 26 C C SUMMATION TO GET A ROSSELAND MEAN 25 ABSK(NTP)=ABSK(NTP)+ROSW(JP)/(VIKTR*(SUMABS+SUMSCA)) SUMW(NTP)=SUMW(NTP)+ROSW(JP) /VIKTR 26 CONTINUE C C END OF 'THE SECOND NTP-LOOP' C IF(J.GT.0)GO TO 29 27 DO28 NTP=1,NT SPRID(NTP)=0. 28 ABSK(NTP)=SUMW(NTP)/ABSK(NTP) C 29 CONTINUE C ADD TM C WRITE(*,*)' ABSKO ROUTINE EXECUTED.' C END ADD TM RETURN END C C *************************************************************************** C SUBROUTINE TABS(NT,T) C C THIS ROUTINE COMPUTES FACTORS FOR INTERPOLATION IN T (TETA IF C ITETA(KOMP) IS GREATER THAN ZERO) IN THE ABKOF TABLE, INITIATED BY C SUBROUTINE INABS. CONCERNING THE OTHER CONTROL INTEGERS, SEE INABS. C THE RESULTING FACTORS ARE PUT IN AFAK. THE NUMBER OF FACTORS FOR C THE COMPONENT KOMP AT TEMPERATURE T(NTP) IS GIVEN IN C NOFAK((NKOMP-KOMPR)*(NTP-1)+KOMP-KOMPR). HERE KOMPR IS THE NUMBER C OF COMPONENTS WITH T-INDEP. COEFFICIENTS. NOFAK=0 MEANS THAT THE C ABSORPTION COEFFICIENT SHOULD BE =0. NPLATS (INDEX AS FOR NOFAK) C GIVES THE ARRAY INDEX OF THE TEMPERATURE POINT AT WHICH THE C INTERPOLATION IN ABKOF SHOULD START. C C NT=NUMBER OF TEMPERATURES C T= ARRAY OF TEMPERATURES C C DIMENSIONS NECESSARY C AFAK(KFADIM),NOFAK(IFADIM),NPLATS(IFADIM),T(1) C THE DIMENSIONS ARE LOWER LIMITS. DIMENSIONS OF ARRAYS IN COMMONS /CA1/ C AND /CA2/ ARE COMMENTED ON IN SUBROUTINE INABS. C IFADIM SHOULD BE AT LEAST =(NKOMP-KOMPR)*NT, WHERE NKOMP IS THE NUMBER C OF COMPONENTS, KOMPR THE NUMBER OF TEMPERATURE-INDEPENDENT C COMPONENTS AND NT THE NUMBER OF TEMPERATURE POINTS (IN THE PARA C METER LIST). C KFADIM SHOULD BE AT LEAST =KOMPR*NT+(NKOMP-KOMPR)*NT*NUM, WHERE NUM IS C BETWEEN 2 AND 3 AND DEPENDENT ON THE TYPE OF TEMPERATURE C INTERPOLATION USED. C C INCLUDE 'PREC' PARAMETER (MEL=16,MJMAX=90,MKMAX=140,MLMAX=400,MJ=5) PARAMETER (MT=300,MKOMP=150,ML=50000,MSET=1,MLATB=50,MTETB=30, * MELMAX=2,MKOMPR=MKOMP,MKOMPT=10, * KFADIM=MKOMPR*MT+MKOMPT*MT*3,IFADIM=MKOMPT*MT) DIMENSION T(NT) C COMMON/UTPUT/ IREAD, IWRIT C COMMON/CA1/DELT(MKOMP,MELMAX),TBOT(MKOMP,MELMAX),IDEL(MKOMP), * ISVIT(MKOMP),ITETA(MKOMP),KVADT(MKOMP),MAXET(MKOMP), * MINET(MKOMP),NTM(MKOMP,MELMAX),NEXTT,NUTZT C COMMON/CA2/ABKOF(30000000),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP C COMMON/CA4/AFAK(KFADIM),NOFAK(IFADIM),NPLATS(IFADIM) C C IFADIM=500 C KFADIM=2500 IFAK=1 KFAK=1 NSVIT=1 C THIS IS JUST A DUMMY STATEMENT TO GIVE NSVIT A FORMAL VALUE C DO81 NTP=1,NT TP=T(NTP) KFAK=KFAK+KOMPR DO81 KOMP=KOMPS,NKOMP IF(ISVIT(KOMP).GT.0)GO TO (51,61,70),NSVIT IF(ITETA(KOMP).LE.0)GO TO 2 1 TS=5040./T(NTP) GO TO 3 2 TS=T(NTP) C C SEARCHING 3 IF((TS-TBOT(KOMP,1)).GE.0.)GO TO 10 IF(MINET(KOMP).LE.0)GO TO 70 C C EXTRAPOLATION DOWNWARDS IF(NEXTT.GT.0)WRITE(IWRIT,200)TS,KOMP INTA=1 AP=(TS-TBOT(KOMP,1))/DELT(KOMP,1) IP=0 GO TO 60 C C SEARCHING CONTINUES 10 INTAP=1 IDP=IDEL(KOMP) DO11 I=1,IDP AP=(TS-TBOT(KOMP,I))/DELT(KOMP,I) IP=INT(AP) INTA=IP+INTAP INAP=NTM(KOMP,I)-1+INTAP IF(INTA.LE.INAP) GO TO 20 11 INTAP=INAP+1 IF(MAXET(KOMP).LE.0)GO TO 70 C C EXTRAPOLATION DOWNWARDS IF(NEXTT.GT.0)WRITE(IWRIT,200)TS,KOMP INTA=INAP IP=NTM(KOMP,IDP)-1 GO TO 60 C 20 IF(KVADT(KOMP).LE.0)GO TO 60 C C QUADRATIC INTERPOLATION 21 IF(INTA.LT.INAP)GO TO 50 INTA=INTA-1 IP=IP-1 C 50 DXX1=AP-FLOAT(IP) DXX2=DXX1-1. DXX3=DXX1-2. A1=DXX2*DXX3*0.5 A2=-DXX1*DXX3 A3=DXX1*DXX2*0.5 51 AFAK(KFAK)=A1 AFAK(KFAK+1)=A2 AFAK(KFAK+2)=A3 NPLATS(IFAK)=INTA NOFAK(IFAK)=3 IFAK=IFAK+1 KFAK=KFAK+3 NSVIT=1 GO TO 80 C C LINEAR INTER/EXTRAPOLATION 60 A2=AP-FLOAT(IP) A1=1.-A2 61 AFAK(KFAK)=A1 AFAK(KFAK+1)=A2 NPLATS(IFAK)=INTA NOFAK(IFAK)=2 IFAK=IFAK+1 KFAK=KFAK+2 NSVIT=2 GO TO 80 C C OUTSIDE TABLE. ABS.COEFF. SHOULD BE = 0 70 IF(NUTZT.GT.0)WRITE(IWRIT,201)TS,KOMP NOFAK(IFAK)=0 IFAK=IFAK+1 NSVIT=3 C 80 CONTINUE IF(KFAK.GT.KFADIM)GO TO 90 IF(IFAK.GT.IFADIM)GO TO 91 81 CONTINUE C GO TO 92 90 WRITE(IWRIT,202)KFAK,KFADIM,NT STOP 91 WRITE(IWRIT,203)IFAK,IFADIM,NT STOP 92 CONTINUE C 200 FORMAT(33H EXTRAPOLATION IN TABS, T (TETA)=,E12.5,5X,12HCOMPONENT *NO,I5) 201 FORMAT(24H ZERO IN TABS, T (TETA)=,E12.5,5X,12HCOMPONENT NO,I5) 202 FORMAT(6H KFAK=,I5,5X,11H GT KFADIM=,I5,5X,12HIN TABS, NT=,I5) 203 FORMAT(6H IFAK=,I5,5X,11H GT IFADIM=,I5,5X,12HIN TABS, NT=,I5) C ADD TM WRITE(*,*)' TABS ROUTINE EXECUTED.' C END ADD TM RETURN END C C ********************************************************************** C SUBROUTINE JON(NTP,T,PE,IEPRO,PG,RO,E,IOUTR) C C C THIS ROUTINE COMPUTES IONIZATION EQUILIBRIA FOR A GIVEN TEMPERATURE (T, C EXPRESSED IN DEGREES KELVIN) AND A GIVEN ELECTRON PRESSURE (PE, IN C DYNES PER CM2). THE FRACTIONS OF IONIZATION ARE PUT IN THE ANJON VECTOR C AND THE PARTITION FUNCTIONS ARE PUT IN PART. IF IEPRO IS GREATER THAN C ZERO, THE GAS PRESSURE (PG,IN DYNES PER CM2), DENSITY (RO, IN GRAMS C PER CM3) AND INNER ENERGY (E, IN ERGS PER GRAM) ARE ALSO EVALUATED. C N O T E . RADIATION PRESSURE IS NOT INCLUDED IN E. C C THE ENERGIES OF IONIZATION ARE REDUCED BY DXI, FOLLOWING BASCHEK ET C AL., ABH. HAMB. VIII, 26 EQ. (10). THESE REDUCTIONS ARE ALSO MADE IN C THE COMPUTATION OF E. C THE ENERGY OF DISSOCIATION FOR H- HAS BEEN REDUCED BY 2*DXI, FOLLOWING C TARAFDAR AND VARDYA, THIRD HARV. SMITHS. CONF., PAGE 143. THE FORMATION C OF MOLECULES IS CONSIDERED FOR T LESS THAN TMOLIM. C C IF IOUTR IS GREATER THAN ZERO, A DETAILED PRINT-OUT WILL BE GIVEN. C C C THE FUNCTION QTRAV AND SUBROUTINE MOLEQ ARE CALLED. C THEY CALL QAS AND MOLFYS RESPECTIVELY. C C DIMENSIONS NECESSARY C A(5),DQ(4),F(MAX(NJ)),PFAK(MAX(NJ)),RFAK(JMAX) C DIMENSIONS OF ARRAYS IN COMMONS /CI1/,/CI4/,/CI5/ AND /CI6/ ARE C COMMENTED ON IN SUBROUTINE INJON. C JMAX IS THE TOTAL NUMBER OF STAGES OF IONIZATION, INCLUDING NEUTRAL C ATOMS. C NJ(I) IS THE NUMBER OF STAGES OF IONIZATION, INCLUDING THE NEUTRAL C STAGE, FOR ELEMENT I. C: C: JON 87-05-30 MODIFICATIONS: (MATS CARLSSON) C: NTP IS INCLUDED IN THE ARGUMENT-LIST TO JON TO MAKE NON-LTE C: INCLUSION AND INTERFACE TO MULTI PROGRAM EASIER (ALSO C: AFFECTS ABSKO) C: C: COMMON BLOCKS HYDCOM, CIN, CXNENH AND COPBID INCLUDED FOR C: COMMUNICATION WITH MULTI AND WITH DETABS C: C: ACTUAL HYDROGEN POPULATIONS ADDED UP AND ''LTE'' POPULATIONS C: CALCULATED USING ACTUAL PROTON DENSITY AND SAHA RELATION C: C: 87-10-20 MODIFICATIONS: (MATS CARLSSON) C: NON-LTE OPTION FOR MOLECULES ADDED. NE/NHT IS THEN FIXED C: C: 88-01-18 MODIFICATIONS: (MATS CARLSSON) C: NON-LTE OPTION FOR IONIZATION FRACTIONS ADDED C: C: 88-01-30 MODIFICATIONS: (MATS CARLSSON) C: DOUBLE PRECISION USED WHEN CALCULATING THE IONIZATION C: FRACTIONS TO AVOID OVERFLOW/UNDERFLOW AT HIGH TEMPERATURES C: C: CALCULATION OF TOTAL NUMBER DENSITIES OF C, N, O, CH, CO, CN C: ADDED. THESE AND NH2 TRANSFERED IN COUT C: C: 88-04-23 MODIFICATIONS (PHILIP JUDGE) C: CORONAL APPROXIMATION CALCULATIONS USED FOR LOW GAS PRESSURES AND HIGH C: TEMPERATURES IN ORDER THAT INAPPROPRIATE ION FRACTIONS IN LTE ARE NOT C: USED C: C: 89-03-24 MODIFICATIONS (MATS CARLSSON) C: FORMATION OF MOLECULES WAS NOT TAKEN INTO ACCOUNT WHEN CALCULATING C: XNENH AND OPACITIES. THIS HAS BEEN CORRECTED. TOTAL NUMBER C: ABUNDANCES OF ATOMS AFTER MOLECULE FORMATION HAS BEEN TAKEN INTO C: ACCOUNT ARE STORED IN NEW VARIABLE ABUNDM C: C: PRINTOUT HAS BEEN CHANGED. IONIZATION FRACTIONS FOR HYDROGEN ARE C: NOW THE NON-LTE VALUES. ABUNDANCES ARE THE ABUNDANCES TAKING C: FORMATION OF MOLECULES INTO ACCOUNT C: C: 92-08-10 MODIFICATIONS (MATS CARLSSON) C: INTEGER ARRAYS WITH ELEMENT NAME CHANGED TO CHARACTER ARRAYS C: C: 92-11-27 MODIFICATIONS: (MATS CARLSSON) C: SAVE STATEMENT ADDED C: INCLUDE 'PREC' PARAMETER (MEL=16,MJMAX=90,MKMAX=140,MLMAX=400,MJ=5) PARAMETER (MT=300,MKOMP=150,ML=50000,MSET=1,MLATB=50,MTETB=30, * MELMAX=2,MKOMPR=MKOMP,MKOMPT=10, * KFADIM=MKOMPR*MT+MKOMPT*MT*3,IFADIM=MKOMPT*MT) DIMENSION DQ(4),F(MJ),PFAK(MJ),RFAK(MJMAX) DIMENSION PRESMO(13) C COMMON/CI1/FL2(5),PARCO(MJMAX),PARQ(4*MJMAX),SHXIJ(5),TPARF(4), *XIONG(MEL,MJ),EEV,ENAMN,SUMH,XKBOL,SUMM,NJ(MEL),NEL CHARACTER*3 CEL COMMON/CC1/CEL(MEL) C COMMON/CI4/ IELEM(16),ION(16,5),TMOLIM,MOLH C COMMON/CI5/ABUND(MEL),ANJON(MEL,MJ),H(5),PART(MEL,MJ),DXI, * F1,F2,F3,F4,F5,XKHM,XMH,XMY C COMMON/CI6/TP,IQFIX(MEL,MJ),NQTEMP C COMMON/CI7/A(5),PFISH,ITP C COMMON/UTPUT/ IREAD, IWRIT COMMON/RABELL/XXRHO(40),XYRHO C COMMON/CI8/YYPG,YYRHO,YYE COMMON/CMOL/PK(13),FH,FC,FN,FO,FE,FHE,FCE,FNE,FOE,EH COMMON/CARC3/F1P,F3P,F4P,F5P,HNIC,PRESMO C* C* MODIFICATIONS START C COMMON/COUTR/ NTO,NTPO(MT),IWOPTN REAL NH,NP,NH2,NH2P,NHMIN,NHT,NHLTE COMMON/HYDCOM/NH,NP,NH2,NH2P,NHMIN,NHT,NHLTE C LOGICAL HLTE REAL NHYD,NPIN COMMON/CIN/ NHYD(MT,5),NPIN(MT),HLTE COMMON /CXNENH/ XNENH C COMMON /COPBID/ PGC(MT),ROC(MT),XMYC(MT),EJONC(MT), * XNENHC(MT),PROV(20,MT) C COMMON/CBMET/ BMET(MT,MKOMP-23),BMETP(MT,MKOMP-23), * FRCION(MEL,MJ,MT),ZNLTE(MEL,MJ,MT) C COMMON/COUT/ TOTH(MT),TOTHI(MT),TOTH2(MT), * TOTCH(MT),TOTCO(MT),TOTCN(MT), * TOTC(MT),TOTNIT(MT),TOTO(MT), * BHYD(MT,5),GRPH C* 89-03-24 START COMMON/CABNDM/ ABUNDM(MEL) C* 89-03-24 END C* C* 89-03-07 MODIFICATION (PHILIP JUDGE) C* CORONAL IONIZATION DATA ADDED PARAMETER (MCOR=30) INTEGER NCOR,IONCOR(MCOR) DOUBLE PRECISION ARADC(MCOR),XRADC(MCOR),ADIC(MCOR),T0C(MCOR), * BDIC(MCOR),T1C(MCOR),ACOLC(MCOR),TCOLC(MCOR),TECOR,DECOR COMMON /CCORON/ TECOR,DECOR, * ARADC,XRADC,ADIC,T0C,BDIC,T1C,ACOLC,TCOLC,NCOR,IONCOR CHARACTER*3 CCOR COMMON /CCCOR/ CCOR(MCOR) INCLUDE 'CCONST' C* 89-03-07 END C* C REAL NE DOUBLE PRECISION FIL REAL NC,NN,NO,NCH,NCO,NCN LOGICAL MASKWR C** C** 88-04-16 PGJ ADDITION C** TEMPORARY VARIABLE TO STORE LTE IONIZATION FRACTIONS OF NON-LTE C** ABSORBERS C* CHARACTER VARIABLES FOR PRINTOUT CHARACTER *10 CANJON(MJ),CPART(MJ) REAL FTEMP(MT,MJ) SAVE C** END PGJ ADDITION C* MODIFICATIONS END C* C STATEMENT FUNCTION FOR 10.** EXP10(X)=EXP(2.302585*X) C ITP=1 C C IS T=THE TEMPERATURE OF THE PRECEDING CALL IF(ABS((T-TP)/T).LT.1.E-8)GO TO 53 51 ITP=0 C C SOME QUANTITIES, ONLY DEPENDENT ON T TETA=5040./T TETA25=1.202E9/(TETA*TETA*SQRT(TETA)) DO52 J=1,5 52 A(J)=FL2(J)*TETA C A=ALFA(BASCHEK ET AL., CITED ABOVE) C IF(NQTEMP.EQ.0)GO TO 53 C C PREPARATION FOR INTERPOLATION OF PARTITION FUNCTIONS IN T DQ(1)=1. DQ(2)=T-TPARF(1) DQ(3)=DQ(2)*(T-TPARF(2)) DQ(4)= DQ(3)*(T-TPARF(3)) C C SOME QUANTITIES ALSO DEPENDENT ON PE C THE PFAK FACTORS ARE USED IN THE SAHA EQUATION. H(J) IS THE C QUANTUM NUMBER OF THE CUT OF THE PARTITION FUNCTIONS (ACCORDING C TO BASCHEK ET AL., CITED ABOVE) FOR J-1 TIMES IONIZED ATOMS. H IS C USED IN QAS. C C XNEL= THE ELECTRON (NUMBER) DENSITY (PER CM3) C PFISH= P(FISCHEL AND SPARKS, ASTROPHYS. J. 164, 359 (1971)) IS USED IN C FUNCTION QAS. C 53 DXI=4.98E-4*TETA*SQRT(PE) DUM=TETA25/PE DIM=EXP10(DXI*TETA) PFAK(1)=DIM*DUM SQDXI=1./SQRT(DXI) H(1)=SHXIJ(1)*SQDXI DO54 J=2,5 PFAK(J)=PFAK(J-1)*DIM 54 H(J)=SHXIJ(J)*SQDXI XNEL=PE/(XKBOL*T) PFISH=4.2E3/XNEL**0.166666667 C C PARTITION FUNCTIONS AND IONIZATION EQUILIBRIA C XNECNO=0. XNENH=0. EJON=0. JA=1 C C BEGINNING OF LOOP OVER ELEMENTS ('THE I-LOOP'). DO24 I=1,NEL NJP=NJ(I) C C SHOULD ELEMENT NO. I BE CONSIDERED IF(IELEM(I).GT.0)GO TO 9 DO 55 J=1,NJP ANJON(I,J)=0. PART(I,J)=0. 55 CONTINUE GO TO 23 C C BEGINNING OF LOOP OVER STAGES OF IONIZATION ('THE J-LOOP') 9 DO19 J=1,NJP JM1=J-1 C C SHOULD STAGE OF IONIZATION NO. J BE CONSIDERED IF(ION(I,J).GT.0)GO TO 10 ANJON(I,J)=0. PART(I,J)=0. GO TO 18 C C WHICH KIND OF PARTITION FUNCTION SHOULD BE COMPUTED C C* C* 88-04-25 ADDITION (PHILIP JUDGE) C* IF THE TEMPERATURES AND PRESSURES LOOK 'CORONAL', AND THE DATA IS NOT C* COMPUTED IN DETAIL IN FILE 'BMET', AND THE ELEMENT IS NOT HYDROGEN, C* THEN COMPUTE THE CORONAL LIMIT IONIZATION FRACTIONS C* C* PARAMETERS TECOR AND DECOR ARE USED TO SPECIFY THE CORONAL C* APPROXIMATION- THEY ARE READ IN ROUTINE INJON C* C* ADD IN PARTITION FUNCTIONS = CONSTANT (UNITY HERE) C* C* C* 92-07-20 MODIFICATION IEL CHANGED TO CEL 10 IF (T .GT. TECOR .AND. PE/BK/T .LT. DECOR * .AND. FRCION(I,J,NTP) .LT. 0.E0 * .AND. CEL(I) .NE. 'H ') THEN CALL CORONA(CEL(I),J,T,PE,FCORON) IF (FCORON .LT. 0.E0)GOTO 101 F(J)=FCORON PART(I,J)=1.E0 PART(I,J+1)=1.E0 GOTO 19 END IF 101 IF (IQFIX(I,J)-1) 14,11,13 C* END PGJ ADDITION C* 11 IF(T.LT.TPARF(1).OR.T.GT.TPARF(4))GO TO 13 PARTP=PART(I,J) IF(ITP.GT.0)GO TO 15 C C PARTITION FUNCTIONS TO BE INTERPOLATED IN T JPARF=(JA-1)*4+1 PARTP=0. DO12 IP=1,4 PARTP=PARTP+PARQ(JPARF)*DQ(IP) 12 JPARF=JPARF+1 GO TO 15 C C PARTITION FUNCTIONS FOLLOWING TRAVING ET AL., ABH. HAMB. VIII, 1 (1966) 13 PARTP=QTRAV(TETA,H(J),J,JA) GO TO 15 C C THE PARTITION FUNCTION IS CONSTANT 14 PARTP=PARCO(JA) C* C* PGJ MODIFICATIONS START C* USE FRCION AS A FLAG THAT MULTI COMPUTED DATA EXISTS FOR ZNLTE C* 15 CONTINUE IF(FRCION(I,J,NTP).GE.0.0) PARTP = ZNLTE(I,J,NTP) IF(J .EQ. NJP) THEN IF(FRCION(I,JM1,NTP) .GE. 0.0) PARTP = ZNLTE(I,J,NTP) END IF PART(I,J) = PARTP C* C* PGJ MODIFICATIONS END C* C C IONIZATION EQUILIBRIA AND TOTAL NUMBER OF ELECTRONS C IF(J.LE.1)GO TO 19 IF(ITP.GT.0)GO TO 17 RFAK(JA)=EXP10(-XIONG(I,JM1)*TETA) 17 F(JM1)=PFAK(JM1)*RFAK(JA)*PARTP/PART(I,J-1) C* C* MODIFICATIONS START C** PGJ ADDED NEW VARIABLE FTEMP TO STORE LTE POPULATIONS TEMPORARILY IF(FRCION(I,JM1,NTP).GE.0.0) THEN FTEMP(I,JM1)=F(JM1) F(JM1) = FRCION(I,JM1,NTP) ENDIF C** PGJ MODIFICATIONS END C* MODIFICATIONS END C* GO TO 19 18 IF(J.GT.1)F(JM1)=0. 19 JA=JA+1 C END OF 'THE J-LOOP' C FIL=1. DO20 J=2,NJP LL=NJP-J+1 20 FIL=1.+F(LL)*FIL C* C* 88-01-30 MODIFICATIONS START FIL=1./FIL ANJON(I,1)=FIL XNEN=0. DO21 J=2,NJP JM1=J-1 FIL=FIL*F(JM1) ANJON(I,J)=FIL C* 88-01-30 MODIFICATIONS END C* IF(I.LE.1)GO TO 24 FLJM1=JM1 21 XNEN=ANJON(I,J)*FLJM1+XNEN IF(I.GT.2.AND.I.LT.6) XNECNO=XNECNO+XNEN*ABUND(I) C* C* 89-03-24 START C* STORE CONTRIBUTION FROM C, N, O IN XNENC, XNENN, XNENO TO BE C* MULTIPLIED BY ABUNDM AFTER THE MOLECULE FORMATION PART C* IF(I.EQ.3) THEN XNENC=XNEN ELSE IF(I.EQ.4) THEN XNENN=XNEN ELSE IF(I.EQ.5) THEN XNENO=XNEN ENDIF C* 89-03-24 END XNENH=XNEN*ABUND(I)+XNENH C XNENH=NUMBER OF ELECTRONS FROM ELEMENTS OTHER THAN HYDROGEN (Q IN C MIHALAS, METH. COMP. PHYS. 7, 1 (1967), EQ. (35)) C XNECNO=NUMBER OF ELECTRONS FROM ELEMENTS OTHER THAN H, C, N, O C C C COMPUTATION OF THE ENERGY OF IONIZATION (EJON). HYDROGEN IS NOT C INCLUDED. C XERG=0. C XERG= THE ENERGY OF IONIZATION PER ATOM (IN ELECTRON VOLTS) C DO22 J=2,NJP JM1=J-1 FLJM1=JM1 22 XERG=ANJON(I,J)*(XIONG(I,JM1)-DXI*FLJM1)+XERG EJON=XERG*ABUND(I)+EJON GO TO 24 23 JA=JA+NJP 24 CONTINUE C END OF 'THE I-LOOP' C C XNECNO=XNENH-XNECNO TP=T IF(IEPRO.LE.0)GO TO 71 C C COMP. OF PRESSURE, DENSITY AND INNER ENERGY C XIH=XIONG(1,1)-DXI XIHM=0.754-2.*DXI C XIH AND XIHM ARE THE ENERGIES OF IONIZATION FOR H AND H- RESPECTIVELY C (IN ELECTRON VOLTS). C XKHM=TETA25*2.*EXP10(-TETA*XIHM) C XKHM = THE 'DISSOCIATION CONSTANT' FOR H-. C IF(T.GT.TMOLIM)GO TO 42 C* C* 87-10-20 MODIFICATIONS START NE=PE/(XKBOL*T) IF(HLTE) THEN HJONH=ANJON(1,2)/ANJON(1,1) ELSE NH=0.0 NHLTE=NPIN(NTP)*ANJON(1,1)/ANJON(1,2) DO 35 N=1,5 NH=NH+NHYD(NTP,N) 35 CONTINUE NP=NPIN(NTP) HJONH=NP/NH CALL MOLFYS(T,XKH2,XKH2P,DEH2,DEH2P) NH2=NH*NH/XKH2*XKBOL*T NH2P=NH*NP/XKH2P*XKBOL*T NHMIN=NH*NE/XKHM*XKBOL*T NHT=NH+NP+NHMIN+2.*(NH2+NH2P) FE=NE/NHT ENDIF IF(MOLH.LE.0) GOTO 45 C C FORMATION OF MOLECULES. ONLY H2 AND H2+ 41 CONTINUE IF(HLTE) THEN CALL MOLEQ(T,PE,HJONH,XIH,XKHM,XIHM,XNENH,F1,F2,F3,F4,F5,FE, * FSUM,EH) NHT=NE*FE NH=F1*NHT NP=F2*NHT NHMIN=F3*NHT NH2P=F4*NHT NH2=F5*NHT ELSE F1=NH/NHT F2=NP/NHT F3=NHMIN/NHT F4=NH2P/NHT F5=NH2/NHT ENDIF C* 87-10-20 MODIFICATIONS END C* FEPE=PE/FE F1P=F1*FEPE F3P=F3*FEPE F4P=F4*FEPE F5P=F5*FEPE GO TO 43 C FORMATION OF MOLECULES COMPOSED OF H,C,N,O 45 IF(ANJON(3,1).LE.0..OR.ANJON(4,1).LE.0..OR.ANJON(5,1).LE.0.) * GOTO 41 HJONC=ANJON(3,2)/ANJON(3,1) HJONN=ANJON(4,2)/ANJON(4,1) HJONO=ANJON(5,2)/ANJON(5,1) ABUC=ABUND(3)/ABUND(1) ABUN=ABUND(4)/ABUND(1) ABUO=ABUND(5)/ABUND(1) CALL MOL(T,PE,HJONH,HJONC,HJONN,HJONO,ABUC,ABUO,ABUN,XIH,XKHM,XIHM *,XNECNO,F1,F2,F3,F4,F5) SUMPMO=0. PRESMO(1)=FHE*PK(1) PRESMO(2)=FHE*FHE*PK(2) PRESMO(3)=FHE*FHE*HJONH*PK(3) PRESMO(4)=FHE*FHE*FOE*PK(4) PRESMO(5)=FHE*FOE*PK(5) PRESMO(6)=FHE*FCE*PK(6) PRESMO(7)=FCE*FOE*PK(7) PRESMO(8)=FCE*FNE*PK(8) PRESMO(9)=FCE*FCE*PK(9) PRESMO(10)=FNE*FNE*PK(10) PRESMO(11)=FOE*FOE*PK(11) PRESMO(12)=FNE*FOE*PK(12) PRESMO(13)=FNE*FHE*PK(13) DO 30 I=1,13 PRESMO(I)=PRESMO(I)*PE 30 SUMPMO=SUMPMO+PRESMO(I) SUMPA=PE*(FHE+FCE+FNE+FOE) SUMPI=PE*(FHE*HJONH+FCE*HJONC+FNE*HJONN+FOE*HJONO) HNIC=PE*FHE HPNIC=HNIC*HJONH PG=PE+SUMPMO+SUMPA+SUMPI+PE*SUMM/FE C* C* 87-10-20 MODIFICATIONS START C* 88-01-30 TKINV=1./(XKBOL*T) NH=HNIC*TKINV NP=HPNIC*TKINV NHLTE=NP*ANJON(1,1)/ANJON(1,2) NHMIN=PRESMO(1)*TKINV NH2=PRESMO(2)*TKINV NH2P=PRESMO(3)*TKINV NHT=NH+NP+NHMIN+2.*(NH2+NH2P) NC=(1.+HJONC)*FC*NHT NN=(1.+HJONN)*FN*NHT NO=(1.+HJONO)*FO*NHT NCH=PRESMO(6)*TKINV NCO=PRESMO(7)*TKINV NCN=PRESMO(8)*TKINV GOTO 46 C* 87-10-20 MODIFICATIONS END C* 88-01-30 C C NO MOLECULES 42 CONTINUE C* C* 87-05-30 MODIFICATIONS START NE=PE/(XKBOL*T) IF(HLTE) THEN FE=XNENH+ANJON(1,2) NHT=NE/FE NP=ANJON(1,2)*NHT NH=ANJON(1,1)*NHT NHLTE=NH ELSE NHLTE=NPIN(NTP)*ANJON(1,1)/ANJON(1,2) NH=0.0 DO 422 N=1,5 NH=NH+NHYD(NTP,N) 422 CONTINUE NP=NPIN(NTP) NHT=NH+NP FE=NE/NHT ENDIF NHMIN=NH*NE/XKHM*XKBOL*T NH2=0.0 NH2P=0.0 F2=NP/NHT F1=NH/NHT C* 87-05-30 MODIFICATIONS END C* F3=0. F4=0. F5=0. FSUM=1. EH=-XIH*F1 43 PG=PE*(1.+(FSUM+SUMH)/FE) 46 RO=PE*XMH*XMY/(XKBOL*FE*T) XYRHO=RO E=1.5*PG/RO+(EH+EJON)*ENAMN YYPG=PG YYRHO=RO YYE=E C C* 88-01-30 MODIFICATIONS START IF(T.GT.TMOLIM .OR. MOLH.GT.0) THEN NC=ABUND(3)/ABUND(1)*NHT NN=ABUND(4)/ABUND(1)*NHT NO=ABUND(5)/ABUND(1)*NHT NCH=0.0 NCO=0.0 NCN=0.0 ENDIF C* 87-07-29 MODIFICATIONS START C* 88-01-30 C* STORE DEPTH-DEPENDENT VARIABLES FOR TRANSFER IN COMMON C* BLOCKS COPBID AND COUT PGC(NTP)=PG ROC(NTP)=RO XMYC(NTP)=XMY*NHT/PG*XKBOL*T EJONC(NTP)=EJON*EEV XNENHC(NTP)=XNENH TOTHI(NTP)=NH TOTH(NTP)=NHT TOTH2(NTP)=NH2 TOTC(NTP)=NC TOTNIT(NTP)=NN TOTO(NTP)=NO TOTCH(NTP)=NCH TOTCO(NTP)=NCO TOTCN(NTP)=NCN C* 87-07-29, 88-01-30 MODIFICATIONS END C* 89-03-24 START ABUNDM(1)=(NH+NP)/NHT ABUNDM(3)=NC/NHT ABUNDM(4)=NN/NHT ABUNDM(5)=NO/NHT XNENH=XNECNO+ABUNDM(3)*XNENC+ABUNDM(4)*XNENN+ABUNDM(5)*XNENO C* 89-03-24 END C* C IF(IOUTR.LE.0)GO TO 71 C C **** PRINT-OUT **** C C* C* 87-11-02 MODIFICATIONS: C* 1P E-FORMAT, C* IWOPTN GOVERNS PRINTOUT, BINARY SWITCHES: C* 1 OPACITY CONTRIBUTIONS C* 2 PARTIAL PRESSURES C* 4 IONIZATION FRACTIONS, PARTITION FUNCTIONS C* IF(.NOT.MASKWR(IWOPTN,1) .AND. .NOT.MASKWR(IWOPTN,2)) GOTO 71 WRITE(IWRIT,204)T,PE,PG,RO,E IF(MASKWR(IWOPTN,2)) THEN WRITE(IWRIT,201) WRITE(IWRIT,202) DO93 I=1,NEL NJP=NJ(I) C* C* PGJ ALTERATION: WRITE BLANKS INSTEAD OF ZEROS C* 89-03-24 MC ALTERATION: WRITE NON-LTE IONIZATION FOR HYDROGEN DO 303 J=1,NJP WRITE(CPART(J)(1:10),FMT='(1P,E10.3)')PART(I,J) IF(I.GT.1) THEN ANJONW=ANJON(I,J) ELSE IF(J.EQ.1) THEN ANJONW=NH/(NH+NP) ELSE ANJONW=NP/(NH+NP) ENDIF IF(ANJONW .LT. 1.E-4)THEN WRITE(CANJON(J)(2:8),FMT='(1P,E7.1)') ANJONW CANJON(J)(1:1)=' ' ELSE WRITE(CANJON(J)(1:8),FMT='(F8.4)') ANJONW ENDIF 303 CONTINUE DO 3031 J=NJP+1,4 CANJON(J)(1:8) = ' ' CPART(J)(1:10) = ' ' 3031 CONTINUE WRITE (IWRIT,FMT=203) CEL(I)(1:2),ABUNDM(I), * (CANJON(J)(1:8),J=1,4),(CPART(J),J=1,4) C* END PGJ,MC ALTERATIONS C* 93 CONTINUE ENDIF IF(T.GT.TMOLIM .OR. .NOT.MASKWR(IWOPTN,1))GO TO 44 IF(MOLH.LE.0)GOTO 47 WRITE(IWRIT,205)F1P,F3P,F5P,F4P GO TO 71 47 CONTINUE WRITE(IWRIT,208)HNIC,(PRESMO(I),I=1,13) GOTO 71 44 WRITE(IWRIT,206) C 71 CONTINUE C* C* PGJ- HAVING USED NON-LTE POPULATIONS AND PARTITION FUNCTIONS FROM C* MULTI WE NOW RE-ASSIGN LTE ION FRACTIONS FOR THE COMPUTATION OF THE C* DETAILED OPACITIES IN ROUTINE ABSKO C* DO 241 I = 1,NEL NJP = NJ(I) FIL = 1. INLTE=0 DO 2021 J = 2,NJP JM1 = J - 1 IF (FRCION(I,JM1,NTP).LT.0.0) GOTO 2021 LL = NJP - J + 1 FIL = 1. + FTEMP(I,LL)*FIL INLTE=1 2021 CONTINUE IF(INLTE .EQ. 0) GOTO 241 ANJON(I,1) = 1. / FIL DO 211 J = 2,NJP JM1 = J - 1 ANJON(I,J) = ANJON(I,JM1)*FTEMP(I,JM1) 211 CONTINUE 241 CONTINUE C** END PGJ ADDITION C** C ADD TM C WRITE(*,*)' JON ROUTINE EXECUTED.' C END ADD TM RETURN 201 FORMAT(1H0,'ELEMENT ABUNDANCE IONIZATION FRACTIONS',17X, *'PARTITION FUNCTIONS') 202 FORMAT(1H ,23X,1HI,7X,2HII,6X,3HIII,5X,2HIV,12X,1HI,9X,2HII,8X, *3HIII,7X,2HIV) 203 FORMAT (6H ,A2,1P,E12.4,4A8,5X,4A10) 204 FORMAT(3H0T=,F7.1,5X,3HPE=,1P,E12.4,5X,3HPG=,E12.4,5X,3HRO=,E12.4, *5X,2HE=,E12.4) 205 FORMAT(1H0,'PARTIAL PRESSURES'/4X,'H',8X,'H-',7X,'H2',7X,'H2+'/1X, *4(1PE9.2)) 206 FORMAT(1H0,'NO MOLECULES CONSIDERED') 207 FORMAT(1H+,56X,1P,4E10.3) 208 FORMAT(1H0,'PARTIAL PRESSURES'/4X,'H',8X,'H-',7X,'H2',7X,'H2+',6X, *'H2O',6X,'OH',7X,'CH',7X,'CO',7X,'CN',7X,'C2',7X,'N2',7X,'O2',7X, *'NO',7X,'NH'/1X,14(1PE9.2)) END C C*********************************************************************** C FUNCTION QTRAV(TETA,HP,J,JA) C C HERE THE PARTITION FUNCTIONS ACCORDING TO TRAVING ET AL., ABH. HAMB. C STERNW. VIII, 1 (1966) ARE COMPUTED. THE SYMBOLS ARE GIVEN C IN THE COMMENTS AT THE BEGINNING OF SUBROUTINE INJON. C FUNCTION QAS IS CALLED. C C DIMENSIONS NECESSARY C A(5),ASDE(KMAX),H(5),QPRIM(KMAX) C KMAX IS THE TOTAL NUMBER OF ELECTRON CONFIGURATIONS. C DIMENSIONS OF ARRAYS IN COMMON /CI3/ ARE COMMENTED ON IN SUBROUTINE C INJON. C C: QTRAV 92-11-27 MODIFICATIONS: (MATS CARLSSON) C: SAVE STATEMENT ADDED C: INCLUDE 'PREC' PARAMETER (MEL=16,MJMAX=90,MKMAX=140,MLMAX=400,MJ=5) DIMENSION ASDE(MKMAX),QPRIM(MKMAX) C COMMON/CI3/ALFA(MLMAX),GAMMA(MLMAX),G0(MJMAX),G2(MKMAX), * XION(MKMAX),XL(MKMAX),JBBEG(MJMAX),JCBEG(MJMAX),NK(MJMAX), * NL(MKMAX),IFISH C COMMON/CI7/A(5),PFISH,ITP C SAVE C C C STATEMENT FUNCTION FOR 10.** EXP10(X)=EXP(2.302585*X) C FLJ=J JB=JBBEG(JA) JC1=JCBEG(JA) NKP=NK(JA) QSUM=0. C C WE START THE LOOP OVER DIFFERENT ELECTRON CONFIGURATIONS ('THE K-LOOP' DO5 K=1,NKP JC2=NL(JB)+JC1-1 C C IS TETA=PRECEDING TETA IF(ITP.GT.0)GO TO 4 PRA=XION(JB)*TETA IF(PRA.LT.12.)GO TO 1 ASDE(JB)=0. GO TO 2 1 ASDE(JB)=G2(JB)*EXP10(-PRA) C 2 QPRIM(JB)=0. IF(NL(JB).LE.0)GO TO 4 DO3 L=JC1,JC2 PRE=GAMMA(L)*TETA IF(PRE.GT.12.)GO TO 3 QPRIM(JB)=QPRIM(JB)+ALFA(L)*EXP10(-PRE) 3 CONTINUE 4 JC1=JC2+1 QSUM=QPRIM(JB)+ASDE(JB)*QAS(HP,XL(JB),A(J),FLJ,PFISH,IFISH) * +QSUM 5 JB=JB+1 C END OF 'THE K-LOOP' QTRAV=G0(JA)+QSUM C RETURN END FUNCTION QAS(H,XL,A,Z,PFISH,IFISH) C C THIS ROUTINE COMPUTES THE ASYMPTOTIC PARTS OF THE PARTITION C FUNCTIONS FOLLOWING C BASCHEK ET AL., ABH. HAMB. VIII, 26 (1966) IF IFISH = 0 C FISCHEL AND SPARKS, AP. J. 164, 359 (1971) IF IFISH = 1 C (APPROXIMATING THE ZETA FUNCTIONS BY INTEGRALS). C C XL=QUANTUM NUMBER FOR THE FIRST LEVEL OF THE ASYMPTOTIC PART C H=QUANTUM NUMBER OF THE CUT (FOR IFISH=0) C A=DZ(FISCHEL AND SPARKS)=ALFA(BASCHEK ET AL.) C PFISH=P(FISCHEL AND SPARKS), ONLY NECESSARY IF IFISH = 1 C C C INCLUDE 'PREC' COMMON/UTPUT/ IREAD, IWRIT C QAS=0.0 IF(IFISH.LT.0) RETURN C C WHICH TYPE IF(IFISH.GT.0)GO TO 1 C C BASCHEK ET AL. QAS=0.333333*(H*(H+1.)*(H+0.5)-XL*(XL+1.)*(XL+0.5)) + * A*(H-XL)+0.5*A*A*(H-XL)/(H*XL) RETURN C C FISCHEL AND SPARKS 1 P=PFISH*Z C C FISCHEL AND SPARKS, EQ. (26) P2=P*P P3=P2*P IF(P.LE.XL)GO TO 2 XLM1=XL-1. R2=XLM1*XLM1 R3=R2*XLM1 QAS=1.3333333*P3+0.5*P2+0.16666667*P+1.33333333*A*P-0.4*A*A/P- *0.33333333*R3-0.5*R2-0.16666667*XLM1-A*XLM1+0.5*A*A/XL RETURN C C FISCHEL AND SPARKS, EQ. (27) 2 AXL2=A/(XL*XL) QAS=P3*P/XL*(1.+AXL2*(0.33333333+0.1*AXL2)) RETURN END SUBROUTINE MOLEQ(T,PE,G2,XIH,XKHM,XIHM,XNENH,F1,F2,F3,F4,F5,FE, * FSUM,EH) C C THIS ROUTINE COMPUTES DISSOCIATION EQUILIBRIA FOR THE MOLECULES C H2 AND H2+ WITH H+, H AND H- CONSIDERED. IT MAINLY FOLLOWS MIHALAS, C METH. COMP. PHYS. 7, 1 (1967). C C THE INNER ENERGY OF THE HYDROGEN GAS, EH, IS ALSO EVALUATED. C C XIH=THE IONIZATION ENERGY OF HYDROGEN C XKHM=THE 'DISSOCIATION CONSTANT' OF H- C XIHM=THE 'DISSOCIATION ENERGY' OF H-. C XNENH=THE NUMBER OF ELECTRONS PER UNIT VOLUME FROM ELEMENTS OTHER THAN C HYDROGEN (Q IN MIHALAS'S ARTICLE) C G2,F1,F2 ETC. SEE REF. C DOUBLE PRECISION NECESSARY FOR RELATIVELY LOW PRESSURES. C C C INCLUDE 'PREC' COMMON/UTPUT/ IREAD, IWRIT DOUBLE PRECISION G3,G4,G5,A,E,B,C,D,C1,C2,C3,CAM,F1D,F2D,F3D,F4D, *F5D,FED,FSUMD,ROOT C C CALL MOLFYS FOR PHYSICAL DATA CALL MOLFYS(T,XKH2,XKH2P,DEH2,DEH2P) C C CALCULATION OF THE EQUILIBRIUM G3=PE/XKHM G4=PE/XKH2P G5=PE/XKH2 A=1.+G2+G3 E=G2*G4/G5 B=2.*(1.+E) C=G5 D=G2-G3 C1=C*B*B+A*D*B-E*A*A C2=2.*A*E-D*B+A*B*XNENH C3=-(E+B*XNENH) CAM=C2/(2.*C1) ROOT=DSQRT(CAM*CAM-C3/C1) F1D=-CAM+ROOT IF(F1D.GT.1.E0)F1D=-CAM-ROOT F5D=(1.E0-A*F1D)/B F4D=E*F5D F3D=G3*F1D F2D=G2*F1D FED=F2D-F3D+F4D+XNENH FSUMD=F1D+F2D+F3D+F4D+F5D F1=F1D F2=F2D F3=F3D F4=F4D F5=F5D FE=FED FSUM=FSUMD C C CALCULATION OF THE ENERGIES EH2=(-2.*XIH+DEH2)*F5 EH2P=(-XIH+DEH2P)*F4 EHM=-(XIHM+XIH)*F3 EHJ=-XIH*F1 EH=EHJ+EHM+EH2+EH2P 1 CONTINUE RETURN END SUBROUTINE MOLFYS(T,XKH2,XKH2P,DEH2,DEH2P) C C THIS ROUTINE GIVES DISSOCIATION CONSTANTS XKH2 (=N(H I)*N(H I)/N(H2) ) C AND XKH2P (=N(H I)*N(H II)/N(H2+)), EXPRESSED IN NUMBER PER CM3, AND C THE SUM OF DISSOCIATION, ROTATION AND VIBRATION ENERGIES, DEH2 AND C DEH2P FOR H2 AND H2+, RESPECTIVELY (EXPRESSED IN ERGS PER MOLECULE). C THE DATA ARE FROM VARDYA, M.N.R.A.S. 129, 205 (1965) AND EARLIER C REFERENCES. THE DISSOCIATION CONSTANT FOR H2 IS FROM TSUJI, C ASTRON. ASTROPHYS. 1973. C INCLUDE 'PREC' DIMENSION A1(5),A2(4),B1(5),B2(5),TE(5) DATA A1/12.739,-5.1172,1.2572E-1,-1.4149E-2,6.3021E-4/, *A2/11.20699 ,-2.794276 ,-0.079196 ,0.024790 /, *B1/2.6757,-1.4772,0.60602,-0.12427,0.009750/, *B2/2.9216,-2.0036,1.7231,-0.82685,0.15253/ TEX=5040./T TE(1)=1. DO1 K=1,4 1 TE(K+1)=TE(K)*TEX XKH2=0. XKH2P=0. DEH2=0. DEH2P=0. DO2 K=1,4 XKH2=A1(K)*TE(K)+XKH2 XKH2P=A2(K)*TE(K)+XKH2P DEH2=B1(K)*TE(K)+DEH2 2 DEH2P=B2(K)*TE(K)+DEH2P XKH2=A1(5)*TE(5)+XKH2 DEH2=(B1(5)*TE(5)+DEH2)*8.617E-5*T-4.476 DEH2P=(B2(5)*TE(5)+DEH2P)*8.617E-5*T-2.648 XKH2=10.**XKH2 XKH2P=10.**XKH2P RETURN END C C ************************************************************************** C SUBROUTINE MOL(T,PE,G2,GC,GN,GO,ABUC,ABUO,ABUN,XIH,XKHM,XIHM,XNEN, *F1,F2,F3,F4,F5) C C THIS ROUTINE COMPUTES DISSOCIATION EQUILIBRIA FOR THE MOLECULES H2,H2+, C H2O,OH,CH,CO,CN,C2,O2,N2,NH AND NO WITH H,H-,H+,C,C+,O,O+,N,N+ CON- C SIDERED, USING A NEWTON-RAPHSON SCHEME. SOME FEATURES COME FROM THE C MONSTER AND FROM MIHALAS, METH. COMP. PHYS. 7,1. C C G2=N(HII)/N(HI), GC=N(CII)/N(CI) ETC. C ABUC= THE NUMBER OF CARBON NUCLEI PER HYDROGEN NUCLEUS, ABUO AND ABUN C ARE THE CORRESPONDING VALUES FOR OXYGEN AND NITROGEN. C XIH = THE IONIZATION ENERGY OF HYDROGEN C XIHM= THE 'DISSOCIATION ENERGY' OF H- C XKHM= THE 'DISSOCIATION CONSTANT' OF H- C XNEN= THE NUMBER OF ELECTRONS PER UNIT VOLUME FROM ELEMENTS OTHER THAN C HYDROGEN, CARBON, OXYGEN AND NITROGEN. C C THE SUBSCRIPT IN AKD(I) ETC. HAS THE FOLLOWING MEANING C I=1 H-, 2 H2, 3 H2+, 4 H2O, 5 OH, 6 CH, 7 CO, 8 CN, 9 C2, 10 N2, C 11 O2, 12 NO, 13 NH C C THIS ROUTINE CALLS MOLMAT AND AINV2 C THE DATA FOR COMPUTING THE DISSOCIATION CONSTANTS ARE FROM TSUJI C (ASTRON. ASTROPHYS. 23,411 (1973)) C C THE ROUTINE GIVES FH, FC, FO, FN, FE. FH=P(HI)/PH, FC=P(CI)/PH ETC., C WHERE PH=NH*KT (NH IS THE NUMBER OF HYDROGEN NUCLEI PER CM3). C C: C: MOL 87-10-20 MODIFICATIONS: (MATS CARLSSON) C: NON-LTE OPTION ADDED. FE IS THEN FIXED TO BE NE/NHT AND C: THE CHARGE CONSERVATION EQUATION IS NOT USED. C: INCLUDE 'PREC' DOUBLE PRECISION AKA(12),AK1(12),AK2(12),AK3(12),AK4(12),AKD(13), *PK(13),TH,WKH,WKC,WKN,WKO,FH,FC, *FN,FO,FE,CAM,ROOT,QN,QNN,A(6,6),F(6),D(6),FHP,FCP,FOP,FNP,FEP *,S,R,B,BK DIMENSION B1(5),B2(5),DIS(10) COMMON/CMOL/PPK(13),FFH,FFC,FFN,FFO,FFE,FHE,FCE,FNE,FOE,EH DATA B1/2.6757,1.4772,0.60602,0.12427,0.00975/, *B2/2.9216,2.0036,1.7231,0.82685,0.15253/, *DIS/9.50,4.38,3.47,11.11,7.90,6.12,9.76,5.12,6.51,3.21/ DATA AKA/12.739E0,11.206998E0,25.420E0,12.371E0,12.135E0,13.820E0, *12.805E0,12.804E0,13.590E0,13.228E0,12.831E0,12.033E0/ DATA AK1/5.1172E0,2.7942767E0,10.522E0,5.0578E0,4.0760E0,11.795E0, *8.2793E0,6.5178E0,10.585E0,5.5181E0,7.1964E0,3.8435E0/ DATA AK2/1.2572E-1,-7.9196803E-2,1.6939E-1,1.3822E-1,1.2768E-1, *1.7217E-1,6.4162E-2,9.7719E-2,2.2067E-1,6.9935E-2,1.7349E-1, &1.3629E-1/ DATA AK3/1.4149E-2,-2.4790744E-2,1.8368E-2,1.6547E-2,1.5473E-2, *2.2888E-2,7.3627E-3,1.2739E-2,2.9997E-2,8.1511E-3,2.3065E-2, *1.6643E-2/ DATA AK4/6.3021E-4,0.E0,8.1730E-4,7.7224E-4,7.2661E-4,1.1349E-3, *3.4666E-4,6.2603E-4,1.4993E-3,3.7970E-4,1.1380E-3,7.8691E-4/ C* C* 87-10-20 MODIFICATIONS START PARAMETER (MT=300,MKOMP=150,ML=50000,MSET=1,MLATB=50,MTETB=30, * MELMAX=2,MKOMPR=MKOMP,MKOMPT=10, * KFADIM=MKOMPR*MT+MKOMPT*MT*3,IFADIM=MKOMPT*MT) C LOGICAL HLTE REAL NHYD,NPIN COMMON/CIN/ NHYD(MT,5),NPIN(MT),HLTE REAL NH,NP,NH2,NH2P,NHMIN,NHT,NHLTE COMMON/HYDCOM/NH,NP,NH2,NH2P,NHMIN,NHT,NHLTE REAL NE DATA XKBOL/1.380662E-16/ C* 87-10-20 MODIFICATIONS END C* C C COMPUTATION OF DISSOCIATION CONSTANTS (AKD) AND PE/K(AB) (PK). TH=5040.E0/T AKD(1)=XKHM PK(1)=PE/XKHM DO 4 J=2,13 M=J-1 AKD(J)=10.E0**(AKA(M)-(AK1(M)-(AK2(M)-(AK3(M)-AK4(M)*TH)*TH)*TH)* *TH) 4 PK(J)=PE/AKD(J) PK(4)=PE*PK(4) C C COMPUTATION OF STARTING VALUES FOR FH,FC ETC. C WKH=1.E0+G2+PK(1) WKC=1.E0+GC WKO=1.E0+GO WKN=1.E0+GN C* C* 87-10-20 MODIFICATIONS START IF(HLTE) THEN FE=XNEN ELSE NE=PE/(XKBOL*T) FE=NE/NHT ENDIF C* 87-10-20 MODIFICATIONS END C* CAM=FE*(1.E0+G2+PK(1))/(2.E0*PK(2)) ROOT=DSQRT(DABS(CAM*CAM+FE/PK(2))) FH=-CAM+ROOT C* IF(HLTE) FE=FH*(G2-PK(1))+XNEN IF(FE.GT.0.E0) GOTO 60 R=PK(2)/PK(1)/PK(1) CAM=(WKH*XNEN/PK(1)-1.E0-2.E0*XNEN*R) S=R-WKH/PK(1) CAM=CAM/2.E0/S ROOT=DSQRT(CAM*CAM-R*XNEN*XNEN/S) C* IF(HLTE) FE=-CAM-ROOT IF(FE.LT.0.) FE=-CAM+ROOT FH=(XNEN-FE)/PK(1) 60 CONTINUE R=1.E0+GO+PK(4)*FH*FH/FE/FE+PK(5)*FH/FE S=1.E0+GC+PK(6)*FH/FE B=PK(7)/FE CAM=(B*(ABUC-ABUO)+R*S)/(2.E0*R*B) BK=ABUO/R*S/B FO=-CAM+DSQRT(CAM*CAM+BK) FC=ABUC/(S+B*FO) 61 QN=1.E0+(FH*PK(13)+FC*PK(8))/FE QNN=FE/4.E0/PK(10) CAM=QN*QNN ROOT=DSQRT(DABS(CAM*CAM+2.E0*ABUN*QNN)) FN=-CAM+ROOT IF(FN.LT.0.E0) FN=0.E0 C C COMPUTATION OF FH,FC, ETC. USING ALL RELEVANT MOLECULES, ATOMS AND IONS C DIFF GIVES THE APPROX. ACCURACY TO WHICH FH ETC. HAVE TO CONVERGE C BEFORE THE ITERATIONS ARE STOPPED. C DIFF=0.001 C* C* 87-10-20 MODIFICATIONS START C IN NON-LTE: DO NOT INCLUDE CHARGE CONSERVATION EQUATION C THEREFORE SET NUMBER OF EQUATIONS TO 4 TO FORCE UNCHANGED C FE IF(HLTE) THEN M=5 ELSE M=4 D(5)=0.0 ENDIF C* 87-10-20 MODIFICATIONS END C* DO 2 J=1,100 FHP=FH FCP=FC FOP=FO FNP=FN FEP=FE NICO=J CALL MOLMAT(PK,G2,GC,GN,GO,ABUC,ABUN,ABUO,FH,FC,FN,FO,FE,XNEN,F,A) CALL AINV2(A,M) DO 30 L=1,M QN=0.E0 DO 3 LL=1,M 3 QN=QN+A(L,LL)*F(LL) D(L)=-QN 30 CONTINUE FH=FH+D(1) FC=FC+D(2) FO=FO+D(3) FN=FN+D(4) FE=FE+D(5) CHECH=DABS(1.E0-FHP/FH) CHECC=DABS(1.E0-FCP/FC) CHECO=DABS(1.E0-FOP/FO) CHECN=DABS(1.E0-FNP/FN) CHECE=DABS(1.E0-FEP/FE) IF(NICO.LE.2) GOTO 2 IF(CHECH.LT.DIFF.AND.CHECC.LT.DIFF.AND.CHECO.LT.DIFF.AND.CHECN.LT. *DIFF.AND.CHECE.LT.DIFF) GOTO 23 2 CONTINUE PRINT 305,FH,FC,FO,FN,FE,CHECH,CHECC,CHECO,CHECN,CHECE 305 FORMAT(' ***MOL*** THE DESIRED ACCURACY WAS NOT ACHIEVED AFTER 100 * ITERATIONS. LATEST VALUES AND DIFFERENCES WERE'/2X,5(1PE11.4),10 *X,5E10.3) 23 CONTINUE C COMPUTATION OF THE INNER ENERGY. DEH2 AND DEH2P ARE THE SUM OF C DISSOCIATION, ROTATION AND VIBRATION ENERGIES (IN EV PER MOLECULE) FOR C H2 AND H2+. DIS(I) IS THE DISSOCIATION ENERGY FOR THE MOLECULE (I+3) C IN THE LIST OF MOLECULES (VALUES ARE FROM TSUJI). FOR THESE MOLECULES C THE ROTATION AND VIBRATION ENERGIES ARE NEGLECTED. 98 TETA=TH DEH2=(B1(1)-(B1(2)-(B1(3)-(B1(4)-B1(5)*TETA)*TETA)*TETA)*TETA)* *8.617E-5*T-4.476 DEH2P=(B2(1)-(B2(2)-(B2(3)-(B2(4)-B2(5)*TETA)*TETA)*TETA)*TETA)* *8.617E-5*T-2.648 FHE=FH/FE FCE=FC/FE FOE=FO/FE FNE=FN/FE EH2=(-2.*XIH+DEH2)*FHE*FH*PK(2) EH2P=(DEH2P-XIH)*FHE*FH*G2*PK(3) EHM=-(XIHM+XIH)*FH*PK(1) EHJ=-XIH*FH EH2O=-(2.*XIH+DIS(1))*FHE*FH*FO*PK(4) EOH=-(XIH+DIS(2))*FOE*FH*PK(5) ECH=-(XIH+DIS(3))*FHE*FC*PK(6) ECO=-DIS(4)*FCE*FO*PK(7) ECN=-DIS(5)*FCE*FN*PK(8) EC2=-DIS(6)*FCE*FC*PK(9) EN2=-DIS(7)*FNE*FN*PK(10) EO2=-DIS(8)*FOE*FO*PK(11) ENO=-DIS(9)*FNE*FO*PK(12) ENH=-(DIS(10)+XIH)*FNE*FH*PK(13) EH=EH2+EH2P+EHM+EHJ+EH2O+EOH+ECH+ECO+ECN+EC2+EN2+EO2+ENO+ENH FFH=FH FFC=FC FFN=FN FFO=FO FFE=FE DO 72 I=1,13 72 PPK(I)=PK(I) F1=FH F2=G2*FH F3=FH*PK(1) F4=FH*FHE*G2*PK(3) F5=FH*FHE*PK(2) RETURN END C C ************************************************************************** C SUBROUTINE MOLMAT(PK,GH,GC,GN,GO,AC,AN,AO,FH,FC,FN,FO,FE,XNEN,F,A) C C THIS ROUTINE COMPUTES THE ELEMENTS OF MATRIX A AND VECTOR F IN THE C NEWTON-RAPHSON PROCEDURE FOR DETERMINING THE MOLECULAR EQUILIBRIUM. C IT IS CALLED BY SUBR. MOL. C INCLUDE 'PREC' DOUBLE PRECISION PK(13),F(6),FH,FC,FN,FO,FE, *H,HH,C,O,XN,A(6,6),FHE,FCE,FNE,FOE FHE=FH/FE FCE=FC/FE FNE=FN/FE FOE=FO/FE H=1.E0+GH+PK(1)+PK(5)*FOE+PK(6)*FCE+PK(13)*FNE HH=2.E0*FHE*(PK(2)+GH*PK(3)+PK(4)*FOE) C=1.E0+GC+PK(7)*FOE+PK(6)*FHE+PK(8)*FNE O=1.E0+GO+PK(4)*FHE*FHE+PK(5)*FHE+PK(7)*FCE+PK(12)*FNE XN=1.E0+GN+PK(13)*FHE+PK(8)*FCE+PK(12)*FOE F(1)=FH*(H+HH)-1.E0 F(2)=FC*(C+2.E0*PK(9)*FCE)-AC F(3)=FO*(O+2.E0*PK(11)*FOE)-AO F(4)=FN*(XN+2.E0*PK(10)*FNE)-AN F(5)=FH*(GH+PK(3)*GH*FHE-PK(1))+GC*FC+GN*FN+GO*FO-FE+XNEN A(1,1)=H+2.E0*HH A(1,2)=FHE*PK(6) A(1,3)=FHE*(2.E0*PK(4)*FHE+PK(5)) A(1,4)=FHE*PK(13) A(1,5)=-FHE*(PK(5)*FOE+PK(6)*FCE+PK(13)*FNE+2.E0*FHE*(PK(2)+GH*PK( *3)+2.E0*PK(4)*FOE)) A(2,1)=FCE*PK(6) A(2,2)=C+4.E0*PK(9)*FCE A(2,3)=FCE*PK(7) A(2,4)=FCE*PK(8) A(2,5)=-FCE*(FOE*PK(7)+FHE*PK(6)+FNE*PK(8)+2.E0*PK(9)*FCE) A(3,1)=FOE*(2.E0*PK(4)*FHE+PK(5)) A(3,2)=FOE*PK(7) A(3,3)=O+4.E0*PK(11)*FOE A(3,4)=FOE*PK(12) A(3,5)=-FOE*(FHE*PK(5)+FCE*PK(7)+FNE*PK(12)+2.E0*(FOE*PK(11)+PK(4) **FHE*FHE)) A(4,1)=FNE*PK(13) A(4,2)=FNE*PK(8) A(4,3)=FNE*PK(12) A(4,4)=XN+4.E0*FNE*PK(10) A(4,5)=-FNE*(FHE*PK(13)+FCE*PK(8)+FOE*PK(12)+2.E0*PK(10)*FNE) A(5,1)=GH*(1.E0+2.E0*PK(3)*FHE)-PK(1) A(5,2)=GC A(5,3)=GO A(5,4)=GN A(5,5)=-GH*PK(3)*FHE*FHE-1.E0 RETURN END C C ************************************************************************** C SUBROUTINE AINV2(A,M) INCLUDE 'PREC' DIMENSION A(6,6),C(6),IND(6) C***** THIS SUBROUTINE EVALUATES THE INVERSE OF A C***** SQUARE M*M MATRIX A C***** THE DIMENSIONS OF THE ARRAYS MAY BE INTEGER VARIABLES WHEN USED********* C***** ON THE IBM 7094,BUT THEY MUST BE INTEGER CONSTANTS ON THE IBM 1130****** DOUBLE PRECISION A,C,AMAX,STO,W1,W 100 AMAX=0.0 DO 2 I=1,M IND(I)=I IF(DABS(A(I,1))-AMAX)2,2,3 3 AMAX=DABS(A(I,1)) I4=I 2 CONTINUE MM=M-1 DO 111 J=1,MM IF(I4-J)6,6,4 4 ISTO=IND(J) IND(J)=IND(I4) IND(I4)=ISTO DO 5 K=1,M STO=A(I4,K) A(I4,K)=A(J,K) A(J,K)=STO 5 CONTINUE 6 AMAX=0.0 J1=J+1 DO 11 I=J1,M A(I,J)=A(I,J)/A(J,J) DO 10 K=J1,M A(I,K)=A(I,K)-A(I,J)*A(J,K) IF (K-J1)14,14,10 14 IF(DABS(A(I,K))-AMAX)10,10,17 17 AMAX=DABS(A(I,K)) I4=I 10 CONTINUE 11 CONTINUE 111 CONTINUE DO 140 I1=1,MM I=M+1-I1 I2=I-1 DO 41 J1=1,I2 J=I2+1-J1 J2=J+1 W1=-A(I,J) IF(I2-J2)141,43,43 43 DO 42 K=J2,I2 W1=W1-A(K,J)*C(K) 42 CONTINUE 141 C(J)=W1 41 CONTINUE DO 40 K=1,I2 A(I,K)=C(K) 40 CONTINUE 140 CONTINUE DO 150 I1=1,M I=M+1-I1 I2=I+1 W=A(I,I) DO 56 J=1,M IF (I-J)52,53,54 52 W1=0.0 GO TO 55 53 W1=1.0 GO TO 55 54 W1=A(I,J) 55 IF(I1-1)156,156,57 57 DO 58 K=I2,M W1=W1-A(I,K)*A(K,J) 58 CONTINUE 156 C(J)=W1 56 CONTINUE DO 50 J=1,M A(I,J)=C(J)/W 50 CONTINUE 150 CONTINUE DO 60 I=1,M 63 IF(IND(I)-I)61,60,61 61 J=IND(I) DO 62 K=1,M STO=A(K,I) A(K,I)=A(K,J) A(K,J)=STO 62 CONTINUE ISTO=IND(J) IND(J)=J IND(I)=ISTO GO TO 63 60 CONTINUE RETURN END C C ************************************************************************** C SUBROUTINE DETABS(J,JP,NTP,IOUTR) C C THIS ROUTINE GIVES THE DETAILS OF THE ABSORPTION MECHANISMS. C CHANGES IN THE ABSORPTION-COEFFICIENT PROGRAM ARE EXPECTED TO C BE CONFINED TO THE TABLES AND TO THIS ROUTINE. C DETABS HAS TWO PURPOSES C 1. JP=0 DETERMINATION OF WAVELENGTH-INDEPENDENT FACTORS (DEP.ON C T, PE AND THE COMPONENT) STORED IN FAKT. C 2. JP= THE ACTUAL WAVELENGTH NUMBER. C MULTIPLICATION OF AB, COMPUTED IN SUBROUTINE ABSKO, C BY WAVELENGTH-DEPENDENT FACTORS. SUMMATION OF THE TOTAL C ABSORPTION AND SCATTERING COEFFICIENTS ( SUMABS AND C SUMSCA ). C C N O T E . BEFORE A CALL ON DETABS FOR PURPOSE 1, SUBROUTINE C JON MUST HAVE BEEN CALLED. C C IF J IS LESS THAN OR EQUAL TO ZERO, THE WEIGHT FOR A ROSSELAND MEAN C WILL BE COMPUTED AND STORED IN VIKTR (THE WEIGHT BEING 1/VIKTR). C NTP IS THE ARRAY INDEX OF THE T-PE POINT. C IF IOUTR IS GREATER THAN ZERO AT A CALL WITH JP GREATER THAN ZERO C (PART TWO OF THE ROUTINE), DETAILS OF THE ABSORPTION COEFFICIENTS C ARE PRINTED. IF IOUTR IS GREATER THAN ONE, A TABLE HEADING IS ALSO C PRINTED. C C C CONTENTS OF COMMON/CI5/, COMMUNICATING PHYSICAL INFORMATION FROM C SUBROUTINE JON. C ABUND ABUNDANCES C ANJON FRACTIONS OF IONIZATION C H QUANTUM NUMBER OF THE HIGHEST EXISTING HYDROGENIC LEVEL C PART PARTITION FUNCTIONS C DXI DECREASE OF IONIZATION ENERGY OF HYDROGEN IN ELECTRON VOLTS C F1 N(HI)/N(H) C F2 N(HII)/N(H) C F3 N(H-)/N(H) C F4 N(H2+)/N(H) C F5 N(H2)/N(H) C XKHM 'DISSOCIATION CONSTANT' OF H- C XMH MASS OF THE HYDROGEN ATOM IN GRAMS C XMY GRAMS OF STELLAR MATTER/GRAMS OF HYDROGEN C C DIMENSIONS NECESSARY C ABUND(NEL),ANJON(NEL,MAX(NJ)),ELS(NT),H(5),HREST(NT),PART(NEL,MAX(NJ)), C PROV(NKOMP,MT) C THE DIMENSIONS ARE LOWER LIMITS. DIMENSIONS IN COMMON /CA5/ ARE C COMMENTED ON IN SUBROUTINE ABSKO. C NEL IS THE NUMBER OF CHEMICAL ELEMENTS INITIATED IN SUBROUTINE INJON C NJ(I) IS THE NUMBER OF STAGES OF IONIZATION, INCLUDING THE NEUTRAL C STAGE, FOR ELEMENT I C NKOMP IS THE NUMBER OF COMPONENTS, NOT INCLUDING THOSE ADDED BY C ANALYTICAL EXPRESSIONS AFTER STATEMENT NO. 13. C NT IS THE NUMBER OF TEMPERATURES-ELECTRON PRESSURES GIVEN AT THE C CALL OF SUBROUTINE ABSKO. C C: C: DETABS 87-05-21 MODIFICATIONS: (MATS CARLSSON) C: COMMON BLOCK /CA2/ ADDED TO MAKE VARIABLE NKOMP AVAILABLE C: COMPONENTS 17 - NKOMP-6 BF CONTINUA GIVEN LEVEL BY LEVEL C: C: 88-05-20 MODIFICATIONS: (MATS CARLSSON) C: WRITES CONTRIBUTIONS TO UNFORMATTED FILE IDLOPC C: C: 89-03-24 MODIFICATIONS: (MATS CARLSSON) C: FORMATION OF MOLECULES WAS NOT TAKEN INTO ACCOUNT WHEN CALCULATING C: XNENH AND OPACITIES. THIS HAS BEEN CORRECTED. TOTAL NUMBER C: ABUNDANCES OF ATOMS AFTER MOLECULE FORMATION HAS BEEN TAKEN INTO C: ACCOUNT ARE STORED IN NEW VARIABLE ABUNDM C: C: C: C: 92-04-02 MODIFICATIONS: (PHILIP JUDGE) C: NON-LTE TREATMENT OF LEVELS N > 5 CORRECTED AND F-F OPACITY C: OF H CORRECTED. EARLIER VERSIONS LEAD TO ERRORS ESPECIALLY AT C: TEMPERATURES BELOW ABOUT 2600K. C: C: 92-11-27 MODIFICATIONS: (MATS CARLSSON) C: SAVE STATEMENT ADDED C: C: 93-03-05 MODIFICATIONS: (MATS CARLSSON) C: RAYLEIGH SCATTERING ON H2 MOLECULES ADDED C: C: 94-03-23 MODIFICATIONS: (MATS CARLSSON, DAN KISELMAN) C: BACKGROUND OPACITY FROM LINES INCLUDED C: C: 95-11-07 MODIFICATIONS: (SALVADOR ALBA, MATS CARLSSON) C: CORRECT EMISSION F-VALUE USED IN CALL TO SEMIC C: AFFECTS ISOUL=2 (SET BY IOPACL=2) C: INCLUDE 'PREC' INCLUDE 'CALIN' PARAMETER (MEL=16,MJMAX=90,MKMAX=140,MLMAX=400,MJ=5) PARAMETER (MT=300,MKOMP=150,ML=50000,MSET=1,MLATB=50,MTETB=30, * MELMAX=2,MKOMPR=MKOMP,MKOMPT=10, * KFADIM=MKOMPR*MT+MKOMPT*MT*3,IFADIM=MKOMPT*MT) DIMENSION ELS(MT),HREST(MT),CNTRB(MEL) DIMENSION FAKRAY(MT),H2RAY(MT) C COMMON/CA2/ABKOF(30000000),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP C COMMON/CI5/ABUND(MEL),ANJON(MEL,MJ),H(5),PART(MEL,MJ),DXI, * F1,F2,F3,F4,F5,XKHM,XMH,XMY C COMMON/CA5/AB(MKOMP),FAKT(MKOMP),PE(MT),T(MT),XLA(ML),XLA3(ML),RO, *SUMABS,SUMSCA,VIKTR,ISET,NLB C COMMON/UTPUT/ IREAD, IWRIT C COMMON/CLEVD/ IONL(MKOMP),CHIL(MKOMP),G2L(MKOMP),IELL(MKOMP) C COMMON/CBMET/ BMET(MT,MKOMP-23),BMETP(MT,MKOMP-23), * FRCION(MEL,MJ,MT),ZNLTE(MEL,MJ,MT) COMMON/LDOPAC/ ALES,BLES C* C* MODIFICATIONS START C COMMON/COUTR/ NTO,NTPO(MT),IWOPTN C COMMON/CI1/FL2(5),PARCO(MJMAX),PARQ(4*MJMAX),SHXIJ(5),TPARF(4), *XIONG(MEL,MJ),EEV,ENAMN,SUMH,XKBOL,SUMM,NJ(MEL),NEL CHARACTER*3 CEL COMMON/CC1/CEL(MEL) REAL NH,NP,NH2,NH2P,NHMIN,NHT,NHLTE COMMON/HYDCOM/NH,NP,NH2,NH2P,NHMIN,NHT,NHLTE C LOGICAL HLTE REAL NHYD,NPIN COMMON/CIN/ NHYD(MT,5),NPIN(MT),HLTE C COMMON/COUT/ TOTH(MT),TOTHI(MT),TOTH2(MT), * TOTCH(MT),TOTCO(MT),TOTCN(MT), * TOTC(MT),TOTNIT(MT),TOTO(MT), * BHYD(MT,5),GRPH C COMMON/CABNDM/ ABUNDM(MEL) C COMMON/CABSB/ ABSLTE(MT),KMPEXC COMMON /CXNENH/ XNENH C COMMON /COPBID/ PGC(MT),ROC(MT),XMYC(MT),EJONC(MT), * XNENHC(MT),PROV(20,MT) REAL FAKTL(MKOMP,MT) LOGICAL MASKWR C* C* PGJ ADDITION CHARACTER*5 CPROV(20) C* END PGJ ADDITION DATA BK/1.380662E-16/,EE/1.602189E-12/,RYD/13.598408/ SAVE C* MODIFICATIONS END C* C** DATA HH/6.626176E-27/,CC/2.99792458E10/, * EM/9.109534E-28/,UU/1.6605655E-24/ COMMON/CI9/AI(MEL) DIMENSION POPLL(MLL,MT) C** C TETA=5040./T(NTP) IF(JP.GT.0)GO TO 7 C C 1. COMPUTATION OF WAVELENGTH-INDEPENDENT QUANTITIES C HN=1./(XMH*XMY) HNH=F1*HN C H- C* H-FF SHOULD BE ADDED IN SEPARATELY TO ALLOW FOR THE FACT THAT THE C* TABLES INCLUDE STIMULATED EMISSION. THIS IS DONE BY SETTING FAKTL C* TO ZERO. FAKT(1)=PE(NTP)*HNH*1.E-17/XKHM FAKT(NKOMP-4)=PE(NTP)*HNH*2.E-26/PART(1,1) FAKTL(1,NTP)=1.0 FAKTL(NKOMP-4,NTP)=0.0 C HI TETA31=31.30364*TETA C* XFAKH=2.0898E-26/PART(1,1)*NHLTE/NHT*HN NNIV=15 XNIV=15. IF(H(1).LT.XNIV)NNIV=INT(H(1)) DO3 M=1,NNIV XM2=M*M XM3=XM2*FLOAT(M) C* IF(M.LE.5) THEN XM5=XM2*XM3 CHIN=(1.0-1.0/(M*M))*RYD*EE BLZFAC=2.0*M*M/PART(1,1)*EXP(-CHIN/BK/T(NTP)) IF(.NOT.HLTE) THEN IF(NHYD(NTP,M).NE.0.0) THEN BHYD(NTP,M)=NHYD(NTP,M)/(BLZFAC*NHLTE) FAKTL(M+1,NTP)=1.0/BHYD(NTP,M) ELSE BHYD(NTP,M)=0.0 FAKTL(M+1,NTP)=1.0 ENDIF ELSE NHYD(NTP,M)=BLZFAC*NH BHYD(NTP,M)=1.0 FAKTL(M+1,NTP)=1.0 ENDIF FAKT(M+1)=1.045E-26*NHYD(NTP,M)*(HNH/NH)/XM5 ELSE FAKT(M+1)=XFAKH*EXP(-TETA31*(1.-1./XM2))/XM3 C* C* 92-04-02 PGJ CHANGES FOR NON-LTE (AND LTE) C* IN THIS APPROXIMATION, THE DEPARTURE COEFFICIENTS OF C* LEVELS 6-15 ARE ASSUMED TO BE THE SAME AS THE GROUND LEVEL C* OF HYDROGEN. THIS MEANS THAT THESE LEVELS ARE MORE STRONGLY C* COUPLED TO THE BOUND LEVELS OF H THAN THE CONTINUUM. C* IF THESE LEVELS ARE THOUGHT TO BE STRONGLY BOUND TO THE C* CONTINUUM THEN THE FOLLOWING LINE SHOULD BE COMMENTED OUT. C* C * * NH / NHLTE C* C* 92-04-02 PGJ CHANGES END C* FAKTL(M+1,NTP)=1.0 ENDIF 3 CONTINUE IF(NPIN(NTP).EQ.0.0) THEN NPIN(NTP)=NP ENDIF ONE=1. FAKT(NNIV+1)=FAKT(NNIV+1)*MIN(H(1)-NNIV,ONE) IF(NNIV.GE.15)GO TO 6 4 N1=NNIV+1 DO 5 M=N1,15 FAKT(M+1)=0. FAKTL(M+1,NTP)=1.0 5 CONTINUE C* C* PHOTOIONIZATION GIVEN LEVEL BY LEVEL C* THE CONSTANT 1.438786314 IS H*C/K C* C C* PGJ: FOLLOWING MATS' SUGGESTION, THE IONIZATION FRACTION IS TAKEN INTO C* ACCOUNT TWICE: I.E FACTM CONTAINS ANJON WHICH ALREADY IS NON-LTE C* SHOULD REPLACE FACTM BY LTE VALUE? C* C* 89-03-24 START ABUND CHANGED TO ABUNDM 6 CONTINUE DO 100 M=17,NKOMP-6 BLZFAC=G2L(M)*EXP(-1.438786314*CHIL(M)/T(NTP)) FAKT(M)=ANJON(IELL(M),IONL(M))*ABUNDM(IELL(M))*HN* * BLZFAC/PART(IELL(M),IONL(M))*BMET(NTP,M-16) FAKTL(M,NTP)=BMETP(NTP,M-16)/BMET(NTP,M-16) 100 CONTINUE C* 89-03-24 END C** CHANGING AREA ************* C** SAME THING HERE FOR LINES DO 110 L=1,NLL BLZFAC=GILL(L)*EXP(-1.438786314*CHILL(L)/T(NTP)) POPLL(L,NTP)=ANJON(IELLLL(L),IONILL(L))*ABUNDM(IELLLL(L))*HN* * BLZFAC/PART(IELLLL(L),IONILL(L)) C** EXCLUDE: *BMET(NTP,M-16) C** FAKT(M,NTP)=BMETP(NTP,M-16)/BMET(NTP,M-16) 110 CONTINUE C** * *********** C C FREE-FREE HI ABSORPTION UMC=2.3026*DXI*TETA EXPJ=XFAKH*EXP(-TETA31+UMC)/(2.*TETA31)* C* 87-05-22 CORRECTION FOR NON-LTE C* 92-04-03 PGJ CORRECTION. C* C* THIS STATEMENT WAS INCORRECT C* IN THE ORIGINAL VERSION. THE PROBLEM LEAD TO VAST OPACITIES C* AT LOW TEMPERATURES SINCE THE POPULATIONS OF THE HIGHER - N C* AND FREE LEVELS OF HYDROGEN WERE OVERESTIMATED C* C* ORIGINAL CODE: C* C* * ANJON(1,1)/ANJON(1,2)*NP/NH C* C* FIRST CORRECTION (INCORRECT) C* C* * NH/NHLTE C* C* FINAL CORRECTION. THIS WORKS BECAUSE NHLTE IS THE POP. OF C* NEUTRAL H ATOMS REQUIRED TO MAKE THE CORRECT NUMBER OF PROTONS C* AT THE GIVEN NE, NP AND TE. THUS, THE OPACITY IS CORRECTLY C* GIVEN ALREADY WIOTH NO FURTHER NEED FOR CORRECTIONS FOR NLTE. C* NOTICE THAT, FOR LEVELS WITH N GT 15, THE LEVELS ARE ASSUMED HERE C* TO BE STRONGLY BOUND TO THE CONTINUUM SO THAT THE OPACITY IS C* CORRECTLY GIVEN BY THE LTE POPNS RELATIVE TO THE NUMBER OF PROTONS C* AND ELECTRONS. C* TO RELAX THIS ASSUMPTION, THE FACTOR NH/NHLTE MUST BE USED C* TO MULTIPLY THE TERM HREST ONLY * 1.0 C* C* 92-04-03 END PGJ CORRECTION. C* ADDF=EXP(TETA31/((FLOAT(NNIV)+0.5)**2)-UMC)-1. IF(H(1).LT.XNIV+0.5)ADDF=0. FAKT(NKOMP-5)=EXPJ FAKTL(NKOMP-5,NTP)=1.0 HREST(NTP)=EXPJ*ADDF C C H+H HNH25=HNH*1.E-25 FAKT(NKOMP-3)=HNH25*HNH25*RO FAKTL(NKOMP-3,NTP)=1.0 C H2+ HNH20=HNH*1.E-20 FAKT(NKOMP-2)=HNH20*HNH20*RO*ANJON(1,2)/ANJON(1,1) FAKTL(NKOMP-2,NTP)=1.0 C H2- FAKT(NKOMP-1)=PE(NTP)*F5*HN FAKTL(NKOMP-1,NTP)=1.0 C HE- FAKT(NKOMP)=PE(NTP)*ANJON(2,1)*ABUND(2)*HN FAKTL(NKOMP,NTP)=1.0 C ELECTRON SCATTERING ELS(NTP)=4.8206E-9*PE(NTP)/(T(NTP)*RO) C RAYLEIGH SCATTERING FAKRAY(NTP)=HNH*2./PART(1,1) H2RAY(NTP)=F5*HN RETURN C N O T E . APART FROM VECTORS HREST AND ELS, NONE OF THE C TEMPERATURE- OR PRESSURE-DEPENDENT VARIABLES DEFINED ABOVE CAN C GENERALLY BE USED AT THE NEXT VISIT BELOW. C ANY SET OF FACTORS WHICH IS WANTED SHOULD BE STORED IN AN ARRAY WITH C DIMENSION = NT, LIKE HREST AND ELS, OR IN FAKT, WHERE THE DATA FOR C FURTHER USE ARE STORED IN SUBR. ABSKO. C C 2. WAVELENGTH-DEPENDENT FACTORS. SUMMATION. C CORRECTION FOR STIMULATED EMISSION 7 EXPA=EXP(-28556.*TETA/XLA(JP)) 11 STIM=1.-EXPA C C ABSORPTION C* C* 87-05-25 MODIFICATIONS FOR NON-LTE C* SUMABS IS CORRECTED INDIVIDUALLY FOR STIMULATED EMISSION C* ABSLTE IS COLLECTIVELY CORRECTED C* ABSLTE IS LTE ABSORPTION CALCULATED USING ACTUAL ION C* DENSITIES AND LTE SAHA RELATION. ABSLTE IS USED FOR C* CALCULATING THE RECOMBINATION PART OF THE BACKGROUND C* SOURCE FUNCTION C* SUMABS=0. ABSLTE(NTP)=0. C H I IF(KMPEXC.LT.2 .OR. KMPEXC.GT.16) THEN DO 12 KOMP=2,16 SUMABS=SUMABS+AB(KOMP)*(1.0-FAKTL(KOMP,NTP)*EXPA) ABSLTE(NTP)=ABSLTE(NTP)+AB(KOMP)*FAKTL(KOMP,NTP) 12 CONTINUE ELSE DO 121 KOMP=2,KMPEXC-1 SUMABS=SUMABS+AB(KOMP)*(1.0-FAKTL(KOMP,NTP)*EXPA) ABSLTE(NTP)=ABSLTE(NTP)+AB(KOMP)*FAKTL(KOMP,NTP) 121 CONTINUE DO 122 KOMP=KMPEXC+1,16 SUMABS=SUMABS+AB(KOMP)*(1.0-FAKTL(KOMP,NTP)*EXPA) ABSLTE(NTP)=ABSLTE(NTP)+AB(KOMP)*FAKTL(KOMP,NTP) 122 CONTINUE ENDIF SUMABS=(SUMABS+HREST(NTP)*STIM)*XLA3(JP) PROV(1,NTP)=SUMABS PROV(2,NTP)=AB(NKOMP-5)*XLA3(JP)*STIM SUMABS=SUMABS+AB(NKOMP-5)*XLA3(JP)*STIM ABSLTE(NTP)=ABSLTE(NTP)+AB(NKOMP-5)*FAKTL(NKOMP-5,NTP) ABSLTE(NTP)=(ABSLTE(NTP)+HREST(NTP))*XLA3(JP) C H-, STIMULATED EMMISION INCLUDED IN TABLES FOR FF C FAKTL FOR H-FF IS SET TO ZERO. H-FF IS THEREFORE ADDED INTO C ABSLTE BUT NOT SUMABS SUMABS=SUMABS+AB(1)*STIM ABSLTE(NTP)=ABSLTE(NTP)+AB(1)+AB(NKOMP-4)/STIM C C ADD IN ALL NON-HYDROGEN CONTRIBUTIONS C IF(KMPEXC.LT.17) THEN DO 13 KOMP=17,NKOMP SUMABS=SUMABS+AB(KOMP)*(1.0-FAKTL(KOMP,NTP)*EXPA) ABSLTE(NTP)=ABSLTE(NTP)+AB(KOMP)*FAKTL(KOMP,NTP) 13 CONTINUE ELSE DO 131 KOMP=17,KMPEXC-1 SUMABS=SUMABS+AB(KOMP)*(1.0-FAKTL(KOMP,NTP)*EXPA) ABSLTE(NTP)=ABSLTE(NTP)+AB(KOMP)*FAKTL(KOMP,NTP) 131 CONTINUE DO 132 KOMP=KMPEXC+1,NKOMP SUMABS=SUMABS+AB(KOMP)*(1.0-FAKTL(KOMP,NTP)*EXPA) ABSLTE(NTP)=ABSLTE(NTP)+AB(KOMP)*FAKTL(KOMP,NTP) 132 CONTINUE ENDIF C** ***************************** C** ***************************** C** NEW AND CHANGED CODE. C** LINE OPACITIES CONTRIBUTE TO BOTH SUMABS AND SUMSCA. C** THE FRACTION DELTA OF ABSORPTION IS SET TO 1.0 IF C** ISOUL=1. IF ISOUL=2 IT IS CALCULATED FROM C** THE LIFETIME OF THE LEVEL AND THE COLLISIONAL RATE C** FROM THE VAN REGEMORTER APPROXIMATION. C** MUST INITIALISE SUMSCA. SUMSCA = 0.0 C LINE OPACITIES DO 133 L=1,NLL IF(FLL(L).EQ.0.0) GOTO 133 IF (XLA(JP).LT.REDLL(L) .AND. XLA(JP).GT.BLUELL(L)) THEN PIONLL=XIONG(IELLLL(L),IONILL(L)) CHIEV=CHILL(L)*CC *HH/EE CHJEV=CHJLL(L)*CC *HH/EE AWGT = AI(IELLLL(L))*UU PROF = PROFLL(XLA(JP),ALAMLL(L),GALL(L),GWLL(L),GQLL(L), * IONILL(L),PIONLL,CHIEV,CHJEV,AWGT,TOTHI(NTP),QNORML,NTP) C** VAN REGEMORTERS APPROXIMATION IS USED FOR COLLISIONAL RATE. IF(ISOUL.EQ.2) THEN COLL = SEMIC(IONILL(L),CHJLL(L),CHILL(L), * FLL(L)*GILL(L)/GJLL(L),T(NTP),1) COLL = COLL * PE(NTP)/XKBOL/T(NTP)*(1.0-EXPA) AUL = GILL(L)/GJLL(L)*6.67E15/ALAMLL(L)**2 * FLL(L) DELTA = COLL/(AUL+COLL) ELSE DELTA = 1.0 ENDIF XLINE = FLL(L)*POPLL(L,NTP)*PROF SUMABS = SUMABS + XLINE*(1.0-EXPA)*DELTA ABSLTE(NTP) = ABSLTE(NTP) + XLINE*DELTA SUMSCA = SUMSCA + XLINE*(1.-DELTA) ENDIF 133 CONTINUE C** ***************************** C** ***************************** C C THE ADDITION OF A MULTIPLICATIVE FACTOR TO SUMABS TO C SIMULATE THE MISSING UV OPACITY. THE FORM IS C A(LAMDA)=A + B*LAMD C FLES=ALES+BLES*1.E-03*XLA(JP) C IF(FLES.LT.0.0) FLES=0.0 C XSUMAB=FLES*SUMABS C SUMABS=SUMABS+XSUMAB C XSPC=XSUMAB/SUMABS C IF(XLA(JP).LT.2600. .AND. XLA(JP).GT.2200.) WRITE(6,1122) C *JP,XLA(JP),FLES,SUMABS,XSUMAB,XSPC C1122 FORMAT(1X,' JP=',I5,5F12.4) C C HERE FURTHER ABSORPTION MECHANISMS, GIVEN IN TABLES OR BY C ANALYTICAL EXPRESSIONS, MAY BE ADDED. ABSLTE(NTP)=ABSLTE(NTP)*STIM C C SCATTERING C* CONSTANT 1026. REPLACED BY VARIABLE TO FACILITATE TRANSITION TO DP C* 90-02-12 RAYH SET TO 0. FOR XLA LT 911 XLIMIT=1026. XRAY=MAX(XLA(JP),XLIMIT) XRAY2=1./(XRAY*XRAY) IF(XLA(JP).LT.911.) XRAY2=0.0 C* END CHANGE RAYH=XRAY2*XRAY2*(5.799E-13+XRAY2*(1.422E-6+XRAY2*2.784))* *FAKRAY(NTP) RAYH2=XRAY2*XRAY2*(8.14E-13+XRAY2*(1.28E-6+XRAY2*1.61))*H2RAY(NTP) C*** ADD SUMSCA TO SUMSCA FROM LINES SUMSCA=SUMSCA+ELS(NTP)+RAYH+RAYH2 C*** C IF(J.GT.0)GO TO 15 C C WEIGHT FOR A ROSSELAND MEAN 14 VIKTR=1./EXPA*STIM*STIM*XLA3(JP)*XLA3(JP) 15 CONTINUE C C* 87-11-02 MODIFICATIONS: C* IWOPTN GOVERNS PRINTOUT, BINARY SWITCHES: C* 1 OPACITY CONTRIBUTIONS C* 2 PARTIAL PRESSURES C* 4 IONIZATION FRACTIONS, PARTITION FUNCTIONS C* C IF(.NOT.MASKWR(IWOPTN,0)) GOTO 23 IF(IOUTR-1)23,21,20 C C **** PRINT-OUT **** 20 WRITE(IWRIT,200) CONVL(XLA(JP)) 200 FORMAT(////' O P A C I T I E S LAMBDA=',F10.2/ * 16X,'PERCENTAGES OF CONTINUOUS OPACITY'/ * ' K OPACITY',3X, * ' HBF HFF H-BF H-FF H2- H2+ H+H HE- HE SI MG AL', * ' FE C N O ELECT R(H) (H2) (HE)',3X, * 'ABS SCAT'/) C C OPEN IDL OUTPUT FILE IF FIRST WAVELENGTH C IF(JP.EQ.1) CALL OPEN(LIDLO,'IDLOPC',0,'NEW') WRITE(LIDLO) REAL(XLA(JP)) C 21 CONTINUE C C STORE OPACITIES FOR PRINTOUT C DO 211 M=1,NEL CNTRB(M)=0.0 211 CONTINUE DO 212 KOMP=17,NKOMP-6 IF(KOMP.NE.KMPEXC) CNTRB(IELL(KOMP))=CNTRB(IELL(KOMP))+ * AB(KOMP)*(1.0-FAKTL(KOMP,NTP)*EXPA) 212 CONTINUE PROV(3,NTP)=AB(1)*STIM C* C* FOLLOWING CHANGED (89-03-06) P. JUDGE PROV(4,NTP) = AB(NKOMP-4) PROV(5,NTP) = AB(NKOMP-1)* (1.0E0-FAKTL(NKOMP-1,NTP)*EXPA) PROV(6,NTP) = AB(NKOMP-2)* (1.0E0-FAKTL(NKOMP-2,NTP)*EXPA) PROV(7,NTP) = AB(NKOMP-3)* (1.0E0-FAKTL(NKOMP-3,NTP)*EXPA) PROV(8,NTP) = AB(NKOMP)* (1.0E0-FAKTL(NKOMP,NTP)*EXPA) PROV(9,NTP) = CNTRB(2) PROV(10,NTP) = CNTRB(10) PROV(11,NTP) = CNTRB(8) PROV(12,NTP) = CNTRB(9) PROV(13,NTP) = CNTRB(15) PROV(14,NTP) = CNTRB(3) PROV(15,NTP) = CNTRB(4) PROV(16,NTP) = CNTRB(5) PROV(17,NTP) = ELS(NTP) PROV(18,NTP) = RAYH PROV(19,NTP) = RAYH2 PROV(20,NTP) = 0.0E0 CHI=SUMABS+SUMSCA C* END 89-03-06 ALTERATION C* C* PGJ ALTERATION: WRITE BLANKS INSTEAD OF ZEROS C* DO 303 KP=1,20 IF(PROV(KP,NTP)/CHI*1.0D2 .LT. 0.1E0)THEN CPROV(KP)(1:5)=' ' ELSE WRITE(CPROV(KP)(1:5),FMT='(F5.1)') * PROV(KP,NTP)/CHI*1.0D2 ENDIF 303 CONTINUE WRITE (IWRIT,FMT=201) NTP,CHI, (CPROV(KP),KP=1,20), + SUMABS/CHI,SUMSCA/CHI 201 FORMAT (1X,I3,1X,1P,E10.3,2X,16A5,1X,4A5,2P,2F6.1) C* END PGJ ALTERATIONS C* WRITE(LIDLO) NTP,REAL(CHI),(REAL(PROV(KP,NTP)),KP=1,20), * REAL(SUMABS),REAL(SUMSCA) 23 CONTINUE C RETURN END C C ********************************************************************** C LOGICAL FUNCTION MASKWR(I,IBIT) C C CHECKS BIT NUMBER IBIT OF INTEGER I AND RETURNS TRUE IF BIT IS ONE C INCLUDE 'PREC' MASKWR=MOD(I/(2**IBIT),2).EQ.1 C RETURN END C C******************************************************************************* C SUBROUTINE CORONA(CEL,ION,TEMP,PRESS,FR1) C C CORONAL ION BALANCE CALCULATION C NEW ROUTINE FOR VERSION 2.0 OPACITY PACKAGE C C INPUT: ELEMENT IDENTIFIER CEL (CHARACTER*3) C ION STAGE IDENTIFIER ION (INTEGER) C TEMP (ELECTRON TEMPERETURE IN K (RL) C PRESS (ELECTRON PRESSURE IN DYNE/CM2) (RL) C C OUTPUT: FR1 THE RATIO OF THE ION STAGE ION TO THE ION STAGE ION+1 C C EXAMPLE: C CEL='C ', ION=1, WILL RETURN FR1= N(C II) / N(C I) IN CORONAL LIMIT C C NOTES: C COMPUTATIONS FROM TABLES OF SHULL & VAN STEENBERG, C AP J SUPPL 48 P95 C NO PE-DEPENDENCE, THIS COULD BE ADDED WHEN COMPUTATIONS BECOME C AVAILABLE C IF THE ION FRACTION IS NOT FOUND THEN THE VALUE FR1 IS SET = C -1 C 88-04-26 NEW ROUTINE (PHILIP JUDGE) C C: 92-07-20 MODIFICATIONS (MATS CARLSSON) C: INTEGER ARRAYS WITH ELEMENT NAME CHANGED TO CHARACTER ARRAYS C: INCLUDE 'PREC' PARAMETER (MCOR=30) INTEGER NCOR,IONCOR(MCOR) DOUBLE PRECISION ARADC(MCOR),XRADC(MCOR),ADIC(MCOR),T0C(MCOR), * BDIC(MCOR),T1C(MCOR),ACOLC(MCOR),TCOLC(MCOR),TECOR,DECOR COMMON /CCORON/ TECOR,DECOR, * ARADC,XRADC,ADIC,T0C,BDIC,T1C,ACOLC,TCOLC,NCOR,IONCOR CHARACTER*3 CCOR COMMON /CCCOR/ CCOR(MCOR) COMMON /CLU/ LINPUT,LATOM,LATOM2,LATMOS,LDSCAL,LABUND,LOUT, * LTIME,LRSTRT,LDSCA2,LWMAT,LNIIT,LDUMS,LDUMI,LDUMC,LOPC, * LJNY,LINIT,LPHI,LJOBLO,LATHSE CHARACTER*(*) CEL C C IDENTIFY THE ELEMENT AND IONIZATION STAGE TO BE COMPUTED C DO 100 N=1,NCOR IF( CEL .EQ. CCOR(N) .AND. ION .EQ. IONCOR(N) )GOTO 99 100 CONTINUE WRITE(LJOBLO,FMT=1000)CEL,ION 1000 FORMAT(' CORONA: SPECIES',A3,I3,' NOT FOUND IN ABSDAT FILE' * , ' SPECIES COMPUTED IN LTE') FR1=-1.E0 RETURN C C ELEMENT HAS BEEN COMPUTED- NOW RETURN THE ION FRACTION C 99 RRATE=ARADC(N)*(TEMP/1.E4)**(-XRADC(N)) + + ADIC(N) * (TEMP**(-1.5)) * EXP(-T0C(N)/TEMP)* + (1.E0+BDIC(N) * (EXP(- T1C(N)/TEMP))) RIRATE=ACOLC(N) * SQRT(TEMP) * EXP( -TCOLC(N) / TEMP) + / (1.E0 + 0.1 * TEMP / TCOLC(N)) FR1=RIRATE/RRATE RETURN END C C*************************************************************************** C SUBROUTINE RCORON(IFILE) C C READS CORONAL ION BALANCE PARAMETERS C NEW ROUTINE FOR VERSION 2.0 OPACITY PACKAGE C INCLUDE 'PREC' PARAMETER (MCOR=30) INTEGER NCOR,IONCOR(MCOR) DOUBLE PRECISION ARADC(MCOR),XRADC(MCOR),ADIC(MCOR),T0C(MCOR), * BDIC(MCOR),T1C(MCOR),ACOLC(MCOR),TCOLC(MCOR),TECOR,DECOR COMMON /CCORON/ TECOR,DECOR, * ARADC,XRADC,ADIC,T0C,BDIC,T1C,ACOLC,TCOLC,NCOR,IONCOR CHARACTER*3 CCOR COMMON /CCCOR/ CCOR(MCOR) CHARACTER *80 CARD PARAMETER (MCORO=16) INTEGER KELEM(MCORO) CHARACTER*3 CELEM(MCORO) DATA CELEM /'H ','HE ','C ','N ','O ', * 'NE ','NA ','MG ','AL ','SI ','S ','K ','CA ','CR ', * 'FE ','NI '/ DATA KELEM /1,2,6,7,8,10,11,12,13,14,16,19,20,24,26,28/ C READ(IFILE,10000)CARD 10000 FORMAT(A) READ (IFILE,*)NCOR,TECOR,DECOR DO 100 N=1,NCOR READ(IFILE,*)ICOR,IONCOR(N),ACOLC(N),TCOLC(N),ARADC(N), * XRADC(N),ADIC(N),BDIC(N),T0C(N),T1C(N) C C USE ICOR ELEMENT NUMBER AND KELEM ARRAY TO ASSIGN CCOR C FOR LATER USE (IN ROUTINE CORONA) C DO 200 I=1,MCORO IF (ICOR .EQ. KELEM(I)) CCOR(N) = CELEM(I) 200 CONTINUE 100 CONTINUE RETURN END C C********************************************************************************** C SUBROUTINE INLIN C C READS ABSLIN FILE WITH DATA FOR BACKGROUND OPACITIES FROM LINES C ONLY ELEMENTS INCLUDED IN ABSDAT CAN BE TREATED C C VARIABLES: C C NLL NUMBER OF LINES C SRCELL DESCRIPTIVE COMMENT LINE C ABNILL STRING GIVING LABEL FOR LOWER LEVEL, STANDARD FORMAT C IONILL IONIZATION STAGE FOR LOWER LEVEL, 1=NEUTRAL C CHILL EXCITATION POTENTIAL, LOWER LEVEL. CM^-1. C GILL STATISTICAL WEIGHT, LOWER LEVEL C ABNJLL SAME FOR UPPER LEVEL C IONJLL C CHJLL C GJLL C ALAMLL VACUUM WAVELENGTH FOR TRANSITION C BLUELL LIMITING BLUE WAVELENGTH FOR LINE INFLUENCE ON OPACITY C REDLL LIMITING RED WAVELENGTH FOR LINE INFLUENCE ON OPACITY C FLL OSCILLATOR STRENGTH C GALL BROADENING RADIATIVE DAMPING PARAMETER GA (SEE ATOM) C GWLL BROADENING VAN DER WAALS PARAMETER GW (SEE ATOM) C GQLL BROADENING STARCK PARAMETER GQ (SEE ATOM) C C: C: INLIN 94-03-23 NEW ROUTINE (MATS CARLSSON, DAN KISELMAN) C: INCLUDE 'PREC' INCLUDE 'CALIN' INCLUDE 'CCONST' C CHARACTER*80 TEXT C CALL OPEN(LLIN,'DUMS4',1,'NEW') CALL CSTRI2(LDUMS2,LLIN,'ABSLIN') C C READ NUMBER OF LINES C READ(LLIN,*) NLL IF (NLL.GT.MLL) CALL STOP('INLIN: NLL .GT. MLL') C C READ DATA FOR LINES C DO 200 L=1,NLL C C SOURCE - A DESCRIPTIVE COMMENT LINE C READ(LLIN,100) TEXT CALL LJUST(TEXT) SRCELL(L) = TEXT(1:20) C C LOWER LEVEL C READ(LLIN,100) TEXT 100 FORMAT(A) CALL LJUST(TEXT) ABNILL(L) = TEXT(1:20) CALL LJUST(ABNILL(L)) READ(LLIN,*) IONILL(L), CHILL(L), GILL(L) C C UPPER LEVEL C READ(LLIN,100) TEXT CALL LJUST(TEXT) ABNJLL(L) = TEXT(1:20) CALL LJUST(ABNJLL(L)) READ(LLIN,*) IONJLL(L), CHJLL(L), GJLL(L) C C SPECTRAL LINE QUANTITIES C READ(LLIN,*) ALAMLL(L), BLUELL(L), REDLL(L) READ(LLIN,*) FLL(L), GALL(L), GWLL(L), GQLL(L) C 200 CONTINUE DO 300 L=1,NLL CALL ELMCLL(L) 300 CONTINUE C CALL CLOSE(LLIN) C ADD TM WRITE(*,*)' INLIN ROUTINE EXECUTED.' C END ADD TM RETURN END C C ********************************************************************** C SUBROUTINE ELMCLL(LL) C C FINDS ELEMENT NUMBER CORRESPONDING TO ABSORPTION COMPONENT C ABNAME(KOMP). THIS IS DONE BY COMPARING THE FIRST TWO LETTERS C IN ABNAME WITH THE ARRAY IEL READ BY INJON C C: ELMCLL 94-03-08 NEW ROUTINE (DAN KISELMAN) C: NEW ROUTINE THAT DOES THE SAME THING FOR LINE DATA C: AS ELMCMP DOES FOR LEVEL DATA. IDENTIFICATION IS BASED C: ON LOWER LEVEL OF LINE - ABNILL. C: THE RESULT IS THE ARRAY IELLLL C: INCLUDE 'PREC' PARAMETER (MEL=16,MJMAX=90,MKMAX=140,MLMAX=400,MJ=5) PARAMETER (MT=300,MKOMP=150,ML=50000,MSET=1,MLATB=50,MTETB=30, * MELMAX=2,MKOMPR=MKOMP,MKOMPT=10, * KFADIM=MKOMPR*MT+MKOMPT*MT*3,IFADIM=MKOMPT*MT) C COMMON/CI1/FL2(5),PARCO(MJMAX),PARQ(4*MJMAX),SHXIJ(5),TPARF(4), *XIONG(MEL,MJ),EEV,ENAMN,SUMH,XKBOL,SUMM,NJ(MEL),NEL CHARACTER*3 CEL COMMON/CC1/CEL(MEL) C INCLUDE 'CALIN' C COMMON /CLU/ LINPUT,LATOM,LATOM2,LATMOS,LDSCAL,LABUND,LOUT, * LTIME,LRSTRT,LDSCA2,LWMAT,LNIIT,LDUMS,LDUMI,LDUMC,LOPC, * LJNY,LINIT,LPHI,LJOBLO,LATHSE C CHARACTER*20 TEXT C TEXT=ABNILL(LL) CALL LJUST(TEXT) DO 200 I=1,NEL IF(TEXT(1:2).EQ.CEL(I)(1:2)) GOTO 300 200 CONTINUE WRITE(LJOBLO,210) TEXT(1:2) 210 FORMAT(' ELMCLL: ELEMENT ',A,' NOT FOUND') CALL STOP(' ') C 300 CONTINUE IELLLL(LL)=I C END C C ********************************************************************** C FUNCTION PROFLL(ALAMD,ALAMB,GA,GW,GQ,ION,PION,CHIEV,CHJEV, * AWGT,TOTHI,QNORM,K) C C CALCULATES HNY4P*B(I,J)*PHI IN UNITS CM**2/PARTICLE C VARIABLES: C ALAMD VACUUM WAVELENGTH WHERE PROFILE IS TO BE CALCULATED C ALAMB VACUUM WAVELENGTH FOR CENTER OF LINE C GA,GW,GQ BROADENING PARAMETERS, SEE ATOM C ION IONIZATION DEGREE C PION IONIZATION POTENTIAL FROM GROUND STAGE (ELECTRON VOLTS) C CHIEV EXCITATION POTENTIAL OF LOWER LEVEL (ELECTRON VOLTS) C CHJEV EXCITATION POTENTIAL OF UPPER LEVEL (ELECTRON VOLTS) C AWGT ATOMIC WEIGHT IN CGS UNITS OF ABSORBER C TOTHI NUMBER DENSITY OF NEUTRAL HYDROGEN C K DEPTH POINT INDEX C C LINE OPACITY IS XLIN=N(LOWER LEVEL)*FLL*(1.-EXP(HNY/KT))*PROFLL C THERMODYNAMIC VARIABLES ARE TRANSFERRED IN COMMON CATMOS AND C CATMO2. NOTE THAT MANY OF THE LOCAL VARIABLES HAVE NAMES C IDENTICAL WITH ARRAYS IN MULTI. CATOM CAN THEREFORE NOT C BE INCLUDED AS A COMMON-BLOCK C C: C: PROFLL 94-03-23 NEW ROUTINE: (MATS CARLSSON, DAN KISELMAN) C: INCLUDE 'PREC' INCLUDE 'PARAM' INCLUDE 'CATMOS' INCLUDE 'CATMO2' INCLUDE 'CCONST' C DATA IDEBUG/0/ SAVE IDEBUG C T=TEMP(K) C C CALCULATE DOPPLER WIDTH C DNYD=SQRT(2.*BK*T/AWGT)*1.E-5/QNORM C C INCLUDE MICROTURBULENCE C DNYD=SQRT(DNYD**2+VTURB(K)**2) C C CALCULATE GAMMA, ADAMP C CTM IF(CHIEV.GE.PION.OR.CHJEV.GE.PION)THEN WRITE(*,*)"ALAMB=",ALAMB STOP"PB IN ABSLIN: CHIEV > PION" ENDIF CTM IF(GW.NE.0.0) THEN ZZ=ION C625=1.283984E-12*ZZ**0.8*(1./(PION-CHJEV)**2- * 1./(PION-CHIEV)**2)**.4 GV=GW*8.411*(8.*BK*T/PI*(1./(1.008*UU)+1./AWGT))**0.3* * TOTHI*C625 ELSE GV=0.0 ENDIF GR=GA IF(GQ.GE.0.0) THEN GS=GQ*NE(K) ELSE C FORMULA FROM GRAY, P.237 GSLG=19.4+2./3.*GQ+LOG10(NE(K)*BK)+LOG10(T)/6. GS=10.**GSLG ENDIF C GAMMA=GR+GV+GS C C DNYD*QNORM IS IN UNITS OF KM/S C DOP IS IN UNITS HZ C DOP=DNYD*QNORM/ALAMB*1.E13 ADAMP=GAMMA/(4.*PI*DOP) C C Q IS DELTA(NY) IN UNITS OF A TYPICAL DOPPLER WIDTH C V IS DELTA(NY)/DNYD, UNITLESS C Q = (CC/ALAMD - CC/ALAMB)*ALAMB*1.E-5/QNORM V=Q/DNYD C CALL VOIGT(ADAMP,V,H) PHI=H/(DNYD*1.772453851) C C PHI IS IN UNITS OF PER TYPICAL DOPPLER WIDTH C WE NOW CONVERT TO CM^2 PER PARTICLE AT FLL=1.0 BY C MULTIPLYING WITH HNY4P*B(I,J). FOLLOW MULTI NOTATION TO C SIMPLIFY COMPARISON C RELATION BETWEEN B(I,J) AND FLL IS: C HH*NU/(4*PI)*B(I,J)=PI*ESU^2/(EM*CC)*FLL C WE CONTINUE TO USE THE FORM FROM MULTI, SUBROUTINE ATOM C BIJ=ALAMB/HC2*FLL*6.671E15 C HNY4P=HH*CC/QNORM/4./PI*1.E-5 FLL=1.00 HC2=2.*HH*CC*1.E24 BIJ=FLL*ALAMB/HC2*6.671E15 C PROFLL=HNY4P*BIJ*PHI if(idebug.eq.1) then print *,'dnyd =',dnyd print *,'adamp =',adamp print *,'gv =',gv print *,'c625 =',c625 print *,'awgt =',awgt print *,'hh,cc,bk=',hh,cc,bk print *,'bij =',bij print *,'phi =',phi print *,'hny4p =',hny4p print *,'h =',h print *,'profll =',profll endif C RETURN END C C********************************************************************* C SUBROUTINE GENCOL C C GENERAL ROUTINE FOR COMPUTING COLLISIONAL RATES (VERSION MAR '89) C FORMAT IS EITHER GIVEN IN TERMS OF A COLLISION STRENGTH OMEGA C OR A CE(TE) RATE C C OMEGAS ARE USED FOR CHARGED IONS IN GENERAL, C SINCE THEY REMAIN ROUGHLY CONSTANT WITH TEMPERATURE. C RATE IS PROP. TO 1/SQRT(TE) * EXP(DELTA-E) C C CE(TE) VALUES ARE USED LARGELY FOR NEUTRALS FOR SAME REASON. C RATE IS PROP. TO SQRT(TE) * EXP(DELTA-E) C C CI(TE) VALUES ARE USED FOR IONIZATION RATES: THESE HAVE A C SQRT(TE) * EXP(DELTA-E) DEPENDENCE AS FOR CE(TE) C C ORIGINALLY CODED BY P.G. JUDGE, APRIL 2ND, 1987 C MODIFIED FOR FORTRAN-77 STANDARD BY P.G. JUDGE, MAY 21ST 1987 C: C: GENCOL 87-05-21 NEW ROUTINE: (PHILIP JUDGE) C: GENERAL COLLISONAL ROUTINE READING TABLES C: C: 89-03-24 MODFICATIONS: (PHILIP JUDGE) C: NEW INPUT 'CP' AND 'CH' ADDED FOR INELASTIC COLLISIONS C: WITH NEUTRAL AND IONIZED HYDROGEN. C: 'SEMI ' CHANGED SO THAT THE ABSORPTION OSCILLATOR STRENGTH C: IS REQUIRED FOR INPUT. C: C: 89-06-07 MODIFICATIONS: (MATS CARLSSON) C: DO LOOP VARIABLE IT CHANGED TO JT IN ORDER NOT TO CONFLICT C: WITH THE MAIN ITERATION VARIABLE IT IN ITER C: C: 90-04-10 MODIFICATIONS: (PHILIP JUDGE) C: LOW TEMPERATURE DIELECTRONIC RECOMBINATION OPTION ADDED C: FOLLOWING NUSSBAUMER AND STOREY (A+A ) C: NOTE THAT ONLY THE RATE DOWNWARD IS ADDED TO THE FIXED RATE C: C: 90-08-27 MODIFICATIONS: (MATS CARLSSON) C: DO LOOP 1 REPLACED BY A GOTO TO REMOVE RESTRICTION ON C: NUMBER OF LINES WITH COLLISIONAL DATA C: C: 92-08-10 MODIFICATIONS (MATS CARLSSON) C: INTEGER ARRAYS WITH ELEMENT NAME CHANGED TO CHARACTER ARRAYS C: C: 92-09-07 MODIFICATIONS (MATS CARLSSON) C: ADDED OPTIONS RECOMB AND ALPHA C: C: 94-01-24 MODIFICATIONS (PHILIP JUDGE) C: AR85 OPTIONS ADDED. ARNAUD AND ROTHENFLUG 1985 C: C: 94-02-22 MODIFICATIONS (PHILIP JUDGE) C: AR85-CEA FORMALISM ADDED C: C: 94-03-08 MODIFICATIONS (PHILIP JUDGE) C: AR85-CH, AR85-CH+, AR85-CHE, AR85-CHE+, FORMALISM ADDED C: C: 95-08-23 MODIFICATIONS (MATS CARLSSON) C: THERMAL P-FUNCTION FOR SEMI-EMPIRICAL RATES RENAMED TO PSEMI C: C: 96-03-20 MODIFICATIONS (MATS CARLSSON) C: WRITE STATEMENT CHANGED TO CONTAIN FEWER CONTINUATION CARDS C: C: 97-11-11 MODIFICATIONS (MATS CARLSSON) C: TAUT SPLINE INTERPOLATION INSTEAD OF SPLINE INTERPOLATION TO C: AVOID NEGATIVE VALUES C: INCLUDE 'PREC' PARAMETER (MTGRD=50,MSHELL=5) INCLUDE 'PARAM' INCLUDE 'CATOM' INCLUDE 'CATMOS' INCLUDE 'CATMO2' INCLUDE 'CCONST' INCLUDE 'CINPUT' INCLUDE 'CLU' C C LOCAL VARIABLES: UP TO MTGRD POINTS IN TEMPERATURE GRID ALLOWED C THIS CAN BE INCREASED C DIMENSION TGRID(MTGRD),CGRID(MTGRD),WORK(MTGRD,6) DIMENSION TGRD(MTGRD*2),CGRD(4,MTGRD*2) DIMENSION CDI(5,MSHELL) DIMENSION CEA(MDEP) CHARACTER *20 KEY C C ADD TM FOR DRAWIN C LOGICAL, PARAMETER :: DRAWIN = .TRUE. LOGICAL, PARAMETER :: DRAW_WRI = .FALSE. INTEGER, PARAMETER :: DRK = 56 REAL, PARAMETER :: DRAWIN_SH = 0.0 DOUBLE PRECISION :: DRAW_MU, DRAW_M, DRAW_V, DRAW_MV DOUBLE PRECISION :: DRAW_PSY, DRAW_X, DRAW_Q, DRAW_F DOUBLE PRECISION :: DRAW_A, DRAW_S, DRAW_CDN, DRAW_CUP C C END ADD TM FOR DRAWIN C C ADD TM FOR H MINUS DOUBLE PRECISION :: PHI_T, NHMIN C END ADD TM C C ALPRD IS TRUE IF INITIA HAS BEEN CALLED TO CALCULATE ALPHA COLLISIONS LOGICAL ALPRD DATA ALPRD/.FALSE./ SAVE ALPRD C C ADD TM C IF(DRAWIN) WRITE(LOUT,*) "H COLLISION DRAWIN'S FORMULA (1969)" IF(DRAWIN) WRITE(LOUT,*) "SCALING FACTOR S_H = ", DRAWIN_SH C C END ADD TM C C C OUTPUT FOR IWATOM .GT. 1 C IF(IWATOM .GT. 1) THEN WRITE(LOUT,8000) WRITE(LOUT,8001) WRITE(LOUT,8002) WRITE(LOUT,8003) WRITE(LOUT,8004) 8000 FORMAT('1 COLLISION RATES FROM SUBROUTINE G E N C O L'// * 1X,'PARAMETERS ARE AS FOLLOWS:'// * 1X,'TEMP - TEMPERATURE GRID GIVEN IN FILE ATOM'/ * 1X,' (SPLINE INTEPOLATIONS ARE MADE)'// * 1X,'CE - NEUTRAL B-B COLLISION RATE WHERE'/ * 1X,' R(U-L) = CE * NE * G(L) * SQRT(TEMP) / G(U)'/) 8001 FORMAT(1X,'OHM - ION B-B COLLISION RATE WHERE'/ * 1X,' R(U-L) = OHM * NE * 8.63E-6 / SQRT(TEMP) / G(U)'// * 1X,'SEMI - B-B COLLISIONAL RATE USING THE SEMI-EMPIRICAL'/ * 1X,' FORMULAE OF VAN REGEMORTER AND SHEVELKO'// * 1X,'CP - B-B COLLISIONAL RATE WITH PROTONS WHERE'/ * 1X,' R(U-L) = CP * NP '// * 1X,'CH - B-B COLLISIONAL RATE WITH NEUTRAL HYDROGEN WHERE') 8002 FORMAT(1X,' R(U-L) = CH * N(H I) '// * 1X,'CI - B-F IONIZATION RATE WHERE'/ * 1X,' R(L-U) = CI * NE * EXP(-DELTAE/KT) * SQRT(T)'// * 1X,'CALP - COLLISIONS WITH ALPHA PARTICLES'/ * 1X,' R(I-J) = CALP * N(NK)'/) 8003 FORMAT(1X,'***********************************************'/ * 1X,'*** ALL THE ABOVE HAVE REVERSE RATES IN LTE ***'/ * 1X,'*** THE FOLLOWING HAVE ZERO REVERSE RATES ***'/ * 1X,'*** UNLESS SPECIFIED EXPLICITLY ***'/ * 1X,'***********************************************'/) 8004 FORMAT(1X,'CH0 - CHARGE TRANSFER RATE WITH NEUTRAL HYDROGEN'/ * 1X,' R(I-J) = CH0 * NH(LEVEL1)'// * 1X,'CH+ - CHARGE TRANSFER RATE WITH IONIZED HYDROGEN'/ * 1X,' R(I-J) = CH+ * N(H II)'/// * 1X,'RECO - RECOMBINATION RATE'/ * 1X,' R(J-I) = RECO * NE'/// * 1X,'KEY ','FROM TO PARAMETERS... '/) ENDIF C NTEMP=1 C C READ THE KEYWORD 'KEY' AND ASSOCIATED PARAMETERS C 50 CONTINUE C C ASSUME INITIALLY THAT DATA ARE GIVEN INDEPENDENT OF TEMPERATURE: C I.E. THAT NTEMP IS ORIGINALLY SET = 1 C C READ(LDUMS,100,END=301)KEY 100 FORMAT(A) CALL LJUST(KEY) IF(KEY(1:1) .EQ. ' ') GOTO 50 IF (KEY(1:3) .EQ. 'END')THEN GOTO 300 ELSE IF (KEY(1:4) .EQ. 'TEMP')THEN READ(LDUMS,*)NTEMP,(TGRID(JT),JT=1,MIN(NTEMP,MTGRD)) C WRITE(*,*)NTEMP,(TGRID(JT),JT=1,MIN(NTEMP,MTGRD)) IF(NTEMP .GT. MTGRD)THEN CALL STOP(' GENCOL: WORK ARRAYS (TGRID) TOO SMALL') ENDIF IF (IWATOM .GT. 1)THEN WRITE(LOUT,803)KEY(1:4),(TGRID(JT),JT=1,NTEMP) 803 FORMAT(1X,A,8X,10(1P,1X,E10.3)) ENDIF GOTO 50 ELSE IF (KEY(1:4) .EQ. 'SEMI') THEN READ(LDUMS, *) IL,IH, FAB IF(IWATOM .GT. 1)WRITE(LOUT,804)KEY(1:4),IL,IH 804 FORMAT(1X,A,2(2X,I2)) ELSE IF (KEY(1:4) .EQ. 'LTDR') THEN READ(LDUMS, *) IL,IH, ALTDR,BLTDR,CLTDR,DLTDR,FLTDR IF(IWATOM .GT. 1)WRITE(LOUT,805)KEY(1:4),IL,IH,ALTDR, * BLTDR,CLTDR,DLTDR,FLTDR 805 FORMAT(1X,A,2(2X,I2),5(2X,F11.4)) C C ADDITION P. JUDGE 24-JAN-1994: BEGIN C ELSE IF (KEY(1:7) .EQ. 'AR85-RR') THEN READ(LDUMS, *) IL,IH,ARADAR,ETAAR ELSE IF (KEY(1:8) .EQ. 'AR85-CDI') THEN READ(LDUMS, *) IL,IH,NCDI IF(NCDI .GT. MSHELL) CALL STOP('GENCOL: NCDI .GT. MSHELL') READ(LDUMS,*) ((CDI(J,I),J=1,5),I=1,NCDI) C C ADDITION P. JUDGE 24-JAN-1994: END C C C 22-FEB-1994 P.G.JUDGE MODIFICATIONS START: C ELSE IF (KEY(1:8) .EQ. 'AR85-CEA') THEN READ(LDUMS, *) IL,IH,CEAFAK ILO=MIN( IL, IH ) IHI=MAX( IL, IH ) CALL AR85CEA(ILO,IHI,CEA) DO 654 K=1,NDEP CEA(K)=CEA(K)*CEAFAK 654 CONTINUE C C 22-FEB-1994 P.G.JUDGE MODIFICATIONS END: C C C 08-MAR-1994 P.G.JUDGE MODIFICATIONS START: C ALL FOUR CHARGE TRANSFER KEYWORDS HERE ELSE IF (KEY(1:7) .EQ. 'AR85-CH') THEN READ(LDUMS, *) IL,IH READ(LDUMS,*) AR85T1,AR85T2,AR85A,AR85B,AR85C,AR85D C C 08-MAR-1994 P.G.JUDGE MODIFICATIONS END: C ELSE IF (KEY(1:7) .EQ. 'SHULL82') THEN READ(LDUMS, *) IL,IH,ACOLSH,TCOLSH,ARADSH,XRADSH,ADISH, * BDISH,T0SH,T1SH IF(IWATOM .GT. 1)WRITE(LOUT,806)KEY(1:6),IL,IH,ACOLSH, * TCOLSH,ARADSH,XRADSH,ADISH,BDISH,T0SH,T1SH 806 FORMAT(1X,A,2(2X,I2),8(2X,1P,E11.4)) ELSE IF (KEY(1:7) .EQ. 'BURGESS') THEN READ(LDUMS,*) IL,IH,CGRID(1) ELSE IF (KEY(1:6) .EQ. 'CORONA') THEN READ(LDUMS, *) IL,IH IF(IWATOM .GT. 1)WRITE(LOUT,804)KEY(1:6),IL,IH ELSE IF (KEY(1:3) .EQ. 'OHM' * .OR. KEY(1:2) .EQ. 'CE' * .OR. KEY(1:2) .EQ. 'CP' * .OR. KEY(1:2) .EQ. 'CH' * .OR. KEY(1:4) .EQ. 'CALP' * .OR. KEY(1:4) .EQ. 'RECO' * .OR. KEY(1:3) .EQ. 'CH0' * .OR. KEY(1:3) .EQ. 'CH+' C MODIF TM C * .OR. KEY(1:2) .EQ. 'CI' C ADD TM * .OR. KEY(1:3) .EQ. 'TEP' * .OR. KEY(1:3) .EQ. 'TEI' * .OR. KEY(1:3) .EQ. 'TEF' * .OR. KEY(1:4) .EQ. 'TEPI' * .OR. KEY(1:4) .EQ. 'TESP' * .OR. KEY(1:5) .EQ. 'UPS_E' C * .OR. KEY(1:4) .EQ. 'THPI' * .OR. KEY(1:3) .EQ. 'THP' * .OR. KEY(1:3) .EQ. 'CHI' * .OR. KEY(1:4) .EQ. 'CHCE' * .OR. KEY(1:8) .EQ. 'UPS_H ' * .OR. KEY(1:8) .EQ. 'UPS_H_CE' C END ADD TM * )THEN C WRITE(*,*) "NTEMP=",NTEMP READ(LDUMS,*) IL,IH,(CGRID(JT),JT=1,NTEMP) C WRITE(*,*)IL,IH,(CGRID(JT),JT=1,NTEMP) C READ(*,*) NINTEP=NTEMP C C 23-FEB-1994 P.G.JUDGE MODIFICATIONS START: C SPECIAL CASE OF RAPID TE DEPENDENCE- INTERPOLATE LINEARLY IF(KEY(1:3) .EQ. 'CH+' .OR. KEY(1:3) .EQ. 'CH0') THEN NINTEP=2 WRITE(LJOBLO,*)'LINEAR INTERPOLATION OF LOG10 ',KEY(1:3) * , ' BETWEEN LEVELS', IL, IH DO 333 JT=1,NTEMP CGRID(JT)=LOG10(CGRID(JT)) 333 CONTINUE ENDIF C C 23-FEB-1994 P.G.JUDGE MODIFICATIONS END: C IF(IWATOM .GT. 1)THEN WRITE(LOUT,802)KEY(1:4), IL, IH, (CGRID(JT),JT=1,NTEMP) 802 FORMAT(1X,A,2(2X,I2),10(1P,1X,E10.3)) ENDIF C ADD TM ELSE IF(KEY(1:2).EQ.'CI') THEN READ(LDUMS, *) IL,IH, CT C END ADD TM ELSE WRITE(LJOBLO,191)KEY(1:4) 191 FORMAT(' GENCOL: KEYWORD(1:4) IS (',A,')') CALL STOP(' GENCOL: UNKNOWN KEYWORD IN ATOMIC DATA') ENDIF C C IDENTIFY THE UPPER AND LOWER LEVELS: C ILO=MIN( IL, IH ) IHI=MAX( IL, IH ) C C CHECK TO SEE THAT THE LEVELS ARE BETWEEN 1 AND NK C IF(ILO .LT. 1 .OR. IHI .GT. NK) * CALL STOP(' GENCOL: LEVEL INDEX OUTSIDE RANGE (1,NK)') C C CHECK TO SEE IF THERE ARE LEVELS WITH ENERGIES NOT INCREASING WITH C THE LEVEL LABEL (THIS AFFECTS CI ETC.) C IF(EV(IHI) .LT. EV(ILO) )THEN WRITE(LJOBLO,1001)KEY(1:4),IHI,ILO 1001 FORMAT(' GENCOL: WARNING- KEYWORD ',A,2(2X,I2), * ' ENERGY OF UPPER LEVEL IS .LT. LOWER LEVEL'/ * ' WARNING- CHECK RESULTS CAREFULLY') ENDIF C C DEPTH DO-LOOP: C DO 3 K=1,NDEP C C SEMI-EMPIRICAL COLLISIONS C IF (KEY(1:4) .EQ. 'SEMI')THEN EUPCM=EV(IHI)*EE/CC/HH ELOCM=EV(ILO)*EE/CC/HH FEM = FAB*G(ILO)/G(IHI) CT=SEMIC(ION(ILO),EUPCM,ELOCM,FEM,TEMP(K),III) CDN=CT*NE(K) CUP = CDN * NSTAR(IHI,K) / NSTAR(ILO,K) C(IHI,ILO,K) = CDN + C(IHI,ILO,K) C(ILO,IHI,K) = CUP + C(ILO,IHI,K) C ADD TM C IF(K.EQ.1) WRITE(*,*) C * 'C(',IHI,',',ILO,', NDEP) = ', C(IHI,ILO,NDEP) C END ADD TM C C CORONAL ION BALANCE DATA (FROM DATA READ IN OPACITY PACKAGE) C ELSE IF (KEY(1:6) .EQ. 'CORONA')THEN PE=BK*NE(K)*TEMP(K) CALL CORONR(ATOMID(1:3),ION(ILO),TEMP(K),PE,RECRAT,RIRAT) C(IHI,ILO,K) = C(IHI,ILO,K) + RECRAT*NE(K) C(ILO,IHI,K) = C(ILO,IHI,K) + RIRAT*NE(K) ELSE IF (KEY(1:7) .EQ. 'AR85-CH') THEN C C TABULAR DATA TO BE INTERPOLATED C ELSE IF (KEY(1:3) .EQ. 'OHM' * .OR. KEY(1:2) .EQ. 'CE' * .OR. KEY(1:2) .EQ. 'CP' * .OR. KEY(1:2) .EQ. 'CH' * .OR. KEY(1:4) .EQ. 'CALP' * .OR. KEY(1:4) .EQ. 'RECO' * .OR. KEY(1:3) .EQ. 'CH0' * .OR. KEY(1:3) .EQ. 'CH+' C * .OR. KEY(1:2) .EQ. 'CI' C ADD TM * .OR. KEY(1:3) .EQ. 'TEP' * .OR. KEY(1:3) .EQ. 'TEI' * .OR. KEY(1:3) .EQ. 'TEF' * .OR. KEY(1:4) .EQ. 'TEPI' * .OR. KEY(1:4) .EQ. 'TESP' * .OR. KEY(1:5) .EQ. 'UPS_E' C * .OR. KEY(1:4) .EQ. 'THPI' * .OR. KEY(1:3) .EQ. 'THP' * .OR. KEY(1:3) .EQ. 'CHI' * .OR. KEY(1:4) .EQ. 'CHCE' * .OR. KEY(1:8) .EQ. 'UPS_H ' * .OR. KEY(1:8) .EQ. 'UPS_H_CE' C END ADD TM * )THEN C IF(K.EQ.1) THEN C X55=5.5 C M=4 C CALL TAUTSP(TGRID,CGRID,NTEMP,X55,WORK,TGRD, C * CGRD,NTMP,M,IFLAG) C ENDIF IF(TEMP(K) .LT. TGRID(1)) THEN CT=CGRID(1) C IF(K.EQ.DRK) WRITE(*,*) "INTERP CASE 1", CT ELSE IF (TEMP(K) .GT. TGRID(NTEMP)) THEN CT=CGRID(NTEMP) C IF(K.EQ.DRK) WRITE(*,*) "INTERP CASE 2", CT ELSE IF(NTEMP.LT.4) THEN CT=SPLIN(TEMP(K),TGRID,CGRID,NTEMP,NINTEP) C IF(K.EQ.DRK) WRITE(*,*) "INTERP CASE 3", CT ELSE C CT=PPVALU(TGRD,CGRD,NTEMP,4,TEMP(K),0,MFLAG) C ADD TM CT=SPLIN(TEMP(K),TGRID,CGRID,NTEMP,NINTEP) C IF(K.EQ.DRK) WRITE(*,*), "INTERP CASE 4", CT C END ADD TM ENDIF ENDIF IF(KEY(1:3) .EQ. 'CH+' .OR. KEY(1:3) .EQ. 'CH0') CT=10.**CT IF(CT .LT. 0.) THEN WRITE(LJOBLO,*)'INTERPOLATED COLLISION PARAMETER < 0.', * ' AT TEMPERATURE ', TEMP(K) WRITE(LJOBLO,*)'FOR TRANSITION ', KEY,' ',IL,' ', IH WRITE(LJOBLO,*)(TGRID(JT),JT=1,NTEMP) WRITE(LJOBLO,*)(CGRID(JT),JT=1,NTEMP) CALL STOP('NEGATIVE COLLISION RATES ENCOUNTERED') ENDIF C C OMEGAS ARE GIVEN (+VE IONS) C IF(KEY(1:3) .EQ. 'OHM') THEN C TM ESSNER SEATON FORMULA FOR FORBIDDEN TRANSITIONS CDN = 8.63E-06 * CT * NE(K) / ( G(IHI)*SQRT(TEMP(K)) ) CUP = CDN * NSTAR(IHI,K) / NSTAR(ILO,K) C(IHI,ILO,K) = CDN + C(IHI,ILO,K) C(ILO,IHI,K) = CUP + C(ILO,IHI,K) C ADD TM C IF(K.EQ.NDEP) WRITE(*,*) C * 'C(',IHI,',',ILO,', NDEP) = ', C(IHI,ILO,K) C END ADD TM C C CE VALUES ARE GIVEN (NEUTRALS) C ELSE IF (KEY(1:2) .EQ. 'CE')THEN CDN = NE(K) * CT * G(ILO) * SQRT(TEMP(K)) / G(IHI) CUP= CDN * NSTAR(IHI,K) / NSTAR(ILO,K) C(IHI,ILO,K) = CDN + C(IHI,ILO,K) C(ILO,IHI,K) = CUP + C(ILO,IHI,K) C C CP VALUES ARE GIVEN (B-B COLLISIONS WITH PROTONS) C ELSE IF (KEY(1:2) .EQ. 'CP')THEN CDN = NH(6,K) * CT CUP= CDN * NSTAR(IHI,K) / NSTAR(ILO,K) C(IHI,ILO,K) = CDN + C(IHI,ILO,K) C(ILO,IHI,K) = CUP + C(ILO,IHI,K) C C CH VALUES ARE GIVEN (COLLISIONS WITH NEUTRAL HYDROGEN) C ELSE IF (KEY(1:3) .EQ. 'CH ')THEN CDN = NH(1,K) * CT CUP= CDN * NSTAR(IHI,K) / NSTAR(ILO,K) C(IHI,ILO,K) = CDN + C(IHI,ILO,K) C(ILO,IHI,K) = CUP + C(ILO,IHI,K) C C CI VALUES ARE GIVEN C ELSE IF (KEY(1:2) .EQ. 'CI')THEN DEKT= (EV(IHI)-EV(ILO)) * EK / TEMP(K) C TM MODIFICATION: SEATON FORMULA FOR IONISATION RATE C CUP = NE(K) * CT * EXP(-DEKT) * SQRT(TEMP(K)) IF(ION(ILO).EQ.1) GBAR_TM = 0.1 IF(ION(ILO).EQ.2) GBAR_TM = 0.2 IF(ION(ILO).GE.3) GBAR_TM = 0.3 CUP = NE(K)*CT*1.55E13*GBAR_TM*EXP(-DEKT)/TEMP(K)**0.5/DEKT if(k==drk) write(*,*) "CI(",temp(k),")=",ct C END TM MODIFICATION CDN = CUP * NSTAR(ILO,K) / NSTAR(IHI,K) C(IHI,ILO,K) = CDN + C(IHI,ILO,K) C(ILO,IHI,K) = CUP + C(ILO,IHI,K) C ADD TM C IF(K.EQ.DRK) WRITE(*,*) C * 'CEI C(',IHI,',',ILO,',',DRK,') = ', C(IHI,ILO,K) C C CALCUL DES COLLISIONS B-F AVEC L'H NEUTRE DRAWIN (1969) C FORMULATION DE LAMBERT (1991) A 10 C IF(DRAWIN) THEN DRAW_X = EK/TEMP(K)*(EV(IHI)-EV(ILO)) DRAW_PSY = (1. + 2./DRAW_X)*EXP(-DRAW_X) DRAW_MU = AWGT*1.00794*UU/(AWGT+1.00794*UU) DRAW_M = EM*(AWGT+1.00794*UU)/(1.00794*UU)**2 DRAW_V = SQRT(2*BK*TEMP(K)/(PI*DRAW_MU)) DRAW_MV = DRAW_M * DRAW_V DRAW_Q = ( 13.6/(EV(IHI)-EV(ILO)) )**2 * 1.0 DRAW_A = 16.*PI*5.292E-9**2 * DRAW_Q*DRAW_MV*DRAW_PSY DRAW_S = NSTAR(IHI,K) / NSTAR(ILO,K) * DRAW_A C DRAW_CDN = DRAWIN_SH * DRAW_A * NH(1,K) C DRAW_CUP = NSTAR(IHI,K) / NSTAR(ILO,K) * DRAW_CDN DRAW_CUP = DRAWIN_SH * DRAW_A * NH(1,K)* DEXP(-DRAW_X) DRAW_CDN = NSTAR(ILO,K) / NSTAR(IHI,K) * DRAW_CUP C(IHI,ILO,K) = DRAW_CDN + C(IHI,ILO,K) C(ILO,IHI,K) = DRAW_CUP + C(ILO,IHI,K) IF(K.EQ.DRK .AND. DRAW_WRI) THEN WRITE(*,*)"TEMP,NH,NE/NH=",TEMP(K),NH(1,K),NH(1,K)/NE(K) WRITE(*,*) 'DRAW_X =', DRAW_X WRITE(*,*) 'DRAW_PSY =', DRAW_PSY WRITE(*,*) 'DRAW_MU =', DRAW_MU WRITE(*,*) 'DRAW_M =', DRAW_M WRITE(*,*) 'DRAW_V =', DRAW_V WRITE(*,*) 'DRAW_Q =', DRAW_Q WRITE(*,*)'CHI A(',IHI,',',ILO,',',DRK,') = ', DRAW_A WRITE(*,*)'CHI S(',IHI,',',ILO,',',DRK,') = ', DRAW_S ENDIF IF(K.EQ.DRK .AND. DRAW_WRI) * WRITE(*,*)'CHI C(',IHI,',',ILO,',',DRK,') = ', DRAW_CDN ENDIF C C END ADD TM C C ADD TM MODIFICATION C UPSILON_H ARE GIVEN C ELSE IF (KEY(1:4) .EQ. 'THPI' .OR. KEY(1:3) .EQ. 'THP' .OR. * KEY(1:8) .EQ. 'UPS_H ' ) THEN CDN = 2.014E-07 * CT * NH(1,K) / ( G(IHI)*SQRT(TEMP(K)) ) CUP = CDN * NSTAR(IHI,K) / NSTAR(ILO,K) C(IHI,ILO,K) = CDN + C(IHI,ILO,K) C(ILO,IHI,K) = CUP + C(ILO,IHI,K) if(k==drk) write(*,*) "THPI,THP,UPS_H(",temp(k),")=",ct C IF(K.EQ.DRK) WRITE(*,*) CT,NH(1,K),CDN/NH(1,K), CUP/NH(1,K) C IF(K.EQ.DRK)WRITE(*,*)'C(',IHI,',',ILO,',',DRK,')',CT,CDN,CUP ELSE IF(KEY(1:3) .EQ. 'CHI') THEN DEKT= (EV(IHI)-EV(ILO)) * EK / TEMP(K) CUP =2.014E-07*CT*NH(1,K)/(G(ILO)*SQRT(TEMP(K)))*DEXP(-DEKT) CDN = CUP * NSTAR(ILO,K) / NSTAR(IHI,K) C(IHI,ILO,K) = CDN + C(IHI,ILO,K) C(ILO,IHI,K) = CUP + C(ILO,IHI,K) C IF(K.EQ.DRK) WRITE(*,*)" DRAWIN CHI: CT,CDN/NH,CUP/NH", C * CT,CDN/NH(1,K),CUP/NH(1,K) ELSE IF(KEY(1:4).EQ.'CHCE' .OR. KEY(1:8).EQ.'UPS_H_CE') THEN DEKT= (EV(IHI)-EV(ILO)-0.754) * EK / TEMP(K) CUP =2.014E-07*CT*NH(1,K)/(G(ILO)*SQRT(TEMP(K)))*DEXP(-DEKT) PHI_T = 1.334*TEMP(K)**2.5 * 10**(-5040.*0.754/TEMP(K)) NHMIN = NH(1,K)*NE(K)* BK * TEMP(K) / PHI_T CDN = 4.028E-07*CT*NHMIN/(G(IHI)*SQRT(TEMP(K))) if(k==drk) write(*,*) "CHCE,UPS_H_CE(",temp(k),")=",ct C IF(K.EQ.DRK) WRITE(*,*)"MQ CHCE: CDN/NHMIN,CUP/NH(1,K)", C * CDN/NHMIN,CUP/NH(1,K) C IF(K.EQ.DRK) WRITE(*,*)"PHI_T, NHMIN, CDN",PHI_T,NHMIN,CDN C(IHI,ILO,K) = CDN + C(IHI,ILO,K) C(ILO,IHI,K) = CUP + C(ILO,IHI,K) C C END ADD TM C C CH OR CH+ VALUES GIVEN: CHARGE TRANSFER COLLISIONS WITH C HYDROGEN ATOMS/IONS NB: ORDERING IMPORTANT HERE C EXAMPLE INPUT: C C CH0 C 1 2 1.E-9 1.E-9 1.E-9 C C THIS ASSUMES THAT THE RATE 1.E-9*NH(1,K) WILL BE ADDED TO THE C COLLISION RATE FROM LEVEL 1 TO LEVEL 2 C ELSE IF (KEY(1:3) .EQ. 'CH0') THEN C(IL,IH,K)= NH(1,K) * CT + C(IL,IH,K) ELSE IF (KEY(1:3) .EQ. 'CH+') THEN C(IL,IH,K)= NH(6,K) * CT + C(IL,IH,K) C C LOW-TEMPERATURE DIELECTRONIC RECOMBINATION COEFFS. ARE GIVEN C FORMULA (9) OF NUSSBAUMER AND STOREY (A+A PAPER II) C ELSE IF(KEY(1:4) .EQ. 'LTDR') THEN T4LTDR=TEMP(K)/1.E4 CDN = 1.E-12*NE(K)* (ALTDR/T4LTDR + BLTDR + * CLTDR*T4LTDR +DLTDR*T4LTDR*T4LTDR) * * EXP(-FLTDR/T4LTDR)/T4LTDR/SQRT(T4LTDR) C(IHI,ILO,K) = CDN + C(IHI,ILO,K) C C ADDITION P. JUDGE 24-JAN-1994: BEGIN C C PARAMETRIC FITS TO DATA OF ARNAUD AND ROTHENFLUG 1985, C APJS 60, 425. C CDI IS 5 BY MSHELL ELEMENT ARRAY, CONTAINING PARAMETERS C I, A,B,C,D OF TABLE 1 OF ARNAUD AND ROTHENFLUG ELSE IF(KEY(1:7) .EQ. 'AR85-RR') THEN CDN= ARADAR*(TEMP(K)/1.E4)**ETAAR C(IHI,ILO,K) = CDN + C(IHI,ILO,K) ELSE IF(KEY(1:8) .EQ. 'AR85-CDI') THEN CUP=0. DO 321 J=1,NCDI XJ=CDI(1,J)*EE/BK/TEMP(K) FXJ=EXP(-XJ)*SQRT(XJ) *(CDI(2,J)+CDI(3,J)*(1.+XJ) + * (CDI(4,J)-XJ*(CDI(2,J)+CDI(3,J)*(2.+XJ)))*FONE(XJ) + * CDI(5,J)*XJ*FTWO(XJ)) CUP = CUP+ 6.69E-07 / CDI(1,J) / SQRT(CDI(1,J))*FXJ 321 CONTINUE IF(CUP .LT. 0.) CALL STOP('GENCOL: CDI-CUP .LT.0') C(ILO,IHI,K) = CUP*NE(K) + C(ILO,IHI,K) C(IHI,ILO,K) = CUP*NE(K)*NSTAR(ILO,K)/NSTAR(IHI,K) * + C(IHI,ILO,K) C C ADDITION P. JUDGE 24-JAN-1994: END C C C 22-FEB-1994 P.G.JUDGE MODIFICATIONS START: C ELSE IF(KEY(1:8) .EQ. 'AR85-CEA') THEN C(ILO,IHI,K) = CEA(K)*NE(K) + C(ILO,IHI,K) C C THIS IS INCORRECT SINCE POPULATION OF UPPER LEVEL IS THE UPPER LEVEL C OF THE DOUBLY EXCITED STATE, **, I.E. THIS SHOULD BE MULTIPLIED BY C G(**)/G(IHI) EXP(E(**) - E(IHI)). A BETTER APPROXIMATION WOULD SEEM TO C BE 0. TIMES THIS TO AVOID PROBLEMS. HENCE COMMENT THIS LINE OUT C C C(IHI,ILO,K) = CEA(K)*NE(K)*NSTAR(ILO,K)/NSTAR(IHI,K) C * + C(IHI,ILO,K) C C 22-FEB-1994 P.G.JUDGE MODIFICATIONS END: C C C 08-MAR-1994 P.G.JUDGE MODIFICATIONS START: C C AR85-CH CHARGE TRANSFER RECOMBINATION WITH NEUTRAL HYDROGEN C ELSE IF(KEY(1:7) .EQ. 'AR85-CH' .AND. KEY(1:8) .NE. * 'AR85-CH+' .AND. KEY(1:8) .NE. 'AR85-CHE') THEN IF(TEMP(K) .GE. AR85T1 .AND. TEMP(K) .LE. AR85T2) THEN T4=TEMP(K)/1.E4 CUP = AR85A * 1.E-9 * T4**AR85B * (1. + AR85C * * EXP(AR85D*T4))*NH(1,K) C(IL,IH,K) = CUP + C(IL,IH,K) ENDIF C C AR85-CH+ CHARGE TRANSFER WITH IONIZED HYDROGEN C ELSE IF(KEY(1:8) .EQ. 'AR85-CH+') THEN IF(TEMP(K) .GE. AR85T1 .AND. TEMP(K) .LE. AR85T2) THEN T4=TEMP(K)/1.E4 CUP = AR85A * 1.E-9 * T4**AR85B * EXP(-AR85C*T4) * * EXP(-AR85D*EE/BK/TEMP(K))*NH(6,K) C(IL,IH,K) = CUP + C(IL,IH,K) ENDIF C C AR85-CHE CHARGE TRANSFER WITH NEUTRAL HELIUM C ELSE IF(KEY(1:8) .EQ. 'AR85-CHE' .AND. KEY(1:9) .NE. * 'AR85-CHE+') THEN IF(TEMP(K) .GE. AR85T1 .AND. TEMP(K) .LE. AR85T2) THEN T4=TEMP(K)/1.E4 HPOP=NH(1,K)+NH(2,K)+NH(3,K)+NH(4,K)+NH(5,K)+NH(6,K) CALL HEPOP(TEMP(K),HPOP,HE1,HE2,HE3) CUP = AR85A * 1.E-9 * T4**AR85B * (1. + AR85C * * EXP(AR85D*T4))*HE1 C(IL,IH,K) = CUP + C(IL,IH,K) ENDIF C C AR85-CHE+ CHARGE TRANSFER WITH IONIZED HELIUM C ELSE IF(KEY(1:9) .EQ. 'AR85-CHE+') THEN IF(TEMP(K) .GE. AR85T1 .AND. TEMP(K) .LE. AR85T2) THEN T4=TEMP(K)/1.E4 HPOP=NH(1,K)+NH(2,K)+NH(3,K)+NH(4,K)+NH(5,K)+NH(6,K) CALL HEPOP(TEMP(K),HPOP,HE1,HE2,HE3) CUP = AR85A * 1.E-9 * T4**AR85B * EXP(-AR85C*T4) * * EXP(-AR85D*EE/BK/TEMP(K))*HE2 C(IL,IH,K) = CUP + C(IL,IH,K) ENDIF C C 08-MAR-1994 P.G.JUDGE MODIFICATIONS END: C C C COMPUTATIONS FROM TABLES OF SHULL & VAN STEENBERG, C AP J SUPPL 48 P95 C ELSE IF(KEY(1:7) .EQ. 'SHULL82') THEN C C NOVEMBER 9, 1994, MODIFICATIONS P. JUDGE, BEGIN C IDEA IS TO REDUCE DIELECTRONIC RECOMBINATION RATE C OWING TO COLLISIONAL IONIZATION OF RYDBERG STATES C FOLLOWING SUMMERS 1974, APPLETON LAB REPT. C SUMMRS=1.0 C TO REMOVE DENSITY DEPENDENCE IN DIELECTRONIC RATE COMMENT OUT C THE NEXT LINE SUMMRS=SUMMERS(ILO,IHI,NE(K)) CDN=ARADSH*(TEMP(K)/1.E4)**(-XRADSH) + SUMMRS* * ADISH /TEMP(K)/SQRT(TEMP(K)) * EXP(-T0SH/TEMP(K))* * (1.E0+BDISH * (EXP(- T1SH/TEMP(K)))) C C NOVEMBER 9, 1994, MODIFICATIONS P. JUDGE, END C CDN=CDN*NE(K) CUP=ACOLSH * SQRT(TEMP(K)) * EXP( -TCOLSH / TEMP(K)) * / (1.E0 + 0.1 * TEMP(K) / TCOLSH) CUP=CUP*NE(K) C* C* 3-BODY RECOMBINATION (HIGH DENSITY LIMIT) C* CDN=CDN+CUP*NSTAR(ILO,K)/NSTAR(IHI,K) C* C(IHI,ILO,K) = CDN + C(IHI,ILO,K) C(ILO,IHI,K) = CUP + C(ILO,IHI,K) C C BURGESS C ELSE IF (KEY(1:7) .EQ. 'BURGESS') THEN DE=(EV(IHI)-EV(ILO)) ZC=ION(ILO)-1 BETAB = 0.25*(SQRT((100.*ZC +91)/(4.*ZC+3))-5.) CBAR=2.3 DEKT=DE*EE/BK/TEMP(K) DDEKT=-DEKT/TEMP(K) X100=500. DEKT=MIN(X100,DEKT) DEKTI=1./DEKT WLOG=LOG(1. + DEKTI) WB = WLOG**(BETAB/(1.+DEKTI)) C EXIN1=EXPINT(1,DEKT,DUM) QB = 2.1715E-08*CBAR*(13.6/DE)**1.5 * SQRT(DEKT) * * EXIN1*WB C GENCOL 95-05-22 VH ACTELC=1 TO BE REPLACED LATER BY C ROUTINE THAT COMPUTES NUMBER C OF ACTIVE ELECTRONS FROM TERM INFORMATION ACTELC=1. CUP=QB*ACTELC*NE(K) CDN=CUP*NSTAR(ILO,K)/NSTAR(IHI,K) C(ILO,IHI,K) = CUP + C(ILO,IHI,K) C(IHI,ILO,K) = CDN + C(IHI,ILO,K) C C CALP VALUES ARE GIVEN (COLLISIONS WITH ALPHA PARTICLES) C ATOM HAS TO BE HE C INITIA IS CALLED FOR FIRST RATE TO READ POPULATIONS C FROM RSTRT C ELSE IF (KEY(1:4) .EQ. 'CALP') THEN IF(ATOMID(1:2).NE.'HE') THEN CALL STOP('GENCOL: ATOM HAS TO BE HE FOR CALPHA') ENDIF IF(.NOT.ALPRD) THEN CALL RDALP ALPRD=.TRUE. ENDIF CDN = N(NK,K) * CT CUP= CDN * NSTAR(IHI,K) / NSTAR(ILO,K) C(IHI,ILO,K) = CDN + C(IHI,ILO,K) C(ILO,IHI,K) = CUP + C(ILO,IHI,K) C C RECOMBINATION COEFFICIENTS ARE GIVEN C C(J-I)=NE*CT C ELSE IF (KEY(1:4) .EQ. 'RECO') THEN C(IHI,ILO,K)= NE(K)*CT + C(IHI,ILO,K) C ADD TM : UPSILON VALUES ARE GIVEN (CT) C C TEP : TRANSITIONS PERMISES EMPIRIQUES C TEI : TRANSITIONS INTERDITES EMPIRIQUES C TEF : TRANSITIONS INTERDITES ENTRE NIVEAUX FINS C TEPI: TRANSITIONS PERMISES/INTERDITES THEORIQUES C TESP: TRANSITIONS SEMI-PERMISES AVEC F TROP PETIT ELSE IF (KEY(1:3) .EQ. 'TEP' * .OR. KEY(1:3) .EQ. 'TEI' * .OR. KEY(1:3) .EQ. 'TEF' * .OR. KEY(1:4) .EQ. 'TEPI' * .OR. KEY(1:4) .EQ. 'TESP' * .OR. KEY(1:5) .EQ. 'UPS_E') THEN CDN = 8.63E-06 * CT * NE(K) / ( G(IHI)*SQRT(TEMP(K)) ) CUP = CDN * NSTAR(IHI,K) / NSTAR(ILO,K) C(IHI,ILO,K) = CDN + C(IHI,ILO,K) C(ILO,IHI,K) = CUP + C(ILO,IHI,K) if(k==drk) write(*,*) "TEPI,UPS_E(",temp(k),")=",ct C C IF(K.EQ.DRK) WRITE(*,*) KEY(1:4), C * ' C(',IHI,',',ILO,',',DRK,') = ', C(IHI,ILO,K) C C CALCUL DES COLLISIONS B-B AVEC L'H NEUTRE DRAWIN (1969) C FORMULATION DE LAMBERT (1991) A10 C IF(DRAWIN) THEN KR = KRAD(IHI,ILO) C IF(K.EQ.NDEP)WRITE(*,*) "KR =", KR IF(KEY(1:3) .EQ. 'TEF') DRAW_F = 0. IF(KEY(1:3) .EQ. 'TEI') DRAW_F = 1. IF(KEY(1:4) .EQ. 'TEPI') THEN IF(KR .EQ. 0) THEN DRAW_F = 1. ELSE DRAW_F = F(KR) ENDIF ELSE IF(KEY(1:3) .EQ. 'TEP') THEN DRAW_F = F(KR) C IF(K.EQ.NDEP)WRITE(*,*) "F(KR) =", F(KR) ENDIF DRAW_X = EK/TEMP(K)*(EV(IHI)-EV(ILO)) DRAW_PSY = (1. + 2./DRAW_X)*EXP(-DRAW_X) DRAW_MU = AWGT*1.00794*UU/(AWGT+1.00794*UU) DRAW_M = EM*(AWGT+1.00794*UU)/(1.00794*UU)**2 DRAW_V = SQRT(2*BK*TEMP(K)/(PI*DRAW_MU)) DRAW_MV = DRAW_M * DRAW_V DRAW_Q = ( 13.6/(EV(IHI)-EV(ILO)) )**2 * DRAW_F DRAW_A = 16.*PI*5.292E-9**2 * DRAW_Q*DRAW_MV*DRAW_PSY DRAW_S = NSTAR(IHI,K) / NSTAR(ILO,K) * DRAW_A DRAW_CDN = DRAWIN_SH * DRAW_A * NH(1,K) DRAW_CUP = NSTAR(IHI,K) / NSTAR(ILO,K) * DRAW_CDN C(IHI,ILO,K) = DRAW_CDN + C(IHI,ILO,K) C(ILO,IHI,K) = DRAW_CUP + C(ILO,IHI,K) IF(K.EQ.DRK .AND. DRAW_WRI) THEN WRITE(*,*)"TEMP,NH,NH/NE=",TEMP(K),NH(1,K),NH(1,K)/NE(K) WRITE(*,*) 'DRAW_X =', DRAW_X WRITE(*,*) 'DRAW_PSY =', DRAW_PSY WRITE(*,*) 'DRAW_MU =', DRAW_MU WRITE(*,*) 'DRAW_M =', DRAW_M WRITE(*,*) 'DRAW_V =', DRAW_V WRITE(*,*) 'DRAW_Q =', DRAW_Q IF(KEY(1:3) .EQ. 'TEF') THEN WRITE(*,*)'THF A(',IHI,',',ILO,',',DRK,') = ', DRAW_A WRITE(*,*)'THF S(',IHI,',',ILO,',',DRK,') = ', DRAW_S ELSE IF(KEY(1:3) .EQ. 'TEI') THEN WRITE(*,*)'THI A(',IHI,',',ILO,',',DRK,') = ', DRAW_A WRITE(*,*)'THI S(',IHI,',',ILO,',',DRK,') = ', DRAW_S ELSE IF(KEY(1:4) .EQ. 'TEPI') THEN WRITE(*,*)'THPI A(',IHI,',',ILO,',',DRK,') = ', DRAW_A WRITE(*,*)'THPI S(',IHI,',',ILO,',',DRK,') = ', DRAW_S ELSE IF(KEY(1:3) .EQ. 'TEP') THEN WRITE(*,*)'THP A(',IHI,',',ILO,',',DRK,') = ', DRAW_A WRITE(*,*)'THP A(',IHI,',',ILO,',',DRK,') = ', DRAW_S ENDIF ENDIF IF(K.EQ.DRK .AND. KEY(1:3) .EQ. 'TEF' .AND. DRAW_WRI) * WRITE(*,*)'THF C(',IHI,',',ILO,',',DRK,') = ', DRAW_CDN IF(K.EQ.DRK .AND. KEY(1:3) .EQ. 'TEI' .AND. DRAW_WRI) * WRITE(*,*)'THI C(',IHI,',',ILO,',',DRK,') = ', DRAW_CDN IF(K.EQ.DRK .AND. KEY(1:4) .EQ. 'TEPI'.AND. DRAW_WRI) THEN WRITE(*,*)'THPI C(',IHI,',',ILO,',',DRK,') = ', DRAW_CDN ELSE IF(K.EQ.DRK.AND.KEY(1:3).EQ.'TEP'.AND.DRAW_WRI) THEN WRITE(*,*)'THP C(',IHI,',',ILO,',',DRK,') = ', DRAW_CDN ENDIF ENDIF C C END ADD TM C C MORE KEYWORDS CAN BE ADDED HERE C ENDIF 3 CONTINUE GOTO 50 C 301 CALL STOP(' GENCOL: KEYWORD ''END'' NOT FOUND IN COLLISION FILE') 300 CONTINUE C C ADD TM WRITE(*,*)'GENCOL ROUTINE EXECUTED.' C END ADD TM C RETURN END C C **************************************************************** C FUNCTION SPLIN(T, X, Y, N, NNN) C C SPLINE INTERPOLATION OF T IN A GIVEN TABLE OF POINTS(X(I),Y(I)). C C Y(I) IS A FUNCTION OF X(I) - X(N)>X(N-1)>....X(1) -OR- X(1)> X(2) C > ....> X(N) - WHEN X IS NORMALISED X(MIN) = 0, XMAX=1, C NORM(ABS(X(I+1)-X(I))) < 1.0E-8,(I=1,N-1). THE ARRAY X IS DIVIDED C INTO OVERLAPPING INTERVALS. EACH INTERVAL CONSISTS OF NNN POINTS, C THE OVERLAP IS INT(LOG(NNN)+3) POINTS. ( 3<=NNN<=100,N). C EACH TIME AFTER A CALL WHEN T CHANGES OF INTERVAL OR AFTER A CALL C WITH ANOTHER SET OF POINTS, A NEW CUBIC SPLINE OF NNN POINTS HAS C TO BE COMPUTED, THEREFORE THE COMPUTING TIME DEPENDS STRONGLY OF C THE SUCCESSION OF CALLS. C FOR EXAMPLE: SUCCESSIVE CALLS, WHERE T IS RANDOMLY CHOSEN WILL COST C A LOT OF COMPUTING TIME - (T OFTEN CHANGES OF INTERVAL) ---> C TAKE NNN THEN AS LARGE AS POSSIBLE. SUCCESSIVE CALLS WHERE T CHANGES C SLIGHTLY COST LESS COMPUTING TIME, SO IT WILL BE CLEAR THAT YOUR C CHOICE OF NNN DEPENDS HEAVILY UPON ITS WAY OF USEAGE. C C COMPUTING TIME: FOR THE COMPUTATION OF SPLINE COEFFICIENTS C THIS ROUTINE NEEDS ABOUT 21*N MULTIPLICATIONS OR DIVISIONS C FOR THE INTERPOLATION BY MEANS OF THE SPLINE COEFFICIENTS C THE ROUTINE NEEDS 9 MULTIPLICATIONS OR DIVISIONS. C C EXTRAPOLATION: IF T IS NOT IN [X(1),X(N)] T IS LINEAR EXTRAPOLATED C C A PART OF THE ALGORITM FOR THE COMPUTATION OF A NATURAL SPLINE C IS TAKEN FROM T.N.E. GREVILLE, THE LINEAR SYSTEM IS SOLVED BY C THE METHOD OF SUCCESSIVE OVERRELAXATION. (ERROR = 1.0E-6) C C REF: T.N.E. GREVILLE, MATHEMATICS RESEARCH CENTER, U.S. ARMY, C UNIVERSITY OF WISCONSIN. MATHEMATICAL METHODS. C C THIS ROUTINE WAS IMPLEMENTED BY E.B.J. VAN DER ZALM, STERRENWACHT C UTRECHT (MAY 7TH 1981). ADAPTED FOR VAX\11 BY PAUL KUIN AT OXFORD. C WRITTEN IN REAL*4 BY P.G. JUDGE, OXFORD C MODIFIED SO THAT IF THE ARGUMENT IS OUTSIDE THE RANGE OF X-VALUES C THEN THE FIRST (OR LAST) Y-VALUE IS TAKEN C C INPUT: T ARGUMENT (REAL) C X ARRAY OF ARGUMENTS (REAL) C Y ARRAY OF FUNCTION VALUES (REAL) C N LENGTH OF THE ARRAYS X,Y C IF N = 2 ---> LINEAR INTERPOLATION C NNN NUMBER OF POINTS OF THE CUBIC SPLINE C IF NNN > N ---> NNN = N C IF NNN > 100 ---> NNN = 100 C IF NNN = 2 LINEAR INTERPOLATION ADOPTED. C C IF NNN IS ZERO NNN=7 (ALTERED BY P JUDGE) C (USED TO BE IF NNN OMITTED ) C OUTPUT: SPLIN INTERPOLATED VALUE AT T C INCLUDE 'PREC' DIMENSION X(N), Y(N), S2(100), S3(100), DELY(100), H(100), * H2(100), DELSQY(100), C(100), B(100), XX(100), YY(100) LOGICAL SEARCH, FOUND CHARACTER*4 INIT DATA INIT/'NOTO'/ SAVE C C NN = NUMBER OF POINTS OF THE SPLINE INTERVAL C NN = MIN(7,N) IF (NNN .EQ. 0) GO TO 10 C PGJ IF (%LOC(NNN).EQ.0) GO TO 10 NN = NNN NN = MIN(N,NNN,100) C C IF T IN [X(K)-ERROR,X(K)+ERROR] T = X(K) C 10 ERROR = 1.0E-12 IF (T.NE.0) ERROR = ABS(1.0E-12*T) FOUND = SEARCH(X,T,1,N,K,ERROR) IF (.NOT.FOUND) GOTO 20 SPLIN = Y(K) RETURN 20 IF (N.NE.2.AND.NN.NE.2) GOTO 30 C C IF N=2 OR NNN=2 LINEAR INTERPOLATION IS ADOPTED C SPLIN = (Y(K+1)-Y(K))*(T-X(K))/(X(K+1)-X(K)) + Y(K) RETURN 30 IF (N.NE.1) GOTO 40 SPLIN = Y(1) RETURN C C INTERVAL OF THE SPLINE IS COMPUTED C 40 IOVER = LOG10(FLOAT(NN))*3 INT = (K-IOVER)/(NN-2*IOVER) + 1 I1 = (INT-1)*(NN-2*IOVER) I2 = I1 + NN -1 IF (I1.GE.1) GOTO 50 I2 = NN I1 = 1 50 IF (I2.LE.N) GOTO 60 I2 = N I1 = N - NN + 1 60 ISHIFT = I1 - 1 N1 = NN - 1 C C INITIALIZATION CHECK C IF (INIT.NE.'OKAY') GOTO 80 C C INTERVAL CHECK C DO 70 I=1,NN IF (XX(I).NE.X(I+ISHIFT)) GOTO 90 IF (YY(I).NE.Y(I+ISHIFT)) GOTO 90 70 CONTINUE GOTO 200 80 INIT = 'OKAY' C C START OF THE COMPUTATION OF SPLINE COEFFICIENTS C 90 RMIN = 1.0E37 RMAX = -1.0E37 DO 100 I=1,NN IF (Y(I+ISHIFT).LT.RMIN) RMIN = Y(I+ISHIFT) IF (Y(I+ISHIFT).GT.RMAX) RMAX = Y(I+ISHIFT) 100 CONTINUE C C COMPUTATION OF THE NORM FACTORS XNORM AND YNORM C XNORM = 1/(X(NN+ISHIFT)-X(1+ISHIFT)) YNORM = RMAX - RMIN IF (YNORM.EQ.0) YNORM = RMAX IF (YNORM.EQ.0) YNORM = 1 YNORM = 1 / YNORM DO 110 I=1,N1 H(I) = (X(I+1+ISHIFT)-X(I+ISHIFT))*XNORM DELY(I) = ((Y(I+1+ISHIFT)-Y(I+ISHIFT))/H(I))*YNORM 110 CONTINUE DO 120 I=2,N1 H2(I) = H(I-1) + H(I) B(I) = 0.5*H(I-1)/H2(I) DELSQY(I) = (DELY(I)-DELY(I-1))/H2(I) S2(I) = 2.*DELSQY(I) C(I) = 3.*DELSQY(I) 120 CONTINUE S2(1) = 0 S2(N1+1) = 0 C C SOLUTION OF THE LINEAR SYSTEM OF THE SPLINE COEFFICIENTS C BY SUCCESSIVE OVERRELAXATION. C CONSTANTS: EPS = ERROR CRITERION IN THE ITERATIVE SOLUTION. C OMEGA = RELAXATION COEFFICIENT. C EPSLN = 1.0E-8 OMEGA = 1.0717968 130 ETA = 0. DO 160 I=2,N1 W = (C(I)-B(I)*S2(I-1)-(0.5-B(I))*S2(I+1)-S2(I))*OMEGA IF (ABS(W)-ETA) 150, 150, 140 140 ETA = ABS(W) 150 S2(I) = S2(I) + W 160 CONTINUE IF (ETA-EPSLN) 170, 130, 130 170 DO 180 I=1,N1 S3(I) = (S2(I+1)-S2(I))/H(I) 180 CONTINUE C C X AND Y STORED IN XX AND YY FOR INTERVAL CHECK C DO 190 I=1,NN XX(I) = X(I+ISHIFT) YY(I) = Y(I+ISHIFT) 190 CONTINUE 200 I = K - I1 + 1 HT1 = (T-X(I+ISHIFT))*XNORM HT2 = (T-X(I+ISHIFT+1) )*XNORM IF ((T-X(1))*XNORM.GT.0) GOTO 210 C C EXTRAPOLATION T < X(1) C SPLIN = Y(1) RETURN 210 IF ((T-X(N))*XNORM.GT.0) GOTO 220 C C INTERPOLATION BY MEANS OF THE SPLINE COEFFICIENTS C SS2 = S2(I) + HT1*S3(I) PROD = HT1*HT2 DELSQS = (S2(I)+S2(I+1)+SS2)/6. SPLIN = Y(I+ISHIFT) + (HT1*DELY(I)+PROD*DELSQS)/YNORM RETURN C C EXTRAPOLATION T > X(N) C 220 SPLIN = Y(N) RETURN END C C ********************************************************************** C LOGICAL FUNCTION SEARCH(ARR,X,IA,IB,K,ERR) C C * SEARCHES THE POINT X WITHIN AN ERROR BOUND -ERR- IN ARRAY ARR * C * IF THAT POINT IS NOT FOUND, IT GIVES THE * C * INTERVAL IN THE ARRAY, WHERE THAT POINT FITS. * C * THE INTERVAL K IF X IN [ARR(K),ARR(K+1)), INTERVAL 1 IF X IN * C * (-INF,ARR(2)), INTERVAL N-1 IF X IN [ARR(N-1),INF)-(ARR INCREASING)* C * INTERVAL 1 IF X IN (INF,ARR(2)),INTERVAL N-1 IF X IN [ARR(N-1), * C * -INF)-(ARR DECREASING) * C * IN THE WORST CASE A SEARCH COSTS 2*LOG2(N) CYCLES. * C * THIS ROUTINE IS VERY ECONOMIC, WHEN IN A SEQUENCE OF SEARCHES, * C * THE DIFFERENCES BETWEEN THE POINTS WHICH ARE TO BE SEARCHED ARE * C * SMALL. * C * FOR EXAMPLE: A SEQUENCE OF SEARCHES WHICH GOES ALONG THE ARRAY, * C * OR A SEQUENCE OF SEARCHES WHICH REMAINS IN A SMALL AREA OF * C * THE ARRAY. * C * * C * INPUT: - ARR ARRAY WITH A NON DECREASING OR A NON * C * INCREASING FUCNTION. * C * - IA,IB LOWER AND UPPER LIMIT OF THE ARRAY WITHIN * C * IS SEARCHED. * C * - X VALUE WHICH YOU WANT TO SEARCH * C * - K LAST INDEX WHICH WAS FOUND * C * SEARCH * C * - ERR ERROR BOUND * C * * C * OUTPUT: - K INDEX OF THE POINT OR INTERVAL OF THE * C * ARRAY WHICH IS FOUND. * C * - SEARCH TRUE - X IS FOUND WITHIN THE ERRORBOUND * C * -ERR- * C * FALSE - X IS NOT FOUND. * C * * C * SEND IN BY E.V.D.ZALM, UTRECHT, STERREWACHT, MARCH 24TH 1981 * C ********************************************************************** INCLUDE 'PREC' DIMENSION ARR(IB) C ONE=1.0 SEARCH = .TRUE. IF (ARR(IB)-ARR(IA).LT.0.0) GOTO 100 5 IF (X.LT.ARR(IA).OR.X.GT.ARR(IB)) GOTO 25 IF (K.LT.IA.OR.K.GT.IB-1) GOTO 25 L = K IP = SIGN(ONE,X-ARR(K)) IF (IP.LT.0.) GOTO 20 10 L = MIN(K+IP,IB) IF (ARR(L).GE.X) GOTO 30 IP = IP * 2 K = L GOTO 10 20 K = MAX(L+IP,IA) IF (ARR(K).LE.X) GOTO 30 IP = IP * 2 L = K GOTO 20 25 K = IA L = IB 30 IF ((L-K).LE.1) GOTO 50 I = INT((K+L)/2.) IF (ARR(I).GE.X) GOTO 40 K = I GOTO 30 40 L = I GOTO 30 100 IF (X.LT.ARR(IB).OR.X.GT.ARR(IA)) GOTO 250 IF (K.LT.IA.OR.K.GT.IB-1) GOTO 250 L = K IP = SIGN(ONE,ARR(K)-X) IF (IP.LT.0.) GOTO 200 110 L = MIN(K+IP,IB) IF (ARR(L).LE.X) GOTO 300 IP = IP * 2 K = L GOTO 110 200 K = MAX(L+IP,IA) IF (ARR(K).GE.X) GOTO 300 IP = IP * 2 L = K GOTO 200 250 K = IA L = IB 300 IF ((L-K).LE.1) GOTO 50 I = INT((K+L)/2.) IF (ARR(I).LE.X) GOTO 400 K = I GOTO 300 400 L = I GOTO 300 50 IF (ABS(X-ARR(K)).LE.ERR) RETURN IF (ABS(X-ARR(L)).GT.ERR) GOTO 60 K = L RETURN 60 SEARCH = .FALSE. RETURN END C C*********************************************************************** C FUNCTION SEMIC(Z,EUP,ELO,FEM,TEMP,IFLAG) C C RETURNS COLLISION RATE DOWNWARDS USING SEMI-EMPIRICAL GF'S C C P.G. JUDGE, NOVEMBER 1987. C C INPUT: C Z - CHARGE OF ION+1 (E.G. FOR C II Z=2) C EUP - ENERGY OF UPPER LEVEL IN CM-1 C ELO - ENERGY OF LOWER LEVEL IN CM-1 C FEM - EMISSION OSCILLATOR STRENGTH ( = GF/G(UPPER)) C TEMP - TEMPERATURE IN DEGREES KELVIN C C OUTPUT: C IFLAG - = 1 FOR VAN REGEMORTER APPROXIMATION C IFLAG - = 2 FOR SHEVELKO APPROXIMATION C SEMIC - DOWNWARD COLLISION RATE IN CM3 /S C INCLUDE 'PREC' INTEGER Z DATA C1,RY /1.43882,109737.312/ C C INITIALIZE C DELTE=EUP-ELO BETA=DELTE*C1/TEMP SEMIC=0.0 C C IFLAG=1 => VAN REGEMORTER APPROXN. C IF(BETA .GE. 0.01)THEN IFLAG=1 SEMIC = 3.2E-7*FEM*(RY/DELTE)**1.5*SQRT(BETA)*PSEMI(Z,BETA) C C IFLAG=2 => SHEVELKO APPROX (TM : 0.01 == 0.01 eV à 12000 K) C ELSE IF(BETA .LT. 0.01)THEN IFLAG=2 SEMIC=1.74E-07*FEM*EXP(BETA)/SQRT(BETA*DELTE/RY) + *LOG( ELO / DELTE * SQRT(RY / C1 / TEMP)) ENDIF C RETURN END C C ********************************************************************** C FUNCTION PSEMI(Z,B) C C THERMAL P-FUNCTION FOR SEMIC EMPIRICAL COLLISION RATES C REFERENCE: SOBEL'MAN - 'ATOMIC PHYSICS II. ' C C: C: PSEMI 94-08-29 MODIFICATIONS: (MATS CARLSSON) C: MULTIPLE RETURN CHANGED TO SINGLE RETURN TO AVOID C: COMPILER BUG IN DIGITAL FORTRAN C: INCLUDE 'PREC' PARAMETER (N1=10) DIMENSION BETREF(N1),PNREF(N1),PCREF(N1) INTEGER Z DATA BETREF/-2.0,-1.699,-1.398,-1.0,-0.699,-0.398,0.0 + ,0.301,0.602,1.0/ DATA PNREF/1.160,0.956,0.758,0.493,0.331,0.209 + ,0.100,0.063,0.040,0.023/ DATA PCREF/1.160,0.977,0.788,0.554,0.403 + ,0.290,0.214,0.201,0.200,0.200/ C C LIMIT OF HIGH TEMPERATURE: KT >> E C IF (B .LT. 0.01)THEN PSEMI = 0.27566 * (0.577 + LOG(B)) C C INTERMEDIATE TEMPS (MOST IMPORTANT FOR EQM PLASMAS) C SPLINE INTERPOLATION ONTO LOGB GRID: C ELSE IF(B .GT. 0.01 .AND. B .LT. 10.0)THEN BB=LOG10(B) IF (Z .EQ. 1) PSEMI = SPLIN(BB,BETREF,PNREF,N1,N1) IF (Z .GT. 1) PSEMI = SPLIN(BB,BETREF,PCREF,N1,N1) C C LIMIT OF LOW TEMPERATURE: KT << E C ELSE IF(B .GT. 10.0)THEN IF(Z .EQ. 1) PSEMI = 0.066 / SQRT(B) IF(Z .GT. 1) PSEMI = 0.200 ENDIF RETURN END C C ********************************************************************** C SUBROUTINE CORONR(CEL,ION,TEMP,PRESS,RRATE,RIRATE) C C CORONAL ION BALANCE CALCULATION C NEW ROUTINE FOR USE WITH V2.0 OPACITY PACKAGE AND GENCOL C C INPUT: ELEMENT IDENTIFIER CEL (CHARACTER) C ION STAGE IDENTIFIER ION (INTEGER) C TEMP (ELECTRON TEMPERATURE IN K (RL) C PRESS (ELECTRON PRESSURE IN DYNE/CM2) (RL) C C OUTPUT: RRATE RECOMBINATION RATE (CM3/S) C RIRATE IONIZATION RATE (CM3/S) C C EXAMPLE: C CEL='C ', ION=1, WILL RETURN C THE RECOMBINATION RATE PER C II ATOM PER ELECTRON C AND THE IONIZATION RATE PER C I ATOM PER ELECTRON C C NOTES: C COMPUTATIONS FROM TABLES OF SHULL & VAN STEENBERG, C AP J SUPPL 48 P95 C NO PE-DEPENDENCE, THIS COULD BE ADDED WHEN COMPUTATIONS BECOME C AVAILABLE C IF THE ION FRACTION IS NOT FOUND THEN THE ROUTINE WILL STOP C C 89-03-28 NEW ROUTINE (PHILIP JUDGE) C C: CORONR 92-08-10 MODIFICATIONS: (MATS CARLSSON) C: INTEGER ARRAYS WITH ELEMENT NAME CHANGED TO CHARACTER ARRAYS C: C: 92-09-09 MODIFICATIONS: (MATS CARLSSON) C: INTEGER IEL IN WRITE STATEMENT CHANGED TO CHARACTER C: C: 95-09-06 MODIFICATIONS: (MATS CARLSSON) C: COMMON BLOCK CLU CHANGED TO INCLUDE FILE C: INCLUDE 'PREC' INCLUDE 'CLU' C PARAMETER (MCOR=30) INTEGER NCOR,IONCOR(MCOR) DOUBLE PRECISION ARADC(MCOR),XRADC(MCOR),ADIC(MCOR),T0C(MCOR), * BDIC(MCOR),T1C(MCOR),ACOLC(MCOR),TCOLC(MCOR),TECOR,DECOR COMMON /CCORON/ TECOR,DECOR, * ARADC,XRADC,ADIC,T0C,BDIC,T1C,ACOLC,TCOLC,NCOR,IONCOR CHARACTER*3 CCOR COMMON /CCCOR/ CCOR(MCOR) CHARACTER*(*) CEL C C IDENTIFY THE ELEMENT AND IONIZATION STAGE TO BE COMPUTED C DO 100 N=1,NCOR IF( CEL .EQ. CCOR(N) .AND. ION .EQ. IONCOR(N) )GOTO 99 100 CONTINUE WRITE(LJOBLO,1024) CEL,ION 1024 FORMAT(' CORONR: SPECIES',A3,I3,' NOT FOUND IN ABSDAT FILE') CALL STOP(' ') C C ELEMENT HAS BEEN COMPUTED- NOW RETURN THE RATES C 99 RRATE=ARADC(N)*(TEMP/1.E4)**(-XRADC(N)) + * ADIC(N) * (TEMP**(-1.5)) * EXP(-T0C(N)/TEMP)* * (1.E0+BDIC(N) * (EXP(- T1C(N)/TEMP))) RIRATE=ACOLC(N) * SQRT(TEMP) * EXP( -TCOLC(N) / TEMP) * / (1.E0 + 0.1 * TEMP / TCOLC(N)) RETURN END C C****************************************************************************** C SUBROUTINE RDALP C C READS POPULATIONS FROM RSTRT C AS INITIA WITH ISTART=-1 AND LMAX=0 C: C: RDALP 92-09-24 NEW ROUTINE: (MATS CARLSSON) C: READS RSTRT C: INCLUDE 'PREC' INCLUDE 'PARAM' INCLUDE 'CATOM' INCLUDE 'CATMOS' INCLUDE 'CSLINE' INCLUDE 'CINPUT' INCLUDE 'CCONST' INCLUDE 'CLU' C PARAMETER (INDEP=200) DIMENSION DPIN(INDEP),ANIN(MK,INDEP),DP(MDEP) CHARACTER*80 TEXT C C READ HELIUM POPULATIONS FROM FILE RSTRT C CSTRIP CAN NOT BE USED BECAUSE FILE DUMS IS BEING READ BY GENCOL C CALL OPEN(LRSTRT,'RSTRT',1,'OLD') CALL OPEN(LDUMS2,'DUMS2',1,'UNKNOWN') 50 CONTINUE READ(LRSTRT,100,END=90) TEXT IF(TEXT(1:1).NE.'*') WRITE(LDUMS2,100) TEXT GOTO 50 90 CONTINUE CALL CLOSE(LRSTRT) CALL REWIND(LDUMS2) READ(LDUMS2,100,END=900) ATMOID 100 FORMAT(A) READ(LDUMS2,100) TEXT CALL LJUST(TEXT) IF(DPTYPE.NE.TEXT(1:1)) THEN CALL STOP('RDALP: DIFFERENT SCALE TYPES IN DSCALE AND RSTRT') ENDIF READ(LDUMS2,*) GDUM READ(LDUMS2,*) KDEP IF(KDEP.GT.INDEP) CALL STOP('RDALP:KDEP.GT.INDEP') READ(LDUMS2,*) (DPIN(K),DUM,DUM,DUM,DUM,K=1,KDEP) READ(LDUMS2,*) ((ANIN(I,K),I=1,NK),K=1,KDEP) C C STORE DEPTH-GRID USED IN DP C IF(DPTYPE.EQ.'M') THEN DO 110 K=1,NDEP DP(K)=LOG10(CMASS(K)) 110 CONTINUE ELSE IF(DPTYPE.EQ.'T') THEN DO 120 K=1,NDEP DP(K)=LOG10(TAU(K)) 120 CONTINUE ELSE CALL STOP('RDALP: DPTYPE NOT IMPLEMENTED YET') ENDIF C C INTERPOLATE START APPROXIMATION TO DEPTH-GRID USED, C LINEAR INTERPOLATION IN THE LOG OF THE POPULATION NUMBERS C C TAKE THE LOG OF THE INPUT POPULATION NUMBERS C DO 140 K=1,KDEP DO 130 I=1,NK ANIN(I,K)=LOG(ANIN(I,K)) 130 CONTINUE 140 CONTINUE C IF(DPIN(1).GT.DP(1)) WRITE(LOUT,150) DPIN(1),DP(1) 150 FORMAT(' EXTRAPOLATION IN MIN DEPTH, DPIN=',F13.7,' DP=',F13.7) IF(DPIN(KDEP).LT.DP(NDEP)) WRITE(LOUT,160) DPIN(KDEP),DP(NDEP) 160 FORMAT(' EXTRAPOLATION IN MAX DEPTH, DPIN=',F13.7,' DP=',F13.7) L=1 DO 200 K=1,NDEP 170 L=L+1 IF(DP(K).GT.DPIN(L) .AND. L.LT.KDEP) GOTO 170 APOL=(DP(K)-DPIN(L-1))/(DPIN(L)-DPIN(L-1)) DO 180 I=1,NK N(I,K)=EXP(ANIN(I,L-1)+APOL*(ANIN(I,L)-ANIN(I,L-1))) 180 CONTINUE L=L-1 200 CONTINUE C RETURN 900 CALL STOP('RDALP: RSTRT NOT EXISTING') END C C********************************************************************* C SUBROUTINE HEPOP(T,TOTH,HE1,HE2,HE3) INCLUDE 'PREC' C C RATIOS OF HELIUM IONIZATION FRACTIONS FROM TABLE IV OF ARNAUD AND ROTHENFLUG C ABHE IS ABUNDANCE OF HELIUM - ASSUMED = 0.1 C PARAMETER(NT=19) DIMENSION TT(NT),ONE(NT),TWO(NT) DATA TT /3.50, 4.00, 4.10, 4.20, 4.30, 4.40, 4.50, 4.60, * 4.70, 4.80, 4.90, * 5.00, 5.10, 5.20, 5.30, 5.40, 5.50, 5.60, 5.70/ DATA ONE /0.0, 0.0 ,0.0 ,0.0 ,0.0 ,-0.07,-0.51,-1.33,-2.07, * -2.63,-3.20,-3.94,-4.67,-5.32,-5.90,-6.42, * -6.90,-7.33,-7.73/ DATA TWO /-20.0,-9.05,-6.10,-3.75,-2.12,-0.84,-0.16, * -0.02,-0.01,-0.05,-0.34,-0.96,-1.60,-2.16,-2.63, * -3.03,-3.38,-3.68,-3.94/ ABHE=0.1 TLOG=LOG10(T) F1=10.**(SPLIN(TLOG,TT,ONE,NT,NT)) F2=10.**(SPLIN(TLOG,TT,TWO,NT,NT)) HE1=TOTH*ABHE*F1 HE2=TOTH*ABHE*F2 ALFA=1.-F1-F2 IF(ALFA .LT. 0.) THEN ALFA=1.E-30 ALFA=TOTH*ABHE*ALFA RETURN END C C********************************************************************* C SUBROUTINE AR85CEA(ILO,IHI,CEA) C C NEW ROUTINE FOR COMPUTING COLLISIONAL AUTOIONIZATION C RATES USING FORMALISM AND FORMULAE FROM ARNAUD AND ROTHENFLUG 1985 C C C: AR85CEA 94-02-22 NEW ROUTINE: (PHILIP JUDGE) C: C: 96-03-07 MODIFICATIONS: (PHILIP JUDGE) C: BUG FIXED: CUP INITIALIZED TO ZERO C: INCLUDE 'PREC' INCLUDE 'PARAM' INCLUDE 'CATOM' INCLUDE 'CATMOS' INCLUDE 'CCONST' INCLUDE 'CLU' DIMENSION CEA(MDEP) CHARACTER*2 CSEQ, ARELEM, ATOMNM LOGICAL DEBUG DATA DEBUG /.FALSE./ C C INITIALIZE OUTPUT TO ZERO C C 96-03-07 BUG FIX BEGIN CUP=0.0 C 96-03-07 BUG FIX END DO 2 K=1,NDEP CEA(K)=0.0 2 CONTINUE C C C FIND ELEMENT C ARELEM = ATOMID(1:2) IZ=IATOMN(ARELEM) ZZ=0.0 + IZ IF (IZ .LT. 1 .OR. IZ .GT. 92) THEN WRITE(LJOBLO,*)'AR85-CEA: ATOMIC NUMBER = ',IZ, ' FOR ',ARELEM WRITE(LJOBLO,*)'AR85-CEA: NO AUTOIONIZATION INCLUDED' RETURN ELSE IF(DEBUG) THEN WRITE(LJOBLO,*)'AR85-CEA: ',ARELEM, ' CHARGE ',ION(ILO)-1 ENDIF C C FIND ISO-ELECTRONIC SEQUENCE C ICHRGE=ION(ILO)-1 ISOSEQ=IZ-ICHRGE CSEQ=ATOMNM(ISOSEQ) DO 1 K=1, NDEP BKT=BK*TEMP(K)/EE C C********************************************************************* C LITHIUM SEQUENCE C********************************************************************* C IF (CSEQ .EQ. 'LI') THEN CEAB=1. / (1. + 2.E-4*ZZ*ZZ*ZZ) CEAZEFF=(ZZ-1.3) CEAIEA=13.6*((ZZ-0.835)*(ZZ-0.835) - 0.25*(ZZ-1.62)* * (ZZ-1.62)) Y=CEAIEA/BKT F1Y=FONE(Y) CPREPRINT CUP= 8.0E+10 * CEAB /CEAZEFF/CEAZEFF/SQRT(BKT) CPREPRINT * * EXP(-Y)*(2.22*F1Y+0.67*(1.-Y*F1Y)+0.49*Y*F1Y+1.2*(Y-F1Y)) CUP=1.60E-07*1.2*CEAB/CEAZEFF/CEAZEFF/SQRT(BKT)*EXP(-Y)* * (2.22*F1Y+0.67*(1.-Y*F1Y)+0.49*Y*F1Y+1.2*Y*(1.-Y*F1Y)) C C TWO SPECIAL CASES: C C C IV - APP A AR85 IF(ARELEM .EQ. 'C ') CUP = CUP*0.6 C N V - APP A AR85 IF(ARELEM .EQ. 'N ') CUP = CUP*0.8 C O VI - APP A AR85 IF(ARELEM .EQ. 'O ') CUP = CUP*1.25 C C********************************************************************* C SODIUM SEQUENCE C********************************************************************* C ELSE IF (CSEQ .EQ. 'NA') THEN IF (IZ .LE. 16) THEN CEAA=2.8E-17*(ZZ-11.)**(-0.7) CEAIEA=26.*(ZZ-10.) Y=CEAIEA/BKT F1Y=FONE(Y) CUP= 6.69E+7 * CEAA *CEAIEA/SQRT(BKT) * EXP(-Y)*(1. - Y*F1Y) ELSE IF (IZ .GE. 18 .AND. IZ .LE. 28) THEN CEAA=1.3E-14*(ZZ-10.)**(-3.73) CEAIEA=11.*(ZZ-10.)*SQRT(ZZ-10.) Y=CEAIEA/BKT F1Y=FONE(Y) CUP= 6.69E+7 * CEAA *CEAIEA/SQRT(BKT) * EXP(-Y) * *(1. - 0.5*(Y -Y*Y + Y*Y*Y*F1Y)) ELSE RETURN ENDIF ENDIF C C********************************************************************* C MAGNESIUM-SULFUR SEQUENCES C********************************************************************* C IF(CSEQ .EQ. 'MG' .OR. CSEQ .EQ. 'AL' * .OR. CSEQ .EQ. 'SI' .OR. * CSEQ .EQ. 'P ' .OR. CSEQ .EQ. 'S ') THEN IF(CSEQ .EQ. 'MG') CEAIEA=10.3*(ZZ-10.)**1.52 IF(CSEQ .EQ. 'AL') CEAIEA=18.0*(ZZ-11.)**1.33 IF(CSEQ .EQ. 'SI') CEAIEA=18.4*(ZZ-12.)**1.36 IF(CSEQ .EQ. 'P ' ) CEAIEA=23.7*(ZZ-13.)**1.29 IF(CSEQ .EQ. 'S ' ) CEAIEA=40.1*(ZZ-14.)**1.1 CEAA=4.0E-13/ZZ/ZZ/CEAIEA Y=CEAIEA/BKT F1Y=FONE(Y) CUP= 6.69E+7 * CEAA *CEAIEA/SQRT(BKT) * EXP(-Y) * *(1. - 0.5*(Y -Y*Y + Y*Y*Y*F1Y)) ENDIF C C C********************************************************************* C SPECIAL CASES C********************************************************************* C C IF(ARELEM .EQ. 'CA' .AND. (ICHRGE .EQ. 0)) THEN CEAA = 9.8E-17 CEAIEA= 25. CEAB=1.12 CUP=6.69E+7*CEAA *CEAIEA/SQRT(BKT) * EXP(-Y)*(1. + CEAB*F1Y) WRITE(LJOBLO,*)'AR85-CEA SPECIAL CASE ',ARELEM, * ' ION ICHRGE ',ICHRGE ELSE IF(ARELEM .EQ. 'CA' .AND. (ICHRGE .EQ. 1)) THEN CEAA = 6.0E-17 CEAIEA= 25. CEAB=1.12 CUP=6.69E+7*CEAA *CEAIEA/SQRT(BKT) * EXP(-Y)*(1. + CEAB*F1Y) ELSE IF(ARELEM .EQ. 'FE' .AND. (ICHRGE .EQ. 3)) THEN CEAA = 1.8E-17 CEAIEA= 60. CEAB=1.0 CUP=6.69E+7*CEAA *CEAIEA/SQRT(BKT) * EXP(-Y)*(1. + CEAB*F1Y) ELSE IF(ARELEM .EQ. 'FE' .AND. (ICHRGE .EQ. 4)) THEN CEAA = 5.0E-17 CEAIEA= 73. CEAB=1.0 CUP=6.69E+7*CEAA *CEAIEA/SQRT(BKT) * EXP(-Y)*(1. + CEAB*F1Y) ENDIF CEA(K)=CUP 1 CONTINUE RETURN END C C********************************************************************* C INTEGER FUNCTION IATOMN(STRING) C C ATOMN 94-02-22 NEW ROUTINE: (PHILIP JUDGE) C GIVES ATOMIC NUMBER OF ARELEMENT IF STRING IS A STRING CONTAINING C THE NAME OF THE ARELEMENT, E.G. IF INPUT IS 'H ' IT WILL RETURN 1 C PARAMETER (NDATA=28) CHARACTER*2 ARELEM(NDATA) CHARACTER *(*) STRING DATA ARELEM /'H ','HE','LI','BE','B ','C ','N ','O ','F ','NE', * 'NA','MG','AL','SI','P ','S ','CL','AR', * 'K ','CA','SC','TI','V ','CR','MN','FE','CO','NI'/ IATOMN=-1 DO 1 I=1,NDATA IF(STRING .EQ. ARELEM(I)) THEN IATOMN=I RETURN ENDIF 1 CONTINUE END C C********************************************************************* C CHARACTER*2 FUNCTION ATOMNM(I) C C ATOMNM 94-02-22 NEW ROUTINE: (PHILIP JUDGE) C GIVES ATOMIC NAME OF ARELEMENT IF I IS AN INTEGER CONTAINING C E.G. IF INPUT IS 'H ' IT WILL RETURN 1, 'HE', IT WILL RETURN 2, ETC. C PARAMETER (NDATA=28) CHARACTER*2 ARELEM(NDATA) DATA ARELEM /'H ','HE','LI','BE','B ','C ','N ','O ','F ','NE', * 'NA','MG','AL','SI','P ','S ','CL','AR', * 'K ','CA','SC','TI','V ','CR','MN','FE','CO','NI'/ IF(I .LE. NDATA .AND. I .GE. 1) THEN ATOMNM= ARELEM(I) ELSE ATOMNM=' ' ENDIF RETURN END C C*********************************************************************** C FUNCTION FONE(X) C C NEW ROUTINE 24-JAN-1994 C CALCULATES F1(X) NEEDED FOR COLLISIONAL RATES OF ARNAUD AND ROTHENFLUG C MODIFIED BY P. JUDGE 15-MAR-1994 C FOR LARGE VALUES OF X, USE ASYMPTOTIC LIMIT C INCLUDE 'PREC' DATA SPLIT /50.0/ IF(X .LE. SPLIT) THEN FONE = EXP(X)*EXPINT(1,X,EX) ELSE FONE= 1./X ENDIF RETURN END C C********************************************************************** C FUNCTION FTWO(X) C C NEW ROUTINE 24-JAN-1994 P. JUDGE C CALCULATES F2(X) NEEDED FOR COLLISIONAL RATES OF ARNAUD AND ROTHENFLUG C IF ARGUMENT X IS < BREAK, THEN USE THE EQNS 5 AND 6 OF HUMMER (1983, JQSRT, 30 281) C BREAK GIVEN BY HUMMER AS 4.0 C C NOTE THAT THE SUGGESTED POLYNOMIAL EXPANSION OF ARNAUD AND ROTHENFLUG C FAILS FOR ARGUMENTS < BREAK- SEE HUMMER'S ORIGINAL PAPER. C IT IS UNCLEAR IF THE TABULATED IONIZATION FRACTIONS OF ARNAUD AND ROTHENFLUG C CONTAIN THIS ERROR. C INCLUDE 'PREC' INCLUDE 'CCONST' DIMENSION P(15), Q(15) DATA BREAK /4.0/ DATA P /1.0,2.1658E+02,2.0336E+04,1.0911E+06,3.7114E+07, * 8.3963E+08,1.2889E+10,1.3449E+11,9.4002E+11,4.2571E+12, * 1.1743E+13,1.7549E+13,1.0806E+13,4.9776E+11,0.0000/, * Q /1.0,2.1958E+02,2.0984E+04,1.1517E+06,4.0349E+07, * 9.4900E+08,1.5345E+10,1.7182E+11,1.3249E+12,6.9071E+12, * 2.3531E+13,4.9432E+13,5.7760E+13,3.0225E+13, 3.3641E+12/ IF(X .GE. BREAK) THEN PX=P(1) XFACT=1.0 DO 1 I=2,15 XFACT = XFACT/X PX=PX+ P(I)*XFACT 1 CONTINUE C PX = P(1) + XI*(P(2) + (XI*P(3) +(XI*P(4) + (XI*P(5) + (XI*P(6) C * + (XI*P(7) + (XI*P(8) +(XI*P(9) + (XI*P(10) + (XI*P(11) + C * (XI*P(12) + (XI*P(13) +(XI*P(14)+XI*P(15)))))))))))))) C QX = Q(1) + XI*(Q(2) + (XI*Q(3) +(XI*Q(4) + (XI*Q(5) + (XI*Q(6) C * + (XI*Q(7) + (XI*Q(8) +(XI*Q(9) + (XI*Q(10) + (XI*Q(11) + C * (XI*Q(12) + (XI*Q(13) +(XI*Q(14)+XI*Q(15)))))))))))))) QX=Q(1) XFACT=1.0 DO 2 I=2,15 XFACT = XFACT/X QX=QX+ Q(I)*XFACT 2 CONTINUE FTWO=PX/QX/X/X ELSE C C HUMMER'S EQUNS 5 AND 6 C GAMMA IS EULER'S CONSTANT (ABRAMOVICZ+STEGUN) C GAMMA=0.5772156649 F0X = PI*PI/12. TERM=1.0 COUNT=0.0 FACT=1.0 XFACT=1.0 DO WHILE (ABS(TERM/F0X) .GT. 1.E-8) COUNT=COUNT+1.0 FACT = FACT*COUNT XFACT=XFACT*(-X) TERM = XFACT/COUNT/COUNT/FACT F0X=F0X+TERM IF(COUNT .GT. 100.) CALL STOP('FTWO: TOO MANY ITERATIONS') ENDDO FTWO=EXP(X)*((LOG(X)+GAMMA)*(LOG(X)+GAMMA)*0.5 + F0X) ENDIF RETURN END FUNCTION SUMMERS(ILO,IHI,EDENS) C C NEW ROUTINE FOR COMPUTING COLLISIONAL REDUCTION OF DIELECTRONIC C RECOMBINATION RATE BY ELECTRON COLLISIONS FOLLOWING SUMMERS 1974 C Inputs: C ILO - index of lower level of transition C IHI - index of upper level of transition C EDENS - electron density in /cm3 C SUMMERS 94-11-09 NEW ROUTINE: (PHILIP JUDGE) C INCLUDE 'PREC' INCLUDE 'PARAM' INCLUDE 'CATOM' INCLUDE 'CATMOS' INCLUDE 'CCONST' INCLUDE 'CLU' CHARACTER*2 CSEQ, ARELEM, ATOMNM LOGICAL DEBUG DATA DEBUG /.FALSE./ SUMMERS=1.0 C C C FIND ELEMENT C ARELEM = ATOMID(1:2) IZ=IATOMN(ARELEM) ZZ=0.0 + IZ IF (IZ .LT. 1 .OR. IZ .GT. 92) THEN WRITE(LJOBLO,*)'SUMMERS: ATOMIC NUMBER = ',IZ, ' FOR ',ARELEM WRITE(LJOBLO,*)'SUMMERS: NO DENSITY EFFECTS IN DIEL RATE' RETURN ELSE IF(DEBUG) THEN WRITE(LJOBLO,*)'SUMMERS: ',ARELEM, ' CHARGE ',ION(ILO) ENDIF C C FIND ISO-ELECTRONIC SEQUENCE OF RECOMBINING ION C ICHRGE=ION(ILO) ZZ=FLOAT(ICHRGE) ISOSEQ=IZ-ICHRGE CSEQ=ATOMNM(ISOSEQ) C C********************************************************************* C LITHIUM, SODIUM, POTASSIUM SEQUENCES C********************************************************************* C RHO0=2000.0 IF (CSEQ .EQ. 'LI' .OR. CSEQ .EQ. 'NA' .OR. * CSEQ .EQ. 'K') RHO0=30.0 RHOQ=EDENS/ZZ/ZZ/ZZ/ZZ/ZZ/ZZ/ZZ SUMMERS=1. / (1.+ RHOQ/RHO0)**0.14 IF(DEBUG) THEN WRITE(LJOBLO,*)'SUMMERS: ',LABEL(IHI),' -> ', * LABEL(ILO), ' SEQUENCE =', CSEQ WRITE(LJOBLO,*)'SUMMERS: DENSITY FACTOR = ',SUMMERS, * ' NE = ', EDENS, 'RHO0=',RHO0 ENDIF RETURN END C********************************************************************* SUBROUTINE TAUTSP ( TAU, GTAU, NTAU, GAMMA, S, * BREAK, COEF, L, K, IFLAG ) INCLUDE 'PREC' C FROM * A PRACTICAL GUIDE TO SPLINES * BY C. DE BOOR CONSTRUCTS CUBIC SPLINE INTERPOLANT TO GIVEN DATA C TAU(I), GTAU(I), I=1,...,NTAU. C IF GAMMA .GT. 0., ADDITIONAL KNOTS ARE INTRODUCED WHERE NEEDED TO C MAKE THE INTERPOLANT MORE FLEXIBLE LOCALLY. THIS AVOIDS EXTRANEOUS C INFLECTION POINTS TYPICAL OF CUBIC SPLINE INTERPOLATION AT KNOTS TO C RAPIDLY CHANGING DATA. C C PARAMETERS C INPUT C TAU SEQUENCE OF DATA POINTS. MUST BE STRICTLY INCREASING. C GTAU CORRESPONDING SEQUENCE OF FUNCTION VALUES. C NTAU NUMBER OF DATA POINTS. MUST BE AT LEAST 4 . C GAMMA INDICATES WHETHER ADDITIONAL FLEXIBILITY IS DESIRED. C = 0., NO ADDITIONAL KNOTS C IN (0.,3.), UNDER CERTAIN CONDITIONS ON THE GIVEN DATA AT C POINTS I-1, I, I+1, AND I+2, A KNOT IS ADDED IN THE C I-TH INTERVAL, I=2,...,NTAU-2. SEE DESCRIPTION OF METH- C OD BELOW. THE INTERPOLANT GETS ROUNDED WITH INCREASING C GAMMA. A VALUE OF 2.5 FOR GAMMA IS TYPICAL. C IN (3.,6.), SAME , EXCEPT THAT KNOTS MIGHT ALSO BE ADDED IN C INTERVALS IN WHICH AN INFLECTION POINT WOULD BE PERMIT- C TED. A VALUE OF 5.5 FOR GAMMA IS TYPICAL. C OUTPUT C BREAK, COEF, L, K GIVE THE PP-REPRESENTATION OF THE INTERPOLANT. C SPECIFICALLY, FOR BREAK(I) .LE. X .LE. BREAK(I+1), THE C INTERPOLANT HAS THE FORM C F(X) = COEF(1,I) +DX(COEF(2,I) +(DX/2)(COEF(3,I) +(DX/3)COEF(4,I))) C WITH DX = X - BREAK(I) AND I=1,...,L . C IFLAG = 1, OK C = 2, INPUT WAS INCORRECT. A PRINTOUT SPECIFYING THE MISTAKE C WAS MADE. C WORKSPACE C S IS REQUIRED, OF SIZE (NTAU,6). THE INDIVIDUAL COLUMNS OF THIS C ARRAY CONTAIN THE FOLLOWING QUANTITIES MENTIONED IN THE WRITE- C UP AND BELOW. C S(.,1) = DTAU = TAU(.+1) - TAU C S(.,2) = DIAG = DIAGONAL IN LINEAR SYSTEM C S(.,3) = U = UPPER DIAGONAL IN LINEAR SYSTEM C S(.,4) = R = RIGHT SIDE FOR LINEAR SYSTEM (INITIALLY) C = FSECND = SOLUTION OF LINEAR SYSTEM , NAMELY THE SECOND C DERIVATIVES OF INTERPOLANT AT TAU C S(.,5) = Z = INDICATOR OF ADDITIONAL KNOTS C S(.,6) = 1/HSECND(1,X) WITH X = Z OR = 1-Z. SEE BELOW. C C ------ M E T H O D ------ C ON THE I-TH INTERVAL, (TAU(I), TAU(I+1)), THE INTERPOLANT IS OF THE C FORM C (*) F(U(X)) = A + B*U + C*H(U,Z) + D*H(1-U,1-Z) , C WITH U = U(X) = (X - TAU(I))/DTAU(I). HERE, C Z = Z(I) = ADDG(I+1)/(ADDG(I) + ADDG(I+1)) C (= .5, IN CASE THE DENOMINATOR VANISHES). WITH C ADDG(J) = ABS(DDG(J)), DDG(J) = DG(J+1) - DG(J), C DG(J) = DIVDIF(J) = (GTAU(J+1) - GTAU(J))/DTAU(J) C AND C H(U,Z) = ALPHA*U**3 + (1 - ALPHA)*(MAX(((U-ZETA)/(1-ZETA)),0)**3 C WITH C ALPHA(Z) = (1-GAMMA/3)/ZETA C ZETA(Z) = 1 - GAMMA*MIN((1 - Z), 1/3) C THUS, FOR 1/3 .LE. Z .LE. 2/3, F IS JUST A CUBIC POLYNOMIAL ON C THE INTERVAL I. OTHERWISE, IT HAS ONE ADDITIONAL KNOT, AT C TAU(I) + ZETA*DTAU(I) . C AS Z APPROACHES 1, H(.,Z) HAS AN INCREASINGLY SHARP BEND NEAR 1, C THUS ALLOWING F TO TURN RAPIDLY NEAR THE ADDITIONAL KNOT. C IN TERMS OF F(J) = GTAU(J) AND C FSECND(J) = 2.DERIVATIVE OF F AT TAU(J), C THE COEFFICIENTS FOR (*) ARE GIVEN AS C A = F(I) - D C B = (F(I+1) - F(I)) - (C - D) C C = FSECND(I+1)*DTAU(I)**2/HSECND(1,Z) C D = FSECND(I)*DTAU(I)**2/HSECND(1,1-Z) C HENCE CAN BE COMPUTED ONCE FSECND(I),I=1,...,NTAU, IS FIXED. C F IS AUTOMATICALLY CONTINUOUS AND HAS A CONTINUOUS SECOND DERIVAT- C IVE (EXCEPT WHEN Z = 0 OR 1 FOR SOME I). WE DETERMINE FSCND(.) FROM C THE REQUIREMENT THAT ALSO THE FIRST DERIVATIVE OF F BE CONTIN- C UOUS. IN ADDITION, WE REQUIRE THAT THE THIRD DERIVATIVE BE CONTINUOUS C ACROSS TAU(2) AND ACROSS TAU(NTAU-1) . THIS LEADS TO A STRICTLY C DIAGONALLY DOMINANT TRIDIAGONAL LINEAR SYSTEM FOR THE FSECND(I) C WHICH WE SOLVE BY GAUSS ELIMINATION WITHOUT PIVOTING. C C: C: TAUTSP 89-08-30 MATS CARLSSON C: TEST OF ONEMZT CHANGED FROM 0. TO 1.E-11 TO AVOID DIVISION C: BY UNDERFLOWED EXPRESSION (ONEMZT**3) C: C: 89-09-05 MATS CARLSSON C: DIMENSION OF BREAK AND COEF CHANGED FROM 1 TO * TO MAKE C: POSSIBLE CHECK OF INDEX OUT OF BOUNDS C: INTEGER IFLAG,K,L,NTAU, I,METHOD,NTAUM1 DIMENSION BREAK(*),COEF(4,*),GTAU(NTAU),S(NTAU,6),TAU(NTAU) DATA ONE/1.0/ SAVE ONE C ALPH(X) = MIN(ONE,ONEMG3/X) C C THERE MUST BE AT LEAST 4 INTERPOLATION POINTS. IF (NTAU .GE. 4) GO TO 5 PRINT 600,NTAU 600 FORMAT(8H NTAU = ,I4,20H. SHOULD BE .GE. 4 .) GO TO 999 C CONSTRUCT DELTA TAU AND FIRST AND SECOND (DIVIDED) DIFFERENCES OF DATA C 5 NTAUM1 = NTAU - 1 DO 6 I=1,NTAUM1 S(I,1) = TAU(I+1) - TAU(I) IF (S(I,1) .GT. 0.) GO TO 6 PRINT 610,I,TAU(I),TAU(I+1) 610 FORMAT(7H POINT ,I3,13H AND THE NEXT,2E15.6,15H ARE DISORDERED) GO TO 999 6 S(I+1,4) = (GTAU(I+1)-GTAU(I))/S(I,1) DO 7 I=2,NTAUM1 7 S(I,4) = S(I+1,4) - S(I,4) C CONSTRUCT SYSTEM OF EQUATIONS FOR SECOND DERIVATIVES AT TAU. AT EACH C INTERIOR DATA POINT, THERE IS ONE CONTINUITY EQUATION, AT THE FIRST C AND THE LAST INTERIOR DATA POINT THERE IS AN ADDITIONAL ONE FOR A C TOTAL OF NTAU EQUATIONS IN NTAU UNKNOWNS. C I = 2 S(2,2) = S(1,1)/3. SIXTH = 1./6. METHOD = 2 GAM = GAMMA IF (GAM .LE. 0.) METHOD = 1 IF ( GAM .LE. 3.) GO TO 9 METHOD = 3 GAM = GAM - 3. 9 ONEMG3 = 1. - GAM/3. C ------ LOOP OVER I ------ 10 CONTINUE C CONSTRUCT Z(I) AND ZETA(I) Z = .5 GO TO (19,11,12),METHOD 11 IF (S(I,4)*S(I+1,4) .LT. 0.) GO TO 19 12 TEMP = ABS(S(I+1,4)) DENOM = ABS(S(I,4)) + TEMP IF (DENOM .EQ. 0.) GO TO 19 Z = TEMP/DENOM IF (ABS(Z - .5) .LE. SIXTH) Z = .5 19 S(I,5) = Z C ******SET UP PART OF THE I-TH EQUATION WHICH DEPENDS ON C THE I-TH INTERVAL IF (Z - .5) 21,22,23 21 ZETA = GAM*Z ONEMZT = 1. - ZETA ZT2 = ZETA**2 ALPHA = ALPH(ONEMZT) FACTOR = ZETA/(ALPHA*(ZT2-1.) + 1.) S(I,6) = ZETA*FACTOR/6. S(I,2) = S(I,2) + S(I,1)*((1.-ALPHA*ONEMZT)*FACTOR/2. - S(I,6)) C IF Z = 0 AND THE PREVIOUS Z = 1, THEN D(I) = 0. SINCE THEN C ALSO U(I-1) = L(I+1) = 0, ITS VALUE DOES NOT MATTER. RESET C D(I) = 1 TO INSURE NONZERO PIVOT IN ELIMINATION. IF (S(I,2) .LE. 0.) S(I,2) = 1. S(I,3) = S(I,1)/6. GO TO 25 22 S(I,2) = S(I,2) + S(I,1)/3. S(I,3) = S(I,1)/6. GO TO 25 23 ONEMZT = GAM*(1. - Z) ZETA = 1. - ONEMZT ALPHA = ALPH(ZETA) FACTOR = ONEMZT/(1. - ALPHA*ZETA*(1.+ONEMZT)) S(I,6) = ONEMZT*FACTOR/6. S(I,2) = S(I,2) + S(I,1)/3. S(I,3) = S(I,6)*S(I,1) 25 IF (I .GT. 2) GO TO 30 S(1,5) = .5 C ******THE FIRST TWO EQUATIONS ENFORCE CONTINUITY OF THE FIRST AND OF C THE THIRD DERIVATIVE ACROSS TAU(2). S(1,2) = S(1,1)/6. S(1,3) = S(2,2) ENTRY3 = S(2,3) IF (Z - .5) 26,27,28 26 FACTR2 = ZETA*(ALPHA*(ZT2-1.) + 1.)/(ALPHA*(ZETA*ZT2-1.)+1.) RATIO = FACTR2*S(2,1)/S(1,2) S(2,2) = FACTR2*S(2,1) + S(1,1) S(2,3) = -FACTR2*S(1,1) GO TO 29 27 RATIO = S(2,1)/S(1,2) S(2,2) = S(2,1) + S(1,1) S(2,3) = -S(1,1) GO TO 29 28 RATIO = S(2,1)/S(1,2) S(2,2) = S(2,1) + S(1,1) S(2,3) = -S(1,1)*6.*ALPHA*S(2,6) C AT THIS POINT, THE FIRST TWO EQUATIONS READ C DIAG(1)*X1 + U(1)*X2 + ENTRY3*X3 = R(2) C -RATIO*DIAG(1)*X1 + DIAG(2)*X2 + U(2)*X3 = 0. C ELIMINATE FIRST UNKNOWN FROM SECOND EQUATION 29 S(2,2) = RATIO*S(1,3) + S(2,2) S(2,3) = RATIO*ENTRY3 + S(2,3) S(1,4) = S(2,4) S(2,4) = RATIO*S(1,4) GO TO 35 30 CONTINUE C ******THE I-TH EQUATION ENFORCES CONTINUITY OF THE FIRST DERIVATIVE C ACROSS TAU(I). IT HAS BEEN SET UP IN STATEMENTS 35 UP TO 40 C AND 21 UP TO 25 AND READS NOW C -RATIO*DIAG(I-1)*XI-1 + DIAG(I)*XI + U(I)*XI+1 = R(I) . C ELIMINATE (I-1)ST UNKNOWN FROM THIS EQUATION S(I,2) = RATIO*S(I-1,3) + S(I,2) S(I,4) = RATIO*S(I-1,4) + S(I,4) C C ******SET UP THE PART OF THE NEXT EQUATION WHICH DEPENDS ON THE C I-TH INTERVAL. 35 IF (Z - .5) 36,37,38 36 RATIO = -S(I,6)*S(I,1)/S(I,2) S(I+1,2) = S(I,1)/3. GO TO 40 37 RATIO = -(S(I,1)/6.)/S(I,2) S(I+1,2) = S(I,1)/3. GO TO 40 38 RATIO = -(S(I,1)/6.)/S(I,2) S(I+1,2) = S(I,1)*((1.-ZETA*ALPHA)*FACTOR/2. - S(I,6)) C ------ END OF I LOOP ------ 40 I = I+1 IF (I .LT. NTAUM1) GO TO 10 S(I,5) = .5 C C ------ LAST TWO EQUATIONS ------ C THE LAST TWO EQUATIONS ENFORCE CONTINUITY OF THIRD DERIVATIVE AND C OF FIRST DERIVATIVE ACROSS TAU(NTAU-1). ENTRY = RATIO*S(I-1,3) + S(I,2) + S(I,1)/3. S(I+1,2) = S(I,1)/6. S(I+1,4) = RATIO*S(I-1,4) + S(I,4) IF (Z - .5) 41,42,43 41 RATIO = S(I,1)*6.*S(I-1,6)*ALPHA/S(I-1,2) S(I,2) = RATIO*S(I-1,3) + S(I,1) + S(I-1,1) S(I,3) = -S(I-1,1) GO TO 45 42 RATIO = S(I,1)/S(I-1,2) S(I,2) = RATIO*S(I-1,3) + S(I,1) + S(I-1,1) S(I,3) = -S(I-1,1) GO TO 45 43 FACTR2 = ONEMZT*(ALPHA*(ONEMZT**2-1.)+1.)/ * (ALPHA*(ONEMZT**3-1.)+1.) RATIO = FACTR2*S(I,1)/S(I-1,2) S(I,2) = RATIO*S(I-1,3) + FACTR2*S(I-1,1) + S(I,1) S(I,3) = -FACTR2*S(I-1,1) C AT THIS POINT, THE LAST TWO EQUATIONS READ C DIAG(I)*XI + U(I)*XI+1 = R(I) C -RATIO*DIAG(I)*XI + DIAG(I+1)*XI+1 = R(I+1) C ELIMINATE XI FROM LAST EQUATION 45 S(I,4) = RATIO*S(I-1,4) RATIO = -ENTRY/S(I,2) S(I+1,2) = RATIO*S(I,3) + S(I+1,2) S(I+1,4) = RATIO*S(I,4) + S(I+1,4) C C ------ BACK SUBSTITUTION ------ C S(NTAU,4) = S(NTAU,4)/S(NTAU,2) 50 S(I,4) = (S(I,4) - S(I,3)*S(I+1,4))/S(I,2) I = I - 1 IF (I .GT. 1) GO TO 50 S(1,4) = (S(1,4)-S(1,3)*S(2,4)-ENTRY3*S(3,4))/S(1,2) C C ------ CONSTRUCT POLYNOMIAL PIECES ------ C BREAK(1) = TAU(1) L = 1 DO 70 I=1,NTAUM1 COEF(1,L) = GTAU(I) COEF(3,L) = S(I,4) DIVDIF = (GTAU(I+1)-GTAU(I))/S(I,1) Z = S(I,5) IF (Z - .5) 61,62,63 61 IF (Z .EQ. 0.) GO TO 65 ZETA = GAM*Z ONEMZT = 1. - ZETA C = S(I+1,4)/6. D = S(I,4)*S(I,6) L = L + 1 DEL = ZETA*S(I,1) BREAK(L) = TAU(I) + DEL ZT2 = ZETA**2 ALPHA = ALPH(ONEMZT) FACTOR = ONEMZT**2*ALPHA COEF(1,L) = GTAU(I) + DIVDIF*DEL * + S(I,1)**2*(D*ONEMZT*(FACTOR-1.)+C*ZETA*(ZT2-1.)) COEF(2,L) = DIVDIF + S(I,1)*(D*(1.-3.*FACTOR)+C*(3.*ZT2-1.)) COEF(3,L) = 6.*(D*ALPHA*ONEMZT + C*ZETA) COEF(4,L) = 6.*(C - D*ALPHA)/S(I,1) COEF(4,L-1) = COEF(4,L) - 6.*D*(1.-ALPHA)/(DEL*ZT2) COEF(2,L-1) = COEF(2,L) - DEL*(COEF(3,L) -(DEL/2.)*COEF(4,L-1)) GO TO 68 62 COEF(2,L) = DIVDIF - S(I,1)*(2.*S(I,4) + S(I+1,4))/6. COEF(4,L) = (S(I+1,4)-S(I,4))/S(I,1) GO TO 68 63 ONEMZT = GAM*(1. - Z) IF (ABS(ONEMZT) .LT. 1.E-11) GO TO 65 ZETA = 1. - ONEMZT ALPHA = ALPH(ZETA) C = S(I+1,4)*S(I,6) D = S(I,4)/6. DEL = ZETA*S(I,1) BREAK(L+1) = TAU(I) + DEL COEF(2,L) = DIVDIF - S(I,1)*(2.*D + C) COEF(4,L) = 6.*(C*ALPHA - D)/S(I,1) L = L + 1 COEF(4,L) = COEF(4,L-1) + 6.*(1.-ALPHA)*C/(S(I,1)*ONEMZT**3) COEF(3,L) = COEF(3,L-1) + DEL*COEF(4,L-1) COEF(2,L) = COEF(2,L-1)+DEL*(COEF(3,L-1)+(DEL/2.)*COEF(4,L-1)) COEF(1,L) = COEF(1,L-1)+DEL*(COEF(2,L-1)+(DEL/2.)*(COEF(3,L-1) * +(DEL/3.)*COEF(4,L-1))) GO TO 68 65 COEF(2,L) = DIVDIF COEF(3,L) = 0. COEF(4,L) = 0. 68 L = L + 1 70 BREAK(L) = TAU(I+1) C* L = L - 1 DELETION OF THIS STATEMENT MAKES EXTRAPOL WARNING POSSIBLE K = 4 IFLAG = 1 RETURN 999 IFLAG = 2 RETURN END C********************************************************************* FUNCTION PPVALU (BREAK, COEF, L, K, X, JDERIV ,MFLAG) INCLUDE 'PREC' C C: PPVALU 94-07-20 MATS CARLSSON C: SETS VALUE TO 0 IF EXTRAPOLATION C: C FROM * A PRACTICAL GUIDE TO SPLINES * BY C. DE BOOR CALLS INTERV CALCULATES VALUE AT X OF JDERIV-TH DERIVATIVE OF PP FCT FROM PP-REPR C C****** I N P U T ****** C BREAK, COEF, L, K.....FORMS THE PP-REPRESENTATION OF THE FUNCTION F C TO BE EVALUATED. SPECIFICALLY, THE J-TH DERIVATIVE OF F IS C GIVEN BY C C (D**J)F(X) = COEF(J+1,I) + H*(COEF(J+2,I) + H*( ... (COEF(K-1,I) + C + H*COEF(K,I)/(K-J-1))/(K-J-2) ... )/2)/1 C C WITH H = X - BREAK(I), AND C C I = MAX( 1 , MAX( J , BREAK(J) .LE. X , 1 .LE. J .LE. L ) ). C C X.....THE POINT AT WHICH TO EVALUATE. C JDERIV.....INTEGER GIVING THE ORDER OF THE DERIVATIVE TO BE EVALUAT- C ED. A S S U M E D TO BE ZERO OR POSITIVE. C C****** O U T P U T ****** C PPVALU.....THE VALUE OF THE (JDERIV)-TH DERIVATIVE OF F AT X. C C****** M E T H O D ****** C THE INTERVAL INDEX I , APPROPRIATE FOR X , IS FOUND THROUGH A C CALL TO INTERV . THE FORMULA ABOVE FOR THE JDERIV-TH DERIVATIVE C OF F IS THEN EVALUATED (BY NESTED MULTIPLICATION). C C: PPVALU 95-11-06 MATS CARLSSON C: RETURNS VALUE OF FLAG FROM INTERV C: INTEGER JDERIV,K,L, I,M,MFLAG DIMENSION BREAK(L),COEF(K,L) PPVALU = 0. FMMJDR = K - JDERIV C DERIVATIVES OF ORDER K OR HIGHER ARE IDENTICALLY ZERO. IF (FMMJDR .LE. 0.) GO TO 99 C C FIND INDEX I OF LARGEST BREAKPOINT TO THE LEFT OF X . CALL INTERV ( BREAK, L, X, I, MFLAG ) C IF(MFLAG.NE.0) THEN PPVALU=0.0 RETURN ENDIF C C EVALUATE JDERIV-TH DERIVATIVE OF I-TH POLYNOMIAL PIECE AT X . H = X - BREAK(I) M = K 9 PPVALU = (PPVALU/FMMJDR)*H + COEF(M,I) M = M - 1 FMMJDR = FMMJDR - 1. IF (FMMJDR .GT. 0.) GO TO 9 99 RETURN END C********************************************************************* SUBROUTINE INTERV ( XT, LXT, X, LEFT, MFLAG ) C FROM * A PRACTICAL GUIDE TO SPLINES * BY C. DE BOOR COMPUTES LEFT = MAX( I , 1 .LE. I .LE. LXT .AND. XT(I) .LE. X ) . C C****** I N P U T ****** C XT.....A REAL SEQUENCE, OF LENGTH LXT , ASSUMED TO BE NONDECREASING C LXT.....NUMBER OF TERMS IN THE SEQUENCE XT . C X.....THE POINT WHOSE LOCATION WITH RESPECT TO THE SEQUENCE XT IS C TO BE DETERMINED. C C****** O U T P U T ****** C LEFT, MFLAG.....BOTH INTEGERS, WHOSE VALUE IS C C 1 -1 IF X .LT. XT(1) C I 0 IF XT(I) .LE. X .LT. XT(I+1) C LXT 1 IF XT(LXT) .LE. X C C IN PARTICULAR, MFLAG = 0 IS THE 'USUAL' CASE. MFLAG .NE. 0 C INDICATES THAT X LIES OUTSIDE THE HALFOPEN INTERVAL C XT(1) .LE. Y .LT. XT(LXT) . THE ASYMMETRIC TREATMENT OF THE C INTERVAL IS DUE TO THE DECISION TO MAKE ALL PP FUNCTIONS CONT- C INUOUS FROM THE RIGHT. C C****** M E T H O D ****** C THE PROGRAM IS DESIGNED TO BE EFFICIENT IN THE COMMON SITUATION THAT C IT IS CALLED REPEATEDLY, WITH X TAKEN FROM AN INCREASING OR DECREA- C SING SEQUENCE. THIS WILL HAPPEN, E.G., WHEN A PP FUNCTION IS TO BE C GRAPHED. THE FIRST GUESS FOR LEFT IS THEREFORE TAKEN TO BE THE VAL- C UE RETURNED AT THE PREVIOUS CALL AND STORED IN THE L O C A L VARIA- C BLE ILO . A FIRST CHECK ASCERTAINS THAT ILO .LT. LXT (THIS IS NEC- C ESSARY SINCE THE PRESENT CALL MAY HAVE NOTHING TO DO WITH THE PREVI- C OUS CALL). THEN, IF XT(ILO) .LE. X .LT. XT(ILO+1), WE SET LEFT = C ILO AND ARE DONE AFTER JUST THREE COMPARISONS. C OTHERWISE, WE REPEATEDLY DOUBLE THE DIFFERENCE ISTEP = IHI - ILO C WHILE ALSO MOVING ILO AND IHI IN THE DIRECTION OF X , UNTIL C XT(ILO) .LE. X .LT. XT(IHI) , C AFTER WHICH WE USE BISECTION TO GET, IN ADDITION, ILO+1 = IHI . C LEFT = ILO IS THEN RETURNED. C C: C: INTERV 88-08-30 MATS CARLSSON C: STOP IF MORE THAN 20 EXTRAPOLATIONS C: C: 88-10-26 MATS CARLSSON C: SAVE STATEMENT INSERTED, EXTRAPOLATION CHECK CHANGED C: TO WORK FOR THE CASE X=XT C: C: 94-01-06 MATS CARLSSON C: IEXTR IN COMMON TO ENABLE ZEROING OUTSIDE ROUTINE C: INITIALIZATION WITH DATA STATEMENT IN VIOLATION OF F77 STANDARD C: C: 94-07-20 MATS CARLSSON C: EXTRAPOLATION RESULTS IN ZERO VALUE AND WARNING MESSAGE C: ONLY 10 WARNINGS PRINTED BUT PROGRAM CONTINUES C: C: 95-08-16 MATS CARLSSON C: INITIALIZATION OF IEXTR MOVED TO BLOCK DATA SUBPROGRAM C: C: 95-11-27 MATS CARLSSON C: MFLAG=1 ONLY SET IF X.GT.XT C: INCLUDE 'PREC' COMMON /CINTV/ IEXTR INTEGER LEFT,LXT,MFLAG, IHI,ILO,ISTEP,MIDDLE DIMENSION XT(LXT) DATA ILO /1/ SAVE ILO IHI = ILO + 1 IF (IHI .LT. LXT) GO TO 20 IF (X .GE. XT(LXT)) GO TO 110 IF (LXT .LE. 1) GO TO 90 ILO = LXT - 1 IHI = LXT C 20 IF (X .GE. XT(IHI)) GO TO 40 IF (X .GE. XT(ILO)) GO TO 100 C C **** NOW X .LT. XT(ILO) . DECREASE ILO TO CAPTURE X . ISTEP = 1 31 IHI = ILO ILO = IHI - ISTEP IF (ILO .LE. 1) GO TO 35 IF (X .GE. XT(ILO)) GO TO 50 ISTEP = ISTEP*2 GO TO 31 35 ILO = 1 IF (X .LT. XT(1)) GO TO 90 GO TO 50 C **** NOW X .GE. XT(IHI) . INCREASE IHI TO CAPTURE X . 40 ISTEP = 1 41 ILO = IHI IHI = ILO + ISTEP IF (IHI .GE. LXT) GO TO 45 IF (X .LT. XT(IHI)) GO TO 50 ISTEP = ISTEP*2 GO TO 41 45 IF (X .GE. XT(LXT)) GO TO 110 IHI = LXT C C **** NOW XT(ILO) .LE. X .LT. XT(IHI) . NARROW THE INTERVAL. 50 MIDDLE = (ILO + IHI)/2 IF (MIDDLE .EQ. ILO) GO TO 100 C NOTE. IT IS ASSUMED THAT MIDDLE = ILO IN CASE IHI = ILO+1 . IF (X .LT. XT(MIDDLE)) GO TO 53 ILO = MIDDLE GO TO 50 53 IHI = MIDDLE GO TO 50 C**** SET OUTPUT AND RETURN. 90 MFLAG = -1 LEFT = 1 IF(IEXTR.LE.10) THEN WRITE(*,92) X,XT(1) 92 FORMAT(' INTERV: X OUTSIDE XT, VALUE SET TO ZERO, X,XT=', * 1P,2E14.6) ENDIF IEXTR=IEXTR+1 RETURN 100 MFLAG = 0 LEFT = ILO RETURN 110 CONTINUE LEFT = LXT-1 MFLAG = 0 IF(X.GT.XT(LXT)) THEN MFLAG = 1 IF(IEXTR.LE.10) THEN WRITE(*,92) X,XT(LXT) ENDIF IEXTR=IEXTR+1 ENDIF RETURN END SUBROUTINE COCOL C C COLLISION RATES FOR VIB-ROT LEVELS WITHIN THE GROUND STATE C OF THE CO MOLECULE C INCLUDE 'PREC' INCLUDE 'PARAM' INCLUDE 'CATOM' INCLUDE 'CATMOS' INCLUDE 'CATMO2' INCLUDE 'CCONST' INCLUDE 'CLU' C PARAMETER (MT=300,MKOMP=150,ML=50000,MSET=1,MLATB=50,MTETB=30, * MELMAX=2,MKOMPR=MKOMP,MKOMPT=10, * KFADIM=MKOMPR*MT+MKOMPT*MT*3,IFADIM=MKOMPT*MT) COMMON/COUT/ TOTH(MT),TOTHI(MT),TOTH2(MT), * TOTCH(MT),TOTCO(MT),TOTCN(MT), * TOTC(MT),TOTNIT(MT),TOTO(MT), * BHYD(MT,5),GRPH C DIMENSION EN(MK) C C CONVERT ENERGIES FROM ELECTRON VOLTS BACK INTO INVERSE CENTIMETERS C DO 50 I=1,NK EN(I)=EV(I)*EE/CC/HH 50 CONTINUE C C SET CROSS SECTION VARIABLES AND REDUCED MASSES (IN UNITS OF CM^-1) C SV1H=5.0E-17 SV1H2=1.4E-16 SV1HE=1.0E-16 C SV0H=2.0E-16 SV0H2=7.0E-16 SV0HE=5.0E-16 C RMH=1.616E-24 RMH2=3.123E-24 RMHE=5.816E-24 C C START LOOPS TO FIND CROSS-SECTIONS FOR J(UPPER LEVEL) TO C I(LOWER LEVEL) TRANSITIONS C DO 300 J=2,NK DO 200 I=1,J-1 C C TEST IF ROTATIONAL TRANSITIONS OCCURS ACROSS LESS THAN 2 ROT LEVELS C JJ=JFIND(G(J)) IJ=JFIND(G(I)) IF (ABS(JJ-IJ).LE.2) THEN C C TEST IF VIBRATIONAL TRANSITION OCCURS FIRSTLY, THEN CALCULATE C COLLISION RATES C JV=IVFIND(EN(J)) IV=IVFIND(EN(I)) IF ((JV-IV).EQ.1) THEN DO 100 K=1,NDEP CH=SV1H*SQRT(8.*BK*TEMP(K)/(RMH*PI))*TOTHI(K) CH2=SV1H2*SQRT(8.*BK*TEMP(K)/(RMH2*PI))*TOTH2(K) CHE=SV1HE*SQRT(8.*BK*TEMP(K)/(RMHE*PI))*(0.1*TOTHI(K)) C(J,I,K)=CH+CH2+CHE C(I,J,K)=C(J,I,K)*NSTAR(J,K)/NSTAR(I,K) 100 CONTINUE C C IF VIBRATIONAL TRANSITION DOES NOT OCCUR, THEN CALCULATE COLLISION RATES C ELSE IF ((JV-IV).EQ.0) THEN DO 150 K=1,NDEP CH=SV0H*SQRT(8.*BK*TEMP(K)/(RMH*PI))*TOTHI(K) CH2=SV0H2*SQRT(8.*BK*TEMP(K)/(RMH2*PI))*TOTH2(K) CHE=SV0HE*SQRT(8.*BK*TEMP(K)/(RMHE*PI))*(0.1*TOTHI(K)) C(J,I,K)=CH+CH2+CHE C(I,J,K)=C(J,I,K)*NSTAR(J,K)/NSTAR(I,K) 150 CONTINUE ENDIF ENDIF 200 CONTINUE 300 CONTINUE END C FUNCTION IVFIND(EN) INCLUDE 'PREC' IF (EN.LT.1000.) THEN IVFIND=0 ELSE IF (EN.LT.3000.) THEN IVFIND=1 ELSE IF (EN.LT.5000.) THEN IVFIND=2 ELSE IF (EN.LT.7000.) THEN IVFIND=3 ENDIF RETURN END C FUNCTION JFIND(G) INCLUDE 'PREC' IG=G+0.5 JFIND=(IG-1)/2 RETURN END C C*********************************************************************** C SUBROUTINE HSEINT(HSE) C C DOES THE HYDROSTATIC EQUILIBRIUM INTEGRATION C ROUTINE ELCNTM IS FOUND IN THE OPACITY PACKAGE C NOTE THAT NO MORE HSE INTEGRATIONS ARE DONE WHEN C THE CORRECTIONS (CORMAX) FALL BELOW ELIM2 C C THE SET OF EQUATIONS THAT ARE SOLVED BY THE NEWTON-RAPHSON C SCHEME ARE: C C 1. XNHN+XNP+XNHM+XNH2+XNH2P+XNH*(SUMABN+GRPH*VTURB**2/(2*BK*TEMP)+NE= C CMASS*GRAV/(BK*TEMP) (HYDROSTATIC EQUILBRIUM INCLUDING C TURBULENT PRESSURE BUT NEGLECTING C RADIATION PRESSURE) C 2. NE + XNHM - XNH*ELCNTM - XNP - XNH2P = 0 (CHARGE CONSERVATION) C 3. XNH = XNHN + XNP + XNHM + 2*XNH2 + 2*XNH2P C 4. D/DNE (Z***) = 0 C 4A.ZH = XNHN/(NE*XNP) C 4B.ZHM = XNHM/(XNHN*NE) C 4C.ZH2 = XNH2/(XNHN*XNHN) C 4D.ZH2P = XNH2P/(XNHN*XNP) C C WHERE THE VARIABLES DENOTE THE FOLLOWING NUMBER DENSITIES: C NE ELECTRONS C XNH HYDROGEN NUCLEI C XNHN NEUTRAL HYDROGEN C XNP IONIZED HYDROGEN (PROTONS) C XNHM NEGATIVE HYDROGEN ION C XNH2 HYDROGEN MOLECULE C XNH2P POSITIVE H2 C AND ALL ''RECIPROCAL DISSOCIATION CONSTANTS'' Z*** ARE CONSTANT C WITH ELECTRON DENSITY AND TAKEN EITHER FROM THE CURRENT RADIATIVE C TRANSFER SOLUTION (ZH) OR FROM LTE (ZH2, ZH2P, ZHM) C C GRPH IS THE NUMBER OF GRAMS PER HYDROGEN NUCLEUS, C C THE INCLUSION OF RADIATION PRESSURE WOULD MODIFY EQUATION 1 C C THERE IS NO CHECK AGAINST WILD BEHAVIOUR OF THE NEWTON-RAPHSON SCHEME C EXCEPT THAT NEGATIVE NE CAUSES THE NEW NE TO BE TAKEN AS OLD NE C DIVIDED BY 10. IF PROBLEMS ARE ENCOUNTERED, SEE NUMERICAL RECIPES C BY PRESS ET AL., PP. 240-259 FOR MORE ROBUST SOLUTION METHODS. C C THE ROUTINE CHECK PROVIDES A DEBUG PRINTOUT WITH NUMERICAL AND C ANALYTICAL NUMERICAL DERIVATIVES AND THE TERMS OF THE NUMERICAL C DERIVATIVES. NORMALLY LCHECK=.FALSE. TO USE ROUTINE CHECK, SET C LCHECK=.TRUE. C: C: HSEINT 87-12-11 MODIFICATIONS: (MATS CARLSSON) C: REWRITTEN TO FIT UPPSALA OPACITY PACKAGE C: C: 89-03-24 MODIFICATIONS: (MATS CARLSSON) C: DEPTH POINT INDEX K PASSED AS AN ARGUMENT TO ELCNTM C: TO ENABLE CORRECT BMET VALUES TO BE USED BY JON C: INCLUDE 'PREC' INCLUDE 'PARAM' INCLUDE 'CATOM' INCLUDE 'CATMOS' INCLUDE 'CATMO2' INCLUDE 'CCONST' INCLUDE 'CINPUT' INCLUDE 'CLU' C PARAMETER (MT=300,MKOMP=150,ML=50000,MSET=1,MLATB=50,MTETB=30, * MELMAX=2,MKOMPR=MKOMP,MKOMPT=10, * KFADIM=MKOMPR*MT+MKOMPT*MT*3,IFADIM=MKOMPT*MT) C COMMON/COUT/ TOTH(MT),TOTHI(MT),TOTH2(MT), * TOTCH(MT),TOTCO(MT),TOTCN(MT), * TOTC(MT),TOTNIT(MT),TOTO(MT), * BHYD(MT,5),GRPH COMMON/ELMSUM/ SUMABN,SUMMY,NELM,NELME C COMMON/COUTR/ NTO,NTPO(MT),IWOPTN DIMENSION OLDNE(MDEP) LOGICAL HSE COMMON/CI4/ IDUM1(16),IDUM2(16,5),TMOLIM,MOLH LOGICAL LCHECK SAVE LCHECK DATA LCHECK/.FALSE./ C CORMAX=0.0 DO 600 K=1,NDEP T=TEMP(K) XPE=NE(K)*BK*T C C STORE OLD VALUES C OLDNE(K)=NE(K) XNHN0=0.0 DO 100 I=1,NK-1 XNHN0=XNHN0+N(I,K) 100 CONTINUE C C ZH IS THE RECIPROCAL ''DISSOCIATION CONSTANT'' FOR HYDROGEN C ASSUMED TO BE CONSTANT C ZH=XNHN0/(NE(K)*N(NK,K)) TETA=5040./T TETA25=1.202E9/(TETA*TETA*SQRT(TETA)) DXI=4.98E-4*TETA*SQRT(XPE) XIHM=0.747-2.*DXI XKHM=TETA25*2.*10.**(-TETA*XIHM) ZHM=1.0/XKHM*BK*T IF(T.GT.TMOLIM) THEN ZH2=0.0 ZH2P=0.0 ELSE CALL MOLFYS(T,XKH2,XKH2P,DEH2,DEH2P) ZH2=1.0/XKH2*BK*T ZH2P=1.0/XKH2P*BK*T ENDIF C C HYDROSTATIC EQUILIBRIUM EQUATION GIVES TOTAL NUMBER OF PARTICLES C XNTOT=CMASS(K)*GRAV/(BK*T) C C FQ IS THE NUMBER OF NON-ELECTRONIC PARTICLES PER HYDROGEN NUCLEUS C IF THERE ARE NO MOLECULES PRESENT C THIS IS WHERE TURBULENT PRESSURE AND RADIATION PRESSURE ENTERS C SEE EQUATION (1) C VT=VTURB(K)*QNORM*1.E5 FQM=SUMABN+GRPH*VT*VT/(2.0*BK*T) FQ=1.0+FQM C C FAC GIVES THE STEP IN THE NUMERICAL DERIVATION OF ELCNTM C FAC=0.01 C C GET STARTING VALUES C ITRY=0 LCHECK=.FALSE. XNE=NE(K) 110 CONTINUE ITRY=ITRY+1 AX2=(1.+FQM/FQ)*(ZH2+ZH2P/XNE/ZH) BX=1.0+1.0/(XNE*ZH)+ZHM*XNE CX=-(XNTOT-XNE)/FQ XNHN=QUADEQ(AX2,BX,CX) XNP=XNHN/(XNE*ZH) XNHM=ZHM*XNHN*XNE XNH2=ZH2*XNHN*XNHN XNH2P=ZH2P*XNHN*XNP XNH=XNHN+XNP+XNHM+2.*XNH2+2.*XNH2P TOTH(K)=XNH C C SOLVE THE CHARGE CONSERVATION EQUATION BY NEWTON-RAPHSON ITERATION C DO 200 M=1,100 C C FIND THE DERIVATIVE OF ELCNTM WITH RESPECT TO NE C THIS IS DONE NUMERICALLY C XUP=XNE*(1.0+FAC) XDN=XNE/(1.0+FAC) DNE=XUP-XDN DION=ELCNTM(K,T,XUP*BK*T)- * ELCNTM(K,T,XDN*BK*T) C XPE=XNE*BK*T XION=ELCNTM(K,T,XPE) XNEOLD=XNE C C FF IS THE RHS OF THE CHARGE CONSERVATION EQUATION (2) C FF=XNE+XNHM-XNH*XION-XNP-XNH2P C C FIND DERIVATIVES C DHNDE=(XNHN*XNHN*(1.+FQM/FQ)*ZH2P/ZH/XNE/XNE+ * XNHN/XNE/XNE/ZH-ZHM*XNHN-1./FQ)/(2.*XNHN*AX2+BX) DPDE=1./XNE/ZH*DHNDE-XNP/XNE DHMDE=ZHM*(XNE*DHNDE+XNHN) DH2DE=2.*ZH2*XNHN*DHNDE DH2PDE=ZH2P/ZH*(2.*XNHN/XNE*DHNDE-XNHN/XNE*XNHN/XNE) DHDE=DHNDE+DPDE+DHMDE+2.*DH2DE+2.*DH2PDE C C DFDE IS D/DNE OF THE CHARGE CONSERVATION EQUATION C CALCULATE NEWTON-RAPHSON STEP AND RELATIVE CHANGE C IF CORRECTION WOULD RESULT IN NEGATIVE NE, DIVIDE C OLD NE BY 10. C DFDE=1.0+DHMDE-DHDE*XION-XNH*DION/DNE-DPDE-DH2PDE DELTA=-FF/DFDE IF(DELTA.LT.-XNE) DELTA=-0.9*XNE SIG=ABS(DELTA/XNE) IF(LCHECK) THEN CALL CHECK(T,XNE,XNHN,XNP,XNHM,XNH2,XNH2P,ZH,ZHM,ZH2,ZH2P, * FQM,XNTOT,AX2,BX,K,SIG) ENDIF C C UPDATE VARIABLES C 150 CONTINUE XNE=XNE+DELTA AX2=(1.+FQM/FQ)*(ZH2+ZH2P/XNE/ZH) BX=1.0+1.0/(XNE*ZH)+ZHM*XNE CX=-(XNTOT-XNE)/FQ XNHN=QUADEQ(AX2,BX,CX) XNP=XNHN/(XNE*ZH) XNHM=ZHM*XNHN*XNE XNH2=ZH2*XNHN*XNHN XNH2P=ZH2P*XNHN*XNP XNH=XNHN+XNP+XNHM+2.*XNH2+2.*XNH2P TOTH(K)=XNH TETA=5040./T TETA25=1.202E9/(TETA*TETA*SQRT(TETA)) DXI=4.98E-4*TETA*SQRT(XPE) XIHM=0.747-2.*DXI XKHM=TETA25*2.*10.**(-TETA*XIHM) ZHM=1.0/XKHM*BK*T IF(SIG.LT.1.E-4) GOTO 300 200 CONTINUE LCHECK=.TRUE. IF(ITRY.LT.3) THEN XNE=2.*XNE GOTO 110 ENDIF WRITE(LJOBLO,210) K,SIG 210 FORMAT(' K=',I4,' SIG=',1P,E10.2) CALL STOP('HSEINT: NO CONVERGENCE') 300 CONTINUE C C UPDATE POPULATIONS N C N(NK,K)=XNP DO 400 I=1,NK-1 N(I,K)=XNHN/XNHN0*N(I,K) 400 CONTINUE C C UPDATE POPULATIONS NH. IF NK IS LESS THAN 6 THE LAST LEVELS C IN NH ARE SET TO ZERO C NH(6,K)=N(NK,K) IMAX=MIN(5,NK-1) DO 500 I=1,IMAX NH(I,K)=N(I,K) 500 CONTINUE DO 550 I=IMAX+1,5 NH(I,K)=0.0 550 CONTINUE C C UPDATE NE C NE(K)=XNE CORMAX=MAX(CORMAX,ABS(NE(K)/OLDNE(K)-1.)) C 600 CONTINUE C C IF NE HAS CONVERGED TO WITHIN ELIM2, STOP HSE INTEGRATIONS BY C SETTING HSE=.FALSE. SWITCH ON PRINTOUTS IN OPACITY PACKAGE BY C SETTING IWOPTN C IF(CORMAX.LT.ELIM2) THEN HSE=.FALSE. IF(IWOPAC.GT.0) THEN IWOPTN=1 ELSE IWOPTN=7 ENDIF ENDIF CALL OPAC(1) CALL DPCONV CALL LTEPOP CALL CLOSE(LDUMC) IF(CROUT.NE.'HCOL') THEN CALL ATOM(1) CALL FREQ ENDIF CALL COLRAT CALL FIXRAD CALL DAMP CALL PROFIL CALL WHSE(OLDNE) C C DO IHSE-1 LAMBDA ITERATIONS C DO 700 I=1,IHSE-1 CALL TRPT CALL STATEQ(ISUM,1) 700 CONTINUE C C WRITE NEW ATMOSPHERE TO FILE ATHSE C CALL WATHSE C RETURN END C C*********************************************************************** C FUNCTION QUADEQ(AX2,BX,CX) C C SOLVES AX2*X**2 + BX*X + CX = 0.0. GIVES ONLY LARGEST ROOT C INCLUDE 'PREC' IF(ABS(AX2*CX/BX/BX).LT.1.0E-5) THEN QUADEQ=-CX/BX ELSE QUADEQ=(-BX+SQRT(BX*BX-4.*AX2*CX))/(2.0*AX2) ENDIF C RETURN END C C ********************************************************************** C SUBROUTINE CHECK(T,XNE,XNHN,XNP,XNHM,XNH2,XNH2P,ZH,ZHM,ZH2,ZH2P, * FQM,XNTOT,AX2,BX,K,SIG) C C CHECK DERIVATIVES IN HSEINT C INCLUDE 'PREC' INCLUDE 'CLU' C FQ=1.0+FQM DHN1=XNHN*XNHN*(1.+FQM/FQ)*ZH2P/ZH/XNE/XNE DHN2=XNHN/XNE/XNE/ZH DHN3=-ZHM*XNHN DHN4=-1./FQ DHNDE=(DHN1+DHN2+DHN3+DHN4)/(2.*XNHN*AX2+BX) DP1=1./XNE/ZH*DHNDE DP2=-XNP/XNE DPDE=DP1+DP2 DHM1=XNE*DHNDE DHM2=XNHN DHMDE=ZHM*(DHM1+DHM2) DH2DE=2.*ZH2*XNHN*DHNDE DH2P1=2.*XNHN/XNE*DHNDE DH2P2=-XNHN/XNE*XNHN/XNE DH2PDE=ZH2P/ZH*(DH2P1+DH2P2) DHDE=DHNDE+DPDE+DHMDE+2.*DH2DE+2.*DH2PDE C C NUMERICAL DERIVATIVE C DXNE=XNE*0.001 XNED=XNE+DXNE AX2D=(1.+FQM/FQ)*(ZH2+ZH2P/XNED/ZH) BXD=1.0+1.0/(XNED*ZH)+ZHM*XNED CXD=-(XNTOT-XNED)/FQ XNHND=QUADEQ(AX2D,BXD,CXD) XNPD=XNHND/(XNED*ZH) XNHMD=ZHM*XNHND*XNED XNH2D=ZH2*XNHND*XNHND XNH2PD=ZH2P*XNHND*XNPD XNHD=XNHND+XNPD+XNHMD+2.*XNH2D+2.*XNH2PD XNH=XNHN+XNP+XNHM+2.*XNH2+2.*XNH2P DNHN=(XNHND-XNHN)/DXNE DNP=(XNPD-XNP)/DXNE DNHM=(XNHMD-XNHM)/DXNE DNH2=(XNH2D-XNH2)/DXNE DNH2P=(XNH2PD-XNH2P)/DXNE DNH=(XNHD-XNH)/DXNE C SMALL=1.E-37 WRITE(*,90) K,T,XNE,SIG,LOG10(MAX(SMALL,SIG)) 90 FORMAT(/' K=',I4,' T=',F7.0,' NE=',1P,E10.2, * ' SIG=',1P,E10.2,' LG SIG=',0P,F7.3/ * 13X,'N',5X,'NUMERIC',2X,'ANALYTIC',7X,'TERMS') WRITE(LJOBLO,100) 'HN ',XNHN,DNHN,DHNDE,DHN1,DHN2,DHN3,DHN4 WRITE(LJOBLO,100) 'P ',XNP,DNP,DPDE,DP1,DP2 WRITE(LJOBLO,100) 'HM ',XNHM,DNHM,DHMDE,DHM1,DHM2 WRITE(LJOBLO,100) 'H2 ',XNH2,DNH2,DH2DE WRITE(LJOBLO,100) 'H2P',XNH2P,DNH2P,DH2PDE,DH2P1,DH2P2 WRITE(LJOBLO,100) 'H ',XNH,DNH,DHDE 100 FORMAT(1X,A,1P,E10.2,2X,2E10.2,2X,4E10.2) C 999 CONTINUE RETURN END C C ********************************************************************** C SUBROUTINE FORMAL C C ADMINISTERS THE PRINTOUTS. VERSION FOR CONTRIBUTION PRINTOUTS C: C: FORMAL 88-01-21 MODIFICATIONS: (MATS CARLSSON) C: CALLS CONTRIBUTION FUNCTION ROUTINES C: CALLS WRBMET C: C: 88-05-04 MODIFICATIONS: (MATS CARLSSON) C: CALLS WRJFIX C: DSCAL2 IS NOT CALLED IF NO TRANSITIONS ARE IN DETAIL C: C: 89-03-18 MODIFICATIONS: (MATS CARLSSON) C: EMAX PRINTOUT CHANGED TO INCLUDE SIGN AND C: LEVEL/TRANSITION AND DEPTH C: C: 90-07-31 MODIFICATIONS: (MATS CARLSSON) C: CALL TO WCHANG CHANGED TO INCLUDE DUMMY ARGUMENTS C: IN PLACE OF E,NK1 AND NDEP1 (E IS NOT USED IN WCHANG C: WHEN ICALL=2) C: C: 92-06-05 MODIFICATIONS: (MATS CARLSSON) C: TEST OF KREJ AND KEJ INCLUDED TO AVOID ACCESSING C: EJ(0,0) WHEN NRAD=0 C: C: 94-03-22 MODIFICATIONS: (MATS CARLSSON) C: IOPAC.GE.10 ALLOWED C: C: 95-08-16 MODIFICATIONS: (MATS CARLSSON) C: BOTH OLD PRINTOUT ROUTINES (TO FILE OUT) AND IDL PRINTOUT C: ROUTINES ARE CALLED C: C: 95-10-20 MODIFICATIONS: (MATS CARLSSON) C: ERROR CAUSING CNTRB TO BE CALLED ONLY FOR IWLINE.LE.0 AND C: NOT WHEN IDLCNT.NE.0 CORRECTED C: INCLUDE 'PREC' INCLUDE 'PARAM' INCLUDE 'CATOM' INCLUDE 'CATMOS' INCLUDE 'CATMO2' INCLUDE 'CTRAN' INCLUDE 'CSLINE' INCLUDE 'CGAUSI' INCLUDE 'CCONST' INCLUDE 'CINPUT' INCLUDE 'CLGMX' INCLUDE 'CTAUQQ' INCLUDE 'CLU' INCLUDE 'COPCL' C DIMENSION DUMMY(1,1) C CHARACTER*16 ETEXT C CALL CPUTIME('FORMAL',0,0,3) CALL WRSTRT IF(ICONV.EQ.1) THEN C C PRINT OPACITY DEPARTURE COEFFICIENTS C IF(MOD(IOPAC,10).EQ.3 .OR. MOD(IOPAC,10).EQ.4) CALL WRBMET C C GO THROUGH PRINTOUTS FIRST WITH ATOMIC MODEL ATOM THEN ATOM2 C DO 300 IRUN=1,2 IF(IRUN.EQ.2) THEN IF(IATOM2.EQ.0) GOTO 400 CALL ATOM2 ENDIF CALL TRPT IF(IRUN.EQ.1) THEN C* C* 89-03-18 START MODIFICATION C STORE KR INDEX FOR MAX CHANGE IN KREJ, K INDEX IN KEJ C KREJ=0 KEJ=0 EMAXJ=0. DO 24 KR=1,NRAD DO 22 K=1,NDEP IF(ABS(EJ(KR,K)).GT.EMAXJ) THEN KREJ=KR KEJ=K EMAXJ=ABS(EJ(KR,K)) ENDIF 22 CONTINUE 24 CONTINUE IF(KREJ.GT.0 .AND. KEJ.GT.0) EMAXJ=EJ(KREJ,KEJ) WRITE(ETEXT,25) KREJ,KEJ 25 FORMAT('EMAXJ(',I4,',',I4,')') CALL WCHANG(DUMMY,1,1,2) CALL WEMAX(ETEXT,EMAXJ) ENDIF CALL TRCONT CALL WN CALL REWIND(LOPC) C C PRINT EQUIVALENT WIDTHS C IF(IWEQW.NE.0) THEN DO 30 KR=1,NLINE CALL EQWDTH(WW,KR) WEQ(KR)=WW 30 CONTINUE CALL WEQW ENDIF C DO 200 KR=1,NRAD C C FIND NY FOR LINECENTER C NY0=1 QMIN=ABS(Q(1,KR)) DO 50 NY=1,NQ(KR) IF(ABS(Q(NY,KR)).LT.QMIN) THEN NY0=NY QMIN=ABS(Q(NY,KR)) ENDIF 50 CONTINUE C C PRINT LINE INFORMATION FOR LINE CENTER AND MU=1 C PRINT TAUNY SCALES C DO 100 NY=1,NQ(KR) CALL READX IF(IWLINE.LT.0 .OR. IDLCNT.NE.0) CALL CNTRB(NY,KR) IF(IWLINE.NE.0 .AND. NY.EQ.NY0) THEN CALL TAUNYQ(NY,KR) IF(KR.LE.NLINE) THEN CALL RWING(KR) CALL WLINE(KR) ELSE CALL WCONT(KR) ENDIF ELSE IF(IWTAUQ.NE.0) THEN CALL TAUNYQ(NY,KR) ENDIF 100 CONTINUE CALL WTAUQQ(KR) CALL WCNTRB(KR) CALL WIDLCN(KR) 200 CONTINUE IF(NRAD.NE.0) CALL DSCAL2 CALL WLGMX CALL WRAD CALL WIDL1 IF(IRUN.EQ.1) THEN CALL WRATE CALL WATHSE ENDIF 300 CONTINUE ELSE CALL WN ENDIF 400 CONTINUE CALL WRJFIX CALL CPUTIME('FORMAL',0,2,3) RETURN END C C*********************************************************************** C SUBROUTINE RDBMET C C READS DEPARTURE COEFFICIENTS OF BACKGROUND ABSORBERS C READS IONIZATION FRACTIONS FOR NON-LTE ELEMENTS C: C: RDBMET 88-01-21 NEW ROUTINE: (MATS CARLSSON, PHILIP JUDGE) C: READS DEPARTURE COEFFICIENTS OF BACKGROUND ABSORBERS C: UPPSALA OPACITY PACKAGE INTERFACE ROUTINE C: C: 88-03-01 ALTERATIONS: (PHILIP JUDGE) C: ALSO READS COMPUTED PARTITION FUNCTIONS FOR CONSISTENCY C: THESE ARE STORED IN ZNLTE C: C: 89-03-23 MODIFICATIONS: (MATS CARLSSON) C: SETS FRCION TO 0.0 FOR THE IONIZATION STAGES NOT INCLUDED C: IN BMET FOR ALL ELEMENTS WITH DATA IN BMET C: C: 92-08-10 MODIFICATIONS (MATS CARLSSON) C: INTEGER ARRAYS WITH ELEMENT NAME CHANGED TO CHARACTER ARRAYS C: INCLUDE 'PREC' INCLUDE 'PARAM' INCLUDE 'CATOM' INCLUDE 'CATMOS' INCLUDE 'CATMO2' INCLUDE 'CSLINE' INCLUDE 'CCONST' INCLUDE 'CINPUT' INCLUDE 'CLU' C PARAMETER (MEL=16,MJMAX=90,MKMAX=140,MLMAX=400,MJ=5) PARAMETER (MT=300,MKOMP=150,ML=50000,MSET=1,MLATB=50,MTETB=30, * MELMAX=2,MKOMPR=MKOMP,MKOMPT=10, * KFADIM=MKOMPR*MT+MKOMPT*MT*3,IFADIM=MKOMPT*MT) C COMMON/CI1/FL2(5),PARCO(MJMAX),PARQ(4*MJMAX),SHXIJ(5),TPARF(4), *XIONG(MEL,MJ),EEV,ENAMN,SUMH,XKBOL,SUMM,NJ(MEL),NEL CHARACTER*3 CEL COMMON/CC1/CEL(MEL) C COMMON/CA2/ABKOF(30000000),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP C CHARACTER*20 ABNAME,LVNAME COMMON/CNAME/ ABNAME(MKOMP),LVNAME(MKOMP) C COMMON/CBMET/ BMET(MT,MKOMP-23),BMETP(MT,MKOMP-23), * FRCION(MEL,MJ,MT),ZNLTE(MEL,MJ,MT) C CHARACTER*20 LBNAME,TEXT PARAMETER (MIN=200,MIONST=5) DIMENSION CMIN(MIN),TAUIN(MIN),BIN(MIN),BPIN(MIN) DIMENSION DP(MDEP),DPIN(MIN),FRCIN(MIONST,MIN), * ZIN(MIONST,MIN) INTEGER IONST(MIONST) C WRITE(LOUT,1002) 1002 FORMAT(/' AS WELL AS HYDROGEN (FROM FILE ''ATMOS''),'/ * ' THE FOLLOWING ABSORBERS ARE TREATED OUT OF LTE: '//) C* CALL OPEN(LUBMET,'BMET',0,'OLD') C C PUT LOG DEPTH-SCALE IN DP C IF(DPTYPE.EQ.'M') THEN DO 50 K=1,NDEP DP(K)=LOG10(CMASS(K)) 50 CONTINUE ELSE DO 60 K=1,NDEP DP(K)=LOG10(TAU(K)) 60 CONTINUE ENDIF C* C* OUTPUT: C* 100 CONTINUE READ(LUBMET,END=900) LBNAME 200 FORMAT(A) CALL LJUST(LBNAME) IF(LBNAME(1:20).EQ.'IONIZATION FRACTIONS') GOTO 501 READ(LUBMET) NIN IF(NIN.GT.MIN) THEN WRITE(LJOBLO,210) LBNAME 210 FORMAT(' RDBMET: ABSORBERS: NIN.GT.MIN ',A) CALL STOP(' ') ENDIF C* DO 270 K=1,NIN READ(LUBMET) CMIN(K),TAUIN(K),BIN(K),BPIN(K) 270 CONTINUE C* C C CHECK TO SEE IF LBNAME CORRESPONDS TO A BACKGROUND ABSORBER C DO 300 KOMP=17,NKOMP-6 IF(LBNAME.EQ.LVNAME(KOMP)) GOTO 310 300 CONTINUE WRITE(LJOBLO,305) LBNAME 305 FORMAT(' RDBMET: WARNING: ABSORBER FOUND IN THE BMET FILE'/ * ' BUT NOT IN THE ABSDAT FILE :',A) GOTO 100 C C INTERPOLATE AND FILL BMET AND BMETP C 310 CONTINUE WRITE(LOUT,315) LBNAME 315 FORMAT(' ',A) IF(DPTYPE.EQ.'M') THEN DO 320 K=1,NIN DPIN(K)=CMIN(K) 320 CONTINUE ELSE DO 330 K=1,NIN DPIN(K)=TAUIN(K) 330 CONTINUE ENDIF C C LINEAR INTERPOLATION. OUTSIDE RANGE, SET VALUE TO LAST KNOWN C L=1 DO 400 K=1,NDEP IF(DP(K).LT.DPIN(1)) THEN BMET(K,KOMP-16)=BIN(1) BMETP(K,KOMP-16)=BPIN(1) ELSE IF(DP(K).GT.DPIN(NIN)) THEN BMET(K,KOMP-16)=BIN(NIN) BMETP(K,KOMP-16)=BPIN(NIN) ELSE 350 CONTINUE L=L+1 IF(DP(K).GT.DPIN(L)) GOTO 350 APOL=(DP(K)-DPIN(L-1))/(DPIN(L)-DPIN(L-1)) BMET(K,KOMP-16)=BIN(L-1)+APOL*(BIN(L)-BIN(L-1)) BMETP(K,KOMP-16)=BPIN(L-1)+APOL*(BPIN(L)-BPIN(L-1)) L=L-1 ENDIF 400 CONTINUE GOTO 100 C C IONIZATION FRACTIONS C 501 WRITE(LOUT,1003) 1003 FORMAT(/' THE FOLLOWING ION STAGES ARE TREATED OUT OF LTE: '//) C* 500 CONTINUE READ(LUBMET,END=900) TEXT READ(LUBMET) NIN,NIONST,(IONST(I),I=1,NIONST) IF(NIN.GT.MIN) THEN WRITE(LJOBLO,510) TEXT 510 FORMAT(' RDBMET: IONIZATION: NIN.GT.MIN ',A) CALL STOP(' ') ENDIF IF(NIONST+1.GT.MIONST) THEN WRITE(LJOBLO,520) TEXT 520 FORMAT(' RDBMET: IONIZATION: NIONST+1.GT.MIONST ',A) CALL STOP(' ') ENDIF C* C* 88-06-19 (P. JUDGE) ASSUME NEXT IONIZATION STAGE IS PREVIOUS+1 C* IONST(NIONST+1)=IONST(NIONST)+1 C* 88-06-19 END C* DO 370 K=1,NIN READ(LUBMET) CMIN(K),TAUIN(K),(FRCIN(I,K),I=1,NIONST), * (ZIN(I,K),I=1,NIONST+1) 370 CONTINUE C* C C FIND ELEMENT INDEX (FIRST WORD IN TEXT IS ASSUMED TO BE ELEMENT NAME) C CALL GETWRD(TEXT,1,K1,K2) DO 610 IELMNT=1,NEL IF(TEXT(K1:K2).EQ.CEL(IELMNT)) GOTO 630 610 CONTINUE WRITE(LJOBLO,620) TEXT(K1:K2) 620 FORMAT(' RDBMET: WARNING: IONIZATION FRACTION ELEMENT FOUND', * ' IN BMET FILE'/' BUT NOT AMONG ELEMENTS: ',A) GOTO 500 C 630 CONTINUE C* C* 89-03-23 MODIFICATION C* PGJ ADDITION OF 88-03-01 GAVE INCORRECT ALIGNMENT OF PARTITION C* FUNCTION INPUT IN OPACITY PACKAGE. FRCION IS NOW SET TO 0.0 FOR C* ELEMENTS WITH DATA IN BMET BEFORE DATA IS INTERPOLATED IN ORDER C* TO TAKE OUT IONIZATION STAGES NOT CALCULATED BY MULTI C* OLD STATEMENT WAS NJ(IELMNT)=NIONST+1 C* REPLACED BY: C* DO 645 I=1,MJ DO 640 K=1,NDEP FRCION(IELMNT,I,K)=0.0 ZNLTE(IELMNT,I,K)=1.0 640 CONTINUE 645 CONTINUE C* 89-03-23 END C* WRITE(LOUT,650) CEL(IELMNT),IONST(1),IONST(NIONST)+1 650 FORMAT(' ',A,' ',I3,' - ',I3) C C INTERPOLATE C IF(DPTYPE.EQ.'M') THEN DO 720 K=1,NIN DPIN(K)=CMIN(K) 720 CONTINUE ELSE DO 730 K=1,NIN DPIN(K)=TAUIN(K) 730 CONTINUE ENDIF C C LINEAR INTERPOLATION. OUTSIDE RANGE, SET VALUE TO LAST KNOWN C* 88-06-19 MODIFICATIONS (P. JUDGE) C* SUM OVER NIONST+1 TO ALLOW INCLUSION OF MULTI-COMPUTED PARTITION FUNCTIONS C* C L=1 DO 800 K=1,NDEP IF(DP(K).LT.DPIN(1)) THEN DO 740 I=1,NIONST+1 IF(I .LE. NIONST) * FRCION(IELMNT,IONST(I),K)=FRCIN(I,1) ZNLTE(IELMNT,IONST(I),K)=ZIN(I,1) 740 CONTINUE ELSE IF(DP(K).GT.DPIN(NIN)) THEN DO 750 I=1,NIONST+1 IF(I .LE. NIONST) * FRCION(IELMNT,IONST(I),K)=FRCIN(I,NIN) ZNLTE(IELMNT,IONST(I),K)=ZIN(I,NIN) 750 CONTINUE ELSE 760 CONTINUE L=L+1 IF(DP(K).GT.DPIN(L)) GOTO 760 APOL=(DP(K)-DPIN(L-1))/(DPIN(L)-DPIN(L-1)) DO 770 I=1,NIONST+1 IF(I .LE. NIONST) * FRCION(IELMNT,IONST(I),K)=FRCIN(I,L-1) + * APOL*(FRCIN(I,L)-FRCIN(I,L-1)) ZNLTE(IELMNT,IONST(I),K)=ZIN(I,L-1) + * APOL*(ZIN(I,L)-ZIN(I,L-1)) 770 CONTINUE L=L-1 ENDIF C* END 88-06-19 ALTERATIONS 800 CONTINUE GOTO 500 C 900 CONTINUE WRITE(LOUT,1004) 1004 FORMAT(/' ALL ADDITIONAL ABSORBERS ARE TREATED IN LTE: '//) C* CALL CLOSE(LUBMET) END C C*********************************************************************** C SUBROUTINE WRBMET C C WRITES DEPARTURE COEFFICIENTS OF BACKGROUND ABSORBERS C WRITES IONIZATION FRACTIONS C: C: WRBMET 88-01-21 NEW ROUTINE: (MATS CARLSSON) C: WRITES DEPARTURE COEFFICIENTS OF BACKGROUND ABSORBERS C: UPPSALA OPACITY PACKAGE INTERFACE ROUTINE C: C: 88-03-01 ALTERATIONS: (PHILIP JUDGE) C: ALSO WRITES COMPUTED PARTITION FUNCTIONS FOR CONSISTENCY C: C: 89-03-23 MODIFICATIONS: (MATS CARLSSON) C: USES ONLY FIRST WORD IN ATOMID TO CHECK IF OLD BMET ENTRY C: SHOULD BE REPLACED WITH THE ONE NOW CALCULATED C: C: 94-03-22 MODIFICATIONS: (MATS CARLSSON) C: IOPAC.GE.10 ALLOWED C: INCLUDE 'PREC' INCLUDE 'PARAM' INCLUDE 'CATOM' INCLUDE 'CATMOS' INCLUDE 'CATMO2' INCLUDE 'CSLINE' INCLUDE 'CCONST' INCLUDE 'CINPUT' INCLUDE 'CLU' C PARAMETER (MEL=16,MJMAX=90,MKMAX=140,MLMAX=400,MJ=5) PARAMETER (MT=300,MKOMP=150,ML=50000,MSET=1,MLATB=50,MTETB=30, * MELMAX=2,MKOMPR=MKOMP,MKOMPT=10, * KFADIM=MKOMPR*MT+MKOMPT*MT*3,IFADIM=MKOMPT*MT) C COMMON/CA2/ABKOF(30000000),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP C CHARACTER*20 ABNAME,LVNAME COMMON/CNAME/ ABNAME(MKOMP),LVNAME(MKOMP) C COMMON/ CBMET/BMET(MT,MKOMP-23),BMETP(MT,MKOMP-23), * FRCION(MEL,MJ,MT),ZNLTE(MEL,MJ,MT) C PARAMETER (MION=10) CHARACTER*20 TEXT DIMENSION ANION(MION),ZION(MION) INTEGER IONST(MION) C C UPDATE BMET AND BMETP WITH CURRENTLY CALCULATED CONTINUA C WRITE THOSE VALUES TO FILE BMET2 C CALL OPEN(LUBMET,'BMET2',0,'NEW') DO 300 I=1,NK-1 C C FIND CONTINUUM ASSOCIATED WITH EACH BOUND LEVEL. THIS IS ASSUMED TO BE C THE LOWEST LYING LEVEL WITH AN IONIZATION STAGE OF ION(I)+1 C DO 100 J=2,NK IF(ION(J).EQ.ION(I)+1) GOTO 150 100 CONTINUE WRITE(LJOBLO,110) I 110 FORMAT(' WRBMET: NO CONTINUUM FOUND FOR LEVEL ',I3) CALL STOP(' ') 150 CONTINUE DO 200 KOMP=17,NKOMP-6 IF(LVNAME(KOMP).EQ.LABEL(I)) GOTO 210 200 CONTINUE C* C* 89-03-11 MODIFICATIONS (PHILIP JUDGE) C* OUTPUT A WARNING WHEN UNKNOWN OPACITY SOURCE COMPUTED. C* THESE LEVELS EXIST IN THE ATOM COMPUTED ION DETAIL C* BUT HAVE NO CORRESPONDENCE WITH THE DATA IN THE ABSDAT FILE. C* WRITE(LJOBLO,1001)LABEL(I) 1001 FORMAT(' WRBMET: WARNING- LEVEL ',A,', COMPUTED IN', * ' DETAIL,'/' DOES NOT EXIST IN THE ABSDAT OPACITY FILE') C* 89-03-11 MODIFICATIONS END (PHILIP JUDGE) C* GOTO 300 210 CONTINUE DO 250 K=1,NDEP BMET(K,KOMP-16)=N(I,K)/NSTAR(I,K) BMETP(K,KOMP-16)=N(J,K)/NSTAR(J,K) 250 CONTINUE WRITE(LUBMET) LVNAME(KOMP) WRITE(LUBMET) NDEP DO 270 K=1,NDEP WRITE(LUBMET) LOG10(CMASS(K)),LOG10(TAU(K)), * BMET(K,KOMP-16),BMETP(K,KOMP-16) 270 CONTINUE 300 CONTINUE C C IF IOPAC=3, COPY THE VALUES FROM THE BMET FILE THAT HAVE NOT C BEEN REPLACED WITH NEWER VALUES C IF(MOD(IOPAC,10).EQ.3) THEN CALL OPEN(LUOLD,'BMET',0,'OLD') 310 CONTINUE C C READ OLD BMET FILE C READ(LUOLD,END=500) TEXT CALL LJUST(TEXT) IF(TEXT(1:20).EQ.'IONIZATION FRACTIONS') GOTO 500 DO 330 I=1,NK-1 IF(TEXT.EQ.LABEL(I)) THEN READ(LUOLD) NIN DO 325 K=1,NIN READ(LUOLD) CLG,TAULG,BM,BMP 325 CONTINUE GOTO 310 ENDIF 330 CONTINUE C C DEPARTURE COEFFICIENTS NOT CALCULATED NOW. PRINT OLD VALUES C WRITE(LUBMET) TEXT READ(LUOLD) NIN WRITE(LUBMET) NIN DO 340 K=1,NIN READ(LUOLD) CLG,TAULG,BM,BMP WRITE(LUBMET) CLG,TAULG,BM,BMP 340 CONTINUE GOTO 310 ENDIF C C IONIZATION FRACTIONS C 500 CONTINUE TEXT='IONIZATION FRACTIONS' WRITE(LUBMET) TEXT(1:20) IF(ATOMID(1:1).EQ.'H') GOTO 900 C C WRITE IONIZATION FRACTIONS OF ELEMENT CALCULATED C C FIND LOWEST AND HIGHEST IONIZATION STAGE C MINION=100 MAXION=0 DO 520 I=1,NK MINION=MIN(MINION,ION(I)) MAXION=MAX(MAXION,ION(I)) 520 CONTINUE IF(MAXION.GT.MION) CALL STOP('WRBMET: MAXION.GT.MION') WRITE(LUBMET) ATOMID WRITE(LUBMET) NDEP,MAXION-MINION,(I,I=MINION,MAXION-1) DO 600 K=1,NDEP DO 550 I=MINION,MAXION ANION(I)=0.0 ZION(I)=0.0 550 CONTINUE ICONT=1 DO 560 J=1,NK I=ION(J) ANION(I)=ANION(I)+N(J,K) C* C* ADDED BY PGJ IF(J.GT.1 .AND. ION(J).EQ.ION(J-1)+1) ICONT=J BIG=37.0 DEN=MIN(EE*(EV(J)-EV(ICONT))/BK/TEMP(K),BIG) ZION(I)=ZION(I)+G(J)*EXP(-DEN) C* END PGJ ADDITION C* 560 CONTINUE WRITE(LUBMET) LOG10(CMASS(K)),LOG10(TAU(K)), * (ANION(I+1)/ANION(I),I=MINION,MAXION-1), * (ZION(I),I=MINION,MAXION) 600 CONTINUE C C IF IOPAC=3, COPY THE VALUES FROM THE BMET FILE THAT HAVE NOT C BEEN REPLACED WITH NEWER VALUES C IF(MOD(IOPAC,10).EQ.3) THEN 610 CONTINUE READ(LUOLD,END=900) TEXT C C COMPARE FIRST WORD IN TEXT WITH FIRST WORD OF ATOM ID TO FIND OUT C IF ELEMENT IN RDBMET IS THE SAME AS THE ONE NOW TREATED IN DETAIL C CALL GETWRD(TEXT,1,K1,K2) CALL GETWRD(ATOMID,1,K11,K22) IF(TEXT(K1:K2).EQ.ATOMID(K11:K22)) THEN READ(LUOLD) NIN,NIONST,(IDUM,I=1,NIONST) IF(NIONST.GT.MION) THEN WRITE(LJOBLO,620) TEXT 620 FORMAT(' WRBMET: IONIZATION: NIONST.GT.MION ',A) CALL STOP(' ') ENDIF DO 630 K=1,NIN READ(LUOLD) CLG,TAULG,(ANION(I),I=1,NIONST), * (ZION(I),I=1,NIONST+1) 630 CONTINUE GOTO 610 ENDIF C C IONIZATION FRACTIONS NOT CALCULATED NOW, PRINT OLD VALUES C WRITE(LUBMET) TEXT READ(LUOLD) NIN,NIONST,(IONST(J),J=1,NIONST) WRITE(LUBMET) NIN,NIONST,(IONST(J),J=1,NIONST) DO 700 K=1,NIN READ(LUOLD) CLG,TAULG,(ANION(I),I=1,NIONST), * (ZION(I),I=1,NIONST+1) WRITE(LUBMET) CLG,TAULG,(ANION(I),I=1,NIONST), * (ZION(I),I=1,NIONST+1) 700 CONTINUE GOTO 610 ENDIF C 900 CONTINUE IF(MOD(IOPAC,10).EQ.3) CALL CLOSE(LUOLD) CALL CLOSE(LUBMET) END C C*********************************************************************** C FUNCTION ELCNTM(K,T,PE) C C RETURNS THE NUMBER OF FREE ELECTRONS PER HYDROGEN NUCLEUS C CONTRIBUTED BY ELEMENTS OTHER THAN HYDROGEN C: C: ELCNTM 88-01-20 NEW ROUTINE: (MATS CARLSSON) C: UPPSALA OPACITY PACKAGE INTERFACE ROUTINE C: C: 89-03-24 MODIFICATIONS: (MATS CARLSSON) C: DEPTH POINT INDEX K PASSED AS AN ARGUMENT TO ENABLE CORRECT C: BMET VALUES TO BE USED BY JON C: C: IEPRO CHANGED TO 1 TO ENABLE MOLECULE CALCULATION IN JON C: C INCLUDE 'PREC' COMMON /CXNENH/ XNENH C IOUTR=0 IEPRO=1 CALL JON(K,T,PE,IEPRO,PGDUM,RODUM,EDUM,IOUTR) C ELCNTM=XNENH END C C*********************************************************************** C SUBROUTINE OPINIT C C INITIALIZES OPACITY PACKAGE C: C: OPINIT 88-01-21 MODIFICATIONS: (MATS CARLSSON) C: UPPSALA OPACITY PACKAGE INTERFACE ROUTINE C: C: 88-06-22 MODIFICATIONS: (MATS CARLSSON) C: CLOSES INPUT FILES IF THEY ARE OPEN MAKING MULTIPLE C: CALLS POSSIBLE C: C: 90-11-08 MODIFICATIONS: (MATS CARLSSON) C: ABNAME CHANGED TO NOT INCLUDE LEADING / C: ABNAME AND LVNAME THEREFORE IDENTICAL C: C: 94-03-24 MODIFICATIONS: (MATS CARLSSON) C: IOPAC.GE.10 ALLOWED, SIGNALS BACKGROUND OPACITY C: FROM LINES C: C: 95-08-04 MODIFICATIONS: (MATS CARLSSON) C: BACKGROUND OPACITY FROM LINES SIGNALLED BY IOPACL C: SOURCE FUNCTION OPTION TRANSFERRED TO OPACITY PACKAGE C WITH ISOUL IN CALIN C: INCLUDE 'PREC' INCLUDE 'PARAM' INCLUDE 'CATOM' INCLUDE 'CATMOS' INCLUDE 'CSLINE' INCLUDE 'CINPUT' INCLUDE 'CCONST' INCLUDE 'CLU' INCLUDE 'CALIN' C PARAMETER (MEL=16,MJMAX=90,MKMAX=140,MLMAX=400,MJ=5) PARAMETER (MT=300,MKOMP=150,ML=50000,MSET=1,MLATB=50,MTETB=30, * MELMAX=2,MKOMPR=MKOMP,MKOMPT=10, * KFADIM=MKOMPR*MT+MKOMPT*MT*3,IFADIM=MKOMPT*MT) C COMMON/CI1/FL2(5),PARCO(MJMAX),PARQ(4*MJMAX),SHXIJ(5),TPARF(4), *XIONG(MEL,MJ),EEV,ENAMN,SUMH,XKBOL,SUMM,NJ(MEL),NEL C COMMON/CA2/ABKOF(30000000),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP C COMMON/UTPUT/ IREAD, IWRIT C COMMON/CFIL/IRESET(MSET),ISLASK,IREAT C COMMON/COUTR/ NTO,NTPO(MT),IWOPTN C COMMON/CXLSET/NSET,NL(MSET),XL(ML,MSET) C COMMON /CBMET/BMET(MT,MKOMP-23),BMETP(MT,MKOMP-23), * FRCION(MEL,MJ,MT),ZNLTE(MEL,MJ,MT) C CHARACTER*20 ABNAME,LVNAME COMMON/CNAME/ ABNAME(MKOMP),LVNAME(MKOMP) C SAVE LABSDA,LDUMO1,LDUMO2 DATA LABSDA,LDUMO1,LDUMO2/0,0,0/ C ADD TM WRITE(*,*)' OPINIT ROUTINE STARTS NOW.' C END ADD TM C C CHECK DIMENSIONS C IF(NDEP.GT.MT) THEN WRITE(LJOBLO,40) NDEP,MT 40 FORMAT(' OPINIT: NDEP=',I4,' MT=',I4) CALL STOP('OPINIT: NDEP.GT.MT') ENDIF C* C* 17-04-88 PGJ ADDITION WRITE (LOUT,201) 201 FORMAT(' OPACITIES FROM UPPSALA PACKAGE') C* END PGJ ADDITION C* C C OPEN ABSORPTION DATA INPUT FILE AND TEMPORARY FILES C ASSIGN OUTPUT TO OUT FILE C CLOSE FILES IF THEY ARE ALREADY OPEN C IF(LABSDA.NE.0) CALL CLOSE(LABSDA) IF(LDUMO1.NE.0) CALL CLOSE(LDUMO1) IF(LDUMO2.NE.0) CALL CLOSE(LDUMO2) C CALL OPEN(LABSDA,'ABSDAT',1,'OLD') IWRIT=LOUT IREAD=LABSDA IREAT=LABSDA CALL OPEN(LDUMO1,'DUMO1',0,'NEW') CALL OPEN(LDUMO2,'DUMO2',0,'NEW') ISLASK=LDUMO1 IRESET(1)=LDUMO2 C C FILL WAVELENGTH ARRAY C NSET=1 L=1 DO 50 KR=1,NRAD IF(.NOT.IWIDE(KR)) THEN L=L+1 ELSE L=L+NQ(KR) ENDIF 50 CONTINUE IF(L.GT.ML) THEN WRITE(LJOBLO,70) L,ML 70 FORMAT(' OPINIT: L=',I7,' ML=',I7) CALL STOP('OPINIT: TOO MANY WAVELENGTHS') ENDIF L=1 XL(1,1)=5000. DO 200 KR=1,NRAD IF(.NOT.IWIDE(KR)) THEN L=L+1 XL(L,1)=ALAMB(KR) ELSE KT=KTRANS(KR) DO 100 NY=1,NQ(KR) L=L+1 XL(L,1)=CC/FRQ(NY,KT)*1.E8 100 CONTINUE ENDIF 200 CONTINUE NL(1)=L C IOUTS=0 CALL CPUTIME('INJON ',0,0,1) CALL INJON(IOUTS) CALL CPUTIME('INJON ',0,1,1) CALL INABS(IOUTS) CALL CPUTIME('INABS ',0,1,1) C C READ BACKGROUND LINE OPACITIES IF IOPACL.NE.0 C TRANSFER QNORM TO OPACITY PACKAGE THROUGH QNORML IN CALIN C TRANSFER SOURCE FUNCTION OPTION TO OPACITY PACKAGE C THROUGH ISOUL IN CALIN C QNORML=QNORM ISOUL=IOPACL NLL=0 IF(IOPACL.NE.0) CALL INLIN CALL CPUTIME('INLIN ',0,1,1) C C FILL ARRAY WITH INDICES WHERE PRINTOUT IS WANTED C IF ATOM IS HYDROGEN AND HSE INTEGRATIONS ARE PERFORMED THEN C THE PRINTOUT IS SET BY HSEINT WHEN THE HSE INTEGRATIONS HAVE C CONVERGED. C IWOPTN GOVERNS PRINTOUT, BINARY SWITCHES: C 1 OPACITY CONTRIBUTIONS C 2 PARTIAL PRESSURES C 4 IONIZATION FRACTIONS, PARTITION FUNCTIONS C IWOPAC.LT.0 GIVES IWOPTN=7, IWOPAC.GT.0 GIVES IWOPTN=1 C M=0 IF(IWOPAC.NE.0) THEN ISTEP=ABS(IWOPAC) DO 300 L=1,NDEP,ISTEP M=M+1 NTPO(M)=L 300 CONTINUE ENDIF NTO=M IF(IHSE.EQ.0 .OR. ATOMID.NE.'H') THEN IF(IWOPAC.GT.0) THEN IWOPTN=1 ELSE IWOPTN=7 ENDIF ELSE IWOPTN=0 ENDIF C C INITIALIZE BMET AND BMETP ARRAYS TO 1.0 C DO 500 KOMP=17,NKOMP-6 DO 400 K=1,NDEP BMET(K,KOMP-16)=1.0 BMETP(K,KOMP-16)=1.0 400 CONTINUE 500 CONTINUE C C INITIALIZE FRCION ARRAY TO -1. C DO 800 K=1,NDEP DO 700 J=1,MJ DO 600 I=1,MEL FRCION(I,J,K)=-1.0 600 CONTINUE 700 CONTINUE 800 CONTINUE C C READ BMET FILE IF IOPAC = 2 OR 3 C IF(MOD(IOPAC,10).EQ.2 .OR. MOD(IOPAC,10).EQ.3) THEN CALL RDBMET ENDIF C ADD TM WRITE(*,*)' OPINIT ROUTINE EXECUTED.' C END ADD TM C END C C*********************************************************************** C