From bb993da44017a06a4af9e51d33d11e9055cea7fc Mon Sep 17 00:00:00 2001 From: Jacob Williams Date: Sat, 3 Feb 2024 22:10:55 -0600 Subject: [PATCH 01/13] refactoring code from https://github.com/nasa/radbelt also added data files --- .gitignore | 1 + README.md | 1 + dgrf1945.dat | 67 +++ dgrf1950.dat | 67 +++ dgrf1955.dat | 67 +++ dgrf1960.dat | 67 +++ dgrf1965.dat | 67 +++ dgrf1970.dat | 67 +++ dgrf1975.dat | 67 +++ dgrf1980.dat | 67 +++ dgrf1985.dat | 67 +++ dgrf1990.dat | 67 +++ dgrf1995.dat | 67 +++ dgrf2000.dat | 67 +++ dgrf2005.dat | 67 +++ dgrf2010.dat | 67 +++ dgrf2015.dat | 67 +++ igrf2020.dat | 67 +++ igrf2020s.dat | 67 +++ src/core.f90 | 72 +++ src/shellig.f90 | 1218 +++++++++++++++++++++++++++++++++++++++++++++++ 21 files changed, 2431 insertions(+) create mode 100644 dgrf1945.dat create mode 100644 dgrf1950.dat create mode 100644 dgrf1955.dat create mode 100644 dgrf1960.dat create mode 100644 dgrf1965.dat create mode 100644 dgrf1970.dat create mode 100644 dgrf1975.dat create mode 100644 dgrf1980.dat create mode 100644 dgrf1985.dat create mode 100644 dgrf1990.dat create mode 100644 dgrf1995.dat create mode 100644 dgrf2000.dat create mode 100644 dgrf2005.dat create mode 100644 dgrf2010.dat create mode 100644 dgrf2015.dat create mode 100644 igrf2020.dat create mode 100644 igrf2020s.dat create mode 100644 src/core.f90 create mode 100644 src/shellig.f90 diff --git a/.gitignore b/.gitignore index b4683d3..9e6cdd5 100644 --- a/.gitignore +++ b/.gitignore @@ -39,3 +39,4 @@ /doc /lib /bin +/archive diff --git a/README.md b/README.md index 5b45666..68363b4 100755 --- a/README.md +++ b/README.md @@ -75,6 +75,7 @@ two lines had been exchanged. ### See also * [NASA ModelWebArchive](https://git.smce.nasa.gov/ccmc-share/modelwebarchive) +* [An Astropy-friendly wrapper for the AE-8/AP-8 Van Allen belt model](https://github.com/nasa/radbelt) ### REFERENCES: diff --git a/dgrf1945.dat b/dgrf1945.dat new file mode 100644 index 0000000..cead48b --- /dev/null +++ b/dgrf1945.dat @@ -0,0 +1,67 @@ + dgrf45 + 10 6371.2 1945.0 + 1 0 -30594. 0. + 1 1 -2285. 5810. + 2 0 -1244. 0. + 2 1 2990. -1702. + 2 2 1578. 477. + 3 0 1282. 0. + 3 1 -1834. -499. + 3 2 1255. 186. + 3 3 913. -11. + 4 0 944. 0. + 4 1 776. 144. + 4 2 544. -276. + 4 3 -421. -55. + 4 4 304. -178. + 5 0 -253. 0. + 5 1 346. -12. + 5 2 194. 95. + 5 3 -20. -67. + 5 4 -142. -119. + 5 5 -82. 82. + 6 0 59. 0. + 6 1 57. 6. + 6 2 6. 100. + 6 3 -246. 16. + 6 4 -25. -9. + 6 5 21. -16. + 6 6 -104. -39. + 7 0 70. 0. + 7 1 -40. -45. + 7 2 0. -18. + 7 3 0. 2. + 7 4 -29. 6. + 7 5 -10. 28. + 7 6 15. -17. + 7 7 29. -22. + 8 0 13. 0. + 8 1 7. 12. + 8 2 -8. -21. + 8 3 -5. -12. + 8 4 9. -7. + 8 5 7. 2. + 8 6 -10. 18. + 8 7 7. 3. + 8 8 2. -11. + 9 0 5. 0. + 9 1 -21. -27. + 9 2 1. 17. + 9 3 -11. 29. + 9 4 3. -9. + 9 5 16. 4. + 9 6 -3. 9. + 9 7 -4. 6. + 9 8 -3. 1. + 9 9 -4. 8. + 10 0 -3. 0. + 10 1 11. 5. + 10 2 1. 1. + 10 3 2. -20. + 10 4 -5. -1. + 10 5 -1. -6. + 10 6 8. 6. + 10 7 -1. -4. + 10 8 -3. -2. + 10 9 5. 0. + 10 10 -2. -2. diff --git a/dgrf1950.dat b/dgrf1950.dat new file mode 100644 index 0000000..b8971b7 --- /dev/null +++ b/dgrf1950.dat @@ -0,0 +1,67 @@ + dgrf50 + 10 6371.2 1950.0 + 1 0 -30554. 0. + 1 1 -2250. 5815. + 2 0 -1341. 0. + 2 1 2998. -1810. + 2 2 1576. 381. + 3 0 1297. 0. + 3 1 -1889. -476. + 3 2 1274. 206. + 3 3 896. -46. + 4 0 954. 0. + 4 1 792. 136. + 4 2 528. -278. + 4 3 -408. -37. + 4 4 303. -210. + 5 0 -240. 0. + 5 1 349. 3. + 5 2 211. 103. + 5 3 -20. -87. + 5 4 -147. -122. + 5 5 -76. 80. + 6 0 54. 0. + 6 1 57. -1. + 6 2 4. 99. + 6 3 -247. 33. + 6 4 -16. -12. + 6 5 12. -12. + 6 6 -105. -30. + 7 0 65. 0. + 7 1 -55. -35. + 7 2 2. -17. + 7 3 1. 0. + 7 4 -40. 10. + 7 5 -7. 36. + 7 6 5. -18. + 7 7 19. -16. + 8 0 22. 0. + 8 1 15. 5. + 8 2 -4. -22. + 8 3 -1. 0. + 8 4 11. -21. + 8 5 15. -8. + 8 6 -13. 17. + 8 7 5. -4. + 8 8 -1. -17. + 9 0 3. 0. + 9 1 -7. -24. + 9 2 -1. 19. + 9 3 -25. 12. + 9 4 10. 2. + 9 5 5. 2. + 9 6 -5. 8. + 9 7 -2. 8. + 9 8 3. -11. + 9 9 8. -7. + 10 0 -8. 0. + 10 1 4. 13. + 10 2 -1. -2. + 10 3 13. -10. + 10 4 -4. 2. + 10 5 4. -3. + 10 6 12. 6. + 10 7 3. -3. + 10 8 2. 6. + 10 9 10. 11. + 10 10 3. 8. diff --git a/dgrf1955.dat b/dgrf1955.dat new file mode 100644 index 0000000..68807d8 --- /dev/null +++ b/dgrf1955.dat @@ -0,0 +1,67 @@ + dgrf55 + 10 6371.2 1955.0 + 1 0 -30500. 0. + 1 1 -2215. 5820. + 2 0 -1440. 0. + 2 1 3003. -1898. + 2 2 1581. 291. + 3 0 1302. 0. + 3 1 -1944. -462. + 3 2 1288. 216. + 3 3 882. -83. + 4 0 958. 0. + 4 1 796. 133. + 4 2 510. -274. + 4 3 -397. -23. + 4 4 290. -230. + 5 0 -229. 0. + 5 1 360. 15. + 5 2 230. 110. + 5 3 -23. -98. + 5 4 -152. -121. + 5 5 -69. 78. + 6 0 47. 0. + 6 1 57. -9. + 6 2 3. 96. + 6 3 -247. 48. + 6 4 -8. -16. + 6 5 7. -12. + 6 6 -107. -24. + 7 0 65. 0. + 7 1 -56. -50. + 7 2 2. -24. + 7 3 10. -4. + 7 4 -32. 8. + 7 5 -11. 28. + 7 6 9. -20. + 7 7 18. -18. + 8 0 11. 0. + 8 1 9. 10. + 8 2 -6. -15. + 8 3 -14. 5. + 8 4 6. -23. + 8 5 10. 3. + 8 6 -7. 23. + 8 7 6. -4. + 8 8 9. -13. + 9 0 4. 0. + 9 1 9. -11. + 9 2 -4. 12. + 9 3 -5. 7. + 9 4 2. 6. + 9 5 4. -2. + 9 6 1. 10. + 9 7 2. 7. + 9 8 2. -6. + 9 9 5. 5. + 10 0 -3. 0. + 10 1 -5. -4. + 10 2 -1. 0. + 10 3 2. -8. + 10 4 -3. -2. + 10 5 7. -4. + 10 6 4. 1. + 10 7 -2. -3. + 10 8 6. 7. + 10 9 -2. -1. + 10 10 0. -3. diff --git a/dgrf1960.dat b/dgrf1960.dat new file mode 100644 index 0000000..3eade82 --- /dev/null +++ b/dgrf1960.dat @@ -0,0 +1,67 @@ + dgrf60 + 10 6371.2 1960.0 + 1 0 -30421. 0. + 1 1 -2169. 5791. + 2 0 -1555. 0. + 2 1 3002. -1967. + 2 2 1590. 206. + 3 0 1302. 0. + 3 1 -1992. -414. + 3 2 1289. 224. + 3 3 878. -130. + 4 0 957. 0. + 4 1 800. 135. + 4 2 504. -278. + 4 3 -394. 3. + 4 4 269. -255. + 5 0 -222. 0. + 5 1 362. 16. + 5 2 242. 125. + 5 3 -26. -117. + 5 4 -156. -114. + 5 5 -63. 81. + 6 0 46. 0. + 6 1 58. -10. + 6 2 1. 99. + 6 3 -237. 60. + 6 4 -1. -20. + 6 5 -2. -11. + 6 6 -113. -17. + 7 0 67. 0. + 7 1 -56. -55. + 7 2 5. -28. + 7 3 15. -6. + 7 4 -32. 7. + 7 5 -7. 23. + 7 6 17. -18. + 7 7 8. -17. + 8 0 15. 0. + 8 1 6. 11. + 8 2 -4. -14. + 8 3 -11. 7. + 8 4 2. -18. + 8 5 10. 4. + 8 6 -5. 23. + 8 7 10. 1. + 8 8 8. -20. + 9 0 4. 0. + 9 1 6. -18. + 9 2 0. 12. + 9 3 -9. 2. + 9 4 1. 0. + 9 5 4. -3. + 9 6 -1. 9. + 9 7 -2. 8. + 9 8 3. 0. + 9 9 -1. 5. + 10 0 1. 0. + 10 1 -3. 4. + 10 2 4. 1. + 10 3 0. 0. + 10 4 -1. 2. + 10 5 4. -5. + 10 6 6. 1. + 10 7 1. -1. + 10 8 -1. 6. + 10 9 2. 0. + 10 10 0. -7. diff --git a/dgrf1965.dat b/dgrf1965.dat new file mode 100644 index 0000000..dfed431 --- /dev/null +++ b/dgrf1965.dat @@ -0,0 +1,67 @@ + dgrf65 + 10 6371.2 1965.0 + 1 0 -30334. 0. + 1 1 -2119. 5776. + 2 0 -1662. 0. + 2 1 2997. -2016. + 2 2 1594. 114. + 3 0 1297. 0. + 3 1 -2038. -404. + 3 2 1292. 240. + 3 3 856. -165. + 4 0 957. 0. + 4 1 804. 148. + 4 2 479. -269. + 4 3 -390. 13. + 4 4 252. -269. + 5 0 -219. 0. + 5 1 358. 19. + 5 2 254. 128. + 5 3 -31. -126. + 5 4 -157. -97. + 5 5 -62. 81. + 6 0 45. 0. + 6 1 61. -11. + 6 2 8. 100. + 6 3 -228. 68. + 6 4 4. -32. + 6 5 1. -8. + 6 6 -111. -7. + 7 0 75. 0. + 7 1 -57. -61. + 7 2 4. -27. + 7 3 13. -2. + 7 4 -26. 6. + 7 5 -6. 26. + 7 6 13. -23. + 7 7 1. -12. + 8 0 13. 0. + 8 1 5. 7. + 8 2 -4. -12. + 8 3 -14. 9. + 8 4 0. -16. + 8 5 8. 4. + 8 6 -1. 24. + 8 7 11. -3. + 8 8 4. -17. + 9 0 8. 0. + 9 1 10. -22. + 9 2 2. 15. + 9 3 -13. 7. + 9 4 10. -4. + 9 5 -1. -5. + 9 6 -1. 10. + 9 7 5. 10. + 9 8 1. -4. + 9 9 -2. 1. + 10 0 -2. 0. + 10 1 -3. 2. + 10 2 2. 1. + 10 3 -5. 2. + 10 4 -2. 6. + 10 5 4. -4. + 10 6 4. 0. + 10 7 0. -2. + 10 8 2. 3. + 10 9 2. 0. + 10 10 0. -6. diff --git a/dgrf1970.dat b/dgrf1970.dat new file mode 100644 index 0000000..45c3192 --- /dev/null +++ b/dgrf1970.dat @@ -0,0 +1,67 @@ + dgrf70 + 10 6371.2 1970.0 + 1 0 -30220. 0. + 1 1 -2068. 5737. + 2 0 -1781. 0. + 2 1 3000. -2047. + 2 2 1611. 25. + 3 0 1287. 0. + 3 1 -2091. -366. + 3 2 1278. 251. + 3 3 838. -196. + 4 0 952. 0. + 4 1 800. 167. + 4 2 461. -266. + 4 3 -395. 26. + 4 4 234. -279. + 5 0 -216. 0. + 5 1 359. 26. + 5 2 262. 139. + 5 3 -42. -139. + 5 4 -160. -91. + 5 5 -56. 83. + 6 0 43. 0. + 6 1 64. -12. + 6 2 15. 100. + 6 3 -212. 72. + 6 4 2. -37. + 6 5 3. -6. + 6 6 -112. 1. + 7 0 72. 0. + 7 1 -57. -70. + 7 2 1. -27. + 7 3 14. -4. + 7 4 -22. 8. + 7 5 -2. 23. + 7 6 13. -23. + 7 7 -2. -11. + 8 0 14. 0. + 8 1 6. 7. + 8 2 -2. -15. + 8 3 -13. 6. + 8 4 -3. -17. + 8 5 5. 6. + 8 6 0. 21. + 8 7 11. -6. + 8 8 3. -16. + 9 0 8. 0. + 9 1 10. -21. + 9 2 2. 16. + 9 3 -12. 6. + 9 4 10. -4. + 9 5 -1. -5. + 9 6 0. 10. + 9 7 3. 11. + 9 8 1. -2. + 9 9 -1. 1. + 10 0 -3. 0. + 10 1 -3. 1. + 10 2 2. 1. + 10 3 -5. 3. + 10 4 -1. 4. + 10 5 6. -4. + 10 6 4. 0. + 10 7 1. -1. + 10 8 0. 3. + 10 9 3. 1. + 10 10 -1. -4. diff --git a/dgrf1975.dat b/dgrf1975.dat new file mode 100644 index 0000000..fe001d9 --- /dev/null +++ b/dgrf1975.dat @@ -0,0 +1,67 @@ + dgrf75 + 10 6371.2 1975.0 + 1 0 -30100. 0. + 1 1 -2013. 5675. + 2 0 -1902. 0. + 2 1 3010. -2067. + 2 2 1632. -68. + 3 0 1276. 0. + 3 1 -2144. -333. + 3 2 1260. 262. + 3 3 830. -223. + 4 0 946. 0. + 4 1 791. 191. + 4 2 438. -265. + 4 3 -405. 39. + 4 4 216. -288. + 5 0 -218. 0. + 5 1 356. 31. + 5 2 264. 148. + 5 3 -59. -152. + 5 4 -159. -83. + 5 5 -49. 88. + 6 0 45. 0. + 6 1 66. -13. + 6 2 28. 99. + 6 3 -198. 75. + 6 4 1. -41. + 6 5 6. -4. + 6 6 -111. 11. + 7 0 71. 0. + 7 1 -56. -77. + 7 2 1. -26. + 7 3 16. -5. + 7 4 -14. 10. + 7 5 0. 22. + 7 6 12. -23. + 7 7 -5. -12. + 8 0 14. 0. + 8 1 6. 6. + 8 2 -1. -16. + 8 3 -12. 4. + 8 4 -8. -19. + 8 5 4. 6. + 8 6 0. 18. + 8 7 10. -10. + 8 8 1. -17. + 9 0 7. 0. + 9 1 10. -21. + 9 2 2. 16. + 9 3 -12. 7. + 9 4 10. -4. + 9 5 -1. -5. + 9 6 -1. 10. + 9 7 4. 11. + 9 8 1. -3. + 9 9 -2. 1. + 10 0 -3. 0. + 10 1 -3. 1. + 10 2 2. 1. + 10 3 -5. 3. + 10 4 -2. 4. + 10 5 5. -4. + 10 6 4. -1. + 10 7 1. -1. + 10 8 0. 3. + 10 9 3. 1. + 10 10 -1. -5. diff --git a/dgrf1980.dat b/dgrf1980.dat new file mode 100644 index 0000000..29ef9c1 --- /dev/null +++ b/dgrf1980.dat @@ -0,0 +1,67 @@ + dgrf80 + 10 6371.2 1980.0 + 1 0 -29992. 0. + 1 1 -1956. 5604. + 2 0 -1997. 0. + 2 1 3027. -2129. + 2 2 1663. -200. + 3 0 1281. 0. + 3 1 -2180. -336. + 3 2 1251. 271. + 3 3 833. -252. + 4 0 938. 0. + 4 1 782. 212. + 4 2 398. -257. + 4 3 -419. 53. + 4 4 199. -297. + 5 0 -218. 0. + 5 1 357. 46. + 5 2 261. 150. + 5 3 -74. -151. + 5 4 -162. -78. + 5 5 -48. 92. + 6 0 48. 0. + 6 1 66. -15. + 6 2 42. 93. + 6 3 -192. 71. + 6 4 4. -43. + 6 5 14. -2. + 6 6 -108. 17. + 7 0 72. 0. + 7 1 -59. -82. + 7 2 2. -27. + 7 3 21. -5. + 7 4 -12. 16. + 7 5 1. 18. + 7 6 11. -23. + 7 7 -2. -10. + 8 0 18. 0. + 8 1 6. 7. + 8 2 0. -18. + 8 3 -11. 4. + 8 4 -7. -22. + 8 5 4. 9. + 8 6 3. 16. + 8 7 6. -13. + 8 8 -1. -15. + 9 0 5. 0. + 9 1 10. -21. + 9 2 1. 16. + 9 3 -12. 9. + 9 4 9. -5. + 9 5 -3. -6. + 9 6 -1. 9. + 9 7 7. 10. + 9 8 2. -6. + 9 9 -5. 2. + 10 0 -4. 0. + 10 1 -4. 1. + 10 2 2. 0. + 10 3 -5. 3. + 10 4 -2. 6. + 10 5 5. -4. + 10 6 3. 0. + 10 7 1. -1. + 10 8 2. 4. + 10 9 3. 0. + 10 10 0. -6. diff --git a/dgrf1985.dat b/dgrf1985.dat new file mode 100644 index 0000000..d771bcf --- /dev/null +++ b/dgrf1985.dat @@ -0,0 +1,67 @@ + dgrf85 + 10 6371.2 1985.0 + 1 0 -29873. 0. + 1 1 -1905. 5500. + 2 0 -2072. 0. + 2 1 3044. -2197. + 2 2 1687. -306. + 3 0 1296. 0. + 3 1 -2208. -310. + 3 2 1247. 284. + 3 3 829. -297. + 4 0 936. 0. + 4 1 780. 232. + 4 2 361. -249. + 4 3 -424. 69. + 4 4 170. -297. + 5 0 -214. 0. + 5 1 355. 47. + 5 2 253. 150. + 5 3 -93. -154. + 5 4 -164. -75. + 5 5 -46. 95. + 6 0 53. 0. + 6 1 65. -16. + 6 2 51. 88. + 6 3 -185. 69. + 6 4 4. -48. + 6 5 16. -1. + 6 6 -102. 21. + 7 0 74. 0. + 7 1 -62. -83. + 7 2 3. -27. + 7 3 24. -2. + 7 4 -6. 20. + 7 5 4. 17. + 7 6 10. -23. + 7 7 0. -7. + 8 0 21. 0. + 8 1 6. 8. + 8 2 0. -19. + 8 3 -11. 5. + 8 4 -9. -23. + 8 5 4. 11. + 8 6 4. 14. + 8 7 4. -15. + 8 8 -4. -11. + 9 0 5. 0. + 9 1 10. -21. + 9 2 1. 15. + 9 3 -12. 9. + 9 4 9. -6. + 9 5 -3. -6. + 9 6 -1. 9. + 9 7 7. 9. + 9 8 1. -7. + 9 9 -5. 2. + 10 0 -4. 0. + 10 1 -4. 1. + 10 2 3. 0. + 10 3 -5. 3. + 10 4 -2. 6. + 10 5 5. -4. + 10 6 3. 0. + 10 7 1. -1. + 10 8 2. 4. + 10 9 3. 0. + 10 10 0. -6. diff --git a/dgrf1990.dat b/dgrf1990.dat new file mode 100644 index 0000000..f431fa4 --- /dev/null +++ b/dgrf1990.dat @@ -0,0 +1,67 @@ + dgrf90 + 10 6371.2 1990.0 + 1 0 -29775. 0. + 1 1 -1848. 5406. + 2 0 -2131. 0. + 2 1 3059. -2279. + 2 2 1686. -373. + 3 0 1314. 0. + 3 1 -2239. -284. + 3 2 1248. 293. + 3 3 802. -352. + 4 0 939. 0. + 4 1 780. 247. + 4 2 325. -240. + 4 3 -423. 84. + 4 4 141. -299. + 5 0 -214. 0. + 5 1 353. 46. + 5 2 245. 154. + 5 3 -109. -153. + 5 4 -165. -69. + 5 5 -36. 97. + 6 0 61. 0. + 6 1 65. -16. + 6 2 59. 82. + 6 3 -178. 69. + 6 4 3. -52. + 6 5 18. 1. + 6 6 -96. 24. + 7 0 77. 0. + 7 1 -64. -80. + 7 2 2. -26. + 7 3 26. 0. + 7 4 -1. 21. + 7 5 5. 17. + 7 6 9. -23. + 7 7 0. -4. + 8 0 23. 0. + 8 1 5. 10. + 8 2 -1. -19. + 8 3 -10. 6. + 8 4 -12. -22. + 8 5 3. 12. + 8 6 4. 12. + 8 7 2. -16. + 8 8 -6. -10. + 9 0 4. 0. + 9 1 9. -20. + 9 2 1. 15. + 9 3 -12. 11. + 9 4 9. -7. + 9 5 -4. -7. + 9 6 -2. 9. + 9 7 7. 8. + 9 8 1. -7. + 9 9 -6. 2. + 10 0 -3. 0. + 10 1 -4. 2. + 10 2 2. 1. + 10 3 -5. 3. + 10 4 -2. 6. + 10 5 4. -4. + 10 6 3. 0. + 10 7 1. -2. + 10 8 3. 3. + 10 9 3. -1. + 10 10 0. -6. diff --git a/dgrf1995.dat b/dgrf1995.dat new file mode 100644 index 0000000..5e0fd4e --- /dev/null +++ b/dgrf1995.dat @@ -0,0 +1,67 @@ + dgrf95 + 10 6371.2 1995.0 + 1 0 -29692. 0. + 1 1 -1784. 5306. + 2 0 -2200. 0. + 2 1 3070. -2366. + 2 2 1681. -413. + 3 0 1335. 0. + 3 1 -2267. -262. + 3 2 1249. 302. + 3 3 759. -427. + 4 0 940. 0. + 4 1 780. 262. + 4 2 290. -236. + 4 3 -418. 97. + 4 4 122. -306. + 5 0 -214. 0. + 5 1 352. 46. + 5 2 235. 165. + 5 3 -118. -143. + 5 4 -166. -55. + 5 5 -17. 107. + 6 0 68. 0. + 6 1 67. -17. + 6 2 68. 72. + 6 3 -170. 67. + 6 4 -1. -58. + 6 5 19. 1. + 6 6 -93. 36. + 7 0 77. 0. + 7 1 -72. -69. + 7 2 1. -25. + 7 3 28. 4. + 7 4 5. 24. + 7 5 4. 17. + 7 6 8. -24. + 7 7 -2. -6. + 8 0 25. 0. + 8 1 6. 11. + 8 2 -6. -21. + 8 3 -9. 8. + 8 4 -14. -23. + 8 5 9. 15. + 8 6 6. 11. + 8 7 -5. -16. + 8 8 -7. -4. + 9 0 4. 0. + 9 1 9. -20. + 9 2 3. 15. + 9 3 -10. 12. + 9 4 8. -6. + 9 5 -8. -8. + 9 6 -1. 8. + 9 7 10. 5. + 9 8 -2. -8. + 9 9 -8. 3. + 10 0 -3. 0. + 10 1 -6. 1. + 10 2 2. 0. + 10 3 -4. 4. + 10 4 -1. 5. + 10 5 4. -5. + 10 6 2. -1. + 10 7 2. -2. + 10 8 5. 1. + 10 9 1. -2. + 10 10 0. -7. \ No newline at end of file diff --git a/dgrf2000.dat b/dgrf2000.dat new file mode 100644 index 0000000..e0c42b1 --- /dev/null +++ b/dgrf2000.dat @@ -0,0 +1,67 @@ + igrf00 + 10 6371.2 2000.0 + 1 0 -29619.4 0.0 + 1 1 -1728.2 5186.1 + 2 0 -2267.7 0.0 + 2 1 3068.4 -2481.6 + 2 2 1670.9 -458. + 3 0 1339.6 0.0 + 3 1 -2288. -227.6 + 3 2 1252.1 293.4 + 3 3 714.5 -491.1 + 4 0 932.3 .0 + 4 1 786.8 272.6 + 4 2 250. -231.9 + 4 3 -403. 119.8 + 4 4 111.3 -303.8 + 5 0 -218.8 .0 + 5 1 351.4 43.8 + 5 2 222.3 171.9 + 5 3 -130.4 -133.1 + 5 4 -168.6 -39.3 + 5 5 -12.9 106.3 + 6 0 72.3 .0 + 6 1 68.2 -17.4 + 6 2 74.2 63.7 + 6 3 -160.9 65.1 + 6 4 -5.9 -61.2 + 6 5 16.9 0.7 + 6 6 -90.4 43.8 + 7 0 79. .0 + 7 1 -74. -64.6 + 7 2 0. -24.2 + 7 3 33.3 6.2 + 7 4 9.1 24. + 7 5 6.9 14.8 + 7 6 7.3 -25.4 + 7 7 -1.2 -5.8 + 8 0 24.4 .0 + 8 1 6.6 11.9 + 8 2 -9.2 -21.5 + 8 3 -7.9 8.5 + 8 4 -16.6 -21.5 + 8 5 9.1 15.5 + 8 6 7. 8.9 + 8 7 -7.9 -14.9 + 8 8 -7. -2.1 + 9 0 5. .0 + 9 1 9.4 -19.7 + 9 2 3. 13.4 + 9 3 -8.4 12.5 + 9 4 6.3 -6.2 + 9 5 -8.9 -8.4 + 9 6 -1.5 8.4 + 9 7 9.3 3.8 + 9 8 -4.3 -8.2 + 9 9 -8.2 4.8 + 10 0 -2.6 .0 + 10 1 -6. 1.7 + 10 2 1.7 0. + 10 3 -3.1 4. + 10 4 -0.5 4.9 + 10 5 3.7 -5.9 + 10 6 1. -1.2 + 10 7 2. -2.9 + 10 8 4.2 0.2 + 10 9 0.3 -2.2 + 10 10 -1.1 -7.4 diff --git a/dgrf2005.dat b/dgrf2005.dat new file mode 100644 index 0000000..92704ac --- /dev/null +++ b/dgrf2005.dat @@ -0,0 +1,67 @@ + igrf05 + 10 6371.2 2005.0 + 1 0 -29554.63 0.00 + 1 1 -1669.05 5077.99 + 2 0 -2337.24 0.00 + 2 1 3047.69 -2594.50 + 2 2 1657.76 -515.43 + 3 0 1336.30 0.00 + 3 1 -2305.83 -198.86 + 3 2 1246.39 269.72 + 3 3 672.51 -524.72 + 4 0 920.55 0.00 + 4 1 797.96 282.07 + 4 2 210.65 -225.23 + 4 3 -379.86 145.15 + 4 4 100.00 -305.36 + 5 0 -227.00 0.00 + 5 1 354.41 42.72 + 5 2 208.95 180.25 + 5 3 -136.54 -123.45 + 5 4 -168.05 -19.57 + 5 5 -13.55 103.85 + 6 0 73.60 0.00 + 6 1 69.56 -20.33 + 6 2 76.74 54.75 + 6 3 -151.34 63.63 + 6 4 -14.58 -63.53 + 6 5 14.58 0.24 + 6 6 -86.36 50.94 + 7 0 79.88 0.00 + 7 1 -74.46 -61.14 + 7 2 -1.65 -22.57 + 7 3 38.73 6.82 + 7 4 12.30 25.35 + 7 5 9.37 10.93 + 7 6 5.42 -26.32 + 7 7 1.94 -4.64 + 8 0 24.80 0.00 + 8 1 7.62 11.20 + 8 2 -11.73 -20.88 + 8 3 -6.88 9.83 + 8 4 -18.11 -19.71 + 8 5 10.17 16.22 + 8 6 9.36 7.61 + 8 7 -11.25 -12.76 + 8 8 -4.87 -0.06 + 9 0 5.58 0.00 + 9 1 9.76 -20.11 + 9 2 3.58 12.69 + 9 3 -6.94 12.67 + 9 4 5.01 -6.72 + 9 5 -10.76 -8.16 + 9 6 -1.25 8.10 + 9 7 8.76 2.92 + 9 8 -6.66 -7.73 + 9 9 -9.22 6.01 + 10 0 -2.17 0.00 + 10 1 -6.12 2.19 + 10 2 1.42 0.10 + 10 3 -2.35 4.46 + 10 4 -0.15 4.76 + 10 5 3.06 -6.58 + 10 6 0.29 -1.01 + 10 7 2.06 -3.47 + 10 8 3.77 -0.86 + 10 9 -0.21 -2.31 + 10 10 -2.09 -7.93 diff --git a/dgrf2010.dat b/dgrf2010.dat new file mode 100644 index 0000000..d028590 --- /dev/null +++ b/dgrf2010.dat @@ -0,0 +1,67 @@ + igrf10 + 10 6371.2 2010.0 + 1 0 -29496.57 0.00 + 1 1 -1586.42 4944.26 + 2 0 -2396.06 0.00 + 2 1 3026.34 -2708.54 + 2 2 1668.17 -575.73 + 3 0 1339.85 0.00 + 3 1 -2326.54 -160.40 + 3 2 1232.10 251.75 + 3 3 633.73 -537.03 + 4 0 912.66 0.00 + 4 1 808.97 286.48 + 4 2 166.58 -211.03 + 4 3 -356.83 164.46 + 4 4 89.40 -309.72 + 5 0 -230.87 0.00 + 5 1 357.29 44.58 + 5 2 200.26 189.01 + 5 3 -141.05 -118.06 + 5 4 -163.17 -0.01 + 5 5 -8.03 101.04 + 6 0 72.78 0.00 + 6 1 68.69 -20.90 + 6 2 75.92 44.18 + 6 3 -141.40 61.54 + 6 4 -22.83 -66.26 + 6 5 13.10 3.02 + 6 6 -78.09 55.40 + 7 0 80.44 0.00 + 7 1 -75.00 -57.80 + 7 2 -4.55 -21.20 + 7 3 45.24 6.54 + 7 4 14.00 24.96 + 7 5 10.46 7.03 + 7 6 1.64 -27.61 + 7 7 4.92 -3.28 + 8 0 24.41 0.00 + 8 1 8.21 10.84 + 8 2 -14.50 -20.03 + 8 3 -5.59 11.83 + 8 4 -19.34 -17.41 + 8 5 11.61 16.71 + 8 6 10.85 6.96 + 8 7 -14.05 -10.74 + 8 8 -3.54 1.64 + 9 0 5.50 0.00 + 9 1 9.45 -20.54 + 9 2 3.45 11.51 + 9 3 -5.27 12.75 + 9 4 3.13 -7.14 + 9 5 -12.38 -7.42 + 9 6 -0.76 7.97 + 9 7 8.43 2.14 + 9 8 -8.42 -6.08 + 9 9 -10.08 7.01 + 10 0 -1.94 0.00 + 10 1 -6.24 2.73 + 10 2 0.89 -0.10 + 10 3 -1.07 4.71 + 10 4 -0.16 4.44 + 10 5 2.45 -7.22 + 10 6 -0.33 -0.96 + 10 7 2.13 -3.95 + 10 8 3.09 -1.99 + 10 9 -1.03 -1.97 + 10 10 -2.80 -8.31 diff --git a/dgrf2015.dat b/dgrf2015.dat new file mode 100644 index 0000000..82b4016 --- /dev/null +++ b/dgrf2015.dat @@ -0,0 +1,67 @@ + dgrf15 + 10 6371.2 2015.0 + 1 0 -29441.46 0.00 + 1 1 -1501.77 4795.99 + 2 0 -2445.88 0.00 + 2 1 3012.20 -2845.41 + 2 2 1676.35 -642.17 + 3 0 1350.33 0.00 + 3 1 -2352.26 -115.29 + 3 2 1225.85 245.04 + 3 3 581.69 -538.70 + 4 0 907.42 0.00 + 4 1 813.68 283.54 + 4 2 120.49 -188.43 + 4 3 -334.85 180.95 + 4 4 70.38 -329.23 + 5 0 -232.91 0.00 + 5 1 360.14 46.98 + 5 2 192.35 196.98 + 5 3 -140.94 -119.14 + 5 4 -157.40 15.98 + 5 5 4.30 100.12 + 6 0 69.55 0.00 + 6 1 67.57 -20.61 + 6 2 72.79 33.30 + 6 3 -129.85 58.74 + 6 4 -28.93 -66.64 + 6 5 13.14 7.35 + 6 6 -70.85 62.41 + 7 0 81.29 0.00 + 7 1 -75.99 -54.27 + 7 2 -6.79 -19.53 + 7 3 51.82 5.59 + 7 4 15.07 24.45 + 7 5 9.32 3.27 + 7 6 -2.88 -27.50 + 7 7 6.61 -2.32 + 8 0 23.98 0.00 + 8 1 8.89 10.04 + 8 2 -16.78 -18.26 + 8 3 -3.16 13.18 + 8 4 -20.56 -14.60 + 8 5 13.33 16.16 + 8 6 11.76 5.69 + 8 7 -15.98 -9.10 + 8 8 -2.02 2.26 + 9 0 5.33 0.00 + 9 1 8.83 -21.77 + 9 2 3.02 10.76 + 9 3 -3.22 11.74 + 9 4 0.67 -6.74 + 9 5 -13.20 -6.88 + 9 6 -0.10 7.79 + 9 7 8.68 1.04 + 9 8 -9.06 -3.89 + 9 9 -10.54 8.44 + 10 0 -2.01 0.00 + 10 1 -6.26 3.28 + 10 2 0.17 -0.40 + 10 3 0.55 4.55 + 10 4 -0.55 4.40 + 10 5 1.70 -7.92 + 10 6 -0.67 -0.61 + 10 7 2.13 -4.16 + 10 8 2.33 -2.85 + 10 9 -1.80 -1.12 + 10 10 -3.59 -8.72 diff --git a/igrf2020.dat b/igrf2020.dat new file mode 100644 index 0000000..2035551 --- /dev/null +++ b/igrf2020.dat @@ -0,0 +1,67 @@ + igrf20 + 10 6371.2 2020.0 + 1 0 -29404.80 0.00 + 1 1 -1450.90 4652.50 + 2 0 -2499.60 0.00 + 2 1 2982.00 -2991.60 + 2 2 1677.00 -734.60 + 3 0 1363.20 0.00 + 3 1 -2381.20 -82.10 + 3 2 1236.20 241.90 + 3 3 525.70 -543.40 + 4 0 903.00 0.00 + 4 1 809.50 281.90 + 4 2 86.30 -158.40 + 4 3 -309.40 199.70 + 4 4 48.00 -349.70 + 5 0 -234.30 0.00 + 5 1 363.20 47.70 + 5 2 187.80 208.30 + 5 3 -140.70 -121.20 + 5 4 -151.20 32.30 + 5 5 13.50 98.90 + 6 0 66.00 0.00 + 6 1 65.50 -19.10 + 6 2 72.90 25.10 + 6 3 -121.50 52.80 + 6 4 -36.20 -64.50 + 6 5 13.50 8.90 + 6 6 -64.70 68.10 + 7 0 80.60 0.00 + 7 1 -76.70 -51.50 + 7 2 -8.20 -16.90 + 7 3 56.50 2.20 + 7 4 15.80 23.50 + 7 5 6.40 -2.20 + 7 6 -7.20 -27.20 + 7 7 9.80 -1.80 + 8 0 23.70 0.00 + 8 1 9.70 8.40 + 8 2 -17.60 -15.30 + 8 3 -0.50 12.80 + 8 4 -21.10 -11.70 + 8 5 15.30 14.90 + 8 6 13.70 3.60 + 8 7 -16.50 -6.90 + 8 8 -0.30 2.80 + 9 0 5.00 0.00 + 9 1 8.40 -23.40 + 9 2 2.90 11.00 + 9 3 -1.50 9.80 + 9 4 -1.10 -5.10 + 9 5 -13.20 -6.30 + 9 6 1.10 7.80 + 9 7 8.80 0.40 + 9 8 -9.30 -1.40 + 9 9 -11.90 9.60 + 10 0 -1.90 0.00 + 10 1 -6.20 3.40 + 10 2 -0.10 -0.20 + 10 3 1.70 3.60 + 10 4 -0.90 4.80 + 10 5 0.70 -8.60 + 10 6 -0.90 -0.10 + 10 7 1.90 -4.30 + 10 8 1.40 -3.40 + 10 9 -2.40 -0.10 + 10 10 -3.80 -8.80 diff --git a/igrf2020s.dat b/igrf2020s.dat new file mode 100644 index 0000000..8c04684 --- /dev/null +++ b/igrf2020s.dat @@ -0,0 +1,67 @@ + igrf20s + 10 6371.2 2025.0 + 1 0 5.70 0.00 + 1 1 7.40 -25.90 + 2 0 -11.00 0.00 + 2 1 -7.00 -30.20 + 2 2 -2.10 -22.40 + 3 0 2.20 0.00 + 3 1 -5.90 6.00 + 3 2 3.10 -1.10 + 3 3 -12.00 0.50 + 4 0 -1.20 0.00 + 4 1 -1.60 -0.10 + 4 2 -5.90 6.50 + 4 3 5.20 3.60 + 4 4 -5.10 -5.00 + 5 0 -0.30 0.00 + 5 1 0.50 0.00 + 5 2 -0.60 2.50 + 5 3 0.20 -0.60 + 5 4 1.30 3.00 + 5 5 0.90 0.30 + 6 0 -0.50 0.00 + 6 1 -0.30 0.00 + 6 2 0.40 -1.60 + 6 3 1.30 -1.30 + 6 4 -1.40 0.80 + 6 5 0.00 0.00 + 6 6 0.90 1.00 + 7 0 -0.10 0.00 + 7 1 -0.20 0.60 + 7 2 0.00 0.60 + 7 3 0.70 -0.80 + 7 4 0.10 -0.20 + 7 5 -0.50 -1.10 + 7 6 -0.80 0.10 + 7 7 0.80 0.30 + 8 0 0.00 0.00 + 8 1 0.10 -0.20 + 8 2 -0.10 0.60 + 8 3 0.40 -0.20 + 8 4 -0.10 0.50 + 8 5 0.40 -0.30 + 8 6 0.30 -0.40 + 8 7 -0.10 0.50 + 8 8 0.40 0.00 + 9 0 0.00 0.00 + 9 1 0.00 0.00 + 9 2 0.00 0.00 + 9 3 0.00 0.00 + 9 4 0.00 0.00 + 9 5 0.00 0.00 + 9 6 0.00 0.00 + 9 7 0.00 0.00 + 9 8 0.00 0.00 + 9 9 0.00 0.00 + 10 0 0.00 0.00 + 10 1 0.00 0.00 + 10 2 0.00 0.00 + 10 3 0.00 0.00 + 10 4 0.00 0.00 + 10 5 0.00 0.00 + 10 6 0.00 0.00 + 10 7 0.00 0.00 + 10 8 0.00 0.00 + 10 9 0.00 0.00 + 10 10 0.00 0.00 diff --git a/src/core.f90 b/src/core.f90 new file mode 100644 index 0000000..cc6ffb2 --- /dev/null +++ b/src/core.f90 @@ -0,0 +1,72 @@ +! Copyright (C) 2021 United States Government as represented by the Administrator +! of the National Aeronautics and Space Administration. No copyright is claimed +! in the United States under Title 17, U.S. Code. All Other Rights Reserved. +! +! SPDX-License-Identifier: NASA-1.3 + +module core + + use radbelt_module + use shellig_module + + implicit none + + contains + +! Adapted from +! https://ccmc.gsfc.nasa.gov/pub/modelweb/geomagnetic/igrf/fortran_code/bilcal.for + +SUBROUTINE igrf(Lon,Lat,Height,Year,Xl,Bbx) + IMPLICIT NONE +!*** Start of declarations inserted by SPAG + REAL bab1 , babs , bdel , bdown , beast , beq , bequ , bnorth , dimo , rr0 + INTEGER icode +!*** End of declarations inserted by SPAG + REAL Lon , Lat , Height , Year , Xl , Bbx + LOGICAL val + + CALL initize() + CALL feldcof(Year,dimo) + CALL feldg(Lat,Lon,Height,bnorth,beast,bdown,babs) + CALL shellg(Lat,Lon,Height,dimo,Xl,icode,bab1) + bequ = dimo/(Xl*Xl*Xl) + IF ( icode==1 ) THEN + bdel = 1.E-3 + CALL findb0(0.05,bdel,val,beq,rr0) + IF ( val ) bequ = beq + ENDIF + Bbx = babs/bequ +END SUBROUTINE igrf + +! Adapted from +! https://ccmc.gsfc.nasa.gov/pub/modelweb/radiation_belt/radbelt/fortran_code/radbelt.for + +SUBROUTINE aep8(E,L,Bb0,Imname,Flux) + IMPLICIT NONE +!*** Start of declarations inserted by SPAG + REAL E(1) , ee , Flux(1) + INTEGER i , ier , ierr , ihead , Imname , iuaeap , map , nmap +!*** End of declarations inserted by SPAG + REAL L , Bb0 + DIMENSION map(20000) , ihead(8) , ee(1) !JW WARNING: map doesn't have to be this big! should allocate it to size nmap ! + CHARACTER*10 name , mname(4) + DATA mname/'ae8min.asc' , 'ae8max.asc' , 'ap8min.asc' , 'ap8max.asc'/ + + iuaeap = 15 + name = mname(Imname) + + OPEN (iuaeap,FILE=name,STATUS='OLD',IOSTAT=ierr,ERR=100,FORM='FORMATTED') + READ (iuaeap,99001) ihead + nmap = ihead(8) + READ (iuaeap,99001) (map(i),i=1,nmap) + + 100 CLOSE (iuaeap) + IF ( ier/=0 ) STOP + + ee(1) = E(1) + CALL trara1(ihead,map,L,Bb0,E,Flux,1) + IF ( Flux(1)>0.0 ) Flux(1) = 10.**Flux(1) +99001 FORMAT (1X,12I6) +END SUBROUTINE aep8 + +end module core diff --git a/src/shellig.f90 b/src/shellig.f90 new file mode 100644 index 0000000..3919816 --- /dev/null +++ b/src/shellig.f90 @@ -0,0 +1,1218 @@ + + module shellig_module + + implicit none + + contains + +! SHELLIG.FOR, Version 2.0, January 1992 +! +! 11/01/91-DKB- SHELLG: lowest starting point for B0 search is 2 +! 1/27/92-DKB- Adopted to IGRF-91 coeffcients model +! 2/05/92-DKB- Reduce variable-names: INTER(P)SHC,EXTRA(P)SHC,INITI(ALI)ZE +! 8/08/95-DKB- Updated to IGRF-45-95; new coeff. DGRF90, IGRF95, IGRF95S +! 5/31/00-DKB- Updated to IGRF-45-00; new coeff.: IGRF00, IGRF00s +! 3/24/05-DKB- Updated to IGRF-45-10; new coeff.: IGRF05, IGRF05s +! + +! +! SUBROUTINE findb0(Stps,Bdel,Value,Bequ,Rr0) +! IMPLICIT NONE +! !*** Start of declarations inserted by SPAG +! REAL b , Bdel , bdelta , Bequ , bmin , bold , bq1 , bq2 , bq3 , p , r1 , r2 , r3 , rold , Rr0 , Sp , step , step12 , Stps , zz +! INTEGER i , irun , j , n +! !*** End of declarations inserted by SPAG +! !-------------------------------------------------------------------- +! ! FINDS SMALLEST MAGNETIC FIELD STRENGTH ON FIELD LINE +! ! +! ! INPUT: STPS STEP SIZE FOR FIELD LINE TRACING +! ! COMMON/FIDB0/ +! ! SP DIPOLE ORIENTED COORDINATES FORM SHELLG; P(1,*), +! ! P(2,*), P(3,*) CLOSEST TO MAGNETIC EQUATOR +! ! BDEL REQUIRED ACCURACY = [ B(LAST) - BEQU ] / BEQU +! ! B(LAST) IS FIELD STRENGTH BEFORE BEQU +! ! +! ! OUTPUT: VALUE =.FALSE., IF BEQU IS NOT MINIMAL VALUE ON FIELD LINE +! ! BEQU MAGNETIC FIELD STRENGTH AT MAGNETIC EQUATOR +! ! RR0 EQUATORIAL RADIUS NORMALIZED TO EARTH RADIUS +! ! BDEL FINAL ACHIEVED ACCURACY +! !-------------------------------------------------------------------- +! DIMENSION p(8,4) , Sp(3) +! LOGICAL Value +! COMMON /fidb0 / Sp +! INTEGER :: spag_nextblock_1 +! spag_nextblock_1 = 1 +! SPAG_DispatchLoop_1: DO +! SELECT CASE (spag_nextblock_1) +! CASE (1) +! ! +! step = Stps +! irun = 0 +! spag_nextblock_1 = 2 +! CASE (2) +! irun = irun + 1 +! IF ( irun>5 ) THEN +! Value = .FALSE. +! spag_nextblock_1 = 3 +! CYCLE SPAG_DispatchLoop_1 +! ENDIF +! !*********************FIRST THREE POINTS +! p(1,2) = Sp(1) +! p(2,2) = Sp(2) +! p(3,2) = Sp(3) +! step = -sign(step,p(3,2)) +! CALL stoer(p(1,2),bq2,r2) +! p(1,3) = p(1,2) + 0.5*step*p(4,2) +! p(2,3) = p(2,2) + 0.5*step*p(5,2) +! p(3,3) = p(3,2) + 0.5*step +! CALL stoer(p(1,3),bq3,r3) +! p(1,1) = p(1,2) - step*(2.*p(4,2)-p(4,3)) +! p(2,1) = p(2,2) - step*(2.*p(5,2)-p(5,3)) +! p(3,1) = p(3,2) - step +! CALL stoer(p(1,1),bq1,r1) +! p(1,3) = p(1,2) + step*(20.*p(4,3)-3.*p(4,2)+p(4,1))/18. +! p(2,3) = p(2,2) + step*(20.*p(5,3)-3.*p(5,2)+p(5,1))/18. +! p(3,3) = p(3,2) + step +! CALL stoer(p(1,3),bq3,r3) +! !******************INVERT SENSE IF REQUIRED +! IF ( bq3>bq1 ) THEN +! step = -step +! r3 = r1 +! bq3 = bq1 +! DO i = 1 , 5 +! zz = p(i,1) +! p(i,1) = p(i,3) +! p(i,3) = zz +! ENDDO +! ENDIF +! !******************INITIALIZATION +! step12 = step/12. +! Value = .TRUE. +! bmin = 1.E4 +! bold = 1.E4 +! !******************CORRECTOR (FIELD LINE TRACING) +! n = 0 +! SPAG_Loop_1_1: DO +! p(1,3) = p(1,2) + step12*(5.*p(4,3)+8.*p(4,2)-p(4,1)) +! n = n + 1 +! p(2,3) = p(2,2) + step12*(5.*p(5,3)+8.*p(5,2)-p(5,1)) +! !******************PREDICTOR (FIELD LINE TRACING) +! p(1,4) = p(1,3) + step12*(23.*p(4,3)-16.*p(4,2)+5.*p(4,1)) +! p(2,4) = p(2,3) + step12*(23.*p(5,3)-16.*p(5,2)+5.*p(5,1)) +! p(3,4) = p(3,3) + step +! CALL stoer(p(1,4),bq3,r3) +! DO j = 1 , 3 +! DO i = 1 , 8 +! p(i,j) = p(i,j+1) +! ENDDO +! ENDDO +! b = sqrt(bq3) +! IF ( bBdel ) THEN +! step = step/10. +! spag_nextblock_1 = 2 +! CYCLE SPAG_DispatchLoop_1 +! ENDIF +! EXIT SPAG_Loop_1_1 +! ENDDO SPAG_Loop_1_1 +! spag_nextblock_1 = 3 +! CASE (3) +! Rr0 = rold +! Bequ = bold +! Bdel = bdelta +! EXIT SPAG_DispatchLoop_1 +! END SELECT +! ENDDO SPAG_DispatchLoop_1 +! END SUBROUTINE findb0 + + subroutine findb0(stps,bdel,value,bequ,rr0) + + REAL b , Bdel , bdelta , Bequ , bmin , bold , bq1 , bq2 , bq3 , p , r1 , r2 , r3 , & + rold , Rr0 , Sp , step , step12 , Stps , zz + INTEGER i , irun , j , n + dimension p(8,4),sp(3) + logical value + + common/fidb0/ sp + + step=stps + irun=0 + + main : do + irun=irun+1 + if (irun>5) then + value=.false. + exit main + endif + !*********************first three points + p(1,2)=sp(1) + p(2,2)=sp(2) + p(3,2)=sp(3) + step=-sign(step,p(3,2)) + call stoer(p(1,2),bq2,r2) + p(1,3)=p(1,2)+0.5*step*p(4,2) + p(2,3)=p(2,2)+0.5*step*p(5,2) + p(3,3)=p(3,2)+0.5*step + call stoer(p(1,3),bq3,r3) + p(1,1)=p(1,2)-step*(2.*p(4,2)-p(4,3)) + p(2,1)=p(2,2)-step*(2.*p(5,2)-p(5,3)) + p(3,1)=p(3,2)-step + call stoer(p(1,1),bq1,r1) + p(1,3)=p(1,2)+step*(20.*p(4,3)-3.*p(4,2)+p(4,1))/18. + p(2,3)=p(2,2)+step*(20.*p(5,3)-3.*p(5,2)+p(5,1))/18. + p(3,3)=p(3,2)+step + call stoer(p(1,3),bq3,r3) + !******************invert sense if required + if (bq3>bq1) then + step=-step + r3=r1 + bq3=bq1 + do i=1,5 + zz=p(i,1) + p(i,1)=p(i,3) + p(i,3)=zz + end do + end if + !******************initialization + step12=step/12. + value=.true. + bmin=1.e4 + bold=1.e4 + !******************corrector (field line tracing) + n=0 + corrector : do + p(1,3)=p(1,2)+step12*(5.*p(4,3)+8.*p(4,2)-p(4,1)) + n=n+1 + p(2,3)=p(2,2)+step12*(5.*p(5,3)+8.*p(5,2)-p(5,1)) + !******************predictor (field line tracing) + p(1,4)=p(1,3)+step12*(23.*p(4,3)-16.*p(4,2)+5.*p(4,1)) + p(2,4)=p(2,3)+step12*(23.*p(5,3)-16.*p(5,2)+5.*p(5,1)) + p(3,4)=p(3,3)+step + call stoer(p(1,4),bq3,r3) + do j=1,3 + do i=1,8 + p(i,j)=p(i,j+1) + end do + end do + b=sqrt(bq3) + if (bbold) exit corrector + bold=b + rold=1./r3 + sp(1)=p(1,4) + sp(2)=p(2,4) + sp(3)=p(3,4) + end do corrector + if (bold/=bmin) then + value=.false. + endif + bdelta=(b-bold)/bold + if (bdelta<=bdel) exit main + step=step/10. + end do main + + rr0=rold + bequ=bold + bdel=bdelta + + end subroutine findb0 + +!-------------------------------------------------------------------- +! CALCULATES L-VALUE FOR SPECIFIED GEODAETIC COORDINATES, ALTITUDE +! AND GEMAGNETIC FIELD MODEL. +! REF: G. KLUGE, EUROPEAN SPACE OPERATIONS CENTER, INTERNAL NOTE +! NO. 67, 1970. +! G. KLUGE, COMPUTER PHYSICS COMMUNICATIONS 3, 31-35, 1972 +!-------------------------------------------------------------------- +! CHANGES (D. BILITZA, NOV 87): +! - USING CORRECT DIPOL MOMENT I.E.,DIFFERENT COMMON/MODEL/ +! - USING IGRF EARTH MAGNETIC FIELD MODELS FROM 1945 TO 1990 +!-------------------------------------------------------------------- +! INPUT: ENTRY POINT SHELLG +! GLAT GEODETIC LATITUDE IN DEGREES (NORTH) +! GLON GEODETIC LONGITUDE IN DEGREES (EAST) +! ALT ALTITUDE IN KM ABOVE SEA LEVEL +! +! ENTRY POINT SHELLC +! V(3) CARTESIAN COORDINATES IN EARTH RADII (6371.2 KM) +! X-AXIS POINTING TO EQUATOR AT 0 LONGITUDE +! Y-AXIS POINTING TO EQUATOR AT 90 LONG. +! Z-AXIS POINTING TO NORTH POLE +! +! DIMO DIPOL MOMENT IN GAUSS (NORMALIZED TO EARTH RADIUS) +! +! COMMON +! X(3) NOT USED +! H(144) FIELD MODEL COEFFICIENTS ADJUSTED FOR SHELLG +!----------------------------------------------------------------------- +! OUTPUT: FL L-VALUE +! ICODE =1 NORMAL COMPLETION +! =2 UNPHYSICAL CONJUGATE POINT (FL MEANINGLESS) +! =3 SHELL PARAMETER GREATER THAN LIMIT UP TO +! WHICH ACCURATE CALCULATION IS REQUIRED; +! APPROXIMATION IS USED. +! B0 MAGNETIC FIELD STRENGTH IN GAUSS +!----------------------------------------------------------------------- + + SUBROUTINE shellg(Glat,Glon,Alt,Dimo,Fl,Icode,B0) + IMPLICIT NONE + REAL Alt , Aquad , arg1 , arg2 , B0 , bequ , bq1 , bq2 , bq3 , Bquad , c0 , c1 , c2 , c3 , ct , d , d0 , d1 , d2 , Dimo + REAL dimob0 , e0 , e1 , e2 , Era , ff , fi , Fl , gg , Glat , Glon , H , hli , oradik , oterm , p , r , r1 , r2 , r3 + REAL r3h , radik , rlat , rlon , rmax , rmin , rq , Sp , st , step , step12 , step2 , steq , stp , t , term , Umr , V , X + REAL xx , z , zq , zz + INTEGER i , Icode , iequ , n + + DIMENSION V(3) , p(8,100) , Sp(3) + + real,dimension(3,3),parameter :: u = reshape([ +0.3511737 , -0.9148385 , -0.1993679 , & + +0.9335804 , +0.3583680 , +0.0000000 , & + +0.0714471 , -0.1861260 , +0.9799247], [3,3]) + + COMMON X(3) , H(144) + COMMON /fidb0 / Sp + COMMON /gener / Umr , Era , Aquad , Bquad + + !-- RMIN, RMAX ARE BOUNDARIES FOR IDENTIFICATION OF ICODE=2 AND 3 + !-- STEP IS STEP SIZE FOR FIELD LINE TRACING + !-- STEQ IS STEP SIZE FOR INTEGRATION + + DATA rmin , rmax/0.05 , 1.01/ + DATA step , steq/0.20 , 0.03/ + bequ = 1.E10 + + !*****ENTRY POINT SHELLG TO BE USED WITH GEODETIC CO-ORDINATES + rlat = Glat*Umr + ct = sin(rlat) + st = cos(rlat) + d = sqrt(Aquad-(Aquad-Bquad)*ct*ct) + X(1) = (Alt+Aquad/d)*st/Era + X(3) = (Alt+Bquad/d)*ct/Era + rlon = Glon*Umr + X(2) = X(1)*sin(rlon) + X(1) = X(1)*cos(rlon) + CALL spag_block_1() + RETURN + +!*****ENTRY POINT SHELLC TO BE USED WITH CARTESIAN CO-ORDINATES + ENTRY shellc(V,Fl,B0) + X(1) = V(1) + X(2) = V(2) + X(3) = V(3) + CALL spag_block_1() + +CONTAINS + + SUBROUTINE spag_block_1 + + integer,parameter :: max_loop_index = 100 ! 3333 <--- original code had 3333 ... was this a bug ???? + + !*****CONVERT TO DIPOL-ORIENTED CO-ORDINATES + rq = 1./(X(1)*X(1)+X(2)*X(2)+X(3)*X(3)) + r3h = sqrt(rq*sqrt(rq)) + p(1,2) = (X(1)*u(1,1)+X(2)*u(2,1)+X(3)*u(3,1))*r3h + p(2,2) = (X(1)*u(1,2)+X(2)*u(2,2))*r3h + p(3,2) = (X(1)*u(1,3)+X(2)*u(2,3)+X(3)*u(3,3))*rq + ! *****FIRST THREE POINTS OF FIELD LINE + step = -sign(step,p(3,2)) + CALL stoer(p(1,2),bq2,r2) + B0 = sqrt(bq2) + p(1,3) = p(1,2) + 0.5*step*p(4,2) + p(2,3) = p(2,2) + 0.5*step*p(5,2) + p(3,3) = p(3,2) + 0.5*step + CALL stoer(p(1,3),bq3,r3) + p(1,1) = p(1,2) - step*(2.*p(4,2)-p(4,3)) + p(2,1) = p(2,2) - step*(2.*p(5,2)-p(5,3)) + p(3,1) = p(3,2) - step + CALL stoer(p(1,1),bq1,r1) + p(1,3) = p(1,2) + step*(20.*p(4,3)-3.*p(4,2)+p(4,1))/18. + p(2,3) = p(2,2) + step*(20.*p(5,3)-3.*p(5,2)+p(5,1))/18. + p(3,3) = p(3,2) + step + CALL stoer(p(1,3),bq3,r3) + !*****INVERT SENSE IF REQUIRED + IF ( bq3>bq1 ) THEN + step = -step + r3 = r1 + bq3 = bq1 + DO i = 1 , 7 + zz = p(i,1) + p(i,1) = p(i,3) + p(i,3) = zz + ENDDO + ENDIF + !*****SEARCH FOR LOWEST MAGNETIC FIELD STRENGTH + IF ( bq11. ) THEN + !*****PREDICTOR (FIELD LINE TRACING) + p(1,n+1) = p(1,n) + step12*(23.*p(4,n)-16.*p(4,n-1)+5.*p(4,n-2)) + p(2,n+1) = p(2,n) + step12*(23.*p(5,n)-16.*p(5,n-1)+5.*p(5,n-2)) + p(3,n+1) = p(3,n) + step + CALL stoer(p(1,n+1),bq3,r3) + !*****SEARCH FOR LOWEST MAGNETIC FIELD STRENGTH + IF ( bq3rmax ) THEN + Icode = 2 + radik = radik - 12.*(r-rmax)**2 + ENDIF + IF ( radik+radik<=oradik ) EXIT main + term = sqrt(radik)*ff*((e2*t+e1)*t+e0)/(rq+zq) + fi = fi + stp*(oterm+term) + oradik = radik + oterm = term + stp = r*steq + z = z + stp + ENDIF + ENDDO inner + ENDDO main + IF ( iequ<2 ) iequ = 2 + Sp(1) = p(1,iequ-1) + Sp(2) = p(2,iequ-1) + Sp(3) = p(3,iequ-1) + IF ( oradik>=1E-15 ) fi = fi + stp/0.75*oterm*oradik/(oradik-radik) + ! + !-- The minimal allowable value of FI was changed from 1E-15 to 1E-12, + !-- because 1E-38 is the minimal allowable arg. for ALOG in our envir. + !-- D. Bilitza, Nov 87. + ! + fi = 0.5*abs(fi)/sqrt(B0) + 1E-12 + !*****COMPUTE L FROM B AND I. SAME AS CARMEL IN INVAR. + ! + !-- Correct dipole moment is used here. D. Bilitza, Nov 87. + ! + dimob0 = Dimo/B0 + arg1 = alog(fi) + arg2 = alog(dimob0) +! arg = FI*FI*FI/DIMOB0 +! if(abs(arg).gt.88.0) arg=88.0 + xx = 3*arg1 - arg2 + IF ( xx>23.0 ) THEN + gg = xx - 3.0460681E0 + ELSEIF ( xx>11.7 ) THEN + gg = (((((2.8212095E-8*xx-3.8049276E-6)*xx+2.170224E-4)*xx-6.7310339E-3)*xx+1.2038224E-1)*xx-1.8461796E-1) & + & *xx + 2.0007187E0 + ELSEIF ( xx>+3.0 ) THEN + gg = ((((((((6.3271665E-10*xx-3.958306E-8)*xx+9.9766148E-07)*xx-1.2531932E-5)*xx+7.9451313E-5)*xx-3.2077032E-4) & + & *xx+2.1680398E-3)*xx+1.2817956E-2)*xx+4.3510529E-1)*xx + 6.222355E-1 + ELSEIF ( xx>-3.0 ) THEN + gg = ((((((((2.6047023E-10*xx+2.3028767E-9)*xx-2.1997983E-8)*xx-5.3977642E-7)*xx-3.3408822E-6)*xx+3.8379917E-5) & + & *xx+1.1784234E-3)*xx+1.4492441E-2)*xx+4.3352788E-1)*xx + 6.228644E-1 + ELSEIF ( xx>-22. ) THEN + gg = ((((((((-8.1537735E-14*xx+8.3232531E-13)*xx+1.0066362E-9)*xx+8.1048663E-8)*xx+3.2916354E-6)*xx+8.2711096E-5) & + & *xx+1.3714667E-3)*xx+1.5017245E-2)*xx+4.3432642E-1)*xx + 6.2337691E-1 + ELSE + gg = 3.33338E-1*xx + 3.0062102E-1 + ENDIF + Fl = exp(alog((1.+exp(gg))*dimob0)/3.0) + RETURN + END SUBROUTINE spag_block_1 + +END SUBROUTINE shellg + +!*==stoer.f90 processed by SPAG 8.01MH 09:18 3 Feb 2024 +!!SPAG Open source Personal, Educational or Academic User NON-COMMERCIAL USE - Not for use on proprietary or closed source code +! +! +SUBROUTINE stoer(P,Bq,R) + IMPLICIT NONE +!*** Start of declarations inserted by SPAG + REAL Bq , dr , dsq , dx , dxm , dy , dym , dz , dzm , fli , H , P , q , R , rq , u , wr , Xi , xm , ym + REAL zm +!*** End of declarations inserted by SPAG +!******************************************************************* +!* SUBROUTINE USED FOR FIELD LINE TRACING IN SHELLG * +!* CALLS ENTRY POINT FELDI IN GEOMAGNETIC FIELD SUBROUTINE FELDG * +!******************************************************************* + DIMENSION P(7) , u(3,3) + COMMON Xi(3) , H(144) +!*****XM,YM,ZM ARE GEOMAGNETIC CARTESIAN INVERSE CO-ORDINATES + zm = P(3) + fli = P(1)*P(1) + P(2)*P(2) + 1E-15 + R = 0.5*(fli+sqrt(fli*fli+(zm+zm)**2)) + rq = R*R + wr = sqrt(R) + xm = P(1)*wr + ym = P(2)*wr +!*****TRANSFORM TO GEOGRAPHIC CO-ORDINATE SYSTEM + DATA u/ + 0.3511737 , -0.9148385 , -0.1993679 , +0.9335804 , +0.3583680 , +0.0000000 , +0.0714471 , -0.1861260 , +0.9799247/ + Xi(1) = xm*u(1,1) + ym*u(1,2) + zm*u(1,3) + Xi(2) = xm*u(2,1) + ym*u(2,2) + zm*u(2,3) + Xi(3) = xm*u(3,1) + zm*u(3,3) +!*****COMPUTE DERIVATIVES +! Changed from CALL FELDI(XI,H); XI, H are in COMMON block; results +! are the same; dkb Feb 1998 + CALL feldi + q = H(1)/rq + dx = H(3) + H(3) + q*Xi(1) + dy = H(4) + H(4) + q*Xi(2) + dz = H(2) + H(2) + q*Xi(3) +!*****TRANSFORM BACK TO GEOMAGNETIC CO-ORDINATE SYSTEM + dxm = u(1,1)*dx + u(2,1)*dy + u(3,1)*dz + dym = u(1,2)*dx + u(2,2)*dy + dzm = u(1,3)*dx + u(2,3)*dy + u(3,3)*dz + dr = (xm*dxm+ym*dym+zm*dzm)/R +!*****FORM SLOWLY VARYING EXPRESSIONS + P(4) = (wr*dxm-0.5*P(1)*dr)/(R*dzm) + P(5) = (wr*dym-0.5*P(2)*dr)/(R*dzm) + dsq = rq*(dxm*dxm+dym*dym+dzm*dzm) + Bq = dsq*rq*rq + P(6) = sqrt(dsq/(rq+3.*zm*zm)) + P(7) = P(6)*(rq+zm*zm)/(rq*dzm) +END SUBROUTINE stoer + +!*==feldg.f90 processed by SPAG 8.01MH 09:18 3 Feb 2024 +!!SPAG Open source Personal, Educational or Academic User NON-COMMERCIAL USE - Not for use on proprietary or closed source code +! +! +! SUBROUTINE feldg(Glat,Glon,Alt,Bnorth,Beast,Bdown,Babs) +! IMPLICIT NONE +! !*** Start of declarations inserted by SPAG +! REAL Alt , Aquad , B , Babs , Bdown , Beast , Bnorth , Bquad , brho , bxxx , byyy , bzzz , cp , ct , d , Era , f , G , Glat , & +! & Glon +! REAL H , rho , rlat , rlon , rq , s , sp , st , t , Time , Umr , V , x , Xi , xxx , y , yyy , z , zzz +! INTEGER i , ih , ihmax , il , imax , is , k , last , m , Nmax +! !*** End of declarations inserted by SPAG +! !------------------------------------------------------------------- +! ! CALCULATES EARTH MAGNETIC FIELD FROM SPHERICAL HARMONICS MODEL +! ! REF: G. KLUGE, EUROPEAN SPACE OPERATIONS CENTRE, INTERNAL NOTE 61, +! ! 1970. +! !-------------------------------------------------------------------- +! ! CHANGES (D. BILITZA, NOV 87): +! ! - FIELD COEFFICIENTS IN BINARY DATA FILES INSTEAD OF BLOCK DATA +! ! - CALCULATES DIPOL MOMENT +! !-------------------------------------------------------------------- +! ! INPUT: ENTRY POINT FELDG +! ! GLAT GEODETIC LATITUDE IN DEGREES (NORTH) +! ! GLON GEODETIC LONGITUDE IN DEGREES (EAST) +! ! ALT ALTITUDE IN KM ABOVE SEA LEVEL +! ! +! ! ENTRY POINT FELDC +! ! V(3) CARTESIAN COORDINATES IN EARTH RADII (6371.2 KM) +! ! X-AXIS POINTING TO EQUATOR AT 0 LONGITUDE +! ! Y-AXIS POINTING TO EQUATOR AT 90 LONG. +! ! Z-AXIS POINTING TO NORTH POLE +! ! +! ! COMMON BLANK AND ENTRY POINT FELDI ARE NEEDED WHEN USED +! ! IN CONNECTION WITH L-CALCULATION PROGRAM SHELLG. +! ! +! ! COMMON /MODEL/ AND /GENER/ +! ! UMR = ATAN(1.0)*4./180. *UMR= +! ! ERA EARTH RADIUS FOR NORMALIZATION OF CARTESIAN +! ! COORDINATES (6371.2 KM) +! ! AQUAD, BQUAD SQUARE OF MAJOR AND MINOR HALF AXIS FOR +! ! EARTH ELLIPSOID AS RECOMMENDED BY INTERNATIONAL +! ! ASTRONOMICAL UNION (6378.160, 6356.775 KM). +! ! NMAX MAXIMUM ORDER OF SPHERICAL HARMONICS +! ! TIME YEAR (DECIMAL: 1973.5) FOR WHICH MAGNETIC +! ! FIELD IS TO BE CALCULATED +! ! G(M) NORMALIZED FIELD COEFFICIENTS (SEE FELDCOF) +! ! M=NMAX*(NMAX+2) +! !------------------------------------------------------------------------ +! ! OUTPUT: BABS MAGNETIC FIELD STRENGTH IN GAUSS +! ! BNORTH, BEAST, BDOWN COMPONENTS OF THE FIELD WITH RESPECT +! ! TO THE LOCAL GEODETIC COORDINATE SYSTEM, WITH AXIS +! ! POINTING IN THE TANGENTIAL PLANE TO THE NORTH, EAST +! ! AND DOWNWARD. +! !----------------------------------------------------------------------- +! DIMENSION V(3) , B(3) +! CHARACTER*14 Name +! COMMON Xi(3) , H(144) +! COMMON /model / Name , Nmax , Time , G(144) +! COMMON /gener / Umr , Era , Aquad , Bquad +! INTEGER :: spag_nextblock_1 +! INTEGER :: spag_nextblock_2 +! spag_nextblock_1 = 1 +! SPAG_DispatchLoop_1: DO +! SELECT CASE (spag_nextblock_1) +! CASE (1) +! ! +! !-- IS RECORDS ENTRY POINT +! ! +! !*****ENTRY POINT FELDG TO BE USED WITH GEODETIC CO-ORDINATES +! is = 1 +! rlat = Glat*Umr +! ct = sin(rlat) +! st = cos(rlat) +! d = sqrt(Aquad-(Aquad-Bquad)*ct*ct) +! rlon = Glon*Umr +! cp = cos(rlon) +! sp = sin(rlon) +! zzz = (Alt+Bquad/d)*ct/Era +! rho = (Alt+Aquad/d)*st/Era +! xxx = rho*cp +! yyy = rho*sp +! spag_nextblock_1 = 2 +! CYCLE SPAG_DispatchLoop_1 +! ! +! !*****ENTRY POINT FELDC TO BE USED WITH CARTESIAN CO-ORDINATES +! ENTRY feldc(V,B) +! is = 2 +! xxx = V(1) +! yyy = V(2) +! zzz = V(3) +! spag_nextblock_1 = 2 +! CASE (2) +! rq = 1./(xxx*xxx+yyy*yyy+zzz*zzz) +! Xi(1) = xxx*rq +! Xi(2) = yyy*rq +! Xi(3) = zzz*rq +! spag_nextblock_1 = 3 +! CYCLE SPAG_DispatchLoop_1 +! ! +! !*****ENTRY POINT FELDI USED FOR L COMPUTATION +! ENTRY feldi +! is = 3 +! spag_nextblock_1 = 3 +! CASE (3) +! ihmax = Nmax*Nmax + 1 +! last = ihmax + Nmax + Nmax +! imax = Nmax + Nmax - 1 +! DO i = ihmax , last +! H(i) = G(i) +! ENDDO +! DO k = 1 , 3 , 2 +! spag_nextblock_2 = 1 +! SPAG_DispatchLoop_2: DO +! SELECT CASE (spag_nextblock_2) +! CASE (1) +! i = imax +! ih = ihmax +! spag_nextblock_2 = 2 +! CASE (2) +! il = ih - i +! f = 2./float(i-k+2) +! x = Xi(1)*f +! y = Xi(2)*f +! z = Xi(3)*(f+f) +! i = i - 2 +! IF ( i<1 ) THEN +! spag_nextblock_2 = 3 +! CYCLE SPAG_DispatchLoop_2 +! ENDIF +! IF ( i/=1 ) THEN +! DO m = 3 , i , 2 +! H(il+m+1) = G(il+m+1) + z*H(ih+m+1) + x*(H(ih+m+3)-H(ih+m-1)) - y*(H(ih+m+2)+H(ih+m-2)) +! H(il+m) = G(il+m) + z*H(ih+m) + x*(H(ih+m+2)-H(ih+m-2)) + y*(H(ih+m+3)+H(ih+m-1)) +! ENDDO +! ENDIF +! H(il+2) = G(il+2) + z*H(ih+2) + x*H(ih+4) - y*(H(ih+3)+H(ih)) +! H(il+1) = G(il+1) + z*H(ih+1) + y*H(ih+4) + x*(H(ih+3)-H(ih)) +! spag_nextblock_2 = 3 +! CASE (3) +! H(il) = G(il) + z*H(ih) + 2.*(x*H(ih+1)+y*H(ih+2)) +! ih = il +! IF ( i>=k ) THEN +! spag_nextblock_2 = 2 +! CYCLE SPAG_DispatchLoop_2 +! ENDIF +! EXIT SPAG_DispatchLoop_2 +! END SELECT +! ENDDO SPAG_DispatchLoop_2 +! ENDDO +! IF ( is==3 ) RETURN +! s = .5*H(1) + 2.*(H(2)*Xi(3)+H(3)*Xi(1)+H(4)*Xi(2)) +! t = (rq+rq)*sqrt(rq) +! bxxx = t*(H(3)-s*xxx) +! byyy = t*(H(4)-s*yyy) +! bzzz = t*(H(2)-s*zzz) +! IF ( is==2 ) THEN +! B(1) = bxxx +! B(2) = byyy +! B(3) = bzzz +! RETURN +! ENDIF +! Babs = sqrt(bxxx*bxxx+byyy*byyy+bzzz*bzzz) +! Beast = byyy*cp - bxxx*sp +! brho = byyy*sp + bxxx*cp +! Bnorth = bzzz*st - brho*ct +! Bdown = -bzzz*ct - brho*st +! RETURN +! END SELECT +! ENDDO SPAG_DispatchLoop_1 +! END SUBROUTINE feldg + +!.... NOTE: this one was broken by SPAG (above)... so revert to original and see +! if we can manually refactor it. +subroutine feldg(glat,glon,alt,bnorth,beast,bdown,babs) + !------------------------------------------------------------------- + ! calculates earth magnetic field from spherical harmonics model + ! ref: g. kluge, european space operations centre, internal note 61, + ! 1970. + !-------------------------------------------------------------------- + ! changes (d. bilitza, nov 87): + ! - field coefficients in binary data files instead of block data + ! - calculates dipol moment + !-------------------------------------------------------------------- + ! input: entry point feldg + ! glat geodetic latitude in degrees (north) + ! glon geodetic longitude in degrees (east) + ! alt altitude in km above sea level + ! + ! entry point feldc + ! v(3) cartesian coordinates in earth radii (6371.2 km) + ! x-axis pointing to equator at 0 longitude + ! y-axis pointing to equator at 90 long. + ! z-axis pointing to north pole + ! + ! common blank and entry point feldi are needed when used + ! in connection with l-calculation program shellg. + ! + ! common /model/ and /gener/ + ! umr = atan(1.0)*4./180. *umr= + ! era earth radius for normalization of cartesian + ! coordinates (6371.2 km) + ! aquad, bquad square of major and minor half axis for + ! earth ellipsoid as recommended by international + ! astronomical union (6378.160, 6356.775 km). + ! nmax maximum order of spherical harmonics + ! time year (decimal: 1973.5) for which magnetic + ! field is to be calculated + ! g(m) normalized field coefficients (see feldcof) + ! m=nmax*(nmax+2) + !------------------------------------------------------------------------ + ! output: babs magnetic field strength in gauss + ! bnorth, beast, bdown components of the field with respect + ! to the local geodetic coordinate system, with axis + ! pointing in the tangential plane to the north, east + ! and downward. + !----------------------------------------------------------------------- + + !*** Start of declarations inserted by SPAG + REAL Alt , Aquad , B , Babs , Bdown , Beast , Bnorth , Bquad , brho , bxxx , & + byyy , bzzz , cp , ct , d , Era , f , G , Glat , Glon + REAL H , rho , rlat , rlon , rq , s , sp , st , t , Time , Umr , V , x , Xi , xxx , y , yyy , z , zzz + INTEGER i , ih , ihmax , il , imax , is , k , last , m , Nmax + !*** End of declarations inserted by SPAG + + dimension v(3),b(3) + character*14 name + + common xi(3),h(144) + common/model/ name,nmax,time,g(144) + common/gener/ umr,era,aquad,bquad + ! + !-- is records entry point + ! + !*****entry point feldg to be used with geodetic co-ordinates + is=1 + rlat=glat*umr + ct=sin(rlat) + st=cos(rlat) + d=sqrt(aquad-(aquad-bquad)*ct*ct) + rlon=glon*umr + cp=cos(rlon) + sp=sin(rlon) + zzz=(alt+bquad/d)*ct/era + rho=(alt+aquad/d)*st/era + xxx=rho*cp + yyy=rho*sp + goto 10 + ! + !*****entry point feldc to be used with cartesian co-ordinates + entry feldc(v,b) + is=2 + xxx=v(1) + yyy=v(2) + zzz=v(3) + 10 rq=1./(xxx*xxx+yyy*yyy+zzz*zzz) + xi(1)=xxx*rq + xi(2)=yyy*rq + xi(3)=zzz*rq + goto 20 + ! + !*****entry point feldi used for l computation + entry feldi + is=3 + 20 ihmax=nmax*nmax+1 + last=ihmax+nmax+nmax + imax=nmax+nmax-1 + do i=ihmax,last + h(i)=g(i) + end do + do k=1,3,2 + i=imax + ih=ihmax + 1 il=ih-i + f=2./float(i-k+2) + x=xi(1)*f + y=xi(2)*f + z=xi(3)*(f+f) + i=i-2 + if ((i-1)>=0) then + if ((i-1)>0) then + do m=3,i,2 + h(il+m+1)=g(il+m+1)+z*h(ih+m+1)+x*(h(ih+m+3)-h(ih+m-1))-y*(h(ih+m+2)+h(ih+m-2)) + h(il+m)=g(il+m)+z*h(ih+m)+x*(h(ih+m+2)-h(ih+m-2))+y*(h(ih+m+3)+h(ih+m-1)) + end do + end if + h(il+2)=g(il+2)+z*h(ih+2)+x*h(ih+4)-y*(h(ih+3)+h(ih)) + h(il+1)=g(il+1)+z*h(ih+1)+y*h(ih+4)+x*(h(ih+3)-h(ih)) + end if + h(il)=g(il)+z*h(ih)+2.*(x*h(ih+1)+y*h(ih+2)) + ih=il + if (i>=k) goto 1 + end do + + if (is==3) return + s=.5*h(1)+2.*(h(2)*xi(3)+h(3)*xi(1)+h(4)*xi(2)) + t=(rq+rq)*sqrt(rq) + bxxx=t*(h(3)-s*xxx) + byyy=t*(h(4)-s*yyy) + bzzz=t*(h(2)-s*zzz) + if (is==2) then + b(1)=bxxx + b(2)=byyy + b(3)=bzzz + else + babs=sqrt(bxxx*bxxx+byyy*byyy+bzzz*bzzz) + beast=byyy*cp-bxxx*sp + brho=byyy*sp+bxxx*cp + bnorth=bzzz*st-brho*ct + bdown=-bzzz*ct-brho*st + end if + + end subroutine feldg + +!*==feldcof.f90 processed by SPAG 8.01MH 09:18 3 Feb 2024 +!!SPAG Open source Personal, Educational or Academic User NON-COMMERCIAL USE - Not for use on proprietary or closed source code +! +! +SUBROUTINE feldcof(Year,Dimo) + IMPLICIT NONE +!*** Start of declarations inserted by SPAG + REAL Aquad , Bquad , Dimo , dte1 , dte2 , dtemod , Erad , Gh1 , gh2 , gha , sqrt2 , Time , Umr , Year + INTEGER i , ier , is , iu , iyea , j , l , m , n , Nmax , nmax1 , nmax2 , numye +!*** End of declarations inserted by SPAG +!------------------------------------------------------------------------ +! DETERMINES COEFFICIENTS AND DIPOL MOMENT FROM IGRF MODELS +! +! INPUT: YEAR DECIMAL YEAR FOR WHICH GEOMAGNETIC FIELD IS TO +! BE CALCULATED (e.g.:1995.5 for day 185 of 1995) +! OUTPUT: DIMO GEOMAGNETIC DIPOL MOMENT IN GAUSS (NORMALIZED +! TO EARTH'S RADIUS) AT THE TIME (YEAR) +! D. BILITZA, NSSDC, GSFC, CODE 633, GREENBELT, MD 20771, +! (301)286-9536 NOV 1987. +! -corrected for 2000 update - dkb- 5/31/2000 +! ### updated to IGRF-2000 version -dkb- 5/31/2000 +! ### updated to IGRF-2005 version -dkb- 3/24/2000 +!----------------------------------------------------------------------- + CHARACTER*14 filmod , Fil1 , fil2 +! ### FILMOD, DTEMOD arrays +1 + DIMENSION Gh1(144) , gh2(120) , gha(144) , filmod(17) , dtemod(17) + DOUBLE PRECISION x , f0 , f + COMMON /model/ Fil1 , Nmax , Time , Gh1 + COMMON /gener/ Umr , Erad , Aquad , Bquad +! ### changed to conform with IGRF 45-95, also FILMOD, DTEMOD arrays +1 + DATA filmod/'dgrf1945.dat' , 'dgrf1950.dat' , 'dgrf1955.dat' , 'dgrf1960.dat' , 'dgrf1965.dat' , 'dgrf1970.dat' , & + & 'dgrf1975.dat' , 'dgrf1980.dat' , 'dgrf1985.dat' , 'dgrf1990.dat' , 'dgrf1995.dat' , 'dgrf2000.dat' , 'dgrf2005.dat' , & + &'dgrf2010.dat' , 'dgrf2015.dat' , 'igrf2020.dat' , 'igrf2020s.dat'/ + DATA dtemod/1945. , 1950. , 1955. , 1960. , 1965. , 1970. , 1975. , 1980. , 1985. , 1990. , 1995. , 2000. , 2005. , 2010. , & + & 2015. , 2020. , 2025./ +! +! ### numye is number of 5-year priods represented by IGRF +! + numye = 16 +! +! IS=0 FOR SCHMIDT NORMALIZATION IS=1 GAUSS NORMALIZATION +! IU IS INPUT UNIT NUMBER FOR IGRF COEFFICIENT SETS +! + iu = 10 + is = 0 +!-- DETERMINE IGRF-YEARS FOR INPUT-YEAR + Time = Year + iyea = int(Year/5.)*5 + l = (iyea-1945)/5 + 1 + IF ( l<1 ) l = 1 + IF ( l>numye ) l = numye + dte1 = dtemod(l) + Fil1 = filmod(l) + dte2 = dtemod(l+1) + fil2 = filmod(l+1) +!-- GET IGRF COEFFICIENTS FOR THE BOUNDARY YEARS + CALL getshc(iu,Fil1,nmax1,Erad,Gh1,ier) + IF ( ier/=0 ) STOP + CALL getshc(iu,fil2,nmax2,Erad,gh2,ier) + IF ( ier/=0 ) STOP +!-- DETERMINE IGRF COEFFICIENTS FOR YEAR + IF ( l<=numye-1 ) THEN + CALL intershc(Year,dte1,nmax1,Gh1,dte2,nmax2,gh2,Nmax,gha) + ELSE + CALL extrashc(Year,dte1,nmax1,Gh1,nmax2,gh2,Nmax,gha) + ENDIF +!-- DETERMINE MAGNETIC DIPOL MOMENT AND COEFFIECIENTS G + f0 = 0.D0 + DO j = 1 , 3 + f = gha(j)*1.D-5 + f0 = f0 + f*f + ENDDO + Dimo = sqrt(f0) + + Gh1(1) = 0.0 + i = 2 + f0 = 1.D-5 + IF ( is==0 ) f0 = -f0 + sqrt2 = sqrt(2.) + + DO n = 1 , Nmax + x = n + f0 = f0*x*x/(4.D0*x-2.D0) + IF ( is==0 ) f0 = f0*(2.D0*x-1.D0)/x + f = f0*0.5D0 + IF ( is==0 ) f = f*sqrt2 + Gh1(i) = gha(i-1)*f0 + i = i + 1 + DO m = 1 , n + f = f*(x+m)/(x-m+1.D0) + IF ( is==0 ) f = f*sqrt((x-m+1.D0)/(x+m)) + Gh1(i) = gha(i-1)*f + Gh1(i+1) = gha(i)*f + i = i + 2 + ENDDO + ENDDO +END SUBROUTINE feldcof + +!*==getshc.f90 processed by SPAG 8.01MH 09:18 3 Feb 2024 +!!SPAG Open source Personal, Educational or Academic User NON-COMMERCIAL USE - Not for use on proprietary or closed source code +! +! +SUBROUTINE getshc(Iu,Fspec,Nmax,Erad,Gh,Ier) + IMPLICIT NONE +!*** Start of declarations inserted by SPAG + REAL Erad , g , Gh , h + INTEGER i , Ier , Iu , m , mm , n , Nmax , nn +!*** End of declarations inserted by SPAG + +! =============================================================== +! +! Version 1.01 +! +! Reads spherical harmonic coefficients from the specified +! file into an array. +! +! Input: +! IU - Logical unit number +! FSPEC - File specification +! +! Output: +! NMAX - Maximum degree and order of model +! ERAD - Earth's radius associated with the spherical +! harmonic coefficients, in the same units as +! elevation +! GH - Schmidt quasi-normal internal spherical +! harmonic coefficients +! IER - Error number: = 0, no error +! = -2, records out of order +! = FORTRAN run-time error number +! +! A. Zunde +! USGS, MS 964, Box 25046 Federal Center, Denver, CO 80225 +! +! =============================================================== + + CHARACTER Fspec*(*) + DIMENSION Gh(*) + +! --------------------------------------------------------------- +! Open coefficient file. Read past first header record. +! Read degree and order of model and Earth's radius. +! --------------------------------------------------------------- + OPEN (Iu,FILE=Fspec,STATUS='OLD',IOSTAT=Ier,ERR=100) + READ (Iu,*,IOSTAT=Ier,ERR=100) + READ (Iu,*,IOSTAT=Ier,ERR=100) Nmax , Erad +! --------------------------------------------------------------- +! Read the coefficient file, arranged as follows: +! +! N M G H +! ---------------------- +! / 1 0 GH(1) - +! / 1 1 GH(2) GH(3) +! / 2 0 GH(4) - +! / 2 1 GH(5) GH(6) +! NMAX*(NMAX+3)/2 / 2 2 GH(7) GH(8) +! records \ 3 0 GH(9) - +! \ . . . . +! \ . . . . +! NMAX*(NMAX+2) \ . . . . +! elements in GH \ NMAX NMAX . . +! +! N and M are, respectively, the degree and order of the +! coefficient. +! --------------------------------------------------------------- + + i = 0 + main: DO nn = 1 , Nmax + DO mm = 0 , nn + READ (Iu,*,IOSTAT=Ier,ERR=100) n , m , g , h + IF ( nn/=n .OR. mm/=m ) THEN + Ier = -2 + EXIT main + ENDIF + i = i + 1 + Gh(i) = g + IF ( m/=0 ) THEN + i = i + 1 + Gh(i) = h + ENDIF + ENDDO + ENDDO main + + 100 CLOSE (Iu) + +END SUBROUTINE getshc + +!*==intershc.f90 processed by SPAG 8.01MH 09:18 3 Feb 2024 +!!SPAG Open source Personal, Educational or Academic User NON-COMMERCIAL USE - Not for use on proprietary or closed source code +! +! +SUBROUTINE intershc(Date,Dte1,Nmax1,Gh1,Dte2,Nmax2,Gh2,Nmax,Gh) + IMPLICIT NONE +!*** Start of declarations inserted by SPAG + REAL Date , Dte1 , Dte2 , factor , Gh , Gh1 , Gh2 + INTEGER i , k , l , Nmax , Nmax1 , Nmax2 +!*** End of declarations inserted by SPAG + +! =============================================================== +! +! Version 1.01 +! +! Interpolates linearly, in time, between two spherical +! harmonic models. +! +! Input: +! DATE - Date of resulting model (in decimal year) +! DTE1 - Date of earlier model +! NMAX1 - Maximum degree and order of earlier model +! GH1 - Schmidt quasi-normal internal spherical +! harmonic coefficients of earlier model +! DTE2 - Date of later model +! NMAX2 - Maximum degree and order of later model +! GH2 - Schmidt quasi-normal internal spherical +! harmonic coefficients of later model +! +! Output: +! GH - Coefficients of resulting model +! NMAX - Maximum degree and order of resulting model +! +! A. Zunde +! USGS, MS 964, Box 25046 Federal Center, Denver, CO 80225 +! +! =============================================================== + + DIMENSION Gh1(*) , Gh2(*) , Gh(*) + +! --------------------------------------------------------------- +! The coefficients (GH) of the resulting model, at date +! DATE, are computed by linearly interpolating between the +! coefficients of the earlier model (GH1), at date DTE1, +! and those of the later model (GH2), at date DTE2. If one +! model is smaller than the other, the interpolation is +! performed with the missing coefficients assumed to be 0. +! --------------------------------------------------------------- + + factor = (Date-Dte1)/(Dte2-Dte1) + + IF ( Nmax1==Nmax2 ) THEN + k = Nmax1*(Nmax1+2) + Nmax = Nmax1 + ELSEIF ( Nmax1>Nmax2 ) THEN + k = Nmax2*(Nmax2+2) + l = Nmax1*(Nmax1+2) + DO i = k + 1 , l + Gh(i) = Gh1(i) + factor*(-Gh1(i)) + ENDDO + Nmax = Nmax1 + ELSE + k = Nmax1*(Nmax1+2) + l = Nmax2*(Nmax2+2) + DO i = k + 1 , l + Gh(i) = factor*Gh2(i) + ENDDO + Nmax = Nmax2 + ENDIF + + DO i = 1 , k + Gh(i) = Gh1(i) + factor*(Gh2(i)-Gh1(i)) + ENDDO + +END SUBROUTINE intershc + +!*==extrashc.f90 processed by SPAG 8.01MH 09:18 3 Feb 2024 +!!SPAG Open source Personal, Educational or Academic User NON-COMMERCIAL USE - Not for use on proprietary or closed source code +! +! +SUBROUTINE extrashc(Date,Dte1,Nmax1,Gh1,Nmax2,Gh2,Nmax,Gh) + IMPLICIT NONE +!*** Start of declarations inserted by SPAG + REAL Date , Dte1 , factor , Gh , Gh1 , Gh2 + INTEGER i , k , l , Nmax , Nmax1 , Nmax2 +!*** End of declarations inserted by SPAG + +! =============================================================== +! +! Version 1.01 +! +! Extrapolates linearly a spherical harmonic model with a +! rate-of-change model. +! +! Input: +! DATE - Date of resulting model (in decimal year) +! DTE1 - Date of base model +! NMAX1 - Maximum degree and order of base model +! GH1 - Schmidt quasi-normal internal spherical +! harmonic coefficients of base model +! NMAX2 - Maximum degree and order of rate-of-change +! model +! GH2 - Schmidt quasi-normal internal spherical +! harmonic coefficients of rate-of-change model +! +! Output: +! GH - Coefficients of resulting model +! NMAX - Maximum degree and order of resulting model +! +! A. Zunde +! USGS, MS 964, Box 25046 Federal Center, Denver, CO 80225 +! +! =============================================================== + + DIMENSION Gh1(*) , Gh2(*) , Gh(*) + +! --------------------------------------------------------------- +! The coefficients (GH) of the resulting model, at date +! DATE, are computed by linearly extrapolating the coef- +! ficients of the base model (GH1), at date DTE1, using +! those of the rate-of-change model (GH2), at date DTE2. If +! one model is smaller than the other, the extrapolation is +! performed with the missing coefficients assumed to be 0. +! --------------------------------------------------------------- + + factor = (Date-Dte1) + + IF ( Nmax1==Nmax2 ) THEN + k = Nmax1*(Nmax1+2) + Nmax = Nmax1 + ELSEIF ( Nmax1>Nmax2 ) THEN + k = Nmax2*(Nmax2+2) + l = Nmax1*(Nmax1+2) + DO i = k + 1 , l + Gh(i) = Gh1(i) + ENDDO + Nmax = Nmax1 + ELSE + k = Nmax1*(Nmax1+2) + l = Nmax2*(Nmax2+2) + DO i = k + 1 , l + Gh(i) = factor*Gh2(i) + ENDDO + Nmax = Nmax2 + ENDIF + + DO i = 1 , k + Gh(i) = Gh1(i) + factor*Gh2(i) + ENDDO + +END SUBROUTINE extrashc + +!*==initize.f90 processed by SPAG 8.01MH 09:18 3 Feb 2024 +!!SPAG Open source Personal, Educational or Academic User NON-COMMERCIAL USE - Not for use on proprietary or closed source code +! +! +SUBROUTINE initize() + IMPLICIT NONE +!*** Start of declarations inserted by SPAG + REAL Aquad , Bquad , Era , erequ , erpol , Umr +!*** End of declarations inserted by SPAG +!---------------------------------------------------------------- +! Initializes the parameters in COMMON/GENER/ +! +! UMR = ATAN(1.0)*4./180. *UMR= +! ERA EARTH RADIUS FOR NORMALIZATION OF CARTESIAN +! COORDINATES (6371.2 KM) +! EREQU MAJOR HALF AXIS FOR EARTH ELLIPSOID (6378.160 KM) +! ERPOL MINOR HALF AXIS FOR EARTH ELLIPSOID (6356.775 KM) +! AQUAD SQUARE OF MAJOR HALF AXIS FOR EARTH ELLIPSOID +! BQUAD SQUARE OF MINOR HALF AXIS FOR EARTH ELLIPSOID +! +! ERA, EREQU and ERPOL as recommended by the INTERNATIONAL +! ASTRONOMICAL UNION . +!----------------------------------------------------------------- + COMMON /gener / Umr , Era , Aquad , Bquad + Era = 6371.2 + erequ = 6378.16 + erpol = 6356.775 + Aquad = erequ*erequ + Bquad = erpol*erpol + Umr = atan(1.0)*4./180. +END SUBROUTINE initize + +end module SHELLIG_module \ No newline at end of file From d7b831abe7aaf49285979843e502265333bbda19 Mon Sep 17 00:00:00 2001 From: Jacob Williams Date: Sun, 4 Feb 2024 11:08:38 -0600 Subject: [PATCH 02/13] some cleanup and a unit test --- src/core.f90 | 34 ++++++++++++++-------------------- test/radbelt_test.f90 | 37 +++++++++++++++++++++++++++++++++++++ 2 files changed, 51 insertions(+), 20 deletions(-) create mode 100644 test/radbelt_test.f90 diff --git a/src/core.f90 b/src/core.f90 index cc6ffb2..3c956c5 100644 --- a/src/core.f90 +++ b/src/core.f90 @@ -1,8 +1,8 @@ -! Copyright (C) 2021 United States Government as represented by the Administrator -! of the National Aeronautics and Space Administration. No copyright is claimed -! in the United States under Title 17, U.S. Code. All Other Rights Reserved. -! -! SPDX-License-Identifier: NASA-1.3 + +!> +! Adapted from +! * https://ccmc.gsfc.nasa.gov/pub/modelweb/geomagnetic/igrf/fortran_code/bilcal.for +! * https://ccmc.gsfc.nasa.gov/pub/modelweb/radiation_belt/radbelt/fortran_code/radbelt.for module core @@ -12,16 +12,11 @@ module core implicit none contains - -! Adapted from -! https://ccmc.gsfc.nasa.gov/pub/modelweb/geomagnetic/igrf/fortran_code/bilcal.for - + SUBROUTINE igrf(Lon,Lat,Height,Year,Xl,Bbx) IMPLICIT NONE -!*** Start of declarations inserted by SPAG REAL bab1 , babs , bdel , bdown , beast , beq , bequ , bnorth , dimo , rr0 INTEGER icode -!*** End of declarations inserted by SPAG REAL Lon , Lat , Height , Year , Xl , Bbx LOGICAL val @@ -37,18 +32,14 @@ SUBROUTINE igrf(Lon,Lat,Height,Year,Xl,Bbx) ENDIF Bbx = babs/bequ END SUBROUTINE igrf - -! Adapted from -! https://ccmc.gsfc.nasa.gov/pub/modelweb/radiation_belt/radbelt/fortran_code/radbelt.for - + SUBROUTINE aep8(E,L,Bb0,Imname,Flux) IMPLICIT NONE -!*** Start of declarations inserted by SPAG REAL E(1) , ee , Flux(1) - INTEGER i , ier , ierr , ihead , Imname , iuaeap , map , nmap -!*** End of declarations inserted by SPAG + INTEGER i , ierr , ihead , Imname , iuaeap , nmap + integer,dimension(:),allocatable :: map REAL L , Bb0 - DIMENSION map(20000) , ihead(8) , ee(1) !JW WARNING: map doesn't have to be this big! should allocate it to size nmap ! + DIMENSION ihead(8) , ee(1) CHARACTER*10 name , mname(4) DATA mname/'ae8min.asc' , 'ae8max.asc' , 'ap8min.asc' , 'ap8max.asc'/ @@ -58,10 +49,13 @@ SUBROUTINE aep8(E,L,Bb0,Imname,Flux) OPEN (iuaeap,FILE=name,STATUS='OLD',IOSTAT=ierr,ERR=100,FORM='FORMATTED') READ (iuaeap,99001) ihead nmap = ihead(8) + allocate(map(nmap)) READ (iuaeap,99001) (map(i),i=1,nmap) 100 CLOSE (iuaeap) - IF ( ier/=0 ) STOP + IF ( ierr/=0 ) then + error stop 'error reading '//trim(name) + end if ee(1) = E(1) CALL trara1(ihead,map,L,Bb0,E,Flux,1) diff --git a/test/radbelt_test.f90 b/test/radbelt_test.f90 new file mode 100644 index 0000000..9936ef5 --- /dev/null +++ b/test/radbelt_test.f90 @@ -0,0 +1,37 @@ +program radbelt_test + + !! comparison to the python radbelt example + + use core + + implicit none + + real :: lon, lat, height, year, xl,bbx + REAL, DIMENSION(1) :: E + INTEGER :: Imname + REAL, DIMENSION(1) :: Flux, error + + lon = -45.0 + lat = -30.0 + height = 500.0 + + ! >>> from astropy.time import Time + ! >>> time = Time('2021-03-01') + ! >>> time.utc.decimalyear + + year = 2021.1616438356164 ! decimal year + + Imname = 4 ! 'p', 'max' + e = 20.0 + + call igrf(Lon,Lat,Height,Year,Xl,Bbx) + call aep8(E,Xl,Bbx,Imname,Flux) + + error = Flux - 2642.50268555 ! difference from python wrapper version (radbelt) + + write(*,*) 'Flux = ', Flux + write(*,*) 'Error = ', error + + if (abs(error(1))>1.0e-9) error stop 'error' + +end program radbelt_test From d1fea8a6c61f54e92d439db5cb2a6f1429e6ddcf Mon Sep 17 00:00:00 2001 From: Jacob Williams Date: Sun, 4 Feb 2024 17:19:08 -0600 Subject: [PATCH 03/13] refactoring defaulting to real64 now --- README.md | 1 + src/core.f90 | 78 ++-- src/radbelt_kinds_module.F90 | 37 ++ src/shellig.f90 | 735 ++++++++++------------------------- src/trmfun.f90 | 71 ++-- test/radbelt.f90 | 55 ++- test/radbelt_test.f90 | 32 +- 7 files changed, 380 insertions(+), 629 deletions(-) create mode 100644 src/radbelt_kinds_module.F90 diff --git a/README.md b/README.md index 68363b4..8c1b686 100755 --- a/README.md +++ b/README.md @@ -76,6 +76,7 @@ two lines had been exchanged. * [NASA ModelWebArchive](https://git.smce.nasa.gov/ccmc-share/modelwebarchive) * [An Astropy-friendly wrapper for the AE-8/AP-8 Van Allen belt model](https://github.com/nasa/radbelt) +* [pyIGRF](https://github.com/rilma/pyIGRF) ### REFERENCES: diff --git a/src/core.f90 b/src/core.f90 index 3c956c5..51173b1 100644 --- a/src/core.f90 +++ b/src/core.f90 @@ -6,61 +6,87 @@ module core + use radbelt_kinds_module use radbelt_module use shellig_module implicit none + public :: igrf + public :: aep8 + public :: get_flux + contains + + !TODO: we need to read in the coefficients only once and keep them in memory, + ! rather than everytime these functions are called ! + + function get_flux(Lon,Lat,Height,Year,E,Imname) result(flux) + + real(wp) :: lon, lat, height, year, e + integer :: imname + + real(wp) :: flux,xl,bbx + real(wp), dimension(1) :: flux_, e_ + + e_(1) = e + + call igrf(Lon,Lat,Height,Year,Xl,Bbx) + call aep8(e_,Xl,Bbx,Imname,flux_) + + flux = flux_(1) + + end function get_flux -SUBROUTINE igrf(Lon,Lat,Height,Year,Xl,Bbx) - IMPLICIT NONE - REAL bab1 , babs , bdel , bdown , beast , beq , bequ , bnorth , dimo , rr0 - INTEGER icode - REAL Lon , Lat , Height , Year , Xl , Bbx - LOGICAL val +subroutine igrf(lon,lat,height,year,xl,bbx) + + real(wp) bab1 , babs , bdel , bdown , beast , beq , bequ , bnorth , dimo , rr0 + integer icode + real(wp) lon , lat , height , year , xl , bbx + logical val - CALL initize() CALL feldcof(Year,dimo) CALL feldg(Lat,Lon,Height,bnorth,beast,bdown,babs) CALL shellg(Lat,Lon,Height,dimo,Xl,icode,bab1) bequ = dimo/(Xl*Xl*Xl) IF ( icode==1 ) THEN - bdel = 1.E-3 - CALL findb0(0.05,bdel,val,beq,rr0) + bdel = 1.0e-3_wp + CALL findb0(0.05_wp,bdel,val,beq,rr0) IF ( val ) bequ = beq ENDIF Bbx = babs/bequ END SUBROUTINE igrf -SUBROUTINE aep8(E,L,Bb0,Imname,Flux) - IMPLICIT NONE - REAL E(1) , ee , Flux(1) - INTEGER i , ierr , ihead , Imname , iuaeap , nmap +subroutine aep8(e,l,bb0,imname,flux) + + real(wp) e(1) , ee(1) , flux(1) + integer i , ierr , ihead(8) , imname , iuaeap , nmap integer,dimension(:),allocatable :: map - REAL L , Bb0 - DIMENSION ihead(8) , ee(1) - CHARACTER*10 name , mname(4) - DATA mname/'ae8min.asc' , 'ae8max.asc' , 'ap8min.asc' , 'ap8max.asc'/ + real(wp) l , bb0 + character(len=10) :: name + + character(len=10),dimension(4),parameter :: mname = ['ae8min.asc' , & + 'ae8max.asc' , & + 'ap8min.asc' , & + 'ap8max.asc'] iuaeap = 15 name = mname(Imname) - OPEN (iuaeap,FILE=name,STATUS='OLD',IOSTAT=ierr,ERR=100,FORM='FORMATTED') - READ (iuaeap,99001) ihead - nmap = ihead(8) - allocate(map(nmap)) - READ (iuaeap,99001) (map(i),i=1,nmap) - - 100 CLOSE (iuaeap) + OPEN (iuaeap,FILE=name,STATUS='OLD',IOSTAT=ierr,FORM='FORMATTED') IF ( ierr/=0 ) then error stop 'error reading '//trim(name) end if + READ (iuaeap,'(1X,12I6)') ihead + nmap = ihead(8) + allocate(map(nmap)) + READ (iuaeap,'(1X,12I6)') (map(i),i=1,nmap) + CLOSE (iuaeap) ee(1) = E(1) CALL trara1(ihead,map,L,Bb0,E,Flux,1) - IF ( Flux(1)>0.0 ) Flux(1) = 10.**Flux(1) -99001 FORMAT (1X,12I6) + IF ( Flux(1)>0.0_wp ) Flux(1) = 10.0_wp**Flux(1) + END SUBROUTINE aep8 end module core diff --git a/src/radbelt_kinds_module.F90 b/src/radbelt_kinds_module.F90 new file mode 100644 index 0000000..24d0587 --- /dev/null +++ b/src/radbelt_kinds_module.F90 @@ -0,0 +1,37 @@ +!***************************************************************************************** +!> +! Numeric kind definitions for radbelt. + + module radbelt_kinds_module + + use,intrinsic :: iso_fortran_env + + implicit none + + private + +#ifdef REAL32 + integer,parameter,public :: wp = real32 !! Real working precision [4 bytes] +#elif REAL64 + integer,parameter,public :: wp = real64 !! Real working precision [8 bytes] +#elif REAL128 + integer,parameter,public :: wp = real128 !! Real working precision [16 bytes] +#else + integer,parameter,public :: wp = real64 !! Real working precision if not specified [8 bytes] +#endif + +#ifdef INT8 + integer,parameter,public :: ip = int8 !! Integer working precision [1 byte] +#elif INT16 + integer,parameter,public :: ip = int16 !! Integer working precision [2 bytes] +#elif INT32 + integer,parameter,public :: ip = int32 !! Integer working precision [4 bytes] +#elif INT64 + integer,parameter,public :: ip = int64 !! Integer working precision [8 bytes] +#else + integer,parameter,public :: ip = int32 !! Integer working precision if not specified [4 bytes] +#endif + +!***************************************************************************************** + end module radbelt_kinds_module +!***************************************************************************************** diff --git a/src/shellig.f90 b/src/shellig.f90 index 3919816..3ea8f54 100644 --- a/src/shellig.f90 +++ b/src/shellig.f90 @@ -1,147 +1,49 @@ +!> +! +! +! * SHELLIG.FOR, Version 2.0, January 1992 +! * 11/01/91-DKB- SHELLG: lowest starting point for B0 search is 2 +! * 1/27/92-DKB- Adopted to IGRF-91 coeffcients model +! * 2/05/92-DKB- Reduce variable-names: INTER(P)SHC,EXTRA(P)SHC,INITI(ALI)ZE +! * 8/08/95-DKB- Updated to IGRF-45-95; new coeff. DGRF90, IGRF95, IGRF95S +! * 5/31/00-DKB- Updated to IGRF-45-00; new coeff.: IGRF00, IGRF00s +! * 3/24/05-DKB- Updated to IGRF-45-10; new coeff.: IGRF05, IGRF05s module shellig_module + use radbelt_kinds_module + implicit none + private + + ! parameters formerly in `gener` common block + real(wp),parameter :: Era = 6371.2_wp !! earth radius for normalization of cartesian coordinates (6371.2 km) + real(wp),parameter :: erequ = 6378.16_wp + real(wp),parameter :: erpol = 6356.775_wp + real(wp),parameter :: Aquad = erequ*erequ !! square of major half axis for + !! earth ellipsoid as recommended by international + !! astronomical union + real(wp),parameter :: Bquad = erpol*erpol !! square of minor half axis for + !! earth ellipsoid as recommended by international + !! astronomical union + real(wp),parameter :: Umr = atan(1.0_wp)*4.0_wp/180.0_wp !! atan(1.0)*4./180. *umr= + + public :: feldcof + public :: feldg + public :: shellg + public :: findb0 + contains -! SHELLIG.FOR, Version 2.0, January 1992 -! -! 11/01/91-DKB- SHELLG: lowest starting point for B0 search is 2 -! 1/27/92-DKB- Adopted to IGRF-91 coeffcients model -! 2/05/92-DKB- Reduce variable-names: INTER(P)SHC,EXTRA(P)SHC,INITI(ALI)ZE -! 8/08/95-DKB- Updated to IGRF-45-95; new coeff. DGRF90, IGRF95, IGRF95S -! 5/31/00-DKB- Updated to IGRF-45-00; new coeff.: IGRF00, IGRF00s -! 3/24/05-DKB- Updated to IGRF-45-10; new coeff.: IGRF05, IGRF05s -! - -! -! SUBROUTINE findb0(Stps,Bdel,Value,Bequ,Rr0) -! IMPLICIT NONE -! !*** Start of declarations inserted by SPAG -! REAL b , Bdel , bdelta , Bequ , bmin , bold , bq1 , bq2 , bq3 , p , r1 , r2 , r3 , rold , Rr0 , Sp , step , step12 , Stps , zz -! INTEGER i , irun , j , n -! !*** End of declarations inserted by SPAG -! !-------------------------------------------------------------------- -! ! FINDS SMALLEST MAGNETIC FIELD STRENGTH ON FIELD LINE -! ! -! ! INPUT: STPS STEP SIZE FOR FIELD LINE TRACING -! ! COMMON/FIDB0/ -! ! SP DIPOLE ORIENTED COORDINATES FORM SHELLG; P(1,*), -! ! P(2,*), P(3,*) CLOSEST TO MAGNETIC EQUATOR -! ! BDEL REQUIRED ACCURACY = [ B(LAST) - BEQU ] / BEQU -! ! B(LAST) IS FIELD STRENGTH BEFORE BEQU -! ! -! ! OUTPUT: VALUE =.FALSE., IF BEQU IS NOT MINIMAL VALUE ON FIELD LINE -! ! BEQU MAGNETIC FIELD STRENGTH AT MAGNETIC EQUATOR -! ! RR0 EQUATORIAL RADIUS NORMALIZED TO EARTH RADIUS -! ! BDEL FINAL ACHIEVED ACCURACY -! !-------------------------------------------------------------------- -! DIMENSION p(8,4) , Sp(3) -! LOGICAL Value -! COMMON /fidb0 / Sp -! INTEGER :: spag_nextblock_1 -! spag_nextblock_1 = 1 -! SPAG_DispatchLoop_1: DO -! SELECT CASE (spag_nextblock_1) -! CASE (1) -! ! -! step = Stps -! irun = 0 -! spag_nextblock_1 = 2 -! CASE (2) -! irun = irun + 1 -! IF ( irun>5 ) THEN -! Value = .FALSE. -! spag_nextblock_1 = 3 -! CYCLE SPAG_DispatchLoop_1 -! ENDIF -! !*********************FIRST THREE POINTS -! p(1,2) = Sp(1) -! p(2,2) = Sp(2) -! p(3,2) = Sp(3) -! step = -sign(step,p(3,2)) -! CALL stoer(p(1,2),bq2,r2) -! p(1,3) = p(1,2) + 0.5*step*p(4,2) -! p(2,3) = p(2,2) + 0.5*step*p(5,2) -! p(3,3) = p(3,2) + 0.5*step -! CALL stoer(p(1,3),bq3,r3) -! p(1,1) = p(1,2) - step*(2.*p(4,2)-p(4,3)) -! p(2,1) = p(2,2) - step*(2.*p(5,2)-p(5,3)) -! p(3,1) = p(3,2) - step -! CALL stoer(p(1,1),bq1,r1) -! p(1,3) = p(1,2) + step*(20.*p(4,3)-3.*p(4,2)+p(4,1))/18. -! p(2,3) = p(2,2) + step*(20.*p(5,3)-3.*p(5,2)+p(5,1))/18. -! p(3,3) = p(3,2) + step -! CALL stoer(p(1,3),bq3,r3) -! !******************INVERT SENSE IF REQUIRED -! IF ( bq3>bq1 ) THEN -! step = -step -! r3 = r1 -! bq3 = bq1 -! DO i = 1 , 5 -! zz = p(i,1) -! p(i,1) = p(i,3) -! p(i,3) = zz -! ENDDO -! ENDIF -! !******************INITIALIZATION -! step12 = step/12. -! Value = .TRUE. -! bmin = 1.E4 -! bold = 1.E4 -! !******************CORRECTOR (FIELD LINE TRACING) -! n = 0 -! SPAG_Loop_1_1: DO -! p(1,3) = p(1,2) + step12*(5.*p(4,3)+8.*p(4,2)-p(4,1)) -! n = n + 1 -! p(2,3) = p(2,2) + step12*(5.*p(5,3)+8.*p(5,2)-p(5,1)) -! !******************PREDICTOR (FIELD LINE TRACING) -! p(1,4) = p(1,3) + step12*(23.*p(4,3)-16.*p(4,2)+5.*p(4,1)) -! p(2,4) = p(2,3) + step12*(23.*p(5,3)-16.*p(5,2)+5.*p(5,1)) -! p(3,4) = p(3,3) + step -! CALL stoer(p(1,4),bq3,r3) -! DO j = 1 , 3 -! DO i = 1 , 8 -! p(i,j) = p(i,j+1) -! ENDDO -! ENDDO -! b = sqrt(bq3) -! IF ( bBdel ) THEN -! step = step/10. -! spag_nextblock_1 = 2 -! CYCLE SPAG_DispatchLoop_1 -! ENDIF -! EXIT SPAG_Loop_1_1 -! ENDDO SPAG_Loop_1_1 -! spag_nextblock_1 = 3 -! CASE (3) -! Rr0 = rold -! Bequ = bold -! Bdel = bdelta -! EXIT SPAG_DispatchLoop_1 -! END SELECT -! ENDDO SPAG_DispatchLoop_1 -! END SUBROUTINE findb0 - subroutine findb0(stps,bdel,value,bequ,rr0) - REAL b , Bdel , bdelta , Bequ , bmin , bold , bq1 , bq2 , bq3 , p , r1 , r2 , r3 , & - rold , Rr0 , Sp , step , step12 , Stps , zz - INTEGER i , irun , j , n + real(wp) :: b , bdel , bdelta , bequ , bmin , bold , bq1 , & + bq2 , bq3 , p , r1 , r2 , r3 , & + rold , rr0 , sp , step , step12 , stps , zz + integer :: i , irun , j , n dimension p(8,4),sp(3) - logical value + logical :: value common/fidb0/ sp @@ -160,16 +62,16 @@ subroutine findb0(stps,bdel,value,bequ,rr0) p(3,2)=sp(3) step=-sign(step,p(3,2)) call stoer(p(1,2),bq2,r2) - p(1,3)=p(1,2)+0.5*step*p(4,2) - p(2,3)=p(2,2)+0.5*step*p(5,2) - p(3,3)=p(3,2)+0.5*step + p(1,3)=p(1,2)+0.5_wp*step*p(4,2) + p(2,3)=p(2,2)+0.5_wp*step*p(5,2) + p(3,3)=p(3,2)+0.5_wp*step call stoer(p(1,3),bq3,r3) - p(1,1)=p(1,2)-step*(2.*p(4,2)-p(4,3)) - p(2,1)=p(2,2)-step*(2.*p(5,2)-p(5,3)) + p(1,1)=p(1,2)-step*(2.0_wp*p(4,2)-p(4,3)) + p(2,1)=p(2,2)-step*(2.0_wp*p(5,2)-p(5,3)) p(3,1)=p(3,2)-step call stoer(p(1,1),bq1,r1) - p(1,3)=p(1,2)+step*(20.*p(4,3)-3.*p(4,2)+p(4,1))/18. - p(2,3)=p(2,2)+step*(20.*p(5,3)-3.*p(5,2)+p(5,1))/18. + p(1,3)=p(1,2)+step*(20.0_wp*p(4,3)-3.*p(4,2)+p(4,1))/18.0_wp + p(2,3)=p(2,2)+step*(20.0_wp*p(5,3)-3.*p(5,2)+p(5,1))/18.0_wp p(3,3)=p(3,2)+step call stoer(p(1,3),bq3,r3) !******************invert sense if required @@ -184,19 +86,19 @@ subroutine findb0(stps,bdel,value,bequ,rr0) end do end if !******************initialization - step12=step/12. + step12=step/12.0_wp value=.true. - bmin=1.e4 - bold=1.e4 + bmin=1.0e4_wp + bold=1.0e4_wp !******************corrector (field line tracing) n=0 corrector : do - p(1,3)=p(1,2)+step12*(5.*p(4,3)+8.*p(4,2)-p(4,1)) + p(1,3)=p(1,2)+step12*(5.0_wp*p(4,3)+8.0_wp*p(4,2)-p(4,1)) n=n+1 - p(2,3)=p(2,2)+step12*(5.*p(5,3)+8.*p(5,2)-p(5,1)) + p(2,3)=p(2,2)+step12*(5.0_wp*p(5,3)+8.0_wp*p(5,2)-p(5,1)) !******************predictor (field line tracing) - p(1,4)=p(1,3)+step12*(23.*p(4,3)-16.*p(4,2)+5.*p(4,1)) - p(2,4)=p(2,3)+step12*(23.*p(5,3)-16.*p(5,2)+5.*p(5,1)) + p(1,4)=p(1,3)+step12*(23.0_wp*p(4,3)-16.0_wp*p(4,2)+5.0_wp*p(4,1)) + p(2,4)=p(2,3)+step12*(23.0_wp*p(5,3)-16.0_wp*p(5,2)+5.0_wp*p(5,1)) p(3,4)=p(3,3)+step call stoer(p(1,4),bq3,r3) do j=1,3 @@ -208,7 +110,7 @@ subroutine findb0(stps,bdel,value,bequ,rr0) if (bbold) exit corrector bold=b - rold=1./r3 + rold=1.0_wp/r3 sp(1)=p(1,4) sp(2)=p(2,4) sp(3)=p(3,4) @@ -218,7 +120,7 @@ subroutine findb0(stps,bdel,value,bequ,rr0) endif bdelta=(b-bold)/bold if (bdelta<=bdel) exit main - step=step/10. + step=step/10.0_wp end do main rr0=rold @@ -227,68 +129,59 @@ subroutine findb0(stps,bdel,value,bequ,rr0) end subroutine findb0 -!-------------------------------------------------------------------- +!> ! CALCULATES L-VALUE FOR SPECIFIED GEODAETIC COORDINATES, ALTITUDE ! AND GEMAGNETIC FIELD MODEL. -! REF: G. KLUGE, EUROPEAN SPACE OPERATIONS CENTER, INTERNAL NOTE -! NO. 67, 1970. -! G. KLUGE, COMPUTER PHYSICS COMMUNICATIONS 3, 31-35, 1972 -!-------------------------------------------------------------------- -! CHANGES (D. BILITZA, NOV 87): +! +!### Reference +! * G. KLUGE, EUROPEAN SPACE OPERATIONS CENTER, INTERNAL NOTE +! NO. 67, 1970. +! * G. KLUGE, COMPUTER PHYSICS COMMUNICATIONS 3, 31-35, 1972 +! +!### History +! * CHANGES (D. BILITZA, NOV 87): ! - USING CORRECT DIPOL MOMENT I.E.,DIFFERENT COMMON/MODEL/ ! - USING IGRF EARTH MAGNETIC FIELD MODELS FROM 1945 TO 1990 -!-------------------------------------------------------------------- -! INPUT: ENTRY POINT SHELLG -! GLAT GEODETIC LATITUDE IN DEGREES (NORTH) -! GLON GEODETIC LONGITUDE IN DEGREES (EAST) -! ALT ALTITUDE IN KM ABOVE SEA LEVEL -! -! ENTRY POINT SHELLC -! V(3) CARTESIAN COORDINATES IN EARTH RADII (6371.2 KM) -! X-AXIS POINTING TO EQUATOR AT 0 LONGITUDE -! Y-AXIS POINTING TO EQUATOR AT 90 LONG. -! Z-AXIS POINTING TO NORTH POLE -! -! DIMO DIPOL MOMENT IN GAUSS (NORMALIZED TO EARTH RADIUS) -! + + subroutine shellg(glat,glon,alt,dimo,fl,icode,b0) + + real(wp),intent(in) :: glat !! GEODETIC LATITUDE IN DEGREES (NORTH) + real(wp),intent(in) :: glon !! GEODETIC LONGITUDE IN DEGREES (EAST) + real(wp),intent(in) :: alt !! ALTITUDE IN KM ABOVE SEA LEVEL + real(wp),intent(in) :: dimo !! DIPOL MOMENT IN GAUSS (NORMALIZED TO EARTH RADIUS) + real(wp),intent(out) :: fl !! l-value + integer,intent(out) :: icode !! * =1 normal completion + !! * =2 unphysical conjugate point (fl meaningless) + !! * =3 shell parameter greater than limit up to + !! which accurate calculation is required; + !! approximation is used. + real(wp),intent(out) :: b0 !! magnetic field strength in gauss + + real(wp) :: arg1 , arg2 , bequ , bq1 , bq2 , bq3 , c0 , c1 , c2 , c3 , ct , d , d0 , d1 , d2 + real(wp) :: dimob0 , e0 , e1 , e2 , ff , fi , gg , h , hli , oradik , oterm , p , r , r1 , r2 , r3 + real(wp) :: r3h , radik , rlat , rlon , rmax , rmin , rq , sp , st , step , step12 , step2 , steq , stp , t , term , v , x + real(wp) :: xx , z , zq , zz + integer :: i , iequ , n + + dimension v(3) , p(8,100) , sp(3) + + real(wp),dimension(3,3),parameter :: u = reshape([ +0.3511737_wp , -0.9148385_wp , -0.1993679_wp , & + +0.9335804_wp , +0.3583680_wp , +0.0000000_wp , & + +0.0714471_wp , -0.1861260_wp , +0.9799247_wp], [3,3]) + ! COMMON ! X(3) NOT USED ! H(144) FIELD MODEL COEFFICIENTS ADJUSTED FOR SHELLG -!----------------------------------------------------------------------- -! OUTPUT: FL L-VALUE -! ICODE =1 NORMAL COMPLETION -! =2 UNPHYSICAL CONJUGATE POINT (FL MEANINGLESS) -! =3 SHELL PARAMETER GREATER THAN LIMIT UP TO -! WHICH ACCURATE CALCULATION IS REQUIRED; -! APPROXIMATION IS USED. -! B0 MAGNETIC FIELD STRENGTH IN GAUSS -!----------------------------------------------------------------------- - - SUBROUTINE shellg(Glat,Glon,Alt,Dimo,Fl,Icode,B0) - IMPLICIT NONE - REAL Alt , Aquad , arg1 , arg2 , B0 , bequ , bq1 , bq2 , bq3 , Bquad , c0 , c1 , c2 , c3 , ct , d , d0 , d1 , d2 , Dimo - REAL dimob0 , e0 , e1 , e2 , Era , ff , fi , Fl , gg , Glat , Glon , H , hli , oradik , oterm , p , r , r1 , r2 , r3 - REAL r3h , radik , rlat , rlon , rmax , rmin , rq , Sp , st , step , step12 , step2 , steq , stp , t , term , Umr , V , X - REAL xx , z , zq , zz - INTEGER i , Icode , iequ , n - - DIMENSION V(3) , p(8,100) , Sp(3) - - real,dimension(3,3),parameter :: u = reshape([ +0.3511737 , -0.9148385 , -0.1993679 , & - +0.9335804 , +0.3583680 , +0.0000000 , & - +0.0714471 , -0.1861260 , +0.9799247], [3,3]) - COMMON X(3) , H(144) COMMON /fidb0 / Sp - COMMON /gener / Umr , Era , Aquad , Bquad !-- RMIN, RMAX ARE BOUNDARIES FOR IDENTIFICATION OF ICODE=2 AND 3 !-- STEP IS STEP SIZE FOR FIELD LINE TRACING !-- STEQ IS STEP SIZE FOR INTEGRATION - DATA rmin , rmax/0.05 , 1.01/ - DATA step , steq/0.20 , 0.03/ - bequ = 1.E10 + DATA rmin , rmax/0.05_wp , 1.01_wp/ + DATA step , steq/0.20_wp , 0.03_wp/ + bequ = 1.0e10_wp !*****ENTRY POINT SHELLG TO BE USED WITH GEODETIC CO-ORDINATES rlat = Glat*Umr @@ -304,6 +197,10 @@ SUBROUTINE shellg(Glat,Glon,Alt,Dimo,Fl,Icode,B0) RETURN !*****ENTRY POINT SHELLC TO BE USED WITH CARTESIAN CO-ORDINATES +! V(3) CARTESIAN COORDINATES IN EARTH RADII (6371.2 KM) +! X-AXIS POINTING TO EQUATOR AT 0 LONGITUDE +! Y-AXIS POINTING TO EQUATOR AT 90 LONG. +! Z-AXIS POINTING TO NORTH POLE ENTRY shellc(V,Fl,B0) X(1) = V(1) X(2) = V(2) @@ -326,16 +223,16 @@ SUBROUTINE spag_block_1 step = -sign(step,p(3,2)) CALL stoer(p(1,2),bq2,r2) B0 = sqrt(bq2) - p(1,3) = p(1,2) + 0.5*step*p(4,2) - p(2,3) = p(2,2) + 0.5*step*p(5,2) - p(3,3) = p(3,2) + 0.5*step + p(1,3) = p(1,2) + 0.5_wp*step*p(4,2) + p(2,3) = p(2,2) + 0.5_wp*step*p(5,2) + p(3,3) = p(3,2) + 0.5_wp*step CALL stoer(p(1,3),bq3,r3) - p(1,1) = p(1,2) - step*(2.*p(4,2)-p(4,3)) - p(2,1) = p(2,2) - step*(2.*p(5,2)-p(5,3)) + p(1,1) = p(1,2) - step*(2.0_wp*p(4,2)-p(4,3)) + p(2,1) = p(2,2) - step*(2.0_wp*p(5,2)-p(5,3)) p(3,1) = p(3,2) - step CALL stoer(p(1,1),bq1,r1) - p(1,3) = p(1,2) + step*(20.*p(4,3)-3.*p(4,2)+p(4,1))/18. - p(2,3) = p(2,2) + step*(20.*p(5,3)-3.*p(5,2)+p(5,1))/18. + p(1,3) = p(1,2) + step*(20.0_wp*p(4,3)-3.*p(4,2)+p(4,1))/18.0_wp + p(2,3) = p(2,2) + step*(20.0_wp*p(5,3)-3.*p(5,2)+p(5,1))/18.0_wp p(3,3) = p(3,2) + step CALL stoer(p(1,3),bq3,r3) !*****INVERT SENSE IF REQUIRED @@ -363,43 +260,43 @@ SUBROUTINE spag_block_1 iequ = 3 ENDIF !*****INITIALIZATION OF INTEGRATION LOOPS - step12 = step/12. + step12 = step/12.0_wp step2 = step + step steq = sign(steq,step) - fi = 0. + fi = 0.0_wp Icode = 1 - oradik = 0. - oterm = 0. + oradik = 0.0_wp + oterm = 0.0_wp stp = r2*steq z = p(3,2) + stp - stp = stp/0.75 + stp = stp/0.75_wp p(8,1) = step2*(p(1,1)*p(4,1)+p(2,1)*p(5,1)) p(8,2) = step2*(p(1,2)*p(4,2)+p(2,2)*p(5,2)) !*****MAIN LOOP (FIELD LINE TRACING) main: DO n = 3 , max_loop_index !*****CORRECTOR (FIELD LINE TRACING) - p(1,n) = p(1,n-1) + step12*(5.*p(4,n)+8.*p(4,n-1)-p(4,n-2)) - p(2,n) = p(2,n-1) + step12*(5.*p(5,n)+8.*p(5,n-1)-p(5,n-2)) + p(1,n) = p(1,n-1) + step12*(5.0_wp*p(4,n)+8.0_wp*p(4,n-1)-p(4,n-2)) + p(2,n) = p(2,n-1) + step12*(5.0_wp*p(5,n)+8.0_wp*p(5,n-1)-p(5,n-2)) !*****PREPARE EXPANSION COEFFICIENTS FOR INTERPOLATION !*****OF SLOWLY VARYING QUANTITIES p(8,n) = step2*(p(1,n)*p(4,n)+p(2,n)*p(5,n)) c0 = p(1,n-1)**2 + p(2,n-1)**2 c1 = p(8,n-1) - c2 = (p(8,n)-p(8,n-2))*0.25 - c3 = (p(8,n)+p(8,n-2)-c1-c1)/6.0 + c2 = (p(8,n)-p(8,n-2))*0.25_wp + c3 = (p(8,n)+p(8,n-2)-c1-c1)/6.0_wp d0 = p(6,n-1) - d1 = (p(6,n)-p(6,n-2))*0.5 - d2 = (p(6,n)+p(6,n-2)-d0-d0)*0.5 + d1 = (p(6,n)-p(6,n-2))*0.5_wp + d2 = (p(6,n)+p(6,n-2)-d0-d0)*0.5_wp e0 = p(7,n-1) - e1 = (p(7,n)-p(7,n-2))*0.5 - e2 = (p(7,n)+p(7,n-2)-e0-e0)*0.5 + e1 = (p(7,n)-p(7,n-2))*0.5_wp + e2 = (p(7,n)+p(7,n-2)-e0-e0)*0.5_wp inner: DO !*****INNER LOOP (FOR QUADRATURE) t = (z-p(3,n-1))/step - IF ( t>1. ) THEN + IF ( t>1.0_wp ) THEN !*****PREDICTOR (FIELD LINE TRACING) - p(1,n+1) = p(1,n) + step12*(23.*p(4,n)-16.*p(4,n-1)+5.*p(4,n-2)) - p(2,n+1) = p(2,n) + step12*(23.*p(5,n)-16.*p(5,n-1)+5.*p(5,n-2)) + p(1,n+1) = p(1,n) + step12*(23.0_wp*p(4,n)-16.0_wp*p(4,n-1)+5.0_wp*p(4,n-2)) + p(2,n+1) = p(2,n) + step12*(23.0_wp*p(5,n)-16.0_wp*p(5,n-1)+5.0_wp*p(5,n-2)) p(3,n+1) = p(3,n) + step CALL stoer(p(1,n+1),bq3,r3) !*****SEARCH FOR LOWEST MAGNETIC FIELD STRENGTH @@ -409,22 +306,22 @@ SUBROUTINE spag_block_1 ENDIF EXIT inner ELSE - hli = 0.5*(((c3*t+c2)*t+c1)*t+c0) + hli = 0.5_wp*(((c3*t+c2)*t+c1)*t+c0) zq = z*z r = hli + sqrt(hli*hli+zq) IF ( r<=rmin ) THEN !*****APPROXIMATION FOR HIGH VALUES OF L. Icode = 3 t = -p(3,n-1)/step - Fl = 1./(abs(((c3*t+c2)*t+c1)*t+c0)+1E-15) + Fl = 1.0_wp/(abs(((c3*t+c2)*t+c1)*t+c0)+1.0e-15_wp) RETURN ENDIF rq = r*r - ff = sqrt(1.+3.*zq/rq) + ff = sqrt(1.0_wp+3.0_wp*zq/rq) radik = B0 - ((d2*t+d1)*t+d0)*r*rq*ff IF ( r>rmax ) THEN Icode = 2 - radik = radik - 12.*(r-rmax)**2 + radik = radik - 12.0_wp*(r-rmax)**2 ENDIF IF ( radik+radik<=oradik ) EXIT main term = sqrt(radik)*ff*((e2*t+e1)*t+e0)/(rq+zq) @@ -440,79 +337,86 @@ SUBROUTINE spag_block_1 Sp(1) = p(1,iequ-1) Sp(2) = p(2,iequ-1) Sp(3) = p(3,iequ-1) - IF ( oradik>=1E-15 ) fi = fi + stp/0.75*oterm*oradik/(oradik-radik) + IF ( oradik>=1.0e-15_wp ) fi = fi + stp/0.75_wp*oterm*oradik/(oradik-radik) ! !-- The minimal allowable value of FI was changed from 1E-15 to 1E-12, !-- because 1E-38 is the minimal allowable arg. for ALOG in our envir. !-- D. Bilitza, Nov 87. ! - fi = 0.5*abs(fi)/sqrt(B0) + 1E-12 + fi = 0.5_wp*abs(fi)/sqrt(B0) + 1.0e-12_wp !*****COMPUTE L FROM B AND I. SAME AS CARMEL IN INVAR. ! !-- Correct dipole moment is used here. D. Bilitza, Nov 87. ! dimob0 = Dimo/B0 - arg1 = alog(fi) - arg2 = alog(dimob0) + arg1 = log(fi) + arg2 = log(dimob0) ! arg = FI*FI*FI/DIMOB0 -! if(abs(arg).gt.88.0) arg=88.0 +! if(abs(arg)>88.0_wp) arg=88.0_wp xx = 3*arg1 - arg2 - IF ( xx>23.0 ) THEN - gg = xx - 3.0460681E0 + IF ( xx>23.0_wp ) THEN + gg = xx - 3.0460681_wp ELSEIF ( xx>11.7 ) THEN - gg = (((((2.8212095E-8*xx-3.8049276E-6)*xx+2.170224E-4)*xx-6.7310339E-3)*xx+1.2038224E-1)*xx-1.8461796E-1) & - & *xx + 2.0007187E0 + gg = (((((2.8212095E-8_wp*xx-3.8049276E-6_wp)*xx+& + 2.170224E-4_wp)*xx-6.7310339E-3_wp)*xx+& + 1.2038224E-1_wp)*xx-1.8461796E-1_wp)*xx + 2.0007187_wp ELSEIF ( xx>+3.0 ) THEN - gg = ((((((((6.3271665E-10*xx-3.958306E-8)*xx+9.9766148E-07)*xx-1.2531932E-5)*xx+7.9451313E-5)*xx-3.2077032E-4) & - & *xx+2.1680398E-3)*xx+1.2817956E-2)*xx+4.3510529E-1)*xx + 6.222355E-1 + gg = ((((((((6.3271665E-10_wp*xx-3.958306E-8_wp)*xx+& + 9.9766148E-07_wp)*xx-1.2531932E-5_wp)*xx+& + 7.9451313E-5_wp)*xx-3.2077032E-4_wp)*xx+& + 2.1680398E-3_wp)*xx+1.2817956E-2_wp)*xx+& + 4.3510529E-1_wp)*xx + 6.222355E-1_wp ELSEIF ( xx>-3.0 ) THEN - gg = ((((((((2.6047023E-10*xx+2.3028767E-9)*xx-2.1997983E-8)*xx-5.3977642E-7)*xx-3.3408822E-6)*xx+3.8379917E-5) & - & *xx+1.1784234E-3)*xx+1.4492441E-2)*xx+4.3352788E-1)*xx + 6.228644E-1 + gg = ((((((((2.6047023E-10_wp*xx+2.3028767E-9_wp)*xx-& + 2.1997983E-8_wp)*xx-5.3977642E-7_wp)*xx-& + 3.3408822E-6_wp)*xx+3.8379917E-5_wp)*xx+& + 1.1784234E-3_wp)*xx+1.4492441E-2_wp)*xx+& + 4.3352788E-1_wp)*xx + 6.228644E-1_wp ELSEIF ( xx>-22. ) THEN - gg = ((((((((-8.1537735E-14*xx+8.3232531E-13)*xx+1.0066362E-9)*xx+8.1048663E-8)*xx+3.2916354E-6)*xx+8.2711096E-5) & - & *xx+1.3714667E-3)*xx+1.5017245E-2)*xx+4.3432642E-1)*xx + 6.2337691E-1 + gg = ((((((((-8.1537735E-14_wp*xx+8.3232531E-13_wp)*xx+& + 1.0066362E-9_wp)*xx+8.1048663E-8_wp)*xx+& + 3.2916354E-6_wp)*xx+8.2711096E-5_wp)*xx+& + 1.3714667E-3_wp)*xx+1.5017245E-2_wp)*xx+& + 4.3432642E-1_wp)*xx + 6.2337691E-1_wp ELSE - gg = 3.33338E-1*xx + 3.0062102E-1 + gg = 3.33338E-1_wp*xx + 3.0062102E-1_wp ENDIF - Fl = exp(alog((1.+exp(gg))*dimob0)/3.0) + Fl = exp(log((1.0_wp+exp(gg))*dimob0)/3.0_wp) RETURN END SUBROUTINE spag_block_1 END SUBROUTINE shellg -!*==stoer.f90 processed by SPAG 8.01MH 09:18 3 Feb 2024 -!!SPAG Open source Personal, Educational or Academic User NON-COMMERCIAL USE - Not for use on proprietary or closed source code -! -! SUBROUTINE stoer(P,Bq,R) IMPLICIT NONE -!*** Start of declarations inserted by SPAG - REAL Bq , dr , dsq , dx , dxm , dy , dym , dz , dzm , fli , H , P , q , R , rq , u , wr , Xi , xm , ym - REAL zm -!*** End of declarations inserted by SPAG + REAL(wp) Bq , dr , dsq , dx , dxm , dy , dym , dz , dzm , fli , & + H , P , q , R , rq , wr , Xi , xm , ym + REAL(wp) zm !******************************************************************* !* SUBROUTINE USED FOR FIELD LINE TRACING IN SHELLG * !* CALLS ENTRY POINT FELDI IN GEOMAGNETIC FIELD SUBROUTINE FELDG * !******************************************************************* - DIMENSION P(7) , u(3,3) + DIMENSION P(7) + real(wp),dimension(3,3),parameter :: u = reshape([ +0.3511737_wp , -0.9148385_wp , -0.1993679_wp , & + +0.9335804_wp , +0.3583680_wp , +0.0000000_wp , & + +0.0714471_wp , -0.1861260_wp , +0.9799247_wp],[3,3]) COMMON Xi(3) , H(144) !*****XM,YM,ZM ARE GEOMAGNETIC CARTESIAN INVERSE CO-ORDINATES zm = P(3) - fli = P(1)*P(1) + P(2)*P(2) + 1E-15 - R = 0.5*(fli+sqrt(fli*fli+(zm+zm)**2)) + fli = P(1)*P(1) + P(2)*P(2) + 1.0e-15_wp + R = 0.5_wp*(fli+sqrt(fli*fli+(zm+zm)**2)) rq = R*R wr = sqrt(R) xm = P(1)*wr ym = P(2)*wr !*****TRANSFORM TO GEOGRAPHIC CO-ORDINATE SYSTEM - DATA u/ + 0.3511737 , -0.9148385 , -0.1993679 , +0.9335804 , +0.3583680 , +0.0000000 , +0.0714471 , -0.1861260 , +0.9799247/ Xi(1) = xm*u(1,1) + ym*u(1,2) + zm*u(1,3) Xi(2) = xm*u(2,1) + ym*u(2,2) + zm*u(2,3) Xi(3) = xm*u(3,1) + zm*u(3,3) !*****COMPUTE DERIVATIVES ! Changed from CALL FELDI(XI,H); XI, H are in COMMON block; results ! are the same; dkb Feb 1998 - CALL feldi + CALL feldi() q = H(1)/rq dx = H(3) + H(3) + q*Xi(1) dy = H(4) + H(4) + q*Xi(2) @@ -523,187 +427,14 @@ SUBROUTINE stoer(P,Bq,R) dzm = u(1,3)*dx + u(2,3)*dy + u(3,3)*dz dr = (xm*dxm+ym*dym+zm*dzm)/R !*****FORM SLOWLY VARYING EXPRESSIONS - P(4) = (wr*dxm-0.5*P(1)*dr)/(R*dzm) - P(5) = (wr*dym-0.5*P(2)*dr)/(R*dzm) + P(4) = (wr*dxm-0.5_wp*P(1)*dr)/(R*dzm) + P(5) = (wr*dym-0.5_wp*P(2)*dr)/(R*dzm) dsq = rq*(dxm*dxm+dym*dym+dzm*dzm) Bq = dsq*rq*rq P(6) = sqrt(dsq/(rq+3.*zm*zm)) P(7) = P(6)*(rq+zm*zm)/(rq*dzm) END SUBROUTINE stoer -!*==feldg.f90 processed by SPAG 8.01MH 09:18 3 Feb 2024 -!!SPAG Open source Personal, Educational or Academic User NON-COMMERCIAL USE - Not for use on proprietary or closed source code -! -! -! SUBROUTINE feldg(Glat,Glon,Alt,Bnorth,Beast,Bdown,Babs) -! IMPLICIT NONE -! !*** Start of declarations inserted by SPAG -! REAL Alt , Aquad , B , Babs , Bdown , Beast , Bnorth , Bquad , brho , bxxx , byyy , bzzz , cp , ct , d , Era , f , G , Glat , & -! & Glon -! REAL H , rho , rlat , rlon , rq , s , sp , st , t , Time , Umr , V , x , Xi , xxx , y , yyy , z , zzz -! INTEGER i , ih , ihmax , il , imax , is , k , last , m , Nmax -! !*** End of declarations inserted by SPAG -! !------------------------------------------------------------------- -! ! CALCULATES EARTH MAGNETIC FIELD FROM SPHERICAL HARMONICS MODEL -! ! REF: G. KLUGE, EUROPEAN SPACE OPERATIONS CENTRE, INTERNAL NOTE 61, -! ! 1970. -! !-------------------------------------------------------------------- -! ! CHANGES (D. BILITZA, NOV 87): -! ! - FIELD COEFFICIENTS IN BINARY DATA FILES INSTEAD OF BLOCK DATA -! ! - CALCULATES DIPOL MOMENT -! !-------------------------------------------------------------------- -! ! INPUT: ENTRY POINT FELDG -! ! GLAT GEODETIC LATITUDE IN DEGREES (NORTH) -! ! GLON GEODETIC LONGITUDE IN DEGREES (EAST) -! ! ALT ALTITUDE IN KM ABOVE SEA LEVEL -! ! -! ! ENTRY POINT FELDC -! ! V(3) CARTESIAN COORDINATES IN EARTH RADII (6371.2 KM) -! ! X-AXIS POINTING TO EQUATOR AT 0 LONGITUDE -! ! Y-AXIS POINTING TO EQUATOR AT 90 LONG. -! ! Z-AXIS POINTING TO NORTH POLE -! ! -! ! COMMON BLANK AND ENTRY POINT FELDI ARE NEEDED WHEN USED -! ! IN CONNECTION WITH L-CALCULATION PROGRAM SHELLG. -! ! -! ! COMMON /MODEL/ AND /GENER/ -! ! UMR = ATAN(1.0)*4./180. *UMR= -! ! ERA EARTH RADIUS FOR NORMALIZATION OF CARTESIAN -! ! COORDINATES (6371.2 KM) -! ! AQUAD, BQUAD SQUARE OF MAJOR AND MINOR HALF AXIS FOR -! ! EARTH ELLIPSOID AS RECOMMENDED BY INTERNATIONAL -! ! ASTRONOMICAL UNION (6378.160, 6356.775 KM). -! ! NMAX MAXIMUM ORDER OF SPHERICAL HARMONICS -! ! TIME YEAR (DECIMAL: 1973.5) FOR WHICH MAGNETIC -! ! FIELD IS TO BE CALCULATED -! ! G(M) NORMALIZED FIELD COEFFICIENTS (SEE FELDCOF) -! ! M=NMAX*(NMAX+2) -! !------------------------------------------------------------------------ -! ! OUTPUT: BABS MAGNETIC FIELD STRENGTH IN GAUSS -! ! BNORTH, BEAST, BDOWN COMPONENTS OF THE FIELD WITH RESPECT -! ! TO THE LOCAL GEODETIC COORDINATE SYSTEM, WITH AXIS -! ! POINTING IN THE TANGENTIAL PLANE TO THE NORTH, EAST -! ! AND DOWNWARD. -! !----------------------------------------------------------------------- -! DIMENSION V(3) , B(3) -! CHARACTER*14 Name -! COMMON Xi(3) , H(144) -! COMMON /model / Name , Nmax , Time , G(144) -! COMMON /gener / Umr , Era , Aquad , Bquad -! INTEGER :: spag_nextblock_1 -! INTEGER :: spag_nextblock_2 -! spag_nextblock_1 = 1 -! SPAG_DispatchLoop_1: DO -! SELECT CASE (spag_nextblock_1) -! CASE (1) -! ! -! !-- IS RECORDS ENTRY POINT -! ! -! !*****ENTRY POINT FELDG TO BE USED WITH GEODETIC CO-ORDINATES -! is = 1 -! rlat = Glat*Umr -! ct = sin(rlat) -! st = cos(rlat) -! d = sqrt(Aquad-(Aquad-Bquad)*ct*ct) -! rlon = Glon*Umr -! cp = cos(rlon) -! sp = sin(rlon) -! zzz = (Alt+Bquad/d)*ct/Era -! rho = (Alt+Aquad/d)*st/Era -! xxx = rho*cp -! yyy = rho*sp -! spag_nextblock_1 = 2 -! CYCLE SPAG_DispatchLoop_1 -! ! -! !*****ENTRY POINT FELDC TO BE USED WITH CARTESIAN CO-ORDINATES -! ENTRY feldc(V,B) -! is = 2 -! xxx = V(1) -! yyy = V(2) -! zzz = V(3) -! spag_nextblock_1 = 2 -! CASE (2) -! rq = 1./(xxx*xxx+yyy*yyy+zzz*zzz) -! Xi(1) = xxx*rq -! Xi(2) = yyy*rq -! Xi(3) = zzz*rq -! spag_nextblock_1 = 3 -! CYCLE SPAG_DispatchLoop_1 -! ! -! !*****ENTRY POINT FELDI USED FOR L COMPUTATION -! ENTRY feldi -! is = 3 -! spag_nextblock_1 = 3 -! CASE (3) -! ihmax = Nmax*Nmax + 1 -! last = ihmax + Nmax + Nmax -! imax = Nmax + Nmax - 1 -! DO i = ihmax , last -! H(i) = G(i) -! ENDDO -! DO k = 1 , 3 , 2 -! spag_nextblock_2 = 1 -! SPAG_DispatchLoop_2: DO -! SELECT CASE (spag_nextblock_2) -! CASE (1) -! i = imax -! ih = ihmax -! spag_nextblock_2 = 2 -! CASE (2) -! il = ih - i -! f = 2./float(i-k+2) -! x = Xi(1)*f -! y = Xi(2)*f -! z = Xi(3)*(f+f) -! i = i - 2 -! IF ( i<1 ) THEN -! spag_nextblock_2 = 3 -! CYCLE SPAG_DispatchLoop_2 -! ENDIF -! IF ( i/=1 ) THEN -! DO m = 3 , i , 2 -! H(il+m+1) = G(il+m+1) + z*H(ih+m+1) + x*(H(ih+m+3)-H(ih+m-1)) - y*(H(ih+m+2)+H(ih+m-2)) -! H(il+m) = G(il+m) + z*H(ih+m) + x*(H(ih+m+2)-H(ih+m-2)) + y*(H(ih+m+3)+H(ih+m-1)) -! ENDDO -! ENDIF -! H(il+2) = G(il+2) + z*H(ih+2) + x*H(ih+4) - y*(H(ih+3)+H(ih)) -! H(il+1) = G(il+1) + z*H(ih+1) + y*H(ih+4) + x*(H(ih+3)-H(ih)) -! spag_nextblock_2 = 3 -! CASE (3) -! H(il) = G(il) + z*H(ih) + 2.*(x*H(ih+1)+y*H(ih+2)) -! ih = il -! IF ( i>=k ) THEN -! spag_nextblock_2 = 2 -! CYCLE SPAG_DispatchLoop_2 -! ENDIF -! EXIT SPAG_DispatchLoop_2 -! END SELECT -! ENDDO SPAG_DispatchLoop_2 -! ENDDO -! IF ( is==3 ) RETURN -! s = .5*H(1) + 2.*(H(2)*Xi(3)+H(3)*Xi(1)+H(4)*Xi(2)) -! t = (rq+rq)*sqrt(rq) -! bxxx = t*(H(3)-s*xxx) -! byyy = t*(H(4)-s*yyy) -! bzzz = t*(H(2)-s*zzz) -! IF ( is==2 ) THEN -! B(1) = bxxx -! B(2) = byyy -! B(3) = bzzz -! RETURN -! ENDIF -! Babs = sqrt(bxxx*bxxx+byyy*byyy+bzzz*bzzz) -! Beast = byyy*cp - bxxx*sp -! brho = byyy*sp + bxxx*cp -! Bnorth = bzzz*st - brho*ct -! Bdown = -bzzz*ct - brho*st -! RETURN -! END SELECT -! ENDDO SPAG_DispatchLoop_1 -! END SUBROUTINE feldg - -!.... NOTE: this one was broken by SPAG (above)... so revert to original and see -! if we can manually refactor it. subroutine feldg(glat,glon,alt,bnorth,beast,bdown,babs) !------------------------------------------------------------------- ! calculates earth magnetic field from spherical harmonics model @@ -748,19 +479,16 @@ subroutine feldg(glat,glon,alt,bnorth,beast,bdown,babs) ! and downward. !----------------------------------------------------------------------- - !*** Start of declarations inserted by SPAG - REAL Alt , Aquad , B , Babs , Bdown , Beast , Bnorth , Bquad , brho , bxxx , & - byyy , bzzz , cp , ct , d , Era , f , G , Glat , Glon - REAL H , rho , rlat , rlon , rq , s , sp , st , t , Time , Umr , V , x , Xi , xxx , y , yyy , z , zzz - INTEGER i , ih , ihmax , il , imax , is , k , last , m , Nmax - !*** End of declarations inserted by SPAG + REAL(wp) Alt , B , Babs , Bdown , Beast , Bnorth , brho , bxxx , & + byyy , bzzz , cp , ct , d , f , G , Glat , Glon + REAL(wp) H , rho , rlat , rlon , rq , s , sp , st , t , Time , V , x , Xi , xxx , y , yyy , z , zzz + INTEGER i , ih , ihmax , il , imax , is , k , last , m , Nmax dimension v(3),b(3) character*14 name common xi(3),h(144) common/model/ name,nmax,time,g(144) - common/gener/ umr,era,aquad,bquad ! !-- is records entry point ! @@ -773,11 +501,11 @@ subroutine feldg(glat,glon,alt,bnorth,beast,bdown,babs) rlon=glon*umr cp=cos(rlon) sp=sin(rlon) - zzz=(alt+bquad/d)*ct/era - rho=(alt+aquad/d)*st/era - xxx=rho*cp - yyy=rho*sp - goto 10 + zzz=(alt+bquad/d)*ct/era + rho=(alt+aquad/d)*st/era + xxx=rho*cp + yyy=rho*sp + goto 10 ! !*****entry point feldc to be used with cartesian co-ordinates entry feldc(v,b) @@ -792,7 +520,7 @@ subroutine feldg(glat,glon,alt,bnorth,beast,bdown,babs) goto 20 ! !*****entry point feldi used for l computation - entry feldi + entry feldi() is=3 20 ihmax=nmax*nmax+1 last=ihmax+nmax+nmax @@ -804,7 +532,7 @@ subroutine feldg(glat,glon,alt,bnorth,beast,bdown,babs) i=imax ih=ihmax 1 il=ih-i - f=2./float(i-k+2) + f=2.0_wp/real(i-k+2, wp) x=xi(1)*f y=xi(2)*f z=xi(3)*(f+f) @@ -819,13 +547,13 @@ subroutine feldg(glat,glon,alt,bnorth,beast,bdown,babs) h(il+2)=g(il+2)+z*h(ih+2)+x*h(ih+4)-y*(h(ih+3)+h(ih)) h(il+1)=g(il+1)+z*h(ih+1)+y*h(ih+4)+x*(h(ih+3)-h(ih)) end if - h(il)=g(il)+z*h(ih)+2.*(x*h(ih+1)+y*h(ih+2)) + h(il)=g(il)+z*h(ih)+2.0_wp*(x*h(ih+1)+y*h(ih+2)) ih=il if (i>=k) goto 1 end do if (is==3) return - s=.5*h(1)+2.*(h(2)*xi(3)+h(3)*xi(1)+h(4)*xi(2)) + s=0.5_wp*h(1)+2.0_wp*(h(2)*xi(3)+h(3)*xi(1)+h(4)*xi(2)) t=(rq+rq)*sqrt(rq) bxxx=t*(h(3)-s*xxx) byyy=t*(h(4)-s*yyy) @@ -844,16 +572,10 @@ subroutine feldg(glat,glon,alt,bnorth,beast,bdown,babs) end subroutine feldg -!*==feldcof.f90 processed by SPAG 8.01MH 09:18 3 Feb 2024 -!!SPAG Open source Personal, Educational or Academic User NON-COMMERCIAL USE - Not for use on proprietary or closed source code -! -! SUBROUTINE feldcof(Year,Dimo) IMPLICIT NONE -!*** Start of declarations inserted by SPAG - REAL Aquad , Bquad , Dimo , dte1 , dte2 , dtemod , Erad , Gh1 , gh2 , gha , sqrt2 , Time , Umr , Year + REAL(wp) Dimo , dte1 , dte2 , Erad , Gh1 , gh2 , gha , sqrt2 , Time , Year INTEGER i , ier , is , iu , iyea , j , l , m , n , Nmax , nmax1 , nmax2 , numye -!*** End of declarations inserted by SPAG !------------------------------------------------------------------------ ! DETERMINES COEFFICIENTS AND DIPOL MOMENT FROM IGRF MODELS ! @@ -867,18 +589,28 @@ SUBROUTINE feldcof(Year,Dimo) ! ### updated to IGRF-2000 version -dkb- 5/31/2000 ! ### updated to IGRF-2005 version -dkb- 3/24/2000 !----------------------------------------------------------------------- - CHARACTER*14 filmod , Fil1 , fil2 + + CHARACTER(len=14) Fil1 , fil2 ! ### FILMOD, DTEMOD arrays +1 - DIMENSION Gh1(144) , gh2(120) , gha(144) , filmod(17) , dtemod(17) - DOUBLE PRECISION x , f0 , f + DIMENSION Gh1(144) , gh2(120) , gha(144) + real(wp) :: x , f0 , f !! JW: these were double precision in original code while everything else was single precision + COMMON /model/ Fil1 , Nmax , Time , Gh1 - COMMON /gener/ Umr , Erad , Aquad , Bquad -! ### changed to conform with IGRF 45-95, also FILMOD, DTEMOD arrays +1 - DATA filmod/'dgrf1945.dat' , 'dgrf1950.dat' , 'dgrf1955.dat' , 'dgrf1960.dat' , 'dgrf1965.dat' , 'dgrf1970.dat' , & - & 'dgrf1975.dat' , 'dgrf1980.dat' , 'dgrf1985.dat' , 'dgrf1990.dat' , 'dgrf1995.dat' , 'dgrf2000.dat' , 'dgrf2005.dat' , & - &'dgrf2010.dat' , 'dgrf2015.dat' , 'igrf2020.dat' , 'igrf2020s.dat'/ - DATA dtemod/1945. , 1950. , 1955. , 1960. , 1965. , 1970. , 1975. , 1980. , 1985. , 1990. , 1995. , 2000. , 2005. , 2010. , & - & 2015. , 2020. , 2025./ + !COMMON /gener/ Umr , Erad , Aquad , Bquad + + ! ### changed to conform with IGRF 45-95, also FILMOD, DTEMOD arrays +1 + character(len=14),dimension(17),parameter :: filmod = [& + 'dgrf1945.dat ' , 'dgrf1950.dat ' , 'dgrf1955.dat ' , 'dgrf1960.dat ' , & + 'dgrf1965.dat ' , 'dgrf1970.dat ' , 'dgrf1975.dat ' , 'dgrf1980.dat ' , & + 'dgrf1985.dat ' , 'dgrf1990.dat ' , 'dgrf1995.dat ' , 'dgrf2000.dat ' , & + 'dgrf2005.dat ' , 'dgrf2010.dat ' , 'dgrf2015.dat ' , 'igrf2020.dat ' , & + 'igrf2020s.dat'] + real(wp),dimension(17),parameter :: dtemod = [1945.0_wp , 1950.0_wp , 1955.0_wp , & + 1960.0_wp , 1965.0_wp , 1970.0_wp , & + 1975.0_wp , 1980.0_wp , 1985.0_wp , & + 1990.0_wp , 1995.0_wp , 2000.0_wp , & + 2005.0_wp , 2010.0_wp , 2015.0_wp , & + 2020.0_wp , 2025.0_wp] ! ! ### numye is number of 5-year priods represented by IGRF ! @@ -891,7 +623,7 @@ SUBROUTINE feldcof(Year,Dimo) is = 0 !-- DETERMINE IGRF-YEARS FOR INPUT-YEAR Time = Year - iyea = int(Year/5.)*5 + iyea = int(Year/5.0_wp)*5 l = (iyea-1945)/5 + 1 IF ( l<1 ) l = 1 IF ( l>numye ) l = numye @@ -911,30 +643,30 @@ SUBROUTINE feldcof(Year,Dimo) CALL extrashc(Year,dte1,nmax1,Gh1,nmax2,gh2,Nmax,gha) ENDIF !-- DETERMINE MAGNETIC DIPOL MOMENT AND COEFFIECIENTS G - f0 = 0.D0 + f0 = 0.0_wp DO j = 1 , 3 - f = gha(j)*1.D-5 + f = gha(j)*1.0e-5_wp f0 = f0 + f*f ENDDO Dimo = sqrt(f0) - Gh1(1) = 0.0 + Gh1(1) = 0.0_wp i = 2 - f0 = 1.D-5 + f0 = 1.0e-5_wp IF ( is==0 ) f0 = -f0 - sqrt2 = sqrt(2.) + sqrt2 = sqrt(2.0_wp) DO n = 1 , Nmax x = n - f0 = f0*x*x/(4.D0*x-2.D0) - IF ( is==0 ) f0 = f0*(2.D0*x-1.D0)/x - f = f0*0.5D0 + f0 = f0*x*x/(4.0_wp*x-2.0_wp) + IF ( is==0 ) f0 = f0*(2.0_wp*x-1.0_wp)/x + f = f0*0.5_wp IF ( is==0 ) f = f*sqrt2 Gh1(i) = gha(i-1)*f0 i = i + 1 DO m = 1 , n - f = f*(x+m)/(x-m+1.D0) - IF ( is==0 ) f = f*sqrt((x-m+1.D0)/(x+m)) + f = f*(x+m)/(x-m+1.0_wp) + IF ( is==0 ) f = f*sqrt((x-m+1.0_wp)/(x+m)) Gh1(i) = gha(i-1)*f Gh1(i+1) = gha(i)*f i = i + 2 @@ -942,16 +674,10 @@ SUBROUTINE feldcof(Year,Dimo) ENDDO END SUBROUTINE feldcof -!*==getshc.f90 processed by SPAG 8.01MH 09:18 3 Feb 2024 -!!SPAG Open source Personal, Educational or Academic User NON-COMMERCIAL USE - Not for use on proprietary or closed source code -! -! SUBROUTINE getshc(Iu,Fspec,Nmax,Erad,Gh,Ier) IMPLICIT NONE -!*** Start of declarations inserted by SPAG - REAL Erad , g , Gh , h + REAL(wp) Erad , g , Gh , h INTEGER i , Ier , Iu , m , mm , n , Nmax , nn -!*** End of declarations inserted by SPAG ! =============================================================== ! @@ -1031,16 +757,10 @@ SUBROUTINE getshc(Iu,Fspec,Nmax,Erad,Gh,Ier) END SUBROUTINE getshc -!*==intershc.f90 processed by SPAG 8.01MH 09:18 3 Feb 2024 -!!SPAG Open source Personal, Educational or Academic User NON-COMMERCIAL USE - Not for use on proprietary or closed source code -! -! SUBROUTINE intershc(Date,Dte1,Nmax1,Gh1,Dte2,Nmax2,Gh2,Nmax,Gh) IMPLICIT NONE -!*** Start of declarations inserted by SPAG - REAL Date , Dte1 , Dte2 , factor , Gh , Gh1 , Gh2 + REAL(wp) Date , Dte1 , Dte2 , factor , Gh , Gh1 , Gh2 INTEGER i , k , l , Nmax , Nmax1 , Nmax2 -!*** End of declarations inserted by SPAG ! =============================================================== ! @@ -1107,16 +827,10 @@ SUBROUTINE intershc(Date,Dte1,Nmax1,Gh1,Dte2,Nmax2,Gh2,Nmax,Gh) END SUBROUTINE intershc -!*==extrashc.f90 processed by SPAG 8.01MH 09:18 3 Feb 2024 -!!SPAG Open source Personal, Educational or Academic User NON-COMMERCIAL USE - Not for use on proprietary or closed source code -! -! SUBROUTINE extrashc(Date,Dte1,Nmax1,Gh1,Nmax2,Gh2,Nmax,Gh) IMPLICIT NONE -!*** Start of declarations inserted by SPAG - REAL Date , Dte1 , factor , Gh , Gh1 , Gh2 + REAL(wp) Date , Dte1 , factor , Gh , Gh1 , Gh2 INTEGER i , k , l , Nmax , Nmax1 , Nmax2 -!*** End of declarations inserted by SPAG ! =============================================================== ! @@ -1183,36 +897,5 @@ SUBROUTINE extrashc(Date,Dte1,Nmax1,Gh1,Nmax2,Gh2,Nmax,Gh) END SUBROUTINE extrashc -!*==initize.f90 processed by SPAG 8.01MH 09:18 3 Feb 2024 -!!SPAG Open source Personal, Educational or Academic User NON-COMMERCIAL USE - Not for use on proprietary or closed source code -! -! -SUBROUTINE initize() - IMPLICIT NONE -!*** Start of declarations inserted by SPAG - REAL Aquad , Bquad , Era , erequ , erpol , Umr -!*** End of declarations inserted by SPAG -!---------------------------------------------------------------- -! Initializes the parameters in COMMON/GENER/ -! -! UMR = ATAN(1.0)*4./180. *UMR= -! ERA EARTH RADIUS FOR NORMALIZATION OF CARTESIAN -! COORDINATES (6371.2 KM) -! EREQU MAJOR HALF AXIS FOR EARTH ELLIPSOID (6378.160 KM) -! ERPOL MINOR HALF AXIS FOR EARTH ELLIPSOID (6356.775 KM) -! AQUAD SQUARE OF MAJOR HALF AXIS FOR EARTH ELLIPSOID -! BQUAD SQUARE OF MINOR HALF AXIS FOR EARTH ELLIPSOID -! -! ERA, EREQU and ERPOL as recommended by the INTERNATIONAL -! ASTRONOMICAL UNION . -!----------------------------------------------------------------- - COMMON /gener / Umr , Era , Aquad , Bquad - Era = 6371.2 - erequ = 6378.16 - erpol = 6356.775 - Aquad = erequ*erequ - Bquad = erpol*erpol - Umr = atan(1.0)*4./180. -END SUBROUTINE initize end module SHELLIG_module \ No newline at end of file diff --git a/src/trmfun.f90 b/src/trmfun.f90 index f629efc..6464466 100644 --- a/src/trmfun.f90 +++ b/src/trmfun.f90 @@ -1,5 +1,7 @@ module radbelt_module + use radbelt_kinds_module + ! trmfun.for 1987 implicit none @@ -28,21 +30,23 @@ module radbelt_module !*********************************************************************** subroutine trara1(descr,map,fl,bb0,e,f,n) - real bb0 , e , e0 , e1 , e2 , escale , f , f0 , f1 , f2 , fistep , fl , fscale , xnl + real(wp) bb0 , e , e0 , e1 , e2 , escale , f , f0 , f1 , f2 , fistep , fl , fscale , xnl integer i0 , i1 , i2 , i3 , ie , l3 , map , n , nb , nl logical s0 , s1 , s2 dimension e(n) , f(n) , map(*) integer descr(8) - common /tra2 / fistep - data f1 , f2/1.001 , 1.002/ -! + + common /tra2/ fistep + + data f1 , f2/1.001_wp , 1.002_wp/ + fistep = descr(7)/descr(2) escale = descr(4) fscale = descr(7) - xnl = amin1(15.6,abs(fl)) + xnl = min(15.6_wp,abs(fl)) nl = xnl*descr(5) - if ( bb0<1. ) bb0 = 1. - nb = (bb0-1.)*descr(6) + if ( bb0<1.0_wp ) bb0 = 1.0_wp + nb = (bb0-1.0_wp)*descr(6) ! ! i2 is the number of elements in the flux map for the first energy. ! i3 is the index of the last element of the second energy map. @@ -99,7 +103,7 @@ subroutine trara1(descr,map,fl,bb0,e,f,n) ! finally, interpolate in energy. ! f(ie) = f1 + (f2-f1)*(e(ie)-e1)/(e2-e1) - if ( f2<=0.0 ) then + if ( f2<=0.0_wp ) then if ( i1/=0 ) then ! ! --------- special interpolation --------------------------------- @@ -111,13 +115,13 @@ subroutine trara1(descr,map,fl,bb0,e,f,n) ! if ( s0 ) f0 = trara2(map(i0+3),nl,nb)/fscale s0 = .false. - f(ie) = amin1(f(ie),f0+(f1-f0)*(e(ie)-e0)/(e1-e0)) + f(ie) = min(f(ie),f0+(f1-f0)*(e(ie)-e0)/(e1-e0)) endif endif ! ! the logarithmic flux is always kept greater or equal zero. ! - f(ie) = amax1(f(ie),0.) + f(ie) = max(f(ie),0.0_wp) enddo end subroutine trara1 @@ -137,13 +141,13 @@ end subroutine trara1 !***************************************************************** function trara2(map,il,ib) - real dfl , fincr1 , fincr2 , fistep , fkb , fkb1 , fkb2 , fkbj1 , fkbj2 , & - fkbm , fll1 , fll2 , flog , flog1 , flog2 , flogm , & - fnb , fnl , sl1 , sl2 - real trara2 + real(wp) dfl , fincr1 , fincr2 , fistep , fkb , fkb1 , fkb2 , fkbj1 , fkbj2 , & + fkbm , fll1 , fll2 , flog , flog1 , flog2 , flogm , & + fnb , fnl , sl1 , sl2 + real(wp) trara2 integer i1 , i2 , ib , il , itime , j1 , j2 , kt , l1 , l2 , map(*) - common /tra2 / fistep + common /tra2/ fistep integer :: spag_nextblock_1 spag_nextblock_1 = 1 @@ -169,7 +173,7 @@ function trara2(map,il,ib) ! if sub-sub-maps are empty, i. e. length less 4, than trara2=0 ! elseif ( (l1<4) .and. (l2<4) ) then - trara2 = 0. + trara2 = 0.0_wp return else ! @@ -198,8 +202,8 @@ function trara2(map,il,ib) dfl = (fnl-fll1)/(fll2-fll1) flog1 = map(i1+3) flog2 = map(i2+3) - fkb1 = 0. - fkb2 = 0. + fkb1 = 0.0_wp + fkb2 = 0.0_wp if ( l1>=4 ) then ! ! b/b0 loop @@ -215,7 +219,7 @@ function trara2(map,il,ib) spag_nextblock_1 = 2 cycle main endif - trara2 = 0. + trara2 = 0.0_wp return 10 if ( itime/=1 ) then if ( j2==4 ) then @@ -227,11 +231,11 @@ function trara2(map,il,ib) fincr1 = map(i1+j1) fkb1 = fkb1 + fincr1 flog1 = flog1 - fistep - fkbj1 = ((flog1/fistep)*fincr1+fkb1)/((fincr1/fistep)*sl2+1.) + fkbj1 = ((flog1/fistep)*fincr1+fkb1)/((fincr1/fistep)*sl2+1.0_wp) if ( fkbj1<=fkb1 ) goto 15 enddo if ( fkbj1<=fkb2 ) then - trara2 = 0. + trara2 = 0.0_wp return endif 15 if ( fkbj1<=fkb2 ) then @@ -244,10 +248,10 @@ function trara2(map,il,ib) spag_nextblock_1 = 5 cycle main else - fkb1 = 0. + fkb1 = 0.0_wp endif endif - fkb2 = 0. + fkb2 = 0.0_wp endif j2 = 4 fincr2 = map(i2+j2) @@ -256,13 +260,13 @@ function trara2(map,il,ib) spag_nextblock_1 = 4 case (4) flogm = flog1 + (flog2-flog1)*dfl - fkbm = 0. + fkbm = 0.0_wp fkb2 = fkb2 + fincr2 flog2 = flog2 - fistep sl2 = flog2/fkb2 if ( l1<4 ) then - fincr1 = 0. - sl1 = -900000. + fincr1 = 0.0_wp + sl1 = -900000.0_wp spag_nextblock_1 = 6 cycle main else @@ -275,7 +279,7 @@ function trara2(map,il,ib) spag_nextblock_1 = 5 case (5) do while ( sl1>=sl2 ) - fkbj2 = ((flog2/fistep)*fincr2+fkb2)/((fincr2/fistep)*sl1+1.) + fkbj2 = ((flog2/fistep)*fincr2+fkb2)/((fincr2/fistep)*sl1+1.0_wp) fkb = fkb1 + (fkbj2-fkb1)*dfl flog = fkb*sl1 if ( fkb>=fnb ) then @@ -285,7 +289,7 @@ function trara2(map,il,ib) fkbm = fkb flogm = flog if ( j1>=l1 ) then - trara2 = 0. + trara2 = 0.0_wp return else j1 = j1 + 1 @@ -297,14 +301,14 @@ function trara2(map,il,ib) enddo spag_nextblock_1 = 6 case (6) - fkbj1 = ((flog1/fistep)*fincr1+fkb1)/((fincr1/fistep)*sl2+1.) + fkbj1 = ((flog1/fistep)*fincr1+fkb1)/((fincr1/fistep)*sl2+1.0_wp) fkb = fkbj1 + (fkb2-fkbj1)*dfl flog = fkb*sl2 if ( fkb=l2 ) then - trara2 = 0. + trara2 = 0.0_wp return else j2 = j2 + 1 @@ -318,16 +322,17 @@ function trara2(map,il,ib) endif spag_nextblock_1 = 7 case (7) - if ( fkb0.10 ) iei = 2 IF ( ei>0.25 ) iei = 3 diff --git a/test/radbelt_test.f90 b/test/radbelt_test.f90 index 9936ef5..a9c7616 100644 --- a/test/radbelt_test.f90 +++ b/test/radbelt_test.f90 @@ -3,35 +3,35 @@ program radbelt_test !! comparison to the python radbelt example use core + use radbelt_kinds_module implicit none - real :: lon, lat, height, year, xl,bbx - REAL, DIMENSION(1) :: E - INTEGER :: Imname - REAL, DIMENSION(1) :: Flux, error + real(wp) :: lon, lat, height, year, e, flux, error, relerror + integer :: imname - lon = -45.0 - lat = -30.0 - height = 500.0 + lon = -45.0_wp + lat = -30.0_wp + height = 500.0_wp ! >>> from astropy.time import Time ! >>> time = Time('2021-03-01') ! >>> time.utc.decimalyear - year = 2021.1616438356164 ! decimal year - + year = 2021.1616438356164_wp ! decimal year Imname = 4 ! 'p', 'max' - e = 20.0 + e = 20.0_wp - call igrf(Lon,Lat,Height,Year,Xl,Bbx) - call aep8(E,Xl,Bbx,Imname,Flux) + flux = get_flux(lon,lat,height,year,e,imname) - error = Flux - 2642.50268555 ! difference from python wrapper version (radbelt) + ! error = Flux - 2642.50268555_wp ! difference from python wrapper version (radbelt) + error = Flux - 2642.50370051985726336559603128948869_wp ! difference from real128 version + relerror = abs(error/flux) - write(*,*) 'Flux = ', Flux - write(*,*) 'Error = ', error + write(*,*) 'Flux = ', flux + write(*,*) 'Error = ', error + write(*,*) 'Rel Error = ', relerror - if (abs(error(1))>1.0e-9) error stop 'error' + if (relerror>10*epsilon(1.0_wp)) error stop 'error' end program radbelt_test From 6c890bcc276bb5c6a109b45398476250413d39d3 Mon Sep 17 00:00:00 2001 From: Jacob Williams Date: Sun, 4 Feb 2024 21:56:00 -0600 Subject: [PATCH 04/13] refactoring and docstrings --- README.md | 1 + src/shellig.f90 | 538 +++++++++++++++++++++++------------------------- 2 files changed, 258 insertions(+), 281 deletions(-) diff --git a/README.md b/README.md index 8c1b686..b2a14f9 100755 --- a/README.md +++ b/README.md @@ -77,6 +77,7 @@ two lines had been exchanged. * [NASA ModelWebArchive](https://git.smce.nasa.gov/ccmc-share/modelwebarchive) * [An Astropy-friendly wrapper for the AE-8/AP-8 Van Allen belt model](https://github.com/nasa/radbelt) * [pyIGRF](https://github.com/rilma/pyIGRF) +* https://github.com/lanl/RAM-SCB/blob/master/srcExternal/igrf.f ### REFERENCES: diff --git a/src/shellig.f90 b/src/shellig.f90 index 3ea8f54..7aafabc 100644 --- a/src/shellig.f90 +++ b/src/shellig.f90 @@ -169,9 +169,9 @@ subroutine shellg(glat,glon,alt,dimo,fl,icode,b0) +0.9335804_wp , +0.3583680_wp , +0.0000000_wp , & +0.0714471_wp , -0.1861260_wp , +0.9799247_wp], [3,3]) -! COMMON -! X(3) NOT USED -! H(144) FIELD MODEL COEFFICIENTS ADJUSTED FOR SHELLG +! COMMON +! X(3) NOT USED +! H(144) FIELD MODEL COEFFICIENTS ADJUSTED FOR SHELLG COMMON X(3) , H(144) COMMON /fidb0 / Sp @@ -197,10 +197,10 @@ subroutine shellg(glat,glon,alt,dimo,fl,icode,b0) RETURN !*****ENTRY POINT SHELLC TO BE USED WITH CARTESIAN CO-ORDINATES -! V(3) CARTESIAN COORDINATES IN EARTH RADII (6371.2 KM) -! X-AXIS POINTING TO EQUATOR AT 0 LONGITUDE -! Y-AXIS POINTING TO EQUATOR AT 90 LONG. -! Z-AXIS POINTING TO NORTH POLE +! V(3) CARTESIAN COORDINATES IN EARTH RADII (6371.2 KM) +! X-AXIS POINTING TO EQUATOR AT 0 LONGITUDE +! Y-AXIS POINTING TO EQUATOR AT 90 LONG. +! Z-AXIS POINTING TO NORTH POLE ENTRY shellc(V,Fl,B0) X(1) = V(1) X(2) = V(2) @@ -209,7 +209,7 @@ subroutine shellg(glat,glon,alt,dimo,fl,icode,b0) CONTAINS - SUBROUTINE spag_block_1 + subroutine spag_block_1 integer,parameter :: max_loop_index = 100 ! 3333 <--- original code had 3333 ... was this a bug ???? @@ -383,18 +383,18 @@ SUBROUTINE spag_block_1 ENDIF Fl = exp(log((1.0_wp+exp(gg))*dimob0)/3.0_wp) RETURN - END SUBROUTINE spag_block_1 + END subroutine spag_block_1 -END SUBROUTINE shellg +END subroutine shellg -SUBROUTINE stoer(P,Bq,R) +subroutine stoer(P,Bq,R) IMPLICIT NONE REAL(wp) Bq , dr , dsq , dx , dxm , dy , dym , dz , dzm , fli , & H , P , q , R , rq , wr , Xi , xm , ym REAL(wp) zm !******************************************************************* -!* SUBROUTINE USED FOR FIELD LINE TRACING IN SHELLG * -!* CALLS ENTRY POINT FELDI IN GEOMAGNETIC FIELD SUBROUTINE FELDG * +!* subroutine USED FOR FIELD LINE TRACING IN SHELLG * +!* CALLS ENTRY POINT FELDI IN GEOMAGNETIC FIELD subroutine FELDG * !******************************************************************* DIMENSION P(7) real(wp),dimension(3,3),parameter :: u = reshape([ +0.3511737_wp , -0.9148385_wp , -0.1993679_wp , & @@ -433,7 +433,7 @@ SUBROUTINE stoer(P,Bq,R) Bq = dsq*rq*rq P(6) = sqrt(dsq/(rq+3.*zm*zm)) P(7) = P(6)*(rq+zm*zm)/(rq*dzm) -END SUBROUTINE stoer +END subroutine stoer subroutine feldg(glat,glon,alt,bnorth,beast,bdown,babs) !------------------------------------------------------------------- @@ -572,33 +572,36 @@ subroutine feldg(glat,glon,alt,bnorth,beast,bdown,babs) end subroutine feldg -SUBROUTINE feldcof(Year,Dimo) - IMPLICIT NONE - REAL(wp) Dimo , dte1 , dte2 , Erad , Gh1 , gh2 , gha , sqrt2 , Time , Year - INTEGER i , ier , is , iu , iyea , j , l , m , n , Nmax , nmax1 , nmax2 , numye !------------------------------------------------------------------------ -! DETERMINES COEFFICIENTS AND DIPOL MOMENT FROM IGRF MODELS +!> +! Determines coefficients and dipol moment from IGRF models ! -! INPUT: YEAR DECIMAL YEAR FOR WHICH GEOMAGNETIC FIELD IS TO -! BE CALCULATED (e.g.:1995.5 for day 185 of 1995) -! OUTPUT: DIMO GEOMAGNETIC DIPOL MOMENT IN GAUSS (NORMALIZED -! TO EARTH'S RADIUS) AT THE TIME (YEAR) -! D. BILITZA, NSSDC, GSFC, CODE 633, GREENBELT, MD 20771, -! (301)286-9536 NOV 1987. -! -corrected for 2000 update - dkb- 5/31/2000 -! ### updated to IGRF-2000 version -dkb- 5/31/2000 -! ### updated to IGRF-2005 version -dkb- 3/24/2000 -!----------------------------------------------------------------------- - - CHARACTER(len=14) Fil1 , fil2 -! ### FILMOD, DTEMOD arrays +1 - DIMENSION Gh1(144) , gh2(120) , gha(144) - real(wp) :: x , f0 , f !! JW: these were double precision in original code while everything else was single precision +!### Author +! * D. BILITZA, NSSDC, GSFC, CODE 633, GREENBELT, MD 20771, +! (301) 286-9536 NOV 1987. +! +!### History +! * corrected for 2000 update - dkb- 5/31/2000 +! * updated to IGRF-2000 version -dkb- 5/31/2000 +! * updated to IGRF-2005 version -dkb- 3/24/2000 + + subroutine feldcof(year,dimo) + + real(wp),intent(in) :: year !! decimal year for which geomagnetic field is to + !! be calculated (e.g.:1995.5 for day 185 of 1995) + real(wp),intent(out) :: dimo !! geomagnetic dipol moment in gauss (normalized + !! to earth's radius) at the time (year) + + real(wp) :: dte1 , dte2 , erad , gh1(144) , gh2(120) , gha(144) , sqrt2 , time + integer :: i , ier , is , iyea , j , l , m , n , nmax , nmax1 , nmax2 , numye + + character(len=14) :: Fil1 , fil2 + real(wp) :: x , f0 , f !! JW: these were double precision in original + !! code while everything else was single precision COMMON /model/ Fil1 , Nmax , Time , Gh1 - !COMMON /gener/ Umr , Erad , Aquad , Bquad - ! ### changed to conform with IGRF 45-95, also FILMOD, DTEMOD arrays +1 + ! changed to conform with IGRF 45-95, also FILMOD, DTEMOD arrays +1 character(len=14),dimension(17),parameter :: filmod = [& 'dgrf1945.dat ' , 'dgrf1950.dat ' , 'dgrf1955.dat ' , 'dgrf1960.dat ' , & 'dgrf1965.dat ' , 'dgrf1970.dat ' , 'dgrf1975.dat ' , 'dgrf1980.dat ' , & @@ -611,291 +614,264 @@ SUBROUTINE feldcof(Year,Dimo) 1990.0_wp , 1995.0_wp , 2000.0_wp , & 2005.0_wp , 2010.0_wp , 2015.0_wp , & 2020.0_wp , 2025.0_wp] -! -! ### numye is number of 5-year priods represented by IGRF -! - numye = 16 -! -! IS=0 FOR SCHMIDT NORMALIZATION IS=1 GAUSS NORMALIZATION -! IU IS INPUT UNIT NUMBER FOR IGRF COEFFICIENT SETS -! - iu = 10 - is = 0 -!-- DETERMINE IGRF-YEARS FOR INPUT-YEAR - Time = Year - iyea = int(Year/5.0_wp)*5 + + numye = 16 ! number of 5-year priods represented by IGRF + is = 0 ! is=0 for schmidt normalization + ! is=1 gauss normalization + + !-- determine igrf-years for input-year + time = year + iyea = int(year/5.0_wp)*5 l = (iyea-1945)/5 + 1 - IF ( l<1 ) l = 1 - IF ( l>numye ) l = numye + if ( l<1 ) l = 1 + if ( l>numye ) l = numye dte1 = dtemod(l) - Fil1 = filmod(l) + fil1 = filmod(l) dte2 = dtemod(l+1) fil2 = filmod(l+1) -!-- GET IGRF COEFFICIENTS FOR THE BOUNDARY YEARS - CALL getshc(iu,Fil1,nmax1,Erad,Gh1,ier) - IF ( ier/=0 ) STOP - CALL getshc(iu,fil2,nmax2,Erad,gh2,ier) - IF ( ier/=0 ) STOP -!-- DETERMINE IGRF COEFFICIENTS FOR YEAR - IF ( l<=numye-1 ) THEN - CALL intershc(Year,dte1,nmax1,Gh1,dte2,nmax2,gh2,Nmax,gha) - ELSE - CALL extrashc(Year,dte1,nmax1,Gh1,nmax2,gh2,Nmax,gha) - ENDIF -!-- DETERMINE MAGNETIC DIPOL MOMENT AND COEFFIECIENTS G + !-- get igrf coefficients for the boundary years + call getshc(fil1,nmax1,erad,gh1,ier) + if ( ier/=0 ) stop + call getshc(fil2,nmax2,erad,gh2,ier) + if ( ier/=0 ) stop + !-- determine igrf coefficients for year + if ( l<=numye-1 ) then + call intershc(year,dte1,nmax1,gh1,dte2,nmax2,gh2,nmax,gha) + else + call extrashc(year,dte1,nmax1,gh1,nmax2,gh2,nmax,gha) + endif + !-- determine magnetic dipol moment and coeffiecients g f0 = 0.0_wp - DO j = 1 , 3 + do j = 1 , 3 f = gha(j)*1.0e-5_wp f0 = f0 + f*f - ENDDO - Dimo = sqrt(f0) + enddo + dimo = sqrt(f0) - Gh1(1) = 0.0_wp + gh1(1) = 0.0_wp i = 2 f0 = 1.0e-5_wp - IF ( is==0 ) f0 = -f0 + if ( is==0 ) f0 = -f0 sqrt2 = sqrt(2.0_wp) - DO n = 1 , Nmax + do n = 1 , nmax x = n f0 = f0*x*x/(4.0_wp*x-2.0_wp) - IF ( is==0 ) f0 = f0*(2.0_wp*x-1.0_wp)/x + if ( is==0 ) f0 = f0*(2.0_wp*x-1.0_wp)/x f = f0*0.5_wp - IF ( is==0 ) f = f*sqrt2 - Gh1(i) = gha(i-1)*f0 + if ( is==0 ) f = f*sqrt2 + gh1(i) = gha(i-1)*f0 i = i + 1 - DO m = 1 , n + do m = 1 , n f = f*(x+m)/(x-m+1.0_wp) - IF ( is==0 ) f = f*sqrt((x-m+1.0_wp)/(x+m)) - Gh1(i) = gha(i-1)*f - Gh1(i+1) = gha(i)*f + if ( is==0 ) f = f*sqrt((x-m+1.0_wp)/(x+m)) + gh1(i) = gha(i-1)*f + gh1(i+1) = gha(i)*f i = i + 2 - ENDDO - ENDDO -END SUBROUTINE feldcof - -SUBROUTINE getshc(Iu,Fspec,Nmax,Erad,Gh,Ier) - IMPLICIT NONE - REAL(wp) Erad , g , Gh , h - INTEGER i , Ier , Iu , m , mm , n , Nmax , nn + enddo + enddo + +end subroutine feldcof ! =============================================================== +!> +! Reads spherical harmonic coefficients from the specified +! file into an array. ! -! Version 1.01 -! -! Reads spherical harmonic coefficients from the specified -! file into an array. -! -! Input: -! IU - Logical unit number -! FSPEC - File specification -! -! Output: -! NMAX - Maximum degree and order of model -! ERAD - Earth's radius associated with the spherical -! harmonic coefficients, in the same units as -! elevation -! GH - Schmidt quasi-normal internal spherical -! harmonic coefficients -! IER - Error number: = 0, no error -! = -2, records out of order -! = FORTRAN run-time error number -! -! A. Zunde -! USGS, MS 964, Box 25046 Federal Center, Denver, CO 80225 -! -! =============================================================== - - CHARACTER Fspec*(*) - DIMENSION Gh(*) - -! --------------------------------------------------------------- -! Open coefficient file. Read past first header record. -! Read degree and order of model and Earth's radius. -! --------------------------------------------------------------- - OPEN (Iu,FILE=Fspec,STATUS='OLD',IOSTAT=Ier,ERR=100) - READ (Iu,*,IOSTAT=Ier,ERR=100) - READ (Iu,*,IOSTAT=Ier,ERR=100) Nmax , Erad -! --------------------------------------------------------------- -! Read the coefficient file, arranged as follows: -! -! N M G H -! ---------------------- -! / 1 0 GH(1) - -! / 1 1 GH(2) GH(3) -! / 2 0 GH(4) - -! / 2 1 GH(5) GH(6) -! NMAX*(NMAX+3)/2 / 2 2 GH(7) GH(8) -! records \ 3 0 GH(9) - -! \ . . . . -! \ . . . . -! NMAX*(NMAX+2) \ . . . . -! elements in GH \ NMAX NMAX . . -! -! N and M are, respectively, the degree and order of the -! coefficient. -! --------------------------------------------------------------- +!### Author +! * Version 1.01, A. Zunde, USGS, MS 964, +! Box 25046 Federal Center, Denver, CO 80225 - i = 0 - main: DO nn = 1 , Nmax - DO mm = 0 , nn - READ (Iu,*,IOSTAT=Ier,ERR=100) n , m , g , h - IF ( nn/=n .OR. mm/=m ) THEN - Ier = -2 - EXIT main - ENDIF - i = i + 1 - Gh(i) = g - IF ( m/=0 ) THEN +subroutine getshc(Fspec,Nmax,Erad,Gh,Ier) + + character(len=*),intent(in) :: Fspec !! File specification + integer,intent(out) :: Nmax !! Maximum degree and order of model + real(wp),intent(out) :: Erad !! Earth's radius associated with the spherical + !! harmonic coefficients, in the same units as + !! elevation + real(wp),dimension(*),intent(out) :: Gh !! Schmidt quasi-normal internal spherical + !! harmonic coefficients + integer,intent(out) :: Ier !! Error number: + !! + !! * 0, no error + !! * -2, records out of order + !! * FORTRAN run-time error number + + integer :: iu !! logical unit number + real(wp) :: g , h + integer :: i , m , mm , n , nn + + read_file : block + ! --------------------------------------------------------------- + ! Open coefficient file. Read past first header record. + ! Read degree and order of model and Earth's radius. + ! --------------------------------------------------------------- + OPEN (newunit=Iu,FILE=Fspec,STATUS='OLD',IOSTAT=Ier) + if (Ier/=0) then + write(*,*) 'Error opening file: '//trim(fspec) + exit read_file + end if + READ (Iu,*,IOSTAT=Ier) + if (Ier/=0) exit read_file + READ (Iu,*,IOSTAT=Ier) Nmax , Erad + if (Ier/=0) exit read_file + + ! --------------------------------------------------------------- + ! Read the coefficient file, arranged as follows: + ! + ! N M G H + ! ---------------------- + ! / 1 0 GH(1) - + ! / 1 1 GH(2) GH(3) + ! / 2 0 GH(4) - + ! / 2 1 GH(5) GH(6) + ! NMAX*(NMAX+3)/2 / 2 2 GH(7) GH(8) + ! records \ 3 0 GH(9) - + ! \ . . . . + ! \ . . . . + ! NMAX*(NMAX+2) \ . . . . + ! elements in GH \ NMAX NMAX . . + ! + ! N and M are, respectively, the degree and order of the + ! coefficient. + ! --------------------------------------------------------------- + i = 0 + main: DO nn = 1 , Nmax + DO mm = 0 , nn + READ (Iu,*,IOSTAT=Ier) n , m , g , h + if (Ier/=0) exit main + IF ( nn/=n .OR. mm/=m ) THEN + Ier = -2 + EXIT main + ENDIF i = i + 1 - Gh(i) = h - ENDIF - ENDDO - ENDDO main - - 100 CLOSE (Iu) - -END SUBROUTINE getshc + Gh(i) = g + IF ( m/=0 ) THEN + i = i + 1 + Gh(i) = h + ENDIF + ENDDO + ENDDO main -SUBROUTINE intershc(Date,Dte1,Nmax1,Gh1,Dte2,Nmax2,Gh2,Nmax,Gh) - IMPLICIT NONE - REAL(wp) Date , Dte1 , Dte2 , factor , Gh , Gh1 , Gh2 - INTEGER i , k , l , Nmax , Nmax1 , Nmax2 + end block read_file + + CLOSE (Iu) + +END subroutine getshc ! =============================================================== +!> +! Interpolates linearly, in time, between two spherical +! harmonic models. ! -! Version 1.01 -! -! Interpolates linearly, in time, between two spherical -! harmonic models. -! -! Input: -! DATE - Date of resulting model (in decimal year) -! DTE1 - Date of earlier model -! NMAX1 - Maximum degree and order of earlier model -! GH1 - Schmidt quasi-normal internal spherical -! harmonic coefficients of earlier model -! DTE2 - Date of later model -! NMAX2 - Maximum degree and order of later model -! GH2 - Schmidt quasi-normal internal spherical -! harmonic coefficients of later model -! -! Output: -! GH - Coefficients of resulting model -! NMAX - Maximum degree and order of resulting model -! -! A. Zunde -! USGS, MS 964, Box 25046 Federal Center, Denver, CO 80225 +! The coefficients (GH) of the resulting model, at date +! DATE, are computed by linearly interpolating between the +! coefficients of the earlier model (GH1), at date DTE1, +! and those of the later model (GH2), at date DTE2. If one +! model is smaller than the other, the interpolation is +! performed with the missing coefficients assumed to be 0. ! -! =============================================================== - - DIMENSION Gh1(*) , Gh2(*) , Gh(*) +!### Author +! * Version 1.01, A. Zunde +! USGS, MS 964, Box 25046 Federal Center, Denver, CO 80225 -! --------------------------------------------------------------- -! The coefficients (GH) of the resulting model, at date -! DATE, are computed by linearly interpolating between the -! coefficients of the earlier model (GH1), at date DTE1, -! and those of the later model (GH2), at date DTE2. If one -! model is smaller than the other, the interpolation is -! performed with the missing coefficients assumed to be 0. -! --------------------------------------------------------------- +subroutine intershc(date,dte1,nmax1,gh1,dte2,nmax2,gh2,nmax,gh) + + real(wp),intent(in) :: date !! Date of resulting model (in decimal year) + real(wp),intent(in) :: dte1 !! Date of earlier model + integer,intent(in) :: nmax1 !! Maximum degree and order of earlier model + real(wp),intent(in) :: gh1(*) !! Schmidt quasi-normal internal spherical harmonic coefficients of earlier model + real(wp),intent(in) :: dte2 !! Date of later model + integer,intent(in) :: nmax2 !! Maximum degree and order of later model + real(wp),intent(in) :: gh2(*) !! Schmidt quasi-normal internal spherical harmonic coefficients of later model + real(wp),intent(out) :: gh(*) !! Coefficients of resulting model + integer,intent(out) :: nmax !! Maximum degree and order of resulting model + + real(wp) :: factor + integer :: i , k , l - factor = (Date-Dte1)/(Dte2-Dte1) + factor = (date-dte1)/(dte2-dte1) - IF ( Nmax1==Nmax2 ) THEN - k = Nmax1*(Nmax1+2) - Nmax = Nmax1 - ELSEIF ( Nmax1>Nmax2 ) THEN - k = Nmax2*(Nmax2+2) - l = Nmax1*(Nmax1+2) - DO i = k + 1 , l - Gh(i) = Gh1(i) + factor*(-Gh1(i)) - ENDDO - Nmax = Nmax1 - ELSE - k = Nmax1*(Nmax1+2) - l = Nmax2*(Nmax2+2) - DO i = k + 1 , l - Gh(i) = factor*Gh2(i) - ENDDO - Nmax = Nmax2 - ENDIF + if ( nmax1==nmax2 ) then + k = nmax1*(nmax1+2) + nmax = nmax1 + elseif ( nmax1>nmax2 ) then + k = nmax2*(nmax2+2) + l = nmax1*(nmax1+2) + do i = k + 1 , l + gh(i) = gh1(i) + factor*(-gh1(i)) + enddo + nmax = nmax1 + else + k = nmax1*(nmax1+2) + l = nmax2*(nmax2+2) + do i = k + 1 , l + gh(i) = factor*gh2(i) + enddo + nmax = nmax2 + endif - DO i = 1 , k - Gh(i) = Gh1(i) + factor*(Gh2(i)-Gh1(i)) - ENDDO + do i = 1 , k + gh(i) = gh1(i) + factor*(gh2(i)-gh1(i)) + enddo -END SUBROUTINE intershc - -SUBROUTINE extrashc(Date,Dte1,Nmax1,Gh1,Nmax2,Gh2,Nmax,Gh) - IMPLICIT NONE - REAL(wp) Date , Dte1 , factor , Gh , Gh1 , Gh2 - INTEGER i , k , l , Nmax , Nmax1 , Nmax2 +end subroutine intershc ! =============================================================== +!> +! Extrapolates linearly a spherical harmonic model with a +! rate-of-change model. ! -! Version 1.01 -! -! Extrapolates linearly a spherical harmonic model with a -! rate-of-change model. -! -! Input: -! DATE - Date of resulting model (in decimal year) -! DTE1 - Date of base model -! NMAX1 - Maximum degree and order of base model -! GH1 - Schmidt quasi-normal internal spherical -! harmonic coefficients of base model -! NMAX2 - Maximum degree and order of rate-of-change -! model -! GH2 - Schmidt quasi-normal internal spherical -! harmonic coefficients of rate-of-change model -! -! Output: -! GH - Coefficients of resulting model -! NMAX - Maximum degree and order of resulting model -! -! A. Zunde -! USGS, MS 964, Box 25046 Federal Center, Denver, CO 80225 +! The coefficients (GH) of the resulting model, at date +! DATE, are computed by linearly extrapolating the coef- +! ficients of the base model (GH1), at date DTE1, using +! those of the rate-of-change model (GH2), at date DTE2. If +! one model is smaller than the other, the extrapolation is +! performed with the missing coefficients assumed to be 0. ! -! =============================================================== - - DIMENSION Gh1(*) , Gh2(*) , Gh(*) +!### Author +! * Version 1.01, A. Zunde +! USGS, MS 964, Box 25046 Federal Center, Denver, CO 80225 -! --------------------------------------------------------------- -! The coefficients (GH) of the resulting model, at date -! DATE, are computed by linearly extrapolating the coef- -! ficients of the base model (GH1), at date DTE1, using -! those of the rate-of-change model (GH2), at date DTE2. If -! one model is smaller than the other, the extrapolation is -! performed with the missing coefficients assumed to be 0. -! --------------------------------------------------------------- - - factor = (Date-Dte1) +subroutine extrashc(date,dte1,nmax1,gh1,nmax2,gh2,nmax,gh) + + real(wp),intent(in) :: date !! Date of resulting model (in decimal year) + real(wp),intent(in) :: dte1 !! Date of base model + integer,intent(in) :: nmax1 !! Maximum degree and order of base model + real(wp),intent(in) :: gh1(*) !! Schmidt quasi-normal internal spherical harmonic coefficients of base model + integer,intent(in) :: nmax2 !! Maximum degree and order of rate-of-change model + real(wp),intent(in) :: gh2(*) !! Schmidt quasi-normal internal spherical harmonic coefficients of rate-of-change model + real(wp),intent(out) :: gh(*) !! Coefficients of resulting model + integer,intent(out) :: nmax !! Maximum degree and order of resulting model + + real(wp) :: factor + integer :: i , k , l + + factor = (date-dte1) - IF ( Nmax1==Nmax2 ) THEN - k = Nmax1*(Nmax1+2) - Nmax = Nmax1 - ELSEIF ( Nmax1>Nmax2 ) THEN - k = Nmax2*(Nmax2+2) - l = Nmax1*(Nmax1+2) - DO i = k + 1 , l - Gh(i) = Gh1(i) - ENDDO - Nmax = Nmax1 - ELSE - k = Nmax1*(Nmax1+2) - l = Nmax2*(Nmax2+2) - DO i = k + 1 , l - Gh(i) = factor*Gh2(i) - ENDDO - Nmax = Nmax2 - ENDIF + if ( nmax1==nmax2 ) then + k = nmax1*(nmax1+2) + nmax = nmax1 + elseif ( nmax1>nmax2 ) then + k = nmax2*(nmax2+2) + l = nmax1*(nmax1+2) + do i = k + 1 , l + gh(i) = gh1(i) + enddo + nmax = nmax1 + else + k = nmax1*(nmax1+2) + l = nmax2*(nmax2+2) + do i = k + 1 , l + gh(i) = factor*gh2(i) + enddo + nmax = nmax2 + endif - DO i = 1 , k - Gh(i) = Gh1(i) + factor*Gh2(i) - ENDDO + do i = 1 , k + gh(i) = gh1(i) + factor*gh2(i) + enddo -END SUBROUTINE extrashc - +end subroutine extrashc end module SHELLIG_module \ No newline at end of file From bca9c6c0524aaeb7644a3ca8e9f38f3bb063272a Mon Sep 17 00:00:00 2001 From: Jacob Williams Date: Sun, 4 Feb 2024 22:07:02 -0600 Subject: [PATCH 05/13] minor update --- README.md | 1 + src/shellig.f90 | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index b2a14f9..0fc77e9 100755 --- a/README.md +++ b/README.md @@ -78,6 +78,7 @@ two lines had been exchanged. * [An Astropy-friendly wrapper for the AE-8/AP-8 Van Allen belt model](https://github.com/nasa/radbelt) * [pyIGRF](https://github.com/rilma/pyIGRF) * https://github.com/lanl/RAM-SCB/blob/master/srcExternal/igrf.f +* https://github.com/space-physics/igrf/blob/main/src/igrf/fortran/igrf13.f ### REFERENCES: diff --git a/src/shellig.f90 b/src/shellig.f90 index 7aafabc..f13c9c1 100644 --- a/src/shellig.f90 +++ b/src/shellig.f90 @@ -1,9 +1,9 @@ !> -! +! IGRF model ! ! * SHELLIG.FOR, Version 2.0, January 1992 ! * 11/01/91-DKB- SHELLG: lowest starting point for B0 search is 2 -! * 1/27/92-DKB- Adopted to IGRF-91 coeffcients model +! * 1/27/92-DKB- Adopted to IGRF-91 coefficients model ! * 2/05/92-DKB- Reduce variable-names: INTER(P)SHC,EXTRA(P)SHC,INITI(ALI)ZE ! * 8/08/95-DKB- Updated to IGRF-45-95; new coeff. DGRF90, IGRF95, IGRF95S ! * 5/31/00-DKB- Updated to IGRF-45-00; new coeff.: IGRF00, IGRF00s From 5d3c86ec73e9f6f1ef56d5a37998cdb5b3b19570 Mon Sep 17 00:00:00 2001 From: Jacob Williams Date: Sun, 4 Feb 2024 22:09:35 -0600 Subject: [PATCH 06/13] added ford file --- ford.md | 22 ++++++++++++++++++++++ src/shellig.f90 | 2 +- 2 files changed, 23 insertions(+), 1 deletion(-) create mode 100644 ford.md diff --git a/ford.md b/ford.md new file mode 100644 index 0000000..5a194d3 --- /dev/null +++ b/ford.md @@ -0,0 +1,22 @@ +project: radbelt +src_dir: ./src +output_dir: ./doc +media_dir: ./media +project_github: https://github.com/jacobwilliams/radbelt +summary: radbelt +author: Jacob Williams +github: https://github.com/jacobwilliams +predocmark_alt: > +predocmark: < +docmark_alt: +docmark: ! +display: public + protected + private +source: true +graph: true +externalize: true +preprocessor: gfortran -E +extra_mods: iso_fortran_env: https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fFORTRAN_005fENV.html + +{!README.md!} diff --git a/src/shellig.f90 b/src/shellig.f90 index f13c9c1..7ef33d3 100644 --- a/src/shellig.f90 +++ b/src/shellig.f90 @@ -596,7 +596,7 @@ subroutine feldcof(year,dimo) integer :: i , ier , is , iyea , j , l , m , n , nmax , nmax1 , nmax2 , numye character(len=14) :: Fil1 , fil2 - real(wp) :: x , f0 , f !! JW: these were double precision in original + real(wp) :: x , f0 , f !! these were double precision in original !! code while everything else was single precision COMMON /model/ Fil1 , Nmax , Time , Gh1 From 8732b166d76cbc92453d063907c8e43344e1eedd Mon Sep 17 00:00:00 2001 From: Jacob Williams Date: Sun, 4 Feb 2024 22:11:02 -0600 Subject: [PATCH 07/13] move into app --- {test => app}/radbelt.f90 | 0 {test => app}/radbelt.log | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename {test => app}/radbelt.f90 (100%) rename {test => app}/radbelt.log (100%) diff --git a/test/radbelt.f90 b/app/radbelt.f90 similarity index 100% rename from test/radbelt.f90 rename to app/radbelt.f90 diff --git a/test/radbelt.log b/app/radbelt.log similarity index 100% rename from test/radbelt.log rename to app/radbelt.log From ed444ebeca8fc3213439b89bd4eb0f2d5f680518 Mon Sep 17 00:00:00 2001 From: Jacob Williams Date: Mon, 5 Feb 2024 22:57:50 -0600 Subject: [PATCH 08/13] refactoring added vscode file --- app/radbelt.f90 | 10 +- radbelt.code-workspace | 13 ++ src/core.f90 | 118 +++++-------- src/radbelt_kinds_module.F90 | 2 +- src/shellig.f90 | 289 ++++++++++++++++---------------- src/trmfun.f90 | 313 ++++++++++++++++++++++------------- test/radbelt_test.f90 | 17 +- 7 files changed, 422 insertions(+), 340 deletions(-) create mode 100644 radbelt.code-workspace diff --git a/app/radbelt.f90 b/app/radbelt.f90 index 3cdef75..4ec52c4 100644 --- a/app/radbelt.f90 +++ b/app/radbelt.f90 @@ -1,9 +1,11 @@ PROGRAM spag_program_1 - use radbelt_module + use trmfun_module use radbelt_kinds_module IMPLICIT NONE + + type(trm_type) :: trm REAL(wp) af , bb0 , bbeg , bend , blv , bstep , df , e , ebeg , eda , & ediff , eend , ei , estep , fl , flux , vbeg , vend , vstep , & xl @@ -287,7 +289,7 @@ PROGRAM spag_program_1 ! READ (iuaeap) ihead ! nmap = ihead(8) ! READ (iuaeap) (map(i),i=1,nmap) - + ! ASCIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIII ! When using the ASCII coefficient files instead of the binary ! coefficient files, one should replace the preceding 5 statements @@ -299,7 +301,7 @@ PROGRAM spag_program_1 NMAP=IHEAD(8) READ(IUAEAP,1301) (MAP(I),I=1,NMAP) 1301 FORMAT(1X,12I6) - + CLOSE (iuaeap) IF ( mtype<3 ) THEN particle = 'PROTONS' @@ -533,7 +535,7 @@ PROGRAM spag_program_1 !----------------THE B LOOP------------------------------------- DO i = 1 , nb bb0 = xl(2,i) - CALL trara1(ihead,map,fl,bb0,e,flux,ne) + CALL trm%trara1(ihead,map,fl,bb0,e,flux,ne) !----------------THE ENERGY LOOP-------------------------------- DO k = 1 , ne af(k,l,i) = 0.0 diff --git a/radbelt.code-workspace b/radbelt.code-workspace new file mode 100644 index 0000000..489f23c --- /dev/null +++ b/radbelt.code-workspace @@ -0,0 +1,13 @@ +{ + "folders": [ + { + "path": "." + } + ], + "settings": { + "files.trimTrailingWhitespace": true, + "editor.insertSpaces": true, + "editor.tabSize": 4, + "editor.trimAutoWhitespace": true + } +} \ No newline at end of file diff --git a/src/core.f90 b/src/core.f90 index 51173b1..f941e8d 100644 --- a/src/core.f90 +++ b/src/core.f90 @@ -1,24 +1,29 @@ - +!***************************************************************************************** !> -! Adapted from -! * https://ccmc.gsfc.nasa.gov/pub/modelweb/geomagnetic/igrf/fortran_code/bilcal.for -! * https://ccmc.gsfc.nasa.gov/pub/modelweb/radiation_belt/radbelt/fortran_code/radbelt.for +! Main module. +! +! Adapted from +! * https://ccmc.gsfc.nasa.gov/pub/modelweb/geomagnetic/igrf/fortran_code/bilcal.for +! * https://ccmc.gsfc.nasa.gov/pub/modelweb/radiation_belt/radbelt/fortran_code/radbelt.for -module core +module core use radbelt_kinds_module - use radbelt_module + use trmfun_module use shellig_module - implicit none + implicit none - public :: igrf - public :: aep8 + public :: igrf public :: get_flux contains - !TODO: we need to read in the coefficients only once and keep them in memory, + !***************************************************************************************** + !> + ! Main routine. + ! + !@todo we need to read in the coefficients only once and keep them in memory, ! rather than everytime these functions are called ! function get_flux(Lon,Lat,Height,Year,E,Imname) result(flux) @@ -26,67 +31,36 @@ function get_flux(Lon,Lat,Height,Year,E,Imname) result(flux) real(wp) :: lon, lat, height, year, e integer :: imname - real(wp) :: flux,xl,bbx - real(wp), dimension(1) :: flux_, e_ - - e_(1) = e - + real(wp) :: flux,xl,bbx + type(trm_type) :: trm + call igrf(Lon,Lat,Height,Year,Xl,Bbx) - call aep8(e_,Xl,Bbx,Imname,flux_) - - flux = flux_(1) - + call trm%aep8(e,Xl,Bbx,Imname,flux) + end function get_flux - -subroutine igrf(lon,lat,height,year,xl,bbx) - - real(wp) bab1 , babs , bdel , bdown , beast , beq , bequ , bnorth , dimo , rr0 - integer icode - real(wp) lon , lat , height , year , xl , bbx - logical val - - CALL feldcof(Year,dimo) - CALL feldg(Lat,Lon,Height,bnorth,beast,bdown,babs) - CALL shellg(Lat,Lon,Height,dimo,Xl,icode,bab1) - bequ = dimo/(Xl*Xl*Xl) - IF ( icode==1 ) THEN - bdel = 1.0e-3_wp - CALL findb0(0.05_wp,bdel,val,beq,rr0) - IF ( val ) bequ = beq - ENDIF - Bbx = babs/bequ -END SUBROUTINE igrf - -subroutine aep8(e,l,bb0,imname,flux) - - real(wp) e(1) , ee(1) , flux(1) - integer i , ierr , ihead(8) , imname , iuaeap , nmap - integer,dimension(:),allocatable :: map - real(wp) l , bb0 - character(len=10) :: name - - character(len=10),dimension(4),parameter :: mname = ['ae8min.asc' , & - 'ae8max.asc' , & - 'ap8min.asc' , & - 'ap8max.asc'] - - iuaeap = 15 - name = mname(Imname) - - OPEN (iuaeap,FILE=name,STATUS='OLD',IOSTAT=ierr,FORM='FORMATTED') - IF ( ierr/=0 ) then - error stop 'error reading '//trim(name) - end if - READ (iuaeap,'(1X,12I6)') ihead - nmap = ihead(8) - allocate(map(nmap)) - READ (iuaeap,'(1X,12I6)') (map(i),i=1,nmap) - CLOSE (iuaeap) - - ee(1) = E(1) - CALL trara1(ihead,map,L,Bb0,E,Flux,1) - IF ( Flux(1)>0.0_wp ) Flux(1) = 10.0_wp**Flux(1) - -END SUBROUTINE aep8 - -end module core + + !***************************************************************************************** + !> + ! Wrapper for IGRF functions. + + subroutine igrf(lon,lat,height,year,xl,bbx) + + real(wp) :: bab1 , babs , bdel , bdown , beast , beq , bequ , bnorth , dimo , rr0 + integer :: icode + real(wp) :: lon , lat , height , year , xl , bbx + logical :: val + + CALL feldcof(Year,dimo) + CALL feldg(Lat,Lon,Height,bnorth,beast,bdown,babs) + CALL shellg(Lat,Lon,Height,dimo,Xl,icode,bab1) + bequ = dimo/(Xl*Xl*Xl) + IF ( icode==1 ) THEN + bdel = 1.0e-3_wp + CALL findb0(0.05_wp,bdel,val,beq,rr0) + IF ( val ) bequ = beq + ENDIF + Bbx = babs/bequ + + end subroutine igrf + +end module core diff --git a/src/radbelt_kinds_module.F90 b/src/radbelt_kinds_module.F90 index 24d0587..b814007 100644 --- a/src/radbelt_kinds_module.F90 +++ b/src/radbelt_kinds_module.F90 @@ -1,5 +1,5 @@ !***************************************************************************************** -!> +!> ! Numeric kind definitions for radbelt. module radbelt_kinds_module diff --git a/src/shellig.f90 b/src/shellig.f90 index 7ef33d3..7bd1b1f 100644 --- a/src/shellig.f90 +++ b/src/shellig.f90 @@ -1,6 +1,8 @@ +!***************************************************************************************** !> ! IGRF model ! +!### History ! * SHELLIG.FOR, Version 2.0, January 1992 ! * 11/01/91-DKB- SHELLG: lowest starting point for B0 search is 2 ! * 1/27/92-DKB- Adopted to IGRF-91 coefficients model @@ -9,33 +11,35 @@ ! * 5/31/00-DKB- Updated to IGRF-45-00; new coeff.: IGRF00, IGRF00s ! * 3/24/05-DKB- Updated to IGRF-45-10; new coeff.: IGRF05, IGRF05s - module shellig_module + module shellig_module use radbelt_kinds_module - implicit none + implicit none - private + private ! parameters formerly in `gener` common block real(wp),parameter :: Era = 6371.2_wp !! earth radius for normalization of cartesian coordinates (6371.2 km) real(wp),parameter :: erequ = 6378.16_wp real(wp),parameter :: erpol = 6356.775_wp - real(wp),parameter :: Aquad = erequ*erequ !! square of major half axis for - !! earth ellipsoid as recommended by international + real(wp),parameter :: Aquad = erequ*erequ !! square of major half axis for + !! earth ellipsoid as recommended by international !! astronomical union - real(wp),parameter :: Bquad = erpol*erpol !! square of minor half axis for - !! earth ellipsoid as recommended by international + real(wp),parameter :: Bquad = erpol*erpol !! square of minor half axis for + !! earth ellipsoid as recommended by international !! astronomical union real(wp),parameter :: Umr = atan(1.0_wp)*4.0_wp/180.0_wp !! atan(1.0)*4./180. *umr= - + public :: feldcof public :: feldg public :: shellg public :: findb0 - - contains + contains + +!***************************************************************************************** +!> subroutine findb0(stps,bdel,value,bequ,rr0) real(wp) :: b , bdel , bdelta , bequ , bmin , bold , bq1 , & @@ -56,7 +60,7 @@ subroutine findb0(stps,bdel,value,bequ,rr0) value=.false. exit main endif - !*********************first three points + !*********************first three points p(1,2)=sp(1) p(2,2)=sp(2) p(3,2)=sp(3) @@ -85,7 +89,7 @@ subroutine findb0(stps,bdel,value,bequ,rr0) p(i,3)=zz end do end if - !******************initialization + !******************initialization step12=step/12.0_wp value=.true. bmin=1.0e4_wp @@ -104,7 +108,7 @@ subroutine findb0(stps,bdel,value,bequ,rr0) do j=1,3 do i=1,8 p(i,j)=p(i,j+1) - end do + end do end do b=sqrt(bq3) if (b -! CALCULATES L-VALUE FOR SPECIFIED GEODAETIC COORDINATES, ALTITUDE -! AND GEMAGNETIC FIELD MODEL. +! calculates l-value for specified geodaetic coordinates, altitude +! and gemagnetic field model. ! !### Reference ! * G. KLUGE, EUROPEAN SPACE OPERATIONS CENTER, INTERNAL NOTE ! NO. 67, 1970. ! * G. KLUGE, COMPUTER PHYSICS COMMUNICATIONS 3, 31-35, 1972 -! +! !### History ! * CHANGES (D. BILITZA, NOV 87): ! - USING CORRECT DIPOL MOMENT I.E.,DIFFERENT COMMON/MODEL/ ! - USING IGRF EARTH MAGNETIC FIELD MODELS FROM 1945 TO 1990 - + subroutine shellg(glat,glon,alt,dimo,fl,icode,b0) real(wp),intent(in) :: glat !! GEODETIC LATITUDE IN DEGREES (NORTH) @@ -396,7 +401,7 @@ subroutine stoer(P,Bq,R) !* subroutine USED FOR FIELD LINE TRACING IN SHELLG * !* CALLS ENTRY POINT FELDI IN GEOMAGNETIC FIELD subroutine FELDG * !******************************************************************* - DIMENSION P(7) + DIMENSION P(7) real(wp),dimension(3,3),parameter :: u = reshape([ +0.3511737_wp , -0.9148385_wp , -0.1993679_wp , & +0.9335804_wp , +0.3583680_wp , +0.0000000_wp , & +0.0714471_wp , -0.1861260_wp , +0.9799247_wp],[3,3]) @@ -435,15 +440,21 @@ subroutine stoer(P,Bq,R) P(7) = P(6)*(rq+zm*zm)/(rq*dzm) END subroutine stoer -subroutine feldg(glat,glon,alt,bnorth,beast,bdown,babs) - !------------------------------------------------------------------- - ! calculates earth magnetic field from spherical harmonics model - ! ref: g. kluge, european space operations centre, internal note 61, - ! 1970. - !-------------------------------------------------------------------- - ! changes (d. bilitza, nov 87): - ! - field coefficients in binary data files instead of block data - ! - calculates dipol moment +!***************************************************************************************** +!> +! Calculates earth magnetic field from spherical harmonics model +! +!### Reference +! ref: g. kluge, european space operations centre, internal note 61, +! 1970. +! +!### History +! * changes (d. bilitza, nov 87): +! - field coefficients in binary data files instead of block data +! - calculates dipol moment + +subroutine feldg(glat,glon,alt,bnorth,beast,bdown,babs) + !-------------------------------------------------------------------- ! input: entry point feldg ! glat geodetic latitude in degrees (north) @@ -458,16 +469,16 @@ subroutine feldg(glat,glon,alt,bnorth,beast,bdown,babs) ! ! common blank and entry point feldi are needed when used ! in connection with l-calculation program shellg. - ! + ! ! common /model/ and /gener/ ! umr = atan(1.0)*4./180. *umr= - ! era earth radius for normalization of cartesian + ! era earth radius for normalization of cartesian ! coordinates (6371.2 km) - ! aquad, bquad square of major and minor half axis for - ! earth ellipsoid as recommended by international + ! aquad, bquad square of major and minor half axis for + ! earth ellipsoid as recommended by international ! astronomical union (6378.160, 6356.775 km). ! nmax maximum order of spherical harmonics - ! time year (decimal: 1973.5) for which magnetic + ! time year (decimal: 1973.5) for which magnetic ! field is to be calculated ! g(m) normalized field coefficients (see feldcof) ! m=nmax*(nmax+2) @@ -476,103 +487,103 @@ subroutine feldg(glat,glon,alt,bnorth,beast,bdown,babs) ! bnorth, beast, bdown components of the field with respect ! to the local geodetic coordinate system, with axis ! pointing in the tangential plane to the north, east - ! and downward. + ! and downward. !----------------------------------------------------------------------- - - REAL(wp) Alt , B , Babs , Bdown , Beast , Bnorth , brho , bxxx , & - byyy , bzzz , cp , ct , d , f , G , Glat , Glon - REAL(wp) H , rho , rlat , rlon , rq , s , sp , st , t , Time , V , x , Xi , xxx , y , yyy , z , zzz - INTEGER i , ih , ihmax , il , imax , is , k , last , m , Nmax - - dimension v(3),b(3) - character*14 name - - common xi(3),h(144) - common/model/ name,nmax,time,g(144) - ! + + REAL(wp) Alt , B , Babs , Bdown , Beast , Bnorth , brho , bxxx , & + byyy , bzzz , cp , ct , d , f , G , Glat , Glon + REAL(wp) H , rho , rlat , rlon , rq , s , sp , st , t , Time , V , x , Xi , xxx , y , yyy , z , zzz + INTEGER i , ih , ihmax , il , imax , is , k , last , m , Nmax + + dimension v(3),b(3) + character*14 name + + common xi(3),h(144) + common/model/ name,nmax,time,g(144) + !-- is records entry point ! - !*****entry point feldg to be used with geodetic co-ordinates - is=1 + !*****entry point feldg to be used with geodetic co-ordinates + is=1 rlat=glat*umr - ct=sin(rlat) - st=cos(rlat) - d=sqrt(aquad-(aquad-bquad)*ct*ct) + ct=sin(rlat) + st=cos(rlat) + d=sqrt(aquad-(aquad-bquad)*ct*ct) rlon=glon*umr - cp=cos(rlon) - sp=sin(rlon) + cp=cos(rlon) + sp=sin(rlon) zzz=(alt+bquad/d)*ct/era rho=(alt+aquad/d)*st/era - xxx=rho*cp - yyy=rho*sp + xxx=rho*cp + yyy=rho*sp goto 10 ! - !*****entry point feldc to be used with cartesian co-ordinates - entry feldc(v,b) - is=2 - xxx=v(1) - yyy=v(2) - zzz=v(3) - 10 rq=1./(xxx*xxx+yyy*yyy+zzz*zzz) - xi(1)=xxx*rq - xi(2)=yyy*rq - xi(3)=zzz*rq - goto 20 + !*****entry point feldc to be used with cartesian co-ordinates + entry feldc(v,b) + is=2 + xxx=v(1) + yyy=v(2) + zzz=v(3) + 10 rq=1./(xxx*xxx+yyy*yyy+zzz*zzz) + xi(1)=xxx*rq + xi(2)=yyy*rq + xi(3)=zzz*rq + goto 20 ! - !*****entry point feldi used for l computation - entry feldi() - is=3 - 20 ihmax=nmax*nmax+1 - last=ihmax+nmax+nmax - imax=nmax+nmax-1 - do i=ihmax,last - h(i)=g(i) - end do - do k=1,3,2 - i=imax - ih=ihmax - 1 il=ih-i - f=2.0_wp/real(i-k+2, wp) - x=xi(1)*f - y=xi(2)*f - z=xi(3)*(f+f) - i=i-2 - if ((i-1)>=0) then + !*****entry point feldi used for l computation + entry feldi() + is=3 + 20 ihmax=nmax*nmax+1 + last=ihmax+nmax+nmax + imax=nmax+nmax-1 + do i=ihmax,last + h(i)=g(i) + end do + do k=1,3,2 + i=imax + ih=ihmax + 1 il=ih-i + f=2.0_wp/real(i-k+2, wp) + x=xi(1)*f + y=xi(2)*f + z=xi(3)*(f+f) + i=i-2 + if ((i-1)>=0) then if ((i-1)>0) then - do m=3,i,2 - h(il+m+1)=g(il+m+1)+z*h(ih+m+1)+x*(h(ih+m+3)-h(ih+m-1))-y*(h(ih+m+2)+h(ih+m-2)) - h(il+m)=g(il+m)+z*h(ih+m)+x*(h(ih+m+2)-h(ih+m-2))+y*(h(ih+m+3)+h(ih+m-1)) - end do - end if - h(il+2)=g(il+2)+z*h(ih+2)+x*h(ih+4)-y*(h(ih+3)+h(ih)) - h(il+1)=g(il+1)+z*h(ih+1)+y*h(ih+4)+x*(h(ih+3)-h(ih)) + do m=3,i,2 + h(il+m+1)=g(il+m+1)+z*h(ih+m+1)+x*(h(ih+m+3)-h(ih+m-1))-y*(h(ih+m+2)+h(ih+m-2)) + h(il+m)=g(il+m)+z*h(ih+m)+x*(h(ih+m+2)-h(ih+m-2))+y*(h(ih+m+3)+h(ih+m-1)) + end do + end if + h(il+2)=g(il+2)+z*h(ih+2)+x*h(ih+4)-y*(h(ih+3)+h(ih)) + h(il+1)=g(il+1)+z*h(ih+1)+y*h(ih+4)+x*(h(ih+3)-h(ih)) end if h(il)=g(il)+z*h(ih)+2.0_wp*(x*h(ih+1)+y*h(ih+2)) - ih=il - if (i>=k) goto 1 - end do - - if (is==3) return - s=0.5_wp*h(1)+2.0_wp*(h(2)*xi(3)+h(3)*xi(1)+h(4)*xi(2)) - t=(rq+rq)*sqrt(rq) - bxxx=t*(h(3)-s*xxx) - byyy=t*(h(4)-s*yyy) - bzzz=t*(h(2)-s*zzz) + ih=il + if (i>=k) goto 1 + end do + + if (is==3) return + s=0.5_wp*h(1)+2.0_wp*(h(2)*xi(3)+h(3)*xi(1)+h(4)*xi(2)) + t=(rq+rq)*sqrt(rq) + bxxx=t*(h(3)-s*xxx) + byyy=t*(h(4)-s*yyy) + bzzz=t*(h(2)-s*zzz) if (is==2) then - b(1)=bxxx - b(2)=byyy - b(3)=bzzz + b(1)=bxxx + b(2)=byyy + b(3)=bzzz else babs=sqrt(bxxx*bxxx+byyy*byyy+bzzz*bzzz) - beast=byyy*cp-bxxx*sp - brho=byyy*sp+bxxx*cp - bnorth=bzzz*st-brho*ct - bdown=-bzzz*ct-brho*st + beast=byyy*cp-bxxx*sp + brho=byyy*sp+bxxx*cp + bnorth=bzzz*st-brho*ct + bdown=-bzzz*ct-brho*st end if - end subroutine feldg + end subroutine feldg -!------------------------------------------------------------------------ +!***************************************************************************************** !> ! Determines coefficients and dipol moment from IGRF models ! @@ -596,7 +607,7 @@ subroutine feldcof(year,dimo) integer :: i , ier , is , iyea , j , l , m , n , nmax , nmax1 , nmax2 , numye character(len=14) :: Fil1 , fil2 - real(wp) :: x , f0 , f !! these were double precision in original + real(wp) :: x , f0 , f !! these were double precision in original !! code while everything else was single precision COMMON /model/ Fil1 , Nmax , Time , Gh1 @@ -616,7 +627,7 @@ subroutine feldcof(year,dimo) 2020.0_wp , 2025.0_wp] numye = 16 ! number of 5-year priods represented by IGRF - is = 0 ! is=0 for schmidt normalization + is = 0 ! is=0 for schmidt normalization ! is=1 gauss normalization !-- determine igrf-years for input-year @@ -647,13 +658,13 @@ subroutine feldcof(year,dimo) f0 = f0 + f*f enddo dimo = sqrt(f0) - + gh1(1) = 0.0_wp i = 2 f0 = 1.0e-5_wp if ( is==0 ) f0 = -f0 sqrt2 = sqrt(2.0_wp) - + do n = 1 , nmax x = n f0 = f0*x*x/(4.0_wp*x-2.0_wp) @@ -670,18 +681,18 @@ subroutine feldcof(year,dimo) i = i + 2 enddo enddo - + end subroutine feldcof - -! =============================================================== + +!***************************************************************************************** !> ! Reads spherical harmonic coefficients from the specified ! file into an array. ! !### Author -! * Version 1.01, A. Zunde, USGS, MS 964, +! * Version 1.01, A. Zunde, USGS, MS 964, ! Box 25046 Federal Center, Denver, CO 80225 - + subroutine getshc(Fspec,Nmax,Erad,Gh,Ier) character(len=*),intent(in) :: Fspec !! File specification @@ -691,12 +702,12 @@ subroutine getshc(Fspec,Nmax,Erad,Gh,Ier) !! elevation real(wp),dimension(*),intent(out) :: Gh !! Schmidt quasi-normal internal spherical !! harmonic coefficients - integer,intent(out) :: Ier !! Error number: + integer,intent(out) :: Ier !! Error number: !! !! * 0, no error !! * -2, records out of order !! * FORTRAN run-time error number - + integer :: iu !! logical unit number real(wp) :: g , h integer :: i , m , mm , n , nn @@ -756,10 +767,10 @@ subroutine getshc(Fspec,Nmax,Erad,Gh,Ier) end block read_file CLOSE (Iu) - + END subroutine getshc - -! =============================================================== + +!***************************************************************************************** !> ! Interpolates linearly, in time, between two spherical ! harmonic models. @@ -774,7 +785,7 @@ END subroutine getshc !### Author ! * Version 1.01, A. Zunde ! USGS, MS 964, Box 25046 Federal Center, Denver, CO 80225 - + subroutine intershc(date,dte1,nmax1,gh1,dte2,nmax2,gh2,nmax,gh) real(wp),intent(in) :: date !! Date of resulting model (in decimal year) @@ -789,9 +800,9 @@ subroutine intershc(date,dte1,nmax1,gh1,dte2,nmax2,gh2,nmax,gh) real(wp) :: factor integer :: i , k , l - + factor = (date-dte1)/(dte2-dte1) - + if ( nmax1==nmax2 ) then k = nmax1*(nmax1+2) nmax = nmax1 @@ -810,14 +821,14 @@ subroutine intershc(date,dte1,nmax1,gh1,dte2,nmax2,gh2,nmax,gh) enddo nmax = nmax2 endif - + do i = 1 , k gh(i) = gh1(i) + factor*(gh2(i)-gh1(i)) enddo - + end subroutine intershc - -! =============================================================== + +!***************************************************************************************** !> ! Extrapolates linearly a spherical harmonic model with a ! rate-of-change model. @@ -832,7 +843,7 @@ end subroutine intershc !### Author ! * Version 1.01, A. Zunde ! USGS, MS 964, Box 25046 Federal Center, Denver, CO 80225 - + subroutine extrashc(date,dte1,nmax1,gh1,nmax2,gh2,nmax,gh) real(wp),intent(in) :: date !! Date of resulting model (in decimal year) @@ -844,11 +855,11 @@ subroutine extrashc(date,dte1,nmax1,gh1,nmax2,gh2,nmax,gh) real(wp),intent(out) :: gh(*) !! Coefficients of resulting model integer,intent(out) :: nmax !! Maximum degree and order of resulting model - real(wp) :: factor - integer :: i , k , l - + real(wp) :: factor + integer :: i , k , l + factor = (date-dte1) - + if ( nmax1==nmax2 ) then k = nmax1*(nmax1+2) nmax = nmax1 @@ -867,11 +878,11 @@ subroutine extrashc(date,dte1,nmax1,gh1,nmax2,gh2,nmax,gh) enddo nmax = nmax2 endif - + do i = 1 , k gh(i) = gh1(i) + factor*gh2(i) enddo - + end subroutine extrashc end module SHELLIG_module \ No newline at end of file diff --git a/src/trmfun.f90 b/src/trmfun.f90 index 6464466..baab593 100644 --- a/src/trmfun.f90 +++ b/src/trmfun.f90 @@ -1,80 +1,159 @@ -module radbelt_module +!***************************************************************************************** +!> +! Trapped radiation model. +! +!### History +! * Based on: `trmfun.for` 1987 + +module trmfun_module use radbelt_kinds_module - ! trmfun.for 1987 + implicit none + + private + + character(len=10),dimension(4),parameter :: mname = [ 'ae8min.asc' , & + 'ae8max.asc' , & + 'ap8min.asc' , & + 'ap8max.asc'] !! data files available + + type,public :: trm_type + !! main class for the `aep8` model + private - implicit none + ! data read from the files: + character(len=:),allocatable :: file_loaded !! the file that has been loaded + integer,dimension(8) :: ihead = 0 + integer,dimension(:),allocatable :: map - private + real(wp) :: fistep = 0.0_wp !! the stepsize for the parameterization of the logarithm of flux. + !! formerly stored in common block `tra2` - public :: trara1, trara2 + ! formerly saved variables in trara1: + real(wp) :: f1 = 1.001_wp + real(wp) :: f2 = 1.002_wp + + contains + private + procedure,public :: aep8 !! main routine + procedure,public :: trara1, trara2 !! low-level routine + end type trm_type contains -!*********************************************************************** -!*** trara1 finds particle fluxes for given energies, magnetic field *** -!*** strength and l-value. function trara2 is used to interpolate in *** -!*** b-l-space. *** -!*** input: descr(8) header of specified trapped radition model *** -!*** map(...) map of trapped radition model *** -!*** (descr and map are explained at the begin *** -!*** of the main program model) *** -!*** n number of energies *** -!*** e(n) array of energies in mev *** -!*** fl l-value *** -!*** bb0 =b/b0 magnetic field strength normalized *** -!*** to field strength at magnetic equator *** -!*** output: f(n) decadic logarithm of integral fluxes in *** -!*** particles/(cm*cm*sec) *** -!*********************************************************************** -subroutine trara1(descr,map,fl,bb0,e,f,n) - - real(wp) bb0 , e , e0 , e1 , e2 , escale , f , f0 , f1 , f2 , fistep , fl , fscale , xnl - integer i0 , i1 , i2 , i3 , ie , l3 , map , n , nb , nl - logical s0 , s1 , s2 - dimension e(n) , f(n) , map(*) - integer descr(8) - - common /tra2/ fistep - - data f1 , f2/1.001_wp , 1.002_wp/ - - fistep = descr(7)/descr(2) +!***************************************************************************************** +!> +! Main wrapper for the radiation model. +! Reads the coefficient file and calls the low-level routine. + + subroutine aep8(me,e,l,bb0,imname,flux) + + class(trm_type),intent(inout) :: me + + real(wp),intent(in) :: e + real(wp),intent(in) :: l + real(wp),intent(in) :: bb0 + integer,intent(in) :: imname !! which model to load (index in `mname` array) + real(wp),intent(out) :: flux + + real(wp) :: ee(1), f(1) !! temp variables + integer :: i , ierr, iuaeap , nmap + character(len=len(mname)) :: name + logical :: load_file + + name = mname(Imname) ! the file to load + + ! check to see if this file has already been loaded + ! [the class can store one file at a time] + load_file = .true. + if (allocated(me%file_loaded)) then + if (name == me%file_loaded) load_file = .false. + end if + + if (load_file) then + open (newunit = iuaeap,file=name,status='OLD',iostat=ierr,form='FORMATTED') + if ( ierr/=0 ) then + error stop 'error reading '//trim(name) + end if + read (iuaeap,'(1X,12I6)') me%ihead + nmap = me%ihead(8) + allocate(me%map(nmap)) + read (iuaeap,'(1X,12I6)') (me%map(i),i=1,nmap) + close (iuaeap) + me%file_loaded = trim(name) + end if + + ee(1) = e + call me%trara1(me%ihead,me%map,L,Bb0,ee,f,1) + flux = f(1) + IF ( Flux>0.0_wp ) Flux = 10.0_wp**Flux + + end subroutine aep8 +!***************************************************************************************** + +!***************************************************************************************** +!> +! [[trara1]] finds particle fluxes for given energies, magnetic field +! strength and l-value. function [[trara2]] is used to interpolate in +! b-l-space. + + subroutine trara1(me,descr,map,fl,bb0,e,f,n) + + class(trm_type),intent(inout) :: me + integer,intent(in) :: n !! number of energies + integer,intent(in) :: descr(8) !! header of specified trapped radition model + real(wp),intent(in) :: e(n) !! array of energies in mev + real(wp),intent(in) :: fl !! l-value + real(wp),intent(in) :: bb0 !! =b/b0 magnetic field strength normalized + !! to field strength at magnetic equator + integer,intent(in) :: map(*) !! map of trapped radition model + !! (descr and map are explained at the begin + !! of the main program model) + real(wp),intent(out) :: f(n) !! decadic logarithm of integral fluxes in + !! particles/(cm*cm*sec) + + real(wp) :: e0 , e1 , e2 , escale , f0 , fscale , xnl + real(wp) :: bb0_ !! local copy of `bb0`. in the original code + !! this was modified by this routine. + !! added this so `bb0` could be `intent(in)` + integer :: i0 , i1 , i2 , i3 , ie , l3 , nb , nl + logical :: s0 , s1 , s2 + + bb0_ = bb0 + me%fistep = descr(7)/descr(2) escale = descr(4) fscale = descr(7) xnl = min(15.6_wp,abs(fl)) nl = xnl*descr(5) - if ( bb0<1.0_wp ) bb0 = 1.0_wp - nb = (bb0-1.0_wp)*descr(6) -! -! i2 is the number of elements in the flux map for the first energy. -! i3 is the index of the last element of the second energy map. -! l3 is the length of the map for the third energy. -! e1 is the energy of the first energy map (unscaled) -! e2 is the energy of the second energy map (unscaled) -! + if ( bb0_<1.0_wp ) bb0_ = 1.0_wp + nb = (bb0_-1.0_wp)*descr(6) + + ! i2 is the number of elements in the flux map for the first energy. + ! i3 is the index of the last element of the second energy map. + ! l3 is the length of the map for the third energy. + ! e1 is the energy of the first energy map (unscaled) + ! e2 is the energy of the second energy map (unscaled) i1 = 0 i2 = map(1) i3 = i2 + map(i2+1) l3 = map(i3+1) e1 = map(i1+2)/escale e2 = map(i2+2)/escale -! -! s0, s1, s2 are logical variables which indicate whether the flux for -! a particular e, b, l point has already been found in a previous call -! to function trara2. if not, s.. =.true. -! + + ! s0, s1, s2 are logical variables which indicate whether the flux for + ! a particular e, b, l point has already been found in a previous call + ! to function trara2. if not, s.. =.true. s1 = .true. s2 = .true. -! -! energy loop -! + + ! energy loop + do ie = 1 , n -! -! for each energy e(i) find the successive energies e0,e1,e2 in -! model map, which obey e0 < e1 < e(i) < e2 . -! + + ! for each energy e(i) find the successive energies e0,e1,e2 in + ! model map, which obey e0 < e1 < e(i) < e2 . + do while ( (e(ie)>e2) .and. (l3/=0) ) i0 = i1 i1 = i2 @@ -87,69 +166,69 @@ subroutine trara1(descr,map,fl,bb0,e,f,n) s0 = s1 s1 = s2 s2 = .true. - f0 = f1 - f1 = f2 + f0 = me%f1 + me%f1 = me%f2 enddo -! -! call trara2 to interpolate the flux-maps for e1,e2 in l-b/b0- -! space to find fluxes f1,f2 [if they have not already been -! calculated for a previous e(i)]. -! - if ( s1 ) f1 = trara2(map(i1+3),nl,nb)/fscale - if ( s2 ) f2 = trara2(map(i2+3),nl,nb)/fscale + + ! call trara2 to interpolate the flux-maps for e1,e2 in l-b/b0- + ! space to find fluxes f1,f2 [if they have not already been + ! calculated for a previous e(i)]. + + if ( s1 ) me%f1 = me%trara2(map(i1+3),nl,nb)/fscale + if ( s2 ) me%f2 = me%trara2(map(i2+3),nl,nb)/fscale s1 = .false. s2 = .false. -! -! finally, interpolate in energy. -! - f(ie) = f1 + (f2-f1)*(e(ie)-e1)/(e2-e1) - if ( f2<=0.0_wp ) then + + ! finally, interpolate in energy. + + f(ie) = me%f1 + (me%f2-me%f1)*(e(ie)-e1)/(e2-e1) + if ( me%f2<=0.0_wp ) then if ( i1/=0 ) then -! -! --------- special interpolation --------------------------------- -! if the flux for the second energy cannot be found (i.e. f2=0.0), -! and the zeroth energy map has been defined (i.e. i1 not equal 0), -! then interpolate using the flux maps for the zeroth and first -! energy and choose the minimum of this interpolations and the -! interpolation that was done with f2=0. -! - if ( s0 ) f0 = trara2(map(i0+3),nl,nb)/fscale + ! --------- special interpolation --------------------------------- + ! if the flux for the second energy cannot be found (i.e. f2=0.0), + ! and the zeroth energy map has been defined (i.e. i1 not equal 0), + ! then interpolate using the flux maps for the zeroth and first + ! energy and choose the minimum of this interpolations and the + ! interpolation that was done with f2=0. + if ( s0 ) f0 = me%trara2(map(i0+3),nl,nb)/fscale s0 = .false. - f(ie) = min(f(ie),f0+(f1-f0)*(e(ie)-e0)/(e1-e0)) + f(ie) = min(f(ie),f0+(me%f1-f0)*(e(ie)-e0)/(e1-e0)) endif endif -! -! the logarithmic flux is always kept greater or equal zero. -! + + ! the logarithmic flux is always kept greater or equal zero. + f(ie) = max(f(ie),0.0_wp) enddo end subroutine trara1 -!***************************************************************** -!*** trara2 interpolates linearly in l-b/b0-map to obtain *** -!*** the logarithm of integral flux at given l and b/b0. *** -!*** input: map(..) is sub-map (for specific energy) of *** -!*** trapped radiation model map *** -!*** il scaled l-value *** -!*** ib scaled b/b0-1 *** -!*** output: trara2 scaled logarithm of particle flux *** -!***************************************************************** -!*** see main program 'model' for explanation of map format *** -!*** scaling factors. *** -!*** the stepsize for the parameterization of the logarithm *** -!*** of flux is obtained from 'common/tra2/'. *** -!***************************************************************** -function trara2(map,il,ib) - - real(wp) dfl , fincr1 , fincr2 , fistep , fkb , fkb1 , fkb2 , fkbj1 , fkbj2 , & - fkbm , fll1 , fll2 , flog , flog1 , flog2 , flogm , & - fnb , fnl , sl1 , sl2 - real(wp) trara2 - integer i1 , i2 , ib , il , itime , j1 , j2 , kt , l1 , l2 , map(*) - - common /tra2/ fistep +!***************************************************************************************** +!> +! [[trara2]] interpolates linearly in l-b/b0-map to obtain +! the logarithm of integral flux at given l and b/b0. +! +!### Note +! see main program 'model' for explanation of map format +! scaling factors. + +function trara2(me,map,il,ib) + + class(trm_type),intent(inout) :: me + integer,intent(in) :: map(*) !! is sub-map (for specific energy) of + !! trapped radiation model map + integer,intent(in) :: il !! scaled l-value + integer,intent(in) :: ib !! scaled b/b0-1 + real(wp) :: trara2 !! scaled logarithm of particle flux + + real(wp) :: dfl , fincr1 , fincr2 , fistep , fkb , fkb1 , fkb2 , fkbj1 , fkbj2 , & + fkbm , fll1 , fll2 , flog , flog1 , flog2 , flogm , & + fnb , fnl , sl1 , sl2 + integer :: i1 , i2 , itime , j1 , j2 , kt , l1 , l2 + integer :: spag_nextblock_1 + fistep = me%fistep + spag_nextblock_1 = 1 main: do select case (spag_nextblock_1) @@ -159,26 +238,26 @@ function trara2(map,il,ib) itime = 0 i2 = 0 do - ! + ! find consecutive sub-sub-maps for scaled l-values ls1,ls2, ! with il less or equal ls2. l1,l2 are lengths of sub-sub-maps. ! i1,i2 are indeces of first elements minus 1. - ! + l2 = map(i2+1) if ( map(i2+2)<=il ) then i1 = i2 l1 = l2 i2 = i2 + l2 - ! + ! if sub-sub-maps are empty, i. e. length less 4, than trara2=0 - ! + elseif ( (l1<4) .and. (l2<4) ) then trara2 = 0.0_wp return else - ! + ! if flog2 less flog1, than ls2 first map and ls1 second map - ! + if ( map(i2+3)<=map(i1+3) ) exit spag_nextblock_1 = 3 cycle main @@ -194,9 +273,9 @@ function trara2(map,il,ib) l2 = kt spag_nextblock_1 = 3 case (3) - ! + ! determine interpolate in scaled l-value - ! + fll1 = map(i1+2) fll2 = map(i2+2) dfl = (fnl-fll1)/(fll2-fll1) @@ -205,9 +284,9 @@ function trara2(map,il,ib) fkb1 = 0.0_wp fkb2 = 0.0_wp if ( l1>=4 ) then - ! + ! b/b0 loop - ! + do j2 = 4 , l2 fincr2 = map(i2+j2) if ( fkb2+fincr2>fnb ) goto 10 @@ -332,7 +411,7 @@ function trara2(map,il,ib) exit main end select enddo main - + end function trara2 -end module radbelt_module \ No newline at end of file +end module trmfun_module \ No newline at end of file diff --git a/test/radbelt_test.f90 b/test/radbelt_test.f90 index a9c7616..a7e58e4 100644 --- a/test/radbelt_test.f90 +++ b/test/radbelt_test.f90 @@ -1,15 +1,15 @@ program radbelt_test !! comparison to the python radbelt example - - use core + + use core use radbelt_kinds_module - implicit none + implicit none real(wp) :: lon, lat, height, year, e, flux, error, relerror - integer :: imname - + integer :: imname, i + lon = -45.0_wp lat = -30.0_wp height = 500.0_wp @@ -22,16 +22,19 @@ program radbelt_test Imname = 4 ! 'p', 'max' e = 20.0_wp + do i = 1, 3 flux = get_flux(lon,lat,height,year,e,imname) ! error = Flux - 2642.50268555_wp ! difference from python wrapper version (radbelt) error = Flux - 2642.50370051985726336559603128948869_wp ! difference from real128 version - relerror = abs(error/flux) + relerror = abs(error/flux) write(*,*) 'Flux = ', flux write(*,*) 'Error = ', error - write(*,*) 'Rel Error = ', relerror + write(*,*) 'Rel Error = ', relerror if (relerror>10*epsilon(1.0_wp)) error stop 'error' + end do + end program radbelt_test From 25c3f8adb1bcc7b717951094ca597526e5de3a6c Mon Sep 17 00:00:00 2001 From: Jacob Williams Date: Tue, 6 Feb 2024 21:12:03 -0600 Subject: [PATCH 09/13] refactoring removed all common blocks --- src/core.f90 | 53 ++----- src/shellig.f90 | 408 ++++++++++++++++++++++++++---------------------- 2 files changed, 241 insertions(+), 220 deletions(-) diff --git a/src/core.f90 b/src/core.f90 index f941e8d..e0d1a69 100644 --- a/src/core.f90 +++ b/src/core.f90 @@ -2,7 +2,7 @@ !> ! Main module. ! -! Adapted from +!### See also ! * https://ccmc.gsfc.nasa.gov/pub/modelweb/geomagnetic/igrf/fortran_code/bilcal.for ! * https://ccmc.gsfc.nasa.gov/pub/modelweb/radiation_belt/radbelt/fortran_code/radbelt.for @@ -14,53 +14,32 @@ module core implicit none - public :: igrf public :: get_flux contains - !***************************************************************************************** - !> - ! Main routine. - ! - !@todo we need to read in the coefficients only once and keep them in memory, - ! rather than everytime these functions are called ! +!***************************************************************************************** +!> +! Main routine. function get_flux(Lon,Lat,Height,Year,E,Imname) result(flux) - real(wp) :: lon, lat, height, year, e - integer :: imname + real(wp),intent(in) :: lon + real(wp),intent(in) :: lat + real(wp),intent(in) :: height + real(wp),intent(in) :: year + real(wp),intent(in) :: e + integer,intent(in) :: imname + real(wp) :: flux - real(wp) :: flux,xl,bbx + real(wp) :: xl, bbx type(trm_type) :: trm + type(shellig_type) :: igrf - call igrf(Lon,Lat,Height,Year,Xl,Bbx) - call trm%aep8(e,Xl,Bbx,Imname,flux) + call igrf%igrf(lon,lat,height,year,xl,bbx) + call trm%aep8(e,xl,bbx,imname,flux) end function get_flux - - !***************************************************************************************** - !> - ! Wrapper for IGRF functions. - - subroutine igrf(lon,lat,height,year,xl,bbx) - - real(wp) :: bab1 , babs , bdel , bdown , beast , beq , bequ , bnorth , dimo , rr0 - integer :: icode - real(wp) :: lon , lat , height , year , xl , bbx - logical :: val - - CALL feldcof(Year,dimo) - CALL feldg(Lat,Lon,Height,bnorth,beast,bdown,babs) - CALL shellg(Lat,Lon,Height,dimo,Xl,icode,bab1) - bequ = dimo/(Xl*Xl*Xl) - IF ( icode==1 ) THEN - bdel = 1.0e-3_wp - CALL findb0(0.05_wp,bdel,val,beq,rr0) - IF ( val ) bequ = beq - ENDIF - Bbx = babs/bequ - - end subroutine igrf +!***************************************************************************************** end module core diff --git a/src/shellig.f90 b/src/shellig.f90 index 7bd1b1f..a184c4d 100644 --- a/src/shellig.f90 +++ b/src/shellig.f90 @@ -19,6 +19,8 @@ module shellig_module private + integer,parameter :: filename_len = 14 !! length of the model data file names + ! parameters formerly in `gener` common block real(wp),parameter :: Era = 6371.2_wp !! earth radius for normalization of cartesian coordinates (6371.2 km) real(wp),parameter :: erequ = 6378.16_wp @@ -31,25 +33,87 @@ module shellig_module !! astronomical union real(wp),parameter :: Umr = atan(1.0_wp)*4.0_wp/180.0_wp !! atan(1.0)*4./180. *umr= - public :: feldcof - public :: feldg - public :: shellg - public :: findb0 + type,public :: shellig_type + private + + ! formerly in the `fidb0` common block + real(wp),dimension(3) :: sp = 0.0_wp + + ! formerly in blank common + real(wp),dimension(3) :: xi = 0.0_wp + real(wp),dimension(144) :: h = 0.0_wp !! Field model coefficients adjusted for [[shellg]] + + ! formerly in `model` common block + character(len=filename_len) :: name = '' !! file name + integer :: nmax = 0 !! maximum order of spherical harmonics + real(wp) :: Time = 0.0_wp !! year (decimal: 1973.5) for which magnetic field is to be calculated + real(wp),dimension(144) :: g = 0.0_wp !! `g(m)` -- normalized field coefficients (see [[feldcof]]) m=nmax*(nmax+2) + + contains + private + + procedure,public :: igrf - contains + procedure, public :: feldcof + procedure, public :: feldg + procedure, public :: shellg + procedure, public :: findb0 + procedure :: stoer, getshc, intershc, extrashc + + end type shellig_type + + contains +!***************************************************************************************** !***************************************************************************************** !> - subroutine findb0(stps,bdel,value,bequ,rr0) +! Wrapper for IGRF functions. + + subroutine igrf(me,lon,lat,height,year,xl,bbx) + + class(shellig_type),intent(inout) :: me + real(wp),intent(in) :: lon + real(wp),intent(in) :: lat + real(wp),intent(in) :: height + real(wp),intent(in) :: year + real(wp),intent(out) :: xl + real(wp),intent(out) :: bbx + + real(wp) :: bab1 , babs , bdel , bdown , beast , & + beq , bequ , bnorth , dimo , rr0 + integer :: icode + logical :: val + + call me%feldcof(year,dimo) + call me%feldg(lat,lon,height,bnorth,beast,bdown,babs) + call me%shellg(lat,lon,height,dimo,xl,icode,bab1) + + bequ = dimo/(xl*xl*xl) + if ( icode==1 ) then + bdel = 1.0e-3_wp + call me%findb0(0.05_wp,bdel,val,beq,rr0) + if ( val ) bequ = beq + endif + bbx = babs/bequ + + end subroutine igrf +!***************************************************************************************** - real(wp) :: b , bdel , bdelta , bequ , bmin , bold , bq1 , & - bq2 , bq3 , p , r1 , r2 , r3 , & - rold , rr0 , sp , step , step12 , stps , zz +!***************************************************************************************** +!> + subroutine findb0(me,stps,bdel,value,bequ,rr0) + + class(shellig_type),intent(inout) :: me + real(wp),intent(in) :: stps + real(wp),intent(inout) :: bdel + real(wp),intent(out) :: bequ + logical,intent(out) :: value + real(wp),intent(out) :: rr0 + + real(wp) :: b , bdelta , bmin , bold , bq1 , & + bq2 , bq3 , p(8,4) , r1 , r2 , r3 , & + rold , step , step12 , zz integer :: i , irun , j , n - dimension p(8,4),sp(3) - logical :: value - - common/fidb0/ sp step=stps irun=0 @@ -61,23 +125,23 @@ subroutine findb0(stps,bdel,value,bequ,rr0) exit main endif !*********************first three points - p(1,2)=sp(1) - p(2,2)=sp(2) - p(3,2)=sp(3) + p(1,2)=me%sp(1) + p(2,2)=me%sp(2) + p(3,2)=me%sp(3) step=-sign(step,p(3,2)) - call stoer(p(1,2),bq2,r2) + call me%stoer(p(1,2),bq2,r2) p(1,3)=p(1,2)+0.5_wp*step*p(4,2) p(2,3)=p(2,2)+0.5_wp*step*p(5,2) p(3,3)=p(3,2)+0.5_wp*step - call stoer(p(1,3),bq3,r3) + call me%stoer(p(1,3),bq3,r3) p(1,1)=p(1,2)-step*(2.0_wp*p(4,2)-p(4,3)) p(2,1)=p(2,2)-step*(2.0_wp*p(5,2)-p(5,3)) p(3,1)=p(3,2)-step - call stoer(p(1,1),bq1,r1) + call me%stoer(p(1,1),bq1,r1) p(1,3)=p(1,2)+step*(20.0_wp*p(4,3)-3.*p(4,2)+p(4,1))/18.0_wp p(2,3)=p(2,2)+step*(20.0_wp*p(5,3)-3.*p(5,2)+p(5,1))/18.0_wp p(3,3)=p(3,2)+step - call stoer(p(1,3),bq3,r3) + call me%stoer(p(1,3),bq3,r3) !******************invert sense if required if (bq3>bq1) then step=-step @@ -104,7 +168,7 @@ subroutine findb0(stps,bdel,value,bequ,rr0) p(1,4)=p(1,3)+step12*(23.0_wp*p(4,3)-16.0_wp*p(4,2)+5.0_wp*p(4,1)) p(2,4)=p(2,3)+step12*(23.0_wp*p(5,3)-16.0_wp*p(5,2)+5.0_wp*p(5,1)) p(3,4)=p(3,3)+step - call stoer(p(1,4),bq3,r3) + call me%stoer(p(1,4),bq3,r3) do j=1,3 do i=1,8 p(i,j)=p(i,j+1) @@ -115,9 +179,9 @@ subroutine findb0(stps,bdel,value,bequ,rr0) if (b>bold) exit corrector bold=b rold=1.0_wp/r3 - sp(1)=p(1,4) - sp(2)=p(2,4) - sp(3)=p(3,4) + me%sp(1)=p(1,4) + me%sp(2)=p(2,4) + me%sp(3)=p(3,4) end do corrector if (bold/=bmin) then value=.false. @@ -148,8 +212,9 @@ end subroutine findb0 ! - USING CORRECT DIPOL MOMENT I.E.,DIFFERENT COMMON/MODEL/ ! - USING IGRF EARTH MAGNETIC FIELD MODELS FROM 1945 TO 1990 - subroutine shellg(glat,glon,alt,dimo,fl,icode,b0) + subroutine shellg(me,glat,glon,alt,dimo,fl,icode,b0) + class(shellig_type),intent(inout) :: me real(wp),intent(in) :: glat !! GEODETIC LATITUDE IN DEGREES (NORTH) real(wp),intent(in) :: glon !! GEODETIC LONGITUDE IN DEGREES (EAST) real(wp),intent(in) :: alt !! ALTITUDE IN KM ABOVE SEA LEVEL @@ -162,30 +227,24 @@ subroutine shellg(glat,glon,alt,dimo,fl,icode,b0) !! approximation is used. real(wp),intent(out) :: b0 !! magnetic field strength in gauss - real(wp) :: arg1 , arg2 , bequ , bq1 , bq2 , bq3 , c0 , c1 , c2 , c3 , ct , d , d0 , d1 , d2 - real(wp) :: dimob0 , e0 , e1 , e2 , ff , fi , gg , h , hli , oradik , oterm , p , r , r1 , r2 , r3 - real(wp) :: r3h , radik , rlat , rlon , rmax , rmin , rq , sp , st , step , step12 , step2 , steq , stp , t , term , v , x - real(wp) :: xx , z , zq , zz + real(wp) :: arg1 , arg2 , bequ , bq1 , bq2 , bq3 , c0 , c1 , c2 , c3 , & + ct , d , d0 , d1 , d2, dimob0 , e0 , e1 , e2 , ff , fi , gg , & + hli , oradik , oterm , p(8,100) , r , r1 , r2 , r3 , r3h , radik , & + rlat , rlon , rmax , rmin , rq , st , step , step12 , step2 , & + steq , stp , t , term , v(3) , xx , z , zq , zz integer :: i , iequ , n - dimension v(3) , p(8,100) , sp(3) - real(wp),dimension(3,3),parameter :: u = reshape([ +0.3511737_wp , -0.9148385_wp , -0.1993679_wp , & +0.9335804_wp , +0.3583680_wp , +0.0000000_wp , & +0.0714471_wp , -0.1861260_wp , +0.9799247_wp], [3,3]) -! COMMON -! X(3) NOT USED -! H(144) FIELD MODEL COEFFICIENTS ADJUSTED FOR SHELLG - COMMON X(3) , H(144) - COMMON /fidb0 / Sp - !-- RMIN, RMAX ARE BOUNDARIES FOR IDENTIFICATION OF ICODE=2 AND 3 !-- STEP IS STEP SIZE FOR FIELD LINE TRACING !-- STEQ IS STEP SIZE FOR INTEGRATION DATA rmin , rmax/0.05_wp , 1.01_wp/ DATA step , steq/0.20_wp , 0.03_wp/ + bequ = 1.0e10_wp !*****ENTRY POINT SHELLG TO BE USED WITH GEODETIC CO-ORDINATES @@ -193,11 +252,11 @@ subroutine shellg(glat,glon,alt,dimo,fl,icode,b0) ct = sin(rlat) st = cos(rlat) d = sqrt(Aquad-(Aquad-Bquad)*ct*ct) - X(1) = (Alt+Aquad/d)*st/Era - X(3) = (Alt+Bquad/d)*ct/Era + me%Xi(1) = (Alt+Aquad/d)*st/Era + me%Xi(3) = (Alt+Bquad/d)*ct/Era rlon = Glon*Umr - X(2) = X(1)*sin(rlon) - X(1) = X(1)*cos(rlon) + me%Xi(2) = me%Xi(1)*sin(rlon) + me%Xi(1) = me%Xi(1)*cos(rlon) CALL spag_block_1() RETURN @@ -207,9 +266,9 @@ subroutine shellg(glat,glon,alt,dimo,fl,icode,b0) ! Y-AXIS POINTING TO EQUATOR AT 90 LONG. ! Z-AXIS POINTING TO NORTH POLE ENTRY shellc(V,Fl,B0) - X(1) = V(1) - X(2) = V(2) - X(3) = V(3) + me%Xi(1) = V(1) + me%Xi(2) = V(2) + me%Xi(3) = V(3) CALL spag_block_1() CONTAINS @@ -219,27 +278,27 @@ subroutine spag_block_1 integer,parameter :: max_loop_index = 100 ! 3333 <--- original code had 3333 ... was this a bug ???? !*****CONVERT TO DIPOL-ORIENTED CO-ORDINATES - rq = 1./(X(1)*X(1)+X(2)*X(2)+X(3)*X(3)) + rq = 1.0_wp/(me%Xi(1)*me%Xi(1)+me%Xi(2)*me%Xi(2)+me%Xi(3)*me%Xi(3)) r3h = sqrt(rq*sqrt(rq)) - p(1,2) = (X(1)*u(1,1)+X(2)*u(2,1)+X(3)*u(3,1))*r3h - p(2,2) = (X(1)*u(1,2)+X(2)*u(2,2))*r3h - p(3,2) = (X(1)*u(1,3)+X(2)*u(2,3)+X(3)*u(3,3))*rq + p(1,2) = (me%Xi(1)*u(1,1)+me%Xi(2)*u(2,1)+me%Xi(3)*u(3,1))*r3h + p(2,2) = (me%Xi(1)*u(1,2)+me%Xi(2)*u(2,2))*r3h + p(3,2) = (me%Xi(1)*u(1,3)+me%Xi(2)*u(2,3)+me%Xi(3)*u(3,3))*rq ! *****FIRST THREE POINTS OF FIELD LINE step = -sign(step,p(3,2)) - CALL stoer(p(1,2),bq2,r2) + call me%stoer(p(1,2),bq2,r2) B0 = sqrt(bq2) p(1,3) = p(1,2) + 0.5_wp*step*p(4,2) p(2,3) = p(2,2) + 0.5_wp*step*p(5,2) p(3,3) = p(3,2) + 0.5_wp*step - CALL stoer(p(1,3),bq3,r3) + call me%stoer(p(1,3),bq3,r3) p(1,1) = p(1,2) - step*(2.0_wp*p(4,2)-p(4,3)) p(2,1) = p(2,2) - step*(2.0_wp*p(5,2)-p(5,3)) p(3,1) = p(3,2) - step - CALL stoer(p(1,1),bq1,r1) + call me%stoer(p(1,1),bq1,r1) p(1,3) = p(1,2) + step*(20.0_wp*p(4,3)-3.*p(4,2)+p(4,1))/18.0_wp p(2,3) = p(2,2) + step*(20.0_wp*p(5,3)-3.*p(5,2)+p(5,1))/18.0_wp p(3,3) = p(3,2) + step - CALL stoer(p(1,3),bq3,r3) + call me%stoer(p(1,3),bq3,r3) !*****INVERT SENSE IF REQUIRED IF ( bq3>bq1 ) THEN step = -step @@ -303,7 +362,7 @@ subroutine spag_block_1 p(1,n+1) = p(1,n) + step12*(23.0_wp*p(4,n)-16.0_wp*p(4,n-1)+5.0_wp*p(4,n-2)) p(2,n+1) = p(2,n) + step12*(23.0_wp*p(5,n)-16.0_wp*p(5,n-1)+5.0_wp*p(5,n-2)) p(3,n+1) = p(3,n) + step - CALL stoer(p(1,n+1),bq3,r3) + call me%stoer(p(1,n+1),bq3,r3) !*****SEARCH FOR LOWEST MAGNETIC FIELD STRENGTH IF ( bq3=1.0e-15_wp ) fi = fi + stp/0.75_wp*oterm*oradik/(oradik-radik) ! !-- The minimal allowable value of FI was changed from 1E-15 to 1E-12, @@ -392,20 +451,22 @@ END subroutine spag_block_1 END subroutine shellg -subroutine stoer(P,Bq,R) - IMPLICIT NONE - REAL(wp) Bq , dr , dsq , dx , dxm , dy , dym , dz , dzm , fli , & - H , P , q , R , rq , wr , Xi , xm , ym - REAL(wp) zm -!******************************************************************* -!* subroutine USED FOR FIELD LINE TRACING IN SHELLG * -!* CALLS ENTRY POINT FELDI IN GEOMAGNETIC FIELD subroutine FELDG * -!******************************************************************* - DIMENSION P(7) +!***************************************************************************************** +!> +! subroutine USED FOR FIELD LINE TRACING IN [[SHELLG]] +! CALLS ENTRY POINT [[FELDI]] IN GEOMAGNETIC FIELD subroutine [[FELDG]] + +subroutine stoer(me,P,Bq,R) + + class(shellig_type),intent(inout) :: me + REAL(wp) :: Bq , dr , dsq , dx , dxm , dy , dym , dz , dzm , fli , & + P(7) , q , R , rq , wr , xm , ym + REAL(wp) :: zm + real(wp),dimension(3,3),parameter :: u = reshape([ +0.3511737_wp , -0.9148385_wp , -0.1993679_wp , & +0.9335804_wp , +0.3583680_wp , +0.0000000_wp , & +0.0714471_wp , -0.1861260_wp , +0.9799247_wp],[3,3]) - COMMON Xi(3) , H(144) + !*****XM,YM,ZM ARE GEOMAGNETIC CARTESIAN INVERSE CO-ORDINATES zm = P(3) fli = P(1)*P(1) + P(2)*P(2) + 1.0e-15_wp @@ -415,17 +476,18 @@ subroutine stoer(P,Bq,R) xm = P(1)*wr ym = P(2)*wr !*****TRANSFORM TO GEOGRAPHIC CO-ORDINATE SYSTEM - Xi(1) = xm*u(1,1) + ym*u(1,2) + zm*u(1,3) - Xi(2) = xm*u(2,1) + ym*u(2,2) + zm*u(2,3) - Xi(3) = xm*u(3,1) + zm*u(3,3) + me%Xi(1) = xm*u(1,1) + ym*u(1,2) + zm*u(1,3) + me%Xi(2) = xm*u(2,1) + ym*u(2,2) + zm*u(2,3) + me%Xi(3) = xm*u(3,1) + zm*u(3,3) !*****COMPUTE DERIVATIVES ! Changed from CALL FELDI(XI,H); XI, H are in COMMON block; results -! are the same; dkb Feb 1998 - CALL feldi() - q = H(1)/rq - dx = H(3) + H(3) + q*Xi(1) - dy = H(4) + H(4) + q*Xi(2) - dz = H(2) + H(2) + q*Xi(3) +! are the same; dkb Feb 1998. +! JW : feb 2024 : xi, h now class variables. + CALL feldi(me) + q = me%H(1)/rq + dx = me%H(3) + me%H(3) + q*me%Xi(1) + dy = me%H(4) + me%H(4) + q*me%Xi(2) + dz = me%H(2) + me%H(2) + q*me%Xi(3) !*****TRANSFORM BACK TO GEOMAGNETIC CO-ORDINATE SYSTEM dxm = u(1,1)*dx + u(2,1)*dy + u(3,1)*dz dym = u(1,2)*dx + u(2,2)*dy @@ -453,53 +515,23 @@ END subroutine stoer ! - field coefficients in binary data files instead of block data ! - calculates dipol moment -subroutine feldg(glat,glon,alt,bnorth,beast,bdown,babs) +subroutine feldg(me,glat,glon,alt,bnorth,beast,bdown,babs) - !-------------------------------------------------------------------- - ! input: entry point feldg - ! glat geodetic latitude in degrees (north) - ! glon geodetic longitude in degrees (east) - ! alt altitude in km above sea level - ! - ! entry point feldc - ! v(3) cartesian coordinates in earth radii (6371.2 km) - ! x-axis pointing to equator at 0 longitude - ! y-axis pointing to equator at 90 long. - ! z-axis pointing to north pole - ! - ! common blank and entry point feldi are needed when used - ! in connection with l-calculation program shellg. - ! - ! common /model/ and /gener/ - ! umr = atan(1.0)*4./180. *umr= - ! era earth radius for normalization of cartesian - ! coordinates (6371.2 km) - ! aquad, bquad square of major and minor half axis for - ! earth ellipsoid as recommended by international - ! astronomical union (6378.160, 6356.775 km). - ! nmax maximum order of spherical harmonics - ! time year (decimal: 1973.5) for which magnetic - ! field is to be calculated - ! g(m) normalized field coefficients (see feldcof) - ! m=nmax*(nmax+2) - !------------------------------------------------------------------------ - ! output: babs magnetic field strength in gauss - ! bnorth, beast, bdown components of the field with respect - ! to the local geodetic coordinate system, with axis - ! pointing in the tangential plane to the north, east - ! and downward. - !----------------------------------------------------------------------- - - REAL(wp) Alt , B , Babs , Bdown , Beast , Bnorth , brho , bxxx , & - byyy , bzzz , cp , ct , d , f , G , Glat , Glon - REAL(wp) H , rho , rlat , rlon , rq , s , sp , st , t , Time , V , x , Xi , xxx , y , yyy , z , zzz - INTEGER i , ih , ihmax , il , imax , is , k , last , m , Nmax - - dimension v(3),b(3) - character*14 name - - common xi(3),h(144) - common/model/ name,nmax,time,g(144) + class(shellig_type),intent(inout) :: me + real(wp),intent(in) :: glat !! geodetic latitude in degrees (north) + real(wp),intent(in) :: glon !! geodetic longitude in degrees (east) + real(wp),intent(in) :: alt !! altitude in km above sea level + real(wp),intent(out) :: bnorth, beast, bdown !! components of the field with respect + !! to the local geodetic coordinate system, with axis + !! pointing in the tangential plane to the north, east + !! and downward. + real(wp),intent(out) :: Babs !! magnetic field strength in gauss + + real(wp) :: b(3) , brho , bxxx , & + byyy , bzzz , cp , ct , d , f , rho , & + rlat , rlon , rq , s , sp , st , t , v(3) , x , xxx , & + y , yyy , z , zzz + integer :: i , ih , ihmax , il , imax , is , k , last , m !-- is records entry point ! @@ -517,58 +549,68 @@ subroutine feldg(glat,glon,alt,bnorth,beast,bdown,babs) xxx=rho*cp yyy=rho*sp goto 10 - ! + !*****entry point feldc to be used with cartesian co-ordinates - entry feldc(v,b) + ! v(3) cartesian coordinates in earth radii (6371.2 km) + ! x-axis pointing to equator at 0 longitude + ! y-axis pointing to equator at 90 long. + ! z-axis pointing to north pole + entry feldc(me,v,b) is=2 xxx=v(1) yyy=v(2) zzz=v(3) - 10 rq=1./(xxx*xxx+yyy*yyy+zzz*zzz) - xi(1)=xxx*rq - xi(2)=yyy*rq - xi(3)=zzz*rq - goto 20 - ! + + 10 rq=1.0_wp/(xxx*xxx+yyy*yyy+zzz*zzz) + me%xi(1)=xxx*rq + me%xi(2)=yyy*rq + me%xi(3)=zzz*rq + goto 20 + !*****entry point feldi used for l computation - entry feldi() + entry feldi(me) is=3 - 20 ihmax=nmax*nmax+1 - last=ihmax+nmax+nmax - imax=nmax+nmax-1 + 20 ihmax=me%nmax*me%nmax+1 + last=ihmax+me%nmax+me%nmax + imax=me%nmax+me%nmax-1 do i=ihmax,last - h(i)=g(i) + me%h(i)=me%g(i) end do do k=1,3,2 i=imax ih=ihmax - 1 il=ih-i - f=2.0_wp/real(i-k+2, wp) - x=xi(1)*f - y=xi(2)*f - z=xi(3)*(f+f) - i=i-2 - if ((i-1)>=0) then - if ((i-1)>0) then - do m=3,i,2 - h(il+m+1)=g(il+m+1)+z*h(ih+m+1)+x*(h(ih+m+3)-h(ih+m-1))-y*(h(ih+m+2)+h(ih+m-2)) - h(il+m)=g(il+m)+z*h(ih+m)+x*(h(ih+m+2)-h(ih+m-2))+y*(h(ih+m+3)+h(ih+m-1)) - end do + do + il=ih-i + f=2.0_wp/real(i-k+2, wp) + x=me%xi(1)*f + y=me%xi(2)*f + z=me%xi(3)*(f+f) + i=i-2 + if ((i-1)>=0) then + if ((i-1)>0) then + do m=3,i,2 + me%h(il+m+1)=me%g(il+m+1)+z*me%h(ih+m+1)+x*(me%h(ih+m+3)-& + me%h(ih+m-1))-y*(me%h(ih+m+2)+me%h(ih+m-2)) + me%h(il+m)=me%g(il+m)+z*me%h(ih+m)+x*(me%h(ih+m+2)-& + me%h(ih+m-2))+y*(me%h(ih+m+3)+me%h(ih+m-1)) + end do + end if + me%h(il+2)=me%g(il+2)+z*me%h(ih+2)+x*me%h(ih+4)-y*(me%h(ih+3)+me%h(ih)) + me%h(il+1)=me%g(il+1)+z*me%h(ih+1)+y*me%h(ih+4)+x*(me%h(ih+3)-me%h(ih)) end if - h(il+2)=g(il+2)+z*h(ih+2)+x*h(ih+4)-y*(h(ih+3)+h(ih)) - h(il+1)=g(il+1)+z*h(ih+1)+y*h(ih+4)+x*(h(ih+3)-h(ih)) - end if - h(il)=g(il)+z*h(ih)+2.0_wp*(x*h(ih+1)+y*h(ih+2)) - ih=il - if (i>=k) goto 1 + me%h(il)=me%g(il)+z*me%h(ih)+2.0_wp*(x*me%h(ih+1)+y*me%h(ih+2)) + ih=il + if (inumye ) l = numye dte1 = dtemod(l) - fil1 = filmod(l) + me%name = filmod(l) dte2 = dtemod(l+1) fil2 = filmod(l+1) !-- get igrf coefficients for the boundary years - call getshc(fil1,nmax1,erad,gh1,ier) + call me%getshc(me%name,nmax1,erad,me%g,ier) if ( ier/=0 ) stop - call getshc(fil2,nmax2,erad,gh2,ier) + call me%getshc(fil2,nmax2,erad,gh2,ier) if ( ier/=0 ) stop !-- determine igrf coefficients for year if ( l<=numye-1 ) then - call intershc(year,dte1,nmax1,gh1,dte2,nmax2,gh2,nmax,gha) + call me%intershc(year,dte1,nmax1,me%g,dte2,nmax2,gh2,me%nmax,gha) else - call extrashc(year,dte1,nmax1,gh1,nmax2,gh2,nmax,gha) + call me%extrashc(year,dte1,nmax1,me%g,nmax2,gh2,me%nmax,gha) endif !-- determine magnetic dipol moment and coeffiecients g f0 = 0.0_wp @@ -659,25 +698,25 @@ subroutine feldcof(year,dimo) enddo dimo = sqrt(f0) - gh1(1) = 0.0_wp + me%g(1) = 0.0_wp i = 2 f0 = 1.0e-5_wp if ( is==0 ) f0 = -f0 sqrt2 = sqrt(2.0_wp) - do n = 1 , nmax + do n = 1 , me%nmax x = n f0 = f0*x*x/(4.0_wp*x-2.0_wp) if ( is==0 ) f0 = f0*(2.0_wp*x-1.0_wp)/x f = f0*0.5_wp if ( is==0 ) f = f*sqrt2 - gh1(i) = gha(i-1)*f0 + me%g(i) = gha(i-1)*f0 i = i + 1 do m = 1 , n f = f*(x+m)/(x-m+1.0_wp) if ( is==0 ) f = f*sqrt((x-m+1.0_wp)/(x+m)) - gh1(i) = gha(i-1)*f - gh1(i+1) = gha(i)*f + me%g(i) = gha(i-1)*f + me%g(i+1) = gha(i)*f i = i + 2 enddo enddo @@ -693,8 +732,9 @@ end subroutine feldcof ! * Version 1.01, A. Zunde, USGS, MS 964, ! Box 25046 Federal Center, Denver, CO 80225 -subroutine getshc(Fspec,Nmax,Erad,Gh,Ier) +subroutine getshc(me,Fspec,Nmax,Erad,Gh,Ier) + class(shellig_type),intent(inout) :: me character(len=*),intent(in) :: Fspec !! File specification integer,intent(out) :: Nmax !! Maximum degree and order of model real(wp),intent(out) :: Erad !! Earth's radius associated with the spherical @@ -786,8 +826,9 @@ END subroutine getshc ! * Version 1.01, A. Zunde ! USGS, MS 964, Box 25046 Federal Center, Denver, CO 80225 -subroutine intershc(date,dte1,nmax1,gh1,dte2,nmax2,gh2,nmax,gh) +subroutine intershc(me,date,dte1,nmax1,gh1,dte2,nmax2,gh2,nmax,gh) + class(shellig_type),intent(inout) :: me real(wp),intent(in) :: date !! Date of resulting model (in decimal year) real(wp),intent(in) :: dte1 !! Date of earlier model integer,intent(in) :: nmax1 !! Maximum degree and order of earlier model @@ -844,8 +885,9 @@ end subroutine intershc ! * Version 1.01, A. Zunde ! USGS, MS 964, Box 25046 Federal Center, Denver, CO 80225 -subroutine extrashc(date,dte1,nmax1,gh1,nmax2,gh2,nmax,gh) +subroutine extrashc(me,date,dte1,nmax1,gh1,nmax2,gh2,nmax,gh) + class(shellig_type),intent(inout) :: me real(wp),intent(in) :: date !! Date of resulting model (in decimal year) real(wp),intent(in) :: dte1 !! Date of base model integer,intent(in) :: nmax1 !! Maximum degree and order of base model From d1dfa43cf29ead4f1f08ef03039e31ffbd20e64f Mon Sep 17 00:00:00 2001 From: Jacob Williams Date: Tue, 6 Feb 2024 21:21:26 -0600 Subject: [PATCH 10/13] removed data statements should now be threadsafe --- src/shellig.f90 | 70 ++++++++++++++++++++++++------------------------- 1 file changed, 35 insertions(+), 35 deletions(-) diff --git a/src/shellig.f90 b/src/shellig.f90 index a184c4d..4307a03 100644 --- a/src/shellig.f90 +++ b/src/shellig.f90 @@ -49,6 +49,10 @@ module shellig_module real(wp) :: Time = 0.0_wp !! year (decimal: 1973.5) for which magnetic field is to be calculated real(wp),dimension(144) :: g = 0.0_wp !! `g(m)` -- normalized field coefficients (see [[feldcof]]) m=nmax*(nmax+2) + ! formerly saved vars in shellg: + real(wp) :: step = 0.20_wp !! step size for field line tracing + real(wp) :: steq = 0.03_wp !! step size for integration + contains private @@ -230,24 +234,20 @@ subroutine shellg(me,glat,glon,alt,dimo,fl,icode,b0) real(wp) :: arg1 , arg2 , bequ , bq1 , bq2 , bq3 , c0 , c1 , c2 , c3 , & ct , d , d0 , d1 , d2, dimob0 , e0 , e1 , e2 , ff , fi , gg , & hli , oradik , oterm , p(8,100) , r , r1 , r2 , r3 , r3h , radik , & - rlat , rlon , rmax , rmin , rq , st , step , step12 , step2 , & - steq , stp , t , term , v(3) , xx , z , zq , zz + rlat , rlon , rq , st , step12 , step2 , & + stp , t , term , v(3) , xx , z , zq , zz integer :: i , iequ , n real(wp),dimension(3,3),parameter :: u = reshape([ +0.3511737_wp , -0.9148385_wp , -0.1993679_wp , & +0.9335804_wp , +0.3583680_wp , +0.0000000_wp , & +0.0714471_wp , -0.1861260_wp , +0.9799247_wp], [3,3]) - !-- RMIN, RMAX ARE BOUNDARIES FOR IDENTIFICATION OF ICODE=2 AND 3 - !-- STEP IS STEP SIZE FOR FIELD LINE TRACING - !-- STEQ IS STEP SIZE FOR INTEGRATION - - DATA rmin , rmax/0.05_wp , 1.01_wp/ - DATA step , steq/0.20_wp , 0.03_wp/ + real(wp),parameter :: rmin = 0.05_wp !! boundaries for identification of `icode=2 and 3` + real(wp),parameter :: rmax = 1.01_wp !! boundaries for identification of `icode=2 and 3` bequ = 1.0e10_wp - !*****ENTRY POINT SHELLG TO BE USED WITH GEODETIC CO-ORDINATES + !*****ENTRY POINT SHELLG TO BE USED WITH GEODETIC CO-ORDINATES rlat = Glat*Umr ct = sin(rlat) st = cos(rlat) @@ -260,12 +260,12 @@ subroutine shellg(me,glat,glon,alt,dimo,fl,icode,b0) CALL spag_block_1() RETURN -!*****ENTRY POINT SHELLC TO BE USED WITH CARTESIAN CO-ORDINATES +!*****ENTRY POINT SHELLC TO BE USED WITH CARTESIAN CO-ORDINATES ! JW : does not appear to be used anywhere. ! V(3) CARTESIAN COORDINATES IN EARTH RADII (6371.2 KM) ! X-AXIS POINTING TO EQUATOR AT 0 LONGITUDE ! Y-AXIS POINTING TO EQUATOR AT 90 LONG. ! Z-AXIS POINTING TO NORTH POLE - ENTRY shellc(V,Fl,B0) + ENTRY shellc(me,V,Fl,B0) me%Xi(1) = V(1) me%Xi(2) = V(2) me%Xi(3) = V(3) @@ -275,7 +275,7 @@ subroutine shellg(me,glat,glon,alt,dimo,fl,icode,b0) subroutine spag_block_1 - integer,parameter :: max_loop_index = 100 ! 3333 <--- original code had 3333 ... was this a bug ???? + integer,parameter :: max_loop_index = 100 ! 3333 <--- JW : original code had 3333 ... was this a bug ???? !*****CONVERT TO DIPOL-ORIENTED CO-ORDINATES rq = 1.0_wp/(me%Xi(1)*me%Xi(1)+me%Xi(2)*me%Xi(2)+me%Xi(3)*me%Xi(3)) @@ -284,24 +284,24 @@ subroutine spag_block_1 p(2,2) = (me%Xi(1)*u(1,2)+me%Xi(2)*u(2,2))*r3h p(3,2) = (me%Xi(1)*u(1,3)+me%Xi(2)*u(2,3)+me%Xi(3)*u(3,3))*rq ! *****FIRST THREE POINTS OF FIELD LINE - step = -sign(step,p(3,2)) + me%step = -sign(me%step,p(3,2)) call me%stoer(p(1,2),bq2,r2) B0 = sqrt(bq2) - p(1,3) = p(1,2) + 0.5_wp*step*p(4,2) - p(2,3) = p(2,2) + 0.5_wp*step*p(5,2) - p(3,3) = p(3,2) + 0.5_wp*step + p(1,3) = p(1,2) + 0.5_wp*me%step*p(4,2) + p(2,3) = p(2,2) + 0.5_wp*me%step*p(5,2) + p(3,3) = p(3,2) + 0.5_wp*me%step call me%stoer(p(1,3),bq3,r3) - p(1,1) = p(1,2) - step*(2.0_wp*p(4,2)-p(4,3)) - p(2,1) = p(2,2) - step*(2.0_wp*p(5,2)-p(5,3)) - p(3,1) = p(3,2) - step + p(1,1) = p(1,2) - me%step*(2.0_wp*p(4,2)-p(4,3)) + p(2,1) = p(2,2) - me%step*(2.0_wp*p(5,2)-p(5,3)) + p(3,1) = p(3,2) - me%step call me%stoer(p(1,1),bq1,r1) - p(1,3) = p(1,2) + step*(20.0_wp*p(4,3)-3.*p(4,2)+p(4,1))/18.0_wp - p(2,3) = p(2,2) + step*(20.0_wp*p(5,3)-3.*p(5,2)+p(5,1))/18.0_wp - p(3,3) = p(3,2) + step + p(1,3) = p(1,2) + me%step*(20.0_wp*p(4,3)-3.*p(4,2)+p(4,1))/18.0_wp + p(2,3) = p(2,2) + me%step*(20.0_wp*p(5,3)-3.*p(5,2)+p(5,1))/18.0_wp + p(3,3) = p(3,2) + me%step call me%stoer(p(1,3),bq3,r3) !*****INVERT SENSE IF REQUIRED IF ( bq3>bq1 ) THEN - step = -step + me%step = -me%step r3 = r1 bq3 = bq1 DO i = 1 , 7 @@ -324,14 +324,14 @@ subroutine spag_block_1 iequ = 3 ENDIF !*****INITIALIZATION OF INTEGRATION LOOPS - step12 = step/12.0_wp - step2 = step + step - steq = sign(steq,step) + step12 = me%step/12.0_wp + step2 = me%step + me%step + me%steq = sign(me%steq,me%step) fi = 0.0_wp Icode = 1 oradik = 0.0_wp oterm = 0.0_wp - stp = r2*steq + stp = r2*me%steq z = p(3,2) + stp stp = stp/0.75_wp p(8,1) = step2*(p(1,1)*p(4,1)+p(2,1)*p(5,1)) @@ -356,12 +356,12 @@ subroutine spag_block_1 e2 = (p(7,n)+p(7,n-2)-e0-e0)*0.5_wp inner: DO !*****INNER LOOP (FOR QUADRATURE) - t = (z-p(3,n-1))/step + t = (z-p(3,n-1))/me%step IF ( t>1.0_wp ) THEN !*****PREDICTOR (FIELD LINE TRACING) p(1,n+1) = p(1,n) + step12*(23.0_wp*p(4,n)-16.0_wp*p(4,n-1)+5.0_wp*p(4,n-2)) p(2,n+1) = p(2,n) + step12*(23.0_wp*p(5,n)-16.0_wp*p(5,n-1)+5.0_wp*p(5,n-2)) - p(3,n+1) = p(3,n) + step + p(3,n+1) = p(3,n) + me%step call me%stoer(p(1,n+1),bq3,r3) !*****SEARCH FOR LOWEST MAGNETIC FIELD STRENGTH IF ( bq323.0_wp ) THEN gg = xx - 3.0460681_wp - ELSEIF ( xx>11.7 ) THEN + ELSEIF ( xx>11.7_wp ) THEN gg = (((((2.8212095E-8_wp*xx-3.8049276E-6_wp)*xx+& 2.170224E-4_wp)*xx-6.7310339E-3_wp)*xx+& 1.2038224E-1_wp)*xx-1.8461796E-1_wp)*xx + 2.0007187_wp - ELSEIF ( xx>+3.0 ) THEN + ELSEIF ( xx>+3.0_wp ) THEN gg = ((((((((6.3271665E-10_wp*xx-3.958306E-8_wp)*xx+& 9.9766148E-07_wp)*xx-1.2531932E-5_wp)*xx+& 7.9451313E-5_wp)*xx-3.2077032E-4_wp)*xx+& 2.1680398E-3_wp)*xx+1.2817956E-2_wp)*xx+& 4.3510529E-1_wp)*xx + 6.222355E-1_wp - ELSEIF ( xx>-3.0 ) THEN + ELSEIF ( xx>-3.0_wp ) THEN gg = ((((((((2.6047023E-10_wp*xx+2.3028767E-9_wp)*xx-& 2.1997983E-8_wp)*xx-5.3977642E-7_wp)*xx-& 3.3408822E-6_wp)*xx+3.8379917E-5_wp)*xx+& 1.1784234E-3_wp)*xx+1.4492441E-2_wp)*xx+& 4.3352788E-1_wp)*xx + 6.228644E-1_wp - ELSEIF ( xx>-22. ) THEN + ELSEIF ( xx>-22.0_wp ) THEN gg = ((((((((-8.1537735E-14_wp*xx+8.3232531E-13_wp)*xx+& 1.0066362E-9_wp)*xx+8.1048663E-8_wp)*xx+& 3.2916354E-6_wp)*xx+8.2711096E-5_wp)*xx+& From eb069a87f1de325f6bf44ece82d824cf0318a431 Mon Sep 17 00:00:00 2001 From: Jacob Williams Date: Tue, 6 Feb 2024 23:45:50 -0600 Subject: [PATCH 11/13] refactoring --- src/shellig.f90 | 83 ++++++++++++++++++++++++++++--------------------- 1 file changed, 47 insertions(+), 36 deletions(-) diff --git a/src/shellig.f90 b/src/shellig.f90 index 4307a03..a4227bd 100644 --- a/src/shellig.f90 +++ b/src/shellig.f90 @@ -33,7 +33,11 @@ module shellig_module !! astronomical union real(wp),parameter :: Umr = atan(1.0_wp)*4.0_wp/180.0_wp !! atan(1.0)*4./180. *umr= - type,public :: shellig_type + real(wp),dimension(3,3),parameter :: u = reshape([ +0.3511737_wp , -0.9148385_wp , -0.1993679_wp , & + +0.9335804_wp , +0.3583680_wp , +0.0000000_wp , & + +0.0714471_wp , -0.1861260_wp , +0.9799247_wp], [3,3]) + + type,public :: shellig_type private ! formerly in the `fidb0` common block @@ -44,6 +48,7 @@ module shellig_module real(wp),dimension(144) :: h = 0.0_wp !! Field model coefficients adjusted for [[shellg]] ! formerly in `model` common block + integer :: iyea = 0 !! the int year corresponding to the file `name` that has been read character(len=filename_len) :: name = '' !! file name integer :: nmax = 0 !! maximum order of spherical harmonics real(wp) :: Time = 0.0_wp !! year (decimal: 1973.5) for which magnetic field is to be calculated @@ -53,6 +58,9 @@ module shellig_module real(wp) :: step = 0.20_wp !! step size for field line tracing real(wp) :: steq = 0.03_wp !! step size for integration + ! from feldcof, so we can cache the coefficients + real(wp),dimension(120) :: gh2 = 0.0_wp ! JW : why is this 120 and g is 144 ??? + contains private @@ -76,11 +84,12 @@ module shellig_module subroutine igrf(me,lon,lat,height,year,xl,bbx) class(shellig_type),intent(inout) :: me - real(wp),intent(in) :: lon - real(wp),intent(in) :: lat - real(wp),intent(in) :: height - real(wp),intent(in) :: year - real(wp),intent(out) :: xl + real(wp),intent(in) :: lon !! geodetic longitude in degrees (east) + real(wp),intent(in) :: lat !! geodetic latitude in degrees (north) + real(wp),intent(in) :: height !! altitude in km above sea level + real(wp),intent(in) :: year !! decimal year for which geomagnetic field is to + !! be calculated (e.g.:1995.5 for day 185 of 1995) + real(wp),intent(out) :: xl !! l-value real(wp),intent(out) :: bbx real(wp) :: bab1 , babs , bdel , bdown , beast , & @@ -88,6 +97,8 @@ subroutine igrf(me,lon,lat,height,year,xl,bbx) integer :: icode logical :: val + real(wp),parameter :: stps = 0.05_wp + call me%feldcof(year,dimo) call me%feldg(lat,lon,height,bnorth,beast,bdown,babs) call me%shellg(lat,lon,height,dimo,xl,icode,bab1) @@ -95,7 +106,7 @@ subroutine igrf(me,lon,lat,height,year,xl,bbx) bequ = dimo/(xl*xl*xl) if ( icode==1 ) then bdel = 1.0e-3_wp - call me%findb0(0.05_wp,bdel,val,beq,rr0) + call me%findb0(stps,bdel,val,beq,rr0) if ( val ) bequ = beq endif bbx = babs/bequ @@ -116,7 +127,7 @@ subroutine findb0(me,stps,bdel,value,bequ,rr0) real(wp) :: b , bdelta , bmin , bold , bq1 , & bq2 , bq3 , p(8,4) , r1 , r2 , r3 , & - rold , step , step12 , zz + rold , step , step12 , zz integer :: i , irun , j , n step=stps @@ -187,9 +198,7 @@ subroutine findb0(me,stps,bdel,value,bequ,rr0) me%sp(2)=p(2,4) me%sp(3)=p(3,4) end do corrector - if (bold/=bmin) then - value=.false. - endif + if (bold/=bmin) value=.false. bdelta=(b-bold)/bold if (bdelta<=bdel) exit main step=step/10.0_wp @@ -238,10 +247,6 @@ subroutine shellg(me,glat,glon,alt,dimo,fl,icode,b0) stp , t , term , v(3) , xx , z , zq , zz integer :: i , iequ , n - real(wp),dimension(3,3),parameter :: u = reshape([ +0.3511737_wp , -0.9148385_wp , -0.1993679_wp , & - +0.9335804_wp , +0.3583680_wp , +0.0000000_wp , & - +0.0714471_wp , -0.1861260_wp , +0.9799247_wp], [3,3]) - real(wp),parameter :: rmin = 0.05_wp !! boundaries for identification of `icode=2 and 3` real(wp),parameter :: rmax = 1.01_wp !! boundaries for identification of `icode=2 and 3` @@ -453,19 +458,18 @@ END subroutine shellg !***************************************************************************************** !> -! subroutine USED FOR FIELD LINE TRACING IN [[SHELLG]] -! CALLS ENTRY POINT [[FELDI]] IN GEOMAGNETIC FIELD subroutine [[FELDG]] +! subroutine used for field line tracing in [[shellg]] +! calls entry point [[feldi]] in geomagnetic field subroutine [[feldg]] -subroutine stoer(me,P,Bq,R) +subroutine stoer(me,p,bq,r) class(shellig_type),intent(inout) :: me - REAL(wp) :: Bq , dr , dsq , dx , dxm , dy , dym , dz , dzm , fli , & - P(7) , q , R , rq , wr , xm , ym - REAL(wp) :: zm + real(wp),dimension(7),intent(inout) :: p + real(wp),intent(out) :: bq + real(wp),intent(out) :: r - real(wp),dimension(3,3),parameter :: u = reshape([ +0.3511737_wp , -0.9148385_wp , -0.1993679_wp , & - +0.9335804_wp , +0.3583680_wp , +0.0000000_wp , & - +0.0714471_wp , -0.1861260_wp , +0.9799247_wp],[3,3]) + real(wp) :: dr , dsq , dx , dxm , dy , dym , dz , & + dzm , fli , q , rq , wr , xm , ym , zm !*****XM,YM,ZM ARE GEOMAGNETIC CARTESIAN INVERSE CO-ORDINATES zm = P(3) @@ -498,7 +502,7 @@ subroutine stoer(me,P,Bq,R) P(5) = (wr*dym-0.5_wp*P(2)*dr)/(R*dzm) dsq = rq*(dxm*dxm+dym*dym+dzm*dzm) Bq = dsq*rq*rq - P(6) = sqrt(dsq/(rq+3.*zm*zm)) + P(6) = sqrt(dsq/(rq+3.0_wp*zm*zm)) P(7) = P(6)*(rq+zm*zm)/(rq*dzm) END subroutine stoer @@ -646,8 +650,8 @@ subroutine feldcof(me,year,dimo) real(wp),intent(out) :: dimo !! geomagnetic dipol moment in gauss (normalized !! to earth's radius) at the time (year) - real(wp) :: dte1 , dte2 , erad , gh2(120) , gha(144) , sqrt2 - integer :: i , ier , iyea , j , l , m , n , nmax1 , nmax2 + real(wp) :: dte1 , dte2 , erad , gha(144) , sqrt2 + integer :: i , ier , j , l , m , n , nmax1 , nmax2, iyea character(len=filename_len) :: fil2 real(wp) :: x , f0 , f !! these were double precision in original !! code while everything else was single precision @@ -665,30 +669,37 @@ subroutine feldcof(me,year,dimo) 1990.0_wp , 1995.0_wp , 2000.0_wp , & 2005.0_wp , 2010.0_wp , 2015.0_wp , & 2020.0_wp , 2025.0_wp] - integer,parameter :: numye = 16 ! number of 5-year priods represented by IGRF + integer,parameter :: numye = size(dtemod)-1 ! number of 5-year priods represented by IGRF integer,parameter :: is = 0 !! * is=0 for schmidt normalization !! * is=1 gauss normalization + logical :: read_file + !-- determine igrf-years for input-year me%time = year iyea = int(year/5.0_wp)*5 - l = (iyea-1945)/5 + 1 + read_file = iyea /= me%iyea ! if we have to read the file + me%iyea = iyea + l = (me%iyea-1945)/5 + 1 if ( l<1 ) l = 1 if ( l>numye ) l = numye dte1 = dtemod(l) me%name = filmod(l) dte2 = dtemod(l+1) fil2 = filmod(l+1) - !-- get igrf coefficients for the boundary years - call me%getshc(me%name,nmax1,erad,me%g,ier) - if ( ier/=0 ) stop - call me%getshc(fil2,nmax2,erad,gh2,ier) - if ( ier/=0 ) stop + if (read_file) then + ! get igrf coefficients for the boundary years + ! [if they have not ready been loaded] + call me%getshc(me%name,nmax1,erad,me%g,ier) + if ( ier/=0 ) error stop 'error reading file: '//trim(me%name) + call me%getshc(fil2,nmax2,erad,me%gh2,ier) + if ( ier/=0 ) error stop 'error reading file: '//trim(fil2) + end if !-- determine igrf coefficients for year if ( l<=numye-1 ) then - call me%intershc(year,dte1,nmax1,me%g,dte2,nmax2,gh2,me%nmax,gha) + call me%intershc(year,dte1,nmax1,me%g,dte2,nmax2,me%gh2,me%nmax,gha) else - call me%extrashc(year,dte1,nmax1,me%g,nmax2,gh2,me%nmax,gha) + call me%extrashc(year,dte1,nmax1,me%g,nmax2,me%gh2,me%nmax,gha) endif !-- determine magnetic dipol moment and coeffiecients g f0 = 0.0_wp From 7e3d3eec9eb7460e334984512fe95ef6d0a9fa43 Mon Sep 17 00:00:00 2001 From: Jacob Williams Date: Tue, 6 Feb 2024 23:52:31 -0600 Subject: [PATCH 12/13] added CI and readme --- .github/workflows/CI.yml | 86 ++++++++++++++++++++++++++++++++++++ README.md | 94 +++++++++++++++++++++++++++------------- 2 files changed, 149 insertions(+), 31 deletions(-) create mode 100644 .github/workflows/CI.yml diff --git a/.github/workflows/CI.yml b/.github/workflows/CI.yml new file mode 100644 index 0000000..fe11fa8 --- /dev/null +++ b/.github/workflows/CI.yml @@ -0,0 +1,86 @@ +name: CI +on: [push] +jobs: + + Build: + runs-on: ${{ matrix.os }} + permissions: + contents: write + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest] + gcc_v: [10] # Version of GFortran we want to use. + python-version: [3.9] + env: + FC: gfortran-${{ matrix.gcc_v }} + GCC_V: ${{ matrix.gcc_v }} + + steps: + - name: Checkout code + uses: actions/checkout@v3 + with: + submodules: recursive + + - name: Install Python + uses: actions/setup-python@v4 # Use pip to install latest CMake, & FORD/Jin2For, etc. + with: + python-version: ${{ matrix.python-version }} + + - name: Setup Graphviz + uses: ts-graphviz/setup-graphviz@v1 + + - name: Setup Fortran Package Manager + uses: fortran-lang/setup-fpm@v5 + with: + github-token: ${{ secrets.GITHUB_TOKEN }} + + - name: Install Python dependencies + if: contains( matrix.os, 'ubuntu') + run: | + python -m pip install --upgrade pip + pip install ford numpy matplotlib + if [ -f requirements.txt ]; then pip install -r requirements.txt; fi + + - name: Install GFortran Linux + if: contains( matrix.os, 'ubuntu') + run: | + sudo apt-get install lcov + sudo add-apt-repository ppa:ubuntu-toolchain-r/test + sudo apt-get update + sudo apt-get install -y gcc-${{ matrix.gcc_v }} gfortran-${{ matrix.gcc_v }} + sudo update-alternatives \ + --install /usr/bin/gcc gcc /usr/bin/gcc-${{ matrix.gcc_v }} 100 \ + --slave /usr/bin/gfortran gfortran /usr/bin/gfortran-${{ matrix.gcc_v }} \ + --slave /usr/bin/gcov gcov /usr/bin/gcov-${{ matrix.gcc_v }} + + # - name: Compile + # run: fpm build --profile release + + - name: Run tests + run: fpm test --profile debug --flag -coverage + + - name: Create coverage report + run: | + mkdir -p ${{ env.COV_DIR }} + mv ./build/gfortran_*/*/* ${{ env.COV_DIR }} + lcov --capture --initial --base-directory . --directory ${{ env.COV_DIR }} --output-file ${{ env.COV_DIR }}/coverage.base + lcov --capture --base-directory . --directory ${{ env.COV_DIR }} --output-file ${{ env.COV_DIR }}/coverage.capture + lcov --add-tracefile ${{ env.COV_DIR }}/coverage.base --add-tracefile ${{ env.COV_DIR }}/coverage.capture --output-file ${{ env.COV_DIR }}/coverage.info + env: + COV_DIR: build/coverage + + - name: Upload coverage report + uses: codecov/codecov-action@v3 + with: + files: build/coverage/coverage.info + + - name: Build documentation + run: ford ./ford.md + + - name: Deploy Documentation + if: github.ref == 'refs/heads/master' + uses: JamesIves/github-pages-deploy-action@v4.4.1 + with: + branch: gh-pages # The branch the action should deploy to. + folder: doc # The folder the action should deploy. diff --git a/README.md b/README.md index 0fc77e9..c3d1027 100755 --- a/README.md +++ b/README.md @@ -1,4 +1,45 @@ -National Space Science Data Center Data set PT-11B Mar 1996 +Radbelt: Work in progress to refactor the AE-8/AP-8 Van Allen belt model. + +### Status + +[![Language](https://img.shields.io/badge/-Fortran-734f96?logo=fortran&logoColor=white)](https://github.com/topics/fortran) +[![GitHub release](https://img.shields.io/github/release/jacobwilliams/radbelt.svg)](https://github.com/jacobwilliams/radbelt/releases/latest) +[![CI Status](https://github.com/jacobwilliams/radbelt/actions/workflows/CI.yml/badge.svg)](https://github.com/jacobwilliams/radbelt/actions) +[![codecov](https://codecov.io/gh/jacobwilliams/radbelt/branch/master/graph/badge.svg)](https://codecov.io/gh/jacobwilliams/radbelt) +[![last-commit](https://img.shields.io/github/last-commit/jacobwilliams/radbelt)](https://github.com/jacobwilliams/radbelt/commits/master) + +### Compiling + +A [Fortran Package Manager](https://github.com/fortran-lang/fpm) manifest file is included, so that the library and test cases can be compiled with FPM. For example: + +``` +fpm build --profile release +fpm test --profile release +``` + +To use `radbelt` within your fpm project, add the following to your `fpm.toml` file: +```toml +[dependencies] +radbelt = { git="https://github.com/jacobwilliams/radbelt.git" } +``` + +### Documentation + +The latest API documentation can be found [here](https://jacobwilliams.github.io/radbelt/). This was generated from the source code using [FORD](https://github.com/Fortran-FOSS-Programmers/ford). + +### See also + +* [NASA ModelWebArchive](https://git.smce.nasa.gov/ccmc-share/modelwebarchive) +* [An Astropy-friendly wrapper for the AE-8/AP-8 Van Allen belt model](https://github.com/nasa/radbelt) +* [pyIGRF](https://github.com/rilma/pyIGRF) +* https://github.com/lanl/RAM-SCB/blob/master/srcExternal/igrf.f +* https://github.com/space-physics/igrf/blob/main/src/igrf/fortran/igrf13.f + + + +# Original Readme + +National Space Science Data Center Data set PT-11B Mar 1996 ========================================================================= ``` @@ -12,7 +53,7 @@ SOURCE: Dieter Bilitza, GSFC/NSSDC code 633, Greenbelt, dbilitza@pop600.gsfc.nasa.gov CONTENT: 12 files *.* blocks - FORTRAN source code: + FORTRAN source code: driver program with interface RADBELT.FOR 48 subroutines, functions TRMFUN.FOR 30 @@ -34,36 +75,36 @@ CONTENT: 12 files *.* blocks These empirical models describe the differential or integral, omnidirectional fluxes of electrons (AE-8) and protons -(AP-8) in the inner and outer radiation belts (electrons: L=1.1 -to 11, protons: L=1.1 to 7) for two epochs representing solar -maximum (1970) and minimum (1964) conditions. The energy spectrum -ranges from 0.1 to 400 MeV for the protons and from 0.04 to 7 MeV -for the electrons. AE-8 and AP-8 are the most recent ones in a -series of models established by J. Vette and his colleges at NSSDC -starting in the early sixties. The models are based on almost all +(AP-8) in the inner and outer radiation belts (electrons: L=1.1 +to 11, protons: L=1.1 to 7) for two epochs representing solar +maximum (1970) and minimum (1964) conditions. The energy spectrum +ranges from 0.1 to 400 MeV for the protons and from 0.04 to 7 MeV +for the electrons. AE-8 and AP-8 are the most recent ones in a +series of models established by J. Vette and his colleges at NSSDC +starting in the early sixties. The models are based on almost all available satellite data. It is IMPORTANT that the models maps for solar maximum are used with a magnetic field model for epoch=1970 and for solar minimum for epoch=1964. For each epoch and particle the model consists of a three- -dimensional table of (logarithm of) particle fluxes in energy, L-value, -and B/B0 (magnetic field strength normalized to the equator). The program -MODEL finds the particle fluxes for given energy, L-value and B/B0 by -interpolating in energy (subroutine TRARA1) and in L * B/B0 space (TRARA2). +dimensional table of (logarithm of) particle fluxes in energy, L-value, +and B/B0 (magnetic field strength normalized to the equator). The program +MODEL finds the particle fluxes for given energy, L-value and B/B0 by +interpolating in energy (subroutine TRARA1) and in L * B/B0 space (TRARA2). The program RADBELT produces tables of integral or differential fluxes for different energies varying with L or B/B0. The coefficient files are provided in VAX/VMS binary (*.bin) and ASCII (*.asc) format. For all systems other than VMS the use of the ASCII -files is recommended. If using the ASCII coefficient one needs to slightly +files is recommended. If using the ASCII coefficient one needs to slightly modify the RADBELT.FOR program as described in a comment statement in -RADBELT (this comments are found after the OPEN statement for the coefficient +RADBELT (this comments are found after the OPEN statement for the coefficient file). In March 1995 the earlier used compressed model maps AP8MIC and AP8MAC -were replaced with the full maps AP8MIN/MAX with the help of D. Heynderickx -(BIRA, Brussel, Belgium) and A. Beliaev (INP/MSU, Moscow, Russia). Heynderickx -and Beliaev (1995) had found and corrected a small error in the AP8MIN map; +were replaced with the full maps AP8MIN/MAX with the help of D. Heynderickx +(BIRA, Brussel, Belgium) and A. Beliaev (INP/MSU, Moscow, Russia). Heynderickx +and Beliaev (1995) had found and corrected a small error in the AP8MIN map; two lines had been exchanged. ### AVAILABILITY: @@ -71,15 +112,6 @@ two lines had been exchanged. (1) FORTRAN source code from this directory. (2) Model parameters can be computed and plotted online at http://nssdc.gsfc.nasa.gov/space/model/ . - -### See also - -* [NASA ModelWebArchive](https://git.smce.nasa.gov/ccmc-share/modelwebarchive) -* [An Astropy-friendly wrapper for the AE-8/AP-8 Van Allen belt model](https://github.com/nasa/radbelt) -* [pyIGRF](https://github.com/rilma/pyIGRF) -* https://github.com/lanl/RAM-SCB/blob/master/srcExternal/igrf.f -* https://github.com/space-physics/igrf/blob/main/src/igrf/fortran/igrf13.f - ### REFERENCES: G.W. Singley, and J.I. Vette, The AE-4 Model of the Outer Radiation @@ -106,16 +138,16 @@ M.T. Teague, N.J. Schofield, K.W. Chan, and J.I. Vette, A Study of Inner Zone Electron Data and their Comparison with Trapped Radiation Models, NSSDC/WDC-A-R&S 79-06, 1979. -J.I. Vette, The AE-8 Trapped Electron Model Environment, +J.I. Vette, The AE-8 Trapped Electron Model Environment, NSSDC/WDC-A-R&S 91-24, 1991. -J.I. Vette, The NASA/National Space Science Data Center Trapped - Radiation Environment Model Program (1964-1991), NSSDC/WDC-A-R&S +J.I. Vette, The NASA/National Space Science Data Center Trapped + Radiation Environment Model Program (1964-1991), NSSDC/WDC-A-R&S 91-29, 1991. (most of these references are available from NSSDC) D. Heynderickx and A. Beliaev, J. Spacecraft and Rockets 32, 190-192, 1995. -National Space Science Data Center Data set PT-11B Mar 1996 +National Space Science Data Center Data set PT-11B Mar 1996 ========================================================================= From 445edb9f17467cc430ac38ba8362d9f73c3fac73 Mon Sep 17 00:00:00 2001 From: Jacob Williams Date: Tue, 6 Feb 2024 23:53:34 -0600 Subject: [PATCH 13/13] added codecov file --- codecov.yml | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 codecov.yml diff --git a/codecov.yml b/codecov.yml new file mode 100644 index 0000000..7e50f22 --- /dev/null +++ b/codecov.yml @@ -0,0 +1,13 @@ +comment: + layout: header, changes, diff, sunburst +coverage: + ignore: + - test + - doc + status: + patch: + default: + target: 10% + project: + default: + target: 10%