c subroutine solred(ifrst,stl,zpht,xno,xno2,xnn2,tn,f107,f107a, + day,glat,glong,kmx,sr63,qn2p,qop,glyb) c c 2/7/91: These routines obtained from Ray Roble for use in station (loc) c processor. SR63(kmx) is returned. It is added to VER (volume c emission rate) in doptuv.f to be contoured (zp vs ut). c (the routines are: solred, ssflux, column, and tancomp) c 10/11/93: c Modified to remove /TGCMPAR/ common (variables in tgcmpar are now c passed in calls to avoid parameter kmx) c 7/11/95: c Return if solar zenith angle (ZI) > 110 deg. c c (B. Foster) c dimension zpht(kmx),xno(kmx),xno2(kmx),tn(kmx),xnn2(kmx) dimension sht(kmx),gz(kmx),cno(kmx),cno2(kmx),cnn2(kmx),rho(kmx) DIMENSION WAVE1(59),WAVE2(59),SFLUX(59) COMMON/CROSTRF/SIGABS(9,59),SIGION(13,59) DIMENSION BRN2(59),BRO2(59) DIMENSION SR63(KMX),QTIN(KMX),QSR(KMX),QO2P(KMX),QN2P(KMX), 1QOP(KMX),glyb(kmx) dimension txno(kmx),txno2(kmx),txnn2(kmx) DATA BRN2/ + 36 * 0.00, + 0.01, 0.04, 0.04, 0.03, 0.05, 0.05, + 0.15, 0.20, 0.20, 0.25, 0.32, 0.34, + 11 * 0.36/ DATA BRO2/ + 30 * 0.00, + .025, .036, .045, .120, .155, .189, + .230, 0.20, 0.20, 0.20, 0.23, 0.25, + 0.29, 16 * 0.33/ c ISCALE=0 ! write(6,"('solred: f107=',e12.4,' f107a=',e12.4)") f107,f107a CALL SSFLUX(ISCALE,F107,F107A,WAVE1,WAVE2,SFLUX,IFRST) DTOR=ATAN(1.)/45. RTOD=1./DTOR RE=6371.E+5 PI=180./RTOD BOLTZ=1.38E-16 A6300=5.15E-3 A1D=6.81E-3 QUENCH=2.3E-11 ERG=1.602E-12 C1=23.5*DTOR DO 1 K=1,KMX sr63(k) = 0. glyb(k) = 1.e-20 ! 5th component of e5577 QOP(K)=0. QO2P(K)=0. QN2P(K)=0. QTIN(K)=1.E-20 QSR(K)=1.E-20 GZ(K)=980.665*(1.-3.14466E-4*ZPHT(K)) RHO(K)=(32.*XNO2(K)+28.*XNN2(K)+16.*XNO(K))*1.66E-24 XMB=(28.*XNN2(K)+32.*XNO2(K)+16.*XNO(K))/(XNN2(K)+ + XNO2(K)+XNO(K)) SHT(K)=BOLTZ*TN(K)/(XMB*GZ(K)*1.66E-24) 1 CONTINUE c c ut (first arg in column) apparently not used: call column(0.,zpht,xno,xno2,tn,xnn2,sht,gz,cno,cno2,cnn2,kmx) DLE=ATAN(TAN(C1)*SIN(2.*PI*(DAY-80.)/365.)) DLES=SIN(DLE) DLEC=COS(DLE) GLATR=GLAT*DTOR GLONR=GLONG*DTOR SECZI=1./(DLES*SIN(GLATR)+COS(GLATR)*COS(PI*(STL-12.)/12.)*DLEC) ZI=ACOS(1./SECZI)*RTOD c c 7/11/95: Return if solar zenith angle > 110 deg: c (may need to initialize some other stuff) c if (zi.gt.110.) return C DO 3 K=1,KMX ALT=ZPHT(K) XP=(RE+ALT*1.E+5)/SHT(K) Y=0.5*XP*(COS(ZI*DTOR))**2 TT=SQRT(Y) IF(TT.GT.8.) GO TO 10 YERF=(1.0606963+0.55643831*TT)/(1.0619896+1.7245609*TT+TT*TT) GO TO 11 10 YERF=0.56498823/(0.06651874+TT) 11 CONTINUE IF(ZI.GT.90.) GO TO 12 CHAPS=SQRT(0.5*PI*XP)*YERF TXNO(K)=CNO(K)*CHAPS TXNO2(K)=CNO2(K)*CHAPS TXNN2(K)=CNN2(K)*CHAPS GO TO 13 12 CONTINUE RG=(RE+ALT*1.E+5)*SIN(ZI*DTOR) ZG=RG-RE IF(ZG.GT.10.E+5) GO TO 14 ZG=10.E+5 14 CONTINUE CALL TANCOMP(ZG,XMO2,XMN2,XMO,TMM,CNGO2,CNGN2,CNGO, + zpht,xno,xno2,tn,xnn2,sht,cno,cno2,cnn2,kmx) SHG=BOLTZ*TMM/(28.*1.66E-24*GZ(K)) BFD=0.5*PI*RG/SHG CHAPO=SQRT(BFD*16.) CHAO2=SQRT(BFD*32.) CHAN2=SQRT(BFD*28.) TXNO2(K)=CHAO2*(2.*CNGO2-XNO2(K)*SHG*YERF/32.) TXNN2(K)=CHAN2*(2.*CNGN2-XNN2(K)*SHG*YERF/28.) TXNO(K)=CHAPO*(2.*CNGO-XNO(K)*SHG*YERF/16.) 13 CONTINUE TAUR=SIGABS(1,49)*TXNO(K)+SIGABS(3,49)*TXNN2(K) 1+SIGABS(2,49)*TXNO2(K) TAUP=SIGABS(1,20)*TXNO(K)+SIGABS(3,20)*TXNN2(K) 1+SIGABS(2,20)*TXNO2(K) TAUR1=1.3*TAUR TAUR2=2.0*TAUR TAUR3=2.5*TAUR IF(TAUR.GT.9.) TAUR=9. IF(TAUP.GT.9.) TAUP=9. IF(TAUR1.GT.9.) TAUR1=9. IF(TAUR2.GT.9.) TAUR2=9. IF(TAUR3.GT.9.) TAUR3=9. CTAUR=EXP(-TAUR) CTAUR1=EXP(-TAUR1) CTAUR2=EXP(-TAUR2) CTAUR3=EXP(-TAUR3) CTAUP=EXP(-TAUP) RSP=2.4*CTAUR/(CTAUR+2.*(CTAUR1+CTAUR2+CTAUR3)) RSQ=1.5*CTAUR/(CTAUR+2.*(CTAUR1+CTAUR2+CTAUR3)+TAUP/TAUR*CTAUP) CSPI=1.0+RSP CSPJ=1.0+RSQ c c glyb(kmx) = photo dissociation of o2 by solar lyman-beta, returned c for use as 5th source of greenline e5577 emission: c taubt = sigabs(1,17)*txno(k)+sigabs(2,17)*txno2(k)+ + sigabs(3,17)*txnn2(k) glyb(k) = 0.1*sflux(17)*xno2(k)*sigabs(2,17)*exp(-taubt) ! write(6,"('solred: k=',i3,' glyb=',e12.4)") k,glyb(k) c DO 7633 L=1,59 TAU=SIGABS(1,L)*TXNO(K)+SIGABS(2,L)*TXNO2(K)+SIGABS(3,L)* + TXNN2(K) CTAU=EXP(-TAU) THNG1=XNO2(K)*SIGION(2,L)*CTAU*SFLUX(L) THNG2=XNN2(K)*SIGION(3,L)*CTAU*SFLUX(L) THNG3=XNO(K)*SIGION(1,L)*CTAU*SFLUX(L) QO2P(K)=QO2P(K)+THNG1*(1.-BRO2(L)+RSQ) QN2P(K)=QN2P(K)+THNG2*(1.-BRN2(L)+RSP) QOP(K)=QOP(K)+THNG3*(1.+RSP)+THNG1*BRO2(L) IF(L.GT.11) GO TO 7633 TAU=SIGABS(2,L)*TXNO2(K) THNG=SFLUX(L)*SIGABS(2,L)*EXP(-TAU) SR63(K)=SR63(K)+XNO2(K)*THNG*A6300/(A1D*(1.+QUENCH*XNN2(K)/A1D)) 7633 CONTINUE QTIN(K)=QO2P(K)+QN2P(K)+QOP(K) 3 continue RETURN END SUBROUTINE SSFLUX(ISCALE, F107, F107A, WAVE1, WAVE2, SFLUX,ITIMET) SAVE C PARAMETER (LM=59,LMAX=59) C Subroutine SSFLUX scales the solar flux according to the 10.7 cm fl C F107 and the 81-day centered average 10.7 cm flux F107A. The longwave C boundary WAVE1 and shortwave boundary WAVE2 of the wavelenth bins are C returned (Angstroms), and the solar flux in photons cm-2 s-1 returned C in SFLUX. C If ISCALE=0 the flux is scaled using parameterization methods based C F107 and F107A. For ionizing EUV, Hinteregger's contrast ratio method C is used, based on the Torr and Torr (JGR 90, 6675, 1985) bin structure C for reference spectrum SC#21REFW. The 1026A (H LyB) and 335A (FeXVI) C enhancement ratios are calculated from Hinteregger's formula, using th C coefficients which reduce to the reference values at F107=71.5, C F107A=75.4. The 'best fit' coefficients are not used as they produce C negative values at low solar activity, but remain in a 'commented out' C data statement for reference. The rest of the spectrum is then calcul C from these key emissions using Hinteregger's method. Scaling factors C were calculated by the author from contrast ratios in the original C spectrum data file. For FUV in the 1050A-1350A region, 50A interval C averaging was done by the author from SC#21REFW, and scaling factors C also calculated. This is a mere place holder since 50A bins are not C adequate for actual band calculations in this region. For Lyman alpha C which is treated seperately as an individual line, Rottman's C paraterization cited by Bossy (PSS 31, 977, 1983) is used. For the C SR continuum, the Torr et al. (JGR 80, 6063, 1980) parameterization C is used with the coefficients adjusted to reflect the measurements of C (JGR 86, 6697, 1981), Mount et al. (JGR 85, 4271, 1980), and Mount and C Rottman (JGR 86, 9193, 1981; JGR 88, 5403, 1983; JGR 90, 13031, 1985). C (N.b. - the evidence from SME indicates that the change with solar act C of the SR continuum flux is much smaller than what is used here - pers C communication from Gary Rottman.) C If ISCALE=1 linear interpolation between high and low activity spect C is used, based on F107 alone, and assuming that the low activity spect C corresponds to F107=68 and the high activitiy spectrum to F107=243. C The Hinteregger SC#21REFW and F79050 spectra as binned by Torr and Tor C are used for ionizing EUV. For the 1050A-1350A region, the SC#21REFW C spectrum averaged into 50A intervals is used for low solar activity; C the high activity spectrum was obtained by scaling this spectrum C using the contrast ratios. For Lyman alpha and the SR continuum, C linear interpolation amounts to the same thing as the aformentioned C parameterization. C In either case, the EUV fluxes between 250A and 50A are normalized C upwards (Richards and Torr, 1984). The normalization coefficient is 2 C at F107=68 and reduces linearly to 1 at F107=243. C X-ray fluxes shortwards of 50A are included, 10/88. The Hinteregge C fluxes were used to 18A; shortwards of there approximations taken from C notes are employed on a temporary basis. C C S.C. Solomon, 12/88 C C C Definitions: C ISCALE =0 for contrast ratio method, =1 for linear interpolation C F107 daily 10.7 cm flux C F107A 81-day centered average 10.7 cm flux C WAVE1 longwave bound of spectral intervals C WAVE2 shortwave bound of spectral intervals (= WAVE1 for indiv. lin C SFLUX scaled solar flux returned by subroutine C LMAX dimension of WAVE1, WAVE2, and SFLUX arrays, must be <= LM C WAVEL = WAVE1 C WAVES = WAVE2 C RFLUX low solar activity reference flux C XFLUX high solar activity flux C SCALE1 scaling factors for H LyB-keyed chromospheric emissions C SCALE2 scaling factors for FeXVI-keyed coronal emissions C LM dimension of above arrays, currently = 59 C SRA 'A' value for S-R continuum scaling formula C SRB 'B' value for S-R continuum scaling formula C B1 fit coefficients for H LyB C B2 fit coefficients for FeXVI C R1 enhancement ratio for H LyB C R2 enhancement ratio for FeXVI C SFNORM normalization factor for scaling flux shortwards of 250A C C C DIMENSION WAVE1(LMAX), WAVE2(LMAX), SFLUX(LMAX), > WAVEL(LM), WAVES(LM), RFLUX(LM), XFLUX(LM), > SCALE1(LM), SCALE2(LM), SRA(8), SRB(8), B1(3), B2(3) C DIMENSION SIGAO(59),SIGAO2(59),SIGAN2(59),SIGIO(59),SIGIN2(59), 1SIGIO2(59),SIGACO(59),SIGICO(59),SIGACO2(59),SIGICO2(59), 2SIGIO4S(59),SIGIO2D(59),SIGIO2P(59),SIGIO4P(59),SIGIO2Q(59), 3SIGIHE(59),SIGIN(59),SIGIH(59) c c include 'crostrf.h' COMMON/CROSTRF/SIGABS(9,59),SIGION(13,59) c C new B's: DATA B1/1.0, 0.0138, 0.005/, B2/1.0, 0.59425, 0.3811/ C C old B's, commented out: C DATA B1/1.31, 0.01106, 0.00492/, B2/-6.618, 0.66159, 0.38319/ C DATA WAVEL/ 1750.00, 1700.00, 1650.00, 1600.00, 1550.00, 1500.00, > 1450.00, 1400.00, 1350.00, 1300.00, 1250.00, 1215.67, > 1200.00, 1150.00, 1100.00, 1050.00, 1031.91, 1025.72, > 1000.00, 977.02, 950.00, 900.00, 850.00, 800.00, > 789.36, 770.41, 765.15, 750.00, 703.31, 700.00, > 650.00, 629.73, 609.76, 600.00, 584.33, 554.37, > 550.00, 500.00, 465.22, 450.00, 400.00, 368.07, > 350.00, 303.78, 303.31, 300.00, 284.15, 256.30, > 250.00, 200.00, 150.00, 100.00, 50.00, 32.00, > 23.00, 16.00, 8.00, 4.00, 2.00/ DATA WAVES/ 1700.00, 1650.00, 1600.00, 1550.00, 1500.00, 1450.00, > 1400.00, 1350.00, 1300.00, 1250.00, 1200.00, 1215.67, > 1150.00, 1100.00, 1050.00, 1000.00, 1031.91, 1025.72, > 950.00, 977.02, 900.00, 850.00, 800.00, 750.00, > 789.36, 770.41, 765.15, 700.00, 703.31, 650.00, > 600.00, 629.73, 609.76, 550.00, 584.33, 554.37, > 500.00, 450.00, 465.22, 400.00, 350.00, 368.07, > 300.00, 303.78, 303.31, 250.00, 284.15, 256.30, > 200.00, 150.00, 100.00, 50.00, 32.00, 23.00, > 16.00, 8.00, 4.00, 2.00, 1.00/ DATA RFLUX/ 370.45, 203.69, 96.00, 69.71, 50.70, 26.67, > 17.21, 8.26, 12.86, 4.10, 5.20, 333.80, > 2.78, 0.70, 3.07, 3.64, 3.18, 4.38, > 1.78, 5.96, 4.22, 4.43, 1.93, 0.87, > 0.79, 0.24, 0.20, 0.17, 0.39, 0.22, > 0.17, 1.50, 0.45, 0.48, 1.58, 0.80, > 0.51, 0.31, 0.18, 0.39, 0.21, 0.74, > 0.87, 6.00, 0.24, 0.84, 0.10, 0.27, > 0.92, 1.84, 0.13, 0.38, 0.0215, 0.0067, > 0.0009, 0.0003, 1.E-6, 3.E-9, 1.E-11/ DATA XFLUX/ 464.20, 241.50, 131.50, 101.90, 81.32, 48.71, > 37.16, 21.14, 30.70, 11.20, 12.00, 438.80, > 6.50, 1.60, 6.40, 8.66, 9.04, 13.12, > 4.42, 13.18, 12.03, 13.29, 5.01, 2.18, > 1.59, 0.67, 0.43, 0.43, 0.72, 0.46, > 0.48, 3.02, 1.46, 1.02, 4.86, 1.59, > 1.57, 1.67, 0.36, 0.99, 2.20, 1.39, > 5.63, 11.28, 2.50, 4.14, 3.16, 0.59, > 3.70, 4.85, 0.34, 1.15, 0.18, 0.08, > 0.025, 0.03, 1.E-3, 3.E-5, 1.E-6/ DATA SCALE1/35347.5, 33095.6, 18040.6, 13733.0, 12564.2, 7121.38, > 6608.74, 5779.89, 8009.80, 3186.34, 3033.78, 47555., > 1692.09, 405.95, 1516.20, 2731.70, 3314.57, 4375.00, > 1316.91, 3621.91, 3908.56, 4432.54, 1541.21, 531.73, > 364.83, 0.00, 116.00, 129.41, 162.48, 94.07, > 41.29, 709.50, 0.00, 268.47, 1561.05, 367.64, > 290.06, 184.36, 0.00, 86.15, 7.50, 0.00, > 0.00, 2220.00, 0.00, 61.00, 0.00, 86.95, > 206.00, 135.89, 60.35, 157.12, 7.06, 0.75, > 0.00, 0.00, 0.00, 0.00, 0.00/ DATA SCALE2/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, > 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, > 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, > 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, > 0.00, 5.34, 0.00, 0.00, 0.00, 0.54, > 3.30, 0.00, 12.60, 0.00, 0.00, 0.00, > 5.34, 11.63, 2.28, 5.56, 24.93, 8.16, > 60.69, 0.00, 28.20, 45.90, 40.80, 1.27, > 35.47, 42.80, 1.12, 6.19, 1.26, 0.69, > 0.23, 0.30, 0.01, 3.E-4, 1.E-5/ DATA SRA/ 0.536, 0.216, 0.203, 0.184, 0.175, 0.126, > 0.114, 0.073/ DATA SRB/ 334.0, 189.0, 82.2, 57.2, 38.8, 18.1, > 9.46, 3.30/ C DATA SIGAO / 18 * 0.00, > 0.00, 0.00, 2.12, 4.18, 4.38, 4.23, > 4.28, 4.18, 4.18, 8.00,11.35,10.04, > 12.21,12.22,12.23,11.90,12.17,12.13, > 11.91,11.64,11.25,11.21, 9.64, 9.95, > 8.67, 7.70, 7.68, 6.61, 7.13, 6.05, > 5.30, 2.90, 1.60, 0.59, 0.16, 0.05, > 0.51, 0.07, .012, .002, .0002/ C DATA SIGAO2/ 0.50, 1.50, 3.40, 6.00,10.00,13.00, > 15.00,12.00, 2.20, 0.30, 3.00, 0.01, ! 1/30/04: changed siga02(17) from 1.0 to 2.2, as per roble, ! for lyman-beta source of E5577 (ie5577(5) > 0) > 0.30, 0.10, 1.00, 1.10, 2.20, 1.60, > 16.53, 4.00,15.54, 9.85,20.87,27.09, > 26.66,25.18,21.96,29.05,25.00,26.27, > 26.02,25.80,26.10,25.04,22.00,25.59, > 24.06,21.59,20.40,19.39,18.17,18.40, > 17.19,16.80,16.80,15.10,15.70,13.20, > 10.60, 7.10, 4.00, 1.18, 0.32, 0.10, > 1.02, 0.14, .024, .004, .0004/ C DATA SIGAN2/ 18 * 0.00, > 36.16, 0.70,16.99,46.63,15.05,30.71, > 19.26,26.88,35.46,30.94,26.30,29.75, > 23.22,23.20,23.10,22.38,23.20,24.69, > 24.53,21.85,21.80,21.07,17.51,18.00, > 13.00,11.60,11.60,10.30,10.60, 9.70, > 8.00, 4.40, 1.90, 0.60, 0.24, 1.16, > 0.48, 0.09, .015, .003, .0003/ C DATA SIGIO / 18 * 0.00, > 0.00, 0.00, 2.12, 4.18, 4.38, 4.23, > 4.28, 4.18, 4.18, 8.00,11.35,10.04, > 12.21,12.22,12.23,11.90,12.17,12.13, > 11.91,11.64,11.25,11.21, 9.64, 9.95, > 8.67, 7.70, 7.68, 6.61, 7.13, 6.05, > 5.30, 2.90, 1.60, 0.59, 0.16, 0.05, > 0.51, 0.07, .012, .002, .0002/ C DATA SIGIO2/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, > 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, > 0.00, 0.00, 0.00, 0.27, 0.00, 1.00, > 12.22, 2.50, 9.34, 4.69, 6.12, 9.39, > 11.05, 9.69, 8.59,23.81,23.00,22.05, > 25.94,25.80,26.10,25.04,22.00,25.59, > 24.06,21.59,20.40,19.39,18.17,18.40, > 17.19,16.80,16.80,15.10,15.70,13.20, > 10.60, 7.10, 4.00, 1.18, 0.32, 0.10, > 1.02, 0.14, .024, .004, .0004/ C DATA SIGIN2/ 18 * 0.00, > 0.00, 0.00, 0.00, 0.00, 0.00,16.75, > 10.18,18.39,23.77,23.20,23.00,25.06, > 23.22,23.20,23.10,22.38,23.20,24.69, > 24.53,21.85,21.80,21.07,17.51,18.00, > 13.00,11.60,11.60,10.30,10.60, 9.70, > 8.00, 4.40, 1.90, 0.60, 0.24, 1.16, > 0.48, 0.09, .015, .003, .0003/ C C CO DATA SIGACO/6*0.,1.92,3.53,5.48,8.02,10.02,11.70,11.01, 1 12.52,12.47,13.61,15.43,15.69,18.01,19.92,20.09,21.61,22.28, 2 22.52,22.41,18.42,18.60,19.78,25.59,24.45,25.98,26.28,15.26, 3 33.22,21.35,22.59,37.64,49.44,28.50,52.9,3*0.0,16*0./ DATA SIGICO/6*0.,1.92,3.53,5.48,8.02,10.02,11.70,11.01, 1 12.52,12.47,13.61,15.43,15.69,18.01,19.92,20.09,21.44,22.31, 2 21.38,21.62,16.93,16.75,17.01,17.04,16.70,17.02,12.17,9.20, 3 15.44,11.38,17.13,11.70,6*0.0,16*0./ C CO2 DATA SIGACO2/6*0.,4.42,7.51,11.03,14.98,17.88,21.21,20.00, 1 23.44,23.44,23.88,25.70,25.81,27.52,28.48,29.27,31.61,33.20, 2 34.21,34.00,25.31,25.86,25.88,25.96,21.76,22.48,53.96,26.48, 3 21.79,31.83,12.84,49.06,70.89,29.91,34.41,3*0.0,16*0./ DATA SIGICO2/6*0.,4.42,7.51,11.03,14.98,17.88,21.21,20.00, 1 23.44,23.44,23.88,25.70,25.81,27.52,28.48,29.27,31.61,33.20, 2 34.21,34.00,20.16,21.27,21.14,21.72,17.71,17.02,50.39,20.00, 3 17.07,21.53,10.67,19.66,6*0.0,16*0./ C O+(4S) DATA SIGIO4S/6*0.,.32,1.03,1.62,1.95,2.15,2.33,2.23,2.23, 1 2.45,2.61,2.81,2.77,2.99,3.15,3.28,3.39,3.50,3.58,3.46,3.67, 2 3.74,3.73,4.04,4.91,4.20,4.18,4.18,4.28,4.23,4.38,4.18,2.12, 3 5*.00,16*0./ C O+(2D) DATA SIGIO2D/6*0.,.34,1.14,2.00,2.62,3.02,3.39,3.18,3.62, 1 3.63,3.98,4.37,4.31,4.75,5.04,5.23,5.36,5.47,5.49,5.30,5.51, 2 5.50,5.50,5.52,6.44,3.80,12*.00,16*0./ C O+(2P) DATA SIGIO2P/6*0.,.22,.75,1.30,1.70,1.95,2.17,2.04,2.32, 1 2.32,2.52,2.74,2.70,2.93,3.06,3.13,3.15,3.16,3.10,3.02,3.05, 2 2.98,2.97,.47,14*.00,16*0./ C O+(4P) DATA SIGIO4P/6*0.,.10,.34,.58,.73,.82,.89,.85,.91,.91,.93, 1 .92,.92,.55,24*.00,16*0./ C O+(2P*) DATA SIGIO2Q/6*0.,.03,.27,.46,.54,.56,.49,.52,.41,.41, 1 28*.00,16*0./ C HE+ DATA SIGIHE/6*0.,.21,.53,1.02,1.71,2.16,2.67,2.38, 1 3.05,3.05,3.65,4.35,4.25,5.51,6.53,7.09,.72,21*.00,16*0./ C N+ BANKS AND KOCKARTS X1.E-17 DATA SIGIN/6*0.,0.1,0.2,0.25,0.35,0.4,0.5,0.5,0.6,0.6,0.65, 10.8,0.7,1.,1.,1.,1.1,1.15,1.2,1.1,1.2,1.2,1.2,1.2,1.2,1.1,1.1,1.1, 21.0,1.0,1.0,1.0,1.0,5*0.,16*0./ C H+ BANKS AND KOCKARTS X1.E-18 DATA SIGIH/6*0.,0.05,0.02,0.05,0.12,0.16,0.20,0.23,0.27, 10.27,0.36,0.44,0.53,0.8,0.9,1.0,1.4,1.6,1.8,1.8,2.,2.2,2.3,2.8, 23.1,3.5,3.8,4.,4.,4.1,4.8,5.8,6.12,5*0.,16*0./ C IF (ISCALE .EQ. 0) THEN R1 = B1(1) + B1(2)*(F107A-71.5) + B1(3)*(F107-F107A+3.9) R2 = B2(1) + B2(2)*(F107A-71.5) + B2(3)*(F107-F107A+3.9) DO 100 L=1,LMAX IF (L .LT. 9) THEN SFLUX(L) = SRA(L) * F107 + SRB(L) ELSE IF (L .EQ. 12) THEN SFLUX(L) = 332. + 0.6 * (F107-65.) ELSE SFLUX(L) = (RFLUX(L) + ((R1-1.)*SCALE1(L) > + (R2-1.)*SCALE2(L)) / 1000.) IF (SFLUX(L) .LT. 0.0) SFLUX(L) = 0.0 ENDIF ENDIF 100 CONTINUE ELSE FRAT = (F107-68.) / (243.-68.) DO 200 L=1,LMAX SFLUX(L) = RFLUX(L) + (XFLUX(L)-RFLUX(L)) * FRAT 200 CONTINUE ENDIF C SFNORM = 2. - (F107-68.) / (243.-68.) IF (SFNORM .LT. 1.0) SFNORM = 1.0 C DO 300 L=1,LMAX WAVE1(L) = WAVEL(L) WAVE2(L) = WAVES(L) IF (WAVE1(L) .LT. 251. .AND. WAVE2(L) .GT. 49.) > SFLUX(L) = SFLUX(L) * SFNORM SFLUX(L) = SFLUX(L) * 1.E9 300 CONTINUE IF(ITIMET.GT.1) RETURN DO 10 L=1,LMAX M=LMAX-L+1 SIGABS(1,L) = SIGAO(L) * 1.E-18 SIGABS(2,L) = SIGAO2(L) * 1.E-18 SIGABS(3,L) = SIGAN2(L) * 1.E-18 SIGION(1,L) = SIGIO(L) * 1.E-18 SIGION(2,L) = SIGIO2(L) * 1.E-18 SIGION(3,L) = SIGIN2(L) * 1.E-18 SIGABS(4,L) = SIGACO(M) * 1.E-18 SIGION(4,L) = SIGICO(M) * 1.E-18 SIGABS(5,L) = SIGACO2(M)* 1.E-18 SIGION(5,L) = SIGICO2(M)* 1.E-18 SIGION(6,L) = SIGIO4S(M)* 1.E-18 SIGION(7,L) = SIGIO2D(M)* 1.E-18 SIGION(8,L) = SIGIO2P(M)* 1.E-18 SIGION(9,L) = SIGIO4P(M) * 1.E-18 SIGION(10,L)= SIGIO2Q(M)* 1.E-18 SIGION(11,L)= SIGIHE(M) * 1.E-18 SIGION(12,L)= SIGIN(M) * 1.E-17 SIGION(13,L)= SIGIH(M) * 1.E-18 10 CONTINUE RETURN END C SUBROUTINE COLUMN(UT,zpht,xno,xno2,tn,xnn2,sht,gz,cno,cno2,cnn2, + kmx) c call column(0.,zpht,xno,xno2,tn,xnn2,sht,gz,cno,cno2,cnn2,kmx) dimension zpht(kmx),xno(kmx),xno2(kmx),tn(kmx),xnn2(kmx),zqht(kmx) dimension sht(kmx),gz(kmx),cno(kmx),cno2(kmx),cnn2(kmx) c do 100 k=1,kmx 100 zqht(k) = zpht(k)*1.e+5 SHTCP=1.38E-16*TN(KMX)/(1.66E-24*GZ(KMX)) CNO2(KMX)=XNO2(KMX)*SHTCP/32. CNO(KMX)=XNO(KMX)*SHTCP/16. CNN2(KMX)=XNN2(KMX)*SHTCP/28. KMX1=KMX-1 DO 13 K=KMX1,1,-1 K1=K+1 ALP1=ALOG(XNO2(K1)/XNO2(K))/(ZQHT(K1)-ZQHT(K)) ALP2=ALOG(XNO(K1)/XNO(K))/(ZQHT(K1)-ZQHT(K)) ALP3=ALOG(XNN2(K1)/XNN2(K))/(ZQHT(K1)-ZQHT(K)) CNO2(K)=CNO2(K1)+XNO2(K)*(EXP(ALP1*(ZQHT(K1)-ZQHT(K)))-1.)/ALP1 CNN2(K)=CNN2(K1)+XNN2(K)*(EXP(ALP3*(ZQHT(K1)-ZQHT(K)))-1.)/ALP3 IF (ABS(ALP2).LT.1.E-10) GO TO 14 CNO(K)=CNO(K1)+XNO(K)*(EXP(ALP2*(ZQHT(K1)-ZQHT(K)))-1.)/ALP2 GO TO 13 14 CNO(K)=CNO(K1)+XNO(K)*(ZQHT(K1)-ZQHT(K)) 13 CONTINUE RETURN END C SUBROUTINE TANCOMP(ZG,XMO2,XMN2,XMO,TMM,CNGO2,CNGN2,CNGO, + zpht,xno,xno2,tn,xnn2,sht,cno,cno2,cnn2,kmx) SAVE dimension zpht(kmx),xno(kmx),xno2(kmx),tn(kmx),xnn2(kmx) dimension sht(kmx),cno(kmx),cno2(kmx),cnn2(kmx) ZU=ZG*1.E-5 IF(ZU.LT.ZPHT(1)) GO TO 3 KMX1=KMX-1 DO 1 K=1,KMX1 IF(ZU.GE.ZPHT(K).AND.ZU.LE.ZPHT(K+1)) GO TO 2 1 CONTINUE 2 ABD=(ZU-ZPHT(K))/(ZPHT(K+1)-ZPHT(K)) XMO2=XNO2(K)*EXP(ALOG(XNO2(K+1)/XNO2(K))*ABD) XMN2=XNN2(K)*EXP(ALOG(XNN2(K+1)/XNN2(K))*ABD) XMO=XNO(K)*EXP(ALOG(XNO(K+1)/XNO(K))*ABD) TMM=TN(K)+(TN(K+1)-TN(K))*(ZU-ZPHT(K))/(ZPHT(K+1)-ZPHT(K)) CNGO2=CNO2(K)*EXP(ALOG(CNO2(K+1)/CNO2(K))*ABD) CNGN2=CNN2(K)*EXP(ALOG(CNN2(K+1)/CNN2(K))*ABD) CNGO=CNO(K)*EXP(ALOG(CNO(K+1)/CNO(K))*ABD) GO TO 4 3 XMO2=XNO2(1)*EXP((-ZG+ZPHT(1)*1.E+5)/SHT(1)) XMN2=XNN2(1)*EXP((-ZG+ZPHT(1)*1.E+5)/SHT(1)) XMO=XNO(1) TMM=TN(1) CNGO2=XMO2*SHT(1) CNGN2=XMN2*SHT(1) CNGO=CNO(1) 4 CONTINUE RETURN END