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 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(IFADIM),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. include 'spectrum.inc' C C PARAMETER (KFADIM=4000,IFADIM=1000) logical first DIMENSION TSKAL(NDP),PESKAL(NDP),ABSK(NDP),SPRID(NDP) DIMENSION FAKTP(ifadim) DIMENSION SUMW(NDP) dimension tioabs(ndp),h2oabs(ndp) COMMON/UTPUT/IREAD,IWRIT COMMON/CA2/ABKOF(nabdim),KOMPLA(mkomp*20),KOMPR,KOMPS,NKOMP COMMON/CA3/ILOGTA(mkomp),NULL COMMON/CA4/AFAK(KFADIM),NOFAK(IFADIM),NPLATS(IFADIM) COMMON/CA5/AB(mkomp),FAKT(mkomp),PE(NDP),T(NDP),XLA(20),XLA3(20), & RO, & SUMABS,SUMSCA,VIKTR,ISET,NLB COMMON/CFIL/IRESET(numbset),ISLASK,IREAT COMMON/COUTR/NTO,NTPO(10) COMMON/CROS/ROSW(20) COMMON /CARC3/ F1P,F3P,F4P,F5P,HNIC,PRESMO(30) COMMON /CARC4/ PROV(mkomp),NPROVA,NPROVS,NPROV COMMON /TIO/PTIO(NDP),ROsav(NDP),POXG1(NDP) COMMON/CI4/ IELEM(16),ION(16,5),TMOLIM,MOLH COMMON/CMOL1/EH,FE,FH,FHE,FC,FCE,FN,FNE,FO,FOE,FK,FKE,FS,FSE COMMON /DENSTY/ ROTEST(NDP),PRH2O(NDP) data first/.true./ save first C C if (first) then newt=2 first=.false. endif 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 C if(j.le.0) then C molhs=molh C molh =0 C endif c print*,'calling jon, t,pe ',t(ntp),pe(ntp) CALL JON(T(NTP),PE(NTP),1,PG,RO,DUM,IOUTR,ntp) C if(j.le.0) then C molh=molhs C rosav(ntp)=ro C poxg1(ntp)=pe(ntp)*foe C prh2o(ntp)=presmo(4) C endif 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 CASE OF ROSSELAND MEAN. THIS C LOOP ENDS IN STATEMENT NO. 26 10 CONTINUE C if(j.le.0) call tioeq(nt,t,pe) DO26 JP=J1,J2 KFAK=1 IFAK=1 KP=1 C if(j.le.0) then C call tioop(xla(jp),nt,t,tioabs) C call water(xla(jp),nt,t,h2oabs) C endif 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 C print*, 'nkomp = ',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 print*,'osabsko.f faktp(',ifak,')= ',faktp(ifak) 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 CONTINUE C if(j.le.0) sumabs=sumabs + tioabs(ntp) + h2oabs(ntp) IF(J.EQ.0) ABSK(NTP)=ABSK(NTP)+ROSW(JP)*VIKTR/(SUMABS+SUMSCA) IF(J.LT.0) ABSK(NTP)=ABSK(NTP)+ROSW(JP)*VIKTR/SUMABS 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 DO28 NTP=1,NT SPRID(NTP)=0. 28 ABSK(NTP)=SUMW(NTP)/ABSK(NTP) C 29 CONTINUE RETURN END