diff --git a/README.md b/README.md index 0ee7c67..3e769e5 100644 --- a/README.md +++ b/README.md @@ -90,7 +90,7 @@ cmake --build iri2016/build ### setting JF flags -[iri2016.for](./iri2016/src/irisub.for) has a few dozen logical flags stored in variable JF. To reconfigure those flags, edit [iri2016_driver.f90](./iri2016/src/iri2016_driver.f90) and recompile iri2016_driver.exe. +[irisub.for](./iri2016/src/irisub.for) has a few dozen logical flags stored in variable JF. To reconfigure those flags, edit [iri2016_driver.f90](./iri2016/src/iri2016_driver.f90) and recompile iri2016_driver.exe. ### Matlab / GNU Octave diff --git a/iri2016/base.py b/iri2016/base.py index 3a75946..8cb21a1 100644 --- a/iri2016/base.py +++ b/iri2016/base.py @@ -76,6 +76,6 @@ def IRI(time: datetime, altkmrange: typing.Sequence[float], glat: float, glon: f iono["TEC"] = (("time"), [arr[36]]) iono["EqVertIonDrift"] = (("time"), [arr[43]]) - iono["foF2"] = (("time"), [arr[88]]) + iono["foF2"] = (("time"), [arr[99]]) return iono diff --git a/iri2016/data/igrf/dgrf2015.dat b/iri2016/data/igrf/dgrf2015.dat new file mode 100644 index 0000000..3273b44 --- /dev/null +++ b/iri2016/data/igrf/dgrf2015.dat @@ -0,0 +1,197 @@ + dgrf2015 + 13 6371.2 2015.0 +-29441.46 +-1501.77 +4795.99 +-2445.88 +3012.2 +-2845.41 +1676.35 +-642.17 +1350.33 +-2352.26 +-115.29 +1225.85 +245.04 +581.69 +-538.7 +907.42 +813.68 +283.54 +120.49 +-188.43 +-334.85 +180.95 +70.38 +-329.23 +-232.91 +360.14 +46.98 +192.35 +196.98 +-140.94 +-119.14 +-157.4 +15.98 +4.3 +100.12 +69.55 +67.57 +-20.61 +72.79 +33.3 +-129.85 +58.74 +-28.93 +-66.64 +13.14 +7.35 +-70.85 +62.41 +81.29 +-75.99 +-54.27 +-6.79 +-19.53 +51.82 +5.59 +15.07 +24.45 +9.32 +3.27 +-2.88 +-27.5 +6.61 +-2.32 +23.98 +8.89 +10.04 +-16.78 +-18.26 +-3.16 +13.18 +-20.56 +-14.6 +13.33 +16.16 +11.76 +5.69 +-15.98 +-9.1 +-2.02 +2.26 +5.33 +8.83 +-21.77 +3.02 +10.76 +-3.22 +11.74 +0.67 +-6.74 +-13.2 +-6.88 +-0.1 +7.79 +8.68 +1.04 +-9.06 +-3.89 +-10.54 +8.44 +-2.01 +-6.26 +3.28 +0.17 +-0.4 +0.55 +4.55 +-0.55 +4.4 +1.7 +-7.92 +-0.67 +-0.61 +2.13 +-4.16 +2.33 +-2.85 +-1.8 +-1.12 +-3.59 +-8.72 +3 +-1.4 +0 +-2.3 +2.11 +2.08 +-0.6 +-0.79 +-1.05 +0.58 +0.76 +-0.7 +-0.2 +0.14 +-2.12 +1.7 +-1.44 +-0.22 +-2.57 +0.44 +-2.01 +3.49 +-2.34 +-2.09 +-0.16 +-1.08 +0.46 +0.37 +1.23 +1.75 +-0.89 +-2.19 +0.85 +0.27 +0.1 +0.72 +0.54 +-0.09 +-0.37 +0.29 +-0.43 +0.23 +0.22 +-0.89 +-0.94 +-0.16 +-0.03 +0.72 +-0.02 +-0.92 +-0.88 +0.42 +0.49 +0.63 +1.56 +-0.42 +-0.5 +0.96 +-1.24 +-0.19 +-0.1 +0.81 +0.42 +-0.13 +-0.04 +0.38 +0.48 +0.08 +0.48 +0.46 +-0.3 +-0.35 +-0.43 +-0.36 +-0.71 diff --git a/iri2016/data/igrf/igrf2020.dat b/iri2016/data/igrf/igrf2020.dat new file mode 100644 index 0000000..9314b32 --- /dev/null +++ b/iri2016/data/igrf/igrf2020.dat @@ -0,0 +1,197 @@ + igrf2020 + 13 6371.2 2015.0 +-29404.8 +-1450.9 +4652.5 +-2499.6 +2982.0 +-2991.6 +1677.0 +-734.6 +1363.2 +-2381.2 +-82.1 +1236.2 +241.9 +525.7 +-543.4 +903.0 +809.5 +281.9 +86.3 +-158.4 +-309.4 +199.7 +48.0 +-349.7 +-234.3 +363.2 +47.7 +187.8 +208.3 +-140.7 +-121.2 +-151.2 +32.3 +13.5 +98.9 +66.0 +65.5 +-19.1 +72.9 +25.1 +-121.5 +52.8 +-36.2 +-64.5 +13.5 +8.9 +-64.7 +68.1 +80.6 +-76.7 +-51.5 +-8.2 +-16.9 +56.5 +2.2 +15.8 +23.5 +6.4 +-2.2 +-7.2 +-27.2 +9.8 +-1.8 +23.7 +9.7 +8.4 +-17.6 +-15.3 +-0.5 +12.8 +-21.1 +-11.7 +15.3 +14.9 +13.7 +3.6 +-16.5 +-6.9 +-0.3 +2.8 +5.0 +8.4 +-23.4 +2.9 +11.0 +-1.5 +9.8 +-1.1 +-5.1 +-13.2 +-6.3 +1.1 +7.8 +8.8 +0.4 +-9.3 +-1.4 +-11.9 +9.6 +-1.9 +-6.2 +3.4 +-0.1 +-0.2 +1.7 +3.6 +-0.9 +4.8 +0.7 +-8.6 +-0.9 +-0.1 +1.9 +-4.3 +1.4 +-3.4 +-2.4 +-0.1 +-3.8 +-8.8 +3.0 +-1.4 +0.0 +-2.5 +2.5 +2.3 +-0.6 +-0.9 +-0.4 +0.3 +0.6 +-0.7 +-0.2 +-0.1 +-1.7 +1.4 +-1.6 +-0.6 +-3.0 +0.2 +-2.0 +3.1 +-2.6 +-2.0 +-0.1 +-1.2 +0.5 +0.5 +1.3 +1.4 +-1.2 +-1.8 +0.7 +0.1 +0.3 +0.8 +0.5 +-0.2 +-0.3 +0.6 +-0.5 +0.2 +0.1 +-0.9 +-1.1 +0.0 +-0.3 +0.5 +0.1 +-0.9 +-0.9 +0.5 +0.6 +0.7 +1.4 +-0.3 +-0.4 +0.8 +-1.3 +0.0 +-0.1 +0.8 +0.3 +0.0 +-0.1 +0.4 +0.5 +0.1 +0.5 +0.5 +-0.4 +-0.5 +-0.4 +-0.4 +-0.6 diff --git a/iri2016/src/iriflip.for b/iri2016/src/iriflip.for index acf83b3..e32e33e 100644 --- a/iri2016/src/iriflip.for +++ b/iri2016/src/iriflip.for @@ -1,35 +1,37 @@ -C IRIFLIP.for +C IRIFLIP.for C C 2012.00 10/05/11 IRI-2012: bottomside B0 B1 model (SHAMDB0D, SHAB1D), C 2012.00 10/05/11 bottomside Ni model (iriflip.for), auroral foE C 2012.00 10/05/11 storm model (storme_ap), Te with PF10.7 (elteik), -C 2012.00 10/05/11 oval kp model (auroral_boundary), IGRF-11(igrf.for), +C 2012.00 10/05/11 oval kp model (auroral_boundary), IGRF-11(igrf.for), C 2012.00 10/05/11 NRLMSIS00 (cira.for), CGM coordinates, F10.7 daily C 2012.00 10/05/11 81-day 365-day indices (apf107.dat), ap->kp (ckp), C 2012.00 10/05/11 array size change jf(50) outf(20,1000), oarr(100). C 2012.01 12/12/11 Deleted ALT_RATES (not used) -C 2012.01 01/04/12 Deleted FINDAP,READAP,CONV_DATE,GET_DATA,RATCHK (not used) -C 2012.01 01/04/12 Deleted BRACE,ACTUAL_DAY,EPHEM SOLDEC,TFILE,RUN_ERROR (not used) -C 2012.01 01/04/12 COP2D: 99 FOMRAT ',' missing; commented out all WRITEs -C 2014.01 07/17/14 COP4S: NPLUS=0; PR(13)=0.0 ------------------------- A Shabanloui +C 2012.02 01/04/12 Deleted FINDAP,READAP,CONV_DATE,GET_DATA,RATCHK (not used) +C 2012.02 01/04/12 Deleted BRACE,ACTUAL_DAY,EPHEM SOLDEC,TFILE,RUN_ERROR (not used) +C 2012.02 01/04/12 COP2D: 99 FOMRAT ',' missing; commented out all WRITEs +C 2012.03 07/17/14 COP4S: NPLUS=0; PR(13)=0.0 ------------------------- A Shabanloui +C 2012.04 04/16/18 Versioning now based on year of major releases C 2016.01 09/08/16 Main: NEWTON replaced by iteration procedure ------- B Gustavsson +C 2016.02 05/07/18 Added array PRV11 to DATA statement ---------------- K. Knight C**************************************************************************************** C subroutines for IDC model C C includes: main subroutine CHEMION and the following subroutines and functions C KEMPPRN.FOR: CN2D, CNO, CN4S, CN2PLS, CNOP, CO2P, COP4S, COP2D, COP2P, C CNPLS, CN2A, CN2P, CNOPV -C RATES.FOR: RATS -C PESIMP.FOR: SECIPRD, FLXCAL, FACFLX, SIGEXS, TXSION, OXRAT, T_XS_N2, +C RATES.FOR: RATS +C PESIMP.FOR: SECIPRD, FLXCAL, FACFLX, SIGEXS, TXSION, OXRAT, T_XS_N2, C T_XS_OX, OXSIGS -C RSPRIM.FOR: PRIMPR, SCOLUM, PARAMS, PROBS, PROBN2, YLDISS, PROBO2, -C SCHUMN, FACEUV, FACSR, -C -C turn on printout of intermediate quantities with JPRINT=1 also in PARAMS, PROBS, +C RSPRIM.FOR: PRIMPR, SCOLUM, PARAMS, PROBS, PROBN2, YLDISS, PROBO2, +C SCHUMN, FACEUV, FACSR, +C +C turn on printout of intermediate quantities with JPRINT=1 also in PARAMS, PROBS, C PROBN2, YLDISS, and PROBO2 with ISW=1. -C -C Richards, P. G., D. Bilitza, and D. Voglozin (2010), Ion density calculator (IDC): -C A new efficient model of ionospheric ion densities, Radio Sci., 45, RS5007, +C +C Richards, P. G., D. Bilitza, and D. Voglozin (2010), Ion density calculator (IDC): +C A new efficient model of ionospheric ion densities, Radio Sci., 45, RS5007, C doi:10.1029/2009RS004332. C C Fortran code written by Phil Richards, George Mason University, Fairfax, VA, USA @@ -39,12 +41,12 @@ C C C:::::::::::::::::::::::::::: CHEMION ::::::::::::::::::::::::::: C..... This routine was written by Phil Richards April 2010. This version was -C..... modified in April 2011. +C..... modified in April 2011. C..... It takes the specified input electron density and returns O+, O2+, NO+, C..... N2+, N+, NO, and N(2D) densities. These densities generally agree well C..... with Atmosphere Explorer and FLIP model densities. C..... In this version all the densities except O+ are calculated from chemical -C..... equilibrium. The densities are normalized so that the total ion density +C..... equilibrium. The densities are normalized so that the total ion density C..... matches the input electron density. C..... This version has two modes. If the variable USER_OPLUS is positive it is used C..... to specify the O+ density. If USER_OPLUS is negative, O+ is calculated from @@ -54,8 +56,8 @@ C..... exactly, USER_OPLUS. C..... N+ generally agrees well with AE-C data and the FLIP model during the day C..... up to ~500 km, but is inaccurate at night due to diffusion. C..... The NO densities can either be user specified or calculated by the model. -C..... NO will be very good except below about 130 km where it will be -C..... underestimated due to neglect of diffusion. There is an artificial +C..... NO will be very good except below about 130 km where it will be +C..... underestimated due to neglect of diffusion. There is an artificial C..... floor on the NO density to prevent it from getting too low below 130 km. C..... H+ and He+ are only good during the daytime below ~450 km. C..... The EUVAC model is used for solar EUV irradiances @@ -89,9 +91,9 @@ C..... The EUVAC model is used for solar EUV irradiances REAL NE,N2P,N2D,OP2D,OP2P !.. Total (photon & photoel) production rates O+(4S),O+(2P),O+(2D),O2+ REAL TPROD1,PDISOP,TPROD2,TPROD3,TPROD5 - !.. Total Production rates from all sources for NO+, O2+, + !.. Total Production rates from all sources for NO+, O2+, REAL TPNOP,O2PPROD - !.. Production rates hv(e*)+N2->N+, hv+N->N+, Lyman-a -> NO+ + !.. Production rates hv(e*)+N2->N+, hv+N->N+, Lyman-a -> NO+ REAL DISNP,PHOTN,PLYNOP REAL PSEC !.. generic PE production REAL RTS(99) !.. Reaction rates array @@ -99,7 +101,7 @@ C..... The EUVAC model is used for solar EUV irradiances REAL H,DEX,FEX(2) !.. used in Newton solver REAL SUMIONS !.. Sum of the major ions REAL PNO,LNO,PDNOSR !.. Production and loss of NO - REAL N2A !.. N2(A) density + REAL N2A !.. N2(A) density REAL DISN2D,UVDISN,PN2D,LN2D !.. Production and loss of N(2D) REAL N2APRD !.. PE production rate of N2(A) REAL PN4S,LN4S,DISN4S !.. Production and loss of N(4S) @@ -120,7 +122,7 @@ C..... The EUVAC model is used for solar EUV irradiances CALL RATS(0,TE,TI,TN,RTS) !.. Get the reaction rates - !.. PRIMPR calculates solar EUV production rates. + !.. PRIMPR calculates solar EUV production rates. CALL PRIMPR(1,ALT,OXN,N2N,O2N,HEN,SZAD*0.01745,TN,F107,F107A,N4S) !.. Calculate secondary Production from photoelectrons @@ -129,11 +131,11 @@ C..... The EUVAC model is used for solar EUV irradiances UVDISN=OTHPR1(1) !.. EUV dissociation rate of N2 DISNP= EUVION(3,4)+EUVION(3,5)+EUVION(3,6) - > +0.1*(PEPION(3,1)+PEPION(3,2)+PEPION(3,3)) !.. Rydberg diss - > +PEPION(3,4)+PEPION(3,5)+PEPION(3,6) + > +0.1*(PEPION(3,1)+PEPION(3,2)+PEPION(3,3)) !.. Rydberg diss + > +PEPION(3,4)+PEPION(3,5)+PEPION(3,6) DISN2D=2.0*PEPION(3,1)+OTHPR2(3) DISN4S=2.0*PEPION(3,1)+OTHPR2(3) - PRHEP=OTHPR1(2) !.. He+ photoionization + PRHEP=OTHPR1(2) !.. He+ photoionization !.. initialize variables to avoid using left over values HEPLUS=0.0 @@ -150,7 +152,7 @@ C..... The EUVAC model is used for solar EUV irradiances K=K+1 !.. If K=1 print headers in files - !.. These species don't need to be iterated because they are at + !.. These species don't need to be iterated because they are at !.. the top of the food chain !.. O+(2P) Calculate and print densities, production, loss PSEC=PEPION(1,3) !.. Photoelectron production @@ -164,14 +166,14 @@ C..... The EUVAC model is used for solar EUV irradiances CALL COP2D(JPRINT,8,K,ALT,RTS,OXN,O2N,N2N,NE,OP2D,TPROD2,OP2P > ,HEPLUS,N4S,NNO,PSEC) - !.. O+(4S) Calculate and print densities, production, loss. + !.. O+(4S) Calculate and print densities, production, loss. TPROD1=EUVION(1,1) PDISOP=EUVION(2,4)+EUVION(2,5)+PEPION(2,4)+PEPION(2,5) CALL COP4S(JPRINT,4,K,ALT,RTS,OXN,O2N,N2N,NE,COXPLUS,TPROD1,OP2D > ,OP2P,PEPION(1,1),PDISOP,N2PLUS,N2D,NNO,1.0,HEPLUS) !.. Make sure chemical O+ is not greater than Ne - IF(COXPLUS.GT.NE) COXPLUS=NE + IF(COXPLUS.GT.NE) COXPLUS=NE !.. Choose either user specified or chemical O+ IF(USER_OPLUS.GT.0) THEN @@ -179,7 +181,7 @@ C..... The EUVAC model is used for solar EUV irradiances OXPLUS=(USER_OPLUS+COXPLUS)/2 ELSE !.. Alternative chemical equilibrium O+ calculation - OXPLUS=COXPLUS + OXPLUS=COXPLUS ENDIF !.. N2(A) is used in calculating NO density @@ -188,17 +190,17 @@ C..... The EUVAC model is used for solar EUV irradiances !.. Iterate through chemistry to improve results DO ITERS=1,5 - !.. N2+ Calculate and print densities, production, loss. + !.. N2+ Calculate and print densities, production, loss. CALL CN2PLS(JPRINT,9,K,ALT,RTS,OXN,O2N,N2N,NE,N2PLUS,EUVION(3,1) > ,EUVION(3,2),EUVION(3,3),PEPION(3,1),PEPION(3,2),PEPION(3,3) > ,OP2D,OP2P,HEPLUS,NPLUS,NNO,N4S) - !.. N(2D) Calculate and print densities, production, loss. + !.. N(2D) Calculate and print densities, production, loss. CALL CN2D(JPRINT,16,K,ALT,RTS,OXN,O2N,N2N,NOPLUS,NE,PN2D,LN2D > ,N2PLUS,DISN2D,UVDISN,NPLUS,N2P,N2D,OXPLUS,NNO,N2A) N2D=PN2D/LN2D - !.. N+ Calculate and print densities, production, loss. + !.. N+ Calculate and print densities, production, loss. PHOTN=OTHPR2(3) !.. N+ photo production CALL CNPLS(JPRINT,10,K,ALT,RTS,OXN,O2N,N2N,NE,DISNP,NPLUS, > OXPLUS,N2D,OP2P,HEPLUS,PHOTN,O2PLUS,N4S,OP2D,N2PLUS,NNO) @@ -208,16 +210,16 @@ C..... The EUVAC model is used for solar EUV irradiances > ,N2D,N4S,N2P,NNO,O2PLUS,OXPLUS,OTHPR2(2),OTHPR2(1),N2A,NPLUS) NNO=PNO/LNO !.. NO chemical equilibrium density - !.. Set a floor on NO density, which is needed below ~150 km at night + !.. Set a floor on NO density, which is needed below ~150 km at night IF(NNO.LT.1.0E8*EXP((100-ALT)/20)) NNO=1.0E8*EXP((100-ALT)/20) IF(USER_NO.GT.1.0) NNO=USER_NO !.. substitute user specified value IF(NNO.GT.1.5E8) NNO=1.5E8 !.. Don't let NO get too big - !.. NO+ Calculate and print densities, production, loss. + !.. NO+ Calculate and print densities, production, loss. CALL CNOP(JPRINT,11,K,ALT,RTS,OXN,O2N,N2N,NE,TPNOP,NOPLUS,OXPLUS > ,N2PLUS,O2PLUS,N4S,NNO,NPLUS,N2P,PLYNOP,1.0,N2D,OP2D) - !.. O2+ Calculate and print densities, production, loss. + !.. O2+ Calculate and print densities, production, loss. !.. EUV + PE production TPROD5=EUVION(2,1)+EUVION(2,2)+EUVION(2,3)+PEPION(2,1)+ > PEPION(2,2)+PEPION(2,3) @@ -226,7 +228,7 @@ C..... The EUVAC model is used for solar EUV irradiances SUMIONS=OXPLUS+NOPLUS+O2PLUS+NPLUS+N2PLUS - !.. Chemical equilibrium densities are normalized to the input NE + !.. Chemical equilibrium densities are normalized to the input NE !.. and return. IF(ITERS.EQ.5.OR.ABS(SUMSAVE-SUMIONS)/SUMIONS.LT.0.01) THEN OXPLUS=OXPLUS*NE/SUMIONS @@ -236,7 +238,7 @@ C..... The EUVAC model is used for solar EUV irradiances NPLUS=NPLUS*NE/SUMIONS RETURN ENDIF - SUMSAVE=SUMIONS + SUMSAVE=SUMIONS ENDDO RETURN @@ -348,7 +350,7 @@ C::::::::::::::::::::::::::::::: N(4S)::::::::::::::::::::::::::::::::::::::: 7 FORMAT(F6.1,1P,22E8.1) END C::::::::::::::::::::::::::::::: CN2PLS ::::::::::::::::::::::::::::::: -C..... Simplified chemistry of N2+. PUN2P* = production of N2+ by euv +C..... Simplified chemistry of N2+. PUN2P* = production of N2+ by euv C..... in the (X,A,B states). PEN2P* same for p.e.s (X,A,B states) SUBROUTINE CN2PLS(JPR,I,JPT,Z,RTS,ON,O2N,N2N,NE,N2PLS,PUN2PX, > PUN2PA,PUN2PB,PEN2PX,PEN2PA,PEN2PB,OP2D,OP2P,HEPLUS,NPLUS, @@ -405,7 +407,7 @@ C:::::::::::::::::::::::::::::: NO+ :::::::::::::::::::::::::::::::::: PR(10)=N2PLS*NNO*RTS(80) !..Fox PR(11)=NPLUS*NNO*RTS(81) !..Fox PR(12)=RTS(83)*NNO*OP2D !..Fox - PR(13)=OP2D*RTS(90)*N2N !.. -> NO+ + N, Li et al. [1997] + PR(13)=OP2D*RTS(90)*N2N !.. -> NO+ + N, Li et al. [1997] LR(1)=NE*RTS(5) P1=PR(1)+PR(2)+PR(3)+PR(4)+PR(5)+PR(6)+PR(7)+PR(8) > +PR(9)+PR(10)+PR(11)+PR(12)+PR(13) @@ -500,7 +502,7 @@ C::::::::::::::::::::::::::::::::::: O+(2D) ::::::::::::::::::::::::::::::::::: LR(5)=RTS(43)*O2N LR(6)=RTS(83)*NNO !..Fox LR(7)=RTS(84)*N4S !..Fox - LR(8)=RTS(90)*N2N !.. -> NO+ + N, Li et al. [1997] + LR(8)=RTS(90)*N2N !.. -> NO+ + N, Li et al. [1997] OP2D=(PR(1)+PR(2)+PR(3)+PR(4)+PR(5))/ > (LR(1)+LR(2)+LR(3)+LR(4)+LR(5)+LR(6)+LR(7)+LR(8)) IF(JPT.EQ.1.AND.JPR.GT.0) WRITE(I,99) @@ -633,7 +635,7 @@ C..... 21-AUG-1992. Added N2+ recombination source C:::::::::::::::::::::::::::::: NO+(v) :::::::::::::::::::::::::::::::::: C...... This routine calculates the vibrational distribution of no+ C...... Uses AFRL report by Winick et al. AFGL-TR-87-0334, Environmental -C...... Research papers, NO. 991, "An infrared spectral radiance code +C...... Research papers, NO. 991, "An infrared spectral radiance code C...... for the auroral thermosphere (AARC) C...... Written by P. Richards in February 2004 SUBROUTINE CNOPV(JPR,I,JPT,Z,RTS,ON,O2N,N2N,NE,P1,NOP,OPLS @@ -643,11 +645,11 @@ C...... Written by P. Richards in February 2004 PARAMETER (INV=20) !.. NO+(v) array dimensions REAL Z,RTS(99), !.. Altitude, rate coefficients > ON,O2N,N2N,NE, !.. O, N2, O2, electron densities - > P1, !.. total source output for finding [e] + > P1, !.. total source output for finding [e] > NOP,OPLS,N2PLS,O2P, !.. NO+, )+,N2+,O2+ densities > N4S,NNO,NPLUS,N2P, !.. N(4S), NO, N+, N(2P) densities > PLYNOP,VCON, !.. Lyman-a source, N2(v) rate factor - > N2D,OP2D, !.. N(2D), O+(2D) densities + > N2D,OP2D, !.. N(2D), O+(2D) densities > NOPV(INV),NOPTOT, !.. NO+(v) densities and total NO+ density > LR(22),PR(22), !.. storage for NO+ sources and sinks > EINSCO1(INV),EINSCO2(INV), !.. Einstein coeffs for delv=1,2 @@ -670,6 +672,7 @@ C...... Written by P. Richards in February 2004 DATA PRV8/0,.05,.07,.09,.11,.13,.14,.17,.07,.01,.02,.06,.08,7*0/ DATA PRV9/0,.05,.07,.09,.11,.13,.14,.17,.07,.01,.02,.06,.08,7*0/ DATA PRV10/0,.05,.07,.09,.11,.13,.14,.17,.07,.01,.02,.06,.08,7*0/ + DATA PRV11/0,.05,.07,.09,.11,.13,.14,.17,.07,.01,.02,.06,.08,7*0/ DATA PRV12/0,.05,.07,.09,.11,.13,.14,.17,.07,.01,.02,.06,.08,7*0/ DATA K_N2_Q/7.0E-12/ !.. Quenching rate coeff. by N2 @@ -678,8 +681,8 @@ C...... Written by P. Richards in February 2004 DATA EINSCO2/0.0,0.0,.697,1.93,3.61,5.74,8.24,11.1,14.2,17.7, > 21.3,25.1,29.0,33.2,37.4,5*40.0/ !.. Einstein coeff delv=1 !.. rate factors for NO+(v)+e -> N + O. Sheehan and St-Maurice 2004 - DATA LRV/1.0,19*0.3333/ - + DATA LRV/1.0,19*0.3333/ + !... Evaluate total production and loss rates PR(1)=VCON*RTS(3)*N2N*OPLS !.. N2 + O+ PR(2)=N2PLS*ON*RTS(10) !.. N2+ + O @@ -694,7 +697,7 @@ C...... Written by P. Richards in February 2004 PR(10)=N2PLS*NNO*RTS(80) !.. Fox: N2+ + NO PR(11)=NPLUS*NNO*RTS(81) !.. Fox: N+ + NO PR(12)=RTS(83)*NNO*OP2D !.. Fox: O+(2D) + NO - PR(13)=OP2D*RTS(90)*N2N !.. -> NO+ + N, Li et al. [1997] + PR(13)=OP2D*RTS(90)*N2N !.. -> NO+ + N, Li et al. [1997] LR(1)=NE*RTS(5) !.. NO+ + e !..Total source term used in main program to calculate [e] @@ -707,10 +710,10 @@ C...... Written by P. Richards in February 2004 ENDDO NOPTOT=0.0 - !.. loop down evaluating the vibrational populations. Must start + !.. loop down evaluating the vibrational populations. Must start !.. less than INV-1 because need cascade from v+2 DO IV=INV-4,1,-1 - !... chemical production for v=IV = total source * fraction + !... chemical production for v=IV = total source * fraction PNOPV=PR(1)*PRV1(IV)+PR(2)*PRV2(IV)+PR(3)*PRV3(IV)+ > PR(4)*PRV4(IV)+PR(5)*PRV5(IV)+PR(6)*PRV6(IV)+ > PR(7)*PRV7(IV)+PR(8)*PRV8(IV)+PR(9)*PRV9(IV)+ @@ -732,7 +735,7 @@ C...... Written by P. Richards in February 2004 !... diagnostic print. Set alt range to invoke IF(JPR.GT.0.AND.Z.GE.0.AND.Z.LT.10) - > WRITE(6,'(F10.1,I7,1P,22E10.2)') + > WRITE(6,'(F10.1,I7,1P,22E10.2)') > Z,IV,PNOPV,P1,PCASC,P_N2_Q,LNOPV,LRAD,L_N2_Q, > NOPV(IV),NOP,NOPTOT ENDDO @@ -750,7 +753,7 @@ C...... Written by P. Richards in February 2004 END C C -C.................................... RATES.FOR ................. +C.................................... RATES.FOR ................. C.... This is the reaction rate subroutine for the FLIP model. It takes C.... temperatures as input and puts the rates in array RTS. It includes C.... reaction rates, efficiencies for various products, and Einstein @@ -773,23 +776,23 @@ C.... 2001, page 21,305. Rates different from Fox and Sung indicated by PGR !.. O+ + H -> O + H+ Anicich et al. [1993] RTS(2)=6.4E-10 - !.. O+ + N2 --> NO+ + N, Hierl et al.[1997] - !.. The Hierl et al. [1997] lab rate is contaminated by N2(v) - !.. for T > 1300K. Therefore, the Hierl et al. rate is not really - !.. appropriate in the ionosphere. The IDC model uses the Hierl et - !.. al. rate because it does not solve for N2(v). The FLIP model + !.. O+ + N2 --> NO+ + N, Hierl et al.[1997] + !.. The Hierl et al. [1997] lab rate is contaminated by N2(v) + !.. for T > 1300K. Therefore, the Hierl et al. rate is not really + !.. appropriate in the ionosphere. The IDC model uses the Hierl et + !.. al. rate because it does not solve for N2(v). The FLIP model !.. solves for N2(v) and uses the St. Maurice and Torr rate (JGR,1978,p969) - IF(TI.LE.1000) RTS(3)=1.2E-12*(300/TI)**0.45 !.. Hierl et al.[1997] - IF(TI.GT.1000) RTS(3)=7.0E-13*(TI/1000)**2.12 !.. Hierl et al.[1997] - - !.. O+ + O2 -> O2+ + O, Lindinger et al. [1974] - !.. Hierl et al. lists different rates. Hierl et al. [1997] not - !.. used above 1600 because rates are contaminated by O2(v) for - !.. T > 1000K. We don't know the vibrational state in the - !.. thermosphere. This fit was done by PGR May 2009. It is similar + IF(TI.LE.1000) RTS(3)=1.2E-12*(300/TI)**0.45 !.. Hierl et al.[1997] + IF(TI.GT.1000) RTS(3)=7.0E-13*(TI/1000)**2.12 !.. Hierl et al.[1997] + + !.. O+ + O2 -> O2+ + O, Lindinger et al. [1974] + !.. Hierl et al. lists different rates. Hierl et al. [1997] not + !.. used above 1600 because rates are contaminated by O2(v) for + !.. T > 1000K. We don't know the vibrational state in the + !.. thermosphere. This fit was done by PGR May 2009. It is similar !.. to Fox and Sung but does not increase sharply above 1000K. IF(TI.LE.1600) RTS(4)=1.6E-11*(300/TI)**0.52 - IF(TI.GT.1600) RTS(4)=6.7E-12*(TI/1600)**0.6 + IF(TI.GT.1600) RTS(4)=6.7E-12*(TI/1600)**0.6 !.. NO+ + e -> N + O Walls and Dunn [1974) !.. Vejby-Christensen et al [1998] gives 4.0E-7*(300/TE)**0.5 @@ -808,7 +811,7 @@ C.... 2001, page 21,305. Rates different from Fox and Sung indicated by PGR RTS(8)=3.86E-10*(TE/300.)**0.81 !.. NO + N(4S) -> N2 + O Lee et al. [1978] - RTS(9)=3.4E-11 + RTS(9)=3.4E-11 !.. N2+ + O -> NO+ + N Scott et al.[1999] IF(TI.LE.1500) RTS(10)= 1.33E-10*(300/TI)**0.44 @@ -822,7 +825,7 @@ C.... 2001, page 21,305. Rates different from Fox and Sung indicated by PGR RTS(12)=6.03E-8*(300/TE)**0.5 !.. O+(2P) + e -> O+(2D) + e McLaughlin and Bell (1998) - !.. RTS(13)+RTS(14) agrees with Walker et al (1975) and + !.. RTS(13)+RTS(14) agrees with Walker et al (1975) and !.. Chang et al (1993) RTS(13)=1.84E-7*(300/TE)**0.5 @@ -849,28 +852,28 @@ C.... 2001, page 21,305. Rates different from Fox and Sung indicated by PGR > +0.357E-4*TE-(0.333+0.183E-4*TE)*EXP(-1.37E4/TE) > -(0.456+0.174E-4*TE)*EXP(-2.97E4/TE)) - !.. N2 + O+(2D) -> N2+ + O + !.. N2 + O+(2D) -> N2+ + O !..RTS(19)=8.0E-10 !.. Johnson and Biondi RTS(19)=1.50E-10*(300/Ti)**(-0.55) !.. Li et al by PGR - - !.. N2 + O+(2P) -> N2+ + 0 Fox + + !.. N2 + O+(2P) -> N2+ + 0 Fox !.. RTS(20)=6.2E-10*EXP(-340/TI) !.. Li et al from Fox wrong RTS(20)=2.0E-10*(300/Ti)**(-0.55) !.. Li et al by PGR !.. O2+ + N(4S) -> NO+ + 0 Scott et al.[1999] RTS(21)=1.0E-10 - !.. N+ + O2 -> O+ + NO + !.. N+ + O2 -> O+ + NO !.. Torr and Torr gives 6.0E-10 for total N+ + O2 reaction rate !.. Dotan et al [1997] from Fox and Sung gives !IF(TI.LE.1000) TOT_NP_O2_RATE=2.02E-10*(300/TI)**(-0.45) !IF(TI.GT.1000) TOT_NP_O2_RATE=3.49E-10 !.. does not seem to be correct. Probably vibrationally excited O2 !.. Branching ratios for N+ + O2 from O'Keefe et al J. Chem. Phys. 1986 - !.. NO+ +O(3P) = .09, NO+ + O(1D) = .36, O2+ + N(4S) = 0.35, + !.. NO+ +O(3P) = .09, NO+ + O(1D) = .36, O2+ + N(4S) = 0.35, !.. O2+ + N(2D) = 0.15, O+(4S) + NO = .05 TOT_NP_O2_RATE=6.0E-10 !.. Total N+ + O2 rate - RTS(22)=0.05*TOT_NP_O2_RATE + RTS(22)=0.05*TOT_NP_O2_RATE !.. O2+ + NO -> NO+ + O2 Midey and Viggiano [1999] RTS(23)=4.5E-10 * 1.0000 @@ -879,15 +882,15 @@ C.... 2001, page 21,305. Rates different from Fox and Sung indicated by PGR IF(TI.LE.300) RTS(24)=7.0E-13*(300/TI)**0.66 IF(TI.GT.300) RTS(24)=7.0E-13*(TI/300)**0.87 - !.. N+ + O2 -> O2+ + N(4S) - RTS(25)=0.35*TOT_NP_O2_RATE + !.. N+ + O2 -> O2+ + N(4S) + RTS(25)=0.35*TOT_NP_O2_RATE - !.. O+(2P) + O -> O+(4S) + O - !..RTS(26)=5.2E-10 !.. Fox appears to be wrong - !.. (Chang et al., JGR 1993) c.f. 5.2E-11 (Rusch) + !.. O+(2P) + O -> O+(4S) + O + !..RTS(26)=5.2E-10 !.. Fox appears to be wrong + !.. (Chang et al., JGR 1993) c.f. 5.2E-11 (Rusch) RTS(26)=4.0E-10 - !.. N2(A3sig) + O -> NO + N(2D) + !.. N2(A3sig) + O -> NO + N(2D) RTS(27)=2.0E-11 !..see Campbell et al. 2006 RTS(27)=0.000000 !.. Torr and Torr value @@ -899,7 +902,7 @@ C.... 2001, page 21,305. Rates different from Fox and Sung indicated by PGR !.. O2 + N+ -> O(3P) + NO+ !.. Branching ratio from O'Keefe et al J. Chem. Phys. 1968 - RTS(30)=0.09*TOT_NP_O2_RATE + RTS(30)=0.09*TOT_NP_O2_RATE !.. O + N+ -> O+ + N Constantinides et al.[1979].Bates[1989] RTS(31)=2.2E-12 @@ -921,21 +924,21 @@ C.... 2001, page 21,305. Rates different from Fox and Sung indicated by PGR RTS(36)=2.5E-11*EXP(TN/298)**0.55 !.. see Campbell et al. 2006 RTS(36)=2.0E-11 ! .. Torr et al. - !.. N(2P) + O -> products (N(2D,4S) and NO+) and O(3P,1D) + !.. N(2P) + O -> products (N(2D,4S) and NO+) and O(3P,1D) !.. from Piper et al 1993, J. Chem. Phys. vol 98 page 8560. RTS(37)=1.7E-11 - !.. N(2P) + O2 -> NO + O + !.. N(2P) + O2 -> NO + O RTS(38)=3.9E-12*EXP(-60/TN) !.. N(2P) quenching rates(O2+,NO) from Zipf et al jgr 1980 p687 RTS(39)=2.2E-11 RTS(40)=1.8E-10 - !.. N(2D) + NO -> N2 + O + !.. N(2D) + NO -> N2 + O RTS(41)=6.7E-11 - !.. efficiency N2+ + O -> N2 + O+(4S) + !.. efficiency N2+ + O -> N2 + O+(4S) IF(TI.LE.1500) RTS(42)= 7.0E-12*(300/TI)**0.21 IF(TI.GT.1500) RTS(42)= 4.83E-12*(1500/TI)**(-0.41) RTS(42)=RTS(42)/RTS(10) !.. converts to efficiency @@ -949,13 +952,13 @@ C.... 2001, page 21,305. Rates different from Fox and Sung indicated by PGR !.. He+ + N2 -> He + N+ RTS(45)=7.8E-10 - !.. O(1S)+ e -> O(1D) + e + !.. O(1S)+ e -> O(1D) + e RTS(46)=8.5E-9 - !.. O(1S)+ e -> O(3P) + e + !.. O(1S)+ e -> O(3P) + e RTS(47)=1.56E-10*(TE/300)**0.94 - !.. O(1S) + O2 -> O2 + O + !.. O(1S) + O2 -> O2 + O RTS(48)=4.4E-12*EXP(-815.0/TN) !.. NO+ + e -> N(4S) + O @@ -973,7 +976,7 @@ C.... 2001, page 21,305. Rates different from Fox and Sung indicated by PGR !.. Efficiency for N2+ + e -> N(4S) + N(2D) RTS(53)=0.46 - !.. O(1D) -> O + 6300 + 6364 + !.. O(1D) -> O + 6300 + 6364 RTS(54)=0.00934 !.. O(1S) -> O(1D) + 5577 @@ -989,7 +992,7 @@ C.... 2001, page 21,305. Rates different from Fox and Sung indicated by PGR RTS(58)=5.0E-3 !.. N+ + O2 -> NO+ + O(1S) Langford et al., PSS, 33,1225,1985 - RTS(59)=1.0E-3*TOT_NP_O2_RATE + RTS(59)=1.0E-3*TOT_NP_O2_RATE !.. Efficiency for N2(A3sig) + O -> O(1S) + N2 RTS(60)=0.37 @@ -1008,11 +1011,11 @@ C.... 2001, page 21,305. Rates different from Fox and Sung indicated by PGR !.. N+ + O2 -> O2+ + N(2D) !.. Branching ratio from O'Keefe et al J. Chem. Phys. 1968 - RTS(65)=0.15*TOT_NP_O2_RATE + RTS(65)=0.15*TOT_NP_O2_RATE !.. N+ + O2 -> NO+ + O(1D) !.. Branching ratio from O'Keefe et al J. Chem. Phys. 1968 - RTS(66)=0.36*TOT_NP_O2_RATE + RTS(66)=0.36*TOT_NP_O2_RATE !.. hv(Scum-Runge) + O2 -> O(1S) + O branching ratio RTS(67)=0.001 @@ -1023,8 +1026,8 @@ C.... 2001, page 21,305. Rates different from Fox and Sung indicated by PGR !.. O(1D) + O -> O + O Abreu et al. PSS, p1143, 1986 RTS(69)=6.47E-12*(TN/300)**0.14 - !.. hv + N2 -> N+(5S) -> 2143 A emission yield from the 2s sigma g state - !.. of N2. This was taken as 0.6 the value of Cleary and Barth JGR 1987, + !.. hv + N2 -> N+(5S) -> 2143 A emission yield from the 2s sigma g state + !.. of N2. This was taken as 0.6 the value of Cleary and Barth JGR 1987, !.. p13,635 because they did not double EUV below 250 A. RTS(70)=0.06 @@ -1044,7 +1047,7 @@ C.... 2001, page 21,305. Rates different from Fox and Sung indicated by PGR !.. He+ + O2 -> He + O2+ RTS(75) = 9.2E-12 - !.. He+ + O2 -> He + O+(2D) + O(3P) + !.. He+ + O2 -> He + O+(2D) + O(3P) RTS(76) = 2.37E-10 !.. O2+ + N(2D) -> NO+ + O @@ -1085,16 +1088,16 @@ C.... 2001, page 21,305. Rates different from Fox and Sung indicated by PGR !.. H+ + O2 -> O2+ + H RTS(89)=3.8E-9 - + !.. O+(2D) + N2 -> NO+ + N !.. Li et al. (1997). !.. From the ratio of the cross sections. !.. The branching ratio to O+(4S) + N2 not given by Li et al. RTS(90)=2.5E-11 - !.. He+ + O2 -> He + O+(4S) + O + !.. He+ + O2 -> He + O+(4S) + O RTS(91) = 2.39E-11 - !.. He+ + O2 -> He + O+(2P) + O + !.. He+ + O2 -> He + O+(2P) + O RTS(92) = 6.04E-10 !.. He+ + O2 -> He + O+(4S) + O(1D) @@ -1108,7 +1111,7 @@ C.... 2001, page 21,305. Rates different from Fox and Sung indicated by PGR !.. N(2P) + e -> N(4S) + e RTS(96)=2.04E-10*(TE/300)**0.85 - + !.. N(2P) + e -> N(2D) + e RTS(97)=9.5E-9 @@ -1138,7 +1141,7 @@ C..... Calculate secondary ion production, electron heating rate and 3371 excita REAL SZADEG !-- solar zenith angle {0 -> 90 degrees} REAL F107, F107A !-- F107 = Solar 10.7 cm flux REAL TE,TN !-- electron, neutral temperatures (K) - REAL XN(3),OXN,O2N,N2N!-- XN, O, O2, N2, neutral densities (cm-3) + REAL XN(3),OXN,O2N,N2N !-- XN, O, O2, N2, neutral densities (cm-3) REAL XNE !-- electron density (cm-3) REAL XN2D !-- N(2D) density for N(2D) + e -> 2.5 eV REAL XOP2D !-- O+(2D) density for O+(2D) + e -> 3.3 eV @@ -1179,7 +1182,7 @@ C..... Calculate secondary ion production, electron heating rate and 3371 excita > TE,TN,XN,XNE,XN2D,XOP2D,PEFLUX,AFAC,IMAX,DE,EV) !*************************************************************** - !........ sample calculation of ion production rates. + !........ sample calculation of ion production rates. DO I=1,IMAX E=EV(I) CALL TXSION(E,SIGIT) !.. total ion XS @@ -1212,17 +1215,17 @@ c > T_XS_N2(EP),PEPION(1,1),PEXCIT(1,1) END C:::::::::::::::::::::::::: PHOTOELECTRON MODEL :::::::::::::::::::::::: C....... This subroutine evaluates the photoelectron flux using the concept -C....... production frequencies developed by Phil Richards at Utah +C....... production frequencies developed by Phil Richards at Utah C....... State University March 1984. It supercedes the model described in C....... JGR, p2155, 1983. Contact EAST::CSPARA::RICHARDS on SPAN network C------- Some minor updates in April 1992 indicated by C---- -C....... I would appreciate any feedback on bugs or clarity and if it -C....... contributes substantially to a paper, I would appreciate the +C....... I would appreciate any feedback on bugs or clarity and if it +C....... contributes substantially to a paper, I would appreciate the C....... appropriate acknowledgement. C...... **************** WARNING **************** C...... This program is constructed to produce reasonable agreement with C...... the Atmosphere Explorer-E PES fluxes of John Doering (Lee et al. -C...... PSS 1980, page 947). It will NOT give good fluxes if the EUV +C...... PSS 1980, page 947). It will NOT give good fluxes if the EUV C...... attenuation is greater than about a factor of 7 (AFAC < 0.14). C...... The model accurately reproduces the measured fluxes very closely C...... for the case in the test driver at 148 km SZA=53 when AFAC=0.19. @@ -1231,8 +1234,8 @@ C...... periodically as a check. It is doubtful below 140km during the C...... day and below 200km near sunset. Between 200km & 350km, it should C...... be good for solar zenith angles < 90 degrees. Above 350 km there C...... is considerable uncertainty due to neglect of transport but most -C...... models have similar uncertainties at high altitudes due to the -C...... uncertainty in the conjugate photoelectron flux, and the pitch +C...... models have similar uncertainties at high altitudes due to the +C...... uncertainty in the conjugate photoelectron flux, and the pitch C...... angle distribution. C C------ ALT = altitude (km) { 120 -> 500 } @@ -1347,8 +1350,8 @@ c COMMON/SOL/UVFAC(59),EUV !..... Production of pe's at energy EE, taking into account !..... attenuation and EUV variation, and renormalize frequencies - PRODOX=RJOX(I)*XN(1)*AFAC*FFAC*1.0E-9 - PRODN2=RJN2(I)*XN(3)*AFAC*FFAC*1.0E-9 + PRODOX=RJOX(I)*XN(1)*AFAC*FFAC*1.0E-9 + PRODN2=RJN2(I)*XN(3)*AFAC*FFAC*1.0E-9 !..... Sum all the production rates PROD=PRODOX+PRODN2+CASEL+CASOX+CASN2+EPN2D+EPOP2D @@ -1423,7 +1426,7 @@ C..... with the Schram et al. cross sections at high energies !... N2+ cross section SIGIT(3)=0.0 - IF(E.GT.15.0) SIGIT(3)=1.42E-14*(1-9.0/E)**7.1*E**(-0.7) + IF(E.GT.15.0) SIGIT(3)=1.42E-14*(1-9.0/E)**7.1*E**(-0.7) IF(SIGTMP.LT.SIGIT(3)) SIGIT(3)=SIGTMP !... This correction to convert units to cm**2. Keiffer and Dunn page 10 SIGIT(3)=0.87972*SIGIT(3) @@ -1471,23 +1474,23 @@ C.... cross section. P. Richards 2003-10-04 DATA ESAVE/0.0/ !.. Wavelength < 20 A, Auger ionization - IF(EP.GE.600.0) THEN + IF(EP.GE.600.0) THEN T_XS_N2=0.5E-18 !.. Wavelength < 31 A, Auger ionization - ELSEIF(EP.GE.400.0) THEN + ELSEIF(EP.GE.400.0) THEN T_XS_N2=1.0E-18 !.. Wavelength 31.62 to 23.70 A ELSEIF(EP.GE.392.0) THEN T_XS_N2=EXP(7.9864*ALOG(EP)-91.6604) !.. Wavelength 225 to 125 A ELSEIF(EP.GE.55.09) THEN - T_XS_N2=EXP(-2.3711*ALOG(EP)-29.8142) + T_XS_N2=EXP(-2.3711*ALOG(EP)-29.8142) !.. Wavelength > 225 A ELSE - T_XS_N2=EXP(-1.1077*ALOG(EP)-34.8787) + T_XS_N2=EXP(-1.1077*ALOG(EP)-34.8787) ENDIF - !..IF(NINT(10*EP).NE.NINT(10*ESAVE)) WRITE(6,'(2F8.1,1P,2E10.2)') + !..IF(NINT(10*EP).NE.NINT(10*ESAVE)) WRITE(6,'(2F8.1,1P,2E10.2)') !..> 12394.224/EP,EP, T_XS_N2/(3.39E-17*EXP(-0.0263*EP)), T_XS_N2 ESAVE=EP @@ -1508,21 +1511,21 @@ C.... Samson and Pareek Phys. Rev. A, 31, 1470, 1985 DATA ESAVE/0.0/ !.. NEW parameterization - IF(EP.GE.500.0) THEN + IF(EP.GE.500.0) THEN !.. Wavelength shorter than 25 A, Auger ionization T_XS_OX=0.5E-18 - ELSEIF(EP.GE.165.26) THEN + ELSEIF(EP.GE.165.26) THEN !.. Wavelength shorter than 75 A T_XS_OX=EXP(-2.5209*ALOG(EP)-28.8855) - ELSEIF(EP.GE.55.09) THEN + ELSEIF(EP.GE.55.09) THEN !.. Wavelength between 78 and 256.26 A T_XS_OX=EXP(-1.7871*ALOG(EP)-32.6335) ELSE !.. Wavelength longer than 256.26 A - T_XS_OX=EXP(-1.3077*ALOG(EP)-34.5556) + T_XS_OX=EXP(-1.3077*ALOG(EP)-34.5556) ENDIF - !..IF(NINT(10*EP).NE.NINT(10*ESAVE)) WRITE(6,'(2F8.1,1P,2E10.2)') + !..IF(NINT(10*EP).NE.NINT(10*ESAVE)) WRITE(6,'(2F8.1,1P,2E10.2)') !..> 12394.224/EP,EP, T_XS_OX/(27.2E-18*EXP(-3.09E-2*EP)), T_XS_OX ESAVE=EP @@ -1568,8 +1571,8 @@ C C C.................... RSPRIM.FOR .................................. C.... This routine evaluates the ionization rates for photon impact -C.... It is based on a FLIP model routine that was modified in August -C.... 2009 for the chemical equilibrium model by P. richards. +C.... It is based on a FLIP model routine that was modified in August +C.... 2009 for the chemical equilibrium model by P. richards. SUBROUTINE PRIMPR(IJ,Z,ZOX,ZN2,ZO2,HE,SZA,TN,F107,F107A,N4S) IMPLICIT NONE INTEGER IVERT,I,IJ,IK,IPROBS,IS,K,L,LMAX,NNI,K1 @@ -1582,9 +1585,9 @@ C.... 2009 for the chemical equilibrium model by P. richards. REAL COLUMN(3),XN(3),PROB(3,6,37),XSNPLS(37),FNITE(37),CLNITE(3) cpgr REAL TPROB(3,6,37) -cpgr +cpgr - !-- common to hold the EUV and photoelectron production rates + !-- common to hold the EUV and photoelectron production rates COMMON/EUVPRD/EUVION(3,12),PEXCIT(3,12),PEPION(3,12), > OTHPR1(6),OTHPR2(6) COMMON/SIGS/ZFLUX(37),SIGABS(3,37),ZLAM(37),SIGION(3,37), @@ -1595,20 +1598,20 @@ cpgr DATA LMAX/0/, F107SV/0.0/, IPROBS/0/ !.. Fluxes for nighttime ion production in the 37 wavelength bins of !.. Torr et al GRL 1979. The fluxes are set to reproduce the production - !.. rates in Strobel et al. PSS, p1027, 1980. Note that most bins are - !.. set to zero and that the Strobel production rates are scaled by + !.. rates in Strobel et al. PSS, p1027, 1980. Note that most bins are + !.. set to zero and that the Strobel production rates are scaled by !.. FNFAC to stabilize the O+ solution below 200 km. Note also that !.. the wavelengths in FNITE go from largest (#3=HI) to smallest. DATA FNITE/9E5,0.0,9E5,2*0.0,9E6,13*0.0,3E5,8*0.0,3E5,8*0.0/ DATA FNFAC/1.0/ !.. UVFAC(58) is left over from FLIP routines for compatibility - UVFAC(58)=-1.0 + UVFAC(58)=-1.0 IF(ABS((F107-F107SV)/F107).GT.0.005) THEN !.. update UV flux factors CALL FACEUV(UVFAC,F107,F107A) CALL FACSR(UVFAC,F107,F107A) - + !.. call params to get solar flux data and cross sections CALL PARAMS(0,LMAX) F107SV=F107 @@ -1627,7 +1630,7 @@ cpgr IPROBS=1 ENDIF - !... initialization of production rates. 1.0E-15 stabilizes + !... initialization of production rates. 1.0E-15 stabilizes !... e density evaluation at low altitudes in CMINOR DO 10 IS=1,3 DO 10 IK=1,12 @@ -1674,7 +1677,7 @@ C........ OTHPR1(3)= dissociation rate. OTHPR1(5)= Energy CALL SCHUMN(IJ,Z,ZO2,COLUMN,OTHPR1(3),OTHPR1(5)) C C---- Calculate hv + NO ion. freq. from Lyman-a (Brasseur & Solomon) -C---- OTHPR2(2) is photodissociation of NO in the SR bands. +C---- OTHPR2(2) is photodissociation of NO in the SR bands. C---- A small night production from scattered light is included. FREQLY C---- varies with solar activity using Richards et al. 1994 page 8981 C---- LY_a=2.5E11 (Lean), sigi(NO)=2.0E-18 (Brasseur & Solomon page 329) @@ -1686,7 +1689,7 @@ C---- LY_a=2.5E11 (Lean), sigi(NO)=2.0E-18 (Brasseur & Solomon page 329) > +0.001*EXP(-O2SRXS*CLNITE(2))) C !.. wavelength loop begins here ---------- - !.. TAU, TAUN = optical depth for day, night + !.. TAU, TAUN = optical depth for day, night HEPLS=0.0 DO 6 L=1,LMAX TAU=0. @@ -1735,7 +1738,7 @@ C DO 304 I=1,3 XNSIGF=XN(I)*SIGION(I,L)*FLUX K1=NNI(I) - + !.. dspect=# ions formed by w-l l by ionization of k state of species i DO 302 K=1,K1 DSPECT=XNSIGF*PROB(I,K,L) @@ -1795,7 +1798,7 @@ C.... the MSIS model at grazing incidence IF(CHI.LT.1.5708) GO TO 2938 !.. is sza>90.0 degrees - !..Grazing incidence parameters + !..Grazing incidence parameters ALTG=(6371.0E5+Z)*SIN(3.1416-CHI)-6371.0E5 IF(ALTG.GE.85*1.0E5) THEN ZG=ALTG*1.E-5 @@ -1806,7 +1809,7 @@ C.... the MSIS model at grazing incidence GTN=MAX(TINF-(TINF-300.0)*EXP(-0.025*XI),180.0) !.. Neutral densities are extrapolated from altitude to grazing - !.. altitude. Weighted average Tn and GTn is used + !.. altitude. Weighted average Tn and GTn is used GR=GE*(RE/(RE+Z))**2 !.. gravity DO I=1,3 GN(I)=XN(I)*EXP((Z-ALTG)/ @@ -1895,7 +1898,7 @@ C........ absorption cross sections -- o first ,o2, then n2 > ,14.18,120.49,24.662,26.54,31.755,23.339,23.37,22.79,22.787 > ,22.4,24.13,24.501,23.471,23.16,21.675,16.395,16.91,13.857 > ,11.7,11.67,10.493,10.9,10.21,8.392,4.958,2.261,0.72/ -C....... ionization cross sections +C....... ionization cross sections DATA X2/5*0.0,1.315,4.554,3.498,5.091,3.749,3.89,4,10.736,11.46 > ,17.245,13.365,13.4,13.4,13.024,13.09,12.59,12.059,12.127,11.93 > ,11.496,9.687,9.84,8.693,7.7,7.68,6.461,7.08,6.05,5.202,3.732 @@ -2178,7 +2181,7 @@ C----- (F107+F107A)/2 > ,1.439,2.941,1.399,2.416,1.512,1.365,1.570,1.462,2.537,1.393 > ,1.572,1.578,1.681,1.598,1.473,1.530,1.622,1.634,1.525/ - !-- Test to see if need to scale - see DATRD2 subroutine + !-- Test to see if need to scale - see DATRD2 subroutine IF(NINT(UVFAC(58)).EQ.-1.OR.NINT(UVFAC(58)).EQ.-3) THEN !........... EUV scaling F107AV=(F107+F107A)*0.5 @@ -2204,7 +2207,7 @@ C........ from Torr et al. GRL 1980 p6063 DATA SRA/25.5,20.7,13.2,11.6,11.3,7.86,7.68,4.56/ DATA SRB/222.,129.,53.4,36.0,25.0,11.3,6.35,2.05/ C -C---- Test to see if need to scale - see DATRD2 subroutine +C---- Test to see if need to scale - see DATRD2 subroutine !IF(NINT(UVFAC(58)).EQ.-1.OR.NINT(UVFAC(58)).EQ.-3) THEN C DO 505 I=38,50 diff --git a/iri2016/src/irifun.for b/iri2016/src/irifun.for index 7dcd875..a67a616 100644 --- a/iri2016/src/irifun.for +++ b/iri2016/src/irifun.for @@ -1,36 +1,36 @@ c irifun.for, version number can be found at the end of this comment. c----------------------------------------------------------------------- -C Functions and subroutines for the International Reference Ionosphere +C Functions and subroutines for the International Reference Ionosphere C (IRI) model. These functions and subroutines are called by the main C IRI subroutine IRI_SUB in IRISUB.FOR. c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -c Required i/o units: +c Required i/o units: c KONSOL= 6 Program messages (used when jf(12)=.true. -> konsol) c KONSOL=11 Program messages (used when jf(12)=.false. -> MESSAGES.TXT) c -c COMMON/iounit/konsol,mess is used to pass the value of KONSOL from +c COMMON/iounit/konsol,mess is used to pass the value of KONSOL from c IRISUB to IRIFUN and IGRF. If mess=false then messages are turned off. -c -c UNIT=12 TCON: Solar/ionospheric indices IG12, R12 (IG_RZ.DAT) -c UNIT=13 APF,APFMSIS,APF_ONLY: Magnetic indices and F10.7 (APF107.DAT) +c +c UNIT=12 TCON: Solar/ionospheric indices IG12, R12 (IG_RZ.DAT) +c UNIT=13 APF,APFMSIS,APF_ONLY: Magnetic indices and F10.7 (APF107.DAT) c c I/o Units used in other programs: c IUCCIR=10 in IRISUB for CCIR and URSI coefficients (CCIR%%.ASC, %%=month+10) c UNIT=14 in IGRF/GETSHC for IGRF coeff. (DGRF%%%%.DAT, %%%%=year) c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c changes from IRIFU9 to IRIF10: -c SOCO for solar zenith angle +c SOCO for solar zenith angle c ACOS and ASIN argument forced to be within -1 / +1 c EPSTEIN functions corrected for large arguments c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -c changes from IRIF10 to IRIF11: +c changes from IRIF10 to IRIF11: c LAY subroutines introduced c TEBA corrected for 1400 km c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c changes from IRIF11 to IRIF12: -C Neutral temperature subroutines now in CIRA86.FOR +C Neutral temperature subroutines now in CIRA86.FOR C TEDER changed -C All names with 6 or more characters replaced +C All names with 6 or more characters replaced C 10/29/91 XEN: 10^ in loop, instead of at the end C 1/21/93 B0_TAB instead of B0POL C 9/22/94 Alleviate underflow condition in IONCOM exp() @@ -72,26 +72,26 @@ C 2000.06 04/15/01 Include IGRF_SUB subroutine for IK Te model C 2000.07 05/07/01 Include storm subroutine STORM and Ap access s/w C 2000.08 09/07/01 APF: if(j1.eq.j2) -> if(IY.eq.j2) [P. Wilkinson] C 2000.09 09/07/01 CONVER: LO2 = MOD(LO1,20)+1 [P. Webb,D. Pesnell] -C 2000.10 02/20/02 CONVER/DATA: 105.78 -> 015.78 [A. Shovkoplyas] +C 2000.10 02/20/02 CONVER/DATA: 105.78 -> 015.78 [A. Shovkoplyas] C 2000.11 10/28/02 replace TAB/6 blanks, enforce 72/line [D. Simpson] C 2000.12 11/08/02 removing unused variables (corr); apf0 removed C 2000.13 11/26/02 apf() using keyed access to ap.dat file; apf->apf1 -C 2000.14 11/27/02 changed F1_PROB; always 6 preceeding spaces +C 2000.14 11/27/02 changed F1_PROB; always 6 preceeding spaces C 2005.01 03/09/05 CALION,INVDPC,CALNE for new Ne, Ni models -C 2005.01 11/14/05 APF_ONLY for F107D; -C 2005.01 11/14/05 spreadf_brazil; added constraint 0<=P<=1 +C 2005.01 11/14/05 APF_ONLY for F107D; +C 2005.01 11/14/05 spreadf_brazil; added constraint 0<=P<=1 C 2005.02 05/11/06 NeQuick: XE1,TOPQ, M3000HM; stormvd, C 2005.02 03/27/07 STORM: hourly interpolation of Ap [A. Oinats] C 2007.00 05/18/07 Release of IRI-2007 C 2007.01 09/19/07 vdrift et al.: without *8 (no change in results) C 2007.04 02/07/09 IONLOW: N+ correction [V. Truhlik] -C 2007.05 03/30/09 NMDED: avoid exp underflow [K. Choi] +C 2007.05 03/30/09 NMDED: avoid exp underflow [K. Choi] C 2007.05 03/30/09 spreadf_brazil: bspl2f et al b(20->30) [Tab Ji] C 2007.05 03/30/09 APF_ONLY: Compute monthly F10.7 C 2007.06 05/26/09 APF_ONLY: replace i with 1 and IMN with ID [R.Conde] -C 2007.07 07/10/09 CONVER/DATA: 015.78 -> 005.78 [E. Araujo] -C 2007.08 07/23/09 STORM/CONVER: long. discont. [R. Conde, E. Araujo] -C 2007.08 07/23/09 APF,APF_ONLY: use YearBegin from ap.dat [R. Conde] +C 2007.07 07/10/09 CONVER/DATA: 015.78 -> 005.78 [E. Araujo] +C 2007.08 07/23/09 STORM/CONVER: long. discont. [R. Conde, E. Araujo] +C 2007.08 07/23/09 APF,APF_ONLY: use YearBegin from ap.dat [R. Conde] C 2007.10 02/03/10 APF: eof error message; clean-up APF and APF_only C 2007.11 04/19/10 ELTEIK: IF (ALT .GE. 900) THEN [A. Senior] C 2007.11 04/19/10 INILAY: HFFF,XFFF when NIGHT=F1REG=f [A. Senior] @@ -99,7 +99,7 @@ C C 2012.00 10/05/11 IRI-2012: bottomside B0 B1 model (SHAMDB0D, SHAB1D), C 2012.00 10/05/11 bottomside Ni model (iriflip.for), auroral foE C 2012.00 10/05/11 storm model (storme_ap), Te with PF10.7 (elteik), -C 2012.00 10/05/11 oval kp model (auroral_boundary),IGRF-11(igrf.for), +C 2012.00 10/05/11 oval kp model (auroral_boundary),IGRF-11(igrf.for), C 2012.00 10/05/11 NRLMSIS00 (cira.for), CGM coordinates, F10.7 daily C 2012.00 10/05/11 81-day 365-day indices (apf107.dat), ap->kp (ckp), C 2012.00 10/05/11 array size change jf(50) outf(20,1000), oarr(100). @@ -113,49 +113,57 @@ C 2012.01 01/24/12 STORME_AP: change 365 to 366 leap year [F. Simoes] C 2012.01 06/30/12 HMF2ED: hmF2 too low foF2/foE ge 1.7 [I.Zakharenkova] C 2012.01 09/14/12 SHAMDB0D,SHAB1D: initializing CONS2 [P. Coisson] C 2012.02 12/12/12 STORME_AP: add KONSOL and ERROR ouput STORME_AP=-5. -C 2014.00 01/22/14 TPCORR: INVDIP --> INVDP [J.K. Knight] -C 2014.02 07/24/14 COMMON/iounit/ added 'mess' -C 2014.03 08/25/14 ELTEIK,INVDPC,SOCO: ACOS: if(abs(x).gt.1) x=sign(1,x) -C 2014.03 10/02/14 IONLOW,IONHIGH: C1(82) added for SPHARM_IK [J.C. Xue] -C 2014.05 12/22/14 APFMSIS: changed text if out of range of APF107.DAT -C 2015.01 04/27/15 TCON: ionoindx(806),indrz(806) -C 2015.02 07/12/15 add read_ig_rz, readapf107 change TCON,APF* -C 2015.02 07/20/15 APFMSIS: remove duplicate iiap(8) [E. Blanch] -C 2015.03 08/13/15 DATA in subr: DATA values only used first CALL -C 2015.03 08/13/15 COMMON/CONST/UMR,PI -C 2015.03 09/30/15 hmF2 new: SHAMDHMF2, SDMF2 and associated subroutines -C 2015.03 09/30/15 ELTEIK,CALION,IONLOW,IONHIGH w/o invdip calc; INVDPC -C 2015.03 10/12/15 READAPF107: F365 -> F107_365 [M. Hausman] -C 2015.03 10/14/15 LEGFUN: replace print * with write(konsol,..) -C 2015.03 10/14/15 SHAMDB0D,SHAB1D,SCHNEVPD: COMMON/ATB/ -C 2015.03 10/14/15 CLCMLT,DPMTRX --> IGRF.FOR -C 2015.04 02/01/16 TAL: if(SHBR.le.0.0) -> RETURN -C 2015.04 02/01/16 IONLOW,IONHIGH: ALT -> ALTI extrapolation [S.R. Zhang] -C 2016.01 02/24/16 SCHNEVPH: COSD(X) -> COS(X*UMR); CONST/UMR [W. Toler] -C 2016.01 02/24/16 SCHNEVP,LEGFUN: COMMON/COST/dfarg,PI [W. Toler] -C 2016.02 03/23/16 CALION, IONLOW, IONHIGH, INVDPC revised [V. Truhlik] -C 2016.03 07/19/16 XE3_1: change D1F1 to C1 [I. Galkin] -C 2016.04 09/08/16 CALION: Version 2.5 C/NOFS correction [V. Truhlik] -C 2016.04 09/08/16 NEW: model_hmF2 [V. Shubin] -C 2016.05 10/19/16 read_ig_rz: *0.7 for r12_new starting 01/2014 -C 2017.01 02/23/17 SHAB1D: new SCHNEVPDB1 and COMMON/ATB1/ -C 2018.01 03/22/18 INVDPC= ... ALFA*SIGN(1.0,DIPL)*INVL [V. Truhlik] -C 2018.01 03/22/18 INVDPC_OLD for ELTEIK [V. Truhlik] -C 2018.02 04/06/18 read_data_SD: add web dir. location for mcsat%%.dat -C +C 2012.03 01/22/14 TPCORR: INVDIP --> INVDP [J.K. Knight] +C 2012.04 07/24/14 COMMON/iounit/ added 'mess' +C 2012.05 08/25/14 ELTEIK,INVDPC,SOCO: ACOS: if(abs(x).gt.1) x=sign(1,x) +C 2012.06 10/02/14 IONLOW,IONHIGH: C1(82) added for SPHARM_IK [J.C. Xue] +C 2012.07 12/22/14 APFMSIS: changed text if out of range of APF107.DAT +C 2012.08 04/27/15 TCON: ionoindx(806),indrz(806) +C 2012.09 07/12/15 add read_ig_rz, readapf107 change TCON,APF* +C 2012.10 07/20/15 APFMSIS: remove duplicate iiap(8) [E. Blanch] +C 2012.11 04/11/18 read_ig_rz: rz=rz_new*0.7 from 01/2014, ig_rz_10_2016 +C 2012.12 04/16/18 Versioning now based on year of major releases +C +C 2016.01 08/13/15 DATA in subr: DATA values only used first CALL +C 2016.01 08/13/15 COMMON/CONST/UMR,PI +C 2016.02 09/30/15 hmF2 new: SHAMDHMF2, SDMF2 and associated subroutines +C 2016.02 09/30/15 ELTEIK,CALION,IONLOW,IONHIGH w/o invdip calc; INVDPC +C 2016.03 10/12/15 READAPF107: F365 -> F107_365 [M. Hausman] +C 2016.04 10/14/15 LEGFUN: replace print * with write(konsol,..) +C 2016.04 10/14/15 SHAMDB0D,SHAB1D,SCHNEVPD: COMMON/ATB/ +C 2016.04 10/14/15 CLCMLT,DPMTRX --> IGRF.FOR +C 2016.05 02/01/16 TAL: if(SHBR.le.0.0) -> RETURN +C 2016.05 02/01/16 IONLOW,IONHIGH: ALT -> ALTI extrapolation [S.R. Zhang] +C 2016.06 02/24/16 SCHNEVPH: COSD(X) -> COS(X*UMR); CONST/UMR [W. Toler] +C 2016.06 02/24/16 SCHNEVP,LEGFUN: COMMON/COST/dfarg,PI [W. Toler] +C 2016.07 03/23/16 CALION, IONLOW, IONHIGH, INVDPC revised [V. Truhlik] +C 2016.08 07/19/16 XE3_1: change D1F1 to C1 [I. Galkin] +C 2016.09 09/08/16 CALION: Version 2.5 C/NOFS correction [V. Truhlik] +C 2016.09 09/08/16 NEW: model_hmF2 [V. Shubin] +C 2016.10 10/19/16 read_ig_rz: *0.7 for r12_new starting 01/2014 +C 2016.11 02/23/17 SHAB1D: new SCHNEVPDB1 and COMMON/ATB1/ +C 2016.12 03/22/18 INVDPC= ... ALFA*SIGN(1.0,DIPL)*INVL [V. Truhlik] +C 2016.12 03/22/18 INVDPC_OLD for ELTEIK [V. Truhlik] +C 2016.13 04/06/18 read_data_SD: add web dir. location for mcsat%%.dat +C 2016.14 04/23/18 Versioning now based on year of major releases +C 2016.15 05/07/18 StormVd: AE7_12S -> AEd7_12S [K. Knight] +C 2020.01 07/02/19 Added subroutines BOOKER and tops_cor2 (COMMON/BLO11) +C 2020.02 07/19/19 XE1:itopn=3 is topside cor2 option (solar activity term) +C 2020.03 08/05/19 XE1: corrections and BLO11 change +C c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c IRI functions and subroutines: C Ne: XE1,TOPQ,ZERO,DXE1N,XE2,XE3_1,XE4_1,XE5,XE6,XE_1 -C Te, Ti: ELTEIK{INTERP,KODERR,KOEFD,KOF107,LOCATE,SPHARM_IK, +C Te, Ti: ELTEIK{INTERP,KODERR,KOEFD,KOF107,LOCATE,SPHARM_IK, C SPLINE,SPLINT,SWAPEL,TEDIFI,TPCAS,TPCORR},TEBA,SPHARM, C ELTE,TEDE,TI,TN -C Ni: RPID,RDHHE,RDNO,KOEFP1,KOEFP2,KOEFP3,SUFE,IONDANI,IONCO1, +C Ni: RPID,RDHHE,RDNO,KOEFP1,KOEFP2,KOEFP3,SUFE,IONDANI,IONCO1, C IONCO2,APROK,CALION,IONLOW,IONHIGH,INVDPC C PEAKS: FOUT,XMOUT,HMF2ED,XM3000HM,SHAMDHMF2,SCHNEVPDH,model_hmF2, -C SDMF2,hmF2_med_SD,read_data_SD,fun_hmF2_SD,fun_Gk,Legendre, +C SDMF2,hmF2_med_SD,read_data_SD,fun_hmF2_SD,fun_Gk,Legendre, C fun_hmF2UT,Koeff_UT,fun_Akp_UT,fun_Fk_UT,fun_Gk_UT C FOF1ED,f1_c1,f1_prob,FOEEDI,XMDED,GAMMA1 -C PROFILE: TOPH05,CHEBISH,SHAMDB0D,SHAB1D,SCHNEVPD,TBFIT,LEGFUN, +C PROFILE: TOPH05,CHEBISH,SHAMDB0D,SHAB1D,SCHNEVPD,TBFIT,LEGFUN, C B0_98,TAL,VALGUL,DREGION C MAG. FIELD: FIELDG, CONVER(Geom. Corrected Latitude) C TIME: SOCO,HPOL,MODA,UT_LT,SUN @@ -169,73 +177,136 @@ C Auroral: auroral_boundary, ckp C Misc: REGFA1 c----------------------------------------------------------------------- C -C -C************************************************************* -C*************** ELECTRON DENSITY **************************** -C************************************************************* +C +C************************************************************* +C*************** ELECTRON DENSITY **************************** +C************************************************************* C - FUNCTION XE1(H) + FUNCTION XE1(H) c---------------------------------------------------------------- -C DETERMINING ELECTRON DENSITY(M-3) IN THE TOPSIDE IONOSPHERE -C (H=HMF2....2000 KM) BY HARMONIZED BENT-MODEL ADMITTING -C VARIABILITY OF THE GLOBAL PARAMETERS BETA,ETA,DELTA,ZETA WITH -C GEOM. LATITUDE, SMOOTHED SOLAR FLUX AND CRITICAL FREQUENCY. -C BETA,ETA,DELTA,ZETA are computed in IRISUB program and +C DETERMINING ELECTRON DENSITY(M-3) IN THE TOPSIDE IONOSPHERE +C (H=HMF2....2000 KM) BY HARMONIZED BENT-MODEL ADMITTING +C VARIABILITY OF THE GLOBAL PARAMETERS BETA,ETA,DELTA,ZETA WITH +C GEOM. LATITUDE, SMOOTHED SOLAR FLUX AND CRITICAL FREQUENCY. +C BETA,ETA,DELTA,ZETA are computed in IRISUB program and C communicated via COMMON /BLO10. This is the IRI-2001 approach -C [REF.:K.RAWER,S.RAMAKRISHNAN,1978] +C [REF.:K.RAWER,S.RAMAKRISHNAN,1978] C New options include: -C (1) IRI-corrected: TC3,alg10,hcor1 in COMMON /BLO11. +C (1) IRI-corrected: TC3,alg10,hcor1 in COMMON /BLO11. C TC3 correction term divided by (1500-(hcor1-hmF2)) C alg10 = alog(10.) C hcor1 lower height boundary for correction C (2) NeQuick: B2TOP in COMMON /BLO11. -C B2TOP is the topside scale height that depends on foF2 and -C hmF2. +C B2TOP is the topside scale height that depends on foF2 and +C hmF2. C Switch for choosing the desired option is itopn in COMMON /BLO11 C itopn =0 IRI-2001, =1 IRI-2001-corrected, =2 NeQuick -C =3 Gulyaeva-0.5 is not yet implemented. +C =3 Gulyaeva-0.5 is not yet implemented. c---------------------------------------------------------------- COMMON /BLOCK1/HMF2,XNMF2,HMF1,F1REG & /BLO10/BETA,ETA,DELTA,ZETA - & /BLO11/B2TOP,TC3,itopn,alg10,hcor1 +c & /BLO11/B2TOP,TC3,itopn,alg10,hcor1,tcor2 + & /BLO11/B2TOP,itopn,tcor & /QTOP/Y05,H05TOP,QF,XNETOP,xm3000,hhalf,tau & /ARGEXP/ARGMAX - logical f1reg + logical f1reg IF(itopn.eq.2) THEN XE1=TOPQ(H,XNMF2,HMF2,B2TOP) RETURN ENDIF - + DXDH = (1000.-HMF2)/700. x0 = 300. - delta xmx0 = (H-HMF2)/DXDH x = xmx0 + x0 eptr1 = eptr(x,beta,394.5) - eptr(x0,beta,394.5) - eptr2 = eptr(x,100.,300.0) - eptr(x0,100.,300.0) + eptr2 = eptr(x,100.,300.0) - eptr(x0,100.,300.0) y = BETA * ETA * eptr1 + ZETA * (100. * eptr2 - xmx0) Y = y * dxdh if(abs(Y).gt.argmax) Y = sign(argmax,Y) - IF(itopn.eq.3) then - IF((QF.EQ.1.).AND.(ABS(H-H05TOP).LT.1.)) QF=Y05/Y - XE1 = XNMF2 * EXP(-Y*QF) - RETURN - endif - TCOR = 0. - IF(itopn.eq.1.and.h.gt.hcor1) then - xred = h - hcor1 - rco = tc3 * xred - TCOR = rco * alg10 - endif - XE1 = XNMF2 * EXP(-Y+TCOR) - RETURN - END +c IF(itopn.eq.3) then +c IF((QF.EQ.1.).AND.(ABS(H-H05TOP).LT.1.)) QF=Y05/Y +c XE1 = XNMF2 * EXP(-Y*QF) +c RETURN +c endif +c TCORS = 0.0 +c IF(itopn.eq.1.or.itopn.eq.3) then +c xred = h - hcor1 +c rco = tc3 * xred +c TCOR = rco * alg10 +c endif +c IF(h.gt.hcor1) TCORS=TCORS+TCOR +c TCOR=TCOR+TCOR2 + XE1 = XNMF2 * EXP(-Y+TCOR) + RETURN + END C C + subroutine tops_cor2(xh,vmod,a01) +C------------------------------------------------------------------------- +C Determines solar activity correction factor for topside cor option: +C xh height in km +C vmod modified dip latitude in degree +C ap01(1:2,1) A0 and A1 for daytime +C ap01(1:2,2) A0 and A1 for nighttime +C IRI-new = IRI-old * exp(A0+A1*PF10.7) +C------------------------------------------------------------------------- + REAL pa(6,3,2,2),ha(6,3,2,2),sh(5),thh(4) + REAL ah(6),av(6),ap01(3,2,2),a01(2,2) + REAL xmod(7),thhb(5),pb(7,2,2),bv(7) + + DATA pa/0,0,-2.4,-2.4,0,0, + & 0,0,-1.6,-1.6,0,0,0,0,-2.2,-2.2,0,0, + & 0,0,0.0185,0.0185,0,0,0,0,0.018,0.018,0,0, + & 0,0,0.0175,0.0175,0,0,0,0,-1.1,-1.1,0,0, + & 0,0,-0.7,-0.7,0,0,0,0,-1.4,-1.4,0,0, + & 0,0,0.007,0.007,0,0,0,0,0.005,0.005,0,0, + & 0,0,0.01,0.01,0,0/ + DATA ha/0,200,600,900,1400,1700, + & 0,550,700,1100,1400,1700, + & 0,200,600,950,1600,1700, + & 0,300,650,750,1300,1700, + & 0,450,750,850,1400,1700, + & 0,300,650,750,1500,1700, + & 0,400,500,900,1200,1700, + & 0,400,500,900,1200,1700, + & 0,350,550,800,1200,1700, + & 0,400,500,750,900,1700, + & 0,400,550,750,900,1700, + & 0,400,550,750,900,1700/ + DATA xmod/-90.,-60.,-25.,0.,25.,60.,90./ + DATA thh/4*30.0/thhb/5*0.1/ + + do 11 j2=1,3 + do 11 k=1,2 + do 11 l3=1,2 + do 12 i=1,6 + AH(I)=HA(I,J2,K,L3) +12 AV(I)=PA(I,J2,K,L3) +11 AP01(J2,K,L3)=BOOKER(XH,6,AH,AV,THH) + + do 20 i=1,2 + do 20 k=1,2 + do 21 l=1,2 + pb(l,i,k)=0 + pb(l+5,i,k)=0 +21 pb(l+2,i,k)=ap01(l,i,k) 8i,*,*) +20 pb(5,i,k)=ap01(3,i,k) + + do 14 k=1,2 + do 14 l4=1,2 + do 15 i=1,7 +15 BV(I)=PB(I,K,L4) +14 A01(K,L4)=BOOKER(VMOD,7,XMOD,BV,THHB) + return + end +C +C REAL FUNCTION TOPQ(h,No,hmax,Ho) c---------------------------------------------------------------- c NeQuick formula @@ -259,7 +330,7 @@ c---------------------------------------------------------------- RETURN END -C +C C REAL FUNCTION ZERO(DELTA) C FOR A PEAK AT X0 THE FUNCTION ZERO HAS TO BE EQUAL TO 0. @@ -287,23 +358,23 @@ C FOR A PEAK AT X0 THE FUNCTION ZERO HAS TO BE EQUAL TO 0. end C C - FUNCTION DXE1N(H) -C LOGARITHMIC DERIVATIVE OF FUNCTION XE1 (KM-1). + FUNCTION DXE1N(H) +C LOGARITHMIC DERIVATIVE OF FUNCTION XE1 (KM-1). COMMON /BLOCK1/HMF2,XNMF2,HMF1,F1REG - & /BLO10/BETA,ETA,DELTA,ZETA + & /BLO10/BETA,ETA,DELTA,ZETA logical f1reg x0 = 300. - delta X=(H-HMF2)/(1000.0-HMF2)*700.0 + x0 epst2 = epst(x,100.0,300.0) epst1 = epst(x,beta ,394.5) - DXE1N = - ETA * epst1 + ZETA * (1. - epst2) - RETURN - END + DXE1N = - ETA * epst1 + ZETA * (1. - epst2) + RETURN + END C C - REAL FUNCTION XE2(H) -C ELECTRON DENSITY FOR THE BOTTOMSIDE F-REGION (HMF1...HMF2). + REAL FUNCTION XE2(H) +C ELECTRON DENSITY FOR THE BOTTOMSIDE F-REGION (HMF1...HMF2). COMMON /BLOCK1/HMF2,XNMF2,HMF1,F1REG & /BLOCK2/B0,B1,C1 /ARGEXP/ARGMAX logical f1reg @@ -312,14 +383,14 @@ C ELECTRON DENSITY FOR THE BOTTOMSIDE F-REGION (HMF1...HMF2). if(x.le.0.0) x=0.0 z=x**b1 if(z.gt.argmax) z=argmax - XE2=XNMF2*EXP(-z)/COSH(X) - RETURN - END + XE2=XNMF2*EXP(-z)/COSH(X) + RETURN + END C C REAL FUNCTION XE3_1(H) C ELECTRON DENSITY FOR THE F1-LAYER (HZ.....HMF1) -C USING THE NEW DEFINED F1-LAYER FUNCTION (Reinisch and Huang, Advances +C USING THE NEW DEFINED F1-LAYER FUNCTION (Reinisch and Huang, Advances C in Space Research, Volume 25, Number 1, 81-88, 2000) COMMON /BLOCK1/ HMF2,XNMF2,HMF1,F1REG & /BLOCK2/ B0,B1,C1 @@ -352,42 +423,42 @@ C END C C - REAL FUNCTION XE5(H) -C ELECTRON DENSITY FOR THE E AND VALLEY REGION (HME..HEF). - LOGICAL NIGHT + REAL FUNCTION XE5(H) +C ELECTRON DENSITY FOR THE E AND VALLEY REGION (HME..HEF). + LOGICAL NIGHT COMMON /BLOCK4/ HME,XNME,HEF - & /BLOCK5/ NIGHT,E(4) - T3=H-HME - T1=T3*T3*(E(1)+T3*(E(2)+T3*(E(3)+T3*E(4)))) - IF(NIGHT) GOTO 100 - XE5=XNME*(1+T1) - RETURN -100 XE5=XNME*EXP(T1) - RETURN - END -C -C - REAL FUNCTION XE6(H) -C ELECTRON DENSITY FOR THE D REGION (HA...HME). + & /BLOCK5/ NIGHT,E(4) + T3=H-HME + T1=T3*T3*(E(1)+T3*(E(2)+T3*(E(3)+T3*E(4)))) + IF(NIGHT) GOTO 100 + XE5=XNME*(1+T1) + RETURN +100 XE5=XNME*EXP(T1) + RETURN + END +C +C + REAL FUNCTION XE6(H) +C ELECTRON DENSITY FOR THE D REGION (HA...HME). COMMON /BLOCK4/ HME,XNME,HEF & /BLOCK6/ HMD,XNMD,HDX - & /BLOCK7/ D1,XKK,FP30,FP3U,FP1,FP2 - IF(H.GT.HDX) GOTO 100 - Z=H-HMD - FP3=FP3U - IF(Z.GT.0.0) FP3=FP30 - XE6=XNMD*EXP(Z*(FP1+Z*(FP2+Z*FP3))) - RETURN -100 Z=HME-H + & /BLOCK7/ D1,XKK,FP30,FP3U,FP1,FP2 + IF(H.GT.HDX) GOTO 100 + Z=H-HMD + FP3=FP3U + IF(Z.GT.0.0) FP3=FP30 + XE6=XNMD*EXP(Z*(FP1+Z*(FP2+Z*FP3))) + RETURN +100 Z=HME-H XE6=XNME*EXP(-D1*Z**XKK) - RETURN - END + RETURN + END C C - REAL FUNCTION XE_1(H) -C ELECTRON DENSITY BEETWEEN HA(KM) AND 1000 KM -C SUMMARIZING PROCEDURES NE1....6; - COMMON /BLOCK1/HMF2,XNMF2,XHMF1,F1REG + REAL FUNCTION XE_1(H) +C ELECTRON DENSITY BEETWEEN HA(KM) AND 1000 KM +C SUMMARIZING PROCEDURES NE1....6; + COMMON /BLOCK1/HMF2,XNMF2,XHMF1,F1REG & /BLOCK3/HZ,T,HST & /BLOCK4/HME,XNME,HEF logical f1reg @@ -396,34 +467,34 @@ C SUMMARIZING PROCEDURES NE1....6; else hmf1=hmf2 endif - IF(H.LT.HMF2) GOTO 100 - XE_1=XE1(H) - RETURN + IF(H.LT.HMF2) GOTO 100 + XE_1=XE1(H) + RETURN -100 IF(H.LT.HMF1) GOTO 300 - XE_1=XE2(H) - RETURN +100 IF(H.LT.HMF1) GOTO 300 + XE_1=XE2(H) + RETURN -300 IF(H.LT.HZ) GOTO 400 - XE_1=XE3_1(H) - RETURN +300 IF(H.LT.HZ) GOTO 400 + XE_1=XE3_1(H) + RETURN -400 IF(H.LT.HEF) GOTO 500 - XE_1=XE4_1(H) - RETURN +400 IF(H.LT.HEF) GOTO 500 + XE_1=XE4_1(H) + RETURN -500 IF(H.LT.HME) GOTO 600 - XE_1=XE5(H) - RETURN +500 IF(H.LT.HME) GOTO 600 + XE_1=XE5(H) + RETURN -600 XE_1=XE6(H) - RETURN - END +600 XE_1=XE6(H) + RETURN + END +C C -C -C********************************************************** -C***************** ELECTRON TEMPERATURE ******************** -C********************************************************** +C********************************************************** +C***************** ELECTRON TEMPERATURE ******************** +C********************************************************** C SUBROUTINE ELTEIK(PF107Y,INVDIP,MLT,ALT,DDD,PF107,TE,SIGTE) c SUBROUTINE ELTEIK(CRD,PF107Y,INVDIP,FL,DIMO,B0, @@ -466,7 +537,7 @@ C 2.00 (IDL) F107 included as a linear perturbation on global Te patte C Te=Te(invlat,mlt,alt,season,F107) C 3.00 (IDL) invdipl introduced C 2000 (IDL,FORTRAN) correction for seasons included -C 2010 (IDL,FORTRAN) completely new version +C 2010 (IDL,FORTRAN) completely new version C Authors of the model (v 2011) C V. Truhlik, D. Bilitza, and L. Triskova C Author of the code: @@ -489,11 +560,11 @@ c INTEGER CRD,PF107Y,DDD,SEZDAY,XDAY REAL C(82) INTEGER SEZA,SEZB,DDDA,DDDB,DDDD REAL T350,T350A,T350B,T550,T550A,T550B,T850,T850A,T850B, - & T1400,T1400A,T1400B,T2000,T2000A,T2000B + & T1400,T1400A,T1400B,T2000,T2000A,T2000B REAL P350A,P350B,P550A,P550B,P850A,P850B, - & P1400A,P1400B,P2000A,P2000B + & P1400A,P1400B,P2000A,P2000B REAL E350,E350A,E350B,E550,E550A,E550B,E850,E850A,E850B, - & E1400,E1400A,E1400B,E2000,E2000A,E2000B + & E1400,E1400A,E1400B,E2000,E2000A,E2000B REAL TP350A,TP350B,TP550A,TP550B,TP850A,TP850B, & TP140A,TP140B,TP200A,TP200B INTEGER FUN @@ -580,7 +651,7 @@ C 21.12. - 20.3. ELSE DDDD=DDD+365 END IF - FUN=1 + FUN=1 END IF C model Te T350A=0.0 @@ -592,7 +663,7 @@ C model Te T1400A=0.0 T1400B=0.0 T2000A=0.0 - T2000B=0.0 + T2000B=0.0 DO 30 I=1,81 T350A=T350A+C(I)*D(1,SEZA,I) T350B=T350B+C(I)*D(1,SEZB,I) @@ -624,7 +695,7 @@ C model PF107 P1400A=0.0 P1400B=0.0 P2000A=0.0 - P2000B=0.0 + P2000B=0.0 DO 40 I=1,81 P350A=P350A+C(I)*DPF107(1,SEZA,I) P350B=P350B+C(I)*DPF107(1,SEZB,I) @@ -656,7 +727,7 @@ C model errTe E1400A=0.0 E1400B=0.0 E2000A=0.0 - E2000B=0.0 + E2000B=0.0 DO 50 I=1,81 E350A=E350A+C(I)*DERRTE(1,SEZA,I) E350B=E350B+C(I)*DERRTE(1,SEZB,I) @@ -677,14 +748,14 @@ C model errTe E1400A=10**E1400A E1400B=10**E1400B E2000A=10**E2000A - E2000B=10**E2000B + E2000B=10**E2000B C IF (PF107Y .EQ. 1) THEN CALL TPCORR(INVDP,MLT,DDD,PF107, & P350A,P350B,P550A,P550B,P850A,P850B, - & P1400A,P1400B,P2000A,P2000B, + & P1400A,P1400B,P2000A,P2000B, & TP350A,TP350B,TP550A,TP550B,TP850A,TP850B, - & TP140A,TP140B,TP200A,TP200B) + & TP140A,TP140B,TP200A,TP200B) T350A=T350A+TP350A T350B=T350B+TP350B T550A=T550A+TP550A @@ -695,7 +766,7 @@ C T1400B=T1400B+TP140B T2000A=T2000A+TP200A T2000B=T2000B+TP200B - END IF + END IF C Te IF (FUN .EQ. 0) THEN SEZDAY=(DDDB-DDDA) @@ -731,28 +802,28 @@ C error Te E850=(E850A-E850B)*COS(DPI/2.0*XDAY/SEZDAY)+E850B E1400=(E1400A-E1400B)*COS(DPI/2.0*XDAY/SEZDAY)+E1400B E2000=(E2000A-E2000B)*COS(DPI/2.0*XDAY/SEZDAY)+E2000B - END IF + END IF C //////////////////////////////////////////////////////// C Te linear interpolation for altitude IF (ALT .LT. 550) THEN TE=(T550-T350)/200.0*(ALT-350)+T350 - SIGTE=(E550-E350)/200.0*(ALT-350)+E350 + SIGTE=(E550-E350)/200.0*(ALT-350)+E350 END IF - IF ((ALT .GE. 550) .AND. (ALT .LT. 850)) THEN + IF ((ALT .GE. 550) .AND. (ALT .LT. 850)) THEN TE=(T850-T550)/300.0*(ALT-550)+T550 - SIGTE=(E850-E550)/300.0*(ALT-550)+E550 + SIGTE=(E850-E550)/300.0*(ALT-550)+E550 END IF - IF ((ALT .GE. 850) .AND. (ALT .LT. 1400)) THEN + IF ((ALT .GE. 850) .AND. (ALT .LT. 1400)) THEN TE=(T1400-T850)/550.0*(ALT-850)+T850 - SIGTE=(E1400-E850)/550.0*(ALT-850)+E850 + SIGTE=(E1400-E850)/550.0*(ALT-850)+E850 END IF - IF (ALT .GE. 1400) THEN + IF (ALT .GE. 1400) THEN TE=(T2000-T1400)/600.0*(ALT-1400)+T1400 - SIGTE=(E2000-E1400)/600.0*(ALT-1400)+E1400 - END IF - + SIGTE=(E2000-E1400)/600.0*(ALT-1400)+E1400 + END IF + INVDIP=INVDP - + RETURN END C @@ -763,33 +834,33 @@ C------------------------------------------------------------------------------- REAL V(N),X(N),XOUT,Y2(N),YOUT,X0(4),V0(4) REAL XA,XB,XC,VA,VB,VC CALL locate(X,N,XOUT,S) - IF (L .EQ. 0) THEN -C Spline interpolation (L=0) + IF (L .EQ. 0) THEN +C Spline interpolation (L=0) IF (S .LT. 2) S=2 - IF (S .GT. (N-2)) S=N-2 - S0=S-1 + IF (S .GT. (N-2)) S=N-2 + S0=S-1 DO 10 I=1,4 X0(I)=X(S0+I-1) 10 V0(I)=V(S0+I-1) - CALL SPLINE(X0,V0,4,1e30,1e30,Y2) + CALL SPLINE(X0,V0,4,1e30,1e30,Y2) CALL SPLINT(X0,V0,Y2,4,XOUT,YOUT) - END IF + END IF IF (L .EQ. 1) THEN -C Linear interpolation (L=1) +C Linear interpolation (L=1) IF ((S .GE.1) .AND. (S .LT. N)) THEN YOUT=(V(S+1)-V(S))/(X(S+1)-X(S))*(XOUT-X(S))+V(S) END IF - IF (S .EQ. 0) THEN + IF (S .EQ. 0) THEN YOUT=(V(2)-V(1))/(X(2)-X(1))*(XOUT-X(1))+V(1) END IF - IF (S .EQ. N) THEN + IF (S .EQ. N) THEN YOUT=(V(N)-V(N-1))/(X(N)-X(N-1))*(XOUT-X(N))+V(N) - END IF - END IF + END IF + END IF IF (L .EQ. 2) THEN -C Quadratic interpolation (L=2) +C Quadratic interpolation (L=2) IF (S .LT. 2) S=2 - IF (S .GT. (N-1)) S=N-1 + IF (S .GT. (N-1)) S=N-1 XA=X(S-1) XB=X(S) XC=X(S+1) @@ -798,8 +869,8 @@ C Quadratic interpolation (L=2) VC=V(S+1) YOUT=VA*(XOUT-XB)*(XOUT-XC)/((XA-XB)*(XA-XC))+ & VB*(XOUT-XA)*(XOUT-XC)/((XB-XA)*(XB-XC))+ - & VC*(XOUT-XA)*(XOUT-XB)/((XC-XA)*(XC-XB)) - END IF + & VC*(XOUT-XA)*(XOUT-XB)/((XC-XA)*(XC-XB)) + END IF INTERP=YOUT RETURN END @@ -1100,7 +1171,7 @@ C 2000km June solstice 10 DERRTE(5,3,I)=DERRTE(5,2,I)*MIRREQ(I) DO 40 K=1,81 DO 30 J=1,3 - DO 20 I=1,5 + DO 20 I=1,5 DOUT(I,J,K)=DERRTE(I,J,K) 20 CONTINUE 30 CONTINUE @@ -1405,7 +1476,7 @@ C 2000km June solstice 10 D(5,3,I)=D(5,2,I)*MIRREQ(I) DO 40 K=1,81 DO 30 J=1,3 - DO 20 I=1,5 + DO 20 I=1,5 DOUT(I,J,K)=D(I,J,K) 20 CONTINUE 30 CONTINUE @@ -1710,7 +1781,7 @@ C 2000km June solstice 10 DPF107(5,3,I)=DPF107(5,2,I)*MIRREQ(I) DO 40 K=1,81 DO 30 J=1,3 - DO 20 I=1,5 + DO 20 I=1,5 DOUT(I,J,K)=DPF107(I,J,K) 20 CONTINUE 30 CONTINUE @@ -1718,7 +1789,7 @@ C 2000km June solstice C//////////////////////////////////////////////////////////////////////////////////// RETURN END -C +C C SUBROUTINE locate(xx,n,x,j) C------------------------------------------------------------------------------------ @@ -1777,7 +1848,7 @@ C------------------------------------------------------------------------------- 20 CONTINUE RETURN END -C +C C SUBROUTINE spline(x,y,n,yp1,ypn,y2) C------------------------------------------------------------------------------------ @@ -1846,19 +1917,19 @@ C C------------------------------------------------------------------------------------ C swaps elements of array C------------------------------------------------------------------------------------ - INTEGER N,I + INTEGER N,I REAL A(N),AT(N) DO 10 I=1,N -10 AT(I)=A(I) +10 AT(I)=A(I) DO 20 I=0,N-1 -20 A(I+1)=AT(N-I) +20 A(I+1)=AT(N-I) RETURN END C C SUBROUTINE TEDIFI(F107IN,TEXN,TEDN,F107DF,TEDIF) C------------------------------------------------------------------------------------ -C interpolation for solar activity +C interpolation for solar activity C------------------------------------------------------------------------------------ REAL F107IN,TEXN,TEDN,F107DF(3),TEDIF REAL T0DNXN(3),T0DN(2),TDNXN(2) @@ -1868,17 +1939,17 @@ C------------------------------------------------------------------------------- T0DNXN(2)=TEDN T0DNXN(3)=TEXN TEDIF=INTERP(3,2,T0DNXN,F107DF,F107IN) - END IF + END IF IF (F107IN .LT. F107DF(1)) THEN T0DN(1)=0. T0DN(2)=TEDN - TEDIF=INTERP(2,1,T0DN,F107DF(1),F107IN) - END IF + TEDIF=INTERP(2,1,T0DN,F107DF(1),F107IN) + END IF IF (F107IN .GT. F107DF(3)) THEN TDNXN(1)=TEDN TDNXN(2)=TEXN - TEDIF=INTERP(2,1,TDNXN,F107DF(2),F107IN) - END IF + TEDIF=INTERP(2,1,TDNXN,F107DF(2),F107IN) + END IF RETURN END C @@ -1891,16 +1962,16 @@ C------------------------------------------------------------------------------- REAL MLTRAD,PF107,PF107M,XNDI,DNDI,PD(3),XNNI,DNNI,PN(3),TPASEA REAL TA,TM,TDC,TNC CALL TEDIFI(PF107,XNDI,DNDI,PD,TA) - CALL TEDIFI(PF107M,XNDI,DNDI,PD,TM) + CALL TEDIFI(PF107M,XNDI,DNDI,PD,TM) TDC=TA-TM TDC=AMAX1(TDC,-1250.) TDC=AMIN1(TDC,1250.) CALL TEDIFI(PF107,XNNI,DNNI,PN,TA) - CALL TEDIFI(PF107M,XNNI,DNNI,PN,TM) + CALL TEDIFI(PF107M,XNNI,DNNI,PN,TM) TNC=TA-TM TNC=AMAX1(TNC,-1250.) - TNC=AMIN1(TNC,1250.) -C harmonic interpolation for local time + TNC=AMIN1(TNC,1250.) +C harmonic interpolation for local time TPASEA=(1.-COS(MLTRAD))/2.*(TDC-TNC)+TNC RETURN END @@ -1909,47 +1980,47 @@ C C SUBROUTINE TPCORR(INVDIP,MLT,DDD,PF107, & P350A,P350B,P550A,P550B,P850A,P850B, - & P1400A,P1400B,P2000A,P2000B, + & P1400A,P1400B,P2000A,P2000B, & TP350A,TP350B,TP550A,TP550B,TP850A,TP850B, & TP140A,TP140B,TP200A,TP200B) C------------------------------------------------------------------------------------ REAL INVDIP,MLT,PF107 INTEGER DDD REAL P350A,P350B,P550A,P550B,P850A,P850B, - & P1400A,P1400B,P2000A,P2000B, + & P1400A,P1400B,P2000A,P2000B, & TP350A,TP350B,TP550A,TP550B,TP850A,TP850B, & TP140A,TP140B,TP200A,TP200B REAL INTERP REAL MLTRAD -C Constants +C Constants REAL INVDPQ(13) -C PF107 Day Equinox +C PF107 Day Equinox REAL P2DE(13,3),P1DE(13,3),P8DE(13,3),P5DE(13,3),P3DE(13,3) -C Te max-min dif Day Equinox +C Te max-min dif Day Equinox REAL CXN2DE(13),CXN1DE(13),CXN8DE(13),CXN5DE(13),CXN3DE(13) -C Te med-min dif Day Equinox +C Te med-min dif Day Equinox REAL CDN2DE(13),CDN1DE(13),CDN8DE(13),CDN5DE(13),CDN3DE(13) C -C PF107 Night Equinox +C PF107 Night Equinox REAL P2NE(13,3),P1NE(13,3),P8NE(13,3),P5NE(13,3),P3NE(13,3) -C Te max-min dif Night Equinox +C Te max-min dif Night Equinox REAL CXN2NE(13),CXN1NE(13),CXN8NE(13),CXN5NE(13),CXN3NE(13) -C Te med-min dif Night Equinox +C Te med-min dif Night Equinox REAL CDN2NE(13),CDN1NE(13),CDN8NE(13),CDN5NE(13),CDN3NE(13) -C C -C PF107 Day Solstice +C +C PF107 Day Solstice REAL P2DS(13,3),P1DS(13,3),P8DS(13,3),P5DS(13,3),P3DS(13,3) -C Te max-min dif Day Solstice +C Te max-min dif Day Solstice REAL CXN2DS(13),CXN1DS(13),CXN8DS(13),CXN5DS(13),CXN3DS(13) -C Te med-min dif Day Solstice +C Te med-min dif Day Solstice REAL CDN2DS(13),CDN1DS(13),CDN8DS(13),CDN5DS(13),CDN3DS(13) C -C PF107 Night Solstice +C PF107 Night Solstice REAL P2NS(13,3),P1NS(13,3),P8NS(13,3),P5NS(13,3),P3NS(13,3) -C Te max-min dif Night Solstice +C Te max-min dif Night Solstice REAL CXN2NS(13),CXN1NS(13),CXN8NS(13),CXN5NS(13),CXN3NS(13) -C Te med-min dif Night Solstice +C Te med-min dif Night Solstice REAL CDN2NS(13),CDN1NS(13),CDN8NS(13),CDN5NS(13),CDN3NS(13) C working variables REAL TXN2DE(13),TXN1DE(13),TXN8DE(13),TXN5DE(13),TXN3DE(13) @@ -1959,13 +2030,13 @@ C working variables REAL TXN2DS(13),TXN1DS(13),TXN8DS(13),TXN5DS(13),TXN3DS(13) REAL TDN2DS(13),TDN1DS(13),TDN8DS(13),TDN5DS(13),TDN3DS(13) REAL TXN2NS(13),TXN1NS(13),TXN8NS(13),TXN5NS(13),TXN3NS(13) - REAL TDN2NS(13),TDN1NS(13),TDN8NS(13),TDN5NS(13),TDN3NS(13) + REAL TDN2NS(13),TDN1NS(13),TDN8NS(13),TDN5NS(13),TDN3NS(13) C C Interpolated PF107 REAL P2DEI(3),P1DEI(3),P8DEI(3),P5DEI(3),P3DEI(3) REAL P2NEI(3),P1NEI(3),P8NEI(3),P5NEI(3),P3NEI(3) REAL P2DSI(3),P1DSI(3),P8DSI(3),P5DSI(3),P3DSI(3) - REAL P2NSI(3),P1NSI(3),P8NSI(3),P5NSI(3),P3NSI(3) + REAL P2NSI(3),P1NSI(3),P8NSI(3),P5NSI(3),P3NSI(3) C Additional local and temporary variables REAL XN2DEI,XN1DEI,XN8DEI,XN5DEI,XN3DEI REAL XN2NEI,XN1NEI,XN8NEI,XN5NEI,XN3NEI @@ -1976,7 +2047,7 @@ C Additional local and temporary variables REAL DN2DSI,DN1DSI,DN8DSI,DN5DSI,DN3DSI REAL DN2NSI,DN1NSI,DN8NSI,DN5NSI,DN3NSI REAL MLTTMP - INTEGER I + INTEGER I C DATA (INVDPQ(I),I=1,13) /-90.0,-75.0,-60.0,-45.0,-30.0,-15.0, & 0.0, 15.0, 30.0, 45.0, 60.0, 75.0,90.0/ @@ -2046,8 +2117,8 @@ C Equinox DATA (CXN2NE(I),I=1,13) / 76., 134., 192., 821., 801., & 583., 551., 583., 801., 821., 192., 134., 76./ C DATA (CDN2NE(I),I=1,13) / -19., -83., -148., 399., 289., -C & 340., 542., 340., 289., 399., -148., -83., -19./ -C equator corrected +C & 340., 542., 340., 289., 399., -148., -83., -19./ +C equator corrected DATA (CDN2NE(I),I=1,13) / -19., -83., -148., 399., 289., & 340., 340., 340., 289., 399., -148., -83., -19./ DATA ((P1NE(I,J),I=1,13),J=1,3) / @@ -2226,7 +2297,7 @@ C TXN5NE(I)=CXN5NE(I) TDN5NE(I)=CDN5NE(I) TXN3NE(I)=CXN3NE(I) - TDN3NE(I)=CDN3NE(I) + TDN3NE(I)=CDN3NE(I) TXN2DS(I)=CXN2DS(I) TDN2DS(I)=CDN2DS(I) TXN1DS(I)=CXN1DS(I) @@ -2246,9 +2317,9 @@ C TXN5NS(I)=CXN5NS(I) TDN5NS(I)=CDN5NS(I) TXN3NS(I)=CXN3NS(I) -5 TDN3NS(I)=CDN3NS(I) +5 TDN3NS(I)=CDN3NS(I) C - IF (((DDD .GE. 265) .AND. (DDD .LT. 354)) .OR. + IF (((DDD .GE. 265) .AND. (DDD .LT. 354)) .OR. & ((DDD .GE. 354) .OR. (DDD .LT. 79))) THEN CALL SWAPEL(13,TXN2DS) CALL SWAPEL(13,TDN2DS) @@ -2271,7 +2342,7 @@ C CALL SWAPEL(13,TXN3NS) CALL SWAPEL(13,TDN3NS) END IF - + C interpolated Te values for invdip C Te max-min day equinox XN2DEI=INTERP(13,0,TXN2DE,INVDPQ,INVDIP) @@ -2279,50 +2350,50 @@ C Te max-min day equinox XN8DEI=INTERP(13,0,TXN8DE,INVDPQ,INVDIP) XN5DEI=INTERP(13,0,TXN5DE,INVDPQ,INVDIP) XN3DEI=INTERP(13,0,TXN3DE,INVDPQ,INVDIP) -C Te max-min night equinox +C Te max-min night equinox XN2NEI=INTERP(13,0,TXN2NE,INVDPQ,INVDIP) XN1NEI=INTERP(13,0,TXN1NE,INVDPQ,INVDIP) XN8NEI=INTERP(13,0,TXN8NE,INVDPQ,INVDIP) XN5NEI=INTERP(13,0,TXN5NE,INVDPQ,INVDIP) XN3NEI=INTERP(13,0,TXN3NE,INVDPQ,INVDIP) -C Te med-min day equinox +C Te med-min day equinox DN2DEI=INTERP(13,0,TDN2DE,INVDPQ,INVDIP) DN1DEI=INTERP(13,0,TDN1DE,INVDPQ,INVDIP) DN8DEI=INTERP(13,0,TDN8DE,INVDPQ,INVDIP) DN5DEI=INTERP(13,0,TDN5DE,INVDPQ,INVDIP) DN3DEI=INTERP(13,0,TDN3DE,INVDPQ,INVDIP) -C Te med-min night equinox +C Te med-min night equinox DN2NEI=INTERP(13,0,TDN2NE,INVDPQ,INVDIP) DN1NEI=INTERP(13,0,TDN1NE,INVDPQ,INVDIP) DN8NEI=INTERP(13,0,TDN8NE,INVDPQ,INVDIP) DN5NEI=INTERP(13,0,TDN5NE,INVDPQ,INVDIP) DN3NEI=INTERP(13,0,TDN3NE,INVDPQ,INVDIP) -C -C Te max-min day solstice +C +C Te max-min day solstice XN2DSI=INTERP(13,0,TXN2DS,INVDPQ,INVDIP) XN1DSI=INTERP(13,0,TXN1DS,INVDPQ,INVDIP) XN8DSI=INTERP(13,0,TXN8DS,INVDPQ,INVDIP) XN5DSI=INTERP(13,0,TXN5DS,INVDPQ,INVDIP) XN3DSI=INTERP(13,0,TXN3DS,INVDPQ,INVDIP) -C Te max-min night solstice +C Te max-min night solstice XN2NSI=INTERP(13,0,TXN2NS,INVDPQ,INVDIP) XN1NSI=INTERP(13,0,TXN1NS,INVDPQ,INVDIP) XN8NSI=INTERP(13,0,TXN8NS,INVDPQ,INVDIP) XN5NSI=INTERP(13,0,TXN5NS,INVDPQ,INVDIP) XN3NSI=INTERP(13,0,TXN3NS,INVDPQ,INVDIP) -C Te med-min day solstice +C Te med-min day solstice DN2DSI=INTERP(13,0,TDN2DS,INVDPQ,INVDIP) DN1DSI=INTERP(13,0,TDN1DS,INVDPQ,INVDIP) DN8DSI=INTERP(13,0,TDN8DS,INVDPQ,INVDIP) DN5DSI=INTERP(13,0,TDN5DS,INVDPQ,INVDIP) DN3DSI=INTERP(13,0,TDN3DS,INVDPQ,INVDIP) -C Te med-min night solstice +C Te med-min night solstice DN2NSI=INTERP(13,0,TDN2NS,INVDPQ,INVDIP) DN1NSI=INTERP(13,0,TDN1NS,INVDPQ,INVDIP) DN8NSI=INTERP(13,0,TDN8NS,INVDPQ,INVDIP) DN5NSI=INTERP(13,0,TDN5NS,INVDPQ,INVDIP) DN3NSI=INTERP(13,0,TDN3NS,INVDPQ,INVDIP) - DO 10 I=1,3 + DO 10 I=1,3 P2DEI(I)=INTERP(13,1,P2DE(1,I),INVDPQ,INVDIP) P2NEI(I)=INTERP(13,1,P2NE(1,I),INVDPQ,INVDIP) P1DEI(I)=INTERP(13,1,P1DE(1,I),INVDPQ,INVDIP) @@ -2333,7 +2404,7 @@ C Te med-min night solstice P5NEI(I)=INTERP(13,1,P5NE(1,I),INVDPQ,INVDIP) P3DEI(I)=INTERP(13,1,P3DE(1,I),INVDPQ,INVDIP) P3NEI(I)=INTERP(13,1,P3NE(1,I),INVDPQ,INVDIP) - + P2DSI(I)=INTERP(13,1,P2DS(1,I),INVDPQ,INVDIP) P2NSI(I)=INTERP(13,1,P2NS(1,I),INVDPQ,INVDIP) P1DSI(I)=INTERP(13,1,P1DS(1,I),INVDPQ,INVDIP) @@ -2347,9 +2418,9 @@ C Te med-min night solstice MLTTMP=MLT-1 IF (MLTTMP .LT. 0) MLTTMP=MLTTMP+24.0 MLTRAD=MLTTMP/24.0*2*3.1415927 - IF (((DDD .GE. 79) .AND. (DDD .LT. 171)) .OR. + IF (((DDD .GE. 79) .AND. (DDD .LT. 171)) .OR. & ((DDD .GE. 265) .AND. (DDD .LT. 354))) THEN -C Equinox +C Equinox CALL TPCAS(MLTRAD,PF107,P2000A, & XN2DEI,DN2DEI,P2DEI,XN2NEI,DN2NEI,P2NEI,TP200A) CALL TPCAS(MLTRAD,PF107,P1400A, @@ -2360,7 +2431,7 @@ C Equinox & XN5DEI,DN5DEI,P5DEI,XN5NEI,DN5NEI,P5NEI,TP550A) CALL TPCAS(MLTRAD,PF107,P350A, & XN3DEI,DN3DEI,P3DEI,XN3NEI,DN3NEI,P3NEI,TP350A) -C Solstice +C Solstice CALL TPCAS(MLTRAD,PF107,P2000B, & XN2DSI,DN2DSI,P2DSI,XN2NSI,DN2NSI,P2NSI,TP200B) CALL TPCAS(MLTRAD,PF107,P1400B, @@ -2370,11 +2441,11 @@ C Solstice CALL TPCAS(MLTRAD,PF107,P550B, & XN5DSI,DN5DSI,P5DSI,XN5NSI,DN5NSI,P5NSI,TP550B) CALL TPCAS(MLTRAD,PF107,P350B, - & XN3DSI,DN3DSI,P3DSI,XN3NSI,DN3NSI,P3NSI,TP350B) + & XN3DSI,DN3DSI,P3DSI,XN3NSI,DN3NSI,P3NSI,TP350B) END IF - IF (((DDD .GE. 171) .AND. (DDD .LT. 265)) .OR. + IF (((DDD .GE. 171) .AND. (DDD .LT. 265)) .OR. & ((DDD .GE. 354) .OR. (DDD .LT. 79))) THEN -C Solstice +C Solstice CALL TPCAS(MLTRAD,PF107,P2000A, & XN2DSI,DN2DSI,P2DSI,XN2NSI,DN2NSI,P2NSI,TP200A) CALL TPCAS(MLTRAD,PF107,P1400A, @@ -2384,8 +2455,8 @@ C Solstice CALL TPCAS(MLTRAD,PF107,P550A, & XN5DSI,DN5DSI,P5DSI,XN5NSI,DN5NSI,P5NSI,TP550A) CALL TPCAS(MLTRAD,PF107,P350A, - & XN3DSI,DN3DSI,P3DSI,XN3NSI,DN3NSI,P3NSI,TP350A) -C Equinox + & XN3DSI,DN3DSI,P3DSI,XN3NSI,DN3NSI,P3NSI,TP350A) +C Equinox CALL TPCAS(MLTRAD,PF107,P2000B, & XN2DEI,DN2DEI,P2DEI,XN2NEI,DN2NEI,P2NEI,TP200B) CALL TPCAS(MLTRAD,PF107,P1400B, @@ -2395,129 +2466,129 @@ C Equinox CALL TPCAS(MLTRAD,PF107,P550B, & XN5DEI,DN5DEI,P5DEI,XN5NEI,DN5NEI,P5NEI,TP550B) CALL TPCAS(MLTRAD,PF107,P350B, - & XN3DEI,DN3DEI,P3DEI,XN3NEI,DN3NEI,P3NEI,TP350B) - END IF + & XN3DEI,DN3DEI,P3DEI,XN3NEI,DN3NEI,P3NEI,TP350B) + END IF RETURN END c c - SUBROUTINE TEBA(DIPL,SLT,NS,TE) + SUBROUTINE TEBA(DIPL,SLT,NS,TE) C CALCULATES ELECTRON TEMPERATURES TE(1) TO TE(4) AT ALTITUDES -C 300, 400, 1400 AND 3000 KM FOR DIP-LATITUDE DIPL/DEG AND +C 300, 400, 1400 AND 3000 KM FOR DIP-LATITUDE DIPL/DEG AND C LOCAL SOLAR TIME SLT/H USING THE BRACE-THEIS-MODELS (J. ATMOS. C TERR. PHYS. 43, 1317, 1981); NS IS SEASON IN NORTHERN C HEMISOHERE: IS=1 SPRING, IS=2 SUMMER .... C ALSO CALCULATED ARE THE TEMPERATURES AT 400 KM ALTITUDE FOR -C MIDNIGHT (TE(5)) AND NOON (TE(6)). +C MIDNIGHT (TE(5)) AND NOON (TE(6)). DIMENSION C(4,2,81),A(82),TE(6) COMMON /CONST/UMR,PI /const1/humr,dumr - DATA (C(1,1,J),J=1,81)/ - &.3100E1,-.3215E-2,.2440E+0,-.4613E-3,-.1711E-1,.2605E-1, - &-.9546E-1,.1794E-1,.1270E-1,.2791E-1,.1536E-1,-.6629E-2, - &-.3616E-2,.1229E-1,.4147E-3,.1447E-2,-.4453E-3,-.1853, - &-.1245E-1,-.3675E-1,.4965E-2,.5460E-2,.8117E-2,-.1002E-1, - &.5466E-3,-.3087E-1,-.3435E-2,-.1107E-3,.2199E-2,.4115E-3, - &.6061E-3,.2916E-3,-.6584E-1,.4729E-2,-.1523E-2,.6689E-3, - &.1031E-2,.5398E-3,-.1924E-2,-.4565E-1,.7244E-2,-.8543E-4, - &.1052E-2,-.6696E-3,-.7492E-3,.4405E-1,.3047E-2,.2858E-2, - &-.1465E-3,.1195E-2,-.1024E-3,.4582E-1,.8749E-3,.3011E-3, - &.4473E-3,-.2782E-3,.4911E-1,-.1016E-1,.27E-2,-.9304E-3, - &-.1202E-2,.2210E-1,.2566E-2,-.122E-3,.3987E-3,-.5744E-1, - &.4408E-2,-.3497E-2,.83E-3,-.3536E-1,-.8813E-2,.2423E-2, - &-.2994E-1,-.1929E-2,-.5268E-3,-.2228E-1,.3385E-2, - &.413E-1,.4876E-2,.2692E-1,.1684E-2/ - DATA (C(1,2,J),J=1,81)/.313654E1,.6796E-2,.181413,.8564E-1, - &-.32856E-1,-.3508E-2,-.1438E-1,-.2454E-1,.2745E-2,.5284E-1, - &.1136E-1,-.1956E-1,-.5805E-2,.2801E-2,-.1211E-2,.4127E-2, - &.2909E-2,-.25751,-.37915E-2,-.136E-1,-.13225E-1,.1202E-1, - &.1256E-1,-.12165E-1,.1326E-1,-.7123E-1,.5793E-3,.1537E-2, - &.6914E-2,-.4173E-2,.1052E-3,-.5765E-3,-.4041E-1,-.1752E-2, - &-.542E-2,-.684E-2,.8921E-3,-.2228E-2,.1428E-2,.6635E-2,-.48045E-2, - &-.1659E-2,-.9341E-3,.223E-3,-.9995E-3,.4285E-1,-.5211E-3, - &-.3293E-2,.179E-2,.6435E-3,-.1891E-3,.3844E-1,.359E-2,-.8139E-3, - &-.1996E-2,.2398E-3,.2938E-1,.761E-2,.347655E-2,.1707E-2,.2769E-3, - &-.157E-1,.983E-3,-.6532E-3,.929E-4,-.2506E-1,.4681E-2,.1461E-2, - &-.3757E-5,-.9728E-2,.2315E-2,.6377E-3,-.1705E-1,.2767E-2, - &-.6992E-3,-.115E-1,-.1644E-2,.3355E-2,-.4326E-2,.2035E-1,.2985E-1/ - DATA (C(2,1,J),J=1,81)/.3136E1,.6498E-2,.2289,.1859E-1,-.3328E-1, - &-.4889E-2,-.3054E-1,-.1773E-1,-.1728E-1,.6555E-1,.1775E-1, - &-.2488E-1,-.9498E-2,.1493E-1,.281E-2,.2406E-2,.5436E-2,-.2115, - &.7007E-2,-.5129E-1,-.7327E-2,.2402E-1,.4772E-2,-.7374E-2, - &-.3835E-3,-.5013E-1,.2866E-2,.2216E-2,.2412E-3,.2094E-2,.122E-2 - &,-.1703E-3,-.1082,-.4992E-2,-.4065E-2,.3615E-2,-.2738E-2, - &-.7177E-3,.2173E-3,-.4373E-1,-.375E-2,.5507E-2,-.1567E-2, - &-.1458E-2,-.7397E-3,.7903E-1,.4131E-2,.3714E-2,.1073E-2, - &-.8991E-3,.2976E-3,.2623E-1,.2344E-2,.5608E-3,.4124E-3,.1509E-3, - &.5103E-1,.345E-2,.1283E-2,.7238E-3,-.3464E-4,.1663E-1,-.1644E-2, - &-.71E-3,.5281E-3,-.2729E-1,.3556E-2,-.3391E-2,-.1787E-3,.2154E-2, - &.6476E-2,-.8282E-3,-.2361E-1,.9557E-3,.3205E-3,-.2301E-1, - &-.854E-3,-.1126E-1,-.2323E-2,-.8582E-2,.2683E-1/ - DATA (C(2,2,J),J=1,81)/.3144E1,.8571E-2,.2539,.6937E-1,-.1667E-1, - &.2249E-1,-.4162E-1,.1201E-1,.2435E-1,.5232E-1,.2521E-1,-.199E-1, - &-.7671E-2,.1264E-1,-.1551E-2,-.1928E-2,.3652E-2,-.2019,.5697E-2, - &-.3159E-1,-.1451E-1,.2868E-1,.1377E-1,-.4383E-2,.1172E-1, - &-.5683E-1,.3593E-2,.3571E-2,.3282E-2,.1732E-2,-.4921E-3,-.1165E-2 - &,-.1066,-.1892E-1,.357E-2,-.8631E-3,-.1876E-2,-.8414E-4,.2356E-2, - &-.4259E-1,-.322E-2,.4641E-2,.6223E-3,-.168E-2,-.1243E-3,.7393E-1, - &-.3143E-2,-.2362E-2,.1235E-2,-.1551E-2,.2099E-3,.2299E-1,.5301E-2 - &,-.4306E-2,-.1303E-2,.7687E-5,.5305E-1,.6642E-2,-.1686E-2, - &.1048E-2,.5958E-3,.4341E-1,-.8819E-4,-.333E-3,-.2158E-3,-.4106E-1 - &,.4191E-2,.2045E-2,-.1437E-3,-.1803E-1,-.8072E-3,-.424E-3, - &-.26E-1,-.2329E-2,.5949E-3,-.1371E-1,-.2188E-2,.1788E-1, - &.6405E-3,.5977E-2,.1333E-1/ - DATA (C(3,1,J),J=1,81)/.3372E1,.1006E-1,.1436,.2023E-2,-.5166E-1, - &.9606E-2,-.5596E-1,.4914E-3,-.3124E-2,-.4713E-1,-.7371E-2, - &-.4823E-2,-.2213E-2,.6569E-2,-.1962E-3,.3309E-3,-.3908E-3, - &-.2836,.7829E-2,.1175E-1,.9919E-3,.6589E-2,.2045E-2,-.7346E-2 - &,-.89E-3,-.347E-1,-.4977E-2,.147E-2,-.2823E-5,.6465E-3, - &-.1448E-3,.1401E-2,-.8988E-1,-.3293E-4,-.1848E-2,.4439E-3, - &-.1263E-2,.317E-3,-.6227E-3,.1721E-1,-.199E-2,-.4627E-3, - &.2897E-5,-.5454E-3,.3385E-3,.8432E-1,-.1951E-2,.1487E-2, - &.1042E-2,-.4788E-3,-.1276E-3,.2373E-1,.2409E-2,.5263E-3, - &.1301E-2,-.4177E-3,.3974E-1,.1418E-3,-.1048E-2,-.2982E-3, - &-.3396E-4,.131E-1,.1413E-2,-.1373E-3,.2638E-3,-.4171E-1, - &-.5932E-3,-.7523E-3,-.6883E-3,-.2355E-1,.5695E-3,-.2219E-4, - &-.2301E-1,-.9962E-4,-.6761E-3,.204E-2,-.5479E-3,.2591E-1, - &-.2425E-2,.1583E-1,.9577E-2/ - DATA (C(3,2,J),J=1,81)/.3367E1,.1038E-1,.1407,.3622E-1,-.3144E-1, - &.112E-1,-.5674E-1,.3219E-1,.1288E-2,-.5799E-1,-.4609E-2, - &.3252E-2,-.2859E-3,.1226E-1,-.4539E-2,.1310E-2,-.5603E-3, - &-.311,-.1268E-2,.1539E-1,.3146E-2,.7787E-2,-.143E-2,-.482E-2 - &,.2924E-2,-.9981E-1,-.7838E-2,-.1663E-3,.4769E-3,.4148E-2, - &-.1008E-2,-.979E-3,-.9049E-1,-.2994E-2,-.6748E-2,-.9889E-3, - &.1488E-2,-.1154E-2,-.8412E-4,-.1302E-1,-.4859E-2,-.7172E-3, - &-.9401E-3,.9101E-3,-.1735E-3,.7055E-1,.6398E-2,-.3103E-2, - &-.938E-3,-.4E-3,-.1165E-2,.2713E-1,-.1654E-2,.2781E-2, - &-.5215E-5,.2258E-3,.5022E-1,.95E-2,.4147E-3,.3499E-3, - &-.6097E-3,.4118E-1,.6556E-2,.3793E-2,-.1226E-3,-.2517E-1, - &.1491E-3,.1075E-2,.4531E-3,-.9012E-2,.3343E-2,.3431E-2, - &-.2519E-1,.3793E-4,.5973E-3,-.1423E-1,-.132E-2,-.6048E-2, - &-.5005E-2,-.115E-1,.2574E-1/ - DATA (C(4,1,J),J=1,81)/.3574E1,.0,.7537E-1,.0,-.8459E-1, - &0.,-.294E-1,0.,.4547E-1,-.5321E-1,0.,.4328E-2,0.,.6022E-2, - &.0,-.9168E-3,.0,-.1768,.0,.294E-1,.0,.5902E-3,.0,-.9047E-2, - &.0,-.6555E-1,.0,-.1033E-2,.0,.1674E-2,.0,.2802E-3,-.6786E-1 - &,.0,.4193E-2,.0,-.6448E-3,.0,.9277E-3,-.1634E-1,.0,-.2531E-2 - &,.0,.193E-4,.0,.528E-1,.0,.2438E-2,.0,-.5292E-3,.0,.1555E-1 - &,.0,-.3259E-2,.0,-.5998E-3,.3168E-1,.0,.2382E-2,.0,-.4078E-3 - &,.2312E-1,.0,.1481E-3,.0,-.1885E-1,.0,.1144E-2,.0,-.9952E-2 - &,.0,-.551E-3,-.202E-1,.0,-.7283E-4,-.1272E-1,.0,.2224E-2, - &.0,-.251E-2,.2434E-1/ - DATA (C(4,2,J),J=1,81)/.3574E1,-.5639E-2,.7094E-1, - &-.3347E-1,-.861E-1,-.2877E-1,-.3154E-1,-.2847E-2,.1235E-1, - &-.5966E-1,-.3236E-2,.3795E-3,-.8634E-3,.3377E-2,-.1071E-3, - &-.2151E-2,-.4057E-3,-.1783,.126E-1,.2835E-1,-.242E-2, - &.3002E-2,-.4684E-2,-.6756E-2,-.7493E-3,-.6147E-1,-.5636E-2 - &,-.1234E-2,-.1613E-2,-.6353E-4,-.2503E-3,-.1729E-3,-.7148E-1 - &,.5326E-2,.4006E-2,.6484E-3,-.1046E-3,-.6034E-3,-.9435E-3, - &-.2385E-2,.6853E-2,.151E-2,.1319E-2,.9049E-4,-.1999E-3, - &.3976E-1,.2802E-2,-.103E-2,.5599E-3,-.4791E-3,-.846E-4, - &.2683E-1,.427E-2,.5911E-3,.2987E-3,-.208E-3,.1396E-1, - &-.1922E-2,-.1063E-2,.3803E-3,.1343E-3,.1771E-1,-.1038E-2, - &-.4645E-3,-.2481E-3,-.2251E-1,-.29E-2,-.3977E-3,-.516E-3, - &-.8079E-2,-.1528E-2,.306E-3,-.1582E-1,-.8536E-3,.1565E-3, - &-.1252E-1,.2319E-3,.4311E-2,.1024E-2,.1296E-5,.179E-1/ - + DATA (C(1,1,J),J=1,81)/ + &.3100E1,-.3215E-2,.2440E+0,-.4613E-3,-.1711E-1,.2605E-1, + &-.9546E-1,.1794E-1,.1270E-1,.2791E-1,.1536E-1,-.6629E-2, + &-.3616E-2,.1229E-1,.4147E-3,.1447E-2,-.4453E-3,-.1853, + &-.1245E-1,-.3675E-1,.4965E-2,.5460E-2,.8117E-2,-.1002E-1, + &.5466E-3,-.3087E-1,-.3435E-2,-.1107E-3,.2199E-2,.4115E-3, + &.6061E-3,.2916E-3,-.6584E-1,.4729E-2,-.1523E-2,.6689E-3, + &.1031E-2,.5398E-3,-.1924E-2,-.4565E-1,.7244E-2,-.8543E-4, + &.1052E-2,-.6696E-3,-.7492E-3,.4405E-1,.3047E-2,.2858E-2, + &-.1465E-3,.1195E-2,-.1024E-3,.4582E-1,.8749E-3,.3011E-3, + &.4473E-3,-.2782E-3,.4911E-1,-.1016E-1,.27E-2,-.9304E-3, + &-.1202E-2,.2210E-1,.2566E-2,-.122E-3,.3987E-3,-.5744E-1, + &.4408E-2,-.3497E-2,.83E-3,-.3536E-1,-.8813E-2,.2423E-2, + &-.2994E-1,-.1929E-2,-.5268E-3,-.2228E-1,.3385E-2, + &.413E-1,.4876E-2,.2692E-1,.1684E-2/ + DATA (C(1,2,J),J=1,81)/.313654E1,.6796E-2,.181413,.8564E-1, + &-.32856E-1,-.3508E-2,-.1438E-1,-.2454E-1,.2745E-2,.5284E-1, + &.1136E-1,-.1956E-1,-.5805E-2,.2801E-2,-.1211E-2,.4127E-2, + &.2909E-2,-.25751,-.37915E-2,-.136E-1,-.13225E-1,.1202E-1, + &.1256E-1,-.12165E-1,.1326E-1,-.7123E-1,.5793E-3,.1537E-2, + &.6914E-2,-.4173E-2,.1052E-3,-.5765E-3,-.4041E-1,-.1752E-2, + &-.542E-2,-.684E-2,.8921E-3,-.2228E-2,.1428E-2,.6635E-2,-.48045E-2, + &-.1659E-2,-.9341E-3,.223E-3,-.9995E-3,.4285E-1,-.5211E-3, + &-.3293E-2,.179E-2,.6435E-3,-.1891E-3,.3844E-1,.359E-2,-.8139E-3, + &-.1996E-2,.2398E-3,.2938E-1,.761E-2,.347655E-2,.1707E-2,.2769E-3, + &-.157E-1,.983E-3,-.6532E-3,.929E-4,-.2506E-1,.4681E-2,.1461E-2, + &-.3757E-5,-.9728E-2,.2315E-2,.6377E-3,-.1705E-1,.2767E-2, + &-.6992E-3,-.115E-1,-.1644E-2,.3355E-2,-.4326E-2,.2035E-1,.2985E-1/ + DATA (C(2,1,J),J=1,81)/.3136E1,.6498E-2,.2289,.1859E-1,-.3328E-1, + &-.4889E-2,-.3054E-1,-.1773E-1,-.1728E-1,.6555E-1,.1775E-1, + &-.2488E-1,-.9498E-2,.1493E-1,.281E-2,.2406E-2,.5436E-2,-.2115, + &.7007E-2,-.5129E-1,-.7327E-2,.2402E-1,.4772E-2,-.7374E-2, + &-.3835E-3,-.5013E-1,.2866E-2,.2216E-2,.2412E-3,.2094E-2,.122E-2 + &,-.1703E-3,-.1082,-.4992E-2,-.4065E-2,.3615E-2,-.2738E-2, + &-.7177E-3,.2173E-3,-.4373E-1,-.375E-2,.5507E-2,-.1567E-2, + &-.1458E-2,-.7397E-3,.7903E-1,.4131E-2,.3714E-2,.1073E-2, + &-.8991E-3,.2976E-3,.2623E-1,.2344E-2,.5608E-3,.4124E-3,.1509E-3, + &.5103E-1,.345E-2,.1283E-2,.7238E-3,-.3464E-4,.1663E-1,-.1644E-2, + &-.71E-3,.5281E-3,-.2729E-1,.3556E-2,-.3391E-2,-.1787E-3,.2154E-2, + &.6476E-2,-.8282E-3,-.2361E-1,.9557E-3,.3205E-3,-.2301E-1, + &-.854E-3,-.1126E-1,-.2323E-2,-.8582E-2,.2683E-1/ + DATA (C(2,2,J),J=1,81)/.3144E1,.8571E-2,.2539,.6937E-1,-.1667E-1, + &.2249E-1,-.4162E-1,.1201E-1,.2435E-1,.5232E-1,.2521E-1,-.199E-1, + &-.7671E-2,.1264E-1,-.1551E-2,-.1928E-2,.3652E-2,-.2019,.5697E-2, + &-.3159E-1,-.1451E-1,.2868E-1,.1377E-1,-.4383E-2,.1172E-1, + &-.5683E-1,.3593E-2,.3571E-2,.3282E-2,.1732E-2,-.4921E-3,-.1165E-2 + &,-.1066,-.1892E-1,.357E-2,-.8631E-3,-.1876E-2,-.8414E-4,.2356E-2, + &-.4259E-1,-.322E-2,.4641E-2,.6223E-3,-.168E-2,-.1243E-3,.7393E-1, + &-.3143E-2,-.2362E-2,.1235E-2,-.1551E-2,.2099E-3,.2299E-1,.5301E-2 + &,-.4306E-2,-.1303E-2,.7687E-5,.5305E-1,.6642E-2,-.1686E-2, + &.1048E-2,.5958E-3,.4341E-1,-.8819E-4,-.333E-3,-.2158E-3,-.4106E-1 + &,.4191E-2,.2045E-2,-.1437E-3,-.1803E-1,-.8072E-3,-.424E-3, + &-.26E-1,-.2329E-2,.5949E-3,-.1371E-1,-.2188E-2,.1788E-1, + &.6405E-3,.5977E-2,.1333E-1/ + DATA (C(3,1,J),J=1,81)/.3372E1,.1006E-1,.1436,.2023E-2,-.5166E-1, + &.9606E-2,-.5596E-1,.4914E-3,-.3124E-2,-.4713E-1,-.7371E-2, + &-.4823E-2,-.2213E-2,.6569E-2,-.1962E-3,.3309E-3,-.3908E-3, + &-.2836,.7829E-2,.1175E-1,.9919E-3,.6589E-2,.2045E-2,-.7346E-2 + &,-.89E-3,-.347E-1,-.4977E-2,.147E-2,-.2823E-5,.6465E-3, + &-.1448E-3,.1401E-2,-.8988E-1,-.3293E-4,-.1848E-2,.4439E-3, + &-.1263E-2,.317E-3,-.6227E-3,.1721E-1,-.199E-2,-.4627E-3, + &.2897E-5,-.5454E-3,.3385E-3,.8432E-1,-.1951E-2,.1487E-2, + &.1042E-2,-.4788E-3,-.1276E-3,.2373E-1,.2409E-2,.5263E-3, + &.1301E-2,-.4177E-3,.3974E-1,.1418E-3,-.1048E-2,-.2982E-3, + &-.3396E-4,.131E-1,.1413E-2,-.1373E-3,.2638E-3,-.4171E-1, + &-.5932E-3,-.7523E-3,-.6883E-3,-.2355E-1,.5695E-3,-.2219E-4, + &-.2301E-1,-.9962E-4,-.6761E-3,.204E-2,-.5479E-3,.2591E-1, + &-.2425E-2,.1583E-1,.9577E-2/ + DATA (C(3,2,J),J=1,81)/.3367E1,.1038E-1,.1407,.3622E-1,-.3144E-1, + &.112E-1,-.5674E-1,.3219E-1,.1288E-2,-.5799E-1,-.4609E-2, + &.3252E-2,-.2859E-3,.1226E-1,-.4539E-2,.1310E-2,-.5603E-3, + &-.311,-.1268E-2,.1539E-1,.3146E-2,.7787E-2,-.143E-2,-.482E-2 + &,.2924E-2,-.9981E-1,-.7838E-2,-.1663E-3,.4769E-3,.4148E-2, + &-.1008E-2,-.979E-3,-.9049E-1,-.2994E-2,-.6748E-2,-.9889E-3, + &.1488E-2,-.1154E-2,-.8412E-4,-.1302E-1,-.4859E-2,-.7172E-3, + &-.9401E-3,.9101E-3,-.1735E-3,.7055E-1,.6398E-2,-.3103E-2, + &-.938E-3,-.4E-3,-.1165E-2,.2713E-1,-.1654E-2,.2781E-2, + &-.5215E-5,.2258E-3,.5022E-1,.95E-2,.4147E-3,.3499E-3, + &-.6097E-3,.4118E-1,.6556E-2,.3793E-2,-.1226E-3,-.2517E-1, + &.1491E-3,.1075E-2,.4531E-3,-.9012E-2,.3343E-2,.3431E-2, + &-.2519E-1,.3793E-4,.5973E-3,-.1423E-1,-.132E-2,-.6048E-2, + &-.5005E-2,-.115E-1,.2574E-1/ + DATA (C(4,1,J),J=1,81)/.3574E1,.0,.7537E-1,.0,-.8459E-1, + &0.,-.294E-1,0.,.4547E-1,-.5321E-1,0.,.4328E-2,0.,.6022E-2, + &.0,-.9168E-3,.0,-.1768,.0,.294E-1,.0,.5902E-3,.0,-.9047E-2, + &.0,-.6555E-1,.0,-.1033E-2,.0,.1674E-2,.0,.2802E-3,-.6786E-1 + &,.0,.4193E-2,.0,-.6448E-3,.0,.9277E-3,-.1634E-1,.0,-.2531E-2 + &,.0,.193E-4,.0,.528E-1,.0,.2438E-2,.0,-.5292E-3,.0,.1555E-1 + &,.0,-.3259E-2,.0,-.5998E-3,.3168E-1,.0,.2382E-2,.0,-.4078E-3 + &,.2312E-1,.0,.1481E-3,.0,-.1885E-1,.0,.1144E-2,.0,-.9952E-2 + &,.0,-.551E-3,-.202E-1,.0,-.7283E-4,-.1272E-1,.0,.2224E-2, + &.0,-.251E-2,.2434E-1/ + DATA (C(4,2,J),J=1,81)/.3574E1,-.5639E-2,.7094E-1, + &-.3347E-1,-.861E-1,-.2877E-1,-.3154E-1,-.2847E-2,.1235E-1, + &-.5966E-1,-.3236E-2,.3795E-3,-.8634E-3,.3377E-2,-.1071E-3, + &-.2151E-2,-.4057E-3,-.1783,.126E-1,.2835E-1,-.242E-2, + &.3002E-2,-.4684E-2,-.6756E-2,-.7493E-3,-.6147E-1,-.5636E-2 + &,-.1234E-2,-.1613E-2,-.6353E-4,-.2503E-3,-.1729E-3,-.7148E-1 + &,.5326E-2,.4006E-2,.6484E-3,-.1046E-3,-.6034E-3,-.9435E-3, + &-.2385E-2,.6853E-2,.151E-2,.1319E-2,.9049E-4,-.1999E-3, + &.3976E-1,.2802E-2,-.103E-2,.5599E-3,-.4791E-3,-.846E-4, + &.2683E-1,.427E-2,.5911E-3,.2987E-3,-.208E-3,.1396E-1, + &-.1922E-2,-.1063E-2,.3803E-3,.1343E-3,.1771E-1,-.1038E-2, + &-.4645E-3,-.2481E-3,-.2251E-1,-.29E-2,-.3977E-3,-.516E-3, + &-.8079E-2,-.1528E-2,.306E-3,-.1582E-1,-.8536E-3,.1565E-3, + &-.1252E-1,.2319E-3,.4311E-2,.1024E-2,.1296E-5,.179E-1/ + IF(NS.LT.3) THEN IS=NS ELSE IF(NS.GT.3) THEN @@ -2526,158 +2597,158 @@ C MIDNIGHT (TE(5)) AND NOON (TE(6)). ELSE IS=1 ENDIF - COLAT=UMR*(90.-DIPL) - AZ=humr*SLT + COLAT=UMR*(90.-DIPL) + AZ=humr*SLT CALL SPHARM(A,8,8,COLAT,AZ) IF(IS.EQ.2) THEN KEND=3 ELSE KEND=4 - ENDIF - DO 2 K=1,KEND - STE=0. - DO 1 I=1,81 -1 STE=STE+A(I)*C(K,IS,I) + ENDIF + DO 2 K=1,KEND + STE=0. + DO 1 I=1,81 +1 STE=STE+A(I)*C(K,IS,I) 2 TE(K)=10.**STE IF(IS.EQ.2) THEN DIPL=-DIPL - COLAT=UMR*(90.-DIPL) + COLAT=UMR*(90.-DIPL) CALL SPHARM(A,8,8,COLAT,AZ) - STE=0. - DO 11 I=1,81 -11 STE=STE+A(I)*C(4,2,I) + STE=0. + DO 11 I=1,81 +11 STE=STE+A(I)*C(4,2,I) TE(4)=10.**STE ENDIF C---------- TEMPERATURE AT 400KM AT MIDNIGHT AND NOON - DO 4 J=1,2 - STE=0. - AZ=humr*(J-1)*12. - CALL SPHARM(A,8,8,COLAT,AZ) - DO 3 I=1,81 -3 STE=STE+A(I)*C(2,IS,I) -4 TE(J+4)=10.**STE - RETURN - END -C -C - SUBROUTINE SPHARM(C,L,M,COLAT,AZ) -C CALCULATES THE COEFFICIENTS OF THE SPHERICAL HARMONIC -C EXPANSION THAT WAS USED FOR THE BRACE-THEIS-MODELS. - DIMENSION C(82) - C(1)=1. - K=2 - X=COS(COLAT) - C(K)=X - K=K+1 - DO 10 I=2,L - C(K)=((2*I-1)*X*C(K-1)-(I-1)*C(K-2))/I -10 K=K+1 - Y=SIN(COLAT) - DO 20 MT=1,M - CAZ=COS(MT*AZ) - SAZ=SIN(MT*AZ) - C(K)=Y**MT - K=K+1 - IF(MT.EQ.L) GOTO 16 - C(K)=C(K-1)*X*(2*MT+1) - K=K+1 - IF((MT+1).EQ.L) GOTO 16 - DO 15 I=2+MT,L - C(K)=((2*I-1)*X*C(K-1)-(I+MT-1)*C(K-2))/(I-MT) -15 K=K+1 -16 N=L-MT+1 - DO 18 I=1,N - C(K)=C(K-N)*CAZ - C(K-N)=C(K-N)*SAZ -18 K=K+1 -20 CONTINUE - RETURN - END + DO 4 J=1,2 + STE=0. + AZ=humr*(J-1)*12. + CALL SPHARM(A,8,8,COLAT,AZ) + DO 3 I=1,81 +3 STE=STE+A(I)*C(2,IS,I) +4 TE(J+4)=10.**STE + RETURN + END +C +C + SUBROUTINE SPHARM(C,L,M,COLAT,AZ) +C CALCULATES THE COEFFICIENTS OF THE SPHERICAL HARMONIC +C EXPANSION THAT WAS USED FOR THE BRACE-THEIS-MODELS. + DIMENSION C(82) + C(1)=1. + K=2 + X=COS(COLAT) + C(K)=X + K=K+1 + DO 10 I=2,L + C(K)=((2*I-1)*X*C(K-1)-(I-1)*C(K-2))/I +10 K=K+1 + Y=SIN(COLAT) + DO 20 MT=1,M + CAZ=COS(MT*AZ) + SAZ=SIN(MT*AZ) + C(K)=Y**MT + K=K+1 + IF(MT.EQ.L) GOTO 16 + C(K)=C(K-1)*X*(2*MT+1) + K=K+1 + IF((MT+1).EQ.L) GOTO 16 + DO 15 I=2+MT,L + C(K)=((2*I-1)*X*C(K-1)-(I+MT-1)*C(K-2))/(I-MT) +15 K=K+1 +16 N=L-MT+1 + DO 18 I=1,N + C(K)=C(K-N)*CAZ + C(K-N)=C(K-N)*SAZ +18 K=K+1 +20 CONTINUE + RETURN + END C C REAL FUNCTION ELTE(H) c---------------------------------------------------------------- C ELECTRON TEMPERATURE PROFILE BASED ON THE TEMPERATURES AT 7 FIXED -C HEIGHTS (AH(7)) AND THE TEMPERATURE GRADIENTS BETWEEN THESE THESE +C HEIGHTS (AH(7)) AND THE TEMPERATURE GRADIENTS BETWEEN THESE THESE C HEIGHTS (ST(6)) GIVEN IN THE COMMON BLOCK. ATE1 IS THE TEMPERATURE C AT THE STARTING HEIGHT 120 KM. D(5) DEFINE THE TRANSITION SPAN FROM C ONE CONSTANT GRADIENT REGION TO THE NEXT. c---------------------------------------------------------------- COMMON /BLOTE/AH(7),ATE1,ST(6),D(5) C - SUM=ATE1+ST(1)*(H-AH(1)) + SUM=ATE1+ST(1)*(H-AH(1)) DO 1 I=1,5 aa = eptr(h ,d(i),ah(i+1)) bb = eptr(ah(1),d(i),ah(i+1)) -1 SUM=SUM+(ST(I+1)-ST(I))*(AA-BB)*D(I) - ELTE=SUM - RETURN - END -C -C - FUNCTION TEDE(H,DEN,COV) -C ELECTRON TEMEPERATURE MODEL AFTER BRACE,THEIS . -C FOR NEG. COV THE MEAN COV-INDEX (3 SOLAR ROT.) IS EXPECTED. -C DEN IS THE ELECTRON DENSITY IN M-3. - Y=1051.+(17.01*H-2746.)* - &EXP(-5.122E-4*H+(6.094E-12-3.353E-14*H)*DEN) - ACOV=ABS(COV) - YC=1.+(.117+2.02E-3*ACOV)/(1.+EXP(-(ACOV-102.5)/5.)) - IF(COV.LT.0.) - &YC=1.+(.123+1.69E-3*ACOV)/(1.+EXP(-(ACOV-115.)/10.)) - TEDE=Y*YC - RETURN - END -C -C -C************************************************************* +1 SUM=SUM+(ST(I+1)-ST(I))*(AA-BB)*D(I) + ELTE=SUM + RETURN + END +C +C + FUNCTION TEDE(H,DEN,COV) +C ELECTRON TEMEPERATURE MODEL AFTER BRACE,THEIS . +C FOR NEG. COV THE MEAN COV-INDEX (3 SOLAR ROT.) IS EXPECTED. +C DEN IS THE ELECTRON DENSITY IN M-3. + Y=1051.+(17.01*H-2746.)* + &EXP(-5.122E-4*H+(6.094E-12-3.353E-14*H)*DEN) + ACOV=ABS(COV) + YC=1.+(.117+2.02E-3*ACOV)/(1.+EXP(-(ACOV-102.5)/5.)) + IF(COV.LT.0.) + &YC=1.+(.123+1.69E-3*ACOV)/(1.+EXP(-(ACOV-115.)/10.)) + TEDE=Y*YC + RETURN + END +C +C +C************************************************************* C**************** ION TEMPERATURE **************************** -C************************************************************* +C************************************************************* C C REAL FUNCTION TI(H) c---------------------------------------------------------------- -C ION TEMPERATURE FOR HEIGHTS NOT GREATER 1000 KM AND NOT LESS HS -C EXPLANATION SEE FUNCTION RPID. +C ION TEMPERATURE FOR HEIGHTS NOT GREATER 1000 KM AND NOT LESS HS +C EXPLANATION SEE FUNCTION RPID. c---------------------------------------------------------------- REAL MM COMMON /BLOCK8/ HS,TNHS,XSM(4),MM(5),G(4),M - SUM=MM(1)*(H-HS)+TNHS - DO 100 I=1,M-1 + SUM=MM(1)*(H-HS)+TNHS + DO 100 I=1,M-1 aa = eptr(h ,g(i),xsm(i)) bb = eptr(hs,g(i),xsm(i)) -100 SUM=SUM+(MM(I+1)-MM(I))*(AA-BB)*G(I) - TI=SUM - RETURN - END +100 SUM=SUM+(MM(I+1)-MM(I))*(AA-BB)*G(I) + TI=SUM + RETURN + END +C C -C -C************************************************************* -C************* ION RELATIVE PRECENTAGE DENSITY ***************** -C************************************************************* +C************************************************************* +C************* ION RELATIVE PRECENTAGE DENSITY ***************** +C************************************************************* C C REAL FUNCTION RPID (H, H0, N0, M, ST, ID, XS) c------------------------------------------------------------------ -C D.BILITZA,1977,THIS ANALYTIC FUNCTION IS USED TO REPRESENT THE -C RELATIVE PRECENTAGE DENSITY OF ATOMAR AND MOLECULAR OXYGEN IONS. -C THE M+1 HEIGHT GRADIENTS ST(M+1) ARE CONNECTED WITH EPSTEIN- -C STEP-FUNCTIONS AT THE STEP HEIGHTS XS(M) WITH TRANSITION -C THICKNESSES ID(M). RPID(H0,H0,N0,....)=N0. +C D.BILITZA,1977,THIS ANALYTIC FUNCTION IS USED TO REPRESENT THE +C RELATIVE PRECENTAGE DENSITY OF ATOMAR AND MOLECULAR OXYGEN IONS. +C THE M+1 HEIGHT GRADIENTS ST(M+1) ARE CONNECTED WITH EPSTEIN- +C STEP-FUNCTIONS AT THE STEP HEIGHTS XS(M) WITH TRANSITION +C THICKNESSES ID(M). RPID(H0,H0,N0,....)=N0. C ARGMAX is the highest allowed argument for EXP in your system. c------------------------------------------------------------------ - REAL N0 - DIMENSION ID(4), ST(5), XS(4) + REAL N0 + DIMENSION ID(4), ST(5), XS(4) COMMON /ARGEXP/ ARGMAX - SUM=(H-H0)*ST(1) - DO 100 I=1,M + SUM=(H-H0)*ST(1) + DO 100 I=1,M XI=ID(I) aa = eptr(h ,xi,xs(i)) bb = eptr(h0,xi,xs(i)) -100 SUM=SUM+(ST(I+1)-ST(I))*(AA-BB)*XI +100 SUM=SUM+(ST(I+1)-ST(I))*(AA-BB)*XI IF(ABS(SUM).LT.ARGMAX) then SM=EXP(SUM) else IF(SUM.Gt.0.0) then @@ -2685,116 +2756,116 @@ c------------------------------------------------------------------ else SM=0.0 endif - RPID= n0 * SM - RETURN - END -C -c - SUBROUTINE RDHHE (H,HB,RDOH,RDO2H,RNO,PEHE,RDH,RDHE) -C BILITZA,FEB.82,H+ AND HE+ RELATIVE PERECENTAGE DENSITY BELOW -C 1000 KM. THE O+ AND O2+ REL. PER. DENSITIES SHOULD BE GIVEN -C (RDOH,RDO2H). HB IS THE ALTITUDE OF MAXIMAL O+ DENSITY. PEHE -C IS THE PRECENTAGE OF HE+ IONS COMPARED TO ALL LIGHT IONS. -C RNO IS THE RATIO OF NO+ TO O2+DENSITY AT H=HB. - RDHE=0.0 - RDH=0.0 - IF(H.LE.HB) GOTO 100 - REST=100.0-RDOH-RDO2H-RNO*RDO2H - RDH=REST*(1.-PEHE/100.) - RDHE=REST*PEHE/100. -100 RETURN - END -C -C - REAL FUNCTION RDNO(H,HB,RDO2H,RDOH,RNO) -C D.BILITZA, 1978. NO+ RELATIVE PERCENTAGE DENSITY ABOVE 100KM. -C FOR MORE INFORMATION SEE SUBROUTINE RDHHE. - IF (H.GT.HB) GOTO 200 - RDNO=100.0-RDO2H-RDOH - RETURN -200 RDNO=RNO*RDO2H - RETURN + RPID= n0 * SM + RETURN + END +C +c + SUBROUTINE RDHHE (H,HB,RDOH,RDO2H,RNO,PEHE,RDH,RDHE) +C BILITZA,FEB.82,H+ AND HE+ RELATIVE PERECENTAGE DENSITY BELOW +C 1000 KM. THE O+ AND O2+ REL. PER. DENSITIES SHOULD BE GIVEN +C (RDOH,RDO2H). HB IS THE ALTITUDE OF MAXIMAL O+ DENSITY. PEHE +C IS THE PRECENTAGE OF HE+ IONS COMPARED TO ALL LIGHT IONS. +C RNO IS THE RATIO OF NO+ TO O2+DENSITY AT H=HB. + RDHE=0.0 + RDH=0.0 + IF(H.LE.HB) GOTO 100 + REST=100.0-RDOH-RDO2H-RNO*RDO2H + RDH=REST*(1.-PEHE/100.) + RDHE=REST*PEHE/100. +100 RETURN END C C - SUBROUTINE KOEFP1(PG1O) -C THIEMANN,1979,COEFFICIENTS PG1O FOR CALCULATING O+ PROFILES -C BELOW THE F2-MAXIMUM. CHOSEN TO APPROACH DANILOV- -C SEMENOV'S COMPILATION. - DIMENSION PG1O(80), FELD (80) - DATA FELD/-11.0,-11.0,4.0,-11.0,0.08018,0.13027,0.04216, - &0.25,-0.00686,0.00999,5.113,0.1 ,170.0,180.0,0.1175,0.15, - &-11.0,1.0 ,2.0,-11.0,0.069,0.161,0.254,0.18,0.0161,0.0216, - &0.03014,0.1,152.0,167.0,0.04916,0.17,-11.0,2.0,2.0,-11.0, - &0.072,0.092,0.014,0.21,0.01389,0.03863,0.05762,0.12,165.0, - &168.0,0.008,0.258,-11.0,1.0,3.0,-11.0,0.091,0.088,0.008, - &0.34,0.0067,0.0195,0.04,0.1,158.0,172.0,0.01,0.24,-11.0, - &2.0,3.0,-11.0,0.083,0.102,0.045,0.03,0.00127,0.01,0.05, - &0.09,167.0,185.0,0.015,0.18/ - DO 10 I=1,80 -10 PG1O(I)=FELD(I) - RETURN - END -C -C - SUBROUTINE KOEFP2(PG2O) -C THIEMANN,1979,COEFFICIENTS FOR CALCULATION OF O+ PROFILES -C ABOVE THE F2-MAXIMUM (DUMBS,SPENNER:AEROS-COMPILATION) - DIMENSION PG2O(32), FELD(32) - DATA FELD/1.0,-11.0,-11.0,1.0,695.0,-.000781,-.00264, - &2177.0,1.0,-11.0,-11.0,2.0,570.0,-.002,-.0052,1040.0, - &2.0,-11.0,-11.0,1.0,695.0,-.000786,-.00165,3367.0,2.0, - &-11.0,-11.0,2.0,575.0,-.00126,-.00524,1380.0/ - DO 10 I=1,32 -10 PG2O(I)=FELD(I) - RETURN - END -C -C - SUBROUTINE KOEFP3(PG3O) -C THIEMANN,1979,COEFFICIENTS FOR CALCULATING O2+ PROFILES. -C CHOSEN AS TO APPROACH DANILOV-SEMENOV'S COMPILATION. - DIMENSION PG3O(80), FELD(80) - DATA FELD/-11.0,1.0,2.0,-11.0,160.0,31.0,130.0,-10.0, - &198.0,0.0,0.05922,-0.07983,-0.00397,0.00085,-0.00313, - &0.0,-11.0,2.0,2.0,-11.0,140.0,30.0,130.0,-10.0,190.0, - &0.0,0.05107,-0.07964,0.00097,-0.01118,-0.02614,-0.09537, - &-11.0,1.0,3.0,-11.0,140.0,37.0,125.0,0.0,182.0,0.0, - &0.0307,-0.04968,-0.00248,-0.02451,-0.00313,0.0,-11.0, - &2.0,3.0,-11.0,140.0,37.0,125.0,0.0,170.0,0.0,0.02806, - &-0.04716,0.00066,-0.02763,-0.02247,-0.01919,-11.0,-11.0, - &4.0,-11.0,140.0,45.0,136.0,-9.0,181.0,-26.0,0.02994, - &-0.04879,-0.01396,0.00089,-0.09929,0.05589/ - DO 10 I=1,80 -10 PG3O(I)=FELD(I) - RETURN - END -C -C - SUBROUTINE SUFE (FIELD,RFE,M,FE) + REAL FUNCTION RDNO(H,HB,RDO2H,RDOH,RNO) +C D.BILITZA, 1978. NO+ RELATIVE PERCENTAGE DENSITY ABOVE 100KM. +C FOR MORE INFORMATION SEE SUBROUTINE RDHHE. + IF (H.GT.HB) GOTO 200 + RDNO=100.0-RDO2H-RDOH + RETURN +200 RDNO=RNO*RDO2H + RETURN + END +C +C + SUBROUTINE KOEFP1(PG1O) +C THIEMANN,1979,COEFFICIENTS PG1O FOR CALCULATING O+ PROFILES +C BELOW THE F2-MAXIMUM. CHOSEN TO APPROACH DANILOV- +C SEMENOV'S COMPILATION. + DIMENSION PG1O(80), FELD (80) + DATA FELD/-11.0,-11.0,4.0,-11.0,0.08018,0.13027,0.04216, + &0.25,-0.00686,0.00999,5.113,0.1 ,170.0,180.0,0.1175,0.15, + &-11.0,1.0 ,2.0,-11.0,0.069,0.161,0.254,0.18,0.0161,0.0216, + &0.03014,0.1,152.0,167.0,0.04916,0.17,-11.0,2.0,2.0,-11.0, + &0.072,0.092,0.014,0.21,0.01389,0.03863,0.05762,0.12,165.0, + &168.0,0.008,0.258,-11.0,1.0,3.0,-11.0,0.091,0.088,0.008, + &0.34,0.0067,0.0195,0.04,0.1,158.0,172.0,0.01,0.24,-11.0, + &2.0,3.0,-11.0,0.083,0.102,0.045,0.03,0.00127,0.01,0.05, + &0.09,167.0,185.0,0.015,0.18/ + DO 10 I=1,80 +10 PG1O(I)=FELD(I) + RETURN + END +C +C + SUBROUTINE KOEFP2(PG2O) +C THIEMANN,1979,COEFFICIENTS FOR CALCULATION OF O+ PROFILES +C ABOVE THE F2-MAXIMUM (DUMBS,SPENNER:AEROS-COMPILATION) + DIMENSION PG2O(32), FELD(32) + DATA FELD/1.0,-11.0,-11.0,1.0,695.0,-.000781,-.00264, + &2177.0,1.0,-11.0,-11.0,2.0,570.0,-.002,-.0052,1040.0, + &2.0,-11.0,-11.0,1.0,695.0,-.000786,-.00165,3367.0,2.0, + &-11.0,-11.0,2.0,575.0,-.00126,-.00524,1380.0/ + DO 10 I=1,32 +10 PG2O(I)=FELD(I) + RETURN + END +C +C + SUBROUTINE KOEFP3(PG3O) +C THIEMANN,1979,COEFFICIENTS FOR CALCULATING O2+ PROFILES. +C CHOSEN AS TO APPROACH DANILOV-SEMENOV'S COMPILATION. + DIMENSION PG3O(80), FELD(80) + DATA FELD/-11.0,1.0,2.0,-11.0,160.0,31.0,130.0,-10.0, + &198.0,0.0,0.05922,-0.07983,-0.00397,0.00085,-0.00313, + &0.0,-11.0,2.0,2.0,-11.0,140.0,30.0,130.0,-10.0,190.0, + &0.0,0.05107,-0.07964,0.00097,-0.01118,-0.02614,-0.09537, + &-11.0,1.0,3.0,-11.0,140.0,37.0,125.0,0.0,182.0,0.0, + &0.0307,-0.04968,-0.00248,-0.02451,-0.00313,0.0,-11.0, + &2.0,3.0,-11.0,140.0,37.0,125.0,0.0,170.0,0.0,0.02806, + &-0.04716,0.00066,-0.02763,-0.02247,-0.01919,-11.0,-11.0, + &4.0,-11.0,140.0,45.0,136.0,-9.0,181.0,-26.0,0.02994, + &-0.04879,-0.01396,0.00089,-0.09929,0.05589/ + DO 10 I=1,80 +10 PG3O(I)=FELD(I) + RETURN + END +C +C + SUBROUTINE SUFE (FIELD,RFE,M,FE) C SELECTS THE REQUIRED ION DENSITY PARAMETER SET. -C THE INPUT FIELD INCLUDES DIFFERENT SETS OF DIMENSION M EACH -C CARACTERISED BY 4 HEADER NUMBERS. RFE(4) SHOULD CONTAIN THE -C CHOSEN HEADER NUMBERS.FE(M) IS THE CORRESPONDING SET. - DIMENSION RFE(4),FE(12),FIELD(80),EFE(4) - K=0 -100 DO 101 I=1,4 - K=K+1 -101 EFE(I)=FIELD(K) - DO 111 I=1,M - K=K+1 -111 FE(I)=FIELD(K) - DO 120 I=1,4 - IF((EFE(I).GT.-10.0).AND.(RFE(I).NE.EFE(I))) GOTO 100 -120 CONTINUE - RETURN - END +C THE INPUT FIELD INCLUDES DIFFERENT SETS OF DIMENSION M EACH +C CARACTERISED BY 4 HEADER NUMBERS. RFE(4) SHOULD CONTAIN THE +C CHOSEN HEADER NUMBERS.FE(M) IS THE CORRESPONDING SET. + DIMENSION RFE(4),FE(12),FIELD(80),EFE(4) + K=0 +100 DO 101 I=1,4 + K=K+1 +101 EFE(I)=FIELD(K) + DO 111 I=1,M + K=K+1 +111 FE(I)=FIELD(K) + DO 120 I=1,4 + IF((EFE(I).GT.-10.0).AND.(RFE(I).NE.EFE(I))) GOTO 100 +120 CONTINUE + RETURN + END C C subroutine iondani(id,ismo,hx,zd,fd,fs,dion) c------------------------------------------------------- c id day of month -c ismo seasonal month (Northern Hemisphere January +c ismo seasonal month (Northern Hemisphere January c is ismo=1 and so is Southern H. July) c hx altitude in km c zd solar zenith angle in degrees @@ -2850,7 +2921,7 @@ c h altitude in km c zd solar zenith angle in degrees c fd latitude in degrees (same result for fd and -fd) c fs 10.7cm solar radio flux -c t seasonal decimal month (Northern Hemisphere January +c t seasonal decimal month (Northern Hemisphere January c 15 is t=1.5 and so is Southern Hemisphere July 15) c cn(1) O+ relative density in percent c cn(2) H+ relative density in percent @@ -2881,7 +2952,7 @@ c & pn(5,6),phe(5,6),pno(5,6),po2(5,6),pcl(5,6) & 4*0.,-6.3E-5,-6.74E-3,-7.93E-3,-4.65E-3,0.,-3.26E-3, & 4*0.,-1.17E-5,4.88E-3,-1.31E-3,-7.03E-4,0.,-2.38E-3/ data phe/-8.95E-1,6.1,5.39,0.,8.01,4*0.,1200.,4*0.,-1.04E-5, - & 1.9E-3,9.53E-4,1.06E-3,0.,-3.44E-3,10*0./ + & 1.9E-3,9.53E-4,1.06E-3,0.,-3.44E-3,10*0./ c data pno/-22.4,17.7,-13.4,-4.88,62.3,32.7,0.,19.8,2.07,115., c & 5*0.,3.94E-3,0.,2.48E-3,2.15E-4,6.67E-3,5*0., c & -8.4E-3,0.,-3.64E-3,2.E-3,-2.59E-2/ @@ -2921,13 +2992,13 @@ c do 5 i=1,7 beth(i)= var(6) hx=h-hm(i) if(hx) 1,2,3 -1 arg = hx * (hx * all(i) + betl(i)) +1 arg = hx * (hx * all(i) + betl(i)) cn(i) = 0. if(arg.gt.-argmax) cn(i) = cm(i) * exp( arg ) goto 4 2 cn(i) = cm(i) goto 4 -3 arg = hx * (hx * alh(i) + beth(i)) +3 arg = hx * (hx * alh(i) + beth(i)) cn(i) = 0. if(arg.gt.-argmax) cn(i) = cm(i) * exp( arg ) 4 continue @@ -2947,67 +3018,67 @@ C * INPUT: * hei - altitude in km * xhi - solar zenith angle in degree -* it - seasonal month (Northern Hemisphere January +* it - seasonal month (Northern Hemisphere January * is ismo=1 and so is Southern Hemisohere July) * F - 10.7cm solar radio flux (12-month running mean) * OUTPUT: * R1 - NO+ concentration (in percent) -* R2 - O2+ concentration (in percent) -* R3 - Cb+ concentration (in percent) -* R4 - O+ concentration (in percent) +* R2 - O2+ concentration (in percent) +* R3 - Cb+ concentration (in percent) +* R4 - O+ concentration (in percent) * -* A.D. Danilov and N.V. Smirnova, Improving the 75 to 300 km ion +* A.D. Danilov and N.V. Smirnova, Improving the 75 to 300 km ion * composition model of the IRI, Adv. Space Res. 15, #2, 171-177, 1995. * *----------------------------------------------------------------- dimension j1ms70(7),j2ms70(7),h1s70(13,7),h2s70(13,7), * R1ms70(13,7),R2ms70(13,7),rk1ms70(13,7),rk2ms70(13,7), - * j1ms140(7),j2ms140(7),h1s140(13,7),h2s140(13,7), + * j1ms140(7),j2ms140(7),h1s140(13,7),h2s140(13,7), * R1ms140(13,7),R2ms140(13,7),rk1ms140(13,7),rk2ms140(13,7), * j1mw70(7),j2mw70(7),h1w70(13,7),h2w70(13,7), * R1mw70(13,7),R2mw70(13,7),rk1mw70(13,7),rk2mw70(13,7), - * j1mw140(7),j2mw140(7),h1w140(13,7),h2w140(13,7), + * j1mw140(7),j2mw140(7),h1w140(13,7),h2w140(13,7), * R1mw140(13,7),R2mw140(13,7),rk1mw140(13,7),rk2mw140(13,7), * j1mr70(7),j2mr70(7),h1r70(13,7),h2r70(13,7), * R1mr70(13,7),R2mr70(13,7),rk1mr70(13,7),rk2mr70(13,7), - * j1mr140(7),j2mr140(7),h1r140(13,7),h2r140(13,7), + * j1mr140(7),j2mr140(7),h1r140(13,7),h2r140(13,7), * R1mr140(13,7),R2mr140(13,7),rk1mr140(13,7),rk2mr140(13,7) - data j1ms70/11,11,10,10,11,9,11/ + data j1ms70/11,11,10,10,11,9,11/ data j2ms70/13,11,10,11,11,9,11/ data h1s70/75,85,90,95,100,120,130,200,220,250,270,0,0, - * 75,85,90,95,100,120,130,200,220,250,270,0,0, + * 75,85,90,95,100,120,130,200,220,250,270,0,0, * 75,85,90,95,100,115,200,220,250,270,0,0,0, * 75,80,95,100,120,140,200,220,250,270,0,0,0, * 75,80,95,100,120,150,170,200,220,250,270,0,0, * 75,80,95,100,140,200,220,250,270,0,0,0,0, * 75,80,85,95,100,110,145,200,220,250,270,0,0/ data h2s70/75,80,90,95,100,120,130,140,150,200,220,250,270, - * 75,80,90,95,100,120,130,200,220,250,270,0,0, + * 75,80,90,95,100,120,130,200,220,250,270,0,0, * 75,80,90,95,100,115,200,220,250,270,0,0,0, * 75,80,95,100,120,140,150,200,220,250,270,0,0, * 75,80,95,100,120,150,170,200,220,250,270,0,0, * 75,80,95,100,140,200,220,250,270,0,0,0,0, * 75,80,90,95,100,110,145,200,220,250,270,0,0/ data R1ms70/6,30,60,63,59,59,66,52,20,4,2,0,0, - * 6,30,60,63,69,62,66,52,20,4,2,0,0, + * 6,30,60,63,69,62,66,52,20,4,2,0,0, * 6,30,60,63,80,68,53,20,4,2,0,0,0, - * 4,10,60,85,65,65,52,25,12,4,0,0,0, - * 4,10,60,89,72,60,60,52,30,20,10,0,0, - * 4,10,60,92,68,54,40,25,13,0,0,0,0, - * 1,8,20,60,95,93,69,65,45,30,20,0,0/ + * 4,10,60,85,65,65,52,25,12,4,0,0,0, + * 4,10,60,89,72,60,60,52,30,20,10,0,0, + * 4,10,60,92,68,54,40,25,13,0,0,0,0, + * 1,8,20,60,95,93,69,65,45,30,20,0,0/ data R2ms70/4,10,30,32,41,41,32,29,34,28,15,3,1, * 4,10,30,32,31,38,32,28,15,3,1,0,0, * 4,10,30,32,20,32,28,15,3,1,0,0,0, * 2,6,30,15,35,30,34,26,19,8,3,0,0, * 2,6,30,11,28,38,29,29,25,12,5,0,0, * 2,6,30,8,32,30,20,14,8,0,0,0,0, - * 1,2,10,20,5,7,31,23,18,15,10,0,0/ + * 1,2,10,20,5,7,31,23,18,15,10,0,0/ data rk1ms70/2.4,6.,.6,-.8,0,.7,-.2,-1.6,-.533,-.1,-.067,0,0, - * 2.4,6.,.6,1.2,-.35,.4,-.2,-1.6,-.533,-.1,-.067,0,0, + * 2.4,6.,.6,1.2,-.35,.4,-.2,-1.6,-.533,-.1,-.067,0,0, * 2.4,6.,.6,3.4,-.8,-.176,-1.65,-.533,-.1,-.067,0,0,0, * 1.2,3.333,5.,-1.,0,-.216,-1.35,-.433,-.4,-.1,0,0,0, - * 1.2,3.333,5.8,-.85,-.4,0,-.267,-1.1,-.333,-.4,-.2,0,0, - * 1.2,3.333,6.4,-.6,-.233,-.7,-.5,-.6,-.267,0,0,0,0, + * 1.2,3.333,5.8,-.85,-.4,0,-.267,-1.1,-.333,-.4,-.2,0,0, + * 1.2,3.333,6.4,-.6,-.233,-.7,-.5,-.6,-.267,0,0,0,0, * 1.4,2.4,4.,7.,-.2,-.686,-.072,-1.,-.5,-.5,-.5,0,0/ data rk2ms70/1.2,2.,.4,1.8,0,-.9,-.3,.5,-.12,-.65,-.4,-.1,-.033, * 1.2,2.,.4,-.2,.35,-.6,-.057,-.65,-.4,-.1,-.033,0,0, @@ -3016,7 +3087,7 @@ C * .8,1.6,-3.8,.85,.333,-.45,0,-.2,-.433,-.35,-.1,0,0, * .8,1.6,-4.4,.6,-.033,-.5,-.2,-.3,-.2,0,0,0,0, * .2,.8,2.,-3.,.2,.686,-.145,-.25,-.1,-.25,-.2,0,0/ - data j1ms140/11,11,10,10,9,9,12/ + data j1ms140/11,11,10,10,9,9,12/ data j2ms140/11,11,10,9,10,10,12/ data h1s140/75,85,90,95,100,120,130,140,200,220,250,0,0, * 75,85,90,95,100,120,130,140,200,220,250,0,0, @@ -3038,16 +3109,16 @@ C * 4,10,60,85,66,66,38,22,9,1,0,0,0, * 4,10,60,89,71,42,26,17,10,0,0,0,0, * 4,10,60,93,71,48,35,22,10,0,0,0,0, - * 1,8,20,60,95,93,72,60,58,40,26,13,0/ + * 1,8,20,60,95,93,72,60,58,40,26,13,0/ data R2ms140/4,10,30,32,41,41,30,30,10,6,1,0,0, * 4,10,30,32,31,38,31,29,9,6,1,0,0, * 4,10,30,32,20,35,26,9,6,1,0,0,0, * 2,6,30,15,34,24,10,5,1,0,0,0,0, * 2,6,30,11,28,37,21,14,8,5,0,0,0, * 2,6,30,7,29,36,29,20,13,5,0,0,0, - * 1,2,10,20,5,7,28,32,28,20,14,7,0/ + * 1,2,10,20,5,7,28,32,28,20,14,7,0/ data rk1ms140/2.4,6.,.6,-.8,0,.7,0,-.467,-1.2,-.433,0,0,0, - * 2.4,6.,.6,1.2,-.35,.4,0,-.467,-1.2,-.433,0,0,0, + * 2.4,6.,.6,1.2,-.35,.4,0,-.467,-1.2,-.433,0,0,0, * 2.4,6.,.6,3.4,-.75,0,-.45,-1.2,-.433,0,0,0,0, * 1.2,3.333,5.,-.95,0,-.467,-.8,-.433,-.4,0,0,0,0, * 1.2,3.333,5.8,-.9,-.363,-.8,-.3,-.35,-.3,0,0,0,0, @@ -3058,143 +3129,143 @@ C * 1.2,2.,.4,-2.4,.75,-.2,-.486,-.15,-.166,0,0,0,0, * .8,1.6,-3.,.95,-.167,-.7,-.1,-.2,0,0,0,0,0, * .8,1.6,-3.8,.85,.225,-.4,-.35,-.2,-.15,-.133,0,0,0, - * .8,1.6,-4.6,.733,.233,-.175,-.45,-.233,-.4,-.1,0,0,0, + * .8,1.6,-4.6,.733,.233,-.175,-.45,-.233,-.4,-.1,0,0,0, * .2,.8,2.,-3.,.2,.7,.1,-.2,-.4,-.2,-.35,-.167,0/ - data j1mr70/12,12,12,9,10,11,13/ + data j1mr70/12,12,12,9,10,11,13/ data j2mr70/9,9,10,13,12,11,11/ data h1r70/75,80,90,95,100,120,140,180,200,220,250,270,0, - * 75,80,90,95,100,120,145,180,200,220,250,270,0, - * 75,80,90,95,100,120,145,180,200,220,250,270,0, + * 75,80,90,95,100,120,145,180,200,220,250,270,0, + * 75,80,90,95,100,120,145,180,200,220,250,270,0, * 75,95,100,110,140,180,200,250,270,0,0,0,0, * 75,95,125,150,185,195,200,220,250,270,0,0,0, * 75,95,100,150,160,170,190,200,220,250,270,0,0, * 75,80,85,95,100,140,160,170,190,200,220,250,270/ data h2r70/75,95,100,120,180,200,220,250,270,0,0,0,0, - * 75,95,100,120,180,200,220,250,270,0,0,0,0, - * 75,95,100,120,130,190,200,220,250,270,0,0,0, + * 75,95,100,120,180,200,220,250,270,0,0,0,0, + * 75,95,100,120,130,190,200,220,250,270,0,0,0, * 75,80,85,95,100,110,130,180,190,200,220,250,270, * 75,80,85,95,100,125,150,190,200,220,250,270,0, - * 75,80,85,95,100,150,190,200,220,250,270,0,0, + * 75,80,85,95,100,150,190,200,220,250,270,0,0, * 75,85,95,100,140,180,190,200,220,250,270,0,0/ data R1mr70/13,17,57,57,30,53,58,38,33,14,6,2,0, - * 13,17,57,57,37,56,56,38,33,14,6,2,0, - * 13,17,57,57,47,58,55,37,33,14,6,2,0, - * 5,65,54,58,58,38,33,9,1,0,0,0,0, - * 5,65,65,54,40,40,45,26,17,10,0,0,0, - * 5,65,76,56,57,48,44,51,35,22,10,0,0, - * 3,11,35,75,90,65,63,54,54,50,40,26,13/ + * 13,17,57,57,37,56,56,38,33,14,6,2,0, + * 13,17,57,57,47,58,55,37,33,14,6,2,0, + * 5,65,54,58,58,38,33,9,1,0,0,0,0, + * 5,65,65,54,40,40,45,26,17,10,0,0,0, + * 5,65,76,56,57,48,44,51,35,22,10,0,0, + * 3,11,35,75,90,65,63,54,54,50,40,26,13/ data R2mr70/7,43,70,47,15,17,10,4,0,0,0,0,0, - * 7,43,63,44,17,17,10,4,0,0,0,0,0, + * 7,43,63,44,17,17,10,4,0,0,0,0,0, * 7,43,53,42,42,13,17,10,4,0,0,0,0, * 3,5,26,34,46,42,41,23,16,16,10,1,0, - * 3,5,26,34,35,35,42,25,22,14,8,5,0, + * 3,5,26,34,35,35,42,25,22,14,8,5,0, * 3,5,26,34,24,41,31,26,20,13,5,0,0, - * 3,15,15,10,35,35,30,34,20,14,7,0,0/ + * 3,15,15,10,35,35,30,34,20,14,7,0,0/ data rk1mr70/.8,4.,0,-5.4,1.15,.25,-.5,-.25,-.95,-.267,-.2, * -.067,0, - * .8,4.,0,-4.,.95,0,-.514,-.25,-.95,-.267,-.2,-.067,0, - * .8,4.,0,-2.,.55,-.12,-.514,-.2,-.95,-.267,-.2,-.067,0, - * 3.,-2.2,.4,0,-.5,-.25,-.48,-.4,-.033,0,0,0,0, - * 3.,0,-.44,-.466,0,1.0,-.95,-.3,-.35,-.3,0,0,0, - * 3.,2.2,-.4,0.1,-.9,-.2,.7,-.8,-.433,-.6,-.267,0,0, + * .8,4.,0,-4.,.95,0,-.514,-.25,-.95,-.267,-.2,-.067,0, + * .8,4.,0,-2.,.55,-.12,-.514,-.2,-.95,-.267,-.2,-.067,0, + * 3.,-2.2,.4,0,-.5,-.25,-.48,-.4,-.033,0,0,0,0, + * 3.,0,-.44,-.466,0,1.0,-.95,-.3,-.35,-.3,0,0,0, + * 3.,2.2,-.4,0.1,-.9,-.2,.7,-.8,-.433,-.6,-.267,0,0, * 1.6,4.8,4.,3.,-.625,-.1,-.9,0,-.4,-.5,-.467,-.65,-.3/ data rk2mr70/1.8,5.4,-1.15,-.533,.1,-.35,-.2,-.2,0,0,0,0,0, * 1.8,4.,-.95,-.45,0,-.35,-.2,-.2,0,0,0,0,0, - * 1.8,2.,-.55,0,-.483,.4,-.35,-.2,-.2,0,0,0,0, + * 1.8,2.,-.55,0,-.483,.4,-.35,-.2,-.2,0,0,0,0, * .4,4.2,.8,2.4,-.4,-.05,-.36,-.7,0,-.3,-.3,-.05,0, - * .4,4.2,.8,.2,0,.28,-.425,-.3,-.4,-.2,-.15,-.133,0, - * .4,4.2,.8,-2.,.34,-.25,-.5,-.3,-.233,-.4,-.1,0,0, + * .4,4.2,.8,.2,0,.28,-.425,-.3,-.4,-.2,-.15,-.133,0, + * .4,4.2,.8,-2.,.34,-.25,-.5,-.3,-.233,-.4,-.1,0,0, * 1.2,0,-1.,.625,0,-.5,.4,-.7,-.2,-.35,-.167,0,0/ - data j1mr140/12,12,11,12,9,9,13/ + data j1mr140/12,12,11,12,9,9,13/ data j2mr140/10,9,10,12,13,13,12/ data h1r140/75,80,90,95,100,115,130,145,200,220,250,270,0, - * 75,80,90,95,100,110,120,145,200,220,250,270,0, + * 75,80,90,95,100,110,120,145,200,220,250,270,0, * 75,80,90,95,100,115,150,200,220,250,270,0,0, * 75,95,100,120,130,140,150,190,200,220,250,270,0, * 75,95,120,150,190,200,220,250,270,0,0,0,0, * 75,95,100,145,190,200,220,250,270,0,0,0,0, * 75,80,85,95,100,120,160,170,190,200,220,250,270/ data h2r140/75,95,100,115,130,175,200,220,250,270,0,0,0, - * 75,95,100,110,175,200,220,250,270,0,0,0,0, - * 75,95,100,115,130,180,200,220,250,270,0,0,0, + * 75,95,100,110,175,200,220,250,270,0,0,0,0, + * 75,95,100,115,130,180,200,220,250,270,0,0,0, * 75,80,85,95,100,120,130,190,200,220,250,270,0, * 75,80,85,95,100,120,140,160,190,200,220,250,270, * 75,80,85,95,100,145,165,180,190,200,220,250,270, * 75,85,95,100,120,145,170,190,200,220,250,270,0/ data R1mr140/13,17,57,57,28,51,56,56,12,8,1,0,0, - * 13,17,57,57,36,46,55,56,10,8,1,0,0, + * 13,17,57,57,36,46,55,56,10,8,1,0,0, * 13,17,57,57,46,56,55,12,8,1,0,0,0, * 5,65,54,59,56,56,53,23,16,13,3,1,0, * 5,65,65,54,29,16,16,10,2,0,0,0,0, * 5,65,76,58,36,25,20,12,7,0,0,0,0, - * 3,11,35,75,91,76,58,49,45,32,28,20,12/ + * 3,11,35,75,91,76,58,49,45,32,28,20,12/ data R2mr140/7,43,72,49,44,14,7,4,1,0,0,0,0, - * 7,43,64,51,14,7,4,1,0,0,0,0,0, + * 7,43,64,51,14,7,4,1,0,0,0,0,0, * 7,43,54,44,44,13,7,4,1,0,0,0,0, * 3,5,26,34,46,41,44,9,11,7,2,1,0, - * 3,5,26,34,35,35,40,40,16,14,9,5,2, + * 3,5,26,34,35,35,40,40,16,14,9,5,2, * 3,5,26,34,24,40,40,32,19,20,10,7,3, - * 3,15,15,9,24,35,40,28,28,20,10,8,0/ + * 3,15,15,9,24,35,40,28,28,20,10,8,0/ data rk1mr140/.8,4.,0,-5.8,1.533,.333,0,-.8,-.2,-.233,-.05,0,0, * .8,4.,0,-4.2,1.3,.6,.04,-.836,-.1,-.233,-.05,0,0, - * .8,4.,0,-2.2,.667,-.029,-.86,-.2,-.233,-.05,0,0,0, + * .8,4.,0,-2.2,.667,-.029,-.86,-.2,-.233,-.05,0,0,0, * 3.,-2.2,.25,-.3,0,-.3,-.75,-.7,-.15,-.333,-.1,-.033,0, - * 3.,0,-.367,-.625,-1.3,0,-.2,-.4,-.067,0,0,0,0, + * 3.,0,-.367,-.625,-1.3,0,-.2,-.4,-.067,0,0,0,0, * 3.,2.2,-.4,-.489,-1.1,-.25,-.267,-.25,-.2,0,0,0,0, * 1.6,4.8,4.,3.2,-.75,-.45,-.9,-.2,-1.3,-.2,-.267,-.4,-.3/ data rk2mr140/1.8,5.8,-1.533,-.333,-.667,-.28,-.15,-.1,-.05, * 0,0,0,0, * 1.8,4.2,-1.3,-.569,-.28,-.15,-.1,-.05,0,0,0,0,0, - * 1.8,2.2,-.667,0,-.62,-.3,-.15,-.1,-.05,0,0,0,0, + * 1.8,2.2,-.667,0,-.62,-.3,-.15,-.1,-.05,0,0,0,0, * .4,4.2,.8,2.4,-.25,.3,-.583,.2,-.2,-.167,-.05,-.033,0, - * .4,4.2,.8,.02,0,.25,0,-.6,-.2,-.25,-.133,-.15,-.067, - * .4,4.2,.8,-2.,.356,0,-.533,-1.3,.1,-.5,-.1,-.2,-.1, + * .4,4.2,.8,.02,0,.25,0,-.6,-.2,-.25,-.133,-.15,-.067, + * .4,4.2,.8,-2.,.356,0,-.533,-1.3,.1,-.5,-.1,-.2,-.1, * 1.2,0,-1.2,.75,.44,.2,-.6,0,-.4,-.333,-.1,-.2,0/ - data j1mw70/13,13,13,13,9,8,9/ + data j1mw70/13,13,13,13,9,8,9/ data j2mw70/10,10,11,11,9,8,11/ data h1w70/75,80,85,95,100,110,125,145,180,200,220,250,270, * 75,80,85,95,100,110,120,150,180,200,220,250,270, * 75,80,85,95,100,110,120,155,180,200,220,250,270, - * 75,80,90,100,110,120,140,160,190,200,220,250,270, + * 75,80,90,100,110,120,140,160,190,200,220,250,270, * 75,80,90,110,150,200,220,250,270,0,0,0,0, * 75,80,90,100,150,200,250,270,0,0,0,0,0, * 75,80,90,100,120,130,140,200,270,0,0,0,0/ data h2w70/75,90,95,100,110,125,190,200,250,270,0,0,0, - * 75,90,95,100,110,125,190,200,250,270,0,0,0, + * 75,90,95,100,110,125,190,200,250,270,0,0,0, * 75,90,95,100,110,120,145,190,200,250,270,0,0, * 75,80,95,100,110,120,150,200,220,250,270,0,0, * 75,80,90,95,110,145,200,250,270,0,0,0,0, * 75,80,90,100,140,150,200,250,0,0,0,0,0, - * 75,80,85,90,100,120,130,140,160,200,270,0,0/ + * 75,80,85,90,100,120,130,140,160,200,270,0,0/ data R1mw70/28,35,65,65,28,44,46,50,25,25,10,5,0, * 28,35,65,65,36,49,47,47,25,25,10,5,0, * 28,35,65,65,48,54,51,43,25,25,10,5,0, - * 16,24,66,54,58,50,50,38,25,25,10,5,0, - * 16,24,66,66,46,30,20,6,3,0,0,0,0, - * 16,24,66,76,49,32,12,7,0,0,0,0,0, - * 6,19,67,91,64,68,60,40,12,0,0,0,0/ + * 16,24,66,54,58,50,50,38,25,25,10,5,0, + * 16,24,66,66,46,30,20,6,3,0,0,0,0, + * 16,24,66,76,49,32,12,7,0,0,0,0,0, + * 6,19,67,91,64,68,60,40,12,0,0,0,0/ data R2mw70/5,35,35,72,56,54,12,12,2,0,0,0,0, - * 5,35,35,64,51,53,12,12,2,0,0,0,0, + * 5,35,35,64,51,53,12,12,2,0,0,0,0, * 5,35,35,52,46,49,41,12,12,2,0,0,0, * 4,10,40,46,42,50,41,12,7,2,0,0,0, * 4,10,30,34,34,51,14,4,2,0,0,0,0, * 4,10,30,24,45,48,20,5,0,0,0,0,0, - * 2,6,17,23,9,36,32,40,40,20,6,0,0/ + * 2,6,17,23,9,36,32,40,40,20,6,0,0/ data rk1mw70/1.4,6.,0,-7.4,1.6,.133,.2,-.714,0,-.75,-.167,-.25,0, * 1.4,6.,0,-5.8,1.3,-.2,0,-.733,0,-.75,-.167,-.25,0, * 1.4,6.,0,-3.4,.6,-.3,-.229,-.72,0,-.75,-.167,-.25,0, - * 1.6,4.2,-1.2,.4,-.8,0,-.6,-.433,0,-.75,-.167,-.25,0, + * 1.6,4.2,-1.2,.4,-.8,0,-.6,-.433,0,-.75,-.167,-.25,0, * 1.6,4.2,0,-.5,-.32,-.5,-.467,-.15,-.1,0,0,0,0, - * 1.6,4.2,1.,-.54,-.34,-.4,-.25,-.2,0,0,0,0,0, + * 1.6,4.2,1.,-.54,-.34,-.4,-.25,-.2,0,0,0,0,0, * 2.6,4.8,2.4,-1.35,.4,-.8,-.333,-.4,-.3,0,0,0,0/ data rk2mw70/2.,0,7.4,-1.6,-.133,-.646,0,-.2,-.1,0,0,0,0, - * 2.,0,5.8,-1.3,.133,-.631,0,-.2,-.1,0,0,0,0, + * 2.,0,5.8,-1.3,.133,-.631,0,-.2,-.1,0,0,0,0, * 2.,0,3.4,-.6,.3,-.32,-.644,0,-.2,-.1,0,0,0, * 1.2,2.,1.2,-.4,.8,-.3,-.58,-.25,-.167,-.1,0,0,0, - * 1.2,2.,.8,0,.486,-.673,-.2,-.1,-.066,0,0,0,0, - * 1.2,2.,-.6,.525,.3,-.56,-.3,-.1,0,0,0,0,0, + * 1.2,2.,.8,0,.486,-.673,-.2,-.1,-.066,0,0,0,0, + * 1.2,2.,-.6,.525,.3,-.56,-.3,-.1,0,0,0,0,0, * .8,2.2,1.2,-1.4,1.35,-.4,.8,0,-.5,-.2,-.167,0,0/ - data j1mw140/12,11,11,11,11,10,12/ + data j1mw140/12,11,11,11,11,10,12/ data j2mw140/10,11,11,11,11,10,12/ data h1w140/75,80,85,95,100,110,125,145,190,200,220,250,0, * 75,80,85,95,100,110,120,150,190,220,250,0,0, @@ -3205,25 +3276,25 @@ C * 75,80,90,100,120,130,140,160,190,200,250,270,0/ data h2w140/75,90,95,100,110,125,190,200,220,250,0,0,0, * 75,90,95,100,110,120,125,190,200,220,250,0,0, - * 75,90,95,100,110,120,145,190,200,220,250,0,0, + * 75,90,95,100,110,120,145,190,200,220,250,0,0, * 75,80,95,100,110,120,150,190,200,220,250,0,0, * 75,80,90,95,110,145,190,200,220,250,270,0,0, * 75,80,90,100,140,150,200,220,250,270,0,0,0, - * 75,80,85,90,100,120,130,140,160,180,200,220,0/ + * 75,80,85,90,100,120,130,140,160,180,200,220,0/ data R1mw140/28,35,65,65,28,44,46,50,9,6,2,0,0, * 28,35,65,65,36,49,47,47,8,2,0,0,0, * 28,35,65,65,48,54,51,43,8,2,0,0,0, - * 16,24,66,54,58,50,50,42,8,2,0,0,0, + * 16,24,66,54,58,50,50,42,8,2,0,0,0, * 16,24,66,66,46,49,9,10,7,2,0,0,0, * 16,24,66,76,49,54,10,14,4,1,0,0,0, - * 6,19,67,91,64,68,60,58,11,20,5,2,0/ + * 6,19,67,91,64,68,60,58,11,20,5,2,0/ data R2mw140/5,35,35,72,56,54,5,5,1,0,0,0,0, * 5,35,35,64,51,53,53,5,5,1,0,0,0, - * 5,35,35,52,46,49,41,5,5,1,0,0,0, - * 4,10,40,46,42,50,41,5,5,1,0,0,0, - * 4,10,30,34,34,51,10,5,3,1,0,0,0, + * 5,35,35,52,46,49,41,5,5,1,0,0,0, + * 4,10,40,46,42,50,41,5,5,1,0,0,0, + * 4,10,30,34,34,51,10,5,3,1,0,0,0, * 4,10,30,24,45,48,4,2,1,0,0,0,0, - * 2,6,17,23,9,36,32,40,39,29,1,0,0/ + * 2,6,17,23,9,36,32,40,39,29,1,0,0/ data rk1mw140/1.4,6.,0,-7.4,1.6,.133,.2,-.911,-.3,-.2,-.066,0,0, * 1.4,6.,0,-5.8,1.3,-.2,0,-.975,-.2,-.066,0,0,0, * 1.4,6.,0,-3.4,.6,-.3,-.229,-1.,-.2,-.066,0,0,0, @@ -3246,14 +3317,14 @@ C if(z.gt.90)z=90 if((it.eq.1).or.(it.eq.2).or.(it.eq.11).or.(it.eq.12))then if(f.lt.140)then - Call aprok(j1mw70,j2mw70,h1w70,h2w70,R1mw70,R2mw70, - * rk1mw70,rk2mw70,h,z,R1,R2) + Call aprok(j1mw70,j2mw70,h1w70,h2w70,R1mw70,R2mw70, + * rk1mw70,rk2mw70,h,z,R1,R2) R170=R1 R270=R2 endif if(f.gt.70)then - Call aprok(j1mw140,j2mw140,h1w140,h2w140,R1mw140,R2mw140, - * rk1mw140,rk2mw140,h,z,R1,R2) + Call aprok(j1mw140,j2mw140,h1w140,h2w140,R1mw140,R2mw140, + * rk1mw140,rk2mw140,h,z,R1,R2) R1140=R1 R2140=R2 endif @@ -3264,14 +3335,14 @@ C endif if((it.eq.5).or.(it.eq.6).or.(it.eq.7).or.(it.eq.8))then if(f.lt.140)then - Call aprok(j1ms70,j2ms70,h1s70,h2s70,R1ms70,R2ms70, - * rk1ms70,rk2ms70,h,z,R1,R2) + Call aprok(j1ms70,j2ms70,h1s70,h2s70,R1ms70,R2ms70, + * rk1ms70,rk2ms70,h,z,R1,R2) R170=R1 R270=R2 endif if(f.gt.70)then - Call aprok(j1ms140,j2ms140,h1s140,h2s140,R1ms140,R2ms140, - * rk1ms140,rk2ms140,h,z,R1,R2) + Call aprok(j1ms140,j2ms140,h1s140,h2s140,R1ms140,R2ms140, + * rk1ms140,rk2ms140,h,z,R1,R2) R1140=R1 R2140=R2 endif @@ -3282,14 +3353,14 @@ C endif if((it.eq.3).or.(it.eq.4).or.(it.eq.9).or.(it.eq.10))then if(f.lt.140)then - Call aprok(j1mr70,j2mr70,h1r70,h2r70,R1mr70,R2mr70, - * rk1mr70,rk2mr70,h,z,R1,R2) + Call aprok(j1mr70,j2mr70,h1r70,h2r70,R1mr70,R2mr70, + * rk1mr70,rk2mr70,h,z,R1,R2) R170=R1 R270=R2 endif if(f.gt.70)then Call aprok(j1mr140,j2mr140,h1r140,h2r140,R1mr140,R2mr140, - * rk1mr140,rk2mr140,h,z,R1,R2) + * rk1mr140,rk2mr140,h,z,R1,R2) R1140=R1 R2140=R2 endif @@ -3313,11 +3384,11 @@ C c c Subroutine aprok(j1m,j2m,h1,h2,R1m,R2m,rk1m,rk2m,hei,xhi,R1,R2) -c----------------------------------------------------------------- +c----------------------------------------------------------------- dimension zm(7),j1m(7),j2m(7),h1(13,7),h2(13,7),R1m(13,7), * R2m(13,7),rk1m(13,7),rk2m(13,7) data zm/20,40,60,70,80,85,90/ - + h=hei z=xhi @@ -3361,7 +3432,7 @@ c----------------------------------------------------------------- goto 11 endif if(j2.eq.0)then - rk=(z-zm(i1))/(zm(i1+1)-zm(i1)) + rk=(z-zm(i1))/(zm(i1+1)-zm(i1)) R1=R1+(R11-R1)*rk R2=R2+(R12-R2)*rk endif @@ -3370,7 +3441,7 @@ C C SUBROUTINE CALION(INVDIP,MLT,ALT,DDD,PF107,NO,NH,NHE,NN) C---------------------------------------------------------------------- -C Version 2.5 (released 6.4.2016) (Includes a correction for PF107<87.5 +C Version 2.5 (released 6.4.2016) (Includes a correction for PF107<87.5 C based on C/NOFS CINDI data) C CALION calculates ion density of O+, H+, He+ and N+ in the outer C ionosphere with regard to solar activity (F107 index). @@ -3390,15 +3461,15 @@ C Versions: 2.5 FORTRAN C C REFERENCES: C Triskova, L., Truhlik, V., Smilauer, J. An empirical model of ion -C composition in the outer ionosphere. Adv. Space Res. 31 (3), +C composition in the outer ionosphere. Adv. Space Res. 31 (3), C 653–663, 2003. C Truhlik, V., Triskova, L., Smilauer, J. New advances in empirical C modeling of ion composition in the outer ionosphere. Adv. Space C Res. 33, 844–849, 2004. -C Truhlik V., D. Bilitza, L. Triskova, Towards better description of -C solar activity variation in the International Reference Ionosphere -C topside ion composition model, Advances in Space Research, -C Volume 55, Issue 8, 15 April 2015, Pages 2099-2105, ISSN 0273-1177, +C Truhlik V., D. Bilitza, L. Triskova, Towards better description of +C solar activity variation in the International Reference Ionosphere +C topside ion composition model, Advances in Space Research, +C Volume 55, Issue 8, 15 April 2015, Pages 2099-2105, ISSN 0273-1177, C http://dx.doi.org/10.1016/j.asr.2014.07.033. C C Author of the code: @@ -3854,7 +3925,7 @@ C 2250km June solstice & -2.0076E-003, 9.1568E-003,-2.7745E-003, & 9.3070E-004,-1.1010E-003,-2.9865E-004, & -1.0161E-003, 1.0107E-003, 7.9248E-004, - & 4.3800E-003/ + & 4.3800E-003/ C////////////////////////////////////////////////////////////////////// C///////////////////////////////////N+///////////////////////////////// C 550km equinox @@ -4002,7 +4073,7 @@ C 2250km June solstice & -2.3492E-002,-7.9399E-004, 3.7814E-003, & -1.6833E-002/ C////////////////////////////////////////////////////////////////////// -C/////////////////coefficients low solar activity///////////////////// +C/////////////////coefficients low solar activity///////////////////// C//////////////////////////////////O+////////////////////////////////// C 400km equinox DATA (DOL(1,1,J),J=1,49)/ 1.1028E+001,-5.9947E-007,-3.3742E-001, @@ -4627,7 +4698,7 @@ C C/NOFS correction IL=IFIX((PF107-57.5)/10.0) NOCORR=(CORRO(IL+1)-CORRO(IL))/10.0*(PF107-57.5-10*IL)+CORRO(IL) NHCORR=(CORRH(IL+1)-CORRH(IL))/10.0*(PF107-57.5-10*IL)+CORRH(IL) - ENDIF + ENDIF IF (PF107 .GE. 87.5) GOTO 10 NO=NO/NOCORR NH=NH/NHCORR @@ -4639,7 +4710,7 @@ C normalization NH=NH/NTOT NHE=NHE/NTOT NN=NN/NTOT -10 CONTINUE +10 CONTINUE RETURN END C @@ -4650,7 +4721,7 @@ C IONLOW calculates absolute density of O+, H+, He+ or N+ in the outer C ionosphere for a low solar activity (F107 < 100). C Based on spherical harmonics approximation of relative ion density C (by AE-C, and AE-E) at altitudes centred on 400km, 550km, 750km, and 1000km. -C For intermediate altitudes an interpolation is used. +C For intermediate altitudes an interpolation is used. C Recommended altitude range: 350-2500 km!!! C For days between seasons centred at (21.3. = 79; 21.6. = 171; C 23.9. 265; 21.12. = 354) relative ion density is linearly interpolated. @@ -4664,7 +4735,7 @@ C in km, range <350;2000> C DDD - day of year; range <0;365> C D - coefficints of spherical harmonics for a given ion C ION - ion species (0...O+, 1...H+, 2...He+, 3...N+) -C Output: NION - absolute density for given ion +C Output: NION - absolute density for given ion C--------------------------------------------------------------------------- REAL INVDIP,MLT,ALT,NION INTEGER DDD,ION @@ -4778,12 +4849,12 @@ C n(O+) AND n(N+) must not increase above 750km IF (((ION .EQ. 0) .OR. (ION .EQ. 3)) .AND. (N1000 .GT. N750)) & N1000=N750 C n(H+) and n(He+) must not decrease above 750km - IF (((ION .EQ. 1) .OR. (ION .EQ. 2)) .AND. (N1000 .LT. N750)) + IF (((ION .EQ. 1) .OR. (ION .EQ. 2)) .AND. (N1000 .LT. N750)) & N1000=N750 - IF (ALT .GE. 960) SUM=(N1000-N750)/220.0*(ALT-740.0)+N750 + IF (ALT .GE. 960) SUM=(N1000-N750)/220.0*(ALT-740.0)+N750 IF (ALT .GE. 960) GOTO 240 - + ANO(1)=N400 ANO(2)=N550 ANO(3)=N750 @@ -4812,16 +4883,16 @@ C exact values 220 ST(I)=(ANO(I+1)-ANO(I))/(AH(I+1)-AH(I)) c ARGMAX=88.0 - SUM=ANO(1)+ST(1)*(ALT-AH(1)) - + SUM=ANO(1)+ST(1)*(ALT-AH(1)) + DO 230 I=1,2 aa = eptr(alt ,dno(i),ah(i+1)) bb = eptr(ah(1),dno(i),ah(i+1)) 230 SUM=SUM+(ST(I+1)-ST(I))*(AA-BB)*DNO(I) - -240 NION=10**SUM + +240 NION=10**SUM RETURN - END + END C C SUBROUTINE IONHIGH(INVDIP,MLT,ALT,DDD,D,ION,NION) @@ -4830,7 +4901,7 @@ C IONHIGH calculates absolute density of O+, H+, He+ or N+ in the outer C ionosphere for high solar activity conditions (PF10.7 = 210). C Based on spherical harmonics approximation of relative ion density C (by IK24) at altitudes centred on 550km, 900km, 1500km, and 2250km. -C For intermediate altitudes a interpolation is used. +C For intermediate altitudes a interpolation is used. C Recommended altitude range: 500-2500 km!!! C For days between seasons centred at (21.3. = 79; 21.6. = 171; C 23.9. 265; 21.12. = 354) relative ion density is linearly interpolated. @@ -4844,7 +4915,7 @@ C in km, range <500;3000> C DDD - day of year; range <0;365> C D - coefficints of spherical harmonics for a given ion C ION - ion species (0...O+, 1...H+, 2...He+, 3...N+) -C Output: NION - absolute density for given ion +C Output: NION - absolute density for given ion C--------------------------------------------------------------------------- REAL INVDIP,MLT,ALT,NION INTEGER DDD,ION @@ -4871,7 +4942,7 @@ C coefficients for mirroring D(3,3,I)=D(3,2,I)*MIRREQ(I) 10 D(4,3,I)=D(4,2,I)*MIRREQ(I) INVDP=INVDIP - + RMLT=MLT*DTOR*15.0 RCOLAT=(90.0-INVDP)*DTOR CALL SPHARM_IK(C1,6,6,RCOLAT,RMLT) @@ -4954,16 +5025,16 @@ C 2500km level N250B=N0B250 N2500=(N250B-N250A)/(DDDB-DDDA)*(DDDD-DDDA)+N250A -C O+ and N+ may not increase above 1500km - IF (((ION .EQ. 0) .OR. (ION .EQ. 3)) .AND. (N2500 .GT. N1500)) +C O+ and N+ may not increase above 1500km + IF (((ION .EQ. 0) .OR. (ION .EQ. 3)) .AND. (N2500 .GT. N1500)) & N2500=N1500 -C H+ and He+ may not decrease above 1500km - IF (((ION .EQ. 1) .OR. (ION .EQ. 2)) .AND. (N2500 .LT. N1500)) +C H+ and He+ may not decrease above 1500km + IF (((ION .EQ. 1) .OR. (ION .EQ. 2)) .AND. (N2500 .LT. N1500)) & N2500=N1500 - + IF (ALT .GE. 2250.0) SUM=(N2500-N1500)/750.0*(ALT-2250.0)+N2500 IF (ALT .GE. 2250.0) GOTO 240 - + ANO(1)=N550 ANO(2)=N900 ANO(3)=N1500 @@ -4986,29 +5057,29 @@ C H+ and He+ may not decrease above 1500km 220 ST(I)=(ANO(I+1)-ANO(I))/(AH(I+1)-AH(I)) c ARGMAX=88.0 - SUM=ANO(1)+ST(1)*(ALT-AH(1)) - + SUM=ANO(1)+ST(1)*(ALT-AH(1)) + DO 230 I=1,2 aa = eptr(alt ,dno(i),ah(i+1)) bb = eptr(ah(1),dno(i),ah(i+1)) 230 SUM=SUM+(ST(I+1)-ST(I))*(AA-BB)*DNO(I) - -240 NION=10**SUM + +240 NION=10**SUM RETURN END C C REAL FUNCTION INVDPC(FL,DIMO,B0,DIPL) C--------------------------------------------------------------------------- -C INPUT: FL McIlwain L parameter, +C INPUT: FL McIlwain L parameter, C DIMO dipole moment in Gauss -C B0 magnetic field strength in Gauss +C B0 magnetic field strength in Gauss C parameters FL, DIMO and B0 are needed for invariant latitude C computation; uses a highly accurate polynomial expansion C DIPL dip latitude in degree C positive northward, in deg, range <-90.0;90.0> -C RESULT: invdip a "mix" coordinate of the dip latitude (DIPL) and -C of the invariant latitude; INVDIP is positive northward +C RESULT: invdip a "mix" coordinate of the dip latitude (DIPL) and +C of the invariant latitude; INVDIP is positive northward C in degree and ranges from -90.0 to 90.0. C--------------------------------------------------------------------------- REAL FL,DIMO,B0,DIPL,DTOR,ASA,INVL,RINVL,RDIPL,ALFA,BETA @@ -5033,7 +5104,7 @@ c INVDPC=(ALFA*INVL+BETA*DIPL)/(ALFA+BETA) RETURN END C -C +C REAL FUNCTION INVDPC_OLD(FL,DIMO,B0,DIPL) C--------------------------------------------------------------------------- C calculation of INVDIP from FL, DIMO, BO, and DIPL @@ -5062,17 +5133,17 @@ c invariant latitude (absolute value) END C -C -C************************************************************* -C************* PEAK VALUES ELECTRON DENSITY ****************** -C************************************************************* +C +C************************************************************* +C************* PEAK VALUES ELECTRON DENSITY ****************** +C************************************************************* C C real function FOUT(XMODIP,XLATI,XLONGI,UT,FF0) c-------------------------------------------------------------- -C CALCULATES CRITICAL FREQUENCY FOF2/MHZ USING SUBROUTINE GAMMA1. +C CALCULATES CRITICAL FREQUENCY FOF2/MHZ USING SUBROUTINE GAMMA1. C XMODIP = MODIFIED DIP LATITUDE, XLATI = GEOG. LATITUDE, XLONGI= -C LONGITUDE (ALL IN DEG.), MONTH = MONTH, UT = UNIVERSAL TIME +C LONGITUDE (ALL IN DEG.), MONTH = MONTH, UT = UNIVERSAL TIME C (DEC. HOURS), FF0 = ARRAY WITH RZ12-ADJUSTED CCIR/URSI COEFF. C D.BILITZA,JULY 85. c-------------------------------------------------------------- @@ -5088,7 +5159,7 @@ C c-------------------------------------------------------------- C CALCULATES PROPAGATION FACTOR M3000 USING THE SUBROUTINE GAMMA1. C XMODIP = MODIFIED DIP LATITUDE, XLATI = GEOG. LATITUDE, XLONGI= -C LONGITUDE (ALL IN DEG.), MONTH = MONTH, UT = UNIVERSAL TIME +C LONGITUDE (ALL IN DEG.), MONTH = MONTH, UT = UNIVERSAL TIME C (DEC. HOURS), XM0 = ARRAY WITH RZ12-ADJUSTED CCIR/URSI COEFF. C D.BILITZA,JULY 85. c-------------------------------------------------------------- @@ -5100,62 +5171,62 @@ c-------------------------------------------------------------- END C C - REAL FUNCTION HMF2ED(XMAGBR,R,X,XM3) + REAL FUNCTION HMF2ED(XMAGBR,R,X,XM3) c-------------------------------------------------------------- -C CALCULATES THE PEAK HEIGHT HMF2/KM FOR THE MAGNETIC -C LATITUDE XMAGBR/DEGREE AND THE SMOOTHED ZUERICH SUNSPOT +C CALCULATES THE PEAK HEIGHT HMF2/KM FOR THE MAGNETIC +C LATITUDE XMAGBR/DEGREE AND THE SMOOTHED ZUERICH SUNSPOT C NUMBER R USING CCIR-M3000 XM3 AND THE RATIO X=FOF2/FOE. C FOLLOWING CCIR RECOMMENDATION X IS LIMITED TO VALUE -C GREATER OR EQUAL TO 1.7 . -C [REF. D.BILITZA ET AL., TELECOMM.J., 46, 549-553, 1979] -C D.BILITZA,1980. +C GREATER OR EQUAL TO 1.7 . +C [REF. D.BILITZA ET AL., TELECOMM.J., 46, 549-553, 1979] +C D.BILITZA,1980. c-------------------------------------------------------------- - F1=0.00232*R+0.222 - F2=1.2-0.0116*EXP(0.0239*R) - F3=0.096*(R-25.0)/150.0 + F1=0.00232*R+0.222 + F2=1.2-0.0116*EXP(0.0239*R) + F3=0.096*(R-25.0)/150.0 F4=1.0-R/150.0*EXP(-XMAGBR*XMAGBR/1600.0) if(x.lt.1.7) x=1.7 - DELM=F1*F4/(X-F2)+F3 - HMF2ED=1490.0/(XM3+DELM)-176.0 - RETURN - END + DELM=F1*F4/(X-F2)+F3 + HMF2ED=1490.0/(XM3+DELM)-176.0 + RETURN + END C C - REAL FUNCTION XM3000HM(XMAGBR,R,X,HMF2) + REAL FUNCTION XM3000HM(XMAGBR,R,X,HMF2) c-------------------------------------------------------------- C CALCULATES THE PROPAGATION FACTOR M3000 FOR THE MAGNETIC LATITUDE -C XMAGBR/DEG. AND THE SMOOTHED ZUERICH SUNSPOT NUMBER R USING THE -C PEAK HEIGHT HMF2/KM AND THE RATIO X=FOF2/FOE. Reverse of HMF2ED. -C [REF. D.BILITZA ET AL., TELECOMM.J., 46, 549-553, 1979] -C D.BILITZA,1980. ----- no longer used +C XMAGBR/DEG. AND THE SMOOTHED ZUERICH SUNSPOT NUMBER R USING THE +C PEAK HEIGHT HMF2/KM AND THE RATIO X=FOF2/FOE. Reverse of HMF2ED. +C [REF. D.BILITZA ET AL., TELECOMM.J., 46, 549-553, 1979] +C D.BILITZA,1980. ----- no longer used c-------------------------------------------------------------- - F1=0.00232*R+0.222 - F2=1.2-0.0116*EXP(0.0239*R) - F3=0.096*(R-25.0)/150.0 + F1=0.00232*R+0.222 + F2=1.2-0.0116*EXP(0.0239*R) + F3=0.096*(R-25.0)/150.0 F4=1.0-R/150.0*EXP(-XMAGBR*XMAGBR/1600.0) if(x.lt.1.7) x=1.7 - DELM=F1*F4/(X-F2)+F3 + DELM=F1*F4/(X-F2)+F3 XM3000HM=1490.0/(HMF2+176.0)-DELM - RETURN - END + RETURN + END C C SUBROUTINE SHAMDHMF2 (RLAT,FLON,T,RZ,HMF2) C------------------------------------------------------------------- C COMPUTES THE HOURLY VALUES OF hmF2 FROM A SET OF SH COEFFICIENTS -C IN A POINT OF A GIVEN GEOCENTRIC LATITUDE AND LONGITUDE OF THE +C IN A POINT OF A GIVEN GEOCENTRIC LATITUDE AND LONGITUDE OF THE C EARTH'S SURFACE FOR A GIVEN MONTH AND A GIVEN SUNSPOT NUMBER. C PARAMETERS AND COEFFICIENTS ARE GIVEN IN DATA STATEMENTS. C -C INPUT: RLAT The geographic latitude on the FLON meridian -C where the modified dip latitude is equal to the +C INPUT: RLAT The geographic latitude on the FLON meridian +C where the modified dip latitude is equal to the C modip value for the considered point in space. C FLON =LONGITUDE+15.*UT(hours) C T Month as a REAL number (1.0 to 12.0) C RZ 12-month running mean C OUTPUT: HMF2 F2 peak altitude in km C -C Altadill, D., S. Magdaleno, J.M. Torta, and E. Blanch +C Altadill, D., S. Magdaleno, J.M. Torta, and E. Blanch C Adv. Space Res. 52, 1756-1769, 2013. C------------------------------------------------------------------- PARAMETER (IBO=0,JBO=1,KDIM=8,LDIM=4,L=-1) @@ -5168,7 +5239,7 @@ C------------------------------------------------------------------- * HBNM(0:KDIM,0:KDIM,1-IBO-JBO:LDIM) DIMENSION BINT(0:KDIM,0:KDIM,1-IBO-JBO:LDIM), * BEXT(0:KDIM,0:KDIM,1-IBO-JBO:LDIM) - CHARACTER*1 IE + CHARACTER*1 IE COMMON/AMTB/BINT,BEXT,RE,TZERO,IFIT,IB,KINT,LINT,KEXT, * LEXT,KMAX,FN c ,CONST @@ -5296,7 +5367,7 @@ c ,CONST * -51.003, 0.485, 36.183, 0.144, * 65.647,-0.752, -42.617,-0.228, 33.590,-0.298, -27.554,-0.093, * -15.194, 0.193, 20.247, 0.033, 14.304,-0.227, -6.789,-0.088, - * 80*0.000/ + * 80*0.000/ KMAX = MAX(KINT,KEXT) IF (KMAX .GT. KDIM) GO TO 9999 @@ -5310,7 +5381,7 @@ c ,CONST GNM(N,M,J)=GANM(N,M,J)+GBNM(N,M,J)*rz HNM(N,M,J)=HANM(N,M,J)+HBNM(N,M,J)*rz ENDDO - + IF (IE .EQ. 'I') THEN IF (N .GT. KINT) GO TO 500 LJ = LINT @@ -5343,7 +5414,7 @@ c ,CONST C 500 CONTINUE C ********************************************************** -C SYNTHESIZES THE VALUE OF HMF2 FROM THE MODEL +C SYNTHESIZES THE VALUE OF HMF2 FROM THE MODEL C ********************************************************** CALL SCHNEVPDH (RZ,RLAT,FLON,dum,T,L,dum,dum,HMF2) RETURN @@ -5379,11 +5450,11 @@ C SUBROUTINE USED: LEGFUN C C PARAMS & COEFFS TRANSFERRED FROM MAIN PROGRAM IN COMMON/AMTB/ C -C ADAPTED FROM SUBROUTINE SCHNEV OF G.V. HAINES (COMPUTERS & GEOSCIENCES, +C ADAPTED FROM SUBROUTINE SCHNEV OF G.V. HAINES (COMPUTERS & GEOSCIENCES, C 14, 413-447, 1988) C------------------------------------------------------------------------ - PARAMETER (IBO=0,JBO=1,KDIM=8,LDIM=4) + PARAMETER (IBO=0,JBO=1,KDIM=8,LDIM=4) DIMENSION FN(0:KDIM,0:KDIM), CONSTP(0:KDIM,0:KDIM) DIMENSION CML(KDIM), SML(KDIM) DIMENSION DELT(0:LDIM) @@ -5408,10 +5479,10 @@ C 2 FOURIER SERIES C 3 COSINE SERIES C 4 SINE SERIES C NOTE: TZERO AND THINT MAY DEPEND ON IBF. - IBF = 2 + IBF = 2 T1=1. T2=12. - CALL TBFIT (T1,T2,IBF,THINT,TZERO) + CALL TBFIT (T1,T2,IBF,THINT,TZERO) C IF (L .NE. 0) GO TO 100 C BN = FLATO @@ -5626,7 +5697,7 @@ c c Requires the following subroutines and functions: c SDMF2, hmF2_med_SD, read_data_SD, fun_hmF2_SD, c fun_Gk, Legendre, fun_hmF2UT, Koeff_UT, fun_Akp_UT, -c fun_Fk_UT, fun_Gk_UT +c fun_Fk_UT, fun_Gk_UT c c Author of the code: c Valentin Shubin @@ -5634,7 +5705,7 @@ c Pushkov Institute of Terrestrial Magnetism, c Ionosphere and Radio wave propagation (IZMIRAN) c Moscow, Troitsk, 142190, Russia c e-mail: shubin@izmiran.ru -c +c c [Ref. V.N. Shubin. Global median model of the F2-layer c peak height based on ionospheric radio-occultation and c ground-based Digisonde observations. Advances in Space Research (2015) @@ -5645,7 +5716,7 @@ c UT - universal time (real) c monthut - month (integer) c xmodip - modified dip latitude in degrees (real) c long - geodatic longitude in degrees (real) -c F107A - F10.7 index averaged over the 3 Sun rotations +c F107A - F10.7 index averaged over the 3 Sun rotations c in units of 10^-22 W/(m^2 Hz) (real) c c Output: @@ -5673,9 +5744,9 @@ c hmF2_UT(i) = hmF2_med_SD(i,monthut,F107A,xmodip,long) xUT(i) = dble(i) end do -c +c T = dble(UT) - hmF2 = fun_hmF2UT(T) + hmF2 = fun_hmF2UT(T) c return end @@ -5683,10 +5754,10 @@ c c real function hmF2_med_SD(iUT,monthut,F107A,xmodip,long) c--------------------------------------------------------------------- -c Input: +c Input: c iUT - universal time (real) c monthut - month (integer) -c F107A - F10.7 index averaged over the 3 Sun rotations +c F107A - F10.7 index averaged over the 3 Sun rotations c in units of 10^-22 W/(m^2 Hz) (real) c xmodip - modified dip latitude in degrees (real) c long - geodatic longitude in degrees (real) @@ -5712,7 +5783,7 @@ c .. local arrays .. c c Arrays ft1 (12) and ft2 (12) are the median values of F10.7A, c which were used as the margins for -c the low and high solar activity levels +c the low and high solar activity levels c c Jan Feb Mar Apr May Jun data ft1/ 73.6, 72.3, 71.8, 70.9, 73.6,73.0, @@ -5739,9 +5810,9 @@ c hmF2_2 = fun_hmF2_SD(teta,long,Kf) c cov = F107A - cov1 = ft1(monthut) + cov1 = ft1(monthut) cov2 = ft2(monthut) -c +c a = (hmF2_2 - hmF2_1)/log(cov2/cov1) b = hmF2_2 - a*log(cov2) hmF2_med_SD = a*log(cov) + b @@ -5774,7 +5845,7 @@ c .. local arrays .. c if (coeff_month_read(month) .eq. 0) then write(filedata, 10) month+10 - open(10, File=trim(datadir)//'/mcsat/'//filedata, + open(10, File=trim(datadir)//'/mcsat/'//filedata, & status='old') do j=0,47 read(10,20) (coeff_month_all(i,j,month),i=0,148) @@ -5783,31 +5854,31 @@ c coeff_month_read(month) = 1 end if c - coeff_month = coeff_month_all(0:148,0:47,month) + coeff_month = coeff_month_all(0:148,0:47,month) c c Previous operator can be replaced by c c do i=0,148 -c do j=0,47 +c do j=0,47 c coeff_month(i,j) = coeff_month_all(i,j,month) c end do -c end do +c end do c - return - + return + 10 format('mcsat',i2,'.dat') c-web- special for web version c10 FORMAT('/var/www/omniweb/cgi/vitmo/IRI/mcsat',I2,'.dat') -20 format(6(d12.5)) + 20 format(6(d12.5)) end c -c +c real function fun_hmF2_SD(teta,long,Kf) c--------------------------------------------------------------------- -c Input: +c Input: c teta - (90-modip) in degrees c long - geodatic longitude in degrees -c Kf - coefficients of hmF2 spatial decomposition +c Kf - coefficients of hmF2 spatial decomposition c c function to calculate spherical harmonics decomposition c for the spatial dependencies of hmF2 @@ -5831,7 +5902,7 @@ c call fun_Gk(teta,long,Gk) hmF2 = 0.d0 do k=0,148 - hmF2 = hmF2 + Kf(k)*Gk(k) + hmF2 = hmF2 + Kf(k)*Gk(k) end do fun_hmF2_SD = hmF2 c @@ -5871,7 +5942,7 @@ c Gk(k) = Pl_mn(m,n) k = k + 1 end do - else + else do n=m,nn Gk(k) = Pl_mn(m,n)*cos(m*long*umr) Gk(k+1) = Pl_mn(m,n)*sin(m*long*umr) @@ -5888,10 +5959,10 @@ c c--------------------------------------------------------------------- c Input: c mm - harmonics for longitude -c nn - harmonics for the modified dip latitude (modip) +c nn - harmonics for the modified dip latitude (modip) c teta - (90-modip) in degrees c Output: -c P(mm,nn) - associated Legendre function +c P(mm,nn) - associated Legendre function c c subroutine to calculate associated Legendre function P(mm,nn) c with Schmidt normalization @@ -5957,8 +6028,8 @@ c c real function fun_hmF2UT(T) c--------------------------------------------------------------------- -c Input: T - universal time -c +c Input: T - universal time +c c function to calculate Fourier decomposition c for the temporal variations of hmF2 c used the following auxiliary subroutines: @@ -5971,9 +6042,9 @@ c .. local scalars .. integer k, mm, mk c real dtr, dumr double precision hmF2 -c .. local arrays .. +c .. local arrays .. double precision Gk_UT(0:6), Kf_UT(0:6) -c .. local in common .. +c .. local in common .. double precision dtr common/radUT/dtr c common/const1/dtr,dumr @@ -5988,7 +6059,7 @@ c call fun_Gk_UT(mm,mk,t,Gk_UT) hmF2 = 0.d0 do k=0,mk - hmF2 = hmF2 + Kf_UT(k)*Gk_UT(k) + hmF2 = hmF2 + Kf_UT(k)*Gk_UT(k) end do fun_hmF2UT = hmF2 c @@ -6010,7 +6081,7 @@ c .. local arrays .. double precision Akp_UT(0:mk,0:mk) double precision Dk_UT(0:mk) c .. subroutine references .. -c fun_Akp_UT +c fun_Akp_UT c call fun_Akp_UT(mm,mk,Akp_UT,Dk_UT) Kf_UT = 0.d0 @@ -6020,7 +6091,7 @@ c sum_D = sum_D + Akp_UT(m,k)*Kf_UT(m) end do Kf_UT(k) = sum_D + Dk_UT(k) - end do + end do return end @@ -6040,7 +6111,7 @@ c .. local scalars .. double precision sum_Ad, sum_Dd c .. local arrays .. double precision Gk_UT(0:mk), Fk_UT(0:mk) -c .. array in common .. +c .. array in common .. double precision hmF2_UT(0:23) common/hmF2UT/hmF2_UT c .. subroutine references .. @@ -6141,7 +6212,7 @@ c if (m.eq.0) then Gk_UT(k) = 1 k = k + 1 - else + else Gk_UT(k) = cos(m*t*dtr) Gk_UT(k+1) = sin(m*t*dtr) k = k + 2 @@ -6155,22 +6226,22 @@ C REAL FUNCTION FOF1ED(YLATI,R,CHI) c-------------------------------------------------------------- C CALCULATES THE F1 PEAK PLASMA FREQUENCY (FOF1/MHZ) -C INPUT: +C INPUT: C YLATI ABSOLUT VALUE OF DIP-LATITUDE IN DEGREE -c R 12-MONTH RUNNING MEAN OF SUNSPOT NUMBER +c R 12-MONTH RUNNING MEAN OF SUNSPOT NUMBER c CHI SOLAR ZENITH ANGLE IN DEGREE -C REFERENCE: +C REFERENCE: c E.D.DUCHARME ET AL., RADIO SCIENCE 6, 369-378, 1971 C AND 8, 837-839, 1973 c HOWEVER WITH MAGNETIC DIP LATITUDE INSTEAD OF GEOMAGNETIC -c DIPOLE LATITUDE, EYFRIG, 1979 -C--------------------------------------------- D. BILITZA, 1988. +c DIPOLE LATITUDE, EYFRIG, 1979 +C--------------------------------------------- D. BILITZA, 1988. COMMON/CONST/UMR,PI fof1ed=0.0 if (chi.gt.90.0) return DLA = YLATI - F0 = 4.35 + DLA * ( 0.0058 - 1.2E-4 * DLA ) + F0 = 4.35 + DLA * ( 0.0058 - 1.2E-4 * DLA ) F100 = 5.348 + DLA * ( 0.011 - 2.3E-4 * DLA ) FS = F0 + ( F100 - F0 ) * R / 100.0 XMUE = 0.093 + DLA * ( 0.0046 - 5.4E-5 * DLA ) + 3.0E-4 * R @@ -6178,10 +6249,10 @@ C--------------------------------------------- D. BILITZA, 1988. CHI0 = 49.84733 + 0.349504 * DLA CHI100 = 38.96113 + 0.509932 * DLA CHIM = ( CHI0 + ( CHI100 - CHI0 ) * R / 100. ) - IF(CHI.GT.CHIM) FOF1=-FOF1 - FOF1ED = FOF1 + IF(CHI.GT.CHIM) FOF1=-FOF1 + FOF1ED = FOF1 RETURN - END + END C C real function f1_c1(xmodip,hour,saxnon,suxnon) @@ -6190,7 +6261,7 @@ c Space Research, Volume 25, Number 1, 81-88, 2000. common /const/umr,pi pi = umr * 180. - + ABSMDP=ABS(XMODIP) DELA=4.32 IF(ABSMDP.GE.18.) DELA=1.0+EXP(-(ABSMDP-30.0)/10.0) @@ -6212,10 +6283,10 @@ c-------------------------------------------------------------------------- c Occurrence probability of F1 layer after Scotto et al., Advances in c Space Research, Volume 20, Number 9, 1773-1775, 1997. c -c Input: sza solar zenith angle in degrees +c Input: sza solar zenith angle in degrees c glat geomagnetic latitude in degrees C rz12 12-month running mean of sunspot number -c Output: f1prob F1 occurrence probability without L-condition cases +c Output: f1prob F1 occurrence probability without L-condition cases c f1probl F1 occurrence probability with L-condition cases c-------------------------------------------------------------------------- c @@ -6238,57 +6309,57 @@ C C REAL FUNCTION FOEEDI(COV,XHI,XHIM,XLATI) C------------------------------------------------------- -C CALCULATES FOE/MHZ BY THE EDINBURGH-METHOD. -C INPUT: -C COV MONTHLY MEAN 10.7CM SOLAR RADIO FLUX measured at -C ground level -C XHI SOLAR ZENITH ANGLE IN DEGREE +C CALCULATES FOE/MHZ BY THE EDINBURGH-METHOD. +C INPUT: +C COV MONTHLY MEAN 10.7CM SOLAR RADIO FLUX measured at +C ground level +C XHI SOLAR ZENITH ANGLE IN DEGREE C XHIM SOLAR ZENITH ANGLE AT NOON IN DEGREE -C XLATI ABSOLUTE VALUE OF GEOGRAPHIC LATITUDE IN DEGREE, -C REFERENCE: +C XLATI ABSOLUTE VALUE OF GEOGRAPHIC LATITUDE IN DEGREE, +C REFERENCE: C KOURIS-MUGGELETON, CCIR DOC. 6/3/07, 1973 C TROST, J. GEOPHYS. RES. 84, 2736, 1979 (was used C to improve the nighttime varition) C RAWER AND BILITZA, Adv. Space Res. 10(8), 5-14, 1990 -C D.BILITZA--------------------------------- AUGUST 1986. +C D.BILITZA--------------------------------- AUGUST 1986. COMMON/CONST/UMR,PI C variation with solar activity (factor A) ............... - A=1.0+0.0094*(COV-66.0) + A=1.0+0.0094*(COV-66.0) C variation with noon solar zenith angle (B) and with latitude (C) SL=COS(XLATI*UMR) IF(XLATI.LT.32.0) THEN - SM=-1.93+1.92*SL - C=23.0+116.0*SL + SM=-1.93+1.92*SL + C=23.0+116.0*SL ELSE - SM=0.11-0.49*SL - C=92.0+35.0*SL + SM=0.11-0.49*SL + C=92.0+35.0*SL ENDIF if(XHIM.ge.90.) XHIM=89.999 B = COS(XHIM*UMR) ** SM -C variation with solar zenith angle (D) .......................... +C variation with solar zenith angle (D) .......................... IF(XLATI.GT.12.0) THEN SP=1.2 ELSE - SP=1.31 + SP=1.31 ENDIF C adjusted solar zenith angle during nighttime (XHIC) ............. - XHIC=XHI-3.*ALOG(1.+EXP((XHI-89.98)/3.)) - D=COS(XHIC*UMR)**SP + XHIC=XHI-3.*ALOG(1.+EXP((XHI-89.98)/3.)) + D=COS(XHIC*UMR)**SP C determine foE**4 ................................................ - R4FOE=A*B*C*D + R4FOE=A*B*C*D C minimum allowable foE (foe_min=sqrt[SMIN])............................... SMIN=0.121+0.0015*(COV-60.) SMIN=SMIN*SMIN - IF(R4FOE.LT.SMIN) R4FOE=SMIN - FOEEDI=R4FOE**0.25 - RETURN - END + IF(R4FOE.LT.SMIN) R4FOE=SMIN + FOEEDI=R4FOE**0.25 + RETURN + END C C - REAL FUNCTION XMDED(XHI,R,YW) -C D. BILITZA, 1978, CALCULATES ELECTRON DENSITY OF D MAXIMUM. -C XHI/DEG. IS SOLAR ZENITH ANGLE, R SMOOTHED ZURICH SUNSPOT NUMBER -C AND YW/M-3 THE ASSUMED CONSTANT NIGHT VALUE. + REAL FUNCTION XMDED(XHI,R,YW) +C D. BILITZA, 1978, CALCULATES ELECTRON DENSITY OF D MAXIMUM. +C XHI/DEG. IS SOLAR ZENITH ANGLE, R SMOOTHED ZURICH SUNSPOT NUMBER +C AND YW/M-3 THE ASSUMED CONSTANT NIGHT VALUE. C [REF.: D.BILITZA, WORLD DATA CENTER A REPORT UAG-82,7,BOULDER,1981] C corrected 4/25/97 - D. Bilitza c @@ -6297,128 +6368,128 @@ c if(xhi.ge.90) goto 100 Y = 6.05E8 + 0.088E8 * R yy = cos ( xhi * umr ) - yyy = -0.1 / ( yy**2.7 ) - if (yyy.lt.-40.) then + yyy = -0.1 / ( yy**2.7 ) + if (yyy.lt.-40.) then ymd=0.0 else ymd = y * exp(yyy) endif if (ymd.lt.yw) ymd = yw xmded=ymd - RETURN + RETURN -100 XMDED=YW - RETURN +100 XMDED=YW + RETURN END C C REAL FUNCTION GAMMA1(SMODIP,SLAT,SLONG,HOUR, - & IHARM,NQ,K1,M,MM,M3,SFE) + & IHARM,NQ,K1,M,MM,M3,SFE) C--------------------------------------------------------------- -C CALCULATES GAMMA1=FOF2 OR M3000 USING CCIR NUMERICAL MAP +C CALCULATES GAMMA1=FOF2 OR M3000 USING CCIR NUMERICAL MAP C COEFFICIENTS SFE(M3) FOR MODIFIED DIP LATITUDE (SMODIP/DEG) -C GEOGRAPHIC LATITUDE (SLAT/DEG) AND LONGITUDE (SLONG/DEG) +C GEOGRAPHIC LATITUDE (SLAT/DEG) AND LONGITUDE (SLONG/DEG) C AND UNIVERSIAL TIME (HOUR/DECIMAL HOURS). IHARM IS THE MAXIMUM C NUMBER OF HARMONICS USED FOR DESCRIBING DIURNAL VARIATION. -C NQ(K1) IS AN INTEGER ARRAY GIVING THE HIGHEST DEGREES IN -C LATITUDE FOR EACH LONGITUDE HARMONIC WHERE K1 GIVES THE NUMBER -C OF LONGITUDE HARMONICS. M IS THE NUMBER OF COEFFICIENTS FOR +C NQ(K1) IS AN INTEGER ARRAY GIVING THE HIGHEST DEGREES IN +C LATITUDE FOR EACH LONGITUDE HARMONIC WHERE K1 GIVES THE NUMBER +C OF LONGITUDE HARMONICS. M IS THE NUMBER OF COEFFICIENTS FOR C DESCRIBING VARIATIONS WITH SMODIP, SLAT, AND SLONG. MM IS THE C NUMBER OF COEFFICIENTS FOR THE FOURIER TIME SERIES DESCRIBING C VARIATIONS WITH UT. -C M=1+NQ(1)+2*[NQ(2)+1]+2*[NQ(3)+1]+... , MM=2*IHARM+1, M3=M*MM -C SHEIKH,4.3.77. +C M=1+NQ(1)+2*[NQ(2)+1]+2*[NQ(3)+1]+... , MM=2*IHARM+1, M3=M*MM +C SHEIKH,4.3.77. C--------------------------------------------------------------- - REAL*8 C(12),S(12),COEF(100),SUM - DIMENSION NQ(K1),XSINX(13),SFE(M3) + REAL*8 C(12),S(12),COEF(100),SUM + DIMENSION NQ(K1),XSINX(13),SFE(M3) COMMON/CONST/UMR,PI - HOU=(15.0*HOUR-180.0)*UMR - S(1)=SIN(HOU) - C(1)=COS(HOU) - - DO 250 I=2,IHARM - C(I)=C(1)*C(I-1)-S(1)*S(I-1) - S(I)=C(1)*S(I-1)+S(1)*C(I-1) -250 CONTINUE - - DO 300 I=1,M - MI=(I-1)*MM - COEF(I)=SFE(MI+1) - DO 300 J=1,IHARM - COEF(I)=COEF(I)+SFE(MI+2*J)*S(J)+SFE(MI+2*J+1)*C(J) -300 CONTINUE - - SUM=COEF(1) - SS=SIN(SMODIP*UMR) - S3=SS - XSINX(1)=1.0 - INDEX=NQ(1) - - DO 350 J=1,INDEX - SUM=SUM+COEF(1+J)*SS - XSINX(J+1)=SS - SS=SS*S3 -350 CONTINUE - - XSINX(NQ(1)+2)=SS - NP=NQ(1)+1 - SS=COS(SLAT*UMR) - S3=SS - - DO 400 J=2,K1 - S0=SLONG*(J-1.)*UMR - S1=COS(S0) - S2=SIN(S0) - INDEX=NQ(J)+1 - DO 450 L=1,INDEX - NP=NP+1 - SUM=SUM+COEF(NP)*XSINX(L)*SS*S1 - NP=NP+1 - SUM=SUM+COEF(NP)*XSINX(L)*SS*S2 -450 CONTINUE - SS=SS*S3 + HOU=(15.0*HOUR-180.0)*UMR + S(1)=SIN(HOU) + C(1)=COS(HOU) + + DO 250 I=2,IHARM + C(I)=C(1)*C(I-1)-S(1)*S(I-1) + S(I)=C(1)*S(I-1)+S(1)*C(I-1) +250 CONTINUE + + DO 300 I=1,M + MI=(I-1)*MM + COEF(I)=SFE(MI+1) + DO 300 J=1,IHARM + COEF(I)=COEF(I)+SFE(MI+2*J)*S(J)+SFE(MI+2*J+1)*C(J) +300 CONTINUE + + SUM=COEF(1) + SS=SIN(SMODIP*UMR) + S3=SS + XSINX(1)=1.0 + INDEX=NQ(1) + + DO 350 J=1,INDEX + SUM=SUM+COEF(1+J)*SS + XSINX(J+1)=SS + SS=SS*S3 +350 CONTINUE + + XSINX(NQ(1)+2)=SS + NP=NQ(1)+1 + SS=COS(SLAT*UMR) + S3=SS + + DO 400 J=2,K1 + S0=SLONG*(J-1.)*UMR + S1=COS(S0) + S2=SIN(S0) + INDEX=NQ(J)+1 + DO 450 L=1,INDEX + NP=NP+1 + SUM=SUM+COEF(NP)*XSINX(L)*SS*S1 + NP=NP+1 + SUM=SUM+COEF(NP)*XSINX(L)*SS*S2 +450 CONTINUE + SS=SS*S3 400 CONTINUE - - GAMMA1=SUM - RETURN - END + GAMMA1=SUM + + RETURN + END +C C -C -C************************************************************ -C***************** PROFILE PARAMETERS *********************** -C************************************************************ +C************************************************************ +C***************** PROFILE PARAMETERS *********************** +C************************************************************ C C SUBROUTINE TOPH05(COVI,AMLAT,TIME,HMAX,HT05,SG) C--------------------------------------------------------------------------------- -C Gulyaeva T.L. (2003) Variations in the half-width of the topside ionosphere +C Gulyaeva T.L. (2003) Variations in the half-width of the topside ionosphere C according to the observations by space ionosondes ISIS 1,ISIS 2, and IK19. C International J. of Geomagnetism and Aeronomy, 4(3), 201-207. -C Gulyaeva T.L., Titheridge J.E. (2006) Advanced specification of electron density -C and temperature in the IRI ionosphere-plasmasphere model. +C Gulyaeva T.L., Titheridge J.E. (2006) Advanced specification of electron density +C and temperature in the IRI ionosphere-plasmasphere model. C Adv. Space Res. 38(11), 2587-2595, doi:10.1016/j.asr.2005.08.045. C C Implementation of empirical RAT=(h05top-hmF2)/hmF2 derived from ISIS and IK19 C topside electron density profiles to obtain half peak density topside height -C h05top from the Chebishev polinomial coefficients given for +C h05top from the Chebishev polinomial coefficients given for C (1) 4 levels of solar activity: Rz= 0, 50, 100, 150 replaced by C solar radio flux covi=60, 106, 152, 198 C (2) 10 selected grids of geomagnetic latitude (N=S):0,10,20,30,40,50,60,70,80,90 C (3) 5 selected grids of local time: 0, 6, 12, 18, 24. -C (4) 4 seasonal grids: 1 equinox(SG=90deg), 2 summer (SG=180), +C (4) 4 seasonal grids: 1 equinox(SG=90deg), 2 summer (SG=180), C 3 equinox (SG=270), 4 winter(SG=360) C SG=season grids=90,180,270,360 C--------------------------------------------------------------------------------- - DIMENSION CVLEV(4) - COMMON /BLOCK1/HMF2,XNMF2,XHMF1,F1REG + DIMENSION CVLEV(4) + COMMON /BLOCK1/HMF2,XNMF2,XHMF1,F1REG * /QTOP/Y05,H05TOP,QF,XNETOP,XM3000,HHALF,TAU DATA CVLEV/60.,106.,152.,198./ LOGICAL F1REG ABMLAT=ABS(AMLAT) - IR=IFIX((covi-60.)/46.)+1 + IR=IFIX((covi-60.)/46.)+1 M1=IFIX(ABMLAT/10.)+1 L1=IFIX(TIME/6.)+1 M2=M1+1 @@ -6440,7 +6511,7 @@ C RETURN END C -C +C SUBROUTINE CHEBISH(COVS,HOURLT,ABMLAT,RATCH,SG) C--------------------------------------------------------------------------------- C CHEBISHEV POLINOMIALS FOR ABMLAT(10),HOURLT(5) @@ -6451,7 +6522,7 @@ c REAL UK(0:10),CR(0:5,5,3,4),YI(5),YY(5,3) REAL BR(6,5,3,4),YI(5),YY(5,3) REAL PL1(5),PL2(5),PL3(5),CL(0:3) C - COMMON /CONST/rad,pi + COMMON /CONST/rad,pi DATA PL1/-2.,-1.,0.,1.,2./ DATA PL2/2.,-1.,-2.,-1.,2./ DATA PL3/-1.,2.,0.,-2.,1./ @@ -6463,13 +6534,13 @@ C Equinox B0MLAT: *,-12.8000, 35.3084,-38.0043,19.6004,-4.4974,.6975 *, 5.8282,-13.3538, 9.1674,-0.9593,-0.8909,.6062 *, -1.5859, 3.5789, -3.7884, 2.7094,-1.2962,.6759 -C Summer B0MLAT +C Summer B0MLAT *, -7.1103, 21.0389,-24.5539,14.1607,-3.8537,.7266 *, 5.5333,-10.6242, 4.8751, 1.0587,-1.0821,.7527 *,-15.4487, 42.9269,-45.0314,21.4718,-4.2116,.6026 *, -6.6436, 16.4533,-15.5142, 6.8287,-1.2871,.4976 *, -7.1103, 21.0389,-24.5539,14.1607,-3.8537,.7266 -C Winter B0MLAT +C Winter B0MLAT *, 14.9103,-35.2337, 27.3078,-6.5362,-0.6265,.7509 *, 2.3846, -5.8840, 3.7023, 0.8525,-1.2663,.7086 *, -9.8846, 26.6649,-27.0173,12.6959,-2.6536,.6295 @@ -6482,13 +6553,13 @@ C Equinox B1MLAT *,-16.2744, 42.8047,-43.7009,20.7965,-4.0697,.6619 *,-17.3038, 44.3336,-40.9249,15.9042,-2.1554,.4796 *, -4.1218, 10.6136,-11.4922, 6.0470,-1.3620,.5563 -C Summer B1MLAT +C Summer B1MLAT *, -4.9692, 16.5753,-21.3543,12.7061,-3.1758,.6446 *, 1.9000, -2.8167, -0.9962, 3.0687,-1.3454,.6859 *, 7.6769,-14.8343, 6.7030, 1.5578,-1.0626,.4291 *, 5.4833,-10.6322, 4.7571, 1.2178,-0.8223,.4615 *, -4.9692, 16.5753,-21.3543,12.7061,-3.1758,.6446 -C Winter B1MLAT +C Winter B1MLAT *, -4.7282, 13.4491,-15.6931, 8.8388,-1.9732,.5874 *, 5.6756,-14.8458, 11.8927,-2.2632,-0.6122,.6948 *,-14.2872, 40.0829,-41.2716,18.1696,-2.7203,.4916 @@ -6501,13 +6572,13 @@ C Equinox B2MLAT *, 12.0462,-27.8932, 20.6241,-4.5781, 0.0814,.3501 *,-17.0551, 42.3258,-37.1874,13.3608,-1.4804,.4216 *, -3.3282, 10.4296,-12.4722, 6.7623,-1.5172,.4931 -C Summer B2MLAT +C Summer B2MLAT *, 7.3077,-17.1579, 11.6872,-0.7405,-1.0298,.5754 *, 19.2641,-45.1886, 34.3297,-8.1879,-0.1875,.6562 *, 6.0987,-11.0903, 4.3569, 1.4001,-0.7309,.3885 *, 5.9295,-13.9205, 10.2347,-2.2818, 0.0853,.3915 *, 7.3077,-17.1579, 11.6872,-0.7405,-1.0298,.5754 -C Winter B2MLAT +C Winter B2MLAT *, -1.6821, 8.6010,-13.6570, 8.6307,-1.9846,.5635 *, 5.4679,-12.3750, 7.5620, 0.5394,-1.4415,.6659 *, -8.0821, 21.9288,-21.8597, 9.3455,-1.4644,.3599 @@ -6539,17 +6610,17 @@ C DATA UL/-2.,-1.,0.,1.,2./ cl(k)=0. enddo C - IR=IFIX((covs-60.)/46.)+1 + IR=IFIX((covs-60.)/46.)+1 C Given geomagnetic latitude parameter: xi=abmlat/100. DO LS=1,3 DO LL=1,5 - B1=BR(6,LL,LS,IR) - B2=BR(5,LL,LS,IR) - B3=BR(4,LL,LS,IR) - B4=BR(3,LL,LS,IR) - B5=BR(2,LL,LS,IR) - B6=BR(1,LL,LS,IR) + B1=BR(6,LL,LS,IR) + B2=BR(5,LL,LS,IR) + B3=BR(4,LL,LS,IR) + B4=BR(3,LL,LS,IR) + B5=BR(2,LL,LS,IR) + B6=BR(1,LL,LS,IR) HLT=(LL-1)*6.0 YY(LL,LS)=B1+xi*(B2+xi*(B3+xi*(B4+xi*(B5+xi*B6)))) @@ -6577,7 +6648,7 @@ C Apply seasonal interpolation RATCH=ZA+ULL*(CL(1)-3.4*CL(3)+ULL*(CL(2)+ULL*CL(3))) RETURN - END + END C C SUBROUTINE SHAMDB0D (RLAT,FLON,T,RZ,B) @@ -6586,7 +6657,7 @@ C COMPUTES THE HOURLY VALUES OF B0 FROM A SET OF SH COEFFICIENTS C IN A POINT OF A GIVEN GEOCENTRIC LATITUDE AND LONGITUDE C OF THE EARTH'S SURFACE FOR A GIVEN MONTH AND A GIVEN SUSPOT NUMER C -C INPUT: RLAT The geogrphic latitude on the meridian given by +C INPUT: RLAT The geogrphic latitude on the meridian given by C the local time (FLON), where the modified dip C latitude is the same as of the orginal site. C FLON =LONGITUDE+15.*UT(hours) @@ -6594,11 +6665,11 @@ C T Month as a REAL number (1.0 to 12.0) C RZ 12-month running mean C OUTOUT B =B0 C -C Blanch E., D. Arrazola, D. Altadill, D. Buresova, M. Mosert, +C Blanch E., D. Arrazola, D. Altadill, D. Buresova, M. Mosert, C Adv. Space Res. 39, 701-710, 2007. -C Altadill, D., D. Arrazola, E. Blanch, D. Buresova, +C Altadill, D., D. Arrazola, E. Blanch, D. Buresova, C Adv. Space Res. 42, 610-616, 2008. -C Altadill, D., J.M. Torta, and E. Blanch, +C Altadill, D., J.M. Torta, and E. Blanch, C Adv. Space Res. 43,1825-1834, 2009. C------------------------------------------------------------------- PARAMETER (IBO=0,JBO=1,KDIM=6,LDIM=4,L=-1) @@ -6611,7 +6682,7 @@ C------------------------------------------------------------------- * HBNM(0:KDIM,0:KDIM,1-IBO-JBO:LDIM) DIMENSION BINT(0:KDIM,0:KDIM,1-IBO-JBO:LDIM), * BEXT(0:KDIM,0:KDIM,1-IBO-JBO:LDIM) - CHARACTER*1 IE + CHARACTER*1 IE COMMON/ATB/BINT,BEXT,RE,TZERO,IFIT,IB,KINT,LINT,KEXT, * LEXT,KMAX,FN @@ -6704,7 +6775,7 @@ C------------------------------------------------------------------- * 88.440,-0.393, -69.598, 0.643, * -109.481, 0.532, 82.266,-0.765, -59.229, 0.182, 55.279,-0.580, * 28.514,-0.057, -30.282, 0.326, -22.924, 0.164, 11.602,-0.073, - * 40*0.000/ + * 40*0.000/ KMAX = MAX(KINT,KEXT) IF (KMAX .GT. KDIM) GO TO 9999 @@ -6718,7 +6789,7 @@ C------------------------------------------------------------------- GNM(N,M,J)=GANM(N,M,J)+GBNM(N,M,J)*rz HNM(N,M,J)=HANM(N,M,J)+HBNM(N,M,J)*rz ENDDO - + IF (IE .EQ. 'I') THEN IF (N .GT. KINT) GO TO 500 LJ = LINT @@ -6751,7 +6822,7 @@ C------------------------------------------------------------------- C 500 CONTINUE C ********************************************************** -C SYNTHESIZES THE VALUE OF B0 FROM THE MODEL +C SYNTHESIZES THE VALUE OF B0 FROM THE MODEL C ********************************************************** CALL SCHNEVPD(RZ,RLAT,FLON,dum,T,L,dum,dum,B) RETURN @@ -6788,17 +6859,17 @@ C SUBPROGRAM USED: LEGFUN C ***** PARAMS & COEFFS TRANSFERRED FROM MAIN PROGRAM ***** -C ADAPTED FROM SUBROUTINE SCHNEV OF G.V. HAINES (COMPUTERS & GEOSCIENCES, +C ADAPTED FROM SUBROUTINE SCHNEV OF G.V. HAINES (COMPUTERS & GEOSCIENCES, C 14, 413-447, 1988) C------------------------------------------------------------------- - PARAMETER (IBO=0,JBO=1,KDIM=6,LDIM=4) + PARAMETER (IBO=0,JBO=1,KDIM=6,LDIM=4) DIMENSION FN(0:KDIM,0:KDIM), CONSTP(0:KDIM,0:KDIM) DIMENSION CML(KDIM), SML(KDIM) DIMENSION DELT(0:LDIM) DIMENSION BINT(0:KDIM,0:KDIM,1-IBO-JBO:LDIM), * BEXT(0:KDIM,0:KDIM,1-IBO-JBO:LDIM) - COMMON /CONST/dfarg,PI + COMMON /CONST/dfarg,PI * /ATB/BINT,BEXT,RE,TZERO,IFIT,IB,KINT,LINT,KEXT, * LEXT,KMAX,FN CHARACTER*1 IE,RESP @@ -6815,10 +6886,10 @@ C 2 FOURIER SERIES C 3 COSINE SERIES C 4 SINE SERIES C NOTE: TZERO AND THINT MAY DEPEND ON IBF. - IBF = 2 + IBF = 2 T1=1. T2=12. - CALL TBFIT (T1,T2,IBF,THINT,TZERO) + CALL TBFIT (T1,T2,IBF,THINT,TZERO) C IF (L .NE. 0) GO TO 100 C BN = FLATO @@ -6883,7 +6954,7 @@ C RETURN GO TO 999 ENDIF 102 CONTINUE - incept = 0 + incept = 0 if ((ibf.eq.2 .or. ibf.eq.3) .and. incept .eq. 1) then c change to intercept form of fourier series. do i=2,lint,4-ibf @@ -7006,7 +7077,7 @@ C * HBNM(0:KDIM,0:KDIM,1-IBO-JBO:LDIM) DIMENSION BINT(0:KDIM,0:KDIM,1-IBO-JBO:LDIM), * BEXT(0:KDIM,0:KDIM,1-IBO-JBO:LDIM) - CHARACTER*1 IE + CHARACTER*1 IE COMMON/ATB1/BINT,BEXT,RE,TZERO,IFIT,IB,KINT,LINT,KEXT, * LEXT,KMAX,FN @@ -7082,7 +7153,7 @@ C * -1.911, 0.016, -4.519, 0.041, * 2.644,-0.024, 5.569,-0.050, 1.287,-0.009, 3.707,-0.031, * -0.894, 0.007, -2.121, 0.019, 0.669,-0.007, 0.933,-0.010, - * 80*0.000/ + * 80*0.000/ KMAX = MAX(KINT,KEXT) IF (KMAX .GT. KDIM) GO TO 9999 @@ -7096,7 +7167,7 @@ C GNM(N,M,J)=GANM(N,M,J)+GBNM(N,M,J)*rz HNM(N,M,J)=HANM(N,M,J)+HBNM(N,M,J)*rz ENDDO - + IF (IE .EQ. 'I') THEN IF (N .GT. KINT) GO TO 500 LJ = LINT @@ -7131,7 +7202,7 @@ C 500 CONTINUE C ********************************************************** -C SYNTHESIZES THE VALUE OF B1 FROM THE MODEL +C SYNTHESIZES THE VALUE OF B1 FROM THE MODEL C ********************************************************** CALL SCHNEVPDB1(RZ,FLAT,FLON,dum,T,L,dum,dum,B) C @@ -7169,17 +7240,17 @@ C SUBPROGRAM USED: LEGFUN C ***** PARAMS & COEFFS TRANSFERRED FROM MAIN PROGRAM ***** -C ADAPTED FROM SUBROUTINE SCHNEV OF G.V. HAINES (COMPUTERS & GEOSCIENCES, +C ADAPTED FROM SUBROUTINE SCHNEV OF G.V. HAINES (COMPUTERS & GEOSCIENCES, C 14, 413-447, 1988) C------------------------------------------------------------------- - PARAMETER (IBO=0,JBO=1,KDIM=6,LDIM=4) + PARAMETER (IBO=0,JBO=1,KDIM=6,LDIM=4) DIMENSION FN(0:KDIM,0:KDIM), CONSTP(0:KDIM,0:KDIM) DIMENSION CML(KDIM), SML(KDIM) DIMENSION DELT(0:LDIM) DIMENSION BINT(0:KDIM,0:KDIM,1-IBO-JBO:LDIM), * BEXT(0:KDIM,0:KDIM,1-IBO-JBO:LDIM) - COMMON /CONST/dfarg,PI + COMMON /CONST/dfarg,PI * /ATB1/BINT,BEXT,RE,TZERO,IFIT,IB,KINT,LINT,KEXT, * LEXT,KMAX,FN CHARACTER*1 IE,RESP @@ -7196,10 +7267,10 @@ C 2 FOURIER SERIES C 3 COSINE SERIES C 4 SINE SERIES C NOTE: TZERO AND THINT MAY DEPEND ON IBF. - IBF = 2 + IBF = 2 T1=1. T2=12. - CALL TBFIT (T1,T2,IBF,THINT,TZERO) + CALL TBFIT (T1,T2,IBF,THINT,TZERO) C IF (L .NE. 0) GO TO 100 C BN = FLATO @@ -7264,7 +7335,7 @@ C RETURN GO TO 999 ENDIF 102 CONTINUE - incept = 0 + incept = 0 if ((ibf.eq.2 .or. ibf.eq.3) .and. incept .eq. 1) then c change to intercept form of fourier series. do i=2,lint,4-ibf @@ -7502,8 +7573,8 @@ C PRINT TERMS OF SERIES C 135 PRINT *, (BM(I),I=1,J) RETURN END -C -C +C +C REAL FUNCTION B0_98 ( HOUR, SAX, SUX, NSEASN, R, ZLO, ZMODIP) C----------------------------------------------------------------- C Interpolation procedure for bottomside thickness parameter B0. @@ -7531,7 +7602,7 @@ C C 01/98 corrected to include a smooth transition at the modip equator C and no discontinuity at the equatorial change in season. C 09/98 new B0 values incl values at the magnetic equator -C 10/98 longitude as input to determine if magnetic equator in northern +C 10/98 longitude as input to determine if magnetic equator in northern C or southern hemisphere C------------------------------------------------------------------- REAL NITVAL @@ -7584,8 +7655,8 @@ C bfd(2,2) at modip = -18, C bfd(2,1) or bfd(1,1) at modip = 0, C bfd(1,2) at modip = 20, C bfd(1,3) at modip = 45. -C If the Longitude is between 200 and 320 degrees then the modip -C equator is in the southern hemisphere and bfd(2,1) is used at the +C If the Longitude is between 200 and 320 degrees then the modip +C equator is in the southern hemisphere and bfd(2,1) is used at the C equator, otherwise bfd(1,1) is used. c zx1=bfd(2,3) @@ -7616,63 +7687,63 @@ c SUM = bb0 END C C - SUBROUTINE TAL(SHABR,SDELTA,SHBR,SDTDH0,AUS6,SPT) + SUBROUTINE TAL(SHABR,SDELTA,SHBR,SDTDH0,AUS6,SPT) C----------------------------------------------------------- C CALCULATES THE COEFFICIENTS SPT FOR THE POLYNOMIAL -C Y(X)=1+SPT(1)*X**2+SPT(2)*X**3+SPT(3)*X**4+SPT(4)*X**5 -C TO FIT THE VALLEY IN Y, REPRESENTED BY: -C Y(X=0)=1, THE X VALUE OF THE DEEPEST VALLEY POINT (SHABR), -C THE PRECENTAGE DEPTH (SDELTA), THE WIDTH (SHBR) AND THE -C DERIVATIVE DY/DX AT THE UPPER VALLEY BOUNDRY (SDTDH0). -C IF THERE IS AN UNWANTED ADDITIONAL EXTREMUM IN THE VALLEY -C REGION, THEN AUS6=.TRUE., ELSE AUS6=.FALSE.. -C FOR -SDELTA THE COEFF. ARE CALCULATED FOR THE FUNCTION -C Y(X)=EXP(SPT(1)*X**2+...+SPT(4)*X**5). +C Y(X)=1+SPT(1)*X**2+SPT(2)*X**3+SPT(3)*X**4+SPT(4)*X**5 +C TO FIT THE VALLEY IN Y, REPRESENTED BY: +C Y(X=0)=1, THE X VALUE OF THE DEEPEST VALLEY POINT (SHABR), +C THE PRECENTAGE DEPTH (SDELTA), THE WIDTH (SHBR) AND THE +C DERIVATIVE DY/DX AT THE UPPER VALLEY BOUNDRY (SDTDH0). +C IF THERE IS AN UNWANTED ADDITIONAL EXTREMUM IN THE VALLEY +C REGION, THEN AUS6=.TRUE., ELSE AUS6=.FALSE.. +C FOR -SDELTA THE COEFF. ARE CALCULATED FOR THE FUNCTION +C Y(X)=EXP(SPT(1)*X**2+...+SPT(4)*X**5). C----------------------------------------------------------- - DIMENSION SPT(4) - LOGICAL AUS6 + DIMENSION SPT(4) + LOGICAL AUS6 AUS6=.FALSE. if(SHBR.le.0.0) then AUS6=.TRUE. RETURN ENDIF - Z1=-SDELTA/(100.0*SHABR*SHABR) - IF(SDELTA.GT.0.) GOTO 500 - SDELTA=-SDELTA - Z1=ALOG(1.-SDELTA/100.)/(SHABR*SHABR) -500 Z3=SDTDH0/(2.*SHBR) - Z4=SHABR-SHBR - SPT(4)=2.0*(Z1*(SHBR-2.0*SHABR)*SHBR+Z3*Z4*SHABR)/ - & (SHABR*SHBR*Z4*Z4*Z4) + Z1=-SDELTA/(100.0*SHABR*SHABR) + IF(SDELTA.GT.0.) GOTO 500 + SDELTA=-SDELTA + Z1=ALOG(1.-SDELTA/100.)/(SHABR*SHABR) +500 Z3=SDTDH0/(2.*SHBR) + Z4=SHABR-SHBR + SPT(4)=2.0*(Z1*(SHBR-2.0*SHABR)*SHBR+Z3*Z4*SHABR)/ + & (SHABR*SHBR*Z4*Z4*Z4) SPT(3)=Z1*(2.0*SHBR-3.0*SHABR)/(SHABR*Z4*Z4)- - & (2.*SHABR+SHBR)*SPT(4) - SPT(2)=-2.0*Z1/SHABR-2.0*SHABR*SPT(3)-3.0*SHABR*SHABR*SPT(4) - SPT(1)=Z1-SHABR*(SPT(2)+SHABR*(SPT(3)+SHABR*SPT(4))) - B=4.*SPT(3)/(5.*SPT(4))+SHABR - C=-2.*SPT(1)/(5*SPT(4)*SHABR) - Z2=B*B/4.-C - IF(Z2.LT.0.0) GOTO 300 - Z3=SQRT(Z2) - Z1=B/2. - Z2=-Z1+Z3 - IF(Z2.GT.0.0.AND.Z2.LT.SHBR) AUS6=.TRUE. - IF (ABS(Z3).GT.1.E-15) GOTO 400 - Z2=C/Z2 - IF(Z2.GT.0.0.AND.Z2.LT.SHBR) AUS6=.TRUE. - RETURN -400 Z2=-Z1-Z3 - IF(Z2.GT.0.0.AND.Z2.LT.SHBR) AUS6=.TRUE. -300 RETURN - END + & (2.*SHABR+SHBR)*SPT(4) + SPT(2)=-2.0*Z1/SHABR-2.0*SHABR*SPT(3)-3.0*SHABR*SHABR*SPT(4) + SPT(1)=Z1-SHABR*(SPT(2)+SHABR*(SPT(3)+SHABR*SPT(4))) + B=4.*SPT(3)/(5.*SPT(4))+SHABR + C=-2.*SPT(1)/(5*SPT(4)*SHABR) + Z2=B*B/4.-C + IF(Z2.LT.0.0) GOTO 300 + Z3=SQRT(Z2) + Z1=B/2. + Z2=-Z1+Z3 + IF(Z2.GT.0.0.AND.Z2.LT.SHBR) AUS6=.TRUE. + IF (ABS(Z3).GT.1.E-15) GOTO 400 + Z2=C/Z2 + IF(Z2.GT.0.0.AND.Z2.LT.SHBR) AUS6=.TRUE. + RETURN +400 Z2=-Z1-Z3 + IF(Z2.GT.0.0.AND.Z2.LT.SHBR) AUS6=.TRUE. +300 RETURN + END C C SUBROUTINE VALGUL(XHI,HVB,VWU,VWA,VDP) -C --------------------------------------------------------------------- +C --------------------------------------------------------------------- C CALCULATES E-F VALLEY PARAMETERS; T.L. GULYAEVA, ADVANCES IN C SPACE RESEARCH 7, #6, 39-48, 1987. C C INPUT: XHI SOLAR ZENITH ANGLE [DEGREE] -C +C C OUTPUT: VDP VALLEY DEPTH (NVB/NME) C VWU VALLEY WIDTH [KM] C VWA VALLEY WIDTH (SMALLER, CORRECTED BY RAWER) @@ -7695,7 +7766,7 @@ C C Subroutine DRegion(z,it,f,vKp,f5SW,f6WA,elg) c----------------------------------------------------------------------- -c Reference: Danilov, Rodevich, and Smirnova, Adv. Space Res. +c Reference: Danilov, Rodevich, and Smirnova, Adv. Space Res. C 15, #2, 165, 1995. C C Input: z - solar zenith angle in degrees @@ -7709,18 +7780,18 @@ C =0 no WA, =0.5 weak WA, =1 strong WA C Criteria for SW and WA indicators: C SW minor: Temperature increase at the 30 hPa level by 10 deg. C SA major: The same but by 20 degrees. -C Temperature data for each year are published +C Temperature data for each year are published C in Beilage zur Berliner Wetterkarte (K. Labitzke et al.). -C WA weak: An increase of the absorption in the 2-2.8 MHz +C WA weak: An increase of the absorption in the 2-2.8 MHz C range at short A3 paths by 15 dB C WA strong: The same by 30 dB. -C +C C Only for month 12 to 2 (winter). C C Output: elg(7) alog10 of electron density [cm-3] at h=60,65, C 70,75,80,85, and 90km c----------------------------------------------------------------------- -c +c cor dimension h(7),A0(7),A1(7),A2(7),A3(7),A4(7),A5(7),A6(7),elg(7) dimension A0(7),A1(7),A2(7),A3(7),A4(7),A5(7),A6(7),elg(7) data A0/1.0,1.2,1.4,1.5,1.6,1.7,3.0/ @@ -7762,155 +7833,155 @@ cor dimension h(7),A0(7),A1(7),A2(7),A3(7),A4(7),A5(7),A6(7),elg(7) C C C -C -C************************************************************ -C*************** EARTH MAGNETIC FIELD *********************** -C************************************************************** C +C************************************************************ +C*************** EARTH MAGNETIC FIELD *********************** +C************************************************************** C - SUBROUTINE FIELDG(DLAT,DLONG,ALT,X,Y,Z,F,DIP,DEC,SMODIP) -C THIS IS A SPECIAL VERSION OF THE POGO 68/10 MAGNETIC FIELD -C LEGENDRE MODEL. TRANSFORMATION COEFF. G(144) VALID FOR 1973. -C INPUT: DLAT, DLONG=GEOGRAPHIC COORDINATES/DEG.(-90/90,0/360), -C ALT=ALTITUDE/KM. -C OUTPUT: F TOTAL FIELD (GAUSS), Z DOWNWARD VERTICAL COMPONENT -C X,Y COMPONENTS IN THE EQUATORIAL PLANE (X TO ZERO LONGITUDE). -C DIP INCLINATION ANGLE(DEGREE). SMODIP RAWER'S MODFIED DIP. -C SHEIK,1977. +C + SUBROUTINE FIELDG(DLAT,DLONG,ALT,X,Y,Z,F,DIP,DEC,SMODIP) +C THIS IS A SPECIAL VERSION OF THE POGO 68/10 MAGNETIC FIELD +C LEGENDRE MODEL. TRANSFORMATION COEFF. G(144) VALID FOR 1973. +C INPUT: DLAT, DLONG=GEOGRAPHIC COORDINATES/DEG.(-90/90,0/360), +C ALT=ALTITUDE/KM. +C OUTPUT: F TOTAL FIELD (GAUSS), Z DOWNWARD VERTICAL COMPONENT +C X,Y COMPONENTS IN THE EQUATORIAL PLANE (X TO ZERO LONGITUDE). +C DIP INCLINATION ANGLE(DEGREE). SMODIP RAWER'S MODFIED DIP. +C SHEIK,1977. DIMENSION H(144),XI(3),G(144),FEL1(72),FEL2(72) - COMMON/CONST/UMR,PI - DATA FEL1/0.0, 0.1506723,0.0101742, -0.0286519, 0.0092606, - & -0.0130846, 0.0089594, -0.0136808,-0.0001508, -0.0093977, - & 0.0130650, 0.0020520, -0.0121956, -0.0023451, -0.0208555, - & 0.0068416,-0.0142659, -0.0093322, -0.0021364, -0.0078910, - & 0.0045586, 0.0128904, -0.0002951, -0.0237245,0.0289493, - & 0.0074605, -0.0105741, -0.0005116, -0.0105732, -0.0058542, - &0.0033268, 0.0078164,0.0211234, 0.0099309, 0.0362792, - &-0.0201070,-0.0046350,-0.0058722,0.0011147,-0.0013949, - & -0.0108838, 0.0322263, -0.0147390, 0.0031247, 0.0111986, - & -0.0109394,0.0058112, 0.2739046, -0.0155682, -0.0253272, - & 0.0163782, 0.0205730, 0.0022081, 0.0112749,-0.0098427, - & 0.0072705, 0.0195189, -0.0081132, -0.0071889, -0.0579970, - & -0.0856642, 0.1884260,-0.7391512, 0.1210288, -0.0241888, - & -0.0052464, -0.0096312, -0.0044834, 0.0201764, 0.0258343, - &0.0083033, 0.0077187/ - DATA FEL2/0.0586055,0.0102236,-0.0396107, - & -0.0167860, -0.2019911, -0.5810815,0.0379916, 3.7508268, - & 1.8133030, -0.0564250, -0.0557352, 0.1335347, -0.0142641, - & -0.1024618,0.0970994, -0.0751830,-0.1274948, 0.0402073, - & 0.0386290, 0.1883088, 0.1838960, -0.7848989,0.7591817, - & -0.9302389,-0.8560960, 0.6633250, -4.6363869, -13.2599277, - & 0.1002136, 0.0855714,-0.0991981, -0.0765378,-0.0455264, - & 0.1169326, -0.2604067, 0.1800076, -0.2223685, -0.6347679, - &0.5334222, -0.3459502,-0.1573697, 0.8589464, 1.7815990, - &-6.3347645, -3.1513653, -9.9927750,13.3327637, -35.4897308, - &37.3466339, -0.5257398, 0.0571474, -0.5421217, 0.2404770, - & -0.1747774,-0.3433644, 0.4829708,0.3935944, 0.4885033, - & 0.8488121, -0.7640999, -1.8884945, 3.2930784,-7.3497229, - & 0.1672821,-0.2306652, 10.5782146, 12.6031065, 8.6579742, - & 215.5209961, -27.1419220,22.3405762,1108.6394043/ - K=0 - DO 10 I=1,72 - K=K+1 - G(K)=FEL1(I) -10 G(72+K)=FEL2(I) - RLAT=DLAT*UMR - CT=SIN(RLAT) - ST=COS(RLAT) - NMAX=11 - D=SQRT(40680925.0-272336.0*CT*CT) - RLONG=DLONG*UMR - CP=COS(RLONG) - SP=SIN(RLONG) - ZZZ=(ALT+40408589.0/D)*CT/6371.2 - RHO=(ALT+40680925.0/D)*ST/6371.2 - XXX=RHO*CP - YYY=RHO*SP - RQ=1.0/(XXX*XXX+YYY*YYY+ZZZ*ZZZ) - XI(1)=XXX*RQ - XI(2)=YYY*RQ - XI(3)=ZZZ*RQ - IHMAX=NMAX*NMAX+1 - LAST=IHMAX+NMAX+NMAX - IMAX=NMAX+NMAX-1 - DO 100 I=IHMAX,LAST -100 H(I)=G(I) - DO 200 K=1,3,2 - I=IMAX - IH=IHMAX -300 IL=IH-I - F1=2./(I-K+2.) - X1=XI(1)*F1 - Y1=XI(2)*F1 - Z1=XI(3)*(F1+F1) - I=I-2 - IF((I-1).LT.0) GOTO 400 - IF((I-1).EQ.0) GOTO 500 - DO 600 M=3,I,2 - H(IL+M+1)=G(IL+M+1)+Z1*H(IH+M+1)+X1*(H(IH+M+3)-H(IH+M-1))- - &Y1*(H(IH+M+2)+H(IH+M-2)) - H(IL+M)=G(IL+M)+Z1*H(IH+M)+X1*(H(IH+M+2)-H(IH+M-2))+ - &Y1*(H(IH+M+3)+H(IH+M-1)) -600 CONTINUE -500 H(IL+2)=G(IL+2)+Z1*H(IH+2)+X1*H(IH+4)-Y1*(H(IH+3)+H(IH)) - H(IL+1)=G(IL+1)+Z1*H(IH+1)+Y1*H(IH+4)+X1*(H(IH+3)-H(IH)) -400 H(IL)=G(IL)+Z1*H(IH)+2.0*(X1*H(IH+1)+Y1*H(IH+2)) -700 IH=IL - IF(I.GE.K) GOTO 300 -200 CONTINUE - S=0.5*H(1)+2.0*(H(2)*XI(3)+H(3)*XI(1)+H(4)*XI(2)) - XT=(RQ+RQ)*SQRT(RQ) - X=XT*(H(3)-S*XXX) - Y=XT*(H(4)-S*YYY) - Z=XT*(H(2)-S*ZZZ) - F=SQRT(X*X+Y*Y+Z*Z) - BRH0=Y*SP+X*CP - Y=Y*CP-X*SP - X=Z*ST-BRH0*CT - Z=-Z*CT-BRH0*ST + COMMON/CONST/UMR,PI + DATA FEL1/0.0, 0.1506723,0.0101742, -0.0286519, 0.0092606, + & -0.0130846, 0.0089594, -0.0136808,-0.0001508, -0.0093977, + & 0.0130650, 0.0020520, -0.0121956, -0.0023451, -0.0208555, + & 0.0068416,-0.0142659, -0.0093322, -0.0021364, -0.0078910, + & 0.0045586, 0.0128904, -0.0002951, -0.0237245,0.0289493, + & 0.0074605, -0.0105741, -0.0005116, -0.0105732, -0.0058542, + &0.0033268, 0.0078164,0.0211234, 0.0099309, 0.0362792, + &-0.0201070,-0.0046350,-0.0058722,0.0011147,-0.0013949, + & -0.0108838, 0.0322263, -0.0147390, 0.0031247, 0.0111986, + & -0.0109394,0.0058112, 0.2739046, -0.0155682, -0.0253272, + & 0.0163782, 0.0205730, 0.0022081, 0.0112749,-0.0098427, + & 0.0072705, 0.0195189, -0.0081132, -0.0071889, -0.0579970, + & -0.0856642, 0.1884260,-0.7391512, 0.1210288, -0.0241888, + & -0.0052464, -0.0096312, -0.0044834, 0.0201764, 0.0258343, + &0.0083033, 0.0077187/ + DATA FEL2/0.0586055,0.0102236,-0.0396107, + & -0.0167860, -0.2019911, -0.5810815,0.0379916, 3.7508268, + & 1.8133030, -0.0564250, -0.0557352, 0.1335347, -0.0142641, + & -0.1024618,0.0970994, -0.0751830,-0.1274948, 0.0402073, + & 0.0386290, 0.1883088, 0.1838960, -0.7848989,0.7591817, + & -0.9302389,-0.8560960, 0.6633250, -4.6363869, -13.2599277, + & 0.1002136, 0.0855714,-0.0991981, -0.0765378,-0.0455264, + & 0.1169326, -0.2604067, 0.1800076, -0.2223685, -0.6347679, + &0.5334222, -0.3459502,-0.1573697, 0.8589464, 1.7815990, + &-6.3347645, -3.1513653, -9.9927750,13.3327637, -35.4897308, + &37.3466339, -0.5257398, 0.0571474, -0.5421217, 0.2404770, + & -0.1747774,-0.3433644, 0.4829708,0.3935944, 0.4885033, + & 0.8488121, -0.7640999, -1.8884945, 3.2930784,-7.3497229, + & 0.1672821,-0.2306652, 10.5782146, 12.6031065, 8.6579742, + & 215.5209961, -27.1419220,22.3405762,1108.6394043/ + K=0 + DO 10 I=1,72 + K=K+1 + G(K)=FEL1(I) +10 G(72+K)=FEL2(I) + RLAT=DLAT*UMR + CT=SIN(RLAT) + ST=COS(RLAT) + NMAX=11 + D=SQRT(40680925.0-272336.0*CT*CT) + RLONG=DLONG*UMR + CP=COS(RLONG) + SP=SIN(RLONG) + ZZZ=(ALT+40408589.0/D)*CT/6371.2 + RHO=(ALT+40680925.0/D)*ST/6371.2 + XXX=RHO*CP + YYY=RHO*SP + RQ=1.0/(XXX*XXX+YYY*YYY+ZZZ*ZZZ) + XI(1)=XXX*RQ + XI(2)=YYY*RQ + XI(3)=ZZZ*RQ + IHMAX=NMAX*NMAX+1 + LAST=IHMAX+NMAX+NMAX + IMAX=NMAX+NMAX-1 + DO 100 I=IHMAX,LAST +100 H(I)=G(I) + DO 200 K=1,3,2 + I=IMAX + IH=IHMAX +300 IL=IH-I + F1=2./(I-K+2.) + X1=XI(1)*F1 + Y1=XI(2)*F1 + Z1=XI(3)*(F1+F1) + I=I-2 + IF((I-1).LT.0) GOTO 400 + IF((I-1).EQ.0) GOTO 500 + DO 600 M=3,I,2 + H(IL+M+1)=G(IL+M+1)+Z1*H(IH+M+1)+X1*(H(IH+M+3)-H(IH+M-1))- + &Y1*(H(IH+M+2)+H(IH+M-2)) + H(IL+M)=G(IL+M)+Z1*H(IH+M)+X1*(H(IH+M+2)-H(IH+M-2))+ + &Y1*(H(IH+M+3)+H(IH+M-1)) +600 CONTINUE +500 H(IL+2)=G(IL+2)+Z1*H(IH+2)+X1*H(IH+4)-Y1*(H(IH+3)+H(IH)) + H(IL+1)=G(IL+1)+Z1*H(IH+1)+Y1*H(IH+4)+X1*(H(IH+3)-H(IH)) +400 H(IL)=G(IL)+Z1*H(IH)+2.0*(X1*H(IH+1)+Y1*H(IH+2)) +700 IH=IL + IF(I.GE.K) GOTO 300 +200 CONTINUE + S=0.5*H(1)+2.0*(H(2)*XI(3)+H(3)*XI(1)+H(4)*XI(2)) + XT=(RQ+RQ)*SQRT(RQ) + X=XT*(H(3)-S*XXX) + Y=XT*(H(4)-S*YYY) + Z=XT*(H(2)-S*ZZZ) + F=SQRT(X*X+Y*Y+Z*Z) + BRH0=Y*SP+X*CP + Y=Y*CP-X*SP + X=Z*ST-BRH0*CT + Z=-Z*CT-BRH0*ST zdivf=z/f IF(ABS(zdivf).GT.1.) zdivf=SIGN(1.,zdivf) DIP=ASIN(zdivf) - ydivs=y/sqrt(x*x+y*y) + ydivs=y/sqrt(x*x+y*y) IF(ABS(ydivs).GT.1.) ydivs=SIGN(1.,ydivs) DEC=ASIN(ydivs) dipdiv=DIP/SQRT(DIP*DIP+ST) IF(ABS(dipdiv).GT.1.) dipdiv=SIGN(1.,dipdiv) SMODIP=ASIN(dipdiv) - DIP=DIP/UMR - DEC=DEC/UMR - SMODIP=SMODIP/UMR - RETURN - END + DIP=DIP/UMR + DEC=DEC/UMR + SMODIP=SMODIP/UMR + RETURN + END C C -C************************************************************ -C*********** INTERPOLATION AND REST *************************** -C************************************************************** +C************************************************************ +C*********** INTERPOLATION AND REST *************************** +C************************************************************** C C - SUBROUTINE REGFA1(X11,X22,FX11,FX22,EPS,FW,F,SCHALT,X) -C REGULA-FALSI-PROCEDURE TO FIND X WITH F(X)-FW=0. X1,X2 ARE THE -C STARTING VALUES. THE COMUTATION ENDS WHEN THE X-INTERVAL -C HAS BECOME LESS THEN EPS . IF SIGN(F(X1)-FW)= SIGN(F(X2)-FW) -C THEN SCHALT=.TRUE. - LOGICAL L1,LINKS,K,SCHALT + SUBROUTINE REGFA1(X11,X22,FX11,FX22,EPS,FW,F,SCHALT,X) +C REGULA-FALSI-PROCEDURE TO FIND X WITH F(X)-FW=0. X1,X2 ARE THE +C STARTING VALUES. THE COMUTATION ENDS WHEN THE X-INTERVAL +C HAS BECOME LESS THEN EPS . IF SIGN(F(X1)-FW)= SIGN(F(X2)-FW) +C THEN SCHALT=.TRUE. + LOGICAL L1,LINKS,K,SCHALT SCHALT=.FALSE. - EP=EPS - X1=X11 - X2=X22 - F1=FX11-FW - F2=FX22-FW - K=.FALSE. - NG=2 - LFD=0 + EP=EPS + X1=X11 + X2=X22 + F1=FX11-FW + F2=FX22-FW + K=.FALSE. + NG=2 + LFD=0 IF(F1*F2.LE.0.0) GOTO 200 - X=0.0 - SCHALT=.TRUE. + X=0.0 + SCHALT=.TRUE. RETURN -200 X=(X1*F2-X2*F1)/(F2-F1) - GOTO 400 -300 L1=LINKS +200 X=(X1*F2-X2*F1)/(F2-F1) + GOTO 400 +300 L1=LINKS DX=(X2-X1)/NG IF(.NOT.LINKS) DX=DX*(NG-1) X=X1+DX @@ -7919,22 +7990,22 @@ C THEN SCHALT=.TRUE. IF(LFD.GT.20) THEN EP=EP*10. LFD=0 - ENDIF + ENDIF LINKS=(F1*FX.GT.0.0) - K=.NOT.K + K=.NOT.K IF(LINKS) THEN - X1=X - F1=FX + X1=X + F1=FX ELSE - X2=X - F2=FX - ENDIF - IF(ABS(X2-X1).LE.EP) GOTO 800 - IF(K) GOTO 300 - IF((LINKS.AND.(.NOT.L1)).OR.(.NOT.LINKS.AND.L1)) NG=2*NG - GOTO 200 -800 RETURN - END + X2=X + F2=FX + ENDIF + IF(ABS(X2-X1).LE.EP) GOTO 800 + IF(K) GOTO 300 + IF((LINKS.AND.(.NOT.L1)).OR.(.NOT.LINKS.AND.L1)) NG=2*NG + GOTO 200 +800 RETURN + END C C C****************************************************************** @@ -7958,8 +8029,8 @@ c height height in km c c out: declin declination of the sun in degrees c zenith zenith angle of the sun in degrees -c sunrse local time of sunrise in hours -c sunset local time of sunset in hours +c sunrse local time of sunrise in hours +c sunset local time of sunset in hours c------------------------------------------------------------------- c common/const/dtr,pi /const1/humr,dumr @@ -8031,13 +8102,13 @@ c end c C - FUNCTION HPOL(HOUR,TW,XNW,SA,SU,DSA,DSU) + FUNCTION HPOL(HOUR,TW,XNW,SA,SU,DSA,DSU) C------------------------------------------------------- -C PROCEDURE FOR SMOOTH TIME-INTERPOLATION USING EPSTEIN -C STEP FUNCTION AT SUNRISE (SA) AND SUNSET (SU). THE +C PROCEDURE FOR SMOOTH TIME-INTERPOLATION USING EPSTEIN +C STEP FUNCTION AT SUNRISE (SA) AND SUNSET (SU). THE C STEP-WIDTH FOR SUNRISE IS DSA AND FOR SUNSET DSU. -C TW,NW ARE THE DAY AND NIGHT VALUE OF THE PARAMETER TO -C BE INTERPOLATED. SA AND SU ARE TIME OF SUNRIES AND +C TW,NW ARE THE DAY AND NIGHT VALUE OF THE PARAMETER TO +C BE INTERPOLATED. SA AND SU ARE TIME OF SUNRIES AND C SUNSET IN DECIMAL HOURS. C BILITZA----------------------------------------- 1979. IF(ABS(SU).GT.25.) THEN @@ -8049,16 +8120,16 @@ C BILITZA----------------------------------------- 1979. RETURN ENDIF HPOL=XNW+(TW-XNW)*EPST(HOUR,DSA,SA)+ - & (XNW-TW)*EPST(HOUR,DSU,SU) - RETURN - END -C + & (XNW-TW)*EPST(HOUR,DSU,SU) + RETURN + END +C C SUBROUTINE MODA(IN,IYEAR,MONTH,IDAY,IDOY,NRDAYMO) C------------------------------------------------------------------- -C CALCULATES DAY OF YEAR (IDOY, ddd) FROM YEAR (IYEAR, yy or yyyy), -C MONTH (MONTH, mm) AND DAY OF MONTH (IDAY, dd) IF IN=0, OR MONTH -C AND DAY FROM YEAR AND DAY OF YEAR IF IN=1. NRDAYMO is an output +C CALCULATES DAY OF YEAR (IDOY, ddd) FROM YEAR (IYEAR, yy or yyyy), +C MONTH (MONTH, mm) AND DAY OF MONTH (IDAY, dd) IF IN=0, OR MONTH +C AND DAY FROM YEAR AND DAY OF YEAR IF IN=1. NRDAYMO is an output C parameter providing the number of days in the specific month. C------------------------------------------------------------------- DIMENSION MM(12) @@ -8068,11 +8139,11 @@ C------------------------------------------------------------------- MOBE=0 c c leap year rule: years evenly divisible by 4 are leap years, except -c years also evenly divisible by 100 are not leap years, except years -c also evenly divisible by 400 are leap years. The year 2000 therefore +c years also evenly divisible by 100 are not leap years, except years +c also evenly divisible by 400 are leap years. The year 2000 therefore C is a leap year. The 100 and 400 year exception rule c if((iyear/4*4.eq.iyear).and.(iyear/100*100.ne.iyear)) mm(2)=29 -c will become important again in the year 2100 which is not a leap +c will become important again in the year 2100 which is not a leap C year. c mm(2)=28 @@ -8081,7 +8152,7 @@ c IF(IN.GT.0) GOTO 5 mosum=0 if(month.gt.1) then - do 1234 i=1,month-1 + do 1234 i=1,month-1 1234 mosum=mosum+mm(i) endif idoy=mosum+iday @@ -8097,7 +8168,7 @@ c 55 MONTH=IMO IDAY=IDOY-MOOLD RETURN - END + END c c subroutine ut_lt(mode,ut,slt,glong,iyyy,ddd) @@ -8215,7 +8286,7 @@ C SRASN=3.141592654-ATAN2(COS(OBLIQ)/SOB*SC,-COS(SLP)/COS1) RETURN END -C +C C C ********************************************************************* C ************************ EPSTEIN FUNCTIONS ************************** @@ -8282,19 +8353,19 @@ C -------------------------------------------------------------- STEP C C REAL FUNCTION EPSTEP ( Y2, Y1, SC, HX, X) -C---------------------------------------------- STEP FROM Y1 TO Y2 +C---------------------------------------------- STEP FROM Y1 TO Y2 EPSTEP = Y1 + ( Y2 - Y1 ) * EPST ( X, SC, HX) RETURN END C C REAL FUNCTION EPLA ( X, SC, HX ) -C ------------------------------------------------------------ PEAK +C ------------------------------------------------------------ PEAK COMMON/ARGEXP/ARGMAX D1 = ( X - HX ) / SC IF (ABS(D1).LT.ARGMAX) GOTO 1 EPLA = 0 - RETURN + RETURN 1 D0 = EXP ( D1 ) D2 = 1. + D0 EPLA = D0 / ( D2 * D2 ) @@ -8302,9 +8373,33 @@ C ------------------------------------------------------------ PEAK END c c + REAL FUNCTION BOOKER(H,N,AH,AV,D) +c---------------------------------------------------------------- +C PROFILE BASED ON BOOKER APPROACH +C H HEIGHT IN KM +C N NUMBER OF PROFILE SECTIONS WITH CONSTANT GRADIENT +C AH(N) HEIGHTS MARKING BEGINNING AND END OF SECTIONS +C AV(N) PARAMETER VALUES AT AH +C D(N-2) THICKNESS OF TRANSITION REGION BETWEEN SECTIONS +C ST(N-1) SECTION GRADIENTS +c---------------------------------------------------------------- + REAL AH(N),AV(N),ST(N-1),D(N-2) +C + ST(1)=(AV(2)-AV(1))/(AH(2)-AH(1)) + SUM=AV(1)+ST(1)*(H-AH(1)) + DO 1 I=1,N-2 + aa = eptr(h ,d(i),ah(i+1)) + bb = eptr(ah(i),d(i),ah(i+1)) + ST(I+1)=(AV(I+2)-AV(I+1))/(AH(I+2)-AH(I+1)) +1 SUM=SUM+(ST(I+1)-ST(I))*(AA-BB)*D(I) + BOOKER=SUM + RETURN + END +C +C FUNCTION XE2TO5(H,HMF2,NL,HX,SC,AMP) C---------------------------------------------------------------------- -C NORMALIZED ELECTRON DENSITY (N/NMF2) FOR THE MIDDLE IONOSPHERE FROM +C NORMALIZED ELECTRON DENSITY (N/NMF2) FOR THE MIDDLE IONOSPHERE FROM C HME TO HMF2 USING LAY-FUNCTIONS. C---------------------------------------------------------------------- DIMENSION HX(NL),SC(NL),AMP(NL) @@ -8336,15 +8431,15 @@ C C C SUBROUTINE ROGUL(IDAY,XHI,SX,GRO) -C --------------------------------------------------------------------- +C --------------------------------------------------------------------- C CALCULATES RATIO H0.5/HMF2 FOR HALF-DENSITY POINT (NE(H0.5)=0.5* C NMF2) T. GULYAEVA, ADVANCES IN SPACE RESEARCH 7, #6, 39-48, 1987. C C INPUT: IDAY DAY OF YEAR C XHI SOLAR ZENITH ANGLE [DEGREE] -C +C C OUTPUT: GRO RATIO OF HALF DENSITY HEIGHT TO F PEAK HEIGHT -C SX SMOOTHLY VARYING SEASON PARAMTER (SX=1 FOR +C SX SMOOTHLY VARYING SEASON PARAMTER (SX=1 FOR C DAY=1; SX=3 FOR DAY=180; SX=2 FOR EQUINOX) C --------------------------------------------------------------------- C @@ -8453,7 +8548,7 @@ C DO 1 J=1,5 BLI(J) = 0. DO 1 I=1,5 -1 ALI(J,I) = 0. +1 ALI(J,I) = 0. DO 2 I=1,N DO 3 K=1,M0 3 XLI(I,K) = RLAY( X(K), HM, SC(I), HX(I) ) @@ -8466,7 +8561,7 @@ C DO 6 K=1,M BLI(J) = BLI(J) + W(K) * Y(K) * XLI(J,K) DO 6 I=1,N -6 ALI(J,I) = ALI(J,I) + W(K) * XLI(I,K) +6 ALI(J,I) = ALI(J,I) + W(K) * XLI(I,K) & * XLI(J,K) 7 CONTINUE CALL LNGLSN( N, ALI, BLI, SING ) @@ -8478,7 +8573,7 @@ C END C C - SUBROUTINE INILAY(NIGHT,F1REG,XNMF2,XNMF1,XNME,VNE,HMF2,HMF1, + SUBROUTINE INILAY(NIGHT,F1REG,XNMF2,XNMF1,XNME,VNE,HMF2,HMF1, & HME,HV1,HV2,HHALF,HXL,SCL,AMP,IQUAL) C------------------------------------------------------------------- C CALCULATES AMPLITUDES FOR LAY FUNCTIONS @@ -8497,12 +8592,12 @@ C HV1 ALTITUDE OF VALLEY TOP [KM] C HV2 ALTITUDE OF VALLEY BASE [KM] C HHALF ALTITUDE OF HALF-F2-PEAK-DENSITY [KM] C -C OUTPUT: HXL(4) HEIGHT PARAMETERS FOR LAY FUNCTIONS [KM] +C OUTPUT: HXL(4) HEIGHT PARAMETERS FOR LAY FUNCTIONS [KM] C SCL(4) SCALE PARAMETERS FOR LAY FUNCTIONS [KM] C AMP(4) AMPLITUDES FOR LAY FUNCTIONS C IQUAL =0 ok, =1 ok using second choice for HXL(1) C =2 NO SOLUTION -C--------------------------------------------------------------- +C--------------------------------------------------------------- DIMENSION XX(8),YY(8),WW(8),AMP(4),HXL(4),SCL(4) LOGICAL SSIN,NIGHT,F1REG c @@ -8545,7 +8640,7 @@ c c C DAY CONDITION-------------------------------------------------- c earlier tested: HXL(2) = HMF1 + SCL(2) -c +c IF(NIGHT) GOTO 7711 NUMCON = 8 HXL(1) = 0.9 * HMF2 @@ -8585,11 +8680,11 @@ c with F-region -------------------------------------------- GOTO 7722 c C NIGHT CONDITION--------------------------------------------------- -c different HXL,SCL values were tested including: -c SCL(1) = HMF2 * 0.15 - 27.1 HXL(2) = 200. +c different HXL,SCL values were tested including: +c SCL(1) = HMF2 * 0.15 - 27.1 HXL(2) = 200. c HXL(2) = HMF1 + SCL(2) HXL(3) = 140. c SCL(3) = 5. HXL(4) = HME + SCL(4) -c HXL(4) = 105. +c HXL(4) = 105. c 7711 NUMCON = 7 HXL(1) = HHALF @@ -8629,55 +8724,55 @@ C END c c - subroutine read_ig_rz + subroutine read_ig_rz c---------------------------------------------------------------- -c Reads the Rz12 and IG12 indices file IG_RZ.DAT from I/O UNIT=12 +c Reads the Rz12 and IG12 indices file IG_RZ.DAT from I/O UNIT=12 c and stores the indices in COMMON: c common/igrz/aig,arziyst,iyed with aig(806),arz(806), c start year (iyst) c end year (iyed) -c -c The indices file IG_RZ.DAT is structured as follows (values are -c separated by comma): +c +c The indices file IG_RZ.DAT is structured as follows (values are +c separated by comma): c day, month, year of the last update of this file, c a blank line c start month, start year, end month, end year, c a blank line -c the IG index for December of start year minus 1 (this value is +c the IG index for December of start year minus 1 (this value is c needed for interpolating from 1st to 15th of first year) -c the 12 IG indices (13-months running mean) for start year, -c the 12 IG indices for the second year +c the 12 IG indices (13-months running mean) for start year, +c the 12 IG indices for the second year c .. and so on until the last year, -c the 12 IG indices for the last year +c the 12 IG indices for the last year c the IG index for January of end year plus 1 (needed for interpolation) c a blank line -c the Rz index for December of start year minus 1 +c the Rz index for December of start year minus 1 c the 12 Rz indices (13-months running mean) for the start year, -c the 12 Rz indices for the second year +c the 12 Rz indices for the second year c .. and so on until the last year. -c the 12 Rz indices for the last year -c the Rz index for January of end year plus 1 -c +c the 12 Rz indices for the last year +c the Rz index for January of end year plus 1 +c c A negative Rz index means that the given index is the 13-months- -C running mean of the solar radio flux (F10.7). The close correlation +C running mean of the solar radio flux (F10.7). The close correlation C between (Rz)12 and (F10.7)12 is used to compute the (Rz)12 indices. c c An IG index of -111 indicates that no IG values are available for the -c time period. In this case a correlation function between (IG)12 and +c time period. In this case a correlation function between (IG)12 and C (Rz)12 is used to obtain (IG)12. c c The computation of the 13-month-running mean for month M requires the -c indices for the six months preceeding M and the six months following -C M (month: M-6, ..., M+6). To calculate the current running mean one -C therefore requires predictions of the indix for the next six months. -C Starting from six months before the UPDATE DATE (listed at the top of -c the file) and onward the indices are therefore based on indices +c indices for the six months preceeding M and the six months following +C M (month: M-6, ..., M+6). To calculate the current running mean one +C therefore requires predictions of the indix for the next six months. +C Starting from six months before the UPDATE DATE (listed at the top of +c the file) and onward the indices are therefore based on indices c predictions. c---------------------------------------------------------------- integer iyst,iyend,iymst,iupd,iupm,iupy,imst,imend real aig(806),arz(806) - + common /igrz/aig,arz,iymst,iymend common/folders/datadir character(256) :: datadir @@ -8697,7 +8792,7 @@ c get number of data points to read. read(12,*) imst,iyst,imend,iyend iymst=iyst*100+imst iymend=iyend*100+imend - + c inum_vals= 12-imst+1+(iyend-iyst-1)*12 +imend + 2 c 1st year \ full years \last y\ before & after @@ -8710,7 +8805,7 @@ c read all the IG12 (ionoindx) and Rz12 (indrz) values c use scale factor 0.7 for new sunspot number starting from Jan 2014 c and starting with ig_rz file for Oct 2016. if(iupy*100+iupm.gt.201609) then - inum_chan= 3-imst+(2014-iyst)*12 + inum_chan= 3-imst+(2014-iyst)*12 do 1 jj=inum_chan,inum_vals arz(jj)=arz(jj)*0.7 c ggg=aig(jj) @@ -8725,7 +8820,7 @@ c if(zi.gt.274.0) zi=274.0 c ggg=zi c endif c arz(jj)=rrr -c aig(jj)=ggg +c aig(jj)=ggg 1 continue endif close(unit=12) @@ -8744,12 +8839,12 @@ c rsn interpolation parameter c nmonth previous or following month depending c on day c -c Uses read_ig_rz and common/igrz/ to get indices -c +c Uses read_ig_rz and common/igrz/ to get indices +c c rz(1) & ig(1) contain the indices for the month mm and rz(2) & ig(2) c for the previous month (if day less than 15) or for the following -c month (if day greater than 15). These indices are for the mid of the -c month. The indices for the given day are obtained by linear +c month (if day greater than 15). These indices are for the mid of the +c month. The indices for the given day are obtained by linear c interpolation and are stored in rz(3) and ig(3). c---------------------------------------------------------------- @@ -8758,8 +8853,8 @@ c---------------------------------------------------------------- real ionoindx(806),indrz(806) real ig(3),rz(3) logical mess - - common /iounit/konsol,mess + + common /iounit/konsol,mess common /igrz/ionoindx,indrz,iymst,iymend iytmp=yr*100+mm @@ -8801,7 +8896,7 @@ c if((yr/4*4.eq.yr).and.(yr/100*100.ne.yr)) idd2=381 endif rz(2)=indrz(num+1) ig(2)=ionoindx(num+1) - rsn=(idn-idd1)*1./(idd2-idd1) + rsn=(idn-idd1)*1./(idd2-idd1) rz(3)=rz(1)+(rz(2)-rz(1))*rsn ig(3)=ig(1)+(ig(2)-ig(1))*rsn goto 1927 @@ -8837,26 +8932,26 @@ C .... .... C AAP(*,8) 3-hour Ap indices for the UT interval )21-6) C AAP(*,9) daily Ap C AF107(*,1) F10.7 radio flux for the day -C AF107(*,2) 81-day average of F10.7 radio flux +C AF107(*,2) 81-day average of F10.7 radio flux C AF107(*,3) 365-day average of F10.7 C N total number of records c c APF107.DAT is structured as follows: -c JY(I3),JMN(I3),JD(I3) year, month, day -c IIAP(8) (8I3) 3-hour Ap indices for the UT intervals +c JY(I3),JMN(I3),JD(I3) year, month, day +c IIAP(8) (8I3) 3-hour Ap indices for the UT intervals c (0-3(,(3-6(,(6-9(, .., (18-21(,(21-24( c IAPD (I3) daily Ap c IR (I3) sunspot number for the day (empty) c F107 (F5.1) F10.7 radio flux for the day -c F107_81 (F5.1) 81-day average of F10.7 radio flux -c F107_365 (F5.1) 365-day average of F10.7 centered on -c the date of interest. At start and end -c of index file it takes all available -c indices, e.g. for the first date the -c average is only over 40 F10.7 values -c and over 41 values on the 2nd date. -c -c If date is outside the range of the Ap indices file then IAP(1)=-5 +c F107_81 (F5.1) 81-day average of F10.7 radio flux +c F107_365 (F5.1) 365-day average of F10.7 centered on +c the date of interest. At start and end +c of index file it takes all available +c indices, e.g. for the first date the +c average is only over 40 F10.7 values +c and over 41 values on the 2nd date. +c +c If date is outside the range of the Ap indices file then IAP(1)=-5 C------------------------------------------------------------------------- C INTEGER aap(23000,9),iiap(8) @@ -8876,22 +8971,22 @@ c * FORM='FORMATTED',STATUS='OLD') * F107_365 10 FORMAT(3I3,9I3,I3,3F5.1) -c adate(i)=jy*10000+jmn*100+jd - do j=1,8 +c adate(i)=jy*10000+jmn*100+jd + do j=1,8 aap(i,j)=iiap(j) enddo aap(i,9)=iapda c irza(i)=ir if(F107_81.lt.-4.) F107_81=F107D if(F107_365.lt.-4.) F107_365=F107D - af107(i,1)=f107d - af107(i,2)=f107_81 + af107(i,1)=f107d + af107(i,2)=f107_81 af107(i,3)=f107_365 - i=i+1 + i=i+1 goto 1 21 n=i-1 - + CLOSE(13) return end @@ -8909,14 +9004,14 @@ c IAP(1) AP index for UT-39 hours. c c Gets indices from COMMON/APFA/ c -c If date is outside the range of the Ap indices file than IAP(1)=-5 +c If date is outside the range of the Ap indices file than IAP(1)=-5 c----------------------------------------------------------------------- INTEGER aap(23000,9),iiap(8),iap(13) DIMENSION af107(23000,3) LOGICAL mess COMMON /iounit/konsol,mess /apfa/aap,af107,nf107 - + do i=1,8 iap(i)=-1 enddo @@ -8926,7 +9021,7 @@ c----------------------------------------------------------------------- ihour=int(hour/3.)+1 if(ihour.gt.8) ihour=8 - if(is*8+ihour.lt.13) goto 21 ! less then 13 indices available + if(is*8+ihour.lt.13) goto 21 ! less then 13 indices available j1=13-ihour do i=1,ihour @@ -8941,7 +9036,7 @@ c----------------------------------------------------------------------- if(iapi.lt.-2) goto 21 iap(i)=iapi enddo - else + else j2=5-ihour do i=1,8 iapi=aap(is-1,i) @@ -8953,30 +9048,30 @@ c----------------------------------------------------------------------- if(iapi.lt.-2) goto 21 iap(i)=iapi enddo - endif + endif goto 20 - + 21 if(mess) write(konsol,100) 100 format(1X,'One of the ap indeces is negative.', & ' STORM model is turned off.') IAP(1)=-5 - + 20 RETURN END C C SUBROUTINE APFMSIS(ISDATE,HOUR,IAPO) c----------------------------------------------------------------------- -c Finds 3-hourly Ap indices for NRLMSIS00 model +c Finds 3-hourly Ap indices for NRLMSIS00 model c INPUTS: ISDATE Array-index from APF_ONLY c HOUR UT in decimal hours c OUTPUT: IAPO(1:7) 3-hourly Ap index -C +C C IAPO(1) DAILY AP -C IAPO(2) 3-HR AP INDEX FOR CURRENT TIME -C IAPO(3) 3-HR AP INDEX FOR 3 HRS BEFORE CURRENT TIME -C IAPO(4) 3-HR AP INDEX FOR 6 HRS BEFORE CURRENT TIME -C IAPO(5) 3-HR AP INDEX FOR 9 HRS BEFORE CURRENT TIME +C IAPO(2) 3-HR AP INDEX FOR CURRENT TIME +C IAPO(3) 3-HR AP INDEX FOR 3 HRS BEFORE CURRENT TIME +C IAPO(4) 3-HR AP INDEX FOR 6 HRS BEFORE CURRENT TIME +C IAPO(5) 3-HR AP INDEX FOR 9 HRS BEFORE CURRENT TIME C IAPO(6) AVERAGE OF EIGHT 3-HR AP INDICIES FROM 12 TO 33 HRS PRIOR C TO CURRENT TIME C IAPO(7) AVERAGE OF EIGHT 3 HR AP INDICIES FROM 36 TO 57 HRS PRIOR @@ -8984,8 +9079,8 @@ C TO CURRENT TIME c c The 3-hour UT intervals during the day are: (0-3),)3-6),)6-9),)9-12), c )12-15),)15-18),)18-21),)21-24(. -c -c If date is outside the range of the Ap indices file then IAPO(2)=-5 +c +c If date is outside the range of the Ap indices file then IAPO(2)=-5 c----------------------------------------------------------------------- c REAL IAPO @@ -9000,10 +9095,10 @@ c ihour=int(hour/3.)+1 if(ihour.gt.8) ihour=8 - iapo(1)=aap(is,9) + iapo(1)=aap(is,9) C There must be at least 20 indices available - if((is-1)*8+ihour.lt.20) goto 21 + if((is-1)*8+ihour.lt.20) goto 21 C assemble Ap values as needed by MSIS j1=ihour+1 @@ -9031,7 +9126,7 @@ C assemble Ap values as needed by MSIS enddo endif - do 25 i=1,4 + do 25 i=1,4 25 iapo(i+1)=iap(i)*1.0 sum1=0. @@ -9044,7 +9139,7 @@ c iapo(7)=int(sum2/8.+.5) iapo(6)=sum1/8. iapo(7)=sum2/8. goto 20 - + 21 if(mess) write(konsol,100) 100 format(1X,'APFMSIS: No Ap dependence because date is not', & ' covered by APF107.DAT indices file') @@ -9058,26 +9153,26 @@ C SUBROUTINE APF_ONLY(IYYYY,IMN,ID,F107D,F107PD,F107_81,F107_365, * IAPDA,ISDATE) c----------------------------------------------------------------------- -c Finds daily F10.7, daily Ap, and 81-day and 365-day F10.7 index: +c Finds daily F10.7, daily Ap, and 81-day and 365-day F10.7 index: c -c INPUTS: IYYYY (yyyy) year -c IMN (mm) month -c ID (dd) day -c OUTPUT: F107D F10.7 index for the day (adjusted +c INPUTS: IYYYY (yyyy) year +c IMN (mm) month +c ID (dd) day +c OUTPUT: F107D F10.7 index for the day (adjusted c to 1AU) C F107PD F10.7 index for one day prior (used in MSIS) c F107_81 F10.7 average over 3 solar rotations -c (81 days, centered on the current day) +c (81 days, centered on the current day) c F107_365 F10.7 12-month running mean c IAPDA Daily Ap c ISDATE Array-index for the specified date (for c use in APF subroutine. -c +c c Using COMMON/apfa/ for indices c c Is used for vdrift and foeedi. c -c If date is outside the range of indices file than F107D=F107_81=-11.1 +c If date is outside the range of indices file than F107D=F107_81=-11.1 c----------------------------------------------------------------------- INTEGER aap(23000,9),iiap(8),lm(12) @@ -9102,7 +9197,7 @@ c----------------------------------------------------------------------- do i=1,IMN-1 IS=IS+LM(i) ENDDO - + IS=IS+ID ISDATE = IS if(IS.gt.nf107) goto 21 @@ -9116,7 +9211,7 @@ c----------------------------------------------------------------------- if(F107_365.lt.-4.) F107_365=F107D IAPDA=AAP(is,9) goto 20 - + 21 if(mess) write(konsol,100) 100 format(1X,'APF_ONLY: Date is outside range of F10.7D indices', & ' file (F10.7D = F10.7_81 = F10.7RM12).') @@ -9124,10 +9219,10 @@ c----------------------------------------------------------------------- F107_81 = -11.1 F107_365 = -11.1 IAPDA = -11 - + 20 RETURN END -C +C C C----------------------STORM MODEL -------------------------------- C @@ -9136,7 +9231,7 @@ C C This subroutine converts a geographic latitude and longitude C location to a corrected geomagnetic latitude. C -C INPUT: +C INPUT: C geographic latitude -90. to +90. C geographic longitude 0. to 360. positive east from Greenwich. C @@ -9144,7 +9239,7 @@ C OUTPUT: C corrected geomagnetic latitude -90. to +90. - DIMENSION CORMAG(20,91) + DIMENSION CORMAG(20,91) DATA ((CORMAG(i,j),i=1,20),j=1,31)/ +163.68,163.68,163.68,163.68,163.68,163.68, +163.68,163.68,163.68,163.68,163.68,163.68,163.68,163.68, @@ -9381,12 +9476,12 @@ C corrected geomagnetic latitude -90. to +90. +008.15,008.15,008.15,008.15,008.15,008.15,008.15,008.15, +008.15,008.15,008.15,008.15,008.15,008.15/ -C Data Input +C Data Input rlan = rga - rlo = rgo - -C From "normal" geographic latitude -C to angle from South Pole. + rlo = rgo + +C From "normal" geographic latitude +C to angle from South Pole. rla = rlan + 90 IF (rlo .EQ. 360) THEN @@ -9395,31 +9490,31 @@ C to angle from South Pole. C PROXIMITY -C coefficients of the latitudinal points +C coefficients of the latitudinal points LA1 = (INT(rla/2)+1) LA2 = LA1 + 1 if(la2.gt.91) la2=91 -C coefficients of the longitudinal points +C coefficients of the longitudinal points LO1 = (INT(rlo/18)+1) corr LO2 = LO1 + 1 - LO2 = MOD(LO1,20) + 1 + LO2 = MOD(LO1,20) + 1 C Four points of Geomagnetic Coordinates gm1 = CORMAG(LO1,LA1) - gm2 = CORMAG(LO1,LA2) + gm2 = CORMAG(LO1,LA2) gm3 = CORMAG(LO2,LA1) gm4 = CORMAG(LO2,LA2) -C latitudinal points -C X1 = ABS(rla - (INT(rla))) +C latitudinal points +C X1 = ABS(rla - (INT(rla))) C X2 = 2. - X1 x = (rla/2.0 - (INT(rla/2.0))) -C longitudinal points -C Y1 = ABS(rlo - (INT(rlo))) +C longitudinal points +C Y1 = ABS(rlo - (INT(rlo))) C Y2 = 18. - Y1 - y =(rlo/18.0 - (INT(rlo/18.0))) + y =(rlo/18.0 - (INT(rlo/18.0))) C X AND Y VALUES C x = X1 / (X1 + X2) @@ -9431,7 +9526,7 @@ C INTERPOLATION C OUTPUT OF THE PROGRAM C From corrected geomagnetic latitude from North Pole -C to "normal" geomagnetic latitude. +C to "normal" geomagnetic latitude. rgma = 90. - gmla END @@ -9439,7 +9534,7 @@ c c SUBROUTINE STORM(ap,rga,rgo,coor,rgma,ut,doy,cf) C---------------------------------------------------------------------- -C Fortran code to obtain the foF2 storm-time correction factor at +C Fortran code to obtain the foF2 storm-time correction factor at C a given location and time, using the current and the 12 previous C ap values as input. C @@ -9449,9 +9544,9 @@ C in the array will contain the ap at the UT of interest, C the 12th value will contain the 1st three hourly interval C preceeding the time of interest, and so on to the 1st C ap value at the earliest time. -C coor --> (integer). If coor = 2, rga should contain the +C coor --> (integer). If coor = 2, rga should contain the C geomagnetic latitude. -C If coor = 1, rga should contain the +C If coor = 1, rga should contain the C geographic latitude. C rga ---> (real, -90 to 90) geographic or geomagnetic latitude. C rgo ---> (real, 0 to 360, positive east from Greenwich.) @@ -9464,8 +9559,8 @@ C rgma --> corrected magnetic latitude calculated from rga and rgo C C This model and computer code was developed by E. Araujo-Pradere, C T. Fuller-Rowell and M. Condrescu, SEC, NOAA, Boulder, USA -C Ref: -C T. Fuller-Rowell, E. Araujo-Pradere, and M. Condrescu, An +C Ref: +C T. Fuller-Rowell, E. Araujo-Pradere, and M. Condrescu, An C Empirical Ionospheric Storm-Time Ionospheric Correction Model, C Adv. Space Res. 8, 8, 15-24, 2000. C---------------------------------------------------------------------- @@ -9704,31 +9799,31 @@ C C EMPIRICAL STORM-E MODEL: COMPUTES A STORM-TO-QUIET RATIO (SQR) FACTOR C TO ADJUST THE QUIESCENT E-REGION PEAK ELECTRON DENSITY TO ACCOUNT FOR C ENHANCEMENTS DUE TO GEOMAGNETIC ACTIVITY. THE SQR FACTORS WERE -C COMPUTED FROM NO+ 4.3 UM VOLUME EMISSION RATES DERIVED FROM +C COMPUTED FROM NO+ 4.3 UM VOLUME EMISSION RATES DERIVED FROM C TIMED/SABER LIMB RADIANCE MEASUREMENTS. THE SABER-DERIVED SQR FACTORS -C WERE FIT TO POWE-LAW IN THE ap INDEX. +C WERE FIT TO POWE-LAW IN THE ap INDEX. C C INPUT PARAMETERS: C -C JDOY --- DAY OF YEAR (1-365) +C JDOY --- DAY OF YEAR (1-365) C XMLAT --- MAGNETIC LATITUDE (DEGREES) C AP --- ap INDEX C C OUTPUT PARAMETER -C +C C STORME_AP --- STORM-TO-QUIET RATIO (SQR) TO ADJUST QUIESCENT E-REGION C PEAK ELECTRON DENSITY TO ACCOUNT FOR GEOMAGNETIC C ENHANCEMENTS. SQR COMPUTED FROM A POWER-LAW FIT C IN AP-INDEX: SQR=C1*AP**C2+C3 C C REFERENCES: -C +C C (1) Mertens et al. [submitted to JASR, 2011] C (2) Fernandez et al. [JASR, Vol. 46, 2010] C (3) Mertens et al. [Proc. of SPIE, Vol. 7475, 2009] C (4) Mertens et al. [Proc. of SPIE, Vol. 6745, 2007] -C (5) Mertens et al. [JASR, Vol. 39, 2007] -C +C (5) Mertens et al. [JASR, Vol. 39, 2007] +C C SOFTWARE WRITTEN BY Christopher J. Mertens C NASA Langley Research Center C Atmospheric Sciences Competency @@ -9752,7 +9847,7 @@ C C JDOY | 0-79 ||80-171||172-264||265-354||355-365| C DATA ((C1(IML,IDB),IDB=1,NDBD),IML=1,NMLG) - & / 0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-90.0 + & / 0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-90.0 & 0.00000, 0.00000, 0.00000, 0.00000, 0.00000, !-85.0 & 0.00000, 0.00508, 0.17360, 0.00000, 0.00000, !-80.0 & 0.00000, 0.31576, 0.31498, 0.00000, 0.00000, !-75.0 @@ -9788,7 +9883,7 @@ C & 0.06445, 0.00000, 0.00000, 0.10315, 0.06445, ! 75.0 & 0.00149, 0.00000, 0.00000, 0.00073, 0.00149, ! 80.0 & 0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 85.0 - & 0.00000, 0.00000, 0.00000, 0.00000, 0.00000/ ! 90.0 + & 0.00000, 0.00000, 0.00000, 0.00000, 0.00000/ ! 90.0 C C JDOY | 0-79 ||80-171||172-264||265-354||355-365| C @@ -9829,7 +9924,7 @@ C & 0.67340, 0.00000, 0.00000, 0.36809, 0.67340, ! 75.0 & 1.44025, 0.00000, 0.00000, 1.13529, 1.44025, ! 80.0 & 0.00000, 0.00000, 0.00000, 0.00000, 0.00000, ! 85.0 - & 0.00000, 0.00000, 0.00000, 0.00000, 0.00000/ ! 90.0 + & 0.00000, 0.00000, 0.00000, 0.00000, 0.00000/ ! 90.0 C C JDOY | 0-79 ||80-171||172-264||265-354||355-365| C @@ -9872,7 +9967,7 @@ C & 1.00000, 1.00000, 1.00000, 1.00000, 1.00000, ! 85.0 & 1.00000, 1.00000, 1.00000, 1.00000, 1.00000/ ! 90.0 C -C ... Find Season-Averaged Coefficient Index +C ... Find Season-Averaged Coefficient Index C IDXS=0 IF(JDOY.LE.IDBD(1)) IDXS=1 @@ -9884,11 +9979,11 @@ C & 'PROBLEM FINDING SEASON-AVERAGED COEFFICIENT', & 'DAY OF YEAR = ',JDOY STORME_AP=-5.0 - GOTO 222 + GOTO 222 ENDIF C C ... Find Magnetic Latitude Coefficient Index -C +C IDXL=0 DELG=ABS(XMLG(1)-XMLG(2)) DELD=DELG/2.0 @@ -9902,7 +9997,7 @@ C IF((XMLAT.GT.YMM).AND.(XMLAT.LE.YMP)) IDXL=IL ENDDO IF(IDXL.EQ.0) THEN - if(mess) WRITE(konsol,*) 'ERROR IN STORME_AP: ', + if(mess) WRITE(konsol,*) 'ERROR IN STORME_AP: ', & 'PROBLEM FINDING MAGNETIC LATITUDE COEFFICIENT', & 'MAGNETIC LATITUDE(DEGREES) = ',XMLAT STORME_AP=-5.0 @@ -9910,36 +10005,36 @@ C ENDIF C C ... COMPUTE E-REGION ELECTRON DENSITY GEOMAGNETIC STORM ENHANCEMET -C ... FACTOR (i.e., THE STORM-TO-QUIET RATIO (SQR)) +C ... FACTOR (i.e., THE STORM-TO-QUIET RATIO (SQR)) C SQR=C1(IDXL,IDXS)*AP**(C2(IDXL,IDXS))+C3(IDXL,IDXS) IF(SQR.LT.1.0) SQR=1.0 STORME_AP=SQR - + 222 RETURN - END + END C C C**************************************************************************** C subroutine vdrift(xt,xl,param,y) C------------------------------------------------------------------- -C SUBROUTINE CALCULATES EQUATORIAL VERTICAL DRIFT AS DESCRIBED +C SUBROUTINE CALCULATES EQUATORIAL VERTICAL DRIFT AS DESCRIBED C IN SCHERLIESS AND FEJER, JGR, 104, 6829-6842, 1999 C C INPUT: XT: SOLAR LOCAL TIME [h] C XL: GEOGRAPHIC LONGITUDE (+ EAST) [degrees] -C +C C PARAM: 2-DIM ARRAY (DOY,F10.7CM) C DOY :Day of Year has to run from 1 to 365(366) C F10.7cm : F10.7cm solar flux (daily value) -C +C C OUTPUT: Y: EQUATORIAL VERTICAL DRIFT [m/s] C C------------------------------------------------------------------- c IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT REAL (A-H,O-Z) - + c real*8 param(2),coeff(624),coeff1(594),coeff2(30),funct(6) c real*8 xt,xl,y c real*8 bspl4,bspl4_time,bspl4_long @@ -9950,7 +10045,7 @@ c real*8 bspl4,bspl4_time,bspl4_long integer i,j,ind,il,kk integer index_t,dim_t,index_l,dim_l,index,dim,nfunc - + data index_t/13/,dim_t/78/,index_l/8/,dim_l/48/,index/104/, * dim/624/,nfunc/6/ @@ -10061,10 +10156,10 @@ c real*8 bspl4,bspl4_time,bspl4_long * -27.09189,-21.85181,-20.34676, -0.05123, -0.05683, -0.07214, * -27.09561,-22.76383,-25.41151, -0.10272, -0.02058, -0.16720/ - do i=1,594 + do i=1,594 coeff(i)=coeff1(i) enddo - do i=1,30 + do i=1,30 coeff(i+594)=coeff2(i) enddo @@ -10091,7 +10186,7 @@ c real*8 function bspl4_time(i,x1) c ************************************************* c implicit REAL*8 (A-H,O-Z) implicit REAL (A-H,O-Z) - + integer i,order,j,k c real*8 t_t(0:39) c real*8 x,b(20,20),x1 @@ -10138,8 +10233,8 @@ C real function bspl4_long(i,x1) c real*8 function bspl4_long(i,x1) c ************************************************* -c implicit real*8 (A-H,O-Z) - implicit real (A-H,O-Z) +c implicit real*8 (A-H,O-Z) + implicit real (A-H,O-Z) integer i,order,j,k c real*8 t_l(0:24) @@ -10151,7 +10246,7 @@ c real*8 x,b(20,20),x1 * 0,10,100,190,200,250,280,310, * 360,370,460,550,560,610,640,670, * 720,730,820,910,920,970,1000,1030,1080/ - + order=4 x=x1 if(i.ge.0) then @@ -10265,7 +10360,7 @@ c IMPLICIT REAL*8(A-H,O-Z) IMPLICIT REAL(A-H,O-Z) c REAL*8 AE(1:366*24*4),Coff1(1:5,1:9),Coff15(1:6,1:9) REAL AE(1:366*24*4),Coff1(1:5,1:9),Coff15(1:6,1:9) - INTEGER FLAG + INTEGER FLAG DATA Coff1/ @ 0.0124,-0.0168,-0.0152,-0.0174,-0.0704, @ -0.0090,-0.0022,-0.0107, 0.0152,-0.0674, @@ -10298,7 +10393,7 @@ C dAEt_7P5=AE(t)-AE(t-15min); C dAEt_30=AE(t-15)-AE(t-45min); C dAEt_75=AE(t-45)-AE(t-105min); CC -C Following variables are the same to two resolution: +C Following variables are the same to two resolution: C AE1_6=average(AE(1-6hours)); C AE7_12=average(AE(7-12hours)); C AE1_12=average(AE(1-12hours)); @@ -10315,10 +10410,10 @@ C 0.46, AE1_12<70 nT; CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCccccccc C***************************************************** CC FLAG>0--> 1 h time resolution -C**************************************************** +C**************************************************** IF (FLAG.GT.0) THEN -C +C dAEt_30=AE(iP)-AE(iP-1) dAEt_90=AE(iP-1)-AE(iP-2) C @@ -10339,7 +10434,7 @@ C DO i=-7,-12,-1 AEd7_12S=AE(iP+i)-130.0D0 - IF (AEd7_12S.LE.0.0D0) AE7_12S=0.0D0 + IF (AEd7_12S.LE.0.0D0) AEd7_12S=0.0D0 AEd7_12=AEd7_12+AEd7_12S END DO @@ -10358,18 +10453,18 @@ C DO i=-22,-28,-1 AEd22_28S=AE(iP+i)-130.0D0 IF (AED22_28S.LE.0.0D0) AEd22_28S=0.0D0 - AEd22_28=AEd22_28+AEd22_28S + AEd22_28=AEd22_28+AEd22_28S END DO AEd22_28=AEd22_28/7.0D0 AEd22_28P=AEd22_28-200.0D0 IF (AEd22_28P.LE.0.0D0) AEd22_28P=0.0D0 CC - IF (AE1_6.GT.300.0D0) THEN + IF (AE1_6.GT.300.0D0) THEN Alfa=1.0D0 ELSE IF (AE1_6.GT.200.0D0) THEN ALfa=AE1_6/100.0D0-2.0D0 - ELSE + ELSE ALfa=0.0D0 ENDIF CC @@ -10415,7 +10510,7 @@ C******************************************************************** AE1_6=AE1_6/21.0D0 AEd1_6=AEd1_6/21.0D0 CC - AEd7_12=0.0D0 + AEd7_12=0.0D0 DO i=-28,-48,-1 AEd7_12s=AE(iP+i)-130.0 IF (AEd7_12s.LE.0) AEd7_12s=0.0 @@ -10428,7 +10523,7 @@ CC AE1_12=AE1_12+AE(iP+i) END DO AE1_12=AE1_12/45.0D0 -CC +CC AEd22_28=0.0D0 DO i=-88,-112,-1 AEd22_28s=AE(iP+i)-130. @@ -10441,18 +10536,18 @@ CC c AE1_6=0.0D0 c AEd1_6=0.0D0 -c AEd7_12=0.0D0 +c AEd7_12=0.0D0 c AEd22_28P=0.0D0 c AE1_12=0.0D0 c dAEt_7P5=400.D0 c dAEt_30=0.D0 c dAEt_75=0.D0 CC - IF (AE1_6.GT.300.0D0) THEN + IF (AE1_6.GT.300.0D0) THEN Alfa=1.0D0 ELSE IF (AE1_6.GT.200.0D0) THEN ALfa=AE1_6/100.0D0-2.0D0 - ELSE + ELSE ALfa=0.0D0 ENDIF CC @@ -10477,7 +10572,7 @@ CC Vd=PromptVd+DynamoVd ENDIF RETURN - END + END C C real function bspl4_ptime(i,x1) @@ -10527,11 +10622,11 @@ C*************************************************************************** C subroutine spreadf_brazil(idoy,idiy,f107,geolat,osfbr) -********************************************************************** +********************************************************************** * -* SUBROUTINE CALCULATES PERCENTAGE OF SPREAD F OCCURRENCE OVER +* SUBROUTINE CALCULATES PERCENTAGE OF SPREAD F OCCURRENCE OVER * BRAZILIAN SECTOR AS DESCRIBED IN: -* ABDU ET AL., Advances in Space Research, 31(3), +* ABDU ET AL., Advances in Space Research, 31(3), * 703-716, 2003 * * INPUT: @@ -10540,8 +10635,8 @@ C * F107: F10.7 cm SOLAR FLUX (DAILY VALUE) * GEOLAT: BRAZILIAN GEOGRAPHIC LATITUDE BETWEEN -4 AND -22.5 * -* OUTPUT: -* OSFBR(25): PERCENTAGE OF SPREAD F OCCURRENCE FOR 25 TIME +* OUTPUT: +* OSFBR(25): PERCENTAGE OF SPREAD F OCCURRENCE FOR 25 TIME * STEPS FROM LT=18 TO LT=7 ON THE NEXT DAY IN * STEPS OF 0.5 HOURS. * @@ -10549,7 +10644,7 @@ C * dimension param(3),osfbr(25),coef_sfa(684),coef_sfb(684), & sosf(2,32,3,12) - common/mflux/kf,n + common/mflux/kf,n data coef_sfa/ * 0.07,0.13,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.05,0.04,0.03 * ,0.06,0.07,0.02,0.03,0.03,0.07,0.06,0.07,0.21,0.28,0.34,0.16 @@ -10640,7 +10735,7 @@ C * ,0.62,0.59,0.44,0.01,0.00,0.01,0.00,0.00,0.13,0.52,0.77,0.63 * ,0.84,0.67,0.63,0.11,0.00,0.00,0.03,0.03,0.18,0.65,0.75,0.84 * ,0.81,0.63,0.47,0.06,0.02,0.00,0.00,0.05,0.14,0.49,0.76,0.91 - * ,0.58,0.63,0.47,0.09,0.00,0.07,0.01,0.04,0.15,0.48,0.68,0.61 + * ,0.58,0.63,0.47,0.09,0.00,0.07,0.01,0.04,0.15,0.48,0.68,0.61 * ,0.79,0.63,0.55,0.12,0.01,0.01,0.02,0.05,0.13,0.57,0.51,0.63 * ,0.72,0.54,0.43,0.11,0.02,0.00,0.00,0.09,0.16,0.39,0.59,0.72 * ,0.46,0.55,0.39,0.07,0.01,0.03,0.03,0.06,0.15,0.37,0.51,0.50 @@ -10690,24 +10785,24 @@ C do j=1,3 do k=1,12 sosf(1,i,j,k)=0. - sosf(2,i,j,k)=0. + sosf(2,i,j,k)=0. enddo enddo enddo -* +* kc=0 do i=5,23 do j=1,3 do k=1,12 kc=kc+1 sosf(1,i,j,k)=coef_sfa(kc) - sosf(2,i,j,k)=coef_sfb(kc) + sosf(2,i,j,k)=coef_sfb(kc) enddo enddo enddo - - kk=0 - do it=1600,3200,50 + + kk=0 + do it=1600,3200,50 slt=it/100. osft=0. do i=1,23 @@ -10722,19 +10817,19 @@ C do l=1,2 bspl4=bspl4t(i,slt)*bspl2s(j,param(1))* & bspl2l(l,param(3))*bspl2f(m,param(2)) - osft=osft+bspl4*sosf(l,il,ml,jl) + osft=osft+bspl4*sosf(l,il,ml,jl) enddo enddo enddo enddo if(slt.gt.17.98.and.slt.lt.30.01)then kk=kk+1 - osfbr(kk)=osft + osfbr(kk)=osft endif enddo * * - do iii=1,25 + do iii=1,25 if(osfbr(iii).gt.1.) osfbr(iii)=1. if(osfbr(iii).lt.0.) osfbr(iii)=0. enddo @@ -10853,7 +10948,7 @@ C * data ifnodes1 / 78, 77, 75, 79, 80, 77, 78, 80, 76, 81, 78, 78/ data ifnodes2 /144,140,139,142,139,146,142,139,150,151,150,157/ - data ifnodes3 /214,211,201,208,213,220,203,209,213,215,236,221/ + data ifnodes3 /214,211,201,208,213,220,203,209,213,215,236,221/ * ts(0)=ifnodes1(kf) ts(1)=ifnodes2(kf) @@ -10892,10 +10987,10 @@ C C function ckp(ap) C----------------------------------------------------------------------- -C Converts ap index (ap is integer variable varying from 0 to 400) into +C Converts ap index (ap is integer variable varying from 0 to 400) into C kp index (xkp is real variable varying from 0 to 9). Using standard C tables for deriving the 3-hourly ap index from the 3-hourly Kp index -C (e.g., http://www.ngdc.noaa.gov/stp/GEOMAG/kp_ap.shtml) +C (e.g., http://www.ngdc.noaa.gov/stp/GEOMAG/kp_ap.shtml) C----------------------------------------------------------------------- integer ap,ap_array @@ -10903,10 +10998,10 @@ C----------------------------------------------------------------------- dimension ap_array(28),kp_array(28),alap(28) data ap_array /0,2,3,4,5,6,7,9,12,15,18,22,27,32,39,48,56,67, & 80,94,111,132,154,179,207,236,300,400/ - + do 1256 i=2,28 1256 kp_array(i)=(i-1)/3. - + if(ap.eq.0) then ckp=0.0 return @@ -10921,7 +11016,7 @@ C----------------------------------------------------------------------- endif xl_ap=log(ap*1.0) - + i=8 1257 alap(i)=log(ap_array(i)*1.0) if(xl_ap.gt.alap(i)) then @@ -10930,31 +11025,31 @@ C----------------------------------------------------------------------- endif slope=(kp_array(i)-kp_array(i-1))/(alap(i)-alap(i-1)) - + ckp = kp_array(i) + slope * (xl_ap - alap(i)) - + return end -C -C +C +C subroutine auroral_boundary(xkp,xmlt,cgmlat,ab_mlat) C----------------------------------------------------------------------- C Computes equatorward auroral boundary values for givern kp value. -C kp given in units of 0.1 (xkp) for the range from 0.0 to 9.0. Model +C kp given in units of 0.1 (xkp) for the range from 0.0 to 9.0. Model C values are only used for kp=0,1,2,3,4,5,6,7,8,9 and a linear inter- C polation is applied for intermediate kp values. -C -C The auroral oval boundary is given as an array for corrected magnetic -C latitude CGM (ab_mlat). The 48 values correspond to the MLT values +C +C The auroral oval boundary is given as an array for corrected magnetic +C latitude CGM (ab_mlat). The 48 values correspond to the MLT values C of 0.0,0.5,1.0,1.5,2.0 .. 23.5. If the input xmlt is greater than -C -1, then the program determines the CGM latitude, cgmlat, that +C -1, then the program determines the CGM latitude, cgmlat, that C corresponds to the given MLT value (xmlt). C -C Y. Zhang and L.J. Paxton, An empirical Kp-dependent global auroral -C model based on TIMED/GUVI FUV data, Journal of Atmospheric and +C Y. Zhang and L.J. Paxton, An empirical Kp-dependent global auroral +C model based on TIMED/GUVI FUV data, Journal of Atmospheric and C Solar-Terrestrial Physics 70, 1231–1242, 2008. -C -C----------------------------------------------------------------------- +C +C----------------------------------------------------------------------- dimension zp_mlat(48,10),ab_mlat(48),ab_mlt(48) @@ -11000,34 +11095,34 @@ C----------------------------------------------------------------------- * 57.4,56.1,54.9,54.1,53.5,52.8,51.8,50.8,50.1,49.7,49.8,50.4, * 50.9,50.9,50.3,49.7,49.3,49.2,49.3,49.4,49.5,49.6,49.8,50.2/ - + if(xkp.gt.9.0) xkp=9.0 kp1=int(xkp)+1 xkp1=int(xkp)*1.0 kp2=kp1+1 if(kp2.gt.10) kp2=10 - do i=1,48 + do i=1,48 ab_mlat(i)=zp_mlat(i,kp1)+(xkp-xkp1)* & (zp_mlat(i,kp2)-zp_mlat(i,kp1)) enddo - + cgmlat=-99.99 if(xmlt.lt.0.0) return - - do i=1,48 + + do i=1,48 ab_mlt(i)=(i-1)*.5 enddo i1=int(xmlt/0.5)+1 if(i1.ge.48) i1=1 i2=i1+1 - + s1=(zp_mlat(i2,kp1)-zp_mlat(i1,kp1))/(ab_mlt(i2)-ab_mlt(i1)) zmlkp1=zp_mlat(i1,kp1)+(xmlt-ab_mlt(i1))*s1 s2=(zp_mlat(i2,kp2)-zp_mlat(i1,kp2))/(ab_mlt(i2)-ab_mlt(i1)) zmlkp2=zp_mlat(i1,kp2)+(xmlt-ab_mlt(i1))*s2 - + cgmlat=zmlkp1+(xkp-xkp1)*(zmlkp2-zmlkp1) return end diff --git a/iri2016/src/irisub.for b/iri2016/src/irisub.for index 5585d75..e9358a4 100644 --- a/iri2016/src/irisub.for +++ b/iri2016/src/irisub.for @@ -1,20 +1,20 @@ c irisub.for, version number can be found at the end of this comment. c----------------------------------------------------------------------- -C Includes subroutines IRI_SUB and IRI_WEB to compute IRI parameters -C for specified location, date, time, and altitude range and subroutine +C Includes subroutine IRI_SUB to compute IRI parameters for specified +C location, date, time, and altitude range and subroutine and subroutine C IRI_WEB to computes IRI parameters for specified location, date, time C and variable range; variable can be altitude, latitude, longitude, C year, month, day of month, day of year, or hour (UT or LT). C IRI_WEB requires IRI_SUB. Both subroutines require linking with the -c following library files IRIFUN.FOR, IRITEC.FOR, IRIDREG.FOR, -c CIRA.FOR, IGRF.FOR +c following files: IRIFUN.FOR, IRITEC.FOR, IRIDREG.FOR, +c IRIFLIP.FOR CIRA.FOR, IGRF.FOR c----------------------------------------------------------------------- c Programs using subroutine IRI_SUB need to include (see IRITEST.FOR): c c call read_ig_rz c call readapf107 c -c Programs using subroutineIRI_WEB need to include (see IRITEST.FOR): +c Programs using subroutine IRI_WEB need to include (see IRITEST.FOR): c c do i=1,100 c oar(i,1)=-1.0 @@ -134,48 +134,65 @@ C 2012.03 02/13/13 Move B1 before B0 for Gulyaeva-1987 C 2012.03 02/20/13 Use foot-point for CGM to be closer to AACGM C 2012.03 02/20/13 DAT(11,*) is UT time of MLT=0 C 2012.04 09/12/13 Replace HOUR with HOURUT in APFMSIS ---- P. Coisson -C 2014.00 01/22/14 TMAXN in GTD7 SEC->SECNI HOUR->0.0 -C 2014.01 07/17/14 Change estromcor to estormcor -------- A.Shabanloui -C 2014.02 07/24/14 COMMON/iounit/: added 'mess' -C 2014.03 09/18/14 JF(18): FIELDG not UT_LT ............... A.Mazzella -C 2014.03 09/18/14 jf(12)&jf(34): create messages.txt ..... A.Mazzella -C 2014.03 09/18/14 change: icalls.gt.1 to icalls.ge.1 .... A.Mazzella -C 2014.03 09/24/14 added oarr(85)=L and oarr(86)=DIMO -C 2014.04 11/26/14 reading INDAP the first time -C 2014.05 12/22/14 COMMON/CSW/, ISW=0, SW(9)=-1 or =0 (no Ap depend.) -C 2015.01 07/12/15 adapting calls for TCON,APF,APF_ONLY,APFMSIS -C 2015.02 08/13/15 moving SWMI(25) from DATA into program -C 2015.02 08/13/15 add PI to COMMON/CONST; delete COMMON/CONST2 -C 2015.02 08/23/15 Earth parameters now initialized in IRI_SUB -C 2015.03 09/14/15 JF(41)=t COV=F10.7_12, =f COV=f(IG12) -C 2015.03 09/16/15 observed F10.7 for GTD7 and CHEMION -C 2015.03 09/28/15 Calculate invdip parameter only once for 600 km -C 2015.03 09/30/15 hmF2: AMTB-2013 and SHU-2015 models; JF(39:40) -C 2015.03 09/30/15 revised ELTEIK and CALION calls -C 2015.03 10/14/15 added FELDCOF call for CLCMLT .......... M.Hausman -C 2015.03 10/14/15 COMMON/IGRF1/...,DIMO -C 2016.01 02/01/16 if(hef.le.hme) no F1 and no valley .... M.Hausman -C 2016.02 06/01/16 User-specified B0 when jf(43)=false -C 2016.03 08/15/16 Corrected input of F10.7D,Y,81, and 365..M.Hausman -C 2016.03 08/15/16 ITOPN=3(Gulyaeva topside) not yet active M.Hausman -C 2016.04 09/08/16 CHEMION call now with n(H) input -C 2016.04 09/08/16 Replace SDMF2 with model_hmF2 (Shubin) -C 2016.05 09/22/16 COMMON: NmF2s,NmEs (STORM foF2, foE for profile) -C 2016.06 10/20/16 IG12_in->R12=f(IG12_in), R12_in->IG12=f(R12_in) -C 2016.06 10/20/16 F10.7_81_in -> F10.7_365 = F10.7_81_in -C 2017.01 01/26/17 B1 user input; 0.6 F10.7_81=F10.7Din -C 2017.04 10/27/17 F10.7_81in and not F10.7Din -> F10.7D=F10.7_81in -C 2017.05 10/30/17 OARR(87,88)=SAX300,SUX300 -C 2018.01 03/22/18 f107in, f107ino, f107_81in, f107_81ino M. Butala -C 2018.01 03/22/18 f107yo -> f107yobs, f10781o -> f10781obs -C 2018.01 03/22/18 invdip_old for Te elteik() ........... V. Truhlik -C 2018.01 03/22/18 ELTEIK and CALION use PF107OBS ....... V. Truhlik +C 2012.05 01/22/14 TMAXN in GTD7 SEC->SECNI HOUR->0.0 +C 2012.06 07/17/14 Change estromcor to estormcor -------- A.Shabanloui +C 2012.07 07/24/14 COMMON/iounit/: added 'mess' +C 2012.08 09/18/14 JF(18): FIELDG not UT_LT ............... A.Mazzella +C 2012.08 09/18/14 jf(12)&jf(34): create messages.txt ..... A.Mazzella +C 2012.08 09/18/14 change: icalls.gt.1 to icalls.ge.1 .... A.Mazzella +C 2012.09 09/24/14 added oarr(85)=L and oarr(86)=DIMO +C 2012.10 11/26/14 reading INDAP the first time +C 2012.11 12/22/14 COMMON/CSW/, ISW=0, SW(9)=-1 or =0 (no Ap depend.) +C 2012.12 07/12/15 adapting calls for TCON,APF,APF_ONLY,APFMSIS +C +C 2016.01 08/13/15 moving SWMI(25) from DATA into program +C 2016.01 08/13/15 add PI to COMMON/CONST; delete COMMON/CONST2 +C 2016.01 08/23/15 Earth parameters now initialized in IRI_SUB +C 2016.02 09/14/15 JF(41)=t COV=F10.7_12, =f COV=f(IG12) +C 2016.03 09/16/15 observed F10.7 for GTD7 and CHEMION +C 2016.04 09/28/15 Calculate invdip parameter only once for 600 km +C 2016.05 09/30/15 hmF2: AMTB-2013 and SHU-2015 models; JF(39:40) +C 2016.05 09/30/15 revised ELTEIK and CALION calls +C 2016.06 10/14/15 added FELDCOF call for CLCMLT .......... M.Hausman +C 2016.06 10/14/15 COMMON/IGRF1/...,DIMO +C 2016.07 02/01/16 if(hef.le.hme) no F1 and no valley .... M.Hausman +C 2016.08 06/01/16 User-specified B0 when jf(43)=false +C 2016.09 08/15/16 Corrected input of F10.7D,Y,81, and 365..M.Hausman +C 2016.09 08/15/16 ITOPN=3(Gulyaeva topside) not yet active M.Hausman +C 2016.10 09/08/16 CHEMION call now with n(H) input +C 2016.10 09/08/16 Replace SDMF2 with model_hmF2 (Shubin) +C 2016.11 09/22/16 COMMON: NmF2s,NmEs (STORM foF2, foE for profile) +C 2016.12 10/20/16 IG12_in->R12=f(IG12_in), R12_in->IG12=f(R12_in) +C 2016.12 10/20/16 R12=f_Gulyaeva(IG12_in), IG12=f_Gulyaeva(R12_in) +C 2016.12 10/20/16 F10.7_81_in -> F10.7_365 = F10.7_81_in +C 2016.13 01/26/17 B1 user input; 0.6 F10.7_81=F10.7Din +C 2016.16 10/27/17 F10.7_81in and not F10.7Din -> F10.7D=F10.7_81in +C 2016.17 10/30/17 OARR(87,88)=SAX300,SUX300 +C 2016.18 03/22/18 f107in, f107ino, f107_81in, f107_81ino M. Butala +C 2016.18 03/22/18 f107yo -> f107yobs, f10781o -> f10781obs +C 2016.18 03/22/18 invdip_old for Te elteik() ........... V. Truhlik +C 2016.18 03/22/18 ELTEIK and CALION use PF107OBS ....... V. Truhlik +C 2016.19 03/28/18 OAR(1:100)=-1 corrected +C 2016.20 04/23/18 Versioning now based on year of major releases +C 2016.21 04/25/18 Moved secni to Te calculation .......... C. Vasly +C 2016.21 04/25/18 Deleted arrays ddo and d2o; not used ... C. Vasly +C 2016.22 08/23/18 CNEW! B0-Gulyaeva option revised .... T. Gulyaeva +C 2016.23 08/27/18 Moved FIRI option under ELDE calc ..... P. Sultan +C 2016.23 08/27/18 3-h ap,kp available even if storm models are off +C 2016.23 08/27/18 daily ap avail. even if F10.7din or F10.7_81in +C 2016.24 08/29/18 user input for HNEA and HNEE if jf(45) jf(46) +C 2016.25 06/11/19 comments for OARR and output incl HNEA and HNEE +C 2020.01 07/03/19 changed argmax to 87.3 (consistent with IDL) +C 2020.01 07/03/19 itopn=1 now with PF10.7 correction +C 2020.02 07/19/19 itopn=1 cor option, itopn=3 cor2 option +C 2020.03 07/29/19 added 'endif' itopn=3 and declared a01(2,2) +C 2020.04 08/05/19 itopn=3 requires itopn=1, BLO11 change +C 2020.05 01/16/20 ion composition topside if h.ge.300km C - C***************************************************************** C********* INTERNATIONAL REFERENCE IONOSPHERE (IRI). ************* C***************************************************************** @@ -194,8 +211,8 @@ C IYYYY Year as YYYY, e.g. 1985 C MMDD (-DDD) DATE (OR DAY OF YEAR AS A NEGATIVE NUMBER) C DHOUR LOCAL TIME (OR UNIVERSAL TIME + 25) IN DECIMAL C HOURS -C HEIBEG, HEIGHT RANGE IN KM; maximal 1000 heights, i.e. -C HEIEND,HEISTP int((heiend-heibeg)/heistp)+1.le.1000 +C HEIBEG, HEIGHT RANGE IN KM; maximal 100 heights, i.e. +C HEIEND,HEISTP int((heiend-heibeg)/heistp)+1.le.100 C C JF switches to turn off/on (.true./.false.) several options C @@ -232,7 +249,7 @@ C 27 IG12 from file IG12 - user t C 28 spread-F probability not computed false C 29 IRI01-topside new options as def. by JF(30) false C 30 IRI01-topside corr. NeQuick topside model false -C (29,30) = (t,t) IRIold, (f,t) IRIcor, (f,f) NeQuick +C (29,30) = (t,t) IRIold, (f,t) IRIcor, (f,f) NeQuick, (t,f) IRIcor2 C 31 B0,B1 ABT-2009 B0 Gulyaeva-1987 h0.5 t C (4,31) = (t,t) Bil-00, (f,t) ABT-09, (f,f) Gul-87, (t,f) not used C 32 F10.7_81 from file F10.7_81 - user input (oarr(46)) t @@ -244,11 +261,13 @@ C 37 topside w/out foF2-storm with foF2-storm t C 38 turn WRITEs off in IRIFLIP turn WRITEs on t C 39 hmF2 (M3000F2) new models false C 40 hmF2 AMTB-model Shubin-COSMIC model t +C (39,40) = (t,t) hmF2-old, (f,t) AMTB, (f,f) Shubin, (t,f) not used C 41 Use COV=F10.7_365 COV=f(IG12) (IRI before Oct 2015) t C 42 Te with PF10.7 dep. w/o PF10.7 dependance t -C 43 B0 from model B0 user input t -C 44 B1 from model B1 user input t -C 45 +C 43 B0 from model B0 user input in OARR(10) t +C 44 B1 from model B1 user input in OARR(35) t +C 45 HNEA=65/80km dya/night HNEA user input in OARR(89) t +C 46 HNEE=2000km HNEE user input in OARR(90) t C .... C 50 C ------------------------------------------------------------------ @@ -270,8 +289,11 @@ C jf(16) =.false. OARR(6)=user input for hmE/km C jf(17) =.flase. OARR(33)=user input for Rz12 C jf(25) =.false. OARR(41)=user input for daily F10.7 index C jf(27) =.false. OARR(39)=user input for IG12 +C jf(32) =.false. OARR(46)=user input for 81-day avg F10.7 C jf(43) =.false. OARR(10)=user input for B0 -C jf(44) =.false. OARR(87)=user input for B1 +C jf(44) =.false. OARR(35)=user input for B1 +C jf(45) =.false. OARR(89)=user input for HNEA (Ne lower boundary) +C jf(46) =.false. OARR(90)=user input for HNEE (Ne upper boundary) C C C OUTPUT: OUTF(1:20,1:1000) @@ -344,8 +366,11 @@ C OARR(79) = CGM-lati(MLT=20) OARR(80) = CGM-lati for MLT=21 C OARR(81) = CGM-lati(MLT=22) OARR(82) = CGM-lati for MLT=23 C OARR(83) = Kp at current time OARR(84) = magnetic declination C OARR(85) = L-value OARR(86) = dipole moment +C OARR(87) = SAX300 OARR(88) = SUX300 +C #OARR(89) = HNEA #OARR(90) = HNEE C # INPUT as well as OUTPUT parameter C $ special for IRIWeb (only place-holders) +C for more details got to end of subroutine c----------------------------------------------------------------------- C***************************************************************** C*** THE ALTITUDE LIMITS ARE: LOWER (DAY/NIGHT) UPPER *** @@ -391,7 +416,7 @@ c CHARACTER FILNAM*53 & STTE(6),DTE(5),ATE(7),TEA(6),XNAR(2),param(2), & DDO(4),DO2(2),DION(7), & osfbr(25),D_MSIS(9),T_MSIS(2),IAPO(7),SWMI(25),ab_mlat(48), - & DAT(11,4), PLA(4), PLO(4) + & DAT(11,4), PLA(4), PLO(4), a01(2,2) LOGICAL EXT,SCHALT,TECON(2),sam_mon,sam_yea,sam_ut,sam_date, & F1REG,FOF2IN,HMF2IN,URSIF2,LAYVER,RBTT,DREG,rzino,FOF1IN, @@ -401,8 +426,6 @@ c CHARACTER FILNAM*53 & fof2ino,hmf2ino,f107in,f107ino,f107_81in,f107_81ino COMMON /CONST/UMR,PI /const1/humr,dumr /ARGEXP/ARGMAX -c & /const2/icalls,montho,nmono,iyearo,idaynro,ursifo,rzino, -c & igino,ut0 & /IGRF1/ERA,AQUAD,BQUAD,DIMO & /BLOCK1/HMF2,NMF2S,HMF1,F1REG /BLOCK2/B0,B1,C1 & /BLOCK3/HZ,T,HST /BLOCK4/HME,NMES,HEF @@ -411,7 +434,8 @@ c & igino,ut0 & /BLOCK8/HS,TNHS,XSM,MM,DTI,MXSM & /BLOTE/AHH,ATE1,STTE,DTE & /BLO10/BETA,ETA,DELTA,ZETA /findRLAT/FLON,RYEAR - & /BLO11/B2TOP,TC3,itopn,alg10,hcor1 +c & /BLO11/B2TOP,TC3,itopn,alg10,hcor1,tcor2 + & /BLO11/B2TOP,itopn,tcor & /iounit/konsol,mess /CSW/SW(25),ISW,SWC(25) & /QTOP/Y05,H05TOP,QF,XNETOP,XM3000,HHALF,TAU @@ -438,7 +462,7 @@ c set switches for NRLMSIS00 do 7397 kk=1,nummax 7397 OUTF(KI,kk)=-1. C -C oarr(1:6,15,16,33,39:41) is used for inputs +C oarr(1:6,10,15,16,33,35,39,41,46,89,90) are used for inputs C oarr(7)=-1. oarr(8)=-1. @@ -451,14 +475,16 @@ C do 8478 kind=36,38,1 8478 oarr(kind)=-1. oarr(40)=-1. - do 8428 kind=42,100,1 -8428 if(kind.ne.46) oarr(kind)=-1. + do 8428 kind=42,88,1 +8428 if(kind.ne.46) oarr(kind)=-1. + do 8429 kind=91,100,1 +8429 oarr(kind)=-1. C C PROGRAM CONSTANTS AND INITIALIZATION C if(icalls.lt.1) then - ARGMAX=88.0 + ARGMAX=87.3 pi=ATAN(1.0)*4. UMR=pi/180. humr=pi/12. @@ -518,12 +544,6 @@ C DNDS(2)=.01 DNDS(3)=.016 DNDS(4)=.016 - DDO(1)=9 - DDO(2)=5 - DDO(3)=5 - DDO(4)=25 - DO2(1)=5 - DO2(2)=5 XNAR(1)=0.0 XNAR(2)=0.0 DTE(1)=5. @@ -593,21 +613,30 @@ c else oarr(46)=-1. ENDIF - + IF(jf(45)) THEN + HNEA=65 + else + HNEA=oarr(89) + ENDIF + IF(jf(46)) THEN + HNEE=2000 + else + HNEE=oarr(90) + ENDIF c c Topside density .................................................... c if(jf(29)) then -c if (jf(30)) then - itopn=0 -c else -c itopn=3 ! Gulyaeva topside option -c endif + if (jf(30)) then + itopn=0 ! IRI2001 topside option + else + itopn=3 ! IRI-cor2 topside option + endif else if (jf(30)) then - itopn=1 + itopn=1 ! IRI-cor topside option else - itopn=2 + itopn=2 ! NeQuick topside option endif endif c @@ -724,7 +753,7 @@ c if (itopn.eq.0) write(konsol,9207) if (itopn.eq.1) write(konsol,9204) if (itopn.eq.2) write(konsol,9205) -c if (itopn.eq.3) write(konsol,9206) + if (itopn.eq.3) write(konsol,9206) if(FOF2IN) then write(konsol,9015) goto 2889 @@ -799,9 +828,9 @@ c if (itopn.eq.3) write(konsol,9206) & ' Erroneous profile features can occur.') 9014 format('Ne: No upper limit for F10.7 in', & ' topside formula.') -9204 format('Ne: Corrected Topside Formula') +9204 format('Ne: IRI-cor for Topside') 9205 format('Ne: NeQuick for Topside') -9206 format('Ne: Gul-h0.5 for Topside') +9206 format('Ne: IRI-cor2 for Topside') 9207 format('Ne: IRI-2001 for Topside') 9214 format('Ne: B0,B1 Bil-2000') 9215 format('Ne: B0 Gul-1987') @@ -881,7 +910,6 @@ C MLAT, MLONG), MAGNETIC INCLINATION (DIP), DIP LATITUDE (MAGBR) C AND MODIFIED DIP (MODIP), ALL IN DEGREES C - IF(JMAG.GT.0) THEN MLAT=ALATI MLONG= modulo(ALONG, 360.) @@ -1027,9 +1055,9 @@ C observed (at the ground) value. f107y=cov f10781=cov f107365=cov + call APF_ONLY(iyear,month,iday,F107_daily,F107PD,F107_81, + & F107_365,IAP_daily,isdate) if(.not.f107in.or..not.f107_81in) then - call APF_ONLY(iyear,month,iday,F107_daily,F107PD,F107_81, - & F107_365,IAP_daily,isdate) if(F107_daily.gt.-11.1) then f107d=f107_daily f107y=f107PD @@ -1119,9 +1147,7 @@ C lower height boundary (HNEA), upper boundary (HNEE) C 1334 continue - HNEA=65. - IF(DNIGHT) HNEA=80. - HNEE=2000. + IF(JF(45).and.DNIGHT) HNEA=80. IF(NODEN) GOTO 4933 DELA=4.32 @@ -1209,6 +1235,10 @@ C GOTO 4291 +8448 WRITE(konsol,8449) FILNAM +8449 FORMAT(1X////, + & ' The file ',A30,'is not in your directory.') + GOTO 3330 C C LINEAR INTERPOLATION IN SOLAR ACTIVITY. IG12 used for foF2 C @@ -1268,10 +1298,17 @@ c estormcor=-1. fstorm_on=jf(26).and.jf(8) estorm_on=jf(35).and.jf(15) - if(fstorm_on.or.jf(33).or.estorm_on) then +c if(fstorm_on.or.jf(33).or.estorm_on) then c if(.not.sam_date.or..not.sam_ut) then - call apf(isdate,hourut,indap) - endif + call apf(isdate,hourut,indap) +c endif +c endif + index_3h_ap=indap(13) + if(index_3h_ap.gt.-1) then + xkp=ckp(index_3h_ap) + else + xkp=3.0 + endif c c stormtime updating for foF2 (foF2s, NmF2s) @@ -1287,8 +1324,8 @@ c c c stormtime updating for foE (foEs, NmEs) c - if(estorm_on.and.(indap(1).gt.-1)) then - estormcor=STORME_AP(DAYNR,MLAT,INDAP(13)*1.0) + if(estorm_on.and.(index_3h_ap.gt.-1)) then + estormcor=STORME_AP(DAYNR,MLAT,index_3h_ap*1.0) if(estormcor.gt.-2.0) foes=foe*estormcor NMES=1.24E10*FOES*FOES endif @@ -1296,11 +1333,6 @@ c c calculation of equatorward auroral boundary c if(jf(33)) then - if(indap(1).gt.-1) then - xkp=ckp(indap(13)) - else - xkp=3.0 - endif c Corrected magnetic latitude CGM of equatorward boundary, c ab_mlat(48), for MLT=0.0,0.5,1.0 ... 23.5 h and kp=xkp call auroral_boundary(xkp,-1.0,cgmlat,ab_mlat) @@ -1313,10 +1345,8 @@ c cgm_mlt00_ut=DAT(11,1) cgm_lat=DAT(3,3) cgm_lon=DAT(4,3) cgm_mlt00_ut=DAT(11,3) -c print*,lati,longi,mlat,cgm_lat,cgm_lon cgm_mlt=hourut-cgm_mlt00_ut if(cgm_mlt.lt.0.) cgm_mlt=24.+hourut-cgm_mlt00_ut -c print*,cgm_mlt c cgm_mlt_ut=DAT(11,1) c cgm_mlt=cgm_mlt_ut+cgm_lon/15. c if(cgm_mlt.gt.24.) cgm_mlt=cgm_mlt-24. @@ -1419,7 +1449,7 @@ c c Correction term for topside (Bilitza) depends on modip, hour, c sax300, sux300, and hmF2 c - if(itopn.eq.1) then + if(itopn.eq.1.or.itopn.eq.3) then zmp1 = exp(modip / 10.) zmp11 = 1. + zmp1 zmp111 = zmp1 / (zmp11 * zmp11) @@ -1475,7 +1505,7 @@ c CALL SHAB1D (LATI,FLON,ZMONTH,RSSN,B1) else CALL ROGUL(SEADAY,XHI3,SEAX,GRAT) - IF (FNIGHT) GRAT = 0.91D0 - HMF2/4000.D0 +cnew! IF (FNIGHT) GRAT = 0.91D0 - HMF2/4000.D0 B1=HPOL(HOUR,1.9,2.6,SAX200,SUX200,1.,1.) BCOEF = B1*(B1*(0.0046D0*B1-0.0548D0)+0.2546D0) + 0.3606D0 B0CNEW = HMF2*(1.D0-GRAT) @@ -1760,21 +1790,6 @@ C CALL GTD7(IYD,SEC,HEQUI,LATI,LONGI,HOUR,F10781OBS, & F107YOBS,IAPO,0,D_MSIS,T_MSIS) TN120=T_MSIS(2) - IF(HOUR.NE.0.0) THEN -C if(jf(18)) then - secni=(24.-longi/15)*3600. -C else -C iyz=iyear -C idz=daynr -C call ut_lt(1,utni,0.0,longi,iyz,idz) -C secni=utni*3600. -C endif - CALL GTD7(IYD,SECNI,HEQUI,LATI,LONGI,0.0,F10781OBS, - & F107YOBS,IAPO,0,D_MSIS,T_MSIS) - TN1NI=T_MSIS(2) - ELSE - TN1NI=T_MSIS(2) - ENDIF C C--------- CALCULATION OF ELECTRON TEMPERATURE PARAMETER-------- @@ -1793,6 +1808,7 @@ C Te-MAXIMUM based on JICAMARCA and ARECIBO data HMAXN=150. AHH(2)=HPOL(HOUR,HMAXD,HMAXN,SAX200,SUX200,1.,1.) TMAXD=800.*EXP(-(MLAT/33.)**2)+1500. + secni=(24.-longi/15)*3600. CALL GTD7(IYD,SECNI,HMAXN,LATI,LONGI,0.0,F10781OBS, & F107YOBS,IAPO,0,D_MSIS,T_MSIS) TMAXN=T_MSIS(2) @@ -1837,11 +1853,9 @@ c Te at fixed heights 350, 550, 850, 1400, and 2000 km AHH(6)=1400. AHH(7)=2000. hte=2500 +c isa for solar activity correction: isa=0 sol activity corr off isa=0 if(jf(42)) isa=1 -c icd=1 ! compute INVDIP -c isa=0 ! solar activity correction off -c ise=0 ! season correction off do ijk=3,7 c call igrf_sub(lati,longi,ryear,ahh(ijk), c & xl,icode,dipl,babs) @@ -1995,13 +2009,18 @@ C ELEDE=XE_1(HEIGHT) c -c electron density in m-3 in outf(1,*) +c FIRI D region c + if(.not.dreg.and.height.le.140.) then + elede=-1. + call F00(HEIGHT,LATI,DAYNR,XHI,F107D,EDENS,IERROR) + if(ierror.eq.0.or.ierror.eq.2) elede=edens + endif OUTF(1,kk)=ELEDE c -c plasma temperatures +c plasma temperatures in Kelvin c 330 IF(NOTEM) GOTO 7108 @@ -2038,13 +2057,8 @@ c RO2X=-1. RCLUST=-1. if(RBTT) then - if (height.gt.300.) then + if (height.ge.300.) then c Triskova-Truhlik-Smilauer-2003 model -c call igrf_sub(lati,longi,ryear,height, -c & xl,icode,dipl,babs) -c if(xl.gt.10.) xl=10. -c call CALION(1,xinvdip,xl6,dimo,babs6,dipl6,xmlt, -c & height,daynr,f107d,xic_O,xic_H,xic_He,xic_N) call CALION(invdip,xmlt,height,daynr,pf107obs, & xic_O,xic_H,xic_He,xic_N) rox=xic_O*100. @@ -2105,18 +2119,7 @@ c OUTF(10,kk)=RCLUST*xnorm OUTF(11,kk)=RNX*xnorm -c -c D region special: Friedrich&Torkar model in outf(13,*) -c - -7118 if(.not.dreg.and.height.le.140.) then - outf(1,kk)=-1. - call F00(HEIGHT,LATI,DAYNR,XHI,F107D,EDENS,IERROR) - if(ierror.eq.0.or.ierror.eq.2) outf(1,kk)=edens - endif - - - height=height+heistp +7118 height=height+heistp kk=kk+1 if(kk.le.numhei) goto 300 @@ -2179,82 +2182,92 @@ c if(ispf.gt.0.and.ispf.lt.26) spreadf=osfbr(ispf) 1937 continue C -C ADDITIONAL PARAMETER FIELD OARR +C ADDITIONAL PARAMETER FIELD OARR: angles are given in degrees, +C times in decimal hours, altitudes in km, densities in m-3, and +C temperatures in K C IF(NODEN) GOTO 6192 - OARR(1)=NMF2S - OARR(2)=HMF2 + OARR(1)=NMF2S ! F2-peak density in m-3 + OARR(2)=HMF2 ! F2-peak height in km if(f1reg) OARR(3)=NMF1 if(f1reg) OARR(4)=XHMF1 - OARR(5)=NMES - OARR(6)=HME - OARR(7)=NMD - OARR(8)=HMD - OARR(9)=HHALF - OARR(10)=B0 - OARR(11)=VNER - OARR(12)=HEF + OARR(5)=NMES ! E-peak density in m-3 + OARR(6)=HME ! E-peak height in km + OARR(7)=NMD ! density in m-3 of D-region inflection point + OARR(8)=HMD ! height in km of D-region inflection point + OARR(9)=HHALF ! height used by Gulyaeva B0 model + OARR(10)=B0 ! bottomside thickness parameter in km + OARR(11)=VNER ! density in m-3 at E-valley bottom + OARR(12)=HEF ! height in km of E-valley top (Ne(HEF)=NmE) 6192 IF(NOTEM) GOTO 6092 - OARR(13)=ATE(2) - OARR(14)=AHH(2) - OARR(15)=ATE(3) - OARR(16)=ATE(4) - OARR(17)=ATE(5) - OARR(18)=ATE(6) - OARR(19)=ATE(7) - OARR(20)=ATE(1) - OARR(21)=TI1 - OARR(22)=XTETI -6092 OARR(23)=XHI3 - OARR(24)=SUNDEC - OARR(25)=DIP - OARR(26)=MAGBR - OARR(27)=MODIP - OARR(28)=LATI - OARR(29)=SAX200 - OARR(30)=SUX200 - OARR(31)=SEASON - OARR(32)=LONGI - OARR(33)=rssn - OARR(34)=COV - OARR(35)=B1 - OARR(36)=xm3000 + OARR(13)=ATE(2) ! electron temperature Te in K at AHH(2) + OARR(14)=AHH(2) ! intermediate height between 120km and 300/350km + OARR(15)=ATE(3) ! Te at 300km/350km for BIL-1995/TBT2012+SA model + OARR(16)=ATE(4) ! Te at 400km/550km for BIL-1995/TBT2012+SA model + OARR(17)=ATE(5) ! Te at 600km/850km for BIL-1995/TBT2012+SA model + OARR(18)=ATE(6) ! Te at 1400km/1400km for BIL-1995/TBT2012+SA model + OARR(19)=ATE(7) ! Te at 3000km/2000km for BIL-1995/TBT2012+SA model + OARR(20)=ATE(1) ! Te at 120km = neutral temperature from CIRA + OARR(21)=TI1 ! ion temperature in K at 430km + OARR(22)=XTETI ! altitude where Te=Ti +6092 OARR(23)=XHI3 ! solar zenith angle at 200 km + OARR(24)=SUNDEC ! sun declination + OARR(25)=DIP ! IGRF magnetic inclination (dip) + OARR(26)=MAGBR ! IGRF dip latitude + OARR(27)=MODIP ! modified dip latitude + OARR(28)=LATI ! geographic latitude + OARR(29)=SAX200 ! time of sunrise at 200 km + OARR(30)=SUX200 ! time of sunset at 200 km + OARR(31)=SEASON ! =1 spring, 2= summer .. +c SEASON assumes equal length seasons (92 days) with spring +c (SEASON=1) starting at day-of-year=45 + OARR(32)=LONGI ! geographic longitude + OARR(33)=rssn ! 12-month running mean of sunspot number + OARR(34)=COV ! 12-month running mean of F10.7 + OARR(35)=B1 ! Bottomside shape parameter + OARR(36)=xm3000 ! Propagation factor M(3000)F2 C OARR(37) used for TEC and 38 for TEC-top - OARR(39)=gind - OARR(40)=f1pb - OARR(41)=f107d - OARR(42)=c1 - OARR(43)=daynr - OARR(44)=drift - OARR(45)=stormcorr - OARR(46)=f10781 - OARR(47)=estormcor - OARR(48)=spreadf - OARR(49)=MLAT - OARR(50)=MLONG - OARR(51)=indap(13)*1.0 ! ap for current UT - OARR(52)=IAP_daily*1.0 ! daily ap - OARR(53)=invdip - OARR(54)=XMLT - OARR(55)=cgm_lat - OARR(56)=cgm_lon - OARR(57)=cgm_mlt + OARR(39)=gind ! 12-month running mean of IG index + OARR(40)=f1pb ! probability for an F1 layer + OARR(41)=f107d ! daily solar radio flux at 10.7cm:F10.7 + OARR(42)=c1 ! shape parameter for F1 layer + OARR(43)=daynr ! day of year + OARR(44)=drift ! vertical ion drift at equator in m/s + OARR(45)=stormcorr ! ratio foF2_storm/foF2_quiet + OARR(46)=f10781 ! 81-day average of F10.7 + OARR(47)=estormcor ! ratio foE_storm/foE_quiet + OARR(48)=spreadf ! probability of spread-F occurrence + OARR(49)=MLAT ! IGRF magnetic latitude + OARR(50)=MLONG ! IGRF magnetic longitude + OARR(51)=index_3h_ap*1.0 ! ap index for current UT + OARR(52)=IAP_daily*1.0 ! daily ap index + OARR(53)=invdip ! invariant dip latitude + OARR(54)=XMLT ! Magnetic Local Time +C Please check subroutine GEOCGM01 in file IGRF.FOR for more +C information on the Corrected Geomagnetic (CGM) coordinates. +C CGM coordinates are only calculated if you select +C AURORAL BOUNDARIES + OARR(55)=cgm_lat ! Corrected Geomagnetic (CGM) latitude + OARR(56)=cgm_lon ! Corrected Geomagnetic (CGM) longitude + OARR(57)=cgm_mlt ! Magnetic Local Time for CGM coord. OARR(58)=cgmlat ! CGM latitude of equatorward boundary c include only every second auroral boundary point (MLT=0,1,2..23) jjj=58 - do iii=1,47,2 + do iii=1,47,2 ! CGM latitude at MLT=0,1,2 ...23 jjj=jjj+1 oarr(jjj)=ab_mlat(iii) enddo - OARR(83)=xkp - OARR(84)=dec - OARR(85)=fl - OARR(86)=dimo - OARR(87)=SAX300 - OARR(88)=SUX300 - - oarr(89) = foF2 !< Michael Hirsch + OARR(83)=xkp ! Kp at the time specified by the user + OARR(84)=dec ! magnetic declination in degrees + OARR(85)=fl ! L-value + OARR(86)=dimo ! Earth's dipole moment + OARR(87)=SAX300 ! sunrise at 300km in decimal hours + OARR(88)=SUX300 ! sunset at 300km in decimal hours + OARR(89)=HNEA ! lower boundary in km of IRI profile + OARR(90)=HNEE ! upper boundary in km of IRI profile + + oarr(100) = foF2 !< Michael Hirsch 3330 CONTINUE c output of solar indices used @@ -2266,3 +2279,104 @@ c10201 format(I5,11F6.1) RETURN END +c +c + subroutine iri_web(jmag,jf,alati,along,iyyyy,mmdd,iut,dhour, + & height,h_tec_max,ivar,vbeg,vend,vstp,a,b) +c----------------------------------------------------------------------- +c changes: +c 11/16/99 jf(30) instead of jf(17) +c 10/31/08 outf, a, b (100 -> 500) +c +c----------------------------------------------------------------------- +c input: jmag,alati,along,iyyyy,mmdd,dhour see IRI_SUB +c height height in km +c h_tec_max =0 no TEC otherwise upper boundary for integral +c iut =1 for UT =0 for LT +c ivar =1 altitude +c =2,3 latitude,longitude +c =4,5,6 year,month,day +c =7 day of year +c =8 hour (UT or LT) +c vbeg,vend,vstp variable range (begin,end,step) +c output: a similar to outf in IRI_SUB +c b similar to oarr in IRI_SUB +c +c numstp number of steps; maximal 1000 +c----------------------------------------------------------------------- + dimension outf(20,1000),oar(100),oarr(100),a(20,1000) + dimension xvar(8),b(100,1000) + logical jf(50) + + nummax=1000 + numstp=int((vend-vbeg)/vstp)+1 + if(numstp.gt.nummax) numstp=nummax + + do 6249 i=1,100 +6249 oar(i)=b(i,1) + + if(ivar.eq.1) then + do 1249 i=1,100 +1249 oarr(i)=oar(i) + xhour=dhour+iut*25. + call IRI_SUB(JF,JMAG,ALATI,ALONG,IYYYY,MMDD,XHOUR, + & VBEG,VEND,VSTP,a,OARR) + if(h_tec_max.gt.50.) then + call iri_tec (50.,h_tec_max,2,tec,tect,tecb) + oarr(37)=tec + oarr(38)=tect + endif + do 1111 i=1,100 +1111 b(i,1)=oarr(i) + return + endif + if(height.le.0.0) height=100 + xvar(2)=alati + xvar(3)=along + xvar(4)=iyyyy + xvar(5)=mmdd/100 + xvar(6)=mmdd-xvar(5)*100 + xvar(7)=abs(mmdd*1.) + xvar(8)=dhour + + xvar(ivar)=vbeg + + alati=xvar(2) + along=xvar(3) + iyyyy=int(xvar(4)) + if(ivar.eq.7) then + mmdd=-int(vbeg) + else + mmdd=int(xvar(5)*100+xvar(6)) + endif + dhour=xvar(8)+iut*25. + + do 1 i=1,numstp + do 1349 iii=1,100 +1349 oarr(iii)=b(iii,i) + call IRI_SUB(JF,JMAG,ALATI,ALONG,IYYYY,MMDD,DHOUR, + & height,height,1.,OUTF,OARR) + if(h_tec_max.gt.50.) then + call iri_tec (50.,h_tec_max,2,tec,tect,tecb) + oarr(37)=tec + oarr(38)=tect + endif + do 2 ii=1,20 +2 a(ii,i)=outf(ii,1) + do 2222 ii=1,100 +2222 b(ii,i)=oarr(ii) + xvar(ivar)=xvar(ivar)+vstp + + alati=xvar(2) + along=xvar(3) + iyyyy=int(xvar(4)) + if(ivar.eq.7) then + mmdd=-xvar(7) + else + mmdd=int(xvar(5)*100+xvar(6)) + endif + dhour=xvar(8)+iut*25. +1 continue + + return + end diff --git a/setup.cfg b/setup.cfg index b874892..c6123ca 100644 --- a/setup.cfg +++ b/setup.cfg @@ -1,6 +1,6 @@ [metadata] name = iri2016 -version = 1.8.6 +version = 1.9.0 author = Michael Hirsch, Ph.D.; Ronald Ilma author_email = scivision@users.noreply.github.com description = IRI2016 International Reference Ionosphere from Python diff --git a/tests/test_mod.py b/tests/test_mod.py index 326f219..d03d071 100755 --- a/tests/test_mod.py +++ b/tests/test_mod.py @@ -19,6 +19,7 @@ def test_altitude_profile(): assert iri["ne"][10].item() == approx(3.98669824e9, rel=1e-4) assert iri.NmF2.item() == approx(7.71626844e10, rel=1e-4) assert iri.hmF2.item() == approx(312.837677, rel=1e-4) + assert iri.foF2.item() == approx(2.49454951) if __name__ == "__main__":