Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/1_cfc1112.atm
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/1_cfc1112.atm (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/1_cfc1112.atm (revision 8155)
@@ -0,0 +1,84 @@
+ % Atmospheric lifetimes are 44.0 for CFC-11
+ % and 125.0 for CFC-12
+ % rel= 0
+ % <-Northern Data-> <-Southern Data->
+ % Year CFC-11 CFC-12 CFC-11 CFC-12
+ % (ppt) (ppt) (ppt) (ppt)
+ 1931.50 0.00 0.00 0.00 0.00
+ 1932.50 0.00 0.01 0.00 0.01
+ 1933.50 0.00 0.02 0.00 0.01
+ 1934.50 0.00 0.03 0.00 0.02
+ 1935.50 0.00 0.04 0.00 0.03
+ 1936.50 0.00 0.07 0.00 0.04
+ 1937.50 0.00 0.11 0.00 0.07
+ 1938.50 0.00 0.17 0.00 0.11
+ 1939.50 0.01 0.25 0.00 0.17
+ 1940.50 0.01 0.37 0.01 0.25
+ 1941.50 0.02 0.53 0.01 0.36
+ 1942.50 0.02 0.72 0.02 0.51
+ 1943.50 0.03 0.94 0.02 0.69
+ 1944.50 0.04 1.25 0.03 0.91
+ 1945.50 0.05 1.65 0.04 1.21
+ 1946.50 0.08 2.33 0.05 1.64
+ 1947.50 0.14 3.42 0.08 2.33
+ 1948.50 0.24 4.73 0.14 3.32
+ 1949.50 0.42 6.10 0.25 4.48
+ 1950.50 0.67 7.58 0.42 5.77
+ 1951.50 1.02 9.23 0.66 7.19
+ 1952.50 1.53 10.94 1.01 8.72
+ 1953.50 2.21 12.82 1.49 10.37
+ 1954.50 3.07 14.97 2.13 12.20
+ 1955.50 4.11 17.40 2.93 14.25
+ 1956.50 5.39 20.22 3.92 16.59
+ 1957.50 6.84 23.45 5.11 19.28
+ 1958.50 8.19 26.86 6.39 22.28
+ 1959.50 9.47 30.58 7.63 25.52
+ 1960.50 11.13 35.03 8.96 29.18
+ 1961.50 13.38 40.12 10.63 33.42
+ 1962.50 16.23 45.89 12.78 38.25
+ 1963.50 19.72 52.66 15.47 43.80
+ 1964.50 23.87 60.57 18.75 50.28
+ 1965.50 28.57 69.53 22.61 57.76
+ 1966.50 33.78 79.46 26.99 66.21
+ 1967.50 39.63 90.60 31.91 75.67
+ 1968.50 46.27 103.16 37.46 86.31
+ 1969.50 53.96 117.17 43.80 98.25
+ 1970.50 62.75 132.52 51.07 111.52
+ 1971.50 72.36 149.00 59.27 126.02
+ 1972.50 83.04 166.85 68.34 141.70
+ 1973.50 95.27 186.59 78.54 158.82
+ 1974.50 108.81 208.14 90.04 177.62
+ 1975.50 121.86 229.37 102.29 197.54
+ 1976.50 134.47 249.51 114.40 217.31
+ 1977.50 146.47 268.67 126.28 236.49
+ 1978.50 157.18 286.35 137.45 254.72
+ 1979.50 166.67 303.74 147.60 272.00
+ 1980.50 175.11 320.96 158.08 290.34
+ 1981.50 182.81 337.33 166.54 306.90
+ 1982.50 189.88 352.01 174.69 323.74
+ 1983.50 197.72 367.69 183.03 341.15
+ 1984.50 206.34 383.86 190.95 357.80
+ 1985.50 216.12 401.25 200.50 376.45
+ 1986.50 227.48 420.96 209.82 394.00
+ 1987.50 239.67 441.49 220.60 412.82
+ 1988.50 251.05 463.22 231.46 433.46
+ 1989.50 257.28 481.80 240.38 452.97
+ 1990.50 263.65 493.96 249.23 470.55
+ 1991.50 266.33 504.64 254.53 484.07
+ 1992.50 266.00 512.87 258.80 495.65
+ 1993.50 267.58 520.12 260.56 504.49
+ 1994.50 267.24 526.58 261.73 512.31
+ 1995.50 266.38 531.59 261.29 518.39
+ 1996.50 265.25 534.81 261.08 523.50
+ 1997.50 263.84 537.67 260.16 528.18
+ 1998.50 262.24 999.99 258.96 999.99
+ 1999.50 260.72 999.99 257.75 999.99
+ 2000.50 259.34 999.99 255.69 999.99
+ 2001.50 257.13 999.99 253.54 999.99
+ 2002.50 254.89 999.99 252.93 999.99
+ 2003.50 251.89 999.99 250.62 999.99
+ 2004.50 250.67 999.99 249.52 999.99
+ 2005.50 249.49 999.99 247.45 999.99
+ 2006.50 248.31 999.99 245.38 999.99
+ 2007.50 247.13 999.99 243.31 999.99
+ 2008.50 245.95 999.99 241.24 999.99
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/XIOS2/field_def_bgc.xml
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/XIOS2/field_def_bgc.xml (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/XIOS2/field_def_bgc.xml (revision 8155)
@@ -0,0 +1,809 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+ DIC * e3t
+
+ Alkalini * e3t
+
+ O2 * e3t
+
+ CaCO3 * e3t
+
+ PO4 * e3t
+
+ POC * e3t
+
+ Si * e3t
+
+ PHY * e3t
+
+ ZOO * e3t
+
+ DOC * e3t
+
+ PHY2 * e3t
+
+ ZOO2 * e3t
+
+ DSi * e3t
+
+ Fer * e3t
+
+ BFe * e3t
+
+ GOC * e3t
+
+ SFe * e3t
+
+ DFe * e3t
+
+ GSi * e3t
+
+ NFe * e3t
+
+ NCHL * e3t
+
+ DCHL * e3t
+
+ NO3 * e3t
+
+ NH4 * e3t
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ Num * e3t
+
+
+
+ DET * e3t
+
+ DOM * e3t
+
+
+
+ CFC11 * e3t
+
+
+ C14B * e3t
+
+
+ Age * e3t
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/XIOS2/field_def_bgc_CMIP6.xml
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/XIOS2/field_def_bgc_CMIP6.xml (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/XIOS2/field_def_bgc_CMIP6.xml (revision 8155)
@@ -0,0 +1,778 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+ DIC * e3t
+
+ Alkalini * e3t
+
+ O2 * e3t
+
+ CaCO3 * e3t
+
+ PO4 * e3t
+
+ POC * e3t
+
+ Si * e3t
+
+ PHY * e3t
+
+ ZOO * e3t
+
+ DOC * e3t
+
+ PHY2 * e3t
+
+ ZOO2 * e3t
+
+ DSi * e3t
+
+ Fer * e3t
+
+ BFe * e3t
+
+ GOC * e3t
+
+ SFe * e3t
+
+ DFe * e3t
+
+ GSi * e3t
+
+ NFe * e3t
+
+ NCHL * e3t
+
+ DCHL * e3t
+
+ NO3 * e3t
+
+ NH4 * e3t
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ Num * e3t
+
+
+
+ DET * e3t
+
+ DOM * e3t
+
+
+
+ CFC11 * e3t
+
+
+ C14B * e3t
+
+
+ Age * e3t
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/XIOS2/iodef_medusa_et_al.xml
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/XIOS2/iodef_medusa_et_al.xml (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/XIOS2/iodef_medusa_et_al.xml (revision 8155)
@@ -0,0 +1,310 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ @toce_e3t / @e3t
+ @toce2_e3t / @e3t
+ @soce_e3t / @e3t
+ @soce2_e3t / @e3t
+ @ttrd_totad_e3t * 1026.0 * 3991.86795711963
+ @ttrd_iso_e3t * 1026.0 * 3991.86795711963
+ @ttrd_zdfp_e3t * 1026.0 * 3991.86795711963
+ @ttrd_evd_e3t / @e3t
+ @ttrd_qns_e3t / @e3t_surf
+ @ttrd_qsr_e3t * 1026.0 * 3991.86795711963
+ @ttrd_bbl_e3t / @e3t
+ @ttrd_tot_e3t * 1026.0 * 3991.86795711963
+ @strd_totad_e3t * 1026.0 * 0.001
+ @strd_iso_e3t * 1026.0 * 0.001
+ @strd_zdfp_e3t * 1026.0 * 0.001
+ @strd_evd_e3t / @e3t
+ @strd_tot_e3t * 1026.0 * 0.001
+ @strd_bbl_e3t / @e3t
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ @uoce_e3u / @e3u
+ @uoce2_e3u / @e3u
+ @ut_e3u / @e3u
+ @us_e3u / @e3u
+
+
+
+
+
+ @voce_e3v / @e3v
+ @voce2_e3v / @e3v
+ @vt_e3v / @e3v
+ @vs_e3v / @e3v
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ 0
+ false
+ true
+ toyoce
+
+
+
+
+
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/cfc1112sf6.atm
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/cfc1112sf6.atm (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/cfc1112sf6.atm (revision 8155)
@@ -0,0 +1,92 @@
+% Atmospheric lifetimes are 44 for CFC-11
+% and 125 for CFC-12
+% and 1278 for SF6 (Kovacs et al., 2017)
+% rel= 0
+% <-Northern Data-> <-Southern Data->
+% Year CFC-11 CFC-12 SF6 CFC-11 CFC-12 SF6
+% (ppt) (ppt) (ppt) (ppt) (ppt) (ppt)
+1931.5 0.00 0.00 0.00 0.00 0.00 0.00
+1932.5 0.00 0.00 0.00 0.00 0.00 0.00
+1933.5 0.00 0.00 0.00 0.00 0.00 0.00
+1934.5 0.00 0.00 0.00 0.00 0.00 0.00
+1935.5 0.00 0.00 0.00 0.00 0.00 0.00
+1936.5 0.00 0.10 0.00 0.00 0.00 0.00
+1937.5 0.00 0.10 0.00 0.00 0.10 0.00
+1938.5 0.00 0.20 0.00 0.00 0.10 0.00
+1939.5 0.00 0.30 0.00 0.00 0.20 0.00
+1940.5 0.00 0.40 0.00 0.00 0.30 0.00
+1941.5 0.00 0.50 0.00 0.00 0.40 0.00
+1942.5 0.00 0.70 0.00 0.00 0.50 0.00
+1943.5 0.00 0.90 0.00 0.00 0.70 0.00
+1944.5 0.00 1.20 0.00 0.00 0.90 0.00
+1945.5 0.10 1.70 0.00 0.00 1.20 0.00
+1946.5 0.10 2.30 0.00 0.10 1.70 0.00
+1947.5 0.10 3.40 0.00 0.10 2.40 0.00
+1948.5 0.20 4.80 0.00 0.10 3.40 0.00
+1949.5 0.40 6.10 0.00 0.20 4.70 0.00
+1950.5 0.70 7.60 0.00 0.40 6.00 0.00
+1951.5 1.01 9.20 0.00 0.70 7.40 0.00
+1952.5 1.51 11.00 0.00 1.01 9.00 0.00
+1953.5 2.21 12.80 0.04 1.51 10.70 0.04
+1954.5 3.02 15.00 0.04 2.21 12.60 0.04
+1955.5 4.12 17.40 0.04 3.02 14.70 0.04
+1956.5 5.33 20.20 0.04 4.02 17.10 0.04
+1957.5 6.83 23.40 0.05 5.23 19.90 0.04
+1958.5 8.14 26.80 0.05 6.53 23.00 0.04
+1959.5 9.45 30.50 0.05 7.84 26.30 0.05
+1960.5 11.06 35.00 0.05 9.15 30.10 0.05
+1961.5 13.27 40.00 0.06 10.85 34.40 0.06
+1962.5 16.18 45.80 0.07 13.07 39.40 0.06
+1963.5 19.60 52.50 0.08 15.78 45.10 0.07
+1964.5 23.72 60.40 0.09 19.20 51.80 0.08
+1965.5 28.44 69.30 0.11 23.12 59.50 0.10
+1966.5 33.67 79.20 0.13 27.64 68.20 0.12
+1967.5 39.40 90.30 0.15 32.66 77.90 0.14
+1968.5 46.03 102.80 0.18 38.29 88.80 0.17
+1969.5 53.77 116.80 0.21 44.82 101.10 0.19
+1970.5 62.41 132.00 0.23 52.26 114.70 0.22
+1971.5 72.06 148.40 0.26 60.70 129.60 0.24
+1972.5 82.71 166.10 0.30 69.95 145.70 0.28
+1973.5 94.87 185.80 0.34 80.40 163.30 0.31
+1974.5 108.34 207.10 0.38 92.16 182.50 0.35
+1975.5 121.41 228.20 0.44 104.72 202.90 0.40
+1976.5 133.97 248.10 0.50 117.09 223.20 0.46
+1977.5 145.93 266.90 0.58 129.35 242.70 0.53
+1978.5 156.58 284.30 0.66 140.80 261.20 0.61
+1979.5 168.34 306.10 0.76 148.74 273.50 0.70
+1980.5 176.68 323.20 0.88 159.30 292.30 0.81
+1981.5 184.32 339.60 1.00 167.84 308.80 0.93
+1982.5 191.46 353.40 1.13 176.08 325.50 1.04
+1983.5 199.30 369.00 1.27 184.52 342.60 1.17
+1984.5 208.04 385.70 1.40 192.46 359.40 1.29
+1985.5 217.99 403.40 1.55 202.01 378.20 1.43
+1986.5 229.35 424.30 1.71 211.36 396.50 1.58
+1987.5 241.61 444.00 1.88 222.21 416.30 1.73
+1988.5 252.86 465.40 2.05 233.27 435.80 1.89
+1989.5 259.30 483.60 2.22 242.11 454.40 2.05
+1990.5 265.83 497.70 2.41 251.06 472.70 2.22
+1991.5 268.24 506.00 2.62 256.68 487.30 2.42
+1992.5 268.14 516.30 2.85 260.80 498.30 2.63
+1993.5 269.55 523.20 3.09 262.51 507.00 2.84
+1994.5 269.65 528.50 3.33 263.72 514.80 3.07
+1995.5 268.34 533.40 3.58 263.22 521.00 3.30
+1996.5 266.93 537.30 3.86 262.91 526.50 3.55
+1997.5 265.73 540.10 4.07 262.01 530.80 3.81
+1998.5 264.52 542.90 4.25 261.01 534.30 4.01
+1999.5 263.12 544.40 4.48 259.90 537.20 4.25
+2000.5 261.71 545.90 4.68 258.29 539.00 4.46
+2001.5 260.00 546.50 4.90 256.98 540.60 4.65
+2002.5 258.19 546.70 5.14 255.08 541.30 4.88
+2003.5 256.18 546.70 5.37 253.27 541.60 5.07
+2004.5 253.97 545.70 5.58 251.36 541.50 5.30
+2005.5 251.96 544.90 5.80 249.15 540.70 5.51
+2006.5 249.55 543.10 6.04 247.34 539.80 5.75
+2007.5 247.54 541.10 6.33 245.03 538.10 6.03
+2008.5 245.63 538.60 6.62 243.12 536.20 6.29
+2009.5 243.61 536.12 6.89 241.05 533.47 6.58
+2010.5 241.31 533.26 7.21 239.15 531.03 6.87
+2011.5 239.40 530.60 7.46 236.84 528.53 7.17
+2012.5 236.89 527.20 7.73 234.77 526.00 7.43
+2013.5 235.57 525.22 8.09 232.88 523.25 7.73
+2014.5 234.97 522.97 8.40 231.49 521.00 8.11
+2015.5 234.36 520.71 8.72 230.09 518.74 8.50
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/field_def_bgc.xml
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/field_def_bgc.xml (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/field_def_bgc.xml (revision 8155)
@@ -0,0 +1,865 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+ DIC * e3t
+
+ Alkalini * e3t
+
+ O2 * e3t
+
+ CaCO3 * e3t
+
+ PO4 * e3t
+
+ POC * e3t
+
+ Si * e3t
+
+ PHY * e3t
+
+ ZOO * e3t
+
+ DOC * e3t
+
+ PHY2 * e3t
+
+ ZOO2 * e3t
+
+ DSi * e3t
+
+ Fer * e3t
+
+ BFe * e3t
+
+ GOC * e3t
+
+ SFe * e3t
+
+ DFe * e3t
+
+ GSi * e3t
+
+ NFe * e3t
+
+ NCHL * e3t
+
+ DCHL * e3t
+
+ NO3 * e3t
+
+ NH4 * e3t
+
+
+
+ CHN * e3t
+
+ CHD * e3t
+
+ PHN * e3t
+
+ PHD * e3t
+
+ ZMI * e3t
+
+ ZME * e3t
+
+ DIN * e3t
+
+ SIL * e3t
+
+ FER * e3t
+
+ DET * e3t
+
+ PDS * e3t
+
+ DTC * e3t
+
+ DiC * e3t
+
+ ALK * e3t
+
+ OXY * e3t
+
+
+
+
+
+
+ Num * e3t
+
+
+
+ DET * e3t
+
+ DOM * e3t
+
+
+
+ CFC11 * e3t
+
+
+ CFC12 * e3t
+
+
+ SF6 * e3t
+
+
+ C14B * e3t
+
+
+ Age * e3t
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/field_def_dyn.xml
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/field_def_dyn.xml (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/field_def_dyn.xml (revision 8155)
@@ -0,0 +1,1208 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ toce * e3t
+ toce * toce * e3t
+
+ soce * e3t
+ soce * soce * e3t
+
+
+ toce_e3t_vsum/e3t_vsum
+
+
+
+
+ toce_e3t_vsum300/e3t_vsum300
+
+
+ sst * sst
+
+
+
+
+
+
+
+
+ sss * sss
+
+
+
+
+
+
+
+
+ ssh * ssh
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ topthdep - pycndep
+
+
+
+
+
+
+
+
+
+ sshdyn * sshdyn
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ uoce * e3u
+ uoce * uoce * e3u
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ voce * e3v
+ voce * voce * e3v
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ ut * e3u
+
+ us * e3u
+
+ urhop * e3u
+
+ vt * e3v
+
+ vs * e3v
+
+ vrhop * e3v
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ sqrt( ttrd_xad^2 + ttrd_yad^2 + ttrd_zad^2 )
+ sqrt( strd_xad^2 + strd_yad^2 + strd_zad^2 )
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ ttrd_iso_z1 + ttrd_zdf - ttrd_zdfp
+ strd_iso_z1 + strd_zdf - strd_zdfp
+ ttrd_ldf + ttrd_zdf - ttrd_zdfp
+ strd_ldf + strd_zdf - strd_zdfp
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ ttrd_xad * e3t
+ strd_xad * e3t
+ ttrd_yad * e3t
+ strd_yad * e3t
+ ttrd_zad * e3t
+ strd_zad * e3t
+ ttrd_ad * e3t
+ strd_ad * e3t
+ ttrd_totad * e3t
+ strd_totad * e3t
+ ttrd_ldf * e3t
+ strd_ldf * e3t
+ ttrd_zdf * e3t
+ strd_zdf * e3t
+ ttrd_evd * e3t
+ strd_evd * e3t
+
+
+ ttrd_iso_x * e3t
+ strd_iso_x * e3t
+ ttrd_iso_y * e3t
+ strd_iso_y * e3t
+ ttrd_iso_z * e3t
+ strd_iso_z * e3t
+ ttrd_iso * e3t
+ strd_iso * e3t
+ ttrd_zdfp * e3t
+ strd_zdfp * e3t
+
+
+ ttrd_dmp * e3t
+ strd_dmp * e3t
+ ttrd_bbl * e3t
+ strd_bbl * e3t
+ ttrd_npc * e3t
+ strd_npc * e3t
+ ttrd_qns * e3t_surf
+ strd_cdt * e3t_surf
+ ttrd_qsr * e3t
+ ttrd_bbc * e3t
+ ttrd_atf * e3t
+ strd_atf * e3t
+ ttrd_tot * e3t
+ strd_tot * e3t
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ ketrd_ldf*e3t
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ petrd_zdfp * e3t
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ @toce_e3t / @e3t
+ @soce_e3t / @e3t
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ @toce_e3t / @e3t
+ @toce2_e3t / @e3t
+ @soce_e3t / @e3t
+ @soce2_e3t / @e3t
+ @ttrd_totad_e3t * 1026.0 * 3991.86795711963
+ @ttrd_iso_e3t * 1026.0 * 3991.86795711963
+ @ttrd_zdfp_e3t * 1026.0 * 3991.86795711963
+ @ttrd_evd_e3t / @e3t
+ @ttrd_qns_e3t / @e3t_surf
+ @ttrd_qsr_e3t * 1026.0 * 3991.86795711963
+ @ttrd_bbl_e3t / @e3t
+ @ttrd_tot_e3t * 1026.0 * 3991.86795711963
+ @strd_totad_e3t * 1026.0 * 0.001
+ @strd_iso_e3t * 1026.0 * 0.001
+ @strd_zdfp_e3t * 1026.0 * 0.001
+ @strd_evd_e3t / @e3t
+ @strd_tot_e3t * 1026.0 * 0.001
+ @strd_bbl_e3t / @e3t
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ @uoce_e3u / @e3u
+
+
+
+
+
+ @uoce_e3u / @e3u
+ @uoce2_e3u / @e3u
+ @ut_e3u / @e3u
+ @us_e3u / @e3u
+
+
+
+
+
+
+
+
+ @voce_e3v / @e3v
+
+
+
+
+
+ @voce_e3v / @e3v
+ @voce2_e3v / @e3v
+ @vt_e3v / @e3v
+ @vs_e3v / @e3v
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/iodef_medusa_et_al.xml
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/iodef_medusa_et_al.xml (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/iodef_medusa_et_al.xml (revision 8155)
@@ -0,0 +1,448 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ @toce_e3t / @e3t
+ @toce2_e3t / @e3t
+ @soce_e3t / @e3t
+ @soce2_e3t / @e3t
+ @ttrd_totad_e3t * 1026.0 * 3991.86795711963
+ @ttrd_iso_e3t * 1026.0 * 3991.86795711963
+ @ttrd_zdfp_e3t * 1026.0 * 3991.86795711963
+ @ttrd_evd_e3t / @e3t
+ @ttrd_qns_e3t / @e3t_surf
+ @ttrd_qsr_e3t * 1026.0 * 3991.86795711963
+ @ttrd_bbl_e3t / @e3t
+ @ttrd_tot_e3t * 1026.0 * 3991.86795711963
+ @strd_totad_e3t * 1026.0 * 0.001
+ @strd_iso_e3t * 1026.0 * 0.001
+ @strd_zdfp_e3t * 1026.0 * 0.001
+ @strd_evd_e3t / @e3t
+ @strd_tot_e3t * 1026.0 * 0.001
+ @strd_bbl_e3t / @e3t
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ @uoce_e3u / @e3u
+ @uoce2_e3u / @e3u
+ @ut_e3u / @e3u
+ @us_e3u / @e3u
+
+
+
+
+
+ @voce_e3v / @e3v
+ @voce2_e3v / @e3v
+ @vt_e3v / @e3v
+ @vs_e3v / @e3v
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ @toce_e3t / @e3t
+ @toce2_e3t / @e3t
+ @soce_e3t / @e3t
+ @soce2_e3t / @e3t
+ @ttrd_totad_e3t * 1026.0 * 3991.86795711963
+ @ttrd_iso_e3t * 1026.0 * 3991.86795711963
+ @ttrd_zdfp_e3t * 1026.0 * 3991.86795711963
+ @ttrd_evd_e3t / @e3t
+ @ttrd_qns_e3t / @e3t_surf
+ @ttrd_qsr_e3t * 1026.0 * 3991.86795711963
+ @ttrd_bbl_e3t / @e3t
+ @ttrd_tot_e3t * 1026.0 * 3991.86795711963
+ @strd_totad_e3t * 1026.0 * 0.001
+ @strd_iso_e3t * 1026.0 * 0.001
+ @strd_zdfp_e3t * 1026.0 * 0.001
+ @strd_evd_e3t / @e3t
+ @strd_tot_e3t * 1026.0 * 0.001
+ @strd_bbl_e3t / @e3t
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ @uoce_e3u / @e3u
+ @uoce2_e3u / @e3u
+ @ut_e3u / @e3u
+ @us_e3u / @e3u
+
+
+
+
+
+ @voce_e3v / @e3v
+ @voce2_e3v / @e3v
+ @vt_e3v / @e3v
+ @vs_e3v / @e3v
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ 0
+ false
+ true
+ toyoce
+
+
+
+
+
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_age_ref
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_age_ref (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_age_ref (revision 8155)
@@ -0,0 +1,9 @@
+!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!! AGE : 1 - dates (namage)
+!! namelists
+!'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
+&namage ! dates
+!,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
+ rn_age_depth = 10 ! depth over which age tracer reset to zero
+ rn_age_kill_rate = -0.000138888 ! = -1/7200 recip of relaxation timescale (s) for age tracer shallower than age_depth
+/
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_cfc_ref
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_cfc_ref (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_cfc_ref (revision 8155)
@@ -7,5 +7,7 @@
!,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
ndate_beg = 300101 ! datedeb1
- nyear_res = 1932 ! iannee1
+ nyear_res = 1600 ! iannee1
+ simu_type = 1 ! kind of Simulation: 1 = SPIN-UP (90y-cycle)
+!! !! 2 = Hindcast/proj (100y cycle)
/
!'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_cfc_v1_ref
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_cfc_v1_ref (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_cfc_v1_ref (revision 8155)
@@ -0,0 +1,20 @@
+!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!! CFC : 1 - dates (namcfcdate)
+!! namelists
+!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
+&namcfcdate ! dates
+!,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
+ ndate_beg = 300101 ! datedeb1
+ nyear_res = 1600 ! iannee1
+ simu_type = 1 ! kind of Simulation: 1 = SPIN-UP (90y-cycle)
+!! !! 2 = Hindcast/proj (100y cycle)
+/
+!'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
+&namcfcdia ! additional 2D/3D tracers diagnostics
+!,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
+! ! name ! title of the field ! units !
+! ! ! ! !
+ cfcdia2d(1) = 'qtr_c11 ' , 'Air-sea flux of CFC-11 ', 'mol/m2/s '
+ cfcdia2d(2) = 'qint_c11' , 'Cumulative air-sea flux of CFC-11 ', 'mol/m2 '
+/
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_idtra_ref
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_idtra_ref (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_idtra_ref (revision 8155)
@@ -0,0 +1,43 @@
+!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!
+! idealize Tracer namelist : NEMO idealize traceur model option and parameter input
+! -------------
+!
+!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
+! namidtra parameter for 1/2 decay time
+!,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
+!
+!! idealize tracer 1/2 decay time
+!! tmp_decay : 1/2 decay time
+!!
+!! idealize tracer names (to be added if needed)
+!!
+&namidtra
+!
+!! idealize tracer 1/2 decay time
+ tmp_decay = 10 !! years
+!! idealize tracer names
+!!###############################################
+!! names are defined in the top namelist (namtrc)
+!!
+!!###############################################
+/
+!=================================================
+! nammeddia Passive tracers additional diagnostics
+!=================================================
+!
+! ctrc2d : 2d output field name
+! ctrc2u : 2d output field unit
+! ctrc2l : 2d output field long name
+!
+! nwriteadd: frequency of additional arrays outputs(namelist)
+!&nammeddia
+!!##########################################################
+!! No aditional diagnostics associated to idealize tracers.
+!! If one want to add additional diag,
+!! can be done here, following the example just below
+!!##########################################################
+! meddia2d(1) = 'INVTN' , 'Column N inventory' , 'mmolN/m2'
+! meddia2d(2) = 'INVTSI' , 'Column Si inventory' , 'mmolSi/m2'
+!/
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_medusa_ref
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_medusa_ref (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_medusa_ref (revision 8155)
@@ -0,0 +1,372 @@
+!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!
+! BIO namelist : MEDUSA biological model option and parameter input
+! -------------
+!
+!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
+! natbio Shared parameters for dynamics/advection/thermo
+!,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
+!
+!! Primary production and chl related quantities
+!! xxi : conversion factor from gC to mmolN
+!! xaln : Chl-a specific initial slope of P-I curve for non-diatoms
+!! xald : Chl-a specific initial slope of P-I curve for diatoms
+!! jphy : phytoplankton T-dependent growth switch
+!! xvpn : maximum growth rate for non-diatoms
+!! xvpd : maximum growth rate for diatoms
+!! xthetam : maximum Chl to C ratio for non-diatoms
+!! xthetamd : maximum Chl to C ratio for diatoms
+!!
+!! Diatom silicon parameters
+!! xsin0 : minimum diatom Si:N ratio
+!! xnsi0 : minimum diatom N:Si ratio
+!! xuif : hypothetical growth ratio at infinite Si:N ratio
+!!
+!! Nutrient limitation
+!! jliebig : Liebig nutrient uptake switch
+!! xnln : half-sat constant for DIN uptake by non-diatoms
+!! xnld : half-sat constant for DIN uptake by diatoms
+!! xsl : half-sat constant for Si uptake by diatoms
+!! xfld : half-sat constant for Fe uptake by diatoms
+!! xfln : half-sat constant for Fe uptake by non-datoms
+!!
+!! Grazing
+!! xgmi : microzoo maximum growth rate
+!! xgme : mesozoo maximum growth rate
+!! xkmi : microzoo grazing half-sat parameter
+!! xkme : mesozoo grazing half-sat parameter
+!! xphi : micro/mesozoo grazing inefficiency
+!! xbetan : micro/mesozoo N assimilation efficiency
+!! xbetac : micro/mesozoo C assimilation efficiency
+!! xkc : micro/mesozoo net C growth efficiency
+!! xpmipn : grazing preference of microzoo for non-diatoms
+!! xpmid : grazing preference of microzoo for diatoms
+!! xpmepn : grazing preference of mesozoo for non-diatoms
+!! xpmepd : grazing preference of mesozoo for diatoms
+!! xpmezmi : grazing preference of mesozoo for microzoo
+!! xpmed : grazing preference of mesozoo for detritus
+!!
+!! Metabolic losses
+!! xmetapn : non-diatom metabolic loss rate
+!! xmetapd : diatom metabolic loss rate
+!! xmetazmi : microzoo metabolic loss rate
+!! xmetazme : mesozoo metabolic loss rate
+!!
+!! Mortality losses
+!! jmpn : non-diatom mortality functional form
+!! xmpn : non-diatom mortality rate
+!! xkphn : non-diatom mortality half-sat constant
+!! jmpd : diatom mortality functional form
+!! xmpd : diatom mortality rate
+!! xkphd : diatom mortality half-sat constant
+!! jmzmi : microzoo mortality functional form
+!! xmzmi : microzoo mortality rate
+!! xkzmi : microzoo mortality half-sat constant
+!! jmzme : mesozoo mortality functional form
+!! xmzme : mesozoo mortality rate
+!! xkzme : mesozoo mortality half-sat constant
+!!
+!! Remineralisation
+!! jmd : detritus T-dependent remineralisation switch
+!! jsfd : accelerate seafloor detritus remin. switch
+!! xmd : detrital nitrogen remineralisation rate
+!! xmdc : detrital carbon remineralisation rate
+!!
+!! Stochiometric ratios
+!! xthetapn : non-diatom C:N ratio
+!! xthetapd : diatom C:N ratio
+!! xthetazmi : microzoo C:N ratio
+!! xthetazme : mesozoo C:N ratio
+!! xthetad : detritus C:N ratio (FOR IMPLICIT DTC ONLY)
+!! xrfn : phytoplankton Fe:N ratio
+!! xrsn : phytoplankton Si:N ratio (LEGACY; NOT USED)
+!!
+!! Iron parameters
+!! jiron : iron scavenging submodel switch
+!! xfe_mass : iron atomic mass
+!! xfe_sol : aeolian iron solubility
+!! xfe_sed : sediment iron input
+!! xLgT : total ligand concentration (umol/m3)
+!! xk_FeL : dissociation constant for (Fe + L)
+!! xk_sc_Fe : scavenging rate of "free" iron
+!!
+!! Fast-sinking detritus parameters
+!! jmartin : fast detritus remineralisation switch
+!! jfdfate : fate of fast detritus at seafloor switch
+!! jrratio : rain ratio switch
+!! jocalccd : CCD switch
+!! xridg_r0 : Ridgwell rain ratio coefficient
+!! xfdfrac1 : fast-sinking fraction of diatom nat. mort. losses
+!! xfdfrac2 : fast-sinking fraction of mesozooplankton mort. losses
+!! xfdfrac3 : fast-sinking fraction of diatom silicon grazing losses
+!! xcaco3a : polar (high latitude) CaCO3 fraction
+!! xcaco3b : equatorial (low latitude) CaCO3 fraction
+!! xmassc : organic C mass:mole ratio, C106 H175 O40 N16 P1
+!! xmassca : calcium carbonate mass:mole ratio, CaCO3
+!! xmasssi : biogenic silicon mass:mole ratio, (H2SiO3)n
+!! xprotca : calcium carbonate protection ratio
+!! xprotsi : biogenic silicon protection ratio
+!! xfastc : organic C remineralisation length scale
+!! xfastca : calcium carbonate dissolution length scale
+!! xfastsi : biogenic silicon dissolution length scale
+!!
+!! Benthos parameters
+!! jorgben : does organic detritus go to the benthos?
+!! jinorgben : does inorganic detritus go to the benthos?
+!! xsedn : organic nitrogen sediment remineralisation rate
+!! xsedfe : organic iron sediment remineralisation rate
+!! xsedsi : inorganic silicon sediment dissolution rate
+!! xsedc : organic carbon sediment remineralisation rate
+!! xsedca : inorganic carbon sediment dissolution rate
+!! xburial : burial fraction of sediment material
+!!
+!! River parameters
+!! jriver_n : riverine N input?
+!! jriver_si : riverine Si input?
+!! jriver_c : riverine C input?
+!! jriver_alk : riverine alkalinity input?
+!! jriver_dep : depth of riverine input?
+!!
+!! Miscellaneous
+!! xsdiss : diatom frustule dissolution rate
+!!
+!! Gravitational sinking
+!! vsed : detritus gravitational sinking rate
+!! xhr : coeff for Martin's remineralisation profile
+!!
+!! Additional parameters
+!! jpkb : vertical layer for diagnostic of the vertical flux
+!!
+!! UKESM1 - new diagnostics !! Jpalm
+!! jdms : include dms diagnostics
+!! jdms_input : use instant (0) or diel-avg (1) inputs
+!! jdms_model : which DMS model is passed to atmosphere
+!!
+!!
+&natbio
+!
+!! Primary production and chl related quantities
+ xxi = 0.01257 !!
+ xaln = 15.0 !! EKP (05/03/09)
+ xald = 11.25 !! EKP (05/03/09)
+ jphy = 1 !! 0 = T-independent; 1 = T-dependent; 2 = T-dependent-Q10
+ xvpn = 0.640 !! EKP (05/03/09) -- daily avg = 0.530; daily cycle = 1.060; Q10 = 0.64
+ xvpd = 0.600 !! EKP (05/03/09) -- daily avg = 0.500; daily cycle = 1.000; Q10 = 0.6
+ xthetam = 0.05 !! EKP (05/03/09)
+ xthetamd = 0.05 !! EKP (05/03/09)
+ jq10 = 1.50 !! Jpalm (17-06-2016)
+!!
+!! Diatom silicon parameters
+ xsin0 = 0.2 !! Mongin et al. (2003)
+ xnsi0 = 0.2 !! Mongin et al. (2003)
+ xuif = 1.5 !! Mongin et al. (2003)
+!!
+!! Nutrient limitation
+ jliebig = 0 !! 0 = multiplicative, 1 = Liebig
+ xnln = 0.5 !! Fasham (1993)
+ xnld = 0.75 !! EKP (05/03/09)
+ xsld = 3.00 !! Fasham et al. (2006)-ish
+ xfln = 0.00033 !! EKP (29/10/09); Parekh et al. (2005)
+ xfld = 0.00067 !! EKP (29/10/09); Parekh et al. (2005); filtered through Moore et al. (2004)
+!!
+!! Grazing
+ xgmi = 2.0 !! EKP (05/03/09)
+ xgme = 0.5 !! AXY (21/12/09)
+ xkmi = 0.8 !! EKP (26/02/09)
+ xkme = 0.3 !! EKP (26/02/09)
+ xphi = 0.20 !! Anderson & Pondaven (2003; 0.23); EKP (05/03/09; 0.20)
+ xbetan = 0.77 !! Anderson & Pondaven (2003)
+ xbetac = 0.64 !! Anderson & Pondaven (2003)
+!! xbetan = 0.69 !! compromise values inbetween those from ...
+!! xbetac = 0.69 !! Anderson & Pondaven (2003)for detrital carbon model
+ xkc = 0.80 !! Anderson & Pondaven (2003)
+ xpmipn = 0.75 !!
+ xpmid = 0.25 !!
+ xpmepn = 0.15 !! EKP (26/02/09)
+ xpmepd = 0.35 !! EKP (26/02/09)
+ xpmezmi = 0.35 !! EKP (26/02/09)
+ xpmed = 0.15 !! EKP (26/02/09)
+!!
+!! Metabolic losses
+ xmetapn = 0.02 !!
+ xmetapd = 0.02 !!
+ xmetazmi = 0.02 !!
+ xmetazme = 0.02 !!
+!!
+!! Mortality losses
+ jmpn = 3 !! 1=linear; 2=quadratic; 3=hyperbolic; 4=sigmoid
+ xmpn = 0.1 !!
+ xkphn = 0.5 !! EKP (26/02/09): new parameter
+ jmpd = 3 !! 1=linear; 2=quadratic; 3=hyperbolic; 4=sigmoid
+ xmpd = 0.1 !!
+ xkphd = 0.5 !! EKP (26/02/09): new parameter
+ jmzmi = 3 !! 1=linear; 2=quadratic; 3=hyperbolic; 4=sigmoid
+ xmzmi = 0.1 !!
+ xkzmi = 0.5 !!
+ jmzme = 3 !! 1=linear; 2=quadratic; 3=hyperbolic; 4=sigmoid
+ xmzme = 0.2 !! EKP (26/02/09)
+ xkzme = 0.75 !! EKP (26/02/09)
+!!
+!! Remineralisation
+ jmd = 2 !! 0 = T-independent; 1 = T-dependent; 2 = T-dependent-Q10
+ jsfd = 0 !! 0 = unchanged seafloor remin.; 1 = accelerated seafloor remin.
+ xmd = 0.0190 !! T-dependent; 0.05 at 18C (Yool et al., 2010) - Q10 = 0.0190
+ xmdc = 0.0152 !! T-dependent; 0.04 at 18C (Yool et al., 2010) - Q10 = 0.0152
+!!
+!! Stochiometric ratios
+ xthetapn = 6.625 !! Redfield
+ xthetapd = 6.625 !! Redfield
+ xthetazmi = 5.625 !! Redfield
+ xthetazme = 5.625 !! Redfield
+!! AXY (26/11/08): implicit detrital carbon change
+ xthetad = 6.625 !! Redfield
+ xrfn = 30.0e-6 !! Parekh et al. (2005)
+ xrsn = 1.0 !! not used here; retained for Lobster
+!!
+!! Iron parameters
+ jiron = 1 !! iron scavenging submodel switch
+ xfe_mass = 55.485 !! Fe atomic mass
+ xfe_sol = 0.00532 !! scaled to get same input as Parekh et al. (2005)
+ xfe_sed = 0.000228 !! AXY (10/07/12): Moore-ish
+ xLgT = 1.0 !! from Diat-HadOCC; from Parekh et al. (2005)
+ xk_FeL = 100.0 !! from Diat-HadOCC
+ xk_sc_Fe = 1.e-3 !! from Dutkiewicz et al. (2005)
+!!
+!! Fast-sinking detritus parameters
+ jexport = 1 !! 1 = ballast; 2 = Martin (1987); 3 = Henson (2011)
+ jfdfate = 0 !! 0 = instant remin.; 1 = transmogrify into slow detritus
+ jrratio = 2 !! 0 = Dunne (2005); 1 = Ridgwell (2007) surface; 2 = Ridgwell (2007) 3D
+ jocalccd = 1 !! 0 = default, fixed; 1 = calculated, dynamic
+ xridg_r0 = 0.026 !! = 0.044, Ridgwell et al. (2007); scaled to 60% from preliminary sims
+ xfdfrac1 = 0.333 !! control parameter; no "real" value (AXY; 12/03/09)
+ xfdfrac2 = 1.00 !! control parameter; no "real" value (AXY; 12/03/09)
+ xfdfrac3 = 0.80 !! control parameter; no "real" value (AXY; 12/03/09)
+ xcaco3a = 0.02 !! Dunne et al. (2005); not an exact value
+ xcaco3b = 0.10 !! Dunne et al. (2005); not an exact value
+!! AXY (06/01/09): after contacting Dunne, new values are used for masses ...
+!! xmassc = 22.1188 !!
+!! xmassca = 100.086 !! original values; replaced by Dunne suggestion
+!! xmasssi = 78.0988 !!
+ xmassc = 12.011 !! C atomic mass
+ xmassca = 100.086 !! CaCO3; based on atomic masses
+ xmasssi = 60.084 !! SiO2; based on atomic masses
+ xprotca = 0.070 !! Dunne et al. (2005)
+ xprotsi = 0.026 !! Dunne et al. (2005)
+ xfastc = 188.0 !! Dunne et al. (2005)
+ xfastca = 3500.0 !! Dunne et al. (2005)
+ xfastsi = 2000.0 !! Dunne et al. (2005)
+!!
+!! Benthos parameters
+ jorgben = 1 !! 0 = no; 1 = yes
+ jinorgben = 1 !! 0 = no; 1 = yes
+ xsedn = 0.05 !! default ERSEM-ish value
+ xsedfe = 0.05 !! default ERSEM-ish value
+ xsedsi = 0.01 !! default ERSEM-ish value
+ xsedc = 0.05 !! default ERSEM-ish value
+ xsedca = 0.01 !! default ERSEM-ish value
+ xburial = 0.0 !! set to zero
+!!
+!! River parameters
+ jriver_n = 0 !! 0 = no; 1 = runoff-dependent fluxes; 2= fixed fluxes
+ jriver_si = 0 !! 0 = no; 1 = runoff-dependent fluxes; 2= fixed fluxes
+ jriver_c = 0 !! 0 = no; 1 = runoff-dependent fluxes; 2= fixed fluxes
+ jriver_alk= 0 !! 0 = no; 1 = runoff-dependent fluxes; 2= fixed fluxes
+ jriver_dep= 5 !! depth to which river nutrients are added
+!!
+!! Miscellaneous
+ xsdiss = 0.006 !! Mongin et al. (2003); 0.006 is an alternative
+!!
+!! Gravitational sinking
+ vsed = 3.472e-5 !! EKP (05/03/09)
+!!
+!! Additional parameters
+ jpkb = 16 !!
+!!
+!! UKESM1 - new diagnostics !! Jpalm
+ jdms = 1 !! include dms diagnostics
+ jdms_input = 1 !! use instant (0) or diel-avg (1) inputs
+ jdms_model = 3 !! choice of DMS model passed to atmosphere
+!! 1 = ANDR, 2 = SIMO, 3 = ARAN, 4 = HALL
+!!
+/
+!'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
+! natroam
+!,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
+!
+!! xthetaphy : oxygen evolution/consumption by phytoplankton
+!! = (32 / 16) + (6.625 * (119 / 106)) = (2 + 7.4375) mol O2 / mol N
+!! xthetazoo : oxygen consumption by zooplankton
+!! = (32 / 16) + (5.625 * (119 / 106)) = (2 + 6.3149) mol O2 / mol N
+!! xthetanit : oxygen consumption by nitrogen remineralisation
+!! = (32 / 16) = 2 mol O2 / mol N
+!! xthetarem : oxygen consumption by carbon remineralisation
+!! = (119 / 106) = 1.1226 mol O2 / mol C
+!! xo2min : oxygen minimum concentration
+!
+&natroam
+ xthetaphy = 9.4375
+ xthetazoo = 8.3149
+ xthetanit = 2.0
+ xthetarem = 1.1226
+ xo2min = 4.0
+/
+!'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
+! natopt
+!,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
+!
+! xkg0 : green water absorption coefficient [m-1]
+! xkr0 : red water absorption coefficient [m-1]
+! xkgp : pigment green absorption coefficient [m-1]
+! xkrp : pigment red absorption coefficient [m-1]
+! xlg : green chl exposant
+! xlr : red chl exposant
+! rpig : chla / (chla+phea) ratio
+!
+&natopt
+ xkg0 = 0.0232
+ xkr0 = 0.225
+ xkgp = 0.074
+ xkrp = 0.037
+ xlg = 0.629
+ xlr = 0.674
+ rpig = 0.7
+/
+!'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
+! natdbi used if key_trc_diabio is set
+!,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
+!
+! ctrbio : array of biological trend numbers
+! ctrbil : character string describing each biological trend
+! ctrbiu : array of unit numbers used for trend output
+! nwritebio : frequency of biological model output [timesteps]
+!
+&natdbi
+ ctrbio = "BIO_01", "BIO_02", "BIO_03", "BIO_04", "BIO_05", "BIO_06", "BIO_07", "BIO_08", "BIO_09", "BIO_10", "BIO_11", "BIO_12", "BIO_13", "BIO_14", "BIO_15", "BIO_16", "BIO_17", "BIO_18", "BIO_19", "BIO_20", "BIO_21", "BIO_22", "BIO_23", "BIO_24", "BIO_25", "BIO_26", "BIO_27", "BIO_28", "BIO_29", "BIO_30", "BIO_31", "BIO_32", "BIO_33", "BIO_34"
+ ctrbil = "BIO_01", "BIO_02", "BIO_03", "BIO_04", "BIO_05", "BIO_06", "BIO_07", "BIO_08", "BIO_09", "BIO_10", "BIO_11", "BIO_12", "BIO_13", "BIO_14", "BIO_15", "BIO_16", "BIO_17", "BIO_18", "BIO_19", "BIO_20", "BIO_21", "BIO_22", "BIO_23", "BIO_24", "BIO_25", "BIO_26", "BIO_27", "BIO_28", "BIO_29", "BIO_30", "BIO_31", "BIO_32", "BIO_33", "BIO_34"
+ ctrbiu = "m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m","m"
+ nwritebio = 10
+!/
+!&natopt
+/
+!=================================================
+! nammeddia Passive tracers additional diagnostics
+!=================================================
+!
+! ctrc2d : 2d output field name
+! ctrc2u : 2d output field unit
+! ctrc2l : 2d output field long name
+!
+! nwriteadd: frequency of additional arrays outputs(namelist)
+&nammeddia
+/
+!'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
+&nammedsbc ! parameters for inputs deposition
+!,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
+! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask !
+! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! filename !
+ sn_dust = 'dust.orca' , -1 , 'dust' , .true. , .true. , 'yearly' , '' , '' , ''
+!
+ cn_dir = './' ! root directory for the location of the dynamical files
+ bdustfer = .true. ! boolean for dust input from the atmosphere
+/
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_top_MEDUSA_et_al_cfg
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_top_MEDUSA_et_al_cfg (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_top_MEDUSA_et_al_cfg (revision 8155)
@@ -0,0 +1,119 @@
+!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!! NEMO/TOP1 : - tracer run information (namtrc_run)
+!! - tracer definition (namtrc )
+!! - tracer data initialisation (namtrc_dta)
+!! - tracer advection (namtrc_adv)
+!! - tracer lateral diffusion (namtrc_ldf)
+!! - tracer vertical physics (namtrc_zdf)
+!! - tracer newtonian damping (namtrc_dmp)
+!! - dynamical tracer trends (namtrc_trd)
+!! - tracer output diagonstics (namtrc_dia)
+!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!-----------------------------------------------------------------------
+&namtrc_run ! run information
+!-----------------------------------------------------------------------
+ nn_dttrc = 1 ! time step frequency for passive sn_tracers
+ nn_writetrc = 640 ! time step frequency for sn_tracer outputs
+ ln_top_euler = .false. ! use Euler time-stepping for TOP
+ ln_rsttr = .false. ! start from a restart file (T) or not (F)
+ nn_rsttr = 0 ! restart control = 0 initial time step is not compared to the restart file value
+ ! = 1 do not use the value in the restart file
+ ! = 2 calendar parameters read in the restart file
+ cn_trcrst_in = "restart_trc" ! suffix of pass. sn_tracer restart name (input)
+ cn_trcrst_indir = "." ! directory from which to read input passive tracer restarts
+ cn_trcrst_out = "restart_trc" ! suffix of pass. sn_tracer restart name (output)
+ cn_trcrst_outdir = "." ! directory to which to write output passive tracer restarts
+/
+!-----------------------------------------------------------------------
+&namtrc ! tracers definition
+!-----------------------------------------------------------------------
+ ln_trcdta = .false. ! Initialisation from data input file (T) or not (F)
+ ln_trcdmp = .false. ! add a damping termn (T) or not (F)
+ ln_trcdmp_clo = .false. ! damping term (T) or not (F) on closed seas
+/
+!-----------------------------------------------------------------------
+&namtrc_dta ! Initialisation from data input file
+!-----------------------------------------------------------------------
+!
+ cn_dir = './' ! root directory for the location of the data files
+/
+!-----------------------------------------------------------------------
+&namtrc_adv ! advection scheme for passive tracer
+!-----------------------------------------------------------------------
+ ln_trcadv_cen2 = .false. ! 2nd order centered scheme
+ ln_trcadv_tvd = .true. ! TVD scheme
+ ln_trcadv_muscl = .false. ! MUSCL scheme
+ ln_trcadv_muscl2 = .false. ! MUSCL2 scheme + cen2 at boundaries
+ ln_trcadv_ubs = .false. ! UBS scheme
+ ln_trcadv_qck = .false. ! QUICKEST scheme
+ ln_trcadv_msc_ups = .false. ! use upstream scheme within muscl
+/
+!-----------------------------------------------------------------------
+&namtrc_ldf ! lateral diffusion scheme for passive tracer
+!-----------------------------------------------------------------------
+! ! Type of the operator :
+ ln_trcldf_lap = .true. ! laplacian operator
+ ln_trcldf_bilap = .false. ! bilaplacian operator
+ ! Direction of action :
+ ln_trcldf_level = .false. ! iso-level
+ ln_trcldf_hor = .false. ! horizontal (geopotential) (require "key_ldfslp" when ln_sco=T)
+ ln_trcldf_iso = .true. ! iso-neutral (require "key_ldfslp")
+! ! Coefficient
+ rn_ahtrc_0 = 2000. ! horizontal eddy diffusivity for tracers [m2/s]
+ rn_ahtrb_0 = 0. ! background eddy diffusivity for ldf_iso [m2/s]
+/
+!-----------------------------------------------------------------------
+&namtrc_zdf ! vertical physics
+!-----------------------------------------------------------------------
+ ln_trczdf_exp = .false. ! split explicit (T) or implicit (F) time stepping
+ nn_trczdf_exp = 3 ! number of sub-timestep for ln_trczdfexp=T
+/
+!-----------------------------------------------------------------------
+&namtrc_rad ! treatment of negative concentrations
+!-----------------------------------------------------------------------
+ ln_trcrad = .true. ! artificially correct negative concentrations (T) or not (F)
+/
+!-----------------------------------------------------------------------
+&namtrc_dmp ! passive tracer newtonian damping
+!-----------------------------------------------------------------------
+ nn_zdmp_tr = 1 ! vertical shape =0 damping throughout the water column
+ ! =1 no damping in the mixing layer (kz criteria)
+ ! =2 no damping in the mixed layer (rho crieria)
+ cn_resto_tr = 'resto_tr.nc' ! create a damping.coeff NetCDF file (=1) or not (=0)
+/
+!-----------------------------------------------------------------------
+&namtrc_ice ! Representation of sea ice growth & melt effects
+!-----------------------------------------------------------------------
+ nn_ice_tr = -1 ! tracer concentration in sea ice
+ ! =-1 (no vvl: identical cc in ice and ocean / vvl: cc_ice = 0)
+ ! = 0 (no vvl: cc_ice = zero / vvl: cc_ice = )
+ ! = 1 prescribed to a namelist value (implemented in pisces only)
+/
+!-----------------------------------------------------------------------
+&namtrc_trd ! diagnostics on tracer trends ('key_trdtrc')
+! or mixed-layer trends ('key_trdmld_trc')
+!----------------------------------------------------------------------
+ nn_trd_trc = 640 ! time step frequency and tracers trends
+ nn_ctls_trc = 0 ! control surface type in mixed-layer trends (0,1 or n /seconds ; =86400. -> /day)
+ ln_trdmld_trc_restart = .false. ! restart for ML diagnostics
+ ln_trdmld_trc_instant = .true. ! flag to diagnose trends of instantantaneous or mean ML T/S
+ ln_trdtrc(1) = .true.
+ ln_trdtrc(2) = .true.
+ ln_trdtrc(23) = .true.
+/
+!-----------------------------------------------------------------------
+&namtrc_dia ! parameters for passive tracer additional diagnostics
+!----------------------------------------------------------------------
+ ln_diatrc = .false. ! save additional diag. (T) or not (F)
+ ln_diabio = .true. ! output biological trends
+ nn_writedia = 640 ! time step frequency for diagnostics
+ nn_writebio = 640 !: frequency of biological outputs
+/
+!----------------------------------------------------------------------
+! namtrc_bc ! data for boundary conditions
+!-----------------------------------------------------------------------
+&namtrc_bc
+!
+ cn_dir = './' ! root directory for the location of the data files
+/
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_top_MEDUSA_et_al_ref
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_top_MEDUSA_et_al_ref (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/SHARED/namelist_top_MEDUSA_et_al_ref (revision 8155)
@@ -0,0 +1,119 @@
+!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!! NEMO/TOP1 : - tracer run information (namtrc_run)
+!! - tracer definition (namtrc )
+!! - tracer data initialisation (namtrc_dta)
+!! - tracer advection (namtrc_adv)
+!! - tracer lateral diffusion (namtrc_ldf)
+!! - tracer vertical physics (namtrc_zdf)
+!! - tracer newtonian damping (namtrc_dmp)
+!! - dynamical tracer trends (namtrc_trd)
+!! - tracer output diagonstics (namtrc_dia)
+!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!-----------------------------------------------------------------------
+&namtrc_run ! run information
+!-----------------------------------------------------------------------
+ nn_dttrc = 1 ! time step frequency for passive sn_tracers
+ nn_writetrc = 640 ! time step frequency for sn_tracer outputs
+ ln_top_euler = .false. ! use Euler time-stepping for TOP
+ ln_rsttr = .false. ! start from a restart file (T) or not (F)
+ nn_rsttr = 0 ! restart control = 0 initial time step is not compared to the restart file value
+ ! = 1 do not use the value in the restart file
+ ! = 2 calendar parameters read in the restart file
+ cn_trcrst_in = "restart_trc" ! suffix of pass. sn_tracer restart name (input)
+ cn_trcrst_indir = "." ! directory from which to read input passive tracer restarts
+ cn_trcrst_out = "restart_trc" ! suffix of pass. sn_tracer restart name (output)
+ cn_trcrst_outdir = "." ! directory to which to write output passive tracer restarts
+/
+!-----------------------------------------------------------------------
+&namtrc ! tracers definition
+!-----------------------------------------------------------------------
+ ln_trcdta = .false. ! Initialisation from data input file (T) or not (F)
+ ln_trcdmp = .false. ! add a damping termn (T) or not (F)
+ ln_trcdmp_clo = .false. ! damping term (T) or not (F) on closed seas
+/
+!-----------------------------------------------------------------------
+&namtrc_dta ! Initialisation from data input file
+!-----------------------------------------------------------------------
+!
+ cn_dir = './' ! root directory for the location of the data files
+/
+!-----------------------------------------------------------------------
+&namtrc_adv ! advection scheme for passive tracer
+!-----------------------------------------------------------------------
+ ln_trcadv_cen2 = .false. ! 2nd order centered scheme
+ ln_trcadv_tvd = .true. ! TVD scheme
+ ln_trcadv_muscl = .false. ! MUSCL scheme
+ ln_trcadv_muscl2 = .false. ! MUSCL2 scheme + cen2 at boundaries
+ ln_trcadv_ubs = .false. ! UBS scheme
+ ln_trcadv_qck = .false. ! QUICKEST scheme
+ ln_trcadv_msc_ups = .false. ! use upstream scheme within muscl
+/
+!-----------------------------------------------------------------------
+&namtrc_ldf ! lateral diffusion scheme for passive tracer
+!-----------------------------------------------------------------------
+! ! Type of the operator :
+ ln_trcldf_lap = .true. ! laplacian operator
+ ln_trcldf_bilap = .false. ! bilaplacian operator
+ ! Direction of action :
+ ln_trcldf_level = .false. ! iso-level
+ ln_trcldf_hor = .false. ! horizontal (geopotential) (require "key_ldfslp" when ln_sco=T)
+ ln_trcldf_iso = .true. ! iso-neutral (require "key_ldfslp")
+! ! Coefficient
+ rn_ahtrc_0 = 2000. ! horizontal eddy diffusivity for tracers [m2/s]
+ rn_ahtrb_0 = 0. ! background eddy diffusivity for ldf_iso [m2/s]
+/
+!-----------------------------------------------------------------------
+&namtrc_zdf ! vertical physics
+!-----------------------------------------------------------------------
+ ln_trczdf_exp = .false. ! split explicit (T) or implicit (F) time stepping
+ nn_trczdf_exp = 3 ! number of sub-timestep for ln_trczdfexp=T
+/
+!-----------------------------------------------------------------------
+&namtrc_rad ! treatment of negative concentrations
+!-----------------------------------------------------------------------
+ ln_trcrad = .true. ! artificially correct negative concentrations (T) or not (F)
+/
+!-----------------------------------------------------------------------
+&namtrc_dmp ! passive tracer newtonian damping
+!-----------------------------------------------------------------------
+ nn_zdmp_tr = 1 ! vertical shape =0 damping throughout the water column
+ ! =1 no damping in the mixing layer (kz criteria)
+ ! =2 no damping in the mixed layer (rho crieria)
+ cn_resto_tr = 'resto_tr.nc' ! create a damping.coeff NetCDF file (=1) or not (=0)
+/
+!-----------------------------------------------------------------------
+&namtrc_ice ! Representation of sea ice growth & melt effects
+!-----------------------------------------------------------------------
+ nn_ice_tr = -1 ! tracer concentration in sea ice
+ ! =-1 (no vvl: identical cc in ice and ocean / vvl: cc_ice = 0)
+ ! = 0 (no vvl: cc_ice = zero / vvl: cc_ice = )
+ ! = 1 prescribed to a namelist value (implemented in pisces only)
+/
+!-----------------------------------------------------------------------
+&namtrc_trd ! diagnostics on tracer trends ('key_trdtrc')
+! or mixed-layer trends ('key_trdmld_trc')
+!----------------------------------------------------------------------
+ nn_trd_trc = 640 ! time step frequency and tracers trends
+ nn_ctls_trc = 0 ! control surface type in mixed-layer trends (0,1 or n /seconds ; =86400. -> /day)
+ ln_trdmld_trc_restart = .false. ! restart for ML diagnostics
+ ln_trdmld_trc_instant = .true. ! flag to diagnose trends of instantantaneous or mean ML T/S
+ ln_trdtrc(1) = .true.
+ ln_trdtrc(2) = .true.
+ ln_trdtrc(23) = .true.
+/
+!-----------------------------------------------------------------------
+&namtrc_dia ! parameters for passive tracer additional diagnostics
+!----------------------------------------------------------------------
+ ln_diatrc = .false. ! save additional diag. (T) or not (F)
+ ln_diabio = .true. ! output biological trends
+ nn_writedia = 640 ! time step frequency for diagnostics
+ nn_writebio = 640 !: frequency of biological outputs
+/
+!----------------------------------------------------------------------
+! namtrc_bc ! data for boundary conditions
+!-----------------------------------------------------------------------
+&namtrc_bc
+!
+ cn_dir = './' ! root directory for the location of the data files
+/
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/cfg.txt
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/cfg.txt (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/CONFIG/cfg.txt (revision 8155)
@@ -11,2 +11,4 @@
GYRE OPA_SRC
ORCA2_LIM OPA_SRC LIM_SRC_2 NST_SRC
+ORCA2_OFF_PISCES OPA_SRC OFF_SRC TOP_SRC
+ORCA2_OFF_MEDUSA OPA_SRC OFF_SRC TOP_SRC
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modarrays.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modarrays.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modarrays.F (revision 8155)
@@ -0,0 +1,1175 @@
+!
+! $Id: modarrays.F 2715 2011-03-30 15:58:35Z rblod $
+!
+C AGRIF (Adaptive Grid Refinement In Fortran)
+C
+C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
+C Christophe Vouland (Christophe.Vouland@imag.fr)
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.
+C
+C
+C
+CCC Module Agrif_Arrays
+C
+ Module Agrif_Arrays
+ Use Agrif_Types
+C
+ implicit none
+C
+ Contains
+C **************************************************************************
+CCC Subroutine Agrif_Childbounds
+C **************************************************************************
+C
+ Subroutine Agrif_Childbounds(nbdim,lboundloc,uboundloc,
+ & pttab,petab,pttruetab,cetruetab,memberin)
+C
+CCC Description:
+CCC Subroutine calculating the global indices of the child grid
+C
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(nbdim) :: lboundloc,uboundloc
+ INTEGER,DIMENSION(nbdim) :: pttab,petab,pttruetab,cetruetab
+ LOGICAL :: memberin
+C
+C Local variables
+ INTEGER :: i,lbglob,ubglob
+C
+#ifdef key_mpp_mpi
+ INTEGER :: indglob1,indglob2
+#endif
+C
+C
+ do i = 1,nbdim
+C
+ lbglob = lboundloc(i)
+ ubglob = uboundloc(i)
+C
+#ifdef key_mpp_mpi
+C
+ Call AGRIF_InvLoc(lbglob,Agrif_ProcRank,i,indglob1)
+C
+ Call AGRIF_InvLoc(ubglob,Agrif_ProcRank,i,indglob2)
+C
+ pttruetab(i) = max(pttab(i),indglob1)
+C
+ cetruetab(i) = min(petab(i),indglob2)
+C
+#else
+C
+ pttruetab(i) = max(pttab(i),lbglob)
+C
+ cetruetab(i) = min(petab(i),ubglob)
+C
+#endif
+C
+ enddo
+
+ memberin = .TRUE.
+
+ do i=1,nbdim
+ IF (cetruetab(i) < pttruetab(i)) THEN
+ memberin = .FALSE.
+ EXIT
+ ENDIF
+ enddo
+C
+ Return
+C
+C
+ End Subroutine Agrif_Childbounds
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_nbdim_Get_bound
+C **************************************************************************
+C
+ Subroutine Agrif_nbdim_Get_bound(Variable,
+ & lower,upper,indice,nbdim)
+C
+CCC Description:
+CCC This subroutine is used to get the lower and the upper boundaries of a
+C table. Output datas are scalar.
+C
+C Declarations:
+C
+
+C
+C Arguments
+C
+ ! we want extract boundaries of this table
+ TYPE(AGRIF_Variable), Pointer :: Variable
+ INTEGER :: lower,upper ! output data
+ ! direction in wich we want to know the dimension
+ INTEGER :: indice
+ INTEGER :: nbdim ! dimension of the table
+C
+C Local variables
+C
+
+ lower = Variable % lb(indice)
+ upper = Variable % ub(indice)
+ return
+C
+ End Subroutine Agrif_nbdim_Get_bound
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Get_bound_dimension
+C **************************************************************************
+C
+ Subroutine Agrif_nbdim_Get_bound_dimension(Variable,
+ & lower,upper,nbdim)
+C
+CCC Description:
+CCC This subroutine is used to get the lower and the upper boundaries of a
+C table. Output datas are scalar.
+C
+C Declarations:
+C
+
+C
+C Arguments
+C
+ ! we want extract boundaries of this table
+ TYPE(AGRIF_Variable), Pointer :: Variable
+ INTEGER :: nbdim ! dimension of the table
+ INTEGER,DIMENSION(nbdim) :: lower,upper ! output data
+C
+C Local variables
+C
+ lower = Variable % lb(1:nbdim)
+ upper = Variable % ub(1:nbdim)
+ return
+C
+ End Subroutine Agrif_nbdim_Get_bound_dimension
+
+C **************************************************************************
+CCC Subroutine Agrif_nbdim_allocation
+C **************************************************************************
+C
+ Subroutine Agrif_nbdim_allocation(Variable,inf,sup,nbdim)
+C
+CCC Description:
+CCC This subroutine is used to Allocate the table Variable
+C
+C Declarations:
+C
+
+C
+C Arguments
+C
+ TYPE(AGRIF_Variable), Pointer :: Variable
+ INTEGER :: nbdim ! dimension of the table
+ INTEGER,DIMENSION(nbdim) :: inf,sup
+C
+C Local variables
+C
+ SELECT CASE (nbdim)
+ CASE (1)
+ allocate(Variable%array1(
+ & inf(1):sup(1)))
+ CASE (2)
+ allocate(Variable%array2(
+ & inf(1):sup(1),
+ & inf(2):sup(2)))
+ CASE (3)
+ allocate(Variable%array3(
+ & inf(1):sup(1),
+ & inf(2):sup(2),
+ & inf(3):sup(3)))
+ CASE (4)
+ allocate(Variable%array4(
+ & inf(1):sup(1),
+ & inf(2):sup(2),
+ & inf(3):sup(3),
+ & inf(4):sup(4)))
+ CASE (5)
+ allocate(Variable%array5(
+ & inf(1):sup(1),
+ & inf(2):sup(2),
+ & inf(3):sup(3),
+ & inf(4):sup(4),
+ & inf(5):sup(5)))
+ CASE (6)
+ allocate(Variable%array6(
+ & inf(1):sup(1),
+ & inf(2):sup(2),
+ & inf(3):sup(3),
+ & inf(4):sup(4),
+ & inf(5):sup(5),
+ & inf(6):sup(6)))
+ END SELECT
+C
+ return
+C
+ End Subroutine Agrif_nbdim_allocation
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_nbdim_deallocation
+C **************************************************************************
+C
+ Subroutine Agrif_nbdim_deallocation(Variable,nbdim)
+C
+CCC Description:
+CCC This subroutine is used to give the same value to the table Variable
+C
+C Declarations:
+C
+
+C
+C Arguments
+C
+ TYPE(AGRIF_Variable), Pointer :: Variable
+ INTEGER :: nbdim ! dimension of the table
+C
+C Local variables
+C
+
+ SELECT CASE (nbdim)
+ CASE (1)
+ Deallocate(Variable%array1)
+ CASE (2)
+ Deallocate(Variable%array2)
+ CASE (3)
+ Deallocate(Variable%array3)
+ CASE (4)
+ Deallocate(Variable%array4)
+ CASE (5)
+ Deallocate(Variable%array5)
+ CASE (6)
+ Deallocate(Variable%array6)
+ END SELECT
+C
+ return
+C
+ End Subroutine Agrif_nbdim_deallocation
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_nbdim_Full_VarEQreal
+C **************************************************************************
+C
+ Subroutine Agrif_nbdim_Full_VarEQreal(Variable,Value,nbdim)
+C
+CCC Description:
+CCC This subroutine is used to get the lower and the upper boundaries of a
+C table. Output datas are scalar.
+C
+C Declarations:
+C
+
+C
+C Arguments
+C
+ TYPE(AGRIF_Variable), Pointer :: Variable
+ REAL :: Value
+ INTEGER :: nbdim ! dimension of the table
+C
+C Local variables
+C
+ SELECT CASE (nbdim)
+ CASE (1)
+ Variable%array1 = Value
+ CASE (2)
+ Variable%array2 = Value
+ CASE (3)
+ Call Agrif_set_tozero3D(Variable%array3)
+! Variable%array3 = Value
+ CASE (4)
+ Variable%array4 = Value
+ CASE (5)
+ Variable%array5 = Value
+ CASE (6)
+ Variable%array6 = Value
+ END SELECT
+C
+ return
+C
+ End Subroutine Agrif_nbdim_Full_VarEQreal
+
+ Subroutine Agrif_set_tozero3D(tab3D)
+ real,dimension(:,:,:),target :: tab3D
+
+ tab3D = 0.
+
+ end subroutine agrif_set_tozero3D
+C
+C
+#if !defined key_mpp_mpi
+C **************************************************************************
+CCC Subroutine Agrif_nbdim_VarEQreal
+C **************************************************************************
+C
+ Subroutine Agrif_nbdim_VarEQreal(Variable,inf,sup,Value,nbdim)
+C
+CCC Description:
+CCC This subroutine is used to give the same value to a part of
+C the table Variable
+C
+C Declarations:
+C
+
+C
+C Arguments
+C
+ TYPE(AGRIF_Variable), Pointer :: Variable
+ REAL :: Value
+ INTEGER :: nbdim ! dimension of the table
+ INTEGER,DIMENSION(nbdim) :: inf,sup
+C
+C Local variables
+C
+ SELECT CASE (nbdim)
+ CASE (1)
+ Variable%array1(
+ & inf(1):sup(1)
+ & ) = Value
+ CASE (2)
+ Variable%array2(
+ & inf(1):sup(1),
+ & inf(2):sup(2)
+ & ) = Value
+ CASE (3)
+ Variable%array3(
+ & inf(1):sup(1),
+ & inf(2):sup(2),
+ & inf(3):sup(3)
+ & ) = Value
+ CASE (4)
+ Variable%array4(
+ & inf(1):sup(1),
+ & inf(2):sup(2),
+ & inf(3):sup(3),
+ & inf(4):sup(4)
+ & ) = Value
+ CASE (5)
+ Variable%array5(
+ & inf(1):sup(1),
+ & inf(2):sup(2),
+ & inf(3):sup(3),
+ & inf(4):sup(4),
+ & inf(5):sup(5)
+ & ) = Value
+ CASE (6)
+ Variable%array6(
+ & inf(1):sup(1),
+ & inf(2):sup(2),
+ & inf(3):sup(3),
+ & inf(4):sup(4),
+ & inf(5):sup(5),
+ & inf(6):sup(6)
+ & ) = Value
+ END SELECT
+C
+ return
+C
+ End Subroutine Agrif_nbdim_VarEQreal
+#endif
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_nbdim_VarEQvar
+C **************************************************************************
+C
+ Subroutine Agrif_nbdim_VarEQvar(Variable,inf,sup,
+ & Variable2,inf2,sup2,
+ & nbdim)
+C
+CCC Description:
+CCC This subroutine is used to give the value of a part of the table
+C Variable2 to the table Variable
+C
+C Declarations:
+C
+
+C
+C Arguments
+C
+ TYPE(AGRIF_Variable), Pointer :: Variable
+ TYPE(AGRIF_Variable), Pointer :: Variable2
+ INTEGER :: nbdim ! dimension of the table
+ INTEGER,DIMENSION(nbdim) :: inf,sup
+ INTEGER,DIMENSION(nbdim) :: inf2,sup2
+C
+C Local variables
+C
+ SELECT CASE (nbdim)
+ CASE (1)
+ Variable%array1(inf(1):sup(1)) =
+ & Variable2%array1(inf2(1):sup2(1))
+ CASE (2)
+
+ Call Agrif_Copy_2d(Variable%array2,Variable2%array2,
+ & lbound(Variable%array2),
+ & lbound(Variable2%array2),
+ & inf,sup,inf2,sup2)
+
+ CASE (3)
+
+ Call Agrif_Copy_3d(Variable%array3,Variable2%array3,
+ & lbound(Variable%array3),
+ & lbound(Variable2%array3),
+ & inf,sup,inf2,sup2)
+
+ CASE (4)
+
+ Call Agrif_Copy_4d(Variable%array4,Variable2%array4,
+ & lbound(Variable%array4),
+ & lbound(Variable2%array4),
+ & inf,sup,inf2,sup2)
+
+ CASE (5)
+ Variable%array5(inf(1):sup(1),
+ & inf(2):sup(2),
+ & inf(3):sup(3),
+ & inf(4):sup(4),
+ & inf(5):sup(5)) =
+ & Variable2%array5(inf2(1):sup2(1),
+ & inf2(2):sup2(2),
+ & inf2(3):sup2(3),
+ & inf2(4):sup2(4),
+ & inf2(5):sup2(5))
+ CASE (6)
+ Variable%array6(inf(1):sup(1),
+ & inf(2):sup(2),
+ & inf(3):sup(3),
+ & inf(4):sup(4),
+ & inf(5):sup(5),
+ & inf(6):sup(6)) =
+ & Variable2%array6(inf2(1):sup2(1),
+ & inf2(2):sup2(2),
+ & inf2(3):sup2(3),
+ & inf2(4):sup2(4),
+ & inf2(5):sup2(5),
+ & inf2(6):sup2(6))
+ END SELECT
+C
+ return
+C
+ End Subroutine Agrif_nbdim_VarEQvar
+C
+C **************************************************************************
+CCC Subroutine Agrif_nbdim_Full_VarEQvar
+C **************************************************************************
+C
+ Subroutine Agrif_nbdim_Full_VarEQvar(Variable,Variable2,
+ & nbdim)
+C
+CCC Description:
+CCC This subroutine is used to give the value of the table Variable2
+C to the table Variable
+C
+C Declarations:
+C
+
+C
+C Arguments
+C
+ TYPE(AGRIF_Variable), Pointer :: Variable
+ TYPE(AGRIF_Variable), Pointer :: Variable2
+ INTEGER :: nbdim ! dimension of the table
+C
+C Local variables
+C
+ SELECT CASE (nbdim)
+ CASE (1)
+ Variable%array1 = Variable2%array1
+ CASE (2)
+ Variable%array2 = Variable2%array2
+ CASE (3)
+ Variable%array3 = Variable2%array3
+ CASE (4)
+ Variable%array4 = Variable2%array4
+ CASE (5)
+ Variable%array5 = Variable2%array5
+ CASE (6)
+ Variable%array6 = Variable2%array6
+ END SELECT
+C
+ return
+C
+ End Subroutine Agrif_nbdim_Full_VarEQvar
+C
+C
+
+C **************************************************************************
+CCC Subroutine GiveAgrif_SpecialValueToTab_mpi
+C **************************************************************************
+C
+ Subroutine GiveAgrif_SpecialValueToTab_mpi(Variable1,Variable2,
+ & bound1,lower,upper,Value,nbdim)
+C
+CCC Description:
+CCC
+C
+C Declarations:
+C
+
+C
+C Arguments
+C
+ TYPE(AGRIF_VARIABLE), Pointer :: Variable1
+ TYPE(AGRIF_VARIABLE), Pointer :: Variable2
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(:,:,:) :: bound1
+ INTEGER,DIMENSION(nbdim) :: lower,upper
+ REAL :: Value
+C
+C Local variables
+C
+ SELECT CASE (nbdim)
+ CASE (1)
+ Where (Variable1 % array1(
+ & bound1(1,1,2):bound1(1,2,2))
+ & == Value)
+ Variable2 % array1(bound1(1,1,1):bound1(1,2,1))
+ & = Value
+C
+ End Where
+ CASE (2)
+ Where (Variable1 % array2(
+ & bound1(1,1,2):bound1(1,2,2),
+ & bound1(2,1,2):bound1(2,2,2))
+ & == Value)
+ Variable2 % array2(bound1(1,1,1):bound1(1,2,1),
+ & bound1(2,1,1):bound1(2,2,1))
+ & = Value
+C
+ End Where
+ CASE (3)
+ Where (Variable1 % array3(
+ & bound1(1,1,2):bound1(1,2,2),
+ & bound1(2,1,2):bound1(2,2,2),
+ & bound1(3,1,2):bound1(3,2,2))
+ & == Value)
+ Variable2 % array3(bound1(1,1,1):bound1(1,2,1),
+ & bound1(2,1,1):bound1(2,2,1),
+ & bound1(3,1,1):bound1(3,2,1))
+ & = Value
+C
+ End Where
+ CASE (4)
+ Where (Variable1 % array4(
+ & bound1(1,1,2):bound1(1,2,2),
+ & bound1(2,1,2):bound1(2,2,2),
+ & bound1(3,1,2):bound1(3,2,2),
+ & bound1(4,1,2):bound1(4,2,2))
+ & == Value)
+ Variable2 % array4(bound1(1,1,1):bound1(1,2,1),
+ & bound1(2,1,1):bound1(2,2,1),
+ & bound1(3,1,1):bound1(3,2,1),
+ & bound1(4,1,1):bound1(4,2,1))
+ & = Value
+C
+ End Where
+ CASE (5)
+ Where (Variable1 % array5(
+ & bound1(1,1,2):bound1(1,2,2),
+ & bound1(2,1,2):bound1(2,2,2),
+ & bound1(3,1,2):bound1(3,2,2),
+ & bound1(4,1,2):bound1(4,2,2),
+ & bound1(5,1,2):bound1(5,2,2))
+ & == Value)
+ Variable2 % array5(bound1(1,1,1):bound1(1,2,1),
+ & bound1(2,1,1):bound1(2,2,1),
+ & bound1(3,1,1):bound1(3,2,1),
+ & bound1(4,1,1):bound1(4,2,1),
+ & bound1(5,1,1):bound1(5,2,1))
+ & = Value
+C
+ End Where
+ CASE (6)
+ Where (Variable1 % array6(
+ & bound1(1,1,2):bound1(1,2,2),
+ & bound1(2,1,2):bound1(2,2,2),
+ & bound1(3,1,2):bound1(3,2,2),
+ & bound1(4,1,2):bound1(4,2,2),
+ & bound1(5,1,2):bound1(5,2,2),
+ & bound1(6,1,2):bound1(6,2,2))
+ & == Value)
+ Variable2 % array6(bound1(1,1,1):bound1(1,2,1),
+ & bound1(2,1,1):bound1(2,2,1),
+ & bound1(3,1,1):bound1(3,2,1),
+ & bound1(4,1,1):bound1(4,2,1),
+ & bound1(5,1,1):bound1(5,2,1),
+ & bound1(6,1,1):bound1(6,2,1))
+ & = Value
+C
+ End Where
+ END SELECT
+C
+ return
+C
+ End Subroutine GiveAgrif_SpecialValueToTab_mpi
+
+C **************************************************************************
+CCC Subroutine GiveAgrif_SpecialValueToTab
+C **************************************************************************
+C
+ Subroutine GiveAgrif_SpecialValueToTab(Variable1,Variable2,
+ & lower,upper,Value,nbdim)
+C
+CCC Description:
+CCC
+C
+C Declarations:
+C
+
+C
+C Arguments
+C
+ TYPE(AGRIF_VARIABLE), Pointer :: Variable1
+ TYPE(AGRIF_VARIABLE), Pointer :: Variable2
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(nbdim) :: lower,upper
+ REAL :: Value
+C
+C Local variables
+C
+ SELECT CASE (nbdim)
+ CASE (1)
+ Where (Variable1 % array1(
+ & lower(1):upper(1))
+ & == Value)
+ Variable2 % array1(lower(1):upper(1))
+ & = Value
+C
+ End Where
+ CASE (2)
+ Where (Variable1 % array2(
+ & lower(1):upper(1),
+ & lower(2):upper(2))
+ & == Value)
+ Variable2 % array2(lower(1):upper(1),
+ & lower(2):upper(2))
+ & = Value
+C
+ End Where
+ CASE (3)
+ Where (Variable1 % array3(
+ & lower(1):upper(1),
+ & lower(2):upper(2),
+ & lower(3):upper(3))
+ & == Value)
+ Variable2 % array3(lower(1):upper(1),
+ & lower(2):upper(2),
+ & lower(3):upper(3))
+ & = Value
+C
+ End Where
+ CASE (4)
+ Where (Variable1 % array4(
+ & lower(1):upper(1),
+ & lower(2):upper(2),
+ & lower(3):upper(3),
+ & lower(4):upper(4))
+ & == Value)
+ Variable2 % array4(lower(1):upper(1),
+ & lower(2):upper(2),
+ & lower(3):upper(3),
+ & lower(4):upper(4))
+ & = Value
+C
+ End Where
+ CASE (5)
+ Where (Variable1 % array5(
+ & lower(1):upper(1),
+ & lower(2):upper(2),
+ & lower(3):upper(3),
+ & lower(4):upper(4),
+ & lower(5):upper(5))
+ & == Value)
+ Variable2 % array5(lower(1):upper(1),
+ & lower(2):upper(2),
+ & lower(3):upper(3),
+ & lower(4):upper(4),
+ & lower(5):upper(5))
+ & = Value
+C
+ End Where
+ CASE (6)
+ Where (Variable1 % array6(
+ & lower(1):upper(1),
+ & lower(2):upper(2),
+ & lower(2):upper(3),
+ & lower(4):upper(4),
+ & lower(5):upper(5),
+ & lower(6):upper(6))
+ & == Value)
+ Variable2 % array6(lower(1):upper(1),
+ & lower(2):upper(2),
+ & lower(3):upper(3),
+ & lower(4):upper(4),
+ & lower(5):upper(5),
+ & lower(6):upper(6))
+ & = Value
+C
+ End Where
+ END SELECT
+C
+ return
+C
+ End Subroutine GiveAgrif_SpecialValueToTab
+
+C
+C
+#ifdef key_mpp_mpi
+C **************************************************************************
+CCC Subroutine Where_ValTabToTab_mpi
+C **************************************************************************
+C
+ Subroutine Where_ValTabToTab_mpi(
+ & Variable1,Variable2,
+ & lower,upper,Value,nbdim)
+C
+CCC Description:
+CCC
+C
+C Declarations:
+C
+
+C
+C Arguments
+C
+ TYPE(AGRIF_VARIABLE), Pointer :: Variable1
+ TYPE(AGRIF_VARIABLE), Pointer :: Variable2
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(nbdim) :: lower,upper
+ REAL :: Value
+ INTEGER :: i,j,k,l,m,n
+C
+C Local variables
+C
+ SELECT CASE (nbdim)
+ CASE (1)
+ DO i = lower(1),upper(1)
+ IF (variable1%array1(i) == Value) then
+ variable1%array1(i)=Variable2%array1(i)
+ ENDIF
+ ENDDO
+ CASE (2)
+ DO j = lower(2),upper(2)
+ DO i = lower(1),upper(1)
+ IF (variable1%array2(i,j) == Value) then
+ variable1%array2(i,j)=Variable2%array2(i,j)
+ ENDIF
+ ENDDO
+ ENDDO
+ CASE (3)
+ DO k = lower(3),upper(3)
+ DO j = lower(2),upper(2)
+ DO i = lower(1),upper(1)
+ IF (variable1%array3(i,j,k) == Value) then
+ variable1%array3(i,j,k)=Variable2%array3(i,j,k)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ CASE (4)
+ DO l = lower(4),upper(4)
+ DO k = lower(3),upper(3)
+ DO j = lower(2),upper(2)
+ DO i = lower(1),upper(1)
+ IF (variable1%array4(i,j,k,l) == Value) then
+ variable1%array4(i,j,k,l)=Variable2%array4(i,j,k,l)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ CASE (5)
+ DO m = lower(5),upper(5)
+ DO l = lower(4),upper(4)
+ DO k = lower(3),upper(3)
+ DO j = lower(2),upper(2)
+ DO i = lower(1),upper(1)
+ IF (variable1%array5(i,j,k,l,m) == Value) then
+ variable1%array5(i,j,k,l,m)=Variable2%array5(i,j,k,l,m)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ CASE (6)
+ DO n = lower(6),upper(6)
+ DO m = lower(5),upper(5)
+ DO l = lower(4),upper(4)
+ DO k = lower(3),upper(3)
+ DO j = lower(2),upper(2)
+ DO i = lower(1),upper(1)
+ IF (variable1%array6(i,j,k,l,m,n) == Value) then
+ variable1%array6(i,j,k,l,m,n)=Variable2%array6(i,j,k,l,m,n)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ END SELECT
+C
+ return
+C
+ End Subroutine Where_ValTabToTab_mpi
+#endif
+
+C **************************************************************************
+CCC Subroutine PreProcessToInterpOrUpdate
+C **************************************************************************
+C
+ Subroutine PreProcessToInterpOrUpdate(parent,child,
+ & petab_Child,
+ & pttab_Child,pttab_Parent,
+ & s_Child,s_Parent,
+ & ds_Child,ds_Parent,
+ & nbdim)
+C
+CCC Description:
+CCC
+C
+C Declarations:
+C
+C arguments
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(6) :: pttab_child
+ INTEGER,DIMENSION(6) :: petab_child
+ INTEGER,DIMENSION(6) :: pttab_parent
+ TYPE(AGRIF_Variable), Pointer :: root ! Pointer on the variable of the
+ ! root grid
+ TYPE(Agrif_Grid), Pointer :: Agrif_Child_Gr,Agrif_Parent_Gr
+ REAL, DIMENSION(6) :: s_child,s_parent
+ REAL, DIMENSION(6) :: ds_child,ds_parent
+C locals variables
+ INTEGER :: n
+
+C
+C Arguments
+C
+
+C
+C Local variables
+C
+ Agrif_Child_Gr => Agrif_Curgrid
+ Agrif_Parent_Gr => Agrif_Curgrid % parent
+C
+ root => child % var % root_var
+C
+C Number of dimensions of the current grid
+ nbdim = root % nbdim
+C
+ do n=1,nbdim
+C
+ Select case(root % interptab(n))
+C
+C Value of interptab(n) can be either x,y,z or N for a no space
+C DIMENSION
+C
+C The DIMENSION is 'x'
+ case('x')
+C
+ pttab_Child(n) = root % point(1)
+C
+ pttab_Parent(n) = root % point(1)
+C
+ s_Child(n) = Agrif_Child_Gr % Agrif_x(1)
+C
+ s_Parent(n) = Agrif_Parent_Gr % Agrif_x(1)
+C
+ ds_Child(n) = Agrif_Child_Gr % Agrif_d(1)
+C
+ ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(1)
+C
+ if (root % posvar(n).EQ.1) then
+C
+ petab_Child(n) = pttab_Child(n) + Agrif_Child_Gr%nb(1)
+C
+ else
+C
+ petab_Child(n) = pttab_Child(n) +
+ & Agrif_Child_Gr%nb(1) - 1
+C
+ s_Child(n) = s_Child(n) + ds_Child(n)/2.
+C
+ s_Parent(n) = s_Parent(n) + ds_Parent(n)/2.
+C
+ endif
+C
+C The DIMENSION is 'y'
+ case('y')
+C
+ pttab_Child(n) = root % point(2)
+C
+ pttab_Parent(n) = root % point(2)
+C
+ s_Child(n) = Agrif_Child_Gr % Agrif_x(2)
+C
+ s_Parent(n) = Agrif_Parent_Gr % Agrif_x(2)
+C
+ ds_Child(n) = Agrif_Child_Gr % Agrif_d(2)
+C
+ ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(2)
+C
+ if (root % posvar(n).EQ.1) then
+C
+ petab_Child(n) = pttab_Child(n) + Agrif_Child_Gr%nb(2)
+C
+ else
+C
+ petab_Child(n) = pttab_Child(n) +
+ & Agrif_Child_Gr%nb(2) - 1
+C
+ s_Child(n) = s_Child(n) + ds_Child(n)/2.
+C
+ s_Parent(n) = s_Parent(n) + ds_Parent(n)/2.
+C
+ endif
+
+C
+C The DIMENSION is 'z'
+ case('z')
+C
+ pttab_Child(n) = root % point(3)
+C
+ pttab_Parent(n) = root % point(3)
+C
+ s_Child(n) = Agrif_Child_Gr % Agrif_x(3)
+C
+ s_Parent(n) = Agrif_Parent_Gr % Agrif_x(3)
+C
+ ds_Child(n) = Agrif_Child_Gr % Agrif_d(3)
+C
+ ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(3)
+C
+ if (root % posvar(n).EQ.1) then
+C
+ petab_Child(n) = pttab_Child(n) + Agrif_Child_Gr%nb(3)
+C
+ else
+C
+ petab_Child(n) = pttab_Child(n) +
+ & Agrif_Child_Gr%nb(3) - 1
+C
+ s_Child(n) = s_Child(n) + ds_Child(n)/2.
+C
+ s_Parent(n) = s_Parent(n) + ds_Parent(n)/2.
+C
+ endif
+C
+C The DIMENSION is not space
+ case('N')
+C
+C The next coefficients are calculated in order to do a simple copy of
+C values of the grid variable when the procedure of interpolation is
+C called for this DIMENSION
+C
+ Call Agrif_nbdim_Get_bound(child % var,
+ & pttab_Child(n),petab_Child(n),n,nbdim)
+C
+C No interpolation but only a copy of the values of the grid variable
+C
+ pttab_Parent(n) = pttab_Child(n)
+C
+ s_Child(n)=0.
+C
+ s_Parent(n)=0.
+C
+ ds_Child(n)=1.
+C
+ ds_Parent(n)=1.
+C
+ End select
+C
+ enddo
+C
+ return
+C
+ End Subroutine PreProcessToInterpOrUpdate
+
+#ifdef key_mpp_mpi
+C
+C **************************************************************************
+CCC Subroutine GetLocalBoundaries
+C **************************************************************************
+C
+ Subroutine GetLocalBoundaries(tab1,tab2,i,lb,ub,deb,fin)
+C
+CCC Descritpion:
+C
+C
+C Declarations:
+C
+
+C
+C
+C Scalar arguments
+ INTEGER :: tab1,tab2
+ INTEGER :: i
+ INTEGER :: lb,ub
+ INTEGER :: deb,fin
+C
+C Local scalars
+ INTEGER :: imin,imax
+ INTEGER :: i1,i2
+C
+C
+ Call AGRIF_InvLoc(lb,AGRIF_ProcRank,i,imin)
+C
+ Call AGRIF_InvLoc(ub,AGRIF_ProcRank,i,imax)
+C
+C
+ if (imin > tab2) then
+C
+ i1 = imax - imin
+C
+ else
+C
+ i1 = max(tab1 - imin,0)
+C
+ endif
+C
+ if (imax < tab1) then
+C
+ i2 = -(imax - imin)
+C
+ else
+C
+ i2 = min(tab2 - imax,0)
+C
+ endif
+C
+ deb = lb + i1
+C
+ fin = ub + i2
+C
+C
+ End Subroutine GetLocalBoundaries
+C
+#endif
+C
+C
+#ifdef key_mpp_mpi
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_GlobtoLocInd2
+C **************************************************************************
+C
+ Subroutine Agrif_GlobtoLocInd2(tabarray,lboundl,uboundl,tab1,tab2,
+ & nbdim,rank,member)
+C
+CCC Description:
+CCC For a global index located on the current processor, tabarray gives the
+CCC corresponding local index
+C
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(nbdim) :: tab1,tab2
+ INTEGER,DIMENSION(nbdim,2,2 ) :: tabarray
+ INTEGER,DIMENSION(nbdim) :: lboundl,uboundl
+ INTEGER :: rank
+ LOGICAL :: member
+C
+C Local variables
+ INTEGER :: i,i1,k
+ INTEGER :: nbloc(nbdim)
+C
+C
+ tabarray(:,1,:) = HUGE(1)
+ tabarray(:,2,:) = -HUGE(1)
+
+ nbloc = 0
+C
+ do i = 1,nbdim
+C
+ Call Agrif_Invloc(lboundl(i),rank,i,i1)
+
+ do k=tab1(i)+lboundl(i)-i1,tab2(i)+lboundl(i)-i1
+ IF ((k .GE. lboundl(i)) .AND. (k.LE.uboundl(i))) THEN
+ nbloc(i) = 1
+ tabarray(i,1,1) = min(tabarray(i,1,1),k-lboundl(i)+i1)
+ tabarray(i,2,1) = max(tabarray(i,2,1),k-lboundl(i)+i1)
+
+ tabarray(i,1,2) = min(tabarray(i,1,2),k)
+ tabarray(i,2,2) = max(tabarray(i,2,2),k)
+ ENDIF
+ enddo
+C
+ enddo
+
+ member = .FALSE.
+ IF (sum(nbloc) == nbdim) member = .TRUE.
+C
+ Return
+C
+C
+ End Subroutine Agrif_GlobtoLocInd2
+C
+#endif
+
+ Subroutine Agrif_Copy_2d(tabout,tabin,l,m,inf,sup,inf2,sup2)
+ integer,dimension(2) :: l,m,inf,sup,inf2,sup2
+ real,target,dimension(l(1):,l(2):) :: tabout
+ real,target,dimension(m(1):,m(2):) :: tabin
+ tabout(inf(1):sup(1),
+ & inf(2):sup(2)) =
+ & tabin(inf2(1):sup2(1),
+ & inf2(2):sup2(2))
+ End Subroutine Agrif_Copy_2d
+
+ Subroutine Agrif_Copy_3d(tabout,tabin,l,m,inf,sup,inf2,sup2)
+ integer,dimension(3) :: l,m,inf,sup,inf2,sup2
+ real,target,dimension(l(1):,l(2):,l(3):) :: tabout
+ real,target,dimension(m(1):,m(2):,m(3):) :: tabin
+ tabout(inf(1):sup(1),
+ & inf(2):sup(2),
+ & inf(3):sup(3)) =
+ & tabin(inf2(1):sup2(1),
+ & inf2(2):sup2(2),
+ & inf2(3):sup2(3))
+ End Subroutine Agrif_Copy_3d
+
+ Subroutine Agrif_Copy_4d(tabout,tabin,l,m,inf,sup,inf2,sup2)
+ integer,dimension(4) :: l,m,inf,sup,inf2,sup2
+ real,target,dimension(l(1):,l(2):,l(3):,l(4):) :: tabout
+ real,target,dimension(m(1):,m(2):,m(3):,m(4):) :: tabin
+ tabout(inf(1):sup(1),
+ & inf(2):sup(2),
+ & inf(3):sup(3),
+ & inf(4):sup(4)) =
+ & tabin(inf2(1):sup2(1),
+ & inf2(2):sup2(2),
+ & inf2(3):sup2(3),
+ & inf2(4):sup2(4))
+ End Subroutine Agrif_Copy_4d
+
+ End Module Agrif_Arrays
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modbc.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modbc.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modbc.F (revision 8155)
@@ -0,0 +1,1337 @@
+!
+! $Id: modbc.F 2731 2011-04-08 12:05:35Z rblod $
+!
+C AGRIF (Adaptive Grid Refinement In Fortran)
+C
+C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
+C Christophe Vouland (Christophe.Vouland@imag.fr)
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.
+C
+C
+C
+CCC Module Agrif_Boundary
+C
+ Module Agrif_Boundary
+C
+CCC Description:
+CCC Module to calculate the boundary conditions on the child grids from their
+CCC parent grids.
+C
+C Modules used:
+C
+ Use Agrif_Interpolation
+C
+ IMPLICIT NONE
+C
+ CONTAINS
+C Define procedures contained in this module
+C
+C
+
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_bc_1d
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_bc_1d(TypeInterp,parent,child,tab,deb,fin,
+ & weight,pweight,procname)
+C
+CCC Description:
+CCC Subroutine to calculate the boundary conditions on a fine grid for a 1D
+CCC grid variable.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ External :: procname
+ Optional :: procname
+ INTEGER,DIMENSION(6,6) :: TypeInterp ! TYPE of interpolation (linear,
+ ! lagrange, spline, ... )
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
+ ! grid
+ INTEGER :: deb,fin ! Positions where interpolations are
+ ! done on the fine grid
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1)
+ & ), Target :: tab ! Values of the grid variable
+ LOGICAL :: pweight ! Indicates if weight is used for
+ ! the temporal interpolation
+ REAL :: weight ! Coefficient for the time
+ ! interpolation
+C
+C
+C Definition of a temporary AGRIF_PVariable data TYPE representing the grid
+C variable.
+C
+ allocate(childtemp % var)
+C
+ childtemp % var % root_var => child % var % root_var
+C
+C Values of the grid variable
+ childtemp % var % parray1 => tab
+C
+C Temporary results for the time interpolation before and after the space
+C interpolation
+ childtemp % var % oldvalues2D => child % var % oldvalues2D
+C
+C Index indicating if a space interpolation is necessary
+ childtemp % var % interpIndex => child % var % interpIndex
+ childtemp % var % Interpolationshouldbemade =
+ & child % var % Interpolationshouldbemade
+ childtemp % var % list_interp => child % var% list_interp
+
+ childtemp % var% lb = child % var % lb
+ childtemp % var% ub = child % var % ub
+C
+C Call to the procedure for the calculations of the boundary conditions
+ IF (present(procname)) THEN
+ Call Agrif_CorrectVariable
+ & (TypeInterp,parent,childtemp,deb,fin,pweight,weight,procname)
+ ELSE
+ Call Agrif_CorrectVariable
+ & (TypeInterp,parent,childtemp,deb,fin,pweight,weight)
+ ENDIF
+
+C
+ child % var % oldvalues2D => childtemp % var % oldvalues2D
+ child % var % list_interp => childtemp % var %list_interp
+C
+ deallocate(childtemp % var)
+C
+C
+ End Subroutine Agrif_Interp_bc_1D
+C
+
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_bc_2d
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_bc_2d(TypeInterp,parent,child,tab,deb,fin,
+ & weight,pweight,procname)
+C
+CCC Description:
+CCC Subroutine to calculate the boundary conditions on a fine grid for a 2D
+CCC grid variable.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ External :: procname
+ Optional :: procname
+ INTEGER,DIMENSION(6,6) :: TypeInterp ! TYPE of interpolation (linear,
+ ! lagrange, spline, ... )
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
+ ! grid
+ INTEGER :: deb,fin ! Positions where interpolations are
+ ! done on the fine grid
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1),
+ & child%var%lb(2):child%var%ub(2)
+ & ), Target :: tab ! Values of the grid variable
+ LOGICAL :: pweight ! Indicates if weight is used for
+ ! the temporal interpolation
+ REAL :: weight ! Coefficient for the time
+ ! interpolation
+C
+C
+C Definition of a temporary AGRIF_PVariable data TYPE representing the grid
+C variable.
+C
+ allocate(childtemp % var)
+C
+ childtemp % var % root_var => child % var % root_var
+C
+C Values of the grid variable
+ childtemp % var % parray2 => tab
+C
+C Temporary results for the time interpolation before and after the space
+C interpolation
+ childtemp % var % oldvalues2D => child % var % oldvalues2D
+C
+C Index indicating if a space interpolation is necessary
+ childtemp % var % interpIndex => child % var % interpIndex
+ childtemp % var % Interpolationshouldbemade =
+ & child % var % Interpolationshouldbemade
+ childtemp % var % list_interp => child % var% list_interp
+
+ childtemp % var% lb = child % var % lb
+ childtemp % var% ub = child % var % ub
+C
+C Call to the procedure for the calculations of the boundary conditions
+ IF (present(procname)) THEN
+ Call Agrif_CorrectVariable
+ & (TypeInterp,parent,childtemp,deb,fin,pweight,weight,procname)
+ ELSE
+ Call Agrif_CorrectVariable
+ & (TypeInterp,parent,childtemp,deb,fin,pweight,weight)
+ ENDIF
+
+C
+ child % var % oldvalues2D => childtemp % var % oldvalues2D
+ child % var % list_interp => childtemp % var %list_interp
+C
+ deallocate(childtemp % var)
+C
+C
+ End Subroutine Agrif_Interp_bc_2D
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_bc_3d
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_bc_3d(TypeInterp,parent,child,tab,deb,fin,
+ & weight,pweight,procname)
+C
+CCC Description:
+CCC Subroutine to calculate the boundary conditions on a fine grid for a 3D
+CCC variable.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ External :: procname
+ Optional :: procname
+ INTEGER,DIMENSION(6,6) :: TypeInterp ! TYPE of interpolation (linear,
+ ! lagrange, spline, ... )
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
+ ! grid
+ INTEGER :: deb,fin ! Positions where interpolations
+ ! are done on the fine grid
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1),
+ & child%var%lb(2):child%var%ub(2),
+ & child%var%lb(3):child%var%ub(3)
+ & ), Target :: tab ! Values of the grid variable
+ LOGICAL :: pweight ! Indicates if weight is used for
+ ! the temporal interpolation
+ REAL :: weight ! Coefficient for the time
+ ! interpolation
+C
+C
+C Definition of a temporary AGRIF_PVariable data TYPE representing the grid
+C variable.
+C
+ allocate(childtemp % var)
+C
+ childtemp % var % root_var => child % var % root_var
+C
+C Values of the grid variable
+ childtemp % var % parray3 => tab
+C
+C Temporary results for the time interpolation before and after the space
+C interpolation
+ childtemp % var % oldvalues2D => child % var % oldvalues2D
+C
+C Index indicating if a space interpolation is necessary
+ childtemp % var % interpIndex => child % var % interpIndex
+ childtemp % var % Interpolationshouldbemade =
+ & child % var % Interpolationshouldbemade
+ childtemp % var % list_interp => child % var% list_interp
+
+ childtemp % var% lb = child % var % lb
+ childtemp % var% ub = child % var % ub
+C
+C Call to the procedure for the calculations of the boundary conditions
+ IF (present(procname)) THEN
+ Call Agrif_CorrectVariable
+ & (TypeInterp,parent,childtemp,deb,fin,pweight,weight,procname)
+ ELSE
+ Call Agrif_CorrectVariable
+ & (TypeInterp,parent,childtemp,deb,fin,pweight,weight)
+ ENDIF
+C
+ child % var % oldvalues2D => childtemp % var % oldvalues2D
+ child % var % list_interp => childtemp % var %list_interp
+C
+ deallocate(childtemp % var)
+C
+C
+ End Subroutine Agrif_Interp_bc_3D
+C
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_bc_4d
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_bc_4d(TypeInterp,parent,child,tab,deb,fin,
+ & weight,pweight,procname)
+C
+CCC Description:
+CCC Subroutine to calculate the boundary conditions on a fine grid for a 4D
+CCC grid variable.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ External :: procname
+ Optional :: procname
+ INTEGER,DIMENSION(6,6) :: TypeInterp ! TYPE of interpolation (linear,
+ ! lagrange, spline, ... )
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary varaiable on the child
+ ! grid
+ INTEGER :: deb,fin ! Positions where interpolations
+ ! are done on the fine grid
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1),
+ & child%var%lb(2):child%var%ub(2),
+ & child%var%lb(3):child%var%ub(3),
+ & child%var%lb(4):child%var%ub(4)
+ & ), Target :: tab ! Values of the grid variable
+ LOGICAL :: pweight ! Indicates if weight is used for
+ ! the temporal interpolation
+ REAL :: weight ! Coefficient for the time
+ ! interpolation
+C
+C
+C Definition of a temporary AGRIF_PVariable data TYPE representing the grid
+C variable.
+C
+ allocate(childtemp % var)
+C
+ childtemp % var % root_var => child % var % root_var
+C
+C Values of the grid variable
+ childtemp % var % parray4 => tab
+C
+C Temporary results for the time interpolation before and after the space
+C interpolation
+ childtemp % var % oldvalues2D => child % var % oldvalues2D
+C
+C Index indicating if a space interpolation is necessary
+ childtemp % var % interpIndex => child % var % interpIndex
+ childtemp % var % Interpolationshouldbemade =
+ & child % var % Interpolationshouldbemade
+ childtemp % var % list_interp => child % var% list_interp
+
+ childtemp % var% lb = child % var % lb
+ childtemp % var% ub = child % var % ub
+C
+C Call to the procedure for the calculations of the boundary conditions
+ IF (present(procname)) THEN
+ Call Agrif_CorrectVariable
+ & (TypeInterp,parent,childtemp,deb,fin,pweight,weight,procname)
+ ELSE
+ Call Agrif_CorrectVariable
+ & (TypeInterp,parent,childtemp,deb,fin,pweight,weight)
+ ENDIF
+C
+ child % var % oldvalues2D => childtemp % var % oldvalues2D
+ child % var % list_interp => childtemp % var %list_interp
+C
+ deallocate(childtemp % var)
+C
+C
+ End Subroutine Agrif_Interp_bc_4D
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_bc_5d
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_bc_5d(TypeInterp,parent,child,tab,deb,fin,
+ & weight,pweight,procname)
+C
+CCC Description:
+CCC Subroutine to calculate the boundary conditions on a fine grid for a 5D
+CCC grid variable.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ External :: procname
+ Optional :: procname
+ INTEGER,DIMENSION(6,6) :: TypeInterp ! TYPE of interpolation (linear,
+ ! lagrange, spline, ... )
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary varaiable on the child
+ ! grid
+ INTEGER :: deb,fin ! Positions where interpolations
+ ! are done on the fine grid
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1),
+ & child%var%lb(2):child%var%ub(2),
+ & child%var%lb(3):child%var%ub(3),
+ & child%var%lb(4):child%var%ub(4),
+ & child%var%lb(5):child%var%ub(5)
+ & ), Target :: tab ! Values of the grid variable
+ LOGICAL :: pweight ! Indicates if weight is used for
+ ! the temporal interpolation
+ REAL :: weight ! Coefficient for the time
+ ! interpolation
+C
+C
+C Definition of a temporary AGRIF_PVariable data TYPE representing the grid
+C variable.
+C
+ allocate(childtemp % var)
+C
+ childtemp % var % root_var => child % var % root_var
+C
+C Values of the grid variable
+ childtemp % var % parray5 => tab
+C
+C Temporary results for the time interpolation before and after the space
+C interpolation
+ childtemp % var % oldvalues2D => child % var % oldvalues2D
+C
+C Index indicating if a space interpolation is necessary
+ childtemp % var % interpIndex => child % var % interpIndex
+ childtemp % var % Interpolationshouldbemade =
+ & child % var % Interpolationshouldbemade
+ childtemp % var % list_interp => child % var% list_interp
+
+ childtemp % var% lb = child % var % lb
+ childtemp % var% ub = child % var % ub
+
+C
+C Call to the procedure for the calculations of the boundary conditions
+ IF (present(procname)) THEN
+ Call Agrif_CorrectVariable
+ & (TypeInterp,parent,childtemp,deb,fin,pweight,weight,procname)
+ ELSE
+ Call Agrif_CorrectVariable
+ & (TypeInterp,parent,childtemp,deb,fin,pweight,weight)
+ ENDIF
+C
+ child % var % oldvalues2D => childtemp % var % oldvalues2D
+ child % var % list_interp => childtemp % var %list_interp
+C
+ deallocate(childtemp % var)
+C
+C
+ End Subroutine Agrif_Interp_bc_5D
+C
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_bc_6d
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_bc_6d(TypeInterp,parent,child,tab,deb,fin,
+ & weight,pweight)
+C
+CCC Description:
+CCC Subroutine to calculate the boundary conditions on a fine grid for a 6D
+CCC grid variable.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER,DIMENSION(6,6) :: TypeInterp ! TYPE of interpolation (linear,
+ ! lagrange, spline, ... )
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary varaiable on the child
+ ! grid
+ INTEGER :: deb,fin ! Positions where interpolations
+ ! are done on the fine grid
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1),
+ & child%var%lb(2):child%var%ub(2),
+ & child%var%lb(3):child%var%ub(3),
+ & child%var%lb(4):child%var%ub(4),
+ & child%var%lb(5):child%var%ub(5),
+ & child%var%lb(6):child%var%ub(6)
+ & ), Target :: tab ! Values of the grid variable
+ LOGICAL :: pweight ! Indicates if weight is used for
+ ! the temporal interpolation
+ REAL :: weight ! Coefficient for the time
+ ! interpolation
+C
+C
+C Definition of a temporary AGRIF_PVariable data TYPE representing the grid
+C variable.
+C
+ allocate(childtemp % var)
+C
+ childtemp % var % root_var => child % var % root_var
+C
+C Values of the grid variable
+ childtemp % var % parray6 => tab
+C
+C Temporary results for the time interpolation before and after the space
+C interpolation
+ childtemp % var % oldvalues2D => child % var % oldvalues2D
+C
+C Index indicating if a space interpolation is necessary
+ childtemp % var % interpIndex => child % var % interpIndex
+ childtemp % var % Interpolationshouldbemade =
+ & child % var % Interpolationshouldbemade
+ childtemp % var % list_interp => child % var% list_interp
+
+ childtemp % var% lb = child % var % lb
+ childtemp % var% ub = child % var % ub
+C
+C Call to the procedure for the calculations of the boundary conditions
+ Call Agrif_CorrectVariable
+ & (TypeInterp,parent,childtemp,deb,fin,pweight,weight)
+C
+ child % var % oldvalues2D => childtemp % var % oldvalues2D
+ child % var % list_interp => childtemp % var %list_interp
+C
+ deallocate(childtemp % var)
+C
+C
+ End Subroutine Agrif_Interp_bc_6D
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_CorrectVariable
+C **************************************************************************
+C
+ Subroutine AGRIF_CorrectVariable(TypeInterp,parent,child,deb,fin,
+ & pweight,weight,procname)
+C
+CCC Description:
+CCC Subroutine to calculate the boundary conditions on a fine grid.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ External :: procname
+ Optional :: procname
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ INTEGER,DIMENSION(6,6) :: TypeInterp ! TYPE of interpolation
+ ! (linear,lagrange,...)
+ INTEGER :: deb,fin ! Positions where boundary
+ ! conditions are calculated
+ LOGICAL :: pweight ! Indicates if weight is used
+ ! for the time interpolation
+ REAL :: weight ! Coefficient for the time
+ ! interpolation
+C
+C Local scalars
+ TYPE(Agrif_Grid) , Pointer :: Agrif_Child_Gr,Agrif_Parent_Gr
+ TYPE(AGRIF_Variable), Pointer :: root ! Variable on the root grid
+ INTEGER :: nbdim ! Number of dimensions of
+ ! the grid variable
+ INTEGER :: n
+ INTEGER,DIMENSION(6) :: pttab_child ! Index of the first point
+ ! inside the domain for
+ ! the child grid variable
+ INTEGER,DIMENSION(6) :: pttab_parent ! Index of the first point
+ ! inside the domain for
+ ! the parent grid
+ ! variable
+ INTEGER,DIMENSION(6) :: nbtab_Child ! Number of the cells
+ INTEGER,DIMENSION(6) :: posvartab_Child ! Position of the
+ ! variable on the cell
+ INTEGER,DIMENSION(6) :: loctab_Child ! Indicates if the child
+ ! grid has a common
+ ! border with the root
+ ! grid
+ REAL, DIMENSION(6) :: s_child,s_parent ! Positions of the
+ ! parent and child grids
+ REAL, DIMENSION(6) :: ds_child,ds_parent ! Space steps of the
+ ! parent and child grids
+C
+C
+ loctab_child(:) = 0
+C
+ Agrif_Child_Gr => Agrif_Curgrid
+ Agrif_Parent_Gr => Agrif_Curgrid % parent
+ root => child % var % root_var
+ nbdim = root % nbdim
+C
+ do n = 1,nbdim
+ posvartab_child(n) = root % posvar(n)
+ enddo
+C
+C
+ do n = 1,nbdim
+C
+ Select case(root % interptab(n))
+C
+ case('x') ! x DIMENSION
+C
+ nbtab_Child(n) = Agrif_Child_Gr % nb(1)
+ pttab_Child(n) = root % point(1)
+ pttab_Parent(n) = root % point(1)
+ s_Child(n) = Agrif_Child_Gr % Agrif_x(1)
+ s_Parent(n) = Agrif_Parent_Gr % Agrif_x(1)
+ ds_Child(n) = Agrif_Child_Gr % Agrif_d(1)
+ ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(1)
+ if (root % posvar(n) == 2) then
+ s_Child(n) = s_Child(n) + ds_Child(n)/2.
+ s_Parent(n) = s_Parent(n) + ds_Parent(n)/2.
+ endif
+C
+ if (Agrif_CURGRID % NearRootBorder(1))
+ & loctab_child(n) = -1
+ if (Agrif_CURGRID % DistantRootBorder(1))
+ & loctab_child(n) = -2
+ if ((Agrif_CURGRID % NearRootBorder(1)) .AND.
+ & (Agrif_CURGRID % DistantRootBorder(1)))
+ & loctab_child(n) = -3
+C
+ case('y') ! y DIMENSION
+C
+ nbtab_Child(n) = Agrif_Child_Gr % nb(2)
+ pttab_Child(n) = root % point(2)
+ pttab_Parent(n) = root % point(2)
+ s_Child(n) = Agrif_Child_Gr % Agrif_x(2)
+ s_Parent(n) = Agrif_Parent_Gr % Agrif_x(2)
+ ds_Child(n) = Agrif_Child_Gr % Agrif_d(2)
+ ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(2)
+ if (root % posvar(n) == 2) then
+ s_Child(n) = s_Child(n) + ds_Child(n)/2.
+ s_Parent(n) = s_Parent(n) + ds_Parent(n)/2.
+ endif
+C
+ if (Agrif_CURGRID % NearRootBorder(2))
+ & loctab_child(n) = -1
+ if (Agrif_CURGRID % DistantRootBorder(2))
+ & loctab_child(n) = -2
+ if ((Agrif_CURGRID % NearRootBorder(2)) .AND.
+ & (Agrif_CURGRID % DistantRootBorder(2)))
+ & loctab_child(n) = -3
+C
+ case('z') ! z DIMENSION
+C
+ nbtab_Child(n) = Agrif_Child_Gr % nb(3)
+ pttab_Child(n) = root % point(3)
+ pttab_Parent(n) = root % point(3)
+ s_Child(n) = Agrif_Child_Gr % Agrif_x(3)
+ s_Parent(n) = Agrif_Parent_Gr % Agrif_x(3)
+ ds_Child(n) = Agrif_Child_Gr % Agrif_d(3)
+ ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(3)
+ if (root % posvar(n) == 2) then
+ s_Child(n) = s_Child(n) + ds_Child(n)/2.
+ s_Parent(n) = s_Parent(n) + ds_Parent(n)/2.
+ endif
+C
+ if (Agrif_CURGRID % NearRootBorder(3))
+ & loctab_child(n) = -1
+ if (Agrif_CURGRID % DistantRootBorder(3))
+ & loctab_child(n) = -2
+ if ((Agrif_CURGRID % NearRootBorder(3)) .AND.
+ & (Agrif_CURGRID % DistantRootBorder(3)))
+ & loctab_child(n) = -3
+C
+ case('N') ! No space DIMENSION
+C
+ nbtab_Child(n) = child % var % ub(n) - child % var % lb(n)
+ pttab_Child(n) = child % var % lb(n)
+C
+C No interpolation but only a copy of the values of the grid variable
+C
+ posvartab_child(n) = 1
+ pttab_Parent(n)= pttab_Child(n)
+ s_Child(n)=0.
+ s_Parent(n)=0.
+ ds_Child(n)=1.
+ ds_Parent(n)=1.
+ loctab_child(n) = -3
+C
+ End select
+C
+ enddo
+C
+ IF (present(procname)) THEN
+ Call AGRIF_CorrectnD
+ & (TypeInterp,parent,child,deb,fin,pweight,weight,
+ & pttab_Child(1:nbdim),pttab_Parent(1:nbdim),
+ & nbtab_Child(1:nbdim),posvartab_Child(1:nbdim),
+ & loctab_Child(1:nbdim),
+ & s_Child(1:nbdim),s_Parent(1:nbdim),
+ & ds_Child(1:nbdim),ds_Parent(1:nbdim),nbdim,procname)
+ ELSE
+ Call AGRIF_CorrectnD
+ & (TypeInterp,parent,child,deb,fin,pweight,weight,
+ & pttab_Child(1:nbdim),pttab_Parent(1:nbdim),
+ & nbtab_Child(1:nbdim),posvartab_Child(1:nbdim),
+ & loctab_Child(1:nbdim),
+ & s_Child(1:nbdim),s_Parent(1:nbdim),
+ & ds_Child(1:nbdim),ds_Parent(1:nbdim),nbdim)
+ ENDIF
+C
+C
+ End subroutine AGRIF_CorrectVariable
+C
+C **************************************************************************
+CCC Subroutine Agrif_Correctnd
+C **************************************************************************
+C
+ Subroutine AGRIF_Correctnd(TypeInterp,parent,child,deb,fin,
+ & pweight,weight,
+ & pttab_child,pttab_Parent,
+ & nbtab_Child,posvartab_Child,
+ & loctab_Child,
+ & s_Child,s_Parent,
+ & ds_Child,ds_Parent,nbdim,procname)
+C
+CCC Description:
+CCC Subroutine to calculate the boundary conditions for a nD grid variable on
+CCC a fine grid by using a space and time interpolations; it is called by the
+CCC Agrif_CorrectVariable procedure.
+C
+C
+C Declarations:
+C
+
+C
+#ifdef key_mpp_mpi
+C
+ INCLUDE 'mpif.h'
+C
+#endif
+C
+C Arguments
+ External :: procname
+ Optional :: procname
+ INTEGER,DIMENSION(6,6) :: TypeInterp ! TYPE of interpolation (linear,
+ ! spline,...)
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ INTEGER :: deb,fin ! Positions where interpolations
+ ! are done
+ LOGICAL :: pweight ! Indicates if weight is used for
+ ! the temporal interpolation
+ REAL :: weight ! Coefficient for the temporal
+ ! interpolation
+ INTEGER :: nbdim ! Number of dimensions of the grid
+ ! variable
+ INTEGER,DIMENSION(nbdim) :: pttab_child ! Index of the first point inside
+ ! the domain for the parent
+ ! grid variable
+ INTEGER,DIMENSION(nbdim) :: pttab_Parent ! Index of the first point
+ ! inside the domain for the
+ ! child grid variable
+ INTEGER,DIMENSION(nbdim) :: nbtab_Child ! Number of cells of the child
+ ! grid
+ INTEGER,DIMENSION(nbdim) :: posvartab_Child ! Position of the grid
+ ! variable (1 or 2)
+ INTEGER,DIMENSION(nbdim) :: loctab_Child ! Indicates if the child
+ ! grid has a common border with
+ ! the root grid
+ REAL ,DIMENSION(nbdim) :: s_Child,s_Parent ! Positions of the parent
+ ! and child grids
+ REAL ,DIMENSION(nbdim) :: ds_Child,ds_Parent ! Space steps of the
+ ! parent and child grids
+C
+C Local variables
+ TYPE(AGRIF_PVariable) :: restore ! Variable on the parent
+ INTEGER,DIMENSION(nbdim,2) :: lubglob
+ INTEGER :: i
+ INTEGER :: kindex ! Index used for safeguard
+ ! and time interpolation
+ INTEGER,DIMENSION(nbdim,2,2) :: indtab ! Arrays indicating the limits
+ ! of the child
+ INTEGER,DIMENSION(nbdim,2,2) :: indtruetab ! grid variable where
+ ! boundary conditions are
+ INTEGER,DIMENSION(nbdim,2,2,nbdim) :: ptres,ptres2 ! calculated
+ INTEGER :: nb,ndir,n,sizetab(1)
+ REAL, DIMENSION(:), Allocatable :: tab ! Array used for the interpolation
+ REAL :: c1t,c2t ! Coefficients for the time interpolation
+ ! (c2t=1-c1t)
+C
+#ifdef key_mpp_mpi
+C
+ INTEGER,DIMENSION(nbdim) :: lower,upper
+ INTEGER,DIMENSION(nbdim) :: ltab,utab
+ INTEGER,DIMENSION(nbdim) :: lb,ub
+ INTEGER,DIMENSION(nbdim,2) :: iminmaxg
+ INTEGER :: code
+C
+#endif
+C
+C
+ indtab(1:nbdim,2,1) = pttab_child(1:nbdim) + nbtab_child(1:nbdim)
+ & + deb
+ indtab(1:nbdim,2,2) = indtab(1:nbdim,2,1) + ( fin - deb )
+
+ indtab(1:nbdim,1,1) = pttab_child(1:nbdim) - fin
+ indtab(1:nbdim,1,2) = pttab_child(1:nbdim) - deb
+
+ WHERE (posvartab_child(1:nbdim) == 2)
+ indtab(1:nbdim,1,1) = indtab(1:nbdim,1,1) - 1
+ indtab(1:nbdim,1,2) = indtab(1:nbdim,1,2) - 1
+ END WHERE
+
+
+#if !defined key_mpp_mpi
+ Call Agrif_nbdim_Get_bound_dimension(child%var,lubglob(:,1),
+ & lubglob(:,2),nbdim)
+C
+#else
+C
+ Call Agrif_nbdim_Get_bound_dimension(child%var,lb,ub,nbdim)
+
+ DO i = 1,nbdim
+C
+ Call Agrif_Invloc(lb(i),Agrif_Procrank,i,iminmaxg(i,1))
+ Call Agrif_Invloc(ub(i),Agrif_Procrank,i,iminmaxg(i,2))
+C
+ ENDDO
+C
+ iminmaxg(1:nbdim,2) = - iminmaxg(1:nbdim,2)
+
+ CALL MPI_ALLREDUCE(iminmaxg,lubglob,2*nbdim,MPI_INTEGER,MPI_MIN,
+ & MPI_COMM_AGRIF,code)
+
+ lubglob(1:nbdim,2) = - lubglob(1:nbdim,2)
+C
+#endif
+C
+ indtruetab(1:nbdim,1,1) = max(indtab(1:nbdim,1,1),
+ & lubglob(1:nbdim,1))
+ indtruetab(1:nbdim,1,2) = max(indtab(1:nbdim,1,2),
+ & lubglob(1:nbdim,1))
+ indtruetab(1:nbdim,2,1) = min(indtab(1:nbdim,2,1),
+ & lubglob(1:nbdim,2))
+ indtruetab(1:nbdim,2,2) = min(indtab(1:nbdim,2,2),
+ & lubglob(1:nbdim,2))
+
+
+C
+C
+ do nb = 1,nbdim
+C
+ do ndir = 1,2
+C
+ if (loctab_child(nb) /= (-ndir)
+ & .AND. loctab_child(nb) /= -3) then
+C
+ do n = 1,2
+C
+ ptres(nb,n,ndir,nb) = indtruetab(nb,ndir,n)
+C
+ enddo
+C
+ do i = 1,nbdim
+C
+ if (i .NE. nb) then
+C
+ if (loctab_child(i) == -1
+ & .OR. loctab_child(i) == -3) then
+C
+ ptres(i,1,ndir,nb) = pttab_child(i)
+C
+ else
+C
+ ptres(i,1,ndir,nb) = indtruetab(i,1,1)
+C
+ endif
+C
+ if (loctab_child(i) == -2
+ & .OR. loctab_child(i) == -3) then
+C
+ if (posvartab_child(i) == 1) then
+C
+ ptres(i,2,ndir,nb) = pttab_child(i)
+ & + nbtab_child(i)
+C
+ else
+C
+ ptres(i,2,ndir,nb) = pttab_child(i)
+ & + nbtab_child(i) - 1
+C
+ endif
+C
+ else
+C
+ ptres(i,2,ndir,nb) = indtruetab(i,2,2)
+C
+ endif
+C
+ endif
+C
+ enddo
+
+C
+#if defined key_mpp_mpi
+ Call Agrif_nbdim_Get_bound_dimension
+ & (child%var,lower,upper,nbdim)
+
+ do i = 1,nbdim
+C
+ Call GetLocalBoundaries(ptres(i,1,ndir,nb),
+ & ptres(i,2,ndir,nb),i,
+ & lower(i),upper(i),
+ & ltab(i),utab(i))
+ ptres2(i,1,ndir,nb) = max(ltab(i),lower(i))
+ ptres2(i,2,ndir,nb) = min(utab(i),upper(i))
+ if ((i == nb) .AND. (ndir == 1)) then
+ ptres2(i,2,ndir,nb) = max(utab(i),lower(i))
+ elseif ((i == nb) .AND. (ndir == 2)) then
+ ptres2(i,1,ndir,nb) = min(ltab(i),upper(i))
+ endif
+C
+ enddo
+#else
+ ptres2(:,:,ndir,nb) = ptres(:,:,ndir,nb)
+#endif
+
+ endif
+
+ enddo
+ enddo
+C
+ if (child % var % interpIndex
+ & /= Agrif_Curgrid % parent % ngridstep .OR.
+ & child%var%Interpolationshouldbemade ) then
+C
+C Space interpolation
+C
+ kindex = 1
+
+
+C
+ do nb = 1,nbdim
+C
+ do ndir = 1,2
+C
+ if (loctab_child(nb) /= (-ndir)
+ & .AND. loctab_child(nb) /= -3) then
+C
+ IF (present(procname)) THEN
+ Call Agrif_InterpnD
+ & (TYPEInterp(nb,:),parent,child,
+ & ptres(1:nbdim,1,ndir,nb),ptres(1:nbdim,2,ndir,nb),
+ & pttab_child(1:nbdim),pttab_Parent(1:nbdim),
+ & s_Child(1:nbdim),s_Parent(1:nbdim),
+ & ds_Child(1:nbdim),ds_Parent(1:nbdim),
+ & restore,.FALSE.,nbdim,procname)
+ ELSE
+ Call Agrif_InterpnD
+ & (TYPEInterp(nb,:),parent,child,
+ & ptres(1:nbdim,1,ndir,nb),ptres(1:nbdim,2,ndir,nb),
+ & pttab_child(1:nbdim),pttab_Parent(1:nbdim),
+ & s_Child(1:nbdim),s_Parent(1:nbdim),
+ & ds_Child(1:nbdim),ds_Parent(1:nbdim),
+ & restore,.FALSE.,nbdim)
+ ENDIF
+
+ IF (.NOT. child%var%interpolationshouldbemade) THEN
+C
+C Safeguard of the values of the grid variable (at times n and n+1
+C on the parent grid)
+C
+ sizetab(1) = 1
+C
+ do i = 1,nbdim
+C
+ sizetab(1) = sizetab(1)
+ & * (ptres2(i,2,ndir,nb)-ptres2(i,1,ndir,nb)+1)
+C
+ enddo
+
+ Call saveAfterInterp(child,
+ & ptres2(:,:,ndir,nb),kindex,sizetab(1),nbdim)
+C
+ ENDIF
+C
+ endif
+C
+ enddo
+C
+ enddo
+C
+C
+ child % var % interpIndex = Agrif_Curgrid % parent % ngridstep
+C
+C
+ endif
+
+ IF (.NOT. child%var%interpolationshouldbemade) THEN
+C
+C
+C Calculation of the coefficients c1t and c2t for the temporary
+C interpolation
+ if (pweight) then
+C
+ c1t = weight
+C
+ else
+C
+ c1t = (REAL(AGRIF_Nbstepint()) + 1.) / Agrif_Rhot()
+C
+ endif
+C
+ c2t = 1. - c1t
+C
+C Time interpolation
+C
+ kindex = 1
+C
+ do nb = 1,nbdim
+C
+ do ndir = 1,2
+C
+ if (loctab_child(nb) /= (-ndir)
+ & .AND. loctab_child(nb) /= -3) then
+
+ Call timeInterpolation
+ & (child,ptres2(:,:,ndir,nb),kindex,c1t,c2t,nbdim)
+ endif
+C
+ enddo
+C
+ enddo
+C
+
+ ENDIF
+C
+ End Subroutine Agrif_Correctnd
+C
+C
+C **************************************************************************
+CCC Subroutine saveAfterInterp
+C **************************************************************************
+C
+ Subroutine saveAfterInterp(child,bounds,kindex,newsize,nbdim)
+C
+CCC Descritpion:
+CCC Subroutine used to save the values of the grid variable on the fine grid
+CCC after the space interpolation.
+C
+C Declarations:
+C
+
+C
+C argument
+ TYPE (AGRIF_PVariable) :: child ! The fine grid variable
+ INTEGER :: kindex ! Index indicating where this safeguard
+ ! is done on the fine grid
+ INTEGER :: nbdim, newsize
+ INTEGER,DIMENSION(nbdim,2) :: bounds
+C
+C Local scalars
+ INTEGER :: ir,jr,kr,lr,mr,nr
+C
+C
+C Allocation of the array oldvalues2d
+
+C
+ if (newsize .LE. 0) return
+C
+ Call Agrif_Checksize
+ & (child,kindex+newsize)
+
+ if (child % var % interpIndex
+ & /= Agrif_Curgrid % parent % ngridstep ) then
+ child%var%oldvalues2d(1,kindex:kindex+newsize-1)=
+ & child%var%oldvalues2d(2,kindex:kindex+newsize-1)
+ endif
+
+ SELECT CASE (nbdim)
+ CASE (1)
+
+!CDIR ALTCODE
+ do ir=bounds(1,1),bounds(1,2)
+ child%var%oldvalues2d(2,kindex) =
+ & child%var%parray1(ir)
+ kindex = kindex + 1
+ enddo
+C
+ CASE (2)
+
+ do jr=bounds(2,1),bounds(2,2)
+!CDIR ALTCODE
+ do ir=bounds(1,1),bounds(1,2)
+ child%var%oldvalues2d(2,kindex) =
+ & child%var%parray2(ir,jr)
+ kindex = kindex + 1
+ enddo
+ enddo
+C
+ CASE (3)
+ do kr=bounds(3,1),bounds(3,2)
+ do jr=bounds(2,1),bounds(2,2)
+!CDIR ALTCODE
+ do ir=bounds(1,1),bounds(1,2)
+ child%var%oldvalues2d(2,kindex) =
+ & child%var%parray3(ir,jr,kr)
+ kindex = kindex + 1
+ enddo
+ enddo
+ enddo
+C
+ CASE (4)
+ do lr=bounds(4,1),bounds(4,2)
+ do kr=bounds(3,1),bounds(3,2)
+ do jr=bounds(2,1),bounds(2,2)
+!CDIR ALTCODE
+ do ir=bounds(1,1),bounds(1,2)
+ child%var%oldvalues2d(2,kindex) =
+ & child%var%parray4(ir,jr,kr,lr)
+ kindex = kindex + 1
+ enddo
+ enddo
+ enddo
+ enddo
+C
+ CASE (5)
+ do mr=bounds(5,1),bounds(5,2)
+ do lr=bounds(4,1),bounds(4,2)
+ do kr=bounds(3,1),bounds(3,2)
+ do jr=bounds(2,1),bounds(2,2)
+!CDIR ALTCODE
+ do ir=bounds(1,1),bounds(1,2)
+ child%var%oldvalues2d(2,kindex) =
+ & child%var%parray5(ir,jr,kr,lr,mr)
+ kindex = kindex + 1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+C
+ CASE (6)
+ do nr=bounds(6,1),bounds(6,2)
+ do mr=bounds(5,1),bounds(5,2)
+ do lr=bounds(4,1),bounds(4,2)
+ do kr=bounds(3,1),bounds(3,2)
+ do jr=bounds(2,1),bounds(2,2)
+!CDIR ALTCODE
+ do ir=bounds(1,1),bounds(1,2)
+ child%var%oldvalues2d(2,kindex) =
+ & child%var%parray6(ir,jr,kr,lr,mr,nr)
+ kindex = kindex + 1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ END SELECT
+C
+C
+ End subroutine saveAfterInterp
+C
+C
+C
+C **************************************************************************
+CCC Subroutine timeInterpolation
+C **************************************************************************
+C
+ Subroutine timeInterpolation(child,bounds,kindex,c1t,c2t,nbdim)
+C
+CCC Descritpion:
+CCC Subroutine for a linear time interpolation on the child grid.
+C
+C Declarations:
+C
+
+C
+C argument
+ TYPE (AGRIF_PVariable) :: child ! The fine grid variable
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(nbdim,2) :: bounds
+ INTEGER :: kindex ! Index indicating the values of the fine
+ ! grid got before and after the space
+ ! interpolation and used for the time
+ ! interpolation
+ REAL :: c1t,c2t! coefficients for the time interpolation
+ ! (c2t=1-c1t)
+C
+C Local aruments
+ INTEGER :: i
+C Local scalars
+ INTEGER :: ir,jr,kr,lr,mr,nr
+C
+C
+
+ SELECT CASE (nbdim)
+ CASE (1)
+
+!CDIR ALTCODE
+ do ir=bounds(1,1),bounds(1,2)
+ child%var%parray1(ir) =
+ & c2t*child % var % oldvalues2d(1,kindex)
+ & + c1t*child % var % oldvalues2d(2,kindex)
+ kindex = kindex + 1
+ enddo
+C
+ CASE (2)
+
+ do jr=bounds(2,1),bounds(2,2)
+!CDIR ALTCODE
+ do ir=bounds(1,1),bounds(1,2)
+ child%var%parray2(ir,jr) =
+ & c2t*child % var % oldvalues2d(1,kindex)
+ & + c1t*child % var % oldvalues2d(2,kindex)
+ kindex = kindex + 1
+ enddo
+ enddo
+C
+ CASE (3)
+ do kr=bounds(3,1),bounds(3,2)
+ do jr=bounds(2,1),bounds(2,2)
+!CDIR ALTCODE
+ do ir=bounds(1,1),bounds(1,2)
+ child%var%parray3(ir,jr,kr) =
+ & c2t*child % var % oldvalues2d(1,kindex)
+ & + c1t*child % var % oldvalues2d(2,kindex)
+ kindex = kindex + 1
+ enddo
+ enddo
+ enddo
+C
+ CASE (4)
+ do lr=bounds(4,1),bounds(4,2)
+ do kr=bounds(3,1),bounds(3,2)
+ do jr=bounds(2,1),bounds(2,2)
+!CDIR ALTCODE
+ do ir=bounds(1,1),bounds(1,2)
+ child%var%parray4(ir,jr,kr,lr) =
+ & c2t*child % var % oldvalues2d(1,kindex)
+ & + c1t*child % var % oldvalues2d(2,kindex)
+ kindex = kindex + 1
+ enddo
+ enddo
+ enddo
+ enddo
+C
+ CASE (5)
+ do mr=bounds(5,1),bounds(5,2)
+ do lr=bounds(4,1),bounds(4,2)
+ do kr=bounds(3,1),bounds(3,2)
+ do jr=bounds(2,1),bounds(2,2)
+!CDIR ALTCODE
+ do ir=bounds(1,1),bounds(1,2)
+ child%var%parray5(ir,jr,kr,lr,mr) =
+ & c2t*child % var % oldvalues2d(1,kindex)
+ & + c1t*child % var % oldvalues2d(2,kindex)
+ kindex = kindex + 1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+C
+ CASE (6)
+ do nr=bounds(6,1),bounds(6,2)
+ do mr=bounds(5,1),bounds(5,2)
+ do lr=bounds(4,1),bounds(4,2)
+ do kr=bounds(3,1),bounds(3,2)
+ do jr=bounds(2,1),bounds(2,2)
+!CDIR ALTCODE
+ do ir=bounds(1,1),bounds(1,2)
+ child%var%parray6(ir,jr,kr,lr,mr,nr) =
+ & c2t*child % var % oldvalues2d(1,kindex)
+ & + c1t*child % var % oldvalues2d(2,kindex)
+ kindex = kindex + 1
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ END SELECT
+
+C
+C
+ End subroutine timeInterpolation
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Checksize
+C **************************************************************************
+C
+ Subroutine Agrif_Checksize(child,newsize)
+C
+CCC Descritpion:
+CCC Subroutine used in the saveAfterInterp procedure to allocate the
+CCC oldvalues2d array.
+C
+C Declarations:
+C
+
+C
+C TYPE argument
+ TYPE (AGRIF_PVariable) :: child ! The fine grid variable
+C
+C Scalar arguments
+ INTEGER :: newsize ! Size of the domains where the boundary
+ ! conditions are calculated
+C
+C Local arrays
+ REAL, DIMENSION(:,:), Allocatable :: tempoldvalues ! Temporary array
+C
+C
+ if (.NOT. associated(child % var % oldvalues2d)) then
+C
+ allocate(child % var % oldvalues2d(2,newsize))
+C
+ child % var % oldvalues2d=0.
+C
+ else
+C
+ if (SIZE(child % var % oldvalues2d,2) < newsize) then
+C
+ allocate(tempoldvalues(2,SIZE(child % var %
+ & oldvalues2d,2)))
+C
+ tempoldvalues = child % var % oldvalues2d
+C
+ deallocate(child % var % oldvalues2d)
+C
+ allocate(child % var % oldvalues2d(2,newsize))
+C
+ child%var%oldvalues2d=0.
+C
+ child % var % oldvalues2d(:,1:SIZE(tempoldvalues,2)) =
+ & tempoldvalues(:,:)
+C
+ deallocate(tempoldvalues)
+C
+ endif
+C
+ endif
+C
+C
+ End Subroutine Agrif_Checksize
+C
+C
+C
+C
+ End Module AGRIF_boundary
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modbcfunction.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modbcfunction.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modbcfunction.F (revision 8155)
@@ -0,0 +1,2448 @@
+!
+! $Id: modbcfunction.F 2715 2011-03-30 15:58:35Z rblod $
+!
+C AGRIF (Adaptive Grid Refinement In Fortran)
+C
+C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
+C Christophe Vouland (Christophe.Vouland@imag.fr)
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+C
+C
+C
+CCC Module AGRIF_bcfunction
+C
+C
+ Module Agrif_bcfunction
+CCC Description:
+CCC
+C
+C Modules used:
+C
+ Use Agrif_Boundary
+ Use Agrif_Update
+ Use Agrif_fluxmod
+ Use Agrif_Save
+C
+ IMPLICIT NONE
+C
+ interface Agrif_Bc_variable
+ module procedure Agrif_Bc_variable0d,
+ & Agrif_Bc_variable1d,
+ & Agrif_Bc_variable2d,
+ & Agrif_Bc_variable3d,
+ & Agrif_Bc_variable4d,
+ & Agrif_Bc_variable5d
+ end interface
+C
+ interface Agrif_Set_Parent
+ module procedure Agrif_Set_Parent_int,
+ & Agrif_Set_Parent_real
+ end interface
+C
+ interface Agrif_Interp_variable
+ module procedure Agrif_Interp_var0d,
+ & Agrif_Interp_var1d,
+ & Agrif_Interp_var2d,
+ & Agrif_Interp_var3d,
+ & Agrif_Interp_var4d,
+ & Agrif_Interp_var5d
+ end interface
+C
+ interface Agrif_Init_variable
+ module procedure Agrif_Init_variable0d,
+ & Agrif_Init_variable1d,
+ & Agrif_Init_variable2d,
+ & Agrif_Init_variable3d,
+ & Agrif_Init_variable4d
+ end interface
+C
+ interface Agrif_update_variable
+ module procedure Agrif_update_var0d,
+ & Agrif_update_var1d,
+ & Agrif_update_var2d,
+ & Agrif_update_var3d,
+ & Agrif_update_var4d,
+ & Agrif_update_var5d
+ end interface
+
+ interface Agrif_Save_Forrestore
+ module procedure Agrif_Save_Forrestore0d,
+ & Agrif_Save_Forrestore2d,
+ & Agrif_Save_Forrestore3d,
+ & Agrif_Save_Forrestore4d
+ end interface
+C
+ Contains
+C
+C **************************************************************************
+CCC Subroutine Agrif_Set_type
+C **************************************************************************
+C
+ Subroutine Agrif_Set_type(tabvarsindic,posvar,point)
+C
+CCC Description:
+CCC To set the TYPE of the variable.
+C
+C Modules used:
+C
+
+C
+C Declarations:
+C
+C
+C
+C Arguments
+C
+ INTEGER, DIMENSION(:) :: posvar
+ INTEGER, DIMENSION(:) :: point
+C
+ INTEGER :: tabvarsindic ! indice of the variable in tabvars
+ INTEGER :: dimensio ! DIMENSION of the variable
+ INTEGER :: i
+C
+C
+C Begin
+C
+ dimensio = Agrif_Mygrid % tabvars(tabvarsindic) %var % nbdim
+C
+ if (.not.associated(Agrif_Mygrid % tabvars(tabvarsindic)
+ & %var % posvar)) then
+ Allocate(
+ & Agrif_Mygrid % tabvars(tabvarsindic)%var % posvar(dimensio))
+ endif
+
+ do i = 1 , dimensio
+ Agrif_Mygrid % tabvars(tabvarsindic) %var % posvar(i)
+ & = posvar(i)
+ Agrif_Mygrid % tabvars(tabvarsindic) %var % point(i)
+ & = point(i)
+ enddo
+C
+C
+ End Subroutine Agrif_Set_type
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Set_parent_int
+C **************************************************************************
+C
+ Subroutine Agrif_Set_parent_int(tabvarsindic,value)
+C
+CCC Description:
+CCC To set the TYPE of the variable.
+C
+C Modules used:
+C
+
+C
+C Declarations:
+C
+C
+C
+C Arguments
+C
+ INTEGER :: tabvarsindic ! indice of the variable in tabvars
+ INTEGER :: Value
+C
+C Begin
+C
+ Agrif_Curgrid % parent % tabvars(tabvarsindic) %
+ & var % iarray0 = value
+C
+C
+ End Subroutine Agrif_Set_parent_int
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Set_parent_real
+C **************************************************************************
+C
+ Subroutine Agrif_Set_parent_real(tabvarsindic,value)
+C
+CCC Description:
+CCC To set the TYPE of the variable.
+C
+C Modules used:
+C
+
+C
+C Declarations:
+C
+C
+C
+C Arguments
+C
+ INTEGER :: tabvarsindic ! indice of the variable in tabvars
+ REAL :: Value
+C
+C Begin
+C
+ Agrif_Curgrid % parent % tabvars(tabvarsindic) %
+ & var % array0 = value
+C
+C
+ End Subroutine Agrif_Set_parent_real
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Set_raf
+C **************************************************************************
+C
+ Subroutine Agrif_Set_raf(tabvarsindic,tabraf)
+C
+CCC Description:
+CCC Attention tabraf est de taille trois si on ne raffine pas suivant z la
+CCC troisieme entree du tableau tabraf est 'N'
+C
+C Modules used:
+C
+
+C
+C Declarations:
+C
+C Arguments
+C
+ CHARACTER(*) ,DIMENSION(:) :: tabraf
+C
+ INTEGER :: tabvarsindic ! indice of the variable in tabvars
+ INTEGER :: dimensio ! DIMENSION of the variable
+ INTEGER :: i
+C
+C
+C Begin
+C
+ dimensio = Agrif_Mygrid % tabvars(tabvarsindic) %var % nbdim
+C
+ if (.not.associated(Agrif_Mygrid % tabvars(tabvarsindic)
+ & %var % interptab)) then
+ Allocate(
+ & Agrif_Mygrid % tabvars(tabvarsindic)%var% interptab(dimensio))
+ endif
+
+ do i = 1 , dimensio
+ Agrif_Mygrid % tabvars(tabvarsindic) %var % interptab(i)
+ & = TRIM(tabraf(i))
+ enddo
+C
+ End Subroutine Agrif_Set_raf
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Set_bc
+C **************************************************************************
+C
+ Subroutine Agrif_Set_bc(tabvarsindic,point,
+ & Interpolationshouldbemade)
+C
+CCC Description:
+CCC
+C
+C Modules used:
+C
+
+C
+C Declarations:
+C
+C Arguments
+C
+ INTEGER, DIMENSION(2) :: point
+ LOGICAL, OPTIONAL :: Interpolationshouldbemade
+C
+ INTEGER :: tabvarsindic, indic ! indice of the variable in tabvars
+ TYPE(Agrif_PVariable),Pointer ::tabvars
+
+
+C
+C
+C Begin
+C
+C
+
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ endif
+
+ if (Agrif_Curgrid % fixedrank .NE. 0) then
+ IF (.Not.Associated(tabvars%var% interpIndex)) THEN
+ Allocate(tabvars%var % interpIndex)
+ tabvars%var % interpIndex = -1
+
+ Allocate(tabvars%var % oldvalues2D(2,1))
+ tabvars%var % oldvalues2D = 0.
+ ENDIF
+ if ( PRESENT(Interpolationshouldbemade) ) then
+ tabvars%var %
+ & Interpolationshouldbemade = Interpolationshouldbemade
+ endif
+
+ endif
+C
+ tabvars%var % bcinf = point(1)
+ tabvars%var % bcsup = point(2)
+C
+ End Subroutine Agrif_Set_bc
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Set_interp
+C **************************************************************************
+C
+ Subroutine Agrif_Set_interp(tabvarsindic,interp,interp1,interp2,
+ & interp3)
+C
+CCC Description:
+C
+C Declarations:
+C
+C Arguments
+C
+ INTEGER, OPTIONAL :: interp,interp1,interp2,interp3
+C
+ INTEGER :: tabvarsindic, indic ! indice of the variable in tabvars
+ TYPE(Agrif_PVariable),Pointer ::tabvars
+
+
+C
+C
+C Begin
+C
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ tabvars=>Agrif_Mygrid % tabvars(indic)
+ endif
+C
+C Begin
+C
+ tabvars % var % Typeinterp =
+ & Agrif_Constant
+ IF (present(interp)) THEN
+ tabvars % var % Typeinterp =
+ & interp
+ ENDIF
+ IF (present(interp1)) THEN
+ tabvars % var % Typeinterp(1) =
+ & interp1
+ ENDIF
+ IF (present(interp2)) THEN
+ tabvars % var % Typeinterp(2) =
+ & interp2
+ ENDIF
+ IF (present(interp3)) THEN
+ tabvars % var % Typeinterp(3) =
+ & interp3
+ ENDIF
+C
+ End Subroutine Agrif_Set_interp
+C
+C **************************************************************************
+CCC Subroutine Agrif_Set_bcinterp
+C **************************************************************************
+C
+ Subroutine Agrif_Set_bcinterp(tabvarsindic,interp,interp1,
+ & interp2,interp3,interp11,interp12,interp21,interp22)
+C
+CCC Description:
+
+C
+C Modules used:
+C
+
+C
+C Declarations:
+C
+C Arguments
+C
+ INTEGER, OPTIONAL :: interp,interp1,interp2,interp3
+ INTEGER, OPTIONAL :: interp11,interp12,interp21,interp22
+C
+ INTEGER :: tabvarsindic, indic ! indice of the variable in tabvars
+ TYPE(Agrif_PVariable),Pointer ::tabvars
+
+
+C
+C
+C Begin
+C
+C
+
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ tabvars=>Agrif_Mygrid % tabvars(indic)
+ endif
+C
+ tabvars% var % bctypeinterp =
+ & Agrif_Constant
+ IF (present(interp)) THEN
+ tabvars% var % bctypeinterp =
+ & interp
+ ENDIF
+ IF (present(interp1)) THEN
+ tabvars% var % bctypeinterp(1:2,1) =
+ & interp1
+ ENDIF
+ IF (present(interp11)) THEN
+ tabvars% var % bctypeinterp(1,1) =
+ & interp11
+ ENDIF
+ IF (present(interp12)) THEN
+ tabvars% var % bctypeinterp(1,2) =
+ & interp12
+ ENDIF
+ IF (present(interp2)) THEN
+ tabvars% var % bctypeinterp(1:2,2) =
+ & interp2
+ ENDIF
+ IF (present(interp21)) THEN
+ tabvars% var % bctypeinterp(2,1) =
+ & interp21
+ ENDIF
+ IF (present(interp22)) THEN
+ tabvars% var % bctypeinterp(2,2) =
+ & interp22
+ ENDIF
+ IF (present(interp3)) THEN
+ tabvars% var % bctypeinterp(1:2,3) =
+ & interp3
+ ENDIF
+C
+ End Subroutine Agrif_Set_bcinterp
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Set_Update
+C **************************************************************************
+C
+ Subroutine Agrif_Set_Update(tabvarsindic,point)
+C
+CCC Description:
+CCC
+C
+C Modules used:
+C
+
+C
+C Declarations:
+C
+C Arguments
+C
+ INTEGER, DIMENSION(2) :: point
+C
+ INTEGER :: tabvarsindic ! indice of the variable in tabvars
+C
+C
+C Begin
+C
+ Agrif_Curgrid%tabvars(tabvarsindic)%var % updateinf = point(1)
+ Agrif_Curgrid%tabvars(tabvarsindic)%var % updatesup = point(2)
+C
+ End Subroutine Agrif_Set_Update
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Set_UpdateType
+C **************************************************************************
+C
+ Subroutine Agrif_Set_UpdateType(tabvarsindic,
+ & update,update1,update2,
+ & update3,update4,update5)
+C
+CCC Description:
+
+C
+C Modules used:
+C
+
+C
+C Declarations:
+C
+C Arguments
+C
+ INTEGER, OPTIONAL :: update, update1,
+ & update2, update3,update4,update5
+C
+ INTEGER :: tabvarsindic,indic ! indice of the variable in tabvars
+ TYPE(Agrif_PVariable),Pointer :: roottabvars
+C
+C
+C Begin
+
+ indic = tabvarsindic
+
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (indic <=0) then
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+
+C
+ roottabvars% var % typeupdate =
+ & Agrif_Update_Copy
+
+ IF (present(update)) THEN
+ roottabvars% var % typeupdate =
+ & update
+ ENDIF
+ IF (present(update1)) THEN
+ roottabvars% var % typeupdate(1) =
+ & update1
+ ENDIF
+ IF (present(update2)) THEN
+ roottabvars% var % typeupdate(2) =
+ & update2
+ ENDIF
+ IF (present(update3)) THEN
+ roottabvars% var % typeupdate(3) =
+ & update3
+ ENDIF
+ IF (present(update4)) THEN
+ roottabvars% var % typeupdate(4) =
+ & update4
+ ENDIF
+ IF (present(update5)) THEN
+ roottabvars% var % typeupdate(5) =
+ & update5
+ ENDIF
+C
+ End Subroutine Agrif_Set_UpdateType
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Set_restore
+C **************************************************************************
+C
+ Subroutine Agrif_Set_restore(tabvarsindic)
+C
+CCC Description:
+CCC
+C
+C Modules used:
+C
+
+C
+C Declarations:
+C
+C Arguments
+C
+ INTEGER :: tabvarsindic,indic ! indice of the variable in tabvars
+C
+C Begin
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+C
+ Agrif_Mygrid%tabvars(indic)%var % restaure = .TRUE.
+C
+ End Subroutine Agrif_Set_restore
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Init_variable0d
+C **************************************************************************
+ Subroutine Agrif_Init_variable0d(tabvarsindic0,tabvarsindic,
+ & procname)
+
+ INTEGER :: tabvarsindic0 ! indice of the variable in tabvars
+ INTEGER :: tabvarsindic,indic ! indice of the variable in tabvars
+ External :: procname
+ Optional :: procname
+C
+ if (Agrif_Root()) Return
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (present(procname)) then
+ CALL Agrif_Interp_variable(tabvarsindic0,indic,procname)
+ CALL Agrif_Bc_variable(tabvarsindic0,indic,1.,procname)
+ else
+ CALL Agrif_Interp_variable(tabvarsindic0,indic)
+ CALL Agrif_Bc_variable(tabvarsindic0,indic,1.)
+ endif
+
+ End Subroutine Agrif_Init_variable0d
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Init_variable1d
+C **************************************************************************
+ Subroutine Agrif_Init_variable1d(q,tabvarsindic,procname)
+
+ REAL, DIMENSION(:) :: q
+ INTEGER :: tabvarsindic, indic ! indice of the variable in tabvars
+ External :: procname
+ Optional :: procname
+
+C
+ if (Agrif_Root()) Return
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+C
+ if (present(procname)) then
+ CALL Agrif_Interp_variable(q,indic,procname)
+ CALL Agrif_Bc_variable(q,indic,1.,procname)
+ else
+ CALL Agrif_Interp_variable(q,indic)
+ CALL Agrif_Bc_variable(q,indic,1.)
+ endif
+
+ End Subroutine Agrif_Init_variable1d
+C
+C **************************************************************************
+CCC Subroutine Agrif_Init_variable2d
+C **************************************************************************
+ Subroutine Agrif_Init_variable2d(q,tabvarsindic,procname)
+
+ REAL, DIMENSION(:,:) :: q
+ INTEGER :: tabvarsindic ! indice of the variable in tabvars
+ External :: procname
+ Optional :: procname
+ integer :: indic
+
+C
+ if (Agrif_Root()) Return
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (present(procname)) then
+ CALL Agrif_Interp_variable(q,indic,procname)
+ CALL Agrif_Bc_variable(q,indic,1.,procname)
+ else
+ CALL Agrif_Interp_variable(q,indic)
+ CALL Agrif_Bc_variable(q,indic,1.)
+ endif
+
+
+ End Subroutine Agrif_Init_variable2d
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Init_variable3d
+C **************************************************************************
+ Subroutine Agrif_Init_variable3d(q,tabvarsindic,procname)
+
+ REAL, DIMENSION(:,:,:) :: q
+ INTEGER :: tabvarsindic,indic ! indice of the variable in tabvars
+ External :: procname
+ Optional :: procname
+C
+ if (Agrif_Root()) Return
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+C
+ if (present(procname)) then
+ CALL Agrif_Interp_variable(q,indic,procname)
+ CALL Agrif_Bc_variable(q,indic,1.,procname)
+ else
+ CALL Agrif_Interp_variable(q,indic)
+ CALL Agrif_Bc_variable(q,indic,1.)
+ endif
+
+C
+ End Subroutine Agrif_Init_variable3d
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Init_variable4d
+C **************************************************************************
+ Subroutine Agrif_Init_variable4d(q,tabvarsindic,procname)
+
+ REAL, DIMENSION(:,:,:,:) :: q
+ INTEGER :: tabvarsindic, indic ! indice of the variable in tabvars
+ External :: procname
+ Optional :: procname
+C
+ if (Agrif_Root()) Return
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+C
+ if (present(procname)) then
+ CALL Agrif_Interp_variable(q,indic,procname)
+ CALL Agrif_Bc_variable(q,indic,1.,procname)
+ else
+ CALL Agrif_Interp_variable(q,indic)
+ CALL Agrif_Bc_variable(q,indic,1.)
+ endif
+
+C
+ End Subroutine Agrif_Init_variable4d
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Bc_variable0d
+C **************************************************************************
+ Subroutine Agrif_Bc_variable0d(tabvarsindic0,tabvarsindic,
+ & calledweight,procname)
+
+ INTEGER :: tabvarsindic0 ! indice of the variable in tabvars
+ INTEGER :: tabvarsindic ! indice of the variable in tabvars
+C
+ External :: procname
+ Optional :: procname
+ REAL, OPTIONAL :: calledweight
+ REAL :: weight
+ LOGICAL :: pweight
+C
+ INTEGER :: dimensio
+
+ if (Agrif_Root()) Return
+C
+ dimensio = Agrif_Mygrid % tabvars(tabvarsindic) % var % nbdim
+C
+ if ( PRESENT(calledweight) ) then
+ weight=calledweight
+ pweight = .TRUE.
+ else
+ weight = 0.
+ pweight = .FALSE.
+ endif
+C
+C
+
+
+ if ( dimensio .EQ. 1 ) Call Agrif_Interp_Bc_1D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % bctypeinterp,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) %var % array1,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcsup,
+ & weight,
+ & pweight)
+C
+ if ( dimensio .EQ. 2 ) then
+ IF (present(procname)) THEN
+ Call Agrif_Interp_Bc_2D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % bctypeinterp,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) %var % array2,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcsup,
+ & weight,pweight,procname)
+ ELSE
+
+ Call Agrif_Interp_Bc_2D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % bctypeinterp,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) %var % array2,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcsup,
+ & weight,pweight)
+ ENDIF
+ endif
+C
+ if ( dimensio .EQ. 3 ) then
+ IF (present(procname)) THEN
+
+ Call Agrif_Interp_Bc_3D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % bctypeinterp,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) %var % array3,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcsup,
+ & weight,pweight,procname)
+ ELSE
+ Call Agrif_Interp_Bc_3D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % bctypeinterp,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) %var % array3,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcsup,
+ & weight,pweight)
+ ENDIF
+ endif
+C
+ if ( dimensio .EQ. 4 ) then
+ IF (present(procname)) THEN
+ Call Agrif_Interp_Bc_4D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % bctypeinterp,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) %var % array4,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcsup,
+ & weight,pweight,procname)
+ ELSE
+ Call Agrif_Interp_Bc_4D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % bctypeinterp,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) %var % array4,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcsup,
+ & weight,pweight)
+ ENDIF
+ endif
+C
+ if ( dimensio .EQ. 5 ) then
+ IF (present(procname)) THEN
+ Call Agrif_Interp_Bc_5D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % bctypeinterp,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) %var % array5,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcsup,
+ & weight,pweight,procname)
+ ELSE
+ Call Agrif_Interp_Bc_5D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % bctypeinterp,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) %var % array5,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcsup,
+ & weight,pweight)
+ ENDIF
+ endif
+C
+ if ( dimensio .EQ. 6 ) Call Agrif_Interp_Bc_6D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % bctypeinterp,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) %var % array6,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % bcsup,
+ & weight,
+ & pweight)
+C
+C
+ End Subroutine Agrif_Bc_variable0d
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Bc_variable1d
+C **************************************************************************
+ Subroutine Agrif_Bc_variable1d(q,tabvarsindic,calledweight,
+ & procname)
+
+ REAL , Dimension(:) :: q
+ External :: procname
+ Optional :: procname
+ INTEGER :: tabvarsindic, indic ! indice of the variable in tabvars
+C
+ REAL, OPTIONAL :: calledweight
+ REAL :: weight
+ LOGICAL :: pweight
+ TYPE(Agrif_PVariable),Pointer ::tabvars,parenttabvars,roottabvars
+C
+C
+C
+ If (Agrif_Root()) Return
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if ( PRESENT(calledweight) ) then
+ weight=calledweight
+ pweight = .TRUE.
+ else
+ weight = 0.
+ pweight = .FALSE.
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ parenttabvars => tabvars%parent_var
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ parenttabvars => Agrif_Curgrid % parent % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+
+ IF (present(procname)) THEN
+ Call Agrif_Interp_Bc_1D(
+ & roottabvars % var % bctypeinterp,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % bcinf,
+ & tabvars % var % bcsup,
+ & weight,pweight,procname)
+ ELSE
+ Call Agrif_Interp_Bc_1D(
+ & roottabvars % var % bctypeinterp,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % bcinf,
+ & tabvars % var % bcsup,
+ & weight,pweight)
+ ENDIF
+ End Subroutine Agrif_Bc_variable1d
+
+C
+C **************************************************************************
+CCC Subroutine Agrif_Bc_variable2d
+C **************************************************************************
+ Subroutine Agrif_Bc_variable2d(q,tabvarsindic,calledweight,
+ & procname)
+
+ REAL , Dimension(:,:) :: q
+ External :: procname
+ Optional :: procname
+ INTEGER :: tabvarsindic, indic ! indice of the variable in tabvars
+C
+ REAL, OPTIONAL :: calledweight
+ REAL :: weight
+ LOGICAL :: pweight
+ TYPE(Agrif_PVariable),Pointer ::tabvars,parenttabvars,roottabvars
+C
+C
+C
+ If (Agrif_Root()) Return
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if ( PRESENT(calledweight) ) then
+ weight=calledweight
+ pweight = .TRUE.
+ else
+ weight = 0.
+ pweight = .FALSE.
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ parenttabvars => tabvars%parent_var
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ parenttabvars => Agrif_Curgrid % parent % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+
+ IF (present(procname)) THEN
+ Call Agrif_Interp_Bc_2D(
+ & roottabvars % var % bctypeinterp,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % bcinf,
+ & tabvars % var % bcsup,
+ & weight,pweight,procname)
+ ELSE
+ Call Agrif_Interp_Bc_2D(
+ & roottabvars % var % bctypeinterp,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % bcinf,
+ & tabvars % var % bcsup,
+ & weight,pweight)
+ ENDIF
+ End Subroutine Agrif_Bc_variable2d
+
+C
+C **************************************************************************
+CCC Subroutine Agrif_Bc_variable3d
+C **************************************************************************
+ Subroutine Agrif_Bc_variable3d(q,tabvarsindic,calledweight,
+ & procname)
+
+ REAL , Dimension(:,:,:) :: q
+ External :: procname
+ Optional :: procname
+ INTEGER :: tabvarsindic, indic ! indice of the variable in tabvars
+C
+ REAL, OPTIONAL :: calledweight
+ REAL :: weight
+ LOGICAL :: pweight
+ TYPE(Agrif_PVariable),Pointer ::tabvars,parenttabvars,roottabvars
+C
+C
+C
+ If (Agrif_Root()) Return
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if ( PRESENT(calledweight) ) then
+ weight=calledweight
+ pweight = .TRUE.
+ else
+ weight = 0.
+ pweight = .FALSE.
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ parenttabvars => tabvars%parent_var
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ parenttabvars => Agrif_Curgrid % parent % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+
+ IF (present(procname)) THEN
+ Call Agrif_Interp_Bc_3D(
+ & roottabvars % var % bctypeinterp,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % bcinf,
+ & tabvars % var % bcsup,
+ & weight,pweight,procname)
+ ELSE
+ Call Agrif_Interp_Bc_3D(
+ & roottabvars % var % bctypeinterp,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % bcinf,
+ & tabvars % var % bcsup,
+ & weight,pweight)
+ ENDIF
+ End Subroutine Agrif_Bc_variable3d
+
+C
+C **************************************************************************
+CCC Subroutine Agrif_Bc_variable4d
+C **************************************************************************
+ Subroutine Agrif_Bc_variable4d(q,tabvarsindic,calledweight,
+ & procname)
+
+ REAL , Dimension(:,:,:,:) :: q
+ External :: procname
+ Optional :: procname
+ INTEGER :: tabvarsindic, indic ! indice of the variable in tabvars
+C
+ REAL, OPTIONAL :: calledweight
+ REAL :: weight
+ LOGICAL :: pweight
+ TYPE(Agrif_PVariable),Pointer ::tabvars,parenttabvars,roottabvars
+C
+C
+C
+ If (Agrif_Root()) Return
+
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if ( PRESENT(calledweight) ) then
+ weight=calledweight
+ pweight = .TRUE.
+ else
+ weight = 0.
+ pweight = .FALSE.
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ parenttabvars => tabvars%parent_var
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ parenttabvars => Agrif_Curgrid % parent % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+
+ IF (present(procname)) THEN
+ Call Agrif_Interp_Bc_4D(
+ & roottabvars % var % bctypeinterp,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % bcinf,
+ & tabvars % var % bcsup,
+ & weight,pweight,procname)
+ ELSE
+ Call Agrif_Interp_Bc_4D(
+ & roottabvars % var % bctypeinterp,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % bcinf,
+ & tabvars % var % bcsup,
+ & weight,pweight)
+ ENDIF
+ End Subroutine Agrif_Bc_variable4d
+
+C
+C **************************************************************************
+CCC Subroutine Agrif_Bc_variable5d
+C **************************************************************************
+ Subroutine Agrif_Bc_variable5d(q,tabvarsindic,calledweight,
+ & procname)
+
+ REAL , Dimension(:,:,:,:,:) :: q
+ External :: procname
+ Optional :: procname
+ INTEGER :: tabvarsindic, indic ! indice of the variable in tabvars
+C
+ REAL, OPTIONAL :: calledweight
+ REAL :: weight
+ LOGICAL :: pweight
+ TYPE(Agrif_PVariable),Pointer ::tabvars,parenttabvars,roottabvars
+C
+C
+C
+ If (Agrif_Root()) Return
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if ( PRESENT(calledweight) ) then
+ weight=calledweight
+ pweight = .TRUE.
+ else
+ weight = 0.
+ pweight = .FALSE.
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ parenttabvars => tabvars%parent_var
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ parenttabvars => Agrif_Curgrid % parent % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+
+ IF (present(procname)) THEN
+ Call Agrif_Interp_Bc_5d(
+ & roottabvars % var % bctypeinterp,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % bcinf,
+ & tabvars % var % bcsup,
+ & weight,pweight,procname)
+ ELSE
+ Call Agrif_Interp_Bc_5d(
+ & roottabvars % var % bctypeinterp,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % bcinf,
+ & tabvars % var % bcsup,
+ & weight,pweight)
+ ENDIF
+ End Subroutine Agrif_Bc_variable5d
+
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_var0D
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_var0d(tabvarsindic0,tabvarsindic,procname)
+
+ INTEGER :: tabvarsindic0 ! indice of the variable in tabvars
+ INTEGER :: tabvarsindic, indic ! indice of the variable in tabvars
+ INTEGER :: dimensio ! indice of the variable in tabvars
+ External :: procname
+ Optional :: procname
+C
+ if (Agrif_Root()) Return
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+C
+ dimensio = Agrif_Mygrid % tabvars(indic) % var % nbdim
+C
+ if ( dimensio .EQ. 1 ) then
+ if (present(procname)) then
+ Call Agrif_Interp_1D(
+ & Agrif_Mygrid % tabvars(indic) % var % TypeInterp,
+ & Agrif_Curgrid % parent % tabvars(indic),
+ & Agrif_Curgrid % tabvars(indic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array1 ,
+ & Agrif_Mygrid % tabvars(indic) % var % restaure,
+ & Agrif_Mygrid % tabvars(indic) %var % nbdim,procname)
+ else
+ Call Agrif_Interp_1D(
+ & Agrif_Mygrid % tabvars(indic) % var % TypeInterp,
+ & Agrif_Curgrid % parent % tabvars(indic),
+ & Agrif_Curgrid % tabvars(indic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array1 ,
+ & Agrif_Mygrid % tabvars(indic) % var % restaure,
+ & Agrif_Mygrid % tabvars(indic) %var % nbdim)
+ endif
+ endif
+C
+ if ( dimensio .EQ. 2 ) then
+ if (present(procname)) then
+ Call Agrif_Interp_2D(
+ & Agrif_Mygrid % tabvars(indic) % var % TypeInterp,
+ & Agrif_Curgrid % parent % tabvars(indic),
+ & Agrif_Curgrid % tabvars(indic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array2 ,
+ & Agrif_Mygrid % tabvars(indic) % var % restaure,
+ & Agrif_Mygrid % tabvars(indic) %var % nbdim,procname)
+ else
+ Call Agrif_Interp_2D(
+ & Agrif_Mygrid % tabvars(indic) % var % TypeInterp,
+ & Agrif_Curgrid % parent % tabvars(indic),
+ & Agrif_Curgrid % tabvars(indic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array2 ,
+ & Agrif_Mygrid % tabvars(indic) % var % restaure,
+ & Agrif_Mygrid % tabvars(indic) %var % nbdim)
+ endif
+ endif
+C
+ if ( dimensio .EQ. 3 ) then
+ if (present(procname)) then
+ Call Agrif_Interp_3D(
+ & Agrif_Mygrid % tabvars(indic) % var % TypeInterp,
+ & Agrif_Curgrid % parent % tabvars(indic),
+ & Agrif_Curgrid % tabvars(indic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array3 ,
+ & Agrif_Mygrid % tabvars(indic) % var % restaure,
+ & Agrif_Mygrid % tabvars(indic) %var % nbdim,procname)
+ else
+ Call Agrif_Interp_3D(
+ & Agrif_Mygrid % tabvars(indic) % var % TypeInterp,
+ & Agrif_Curgrid % parent % tabvars(indic),
+ & Agrif_Curgrid % tabvars(indic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array3 ,
+ & Agrif_Mygrid % tabvars(indic) % var % restaure,
+ & Agrif_Mygrid % tabvars(indic) %var % nbdim)
+ endif
+ endif
+C
+ if ( dimensio .EQ. 4 ) then
+ if (present(procname)) then
+ Call Agrif_Interp_4D(
+ & Agrif_Mygrid % tabvars(indic) % var % TypeInterp,
+ & Agrif_Curgrid % parent % tabvars(indic),
+ & Agrif_Curgrid % tabvars(indic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array4 ,
+ & Agrif_Mygrid % tabvars(indic) % var % restaure,
+ & Agrif_Mygrid % tabvars(indic) %var % nbdim,procname)
+ else
+ Call Agrif_Interp_4D(
+ & Agrif_Mygrid % tabvars(indic) % var % TypeInterp,
+ & Agrif_Curgrid % parent % tabvars(indic),
+ & Agrif_Curgrid % tabvars(indic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array4 ,
+ & Agrif_Mygrid % tabvars(indic) % var % restaure,
+ & Agrif_Mygrid % tabvars(indic) %var % nbdim)
+ endif
+ endif
+C
+ if ( dimensio .EQ. 5 ) then
+ if (present(procname)) then
+ Call Agrif_Interp_5D(
+ & Agrif_Mygrid % tabvars(indic) % var % TypeInterp,
+ & Agrif_Curgrid % parent % tabvars(indic),
+ & Agrif_Curgrid % tabvars(indic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array5 ,
+ & Agrif_Mygrid % tabvars(indic) % var % restaure,
+ & Agrif_Mygrid % tabvars(indic) %var % nbdim,procname)
+ else
+ Call Agrif_Interp_5D(
+ & Agrif_Mygrid % tabvars(indic) % var % TypeInterp,
+ & Agrif_Curgrid % parent % tabvars(indic),
+ & Agrif_Curgrid % tabvars(indic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array5 ,
+ & Agrif_Mygrid % tabvars(indic) % var % restaure,
+ & Agrif_Mygrid % tabvars(indic) %var % nbdim)
+ endif
+ endif
+C
+ if ( dimensio .EQ. 6 ) then
+ if (present(procname)) then
+ Call Agrif_Interp_6D(
+ & Agrif_Mygrid % tabvars(indic) % var % TypeInterp,
+ & Agrif_Curgrid % parent % tabvars(indic),
+ & Agrif_Curgrid % tabvars(indic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array6 ,
+ & Agrif_Mygrid % tabvars(indic) % var % restaure,
+ & Agrif_Mygrid % tabvars(indic) %var % nbdim,procname)
+ else
+ Call Agrif_Interp_6D(
+ & Agrif_Mygrid % tabvars(indic) % var % TypeInterp,
+ & Agrif_Curgrid % parent % tabvars(indic),
+ & Agrif_Curgrid % tabvars(indic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array6 ,
+ & Agrif_Mygrid % tabvars(indic) % var % restaure,
+ & Agrif_Mygrid % tabvars(indic) %var % nbdim)
+ endif
+ endif
+C
+ Return
+ End Subroutine Agrif_Interp_var0d
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_var1d
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_var1d(q,tabvarsindic,procname)
+
+ REAL, DIMENSION(:) :: q
+ INTEGER :: tabvarsindic, indic ! indice of the variable in tabvars
+ External :: procname
+ Optional :: procname
+ TYPE(Agrif_PVariable),Pointer ::tabvars,parenttabvars,roottabvars
+C
+ if (Agrif_Root()) Return
+C
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ parenttabvars => tabvars%parent_var
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ parenttabvars => Agrif_Curgrid % parent % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+
+ if (present(procname)) then
+ Call Agrif_Interp_1D(
+ & roottabvars % var % TypeInterp,
+ & parenttabvars,
+ & tabvars,q,
+ & roottabvars % var % restaure,
+ & roottabvars %var % nbdim,procname)
+ else
+ Call Agrif_Interp_1D(
+ & roottabvars % var % TypeInterp,
+ & parenttabvars,
+ & tabvars,q,
+ & roottabvars % var % restaure,
+ & roottabvars %var % nbdim)
+
+ endif
+ Return
+ End Subroutine Agrif_Interp_var1d
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_var2d
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_var2d(q,tabvarsindic,procname)
+
+ REAL, DIMENSION(:,:) :: q
+ INTEGER :: tabvarsindic, indic ! indice of the variable in tabvars
+ External :: procname
+ Optional :: procname
+ TYPE(Agrif_PVariable),Pointer ::tabvars,parenttabvars,roottabvars
+C
+ if (Agrif_Root()) Return
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ parenttabvars => tabvars%parent_var
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ if (tabvars%var%restaure) then
+ if (agrif_curgrid%ngridstep == 0) then
+ call AGRIF_CopyFromold_AllOneVar
+ & (Agrif_Curgrid,Agrif_OldMygrid,indic)
+ endif
+ endif
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ parenttabvars => Agrif_Curgrid % parent % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+
+
+ if (present(procname)) then
+ Call Agrif_Interp_2D(
+ & roottabvars % var % TypeInterp,
+ & parenttabvars,
+ & tabvars,q,
+ & roottabvars % var % restaure,
+ & roottabvars %var % nbdim,procname)
+ else
+ Call Agrif_Interp_2D(
+ & roottabvars % var % TypeInterp,
+ & parenttabvars,
+ & tabvars,q,
+ & roottabvars % var % restaure,
+ & roottabvars %var % nbdim)
+
+ endif
+ Return
+ End Subroutine Agrif_Interp_var2d
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_var3d
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_var3d(q,tabvarsindic,procname)
+
+ REAL, DIMENSION(:,:,:) :: q
+ INTEGER :: tabvarsindic, indic ! indice of the variable in tabvars
+ External :: procname
+ Optional :: procname
+ TYPE(Agrif_PVariable),Pointer ::tabvars,parenttabvars,roottabvars
+C
+ if (Agrif_Root()) Return
+C
+
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ parenttabvars => tabvars%parent_var
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ if (tabvars%var%restaure) then
+ if (agrif_curgrid%ngridstep == 0) then
+ call AGRIF_CopyFromold_AllOneVar
+ & (Agrif_Curgrid,Agrif_OldMygrid,indic)
+ endif
+ endif
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ parenttabvars => Agrif_Curgrid % parent % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+
+ if (present(procname)) then
+ Call Agrif_Interp_3D(
+ & roottabvars % var % TypeInterp,
+ & parenttabvars,
+ & tabvars,q,
+ & roottabvars % var % restaure,
+ & roottabvars %var % nbdim,procname)
+ else
+ Call Agrif_Interp_3D(
+ & roottabvars % var % TypeInterp,
+ & parenttabvars,
+ & tabvars,q,
+ & roottabvars % var % restaure,
+ & roottabvars %var % nbdim)
+
+ endif
+ Return
+ End Subroutine Agrif_Interp_var3d
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_var4d
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_var4d(q,tabvarsindic,procname)
+
+ REAL, DIMENSION(:,:,:,:) :: q
+ INTEGER :: tabvarsindic, indic ! indice of the variable in tabvars
+ External :: procname
+ Optional :: procname
+ TYPE(Agrif_PVariable),Pointer ::tabvars,parenttabvars,roottabvars
+C
+ if (Agrif_Root()) Return
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ parenttabvars => tabvars%parent_var
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ if (tabvars%var%restaure) then
+ if (agrif_curgrid%ngridstep == 0) then
+ call AGRIF_CopyFromold_AllOneVar
+ & (Agrif_Curgrid,Agrif_OldMygrid,indic)
+ endif
+ endif
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ parenttabvars => Agrif_Curgrid % parent % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+
+ if (present(procname)) then
+ Call Agrif_Interp_4D(
+ & roottabvars % var % TypeInterp,
+ & parenttabvars,
+ & tabvars,q,
+ & roottabvars % var % restaure,
+ & roottabvars %var % nbdim,procname)
+ else
+ Call Agrif_Interp_4D(
+ & roottabvars % var % TypeInterp,
+ & parenttabvars,
+ & tabvars,q,
+ & roottabvars % var % restaure,
+ & roottabvars %var % nbdim)
+
+ endif
+
+ Return
+ End Subroutine Agrif_Interp_var4d
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_var5d
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_var5d(q,tabvarsindic,procname)
+
+ REAL, DIMENSION(:,:,:,:,:) :: q
+ INTEGER :: tabvarsindic, indic ! indice of the variable in tabvars
+ External :: procname
+ Optional :: procname
+ TYPE(Agrif_PVariable),Pointer ::tabvars,parenttabvars,roottabvars
+C
+ if (Agrif_Root()) Return
+C
+
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ parenttabvars => tabvars%parent_var
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ parenttabvars => Agrif_Curgrid % parent % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+
+ if (present(procname)) then
+ Call Agrif_Interp_5D(
+ & roottabvars % var % TypeInterp,
+ & parenttabvars,
+ & tabvars,q,
+ & roottabvars % var % restaure,
+ & roottabvars %var % nbdim,procname)
+ else
+ Call Agrif_Interp_5D(
+ & roottabvars % var % TypeInterp,
+ & parenttabvars,
+ & tabvars,q,
+ & roottabvars % var % restaure,
+ & roottabvars %var % nbdim)
+
+ endif
+ Return
+ End Subroutine Agrif_Interp_var5d
+C
+C **************************************************************************
+CCC Subroutine Agrif_update_var0d
+C **************************************************************************
+C
+ Subroutine Agrif_update_var0d(tabvarsindic0,tabvarsindic,
+ & locupdate,locupdate1,
+ & locupdate2,procname)
+
+ INTEGER :: tabvarsindic ! indice of the variable in tabvars
+ INTEGER :: tabvarsindic0 ! indice of the variable in tabvars
+ External :: procname
+ Optional :: procname
+ INTEGER :: dimensio
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate1
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate2
+C
+ dimensio = Agrif_Mygrid % tabvars(tabvarsindic) % var % nbdim
+C
+ if (Agrif_Root()) Return
+
+C
+ IF (present(locupdate)) THEN
+ Agrif_Curgrid%tabvars(tabvarsindic)%var % updateinf(1:dimensio)
+ & = locupdate(1)
+ Agrif_Curgrid%tabvars(tabvarsindic)%var % updatesup(1:dimensio)
+ & = locupdate(2)
+ ELSE
+ Agrif_Curgrid%tabvars(tabvarsindic)%var % updateinf(1:dimensio)
+ & = -99
+ Agrif_Curgrid%tabvars(tabvarsindic)%var % updatesup(1:dimensio)
+ & = -99
+ ENDIF
+
+ IF (present(locupdate1)) THEN
+ Agrif_Curgrid%tabvars(tabvarsindic)%var % updateinf(1)
+ & = locupdate1(1)
+ Agrif_Curgrid%tabvars(tabvarsindic)%var % updatesup(1)
+ & = locupdate1(2)
+ ENDIF
+
+ IF (present(locupdate2)) THEN
+ Agrif_Curgrid%tabvars(tabvarsindic)%var % updateinf(2)
+ & = locupdate2(1)
+ Agrif_Curgrid%tabvars(tabvarsindic)%var % updatesup(2)
+ & = locupdate2(2)
+ ENDIF
+
+ if ( dimensio .EQ. 1 ) then
+ IF (present(procname)) THEN
+ Call Agrif_Update_1D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % typeupdate,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array1 ,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updateinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updatesup,
+ & procname)
+ ELSE
+ Call Agrif_Update_1D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % typeupdate,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array1 ,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updateinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updatesup)
+ ENDIF
+ endif
+ if ( dimensio .EQ. 2 ) then
+ IF (present(procname)) THEN
+ Call Agrif_Update_2D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % typeupdate,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array2 ,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updateinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updatesup,
+ & procname)
+ ELSE
+ Call Agrif_Update_2D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % typeupdate,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array2 ,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updateinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updatesup)
+ ENDIF
+ endif
+ if ( dimensio .EQ. 3 ) then
+ IF (present(procname)) THEN
+ Call Agrif_Update_3D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % typeupdate,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array3 ,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updateinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updatesup,
+ & procname)
+ ELSE
+ Call Agrif_Update_3D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % typeupdate,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array3 ,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updateinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updatesup)
+ ENDIF
+ endif
+ if ( dimensio .EQ. 4 ) then
+ IF (present(procname)) THEN
+ Call Agrif_Update_4D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % typeupdate,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array4 ,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updateinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updatesup,
+ & procname)
+ ELSE
+ Call Agrif_Update_4D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % typeupdate,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array4 ,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updateinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updatesup)
+ ENDIF
+ endif
+ if ( dimensio .EQ. 5 ) then
+ IF (present(procname)) THEN
+ Call Agrif_Update_5D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % typeupdate,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array5 ,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updateinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updatesup,
+ & procname)
+ ELSE
+ Call Agrif_Update_5D(
+ & Agrif_Mygrid % tabvars(tabvarsindic) % var % typeupdate,
+ & Agrif_Curgrid % parent % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic),
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array5 ,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updateinf,
+ & Agrif_Curgrid % tabvars(tabvarsindic) % var % updatesup)
+ ENDIF
+ endif
+
+ Return
+ End Subroutine Agrif_update_var0d
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_update_var1d
+C **************************************************************************
+C
+ Subroutine Agrif_update_var1d(q,tabvarsindic,locupdate,
+ & locupdate1,locupdate2,procname)
+
+ REAL, DIMENSION(:) :: q
+ INTEGER :: tabvarsindic,indic ! indice of the variable in tabvars
+ External :: procname
+ Optional :: procname
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate1
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate2
+ TYPE(Agrif_PVariable),Pointer ::tabvars,parenttabvars,roottabvars
+C
+ if (Agrif_Root()) Return
+C
+
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ parenttabvars => tabvars%parent_var
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ parenttabvars => Agrif_Curgrid % parent % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+
+ IF (present(locupdate)) THEN
+ tabvars%var % updateinf(1:1)
+ & = locupdate(1)
+ tabvars%var % updatesup(1:1)
+ & = locupdate(2)
+ ELSE
+ tabvars%var % updateinf(1:1)
+ & = -99
+ tabvars%var % updatesup(1:1)
+ & = -99
+ ENDIF
+
+ IF (present(locupdate1)) THEN
+ tabvars%var % updateinf(1)
+ & = locupdate1(1)
+ tabvars%var % updatesup(1)
+ & = locupdate1(2)
+ ENDIF
+
+ IF (present(locupdate2)) THEN
+ tabvars%var % updateinf(2)
+ & = locupdate2(1)
+ tabvars%var % updatesup(2)
+ & = locupdate2(2)
+ ENDIF
+
+ IF (present(procname)) THEN
+ Call Agrif_Update_1D(
+ & roottabvars % var % typeupdate,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % updateinf,
+ & tabvars % var % updatesup,
+ & procname)
+ ELSE
+ Call Agrif_Update_1D(
+ & roottabvars % var % typeupdate,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % updateinf,
+ & tabvars % var % updatesup)
+ ENDIF
+
+ Return
+ End Subroutine Agrif_update_var1d
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_update_var2d
+C **************************************************************************
+C
+ Subroutine Agrif_update_var2d(q,tabvarsindic,locupdate,
+ & locupdate1,locupdate2,procname)
+
+ REAL, DIMENSION(:,:) :: q
+ External :: procname
+ Optional :: procname
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate1
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate2
+ INTEGER :: tabvarsindic,indic ! indice of the variable in tabvars
+ TYPE(Agrif_PVariable),Pointer ::tabvars,parenttabvars,roottabvars
+C
+ IF (Agrif_Root()) RETURN
+
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ parenttabvars => tabvars%parent_var
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ parenttabvars => Agrif_Curgrid % parent % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+
+ IF (present(locupdate)) THEN
+ tabvars%var % updateinf(1:2)
+ & = locupdate(1)
+ tabvars%var % updatesup(1:2)
+ & = locupdate(2)
+ ELSE
+ tabvars%var % updateinf(1:2)
+ & = -99
+ tabvars%var % updatesup(1:2)
+ & = -99
+ ENDIF
+
+ IF (present(locupdate1)) THEN
+ tabvars%var % updateinf(1)
+ & = locupdate1(1)
+ tabvars%var % updatesup(1)
+ & = locupdate1(2)
+ ENDIF
+
+ IF (present(locupdate2)) THEN
+ tabvars%var % updateinf(2)
+ & = locupdate2(1)
+ tabvars%var % updatesup(2)
+ & = locupdate2(2)
+ ENDIF
+
+ IF (present(procname)) THEN
+ Call Agrif_Update_2D(
+ & roottabvars % var % typeupdate,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % updateinf,
+ & tabvars % var % updatesup,
+ & procname)
+ ELSE
+ Call Agrif_Update_2D(
+ & roottabvars % var % typeupdate,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % updateinf,
+ & tabvars % var % updatesup)
+ ENDIF
+
+ Return
+ End Subroutine Agrif_update_var2d
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_update_var3d
+C **************************************************************************
+C
+ Subroutine Agrif_update_var3d(q,tabvarsindic,locupdate,
+ & locupdate1,locupdate2,procname)
+
+ REAL, DIMENSION(:,:,:) :: q
+ External :: procname
+ Optional :: procname
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate1
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate2
+ INTEGER :: tabvarsindic,indic ! indice of the variable in tabvars
+ TYPE(Agrif_PVariable),Pointer ::tabvars,parenttabvars,roottabvars
+C
+ IF (Agrif_Root()) RETURN
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ parenttabvars => tabvars%parent_var
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ parenttabvars => Agrif_Curgrid % parent % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+
+ IF (present(locupdate)) THEN
+ tabvars%var % updateinf(1:3)
+ & = locupdate(1)
+ tabvars%var % updatesup(1:3)
+ & = locupdate(2)
+ ELSE
+ tabvars%var % updateinf(1:3)
+ & = -99
+ tabvars%var % updatesup(1:3)
+ & = -99
+ ENDIF
+
+ IF (present(locupdate1)) THEN
+ tabvars%var % updateinf(1)
+ & = locupdate1(1)
+ tabvars%var % updatesup(1)
+ & = locupdate1(2)
+ ENDIF
+
+ IF (present(locupdate2)) THEN
+ tabvars%var % updateinf(2)
+ & = locupdate2(1)
+ tabvars%var % updatesup(2)
+ & = locupdate2(2)
+ ENDIF
+
+ IF (present(procname)) THEN
+ Call Agrif_Update_3D(
+ & roottabvars % var % typeupdate,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % updateinf,
+ & tabvars % var % updatesup,
+ & procname)
+ ELSE
+ Call Agrif_Update_3D(
+ & roottabvars % var % typeupdate,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % updateinf,
+ & tabvars % var % updatesup)
+ ENDIF
+
+ Return
+ End Subroutine Agrif_update_var3d
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_update_var4d
+C **************************************************************************
+C
+ Subroutine Agrif_update_var4d(q,tabvarsindic,locupdate,
+ & locupdate1,locupdate2,procname)
+
+ REAL, DIMENSION(:,:,:,:) :: q
+ External :: procname
+ Optional :: procname
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate1
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate2
+ INTEGER :: tabvarsindic,indic ! indice of the variable in tabvars
+ TYPE(Agrif_PVariable),Pointer ::tabvars,parenttabvars,roottabvars
+C
+ IF (Agrif_Root()) RETURN
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ parenttabvars => tabvars%parent_var
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ parenttabvars => Agrif_Curgrid % parent % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+C
+ IF (present(locupdate)) THEN
+ tabvars%var % updateinf(1:4)
+ & = locupdate(1)
+ tabvars%var % updatesup(1:4)
+ & = locupdate(2)
+ ELSE
+ tabvars%var % updateinf(1:4)
+ & = -99
+ tabvars%var % updatesup(1:4)
+ & = -99
+ ENDIF
+
+ IF (present(locupdate1)) THEN
+ tabvars%var % updateinf(1)
+ & = locupdate1(1)
+ tabvars%var % updatesup(1)
+ & = locupdate1(2)
+ ENDIF
+
+ IF (present(locupdate2)) THEN
+ tabvars%var % updateinf(2)
+ & = locupdate2(1)
+ tabvars%var % updatesup(2)
+ & = locupdate2(2)
+ ENDIF
+
+ IF (present(procname)) THEN
+ Call Agrif_Update_4D(
+ & roottabvars % var % typeupdate,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % updateinf,
+ & tabvars % var % updatesup,
+ & procname)
+ ELSE
+ Call Agrif_Update_4D(
+ & roottabvars % var % typeupdate,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % updateinf,
+ & tabvars % var % updatesup)
+ ENDIF
+
+ Return
+ End Subroutine Agrif_update_var4d
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_update_var5d
+C **************************************************************************
+C
+ Subroutine Agrif_update_var5d(q,tabvarsindic,locupdate,
+ & locupdate1,locupdate2,procname)
+
+ REAL, DIMENSION(:,:,:,:,:) :: q
+ External :: procname
+ Optional :: procname
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate1
+ INTEGER, DIMENSION(2), OPTIONAL :: locupdate2
+ INTEGER :: tabvarsindic,indic ! indice of the variable in tabvars
+ TYPE(Agrif_PVariable),Pointer ::tabvars,parenttabvars,roottabvars
+C
+ IF (Agrif_Root()) RETURN
+C
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ parenttabvars => tabvars%parent_var
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ parenttabvars => Agrif_Curgrid % parent % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+
+ IF (present(locupdate)) THEN
+ tabvars%var % updateinf(1:5)
+ & = locupdate(1)
+ tabvars%var % updatesup(1:5)
+ & = locupdate(2)
+ ELSE
+ tabvars%var % updateinf(1:5)
+ & = -99
+ tabvars%var % updatesup(1:5)
+ & = -99
+ ENDIF
+
+ IF (present(locupdate1)) THEN
+ tabvars%var % updateinf(1)
+ & = locupdate1(1)
+ tabvars%var % updatesup(1)
+ & = locupdate1(2)
+ ENDIF
+
+ IF (present(locupdate2)) THEN
+ tabvars%var % updateinf(2)
+ & = locupdate2(1)
+ tabvars%var % updatesup(2)
+ & = locupdate2(2)
+ ENDIF
+
+ IF (present(procname)) THEN
+ Call Agrif_Update_5D(
+ & roottabvars % var % typeupdate,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % updateinf,
+ & tabvars % var % updatesup,
+ & procname)
+ ELSE
+ Call Agrif_Update_5D(
+ & roottabvars % var % typeupdate,
+ & parenttabvars,
+ & tabvars,q,
+ & tabvars % var % updateinf,
+ & tabvars % var % updatesup)
+ ENDIF
+
+ Return
+ End Subroutine Agrif_update_var5d
+
+ Subroutine Agrif_Declare_Flux(fluxname,profilename)
+ character*(*) :: fluxname, profilename
+ Type(Agrif_Flux), pointer :: newflux
+ Type(Agrif_Profile), pointer :: parcours
+ logical :: foundprofile
+ integer :: i,j,n
+
+ foundprofile = .FALSE.
+ parcours => Agrif_Myprofiles
+
+ Do While (Associated(parcours))
+ IF (parcours % profilename == profilename) THEN
+ foundprofile = .TRUE.
+ EXIT
+ ENDIF
+ parcours => parcours%nextprofile
+ End Do
+
+ IF (.NOT.foundprofile) THEN
+ write(*,*) 'The profile '''
+ & //TRIM(profilename)//''' has not been declared'
+ stop
+ ENDIF
+
+ Allocate(Newflux)
+
+ Newflux % fluxname = fluxname
+
+ Newflux % profile => parcours
+
+ Newflux % nextflux => Agrif_Curgrid % fluxes
+
+ Agrif_Curgrid % fluxes => Newflux
+
+ End Subroutine Agrif_Declare_Flux
+
+ Subroutine Agrif_Save_Flux(fluxname, fluxtab)
+ character*(*) :: fluxname
+ REAL, DIMENSION(:,:) :: fluxtab
+
+
+ Type(Agrif_Flux), pointer :: Flux
+
+ Type(Agrif_pgrid), pointer :: parcours_child
+
+ Type(Agrif_grid), Pointer :: currentgrid,oldcurgrid
+
+ IF (.Not.Agrif_Root()) THEN
+ Flux => Agrif_Search_Flux(fluxname)
+
+ IF (.NOT.Flux%fluxallocated) THEN
+ CALL Agrif_AllocateFlux(Flux,fluxtab)
+ ENDIF
+
+ Call Agrif_Save_Fluxtab(Flux,fluxtab)
+
+ ENDIF
+
+ oldcurgrid=> Agrif_Curgrid
+
+ parcours_child => Agrif_Curgrid%child_grids
+
+ Do While (Associated(parcours_child))
+ currentgrid => parcours_child%gr
+ Agrif_Curgrid => parcours_child%gr
+ Flux => Agrif_Search_Flux(fluxname)
+ IF (.NOT.Flux%fluxallocated) THEN
+ CALL Agrif_AllocateFlux(Flux,fluxtab)
+ ENDIF
+ Call Agrif_Save_Fluxtab_child(Flux,fluxtab)
+ parcours_child=> parcours_child%next
+ End Do
+
+ Agrif_Curgrid=>oldcurgrid
+
+ End Subroutine Agrif_Save_Flux
+
+ Subroutine Agrif_Cancel_Flux(fluxname)
+ character*(*) :: fluxname
+
+ Type(Agrif_Flux), pointer :: Flux
+
+ Flux => Agrif_Search_Flux(fluxname)
+
+ IF (Flux%FluxAllocated) Call Agrif_Cancel_Fluxarray(Flux)
+
+ End Subroutine Agrif_Cancel_Flux
+
+ Subroutine Agrif_Flux_Correction(fluxname, procname)
+ character*(*) :: fluxname
+ external :: procname
+
+ Type(Agrif_Flux), pointer :: Flux
+
+ Flux => Agrif_Search_Flux(fluxname)
+
+ Call Agrif_FluxCorrect(Flux, procname)
+
+
+ End Subroutine Agrif_Flux_Correction
+
+
+
+ Subroutine Agrif_Declare_Profile_flux(profilename,posvar,
+ & firstpoint,raf)
+ character*(*) :: profilename
+ Type(Agrif_Profile), Pointer :: newprofile
+ INTEGER, DIMENSION(:) :: posvar
+ INTEGER, DIMENSION(:) :: firstpoint
+ CHARACTER(*) ,DIMENSION(:) :: raf
+ INTEGER :: dimensio
+
+ dimensio = SIZE(posvar)
+C
+C
+ Allocate(newprofile)
+ Allocate(newprofile%posvar(dimensio))
+ Allocate(newprofile%interptab(dimensio))
+ newprofile%profilename = profilename
+ newprofile%interptab = raf
+ newprofile%nbdim = dimensio
+ newprofile%posvar = posvar
+ newprofile%point(1:dimensio) = firstpoint
+
+ newprofile % nextprofile => Agrif_myprofiles
+
+ Agrif_myprofiles => newprofile
+
+ End Subroutine Agrif_Declare_Profile_flux
+
+ Subroutine Agrif_Save_ForRestore0D(tabvarsindic0,tabvarsindic)
+ integer :: tabvarsindic0, tabvarsindic
+ integer :: dimensio
+
+ dimensio = Agrif_Mygrid % tabvars(tabvarsindic0) % var % nbdim
+
+ select case(dimensio)
+ case(2)
+ call Agrif_Save_ForRestore2D(
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array2,
+ & tabvarsindic)
+ case(3)
+ call Agrif_Save_ForRestore3D(
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array3,
+ & tabvarsindic)
+ case(4)
+ call Agrif_Save_ForRestore4D(
+ & Agrif_Curgrid % tabvars(tabvarsindic0) % var % array4,
+ & tabvarsindic)
+ end select
+
+ Return
+ End Subroutine Agrif_Save_ForRestore0D
+
+
+
+ Subroutine Agrif_Save_ForRestore2D(q,tabvarsindic)
+ real,dimension(:,:) :: q
+ integer :: tabvarsindic, indic
+ TYPE(Agrif_PVariable),Pointer ::tabvars, roottabvars
+
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+ if (.not.allocated(tabvars%var%array2)) then
+ allocate(tabvars%var%array2(tabvars%var%lb(1):tabvars%var%ub(1),
+ & tabvars%var%lb(2):tabvars%var%ub(2)))
+ endif
+ tabvars%var%array2 = q
+ roottabvars%var%restaure = .true.
+
+ Return
+ End Subroutine Agrif_Save_ForRestore2D
+
+ Subroutine Agrif_Save_ForRestore3D(q,tabvarsindic)
+ real,dimension(:,:,:) :: q
+ integer :: tabvarsindic, indic
+ TYPE(Agrif_PVariable),Pointer ::tabvars, roottabvars
+
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+
+ if (.not.allocated(tabvars%var%array3)) then
+ allocate(tabvars%var%array3(tabvars%var%lb(1):tabvars%var%ub(1),
+ & tabvars%var%lb(2):tabvars%var%ub(2),
+ & tabvars%var%lb(3):tabvars%var%ub(3)))
+ endif
+ tabvars%var%array3 = q
+ roottabvars%var%restaure = .true.
+
+ Return
+ End Subroutine Agrif_Save_ForRestore3D
+
+ Subroutine Agrif_Save_ForRestore4D(q,tabvarsindic)
+ real,dimension(:,:,:,:) :: q
+ integer :: tabvarsindic, indic
+ TYPE(Agrif_PVariable),Pointer ::tabvars, roottabvars
+
+ indic = tabvarsindic
+ if (tabvarsindic >=0) then
+ if (agrif_curgrid%tabvars(tabvarsindic)%var%nbdim == 0) then
+ indic = agrif_curgrid%tabvars(tabvarsindic)%var%iarray0
+ endif
+ endif
+
+ if (indic <=0) then
+ tabvars => Agrif_Search_Variable(Agrif_Curgrid,-indic)
+ roottabvars => Agrif_Search_Variable(Agrif_Mygrid,-indic)
+ else
+ tabvars=>Agrif_Curgrid % tabvars(indic)
+ roottabvars => Agrif_Mygrid % tabvars(indic)
+ endif
+
+ if (.not.allocated(tabvars%var%array4)) then
+ allocate(tabvars%var%array4(tabvars%var%lb(1):tabvars%var%ub(1),
+ & tabvars%var%lb(2):tabvars%var%ub(2),
+ & tabvars%var%lb(3):tabvars%var%ub(3),
+ & tabvars%var%lb(4):tabvars%var%ub(4)))
+ endif
+ tabvars%var%array4 = q
+ roottabvars%var%restaure = .true.
+
+ Return
+ End Subroutine Agrif_Save_ForRestore4D
+C
+ End module Agrif_bcfunction
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modcluster.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modcluster.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modcluster.F (revision 8155)
@@ -0,0 +1,1452 @@
+!
+! $Id: modcluster.F 2715 2011-03-30 15:58:35Z rblod $
+!
+C AGRIF (Adaptive Grid Refinement In Fortran)
+C
+C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
+C Christophe Vouland (Christophe.Vouland@imag.fr)
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.
+C
+C
+C
+CCC Module AGRIF_Clustering
+C
+C
+ Module Agrif_Clustering
+C
+CCC Description:
+CCC Module to create and initialize the grid hierarchy from the
+CCC AGRIF_FixedGrids.in file.
+C
+C Modules used:
+C
+ Use Agrif_Curgridfunctions
+ Use Agrif_Init_Vars
+ Use Agrif_Save
+C
+ IMPLICIT NONE
+C
+ Contains
+C Define procedures contained in this module
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Cluster_All
+C **************************************************************************
+C
+ Recursive Subroutine Agrif_Cluster_All(g,coarsegrid)
+C
+CCC Description:
+CCC Subroutine for the clustering. A temporary grid hierarchy, pointed by
+CCC coarsegrid, is created.
+C
+CC Method:
+CC
+C
+C Declarations:
+C
+C Pointer arguments
+ TYPE(AGRIF_grid) ,pointer :: g ! Pointer on the current grid
+ TYPE(AGRIF_rectangle),pointer :: coarsegrid
+C
+C Local pointer
+ TYPE(AGRIF_lrectangle),pointer :: parcours
+ TYPE(AGRIF_grid) ,pointer :: newgrid
+ REAL :: g_eps
+ INTEGER :: iii
+C
+ g_eps = huge(1.)
+ do iii = 1 , Agrif_Probdim
+ g_eps = min(g_eps,g%Agrif_d(iii))
+ enddo
+C
+ g_eps = g_eps/100.
+C
+C Necessary condition for clustering
+ do iii = 1 , Agrif_Probdim
+ if (g%Agrif_d(iii)/Agrif_coeffref(iii).LT.
+ & (Agrif_mind(iii)-g_eps)) Return
+ enddo
+C
+ Nullify(coarsegrid%childgrids)
+C
+ Call Agrif_ClusterGridnD(g,coarsegrid)
+C
+ parcours => coarsegrid % childgrids
+C
+ do while (associated(parcours))
+C
+C Newgrid is created. It is a copy of a fine grid created previously by
+C clustering.
+ Allocate(newgrid)
+C
+ Nullify(newgrid%child_grids)
+C
+ do iii = 1 , Agrif_Probdim
+ newgrid % nb(iii) = (parcours % r % imax(iii) -
+ & parcours % r % imin(iii)) *
+ & Agrif_Coeffref(iii)
+C
+ newgrid % Agrif_x(iii) = g%Agrif_x(iii) +
+ & (parcours %r % imin(iii) -1)
+ & *g%Agrif_d(iii)
+C
+ newgrid % Agrif_d(iii) = g%Agrif_d(iii) / Agrif_Coeffref(iii)
+C
+ enddo
+C
+ if ( Agrif_Probdim .EQ. 1 ) then
+ allocate(newgrid%tabpoint1D(newgrid%nb(1)+1))
+ newgrid%tabpoint1D = 0
+ endif
+C
+ if ( Agrif_Probdim .EQ. 2 ) then
+ allocate(newgrid%tabpoint2D(newgrid%nb(1)+1,
+ & newgrid%nb(2)+1))
+ newgrid%tabpoint2D = 0
+ endif
+C
+ if ( Agrif_Probdim .EQ. 3 ) then
+ allocate(newgrid%tabpoint3D(newgrid%nb(1)+1,
+ & newgrid%nb(2)+1,
+ & newgrid%nb(3)+1))
+ newgrid%tabpoint3D = 0
+ endif
+C Points detection on newgrid
+ Call Agrif_TabpointsnD(Agrif_mygrid,newgrid)
+C
+C Recursive call to Agrif_Cluster_All
+ Call Agrif_Cluster_All (newgrid, parcours % r)
+C
+ parcours => parcours % next
+C
+ if ( Agrif_Probdim .EQ. 1 ) Deallocate(newgrid%tabpoint1D)
+ if ( Agrif_Probdim .EQ. 2 ) Deallocate(newgrid%tabpoint2D)
+ if ( Agrif_Probdim .EQ. 3 ) Deallocate(newgrid%tabpoint3D)
+C
+ Deallocate(newgrid)
+C
+ enddo
+C
+C
+ End Subroutine Agrif_Cluster_All
+C
+C **************************************************************************
+CCC Subroutine Agrif_TabpointsnD
+C **************************************************************************
+C
+ Recursive Subroutine Agrif_TabpointsnD(g,newgrid)
+C
+CCC Description:
+CCC Copy on newgrid of points detected on the grid hierarchy pointed by g.
+C
+CC Method:
+CC
+C
+C Declarations:
+C
+C Arguments
+ TYPE(Agrif_Grid),pointer :: g,newgrid
+C
+C Local variables
+ TYPE(Agrif_Pgrid),pointer :: parcours
+C
+ REAL :: g_eps,newgrid_eps,eps
+ REAL , DIMENSION(3) :: newmin,newmax
+ REAL , DIMENSION(3) :: gmin,gmax
+ REAL , DIMENSION(3) :: xmin
+ INTEGER, DIMENSION(3) :: igmin,inewmin
+ INTEGER, DIMENSION(3) :: inewmax
+ INTEGER :: iii
+ INTEGER :: i,j,k
+ INTEGER :: i0,j0,k0
+C
+C
+ parcours => g % child_grids
+C
+ do While(associated(parcours))
+ Call Agrif_TabpointsnD(parcours%gr,newgrid)
+ parcours => parcours % next
+ enddo
+C
+ g_eps = 10.
+ newgrid_eps = 10.
+C
+ do iii = 1 , Agrif_probdim
+ g_eps = min( g_eps , g % Agrif_d(iii) )
+ newgrid_eps = min(newgrid_eps,newgrid%Agrif_d(iii))
+ enddo
+C
+ eps = min(g_eps,newgrid_eps)/100.
+C
+ do iii = 1 , Agrif_probdim
+ if (newgrid%Agrif_d(iii) .LT. (g%Agrif_d(iii)-eps)) Return
+C
+ gmin(iii) = g%Agrif_x(iii)
+ gmax(iii) = g%Agrif_x(iii) + g%nb(iii) * g%Agrif_d(iii)
+C
+ newmin(iii) = newgrid%Agrif_x(iii)
+ newmax(iii) = newgrid%Agrif_x(iii) + newgrid%nb(iii) *
+ & newgrid%Agrif_d(iii)
+C
+ if (gmax(iii) .LT. newmin(iii)) Return
+C
+ if (gmin(iii) .GT. newmax(iii)) Return
+C
+ inewmin(iii) = 1 - floor(-(max(gmin(iii),newmin(iii))-
+ & newmin(iii))
+ & /newgrid%Agrif_d(iii))
+C
+ xmin(iii) = newgrid%Agrif_x(iii) + (inewmin(iii)-1)*
+ & newgrid%Agrif_d(iii)
+C
+ igmin(iii) = 1 + nint((xmin(iii)-gmin(iii))/g%Agrif_d(iii))
+C
+ inewmax(iii) = 1 + int((min(gmax(iii),newmax(iii))-
+ & newmin(iii))/newgrid%Agrif_d(iii))
+ enddo
+C
+ if ( Agrif_probdim .EQ. 1 ) then
+ i0 = igmin(1)
+ do i = inewmin(1),inewmax(1)
+ newgrid%tabpoint1D(i) = max(
+ & newgrid%tabpoint1D(i),
+ & g%tabpoint1D(i0))
+ enddo
+ i0 = i0 + int(newgrid%Agrif_d(1)/g%Agrif_d(1))
+ endif
+C
+ if ( Agrif_probdim .EQ. 2 ) then
+ i0 = igmin(1)
+ do i = inewmin(1),inewmax(1)
+ j0 = igmin(2)
+ do j = inewmin(2),inewmax(2)
+ newgrid%tabpoint2D(i,j) = max(
+ & newgrid%tabpoint2D(i,j),
+ & g%tabpoint2D(i0,j0))
+ j0 = j0 + int(newgrid%Agrif_d(2)/g%Agrif_d(2))
+ enddo
+ i0 = i0 + int(newgrid%Agrif_d(1)/g%Agrif_d(1))
+ enddo
+ endif
+C
+ if ( Agrif_probdim .EQ. 3 ) then
+ i0 = igmin(1)
+ do i = inewmin(1),inewmax(1)
+ j0 = igmin(2)
+ do j = inewmin(2),inewmax(2)
+ k0 = igmin(3)
+ do k = inewmin(3),inewmax(3)
+ newgrid%tabpoint3D(i,j,k) = max(
+ & newgrid%tabpoint3D(i,j,k),
+ & g%tabpoint3D(i0,j0,k0))
+ k0 = k0 + int(newgrid%Agrif_d(3)/g%Agrif_d(3))
+ enddo
+ j0 = j0 + int(newgrid%Agrif_d(2)/g%Agrif_d(2))
+ enddo
+ i0 = i0 + int(newgrid%Agrif_d(1)/g%Agrif_d(1))
+ enddo
+ endif
+C
+ Return
+C
+C
+ End Subroutine Agrif_TabpointsnD
+C
+C **************************************************************************
+CCC Subroutine Agrif_ClusterGridnD
+C **************************************************************************
+C
+ Subroutine Agrif_ClusterGridnD(g,coarsegrid)
+C
+CCC Description:
+CCC Clustering on the grid pointed by g.
+C
+CC Method:
+CC
+C
+C Declarations:
+C
+C Pointer arguments
+ TYPE(AGRIF_grid) ,pointer :: g ! Pointer on the current grid
+ TYPE(AGRIF_rectangle),pointer :: coarsegrid
+C
+C Local variables
+ TYPE(Agrif_rectangle) :: newrect
+ TYPE(Agrif_Variable) :: newflag
+C
+ INTEGER :: i,j,k
+ INTEGER ,DIMENSION(3) :: sx
+ INTEGER :: bufferwidth,flagpoints
+ INTEGER :: n1,n2,m1,m2,o1,o2
+ INTEGER :: iii
+C
+C
+ bufferwidth = int(Agrif_Minwidth/5.)
+C
+ do iii = 1 , Agrif_probdim
+ sx(iii) = g % nb(iii) + 1
+ enddo
+C
+ if ( Agrif_probdim .EQ. 1 ) then
+ allocate(newflag%iarray1(sx(1)))
+ newflag%iarray1 = 0
+ endif
+ if ( Agrif_probdim .EQ. 2 ) then
+ allocate(newflag%iarray2(sx(1),sx(2)))
+ newflag%iarray2 = 0
+ endif
+ if ( Agrif_probdim .EQ. 3 ) then
+ allocate(newflag%iarray3(sx(1),sx(2),sx(3)))
+ newflag%iarray3 = 0
+ endif
+C
+ flagpoints = 0
+C
+ if (bufferwidth>0) then
+C
+ if ( Agrif_probdim .EQ. 1 ) then
+ do i = bufferwidth,sx(1)-bufferwidth+1
+ if (g % tabpoint1D(i) .EQ. 1) then
+ m1 = i - bufferwidth + 1
+ m2 = i + bufferwidth - 1
+ flagpoints = flagpoints + 1
+ newflag%iarray1(m1:m2)=1
+ endif
+ enddo
+ endif
+C
+ if ( Agrif_probdim .EQ. 2 ) then
+ do i = bufferwidth,sx(1)-bufferwidth+1
+ do j = bufferwidth,sx(2)-bufferwidth+1
+ if (g % tabpoint2D(i,j) .EQ. 1) then
+ n1 = j - bufferwidth + 1
+ n2 = j + bufferwidth - 1
+ m1 = i - bufferwidth + 1
+ m2 = i + bufferwidth - 1
+ flagpoints = flagpoints + 1
+ newflag%iarray2(m1:m2,n1:n2)=1
+ endif
+ enddo
+ enddo
+ endif
+C
+ if ( Agrif_probdim .EQ. 3 ) then
+ do i = bufferwidth,sx(1)-bufferwidth+1
+ do j = bufferwidth,sx(2)-bufferwidth+1
+ do k = bufferwidth,sx(3)-bufferwidth+1
+ if (g % tabpoint3D(i,j,k) .EQ. 1) then
+ o1 = k - bufferwidth + 1
+ o2 = k + bufferwidth - 1
+ n1 = j - bufferwidth + 1
+ n2 = j + bufferwidth - 1
+ m1 = i - bufferwidth + 1
+ m2 = i + bufferwidth - 1
+ flagpoints = flagpoints + 1
+ newflag%iarray3(m1:m2,n1:n2,o1:o2)=1
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+ else
+ flagpoints = 1
+C
+ if ( Agrif_probdim .EQ. 1 ) then
+ newflag%iarray1 = g % tabpoint1D
+ endif
+ if ( Agrif_probdim .EQ. 2 ) then
+ newflag%iarray2 = g % tabpoint2D
+ endif
+ if ( Agrif_probdim .EQ. 3 ) then
+ newflag%iarray3 = g % tabpoint3D
+ endif
+ endif
+C
+ if (flagpoints .EQ. 0) then
+ if ( Agrif_probdim .EQ. 1 ) deallocate(newflag%iarray1)
+ if ( Agrif_probdim .EQ. 2 ) deallocate(newflag%iarray2)
+ if ( Agrif_probdim .EQ. 3 ) deallocate(newflag%iarray3)
+ Return
+ endif
+C
+ do iii = 1 , Agrif_probdim
+ newrect % imin(iii) = 1
+ newrect % imax(iii) = sx(iii)
+ enddo
+C
+ Call Agrif_Clusternd(newflag,
+ & coarsegrid%childgrids,newrect)
+C
+ if ( Agrif_probdim .EQ. 1 ) deallocate(newflag%iarray1)
+ if ( Agrif_probdim .EQ. 2 ) deallocate(newflag%iarray2)
+ if ( Agrif_probdim .EQ. 3 ) deallocate(newflag%iarray3)
+C
+C
+ End Subroutine Agrif_ClusterGridnD
+C
+C **************************************************************************
+CCC Subroutine Agrif_ClusternD
+C **************************************************************************
+C
+ Recursive subroutine Agrif_Clusternd(flag,boxlib,oldB)
+C
+CCC Description:
+CCC Clustering on the grid pointed by oldB.
+C
+CC Method:
+CC
+C
+C Declarations:
+C
+C Arguments
+ TYPE(Agrif_rectangle) :: oldB
+ TYPE(Agrif_Variable) :: flag
+c INTEGER,DIMENSION(oldB%imin(1):oldB%imax(1),
+c & oldB%imin(2):oldB%imax(2)) :: flag
+ TYPE(Agrif_lrectangle),pointer :: boxlib
+C
+C Local variables
+ TYPE(Agrif_lrectangle),pointer :: tempbox,parcbox,parcbox2
+ TYPE(Agrif_rectangle) :: newB,newB2
+ INTEGER :: i,j,k,iii
+ INTEGER,DIMENSION(:),allocatable :: i_sig
+ INTEGER,DIMENSION(:),allocatable :: j_sig
+ INTEGER,DIMENSION(:),allocatable :: k_sig
+ INTEGER,DIMENSION(3) :: ipu,ipl
+ INTEGER,DIMENSION(3) :: istr,islice
+ REAL :: cureff
+ REAL :: neweff
+ INTEGER :: ValMax,ValSum,TailleTab
+ INTEGER :: nbpoints,nbpointsflag
+ LOGICAL :: test
+C
+ allocate(i_sig(oldB%imin(1):oldB%imax(1)))
+ if ( Agrif_probdim .GE. 2 )
+ & allocate(j_sig(oldB%imin(2):oldB%imax(2)))
+ if ( Agrif_probdim .EQ. 3 )
+ & allocate(k_sig(oldB%imin(3):oldB%imax(3)))
+C
+ test = .FALSE.
+ do iii = 1 , Agrif_probdim
+ test = test .OR. ( (oldB%imax(iii)-oldB%imin(iii)+1)
+ & .LT. Agrif_Minwidth)
+ enddo
+ if ( test ) Return
+C
+ if ( Agrif_probdim .EQ. 1 ) i_sig = flag%iarray1
+ if ( Agrif_probdim .EQ. 2 ) then
+ do i = oldB%imin(1),oldB%imax(1)
+ i_sig(i) = SUM(flag%iarray2(i,
+ & oldB%imin(2):oldB%imax(2)))
+ enddo
+ do j = oldB%imin(2),oldB%imax(2)
+ j_sig(j) = SUM(flag%iarray2(
+ & oldB%imin(1):oldB%imax(1),j))
+ enddo
+ endif
+ if ( Agrif_probdim .EQ. 3 ) then
+ do i = oldB%imin(1),oldB%imax(1)
+ i_sig(i) = SUM(flag%iarray3(i,
+ & oldB%imin(2):oldB%imax(2),
+ & oldB%imin(3):oldB%imax(3)))
+ enddo
+ do j = oldB%imin(2),oldB%imax(2)
+ j_sig(j) = SUM(flag%iarray3(
+ & oldB%imin(1):oldB%imax(1),j,
+ & oldB%imin(3):oldB%imax(3)))
+ enddo
+ do k = oldB%imin(3),oldB%imax(3)
+ k_sig(k) = SUM(flag%iarray3(
+ & oldB%imin(1):oldB%imax(1),
+ & oldB%imin(2):oldB%imax(2),k))
+ enddo
+ endif
+C
+ do iii = 1 , Agrif_probdim
+ ipl(iii) = oldB%imin(iii)
+ ipu(iii) = oldB%imax(iii)
+ enddo
+C
+ Call Agrif_Clusterprune(i_sig,ipl(1),ipu(1))
+ if ( Agrif_probdim .GE. 2 )
+ & Call Agrif_Clusterprune(j_sig,ipl(2),ipu(2))
+ if ( Agrif_probdim .EQ. 3 )
+ & Call Agrif_Clusterprune(k_sig,ipl(3),ipu(3))
+C
+ test = .TRUE.
+ do iii = 1 , Agrif_probdim
+ test = test .AND. (ipl(iii).EQ.oldB%imin(iii))
+ test = test .AND. (ipu(iii).EQ.oldB%imax(iii))
+ enddo
+
+ if (.NOT. test) then
+ do iii = 1 , Agrif_probdim
+ newB%imin(iii) = ipl(iii)
+ newB%imax(iii) = ipu(iii)
+ enddo
+C
+ if ( Agrif_probdim .EQ. 1 )
+ & nbpoints = SUM(flag%iarray1(newB%imin(1):newB%imax(1)))
+ if ( Agrif_probdim .EQ. 2 )
+ & nbpoints = SUM(flag%iarray2(newB%imin(1):newB%imax(1),
+ & newB%imin(2):newB%imax(2)))
+ if ( Agrif_probdim .EQ. 3 )
+ & nbpoints = SUM(flag%iarray3(newB%imin(1):newB%imax(1),
+ & newB%imin(2):newB%imax(2),
+ & newB%imin(3):newB%imax(3)))
+C
+ if ( Agrif_probdim .EQ. 1 )
+ & TailleTab = newB%imax(1)-newB%imin(1)+1
+ if ( Agrif_probdim .EQ. 2 )
+ & TailleTab = (newB%imax(1)-newB%imin(1)+1)*
+ & (newB%imax(2)-newB%imin(2)+1)
+ if ( Agrif_probdim .EQ. 3 )
+ & TailleTab = (newB%imax(1)-newB%imin(1)+1)*
+ & (newB%imax(2)-newB%imin(2)+1)*
+ & (newB%imax(3)-newB%imin(3)+1)
+C
+ neweff = REAL(nbpoints)/TailleTab
+C
+ if (nbpoints.GT.0) then
+C
+ if ((neweff .GT .Agrif_efficiency)) then
+ Call Agrif_Add_Rectangle(newB,boxlib)
+ Return
+ else
+C
+ tempbox => boxlib
+ newB2 = newB
+ Call Agrif_Clusternd(flag,
+ & boxlib,newB)
+C
+C Compute new efficiency
+C
+ cureff = neweff
+ parcbox2 => boxlib
+ nbpoints = 0
+ nbpointsflag = 0
+C
+ do While (associated(parcbox2))
+ if (associated(parcbox2,tempbox)) Exit
+ newB = parcbox2%r
+C
+ if ( Agrif_probdim .EQ. 1 ) Valsum =
+ & SUM(flag%iarray1(
+ & newB%imin(1):newB%imax(1)))
+ if ( Agrif_probdim .EQ. 2 ) Valsum =
+ & SUM(flag%iarray2(
+ & newB%imin(1):newB%imax(1),
+ & newB%imin(2):newB%imax(2)))
+ if ( Agrif_probdim .EQ. 3 ) Valsum =
+ & SUM(flag%iarray3(
+ & newB%imin(1):newB%imax(1),
+ & newB%imin(2):newB%imax(2),
+ & newB%imin(3):newB%imax(3)))
+C
+ nbpointsflag = nbpointsflag + ValSum
+ if ( Agrif_probdim .EQ. 1 )
+ & TailleTab = newB%imax(1)-newB%imin(1)+1
+ if ( Agrif_probdim .EQ. 2 )
+ & TailleTab = (newB%imax(1)-newB%imin(1)+1)*
+ & (newB%imax(2)-newB%imin(2)+1)
+ if ( Agrif_probdim .EQ. 3 )
+ & TailleTab = (newB%imax(1)-newB%imin(1)+1)*
+ & (newB%imax(2)-newB%imin(2)+1)*
+ & (newB%imax(3)-newB%imin(3)+1)
+ nbpoints = nbpoints + TailleTab
+ parcbox2 => parcbox2%next
+ enddo
+C coefficient 1.05 avant 1.15 possibilité de laisser choix à l utilisateur
+ if (REAL(nbpointsflag)/REAL(nbpoints)
+ & .LT.(1.0001*cureff)) then
+ parcbox2 => boxlib
+ do While (associated(parcbox2))
+ if (associated(parcbox2,tempbox)) Exit
+ deallocate(parcbox2%r)
+ parcbox2 => parcbox2%next
+ enddo
+ boxlib => tempbox
+ Call Agrif_Add_Rectangle(newB2,boxlib)
+ Return
+ endif
+ endif
+ endif
+ Return
+ endif
+C
+ do iii = 1 , Agrif_Probdim
+ istr(iii) = oldB%imax(iii)
+ islice(iii) = oldB%imin(iii)
+ enddo
+C
+ Call Agrif_Clusterslice(i_sig,islice(1),istr(1))
+ if ( Agrif_probdim .GE. 2 )
+ & Call Agrif_Clusterslice(j_sig,islice(2),istr(2))
+ if ( Agrif_probdim .EQ. 3 )
+ & Call Agrif_Clusterslice(k_sig,islice(3),istr(3))
+C
+ ValSum = 0
+ do iii = 1 , Agrif_Probdim
+ Valsum = valSum + islice(iii)
+ enddo
+C
+ if ( Valsum .EQ. -Agrif_Probdim ) then
+ Call Agrif_Add_Rectangle(oldB,boxlib)
+ Return
+ endif
+C
+ nullify(tempbox)
+ tempbox => boxlib
+ if ( Agrif_probdim .EQ. 1 )
+ & cureff = oldB%imax(1)-oldB%imin(1)+1
+ if ( Agrif_probdim .EQ. 2 )
+ & cureff = (oldB%imax(1)-oldB%imin(1)+1)*
+ & (oldB%imax(2)-oldB%imin(2)+1)
+ if ( Agrif_probdim .EQ. 3 )
+ & cureff = (oldB%imax(1)-oldB%imin(1)+1)*
+ & (oldB%imax(2)-oldB%imin(2)+1)*
+ & (oldB%imax(3)-oldB%imin(3)+1)
+ Nullify(parcbox)
+C
+ do iii = 1 , Agrif_Probdim
+ newB%imax(iii) = oldB%imax(iii)
+ newB%imin(iii) = oldB%imin(iii)
+ enddo
+C
+ ValMax = 0
+ do iii = 1 , Agrif_Probdim
+ ValMax = Max(ValMax,istr(iii))
+ enddo
+C
+ if (istr(1) .EQ. ValMax ) then
+ newB%imax(1) = islice(1)
+ Call Agrif_Add_Rectangle(newB,parcbox)
+ newB%imin(1) = islice(1)+1
+ newB%imax(1) = oldB%imax(1)
+ Call Agrif_Add_Rectangle(newB,parcbox)
+ elseif ( Agrif_probdim .GE. 2 ) then
+ if (istr(2) .EQ. ValMax ) then
+ newB%imax(2) = islice(2)
+ Call Agrif_Add_Rectangle(newB,parcbox)
+ newB%imin(2) = islice(2)+1
+ newB%imax(2) = oldB%imax(2)
+ Call Agrif_Add_Rectangle(newB,parcbox)
+ elseif ( Agrif_probdim .EQ. 3 ) then
+ newB%imax(3) = islice(3)
+ Call Agrif_Add_Rectangle(newB,parcbox)
+ newB%imin(3) = islice(3)+1
+ newB%imax(3) = oldB%imax(3)
+ Call Agrif_Add_Rectangle(newB,parcbox)
+ endif
+ endif
+C
+ do While (associated(parcbox))
+ newB = parcbox%r
+C
+ if ( Agrif_probdim .EQ. 1 ) nbpoints =
+ & SUM(flag%iarray1(
+ & newB%imin(1):newB%imax(1)))
+ if ( Agrif_probdim .EQ. 2 ) nbpoints =
+ & SUM(flag%iarray2(
+ & newB%imin(1):newB%imax(1),
+ & newB%imin(2):newB%imax(2)))
+ if ( Agrif_probdim .EQ. 3 ) nbpoints =
+ & SUM(flag%iarray3(
+ & newB%imin(1):newB%imax(1),
+ & newB%imin(2):newB%imax(2),
+ & newB%imin(3):newB%imax(3)))
+C
+ if ( Agrif_probdim .EQ. 1 )
+ & TailleTab = newB%imax(1)-newB%imin(1)+1
+ if ( Agrif_probdim .EQ. 2 )
+ & TailleTab = (newB%imax(1)-newB%imin(1)+1)*
+ & (newB%imax(2)-newB%imin(2)+1)
+ if ( Agrif_probdim .EQ. 3 )
+ & TailleTab = (newB%imax(1)-newB%imin(1)+1)*
+ & (newB%imax(2)-newB%imin(2)+1)*
+ & (newB%imax(3)-newB%imin(3)+1)
+
+ neweff = REAL(nbpoints) / TailleTab
+C
+ if (nbpoints .GT. 0) then
+C
+ if ((neweff .GT .Agrif_efficiency)) then
+ Call Agrif_Add_Rectangle(newB,boxlib)
+ else
+ tempbox => boxlib
+ newB2 = newB
+ Call Agrif_Clusternd(flag,
+ & boxlib,newB)
+C
+C Compute new efficiency
+C
+ cureff = neweff
+ parcbox2 => boxlib
+ nbpoints = 0
+ nbpointsflag = 0
+C
+ do While (associated(parcbox2))
+ if (associated(parcbox2,tempbox)) Exit
+ newB = parcbox2%r
+C
+ if ( Agrif_probdim .EQ. 1 ) ValSum =
+ & SUM(flag%iarray1(
+ & newB%imin(1):newB%imax(1)))
+ if ( Agrif_probdim .EQ. 2 ) ValSum =
+ & SUM(flag%iarray2(
+ & newB%imin(1):newB%imax(1),
+ & newB%imin(2):newB%imax(2)))
+ if ( Agrif_probdim .EQ. 3 ) ValSum =
+ & SUM(flag%iarray3(
+ & newB%imin(1):newB%imax(1),
+ & newB%imin(2):newB%imax(2),
+ & newB%imin(3):newB%imax(3)))
+C
+ nbpointsflag = nbpointsflag + ValSum
+C
+ if ( Agrif_probdim .EQ. 1 )
+ & TailleTab = newB%imax(1)-newB%imin(1)+1
+ if ( Agrif_probdim .EQ. 2 )
+ & TailleTab = (newB%imax(1)-newB%imin(1)+1)*
+ & (newB%imax(2)-newB%imin(2)+1)
+ if ( Agrif_probdim .EQ. 3 )
+ & TailleTab = (newB%imax(1)-newB%imin(1)+1)*
+ & (newB%imax(2)-newB%imin(2)+1)*
+ & (newB%imax(3)-newB%imin(3)+1)
+
+ nbpoints = nbpoints + TailleTab
+C
+ parcbox2 => parcbox2%next
+ enddo
+C
+ if (REAL(nbpointsflag)/REAL(nbpoints)
+ & .LT.(1.15*cureff)) then
+ parcbox2 => boxlib
+ do While (associated(parcbox2))
+ if (associated(parcbox2,tempbox)) Exit
+ deallocate(parcbox2%r)
+ parcbox2 => parcbox2%next
+ enddo
+ boxlib => tempbox
+ Call Agrif_Add_Rectangle(newB2,boxlib)
+ endif
+ endif
+ endif
+ parcbox => parcbox%next
+ enddo
+C
+C
+ Return
+C
+ End Subroutine Agrif_Clusternd
+C
+C **************************************************************************
+CCC Subroutine Agrif_Clusterslice
+C **************************************************************************
+C
+ Subroutine Agrif_Clusterslice(sig,slice,str)
+C
+C
+CCC Description:
+CCC
+C
+CC Method:
+CC
+C
+C Declarations:
+C
+C Arguments
+ INTEGER :: slice,str
+ INTEGER,DIMENSION(slice:str) :: sig
+C
+C Local variables
+ INTEGER :: ideb,ifin
+ INTEGER :: i,t,a,di,ts
+ INTEGER,DIMENSION(slice:str) :: lap
+C
+C
+ ideb = slice
+ ifin = str
+C
+ if (SIZE(sig) <= 2*Agrif_Minwidth) then
+ str = -1
+ slice = -1
+ Return
+ endif
+C
+ t = -1
+ a = -1
+C
+ do i = ideb+Agrif_Minwidth-1,ifin-Agrif_Minwidth
+ if (sig(i) .EQ. 0) then
+ if ((i-ideb) < (ifin-i)) then
+ di = i - ideb
+ else
+ di = ifin - i
+ endif
+C
+ if (di > t) then
+ a = i
+ t = di
+ endif
+ endif
+ enddo
+C
+ if (a .NE. (-1)) then
+ slice = a
+ str = t
+ Return
+ endif
+C
+ t = -1
+ a = -1
+C
+ do i = ideb+1,ifin-1
+ lap(i) = sig(i+1) + sig(i-1) - 2*sig(i)
+ enddo
+C
+ do i = ideb + Agrif_Minwidth-1,ifin-Agrif_Minwidth
+ if ((lap(i+1)*lap(i)) .LE. 0) then
+ ts = ABS(lap(i+1) - lap(i))
+ if (ts > t) then
+ t = ts
+ a = i
+ endif
+ endif
+ enddo
+C
+ if (a .EQ. (ideb + Agrif_Minwidth - 1)) then
+ a = -1
+ t = -1
+ endif
+C
+ slice = a
+ str = t
+C
+C
+ End Subroutine Agrif_Clusterslice
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Clusterprune
+C **************************************************************************
+C
+ Subroutine Agrif_Clusterprune(sig,pl,pu)
+C
+C
+CCC Description:
+CCC
+C
+CC Method:
+CC
+C
+C Declarations:
+C
+C Arguments
+ INTEGER :: pl,pu
+ INTEGER,DIMENSION(pl:pu) :: sig
+C
+C Local variables
+ INTEGER :: ideb,ifin
+ INTEGER :: diff,addl,addu,udist,ldist
+C
+C
+ ideb = pl
+ ifin = pu
+C
+ if (SIZE(sig) <= Agrif_Minwidth) then
+ return
+ endif
+C
+ do While ((sig(pl) .EQ. 0) .AND. (pl < ifin))
+ pl = pl + 1
+ enddo
+C
+ do While ((sig(pu) .EQ. 0) .AND. (pu > ideb))
+ pu = pu - 1
+ enddo
+C
+ if ((pu-pl) < Agrif_Minwidth) then
+ diff = Agrif_Minwidth - (pu - pl + 1)
+ udist = ifin - pu
+ ldist = pl - ideb
+ addl = diff / 2
+ addu = diff - addl
+ if (addu > udist) then
+ addu = udist
+ addl = diff - addu
+ endif
+C
+ if (addl > ldist) then
+ addl = ldist
+ addu = diff - addl
+ endif
+C
+ pu = pu + addu
+ pl = pl - addl
+C
+ endif
+C
+C
+ End Subroutine Agrif_Clusterprune
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Add_Rectangle
+C **************************************************************************
+C
+ Subroutine Agrif_Add_Rectangle(R,LR)
+C
+CCC Description:
+CCC Subroutine to add the Agrif_Rectangle R in a list managed by LR.
+C
+C Declarations:
+C
+C Arguments
+ TYPE(AGRIF_rectangle) :: R
+ TYPE(AGRIF_lrectangle), Pointer :: LR
+C
+C Local variable
+ TYPE(AGRIF_lrectangle), Pointer :: newrect
+C
+ INTEGER :: iii
+C
+C
+ allocate(newrect)
+ allocate(newrect % r)
+C
+ newrect % r = R
+C
+ do iii = 1 , Agrif_Probdim
+ newrect % r % spaceref(iii) = Agrif_Coeffref(iii)
+ newrect % r % timeref(iii) = Agrif_Coeffreft(iii)
+ enddo
+C
+ newrect % r % number = -1
+ Nullify(newrect % r % childgrids)
+ newrect % next => LR
+ LR => newrect
+C
+C
+ End Subroutine Agrif_Add_Rectangle
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Read_Fix_Grd
+C **************************************************************************
+C
+ Recursive Subroutine Agrif_Read_Fix_Grd(coarsegrid,j,nunit)
+C
+CCC Description:
+CCC Subroutine to create the grid hierarchy from the reading of the
+CCC AGRIF_FixedGrids.in file.
+C
+CC Method:
+CC Recursive subroutine and creation of a first grid hierarchy from the
+CC reading of the AGRIF_FixedGrids.in file.
+C
+C Declarations:
+C
+C Pointer argument
+ TYPE(AGRIF_rectangle), Pointer :: coarsegrid ! Pointer on the first grid
+ ! of the grid hierarchy
+C
+C Scalar arguments
+ INTEGER :: j ! Number of the new grid
+ INTEGER :: nunit ! unit associated with file
+C
+C Local variables
+ TYPE(AGRIF_rectangle) :: newrect ! Pointer on a new grid
+ TYPE(AGRIF_lrectangle), Pointer :: parcours ! Pointer for the recursive
+ ! procedure
+ TYPE(AGRIF_lrectangle), Pointer :: newlrect
+ TYPE(AGRIF_lrectangle), Pointer :: end_list
+ INTEGER :: i ! for each child grid
+ INTEGER :: nb_grids ! Number of child grids
+ INTEGER :: iii
+C
+C
+ Nullify(newrect%childgrids)
+C
+C Reading of the number of child grids
+ read(nunit,*) nb_grids
+C
+C coarsegrid%nbgridchild = nb_grids
+C
+ allocate(end_list)
+C
+ nullify(end_list % r)
+ nullify(end_list % next)
+C
+ coarsegrid % childgrids => end_list
+C
+C Reading of imin(1),imax(1),imin(2),imax(2),imin(3),imax(3), and space and
+C time refinement factors for each child grid.
+C Creation and addition of the new grid to the grid hierarchy.
+C
+ do i = 1,nb_grids
+ allocate(newlrect)
+ newrect % number = j ! Number of the grid
+C
+ if ( Agrif_USE_ONLY_FIXED_GRIDS .EQ. 0 ) then
+ if (Agrif_Probdim == 3) then
+ read(nunit,*) newrect % imin(1), newrect % imax(1),
+ & newrect % imin(2), newrect % imax(2),
+ & newrect % imin(3), newrect % imax(3),
+ & newrect % spaceref(1),newrect % spaceref(2),
+ & newrect % spaceref(3),
+ & newrect % timeref(1),newrect % timeref(2),
+ & newrect % timeref(3)
+ elseif (Agrif_Probdim == 2) then
+ read(nunit,*) newrect % imin(1),newrect % imax(1),
+ & newrect % imin(2),newrect % imax(2),
+ & newrect % spaceref(1),newrect % spaceref(2),
+ & newrect % timeref(1),newrect % timeref(2)
+ elseif (Agrif_Probdim == 1) then
+ read(nunit,*) newrect % imin(1), newrect % imax(1),
+ & newrect % spaceref(1),
+ & newrect % timeref(1)
+ endif
+ else
+ if (Agrif_Probdim == 3) then
+ read(nunit,*) newrect % imin(1), newrect % imax(1),
+ & newrect % imin(2), newrect % imax(2),
+ & newrect % imin(3), newrect % imax(3),
+ & newrect % spaceref(1),newrect % spaceref(2),
+ & newrect % spaceref(3),
+ & newrect % timeref(1)
+ elseif (Agrif_Probdim == 2) then
+ read(nunit,*) newrect % imin(1),newrect % imax(1),
+ & newrect % imin(2),newrect % imax(2),
+ & newrect % spaceref(1),newrect % spaceref(2),
+ & newrect % timeref(1)
+ elseif (Agrif_Probdim == 1) then
+ read(nunit,*) newrect % imin(1), newrect % imax(1),
+ & newrect % spaceref(1),
+ & newrect % timeref(1)
+ endif
+C
+ if ( Agrif_probdim .GE. 2 ) then
+ do iii = 2 , Agrif_probdim
+ newrect % timeref(iii) = newrect % timeref(1)
+ enddo
+ endif
+C
+ endif
+C
+C Addition to the grid hierarchy
+C
+ nullify(newrect % childgrids)
+ j = j + 1
+ Allocate(newlrect%r)
+ newlrect % r = newrect
+ nullify(newlrect % next)
+ end_list % next => newlrect
+ end_list => end_list % next
+ enddo
+C
+ coarsegrid % childgrids => coarsegrid % childgrids % next
+ parcours => coarsegrid % childgrids
+C
+C Recursive operation to create the grid hierarchy branch by branch
+C
+ do while (associated(parcours))
+ call Agrif_Read_Fix_Grd (parcours % r,j,nunit)
+ parcours => parcours % next
+ enddo
+C
+C
+ End Subroutine Agrif_Read_Fix_Grd
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Create_Grids
+C **************************************************************************
+C
+ Recursive Subroutine Agrif_Create_Grids(g,coarsegrid)
+C
+CCC Description:
+CCC Subroutine to create the grid hierarchy (g) from the one created with the
+CCC Agrif_Read_Fix_Grd or Agrif_Cluster_All procedures (coarsegrid).
+C
+CC Method:
+CC Recursive subroutine.
+C
+C Declarations:
+C
+C Pointer arguments
+ TYPE(AGRIF_grid) , Pointer :: g ! Pointer on the root coarse
+ ! grid
+ TYPE(AGRIF_rectangle), Pointer :: coarsegrid ! Pointer on the root coarse
+ ! grid of the grid hierarchy
+ ! created with the
+ ! Agrif_Read_Fix_Grd
+ ! subroutine
+C
+C Local pointers
+ TYPE(Agrif_grid) , Pointer :: newgrid ! New grid
+ TYPE(Agrif_pgrid) , Pointer :: newpgrid
+ TYPE(Agrif_pgrid) , Pointer :: parcours2
+ TYPE(Agrif_lrectangle), Pointer :: parcours
+ TYPE(Agrif_pgrid) , Pointer :: end_list
+ TYPE(Agrif_pgrid) , Pointer :: parcours3
+C
+C Local scalars
+ LOGICAL :: nullliste
+ INTEGER :: iii
+ INTEGER :: moving_grid_id = 0
+
+C
+ parcours3 => g % child_grids
+C
+ if (associated(parcours3)) then
+ do While (associated(parcours3 % next))
+ parcours3 => parcours3 % next
+ enddo
+ end_list => parcours3
+ nullliste=.FALSE.
+ else
+ allocate(end_list)
+ nullify(end_list % gr)
+ nullify(end_list % next)
+ g % child_grids => end_list
+ parcours3 => end_list
+ nullliste=.TRUE.
+ endif
+C
+ parcours => coarsegrid % childgrids
+C
+C Creation of the grid hierarchy from the one created by using the
+C Agrif_Read_Fix_Grd subroutine
+C
+ do while (associated(parcours))
+ allocate(newgrid)
+ moving_grid_id=moving_grid_id+1
+ newgrid % grid_id = moving_grid_id
+ do iii = 1 , Agrif_Probdim
+ newgrid % spaceref(iii) = parcours % r % spaceref(iii)
+ newgrid % timeref(iii) = parcours % r % timeref(iii)
+ enddo
+C
+ do iii = 1 , Agrif_Probdim
+ newgrid % nb(iii) = (parcours % r % imax(iii)
+ & - parcours % r % imin(iii))
+ & * parcours % r % spaceref(iii)
+C
+ newgrid % ix(iii) = parcours % r % imin(iii)
+C
+ newgrid % Agrif_d(iii) = g % Agrif_d(iii)
+ & / REAL(newgrid % spaceref(iii))
+C
+ newgrid % Agrif_x(iii) = g % Agrif_x(iii) +
+ & (parcours % r % imin(iii) - 1)* g % Agrif_d(iii)
+C
+ enddo
+C
+C Pointer on the parent grid
+C
+ newgrid % parent => g
+
+C Level of the current grid
+ newgrid % level = newgrid % parent % level + 1
+ if (newgrid % level > Agrif_MaxLevelLoc) then
+ Agrif_MaxLevelLoc = newgrid%level
+ endif
+
+C
+C Grid pointed by newgrid is a fixed grid
+C
+ if (parcours % r % number .GT. 0) then
+ newgrid % fixed = .true.
+ else
+ newgrid % fixed = .false.
+ endif
+C
+C Number of the grid pointed by newgrid
+ newgrid % fixedrank = parcours % r % number
+C
+C No time calculation on this grid
+ newgrid % ngridstep = 0
+C
+C Test indicating if the current grid has a common border with the root
+C coarse grid in the x direction
+ do iii = 1 , Agrif_Probdim
+ newgrid % NearRootBorder(iii) = .FALSE.
+C
+ if ((newgrid % parent % NearRootBorder(iii)) .AND.
+ & (newgrid % ix(iii) == 1)) then
+ newgrid % NearRootBorder(iii) = .TRUE.
+ endif
+C
+ newgrid % DistantRootBorder(iii) = .FALSE.
+C
+ if ((newgrid % parent % DistantRootBorder(iii)) .AND.
+ & (newgrid % ix(iii) +
+ & (newgrid % nb(iii)/newgrid % spaceref(iii))
+ & - 1 == newgrid % parent % nb(iii))) then
+ newgrid % DistantRootBorder(iii) = .TRUE.
+ endif
+ enddo
+C
+C Writing in output files
+C
+ newgrid % oldgrid = .FALSE.
+C
+C
+C Definition of the CHARACTERistics of the variable of the grid pointed by
+C newgrid
+ Call Agrif_Create_Var (newgrid)
+C
+C Instanciation of the grid pointed by newgrid and its variables
+ Call Agrif_Instance (newgrid)
+C
+C Nullify the variable of the grid pointed by newgrid
+C
+C
+C Addition of this grid to the grid hierarchy
+C
+ nullify(newgrid % child_grids)
+ allocate(newpgrid)
+ newpgrid % gr => newgrid
+ nullify(newpgrid % next)
+ end_list % next => newpgrid
+ end_list => end_list % next
+ parcours => parcours % next
+C
+C Updating the total number of fixed grids
+ if (newgrid % fixed) then
+ AGRIF_nbfixedgrids = AGRIF_nbfixedgrids + 1
+ endif
+C
+ enddo
+C
+C
+ if (nullliste) then
+ g % child_grids => g % child_grids % next
+ parcours2 => g % child_grids
+ deallocate(parcours3)
+ else
+ parcours2 => parcours3 % next
+ endif
+C
+ parcours => coarsegrid % childgrids
+C
+C Recursive call to the subroutine Agrif_Create_Fixed_Grids to create the
+C grid hierarchy
+C
+ do while (associated(parcours))
+ Call Agrif_Create_Grids (parcours2 % gr,parcours % r)
+ parcours => parcours % next
+ parcours2 => parcours2 % next
+ enddo
+C
+ Return
+C
+ End Subroutine Agrif_Create_Grids
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Init_Hierarchy
+C **************************************************************************
+C
+ Recursive Subroutine Agrif_Init_Hierarchy(g)
+C
+CCC Description:
+CCC Subroutine to initialize all the grids except the root coarse grid (this
+CCC one, pointed by AGRIF_mygrid, is initialized by the subroutine
+CCC Agrif_Init_Grids defi ned in the module Agrif_Util and called in the main
+CCC program ).
+C
+CC Method:
+CC Recursive subroutine.
+C
+C Declarations:
+C
+C Pointer argument
+ TYPE(AGRIF_grid), Pointer :: g ! Pointer on the root coarse grid
+C
+C Local variables
+ TYPE(AGRIF_pgrid), Pointer :: parcours ! Pointer for the recursive call
+ LOGICAL :: Init_Hierarchy
+C
+C
+ parcours=>g%child_grids
+C
+ do while (associated(parcours))
+ Init_Hierarchy = .false.
+ if ( AGRIF_USE_FIXED_GRIDS .EQ. 1 .OR.
+ & AGRIF_USE_ONLY_FIXED_GRIDS .EQ. 1 ) then
+ if ((parcours%gr%fixed)
+ & .AND. (Agrif_mygrid%ngridstep == 0)) then
+ Init_Hierarchy = .true.
+ endif
+ endif
+C
+ if (.NOT. parcours%gr%fixed) Init_Hierarchy = .true.
+ if (parcours % gr % oldgrid) Init_Hierarchy = .false.
+C
+ if (Init_Hierarchy) then
+C
+C Instanciation of the grid pointed by parcours%gr and its variables
+ Call Agrif_Instance (parcours % gr)
+C
+C Allocation of the arrays containing values of the variables of the
+C grid pointed by parcours%gr
+C
+ Call Agrif_Allocation (parcours % gr)
+C
+ Call Agrif_initialisations(parcours % gr)
+C
+ Call Agrif_Instance(parcours % gr)
+C
+ if ( Agrif_USE_ONLY_FIXED_GRIDS .EQ. 0 ) then
+ Call Agrif_Allocate_Restore (parcours % gr)
+ endif
+C
+ if ( Agrif_USE_ONLY_FIXED_GRIDS .EQ. 0 ) then
+C Initialization by copy of the grids created by clustering
+ Call AGRIF_CopyFromold_All (parcours%gr,
+ & Agrif_oldmygrid)
+ endif
+C
+C Initialization by interpolation
+C (this routine is written by the user)
+ Call Agrif_InitValues()
+C
+ if ( Agrif_USE_ONLY_FIXED_GRIDS .EQ. 0 ) then
+ Call Agrif_Free_Restore (parcours % gr)
+ endif
+C
+ endif
+ parcours => parcours % next
+C
+ enddo
+C
+ parcours => g % child_grids
+C
+C Recursive operation to initialize all the grids
+ do while (associated(parcours))
+ Call Agrif_Init_Hierarchy (parcours%gr)
+ parcours => parcours%next
+ enddo
+C
+ End Subroutine Agrif_Init_Hierarchy
+C
+C **************************************************************************
+CCC Subroutine Agrif_Allocate_Restore
+C **************************************************************************
+C
+ Subroutine Agrif_Allocate_Restore(Agrif_Gr)
+C
+C
+C Modules used:
+C
+ TYPE(AGRIF_grid), Pointer :: Agrif_Gr ! Pointer on the root coarse grid
+C
+ INTEGER :: i
+C
+ do i = 1 , Agrif_NbVariables
+ if ( Agrif_Mygrid%tabvars(i)%var % restaure ) then
+ if ( Agrif_Gr%tabvars(i)%var % nbdim .EQ. 1 ) then
+ Allocate( Agrif_Gr%tabvars(i)%var%
+ & Restore1D(lbound(Agrif_Gr%tabvars(i)%var%array1,1)
+ & :ubound(Agrif_Gr%tabvars(i)%var%array1,1)))
+ Agrif_Gr%tabvars(i)%var%Restore1D = 0
+C
+ endif
+ if ( Agrif_Gr%tabvars(i)%var % nbdim .EQ. 2 ) then
+ Allocate( Agrif_Gr%tabvars(i)%var%Restore2D(
+ & lbound(Agrif_Gr%tabvars(i)%var%array2,1):
+ & ubound(Agrif_Gr%tabvars(i)%var%array2,1),
+ & lbound(Agrif_Gr%tabvars(i)%var%array2,2)
+ & :ubound(Agrif_Gr%tabvars(i)%var%array2,2)))
+ Agrif_Gr%tabvars(i)%var%Restore2D = 0
+C
+ endif
+ if ( Agrif_Mygrid%tabvars(i)%var % nbdim .EQ. 3 ) then
+C
+ Allocate( Agrif_Gr%tabvars(i)%var%Restore3D(
+ & lbound(Agrif_Gr%tabvars(i)%var%array3,1):
+ & ubound(Agrif_Gr%tabvars(i)%var%array3,1),
+ & lbound(Agrif_Gr%tabvars(i)%var%array3,2):
+ & ubound(Agrif_Gr%tabvars(i)%var%array3,2),
+ & lbound(Agrif_Gr%tabvars(i)%var%array3,3):
+ & ubound(Agrif_Gr%tabvars(i)%var%array3,3)))
+ Agrif_Gr%tabvars(i)%var%Restore3D = 0
+ endif
+C
+ endif
+ enddo
+C
+ Return
+C
+C
+ End Subroutine Agrif_Allocate_Restore
+C
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Free_Restore
+C **************************************************************************
+C
+ Subroutine Agrif_Free_Restore(Agrif_Gr)
+C
+C
+C Pointer argument
+ TYPE(AGRIF_grid), Pointer :: Agrif_Gr ! Pointer on the root coarse grid
+ INTEGER :: i
+C
+ do i = 1 , Agrif_NbVariables
+ if ( Agrif_Mygrid % tabvars(i) % var % restaure) then
+C
+ if (associated(Agrif_Gr%tabvars(i)%var%Restore1D)) then
+ Deallocate(Agrif_Gr%tabvars(i)%var%Restore1D)
+ endif
+ if (associated(Agrif_Gr%tabvars(i)%var%Restore2D)) then
+ Deallocate(Agrif_Gr%tabvars(i)%var%Restore2D)
+ endif
+ if (associated(Agrif_Gr%tabvars(i)%var%Restore3D)) then
+ Deallocate(Agrif_Gr%tabvars(i)%var%Restore3D)
+ endif
+ if (associated(Agrif_Gr%tabvars(i)%var%Restore4D)) then
+ Deallocate(Agrif_Gr%tabvars(i)%var%Restore4D)
+ endif
+ if (associated(Agrif_Gr%tabvars(i)%var%Restore5D)) then
+ Deallocate(Agrif_Gr%tabvars(i)%var%Restore5D)
+ endif
+ if (associated(Agrif_Gr%tabvars(i)%var%Restore6D)) then
+ Deallocate(Agrif_Gr%tabvars(i)%var%Restore6D)
+ endif
+C
+ endif
+ enddo
+C
+ Return
+C
+C
+ End Subroutine Agrif_Free_Restore
+C
+C
+C
+ End Module Agrif_Clustering
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modcurgridfunctions.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modcurgridfunctions.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modcurgridfunctions.F (revision 8155)
@@ -0,0 +1,990 @@
+!
+! $Id: modcurgridfunctions.F 2715 2011-03-30 15:58:35Z rblod $
+!
+C AGRIF (Adaptive Grid Refinement In Fortran)
+C
+C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
+C Christophe Vouland (Christophe.Vouland@imag.fr)
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.
+C
+C
+C
+CCC Module Agrif_CurgridFunctions
+C
+ Module Agrif_CurgridFunctions
+C
+CCC Description:
+CCC Module to define some procedures concerning the current grid
+C
+C Modules used:
+C
+ Use Agrif_Init
+C
+ IMPLICIT NONE
+C
+C
+ Contains
+C Define procedures contained in this module
+C
+C **************************************************************************
+CCC Function Agrif_Rhot
+C **************************************************************************
+C
+ Function Agrif_Rhot()
+C
+CCC Description:
+CCC Function returning the time refinement factor of the current grid.
+C
+C Declarations:
+C
+
+C
+ REAL :: Agrif_Rhot ! Result
+C
+C Local scalar
+ INTEGER :: res ! Intermediate result
+ INTEGER :: iii
+C
+C
+ res=1
+C
+ do iii = 1 , Agrif_Probdim
+ res = max(res, AGRIF_Curgrid % timeref(iii))
+ enddo
+C
+ Agrif_Rhot = float(res)
+C
+C
+ End function Agrif_rhot
+C
+C
+C
+C
+C **************************************************************************
+CCC Function Agrif_IRhot
+C **************************************************************************
+C
+ Function Agrif_IRhot()
+C
+CCC Description:
+CCC Function returning the time refinement factor of the current grid.
+C
+C Declarations:
+C
+
+C
+ INTEGER :: Agrif_IRhot ! Result
+C
+C Local scalar
+ INTEGER :: res ! Intermediate result
+ INTEGER :: iii
+C
+C
+ res=1
+C
+ do iii = 1 , Agrif_Probdim
+ res = max(res, AGRIF_Curgrid % timeref(iii))
+ enddo
+C
+ Agrif_IRhot = res
+C
+C
+ End function Agrif_IRhot
+C
+C
+C
+C **************************************************************************
+CCC Function Agrif_Parent_Rhot
+C **************************************************************************
+C
+ Function Agrif_Parent_Rhot()
+C
+CCC Description:
+CCC Function returning the time refinement factor of the parent grid of the
+CCC current grid.
+C
+C Declarations:
+C
+
+C
+ REAL :: Agrif_Parent_Rhot ! Result
+C
+C Local scalar
+ INTEGER :: res ! Intermediate result
+ INTEGER :: iii
+C
+C
+ res=1
+C
+ do iii = 1 , Agrif_Probdim
+ res = max(res, AGRIF_Curgrid % parent % timeref(iii))
+ enddo
+C
+ Agrif_Parent_Rhot = float(res)
+C
+C
+ End function Agrif_Parent_Rhot
+C
+C
+C **************************************************************************
+CCC Function Agrif_Parent_IRhot
+C **************************************************************************
+C
+ Function Agrif_Parent_IRhot()
+C
+CCC Description:
+CCC Function returning the time refinement factor of the parent grid of the
+CCC current grid.
+C
+C Declarations:
+C
+
+C
+ INTEGER :: Agrif_Parent_IRhot ! Result
+C
+C Local scalar
+ INTEGER :: res ! Intermediate result
+ INTEGER :: iii
+C
+C
+ res=1
+C
+ do iii = 1 , Agrif_Probdim
+ res = max(res, AGRIF_Curgrid % parent % timeref(iii))
+ enddo
+C
+ Agrif_Parent_IRhot = res
+C
+C
+ End function Agrif_Parent_IRhot
+C
+C
+C **************************************************************************
+CCC Function Agrif_Nbstepint
+C **************************************************************************
+C
+ Function Agrif_Nbstepint()
+C
+CCC Description:
+CCC Function for the calculation of the coefficients used for the time
+CCC interpolation (module Agrif_Boundary).
+C
+C Declarations:
+C
+
+C
+ INTEGER :: Agrif_nbstepint ! result
+C
+C
+ Agrif_nbstepint = mod(AGRIF_CURGRID % ngridstep,
+ & int(AGRIF_rhot()))
+C
+C
+ End function Agrif_Nbstepint
+C
+C
+C
+CC **************************************************************************
+CCC Function Agrif_Parent_Nbstepint
+C **************************************************************************
+C
+ Function Agrif_Parent_Nbstepint()
+C
+CCC Description:
+CCC Function for the calculation of the coefficients used for the time
+CCC interpolation (module Agrif_Boundary).
+C
+C Declarations:
+C
+
+C
+ INTEGER :: Agrif_Parent_Nbstepint ! result
+C
+C
+ Agrif_Parent_Nbstepint = mod(AGRIF_CURGRID % parent % ngridstep,
+ & int(AGRIF_Parent_Rhot()))
+C
+C
+ End function Agrif_Parent_Nbstepint
+C
+C **************************************************************************
+CCC Subroutine Agrif_InterpNearBorderX
+C **************************************************************************
+C
+ Subroutine Agrif_InterpNearBorderX()
+C
+CCC Description:
+CCC Subroutine allowing to interpole (in the x direction) on a near border of
+CCC the current grid if this one has a common border with the root coarse
+CCC grid.
+C
+C Declarations:
+C
+
+C
+C
+ AGRIF_CURGRID % NearRootBorder(1) = .FALSE.
+C
+C
+ End Subroutine Agrif_InterpNearBorderX
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_InterpDistantBorderX
+C **************************************************************************
+C
+ Subroutine Agrif_InterpDistantBorderX()
+C
+CCC Description:
+CCC Subroutine allowing to interpole (in the x direction) on a distant border
+CCC of the current grid if this one has a common border with the root coarse
+CCC grid.
+C
+C Declarations:
+C
+
+C
+C
+ AGRIF_CURGRID % DistantRootBorder(1) = .FALSE.
+C
+C
+ End Subroutine Agrif_InterpDistantBorderX
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_InterpNearBorderY
+C **************************************************************************
+C
+ Subroutine Agrif_InterpNearBorderY()
+C
+CCC Description:
+CCC Subroutine allowing to interpole (in the y direction) on a near border of
+CCC the current grid if this one has a common border with the root coarse
+CCC grid.
+C
+C Declarations:
+C
+
+C
+C
+ AGRIF_CURGRID % NearRootBorder(2) = .FALSE.
+C
+C
+ End Subroutine Agrif_InterpNearBorderY
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_InterpDistantBorderY
+C **************************************************************************
+C
+ Subroutine Agrif_InterpDistantBorderY()
+C
+CCC Description:
+CCC Subroutine allowing to interpole (in the y direction) on a distant border
+CCC of the current grid if this one has a common border with the root coarse
+CCC grid.
+C
+C Declarations:
+C
+
+C
+C
+ AGRIF_CURGRID % DistantRootBorder(2) = .FALSE.
+C
+C
+ End Subroutine Agrif_InterpDistantBorderY
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_InterpNearBorderZ
+C **************************************************************************
+C
+ Subroutine Agrif_InterpNearBorderZ()
+C
+CCC Description:
+CCC Subroutine allowing to interpole (in the z direction) on a near border of
+CCC the current grid if this one has a common border with the root coarse
+CCC grid.
+C
+C Declarations:
+C
+
+C
+C
+ AGRIF_CURGRID % NearRootBorder(3) = .FALSE.
+C
+C
+ End Subroutine Agrif_InterpNearBorderZ
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_InterpDistantBorderZ
+C **************************************************************************
+C
+ Subroutine Agrif_InterpDistantBorderZ()
+C
+CCC Description:
+CCC Subroutine allowing to interpole (in the z direction) on a distant border
+CCC of the current grid if this one has a common border with the root coarse
+CCC grid.
+C
+C Declarations:
+C
+
+C
+C
+ AGRIF_CURGRID % DistantRootBorder(3) = .FALSE.
+C
+C
+ End Subroutine Agrif_InterpDistantBorderZ
+C
+C **************************************************************************
+CCC Function Agrif_Parent_Nb_Step
+C **************************************************************************
+C
+ Function AGRIF_Parent_Nb_Step()
+C
+CCC Description:
+CCC Function returning the number of time steps of the parent grid of the
+CCC current grid.
+C
+C Declarations:
+C
+
+C
+ INTEGER :: AGRIF_Parent_Nb_Step ! Result
+C
+C
+ if (Agrif_Root()) then
+C
+ Agrif_Parent_Nb_Step = -1
+C
+ else
+C
+ Agrif_Parent_Nb_Step = Agrif_Curgrid % parent % ngridstep
+C
+ endif
+C
+C
+ End function Agrif_Parent_Nb_Step
+C
+C
+C
+C **************************************************************************
+CCC Function Agrif_Root
+C **************************************************************************
+C
+ Function Agrif_Root()
+C
+CCC Description:
+CCC Function indicating if the current grid is or not the root grid.
+C
+C Declarations:
+C
+
+C
+ LOGICAL :: Agrif_Root ! Result
+C
+C
+ if (AGRIF_CURGRID % fixedrank .EQ. 0) then
+C
+ Agrif_Root = .TRUE.
+C
+ else
+C
+ Agrif_Root = .FALSE.
+C
+ endif
+C
+C
+ End function Agrif_Root
+C
+C
+C
+C **************************************************************************
+CCC Function Agrif_Parent_Root
+C **************************************************************************
+C
+ Function Agrif_Parent_Root()
+C
+CCC Description:
+CCC Function indicating if the parent grid of the current grid is or not the
+CCC root grid.
+C
+C Declarations:
+C
+
+C
+ LOGICAL :: Agrif_Parent_Root ! Result
+C
+C
+ if (AGRIF_CURGRID % parent % fixedrank .EQ. 0) then
+C
+ Agrif_Parent_Root = .TRUE.
+C
+ else
+C
+ Agrif_Parent_Root = .FALSE.
+C
+ endif
+C
+C
+ End function Agrif_Parent_Root
+C
+C
+C
+C **************************************************************************
+CCC Function Agrif_Fixed
+C **************************************************************************
+C
+ Function Agrif_Fixed()
+C
+CCC Description:
+CCC Function returning the number of the current grid.
+C
+C Declarations:
+C
+
+C
+ INTEGER Agrif_Fixed ! Result
+C
+C
+ if (Agrif_Curgrid % fixed) then
+C
+ Agrif_Fixed = Agrif_Curgrid % fixedrank
+C
+ else
+C
+ Agrif_Fixed = -1
+C
+ endif
+C
+C
+ End function Agrif_Fixed
+C
+C
+C
+C **************************************************************************
+CCC Function Agrif_Parent_Fixed
+C **************************************************************************
+
+ Function Agrif_Parent_Fixed()
+C
+CCC Description:
+CCC Function returning the number of the parent grid of the current grid.
+C
+C Declarations:
+C
+
+C
+ INTEGER Agrif_Parent_Fixed ! Result
+C
+C
+ if (Agrif_Curgrid % parent % fixed) then
+C
+ Agrif_Parent_Fixed = AGRIF_CURGRID % parent % fixedrank
+C
+ else
+C
+ Agrif_Parent_Fixed = 0
+C
+ endif
+C
+C
+ End function Agrif_Parent_Fixed
+C
+C
+C
+C **************************************************************************
+CCC Function Agrif_Is_Fixed
+C **************************************************************************
+
+ Function Agrif_Is_Fixed()
+C
+CCC Description:
+CCC Function returning true if the current grid is fixed.
+C
+C Declarations:
+C
+
+C
+ LOGICAL Agrif_Is_Fixed ! Result
+C
+C
+ if (Agrif_Curgrid % fixed) then
+C
+ Agrif_Is_Fixed = .true.
+C
+ else
+C
+ Agrif_Is_Fixed = .false.
+C
+ endif
+C
+C
+ End function Agrif_Is_Fixed
+C
+C
+C
+C **************************************************************************
+CCC Function Agrif_Parent_Is_Fixed
+C **************************************************************************
+
+ Function Agrif_Parent_Is_Fixed()
+C
+CCC Description:
+CCC Function returning true if the parent grid of the current grid is fixed.
+C
+C Declarations:
+C
+
+C
+ LOGICAL Agrif_Parent_Is_Fixed ! Result
+C
+C
+ if (Agrif_Curgrid % parent % fixed) then
+C
+ Agrif_Parent_Is_Fixed = .true.
+C
+ else
+C
+ Agrif_Parent_Is_Fixed = .false.
+C
+ endif
+C
+C
+ End function Agrif_Parent_Is_Fixed
+C
+C
+C
+C **************************************************************************
+CCC Function AGRIF_CFixed
+C **************************************************************************
+
+ Function AGRIF_CFixed()
+C
+CCC Description:
+CCC Function returning the number of the current grid.
+C
+C Declarations:
+C
+
+C
+ CHARACTER(3) AGRIF_CFixed ! Result
+C
+C Local variables
+ CHARACTER(3) cfixed
+ INTEGER fixed
+C
+C
+ fixed = Agrif_Fixed()
+C
+ if(fixed.NE.-1) then
+C
+ if (fixed .LE. 9) then
+C
+ write(cfixed,'(i1)')fixed
+C
+ else
+C
+ write(cfixed,'(i2)')fixed
+C
+ endif
+C
+ AGrif_Cfixed=cfixed
+C
+ else
+C
+ print*,'Call to AGRIF_CFixed() on a moving grid'
+ stop
+C
+ endif
+
+ End function AGRIF_CFixed
+C
+C
+C
+C **************************************************************************
+CCC Function AGRIF_Parent_CFixed
+C **************************************************************************
+
+ Function AGRIF_Parent_CFixed()
+C
+CCC Description:
+CCC Function returning the number of the parent grid of the current grid.
+C
+C Declarations:
+C
+
+C
+ CHARACTER(3) AGRIF_Parent_CFixed ! Result
+C
+C Local variables
+ CHARACTER(3) cfixed
+ INTEGER fixed
+C
+C
+ fixed = Agrif_Parent_Fixed()
+C
+ if(fixed.NE.-1) then
+C
+ if (fixed .LE. 9) then
+C
+ write(cfixed,'(i1)')fixed
+C
+ else
+C
+ write(cfixed,'(i2)')fixed
+C
+ endif
+C
+ AGrif_Parent_Cfixed=cfixed
+C
+ else
+C
+ print*,'Illegal call to AGRIF_Parent_CFixed()'
+ stop
+C
+ endif
+
+ End function AGRIF_Parent_CFixed
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_ChildGrid_to_ParentGrid
+C **************************************************************************
+C
+ Subroutine Agrif_ChildGrid_to_ParentGrid()
+C
+CCC Description:
+CCC Subroutine allowing to make the pointer AGRIF_CURGRID point on the parent
+CCC grid of the current grid.
+C
+C Declarations:
+C
+
+C
+
+ Agrif_Curgrid%Parent%save_grid => Agrif_Curgrid
+C
+ Call Agrif_Instance(Agrif_Curgrid%parent)
+C
+C
+ End Subroutine Agrif_ChildGrid_to_ParentGrid
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_ParentGrid_to_ChildGrid
+C **************************************************************************
+C
+ Subroutine Agrif_ParentGrid_to_ChildGrid()
+C
+CCC Description:
+CCC Subroutine allowing to make the pointer AGRIF_CURGRID point on the child
+CCC grid after having called the Agrif_ChildGrid_to_ParentGrid subroutine.
+C
+C Declarations:
+C
+
+C
+C
+ Call Agrif_Instance(Agrif_Curgrid%save_grid)
+C
+C
+ End Subroutine Agrif_ParentGrid_to_ChildGrid
+C
+C
+C
+C **************************************************************************
+CCC Function Agrif_Get_Unit
+C **************************************************************************
+C
+ Function Agrif_Get_Unit()
+
+CCC Description : return a unit not connected to any file
+C
+C Declarations
+C
+
+C
+ INTEGER Agrif_Get_Unit
+C
+C Local scalars
+ INTEGER n
+ LOGICAL op
+C
+ INTEGER :: nunit
+ INTEGER :: iii,out,iiimax
+ Logical :: BEXIST
+ INTEGER,DIMENSION(1:1000) :: ForbiddenUnit
+C
+C
+C Load forbidden Unit if the file Agrif_forbidenUnit exist
+C
+
+ INQUIRE(FILE='Agrif_forbiddenUnit.txt',EXIST=BEXIST)
+ If (.not. BEXIST) Then
+c File Agrif_forbiddenUnit.txt not found
+ Else
+ nunit = 777
+ open(nunit,file='Agrif_forbiddenUnit.txt',form='formatted',
+ & status="old")
+ iii = 1
+ do while ( .TRUE. )
+ read(nunit,*,END = 99) ForbiddenUnit(iii)
+ iii = iii + 1
+ enddo
+ 99 CONTINUE
+ iiimax = iii
+ close(nunit)
+ endif
+C
+ do n = 7,1000
+C
+ Inquire(Unit=n,Opened=op)
+C
+ out = 0
+ if ( BEXIST .AND. .NOT.op) then
+ do iii = 1 , iiimax
+ if ( n .EQ. ForbiddenUnit(iii) ) out = 1
+ enddo
+ endif
+C
+ if (.NOT.op .AND. out .EQ. 0) exit
+C
+ enddo
+C
+ Agrif_Get_Unit=n
+C
+C
+ End Function Agrif_Get_Unit
+
+ Subroutine Agrif_Set_Efficiency(eff)
+ REAL :: eff
+
+ IF ((eff.LT.0.).OR.(eff.GT.1)) THEN
+ write(*,*)'Error Efficiency should be between 0 and 1'
+ stop
+ ELSE
+ Agrif_efficiency = eff
+ ENDIF
+ End Subroutine Agrif_Set_Efficiency
+
+ Subroutine Agrif_Set_Regridding(regfreq)
+ INTEGER :: regfreq
+
+ IF (regfreq.LT.0) THEN
+ write(*,*)'Regridding frequency should be positive'
+ stop
+ ELSE
+ Agrif_regridding = regfreq
+ ENDIF
+ End Subroutine Agrif_Set_Regridding
+C
+C
+C **************************************************************************
+CCC subroutine Agrif_Set_coeffref_x
+C **************************************************************************
+ subroutine Agrif_Set_coeffref_x(coefref)
+
+ integer :: coefref
+
+ if (coefref.LT.0) then
+ write(*,*)'Coefficient of raffinement should be positive'
+ stop
+ else
+ AGRIF_coeffref(1) = coefref
+ endif
+ end subroutine Agrif_Set_coeffref_x
+C
+C **************************************************************************
+CCC subroutine Agrif_Set_coeffref_y
+C **************************************************************************
+ subroutine Agrif_Set_coeffref_y(coefref)
+
+ integer :: coefref
+
+ if (coefref.LT.0) then
+ write(*,*)'Coefficient of raffinement should be positive'
+ stop
+ else
+ AGRIF_coeffref(2) = coefref
+ endif
+ end subroutine Agrif_Set_coeffref_y
+C
+C **************************************************************************
+CCC subroutine Agrif_Set_coeffref_z
+C **************************************************************************
+ subroutine Agrif_Set_coeffref_z(coefref)
+
+ integer :: coefref
+
+ if (coefref.LT.0) then
+ write(*,*)'Coefficient of raffinement should be positive'
+ stop
+ else
+ AGRIF_coeffref(3) = coefref
+ endif
+ end subroutine Agrif_Set_coeffref_z
+C
+C **************************************************************************
+CCC subroutine Agrif_Set_coeffreft_x
+C **************************************************************************
+ subroutine Agrif_Set_coeffreft_x(coefref)
+
+ integer :: coefref
+
+ if (coefref.LT.0) then
+ write(*,*)'Coefficient of time raffinement should be positive'
+ stop
+ else
+ AGRIF_coeffreft(1) = coefref
+ endif
+ end subroutine Agrif_Set_coeffreft_x
+C
+C **************************************************************************
+CCC subroutine Agrif_Set_coeffreft_y
+C **************************************************************************
+ subroutine Agrif_Set_coeffreft_y(coefref)
+
+ integer :: coefref
+
+ if (coefref.LT.0) then
+ write(*,*)'Coefficient of time raffinement should be positive'
+ stop
+ else
+ AGRIF_coeffreft(2) = coefref
+ endif
+ end subroutine Agrif_Set_coeffreft_y
+C
+C **************************************************************************
+CCC subroutine Agrif_Set_coeffreft_z
+C **************************************************************************
+ subroutine Agrif_Set_coeffreft_z(coefref)
+
+ integer :: coefref
+
+ if (coefref.LT.0) then
+ write(*,*)'Coefficient of time raffinement should be positive'
+ stop
+ else
+ AGRIF_coeffreft(3) = coefref
+ endif
+ end subroutine Agrif_Set_coeffreft_z
+C
+C **************************************************************************
+CCC subroutine Agrif_Set_Minwidth
+C **************************************************************************
+ subroutine Agrif_Set_Minwidth(coefminwidth)
+
+ integer :: coefminwidth
+
+ if (coefminwidth.LT.0) then
+ write(*,*)'Coefficient of Minwidth should be positive'
+ stop
+ else
+ Agrif_Minwidth = coefminwidth
+ endif
+ end subroutine Agrif_Set_Minwidth
+C
+C **************************************************************************
+CCC subroutine Agrif_Set_Rafmax
+C **************************************************************************
+ subroutine Agrif_Set_Rafmax(coefrafmax)
+
+ integer :: coefrafmax
+ integer :: i
+ real :: res
+
+ if (coefrafmax.LT.0) then
+ write(*,*)'Coefficient of should be positive'
+ stop
+ else
+ res = 1.
+ do i = 1 , coefrafmax - 1
+ res = res * FLOAT(AGRIF_coeffref(1))
+ enddo
+ if ( res .EQ. 0 ) res = 1
+ Agrif_Mind(1) = 1. / res
+C
+ res = 1.
+ do i = 1 , coefrafmax - 1
+ res = res * FLOAT(AGRIF_coeffref(2))
+ enddo
+ if ( res .EQ. 0 ) res = 1
+ Agrif_Mind(2) = 1. / res
+C
+ res = 1.
+ do i = 1 , coefrafmax - 1
+ res = res * FLOAT(AGRIF_coeffref(3))
+ enddo
+ if ( res .EQ. 0 ) res = 1
+ Agrif_Mind(3) = 1. / res
+C
+ endif
+ end subroutine Agrif_Set_Rafmax
+C
+C **************************************************************************
+CCC subroutine Agrif_Open_File
+C **************************************************************************
+ subroutine Agrif_Open_File(num_id,name_file)
+
+ integer :: num_id
+ character(*) :: name_file
+
+ num_id = Agrif_Get_Unit()
+ if ( .NOT. Agrif_Root() ) then
+ name_file = TRIM(Agrif_CFixed())//'_'//TRIM(name_file)
+ endif
+
+ end subroutine Agrif_Open_File
+
+C **************************************************************************
+CCC subroutine Agrif_Set_MaskMaxSearch
+C **************************************************************************
+ subroutine Agrif_Set_MaskMaxSearch(mymaxsearch)
+ integer mymaxsearch
+ MaxSearch = mymaxsearch
+ end subroutine Agrif_Set_MaskMaxSearch
+
+C *****************************************************************
+CCC subroutine Agrif_Level
+C *****************************************************************
+ Function Agrif_Level()
+ Integer :: Agrif_Level
+
+ Agrif_Level = Agrif_Curgrid % level
+
+ End Function Agrif_Level
+
+C *****************************************************************
+CCC subroutine Agrif_MaxLevel
+C *****************************************************************
+ Function Agrif_MaxLevel()
+ Integer :: Agrif_MaxLevel
+
+ Agrif_MaxLevel = Agrif_MaxLevelLoc
+
+ End Function Agrif_MaxLevel
+
+ End Module Agrif_CurgridFunctions
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modflux.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modflux.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modflux.F (revision 8155)
@@ -0,0 +1,339 @@
+C Agrif (Adaptive Grid Refinement In Fortran)
+C
+C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
+C Christophe Vouland (Christophe.Vouland@imag.fr)
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 59 Temple Place-Suite 330, Boston, MA 02111-1307, USA.
+C
+C
+C
+CCC Module Agrif_fluxmod
+C
+ Module Agrif_fluxmod
+ Use Agrif_types
+ Use Agrif_Arrays
+ Use Agrif_Curgridfunctions
+
+ CONTAINS
+
+
+ Subroutine Agrif_AllocateFlux(Flux,fluxtab)
+ Type(Agrif_Flux), Pointer :: Flux
+ Real, Dimension(:,:) :: fluxtab
+ Type(Agrif_Profile), Pointer :: Profile
+ Integer :: dimensio,n,n2
+ INTEGER, DIMENSION(:,:), Pointer :: normalsizes
+ INTEGER, DIMENSION(6) :: unitarray
+ Type(Agrif_Variable), Pointer :: fluxtabvar
+ Integer :: nbout
+
+ Profile => Flux%profile
+ dimensio = Profile%nbdim
+
+ unitarray = 1
+
+ do n=1,dimensio
+ IF (Profile%posvar(n) == 1) THEN
+ IF (Profile%interptab(n) == 'x') THEN
+ Allocate(Flux%fluxtabx)
+ fluxtabvar => Flux%fluxtabx
+ ELSE IF (Profile%interptab(n) == 'y') THEN
+ Allocate(Flux%fluxtaby)
+ fluxtabvar => Flux%fluxtaby
+ ELSE IF (Profile%interptab(n) == 'z') THEN
+ Allocate(Flux%fluxtabz)
+ fluxtabvar => Flux%fluxtabz
+ ENDIF
+ ALLOCATE(fluxtabvar%iarray2(2,6))
+ normalsizes=>fluxtabvar%iarray2
+ normalsizes(1,1) = 2
+ nbout = 1
+ DO n2 = 1,dimensio
+ IF (n2 .NE. n) THEN
+ nbout = nbout + 1
+ If ((Profile%posvar(n2) == 1)
+ & .OR.(Profile%posvar(n2) == 2)) THEN
+ IF (Profile%interptab(n2) == 'x') THEN
+ normalsizes(2,n2) =
+ & Agrif_Curgrid%nb(1)/agrif_Curgrid%spaceref(1)
+ normalsizes(1,nbout) =
+ & Agrif_Curgrid%nb(1)/agrif_Curgrid%spaceref(1)
+ ELSE IF (Profile%interptab(n2) == 'y') THEN
+ normalsizes(2,n2) =
+ & Agrif_Curgrid%nb(2)/agrif_Curgrid%spaceref(2)
+ normalsizes(1,nbout) =
+ & Agrif_Curgrid%nb(2)/agrif_Curgrid%spaceref(2)
+ ELSE IF (Profile%interptab(n2) == 'z') THEN
+ normalsizes(2,n2) =
+ & Agrif_Curgrid%nb(3)/agrif_Curgrid%spaceref(3)
+ normalsizes(1,nbout) =
+ & Agrif_Curgrid%nb(3)/agrif_Curgrid%spaceref(3)
+ ENDIF
+ ELSE
+ normalsizes(2,n2) = SIZE(fluxtab,n2)
+ normalsizes(1,nbout) = SIZE(fluxtab,n2)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+ enddo
+
+
+ do n=1,dimensio
+ IF (Profile%posvar(n) == 1) THEN
+ IF (Profile%interptab(n) == 'x') THEN
+ fluxtabvar => Flux%fluxtabx
+ ELSE IF (Profile%interptab(n) == 'y') THEN
+ fluxtabvar => Flux%fluxtaby
+ ELSE IF (Profile%interptab(n) == 'z') THEN
+ fluxtabvar => Flux%fluxtabz
+ ENDIF
+ Call Agrif_nbdim_allocation(fluxtabvar,unitarray(1:dimensio),
+ & fluxtabvar%iarray2(1,1:dimensio),dimensio)
+ ENDIF
+ enddo
+
+ Flux%fluxallocated = .TRUE.
+
+ End Subroutine Agrif_AllocateFlux
+
+ FUNCTION Agrif_Search_Flux(fluxname)
+ character*(*) fluxname
+ Type(Agrif_Flux), Pointer :: Agrif_Search_Flux
+
+ Type(Agrif_Flux), pointer :: parcours
+ Logical :: foundflux
+
+ foundflux = .FALSE.
+ parcours => Agrif_Curgrid%fluxes
+
+ Do While (Associated(parcours))
+ IF (parcours % fluxname == fluxname) THEN
+ foundflux = .TRUE.
+ EXIT
+ ENDIF
+ parcours => parcours%nextflux
+ End Do
+
+ IF (.NOT.foundflux) THEN
+ write(*,*) 'The array flux '''
+ & //TRIM(fluxname)//''' has not been declared'
+ stop
+ ENDIF
+
+ Agrif_Search_Flux => parcours
+
+ End Function Agrif_Search_Flux
+
+ Subroutine Agrif_Save_Fluxtab(Flux,Fluxtab)
+ Type(Agrif_Flux), Pointer :: Flux
+ Real, Dimension(:,:) :: Fluxtab
+ INTEGER, DIMENSION(:,:), Pointer :: normalsizes
+ INTEGER, DIMENSION(6) :: normalsizes2, normalsizes3
+ INTEGER, DIMENSION(6) :: unitarray2, unitarray3
+ Type(Agrif_Variable), Pointer :: fluxtabvar
+ Type(Agrif_Profile), Pointer :: Profile
+ Integer :: dimensio,n,n2,j,j1,j2
+
+ Profile => Flux%profile
+ dimensio = Profile%nbdim
+
+ do n=1,dimensio
+ IF (Profile%posvar(n) == 1) THEN
+ IF (Profile%interptab(n) == 'x') THEN
+ fluxtabvar => Flux%fluxtabx
+ ELSE IF (Profile%interptab(n) == 'y') THEN
+ fluxtabvar => Flux%fluxtaby
+ ELSE IF (Profile%interptab(n) == 'z') THEN
+ fluxtabvar => Flux%fluxtabz
+ ENDIF
+ normalsizes => fluxtabvar%iarray2
+ unitarray2 = 1
+ unitarray3 = 1
+ normalsizes2 = normalsizes(1,:)
+ normalsizes3 = normalsizes(2,:)
+
+ unitarray3(n) = Profile%point(n)
+ normalsizes3(n) = Profile%point(n)
+
+ SELECT CASE(dimensio)
+ CASE(1)
+ CASE(2)
+ j1 = unitarray3(2)
+ Do j=unitarray3(2),normalsizes3(2)
+ do j2 = j1,j1+Agrif_curgrid%spaceref(2)
+! print *,'flux stocke fiun = ',j2,fluxtab(unitarray3(1),j2)
+ enddo
+ fluxtabvar%array2(1:1,j) =
+ & fluxtabvar%array2(1:1,j) +
+ & SUM(fluxtab(unitarray3(1):normalsizes3(1),
+ & j1:j1+Agrif_Curgrid%spaceref(2)))
+ j1 = j1+Agrif_Curgrid%spaceref(2)
+ EndDo
+ END SELECT
+
+ unitarray3(n) = Profile%point(n)+Agrif_Curgrid%nb(n)
+ normalsizes3(n) = Profile%point(n)+Agrif_Curgrid%nb(n)
+ SELECT CASE(dimensio)
+ CASE(1)
+ CASE(2)
+ j1 = unitarray3(2)
+ Do j=unitarray3(2),normalsizes3(2)
+ fluxtabvar%array2(2:2,j) =
+ & fluxtabvar%array2(2:2,j) +
+ & SUM(fluxtab(unitarray3(1):normalsizes3(1),
+ & j1:j1+Agrif_Curgrid%spaceref(2)))
+ j1 = j1+Agrif_Curgrid%spaceref(2)
+ EndDo
+ END SELECT
+ ENDIF
+ enddo
+
+ End Subroutine Agrif_Save_Fluxtab
+
+ Subroutine Agrif_Save_Fluxtab_child(Flux,Fluxtab)
+ Type(Agrif_Flux), Pointer :: Flux
+ Real, Dimension(:,:) :: Fluxtab
+ INTEGER, DIMENSION(:,:), Pointer :: normalsizes
+ INTEGER, DIMENSION(6) :: normalsizes2, normalsizes3
+ INTEGER, DIMENSION(6) :: unitarray2, unitarray3
+ Type(Agrif_Variable), Pointer :: fluxtabvar
+ Type(Agrif_Profile), Pointer :: Profile
+ Integer :: dimensio,n,n2
+
+ Profile => Flux%profile
+ dimensio = Profile%nbdim
+
+ do n=1,dimensio
+ IF (Profile%posvar(n) == 1) THEN
+ IF (Profile%interptab(n) == 'x') THEN
+ fluxtabvar => Flux%fluxtabx
+ ELSE IF (Profile%interptab(n) == 'y') THEN
+ fluxtabvar => Flux%fluxtaby
+ ELSE IF (Profile%interptab(n) == 'z') THEN
+ fluxtabvar => Flux%fluxtabz
+ ENDIF
+ normalsizes => fluxtabvar%iarray2
+ unitarray2 = 1
+ unitarray3 = 1
+ normalsizes2 = normalsizes(1,:)
+ normalsizes3 = normalsizes(2,:)
+
+ unitarray3(n) = Profile%point(n)+Agrif_Curgrid%ix(n)
+ normalsizes3(n) = unitarray3(n)
+
+ SELECT CASE(dimensio)
+ CASE(1)
+ CASE(2)
+ fluxtabvar%array2(1:1,
+ & unitarray2(2):normalsizes2(2)) =
+ & - fluxtab(unitarray3(1):normalsizes3(1),
+ & unitarray3(2):normalsizes3(2))
+! print *,'flux stocke = ',fluxtab(unitarray3(1):normalsizes3(1),
+! & unitarray3(2):normalsizes3(2))
+ END SELECT
+
+ unitarray3(n) = unitarray3(n)+
+ & Agrif_Curgrid%nb(n)/Agrif_Curgrid%spaceref(n)
+ normalsizes3(n) = unitarray3(n)
+ SELECT CASE(dimensio)
+ CASE(1)
+ CASE(2)
+ fluxtabvar%array2(2:2,
+ & unitarray2(2):normalsizes2(2)) =
+ & - fluxtab(unitarray3(1):normalsizes3(1),
+ & unitarray3(2):normalsizes3(2))
+ END SELECT
+ ENDIF
+ enddo
+
+ End Subroutine Agrif_Save_Fluxtab_child
+
+ Subroutine Agrif_Cancel_Fluxarray(Flux)
+ Type(Agrif_Flux), Pointer :: Flux
+ Type(Agrif_Variable), Pointer :: fluxtabvar
+ Type(Agrif_Profile), Pointer :: Profile
+ Integer :: dimensio,n,n2
+
+ Profile => Flux%profile
+ dimensio = Profile%nbdim
+
+ do n=1,dimensio
+ IF (Profile%posvar(n) == 1) THEN
+ IF (Profile%interptab(n) == 'x') THEN
+ fluxtabvar => Flux%fluxtabx
+ ELSE IF (Profile%interptab(n) == 'y') THEN
+ fluxtabvar => Flux%fluxtaby
+ ELSE IF (Profile%interptab(n) == 'z') THEN
+ fluxtabvar => Flux%fluxtabz
+ ENDIF
+
+ SELECT CASE(dimensio)
+ CASE(1)
+ CASE(2)
+ fluxtabvar%array2 = 0.
+ END SELECT
+ ENDIF
+ enddo
+
+ End Subroutine Agrif_Cancel_Fluxarray
+
+ Subroutine Agrif_FluxCorrect(Flux, procname)
+ Type(Agrif_Flux), Pointer :: Flux
+ External :: procname
+ Type(Agrif_Variable), Pointer :: fluxtabvar
+ Type(Agrif_Profile), Pointer :: Profile
+ Integer :: dimensio,n,n2,j1,j2
+ Integer, Dimension(:), Allocatable :: Loctab
+ Integer :: locind
+
+ Profile => Flux%profile
+ dimensio = Profile%nbdim
+
+ do n=1,dimensio
+ IF (Profile%posvar(n) == 1) THEN
+ IF (Profile%interptab(n) == 'x') THEN
+ fluxtabvar => Flux%fluxtabx
+ locind = 1
+ ELSE IF (Profile%interptab(n) == 'y') THEN
+ fluxtabvar => Flux%fluxtaby
+ locind = 2
+ ELSE IF (Profile%interptab(n) == 'z') THEN
+ fluxtabvar => Flux%fluxtabz
+ locind = 3
+ ENDIF
+
+ SELECT CASE(dimensio)
+ CASE(1)
+ CASE(2)
+ Allocate(Loctab(2))
+ Loctab(1) = Agrif_Curgrid%ix(locind)
+ Loctab(2) = Agrif_Curgrid%ix(locind)+
+ & Agrif_Curgrid%nb(locind)/Agrif_Curgrid%spaceref(locind)
+ j1 = agrif_curgrid%ix(2)
+ j2 = agrif_curgrid%ix(2)+
+ & agrif_curgrid%nb(2)/Agrif_curgrid%spaceref(2)
+ Call Agrif_ChildGrid_to_ParentGrid()
+ Call procname(fluxtabvar%array2,Loctab(1),Loctab(2),j1,j2)
+ Call Agrif_ParentGrid_to_ChildGrid()
+ END SELECT
+ ENDIF
+ enddo
+
+ If (Allocated(Loctab)) Deallocate(Loctab)
+
+ End Subroutine Agrif_FluxCorrect
+
+ End Module Agrif_fluxmod
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modinit.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modinit.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modinit.F (revision 8155)
@@ -0,0 +1,252 @@
+C AGRIF (Adaptive Grid Refinement In Fortran)
+C
+C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
+C Christophe Vouland (Christophe.Vouland@imag.fr)
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.
+C
+C
+C
+CCC Module Agrif_Init
+C
+ Module Agrif_Init
+C
+CCC Description:
+CCC Several operations on the variables of the current grid (creation,
+CCC instanciation, ...) used during the creation of the grid hierarchy and
+CCC during the time integration.
+C
+C Modules used:
+C
+ Use Agrif_Types
+ Use Agrif_link
+C
+ IMPLICIT NONE
+C
+ Contains
+C Defininition of the procedures contained in this module
+C
+C **************************************************************************
+CCC Subroutine Agrif_Allocation
+C **************************************************************************
+C
+ Subroutine Agrif_Allocation(Agrif_Gr)
+C
+CCC Description:
+CCC Subroutine to allocate the arrays containing the values of the variables
+CCC of the current grd.
+C
+CC Method:
+CC Use of the allocate function.
+C
+C Declarations:
+C
+C Pointer argument:
+ TYPE(AGRIF_grid), Pointer :: Agrif_Gr ! Pointer on the current grid
+C
+C Allocation of the arrays of the variables
+C We cut this in several files to avoid long compilation timings
+C
+ Call Agrif_Allocationcalls(Agrif_Gr)
+C
+ if ( Agrif_USE_ONLY_FIXED_GRIDS .EQ. 0 ) then
+C
+ if ( Agrif_Probdim .EQ. 1 )
+ & Allocate(Agrif_Gr%tabpoint1D(Agrif_Gr%nb(1)+1))
+ if ( Agrif_Probdim .EQ. 2 )
+ & Allocate(Agrif_Gr%tabpoint2D(Agrif_Gr%nb(1)+1,
+ & Agrif_Gr%nb(2)+1))
+ if ( Agrif_Probdim .EQ. 3 )
+ & Allocate(Agrif_Gr%tabpoint3D(Agrif_Gr%nb(1)+1,
+ & Agrif_Gr%nb(2)+1,Agrif_Gr%nb(3)+1))
+C
+ endif
+C
+ End Subroutine Agrif_Allocation
+C
+C **************************************************************************
+CCC Subroutine Agrif_Instance
+C **************************************************************************
+C
+ Subroutine Agrif_Instance(Agrif_Gr)
+C
+CCC Description:
+CCC Subroutine to do an instance of the common variables to the variables of
+CCC the current grid.
+C
+CC Method:
+CC Pointing the common variables on these of the current grid.
+C
+C Declarations:
+C
+
+C
+C
+
+C
+C Pointer argument:
+ Type(Agrif_Grid), Pointer :: Agrif_Gr ! Pointer on the current grid
+C
+C
+ Agrif_Curgrid => Agrif_Gr
+ Agrif_tabvars => Agrif_Curgrid % tabvars
+C
+ Call Agrif_Get_numberofcells(Agrif_Gr)
+C
+C
+C Calculation of isf,jsf,nzsf and of the index of the output file
+ Call Agrif_InitWorkSpace()
+C
+C
+ End Subroutine Agrif_Instance
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_initialisations
+C **************************************************************************
+ Subroutine Agrif_initialisations(Agrif_Gr)
+C
+CCC Description:
+C
+CC Method:
+C
+C Declarations:
+C
+ INTEGER :: i
+C
+C Pointer argument:
+ Type(Agrif_Grid), Pointer :: Agrif_Gr
+
+C
+ do i = 1 , Agrif_NbVariables
+C
+ Agrif_Gr % tabvars(i) % var % nbdim = 0
+C
+ if (allocated(Agrif_Gr%tabvars(i)%var%array1)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 1
+ Agrif_Gr % tabvars(i) % var % lb(1:1) =
+ & lbound(Agrif_Gr%tabvars(i)%var%array1)
+ Agrif_Gr % tabvars(i) % var % ub(1:1) =
+ & ubound(Agrif_Gr%tabvars(i)%var%array1)
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%array2)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 2
+ Agrif_Gr % tabvars(i) % var % lb(1:2) =
+ & lbound(Agrif_Gr%tabvars(i)%var%array2)
+ Agrif_Gr % tabvars(i) % var % ub(1:2) =
+ & ubound(Agrif_Gr%tabvars(i)%var%array2)
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%array3)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 3
+ Agrif_Gr % tabvars(i) % var % lb(1:3) =
+ & lbound(Agrif_Gr%tabvars(i)%var%array3)
+ Agrif_Gr % tabvars(i) % var % ub(1:3) =
+ & ubound(Agrif_Gr%tabvars(i)%var%array3)
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%array4)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 4
+ Agrif_Gr % tabvars(i) % var % lb(1:4) =
+ & lbound(Agrif_Gr%tabvars(i)%var%array4)
+ Agrif_Gr % tabvars(i) % var % ub(1:4) =
+ & ubound(Agrif_Gr%tabvars(i)%var%array4)
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%array5)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 5
+ Agrif_Gr % tabvars(i) % var % lb(1:5) =
+ & lbound(Agrif_Gr%tabvars(i)%var%array5)
+ Agrif_Gr % tabvars(i) % var % ub(1:5) =
+ & ubound(Agrif_Gr%tabvars(i)%var%array5)
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%array6)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 6
+ Agrif_Gr % tabvars(i) % var % lb(1:6) =
+ & lbound(Agrif_Gr%tabvars(i)%var%array6)
+ Agrif_Gr % tabvars(i) % var % ub(1:6) =
+ & ubound(Agrif_Gr%tabvars(i)%var%array6)
+ endif
+C
+ if (allocated(Agrif_Gr%tabvars(i)%var%darray1)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 1
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%darray2)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 2
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%darray3)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 3
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%darray4)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 4
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%darray5)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 5
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%darray6)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 6
+ endif
+C
+ if (allocated(Agrif_Gr%tabvars(i)%var%larray1)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 1
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%larray2)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 2
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%larray3)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 3
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%larray4)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 4
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%larray5)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 5
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%larray6)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 6
+ endif
+C
+ if (allocated(Agrif_Gr%tabvars(i)%var%iarray1)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 1
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%iarray2)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 2
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%iarray3)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 3
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%iarray4)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 4
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%iarray5)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 5
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%iarray6)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 6
+ endif
+C
+ if (allocated(Agrif_Gr%tabvars(i)%var%carray1)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 1
+ endif
+ if (allocated(Agrif_Gr%tabvars(i)%var%carray2)) then
+ Agrif_Gr % tabvars(i) % var % nbdim = 2
+ endif
+C
+ enddo
+C
+ Return
+C
+C
+ End Subroutine Agrif_initialisations
+C
+C
+ End Module AGRIF_Init
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modinitvars.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modinitvars.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modinitvars.F (revision 8155)
@@ -0,0 +1,125 @@
+!
+! $Id: modinitvars.F 2528 2010-12-27 17:33:53Z rblod $
+!
+C Agrif (Adaptive Grid Refinement In Fortran)
+C
+C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
+C Christophe Vouland (Christophe.Vouland@imag.fr)
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+C
+C
+C
+CCC Module Agrif_Init_Vars
+C
+ Module Agrif_Init_Vars
+C
+CCC Description:
+CCC Initialization of the variables of the current grid.
+C
+C Modules used:
+C
+ Use Agrif_Types
+ Use Agrif_link
+C
+ IMPLICIT NONE
+C
+ Contains
+C Defininition of the procedures contained in this module
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Create_var
+C **************************************************************************
+C
+ Subroutine Agrif_Create_Var(Agrif_Gr)
+C
+CCC Description:
+CCC Allocation of the field "var" of the grid variables.
+CCC Fields "root_var", "nbdim" and "parent_var" of the grid variables.
+CCC Array "tabvars" of the current grid.
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+C Pointer argument:
+ TYPE(Agrif_Grid),pointer :: Agrif_Gr ! Pointer on the current grid
+ INTEGER :: nb
+C
+C Array "tabvars" of the current grid.
+C
+ Allocate(Agrif_Gr % tabvars(Agrif_NbVariables))
+C
+ do nb = 1, Agrif_NbVariables
+ Allocate(Agrif_Gr % tabvars(nb) % var)
+ enddo
+
+C Fields "root_var", "nbdim" and "parent_var" of the grid variables.
+ if (Agrif_Gr % fixedrank .NE.0) then
+ do nb = 1, Agrif_NbVariables
+ Agrif_Gr % tabvars(nb) % parent_var =>
+ & Agrif_Gr % parent %tabvars(nb)
+ Agrif_Gr % tabvars(nb) % var % nbdim =
+ & Agrif_Mygrid % tabvars(nb) % var % nbdim
+ Agrif_Gr % tabvars(nb) % var % root_var =>
+ & Agrif_Mygrid % tabvars(nb) % var
+ enddo
+ endif
+C
+ End Subroutine Agrif_Create_Var
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_CreateVar
+C **************************************************************************
+C
+ Subroutine Agrif_CreateVar(Agrif_Gr)
+C
+CCC Description:
+CCC This subroutine allows to make a link between Mygrid and the current grid
+C
+C Modules used:
+C
+C
+C Declarations:
+C
+C
+C
+C Arguments
+C
+ TYPE(Agrif_Grid),pointer :: Agrif_Gr ! Pointer on the current grid
+ INTEGER :: i ! Loop
+C
+ if (Agrif_Gr % fixedrank .NE. 0) then
+C
+ do i = 1 , Agrif_NbVariables
+ Agrif_Gr % tabvars(i) % parent_var =>
+ & Agrif_Gr % parent % tabvars(i)
+ Agrif_Gr % tabvars(i) % var % root_var =>
+ & Agrif_Mygrid % tabvars(i) % var
+ Agrif_Gr % tabvars(i) % var % nbdim =
+ & Agrif_Gr % parent % tabvars(i) % var % nbdim
+ enddo
+C
+ endif
+C
+ End Subroutine Agrif_CreateVar
+C
+C
+C
+ End Module Agrif_Init_Vars
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modinterp.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modinterp.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modinterp.F (revision 8155)
@@ -0,0 +1,2270 @@
+!
+! $Id: modinterp.F 2731 2011-04-08 12:05:35Z rblod $
+!
+C AGRIF (Adaptive Grid Refinement In Fortran)
+C
+C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
+C Christophe Vouland (Christophe.Vouland@imag.fr)
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.
+C
+C
+C
+CCC Module Agrif_Interpolation
+C
+ Module Agrif_Interpolation
+C
+CCC Description:
+CCC Module to initialize a fine grid from its parent grid, by using a space
+CCC interpolation
+C
+C Modules used:
+C
+ Use Agrif_Interpbasic
+ Use Agrif_Arrays
+ Use Agrif_Mask
+ Use Agrif_CurgridFunctions
+#if defined key_mpp_mpi
+ Use Agrif_mpp
+#endif
+C
+ IMPLICIT NONE
+ logical, private:: precomputedone(7) = .FALSE.
+C
+ CONTAINS
+C Define procedures contained in this module
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_1d
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_1d(TypeInterp,parent,child,tab,
+ & torestore,nbdim,procname)
+C
+CCC Description:
+CCC Subroutine to calculate the boundary conditions of a fine grid for a 1D
+C grid variable.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(6) :: TypeInterp ! Kind of interpolation
+ ! (linear,lagrange,spline)
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
+ ! grid
+ LOGICAL :: torestore
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1)
+ & ), Target :: tab ! Result
+ External :: procname
+ Optional :: procname
+C
+C
+ allocate(childtemp % var)
+C
+C Pointer on the root variable
+ childtemp % var % root_var => child % var %root_var
+C
+C Number of dimensions of the grid variable
+ childtemp % var % nbdim = nbdim
+C
+C Tab is the result of the interpolation
+ childtemp % var % parray1 => tab
+
+ childtemp % var % lb = child % var % lb
+ childtemp % var % ub = child % var % ub
+
+C
+ if (torestore) then
+C
+ childtemp % var % parray1 = child % var % array1
+C
+ childtemp % var % restore1D => child % var % restore1D
+C
+ else
+C
+ Nullify(childtemp % var % restore1D)
+C
+ endif
+C
+C Index indicating (in the Agrif_Interp1D procedure) if a space
+C interpolation is necessary
+ childtemp % var % interpIndex => child % var % interpIndex
+ childtemp % var % Interpolationshouldbemade =
+ & child % var % Interpolationshouldbemade
+ childtemp % var % list_interp => child % var% list_interp
+C
+ if (present(procname)) then
+ Call Agrif_InterpVariable
+ & (TypeInterp,parent,childtemp,torestore,procname)
+ else
+ Call Agrif_InterpVariable
+ & (TypeInterp,parent,childtemp,torestore)
+ endif
+ child % var % list_interp => childtemp % var %list_interp
+C
+ deallocate(childtemp % var)
+C
+C
+ End Subroutine Agrif_Interp_1D
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_2d
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_2d(TypeInterp,parent,child,tab,
+ & torestore,nbdim,procname)
+C
+CCC Description:
+CCC Subroutine to calculate the boundary conditions of a fine grid for a 2D
+C grid variable.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(6) :: TypeInterp ! Kind of interpolation
+ ! (linear,lagrange,spline)
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
+ ! grid
+ LOGICAL :: torestore
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1),
+ & child%var%lb(2):child%var%ub(2)
+ & ), Target :: tab ! Result
+ External :: procname
+ Optional :: procname
+C
+C
+ allocate(childtemp % var)
+C
+C Pointer on the root variable
+ childtemp % var % root_var => child % var %root_var
+C
+C Number of dimensions of the grid variable
+ childtemp % var % nbdim = nbdim
+C
+C Tab is the result of the interpolation
+ childtemp % var % parray2 => tab
+
+ childtemp % var % lb = child % var % lb
+ childtemp % var % ub = child % var % ub
+
+C
+ if (torestore) then
+C
+ childtemp % var % parray2 = child % var % array2
+C
+ childtemp % var % restore2D => child % var % restore2D
+C
+ else
+C
+ Nullify(childtemp % var % restore2D)
+C
+ endif
+C
+C Index indicating (in the Agrif_Interp2D procedure) if a space
+C interpolation is necessary
+ childtemp % var % interpIndex => child % var % interpIndex
+ childtemp % var % Interpolationshouldbemade =
+ & child % var % Interpolationshouldbemade
+ childtemp % var % list_interp => child % var% list_interp
+C
+ if (present(procname)) then
+ Call Agrif_InterpVariable
+ & (TypeInterp,parent,childtemp,torestore,procname)
+ else
+ Call Agrif_InterpVariable
+ & (TypeInterp,parent,childtemp,torestore)
+ endif
+
+ child % var % list_interp => childtemp % var %list_interp
+C
+ deallocate(childtemp % var)
+C
+C
+ End Subroutine Agrif_Interp_2D
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_3d
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_3d(TypeInterp,parent,child,tab,
+ & torestore,nbdim,procname)
+C
+CCC Description:
+CCC Subroutine to calculate the boundary conditions of a fine grid for a 3D
+C grid variable.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(6) :: TypeInterp ! Kind of interpolation
+ ! (linear,lagrange,spline)
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
+ ! grid
+ LOGICAL :: torestore
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1),
+ & child%var%lb(2):child%var%ub(2),
+ & child%var%lb(3):child%var%ub(3)
+ & ), Target :: tab ! Results
+ External :: procname
+ Optional :: procname
+C
+C
+ allocate(childtemp % var)
+C
+C Pointer on the root variable
+ childtemp % var % root_var => child % var %root_var
+C
+C Number of dimensions of the grid variable
+ childtemp % var % nbdim = nbdim
+C
+C Tab is the result of the interpolation
+ childtemp % var % parray3 => tab
+
+ childtemp % var % lb = child % var % lb
+ childtemp % var % ub = child % var % ub
+C
+ if (torestore) then
+C
+ childtemp % var % parray3 = child % var % array3
+C
+ childtemp % var % restore3D => child % var % restore3D
+C
+ else
+C
+ Nullify(childtemp % var % restore3D)
+C
+ endif
+C
+C Index indicating (in the Agrif_Interp3D procedure) if a space
+C interpolation is necessary
+ childtemp % var % interpIndex => child % var % interpIndex
+ childtemp % var % Interpolationshouldbemade =
+ & child % var % Interpolationshouldbemade
+ childtemp % var % list_interp => child % var% list_interp
+C
+
+ if (present(procname)) then
+ Call Agrif_InterpVariable
+ & (TypeInterp,parent,childtemp,torestore,procname)
+ else
+ Call Agrif_InterpVariable
+ & (TypeInterp,parent,childtemp,torestore)
+ endif
+
+
+ child % var % list_interp => childtemp % var %list_interp
+C
+ deallocate(childtemp % var)
+C
+C
+ End Subroutine Agrif_Interp_3D
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_4d
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_4d(TypeInterp,parent,child,tab,
+ & torestore,nbdim,procname)
+C
+CCC Description:
+CCC Subroutine to calculate the boundary conditions of a fine grid for a 4D
+C grid variable.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(6) :: TypeInterp ! Kind of interpolation
+ ! (linear,lagrange,spline)
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
+ ! grid
+ LOGICAL :: torestore
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1),
+ & child%var%lb(2):child%var%ub(2),
+ & child%var%lb(3):child%var%ub(3),
+ & child%var%lb(4):child%var%ub(4)
+ & ), Target :: tab ! Results
+ External :: procname
+ Optional :: procname
+C
+C
+ allocate(childtemp % var)
+C
+C Pointer on the root variable
+ childtemp % var % root_var => child % var %root_var
+C
+C Number of dimensions of the grid variable
+ childtemp % var % nbdim = nbdim
+C
+C Tab is the result of the interpolation
+ childtemp % var % parray4 => tab
+
+ childtemp % var % lb = child % var % lb
+ childtemp % var % ub = child % var % ub
+
+C
+ if (torestore) then
+C
+ childtemp % var % parray4 = child % var % array4
+C
+ childtemp % var % restore4D => child % var % restore4D
+C
+ else
+C
+ Nullify(childtemp % var % restore4D)
+C
+ endif
+C
+C Index indicating (in the Agrif_Interp4D procedure) if a space
+C interpolation is necessary
+ childtemp % var % interpIndex => child % var % interpIndex
+ childtemp % var % Interpolationshouldbemade =
+ & child % var % Interpolationshouldbemade
+ childtemp % var % list_interp => child % var% list_interp
+C
+ if (present(procname)) then
+ Call Agrif_InterpVariable
+ & (TypeInterp,parent,childtemp,torestore,procname)
+ else
+ Call Agrif_InterpVariable
+ & (TypeInterp,parent,childtemp,torestore)
+ endif
+
+
+ child % var % list_interp => childtemp % var %list_interp
+C
+ deallocate(childtemp % var)
+C
+C
+ End Subroutine Agrif_Interp_4D
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_5d
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_5d(TypeInterp,parent,child,tab,
+ & torestore,nbdim,procname)
+C
+CCC Description:
+CCC Subroutine to calculate the boundary conditions of a fine grid for a 5D
+C grid variable.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(6) :: TypeInterp ! Kind of interpolation
+ ! (linear,lagrange,spline)
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
+ ! grid
+ LOGICAL :: torestore
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1),
+ & child%var%lb(2):child%var%ub(2),
+ & child%var%lb(3):child%var%ub(3),
+ & child%var%lb(4):child%var%ub(4),
+ & child%var%lb(5):child%var%ub(5)
+ & ), Target :: tab ! Results
+ External :: procname
+ Optional :: procname
+C
+C
+ allocate(childtemp % var)
+C
+C Pointer on the root variable
+ childtemp % var % root_var => child % var %root_var
+C
+C Number of dimensions of the grid variable
+ childtemp % var % nbdim = nbdim
+C
+C Tab is the result of the interpolation
+ childtemp % var % parray5 => tab
+
+ childtemp % var % lb = child % var % lb
+ childtemp % var % ub = child % var % ub
+
+C
+ if (torestore) then
+C
+ childtemp % var % parray5 = child % var % array5
+C
+ childtemp % var % restore5D => child % var % restore5D
+C
+ else
+C
+ Nullify(childtemp % var % restore5D)
+C
+ endif
+C
+C Index indicating (in the Agrif_Interp5D procedure) if a space
+C interpolation is necessary
+ childtemp % var % interpIndex => child % var % interpIndex
+ childtemp % var % Interpolationshouldbemade =
+ & child % var % Interpolationshouldbemade
+ childtemp % var % list_interp => child % var% list_interp
+C
+ if (present(procname)) then
+ Call Agrif_InterpVariable
+ & (TypeInterp,parent,childtemp,torestore,procname)
+ else
+ Call Agrif_InterpVariable
+ & (TypeInterp,parent,childtemp,torestore)
+ endif
+
+
+ child % var % list_interp => childtemp % var %list_interp
+C
+ deallocate(childtemp % var)
+C
+C
+ End Subroutine Agrif_Interp_5D
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_6d
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_6d(TypeInterp,parent,child,tab,
+ & torestore,nbdim,procname)
+C
+CCC Description:
+CCC Subroutine to calculate the boundary conditions of a fine grid for a 6D
+C grid variable.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(6) :: TypeInterp ! Kind of interpolation
+ ! (linear,lagrange,spline)
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
+ ! grid
+ LOGICAL :: torestore
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1),
+ & child%var%lb(2):child%var%ub(2),
+ & child%var%lb(3):child%var%ub(3),
+ & child%var%lb(4):child%var%ub(4),
+ & child%var%lb(5):child%var%ub(5),
+ & child%var%lb(6):child%var%ub(6)
+ & ), Target :: tab ! Results
+ External :: procname
+ Optional :: procname
+C
+C
+ allocate(childtemp % var)
+C
+C Pointer on the root variable
+ childtemp % var % root_var => child % var %root_var
+C
+C Number of dimensions of the grid variable
+ childtemp % var % nbdim = nbdim
+C
+C Tab is the result of the interpolation
+ childtemp % var % parray6 => tab
+
+ childtemp % var % lb = child % var % lb
+ childtemp % var % ub = child % var % ub
+
+C
+ if (torestore) then
+C
+ childtemp % var % parray6 = child % var % array6
+C
+ childtemp % var % restore6D => child % var % restore6D
+C
+ else
+C
+ Nullify(childtemp % var % restore6D)
+C
+ endif
+C
+C Index indicating (in the Agrif_Interp6D procedure) if a space
+C interpolation is necessary
+ childtemp % var % interpIndex => child % var % interpIndex
+ childtemp % var % Interpolationshouldbemade =
+ & child % var % Interpolationshouldbemade
+
+ childtemp % var % list_interp => child % var% list_interp
+C
+
+ if (present(procname)) then
+ Call Agrif_InterpVariable
+ & (TypeInterp,parent,childtemp,torestore,procname)
+ else
+ Call Agrif_InterpVariable
+ & (TypeInterp,parent,childtemp,torestore)
+ endif
+
+
+C
+ child % var % list_interp => childtemp % var %list_interp
+ deallocate(childtemp % var)
+C
+C
+ End Subroutine Agrif_Interp_6D
+C
+C
+C
+C **************************************************************************
+C Subroutine Agrif_InterpVariable
+C **************************************************************************
+C
+ Subroutine Agrif_InterpVariable(TYPEinterp,parent,child,torestore,
+ & procname)
+C
+CCC Description:
+CCC Subroutine to set some arguments of subroutine Agrif_InterpnD, n being the
+CCC DIMENSION of the grid variable.
+C
+CC Declarations:
+C
+c
+C
+C
+C Scalar argument
+ INTEGER,DIMENSION(6) :: TYPEinterp! TYPE of interpolation
+ ! (linear,spline,...)
+C Data TYPE arguments
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+C
+C LOGICAL argument
+ LOGICAL:: torestore ! Its value is .false., it indicates the
+ ! results of the interpolation are
+ ! applied on the whole current grid
+C
+C Local scalars
+ INTEGER :: nbdim ! Number of dimensions of the
+ ! current grid
+ INTEGER ,DIMENSION(6) :: pttab_child
+ INTEGER ,DIMENSION(6) :: petab_child
+ INTEGER ,DIMENSION(6) :: pttab_parent
+ REAL ,DIMENSION(6) :: s_child,s_parent
+ REAL ,DIMENSION(6) :: ds_child,ds_parent
+ External :: procname
+ Optional :: procname
+
+C
+ Call PreProcessToInterpOrUpdate(parent,child,
+ & petab_Child(1:nbdim),
+ & pttab_Child(1:nbdim),pttab_Parent(1:nbdim),
+ & s_Child(1:nbdim),s_Parent(1:nbdim),
+ & ds_Child(1:nbdim),ds_Parent(1:nbdim),
+ & nbdim)
+C
+C
+C Call to a procedure of interpolation against the number of dimensions of
+C the grid variable
+C
+
+ if (present(procname)) then
+ call Agrif_InterpnD
+ & (TYPEinterp,parent,child,
+ & pttab_Child(1:nbdim),petab_Child(1:nbdim),
+ & pttab_Child(1:nbdim),pttab_Parent(1:nbdim),
+ & s_Child(1:nbdim),s_Parent(1:nbdim),
+ & ds_Child(1:nbdim),ds_Parent(1:nbdim),
+ & child,torestore,nbdim,procname)
+ else
+ call Agrif_InterpnD
+ & (TYPEinterp,parent,child,
+ & pttab_Child(1:nbdim),petab_Child(1:nbdim),
+ & pttab_Child(1:nbdim),pttab_Parent(1:nbdim),
+ & s_Child(1:nbdim),s_Parent(1:nbdim),
+ & ds_Child(1:nbdim),ds_Parent(1:nbdim),
+ & child,torestore,nbdim)
+
+ endif
+C
+ Return
+C
+C
+ End subroutine Agrif_InterpVariable
+C
+C
+C **************************************************************************
+C Subroutine Agrif_InterpnD
+C **************************************************************************
+C
+ Subroutine Agrif_InterpnD(TYPEinterp,parent,child,
+ & pttab,petab,
+ & pttab_Child,pttab_Parent,
+ & s_Child,s_Parent,ds_Child,ds_Parent,
+ & restore,torestore,nbdim,procname)
+C
+C Description:
+C Subroutine to interpolate a nD grid variable from its parent grid,
+C by using a space interpolation.
+C
+C Declarations:
+C
+
+C
+#ifdef key_mpp_mpi
+C
+ INCLUDE 'mpif.h'
+C
+#endif
+C
+C Arguments
+ External :: procname
+ Optional :: procname
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(6) :: TYPEinterp ! TYPE of interpolation
+ ! (linear,...)
+ TYPE(AGRIF_PVARIABLE) :: parent ! Variable of the parent
+ ! grid
+ TYPE(AGRIF_PVARIABLE) :: child ! Variable of the child
+ ! grid
+ INTEGER,DIMENSION(nbdim) :: pttab ! Index of the first
+ ! point inside the
+ ! domain
+ INTEGER,DIMENSION(nbdim) :: petab ! Index of the first
+ ! point inside the
+ ! domain
+ INTEGER,DIMENSION(nbdim) :: pttab_Child ! Index of the first
+ ! point inside the
+ ! domain for the child
+ ! grid variable
+ INTEGER,DIMENSION(nbdim) :: pttab_Parent ! Index of the first
+ ! point inside the
+ ! domain for the
+ ! parent grid variable
+ TYPE(AGRIF_PVARIABLE) :: restore ! Indicates points where
+ ! interpolation
+ REAL,DIMENSION(nbdim) :: s_Child,s_Parent ! Positions of the parent
+ ! and child grids
+ REAL,DIMENSION(nbdim) :: ds_Child,ds_Parent ! Space steps of the
+ ! parent and child
+ ! grids
+ LOGICAL :: torestore ! Indicates if the array
+ ! restore is used
+C
+C Local pointers
+ TYPE(AGRIF_PVARIABLE),SAVE :: tempP,tempPextend ! Temporary parent grid variable
+ TYPE(AGRIF_PVARIABLE),SAVE :: tempC ! Temporary child grid variable
+C
+C Local scalars
+ INTEGER :: i,j,k,l,m,n
+ INTEGER,DIMENSION(nbdim) :: pttruetab,cetruetab
+ INTEGER,DIMENSION(nbdim) :: indmin,indmax
+ LOGICAL,DIMENSION(nbdim) :: noraftab
+ REAL ,DIMENSION(nbdim) :: s_Child_temp,s_Parent_temp
+ INTEGER,DIMENSION(nbdim) :: lowerbound,upperbound
+ INTEGER,DIMENSION(nbdim) :: indminglob,indmaxglob
+ INTEGER,DIMENSION(nbdim,2,2) :: childarray
+ INTEGER,DIMENSION(nbdim,2,2) :: parentarray
+ LOGICAL :: memberin,member
+ TYPE(AGRIF_PVARIABLE),SAVE :: parentvalues
+ LOGICAL :: find_list_interp
+ INTEGER,DIMENSION(nbdim) :: indminglob2,indmaxglob2
+C
+#ifdef key_mpp_mpi
+C
+ LOGICAL :: memberout
+ INTEGER,PARAMETER :: etiquette = 100
+ INTEGER :: code
+ INTEGER,DIMENSION(nbdim,4) :: tab3
+ INTEGER,DIMENSION(nbdim,4,0:Agrif_Nbprocs-1) :: tab4
+ INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab4t
+ LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall
+ LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc1,recvfromproc1
+ LOGICAL, DIMENSION(1) :: memberin1
+C
+#endif
+C
+
+C
+C Boundaries of the current grid where interpolation is done
+
+ IF (Associated(child%var%list_interp)) THEN
+ Call Agrif_Find_list_interp(child%var%list_interp,pttab,petab,
+ & pttab_Child,pttab_Parent,nbdim,
+ & indmin,indmax,indminglob,
+ & indmaxglob,indminglob2,indmaxglob2,parentarray,
+ & pttruetab,cetruetab,member,memberin,find_list_interp
+#if defined key_mpp_mpi
+ & ,tab4t,memberinall,sendtoproc1,recvfromproc1
+#endif
+ & )
+ ELSE
+ find_list_interp = .FALSE.
+ ENDIF
+
+ IF (.not.find_list_interp) THEN
+
+ Call Agrif_nbdim_Get_bound_dimension(child % var,
+ & lowerbound,upperbound,nbdim)
+
+ Call Agrif_Childbounds(nbdim,lowerbound,upperbound,
+ & pttab,petab,
+ & pttruetab,cetruetab,memberin)
+
+C
+ Call Agrif_Parentbounds(TYPEinterp,nbdim,indminglob,indmaxglob,
+ & s_Parent_temp,s_Child_temp,
+ & s_Child,ds_Child,
+ & s_Parent,ds_Parent,
+ & pttab,petab,
+ & pttab_Child,pttab_Parent,
+ & child%var%root_var%posvar,
+ & child % var % root_var % interptab)
+
+#ifdef key_mpp_mpi
+ IF (memberin) THEN
+ Call Agrif_Parentbounds(TYPEinterp,nbdim,indmin,indmax,
+ & s_Parent_temp,s_Child_temp,
+ & s_Child,ds_Child,
+ & s_Parent,ds_Parent,
+ & pttruetab,cetruetab,
+ & pttab_Child,pttab_Parent,
+ & child%var%root_var%posvar,
+ & child % var % root_var % interptab)
+ ENDIF
+
+ Call Agrif_nbdim_Get_bound_dimension(parent%var,
+ & lowerbound,upperbound,nbdim)
+
+ Call Agrif_ChildGrid_to_ParentGrid()
+C
+ Call Agrif_Childbounds(nbdim,
+ & lowerbound,upperbound,
+ & indminglob,indmaxglob,
+ & indminglob2,indmaxglob2,member)
+
+C
+ IF (member) THEN
+ Call Agrif_GlobtoLocInd2(parentarray,
+ & lowerbound,upperbound,
+ & indminglob2,indmaxglob2,
+ & nbdim,Agrif_Procrank,
+ & member)
+ endif
+
+ Call Agrif_ParentGrid_to_ChildGrid()
+#else
+ parentarray(:,1,1) = indminglob
+ parentarray(:,2,1) = indmaxglob
+ parentarray(:,1,2) = indminglob
+ parentarray(:,2,2) = indmaxglob
+ indmin = indminglob
+ indmax = indmaxglob
+ member = .TRUE.
+#endif
+
+ ELSE
+
+#if !defined key_mpp_mpi
+ parentarray(:,1,1) = indminglob
+ parentarray(:,2,1) = indmaxglob
+ parentarray(:,1,2) = indminglob
+ parentarray(:,2,2) = indmaxglob
+ indmin = indminglob
+ indmax = indmaxglob
+ member = .TRUE.
+ s_Parent_temp = s_Parent + (indminglob - pttab_Parent)*ds_Parent
+ s_Child_temp = s_Child + (pttab - pttab_Child) * ds_Child
+#else
+ s_Parent_temp = s_Parent + (indmin - pttab_Parent)*ds_Parent
+ s_Child_temp = s_Child + (pttruetab - pttab_Child) * ds_Child
+#endif
+
+ ENDIF
+
+ IF (member) THEN
+ IF (.not.associated(tempP%var)) allocate(tempP%var)
+
+C
+ Call Agrif_nbdim_allocation(tempP%var,
+ & parentarray(:,1,1),parentarray(:,2,1),nbdim)
+
+ Call Agrif_nbdim_Full_VarEQreal(tempP%var,0.,nbdim)
+
+ IF (present(procname)) THEN
+ Call Agrif_ChildGrid_to_ParentGrid()
+ SELECT CASE (nbdim)
+ CASE(1)
+ CALL procname(tempP%var%array1,
+ & parentarray(1,1,2),parentarray(1,2,2))
+ CASE(2)
+ CALL procname(tempP%var%array2,
+ & parentarray(1,1,2),parentarray(1,2,2),
+ & parentarray(2,1,2),parentarray(2,2,2))
+ CASE(3)
+ CALL procname(tempP%var%array3,
+ & parentarray(1,1,2),parentarray(1,2,2),
+ & parentarray(2,1,2),parentarray(2,2,2),
+ & parentarray(3,1,2),parentarray(3,2,2))
+ CASE(4)
+ CALL procname(tempP%var%array4,
+ & parentarray(1,1,2),parentarray(1,2,2),
+ & parentarray(2,1,2),parentarray(2,2,2),
+ & parentarray(3,1,2),parentarray(3,2,2),
+ & parentarray(4,1,2),parentarray(4,2,2))
+ CASE(5)
+ CALL procname(tempP%var%array5,
+ & parentarray(1,1,2),parentarray(1,2,2),
+ & parentarray(2,1,2),parentarray(2,2,2),
+ & parentarray(3,1,2),parentarray(3,2,2),
+ & parentarray(4,1,2),parentarray(4,2,2),
+ & parentarray(5,1,2),parentarray(5,2,2))
+ CASE(6)
+ CALL procname(tempP%var%array6,
+ & parentarray(1,1,2),parentarray(1,2,2),
+ & parentarray(2,1,2),parentarray(2,2,2),
+ & parentarray(3,1,2),parentarray(3,2,2),
+ & parentarray(4,1,2),parentarray(4,2,2),
+ & parentarray(5,1,2),parentarray(5,2,2),
+ & parentarray(6,1,2),parentarray(6,2,2))
+ END SELECT
+ Call Agrif_ParentGrid_to_ChildGrid()
+ ELSE
+
+ Call Agrif_nbdim_VarEQvar(tempP%var,
+ & parentarray(:,1,1),parentarray(:,2,1),
+ & parent%var,parentarray(:,1,2),parentarray(:,2,2),
+ & nbdim)
+ ENDIF
+ endif
+
+#ifdef key_mpp_mpi
+ if (.not.find_list_interp) then
+ tab3(:,1) = indminglob2(:)
+ tab3(:,2) = indmaxglob2(:)
+ tab3(:,3) = indmin(:)
+ tab3(:,4) = indmax(:)
+C
+C
+ Call MPI_ALLGATHER(tab3,4*nbdim,MPI_INTEGER,tab4,4*nbdim,
+ & MPI_INTEGER,MPI_COMM_AGRIF,code)
+
+ IF (.not.associated(tempPextend%var)) Allocate(tempPextend%var)
+
+ DO k=0,Agrif_Nbprocs-1
+ do j=1,4
+ do i=1,nbdim
+ tab4t(i,k,j) = tab4(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ memberin1(1) = memberin
+ CALL MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall,
+ & 1,MPI_LOGICAL,MPI_COMM_AGRIF,code)
+
+ Call Get_External_Data_first(tab4t(:,:,1),
+ & tab4t(:,:,2),
+ & tab4t(:,:,3),tab4t(:,:,4),nbdim,member,memberin,
+ & memberinall,sendtoproc1,recvfromproc1,tab4t(:,:,5),
+ & tab4t(:,:,6),tab4t(:,:,7),tab4t(:,:,8))
+
+ endif
+
+! Call Get_External_Data(tempP,tempPextend,tab4t(:,:,1),
+! & tab4t(:,:,2),
+! & tab4t(:,:,3),tab4t(:,:,4),nbdim,member,memberin,
+! & memberinall)
+
+ Call ExchangeSameLevel2(sendtoproc1,recvfromproc1,nbdim,
+ & tab4t(:,:,3),tab4t(:,:,4),tab4t(:,:,5),tab4t(:,:,6),
+ & tab4t(:,:,7),tab4t(:,:,8),memberin,tempP,
+ & tempPextend)
+#else
+ tempPextend%var => tempP%var
+#endif
+
+ if (.not.find_list_interp) then
+ Call Agrif_Addto_list_interp(child%var%list_interp,pttab,petab,
+ & pttab_Child,pttab_Parent,indmin,indmax,
+ & indminglob,indmaxglob,indminglob2,indmaxglob2,parentarray,
+ & pttruetab,cetruetab,member,memberin,nbdim
+#if defined key_mpp_mpi
+ & ,tab4t,memberinall,sendtoproc1,recvfromproc1
+#endif
+ & )
+ endif
+C
+C
+ IF (memberin) THEN
+ IF (.not.associated(tempC%var)) allocate(tempC%var)
+C
+
+ Call Agrif_nbdim_allocation(tempC%var,pttruetab,cetruetab,nbdim)
+
+C
+C
+C Special values on the parent grid
+ if (Agrif_UseSpecialValue) then
+C
+ noraftab(1:nbdim) =
+ & child % var % root_var % interptab(1:nbdim) .EQ. 'N'
+C
+ IF (.not.associated(parentvalues%var))
+ & Allocate(parentvalues%var)
+C
+ Call Agrif_nbdim_allocation
+ & (parentvalues%var,indmin,indmax,nbdim)
+ Call Agrif_nbdim_Full_VarEQvar
+ & (parentvalues%var,tempPextend%var,nbdim)
+C
+ Call Agrif_CheckMasknD(tempPextend,
+ & parentvalues,
+ & indmin(1:nbdim),indmax(1:nbdim),
+ & indmin(1:nbdim),indmax(1:nbdim),
+ & noraftab(1:nbdim),nbdim)
+C
+ Call Agrif_nbdim_deallocation(parentvalues%var,nbdim)
+C Deallocate(parentvalues%var)
+C
+C
+ endif
+
+C
+C
+C Interpolation of the current grid
+
+ IF (memberin) THEN
+ if ( nbdim .EQ. 1 ) then
+ Call Agrif_Interp_1D_recursive(TypeInterp,
+ & tempPextend%var%array1,tempC%var%array1,
+ & indmin,indmax,
+ & pttruetab,cetruetab,
+ & s_Child_temp,s_Parent_temp,
+ & ds_Child,ds_Parent,nbdim)
+ elseif ( nbdim .EQ. 2 ) then
+
+ Call Agrif_Interp_2D_recursive(TypeInterp,
+ & tempPextend%var%array2,tempC%var%array2,
+ & indmin,indmax,
+ & pttruetab,cetruetab,
+ & s_Child_temp,s_Parent_temp,
+ & ds_Child,ds_Parent,nbdim)
+ elseif ( nbdim .EQ. 3 ) then
+
+ Call Agrif_Interp_3D_recursive(TypeInterp,
+ & tempPextend%var%array3,tempC%var%array3,
+ & indmin,indmax,
+ & pttruetab,cetruetab,
+ & s_Child_temp,s_Parent_temp,
+ & ds_Child,ds_Parent,nbdim)
+ elseif ( nbdim .EQ. 4 ) then
+ Call Agrif_Interp_4D_recursive(TypeInterp,
+ & tempPextend%var%array4,tempC%var%array4,
+ & indmin,indmax,
+ & pttruetab,cetruetab,
+ & s_Child_temp,s_Parent_temp,
+ & ds_Child,ds_Parent,nbdim)
+ elseif ( nbdim .EQ. 5 ) then
+ Call Agrif_Interp_5D_recursive(TypeInterp,
+ & tempPextend%var%array5,tempC%var%array5,
+ & indmin,indmax,
+ & pttruetab,cetruetab,
+ & s_Child_temp,s_Parent_temp,
+ & ds_Child,ds_Parent,nbdim)
+ elseif ( nbdim .EQ. 6 ) then
+ Call Agrif_Interp_6D_recursive(TypeInterp,
+ & tempPextend%var%array6,tempC%var%array6,
+ & indmin,indmax,
+ & pttruetab,cetruetab,
+ & s_Child_temp,s_Parent_temp,
+ & ds_Child,ds_Parent,nbdim)
+ endif
+
+
+C
+
+ Call Agrif_nbdim_Get_bound_dimension(child % var,
+ & lowerbound,upperbound,nbdim)
+
+#ifdef key_mpp_mpi
+ Call Agrif_GlobtoLocInd2(childarray,
+ & lowerbound,upperbound,
+ & pttruetab,cetruetab,
+ & nbdim,Agrif_Procrank,
+ & memberout)
+
+#else
+ childarray(:,1,1) = pttruetab
+ childarray(:,2,1) = cetruetab
+ childarray(:,1,2) = pttruetab
+ childarray(:,2,2) = cetruetab
+ccccccccccccccc memberout = .TRUE.
+#endif
+
+
+C
+C
+C Special values on the child grid
+ if (Agrif_UseSpecialValueFineGrid) then
+C
+
+ Call GiveAgrif_SpecialValueToTab_mpi(child%var,tempC%var,
+ & childarray,
+ & pttruetab,cetruetab,
+ & Agrif_SpecialValueFineGrid,nbdim)
+
+C
+ endif
+
+ endif
+
+C
+ if (torestore) then
+C
+#ifdef key_mpp_mpi
+C
+ SELECT CASE (nbdim)
+ CASE (1)
+ do i = pttruetab(1),cetruetab(1)
+ChildarrayAModifier if (restore%var%restore1D(i) == 0)
+ChildarrayAModifier & child%var%array1(childarray(i,1,2)
+ChildarrayAModifier & ) =
+ChildarrayAModifier & tempC%var%array1(i)
+ enddo
+ CASE (2)
+ do i = pttruetab(1),cetruetab(1)
+ do j = pttruetab(2),cetruetab(2)
+ChildarrayAModifier if (restore%var%restore2D(i,j) == 0)
+ChildarrayAModifier & child%var%array2(childarray(i,1,2),
+ChildarrayAModifier & childarray(j,2,2)) =
+ChildarrayAModifier & tempC%var%array2(i,j)
+ enddo
+ enddo
+ CASE (3)
+ do i = pttruetab(1),cetruetab(1)
+ do j = pttruetab(2),cetruetab(2)
+ do k = pttruetab(3),cetruetab(3)
+ChildarrayAModifier if (restore%var%restore3D(i,j,k) == 0)
+ChildarrayAModifier & child%var%array3(childarray(i,1,2),
+ChildarrayAModifier & childarray(j,2,2),
+ChildarrayAModifier & childarray(k,3,2)) =
+ChildarrayAModifier & tempC%var%array3(i,j,k)
+ enddo
+ enddo
+ enddo
+ CASE (4)
+ do i = pttruetab(1),cetruetab(1)
+ do j = pttruetab(2),cetruetab(2)
+ do k = pttruetab(3),cetruetab(3)
+ do l = pttruetab(4),cetruetab(4)
+ChildarrayAModifier if (restore%var%restore4D(i,j,k,l) == 0)
+ChildarrayAModifier & child%var%array4(childarray(i,1,2),
+ChildarrayAModifier & childarray(j,2,2),
+ChildarrayAModifier & childarray(k,3,2),
+ChildarrayAModifier & childarray(l,4,2)) =
+ChildarrayAModifier & tempC%var%array4(i,j,k,l)
+ enddo
+ enddo
+ enddo
+ enddo
+ CASE (5)
+ do i = pttruetab(1),cetruetab(1)
+ do j = pttruetab(2),cetruetab(2)
+ do k = pttruetab(3),cetruetab(3)
+ do l = pttruetab(4),cetruetab(4)
+ do m = pttruetab(5),cetruetab(5)
+ChildarrayAModifier if (restore%var%restore5D(i,j,k,l,m) == 0)
+ChildarrayAModifier & child%var%array5(childarray(i,1,2),
+ChildarrayAModifier & childarray(j,2,2),
+ChildarrayAModifier & childarray(k,3,2),
+ChildarrayAModifier & childarray(l,4,2),
+ChildarrayAModifier & childarray(m,5,2)) =
+ChildarrayAModifier & tempC%var%array5(i,j,k,l,m)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ CASE (6)
+ do i = pttruetab(1),cetruetab(1)
+ do j = pttruetab(2),cetruetab(2)
+ do k = pttruetab(3),cetruetab(3)
+ do l = pttruetab(4),cetruetab(4)
+ do m = pttruetab(5),cetruetab(5)
+ do n = pttruetab(6),cetruetab(6)
+ChildarrayAModifier if (restore%var%restore6D(i,j,k,l,m,n) == 0)
+ChildarrayAModifier & child%var%array6(childarray(i,1,2),
+ChildarrayAModifier & childarray(j,2,2),
+ChildarrayAModifier & childarray(k,3,2),
+ChildarrayAModifier & childarray(l,4,2),
+ChildarrayAModifier & childarray(m,5,2),
+ChildarrayAModifier & childarray(n,6,2)) =
+ChildarrayAModifier & tempC%var%array6(i,j,k,l,m,n)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ END SELECT
+C
+#else
+ SELECT CASE (nbdim)
+ CASE (1)
+ do i = pttruetab(1),cetruetab(1)
+ if (restore%var%restore1D(i) == 0)
+ & child % var % parray1(i) =
+ & tempC % var % array1(i)
+ enddo
+ CASE (2)
+ do j = pttruetab(2),cetruetab(2)
+ do i = pttruetab(1),cetruetab(1)
+ if (restore%var%restore2D(i,j) == 0)
+ & child % var % parray2(i,j) =
+ & tempC % var % array2(i,j)
+ enddo
+ enddo
+ CASE (3)
+ do k = pttruetab(3),cetruetab(3)
+ do j = pttruetab(2),cetruetab(2)
+ do i = pttruetab(1),cetruetab(1)
+ if (restore%var%restore3D(i,j,k) == 0)
+ & child % var % parray3(i,j,k) =
+ & tempC % var % array3(i,j,k)
+ enddo
+ enddo
+ enddo
+ CASE (4)
+ do l = pttruetab(4),cetruetab(4)
+ do k = pttruetab(3),cetruetab(3)
+ do j = pttruetab(2),cetruetab(2)
+ do i = pttruetab(1),cetruetab(1)
+ if (restore%var%restore4D(i,j,k,l) == 0)
+ & child % var % parray4(i,j,k,l) =
+ & tempC % var % array4(i,j,k,l)
+ enddo
+ enddo
+ enddo
+ enddo
+ CASE (5)
+ do m = pttruetab(5),cetruetab(5)
+ do l = pttruetab(4),cetruetab(4)
+ do k = pttruetab(3),cetruetab(3)
+ do j = pttruetab(2),cetruetab(2)
+ do i = pttruetab(1),cetruetab(1)
+ if (restore%var%restore5D(i,j,k,l,m) == 0)
+ & child % var % parray5(i,j,k,l,m) =
+ & tempC % var % array5(i,j,k,l,m)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ CASE (6)
+ do n = pttruetab(6),cetruetab(6)
+ do m = pttruetab(5),cetruetab(5)
+ do l = pttruetab(4),cetruetab(4)
+ do k = pttruetab(3),cetruetab(3)
+ do j = pttruetab(2),cetruetab(2)
+ do i = pttruetab(1),cetruetab(1)
+ if (restore%var%restore6D(i,j,k,l,m,n) == 0)
+ & child % var % parray6(i,j,k,l,m,n) =
+ & tempC % var % array6(i,j,k,l,m,n)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ END SELECT
+C
+#endif
+C
+ else
+C
+C
+ IF (memberin) THEN
+ SELECT CASE (nbdim)
+ CASE (1)
+ child%var%parray1(childarray(1,1,2):childarray(1,2,2)) =
+ & tempC%var%array1(childarray(1,1,1):childarray(1,2,1))
+ CASE (2)
+ child%var%parray2(childarray(1,1,2):childarray(1,2,2),
+ & childarray(2,1,2):childarray(2,2,2)) =
+ & tempC%var%array2(childarray(1,1,1):childarray(1,2,1),
+ & childarray(2,1,1):childarray(2,2,1))
+ CASE (3)
+ child%var%parray3(childarray(1,1,2):childarray(1,2,2),
+ & childarray(2,1,2):childarray(2,2,2),
+ & childarray(3,1,2):childarray(3,2,2)) =
+ & tempC%var%array3(childarray(1,1,1):childarray(1,2,1),
+ & childarray(2,1,1):childarray(2,2,1),
+ & childarray(3,1,1):childarray(3,2,1))
+ CASE (4)
+ child%var%parray4(childarray(1,1,2):childarray(1,2,2),
+ & childarray(2,1,2):childarray(2,2,2),
+ & childarray(3,1,2):childarray(3,2,2),
+ & childarray(4,1,2):childarray(4,2,2)) =
+ & tempC%var%array4(childarray(1,1,1):childarray(1,2,1),
+ & childarray(2,1,1):childarray(2,2,1),
+ & childarray(3,1,1):childarray(3,2,1),
+ & childarray(4,1,1):childarray(4,2,1))
+ CASE (5)
+ child%var%parray5(childarray(1,1,2):childarray(1,2,2),
+ & childarray(2,1,2):childarray(2,2,2),
+ & childarray(3,1,2):childarray(3,2,2),
+ & childarray(4,1,2):childarray(4,2,2),
+ & childarray(5,1,2):childarray(5,2,2)) =
+ & tempC%var%array5(childarray(1,1,1):childarray(1,2,1),
+ & childarray(2,1,1):childarray(2,2,1),
+ & childarray(3,1,1):childarray(3,2,1),
+ & childarray(4,1,1):childarray(4,2,1),
+ & childarray(5,1,1):childarray(5,2,1))
+ CASE (6)
+ child%var%parray6(childarray(1,1,2):childarray(1,2,2),
+ & childarray(2,1,2):childarray(2,2,2),
+ & childarray(3,1,2):childarray(3,2,2),
+ & childarray(4,1,2):childarray(4,2,2),
+ & childarray(5,1,2):childarray(5,2,2),
+ & childarray(6,1,2):childarray(6,2,2)) =
+ & tempC%var%array6(childarray(1,1,1):childarray(1,2,1),
+ & childarray(2,1,1):childarray(2,2,1),
+ & childarray(3,1,1):childarray(3,2,1),
+ & childarray(4,1,1):childarray(4,2,1),
+ & childarray(5,1,1):childarray(5,2,1),
+ & childarray(6,1,1):childarray(6,2,1))
+ END SELECT
+ ENDIF
+C
+C
+ endif
+
+ Call Agrif_nbdim_deallocation(tempPextend%var,nbdim)
+C deallocate(tempPextend%var)
+
+ Call Agrif_nbdim_deallocation(tempC%var,nbdim)
+
+C Deallocate(tempC % var)
+ ELSE
+
+C deallocate(tempPextend%var)
+
+ ENDIF
+C
+C
+C Deallocations
+#ifdef key_mpp_mpi
+ IF (member) THEN
+ Call Agrif_nbdim_deallocation(tempP%var,nbdim)
+C Deallocate(tempP % var)
+ endif
+#endif
+C
+C
+
+C
+C
+ End Subroutine Agrif_InterpnD
+C
+C
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Parentbounds
+C **************************************************************************
+C
+ Subroutine Agrif_Parentbounds(TYPEinterp,nbdim,indmin,indmax,
+ & s_Parent_temp,
+ & s_Child_temp,s_Child,ds_Child,
+ & s_Parent,ds_Parent,
+ & pttruetab,cetruetab,pttab_Child,
+ & pttab_Parent,posvar,interptab)
+C
+CCC Description:
+CCC Subroutine calculating the bounds of the parent grid for the interpolation
+CCC of the child grid
+C
+C
+C Declarations:
+C
+C
+C Arguments
+ INTEGER :: nbdim
+ INTEGER, DIMENSION(6) :: TypeInterp
+ INTEGER,DIMENSION(nbdim) :: indmin,indmax
+ REAL,DIMENSION(nbdim) :: s_Parent_temp,s_child_temp
+ REAL,DIMENSION(nbdim) :: s_Child,ds_child
+ REAL,DIMENSION(nbdim) :: s_Parent,ds_Parent
+ INTEGER,DIMENSION(nbdim) :: pttruetab,cetruetab
+ INTEGER,DIMENSION(nbdim) :: pttab_Child,pttab_Parent
+ INTEGER,DIMENSION(nbdim) :: posvar
+ CHARACTER(6), DIMENSION(nbdim) :: interptab
+C
+C Local variables
+ INTEGER :: i
+ REAL,DIMENSION(nbdim) :: dim_newmin,dim_newmax
+C
+ dim_newmin = s_Child + (pttruetab - pttab_Child) * ds_Child
+ dim_newmax = s_Child + (cetruetab - pttab_Child) * ds_Child
+
+ DO i = 1,nbdim
+C
+ indmin(i) = pttab_Parent(i) +
+ & agrif_int((dim_newmin(i)-s_Parent(i))/ds_Parent(i))
+C
+ indmax(i) = pttab_Parent(i) +
+ & agrif_ceiling((dim_newmax(i)-
+ & s_Parent(i))/ds_Parent(i))
+
+C
+C
+C Necessary for the Quadratic interpolation
+C
+
+ IF ((pttruetab(i) == cetruetab(i)) .AND.
+ & (posvar(i) == 1)) THEN
+ ELSEIF (interptab(i) .EQ. 'N') THEN
+ ELSEIF ( TYPEinterp(i) .eq. Agrif_ppm .or.
+ & TYPEinterp(i) .eq. Agrif_eno .or.
+ & TYPEinterp(i) .eq. Agrif_weno) THEN
+ indmin(i) = indmin(i) - 2
+ indmax(i) = indmax(i) + 2
+ ELSE IF (( TYPEinterp(i) .ne. Agrif_constant )
+ & .AND.( TYPEinterp(i) .ne. Agrif_linear )) THEN
+ indmin(i) = indmin(i) - 1
+ indmax(i) = indmax(i) + 1
+ ENDIF
+
+
+C
+ ENDDO
+C
+ s_Parent_temp = s_Parent + (indmin - pttab_Parent) * ds_Parent
+C
+ s_Child_temp = s_Child + (pttruetab - pttab_Child) * ds_Child
+C
+C
+ Return
+C
+C
+ End Subroutine Agrif_Parentbounds
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_1D_Recursive
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_1D_recursive(TypeInterp,tabin,tabout,
+ & indmin,indmax,
+ & pttab_child,petab_child,
+ & s_child,s_parent,ds_child,ds_parent,nbdim)
+C
+CCC Description:
+CCC Subroutine for the interpolation of a 1D grid variable.
+CCC It calls Agrif_InterpBase.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(1) :: TypeInterp
+ INTEGER, DIMENSION(nbdim) :: indmin,indmax
+ INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
+ REAL, DIMENSION(nbdim) :: s_child,s_parent
+ REAL, DIMENSION(nbdim) :: ds_child,ds_parent
+ REAL, INTENT(IN),DIMENSION(indmin(nbdim):indmax(nbdim)) :: tabin
+ REAL, INTENT(OUT),
+ & DIMENSION(pttab_child(nbdim):petab_child(nbdim)) :: tabout
+ INTEGER :: coeffraf
+C
+C
+C Commentaire perso : nbdim vaut toujours 1 ici.
+C
+ coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
+
+ Call Agrif_InterpBase(TypeInterp(1),
+ & tabin(indmin(nbdim):indmax(nbdim)),
+ & tabout(pttab_child(nbdim):petab_child(nbdim)),
+ & indmin(nbdim),indmax(nbdim),
+ & pttab_child(nbdim),petab_child(nbdim),
+ & s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),coeffraf)
+
+C
+ Return
+C
+C
+ End Subroutine Agrif_Interp_1D_recursive
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_2D_Recursive
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_2D_recursive(TypeInterp,
+ & tabin,tabout,
+ & indmin,indmax,
+ & pttab_child,petab_child,
+ & s_child, s_parent,
+ & ds_child,ds_parent,
+ & nbdim)
+C
+CCC Description:
+CCC Subroutine for the interpolation of a 2D grid variable.
+CCC It calls Agrif_Interp_1D_recursive and Agrif_InterpBase.
+C
+C Declarations:
+C
+
+C
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(2) :: TypeInterp
+ INTEGER, DIMENSION(nbdim) :: indmin,indmax
+ INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
+ REAL , DIMENSION(nbdim) :: s_child, s_parent
+ REAL , DIMENSION(nbdim) :: ds_child,ds_parent
+ REAL ,INTENT(IN), DIMENSION(
+ & indmin(nbdim-1):indmax(nbdim-1),
+ & indmin(nbdim):indmax(nbdim)
+ & ) :: tabin
+ REAL ,INTENT(OUT), DIMENSION(
+ & pttab_child(nbdim-1):petab_child(nbdim-1),
+ & pttab_child(nbdim):petab_child(nbdim)
+ & ) :: tabout
+C
+C Local variables
+ REAL, DIMENSION(pttab_child(nbdim-1):petab_child(nbdim-1),
+ & indmin(nbdim):indmax(nbdim)) :: tabtemp
+ INTEGER i,j
+ INTEGER :: coeffraf
+ REAL , DIMENSION(
+ & pttab_child(nbdim):petab_child(nbdim),
+ & pttab_child(nbdim-1):petab_child(nbdim-1)
+ & ) :: tabout_trsp
+ REAL, DIMENSION(indmin(nbdim):indmax(nbdim),
+ & pttab_child(nbdim-1):petab_child(nbdim-1)) :: tabtemp_trsp
+
+C
+C
+C
+C
+C Commentaire perso : nbdim vaut toujours 2 ici.
+C
+ coeffraf = nint ( ds_parent(1) / ds_child(1) )
+ IF((TypeInterp(1) == Agrif_Linear) .AND. (coeffraf /= 1 ) )THEN
+
+!---CDIR NEXPAND
+ IF(.NOT. precomputedone(1) ) call linear1Dprecompute2D(
+ & indmax(2)-indmin(2)+1,
+ & indmax(1)-indmin(1)+1,
+ & petab_child(1)-pttab_child(1)+1,
+ & s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
+!---CDIR NEXPAND
+ call linear1daftercompute(tabin,tabtemp,
+ & size(tabin), size(tabtemp),
+ & s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
+
+ ELSEIF((TypeInterp(1) == Agrif_PPM) .AND. (coeffraf /= 1 ) )THEN
+!---CDIR NEXPAND
+ IF(.NOT. precomputedone(1) ) call ppm1Dprecompute2D(
+ & indmax(2)-indmin(2)+1,
+ & indmax(1)-indmin(1)+1,
+ & petab_child(1)-pttab_child(1)+1,
+ & s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
+!---CDIR NEXPAND
+ call ppm1daftercompute(tabin,tabtemp,
+ & size(tabin), size(tabtemp),
+ & s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
+
+ ELSE
+
+ do j = indmin(nbdim),indmax(nbdim)
+C
+!---CDIR NEXPAND
+ Call Agrif_Interp_1D_recursive(TypeInterp(1),
+ & tabin(indmin(nbdim-1):indmax(nbdim-1),j),
+ & tabtemp(pttab_child(nbdim-1):petab_child(nbdim-1),j),
+ & indmin(1:nbdim-1),indmax(1:nbdim-1),
+ & pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
+ & s_child(1:nbdim-1),s_parent(1:nbdim-1),
+ & ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
+C
+ enddo
+ ENDIF
+
+ coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
+
+ tabtemp_trsp = TRANSPOSE(tabtemp)
+
+ IF((TypeInterp(2) == Agrif_Linear) .AND. (coeffraf /= 1 ) )THEN
+
+!---CDIR NEXPAND
+ IF(.NOT. precomputedone(2) ) call linear1Dprecompute2D(
+ & petab_child(1)-pttab_child(1)+1,
+ & indmax(2)-indmin(2)+1,
+ & petab_child(2)-pttab_child(2)+1,
+ & s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
+!---CDIR NEXPAND
+ call linear1daftercompute(tabtemp_trsp,tabout_trsp,
+ & size(tabtemp_trsp), size(tabout_trsp),
+ & s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
+
+ ELSEIF((TypeInterp(2) == Agrif_PPM) .AND. (coeffraf /= 1 ) )THEN
+
+!---CDIR NEXPAND
+ IF(.NOT. precomputedone(1) )call ppm1Dprecompute2D(
+ & petab_child(1)-pttab_child(1)+1,
+ & indmax(2)-indmin(2)+1,
+ & petab_child(2)-pttab_child(2)+1,
+ & s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
+!---CDIR NEXPAND
+ call ppm1daftercompute(tabtemp_trsp,tabout_trsp,
+ & size(tabtemp_trsp), size(tabout_trsp),
+ & s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
+
+ ELSE
+ do i=pttab_child(nbdim-1),petab_child(nbdim-1)
+C
+!---CDIR NEXPAND
+ Call Agrif_InterpBase(TypeInterp(2),
+ & tabtemp_trsp(indmin(nbdim):indmax(nbdim),i),
+ & tabout_trsp(pttab_child(nbdim):petab_child(nbdim),i),
+ & indmin(nbdim),indmax(nbdim),
+ & pttab_child(nbdim),petab_child(nbdim),
+ & s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),coeffraf)
+
+C
+ enddo
+ ENDIF
+
+ tabout = TRANSPOSE(tabout_trsp)
+C
+ Return
+C
+C
+ End Subroutine Agrif_Interp_2D_recursive
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_3D_Recursive
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_3D_recursive(TypeInterp,tabin,tabout,
+ & indmin,indmax,
+ & pttab_child,petab_child,
+ & s_child,s_parent,ds_child,ds_parent,nbdim)
+C
+CCC Description:
+CCC Subroutine for the interpolation of a 3D grid variable.
+CCC It calls Agrif_Interp_2D_recursive and Agrif_InterpBase.
+C
+C Declarations:
+C
+
+C
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(3) :: TypeInterp
+ INTEGER, DIMENSION(nbdim) :: indmin,indmax
+ INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
+ REAL, DIMENSION(nbdim) :: s_child,s_parent,ds_child,ds_parent
+ REAL,INTENT(IN), DIMENSION(indmin(nbdim-2):indmax(nbdim-2),
+ & indmin(nbdim-1):indmax(nbdim-1),
+ & indmin(nbdim) :indmax(nbdim)) :: tabin
+ REAL,INTENT(OUT),
+ & DIMENSION(pttab_child(nbdim-2):petab_child(nbdim-2),
+ & pttab_child(nbdim-1):petab_child(nbdim-1),
+ & pttab_child(nbdim):petab_child(nbdim)) :: tabout
+C
+C Local variables
+ REAL, DIMENSION(pttab_child(nbdim-2):petab_child(nbdim-2),
+ & pttab_child(nbdim-1):petab_child(nbdim-1),
+ & indmin(nbdim):indmax(nbdim)) :: tabtemp
+ INTEGER i,j,k
+ INTEGER :: coeffraf, locind_child_left, kdeb
+C
+C
+ coeffraf = nint ( ds_parent(1) / ds_child(1) )
+ IF((TypeInterp(1) == Agrif_Linear) .AND. (coeffraf/=1))THEN
+ Call linear1Dprecompute2D(
+ & indmax(2)-indmin(2)+1,
+ & indmax(1)-indmin(1)+1,
+ & petab_child(1)-pttab_child(1)+1,
+ & s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
+ precomputedone(1) = .TRUE.
+ ELSEIF((TypeInterp(1) == Agrif_PPM) .AND. (coeffraf/=1))THEN
+ Call ppm1Dprecompute2D(
+ & indmax(2)-indmin(2)+1,
+ & indmax(1)-indmin(1)+1,
+ & petab_child(1)-pttab_child(1)+1,
+ & s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
+ precomputedone(1) = .TRUE.
+ ENDIF
+
+ coeffraf = nint ( ds_parent(2) / ds_child(2) )
+ IF((TypeInterp(2) == Agrif_Linear) .AND. (coeffraf/=1)) THEN
+ Call linear1Dprecompute2D(
+ & petab_child(1)-pttab_child(1)+1,
+ & indmax(2)-indmin(2)+1,
+ & petab_child(2)-pttab_child(2)+1,
+ & s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
+ precomputedone(2) = .TRUE.
+ ELSEIF((TypeInterp(2) == Agrif_PPM) .AND. (coeffraf/=1)) THEN
+ Call ppm1Dprecompute2D(
+ & petab_child(1)-pttab_child(1)+1,
+ & indmax(2)-indmin(2)+1,
+ & petab_child(2)-pttab_child(2)+1,
+ & s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
+ precomputedone(2) = .TRUE.
+ ENDIF
+
+ do k = indmin(nbdim),indmax(nbdim)
+C
+ Call Agrif_Interp_2D_recursive(TypeInterp(1:2),
+ & tabin(indmin(nbdim-2):indmax(nbdim-2),
+ & indmin(nbdim-1):indmax(nbdim-1),k),
+ & tabtemp(pttab_child(nbdim-2):petab_child(nbdim-2),
+ & pttab_child(nbdim-1):petab_child(nbdim-1),k),
+ & indmin(1:nbdim-1),indmax(1:nbdim-1),
+ & pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
+ & s_child(1:nbdim-1),s_parent(1:nbdim-1),
+ & ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
+C
+ enddo
+
+ precomputedone(1) = .FALSE.
+ precomputedone(2) = .FALSE.
+ coeffraf = nint ( ds_parent(3) / ds_child(3) )
+
+ Call Agrif_Compute_nbdim_interp(s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
+
+ IF (coeffraf == 1) THEN
+
+ kdeb = indmin(3)+locind_child_left-2
+ do k=pttab_child(3),petab_child(3)
+ kdeb = kdeb + 1
+ do j = pttab_child(2),petab_child(2)
+ do i = pttab_child(1),petab_child(1)
+ tabout(i,j,k) = tabtemp(i,j,kdeb)
+ enddo
+ enddo
+ enddo
+
+ ELSE
+C
+ do j=pttab_child(nbdim-1),petab_child(nbdim-1)
+C
+ do i=pttab_child(nbdim-2),petab_child(nbdim-2)
+C
+ Call Agrif_InterpBase(TypeInterp(3),
+ & tabtemp(i,j,indmin(nbdim):indmax(nbdim)),
+ & tabout(i,j,pttab_child(nbdim):petab_child(nbdim)),
+ & indmin(nbdim),indmax(nbdim),
+ & pttab_child(nbdim),petab_child(nbdim),
+ & s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),coeffraf)
+C
+ enddo
+C
+ enddo
+ ENDIF
+C
+ Return
+C
+C
+ End Subroutine Agrif_Interp_3D_recursive
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_4D_Recursive
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_4D_recursive(TypeInterp,tabin,tabout,
+ & indmin,indmax,
+ & pttab_child,petab_child,
+ & s_child,s_parent,ds_child,ds_parent,nbdim)
+C
+CCC Description:
+CCC Subroutine for the interpolation of a 4D grid variable.
+CCC It calls Agrif_Interp_3D_recursive and Agrif_InterpBase.
+C
+C Declarations:
+C
+
+C
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(4) :: TypeInterp
+ INTEGER, DIMENSION(nbdim) :: indmin,indmax
+ INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
+ REAL, DIMENSION(nbdim) :: s_child,s_parent,ds_child,ds_parent
+ REAL,INTENT(IN), DIMENSION(indmin(nbdim-3):indmax(nbdim-3),
+ & indmin(nbdim-2):indmax(nbdim-2),
+ & indmin(nbdim-1):indmax(nbdim-1),
+ & indmin(nbdim):indmax(nbdim)) :: tabin
+ REAL,INTENT(OUT),
+ & DIMENSION(pttab_child(nbdim-3):petab_child(nbdim-3),
+ & pttab_child(nbdim-2):petab_child(nbdim-2),
+ & pttab_child(nbdim-1):petab_child(nbdim-1),
+ & pttab_child(nbdim):petab_child(nbdim)) :: tabout
+C
+C Local variables
+ REAL, DIMENSION(pttab_child(nbdim-3):petab_child(nbdim-3),
+ & pttab_child(nbdim-2):petab_child(nbdim-2),
+ & pttab_child(nbdim-1):petab_child(nbdim-1),
+ & indmin(nbdim):indmax(nbdim)) :: tabtemp
+ INTEGER i,j,k,l
+ INTEGER :: coeffraf
+C
+C
+ do l = indmin(nbdim),indmax(nbdim)
+C
+ Call Agrif_Interp_3D_recursive(TypeInterp(1:3),
+ & tabin(indmin(nbdim-3):indmax(nbdim-3),
+ & indmin(nbdim-2):indmax(nbdim-2),
+ & indmin(nbdim-1):indmax(nbdim-1),l),
+ & tabtemp(pttab_child(nbdim-3):petab_child(nbdim-3),
+ & pttab_child(nbdim-2):petab_child(nbdim-2),
+ & pttab_child(nbdim-1):petab_child(nbdim-1),l),
+ & indmin(1:nbdim-1),indmax(1:nbdim-1),
+ & pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
+ & s_child(1:nbdim-1),s_parent(1:nbdim-1),
+ & ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
+C
+ enddo
+C
+ coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
+
+ do k = pttab_child(nbdim-1),petab_child(nbdim-1)
+C
+ do j = pttab_child(nbdim-2),petab_child(nbdim-2)
+C
+ do i = pttab_child(nbdim-3),petab_child(nbdim-3)
+C
+ Call Agrif_InterpBase(TypeInterp(4),
+ & tabtemp(i,j,k,indmin(nbdim):indmax(nbdim)),
+ & tabout(i,j,k,pttab_child(nbdim):petab_child(nbdim)),
+ & indmin(nbdim),indmax(nbdim),
+ & pttab_child(nbdim),petab_child(nbdim),
+ & s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),coeffraf)
+C
+ enddo
+C
+ enddo
+C
+ enddo
+C
+ Return
+C
+C
+ End Subroutine Agrif_Interp_4D_recursive
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_5D_Recursive
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_5D_recursive(TypeInterp,tabin,tabout,
+ & indmin,indmax,
+ & pttab_child,petab_child,
+ & s_child,s_parent,ds_child,ds_parent,nbdim)
+C
+CCC Description:
+CCC Subroutine for the interpolation of a 5D grid variable.
+CCC It calls Agrif_Interp_4D_recursive and Agrif_InterpBase.
+C
+C Declarations:
+C
+
+C
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(5) :: TypeInterp
+ INTEGER, DIMENSION(nbdim) :: indmin,indmax
+ INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
+ REAL, DIMENSION(nbdim) :: s_child,s_parent,ds_child,ds_parent
+ REAL,INTENT(IN), DIMENSION(indmin(nbdim-4):indmax(nbdim-4),
+ & indmin(nbdim-3):indmax(nbdim-3),
+ & indmin(nbdim-2):indmax(nbdim-2),
+ & indmin(nbdim-1):indmax(nbdim-1),
+ & indmin(nbdim):indmax(nbdim)) :: tabin
+ REAL,INTENT(OUT),
+ & DIMENSION(pttab_child(nbdim-4):petab_child(nbdim-4),
+ & pttab_child(nbdim-3):petab_child(nbdim-3),
+ & pttab_child(nbdim-2):petab_child(nbdim-2),
+ & pttab_child(nbdim-1):petab_child(nbdim-1),
+ & pttab_child(nbdim):petab_child(nbdim)) :: tabout
+C
+C Local variables
+ REAL, DIMENSION(pttab_child(nbdim-4):petab_child(nbdim-4),
+ & pttab_child(nbdim-3):petab_child(nbdim-3),
+ & pttab_child(nbdim-2):petab_child(nbdim-2),
+ & pttab_child(nbdim-1):petab_child(nbdim-1),
+ & indmin(nbdim):indmax(nbdim)) :: tabtemp
+ INTEGER i,j,k,l,m
+ INTEGER :: coeffraf
+C
+C
+ do m = indmin(nbdim),indmax(nbdim)
+C
+ Call Agrif_Interp_4D_recursive(TypeInterp(1:4),
+ & tabin(indmin(nbdim-4):indmax(nbdim-4),
+ & indmin(nbdim-3):indmax(nbdim-3),
+ & indmin(nbdim-2):indmax(nbdim-2),
+ & indmin(nbdim-1):indmax(nbdim-1),m),
+ & tabtemp(pttab_child(nbdim-4):petab_child(nbdim-4),
+ & pttab_child(nbdim-3):petab_child(nbdim-3),
+ & pttab_child(nbdim-2):petab_child(nbdim-2),
+ & pttab_child(nbdim-1):petab_child(nbdim-1),m),
+ & indmin(1:nbdim-1),indmax(1:nbdim-1),
+ & pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
+ & s_child(1:nbdim-1),s_parent(1:nbdim-1),
+ & ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
+C
+ enddo
+
+ coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
+C
+ do l = pttab_child(nbdim-1),petab_child(nbdim-1)
+C
+ do k = pttab_child(nbdim-2),petab_child(nbdim-2)
+C
+ do j = pttab_child(nbdim-3),petab_child(nbdim-3)
+C
+ do i = pttab_child(nbdim-4),petab_child(nbdim-4)
+C
+ Call Agrif_InterpBase(TypeInterp(5),
+ & tabtemp(i,j,k,l,indmin(nbdim):indmax(nbdim)),
+ & tabout(i,j,k,l,
+ & pttab_child(nbdim):petab_child(nbdim)),
+ & indmin(nbdim),indmax(nbdim),
+ & pttab_child(nbdim),petab_child(nbdim),
+ & s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),coeffraf)
+C
+ enddo
+C
+ enddo
+C
+ enddo
+C
+ enddo
+C
+C
+ Return
+C
+C
+ End Subroutine Agrif_Interp_5D_recursive
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Interp_6D_Recursive
+C **************************************************************************
+C
+ Subroutine Agrif_Interp_6D_recursive(TypeInterp,tabin,tabout,
+ & indmin,indmax,
+ & pttab_child,petab_child,
+ & s_child,s_parent,ds_child,ds_parent,nbdim)
+C
+CCC Description:
+CCC Subroutine for the interpolation of a 6D grid variable.
+CCC It calls Agrif_Interp_4D_recursive and Agrif_InterpBase.
+C
+C Declarations:
+C
+
+C
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(6) :: TypeInterp
+ INTEGER, DIMENSION(nbdim) :: indmin,indmax
+ INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
+ REAL, DIMENSION(nbdim) :: s_child,s_parent,ds_child,ds_parent
+ REAL,INTENT(IN), DIMENSION(indmin(nbdim-5):indmax(nbdim-5),
+ & indmin(nbdim-4):indmax(nbdim-4),
+ & indmin(nbdim-3):indmax(nbdim-3),
+ & indmin(nbdim-2):indmax(nbdim-2),
+ & indmin(nbdim-1):indmax(nbdim-1),
+ & indmin(nbdim):indmax(nbdim)) :: tabin
+ REAL,INTENT(OUT),
+ & DIMENSION(pttab_child(nbdim-5):petab_child(nbdim-5),
+ & pttab_child(nbdim-4):petab_child(nbdim-4),
+ & pttab_child(nbdim-3):petab_child(nbdim-3),
+ & pttab_child(nbdim-2):petab_child(nbdim-2),
+ & pttab_child(nbdim-1):petab_child(nbdim-1),
+ & pttab_child(nbdim):petab_child(nbdim)) :: tabout
+C
+C Local variables
+ REAL, DIMENSION(pttab_child(nbdim-5):petab_child(nbdim-5),
+ & pttab_child(nbdim-4):petab_child(nbdim-4),
+ & pttab_child(nbdim-3):petab_child(nbdim-3),
+ & pttab_child(nbdim-2):petab_child(nbdim-2),
+ & pttab_child(nbdim-1):petab_child(nbdim-1),
+ & indmin(nbdim):indmax(nbdim)) :: tabtemp
+ INTEGER i,j,k,l,m,n
+ INTEGER :: coeffraf
+C
+C
+C
+ do n = indmin(nbdim),indmax(nbdim)
+C
+ Call Agrif_Interp_5D_recursive(TypeInterp(1:5),
+ & tabin(indmin(nbdim-5):indmax(nbdim-5),
+ & indmin(nbdim-4):indmax(nbdim-4),
+ & indmin(nbdim-3):indmax(nbdim-3),
+ & indmin(nbdim-2):indmax(nbdim-2),
+ & indmin(nbdim-1):indmax(nbdim-1),n),
+ & tabtemp(pttab_child(nbdim-5):petab_child(nbdim-5),
+ & pttab_child(nbdim-4):petab_child(nbdim-4),
+ & pttab_child(nbdim-3):petab_child(nbdim-3),
+ & pttab_child(nbdim-2):petab_child(nbdim-2),
+ & pttab_child(nbdim-1):petab_child(nbdim-1),n),
+ & indmin(1:nbdim-1),indmax(1:nbdim-1),
+ & pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
+ & s_child(1:nbdim-1),s_parent(1:nbdim-1),
+ & ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
+C
+ enddo
+
+ coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
+C
+ do m = pttab_child(nbdim-1),petab_child(nbdim-1)
+ do l = pttab_child(nbdim-2),petab_child(nbdim-2)
+C
+ do k = pttab_child(nbdim-3),petab_child(nbdim-3)
+C
+ do j = pttab_child(nbdim-4),petab_child(nbdim-4)
+C
+ do i = pttab_child(nbdim-5),petab_child(nbdim-5)
+C
+ Call Agrif_InterpBase(TypeInterp(6),
+ & tabtemp(i,j,k,l,m,indmin(nbdim):indmax(nbdim)),
+ & tabout(i,j,k,l,m,
+ & pttab_child(nbdim):petab_child(nbdim)),
+ & indmin(nbdim),indmax(nbdim),
+ & pttab_child(nbdim),petab_child(nbdim),
+ & s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),coeffraf)
+C
+ enddo
+C
+ enddo
+C
+ enddo
+C
+ enddo
+ enddo
+C
+C
+ Return
+C
+C
+ End Subroutine Agrif_Interp_6D_recursive
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_InterpBase
+C **************************************************************************
+C
+ Subroutine Agrif_InterpBase(TypeInterp,
+ & parenttab,childtab,
+ & indmin,indmax,pttab_child,petab_child,
+ & s_parent,s_child,ds_parent,ds_child,
+ & coeffraf)
+C
+CCC Description:
+CCC Subroutine calling the interpolation method chosen by the user (linear,
+CCC lagrange or spline).
+C
+C Declarations:
+C
+
+C
+ INTEGER :: TypeInterp
+ INTEGER :: indmin,indmax
+ INTEGER :: pttab_child,petab_child
+ REAL,INTENT(IN),DIMENSION(indmin:indmax) :: parenttab
+ REAL,INTENT(OUT),DIMENSION(pttab_child:petab_child) :: childtab
+ REAL :: s_parent,s_child,ds_parent,ds_child
+ INTEGER :: coeffraf
+C
+C
+ IF ((indmin == indmax).AND.(pttab_child == petab_child)) THEN
+ childtab(pttab_child) = parenttab(indmin)
+ ELSEIF (TYPEinterp .EQ. AGRIF_LINEAR) then
+C
+C Linear interpolation
+
+ Call linear1D
+ & (parenttab,childtab,
+ & indmax-indmin+1,petab_child-pttab_child+1,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+ elseif ( TYPEinterp .EQ. AGRIF_PPM ) then
+
+ Call ppm1D
+ & (parenttab,childtab,
+ & indmax-indmin+1,petab_child-pttab_child+1,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+
+ elseif (TYPEinterp .EQ. AGRIF_LAGRANGE) then
+C
+C Lagrange interpolation
+ Call lagrange1D
+ & (parenttab,childtab,
+ & indmax-indmin+1,petab_child-pttab_child+1,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+ elseif (TYPEinterp .EQ. AGRIF_ENO) then
+C
+C Eno interpolation
+ Call eno1D
+ & (parenttab,childtab,
+ & indmax-indmin+1,petab_child-pttab_child+1,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+ elseif (TYPEinterp .EQ. AGRIF_WENO) then
+C
+C Eno interpolation
+ Call weno1D
+ & (parenttab,childtab,
+ & indmax-indmin+1,petab_child-pttab_child+1,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+ Else if (TYPEinterp .EQ. AGRIF_LINEARCONSERV) then
+C
+C Linear conservative interpolation
+
+ Call linear1Dconserv
+ & (parenttab,childtab,
+ & indmax-indmin+1,petab_child-pttab_child+1,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+ Else if (TYPEinterp .EQ. AGRIF_LINEARCONSERVLIM) then
+C
+C Linear conservative interpolation
+
+ Call linear1Dconservlim
+ & (parenttab,childtab,
+ & indmax-indmin+1,petab_child-pttab_child+1,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+ elseif (TYPEinterp .EQ. AGRIF_CONSTANT) then
+C
+ Call constant1D
+ & (parenttab,childtab,
+ & indmax-indmin+1,petab_child-pttab_child+1,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+ endif
+C
+C
+ End Subroutine Agrif_InterpBase
+C
+
+ Subroutine Agrif_Compute_nbdim_interp(s_parent,s_child,
+ & ds_parent,ds_child,coeffraf,locind_child_left)
+ real :: s_parent,s_child,ds_parent,ds_child
+ integer :: coeffraf,locind_child_left
+
+ coeffraf = nint(ds_parent/ds_child)
+ locind_child_left = 1 + agrif_int((s_child-s_parent)/ds_parent)
+ End Subroutine Agrif_Compute_nbdim_interp
+C
+
+ Subroutine Agrif_Find_list_interp(list_interp,pttab,petab,
+ & pttab_Child,pttab_Parent,nbdim,
+ & indmin,indmax,indminglob,
+ & indmaxglob,indminglob2,indmaxglob2,parentarray,
+ & pttruetab,cetruetab,member,memberin,
+ & find_list_interp
+#if defined key_mpp_mpi
+ & ,tab4t,memberinall,sendtoproc1,recvfromproc1
+#endif
+ & )
+ TYPE(Agrif_List_Interp_Loc), Pointer :: list_interp
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(nbdim) :: pttab,petab,pttab_Child,pttab_Parent
+ LOGICAL :: find_list_interp
+ Type(Agrif_List_Interp_loc), Pointer :: parcours
+ INTEGER,DIMENSION(nbdim) :: indmin,indmax
+ INTEGER,DIMENSION(nbdim) :: indminglob,indmaxglob
+ INTEGER,DIMENSION(nbdim) :: pttruetab,cetruetab
+ INTEGER,DIMENSION(nbdim) :: indminglob2,indmaxglob2
+ INTEGER,DIMENSION(nbdim,2,2) :: parentarray
+ LOGICAL :: member, memberin
+ INTEGER :: i
+#ifdef key_mpp_mpi
+C
+ INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab4t
+ LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall
+ LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc1,recvfromproc1
+#endif
+
+ find_list_interp = .FALSE.
+
+ parcours => list_interp
+ Find_loop : Do While (associated(parcours))
+ Do i=1,nbdim
+ IF ((pttab(i) /= parcours%interp_loc%pttab(i)).OR.
+ & (petab(i) /= parcours%interp_loc%petab(i)).OR.
+ & (pttab_child(i) /= parcours%interp_loc%pttab_child(i)).OR.
+ & (pttab_parent(i) /= parcours%interp_loc%pttab_parent(i)))
+ & THEN
+ parcours=>parcours%suiv
+ Cycle Find_loop
+ ENDIF
+ EndDo
+
+ indmin = parcours%interp_loc%indmin(1:nbdim)
+ indmax = parcours%interp_loc%indmax(1:nbdim)
+
+ pttruetab = parcours%interp_loc%pttruetab(1:nbdim)
+ cetruetab = parcours%interp_loc%cetruetab(1:nbdim)
+
+#if !defined key_mpp_mpi
+ indminglob = parcours%interp_loc%indminglob(1:nbdim)
+ indmaxglob = parcours%interp_loc%indmaxglob(1:nbdim)
+#else
+ indminglob2 = parcours%interp_loc%indminglob2(1:nbdim)
+ indmaxglob2 = parcours%interp_loc%indmaxglob2(1:nbdim)
+ parentarray = parcours%interp_loc%parentarray(1:nbdim,:,:)
+ member = parcours%interp_loc%member
+ tab4t = parcours%interp_loc%tab4t(1:nbdim,0:Agrif_Nbprocs-1,1:8)
+ memberinall = parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1)
+ sendtoproc1 = parcours%interp_loc%sendtoproc1(0:Agrif_Nbprocs-1)
+ recvfromproc1 =
+ & parcours%interp_loc%recvfromproc1(0:Agrif_Nbprocs-1)
+#endif
+ memberin = parcours%interp_loc%memberin
+ find_list_interp = .TRUE.
+ Exit Find_loop
+ End Do Find_loop
+
+ End Subroutine Agrif_Find_list_interp
+
+ Subroutine Agrif_AddTo_list_interp(list_interp,pttab,petab,
+ & pttab_Child,pttab_Parent,indmin,indmax,
+ & indminglob,indmaxglob,
+ & indminglob2,indmaxglob2,
+ & parentarray,pttruetab,cetruetab,
+ & member,memberin,nbdim
+#if defined key_mpp_mpi
+ & ,tab4t,memberinall,sendtoproc1,recvfromproc1
+#endif
+ & )
+
+ TYPE(Agrif_List_Interp_Loc), Pointer :: list_interp
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(nbdim) :: pttab,petab,pttab_Child,pttab_Parent
+ INTEGER,DIMENSION(nbdim) :: indmin,indmax
+ INTEGER,DIMENSION(nbdim) :: indminglob,indmaxglob
+ INTEGER,DIMENSION(nbdim) :: indminglob2,indmaxglob2
+ INTEGER,DIMENSION(nbdim) :: pttruetab,cetruetab
+ INTEGER,DIMENSION(nbdim,2,2) :: parentarray
+ LOGICAL :: member, memberin
+#ifdef key_mpp_mpi
+C
+ INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab4t
+ LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: memberinall
+ LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc1
+ LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: recvfromproc1
+#endif
+ Type(Agrif_List_Interp_loc), Pointer :: parcours
+
+ Allocate(parcours)
+ Allocate(parcours%interp_loc)
+
+ parcours%interp_loc%pttab(1:nbdim) = pttab(1:nbdim)
+ parcours%interp_loc%petab(1:nbdim) = petab(1:nbdim)
+ parcours%interp_loc%pttab_child(1:nbdim) = pttab_child(1:nbdim)
+ parcours%interp_loc%pttab_parent(1:nbdim) = pttab_parent(1:nbdim)
+
+
+ parcours%interp_loc%indmin(1:nbdim) = indmin(1:nbdim)
+ parcours%interp_loc%indmax(1:nbdim) = indmax(1:nbdim)
+
+ parcours%interp_loc%memberin = memberin
+#if !defined key_mpp_mpi
+ parcours%interp_loc%indminglob(1:nbdim) = indminglob(1:nbdim)
+ parcours%interp_loc%indmaxglob(1:nbdim) = indmaxglob(1:nbdim)
+#else
+ parcours%interp_loc%indminglob2(1:nbdim) = indminglob2(1:nbdim)
+ parcours%interp_loc%indmaxglob2(1:nbdim) = indmaxglob2(1:nbdim)
+ parcours%interp_loc%parentarray(1:nbdim,:,:)
+ & = parentarray(1:nbdim,:,:)
+ parcours%interp_loc%member = member
+ Allocate(parcours%interp_loc%tab4t(nbdim,0:Agrif_Nbprocs-1,8))
+ Allocate(parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1))
+ Allocate(parcours%interp_loc%sendtoproc1(0:Agrif_Nbprocs-1))
+ Allocate(parcours%interp_loc%recvfromproc1(0:Agrif_Nbprocs-1))
+ parcours%interp_loc%tab4t=tab4t
+ parcours%interp_loc%memberinall=memberinall
+ parcours%interp_loc%sendtoproc1=sendtoproc1
+ parcours%interp_loc%recvfromproc1=recvfromproc1
+#endif
+
+ parcours%interp_loc%pttruetab(1:nbdim) = pttruetab(1:nbdim)
+ parcours%interp_loc%cetruetab(1:nbdim) = cetruetab(1:nbdim)
+
+ parcours%suiv => list_interp
+
+ list_interp => parcours
+ End Subroutine Agrif_Addto_list_interp
+
+ End Module Agrif_Interpolation
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modinterpbasic.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modinterpbasic.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modinterpbasic.F (revision 8155)
@@ -0,0 +1,1706 @@
+!
+! $Id: modinterpbasic.F 2715 2011-03-30 15:58:35Z rblod $
+!
+C AGRIF (Adaptive Grid Refinement In Fortran)
+C
+C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
+C Christophe Vouland (Christophe.Vouland@imag.fr)
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.
+C
+C
+C
+CCC Module Agrif_Interpbasic
+C
+ Module Agrif_Interpbasic
+C
+CCC Description:
+CCC Module containing different procedures of interpolation (linear,lagrange,
+CCC spline,...) used in the Agrif_Interpolation module.
+C
+C Modules used:
+ USE Agrif_types
+C
+ IMPLICIT NONE
+C
+ Real,Dimension(Agrif_MaxRaff) :: tabdiff2, tabdiff3
+ Real,Dimension(5,Agrif_MaxRaff,3) :: tabppm
+ Real,Dimension(:),Allocatable::tabtest4
+ Integer, Dimension(:,:), Allocatable :: indparent
+ Integer, Dimension(:,:), Allocatable ::
+ & indparentppm,indchildppm
+ Integer, Dimension(:), Allocatable ::
+ & indparentppm_1d,indchildppm_1d
+ Real, Dimension(:,:),Allocatable :: coeffparent
+
+ CONTAINS
+C Define procedures contained in this module
+C
+C **************************************************************************
+CCC Subroutine Linear1d
+C **************************************************************************
+C
+ Subroutine Linear1d(x,y,np,nc,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+CCC Description:
+CCC Subroutine to do a linear 1D interpolation on a child grid (vector y) from
+CCC its parent grid (vector x).
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: np,nc
+ REAL,INTENT(IN), DIMENSION(np) :: x
+ REAL,INTENT(OUT), DIMENSION(nc) :: y
+ REAL :: s_parent,s_child,ds_parent,ds_child
+C
+C Local scalars
+ INTEGER :: i,coeffraf,locind_parent_left
+ REAL :: ypos,globind_parent_left,globind_parent_right
+ REAL :: invds, invds2
+ REAL :: ypos2,diff
+C
+C
+
+ coeffraf = nint(ds_parent/ds_child)
+C
+ if (coeffraf == 1) then
+C
+ locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent)
+C
+ y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1)
+C
+ return
+C
+ endif
+C
+ ypos = s_child
+
+ locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
+
+ globind_parent_left = s_parent
+ & + (locind_parent_left - 1)*ds_parent
+
+ globind_parent_right = globind_parent_left + ds_parent
+
+C
+ invds = 1./ds_parent
+ invds2 = ds_child/ds_parent
+
+ ypos2 = ypos*invds
+ globind_parent_right=globind_parent_right*invds
+
+ do i = 1,nc-1
+C
+ if (ypos2 > globind_parent_right) then
+ locind_parent_left = locind_parent_left + 1.
+ globind_parent_right = globind_parent_right + 1.
+ ypos2 = ypos*invds+(i-1)*invds2
+ endif
+
+ diff=(globind_parent_right - ypos2)
+ y(i) = (diff*x(locind_parent_left)
+ & + (1.-diff)*x(locind_parent_left+1))
+C
+ ypos2 = ypos2 + invds2
+C
+ enddo
+C
+ ypos = s_child + (nc-1)*ds_child
+ locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
+C
+ if (locind_parent_left == np) then
+C
+ y(nc) = x(np)
+C
+ else
+C
+ globind_parent_left = s_parent
+ & + (locind_parent_left - 1)*ds_parent
+C
+ y(nc) = ((globind_parent_left + ds_parent - ypos)
+ & *x(locind_parent_left)
+ & + (ypos - globind_parent_left)
+ & *x(locind_parent_left+1))*invds
+C
+ endif
+C
+ Return
+C
+C
+ End Subroutine Linear1d
+
+ Subroutine Linear1dprecompute2d(np2, np,nc,
+ & s_parent,s_child,ds_parent,ds_child,dir)
+C
+CCC Description:
+CCC Subroutine to compute 2D coefficient and index for a linear 1D interpolation
+CCC on a child grid (vector y) from its parent grid (vector x).
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: np,nc,np2,dir
+ REAL :: s_parent,s_child,ds_parent,ds_child
+C
+C Local scalars
+ INTEGER :: i,j,coeffraf,locind_parent_left,inc,inc1,inc2,toto
+ Integer, Dimension(:,:), Allocatable :: indparent_tmp
+ Real, Dimension(:,:), Allocatable :: coeffparent_tmp
+ REAL :: ypos,globind_parent_left,globind_parent_right
+ REAL :: invds, invds2, invds3
+ REAL :: ypos2,diff
+C
+C
+
+ coeffraf = nint(ds_parent/ds_child)
+C
+ ypos = s_child
+
+ locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
+
+ globind_parent_left = s_parent
+ & + (locind_parent_left - 1)*ds_parent
+
+ globind_parent_right = globind_parent_left + ds_parent
+
+C
+ invds = 1./ds_parent
+ invds2 = ds_child/ds_parent
+ invds3 = 0.5/real(coeffraf)
+
+ ypos2 = ypos*invds
+ globind_parent_right=globind_parent_right*invds
+
+ if (.not.allocated(indparent)) then
+ allocate(indparent(nc*np2,3),coeffparent(nc*np2,3))
+ else
+ if (size(indparent,1) globind_parent_right) then
+ locind_parent_left = locind_parent_left + 1
+ globind_parent_right = globind_parent_right + 1.
+ ypos2 = ypos*invds+(i-1)*invds2
+ endif
+
+ diff=(globind_parent_right - ypos2)
+ diff = invds3*nint(2*coeffraf*diff)
+ indparent(i,dir) = locind_parent_left
+
+ coeffparent(i,dir) = diff
+
+ ypos2 = ypos2 + invds2
+C
+ enddo
+C
+ ypos = s_child + (nc-1)*ds_child
+ locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
+
+ if (locind_parent_left == np) then
+ indparent(nc,dir) = locind_parent_left-1
+ coeffparent(nc,dir) = 0.
+ else
+C
+ globind_parent_left = s_parent
+ & + (locind_parent_left - 1)*ds_parent
+C
+ indparent(nc,dir) = locind_parent_left
+ diff = (globind_parent_left + ds_parent - ypos)
+ & * invds
+ diff = invds3*nint(2*coeffraf*diff)
+ coeffparent(nc,dir) = diff
+ endif
+
+ do i=2, np2
+ inc = i*nc
+ inc1 = (i-1)*nc
+ inc2 = (i-2)*nc
+!CDIR ALTCODE
+ indparent(1+inc1:inc,dir) = indparent(1+inc2:inc1,dir)+np
+!CDIR ALTCODE
+ coeffparent(1+inc1:inc,dir) =coeffparent(1:nc,dir)
+ enddo
+
+ Return
+C
+C
+ End Subroutine Linear1dprecompute2d
+
+
+
+ Subroutine Linear1dprecompute(np,nc,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+CCC Description:
+CCC Subroutine to compute 1D coefficient and index for a linear 1D interpolation
+CCC on a child grid (vector y) from its parent grid (vector x).
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: np,nc
+ REAL :: s_parent,s_child,ds_parent,ds_child
+C
+C Local scalars
+ INTEGER :: i,coeffraf,locind_parent_left
+ REAL :: ypos,globind_parent_left,globind_parent_right
+ REAL :: invds, invds2, invds3
+ REAL :: ypos2,diff
+C
+C
+
+ coeffraf = nint(ds_parent/ds_child)
+C
+ if (coeffraf == 1) then
+C
+ return
+C
+ endif
+C
+ ypos = s_child
+
+ locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
+
+ globind_parent_left = s_parent
+ & + (locind_parent_left - 1)*ds_parent
+
+ globind_parent_right = globind_parent_left + ds_parent
+
+C
+ invds = 1./ds_parent
+ invds2 = ds_child/ds_parent
+ invds3 = 0.5/real(coeffraf)
+
+ ypos2 = ypos*invds
+ globind_parent_right=globind_parent_right*invds
+
+ if (.not.allocated(indparent)) then
+ allocate(indparent(nc,1),coeffparent(nc,1))
+ else
+ if (size(indparent) globind_parent_right) then
+ locind_parent_left = locind_parent_left + 1
+ globind_parent_right = globind_parent_right + 1.
+ ypos2 = ypos*invds+(i-1)*invds2
+ endif
+
+ diff=(globind_parent_right - ypos2)
+
+ diff = invds3*nint(2*coeffraf*diff)
+
+ indparent(i,1) = locind_parent_left
+
+ coeffparent(i,1) = diff
+ ypos2 = ypos2 + invds2
+C
+ enddo
+C
+ ypos = s_child + (nc-1)*ds_child
+ locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
+
+ if (locind_parent_left == np) then
+ indparent(nc,1) = locind_parent_left-1
+ coeffparent(nc,1) = 0.
+ else
+C
+ globind_parent_left = s_parent
+ & + (locind_parent_left - 1)*ds_parent
+C
+ indparent(nc,1) = locind_parent_left
+
+ diff = (globind_parent_left + ds_parent - ypos)
+ & * invds
+ diff = invds3*nint(2*coeffraf*diff)
+ coeffparent(nc,1) = diff
+ endif
+C
+ Return
+C
+C
+ End Subroutine Linear1dprecompute
+
+ Subroutine Linear1daftercompute(x,y,np,nc,
+ & s_parent,s_child,ds_parent,ds_child,dir)
+C
+CCC Description:
+CCC Subroutine to do a linear 1D interpolation on a child grid (vector y) from
+CCC its parent grid (vector x) using precomputed coefficient and index.
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: np,nc,dir
+ REAL,INTENT(IN), DIMENSION(np) :: x
+ REAL,INTENT(OUT), DIMENSION(nc) :: y
+ REAL :: s_parent,s_child,ds_parent,ds_child
+C
+C Local scalars
+ INTEGER :: i,coeffraf,locind_parent_left
+ REAL :: ypos,globind_parent_left,globind_parent_right
+ REAL :: invds, invds2
+ REAL :: ypos2,diff
+C
+C
+
+!CDIR ALTCODE
+!CDIR NODEP
+ do i = 1,nc
+C
+ y(i)=coeffparent(i,dir)*x(MAX(indparent(i,dir),1))+
+ & (1.-coeffparent(i,dir))*x(indparent(i,dir)+1)
+C
+ enddo
+C
+ Return
+C
+C
+ End Subroutine Linear1daftercompute
+
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Lagrange1d
+C **************************************************************************
+C
+ Subroutine Lagrange1d(x,y,np,nc,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+CCC Description:
+CCC Subroutine to do a lagrange 1D interpolation on a child grid (vector y)
+CCC from its parent grid (vector x).
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: np,nc
+ REAL,INTENT(IN), DIMENSION(np) :: x
+ REAL,INTENT(OUT), DIMENSION(nc) :: y
+ REAL :: s_parent,s_child,ds_parent,ds_child
+C
+C Local scalars
+ INTEGER :: i,coeffraf,locind_parent_left
+ REAL :: ypos,globind_parent_left
+ REAL :: X1,X2,X3
+ real :: deltax,invdsparent
+ real t1,t2,t3,t4,t5,t6,t7,t8
+C
+C
+ if (np <= 2) then
+C
+ Call Linear1D(x,y,np,nc,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+ Return
+C
+ endif
+C
+ coeffraf = nint(ds_parent/ds_child)
+C
+ if (coeffraf == 1) then
+C
+ locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent)
+C
+ y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1)
+C
+ return
+C
+ endif
+
+ invdsparent=1./ds_parent
+C
+ ypos = s_child
+C
+ do i = 1,nc
+C
+ locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
+C
+
+ globind_parent_left = s_parent
+ & + (locind_parent_left - 1)*ds_parent
+
+C deltax = invdsparent*(ypos-globind_parent_left)
+ deltax = nint(coeffraf*deltax)/real(coeffraf)
+
+ ypos = ypos + ds_child
+ if (abs(deltax).LE.0.0001) then
+ y(i)=x(locind_parent_left)
+
+ cycle
+ endif
+C
+C
+ t2 = deltax - 2.
+ t3 = deltax - 1.
+ t4 = deltax + 1.
+
+ t5 = -(1./6.)*deltax*t2*t3
+ t6 = 0.5*t2*t3*t4
+ t7 = -0.5*deltax*t2*t4
+ t8 = (1./6.)*deltax*t3*t4
+
+ y(i)=t5*x(locind_parent_left-1)+t6*x(locind_parent_left)
+ & +t7*x(locind_parent_left+1)+t8*x(locind_parent_left+2)
+C
+C
+ enddo
+C
+ return
+C
+C
+ End Subroutine Lagrange1d
+C
+C
+C **************************************************************************
+CCC Subroutine Constant1d
+C **************************************************************************
+C
+ Subroutine constant1d(x,y,np,nc,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+CCC Description:
+CCC Subroutine to do a linear 1D interpolation on a child grid (vector y) from
+CCC its parent grid (vector x).
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: np,nc
+ REAL,INTENT(IN), DIMENSION(np) :: x
+ REAL,INTENT(OUT), DIMENSION(nc) :: y
+ REAL :: s_parent,s_child,ds_parent,ds_child
+C
+C Local scalars
+ INTEGER :: i,coeffraf,locind_parent
+ REAL :: ypos
+C
+C
+
+ coeffraf = nint(ds_parent/ds_child)
+C
+ if (coeffraf == 1) then
+C
+ locind_parent = 1 + nint((s_child - s_parent)/ds_parent)
+C
+ y(1:nc) = x(locind_parent:locind_parent+nc-1)
+C
+ return
+C
+ endif
+C
+ ypos = s_child
+C
+ do i = 1,nc
+C
+ locind_parent = 1 + nint((ypos - s_parent)/ds_parent)
+C
+ y(i) = x(locind_parent)
+C
+ ypos = ypos + ds_child
+C
+ enddo
+C
+ Return
+C
+C
+ End Subroutine constant1d
+C
+C **************************************************************************
+CCC Subroutine Linear1dconserv
+C **************************************************************************
+C
+ Subroutine Linear1dconserv(x,y,np,nc,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+CCC Description:
+CCC Subroutine to do a linear 1D interpolation on a child grid (vector y) from
+CCC its parent grid (vector x).
+C
+CC Method:
+C
+C Declarations:
+C
+ Implicit none
+C
+C Arguments
+ Integer :: np,nc
+ Real, Dimension(np) :: x
+ Real, Dimension(nc) :: y
+ Real, Dimension(:),Allocatable :: ytemp
+ Real :: s_parent,s_child,ds_parent,ds_child
+C
+C Local scalars
+ Integer :: i,coeffraf,locind_parent_left,locind_parent_last
+ Real :: ypos
+ integer :: i1,i2,ii
+ real :: xpmin,xpmax,slope
+ INTEGER :: diffmod
+ REAL :: xdiffmod
+
+C
+C
+
+ coeffraf = nint(ds_parent/ds_child)
+C
+ If (coeffraf == 1) Then
+C
+ locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent)
+C
+ y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1)
+C
+ return
+C
+ End If
+C
+ diffmod = 0
+ IF (mod(coeffraf,2) == 0) diffmod = 1
+
+ xdiffmod = real(diffmod)/2.
+
+ allocate(ytemp(-2*coeffraf:nc+2*coeffraf))
+C
+ ypos = s_child
+C
+ locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
+
+ locind_parent_last = 1 +
+ & agrif_ceiling((ypos +(nc - 1) *ds_child - s_parent)/ds_parent)
+
+ xpmin = s_parent + (locind_parent_left-1)*ds_parent
+ xpmax = s_parent + (locind_parent_last-1)*ds_parent
+
+ i1 = 1+agrif_int((xpmin-s_child)/ds_child)
+ i2 = 1+agrif_int((xpmax-s_child)/ds_child)
+
+ i = i1
+
+ if (locind_parent_left == 1) then
+ slope=
+ & (x(locind_parent_left+1)-x(locind_parent_left))/(coeffraf)
+ else
+ slope=
+ & (x(locind_parent_left+1)-x(locind_parent_left-1))/(2.*coeffraf)
+ endif
+
+ do ii=i-coeffraf/2+diffmod,i+coeffraf/2
+ ytemp(ii) = x(locind_parent_left)+(ii-i-xdiffmod/2.)*slope
+ enddo
+
+ locind_parent_left = locind_parent_left + 1
+
+ do i=i1 + coeffraf, i2 - coeffraf,coeffraf
+ slope=
+ & (x(locind_parent_left+1)-x(locind_parent_left-1))/(2.*coeffraf)
+ do ii=i-coeffraf/2+diffmod,i+coeffraf/2
+ ytemp(ii) = x(locind_parent_left)+(ii-i-xdiffmod/2.)*slope
+ enddo
+ locind_parent_left = locind_parent_left + 1
+ enddo
+
+ i = i2
+
+ if (locind_parent_left == np) then
+ slope=
+ & (x(locind_parent_left)-x(locind_parent_left-1))/(coeffraf)
+ else
+ slope=
+ & (x(locind_parent_left+1)-x(locind_parent_left-1))/(2.*coeffraf)
+ endif
+
+ do ii=i-coeffraf/2+diffmod,nc
+ ytemp(ii) = x(locind_parent_left)+(ii-i-xdiffmod/2.)*slope
+ enddo
+C
+ y(1:nc)=ytemp(1:nc)
+C
+ deallocate(ytemp)
+ Return
+C
+ End Subroutine Linear1dconserv
+
+C
+C **************************************************************************
+CCC Subroutine Linear1dconservlim
+C **************************************************************************
+C
+ Subroutine Linear1dconservlim(x,y,np,nc,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+CCC Description:
+CCC Subroutine to do a linear 1D interpolation on a child grid (vector y) from
+CCC its parent grid (vector x).
+C
+CC Method:
+C
+C Declarations:
+C
+ Implicit none
+C
+C Arguments
+ Integer :: np,nc
+ Real, Dimension(np) :: x
+ Real, Dimension(nc) :: y
+ Real, Dimension(:),Allocatable :: ytemp
+ Real :: s_parent,s_child,ds_parent,ds_child
+C
+C Local scalars
+ Integer :: i,coeffraf,locind_parent_left,locind_parent_last
+ Real :: ypos
+ integer :: i1,i2,ii
+ real :: xpmin,xpmax,slope
+ INTEGER :: diffmod
+ real :: xdiffmod
+C
+C
+
+ coeffraf = nint(ds_parent/ds_child)
+C
+ If (coeffraf == 1) Then
+C
+ locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent)
+C
+ y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1)
+C
+ return
+C
+ End If
+C
+ IF (coeffraf .NE.3) THEN
+ print *,'LINEARCONSERVLIM not ready for refinement ratio = ',
+ & coeffraf
+ stop
+ ENDIF
+
+ diffmod = 0
+ IF (mod(coeffraf,2) == 0) diffmod = 1
+
+ xdiffmod = real(diffmod)/2.
+
+ allocate(ytemp(-2*coeffraf:nc+2*coeffraf))
+C
+ ypos = s_child
+C
+ locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
+
+ locind_parent_last = 1 +
+ & agrif_ceiling((ypos +(nc - 1) *ds_child - s_parent)/ds_parent)
+
+ xpmin = s_parent + (locind_parent_left-1)*ds_parent
+ xpmax = s_parent + (locind_parent_last-1)*ds_parent
+
+ i1 = 1+agrif_int((xpmin-s_child)/ds_child)
+ i2 = 1+agrif_int((xpmax-s_child)/ds_child)
+
+ i = i1
+
+ if (locind_parent_left == 1) then
+ slope=0.
+ else
+ slope = vanleer(x(locind_parent_left-1:locind_parent_left+1))
+ slope = slope / coeffraf
+ endif
+
+ do ii=i-coeffraf/2+diffmod,i+coeffraf/2
+ ytemp(ii) = x(locind_parent_left)+(ii-i-xdiffmod/2.)*slope
+ enddo
+
+ locind_parent_left = locind_parent_left + 1
+
+ do i=i1 + coeffraf, i2 - coeffraf,coeffraf
+ slope = vanleer(x(locind_parent_left-1:locind_parent_left+1))
+ slope = slope / coeffraf
+
+ do ii=i-coeffraf/2+diffmod,i+coeffraf/2
+ ytemp(ii) = x(locind_parent_left)+(ii-i-xdiffmod/2.)*slope
+ enddo
+ locind_parent_left = locind_parent_left + 1
+ enddo
+
+ i = i2
+
+ if (locind_parent_left == np) then
+ slope=0.
+ else
+ slope = vanleer(x(locind_parent_left-1:locind_parent_left+1))
+ slope = slope / coeffraf
+ endif
+
+ do ii=i-coeffraf/2+diffmod,nc
+ ytemp(ii) = x(locind_parent_left)+(ii-i-xdiffmod/2.)*slope
+ enddo
+C
+ y(1:nc)=ytemp(1:nc)
+C
+ deallocate(ytemp)
+ Return
+C
+ End Subroutine Linear1dconservlim
+C
+
+C **************************************************************************
+CCC Subroutine ppm1d
+C **************************************************************************
+C
+ Subroutine ppm1d(x,y,np,nc,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+CCC Description:
+CCC Subroutine to do a 1D interpolation and apply monotonicity constraints
+CCC using piecewise parabolic method
+CCC on a child grid (vector y) from its parent grid (vector x).
+CC Method:
+C
+C Declarations:
+C
+ Implicit none
+C
+C Arguments
+ Integer :: np,nc
+ Real, INTENT(IN),Dimension(np) :: x
+ Real, INTENT(OUT),Dimension(nc) :: y
+C Real, Dimension(:),Allocatable :: ytemp
+ Real :: s_parent,s_child,ds_parent,ds_child
+C
+C Local scalars
+ Integer :: i,coeffraf,locind_parent_left,locind_parent_last
+ Integer :: iparent,ipos,pos,nmin,nmax
+ Real :: ypos
+ integer :: i1,jj
+ Real :: xpmin,a
+C
+ Real :: xrmin,xrmax,am3,s2,s1
+ Real, Dimension(np) :: xl,delta,a6,slope
+C Real, Dimension(:),Allocatable :: diff,diff2,diff3
+ INTEGER :: diffmod
+ REAL :: invcoeffraf
+C
+ coeffraf = nint(ds_parent/ds_child)
+C
+ If (coeffraf == 1) Then
+ locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent)
+!CDIR ALTCODE
+!CDIR SHORTLOOP
+ y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1)
+ return
+ End If
+ invcoeffraf = ds_child/ds_parent
+C
+
+ IF( .NOT. allocated(tabtest4) ) THEN
+ Allocate(tabtest4(-2*coeffraf:nc+2*coeffraf))
+ ELSE
+ IF (size(tabtest4) .LT. nc+4*coeffraf+1)THEN
+ deallocate( tabtest4 )
+ Allocate(tabtest4(-2*coeffraf:nc+2*coeffraf))
+ ENDIF
+ ENDIF
+
+ ypos = s_child
+C
+ locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
+ locind_parent_last = 1 +
+ & agrif_ceiling((ypos +(nc - 1)
+ & *ds_child - s_parent)/ds_parent)
+C
+ xpmin = s_parent + (locind_parent_left-1)*ds_parent
+ i1 = 1+agrif_int((xpmin-s_child)/ds_child)
+C
+C
+
+!CDIR NOVECTOR
+ Do i=1,coeffraf
+ tabdiff2(i)=(real(i)-0.5)*invcoeffraf
+ EndDo
+
+ a = invcoeffraf**2
+ tabdiff3(1) = (1./3.)*a
+ a=2.*a
+!CDIR NOVECTOR
+ Do i=2,coeffraf
+ tabdiff3(i) = tabdiff3(i-1)+(real(i)-1)*a
+ EndDo
+C
+ if( locind_parent_last+2 <= np ) then
+ nmax = locind_parent_last+2
+ else if( locind_parent_last+1 <= np ) then
+ nmax = locind_parent_last+1
+ else
+ nmax = locind_parent_last
+ endif
+C
+ if(locind_parent_left-1 >= 1) then
+ nmin = locind_parent_left-1
+ else
+ nmin = locind_parent_left
+ endif
+C
+C
+!CDIR ALTCODE
+!CDIR SHORTLOOP
+ Do i = nmin,nmax
+ slope(i) = x(i) - x(i-1)
+ Enddo
+
+!CDIR ALTCODE
+!CDIR SHORTLOOP
+ Do i = nmin+1,nmax-1
+ xl(i)= 0.5*(x(i-1)+x(i))
+ & -0.08333333333333*(slope(i+1)-slope(i-1))
+ Enddo
+C
+C apply parabolic monotonicity
+!CDIR ALTCODE
+!CDIR SHORTLOOP
+ Do i = locind_parent_left,locind_parent_last
+ delta(i) = xl(i+1) - xl(i)
+ a6(i) = 6.*x(i)-3.*(xl(i) +xl(i+1))
+C
+ End do
+C
+ diffmod = 0
+ IF (mod(coeffraf,2) == 0) diffmod = 1
+C
+ ipos = i1
+C
+ Do iparent = locind_parent_left,locind_parent_last
+ pos=1
+!CDIR ALTCODE
+!CDIR SHORTLOOP
+ Do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2
+C
+ tabtest4(jj) = xl(iparent)
+ & + tabdiff2(pos) * (delta(iparent)+a6(iparent))
+ & - tabdiff3(pos) * a6(iparent)
+ pos = pos+1
+ End do
+ ipos = ipos + coeffraf
+C
+ End do
+C
+C
+!CDIR ALTCODE
+!CDIR SHORTLOOP
+ y(1:nc)=tabtest4(1:nc)
+
+ Return
+ End Subroutine ppm1d
+
+
+ Subroutine ppm1dprecompute2d(np2,np,nc,
+ & s_parent,s_child,ds_parent,ds_child,dir)
+C
+CCC Description:
+CCC Subroutine to compute 2D coefficients and index for a 1D interpolation
+CCC using piecewise parabolic method
+CC Method:
+C
+C Declarations:
+C
+ Implicit none
+C
+C Arguments
+ Integer :: np2,np,nc,dir
+C Real, Dimension(:),Allocatable :: ytemp
+ Real :: s_parent,s_child,ds_parent,ds_child
+C
+C Local scalars
+ Integer, Dimension(:,:), Allocatable :: indparent_tmp
+ Integer, Dimension(:,:), Allocatable :: indchild_tmp
+ Integer :: i,coeffraf,locind_parent_left,locind_parent_last
+ Integer :: iparent,ipos,pos,nmin,nmax
+ Real :: ypos
+ integer :: i1,jj
+ Real :: xpmin,a
+C
+ Real :: xrmin,xrmax,am3,s2,s1
+ Real, Dimension(np) :: xl,delta,a6,slope
+ INTEGER :: diffmod
+ REAL :: invcoeffraf
+C
+ coeffraf = nint(ds_parent/ds_child)
+C
+ invcoeffraf = ds_child/ds_parent
+C
+
+ if (.not.allocated(indparentppm)) then
+ allocate(
+ & indparentppm(np2*nc,3),
+ & indchildppm(np2*nc,3)
+ & )
+ else
+ if (size(indparentppm,1) 0) then
+ etap = etap+1
+ else if (ak(k,i) < 0) then
+ etan = etan + 1
+ endif
+ enddo
+
+ do k=0,1
+ if (ak(k,i) == 0) then
+ Ck(k,i) = 1.
+ else if (ak(k,i) > 0) then
+ Ck(k,i) = 1./(etap * ak(k,i))
+ else
+ Ck(k,i) = -1./(etan * ak(k,i))
+ endif
+ enddo
+ enddo
+
+C
+ a = 0.
+ b = invcoeffraf
+ Do i=1,coeffraf
+ diff2(i) = 0.5*(b*b - a*a)
+ diff3(i) = (1./3.)*(b*b*b - a*a*a)
+ a = a + invcoeffraf
+ b = b + invcoeffraf
+ End do
+C
+ if( locind_parent_last+2 <= np ) then
+ nmax = locind_parent_last+2
+ elseif( locind_parent_last+1 <= np ) then
+ nmax = locind_parent_last+1
+ else
+ nmax = locind_parent_last
+ endif
+C
+ if(locind_parent_left-2 >= 1) then
+ nmin = locind_parent_left-2
+ elseif(locind_parent_left-1 >= 1) then
+ nmin = locind_parent_left-1
+ else
+ nmin = locind_parent_left
+ endif
+C
+ Do i = nmin+1,nmax
+ slope(i) = (x(i) - x(i-1))
+ Enddo
+ DO i=nmin+2,nmax
+ smooth(i) = 0.5*(slope(i)**2+slope(i-1)**2)
+ & +(slope(i)-slope(i-1))**2
+ enddo
+C
+ diffmod = 0
+ IF (mod(coeffraf,2) == 0) diffmod = 1
+C
+ ipos = i1
+C
+ Do iparent = locind_parent_left,locind_parent_last
+ pos=1
+
+ delta0=1./(epsilon+smooth(iparent ))**3
+ delta1=1./(epsilon+smooth(iparent+1))**3
+ delta2=1./(epsilon+smooth(iparent+2))**3
+
+ Do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2
+C
+ pos = pos+1
+ End do
+ ipos = ipos + coeffraf
+C
+ End do
+C
+C
+ y(1:nc)=ytemp(1:nc)
+ deallocate(ytemp)
+ deallocate(diff, diff2, diff3)
+
+ deallocate(ak,ck)
+
+ Return
+ End Subroutine weno1dnew
+
+C **************************************************************************
+CCC Subroutine weno1d
+C **************************************************************************
+C
+ Subroutine weno1d(x,y,np,nc,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+CCC Description:
+CCC Subroutine to do a 1D interpolation and apply monotonicity constraints
+CCC using piecewise parabolic method
+CCC on a child grid (vector y) from its parent grid (vector x).
+CC Method:
+C
+C Declarations:
+C
+ Implicit none
+C
+C Arguments
+ Integer :: np,nc
+ Real, Dimension(np) :: x
+ Real, Dimension(nc) :: y
+ Real, Dimension(:),Allocatable :: ytemp
+ Real :: s_parent,s_child,ds_parent,ds_child
+C
+C Local scalars
+ Integer :: i,coeffraf,locind_parent_left,locind_parent_last
+ Integer :: iparent,ipos,pos,nmin,nmax
+ Real :: ypos
+ integer :: i1,jj
+ Real :: xpmin,cavg,a,b
+C
+ Real :: xrmin,xrmax,am3,s2,s1
+ Real, Dimension(np) :: xr,xl,delta,a6,slope,slope2
+ Real, Dimension(:),Allocatable :: diff,diff2,diff3
+ INTEGER :: diffmod
+ REAL :: invcoeffraf
+ integer :: s,l,k
+ integer :: etan, etap
+ real :: delta0, delta1,sumdelta
+ real :: epsilon
+ parameter (epsilon = 1.D-8)
+C
+ coeffraf = nint(ds_parent/ds_child)
+C
+ If (coeffraf == 1) Then
+ locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent)
+ y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1)
+ return
+ End If
+ invcoeffraf = ds_child/ds_parent
+
+C
+ Allocate(ytemp(-2*coeffraf:nc+2*coeffraf))
+ ypos = s_child
+C
+ locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
+ locind_parent_last = 1 +
+ & agrif_ceiling((ypos +(nc - 1)
+ & *ds_child - s_parent)/ds_parent)
+C
+ xpmin = s_parent + (locind_parent_left-1)*ds_parent
+ i1 = 1+agrif_int((xpmin-s_child)/ds_child)
+C
+ Allocate( diff(coeffraf))
+C
+ diff(1)=0.5*invcoeffraf
+ do i=2,coeffraf
+ diff(i) = diff(i-1)+invcoeffraf
+ enddo
+C
+ if( locind_parent_last+2 <= np ) then
+ nmax = locind_parent_last+2
+ else if( locind_parent_last+1 <= np ) then
+ nmax = locind_parent_last+1
+ else
+ nmax = locind_parent_last
+ endif
+C
+ if(locind_parent_left-1 >= 1) then
+ nmin = locind_parent_left-1
+ else
+ nmin = locind_parent_left
+ endif
+C
+ Do i = nmin+1,nmax
+ slope(i) = (x(i) - x(i-1))
+ Enddo
+C
+ diffmod = 0
+ IF (mod(coeffraf,2) == 0) diffmod = 1
+C
+ ipos = i1
+C
+ Do iparent = locind_parent_left,locind_parent_last
+ pos=1
+ delta0=1./(epsilon+slope(iparent )**2)**2
+ delta1=1./(epsilon+slope(iparent+1)**2)**2
+ sumdelta = 1./(delta0+delta1)
+ Do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2
+C
+ ytemp(jj) = x(iparent)+(diff(pos)-0.5)*(
+ & delta0*slope(iparent)+
+ & delta1*slope(iparent+1))*sumdelta
+ pos = pos+1
+ End do
+ ipos = ipos + coeffraf
+C
+ End do
+C
+C
+ y(1:nc)=ytemp(1:nc)
+ deallocate(ytemp)
+ deallocate(diff)
+
+ Return
+ End Subroutine weno1d
+
+C
+C **************************************************************************
+CCC Subroutine eno1d
+C **************************************************************************
+C
+ Subroutine eno1d(x,y,np,nc,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+CCC Description:
+CCC ---- p 163-164 Computational gasdynamics ----
+CCC Subroutine to do a 1D interpolation
+CCC using piecewise polynomial ENO reconstruction technique
+CCC on a child grid (vector y) from its parent grid (vector x).
+CC Method:
+C
+C Declarations:
+C
+ Implicit none
+C
+C Arguments
+ Integer :: np,nc
+ Real, Dimension(np) :: x
+ Real, Dimension(nc) :: y
+ Real, Dimension(:),Allocatable :: ytemp
+ Real :: s_parent,s_child,ds_parent,ds_child
+C
+C Local scalars
+ Integer :: i,coeffraf,locind_parent_left,locind_parent_last
+ Integer :: ipos,pos
+ Real :: ypos,xi
+ integer :: i1,jj
+ Real :: xpmin,cavg
+C
+ Real, Dimension(3,np) :: dd,c
+ Integer :: left
+C
+ Real, DImension(1:np+1) :: xhalf
+ Real, Dimension(:,:),Allocatable :: Xbar
+ INTEGER :: diffmod
+C
+ coeffraf = nint(ds_parent/ds_child)
+C
+ If (coeffraf == 1) Then
+ locind_parent_left = 1 + nint((s_child - s_parent)/ds_parent)
+ y(1:nc) = x(locind_parent_left:locind_parent_left+nc-1)
+ return
+ End If
+
+ diffmod = 0
+ IF (mod(coeffraf,2) == 0) diffmod = 1
+C
+ Allocate(ytemp(-2*coeffraf:nc+2*coeffraf))
+ ypos = s_child
+ locind_parent_left = 1 + agrif_int((ypos - s_parent)/ds_parent)
+ locind_parent_last = 1 +
+ & agrif_ceiling((ypos +(nc - 1) *ds_child -
+ & s_parent)/ds_parent)
+ xpmin = s_parent + (locind_parent_left-1)*ds_parent
+ i1 = 1+agrif_int((xpmin-s_child)/ds_child)
+C
+ xhalf(np+1) = np + 0.5
+ Do i = 1,np
+ xhalf(i) = i - 0.5
+ Enddo
+C
+C compute divided differences
+C
+ dd(1,1:np) = x(1:np)
+ dd(2,1:np-1) = 0.5*( dd(1,2:np) - dd(1,1:np-1) )
+ dd(3,1:np-2) = (1./3.)*( dd(2,2:np-1) - dd(2,1:np-2) )
+C
+ Allocate( Xbar( coeffraf,2 ) )
+ xi = 0.5
+ Do i = 1,coeffraf
+ Xbar(i,1) = (i-1)*ds_child/ds_parent - xi
+ Xbar(i,2) = i*ds_child/ds_parent - xi
+ Enddo
+C
+ ipos = i1
+C
+ DO i = locind_parent_left,locind_parent_last
+ left = i
+ do jj = 2,3
+ If(abs(dd(jj,left)) .gt. abs(dd(jj,left-1)))
+ & left = left-1
+ enddo
+C
+C convert to Taylor series form
+C
+ Call Taylor(i,xhalf(left:left+2),dd(1:3,left),c(1:3,i))
+ ENDDO
+C
+C evaluate the reconstruction on each cell
+C
+ DO i = locind_parent_left,locind_parent_last
+C
+ cavg = 0.
+ pos = 1.
+C
+ Do jj = ipos - coeffraf/2+diffmod,ipos + coeffraf/2
+ ytemp(jj) =(c(1,i)*(Xbar(pos,2)-Xbar(pos,1))
+ & +c(2,i)*(Xbar(pos,2)*Xbar(pos,2)-
+ & Xbar(pos,1)*Xbar(pos,1))
+ & +c(3,i)*(Xbar(pos,2)*Xbar(pos,2)*Xbar(pos,2)-
+ & Xbar(pos,1)*Xbar(pos,1)*Xbar(pos,1)))
+ & *coeffraf
+ cavg = cavg + ytemp(jj)
+ pos = pos+1
+ Enddo
+ ipos = ipos + coeffraf
+ ENDDO
+C
+ y(1:nc)=ytemp(1:nc)
+ deallocate(ytemp,Xbar)
+C
+ Return
+ End Subroutine eno1d
+C
+C
+C **************************************************************************
+CCC Subroutine taylor
+C **************************************************************************
+C
+ subroutine taylor(ind,xhalf,dd,c)
+C
+ Integer :: ind
+ real,dimension(3) :: dd,c
+ real,dimension(0:3,0:3) :: d
+ real,dimension(3) :: xhalf
+ integer ::i,j
+C
+C
+ d(0,0:3)=1.
+ do i = 1,3
+ d(i,0)=(ind-xhalf(i))*d(i-1,0)
+ enddo
+C
+ do i = 1,3
+ do j = 1,3-i
+ d(i,j) = d(i,j-1) + (ind-xhalf(i+j))*d(i-1,j)
+ enddo
+ enddo
+C
+ do j = 1,3
+ c(j) = 0.
+ do i=0,3-j
+ c(j) = c(j) + d(i,j)*dd(i+j)
+ enddo
+ enddo
+C
+ end subroutine taylor
+
+
+ REAL FUNCTION vanleer(tab)
+ REAL, DIMENSION(3) :: tab
+ real res1
+ real p1,p2,p3
+
+ p1=(tab(3)-tab(1))/2.
+ p2=2.*(tab(2)-tab(1))
+ p3=2.*(tab(3)-tab(2))
+
+ if ((p1>0.).AND.(p2>0.).AND.(p3>0)) then
+ res1=minval((/p1,p2,p3/))
+ elseif ((p1<0.).AND.(p2<0.).AND.(p3<0)) then
+ res1=maxval((/p1,p2,p3/))
+ else
+ res1=0.
+ endif
+
+ vanleer = res1
+
+
+ END FUNCTION vanleer
+
+C
+ End Module Agrif_Interpbasic
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modlinktomodel.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modlinktomodel.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modlinktomodel.F (revision 8155)
@@ -0,0 +1,186 @@
+C AGRIF (Adaptive Grid Refinement In Fortran)
+C
+C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
+C Christophe Vouland (Christophe.Vouland@imag.fr)
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+C
+C
+ Module Agrif_link
+C
+CCC Description:
+CCC This module is used to link AGRIF files to the model
+C
+C Modules used:
+C
+c external Agrif_InitValues
+c external Agrif_detect
+C
+ external Agrif_InitWorkspace
+ external Agrif_probdim_modtype_def
+ external Agrif_clustering_def
+ external Agrif_comm_def
+C Interface
+ INTERFACE
+ SUBROUTINE Sub_Loop_Agrif_InvLoc(indloc,nprocloc,i,
+ & indglob,njmppt,nimppt)
+ INTEGER :: indglob
+ INTEGER :: indloc
+ INTEGER :: nprocloc
+ INTEGER :: i
+
+ INTEGER, ALLOCATABLE, Dimension(:) :: njmppt
+ INTEGER, ALLOCATABLE, Dimension(:) :: nimppt
+ END SUBROUTINE
+ END INTERFACE
+ Interface
+ Subroutine Agrif_Set_numberofcells(Agrif_Gr)
+ Use Agrif_Types, Only : Agrif_grid
+ TYPE(Agrif_Grid), Pointer :: Agrif_Gr ! Pointer on the current grid
+ End Subroutine Agrif_Set_numberofcells
+ End interface
+ Interface
+ Subroutine Agrif_Get_numberofcells(Agrif_Gr)
+ Use Agrif_Types, Only : Agrif_grid
+ TYPE(Agrif_Grid), Pointer :: Agrif_Gr ! Pointer on the current grid
+ End Subroutine Agrif_Get_numberofcells
+ End interface
+ Interface
+ Subroutine Agrif_Allocationcalls(Agrif_Gr)
+ Use Agrif_Types, Only : Agrif_grid
+ TYPE(Agrif_Grid), Pointer :: Agrif_Gr ! Pointer on the current grid
+ End Subroutine Agrif_Allocationcalls
+ End interface
+C
+ End Module Agrif_link
+C **************************************************************************
+CCC Function Agrif_parent
+C modify by conv. To use : un_parent = Agrif_Parent(un)
+C **************************************************************************
+CCC Function Agrif_Get_Coarse_Grid
+C modify by conv. To use : un_Mygrid = Agrif_Get_Coarse_grid(un)
+C **************************************************************************
+CCC Function Agrif_Rhox
+C modify by conv. To use : var = Agrif_Rhox()
+C REAL(Agrif_Curgrid % spaceref(1))
+C **************************************************************************
+CCC Function Agrif_Parent_Rhox
+C modify by conv. To use : var = Agrif_Parent_Rhox()
+C REAL(Agrif_Curgrid % parent % spaceref(1))
+C **************************************************************************
+CCC Function Agrif_Irhox
+C modify by conv. To use : var = Agrif_Parent_IRhox()
+C Agrif_Curgrid % spaceref(1)
+C **************************************************************************
+CCC Function Agrif_Parent_Irhox
+C modify by conv. To use : var = Agrif_Parent_IRhox()
+C Agrif_Curgrid % parent % spaceref(1)
+C **************************************************************************
+CCC Function Agrif_Rhoy
+C modify by conv. To use : var = Agrif_Rhoy()
+C REAL(Agrif_Curgrid % spaceref(2))
+C **************************************************************************
+CCC Function Agrif_Parent_Rhoy
+C modify by conv. To use : var = Agrif_Parent_Rhoy()
+C REAL(Agrif_Curgrid % parent % spaceref(2))
+C **************************************************************************
+CCC Function Agrif_Irhoy
+C modify by conv. To use : var = Agrif_Parent_IRhoy()
+C Agrif_Curgrid % spaceref(2)
+C **************************************************************************
+CCC Function Agrif_Parent_Irhoy
+C modify by conv. To use : var = Agrif_Parent_IRhoy()
+C Agrif_Curgrid % parent % spaceref(2)
+C **************************************************************************
+CCC Function Agrif_Rhoz
+C modify by conv. To use : var = Agrif_Rhoz()
+C REAL(Agrif_Curgrid % spaceref(3))
+C **************************************************************************
+CCC Function Agrif_Parent_Rhoz
+C modify by conv. To use : var = Agrif_Parent_Rhoz()
+C REAL(Agrif_Curgrid % parent % spaceref(3))
+C **************************************************************************
+CCC Function Agrif_Irhoz
+C modify by conv. To use : var = Agrif_Parent_IRhoz()
+C Agrif_Curgrid % spaceref(3)
+C **************************************************************************
+CCC Function Agrif_Parent_Irhoz
+C modify by conv. To use : var = Agrif_Parent_IRhoz()
+C Agrif_Curgrid % parent % spaceref(3)
+C **************************************************************************
+CCC Function Agrif_NearCommonBorderX
+C modify by conv. To use : var = Agrif_NearCommonBorderX()
+C AGRIF_CURGRID % NearRootBorder(1)
+C **************************************************************************
+CCC Function Agrif_NearCommonBorderY
+C modify by conv. To use : var = Agrif_NearCommonBorderY()
+C AGRIF_CURGRID % NearRootBorder(2)
+C **************************************************************************
+CCC Function Agrif_NearCommonBorderZ
+C modify by conv. To use : var = Agrif_NearCommonBorderZ()
+C AGRIF_CURGRID % NearRootBorder(3)
+C **************************************************************************
+CCC Function Agrif_DistantCommonBorderX
+C modify by conv. To use : var = Agrif_DistantCommonBorderX()
+C AGRIF_CURGRID % DistantRootBorder(1)
+C **************************************************************************
+CCC Function Agrif_DistantCommonBorderY
+C modify by conv. To use : var = Agrif_DistantCommonBorderY()
+C AGRIF_CURGRID % DistantRootBorder(2)
+C **************************************************************************
+CCC Function Agrif_DistantCommonBorderZ
+C modify by conv. To use : var = Agrif_DistantCommonBorderZ()
+C AGRIF_CURGRID % DistantRootBorder(3)
+C **************************************************************************
+CCC Function Agrif_Nb_Step
+C modify by conv. To use : var = Agrif_Nb_Step()
+C AGRIF_CURGRID % ngridstep
+C **************************************************************************
+CCC Function Agrif_Nb_Fine_Grids
+C modify by conv. To use : var = Agrif_Nb_Fine_Grids()
+C Agrif_nbfixedgrids
+C **************************************************************************
+CCC Function Agrif_Ix
+C modify by conv. To use : var = Agrif_Ix()
+C Agrif_CURGRID % ix(1)
+C **************************************************************************
+CCC Function Agrif_Parent_Ix
+C modify by conv. To use : var = Agrif_Parent_Ix()
+C Agrif_CURGRID % parent % ix(1)
+C **************************************************************************
+CCC Function Agrif_Iy
+C modify by conv. To use : var = Agrif_Iy()
+C AGRIF_CURGRID % ix(2)
+C **************************************************************************
+CCC Function Agrif_Parent_Iy
+C modify by conv. To use : var = Agrif_Parent_Iy()
+C Agrif_CURGRID % parent % ix(2)
+C **************************************************************************
+CCC Function Agrif_Iz
+C modify by conv. To use : var = Agrif_Iz()
+C AGRIF_CURGRID % ix(3)
+C **************************************************************************
+CCC Function Agrif_Parent_Iz
+C modify by conv. To use : var = Agrif_Parent_Iz()
+C Agrif_CURGRID % parent % ix(3)
+C **************************************************************************
+CCC Function Agrif_Get_grid_id
+C modify by conv. To use : var = Agrif_Get_grid_id()
+C Agrif_CURGRID % grid_id
+C **************************************************************************
+CCC Function Agrif_Get_parent_id
+C modify by conv. To use : var = Agrif_Get_parent_id()
+C Agrif_CURGRID % parent % grid_id
+C **************************************************************************
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modmask.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modmask.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modmask.F (revision 8155)
@@ -0,0 +1,688 @@
+!
+! $Id: modmask.F 2528 2010-12-27 17:33:53Z rblod $
+!
+C AGRIF (Adaptive Grid Refinement In Fortran)
+C
+C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
+C Christophe Vouland (Christophe.Vouland@imag.fr)
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+C
+C
+C
+CCC Module Agrif_Mask
+C
+ Module Agrif_Mask
+C
+CCC Description:
+CCC Module for masks
+C
+C Modules used:
+C
+ Use Agrif_Types
+C
+ IMPLICIT NONE
+C
+ CONTAINS
+C Define procedures contained in this module
+C
+C **************************************************************************
+C Subroutine Agrif_CheckMasknD
+C **************************************************************************
+C
+ Subroutine Agrif_CheckMasknD(tempP,parent,pbtab,petab,ppbtab,
+ & ppetab,noraftab,nbdim)
+C
+CCC Description:
+CCC Subroutine called in the procedure Agrif_InterpnD to recalculate the value
+CCC of the parent grid variable when this one is equal to Agrif_SpecialValue.
+C
+C Declarations:
+C
+
+C
+C Arrays arguments
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(nbdim) :: pbtab ! Limits of the parent grid used
+ INTEGER,DIMENSION(nbdim) :: petab ! interpolation of the child grid
+ LOGICAL,DIMENSION(nbdim) :: noraftab
+ INTEGER,DIMENSION(nbdim) :: ppbtab,ppetab
+C
+C Pointer argument
+ TYPE(AGRIF_PVARIABLE) :: tempP ! Part of the parent grid used for
+ ! the interpolation of the child grid
+C Data TYPE argument
+ TYPE(AGRIF_PVARIABLE) :: parent ! The parent grid
+C
+C Local scalar
+ INTEGER :: i0,j0,k0,l0,m0,n0
+C
+C Local arrays
+C
+C
+ SELECT CASE (nbdim)
+ CASE (1)
+ do i0 = pbtab(1),petab(1)
+ IF (tempP%var%array1(i0)
+ & == Agrif_SpecialValue) Then
+ Call CalculNewValTempP((/i0/),
+ & tempP,parent,
+ & ppbtab,ppetab,
+ & noraftab,nbdim)
+ ENDIF
+ enddo
+ CASE (2)
+ do j0 = pbtab(2),petab(2)
+ do i0 = pbtab(1),petab(1)
+ IF (tempP%var%array2(i0,j0)
+ & == Agrif_SpecialValue) Then
+ Call CalculNewValTempP((/i0,j0/),
+ & tempP,parent,
+ & ppbtab,ppetab,
+ & noraftab,nbdim)
+ ENDIF
+ enddo
+ enddo
+ CASE (3)
+ do k0 = pbtab(3),petab(3)
+ do j0 = pbtab(2),petab(2)
+ do i0 = pbtab(1),petab(1)
+ IF (tempP%var%array3(i0,j0,k0)
+ & == Agrif_SpecialValue) Then
+!------CDIR NEXPAND
+ Call CalculNewValTempP3D((/i0,j0,k0/),
+ & tempP%var%array3(ppbtab(1),ppbtab(2),ppbtab(3)),
+ & parent%var%array3(ppbtab(1),ppbtab(2),ppbtab(3)),
+ & ppbtab,ppetab,
+ & noraftab,MaxSearch,Agrif_SpecialValue)
+
+c Call CalculNewValTempP((/i0,j0,k0/),
+c & tempP,parent,
+c & ppbtab,ppetab,
+c & noraftab,nbdim)
+
+ ENDIF
+ enddo
+ enddo
+ enddo
+ CASE (4)
+ do l0 = pbtab(4),petab(4)
+ do k0 = pbtab(3),petab(3)
+ do j0 = pbtab(2),petab(2)
+ do i0 = pbtab(1),petab(1)
+ IF (tempP%var%array4(i0,j0,k0,l0)
+ & == Agrif_SpecialValue) Then
+ Call CalculNewValTempP4D((/i0,j0,k0,l0/),
+ & tempP%var%array4(ppbtab(1),ppbtab(2),ppbtab(3),ppbtab(4)),
+ & parent%var%array4(ppbtab(1),ppbtab(2),ppbtab(3),ppbtab(4)),
+ & ppbtab,ppetab,
+ & noraftab,MaxSearch,Agrif_SpecialValue)
+ ENDIF
+ enddo
+ enddo
+ enddo
+ enddo
+ CASE (5)
+ do m0 = pbtab(5),petab(5)
+ do l0 = pbtab(4),petab(4)
+ do k0 = pbtab(3),petab(3)
+ do j0 = pbtab(2),petab(2)
+ do i0 = pbtab(1),petab(1)
+ IF (tempP%var%array5(i0,j0,k0,l0,m0)
+ & == Agrif_SpecialValue) Then
+ Call CalculNewValTempP((/i0,j0,k0,l0,m0/),
+ & tempP,parent,
+ & ppbtab,ppetab,
+ & noraftab,nbdim)
+ ENDIF
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ CASE (6)
+ do n0 = pbtab(6),petab(6)
+ do m0 = pbtab(5),petab(5)
+ do l0 = pbtab(4),petab(4)
+ do k0 = pbtab(3),petab(3)
+ do j0 = pbtab(2),petab(2)
+ do i0 = pbtab(1),petab(1)
+ IF (tempP%var%array6(i0,j0,k0,l0,m0,n0)
+ & == Agrif_SpecialValue) Then
+ Call CalculNewValTempP((/i0,j0,k0,l0,m0,n0/),
+ & tempP,parent,
+ & ppbtab,ppetab,
+ & noraftab,nbdim)
+ ENDIF
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ END SELECT
+C
+C
+C
+ End Subroutine Agrif_CheckMasknD
+C
+C
+C **************************************************************************
+C Subroutine CalculNewValTempP
+C **************************************************************************
+C
+ Subroutine CalculNewValTempP(indic,
+ & tempP,parent,ppbtab,
+ & ppetab,noraftab,nbdim)
+C
+CCC Description:
+CCC Subroutine called in the procedure Agrif_InterpnD to recalculate the value
+CCC of the parent grid variable when this one is equal to Agrif_SpecialValue.
+C
+C Declarations:
+C
+
+C
+C Arrays arguments
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(nbdim) :: indic
+ LOGICAL,DIMENSION(nbdim) :: noraftab
+ INTEGER,DIMENSION(nbdim) :: ppbtab,ppetab
+C
+C Pointer argument
+ TYPE(AGRIF_PVARIABLE) :: tempP ! Part of the parent grid used for
+ ! the interpolation of the child grid
+C Data TYPE argument
+ TYPE(AGRIF_PVARIABLE) :: parent ! The parent grid
+C
+C Local scalar
+ INTEGER :: i,ii,iii,jj,kk,ll,mm,nn
+ INTEGER,DIMENSION(nbdim) :: imin,imax,idecal
+ INTEGER :: Nbvals
+ REAL :: Res
+ REAL :: ValParent
+ INTEGER :: ValMax
+ LOGICAL :: firsttest
+C
+C Local arrays
+C
+ ValMax = 1
+ do iii = 1 , nbdim
+ IF (.NOT.noraftab(iii)) THEN
+ ValMax = max(ValMax,ppetab(iii)-indic(iii))
+ ValMax = max(ValMax,indic(iii)-ppbtab(iii))
+ ENDIF
+ enddo
+C
+ Valmax = min(Valmax,MaxSearch)
+C
+!CDIR NOVECTOR
+ imin = indic
+!CDIR NOVECTOR
+ imax = indic
+C
+ i = 1
+ firsttest = .TRUE.
+C
+ do While(i <= ValMax)
+C
+ IF ((i == 1).AND.(firsttest)) i = Valmax
+
+ do iii = 1 , nbdim
+ if (.NOT.noraftab(iii)) then
+ imin(iii) = max(indic(iii) - i,ppbtab(iii))
+ imax(iii) = min(indic(iii) + i,ppetab(iii))
+ if (firsttest) then
+ if (indic(iii).GT.ppbtab(iii)) then
+
+!CDIR NOVECTOR
+ idecal = indic
+ idecal(iii) = idecal(iii)-1
+ SELECT CASE(nbdim)
+ CASE (1)
+ if (tempP%var%array1(idecal(1)
+ & ) == Agrif_SpecialValue) then
+ imin(iii) = imax(iii)
+ endif
+ CASE (2)
+ if (tempP%var%array2(idecal(1),
+ & idecal(2)) == Agrif_SpecialValue) then
+ imin(iii) = imax(iii)
+ endif
+ CASE (3)
+ if (tempP%var%array3(idecal(1),
+ & idecal(2),idecal(3))
+ & == Agrif_SpecialValue) then
+ imin(iii) = imax(iii)
+ endif
+ CASE (4)
+ if (tempP%var%array4(idecal(1),
+ & idecal(2),idecal(3),idecal(4))
+ & == Agrif_SpecialValue) then
+ imin(iii) = imax(iii)
+ endif
+ CASE (5)
+ if (tempP%var%array5(idecal(1),
+ & idecal(2),idecal(3),idecal(4),idecal(5))
+ & == Agrif_SpecialValue) then
+ imin(iii) = imax(iii)
+ endif
+ CASE (6)
+ if (tempP%var%array6(idecal(1),
+ & idecal(2),idecal(3),idecal(4),idecal(5),idecal(6))
+ & == Agrif_SpecialValue) then
+ imin(iii) = imax(iii)
+ endif
+ END SELECT
+ endif
+ endif
+ endif
+ enddo
+C
+ Res = 0.
+ Nbvals = 0
+C
+ SELECT CASE(nbdim)
+ CASE (1)
+!CDIR ALTCODE
+!CDIR SHORTLOOP
+ do ii = imin(1),imax(1)
+ ValParent = parent%var%array1(ii)
+ if ( ValParent .NE. Agrif_SpecialValue) then
+ Res = Res + ValParent
+ Nbvals = Nbvals + 1
+ endif
+ enddo
+C
+ CASE (2)
+ do jj = imin(2),imax(2)
+!CDIR ALTCODE
+!CDIR SHORTLOOP
+ do ii = imin(1),imax(1)
+ ValParent = parent%var%array2(ii,jj)
+ if ( ValParent .NE. Agrif_SpecialValue) then
+ Res = Res + ValParent
+ Nbvals = Nbvals + 1
+ endif
+ enddo
+ enddo
+
+ CASE (3)
+ do kk = imin(3),imax(3)
+ do jj = imin(2),imax(2)
+!CDIR ALTCODE
+!CDIR SHORTLOOP
+ do ii = imin(1),imax(1)
+ ValParent = parent%var%array3(ii,jj,kk)
+ if ( ValParent .NE. Agrif_SpecialValue) then
+ Res = Res + ValParent
+ Nbvals = Nbvals + 1
+ endif
+ enddo
+ enddo
+ enddo
+
+ CASE (4)
+ do ll = imin(4),imax(4)
+ do kk = imin(3),imax(3)
+ do jj = imin(2),imax(2)
+!CDIR ALTCODE
+!CDIR SHORTLOOP
+ do ii = imin(1),imax(1)
+ ValParent = parent%var%array4(ii,jj,kk,ll)
+ if ( ValParent .NE. Agrif_SpecialValue) then
+ Res = Res + ValParent
+ Nbvals = Nbvals + 1
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+ CASE (5)
+ do mm = imin(5),imax(5)
+ do ll = imin(4),imax(4)
+ do kk = imin(3),imax(3)
+ do jj = imin(2),imax(2)
+!CDIR ALTCODE
+!CDIR SHORTLOOP
+ do ii = imin(1),imax(1)
+ ValParent = parent%var%array5(ii,jj,kk,ll,mm)
+ if ( ValParent .NE. Agrif_SpecialValue) then
+ Res = Res + ValParent
+ Nbvals = Nbvals + 1
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+
+ CASE (6)
+ do nn = imin(6),imax(6)
+ do mm = imin(5),imax(5)
+ do ll = imin(4),imax(4)
+ do kk = imin(3),imax(3)
+ do jj = imin(2),imax(2)
+!CDIR ALTCODE
+!CDIR SHORTLOOP
+ do ii = imin(1),imax(1)
+ ValParent = parent%var%array6(ii,jj,kk,ll,mm,nn)
+ if ( ValParent .NE. Agrif_SpecialValue) then
+ Res = Res + ValParent
+ Nbvals = Nbvals + 1
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+
+ END SELECT
+C
+C
+
+ if (Nbvals.GT.0) then
+ if (firsttest) then
+ firsttest = .FALSE.
+ i=1
+ cycle
+ endif
+ SELECT CASE(nbdim)
+ CASE (1)
+ tempP%var%array1(indic(1))
+ & = Res/Nbvals
+ CASE (2)
+ tempP%var%array2(indic(1),
+ & indic(2)) = Res/Nbvals
+ CASE (3)
+ tempP%var%array3(indic(1),
+ & indic(2),indic(3)) = Res/Nbvals
+ CASE (4)
+ tempP%var%array4(indic(1),
+ & indic(2),indic(3),indic(4))
+ & = Res/Nbvals
+ CASE (5)
+ tempP%var%array5(indic(1),
+ & indic(2),indic(3),indic(4),
+ & indic(5)) = Res/Nbvals
+ CASE (6)
+ tempP%var%array6(indic(1),
+ & indic(2),indic(3),indic(4),
+ & indic(5),indic(6)) = Res/Nbvals
+ END SELECT
+ exit
+ else
+ if (firsttest) exit
+ i = i + 1
+ endif
+ enddo
+C
+ End Subroutine CalculNewValTempP
+C
+C
+ End Module Agrif_Mask
+
+ Subroutine CalculNewValTempP3D(indic,
+ & tempP,parent,ppbtab,
+ & ppetab,noraftab,MaxSearch,Agrif_SpecialValue)
+C
+CCC Description:
+CCC Subroutine called in the procedure Agrif_InterpnD to recalculate the value
+CCC of the parent grid variable when this one is equal to Agrif_SpecialValue.
+C
+C Declarations:
+C
+
+C
+C Arrays arguments
+ INTEGER, PARAMETER :: nbdim = 3
+ INTEGER,DIMENSION(nbdim) :: indic
+ LOGICAL,DIMENSION(nbdim) :: noraftab
+ INTEGER,DIMENSION(nbdim) :: ppbtab,ppetab
+ REAL :: Agrif_SpecialValue
+C
+C Pointer argument
+ REAL,DIMENSION(ppbtab(1):ppetab(1),ppbtab(2):ppetab(2),
+ & ppbtab(3):ppetab(3)) :: tempP, parent ! Part of the parent grid used for
+ ! the interpolation of the child grid
+C
+C Local scalar
+ INTEGER :: i,ii,iii,jj,kk,ll,mm,nn
+ INTEGER,DIMENSION(nbdim) :: imin,imax,idecal
+ INTEGER :: Nbvals
+ REAL :: Res
+ REAL :: ValParent
+ INTEGER :: ValMax
+ INTEGER :: MaxSearch
+ LOGICAL :: Existunmasked
+C
+C Local arrays
+C
+ ValMax = 1
+!CDIR NOVECTOR
+ do iii = 1 , nbdim
+ IF (.NOT.noraftab(iii)) THEN
+ ValMax = max(ValMax,ppetab(iii)-indic(iii))
+ ValMax = max(ValMax,indic(iii)-ppbtab(iii))
+ ENDIF
+ enddo
+C
+ Valmax = min(Valmax,MaxSearch)
+C
+!CDIR NOVECTOR
+ imin = indic
+!CDIR NOVECTOR
+ imax = indic
+
+!CDIR NOVECTOR
+ idecal = indic
+C
+ i = Valmax
+
+ do iii = 1 , nbdim
+ if (.NOT.noraftab(iii)) then
+ imin(iii) = max(indic(iii) - i,ppbtab(iii))
+ imax(iii) = min(indic(iii) + i,ppetab(iii))
+
+ if (indic(iii).GT.ppbtab(iii)) then
+
+ idecal(iii) = idecal(iii)-1
+
+ if (tempP(idecal(1),idecal(2),idecal(3))
+ & == Agrif_SpecialValue) then
+ imin(iii) = imax(iii)
+ endif
+
+ idecal(iii) = idecal(iii)+1
+ endif
+
+ endif
+ enddo
+C
+ Existunmasked = .FALSE.
+C
+ do kk = imin(3),imax(3)
+ do jj = imin(2),imax(2)
+!CDIR NOVECTOR
+ do ii = imin(1),imax(1)
+ if ( parent(ii,jj,kk) .NE. Agrif_SpecialValue) then
+ Existunmasked = .TRUE.
+ exit
+ endif
+ enddo
+ enddo
+ enddo
+C
+C
+ if (.Not.Existunmasked) return
+C
+ i = 1
+C
+ do While(i <= ValMax)
+C
+
+ do iii = 1 , nbdim
+ if (.NOT.noraftab(iii)) then
+ imin(iii) = max(indic(iii) - i,ppbtab(iii))
+ imax(iii) = min(indic(iii) + i,ppetab(iii))
+ endif
+ enddo
+C
+ Res = 0.
+ Nbvals = 0
+C
+ do kk = imin(3),imax(3)
+ do jj = imin(2),imax(2)
+!CDIR NOVECTOR
+ do ii = imin(1),imax(1)
+ ValParent = parent(ii,jj,kk)
+ if ( ValParent .NE. Agrif_SpecialValue) then
+ Res = Res + ValParent
+ Nbvals = Nbvals + 1
+ endif
+ enddo
+ enddo
+ enddo
+C
+C
+
+ if (Nbvals.GT.0) then
+ tempP(indic(1),indic(2),indic(3)) = Res/Nbvals
+ exit
+ else
+ i = i + 1
+ endif
+ enddo
+C
+ End Subroutine CalculNewValTempP3D
+
+ Subroutine CalculNewValTempP4D(indic,
+ & tempP,parent,ppbtab,
+ & ppetab,noraftab,MaxSearch,Agrif_SpecialValue)
+C
+CCC Description:
+CCC Subroutine called in the procedure Agrif_InterpnD to recalculate the value
+CCC of the parent grid variable when this one is equal to Agrif_SpecialValue.
+C
+C Declarations:
+C
+
+C
+C Arrays arguments
+ INTEGER, PARAMETER :: nbdim = 4
+ INTEGER,DIMENSION(nbdim) :: indic
+ LOGICAL,DIMENSION(nbdim) :: noraftab
+ INTEGER,DIMENSION(nbdim) :: ppbtab,ppetab
+ INTEGER :: MaxSearch
+ REAL :: Agrif_SpecialValue
+C
+C Pointer argument
+ REAL,DIMENSION(ppbtab(1):ppetab(1),ppbtab(2):ppetab(2),
+ & ppbtab(3):ppetab(3),
+ & ppbtab(4):ppetab(4)) :: tempP, parent ! Part of the parent grid used for
+ ! the interpolation of the child grid
+C
+C Local scalar
+ INTEGER :: i,ii,iii,jj,kk,ll,mm,nn
+ INTEGER,DIMENSION(nbdim) :: imin,imax,idecal
+ INTEGER :: Nbvals
+ REAL :: Res
+ REAL :: ValParent
+ INTEGER :: ValMax
+ LOGICAL :: firsttest
+C
+C Local arrays
+C
+ ValMax = 1
+ do iii = 1 , nbdim
+ IF (.NOT.noraftab(iii)) THEN
+ ValMax = max(ValMax,ppetab(iii)-indic(iii))
+ ValMax = max(ValMax,indic(iii)-ppbtab(iii))
+ ENDIF
+ enddo
+C
+ Valmax = min(Valmax,MaxSearch)
+C
+ imin = indic
+ imax = indic
+C
+ i = 1
+ firsttest = .TRUE.
+ idecal = indic
+
+C
+ do While(i <= ValMax)
+C
+ IF ((i == 1).AND.(firsttest)) i = Valmax
+
+ do iii = 1 , nbdim
+ if (.NOT.noraftab(iii)) then
+ imin(iii) = max(indic(iii) - i,ppbtab(iii))
+ imax(iii) = min(indic(iii) + i,ppetab(iii))
+ if (firsttest) then
+ if (indic(iii).GT.ppbtab(iii)) then
+
+
+ idecal(iii) = idecal(iii)-1
+
+ if (tempP(idecal(1),idecal(2),idecal(3),idecal(4))
+ & == Agrif_SpecialValue) then
+ imin(iii) = imax(iii)
+ endif
+
+ idecal(iii) = idecal(iii)+1
+ endif
+ endif
+ endif
+ enddo
+C
+ Res = 0.
+ Nbvals = 0
+C
+ do ll = imin(4),imax(4)
+ do kk = imin(3),imax(3)
+ do jj = imin(2),imax(2)
+ do ii = imin(1),imax(1)
+ ValParent = parent(ii,jj,kk,ll)
+ if ( ValParent .NE. Agrif_SpecialValue) then
+ Res = Res + ValParent
+ Nbvals = Nbvals + 1
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+C
+C
+
+ if (Nbvals.GT.0) then
+ if (firsttest) then
+ firsttest = .FALSE.
+ i=1
+ cycle
+ endif
+
+ tempP(indic(1),indic(2),indic(3),indic(4)) = Res/Nbvals
+
+ exit
+ else
+ if (firsttest) exit
+ i = i + 1
+ endif
+ enddo
+C
+ End Subroutine CalculNewValTempP4D
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modmpp.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modmpp.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modmpp.F (revision 8155)
@@ -0,0 +1,1119 @@
+!
+! $Id: modmpp.F 2731 2011-04-08 12:05:35Z rblod $
+!
+C AGRIF (Adaptive Grid Refinement In Fortran)
+C
+C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
+C Christophe Vouland (Christophe.Vouland@imag.fr)
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.
+C
+C
+C
+CCC Module Agrif_mpp
+C
+ Module Agrif_mpp
+ Use Agrif_Types
+ Use Agrif_Arrays
+
+ Contains
+#ifdef key_mpp_mpi
+ Subroutine Get_External_Data_first(pttruetab,
+ & cetruetab,pttruetabwhole,cetruetabwhole,nbdim,memberin,
+ & memberout,memberoutall1,sendtoproc,recvfromproc,imin,imax,
+ & imin_recv,imax_recv)
+
+ IMPLICIT NONE
+ INCLUDE 'mpif.h'
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(nbdim,0:Agrif_NbProcs-1) :: pttruetab,
+ & cetruetab
+ INTEGER,DIMENSION(nbdim,0:Agrif_NbProcs-1) :: pttruetabwhole,
+ & cetruetabwhole
+ INTEGER :: k,i,k2
+ LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc, recvfromproc
+ INTEGER,DIMENSION(nbdim,0:Agrif_NbProcs-1):: imin,imax,
+ & imin_recv,imax_recv
+ LOGICAL :: memberin, memberout
+ INTEGER :: imintmp, imaxtmp,j,i1
+ INTEGER :: imin1,imax1
+ LOGICAL :: tochange,tochangebis
+ INTEGER,DIMENSION(nbdim,0:Agrif_NbProcs-1) :: pttruetab2,
+ & cetruetab2
+ LOGICAL :: memberout1(1),memberoutall(0:Agrif_Nbprocs-1)
+ LOGICAL, OPTIONAL :: memberoutall1(0:Agrif_Nbprocs-1)
+ INTEGER :: code
+
+C pttruetab2 and cetruetab2 are modified arraysin order to always
+C send the most inner points
+
+
+ IF (present(memberoutall1)) THEN
+ memberoutall = memberoutall1
+ ELSE
+ memberout1(1) = memberout
+
+ CALL MPI_ALLGATHER(memberout1,1,MPI_LOGICAL,memberoutall,
+ & 1,MPI_LOGICAL,MPI_COMM_AGRIF,code)
+ ENDIF
+ pttruetab2(:,Agrif_Procrank) = pttruetab(:,Agrif_Procrank)
+ cetruetab2(:,Agrif_Procrank) = cetruetab(:,Agrif_Procrank)
+ do k2=0,Agrif_Nbprocs-1
+ do i=1,nbdim
+
+ tochangebis=.TRUE.
+ DO i1=1,nbdim
+ IF (i .NE. i1) THEN
+ IF ((pttruetab(i1,Agrif_Procrank).NE.pttruetab(i1,k2)).OR.
+ & (cetruetab(i1,Agrif_Procrank).NE.cetruetab(i1,k2))) THEN
+ tochangebis = .FALSE.
+ EXIT
+ ENDIF
+ ENDIF
+ ENDDO
+
+ IF (tochangebis) THEN
+
+
+ imin1 = max(pttruetab(i,Agrif_Procrank),
+ & pttruetab(i,k2))
+ imax1 = min(cetruetab(i,Agrif_Procrank),
+ & cetruetab(i,k2))
+
+C Always send the most interior points
+
+ tochange = .false.
+ IF (cetruetab(i,Agrif_Procrank)> cetruetab(i,k2)) THEN
+
+ DO j=imin1,imax1
+ IF ((cetruetab(i,k2)-j) >
+ & (j-pttruetab(i,Agrif_Procrank))) THEN
+ imintmp = j+1
+ tochange = .TRUE.
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+
+ if (tochange) then
+C
+ pttruetab2(i,Agrif_Procrank) = imintmp
+C
+ endif
+
+ tochange = .FALSE.
+ imaxtmp=0
+ IF (pttruetab(i,Agrif_Procrank) < pttruetab(i,k2)) THEN
+ DO j=imax1,imin1,-1
+ IF ((j-pttruetab(i,k2)) >
+ & (cetruetab(i,Agrif_Procrank)-j)) THEN
+ imaxtmp = j-1
+ tochange = .TRUE.
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ if (tochange) then
+C
+ cetruetab2(i,Agrif_Procrank) = imaxtmp
+C
+ endif
+C
+
+ ENDIF
+ enddo
+ enddo
+
+
+ do k = 0,Agrif_NbProcs-1
+C
+ sendtoproc(k) = .true.
+C
+!CDIR SHORTLOOP
+ do i = 1,nbdim
+C
+ imin(i,k) = max(pttruetab2(i,Agrif_Procrank),
+ & pttruetabwhole(i,k))
+ imax(i,k) = min(cetruetab2(i,Agrif_Procrank),
+ & cetruetabwhole(i,k))
+C
+ if (imin(i,k) > imax(i,k)) then
+C
+ sendtoproc(k) = .false.
+C
+ endif
+C
+ enddo
+ IF (.NOT.memberoutall(k)) THEN
+ sendtoproc(k) = .FALSE.
+ ENDIF
+C
+ enddo
+
+ Call Exchangesamelevel_first(sendtoproc,nbdim,imin,imax,
+ & recvfromproc,imin_recv,imax_recv)
+
+ End Subroutine Get_External_Data_first
+C
+ Subroutine Get_External_Data(tempC,tempCextend,pttruetab,
+ & cetruetab,pttruetabwhole,cetruetabwhole,nbdim,memberin,
+ & memberout,memberoutall1)
+
+ IMPLICIT NONE
+ INCLUDE 'mpif.h'
+ INTEGER :: nbdim
+ TYPE(Agrif_PVariable) :: tempC, tempCextend
+ INTEGER,DIMENSION(nbdim,0:Agrif_NbProcs-1) :: pttruetab,
+ & cetruetab
+ INTEGER,DIMENSION(nbdim,0:Agrif_NbProcs-1) :: pttruetabwhole,
+ & cetruetabwhole
+ INTEGER :: k,i,k2
+ LOGICAL :: sendtoproc(0:Agrif_Nbprocs-1)
+ INTEGER,DIMENSION(nbdim,0:Agrif_NbProcs-1) :: imin,imax
+ LOGICAL :: memberin, memberout
+ INTEGER :: imintmp, imaxtmp,j,i1
+ INTEGER :: imin1,imax1
+ LOGICAL :: tochange,tochangebis
+ INTEGER,DIMENSION(nbdim,0:Agrif_NbProcs-1) :: pttruetab2,
+ & cetruetab2
+ LOGICAL :: memberout1(1),memberoutall(0:Agrif_Nbprocs-1)
+ LOGICAL, OPTIONAL :: memberoutall1(0:Agrif_Nbprocs-1)
+ INTEGER :: code
+
+C pttruetab2 and cetruetab2 are modified arraysin order to always
+C send the most inner points
+
+
+ IF (present(memberoutall1)) THEN
+ memberoutall = memberoutall1
+ ELSE
+ memberout1(1) = memberout
+
+ CALL MPI_ALLGATHER(memberout1,1,MPI_LOGICAL,memberoutall,
+ & 1,MPI_LOGICAL,MPI_COMM_AGRIF,code)
+ ENDIF
+ pttruetab2(:,Agrif_Procrank) = pttruetab(:,Agrif_Procrank)
+ cetruetab2(:,Agrif_Procrank) = cetruetab(:,Agrif_Procrank)
+ do k2=0,Agrif_Nbprocs-1
+ do i=1,nbdim
+
+ tochangebis=.TRUE.
+ DO i1=1,nbdim
+ IF (i .NE. i1) THEN
+ IF ((pttruetab(i1,Agrif_Procrank).NE.pttruetab(i1,k2)).OR.
+ & (cetruetab(i1,Agrif_Procrank).NE.cetruetab(i1,k2))) THEN
+ tochangebis = .FALSE.
+ EXIT
+ ENDIF
+ ENDIF
+ ENDDO
+
+ IF (tochangebis) THEN
+
+
+ imin1 = max(pttruetab(i,Agrif_Procrank),
+ & pttruetab(i,k2))
+ imax1 = min(cetruetab(i,Agrif_Procrank),
+ & cetruetab(i,k2))
+
+C Always send the most interior points
+
+ tochange = .false.
+ IF (cetruetab(i,Agrif_Procrank)> cetruetab(i,k2)) THEN
+
+ DO j=imin1,imax1
+ IF ((cetruetab(i,k2)-j) >
+ & (j-pttruetab(i,Agrif_Procrank))) THEN
+ imintmp = j+1
+ tochange = .TRUE.
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+
+ if (tochange) then
+C
+ pttruetab2(i,Agrif_Procrank) = imintmp
+C
+ endif
+
+ tochange = .FALSE.
+ imaxtmp=0
+ IF (pttruetab(i,Agrif_Procrank) < pttruetab(i,k2)) THEN
+ DO j=imax1,imin1,-1
+ IF ((j-pttruetab(i,k2)) >
+ & (cetruetab(i,Agrif_Procrank)-j)) THEN
+ imaxtmp = j-1
+ tochange = .TRUE.
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ if (tochange) then
+C
+ cetruetab2(i,Agrif_Procrank) = imaxtmp
+C
+ endif
+C
+
+ ENDIF
+ enddo
+ enddo
+
+
+ do k = 0,Agrif_NbProcs-1
+C
+ sendtoproc(k) = .true.
+C
+!CDIR SHORTLOOP
+ do i = 1,nbdim
+C
+ imin(i,k) = max(pttruetab2(i,Agrif_Procrank),
+ & pttruetabwhole(i,k))
+ imax(i,k) = min(cetruetab2(i,Agrif_Procrank),
+ & cetruetabwhole(i,k))
+C
+ if (imin(i,k) > imax(i,k)) then
+C
+ sendtoproc(k) = .false.
+C
+ endif
+C
+ enddo
+ IF (.NOT.memberoutall(k)) THEN
+ sendtoproc(k) = .FALSE.
+ ENDIF
+C
+ enddo
+
+
+c IF (.NOT.memberin) sendtoproc = .FALSE.
+
+ IF (memberout) THEN
+ Call Agrif_nbdim_allocation(tempCextend%var,
+ & pttruetabwhole(:,Agrif_ProcRank),
+ & cetruetabwhole(:,Agrif_ProcRank),nbdim)
+ call Agrif_nbdim_Full_VarEQreal(tempCextend%var,0.,nbdim)
+ ENDIF
+
+ IF (sendtoproc(Agrif_ProcRank)) THEN
+ Call Agrif_nbdim_VarEQvar(tempCextend%var,
+ & imin(:,Agrif_Procrank),
+ & imax(:,Agrif_Procrank),
+ & tempC%var,
+ & imin(:,Agrif_Procrank),
+ & imax(:,Agrif_Procrank),
+ & nbdim)
+ ENDIF
+
+ Call Exchangesamelevel(sendtoproc,nbdim,imin,imax,tempC,
+ & tempCextend)
+
+ End Subroutine Get_External_Data
+
+ Subroutine ExchangeSameLevel(sendtoproc,nbdim,imin,imax,
+ & tempC,tempCextend)
+ Implicit None
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1) :: imin,imax
+ INTEGER,DIMENSION(nbdim,2,0:Agrif_Nbprocs-1) :: iminmax_temp
+ INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1) :: imin_recv,imax_recv
+ TYPE(Agrif_PVARIABLE) :: tempC,tempCextend
+ LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc
+ LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: recvfromproc
+ LOGICAL :: res
+ TYPE(AGRIF_PVARIABLE), SAVE :: temprecv
+
+ INCLUDE 'mpif.h'
+ INTEGER :: i,k
+ INTEGER :: etiquette = 100
+ INTEGER :: code, datasize
+ INTEGER,DIMENSION(MPI_STATUS_SIZE) :: statut
+
+
+ do k = 0,Agrif_ProcRank-1
+C
+C
+ Call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+C
+ if (sendtoproc(k)) then
+C
+ iminmax_temp(:,1,k) = imin(:,k)
+ iminmax_temp(:,2,k) = imax(:,k)
+
+ Call MPI_SEND(iminmax_temp(:,:,k),
+ & 2*nbdim,MPI_INTEGER,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+C
+ datasize = 1
+C
+!CDIR SHORTLOOP
+ do i = 1,nbdim
+C
+ datasize = datasize * (imax(i,k)-imin(i,k)+1)
+C
+ enddo
+C
+ SELECT CASE(nbdim)
+ CASE(1)
+ Call MPI_SEND(tempC%var%array1(
+ & imin(1,k):imax(1,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(2)
+ Call MPI_SEND(tempC%var%array2(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(3)
+
+ Call Agrif_Send_3Darray(tempC%var%array3,
+ & lbound(tempC%var%array3),imin(:,k),imax(:,k),k)
+ CASE(4)
+ Call MPI_SEND(tempC%var%array4(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(5)
+ Call MPI_SEND(tempC%var%array5(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k),
+ & imin(5,k):imax(5,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(6)
+ Call MPI_SEND(tempC%var%array6(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k),
+ & imin(5,k):imax(5,k),
+ & imin(6,k):imax(6,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ END SELECT
+C
+ endif
+
+C
+ enddo
+C
+C
+C Reception from others processors of the necessary part of the parent grid
+ do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
+C
+C
+ Call MPI_RECV(res,1,MPI_LOGICAL,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+C
+ recvfromproc(k) = res
+
+C
+ if (recvfromproc(k)) then
+C
+ Call MPI_RECV(iminmax_temp(:,:,k),
+ & 2*nbdim,MPI_INTEGER,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+
+ imin_recv(:,k) = iminmax_temp(:,1,k)
+ imax_recv(:,k) = iminmax_temp(:,2,k)
+
+ datasize = 1
+C
+!CDIR SHORTLOOP
+ do i = 1,nbdim
+C
+ datasize = datasize * (imax_recv(i,k)-imin_recv(i,k)+1)
+C
+ enddo
+
+ IF (.Not.Associated(temprecv%var)) allocate(temprecv%var)
+ call Agrif_nbdim_allocation(temprecv%var,imin_recv(:,k),
+ & imax_recv(:,k),nbdim)
+ SELECT CASE(nbdim)
+ CASE(1)
+ Call MPI_RECV(temprecv%var%array1,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ CASE(2)
+ Call MPI_RECV(temprecv%var%array2,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ CASE(3)
+ Call MPI_RECV(temprecv%var%array3,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+
+ CASE(4)
+ Call MPI_RECV(temprecv%var%array4,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ CASE(5)
+ Call MPI_RECV(temprecv%var%array5,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ CASE(6)
+ Call MPI_RECV(temprecv%var%array6,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ END SELECT
+
+ Call where_valtabtotab_mpi(tempCextend%var,
+ & temprecv%var,imin_recv(:,k),imax_recv(:,k),0.,nbdim)
+
+ Call Agrif_nbdim_deallocation(temprecv%var,nbdim)
+C deallocate(temprecv%var)
+
+ endif
+
+C
+ enddo
+
+C Reception from others processors of the necessary part of the parent grid
+ do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
+C
+C
+
+ Call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+C
+ if (sendtoproc(k)) then
+C
+ iminmax_temp(:,1,k) = imin(:,k)
+ iminmax_temp(:,2,k) = imax(:,k)
+
+ Call MPI_SEND(iminmax_temp(:,:,k),
+ & 2*nbdim,MPI_INTEGER,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+C
+ SELECT CASE(nbdim)
+ CASE(1)
+ datasize=SIZE(tempC%var%array1(
+ & imin(1,k):imax(1,k)))
+ Call MPI_SEND(tempC%var%array1(
+ & imin(1,k):imax(1,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(2)
+ datasize=SIZE(tempC%var%array2(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k)))
+ Call MPI_SEND(tempC%var%array2(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(3)
+ datasize=SIZE(tempC%var%array3(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k)))
+ Call MPI_SEND(tempC%var%array3(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(4)
+ datasize=SIZE(tempC%var%array4(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k)))
+ Call MPI_SEND(tempC%var%array4(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(5)
+ datasize=SIZE(tempC%var%array5(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k),
+ & imin(5,k):imax(5,k)))
+ Call MPI_SEND(tempC%var%array5(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k),
+ & imin(5,k):imax(5,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(6)
+ datasize=SIZE(tempC%var%array6(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k),
+ & imin(5,k):imax(5,k),
+ & imin(6,k):imax(6,k)))
+ Call MPI_SEND(tempC%var%array6(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k),
+ & imin(5,k):imax(5,k),
+ & imin(6,k):imax(6,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ END SELECT
+C
+ endif
+
+C
+ enddo
+C
+C
+C Reception from others processors of the necessary part of the parent grid
+ do k = Agrif_ProcRank-1,0,-1
+C
+C
+ Call MPI_RECV(res,1,MPI_LOGICAL,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+C
+ recvfromproc(k) = res
+
+C
+ if (recvfromproc(k)) then
+C
+ Call MPI_RECV(iminmax_temp(:,:,k),
+ & 2*nbdim,MPI_INTEGER,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+
+C imin_recv(:,k) = iminmax_temp(:,1,k)
+C imax_recv(:,k) = iminmax_temp(:,2,k)
+
+C datasize = 1
+C
+C do i = 1,nbdim
+C
+C datasize = datasize * (imax_recv(i,k)-imin_recv(i,k)+1)
+C
+C enddo
+ IF (.Not.Associated(temprecv%var)) allocate(temprecv%var)
+ call Agrif_nbdim_allocation(temprecv%var,
+ & iminmax_temp(:,1,k),iminmax_temp(:,2,k),nbdim)
+ SELECT CASE(nbdim)
+ CASE(1)
+ datasize=SIZE(temprecv%var%array1)
+ Call MPI_RECV(temprecv%var%array1,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ CASE(2)
+ datasize=SIZE(temprecv%var%array2)
+ Call MPI_RECV(temprecv%var%array2,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ CASE(3)
+ datasize=SIZE(temprecv%var%array3)
+ Call MPI_RECV(temprecv%var%array3,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+
+ CASE(4)
+ datasize=SIZE(temprecv%var%array4)
+ Call MPI_RECV(temprecv%var%array4,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ CASE(5)
+ datasize=SIZE(temprecv%var%array5)
+ Call MPI_RECV(temprecv%var%array5,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ CASE(6)
+ datasize=SIZE(temprecv%var%array6)
+ Call MPI_RECV(temprecv%var%array6,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ END SELECT
+
+ Call where_valtabtotab_mpi(tempCextend%var,
+ & temprecv%var,iminmax_temp(:,1,k),iminmax_temp(:,2,k)
+ & ,0.,nbdim)
+
+ Call Agrif_nbdim_deallocation(temprecv%var,nbdim)
+C deallocate(temprecv%var)
+ endif
+
+C
+ enddo
+
+ End Subroutine ExchangeSamelevel
+
+ Subroutine ExchangeSameLevel_first(sendtoproc,nbdim,imin,imax,
+ & recvfromproc,imin_recv,imax_recv)
+ Implicit None
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1) :: imin,imax
+ INTEGER,DIMENSION(nbdim,2,0:Agrif_Nbprocs-1) :: iminmax_temp
+ INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1) :: imin_recv,imax_recv
+ LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc
+ LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: recvfromproc
+ LOGICAL :: res
+
+ INCLUDE 'mpif.h'
+ INTEGER :: i,k
+ INTEGER :: etiquette = 100
+ INTEGER :: code, datasize
+ INTEGER,DIMENSION(MPI_STATUS_SIZE) :: statut
+
+
+ do k = 0,Agrif_ProcRank-1
+C
+C
+ Call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+C
+ if (sendtoproc(k)) then
+C
+ iminmax_temp(:,1,k) = imin(:,k)
+ iminmax_temp(:,2,k) = imax(:,k)
+
+ Call MPI_SEND(iminmax_temp(:,:,k),
+ & 2*nbdim,MPI_INTEGER,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+C
+ endif
+
+C
+ enddo
+C
+C
+C Reception from others processors of the necessary part of the parent grid
+ do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
+C
+C
+ Call MPI_RECV(res,1,MPI_LOGICAL,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+C
+ recvfromproc(k) = res
+
+C
+ if (recvfromproc(k)) then
+C
+ Call MPI_RECV(iminmax_temp(:,:,k),
+ & 2*nbdim,MPI_INTEGER,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+
+ imin_recv(:,k) = iminmax_temp(:,1,k)
+ imax_recv(:,k) = iminmax_temp(:,2,k)
+ endif
+
+C
+ enddo
+
+C Reception from others processors of the necessary part of the parent grid
+ do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
+C
+C
+
+ Call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+C
+ if (sendtoproc(k)) then
+C
+ iminmax_temp(:,1,k) = imin(:,k)
+ iminmax_temp(:,2,k) = imax(:,k)
+
+ Call MPI_SEND(iminmax_temp(:,:,k),
+ & 2*nbdim,MPI_INTEGER,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+C
+ endif
+
+C
+ enddo
+C
+C
+C Reception from others processors of the necessary part of the parent grid
+ do k = Agrif_ProcRank-1,0,-1
+C
+C
+ Call MPI_RECV(res,1,MPI_LOGICAL,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+C
+ recvfromproc(k) = res
+
+C
+ if (recvfromproc(k)) then
+C
+ Call MPI_RECV(iminmax_temp(:,:,k),
+ & 2*nbdim,MPI_INTEGER,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+
+ imin_recv(:,k) = iminmax_temp(:,1,k)
+ imax_recv(:,k) = iminmax_temp(:,2,k)
+ endif
+
+C
+ enddo
+
+ End Subroutine ExchangeSamelevel_first
+
+ Subroutine ExchangeSameLevel2(sendtoproc,recvfromproc,
+ & nbdim,
+ & pttruetabwhole,cetruetabwhole,imin,imax,
+ & imin_recv,imax_recv,memberout,tempC,tempCextend)
+ Implicit None
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1) :: imin,imax
+ INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1) :: pttruetabwhole,
+ & cetruetabwhole
+ INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1) :: imin_recv,imax_recv
+ TYPE(Agrif_PVARIABLE) :: tempC,tempCextend
+ LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc
+ LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: recvfromproc
+ LOGICAL :: res
+ LOGICAL :: memberout
+ TYPE(AGRIF_PVARIABLE), SAVE :: temprecv
+
+ INCLUDE 'mpif.h'
+ INTEGER :: i,k
+ INTEGER :: etiquette = 100
+ INTEGER :: code, datasize
+ INTEGER,DIMENSION(MPI_STATUS_SIZE) :: statut
+
+ IF (memberout) THEN
+ Call Agrif_nbdim_allocation(tempCextend%var,
+ & pttruetabwhole(:,Agrif_ProcRank),
+ & cetruetabwhole(:,Agrif_ProcRank),nbdim)
+ call Agrif_nbdim_Full_VarEQreal(tempCextend%var,0.,nbdim)
+ ENDIF
+
+ IF (sendtoproc(Agrif_ProcRank)) THEN
+ Call Agrif_nbdim_VarEQvar(tempCextend%var,
+ & imin(:,Agrif_Procrank),
+ & imax(:,Agrif_Procrank),
+ & tempC%var,
+ & imin(:,Agrif_Procrank),
+ & imax(:,Agrif_Procrank),
+ & nbdim)
+ ENDIF
+
+ do k = 0,Agrif_ProcRank-1
+C
+C
+C
+ if (sendtoproc(k)) then
+C
+ datasize = 1
+C
+!CDIR SHORTLOOP
+ do i = 1,nbdim
+C
+ datasize = datasize * (imax(i,k)-imin(i,k)+1)
+C
+ enddo
+C
+
+ SELECT CASE(nbdim)
+ CASE(1)
+ Call MPI_SEND(tempC%var%array1(
+ & imin(1,k):imax(1,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(2)
+ Call MPI_SEND(tempC%var%array2(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(3)
+
+ Call Agrif_Send_3Darray(tempC%var%array3,
+ & lbound(tempC%var%array3),imin(:,k),imax(:,k),k)
+ CASE(4)
+ Call MPI_SEND(tempC%var%array4(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(5)
+ Call MPI_SEND(tempC%var%array5(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k),
+ & imin(5,k):imax(5,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(6)
+ Call MPI_SEND(tempC%var%array6(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k),
+ & imin(5,k):imax(5,k),
+ & imin(6,k):imax(6,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ END SELECT
+C
+ endif
+
+C
+ enddo
+C
+C
+C Reception from others processors of the necessary part of the parent grid
+ do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
+
+C
+ if (recvfromproc(k)) then
+
+ datasize = 1
+C
+!CDIR SHORTLOOP
+ do i = 1,nbdim
+C
+ datasize = datasize * (imax_recv(i,k)-imin_recv(i,k)+1)
+C
+ enddo
+
+ IF (.Not.Associated(temprecv%var)) allocate(temprecv%var)
+ call Agrif_nbdim_allocation(temprecv%var,imin_recv(:,k),
+ & imax_recv(:,k),nbdim)
+ SELECT CASE(nbdim)
+ CASE(1)
+ Call MPI_RECV(temprecv%var%array1,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ CASE(2)
+ Call MPI_RECV(temprecv%var%array2,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ CASE(3)
+ Call MPI_RECV(temprecv%var%array3,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+
+ CASE(4)
+ Call MPI_RECV(temprecv%var%array4,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ CASE(5)
+ Call MPI_RECV(temprecv%var%array5,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ CASE(6)
+ Call MPI_RECV(temprecv%var%array6,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ END SELECT
+
+ Call where_valtabtotab_mpi(tempCextend%var,
+ & temprecv%var,imin_recv(:,k),imax_recv(:,k),0.,nbdim)
+
+ Call Agrif_nbdim_deallocation(temprecv%var,nbdim)
+C deallocate(temprecv%var)
+
+ endif
+
+C
+ enddo
+
+C Reception from others processors of the necessary part of the parent grid
+ do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
+C
+C
+ if (sendtoproc(k)) then
+C
+ SELECT CASE(nbdim)
+ CASE(1)
+ datasize=SIZE(tempC%var%array1(
+ & imin(1,k):imax(1,k)))
+ Call MPI_SEND(tempC%var%array1(
+ & imin(1,k):imax(1,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(2)
+ datasize=SIZE(tempC%var%array2(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k)))
+ Call MPI_SEND(tempC%var%array2(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(3)
+ datasize=SIZE(tempC%var%array3(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k)))
+ Call MPI_SEND(tempC%var%array3(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(4)
+ datasize=SIZE(tempC%var%array4(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k)))
+ Call MPI_SEND(tempC%var%array4(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(5)
+ datasize=SIZE(tempC%var%array5(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k),
+ & imin(5,k):imax(5,k)))
+ Call MPI_SEND(tempC%var%array5(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k),
+ & imin(5,k):imax(5,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ CASE(6)
+ datasize=SIZE(tempC%var%array6(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k),
+ & imin(5,k):imax(5,k),
+ & imin(6,k):imax(6,k)))
+ Call MPI_SEND(tempC%var%array6(
+ & imin(1,k):imax(1,k),
+ & imin(2,k):imax(2,k),
+ & imin(3,k):imax(3,k),
+ & imin(4,k):imax(4,k),
+ & imin(5,k):imax(5,k),
+ & imin(6,k):imax(6,k)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+ END SELECT
+C
+ endif
+
+C
+ enddo
+C
+C
+C Reception from others processors of the necessary part of the parent grid
+ do k = Agrif_ProcRank-1,0,-1
+C
+
+C
+ if (recvfromproc(k)) then
+C
+ IF (.Not.Associated(temprecv%var)) allocate(temprecv%var)
+ call Agrif_nbdim_allocation(temprecv%var,
+ & imin_recv(:,k),imax_recv(:,k),nbdim)
+ SELECT CASE(nbdim)
+ CASE(1)
+ datasize=SIZE(temprecv%var%array1)
+ Call MPI_RECV(temprecv%var%array1,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ CASE(2)
+ datasize=SIZE(temprecv%var%array2)
+ Call MPI_RECV(temprecv%var%array2,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ CASE(3)
+ datasize=SIZE(temprecv%var%array3)
+ Call MPI_RECV(temprecv%var%array3,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+
+ CASE(4)
+ datasize=SIZE(temprecv%var%array4)
+ Call MPI_RECV(temprecv%var%array4,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ CASE(5)
+ datasize=SIZE(temprecv%var%array5)
+ Call MPI_RECV(temprecv%var%array5,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ CASE(6)
+ datasize=SIZE(temprecv%var%array6)
+ Call MPI_RECV(temprecv%var%array6,
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,statut,code)
+ END SELECT
+
+ Call where_valtabtotab_mpi(tempCextend%var,
+ & temprecv%var,imin_recv(:,k),imax_recv(:,k)
+ & ,0.,nbdim)
+
+ Call Agrif_nbdim_deallocation(temprecv%var,nbdim)
+C deallocate(temprecv%var)
+ endif
+
+C
+ enddo
+
+ End Subroutine ExchangeSamelevel2
+
+ Subroutine Agrif_Send_3Darray(tab3D,bounds,imin,imax,k)
+ integer, dimension(3) :: bounds, imin, imax
+ real,dimension(bounds(1):,bounds(2):,bounds(3):),target
+ & :: tab3D
+ integer :: k
+ integer :: etiquette = 100
+ integer :: datasize, code
+ INCLUDE 'mpif.h'
+
+ datasize = SIZE(tab3D(
+ & imin(1):imax(1),
+ & imin(2):imax(2),
+ & imin(3):imax(3)))
+
+ Call MPI_SEND(tab3D(
+ & imin(1):imax(1),
+ & imin(2):imax(2),
+ & imin(3):imax(3)),
+ & datasize,MPI_DOUBLE_PRECISION,k,etiquette,
+ & MPI_COMM_AGRIF,code)
+
+ End Subroutine Agrif_Send_3Darray
+
+#else
+ Subroutine Agrif_mpp_empty()
+ End Subroutine Agrif_mpp_empty
+#endif
+
+ End Module Agrif_mpp
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modsauv.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modsauv.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modsauv.F (revision 8155)
@@ -0,0 +1,937 @@
+!
+! $Id: modsauv.F 2715 2011-03-30 15:58:35Z rblod $
+!
+C AGRIF (Adaptive Grid Refinement In Fortran)
+C
+C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
+C Christophe Vouland (Christophe.Vouland@imag.fr)
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.
+C
+C
+C
+CCC Module Agrif_Save
+C
+ Module Agrif_Save
+C
+CCC Description:
+CCC Module for the initialization by copy of the grids created by clustering.
+C
+C Modules used:
+C
+ Use Agrif_Types
+ Use Agrif_Link
+ Use Agrif_Arrays
+ Use Agrif_Variables
+C
+ IMPLICIT NONE
+C
+ Contains
+C Definition of procedures contained in this module.
+C
+C
+ Subroutine Agrif_Deallocate_Arrays(Var)
+ type(Agrif_Variable), pointer :: Var
+
+ if (ALLOCATED(var%array1)) then
+ Deallocate(var%array1)
+ endif
+ if (ALLOCATED(var%array2)) then
+ Deallocate(var%array2)
+ endif
+ if (ALLOCATED(var%array3)) then
+ Deallocate(var%array3)
+ endif
+ if (ALLOCATED(var%array4)) then
+ Deallocate(var%array4)
+ endif
+ if (ALLOCATED(var%array5)) then
+ Deallocate(var%array5)
+ endif
+ if (ALLOCATED(var%array6)) then
+ Deallocate(var%array6)
+ endif
+C
+ if (ALLOCATED(var%darray1)) then
+ Deallocate(var%darray1)
+ endif
+ if (ALLOCATED(var%darray2)) then
+ Deallocate(var%darray2)
+ endif
+ if (ALLOCATED(var%darray3)) then
+ Deallocate(var%darray3)
+ endif
+ if (ALLOCATED(var%darray4)) then
+ Deallocate(var%darray4)
+ endif
+ if (ALLOCATED(var%darray5)) then
+ Deallocate(var%darray5)
+ endif
+ if (ALLOCATED(var%darray6)) then
+ Deallocate(var%darray6)
+ endif
+C
+ if (ALLOCATED(var%larray1)) then
+ Deallocate(var%larray1)
+ endif
+ if (ALLOCATED(var%larray2)) then
+ Deallocate(var%larray2)
+ endif
+ if (ALLOCATED(var%larray3)) then
+ Deallocate(var%larray3)
+ endif
+ if (ALLOCATED(var%larray4)) then
+ Deallocate(var%larray4)
+ endif
+ if (ALLOCATED(var%larray5)) then
+ Deallocate(var%larray5)
+ endif
+ if (ALLOCATED(var%larray6)) then
+ Deallocate(var%larray6)
+ endif
+C
+ if (ALLOCATED(var%iarray1)) then
+ Deallocate(var%iarray1)
+ endif
+ if (ALLOCATED(var%iarray2)) then
+ Deallocate(var%iarray2)
+ endif
+ if (ALLOCATED(var%iarray3)) then
+ Deallocate(var%iarray3)
+ endif
+ if (ALLOCATED(var%iarray4)) then
+ Deallocate(var%iarray4)
+ endif
+ if (ALLOCATED(var%iarray5)) then
+ Deallocate(var%iarray5)
+ endif
+ if (ALLOCATED(var%iarray6)) then
+ Deallocate(var%iarray6)
+ endif
+C
+ if (ALLOCATED(var%carray1)) then
+ Deallocate(var%carray1)
+ endif
+ if (ALLOCATED(var%carray2)) then
+ Deallocate(var%carray2)
+ endif
+C
+ if (associated(var%oldvalues2D)) then
+ Deallocate(var%oldvalues2D)
+ endif
+ if (associated(var%interpIndex)) then
+ Deallocate(var%interpIndex)
+ endif
+
+ if (associated(var%posvar)) then
+ Deallocate(var%posvar)
+ endif
+
+ if (associated(var%interptab)) then
+ Deallocate(var%interptab)
+ endif
+
+ Return
+ End Subroutine Agrif_Deallocate_Arrays
+C
+C **************************************************************************
+CCC Subroutine Agrif_Free_data_before
+C **************************************************************************
+C
+ Subroutine Agrif_Free_data_before(Agrif_Gr)
+C
+CCC Description:
+CCC
+C
+CC Method:
+CC
+C
+C Declarations:
+C
+
+C
+C Pointer argument
+ TYPE(Agrif_Grid),pointer :: Agrif_Gr ! Pointer on the current grid
+ INTEGER i
+ Type(Agrif_List_Variables), pointer :: parcours
+C
+C
+ do i = 1 , AGRIF_NbVariables
+ if ( .NOT. Agrif_Mygrid % tabvars(i) % var % restaure) then
+C
+ call Agrif_Deallocate_Arrays(Agrif_Gr%tabvars(i)%var)
+
+ endif
+
+C
+ if (associated(Agrif_Gr%tabvars(i)%var%list_interp)) then
+ Call Agrif_Free_list_interp
+ & (Agrif_Gr%tabvars(i)%var%list_interp)
+ endif
+C
+ if ( .NOT. Agrif_Mygrid % tabvars(i) % var % restaure) then
+ Deallocate(Agrif_Gr%tabvars(i)%var)
+C
+ endif
+ enddo
+
+ parcours => Agrif_Gr%variables
+
+ do i=1,Agrif_Gr%NbVariables
+ if (.NOT. parcours%pvar%var%root_var%restaure) then
+ call Agrif_Deallocate_Arrays(parcours%pvar%var)
+ endif
+ if (associated(parcours%pvar%var%list_interp)) then
+ Call Agrif_Free_list_interp
+ & (parcours%pvar%var%list_interp)
+ endif
+C
+ if ( .NOT. parcours%pvar%var%root_var % restaure) then
+ Deallocate(parcours%pvar%var)
+C
+ endif
+ parcours => parcours%nextvariable
+ enddo
+C
+C
+C
+ if ( Agrif_USE_ONLY_FIXED_GRIDS .EQ. 0 ) then
+ if ( Agrif_Probdim .EQ. 1 ) Deallocate(Agrif_Gr%tabpoint1D)
+ if ( Agrif_Probdim .EQ. 2 ) Deallocate(Agrif_Gr%tabpoint2D)
+ if ( Agrif_Probdim .EQ. 3 ) Deallocate(Agrif_Gr%tabpoint3D)
+ endif
+C
+ Return
+C
+C
+ End Subroutine Agrif_Free_data_before
+C
+C
+ Recursive Subroutine Agrif_Free_list_interp(list_interp)
+ TYPE(Agrif_List_Interp_Loc), Pointer :: list_interp
+
+ if (associated(list_interp%suiv))
+ & Call Agrif_Free_list_interp(list_interp%suiv)
+
+#ifdef key_mpp_mpi
+ Deallocate(list_interp%interp_loc%tab4t)
+ Deallocate(list_interp%interp_loc%memberinall)
+ Deallocate(list_interp%interp_loc%sendtoproc1)
+ Deallocate(list_interp%interp_loc%recvfromproc1)
+#endif
+ Deallocate(list_interp%interp_loc)
+ Deallocate(list_interp)
+ Nullify(list_interp)
+
+ End Subroutine Agrif_Free_list_interp
+C
+C **************************************************************************
+CCC Subroutine Agrif_Free_data_after
+C **************************************************************************
+C
+ Subroutine Agrif_Free_data_after(Agrif_Gr)
+C
+CCC Description:
+CCC
+C
+CC Method:
+CC
+C
+C Declarations:
+C
+C
+
+C
+C Pointer argument
+ TYPE(Agrif_Grid),pointer :: Agrif_Gr ! Pointer on the current grid
+ INTEGER i
+ Type(Agrif_List_Variables), pointer :: parcours, rootparcours
+C
+C
+ do i = 1 , AGRIF_NbVariables
+ if ( Agrif_Mygrid % tabvars(i) % var % restaure) then
+
+ call Agrif_Deallocate_Arrays(Agrif_Gr%tabvars(i)%var)
+ !
+ Deallocate(Agrif_Gr%tabvars(i)%var)
+!
+ endif
+ enddo
+
+ parcours => Agrif_Gr%variables
+ rootparcours=>Agrif_Mygrid%variables
+
+ do i=1,Agrif_Gr%NbVariables
+ if (rootparcours%pvar%var%restaure) then
+ call Agrif_Deallocate_Arrays(parcours%pvar%var)
+
+ Deallocate(parcours%pvar%var)
+C
+ endif
+ parcours => parcours%nextvariable
+ rootparcours => rootparcours%nextvariable
+ enddo
+
+C
+C
+ Return
+C
+C
+ End Subroutine Agrif_Free_data_after
+C
+C
+CC **************************************************************************
+CCC Subroutine AGRIF_CopyFromold_All
+C **************************************************************************
+C
+ Recursive Subroutine AGRIF_CopyFromold_All(g,oldchildgrids)
+C
+CCC Description:
+CCC Routine called in the Agrif_Init_Hierarchy procedure
+C (Agrif_Clustering module).
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+C Pointer argument
+ TYPE(AGRIF_grid),pointer :: g ! Pointer on the current grid
+ TYPE(AGRIF_pgrid),pointer :: oldchildgrids
+C
+C Local pointer
+ TYPE(AGRIF_pgrid),pointer :: parcours ! Pointer for the recursive
+ ! procedure
+ REAL g_eps,eps,oldgrid_eps
+ INTEGER :: out
+ INTEGER :: iii
+C
+ out = 0
+C
+ parcours => oldchildgrids
+C
+ do while (associated(parcours))
+C
+ if ((.NOT. g % fixed) .AND. (parcours % gr %oldgrid)) then
+C
+ g_eps = huge(1.)
+ oldgrid_eps = huge(1.)
+ do iii = 1 , Agrif_Probdim
+ g_eps = min(g_eps,g % Agrif_d(iii))
+ oldgrid_eps = min(oldgrid_eps,
+ & parcours % gr % Agrif_d(iii))
+ enddo
+C
+ eps = min(g_eps,oldgrid_eps)/100.
+C
+ do iii = 1 , Agrif_Probdim
+
+ if (g % Agrif_d(iii) .LT.
+ & (parcours % gr % Agrif_d(iii) - eps)) then
+C
+ parcours => parcours % next
+C
+ out = 1
+C
+ Exit
+C
+ endif
+C
+ enddo
+ if ( out .EQ. 1 ) Cycle
+C
+ Call AGRIF_CopyFromOld(g,parcours%gr)
+C
+ endif
+C
+ Call Agrif_CopyFromold_All
+ & (g, parcours % gr % child_grids)
+C
+ parcours => parcours % next
+C
+ enddo
+C
+C
+ Return
+C
+C
+ End Subroutine AGRIF_CopyFromold_All
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_CopyFromold
+C **************************************************************************
+C
+ Subroutine Agrif_CopyFromold(Agrif_New_Gr,Agrif_Old_Gr)
+C
+CCC Description:
+CCC Call to the Agrif_Copy procedure.
+C
+CC Method:
+CC
+C
+C Declarations:
+C
+
+C
+C Pointer argument
+ TYPE(Agrif_Grid),Pointer :: Agrif_New_Gr ! Pointer on the current grid
+ TYPE(Agrif_Grid),Pointer :: Agrif_Old_Gr ! Pointer on an old grid
+ INTEGER :: i
+C
+C
+ do i = 1 , AGRIF_NbVariables
+ if ( Agrif_Mygrid % tabvars(i) % var % restaure ) then
+C
+ Call Agrif_Copy(Agrif_New_Gr,Agrif_Old_Gr,
+ & Agrif_New_Gr % tabvars(i),
+ & Agrif_Old_Gr % tabvars(i))
+C
+ endif
+ enddo
+
+C
+C
+ Return
+C
+C
+ End Subroutine Agrif_CopyFromold
+
+CC **************************************************************************
+CCC Subroutine AGRIF_CopyFromold_AllOneVar
+C **************************************************************************
+C
+ Recursive Subroutine AGRIF_CopyFromold_AllOneVar(g,oldchildgrids,
+ & indic)
+C
+CCC Description:
+CCC Routine called in the Agrif_Init_Hierarchy procedure
+C (Agrif_Clustering module).
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+C Pointer argument
+ TYPE(AGRIF_grid),pointer :: g ! Pointer on the current grid
+ TYPE(AGRIF_pgrid),pointer :: oldchildgrids
+ integer :: indic
+C
+C Local pointer
+ TYPE(AGRIF_pgrid),pointer :: parcours ! Pointer for the recursive
+ ! procedure
+ REAL g_eps,eps,oldgrid_eps
+ INTEGER :: out
+ INTEGER :: iii
+C
+ out = 0
+C
+ parcours => oldchildgrids
+C
+ do while (associated(parcours))
+C
+ if ((.NOT. g % fixed) .AND. (parcours % gr %oldgrid)) then
+C
+ g_eps = huge(1.)
+ oldgrid_eps = huge(1.)
+ do iii = 1 , Agrif_Probdim
+ g_eps = min(g_eps,g % Agrif_d(iii))
+ oldgrid_eps = min(oldgrid_eps,
+ & parcours % gr % Agrif_d(iii))
+ enddo
+C
+ eps = min(g_eps,oldgrid_eps)/100.
+C
+ do iii = 1 , Agrif_Probdim
+
+ if (g % Agrif_d(iii) .LT.
+ & (parcours % gr % Agrif_d(iii) - eps)) then
+C
+ parcours => parcours % next
+C
+ out = 1
+C
+ Exit
+C
+ endif
+C
+ enddo
+ if ( out .EQ. 1 ) Cycle
+C
+ Call AGRIF_CopyFromOldOneVar(g,parcours%gr,indic)
+C
+ endif
+C
+ Call Agrif_CopyFromold_AllOneVar
+ & (g, parcours % gr % child_grids,indic)
+C
+ parcours => parcours % next
+C
+ enddo
+C
+C
+ Return
+C
+C
+ End Subroutine AGRIF_CopyFromold_AllOneVar
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_CopyFromoldOneVar
+C **************************************************************************
+C
+ Subroutine Agrif_CopyFromoldOneVar(Agrif_New_Gr,Agrif_Old_Gr,
+ & indic)
+C
+CCC Description:
+CCC Call to the Agrif_Copy procedure.
+C
+CC Method:
+CC
+C
+C Declarations:
+C
+
+C
+C Pointer argument
+ TYPE(Agrif_Grid),Pointer :: Agrif_New_Gr ! Pointer on the current grid
+ TYPE(Agrif_Grid),Pointer :: Agrif_Old_Gr ! Pointer on an old grid
+ INTEGER :: indic
+ INTEGER :: i
+ TYPE(Agrif_PVariable),Pointer ::tabvars,oldtabvars
+C
+C
+ tabvars => Agrif_Search_Variable(Agrif_New_Gr,-indic)
+ oldtabvars => Agrif_Search_Variable(Agrif_Old_Gr,-indic)
+
+ Call Agrif_Nbdim_Allocation(tabvars%var,
+ & tabvars%var%lb,tabvars%var%ub,
+ & tabvars%var%nbdim)
+
+ Call Agrif_Copy(Agrif_New_Gr,Agrif_Old_Gr,
+ & tabvars,oldtabvars)
+
+
+C
+C
+ Return
+C
+C
+ End Subroutine Agrif_CopyFromoldOneVar
+
+C
+C
+CC
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Copy
+C **************************************************************************
+C
+ Subroutine Agrif_Copy(Agrif_New_Gr,Agrif_Old_Gr,New_Var,Old_Var)
+C
+CCC Description:
+CCC Sets arguments of the Agrif_UpdatenD procedures, n being the number of
+CCC DIMENSION of the grid variable.
+C
+CC Method:
+CC
+C
+C Declarations:
+C
+
+C
+C Pointer argument
+ TYPE(Agrif_Grid),Pointer :: Agrif_New_Gr ! Pointer on the current grid
+ TYPE(Agrif_Grid), Pointer :: Agrif_Old_Gr ! Pointer on an old grid
+ TYPE(Agrif_Pvariable) :: New_Var, Old_Var
+ INTEGER :: nbdim ! Number of dimensions of the current
+ ! grid
+ INTEGER,DIMENSION(6) :: pttabnew ! Indexes of the first point in the
+ ! domain
+ INTEGER,DIMENSION(6) :: petabnew ! Indexes of the first point in the
+ ! domain
+ INTEGER,DIMENSION(6) :: pttabold ! Indexes of the first point in the
+ ! domain
+ INTEGER,DIMENSION(6) :: petabold ! Indexes of the first point in the
+ ! domain
+ INTEGER,DIMENSION(6) :: nbtabold ! Number of cells in each direction
+
+ INTEGER,DIMENSION(6) :: nbtabnew ! Number of cells in each direction
+ TYPE(AGRIF_Variable), Pointer :: root ! Pointer on the variable of the
+ ! root grid
+ REAL, DIMENSION(6) :: snew,sold
+ REAL, DIMENSION(6) :: dsnew,dsold
+ REAL :: eps
+ INTEGER :: n
+C
+C
+ root => New_Var % var % root_var
+C
+ nbdim = root % nbdim
+C
+ do n=1,nbdim
+C
+ select case(root % interptab(n))
+C
+ case('x')
+C
+ pttabnew(n) = root % point(1)
+C
+ pttabold(n) = root % point(1)
+C
+ snew(n) = Agrif_New_Gr % Agrif_x(1)
+C
+ sold(n) = Agrif_Old_Gr % Agrif_x(1)
+C
+ dsnew(n) = Agrif_New_Gr % Agrif_d(1)
+C
+ dsold(n) = Agrif_Old_Gr % Agrif_d(1)
+C
+ if (root % posvar(n) .EQ. 1) then
+C
+ petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(1)
+C
+ petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(1)
+C
+ else
+C
+ petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(1) - 1
+C
+ petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(1) - 1
+C
+ snew(n) = snew(n) + dsnew(n)/2.
+C
+ sold(n) = sold(n) + dsold(n)/2.
+C
+ endif
+C
+ case('y')
+C
+ pttabnew(n) = root % point(2)
+C
+ pttabold(n) = root % point(2)
+C
+ snew(n) = Agrif_New_Gr % Agrif_x(2)
+C
+ sold(n) = Agrif_Old_Gr % Agrif_x(2)
+C
+ dsnew(n) = Agrif_New_Gr % Agrif_d(2)
+C
+ dsold(n) = Agrif_Old_Gr % Agrif_d(2)
+C
+ if (root % posvar(n) .EQ. 1) then
+C
+ petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(2)
+C
+ petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(2)
+C
+ else
+C
+ petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(2) - 1
+C
+ petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(2) - 1
+C
+ snew(n) = snew(n) + dsnew(n)/2.
+C
+ sold(n) = sold(n) + dsold(n)/2.
+C
+ endif
+C
+ case('z')
+C
+ pttabnew(n) = root % point(3)
+C
+ pttabold(n) = root % point(3)
+C
+ snew(n) = Agrif_New_Gr % Agrif_x(3)
+C
+ sold(n) = Agrif_Old_Gr % Agrif_x(3)
+C
+ dsnew(n) = Agrif_New_Gr % Agrif_d(3)
+C
+ dsold(n) = Agrif_Old_Gr % Agrif_d(3)
+C
+ if (root % posvar(n) .EQ. 1) then
+C
+ petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(3)
+C
+ petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(3)
+C
+ else
+C
+ petabnew(n) = pttabnew(n) + Agrif_New_Gr % nb(3) - 1
+C
+ petabold(n) = pttabold(n) + Agrif_Old_Gr % nb(3) - 1
+C
+ snew(n) = snew(n) + dsnew(n)/2.
+C
+ sold(n) = sold(n) + dsold(n)/2.
+C
+ endif
+C
+ case('N')
+C
+ Call Agrif_nbdim_Get_bound(New_Var%var,
+ & pttabnew(n),petabnew(n),
+ & n,nbdim)
+C
+ pttabold(n) = pttabnew(n)
+C
+ petabold(n) = petabnew(n)
+C
+ snew(n) = 0.
+C
+ sold(n) = 0.
+C
+ dsnew(n) = 1.
+C
+ dsold(n) = 1.
+C
+ end select
+C
+ enddo
+C
+ do n = 1,nbdim
+C
+ nbtabnew(n) = petabnew(n) - pttabnew(n)
+C
+ nbtabold(n) = petabold(n) - pttabold(n)
+C
+ enddo
+C
+ eps = min(minval(dsnew(1:nbdim)),minval(dsold(1:nbdim)))
+C
+ eps = eps/100.
+C
+ do n = 1,nbdim
+C
+ if (snew(n) .GT. (sold(n)+dsold(n)*nbtabold(n)+eps)) Return
+C
+ if ((snew(n)+dsnew(n)*nbtabnew(n)-eps) .LT. sold(n)) Return
+C
+ enddo
+C
+C
+ Call AGRIF_CopynD
+ & (New_Var,Old_Var,pttabold,petabold,pttabnew,petabnew,
+ & sold,snew,dsold,dsnew,nbdim)
+C
+C
+ Return
+C
+C
+ End Subroutine Agrif_Copy
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_CopynD
+C **************************************************************************
+C
+ Subroutine Agrif_CopynD(New_Var,Old_Var,pttabold,petabold,
+ & pttabnew,petabnew,sold,snew,dsold,
+ & dsnew,nbdim)
+C
+CCC Description:
+CCC Copy of the nD New_Var variable from the nD Old_Var variable.
+C
+CC Method:
+CC
+C
+C Declarations:
+C
+
+C
+ INTEGER :: nbdim
+ TYPE(Agrif_Pvariable) :: New_Var, Old_Var
+ INTEGER,DIMENSION(nbdim) :: pttabnew
+ INTEGER,DIMENSION(nbdim) :: petabnew
+ INTEGER,DIMENSION(nbdim) :: pttabold
+ INTEGER,DIMENSION(nbdim) :: petabold
+ REAL, DIMENSION(nbdim) :: snew,sold
+ REAL, DIMENSION(nbdim) :: dsnew,dsold
+C
+ INTEGER :: i,j,k,l,m,n,i0,j0,k0,l0,m0,n0
+C
+ REAL, DIMENSION(nbdim) :: dim_gmin,dim_gmax
+ REAL, DIMENSION(nbdim) :: dim_newmin,dim_newmax
+ REAL, DIMENSION(nbdim) :: dim_min
+ INTEGER, DIMENSION(nbdim) :: ind_gmin,ind_newmin
+ INTEGER, DIMENSION(nbdim) :: ind_newmax
+C
+C
+ do i = 1,nbdim
+C
+ dim_gmin(i) = sold(i)
+ dim_gmax(i) = sold(i) + (petabold(i)-pttabold(i)) * dsold(i)
+C
+ dim_newmin(i) = snew(i)
+ dim_newmax(i) = snew(i) + (petabnew(i)-pttabnew(i)) * dsnew(i)
+C
+ enddo
+C
+ do i = 1,nbdim
+C
+ if (dim_gmax(i) .LT. dim_newmin(i)) Return
+C
+ if (dim_gmin(i) .GT. dim_newmax(i)) Return
+C
+ enddo
+C
+C
+ do i = 1,nbdim
+C
+ ind_newmin(i) = pttabnew(i) - floor(-(max(dim_gmin(i),
+ & dim_newmin(i))-dim_newmin(i))/dsnew(i))
+C
+ dim_min(i) = snew(i) + (ind_newmin(i)-pttabnew(i))*dsnew(i)
+C
+ ind_gmin(i) = pttabold(i) + nint((dim_min(i)-
+ & dim_gmin(i))/dsold(i))
+C
+ ind_newmax(i) = pttabnew(i)
+ & + int((min(dim_gmax(i),dim_newmax(i))
+ & -dim_newmin(i))/dsnew(i))
+C
+ enddo
+C
+C
+C
+ SELECT CASE (nbdim)
+ CASE (1)
+ i0 = ind_gmin(1)
+ do i = ind_newmin(1),ind_newmax(1)
+ New_Var % var % array1(i) =
+ & Old_Var % var % array1(i0)
+ New_Var % var % restore1D(i) = 1
+ i0 = i0 + int(dsnew(1)/dsold(1))
+ enddo
+ CASE (2)
+
+ i0 = ind_gmin(1)
+ do i = ind_newmin(1),ind_newmax(1)
+ j0 = ind_gmin(2)
+ do j = ind_newmin(2),ind_newmax(2)
+ New_Var % var % array2(i,j) =
+ & Old_Var % var % array2(i0,j0)
+ New_Var % var % restore2D(i,j) = 1
+ j0 = j0 + int(dsnew(2)/dsold(2))
+ enddo
+ i0 = i0 + int(dsnew(1)/dsold(1))
+ enddo
+ CASE (3)
+ i0 = ind_gmin(1)
+ do i = ind_newmin(1),ind_newmax(1)
+ j0 = ind_gmin(2)
+ do j = ind_newmin(2),ind_newmax(2)
+ k0 = ind_gmin(3)
+ do k = ind_newmin(3),ind_newmax(3)
+ New_Var % var % array3(i,j,k) =
+ & Old_Var % var % array3(i0,j0,k0)
+ New_Var % var % restore3D(i,j,k) = 1
+ k0 = k0 + int(dsnew(3)/dsold(3))
+ enddo
+ j0 = j0 + int(dsnew(2)/dsold(2))
+ enddo
+ i0 = i0 + int(dsnew(1)/dsold(1))
+ enddo
+ CASE (4)
+ i0 = ind_gmin(1)
+ do i = ind_newmin(1),ind_newmax(1)
+ j0 = ind_gmin(2)
+ do j = ind_newmin(2),ind_newmax(2)
+ k0 = ind_gmin(3)
+ do k = ind_newmin(3),ind_newmax(3)
+ l0 = ind_gmin(4)
+ do l = ind_newmin(4),ind_newmax(4)
+ New_Var % var % array4(i,j,k,l) =
+ & Old_Var % var % array4(i0,j0,k0,l0)
+ New_Var % var % restore4D(i,j,k,l) = 1
+ l0 = l0 + int(dsnew(4)/dsold(4))
+ enddo
+ k0 = k0 + int(dsnew(3)/dsold(3))
+ enddo
+ j0 = j0 + int(dsnew(2)/dsold(2))
+ enddo
+ i0 = i0 + int(dsnew(1)/dsold(1))
+ enddo
+ CASE (5)
+ i0 = ind_gmin(1)
+ do i = ind_newmin(1),ind_newmax(1)
+ j0 = ind_gmin(2)
+ do j = ind_newmin(2),ind_newmax(2)
+ k0 = ind_gmin(3)
+ do k = ind_newmin(3),ind_newmax(3)
+ l0 = ind_gmin(4)
+ do l = ind_newmin(4),ind_newmax(4)
+ m0 = ind_gmin(5)
+ do m = ind_newmin(5),ind_newmax(5)
+ New_Var % var % array5(i,j,k,l,m) =
+ & Old_Var % var % array5(i0,j0,k0,l0,m0)
+ New_Var % var % restore5D(i,j,k,l,m) = 1
+ m0 = m0 + int(dsnew(5)/dsold(5))
+ enddo
+ l0 = l0 + int(dsnew(4)/dsold(4))
+ enddo
+ k0 = k0 + int(dsnew(3)/dsold(3))
+ enddo
+ j0 = j0 + int(dsnew(2)/dsold(2))
+ enddo
+ i0 = i0 + int(dsnew(1)/dsold(1))
+ enddo
+ CASE (6)
+ i0 = ind_gmin(1)
+ do i = ind_newmin(1),ind_newmax(1)
+ j0 = ind_gmin(2)
+ do j = ind_newmin(2),ind_newmax(2)
+ k0 = ind_gmin(3)
+ do k = ind_newmin(3),ind_newmax(3)
+ l0 = ind_gmin(4)
+ do l = ind_newmin(4),ind_newmax(4)
+ m0 = ind_gmin(5)
+ do m = ind_newmin(5),ind_newmax(5)
+ n0 = ind_gmin(6)
+ do n = ind_newmin(6),ind_newmax(6)
+ New_Var % var % array6(i,j,k,l,m,n) =
+ & Old_Var % var % array6(i0,j0,k0,l0,m0,n0)
+ New_Var % var % restore6D(i,j,k,l,m,n) = 1
+ n0 = n0 + int(dsnew(6)/dsold(6))
+ enddo
+ m0 = m0 + int(dsnew(5)/dsold(5))
+ enddo
+ l0 = l0 + int(dsnew(4)/dsold(4))
+ enddo
+ k0 = k0 + int(dsnew(3)/dsold(3))
+ enddo
+ j0 = j0 + int(dsnew(2)/dsold(2))
+ enddo
+ i0 = i0 + int(dsnew(1)/dsold(1))
+ enddo
+ END SELECT
+C
+ Return
+C
+C
+ End Subroutine Agrif_CopynD
+C
+C
+C
+ End module Agrif_Save
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modtypes.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modtypes.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modtypes.F (revision 8155)
@@ -0,0 +1,460 @@
+C Agrif (Adaptive Grid Refinement In Fortran)
+C
+C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
+C Christophe Vouland (Christophe.Vouland@imag.fr)
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 59 Temple Place-Suite 330, Boston, MA 02111-1307, USA.
+C
+C
+C
+CCC Module Agrif_types
+C
+ Module Agrif_types
+C
+CCC Description:
+CCC Definition of data types used in Agrif, of several variables and
+C PARAMETERs.
+C
+ IMPLICIT NONE
+
+C Maximum refinement ratio
+
+ INTEGER, PARAMETER :: Agrif_MaxRaff = 7
+
+C Maximum number of grids of the hierarchy
+ INTEGER, PARAMETER :: Agrif_NbMaxGrids = 10
+C MPI Communicator
+ INTEGER :: MPI_COMM_AGRIF
+C
+C **************************************************************************
+CCC TYPE Agrif_LRECTANGLE
+C **************************************************************************
+C
+CCC Description:
+CCC Data TYPE allowing a grid to reach a grid on the same level or its child
+CCC grids.
+C
+ TYPE Agrif_lrectangle
+ TYPE(Agrif_rectangle) , Pointer :: r ! to reach a child grid
+ TYPE(Agrif_lrectangle), Pointer :: next ! to reach a grid on the
+ ! same level
+ End TYPE Agrif_lrectangle
+C
+C **************************************************************************
+CCC TYPE Agrif_RECTANGLE:
+C **************************************************************************
+C
+CCC Description:
+CCC Data TYPE to define several CHARACTERistics of a grid (number,position,
+CCC time and space refinement factors,...).
+C
+ TYPE Agrif_rectangle
+ INTEGER :: number ! Number of the grid
+ ! Number of child grids
+ INTEGER :: nbgridchild
+ ! Minimal position in the x,y and z direction
+ INTEGER, DIMENSION(3) :: imin
+ ! Maximal position in the x,y and z direction
+ INTEGER, DIMENSION(3) :: imax
+ ! Space refinement factor in the x,y and z direction
+ INTEGER, DIMENSION(3) :: spaceref
+ ! Time refinement factor in the x,y and z direction
+ INTEGER, DIMENSION(3) :: timeref
+ ! Pointer to reach a grid on the same level or a child grid
+ TYPE(Agrif_lrectangle), Pointer :: childgrids
+ End TYPE Agrif_rectangle
+C
+C
+C
+C **************************************************************************
+CCC TYPE Agrif_PGrid
+C **************************************************************************
+C
+CCC Description:
+CCC Data TYPE to go over the grid hierarchy (used for the creation of this
+CCC grid hierarchy and during the time integration).
+C
+ TYPE Agrif_pgrid
+ ! allows to reach a child grid
+ TYPE(Agrif_grid) , Pointer :: gr
+ ! allows to reach the grids of the same level
+ TYPE(Agrif_pgrid), Pointer :: next
+ End TYPE Agrif_pgrid
+C
+C
+C
+C **************************************************************************
+CCC TYPE Agrif_PVariable
+C **************************************************************************
+C
+CCC Description:
+CCC Data TYPE to define a grid variable.
+C
+ TYPE Agrif_PVariable
+ ! This field allows to get the various CHARACTERistics
+ ! of the variable (defined by the Agrif_Variable data TYPE)
+ TYPE(Agrif_Variable) , Pointer :: var
+ ! Pointer on the parent grid
+ TYPE(Agrif_PVariable), Pointer :: parent_var
+ End TYPE Agrif_PVariable
+C
+C **************************************************************************
+CCC TYPE Agrif_Grid
+C **************************************************************************
+C
+CCC Description:
+CCC Data TYPE to define a grid (position, space and time refinement factors).
+C
+ TYPE Agrif_grid
+ ! pointer on the parent grid
+ TYPE(Agrif_grid) ,Pointer :: parent
+ ! pointer on the child grids
+ TYPE(Agrif_pgrid) ,Pointer :: child_grids
+ ! List of the grid variables
+ TYPE(Agrif_PVariable), DIMENSION(:) ,Pointer :: tabvars
+ ! pointer on the save grid
+ TYPE(Agrif_grid) ,Pointer :: save_grid
+C
+ ! Global x,y and z position
+ REAL ,DIMENSION(3) :: Agrif_x
+ ! Global space step in the x,y and z direction
+ REAL ,DIMENSION(3) :: Agrif_d
+ ! number of cells in the x,y and z direction
+ INTEGER ,DIMENSION(3) :: nb
+ ! minimal position in the x,y and z direction
+ INTEGER ,DIMENSION(3) :: ix
+ ! Space refinement factor in the x,y and z direction
+ INTEGER ,DIMENSION(3) :: spaceref
+ ! Time refinement factor in the x,y and z direction
+ INTEGER ,DIMENSION(3) :: timeref
+ INTEGER ,DIMENSION(:) ,Pointer :: restore1D
+ INTEGER ,DIMENSION(:,:) ,Pointer :: restore2D
+ INTEGER ,DIMENSION(:,:,:) ,Pointer :: restore3D
+ INTEGER ,DIMENSION(:,:,:,:) ,Pointer :: restore4D
+ INTEGER ,DIMENSION(:,:,:,:,:) ,Pointer :: restore5D
+ INTEGER ,DIMENSION(:,:,:,:,:,:),Pointer :: restore6D
+ ! number of time step
+ INTEGER :: ngridstep
+ INTEGER :: rank
+ !moving grid id
+ INTEGER :: grid_id
+ ! number of the grid
+ INTEGER :: fixedrank
+ ! fixed or moving grid ?
+ LOGICAL :: fixed
+ LOGICAL :: oldgrid
+C LOGICALs indicating if the current grid has a common border
+C with the root coarse grid
+ LOGICAL ,DIMENSION(3) :: NearRootBorder
+ LOGICAL ,DIMENSION(3) :: DistantRootBorder
+C Arrays for adaptive grid refinement
+ REAL ,DIMENSION(:) ,Pointer :: valtabpoint1D
+ REAL ,DIMENSION(:,:) ,Pointer :: valtabpoint2D
+ REAL ,DIMENSION(:,:,:) ,Pointer :: valtabpoint3D
+ INTEGER ,DIMENSION(:) ,Pointer :: tabpoint1D
+ INTEGER ,DIMENSION(:,:) ,Pointer :: tabpoint2D
+ INTEGER ,DIMENSION(:,:,:) ,Pointer :: tabpoint3D
+ Type(Agrif_List_Variables), Pointer :: variables=>NULL()
+ INTEGER :: NbVariables = 0
+ Type(Agrif_Flux), Pointer :: fluxes => NULL()
+ INTEGER :: level
+ ! level of the grid in the hierarchy
+ End TYPE Agrif_grid
+C
+C **************************************************************************
+CCC TYPE Agrif_VARIABLE
+C **************************************************************************
+C
+CCC Description:
+CCC Data TYPE to CHARACTERize a grid variable.
+C
+ TYPE Agrif_Variable
+ CHARACTER*80 :: variablename
+C
+ ! Pointer on the variable of the root grid
+ TYPE(Agrif_Variable), Pointer :: root_var
+C
+ ! index of the first point in the REAL domain (x,y and z direction)
+ INTEGER ,DIMENSION(6) :: point
+ ! position of the variable on the cell (1 for the boarder of
+ ! the edge, 2 for the center)
+ INTEGER ,DIMENSION(:) ,Pointer :: posvar => NULL()
+ ! Indication for the space interpolation (module Agrif_Boundary)
+ INTEGER ,Pointer :: interpIndex => NULL()
+ ! number of DIMENSIONs of the grid variable
+ INTEGER :: nbdim = 0
+ ! Array indicating the TYPE of DIMENSION (space or not) for
+ ! each of them
+ CHARACTER(6),DIMENSION(:) ,Pointer :: interptab => NULL()
+C Arrays containing the values of the grid variables (REAL)
+ REAL :: array0
+ REAL , DIMENSION(:) ,ALLOCATABLE :: array1
+ REAL , DIMENSION(:,:) ,ALLOCATABLE :: array2
+ REAL , DIMENSION(:,:,:) ,ALLOCATABLE :: array3
+ REAL , DIMENSION(:,:,:,:) ,ALLOCATABLE :: array4
+ REAL , DIMENSION(:,:,:,:,:) ,ALLOCATABLE :: array5
+ REAL , DIMENSION(:,:,:,:,:,:),ALLOCATABLE :: array6
+
+ REAL , DIMENSION(:) ,POINTER :: parray1
+ REAL , DIMENSION(:,:) ,POINTER :: parray2
+ REAL , DIMENSION(:,:,:) ,POINTER :: parray3
+ REAL , DIMENSION(:,:,:,:) ,POINTER :: parray4
+ REAL , DIMENSION(:,:,:,:,:) ,POINTER :: parray5
+ REAL , DIMENSION(:,:,:,:,:,:),POINTER :: parray6
+
+C Arrays containing the values of the grid variables (REAL*8)
+ REAL*8 :: darray0
+ REAL*8, DIMENSION(:) ,ALLOCATABLE :: darray1
+ REAL*8, DIMENSION(:,:) ,ALLOCATABLE :: darray2
+ REAL*8, DIMENSION(:,:,:) ,ALLOCATABLE :: darray3
+ REAL*8, DIMENSION(:,:,:,:) ,ALLOCATABLE :: darray4
+ REAL*8, DIMENSION(:,:,:,:,:) ,ALLOCATABLE :: darray5
+ REAL*8, DIMENSION(:,:,:,:,:,:),ALLOCATABLE :: darray6
+C Arrays containing the values of the grid variables (REAL*4)
+ REAL*4 :: sarray0
+ REAL*4, DIMENSION(:) ,ALLOCATABLE :: sarray1
+ REAL*4, DIMENSION(:,:) ,ALLOCATABLE :: sarray2
+ REAL*4, DIMENSION(:,:,:) ,ALLOCATABLE :: sarray3
+ REAL*4, DIMENSION(:,:,:,:) ,ALLOCATABLE :: sarray4
+ REAL*4, DIMENSION(:,:,:,:,:) ,ALLOCATABLE :: sarray5
+ REAL*4, DIMENSION(:,:,:,:,:,:),ALLOCATABLE :: sarray6
+C Arrays containing the values of the grid variables (LOGICAL)
+ LOGICAL :: larray0
+ LOGICAL, DIMENSION(:) ,ALLOCATABLE :: larray1
+ LOGICAL, DIMENSION(:,:) ,ALLOCATABLE :: larray2
+ LOGICAL, DIMENSION(:,:,:) ,ALLOCATABLE :: larray3
+ LOGICAL, DIMENSION(:,:,:,:) ,ALLOCATABLE :: larray4
+ LOGICAL, DIMENSION(:,:,:,:,:) ,ALLOCATABLE :: larray5
+ LOGICAL, DIMENSION(:,:,:,:,:,:),ALLOCATABLE :: larray6
+C Arrays containing the values of the grid variables (INTEGER)
+ INTEGER :: iarray0
+ INTEGER, DIMENSION(:) ,ALLOCATABLE :: iarray1
+ INTEGER, DIMENSION(:,:) ,ALLOCATABLE :: iarray2
+ INTEGER, DIMENSION(:,:,:) ,ALLOCATABLE :: iarray3
+ INTEGER, DIMENSION(:,:,:,:) ,ALLOCATABLE :: iarray4
+ INTEGER, DIMENSION(:,:,:,:,:) ,ALLOCATABLE :: iarray5
+ INTEGER, DIMENSION(:,:,:,:,:,:),ALLOCATABLE :: iarray6
+C
+ INTEGER, DIMENSION(:) ,Pointer :: restore1D => NULL()
+ INTEGER, DIMENSION(:,:) ,Pointer :: restore2D => NULL()
+ INTEGER, DIMENSION(:,:,:) ,Pointer :: restore3D => NULL()
+ INTEGER, DIMENSION(:,:,:,:) ,Pointer :: restore4D => NULL()
+ INTEGER, DIMENSION(:,:,:,:,:) ,Pointer :: restore5D => NULL()
+ INTEGER, DIMENSION(:,:,:,:,:,:),Pointer :: restore6D => NULL()
+C
+ CHARACTER(2050) :: carray0
+ CHARACTER(200), DIMENSION(:) ,ALLOCATABLE :: carray1
+ CHARACTER(200), DIMENSION(:,:) ,ALLOCATABLE :: carray2
+C
+ ! Array used for the time interpolation
+ REAL , DIMENSION(:,:) ,Pointer :: oldvalues2D => NULL()
+
+ ! if the variable should be restore -> =1
+ LOGICAL :: restaure = .FALSE.
+ ! the interpolation should be made in any case
+ LOGICAL :: Interpolationshouldbemade = .FALSE.
+ INTEGER :: bcinf ! option bc
+ INTEGER :: bcsup ! option bc
+ INTEGER, DIMENSION(6) :: updateinf ! option update
+ INTEGER, DIMENSION(6) :: updatesup ! option update
+ INTEGER, DIMENSION(6,6) :: bcTYPEinterp ! option bcinterp
+ INTEGER, DIMENSION(6) :: TYPEinterp ! option interp
+ INTEGER, DIMENSION(6) :: TYPEupdate ! option update
+
+ INTEGER, DIMENSION(6) :: lb, ub
+
+ Type(Agrif_List_Interp_Loc), Pointer :: list_interp => NULL()
+ Type(Agrif_List_Interp_Loc), Pointer :: list_update => NULL()
+C
+ End TYPE Agrif_Variable
+
+ Type Agrif_Interp_Loc
+ integer,dimension(6) :: pttab,petab,
+ & pttab_Child,pttab_Parent = -99
+ integer,dimension(6) :: indmin, indmax
+ INTEGER,DIMENSION(6) :: pttruetab,cetruetab
+ logical :: member, memberin
+#if !defined key_mpp_mpi
+ integer,dimension(6) :: indminglob,indmaxglob
+#else
+ integer,dimension(6) :: indminglob2,indmaxglob2
+ INTEGER,DIMENSION(6,2,2) :: parentarray
+ INTEGER,DIMENSION(:,:,:), POINTER :: tab4t
+ LOGICAL, DIMENSION(:), POINTER :: memberinall
+ INTEGER,DIMENSION(:,:,:), POINTER :: tab5t
+ LOGICAL, DIMENSION(:), POINTER :: memberinall2
+ LOGICAL, DIMENSION(:), POINTER :: sendtoproc1
+ LOGICAL, DIMENSION(:), POINTER :: recvfromproc1
+ LOGICAL, DIMENSION(:), POINTER :: sendtoproc2
+ LOGICAL, DIMENSION(:), POINTER :: recvfromproc2
+#endif
+ End Type Agrif_Interp_Loc
+
+ Type Agrif_List_Interp_Loc
+ Type(Agrif_Interp_Loc), Pointer :: interp_loc
+ Type(Agrif_List_Interp_Loc), Pointer :: suiv
+ End Type Agrif_List_Interp_Loc
+
+ TYPE Agrif_List_Variables
+ Type(Agrif_PVariable), Pointer :: pvar
+ Type(Agrif_List_Variables), Pointer :: nextvariable => NULL()
+ END TYPE Agrif_List_Variables
+
+ TYPE Agrif_Profile
+ character*80 :: profilename
+C
+ ! index of the first point in the REAL domain (x,y and z direction)
+ INTEGER ,DIMENSION(6) :: point
+ ! position of the variable on the cell (1 for the boarder of
+ ! the edge, 2 for the center)
+ INTEGER ,DIMENSION(:) ,Pointer :: posvar => NULL()
+ ! Indication for the space interpolation (module Agrif_Boundary)
+ INTEGER ,Pointer :: interpIndex => NULL()
+ ! number of DIMENSIONs of the grid variable
+ INTEGER :: nbdim = 0
+ ! Array indicating the TYPE of DIMENSION (space or not) for
+ ! each of them
+ CHARACTER(6),DIMENSION(:) ,Pointer :: interptab => NULL()
+ Type(Agrif_Variable), Pointer :: var
+ Type(Agrif_Profile), Pointer :: nextprofile => NULL()
+ END TYPE Agrif_Profile
+
+ Type(Agrif_Profile), Pointer :: Agrif_MyProfiles => NULL()
+
+C Boundaries Fluxes
+
+ Type Agrif_Flux
+ Character*80 fluxname
+ Type(Agrif_Variable), Pointer :: fluxtabx
+ Type(Agrif_Variable), Pointer :: fluxtaby
+ Type(Agrif_Variable), Pointer :: fluxtabz
+ Type(Agrif_Profile), Pointer :: profile
+ Logical :: Fluxallocated = .FALSE.
+ Type(Agrif_Flux), Pointer :: nextflux => NULL()
+ End Type Agrif_Flux
+C
+C **************************************************************************
+CCC Different PARAMETERs
+C **************************************************************************
+ TYPE(Agrif_PVariable), DIMENSION(:) ,Pointer :: Agrif_tabvars
+C
+ ! this pointer always points on the root grid of the grid hierarchy
+ TYPE(Agrif_grid) ,Pointer :: Agrif_Mygrid
+ ! Pointer used in the Agrif_regrid subroutine (Agrif_Util module).
+ ! It contains the safeguard of the grid hierarchy.
+ TYPE(Agrif_pgrid) ,Pointer :: Agrif_oldmygrid
+ ! pointer to the current grid (the link is done by using the
+ ! Agrif_Instance procedure (module Agrif_Init))
+ TYPE(Agrif_grid) ,Pointer :: Agrif_Curgrid
+ ! Pointer used in the Agrif_ChildGrid_to_ParentGrid and
+ ! Agrif_ParentGrid_to_ChildGrid subroutines
+ ! (Agrif_CurgridFunctions module). It contains the
+ ! safeguard of the current grid hierarchy.
+ TYPE(Agrif_grid) ,Pointer :: Agrif_saveCURGRID
+C
+ ! Problem DIMENSION
+ INTEGER :: Agrif_Probdim
+ ! number of variables
+ INTEGER :: Agrif_NbVariables
+ ! number of fixed grids in the grid hierarchy
+ INTEGER :: Agrif_nbfixedgrids
+ ! space refinement factor
+ INTEGER ,DIMENSION(3) :: Agrif_coeffref
+ ! time refinement factor
+ INTEGER ,DIMENSION(3) :: Agrif_coeffreft
+ ! LOGICAL to use special values on the parent grid
+ LOGICAL :: Agrif_UseSpecialValue
+ ! LOGICAL to use special values on the parent grid
+ LOGICAL :: Agrif_UseSpecialValueInUpdate
+ ! LOGICAL to use special values on the current grid
+ LOGICAL :: Agrif_UseSpecialValueFineGrid
+ ! Special values on the parent grid
+ REAL :: Agrif_SpecialValue
+ ! Special values on the current grid
+ REAL :: Agrif_SpecialValueFineGrid
+C clustering PARAMETERs
+ INTEGER :: Agrif_Regridding = 10
+ INTEGER :: Agrif_Minwidth
+ REAL :: Agrif_Efficiency = 0.7
+ INTEGER :: MaxSearch = 5
+ REAL ,DIMENSION(3) :: Agrif_mind
+C PARAMETERs for the interpolation of the child grids
+ ! linear interpolation
+ INTEGER ,PARAMETER :: Agrif_linear=1
+ ! lagrange interpolation
+ INTEGER ,PARAMETER :: Agrif_lagrange=2
+ ! spline interpolation
+ INTEGER ,PARAMETER :: Agrif_eno=3
+ ! user s interpolation
+ INTEGER ,PARAMETER :: Agrif_user_interp=4
+ ! constant interpolation
+ INTEGER ,PARAMETER :: Agrif_constant=5
+ ! linear conservative interpolation
+ INTEGER ,PARAMETER :: Agrif_linearconserv=6
+ ! linear conservative interpolation
+ INTEGER ,PARAMETER :: Agrif_linearconservlim=7
+ INTEGER ,PARAMETER :: Agrif_ppm=8
+ INTEGER ,PARAMETER :: Agrif_weno=9
+C PARAMETERs for the update of the parent grids
+ INTEGER ,PARAMETER :: Agrif_Update_Copy=1 ! copy
+ INTEGER ,PARAMETER :: Agrif_Update_Average=2 ! average
+ INTEGER ,PARAMETER :: Agrif_Update_Full_Weighting=3 ! full-weighting
+C Raffinement grid switch definition
+ ! Agrif_USE_ONLY_FIXED_GRIDS =1 if fixed grid mode
+ INTEGER :: Agrif_USE_ONLY_FIXED_GRIDS
+ ! Agrif_USE_FIXED_GRIDS = 1 if AMR mode + fixed grid
+ ! else only AMR mode
+ INTEGER :: Agrif_USE_FIXED_GRIDS
+ INTEGER :: Agrif_Maxlevelloc
+C
+#ifdef key_mpp_mpi
+ INTEGER :: Agrif_Nbprocs ! Number of processors
+ INTEGER :: Agrif_ProcRank ! Rank of the current processor
+ INTEGER :: Agrif_Group ! Group associated to MPI_COMM_AGRIF
+ INTEGER :: Agrif_MPIPREC
+#endif
+C
+ contains
+C
+ Integer Function agrif_ceiling(x)
+C
+ Real :: x
+ Integer ::i
+C
+ i = floor(x)
+C
+ if( abs(x - i).le.0.0001 )then
+ agrif_ceiling = i
+ else
+ agrif_ceiling = i+1
+ endif
+C
+ End Function
+C
+ Integer Function agrif_int(x)
+C
+ Real :: x
+ Integer ::i
+C
+ i = floor(x) + 1
+C
+ if( abs(x - i).le.0.0001 )then
+ agrif_int = i
+ else
+ agrif_int = i-1
+ endif
+C
+ End Function
+ End Module Agrif_TYPEs
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modupdate.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modupdate.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modupdate.F (revision 8155)
@@ -0,0 +1,2677 @@
+!
+! $Id: modupdate.F 2731 2011-04-08 12:05:35Z rblod $
+!
+C AGRIF (Adaptive Grid Refinement In Fortran)
+C
+C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
+C Christophe Vouland (Christophe.Vouland@imag.fr)
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.
+C
+C
+C
+CCC Module Agrif_Update
+C
+ Module Agrif_Update
+C
+CCC Description:
+CCC Module to update a parent grid from its child grids
+C
+C Modules used:
+C
+ Use Agrif_Updatebasic
+c Use Agrif_Boundary
+ Use Agrif_Arrays
+ Use Agrif_CurgridFunctions
+ Use Agrif_Mask
+#ifdef key_mpp_mpi
+ Use Agrif_mpp
+#endif
+C
+ IMPLICIT NONE
+ logical, private :: precomputedone(7) = .FALSE.
+C
+ CONTAINS
+C Define procedures contained in this module
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Update_1d
+C **************************************************************************
+C
+ Subroutine Agrif_Update_1d(TypeUpdate,parent,child,tab,deb,fin,
+ & procname)
+C
+CCC Description:
+CCC Subroutine to update a 1D grid variable on the parent grid.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update (copy or average)
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
+ INTEGER, DIMENSION(6) :: deb,fin ! Positions where interpolations
+ ! are done on the fine grid
+ External :: procname
+ Optional :: procname
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1)
+ & ), Target :: tab ! Result
+C
+C
+C Definition of a temporary AGRIF_PVariable data TYPE
+ allocate(childtemp % var)
+C
+C Pointer on the root variable
+ childtemp % var % root_var => child % var %root_var
+C
+C Number of dimensions of the grid variable
+ childtemp % var % nbdim = 1
+C
+C Values on the current grid used for the update
+C childtemp % var % array1 => tab
+
+ childtemp % var % lb = child % var % lb
+ childtemp % var % ub = child % var % ub
+
+C childtemp % var % list_update => child%var%list_update
+
+C
+
+ IF (present(procname)) THEN
+ CALL Agrif_UpdateVariable
+ & (TypeUpdate,parent,child,deb,fin,procname)
+ ELSE
+ CALL Agrif_UpdateVariable
+ & (TypeUpdate,parent,child,deb,fin)
+ ENDIF
+C
+C child % var % list_update => childtemp%var%list_update
+
+ deallocate(childtemp % var)
+C
+C
+ End Subroutine Agrif_Update_1D
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Update_2d
+C **************************************************************************
+C
+
+ Subroutine Agrif_Update_2d(TypeUpdate,parent,child,tab,deb,fin,
+ & procname)
+C
+CCC Description:
+CCC Subroutine to update a 2D grid variable on the parent grid.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update (copy or average)
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
+ INTEGER, DIMENSION(6) :: deb,fin ! Positions where interpolations
+ ! are done on the fine grid
+
+ External :: procname
+ Optional :: procname
+
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1),
+ & child%var%lb(2):child%var%ub(2)
+ & ), Target :: tab ! Result
+C
+C
+C Definition of a temporary AGRIF_PVariable data TYPE
+ allocate(childtemp % var)
+C
+C Pointer on the root variable
+ childtemp % var % root_var => child % var %root_var
+C
+C Number of dimensions of the grid variable
+ childtemp % var % nbdim = 2
+C
+C Values on the current grid used for the update
+C childtemp % var % array2 => tab
+
+ childtemp % var % lb = child % var % lb
+ childtemp % var % ub = child % var % ub
+
+C childtemp % var % list_update => child%var%list_update
+C
+ IF (present(procname)) THEN
+ CALL Agrif_UpdateVariable
+ & (TypeUpdate,parent,child,deb,fin,procname)
+ ELSE
+ CALL Agrif_UpdateVariable
+ & (TypeUpdate,parent,child,deb,fin)
+ ENDIF
+C
+C child % var % list_update => childtemp%var%list_update
+
+ deallocate(childtemp % var)
+C
+C
+ End Subroutine Agrif_Update_2D
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Update_3d
+C **************************************************************************
+C
+ Subroutine Agrif_Update_3d(TypeUpdate,parent,child,tab,deb,fin,
+ & procname)
+C
+CCC Description:
+CCC Subroutine to update a 3D grid variable on the parent grid.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update (copy or average)
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
+ INTEGER, DIMENSION(6) :: deb,fin ! Positions where interpolations
+ ! are done on the fine grid
+ External :: procname
+ Optional :: procname
+
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1),
+ & child%var%lb(2):child%var%ub(2),
+ & child%var%lb(3):child%var%ub(3)
+ & ), Target :: tab ! Results
+C
+C
+C Definition of a temporary AGRIF_PVariable data TYPE
+ allocate(childtemp % var)
+C
+C Pointer on the root variable
+ childtemp % var % root_var => child % var %root_var
+C
+C Number of dimensions of the grid variable
+ childtemp % var % nbdim = 3
+C
+C Values on the current grid used for the update
+C childtemp % var % array3 => tab
+
+ childtemp % var % lb = child % var % lb
+ childtemp % var % ub = child % var % ub
+
+
+C childtemp % var % list_update => child%var%list_update
+C
+ IF (present(procname)) THEN
+ CALL Agrif_UpdateVariable
+ & (TypeUpdate,parent,child,deb,fin,procname)
+ ELSE
+ CALL Agrif_UpdateVariable
+ & (TypeUpdate,parent,child,deb,fin)
+ ENDIF
+C
+C child % var % list_update => childtemp%var%list_update
+
+ DEALLOCATE(childtemp % var)
+C
+C
+ End Subroutine Agrif_Update_3D
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Update_4d
+C **************************************************************************
+C
+ Subroutine Agrif_Update_4d(TypeUpdate,parent,child,tab,deb,fin,
+ & procname)
+C
+CCC Description:
+CCC Subroutine to update a 4D grid variable on the parent grid.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update (copy or average)
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
+ INTEGER, DIMENSION(6) :: deb,fin ! Positions where interpolations
+ ! are done on the fine grid
+ External :: procname
+ Optional :: procname
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1),
+ & child%var%lb(2):child%var%ub(2),
+ & child%var%lb(3):child%var%ub(3),
+ & child%var%lb(4):child%var%ub(4)
+ & ), Target :: tab ! Results
+C
+C
+C Definition of a temporary AGRIF_PVariable data TYPE
+ allocate(childtemp % var)
+C
+C Pointer on the root variable
+ childtemp % var % root_var => child % var %root_var
+C
+C Number of dimensions of the grid variable
+ childtemp % var % nbdim = 4
+C
+C Values on the current grid used for the update
+C childtemp % var % array4 => tab
+
+ childtemp % var % lb = child % var % lb
+ childtemp % var % ub = child % var % ub
+
+
+C childtemp % var % list_update => child%var%list_update
+
+C
+ IF (present(procname)) THEN
+ CALL Agrif_UpdateVariable
+ & (TypeUpdate,parent,child,deb,fin,procname)
+ ELSE
+ CALL Agrif_UpdateVariable
+ & (TypeUpdate,parent,child,deb,fin)
+ ENDIF
+
+C child % var % list_update => childtemp%var%list_update
+C
+ deallocate(childtemp % var)
+C
+C
+ End Subroutine Agrif_Update_4D
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Update_5d
+C **************************************************************************
+C
+ Subroutine Agrif_Update_5d(TypeUpdate,parent,child,tab,deb,fin,
+ & procname)
+C
+CCC Description:
+CCC Subroutine to update a 5D grid variable on the parent grid.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update (copy or average)
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
+ INTEGER, DIMENSION(6) :: deb,fin ! Positions where interpolations
+ ! are done on the fine grid
+ External :: procname
+ Optional :: procname
+
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1),
+ & child%var%lb(2):child%var%ub(2),
+ & child%var%lb(3):child%var%ub(3),
+ & child%var%lb(4):child%var%ub(4),
+ & child%var%lb(5):child%var%ub(5)
+ & ), Target :: tab ! Results
+C
+C
+C Definition of a temporary AGRIF_PVariable data TYPE
+ allocate(childtemp % var)
+C
+C Pointer on the root variable
+ childtemp % var % root_var => child % var %root_var
+C
+C Number of dimensions of the grid variable
+ childtemp % var % nbdim = 5
+C
+C Values on the current grid used for the update
+C childtemp % var % array5 => tab
+
+ childtemp % var % lb = child % var % lb
+ childtemp % var % ub = child % var % ub
+
+C childtemp % var % list_update => child%var%list_update
+C
+ IF (present(procname)) THEN
+ CALL Agrif_UpdateVariable
+ & (TypeUpdate,parent,child,deb,fin,procname)
+ ELSE
+ CALL Agrif_UpdateVariable
+ & (TypeUpdate,parent,child,deb,fin)
+ ENDIF
+
+C child % var % list_update => childtemp%var%list_update
+
+C
+ deallocate(childtemp % var)
+C
+C
+ End Subroutine Agrif_Update_5D
+C
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Update_6d
+C **************************************************************************
+C
+ Subroutine Agrif_Update_6d(TypeUpdate,parent,child,tab,deb,fin)
+C
+CCC Description:
+CCC Subroutine to update a 6D grid variable on the parent grid.
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update (copy or average)
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ TYPE(AGRIF_PVariable) :: childtemp ! Temporary variable on the child
+ INTEGER, DIMENSION(6) :: deb,fin ! Positions where interpolations
+ ! are done on the fine grid
+ REAL, DIMENSION(
+ & child%var%lb(1):child%var%ub(1),
+ & child%var%lb(2):child%var%ub(2),
+ & child%var%lb(3):child%var%ub(3),
+ & child%var%lb(4):child%var%ub(4),
+ & child%var%lb(5):child%var%ub(5),
+ & child%var%lb(6):child%var%ub(6)
+ & ), Target :: tab ! Results
+C
+C
+C Definition of a temporary AGRIF_PVariable data TYPE
+ allocate(childtemp % var)
+C
+C Pointer on the root variable
+ childtemp % var % root_var => child % var %root_var
+C
+C Number of dimensions of the grid variable
+ childtemp % var % nbdim = 6
+C
+C Values on the current grid used for the update
+C childtemp % var % array6 => tab
+
+ childtemp % var % lb = child % var % lb
+ childtemp % var % ub = child % var % ub
+
+C childtemp % var % list_update => child%var%list_update
+C
+ Call Agrif_UpdateVariable
+ & (TypeUpdate,parent,child,deb,fin)
+
+C child % var % list_update => childtemp%var%list_update
+
+C
+ deallocate(childtemp % var)
+C
+C
+ End Subroutine Agrif_Update_6D
+C
+C
+C
+C **************************************************************************
+C Subroutine Agrif_UpdateVariable
+C **************************************************************************
+C
+ Subroutine Agrif_UpdateVariable(TypeUpdate,parent,child,deb,fin,
+ & procname)
+C
+CCC Description:
+CCC Subroutine to set arguments of Agrif_UpdatenD, n being the number of
+C dimensions of the grid variable.
+C
+CC Declarations:
+C
+c
+C
+C Scalar argument
+ INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update (copy or average)
+C Data TYPE arguments
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
+ INTEGER, DIMENSION(6) :: deb,fin ! Positions where interpolations
+ ! are calculated
+ External :: procname
+ Optional :: procname
+
+C
+C Local scalars
+ INTEGER :: nbdim ! Number of dimensions of the current
+ ! grid
+ INTEGER ,DIMENSION(6) :: pttab_child
+ INTEGER ,DIMENSION(6) :: petab_child
+ INTEGER ,DIMENSION(6) :: pttab_parent
+ REAL ,DIMENSION(6) :: s_child,s_parent
+ REAL ,DIMENSION(6) :: ds_child,ds_parent
+ INTEGER,DIMENSION(6) :: loctab_Child ! Indicates if the child
+ ! grid has a common border with
+ ! the root grid
+ TYPE(AGRIF_Variable), Pointer :: root ! Variable on the root grid
+ INTEGER,DIMENSION(6) :: posvartab_Child ! Position of the
+ ! variable on the cell
+ INTEGER,DIMENSION(6) :: nbtab_Child ! Number of the cells
+ INTEGER :: n
+ LOGICAL :: wholeupdate
+C
+C
+
+ loctab_child(:) = 0
+C
+ root => child % var % root_var
+ nbdim = root % nbdim
+C
+ do n = 1,nbdim
+ posvartab_child(n) = root % posvar(n)
+ enddo
+C
+
+ Call PreProcessToInterpOrUpdate(parent,child,
+ & petab_Child(1:nbdim),
+ & pttab_Child(1:nbdim),pttab_Parent(1:nbdim),
+ & s_Child(1:nbdim),s_Parent(1:nbdim),
+ & ds_Child(1:nbdim),ds_Parent(1:nbdim),
+ & nbdim)
+C
+C
+ do n = 1,nbdim
+C
+ Select case(root % interptab(n))
+C
+ case('x') ! x DIMENSION
+C
+ nbtab_Child(n) = Agrif_Curgrid % nb(1)
+C
+ case('y') ! y DIMENSION
+C
+ nbtab_Child(n) = Agrif_Curgrid % nb(2)
+C
+ case('z') ! z DIMENSION
+C
+ nbtab_Child(n) = Agrif_Curgrid % nb(3)
+C
+ case('N') ! No space DIMENSION
+C
+
+ nbtab_Child(n) = child % var % ub(n) - child % var % lb(n)
+C
+C No interpolation but only a copy of the values of the grid variable
+C
+ posvartab_child(n) = 1
+
+ loctab_child(n) = -3
+C
+ End select
+C
+ enddo
+
+C Call to a procedure of update according to the number of dimensions of
+C the grid variable
+
+ wholeupdate = .FALSE.
+
+ do n=1,nbdim
+ if (loctab_child(n) /= -3) then
+ if (deb(n)>fin(n)) wholeupdate = .TRUE.
+ if ((deb(n) == -99).AND.(deb(n)==fin(n))) wholeupdate=.TRUE.
+ endif
+ enddo
+
+ IF (present(procname)) THEN
+
+ IF (wholeupdate) THEN
+
+ Call AGRIF_UpdateWhole
+ & (TypeUpdate,parent,child,deb,fin,
+ & pttab_Child(1:nbdim),pttab_Parent(1:nbdim),
+ & nbtab_Child(1:nbdim),posvartab_Child(1:nbdim),
+ & loctab_Child(1:nbdim),
+ & s_Child(1:nbdim),s_Parent(1:nbdim),
+ & ds_Child(1:nbdim),ds_Parent(1:nbdim),nbdim,procname)
+ ELSE
+ Call AGRIF_UpdateBcnD
+ & (TypeUpdate,parent,child,deb,fin,
+ & pttab_Child(1:nbdim),pttab_Parent(1:nbdim),
+ & nbtab_Child(1:nbdim),posvartab_Child(1:nbdim),
+ & loctab_Child(1:nbdim),
+ & s_Child(1:nbdim),s_Parent(1:nbdim),
+ & ds_Child(1:nbdim),ds_Parent(1:nbdim),nbdim,procname)
+ ENDIF
+ ELSE
+ IF (wholeupdate) THEN
+ Call AGRIF_UpdateWhole
+ & (TypeUpdate,parent,child,deb,fin,
+ & pttab_Child(1:nbdim),pttab_Parent(1:nbdim),
+ & nbtab_Child(1:nbdim),posvartab_Child(1:nbdim),
+ & loctab_Child(1:nbdim),
+ & s_Child(1:nbdim),s_Parent(1:nbdim),
+ & ds_Child(1:nbdim),ds_Parent(1:nbdim),nbdim)
+ ELSE
+ Call AGRIF_UpdateBcnD
+ & (TypeUpdate,parent,child,deb,fin,
+ & pttab_Child(1:nbdim),pttab_Parent(1:nbdim),
+ & nbtab_Child(1:nbdim),posvartab_Child(1:nbdim),
+ & loctab_Child(1:nbdim),
+ & s_Child(1:nbdim),s_Parent(1:nbdim),
+ & ds_Child(1:nbdim),ds_Parent(1:nbdim),nbdim)
+ ENDIF
+ ENDIF
+C
+ Return
+C
+C
+ End subroutine Agrif_UpdateVariable
+C
+C **************************************************************************
+CCC Subroutine Agrif_UpdateWhole
+C **************************************************************************
+C
+ Subroutine AGRIF_UpdateWhole(TypeUpdate,parent,child,deb,fin,
+ & pttab_child,pttab_Parent,
+ & nbtab_Child,posvartab_Child,
+ & loctab_Child,
+ & s_Child,s_Parent,
+ & ds_Child,ds_Parent,nbdim,procname)
+C
+CCC Description:
+CCC Subroutine to calculate the boundary conditions for a nD grid variable on
+CCC a fine grid by using a space and time interpolations; it is called by the
+CCC Agrif_CorrectVariable procedure.
+C
+C
+C Declarations:
+C
+
+C
+#ifdef key_mpp_mpi
+C
+ INCLUDE 'mpif.h'
+C
+#endif
+C
+C Arguments
+ INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update (copy or
+ ! average)
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent
+ ! grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child
+ ! grid
+ INTEGER, DIMENSION(6) :: deb, fin
+ INTEGER :: nbdim ! Number of dimensions of
+ ! the grid variable
+ INTEGER,DIMENSION(nbdim) :: pttab_child ! Index of the first point
+ ! inside the domain for
+ ! the parent grid
+ ! variable
+ INTEGER,DIMENSION(nbdim) :: pttab_Parent ! Index of the first point
+ ! inside the domain for
+ ! the child grid
+ ! variable
+ INTEGER,DIMENSION(nbdim) :: nbtab_Child ! Number of cells of the
+ ! child grid
+ INTEGER,DIMENSION(nbdim) :: posvartab_Child ! Position of the grid
+ ! variable (1 or 2)
+ INTEGER,DIMENSION(nbdim) :: loctab_Child ! Indicates if the child
+ ! grid has a common
+ ! border with the root
+ ! grid
+ REAL ,DIMENSION(nbdim) :: s_Child,s_Parent ! Positions of the parent
+ ! and child grids
+ REAL ,DIMENSION(nbdim) :: ds_Child,ds_Parent ! Space steps of the parent
+ ! and child grids
+ External :: procname
+ Optional :: procname
+C
+C Local variables
+ INTEGER,DIMENSION(nbdim,2) :: lubglob
+ INTEGER :: i
+ INTEGER,DIMENSION(nbdim,2,2) :: indtab ! Arrays indicating the
+ ! limits of the child
+ INTEGER,DIMENSION(nbdim,2,2) :: indtruetab ! grid variable where
+ ! boundary conditions are
+ integer :: coeffraf
+ INTEGER :: debloc, finloc
+C
+#ifdef key_mpp_mpi
+C
+ INTEGER,DIMENSION(nbdim) :: lb,ub
+ INTEGER,DIMENSION(nbdim,2) :: iminmaxg
+ INTEGER :: code
+C
+#endif
+C
+C
+C indtab contains the limits for the fine grid points that will be used
+C in the update scheme
+
+ DO i = 1, nbdim
+ coeffraf = nint(ds_Parent(i)/ds_Child(i))
+ debloc = 0
+ finloc = nbtab_Child(i)/coeffraf - 1
+
+ IF (posvartab_child(i) == 1) THEN
+ finloc = finloc - 1
+ ENDIF
+
+ IF (deb(i) > fin(i)) THEN
+ debloc = deb(i)
+ finloc = finloc - deb(i)
+ ENDIF
+
+ indtab(i,1,1) = pttab_child(i) + (debloc + 1) * coeffraf
+ indtab(i,1,2) = pttab_child(i) + (finloc + 1) * coeffraf
+
+ IF (posvartab_child(i) == 1) THEN
+ IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
+ indtab(i,1,1) = indtab(i,1,1) - (coeffraf - 1)
+ indtab(i,1,2) = indtab(i,1,2) + (coeffraf - 1)
+ ELSE IF (TypeUpdate(i) .NE. Agrif_Update_Copy) THEN
+ indtab(i,1,1) = indtab(i,1,1) - coeffraf / 2
+ indtab(i,1,2) = indtab(i,1,2) + coeffraf / 2
+ ENDIF
+ ELSE
+ indtab(i,1,1) = indtab(i,1,1) - coeffraf
+ indtab(i,1,2) = indtab(i,1,2) - 1
+C at this point, indices are OK for an average
+ IF ((TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting)) THEN
+ indtab(i,1,1) = indtab(i,1,1) - coeffraf/2
+ indtab(i,1,2) = indtab(i,1,2) + coeffraf/2
+ ENDIF
+ ENDIF
+ IF (loctab_child(i) == -3) THEN
+ indtab(i,1,1) = pttab_child(i)
+C
+ if (posvartab_child(i) == 1) then
+C
+ indtab(i,1,2) = pttab_child(i) + nbtab_child(i)
+C
+ else
+C
+ indtab(i,1,2) = pttab_child(i) + nbtab_child(i) - 1
+ ENDIF
+ ENDIF
+ ENDDO
+
+C lubglob contains the global lbound and ubound of the child array
+C lubglob(:,1) : global lbound for each dimension
+C lubglob(:,2) : global lbound for each dimension
+
+#if !defined key_mpp_mpi
+ Call Agrif_nbdim_Get_bound_dimension(child % var,lubglob(:,1),
+ & lubglob(:,2),nbdim)
+C
+#else
+C
+ Call Agrif_nbdim_Get_bound_dimension(child % var,lb,ub,nbdim)
+ DO i = 1,nbdim
+C
+ Call Agrif_Invloc(lb(i),Agrif_Procrank,i,iminmaxg(i,1))
+ Call Agrif_Invloc(ub(i),Agrif_Procrank,i,iminmaxg(i,2))
+C
+ ENDDO
+C
+ iminmaxg(1:nbdim,2) = - iminmaxg(1:nbdim,2)
+
+ CALL MPI_ALLREDUCE(iminmaxg,lubglob,2*nbdim,MPI_INTEGER,MPI_MIN,
+ & MPI_COMM_AGRIF,code)
+
+ lubglob(1:nbdim,2) = - lubglob(1:nbdim,2)
+C
+#endif
+C
+ indtruetab(1:nbdim,1,1) = max(indtab(1:nbdim,1,1),
+ & lubglob(1:nbdim,1))
+ indtruetab(1:nbdim,1,2) = min(indtab(1:nbdim,1,2),
+ & lubglob(1:nbdim,2))
+
+C
+C
+ IF (present(procname)) THEN
+ Call Agrif_UpdatenD
+ & (TypeUpdate,parent,child,
+ & indtruetab(1:nbdim,1,1),indtruetab(1:nbdim,1,2),
+ & pttab_child(1:nbdim),pttab_Parent(1:nbdim),
+ & s_Child(1:nbdim),s_Parent(1:nbdim),
+ & ds_Child(1:nbdim),ds_Parent(1:nbdim),
+ & posvartab_child,loctab_Child,
+ & nbdim,procname)
+ ELSE
+ Call Agrif_UpdatenD
+ & (TypeUpdate,parent,child,
+ & indtruetab(1:nbdim,1,1),indtruetab(1:nbdim,1,2),
+ & pttab_child(1:nbdim),pttab_Parent(1:nbdim),
+ & s_Child(1:nbdim),s_Parent(1:nbdim),
+ & ds_Child(1:nbdim),ds_Parent(1:nbdim),
+ & posvartab_child,loctab_Child,
+ & nbdim)
+ ENDIF
+C
+C
+C
+ End Subroutine Agrif_UpdateWhole
+C
+C **************************************************************************
+CCC Subroutine Agrif_UpdateBcnd
+C **************************************************************************
+C
+ Subroutine AGRIF_UpdateBcnd(TypeUpdate,parent,child,deb,fin,
+ & pttab_child,pttab_Parent,
+ & nbtab_Child,posvartab_Child,
+ & loctab_Child,
+ & s_Child,s_Parent,
+ & ds_Child,ds_Parent,nbdim,procname)
+C
+CCC Description:
+CCC Subroutine to calculate the boundary conditions for a nD grid variable on
+CCC a fine grid by using a space and time interpolations; it is called by the
+CCC Agrif_CorrectVariable procedure.
+C
+C
+C Declarations:
+C
+
+C
+#ifdef key_mpp_mpi
+C
+ INCLUDE 'mpif.h'
+C
+#endif
+C
+C Arguments
+ INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update
+ ! (copy or average)
+ TYPE(AGRIF_PVariable) :: parent ! Variable on the parent
+ ! grid
+ TYPE(AGRIF_PVariable) :: child ! Variable on the child
+ ! grid
+ INTEGER, DIMENSION(6) :: deb, fin
+ INTEGER :: nbdim ! Number of dimensions of
+ ! the grid variable
+ INTEGER,DIMENSION(nbdim) :: pttab_child ! Index of the first point
+ ! inside the domain for
+ ! the parent grid
+ ! variable
+ INTEGER,DIMENSION(nbdim) :: pttab_Parent ! Index of the first point
+ ! inside the domain for
+ ! the child grid variable
+ INTEGER,DIMENSION(nbdim) :: nbtab_Child ! Number of cells of the
+ ! child grid
+ INTEGER,DIMENSION(nbdim) :: posvartab_Child ! Position of the grid
+ ! variable (1 or 2)
+ INTEGER,DIMENSION(nbdim) :: loctab_Child ! Indicates if the child
+ ! grid has a common
+ ! border with the root
+ ! grid
+ REAL ,DIMENSION(nbdim) :: s_Child,s_Parent ! Positions of the parent
+ ! and child grids
+ REAL ,DIMENSION(nbdim) :: ds_Child,ds_Parent ! Space steps of the parent
+ ! and child grids
+ External :: procname
+ Optional :: procname
+C
+C Local variables
+ INTEGER,DIMENSION(nbdim,2) :: lubglob
+ INTEGER :: i
+ INTEGER,DIMENSION(nbdim,2,2) :: indtab ! Arrays indicating the
+ ! limits of the child
+ INTEGER,DIMENSION(nbdim,2,2) :: indtruetab ! grid variable where
+ ! boundary conditions are
+ INTEGER,DIMENSION(nbdim,2,2,nbdim) :: ptres ! calculated
+ INTEGER :: nb,ndir,n
+ integer :: coeffraf
+C
+#ifdef key_mpp_mpi
+C
+ INTEGER,DIMENSION(nbdim) :: lb,ub
+ INTEGER,DIMENSION(nbdim,2) :: iminmaxg
+ INTEGER :: code
+C
+#endif
+C
+C
+
+ DO i = 1, nbdim
+ coeffraf = nint(ds_Parent(i)/ds_Child(i))
+ indtab(i,1,1) = pttab_child(i) + (deb(i) + 1) * coeffraf
+ indtab(i,1,2) = pttab_child(i) + (fin(i) + 1) * coeffraf
+
+ indtab(i,2,1) = pttab_child(i) + nbtab_child(i)
+ & - (fin(i) + 1) * coeffraf
+ indtab(i,2,2) = pttab_child(i) + nbtab_child(i)
+ & - (deb(i) + 1) * coeffraf
+
+ IF (posvartab_child(i) == 1) THEN
+ IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
+ indtab(i,:,1) = indtab(i,:,1) - (coeffraf - 1)
+ indtab(i,:,2) = indtab(i,:,2) + (coeffraf - 1)
+ ELSE IF (TypeUpdate(i) .NE. Agrif_Update_Copy) THEN
+ indtab(i,:,1) = indtab(i,:,1) - coeffraf / 2
+ indtab(i,:,2) = indtab(i,:,2) + coeffraf / 2
+ ENDIF
+ ELSE
+ indtab(i,1,1) = indtab(i,1,1) - coeffraf
+ indtab(i,1,2) = indtab(i,1,2) - 1
+ indtab(i,2,2) = indtab(i,2,2) + coeffraf - 1
+ IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
+ indtab(i,1,1) = indtab(i,1,1) - coeffraf/2
+ indtab(i,1,2) = indtab(i,1,2) + coeffraf/2
+ indtab(i,2,1) = indtab(i,2,1) - coeffraf/2
+ indtab(i,2,2) = indtab(i,2,2) + coeffraf/2
+ ENDIF
+ ENDIF
+ ENDDO
+
+#if !defined key_mpp_mpi
+ Call Agrif_nbdim_Get_bound_dimension(child % var,lubglob(:,1),
+ & lubglob(:,2),nbdim)
+
+C
+#else
+C
+ Call Agrif_nbdim_Get_bound_dimension(child % var,lb,ub,nbdim)
+ DO i = 1,nbdim
+C
+ Call Agrif_Invloc(lb(i),Agrif_Procrank,i,iminmaxg(i,1))
+ Call Agrif_Invloc(ub(i),Agrif_Procrank,i,iminmaxg(i,2))
+C
+ ENDDO
+C
+ iminmaxg(1:nbdim,2) = - iminmaxg(1:nbdim,2)
+
+ CALL MPI_ALLREDUCE(iminmaxg,lubglob,2*nbdim,MPI_INTEGER,MPI_MIN,
+ & MPI_COMM_AGRIF,code)
+
+ lubglob(1:nbdim,2) = - lubglob(1:nbdim,2)
+C
+#endif
+C
+ indtruetab(1:nbdim,1,1) = max(indtab(1:nbdim,1,1),
+ & lubglob(1:nbdim,1))
+ indtruetab(1:nbdim,1,2) = max(indtab(1:nbdim,1,2),
+ & lubglob(1:nbdim,1))
+ indtruetab(1:nbdim,2,1) = min(indtab(1:nbdim,2,1),
+ & lubglob(1:nbdim,2))
+ indtruetab(1:nbdim,2,2) = min(indtab(1:nbdim,2,2),
+ & lubglob(1:nbdim,2))
+
+C
+C
+ do nb = 1,nbdim
+C
+ do ndir = 1,2
+C
+ if (loctab_child(nb) /= -3) then
+C
+ do n = 1,2
+C
+ ptres(nb,n,ndir,nb) = indtruetab(nb,ndir,n)
+C
+ enddo
+C
+ do i = 1,nbdim
+C
+ if (i .NE. nb) then
+C
+ if (loctab_child(i) == -3) then
+C
+ ptres(i,1,ndir,nb) = pttab_child(i)
+C
+ else
+C
+ ptres(i,1,ndir,nb) = indtruetab(i,1,1)
+C
+ endif
+C
+ if (loctab_child(i) == -3) then
+C
+ if (posvartab_child(i) == 1) then
+C
+ ptres(i,2,ndir,nb) = pttab_child(i)
+ & + nbtab_child(i)
+C
+ else
+C
+ ptres(i,2,ndir,nb) = pttab_child(i)
+ & + nbtab_child(i) - 1
+C
+ endif
+C
+ else
+C
+ ptres(i,2,ndir,nb) = indtruetab(i,2,2)
+C
+ endif
+C
+ endif
+C
+ enddo
+
+C
+
+ endif
+
+ enddo
+ enddo
+C
+
+C
+
+ do nb = 1,nbdim
+C
+ do ndir = 1,2
+C
+ if (loctab_child(nb) /= -3) then
+C
+ IF (present(procname)) THEN
+ Call Agrif_UpdatenD
+ & (TypeUpdate,parent,child,
+ & ptres(1:nbdim,1,ndir,nb),ptres(1:nbdim,2,ndir,nb),
+ & pttab_child(1:nbdim),pttab_Parent(1:nbdim),
+ & s_Child(1:nbdim),s_Parent(1:nbdim),
+ & ds_Child(1:nbdim),ds_Parent(1:nbdim),
+ & posvartab_Child,loctab_Child,
+ & nbdim,procname,nb,ndir)
+ ELSE
+ Call Agrif_UpdatenD
+ & (TypeUpdate,parent,child,
+ & ptres(1:nbdim,1,ndir,nb),ptres(1:nbdim,2,ndir,nb),
+ & pttab_child(1:nbdim),pttab_Parent(1:nbdim),
+ & s_Child(1:nbdim),s_Parent(1:nbdim),
+ & ds_Child(1:nbdim),ds_Parent(1:nbdim),
+ & posvartab_Child,loctab_Child,
+ & nbdim)
+ ENDIF
+C
+ endif
+
+C
+ enddo
+C
+ enddo
+C
+C
+C
+ End Subroutine Agrif_UpdateBcnd
+C
+C **************************************************************************
+CCC Subroutine Agrif_UpdatenD
+C **************************************************************************
+C
+ Subroutine Agrif_UpdatenD(TypeUpdate,parent,child,
+ & pttab,petab,
+ & pttab_Child,pttab_Parent,
+ & s_Child,s_Parent,
+ & ds_Child,ds_Parent,
+ & posvartab_Child,loctab_Child,
+ & nbdim,procname,nb,ndir)
+C
+C Description:
+C Subroutine to update a 2D grid variable on the parent grid of
+C the current grid.
+C
+C Declarations:
+C
+
+C
+#ifdef key_mpp_mpi
+C
+ INCLUDE 'mpif.h'
+C
+#endif
+C
+C Arguments
+ INTEGER :: nbdim
+ INTEGER, DIMENSION(6) :: TypeUpdate ! TYPE of update
+ ! (copy or average)
+ TYPE(AGRIF_PVARIABLE) :: parent ! Variable of the parent
+ ! grid
+ TYPE(AGRIF_PVARIABLE) :: child ! Variable of the child
+ ! grid
+ INTEGER,DIMENSION(nbdim) :: pttab ! Index of the first
+ ! point inside the
+ ! domain
+ INTEGER,DIMENSION(nbdim) :: petab ! Index of the first
+ ! point inside the
+ ! domain
+ INTEGER,DIMENSION(nbdim) :: pttab_Child ! Index of the first
+ ! point inside the
+ ! domain for the child
+ ! grid variable
+ INTEGER,DIMENSION(nbdim) :: pttab_Parent ! Index of the first
+ ! point inside the
+ ! domain for the parent
+ ! grid variable
+ REAL,DIMENSION(nbdim) :: s_Child,s_Parent ! Positions of the parent
+ ! and child grids
+ REAL,DIMENSION(nbdim) :: ds_Child,ds_Parent ! Space steps of the
+ ! parent and child
+ ! grids
+ External :: procname
+ Optional :: procname
+ Integer :: nb,ndir
+ Optional :: nb,ndir
+
+C
+C Local pointers
+ TYPE(AGRIF_PVARIABLE), SAVE :: tempP ! Temporary parent grid variable
+ TYPE(AGRIF_PVARIABLE), SAVE :: tempC ! Temporary child grid variable
+C
+C Local scalars
+ INTEGER,DIMENSION(nbdim) :: pttruetab,cetruetab
+ INTEGER,DIMENSION(nbdim) :: posvartab_Child,loctab_Child
+ INTEGER,DIMENSION(nbdim) :: indmin,indmax
+ INTEGER,DIMENSION(nbdim) :: indminglob,indmaxglob
+ REAL ,DIMENSION(nbdim) :: s_Child_temp,s_Parent_temp
+cccccccc LOGICAL,DIMENSION(nbdim) :: noraftab
+ INTEGER,DIMENSION(nbdim) :: lowerbound,upperbound
+ LOGICAL :: memberin, member
+ INTEGER,DIMENSION(nbdim) :: pttruetabwhole,cetruetabwhole
+ INTEGER,DIMENSION(nbdim,2,2) :: childarray
+ INTEGER,DIMENSION(nbdim,2,2) :: parentarray
+ TYPE(AGRIF_PVARIABLE), SAVE :: tempCextend,tempPextend ! Temporary child
+ INTEGER :: nbin, ndirin
+C
+#ifdef key_mpp_mpi
+C
+ INTEGER,DIMENSION(nbdim) :: indminglob2,indmaxglob2
+ LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc1,recvfromproc1
+ LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc2,recvfromproc2
+ INTEGER :: code
+ INTEGER :: i,j,k
+ INTEGER,DIMENSION(nbdim,4) :: tab3
+ INTEGER,DIMENSION(nbdim,4,0:Agrif_Nbprocs-1) :: tab4
+ INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab4t
+ INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab5t
+ LOGICAL :: find_list_update
+ LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall, memberinall2
+ LOGICAL, DIMENSION(1) :: memberin1
+C
+#endif
+C
+
+C
+C local lbound and ubound of the child array
+
+ Call Agrif_nbdim_Get_bound_dimension(child%var,
+ & lowerbound,upperbound,nbdim)
+
+C here pttab and petab corresponds to the (global) indices of the points needed
+C in the update
+C pttruetab and cetruetab contains only indices that are present
+C on the local processor
+
+ Call Agrif_Childbounds(nbdim,
+ & lowerbound,upperbound,
+ & pttab,petab,
+ & pttruetab,cetruetab,memberin)
+
+ Call Agrif_Prtbounds(nbdim,indminglob,indmaxglob,s_Parent_temp,
+ & s_Child_temp,s_Child,ds_Child,
+ & s_Parent,ds_Parent,
+ & pttab,petab,pttab_Child,
+ & pttab_Parent,
+ & posvartab_Child,TypeUpdate,loctab_Child
+#ifdef key_mpp_mpi
+ & ,pttruetabwhole,cetruetabwhole
+#endif
+ & )
+
+#ifdef key_mpp_mpi
+ IF (memberin) THEN
+ Call Agrif_GlobtoLocInd2(childarray,
+ & lowerbound,upperbound,
+ & pttruetab,cetruetab,
+ & nbdim,Agrif_Procrank,
+ & member)
+
+ ENDIF
+
+
+ Call Agrif_Prtbounds(nbdim,indmin,indmax,s_Parent_temp,
+ & s_Child_temp,s_Child,ds_Child,
+ & s_Parent,ds_Parent,
+ & pttruetab,cetruetab,pttab_Child,
+ & pttab_Parent,
+ & posvartab_Child,TypeUpdate,loctab_Child
+ & ,pttruetabwhole,cetruetabwhole
+ & )
+
+#else
+ indmin = indminglob
+ indmax = indmaxglob
+ pttruetabwhole = pttruetab
+ cetruetabwhole = cetruetab
+ childarray(:,1,2) = pttruetab
+ childarray(:,2,2) = cetruetab
+#endif
+
+ IF (present(procname)) THEN
+ IF (.Not.present(nb)) THEN
+ nbin=0
+ ndirin=0
+ ELSE
+ nbin = nb
+ ndirin = ndir
+ ENDIF
+ ENDIF
+
+ IF (memberin) THEN
+ IF (.not.associated(tempC%var)) allocate(tempC%var)
+
+C
+ Call Agrif_nbdim_allocation(tempC%var,
+ & pttruetab,cetruetab,nbdim)
+
+ Call Agrif_nbdim_Full_VarEQreal(tempC%var,0.,nbdim)
+
+ IF (present(procname)) THEN
+ SELECT CASE (nbdim)
+ CASE(1)
+ CALL procname(tempC%var%array1,
+ & childarray(1,1,2),childarray(1,2,2),
+ & .TRUE.,nbin,ndirin)
+ CASE(2)
+ CALL procname(tempC%var%array2,
+ & childarray(1,1,2),childarray(1,2,2),
+ & childarray(2,1,2),childarray(2,2,2),
+ & .TRUE.,nbin,ndirin)
+ CASE(3)
+ CALL procname(tempC%var%array3,
+ & childarray(1,1,2),childarray(1,2,2),
+ & childarray(2,1,2),childarray(2,2,2),
+ & childarray(3,1,2),childarray(3,2,2),
+ & .TRUE.,nbin,ndirin)
+ CASE(4)
+ CALL procname(tempC%var%array4,
+ & childarray(1,1,2),childarray(1,2,2),
+ & childarray(2,1,2),childarray(2,2,2),
+ & childarray(3,1,2),childarray(3,2,2),
+ & childarray(4,1,2),childarray(4,2,2),
+ & .TRUE.,nbin,ndirin)
+ CASE(5)
+ CALL procname(tempC%var%array5,
+ & childarray(1,1,2),childarray(1,2,2),
+ & childarray(2,1,2),childarray(2,2,2),
+ & childarray(3,1,2),childarray(3,2,2),
+ & childarray(4,1,2),childarray(4,2,2),
+ & childarray(5,1,2),childarray(5,2,2),
+ & .TRUE.,nbin,ndirin)
+ CASE(6)
+ CALL procname(tempC%var%array6,
+ & childarray(1,1,2),childarray(1,2,2),
+ & childarray(2,1,2),childarray(2,2,2),
+ & childarray(3,1,2),childarray(3,2,2),
+ & childarray(4,1,2),childarray(4,2,2),
+ & childarray(5,1,2),childarray(5,2,2),
+ & childarray(6,1,2),childarray(6,2,2),
+ & .TRUE.,nbin,ndirin)
+ END SELECT
+ ELSE
+ Call Agrif_nbdim_VarEQvar(tempC%var,pttruetab,cetruetab,
+ & child%var,childarray(:,1,2),childarray(:,2,2),
+ & nbdim)
+ ENDIF
+
+ ENDIF
+
+
+
+C
+C
+#ifdef key_mpp_mpi
+C
+C tab2 contains the necessary limits of the parent grid for each processor
+
+ IF (Associated(child%var%list_update)) THEN
+ Call Agrif_Find_list_update(child%var%list_update,pttab,petab,
+ & pttab_Child,pttab_Parent,nbdim,
+ & find_list_update,tab4t,tab5t,memberinall,memberinall2,
+ & sendtoproc1,recvfromproc1,sendtoproc2,recvfromproc2)
+ ELSE
+ find_list_update = .FALSE.
+ ENDIF
+
+ if (.not.find_list_update) then
+ tab3(:,1) = pttruetab(:)
+ tab3(:,2) = cetruetab(:)
+ tab3(:,3) = pttruetabwhole(:)
+ tab3(:,4) = cetruetabwhole(:)
+C
+C
+ Call MPI_ALLGATHER(tab3,4*nbdim,MPI_INTEGER,tab4,4*nbdim,
+ & MPI_INTEGER,MPI_COMM_AGRIF,code)
+
+ IF (.not.associated(tempCextend%var)) Allocate(tempCextend%var)
+ DO k=0,Agrif_Nbprocs-1
+ do j=1,4
+ do i=1,nbdim
+ tab4t(i,k,j) = tab4(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ memberin1(1) = memberin
+ CALL MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall,
+ & 1,MPI_LOGICAL,MPI_COMM_AGRIF,code)
+
+ Call Get_External_Data_first(tab4t(:,:,1),
+ & tab4t(:,:,2),
+ & tab4t(:,:,3),tab4t(:,:,4),nbdim,memberin,memberin,
+ & memberinall,sendtoproc1,recvfromproc1,tab4t(:,:,5),
+ & tab4t(:,:,6),tab4t(:,:,7),tab4t(:,:,8))
+
+ endif
+
+ Call ExchangeSameLevel2(sendtoproc1,recvfromproc1,nbdim,
+ & tab4t(:,:,3),tab4t(:,:,4),tab4t(:,:,5),tab4t(:,:,6),
+ & tab4t(:,:,7),tab4t(:,:,8),memberin,tempC,
+ & tempCextend)
+
+! Call Get_External_Data(tempC,tempCextend,tab4t(:,:,1),
+! & tab4t(:,:,2),
+! & tab4t(:,:,3),tab4t(:,:,4),nbdim,memberin,memberin,
+! & memberinall)
+
+#else
+ tempCextend%var => tempC%var
+#endif
+
+C
+C
+C Update of the parent grid (tempP) from the child grid (tempC)
+
+
+ IF (memberin) THEN
+
+ IF (.not.associated(tempP%var)) allocate(tempP%var)
+ Call Agrif_nbdim_allocation(tempP%var,
+ & indmin,indmax,nbdim)
+
+ if ( nbdim .EQ. 1 ) then
+ tempP%var%array1 = 0.
+ Call Agrif_Update_1D_recursive(TypeUpdate,
+ & tempP%var%array1,tempCextend%var%array1,
+ & indmin,indmax,
+ & pttruetabwhole,cetruetabwhole,
+ & s_Child_temp,s_Parent_temp,
+ & ds_Child,ds_Parent,nbdim)
+ endif
+ if ( nbdim .EQ. 2 ) then
+ Call Agrif_Update_2D_recursive(TypeUpdate,
+ & tempP%var%array2,tempCextend%var%array2,
+ & indmin,indmax,
+ & pttruetabwhole,cetruetabwhole,
+ & s_Child_temp,s_Parent_temp,
+ & ds_Child,ds_Parent,nbdim)
+ endif
+
+ if ( nbdim .EQ. 3 ) then
+ Call Agrif_Update_3D_recursive(TypeUpdate,
+ & tempP%var%array3,tempCextend%var%array3,
+ & indmin,indmax,
+ & pttruetabwhole,cetruetabwhole,
+ & s_Child_temp,s_Parent_temp,
+ & ds_Child,ds_Parent,nbdim)
+ endif
+ if ( nbdim .EQ. 4 ) then
+ Call Agrif_Update_4D_recursive(TypeUpdate,
+ & tempP%var%array4,tempCextend%var%array4,
+ & indmin,indmax,
+ & pttruetabwhole,cetruetabwhole,
+ & s_Child_temp,s_Parent_temp,
+ & ds_Child,ds_Parent,nbdim)
+ endif
+ if ( nbdim .EQ. 5 ) then
+ Call Agrif_Update_5D_recursive(TypeUpdate,
+ & tempP%var%array5,tempCextend%var%array5,
+ & indmin,indmax,
+ & pttruetabwhole,cetruetabwhole,
+ & s_Child_temp,s_Parent_temp,
+ & ds_Child,ds_Parent,nbdim)
+ endif
+ if ( nbdim .EQ. 6 ) then
+ Call Agrif_Update_6D_recursive(TypeUpdate,
+ & tempP%var%array6,tempCextend%var%array6,
+ & indmin,indmax,
+ & pttruetabwhole,cetruetabwhole,
+ & s_Child_temp,s_Parent_temp,
+ & ds_Child,ds_Parent,nbdim)
+ endif
+
+ Call Agrif_nbdim_deallocation(tempCextend%var,nbdim)
+C Deallocate(tempCextend%var)
+
+ ENDIF
+
+#ifdef key_mpp_mpi
+ Call Agrif_nbdim_Get_bound_dimension(parent%var,
+ & lowerbound,upperbound,nbdim)
+
+ Call Agrif_ChildGrid_to_ParentGrid()
+C
+ Call Agrif_Childbounds(nbdim,
+ & lowerbound,upperbound,
+ & indminglob,indmaxglob,
+ & indminglob2,indmaxglob2,member)
+C
+ IF (member) THEN
+ Call Agrif_GlobtoLocInd2(parentarray,
+ & lowerbound,upperbound,
+ & indminglob2,indmaxglob2,
+ & nbdim,Agrif_Procrank,
+ & member)
+ ENDIF
+
+ Call Agrif_ParentGrid_to_ChildGrid()
+
+ if (.not.find_list_update) then
+ tab3(:,1) = indmin(:)
+ tab3(:,2) = indmax(:)
+ tab3(:,3) = indminglob2(:)
+ tab3(:,4) = indmaxglob2(:)
+C
+ Call MPI_ALLGATHER(tab3,4*nbdim,MPI_INTEGER,tab4,4*nbdim,
+ & MPI_INTEGER,MPI_COMM_AGRIF,code)
+
+ IF (.not.associated(tempPextend%var)) Allocate(tempPextend%var)
+ DO k=0,Agrif_Nbprocs-1
+ do j=1,4
+ do i=1,nbdim
+ tab5t(i,k,j) = tab4(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ memberin1(1) = member
+ CALL MPI_ALLGATHER(memberin1,1,MPI_LOGICAL,memberinall2,
+ & 1,MPI_LOGICAL,MPI_COMM_AGRIF,code)
+
+ Call Get_External_Data_first(tab5t(:,:,1),
+ & tab5t(:,:,2),
+ & tab5t(:,:,3),tab5t(:,:,4),nbdim,memberin,member,
+ & memberinall2,sendtoproc2,recvfromproc2,tab5t(:,:,5),
+ & tab5t(:,:,6),tab5t(:,:,7),tab5t(:,:,8))
+
+ Call Agrif_Addto_list_update(child%var%list_update,pttab,petab,
+ & pttab_Child,pttab_Parent,nbdim
+ & ,tab4t,tab5t,memberinall,memberinall2,
+ & sendtoproc1,recvfromproc1,sendtoproc2,recvfromproc2)
+
+ endif
+
+c Call Get_External_Data(tempP,tempPextend,tab5t(:,:,1),
+c & tab5t(:,:,2),
+c & tab5t(:,:,3),tab5t(:,:,4),nbdim,memberin,member,
+c & memberinall2)
+
+ Call ExchangeSameLevel2(sendtoproc2,recvfromproc2,nbdim,
+ & tab5t(:,:,3),tab5t(:,:,4),tab5t(:,:,5),tab5t(:,:,6),
+ & tab5t(:,:,7),tab5t(:,:,8),member,tempP,
+ & tempPextend)
+
+#else
+ tempPextend%var => tempP%var
+ parentarray(:,1,1) = indmin
+ parentarray(:,2,1) = indmax
+ parentarray(:,1,2) = indmin
+ parentarray(:,2,2) = indmax
+ member = .TRUE.
+#endif
+
+C
+C
+C
+C Special values on the child grid
+ if (Agrif_UseSpecialValueFineGrid) then
+C
+ccc noraftab(1:nbdim) =
+ccc & child % var % root_var % interptab(1:nbdim) .EQ. 'N'
+C
+#ifdef key_mpp_mpi
+C
+c Allocate(childvalues% var)
+C
+c Call Agrif_nbdim_allocation(childvalues%var,
+c & pttruetab,cetruetab,nbdim)
+c Call Agrif_nbdim_Full_VarEQvar(childvalues% var,
+c & tempC% var,
+c & nbdim)
+c Call Agrif_CheckMasknD(tempC,childvalues,
+c & pttruetab(1:nbdim),cetruetab(1:nbdim),
+c & pttruetab(1:nbdim),cetruetab(1:nbdim),
+c & noraftab(1:nbdim),nbdim)
+c Call Agrif_nbdim_deallocation(childvalues% var,nbdim)
+c Deallocate(childvalues % var)
+C
+#else
+C
+c Call Agrif_nbdim_Get_bound_dimension(child%var,
+c & lowerbound,upperbound,nbdim)
+c Call Agrif_CheckMasknD(tempC,child,
+c & pttruetab(1:nbdim),cetruetab(1:nbdim),
+c & lowerbound,
+c & upperbound,
+c & noraftab(1:nbdim),nbdim)
+C
+#endif
+C
+ endif
+
+
+C
+C
+C
+C
+C Special values on the parent grid
+ if (Agrif_UseSpecialValue) then
+C
+#ifdef key_mpp_mpi
+C
+c Call GiveAgrif_SpecialValueToTab_mpi(parent%var,tempP%var,
+c & parentarray,
+c & indmin,indmax,
+c & Agrif_SpecialValue,nbdim)
+C
+C
+#else
+C
+c Call GiveAgrif_SpecialValueToTab(parent%var,tempP%var,
+c & indmin,indmax,
+c & Agrif_SpecialValue,nbdim)
+C
+#endif
+C
+C
+ endif
+C
+C
+ IF (member) THEN
+
+ IF (present(procname)) THEN
+ CALL Agrif_ChildGrid_to_ParentGrid()
+ SELECT CASE(nbdim)
+ CASE(1)
+ CALL procname(
+ & tempPextend%var%array1(
+ & parentarray(1,1,1):parentarray(1,2,1)),
+ & parentarray(1,1,2),parentarray(1,2,2),
+ & .FALSE.,nbin,ndirin
+ & )
+ CASE(2)
+ CALL procname(
+ & tempPextend%var%array2(
+ & parentarray(1,1,1):parentarray(1,2,1),
+ & parentarray(2,1,1):parentarray(2,2,1)),
+ & parentarray(1,1,2),parentarray(1,2,2),
+ & parentarray(2,1,2),parentarray(2,2,2),
+ & .FALSE.,nbin,ndirin
+ & )
+ CASE(3)
+ CALL procname(
+ & tempPextend%var%array3(
+ & parentarray(1,1,1):parentarray(1,2,1),
+ & parentarray(2,1,1):parentarray(2,2,1),
+ & parentarray(3,1,1):parentarray(3,2,1)),
+ & parentarray(1,1,2),parentarray(1,2,2),
+ & parentarray(2,1,2),parentarray(2,2,2),
+ & parentarray(3,1,2),parentarray(3,2,2),
+ & .FALSE.,nbin,ndirin
+ & )
+ CASE(4)
+ CALL procname(
+ & tempPextend%var%array4(
+ & parentarray(1,1,1):parentarray(1,2,1),
+ & parentarray(2,1,1):parentarray(2,2,1),
+ & parentarray(3,1,1):parentarray(3,2,1),
+ & parentarray(4,1,1):parentarray(4,2,1)),
+ & parentarray(1,1,2),parentarray(1,2,2),
+ & parentarray(2,1,2),parentarray(2,2,2),
+ & parentarray(3,1,2),parentarray(3,2,2),
+ & parentarray(4,1,2),parentarray(4,2,2),
+ & .FALSE.,nbin,ndirin
+ & )
+ CASE(5)
+ CALL procname(
+ & tempPextend%var%array5(
+ & parentarray(1,1,1):parentarray(1,2,1),
+ & parentarray(2,1,1):parentarray(2,2,1),
+ & parentarray(3,1,1):parentarray(3,2,1),
+ & parentarray(4,1,1):parentarray(4,2,1),
+ & parentarray(5,1,1):parentarray(5,2,1)),
+ & parentarray(1,1,2),parentarray(1,2,2),
+ & parentarray(2,1,2),parentarray(2,2,2),
+ & parentarray(3,1,2),parentarray(3,2,2),
+ & parentarray(4,1,2),parentarray(4,2,2),
+ & parentarray(5,1,2),parentarray(5,2,2),
+ & .FALSE.,nbin,ndirin
+ & )
+ CASE(6)
+ CALL procname(
+ & tempPextend%var%array6(
+ & parentarray(1,1,1):parentarray(1,2,1),
+ & parentarray(2,1,1):parentarray(2,2,1),
+ & parentarray(3,1,1):parentarray(3,2,1),
+ & parentarray(4,1,1):parentarray(4,2,1),
+ & parentarray(5,1,1):parentarray(5,2,1),
+ & parentarray(6,1,1):parentarray(6,2,1)),
+ & parentarray(1,1,2),parentarray(1,2,2),
+ & parentarray(2,1,2),parentarray(2,2,2),
+ & parentarray(3,1,2),parentarray(3,2,2),
+ & parentarray(4,1,2),parentarray(4,2,2),
+ & parentarray(5,1,2),parentarray(5,2,2),
+ & parentarray(6,1,2),parentarray(6,2,2),
+ & .FALSE.,nbin,ndirin
+ & )
+ END SELECT
+ CALL Agrif_ParentGrid_to_ChildGrid()
+ ELSE
+ SELECT CASE(nbdim)
+ CASE(1)
+ parent%var%array1(parentarray(1,1,2):parentarray(1,2,2)) =
+ & tempPextend%var%array1(
+ & parentarray(1,1,1):parentarray(1,2,1))
+ CASE(2)
+ parent%var%array2(parentarray(1,1,2):parentarray(1,2,2),
+ & parentarray(2,1,2):parentarray(2,2,2)) =
+ & tempPextend%var%array2(
+ & parentarray(1,1,1):parentarray(1,2,1),
+ & parentarray(2,1,1):parentarray(2,2,1))
+ CASE(3)
+ parent%var%array3(parentarray(1,1,2):parentarray(1,2,2),
+ & parentarray(2,1,2):parentarray(2,2,2),
+ & parentarray(3,1,2):parentarray(3,2,2)) =
+ & tempPextend%var%array3(
+ & parentarray(1,1,1):parentarray(1,2,1),
+ & parentarray(2,1,1):parentarray(2,2,1),
+ & parentarray(3,1,1):parentarray(3,2,1))
+ CASE(4)
+ parent%var%array4(parentarray(1,1,2):parentarray(1,2,2),
+ & parentarray(2,1,2):parentarray(2,2,2),
+ & parentarray(3,1,2):parentarray(3,2,2),
+ & parentarray(4,1,2):parentarray(4,2,2)) =
+ & tempPextend%var%array4(
+ & parentarray(1,1,1):parentarray(1,2,1),
+ & parentarray(2,1,1):parentarray(2,2,1),
+ & parentarray(3,1,1):parentarray(3,2,1),
+ & parentarray(4,1,1):parentarray(4,2,1))
+ CASE(5)
+ parent%var%array5(parentarray(1,1,2):parentarray(1,2,2),
+ & parentarray(2,1,2):parentarray(2,2,2),
+ & parentarray(3,1,2):parentarray(3,2,2),
+ & parentarray(4,1,2):parentarray(4,2,2),
+ & parentarray(5,1,2):parentarray(5,2,2)) =
+ & tempPextend%var%array5(
+ & parentarray(1,1,1):parentarray(1,2,1),
+ & parentarray(2,1,1):parentarray(2,2,1),
+ & parentarray(3,1,1):parentarray(3,2,1),
+ & parentarray(4,1,1):parentarray(4,2,1),
+ & parentarray(5,1,1):parentarray(5,2,1))
+ CASE(6)
+ parent%var%array6(parentarray(1,1,2):parentarray(1,2,2),
+ & parentarray(2,1,2):parentarray(2,2,2),
+ & parentarray(3,1,2):parentarray(3,2,2),
+ & parentarray(4,1,2):parentarray(4,2,2),
+ & parentarray(5,1,2):parentarray(5,2,2),
+ & parentarray(6,1,2):parentarray(6,2,2)) =
+ & tempPextend%var%array6(
+ & parentarray(1,1,1):parentarray(1,2,1),
+ & parentarray(2,1,1):parentarray(2,2,1),
+ & parentarray(3,1,1):parentarray(3,2,1),
+ & parentarray(4,1,1):parentarray(4,2,1),
+ & parentarray(5,1,1):parentarray(5,2,1),
+ & parentarray(6,1,1):parentarray(6,2,1))
+ END SELECT
+ ENDIF
+
+ Call Agrif_nbdim_deallocation(tempPextend%var,nbdim)
+ ENDIF
+C
+C
+C Deallocations
+
+ IF (memberin) THEN
+#ifdef key_mpp_mpi
+ Call Agrif_nbdim_deallocation(tempP%var,nbdim)
+ Call Agrif_nbdim_deallocation(tempC%var,nbdim)
+! Deallocate(tempC % var)
+#endif
+! Deallocate(tempP % var)
+ ENDIF
+#ifdef key_mpp_mpi
+! Deallocate(tempPextend%var)
+! IF (.Not.memberin) Deallocate(tempCextend%var)
+#endif
+
+C
+C
+ End Subroutine Agrif_UpdatenD
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Prtbounds
+C **************************************************************************
+C
+ Subroutine Agrif_Prtbounds(nbdim,indmin,indmax,s_Parent_temp,
+ & s_Child_temp,s_Child,ds_Child,
+ & s_Parent,ds_Parent,
+ & pttruetab,cetruetab,pttab_Child,
+ & pttab_Parent,
+ & posvartab_child,TypeUpdate,
+ & loctab_Child
+#ifdef key_mpp_mpi
+ & ,pttruetabwhole,cetruetabwhole
+#endif
+ & )
+C
+CCC Description:
+CCC Subroutine calculating the bounds of the parent grid to be updated
+CCC by the child grid
+C
+C
+C Declarations:
+C
+
+C
+#ifdef key_mpp_mpi
+cccccccccccccccccccccccccc#include "mpif.h"
+#endif
+C
+C Arguments
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(nbdim) :: indmin,indmax
+ REAL,DIMENSION(nbdim) :: s_Parent_temp,s_child_temp
+ REAL,DIMENSION(nbdim) :: s_Child,ds_child
+ REAL,DIMENSION(nbdim) :: s_Parent,ds_Parent
+ INTEGER,DIMENSION(nbdim) :: pttruetab,cetruetab
+ INTEGER,DIMENSION(nbdim) :: posvartab_child,TypeUpdate
+ INTEGER,DIMENSION(nbdim) :: loctab_Child
+ INTEGER,DIMENSION(nbdim) :: pttab_Child,pttab_Parent
+C
+C Local variables
+ INTEGER :: i
+ REAL,DIMENSION(nbdim) :: dim_newmin,dim_newmax
+#ifdef key_mpp_mpi
+ INTEGER,DIMENSION(nbdim) :: pttruetabwhole,cetruetabwhole
+ REAL :: positionmin,positionmax
+ INTEGER :: imin,imax
+ INTEGER :: coeffraf
+#endif
+C
+C
+ do i = 1,nbdim
+C
+ dim_newmin(i) = s_Child(i) + (pttruetab(i) -
+ & pttab_Child(i)) * ds_Child(i)
+C
+ dim_newmax(i) = s_Child(i) + (cetruetab(i) -
+ & pttab_Child(i)) * ds_Child(i)
+C
+ indmin(i) = pttab_Parent(i) +
+ & agrif_ceiling((dim_newmin(i)-s_Parent(i))/ds_Parent(i))
+C
+ indmax(i) = pttab_Parent(i) +
+ & agrif_int((dim_newmax(i)-s_Parent(i))/ds_Parent(i))
+C
+#ifdef key_mpp_mpi
+ positionmin = s_Parent(i) + (indmin(i)-
+ & pttab_Parent(i))*ds_Parent(i)
+ IF (loctab_Child(i) .NE. -3) THEN
+ IF (posvartab_child(i) == 1) THEN
+ IF (TypeUpdate(i) .EQ. Agrif_Update_Average) THEN
+ positionmin = positionmin - ds_Parent(i)/2.
+ ELSE IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
+ positionmin = positionmin - (ds_Parent(i)-ds_Child(i))
+ ENDIF
+ ELSE
+ IF (TypeUpdate(i).NE.Agrif_Update_Full_Weighting) THEN
+ positionmin = positionmin - ds_Parent(i)/2.
+ ELSE
+ coeffraf = nint(ds_Parent(i)/ds_Child(i))
+ if (mod(coeffraf,2) == 1) then
+ positionmin = positionmin - (ds_Parent(i)-ds_Child(i))
+ else
+ positionmin = positionmin - (ds_Parent(i)-ds_Child(i))
+ & -ds_Child(i)/2.
+ endif
+ ENDIF
+ ENDIF
+ ENDIF
+ imin = pttab_Child(i) +
+ & agrif_ceiling((positionmin-s_Child(i))/ds_Child(i))
+
+ positionmin = s_Child(i) + (imin -
+ & pttab_Child(i)) * ds_Child(i)
+
+ pttruetabwhole(i) = imin
+
+ positionmax = s_Parent(i) + (indmax(i)-
+ & pttab_Parent(i))*ds_Parent(i)
+ IF (loctab_Child(i) .NE. -3) THEN
+ IF (posvartab_child(i) == 1) THEN
+ IF (TypeUpdate(i) .EQ. Agrif_Update_Average) THEN
+ positionmax = positionmax + ds_Parent(i)/2.
+ ELSE IF (TypeUpdate(i) .EQ. Agrif_Update_Full_Weighting) THEN
+ positionmax = positionmax + (ds_Parent(i)-ds_Child(i))
+ ENDIF
+ ELSE
+ IF (TypeUpdate(i).NE.Agrif_Update_Full_Weighting) THEN
+ positionmax = positionmax + ds_Parent(i)/2.
+ ELSE
+ coeffraf = nint(ds_Parent(i)/ds_Child(i))
+ if (mod(coeffraf,2) == 1) then
+ positionmax = positionmax + (ds_Parent(i)-ds_Child(i))
+ else
+ positionmax = positionmax + (ds_Parent(i)-ds_Child(i))
+ & + ds_Child(i)/2.
+ endif
+
+ ENDIF
+ ENDIF
+ ENDIF
+ imax = pttab_Child(i) +
+ & agrif_int((positionmax-s_Child(i))/ds_Child(i))
+
+ positionmax = s_Child(i) + (imax -
+ & pttab_Child(i)) * ds_Child(i)
+
+ cetruetabwhole(i) = imax
+
+#endif
+C
+ s_Parent_temp(i) = s_Parent(i) +
+ & (indmin(i) - pttab_Parent(i)) *
+ & ds_Parent(i)
+C
+ s_Child_temp(i) = dim_newmin(i)
+
+#ifdef key_mpp_mpi
+ s_Child_temp(i) = positionmin
+#endif
+C
+ enddo
+C
+ Return
+C
+C
+ End Subroutine Agrif_Prtbounds
+C
+C
+C
+C
+
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Update_2D_Recursive
+C **************************************************************************
+C
+ Subroutine Agrif_Update_2D_recursive(TypeUpdate,tempP,tempC,
+ & indmin,indmax,
+ & pttab_child,petab_child,
+ & s_child,s_parent,
+ & ds_child,ds_parent,nbdim)
+C
+CCC Description:
+CCC Subroutine to update a 2D grid variable on the parent grid.
+CCC It calls Agrif_Update_1D_Recursive and Agrif_UpdateBase.
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+ INTEGER :: nbdim
+ INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
+ INTEGER, DIMENSION(nbdim) :: indmin,indmax
+ INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
+ REAL, DIMENSION(nbdim) :: s_child,s_parent
+ REAL, DIMENSION(nbdim) :: ds_child,ds_parent
+ REAL, DIMENSION(indmin(1):indmax(1),
+ & indmin(2):indmax(2)) :: tempP
+C REAL, DIMENSION(pttab_child(1):petab_child(1),
+C & pttab_child(2):petab_child(2)) :: tempC
+
+ REAL, DIMENSION(:,:) :: tempC
+C
+C Local variables
+ REAL, DIMENSION(indmin(1):indmax(1),
+ & pttab_child(2):petab_child(2)) :: tabtemp
+ REAL, DIMENSION(indmin(2):indmax(2),
+ & indmin(1):indmax(1)) :: tempP_trsp
+ REAL, DIMENSION(pttab_child(2):petab_child(2),
+ & indmin(1):indmax(1)) :: tabtemp_trsp
+ INTEGER :: i,j
+ INTEGER :: coeffraf,locind_child_left
+C
+ tabtemp = 0.
+
+
+ coeffraf = nint ( ds_parent(1) / ds_child(1) )
+ IF((TypeUpdate(1) == AGRIF_Update_average)
+ & .AND. (coeffraf /= 1 ))THEN
+!---CDIR NEXPAND
+ IF(.NOT. precomputedone(1) ) Call average1Dprecompute2D
+ & (petab_child(2)-pttab_child(2)+1,
+ & indmax(1)-indmin(1)+1,
+ & petab_child(1)-pttab_child(1)+1,
+ & s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
+!---CDIR NEXPAND
+ Call average1Daftercompute
+ & ( tabtemp, tempC,
+ & size(tabtemp), size(tempC),
+ & s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
+
+ ELSEIF((TypeUpdate(1) == AGRIF_Update_copy)
+ & .AND. (coeffraf /= 1 ))THEN
+!---CDIR NEXPAND
+ IF(.NOT. precomputedone(1) ) Call copy1Dprecompute2D
+ & (petab_child(2)-pttab_child(2)+1,
+ & indmax(1)-indmin(1)+1,
+ & petab_child(1)-pttab_child(1)+1,
+ & s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
+!---CDIR NEXPAND
+ Call copy1Daftercompute
+ & ( tabtemp, tempC,
+ & size(tabtemp), size(tempC),
+ & s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
+
+ ELSE
+ do j = pttab_child(nbdim),petab_child(nbdim)
+C
+!---CDIR NEXPAND
+ Call Agrif_Update_1D_recursive(TypeUpdate(1:nbdim-1),
+ & tabtemp(:,j),
+ & tempC(:,j-pttab_child(nbdim)+1),
+ & indmin(1:nbdim-1),indmax(1:nbdim-1),
+ & pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
+ & s_child(1:nbdim-1),s_parent(1:nbdim-1),
+ & ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
+C
+ enddo
+ ENDIF
+ tabtemp_trsp = TRANSPOSE(tabtemp)
+ coeffraf = nint(ds_parent(nbdim)/ds_child(nbdim))
+
+!---CDIR NEXPAND
+ Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
+C
+
+ tempP_trsp = 0.
+
+ IF((TypeUpdate(2) == AGRIF_Update_average)
+ & .AND. (coeffraf /= 1 ))THEN
+!---CDIR NEXPAND
+ IF(.NOT. precomputedone(2) ) Call average1Dprecompute2D
+ & ( indmax(1)-indmin(1)+1,
+ & indmax(2)-indmin(2)+1,
+ & petab_child(2)-pttab_child(2)+1,
+ & s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
+!---CDIR NEXPAND
+ Call average1Daftercompute
+ & ( tempP_trsp, tabtemp_trsp,
+ & size(tempP_trsp), size(tabtemp_trsp),
+ & s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
+
+ ELSEIF((TypeUpdate(2) == AGRIF_Update_copy)
+ & .AND. (coeffraf /= 1 ))THEN
+!---CDIR NEXPAND
+ IF(.NOT. precomputedone(2) ) Call copy1Dprecompute2D
+ & ( indmax(1)-indmin(1)+1,
+ & indmax(2)-indmin(2)+1,
+ & petab_child(2)-pttab_child(2)+1,
+ & s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
+!---CDIR NEXPAND
+ Call copy1Daftercompute
+ & ( tempP_trsp, tabtemp_trsp,
+ & size(tempP_trsp), size(tabtemp_trsp),
+ & s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
+
+ ELSE
+
+ do i = indmin(1),indmax(1)
+C
+!---CDIR NEXPAND
+ Call Agrif_UpdateBase(TypeUpdate(2),
+ & tempP_trsp(indmin(nbdim):indmax(nbdim),i),
+ & tabtemp_trsp(pttab_child(nbdim):petab_child(nbdim),i),
+ & indmin(nbdim),indmax(nbdim),
+ & pttab_child(nbdim),petab_child(nbdim),
+ & s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),
+ & coeffraf,locind_child_left)
+C
+ enddo
+
+ ENDIF
+
+ tempP = TRANSPOSE(tempP_trsp)
+C
+ Return
+C
+C
+ End Subroutine Agrif_Update_2D_recursive
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Update_3D_Recursive
+C **************************************************************************
+C
+ Subroutine Agrif_Update_3D_recursive(TypeUpdate,tempP,tempC,
+ & indmin,indmax,
+ & pttab_child,petab_child,
+ & s_child,s_parent,
+ & ds_child,ds_parent,nbdim)
+C
+CCC Description:
+CCC Subroutine to update a 3D grid variable on the parent grid.
+CCC It calls Agrif_Update_2D_Recursive and Agrif_UpdateBase.
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+ INTEGER :: nbdim
+ INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
+ INTEGER, DIMENSION(nbdim) :: indmin,indmax
+ INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
+ REAL, DIMENSION(nbdim) :: s_child,s_parent
+ REAL, DIMENSION(nbdim) :: ds_child,ds_parent
+ REAL, DIMENSION(indmin(1):indmax(1),
+ & indmin(2):indmax(2),
+ & indmin(3):indmax(3)) :: tempP
+ REAL, DIMENSION(pttab_child(1):petab_child(1),
+ & pttab_child(2):petab_child(2),
+ & pttab_child(3):petab_child(3)) :: tempC
+C
+C Local variables
+ REAL, DIMENSION(indmin(1):indmax(1),
+ & indmin(2):indmax(2),
+ & pttab_child(3):petab_child(3)) :: tabtemp
+ INTEGER :: i,j,k
+ INTEGER :: coeffraf,locind_child_left
+ INTEGER :: kdeb
+C
+C
+ coeffraf = nint ( ds_parent(1) / ds_child(1) )
+ IF((TypeUpdate(1) == AGRIF_Update_average)
+ & .AND. (coeffraf /= 1 ))THEN
+!---CDIR NEXPAND
+ Call average1Dprecompute2D
+ & (petab_child(2)-pttab_child(2)+1,
+ & indmax(1)-indmin(1)+1,
+ & petab_child(1)-pttab_child(1)+1,
+ & s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
+ precomputedone(1) = .TRUE.
+ ELSEIF((TypeUpdate(1) == AGRIF_Update_copy)
+ & .AND. (coeffraf /= 1 ))THEN
+!---CDIR NEXPAND
+ Call copy1Dprecompute2D
+ & (petab_child(2)-pttab_child(2)+1,
+ & indmax(1)-indmin(1)+1,
+ & petab_child(1)-pttab_child(1)+1,
+ & s_parent(1),s_child(1),ds_parent(1),ds_child(1),1)
+ precomputedone(1) = .TRUE.
+ ENDIF
+
+ coeffraf = nint ( ds_parent(2) / ds_child(2) )
+ IF((TypeUpdate(2) == AGRIF_Update_average)
+ & .AND. (coeffraf /= 1 ))THEN
+!---CDIR NEXPAND
+ Call average1Dprecompute2D
+ & ( indmax(1)-indmin(1)+1,
+ & indmax(2)-indmin(2)+1,
+ & petab_child(2)-pttab_child(2)+1,
+ & s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
+ precomputedone(2) = .TRUE.
+ ELSEIF((TypeUpdate(2) == AGRIF_Update_copy)
+ & .AND. (coeffraf /= 1 ))THEN
+!---CDIR NEXPAND
+ Call copy1Dprecompute2D
+ & ( indmax(1)-indmin(1)+1,
+ & indmax(2)-indmin(2)+1,
+ & petab_child(2)-pttab_child(2)+1,
+ & s_parent(2),s_child(2),ds_parent(2),ds_child(2),2)
+ precomputedone(2) = .TRUE.
+ ENDIF
+
+
+ do k = pttab_child(nbdim),petab_child(nbdim)
+C
+ Call Agrif_Update_2D_recursive(TypeUpdate(1:nbdim-1),
+ & tabtemp(:,:,k),
+ & tempC(:,:,k),
+ & indmin(1:nbdim-1),indmax(1:nbdim-1),
+ & pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
+ & s_child(1:nbdim-1),s_parent(1:nbdim-1),
+ & ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
+C
+ enddo
+C
+ precomputedone(1) = .FALSE.
+ precomputedone(2) = .FALSE.
+ coeffraf = nint ( ds_parent(3) / ds_child(3) )
+
+ Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
+
+ IF (coeffraf == 1) THEN
+
+ kdeb = pttab_child(3)+locind_child_left-2
+ do k=indmin(3),indmax(3)
+ kdeb = kdeb + 1
+ do j = indmin(2),indmax(2)
+ do i = indmin(1),indmax(1)
+ tempP(i,j,k) = tabtemp(i,j,kdeb)
+ enddo
+ enddo
+ enddo
+
+ ELSE
+ tempP = 0.
+C
+ do j = indmin(2),indmax(2)
+C
+ do i = indmin(1),indmax(1)
+C
+ Call Agrif_UpdateBase(TypeUpdate(3),
+ & tempP(i,j,:),
+ & tabtemp(i,j,:),
+ & indmin(nbdim),indmax(nbdim),
+ & pttab_child(nbdim),petab_child(nbdim),
+ & s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),
+ & coeffraf,locind_child_left)
+C
+ enddo
+C
+ enddo
+ ENDIF
+C
+ Return
+C
+C
+ End Subroutine Agrif_Update_3D_recursive
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Update_4D_Recursive
+C **************************************************************************
+C
+ Subroutine Agrif_Update_4D_recursive(TypeUpdate,tempP,tempC,
+ & indmin,indmax,
+ & pttab_child,petab_child,
+ & s_child,s_parent,
+ & ds_child,ds_parent,nbdim)
+C
+CCC Description:
+CCC Subroutine to update a 4D grid variable on the parent grid.
+CCC It calls Agrif_Update_3D_Recursive and Agrif_UpdateBase.
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+ INTEGER :: nbdim
+ INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
+ INTEGER, DIMENSION(nbdim) :: indmin,indmax
+ INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
+ REAL, DIMENSION(nbdim) :: s_child,s_parent
+ REAL, DIMENSION(nbdim) :: ds_child,ds_parent
+ REAL, DIMENSION(indmin(1):indmax(1),
+ & indmin(2):indmax(2),
+ & indmin(3):indmax(3),
+ & indmin(4):indmax(4)) :: tempP
+ REAL, DIMENSION(pttab_child(1):petab_child(1),
+ & pttab_child(2):petab_child(2),
+ & pttab_child(3):petab_child(3),
+ & pttab_child(4):petab_child(4)) :: tempC
+C
+C Local variables
+ REAL, DIMENSION(:,:,:,:), Allocatable :: tabtemp
+ INTEGER :: i,j,k,l
+ INTEGER :: coeffraf,locind_child_left
+C
+C
+ Allocate(tabtemp(indmin(1):indmax(1),
+ & indmin(2):indmax(2),
+ & indmin(3):indmax(3),
+ & pttab_child(4):petab_child(4)))
+C
+ do l = pttab_child(nbdim),petab_child(nbdim)
+C
+ Call Agrif_Update_3D_recursive(TypeUpdate(1:nbdim-1),
+ & tabtemp(indmin(nbdim-3):indmax(nbdim-3),
+ & indmin(nbdim-2):indmax(nbdim-2),
+ & indmin(nbdim-1):indmax(nbdim-1),l),
+ & tempC(pttab_child(nbdim-3):petab_child(nbdim-3),
+ & pttab_child(nbdim-2):petab_child(nbdim-2),
+ & pttab_child(nbdim-1):petab_child(nbdim-1),l),
+ & indmin(1:nbdim-1),indmax(1:nbdim-1),
+ & pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
+ & s_child(1:nbdim-1),s_parent(1:nbdim-1),
+ & ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
+C
+ enddo
+
+ Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
+C
+ tempP = 0.
+
+ do k = indmin(3),indmax(3)
+C
+ do j = indmin(2),indmax(2)
+C
+ do i = indmin(1),indmax(1)
+C
+ Call Agrif_UpdateBase(TypeUpdate(4),
+ & tempP(i,j,k,indmin(nbdim):indmax(nbdim)),
+ & tabtemp(i,j,k,pttab_child(nbdim):petab_child(nbdim)),
+ & indmin(nbdim),indmax(nbdim),
+ & pttab_child(nbdim),petab_child(nbdim),
+ & s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),
+ & coeffraf,locind_child_left)
+C
+ enddo
+C
+ enddo
+C
+ enddo
+C
+ Deallocate(tabtemp)
+C
+ Return
+C
+C
+ End Subroutine Agrif_Update_4D_recursive
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Update_5D_Recursive
+C **************************************************************************
+C
+ Subroutine Agrif_Update_5D_recursive(TypeUpdate,tempP,tempC,
+ & indmin,indmax,
+ & pttab_child,petab_child,
+ & s_child,s_parent,
+ & ds_child,ds_parent,nbdim)
+C
+CCC Description:
+CCC Subroutine to update a 5D grid variable on the parent grid.
+CCC It calls Agrif_Update_4D_Recursive and Agrif_UpdateBase.
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+ INTEGER :: nbdim
+ INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
+ INTEGER, DIMENSION(nbdim) :: indmin,indmax
+ INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
+ REAL, DIMENSION(nbdim) :: s_child,s_parent
+ REAL, DIMENSION(nbdim) :: ds_child,ds_parent
+ REAL, DIMENSION(indmin(1):indmax(1),
+ & indmin(2):indmax(2),
+ & indmin(3):indmax(3),
+ & indmin(4):indmax(4),
+ & indmin(5):indmax(5)) :: tempP
+ REAL, DIMENSION(pttab_child(1):petab_child(1),
+ & pttab_child(2):petab_child(2),
+ & pttab_child(3):petab_child(3),
+ & pttab_child(4):petab_child(4),
+ & pttab_child(5):petab_child(5)) :: tempC
+C
+C Local variables
+ REAL, DIMENSION(:,:,:,:,:), Allocatable :: tabtemp
+ INTEGER :: i,j,k,l,m
+ INTEGER :: coeffraf,locind_child_left
+C
+C
+ Allocate(tabtemp(indmin(1):indmax(1),
+ & indmin(2):indmax(2),
+ & indmin(3):indmax(3),
+ & indmin(4):indmax(4),
+ & pttab_child(5):petab_child(5)))
+C
+ do m = pttab_child(nbdim),petab_child(nbdim)
+C
+ Call Agrif_Update_4D_recursive(TypeUpdate(1:nbdim-1),
+ & tabtemp(indmin(nbdim-4):indmax(nbdim-4),
+ & indmin(nbdim-3):indmax(nbdim-3),
+ & indmin(nbdim-2):indmax(nbdim-2),
+ & indmin(nbdim-1):indmax(nbdim-1),m),
+ & tempC(pttab_child(nbdim-4):petab_child(nbdim-4),
+ & pttab_child(nbdim-3):petab_child(nbdim-3),
+ & pttab_child(nbdim-2):petab_child(nbdim-2),
+ & pttab_child(nbdim-1):petab_child(nbdim-1),m),
+ & indmin(1:nbdim-1),indmax(1:nbdim-1),
+ & pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
+ & s_child(1:nbdim-1),s_parent(1:nbdim-1),
+ & ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
+C
+ enddo
+
+ Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
+ tempP = 0.
+C
+ do l = indmin(4),indmax(4)
+C
+ do k = indmin(3),indmax(3)
+C
+ do j = indmin(2),indmax(2)
+C
+ do i = indmin(1),indmax(1)
+C
+ Call Agrif_UpdateBase(TypeUpdate(5),
+ & tempP(i,j,k,l,indmin(nbdim):indmax(nbdim)),
+ & tabtemp(i,j,k,l,
+ & pttab_child(nbdim):petab_child(nbdim)),
+ & indmin(nbdim),indmax(nbdim),
+ & pttab_child(nbdim),petab_child(nbdim),
+ & s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),
+ & coeffraf,locind_child_left)
+C
+ enddo
+C
+ enddo
+C
+ enddo
+C
+ enddo
+C
+ Deallocate(tabtemp)
+C
+ Return
+C
+C
+ End Subroutine Agrif_Update_5D_recursive
+C
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Update_6D_Recursive
+C **************************************************************************
+C
+ Subroutine Agrif_Update_6D_recursive(TypeUpdate,tempP,tempC,
+ & indmin,indmax,
+ & pttab_child,petab_child,
+ & s_child,s_parent,
+ & ds_child,ds_parent,nbdim)
+C
+CCC Description:
+CCC Subroutine to update a 6D grid variable on the parent grid.
+CCC It calls Agrif_Update_5D_Recursive and Agrif_UpdateBase.
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+ INTEGER :: nbdim
+ INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
+ INTEGER, DIMENSION(nbdim) :: indmin,indmax
+ INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
+ REAL, DIMENSION(nbdim) :: s_child,s_parent
+ REAL, DIMENSION(nbdim) :: ds_child,ds_parent
+ REAL, DIMENSION(indmin(1):indmax(1),
+ & indmin(2):indmax(2),
+ & indmin(3):indmax(3),
+ & indmin(4):indmax(4),
+ & indmin(5):indmax(5),
+ & indmin(6):indmax(6)) :: tempP
+ REAL, DIMENSION(pttab_child(1):petab_child(1),
+ & pttab_child(2):petab_child(2),
+ & pttab_child(3):petab_child(3),
+ & pttab_child(4):petab_child(4),
+ & pttab_child(5):petab_child(5),
+ & pttab_child(6):petab_child(6)) :: tempC
+C
+C Local variables
+ REAL, DIMENSION(:,:,:,:,:,:), Allocatable :: tabtemp
+ INTEGER :: i,j,k,l,m,n
+ INTEGER :: coeffraf,locind_child_left
+C
+C
+ Allocate(tabtemp(indmin(1):indmax(1),
+ & indmin(2):indmax(2),
+ & indmin(3):indmax(3),
+ & indmin(4):indmax(4),
+ & indmin(5):indmax(5),
+ & pttab_child(6):petab_child(6)))
+C
+ do n = pttab_child(nbdim),petab_child(nbdim)
+C
+ Call Agrif_Update_5D_recursive(TypeUpdate(1:nbdim-1),
+ & tabtemp(indmin(nbdim-5):indmax(nbdim-5),
+ & indmin(nbdim-4):indmax(nbdim-4),
+ & indmin(nbdim-3):indmax(nbdim-3),
+ & indmin(nbdim-2):indmax(nbdim-2),
+ & indmin(nbdim-1):indmax(nbdim-1),n),
+ & tempC(pttab_child(nbdim-5):petab_child(nbdim-5),
+ & pttab_child(nbdim-4):petab_child(nbdim-4),
+ & pttab_child(nbdim-3):petab_child(nbdim-3),
+ & pttab_child(nbdim-2):petab_child(nbdim-2),
+ & pttab_child(nbdim-1):petab_child(nbdim-1),n),
+ & indmin(1:nbdim-1),indmax(1:nbdim-1),
+ & pttab_child(1:nbdim-1),petab_child(1:nbdim-1),
+ & s_child(1:nbdim-1),s_parent(1:nbdim-1),
+ & ds_child(1:nbdim-1),ds_parent(1:nbdim-1),nbdim-1)
+C
+ enddo
+
+ Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
+C
+ tempP = 0.
+
+ do m = indmin(5),indmax(5)
+ do l = indmin(4),indmax(4)
+C
+ do k = indmin(3),indmax(3)
+C
+ do j = indmin(2),indmax(2)
+C
+ do i = indmin(1),indmax(1)
+C
+ Call Agrif_UpdateBase(TypeUpdate(6),
+ & tempP(i,j,k,l,m,indmin(nbdim):indmax(nbdim)),
+ & tabtemp(i,j,k,l,m,
+ & pttab_child(nbdim):petab_child(nbdim)),
+ & indmin(nbdim),indmax(nbdim),
+ & pttab_child(nbdim),petab_child(nbdim),
+ & s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),
+ & coeffraf,locind_child_left)
+C
+ enddo
+C
+ enddo
+C
+ enddo
+C
+ enddo
+ enddo
+C
+ Deallocate(tabtemp)
+C
+ Return
+C
+C
+ End Subroutine Agrif_Update_6D_recursive
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_UpdateBase
+C **************************************************************************
+C
+ Subroutine Agrif_UpdateBase(TypeUpdate,
+ & parenttab,childtab,
+ & indmin,indmax,pttab_child,petab_child,
+ & s_parent,s_child,ds_parent,ds_child,
+ & coeffraf,locind_child_left)
+C
+CCC Description:
+CCC Subroutine calling the updating method chosen by the user (copy, average
+CCC or full-weighting).
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+ INTEGER :: TypeUpdate
+ INTEGER :: indmin,indmax
+ INTEGER :: pttab_child,petab_child
+ REAL,DIMENSION(indmin:indmax) :: parenttab
+ REAL,DIMENSION(pttab_child:petab_child) :: childtab
+ REAL :: s_parent,s_child
+ REAL :: ds_parent,ds_child
+ INTEGER :: coeffraf,locind_child_left
+C
+C
+ if (TypeUpdate == AGRIF_Update_copy) then
+C
+ Call agrif_copy1D
+ & (parenttab,childtab,
+ & indmax-indmin+1,petab_child-pttab_child+1,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+ elseif (TypeUpdate == AGRIF_Update_average) then
+C
+ Call average1D
+ & (parenttab,childtab,
+ & indmax-indmin+1,petab_child-pttab_child+1,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+ elseif (TypeUpdate == AGRIF_Update_full_weighting) then
+C
+ Call full_weighting1D
+ & (parenttab,childtab,
+ & indmax-indmin+1,petab_child-pttab_child+1,
+ & s_parent,s_child,ds_parent,ds_child,
+ & coeffraf,locind_child_left)
+C
+ endif
+C
+ Return
+C
+C
+ End Subroutine Agrif_UpdateBase
+C
+C
+
+ Subroutine Agrif_Compute_nbdim_update(s_parent,s_child,
+ & ds_parent,ds_child,coeffraf,locind_child_left)
+ real :: s_parent,s_child,ds_parent,ds_child
+ integer :: coeffraf,locind_child_left
+
+ coeffraf = nint(ds_parent/ds_child)
+ locind_child_left = 1 + agrif_int((s_parent-s_child)/ds_child)
+
+ End Subroutine Agrif_Compute_nbdim_update
+
+#if defined key_mpp_mpi
+ Subroutine Agrif_Find_list_update(list_update,pttab,petab,
+ & pttab_Child,pttab_Parent,nbdim,
+ & find_list_update,tab4t,tab5t,memberinall,memberinall2,
+ & sendtoproc1,recvfromproc1,sendtoproc2,recvfromproc2)
+ TYPE(Agrif_List_Interp_Loc), Pointer :: list_update
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(nbdim) :: pttab,petab,pttab_Child,pttab_Parent
+ LOGICAL :: find_list_update
+ Type(Agrif_List_Interp_loc), Pointer :: parcours
+ INTEGER :: i
+C
+ INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab4t
+ INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab5t
+ LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: memberinall,memberinall2
+ LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc1,recvfromproc1
+ LOGICAL, DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc2,recvfromproc2
+
+ find_list_update = .FALSE.
+
+ parcours => list_update
+
+ Find_loop : Do While (associated(parcours))
+ Do i=1,nbdim
+ IF ((pttab(i) /= parcours%interp_loc%pttab(i)).OR.
+ & (petab(i) /= parcours%interp_loc%petab(i)).OR.
+ & (pttab_child(i) /= parcours%interp_loc%pttab_child(i)).OR.
+ & (pttab_parent(i) /= parcours%interp_loc%pttab_parent(i)))
+ & THEN
+ parcours=>parcours%suiv
+ Cycle Find_loop
+ ENDIF
+ EndDo
+
+ tab4t = parcours%interp_loc%tab4t(1:nbdim,0:Agrif_Nbprocs-1,1:8)
+ memberinall = parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1)
+
+ tab5t = parcours%interp_loc%tab5t(1:nbdim,0:Agrif_Nbprocs-1,1:8)
+ memberinall2 =
+ & parcours%interp_loc%memberinall2(0:Agrif_Nbprocs-1)
+ sendtoproc1 =
+ & parcours%interp_loc%sendtoproc1(0:Agrif_Nbprocs-1)
+ recvfromproc1 =
+ & parcours%interp_loc%recvfromproc1(0:Agrif_Nbprocs-1)
+ sendtoproc2 =
+ & parcours%interp_loc%sendtoproc2(0:Agrif_Nbprocs-1)
+ recvfromproc2 =
+ & parcours%interp_loc%recvfromproc2(0:Agrif_Nbprocs-1)
+
+ find_list_update = .TRUE.
+ Exit Find_loop
+ End Do Find_loop
+
+ End Subroutine Agrif_Find_list_update
+
+ Subroutine Agrif_AddTo_list_update(list_update,pttab,petab,
+ & pttab_Child,pttab_Parent,nbdim
+ & ,tab4t,tab5t,memberinall,memberinall2,
+ & sendtoproc1,recvfromproc1,sendtoproc2,recvfromproc2)
+
+ TYPE(Agrif_List_Interp_Loc), Pointer :: list_update
+ INTEGER :: nbdim
+ INTEGER,DIMENSION(nbdim) :: pttab,petab,pttab_Child,pttab_Parent
+ INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab4t
+ INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1,8) :: tab5t
+ LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: memberinall, memberinall2
+ LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc1, recvfromproc1
+ LOGICAL,DIMENSION(0:Agrif_Nbprocs-1) :: sendtoproc2, recvfromproc2
+
+ Type(Agrif_List_Interp_loc), Pointer :: parcours
+
+ Allocate(parcours)
+ Allocate(parcours%interp_loc)
+
+ parcours%interp_loc%pttab(1:nbdim) = pttab(1:nbdim)
+ parcours%interp_loc%petab(1:nbdim) = petab(1:nbdim)
+ parcours%interp_loc%pttab_child(1:nbdim) = pttab_child(1:nbdim)
+ parcours%interp_loc%pttab_parent(1:nbdim) = pttab_parent(1:nbdim)
+ Allocate(parcours%interp_loc%tab4t(nbdim,0:Agrif_Nbprocs-1,8))
+ Allocate(parcours%interp_loc%memberinall(0:Agrif_Nbprocs-1))
+
+ Allocate(parcours%interp_loc%tab5t(nbdim,0:Agrif_Nbprocs-1,8))
+ Allocate(parcours%interp_loc%memberinall2(0:Agrif_Nbprocs-1))
+ Allocate(parcours%interp_loc%sendtoproc1(0:Agrif_Nbprocs-1))
+ Allocate(parcours%interp_loc%recvfromproc1(0:Agrif_Nbprocs-1))
+ Allocate(parcours%interp_loc%sendtoproc2(0:Agrif_Nbprocs-1))
+ Allocate(parcours%interp_loc%recvfromproc2(0:Agrif_Nbprocs-1))
+
+ parcours%interp_loc%tab4t=tab4t
+ parcours%interp_loc%memberinall=memberinall
+
+ parcours%interp_loc%tab5t=tab5t
+ parcours%interp_loc%memberinall2=memberinall2
+ parcours%interp_loc%sendtoproc1=sendtoproc1
+ parcours%interp_loc%recvfromproc1=recvfromproc1
+ parcours%interp_loc%sendtoproc2=sendtoproc2
+ parcours%interp_loc%recvfromproc2=recvfromproc2
+
+ parcours%suiv => list_update
+
+ list_update => parcours
+
+ End Subroutine Agrif_Addto_list_update
+#endif
+
+
+C **************************************************************************
+CCC Subroutine Agrif_Update_1D_Recursive
+C **************************************************************************
+C
+ Subroutine Agrif_Update_1D_recursive(TypeUpdate,tempP,tempC,
+ & indmin,indmax,
+ & pttab_child,petab_child,
+ & s_child,s_parent,
+ & ds_child,ds_parent,nbdim)
+C
+CCC Description:
+CCC Subroutine to update a 1D grid variable on the parent grid.
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: nbdim
+ INTEGER, DIMENSION(nbdim) :: TypeUpdate ! TYPE of update (copy or average)
+ INTEGER, DIMENSION(nbdim) :: indmin,indmax
+ INTEGER, DIMENSION(nbdim) :: pttab_child,petab_child
+ REAL, DIMENSION(nbdim) :: s_child,s_parent
+ REAL, DIMENSION(nbdim) :: ds_child,ds_parent
+ REAL, DIMENSION(indmin(nbdim):indmax(nbdim)) :: tempP
+ REAL, DIMENSION(pttab_child(nbdim):petab_child(nbdim)) :: tempC
+ INTEGER :: coeffraf,locind_child_left
+C
+C
+ Call Agrif_Compute_nbdim_update(s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),coeffraf,locind_child_left)
+
+ Call Agrif_UpdateBase(TypeUpdate(1),
+ & tempP(indmin(nbdim):indmax(nbdim)),
+ & tempC(pttab_child(nbdim):petab_child(nbdim)),
+ & indmin(nbdim),indmax(nbdim),
+ & pttab_child(nbdim),petab_child(nbdim),
+ & s_parent(nbdim),s_child(nbdim),
+ & ds_parent(nbdim),ds_child(nbdim),
+ & coeffraf,locind_child_left)
+
+C
+ Return
+C
+C
+ End Subroutine Agrif_Update_1D_recursive
+
+ End Module Agrif_Update
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modupdatebasic.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modupdatebasic.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modupdatebasic.F (revision 8155)
@@ -0,0 +1,659 @@
+!
+! $Id: modupdatebasic.F 2715 2011-03-30 15:58:35Z rblod $
+!
+C AGRIF (Adaptive Grid Refinement In Fortran)
+C
+C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
+C Christophe Vouland (Christophe.Vouland@imag.fr)
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+C
+C
+C
+CCC Module Agrif_Updatebasic
+C
+C
+ Module Agrif_Updatebasic
+C
+CCC Description:
+CCC Module containing different procedures of update (copy,average,
+CCC full_weighting) used in the Agrif_Update module.
+C
+C Modules used:
+C
+ USE Agrif_types
+
+ IMPLICIT NONE
+
+ integer,dimension(:,:),allocatable :: indchildcopy
+ integer,dimension(:,:),allocatable :: indchildaverage
+C
+
+ CONTAINS
+C Define procedures contained in this module
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Copy1d
+C **************************************************************************
+C
+ Subroutine agrif_copy1d(x,y,np,nc,
+ & s_parent,s_child,ds_parent,ds_child)
+C
+CCC Description:
+CCC Subroutine to do a copy on a parent grid (vector x) from its child grid
+CCC (vector y).
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: np,nc
+ REAL, DIMENSION(np) :: x
+ REAL, DIMENSION(nc) :: y
+ REAL :: s_parent,s_child
+ REAL :: ds_parent,ds_child
+C
+C Local variables
+ INTEGER :: i,locind_child_left,coeffraf
+C
+C
+ coeffraf = nint(ds_parent/ds_child)
+C
+ if (coeffraf == 1) then
+C
+ locind_child_left = 1 + nint((s_parent - s_child)/ds_child)
+C
+!CDIR ALTCODE
+ x(1:np) = y(locind_child_left:locind_child_left+np-1)
+C
+ return
+C
+ endif
+C
+
+ locind_child_left = 1 + nint((s_parent - s_child)/ds_child)
+
+!CDIR ALTCODE
+ do i = 1,np
+C
+ x(i) = y(locind_child_left)
+C
+ locind_child_left = locind_child_left + coeffraf
+C
+ enddo
+
+C
+ Return
+C
+C
+ End Subroutine agrif_copy1d
+
+C **************************************************************************
+CCC Subroutine Copy1dprecompute
+C **************************************************************************
+C
+ Subroutine copy1dprecompute2d(nc2,np,nc,
+ & s_parent,s_child,ds_parent,ds_child,dir)
+C
+CCC Description:
+CCC Subroutine to precompute index for a copy on a parent grid (vector x) from
+CCC its child grid (vector y).
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+C Arguments
+ INTEGER :: nc2,np,nc
+ INTEGER :: dir
+ REAL :: s_parent,s_child
+ REAL :: ds_parent,ds_child
+C
+C Local variables
+ INTEGER,DIMENSION(:,:),ALLOCATABLE :: indchildcopy_tmp
+ INTEGER :: i,locind_child_left,coeffraf
+C
+C
+ coeffraf = nint(ds_parent/ds_child)
+C
+ locind_child_left = 1 + nint((s_parent - s_child)/ds_child)
+
+ if (.not.allocated(indchildcopy)) then
+ allocate(indchildcopy(np*nc2,3))
+ else
+ if (size(indchildcopy,1) Agrif_Mygrid % child_grids
+ endif
+ else
+ Agrif_oldmygrid => Agrif_Mygrid % child_grids
+ Nullify(Agrif_Mygrid % child_grids)
+ endif
+C
+ if ( Agrif_USE_ONLY_FIXED_GRIDS .EQ. 0 ) then
+C
+ Call Agrif_Save_All(Agrif_oldmygrid)
+C
+ Call Agrif_Free_before_All(Agrif_oldmygrid)
+C
+C Creation of the grid hierarchy from coarsegrid_moving
+ Call Agrif_Create_Grids
+ & (Agrif_Mygrid,coarsegrid_moving)
+C
+ endif
+C
+C Initialization of the grid hierarchy by copy or interpolation
+C
+ Call Agrif_Init_Hierarchy(Agrif_Mygrid)
+C
+ if ( Agrif_USE_ONLY_FIXED_GRIDS .EQ. 0 )
+ & Call Agrif_Free_after_All(Agrif_oldmygrid)
+C
+ Deallocate(coarsegrid_fixed)
+ Deallocate(coarsegrid_moving)
+C
+ Return
+C
+C Opening error
+C
+ 99 INQUIRE(FILE='AGRIF_FixedGrids.in',EXIST=BEXIST)
+ If (.not. BEXIST) Then
+ print*,'ERROR : File AGRIF_FixedGrids.in not found.'
+ STOP
+ Else
+ print*,'Error opening file AGRIF_FixedGrids.in'
+ STOP
+ endif
+C
+ End Subroutine Agrif_Regrid
+C
+C **************************************************************************
+CCC Subroutine Agrif_detect_All
+C **************************************************************************
+C
+ Recursive Subroutine Agrif_detect_all(g)
+C
+CCC Description:
+CCC Subroutine to detect areas to be refined.
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+C Pointer argument
+ TYPE(Agrif_Grid) ,pointer :: g ! Pointer on the current grid
+C
+C Local variables
+ Type(Agrif_pgrid),pointer :: parcours ! Pointer for the recursive
+ ! procedure
+ INTEGER, DIMENSION(3) :: size
+ INTEGER :: iii
+ Real :: g_eps
+C
+ parcours => g % child_grids
+C
+C To be positioned on the finer grids of the grid hierarchy
+C
+ do while (associated(parcours))
+ Call Agrif_detect_all (parcours % gr)
+ parcours => parcours % next
+ enddo
+C
+ g_eps = huge(1.)
+ do iii = 1 , Agrif_Probdim
+ g_eps=min(g_eps,g%Agrif_d(iii))
+ enddo
+C
+ g_eps = g_eps/100.
+C
+ if ( Agrif_Probdim .EQ. 1 ) g%tabpoint1D=0
+ if ( Agrif_Probdim .EQ. 2 ) g%tabpoint2D=0
+ if ( Agrif_Probdim .EQ. 3 ) g%tabpoint3D=0
+C
+ do iii = 1 , Agrif_Probdim
+ if (g%Agrif_d(iii)/Agrif_coeffref(iii).LT.
+ & (Agrif_mind(iii)-g_eps)) Return
+ enddo
+C
+ Call Agrif_instance(g)
+C
+C Detection (Agrif_detect is a user s routine)
+C
+
+ do iii = 1 , Agrif_Probdim
+ size(iii) = g%nb(iii) + 1
+ enddo
+C
+ SELECT CASE (Agrif_Probdim)
+ CASE (1)
+ Call Agrif_detect(g%tabpoint1D,size)
+ CASE (2)
+ Call Agrif_detect(g%tabpoint2D,size)
+ CASE (3)
+ Call Agrif_detect(g%tabpoint3D,size)
+ END SELECT
+C
+C Addition of the areas detected on the child grids
+C
+ parcours => g % child_grids
+C
+ Do while (associated(parcours))
+ Call Agrif_Add_detected_areas (g,parcours % gr)
+ parcours => parcours % next
+ enddo
+C
+ Return
+C
+ End Subroutine Agrif_detect_all
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Add_detected_areas
+C **************************************************************************
+C
+ Subroutine Agrif_Add_detected_areas(parentgrid,childgrid)
+C
+CCC Description:
+CCC Subroutine to add on the parent grid the areas detected
+CC on its child grids.
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+ Type(Agrif_Grid),pointer :: parentgrid,childgrid
+C
+ Integer :: i,j,k
+C
+ do i = 1,childgrid%nb(1)+1
+ if ( Agrif_Probdim .EQ. 1 ) then
+ If (childgrid%tabpoint1D(i).EQ.1) Then
+ parentgrid%tabpoint1D(childgrid%ix(1)+
+ & (i-1)/Agrif_Coeffref(1)) = 1
+ endif
+ else
+ do j=1,childgrid%nb(2)+1
+ if (Agrif_Probdim.EQ.2) then
+ If (childgrid%tabpoint2D(i,j).EQ.1) Then
+ parentgrid%tabpoint2D(
+ & childgrid%ix(1)+(i-1)/Agrif_Coeffref(1),
+ & childgrid%ix(2)+(j-1)/Agrif_Coeffref(2)) = 1
+ endif
+ else
+ do k=1,childgrid%nb(3)+1
+ If (childgrid%tabpoint3D(i,j,k).EQ.1) Then
+ parentgrid%tabpoint3D(
+ & childgrid%ix(1)+(i-1)/Agrif_Coeffref(1),
+ & childgrid%ix(2)+(j-1)/Agrif_Coeffref(2),
+ & childgrid%ix(3)+(k-1)/Agrif_Coeffref(3)) = 1
+ endif
+ enddo
+ endif
+ enddo
+ endif
+ enddo
+C
+ Return
+C
+ End Subroutine Agrif_Add_detected_areas
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Free_before_All
+C **************************************************************************
+C
+ Recursive Subroutine Agrif_Free_before_All(g)
+C
+CCC Description:
+C
+CC Method:
+C
+C Declarations:
+C
+C Pointer argument
+ Type(Agrif_pgrid),pointer :: g ! Pointer on the current grid
+C
+C Local pointer
+ Type(Agrif_pgrid),pointer :: parcours ! Pointer for the recursive
+ ! procedure
+C
+C
+ parcours => g
+C
+ Do while (associated(parcours))
+ If (.not. parcours%gr%fixed) Then
+ Call Agrif_Free_data_before(parcours%gr)
+ parcours % gr % oldgrid = .TRUE.
+ endif
+C
+ Call Agrif_Free_before_all (parcours % gr % child_grids)
+C
+ parcours => parcours % next
+ enddo
+C
+ Return
+C
+C
+ End Subroutine Agrif_Free_before_All
+C **************************************************************************
+CCC Subroutine Agrif_Save_All
+C **************************************************************************
+C
+ Recursive Subroutine Agrif_Save_All(g)
+C
+CCC Description:
+C
+CC Method:
+C
+C Declarations:
+C
+C Pointer argument
+ Type(Agrif_pgrid),pointer :: g ! Pointer on the current grid
+C
+C Local pointer
+ Type(Agrif_pgrid),pointer :: parcours ! Pointer for the recursive
+ ! procedure
+C
+C
+ parcours => g
+C
+ Do while (associated(parcours))
+ If (.not. parcours%gr%fixed) Then
+ Call Agrif_Instance(parcours%gr)
+ Call Agrif_Before_Regridding()
+ parcours % gr % oldgrid = .TRUE.
+ endif
+C
+ Call Agrif_Save_All (parcours % gr % child_grids)
+C
+ parcours => parcours % next
+ enddo
+C
+ Return
+C
+C
+ End Subroutine Agrif_Save_All
+C
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Free_after_All
+C **************************************************************************
+C
+ Recursive Subroutine Agrif_Free_after_All(g)
+C
+CCC Description:
+C
+CC Method:
+C
+C Declarations:
+C
+
+C
+C Pointer argument
+ Type(Agrif_pgrid),pointer :: g ! Pointer on the current grid
+C
+C Local pointers
+ TYPE(Agrif_pgrid),pointer :: parcours ! Pointer for the recursive proced
+ Type(Agrif_pgrid),pointer :: preparcours
+ Type(Agrif_pgrid),pointer :: preparcoursini
+C
+C
+ Allocate(preparcours)
+C
+ preparcoursini => preparcours
+C
+ Nullify(preparcours % gr)
+C
+ preparcours % next => g
+C
+ parcours => g
+C
+ Do while (associated(parcours))
+C
+ if ( (.NOT. parcours% gr% fixed) .AND.
+ & (parcours% gr% oldgrid ) ) then
+ Call Agrif_Free_data_after(parcours%gr)
+ endif
+C
+ Call Agrif_Free_after_all (parcours % gr % child_grids)
+C
+ If (parcours % gr % oldgrid) Then
+ Deallocate(parcours % gr)
+ preparcours % next => parcours % next
+ Deallocate(parcours)
+ parcours => preparcours % next
+ Else
+ preparcours => preparcours % next
+ parcours => parcours % next
+ endif
+ enddo
+C
+ Deallocate(preparcoursini)
+C
+ Return
+C
+ End Subroutine Agrif_Free_after_All
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Integrate
+C **************************************************************************
+C
+ Recursive Subroutine Agrif_Integrate(g, procname)
+C
+CCC Description:
+CCC Subroutine to manage the time integration of the grid hierarchy.
+C
+CC Method:
+CC Recursive subroutine and call on subroutines Agrif_Instance & Agrif_Step
+C
+C Declarations:
+C
+
+C
+C Pointer argument
+ Type(Agrif_Grid),pointer :: g ! Pointer on the current grid
+C
+C main procedure name
+ Optional :: procname
+ External :: procname
+C
+C Local pointer
+ Type(Agrif_pgrid),pointer :: parcours ! Pointer for the recursive
+ ! procedure
+C
+C Local scalars
+ INTEGER :: nbt ! Number of time steps
+ ! of the current grid
+ INTEGER :: k
+ INTEGER :: iii
+C
+C Instanciation of the variables of the current grid
+ If (g%fixedrank .NE.0) Then
+ Call Agrif_Instance
+ & (g)
+ End If
+C
+C One step on the current grid
+C
+ If (present(procname)) Then
+ Call procname ()
+ Else
+ write(*,*) 'The name of the step subroutine has not '
+ write(*,*) 'been given in the subroutine Agrif_Integrate'
+ stop
+ endif
+C
+C Number of time steps on the current grid
+C
+ g%ngridstep = g % ngridstep + 1
+C
+ parcours => g % child_grids
+C
+C Recursive procedure for the time integration of the grid hierarchy
+ Do while (associated(parcours))
+C
+C Instanciation of the variables of the current grid
+ Call Agrif_Instance
+ & (parcours % gr)
+C
+C Number of time steps
+ nbt = 1
+ do iii = 1 , Agrif_Probdim
+ nbt = max(nbt, parcours % gr % timeref(iii))
+ enddo
+C
+ Do k = 1,nbt
+C
+ If (present(procname)) Then
+ Call Agrif_Integrate (parcours % gr, procname)
+ Else
+ Call Agrif_Integrate (parcours % gr)
+ endif
+C
+ enddo
+C
+ parcours => parcours % next
+C
+ enddo
+C
+C
+ End Subroutine Agrif_Integrate
+
+C **************************************************************************
+CCC Subroutine Agrif_Integrate_Child
+C **************************************************************************
+C
+ Recursive Subroutine Agrif_Integrate_Child(g,procname)
+C
+CCC Description:
+CCC Subroutine to manage the time integration of the grid hierarchy.
+C
+CC Method:
+CC Recursive subroutine and call on subroutines Agrif_Instance & Agrif_Step.
+C
+C Declarations:
+C
+
+C
+C Pointer argument
+ Type(Agrif_Grid),pointer :: g ! Pointer on the current grid
+C
+C main procedure name
+ Optional :: procname
+ External :: procname
+C
+C Local pointer
+ Type(Agrif_pgrid),pointer :: parcours ! Pointer for the recursive
+ ! procedure
+C
+C One step on the current grid
+C
+ If (present(procname)) Then
+ Call procname ()
+ Else
+ write(*,*) 'The name of the step subroutine has not '
+ write(*,*) 'been given in the subroutine Agrif_Integrate'
+ stop
+ endif
+C
+C Number of time steps on the current grid
+C
+C
+ parcours => g % child_grids
+C
+C Recursive procedure for the time integration of the grid hierarchy
+ Do while (associated(parcours))
+C
+C Instanciation of the variables of the current grid
+ Call Agrif_Instance
+ & (parcours % gr)
+
+C
+ If (present(procname)) Then
+ Call Agrif_Integrate_Child (parcours % gr, procname)
+ Else
+ Call Agrif_Integrate_Child (parcours % gr)
+ endif
+C
+ parcours => parcours % next
+C
+ enddo
+C
+C
+ End Subroutine Agrif_Integrate_Child
+
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Init_Grids
+C **************************************************************************
+C
+ Subroutine Agrif_Init_Grids
+C
+CCC Description:
+CCC Subroutine to initialize the root coarse grid pointed by Agrif_Mygrid.
+CCC It is called in the main program.
+C
+C Declarations:
+C
+C
+ INTEGER :: iii
+C
+C definition of the probdim and modtypes variables
+C
+#ifdef key_mpp_mpi
+ INCLUDE 'mpif.h'
+ Agrif_MPIPREC = MPI_DOUBLE_PRECISION
+#endif
+ Call Agrif_probdim_modtype_def()
+C
+ Agrif_UseSpecialValue = .FALSE.
+ Agrif_UseSpecialValueFineGrid = .FALSE.
+ Agrif_SpecialValue = 0.
+ Agrif_SpecialValueFineGrid = 0.
+C
+C Allocation of Agrif_Mygrid
+ allocate(Agrif_Mygrid)
+C
+C Space and time refinement factors are set to 1 on the root grid
+C
+ do iii = 1 , Agrif_Probdim
+ Agrif_Mygrid % spaceref(iii) = 1
+ Agrif_Mygrid % timeref(iii) = 1
+ enddo
+C
+C Initialization of the number of time steps
+ Agrif_Mygrid % ngridstep = 0
+ Agrif_Mygrid % grid_id = 0
+C
+C No parent grid for the root coarse grid
+ Nullify(Agrif_Mygrid % parent)
+C
+C Initialization of the minimum positions, global abscissa and space steps
+ do iii= 1 , Agrif_Probdim
+ Agrif_Mygrid % ix(iii) = 1
+ Agrif_Mygrid % Agrif_x(iii) = 0.
+ Agrif_Mygrid % Agrif_d(iii) = 1.
+C Borders of the root coarse grid
+ Agrif_Mygrid % NearRootBorder(iii) = .true.
+ Agrif_Mygrid % DistantRootBorder(iii) = .true.
+ enddo
+C
+C The root coarse grid is a fixed grid
+ Agrif_Mygrid % fixed = .TRUE.
+C Level of the root grid
+ Agrif_Mygrid % level = 0
+C Maximum level in the hierarchy
+ Agrif_MaxLevelLoc = 0
+
+C
+C Number of the grid pointed by Agrif_Mygrid (root coarse grid)
+ Agrif_Mygrid % rank = 1
+C
+C Number of the root grid as a fixed grid
+ Agrif_Mygrid % fixedrank = 0
+C
+C Initialization of some fields of the root grid variables
+ Call Agrif_Create_Var (Agrif_Mygrid)
+C
+C Initialization of the other fields of the root grid variables (number of
+C cells, positions, number and type of its dimensions, ...)
+ Call Agrif_Set_numberofcells(Agrif_Mygrid)
+C
+ Call Agrif_Instance (Agrif_Mygrid)
+C
+ Call Agrif_Set_numberofcells(Agrif_Mygrid)
+C
+C Allocation of the array containing the values of the grid variables
+ Call Agrif_Allocation (Agrif_Mygrid)
+C
+ Call Agrif_initialisations(Agrif_Mygrid)
+C
+ nullify(Agrif_Mygrid % child_grids)
+C
+C Total number of fixed grids
+ Agrif_nbfixedgrids = 0
+C
+ Call Agrif_Instance (Agrif_Mygrid)
+C
+ End Subroutine Agrif_Init_Grids
+C
+C
+C **************************************************************************
+CCC Subroutine Agrif_Deallocation
+C **************************************************************************
+C
+ Subroutine Agrif_Deallocation
+C
+CCC Description:
+CCC Subroutine to initialize the root coarse grid pointed by Agrif_Mygrid.
+CCC It is called in the main program.
+C
+C Declarations:
+C
+C
+ INTEGER :: nb
+C
+C definition of the probdim and modtypes variables
+C
+ do nb = 1, Agrif_NbVariables
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % array1) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % array1)
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % array2) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % array2)
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % array3) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % array3)
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % array4) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % array4)
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % array5) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % array5)
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % array6) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % array6)
+C
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % iarray1) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % iarray1)
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % iarray2) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % iarray2)
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % iarray3) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % iarray3)
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % iarray4) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % iarray4)
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % iarray5) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % iarray5)
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % iarray6) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % iarray6)
+C
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % larray1) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % larray1)
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % larray2) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % larray2)
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % larray3) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % larray3)
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % larray4) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % larray4)
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % larray5) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % larray5)
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % larray6) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % larray6)
+C
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % carray1) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % carray1)
+ if ( allocated(Agrif_Mygrid % tabvars(nb) % var % carray2) )
+ & Deallocate(Agrif_Mygrid % tabvars(nb) % var % carray2)
+ enddo
+C
+ do nb = 1, Agrif_NbVariables
+ Deallocate(Agrif_Mygrid % tabvars(nb) % var)
+ enddo
+C
+ Deallocate(Agrif_Mygrid % tabvars)
+C
+ Deallocate(Agrif_Mygrid)
+C
+ End Subroutine Agrif_Deallocation
+C
+ End module Agrif_Util
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modvariables.F
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modvariables.F (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/AGRIF_FILES/modvariables.F (revision 8155)
@@ -0,0 +1,152 @@
+ Module Agrif_Variables
+ Use Agrif_CurgridFunctions
+
+ Contains
+ Subroutine Agrif_Declare_Variable(posvar,firstpoint,
+ & raf,lb,ub,varid,torestore)
+ character*(80) :: variablename
+ Type(Agrif_List_Variables), Pointer :: newvariable,newvariablep
+ INTEGER, DIMENSION(:) :: posvar
+ INTEGER, DIMENSION(:) :: lb,ub
+ INTEGER, DIMENSION(:) :: firstpoint
+ CHARACTER(*) ,DIMENSION(:) :: raf
+ TYPE(Agrif_Pvariable), Pointer :: parent_var,root_var
+ INTEGER :: dimensio
+ INTEGER :: varid
+ LOGICAL, OPTIONAL :: torestore
+ LOGICAL :: restaure
+
+! if (agrif_root()) return
+
+ variablename = 'xxx'
+
+ restaure = .FALSE.
+ if (agrif_mygrid%ngridstep /= 0) then
+ if (present(torestore)) restaure = torestore
+ endif
+
+ dimensio = SIZE(posvar)
+C
+C
+ Allocate(newvariable)
+ Allocate(newvariable%pvar)
+ Allocate(newvariable%pvar%var)
+ Allocate(newvariable%pvar%var%posvar(dimensio))
+ Allocate(newvariable%pvar%var%interptab(dimensio))
+ newvariable%pvar%var%variablename = variablename
+ newvariable%pvar%var%interptab = raf
+ newvariable%pvar%var%nbdim = dimensio
+ newvariable%pvar%var%posvar = posvar
+ newvariable%pvar%var%point(1:dimensio) = firstpoint
+ newvariable%pvar%var%restaure = restaure
+
+ newvariable%pvar%var%lb(1:dimensio) = lb(1:dimensio)
+ newvariable%pvar%var%ub(1:dimensio) = ub(1:dimensio)
+
+ if (restaure) then
+ select case(dimensio)
+ case(1)
+ Allocate( newvariable%pvar%var%Restore1D(
+ & lb(1):ub(1)))
+ newvariable%pvar%var%Restore1D = 0
+ case(2)
+ Allocate( newvariable%pvar%var%Restore2D(
+ & lb(1):ub(1),lb(2):ub(2)))
+ newvariable%pvar%var%Restore2D = 0
+ case(3)
+ Allocate( newvariable%pvar%var%Restore3D(
+ & lb(1):ub(1),lb(2):ub(2),lb(3):ub(3)))
+ newvariable%pvar%var%Restore3D = 0
+ case(4)
+ Allocate( newvariable%pvar%var%Restore4D(
+ & lb(1):ub(1),lb(2):ub(2),lb(3):ub(3),lb(4):ub(4)))
+ newvariable%pvar%var%Restore4D = 0
+ case(5)
+ Allocate( newvariable%pvar%var%Restore5D(
+ & lb(1):ub(1),lb(2):ub(2),lb(3):ub(3),lb(4):ub(4),
+ & lb(5):ub(5)))
+ newvariable%pvar%var%Restore5D = 0
+ end select
+ endif
+
+ newvariable % nextvariable => Agrif_Curgrid%variables
+
+ Agrif_Curgrid%variables => newvariable
+ Agrif_Curgrid%Nbvariables = Agrif_Curgrid%Nbvariables + 1
+
+ varid = -Agrif_Curgrid%Nbvariables
+
+! if (agrif_curgrid%parent%nbvariables < agrif_curgrid%nbvariables)
+! & then
+! Allocate(newvariablep)
+! Allocate(newvariablep%pvar)
+! Allocate(newvariablep%pvar%var)
+! Allocate(newvariablep%pvar%var%posvar(dimensio))
+! Allocate(newvariablep%pvar%var%interptab(dimensio))
+! newvariablep%pvar%var%variablename = variablename
+! newvariablep%pvar%var%interptab = raf
+! newvariablep%pvar%var%nbdim = dimensio
+! newvariablep%pvar%var%posvar = posvar
+! newvariablep%pvar%var%point(1:dimensio) = firstpoint
+! newvariablep%pvar%var%restaure = restaure
+!
+! newvariablep%pvar%var%lb(1:dimensio) = lb(1:dimensio)
+! newvariablep%pvar%var%ub(1:dimensio) = ub(1:dimensio)
+!
+! newvariablep % nextvariable => Agrif_Curgrid%parent%variables
+!
+! Agrif_Curgrid%parent%variables => newvariablep
+!
+! Agrif_Curgrid%parent%Nbvariables =
+! & Agrif_Curgrid%parent%Nbvariables + 1
+! parent_var=>newvariablep%pvar
+! else
+! parent_var=>Agrif_Search_Variable
+! & (Agrif_Curgrid%parent,Agrif_Curgrid%nbvariables)
+! endif
+
+ if (.not.agrif_root()) then
+ parent_var=>Agrif_Search_Variable
+ & (Agrif_Curgrid%parent,Agrif_Curgrid%nbvariables)
+
+ newvariable%pvar%parent_var=>parent_var
+ do i=1,dimensio
+ if (parent_var%var%interptab(i)=='N') then
+ parent_var%var%lb(i)=lb(i)
+ parent_var%var%ub(i)=ub(i)
+ endif
+ enddo
+ endif
+
+ root_var=>Agrif_Search_Variable
+ & (Agrif_Mygrid,Agrif_Curgrid%nbvariables)
+
+ newvariable%pvar%var%root_var=>root_var%var
+
+
+ End Subroutine Agrif_Declare_Variable
+
+ FUNCTION Agrif_Search_Variable(grid,varid)
+ integer :: varid
+ Type(Agrif_Pvariable), Pointer :: Agrif_Search_variable
+ Type(Agrif_grid), Pointer :: grid
+
+ Type(Agrif_List_Variables), pointer :: parcours
+ Logical :: foundvariable
+ integer nb
+ integer :: varidinv
+
+ foundvariable = .FALSE.
+ parcours => grid%variables
+ varidinv = 1 + grid%nbvariables - varid
+
+ do nb=1,varidinv-1
+ parcours => parcours%nextvariable
+ End Do
+
+ Agrif_Search_variable => parcours%pvar
+
+
+ End Function Agrif_Search_variable
+
+ End Module Agrif_Variables
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/Makefile.lex
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/Makefile.lex (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/Makefile.lex (revision 8155)
@@ -0,0 +1,77 @@
+# Compilation:
+CC = cc -O -g -Wall
+LEX = flex
+
+# option de flex et pas de lex
+LEXFLAGS=-i
+YACC = byacc -t -v -g
+YACC = bison -t -v -g
+YACC = bison
+
+
+OBJS = main.o WriteInFile.o toamr.o fortran.o \
+ dependfile.o SubLoopCreation.o WorkWithlistvarindoloop.o \
+ WorkWithvarofsubroutineliste.o WorkWithParameterlist.o \
+ Writedeclarations.o WorkWithglobliste.o UtilFortran.o \
+ UtilNotGridDep.o WorkWithlistdatavariable.o \
+ DiversListe.o UtilAgrif.o WorkWithAllocatelist.o \
+ UtilCharacter.o UtilListe.o UtilFile.o \
+ WorkWithlistofmodulebysubroutine.o WorkWithlistmoduleinfile.o \
+ WorkWithlistofcoupled.o
+
+.SUFFIXES:
+.SUFFIXES: .c .o
+
+all : conv
+
+conv : $(OBJS)
+ $(CC) $(OBJS) $(LEXLIB) -o ../$@
+
+main.o : main.c
+main.c : convert.tab.c convert.yy.c
+ rm -f main.c
+ cat convert.tab.c convert.yy.c > main.c
+ rm -f convert.yy.c convert.tab.c
+fortran.o : fortran.c
+fortran.c : fortran.tab.c fortran.yy.c
+ rm -f fortran.c
+ cat fortran.tab.c fortran.yy.c > fortran.c
+#rm -f fortran.yy.c fortran.tab.c
+convert.tab.c : convert.y decl.h
+ $(YACC) convert.y
+# mv -f y.tab.c convert.tab.c
+fortran.tab.c : fortran.y decl.h
+ $(YACC) -p fortran fortran.y
+# mv -f y.tab.c fortran.tab.c
+# mv -f y.output fortran.output
+# mv -f y.dot fortran.dot
+convert.yy.c : convert.lex
+ $(LEX) $(LEXFLAGS) -oconvert.yy.c convert.lex
+fortran.yy.c : fortran.lex
+ $(LEX) $(LEXFLAGS) -Pfortran -ofortran.yy.c fortran.lex
+
+toamr.o : toamr.c decl.h
+WriteInFile.o : WriteInFile.c decl.h
+dependfile.o : dependfile.c decl.h
+SubLoopCreation.o : SubLoopCreation.c decl.h
+WorkWithglobliste.o : WorkWithglobliste.c decl.h
+WorkWithlistvarindoloop.o : WorkWithlistvarindoloop.c decl.h
+WorkWithvarofsubroutineliste.o : WorkWithvarofsubroutineliste.c decl.h
+Writedeclarations.o : Writedeclarations.c decl.h
+UtilFortran.o : UtilFortran.c decl.h
+WorkWithParameterlist.o : WorkWithParameterlist.c decl.h
+UtilNotGridDep.o : UtilNotGridDep.c decl.h
+WorkWithlistdatavariable.o : WorkWithlistdatavariable.c decl.h
+DiversListe.o : DiversListe.c decl.h
+UtilAgrif.o : UtilAgrif.c decl.h
+WorkWithAllocatelist.o : WorkWithAllocatelist.c decl.h
+UtilCharacter.o : UtilCharacter.c decl.h
+UtilListe.o : UtilListe.c decl.h
+UtilFile.o : UtilFile.c decl.h
+WorkWithlistofmodulebysubroutine.o : WorkWithlistofmodulebysubroutine.c decl.h
+WorkWithlistmoduleinfile.o : WorkWithlistmoduleinfile.c decl.h
+WorkWithlistofcoupled.o : WorkWithlistofcoupled.c decl.h
+clean :
+ /bin/rm -f *.o y.tab.c main.c lex.yy.c fortran.c \
+ fortran.tab.c fortran.yy.c convert.tab.c convert.yy.c \
+ y.output
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/Makefile.lex.byacc
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/Makefile.lex.byacc (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/Makefile.lex.byacc (revision 8155)
@@ -0,0 +1,76 @@
+# Compilation:
+CC = cc -O -g -Wall
+LEX = flex
+
+# option de flex et pas de lex
+LEXFLAGS=-i
+YACC = byacc -t -v -g
+YACC = bison -t -v -g
+
+
+OBJS = main.o WriteInFile.o toamr.o fortran.o \
+ dependfile.o SubLoopCreation.o WorkWithlistvarindoloop.o \
+ WorkWithvarofsubroutineliste.o WorkWithParameterlist.o \
+ Writedeclarations.o WorkWithglobliste.o UtilFortran.o \
+ UtilNotGridDep.o WorkWithlistdatavariable.o \
+ DiversListe.o UtilAgrif.o WorkWithAllocatelist.o \
+ UtilCharacter.o UtilListe.o UtilFile.o \
+ WorkWithlistofmodulebysubroutine.o WorkWithlistmoduleinfile.o \
+ WorkWithlistofcoupled.o
+
+.SUFFIXES:
+.SUFFIXES: .c .o
+
+all : conv
+
+conv : $(OBJS)
+ $(CC) $(OBJS) $(LEXLIB) -o ../$@
+
+main.o : main.c
+main.c : convert.tab.c convert.yy.c
+ rm -f main.c
+ cat convert.tab.c convert.yy.c > main.c
+ rm -f convert.yy.c convert.tab.c
+fortran.o : fortran.c
+fortran.c : fortran.tab.c fortran.yy.c
+ rm -f fortran.c
+ cat fortran.tab.c fortran.yy.c > fortran.c
+#rm -f fortran.yy.c fortran.tab.c
+convert.tab.c : convert.y decl.h
+ $(YACC) convert.y
+ mv -f y.tab.c convert.tab.c
+fortran.tab.c : fortran.y decl.h
+ $(YACC) -p fortran fortran.y
+ mv -f y.tab.c fortran.tab.c
+ mv -f y.output fortran.output
+ mv -f y.dot fortran.dot
+convert.yy.c : convert.lex
+ $(LEX) $(LEXFLAGS) -oconvert.yy.c convert.lex
+fortran.yy.c : fortran.lex
+ $(LEX) $(LEXFLAGS) -Pfortran -ofortran.yy.c fortran.lex
+
+toamr.o : toamr.c decl.h
+WriteInFile.o : WriteInFile.c decl.h
+dependfile.o : dependfile.c decl.h
+SubLoopCreation.o : SubLoopCreation.c decl.h
+WorkWithglobliste.o : WorkWithglobliste.c decl.h
+WorkWithlistvarindoloop.o : WorkWithlistvarindoloop.c decl.h
+WorkWithvarofsubroutineliste.o : WorkWithvarofsubroutineliste.c decl.h
+Writedeclarations.o : Writedeclarations.c decl.h
+UtilFortran.o : UtilFortran.c decl.h
+WorkWithParameterlist.o : WorkWithParameterlist.c decl.h
+UtilNotGridDep.o : UtilNotGridDep.c decl.h
+WorkWithlistdatavariable.o : WorkWithlistdatavariable.c decl.h
+DiversListe.o : DiversListe.c decl.h
+UtilAgrif.o : UtilAgrif.c decl.h
+WorkWithAllocatelist.o : WorkWithAllocatelist.c decl.h
+UtilCharacter.o : UtilCharacter.c decl.h
+UtilListe.o : UtilListe.c decl.h
+UtilFile.o : UtilFile.c decl.h
+WorkWithlistofmodulebysubroutine.o : WorkWithlistofmodulebysubroutine.c decl.h
+WorkWithlistmoduleinfile.o : WorkWithlistmoduleinfile.c decl.h
+WorkWithlistofcoupled.o : WorkWithlistofcoupled.c decl.h
+clean :
+ /bin/rm -f *.o y.tab.c main.c lex.yy.c fortran.c \
+ fortran.tab.c fortran.yy.c convert.tab.c convert.yy.c \
+ y.output
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/convert.lex
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/convert.lex (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/convert.lex (revision 8155)
@@ -0,0 +1,87 @@
+/******************************************************************************/
+/* */
+/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */
+/* */
+/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */
+/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */
+/* This software is governed by the CeCILL-C license under French law and */
+/* abiding by the rules of distribution of free software. You can use, */
+/* modify and/ or redistribute the software under the terms of the CeCILL-C */
+/* license as circulated by CEA, CNRS and INRIA at the following URL */
+/* "http://www.cecill.info". */
+/* */
+/* As a counterpart to the access to the source code and rights to copy, */
+/* modify and redistribute granted by the license, users are provided only */
+/* with a limited warranty and the software's author, the holder of the */
+/* economic rights, and the successive licensors have only limited */
+/* liability. */
+/* */
+/* In this respect, the user's attention is drawn to the risks associated */
+/* with loading, using, modifying and/or developing or reproducing the */
+/* software by the user in light of its specific status of free software, */
+/* that may mean that it is complicated to manipulate, and that also */
+/* therefore means that it is reserved for developers and experienced */
+/* professionals having in-depth computer knowledge. Users are therefore */
+/* encouraged to load and test the software's suitability as regards their */
+/* requirements in conditions enabling the security of their systems and/or */
+/* data to be ensured and, more generally, to use and operate it in the */
+/* same conditions as regards security. */
+/* */
+/* The fact that you are presently reading this means that you have had */
+/* knowledge of the CeCILL-C license and that you accept its terms. */
+/******************************************************************************/
+/* version 1.7 */
+/******************************************************************************/
+%s character
+%{
+#include
+#include
+#include
+int line_num=1;
+extern FILE * yyin;
+#define MAX_INCLUDE_DEPTH 30
+YY_BUFFER_STATE include_stack[MAX_INCLUDE_DEPTH];
+%}
+
+COMMENT "%"
+SEPARATEUR "::"
+NIMPORTEQUOI .
+COMMENTAIRES1 {COMMENT}{NIMPORTEQUOI}*{COMMENT}
+PROBTYPE "1D"|"2D"|"3D"
+USEITEM "FIXED_GRIDS"|"ONLY_FIXED_GRIDS"|"F77"
+NAME [a-zA-Z\_][a-zA-Z0-9\_]*
+DIGIT [0-9]+
+NEXTLINE \n+[ \t]+"$"|\n+[ \t]+"&"
+%%
+parammodule return TOK_MODULEMAIN; /* name of the module */
+notgriddep return TOK_NOTGRIDDEP; /* variable which are not grid dependent */
+use return TOK_USE;
+{COMMENTAIRES1} {}
+{SEPARATEUR} return TOK_SEP;
+{USEITEM} {strcpy(yylval.na,yytext); return TOK_USEITEM;}
+{PROBTYPE} {strcpy(yylval.na,yytext); return TOK_PROBTYPE;}
+ /* dimension of the problem */
+{NAME} {strcpy(yylval.na,yytext); return TOK_NAME;}
+;|\,|\(|\)|:|\[|\] {return (int) *yytext;}
+\n {line_num++;return (int) *yytext;}
+[ \t]+ ;
+%%
+
+
+int yywrap()
+{
+}
+
+
+yyerror(char *s)
+{
+if (!strcasecmp(curfile,mainfile))
+{
+ printf("Dans convert %s line %d, fichier %s\n",s,line_num,curfile);
+}
+else
+{
+ printf("Dans convert %s line %d, fichier %s\n",s,line_num,curfile);
+}
+exit(0);
+}
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/convert.y
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/convert.y (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/convert.y (revision 8155)
@@ -0,0 +1,450 @@
+/******************************************************************************/
+/* */
+/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */
+/* */
+/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */
+/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */
+/* This software is governed by the CeCILL-C license under French law and */
+/* abiding by the rules of distribution of free software. You can use, */
+/* modify and/ or redistribute the software under the terms of the CeCILL-C */
+/* license as circulated by CEA, CNRS and INRIA at the following URL */
+/* "http://www.cecill.info". */
+/* */
+/* As a counterpart to the access to the source code and rights to copy, */
+/* modify and redistribute granted by the license, users are provided only */
+/* with a limited warranty and the software's author, the holder of the */
+/* economic rights, and the successive licensors have only limited */
+/* liability. */
+/* */
+/* In this respect, the user's attention is drawn to the risks associated */
+/* with loading, using, modifying and/or developing or reproducing the */
+/* software by the user in light of its specific status of free software, */
+/* that may mean that it is complicated to manipulate, and that also */
+/* therefore means that it is reserved for developers and experienced */
+/* professionals having in-depth computer knowledge. Users are therefore */
+/* encouraged to load and test the software's suitability as regards their */
+/* requirements in conditions enabling the security of their systems and/or */
+/* data to be ensured and, more generally, to use and operate it in the */
+/* same conditions as regards security. */
+/* */
+/* The fact that you are presently reading this means that you have had */
+/* knowledge of the CeCILL-C license and that you accept its terms. */
+/******************************************************************************/
+/* version 1.7 */
+/******************************************************************************/
+%{
+#include
+#include
+#include
+#include "decl.h"
+%}
+
+%union {
+ int ival;
+ char na[LONG_C];
+ listnom * ln;
+ }
+
+%token TOK_SEP
+%token TOK_USE
+%token TOK_MODULEMAIN /* name of the module */
+%token TOK_NOTGRIDDEP /* Variable which are not grid dependent */
+%token TOK_USEITEM
+%token TOK_NAME
+%token TOK_PROBTYPE /* dimension of the problem */
+%token ','
+%token ';'
+%token ':'
+%token '('
+%token ')'
+%token '['
+%token ']'
+%%
+input :
+ | input line
+;
+line :'\n'
+ | TOK_PROBTYPE TOK_NAME ';' {initdimprob(1,$2,"0","0");}
+ | TOK_PROBTYPE TOK_NAME ',' TOK_NAME ';' {initdimprob(2,$2, $4,"0");}
+ | TOK_PROBTYPE TOK_NAME ',' TOK_NAME ',' TOK_NAME ';'
+ {initdimprob(3,$2, $4, $6);}
+ | TOK_MODULEMAIN TOK_NAME ';'
+ {listofmodules = Addtolistnom($2,listofmodules,0);
+ Addmoduletothelist($2);}
+ | TOK_NOTGRIDDEP TOK_SEP TOK_NAME ';' {Add_NotGridDepend_Var_1($3);}
+ | TOK_USE TOK_USEITEM ';' {
+ if (!strcasecmp($2,"FIXED_GRIDS"))
+ fixedgrids=1;
+ if (!strcasecmp($2,"ONLY_FIXED_GRIDS"))
+ onlyfixedgrids=1;
+ }
+ ;
+%%
+
+int main(int argc,char *argv[])
+{
+ extern FILE * yyin ;
+ FILE *dependglobaloutput;
+ int i;
+ listnom *parcours;
+ listvar *newvar;
+ int stylegiven = 0;
+ int infreegiven ;
+ int infixedgiven ;
+ int lengthmainfile;
+
+ if (argc < 2)
+ {
+ printf("usage : conv [-rm] [-incdir ] \n");
+ printf(" [-comdirin ] [-comdirout ]\n");
+ printf(" [-convfile ] -SubloopScalar -SubloopScalar1 \n");
+ printf(" [-free|-fixed]\n");
+ exit(0);
+ }
+/******************************************************************************/
+/* 1- Variables initialization */
+/******************************************************************************/
+ List_Global_Var=(listvar *)NULL;
+ List_GlobalParameter_Var=(listvar *)NULL;
+ List_Allocate_Var=(listallocate *)NULL;
+ List_Common_Var=(listvar *)NULL;
+ List_SubroutineWhereAgrifUsed=(listnom *)NULL;
+ List_Subroutine_For_Alloc=(listnom *)NULL;
+ List_Include=(listusemodule *)NULL;
+ List_NameOfModuleUsed=(listusemodule *)NULL;
+ listofmoduletmp=(listusemodule *)NULL;
+ List_SubroutineDeclaration_Var=(listvar *)NULL;
+ List_UsedInSubroutine_Var=(listvar *)NULL;
+ List_NotGridDepend_Var=(listvar *)NULL;
+ Listofavailableindices=(listindice *)NULL;
+ List_CouplePointed_Var=(listvarpointtovar *)NULL;
+ List_ModuleUsed_Var = (listvar *)NULL;
+ List_ModuleUsedInModuleUsed_Var = (listvar *)NULL;
+ List_GlobParamModuleUsed_Var = (listparameter *)NULL;
+ List_GlobParamModuleUsedInModuleUsed_Var = (listparameter *)NULL;
+ List_SubroutineArgument_Var = (listvar *)NULL;
+ List_FunctionType_Var = (listvar *)NULL;
+ tmpuselocallist = (listusemodule *)NULL;
+ List_ContainsSubroutine = (listnom *)NULL;
+ oldfortranout = (FILE *)NULL;
+
+ strcpy(mainfile,argv[1]);
+ strcpy(nomdir,"AGRIF_INC");
+ strcpy(commondirin,".");
+ strcpy(commondirout,".");
+ strcpy(filetoparse," ");
+ strcpy(subofagrifinitgrids,"");
+ strcpy(meetagrifinitgrids,"");
+ strcpy(mpiinitvar,"");
+
+ length_last = 0 ;
+ length_first = 0 ;
+ length_v_typevar = 0 ;
+ length_v_nomvar = 0 ;
+ length_v_dimchar = 0 ;
+ length_v_modulename = 0 ;
+ length_v_commonname = 0 ;
+ length_v_vallengspec = 0 ;
+ length_v_nameinttypename = 0 ;
+ length_v_commoninfile = 0 ;
+ length_v_subroutinename = 0 ;
+ length_v_precision = 0 ;
+ length_v_IntentSpec = 0 ;
+ length_v_initialvalue = 0 ;
+ length_v_readedlistdimension = 0 ;
+ length_u_usemodule = 0 ;
+ length_u_charusemodule = 0 ;
+ length_u_cursubroutine = 0 ;
+ length_u_modulename = 0 ;
+ length_n_name = 0 ;
+ length_c_namevar = 0 ;
+ length_c_namepointedvar = 0 ;
+ length_o_nom = 0 ;
+ length_o_module = 0 ;
+ length_a_nomvar = 0 ;
+ length_a_subroutine = 0 ;
+ length_a_module = 0 ;
+ length_t_usemodule = 0 ;
+ length_t_cursubroutine = 0 ;
+ length_curfilename = 0 ;
+ length_nomfileoutput = 0 ;
+ length_motparse = 0 ;
+ length_mainfile = 0 ;
+ length_nomdir = 0 ;
+ length_commondirout = 0 ;
+ length_commondirin = 0 ;
+ length_filetoparse = 0 ;
+ length_curbuf = 0 ;
+ length_toprintglob = 0 ;
+ length_tmpvargridname = 0 ;
+ length_ligne_Subloop = 0 ;
+ length_lvargridname_toamr = 0 ;
+ length_toprint_utilagrif = 0 ;
+ length_toprinttmp_utilchar = 0 ;
+ length_ligne_writedecl = 0 ;
+ length_newname_toamr = 0 ;
+ length_newname_writedecl = 0 ;
+ length_ligne_toamr = 0 ;
+ length_tmpligne_writedecl = 0 ;
+ value_char_size = 0 ;
+ value_char_size1 = 0 ;
+ value_char_size2 = 0 ;
+ value_char_size3 = 0 ;
+ inallocate = 0;
+ infixed = 1;
+ infree = 0;
+
+ checkexistcommon=1;
+ todebug=0;
+ onlyfixedgrids=0;
+ fixedgrids=0;
+ InAgrifParentDef = 0;
+ IndicenbmaillesX=0;
+ IndicenbmaillesY=0;
+ IndicenbmaillesZ=0;
+ created_dimensionlist = 1;
+ indicemaxtabvars = 0; /* current indice in the table tabvars */
+ SubloopScalar = 0;
+ todebug = 0;
+ todebugfree = 0;
+ retour77 = 1 ;
+ mark = 0 ;
+ shouldincludempif = 0 ;
+ Read_val_max();
+/******************************************************************************/
+/* 2- Program arguments */
+/******************************************************************************/
+
+ if ((yyin=fopen(argv[1],"r"))==NULL)
+ {
+ printf("the file %s doesn't exist \n",argv[1]);
+ exit(0);
+ }
+
+ i=2;
+ while (i.in */
+/******************************************************************************/
+
+ if ((yyin=fopen(argv[1],"r"))==NULL)
+ {
+ printf("the file %s doesn't exist \n",argv[1]);
+ exit(0);
+ }
+ strcpy(mainfile,argv[1]);
+ Save_Length(mainfile,33);
+
+ if ( strstr(filetoparse,".f90") ||
+ strstr(filetoparse,".F90") ) retour77 = 0;
+
+ yyparse();
+
+/******************************************************************************/
+/* 4- Preparation of the file parsing */
+/******************************************************************************/
+ if ((yyin=fopen(filetoparse,"r"))==NULL) /* Is the file to parse exist ? */
+ {
+ printf("the file %s doesn't exist \n",filetoparse);
+ exit(0);
+ }
+ /* mainfile : the name of the file to parse */
+ strcpy(mainfile,filetoparse);
+ /* */
+ if ((dependglobaloutput=fopen(".dependglobal_agrif","r"))!=NULL)
+ {
+ fscanf(dependglobaloutput,"%d\n",&indicemaxtabvars);
+ fclose(dependglobaloutput);
+ }
+ Readthedependavailablefile();
+ /* Read the .dependnbxnby file which contains indices of nbmaillsX, */
+ /* nbmailleY and nbmailleZ */
+ Readthedependnbxnbyfile();
+ Read_Subroutine_For_Alloc();
+/******************************************************************************/
+/* 5- Parsing of the input file (2 times) */
+/******************************************************************************/
+ /* Record all variable in list */
+ firstpass = 1;
+ processfortran(filetoparse);
+ /* */
+ CompleteThelistvarindoloop();
+ /* Read list of module used */
+ RecordUseModulesVariables();
+ /* Read list of module used in module used */
+ RecordUseModulesUseModulesVariables();
+ /* Save variables are considered as globals ones */
+ Update_List_Global_Var_From_List_Save_Var();
+ /* Update all lists */
+ ListUpdate();
+ /* */
+ Clean_List_Global_Var();
+ /* Indice tabvars identification */
+ IndiceTabvarsIdentification();
+ /* Update all lists */
+ ListUpdate();
+ /* The allocation subroutine is necessary ???? */
+ New_Allocate_Subroutine_Is_Necessary();
+ /* The allocation subroutine is necessary for common list */
+ New_Allocate_Subroutine_For_Common_Is_Necessary();
+ /* Sort List_SubroutineArgument_Var */
+ Sort_List_SubroutineArgument_Var();
+ /* Clean all lists */
+ ListClean();
+ /* Update Indice of List_UsedInSubroutine_Var from module used */
+ List_UsedInSubroutine_Var_Update_From_Module_Used();
+ /* Update List_SubroutineWhereAgrifUsed */
+ UpdateList_SubroutineWhereAgrifUsed();
+ /* Update List_UsedInSubroutine_Var with v_readedlistdimension */
+ UpdateList_UsedInSubroutine_With_dimension();;
+ /* */
+ ModifyThelistvarindoloop();
+ /* */
+ UpdateListDeclarationWithDimensionList();
+ /* */
+ GiveTypeOfVariables();
+ Affiche();
+ /* Build new subroutines */
+ firstpass = 0;
+ processfortran(filetoparse);
+
+ newvar = (listvar *)NULL;
+/*newvar = List_Global_Var; */
+ while ( newvar )
+ {
+ printf("++++ %s %d %s %s %s\n",
+ newvar->var->v_nomvar,
+ newvar->var->v_nbdim,
+ newvar->var->v_subroutinename,
+ newvar->var->v_modulename,
+ newvar->var->v_typevar
+ );
+ newvar = newvar->suiv;
+ }
+/******************************************************************************/
+/* 6- Write informations in output files */
+/******************************************************************************/
+
+ /* Write the .dependglobal_agrif file which contain the max indice */
+ /* of the tabvars table */
+ dependglobaloutput = fopen(".dependglobal_agrif","w");
+ fprintf(dependglobaloutput,"%d\n",indicemaxtabvars);
+ fclose(dependglobaloutput);
+ /* Write the list of available indice */
+ Writethedependavailablefile();
+ /* Write the .dependnbxnby file which contains indices of nbmaillsX, */
+ /* nbmailleY and nbmailleZ */
+ Writethedependnbxnbyfile();
+ /* Write the .depend file which contain general informations */
+ /* about variable of this file */
+ parcours = List_NameOfModule;
+ while( parcours )
+ {
+ Writethedependlistofmoduleused(parcours->o_nom);
+ WritedependParameterList(parcours->o_nom);
+ Writethedependfile(parcours->o_nom,List_Global_Var);
+ parcours=parcours->suiv;
+ }
+ parcours = List_NameOfCommon;
+ while( parcours )
+ {
+ Writethedependfile(parcours->o_nom,List_Common_Var);
+ parcours=parcours->suiv;
+ }
+ Write_Subroutine_For_Alloc();
+/******************************************************************************/
+/* 7- Create files in AGRIF_INC directory */
+/******************************************************************************/
+ creefichieramr(NameTamponfile);
+
+ Write_val_max();
+
+ if ( todebug == 1 ) printf("Out of CONV \n");
+ return 0;
+}
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/fortran.lex
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/fortran.lex (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/fortran.lex (revision 8155)
@@ -0,0 +1,370 @@
+/******************************************************************************/
+/* */
+/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */
+/* */
+/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */
+/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */
+/* This software is governed by the CeCILL-C license under French law and */
+/* abiding by the rules of distribution of free software. You can use, */
+/* modify and/ or redistribute the software under the terms of the CeCILL-C */
+/* license as circulated by CEA, CNRS and INRIA at the following URL */
+/* "http://www.cecill.info". */
+/* */
+/* As a counterpart to the access to the source code and rights to copy, */
+/* modify and redistribute granted by the license, users are provided only */
+/* with a limited warranty and the software's author, the holder of the */
+/* economic rights, and the successive licensors have only limited */
+/* liability. */
+/* */
+/* In this respect, the user's attention is drawn to the risks associated */
+/* with loading, using, modifying and/or developing or reproducing the */
+/* software by the user in light of its specific status of free software, */
+/* that may mean that it is complicated to manipulate, and that also */
+/* therefore means that it is reserved for developers and experienced */
+/* professionals having in-depth computer knowledge. Users are therefore */
+/* encouraged to load and test the software's suitability as regards their */
+/* requirements in conditions enabling the security of their systems and/or */
+/* data to be ensured and, more generally, to use and operate it in the */
+/* same conditions as regards security. */
+/* */
+/* The fact that you are presently reading this means that you have had */
+/* knowledge of the CeCILL-C license and that you accept its terms. */
+/******************************************************************************/
+/* version 1.7 */
+/******************************************************************************/
+%x parameter
+%s character
+%x donottreat
+%s fortran77style
+%s fortran90style
+%{
+#include
+#include
+#include
+extern FILE * yyin;
+#define MAX_INCLUDE_DEPTH 30
+#define tabsize 6
+YY_BUFFER_STATE include_stack[MAX_INCLUDE_DEPTH];
+int line_num_fortran=1;
+int line_num_fortran_common=1;
+int newlinef90 = 0;
+char *tmp;
+char tmpc;
+/******************************************************************************/
+/**************PETITS PB NON PREVUS *******************************************/
+/******************************************************************************/
+/* NEXTLINF77 un ligne fortran 77 peut commencer par - &a=b or on */
+/* a prevu seulement & a=b avec l'espace entre le symbole */
+/* de la 7eme et le debut de la ligne de commande */
+/* le ! est aussi interdit comme symbole de la 7 eme colonne */
+/* Normalement NEXTLINEF77 \n+[ ]{5}[^ ] */
+/******************************************************************************/
+#define YY_USER_ACTION \
+ {\
+ if (firstpass == 0) \
+ {\
+ strcat(curbuf,yytext); \
+ Save_Length(curbuf,38); \
+ strcpy(motparse,yytext);\
+ Save_Length(motparse,32); \
+ colnum = colnum + strlen(motparse);\
+ ECHO; \
+ }\
+ strcpy(motparse1,yytext);\
+/* printf("yytext = %s\n",yytext);*/\
+ /*if ( firstpass == 1 )
+ printf("yytext = %s %d\n",yytext,strlen(yytext));*/\
+ }
+%}
+AGRIFDEB "Agrif_debut"
+AGRIFFIN "Agrif_fin"
+REAL8 "real*8"[ \t]*"(a-h,o-z)"
+NOTTREAT Agrif_do_not_treat
+ENDNOTTREAT Agrif_end_do_not_treat
+
+NIMPORTEQUOI .
+SLASH "/"
+DSLASH "/"[ \t]*"/"
+NAME [a-zA-Z\_][a-zA-Z0-9\_]*
+DIGIT [0-9]+
+INT {DIGIT}
+EXPONENT e[-+]?{DIGIT}
+DEXPONENT d[-+]?{DIGIT}
+QEXPONENT q[-+]?{DIGIT}
+REAL (({DIGIT}\.[0-9]+|[0-9]*\.{DIGIT}){EXPONENT}?)|{DIGIT}\.{EXPONENT}
+REALDP (({DIGIT}\.[0-9]+|[0-9]*\.{DIGIT}){DEXPONENT}?)|{DIGIT}\.{DEXPONENT}
+REALQP (({DIGIT}\.[0-9]+|[0-9]*\.{DIGIT}){QEXPONENT}?)|{DIGIT}\.{QEXPONENT}
+ENDFUNCTION end[ \t]*function
+DOUBLEPRECISION double[ \t]*precision
+DOUBLECOMPLEX double[ \t]*complex
+
+COMMENTAIRESFORTRAN77 ^([Cc*](([ \t]*\n)|([^AaHhOo\n]{NIMPORTEQUOI}*\n)))
+COMMENTAIRESFORTRAN77_2 \n([Cc*](([ \t]*\n)|([^AaHhOo\n]{NIMPORTEQUOI}*\n)))
+COMMENTAIRESFORTRAN90 ^([ \t]*!{NIMPORTEQUOI}*\n)
+COMMENTAIRESFORTRAN90_2 (!{NIMPORTEQUOI}*)
+NEXTLINEF90 "&"{NIMPORTEQUOI}*[\n]*
+NEXTLINEF77 [\n \t]*\n[ \t]{5}("&"|"+"|"$"|"*"|"1"|"2"|"3"|"4"|"5"|"6"|"7"|"8"|"9"|"."|"#")
+%%
+ if (infixed) BEGIN(fortran77style) ;
+ if (infree) BEGIN(fortran90style) ;
+
+^C${AGRIFDEB} return TOK_DEBUT;
+^C${AGRIFFIN} return TOK_FIN;
+^C$OMP[ \t]*{NIMPORTEQUOI}* return TOK_OMP;
+^C$[ \t]*{NIMPORTEQUOI}* return TOK_DOLLAR;
+
+{REAL8} {return TOK_REAL8;}
+subroutine {return TOK_SUBROUTINE;}
+program {return TOK_PROGRAM;}
+allocate {inallocate = 1; return TOK_ALLOCATE;}
+nullify {return TOK_NULLIFY;}
+deallocate {inallocate = 1; return TOK_DEALLOCATE;}
+result {return TOK_RESULT;}
+function {return TOK_FUNCTION;}
+end[ \t]*subroutine {strcpy(yylval.na,yytext);return TOK_ENDSUBROUTINE;}
+end[ \t]*program {strcpy(yylval.na,yytext);return TOK_ENDPROGRAM;}
+end[ \t]*function {strcpy(yylval.na,yytext);return TOK_ENDFUNCTION;}
+end {strcpy(yylval.na,yytext);return TOK_ENDUNIT;}
+include return TOK_INCLUDE;
+^[ \t]*use[ ]+ {
+ strcpy(yylval.na,yytext);
+ tmpc = input();
+ unput(tmpc);
+ if ( (
+ tmpc >= 'a' && tmpc <= 'z'
+ ) || (
+ tmpc >= 'A' && tmpc <= 'Z'
+ ) )
+ {
+ return TOK_USE;
+ }
+ else
+ {
+ return TOK_NAME;
+ }
+ }
+rewind {return TOK_REWIND;}
+implicit return TOK_IMPLICIT;
+none return TOK_NONE;
+call return TOK_CALL;
+.true. return TOK_TRUE;
+.false. return TOK_FALSE;
+\=\> {return TOK_POINT_TO;}
+\*\* {strcpy(yylval.na,yytext);return TOK_DASTER;}
+\.[ \t]*eqv\. {strcpy(yylval.na,yytext);return TOK_EQV;}
+\.[ \t]*eq\. {strcpy(yylval.na,yytext);return TOK_EQ;}
+\.[ \t]*gt\. {strcpy(yylval.na,yytext);return TOK_GT;}
+\.[ \t]*ge\. {strcpy(yylval.na,yytext);return TOK_GE;}
+\.[ \t]*lt\. {strcpy(yylval.na,yytext);return TOK_LT;}
+\.[ \t]*le\. {strcpy(yylval.na,yytext);return TOK_LE;}
+\.[ \t]*neqv\. {strcpy(yylval.na,yytext);return TOK_NEQV;}
+\.[ \t]*ne\. {strcpy(yylval.na,yytext);return TOK_NE;}
+\.[ \t]*not\. {strcpy(yylval.na,yytext);return TOK_NOT;}
+\.[ \t]*or\. {strcpy(yylval.na,yytext);return TOK_OR;}
+\.[ \t]*xor\. {strcpy(yylval.na,yytext);return TOK_XOR;}
+\.[ \t]*and\. {strcpy(yylval.na,yytext);return TOK_AND;}
+module {return TOK_MODULE;}
+do[ 0-9\t]*while {return TOK_DOWHILE;}
+end[ \t]*module return TOK_ENDMODULE;
+end[ \t]*do return TOK_ENDDO;
+do {return TOK_PLAINDO;}
+real {strcpy(yylval.na,yytext);return TOK_REAL;}
+integer {strcpy(yylval.na,yytext);return TOK_INTEGER;}
+logical {strcpy(yylval.na,yytext);return TOK_LOGICAL;}
+character {strcpy(yylval.na,yytext);return TOK_CHARACTER;}
+allocatable {return TOK_ALLOCATABLE;}
+close return TOK_CLOSE;
+inquire return TOK_INQUIRE;
+dimension {return TOK_DIMENSION;}
+pause return TOK_PAUSE;
+equivalence return TOK_EQUIVALENCE;
+stop return TOK_STOP;
+where return TOK_WHERE;
+end[ \t]*where return TOK_ENDWHERE;
+else[ \t]*where return TOK_ELSEWHERE;
+complex {return TOK_COMPLEX;}
+^[ \t]*contains {return TOK_CONTAINS;}
+only {return TOK_ONLY;}
+parameter {return TOK_PARAMETER;}
+recursive {return TOK_RECURSIVE;}
+common {return TOK_COMMON;}
+^[ \t]*global[ \t]+ {return TOK_GLOBAL;}
+external {return TOK_EXTERNAL;}
+intent {return TOK_INTENT;}
+pointer {return TOK_POINTER;}
+optional {return TOK_OPTIONAL;}
+save {return TOK_SAVE;}
+^[ \t]*type[ \t\,]+ {return TOK_TYPE;}
+^[ \t]*type[ \t]*\( {return TOK_TYPEPAR;}
+stat {if (inallocate == 1) return TOK_STAT; else {strcpy(yylval.na,yytext);return TOK_NAME;}}
+end[ \t]*type {return TOK_ENDTYPE;}
+open return TOK_OPEN;
+return return TOK_RETURN;
+exit[^(] return TOK_EXIT;
+print return TOK_PRINT;
+module[ \t]*procedure {return TOK_PROCEDURE;}
+read {return TOK_READ;}
+namelist {return TOK_NAMELIST;}
+write {return TOK_WRITE;}
+target {return TOK_TARGET;}
+public {return TOK_PUBLIC;}
+private {return TOK_PRIVATE;}
+in {strcpy(yylval.nac,yytext);return TOK_IN;}
+^[ \t]*data[ \t]+ {strcpy(yylval.na,yytext);return TOK_DATA;}
+continue return TOK_CONTINUE;
+go[ \t]*to {return TOK_PLAINGOTO;}
+out {strcpy(yylval.nac,yytext);return TOK_OUT;}
+inout {strcpy(yylval.nac,yytext);return TOK_INOUT;}
+intrinsic {return TOK_INTRINSIC;}
+then {return TOK_THEN;}
+else[ \t]*if {return TOK_ELSEIF;}
+else {return TOK_ELSE;}
+end[ \t]*if {return TOK_ENDIF;}
+if[ \t]*\( {return TOK_LOGICALIF;}
+sum[ \t]*\( {return TOK_SUM;}
+max[ \t]*\( {return TOK_MAX;}
+tanh {return TOK_TANH;}
+maxval {return TOK_MAXVAL;}
+trim {return TOK_TRIM;}
+sqrt\( {return TOK_SQRT;}
+select[ \t]*case {return TOK_SELECTCASE;}
+^[ \t]*case[ \t]*\( {return TOK_CASE;}
+^[ \t]*case[ \t]*default {return TOK_CASEDEFAULT;}
+end[ \t]*select {return TOK_ENDSELECT;}
+file[ \t]*\= {return TOK_FILE;}
+end[ \t]*\= {return TOK_END;}
+err[ \t]*\= {return TOK_ERR;}
+exist[ \t]*\= {return TOK_EXIST;}
+min[ \t]*\( {return TOK_MIN;}
+nint {return TOK_NINT;}
+float {return TOK_FLOAT;}
+exp {return TOK_EXP;}
+cos {return TOK_COS;}
+cosh {return TOK_COSH;}
+acos {return TOK_ACOS;}
+sin {return TOK_SIN;}
+sinh {return TOK_SINH;}
+asin {return TOK_ASIN;}
+log {return TOK_LOG;}
+tan {return TOK_TAN;}
+atan {return TOK_ATAN;}
+cycle {return TOK_CYCLE;}
+abs\( {return TOK_ABS;}
+mod {return TOK_MOD;}
+sign {return TOK_SIGN;}
+minloc {return TOK_MINLOC;}
+maxloc {return TOK_MAXLOC;}
+minval {return TOK_MINVAL;}
+backspace {return TOK_BACKSPACE;}
+\({SLASH} {return TOK_LEFTAB;}
+{SLASH}\) {return TOK_RIGHTAB;}
+format[ \t]*\(({NIMPORTEQUOI}|{NEXTLINEF90}|{NEXTLINEF77})*\) {return TOK_FORMAT;}
+{DOUBLEPRECISION} {strcpy(yylval.na,yytext);return TOK_DOUBLEPRECISION;}
+{DOUBLECOMPLEX} {strcpy(yylval.na,yytext);return TOK_DOUBLECOMPLEX;}
+{SLASH} {strcpy(yylval.na,yytext);return TOK_SLASH;}
+DSLASH {strcpy(yylval.na,yytext);return TOK_DSLASH;}
+(\')[^']*&{0,1}\n[ \t]*&{0,1}[^']*(\') {strcpy(yylval.na,yytext);return TOK_CHAR_CUT;}
+(\')[^\n']*(\') {strcpy(yylval.na,yytext);return TOK_CHAR_CONSTANT;}
+(\")[^\n"]*(\") {strcpy(yylval.na,yytext);return TOK_CHAR_MESSAGE;}
+({NAME}{REAL}) {strcpy(yylval.na,yytext);return TOK_CHAR_INT;}
+^[ \t]*interface {printf("debug interfacer\n");BEGIN(donottreat);}
+^[ \t]*end[ \t]*interface[ \t]*\n {
+ BEGIN(INITIAL);
+ if (infixed) BEGIN(fortran77style) ;
+ if (infree) BEGIN(fortran90style) ;
+ line_num_fortran++;line_num_fortran_common++;
+ return '\n';
+ }
+{NAME} {strcpy(yylval.na,yytext);return TOK_NAME;}
+{REAL} {strcpy(yylval.na,yytext);return TOK_CSTREAL;}
+{REALDP} {strcpy(yylval.na,yytext);return TOK_CSTREALDP;}
+{REALQP} {strcpy(yylval.na,yytext);return TOK_CSTREALQP;}
+({DIGIT}\.)/[^{NAME}|"and."|"false."|"true."|"eq."|"or."|"gt."|"ge."|"lt."|"le."|"not."|"ne."] {strcpy(yylval.na,yytext);return TOK_CSTREAL;}
+{INT} {strcpy(yylval.na,yytext);return TOK_CSTINT;}
+\$ {}
+\'|\" {return TOK_QUOTE;}
+\. {}
+\(|\)|:|\[|\]|\+|\-|\* {strcpy(yylval.na,yytext);return (int) *yytext;}
+\% {afterpercent = 1; strcpy(yylval.na,yytext);return (int) *yytext;}
+\; {return TOK_SEMICOLON;}
+\, {return (int) *yytext;}
+\= {return (int) *yytext;}
+\< {return (int) *yytext;}
+\> {return (int) *yytext;}
+\n {colnum=0;line_num_fortran++;line_num_fortran_common++; return (int) *yytext;}
+^[ ]*$
+^(((" "|[0-9]){1,5})|([ \t]{1,5}))[ &]+ {if (newlinef90 == 0) return TOK_LABEL; else newlinef90 = 0;}
+[ ]+
+[\t]+ {colnum=colnum-1+tabsize;}
+[ \t]+ ;
+{NEXTLINEF90} {line_num_fortran++;line_num_fortran_common++;newlinef90=1;colnum=0;}
+{NEXTLINEF77} {line_num_fortran++;line_num_fortran_common++;colnum=0;}
+{COMMENTAIRESFORTRAN77} {
+ convert2lower(motparse1);
+ if ( strncasecmp(motparse1,"contains",8) == 0 )
+ {
+ return TOK_CONTAINS;
+ }
+ else
+ {
+ /* colnum=0;line_num_fortran++;line_num_fortran_common++;*/
+ if ( !strcasecmp(motparse1,"C$AGRIF_DO_NOT_TREAT\n"))
+ return TOK_DONOTTREAT;
+ if ( !strcasecmp(motparse1,"C$AGRIF_END_DO_NOT_TREAT\n")) return TOK_ENDDONOTTREAT;
+ unput('\n');
+ }
+ }
+{COMMENTAIRESFORTRAN77_2} {
+ convert2lower(&motparse1[1]);
+ if ( strncasecmp(&motparse1[1],"contains",8) == 0 )
+ {
+ return TOK_CONTAINS;
+ }
+ else
+ {
+ /* colnum=0;line_num_fortran++;line_num_fortran_common++;*/
+ if ( !strcasecmp(&motparse1[1],"C$AGRIF_DO_NOT_TREAT\n"))
+ return TOK_DONOTTREAT;
+ if ( !strcasecmp(&motparse1[1],"C$AGRIF_END_DO_NOT_TREAT\n")) return TOK_ENDDONOTTREAT;
+ unput('\n');
+ }
+ }
+^"!$AGRIF_DO_NOT_TREAT"[ \t]*\n {
+ BEGIN(donottreat);
+ }
+^"!$AGRIF_END_DO_NOT_TREAT"[ \t]*\n {
+ BEGIN(INITIAL);
+ if (infixed) BEGIN(fortran77style) ;
+ if (infree) BEGIN(fortran90style) ;
+ line_num_fortran++;line_num_fortran_common++;
+ return '\n';
+ }
+.*\n {line_num_fortran++;line_num_fortran_common++;}
+{COMMENTAIRESFORTRAN90} {
+ colnum = 0;
+ if ( !strcasecmp(motparse1,"!$AGRIF_DO_NOT_TREAT\n")) return TOK_DONOTTREAT;
+ if ( !strcasecmp(motparse1,"!$AGRIF_END_DO_NOT_TREAT\n")) return TOK_ENDDONOTTREAT;
+ }
+{COMMENTAIRESFORTRAN90_2} {
+ colnum = 0;
+ if ( !strcasecmp(motparse1,"!$AGRIF_DO_NOT_TREAT\n")) return TOK_DONOTTREAT;
+ if ( !strcasecmp(motparse1,"!$AGRIF_END_DO_NOT_TREAT\n")) return TOK_ENDDONOTTREAT;
+ }
+%%
+
+fortranerror(char *s)
+{
+ if (!strcasecmp(curfile,mainfile))
+ {
+ printf("%s line %d, file %s motclef = %s\n",s,line_num_fortran,curfile,yytext);
+ }
+ else
+ {
+ printf("%s line %d, file %s motclef = %s curbuf = %s\n",s,line_num_fortran_common,curfile,yytext,curbuf);
+ }
+/* exit(0);*/
+}
+
+int fortranwrap()
+{
+}
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/fortran.tab.c
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/fortran.tab.c (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/fortran.tab.c (revision 8155)
@@ -0,0 +1,6863 @@
+/* A Bison parser, made by GNU Bison 2.3. */
+
+/* Skeleton implementation for Bison's Yacc-like parsers in C
+
+ Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006
+ Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ Boston, MA 02110-1301, USA. */
+
+/* As a special exception, you may create a larger work that contains
+ part or all of the Bison parser skeleton and distribute that work
+ under terms of your choice, so long as that work isn't itself a
+ parser generator using the skeleton or a modified version thereof
+ as a parser skeleton. Alternatively, if you modify or redistribute
+ the parser skeleton itself, you may (at your option) remove this
+ special exception, which will cause the skeleton and the resulting
+ Bison output files to be licensed under the GNU General Public
+ License without this special exception.
+
+ This special exception was added by the Free Software Foundation in
+ version 2.2 of Bison. */
+
+/* C LALR(1) parser skeleton written by Richard Stallman, by
+ simplifying the original so-called "semantic" parser. */
+
+/* All symbols defined below should begin with yy or YY, to avoid
+ infringing on user name space. This should be done even for local
+ variables, as they might otherwise be expanded by user macros.
+ There are some unavoidable exceptions within include files to
+ define necessary library symbols; they are noted "INFRINGES ON
+ USER NAME SPACE" below. */
+
+/* Identify Bison output. */
+#define YYBISON 1
+
+/* Bison version. */
+#define YYBISON_VERSION "2.3"
+
+/* Skeleton name. */
+#define YYSKELETON_NAME "yacc.c"
+
+/* Pure parsers. */
+#define YYPURE 0
+
+/* Using locations. */
+#define YYLSP_NEEDED 0
+
+/* Substitute the variable and function names. */
+#define yyparse fortranparse
+#define yylex fortranlex
+#define yyerror fortranerror
+#define yylval fortranlval
+#define yychar fortranchar
+#define yydebug fortrandebug
+#define yynerrs fortrannerrs
+
+
+/* Tokens. */
+#ifndef YYTOKENTYPE
+# define YYTOKENTYPE
+ /* Put the tokens into the symbol table, so that GDB and other debuggers
+ know about them. */
+ enum yytokentype {
+ TOK_BINARY_OP = 258,
+ TOK_NEQV = 259,
+ TOK_EQV = 260,
+ TOK_XOR = 261,
+ TOK_OR = 262,
+ TOK_AND = 263,
+ TOK_NOT = 264,
+ TOK_NE = 265,
+ TOK_EQ = 266,
+ TOK_GE = 267,
+ TOK_LE = 268,
+ TOK_GT = 269,
+ TOK_LT = 270,
+ TOK_UNARY_OP = 271,
+ TOK_DSLASH = 272,
+ TOK_SLASH = 273,
+ TOK_DASTER = 274,
+ TOK_SEP = 275,
+ TOK_SEMICOLON = 276,
+ TOK_NEXTLINE = 277,
+ TOK_PARAMETER = 278,
+ TOK_RESULT = 279,
+ TOK_ONLY = 280,
+ TOK_INCLUDE = 281,
+ TOK_SUBROUTINE = 282,
+ TOK_PROGRAM = 283,
+ TOK_FUNCTION = 284,
+ TOK_OMP = 285,
+ TOK_DOLLAR = 286,
+ TOK_FORMAT = 287,
+ TOK_MAX = 288,
+ TOK_TANH = 289,
+ TOK_WHERE = 290,
+ TOK_ELSEWHERE = 291,
+ TOK_ENDWHERE = 292,
+ TOK_MAXVAL = 293,
+ TOK_TRIM = 294,
+ TOK_SUM = 295,
+ TOK_SQRT = 296,
+ TOK_CASE = 297,
+ TOK_SELECTCASE = 298,
+ TOK_FILE = 299,
+ TOK_END = 300,
+ TOK_ERR = 301,
+ TOK_DONOTTREAT = 302,
+ TOK_ENDDONOTTREAT = 303,
+ TOK_EXIST = 304,
+ TOK_MIN = 305,
+ TOK_FLOAT = 306,
+ TOK_EXP = 307,
+ TOK_COS = 308,
+ TOK_COSH = 309,
+ TOK_ACOS = 310,
+ TOK_NINT = 311,
+ TOK_CYCLE = 312,
+ TOK_SIN = 313,
+ TOK_SINH = 314,
+ TOK_ASIN = 315,
+ TOK_EQUIVALENCE = 316,
+ TOK_BACKSPACE = 317,
+ TOK_LOG = 318,
+ TOK_TAN = 319,
+ TOK_ATAN = 320,
+ TOK_RECURSIVE = 321,
+ TOK_ABS = 322,
+ TOK_MOD = 323,
+ TOK_SIGN = 324,
+ TOK_MINLOC = 325,
+ TOK_MAXLOC = 326,
+ TOK_EXIT = 327,
+ TOK_MINVAL = 328,
+ TOK_PUBLIC = 329,
+ TOK_PRIVATE = 330,
+ TOK_ALLOCATABLE = 331,
+ TOK_RETURN = 332,
+ TOK_THEN = 333,
+ TOK_ELSEIF = 334,
+ TOK_ELSE = 335,
+ TOK_ENDIF = 336,
+ TOK_PRINT = 337,
+ TOK_PLAINGOTO = 338,
+ TOK_CONSTRUCTID = 339,
+ TOK_LOGICALIF = 340,
+ TOK_PLAINDO = 341,
+ TOK_CONTAINS = 342,
+ TOK_ENDDO = 343,
+ TOK_MODULE = 344,
+ TOK_ENDMODULE = 345,
+ TOK_DOWHILE = 346,
+ TOK_ALLOCATE = 347,
+ TOK_OPEN = 348,
+ TOK_CLOSE = 349,
+ TOK_INQUIRE = 350,
+ TOK_WRITE = 351,
+ TOK_READ = 352,
+ TOK_REWIND = 353,
+ TOK_DEALLOCATE = 354,
+ TOK_NULLIFY = 355,
+ TOK_FIN = 356,
+ TOK_DEBUT = 357,
+ TOK_DIMENSION = 358,
+ TOK_ENDSELECT = 359,
+ TOK_EXTERNAL = 360,
+ TOK_INTENT = 361,
+ TOK_INTRINSIC = 362,
+ TOK_NAMELIST = 363,
+ TOK_CASEDEFAULT = 364,
+ TOK_OPTIONAL = 365,
+ TOK_POINTER = 366,
+ TOK_CONTINUE = 367,
+ TOK_SAVE = 368,
+ TOK_TARGET = 369,
+ TOK_QUOTE = 370,
+ TOK_IMPLICIT = 371,
+ TOK_NONE = 372,
+ TOK_CALL = 373,
+ TOK_STAT = 374,
+ TOK_POINT_TO = 375,
+ TOK_COMMON = 376,
+ TOK_GLOBAL = 377,
+ TOK_INTERFACE = 378,
+ TOK_ENDINTERFACE = 379,
+ TOK_LEFTAB = 380,
+ TOK_RIGHTAB = 381,
+ TOK_PAUSE = 382,
+ TOK_PROCEDURE = 383,
+ TOK_STOP = 384,
+ TOK_NAMEEQ = 385,
+ TOK_REAL8 = 386,
+ TOK_OUT = 387,
+ TOK_INOUT = 388,
+ TOK_IN = 389,
+ TOK_USE = 390,
+ TOK_TRUE = 391,
+ TOK_FALSE = 392,
+ TOK_LABEL = 393,
+ TOK_TYPE = 394,
+ TOK_TYPEPAR = 395,
+ TOK_ENDTYPE = 396,
+ TOK_REAL = 397,
+ TOK_INTEGER = 398,
+ TOK_LOGICAL = 399,
+ TOK_DOUBLEPRECISION = 400,
+ TOK_DOUBLEREAL = 401,
+ TOK_ENDSUBROUTINE = 402,
+ TOK_ENDFUNCTION = 403,
+ TOK_ENDPROGRAM = 404,
+ TOK_ENDUNIT = 405,
+ TOK_CHARACTER = 406,
+ TOK_CHAR_CONSTANT = 407,
+ TOK_CHAR_CUT = 408,
+ TOK_DATA = 409,
+ TOK_CHAR_INT = 410,
+ TOK_CHAR_MESSAGE = 411,
+ TOK_CSTREAL = 412,
+ TOK_CSTREALDP = 413,
+ TOK_CSTREALQP = 414,
+ TOK_SFREAL = 415,
+ TOK_COMPLEX = 416,
+ TOK_DOUBLECOMPLEX = 417,
+ TOK_NAME = 418,
+ TOK_NAME_CHAR = 419,
+ TOK_PROBTYPE = 420,
+ TOK_INTERPTYPE = 421,
+ TOK_VARTYPE = 422,
+ TOK_BC = 423,
+ TOK_OP = 424,
+ TOK_CSTINT = 425,
+ TOK_COMMENT = 426,
+ TOK_FILENAME = 427
+ };
+#endif
+/* Tokens. */
+#define TOK_BINARY_OP 258
+#define TOK_NEQV 259
+#define TOK_EQV 260
+#define TOK_XOR 261
+#define TOK_OR 262
+#define TOK_AND 263
+#define TOK_NOT 264
+#define TOK_NE 265
+#define TOK_EQ 266
+#define TOK_GE 267
+#define TOK_LE 268
+#define TOK_GT 269
+#define TOK_LT 270
+#define TOK_UNARY_OP 271
+#define TOK_DSLASH 272
+#define TOK_SLASH 273
+#define TOK_DASTER 274
+#define TOK_SEP 275
+#define TOK_SEMICOLON 276
+#define TOK_NEXTLINE 277
+#define TOK_PARAMETER 278
+#define TOK_RESULT 279
+#define TOK_ONLY 280
+#define TOK_INCLUDE 281
+#define TOK_SUBROUTINE 282
+#define TOK_PROGRAM 283
+#define TOK_FUNCTION 284
+#define TOK_OMP 285
+#define TOK_DOLLAR 286
+#define TOK_FORMAT 287
+#define TOK_MAX 288
+#define TOK_TANH 289
+#define TOK_WHERE 290
+#define TOK_ELSEWHERE 291
+#define TOK_ENDWHERE 292
+#define TOK_MAXVAL 293
+#define TOK_TRIM 294
+#define TOK_SUM 295
+#define TOK_SQRT 296
+#define TOK_CASE 297
+#define TOK_SELECTCASE 298
+#define TOK_FILE 299
+#define TOK_END 300
+#define TOK_ERR 301
+#define TOK_DONOTTREAT 302
+#define TOK_ENDDONOTTREAT 303
+#define TOK_EXIST 304
+#define TOK_MIN 305
+#define TOK_FLOAT 306
+#define TOK_EXP 307
+#define TOK_COS 308
+#define TOK_COSH 309
+#define TOK_ACOS 310
+#define TOK_NINT 311
+#define TOK_CYCLE 312
+#define TOK_SIN 313
+#define TOK_SINH 314
+#define TOK_ASIN 315
+#define TOK_EQUIVALENCE 316
+#define TOK_BACKSPACE 317
+#define TOK_LOG 318
+#define TOK_TAN 319
+#define TOK_ATAN 320
+#define TOK_RECURSIVE 321
+#define TOK_ABS 322
+#define TOK_MOD 323
+#define TOK_SIGN 324
+#define TOK_MINLOC 325
+#define TOK_MAXLOC 326
+#define TOK_EXIT 327
+#define TOK_MINVAL 328
+#define TOK_PUBLIC 329
+#define TOK_PRIVATE 330
+#define TOK_ALLOCATABLE 331
+#define TOK_RETURN 332
+#define TOK_THEN 333
+#define TOK_ELSEIF 334
+#define TOK_ELSE 335
+#define TOK_ENDIF 336
+#define TOK_PRINT 337
+#define TOK_PLAINGOTO 338
+#define TOK_CONSTRUCTID 339
+#define TOK_LOGICALIF 340
+#define TOK_PLAINDO 341
+#define TOK_CONTAINS 342
+#define TOK_ENDDO 343
+#define TOK_MODULE 344
+#define TOK_ENDMODULE 345
+#define TOK_DOWHILE 346
+#define TOK_ALLOCATE 347
+#define TOK_OPEN 348
+#define TOK_CLOSE 349
+#define TOK_INQUIRE 350
+#define TOK_WRITE 351
+#define TOK_READ 352
+#define TOK_REWIND 353
+#define TOK_DEALLOCATE 354
+#define TOK_NULLIFY 355
+#define TOK_FIN 356
+#define TOK_DEBUT 357
+#define TOK_DIMENSION 358
+#define TOK_ENDSELECT 359
+#define TOK_EXTERNAL 360
+#define TOK_INTENT 361
+#define TOK_INTRINSIC 362
+#define TOK_NAMELIST 363
+#define TOK_CASEDEFAULT 364
+#define TOK_OPTIONAL 365
+#define TOK_POINTER 366
+#define TOK_CONTINUE 367
+#define TOK_SAVE 368
+#define TOK_TARGET 369
+#define TOK_QUOTE 370
+#define TOK_IMPLICIT 371
+#define TOK_NONE 372
+#define TOK_CALL 373
+#define TOK_STAT 374
+#define TOK_POINT_TO 375
+#define TOK_COMMON 376
+#define TOK_GLOBAL 377
+#define TOK_INTERFACE 378
+#define TOK_ENDINTERFACE 379
+#define TOK_LEFTAB 380
+#define TOK_RIGHTAB 381
+#define TOK_PAUSE 382
+#define TOK_PROCEDURE 383
+#define TOK_STOP 384
+#define TOK_NAMEEQ 385
+#define TOK_REAL8 386
+#define TOK_OUT 387
+#define TOK_INOUT 388
+#define TOK_IN 389
+#define TOK_USE 390
+#define TOK_TRUE 391
+#define TOK_FALSE 392
+#define TOK_LABEL 393
+#define TOK_TYPE 394
+#define TOK_TYPEPAR 395
+#define TOK_ENDTYPE 396
+#define TOK_REAL 397
+#define TOK_INTEGER 398
+#define TOK_LOGICAL 399
+#define TOK_DOUBLEPRECISION 400
+#define TOK_DOUBLEREAL 401
+#define TOK_ENDSUBROUTINE 402
+#define TOK_ENDFUNCTION 403
+#define TOK_ENDPROGRAM 404
+#define TOK_ENDUNIT 405
+#define TOK_CHARACTER 406
+#define TOK_CHAR_CONSTANT 407
+#define TOK_CHAR_CUT 408
+#define TOK_DATA 409
+#define TOK_CHAR_INT 410
+#define TOK_CHAR_MESSAGE 411
+#define TOK_CSTREAL 412
+#define TOK_CSTREALDP 413
+#define TOK_CSTREALQP 414
+#define TOK_SFREAL 415
+#define TOK_COMPLEX 416
+#define TOK_DOUBLECOMPLEX 417
+#define TOK_NAME 418
+#define TOK_NAME_CHAR 419
+#define TOK_PROBTYPE 420
+#define TOK_INTERPTYPE 421
+#define TOK_VARTYPE 422
+#define TOK_BC 423
+#define TOK_OP 424
+#define TOK_CSTINT 425
+#define TOK_COMMENT 426
+#define TOK_FILENAME 427
+
+
+
+
+/* Copy the first part of user declarations. */
+#line 36 "fortran.y"
+
+#define YYMAXDEPTH 1000
+#include
+#include
+#include
+#include "decl.h"
+extern int line_num_fortran;
+extern int line_num_fortran_common;
+char *tmp;
+char c_selectorname[LONG_C];
+char ligne[LONG_C];
+char truename[LONGNOM];
+char identcopy[LONG_C];
+int c_selectorgiven=0;
+int incom;
+listvar *curlistvar;
+typedim c_selectordim;
+listcouple *coupletmp;
+listdim *parcoursdim;
+int removeline=0;
+listvar *test;
+
+
+/* Enabling traces. */
+#ifndef YYDEBUG
+# define YYDEBUG 0
+#endif
+
+/* Enabling verbose error messages. */
+#ifdef YYERROR_VERBOSE
+# undef YYERROR_VERBOSE
+# define YYERROR_VERBOSE 1
+#else
+# define YYERROR_VERBOSE 0
+#endif
+
+/* Enabling the token table. */
+#ifndef YYTOKEN_TABLE
+# define YYTOKEN_TABLE 0
+#endif
+
+#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED
+typedef union YYSTYPE
+#line 59 "fortran.y"
+{
+ char nac[LONG_C];
+ char na[LONGNOM];
+ listdim *d;
+ listvar *l;
+ listnom *ln;
+ listcouple *lc;
+ listname *lnn;
+ typedim dim1;
+ variable *v;
+ }
+/* Line 193 of yacc.c. */
+#line 483 "fortran.tab.c"
+ YYSTYPE;
+# define yystype YYSTYPE /* obsolescent; will be withdrawn */
+# define YYSTYPE_IS_DECLARED 1
+# define YYSTYPE_IS_TRIVIAL 1
+#endif
+
+
+
+/* Copy the second part of user declarations. */
+
+
+/* Line 216 of yacc.c. */
+#line 496 "fortran.tab.c"
+
+#ifdef short
+# undef short
+#endif
+
+#ifdef YYTYPE_UINT8
+typedef YYTYPE_UINT8 yytype_uint8;
+#else
+typedef unsigned char yytype_uint8;
+#endif
+
+#ifdef YYTYPE_INT8
+typedef YYTYPE_INT8 yytype_int8;
+#elif (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+typedef signed char yytype_int8;
+#else
+typedef short int yytype_int8;
+#endif
+
+#ifdef YYTYPE_UINT16
+typedef YYTYPE_UINT16 yytype_uint16;
+#else
+typedef unsigned short int yytype_uint16;
+#endif
+
+#ifdef YYTYPE_INT16
+typedef YYTYPE_INT16 yytype_int16;
+#else
+typedef short int yytype_int16;
+#endif
+
+#ifndef YYSIZE_T
+# ifdef __SIZE_TYPE__
+# define YYSIZE_T __SIZE_TYPE__
+# elif defined size_t
+# define YYSIZE_T size_t
+# elif ! defined YYSIZE_T && (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+# include /* INFRINGES ON USER NAME SPACE */
+# define YYSIZE_T size_t
+# else
+# define YYSIZE_T unsigned int
+# endif
+#endif
+
+#define YYSIZE_MAXIMUM ((YYSIZE_T) -1)
+
+#ifndef YY_
+# if defined YYENABLE_NLS && YYENABLE_NLS
+# if ENABLE_NLS
+# include /* INFRINGES ON USER NAME SPACE */
+# define YY_(msgid) dgettext ("bison-runtime", msgid)
+# endif
+# endif
+# ifndef YY_
+# define YY_(msgid) msgid
+# endif
+#endif
+
+/* Suppress unused-variable warnings by "using" E. */
+#if ! defined lint || defined __GNUC__
+# define YYUSE(e) ((void) (e))
+#else
+# define YYUSE(e) /* empty */
+#endif
+
+/* Identity function, used to suppress warnings about constant conditions. */
+#ifndef lint
+# define YYID(n) (n)
+#else
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+static int
+YYID (int i)
+#else
+static int
+YYID (i)
+ int i;
+#endif
+{
+ return i;
+}
+#endif
+
+#if ! defined yyoverflow || YYERROR_VERBOSE
+
+/* The parser invokes alloca or malloc; define the necessary symbols. */
+
+# ifdef YYSTACK_USE_ALLOCA
+# if YYSTACK_USE_ALLOCA
+# ifdef __GNUC__
+# define YYSTACK_ALLOC __builtin_alloca
+# elif defined __BUILTIN_VA_ARG_INCR
+# include /* INFRINGES ON USER NAME SPACE */
+# elif defined _AIX
+# define YYSTACK_ALLOC __alloca
+# elif defined _MSC_VER
+# include /* INFRINGES ON USER NAME SPACE */
+# define alloca _alloca
+# else
+# define YYSTACK_ALLOC alloca
+# if ! defined _ALLOCA_H && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+# include /* INFRINGES ON USER NAME SPACE */
+# ifndef _STDLIB_H
+# define _STDLIB_H 1
+# endif
+# endif
+# endif
+# endif
+# endif
+
+# ifdef YYSTACK_ALLOC
+ /* Pacify GCC's `empty if-body' warning. */
+# define YYSTACK_FREE(Ptr) do { /* empty */; } while (YYID (0))
+# ifndef YYSTACK_ALLOC_MAXIMUM
+ /* The OS might guarantee only one guard page at the bottom of the stack,
+ and a page size can be as small as 4096 bytes. So we cannot safely
+ invoke alloca (N) if N exceeds 4096. Use a slightly smaller number
+ to allow for a few compiler-allocated temporary stack slots. */
+# define YYSTACK_ALLOC_MAXIMUM 4032 /* reasonable circa 2006 */
+# endif
+# else
+# define YYSTACK_ALLOC YYMALLOC
+# define YYSTACK_FREE YYFREE
+# ifndef YYSTACK_ALLOC_MAXIMUM
+# define YYSTACK_ALLOC_MAXIMUM YYSIZE_MAXIMUM
+# endif
+# if (defined __cplusplus && ! defined _STDLIB_H \
+ && ! ((defined YYMALLOC || defined malloc) \
+ && (defined YYFREE || defined free)))
+# include /* INFRINGES ON USER NAME SPACE */
+# ifndef _STDLIB_H
+# define _STDLIB_H 1
+# endif
+# endif
+# ifndef YYMALLOC
+# define YYMALLOC malloc
+# if ! defined malloc && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+void *malloc (YYSIZE_T); /* INFRINGES ON USER NAME SPACE */
+# endif
+# endif
+# ifndef YYFREE
+# define YYFREE free
+# if ! defined free && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+void free (void *); /* INFRINGES ON USER NAME SPACE */
+# endif
+# endif
+# endif
+#endif /* ! defined yyoverflow || YYERROR_VERBOSE */
+
+
+#if (! defined yyoverflow \
+ && (! defined __cplusplus \
+ || (defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL)))
+
+/* A type that is properly aligned for any stack member. */
+union yyalloc
+{
+ yytype_int16 yyss;
+ YYSTYPE yyvs;
+ };
+
+/* The size of the maximum gap between one aligned stack and the next. */
+# define YYSTACK_GAP_MAXIMUM (sizeof (union yyalloc) - 1)
+
+/* The size of an array large to enough to hold all stacks, each with
+ N elements. */
+# define YYSTACK_BYTES(N) \
+ ((N) * (sizeof (yytype_int16) + sizeof (YYSTYPE)) \
+ + YYSTACK_GAP_MAXIMUM)
+
+/* Copy COUNT objects from FROM to TO. The source and destination do
+ not overlap. */
+# ifndef YYCOPY
+# if defined __GNUC__ && 1 < __GNUC__
+# define YYCOPY(To, From, Count) \
+ __builtin_memcpy (To, From, (Count) * sizeof (*(From)))
+# else
+# define YYCOPY(To, From, Count) \
+ do \
+ { \
+ YYSIZE_T yyi; \
+ for (yyi = 0; yyi < (Count); yyi++) \
+ (To)[yyi] = (From)[yyi]; \
+ } \
+ while (YYID (0))
+# endif
+# endif
+
+/* Relocate STACK from its old location to the new one. The
+ local variables YYSIZE and YYSTACKSIZE give the old and new number of
+ elements in the stack, and YYPTR gives the new location of the
+ stack. Advance YYPTR to a properly aligned location for the next
+ stack. */
+# define YYSTACK_RELOCATE(Stack) \
+ do \
+ { \
+ YYSIZE_T yynewbytes; \
+ YYCOPY (&yyptr->Stack, Stack, yysize); \
+ Stack = &yyptr->Stack; \
+ yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \
+ yyptr += yynewbytes / sizeof (*yyptr); \
+ } \
+ while (YYID (0))
+
+#endif
+
+/* YYFINAL -- State number of the termination state. */
+#define YYFINAL 2
+/* YYLAST -- Last index in YYTABLE. */
+#define YYLAST 6070
+
+/* YYNTOKENS -- Number of terminals. */
+#define YYNTOKENS 190
+/* YYNNTS -- Number of nonterminals. */
+#define YYNNTS 184
+/* YYNRULES -- Number of rules. */
+#define YYNRULES 555
+/* YYNRULES -- Number of states. */
+#define YYNSTATES 982
+
+/* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */
+#define YYUNDEFTOK 2
+#define YYMAXUTOK 427
+
+#define YYTRANSLATE(YYX) \
+ ((unsigned int) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK)
+
+/* YYTRANSLATE[YYLEX] -- Bison symbol number corresponding to YYLEX. */
+static const yytype_uint8 yytranslate[] =
+{
+ 0, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 187, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 183, 2, 2, 2, 189, 2, 2,
+ 179, 180, 23, 21, 3, 22, 2, 188, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 4, 2,
+ 185, 5, 186, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 181, 2, 182, 2, 184, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 1, 2, 6, 7,
+ 8, 9, 10, 11, 12, 13, 14, 15, 16, 17,
+ 18, 19, 20, 24, 25, 26, 27, 28, 29, 30,
+ 31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
+ 41, 42, 43, 44, 45, 46, 47, 48, 49, 50,
+ 51, 52, 53, 54, 55, 56, 57, 58, 59, 60,
+ 61, 62, 63, 64, 65, 66, 67, 68, 69, 70,
+ 71, 72, 73, 74, 75, 76, 77, 78, 79, 80,
+ 81, 82, 83, 84, 85, 86, 87, 88, 89, 90,
+ 91, 92, 93, 94, 95, 96, 97, 98, 99, 100,
+ 101, 102, 103, 104, 105, 106, 107, 108, 109, 110,
+ 111, 112, 113, 114, 115, 116, 117, 118, 119, 120,
+ 121, 122, 123, 124, 125, 126, 127, 128, 129, 130,
+ 131, 132, 133, 134, 135, 136, 137, 138, 139, 140,
+ 141, 142, 143, 144, 145, 146, 147, 148, 149, 150,
+ 151, 152, 153, 154, 155, 156, 157, 158, 159, 160,
+ 161, 162, 163, 164, 165, 166, 167, 168, 169, 170,
+ 171, 172, 173, 174, 175, 176, 177, 178
+};
+
+#if YYDEBUG
+/* YYPRHS[YYN] -- Index of the first RHS symbol of rule number YYN in
+ YYRHS. */
+static const yytype_uint16 yyprhs[] =
+{
+ 0, 0, 3, 4, 7, 10, 13, 15, 19, 23,
+ 25, 29, 32, 35, 39, 43, 46, 49, 52, 54,
+ 56, 58, 60, 61, 62, 65, 66, 68, 69, 70,
+ 72, 73, 78, 81, 88, 93, 96, 98, 99, 101,
+ 103, 104, 107, 111, 112, 115, 119, 121, 125, 127,
+ 129, 132, 137, 140, 143, 148, 151, 153, 155, 157,
+ 159, 161, 163, 165, 167, 169, 171, 176, 180, 184,
+ 187, 191, 192, 194, 196, 198, 200, 202, 204, 206,
+ 208, 210, 212, 214, 216, 218, 220, 222, 224, 226,
+ 228, 230, 232, 234, 236, 238, 240, 242, 244, 248,
+ 252, 258, 260, 264, 268, 271, 276, 278, 282, 283,
+ 286, 289, 293, 295, 297, 299, 304, 311, 316, 318,
+ 322, 325, 329, 335, 339, 341, 342, 345, 347, 352,
+ 356, 359, 363, 367, 371, 375, 376, 378, 381, 384,
+ 388, 394, 398, 399, 402, 405, 407, 413, 419, 422,
+ 426, 429, 433, 435, 439, 442, 446, 452, 454, 457,
+ 459, 463, 466, 468, 472, 473, 475, 477, 481, 485,
+ 488, 490, 494, 497, 500, 501, 508, 516, 517, 520,
+ 523, 527, 531, 533, 534, 537, 542, 546, 550, 555,
+ 558, 560, 562, 564, 566, 568, 570, 572, 574, 575,
+ 578, 580, 584, 585, 588, 592, 594, 598, 601, 605,
+ 607, 609, 611, 613, 614, 618, 619, 622, 627, 629,
+ 633, 635, 637, 639, 642, 644, 649, 651, 653, 655,
+ 657, 659, 661, 663, 665, 667, 669, 670, 674, 676,
+ 680, 682, 684, 687, 690, 694, 696, 698, 700, 704,
+ 706, 708, 712, 716, 721, 726, 730, 735, 740, 744,
+ 749, 754, 759, 764, 769, 774, 779, 784, 789, 794,
+ 799, 804, 809, 813, 818, 823, 828, 833, 835, 839,
+ 841, 843, 845, 848, 851, 854, 856, 858, 861, 864,
+ 867, 870, 873, 876, 879, 882, 885, 888, 891, 895,
+ 898, 902, 905, 908, 911, 914, 917, 920, 923, 924,
+ 926, 929, 932, 935, 937, 939, 941, 943, 944, 946,
+ 949, 954, 960, 965, 969, 973, 975, 978, 980, 984,
+ 986, 988, 992, 998, 1003, 1007, 1010, 1013, 1015, 1017,
+ 1019, 1021, 1023, 1025, 1027, 1029, 1032, 1035, 1037, 1040,
+ 1042, 1044, 1045, 1047, 1053, 1054, 1056, 1058, 1060, 1061,
+ 1065, 1069, 1070, 1076, 1079, 1084, 1091, 1098, 1100, 1102,
+ 1104, 1108, 1112, 1114, 1118, 1122, 1124, 1126, 1132, 1138,
+ 1143, 1145, 1148, 1151, 1154, 1157, 1159, 1162, 1168, 1170,
+ 1172, 1175, 1181, 1183, 1186, 1190, 1195, 1197, 1199, 1201,
+ 1203, 1205, 1207, 1209, 1211, 1215, 1219, 1223, 1226, 1229,
+ 1230, 1236, 1244, 1245, 1248, 1250, 1252, 1253, 1255, 1257,
+ 1259, 1261, 1264, 1266, 1268, 1270, 1276, 1282, 1285, 1288,
+ 1291, 1294, 1296, 1297, 1302, 1309, 1311, 1315, 1318, 1321,
+ 1324, 1325, 1329, 1330, 1332, 1335, 1337, 1339, 1343, 1345,
+ 1348, 1350, 1352, 1355, 1358, 1361, 1365, 1368, 1370, 1371,
+ 1373, 1376, 1379, 1380, 1383, 1387, 1391, 1395, 1399, 1401,
+ 1405, 1407, 1409, 1413, 1415, 1417, 1419, 1423, 1426, 1431,
+ 1436, 1439, 1442, 1444, 1446, 1448, 1450, 1452, 1454, 1456,
+ 1458, 1460, 1464, 1466, 1468, 1472, 1476, 1480, 1484, 1487,
+ 1491, 1494, 1497, 1500, 1503, 1507, 1509, 1511, 1513, 1515,
+ 1519, 1520, 1522, 1525, 1530, 1533, 1536, 1542, 1543, 1545,
+ 1548, 1550, 1552, 1554, 1558, 1562, 1566, 1570, 1574, 1578,
+ 1580, 1582, 1584, 1588, 1594, 1600, 1606, 1612, 1620, 1622,
+ 1631, 1634, 1636, 1638, 1642, 1644, 1646, 1648, 1653, 1655,
+ 1659, 1660, 1665, 1667, 1671, 1675
+};
+
+/* YYRHS -- A `-1'-separated list of the rules' RHS. */
+static const yytype_int16 yyrhs[] =
+{
+ 191, 0, -1, -1, 191, 192, -1, 187, 198, -1,
+ 199, 193, -1, 177, -1, 197, 200, 205, -1, 1,
+ 205, 201, -1, 194, -1, 193, 27, 194, -1, 203,
+ 196, -1, 212, 196, -1, 206, 207, 196, -1, 315,
+ 200, 205, -1, 195, 196, -1, 298, 4, -1, 198,
+ 200, -1, 53, -1, 54, -1, 36, -1, 37, -1,
+ -1, -1, 144, 201, -1, -1, 177, -1, -1, -1,
+ 72, -1, -1, 202, 33, 204, 208, -1, 34, 204,
+ -1, 202, 35, 204, 208, 30, 209, -1, 202, 35,
+ 204, 208, -1, 95, 169, -1, 169, -1, -1, 32,
+ -1, 158, -1, -1, 179, 180, -1, 179, 210, 180,
+ -1, -1, 179, 180, -1, 179, 210, 180, -1, 211,
+ -1, 210, 3, 211, -1, 169, -1, 23, -1, 257,
+ 222, -1, 145, 213, 221, 324, -1, 147, 324, -1,
+ 117, 216, -1, 224, 179, 249, 180, -1, 224, 249,
+ -1, 243, -1, 228, -1, 253, -1, 239, -1, 241,
+ -1, 240, -1, 308, -1, 251, -1, 237, -1, 234,
+ -1, 68, 179, 280, 180, -1, 111, 221, 242, -1,
+ 113, 221, 215, -1, 67, 217, -1, 225, 226, 187,
+ -1, -1, 275, -1, 46, -1, 40, -1, 44, -1,
+ 56, -1, 79, -1, 45, -1, 47, -1, 62, -1,
+ 57, -1, 58, -1, 59, -1, 60, -1, 61, -1,
+ 64, -1, 65, -1, 66, -1, 69, -1, 70, -1,
+ 71, -1, 74, -1, 75, -1, 76, -1, 77, -1,
+ 169, -1, 214, -1, 215, 3, 214, -1, 179, 220,
+ 180, -1, 216, 3, 179, 220, 180, -1, 218, -1,
+ 217, 3, 218, -1, 179, 219, 180, -1, 298, 276,
+ -1, 219, 3, 298, 276, -1, 280, -1, 220, 3,
+ 280, -1, -1, 4, 4, -1, 255, 256, -1, 223,
+ 204, 208, -1, 35, -1, 29, -1, 160, -1, 169,
+ 24, 227, 24, -1, 226, 248, 169, 24, 227, 24,
+ -1, 231, 24, 227, 24, -1, 232, -1, 232, 3,
+ 227, -1, 229, 230, -1, 229, 247, 230, -1, 228,
+ 248, 247, 248, 230, -1, 228, 3, 230, -1, 119,
+ -1, -1, 169, 276, -1, 169, -1, 169, 179, 280,
+ 180, -1, 231, 3, 231, -1, 233, 299, -1, 232,
+ 21, 232, -1, 232, 22, 232, -1, 232, 23, 232,
+ -1, 232, 188, 232, -1, -1, 284, -1, 235, 236,
+ -1, 114, 298, -1, 114, 247, 298, -1, 235, 248,
+ 247, 248, 298, -1, 235, 3, 298, -1, -1, 129,
+ 324, -1, 130, 324, -1, 109, -1, 238, 248, 169,
+ 276, 264, -1, 239, 3, 169, 276, 264, -1, 81,
+ 187, -1, 81, 221, 242, -1, 80, 187, -1, 80,
+ 221, 242, -1, 169, -1, 242, 3, 169, -1, 244,
+ 245, -1, 244, 247, 245, -1, 243, 248, 247, 248,
+ 245, -1, 127, -1, 128, 127, -1, 246, -1, 245,
+ 3, 246, -1, 169, 276, -1, 20, -1, 24, 169,
+ 24, -1, -1, 3, -1, 250, -1, 249, 3, 250,
+ -1, 169, 5, 280, -1, 134, 252, -1, 169, -1,
+ 252, 3, 169, -1, 122, 123, -1, 122, 137, -1,
+ -1, 271, 254, 169, 276, 264, 305, -1, 255, 3,
+ 254, 169, 276, 264, 305, -1, -1, 262, 266, -1,
+ 261, 259, -1, 263, 23, 176, -1, 258, 268, 180,
+ -1, 146, -1, -1, 23, 176, -1, 23, 179, 260,
+ 180, -1, 179, 260, 180, -1, 169, 269, 270, -1,
+ 169, 5, 269, 270, -1, 269, 270, -1, 157, -1,
+ 263, -1, 149, -1, 148, -1, 167, -1, 151, -1,
+ 168, -1, 150, -1, -1, 23, 265, -1, 280, -1,
+ 179, 23, 180, -1, -1, 23, 267, -1, 179, 268,
+ 180, -1, 280, -1, 179, 23, 180, -1, 169, 269,
+ -1, 169, 5, 269, -1, 169, -1, 176, -1, 280,
+ -1, 23, -1, -1, 3, 169, 269, -1, -1, 4,
+ 4, -1, 3, 272, 4, 4, -1, 273, -1, 272,
+ 3, 273, -1, 29, -1, 275, -1, 82, -1, 109,
+ 276, -1, 111, -1, 112, 179, 274, 180, -1, 113,
+ -1, 116, -1, 117, -1, 119, -1, 120, -1, 140,
+ -1, 138, -1, 139, -1, 80, -1, 81, -1, -1,
+ 179, 277, 180, -1, 278, -1, 277, 3, 278, -1,
+ 279, -1, 4, -1, 280, 4, -1, 4, 280, -1,
+ 280, 4, 279, -1, 23, -1, 280, -1, 283, -1,
+ 179, 280, 180, -1, 307, -1, 281, -1, 46, 282,
+ 180, -1, 39, 282, 180, -1, 40, 179, 282, 180,
+ -1, 44, 179, 282, 180, -1, 56, 282, 180, -1,
+ 79, 179, 282, 180, -1, 45, 179, 280, 180, -1,
+ 47, 280, 180, -1, 148, 179, 282, 180, -1, 62,
+ 179, 280, 180, -1, 57, 179, 280, 180, -1, 58,
+ 179, 280, 180, -1, 59, 179, 280, 180, -1, 60,
+ 179, 280, 180, -1, 61, 179, 280, 180, -1, 64,
+ 179, 280, 180, -1, 65, 179, 280, 180, -1, 66,
+ 179, 280, 180, -1, 69, 179, 280, 180, -1, 70,
+ 179, 280, 180, -1, 71, 179, 280, 180, -1, 73,
+ 280, 180, -1, 74, 179, 282, 180, -1, 75, 179,
+ 282, 180, -1, 76, 179, 282, 180, -1, 77, 179,
+ 282, 180, -1, 280, -1, 282, 3, 280, -1, 288,
+ -1, 299, -1, 293, -1, 280, 285, -1, 284, 280,
+ -1, 12, 280, -1, 21, -1, 22, -1, 21, 280,
+ -1, 22, 280, -1, 23, 280, -1, 25, 280, -1,
+ 14, 280, -1, 8, 280, -1, 17, 280, -1, 186,
+ 280, -1, 18, 280, -1, 185, 280, -1, 15, 280,
+ -1, 186, 5, 280, -1, 16, 280, -1, 185, 5,
+ 280, -1, 13, 280, -1, 7, 280, -1, 9, 280,
+ -1, 10, 280, -1, 11, 280, -1, 24, 286, -1,
+ 5, 287, -1, -1, 280, -1, 5, 280, -1, 24,
+ 280, -1, 5, 280, -1, 280, -1, 298, -1, 292,
+ -1, 290, -1, -1, 291, -1, 291, 302, -1, 292,
+ 179, 294, 180, -1, 292, 179, 294, 180, 302, -1,
+ 298, 179, 294, 180, -1, 288, 189, 288, -1, 131,
+ 360, 132, -1, 289, -1, 289, 295, -1, 296, -1,
+ 295, 3, 296, -1, 280, -1, 297, -1, 280, 4,
+ 280, -1, 280, 4, 280, 4, 280, -1, 4, 280,
+ 4, 280, -1, 4, 4, 280, -1, 4, 280, -1,
+ 280, 4, -1, 4, -1, 169, -1, 142, -1, 143,
+ -1, 176, -1, 163, -1, 164, -1, 165, -1, 299,
+ 169, -1, 300, 301, -1, 158, -1, 300, 158, -1,
+ 162, -1, 159, -1, -1, 302, -1, 179, 303, 4,
+ 303, 180, -1, -1, 280, -1, 187, -1, 280, -1,
+ -1, 306, 5, 280, -1, 306, 126, 280, -1, -1,
+ 179, 283, 3, 283, 180, -1, 309, 310, -1, 309,
+ 310, 3, 311, -1, 309, 310, 3, 31, 4, 187,
+ -1, 309, 310, 3, 31, 4, 313, -1, 141, -1,
+ 169, -1, 312, -1, 311, 3, 312, -1, 169, 126,
+ 169, -1, 314, -1, 313, 3, 314, -1, 169, 126,
+ 169, -1, 169, -1, 328, -1, 98, 179, 366, 370,
+ 180, -1, 105, 179, 369, 370, 180, -1, 106, 179,
+ 371, 180, -1, 317, -1, 318, 324, -1, 316, 324,
+ -1, 319, 324, -1, 96, 324, -1, 321, -1, 372,
+ 328, -1, 41, 179, 280, 180, 304, -1, 42, -1,
+ 43, -1, 372, 84, -1, 85, 179, 280, 180, 84,
+ -1, 86, -1, 87, 324, -1, 48, 320, 180, -1,
+ 49, 179, 280, 180, -1, 115, -1, 110, -1, 93,
+ -1, 153, -1, 156, -1, 155, -1, 154, -1, 280,
+ -1, 320, 3, 280, -1, 320, 4, 280, -1, 326,
+ 323, 322, -1, 327, 280, -1, 94, 325, -1, -1,
+ 373, 5, 280, 3, 280, -1, 373, 5, 280, 3,
+ 280, 3, 280, -1, -1, 176, 248, -1, 187, -1,
+ 169, -1, -1, 169, -1, 92, -1, 97, -1, 118,
+ -1, 330, 332, -1, 365, -1, 341, -1, 333, -1,
+ 98, 179, 366, 370, 180, -1, 105, 179, 369, 370,
+ 180, -1, 78, 303, -1, 83, 304, -1, 63, 304,
+ -1, 340, 304, -1, 331, -1, -1, 298, 329, 276,
+ 276, -1, 330, 189, 298, 329, 276, 276, -1, 176,
+ -1, 331, 3, 176, -1, 5, 280, -1, 126, 280,
+ -1, 336, 334, -1, -1, 179, 335, 180, -1, -1,
+ 338, -1, 337, 169, -1, 124, -1, 339, -1, 338,
+ 3, 339, -1, 280, -1, 23, 364, -1, 133, -1,
+ 135, -1, 349, 345, -1, 351, 343, -1, 352, 345,
+ -1, 352, 345, 360, -1, 104, 346, -1, 38, -1,
+ -1, 356, -1, 345, 342, -1, 350, 344, -1, -1,
+ 3, 356, -1, 179, 347, 180, -1, 179, 353, 180,
+ -1, 179, 298, 180, -1, 179, 176, 180, -1, 176,
+ -1, 179, 283, 180, -1, 169, -1, 348, -1, 347,
+ 3, 348, -1, 353, -1, 23, -1, 25, -1, 298,
+ 280, 276, -1, 298, 280, -1, 298, 280, 189, 330,
+ -1, 298, 179, 297, 180, -1, 298, 23, -1, 298,
+ 25, -1, 99, -1, 100, -1, 354, -1, 23, -1,
+ 103, -1, 101, -1, 88, -1, 102, -1, 354, -1,
+ 179, 353, 180, -1, 288, -1, 299, -1, 353, 355,
+ 353, -1, 353, 23, 353, -1, 353, 24, 353, -1,
+ 353, 25, 353, -1, 355, 353, -1, 353, 20, 353,
+ -1, 50, 280, -1, 55, 280, -1, 52, 280, -1,
+ 51, 280, -1, 169, 5, 280, -1, 281, -1, 21,
+ -1, 22, -1, 358, -1, 356, 3, 358, -1, -1,
+ 288, -1, 357, 359, -1, 179, 356, 180, 359, -1,
+ 281, 359, -1, 299, 359, -1, 179, 356, 3, 363,
+ 180, -1, -1, 285, -1, 359, 285, -1, 283, -1,
+ 362, -1, 361, -1, 283, 3, 280, -1, 283, 3,
+ 362, -1, 362, 3, 280, -1, 362, 3, 362, -1,
+ 361, 3, 280, -1, 361, 3, 362, -1, 283, -1,
+ 281, -1, 307, -1, 179, 280, 180, -1, 179, 283,
+ 3, 363, 180, -1, 179, 362, 3, 363, 180, -1,
+ 179, 361, 3, 363, 180, -1, 169, 5, 280, 3,
+ 280, -1, 169, 5, 280, 3, 280, 3, 280, -1,
+ 176, -1, 89, 179, 280, 3, 280, 180, 3, 280,
+ -1, 89, 364, -1, 367, -1, 330, -1, 366, 3,
+ 367, -1, 298, -1, 292, -1, 368, -1, 298, 179,
+ 295, 180, -1, 367, -1, 369, 3, 367, -1, -1,
+ 3, 125, 5, 298, -1, 298, -1, 371, 3, 298,
+ -1, 91, 280, 180, -1, 298, -1
+};
+
+/* YYRLINE[YYN] -- source line where rule number YYN was defined. */
+static const yytype_uint16 yyrline[] =
+{
+ 0, 336, 336, 337, 339, 340, 341, 342, 343, 346,
+ 347, 349, 350, 351, 360, 361, 363, 365, 367, 374,
+ 379, 380, 382, 384, 385, 387, 388, 394, 397, 398,
+ 401, 402, 430, 448, 481, 515, 532, 539, 541, 545,
+ 550, 553, 556, 561, 562, 563, 571, 582, 594, 595,
+ 597, 605, 613, 619, 620, 635, 648, 649, 655, 656,
+ 693, 706, 707, 708, 709, 710, 711, 712, 713, 714,
+ 715, 734, 735, 741, 742, 743, 744, 745, 746, 747,
+ 748, 749, 750, 751, 752, 753, 754, 755, 756, 757,
+ 758, 759, 760, 761, 762, 763, 764, 766, 767, 769,
+ 770, 772, 773, 775, 777, 778, 780, 781, 783, 784,
+ 786, 870, 907, 913, 918, 923, 937, 951, 966, 973,
+ 982, 983, 984, 985, 987, 992, 993, 998, 1002, 1007,
+ 1012, 1014, 1016, 1018, 1020, 1024, 1025, 1028, 1030, 1031,
+ 1032, 1033, 1035, 1037, 1042, 1047, 1053, 1069, 1086, 1087,
+ 1089, 1093, 1098, 1102, 1107, 1113, 1124, 1136, 1141, 1147,
+ 1152, 1156, 1166, 1175, 1185, 1186, 1188, 1192, 1197, 1220,
+ 1222, 1223, 1225, 1235, 1237, 1239, 1272, 1307, 1309, 1311,
+ 1315, 1320, 1326, 1334, 1335, 1337, 1338, 1340, 1341, 1342,
+ 1344, 1349, 1351, 1356, 1360, 1363, 1369, 1371, 1377, 1378,
+ 1380, 1381, 1383, 1384, 1385, 1387, 1388, 1390, 1391, 1400,
+ 1404, 1409, 1411, 1414, 1415, 1417, 1418, 1419, 1421, 1422,
+ 1424, 1428, 1429, 1431, 1436, 1438, 1440, 1441, 1442, 1443,
+ 1449, 1452, 1453, 1454, 1456, 1458, 1461, 1466, 1470, 1472,
+ 1476, 1481, 1485, 1490, 1495, 1503, 1504, 1506, 1507, 1509,
+ 1511, 1515, 1517, 1519, 1521, 1523, 1525, 1527, 1529, 1531,
+ 1533, 1535, 1537, 1539, 1541, 1543, 1545, 1547, 1549, 1551,
+ 1553, 1555, 1557, 1559, 1561, 1563, 1565, 1568, 1569, 1573,
+ 1574, 1576, 1578, 1580, 1582, 1585, 1586, 1588, 1590, 1592,
+ 1594, 1596, 1598, 1600, 1602, 1604, 1606, 1608, 1610, 1612,
+ 1614, 1616, 1618, 1620, 1622, 1624, 1626, 1628, 1631, 1632,
+ 1634, 1636, 1639, 1641, 1645, 1650, 1655, 1661, 1673, 1678,
+ 1680, 1683, 1687, 1697, 1703, 1706, 1707, 1710, 1711, 1714,
+ 1715, 1717, 1719, 1722, 1724, 1725, 1726, 1727, 1729, 1787,
+ 1789, 1790, 1791, 1792, 1793, 1794, 1796, 1798, 1800, 1801,
+ 1803, 1806, 1807, 1809, 1812, 1813, 1815, 1816, 1818, 1819,
+ 1827, 1836, 1838, 1841, 1861, 1895, 1915, 1966, 1974, 1977,
+ 1981, 1991, 2002, 2006, 2016, 2028, 2037, 2038, 2044, 2050,
+ 2051, 2101, 2119, 2139, 2158, 2203, 2204, 2205, 2206, 2207,
+ 2208, 2209, 2210, 2211, 2212, 2213, 2214, 2215, 2216, 2260,
+ 2270, 2279, 2288, 2297, 2298, 2299, 2301, 2302, 2303, 2305,
+ 2306, 2307, 2308, 2309, 2311, 2312, 2314, 2315, 2317, 2319,
+ 2326, 2327, 2328, 2329, 2330, 2331, 2337, 2343, 2344, 2345,
+ 2346, 2347, 2349, 2350, 2360, 2362, 2363, 2365, 2366, 2368,
+ 2396, 2397, 2399, 2400, 2402, 2432, 2434, 2435, 2438, 2452,
+ 2455, 2456, 2459, 2460, 2461, 2462, 2463, 2464, 2476, 2477,
+ 2479, 2480, 2485, 2486, 2488, 2489, 2491, 2492, 2493, 2494,
+ 2495, 2497, 2498, 2500, 2501, 2502, 2503, 2504, 2505, 2506,
+ 2507, 2508, 2510, 2511, 2513, 2514, 2517, 2518, 2519, 2522,
+ 2525, 2526, 2528, 2529, 2530, 2531, 2532, 2533, 2534, 2535,
+ 2536, 2537, 2538, 2539, 2540, 2541, 2543, 2544, 2546, 2547,
+ 2549, 2550, 2552, 2553, 2554, 2555, 2556, 2558, 2559, 2560,
+ 2562, 2563, 2564, 2566, 2568, 2570, 2572, 2574, 2576, 2578,
+ 2579, 2581, 2583, 2585, 2587, 2589, 2593, 2596, 2603, 2605,
+ 2606, 2608, 2609, 2610, 2612, 2614, 2615, 2617, 2624, 2625,
+ 2627, 2628, 2630, 2631, 2639, 2641
+};
+#endif
+
+#if YYDEBUG || YYERROR_VERBOSE || YYTOKEN_TABLE
+/* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM.
+ First, the terminals, then, starting at YYNTOKENS, nonterminals. */
+static const char *const yytname[] =
+{
+ "$end", "error", "$undefined", "','", "':'", "'='", "TOK_BINARY_OP",
+ "TOK_NEQV", "TOK_EQV", "TOK_XOR", "TOK_OR", "TOK_AND", "TOK_NOT",
+ "TOK_NE", "TOK_EQ", "TOK_GE", "TOK_LE", "TOK_GT", "TOK_LT",
+ "TOK_UNARY_OP", "TOK_DSLASH", "'+'", "'-'", "'*'", "TOK_SLASH",
+ "TOK_DASTER", "TOK_SEP", "TOK_SEMICOLON", "TOK_NEXTLINE",
+ "TOK_PARAMETER", "TOK_RESULT", "TOK_ONLY", "TOK_INCLUDE",
+ "TOK_SUBROUTINE", "TOK_PROGRAM", "TOK_FUNCTION", "TOK_OMP", "TOK_DOLLAR",
+ "TOK_FORMAT", "TOK_MAX", "TOK_TANH", "TOK_WHERE", "TOK_ELSEWHERE",
+ "TOK_ENDWHERE", "TOK_MAXVAL", "TOK_TRIM", "TOK_SUM", "TOK_SQRT",
+ "TOK_CASE", "TOK_SELECTCASE", "TOK_FILE", "TOK_END", "TOK_ERR",
+ "TOK_DONOTTREAT", "TOK_ENDDONOTTREAT", "TOK_EXIST", "TOK_MIN",
+ "TOK_FLOAT", "TOK_EXP", "TOK_COS", "TOK_COSH", "TOK_ACOS", "TOK_NINT",
+ "TOK_CYCLE", "TOK_SIN", "TOK_SINH", "TOK_ASIN", "TOK_EQUIVALENCE",
+ "TOK_BACKSPACE", "TOK_LOG", "TOK_TAN", "TOK_ATAN", "TOK_RECURSIVE",
+ "TOK_ABS", "TOK_MOD", "TOK_SIGN", "TOK_MINLOC", "TOK_MAXLOC", "TOK_EXIT",
+ "TOK_MINVAL", "TOK_PUBLIC", "TOK_PRIVATE", "TOK_ALLOCATABLE",
+ "TOK_RETURN", "TOK_THEN", "TOK_ELSEIF", "TOK_ELSE", "TOK_ENDIF",
+ "TOK_PRINT", "TOK_PLAINGOTO", "TOK_CONSTRUCTID", "TOK_LOGICALIF",
+ "TOK_PLAINDO", "TOK_CONTAINS", "TOK_ENDDO", "TOK_MODULE",
+ "TOK_ENDMODULE", "TOK_DOWHILE", "TOK_ALLOCATE", "TOK_OPEN", "TOK_CLOSE",
+ "TOK_INQUIRE", "TOK_WRITE", "TOK_READ", "TOK_REWIND", "TOK_DEALLOCATE",
+ "TOK_NULLIFY", "TOK_FIN", "TOK_DEBUT", "TOK_DIMENSION", "TOK_ENDSELECT",
+ "TOK_EXTERNAL", "TOK_INTENT", "TOK_INTRINSIC", "TOK_NAMELIST",
+ "TOK_CASEDEFAULT", "TOK_OPTIONAL", "TOK_POINTER", "TOK_CONTINUE",
+ "TOK_SAVE", "TOK_TARGET", "TOK_QUOTE", "TOK_IMPLICIT", "TOK_NONE",
+ "TOK_CALL", "TOK_STAT", "TOK_POINT_TO", "TOK_COMMON", "TOK_GLOBAL",
+ "TOK_INTERFACE", "TOK_ENDINTERFACE", "TOK_LEFTAB", "TOK_RIGHTAB",
+ "TOK_PAUSE", "TOK_PROCEDURE", "TOK_STOP", "TOK_NAMEEQ", "TOK_REAL8",
+ "TOK_OUT", "TOK_INOUT", "TOK_IN", "TOK_USE", "TOK_TRUE", "TOK_FALSE",
+ "TOK_LABEL", "TOK_TYPE", "TOK_TYPEPAR", "TOK_ENDTYPE", "TOK_REAL",
+ "TOK_INTEGER", "TOK_LOGICAL", "TOK_DOUBLEPRECISION", "TOK_DOUBLEREAL",
+ "TOK_ENDSUBROUTINE", "TOK_ENDFUNCTION", "TOK_ENDPROGRAM", "TOK_ENDUNIT",
+ "TOK_CHARACTER", "TOK_CHAR_CONSTANT", "TOK_CHAR_CUT", "TOK_DATA",
+ "TOK_CHAR_INT", "TOK_CHAR_MESSAGE", "TOK_CSTREAL", "TOK_CSTREALDP",
+ "TOK_CSTREALQP", "TOK_SFREAL", "TOK_COMPLEX", "TOK_DOUBLECOMPLEX",
+ "TOK_NAME", "TOK_NAME_CHAR", "TOK_PROBTYPE", "TOK_INTERPTYPE",
+ "TOK_VARTYPE", "TOK_BC", "TOK_OP", "TOK_CSTINT", "TOK_COMMENT",
+ "TOK_FILENAME", "'('", "')'", "'['", "']'", "'!'", "'_'", "'<'", "'>'",
+ "'\\n'", "'/'", "'%'", "$accept", "input", "line", "suite_line_list",
+ "suite_line", "instr", "fin_line", "keyword", "position", "thislabel",
+ "cmnt", "nulcurbuf", "opt_recursive", "entry", "name_routine",
+ "writedeclar", "before_include", "filename", "arglist", "arglist1",
+ "args", "arg", "spec", "opt_spec", "name_intrinsic",
+ "use_intrinsic_list", "list_couple", "list_expr_equi", "expr_equi",
+ "list_expr_equi1", "list_expr", "opt_sep", "after_type",
+ "before_function", "before_parameter", "before_data", "data",
+ "datavallist", "save", "before_save", "varsave", "datanamelist",
+ "expr_data", "opt_signe", "namelist", "namelist_action",
+ "after_namelist", "interface", "before_dimension", "dimension",
+ "private", "public", "use_name_list", "common", "before_common",
+ "var_common_list", "var_common", "comblock", "opt_comma", "paramlist",
+ "paramitem", "module_proc_stmt", "proc_name_list", "implicit",
+ "opt_retour", "dcl", "nodimsgiven", "type", "before_typepar",
+ "c_selector", "c_attribute", "before_character", "typespec", "typename",
+ "lengspec", "proper_lengspec", "selector", "proper_selector",
+ "attribute", "clause", "opt_clause", "options", "attr_spec_list",
+ "attr_spec", "intent_spec", "access_spec", "dims", "dimlist", "dim",
+ "ubound", "expr", "predefinedfunction", "minmaxlist", "uexpr", "signe",
+ "operation", "after_slash", "after_equal", "lhs", "beforefunctionuse",
+ "array_ele_substring_func_ref", "begin_array", "structure_component",
+ "vec", "funarglist", "funargs", "funarg", "triplet", "ident",
+ "simple_const", "string_constant", "opt_substring", "substring",
+ "optexpr", "opt_expr", "initial_value", "before_initial",
+ "complex_const", "use_stat", "word_use", "module_name", "rename_list",
+ "rename_name", "only_list", "only_name", "exec", "word_endsubroutine",
+ "word_endunit", "word_endprogram", "word_endfunction", "caselist",
+ "boucledo", "do_arg", "opt_int", "opt_name", "optname", "worddo",
+ "wordwhile", "iffable", "before_dims", "ident_dims", "int_list",
+ "after_ident_dims", "call", "opt_call", "opt_callarglist", "keywordcall",
+ "before_call", "callarglist", "callarg", "stop", "io", "option_inlist",
+ "option_read", "opt_inlist", "ioctl", "after_rewind", "ctllist",
+ "ioclause", "iofctl", "infmt", "read", "write", "fexpr", "unpar_fexpr",
+ "addop", "inlist", "opt_lhs", "inelt", "opt_operation", "outlist",
+ "out2", "other", "dospec", "label", "goto", "allocation_list",
+ "allocate_object", "array_element", "allocate_object_list",
+ "opt_stat_spec", "pointer_name_list", "logif", "do_var", 0
+};
+#endif
+
+# ifdef YYPRINT
+/* YYTOKNUM[YYLEX-NUM] -- Internal token number corresponding to
+ token YYLEX-NUM. */
+static const yytype_uint16 yytoknum[] =
+{
+ 0, 256, 257, 44, 58, 61, 258, 259, 260, 261,
+ 262, 263, 264, 265, 266, 267, 268, 269, 270, 271,
+ 272, 43, 45, 42, 273, 274, 275, 276, 277, 278,
+ 279, 280, 281, 282, 283, 284, 285, 286, 287, 288,
+ 289, 290, 291, 292, 293, 294, 295, 296, 297, 298,
+ 299, 300, 301, 302, 303, 304, 305, 306, 307, 308,
+ 309, 310, 311, 312, 313, 314, 315, 316, 317, 318,
+ 319, 320, 321, 322, 323, 324, 325, 326, 327, 328,
+ 329, 330, 331, 332, 333, 334, 335, 336, 337, 338,
+ 339, 340, 341, 342, 343, 344, 345, 346, 347, 348,
+ 349, 350, 351, 352, 353, 354, 355, 356, 357, 358,
+ 359, 360, 361, 362, 363, 364, 365, 366, 367, 368,
+ 369, 370, 371, 372, 373, 374, 375, 376, 377, 378,
+ 379, 380, 381, 382, 383, 384, 385, 386, 387, 388,
+ 389, 390, 391, 392, 393, 394, 395, 396, 397, 398,
+ 399, 400, 401, 402, 403, 404, 405, 406, 407, 408,
+ 409, 410, 411, 412, 413, 414, 415, 416, 417, 418,
+ 419, 420, 421, 422, 423, 424, 425, 426, 427, 40,
+ 41, 91, 93, 33, 95, 60, 62, 10, 47, 37
+};
+# endif
+
+/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */
+static const yytype_uint16 yyr1[] =
+{
+ 0, 190, 191, 191, 192, 192, 192, 192, 192, 193,
+ 193, 194, 194, 194, 194, 194, 195, 196, 197, 197,
+ 197, 197, 198, 199, 199, 200, 200, 201, 202, 202,
+ 203, 203, 203, 203, 203, 203, 204, 205, 206, 207,
+ 208, 208, 208, 209, 209, 209, 210, 210, 211, 211,
+ 212, 212, 212, 212, 212, 212, 212, 212, 212, 212,
+ 212, 212, 212, 212, 212, 212, 212, 212, 212, 212,
+ 212, 213, 213, 214, 214, 214, 214, 214, 214, 214,
+ 214, 214, 214, 214, 214, 214, 214, 214, 214, 214,
+ 214, 214, 214, 214, 214, 214, 214, 215, 215, 216,
+ 216, 217, 217, 218, 219, 219, 220, 220, 221, 221,
+ 222, 222, 223, 224, 225, 226, 226, 226, 227, 227,
+ 228, 228, 228, 228, 229, 230, 230, 231, 231, 231,
+ 232, 232, 232, 232, 232, 233, 233, 234, 235, 235,
+ 235, 235, 236, 237, 237, 238, 239, 239, 240, 240,
+ 241, 241, 242, 242, 243, 243, 243, 244, 244, 245,
+ 245, 246, 247, 247, 248, 248, 249, 249, 250, 251,
+ 252, 252, 253, 253, 254, 255, 255, 256, 257, 257,
+ 257, 257, 258, 259, 259, 259, 259, 260, 260, 260,
+ 261, 262, 263, 263, 263, 263, 263, 263, 264, 264,
+ 265, 265, 266, 266, 266, 267, 267, 268, 268, 268,
+ 268, 269, 269, 270, 270, 271, 271, 271, 272, 272,
+ 273, 273, 273, 273, 273, 273, 273, 273, 273, 273,
+ 273, 274, 274, 274, 275, 275, 276, 276, 277, 277,
+ 278, 278, 278, 278, 278, 279, 279, 280, 280, 280,
+ 280, 281, 281, 281, 281, 281, 281, 281, 281, 281,
+ 281, 281, 281, 281, 281, 281, 281, 281, 281, 281,
+ 281, 281, 281, 281, 281, 281, 281, 282, 282, 283,
+ 283, 283, 283, 283, 283, 284, 284, 285, 285, 285,
+ 285, 285, 285, 285, 285, 285, 285, 285, 285, 285,
+ 285, 285, 285, 285, 285, 285, 285, 285, 286, 286,
+ 286, 286, 287, 287, 288, 288, 288, 289, 290, 290,
+ 290, 290, 291, 292, 293, 294, 294, 295, 295, 296,
+ 296, 297, 297, 297, 297, 297, 297, 297, 298, 299,
+ 299, 299, 299, 299, 299, 299, 299, 300, 300, 300,
+ 300, 301, 301, 302, 303, 303, 304, 304, 305, 305,
+ 305, 306, 307, 308, 308, 308, 308, 309, 310, 311,
+ 311, 312, 313, 313, 314, 314, 315, 315, 315, 315,
+ 315, 315, 315, 315, 315, 315, 315, 315, 315, 315,
+ 315, 315, 315, 315, 315, 315, 315, 315, 315, 316,
+ 317, 318, 319, 320, 320, 320, 321, 321, 321, 322,
+ 322, 322, 323, 323, 324, 324, 325, 325, 326, 327,
+ 328, 328, 328, 328, 328, 328, 328, 328, 328, 328,
+ 328, 328, 329, 330, 330, 331, 331, 332, 332, 333,
+ 334, 334, 335, 335, 336, 337, 338, 338, 339, 339,
+ 340, 340, 341, 341, 341, 341, 341, 341, 342, 342,
+ 343, 343, 344, 344, 345, 345, 346, 346, 346, 346,
+ 346, 347, 347, 348, 348, 348, 348, 348, 348, 348,
+ 348, 348, 349, 349, 350, 350, 351, 351, 351, 352,
+ 353, 353, 354, 354, 354, 354, 354, 354, 354, 354,
+ 354, 354, 354, 354, 354, 354, 355, 355, 356, 356,
+ 357, 357, 358, 358, 358, 358, 358, 359, 359, 359,
+ 360, 360, 360, 361, 361, 361, 361, 361, 361, 361,
+ 361, 362, 362, 362, 362, 362, 363, 363, 364, 365,
+ 365, 366, 366, 366, 367, 367, 367, 368, 369, 369,
+ 370, 370, 371, 371, 372, 373
+};
+
+/* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */
+static const yytype_uint8 yyr2[] =
+{
+ 0, 2, 0, 2, 2, 2, 1, 3, 3, 1,
+ 3, 2, 2, 3, 3, 2, 2, 2, 1, 1,
+ 1, 1, 0, 0, 2, 0, 1, 0, 0, 1,
+ 0, 4, 2, 6, 4, 2, 1, 0, 1, 1,
+ 0, 2, 3, 0, 2, 3, 1, 3, 1, 1,
+ 2, 4, 2, 2, 4, 2, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 4, 3, 3, 2,
+ 3, 0, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 3, 3,
+ 5, 1, 3, 3, 2, 4, 1, 3, 0, 2,
+ 2, 3, 1, 1, 1, 4, 6, 4, 1, 3,
+ 2, 3, 5, 3, 1, 0, 2, 1, 4, 3,
+ 2, 3, 3, 3, 3, 0, 1, 2, 2, 3,
+ 5, 3, 0, 2, 2, 1, 5, 5, 2, 3,
+ 2, 3, 1, 3, 2, 3, 5, 1, 2, 1,
+ 3, 2, 1, 3, 0, 1, 1, 3, 3, 2,
+ 1, 3, 2, 2, 0, 6, 7, 0, 2, 2,
+ 3, 3, 1, 0, 2, 4, 3, 3, 4, 2,
+ 1, 1, 1, 1, 1, 1, 1, 1, 0, 2,
+ 1, 3, 0, 2, 3, 1, 3, 2, 3, 1,
+ 1, 1, 1, 0, 3, 0, 2, 4, 1, 3,
+ 1, 1, 1, 2, 1, 4, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 0, 3, 1, 3,
+ 1, 1, 2, 2, 3, 1, 1, 1, 3, 1,
+ 1, 3, 3, 4, 4, 3, 4, 4, 3, 4,
+ 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
+ 4, 4, 3, 4, 4, 4, 4, 1, 3, 1,
+ 1, 1, 2, 2, 2, 1, 1, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 3, 2,
+ 3, 2, 2, 2, 2, 2, 2, 2, 0, 1,
+ 2, 2, 2, 1, 1, 1, 1, 0, 1, 2,
+ 4, 5, 4, 3, 3, 1, 2, 1, 3, 1,
+ 1, 3, 5, 4, 3, 2, 2, 1, 1, 1,
+ 1, 1, 1, 1, 1, 2, 2, 1, 2, 1,
+ 1, 0, 1, 5, 0, 1, 1, 1, 0, 3,
+ 3, 0, 5, 2, 4, 6, 6, 1, 1, 1,
+ 3, 3, 1, 3, 3, 1, 1, 5, 5, 4,
+ 1, 2, 2, 2, 2, 1, 2, 5, 1, 1,
+ 2, 5, 1, 2, 3, 4, 1, 1, 1, 1,
+ 1, 1, 1, 1, 3, 3, 3, 2, 2, 0,
+ 5, 7, 0, 2, 1, 1, 0, 1, 1, 1,
+ 1, 2, 1, 1, 1, 5, 5, 2, 2, 2,
+ 2, 1, 0, 4, 6, 1, 3, 2, 2, 2,
+ 0, 3, 0, 1, 2, 1, 1, 3, 1, 2,
+ 1, 1, 2, 2, 2, 3, 2, 1, 0, 1,
+ 2, 2, 0, 2, 3, 3, 3, 3, 1, 3,
+ 1, 1, 3, 1, 1, 1, 3, 2, 4, 4,
+ 2, 2, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 3, 1, 1, 3, 3, 3, 3, 2, 3,
+ 2, 2, 2, 2, 3, 1, 1, 1, 1, 3,
+ 0, 1, 2, 4, 2, 2, 5, 0, 1, 2,
+ 1, 1, 1, 3, 3, 3, 3, 3, 3, 1,
+ 1, 1, 3, 5, 5, 5, 5, 7, 1, 8,
+ 2, 1, 1, 3, 1, 1, 1, 4, 1, 3,
+ 0, 4, 1, 3, 3, 1
+};
+
+/* YYDEFACT[STATE-NAME] -- Default rule to reduce with in state
+ STATE-NUM when YYTABLE doesn't specify something else to do. Zero
+ means the default is an error. */
+static const yytype_uint16 yydefact[] =
+{
+ 2, 0, 1, 37, 20, 21, 18, 19, 27, 6,
+ 22, 3, 25, 30, 27, 24, 4, 26, 37, 113,
+ 38, 0, 457, 0, 388, 389, 0, 0, 0, 0,
+ 0, 29, 354, 108, 108, 0, 0, 392, 0, 488,
+ 0, 0, 418, 398, 416, 0, 0, 419, 0, 482,
+ 483, 487, 489, 486, 0, 0, 0, 145, 397, 108,
+ 108, 0, 396, 0, 420, 124, 0, 445, 157, 0,
+ 0, 0, 450, 0, 451, 367, 71, 182, 0, 193,
+ 192, 197, 195, 399, 402, 401, 400, 190, 114, 194,
+ 196, 338, 435, 5, 9, 22, 0, 22, 0, 22,
+ 0, 0, 57, 125, 65, 142, 64, 164, 59, 61,
+ 60, 56, 0, 63, 58, 215, 0, 183, 202, 191,
+ 432, 62, 0, 25, 0, 380, 0, 0, 385, 412,
+ 0, 376, 0, 431, 424, 440, 0, 0, 423, 0,
+ 0, 0, 422, 0, 8, 7, 36, 32, 0, 0,
+ 285, 286, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 339, 340,
+ 0, 347, 350, 349, 342, 343, 344, 341, 0, 403,
+ 250, 247, 0, 279, 316, 318, 315, 281, 314, 280,
+ 351, 249, 0, 0, 356, 357, 429, 0, 69, 101,
+ 0, 355, 427, 0, 150, 0, 148, 0, 428, 0,
+ 415, 414, 393, 538, 0, 540, 0, 417, 408, 35,
+ 384, 0, 470, 468, 0, 456, 0, 0, 0, 0,
+ 162, 0, 0, 138, 0, 53, 172, 173, 158, 143,
+ 144, 170, 169, 234, 235, 108, 72, 52, 30, 15,
+ 25, 0, 0, 11, 39, 22, 12, 0, 0, 55,
+ 166, 127, 164, 0, 125, 0, 236, 120, 125, 165,
+ 137, 0, 165, 0, 0, 0, 236, 154, 159, 0,
+ 0, 0, 112, 50, 0, 177, 174, 209, 210, 0,
+ 0, 0, 179, 0, 0, 178, 0, 16, 236, 368,
+ 363, 37, 382, 381, 383, 164, 409, 407, 0, 0,
+ 0, 421, 0, 442, 439, 444, 430, 0, 452, 506,
+ 507, 485, 0, 0, 0, 0, 338, 0, 505, 492,
+ 493, 453, 458, 462, 0, 484, 0, 454, 390, 0,
+ 0, 432, 386, 0, 284, 277, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 530, 520, 249, 0, 522, 521, 0,
+ 0, 247, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 308, 0, 0,
+ 0, 282, 283, 0, 354, 319, 317, 317, 345, 348,
+ 346, 352, 0, 0, 394, 0, 0, 236, 0, 0,
+ 109, 152, 151, 149, 0, 0, 554, 0, 545, 432,
+ 542, 550, 541, 546, 341, 247, 314, 544, 548, 550,
+ 552, 0, 67, 74, 75, 78, 73, 79, 76, 81,
+ 82, 83, 84, 85, 80, 86, 87, 88, 89, 90,
+ 91, 92, 93, 94, 95, 77, 96, 97, 68, 0,
+ 139, 0, 106, 0, 0, 0, 10, 17, 40, 40,
+ 13, 0, 0, 0, 135, 0, 70, 0, 0, 135,
+ 123, 164, 0, 126, 121, 141, 164, 236, 236, 164,
+ 161, 0, 155, 220, 222, 236, 224, 0, 226, 227,
+ 228, 229, 230, 0, 218, 221, 216, 40, 174, 110,
+ 0, 0, 212, 207, 211, 181, 184, 0, 338, 0,
+ 213, 0, 203, 205, 0, 180, 236, 0, 14, 413,
+ 555, 406, 0, 437, 438, 432, 436, 0, 448, 0,
+ 443, 446, 474, 475, 0, 314, 0, 471, 473, 490,
+ 500, 503, 502, 501, 0, 473, 510, 517, 511, 517,
+ 460, 459, 517, 508, 510, 461, 0, 0, 0, 0,
+ 0, 498, 455, 0, 0, 0, 0, 252, 0, 0,
+ 0, 251, 258, 255, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 272, 0, 0, 0,
+ 0, 0, 0, 247, 0, 0, 0, 324, 0, 0,
+ 0, 248, 0, 0, 313, 307, 302, 292, 303, 304,
+ 305, 301, 291, 297, 299, 293, 295, 287, 288, 289,
+ 0, 0, 309, 306, 290, 0, 296, 0, 294, 323,
+ 0, 325, 0, 0, 404, 405, 395, 0, 103, 104,
+ 102, 66, 0, 0, 0, 317, 0, 0, 467, 469,
+ 466, 0, 0, 0, 379, 0, 163, 0, 99, 0,
+ 171, 51, 0, 31, 34, 168, 54, 167, 0, 118,
+ 0, 136, 0, 0, 127, 129, 0, 125, 241, 245,
+ 0, 238, 240, 246, 0, 198, 198, 0, 160, 223,
+ 0, 0, 0, 111, 0, 236, 208, 0, 0, 213,
+ 186, 0, 189, 0, 204, 433, 0, 0, 364, 369,
+ 0, 236, 449, 441, 0, 0, 480, 481, 317, 236,
+ 0, 464, 465, 504, 465, 0, 518, 514, 515, 510,
+ 512, 463, 499, 495, 496, 497, 494, 550, 550, 387,
+ 278, 253, 254, 257, 261, 262, 263, 264, 265, 260,
+ 266, 267, 268, 269, 270, 271, 273, 274, 275, 276,
+ 256, 248, 0, 0, 0, 523, 524, 527, 528, 525,
+ 526, 259, 247, 312, 310, 311, 300, 298, 354, 337,
+ 329, 326, 327, 330, 320, 322, 236, 153, 391, 0,
+ 0, 0, 543, 377, 549, 378, 553, 98, 107, 0,
+ 49, 48, 41, 0, 46, 43, 115, 135, 135, 135,
+ 135, 135, 130, 128, 135, 117, 122, 243, 0, 237,
+ 242, 140, 0, 146, 147, 156, 232, 233, 231, 0,
+ 219, 217, 236, 198, 185, 213, 187, 0, 206, 0,
+ 0, 0, 0, 236, 447, 491, 0, 0, 0, 476,
+ 472, 473, 510, 517, 519, 509, 0, 0, 338, 0,
+ 0, 0, 362, 0, 0, 335, 336, 0, 321, 105,
+ 0, 547, 0, 100, 0, 42, 0, 33, 119, 131,
+ 132, 133, 134, 0, 239, 244, 246, 0, 199, 200,
+ 225, 198, 358, 188, 214, 375, 365, 366, 372, 371,
+ 370, 0, 434, 479, 478, 0, 513, 425, 426, 0,
+ 533, 535, 534, 353, 334, 0, 331, 328, 0, 551,
+ 47, 44, 0, 116, 0, 358, 175, 0, 0, 0,
+ 410, 516, 0, 333, 0, 539, 45, 201, 176, 0,
+ 0, 374, 373, 0, 0, 332, 359, 360, 411, 536,
+ 0, 537
+};
+
+/* YYDEFGOTO[NTERM-NUM]. */
+static const yytype_int16 yydefgoto[] =
+{
+ -1, 1, 11, 93, 94, 95, 259, 12, 260, 13,
+ 18, 15, 96, 97, 147, 14, 98, 265, 693, 907,
+ 833, 834, 99, 255, 477, 478, 245, 208, 209, 426,
+ 481, 215, 293, 294, 100, 101, 272, 698, 102, 103,
+ 277, 273, 699, 700, 104, 105, 280, 106, 107, 108,
+ 109, 110, 432, 111, 112, 287, 288, 242, 275, 269,
+ 270, 113, 252, 114, 530, 295, 529, 115, 116, 302,
+ 539, 117, 118, 119, 853, 918, 305, 542, 299, 540,
+ 732, 296, 523, 524, 859, 525, 503, 710, 711, 712,
+ 355, 190, 356, 191, 192, 411, 653, 635, 193, 661,
+ 194, 195, 196, 197, 663, 811, 812, 813, 198, 199,
+ 200, 420, 415, 212, 206, 956, 957, 201, 121, 122,
+ 310, 738, 739, 927, 928, 123, 124, 125, 126, 127,
+ 202, 128, 551, 316, 222, 228, 129, 130, 131, 308,
+ 132, 133, 321, 134, 324, 559, 135, 136, 560, 561,
+ 137, 138, 580, 341, 585, 328, 235, 566, 567, 139,
+ 343, 140, 141, 344, 569, 346, 581, 582, 583, 757,
+ 386, 387, 388, 889, 225, 142, 441, 442, 443, 449,
+ 677, 451, 143, 552
+};
+
+/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing
+ STATE-NUM. */
+#define YYPACT_NINF -711
+static const yytype_int16 yypact[] =
+{
+ -711, 923, -711, -711, -711, -711, -711, -711, -711, -711,
+ -711, -711, -98, 5724, -711, -711, -711, -711, -711, -711,
+ -711, -51, -711, -47, -711, -711, 4731, 54, 2666, 70,
+ 115, -711, 4731, 34, 40, 2666, 117, -711, -63, -711,
+ 7, 4731, -711, -711, -39, 66, -63, -711, 137, -711,
+ -711, -711, -711, -711, 184, 141, 170, -711, -711, 199,
+ 199, 155, -711, 175, -711, -711, 37, -711, -711, 92,
+ -63, -63, -711, 129, -711, -711, 116, -711, -63, -711,
+ -711, -711, -711, -711, -711, -711, -711, -711, -711, -711,
+ -711, -711, -711, 217, -711, -711, 31, -711, 96, -711,
+ -64, 187, 97, 156, -711, 149, -711, 384, 390, -711,
+ -711, 395, 165, -711, -711, 91, -15, 80, 125, 372,
+ 416, -711, 253, -98, -63, -711, -63, -63, -711, 247,
+ 4731, -711, 24, 434, -711, 267, 278, 2666, -711, 270,
+ 5575, 270, -711, 2341, -711, -711, -711, -711, 4731, 4731,
+ -711, -711, 4731, 276, 279, 280, 4731, 4731, 4731, 285,
+ 291, 292, 296, 299, 301, 309, 310, 313, 316, 317,
+ 318, 4731, 319, 325, 328, 329, 330, 4859, -711, -711,
+ 331, -711, -711, -711, -711, -711, -711, -711, 4731, 2530,
+ -711, -711, 4731, 304, -711, 334, 342, -711, 343, 354,
+ -33, -711, 43, 4731, -711, 2530, -711, 356, 528, -711,
+ 4731, 2530, -711, 534, -711, 376, -711, 376, -711, 4731,
+ -711, -711, -711, -711, 4731, -711, 1494, -711, -711, -711,
+ -711, 356, -711, -711, 4987, -711, 356, 356, 376, 2588,
+ -711, 377, 356, -711, 4731, 544, -711, -711, -711, -711,
+ -711, -711, 546, -711, -711, 199, -711, -711, 5724, -711,
+ -98, -51, -51, -711, -711, -711, -711, 557, 394, 561,
+ -711, 21, 33, 144, 397, 139, 388, -711, 397, 356,
+ -711, 139, -711, 399, 402, 139, 388, 571, -711, 407,
+ 733, 575, -711, -711, -51, 572, -711, 3067, -711, 401,
+ 215, 3963, -711, 5115, -15, -711, 425, -711, 388, -711,
+ 601, -711, -711, -711, -711, 384, 356, 2530, 4731, 4731,
+ 356, -711, 429, 4091, -711, -711, -711, 5430, -711, -711,
+ -711, -711, 4731, 4731, 4731, 4731, 610, 5430, -711, 304,
+ 354, -711, 1098, 616, 588, 618, 5621, 4859, -711, 441,
+ 443, -711, -711, 1515, 670, 2530, 27, 4731, 4731, 4731,
+ 36, 1550, 45, 4731, 4731, 4731, 4731, 4731, 4731, 4731,
+ 4731, 4731, 4731, 4731, 4731, 1572, 4731, 4731, 4731, 4731,
+ 4731, 4859, 2530, 1594, 782, -711, 500, 630, 631, 4731,
+ 1615, 633, 3451, 4731, 4731, 4731, 4731, 4731, 4731, 4731,
+ 4731, 4731, 4731, 4731, 4731, 4731, 4731, 3195, 4731, 3579,
+ 3707, -711, 128, 356, 4731, -711, -711, -711, -711, -711,
+ -711, -711, 4731, 4731, -711, 1637, 48, 388, 70, 1697,
+ -711, -711, 641, 641, 1819, 1173, -711, 304, -24, -1,
+ 457, 647, -711, -711, 471, 472, 151, -1, -711, 650,
+ -711, 62, 641, -711, -711, -711, -711, -711, -711, -711,
+ -711, -711, -711, -711, -711, -711, -711, -711, -711, -711,
+ -711, -711, -711, -711, -711, -711, -711, -711, 651, 634,
+ -711, 71, 2530, 476, 488, -63, -711, -711, 480, 480,
+ -711, 4731, 72, 394, 314, 4731, -711, 491, 495, 314,
+ -711, 384, 2538, -711, -711, -711, 384, 388, 388, 384,
+ -711, 407, 571, -711, -711, 388, -711, 486, -711, -711,
+ -711, -711, -711, 358, -711, -711, -711, 480, -711, -711,
+ 497, 4219, -711, -711, 2530, -711, -711, 3963, 3323, 487,
+ 665, 4347, -711, 2530, 489, -711, 388, 23, -711, -711,
+ -711, -711, 667, 2530, 2530, -711, -711, 498, 2530, 493,
+ 672, -711, -711, -711, 5621, 3835, 75, -711, 119, -711,
+ 2530, 2530, 2530, 2530, 4731, 530, 5850, 2530, 304, 1840,
+ -711, 674, 2530, -711, 5850, -711, 5621, 5621, 5621, 5621,
+ 5621, 654, -711, 356, 356, 2666, 4731, -711, 84, 85,
+ 1879, -711, -711, -711, 1900, 1921, 1942, 1963, 2006, 2027,
+ 2145, 2209, 2230, 2251, 2272, 2293, -711, 86, 88, 89,
+ 90, 98, 2327, 678, 687, 693, 4859, -711, 4859, 4859,
+ 99, -711, 4731, 4731, 2530, -711, 710, 710, 569, 569,
+ 670, 814, 814, 814, 814, 814, 814, 133, 133, 128,
+ 4731, 4731, 2530, -711, 128, 4731, 814, 4731, 814, 304,
+ 695, 2811, 517, 520, 2530, 2530, -711, 356, -711, -711,
+ -711, -711, 532, 619, 4731, 2811, -49, 526, -711, -711,
+ -711, -49, 527, 356, -711, 2588, -711, 4731, -711, 4731,
+ -711, -711, 67, -711, 681, 2530, -711, -711, 689, 50,
+ 716, -711, 2348, 691, 538, -711, 705, 397, 4731, -711,
+ 105, -711, -711, 1384, 356, 707, 707, 407, -711, -711,
+ 287, 733, 732, -711, 568, 388, -711, 558, 4219, 665,
+ -711, 570, -711, 560, -711, -711, 738, 617, 741, -711,
+ 4731, 388, -711, -711, 4091, 536, -711, -711, 2811, 519,
+ 5430, -711, -711, 2530, 727, 106, -711, 2530, 2530, 5850,
+ 2530, 674, 574, 654, 654, 654, 406, 647, 650, -711,
+ 2530, -711, -711, -711, -711, -711, -711, -711, -711, -711,
+ -711, -711, -711, -711, -711, -711, -711, -711, -711, -711,
+ -711, -711, 5243, 5243, 5243, 2530, -711, 2530, -711, 2530,
+ -711, -711, 573, 814, 814, 128, 814, 814, 4731, 2939,
+ 1406, 745, -711, -711, 334, -711, 388, -711, -711, 2475,
+ 107, 744, -711, -711, -711, -711, -711, -711, 2530, 109,
+ -711, -711, -711, 110, -711, 577, -711, 314, 314, 314,
+ 314, 314, 354, -711, 314, -711, -711, 2530, 2538, -711,
+ 4475, -711, 5371, -711, -711, 571, -711, -711, -711, 579,
+ -711, -711, 388, 707, -711, 665, -711, 4219, -711, -50,
+ 581, 582, 1196, 388, -711, -711, 1362, 580, 356, -711,
+ -711, 588, 5891, 2530, -711, -711, 583, 584, 747, 585,
+ 590, 591, -711, 592, 4731, 1428, 4731, 2811, -711, -711,
+ 754, -711, 356, -711, 26, -711, 93, -711, -711, 29,
+ 29, 586, 113, 737, -711, -711, 2530, 4603, -711, 2530,
+ -711, 707, 64, -711, -711, 649, -711, 770, -711, -711,
+ -711, 4731, -711, -711, 457, 596, 2530, -711, -711, 4731,
+ -711, -711, -711, -711, 2530, 4731, 1471, -711, 4731, -711,
+ -711, -711, 111, -711, 597, 64, -711, 162, 609, 611,
+ 1282, -711, 1305, 2530, 4731, 2530, -711, -711, -711, 4731,
+ 4731, -711, -711, 4731, 4731, 2530, 2530, 2530, 2530, 1328,
+ 4731, 2530
+};
+
+/* YYPGOTO[NTERM-NUM]. */
+static const yytype_int16 yypgoto[] =
+{
+ -711, -711, -711, -711, 523, -711, 30, -711, 774, -711,
+ -66, 772, -711, -711, 65, 6, -711, -711, -430, -711,
+ -118, -110, -711, -711, 123, -711, -711, -711, 373, -711,
+ 120, 1, -711, -711, -711, -711, -711, -480, -711, -711,
+ -264, 312, -439, -711, -711, -711, -711, -711, -711, -711,
+ -711, -711, -68, -711, -711, -276, 300, -35, -85, 548,
+ 324, -711, -711, -711, 274, -711, -711, -711, -711, -711,
+ 281, -711, -711, -711, -699, -711, -711, -711, 515, -290,
+ -666, -711, -711, 100, -711, 749, -104, -711, -25, -17,
+ -26, -136, 56, -176, -432, -497, -711, -711, -103, -711,
+ -711, -711, -204, -711, 404, 159, -57, 95, -5, -70,
+ -711, -711, -197, -398, -30, -108, -711, -166, -711, -711,
+ -711, -711, -23, -711, -105, -711, -711, -711, -711, -711,
+ -711, -711, -711, -711, -28, -711, -711, -711, 708, 302,
+ -208, -711, -711, -711, -711, -711, -711, -711, -711, 118,
+ -711, -711, -711, -711, -711, 277, -711, -711, 114, -711,
+ -711, -711, -711, -306, 720, -263, -226, -711, -673, -554,
+ 514, 482, -326, -710, 308, -711, 273, -202, -711, 275,
+ -416, -711, -711, -711
+};
+
+/* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If
+ positive, shift that token. If negative, reduce the rule which
+ number is the opposite. If zero, do what YYDEFACT says.
+ If YYTABLE_NINF, syntax error. */
+#define YYTABLE_NINF -511
+static const yytype_int16 yytable[] =
+{
+ 189, 384, 205, 421, 338, 218, 211, 533, 120, 205,
+ 500, 385, 391, 512, 504, 226, 660, 854, 230, 706,
+ 281, 568, 283, 440, 145, 758, 285, 438, 760, 318,
+ 596, 575, 438, 682, 448, 217, 282, 339, 213, 596,
+ 591, 383, 249, 250, 213, 494, 422, 423, 596, 830,
+ 257, 667, 840, 837, 736, 625, 243, 311, 445, 694,
+ 238, 239, 701, 866, 261, 683, 262, 701, 278, -361,
+ 340, 838, 839, 840, 687, 493, 821, 289, 750, 17,
+ 756, 590, 756, 890, 891, 756, 885, 596, 596, 596,
+ 830, 596, 596, 596, 290, 291, 312, 723, 313, 314,
+ 274, 596, 596, 300, 317, 267, 220, 326, 848, 882,
+ 897, 205, 687, 904, 904, 268, 830, -164, 146, 925,
+ 91, -164, 353, 354, 221, 419, 292, 263, 437, 266,
+ 227, 361, 148, 437, 838, 839, 840, 926, 351, 586,
+ 329, 330, 587, 588, 589, 375, 414, 498, 303, 433,
+ 319, 382, 279, 408, 297, 416, 406, 407, 408, 240,
+ 246, 298, 390, 241, 922, -315, 412, 969, 499, -164,
+ 452, 384, 935, -164, 247, 240, 240, 425, 675, 241,
+ 241, 385, 510, 223, 429, 240, 224, 497, -314, 241,
+ -361, 338, 737, 434, 487, 831, 253, 254, 435, 923,
+ 495, 338, 427, 213, 546, 623, 577, 597, 382, 885,
+ 338, 383, 360, 320, 362, 385, 601, 841, 482, 248,
+ 496, 214, 955, 424, 339, 603, 439, 216, 668, 446,
+ 549, 447, 450, 203, 339, 229, 831, 480, 841, 578,
+ 501, 726, 684, 339, 258, 383, 506, 832, 729, 207,
+ 509, 688, 696, 120, 264, 751, 485, 340, 745, 301,
+ 884, 884, 831, 884, 771, 772, 786, 340, 787, 788,
+ 789, 534, 579, 951, 505, 534, 340, 543, 790, 801,
+ 762, 763, 764, 765, 766, 849, 883, 901, 970, 903,
+ 905, 966, 553, 554, 210, 490, 219, 558, 251, 752,
+ 796, 841, 798, 800, 304, 590, 570, 571, 572, 573,
+ 659, 550, 590, 409, 410, 555, 231, 548, 409, 410,
+ 236, 382, 565, 669, 91, 276, 488, 489, 590, 936,
+ 417, 680, 565, 600, 286, 150, 151, 604, 605, 606,
+ 607, 608, 609, 610, 611, 612, 613, 614, 615, 237,
+ 755, 886, 887, 232, 244, 622, 271, 908, 761, 527,
+ 233, 721, 722, 234, 913, 391, 634, 636, 637, 638,
+ 639, 640, 641, 642, 643, 644, 645, 646, 647, 648,
+ 649, 652, 654, 656, 658, 440, 756, 282, 211, 438,
+ 438, 536, 448, 284, 537, 306, 664, 665, 282, 909,
+ 910, 911, 912, 715, 716, 701, 701, 701, 701, 701,
+ 893, 719, 701, 598, 599, -164, 707, 342, 347, -164,
+ 307, 714, 309, 315, 717, 856, 857, 858, 338, 587,
+ 588, 589, 617, 618, 619, 620, 621, 322, 865, 884,
+ 577, 855, 735, 846, 881, 630, 323, 325, 577, 327,
+ 338, 338, 338, 338, 338, 357, 802, 691, 358, 359,
+ 385, 339, 385, 385, 363, 695, 796, 798, 800, 702,
+ 364, 365, 438, 578, 822, 366, 713, 438, 367, 824,
+ 368, 578, 590, 339, 339, 339, 339, 339, 369, 370,
+ 437, 437, 371, 413, 340, 372, 373, 374, 376, 590,
+ 590, 590, 590, 590, 377, 534, 579, 378, 379, 380,
+ 389, 534, 534, 414, 579, 390, 340, 340, 340, 340,
+ 340, 416, 417, 418, 392, 91, 393, 394, 395, 396,
+ 397, 428, 398, 399, 400, 401, 402, 403, 430, 749,
+ 404, 405, 406, 407, 408, 431, 479, 483, 753, 484,
+ 586, 329, 330, 587, 588, 589, 586, 329, 330, 587,
+ 588, 589, 491, 267, 493, 769, 276, 502, 507, 205,
+ 770, 508, 391, 437, 511, 528, 286, 924, 437, 526,
+ 397, 535, 398, 399, 400, 401, 402, 403, 439, 447,
+ 404, 405, 406, 407, 408, 329, 330, 587, 588, 589,
+ 795, 545, 797, 799, 547, 556, 382, 803, 586, 329,
+ 330, 587, 588, 589, 338, 574, 802, 898, 590, 584,
+ 593, 863, 594, 577, 804, 805, 385, 385, 385, 806,
+ 842, 807, 627, 628, 629, 810, 632, 873, -490, -490,
+ -490, -490, -490, -490, 672, 879, 320, 339, 819, 810,
+ 676, 678, 679, 681, 685, 689, 578, 690, 686, 692,
+ 703, 828, 816, 482, 704, 720, 725, 730, 731, 734,
+ 934, 447, 740, 743, 223, 744, 447, 759, 826, 589,
+ 340, 792, 847, 398, 399, 400, 401, 402, 403, 579,
+ 793, 404, 405, 406, 407, 408, 794, 814, 502, 808,
+ 815, 817, 534, 818, 409, 410, 823, 825, 878, 851,
+ 754, 835, 899, 836, 872, 844, 875, 495, 558, 395,
+ 396, 397, 876, 398, 399, 400, 401, 402, 403, 845,
+ 852, 404, 405, 406, 407, 408, 861, 862, 864, 867,
+ 868, 391, 869, 870, 871, 565, 577, -491, 897, 902,
+ 929, 737, 939, 892, 409, 410, 906, 948, 921, 920,
+ 933, 953, 513, 937, 938, 940, 795, 797, 799, 932,
+ 941, 942, 943, 959, 841, 958, 961, 967, 971, 578,
+ 925, 486, 211, 895, 16, 626, 144, -247, 952, -247,
+ -247, -247, -247, -247, 950, -247, -247, -247, -247, -247,
+ -247, 670, 724, -247, -247, -247, -247, -247, 827, 829,
+ 705, 718, 579, 253, 254, 514, 492, 697, 727, 544,
+ 662, 860, 713, 914, 916, 256, 919, -511, -511, -511,
+ -511, -511, -511, 915, 820, 404, 405, 406, 407, 408,
+ 947, 534, 515, 877, 516, 517, 518, 968, 930, 519,
+ 520, 352, 521, 522, 972, 409, 410, 741, 178, 179,
+ 345, 592, 874, 624, 880, 742, 767, 0, 944, 768,
+ 946, 810, 0, 351, 181, 182, 0, 0, 183, 184,
+ 185, 186, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 390, 187, 0, 0, 409, 410, 949, 0, 0,
+ 0, 0, 0, 0, 0, 960, 0, 0, 0, 0,
+ 0, 0, 0, 962, 0, 0, 0, 0, 0, 963,
+ 0, 0, 965, 2, 3, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 975, 0,
+ 0, 0, 0, 976, 977, 0, 0, 978, 979, 0,
+ -23, 0, -23, 0, 981, -23, -23, -23, -23, 4,
+ 5, -23, 0, 0, -23, -23, -23, -247, -247, 0,
+ 0, -23, -23, 0, 0, 0, 6, 7, 0, 0,
+ 0, 0, 0, 0, 0, 0, -23, 0, 0, 0,
+ -23, -23, 0, 0, 0, -23, 0, 0, 0, 409,
+ 410, -23, 0, -23, -23, 0, -23, 0, -23, -23,
+ -23, -23, -23, 0, -23, -23, -23, -23, -23, -23,
+ -23, -23, -23, -23, -23, -23, -23, -23, -23, -23,
+ 0, 0, -23, -23, -23, 0, -23, -23, -23, 0,
+ -23, -23, -23, 0, 0, -23, 0, -23, 0, 0,
+ -23, -23, -23, -23, 0, 0, -23, -23, -23, 0,
+ 0, 0, 0, 0, -23, 0, 0, 8, -23, -23,
+ -23, -23, -23, -23, -23, 0, -23, -23, -23, -23,
+ -23, 0, 0, -23, 0, 0, 0, 0, 0, 0,
+ -23, -23, -23, 0, 0, 0, 0, 0, 0, -23,
+ 9, -510, 0, -510, 0, -510, -510, -510, -510, -510,
+ 10, -510, -510, -510, -510, -510, -510, 0, 0, -510,
+ -510, -510, -510, -510, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 152, 153, 0,
+ 0, 0, 154, 155, 156, 157, 0, 0, 0, 0,
+ 0, 0, 0, 0, 158, 159, 160, 161, 162, 163,
+ 164, 0, 165, 166, 167, 0, 0, 168, 169, 170,
+ 0, 171, 172, 173, 174, 175, 674, 176, 392, 0,
+ 393, 394, 395, 396, 397, 0, 398, 399, 400, 401,
+ 402, 403, 0, 0, 404, 405, 406, 407, 408, 931,
+ 0, 392, 0, 393, 394, 395, 396, 397, 0, 398,
+ 399, 400, 401, 402, 403, 0, 0, 404, 405, 406,
+ 407, 408, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 178, 179, 0, 0, 0, 0, 180, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 181, 182, 0, 0,
+ 183, 184, 185, 186, 0, 0, 0, 91, 0, 0,
+ 0, 0, 0, 0, 187, 0, 0, 576, 0, 0,
+ 0, 0, 0, -510, -510, 973, 0, 392, 0, 393,
+ 394, 395, 396, 397, 0, 398, 399, 400, 401, 402,
+ 403, 0, 0, 404, 405, 406, 407, 408, 974, 0,
+ 392, 0, 393, 394, 395, 396, 397, 0, 398, 399,
+ 400, 401, 402, 403, 0, 0, 404, 405, 406, 407,
+ 408, 980, 0, 392, 0, 393, 394, 395, 396, 397,
+ 0, 398, 399, 400, 401, 402, 403, 0, 0, 404,
+ 405, 406, 407, 408, 0, 0, 0, 0, 409, 410,
+ 0, 0, 0, 0, 0, 0, 896, 392, 0, 393,
+ 394, 395, 396, 397, 0, 398, 399, 400, 401, 402,
+ 403, 409, 410, 404, 405, 406, 407, 408, 850, 392,
+ 0, 393, 394, 395, 396, 397, 0, 398, 399, 400,
+ 401, 402, 403, 0, 0, 404, 405, 406, 407, 408,
+ 896, 392, 0, 393, 394, 395, 396, 397, 0, 398,
+ 399, 400, 401, 402, 403, 0, 0, 404, 405, 406,
+ 407, 408, 945, 392, 0, 393, 394, 395, 396, 397,
+ 0, 398, 399, 400, 401, 402, 403, 0, 0, 404,
+ 405, 406, 407, 408, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 409, 410, 0,
+ 0, 0, 0, 0, 0, 964, 392, 0, 393, 394,
+ 395, 396, 397, 0, 398, 399, 400, 401, 402, 403,
+ 409, 410, 404, 405, 406, 407, 408, 0, 0, 392,
+ 0, 393, 394, 395, 396, 397, 0, 398, 399, 400,
+ 401, 402, 403, 409, 410, 404, 405, 406, 407, 408,
+ 392, 0, 393, 394, 395, 396, 397, 0, 398, 399,
+ 400, 401, 402, 403, 0, 0, 404, 405, 406, 407,
+ 408, 0, 631, 0, 0, 0, 0, 409, 410, 0,
+ 0, 0, 0, 0, 0, 392, 0, 393, 394, 395,
+ 396, 397, 0, 398, 399, 400, 401, 402, 403, 409,
+ 410, 404, 405, 406, 407, 408, 0, 392, 0, 393,
+ 394, 395, 396, 397, 0, 398, 399, 400, 401, 402,
+ 403, 409, 410, 404, 405, 406, 407, 408, 0, -250,
+ 0, -250, -250, -250, -250, -250, 0, -250, -250, -250,
+ -250, -250, -250, 409, 410, -250, -250, -250, -250, -250,
+ 392, 0, 393, 394, 395, 396, 397, 0, 398, 399,
+ 400, 401, 402, 403, 0, 0, 404, 405, 406, 407,
+ 408, 0, 392, 0, 393, 394, 395, 396, 397, 0,
+ 398, 399, 400, 401, 402, 403, 409, 410, 404, 405,
+ 406, 407, 408, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 436, 0, 0, 0, 0, 409,
+ 410, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 595, 0, 0, 0, 0,
+ 409, 410, 392, 0, 393, 394, 395, 396, 397, 0,
+ 398, 399, 400, 401, 402, 403, 0, 0, 404, 405,
+ 406, 407, 408, 0, 0, 0, 0, 0, 0, 0,
+ 602, 0, 0, 0, 0, 409, 410, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 616, 0, 0, 0, 0, 409, 410, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, -250, 0, 0, 0, 0, -250,
+ -250, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 631, 0, 0, 0, 0,
+ 409, 410, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 666, 0, 0,
+ 0, 0, 409, 410, 392, 0, 393, 394, 395, 396,
+ 397, 0, 398, 399, 400, 401, 402, 403, 0, 0,
+ 404, 405, 406, 407, 408, 392, 0, 393, 394, 395,
+ 396, 397, 0, 398, 399, 400, 401, 402, 403, 0,
+ 0, 404, 405, 406, 407, 408, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 671, 0, 0,
+ 0, 0, 409, 410, 392, 0, 393, 394, 395, 396,
+ 397, 0, 398, 399, 400, 401, 402, 403, 0, 0,
+ 404, 405, 406, 407, 408, 392, 0, 393, 394, 395,
+ 396, 397, 0, 398, 399, 400, 401, 402, 403, 0,
+ 0, 404, 405, 406, 407, 408, 392, 0, 393, 394,
+ 395, 396, 397, 0, 398, 399, 400, 401, 402, 403,
+ 0, 0, 404, 405, 406, 407, 408, 392, 0, 393,
+ 394, 395, 396, 397, 0, 398, 399, 400, 401, 402,
+ 403, 0, 0, 404, 405, 406, 407, 408, 392, 0,
+ 393, 394, 395, 396, 397, 0, 398, 399, 400, 401,
+ 402, 403, 0, 0, 404, 405, 406, 407, 408, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 673,
+ 0, 0, 0, 0, 409, 410, 0, 0, 0, 418,
+ 0, 392, 0, 393, 394, 395, 396, 397, 0, 398,
+ 399, 400, 401, 402, 403, 409, 410, 404, 405, 406,
+ 407, 408, 392, 0, 393, 394, 395, 396, 397, 0,
+ 398, 399, 400, 401, 402, 403, 0, 0, 404, 405,
+ 406, 407, 408, 0, 0, 0, 0, 0, 0, 773,
+ 0, 0, 0, 0, 409, 410, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 774, 0, 0, 0, 0, 409, 410, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 775, 0, 0, 0, 0, 409, 410, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 776, 0, 0, 0, 0, 409, 410, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 777, 0, 0, 0, 0, 409, 410,
+ 392, 0, 393, 394, 395, 396, 397, 0, 398, 399,
+ 400, 401, 402, 403, 0, 0, 404, 405, 406, 407,
+ 408, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 778, 0, 0, 0,
+ 0, 409, 410, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 779, 0, 0,
+ 0, 0, 409, 410, 392, 0, 393, 394, 395, 396,
+ 397, 0, 398, 399, 400, 401, 402, 403, 0, 0,
+ 404, 405, 406, 407, 408, 392, 0, 393, 394, 395,
+ 396, 397, 0, 398, 399, 400, 401, 402, 403, 0,
+ 0, 404, 405, 406, 407, 408, 392, 0, 393, 394,
+ 395, 396, 397, 0, 398, 399, 400, 401, 402, 403,
+ 0, 0, 404, 405, 406, 407, 408, 392, 0, 393,
+ 394, 395, 396, 397, 0, 398, 399, 400, 401, 402,
+ 403, 0, 0, 404, 405, 406, 407, 408, 392, 0,
+ 393, 394, 395, 396, 397, 0, 398, 399, 400, 401,
+ 402, 403, 0, 0, 404, 405, 406, 407, 408, 0,
+ 0, 0, 0, 0, 0, 780, 0, 0, 0, 0,
+ 409, 410, 392, 0, 393, 394, 395, 396, 397, 0,
+ 398, 399, 400, 401, 402, 403, 0, 0, 404, 405,
+ 406, 407, 408, 392, 0, 393, 394, 395, 396, 397,
+ 0, 398, 399, 400, 401, 402, 403, 0, 0, 404,
+ 405, 406, 407, 408, 0, 0, 0, 0, 0, 22,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 781,
+ 0, 0, 0, 0, 409, 410, 0, 0, 0, 0,
+ 0, 0, 0, 0, 28, 0, 0, 0, 0, 0,
+ 782, 0, 0, 0, 0, 409, 410, 0, 0, 32,
+ 0, 0, 0, 0, 35, 348, 0, 0, 0, 39,
+ 40, 783, 0, 0, 0, 0, 409, 410, 0, 349,
+ 49, 50, 51, 52, 53, 54, 350, 0, 0, 0,
+ 0, 0, 784, 0, 0, 0, 0, 409, 410, 64,
+ 0, 0, 0, 0, 0, 67, 0, 0, 0, 0,
+ 0, 0, 0, 785, 72, 0, 74, 0, 409, 410,
+ 392, 0, 393, 394, 395, 396, 397, 0, 398, 399,
+ 400, 401, 402, 403, 0, 0, 404, 405, 406, 407,
+ 408, 0, 0, 0, 0, 0, 0, 791, 0, 0,
+ 91, 0, 409, 410, 0, 0, 0, 92, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 843, 0,
+ 0, 0, 0, 409, 410, 392, 0, 393, 394, 395,
+ 396, 397, 708, 398, 399, 400, 401, 402, 403, 0,
+ 149, 404, 405, 406, 407, 408, 0, 0, 0, 150,
+ 151, 709, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 152, 153, 0,
+ 0, 0, 154, 155, 156, 157, 0, 0, 0, 0,
+ 0, 0, 0, 0, 158, 159, 160, 161, 162, 163,
+ 164, 0, 165, 166, 167, 0, 0, 168, 169, 170,
+ 0, 171, 172, 173, 174, 175, 0, 176, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 453, 0,
+ 0, 0, 454, 455, 456, 457, 0, 0, 0, 0,
+ 0, 0, 0, 0, 458, 459, 460, 461, 462, 463,
+ 464, 0, 465, 466, 467, 900, 0, 468, 469, 470,
+ 409, 410, 471, 472, 473, 474, 0, 475, 0, 177,
+ 0, 0, 0, 0, 0, 0, 0, 0, 149, 0,
+ 178, 179, 0, 0, 0, 0, 180, 150, 151, 0,
+ 0, 0, 0, 0, 0, 0, 181, 182, 0, 0,
+ 183, 184, 185, 186, 0, 152, 153, 91, 0, 0,
+ 154, 155, 156, 157, 187, 409, 410, 188, 0, 0,
+ 0, 0, 158, 159, 160, 161, 162, 163, 164, 0,
+ 165, 166, 167, 0, 0, 168, 169, 170, 0, 171,
+ 172, 173, 174, 175, 0, 176, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 476, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 177, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 178, 179,
+ 0, 0, 0, 0, 180, 809, 0, 0, 0, 0,
+ 0, 0, 0, 149, 181, 182, 0, 0, 183, 184,
+ 185, 186, 150, 151, 0, 91, 0, 0, 0, 0,
+ 0, 0, 187, 0, 0, 188, 0, 0, 0, 0,
+ 152, 153, 0, 204, 0, 154, 155, 156, 157, 0,
+ 0, 0, 0, 0, 0, 0, 0, 158, 159, 160,
+ 161, 162, 163, 164, 0, 165, 166, 167, 0, 0,
+ 168, 169, 170, 0, 171, 172, 173, 174, 175, 0,
+ 176, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 177, 894, 0, 0, 0, 0, 0, 0,
+ 0, 149, 0, 178, 179, 0, 0, 0, 0, 180,
+ 150, 151, 0, 0, 0, 0, 0, 0, 0, 181,
+ 182, 0, 0, 183, 184, 185, 186, 0, 152, 153,
+ 91, 0, 0, 154, 155, 156, 157, 187, 0, 0,
+ 188, 0, 0, 0, 0, 158, 159, 160, 161, 162,
+ 163, 164, 0, 165, 166, 167, 0, 0, 168, 169,
+ 170, 0, 171, 172, 173, 174, 175, 0, 176, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 177, 0, 531, 0, 0, 0, 0, 0, 0, 149,
+ 0, 178, 179, 0, 0, 0, 0, 180, 150, 151,
+ 532, 0, 0, 0, 0, 0, 0, 181, 182, 0,
+ 0, 183, 184, 185, 186, 0, 152, 153, 91, 0,
+ 0, 154, 155, 156, 157, 187, 0, 0, 188, 0,
+ 0, 0, 0, 158, 159, 160, 161, 162, 163, 164,
+ 0, 165, 166, 167, 0, 0, 168, 169, 170, 0,
+ 171, 172, 173, 174, 175, 0, 176, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 177, 0,
+ 650, 0, 0, 0, 0, 0, 0, 149, 0, 178,
+ 179, 0, 0, 0, 0, 180, 150, 151, 0, 651,
+ 0, 0, 0, 0, 0, 181, 182, 0, 0, 183,
+ 184, 185, 186, 0, 152, 153, 91, 0, 0, 154,
+ 155, 156, 157, 187, 0, 0, 188, 0, 0, 0,
+ 0, 158, 159, 160, 161, 162, 163, 164, 0, 165,
+ 166, 167, 0, 0, 168, 169, 170, 0, 171, 172,
+ 173, 174, 175, 0, 176, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 177, 0, 728, 0,
+ 0, 0, 0, 0, 0, 149, 0, 178, 179, 0,
+ 0, 0, 0, 180, 150, 151, 532, 0, 0, 0,
+ 0, 0, 0, 181, 182, 0, 0, 183, 184, 185,
+ 186, 0, 152, 153, 91, 0, 0, 154, 155, 156,
+ 157, 187, 0, 0, 188, 0, 0, 0, 0, 158,
+ 159, 160, 161, 162, 163, 164, 0, 165, 166, 167,
+ 0, 0, 168, 169, 170, 0, 171, 172, 173, 174,
+ 175, 0, 176, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 177, 0, 633, 0, 0, 0,
+ 0, 0, 0, 149, 0, 178, 179, 0, 0, 0,
+ 0, 180, 150, 151, 0, 0, 0, 0, 0, 0,
+ 0, 181, 182, 0, 0, 183, 184, 185, 186, 0,
+ 152, 153, 91, 0, 0, 154, 155, 156, 157, 187,
+ 0, 0, 188, 0, 0, 0, 0, 158, 159, 160,
+ 161, 162, 163, 164, 0, 165, 166, 167, 0, 0,
+ 168, 169, 170, 0, 171, 172, 173, 174, 175, 0,
+ 176, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 177, 0, 655, 0, 0, 0, 0, 0,
+ 0, 149, 0, 178, 179, 0, 0, 0, 0, 180,
+ 150, 151, 0, 0, 0, 0, 0, 0, 0, 181,
+ 182, 0, 0, 183, 184, 185, 186, 0, 152, 153,
+ 91, 0, 0, 154, 155, 156, 157, 187, 0, 0,
+ 188, 0, 0, 0, 0, 158, 159, 160, 161, 162,
+ 163, 164, 0, 165, 166, 167, 0, 0, 168, 169,
+ 170, 0, 171, 172, 173, 174, 175, 0, 176, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 177, 0, 657, 0, 0, 0, 0, 0, 0, 149,
+ 0, 178, 179, 0, 0, 0, 0, 180, 150, 151,
+ 0, 0, 0, 0, 0, 0, 0, 181, 182, 0,
+ 0, 183, 184, 185, 186, 0, 152, 153, 91, 0,
+ 0, 154, 155, 156, 157, 187, 0, 0, 188, 0,
+ 0, 0, 0, 158, 159, 160, 161, 162, 163, 164,
+ 0, 165, 166, 167, 0, 0, 168, 169, 170, 0,
+ 171, 172, 173, 174, 175, 0, 176, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 177, 0,
+ 0, 0, 0, 0, 0, 0, 0, 149, 0, 178,
+ 179, 0, 0, 0, 0, 180, 150, 151, 746, 0,
+ 747, 0, 0, 0, 0, 181, 182, 0, 0, 183,
+ 184, 185, 186, 0, 152, 153, 91, 0, 0, 154,
+ 155, 156, 157, 187, 0, 0, 188, 0, 0, 0,
+ 0, 158, 159, 160, 161, 162, 163, 164, 0, 165,
+ 166, 167, 0, 0, 168, 169, 170, 0, 171, 172,
+ 173, 174, 175, 0, 176, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 177, 0, 0, 0,
+ 0, 0, 0, 0, 0, 149, 0, 178, 179, 0,
+ 0, 0, 0, 180, 150, 151, 532, 0, 0, 0,
+ 0, 0, 0, 181, 182, 0, 0, 183, 184, 185,
+ 186, 0, 152, 153, 91, 0, 0, 154, 155, 156,
+ 157, 187, 0, 0, 748, 0, 0, 0, 0, 158,
+ 159, 160, 161, 162, 163, 164, 0, 165, 166, 167,
+ 0, 0, 168, 169, 170, 0, 171, 172, 173, 174,
+ 175, 0, 176, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 177, 0, 0, 0, 0, 0,
+ 0, 0, 0, 149, 0, 178, 179, 0, 0, 0,
+ 0, 180, 150, 151, 557, 0, 0, 0, 0, 0,
+ 0, 181, 182, 0, 0, 183, 184, 185, 186, 0,
+ 152, 153, 538, 0, 0, 154, 155, 156, 157, 187,
+ 0, 0, 188, 0, 0, 0, 0, 158, 159, 160,
+ 161, 162, 163, 164, 0, 165, 166, 167, 0, 0,
+ 168, 169, 170, 0, 171, 172, 173, 174, 175, 0,
+ 176, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 177, 0, 0, 0, 0, 0, 0, 0,
+ 0, 149, 0, 178, 179, 0, 0, 0, 0, 180,
+ 150, 151, 532, 0, 0, 0, 0, 0, 0, 181,
+ 182, 0, 0, 183, 184, 185, 186, 0, 152, 153,
+ 91, 0, 0, 154, 155, 156, 157, 187, 0, 0,
+ 188, 0, 0, 0, 0, 158, 159, 160, 161, 162,
+ 163, 164, 0, 165, 166, 167, 0, 0, 168, 169,
+ 170, 0, 171, 172, 173, 174, 175, 0, 176, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 177, 0, 0, 0, 0, 0, 0, 0, 0, 149,
+ 0, 178, 179, 0, 0, 0, 0, 180, 150, 151,
+ 733, 0, 0, 0, 0, 0, 0, 181, 182, 0,
+ 0, 183, 184, 185, 186, 0, 152, 153, 91, 0,
+ 0, 154, 155, 156, 157, 187, 0, 0, 188, 0,
+ 0, 0, 0, 158, 159, 160, 161, 162, 163, 164,
+ 0, 165, 166, 167, 0, 0, 168, 169, 170, 0,
+ 171, 172, 173, 174, 175, 0, 176, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 177, 0,
+ 0, 0, 0, 0, 0, 0, 0, 149, 0, 178,
+ 179, 0, 0, 0, 0, 180, 150, 151, 709, 0,
+ 0, 0, 0, 0, 0, 181, 182, 0, 0, 183,
+ 184, 185, 186, 0, 152, 153, 91, 0, 0, 154,
+ 155, 156, 157, 187, 0, 0, 188, 0, 0, 0,
+ 0, 158, 159, 160, 161, 162, 163, 164, 0, 165,
+ 166, 167, 0, 0, 168, 169, 170, 0, 171, 172,
+ 173, 174, 175, 0, 176, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 177, 0, 0, 0,
+ 0, 0, 0, 0, 0, 149, 0, 178, 179, 0,
+ 0, 0, 0, 180, 150, 151, 954, 0, 0, 0,
+ 0, 0, 0, 181, 182, 0, 0, 183, 184, 185,
+ 186, 0, 152, 153, 91, 0, 0, 154, 155, 156,
+ 157, 187, 0, 0, 188, 0, 0, 0, 0, 158,
+ 159, 160, 161, 162, 163, 164, 0, 165, 166, 167,
+ 0, 0, 168, 169, 170, 0, 171, 172, 173, 174,
+ 175, 0, 176, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 177, 0, 0, 0, 0, 0,
+ 0, 0, 0, 149, 0, 178, 179, 0, 0, 0,
+ 0, 180, 150, 151, 0, 0, 0, 0, 0, 0,
+ 0, 181, 182, 0, 0, 183, 184, 185, 186, 0,
+ 152, 153, 91, 0, 0, 154, 155, 156, 157, 187,
+ 0, 0, 188, 0, 0, 0, 0, 158, 159, 160,
+ 161, 162, 163, 164, 0, 165, 166, 167, 0, 0,
+ 168, 169, 170, 0, 171, 172, 173, 174, 175, 0,
+ 176, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 177, 0, 0, 0, 0, 0, 0, 0,
+ 0, 149, 0, 178, 179, 0, 0, 0, 0, 180,
+ 150, 151, 0, 0, 0, 0, 0, 0, 0, 181,
+ 182, 0, 0, 183, 184, 185, 186, 0, 152, 153,
+ 91, 0, 0, 154, 155, 156, 157, 187, 0, 0,
+ 188, 0, 0, 0, 0, 158, 159, 160, 161, 162,
+ 163, 164, 0, 165, 166, 167, 0, 0, 168, 169,
+ 170, 0, 171, 172, 173, 174, 175, 0, 176, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 177, 0, 0, 0, 0, 0, 0, 0, 0, 149,
+ 0, 178, 179, 0, 0, 0, 0, 180, 150, 151,
+ 0, 0, 0, 0, 0, 0, 0, 181, 182, 0,
+ 0, 183, 184, 185, 186, 0, 152, 153, 91, 0,
+ 0, 154, 155, 156, 157, 187, 0, 0, 381, 0,
+ 0, 0, 0, 158, 159, 160, 161, 162, 163, 164,
+ 0, 165, 166, 167, 0, 0, 168, 169, 170, 0,
+ 171, 172, 173, 174, 175, 0, 176, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 177, 0,
+ 0, 0, 0, 0, 0, 0, 0, 149, 0, 178,
+ 179, 0, 0, 0, 0, 180, 150, 151, 0, 0,
+ 0, 0, 0, 0, 0, 181, 182, 0, 0, 183,
+ 184, 185, 186, 0, 152, 153, 91, 0, 0, 154,
+ 155, 156, 157, 444, 0, 0, 188, 0, 0, 0,
+ 0, 158, 159, 160, 161, 162, 163, 164, 0, 165,
+ 166, 167, 0, 0, 168, 169, 170, 0, 171, 172,
+ 173, 174, 175, 0, 176, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 177, 0, 0, 0,
+ 0, 0, 0, 0, 0, 149, 0, 178, 179, 0,
+ 0, 0, 0, 180, 150, 151, 0, 0, 0, 0,
+ 0, 0, 0, 181, 182, 0, 0, 183, 184, 185,
+ 186, 0, 152, 153, 91, 0, 0, 154, 155, 156,
+ 157, 187, 0, 0, 541, 0, 0, 0, 0, 158,
+ 159, 160, 161, 162, 163, 164, 0, 165, 166, 167,
+ 0, 0, 168, 169, 170, 0, 171, 172, 173, 174,
+ 175, 0, 176, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 177, 0, 0, 0, 0, 0,
+ 0, 0, 0, 149, 0, 178, 179, 0, 0, 0,
+ 0, 180, 150, 151, 0, 0, 0, 0, 0, 0,
+ 0, 181, 182, 0, 0, 183, 184, 185, 186, 0,
+ 152, 153, 888, 0, 0, 154, 155, 156, 157, 187,
+ 0, 0, 381, 0, 0, 0, 0, 158, 159, 160,
+ 161, 162, 163, 164, 0, 165, 166, 167, 0, 0,
+ 168, 169, 170, 0, 171, 172, 173, 174, 175, 0,
+ 176, 329, 330, 562, 0, 563, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 152,
+ 153, 0, 0, 0, 154, 155, 156, 157, 0, 0,
+ 332, 333, 334, 0, 0, 335, 158, 159, 160, 161,
+ 162, 163, 164, 0, 165, 166, 167, 0, 0, 168,
+ 169, 170, 177, 171, 172, 173, 174, 175, 0, 176,
+ 0, 0, 0, 178, 179, 0, 0, 0, 0, 180,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 181,
+ 182, 0, 0, 183, 184, 185, 186, 0, 0, 0,
+ 91, 0, 0, 0, 0, 0, 0, 187, 0, 0,
+ 917, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 178, 179, 0, 0, 0, 0, 180, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 181, 182,
+ 0, 0, 183, 184, 185, 186, 329, 330, 331, 336,
+ 0, 0, 0, 0, 0, 0, 187, 0, 0, 564,
+ 0, 0, 0, 0, 152, 153, 0, 0, 0, 154,
+ 155, 156, 157, 0, 0, 332, 333, 334, 0, 0,
+ 335, 158, 159, 160, 161, 162, 163, 164, 0, 165,
+ 166, 167, 329, 330, 168, 169, 170, 0, 171, 172,
+ 173, 174, 175, 0, 176, 0, 0, 0, 0, 0,
+ 152, 153, 0, 0, 0, 154, 155, 156, 157, 0,
+ 0, 332, 333, 334, 0, 0, 335, 158, 159, 160,
+ 161, 162, 163, 164, 0, 165, 166, 167, 0, 0,
+ 168, 169, 170, 0, 171, 172, 173, 174, 175, 0,
+ 176, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 178, 179, 0,
+ 0, 0, 0, 180, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 181, 182, 0, 0, 183, 184, 185,
+ 186, 0, 0, 0, 336, 0, 0, 0, 0, 0,
+ 0, 187, 0, 19, 337, 0, 20, -28, 21, -28,
+ 0, 0, 22, 178, 179, 23, 24, 25, 0, 180,
+ 0, 0, 26, 27, 0, 0, 0, 0, 0, 181,
+ 182, 0, 0, 183, 184, 185, 186, 28, 0, 0,
+ 336, 29, 30, 0, 0, 0, 31, 187, 0, 0,
+ 564, 0, 32, 0, 33, 34, 0, 35, 0, 36,
+ 37, 38, 39, 40, 0, 41, 42, 43, 44, 45,
+ 46, 47, 48, 49, 50, 51, 52, 53, 54, 55,
+ 56, 0, 0, 57, 58, 59, 0, 60, 61, 62,
+ 0, 63, 64, 65, 0, 0, 66, 0, 67, 0,
+ 0, 68, 69, 70, 71, 0, 0, 72, 73, 74,
+ 0, 0, 0, 0, 0, 75, 0, 0, 0, 76,
+ 77, 78, 79, 80, 81, 82, 0, 83, 84, 85,
+ 86, 87, 0, 0, 88, 0, 0, 0, 0, 152,
+ 153, 89, 90, 91, 154, 155, 156, 157, 0, 0,
+ 92, 0, 0, 0, 0, 0, 158, 159, 160, 161,
+ 162, 163, 164, 0, 165, 166, 167, 0, 0, 168,
+ 169, 170, 0, 171, 172, 173, 174, 175, 0, 176,
+ 152, 153, 0, 0, 0, 154, 155, 156, 157, 0,
+ 0, 0, 0, 0, 0, 0, 0, 158, 159, 160,
+ 161, 162, 163, 164, 0, 165, 166, 167, 0, 0,
+ 168, 169, 170, 0, 171, 172, 173, 174, 175, 0,
+ 176, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 178, 179, 0, 0, 0, 0, 180, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 181, 182,
+ 0, 0, 183, 184, 185, 186, 0, 0, 0, 91,
+ 0, 0, 0, 0, 0, 0, 187, 0, 0, 576,
+ 0, 0, 0, 178, 179, 0, 0, 0, 0, 180,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 181,
+ 182, 0, 0, 183, 184, 185, 186, 0, 0, 0,
+ 888, 0, 0, 0, 0, 0, 0, 187, 0, 0,
+ 576
+};
+
+static const yytype_int16 yycheck[] =
+{
+ 26, 177, 28, 200, 140, 35, 32, 297, 13, 35,
+ 274, 177, 188, 289, 278, 41, 414, 716, 46, 499,
+ 105, 327, 107, 231, 18, 579, 111, 231, 582, 5,
+ 3, 337, 236, 449, 236, 34, 3, 140, 4, 3,
+ 346, 177, 70, 71, 4, 24, 3, 4, 3, 23,
+ 78, 3, 23, 3, 31, 381, 61, 123, 234, 489,
+ 59, 60, 494, 729, 33, 3, 35, 499, 103, 5,
+ 140, 21, 22, 23, 3, 3, 125, 112, 3, 177,
+ 577, 344, 579, 793, 794, 582, 759, 3, 3, 3,
+ 23, 3, 3, 3, 3, 4, 124, 527, 126, 127,
+ 3, 3, 3, 23, 130, 169, 169, 137, 3, 3,
+ 3, 137, 3, 3, 3, 179, 23, 20, 169, 169,
+ 169, 24, 148, 149, 187, 158, 35, 97, 231, 99,
+ 169, 157, 179, 236, 21, 22, 23, 187, 143, 20,
+ 21, 22, 23, 24, 25, 171, 179, 3, 23, 217,
+ 126, 177, 3, 25, 169, 179, 23, 24, 25, 20,
+ 123, 176, 188, 24, 863, 189, 192, 5, 24, 20,
+ 238, 347, 882, 24, 137, 20, 20, 203, 179, 24,
+ 24, 347, 286, 176, 210, 20, 179, 272, 189, 24,
+ 126, 327, 169, 219, 260, 169, 80, 81, 224, 865,
+ 179, 337, 207, 4, 308, 381, 342, 180, 234, 882,
+ 346, 347, 156, 189, 158, 381, 180, 188, 244, 127,
+ 187, 187, 921, 180, 327, 180, 231, 187, 180, 234,
+ 315, 236, 237, 179, 337, 169, 169, 242, 188, 342,
+ 275, 531, 180, 346, 27, 381, 281, 180, 538, 179,
+ 285, 180, 180, 258, 158, 180, 255, 327, 564, 179,
+ 757, 758, 169, 760, 180, 180, 180, 337, 180, 180,
+ 180, 297, 342, 180, 279, 301, 346, 303, 180, 180,
+ 586, 587, 588, 589, 590, 180, 180, 180, 126, 180,
+ 180, 180, 318, 319, 179, 265, 179, 323, 169, 180,
+ 626, 188, 628, 629, 179, 568, 332, 333, 334, 335,
+ 413, 316, 575, 185, 186, 320, 179, 311, 185, 186,
+ 179, 347, 327, 427, 169, 169, 261, 262, 591, 883,
+ 179, 180, 337, 359, 169, 21, 22, 363, 364, 365,
+ 366, 367, 368, 369, 370, 371, 372, 373, 374, 179,
+ 576, 767, 768, 169, 179, 381, 169, 837, 584, 294,
+ 176, 3, 4, 179, 844, 541, 392, 393, 394, 395,
+ 396, 397, 398, 399, 400, 401, 402, 403, 404, 405,
+ 406, 407, 408, 409, 410, 593, 883, 3, 414, 593,
+ 594, 176, 594, 3, 179, 23, 422, 423, 3, 838,
+ 839, 840, 841, 507, 508, 837, 838, 839, 840, 841,
+ 808, 515, 844, 357, 358, 20, 501, 140, 141, 24,
+ 4, 506, 169, 176, 509, 138, 139, 140, 564, 23,
+ 24, 25, 376, 377, 378, 379, 380, 3, 728, 936,
+ 576, 717, 546, 707, 750, 389, 179, 169, 584, 179,
+ 586, 587, 588, 589, 590, 179, 632, 485, 179, 179,
+ 626, 564, 628, 629, 179, 491, 792, 793, 794, 495,
+ 179, 179, 676, 576, 676, 179, 502, 681, 179, 681,
+ 179, 584, 745, 586, 587, 588, 589, 590, 179, 179,
+ 593, 594, 179, 189, 564, 179, 179, 179, 179, 762,
+ 763, 764, 765, 766, 179, 531, 576, 179, 179, 179,
+ 179, 537, 538, 179, 584, 541, 586, 587, 588, 589,
+ 590, 179, 179, 169, 5, 169, 7, 8, 9, 10,
+ 11, 3, 13, 14, 15, 16, 17, 18, 4, 565,
+ 21, 22, 23, 24, 25, 169, 169, 3, 574, 3,
+ 20, 21, 22, 23, 24, 25, 20, 21, 22, 23,
+ 24, 25, 5, 169, 3, 595, 169, 179, 169, 595,
+ 596, 169, 748, 676, 3, 3, 169, 867, 681, 4,
+ 11, 180, 13, 14, 15, 16, 17, 18, 593, 594,
+ 21, 22, 23, 24, 25, 21, 22, 23, 24, 25,
+ 626, 176, 628, 629, 3, 176, 632, 633, 20, 21,
+ 22, 23, 24, 25, 750, 5, 792, 814, 881, 3,
+ 179, 725, 179, 759, 650, 651, 792, 793, 794, 655,
+ 700, 657, 132, 3, 3, 661, 3, 741, 20, 21,
+ 22, 23, 24, 25, 3, 749, 189, 750, 674, 675,
+ 3, 180, 180, 3, 3, 179, 759, 169, 24, 179,
+ 169, 687, 667, 689, 169, 179, 169, 180, 3, 180,
+ 878, 676, 5, 180, 176, 3, 681, 3, 683, 25,
+ 750, 3, 708, 13, 14, 15, 16, 17, 18, 759,
+ 3, 21, 22, 23, 24, 25, 3, 180, 179, 4,
+ 180, 169, 728, 84, 185, 186, 180, 180, 189, 714,
+ 180, 30, 816, 24, 740, 24, 180, 179, 744, 9,
+ 10, 11, 748, 13, 14, 15, 16, 17, 18, 24,
+ 23, 21, 22, 23, 24, 25, 4, 169, 180, 169,
+ 180, 917, 4, 126, 3, 750, 882, 20, 3, 5,
+ 169, 169, 5, 180, 185, 186, 179, 3, 862, 180,
+ 180, 24, 29, 180, 180, 180, 792, 793, 794, 873,
+ 180, 180, 180, 3, 188, 126, 180, 180, 169, 882,
+ 169, 258, 808, 809, 10, 3, 14, 5, 906, 7,
+ 8, 9, 10, 11, 904, 13, 14, 15, 16, 17,
+ 18, 428, 528, 21, 22, 23, 24, 25, 685, 689,
+ 498, 511, 882, 80, 81, 82, 268, 493, 537, 304,
+ 416, 721, 848, 848, 850, 76, 852, 13, 14, 15,
+ 16, 17, 18, 850, 675, 21, 22, 23, 24, 25,
+ 897, 867, 109, 748, 111, 112, 113, 955, 871, 116,
+ 117, 143, 119, 120, 959, 185, 186, 555, 142, 143,
+ 140, 347, 744, 381, 750, 557, 593, -1, 894, 594,
+ 896, 897, -1, 878, 158, 159, -1, -1, 162, 163,
+ 164, 165, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 917, 176, -1, -1, 185, 186, 902, -1, -1,
+ -1, -1, -1, -1, -1, 931, -1, -1, -1, -1,
+ -1, -1, -1, 939, -1, -1, -1, -1, -1, 945,
+ -1, -1, 948, 0, 1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 964, -1,
+ -1, -1, -1, 969, 970, -1, -1, 973, 974, -1,
+ 27, -1, 29, -1, 980, 32, 33, 34, 35, 36,
+ 37, 38, -1, -1, 41, 42, 43, 185, 186, -1,
+ -1, 48, 49, -1, -1, -1, 53, 54, -1, -1,
+ -1, -1, -1, -1, -1, -1, 63, -1, -1, -1,
+ 67, 68, -1, -1, -1, 72, -1, -1, -1, 185,
+ 186, 78, -1, 80, 81, -1, 83, -1, 85, 86,
+ 87, 88, 89, -1, 91, 92, 93, 94, 95, 96,
+ 97, 98, 99, 100, 101, 102, 103, 104, 105, 106,
+ -1, -1, 109, 110, 111, -1, 113, 114, 115, -1,
+ 117, 118, 119, -1, -1, 122, -1, 124, -1, -1,
+ 127, 128, 129, 130, -1, -1, 133, 134, 135, -1,
+ -1, -1, -1, -1, 141, -1, -1, 144, 145, 146,
+ 147, 148, 149, 150, 151, -1, 153, 154, 155, 156,
+ 157, -1, -1, 160, -1, -1, -1, -1, -1, -1,
+ 167, 168, 169, -1, -1, -1, -1, -1, -1, 176,
+ 177, 3, -1, 5, -1, 7, 8, 9, 10, 11,
+ 187, 13, 14, 15, 16, 17, 18, -1, -1, 21,
+ 22, 23, 24, 25, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 39, 40, -1,
+ -1, -1, 44, 45, 46, 47, -1, -1, -1, -1,
+ -1, -1, -1, -1, 56, 57, 58, 59, 60, 61,
+ 62, -1, 64, 65, 66, -1, -1, 69, 70, 71,
+ -1, 73, 74, 75, 76, 77, 3, 79, 5, -1,
+ 7, 8, 9, 10, 11, -1, 13, 14, 15, 16,
+ 17, 18, -1, -1, 21, 22, 23, 24, 25, 3,
+ -1, 5, -1, 7, 8, 9, 10, 11, -1, 13,
+ 14, 15, 16, 17, 18, -1, -1, 21, 22, 23,
+ 24, 25, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 142, 143, -1, -1, -1, -1, 148, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 158, 159, -1, -1,
+ 162, 163, 164, 165, -1, -1, -1, 169, -1, -1,
+ -1, -1, -1, -1, 176, -1, -1, 179, -1, -1,
+ -1, -1, -1, 185, 186, 3, -1, 5, -1, 7,
+ 8, 9, 10, 11, -1, 13, 14, 15, 16, 17,
+ 18, -1, -1, 21, 22, 23, 24, 25, 3, -1,
+ 5, -1, 7, 8, 9, 10, 11, -1, 13, 14,
+ 15, 16, 17, 18, -1, -1, 21, 22, 23, 24,
+ 25, 3, -1, 5, -1, 7, 8, 9, 10, 11,
+ -1, 13, 14, 15, 16, 17, 18, -1, -1, 21,
+ 22, 23, 24, 25, -1, -1, -1, -1, 185, 186,
+ -1, -1, -1, -1, -1, -1, 4, 5, -1, 7,
+ 8, 9, 10, 11, -1, 13, 14, 15, 16, 17,
+ 18, 185, 186, 21, 22, 23, 24, 25, 4, 5,
+ -1, 7, 8, 9, 10, 11, -1, 13, 14, 15,
+ 16, 17, 18, -1, -1, 21, 22, 23, 24, 25,
+ 4, 5, -1, 7, 8, 9, 10, 11, -1, 13,
+ 14, 15, 16, 17, 18, -1, -1, 21, 22, 23,
+ 24, 25, 4, 5, -1, 7, 8, 9, 10, 11,
+ -1, 13, 14, 15, 16, 17, 18, -1, -1, 21,
+ 22, 23, 24, 25, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 185, 186, -1,
+ -1, -1, -1, -1, -1, 4, 5, -1, 7, 8,
+ 9, 10, 11, -1, 13, 14, 15, 16, 17, 18,
+ 185, 186, 21, 22, 23, 24, 25, -1, -1, 5,
+ -1, 7, 8, 9, 10, 11, -1, 13, 14, 15,
+ 16, 17, 18, 185, 186, 21, 22, 23, 24, 25,
+ 5, -1, 7, 8, 9, 10, 11, -1, 13, 14,
+ 15, 16, 17, 18, -1, -1, 21, 22, 23, 24,
+ 25, -1, 180, -1, -1, -1, -1, 185, 186, -1,
+ -1, -1, -1, -1, -1, 5, -1, 7, 8, 9,
+ 10, 11, -1, 13, 14, 15, 16, 17, 18, 185,
+ 186, 21, 22, 23, 24, 25, -1, 5, -1, 7,
+ 8, 9, 10, 11, -1, 13, 14, 15, 16, 17,
+ 18, 185, 186, 21, 22, 23, 24, 25, -1, 5,
+ -1, 7, 8, 9, 10, 11, -1, 13, 14, 15,
+ 16, 17, 18, 185, 186, 21, 22, 23, 24, 25,
+ 5, -1, 7, 8, 9, 10, 11, -1, 13, 14,
+ 15, 16, 17, 18, -1, -1, 21, 22, 23, 24,
+ 25, -1, 5, -1, 7, 8, 9, 10, 11, -1,
+ 13, 14, 15, 16, 17, 18, 185, 186, 21, 22,
+ 23, 24, 25, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 180, -1, -1, -1, -1, 185,
+ 186, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 180, -1, -1, -1, -1,
+ 185, 186, 5, -1, 7, 8, 9, 10, 11, -1,
+ 13, 14, 15, 16, 17, 18, -1, -1, 21, 22,
+ 23, 24, 25, -1, -1, -1, -1, -1, -1, -1,
+ 180, -1, -1, -1, -1, 185, 186, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 180, -1, -1, -1, -1, 185, 186, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 180, -1, -1, -1, -1, 185,
+ 186, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 180, -1, -1, -1, -1,
+ 185, 186, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 180, -1, -1,
+ -1, -1, 185, 186, 5, -1, 7, 8, 9, 10,
+ 11, -1, 13, 14, 15, 16, 17, 18, -1, -1,
+ 21, 22, 23, 24, 25, 5, -1, 7, 8, 9,
+ 10, 11, -1, 13, 14, 15, 16, 17, 18, -1,
+ -1, 21, 22, 23, 24, 25, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 180, -1, -1,
+ -1, -1, 185, 186, 5, -1, 7, 8, 9, 10,
+ 11, -1, 13, 14, 15, 16, 17, 18, -1, -1,
+ 21, 22, 23, 24, 25, 5, -1, 7, 8, 9,
+ 10, 11, -1, 13, 14, 15, 16, 17, 18, -1,
+ -1, 21, 22, 23, 24, 25, 5, -1, 7, 8,
+ 9, 10, 11, -1, 13, 14, 15, 16, 17, 18,
+ -1, -1, 21, 22, 23, 24, 25, 5, -1, 7,
+ 8, 9, 10, 11, -1, 13, 14, 15, 16, 17,
+ 18, -1, -1, 21, 22, 23, 24, 25, 5, -1,
+ 7, 8, 9, 10, 11, -1, 13, 14, 15, 16,
+ 17, 18, -1, -1, 21, 22, 23, 24, 25, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 180,
+ -1, -1, -1, -1, 185, 186, -1, -1, -1, 169,
+ -1, 5, -1, 7, 8, 9, 10, 11, -1, 13,
+ 14, 15, 16, 17, 18, 185, 186, 21, 22, 23,
+ 24, 25, 5, -1, 7, 8, 9, 10, 11, -1,
+ 13, 14, 15, 16, 17, 18, -1, -1, 21, 22,
+ 23, 24, 25, -1, -1, -1, -1, -1, -1, 180,
+ -1, -1, -1, -1, 185, 186, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 180, -1, -1, -1, -1, 185, 186, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 180, -1, -1, -1, -1, 185, 186, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 180, -1, -1, -1, -1, 185, 186, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 180, -1, -1, -1, -1, 185, 186,
+ 5, -1, 7, 8, 9, 10, 11, -1, 13, 14,
+ 15, 16, 17, 18, -1, -1, 21, 22, 23, 24,
+ 25, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 180, -1, -1, -1,
+ -1, 185, 186, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 180, -1, -1,
+ -1, -1, 185, 186, 5, -1, 7, 8, 9, 10,
+ 11, -1, 13, 14, 15, 16, 17, 18, -1, -1,
+ 21, 22, 23, 24, 25, 5, -1, 7, 8, 9,
+ 10, 11, -1, 13, 14, 15, 16, 17, 18, -1,
+ -1, 21, 22, 23, 24, 25, 5, -1, 7, 8,
+ 9, 10, 11, -1, 13, 14, 15, 16, 17, 18,
+ -1, -1, 21, 22, 23, 24, 25, 5, -1, 7,
+ 8, 9, 10, 11, -1, 13, 14, 15, 16, 17,
+ 18, -1, -1, 21, 22, 23, 24, 25, 5, -1,
+ 7, 8, 9, 10, 11, -1, 13, 14, 15, 16,
+ 17, 18, -1, -1, 21, 22, 23, 24, 25, -1,
+ -1, -1, -1, -1, -1, 180, -1, -1, -1, -1,
+ 185, 186, 5, -1, 7, 8, 9, 10, 11, -1,
+ 13, 14, 15, 16, 17, 18, -1, -1, 21, 22,
+ 23, 24, 25, 5, -1, 7, 8, 9, 10, 11,
+ -1, 13, 14, 15, 16, 17, 18, -1, -1, 21,
+ 22, 23, 24, 25, -1, -1, -1, -1, -1, 38,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 180,
+ -1, -1, -1, -1, 185, 186, -1, -1, -1, -1,
+ -1, -1, -1, -1, 63, -1, -1, -1, -1, -1,
+ 180, -1, -1, -1, -1, 185, 186, -1, -1, 78,
+ -1, -1, -1, -1, 83, 84, -1, -1, -1, 88,
+ 89, 180, -1, -1, -1, -1, 185, 186, -1, 98,
+ 99, 100, 101, 102, 103, 104, 105, -1, -1, -1,
+ -1, -1, 180, -1, -1, -1, -1, 185, 186, 118,
+ -1, -1, -1, -1, -1, 124, -1, -1, -1, -1,
+ -1, -1, -1, 180, 133, -1, 135, -1, 185, 186,
+ 5, -1, 7, 8, 9, 10, 11, -1, 13, 14,
+ 15, 16, 17, 18, -1, -1, 21, 22, 23, 24,
+ 25, -1, -1, -1, -1, -1, -1, 180, -1, -1,
+ 169, -1, 185, 186, -1, -1, -1, 176, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 180, -1,
+ -1, -1, -1, 185, 186, 5, -1, 7, 8, 9,
+ 10, 11, 4, 13, 14, 15, 16, 17, 18, -1,
+ 12, 21, 22, 23, 24, 25, -1, -1, -1, 21,
+ 22, 23, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 39, 40, -1,
+ -1, -1, 44, 45, 46, 47, -1, -1, -1, -1,
+ -1, -1, -1, -1, 56, 57, 58, 59, 60, 61,
+ 62, -1, 64, 65, 66, -1, -1, 69, 70, 71,
+ -1, 73, 74, 75, 76, 77, -1, 79, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 40, -1,
+ -1, -1, 44, 45, 46, 47, -1, -1, -1, -1,
+ -1, -1, -1, -1, 56, 57, 58, 59, 60, 61,
+ 62, -1, 64, 65, 66, 180, -1, 69, 70, 71,
+ 185, 186, 74, 75, 76, 77, -1, 79, -1, 131,
+ -1, -1, -1, -1, -1, -1, -1, -1, 12, -1,
+ 142, 143, -1, -1, -1, -1, 148, 21, 22, -1,
+ -1, -1, -1, -1, -1, -1, 158, 159, -1, -1,
+ 162, 163, 164, 165, -1, 39, 40, 169, -1, -1,
+ 44, 45, 46, 47, 176, 185, 186, 179, -1, -1,
+ -1, -1, 56, 57, 58, 59, 60, 61, 62, -1,
+ 64, 65, 66, -1, -1, 69, 70, 71, -1, 73,
+ 74, 75, 76, 77, -1, 79, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 169, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 131, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 142, 143,
+ -1, -1, -1, -1, 148, 4, -1, -1, -1, -1,
+ -1, -1, -1, 12, 158, 159, -1, -1, 162, 163,
+ 164, 165, 21, 22, -1, 169, -1, -1, -1, -1,
+ -1, -1, 176, -1, -1, 179, -1, -1, -1, -1,
+ 39, 40, -1, 187, -1, 44, 45, 46, 47, -1,
+ -1, -1, -1, -1, -1, -1, -1, 56, 57, 58,
+ 59, 60, 61, 62, -1, 64, 65, 66, -1, -1,
+ 69, 70, 71, -1, 73, 74, 75, 76, 77, -1,
+ 79, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 131, 4, -1, -1, -1, -1, -1, -1,
+ -1, 12, -1, 142, 143, -1, -1, -1, -1, 148,
+ 21, 22, -1, -1, -1, -1, -1, -1, -1, 158,
+ 159, -1, -1, 162, 163, 164, 165, -1, 39, 40,
+ 169, -1, -1, 44, 45, 46, 47, 176, -1, -1,
+ 179, -1, -1, -1, -1, 56, 57, 58, 59, 60,
+ 61, 62, -1, 64, 65, 66, -1, -1, 69, 70,
+ 71, -1, 73, 74, 75, 76, 77, -1, 79, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 131, -1, 5, -1, -1, -1, -1, -1, -1, 12,
+ -1, 142, 143, -1, -1, -1, -1, 148, 21, 22,
+ 23, -1, -1, -1, -1, -1, -1, 158, 159, -1,
+ -1, 162, 163, 164, 165, -1, 39, 40, 169, -1,
+ -1, 44, 45, 46, 47, 176, -1, -1, 179, -1,
+ -1, -1, -1, 56, 57, 58, 59, 60, 61, 62,
+ -1, 64, 65, 66, -1, -1, 69, 70, 71, -1,
+ 73, 74, 75, 76, 77, -1, 79, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 131, -1,
+ 5, -1, -1, -1, -1, -1, -1, 12, -1, 142,
+ 143, -1, -1, -1, -1, 148, 21, 22, -1, 24,
+ -1, -1, -1, -1, -1, 158, 159, -1, -1, 162,
+ 163, 164, 165, -1, 39, 40, 169, -1, -1, 44,
+ 45, 46, 47, 176, -1, -1, 179, -1, -1, -1,
+ -1, 56, 57, 58, 59, 60, 61, 62, -1, 64,
+ 65, 66, -1, -1, 69, 70, 71, -1, 73, 74,
+ 75, 76, 77, -1, 79, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 131, -1, 5, -1,
+ -1, -1, -1, -1, -1, 12, -1, 142, 143, -1,
+ -1, -1, -1, 148, 21, 22, 23, -1, -1, -1,
+ -1, -1, -1, 158, 159, -1, -1, 162, 163, 164,
+ 165, -1, 39, 40, 169, -1, -1, 44, 45, 46,
+ 47, 176, -1, -1, 179, -1, -1, -1, -1, 56,
+ 57, 58, 59, 60, 61, 62, -1, 64, 65, 66,
+ -1, -1, 69, 70, 71, -1, 73, 74, 75, 76,
+ 77, -1, 79, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 131, -1, 5, -1, -1, -1,
+ -1, -1, -1, 12, -1, 142, 143, -1, -1, -1,
+ -1, 148, 21, 22, -1, -1, -1, -1, -1, -1,
+ -1, 158, 159, -1, -1, 162, 163, 164, 165, -1,
+ 39, 40, 169, -1, -1, 44, 45, 46, 47, 176,
+ -1, -1, 179, -1, -1, -1, -1, 56, 57, 58,
+ 59, 60, 61, 62, -1, 64, 65, 66, -1, -1,
+ 69, 70, 71, -1, 73, 74, 75, 76, 77, -1,
+ 79, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 131, -1, 5, -1, -1, -1, -1, -1,
+ -1, 12, -1, 142, 143, -1, -1, -1, -1, 148,
+ 21, 22, -1, -1, -1, -1, -1, -1, -1, 158,
+ 159, -1, -1, 162, 163, 164, 165, -1, 39, 40,
+ 169, -1, -1, 44, 45, 46, 47, 176, -1, -1,
+ 179, -1, -1, -1, -1, 56, 57, 58, 59, 60,
+ 61, 62, -1, 64, 65, 66, -1, -1, 69, 70,
+ 71, -1, 73, 74, 75, 76, 77, -1, 79, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 131, -1, 5, -1, -1, -1, -1, -1, -1, 12,
+ -1, 142, 143, -1, -1, -1, -1, 148, 21, 22,
+ -1, -1, -1, -1, -1, -1, -1, 158, 159, -1,
+ -1, 162, 163, 164, 165, -1, 39, 40, 169, -1,
+ -1, 44, 45, 46, 47, 176, -1, -1, 179, -1,
+ -1, -1, -1, 56, 57, 58, 59, 60, 61, 62,
+ -1, 64, 65, 66, -1, -1, 69, 70, 71, -1,
+ 73, 74, 75, 76, 77, -1, 79, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 131, -1,
+ -1, -1, -1, -1, -1, -1, -1, 12, -1, 142,
+ 143, -1, -1, -1, -1, 148, 21, 22, 23, -1,
+ 25, -1, -1, -1, -1, 158, 159, -1, -1, 162,
+ 163, 164, 165, -1, 39, 40, 169, -1, -1, 44,
+ 45, 46, 47, 176, -1, -1, 179, -1, -1, -1,
+ -1, 56, 57, 58, 59, 60, 61, 62, -1, 64,
+ 65, 66, -1, -1, 69, 70, 71, -1, 73, 74,
+ 75, 76, 77, -1, 79, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 131, -1, -1, -1,
+ -1, -1, -1, -1, -1, 12, -1, 142, 143, -1,
+ -1, -1, -1, 148, 21, 22, 23, -1, -1, -1,
+ -1, -1, -1, 158, 159, -1, -1, 162, 163, 164,
+ 165, -1, 39, 40, 169, -1, -1, 44, 45, 46,
+ 47, 176, -1, -1, 179, -1, -1, -1, -1, 56,
+ 57, 58, 59, 60, 61, 62, -1, 64, 65, 66,
+ -1, -1, 69, 70, 71, -1, 73, 74, 75, 76,
+ 77, -1, 79, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 131, -1, -1, -1, -1, -1,
+ -1, -1, -1, 12, -1, 142, 143, -1, -1, -1,
+ -1, 148, 21, 22, 23, -1, -1, -1, -1, -1,
+ -1, 158, 159, -1, -1, 162, 163, 164, 165, -1,
+ 39, 40, 169, -1, -1, 44, 45, 46, 47, 176,
+ -1, -1, 179, -1, -1, -1, -1, 56, 57, 58,
+ 59, 60, 61, 62, -1, 64, 65, 66, -1, -1,
+ 69, 70, 71, -1, 73, 74, 75, 76, 77, -1,
+ 79, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 131, -1, -1, -1, -1, -1, -1, -1,
+ -1, 12, -1, 142, 143, -1, -1, -1, -1, 148,
+ 21, 22, 23, -1, -1, -1, -1, -1, -1, 158,
+ 159, -1, -1, 162, 163, 164, 165, -1, 39, 40,
+ 169, -1, -1, 44, 45, 46, 47, 176, -1, -1,
+ 179, -1, -1, -1, -1, 56, 57, 58, 59, 60,
+ 61, 62, -1, 64, 65, 66, -1, -1, 69, 70,
+ 71, -1, 73, 74, 75, 76, 77, -1, 79, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 131, -1, -1, -1, -1, -1, -1, -1, -1, 12,
+ -1, 142, 143, -1, -1, -1, -1, 148, 21, 22,
+ 23, -1, -1, -1, -1, -1, -1, 158, 159, -1,
+ -1, 162, 163, 164, 165, -1, 39, 40, 169, -1,
+ -1, 44, 45, 46, 47, 176, -1, -1, 179, -1,
+ -1, -1, -1, 56, 57, 58, 59, 60, 61, 62,
+ -1, 64, 65, 66, -1, -1, 69, 70, 71, -1,
+ 73, 74, 75, 76, 77, -1, 79, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 131, -1,
+ -1, -1, -1, -1, -1, -1, -1, 12, -1, 142,
+ 143, -1, -1, -1, -1, 148, 21, 22, 23, -1,
+ -1, -1, -1, -1, -1, 158, 159, -1, -1, 162,
+ 163, 164, 165, -1, 39, 40, 169, -1, -1, 44,
+ 45, 46, 47, 176, -1, -1, 179, -1, -1, -1,
+ -1, 56, 57, 58, 59, 60, 61, 62, -1, 64,
+ 65, 66, -1, -1, 69, 70, 71, -1, 73, 74,
+ 75, 76, 77, -1, 79, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 131, -1, -1, -1,
+ -1, -1, -1, -1, -1, 12, -1, 142, 143, -1,
+ -1, -1, -1, 148, 21, 22, 23, -1, -1, -1,
+ -1, -1, -1, 158, 159, -1, -1, 162, 163, 164,
+ 165, -1, 39, 40, 169, -1, -1, 44, 45, 46,
+ 47, 176, -1, -1, 179, -1, -1, -1, -1, 56,
+ 57, 58, 59, 60, 61, 62, -1, 64, 65, 66,
+ -1, -1, 69, 70, 71, -1, 73, 74, 75, 76,
+ 77, -1, 79, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 131, -1, -1, -1, -1, -1,
+ -1, -1, -1, 12, -1, 142, 143, -1, -1, -1,
+ -1, 148, 21, 22, -1, -1, -1, -1, -1, -1,
+ -1, 158, 159, -1, -1, 162, 163, 164, 165, -1,
+ 39, 40, 169, -1, -1, 44, 45, 46, 47, 176,
+ -1, -1, 179, -1, -1, -1, -1, 56, 57, 58,
+ 59, 60, 61, 62, -1, 64, 65, 66, -1, -1,
+ 69, 70, 71, -1, 73, 74, 75, 76, 77, -1,
+ 79, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 131, -1, -1, -1, -1, -1, -1, -1,
+ -1, 12, -1, 142, 143, -1, -1, -1, -1, 148,
+ 21, 22, -1, -1, -1, -1, -1, -1, -1, 158,
+ 159, -1, -1, 162, 163, 164, 165, -1, 39, 40,
+ 169, -1, -1, 44, 45, 46, 47, 176, -1, -1,
+ 179, -1, -1, -1, -1, 56, 57, 58, 59, 60,
+ 61, 62, -1, 64, 65, 66, -1, -1, 69, 70,
+ 71, -1, 73, 74, 75, 76, 77, -1, 79, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 131, -1, -1, -1, -1, -1, -1, -1, -1, 12,
+ -1, 142, 143, -1, -1, -1, -1, 148, 21, 22,
+ -1, -1, -1, -1, -1, -1, -1, 158, 159, -1,
+ -1, 162, 163, 164, 165, -1, 39, 40, 169, -1,
+ -1, 44, 45, 46, 47, 176, -1, -1, 179, -1,
+ -1, -1, -1, 56, 57, 58, 59, 60, 61, 62,
+ -1, 64, 65, 66, -1, -1, 69, 70, 71, -1,
+ 73, 74, 75, 76, 77, -1, 79, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 131, -1,
+ -1, -1, -1, -1, -1, -1, -1, 12, -1, 142,
+ 143, -1, -1, -1, -1, 148, 21, 22, -1, -1,
+ -1, -1, -1, -1, -1, 158, 159, -1, -1, 162,
+ 163, 164, 165, -1, 39, 40, 169, -1, -1, 44,
+ 45, 46, 47, 176, -1, -1, 179, -1, -1, -1,
+ -1, 56, 57, 58, 59, 60, 61, 62, -1, 64,
+ 65, 66, -1, -1, 69, 70, 71, -1, 73, 74,
+ 75, 76, 77, -1, 79, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 131, -1, -1, -1,
+ -1, -1, -1, -1, -1, 12, -1, 142, 143, -1,
+ -1, -1, -1, 148, 21, 22, -1, -1, -1, -1,
+ -1, -1, -1, 158, 159, -1, -1, 162, 163, 164,
+ 165, -1, 39, 40, 169, -1, -1, 44, 45, 46,
+ 47, 176, -1, -1, 179, -1, -1, -1, -1, 56,
+ 57, 58, 59, 60, 61, 62, -1, 64, 65, 66,
+ -1, -1, 69, 70, 71, -1, 73, 74, 75, 76,
+ 77, -1, 79, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 131, -1, -1, -1, -1, -1,
+ -1, -1, -1, 12, -1, 142, 143, -1, -1, -1,
+ -1, 148, 21, 22, -1, -1, -1, -1, -1, -1,
+ -1, 158, 159, -1, -1, 162, 163, 164, 165, -1,
+ 39, 40, 169, -1, -1, 44, 45, 46, 47, 176,
+ -1, -1, 179, -1, -1, -1, -1, 56, 57, 58,
+ 59, 60, 61, 62, -1, 64, 65, 66, -1, -1,
+ 69, 70, 71, -1, 73, 74, 75, 76, 77, -1,
+ 79, 21, 22, 23, -1, 25, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 39,
+ 40, -1, -1, -1, 44, 45, 46, 47, -1, -1,
+ 50, 51, 52, -1, -1, 55, 56, 57, 58, 59,
+ 60, 61, 62, -1, 64, 65, 66, -1, -1, 69,
+ 70, 71, 131, 73, 74, 75, 76, 77, -1, 79,
+ -1, -1, -1, 142, 143, -1, -1, -1, -1, 148,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 158,
+ 159, -1, -1, 162, 163, 164, 165, -1, -1, -1,
+ 169, -1, -1, -1, -1, -1, -1, 176, -1, -1,
+ 179, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 142, 143, -1, -1, -1, -1, 148, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 158, 159,
+ -1, -1, 162, 163, 164, 165, 21, 22, 23, 169,
+ -1, -1, -1, -1, -1, -1, 176, -1, -1, 179,
+ -1, -1, -1, -1, 39, 40, -1, -1, -1, 44,
+ 45, 46, 47, -1, -1, 50, 51, 52, -1, -1,
+ 55, 56, 57, 58, 59, 60, 61, 62, -1, 64,
+ 65, 66, 21, 22, 69, 70, 71, -1, 73, 74,
+ 75, 76, 77, -1, 79, -1, -1, -1, -1, -1,
+ 39, 40, -1, -1, -1, 44, 45, 46, 47, -1,
+ -1, 50, 51, 52, -1, -1, 55, 56, 57, 58,
+ 59, 60, 61, 62, -1, 64, 65, 66, -1, -1,
+ 69, 70, 71, -1, 73, 74, 75, 76, 77, -1,
+ 79, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 142, 143, -1,
+ -1, -1, -1, 148, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 158, 159, -1, -1, 162, 163, 164,
+ 165, -1, -1, -1, 169, -1, -1, -1, -1, -1,
+ -1, 176, -1, 29, 179, -1, 32, 33, 34, 35,
+ -1, -1, 38, 142, 143, 41, 42, 43, -1, 148,
+ -1, -1, 48, 49, -1, -1, -1, -1, -1, 158,
+ 159, -1, -1, 162, 163, 164, 165, 63, -1, -1,
+ 169, 67, 68, -1, -1, -1, 72, 176, -1, -1,
+ 179, -1, 78, -1, 80, 81, -1, 83, -1, 85,
+ 86, 87, 88, 89, -1, 91, 92, 93, 94, 95,
+ 96, 97, 98, 99, 100, 101, 102, 103, 104, 105,
+ 106, -1, -1, 109, 110, 111, -1, 113, 114, 115,
+ -1, 117, 118, 119, -1, -1, 122, -1, 124, -1,
+ -1, 127, 128, 129, 130, -1, -1, 133, 134, 135,
+ -1, -1, -1, -1, -1, 141, -1, -1, -1, 145,
+ 146, 147, 148, 149, 150, 151, -1, 153, 154, 155,
+ 156, 157, -1, -1, 160, -1, -1, -1, -1, 39,
+ 40, 167, 168, 169, 44, 45, 46, 47, -1, -1,
+ 176, -1, -1, -1, -1, -1, 56, 57, 58, 59,
+ 60, 61, 62, -1, 64, 65, 66, -1, -1, 69,
+ 70, 71, -1, 73, 74, 75, 76, 77, -1, 79,
+ 39, 40, -1, -1, -1, 44, 45, 46, 47, -1,
+ -1, -1, -1, -1, -1, -1, -1, 56, 57, 58,
+ 59, 60, 61, 62, -1, 64, 65, 66, -1, -1,
+ 69, 70, 71, -1, 73, 74, 75, 76, 77, -1,
+ 79, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 142, 143, -1, -1, -1, -1, 148, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 158, 159,
+ -1, -1, 162, 163, 164, 165, -1, -1, -1, 169,
+ -1, -1, -1, -1, -1, -1, 176, -1, -1, 179,
+ -1, -1, -1, 142, 143, -1, -1, -1, -1, 148,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 158,
+ 159, -1, -1, 162, 163, 164, 165, -1, -1, -1,
+ 169, -1, -1, -1, -1, -1, -1, 176, -1, -1,
+ 179
+};
+
+/* YYSTOS[STATE-NUM] -- The (internal number of the) accessing
+ symbol of state STATE-NUM. */
+static const yytype_uint16 yystos[] =
+{
+ 0, 191, 0, 1, 36, 37, 53, 54, 144, 177,
+ 187, 192, 197, 199, 205, 201, 198, 177, 200, 29,
+ 32, 34, 38, 41, 42, 43, 48, 49, 63, 67,
+ 68, 72, 78, 80, 81, 83, 85, 86, 87, 88,
+ 89, 91, 92, 93, 94, 95, 96, 97, 98, 99,
+ 100, 101, 102, 103, 104, 105, 106, 109, 110, 111,
+ 113, 114, 115, 117, 118, 119, 122, 124, 127, 128,
+ 129, 130, 133, 134, 135, 141, 145, 146, 147, 148,
+ 149, 150, 151, 153, 154, 155, 156, 157, 160, 167,
+ 168, 169, 176, 193, 194, 195, 202, 203, 206, 212,
+ 224, 225, 228, 229, 234, 235, 237, 238, 239, 240,
+ 241, 243, 244, 251, 253, 257, 258, 261, 262, 263,
+ 298, 308, 309, 315, 316, 317, 318, 319, 321, 326,
+ 327, 328, 330, 331, 333, 336, 337, 340, 341, 349,
+ 351, 352, 365, 372, 201, 205, 169, 204, 179, 12,
+ 21, 22, 39, 40, 44, 45, 46, 47, 56, 57,
+ 58, 59, 60, 61, 62, 64, 65, 66, 69, 70,
+ 71, 73, 74, 75, 76, 77, 79, 131, 142, 143,
+ 148, 158, 159, 162, 163, 164, 165, 176, 179, 280,
+ 281, 283, 284, 288, 290, 291, 292, 293, 298, 299,
+ 300, 307, 320, 179, 187, 280, 304, 179, 217, 218,
+ 179, 280, 303, 4, 187, 221, 187, 221, 304, 179,
+ 169, 187, 324, 176, 179, 364, 280, 169, 325, 169,
+ 324, 179, 169, 176, 179, 346, 179, 179, 221, 221,
+ 20, 24, 247, 298, 179, 216, 123, 137, 127, 324,
+ 324, 169, 252, 80, 81, 213, 275, 324, 27, 196,
+ 198, 33, 35, 196, 158, 207, 196, 169, 179, 249,
+ 250, 169, 226, 231, 3, 248, 169, 230, 247, 3,
+ 236, 248, 3, 248, 3, 248, 169, 245, 246, 247,
+ 3, 4, 35, 222, 223, 255, 271, 169, 176, 268,
+ 23, 179, 259, 23, 179, 266, 23, 4, 329, 169,
+ 310, 200, 324, 324, 324, 176, 323, 280, 5, 126,
+ 189, 332, 3, 179, 334, 169, 304, 179, 345, 21,
+ 22, 23, 50, 51, 52, 55, 169, 179, 281, 288,
+ 299, 343, 345, 350, 353, 354, 355, 345, 84, 98,
+ 105, 298, 328, 280, 280, 280, 282, 179, 179, 179,
+ 282, 280, 282, 179, 179, 179, 179, 179, 179, 179,
+ 179, 179, 179, 179, 179, 280, 179, 179, 179, 179,
+ 179, 179, 280, 281, 283, 307, 360, 361, 362, 179,
+ 280, 283, 5, 7, 8, 9, 10, 11, 13, 14,
+ 15, 16, 17, 18, 21, 22, 23, 24, 25, 185,
+ 186, 285, 280, 189, 179, 302, 179, 179, 169, 158,
+ 301, 302, 3, 4, 180, 280, 219, 298, 3, 280,
+ 4, 169, 242, 242, 280, 280, 180, 288, 292, 298,
+ 330, 366, 367, 368, 176, 283, 298, 298, 367, 369,
+ 298, 371, 242, 40, 44, 45, 46, 47, 56, 57,
+ 58, 59, 60, 61, 62, 64, 65, 66, 69, 70,
+ 71, 74, 75, 76, 77, 79, 169, 214, 215, 169,
+ 298, 220, 280, 3, 3, 221, 194, 200, 204, 204,
+ 196, 5, 249, 3, 24, 179, 187, 248, 3, 24,
+ 230, 247, 179, 276, 230, 298, 247, 169, 169, 247,
+ 276, 3, 245, 29, 82, 109, 111, 112, 113, 116,
+ 117, 119, 120, 272, 273, 275, 4, 204, 3, 256,
+ 254, 5, 23, 269, 280, 180, 176, 179, 169, 260,
+ 269, 179, 267, 280, 268, 176, 276, 3, 205, 248,
+ 298, 322, 373, 280, 280, 298, 176, 23, 280, 335,
+ 338, 339, 23, 25, 179, 298, 347, 348, 353, 354,
+ 280, 280, 280, 280, 5, 353, 179, 281, 288, 299,
+ 342, 356, 357, 358, 3, 344, 20, 23, 24, 25,
+ 355, 353, 360, 179, 179, 180, 3, 180, 282, 282,
+ 280, 180, 180, 180, 280, 280, 280, 280, 280, 280,
+ 280, 280, 280, 280, 280, 280, 180, 282, 282, 282,
+ 282, 282, 280, 283, 361, 362, 3, 132, 3, 3,
+ 282, 180, 3, 5, 280, 287, 280, 280, 280, 280,
+ 280, 280, 280, 280, 280, 280, 280, 280, 280, 280,
+ 5, 24, 280, 286, 280, 5, 280, 5, 280, 288,
+ 303, 289, 294, 294, 280, 280, 180, 3, 180, 276,
+ 218, 180, 3, 180, 3, 179, 3, 370, 180, 180,
+ 180, 3, 370, 3, 180, 3, 24, 3, 180, 179,
+ 169, 324, 179, 208, 208, 280, 180, 250, 227, 232,
+ 233, 284, 280, 169, 169, 231, 227, 248, 4, 23,
+ 277, 278, 279, 280, 248, 276, 276, 248, 246, 276,
+ 179, 3, 4, 208, 254, 169, 269, 260, 5, 269,
+ 180, 3, 270, 23, 180, 276, 31, 169, 311, 312,
+ 5, 329, 364, 180, 3, 353, 23, 25, 179, 280,
+ 3, 180, 180, 280, 180, 356, 285, 359, 359, 3,
+ 359, 356, 353, 353, 353, 353, 353, 366, 369, 304,
+ 280, 180, 180, 180, 180, 180, 180, 180, 180, 180,
+ 180, 180, 180, 180, 180, 180, 180, 180, 180, 180,
+ 180, 180, 3, 3, 3, 280, 362, 280, 362, 280,
+ 362, 180, 283, 280, 280, 280, 280, 280, 4, 4,
+ 280, 295, 296, 297, 180, 180, 298, 169, 84, 280,
+ 295, 125, 367, 180, 367, 180, 298, 214, 280, 220,
+ 23, 169, 180, 210, 211, 30, 24, 3, 21, 22,
+ 23, 188, 299, 180, 24, 24, 230, 280, 3, 180,
+ 4, 298, 23, 264, 264, 245, 138, 139, 140, 274,
+ 273, 4, 169, 276, 180, 269, 270, 169, 180, 4,
+ 126, 3, 280, 276, 339, 180, 280, 297, 189, 276,
+ 348, 353, 3, 180, 285, 358, 370, 370, 169, 363,
+ 363, 363, 180, 303, 4, 280, 4, 3, 302, 276,
+ 180, 180, 5, 180, 3, 180, 179, 209, 227, 232,
+ 232, 232, 232, 227, 278, 279, 280, 179, 265, 280,
+ 180, 276, 264, 270, 269, 169, 187, 313, 314, 169,
+ 312, 3, 276, 180, 330, 363, 359, 180, 180, 5,
+ 180, 180, 180, 180, 280, 4, 280, 296, 3, 298,
+ 211, 180, 210, 24, 23, 264, 305, 306, 126, 3,
+ 280, 180, 280, 280, 4, 280, 180, 180, 305, 5,
+ 126, 169, 314, 3, 3, 280, 280, 280, 280, 280,
+ 3, 280
+};
+
+#define yyerrok (yyerrstatus = 0)
+#define yyclearin (yychar = YYEMPTY)
+#define YYEMPTY (-2)
+#define YYEOF 0
+
+#define YYACCEPT goto yyacceptlab
+#define YYABORT goto yyabortlab
+#define YYERROR goto yyerrorlab
+
+
+/* Like YYERROR except do call yyerror. This remains here temporarily
+ to ease the transition to the new meaning of YYERROR, for GCC.
+ Once GCC version 2 has supplanted version 1, this can go. */
+
+#define YYFAIL goto yyerrlab
+
+#define YYRECOVERING() (!!yyerrstatus)
+
+#define YYBACKUP(Token, Value) \
+do \
+ if (yychar == YYEMPTY && yylen == 1) \
+ { \
+ yychar = (Token); \
+ yylval = (Value); \
+ yytoken = YYTRANSLATE (yychar); \
+ YYPOPSTACK (1); \
+ goto yybackup; \
+ } \
+ else \
+ { \
+ yyerror (YY_("syntax error: cannot back up")); \
+ YYERROR; \
+ } \
+while (YYID (0))
+
+
+#define YYTERROR 1
+#define YYERRCODE 256
+
+
+/* YYLLOC_DEFAULT -- Set CURRENT to span from RHS[1] to RHS[N].
+ If N is 0, then set CURRENT to the empty location which ends
+ the previous symbol: RHS[0] (always defined). */
+
+#define YYRHSLOC(Rhs, K) ((Rhs)[K])
+#ifndef YYLLOC_DEFAULT
+# define YYLLOC_DEFAULT(Current, Rhs, N) \
+ do \
+ if (YYID (N)) \
+ { \
+ (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \
+ (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \
+ (Current).last_line = YYRHSLOC (Rhs, N).last_line; \
+ (Current).last_column = YYRHSLOC (Rhs, N).last_column; \
+ } \
+ else \
+ { \
+ (Current).first_line = (Current).last_line = \
+ YYRHSLOC (Rhs, 0).last_line; \
+ (Current).first_column = (Current).last_column = \
+ YYRHSLOC (Rhs, 0).last_column; \
+ } \
+ while (YYID (0))
+#endif
+
+
+/* YY_LOCATION_PRINT -- Print the location on the stream.
+ This macro was not mandated originally: define only if we know
+ we won't break user code: when these are the locations we know. */
+
+#ifndef YY_LOCATION_PRINT
+# if defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL
+# define YY_LOCATION_PRINT(File, Loc) \
+ fprintf (File, "%d.%d-%d.%d", \
+ (Loc).first_line, (Loc).first_column, \
+ (Loc).last_line, (Loc).last_column)
+# else
+# define YY_LOCATION_PRINT(File, Loc) ((void) 0)
+# endif
+#endif
+
+
+/* YYLEX -- calling `yylex' with the right arguments. */
+
+#ifdef YYLEX_PARAM
+# define YYLEX yylex (YYLEX_PARAM)
+#else
+# define YYLEX yylex ()
+#endif
+
+/* Enable debugging if requested. */
+#if YYDEBUG
+
+# ifndef YYFPRINTF
+# include /* INFRINGES ON USER NAME SPACE */
+# define YYFPRINTF fprintf
+# endif
+
+# define YYDPRINTF(Args) \
+do { \
+ if (yydebug) \
+ YYFPRINTF Args; \
+} while (YYID (0))
+
+# define YY_SYMBOL_PRINT(Title, Type, Value, Location) \
+do { \
+ if (yydebug) \
+ { \
+ YYFPRINTF (stderr, "%s ", Title); \
+ yy_symbol_print (stderr, \
+ Type, Value); \
+ YYFPRINTF (stderr, "\n"); \
+ } \
+} while (YYID (0))
+
+
+/*--------------------------------.
+| Print this symbol on YYOUTPUT. |
+`--------------------------------*/
+
+/*ARGSUSED*/
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+static void
+yy_symbol_value_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep)
+#else
+static void
+yy_symbol_value_print (yyoutput, yytype, yyvaluep)
+ FILE *yyoutput;
+ int yytype;
+ YYSTYPE const * const yyvaluep;
+#endif
+{
+ if (!yyvaluep)
+ return;
+# ifdef YYPRINT
+ if (yytype < YYNTOKENS)
+ YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep);
+# else
+ YYUSE (yyoutput);
+# endif
+ switch (yytype)
+ {
+ default:
+ break;
+ }
+}
+
+
+/*--------------------------------.
+| Print this symbol on YYOUTPUT. |
+`--------------------------------*/
+
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+static void
+yy_symbol_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep)
+#else
+static void
+yy_symbol_print (yyoutput, yytype, yyvaluep)
+ FILE *yyoutput;
+ int yytype;
+ YYSTYPE const * const yyvaluep;
+#endif
+{
+ if (yytype < YYNTOKENS)
+ YYFPRINTF (yyoutput, "token %s (", yytname[yytype]);
+ else
+ YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]);
+
+ yy_symbol_value_print (yyoutput, yytype, yyvaluep);
+ YYFPRINTF (yyoutput, ")");
+}
+
+/*------------------------------------------------------------------.
+| yy_stack_print -- Print the state stack from its BOTTOM up to its |
+| TOP (included). |
+`------------------------------------------------------------------*/
+
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+static void
+yy_stack_print (yytype_int16 *bottom, yytype_int16 *top)
+#else
+static void
+yy_stack_print (bottom, top)
+ yytype_int16 *bottom;
+ yytype_int16 *top;
+#endif
+{
+ YYFPRINTF (stderr, "Stack now");
+ for (; bottom <= top; ++bottom)
+ YYFPRINTF (stderr, " %d", *bottom);
+ YYFPRINTF (stderr, "\n");
+}
+
+# define YY_STACK_PRINT(Bottom, Top) \
+do { \
+ if (yydebug) \
+ yy_stack_print ((Bottom), (Top)); \
+} while (YYID (0))
+
+
+/*------------------------------------------------.
+| Report that the YYRULE is going to be reduced. |
+`------------------------------------------------*/
+
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+static void
+yy_reduce_print (YYSTYPE *yyvsp, int yyrule)
+#else
+static void
+yy_reduce_print (yyvsp, yyrule)
+ YYSTYPE *yyvsp;
+ int yyrule;
+#endif
+{
+ int yynrhs = yyr2[yyrule];
+ int yyi;
+ unsigned long int yylno = yyrline[yyrule];
+ YYFPRINTF (stderr, "Reducing stack by rule %d (line %lu):\n",
+ yyrule - 1, yylno);
+ /* The symbols being reduced. */
+ for (yyi = 0; yyi < yynrhs; yyi++)
+ {
+ fprintf (stderr, " $%d = ", yyi + 1);
+ yy_symbol_print (stderr, yyrhs[yyprhs[yyrule] + yyi],
+ &(yyvsp[(yyi + 1) - (yynrhs)])
+ );
+ fprintf (stderr, "\n");
+ }
+}
+
+# define YY_REDUCE_PRINT(Rule) \
+do { \
+ if (yydebug) \
+ yy_reduce_print (yyvsp, Rule); \
+} while (YYID (0))
+
+/* Nonzero means print parse trace. It is left uninitialized so that
+ multiple parsers can coexist. */
+int yydebug;
+#else /* !YYDEBUG */
+# define YYDPRINTF(Args)
+# define YY_SYMBOL_PRINT(Title, Type, Value, Location)
+# define YY_STACK_PRINT(Bottom, Top)
+# define YY_REDUCE_PRINT(Rule)
+#endif /* !YYDEBUG */
+
+
+/* YYINITDEPTH -- initial size of the parser's stacks. */
+#ifndef YYINITDEPTH
+# define YYINITDEPTH 200
+#endif
+
+/* YYMAXDEPTH -- maximum size the stacks can grow to (effective only
+ if the built-in stack extension method is used).
+
+ Do not make this value too large; the results are undefined if
+ YYSTACK_ALLOC_MAXIMUM < YYSTACK_BYTES (YYMAXDEPTH)
+ evaluated with infinite-precision integer arithmetic. */
+
+#ifndef YYMAXDEPTH
+# define YYMAXDEPTH 10000
+#endif
+
+
+
+
+#if YYERROR_VERBOSE
+
+# ifndef yystrlen
+# if defined __GLIBC__ && defined _STRING_H
+# define yystrlen strlen
+# else
+/* Return the length of YYSTR. */
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+static YYSIZE_T
+yystrlen (const char *yystr)
+#else
+static YYSIZE_T
+yystrlen (yystr)
+ const char *yystr;
+#endif
+{
+ YYSIZE_T yylen;
+ for (yylen = 0; yystr[yylen]; yylen++)
+ continue;
+ return yylen;
+}
+# endif
+# endif
+
+# ifndef yystpcpy
+# if defined __GLIBC__ && defined _STRING_H && defined _GNU_SOURCE
+# define yystpcpy stpcpy
+# else
+/* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in
+ YYDEST. */
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+static char *
+yystpcpy (char *yydest, const char *yysrc)
+#else
+static char *
+yystpcpy (yydest, yysrc)
+ char *yydest;
+ const char *yysrc;
+#endif
+{
+ char *yyd = yydest;
+ const char *yys = yysrc;
+
+ while ((*yyd++ = *yys++) != '\0')
+ continue;
+
+ return yyd - 1;
+}
+# endif
+# endif
+
+# ifndef yytnamerr
+/* Copy to YYRES the contents of YYSTR after stripping away unnecessary
+ quotes and backslashes, so that it's suitable for yyerror. The
+ heuristic is that double-quoting is unnecessary unless the string
+ contains an apostrophe, a comma, or backslash (other than
+ backslash-backslash). YYSTR is taken from yytname. If YYRES is
+ null, do not copy; instead, return the length of what the result
+ would have been. */
+static YYSIZE_T
+yytnamerr (char *yyres, const char *yystr)
+{
+ if (*yystr == '"')
+ {
+ YYSIZE_T yyn = 0;
+ char const *yyp = yystr;
+
+ for (;;)
+ switch (*++yyp)
+ {
+ case '\'':
+ case ',':
+ goto do_not_strip_quotes;
+
+ case '\\':
+ if (*++yyp != '\\')
+ goto do_not_strip_quotes;
+ /* Fall through. */
+ default:
+ if (yyres)
+ yyres[yyn] = *yyp;
+ yyn++;
+ break;
+
+ case '"':
+ if (yyres)
+ yyres[yyn] = '\0';
+ return yyn;
+ }
+ do_not_strip_quotes: ;
+ }
+
+ if (! yyres)
+ return yystrlen (yystr);
+
+ return yystpcpy (yyres, yystr) - yyres;
+}
+# endif
+
+/* Copy into YYRESULT an error message about the unexpected token
+ YYCHAR while in state YYSTATE. Return the number of bytes copied,
+ including the terminating null byte. If YYRESULT is null, do not
+ copy anything; just return the number of bytes that would be
+ copied. As a special case, return 0 if an ordinary "syntax error"
+ message will do. Return YYSIZE_MAXIMUM if overflow occurs during
+ size calculation. */
+static YYSIZE_T
+yysyntax_error (char *yyresult, int yystate, int yychar)
+{
+ int yyn = yypact[yystate];
+
+ if (! (YYPACT_NINF < yyn && yyn <= YYLAST))
+ return 0;
+ else
+ {
+ int yytype = YYTRANSLATE (yychar);
+ YYSIZE_T yysize0 = yytnamerr (0, yytname[yytype]);
+ YYSIZE_T yysize = yysize0;
+ YYSIZE_T yysize1;
+ int yysize_overflow = 0;
+ enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 };
+ char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM];
+ int yyx;
+
+# if 0
+ /* This is so xgettext sees the translatable formats that are
+ constructed on the fly. */
+ YY_("syntax error, unexpected %s");
+ YY_("syntax error, unexpected %s, expecting %s");
+ YY_("syntax error, unexpected %s, expecting %s or %s");
+ YY_("syntax error, unexpected %s, expecting %s or %s or %s");
+ YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s");
+# endif
+ char *yyfmt;
+ char const *yyf;
+ static char const yyunexpected[] = "syntax error, unexpected %s";
+ static char const yyexpecting[] = ", expecting %s";
+ static char const yyor[] = " or %s";
+ char yyformat[sizeof yyunexpected
+ + sizeof yyexpecting - 1
+ + ((YYERROR_VERBOSE_ARGS_MAXIMUM - 2)
+ * (sizeof yyor - 1))];
+ char const *yyprefix = yyexpecting;
+
+ /* Start YYX at -YYN if negative to avoid negative indexes in
+ YYCHECK. */
+ int yyxbegin = yyn < 0 ? -yyn : 0;
+
+ /* Stay within bounds of both yycheck and yytname. */
+ int yychecklim = YYLAST - yyn + 1;
+ int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS;
+ int yycount = 1;
+
+ yyarg[0] = yytname[yytype];
+ yyfmt = yystpcpy (yyformat, yyunexpected);
+
+ for (yyx = yyxbegin; yyx < yyxend; ++yyx)
+ if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR)
+ {
+ if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM)
+ {
+ yycount = 1;
+ yysize = yysize0;
+ yyformat[sizeof yyunexpected - 1] = '\0';
+ break;
+ }
+ yyarg[yycount++] = yytname[yyx];
+ yysize1 = yysize + yytnamerr (0, yytname[yyx]);
+ yysize_overflow |= (yysize1 < yysize);
+ yysize = yysize1;
+ yyfmt = yystpcpy (yyfmt, yyprefix);
+ yyprefix = yyor;
+ }
+
+ yyf = YY_(yyformat);
+ yysize1 = yysize + yystrlen (yyf);
+ yysize_overflow |= (yysize1 < yysize);
+ yysize = yysize1;
+
+ if (yysize_overflow)
+ return YYSIZE_MAXIMUM;
+
+ if (yyresult)
+ {
+ /* Avoid sprintf, as that infringes on the user's name space.
+ Don't have undefined behavior even if the translation
+ produced a string with the wrong number of "%s"s. */
+ char *yyp = yyresult;
+ int yyi = 0;
+ while ((*yyp = *yyf) != '\0')
+ {
+ if (*yyp == '%' && yyf[1] == 's' && yyi < yycount)
+ {
+ yyp += yytnamerr (yyp, yyarg[yyi++]);
+ yyf += 2;
+ }
+ else
+ {
+ yyp++;
+ yyf++;
+ }
+ }
+ }
+ return yysize;
+ }
+}
+#endif /* YYERROR_VERBOSE */
+
+
+
+/*-----------------------------------------------.
+| Release the memory associated to this symbol. |
+`-----------------------------------------------*/
+
+/*ARGSUSED*/
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+static void
+yydestruct (const char *yymsg, int yytype, YYSTYPE *yyvaluep)
+#else
+static void
+yydestruct (yymsg, yytype, yyvaluep)
+ const char *yymsg;
+ int yytype;
+ YYSTYPE *yyvaluep;
+#endif
+{
+ YYUSE (yyvaluep);
+
+ if (!yymsg)
+ yymsg = "Deleting";
+ YY_SYMBOL_PRINT (yymsg, yytype, yyvaluep, yylocationp);
+
+ switch (yytype)
+ {
+
+ default:
+ break;
+ }
+}
+
+
+
+/* Prevent warnings from -Wmissing-prototypes. */
+
+#ifdef YYPARSE_PARAM
+#if defined __STDC__ || defined __cplusplus
+int yyparse (void *YYPARSE_PARAM);
+#else
+int yyparse ();
+#endif
+#else /* ! YYPARSE_PARAM */
+#if defined __STDC__ || defined __cplusplus
+int yyparse (void);
+#else
+int yyparse ();
+#endif
+#endif /* ! YYPARSE_PARAM */
+
+
+
+/* The look-ahead symbol. */
+int yychar;
+
+/* The semantic value of the look-ahead symbol. */
+YYSTYPE yylval;
+
+/* Number of syntax errors so far. */
+int yynerrs;
+
+
+
+/*----------.
+| yyparse. |
+`----------*/
+
+#ifdef YYPARSE_PARAM
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+int
+yyparse (void *YYPARSE_PARAM)
+#else
+int
+yyparse (YYPARSE_PARAM)
+ void *YYPARSE_PARAM;
+#endif
+#else /* ! YYPARSE_PARAM */
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+int
+yyparse (void)
+#else
+int
+yyparse ()
+
+#endif
+#endif
+{
+
+ int yystate;
+ int yyn;
+ int yyresult;
+ /* Number of tokens to shift before error messages enabled. */
+ int yyerrstatus;
+ /* Look-ahead token as an internal (translated) token number. */
+ int yytoken = 0;
+#if YYERROR_VERBOSE
+ /* Buffer for error messages, and its allocated size. */
+ char yymsgbuf[128];
+ char *yymsg = yymsgbuf;
+ YYSIZE_T yymsg_alloc = sizeof yymsgbuf;
+#endif
+
+ /* Three stacks and their tools:
+ `yyss': related to states,
+ `yyvs': related to semantic values,
+ `yyls': related to locations.
+
+ Refer to the stacks thru separate pointers, to allow yyoverflow
+ to reallocate them elsewhere. */
+
+ /* The state stack. */
+ yytype_int16 yyssa[YYINITDEPTH];
+ yytype_int16 *yyss = yyssa;
+ yytype_int16 *yyssp;
+
+ /* The semantic value stack. */
+ YYSTYPE yyvsa[YYINITDEPTH];
+ YYSTYPE *yyvs = yyvsa;
+ YYSTYPE *yyvsp;
+
+
+
+#define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N))
+
+ YYSIZE_T yystacksize = YYINITDEPTH;
+
+ /* The variables used to return semantic value and location from the
+ action routines. */
+ YYSTYPE yyval;
+
+
+ /* The number of symbols on the RHS of the reduced rule.
+ Keep to zero when no symbol should be popped. */
+ int yylen = 0;
+
+ YYDPRINTF ((stderr, "Starting parse\n"));
+
+ yystate = 0;
+ yyerrstatus = 0;
+ yynerrs = 0;
+ yychar = YYEMPTY; /* Cause a token to be read. */
+
+ /* Initialize stack pointers.
+ Waste one element of value and location stack
+ so that they stay on the same level as the state stack.
+ The wasted elements are never initialized. */
+
+ yyssp = yyss;
+ yyvsp = yyvs;
+
+ goto yysetstate;
+
+/*------------------------------------------------------------.
+| yynewstate -- Push a new state, which is found in yystate. |
+`------------------------------------------------------------*/
+ yynewstate:
+ /* In all cases, when you get here, the value and location stacks
+ have just been pushed. So pushing a state here evens the stacks. */
+ yyssp++;
+
+ yysetstate:
+ *yyssp = yystate;
+
+ if (yyss + yystacksize - 1 <= yyssp)
+ {
+ /* Get the current used size of the three stacks, in elements. */
+ YYSIZE_T yysize = yyssp - yyss + 1;
+
+#ifdef yyoverflow
+ {
+ /* Give user a chance to reallocate the stack. Use copies of
+ these so that the &'s don't force the real ones into
+ memory. */
+ YYSTYPE *yyvs1 = yyvs;
+ yytype_int16 *yyss1 = yyss;
+
+
+ /* Each stack pointer address is followed by the size of the
+ data in use in that stack, in bytes. This used to be a
+ conditional around just the two extra args, but that might
+ be undefined if yyoverflow is a macro. */
+ yyoverflow (YY_("memory exhausted"),
+ &yyss1, yysize * sizeof (*yyssp),
+ &yyvs1, yysize * sizeof (*yyvsp),
+
+ &yystacksize);
+
+ yyss = yyss1;
+ yyvs = yyvs1;
+ }
+#else /* no yyoverflow */
+# ifndef YYSTACK_RELOCATE
+ goto yyexhaustedlab;
+# else
+ /* Extend the stack our own way. */
+ if (YYMAXDEPTH <= yystacksize)
+ goto yyexhaustedlab;
+ yystacksize *= 2;
+ if (YYMAXDEPTH < yystacksize)
+ yystacksize = YYMAXDEPTH;
+
+ {
+ yytype_int16 *yyss1 = yyss;
+ union yyalloc *yyptr =
+ (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize));
+ if (! yyptr)
+ goto yyexhaustedlab;
+ YYSTACK_RELOCATE (yyss);
+ YYSTACK_RELOCATE (yyvs);
+
+# undef YYSTACK_RELOCATE
+ if (yyss1 != yyssa)
+ YYSTACK_FREE (yyss1);
+ }
+# endif
+#endif /* no yyoverflow */
+
+ yyssp = yyss + yysize - 1;
+ yyvsp = yyvs + yysize - 1;
+
+
+ YYDPRINTF ((stderr, "Stack size increased to %lu\n",
+ (unsigned long int) yystacksize));
+
+ if (yyss + yystacksize - 1 <= yyssp)
+ YYABORT;
+ }
+
+ YYDPRINTF ((stderr, "Entering state %d\n", yystate));
+
+ goto yybackup;
+
+/*-----------.
+| yybackup. |
+`-----------*/
+yybackup:
+
+ /* Do appropriate processing given the current state. Read a
+ look-ahead token if we need one and don't already have one. */
+
+ /* First try to decide what to do without reference to look-ahead token. */
+ yyn = yypact[yystate];
+ if (yyn == YYPACT_NINF)
+ goto yydefault;
+
+ /* Not known => get a look-ahead token if don't already have one. */
+
+ /* YYCHAR is either YYEMPTY or YYEOF or a valid look-ahead symbol. */
+ if (yychar == YYEMPTY)
+ {
+ YYDPRINTF ((stderr, "Reading a token: "));
+ yychar = YYLEX;
+ }
+
+ if (yychar <= YYEOF)
+ {
+ yychar = yytoken = YYEOF;
+ YYDPRINTF ((stderr, "Now at end of input.\n"));
+ }
+ else
+ {
+ yytoken = YYTRANSLATE (yychar);
+ YY_SYMBOL_PRINT ("Next token is", yytoken, &yylval, &yylloc);
+ }
+
+ /* If the proper action on seeing token YYTOKEN is to reduce or to
+ detect an error, take that action. */
+ yyn += yytoken;
+ if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken)
+ goto yydefault;
+ yyn = yytable[yyn];
+ if (yyn <= 0)
+ {
+ if (yyn == 0 || yyn == YYTABLE_NINF)
+ goto yyerrlab;
+ yyn = -yyn;
+ goto yyreduce;
+ }
+
+ if (yyn == YYFINAL)
+ YYACCEPT;
+
+ /* Count tokens shifted since error; after three, turn off error
+ status. */
+ if (yyerrstatus)
+ yyerrstatus--;
+
+ /* Shift the look-ahead token. */
+ YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc);
+
+ /* Discard the shifted token unless it is eof. */
+ if (yychar != YYEOF)
+ yychar = YYEMPTY;
+
+ yystate = yyn;
+ *++yyvsp = yylval;
+
+ goto yynewstate;
+
+
+/*-----------------------------------------------------------.
+| yydefault -- do the default action for the current state. |
+`-----------------------------------------------------------*/
+yydefault:
+ yyn = yydefact[yystate];
+ if (yyn == 0)
+ goto yyerrlab;
+ goto yyreduce;
+
+
+/*-----------------------------.
+| yyreduce -- Do a reduction. |
+`-----------------------------*/
+yyreduce:
+ /* yyn is the number of a rule to reduce with. */
+ yylen = yyr2[yyn];
+
+ /* If YYLEN is nonzero, implement the default value of the action:
+ `$$ = $1'.
+
+ Otherwise, the following line sets YYVAL to garbage.
+ This behavior is undocumented and Bison
+ users should not rely upon it. Assigning to YYVAL
+ unconditionally makes the parser a bit smaller, and it avoids a
+ GCC warning that YYVAL may be used uninitialized. */
+ yyval = yyvsp[1-yylen];
+
+
+ YY_REDUCE_PRINT (yyn);
+ switch (yyn)
+ {
+ case 8:
+#line 344 "fortran.y"
+ {yyerrok;yyclearin;;}
+ break;
+
+ case 13:
+#line 352 "fortran.y"
+ {
+ if (inmoduledeclare == 0 )
+ {
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curinclude,
+ pos_end-pos_curinclude);
+ }
+ ;}
+ break;
+
+ case 18:
+#line 368 "fortran.y"
+ {
+ /* we should ignore the declaration until the keyword */
+ /* TOK_ENDDONOTTREAT */
+ couldaddvariable = 0 ;
+ RemoveWordCUR_0(fortranout,-20,20);
+ ;}
+ break;
+
+ case 19:
+#line 375 "fortran.y"
+ {
+ couldaddvariable = 1 ;
+ RemoveWordCUR_0(fortranout,-24,24);
+ ;}
+ break;
+
+ case 22:
+#line 382 "fortran.y"
+ {pos_cur = setposcur();;}
+ break;
+
+ case 27:
+#line 394 "fortran.y"
+ {if (incom !=1) {strcpy(curbuf,"");incom=0;};}
+ break;
+
+ case 28:
+#line 397 "fortran.y"
+ {isrecursive = 0;;}
+ break;
+
+ case 29:
+#line 399 "fortran.y"
+ {isrecursive = 1;;}
+ break;
+
+ case 31:
+#line 403 "fortran.y"
+ {
+ if ( couldaddvariable == 1)
+ {
+ /* open param file */
+ if ( firstpass == 0 )
+ {
+ sprintf(ligne,"%s/ParamFile%s.h",nomdir,(yyvsp[(3) - (4)].nac));
+ paramout=fopen(ligne,"w");
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+
+ }
+ Add_SubroutineArgument_Var_1((yyvsp[(4) - (4)].l));
+ if ( inmodulemeet == 1 )
+ {
+ insubroutinedeclare = 1;
+ /* in the second step we should write the head of */
+ /* the subroutine sub_loop_ */
+ writeheadnewsub_0(1);
+ }
+ else
+ {
+ insubroutinedeclare = 1;
+ writeheadnewsub_0(1);
+ }
+ }
+ ;}
+ break;
+
+ case 32:
+#line 431 "fortran.y"
+ {
+ /* open param file */
+ if ( firstpass == 0 )
+ {
+ sprintf(ligne,"%s/ParamFile%s.h",nomdir,(yyvsp[(2) - (2)].nac));
+ paramout=fopen(ligne,"w");
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+
+ }
+ strcpy(subroutinename,(yyvsp[(2) - (2)].nac));
+ /* Common case */
+ insubroutinedeclare = 1;
+ /* in the second step we should write the head of */
+ /* the subroutine sub_loop_ */
+ writeheadnewsub_0(1);
+ ;}
+ break;
+
+ case 33:
+#line 449 "fortran.y"
+ {
+ /* open param file */
+ if ( firstpass == 0 )
+ {
+ sprintf(ligne,"%s/ParamFile%s.h",nomdir,(yyvsp[(3) - (6)].nac));
+ paramout=fopen(ligne,"w");
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+ }
+ strcpy(subroutinename,(yyvsp[(3) - (6)].nac));
+ if ( inmodulemeet == 1 )
+ {
+ insubroutinedeclare = 1;
+ /* we should to list of the subroutine argument the */
+ /* name of the function which has to be defined */
+ Add_SubroutineArgument_Var_1((yyvsp[(4) - (6)].l));
+ strcpy(DeclType,"");
+ /* in the second step we should write the head of */
+ /* the subroutine sub_loop_ */
+ writeheadnewsub_0(2);
+ }
+ else
+ {
+ insubroutinedeclare = 1;
+ /* we should to list of the subroutine argument */
+ /* name of the function which has to be defined */
+ Add_SubroutineArgument_Var_1((yyvsp[(4) - (6)].l));
+ strcpy(DeclType,"");
+ Add_FunctionType_Var_1((yyvsp[(3) - (6)].nac));
+ writeheadnewsub_0(2);
+ }
+ ;}
+ break;
+
+ case 34:
+#line 482 "fortran.y"
+ {
+ /* open param file */
+ if ( firstpass == 0 )
+ {
+ sprintf(ligne,"%s/ParamFile%s.h",nomdir,(yyvsp[(3) - (4)].nac));
+ paramout=fopen(ligne,"w");
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+ }
+ strcpy(subroutinename,(yyvsp[(3) - (4)].nac));
+ if ( inmodulemeet == 1 )
+ {
+ insubroutinedeclare = 1;
+ /* we should to list of the subroutine argument the */
+ /* name of the function which has to be defined */
+ Add_SubroutineArgument_Var_1((yyvsp[(4) - (4)].l));
+ strcpy(DeclType,"");
+ Add_FunctionType_Var_1((yyvsp[(3) - (4)].nac));
+ /* in the second step we should write the head of */
+ /* the subroutine sub_loop_ */
+ writeheadnewsub_0(2);
+ }
+ else
+ {
+ insubroutinedeclare = 1;
+ /* we should to list of the subroutine argument */
+ /* name of the function which has to be defined */
+ Add_SubroutineArgument_Var_1((yyvsp[(4) - (4)].l));
+ strcpy(DeclType,"");
+ Add_FunctionType_Var_1((yyvsp[(3) - (4)].nac));
+ writeheadnewsub_0(2);
+ }
+ ;}
+ break;
+
+ case 35:
+#line 516 "fortran.y"
+ {
+ GlobalDeclaration = 0;
+ strcpy(curmodulename,(yyvsp[(2) - (2)].nac));
+ strcpy(subroutinename,"");
+ Add_NameOfModule_1((yyvsp[(2) - (2)].nac));
+ if ( inmoduledeclare == 0 )
+ {
+ /* To know if there are in the module declaration */
+ inmoduledeclare = 1;
+ /* to know if a module has been met */
+ inmodulemeet = 1;
+ /* to know if we are after the keyword contains */
+ aftercontainsdeclare = 0 ;
+ }
+ ;}
+ break;
+
+ case 36:
+#line 533 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));strcpy(subroutinename,(yyvsp[(1) - (1)].nac));
+ }
+ ;}
+ break;
+
+ case 38:
+#line 542 "fortran.y"
+ {
+ pos_curinclude = setposcur()-9;
+ ;}
+ break;
+
+ case 39:
+#line 546 "fortran.y"
+ {
+ if ( couldaddvariable == 1 ) Add_Include_1((yyvsp[(1) - (1)].nac));
+ ;}
+ break;
+
+ case 40:
+#line 550 "fortran.y"
+ {
+ if ( firstpass == 1 && couldaddvariable == 1) (yyval.l)=NULL;
+ ;}
+ break;
+
+ case 41:
+#line 553 "fortran.y"
+ {
+ if ( firstpass == 1 && couldaddvariable == 1 ) (yyval.l)=NULL;
+ ;}
+ break;
+
+ case 42:
+#line 557 "fortran.y"
+ {
+ if ( firstpass == 1 && couldaddvariable == 1 ) (yyval.l)=(yyvsp[(2) - (3)].l);
+ ;}
+ break;
+
+ case 45:
+#line 564 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ Add_SubroutineArgument_Var_1((yyvsp[(2) - (3)].l));
+ }
+ ;}
+ break;
+
+ case 46:
+#line 571 "fortran.y"
+ {
+ if ( firstpass == 1 && couldaddvariable == 1)
+ {
+ strcpy(nameinttypenameback,nameinttypename);
+ strcpy(nameinttypename,"");
+ curvar=createvar((yyvsp[(1) - (1)].na),NULL);
+ strcpy(nameinttypename,nameinttypenameback);
+ curlistvar=insertvar(NULL,curvar);
+ (yyval.l)=settype("",curlistvar);
+ }
+ ;}
+ break;
+
+ case 47:
+#line 583 "fortran.y"
+ {
+ if ( firstpass == 1 && couldaddvariable == 1)
+ {
+ strcpy(nameinttypenameback,nameinttypename);
+ strcpy(nameinttypename,"");
+ curvar=createvar((yyvsp[(3) - (3)].na),NULL);
+ strcpy(nameinttypename,nameinttypenameback);
+ (yyval.l)=insertvar((yyvsp[(1) - (3)].l),curvar);
+ }
+ ;}
+ break;
+
+ case 48:
+#line 594 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),(yyvsp[(1) - (1)].nac));;}
+ break;
+
+ case 49:
+#line 595 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),"*");;}
+ break;
+
+ case 50:
+#line 598 "fortran.y"
+ {
+ if ( VarTypepar == 1 )
+ {
+ couldaddvariable = 1 ;
+ VarTypepar = 0;
+ }
+ ;}
+ break;
+
+ case 51:
+#line 606 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ VarType = 1;
+ couldaddvariable = 0 ;
+ }
+ ;}
+ break;
+
+ case 52:
+#line 614 "fortran.y"
+ {
+ if ( VarType == 1 ) couldaddvariable = 1 ;
+ VarType = 0;
+ VarTypepar = 0;
+ ;}
+ break;
+
+ case 54:
+#line 621 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ if ( insubroutinedeclare == 0 )
+ {
+ Add_GlobalParameter_Var_1((yyvsp[(3) - (4)].l));
+ }
+ else Add_Parameter_Var_1((yyvsp[(3) - (4)].l));
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_cur_decl,
+ pos_end-pos_cur_decl);
+ }
+ VariableIsParameter = 0 ;
+ ;}
+ break;
+
+ case 55:
+#line 636 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ if ( insubroutinedeclare == 0 )
+ Add_GlobalParameter_Var_1((yyvsp[(2) - (2)].l));
+ else Add_Parameter_Var_1((yyvsp[(2) - (2)].l));
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_cur_decl,
+ pos_end-pos_cur_decl);
+ }
+ VariableIsParameter = 0 ;
+ ;}
+ break;
+
+ case 57:
+#line 650 "fortran.y"
+ {
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_cursave,
+ pos_end-pos_cursave);
+ ;}
+ break;
+
+ case 59:
+#line 657 "fortran.y"
+ {
+ /* if the variable is a parameter we can suppose that is */
+ /* value is the same on each grid. It is not useless to */
+ /* create a copy of it on each grid */
+ if ( couldaddvariable == 1 )
+ {
+ Add_Globliste_1((yyvsp[(1) - (1)].l));
+ /* if variableparamlists has been declared in a */
+ /* subroutine */
+ if ( insubroutinedeclare == 1 )
+ {
+ Add_Dimension_Var_1((yyvsp[(1) - (1)].l));
+ }
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curdimension,
+ pos_end-pos_curdimension);
+ }
+ /* */
+ PublicDeclare = 0;
+ PrivateDeclare = 0;
+ ExternalDeclare = 0;
+ strcpy(NamePrecision,"");
+ c_star = 0;
+ strcpy(InitialValueGiven," ");
+ strcpy(IntentSpec,"");
+ VariableIsParameter = 0 ;
+ Allocatabledeclare = 0 ;
+ Targetdeclare = 0 ;
+ SaveDeclare = 0;
+ pointerdeclare = 0;
+ optionaldeclare = 0 ;
+ dimsgiven=0;
+ c_selectorgiven=0;
+ strcpy(nameinttypename,"");
+ strcpy(c_selectorname,"");
+ ;}
+ break;
+
+ case 60:
+#line 694 "fortran.y"
+ {
+ if (firstpass == 0)
+ {
+ if ((yyvsp[(1) - (1)].lnn))
+ {
+ removeglobfromlist(&((yyvsp[(1) - (1)].lnn)));
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_cur,pos_end-pos_cur);
+ writelistpublic((yyvsp[(1) - (1)].lnn));
+ }
+ }
+ ;}
+ break;
+
+ case 70:
+#line 716 "fortran.y"
+ {
+ /* we should remove the data declaration */
+ if ( couldaddvariable == 1 && aftercontainsdeclare != 2 )
+ {
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curdata,
+ pos_end-pos_curdata);
+ }
+ if ( couldaddvariable == 1 && aftercontainsdeclare == 1 )
+ {
+ if (firstpass == 0)
+ {
+ ReWriteDataStatement_0(fortranout);
+ pos_end = setposcur();
+ }
+ }
+ ;}
+ break;
+
+ case 72:
+#line 736 "fortran.y"
+ {
+ PublicDeclare = 0 ;
+ PrivateDeclare = 0 ;
+ ;}
+ break;
+
+ case 110:
+#line 787 "fortran.y"
+ {
+ /* if the variable is a parameter we can suppose that is*/
+ /* value is the same on each grid. It is not useless */
+ /* to create a copy of it on each grid */
+ if ( couldaddvariable == 1 )
+ {
+ pos_end = setposcur();
+ /*if (insubroutinedeclare == 0)
+ { */
+ RemoveWordSET_0(fortranout,pos_cur_decl,
+ pos_end-pos_cur_decl);
+
+ /* }
+ else
+ {*/
+ ReWriteDeclarationAndAddTosubroutine_01((yyvsp[(1) - (2)].l));
+ pos_cur_decl = setposcur();
+
+ /*}*/
+ if ( firstpass == 0 &&
+ GlobalDeclaration == 0 &&
+ insubroutinedeclare == 0 )
+ {
+
+ sprintf(ligne,"\n#include \"Module_Declar_%s.h\"\n"
+ ,curmodulename);
+ tofich(fortranout,ligne,1);
+ sprintf (ligne, "Module_Declar_%s.h",curmodulename);
+ module_declar = associate(ligne);
+ sprintf (ligne, " ");
+ tofich (module_declar, ligne,1);
+ GlobalDeclaration = 1 ;
+ pos_cur_decl = setposcur();
+
+ }
+ (yyval.l) = (yyvsp[(1) - (2)].l);
+ Add_Globliste_1((yyvsp[(1) - (2)].l));
+
+ if ( insubroutinedeclare == 0 )
+ Add_GlobalParameter_Var_1((yyvsp[(1) - (2)].l));
+ else
+ {
+ if ( pointerdeclare == 1 )
+ Add_Pointer_Var_From_List_1((yyvsp[(1) - (2)].l));
+ Add_Parameter_Var_1((yyvsp[(1) - (2)].l));
+ }
+
+ /* if variables has been declared in a subroutine */
+ if ( insubroutinedeclare == 1 )
+ {
+ /* Add_SubroutineDeclaration_Var_1($1);*/
+ }
+ /* If there are a SAVE declarations in module's */
+ /* subroutines we should remove it from the */
+ /* subroutines declaration and add it in the */
+ /* global declarations */
+ if ( aftercontainsdeclare == 1 &&
+ SaveDeclare == 1 && firstpass == 1 )
+ {
+ if ( inmodulemeet == 0 ) Add_Save_Var_dcl_1((yyvsp[(1) - (2)].l));
+ else Add_SubroutineDeclarationSave_Var_1((yyvsp[(1) - (2)].l));
+ }
+ }
+ /* */
+ PublicDeclare = 0;
+ PrivateDeclare = 0;
+ ExternalDeclare = 0;
+ strcpy(NamePrecision,"");
+ c_star = 0;
+ strcpy(InitialValueGiven," ");
+ strcpy(IntentSpec,"");
+ VariableIsParameter = 0 ;
+ Allocatabledeclare = 0 ;
+ Targetdeclare = 0 ;
+ SaveDeclare = 0;
+ pointerdeclare = 0;
+ optionaldeclare = 0 ;
+ dimsgiven=0;
+ c_selectorgiven=0;
+ strcpy(nameinttypename,"");
+ strcpy(c_selectorname,"");
+ GlobalDeclarationType = 0;
+ ;}
+ break;
+
+ case 111:
+#line 871 "fortran.y"
+ {
+ /* open param file */
+ if ( firstpass == 0 )
+ {
+ sprintf(ligne,"%s/ParamFile%s.h",nomdir,(yyvsp[(2) - (3)].nac));
+ paramout=fopen(ligne,"w");
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+ }
+ strcpy(subroutinename,(yyvsp[(2) - (3)].nac));
+ if ( inmodulemeet == 1 )
+ {
+ insubroutinedeclare = 1;
+ /* we should to list of the subroutine argument the */
+ /* name of the function which has to be defined */
+ Add_SubroutineArgument_Var_1((yyvsp[(3) - (3)].l));
+ Add_FunctionType_Var_1((yyvsp[(2) - (3)].nac));
+ /* in the second step we should write the head of */
+ /* the subroutine sub_loop_ */
+ writeheadnewsub_0(2);
+ }
+ else
+ {
+ insubroutinedeclare = 1;
+ /* we should to list of the subroutine argument the */
+ /* name of the function which has to be defined */
+ Add_SubroutineArgument_Var_1((yyvsp[(3) - (3)].l));
+ Add_FunctionType_Var_1((yyvsp[(2) - (3)].nac));
+ /* in the second step we should write the head of */
+ /* the subroutine sub_loop_ */
+ writeheadnewsub_0(2);
+ }
+ strcpy(nameinttypename,"");
+
+ ;}
+ break;
+
+ case 112:
+#line 908 "fortran.y"
+ {
+ functiondeclarationisdone = 1;
+ ;}
+ break;
+
+ case 113:
+#line 914 "fortran.y"
+ {
+ VariableIsParameter = 1;
+ pos_curparameter = setposcur()-9;
+ ;}
+ break;
+
+ case 114:
+#line 919 "fortran.y"
+ {
+ pos_curdata = setposcur()-strlen((yyvsp[(1) - (1)].nac));
+ Init_List_Data_Var();
+ ;}
+ break;
+
+ case 115:
+#line 924 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+/* if ( aftercontainsdeclare == 1 ) strcpy(ligne,"");
+ else */
+/* sprintf(ligne,"%s",$3);*/
+ createstringfromlistname(ligne,(yyvsp[(3) - (4)].lnn));
+ if (firstpass == 1)
+ Add_Data_Var_1(&List_Data_Var,(yyvsp[(1) - (4)].nac),ligne);
+ else
+ Add_Data_Var_1(&List_Data_Var_Cur,(yyvsp[(1) - (4)].nac),ligne);
+ }
+ ;}
+ break;
+
+ case 116:
+#line 938 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /*if ( aftercontainsdeclare == 1 ) strcpy(ligne,"");
+ else */
+ /*sprintf(ligne,"%s",$5); */
+ createstringfromlistname(ligne,(yyvsp[(5) - (6)].lnn));
+ if (firstpass == 1)
+ Add_Data_Var_1(&List_Data_Var,(yyvsp[(3) - (6)].nac),ligne);
+ else
+ Add_Data_Var_1(&List_Data_Var_Cur,(yyvsp[(3) - (6)].nac),ligne);
+ }
+ ;}
+ break;
+
+ case 117:
+#line 952 "fortran.y"
+ {
+ /*******************************************************/
+ /*******************************************************/
+ /*******************************************************/
+ /*******************************************************/
+ /*******************************************************/
+ /*******************************************************/
+ /*******************************************************/
+ if (firstpass == 1)
+ Add_Data_Var_Names_01(&List_Data_Var,(yyvsp[(1) - (4)].lnn),(yyvsp[(3) - (4)].lnn));
+ else
+ Add_Data_Var_Names_01(&List_Data_Var_Cur,(yyvsp[(1) - (4)].lnn),(yyvsp[(3) - (4)].lnn));
+ ;}
+ break;
+
+ case 118:
+#line 967 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ (yyval.lnn) = Insertname(NULL,(yyvsp[(1) - (1)].na),0);
+ }
+ ;}
+ break;
+
+ case 119:
+#line 974 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ (yyval.lnn) = Insertname((yyvsp[(3) - (3)].lnn),(yyvsp[(1) - (3)].na),1);
+ }
+ ;}
+ break;
+
+ case 124:
+#line 988 "fortran.y"
+ {
+ pos_cursave = setposcur()-4;
+ ;}
+ break;
+
+ case 126:
+#line 994 "fortran.y"
+ {
+ if ( couldaddvariable == 1 ) Add_Save_Var_1((yyvsp[(1) - (2)].nac),(yyvsp[(2) - (2)].d));
+ ;}
+ break;
+
+ case 127:
+#line 999 "fortran.y"
+ {
+ (yyval.lnn)=Insertname(NULL,(yyvsp[(1) - (1)].nac),0);
+ ;}
+ break;
+
+ case 128:
+#line 1003 "fortran.y"
+ {
+ printf("INSTRUCTION NON TRAITEE : INITIALISATION DE DATA AVEC EXPRESSION\n");
+ exit(0);
+ ;}
+ break;
+
+ case 129:
+#line 1008 "fortran.y"
+ {
+ (yyval.lnn) = concat_listname((yyvsp[(1) - (3)].lnn),(yyvsp[(3) - (3)].lnn));
+ ;}
+ break;
+
+ case 130:
+#line 1013 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].nac),(yyvsp[(2) - (2)].nac));;}
+ break;
+
+ case 131:
+#line 1015 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s+%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na));;}
+ break;
+
+ case 132:
+#line 1017 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s-%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na));;}
+ break;
+
+ case 133:
+#line 1019 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s*%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na));;}
+ break;
+
+ case 134:
+#line 1021 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s/%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na));;}
+ break;
+
+ case 135:
+#line 1024 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.nac),"");;}
+ break;
+
+ case 136:
+#line 1026 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));;}
+ break;
+
+ case 143:
+#line 1038 "fortran.y"
+ {
+ ininterfacedeclare = 1 ;
+ printf("INTEFACE entree\n");
+ ;}
+ break;
+
+ case 144:
+#line 1043 "fortran.y"
+ {
+ ininterfacedeclare = 0;
+ ;}
+ break;
+
+ case 145:
+#line 1048 "fortran.y"
+ {
+ positioninblock=0;
+ pos_curdimension = setposcur()-9;
+ ;}
+ break;
+
+ case 146:
+#line 1054 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* */
+ curvar=createvar((yyvsp[(3) - (5)].nac),(yyvsp[(4) - (5)].d));
+ /* */
+ CreateAndFillin_Curvar("",curvar);
+ /* */
+ curlistvar=insertvar(NULL,curvar);
+ /* */
+ (yyval.l)=settype("",curlistvar);
+ /* */
+ strcpy(vallengspec,"");
+ }
+ ;}
+ break;
+
+ case 147:
+#line 1070 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* */
+ curvar=createvar((yyvsp[(3) - (5)].nac),(yyvsp[(4) - (5)].d));
+ /* */
+ CreateAndFillin_Curvar("",curvar);
+ /* */
+ curlistvar=insertvar((yyvsp[(1) - (5)].l),curvar);
+ /* */
+ (yyval.l)=curlistvar;
+ /* */
+ strcpy(vallengspec,"");
+ }
+ ;}
+ break;
+
+ case 150:
+#line 1090 "fortran.y"
+ {
+ (yyval.lnn)=(listname *)NULL;
+ ;}
+ break;
+
+ case 151:
+#line 1094 "fortran.y"
+ {
+ (yyval.lnn)=(yyvsp[(3) - (3)].lnn);
+ ;}
+ break;
+
+ case 152:
+#line 1099 "fortran.y"
+ {
+ (yyval.lnn) = Insertname(NULL,(yyvsp[(1) - (1)].nac),0);
+ ;}
+ break;
+
+ case 153:
+#line 1103 "fortran.y"
+ {
+ (yyval.lnn) = Insertname((yyvsp[(1) - (3)].lnn),(yyvsp[(3) - (3)].nac),0);
+ ;}
+ break;
+
+ case 154:
+#line 1108 "fortran.y"
+ {
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curcommon,
+ pos_end-pos_curcommon);
+ ;}
+ break;
+
+ case 155:
+#line 1114 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ sprintf(charusemodule,"%s",(yyvsp[(2) - (3)].nac));
+ Add_NameOfCommon_1((yyvsp[(2) - (3)].nac),subroutinename);
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curcommon,
+ pos_end-pos_curcommon);
+ }
+ ;}
+ break;
+
+ case 156:
+#line 1125 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ sprintf(charusemodule,"%s",(yyvsp[(3) - (5)].nac));
+ Add_NameOfCommon_1((yyvsp[(3) - (5)].nac),subroutinename);
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curcommon,
+ pos_end-pos_curcommon);
+ }
+ ;}
+ break;
+
+ case 157:
+#line 1137 "fortran.y"
+ {
+ positioninblock=0;
+ pos_curcommon = setposcur()-6;
+ ;}
+ break;
+
+ case 158:
+#line 1142 "fortran.y"
+ {
+ positioninblock=0;
+ pos_curcommon = setposcur()-6-7;
+ ;}
+ break;
+
+ case 159:
+#line 1148 "fortran.y"
+ {
+ if ( couldaddvariable == 1 ) Add_Common_var_1();
+ ;}
+ break;
+
+ case 160:
+#line 1153 "fortran.y"
+ {
+ if ( couldaddvariable == 1 ) Add_Common_var_1();
+ ;}
+ break;
+
+ case 161:
+#line 1157 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ positioninblock = positioninblock + 1 ;
+ strcpy(commonvar,(yyvsp[(1) - (2)].nac));
+ commondim = (yyvsp[(2) - (2)].d);
+ }
+ ;}
+ break;
+
+ case 162:
+#line 1167 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy((yyval.nac),"");
+ positioninblock=0;
+ strcpy(commonblockname,"");
+ }
+ ;}
+ break;
+
+ case 163:
+#line 1176 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy((yyval.nac),(yyvsp[(2) - (3)].nac));
+ positioninblock=0;
+ strcpy(commonblockname,(yyvsp[(2) - (3)].nac));
+ }
+ ;}
+ break;
+
+ case 166:
+#line 1189 "fortran.y"
+ {
+ if ( couldaddvariable == 1 ) (yyval.l)=insertvar(NULL,(yyvsp[(1) - (1)].v));
+ ;}
+ break;
+
+ case 167:
+#line 1193 "fortran.y"
+ {
+ if ( couldaddvariable == 1 ) (yyval.l)=insertvar((yyvsp[(1) - (3)].l),(yyvsp[(3) - (3)].v));
+ ;}
+ break;
+
+ case 168:
+#line 1198 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ curvar=(variable *) malloc(sizeof(variable));
+ /* */
+ Init_Variable(curvar);
+ /* */
+ curvar->v_VariableIsParameter=1;
+ strcpy(curvar->v_nomvar,(yyvsp[(1) - (3)].nac));
+ Save_Length((yyvsp[(1) - (3)].nac),4);
+ strcpy(curvar->v_subroutinename,subroutinename);
+ Save_Length(subroutinename,11);
+ strcpy(curvar->v_modulename,curmodulename);
+ Save_Length(curmodulename,6);
+ strcpy(curvar->v_initialvalue,(yyvsp[(3) - (3)].na));
+ Save_Length((yyvsp[(3) - (3)].na),14);
+ strcpy(curvar->v_commoninfile,mainfile);
+ Save_Length(mainfile,10);
+ (yyval.v)=curvar;
+ }
+ ;}
+ break;
+
+ case 172:
+#line 1226 "fortran.y"
+ {
+ if ( insubroutinedeclare == 1 )
+ {
+ Add_ImplicitNoneSubroutine_1();
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_end-13,
+ 13);
+ }
+ ;}
+ break;
+
+ case 175:
+#line 1240 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* */
+ if (dimsgiven == 1)
+ {
+ curvar=createvar((yyvsp[(3) - (6)].nac),curdim);
+ GlobalDeclarationType == 0;
+ }
+ else
+ {
+ curvar=createvar((yyvsp[(3) - (6)].nac),(yyvsp[(4) - (6)].d));
+ }
+ /* */
+ CreateAndFillin_Curvar(DeclType,curvar);
+ /* */
+ curlistvar=insertvar(NULL,curvar);
+ if (!strcasecmp(DeclType,"character"))
+ {
+ if (c_selectorgiven == 1)
+ {
+ strcpy(c_selectordim.first,"1");
+ strcpy(c_selectordim.last,c_selectorname);
+ Save_Length(c_selectorname,1);
+ change_dim_char
+ (insertdim(NULL,c_selectordim),curlistvar);
+ }
+ }
+ (yyval.l)=settype(DeclType,curlistvar);
+ }
+ strcpy(vallengspec,"");
+ ;}
+ break;
+
+ case 176:
+#line 1273 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ if (dimsgiven == 1)
+ {
+ curvar=createvar((yyvsp[(4) - (7)].nac),curdim);
+ }
+ else
+ {
+ curvar=createvar((yyvsp[(4) - (7)].nac),(yyvsp[(5) - (7)].d));
+ }
+ /* */
+ CreateAndFillin_Curvar((yyvsp[(1) - (7)].l)->var->v_typevar,curvar);
+ /* */
+ strcpy(curvar->v_typevar,((yyvsp[(1) - (7)].l)->var->v_typevar));
+ Save_Length((yyvsp[(1) - (7)].l)->var->v_typevar,3);
+ /* */
+ curlistvar=insertvar((yyvsp[(1) - (7)].l),curvar);
+ if (!strcasecmp(DeclType,"character"))
+ {
+ if (c_selectorgiven == 1)
+ {
+ strcpy(c_selectordim.first,"1");
+ strcpy(c_selectordim.last,c_selectorname);
+ Save_Length(c_selectorname,1);
+ change_dim_char
+ (insertdim(NULL,c_selectordim),curlistvar);
+ }
+ }
+ (yyval.l)=curlistvar;
+ }
+ strcpy(vallengspec,"");
+ ;}
+ break;
+
+ case 177:
+#line 1307 "fortran.y"
+ {dimsgiven=0;;}
+ break;
+
+ case 178:
+#line 1310 "fortran.y"
+ {strcpy(DeclType,(yyvsp[(1) - (2)].nac));;}
+ break;
+
+ case 179:
+#line 1312 "fortran.y"
+ {
+ strcpy(DeclType,"CHARACTER");
+ ;}
+ break;
+
+ case 180:
+#line 1316 "fortran.y"
+ {
+ strcpy(DeclType,(yyvsp[(1) - (3)].nac));
+ strcpy(nameinttypename,(yyvsp[(3) - (3)].nac));
+ ;}
+ break;
+
+ case 181:
+#line 1321 "fortran.y"
+ {
+ strcpy(DeclType,"TYPE");
+ GlobalDeclarationType = 1
+ ;}
+ break;
+
+ case 182:
+#line 1327 "fortran.y"
+ {
+ /* if ( couldaddvariable == 1 ) VarTypepar = 1 ;
+ couldaddvariable = 0 ;
+ pos_cur_decl = setposcur()-5;*/
+ pos_cur_decl = setposcur()-5;
+ ;}
+ break;
+
+ case 184:
+#line 1336 "fortran.y"
+ {c_selectorgiven=1;strcpy(c_selectorname,(yyvsp[(2) - (2)].nac));;}
+ break;
+
+ case 185:
+#line 1337 "fortran.y"
+ {c_star = 1;;}
+ break;
+
+ case 190:
+#line 1345 "fortran.y"
+ {
+ pos_cur_decl = setposcur()-9;
+ ;}
+ break;
+
+ case 191:
+#line 1349 "fortran.y"
+ {strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));;}
+ break;
+
+ case 192:
+#line 1352 "fortran.y"
+ {
+ strcpy((yyval.nac),"INTEGER");
+ pos_cur_decl = setposcur()-7;
+ ;}
+ break;
+
+ case 193:
+#line 1356 "fortran.y"
+ {
+ strcpy((yyval.nac),"REAL");
+ pos_cur_decl = setposcur()-4;
+ ;}
+ break;
+
+ case 194:
+#line 1361 "fortran.y"
+ {strcpy((yyval.nac),"COMPLEX");
+ pos_cur_decl = setposcur()-7;;}
+ break;
+
+ case 195:
+#line 1364 "fortran.y"
+ {
+ pos_cur_decl = setposcur()-16;
+ strcpy((yyval.nac),"REAL");
+ strcpy(nameinttypename,"8");
+ ;}
+ break;
+
+ case 196:
+#line 1370 "fortran.y"
+ {strcpy((yyval.nac),"DOUBLE COMPLEX");;}
+ break;
+
+ case 197:
+#line 1372 "fortran.y"
+ {
+ strcpy((yyval.nac),"LOGICAL");
+ pos_cur_decl = setposcur()-7;
+ ;}
+ break;
+
+ case 199:
+#line 1378 "fortran.y"
+ {strcpy(vallengspec,(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 200:
+#line 1380 "fortran.y"
+ {sprintf((yyval.na),"*%s",(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 201:
+#line 1381 "fortran.y"
+ {strcpy((yyval.na),"*(*)");;}
+ break;
+
+ case 208:
+#line 1392 "fortran.y"
+ {
+ if ( strstr((yyvsp[(3) - (3)].na),"0.d0") )
+ {
+ strcpy(nameinttypename,"8");
+ sprintf(NamePrecision,"");
+ }
+ else sprintf(NamePrecision,"%s = %s",(yyvsp[(1) - (3)].nac),(yyvsp[(3) - (3)].na));
+ ;}
+ break;
+
+ case 209:
+#line 1401 "fortran.y"
+ {
+ strcpy(NamePrecision,(yyvsp[(1) - (1)].nac));
+ ;}
+ break;
+
+ case 210:
+#line 1405 "fortran.y"
+ {
+ strcpy(NamePrecision,(yyvsp[(1) - (1)].nac));
+ ;}
+ break;
+
+ case 211:
+#line 1409 "fortran.y"
+ {strcpy(CharacterSize,(yyvsp[(1) - (1)].na));
+ strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 212:
+#line 1411 "fortran.y"
+ {strcpy(CharacterSize,"*");
+ strcpy((yyval.na),"*");;}
+ break;
+
+ case 220:
+#line 1425 "fortran.y"
+ {
+ VariableIsParameter = 1;
+ ;}
+ break;
+
+ case 222:
+#line 1430 "fortran.y"
+ {Allocatabledeclare = 1;;}
+ break;
+
+ case 223:
+#line 1432 "fortran.y"
+ {
+ dimsgiven=1;
+ curdim=(yyvsp[(2) - (2)].d);
+ ;}
+ break;
+
+ case 224:
+#line 1437 "fortran.y"
+ {ExternalDeclare = 1;;}
+ break;
+
+ case 225:
+#line 1439 "fortran.y"
+ {strcpy(IntentSpec,(yyvsp[(3) - (4)].nac));;}
+ break;
+
+ case 227:
+#line 1441 "fortran.y"
+ {optionaldeclare = 1 ;;}
+ break;
+
+ case 228:
+#line 1442 "fortran.y"
+ {pointerdeclare = 1 ;;}
+ break;
+
+ case 229:
+#line 1443 "fortran.y"
+ {
+/* if ( inmodulemeet == 1 )
+ {*/
+ SaveDeclare = 1 ;
+ /* }*/
+ ;}
+ break;
+
+ case 230:
+#line 1450 "fortran.y"
+ {Targetdeclare = 1;;}
+ break;
+
+ case 231:
+#line 1452 "fortran.y"
+ {strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));;}
+ break;
+
+ case 232:
+#line 1453 "fortran.y"
+ {strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));;}
+ break;
+
+ case 233:
+#line 1454 "fortran.y"
+ {strcpy((yyval.nac),(yyvsp[(1) - (1)].nac)); ;}
+ break;
+
+ case 234:
+#line 1457 "fortran.y"
+ {PublicDeclare = 1;;}
+ break;
+
+ case 235:
+#line 1459 "fortran.y"
+ {PrivateDeclare = 1;;}
+ break;
+
+ case 236:
+#line 1461 "fortran.y"
+ {if ( created_dimensionlist == 1 )
+ {
+ (yyval.d)=(listdim *)NULL;
+ }
+ ;}
+ break;
+
+ case 237:
+#line 1467 "fortran.y"
+ {if ( created_dimensionlist == 1 ||
+ agrif_parentcall == 1 ) (yyval.d)=(yyvsp[(2) - (3)].d);;}
+ break;
+
+ case 238:
+#line 1470 "fortran.y"
+ {if ( created_dimensionlist == 1 ||
+ agrif_parentcall == 1 ) (yyval.d)=insertdim(NULL,(yyvsp[(1) - (1)].dim1));;}
+ break;
+
+ case 239:
+#line 1473 "fortran.y"
+ {if ( couldaddvariable == 1 )
+ if ( created_dimensionlist == 1 ) (yyval.d)=insertdim((yyvsp[(1) - (3)].d),(yyvsp[(3) - (3)].dim1));;}
+ break;
+
+ case 240:
+#line 1476 "fortran.y"
+ {
+ strcpy((yyval.dim1).first,"1");
+ strcpy((yyval.dim1).last,(yyvsp[(1) - (1)].na));
+ Save_Length((yyvsp[(1) - (1)].na),1);
+ ;}
+ break;
+
+ case 241:
+#line 1481 "fortran.y"
+ {
+ strcpy((yyval.dim1).first,"");
+ strcpy((yyval.dim1).last,"");
+ ;}
+ break;
+
+ case 242:
+#line 1485 "fortran.y"
+ {
+ strcpy((yyval.dim1).first,(yyvsp[(1) - (2)].na));
+ Save_Length((yyvsp[(1) - (2)].na),2);
+ strcpy((yyval.dim1).last,"");
+ ;}
+ break;
+
+ case 243:
+#line 1490 "fortran.y"
+ {
+ strcpy((yyval.dim1).first,"");
+ strcpy((yyval.dim1).last,(yyvsp[(2) - (2)].na));
+ Save_Length((yyvsp[(2) - (2)].na),1);
+ ;}
+ break;
+
+ case 244:
+#line 1496 "fortran.y"
+ {
+ strcpy((yyval.dim1).first,(yyvsp[(1) - (3)].na));
+ Save_Length((yyvsp[(1) - (3)].na),2);
+ strcpy((yyval.dim1).last,(yyvsp[(3) - (3)].na));
+ Save_Length((yyvsp[(3) - (3)].na),1);
+ ;}
+ break;
+
+ case 245:
+#line 1503 "fortran.y"
+ {strcpy((yyval.na),"*");;}
+ break;
+
+ case 246:
+#line 1504 "fortran.y"
+ {strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 247:
+#line 1506 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 248:
+#line 1508 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"(%s)",(yyvsp[(2) - (3)].na));;}
+ break;
+
+ case 249:
+#line 1510 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 250:
+#line 1512 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 251:
+#line 1516 "fortran.y"
+ {sprintf((yyval.na),"SUM(%s)",(yyvsp[(2) - (3)].na));;}
+ break;
+
+ case 252:
+#line 1518 "fortran.y"
+ {sprintf((yyval.na),"MAX(%s)",(yyvsp[(2) - (3)].na));;}
+ break;
+
+ case 253:
+#line 1520 "fortran.y"
+ {sprintf((yyval.na),"TANH(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 254:
+#line 1522 "fortran.y"
+ {sprintf((yyval.na),"MAXVAL(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 255:
+#line 1524 "fortran.y"
+ {sprintf((yyval.na),"MIN(%s)",(yyvsp[(2) - (3)].na));;}
+ break;
+
+ case 256:
+#line 1526 "fortran.y"
+ {sprintf((yyval.na),"MINVAL(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 257:
+#line 1528 "fortran.y"
+ {sprintf((yyval.na),"TRIM(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 258:
+#line 1530 "fortran.y"
+ {sprintf((yyval.na),"SQRT(%s)",(yyvsp[(2) - (3)].na));;}
+ break;
+
+ case 259:
+#line 1532 "fortran.y"
+ {sprintf((yyval.na),"REAL(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 260:
+#line 1534 "fortran.y"
+ {sprintf((yyval.na),"NINT(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 261:
+#line 1536 "fortran.y"
+ {sprintf((yyval.na),"FLOAT(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 262:
+#line 1538 "fortran.y"
+ {sprintf((yyval.na),"EXP(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 263:
+#line 1540 "fortran.y"
+ {sprintf((yyval.na),"COS(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 264:
+#line 1542 "fortran.y"
+ {sprintf((yyval.na),"COSH(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 265:
+#line 1544 "fortran.y"
+ {sprintf((yyval.na),"ACOS(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 266:
+#line 1546 "fortran.y"
+ {sprintf((yyval.na),"SIN(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 267:
+#line 1548 "fortran.y"
+ {sprintf((yyval.na),"SINH(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 268:
+#line 1550 "fortran.y"
+ {sprintf((yyval.na),"ASIN(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 269:
+#line 1552 "fortran.y"
+ {sprintf((yyval.na),"LOG(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 270:
+#line 1554 "fortran.y"
+ {sprintf((yyval.na),"TAN(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 271:
+#line 1556 "fortran.y"
+ {sprintf((yyval.na),"ATAN(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 272:
+#line 1558 "fortran.y"
+ {sprintf((yyval.na),"ABS(%s)",(yyvsp[(2) - (3)].na));;}
+ break;
+
+ case 273:
+#line 1560 "fortran.y"
+ {sprintf((yyval.na),"MOD(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 274:
+#line 1562 "fortran.y"
+ {sprintf((yyval.na),"SIGN(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 275:
+#line 1564 "fortran.y"
+ {sprintf((yyval.na),"MINLOC(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 276:
+#line 1566 "fortran.y"
+ {sprintf((yyval.na),"MAXLOC(%s)",(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 277:
+#line 1568 "fortran.y"
+ {strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 278:
+#line 1570 "fortran.y"
+ {if ( couldaddvariable == 1 )
+ { strcpy((yyval.na),(yyvsp[(1) - (3)].na));strcat((yyval.na),",");strcat((yyval.na),(yyvsp[(3) - (3)].na));};}
+ break;
+
+ case 279:
+#line 1573 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 280:
+#line 1575 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),(yyvsp[(1) - (1)].nac));;}
+ break;
+
+ case 281:
+#line 1577 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 282:
+#line 1579 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 283:
+#line 1581 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].nac),(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 284:
+#line 1583 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].nac),(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 285:
+#line 1585 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.nac),"+");;}
+ break;
+
+ case 286:
+#line 1586 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.nac),"-");;}
+ break;
+
+ case 287:
+#line 1589 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"+%s",(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 288:
+#line 1591 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"-%s",(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 289:
+#line 1593 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"*%s",(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 290:
+#line 1595 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].nac),(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 291:
+#line 1597 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].nac),(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 292:
+#line 1599 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].nac),(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 293:
+#line 1601 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].nac),(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 294:
+#line 1603 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na)," > %s",(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 295:
+#line 1605 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].nac),(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 296:
+#line 1607 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na)," < %s",(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 297:
+#line 1609 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].nac),(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 298:
+#line 1611 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na)," >= %s",(yyvsp[(3) - (3)].na));;}
+ break;
+
+ case 299:
+#line 1613 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].nac),(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 300:
+#line 1615 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na)," <= %s",(yyvsp[(3) - (3)].na));;}
+ break;
+
+ case 301:
+#line 1617 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].nac),(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 302:
+#line 1619 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].nac),(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 303:
+#line 1621 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].nac),(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 304:
+#line 1623 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].nac),(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 305:
+#line 1625 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s%s",(yyvsp[(1) - (2)].nac),(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 306:
+#line 1627 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s",(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 307:
+#line 1629 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s",(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 308:
+#line 1631 "fortran.y"
+ {strcpy((yyval.na),"");;}
+ break;
+
+ case 309:
+#line 1633 "fortran.y"
+ {sprintf((yyval.na),"/%s",(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 310:
+#line 1635 "fortran.y"
+ {sprintf((yyval.na),"/= %s",(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 311:
+#line 1637 "fortran.y"
+ {sprintf((yyval.na),"//%s",(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 312:
+#line 1640 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"==%s",(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 313:
+#line 1642 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"= %s",(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 314:
+#line 1645 "fortran.y"
+ {if ( couldaddvariable == 1 )
+ {
+ printf("ident = %s\n",(yyvsp[(1) - (1)].nac));
+ strcpy((yyval.na),(yyvsp[(1) - (1)].nac));}
+ ;}
+ break;
+
+ case 315:
+#line 1651 "fortran.y"
+ {if ( couldaddvariable == 1 ) {
+ printf("struct = %s\n",(yyvsp[(1) - (1)].na));
+ strcpy((yyval.na),(yyvsp[(1) - (1)].na));}
+ ;}
+ break;
+
+ case 316:
+#line 1656 "fortran.y"
+ {if ( couldaddvariable == 1 ) {
+ printf("arrayref = %s\n",(yyvsp[(1) - (1)].na));
+ strcpy((yyval.na),(yyvsp[(1) - (1)].na));
+ };}
+ break;
+
+ case 317:
+#line 1661 "fortran.y"
+ {
+ agrif_parentcall =0;
+ if (!strcasecmp(identcopy,"Agrif_Parent") )
+ agrif_parentcall =1;
+ if ( Agrif_in_Tok_NAME(identcopy) == 1 )
+ {
+ inagrifcallargument = 1;
+ Add_SubroutineWhereAgrifUsed_1(subroutinename,
+ curmodulename);
+ }
+ ;}
+ break;
+
+ case 318:
+#line 1674 "fortran.y"
+ {
+ strcpy((yyval.na),(yyvsp[(1) - (1)].na));
+ if ( incalldeclare == 0 ) inagrifcallargument = 0;
+ ;}
+ break;
+
+ case 319:
+#line 1679 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na)," %s %s ",(yyvsp[(1) - (2)].na),(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 320:
+#line 1681 "fortran.y"
+ {if ( couldaddvariable == 1 )
+ sprintf((yyval.na)," %s ( %s )",(yyvsp[(1) - (4)].na),(yyvsp[(3) - (4)].na));;}
+ break;
+
+ case 321:
+#line 1684 "fortran.y"
+ {if ( couldaddvariable == 1 )
+ sprintf((yyval.na)," %s ( %s ) %s ",(yyvsp[(1) - (5)].na),(yyvsp[(3) - (5)].na),(yyvsp[(5) - (5)].na));;}
+ break;
+
+ case 322:
+#line 1688 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ sprintf((yyval.na)," %s ( %s )",(yyvsp[(1) - (4)].nac),(yyvsp[(3) - (4)].na));
+ ModifyTheAgrifFunction_0((yyvsp[(3) - (4)].na));
+ agrif_parentcall =0;
+ }
+ ;}
+ break;
+
+ case 323:
+#line 1698 "fortran.y"
+ {
+ sprintf((yyval.na)," %s %% %s ",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na));
+ if ( incalldeclare == 0 ) inagrifcallargument = 0;
+ ;}
+ break;
+
+ case 324:
+#line 1704 "fortran.y"
+ {sprintf((yyval.na),"(/%s/)",(yyvsp[(2) - (3)].na));;}
+ break;
+
+ case 325:
+#line 1706 "fortran.y"
+ {strcpy((yyval.na)," ");;}
+ break;
+
+ case 326:
+#line 1708 "fortran.y"
+ {strcpy((yyval.na),(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 327:
+#line 1710 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 328:
+#line 1712 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s,%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na));;}
+ break;
+
+ case 329:
+#line 1714 "fortran.y"
+ {strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 330:
+#line 1715 "fortran.y"
+ {strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 331:
+#line 1718 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s :%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na));;}
+ break;
+
+ case 332:
+#line 1720 "fortran.y"
+ {if ( couldaddvariable == 1 )
+ sprintf((yyval.na),"%s :%s :%s",(yyvsp[(1) - (5)].na),(yyvsp[(3) - (5)].na),(yyvsp[(5) - (5)].na));;}
+ break;
+
+ case 333:
+#line 1723 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),":%s :%s",(yyvsp[(2) - (4)].na),(yyvsp[(4) - (4)].na));;}
+ break;
+
+ case 334:
+#line 1724 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),": : %s",(yyvsp[(3) - (3)].na));;}
+ break;
+
+ case 335:
+#line 1725 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),":%s",(yyvsp[(2) - (2)].na));;}
+ break;
+
+ case 336:
+#line 1726 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s :",(yyvsp[(1) - (2)].na));;}
+ break;
+
+ case 337:
+#line 1727 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),":");;}
+ break;
+
+ case 338:
+#line 1729 "fortran.y"
+ {
+ if ( couldaddvariable == 1 && afterpercent == 0)
+ {
+ if ( Vartonumber((yyvsp[(1) - (1)].nac)) == 1 )
+ {
+ Add_SubroutineWhereAgrifUsed_1(subroutinename,
+ curmodulename);
+ }
+ if (!strcasecmp((yyvsp[(1) - (1)].nac),"Agrif_Parent") )
+ agrif_parentcall =1;
+ if ( VariableIsNotFunction((yyvsp[(1) - (1)].nac)) == 0 )
+ {
+ printf("var = %s\n",(yyvsp[(1) - (1)].nac));
+ if ( inagrifcallargument == 1 )
+ {
+ if ( !strcasecmp((yyvsp[(1) - (1)].nac),identcopy) )
+ {
+ strcpy(sameagrifname,identcopy);
+ sameagrifargument = 1;
+ }
+ }
+ strcpy(identcopy,(yyvsp[(1) - (1)].nac));
+ pointedvar=0;
+ strcpy(truename,(yyvsp[(1) - (1)].nac));
+ if (variscoupled_0((yyvsp[(1) - (1)].nac))) strcpy(truename,getcoupledname_0((yyvsp[(1) - (1)].nac)));
+
+ if ( VarIsNonGridDepend(truename) == 0 &&
+ Variableshouldberemove(truename) == 0 )
+ {
+ if ( inagrifcallargument == 1 ||
+ varispointer_0(truename) == 1 )
+ {
+ printf("var2 = %s\n",(yyvsp[(1) - (1)].nac));
+ if ((IsinListe(List_UsedInSubroutine_Var,(yyvsp[(1) - (1)].nac)) == 1) || (inagrifcallargument == 1))
+ {
+ if (varistyped_0(truename) == 0)
+ {
+ ModifyTheVariableName_0(truename,strlen((yyvsp[(1) - (1)].nac)));
+ }
+ }
+ }
+ printf("ici3\n");
+ if ( inagrifcallargument != 1 ||
+ sameagrifargument ==1 )
+ {
+ printf("ici5 %s\n",truename);
+ Add_UsedInSubroutine_Var_1(truename);
+ }
+ }
+ NotifyAgrifFunction_0(truename);
+ }
+ }
+ else
+ {
+ afterpercent = 0;
+ }
+ ;}
+ break;
+
+ case 339:
+#line 1788 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.nac),".TRUE.");;}
+ break;
+
+ case 340:
+#line 1789 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.nac),".FALSE.");;}
+ break;
+
+ case 341:
+#line 1790 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));;}
+ break;
+
+ case 342:
+#line 1791 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));;}
+ break;
+
+ case 343:
+#line 1792 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));;}
+ break;
+
+ case 344:
+#line 1793 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));;}
+ break;
+
+ case 345:
+#line 1795 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.nac),"%s%s",(yyvsp[(1) - (2)].nac),(yyvsp[(2) - (2)].nac));;}
+ break;
+
+ case 347:
+#line 1799 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));;}
+ break;
+
+ case 349:
+#line 1802 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));;}
+ break;
+
+ case 350:
+#line 1804 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));;}
+ break;
+
+ case 351:
+#line 1806 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na)," ");;}
+ break;
+
+ case 352:
+#line 1807 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 353:
+#line 1810 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"(%s :%s)",(yyvsp[(2) - (5)].na),(yyvsp[(4) - (5)].na));;}
+ break;
+
+ case 354:
+#line 1812 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na)," ");;}
+ break;
+
+ case 355:
+#line 1813 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 356:
+#line 1815 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na)," ");;}
+ break;
+
+ case 357:
+#line 1816 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 358:
+#line 1818 "fortran.y"
+ { strcpy(InitialValueGiven," ");;}
+ break;
+
+ case 359:
+#line 1820 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy(InitValue,(yyvsp[(3) - (3)].na));
+ strcpy(InitialValueGiven,"=");
+ }
+ ;}
+ break;
+
+ case 360:
+#line 1828 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy(InitValue,(yyvsp[(3) - (3)].na));
+ strcpy(InitialValueGiven,"=>");
+ }
+ ;}
+ break;
+
+ case 361:
+#line 1836 "fortran.y"
+ {pos_curinit = setposcur();;}
+ break;
+
+ case 362:
+#line 1839 "fortran.y"
+ {sprintf((yyval.na),"(%s,%s)",(yyvsp[(2) - (5)].na),(yyvsp[(4) - (5)].na));;}
+ break;
+
+ case 363:
+#line 1842 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* if variables has been declared in a subroutine */
+ if (insubroutinedeclare == 1)
+ {
+ copyuse_0((yyvsp[(2) - (2)].nac));
+ }
+ sprintf(charusemodule,"%s",(yyvsp[(2) - (2)].nac));
+ Add_NameOfModuleUsed_1((yyvsp[(2) - (2)].nac));
+
+ if ( inmoduledeclare == 0 )
+ {
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curuse,
+ pos_end-pos_curuse);
+ }
+ }
+ ;}
+ break;
+
+ case 364:
+#line 1862 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ if (insubroutinedeclare == 1)
+ {
+ Add_CouplePointed_Var_1((yyvsp[(2) - (4)].nac),(yyvsp[(4) - (4)].lc));
+ }
+ if ( firstpass == 1 )
+ {
+ if ( insubroutinedeclare == 1 )
+ {
+ coupletmp = (yyvsp[(4) - (4)].lc);
+ strcpy(ligne,"");
+ while ( coupletmp )
+ {
+ strcat(ligne,coupletmp->c_namevar);
+ strcat(ligne," => ");
+ strcat(ligne,coupletmp->c_namepointedvar);
+ coupletmp = coupletmp->suiv;
+ if ( coupletmp ) strcat(ligne,",");
+ }
+ sprintf(charusemodule,"%s",(yyvsp[(2) - (4)].nac));
+ }
+ Add_NameOfModuleUsed_1((yyvsp[(2) - (4)].nac));
+ }
+ if ( inmoduledeclare == 0 )
+ {
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curuse,
+ pos_end-pos_curuse);
+ }
+ }
+ ;}
+ break;
+
+ case 365:
+#line 1896 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* if variables has been declared in a subroutine */
+ if (insubroutinedeclare == 1)
+ {
+ copyuseonly_0((yyvsp[(2) - (6)].nac));
+ }
+ sprintf(charusemodule,"%s",(yyvsp[(2) - (6)].nac));
+ Add_NameOfModuleUsed_1((yyvsp[(2) - (6)].nac));
+
+ if ( inmoduledeclare == 0 )
+ {
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curuse,
+ pos_end-pos_curuse);
+ }
+ }
+ ;}
+ break;
+
+ case 366:
+#line 1916 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* if variables has been declared in a subroutine */
+ if (insubroutinedeclare == 1)
+ {
+ Add_CouplePointed_Var_1((yyvsp[(2) - (6)].nac),(yyvsp[(6) - (6)].lc));
+ }
+ if ( firstpass == 1 )
+ {
+ if ( insubroutinedeclare == 1 )
+ {
+ coupletmp = (yyvsp[(6) - (6)].lc);
+ strcpy(ligne,"");
+ while ( coupletmp )
+ {
+ strcat(ligne,coupletmp->c_namevar);
+ if ( strcasecmp(coupletmp->c_namepointedvar,"") )
+ strcat(ligne," => ");
+ strcat(ligne,coupletmp->c_namepointedvar);
+ coupletmp = coupletmp->suiv;
+ if ( coupletmp ) strcat(ligne,",");
+ }
+ sprintf(charusemodule,"%s",(yyvsp[(2) - (6)].nac));
+ }
+ Add_NameOfModuleUsed_1((yyvsp[(2) - (6)].nac));
+ }
+ if ( firstpass == 0 )
+ {
+ if ( inmoduledeclare == 0 )
+ {
+
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curuse,
+ pos_end-pos_curuse);
+ if (oldfortranout)
+ variableisglobalinmodule((yyvsp[(6) - (6)].lc),(yyvsp[(2) - (6)].nac),oldfortranout,pos_curuseold);
+
+ }
+ else
+ {
+
+ /* if we are in the module declare and if the */
+ /* onlylist is a list of global variable */
+ variableisglobalinmodule((yyvsp[(6) - (6)].lc), (yyvsp[(2) - (6)].nac), fortranout,pos_curuse);
+ }
+ }
+ }
+ ;}
+ break;
+
+ case 367:
+#line 1967 "fortran.y"
+ {
+ pos_curuse = setposcur()-strlen((yyvsp[(1) - (1)].nac));
+ if (firstpass == 0 && oldfortranout) {
+ pos_curuseold = setposcurname(oldfortranout);
+ }
+ ;}
+ break;
+
+ case 368:
+#line 1975 "fortran.y"
+ {strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));;}
+ break;
+
+ case 369:
+#line 1978 "fortran.y"
+ {
+ if ( couldaddvariable == 1 ) (yyval.lc) = (yyvsp[(1) - (1)].lc);
+ ;}
+ break;
+
+ case 370:
+#line 1982 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* insert the variable in the list $1 */
+ (yyvsp[(3) - (3)].lc)->suiv = (yyvsp[(1) - (3)].lc);
+ (yyval.lc) = (yyvsp[(3) - (3)].lc);
+ }
+ ;}
+ break;
+
+ case 371:
+#line 1992 "fortran.y"
+ {
+ coupletmp =(listcouple *)malloc(sizeof(listcouple));
+ strcpy(coupletmp->c_namevar,(yyvsp[(1) - (3)].nac));
+ Save_Length((yyvsp[(1) - (3)].nac),21);
+ strcpy(coupletmp->c_namepointedvar,(yyvsp[(3) - (3)].nac));
+ Save_Length((yyvsp[(3) - (3)].nac),22);
+ coupletmp->suiv = NULL;
+ (yyval.lc) = coupletmp;
+ ;}
+ break;
+
+ case 372:
+#line 2003 "fortran.y"
+ {
+ if ( couldaddvariable == 1 ) (yyval.lc) = (yyvsp[(1) - (1)].lc);
+ ;}
+ break;
+
+ case 373:
+#line 2007 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* insert the variable in the list $1 */
+ (yyvsp[(3) - (3)].lc)->suiv = (yyvsp[(1) - (3)].lc);
+ (yyval.lc) = (yyvsp[(3) - (3)].lc);
+ }
+ ;}
+ break;
+
+ case 374:
+#line 2017 "fortran.y"
+ {
+ coupletmp =(listcouple *)malloc(sizeof(listcouple));
+ strcpy(coupletmp->c_namevar,(yyvsp[(1) - (3)].nac));
+ Save_Length((yyvsp[(1) - (3)].nac),21);
+ strcpy(coupletmp->c_namepointedvar,(yyvsp[(3) - (3)].nac));
+ Save_Length((yyvsp[(3) - (3)].nac),22);
+ coupletmp->suiv = NULL;
+ (yyval.lc) = coupletmp;
+ pointedvar=1;
+ Add_UsedInSubroutine_Var_1((yyvsp[(1) - (3)].nac));
+ ;}
+ break;
+
+ case 375:
+#line 2028 "fortran.y"
+ {
+ coupletmp =(listcouple *)malloc(sizeof(listcouple));
+ strcpy(coupletmp->c_namevar,(yyvsp[(1) - (1)].nac));
+ Save_Length((yyvsp[(1) - (1)].nac),21);
+ strcpy(coupletmp->c_namepointedvar,"");
+ coupletmp->suiv = NULL;
+ (yyval.lc) = coupletmp;
+ ;}
+ break;
+
+ case 377:
+#line 2039 "fortran.y"
+ {
+ Add_SubroutineWhereAgrifUsed_1(subroutinename,
+ curmodulename);
+ inallocate = 0;
+ ;}
+ break;
+
+ case 378:
+#line 2045 "fortran.y"
+ {
+ Add_SubroutineWhereAgrifUsed_1(subroutinename,
+ curmodulename);
+ inallocate = 0;
+ ;}
+ break;
+
+ case 380:
+#line 2052 "fortran.y"
+ {
+ GlobalDeclaration = 0 ;
+ if ( firstpass == 0 &&
+ strcasecmp(subroutinename,"") )
+ {
+ if ( module_declar && insubroutinedeclare == 0 )
+ {
+ fclose(module_declar);
+ }
+ }
+ if ( couldaddvariable == 1 &&
+ strcasecmp(subroutinename,"") )
+ {
+ if ( inmodulemeet == 1 )
+ {
+ /* we are in a module */
+ if ( insubroutinedeclare == 1 )
+ {
+ /* it is like an end subroutine */
+ insubroutinedeclare = 0 ;
+ /* */
+ pos_cur = setposcur();
+ closeandcallsubloopandincludeit_0(1);
+ functiondeclarationisdone = 0;
+ }
+ else
+ {
+ /* it is like an end module */
+ inmoduledeclare = 0 ;
+ inmodulemeet = 0 ;
+ }
+ }
+ else
+ {
+ insubroutinedeclare = 0;
+ /* */
+ pos_cur = setposcur();
+ closeandcallsubloopandincludeit_0(2);
+ functiondeclarationisdone = 0;
+ if ( firstpass == 0 )
+ {
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+ fclose(paramout);
+ }
+ }
+ }
+ strcpy(subroutinename,"");
+ ;}
+ break;
+
+ case 381:
+#line 2102 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ insubroutinedeclare = 0;
+ /* */
+ pos_cur = setposcur();
+ closeandcallsubloopandincludeit_0(3);
+ functiondeclarationisdone = 0;
+ if ( firstpass == 0 )
+ {
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+ fclose(paramout);
+ }
+ strcpy(subroutinename,"");
+ }
+ ;}
+ break;
+
+ case 382:
+#line 2120 "fortran.y"
+ {
+ if ( couldaddvariable == 1 &&
+ strcasecmp(subroutinename,"") )
+ {
+ insubroutinedeclare = 0;
+ /* */
+ pos_cur = setposcur();
+
+ closeandcallsubloopandincludeit_0(1);
+ functiondeclarationisdone = 0;
+ if ( firstpass == 0 )
+ {
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+ fclose(paramout);
+ }
+ strcpy(subroutinename,"");
+ }
+ ;}
+ break;
+
+ case 383:
+#line 2140 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ insubroutinedeclare = 0;
+ /* */
+ pos_cur = setposcur();
+
+ closeandcallsubloopandincludeit_0(0);
+ functiondeclarationisdone = 0;
+ if ( firstpass == 0 )
+ {
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+ fclose(paramout);
+ }
+ strcpy(subroutinename,"");
+ }
+ ;}
+ break;
+
+ case 384:
+#line 2159 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* if we never meet the contains keyword */
+ Remove_Word_end_module_0(strlen((yyvsp[(2) - (2)].nac)));
+ if ( inmoduledeclare == 1 )
+ {
+ if ( aftercontainsdeclare == 0 )
+ {
+ Write_GlobalParameter_Declaration_0();
+ Write_NotGridDepend_Declaration_0();
+ Write_GlobalType_Declaration_0();
+ if ( module_declar_type )
+ {
+ strcpy (ligne, "\n#include \"Module_DeclarType_");
+ strcat (ligne, curmodulename);
+ strcat (ligne, ".h\"\n");
+ tofich(fortranout,ligne,1);
+ }
+ Write_Alloc_Subroutine_For_End_0();
+ }
+ }
+
+ inmoduledeclare = 0 ;
+ inmodulemeet = 0 ;
+
+ Write_Word_end_module_0();
+ strcpy(curmodulename,"");
+ aftercontainsdeclare = 1;
+ if ( firstpass == 0 )
+ {
+ if ( module_declar && insubroutinedeclare == 0)
+ {
+ fclose(module_declar);
+ }
+ if ( module_declar_type && insubroutinedeclare == 0)
+ {
+ fclose(module_declar_type);
+ module_declar_type = 0;
+ }
+ }
+ GlobalDeclaration = 0 ;
+ }
+ ;}
+ break;
+
+ case 398:
+#line 2217 "fortran.y"
+ {
+ if (inmoduledeclare == 1 )
+ {
+ Remove_Word_Contains_0();
+ Write_GlobalParameter_Declaration_0();
+ Write_GlobalType_Declaration_0();
+ if ( module_declar_type)
+ {
+ strcpy (ligne, "\n#include \"Module_DeclarType_");
+ strcat (ligne, curmodulename);
+ strcat (ligne, ".h\"\n");
+ tofich(fortranout,ligne,1);
+ }
+ Write_NotGridDepend_Declaration_0();
+ Write_Alloc_Subroutine_0();
+ inmoduledeclare = 0 ;
+ aftercontainsdeclare = 1;
+ }
+ else
+ {
+ incontainssubroutine = 1;
+ strcpy(previoussubroutinename,subroutinename);
+ if ( couldaddvariable == 1 )
+ {
+ if ( firstpass == 1 ) List_ContainsSubroutine =
+ Addtolistnom(subroutinename,
+ List_ContainsSubroutine,0);
+ insubroutinedeclare = 0;
+ /* */
+
+ closeandcallsubloop_contains_0();
+ functiondeclarationisdone = 0;
+ if ( firstpass == 0 )
+ {
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+ fclose(paramout);
+ }
+ }
+ strcpy(subroutinename,"");
+ }
+ ;}
+ break;
+
+ case 399:
+#line 2261 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));
+ pos_endsubroutine = setposcur()-strlen((yyvsp[(1) - (1)].nac));
+ functiondeclarationisdone = 0;
+ }
+ ;}
+ break;
+
+ case 400:
+#line 2271 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));
+ pos_endsubroutine = setposcur()-strlen((yyvsp[(1) - (1)].nac));
+ }
+ ;}
+ break;
+
+ case 401:
+#line 2280 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));
+ pos_endsubroutine = setposcur()-strlen((yyvsp[(1) - (1)].nac));
+ }
+ ;}
+ break;
+
+ case 402:
+#line 2289 "fortran.y"
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));
+ pos_endsubroutine = setposcur()-strlen((yyvsp[(1) - (1)].nac));
+ }
+ ;}
+ break;
+
+ case 414:
+#line 2311 "fortran.y"
+ {strcpy((yyval.nac),"");;}
+ break;
+
+ case 415:
+#line 2312 "fortran.y"
+ {strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));;}
+ break;
+
+ case 425:
+#line 2332 "fortran.y"
+ {
+ Add_SubroutineWhereAgrifUsed_1(subroutinename,
+ curmodulename);
+ inallocate = 0;
+ ;}
+ break;
+
+ case 426:
+#line 2338 "fortran.y"
+ {
+ Add_SubroutineWhereAgrifUsed_1(subroutinename,
+ curmodulename);
+ inallocate = 0;
+ ;}
+ break;
+
+ case 432:
+#line 2349 "fortran.y"
+ {if ( couldaddvariable == 1 ) created_dimensionlist = 0;;}
+ break;
+
+ case 433:
+#line 2351 "fortran.y"
+ {
+ created_dimensionlist = 1;
+ if ( agrif_parentcall == 1 )
+ {
+ ModifyTheAgrifFunction_0((yyvsp[(3) - (4)].d)->dim.last);
+ agrif_parentcall =0;
+ fprintf(fortranout," = ");
+ }
+ ;}
+ break;
+
+ case 434:
+#line 2361 "fortran.y"
+ {created_dimensionlist = 1;;}
+ break;
+
+ case 439:
+#line 2369 "fortran.y"
+ {
+ inagrifcallargument = 0 ;
+ incalldeclare=0;
+ if ( oldfortranout &&
+ !strcasecmp(meetagrifinitgrids,subroutinename) &&
+ firstpass == 0 &&
+ callmpiinit == 1)
+ {
+ /* pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curcall,
+ pos_end-pos_curcall);
+ fprintf(oldfortranout," Call MPI_Init (%s) \n"
+ ,mpiinitvar);*/
+ }
+ if ( oldfortranout &&
+ callagrifinitgrids == 1 &&
+ firstpass == 0 )
+ {
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curcall,
+ pos_end-pos_curcall);
+
+ strcpy(subofagrifinitgrids,subroutinename);
+ }
+ Instanciation_0(sameagrifname);
+ ;}
+ break;
+
+ case 444:
+#line 2403 "fortran.y"
+ {
+ if (!strcasecmp((yyvsp[(2) - (2)].nac),"MPI_Init") )
+ {
+ callmpiinit = 1;
+ }
+ else
+ {
+ callmpiinit = 0;
+ }
+ if (!strcasecmp((yyvsp[(2) - (2)].nac),"Agrif_Init_Grids") )
+ {
+ callagrifinitgrids = 1;
+ strcpy(meetagrifinitgrids,subroutinename);
+ }
+ else callagrifinitgrids = 0;
+ if ( !strcasecmp((yyvsp[(2) - (2)].nac),"Agrif_Open_File") )
+ {
+ Add_SubroutineWhereAgrifUsed_1(subroutinename,
+ curmodulename);
+ }
+ if ( Vartonumber((yyvsp[(2) - (2)].nac)) == 1 )
+ {
+ incalldeclare=1;
+ inagrifcallargument = 1 ;
+ Add_SubroutineWhereAgrifUsed_1(subroutinename,
+ curmodulename);
+ }
+ ;}
+ break;
+
+ case 445:
+#line 2433 "fortran.y"
+ {pos_curcall=setposcur()-4;;}
+ break;
+
+ case 448:
+#line 2438 "fortran.y"
+ {
+ if ( callmpiinit == 1 )
+ {
+ strcpy(mpiinitvar,(yyvsp[(1) - (1)].na));
+ if ( firstpass == 1 )
+ {
+ Add_UsedInSubroutine_Var_1 (mpiinitvar);
+/* curvar=createvar($1,NULL);
+ curlistvar=insertvar(NULL,curvar);
+ List_Subr outineArgument_Var = AddListvarToListvar
+ (curlistvar,List_SubroutineAr gument_Var,1);*/
+ }
+ }
+ ;}
+ break;
+
+ case 520:
+#line 2562 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 521:
+#line 2563 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 522:
+#line 2564 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 523:
+#line 2567 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s,%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na));;}
+ break;
+
+ case 524:
+#line 2569 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s,%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na));;}
+ break;
+
+ case 525:
+#line 2571 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s,%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na));;}
+ break;
+
+ case 526:
+#line 2573 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s,%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na));;}
+ break;
+
+ case 527:
+#line 2575 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s,%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na));;}
+ break;
+
+ case 528:
+#line 2577 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"%s,%s",(yyvsp[(1) - (3)].na),(yyvsp[(3) - (3)].na));;}
+ break;
+
+ case 529:
+#line 2578 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 530:
+#line 2579 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 531:
+#line 2582 "fortran.y"
+ {if ( couldaddvariable == 1 ) strcpy((yyval.na),(yyvsp[(1) - (1)].na));;}
+ break;
+
+ case 532:
+#line 2584 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na)," (%s)",(yyvsp[(2) - (3)].na));;}
+ break;
+
+ case 533:
+#line 2586 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"(%s,%s)",(yyvsp[(2) - (5)].na),(yyvsp[(4) - (5)].na));;}
+ break;
+
+ case 534:
+#line 2588 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"(%s,%s)",(yyvsp[(2) - (5)].na),(yyvsp[(4) - (5)].na));;}
+ break;
+
+ case 535:
+#line 2590 "fortran.y"
+ {if ( couldaddvariable == 1 ) sprintf((yyval.na),"(%s,%s)",(yyvsp[(2) - (5)].na),(yyvsp[(4) - (5)].na));;}
+ break;
+
+ case 536:
+#line 2594 "fortran.y"
+ {if ( couldaddvariable == 1 )
+ sprintf((yyval.na),"%s=%s,%s)",(yyvsp[(1) - (5)].nac),(yyvsp[(3) - (5)].na),(yyvsp[(5) - (5)].na));;}
+ break;
+
+ case 537:
+#line 2597 "fortran.y"
+ {if ( couldaddvariable == 1 )
+ sprintf((yyval.na),"%s=%s,%s,%s)",(yyvsp[(1) - (7)].nac),(yyvsp[(3) - (7)].na),(yyvsp[(5) - (7)].na),(yyvsp[(7) - (7)].na));;}
+ break;
+
+ case 544:
+#line 2613 "fortran.y"
+ {Add_Allocate_Var_1((yyvsp[(1) - (1)].nac),curmodulename);;}
+ break;
+
+ case 547:
+#line 2618 "fortran.y"
+ {Add_Allocate_Var_1((yyvsp[(1) - (4)].nac),curmodulename);;}
+ break;
+
+ case 555:
+#line 2641 "fortran.y"
+ {strcpy((yyval.nac),(yyvsp[(1) - (1)].nac));;}
+ break;
+
+
+/* Line 1267 of yacc.c. */
+#line 6522 "fortran.tab.c"
+ default: break;
+ }
+ YY_SYMBOL_PRINT ("-> $$ =", yyr1[yyn], &yyval, &yyloc);
+
+ YYPOPSTACK (yylen);
+ yylen = 0;
+ YY_STACK_PRINT (yyss, yyssp);
+
+ *++yyvsp = yyval;
+
+
+ /* Now `shift' the result of the reduction. Determine what state
+ that goes to, based on the state we popped back to and the rule
+ number reduced by. */
+
+ yyn = yyr1[yyn];
+
+ yystate = yypgoto[yyn - YYNTOKENS] + *yyssp;
+ if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == *yyssp)
+ yystate = yytable[yystate];
+ else
+ yystate = yydefgoto[yyn - YYNTOKENS];
+
+ goto yynewstate;
+
+
+/*------------------------------------.
+| yyerrlab -- here on detecting error |
+`------------------------------------*/
+yyerrlab:
+ /* If not already recovering from an error, report this error. */
+ if (!yyerrstatus)
+ {
+ ++yynerrs;
+#if ! YYERROR_VERBOSE
+ yyerror (YY_("syntax error"));
+#else
+ {
+ YYSIZE_T yysize = yysyntax_error (0, yystate, yychar);
+ if (yymsg_alloc < yysize && yymsg_alloc < YYSTACK_ALLOC_MAXIMUM)
+ {
+ YYSIZE_T yyalloc = 2 * yysize;
+ if (! (yysize <= yyalloc && yyalloc <= YYSTACK_ALLOC_MAXIMUM))
+ yyalloc = YYSTACK_ALLOC_MAXIMUM;
+ if (yymsg != yymsgbuf)
+ YYSTACK_FREE (yymsg);
+ yymsg = (char *) YYSTACK_ALLOC (yyalloc);
+ if (yymsg)
+ yymsg_alloc = yyalloc;
+ else
+ {
+ yymsg = yymsgbuf;
+ yymsg_alloc = sizeof yymsgbuf;
+ }
+ }
+
+ if (0 < yysize && yysize <= yymsg_alloc)
+ {
+ (void) yysyntax_error (yymsg, yystate, yychar);
+ yyerror (yymsg);
+ }
+ else
+ {
+ yyerror (YY_("syntax error"));
+ if (yysize != 0)
+ goto yyexhaustedlab;
+ }
+ }
+#endif
+ }
+
+
+
+ if (yyerrstatus == 3)
+ {
+ /* If just tried and failed to reuse look-ahead token after an
+ error, discard it. */
+
+ if (yychar <= YYEOF)
+ {
+ /* Return failure if at end of input. */
+ if (yychar == YYEOF)
+ YYABORT;
+ }
+ else
+ {
+ yydestruct ("Error: discarding",
+ yytoken, &yylval);
+ yychar = YYEMPTY;
+ }
+ }
+
+ /* Else will try to reuse look-ahead token after shifting the error
+ token. */
+ goto yyerrlab1;
+
+
+/*---------------------------------------------------.
+| yyerrorlab -- error raised explicitly by YYERROR. |
+`---------------------------------------------------*/
+yyerrorlab:
+
+ /* Pacify compilers like GCC when the user code never invokes
+ YYERROR and the label yyerrorlab therefore never appears in user
+ code. */
+ if (/*CONSTCOND*/ 0)
+ goto yyerrorlab;
+
+ /* Do not reclaim the symbols of the rule which action triggered
+ this YYERROR. */
+ YYPOPSTACK (yylen);
+ yylen = 0;
+ YY_STACK_PRINT (yyss, yyssp);
+ yystate = *yyssp;
+ goto yyerrlab1;
+
+
+/*-------------------------------------------------------------.
+| yyerrlab1 -- common code for both syntax error and YYERROR. |
+`-------------------------------------------------------------*/
+yyerrlab1:
+ yyerrstatus = 3; /* Each real token shifted decrements this. */
+
+ for (;;)
+ {
+ yyn = yypact[yystate];
+ if (yyn != YYPACT_NINF)
+ {
+ yyn += YYTERROR;
+ if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR)
+ {
+ yyn = yytable[yyn];
+ if (0 < yyn)
+ break;
+ }
+ }
+
+ /* Pop the current state because it cannot handle the error token. */
+ if (yyssp == yyss)
+ YYABORT;
+
+
+ yydestruct ("Error: popping",
+ yystos[yystate], yyvsp);
+ YYPOPSTACK (1);
+ yystate = *yyssp;
+ YY_STACK_PRINT (yyss, yyssp);
+ }
+
+ if (yyn == YYFINAL)
+ YYACCEPT;
+
+ *++yyvsp = yylval;
+
+
+ /* Shift the error token. */
+ YY_SYMBOL_PRINT ("Shifting", yystos[yyn], yyvsp, yylsp);
+
+ yystate = yyn;
+ goto yynewstate;
+
+
+/*-------------------------------------.
+| yyacceptlab -- YYACCEPT comes here. |
+`-------------------------------------*/
+yyacceptlab:
+ yyresult = 0;
+ goto yyreturn;
+
+/*-----------------------------------.
+| yyabortlab -- YYABORT comes here. |
+`-----------------------------------*/
+yyabortlab:
+ yyresult = 1;
+ goto yyreturn;
+
+#ifndef yyoverflow
+/*-------------------------------------------------.
+| yyexhaustedlab -- memory exhaustion comes here. |
+`-------------------------------------------------*/
+yyexhaustedlab:
+ yyerror (YY_("memory exhausted"));
+ yyresult = 2;
+ /* Fall through. */
+#endif
+
+yyreturn:
+ if (yychar != YYEOF && yychar != YYEMPTY)
+ yydestruct ("Cleanup: discarding lookahead",
+ yytoken, &yylval);
+ /* Do not reclaim the symbols of the rule which action triggered
+ this YYABORT or YYACCEPT. */
+ YYPOPSTACK (yylen);
+ YY_STACK_PRINT (yyss, yyssp);
+ while (yyssp != yyss)
+ {
+ yydestruct ("Cleanup: popping",
+ yystos[*yyssp], yyvsp);
+ YYPOPSTACK (1);
+ }
+#ifndef yyoverflow
+ if (yyss != yyssa)
+ YYSTACK_FREE (yyss);
+#endif
+#if YYERROR_VERBOSE
+ if (yymsg != yymsgbuf)
+ YYSTACK_FREE (yymsg);
+#endif
+ /* Make sure YYID is used. */
+ return YYID (yyresult);
+}
+
+
+#line 2643 "fortran.y"
+
+
+void processfortran(char *fichier_entree)
+{
+ extern FILE *fortranin;
+ extern FILE *fortranout;
+ char nomfile[LONG_C];
+ int c;
+ int confirmyes;
+
+/* fortrandebug = 1;*/
+ if ( mark == 1 ) printf("Firstpass == %d \n",firstpass);
+/******************************************************************************/
+/* 1- Open input and output files */
+/******************************************************************************/
+ strcpy(nomfile,commondirin);
+ strcat(nomfile,"/");
+ strcat(nomfile,fichier_entree);
+ fortranin=fopen( nomfile,"r");
+ if (! fortranin)
+ {
+ printf("Error : File %s does not exist\n",nomfile);
+ exit(1);
+ }
+
+ strcpy(curfile,nomfile);
+ strcpy(nomfile,commondirout);
+ strcat(nomfile,"/");
+ strcat(nomfile,fichier_entree);
+ strcpy(nomfileoutput,nomfile);
+ Save_Length(nomfileoutput,31);
+ if (firstpass == 1)
+ {
+ if (checkexistcommon == 1)
+ {
+ if (fopen(nomfile,"r"))
+ {
+ printf("Warning : file %s already exist\n",nomfile);
+ confirmyes = 0;
+ while (confirmyes==0)
+ {
+ printf("Override file %s ? [Y/N]\n",nomfile);
+ c=getchar();
+ getchar();
+ if (c==79 || c==110)
+ {
+ printf("We stop\n");
+ exit(1);
+ }
+ if (c==89 || c==121)
+ {
+ confirmyes=1;
+ }
+ }
+ }
+ }
+ }
+
+/******************************************************************************/
+/* 2- Variables initialization */
+/******************************************************************************/
+
+ line_num_fortran_common=1;
+ line_num_fortran=1;
+ PublicDeclare = 0;
+ PrivateDeclare = 0;
+ ExternalDeclare = 0;
+ SaveDeclare = 0;
+ pointerdeclare = 0;
+ optionaldeclare = 0;
+ incalldeclare = 0;
+ VarType = 0;
+ VarTypepar = 0;
+ Allocatabledeclare = 0 ;
+ Targetdeclare = 0 ;
+ strcpy(NamePrecision," ");
+ VariableIsParameter = 0 ;
+ strcpy(NamePrecision,"");
+ c_star = 0 ;
+ functiondeclarationisdone = 0;
+ insubroutinedeclare = 0 ;
+ ininterfacedeclare = 0 ;
+ strcpy(subroutinename," ");
+ isrecursive = 0;
+ strcpy(InitialValueGiven," ");
+ strcpy(EmptyChar," ");
+ inmoduledeclare = 0;
+ incontainssubroutine = 0;
+ module_declar_type = 0;
+ GlobalDeclarationType = 0;
+ colnum=0;
+ incom=0;
+ couldaddvariable=1;
+ afterpercent = 0;
+ aftercontainsdeclare = 1;
+ strcpy(nameinttypename,"");
+ /* Name of the file without format */
+ tmp = strchr(fichier_entree, '.');
+ strncpy(curfilename,fichier_entree,strlen(fichier_entree)-strlen(tmp));
+ Save_Length(curfilename,30);
+/******************************************************************************/
+/* 3- Parsing of the input file (1 time) */
+/******************************************************************************/
+ if (firstpass == 0 )
+ {
+ fortranout=fopen(nomfileoutput,"w");
+
+/* NewModule_Creation_0();*/
+ }
+
+ fortranparse();
+
+ if (firstpass == 0 )
+ {
+ NewModule_Creation_0();
+ }
+
+ strcpy(curfile,mainfile);
+
+ if (firstpass == 0 )
+ {
+ fclose(fortranout);
+ }
+}
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/fortran.y
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/fortran.y (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/fortran.y (revision 8155)
@@ -0,0 +1,2766 @@
+/******************************************************************************/
+/* */
+/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */
+/* */
+/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */
+/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */
+/* This software is governed by the CeCILL-C license under French law and */
+/* abiding by the rules of distribution of free software. You can use, */
+/* modify and/ or redistribute the software under the terms of the CeCILL-C */
+/* license as circulated by CEA, CNRS and INRIA at the following URL */
+/* "http ://www.cecill.info". */
+/* */
+/* As a counterpart to the access to the source code and rights to copy, */
+/* modify and redistribute granted by the license, users are provided only */
+/* with a limited warranty and the software's author, the holder of the */
+/* economic rights, and the successive licensors have only limited */
+/* liability. */
+/* */
+/* In this respect, the user's attention is drawn to the risks associated */
+/* with loading, using, modifying and/or developing or reproducing the */
+/* software by the user in light of its specific status of free software, */
+/* that may mean that it is complicated to manipulate, and that also */
+/* therefore means that it is reserved for developers and experienced */
+/* professionals having in-depth computer knowledge. Users are therefore */
+/* encouraged to load and test the software's suitability as regards their */
+/* requirements in conditions enabling the security of their systems and/or */
+/* data to be ensured and, more generally, to use and operate it in the */
+/* same conditions as regards security. */
+/* */
+/* The fact that you are presently reading this means that you have had */
+/* knowledge of the CeCILL-C license and that you accept its terms. */
+/******************************************************************************/
+/* version 1.7 */
+/******************************************************************************/
+
+%{
+#define YYMAXDEPTH 1000
+#include
+#include
+#include
+#include "decl.h"
+extern int line_num_fortran;
+extern int line_num_fortran_common;
+char *tmp;
+char c_selectorname[LONG_C];
+char ligne[LONG_C];
+char truename[LONGNOM];
+char identcopy[LONG_C];
+int c_selectorgiven=0;
+int incom;
+listvar *curlistvar;
+typedim c_selectordim;
+listcouple *coupletmp;
+listdim *parcoursdim;
+int removeline=0;
+listvar *test;
+%}
+
+%union {
+ char nac[LONG_C];
+ char na[LONGNOM];
+ listdim *d;
+ listvar *l;
+ listnom *ln;
+ listcouple *lc;
+ listname *lnn;
+ typedim dim1;
+ variable *v;
+ }
+
+%left ','
+%nonassoc ':'
+%right '='
+%left TOK_BINARY_OP
+%left TOK_EQV TOK_NEQV
+%left TOK_OR TOK_XOR
+%left TOK_AND
+%left TOK_NOT
+%nonassoc TOK_LT TOK_GT TOK_LE TOK_GE TOK_EQ TOK_NE
+%nonassoc TOK_UNARY_OP
+%left TOK_DSLASH
+%left '+' '-'
+%left '*' TOK_SLASH
+%right TOK_DASTER
+
+%token TOK_SEP
+%token TOK_SEMICOLON
+%token TOK_NEXTLINE
+%token TOK_PARAMETER
+%token TOK_RESULT
+%token TOK_ONLY
+%token TOK_INCLUDE
+%token TOK_SUBROUTINE
+%token TOK_PROGRAM
+%token TOK_FUNCTION
+%token TOK_OMP
+%token TOK_DOLLAR
+%token TOK_FORMAT
+%token TOK_MAX
+%token TOK_TANH
+%token TOK_WHERE
+%token TOK_ELSEWHERE
+%token TOK_ENDWHERE
+%token TOK_MAXVAL
+%token TOK_TRIM
+%token TOK_SUM
+%token TOK_SQRT
+%token TOK_CASE
+%token TOK_SELECTCASE
+%token TOK_FILE
+%token TOK_END
+%token TOK_ERR
+%token TOK_DONOTTREAT
+%token TOK_ENDDONOTTREAT
+%token TOK_EXIST
+%token TOK_MIN
+%token TOK_FLOAT
+%token TOK_EXP
+%token TOK_COS
+%token TOK_COSH
+%token TOK_ACOS
+%token TOK_NINT
+%token TOK_CYCLE
+%token TOK_SIN
+%token TOK_SINH
+%token TOK_ASIN
+%token TOK_EQUIVALENCE
+%token TOK_BACKSPACE
+%token TOK_LOG
+%token TOK_TAN
+%token TOK_ATAN
+%token TOK_RECURSIVE
+%token TOK_ABS
+%token TOK_MOD
+%token TOK_SIGN
+%token TOK_MINLOC
+%token TOK_MAXLOC
+%token TOK_EXIT
+%token TOK_MINVAL
+%token TOK_PUBLIC
+%token TOK_PRIVATE
+%token TOK_ALLOCATABLE
+%token TOK_RETURN
+%token TOK_THEN
+%token TOK_ELSEIF
+%token TOK_ELSE
+%token TOK_ENDIF
+%token TOK_PRINT
+%token TOK_PLAINGOTO
+%token TOK_CONSTRUCTID
+%token TOK_LOGICALIF
+%token TOK_PLAINDO
+%token TOK_CONTAINS
+%token TOK_ENDDO
+%token TOK_MODULE
+%token TOK_ENDMODULE
+%token TOK_DOWHILE
+%token TOK_ALLOCATE
+%token TOK_OPEN
+%token TOK_CLOSE
+%token TOK_INQUIRE
+%token TOK_WRITE
+%token TOK_READ
+%token TOK_REWIND
+%token TOK_DEALLOCATE
+%token TOK_NULLIFY
+%token TOK_FIN
+%token TOK_DEBUT
+%token TOK_DIMENSION
+%token TOK_ENDSELECT
+%token TOK_EXTERNAL
+%token TOK_INTENT
+%token TOK_INTRINSIC
+%token TOK_NAMELIST
+%token TOK_CASEDEFAULT
+%token TOK_OPTIONAL
+%token TOK_POINTER
+%token TOK_CONTINUE
+%token TOK_SAVE
+%token TOK_TARGET
+%token TOK_QUOTE
+%token TOK_IMPLICIT
+%token TOK_NONE
+%token TOK_CALL
+%token TOK_STAT
+%token TOK_POINT_TO
+%token TOK_COMMON
+%token TOK_GLOBAL
+%token TOK_INTERFACE
+%token TOK_ENDINTERFACE
+%token TOK_LEFTAB
+%token TOK_RIGHTAB
+%token TOK_PAUSE
+%token TOK_PROCEDURE
+%token TOK_STOP
+%token TOK_NAMEEQ
+%token TOK_REAL8
+%token TOK_OUT
+%token TOK_INOUT
+%token TOK_IN
+%token TOK_USE
+%token TOK_DSLASH
+%token TOK_DASTER
+%token TOK_EQ
+%token TOK_EQV
+%token TOK_GT
+%token TOK_LT
+%token TOK_GE
+%token TOK_NE
+%token TOK_NEQV
+%token TOK_LE
+%token TOK_OR
+%token TOK_XOR
+%token TOK_NOT
+%token TOK_AND
+%token TOK_TRUE
+%token TOK_FALSE
+%token TOK_LABEL
+%token TOK_TYPE
+%token TOK_TYPEPAR
+%token TOK_ENDTYPE
+%token TOK_REAL
+%token TOK_INTEGER
+%token TOK_LOGICAL
+%token TOK_DOUBLEPRECISION
+%token TOK_DOUBLEREAL
+%token TOK_ENDSUBROUTINE
+%token TOK_ENDFUNCTION
+%token TOK_ENDPROGRAM
+%token TOK_ENDUNIT
+%token TOK_CHARACTER
+%token TOK_CHAR_CONSTANT
+%token TOK_CHAR_CUT
+%token TOK_DATA
+%token TOK_CHAR_INT
+%token TOK_CHAR_MESSAGE
+%token TOK_CSTREAL
+%token TOK_CSTREALDP
+%token TOK_CSTREALQP
+%token TOK_SFREAL
+%token TOK_COMPLEX
+%token TOK_DOUBLECOMPLEX
+%token TOK_NAME
+%token TOK_NAME_CHAR
+%token TOK_PROBTYPE /* dimension of the problem */
+%token TOK_INTERPTYPE/* kind of interpolation */
+%token TOK_VARTYPE /* posit ion of the grid variable on the cells of */
+ /* the mesh */
+%token TOK_SLASH
+%token TOK_BC /* calculation of the boundary conditions */
+%token TOK_OP
+%token TOK_CSTINT
+%token TOK_COMMENT
+%token TOK_FILENAME
+%token ','
+%token ':'
+%token '('
+%token ')'
+%token '['
+%token ']'
+%token '!'
+%token '_'
+%token '<'
+%token '>'
+%type dcl
+%type after_type
+%type dimension
+%type paramlist
+%type args
+%type arglist
+%type only_list
+%type only_name
+%type rename_list
+%type rename_name
+%type dims
+%type dimlist
+%type dim
+%type paramitem
+%type comblock
+%type name_routine
+%type module_name
+%type opt_name
+%type type
+%type word_endsubroutine
+%type word_endfunction
+%type word_endprogram
+%type word_endunit
+%type typename
+%type typespec
+%type string_constant
+%type simple_const
+%type ident
+%type do_var
+%type intent_spec
+%type signe
+%type opt_signe
+%type filename
+%type attribute
+%type complex_const
+%type begin_array
+%type clause
+%type arg
+%type uexpr
+%type minmaxlist
+%type lhs
+%type vec
+%type outlist
+%type out2
+%type other
+%type dospec
+%type expr_data
+%type structure_component
+%type array_ele_substring_func_ref
+%type funarglist
+%type funarg
+%type funargs
+%type triplet
+%type substring
+%type opt_substring
+%type opt_expr
+%type optexpr
+%type datavallist
+%type datanamelist
+%type after_slash
+%type after_equal
+%type predefinedfunction
+%type expr
+%type ubound
+%type operation
+%type proper_lengspec
+%type use_name_list
+%type public
+
+%left TOK_OP
+%%
+input :
+ | input line
+ ;
+line : '\n' position
+ | thislabel suite_line_list
+ | TOK_COMMENT
+ | keyword cmnt writedeclar
+ | error writedeclar nulcurbuf
+ {yyerrok;yyclearin;}
+ ;
+suite_line_list : suite_line
+ | suite_line_list TOK_SEMICOLON suite_line
+ ;
+suite_line : entry fin_line /* subroutine, function, module */
+ | spec fin_line /* declaration */
+ | before_include filename fin_line
+ {
+ if (inmoduledeclare == 0 )
+ {
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curinclude,
+ pos_end-pos_curinclude);
+ }
+ }
+ | exec cmnt writedeclar /* if, do etc ... */
+ | instr fin_line /* instruction ident : do i = 1 ... */
+ ;
+instr : ident ':'
+ ;
+fin_line : position cmnt
+ ;
+keyword : TOK_DONOTTREAT
+ {
+ /* we should ignore the declaration until the keyword */
+ /* TOK_ENDDONOTTREAT */
+ couldaddvariable = 0 ;
+ RemoveWordCUR_0(fortranout,-20,20);
+ }
+ | TOK_ENDDONOTTREAT
+ {
+ couldaddvariable = 1 ;
+ RemoveWordCUR_0(fortranout,-24,24);
+ }
+ | TOK_OMP
+ | TOK_DOLLAR
+ ;
+position : {pos_cur = setposcur();}
+ ;
+thislabel :
+ | TOK_LABEL nulcurbuf
+ ;
+cmnt :
+ | TOK_COMMENT
+ ;
+incomment :
+ {incom = 1;}
+ ;
+nulcurbuf :
+ {if (incom !=1) {strcpy(curbuf,"");incom=0;}}
+ ;
+opt_recursive :
+ {isrecursive = 0;}
+ | TOK_RECURSIVE
+ {isrecursive = 1;}
+ ;
+entry :
+ | opt_recursive TOK_SUBROUTINE name_routine arglist
+ {
+ if ( couldaddvariable == 1)
+ {
+ /* open param file */
+ if ( firstpass == 0 )
+ {
+ sprintf(ligne,"%s/ParamFile%s.h",nomdir,$3);
+ paramout=fopen(ligne,"w");
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+
+ }
+ Add_SubroutineArgument_Var_1($4);
+ if ( inmodulemeet == 1 )
+ {
+ insubroutinedeclare = 1;
+ /* in the second step we should write the head of */
+ /* the subroutine sub_loop_ */
+ writeheadnewsub_0(1);
+ }
+ else
+ {
+ insubroutinedeclare = 1;
+ writeheadnewsub_0(1);
+ }
+ }
+ }
+ | TOK_PROGRAM name_routine
+ {
+ /* open param file */
+ if ( firstpass == 0 )
+ {
+ sprintf(ligne,"%s/ParamFile%s.h",nomdir,$2);
+ paramout=fopen(ligne,"w");
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+
+ }
+ strcpy(subroutinename,$2);
+ /* Common case */
+ insubroutinedeclare = 1;
+ /* in the second step we should write the head of */
+ /* the subroutine sub_loop_ */
+ writeheadnewsub_0(1);
+ }
+ | opt_recursive TOK_FUNCTION name_routine arglist TOK_RESULT arglist1
+ {
+ /* open param file */
+ if ( firstpass == 0 )
+ {
+ sprintf(ligne,"%s/ParamFile%s.h",nomdir,$3);
+ paramout=fopen(ligne,"w");
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+ }
+ strcpy(subroutinename,$3);
+ if ( inmodulemeet == 1 )
+ {
+ insubroutinedeclare = 1;
+ /* we should to list of the subroutine argument the */
+ /* name of the function which has to be defined */
+ Add_SubroutineArgument_Var_1($4);
+ strcpy(DeclType,"");
+ /* in the second step we should write the head of */
+ /* the subroutine sub_loop_ */
+ writeheadnewsub_0(2);
+ }
+ else
+ {
+ insubroutinedeclare = 1;
+ /* we should to list of the subroutine argument */
+ /* name of the function which has to be defined */
+ Add_SubroutineArgument_Var_1($4);
+ strcpy(DeclType,"");
+ Add_FunctionType_Var_1($3);
+ writeheadnewsub_0(2);
+ }
+ }
+ | opt_recursive TOK_FUNCTION name_routine arglist
+ {
+ /* open param file */
+ if ( firstpass == 0 )
+ {
+ sprintf(ligne,"%s/ParamFile%s.h",nomdir,$3);
+ paramout=fopen(ligne,"w");
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+ }
+ strcpy(subroutinename,$3);
+ if ( inmodulemeet == 1 )
+ {
+ insubroutinedeclare = 1;
+ /* we should to list of the subroutine argument the */
+ /* name of the function which has to be defined */
+ Add_SubroutineArgument_Var_1($4);
+ strcpy(DeclType,"");
+ Add_FunctionType_Var_1($3);
+ /* in the second step we should write the head of */
+ /* the subroutine sub_loop_ */
+ writeheadnewsub_0(2);
+ }
+ else
+ {
+ insubroutinedeclare = 1;
+ /* we should to list of the subroutine argument */
+ /* name of the function which has to be defined */
+ Add_SubroutineArgument_Var_1($4);
+ strcpy(DeclType,"");
+ Add_FunctionType_Var_1($3);
+ writeheadnewsub_0(2);
+ }
+ }
+ | TOK_MODULE TOK_NAME
+ {
+ GlobalDeclaration = 0;
+ strcpy(curmodulename,$2);
+ strcpy(subroutinename,"");
+ Add_NameOfModule_1($2);
+ if ( inmoduledeclare == 0 )
+ {
+ /* To know if there are in the module declaration */
+ inmoduledeclare = 1;
+ /* to know if a module has been met */
+ inmodulemeet = 1;
+ /* to know if we are after the keyword contains */
+ aftercontainsdeclare = 0 ;
+ }
+ }
+ ;
+name_routine : TOK_NAME
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy($$,$1);strcpy(subroutinename,$1);
+ }
+ }
+writedeclar :
+ ;
+before_include : TOK_INCLUDE
+ {
+ pos_curinclude = setposcur()-9;
+ }
+filename : TOK_CHAR_CONSTANT
+ {
+ if ( couldaddvariable == 1 ) Add_Include_1($1);
+ }
+ ;
+arglist : {
+ if ( firstpass == 1 && couldaddvariable == 1) $$=NULL;
+ }
+ | '(' ')' {
+ if ( firstpass == 1 && couldaddvariable == 1 ) $$=NULL;
+ }
+ | '(' args ')'
+ {
+ if ( firstpass == 1 && couldaddvariable == 1 ) $$=$2;
+ }
+ ;
+arglist1:
+ | '(' ')'
+ | '(' args ')'
+ {
+ if ( couldaddvariable == 1 )
+ {
+ Add_SubroutineArgument_Var_1($2);
+ }
+ }
+ ;
+args :arg {
+ if ( firstpass == 1 && couldaddvariable == 1)
+ {
+ strcpy(nameinttypenameback,nameinttypename);
+ strcpy(nameinttypename,"");
+ curvar=createvar($1,NULL);
+ strcpy(nameinttypename,nameinttypenameback);
+ curlistvar=insertvar(NULL,curvar);
+ $$=settype("",curlistvar);
+ }
+ }
+ | args ',' arg
+ {
+ if ( firstpass == 1 && couldaddvariable == 1)
+ {
+ strcpy(nameinttypenameback,nameinttypename);
+ strcpy(nameinttypename,"");
+ curvar=createvar($3,NULL);
+ strcpy(nameinttypename,nameinttypenameback);
+ $$=insertvar($1,curvar);
+ }
+ }
+ ;
+arg : TOK_NAME {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ | '*' {if ( couldaddvariable == 1 ) strcpy($$,"*");}
+ ;
+spec : type after_type
+ {
+ if ( VarTypepar == 1 )
+ {
+ couldaddvariable = 1 ;
+ VarTypepar = 0;
+ }
+ }
+ | TOK_TYPE opt_spec opt_sep opt_name
+ {
+ if ( couldaddvariable == 1 )
+ {
+ VarType = 1;
+ couldaddvariable = 0 ;
+ }
+ }
+ | TOK_ENDTYPE opt_name
+ {
+ if ( VarType == 1 ) couldaddvariable = 1 ;
+ VarType = 0;
+ VarTypepar = 0;
+ }
+ | TOK_POINTER list_couple
+ | before_parameter '(' paramlist ')'
+ {
+ if ( couldaddvariable == 1 )
+ {
+ if ( insubroutinedeclare == 0 )
+ {
+ Add_GlobalParameter_Var_1($3);
+ }
+ else Add_Parameter_Var_1($3);
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_cur_decl,
+ pos_end-pos_cur_decl);
+ }
+ VariableIsParameter = 0 ;
+ }
+ | before_parameter paramlist
+ {
+ if ( couldaddvariable == 1 )
+ {
+ if ( insubroutinedeclare == 0 )
+ Add_GlobalParameter_Var_1($2);
+ else Add_Parameter_Var_1($2);
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_cur_decl,
+ pos_end-pos_cur_decl);
+ }
+ VariableIsParameter = 0 ;
+ }
+ | common
+ | save
+ {
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_cursave,
+ pos_end-pos_cursave);
+ }
+ | implicit
+ | dimension
+ {
+ /* if the variable is a parameter we can suppose that is */
+ /* value is the same on each grid. It is not useless to */
+ /* create a copy of it on each grid */
+ if ( couldaddvariable == 1 )
+ {
+ Add_Globliste_1($1);
+ /* if variableparamlists has been declared in a */
+ /* subroutine */
+ if ( insubroutinedeclare == 1 )
+ {
+ Add_Dimension_Var_1($1);
+ }
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curdimension,
+ pos_end-pos_curdimension);
+ }
+ /* */
+ PublicDeclare = 0;
+ PrivateDeclare = 0;
+ ExternalDeclare = 0;
+ strcpy(NamePrecision,"");
+ c_star = 0;
+ strcpy(InitialValueGiven," ");
+ strcpy(IntentSpec,"");
+ VariableIsParameter = 0 ;
+ Allocatabledeclare = 0 ;
+ Targetdeclare = 0 ;
+ SaveDeclare = 0;
+ pointerdeclare = 0;
+ optionaldeclare = 0 ;
+ dimsgiven=0;
+ c_selectorgiven=0;
+ strcpy(nameinttypename,"");
+ strcpy(c_selectorname,"");
+ }
+ | public
+ {
+ if (firstpass == 0)
+ {
+ if ($1)
+ {
+ removeglobfromlist(&($1));
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_cur,pos_end-pos_cur);
+ writelistpublic($1);
+ }
+ }
+ }
+ | private
+ | use_stat
+ | module_proc_stmt
+ | interface
+ | namelist
+ | TOK_BACKSPACE '(' expr ')'
+ | TOK_EXTERNAL opt_sep use_name_list
+ | TOK_INTRINSIC opt_sep use_intrinsic_list
+ | TOK_EQUIVALENCE list_expr_equi
+ | before_data data '\n'
+ {
+ /* we should remove the data declaration */
+ if ( couldaddvariable == 1 && aftercontainsdeclare != 2 )
+ {
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curdata,
+ pos_end-pos_curdata);
+ }
+ if ( couldaddvariable == 1 && aftercontainsdeclare == 1 )
+ {
+ if (firstpass == 0)
+ {
+ ReWriteDataStatement_0(fortranout);
+ pos_end = setposcur();
+ }
+ }
+ }
+ ;
+opt_spec :
+ | access_spec
+ {
+ PublicDeclare = 0 ;
+ PrivateDeclare = 0 ;
+ }
+ ;
+name_intrinsic : TOK_SUM
+ | TOK_TANH
+ | TOK_MAXVAL
+ | TOK_MIN
+ | TOK_MINVAL
+ | TOK_TRIM
+ | TOK_SQRT
+ | TOK_NINT
+ | TOK_FLOAT
+ | TOK_EXP
+ | TOK_COS
+ | TOK_COSH
+ | TOK_ACOS
+ | TOK_SIN
+ | TOK_SINH
+ | TOK_ASIN
+ | TOK_LOG
+ | TOK_TAN
+ | TOK_ATAN
+ | TOK_MOD
+ | TOK_SIGN
+ | TOK_MINLOC
+ | TOK_MAXLOC
+ | TOK_NAME
+ ;
+use_intrinsic_list : name_intrinsic
+ | use_intrinsic_list ',' name_intrinsic
+ ;
+list_couple : '(' list_expr ')'
+ | list_couple ',' '(' list_expr ')'
+ ;
+list_expr_equi : expr_equi
+ | list_expr_equi ',' expr_equi
+ ;
+expr_equi : '(' list_expr_equi1 ')'
+ ;
+list_expr_equi1 : ident dims
+ | list_expr_equi1 ',' ident dims
+ ;
+list_expr : expr
+ | list_expr ',' expr
+ ;
+opt_sep :
+ | ':' ':'
+ ;
+after_type : dcl nodimsgiven
+ {
+ /* if the variable is a parameter we can suppose that is*/
+ /* value is the same on each grid. It is not useless */
+ /* to create a copy of it on each grid */
+ if ( couldaddvariable == 1 )
+ {
+ pos_end = setposcur();
+ /*if (insubroutinedeclare == 0)
+ { */
+ RemoveWordSET_0(fortranout,pos_cur_decl,
+ pos_end-pos_cur_decl);
+
+ /* }
+ else
+ {*/
+ ReWriteDeclarationAndAddTosubroutine_01($1);
+ pos_cur_decl = setposcur();
+
+ /*}*/
+ if ( firstpass == 0 &&
+ GlobalDeclaration == 0 &&
+ insubroutinedeclare == 0 )
+ {
+
+ sprintf(ligne,"\n#include \"Module_Declar_%s.h\"\n"
+ ,curmodulename);
+ tofich(fortranout,ligne,1);
+ sprintf (ligne, "Module_Declar_%s.h",curmodulename);
+ module_declar = associate(ligne);
+ sprintf (ligne, " ");
+ tofich (module_declar, ligne,1);
+ GlobalDeclaration = 1 ;
+ pos_cur_decl = setposcur();
+
+ }
+ $$ = $1;
+ Add_Globliste_1($1);
+
+ if ( insubroutinedeclare == 0 )
+ Add_GlobalParameter_Var_1($1);
+ else
+ {
+ if ( pointerdeclare == 1 )
+ Add_Pointer_Var_From_List_1($1);
+ Add_Parameter_Var_1($1);
+ }
+
+ /* if variables has been declared in a subroutine */
+ if ( insubroutinedeclare == 1 )
+ {
+ /* Add_SubroutineDeclaration_Var_1($1);*/
+ }
+ /* If there are a SAVE declarations in module's */
+ /* subroutines we should remove it from the */
+ /* subroutines declaration and add it in the */
+ /* global declarations */
+ if ( aftercontainsdeclare == 1 &&
+ SaveDeclare == 1 && firstpass == 1 )
+ {
+ if ( inmodulemeet == 0 ) Add_Save_Var_dcl_1($1);
+ else Add_SubroutineDeclarationSave_Var_1($1);
+ }
+ }
+ /* */
+ PublicDeclare = 0;
+ PrivateDeclare = 0;
+ ExternalDeclare = 0;
+ strcpy(NamePrecision,"");
+ c_star = 0;
+ strcpy(InitialValueGiven," ");
+ strcpy(IntentSpec,"");
+ VariableIsParameter = 0 ;
+ Allocatabledeclare = 0 ;
+ Targetdeclare = 0 ;
+ SaveDeclare = 0;
+ pointerdeclare = 0;
+ optionaldeclare = 0 ;
+ dimsgiven=0;
+ c_selectorgiven=0;
+ strcpy(nameinttypename,"");
+ strcpy(c_selectorname,"");
+ GlobalDeclarationType = 0;
+ }
+ | before_function name_routine arglist
+ {
+ /* open param file */
+ if ( firstpass == 0 )
+ {
+ sprintf(ligne,"%s/ParamFile%s.h",nomdir,$2);
+ paramout=fopen(ligne,"w");
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+ }
+ strcpy(subroutinename,$2);
+ if ( inmodulemeet == 1 )
+ {
+ insubroutinedeclare = 1;
+ /* we should to list of the subroutine argument the */
+ /* name of the function which has to be defined */
+ Add_SubroutineArgument_Var_1($3);
+ Add_FunctionType_Var_1($2);
+ /* in the second step we should write the head of */
+ /* the subroutine sub_loop_ */
+ writeheadnewsub_0(2);
+ }
+ else
+ {
+ insubroutinedeclare = 1;
+ /* we should to list of the subroutine argument the */
+ /* name of the function which has to be defined */
+ Add_SubroutineArgument_Var_1($3);
+ Add_FunctionType_Var_1($2);
+ /* in the second step we should write the head of */
+ /* the subroutine sub_loop_ */
+ writeheadnewsub_0(2);
+ }
+ strcpy(nameinttypename,"");
+
+ }
+ ;
+before_function : TOK_FUNCTION
+ {
+ functiondeclarationisdone = 1;
+ }
+ ;
+
+before_parameter : TOK_PARAMETER
+ {
+ VariableIsParameter = 1;
+ pos_curparameter = setposcur()-9;
+ }
+before_data : TOK_DATA
+ {
+ pos_curdata = setposcur()-strlen($1);
+ Init_List_Data_Var();
+ }
+data : TOK_NAME TOK_SLASH datavallist TOK_SLASH
+ {
+ if ( couldaddvariable == 1 )
+ {
+/* if ( aftercontainsdeclare == 1 ) strcpy(ligne,"");
+ else */
+/* sprintf(ligne,"%s",$3);*/
+ createstringfromlistname(ligne,$3);
+ if (firstpass == 1)
+ Add_Data_Var_1(&List_Data_Var,$1,ligne);
+ else
+ Add_Data_Var_1(&List_Data_Var_Cur,$1,ligne);
+ }
+ }
+ | data opt_comma TOK_NAME TOK_SLASH datavallist TOK_SLASH
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /*if ( aftercontainsdeclare == 1 ) strcpy(ligne,"");
+ else */
+ /*sprintf(ligne,"%s",$5); */
+ createstringfromlistname(ligne,$5);
+ if (firstpass == 1)
+ Add_Data_Var_1(&List_Data_Var,$3,ligne);
+ else
+ Add_Data_Var_1(&List_Data_Var_Cur,$3,ligne);
+ }
+ }
+ | datanamelist TOK_SLASH datavallist TOK_SLASH
+ {
+ /*******************************************************/
+ /*******************************************************/
+ /*******************************************************/
+ /*******************************************************/
+ /*******************************************************/
+ /*******************************************************/
+ /*******************************************************/
+ if (firstpass == 1)
+ Add_Data_Var_Names_01(&List_Data_Var,$1,$3);
+ else
+ Add_Data_Var_Names_01(&List_Data_Var_Cur,$1,$3);
+ }
+ ;
+datavallist : expr_data
+ {
+ if ( couldaddvariable == 1 )
+ {
+ $$ = Insertname(NULL,$1,0);
+ }
+ }
+ | expr_data ',' datavallist
+ {
+ if ( couldaddvariable == 1 )
+ {
+ $$ = Insertname($3,$1,1);
+ }
+ }
+ ;
+
+save : before_save varsave
+ | before_save comblock varsave
+ | save opt_comma comblock opt_comma varsave
+ | save ',' varsave
+ ;
+before_save : TOK_SAVE
+ {
+ pos_cursave = setposcur()-4;
+ }
+ ;
+varsave :
+ | TOK_NAME dims
+ {
+ if ( couldaddvariable == 1 ) Add_Save_Var_1($1,$2);
+ }
+ ;
+datanamelist : TOK_NAME
+ {
+ $$=Insertname(NULL,$1,0);
+ }
+ | TOK_NAME '(' expr ')'
+ {
+ printf("INSTRUCTION NON TRAITEE : INITIALISATION DE DATA AVEC EXPRESSION\n");
+ exit(0);
+ }
+ | datanamelist ',' datanamelist
+ {
+ $$ = concat_listname($1,$3);
+ }
+ ;
+expr_data : opt_signe simple_const
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s%s",$1,$2);}
+ | expr_data '+' expr_data
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s+%s",$1,$3);}
+ | expr_data '-' expr_data
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s-%s",$1,$3);}
+ | expr_data '*' expr_data
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s*%s",$1,$3);}
+ | expr_data '/' expr_data
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s/%s",$1,$3);}
+ ;
+opt_signe :
+ {if ( couldaddvariable == 1 ) strcpy($$,"");}
+ | signe
+ {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ ;
+namelist : namelist_action after_namelist
+ ;
+namelist_action : TOK_NAMELIST ident
+ | TOK_NAMELIST comblock ident
+ | namelist_action opt_comma comblock opt_comma ident
+ | namelist_action ',' ident
+ ;
+after_namelist :
+ ;
+interface : TOK_INTERFACE opt_name
+ {
+ ininterfacedeclare = 1 ;
+ printf("INTEFACE entree\n");
+ }
+ | TOK_ENDINTERFACE opt_name
+ {
+ ininterfacedeclare = 0;
+ }
+ ;
+before_dimension : TOK_DIMENSION
+ {
+ positioninblock=0;
+ pos_curdimension = setposcur()-9;
+ }
+
+dimension : before_dimension opt_comma TOK_NAME dims lengspec
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* */
+ curvar=createvar($3,$4);
+ /* */
+ CreateAndFillin_Curvar("",curvar);
+ /* */
+ curlistvar=insertvar(NULL,curvar);
+ /* */
+ $$=settype("",curlistvar);
+ /* */
+ strcpy(vallengspec,"");
+ }
+ }
+ | dimension ',' TOK_NAME dims lengspec
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* */
+ curvar=createvar($3,$4);
+ /* */
+ CreateAndFillin_Curvar("",curvar);
+ /* */
+ curlistvar=insertvar($1,curvar);
+ /* */
+ $$=curlistvar;
+ /* */
+ strcpy(vallengspec,"");
+ }
+ }
+ ;
+private : TOK_PRIVATE '\n'
+ | TOK_PRIVATE opt_sep use_name_list
+ ;
+public : TOK_PUBLIC '\n'
+ {
+ $$=(listname *)NULL;
+ }
+ | TOK_PUBLIC opt_sep use_name_list
+ {
+ $$=$3;
+ }
+ ;
+use_name_list : TOK_NAME
+ {
+ $$ = Insertname(NULL,$1,0);
+ }
+ | use_name_list ',' TOK_NAME
+ {
+ $$ = Insertname($1,$3,0);
+ }
+ ;
+common : before_common var_common_list
+ {
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curcommon,
+ pos_end-pos_curcommon);
+ }
+ | before_common comblock var_common_list
+ {
+ if ( couldaddvariable == 1 )
+ {
+ sprintf(charusemodule,"%s",$2);
+ Add_NameOfCommon_1($2,subroutinename);
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curcommon,
+ pos_end-pos_curcommon);
+ }
+ }
+ | common opt_comma comblock opt_comma var_common_list
+ {
+ if ( couldaddvariable == 1 )
+ {
+ sprintf(charusemodule,"%s",$3);
+ Add_NameOfCommon_1($3,subroutinename);
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curcommon,
+ pos_end-pos_curcommon);
+ }
+ }
+ ;
+before_common : TOK_COMMON
+ {
+ positioninblock=0;
+ pos_curcommon = setposcur()-6;
+ }
+ | TOK_GLOBAL TOK_COMMON
+ {
+ positioninblock=0;
+ pos_curcommon = setposcur()-6-7;
+ }
+ ;
+var_common_list : var_common
+ {
+ if ( couldaddvariable == 1 ) Add_Common_var_1();
+ }
+
+ | var_common_list ',' var_common
+ {
+ if ( couldaddvariable == 1 ) Add_Common_var_1();
+ }
+var_common : TOK_NAME dims
+ {
+ if ( couldaddvariable == 1 )
+ {
+ positioninblock = positioninblock + 1 ;
+ strcpy(commonvar,$1);
+ commondim = $2;
+ }
+ }
+ ;
+comblock : TOK_DSLASH
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy($$,"");
+ positioninblock=0;
+ strcpy(commonblockname,"");
+ }
+ }
+ | TOK_SLASH TOK_NAME TOK_SLASH
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy($$,$2);
+ positioninblock=0;
+ strcpy(commonblockname,$2);
+ }
+ }
+ ;
+opt_comma :
+ | ','
+ ;
+paramlist : paramitem
+ {
+ if ( couldaddvariable == 1 ) $$=insertvar(NULL,$1);
+ }
+ | paramlist ',' paramitem
+ {
+ if ( couldaddvariable == 1 ) $$=insertvar($1,$3);
+ }
+ ;
+paramitem : TOK_NAME '=' expr
+ {
+ if ( couldaddvariable == 1 )
+ {
+ curvar=(variable *) malloc(sizeof(variable));
+ /* */
+ Init_Variable(curvar);
+ /* */
+ curvar->v_VariableIsParameter=1;
+ strcpy(curvar->v_nomvar,$1);
+ Save_Length($1,4);
+ strcpy(curvar->v_subroutinename,subroutinename);
+ Save_Length(subroutinename,11);
+ strcpy(curvar->v_modulename,curmodulename);
+ Save_Length(curmodulename,6);
+ strcpy(curvar->v_initialvalue,$3);
+ Save_Length($3,14);
+ strcpy(curvar->v_commoninfile,mainfile);
+ Save_Length(mainfile,10);
+ $$=curvar;
+ }
+ }
+ ;
+module_proc_stmt : TOK_PROCEDURE proc_name_list
+ ;
+proc_name_list : TOK_NAME
+ | proc_name_list ',' TOK_NAME
+ ;
+implicit : TOK_IMPLICIT TOK_NONE
+ {
+ if ( insubroutinedeclare == 1 )
+ {
+ Add_ImplicitNoneSubroutine_1();
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_end-13,
+ 13);
+ }
+ }
+ | TOK_IMPLICIT TOK_REAL8
+ ;
+opt_retour :
+ ;
+dcl : options opt_retour TOK_NAME dims lengspec initial_value
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* */
+ if (dimsgiven == 1)
+ {
+ curvar=createvar($3,curdim);
+ GlobalDeclarationType == 0;
+ }
+ else
+ {
+ curvar=createvar($3,$4);
+ }
+ /* */
+ CreateAndFillin_Curvar(DeclType,curvar);
+ /* */
+ curlistvar=insertvar(NULL,curvar);
+ if (!strcasecmp(DeclType,"character"))
+ {
+ if (c_selectorgiven == 1)
+ {
+ strcpy(c_selectordim.first,"1");
+ strcpy(c_selectordim.last,c_selectorname);
+ Save_Length(c_selectorname,1);
+ change_dim_char
+ (insertdim(NULL,c_selectordim),curlistvar);
+ }
+ }
+ $$=settype(DeclType,curlistvar);
+ }
+ strcpy(vallengspec,"");
+ }
+ | dcl ',' opt_retour TOK_NAME dims lengspec initial_value
+ {
+ if ( couldaddvariable == 1 )
+ {
+ if (dimsgiven == 1)
+ {
+ curvar=createvar($4,curdim);
+ }
+ else
+ {
+ curvar=createvar($4,$5);
+ }
+ /* */
+ CreateAndFillin_Curvar($1->var->v_typevar,curvar);
+ /* */
+ strcpy(curvar->v_typevar,($1->var->v_typevar));
+ Save_Length($1->var->v_typevar,3);
+ /* */
+ curlistvar=insertvar($1,curvar);
+ if (!strcasecmp(DeclType,"character"))
+ {
+ if (c_selectorgiven == 1)
+ {
+ strcpy(c_selectordim.first,"1");
+ strcpy(c_selectordim.last,c_selectorname);
+ Save_Length(c_selectorname,1);
+ change_dim_char
+ (insertdim(NULL,c_selectordim),curlistvar);
+ }
+ }
+ $$=curlistvar;
+ }
+ strcpy(vallengspec,"");
+ }
+ ;
+nodimsgiven : {dimsgiven=0;}
+ ;
+type : typespec selector
+ {strcpy(DeclType,$1);}
+ | before_character c_selector
+ {
+ strcpy(DeclType,"CHARACTER");
+ }
+ | typename '*' TOK_CSTINT
+ {
+ strcpy(DeclType,$1);
+ strcpy(nameinttypename,$3);
+ }
+ | before_typepar attribute ')'
+ {
+ strcpy(DeclType,"TYPE");
+ GlobalDeclarationType = 1
+ }
+ ;
+before_typepar : TOK_TYPEPAR
+ {
+ /* if ( couldaddvariable == 1 ) VarTypepar = 1 ;
+ couldaddvariable = 0 ;
+ pos_cur_decl = setposcur()-5;*/
+ pos_cur_decl = setposcur()-5;
+ }
+ ;
+c_selector :
+ | '*' TOK_CSTINT
+ {c_selectorgiven=1;strcpy(c_selectorname,$2);}
+ | '*' '(' c_attribute ')' {c_star = 1;}
+ | '(' c_attribute ')'
+ ;
+c_attribute : TOK_NAME clause opt_clause
+ | TOK_NAME '=' clause opt_clause
+ | clause opt_clause
+ ;
+before_character : TOK_CHARACTER
+ {
+ pos_cur_decl = setposcur()-9;
+ }
+ ;
+typespec : typename {strcpy($$,$1);}
+ ;
+typename : TOK_INTEGER
+ {
+ strcpy($$,"INTEGER");
+ pos_cur_decl = setposcur()-7;
+ }
+ | TOK_REAL {
+ strcpy($$,"REAL");
+ pos_cur_decl = setposcur()-4;
+ }
+ | TOK_COMPLEX
+ {strcpy($$,"COMPLEX");
+ pos_cur_decl = setposcur()-7;}
+ | TOK_DOUBLEPRECISION
+ {
+ pos_cur_decl = setposcur()-16;
+ strcpy($$,"REAL");
+ strcpy(nameinttypename,"8");
+ }
+ | TOK_DOUBLECOMPLEX
+ {strcpy($$,"DOUBLE COMPLEX");}
+ | TOK_LOGICAL
+ {
+ strcpy($$,"LOGICAL");
+ pos_cur_decl = setposcur()-7;
+ }
+ ;
+lengspec :
+ | '*' proper_lengspec {strcpy(vallengspec,$2);}
+ ;
+proper_lengspec : expr {sprintf($$,"*%s",$1);}
+ | '(' '*' ')'{strcpy($$,"*(*)");}
+ ;
+selector :
+ | '*' proper_selector
+ | '(' attribute ')'
+ ;
+proper_selector : expr
+ | '(' '*' ')'
+ ;
+attribute : TOK_NAME clause
+ | TOK_NAME '=' clause
+ {
+ if ( strstr($3,"0.d0") )
+ {
+ strcpy(nameinttypename,"8");
+ sprintf(NamePrecision,"");
+ }
+ else sprintf(NamePrecision,"%s = %s",$1,$3);
+ }
+ | TOK_NAME
+ {
+ strcpy(NamePrecision,$1);
+ }
+ | TOK_CSTINT
+ {
+ strcpy(NamePrecision,$1);
+ }
+ ;
+clause : expr {strcpy(CharacterSize,$1);
+ strcpy($$,$1);}
+ | '*' {strcpy(CharacterSize,"*");
+ strcpy($$,"*");}
+ ;
+opt_clause :
+ | ',' TOK_NAME clause
+ ;
+options :
+ | ':' ':'
+ | ',' attr_spec_list ':' ':'
+ ;
+attr_spec_list : attr_spec
+ | attr_spec_list ',' attr_spec
+ ;
+attr_spec : TOK_PARAMETER
+ {
+ VariableIsParameter = 1;
+ }
+ | access_spec
+ | TOK_ALLOCATABLE
+ {Allocatabledeclare = 1;}
+ | TOK_DIMENSION dims
+ {
+ dimsgiven=1;
+ curdim=$2;
+ }
+ | TOK_EXTERNAL
+ {ExternalDeclare = 1;}
+ | TOK_INTENT '(' intent_spec ')'
+ {strcpy(IntentSpec,$3);}
+ | TOK_INTRINSIC
+ | TOK_OPTIONAL{optionaldeclare = 1 ;}
+ | TOK_POINTER {pointerdeclare = 1 ;}
+ | TOK_SAVE {
+/* if ( inmodulemeet == 1 )
+ {*/
+ SaveDeclare = 1 ;
+ /* }*/
+ }
+ | TOK_TARGET
+ {Targetdeclare = 1;}
+ ;
+intent_spec : TOK_IN {strcpy($$,$1);}
+ | TOK_OUT {strcpy($$,$1);}
+ | TOK_INOUT {strcpy($$,$1); }
+ ;
+access_spec : TOK_PUBLIC
+ {PublicDeclare = 1;}
+ | TOK_PRIVATE
+ {PrivateDeclare = 1;}
+ ;
+dims : {if ( created_dimensionlist == 1 )
+ {
+ $$=(listdim *)NULL;
+ }
+ }
+ | '(' dimlist ')'
+ {if ( created_dimensionlist == 1 ||
+ agrif_parentcall == 1 ) $$=$2;}
+ ;
+dimlist : dim {if ( created_dimensionlist == 1 ||
+ agrif_parentcall == 1 ) $$=insertdim(NULL,$1);}
+ | dimlist ',' dim
+ {if ( couldaddvariable == 1 )
+ if ( created_dimensionlist == 1 ) $$=insertdim($1,$3);}
+ ;
+dim : ubound {
+ strcpy($$.first,"1");
+ strcpy($$.last,$1);
+ Save_Length($1,1);
+ }
+ | ':' {
+ strcpy($$.first,"");
+ strcpy($$.last,"");
+ }
+ | expr ':' {
+ strcpy($$.first,$1);
+ Save_Length($1,2);
+ strcpy($$.last,"");
+ }
+ | ':' expr {
+ strcpy($$.first,"");
+ strcpy($$.last,$2);
+ Save_Length($2,1);
+ }
+ | expr ':' ubound
+ {
+ strcpy($$.first,$1);
+ Save_Length($1,2);
+ strcpy($$.last,$3);
+ Save_Length($3,1);
+ }
+ ;
+ubound : '*' {strcpy($$,"*");}
+ | expr {strcpy($$,$1);}
+ ;
+expr : uexpr {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ | '(' expr ')'
+ {if ( couldaddvariable == 1 ) sprintf($$,"(%s)",$2);}
+ | complex_const
+ {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ | predefinedfunction
+ {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ ;
+
+predefinedfunction : TOK_SUM minmaxlist ')'
+ {sprintf($$,"SUM(%s)",$2);}
+ | TOK_MAX minmaxlist ')'
+ {sprintf($$,"MAX(%s)",$2);}
+ | TOK_TANH '(' minmaxlist ')'
+ {sprintf($$,"TANH(%s)",$3);}
+ | TOK_MAXVAL '(' minmaxlist ')'
+ {sprintf($$,"MAXVAL(%s)",$3);}
+ | TOK_MIN minmaxlist ')'
+ {sprintf($$,"MIN(%s)",$2);}
+ | TOK_MINVAL '(' minmaxlist ')'
+ {sprintf($$,"MINVAL(%s)",$3);}
+ | TOK_TRIM '(' expr ')'
+ {sprintf($$,"TRIM(%s)",$3);}
+ | TOK_SQRT expr ')'
+ {sprintf($$,"SQRT(%s)",$2);}
+ | TOK_REAL '(' minmaxlist ')'
+ {sprintf($$,"REAL(%s)",$3);}
+ | TOK_NINT '(' expr ')'
+ {sprintf($$,"NINT(%s)",$3);}
+ | TOK_FLOAT '(' expr ')'
+ {sprintf($$,"FLOAT(%s)",$3);}
+ | TOK_EXP '(' expr ')'
+ {sprintf($$,"EXP(%s)",$3);}
+ | TOK_COS '(' expr ')'
+ {sprintf($$,"COS(%s)",$3);}
+ | TOK_COSH '(' expr ')'
+ {sprintf($$,"COSH(%s)",$3);}
+ | TOK_ACOS '(' expr ')'
+ {sprintf($$,"ACOS(%s)",$3);}
+ | TOK_SIN '(' expr ')'
+ {sprintf($$,"SIN(%s)",$3);}
+ | TOK_SINH '(' expr ')'
+ {sprintf($$,"SINH(%s)",$3);}
+ | TOK_ASIN '(' expr ')'
+ {sprintf($$,"ASIN(%s)",$3);}
+ | TOK_LOG '(' expr ')'
+ {sprintf($$,"LOG(%s)",$3);}
+ | TOK_TAN '(' expr ')'
+ {sprintf($$,"TAN(%s)",$3);}
+ | TOK_ATAN '(' expr ')'
+ {sprintf($$,"ATAN(%s)",$3);}
+ | TOK_ABS expr ')'
+ {sprintf($$,"ABS(%s)",$2);}
+ | TOK_MOD '(' minmaxlist ')'
+ {sprintf($$,"MOD(%s)",$3);}
+ | TOK_SIGN '(' minmaxlist ')'
+ {sprintf($$,"SIGN(%s)",$3);}
+ | TOK_MINLOC '(' minmaxlist ')'
+ {sprintf($$,"MINLOC(%s)",$3);}
+ | TOK_MAXLOC '(' minmaxlist ')'
+ {sprintf($$,"MAXLOC(%s)",$3);}
+ ;
+minmaxlist : expr {strcpy($$,$1);}
+ | minmaxlist ',' expr
+ {if ( couldaddvariable == 1 )
+ { strcpy($$,$1);strcat($$,",");strcat($$,$3);}}
+ ;
+uexpr : lhs {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ | simple_const
+ {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ | vec
+ {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ | expr operation
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s%s",$1,$2);}
+ | signe expr %prec '*'
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s%s",$1,$2);}
+ | TOK_NOT expr
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s%s",$1,$2);}
+ ;
+signe : '+' {if ( couldaddvariable == 1 ) strcpy($$,"+");}
+ | '-' {if ( couldaddvariable == 1 ) strcpy($$,"-");}
+ ;
+operation : '+' expr %prec '+'
+ {if ( couldaddvariable == 1 ) sprintf($$,"+%s",$2);}
+ | '-' expr %prec '+'
+ {if ( couldaddvariable == 1 ) sprintf($$,"-%s",$2);}
+ | '*' expr
+ {if ( couldaddvariable == 1 ) sprintf($$,"*%s",$2);}
+ | TOK_DASTER expr
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s%s",$1,$2);}
+ | TOK_EQ expr %prec TOK_EQ
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s%s",$1,$2);}
+ | TOK_EQV expr %prec TOK_EQV
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s%s",$1,$2);}
+ | TOK_GT expr %prec TOK_EQ
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s%s",$1,$2);}
+ | '>' expr %prec TOK_EQ
+ {if ( couldaddvariable == 1 ) sprintf($$," > %s",$2);}
+ | TOK_LT expr %prec TOK_EQ
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s%s",$1,$2);}
+ | '<' expr %prec TOK_EQ
+ {if ( couldaddvariable == 1 ) sprintf($$," < %s",$2);}
+ | TOK_GE expr %prec TOK_EQ
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s%s",$1,$2);}
+ | '>''=' expr %prec TOK_EQ
+ {if ( couldaddvariable == 1 ) sprintf($$," >= %s",$3);}
+ | TOK_LE expr %prec TOK_EQ
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s%s",$1,$2);}
+ | '<''=' expr %prec TOK_EQ
+ {if ( couldaddvariable == 1 ) sprintf($$," <= %s",$3);}
+ | TOK_NE expr %prec TOK_EQ
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s%s",$1,$2);}
+ | TOK_NEQV expr %prec TOK_EQV
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s%s",$1,$2);}
+ | TOK_XOR expr
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s%s",$1,$2);}
+ | TOK_OR expr
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s%s",$1,$2);}
+ | TOK_AND expr
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s%s",$1,$2);}
+ | TOK_SLASH after_slash
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s",$2);}
+ | '=' after_equal
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s",$2);}
+
+after_slash : {strcpy($$,"");}
+ | expr
+ {sprintf($$,"/%s",$1);}
+ | '=' expr %prec TOK_EQ
+ {sprintf($$,"/= %s",$2);}
+ | TOK_SLASH expr
+ {sprintf($$,"//%s",$2);}
+ ;
+after_equal : '=' expr %prec TOK_EQ
+ {if ( couldaddvariable == 1 ) sprintf($$,"==%s",$2);}
+ | expr
+ {if ( couldaddvariable == 1 ) sprintf($$,"= %s",$1);}
+ ;
+
+lhs : ident {if ( couldaddvariable == 1 )
+ {
+ printf("ident = %s\n",$1);
+ strcpy($$,$1);}
+ }
+ | structure_component
+ {if ( couldaddvariable == 1 ) {
+ printf("struct = %s\n",$1);
+ strcpy($$,$1);}
+ }
+ | array_ele_substring_func_ref
+ {if ( couldaddvariable == 1 ) {
+ printf("arrayref = %s\n",$1);
+ strcpy($$,$1);
+ }}
+ ;
+beforefunctionuse : {
+ agrif_parentcall =0;
+ if (!strcasecmp(identcopy,"Agrif_Parent") )
+ agrif_parentcall =1;
+ if ( Agrif_in_Tok_NAME(identcopy) == 1 )
+ {
+ inagrifcallargument = 1;
+ Add_SubroutineWhereAgrifUsed_1(subroutinename,
+ curmodulename);
+ }
+ }
+ ;
+array_ele_substring_func_ref : begin_array
+ {
+ strcpy($$,$1);
+ if ( incalldeclare == 0 ) inagrifcallargument = 0;
+ }
+ | begin_array substring
+ {if ( couldaddvariable == 1 ) sprintf($$," %s %s ",$1,$2);}
+ | structure_component '(' funarglist ')'
+ {if ( couldaddvariable == 1 )
+ sprintf($$," %s ( %s )",$1,$3);}
+ | structure_component '(' funarglist ')' substring
+ {if ( couldaddvariable == 1 )
+ sprintf($$," %s ( %s ) %s ",$1,$3,$5);}
+ ;
+begin_array : ident '(' funarglist ')'
+ {
+ if ( couldaddvariable == 1 )
+ {
+ sprintf($$," %s ( %s )",$1,$3);
+ ModifyTheAgrifFunction_0($3);
+ agrif_parentcall =0;
+ }
+ }
+ ;
+structure_component : lhs '%' lhs
+ {
+ sprintf($$," %s %% %s ",$1,$3);
+ if ( incalldeclare == 0 ) inagrifcallargument = 0;
+ }
+ ;
+vec : TOK_LEFTAB outlist TOK_RIGHTAB
+ {sprintf($$,"(/%s/)",$2);}
+ ;
+funarglist : beforefunctionuse {strcpy($$," ");}
+ | beforefunctionuse funargs
+ {strcpy($$,$2);}
+ ;
+funargs : funarg {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ | funargs ',' funarg
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s,%s",$1,$3);}
+ ;
+funarg : expr {strcpy($$,$1);}
+ | triplet {strcpy($$,$1);}
+ ;
+triplet : expr ':' expr
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s :%s",$1,$3);}
+ | expr ':' expr ':' expr
+ {if ( couldaddvariable == 1 )
+ sprintf($$,"%s :%s :%s",$1,$3,$5);}
+ | ':' expr ':' expr
+ {if ( couldaddvariable == 1 ) sprintf($$,":%s :%s",$2,$4);}
+ | ':' ':' expr{if ( couldaddvariable == 1 ) sprintf($$,": : %s",$3);}
+ | ':' expr {if ( couldaddvariable == 1 ) sprintf($$,":%s",$2);}
+ | expr ':' {if ( couldaddvariable == 1 ) sprintf($$,"%s :",$1);}
+ | ':' {if ( couldaddvariable == 1 ) sprintf($$,":");}
+ ;
+ident : TOK_NAME {
+ if ( couldaddvariable == 1 && afterpercent == 0)
+ {
+ if ( Vartonumber($1) == 1 )
+ {
+ Add_SubroutineWhereAgrifUsed_1(subroutinename,
+ curmodulename);
+ }
+ if (!strcasecmp($1,"Agrif_Parent") )
+ agrif_parentcall =1;
+ if ( VariableIsNotFunction($1) == 0 )
+ {
+ printf("var = %s\n",$1);
+ if ( inagrifcallargument == 1 )
+ {
+ if ( !strcasecmp($1,identcopy) )
+ {
+ strcpy(sameagrifname,identcopy);
+ sameagrifargument = 1;
+ }
+ }
+ strcpy(identcopy,$1);
+ pointedvar=0;
+ strcpy(truename,$1);
+ if (variscoupled_0($1)) strcpy(truename,getcoupledname_0($1));
+
+ if ( VarIsNonGridDepend(truename) == 0 &&
+ Variableshouldberemove(truename) == 0 )
+ {
+ if ( inagrifcallargument == 1 ||
+ varispointer_0(truename) == 1 )
+ {
+ printf("var2 = %s\n",$1);
+ if ((IsinListe(List_UsedInSubroutine_Var,$1) == 1) || (inagrifcallargument == 1))
+ {
+ if (varistyped_0(truename) == 0)
+ {
+ ModifyTheVariableName_0(truename,strlen($1));
+ }
+ }
+ }
+ printf("ici3\n");
+ if ( inagrifcallargument != 1 ||
+ sameagrifargument ==1 )
+ {
+ printf("ici5 %s\n",truename);
+ Add_UsedInSubroutine_Var_1(truename);
+ }
+ }
+ NotifyAgrifFunction_0(truename);
+ }
+ }
+ else
+ {
+ afterpercent = 0;
+ }
+ }
+ ;
+simple_const : TOK_TRUE
+ {if ( couldaddvariable == 1 ) strcpy($$,".TRUE.");}
+ | TOK_FALSE {if ( couldaddvariable == 1 ) strcpy($$,".FALSE.");}
+ | TOK_CSTINT {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ | TOK_CSTREAL {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ | TOK_CSTREALDP{if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ | TOK_CSTREALQP{if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ | simple_const TOK_NAME
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s%s",$1,$2);}
+ | string_constant opt_substring
+ ;
+string_constant : TOK_CHAR_CONSTANT
+ {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ | string_constant TOK_CHAR_CONSTANT
+ | TOK_CHAR_MESSAGE
+ {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ | TOK_CHAR_CUT
+ {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ ;
+opt_substring : {if ( couldaddvariable == 1 ) strcpy($$," ");}
+ | substring {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ ;
+substring : '(' optexpr ':' optexpr ')'
+ {if ( couldaddvariable == 1 ) sprintf($$,"(%s :%s)",$2,$4);}
+ ;
+optexpr : {if ( couldaddvariable == 1 ) strcpy($$," ");}
+ | expr {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ ;
+opt_expr : '\n' {if ( couldaddvariable == 1 ) strcpy($$," ");}
+ | expr {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ ;
+initial_value : { strcpy(InitialValueGiven," ");}
+ | before_initial '=' expr
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy(InitValue,$3);
+ strcpy(InitialValueGiven,"=");
+ }
+ }
+ | before_initial TOK_POINT_TO expr
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy(InitValue,$3);
+ strcpy(InitialValueGiven,"=>");
+ }
+ }
+ ;
+before_initial : {pos_curinit = setposcur();}
+ ;
+complex_const : '(' uexpr ',' uexpr ')'
+ {sprintf($$,"(%s,%s)",$2,$4);}
+ ;
+use_stat : word_use module_name
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* if variables has been declared in a subroutine */
+ if (insubroutinedeclare == 1)
+ {
+ copyuse_0($2);
+ }
+ sprintf(charusemodule,"%s",$2);
+ Add_NameOfModuleUsed_1($2);
+
+ if ( inmoduledeclare == 0 )
+ {
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curuse,
+ pos_end-pos_curuse);
+ }
+ }
+ }
+ | word_use module_name ',' rename_list
+ {
+ if ( couldaddvariable == 1 )
+ {
+ if (insubroutinedeclare == 1)
+ {
+ Add_CouplePointed_Var_1($2,$4);
+ }
+ if ( firstpass == 1 )
+ {
+ if ( insubroutinedeclare == 1 )
+ {
+ coupletmp = $4;
+ strcpy(ligne,"");
+ while ( coupletmp )
+ {
+ strcat(ligne,coupletmp->c_namevar);
+ strcat(ligne," => ");
+ strcat(ligne,coupletmp->c_namepointedvar);
+ coupletmp = coupletmp->suiv;
+ if ( coupletmp ) strcat(ligne,",");
+ }
+ sprintf(charusemodule,"%s",$2);
+ }
+ Add_NameOfModuleUsed_1($2);
+ }
+ if ( inmoduledeclare == 0 )
+ {
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curuse,
+ pos_end-pos_curuse);
+ }
+ }
+ }
+ | word_use module_name ',' TOK_ONLY ':' '\n'
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* if variables has been declared in a subroutine */
+ if (insubroutinedeclare == 1)
+ {
+ copyuseonly_0($2);
+ }
+ sprintf(charusemodule,"%s",$2);
+ Add_NameOfModuleUsed_1($2);
+
+ if ( inmoduledeclare == 0 )
+ {
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curuse,
+ pos_end-pos_curuse);
+ }
+ }
+ }
+ | word_use module_name ',' TOK_ONLY ':' only_list
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* if variables has been declared in a subroutine */
+ if (insubroutinedeclare == 1)
+ {
+ Add_CouplePointed_Var_1($2,$6);
+ }
+ if ( firstpass == 1 )
+ {
+ if ( insubroutinedeclare == 1 )
+ {
+ coupletmp = $6;
+ strcpy(ligne,"");
+ while ( coupletmp )
+ {
+ strcat(ligne,coupletmp->c_namevar);
+ if ( strcasecmp(coupletmp->c_namepointedvar,"") )
+ strcat(ligne," => ");
+ strcat(ligne,coupletmp->c_namepointedvar);
+ coupletmp = coupletmp->suiv;
+ if ( coupletmp ) strcat(ligne,",");
+ }
+ sprintf(charusemodule,"%s",$2);
+ }
+ Add_NameOfModuleUsed_1($2);
+ }
+ if ( firstpass == 0 )
+ {
+ if ( inmoduledeclare == 0 )
+ {
+
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curuse,
+ pos_end-pos_curuse);
+ if (oldfortranout)
+ variableisglobalinmodule($6,$2,oldfortranout,pos_curuseold);
+
+ }
+ else
+ {
+
+ /* if we are in the module declare and if the */
+ /* onlylist is a list of global variable */
+ variableisglobalinmodule($6, $2, fortranout,pos_curuse);
+ }
+ }
+ }
+ }
+ ;
+word_use : TOK_USE
+ {
+ pos_curuse = setposcur()-strlen($1);
+ if (firstpass == 0 && oldfortranout) {
+ pos_curuseold = setposcurname(oldfortranout);
+ }
+ }
+ ;
+module_name : TOK_NAME
+ {strcpy($$,$1);}
+ ;
+rename_list : rename_name
+ {
+ if ( couldaddvariable == 1 ) $$ = $1;
+ }
+ | rename_list ',' rename_name
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* insert the variable in the list $1 */
+ $3->suiv = $1;
+ $$ = $3;
+ }
+ }
+ ;
+rename_name : TOK_NAME TOK_POINT_TO TOK_NAME
+ {
+ coupletmp =(listcouple *)malloc(sizeof(listcouple));
+ strcpy(coupletmp->c_namevar,$1);
+ Save_Length($1,21);
+ strcpy(coupletmp->c_namepointedvar,$3);
+ Save_Length($3,22);
+ coupletmp->suiv = NULL;
+ $$ = coupletmp;
+ }
+ ;
+only_list : only_name
+ {
+ if ( couldaddvariable == 1 ) $$ = $1;
+ }
+ | only_list ',' only_name
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* insert the variable in the list $1 */
+ $3->suiv = $1;
+ $$ = $3;
+ }
+ }
+ ;
+only_name : TOK_NAME TOK_POINT_TO TOK_NAME
+ {
+ coupletmp =(listcouple *)malloc(sizeof(listcouple));
+ strcpy(coupletmp->c_namevar,$1);
+ Save_Length($1,21);
+ strcpy(coupletmp->c_namepointedvar,$3);
+ Save_Length($3,22);
+ coupletmp->suiv = NULL;
+ $$ = coupletmp;
+ pointedvar=1;
+ Add_UsedInSubroutine_Var_1($1);
+ }
+ | TOK_NAME {
+ coupletmp =(listcouple *)malloc(sizeof(listcouple));
+ strcpy(coupletmp->c_namevar,$1);
+ Save_Length($1,21);
+ strcpy(coupletmp->c_namepointedvar,"");
+ coupletmp->suiv = NULL;
+ $$ = coupletmp;
+ }
+ ;
+exec : iffable
+ | TOK_ALLOCATE '(' allocation_list opt_stat_spec ')'
+ {
+ Add_SubroutineWhereAgrifUsed_1(subroutinename,
+ curmodulename);
+ inallocate = 0;
+ }
+ | TOK_DEALLOCATE '(' allocate_object_list opt_stat_spec ')'
+ {
+ Add_SubroutineWhereAgrifUsed_1(subroutinename,
+ curmodulename);
+ inallocate = 0;
+ }
+ | TOK_NULLIFY '(' pointer_name_list ')'
+ | word_endunit /* end */
+ {
+ GlobalDeclaration = 0 ;
+ if ( firstpass == 0 &&
+ strcasecmp(subroutinename,"") )
+ {
+ if ( module_declar && insubroutinedeclare == 0 )
+ {
+ fclose(module_declar);
+ }
+ }
+ if ( couldaddvariable == 1 &&
+ strcasecmp(subroutinename,"") )
+ {
+ if ( inmodulemeet == 1 )
+ {
+ /* we are in a module */
+ if ( insubroutinedeclare == 1 )
+ {
+ /* it is like an end subroutine */
+ insubroutinedeclare = 0 ;
+ /* */
+ pos_cur = setposcur();
+ closeandcallsubloopandincludeit_0(1);
+ functiondeclarationisdone = 0;
+ }
+ else
+ {
+ /* it is like an end module */
+ inmoduledeclare = 0 ;
+ inmodulemeet = 0 ;
+ }
+ }
+ else
+ {
+ insubroutinedeclare = 0;
+ /* */
+ pos_cur = setposcur();
+ closeandcallsubloopandincludeit_0(2);
+ functiondeclarationisdone = 0;
+ if ( firstpass == 0 )
+ {
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+ fclose(paramout);
+ }
+ }
+ }
+ strcpy(subroutinename,"");
+ }
+ | word_endprogram opt_name
+ {
+ if ( couldaddvariable == 1 )
+ {
+ insubroutinedeclare = 0;
+ /* */
+ pos_cur = setposcur();
+ closeandcallsubloopandincludeit_0(3);
+ functiondeclarationisdone = 0;
+ if ( firstpass == 0 )
+ {
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+ fclose(paramout);
+ }
+ strcpy(subroutinename,"");
+ }
+ }
+ | word_endsubroutine opt_name
+ {
+ if ( couldaddvariable == 1 &&
+ strcasecmp(subroutinename,"") )
+ {
+ insubroutinedeclare = 0;
+ /* */
+ pos_cur = setposcur();
+
+ closeandcallsubloopandincludeit_0(1);
+ functiondeclarationisdone = 0;
+ if ( firstpass == 0 )
+ {
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+ fclose(paramout);
+ }
+ strcpy(subroutinename,"");
+ }
+ }
+ | word_endfunction opt_name
+ {
+ if ( couldaddvariable == 1 )
+ {
+ insubroutinedeclare = 0;
+ /* */
+ pos_cur = setposcur();
+
+ closeandcallsubloopandincludeit_0(0);
+ functiondeclarationisdone = 0;
+ if ( firstpass == 0 )
+ {
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+ fclose(paramout);
+ }
+ strcpy(subroutinename,"");
+ }
+ }
+ | TOK_ENDMODULE opt_name
+ {
+ if ( couldaddvariable == 1 )
+ {
+ /* if we never meet the contains keyword */
+ Remove_Word_end_module_0(strlen($2));
+ if ( inmoduledeclare == 1 )
+ {
+ if ( aftercontainsdeclare == 0 )
+ {
+ Write_GlobalParameter_Declaration_0();
+ Write_NotGridDepend_Declaration_0();
+ Write_GlobalType_Declaration_0();
+ if ( module_declar_type )
+ {
+ strcpy (ligne, "\n#include \"Module_DeclarType_");
+ strcat (ligne, curmodulename);
+ strcat (ligne, ".h\"\n");
+ tofich(fortranout,ligne,1);
+ }
+ Write_Alloc_Subroutine_For_End_0();
+ }
+ }
+
+ inmoduledeclare = 0 ;
+ inmodulemeet = 0 ;
+
+ Write_Word_end_module_0();
+ strcpy(curmodulename,"");
+ aftercontainsdeclare = 1;
+ if ( firstpass == 0 )
+ {
+ if ( module_declar && insubroutinedeclare == 0)
+ {
+ fclose(module_declar);
+ }
+ if ( module_declar_type && insubroutinedeclare == 0)
+ {
+ fclose(module_declar_type);
+ module_declar_type = 0;
+ }
+ }
+ GlobalDeclaration = 0 ;
+ }
+ }
+ | boucledo
+ | logif iffable
+ | TOK_WHERE '(' expr ')' opt_expr
+ | TOK_ELSEWHERE
+ | TOK_ENDWHERE
+ | logif TOK_THEN
+ | TOK_ELSEIF '(' expr ')' TOK_THEN
+ | TOK_ELSE
+ | TOK_ENDIF opt_name
+ | TOK_CASE caselist ')'
+ | TOK_SELECTCASE '(' expr ')'
+ | TOK_CASEDEFAULT
+ | TOK_ENDSELECT
+ | TOK_CONTAINS
+ {
+ if (inmoduledeclare == 1 )
+ {
+ Remove_Word_Contains_0();
+ Write_GlobalParameter_Declaration_0();
+ Write_GlobalType_Declaration_0();
+ if ( module_declar_type)
+ {
+ strcpy (ligne, "\n#include \"Module_DeclarType_");
+ strcat (ligne, curmodulename);
+ strcat (ligne, ".h\"\n");
+ tofich(fortranout,ligne,1);
+ }
+ Write_NotGridDepend_Declaration_0();
+ Write_Alloc_Subroutine_0();
+ inmoduledeclare = 0 ;
+ aftercontainsdeclare = 1;
+ }
+ else
+ {
+ incontainssubroutine = 1;
+ strcpy(previoussubroutinename,subroutinename);
+ if ( couldaddvariable == 1 )
+ {
+ if ( firstpass == 1 ) List_ContainsSubroutine =
+ Addtolistnom(subroutinename,
+ List_ContainsSubroutine,0);
+ insubroutinedeclare = 0;
+ /* */
+
+ closeandcallsubloop_contains_0();
+ functiondeclarationisdone = 0;
+ if ( firstpass == 0 )
+ {
+ if ( retour77 == 0 ) fprintf(paramout,"!\n");
+ else fprintf(paramout,"C\n");
+ fclose(paramout);
+ }
+ }
+ strcpy(subroutinename,"");
+ }
+ }
+ ;
+word_endsubroutine : TOK_ENDSUBROUTINE
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy($$,$1);
+ pos_endsubroutine = setposcur()-strlen($1);
+ functiondeclarationisdone = 0;
+ }
+ }
+ ;
+word_endunit : TOK_ENDUNIT
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy($$,$1);
+ pos_endsubroutine = setposcur()-strlen($1);
+ }
+ }
+ ;
+word_endprogram : TOK_ENDPROGRAM
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy($$,$1);
+ pos_endsubroutine = setposcur()-strlen($1);
+ }
+ }
+ ;
+word_endfunction : TOK_ENDFUNCTION
+ {
+ if ( couldaddvariable == 1 )
+ {
+ strcpy($$,$1);
+ pos_endsubroutine = setposcur()-strlen($1);
+ }
+ }
+ ;
+caselist : expr
+ | caselist ',' expr
+ | caselist ':' expr
+ ;
+boucledo : worddo opt_int do_arg
+ | wordwhile expr
+ | TOK_ENDDO optname
+ ;
+do_arg :
+ | do_var '=' expr ',' expr
+ | do_var '=' expr ',' expr ',' expr
+opt_int :
+ | TOK_CSTINT opt_comma
+ ;
+opt_name : '\n' {strcpy($$,"");}
+ | TOK_NAME {strcpy($$,$1);}
+ ;
+optname :
+ | TOK_NAME
+ ;
+worddo : TOK_PLAINDO
+ ;
+wordwhile :TOK_DOWHILE
+ ;
+
+dotarget :
+ | TOK_CSTINT
+ ;
+
+iffable : TOK_CONTINUE
+ | ident_dims after_ident_dims
+ | goto
+ | io
+ | call
+ | TOK_ALLOCATE '(' allocation_list opt_stat_spec ')'
+ {
+ Add_SubroutineWhereAgrifUsed_1(subroutinename,
+ curmodulename);
+ inallocate = 0;
+ }
+ | TOK_DEALLOCATE '(' allocate_object_list opt_stat_spec ')'
+ {
+ Add_SubroutineWhereAgrifUsed_1(subroutinename,
+ curmodulename);
+ inallocate = 0;
+ }
+ | TOK_EXIT optexpr
+ | TOK_RETURN opt_expr
+ | TOK_CYCLE opt_expr
+ | stop opt_expr
+ | int_list
+ ;
+before_dims : {if ( couldaddvariable == 1 ) created_dimensionlist = 0;}
+ident_dims : ident before_dims dims dims
+ {
+ created_dimensionlist = 1;
+ if ( agrif_parentcall == 1 )
+ {
+ ModifyTheAgrifFunction_0($3->dim.last);
+ agrif_parentcall =0;
+ fprintf(fortranout," = ");
+ }
+ }
+ | ident_dims '%' ident before_dims dims dims
+ {created_dimensionlist = 1;}
+int_list : TOK_CSTINT
+ | int_list ',' TOK_CSTINT
+ ;
+after_ident_dims : '=' expr
+ | TOK_POINT_TO expr
+ ;
+call : keywordcall opt_call
+ {
+ inagrifcallargument = 0 ;
+ incalldeclare=0;
+ if ( oldfortranout &&
+ !strcasecmp(meetagrifinitgrids,subroutinename) &&
+ firstpass == 0 &&
+ callmpiinit == 1)
+ {
+ /* pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curcall,
+ pos_end-pos_curcall);
+ fprintf(oldfortranout," Call MPI_Init (%s) \n"
+ ,mpiinitvar);*/
+ }
+ if ( oldfortranout &&
+ callagrifinitgrids == 1 &&
+ firstpass == 0 )
+ {
+ pos_end = setposcur();
+ RemoveWordSET_0(fortranout,pos_curcall,
+ pos_end-pos_curcall);
+
+ strcpy(subofagrifinitgrids,subroutinename);
+ }
+ Instanciation_0(sameagrifname);
+ }
+ ;
+opt_call :
+ | '(' opt_callarglist ')'
+ ;
+opt_callarglist :
+ | callarglist
+ ;
+keywordcall : before_call TOK_NAME
+ {
+ if (!strcasecmp($2,"MPI_Init") )
+ {
+ callmpiinit = 1;
+ }
+ else
+ {
+ callmpiinit = 0;
+ }
+ if (!strcasecmp($2,"Agrif_Init_Grids") )
+ {
+ callagrifinitgrids = 1;
+ strcpy(meetagrifinitgrids,subroutinename);
+ }
+ else callagrifinitgrids = 0;
+ if ( !strcasecmp($2,"Agrif_Open_File") )
+ {
+ Add_SubroutineWhereAgrifUsed_1(subroutinename,
+ curmodulename);
+ }
+ if ( Vartonumber($2) == 1 )
+ {
+ incalldeclare=1;
+ inagrifcallargument = 1 ;
+ Add_SubroutineWhereAgrifUsed_1(subroutinename,
+ curmodulename);
+ }
+ }
+ ;
+before_call : TOK_CALL
+ {pos_curcall=setposcur()-4;}
+callarglist : callarg
+ | callarglist ',' callarg
+ ;
+
+callarg : expr {
+ if ( callmpiinit == 1 )
+ {
+ strcpy(mpiinitvar,$1);
+ if ( firstpass == 1 )
+ {
+ Add_UsedInSubroutine_Var_1 (mpiinitvar);
+/* curvar=createvar($1,NULL);
+ curlistvar=insertvar(NULL,curvar);
+ List_Subr outineArgument_Var = AddListvarToListvar
+ (curlistvar,List_SubroutineAr gument_Var,1);*/
+ }
+ }
+ }
+ | '*' label
+ ;
+
+stop : TOK_PAUSE
+ | TOK_STOP
+ ;
+
+io : iofctl ioctl
+ | read option_read
+ | write ioctl
+ | write ioctl outlist
+ | TOK_REWIND after_rewind
+ | TOK_FORMAT
+ ;
+opt_CHAR_INT :
+ | TOK_CSTINT TOK_NAME
+ ;
+idfile : '*'
+ | TOK_CSTINT
+ | ident
+ ;
+option_print :
+ | ',' outlist
+ ;
+option_inlist :
+ | inlist
+ ;
+option_read : ioctl option_inlist
+ | infmt opt_inlist
+ ;
+opt_outlist :
+ | outlist
+ ;
+opt_inlist :
+ | ',' inlist
+ ;
+ioctl : '(' ctllist ')'
+ | '(' fexpr ')'
+ ;
+after_rewind : '(' ident ')'
+ | '(' TOK_CSTINT ')'
+ | TOK_CSTINT
+ | '(' uexpr ')'
+ | TOK_NAME
+ ;
+ctllist : ioclause
+ | ctllist ',' ioclause
+ ;
+ioclause : fexpr
+ | '*'
+ | TOK_DASTER
+ | ident expr dims
+ | ident expr
+ | ident expr '%' ident_dims
+ | ident '(' triplet ')'
+ | ident '*'
+ | ident TOK_DASTER
+ ;
+iofctl : TOK_OPEN
+ | TOK_CLOSE
+ ;
+infmt : unpar_fexpr
+ | '*'
+ ;
+
+read :TOK_READ
+ | TOK_INQUIRE
+ | TOK_PRINT
+ ;
+
+write : TOK_WRITE
+ ;
+
+fexpr : unpar_fexpr
+ | '(' fexpr ')'
+ ;
+unpar_fexpr : lhs
+ | simple_const
+ | fexpr addop fexpr %prec '+'
+ | fexpr '*' fexpr
+ | fexpr TOK_SLASH fexpr
+ | fexpr TOK_DASTER fexpr
+ | addop fexpr %prec '*'
+ | fexpr TOK_DSLASH fexpr
+ | TOK_FILE expr
+ | TOK_EXIST expr
+ | TOK_ERR expr
+ | TOK_END expr
+ | TOK_NAME '=' expr
+ | predefinedfunction
+ ;
+addop : '+'
+ | '-'
+ ;
+inlist : inelt
+ | inlist ',' inelt
+ ;
+opt_lhs :
+ | lhs
+ ;
+inelt : opt_lhs opt_operation
+ | '(' inlist ')' opt_operation
+ | predefinedfunction opt_operation
+ | simple_const opt_operation
+ | '(' inlist ',' dospec ')'
+ ;
+opt_operation :
+ | operation
+ | opt_operation operation
+ ;
+outlist : uexpr {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ | other {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ | out2 {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ ;
+out2: uexpr ',' expr
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s,%s",$1,$3);}
+ | uexpr ',' other
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s,%s",$1,$3);}
+ | other ',' expr
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s,%s",$1,$3);}
+ | other ',' other
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s,%s",$1,$3);}
+ | out2 ',' expr
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s,%s",$1,$3);}
+ | out2 ',' other
+ {if ( couldaddvariable == 1 ) sprintf($$,"%s,%s",$1,$3);}
+ | uexpr {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ | predefinedfunction {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ ;
+other : complex_const
+ {if ( couldaddvariable == 1 ) strcpy($$,$1);}
+ | '(' expr ')'
+ {if ( couldaddvariable == 1 ) sprintf($$," (%s)",$2);}
+ | '(' uexpr ',' dospec ')'
+ {if ( couldaddvariable == 1 ) sprintf($$,"(%s,%s)",$2,$4);}
+ | '(' other ',' dospec ')'
+ {if ( couldaddvariable == 1 ) sprintf($$,"(%s,%s)",$2,$4);}
+ | '(' out2 ',' dospec ')'
+ {if ( couldaddvariable == 1 ) sprintf($$,"(%s,%s)",$2,$4);}
+ ;
+
+dospec : TOK_NAME '=' expr ',' expr
+ {if ( couldaddvariable == 1 )
+ sprintf($$,"%s=%s,%s)",$1,$3,$5);}
+ | TOK_NAME '=' expr ',' expr ',' expr
+ {if ( couldaddvariable == 1 )
+ sprintf($$,"%s=%s,%s,%s)",$1,$3,$5,$7);}
+ ;
+labellist : label
+ | labellist ',' label
+ ;
+label : TOK_CSTINT
+ ;
+goto : TOK_PLAINGOTO '(' expr ',' expr ')' ',' expr
+ | TOK_PLAINGOTO label
+ ;
+allocation_list : allocate_object
+ | ident_dims
+ | allocation_list ',' allocate_object
+ ;
+allocate_object : ident
+ {Add_Allocate_Var_1($1,curmodulename);}
+ | structure_component
+ | array_element
+ ;
+array_element : ident '(' funargs ')'
+ {Add_Allocate_Var_1($1,curmodulename);}
+ ;
+subscript_list : expr
+ | subscript_list ',' expr
+ ;
+
+allocate_object_list :allocate_object
+ | allocate_object_list ',' allocate_object
+ ;
+opt_stat_spec :
+ | ',' TOK_STAT '=' ident
+ ;
+pointer_name_list : ident
+ | pointer_name_list ',' ident
+ ;
+opt_construct_name :
+ | TOK_NAME
+ ;
+opt_construct_name_colon :
+ | TOK_CONSTRUCTID ':'
+ ;
+logif : TOK_LOGICALIF expr ')'
+ ;
+do_var : ident {strcpy($$,$1);}
+ ;
+%%
+
+void processfortran(char *fichier_entree)
+{
+ extern FILE *fortranin;
+ extern FILE *fortranout;
+ char nomfile[LONG_C];
+ int c;
+ int confirmyes;
+
+/* fortrandebug = 1;*/
+ if ( mark == 1 ) printf("Firstpass == %d \n",firstpass);
+/******************************************************************************/
+/* 1- Open input and output files */
+/******************************************************************************/
+ strcpy(nomfile,commondirin);
+ strcat(nomfile,"/");
+ strcat(nomfile,fichier_entree);
+ fortranin=fopen( nomfile,"r");
+ if (! fortranin)
+ {
+ printf("Error : File %s does not exist\n",nomfile);
+ exit(1);
+ }
+
+ strcpy(curfile,nomfile);
+ strcpy(nomfile,commondirout);
+ strcat(nomfile,"/");
+ strcat(nomfile,fichier_entree);
+ strcpy(nomfileoutput,nomfile);
+ Save_Length(nomfileoutput,31);
+ if (firstpass == 1)
+ {
+ if (checkexistcommon == 1)
+ {
+ if (fopen(nomfile,"r"))
+ {
+ printf("Warning : file %s already exist\n",nomfile);
+ confirmyes = 0;
+ while (confirmyes==0)
+ {
+ printf("Override file %s ? [Y/N]\n",nomfile);
+ c=getchar();
+ getchar();
+ if (c==79 || c==110)
+ {
+ printf("We stop\n");
+ exit(1);
+ }
+ if (c==89 || c==121)
+ {
+ confirmyes=1;
+ }
+ }
+ }
+ }
+ }
+
+/******************************************************************************/
+/* 2- Variables initialization */
+/******************************************************************************/
+
+ line_num_fortran_common=1;
+ line_num_fortran=1;
+ PublicDeclare = 0;
+ PrivateDeclare = 0;
+ ExternalDeclare = 0;
+ SaveDeclare = 0;
+ pointerdeclare = 0;
+ optionaldeclare = 0;
+ incalldeclare = 0;
+ VarType = 0;
+ VarTypepar = 0;
+ Allocatabledeclare = 0 ;
+ Targetdeclare = 0 ;
+ strcpy(NamePrecision," ");
+ VariableIsParameter = 0 ;
+ strcpy(NamePrecision,"");
+ c_star = 0 ;
+ functiondeclarationisdone = 0;
+ insubroutinedeclare = 0 ;
+ ininterfacedeclare = 0 ;
+ strcpy(subroutinename," ");
+ isrecursive = 0;
+ strcpy(InitialValueGiven," ");
+ strcpy(EmptyChar," ");
+ inmoduledeclare = 0;
+ incontainssubroutine = 0;
+ module_declar_type = 0;
+ GlobalDeclarationType = 0;
+ colnum=0;
+ incom=0;
+ couldaddvariable=1;
+ afterpercent = 0;
+ aftercontainsdeclare = 1;
+ strcpy(nameinttypename,"");
+ /* Name of the file without format */
+ tmp = strchr(fichier_entree, '.');
+ strncpy(curfilename,fichier_entree,strlen(fichier_entree)-strlen(tmp));
+ Save_Length(curfilename,30);
+/******************************************************************************/
+/* 3- Parsing of the input file (1 time) */
+/******************************************************************************/
+ if (firstpass == 0 )
+ {
+ fortranout=fopen(nomfileoutput,"w");
+
+/* NewModule_Creation_0();*/
+ }
+
+ fortranparse();
+
+ if (firstpass == 0 )
+ {
+ NewModule_Creation_0();
+ }
+
+ strcpy(curfile,mainfile);
+
+ if (firstpass == 0 )
+ {
+ fclose(fortranout);
+ }
+}
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/fortran.yy.c
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/fortran.yy.c (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/EXTERNAL/AGRIF/LIB/fortran.yy.c (revision 8155)
@@ -0,0 +1,5248 @@
+#line 2 "fortran.yy.c"
+
+#line 4 "fortran.yy.c"
+
+#define YY_INT_ALIGNED short int
+
+/* A lexical scanner generated by flex */
+
+#define yy_create_buffer fortran_create_buffer
+#define yy_delete_buffer fortran_delete_buffer
+#define yy_flex_debug fortran_flex_debug
+#define yy_init_buffer fortran_init_buffer
+#define yy_flush_buffer fortran_flush_buffer
+#define yy_load_buffer_state fortran_load_buffer_state
+#define yy_switch_to_buffer fortran_switch_to_buffer
+#define yyin fortranin
+#define yyleng fortranleng
+#define yylex fortranlex
+#define yylineno fortranlineno
+#define yyout fortranout
+#define yyrestart fortranrestart
+#define yytext fortrantext
+#define yywrap fortranwrap
+#define yyalloc fortranalloc
+#define yyrealloc fortranrealloc
+#define yyfree fortranfree
+
+#define FLEX_SCANNER
+#define YY_FLEX_MAJOR_VERSION 2
+#define YY_FLEX_MINOR_VERSION 5
+#define YY_FLEX_SUBMINOR_VERSION 35
+#if YY_FLEX_SUBMINOR_VERSION > 0
+#define FLEX_BETA
+#endif
+
+/* First, we deal with platform-specific or compiler-specific issues. */
+
+/* begin standard C headers. */
+#include
+#include
+#include
+#include
+
+/* end standard C headers. */
+
+/* flex integer type definitions */
+
+#ifndef FLEXINT_H
+#define FLEXINT_H
+
+/* C99 systems have . Non-C99 systems may or may not. */
+
+#if defined (__STDC_VERSION__) && __STDC_VERSION__ >= 199901L
+
+/* C99 says to define __STDC_LIMIT_MACROS before including stdint.h,
+ * if you want the limit (max/min) macros for int types.
+ */
+#ifndef __STDC_LIMIT_MACROS
+#define __STDC_LIMIT_MACROS 1
+#endif
+
+#include
+typedef int8_t flex_int8_t;
+typedef uint8_t flex_uint8_t;
+typedef int16_t flex_int16_t;
+typedef uint16_t flex_uint16_t;
+typedef int32_t flex_int32_t;
+typedef uint32_t flex_uint32_t;
+#else
+typedef signed char flex_int8_t;
+typedef short int flex_int16_t;
+typedef int flex_int32_t;
+typedef unsigned char flex_uint8_t;
+typedef unsigned short int flex_uint16_t;
+typedef unsigned int flex_uint32_t;
+#endif /* ! C99 */
+
+/* Limits of integral types. */
+#ifndef INT8_MIN
+#define INT8_MIN (-128)
+#endif
+#ifndef INT16_MIN
+#define INT16_MIN (-32767-1)
+#endif
+#ifndef INT32_MIN
+#define INT32_MIN (-2147483647-1)
+#endif
+#ifndef INT8_MAX
+#define INT8_MAX (127)
+#endif
+#ifndef INT16_MAX
+#define INT16_MAX (32767)
+#endif
+#ifndef INT32_MAX
+#define INT32_MAX (2147483647)
+#endif
+#ifndef UINT8_MAX
+#define UINT8_MAX (255U)
+#endif
+#ifndef UINT16_MAX
+#define UINT16_MAX (65535U)
+#endif
+#ifndef UINT32_MAX
+#define UINT32_MAX (4294967295U)
+#endif
+
+#endif /* ! FLEXINT_H */
+
+#ifdef __cplusplus
+
+/* The "const" storage-class-modifier is valid. */
+#define YY_USE_CONST
+
+#else /* ! __cplusplus */
+
+/* C99 requires __STDC__ to be defined as 1. */
+#if defined (__STDC__)
+
+#define YY_USE_CONST
+
+#endif /* defined (__STDC__) */
+#endif /* ! __cplusplus */
+
+#ifdef YY_USE_CONST
+#define yyconst const
+#else
+#define yyconst
+#endif
+
+/* Returned upon end-of-file. */
+#define YY_NULL 0
+
+/* Promotes a possibly negative, possibly signed char to an unsigned
+ * integer for use as an array index. If the signed char is negative,
+ * we want to instead treat it as an 8-bit unsigned char, hence the
+ * double cast.
+ */
+#define YY_SC_TO_UI(c) ((unsigned int) (unsigned char) c)
+
+/* Enter a start condition. This macro really ought to take a parameter,
+ * but we do it the disgusting crufty way forced on us by the ()-less
+ * definition of BEGIN.
+ */
+#define BEGIN (yy_start) = 1 + 2 *
+
+/* Translate the current start state into a value that can be later handed
+ * to BEGIN to return to the state. The YYSTATE alias is for lex
+ * compatibility.
+ */
+#define YY_START (((yy_start) - 1) / 2)
+#define YYSTATE YY_START
+
+/* Action number for EOF rule of a given start state. */
+#define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1)
+
+/* Special action meaning "start processing a new file". */
+#define YY_NEW_FILE fortranrestart(fortranin )
+
+#define YY_END_OF_BUFFER_CHAR 0
+
+/* Size of default input buffer. */
+#ifndef YY_BUF_SIZE
+#define YY_BUF_SIZE 16384
+#endif
+
+/* The state buf must be large enough to hold one state per character in the main buffer.
+ */
+#define YY_STATE_BUF_SIZE ((YY_BUF_SIZE + 2) * sizeof(yy_state_type))
+
+#ifndef YY_TYPEDEF_YY_BUFFER_STATE
+#define YY_TYPEDEF_YY_BUFFER_STATE
+typedef struct yy_buffer_state *YY_BUFFER_STATE;
+#endif
+
+#ifndef YY_TYPEDEF_YY_SIZE_T
+#define YY_TYPEDEF_YY_SIZE_T
+typedef size_t yy_size_t;
+#endif
+
+extern yy_size_t fortranleng;
+
+extern FILE *fortranin, *fortranout;
+
+#define EOB_ACT_CONTINUE_SCAN 0
+#define EOB_ACT_END_OF_FILE 1
+#define EOB_ACT_LAST_MATCH 2
+
+ #define YY_LESS_LINENO(n)
+
+/* Return all but the first "n" matched characters back to the input stream. */
+#define yyless(n) \
+ do \
+ { \
+ /* Undo effects of setting up fortrantext. */ \
+ int yyless_macro_arg = (n); \
+ YY_LESS_LINENO(yyless_macro_arg);\
+ *yy_cp = (yy_hold_char); \
+ YY_RESTORE_YY_MORE_OFFSET \
+ (yy_c_buf_p) = yy_cp = yy_bp + yyless_macro_arg - YY_MORE_ADJ; \
+ YY_DO_BEFORE_ACTION; /* set up fortrantext again */ \
+ } \
+ while ( 0 )
+
+#define unput(c) yyunput( c, (yytext_ptr) )
+
+#ifndef YY_STRUCT_YY_BUFFER_STATE
+#define YY_STRUCT_YY_BUFFER_STATE
+struct yy_buffer_state
+ {
+ FILE *yy_input_file;
+
+ char *yy_ch_buf; /* input buffer */
+ char *yy_buf_pos; /* current position in input buffer */
+
+ /* Size of input buffer in bytes, not including room for EOB
+ * characters.
+ */
+ yy_size_t yy_buf_size;
+
+ /* Number of characters read into yy_ch_buf, not including EOB
+ * characters.
+ */
+ yy_size_t yy_n_chars;
+
+ /* Whether we "own" the buffer - i.e., we know we created it,
+ * and can realloc() it to grow it, and should free() it to
+ * delete it.
+ */
+ int yy_is_our_buffer;
+
+ /* Whether this is an "interactive" input source; if so, and
+ * if we're using stdio for input, then we want to use getc()
+ * instead of fread(), to make sure we stop fetching input after
+ * each newline.
+ */
+ int yy_is_interactive;
+
+ /* Whether we're considered to be at the beginning of a line.
+ * If so, '^' rules will be active on the next match, otherwise
+ * not.
+ */
+ int yy_at_bol;
+
+ int yy_bs_lineno; /**< The line count. */
+ int yy_bs_column; /**< The column count. */
+
+ /* Whether to try to fill the input buffer when we reach the
+ * end of it.
+ */
+ int yy_fill_buffer;
+
+ int yy_buffer_status;
+
+#define YY_BUFFER_NEW 0
+#define YY_BUFFER_NORMAL 1
+ /* When an EOF's been seen but there's still some text to process
+ * then we mark the buffer as YY_EOF_PENDING, to indicate that we
+ * shouldn't try reading from the input source any more. We might
+ * still have a bunch of tokens to match, though, because of
+ * possible backing-up.
+ *
+ * When we actually see the EOF, we change the status to "new"
+ * (via fortranrestart()), so that the user can continue scanning by
+ * just pointing fortranin at a new input file.
+ */
+#define YY_BUFFER_EOF_PENDING 2
+
+ };
+#endif /* !YY_STRUCT_YY_BUFFER_STATE */
+
+/* Stack of input buffers. */
+static size_t yy_buffer_stack_top = 0; /**< index of top of stack. */
+static size_t yy_buffer_stack_max = 0; /**< capacity of stack. */
+static YY_BUFFER_STATE * yy_buffer_stack = 0; /**< Stack as an array. */
+
+/* We provide macros for accessing buffer states in case in the
+ * future we want to put the buffer states in a more general
+ * "scanner state".
+ *
+ * Returns the top of the stack, or NULL.
+ */
+#define YY_CURRENT_BUFFER ( (yy_buffer_stack) \
+ ? (yy_buffer_stack)[(yy_buffer_stack_top)] \
+ : NULL)
+
+/* Same as previous macro, but useful when we know that the buffer stack is not
+ * NULL or when we need an lvalue. For internal use only.
+ */
+#define YY_CURRENT_BUFFER_LVALUE (yy_buffer_stack)[(yy_buffer_stack_top)]
+
+/* yy_hold_char holds the character lost when fortrantext is formed. */
+static char yy_hold_char;
+static yy_size_t yy_n_chars; /* number of characters read into yy_ch_buf */
+yy_size_t fortranleng;
+
+/* Points to current character in buffer. */
+static char *yy_c_buf_p = (char *) 0;
+static int yy_init = 0; /* whether we need to initialize */
+static int yy_start = 0; /* start state number */
+
+/* Flag which is used to allow fortranwrap()'s to do buffer switches
+ * instead of setting up a fresh fortranin. A bit of a hack ...
+ */
+static int yy_did_buffer_switch_on_eof;
+
+void fortranrestart (FILE *input_file );
+void fortran_switch_to_buffer (YY_BUFFER_STATE new_buffer );
+YY_BUFFER_STATE fortran_create_buffer (FILE *file,int size );
+void fortran_delete_buffer (YY_BUFFER_STATE b );
+void fortran_flush_buffer (YY_BUFFER_STATE b );
+void fortranpush_buffer_state (YY_BUFFER_STATE new_buffer );
+void fortranpop_buffer_state (void );
+
+static void fortranensure_buffer_stack (void );
+static void fortran_load_buffer_state (void );
+static void fortran_init_buffer (YY_BUFFER_STATE b,FILE *file );
+
+#define YY_FLUSH_BUFFER fortran_flush_buffer(YY_CURRENT_BUFFER )
+
+YY_BUFFER_STATE fortran_scan_buffer (char *base,yy_size_t size );
+YY_BUFFER_STATE fortran_scan_string (yyconst char *yy_str );
+YY_BUFFER_STATE fortran_scan_bytes (yyconst char *bytes,yy_size_t len );
+
+void *fortranalloc (yy_size_t );
+void *fortranrealloc (void *,yy_size_t );
+void fortranfree (void * );
+
+#define yy_new_buffer fortran_create_buffer
+
+#define yy_set_interactive(is_interactive) \
+ { \
+ if ( ! YY_CURRENT_BUFFER ){ \
+ fortranensure_buffer_stack (); \
+ YY_CURRENT_BUFFER_LVALUE = \
+ fortran_create_buffer(fortranin,YY_BUF_SIZE ); \
+ } \
+ YY_CURRENT_BUFFER_LVALUE->yy_is_interactive = is_interactive; \
+ }
+
+#define yy_set_bol(at_bol) \
+ { \
+ if ( ! YY_CURRENT_BUFFER ){\
+ fortranensure_buffer_stack (); \
+ YY_CURRENT_BUFFER_LVALUE = \
+ fortran_create_buffer(fortranin,YY_BUF_SIZE ); \
+ } \
+ YY_CURRENT_BUFFER_LVALUE->yy_at_bol = at_bol; \
+ }
+
+#define YY_AT_BOL() (YY_CURRENT_BUFFER_LVALUE->yy_at_bol)
+
+/* Begin user sect3 */
+
+typedef unsigned char YY_CHAR;
+
+FILE *fortranin = (FILE *) 0, *fortranout = (FILE *) 0;
+
+typedef int yy_state_type;
+
+extern int fortranlineno;
+
+int fortranlineno = 1;
+
+extern char *fortrantext;
+#define yytext_ptr fortrantext
+
+static yy_state_type yy_get_previous_state (void );
+static yy_state_type yy_try_NUL_trans (yy_state_type current_state );
+static int yy_get_next_buffer (void );
+static void yy_fatal_error (yyconst char msg[] );
+
+/* Done after the current pattern has been matched and before the
+ * corresponding action - sets up fortrantext.
+ */
+#define YY_DO_BEFORE_ACTION \
+ (yytext_ptr) = yy_bp; \
+ fortranleng = (size_t) (yy_cp - yy_bp); \
+ (yy_hold_char) = *yy_cp; \
+ *yy_cp = '\0'; \
+ (yy_c_buf_p) = yy_cp;
+
+#define YY_NUM_RULES 176
+#define YY_END_OF_BUFFER 177
+/* This struct is not used in this scanner,
+ but its presence is necessary. */
+struct yy_trans_info
+ {
+ flex_int32_t yy_verify;
+ flex_int32_t yy_nxt;
+ };
+static yyconst flex_int16_t yy_accept[1162] =
+ { 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 177, 176, 165, 161, 164, 175, 152, 151,
+ 155, 167, 152, 154, 154, 154, 157, 153, 137, 150,
+ 156, 159, 158, 160, 145, 145, 145, 145, 145, 145,
+ 145, 145, 145, 145, 145, 145, 145, 145, 145, 145,
+ 145, 145, 165, 161, 164, 175, 150, 145, 145, 145,
+ 145, 145, 145, 176, 176, 173, 176, 176, 176, 161,
+ 161, 154, 145, 0, 0, 165, 0, 166, 0, 164,
+ 175, 175, 175, 0, 141, 0, 0, 167, 167, 167,
+ 167, 0, 0, 0, 140, 0, 0, 132, 26, 0,
+
+ 146, 0, 0, 0, 0, 0, 0, 0, 133, 0,
+ 150, 25, 0, 145, 145, 145, 145, 145, 145, 145,
+ 145, 145, 145, 145, 145, 145, 145, 145, 145, 145,
+ 43, 145, 145, 145, 145, 145, 145, 145, 145, 145,
+ 145, 145, 145, 145, 85, 145, 145, 145, 145, 145,
+ 145, 145, 145, 145, 145, 145, 145, 145, 145, 145,
+ 145, 145, 145, 145, 145, 145, 145, 145, 145, 145,
+ 145, 145, 165, 163, 0, 163, 0, 0, 0, 0,
+ 0, 0, 166, 162, 163, 0, 175, 174, 175, 175,
+ 175, 163, 150, 4, 145, 145, 145, 145, 85, 145,
+
+ 145, 0, 173, 0, 0, 0, 0, 0, 0, 0,
+ 169, 26, 0, 0, 4, 0, 145, 145, 145, 145,
+ 145, 145, 0, 0, 0, 175, 175, 0, 0, 167,
+ 167, 0, 0, 0, 0, 139, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 149, 146, 0, 0, 0, 142, 0, 145, 145,
+ 145, 145, 145, 145, 145, 145, 145, 145, 145, 145,
+ 145, 115, 145, 145, 145, 0, 145, 145, 145, 145,
+ 145, 16, 145, 145, 145, 114, 145, 145, 145, 145,
+ 145, 0, 145, 0, 96, 145, 145, 145, 145, 145,
+
+ 121, 145, 145, 126, 145, 145, 145, 145, 145, 145,
+ 145, 89, 145, 145, 145, 145, 145, 145, 145, 145,
+ 145, 145, 145, 145, 145, 145, 118, 145, 145, 145,
+ 145, 145, 122, 145, 145, 145, 145, 145, 165, 163,
+ 0, 166, 0, 0, 0, 0, 0, 0, 0, 0,
+ 163, 0, 163, 175, 175, 175, 150, 4, 4, 4,
+ 4, 145, 145, 145, 145, 145, 145, 145, 0, 0,
+ 0, 0, 170, 0, 0, 169, 0, 0, 4, 4,
+ 4, 4, 142, 0, 145, 145, 0, 145, 145, 145,
+ 145, 0, 0, 0, 175, 175, 0, 0, 167, 167,
+
+ 0, 0, 0, 0, 147, 0, 146, 0, 148, 0,
+ 28, 0, 30, 29, 32, 31, 34, 0, 0, 36,
+ 0, 146, 0, 147, 0, 146, 0, 148, 0, 142,
+ 0, 125, 117, 145, 145, 120, 123, 145, 145, 22,
+ 145, 145, 145, 145, 145, 116, 145, 145, 145, 0,
+ 145, 145, 145, 94, 0, 108, 145, 145, 145, 145,
+ 145, 145, 145, 145, 145, 0, 109, 145, 145, 145,
+ 145, 145, 145, 145, 0, 88, 145, 145, 145, 145,
+ 145, 145, 145, 0, 98, 145, 145, 0, 111, 145,
+ 145, 145, 145, 112, 21, 145, 60, 74, 145, 145,
+
+ 145, 145, 145, 145, 145, 145, 79, 44, 145, 145,
+ 145, 145, 69, 145, 127, 119, 145, 72, 54, 145,
+ 0, 97, 99, 145, 92, 101, 145, 145, 165, 163,
+ 166, 0, 0, 0, 0, 0, 0, 0, 163, 0,
+ 163, 175, 175, 175, 150, 4, 4, 145, 145, 145,
+ 145, 145, 145, 18, 0, 0, 0, 0, 0, 170,
+ 0, 0, 4, 4, 0, 142, 0, 145, 145, 145,
+ 145, 0, 0, 0, 175, 175, 0, 0, 167, 167,
+ 0, 0, 38, 27, 0, 35, 37, 0, 142, 0,
+ 142, 145, 145, 145, 145, 145, 49, 145, 145, 145,
+
+ 124, 145, 145, 0, 145, 145, 145, 0, 145, 145,
+ 0, 0, 0, 0, 0, 0, 0, 0, 42, 145,
+ 95, 145, 145, 145, 145, 145, 145, 145, 145, 76,
+ 76, 76, 76, 145, 0, 107, 113, 145, 145, 88,
+ 145, 145, 90, 145, 145, 145, 145, 145, 145, 145,
+ 145, 145, 145, 145, 145, 145, 145, 52, 145, 77,
+ 145, 145, 145, 0, 145, 145, 145, 145, 145, 102,
+ 145, 145, 55, 81, 165, 163, 166, 0, 0, 0,
+ 0, 0, 0, 163, 0, 163, 175, 175, 175, 150,
+ 4, 3, 0, 104, 145, 145, 86, 145, 145, 70,
+
+ 71, 70, 0, 0, 0, 0, 4, 3, 0, 142,
+ 0, 142, 145, 49, 145, 124, 0, 23, 0, 175,
+ 23, 0, 23, 23, 167, 23, 0, 23, 23, 23,
+ 33, 145, 145, 23, 23, 23, 145, 145, 63, 145,
+ 145, 145, 145, 0, 145, 145, 138, 0, 0, 93,
+ 145, 42, 0, 95, 0, 0, 0, 0, 0, 0,
+ 145, 145, 145, 145, 145, 145, 145, 145, 0, 110,
+ 145, 145, 145, 145, 145, 145, 145, 66, 145, 145,
+ 129, 100, 128, 130, 39, 145, 145, 145, 145, 145,
+ 145, 145, 83, 0, 145, 11, 75, 19, 145, 145,
+
+ 82, 165, 163, 166, 0, 0, 0, 0, 163, 175,
+ 175, 23, 4, 3, 3, 145, 145, 145, 145, 0,
+ 0, 0, 23, 4, 3, 3, 145, 23, 23, 23,
+ 24, 0, 168, 24, 24, 24, 24, 24, 24, 24,
+ 24, 24, 24, 145, 145, 145, 58, 145, 145, 145,
+ 0, 0, 145, 145, 40, 93, 0, 145, 0, 0,
+ 0, 0, 0, 0, 0, 145, 145, 145, 145, 145,
+ 73, 145, 145, 145, 0, 0, 145, 145, 17, 50,
+ 45, 145, 46, 0, 145, 145, 9, 145, 145, 67,
+ 84, 7, 0, 0, 145, 0, 145, 145, 0, 0,
+
+ 0, 0, 175, 24, 4, 145, 145, 64, 145, 0,
+ 0, 24, 4, 24, 24, 24, 145, 8, 145, 145,
+ 87, 145, 145, 40, 0, 0, 145, 145, 0, 145,
+ 0, 0, 0, 0, 0, 73, 0, 145, 145, 145,
+ 145, 145, 56, 145, 65, 0, 0, 0, 0, 134,
+ 12, 20, 145, 0, 145, 80, 68, 145, 0, 145,
+ 0, 145, 145, 0, 0, 0, 175, 4, 145, 59,
+ 145, 0, 0, 4, 145, 131, 47, 145, 51, 0,
+ 0, 145, 145, 0, 57, 0, 0, 0, 0, 0,
+ 56, 145, 41, 145, 106, 145, 145, 0, 0, 0,
+
+ 0, 0, 134, 91, 0, 145, 61, 0, 62, 0,
+ 145, 145, 0, 59, 0, 175, 4, 4, 145, 143,
+ 0, 0, 4, 4, 145, 10, 0, 0, 145, 145,
+ 57, 0, 41, 0, 106, 0, 145, 14, 145, 145,
+ 0, 0, 0, 145, 0, 0, 103, 6, 0, 143,
+ 175, 4, 4, 145, 0, 0, 4, 4, 48, 0,
+ 0, 145, 145, 0, 14, 0, 15, 145, 53, 0,
+ 0, 0, 145, 0, 103, 0, 175, 4, 2, 105,
+ 0, 0, 4, 2, 0, 0, 145, 145, 15, 0,
+ 145, 0, 0, 0, 145, 0, 105, 175, 4, 0,
+
+ 0, 4, 0, 0, 136, 145, 0, 13, 0, 0,
+ 0, 145, 0, 175, 1, 0, 0, 144, 1, 136,
+ 0, 145, 13, 0, 0, 0, 0, 145, 0, 175,
+ 0, 0, 135, 0, 0, 0, 78, 5, 175, 0,
+ 135, 78, 175, 0, 175, 0, 175, 0, 175, 0,
+ 175, 0, 175, 171, 0, 0, 0, 0, 0, 172,
+ 0
+ } ;
+
+static yyconst flex_int32_t yy_ec[256] =
+ { 0,
+ 1, 1, 1, 1, 1, 1, 1, 1, 2, 3,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 4, 5, 6, 7, 8, 9, 10, 11, 12,
+ 13, 14, 15, 16, 17, 18, 19, 20, 21, 22,
+ 23, 24, 25, 26, 27, 28, 29, 30, 31, 32,
+ 33, 34, 1, 1, 35, 36, 37, 38, 39, 40,
+ 41, 42, 43, 44, 45, 46, 47, 48, 49, 50,
+ 51, 52, 53, 54, 55, 56, 57, 58, 59, 60,
+ 61, 1, 62, 1, 63, 1, 64, 65, 66, 67,
+
+ 68, 69, 70, 71, 72, 44, 73, 74, 75, 76,
+ 77, 78, 79, 80, 81, 82, 83, 84, 85, 86,
+ 87, 88, 89, 89, 89, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1
+ } ;
+
+static yyconst flex_int32_t yy_meta[90] =
+ { 0,
+ 1, 2, 3, 2, 1, 4, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 5, 1, 6,
+ 6, 6, 6, 6, 6, 6, 6, 6, 6, 1,
+ 1, 1, 1, 1, 7, 8, 8, 9, 9, 5,
+ 10, 11, 8, 8, 8, 10, 10, 10, 7, 8,
+ 9, 10, 10, 5, 10, 8, 12, 8, 8, 8,
+ 1, 1, 8, 7, 8, 8, 9, 9, 5, 10,
+ 11, 8, 8, 10, 10, 10, 7, 8, 9, 10,
+ 10, 5, 10, 8, 12, 8, 8, 8, 4
+ } ;
+
+static yyconst flex_int16_t yy_base[1215] =
+ { 0,
+ 0, 88, 0, 0, 0, 0, 1215, 93, 1196, 91,
+ 0, 0, 1179, 64, 97, 117, 132, 87, 124, 98,
+ 99, 142, 173, 154, 108, 135, 134, 254, 172, 179,
+ 175, 178, 219, 180, 323, 388, 384, 318, 386, 319,
+ 186, 128, 250, 256, 392, 404, 438, 428, 204, 455,
+ 432, 465, 544, 120, 537, 548, 627, 624, 622, 544,
+ 644, 658, 251, 9159, 1175, 9159, 267, 99, 162, 569,
+ 572, 620, 745, 164, 107, 262, 307, 335, 376, 522,
+ 0, 167, 157, 1162, 9159, 278, 321, 1160, 1118, 372,
+ 304, 532, 593, 567, 9159, 633, 832, 9159, 9159, 911,
+
+ 798, 318, 319, 450, 799, 552, 320, 354, 9159, 978,
+ 834, 9159, 865, 860, 862, 866, 914, 863, 973, 980,
+ 974, 1013, 1024, 1045, 869, 1049, 1075, 1095, 1098, 1101,
+ 1182, 1177, 1161, 1181, 1214, 1212, 1237, 1239, 1235, 1270,
+ 1290, 1316, 1325, 1293, 1346, 1323, 1366, 1368, 1391, 1399,
+ 1403, 1429, 1430, 1455, 1452, 1478, 1498, 1482, 1523, 1521,
+ 1554, 1548, 1579, 1586, 1606, 1629, 1649, 1675, 1681, 1698,
+ 1707, 1729, 871, 1114, 1109, 140, 1023, 187, 372, 403,
+ 553, 401, 1095, 565, 1792, 1818, 1083, 9159, 643, 669,
+ 589, 1844, 1870, 1580, 1865, 1867, 1868, 1905, 1926, 1922,
+
+ 1925, 1078, 9159, 837, 437, 677, 249, 660, 1072, 712,
+ 9159, 1062, 844, 625, 1874, 1993, 2022, 1042, 864, 473,
+ 904, 621, 506, 651, 721, 798, 791, 890, 912, 936,
+ 907, 725, 1029, 1143, 729, 9159, 1114, 1179, 2097, 2112,
+ 2127, 229, 937, 1033, 1012, 1006, 994, 943, 883, 974,
+ 891, 9159, 1476, 2142, 2157, 2172, 2182, 2202, 2178, 2180,
+ 2200, 2203, 2223, 2243, 2246, 2244, 2276, 2269, 2299, 2307,
+ 2301, 2324, 2344, 2351, 2377, 901, 1018, 2374, 2394, 2397,
+ 2414, 2495, 2434, 2440, 2465, 2472, 2518, 2521, 2515, 2548,
+ 2556, 1138, 2564, 968, 9159, 2581, 2597, 2604, 2627, 2649,
+
+ 2650, 2690, 2693, 2686, 2726, 2738, 2746, 2747, 2763, 2783,
+ 2799, 2800, 2803, 2820, 2840, 2843, 2870, 2891, 2895, 2903,
+ 2926, 2928, 2935, 2961, 2981, 2958, 2984, 2978, 3004, 3011,
+ 3027, 3052, 3048, 3059, 3085, 3068, 3105, 3111, 196, 203,
+ 976, 383, 974, 988, 1018, 1014, 1025, 1029, 1042, 253,
+ 3174, 3200, 3226, 1067, 1182, 1172, 3252, 0, 418, 288,
+ 1096, 3228, 3229, 3231, 3251, 3267, 3287, 3290, 1188, 1566,
+ 973, 740, 9159, 938, 866, 9159, 1268, 1178, 931, 1170,
+ 1241, 1299, 3354, 3381, 0, 903, 3408, 1148, 1116, 1177,
+ 1322, 1145, 410, 1415, 1235, 460, 1292, 1218, 1323, 1022,
+
+ 963, 1520, 1662, 3418, 3430, 3440, 3450, 3460, 3470, 889,
+ 9159, 865, 9159, 9159, 9159, 9159, 9159, 1239, 853, 9159,
+ 846, 2472, 3480, 3490, 3500, 3510, 3520, 3530, 3545, 3555,
+ 3575, 9159, 3289, 3553, 3573, 3551, 3574, 3590, 3596, 3612,
+ 3628, 3634, 3635, 3655, 3671, 3651, 3687, 3688, 3696, 459,
+ 3728, 3736, 3740, 3784, 3868, 9159, 3780, 3776, 3807, 3811,
+ 3850, 3912, 3872, 3920, 3921, 1351, 9159, 3828, 4005, 4060,
+ 4095, 3904, 4063, 4069, 1258, 4096, 4104, 4126, 4134, 4156,
+ 4165, 4196, 4205, 1409, 9159, 4208, 4197, 1476, 9159, 4235,
+ 4241, 4257, 4261, 4273, 4284, 4293, 4305, 4309, 4332, 4336,
+
+ 4353, 4316, 4359, 4362, 4384, 4407, 4385, 4416, 4423, 4448,
+ 4455, 4456, 4486, 4494, 4488, 4511, 4527, 4519, 4531, 4554,
+ 1498, 9159, 4552, 4575, 4584, 4587, 4607, 4610, 493, 529,
+ 551, 476, 1287, 816, 953, 1119, 1293, 841, 4678, 4704,
+ 4730, 1607, 1346, 1458, 4756, 1362, 1397, 4733, 4732, 4759,
+ 4627, 4768, 4817, 733, 1619, 1594, 1406, 728, 1537, 9159,
+ 1571, 1651, 1625, 1613, 4839, 4867, 4894, 1627, 1658, 1686,
+ 1714, 1394, 0, 1756, 1574, 0, 1668, 724, 1709, 724,
+ 1763, 1775, 9159, 9159, 708, 9159, 9159, 4904, 4916, 4926,
+ 4936, 4771, 4931, 5013, 4934, 5068, 5069, 5071, 5075, 5072,
+
+ 5120, 5121, 5123, 1725, 5127, 5153, 5176, 1832, 5175, 5179,
+ 1458, 1493, 1739, 1516, 1519, 1873, 1592, 1739, 5201, 5224,
+ 5202, 5241, 5240, 5257, 5278, 5280, 5301, 5284, 5352, 9159,
+ 5351, 5346, 5349, 5353, 1802, 9159, 5355, 5385, 5401, 9159,
+ 5405, 5408, 5412, 5428, 5449, 5451, 5458, 5460, 5495, 5501,
+ 5531, 5527, 5539, 5571, 5564, 5575, 5591, 5602, 5623, 5614,
+ 5634, 5635, 5660, 693, 5666, 5667, 5692, 5703, 5715, 9159,
+ 5723, 5719, 5740, 5746, 846, 1103, 1234, 1788, 1768, 1386,
+ 1788, 1615, 1847, 1854, 236, 590, 1781, 1913, 715, 5809,
+ 1790, 1645, 2264, 9159, 5785, 5805, 1690, 5806, 5807, 2344,
+
+ 9159, 1951, 1858, 1924, 2256, 679, 1930, 1879, 5870, 5880,
+ 5907, 5917, 1811, 658, 5946, 624, 0, 9159, 6034, 0,
+ 0, 613, 609, 9159, 604, 586, 2245, 2364, 2389, 9159,
+ 9159, 6063, 6118, 6139, 6138, 6134, 6135, 6141, 6161, 6173,
+ 6184, 6209, 6217, 1654, 6260, 6248, 6216, 1844, 1864, 6239,
+ 6280, 9159, 1689, 9159, 1930, 1750, 1763, 1934, 1933, 2077,
+ 6300, 6292, 6317, 6337, 6338, 6344, 6369, 6376, 2212, 9159,
+ 6360, 6413, 6392, 6412, 6424, 6433, 6456, 6435, 6465, 6476,
+ 6488, 6497, 6508, 6509, 6552, 6529, 6540, 6549, 6560, 6585,
+ 6593, 6605, 6628, 2392, 6636, 6637, 6648, 6659, 6694, 6685,
+
+ 6686, 6775, 2286, 518, 2092, 2103, 1938, 2148, 2420, 2303,
+ 472, 442, 2196, 0, 1803, 6692, 6717, 6768, 6756, 2424,
+ 2334, 426, 422, 2432, 378, 1883, 6858, 6945, 6974, 337,
+ 9159, 1922, 9159, 0, 328, 9159, 314, 2481, 2510, 9159,
+ 6929, 6757, 7029, 7031, 7037, 7040, 7033, 7077, 7070, 7086,
+ 2264, 2842, 7093, 7097, 7118, 9159, 2372, 7129, 2384, 2060,
+ 2411, 2418, 2078, 2421, 2139, 7138, 7149, 7170, 7179, 7195,
+ 7201, 7227, 7234, 7236, 2483, 3160, 7259, 7257, 7279, 7280,
+ 7282, 7302, 7318, 2564, 7325, 7319, 7345, 7356, 7377, 7357,
+ 7368, 7388, 2513, 2467, 7400, 2603, 7389, 7425, 2468, 2371,
+
+ 2235, 2479, 361, 296, 182, 7409, 7432, 2249, 7455, 622,
+ 2529, 227, 1008, 7505, 0, 207, 7482, 7503, 7505, 7514,
+ 7535, 7536, 7544, 9159, 2413, 2526, 7567, 7571, 2546, 7593,
+ 2547, 2562, 2567, 2526, 2575, 9159, 2526, 7587, 7625, 7594,
+ 7631, 7632, 7648, 7657, 7668, 3179, 3203, 2672, 3229, 3335,
+ 7684, 7688, 7709, 2597, 7705, 7725, 7732, 7736, 178, 7758,
+ 2596, 7775, 7769, 2619, 2617, 2641, 2696, 2668, 7795, 7801,
+ 7807, 2677, 2720, 3150, 7827, 7818, 7834, 7867, 7850, 2625,
+ 2685, 7870, 7890, 2688, 7859, 2699, 2731, 2741, 2661, 2665,
+ 9159, 7911, 7907, 7910, 7927, 7933, 7963, 2822, 3360, 3384,
+
+ 3411, 4103, 4220, 7959, 2702, 7970, 7966, 2741, 7986, 2738,
+ 8003, 8019, 2758, 9159, 2765, 2781, 2809, 2818, 8030, 8026,
+ 2900, 2883, 2903, 2951, 8042, 8051, 2820, 2829, 8063, 8086,
+ 9159, 2838, 9159, 2846, 9159, 2846, 8088, 8090, 8113, 8134,
+ 3067, 4430, 2880, 8136, 175, 2911, 8125, 8156, 2877, 9159,
+ 1190, 2938, 2908, 8157, 3034, 3081, 3049, 3028, 8173, 2959,
+ 2985, 8189, 8182, 3029, 9159, 3039, 8205, 8212, 8214, 3241,
+ 4684, 3056, 8235, 3049, 9159, 3056, 3212, 3072, 0, 8237,
+ 1210, 3169, 3157, 144, 3103, 3103, 8257, 8260, 9159, 3110,
+ 8283, 3255, 4708, 3110, 8290, 123, 9159, 3235, 3207, 3329,
+
+ 3387, 3558, 3232, 3256, 8306, 8313, 3278, 8315, 8396, 4870,
+ 3259, 8391, 3280, 3664, 0, 3349, 3414, 9159, 103, 9159,
+ 3346, 8392, 9159, 3745, 4900, 8473, 3347, 8450, 90, 1237,
+ 1328, 3570, 8470, 4973, 4977, 3380, 8471, 9159, 3676, 3645,
+ 9159, 9159, 3693, 3608, 3764, 3684, 3616, 1433, 3705, 3782,
+ 3810, 3774, 3875, 9159, 3852, 3697, 3910, 3892, 3896, 9159,
+ 9159, 8553, 8565, 8577, 8589, 8601, 8613, 8621, 8623, 8635,
+ 8647, 8659, 8671, 8678, 8687, 8699, 8711, 8723, 8735, 8747,
+ 8754, 8762, 8774, 8786, 8798, 8810, 8822, 8834, 8846, 8858,
+ 8870, 8882, 8894, 8906, 8918, 8930, 8942, 8954, 8966, 8978,
+
+ 8990, 9002, 9014, 9026, 9038, 9050, 9062, 9074, 9086, 9098,
+ 9110, 9122, 9134, 9146
+ } ;
+
+static yyconst flex_int16_t yy_def[1215] =
+ { 0,
+ 1161, 1, 1162, 1162, 1, 2, 1163, 1163, 1, 2,
+ 1, 2, 1161, 1161, 1161, 1161, 1161, 1164, 1165, 1161,
+ 1161, 1166, 1167, 1161, 1161, 1161, 1161, 1161, 1161, 1168,
+ 1161, 1161, 1161, 1161, 1169, 1169, 36, 36, 36, 36,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 1161, 1161, 53, 1170, 1161, 36, 36, 36,
+ 36, 36, 36, 1161, 1171, 1161, 1171, 1171, 1171, 1161,
+ 1161, 1172, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1164, 1164, 1164, 1165, 1161, 1165, 1165, 1166, 1161, 1166,
+ 1166, 1167, 1173, 1167, 1161, 1167, 1167, 1161, 1161, 1161,
+
+ 1174, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1175,
+ 1161, 1161, 1161, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 1169, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 53, 173, 1176, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 173, 1161, 173, 1161, 1170, 1161, 1170, 1170,
+ 1170, 1161, 1161, 1177, 36, 36, 36, 36, 36, 36,
+
+ 36, 1171, 1161, 1171, 1171, 1171, 1171, 1178, 1179, 1179,
+ 1161, 1179, 1179, 1179, 1180, 1179, 1161, 217, 217, 217,
+ 217, 217, 1161, 1161, 1161, 1164, 1164, 1165, 1165, 1166,
+ 1166, 1173, 1173, 1173, 1173, 1161, 1167, 1167, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1181, 1161, 1161, 1161, 1161, 1161, 36, 36,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 36, 36, 36, 1182, 131, 36, 36, 36,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 1161, 36, 1161, 1161, 36, 36, 36, 36, 36,
+
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 36, 36, 36, 36, 36, 36, 173, 173,
+ 1161, 173, 1176, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 185, 1161, 1161, 1170, 1170, 1170, 1161, 1177, 1177, 1177,
+ 1177, 36, 36, 36, 36, 36, 36, 36, 1171, 1171,
+ 1183, 1183, 1161, 1179, 1179, 1161, 1179, 1179, 1180, 1180,
+ 1180, 1180, 1179, 1179, 217, 217, 1179, 217, 217, 217,
+ 217, 1161, 1161, 1161, 1164, 1164, 1165, 1165, 1166, 1166,
+
+ 1173, 1167, 1167, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1181, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 1161,
+ 36, 36, 36, 36, 1161, 1161, 36, 36, 36, 36,
+ 36, 36, 36, 36, 36, 1161, 1161, 36, 1161, 36,
+ 36, 36, 36, 36, 1161, 36, 36, 36, 36, 36,
+ 36, 36, 36, 1161, 1161, 36, 36, 1161, 1161, 36,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 1161, 1161, 36, 36, 36, 36, 36, 36, 173, 173,
+ 173, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 185, 1161,
+ 1161, 1170, 1170, 1170, 1161, 1177, 1177, 36, 36, 36,
+ 36, 36, 36, 1161, 1171, 1171, 1171, 1183, 1183, 1161,
+ 1179, 1179, 1180, 1180, 1179, 1179, 1179, 217, 217, 217,
+ 217, 1161, 1184, 1161, 1164, 1185, 1165, 1186, 1187, 1188,
+ 1189, 1190, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 36, 36, 1161, 36, 36, 36, 36, 36, 36,
+
+ 36, 36, 36, 1161, 36, 36, 36, 1161, 36, 36,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 36, 36,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 1161,
+ 1161, 36, 36, 36, 1161, 1161, 36, 36, 36, 1161,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 36, 1161, 36, 36, 36, 36, 36, 1161,
+ 36, 36, 36, 36, 173, 173, 173, 1161, 1161, 1161,
+ 1161, 1161, 1161, 173, 1161, 1161, 1170, 1170, 1191, 1161,
+ 1177, 1192, 1161, 1161, 36, 36, 1161, 36, 36, 1161,
+
+ 1161, 1161, 1171, 1171, 1179, 1193, 1180, 1194, 1179, 1179,
+ 1179, 1179, 217, 217, 1161, 217, 1195, 1161, 1161, 1196,
+ 1197, 1198, 1199, 1161, 1200, 1201, 1202, 1203, 1203, 1161,
+ 1161, 1161, 36, 1161, 36, 36, 36, 36, 36, 36,
+ 36, 36, 36, 1161, 36, 36, 36, 1161, 1161, 36,
+ 36, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 36, 36, 36, 36, 36, 36, 36, 36, 1161, 1161,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 36, 1161, 36, 36, 36, 36, 36, 36,
+
+ 36, 1161, 802, 802, 1161, 1161, 1161, 1161, 802, 1204,
+ 1205, 1204, 1206, 1207, 1207, 36, 36, 36, 36, 1208,
+ 1208, 1209, 1210, 1211, 1212, 1212, 1161, 1210, 1161, 829,
+ 1161, 1161, 1161, 1197, 1199, 1161, 1201, 1203, 1203, 1161,
+ 1161, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 1161, 1161, 36, 36, 36, 1161, 1161, 36, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 36, 36, 36, 36, 36,
+ 36, 36, 36, 36, 1161, 1213, 36, 36, 36, 36,
+ 36, 36, 36, 1161, 36, 36, 36, 36, 36, 36,
+ 36, 36, 1161, 1161, 36, 1161, 36, 36, 1161, 1161,
+
+ 1161, 1161, 1204, 1204, 1206, 36, 36, 1161, 36, 1208,
+ 1208, 1210, 1211, 1210, 829, 829, 36, 36, 36, 36,
+ 36, 36, 36, 1161, 1161, 1161, 36, 36, 1161, 36,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 36, 36, 36,
+ 36, 36, 36, 36, 36, 1213, 1213, 1161, 1214, 1213,
+ 36, 36, 36, 1161, 36, 36, 36, 36, 1161, 36,
+ 1161, 36, 36, 1161, 1161, 1161, 1204, 1206, 36, 36,
+ 36, 1208, 1208, 1211, 36, 36, 36, 36, 36, 1161,
+ 1161, 36, 36, 1161, 36, 1161, 1161, 1161, 1161, 1161,
+ 1161, 36, 36, 36, 36, 36, 36, 1161, 1214, 1214,
+
+ 1213, 1214, 1214, 36, 1161, 36, 36, 1161, 36, 1161,
+ 36, 36, 1161, 1161, 1161, 1204, 1206, 1206, 36, 36,
+ 1208, 1208, 1211, 1211, 36, 36, 1161, 1161, 36, 36,
+ 1161, 1161, 1161, 1161, 1161, 1161, 36, 36, 36, 36,
+ 1161, 1213, 1161, 36, 1161, 1161, 36, 36, 1161, 1161,
+ 1204, 1206, 1206, 36, 1208, 1208, 1211, 1211, 36, 1161,
+ 1161, 36, 36, 1161, 1161, 1161, 36, 36, 36, 1161,
+ 1213, 1161, 36, 1161, 1161, 1161, 1204, 1206, 1206, 36,
+ 1208, 1208, 1211, 1211, 1161, 1161, 36, 36, 1161, 1161,
+ 36, 1161, 1213, 1161, 36, 1161, 1161, 1204, 1206, 1208,
+
+ 1208, 1211, 1161, 1161, 36, 36, 1161, 36, 1161, 1213,
+ 1161, 36, 1161, 1204, 1206, 1208, 1208, 1161, 1211, 1161,
+ 1161, 36, 1161, 1161, 1213, 1213, 1161, 36, 1161, 1204,
+ 1208, 1161, 36, 1213, 1214, 1161, 36, 1161, 1204, 1208,
+ 1161, 1161, 1204, 1208, 1204, 1208, 1204, 1208, 1204, 1208,
+ 1204, 1208, 1204, 1161, 1208, 1208, 1208, 1208, 1208, 1161,
+ 0, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161
+ } ;
+
+static yyconst flex_int16_t yy_nxt[9249] =
+ { 0,
+ 14, 15, 16, 17, 18, 19, 14, 20, 21, 22,
+ 23, 24, 25, 26, 25, 27, 25, 28, 29, 30,
+ 30, 30, 30, 30, 30, 30, 30, 30, 30, 25,
+ 31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
+ 41, 42, 43, 42, 42, 44, 45, 46, 47, 48,
+ 42, 49, 50, 51, 42, 42, 52, 42, 42, 42,
+ 25, 25, 42, 35, 36, 37, 38, 39, 40, 41,
+ 42, 43, 42, 44, 45, 46, 47, 48, 42, 49,
+ 50, 51, 42, 42, 52, 42, 42, 42, 14, 53,
+ 54, 55, 56, 71, 67, 66, 67, 68, 76, 77,
+
+ 78, 203, 1138, 74, 72, 211, 206, 57, 57, 57,
+ 57, 57, 57, 57, 57, 57, 57, 75, 79, 77,
+ 79, 79, 77, 79, 58, 59, 82, 73, 60, 85,
+ 61, 69, 74, 78, 77, 80, 74, 74, 74, 1113,
+ 83, 62, 63, 176, 89, 75, 211, 74, 99, 176,
+ 75, 75, 75, 58, 59, 82, 73, 60, 224, 61,
+ 69, 75, 115, 86, 203, 74, 74, 74, 83, 62,
+ 63, 74, 98, 74, 74, 93, 74, 87, 75, 75,
+ 75, 90, 94, 95, 109, 75, 224, 75, 75, 75,
+ 1074, 115, 86, 74, 1008, 91, 110, 529, 223, 530,
+
+ 74, 226, 74, 74, 531, 87, 530, 75, 227, 207,
+ 90, 74, 96, 75, 74, 75, 75, 74, 74, 74,
+ 115, 346, 74, 91, 387, 75, 97, 223, 75, 211,
+ 226, 75, 75, 75, 142, 75, 227, 207, 115, 176,
+ 74, 96, 161, 74, 968, 176, 74, 74, 74, 115,
+ 346, 203, 112, 75, 97, 100, 75, 100, 74, 75,
+ 75, 75, 142, 76, 77, 78, 410, 115, 204, 203,
+ 204, 161, 75, 101, 101, 101, 101, 101, 101, 101,
+ 101, 101, 101, 85, 115, 115, 370, 74, 102, 143,
+ 115, 538, 103, 74, 104, 410, 144, 145, 188, 105,
+
+ 75, 106, 107, 201, 146, 205, 89, 75, 79, 77,
+ 79, 108, 228, 115, 115, 370, 89, 102, 143, 115,
+ 538, 103, 74, 104, 144, 145, 85, 105, 546, 106,
+ 107, 201, 146, 85, 205, 75, 78, 77, 78, 108,
+ 113, 228, 114, 114, 114, 114, 114, 114, 114, 114,
+ 114, 114, 115, 115, 387, 231, 129, 546, 116, 117,
+ 130, 138, 118, 188, 139, 242, 131, 140, 119, 243,
+ 132, 250, 229, 141, 89, 120, 121, 225, 77, 225,
+ 211, 115, 115, 231, 531, 129, 530, 116, 117, 130,
+ 138, 118, 139, 242, 131, 140, 119, 243, 132, 250,
+
+ 229, 141, 251, 120, 121, 113, 230, 114, 114, 114,
+ 114, 114, 114, 114, 114, 114, 114, 347, 124, 359,
+ 115, 359, 122, 967, 211, 125, 147, 118, 211, 126,
+ 251, 133, 127, 134, 148, 230, 135, 136, 150, 203,
+ 149, 123, 128, 137, 188, 347, 151, 124, 573, 115,
+ 348, 122, 152, 350, 125, 147, 118, 126, 153, 133,
+ 127, 134, 157, 148, 135, 136, 168, 150, 149, 123,
+ 128, 137, 115, 169, 188, 151, 158, 573, 348, 159,
+ 152, 350, 160, 170, 207, 154, 153, 155, 244, 162,
+ 387, 157, 156, 163, 675, 168, 676, 164, 576, 115,
+
+ 604, 115, 169, 245, 158, 165, 171, 159, 166, 167,
+ 160, 170, 207, 154, 678, 155, 172, 244, 162, 804,
+ 156, 389, 163, 78, 77, 80, 164, 576, 115, 604,
+ 677, 245, 676, 165, 93, 171, 166, 167, 183, 184,
+ 185, 94, 95, 678, 172, 173, 77, 174, 175, 389,
+ 188, 392, 677, 176, 676, 189, 186, 186, 186, 186,
+ 186, 186, 186, 186, 186, 186, 79, 77, 79, 93,
+ 79, 77, 79, 79, 77, 79, 94, 95, 115, 392,
+ 177, 178, 208, 74, 179, 208, 180, 190, 89, 198,
+ 248, 188, 142, 176, 233, 234, 233, 181, 182, 176,
+
+ 249, 191, 235, 236, 224, 208, 89, 115, 208, 177,
+ 178, 349, 74, 179, 85, 180, 190, 198, 836, 248,
+ 142, 210, 211, 210, 203, 181, 182, 211, 249, 191,
+ 192, 194, 224, 212, 208, 93, 176, 208, 387, 349,
+ 356, 387, 94, 95, 110, 188, 193, 193, 193, 193,
+ 193, 193, 193, 193, 193, 193, 197, 391, 195, 213,
+ 129, 372, 373, 372, 130, 125, 74, 237, 356, 126,
+ 131, 188, 196, 214, 132, 387, 378, 354, 115, 203,
+ 75, 211, 128, 143, 972, 197, 391, 195, 213, 129,
+ 144, 199, 168, 130, 125, 74, 237, 126, 131, 169,
+
+ 196, 214, 132, 355, 378, 393, 354, 115, 75, 170,
+ 128, 369, 143, 375, 376, 375, 200, 188, 144, 199,
+ 794, 168, 394, 77, 394, 731, 89, 234, 169, 724,
+ 373, 234, 355, 393, 401, 236, 554, 170, 401, 236,
+ 369, 559, 560, 559, 200, 209, 210, 211, 210, 209,
+ 209, 209, 215, 209, 209, 209, 209, 209, 209, 209,
+ 209, 209, 216, 209, 217, 217, 217, 217, 217, 217,
+ 217, 217, 217, 217, 209, 209, 209, 209, 209, 195,
+ 218, 218, 218, 218, 219, 218, 125, 218, 218, 218,
+ 220, 218, 218, 196, 218, 218, 218, 218, 221, 218,
+
+ 218, 218, 218, 222, 218, 209, 209, 218, 195, 218,
+ 218, 218, 218, 219, 218, 125, 218, 218, 220, 218,
+ 218, 196, 218, 218, 218, 218, 221, 218, 218, 218,
+ 218, 222, 218, 209, 93, 239, 240, 246, 204, 203,
+ 204, 94, 95, 395, 554, 396, 211, 802, 241, 803,
+ 680, 110, 247, 111, 111, 111, 111, 111, 111, 111,
+ 111, 111, 111, 587, 239, 240, 246, 375, 376, 375,
+ 586, 395, 339, 396, 340, 205, 241, 258, 377, 680,
+ 247, 387, 584, 238, 257, 257, 257, 257, 257, 257,
+ 257, 257, 257, 257, 115, 85, 115, 261, 388, 115,
+
+ 115, 115, 115, 268, 205, 115, 583, 377, 115, 89,
+ 1161, 238, 100, 115, 100, 115, 115, 85, 259, 115,
+ 387, 387, 115, 115, 341, 115, 261, 388, 115, 115,
+ 115, 115, 268, 211, 115, 397, 419, 115, 89, 1161,
+ 211, 115, 421, 115, 115, 102, 259, 115, 115, 103,
+ 115, 104, 341, 115, 411, 390, 105, 450, 106, 107,
+ 417, 400, 260, 397, 419, 234, 398, 115, 108, 294,
+ 421, 294, 401, 236, 102, 373, 188, 115, 103, 295,
+ 104, 399, 115, 390, 105, 450, 106, 107, 681, 400,
+ 260, 420, 412, 418, 398, 115, 108, 253, 253, 253,
+
+ 253, 253, 253, 253, 253, 253, 253, 115, 264, 399,
+ 211, 416, 115, 115, 115, 254, 255, 681, 262, 115,
+ 412, 418, 263, 415, 89, 265, 115, 115, 256, 414,
+ 233, 234, 233, 115, 349, 258, 115, 264, 235, 236,
+ 532, 115, 115, 115, 254, 255, 262, 115, 115, 266,
+ 413, 263, 115, 265, 115, 115, 256, 344, 115, 387,
+ 580, 115, 349, 115, 211, 533, 115, 534, 532, 188,
+ 974, 345, 115, 535, 211, 265, 115, 115, 266, 115,
+ 203, 115, 536, 115, 115, 188, 344, 115, 115, 580,
+ 267, 537, 115, 533, 115, 534, 342, 269, 115, 345,
+
+ 115, 535, 115, 265, 804, 115, 803, 542, 115, 115,
+ 536, 188, 115, 115, 115, 342, 93, 115, 267, 537,
+ 89, 270, 271, 94, 95, 269, 115, 272, 115, 115,
+ 115, 273, 274, 387, 115, 115, 542, 115, 115, 292,
+ 115, 292, 547, 115, 233, 234, 233, 275, 115, 270,
+ 271, 115, 235, 236, 115, 272, 115, 682, 115, 402,
+ 273, 274, 89, 115, 115, 387, 115, 85, 569, 115,
+ 547, 380, 211, 380, 188, 275, 115, 203, 1161, 115,
+ 211, 93, 115, 276, 188, 276, 682, 402, 94, 95,
+ 203, 475, 188, 568, 387, 115, 569, 572, 70, 113,
+
+ 115, 277, 277, 277, 277, 277, 277, 277, 277, 277,
+ 277, 115, 203, 281, 115, 115, 115, 66, 282, 475,
+ 115, 568, 280, 85, 115, 572, 544, 543, 555, 115,
+ 115, 570, 562, 403, 115, 804, 278, 803, 279, 188,
+ 115, 281, 115, 211, 115, 115, 115, 282, 115, 115,
+ 280, 115, 1077, 115, 544, 543, 578, 555, 115, 570,
+ 562, 403, 115, 284, 278, 115, 279, 115, 283, 115,
+ 211, 115, 1100, 115, 115, 115, 115, 115, 115, 285,
+ 115, 563, 115, 289, 288, 578, 286, 575, 115, 1161,
+ 287, 284, 115, 115, 585, 115, 283, 85, 115, 1139,
+
+ 115, 211, 115, 115, 115, 115, 640, 115, 285, 115,
+ 563, 289, 288, 561, 286, 575, 115, 292, 287, 292,
+ 115, 290, 585, 115, 115, 89, 294, 115, 294, 115,
+ 203, 683, 115, 115, 640, 1161, 295, 291, 115, 387,
+ 679, 561, 296, 115, 577, 564, 115, 1161, 188, 290,
+ 115, 115, 466, 115, 466, 115, 115, 115, 115, 261,
+ 683, 115, 115, 301, 115, 291, 1161, 571, 679, 293,
+ 296, 115, 577, 564, 115, 579, 115, 1161, 115, 115,
+ 115, 1161, 297, 467, 115, 115, 115, 697, 261, 697,
+ 1140, 115, 301, 115, 298, 571, 299, 293, 688, 300,
+
+ 115, 1161, 115, 579, 115, 115, 115, 115, 203, 115,
+ 484, 297, 484, 691, 115, 303, 574, 77, 574, 115,
+ 485, 115, 298, 302, 299, 115, 688, 300, 304, 115,
+ 115, 115, 717, 115, 115, 203, 115, 115, 115, 1161,
+ 1161, 691, 115, 303, 115, 305, 692, 115, 1161, 115,
+ 306, 302, 115, 704, 115, 1161, 115, 304, 1161, 115,
+ 188, 717, 115, 115, 115, 1161, 115, 115, 115, 115,
+ 1161, 115, 115, 305, 692, 308, 307, 488, 306, 488,
+ 115, 704, 115, 115, 115, 1161, 115, 489, 1161, 115,
+ 310, 115, 115, 115, 115, 1150, 689, 115, 115, 521,
+
+ 309, 521, 1161, 308, 307, 311, 752, 1161, 115, 522,
+ 115, 115, 115, 239, 240, 115, 115, 115, 115, 310,
+ 115, 115, 93, 115, 315, 689, 241, 1161, 309, 94,
+ 95, 312, 115, 311, 752, 115, 115, 115, 559, 560,
+ 559, 115, 239, 240, 1161, 115, 115, 753, 1161, 313,
+ 115, 115, 314, 315, 241, 115, 318, 115, 1161, 312,
+ 115, 115, 115, 115, 755, 316, 115, 556, 203, 556,
+ 756, 317, 581, 211, 115, 753, 115, 313, 1161, 115,
+ 314, 359, 115, 359, 115, 318, 115, 115, 319, 115,
+ 320, 115, 755, 115, 316, 556, 203, 556, 756, 317,
+
+ 581, 115, 115, 324, 115, 1161, 321, 322, 557, 188,
+ 323, 115, 720, 115, 360, 211, 115, 319, 115, 320,
+ 115, 203, 115, 705, 325, 115, 326, 211, 361, 115,
+ 1161, 324, 115, 327, 321, 322, 557, 557, 323, 115,
+ 115, 720, 115, 360, 387, 115, 815, 115, 815, 115,
+ 759, 705, 325, 211, 115, 326, 361, 328, 687, 115,
+ 115, 327, 708, 329, 93, 557, 808, 115, 115, 115,
+ 703, 94, 95, 85, 115, 387, 707, 330, 759, 713,
+ 265, 1161, 115, 115, 331, 328, 687, 115, 115, 706,
+ 708, 697, 329, 697, 808, 332, 714, 115, 703, 851,
+
+ 582, 1161, 115, 387, 707, 330, 722, 713, 265, 115,
+ 115, 89, 115, 331, 115, 115, 1161, 115, 706, 335,
+ 115, 1161, 333, 332, 715, 714, 334, 851, 115, 582,
+ 115, 387, 115, 1161, 115, 722, 859, 115, 115, 1161,
+ 336, 115, 1161, 115, 115, 337, 115, 725, 335, 115,
+ 333, 115, 716, 715, 334, 1161, 115, 719, 77, 719,
+ 115, 115, 115, 115, 859, 93, 115, 744, 115, 336,
+ 115, 338, 94, 95, 337, 115, 725, 93, 754, 115,
+ 760, 716, 115, 188, 729, 730, 1161, 1161, 115, 693,
+ 1161, 693, 115, 342, 184, 351, 744, 115, 861, 694,
+
+ 338, 727, 806, 635, 815, 635, 815, 754, 862, 760,
+ 115, 352, 352, 352, 352, 352, 352, 352, 352, 352,
+ 352, 353, 807, 810, 1161, 805, 861, 176, 387, 1161,
+ 727, 806, 813, 608, 636, 608, 862, 352, 352, 352,
+ 352, 352, 352, 352, 352, 352, 352, 353, 700, 827,
+ 700, 807, 810, 176, 805, 804, 184, 809, 701, 1161,
+ 203, 813, 702, 352, 352, 352, 352, 352, 352, 352,
+ 352, 352, 352, 353, 748, 380, 211, 380, 827, 176,
+ 826, 211, 826, 856, 826, 211, 826, 110, 749, 357,
+ 357, 357, 357, 357, 357, 357, 357, 357, 357, 115,
+
+ 820, 115, 115, 748, 115, 857, 115, 115, 381, 1161,
+ 267, 757, 856, 270, 363, 188, 749, 362, 115, 272,
+ 115, 364, 382, 832, 77, 832, 203, 758, 115, 820,
+ 115, 115, 211, 115, 857, 115, 115, 381, 267, 115,
+ 757, 270, 363, 1161, 115, 362, 115, 272, 115, 364,
+ 382, 811, 702, 365, 702, 758, 115, 1161, 115, 115,
+ 115, 115, 297, 368, 115, 115, 702, 860, 115, 863,
+ 1161, 367, 824, 115, 298, 115, 299, 821, 115, 366,
+ 811, 365, 864, 901, 1161, 115, 115, 1161, 115, 115,
+ 115, 297, 368, 115, 115, 211, 860, 1161, 863, 367,
+
+ 1161, 824, 298, 115, 299, 821, 115, 366, 1161, 1161,
+ 864, 901, 383, 383, 383, 383, 383, 383, 383, 383,
+ 383, 383, 374, 374, 211, 374, 374, 374, 374, 374,
+ 374, 374, 374, 374, 374, 374, 374, 374, 374, 384,
+ 374, 385, 385, 385, 385, 385, 385, 385, 385, 385,
+ 385, 374, 374, 374, 374, 374, 386, 386, 386, 386,
+ 386, 386, 386, 386, 386, 386, 386, 386, 386, 386,
+ 386, 386, 386, 386, 386, 386, 386, 386, 386, 386,
+ 386, 386, 374, 374, 386, 386, 386, 386, 386, 386,
+ 386, 386, 386, 386, 386, 386, 386, 386, 386, 386,
+
+ 386, 386, 386, 386, 386, 386, 386, 386, 386, 386,
+ 374, 404, 1161, 404, 932, 865, 405, 405, 405, 405,
+ 405, 405, 405, 405, 405, 405, 406, 1161, 406, 935,
+ 899, 407, 407, 407, 407, 407, 407, 407, 407, 407,
+ 407, 408, 932, 408, 865, 900, 409, 409, 409, 409,
+ 409, 409, 409, 409, 409, 409, 423, 935, 423, 899,
+ 1161, 424, 424, 424, 424, 424, 424, 424, 424, 424,
+ 424, 425, 1161, 425, 900, 1161, 426, 426, 426, 426,
+ 426, 426, 426, 426, 426, 426, 427, 902, 427, 432,
+ 937, 428, 428, 428, 428, 428, 428, 428, 428, 428,
+
+ 428, 257, 257, 257, 257, 257, 257, 257, 257, 257,
+ 257, 1161, 115, 769, 115, 769, 902, 115, 937, 115,
+ 429, 430, 430, 430, 430, 430, 430, 430, 430, 430,
+ 430, 115, 433, 115, 115, 905, 908, 115, 908, 115,
+ 431, 115, 115, 115, 770, 434, 115, 93, 115, 429,
+ 908, 435, 908, 115, 839, 840, 115, 115, 211, 115,
+ 433, 115, 115, 115, 905, 693, 115, 693, 115, 431,
+ 436, 115, 1161, 434, 1161, 694, 115, 115, 115, 435,
+ 115, 115, 115, 115, 115, 115, 115, 804, 439, 803,
+ 437, 115, 1161, 1161, 822, 176, 115, 115, 436, 115,
+
+ 438, 805, 924, 115, 115, 188, 115, 115, 115, 115,
+ 115, 115, 115, 1161, 115, 115, 439, 1161, 437, 1161,
+ 441, 440, 115, 822, 115, 115, 1161, 115, 438, 115,
+ 805, 924, 115, 115, 1161, 115, 203, 115, 115, 115,
+ 115, 115, 903, 1161, 115, 700, 115, 700, 441, 440,
+ 115, 442, 115, 443, 445, 701, 444, 115, 115, 702,
+ 115, 1161, 115, 115, 115, 446, 93, 115, 1161, 115,
+ 115, 903, 911, 94, 95, 115, 1161, 115, 115, 442,
+ 115, 443, 445, 115, 444, 115, 1161, 115, 115, 447,
+ 115, 93, 115, 893, 446, 893, 448, 115, 94, 95,
+
+ 1161, 911, 1161, 894, 115, 115, 1161, 115, 115, 451,
+ 929, 115, 115, 115, 115, 449, 115, 447, 965, 115,
+ 931, 804, 184, 809, 448, 115, 203, 115, 115, 176,
+ 115, 453, 115, 115, 211, 452, 115, 115, 451, 929,
+ 115, 466, 115, 466, 449, 115, 965, 115, 115, 931,
+ 115, 933, 454, 115, 1161, 115, 934, 115, 115, 936,
+ 453, 980, 115, 910, 452, 115, 1161, 115, 115, 1161,
+ 1161, 913, 467, 115, 115, 115, 465, 115, 115, 115,
+ 933, 454, 115, 93, 875, 934, 875, 115, 936, 980,
+ 94, 95, 910, 115, 876, 115, 455, 115, 455, 115,
+
+ 913, 959, 115, 115, 115, 465, 115, 964, 115, 239,
+ 240, 115, 93, 966, 893, 115, 893, 468, 469, 94,
+ 95, 115, 241, 1161, 894, 115, 1161, 456, 115, 115,
+ 959, 203, 457, 115, 458, 115, 964, 459, 239, 240,
+ 115, 460, 966, 1161, 461, 468, 469, 462, 463, 472,
+ 241, 464, 115, 115, 115, 115, 470, 115, 115, 471,
+ 115, 457, 989, 458, 991, 884, 459, 884, 115, 460,
+ 1161, 115, 461, 1161, 115, 462, 463, 981, 472, 464,
+ 973, 115, 115, 115, 115, 470, 115, 115, 471, 115,
+ 115, 989, 474, 991, 473, 115, 115, 984, 115, 115,
+
+ 986, 115, 115, 115, 896, 981, 896, 987, 973, 115,
+ 1161, 115, 476, 954, 1161, 115, 115, 115, 988, 115,
+ 115, 474, 473, 990, 115, 984, 477, 115, 986, 115,
+ 1010, 115, 115, 1161, 115, 987, 115, 115, 115, 961,
+ 476, 954, 478, 115, 115, 115, 988, 1161, 1005, 115,
+ 115, 990, 1161, 1013, 477, 1161, 1161, 115, 479, 1010,
+ 115, 115, 115, 1161, 1161, 115, 115, 115, 961, 1014,
+ 478, 1027, 115, 998, 948, 998, 1005, 1015, 115, 203,
+ 115, 480, 1013, 115, 115, 115, 479, 481, 115, 115,
+ 115, 484, 483, 484, 488, 115, 488, 1014, 188, 1027,
+
+ 482, 485, 115, 115, 489, 1017, 1015, 1018, 115, 480,
+ 1161, 1161, 115, 115, 1035, 1021, 481, 115, 115, 1036,
+ 115, 483, 203, 1028, 115, 115, 1031, 115, 482, 115,
+ 115, 115, 115, 1016, 1017, 486, 1018, 1161, 490, 115,
+ 492, 1032, 1035, 115, 1021, 487, 115, 1036, 491, 115,
+ 1043, 1161, 1028, 115, 115, 1031, 115, 1161, 115, 1022,
+ 115, 115, 1016, 486, 493, 115, 490, 115, 492, 1033,
+ 1032, 115, 115, 487, 115, 1034, 491, 115, 1043, 115,
+ 115, 115, 1045, 188, 495, 115, 115, 1161, 1022, 115,
+ 1046, 494, 496, 493, 115, 1161, 1161, 115, 1033, 115,
+
+ 115, 115, 115, 1050, 1034, 1161, 115, 115, 1161, 115,
+ 115, 1045, 1049, 495, 115, 115, 115, 115, 1046, 494,
+ 496, 497, 115, 1041, 948, 1041, 115, 115, 115, 1051,
+ 498, 115, 1050, 115, 115, 1161, 115, 500, 115, 115,
+ 1049, 499, 115, 852, 115, 852, 115, 1052, 1161, 497,
+ 1161, 115, 115, 115, 115, 1161, 115, 1051, 498, 115,
+ 1053, 1161, 115, 115, 115, 1061, 500, 115, 115, 1060,
+ 499, 115, 501, 115, 115, 1161, 1052, 115, 925, 115,
+ 115, 115, 115, 115, 115, 203, 1064, 502, 115, 1053,
+ 503, 926, 1065, 115, 1061, 1161, 115, 1060, 504, 1066,
+
+ 501, 115, 203, 115, 115, 211, 115, 925, 115, 115,
+ 505, 115, 1161, 1161, 1064, 502, 1072, 1056, 503, 926,
+ 1065, 115, 1076, 115, 115, 115, 504, 1066, 1161, 115,
+ 115, 1161, 507, 115, 115, 1161, 506, 115, 115, 505,
+ 508, 1057, 115, 1161, 115, 1072, 1056, 1055, 115, 1075,
+ 1076, 115, 1161, 211, 115, 1079, 115, 509, 115, 115,
+ 115, 507, 115, 115, 506, 115, 115, 115, 508, 115,
+ 1057, 115, 115, 1078, 115, 1055, 115, 512, 1075, 115,
+ 510, 115, 511, 1079, 115, 509, 1161, 1161, 115, 115,
+ 1161, 115, 115, 1058, 115, 115, 115, 115, 115, 513,
+
+ 115, 1161, 1078, 115, 1085, 515, 512, 115, 510, 115,
+ 511, 115, 115, 1161, 115, 115, 115, 115, 115, 514,
+ 115, 115, 1058, 115, 115, 516, 115, 1086, 513, 115,
+ 211, 517, 1085, 515, 115, 1161, 203, 115, 115, 115,
+ 1161, 115, 115, 115, 115, 115, 115, 115, 514, 115,
+ 115, 211, 115, 521, 516, 521, 1086, 518, 1161, 517,
+ 519, 115, 115, 522, 115, 115, 115, 115, 1070, 948,
+ 1070, 1081, 115, 1161, 115, 1084, 1089, 1161, 520, 115,
+ 115, 1090, 115, 203, 1083, 518, 115, 115, 519, 523,
+ 115, 115, 115, 115, 1094, 115, 1161, 1096, 115, 524,
+
+ 1081, 115, 115, 1084, 1089, 115, 520, 115, 115, 1097,
+ 1090, 115, 115, 1083, 526, 115, 115, 1082, 523, 115,
+ 115, 115, 115, 1094, 115, 1096, 1099, 115, 524, 115,
+ 1161, 115, 525, 115, 1161, 1161, 115, 1097, 115, 115,
+ 115, 1103, 526, 1161, 115, 115, 1082, 1111, 115, 115,
+ 115, 1161, 211, 115, 1099, 1104, 527, 1107, 115, 211,
+ 525, 947, 948, 947, 528, 1161, 115, 1161, 115, 949,
+ 1103, 203, 950, 115, 115, 531, 1111, 539, 1161, 115,
+ 947, 948, 947, 1104, 527, 1107, 115, 1023, 949, 1024,
+ 1161, 950, 528, 540, 540, 540, 540, 540, 540, 540,
+
+ 540, 540, 540, 541, 947, 948, 947, 1101, 1161, 176,
+ 1161, 1102, 949, 1161, 188, 950, 1023, 1161, 1024, 540,
+ 540, 540, 540, 540, 540, 540, 540, 540, 540, 541,
+ 1000, 1001, 1000, 1161, 1161, 176, 1101, 188, 1002, 1102,
+ 1161, 1003, 1092, 948, 1092, 540, 540, 540, 540, 540,
+ 540, 540, 540, 540, 540, 541, 1109, 948, 1109, 1098,
+ 1115, 176, 115, 115, 1161, 550, 548, 115, 115, 110,
+ 115, 545, 545, 545, 545, 545, 545, 545, 545, 545,
+ 545, 115, 549, 1114, 115, 115, 551, 1098, 1115, 1120,
+ 115, 115, 115, 554, 550, 548, 115, 115, 1121, 115,
+
+ 1161, 115, 1161, 1161, 115, 552, 115, 1161, 1161, 115,
+ 549, 1114, 115, 1127, 115, 551, 1123, 1120, 482, 115,
+ 115, 115, 1161, 115, 115, 553, 115, 1121, 115, 115,
+ 115, 203, 115, 1161, 552, 115, 947, 948, 947, 1129,
+ 115, 1127, 115, 115, 949, 1123, 482, 950, 115, 1161,
+ 115, 203, 115, 115, 553, 115, 211, 115, 115, 1161,
+ 1161, 1000, 1001, 1000, 1161, 1161, 1116, 1129, 115, 1002,
+ 115, 115, 1003, 383, 383, 383, 383, 383, 383, 383,
+ 383, 383, 383, 211, 1161, 1000, 1001, 1000, 1117, 1118,
+ 1117, 1161, 565, 1002, 1132, 1116, 1003, 1131, 1136, 1161,
+
+ 566, 566, 566, 566, 566, 566, 566, 566, 566, 566,
+ 211, 1161, 1042, 1001, 1042, 1117, 1118, 1117, 1142, 567,
+ 949, 565, 1132, 950, 1161, 1131, 1136, 383, 383, 383,
+ 383, 383, 383, 383, 383, 383, 383, 405, 405, 405,
+ 405, 405, 405, 405, 405, 405, 405, 1142, 567, 405,
+ 405, 405, 405, 405, 405, 405, 405, 405, 405, 407,
+ 407, 407, 407, 407, 407, 407, 407, 407, 407, 407,
+ 407, 407, 407, 407, 407, 407, 407, 407, 407, 409,
+ 409, 409, 409, 409, 409, 409, 409, 409, 409, 409,
+ 409, 409, 409, 409, 409, 409, 409, 409, 409, 424,
+
+ 424, 424, 424, 424, 424, 424, 424, 424, 424, 424,
+ 424, 424, 424, 424, 424, 424, 424, 424, 424, 426,
+ 426, 426, 426, 426, 426, 426, 426, 426, 426, 426,
+ 426, 426, 426, 426, 426, 426, 426, 426, 426, 428,
+ 428, 428, 428, 428, 428, 428, 428, 428, 428, 428,
+ 428, 428, 428, 428, 428, 428, 428, 428, 428, 588,
+ 211, 588, 1161, 1161, 589, 589, 589, 589, 589, 589,
+ 589, 589, 589, 589, 430, 430, 430, 430, 430, 430,
+ 430, 430, 430, 430, 1161, 115, 1161, 115, 1161, 590,
+ 115, 590, 115, 429, 591, 591, 591, 591, 591, 591,
+
+ 591, 591, 591, 591, 115, 592, 115, 115, 115, 593,
+ 203, 1119, 115, 115, 115, 1161, 115, 1141, 188, 115,
+ 1161, 115, 429, 1161, 115, 1161, 115, 115, 594, 115,
+ 115, 1161, 115, 592, 115, 115, 115, 115, 593, 1119,
+ 1161, 115, 115, 115, 1161, 1141, 115, 203, 595, 115,
+ 1149, 115, 1161, 115, 115, 115, 1146, 594, 115, 115,
+ 1161, 1161, 596, 1161, 115, 115, 188, 115, 115, 115,
+ 1161, 115, 597, 115, 115, 115, 595, 115, 188, 1149,
+ 115, 115, 1161, 598, 1146, 115, 203, 115, 115, 115,
+ 115, 596, 1144, 115, 115, 188, 115, 115, 115, 203,
+
+ 599, 597, 115, 115, 115, 115, 1161, 188, 115, 115,
+ 115, 598, 1161, 600, 115, 115, 115, 1130, 115, 115,
+ 1144, 115, 115, 115, 115, 601, 115, 115, 599, 1143,
+ 115, 1157, 115, 602, 115, 115, 115, 1148, 1161, 115,
+ 115, 115, 600, 603, 1145, 1130, 1124, 948, 1124, 115,
+ 115, 115, 115, 1161, 601, 115, 115, 1143, 1151, 115,
+ 1157, 602, 115, 1161, 115, 1148, 188, 115, 115, 115,
+ 115, 603, 1145, 605, 115, 115, 203, 115, 606, 115,
+ 1161, 115, 1161, 1161, 203, 608, 1151, 608, 1161, 115,
+ 1161, 115, 607, 115, 1161, 1161, 115, 1161, 1161, 115,
+
+ 1161, 605, 1147, 115, 115, 1161, 1161, 606, 115, 115,
+ 115, 1153, 1154, 1153, 115, 115, 1161, 115, 115, 115,
+ 607, 115, 1161, 115, 1161, 1155, 609, 1161, 619, 115,
+ 620, 1147, 1161, 115, 1161, 1152, 1161, 115, 1161, 115,
+ 610, 115, 1161, 115, 115, 115, 621, 115, 115, 1161,
+ 115, 1161, 115, 1155, 203, 609, 619, 115, 620, 622,
+ 115, 115, 115, 1152, 115, 115, 1161, 115, 610, 455,
+ 115, 455, 1161, 1161, 115, 621, 1153, 1154, 1153, 115,
+ 1161, 629, 1161, 1161, 115, 1161, 1161, 622, 115, 115,
+ 1156, 115, 115, 1159, 1160, 1159, 115, 1159, 1160, 1159,
+
+ 456, 623, 1161, 115, 1161, 611, 115, 612, 1161, 629,
+ 613, 115, 203, 115, 614, 1161, 1161, 615, 115, 1156,
+ 616, 617, 1161, 1161, 618, 115, 1161, 1161, 1161, 623,
+ 626, 115, 1161, 1161, 611, 115, 612, 1161, 115, 613,
+ 115, 1161, 614, 115, 1161, 615, 115, 1161, 616, 617,
+ 624, 115, 618, 115, 115, 115, 1161, 637, 626, 115,
+ 115, 627, 1161, 1158, 1161, 115, 625, 115, 1161, 1161,
+ 1161, 1161, 115, 115, 115, 115, 628, 1161, 1161, 624,
+ 115, 1161, 1161, 115, 115, 637, 1161, 1161, 115, 115,
+ 627, 1158, 1161, 115, 625, 1161, 1161, 1161, 1161, 1161,
+
+ 1161, 115, 115, 1161, 628, 630, 630, 630, 630, 630,
+ 630, 630, 630, 630, 630, 630, 1161, 630, 630, 630,
+ 630, 630, 631, 630, 632, 632, 632, 632, 632, 632,
+ 632, 632, 632, 632, 630, 630, 630, 630, 630, 633,
+ 633, 633, 633, 633, 633, 633, 633, 633, 633, 633,
+ 633, 633, 633, 633, 633, 633, 633, 633, 633, 633,
+ 633, 633, 633, 633, 633, 630, 630, 633, 633, 633,
+ 633, 633, 633, 633, 633, 633, 633, 633, 633, 633,
+ 633, 633, 633, 633, 633, 633, 633, 633, 633, 633,
+ 633, 633, 633, 630, 115, 1161, 635, 638, 635, 115,
+
+ 1161, 1161, 115, 115, 1000, 1001, 1000, 1161, 115, 1161,
+ 1161, 634, 1002, 115, 1161, 1003, 115, 1161, 1161, 1161,
+ 1161, 1161, 639, 115, 1161, 1161, 638, 636, 115, 115,
+ 115, 115, 115, 1161, 115, 115, 1161, 115, 115, 634,
+ 1161, 115, 1161, 115, 115, 1161, 641, 1161, 115, 115,
+ 639, 1161, 1161, 1161, 1161, 1161, 1161, 115, 115, 115,
+ 115, 1161, 1161, 115, 115, 115, 1161, 115, 115, 1161,
+ 1161, 1161, 115, 115, 1161, 641, 115, 115, 1161, 115,
+ 642, 1161, 1161, 1161, 1161, 115, 1161, 643, 1161, 115,
+ 115, 1161, 1161, 1161, 115, 115, 1161, 115, 644, 115,
+
+ 1161, 1161, 115, 1161, 115, 645, 1161, 115, 642, 115,
+ 1161, 1161, 646, 1161, 1161, 643, 1161, 1161, 115, 115,
+ 1161, 1000, 1001, 1000, 115, 1161, 1161, 644, 115, 1002,
+ 115, 650, 1003, 115, 645, 115, 115, 115, 647, 115,
+ 646, 648, 115, 1161, 115, 1161, 115, 115, 1161, 115,
+ 115, 1161, 1161, 1161, 1161, 1161, 649, 1161, 115, 115,
+ 650, 115, 1161, 1161, 115, 115, 1161, 647, 115, 115,
+ 648, 115, 1161, 115, 115, 652, 115, 115, 115, 1161,
+ 115, 1161, 1161, 651, 649, 1161, 115, 1161, 115, 115,
+ 1161, 115, 1161, 1161, 115, 115, 115, 1161, 115, 1161,
+
+ 115, 1161, 653, 115, 652, 1161, 654, 115, 1161, 115,
+ 115, 651, 115, 1161, 115, 1161, 115, 1161, 115, 1161,
+ 115, 1161, 115, 115, 115, 115, 115, 115, 1161, 115,
+ 653, 1161, 115, 1161, 654, 655, 115, 115, 115, 115,
+ 1161, 115, 115, 115, 115, 1161, 115, 115, 115, 1161,
+ 115, 1161, 115, 1161, 115, 115, 115, 1161, 115, 1161,
+ 1161, 115, 115, 1161, 655, 115, 115, 1161, 115, 659,
+ 115, 115, 115, 115, 115, 115, 1161, 115, 1161, 115,
+ 656, 1161, 657, 1161, 115, 115, 115, 115, 1161, 115,
+ 115, 658, 115, 115, 1161, 115, 661, 659, 115, 115,
+
+ 115, 115, 1161, 1161, 115, 1161, 115, 1161, 656, 1161,
+ 657, 1161, 660, 115, 1161, 115, 115, 115, 115, 115,
+ 658, 115, 115, 115, 115, 661, 1161, 115, 1161, 664,
+ 115, 1071, 948, 1071, 115, 662, 1161, 115, 115, 949,
+ 660, 115, 950, 115, 1161, 1161, 115, 115, 115, 663,
+ 115, 1161, 115, 115, 1161, 115, 1161, 115, 1161, 1161,
+ 115, 1161, 115, 662, 1161, 115, 115, 1161, 1161, 115,
+ 115, 1161, 1161, 1161, 665, 115, 115, 1161, 663, 115,
+ 1161, 1161, 115, 1161, 115, 1161, 115, 115, 115, 115,
+ 115, 115, 1161, 666, 115, 115, 1161, 115, 1161, 1161,
+
+ 1161, 115, 665, 668, 115, 1161, 667, 1161, 115, 115,
+ 1161, 115, 1161, 1161, 1161, 1161, 115, 1161, 115, 115,
+ 115, 666, 115, 115, 115, 115, 1161, 115, 115, 115,
+ 669, 668, 1161, 115, 667, 1161, 115, 115, 670, 115,
+ 1161, 115, 1161, 1161, 1161, 115, 1161, 115, 1161, 115,
+ 115, 115, 1161, 115, 115, 1161, 115, 115, 115, 669,
+ 1161, 115, 115, 1161, 115, 115, 115, 115, 1161, 115,
+ 115, 1161, 115, 1161, 115, 115, 1161, 1161, 1161, 115,
+ 115, 1161, 115, 1161, 115, 1161, 115, 115, 115, 1161,
+ 115, 115, 115, 115, 115, 115, 1161, 1161, 1161, 115,
+
+ 115, 1161, 671, 1161, 1161, 115, 1161, 115, 115, 115,
+ 1161, 1161, 115, 672, 115, 115, 1161, 115, 115, 1161,
+ 115, 115, 115, 115, 1161, 1161, 115, 1161, 115, 1161,
+ 671, 1161, 1161, 115, 1161, 115, 1161, 115, 115, 1161,
+ 115, 115, 672, 115, 115, 673, 115, 115, 674, 115,
+ 115, 1161, 115, 1161, 1161, 115, 115, 1161, 1161, 1161,
+ 115, 698, 1161, 115, 1161, 115, 115, 1161, 115, 1161,
+ 115, 1161, 1161, 115, 673, 115, 1161, 674, 115, 677,
+ 115, 684, 1161, 1161, 1161, 1093, 948, 1093, 115, 1161,
+ 698, 115, 1161, 949, 1161, 115, 950, 685, 685, 685,
+
+ 685, 685, 685, 685, 685, 685, 685, 686, 115, 1110,
+ 948, 1110, 1161, 176, 1161, 1161, 1161, 949, 1161, 1161,
+ 950, 1161, 1161, 685, 685, 685, 685, 685, 685, 685,
+ 685, 685, 685, 686, 693, 1161, 693, 1161, 1161, 176,
+ 1161, 1161, 1161, 1161, 694, 1161, 1161, 1161, 1161, 685,
+ 685, 685, 685, 685, 685, 685, 685, 685, 685, 686,
+ 697, 1161, 697, 1161, 1161, 176, 696, 115, 1161, 1161,
+ 695, 115, 115, 110, 600, 690, 690, 690, 690, 690,
+ 690, 690, 690, 690, 690, 115, 115, 1161, 1161, 1161,
+ 1161, 1161, 1161, 115, 1161, 696, 115, 1161, 115, 695,
+
+ 115, 115, 115, 600, 1161, 115, 1161, 115, 645, 732,
+ 115, 1161, 115, 115, 115, 646, 1161, 1161, 700, 699,
+ 700, 115, 115, 1161, 115, 1161, 1161, 115, 701, 1161,
+ 1161, 115, 702, 1161, 115, 1161, 115, 645, 732, 115,
+ 115, 211, 1161, 646, 1161, 1161, 1161, 699, 1161, 115,
+ 1161, 115, 115, 709, 1161, 709, 115, 1161, 710, 710,
+ 710, 710, 710, 710, 710, 710, 710, 710, 1161, 211,
+ 115, 1126, 948, 1126, 1161, 1161, 1161, 1161, 1161, 949,
+ 115, 1161, 950, 1161, 1161, 115, 566, 566, 566, 566,
+ 566, 566, 566, 566, 566, 566, 211, 1161, 115, 1161,
+
+ 1161, 947, 948, 947, 1161, 565, 1161, 1161, 711, 949,
+ 711, 1161, 950, 712, 712, 712, 712, 712, 712, 712,
+ 712, 712, 712, 589, 589, 589, 589, 589, 589, 589,
+ 589, 589, 589, 1161, 565, 589, 589, 589, 589, 589,
+ 589, 589, 589, 589, 589, 591, 591, 591, 591, 591,
+ 591, 591, 591, 591, 591, 591, 591, 591, 591, 591,
+ 591, 591, 591, 591, 591, 733, 1161, 1161, 115, 1161,
+ 115, 1161, 1161, 115, 947, 948, 947, 1161, 1000, 1001,
+ 1000, 1161, 949, 737, 115, 950, 1002, 115, 1161, 1003,
+ 1161, 1161, 1161, 1161, 733, 1161, 1161, 115, 1161, 115,
+
+ 1161, 1161, 115, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 737, 115, 718, 718, 115, 718, 718, 718, 718,
+ 718, 718, 718, 718, 718, 718, 718, 718, 718, 718,
+ 734, 718, 735, 735, 735, 735, 735, 735, 735, 735,
+ 735, 735, 718, 718, 718, 718, 718, 736, 736, 736,
+ 736, 736, 736, 736, 736, 736, 736, 736, 736, 736,
+ 736, 736, 736, 736, 736, 736, 736, 736, 736, 736,
+ 736, 736, 736, 718, 718, 736, 736, 736, 736, 736,
+ 736, 736, 736, 736, 736, 736, 736, 736, 736, 736,
+ 736, 736, 736, 736, 736, 736, 736, 736, 736, 736,
+
+ 736, 718, 115, 115, 738, 115, 115, 115, 115, 115,
+ 115, 115, 1161, 740, 115, 1161, 1161, 1161, 739, 741,
+ 1161, 115, 115, 1161, 115, 115, 1161, 1161, 115, 1161,
+ 1161, 115, 115, 738, 115, 115, 115, 115, 115, 115,
+ 115, 1161, 740, 115, 1161, 1161, 739, 741, 1161, 115,
+ 115, 1161, 115, 115, 115, 115, 115, 115, 1161, 115,
+ 115, 115, 115, 1161, 1161, 745, 115, 1161, 1161, 742,
+ 1161, 1161, 1161, 115, 115, 743, 115, 1161, 1161, 1161,
+ 115, 1161, 1161, 115, 115, 1161, 115, 115, 115, 115,
+ 115, 115, 115, 1161, 745, 115, 1161, 742, 746, 1161,
+
+ 1161, 115, 115, 743, 115, 1161, 115, 1161, 115, 115,
+ 115, 1161, 1161, 115, 750, 115, 115, 747, 115, 1161,
+ 751, 115, 1161, 1161, 1161, 1161, 746, 1161, 115, 115,
+ 1161, 1161, 115, 1161, 115, 115, 115, 1161, 115, 115,
+ 115, 115, 115, 750, 115, 1161, 747, 115, 1161, 751,
+ 1161, 1161, 1161, 1161, 115, 115, 115, 115, 115, 1161,
+ 115, 1161, 1161, 115, 115, 115, 1161, 1161, 1161, 115,
+ 115, 761, 1161, 1161, 115, 115, 1161, 115, 762, 115,
+ 115, 1161, 115, 115, 1161, 1161, 1161, 115, 763, 1161,
+ 1161, 115, 115, 115, 115, 1161, 115, 1161, 1161, 761,
+
+ 1161, 1161, 764, 115, 115, 115, 1161, 762, 115, 115,
+ 115, 1161, 115, 765, 115, 1161, 763, 115, 768, 115,
+ 115, 115, 115, 115, 1161, 115, 1161, 1161, 1161, 766,
+ 764, 115, 1161, 115, 1161, 115, 1161, 115, 115, 767,
+ 115, 115, 765, 115, 1161, 1161, 115, 768, 115, 1161,
+ 1161, 1161, 115, 769, 115, 769, 1161, 766, 1161, 115,
+ 1161, 115, 1161, 258, 115, 115, 1161, 1161, 767, 115,
+ 257, 257, 257, 257, 257, 257, 257, 257, 257, 257,
+ 115, 1161, 115, 115, 770, 115, 115, 115, 115, 115,
+ 1161, 115, 115, 1161, 115, 1161, 1161, 1161, 1161, 115,
+
+ 771, 1161, 115, 1161, 1161, 115, 115, 1161, 115, 115,
+ 1161, 1161, 115, 1161, 115, 115, 115, 115, 115, 115,
+ 115, 115, 1161, 115, 115, 1161, 1161, 115, 771, 1161,
+ 115, 1161, 1161, 115, 115, 115, 115, 1161, 772, 115,
+ 115, 774, 115, 773, 115, 775, 115, 115, 115, 1161,
+ 1161, 115, 1161, 115, 115, 1161, 1161, 1161, 115, 1161,
+ 1161, 115, 115, 1161, 115, 115, 772, 115, 115, 115,
+ 774, 115, 773, 115, 775, 115, 115, 1161, 1161, 776,
+ 115, 115, 115, 115, 1161, 115, 115, 777, 115, 115,
+ 115, 115, 115, 115, 780, 1161, 115, 115, 1161, 115,
+
+ 1161, 1161, 115, 1161, 778, 779, 1161, 776, 1161, 115,
+ 1161, 115, 115, 115, 115, 1161, 777, 115, 1161, 115,
+ 1161, 115, 1161, 780, 1161, 1161, 115, 1161, 115, 115,
+ 115, 781, 778, 779, 115, 115, 1161, 1161, 1161, 115,
+ 115, 115, 1161, 1161, 1161, 1161, 782, 1161, 115, 1161,
+ 1161, 1161, 1161, 1161, 115, 1161, 1161, 1161, 115, 1161,
+ 781, 115, 1161, 115, 115, 115, 115, 783, 1161, 115,
+ 115, 1161, 784, 115, 782, 1161, 115, 785, 115, 1161,
+ 115, 1161, 115, 1161, 115, 1161, 1161, 1161, 1161, 1161,
+ 115, 1161, 115, 1161, 115, 115, 783, 1161, 115, 115,
+
+ 784, 1161, 115, 787, 1161, 115, 785, 115, 115, 115,
+ 115, 1161, 115, 786, 115, 1161, 1161, 115, 1161, 1161,
+ 115, 1161, 788, 1161, 115, 115, 1161, 115, 115, 789,
+ 115, 1161, 787, 1161, 115, 1161, 115, 1161, 115, 115,
+ 1161, 115, 786, 115, 115, 115, 1161, 1161, 115, 1161,
+ 788, 1161, 115, 115, 115, 115, 115, 115, 789, 115,
+ 1161, 790, 115, 1161, 1161, 115, 1161, 115, 115, 792,
+ 115, 1161, 115, 115, 115, 1161, 115, 115, 1161, 1161,
+ 1161, 1161, 115, 115, 1161, 1161, 115, 791, 115, 1161,
+ 790, 115, 1161, 1161, 115, 115, 793, 115, 792, 115,
+
+ 115, 115, 115, 115, 115, 115, 115, 1161, 1161, 1161,
+ 1161, 1161, 1161, 115, 1161, 791, 115, 1161, 795, 115,
+ 796, 1161, 1161, 115, 1161, 793, 115, 1161, 115, 115,
+ 115, 115, 1161, 1161, 115, 115, 1161, 115, 1161, 797,
+ 798, 115, 115, 1161, 1161, 115, 795, 115, 796, 115,
+ 1161, 1161, 1161, 115, 115, 115, 115, 115, 115, 1161,
+ 115, 1161, 115, 1161, 1161, 1161, 115, 797, 799, 798,
+ 1161, 115, 801, 115, 115, 1161, 115, 800, 115, 115,
+ 115, 1161, 115, 115, 115, 115, 115, 115, 1161, 1161,
+ 1161, 115, 1161, 115, 1161, 1161, 799, 1161, 1161, 115,
+
+ 801, 1161, 1161, 115, 115, 800, 1161, 1161, 115, 115,
+ 1161, 1161, 176, 1161, 115, 1161, 1161, 1161, 176, 115,
+ 1161, 115, 1161, 816, 115, 1161, 110, 115, 111, 111,
+ 111, 111, 111, 111, 111, 111, 111, 111, 115, 115,
+ 115, 115, 1161, 1161, 115, 115, 819, 817, 115, 1161,
+ 1161, 818, 816, 115, 1161, 1161, 1161, 1161, 115, 115,
+ 115, 1161, 1161, 1161, 1161, 1161, 115, 1161, 115, 115,
+ 115, 1161, 211, 115, 115, 819, 817, 1161, 1161, 818,
+ 1161, 1161, 211, 1161, 1161, 1161, 115, 115, 115, 710,
+ 710, 710, 710, 710, 710, 710, 710, 710, 710, 710,
+
+ 710, 710, 710, 710, 710, 710, 710, 710, 710, 211,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 211,
+ 1161, 1161, 1161, 1161, 1161, 1161, 712, 712, 712, 712,
+ 712, 712, 712, 712, 712, 712, 712, 712, 712, 712,
+ 712, 712, 712, 712, 712, 712, 823, 823, 211, 823,
+ 823, 823, 823, 823, 823, 823, 823, 823, 823, 823,
+ 823, 823, 823, 828, 823, 829, 829, 829, 829, 829,
+ 829, 829, 829, 829, 829, 823, 823, 823, 823, 823,
+ 830, 830, 830, 830, 830, 830, 830, 830, 830, 830,
+ 830, 830, 830, 830, 830, 830, 830, 830, 830, 830,
+
+ 830, 830, 830, 830, 830, 830, 823, 823, 830, 830,
+ 830, 830, 830, 830, 830, 830, 830, 830, 830, 830,
+ 830, 830, 830, 830, 830, 830, 830, 830, 830, 830,
+ 830, 830, 830, 830, 823, 832, 77, 832, 1161, 1161,
+ 833, 833, 1161, 833, 1161, 1161, 1161, 833, 833, 1161,
+ 1161, 833, 1161, 1161, 833, 833, 833, 833, 833, 833,
+ 833, 833, 833, 831, 831, 1161, 831, 831, 831, 831,
+ 831, 831, 831, 831, 831, 831, 831, 831, 831, 831,
+ 841, 831, 842, 842, 842, 842, 842, 842, 842, 842,
+ 842, 842, 831, 831, 831, 831, 831, 843, 843, 843,
+
+ 843, 843, 843, 843, 843, 843, 843, 843, 843, 843,
+ 843, 843, 843, 843, 843, 843, 843, 843, 843, 843,
+ 843, 843, 843, 831, 831, 843, 843, 843, 843, 843,
+ 843, 843, 843, 843, 843, 843, 843, 843, 843, 843,
+ 843, 843, 843, 843, 843, 843, 843, 843, 843, 843,
+ 843, 831, 115, 1161, 1161, 258, 1161, 115, 257, 257,
+ 257, 257, 257, 257, 257, 257, 257, 257, 115, 845,
+ 1161, 844, 115, 115, 115, 115, 1161, 115, 1161, 1161,
+ 115, 115, 1161, 1161, 1161, 1161, 115, 115, 115, 1161,
+ 1161, 115, 1161, 1161, 846, 115, 1161, 115, 845, 844,
+
+ 115, 115, 115, 115, 115, 1161, 115, 115, 1161, 115,
+ 1161, 1161, 115, 1161, 115, 115, 115, 1161, 115, 115,
+ 1161, 1161, 846, 115, 115, 1161, 115, 1161, 1161, 115,
+ 847, 1161, 1161, 1161, 1161, 1161, 115, 115, 848, 1161,
+ 1161, 115, 115, 115, 1161, 849, 1161, 115, 115, 1161,
+ 115, 115, 115, 1161, 115, 115, 115, 1161, 847, 850,
+ 1161, 852, 115, 852, 1161, 115, 848, 1161, 1161, 115,
+ 115, 1161, 115, 115, 849, 1161, 1161, 115, 115, 115,
+ 115, 1161, 115, 1161, 115, 115, 855, 115, 850, 1161,
+ 115, 1161, 115, 1161, 115, 1161, 853, 115, 115, 115,
+
+ 1161, 115, 115, 1161, 1161, 1161, 1161, 115, 1161, 854,
+ 1161, 115, 1161, 115, 115, 855, 115, 1161, 858, 115,
+ 115, 1161, 1161, 115, 1161, 853, 115, 1161, 115, 115,
+ 1161, 115, 1161, 115, 115, 1161, 866, 854, 1161, 115,
+ 1161, 115, 1161, 115, 1161, 115, 867, 858, 115, 1161,
+ 1161, 115, 1161, 115, 1161, 115, 115, 868, 1161, 1161,
+ 115, 115, 1161, 115, 1161, 866, 1161, 1161, 115, 1161,
+ 115, 115, 115, 115, 867, 869, 115, 115, 115, 1161,
+ 115, 115, 871, 115, 1161, 115, 868, 1161, 1161, 870,
+ 115, 115, 1161, 1161, 874, 1161, 1161, 115, 115, 115,
+
+ 115, 115, 1161, 115, 869, 115, 115, 115, 115, 1161,
+ 115, 871, 115, 115, 875, 115, 875, 870, 115, 115,
+ 872, 873, 115, 874, 876, 115, 115, 1161, 115, 115,
+ 1161, 115, 115, 1161, 1161, 1161, 1161, 115, 1161, 115,
+ 877, 115, 1161, 1161, 115, 115, 115, 115, 872, 873,
+ 115, 115, 115, 1161, 878, 115, 1161, 115, 115, 1161,
+ 115, 1161, 879, 115, 1161, 115, 115, 115, 877, 115,
+ 1161, 880, 115, 115, 115, 115, 115, 115, 1161, 1161,
+ 115, 115, 1161, 878, 1161, 1161, 115, 115, 115, 1161,
+ 115, 879, 115, 115, 115, 115, 115, 1161, 115, 115,
+
+ 880, 115, 1161, 115, 115, 115, 1161, 881, 1161, 115,
+ 115, 1161, 1161, 1161, 115, 115, 115, 882, 115, 115,
+ 1161, 883, 115, 1161, 115, 1161, 1161, 115, 115, 115,
+ 1161, 115, 1161, 115, 1161, 881, 115, 115, 1161, 115,
+ 1161, 115, 115, 115, 115, 882, 115, 115, 115, 883,
+ 115, 115, 1161, 884, 1161, 884, 115, 115, 1161, 1161,
+ 115, 115, 115, 115, 1161, 115, 1161, 1161, 115, 115,
+ 1161, 115, 115, 1161, 115, 1161, 115, 115, 115, 115,
+ 1161, 886, 115, 888, 1161, 1161, 115, 1161, 115, 115,
+ 115, 115, 115, 115, 115, 1161, 1161, 115, 887, 115,
+
+ 1161, 885, 115, 115, 1161, 115, 1161, 1161, 115, 886,
+ 115, 1161, 888, 889, 1161, 115, 1161, 115, 1161, 115,
+ 115, 115, 1161, 115, 115, 1161, 887, 115, 115, 885,
+ 115, 891, 115, 115, 1161, 1161, 890, 1161, 115, 115,
+ 1161, 889, 1161, 1161, 115, 1161, 115, 1161, 115, 1161,
+ 1161, 892, 1161, 115, 1161, 1161, 115, 1161, 115, 1161,
+ 891, 115, 115, 1161, 890, 1161, 115, 115, 115, 1161,
+ 115, 115, 1161, 115, 115, 115, 115, 1161, 895, 892,
+ 1161, 115, 115, 1161, 1161, 1161, 115, 115, 1161, 115,
+ 115, 115, 1161, 115, 1161, 896, 115, 896, 115, 115,
+
+ 115, 115, 1161, 1161, 115, 115, 1161, 895, 1161, 115,
+ 1161, 115, 115, 1161, 1161, 1161, 115, 115, 115, 115,
+ 115, 1161, 115, 1161, 115, 115, 115, 115, 115, 115,
+ 897, 906, 1161, 115, 1161, 1161, 1161, 1161, 898, 115,
+ 115, 1161, 1161, 1161, 1161, 115, 1161, 115, 115, 115,
+ 1161, 115, 1161, 115, 115, 115, 115, 115, 1161, 897,
+ 906, 1161, 115, 1161, 907, 1161, 898, 115, 1161, 908,
+ 115, 908, 1161, 115, 258, 115, 802, 77, 804, 175,
+ 115, 1161, 1161, 1161, 1161, 115, 1161, 1161, 1161, 1161,
+ 909, 115, 907, 1161, 1161, 115, 115, 1161, 115, 1161,
+
+ 1161, 1161, 115, 1161, 1161, 1161, 1161, 115, 1161, 115,
+ 115, 177, 178, 1161, 1161, 179, 1161, 180, 1161, 909,
+ 115, 115, 1161, 1161, 115, 115, 1161, 1161, 341, 182,
+ 1161, 115, 1161, 1161, 1161, 1161, 115, 115, 115, 1161,
+ 177, 178, 1161, 1161, 179, 1161, 180, 1161, 1161, 115,
+ 1161, 1161, 1161, 1161, 1161, 1161, 341, 182, 912, 912,
+ 211, 912, 912, 912, 912, 912, 912, 912, 912, 912,
+ 912, 912, 912, 912, 912, 914, 912, 915, 915, 915,
+ 915, 915, 915, 915, 915, 915, 915, 912, 912, 912,
+ 912, 912, 916, 916, 916, 916, 916, 916, 916, 916,
+
+ 916, 916, 916, 916, 916, 916, 916, 916, 916, 916,
+ 916, 916, 916, 916, 916, 916, 916, 916, 912, 912,
+ 916, 916, 916, 916, 916, 916, 916, 916, 916, 916,
+ 916, 916, 916, 916, 916, 916, 916, 916, 916, 916,
+ 916, 916, 916, 916, 916, 916, 912, 211, 257, 257,
+ 257, 257, 257, 257, 257, 257, 257, 257, 1161, 1161,
+ 1161, 1161, 1161, 1161, 383, 383, 383, 383, 383, 383,
+ 383, 383, 383, 383, 374, 374, 211, 374, 374, 374,
+ 374, 374, 374, 374, 374, 374, 374, 374, 374, 374,
+ 374, 384, 374, 385, 385, 385, 385, 385, 385, 385,
+
+ 385, 385, 385, 374, 374, 374, 374, 374, 386, 386,
+ 386, 386, 386, 386, 386, 386, 386, 386, 386, 386,
+ 386, 386, 386, 386, 386, 386, 386, 386, 386, 386,
+ 386, 386, 386, 386, 374, 374, 386, 386, 386, 386,
+ 386, 386, 386, 386, 386, 386, 386, 386, 386, 386,
+ 386, 386, 386, 386, 386, 386, 386, 386, 386, 386,
+ 386, 386, 374, 115, 1161, 917, 1161, 115, 115, 918,
+ 115, 115, 115, 919, 115, 1161, 115, 1161, 920, 115,
+ 1161, 1161, 115, 1161, 115, 1161, 115, 1161, 1161, 1161,
+ 115, 1161, 115, 115, 917, 1161, 115, 115, 918, 115,
+
+ 115, 115, 919, 115, 922, 115, 1161, 920, 115, 115,
+ 115, 115, 115, 1161, 115, 921, 115, 1161, 115, 1161,
+ 115, 115, 1161, 115, 1161, 115, 1161, 115, 1161, 1161,
+ 115, 115, 115, 922, 923, 1161, 115, 1161, 115, 115,
+ 115, 927, 1161, 1161, 921, 115, 115, 1161, 928, 115,
+ 115, 115, 115, 1161, 115, 1161, 115, 115, 115, 1161,
+ 115, 115, 923, 115, 1161, 115, 1161, 115, 115, 927,
+ 1161, 115, 115, 1161, 115, 1161, 928, 115, 115, 1161,
+ 930, 115, 115, 115, 1161, 1161, 115, 1161, 115, 1161,
+ 1161, 938, 115, 1161, 939, 1161, 1161, 115, 1161, 115,
+
+ 1161, 115, 115, 1161, 115, 1161, 115, 1161, 930, 115,
+ 115, 1161, 115, 115, 1161, 941, 1161, 115, 115, 938,
+ 1161, 940, 939, 115, 1161, 1161, 1161, 1161, 1161, 115,
+ 115, 1161, 115, 115, 115, 115, 1161, 1161, 115, 1161,
+ 115, 1161, 115, 942, 941, 1161, 1161, 115, 115, 940,
+ 1161, 115, 1161, 1161, 115, 1161, 1161, 1161, 115, 1161,
+ 115, 115, 1161, 115, 115, 943, 115, 1161, 115, 115,
+ 115, 942, 944, 115, 1161, 115, 115, 1161, 1161, 1161,
+ 115, 945, 115, 1161, 1161, 1161, 1161, 115, 1161, 115,
+ 115, 115, 1161, 115, 943, 115, 115, 115, 115, 115,
+
+ 1161, 944, 115, 1161, 115, 1161, 951, 1161, 115, 945,
+ 952, 1161, 115, 115, 115, 115, 115, 115, 115, 115,
+ 115, 115, 115, 1161, 1161, 115, 1161, 115, 1161, 1161,
+ 1161, 1161, 115, 115, 951, 115, 115, 1161, 952, 1161,
+ 115, 115, 115, 115, 953, 115, 1161, 115, 115, 1161,
+ 115, 1161, 115, 115, 1161, 115, 1161, 115, 115, 115,
+ 115, 115, 1161, 115, 115, 115, 1161, 1161, 1161, 1161,
+ 115, 115, 956, 953, 1161, 1161, 955, 1161, 115, 115,
+ 1161, 115, 115, 115, 115, 1161, 115, 115, 115, 1161,
+ 115, 115, 1161, 115, 1161, 115, 115, 1161, 115, 115,
+
+ 956, 957, 115, 1161, 955, 1161, 115, 115, 115, 115,
+ 115, 115, 1161, 115, 1161, 958, 115, 1161, 1161, 115,
+ 115, 115, 115, 962, 115, 115, 115, 115, 115, 957,
+ 115, 115, 1161, 1161, 115, 1161, 115, 115, 115, 115,
+ 115, 115, 115, 969, 958, 115, 1161, 1161, 115, 115,
+ 1161, 115, 962, 115, 1161, 960, 115, 115, 115, 115,
+ 1161, 1161, 115, 115, 115, 1161, 115, 963, 115, 115,
+ 115, 115, 969, 1161, 1161, 1161, 1161, 115, 115, 1161,
+ 1161, 115, 1161, 960, 970, 115, 1161, 1161, 115, 115,
+ 115, 971, 1161, 115, 115, 115, 963, 1161, 1161, 1161,
+
+ 115, 1161, 1161, 1161, 1161, 1161, 115, 211, 115, 1161,
+ 1161, 1161, 970, 115, 1161, 1161, 115, 975, 115, 1161,
+ 971, 115, 1161, 115, 383, 383, 383, 383, 383, 383,
+ 383, 383, 383, 383, 1161, 115, 115, 115, 1161, 115,
+ 1161, 1161, 115, 976, 115, 115, 975, 1161, 115, 1161,
+ 115, 1161, 1161, 115, 1161, 1161, 115, 1161, 115, 1161,
+ 1161, 1161, 1161, 115, 1161, 977, 115, 115, 115, 115,
+ 115, 115, 976, 115, 115, 115, 1161, 115, 115, 1161,
+ 1161, 1161, 115, 115, 115, 1161, 115, 1161, 115, 978,
+ 1161, 979, 1161, 977, 1161, 115, 1161, 115, 115, 115,
+
+ 1161, 115, 1161, 115, 115, 115, 115, 115, 1161, 983,
+ 115, 1161, 115, 982, 1161, 1161, 115, 978, 1161, 979,
+ 115, 115, 1161, 1161, 115, 115, 115, 115, 994, 992,
+ 115, 985, 115, 115, 115, 115, 1161, 1161, 983, 115,
+ 115, 982, 1161, 1161, 1161, 1161, 115, 115, 115, 1161,
+ 115, 1161, 115, 1161, 1161, 115, 115, 994, 992, 115,
+ 985, 115, 115, 993, 115, 115, 115, 1161, 115, 1161,
+ 115, 115, 1161, 1161, 115, 115, 1161, 1161, 115, 1161,
+ 1161, 1161, 115, 1161, 995, 115, 996, 115, 115, 1161,
+ 1161, 115, 993, 115, 115, 115, 115, 1161, 1161, 115,
+
+ 115, 115, 115, 1161, 997, 1161, 115, 115, 1161, 1161,
+ 115, 115, 995, 115, 996, 1161, 115, 1161, 115, 1161,
+ 115, 115, 115, 115, 1161, 115, 1161, 115, 1161, 115,
+ 1161, 115, 997, 1161, 1161, 1161, 115, 115, 115, 115,
+ 1161, 115, 1161, 115, 115, 1004, 1161, 115, 115, 115,
+ 1161, 115, 115, 1006, 1161, 1161, 115, 1161, 115, 115,
+ 1161, 1161, 115, 1161, 115, 115, 115, 1161, 115, 115,
+ 115, 115, 115, 115, 1004, 115, 1161, 115, 115, 1161,
+ 1161, 1006, 1161, 1161, 1161, 115, 115, 1007, 115, 115,
+ 115, 1161, 115, 115, 1161, 115, 1009, 115, 1161, 115,
+
+ 115, 1161, 1161, 115, 115, 1161, 115, 1161, 115, 115,
+ 1161, 115, 1161, 115, 115, 1007, 1012, 115, 1161, 1161,
+ 1161, 115, 115, 1161, 1161, 1009, 115, 1011, 115, 115,
+ 1161, 1161, 115, 1161, 115, 115, 1161, 115, 115, 115,
+ 115, 115, 1161, 115, 1012, 1020, 115, 1161, 115, 1019,
+ 115, 1161, 115, 1161, 115, 1011, 115, 115, 115, 1161,
+ 115, 115, 1161, 115, 115, 1161, 115, 1161, 115, 115,
+ 115, 115, 1025, 115, 1020, 115, 115, 1019, 1161, 1161,
+ 115, 115, 115, 1161, 115, 1161, 115, 115, 115, 115,
+ 115, 1161, 1161, 115, 1161, 115, 1161, 115, 115, 115,
+
+ 1025, 115, 115, 115, 115, 1026, 115, 1161, 115, 115,
+ 1161, 1161, 115, 115, 1161, 115, 1161, 1161, 115, 1029,
+ 115, 1161, 115, 115, 115, 1161, 1030, 115, 1161, 115,
+ 115, 115, 1161, 115, 1026, 115, 1161, 1161, 115, 1161,
+ 115, 115, 1161, 115, 115, 115, 115, 1029, 115, 115,
+ 115, 115, 1161, 115, 1161, 1030, 1038, 1161, 115, 1037,
+ 115, 115, 1161, 115, 115, 1161, 115, 115, 1161, 1161,
+ 115, 115, 115, 115, 115, 115, 1161, 1161, 115, 115,
+ 115, 1161, 1161, 1161, 1038, 1161, 1039, 1037, 115, 1161,
+ 115, 115, 115, 115, 1161, 115, 115, 115, 115, 1040,
+
+ 115, 115, 115, 1161, 115, 115, 1044, 1161, 115, 115,
+ 1161, 1161, 115, 1161, 1039, 1161, 115, 1161, 1161, 115,
+ 115, 1161, 115, 115, 1161, 115, 115, 115, 1040, 115,
+ 1161, 115, 1161, 115, 115, 1044, 1161, 115, 115, 115,
+ 115, 1047, 115, 1161, 115, 1161, 1161, 115, 1161, 115,
+ 1161, 115, 1161, 115, 115, 1161, 115, 1048, 115, 1161,
+ 115, 1161, 1161, 1161, 115, 115, 115, 115, 1161, 115,
+ 1047, 115, 115, 1161, 1161, 1054, 115, 1161, 1161, 115,
+ 1059, 115, 115, 115, 115, 115, 1048, 115, 1161, 115,
+ 115, 1161, 1161, 115, 115, 115, 1161, 115, 115, 1161,
+
+ 115, 1161, 115, 1054, 115, 115, 1161, 115, 1062, 1059,
+ 115, 115, 1161, 1161, 115, 1161, 115, 1161, 1161, 115,
+ 115, 1161, 115, 115, 115, 115, 115, 115, 1063, 115,
+ 1161, 115, 115, 1161, 1161, 1067, 1062, 1161, 1161, 115,
+ 1161, 115, 1161, 115, 115, 1161, 1161, 115, 1161, 115,
+ 1161, 115, 115, 115, 115, 1068, 115, 1063, 115, 115,
+ 1161, 1161, 1161, 1067, 115, 1161, 115, 115, 115, 115,
+ 115, 115, 1069, 115, 1073, 115, 115, 1161, 115, 1161,
+ 1161, 115, 1161, 1161, 1068, 1161, 1161, 115, 115, 115,
+ 115, 115, 1161, 115, 115, 115, 115, 115, 1161, 115,
+
+ 1161, 1069, 115, 1073, 115, 1161, 115, 115, 1161, 115,
+ 1080, 1161, 115, 1161, 1161, 115, 115, 115, 1161, 115,
+ 115, 115, 1161, 115, 115, 115, 115, 1087, 115, 1161,
+ 1161, 1161, 1161, 1161, 1088, 115, 115, 115, 1080, 115,
+ 1161, 115, 115, 1161, 115, 115, 115, 1161, 115, 1161,
+ 115, 115, 115, 115, 115, 1161, 1087, 115, 115, 1091,
+ 1161, 1161, 1088, 115, 1161, 115, 1161, 115, 115, 115,
+ 115, 115, 1095, 115, 115, 115, 115, 115, 1161, 1161,
+ 115, 1161, 115, 1161, 1161, 1161, 115, 1091, 115, 1161,
+ 115, 115, 1161, 115, 115, 115, 115, 1161, 115, 115,
+
+ 115, 1095, 1106, 115, 1161, 115, 1161, 1161, 1161, 1161,
+ 115, 1161, 1161, 115, 1105, 1161, 115, 115, 115, 1161,
+ 115, 1108, 115, 115, 115, 115, 1161, 1161, 115, 115,
+ 1161, 1106, 1161, 1161, 1161, 1161, 115, 1161, 115, 1161,
+ 115, 115, 1105, 115, 1112, 115, 115, 115, 1161, 115,
+ 1108, 115, 115, 115, 115, 1161, 1161, 1161, 115, 115,
+ 1161, 1122, 1161, 1161, 115, 1161, 115, 1161, 115, 115,
+ 1161, 115, 1112, 1161, 115, 1161, 115, 1161, 115, 1161,
+ 1161, 115, 1161, 115, 1161, 1161, 1161, 115, 1161, 1122,
+ 1161, 1161, 1161, 1161, 115, 1161, 115, 1124, 948, 1124,
+
+ 1161, 1161, 1125, 1125, 1161, 1125, 1161, 1161, 1161, 1125,
+ 1125, 1161, 1161, 1125, 1161, 1161, 1125, 1125, 1125, 1125,
+ 1125, 1125, 1125, 1125, 1125, 115, 115, 1161, 1161, 1161,
+ 115, 115, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1133,
+ 1161, 1161, 1128, 1161, 115, 115, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 115, 115, 1161, 1161, 1161, 115,
+ 115, 1161, 1161, 1161, 1161, 1161, 1161, 1133, 1161, 1161,
+ 1128, 1161, 115, 115, 947, 948, 947, 1161, 1161, 1134,
+ 1134, 1161, 1135, 1161, 115, 950, 1134, 1134, 1137, 115,
+ 1134, 1161, 1161, 1134, 1134, 1134, 1134, 1134, 1134, 1134,
+
+ 1134, 1134, 1161, 115, 115, 115, 1161, 1161, 1161, 115,
+ 115, 1161, 1161, 115, 1161, 1161, 1161, 1137, 115, 1161,
+ 1161, 1161, 1161, 115, 115, 1161, 1161, 1161, 1161, 1161,
+ 1161, 115, 1161, 115, 115, 1161, 1161, 1161, 115, 115,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 115, 115, 64, 64, 64, 64, 64, 64, 64,
+ 64, 64, 64, 64, 64, 65, 65, 65, 65, 65,
+ 65, 65, 65, 65, 65, 65, 65, 81, 81, 1161,
+ 81, 81, 81, 81, 81, 81, 81, 81, 81, 84,
+ 84, 1161, 84, 84, 84, 84, 84, 84, 84, 84,
+
+ 84, 88, 88, 88, 88, 88, 88, 88, 88, 88,
+ 88, 88, 88, 92, 92, 92, 92, 92, 92, 92,
+ 92, 92, 92, 92, 92, 111, 111, 115, 115, 115,
+ 115, 115, 115, 115, 115, 187, 187, 187, 187, 187,
+ 187, 187, 187, 187, 187, 187, 187, 202, 202, 202,
+ 202, 202, 202, 202, 202, 202, 202, 202, 202, 209,
+ 209, 209, 209, 209, 209, 1161, 209, 209, 209, 1161,
+ 209, 232, 232, 232, 232, 232, 232, 232, 232, 232,
+ 232, 232, 232, 101, 1161, 1161, 101, 252, 252, 252,
+ 1161, 1161, 252, 1161, 252, 252, 1161, 252, 252, 343,
+
+ 343, 343, 343, 343, 343, 343, 343, 343, 343, 343,
+ 343, 358, 358, 1161, 358, 358, 358, 358, 358, 358,
+ 358, 358, 358, 371, 371, 371, 371, 371, 371, 1161,
+ 371, 371, 371, 1161, 371, 374, 374, 374, 374, 374,
+ 374, 374, 374, 374, 374, 374, 374, 379, 379, 379,
+ 379, 379, 379, 379, 379, 379, 379, 379, 379, 422,
+ 1161, 1161, 422, 276, 1161, 1161, 1161, 276, 1161, 1161,
+ 1161, 1161, 1161, 276, 558, 558, 558, 558, 558, 558,
+ 558, 558, 558, 558, 558, 558, 718, 718, 1161, 718,
+ 718, 718, 718, 718, 718, 718, 718, 718, 721, 721,
+
+ 1161, 721, 721, 721, 721, 721, 721, 721, 721, 721,
+ 723, 723, 1161, 723, 723, 723, 723, 723, 723, 723,
+ 723, 723, 88, 88, 88, 88, 88, 88, 88, 88,
+ 88, 88, 88, 88, 726, 726, 726, 726, 726, 726,
+ 726, 726, 726, 726, 726, 726, 92, 92, 92, 92,
+ 92, 92, 92, 92, 92, 92, 92, 92, 728, 728,
+ 728, 728, 728, 728, 728, 728, 728, 728, 728, 728,
+ 812, 812, 812, 812, 812, 812, 812, 812, 812, 812,
+ 812, 812, 814, 814, 1161, 814, 814, 814, 814, 814,
+ 814, 814, 814, 814, 823, 823, 823, 823, 823, 823,
+
+ 823, 823, 823, 823, 823, 823, 825, 825, 825, 825,
+ 825, 825, 825, 825, 825, 825, 825, 825, 831, 831,
+ 1161, 831, 831, 831, 831, 831, 831, 831, 831, 831,
+ 834, 834, 1161, 834, 834, 834, 834, 834, 834, 834,
+ 834, 834, 81, 81, 1161, 81, 81, 81, 81, 81,
+ 81, 81, 81, 81, 835, 835, 1161, 835, 835, 835,
+ 835, 835, 835, 835, 835, 835, 84, 84, 1161, 84,
+ 84, 84, 84, 84, 84, 84, 84, 84, 837, 837,
+ 837, 837, 837, 837, 837, 837, 837, 837, 837, 837,
+ 88, 88, 88, 88, 88, 88, 88, 88, 88, 88,
+
+ 88, 88, 838, 838, 838, 838, 838, 838, 838, 838,
+ 838, 838, 838, 838, 92, 92, 92, 92, 92, 92,
+ 92, 92, 92, 92, 92, 92, 187, 187, 187, 187,
+ 187, 187, 187, 187, 187, 187, 187, 187, 904, 904,
+ 904, 904, 904, 904, 904, 904, 904, 904, 904, 904,
+ 358, 358, 1161, 358, 358, 358, 358, 358, 358, 358,
+ 358, 358, 814, 814, 1161, 814, 814, 814, 814, 814,
+ 814, 814, 814, 814, 202, 202, 202, 202, 202, 202,
+ 202, 202, 202, 202, 202, 202, 912, 912, 912, 912,
+ 912, 912, 912, 912, 912, 912, 912, 912, 374, 374,
+
+ 374, 374, 374, 374, 374, 374, 374, 374, 374, 374,
+ 379, 379, 379, 379, 379, 379, 379, 379, 379, 379,
+ 379, 379, 825, 825, 825, 825, 825, 825, 825, 825,
+ 825, 825, 825, 825, 946, 946, 946, 946, 946, 946,
+ 946, 946, 946, 946, 946, 946, 999, 999, 999, 999,
+ 999, 999, 999, 999, 999, 999, 999, 999, 13, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161
+ } ;
+
+static yyconst flex_int16_t yy_chk[9249] =
+ { 0,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 2,
+ 2, 2, 2, 10, 8, 8, 8, 8, 15, 15,
+
+ 15, 68, 1129, 14, 10, 1119, 68, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 14, 16, 16,
+ 16, 54, 54, 54, 2, 2, 18, 10, 2, 19,
+ 2, 8, 14, 17, 17, 17, 15, 20, 21, 1096,
+ 18, 2, 2, 176, 22, 14, 1084, 25, 26, 176,
+ 15, 20, 21, 2, 2, 18, 10, 2, 75, 2,
+ 8, 25, 42, 19, 69, 15, 20, 21, 18, 2,
+ 2, 17, 24, 27, 26, 23, 25, 19, 15, 20,
+ 21, 22, 23, 23, 29, 17, 75, 27, 26, 25,
+ 1045, 42, 19, 24, 959, 22, 30, 339, 74, 339,
+
+ 17, 82, 27, 26, 340, 19, 340, 24, 83, 69,
+ 22, 29, 23, 17, 31, 27, 26, 32, 30, 34,
+ 41, 178, 24, 22, 916, 29, 23, 74, 31, 912,
+ 82, 32, 30, 34, 41, 24, 83, 69, 49, 685,
+ 29, 23, 49, 31, 905, 685, 32, 30, 34, 41,
+ 178, 207, 33, 29, 23, 28, 31, 28, 33, 32,
+ 30, 34, 41, 76, 76, 76, 242, 49, 67, 67,
+ 67, 49, 33, 28, 28, 28, 28, 28, 28, 28,
+ 28, 28, 28, 86, 43, 63, 207, 33, 28, 43,
+ 44, 350, 28, 28, 28, 242, 43, 43, 904, 28,
+
+ 33, 28, 28, 63, 44, 67, 91, 28, 77, 77,
+ 77, 28, 86, 43, 63, 207, 837, 28, 43, 44,
+ 350, 28, 28, 28, 43, 43, 87, 28, 360, 28,
+ 28, 63, 44, 835, 67, 28, 78, 78, 78, 28,
+ 35, 86, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 38, 40, 830, 91, 38, 360, 35, 35,
+ 38, 40, 35, 903, 40, 102, 38, 40, 35, 103,
+ 38, 107, 87, 40, 90, 35, 35, 79, 79, 79,
+ 825, 38, 40, 91, 342, 38, 342, 35, 35, 38,
+ 40, 35, 40, 102, 38, 40, 35, 103, 38, 107,
+
+ 87, 40, 108, 35, 35, 36, 90, 36, 36, 36,
+ 36, 36, 36, 36, 36, 36, 36, 179, 37, 359,
+ 39, 359, 36, 903, 823, 37, 45, 36, 822, 37,
+ 108, 39, 37, 39, 45, 90, 39, 39, 46, 205,
+ 45, 36, 37, 39, 812, 179, 46, 37, 393, 39,
+ 180, 36, 46, 182, 37, 45, 36, 37, 46, 39,
+ 37, 39, 48, 45, 39, 39, 51, 46, 45, 36,
+ 37, 39, 47, 51, 811, 46, 48, 393, 180, 48,
+ 46, 182, 48, 51, 205, 47, 46, 47, 104, 50,
+ 220, 48, 47, 50, 529, 51, 529, 50, 396, 52,
+
+ 450, 47, 51, 104, 48, 50, 52, 48, 50, 50,
+ 48, 51, 205, 47, 532, 47, 52, 104, 50, 804,
+ 47, 220, 50, 80, 80, 80, 50, 396, 52, 450,
+ 530, 104, 530, 50, 92, 52, 50, 50, 55, 55,
+ 55, 92, 92, 532, 52, 53, 53, 53, 53, 220,
+ 56, 223, 531, 53, 531, 56, 55, 55, 55, 55,
+ 55, 55, 55, 55, 55, 55, 184, 184, 184, 94,
+ 70, 70, 70, 71, 71, 71, 94, 94, 60, 223,
+ 53, 53, 70, 53, 53, 71, 53, 56, 726, 60,
+ 106, 191, 60, 686, 93, 93, 93, 53, 53, 686,
+
+ 106, 56, 93, 93, 181, 70, 725, 60, 71, 53,
+ 53, 181, 53, 53, 723, 53, 56, 60, 722, 106,
+ 60, 72, 72, 72, 910, 53, 53, 214, 106, 56,
+ 57, 58, 181, 72, 70, 96, 57, 71, 222, 181,
+ 191, 716, 96, 96, 57, 189, 57, 57, 57, 57,
+ 57, 57, 57, 57, 57, 57, 59, 222, 58, 72,
+ 59, 208, 208, 208, 59, 58, 57, 96, 191, 58,
+ 59, 190, 58, 72, 59, 714, 214, 189, 61, 206,
+ 57, 706, 58, 61, 910, 59, 222, 58, 72, 59,
+ 61, 61, 62, 59, 58, 57, 96, 58, 59, 62,
+
+ 58, 72, 59, 190, 214, 224, 189, 61, 57, 62,
+ 58, 206, 61, 210, 210, 210, 62, 689, 61, 61,
+ 664, 62, 225, 225, 225, 585, 580, 232, 62, 578,
+ 558, 235, 190, 224, 232, 232, 554, 62, 235, 235,
+ 206, 372, 372, 372, 62, 73, 73, 73, 73, 73,
+ 73, 73, 73, 73, 73, 73, 73, 73, 73, 73,
+ 73, 73, 73, 73, 73, 73, 73, 73, 73, 73,
+ 73, 73, 73, 73, 73, 73, 73, 73, 73, 73,
+ 73, 73, 73, 73, 73, 73, 73, 73, 73, 73,
+ 73, 73, 73, 73, 73, 73, 73, 73, 73, 73,
+
+ 73, 73, 73, 73, 73, 73, 73, 73, 73, 73,
+ 73, 73, 73, 73, 73, 73, 73, 73, 73, 73,
+ 73, 73, 73, 73, 73, 73, 73, 73, 73, 73,
+ 73, 73, 73, 73, 97, 101, 101, 105, 204, 204,
+ 204, 97, 97, 226, 538, 227, 213, 675, 101, 675,
+ 534, 111, 105, 111, 111, 111, 111, 111, 111, 111,
+ 111, 111, 111, 421, 101, 101, 105, 375, 375, 375,
+ 419, 226, 173, 227, 173, 204, 101, 114, 213, 534,
+ 105, 219, 412, 97, 113, 113, 113, 113, 113, 113,
+ 113, 113, 113, 113, 114, 228, 115, 118, 219, 114,
+
+ 116, 115, 118, 125, 204, 116, 410, 213, 125, 231,
+ 173, 97, 100, 114, 100, 115, 118, 229, 116, 116,
+ 386, 221, 125, 114, 173, 115, 118, 219, 114, 116,
+ 115, 118, 125, 379, 116, 228, 249, 125, 230, 173,
+ 374, 114, 251, 115, 118, 100, 116, 116, 117, 100,
+ 125, 100, 173, 117, 243, 221, 100, 276, 100, 100,
+ 248, 231, 117, 228, 249, 401, 229, 117, 100, 294,
+ 251, 294, 401, 401, 100, 371, 343, 117, 100, 294,
+ 100, 230, 117, 221, 100, 276, 100, 100, 535, 231,
+ 117, 250, 243, 248, 229, 117, 100, 110, 110, 110,
+
+ 110, 110, 110, 110, 110, 110, 110, 119, 121, 230,
+ 913, 247, 119, 121, 120, 110, 110, 535, 119, 120,
+ 243, 248, 120, 246, 400, 121, 119, 121, 110, 245,
+ 233, 233, 233, 120, 341, 277, 119, 121, 233, 233,
+ 344, 119, 121, 120, 110, 110, 119, 122, 120, 122,
+ 244, 120, 122, 121, 119, 121, 110, 177, 123, 218,
+ 400, 120, 341, 123, 212, 345, 122, 346, 344, 354,
+ 913, 177, 277, 347, 209, 123, 122, 123, 122, 124,
+ 202, 122, 348, 126, 124, 187, 177, 123, 126, 400,
+ 124, 349, 123, 345, 122, 346, 183, 126, 124, 177,
+
+ 277, 347, 126, 123, 676, 123, 676, 354, 124, 127,
+ 348, 175, 126, 124, 127, 174, 237, 126, 124, 349,
+ 89, 127, 127, 237, 237, 126, 124, 127, 127, 128,
+ 126, 128, 129, 389, 128, 130, 354, 129, 127, 292,
+ 130, 292, 361, 127, 234, 234, 234, 130, 128, 127,
+ 127, 129, 234, 234, 130, 127, 127, 536, 128, 237,
+ 128, 129, 88, 128, 130, 388, 129, 84, 389, 130,
+ 361, 380, 380, 380, 356, 130, 128, 65, 13, 129,
+ 378, 238, 130, 131, 355, 131, 536, 237, 238, 238,
+ 369, 292, 1051, 388, 390, 133, 389, 392, 9, 131,
+
+ 133, 131, 131, 131, 131, 131, 131, 131, 131, 131,
+ 131, 132, 1081, 133, 133, 134, 132, 7, 134, 292,
+ 134, 388, 132, 398, 133, 392, 356, 355, 369, 133,
+ 132, 390, 378, 238, 134, 677, 131, 677, 131, 1130,
+ 132, 133, 133, 381, 134, 132, 136, 134, 135, 134,
+ 132, 136, 1051, 135, 356, 355, 398, 369, 132, 390,
+ 378, 238, 134, 136, 131, 136, 131, 135, 135, 139,
+ 377, 137, 1081, 138, 139, 136, 137, 135, 138, 137,
+ 136, 381, 135, 139, 138, 398, 137, 395, 139, 0,
+ 137, 136, 138, 136, 418, 135, 135, 397, 139, 1130,
+
+ 137, 382, 138, 139, 140, 137, 475, 138, 137, 140,
+ 381, 139, 138, 377, 137, 395, 139, 142, 137, 142,
+ 138, 140, 418, 140, 141, 399, 143, 144, 143, 141,
+ 1131, 537, 144, 140, 475, 0, 143, 141, 140, 391,
+ 533, 377, 144, 141, 397, 382, 144, 0, 543, 140,
+ 142, 140, 466, 141, 466, 142, 144, 146, 141, 143,
+ 537, 144, 146, 146, 143, 141, 0, 391, 533, 142,
+ 144, 141, 397, 382, 144, 399, 146, 0, 143, 142,
+ 145, 0, 145, 466, 142, 145, 146, 680, 143, 680,
+ 1131, 146, 146, 143, 145, 391, 145, 142, 543, 145,
+
+ 147, 0, 148, 399, 146, 147, 143, 148, 557, 145,
+ 484, 145, 484, 546, 145, 148, 394, 394, 394, 147,
+ 484, 148, 145, 147, 145, 149, 543, 145, 149, 147,
+ 149, 148, 572, 150, 147, 1148, 148, 151, 150, 0,
+ 0, 546, 151, 148, 149, 150, 547, 147, 0, 148,
+ 151, 147, 150, 557, 149, 0, 151, 149, 0, 149,
+ 544, 572, 150, 152, 153, 0, 151, 150, 152, 153,
+ 0, 151, 149, 150, 547, 153, 152, 488, 151, 488,
+ 150, 557, 152, 153, 151, 0, 155, 488, 0, 154,
+ 155, 155, 152, 153, 154, 1148, 544, 152, 153, 521,
+
+ 154, 521, 0, 153, 152, 155, 611, 0, 154, 521,
+ 152, 153, 156, 253, 253, 155, 158, 156, 154, 155,
+ 155, 158, 402, 154, 158, 544, 253, 0, 154, 402,
+ 402, 156, 157, 155, 611, 158, 154, 157, 559, 559,
+ 559, 156, 253, 253, 0, 158, 156, 612, 0, 157,
+ 158, 157, 157, 158, 253, 160, 160, 159, 0, 156,
+ 160, 157, 159, 158, 614, 159, 157, 370, 370, 370,
+ 615, 159, 402, 561, 160, 612, 159, 157, 0, 157,
+ 157, 194, 162, 194, 160, 160, 159, 162, 161, 160,
+ 161, 159, 614, 161, 159, 556, 556, 556, 615, 159,
+
+ 402, 162, 160, 162, 159, 0, 161, 161, 370, 542,
+ 161, 162, 575, 163, 194, 564, 162, 161, 163, 161,
+ 164, 555, 161, 561, 163, 164, 164, 563, 194, 162,
+ 0, 162, 163, 164, 161, 161, 556, 370, 161, 164,
+ 165, 575, 163, 194, 568, 165, 692, 163, 692, 164,
+ 617, 561, 163, 562, 164, 164, 194, 165, 542, 165,
+ 163, 164, 564, 166, 403, 556, 682, 164, 166, 165,
+ 555, 403, 403, 577, 165, 569, 563, 166, 617, 568,
+ 166, 0, 166, 167, 167, 165, 542, 165, 167, 562,
+ 564, 697, 166, 697, 682, 167, 569, 166, 555, 744,
+
+ 403, 0, 167, 570, 563, 166, 577, 568, 166, 168,
+ 166, 579, 167, 167, 168, 169, 0, 167, 562, 169,
+ 169, 0, 168, 167, 570, 569, 168, 744, 168, 403,
+ 167, 571, 170, 0, 169, 577, 753, 170, 168, 0,
+ 170, 171, 0, 168, 169, 171, 171, 579, 169, 169,
+ 168, 170, 571, 570, 168, 0, 168, 574, 574, 574,
+ 171, 170, 169, 172, 753, 581, 170, 604, 172, 170,
+ 171, 172, 581, 581, 171, 171, 579, 582, 613, 170,
+ 618, 571, 172, 687, 582, 582, 0, 0, 171, 678,
+ 0, 678, 172, 185, 185, 185, 604, 172, 756, 678,
+
+ 172, 581, 679, 635, 815, 635, 815, 613, 757, 618,
+ 172, 185, 185, 185, 185, 185, 185, 185, 185, 185,
+ 185, 186, 681, 687, 0, 678, 756, 186, 713, 0,
+ 581, 679, 691, 608, 635, 608, 757, 186, 186, 186,
+ 186, 186, 186, 186, 186, 186, 186, 192, 683, 713,
+ 683, 681, 687, 192, 678, 684, 684, 684, 683, 0,
+ 703, 691, 683, 192, 192, 192, 192, 192, 192, 192,
+ 192, 192, 192, 193, 608, 215, 215, 215, 713, 193,
+ 708, 708, 708, 748, 826, 826, 826, 193, 608, 193,
+ 193, 193, 193, 193, 193, 193, 193, 193, 193, 195,
+
+ 703, 196, 197, 608, 195, 749, 196, 197, 215, 0,
+ 195, 616, 748, 196, 196, 688, 608, 195, 195, 196,
+ 196, 197, 215, 832, 832, 832, 704, 616, 195, 703,
+ 196, 197, 707, 195, 749, 196, 197, 215, 195, 198,
+ 616, 196, 196, 0, 198, 195, 195, 196, 196, 197,
+ 215, 688, 702, 198, 702, 616, 200, 0, 198, 201,
+ 199, 200, 199, 201, 201, 199, 702, 755, 198, 758,
+ 0, 200, 707, 198, 199, 200, 199, 704, 201, 199,
+ 688, 198, 759, 807, 0, 200, 198, 0, 201, 199,
+ 200, 199, 201, 201, 199, 216, 755, 0, 758, 200,
+
+ 0, 707, 199, 200, 199, 704, 201, 199, 0, 0,
+ 759, 807, 216, 216, 216, 216, 216, 216, 216, 216,
+ 216, 216, 217, 217, 217, 217, 217, 217, 217, 217,
+ 217, 217, 217, 217, 217, 217, 217, 217, 217, 217,
+ 217, 217, 217, 217, 217, 217, 217, 217, 217, 217,
+ 217, 217, 217, 217, 217, 217, 217, 217, 217, 217,
+ 217, 217, 217, 217, 217, 217, 217, 217, 217, 217,
+ 217, 217, 217, 217, 217, 217, 217, 217, 217, 217,
+ 217, 217, 217, 217, 217, 217, 217, 217, 217, 217,
+ 217, 217, 217, 217, 217, 217, 217, 217, 217, 217,
+
+ 217, 217, 217, 217, 217, 217, 217, 217, 217, 217,
+ 217, 239, 0, 239, 860, 760, 239, 239, 239, 239,
+ 239, 239, 239, 239, 239, 239, 240, 0, 240, 863,
+ 805, 240, 240, 240, 240, 240, 240, 240, 240, 240,
+ 240, 241, 860, 241, 760, 806, 241, 241, 241, 241,
+ 241, 241, 241, 241, 241, 241, 254, 863, 254, 805,
+ 0, 254, 254, 254, 254, 254, 254, 254, 254, 254,
+ 254, 255, 0, 255, 806, 0, 255, 255, 255, 255,
+ 255, 255, 255, 255, 255, 255, 256, 808, 256, 259,
+ 865, 256, 256, 256, 256, 256, 256, 256, 256, 256,
+
+ 256, 257, 257, 257, 257, 257, 257, 257, 257, 257,
+ 257, 0, 259, 769, 260, 769, 808, 259, 865, 260,
+ 257, 258, 258, 258, 258, 258, 258, 258, 258, 258,
+ 258, 259, 260, 260, 261, 813, 901, 262, 901, 261,
+ 258, 259, 262, 260, 769, 261, 259, 727, 260, 257,
+ 908, 262, 908, 261, 727, 727, 262, 263, 705, 259,
+ 260, 260, 263, 261, 813, 693, 262, 693, 261, 258,
+ 263, 262, 0, 261, 0, 693, 263, 264, 266, 262,
+ 265, 261, 264, 266, 262, 265, 263, 803, 266, 803,
+ 264, 263, 0, 0, 705, 803, 264, 266, 263, 265,
+
+ 265, 693, 851, 268, 263, 810, 264, 266, 268, 265,
+ 267, 264, 266, 0, 265, 267, 266, 0, 264, 0,
+ 268, 267, 268, 705, 264, 266, 0, 265, 265, 267,
+ 693, 851, 268, 269, 0, 271, 821, 268, 269, 267,
+ 271, 270, 810, 0, 267, 700, 270, 700, 268, 267,
+ 268, 269, 269, 270, 271, 700, 270, 267, 272, 700,
+ 270, 0, 269, 272, 271, 272, 728, 269, 0, 271,
+ 270, 810, 821, 728, 728, 270, 0, 272, 273, 269,
+ 269, 270, 271, 273, 270, 274, 0, 272, 270, 273,
+ 274, 729, 272, 794, 272, 794, 274, 273, 729, 729,
+
+ 0, 821, 0, 794, 274, 272, 0, 273, 278, 278,
+ 857, 275, 273, 278, 274, 275, 275, 273, 900, 274,
+ 859, 809, 809, 809, 274, 273, 820, 278, 279, 809,
+ 275, 280, 274, 279, 824, 279, 280, 278, 278, 857,
+ 275, 284, 278, 284, 275, 275, 900, 279, 281, 859,
+ 280, 861, 281, 281, 0, 278, 862, 279, 275, 864,
+ 280, 925, 279, 820, 279, 280, 0, 281, 283, 0,
+ 0, 824, 284, 283, 284, 279, 283, 281, 280, 284,
+ 861, 281, 281, 838, 875, 862, 875, 283, 864, 925,
+ 838, 838, 820, 284, 875, 281, 282, 283, 282, 285,
+
+ 824, 894, 283, 284, 285, 283, 286, 899, 284, 422,
+ 422, 286, 839, 902, 893, 283, 893, 285, 285, 839,
+ 839, 284, 422, 0, 893, 286, 0, 282, 285, 282,
+ 894, 911, 282, 285, 282, 286, 899, 282, 422, 422,
+ 286, 282, 902, 0, 282, 285, 285, 282, 282, 289,
+ 422, 282, 287, 286, 289, 288, 287, 287, 282, 288,
+ 288, 282, 934, 282, 937, 884, 282, 884, 289, 282,
+ 0, 287, 282, 0, 288, 282, 282, 926, 289, 282,
+ 911, 287, 290, 289, 288, 287, 287, 290, 288, 288,
+ 291, 934, 291, 937, 290, 291, 289, 929, 293, 287,
+
+ 931, 290, 288, 293, 896, 926, 896, 932, 911, 291,
+ 0, 290, 293, 884, 0, 296, 290, 293, 933, 291,
+ 296, 291, 290, 935, 291, 929, 296, 293, 931, 290,
+ 961, 297, 293, 0, 296, 932, 297, 291, 298, 896,
+ 293, 884, 297, 298, 296, 293, 933, 0, 954, 296,
+ 297, 935, 0, 964, 296, 0, 0, 298, 298, 961,
+ 297, 299, 296, 0, 0, 297, 299, 298, 896, 965,
+ 297, 980, 298, 948, 948, 948, 954, 966, 297, 972,
+ 299, 299, 964, 300, 301, 298, 298, 300, 300, 301,
+ 299, 302, 301, 302, 303, 299, 303, 965, 967, 980,
+
+ 300, 302, 300, 301, 303, 968, 966, 968, 299, 299,
+ 0, 0, 300, 301, 989, 972, 300, 300, 301, 990,
+ 304, 301, 973, 981, 302, 304, 984, 303, 300, 302,
+ 300, 301, 303, 967, 968, 302, 968, 0, 303, 304,
+ 304, 986, 989, 302, 972, 302, 303, 990, 303, 304,
+ 1005, 0, 981, 302, 304, 984, 303, 0, 302, 973,
+ 305, 303, 967, 302, 305, 305, 303, 304, 304, 987,
+ 986, 302, 306, 302, 303, 988, 303, 306, 1005, 305,
+ 307, 308, 1008, 1016, 307, 307, 308, 0, 973, 305,
+ 1010, 306, 308, 305, 305, 0, 0, 309, 987, 307,
+
+ 308, 306, 309, 1015, 988, 0, 306, 305, 0, 307,
+ 308, 1008, 1013, 307, 307, 308, 309, 310, 1010, 306,
+ 308, 309, 310, 998, 998, 998, 309, 307, 308, 1016,
+ 310, 309, 1015, 311, 312, 0, 310, 313, 311, 312,
+ 1013, 311, 313, 852, 309, 852, 310, 1017, 0, 309,
+ 0, 310, 311, 312, 314, 0, 313, 1016, 310, 314,
+ 1018, 0, 311, 312, 310, 1028, 313, 311, 312, 1027,
+ 311, 313, 314, 314, 315, 0, 1017, 316, 852, 315,
+ 311, 312, 316, 314, 313, 1022, 1032, 315, 314, 1018,
+ 316, 852, 1034, 315, 1028, 0, 316, 1027, 316, 1036,
+
+ 314, 314, 1021, 315, 317, 1023, 316, 852, 315, 317,
+ 317, 316, 0, 0, 1032, 315, 1043, 1022, 316, 852,
+ 1034, 315, 1049, 317, 316, 318, 316, 1036, 0, 319,
+ 318, 0, 319, 317, 319, 0, 318, 320, 317, 317,
+ 319, 1023, 320, 0, 318, 1043, 1022, 1021, 319, 1046,
+ 1049, 317, 0, 1024, 318, 1053, 320, 320, 319, 318,
+ 321, 319, 322, 319, 318, 321, 320, 322, 319, 323,
+ 1023, 320, 318, 1052, 323, 1021, 319, 323, 1046, 321,
+ 321, 322, 322, 1053, 320, 320, 0, 0, 323, 321,
+ 0, 322, 326, 1024, 321, 324, 322, 326, 323, 324,
+
+ 324, 0, 1052, 323, 1060, 326, 323, 321, 321, 322,
+ 322, 326, 328, 0, 324, 325, 323, 328, 327, 325,
+ 325, 326, 1024, 327, 324, 327, 326, 1061, 324, 324,
+ 1058, 328, 1060, 326, 325, 0, 1055, 327, 329, 326,
+ 0, 328, 324, 329, 325, 330, 328, 327, 325, 325,
+ 330, 1057, 327, 332, 327, 332, 1061, 329, 0, 328,
+ 330, 331, 325, 332, 330, 327, 331, 329, 1041, 1041,
+ 1041, 1055, 329, 0, 330, 1058, 1064, 0, 331, 330,
+ 331, 1066, 333, 1056, 1057, 329, 332, 333, 330, 333,
+ 331, 332, 330, 334, 1072, 331, 0, 1074, 334, 334,
+
+ 1055, 333, 336, 1058, 1064, 332, 331, 336, 331, 1076,
+ 1066, 333, 334, 1057, 336, 332, 333, 1056, 333, 335,
+ 332, 336, 334, 1072, 335, 1074, 1078, 334, 334, 333,
+ 0, 336, 335, 332, 0, 0, 336, 1076, 335, 337,
+ 334, 1085, 336, 0, 337, 338, 1056, 1094, 335, 336,
+ 338, 0, 974, 335, 1078, 1086, 337, 1090, 337, 1083,
+ 335, 876, 876, 876, 338, 0, 335, 0, 337, 876,
+ 1085, 1082, 876, 337, 338, 351, 1094, 351, 0, 338,
+ 946, 946, 946, 1086, 337, 1090, 337, 974, 946, 974,
+ 0, 946, 338, 351, 351, 351, 351, 351, 351, 351,
+
+ 351, 351, 351, 352, 947, 947, 947, 1082, 0, 352,
+ 0, 1083, 947, 0, 1077, 947, 974, 0, 974, 352,
+ 352, 352, 352, 352, 352, 352, 352, 352, 352, 353,
+ 949, 949, 949, 0, 0, 353, 1082, 1098, 949, 1083,
+ 0, 949, 1070, 1070, 1070, 353, 353, 353, 353, 353,
+ 353, 353, 353, 353, 353, 357, 1092, 1092, 1092, 1077,
+ 1099, 357, 362, 363, 0, 364, 362, 362, 363, 357,
+ 364, 357, 357, 357, 357, 357, 357, 357, 357, 357,
+ 357, 362, 363, 1098, 364, 365, 365, 1077, 1099, 1103,
+ 365, 362, 363, 368, 364, 362, 362, 363, 1104, 364,
+
+ 0, 366, 0, 0, 365, 366, 366, 0, 0, 362,
+ 363, 1098, 364, 1111, 365, 365, 1107, 1103, 366, 365,
+ 366, 367, 0, 433, 368, 367, 367, 1104, 433, 368,
+ 366, 1100, 365, 0, 366, 366, 950, 950, 950, 1113,
+ 367, 1111, 433, 368, 950, 1107, 366, 950, 366, 0,
+ 367, 1116, 433, 368, 367, 367, 383, 433, 368, 0,
+ 0, 999, 999, 999, 0, 0, 1100, 1113, 367, 999,
+ 433, 368, 999, 383, 383, 383, 383, 383, 383, 383,
+ 383, 383, 383, 384, 0, 1000, 1000, 1000, 1101, 1101,
+ 1101, 0, 383, 1000, 1121, 1100, 1000, 1116, 1127, 0,
+
+ 384, 384, 384, 384, 384, 384, 384, 384, 384, 384,
+ 387, 0, 1001, 1001, 1001, 1117, 1117, 1117, 1136, 384,
+ 1001, 383, 1121, 1001, 0, 1116, 1127, 387, 387, 387,
+ 387, 387, 387, 387, 387, 387, 387, 404, 404, 404,
+ 404, 404, 404, 404, 404, 404, 404, 1136, 384, 405,
+ 405, 405, 405, 405, 405, 405, 405, 405, 405, 406,
+ 406, 406, 406, 406, 406, 406, 406, 406, 406, 407,
+ 407, 407, 407, 407, 407, 407, 407, 407, 407, 408,
+ 408, 408, 408, 408, 408, 408, 408, 408, 408, 409,
+ 409, 409, 409, 409, 409, 409, 409, 409, 409, 423,
+
+ 423, 423, 423, 423, 423, 423, 423, 423, 423, 424,
+ 424, 424, 424, 424, 424, 424, 424, 424, 424, 425,
+ 425, 425, 425, 425, 425, 425, 425, 425, 425, 426,
+ 426, 426, 426, 426, 426, 426, 426, 426, 426, 427,
+ 427, 427, 427, 427, 427, 427, 427, 427, 427, 428,
+ 428, 428, 428, 428, 428, 428, 428, 428, 428, 429,
+ 1102, 429, 0, 0, 429, 429, 429, 429, 429, 429,
+ 429, 429, 429, 429, 430, 430, 430, 430, 430, 430,
+ 430, 430, 430, 430, 0, 436, 0, 434, 0, 431,
+ 436, 431, 434, 430, 431, 431, 431, 431, 431, 431,
+
+ 431, 431, 431, 431, 436, 434, 434, 435, 437, 435,
+ 1144, 1102, 435, 437, 436, 0, 434, 1132, 1147, 436,
+ 0, 434, 430, 0, 438, 0, 435, 437, 438, 438,
+ 439, 0, 436, 434, 434, 439, 435, 437, 435, 1102,
+ 0, 435, 437, 438, 0, 1132, 440, 1140, 439, 439,
+ 1147, 440, 0, 438, 435, 437, 1144, 438, 438, 439,
+ 0, 0, 441, 0, 439, 440, 1114, 441, 442, 443,
+ 0, 438, 442, 442, 443, 440, 439, 439, 1139, 1147,
+ 440, 441, 0, 443, 1144, 446, 1146, 442, 443, 444,
+ 446, 441, 1140, 440, 444, 1143, 441, 442, 443, 1156,
+
+ 444, 442, 442, 443, 446, 445, 0, 1149, 444, 441,
+ 445, 443, 0, 445, 446, 442, 443, 1114, 444, 446,
+ 1140, 447, 448, 444, 445, 447, 447, 448, 444, 1139,
+ 449, 1156, 446, 448, 445, 449, 444, 1146, 0, 445,
+ 447, 448, 445, 449, 1143, 1114, 1124, 1124, 1124, 449,
+ 447, 448, 445, 0, 447, 447, 448, 1139, 1149, 449,
+ 1156, 448, 451, 0, 449, 1146, 1145, 451, 447, 448,
+ 452, 449, 1143, 451, 453, 452, 1152, 449, 452, 453,
+ 0, 451, 0, 0, 1150, 454, 1149, 454, 0, 452,
+ 0, 451, 453, 453, 0, 0, 451, 0, 0, 452,
+
+ 0, 451, 1145, 453, 452, 0, 0, 452, 453, 451,
+ 458, 1151, 1151, 1151, 457, 458, 0, 452, 454, 457,
+ 453, 453, 0, 454, 0, 1152, 454, 0, 457, 458,
+ 458, 1145, 0, 457, 0, 1150, 0, 454, 0, 458,
+ 454, 459, 0, 457, 458, 460, 459, 454, 457, 0,
+ 460, 0, 454, 1152, 1155, 454, 457, 458, 458, 460,
+ 459, 457, 468, 1150, 460, 454, 0, 468, 454, 455,
+ 459, 455, 0, 0, 460, 459, 1153, 1153, 1153, 460,
+ 0, 468, 0, 0, 461, 0, 0, 460, 459, 461,
+ 1155, 468, 460, 1158, 1158, 1158, 468, 1159, 1159, 1159,
+
+ 455, 461, 0, 461, 0, 455, 463, 455, 0, 468,
+ 455, 463, 1157, 461, 455, 0, 0, 455, 461, 1155,
+ 455, 455, 0, 0, 455, 463, 0, 0, 0, 461,
+ 463, 461, 0, 0, 455, 463, 455, 0, 472, 455,
+ 463, 0, 455, 472, 0, 455, 462, 0, 455, 455,
+ 462, 462, 455, 463, 464, 465, 0, 472, 463, 464,
+ 465, 464, 0, 1157, 0, 462, 462, 472, 0, 0,
+ 0, 0, 472, 464, 465, 462, 465, 0, 0, 462,
+ 462, 0, 0, 464, 465, 472, 0, 0, 464, 465,
+ 464, 1157, 0, 462, 462, 0, 0, 0, 0, 0,
+
+ 0, 464, 465, 0, 465, 469, 469, 469, 469, 469,
+ 469, 469, 469, 469, 469, 469, 0, 469, 469, 469,
+ 469, 469, 469, 469, 469, 469, 469, 469, 469, 469,
+ 469, 469, 469, 469, 469, 469, 469, 469, 469, 469,
+ 469, 469, 469, 469, 469, 469, 469, 469, 469, 469,
+ 469, 469, 469, 469, 469, 469, 469, 469, 469, 469,
+ 469, 469, 469, 469, 469, 469, 469, 469, 469, 469,
+ 469, 469, 469, 469, 469, 469, 469, 469, 469, 469,
+ 469, 469, 469, 469, 469, 469, 469, 469, 469, 469,
+ 469, 469, 469, 469, 470, 0, 471, 473, 471, 470,
+
+ 0, 0, 473, 474, 1002, 1002, 1002, 0, 474, 0,
+ 0, 470, 1002, 470, 0, 1002, 473, 0, 0, 0,
+ 0, 0, 474, 470, 0, 0, 473, 471, 470, 471,
+ 476, 473, 474, 0, 471, 476, 0, 474, 477, 470,
+ 0, 470, 0, 477, 473, 0, 477, 0, 471, 476,
+ 474, 0, 0, 0, 0, 0, 0, 477, 471, 476,
+ 478, 0, 0, 471, 476, 478, 0, 477, 479, 0,
+ 0, 0, 477, 479, 0, 477, 471, 476, 0, 478,
+ 478, 0, 0, 0, 0, 477, 0, 479, 0, 478,
+ 480, 0, 0, 0, 478, 480, 0, 479, 480, 481,
+
+ 0, 0, 479, 0, 481, 481, 0, 478, 478, 480,
+ 0, 0, 481, 0, 0, 479, 0, 0, 481, 480,
+ 0, 1003, 1003, 1003, 480, 0, 0, 480, 481, 1003,
+ 482, 487, 1003, 481, 481, 482, 487, 480, 482, 483,
+ 481, 483, 486, 0, 483, 0, 481, 486, 0, 482,
+ 487, 0, 0, 0, 0, 0, 486, 0, 483, 482,
+ 487, 486, 0, 0, 482, 487, 0, 482, 483, 490,
+ 483, 486, 0, 483, 490, 491, 486, 482, 487, 0,
+ 491, 0, 0, 490, 486, 0, 483, 0, 490, 486,
+ 0, 492, 0, 0, 491, 493, 492, 0, 490, 0,
+
+ 493, 0, 492, 490, 491, 0, 493, 494, 0, 491,
+ 492, 490, 494, 0, 493, 0, 490, 0, 495, 0,
+ 492, 0, 491, 495, 493, 492, 494, 496, 0, 493,
+ 492, 0, 496, 0, 493, 496, 494, 495, 492, 497,
+ 0, 494, 493, 498, 497, 0, 496, 495, 498, 0,
+ 502, 0, 495, 0, 494, 502, 496, 0, 497, 0,
+ 0, 496, 498, 0, 496, 495, 499, 0, 497, 502,
+ 500, 499, 498, 497, 496, 500, 0, 498, 0, 502,
+ 499, 0, 500, 0, 502, 499, 497, 501, 0, 500,
+ 498, 501, 501, 503, 0, 499, 504, 502, 503, 500,
+
+ 499, 504, 0, 0, 500, 0, 501, 0, 499, 0,
+ 500, 0, 503, 499, 0, 504, 501, 500, 505, 507,
+ 501, 501, 503, 505, 507, 504, 0, 503, 0, 508,
+ 504, 1042, 1042, 1042, 501, 505, 0, 505, 507, 1042,
+ 503, 506, 1042, 504, 0, 0, 506, 505, 507, 506,
+ 508, 0, 505, 507, 0, 508, 0, 509, 0, 0,
+ 506, 0, 509, 505, 0, 505, 507, 0, 0, 508,
+ 506, 0, 0, 0, 509, 506, 509, 0, 506, 508,
+ 0, 0, 510, 0, 508, 0, 509, 510, 506, 511,
+ 512, 509, 0, 510, 511, 512, 0, 508, 0, 0,
+
+ 0, 510, 509, 512, 509, 0, 511, 0, 511, 512,
+ 0, 510, 0, 0, 0, 0, 510, 0, 511, 512,
+ 513, 510, 515, 511, 512, 513, 0, 515, 514, 510,
+ 514, 512, 0, 514, 511, 0, 511, 512, 517, 513,
+ 0, 515, 0, 0, 0, 516, 0, 514, 0, 513,
+ 516, 515, 0, 518, 513, 0, 515, 514, 518, 514,
+ 0, 517, 514, 0, 516, 519, 517, 513, 0, 515,
+ 519, 0, 518, 0, 516, 514, 0, 0, 0, 516,
+ 517, 0, 518, 0, 519, 0, 523, 518, 520, 0,
+ 517, 523, 516, 520, 519, 517, 0, 0, 0, 519,
+
+ 518, 0, 520, 0, 0, 523, 0, 520, 517, 524,
+ 0, 0, 519, 524, 524, 523, 0, 520, 525, 0,
+ 523, 526, 520, 525, 0, 0, 526, 0, 524, 0,
+ 520, 0, 0, 523, 0, 520, 0, 525, 524, 0,
+ 526, 527, 524, 524, 528, 527, 527, 525, 528, 528,
+ 526, 0, 525, 0, 0, 526, 524, 0, 0, 0,
+ 527, 551, 0, 528, 0, 525, 551, 0, 526, 0,
+ 527, 0, 0, 528, 527, 527, 0, 528, 528, 539,
+ 551, 539, 0, 0, 0, 1071, 1071, 1071, 527, 0,
+ 551, 528, 0, 1071, 0, 551, 1071, 539, 539, 539,
+
+ 539, 539, 539, 539, 539, 539, 539, 540, 551, 1093,
+ 1093, 1093, 0, 540, 0, 0, 0, 1093, 0, 0,
+ 1093, 0, 0, 540, 540, 540, 540, 540, 540, 540,
+ 540, 540, 540, 541, 548, 0, 548, 0, 0, 541,
+ 0, 0, 0, 0, 548, 0, 0, 0, 0, 541,
+ 541, 541, 541, 541, 541, 541, 541, 541, 541, 545,
+ 550, 0, 550, 0, 0, 545, 549, 548, 0, 0,
+ 548, 549, 548, 545, 549, 545, 545, 545, 545, 545,
+ 545, 545, 545, 545, 545, 549, 548, 0, 0, 0,
+ 0, 0, 0, 550, 0, 549, 548, 0, 550, 548,
+
+ 549, 548, 552, 549, 0, 592, 0, 552, 552, 592,
+ 592, 0, 550, 549, 548, 552, 0, 0, 553, 552,
+ 553, 552, 550, 0, 592, 0, 0, 550, 553, 0,
+ 0, 552, 553, 0, 592, 0, 552, 552, 592, 592,
+ 550, 565, 0, 552, 0, 0, 0, 552, 0, 552,
+ 0, 553, 592, 565, 0, 565, 553, 0, 565, 565,
+ 565, 565, 565, 565, 565, 565, 565, 565, 0, 566,
+ 553, 1110, 1110, 1110, 0, 0, 0, 0, 0, 1110,
+ 553, 0, 1110, 0, 0, 553, 566, 566, 566, 566,
+ 566, 566, 566, 566, 566, 566, 567, 0, 553, 0,
+
+ 0, 1125, 1125, 1125, 0, 566, 0, 0, 567, 1125,
+ 567, 0, 1125, 567, 567, 567, 567, 567, 567, 567,
+ 567, 567, 567, 588, 588, 588, 588, 588, 588, 588,
+ 588, 588, 588, 0, 566, 589, 589, 589, 589, 589,
+ 589, 589, 589, 589, 589, 590, 590, 590, 590, 590,
+ 590, 590, 590, 590, 590, 591, 591, 591, 591, 591,
+ 591, 591, 591, 591, 591, 593, 0, 0, 595, 0,
+ 593, 0, 0, 595, 1134, 1134, 1134, 0, 1135, 1135,
+ 1135, 0, 1134, 595, 593, 1134, 1135, 595, 0, 1135,
+ 0, 0, 0, 0, 593, 0, 0, 595, 0, 593,
+
+ 0, 0, 595, 0, 0, 0, 0, 0, 0, 0,
+ 0, 595, 593, 594, 594, 595, 594, 594, 594, 594,
+ 594, 594, 594, 594, 594, 594, 594, 594, 594, 594,
+ 594, 594, 594, 594, 594, 594, 594, 594, 594, 594,
+ 594, 594, 594, 594, 594, 594, 594, 594, 594, 594,
+ 594, 594, 594, 594, 594, 594, 594, 594, 594, 594,
+ 594, 594, 594, 594, 594, 594, 594, 594, 594, 594,
+ 594, 594, 594, 594, 594, 594, 594, 594, 594, 594,
+ 594, 594, 594, 594, 594, 594, 594, 594, 594, 594,
+ 594, 594, 594, 594, 594, 594, 594, 594, 594, 594,
+
+ 594, 594, 596, 597, 596, 598, 600, 596, 597, 599,
+ 598, 600, 0, 599, 599, 0, 0, 0, 598, 600,
+ 0, 596, 597, 0, 598, 600, 0, 0, 599, 0,
+ 0, 596, 597, 596, 598, 600, 596, 597, 599, 598,
+ 600, 0, 599, 599, 0, 0, 598, 600, 0, 596,
+ 597, 0, 598, 600, 601, 602, 599, 603, 0, 601,
+ 602, 605, 603, 0, 0, 605, 605, 0, 0, 602,
+ 0, 0, 0, 601, 602, 603, 603, 0, 0, 0,
+ 605, 0, 0, 601, 602, 0, 603, 606, 601, 602,
+ 605, 603, 606, 0, 605, 605, 0, 602, 606, 0,
+
+ 0, 601, 602, 603, 603, 0, 606, 0, 605, 609,
+ 607, 0, 0, 610, 609, 607, 606, 607, 610, 0,
+ 610, 606, 0, 0, 0, 0, 606, 0, 609, 607,
+ 0, 0, 610, 0, 606, 619, 621, 0, 609, 607,
+ 619, 621, 610, 609, 607, 0, 607, 610, 0, 610,
+ 0, 0, 0, 0, 619, 621, 609, 607, 620, 0,
+ 610, 0, 0, 620, 619, 621, 0, 0, 0, 619,
+ 621, 620, 0, 0, 623, 622, 0, 620, 622, 623,
+ 622, 0, 619, 621, 0, 0, 0, 620, 623, 0,
+ 0, 624, 620, 623, 622, 0, 624, 0, 0, 620,
+
+ 0, 0, 624, 623, 622, 620, 0, 622, 623, 622,
+ 624, 0, 625, 625, 626, 0, 623, 625, 628, 626,
+ 624, 623, 622, 628, 0, 624, 0, 0, 0, 626,
+ 624, 625, 0, 626, 0, 627, 0, 628, 624, 627,
+ 627, 625, 625, 626, 0, 0, 625, 628, 626, 0,
+ 0, 0, 628, 629, 627, 629, 0, 626, 0, 625,
+ 0, 626, 0, 632, 627, 628, 0, 0, 627, 627,
+ 631, 631, 631, 631, 631, 631, 631, 631, 631, 631,
+ 632, 0, 627, 633, 629, 632, 629, 634, 633, 637,
+ 0, 629, 634, 0, 637, 0, 0, 0, 0, 632,
+
+ 634, 0, 633, 0, 0, 629, 634, 0, 637, 632,
+ 0, 0, 633, 0, 632, 629, 634, 633, 637, 638,
+ 629, 634, 0, 637, 638, 0, 0, 632, 634, 0,
+ 633, 0, 0, 629, 634, 639, 637, 0, 638, 641,
+ 639, 641, 642, 639, 641, 642, 643, 642, 638, 0,
+ 0, 643, 0, 638, 639, 0, 0, 0, 641, 0,
+ 0, 642, 644, 0, 639, 643, 638, 644, 641, 639,
+ 641, 642, 639, 641, 642, 643, 642, 0, 0, 644,
+ 643, 644, 639, 645, 0, 646, 641, 645, 645, 642,
+ 646, 644, 647, 643, 648, 0, 644, 647, 0, 648,
+
+ 0, 0, 645, 0, 646, 647, 0, 644, 0, 644,
+ 0, 647, 645, 648, 646, 0, 645, 645, 0, 646,
+ 0, 647, 0, 648, 0, 0, 647, 0, 648, 649,
+ 645, 649, 646, 647, 649, 650, 0, 0, 0, 647,
+ 650, 648, 0, 0, 0, 0, 650, 0, 649, 0,
+ 0, 0, 0, 0, 650, 0, 0, 0, 649, 0,
+ 649, 652, 0, 649, 650, 651, 652, 651, 0, 650,
+ 651, 0, 652, 653, 650, 0, 649, 653, 653, 0,
+ 652, 0, 650, 0, 651, 0, 0, 0, 0, 0,
+ 652, 0, 653, 0, 651, 652, 651, 0, 655, 651,
+
+ 652, 0, 653, 655, 0, 654, 653, 653, 652, 656,
+ 654, 0, 651, 654, 656, 0, 0, 655, 0, 0,
+ 653, 0, 656, 0, 654, 657, 0, 655, 656, 657,
+ 657, 0, 655, 0, 654, 0, 658, 0, 656, 654,
+ 0, 658, 654, 656, 657, 655, 0, 0, 660, 0,
+ 656, 0, 654, 660, 657, 658, 656, 659, 657, 657,
+ 0, 659, 659, 0, 0, 658, 0, 660, 661, 662,
+ 658, 0, 657, 661, 662, 0, 659, 660, 0, 0,
+ 0, 0, 660, 658, 0, 0, 659, 661, 662, 0,
+ 659, 659, 0, 0, 663, 660, 663, 661, 662, 663,
+
+ 665, 666, 661, 662, 659, 665, 666, 0, 0, 0,
+ 0, 0, 0, 663, 0, 661, 662, 0, 665, 665,
+ 666, 0, 0, 663, 0, 663, 667, 0, 663, 665,
+ 666, 667, 0, 0, 665, 666, 0, 668, 0, 667,
+ 668, 663, 668, 0, 0, 667, 665, 665, 666, 669,
+ 0, 0, 0, 672, 669, 667, 668, 671, 672, 0,
+ 667, 0, 671, 0, 0, 0, 668, 667, 669, 668,
+ 0, 668, 672, 667, 673, 0, 671, 671, 669, 673,
+ 674, 0, 672, 669, 668, 674, 671, 672, 0, 0,
+ 0, 671, 0, 673, 0, 0, 669, 0, 0, 674,
+
+ 672, 0, 0, 673, 671, 671, 0, 0, 673, 674,
+ 0, 0, 690, 0, 674, 0, 0, 0, 690, 695,
+ 0, 673, 0, 695, 695, 0, 690, 674, 690, 690,
+ 690, 690, 690, 690, 690, 690, 690, 690, 695, 696,
+ 698, 699, 0, 0, 696, 698, 699, 696, 695, 0,
+ 0, 698, 695, 695, 0, 0, 0, 0, 696, 698,
+ 699, 0, 0, 0, 0, 0, 695, 0, 696, 698,
+ 699, 0, 709, 696, 698, 699, 696, 0, 0, 698,
+ 0, 0, 710, 0, 0, 0, 696, 698, 699, 709,
+ 709, 709, 709, 709, 709, 709, 709, 709, 709, 710,
+
+ 710, 710, 710, 710, 710, 710, 710, 710, 710, 711,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 712,
+ 0, 0, 0, 0, 0, 0, 711, 711, 711, 711,
+ 711, 711, 711, 711, 711, 711, 712, 712, 712, 712,
+ 712, 712, 712, 712, 712, 712, 715, 715, 715, 715,
+ 715, 715, 715, 715, 715, 715, 715, 715, 715, 715,
+ 715, 715, 715, 715, 715, 715, 715, 715, 715, 715,
+ 715, 715, 715, 715, 715, 715, 715, 715, 715, 715,
+ 715, 715, 715, 715, 715, 715, 715, 715, 715, 715,
+ 715, 715, 715, 715, 715, 715, 715, 715, 715, 715,
+
+ 715, 715, 715, 715, 715, 715, 715, 715, 715, 715,
+ 715, 715, 715, 715, 715, 715, 715, 715, 715, 715,
+ 715, 715, 715, 715, 715, 715, 715, 715, 715, 715,
+ 715, 715, 715, 715, 715, 719, 719, 719, 0, 0,
+ 719, 719, 0, 719, 0, 0, 0, 719, 719, 0,
+ 0, 719, 0, 0, 719, 719, 719, 719, 719, 719,
+ 719, 719, 719, 732, 732, 0, 732, 732, 732, 732,
+ 732, 732, 732, 732, 732, 732, 732, 732, 732, 732,
+ 732, 732, 732, 732, 732, 732, 732, 732, 732, 732,
+ 732, 732, 732, 732, 732, 732, 732, 732, 732, 732,
+
+ 732, 732, 732, 732, 732, 732, 732, 732, 732, 732,
+ 732, 732, 732, 732, 732, 732, 732, 732, 732, 732,
+ 732, 732, 732, 732, 732, 732, 732, 732, 732, 732,
+ 732, 732, 732, 732, 732, 732, 732, 732, 732, 732,
+ 732, 732, 732, 732, 732, 732, 732, 732, 732, 732,
+ 732, 732, 733, 0, 0, 735, 0, 733, 734, 734,
+ 734, 734, 734, 734, 734, 734, 734, 734, 736, 737,
+ 0, 733, 735, 736, 737, 738, 0, 735, 0, 0,
+ 738, 733, 0, 0, 0, 0, 733, 736, 737, 0,
+ 0, 735, 0, 0, 738, 739, 0, 736, 737, 733,
+
+ 739, 735, 736, 737, 738, 0, 735, 740, 0, 738,
+ 0, 0, 740, 0, 739, 736, 737, 0, 741, 735,
+ 0, 0, 738, 741, 739, 0, 740, 0, 0, 739,
+ 740, 0, 0, 0, 0, 0, 740, 741, 741, 0,
+ 0, 740, 739, 742, 0, 742, 0, 741, 742, 0,
+ 747, 743, 741, 0, 740, 747, 743, 0, 740, 743,
+ 0, 745, 742, 745, 0, 741, 741, 0, 0, 747,
+ 743, 0, 742, 750, 742, 0, 0, 742, 750, 747,
+ 743, 0, 746, 0, 747, 743, 746, 746, 743, 0,
+ 742, 0, 750, 0, 745, 0, 745, 747, 743, 745,
+
+ 0, 746, 750, 0, 0, 0, 0, 750, 0, 745,
+ 0, 746, 0, 745, 751, 746, 746, 0, 751, 751,
+ 750, 0, 0, 745, 0, 745, 762, 0, 745, 746,
+ 0, 762, 0, 751, 761, 0, 761, 745, 0, 761,
+ 0, 745, 0, 751, 0, 762, 762, 751, 751, 0,
+ 0, 763, 0, 761, 0, 762, 763, 763, 0, 0,
+ 762, 751, 0, 761, 0, 761, 0, 0, 761, 0,
+ 763, 764, 765, 762, 762, 764, 764, 765, 766, 0,
+ 763, 761, 766, 766, 0, 763, 763, 0, 0, 765,
+ 764, 765, 0, 0, 771, 0, 0, 766, 763, 771,
+
+ 764, 765, 0, 767, 764, 764, 765, 766, 767, 0,
+ 768, 766, 766, 771, 772, 768, 772, 765, 764, 765,
+ 767, 768, 767, 771, 772, 766, 773, 0, 771, 768,
+ 0, 773, 767, 0, 0, 0, 0, 767, 0, 768,
+ 773, 771, 0, 0, 768, 773, 774, 772, 767, 768,
+ 767, 774, 772, 0, 774, 773, 0, 768, 775, 0,
+ 773, 0, 775, 775, 0, 774, 772, 776, 773, 778,
+ 0, 776, 776, 773, 778, 774, 772, 775, 0, 0,
+ 774, 772, 0, 774, 0, 0, 776, 775, 778, 0,
+ 777, 775, 775, 774, 772, 777, 776, 0, 778, 779,
+
+ 776, 776, 0, 778, 779, 775, 0, 777, 0, 777,
+ 780, 0, 0, 0, 776, 780, 778, 779, 779, 777,
+ 0, 780, 781, 0, 777, 0, 0, 781, 779, 780,
+ 0, 782, 0, 779, 0, 777, 782, 777, 0, 780,
+ 0, 781, 783, 784, 780, 779, 779, 783, 784, 780,
+ 782, 781, 0, 785, 0, 785, 781, 780, 0, 0,
+ 782, 783, 784, 786, 0, 782, 0, 0, 786, 781,
+ 0, 783, 784, 0, 787, 0, 783, 784, 782, 787,
+ 0, 786, 786, 788, 0, 0, 785, 0, 788, 783,
+ 784, 785, 786, 787, 789, 0, 0, 786, 787, 789,
+
+ 0, 785, 788, 787, 0, 785, 0, 0, 787, 786,
+ 786, 0, 788, 789, 0, 785, 0, 788, 0, 790,
+ 785, 787, 0, 789, 790, 0, 787, 791, 789, 785,
+ 788, 791, 791, 785, 0, 0, 790, 0, 790, 792,
+ 0, 789, 0, 0, 792, 0, 791, 0, 790, 0,
+ 0, 792, 0, 790, 0, 0, 791, 0, 792, 0,
+ 791, 791, 793, 0, 790, 0, 790, 793, 792, 0,
+ 795, 796, 0, 792, 791, 795, 796, 0, 795, 792,
+ 0, 793, 797, 0, 0, 0, 792, 797, 0, 795,
+ 796, 793, 0, 798, 0, 799, 793, 799, 798, 795,
+
+ 796, 797, 0, 0, 795, 796, 0, 795, 0, 793,
+ 0, 797, 798, 0, 0, 0, 797, 795, 796, 800,
+ 801, 0, 798, 0, 800, 801, 816, 798, 799, 797,
+ 799, 816, 0, 799, 0, 0, 0, 0, 800, 801,
+ 798, 0, 0, 0, 0, 816, 0, 799, 800, 801,
+ 0, 817, 0, 800, 801, 816, 817, 799, 0, 799,
+ 816, 0, 799, 0, 817, 0, 800, 801, 0, 818,
+ 817, 818, 0, 816, 842, 799, 802, 802, 802, 802,
+ 817, 0, 0, 0, 0, 817, 0, 0, 0, 0,
+ 819, 842, 817, 0, 0, 819, 842, 0, 817, 0,
+
+ 0, 0, 818, 0, 0, 0, 0, 818, 0, 819,
+ 842, 802, 802, 0, 0, 802, 0, 802, 0, 819,
+ 842, 818, 0, 0, 819, 842, 0, 0, 802, 802,
+ 0, 818, 0, 0, 0, 0, 818, 819, 842, 0,
+ 802, 802, 0, 0, 802, 0, 802, 0, 0, 818,
+ 0, 0, 0, 0, 0, 0, 802, 802, 827, 827,
+ 827, 827, 827, 827, 827, 827, 827, 827, 827, 827,
+ 827, 827, 827, 827, 827, 827, 827, 827, 827, 827,
+ 827, 827, 827, 827, 827, 827, 827, 827, 827, 827,
+ 827, 827, 827, 827, 827, 827, 827, 827, 827, 827,
+
+ 827, 827, 827, 827, 827, 827, 827, 827, 827, 827,
+ 827, 827, 827, 827, 827, 827, 827, 827, 827, 827,
+ 827, 827, 827, 827, 827, 827, 827, 827, 827, 827,
+ 827, 827, 827, 827, 827, 827, 827, 827, 827, 827,
+ 827, 827, 827, 827, 827, 827, 827, 828, 841, 841,
+ 841, 841, 841, 841, 841, 841, 841, 841, 0, 0,
+ 0, 0, 0, 0, 828, 828, 828, 828, 828, 828,
+ 828, 828, 828, 828, 829, 829, 829, 829, 829, 829,
+ 829, 829, 829, 829, 829, 829, 829, 829, 829, 829,
+ 829, 829, 829, 829, 829, 829, 829, 829, 829, 829,
+
+ 829, 829, 829, 829, 829, 829, 829, 829, 829, 829,
+ 829, 829, 829, 829, 829, 829, 829, 829, 829, 829,
+ 829, 829, 829, 829, 829, 829, 829, 829, 829, 829,
+ 829, 829, 829, 829, 829, 829, 829, 829, 829, 829,
+ 829, 829, 829, 829, 829, 829, 829, 829, 829, 829,
+ 829, 829, 829, 829, 829, 829, 829, 829, 829, 829,
+ 829, 829, 829, 843, 0, 844, 0, 847, 843, 844,
+ 844, 845, 847, 845, 846, 0, 845, 0, 846, 846,
+ 0, 0, 843, 0, 844, 0, 847, 0, 0, 0,
+ 845, 0, 843, 846, 844, 0, 847, 843, 844, 844,
+
+ 845, 847, 845, 846, 849, 845, 0, 846, 846, 849,
+ 843, 848, 844, 0, 847, 848, 848, 0, 845, 0,
+ 850, 846, 0, 849, 0, 850, 0, 853, 0, 0,
+ 848, 854, 853, 849, 850, 0, 854, 0, 849, 850,
+ 848, 853, 0, 0, 848, 848, 853, 0, 854, 850,
+ 854, 849, 855, 0, 850, 0, 853, 855, 848, 0,
+ 854, 853, 850, 858, 0, 854, 0, 850, 858, 853,
+ 0, 855, 866, 0, 853, 0, 854, 866, 854, 0,
+ 858, 855, 858, 867, 0, 0, 855, 0, 867, 0,
+ 0, 866, 858, 0, 867, 0, 0, 858, 0, 855,
+
+ 0, 866, 867, 0, 868, 0, 866, 0, 858, 868,
+ 858, 0, 867, 869, 0, 869, 0, 867, 869, 866,
+ 0, 868, 867, 868, 0, 0, 0, 0, 0, 870,
+ 867, 0, 869, 868, 870, 871, 0, 0, 868, 0,
+ 871, 0, 869, 870, 869, 0, 0, 869, 870, 868,
+ 0, 868, 0, 0, 871, 0, 0, 0, 870, 0,
+ 869, 872, 0, 870, 871, 872, 872, 0, 873, 871,
+ 874, 870, 873, 873, 0, 874, 870, 0, 0, 0,
+ 872, 874, 871, 0, 0, 0, 0, 873, 0, 874,
+ 872, 878, 0, 877, 872, 872, 878, 873, 877, 874,
+
+ 0, 873, 873, 0, 874, 0, 877, 0, 872, 874,
+ 878, 0, 877, 879, 880, 873, 881, 874, 879, 880,
+ 878, 881, 877, 0, 0, 878, 0, 877, 0, 0,
+ 0, 0, 879, 880, 877, 881, 882, 0, 878, 0,
+ 877, 882, 879, 880, 882, 881, 0, 879, 880, 0,
+ 881, 0, 883, 886, 0, 882, 0, 883, 886, 885,
+ 879, 880, 0, 881, 885, 882, 0, 0, 0, 0,
+ 882, 883, 886, 882, 0, 0, 885, 0, 885, 887,
+ 0, 883, 886, 882, 887, 0, 883, 886, 885, 0,
+ 888, 890, 0, 885, 0, 888, 890, 0, 887, 883,
+
+ 886, 888, 891, 0, 885, 0, 885, 891, 887, 888,
+ 890, 889, 0, 887, 0, 889, 889, 0, 0, 888,
+ 890, 891, 892, 897, 888, 890, 887, 892, 897, 888,
+ 889, 891, 0, 0, 895, 0, 891, 888, 890, 895,
+ 889, 892, 897, 906, 889, 889, 0, 0, 906, 891,
+ 0, 892, 897, 895, 0, 895, 892, 897, 889, 898,
+ 0, 0, 906, 895, 898, 0, 907, 898, 895, 892,
+ 897, 907, 906, 0, 0, 0, 0, 906, 898, 0,
+ 0, 895, 0, 895, 907, 907, 0, 0, 898, 909,
+ 906, 909, 0, 898, 909, 907, 898, 0, 0, 0,
+
+ 907, 0, 0, 0, 0, 0, 898, 914, 909, 0,
+ 0, 0, 907, 907, 0, 0, 917, 917, 909, 0,
+ 909, 917, 0, 909, 914, 914, 914, 914, 914, 914,
+ 914, 914, 914, 914, 0, 917, 909, 918, 0, 919,
+ 0, 0, 918, 919, 919, 917, 917, 0, 920, 0,
+ 917, 0, 0, 920, 0, 0, 918, 0, 919, 0,
+ 0, 0, 0, 917, 0, 920, 918, 920, 919, 921,
+ 922, 918, 919, 919, 921, 922, 0, 920, 923, 0,
+ 0, 0, 920, 923, 918, 0, 919, 0, 921, 922,
+ 0, 923, 0, 920, 0, 920, 0, 923, 921, 922,
+
+ 0, 927, 0, 921, 922, 928, 927, 923, 0, 928,
+ 928, 0, 923, 927, 0, 0, 921, 922, 0, 923,
+ 927, 938, 0, 0, 928, 923, 938, 930, 940, 938,
+ 927, 930, 930, 940, 928, 927, 0, 0, 928, 928,
+ 938, 927, 0, 0, 0, 0, 930, 940, 927, 0,
+ 938, 0, 928, 0, 0, 938, 930, 940, 938, 939,
+ 930, 930, 940, 939, 939, 941, 942, 0, 938, 0,
+ 941, 942, 0, 0, 930, 940, 0, 0, 939, 0,
+ 0, 0, 943, 0, 941, 942, 942, 943, 939, 0,
+ 0, 944, 939, 939, 941, 942, 944, 0, 0, 941,
+
+ 942, 943, 945, 0, 944, 0, 939, 945, 0, 0,
+ 944, 943, 941, 942, 942, 0, 943, 0, 951, 0,
+ 944, 945, 952, 951, 0, 944, 0, 952, 0, 943,
+ 0, 945, 944, 0, 0, 0, 945, 951, 944, 955,
+ 0, 952, 0, 953, 955, 953, 0, 951, 953, 945,
+ 0, 952, 951, 955, 0, 0, 952, 0, 955, 956,
+ 0, 0, 953, 0, 956, 951, 957, 0, 955, 952,
+ 958, 957, 953, 955, 953, 958, 0, 953, 956, 0,
+ 0, 955, 0, 0, 0, 957, 955, 958, 956, 958,
+ 953, 0, 960, 956, 0, 957, 960, 960, 0, 958,
+
+ 957, 0, 0, 963, 958, 0, 956, 0, 963, 962,
+ 0, 960, 0, 957, 962, 958, 963, 958, 0, 0,
+ 0, 960, 963, 0, 0, 960, 960, 962, 962, 969,
+ 0, 0, 963, 0, 969, 970, 0, 963, 962, 960,
+ 970, 971, 0, 962, 963, 971, 971, 0, 969, 969,
+ 963, 0, 976, 0, 970, 962, 962, 976, 969, 0,
+ 971, 975, 0, 969, 970, 0, 975, 0, 977, 970,
+ 971, 976, 975, 977, 971, 971, 969, 969, 0, 0,
+ 975, 976, 970, 0, 979, 0, 976, 977, 971, 979,
+ 975, 0, 0, 985, 0, 975, 0, 977, 985, 976,
+
+ 975, 978, 977, 979, 982, 978, 978, 0, 975, 982,
+ 0, 0, 985, 979, 0, 977, 0, 0, 979, 982,
+ 978, 0, 985, 982, 983, 0, 983, 985, 0, 983,
+ 978, 979, 0, 982, 978, 978, 0, 0, 982, 0,
+ 985, 993, 0, 983, 994, 992, 993, 982, 978, 994,
+ 992, 982, 0, 983, 0, 983, 994, 0, 983, 992,
+ 993, 995, 0, 994, 992, 0, 995, 996, 0, 0,
+ 993, 983, 996, 994, 992, 993, 0, 0, 994, 992,
+ 995, 0, 0, 0, 994, 0, 996, 992, 993, 0,
+ 995, 994, 992, 1004, 0, 995, 996, 997, 1004, 997,
+
+ 1007, 996, 997, 0, 1006, 1007, 1006, 0, 995, 1006,
+ 0, 0, 1004, 0, 996, 0, 997, 0, 0, 1007,
+ 1009, 0, 1004, 1006, 0, 1009, 997, 1004, 997, 1007,
+ 0, 997, 0, 1006, 1007, 1006, 0, 1011, 1006, 1009,
+ 1004, 1011, 1011, 0, 997, 0, 0, 1007, 0, 1009,
+ 0, 1006, 0, 1012, 1009, 0, 1011, 1012, 1012, 0,
+ 1020, 0, 0, 0, 1019, 1020, 1011, 1009, 0, 1019,
+ 1011, 1011, 1012, 0, 0, 1019, 1025, 0, 0, 1020,
+ 1025, 1025, 1012, 1019, 1011, 1026, 1012, 1012, 0, 1020,
+ 1026, 0, 0, 1019, 1020, 1025, 0, 1029, 1019, 0,
+
+ 1012, 0, 1029, 1019, 1026, 1025, 0, 1020, 1029, 1025,
+ 1025, 1019, 0, 0, 1026, 0, 1029, 0, 0, 1026,
+ 1030, 0, 1037, 1025, 1038, 1030, 1029, 1037, 1030, 1038,
+ 0, 1029, 1026, 0, 0, 1037, 1029, 0, 0, 1030,
+ 0, 1037, 0, 1038, 1029, 0, 0, 1039, 0, 1030,
+ 0, 1037, 1039, 1038, 1030, 1039, 1037, 1030, 1038, 1047,
+ 0, 0, 0, 1037, 1047, 0, 1039, 1030, 1040, 1037,
+ 1044, 1038, 1040, 1040, 1044, 1044, 1039, 0, 1047, 0,
+ 0, 1039, 0, 0, 1039, 0, 0, 1040, 1047, 1044,
+ 1048, 1054, 0, 1047, 1039, 1048, 1054, 1040, 0, 1044,
+
+ 0, 1040, 1040, 1044, 1044, 0, 1047, 1059, 0, 1048,
+ 1054, 0, 1059, 0, 0, 1040, 1063, 1044, 0, 1048,
+ 1054, 1063, 0, 1062, 1048, 1054, 1059, 1062, 1062, 0,
+ 0, 0, 0, 0, 1063, 1063, 1059, 1048, 1054, 1067,
+ 0, 1059, 1062, 0, 1067, 1063, 1068, 0, 1069, 0,
+ 1063, 1068, 1062, 1069, 1059, 0, 1062, 1062, 1067, 1068,
+ 0, 0, 1063, 1063, 0, 1068, 0, 1069, 1067, 1073,
+ 1062, 1080, 1073, 1067, 1073, 1068, 1080, 1069, 0, 0,
+ 1068, 0, 1069, 0, 0, 0, 1067, 1068, 1073, 0,
+ 1080, 1087, 0, 1068, 1088, 1069, 1087, 0, 1073, 1088,
+
+ 1080, 1073, 1088, 1073, 0, 1080, 0, 0, 0, 0,
+ 1087, 0, 0, 1088, 1087, 0, 1073, 1091, 1080, 0,
+ 1087, 1091, 1091, 1088, 1095, 1087, 0, 0, 1088, 1095,
+ 0, 1088, 0, 0, 0, 0, 1091, 0, 1087, 0,
+ 1105, 1088, 1087, 1095, 1095, 1105, 1091, 1106, 0, 1108,
+ 1091, 1091, 1106, 1095, 1108, 0, 0, 0, 1095, 1105,
+ 0, 1106, 0, 0, 1091, 0, 1106, 0, 1108, 1105,
+ 0, 1095, 1095, 0, 1105, 0, 1106, 0, 1108, 0,
+ 0, 1106, 0, 1108, 0, 0, 0, 1105, 0, 1106,
+ 0, 0, 0, 0, 1106, 0, 1108, 1109, 1109, 1109,
+
+ 0, 0, 1109, 1109, 0, 1109, 0, 0, 0, 1109,
+ 1109, 0, 0, 1109, 0, 0, 1109, 1109, 1109, 1109,
+ 1109, 1109, 1109, 1109, 1109, 1112, 1122, 0, 0, 0,
+ 1112, 1122, 0, 0, 0, 0, 0, 0, 0, 1122,
+ 0, 0, 1112, 0, 1112, 1122, 0, 0, 0, 0,
+ 0, 0, 0, 0, 1112, 1122, 0, 0, 0, 1112,
+ 1122, 0, 0, 0, 0, 0, 0, 1122, 0, 0,
+ 1112, 0, 1112, 1122, 1126, 1126, 1126, 0, 0, 1126,
+ 1126, 0, 1126, 0, 1128, 1126, 1126, 1126, 1128, 1128,
+ 1126, 0, 0, 1126, 1126, 1126, 1126, 1126, 1126, 1126,
+
+ 1126, 1126, 0, 1128, 1133, 1137, 0, 0, 0, 1133,
+ 1137, 0, 0, 1128, 0, 0, 0, 1128, 1128, 0,
+ 0, 0, 0, 1133, 1137, 0, 0, 0, 0, 0,
+ 0, 1128, 0, 1133, 1137, 0, 0, 0, 1133, 1137,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 1133, 1137, 1162, 1162, 1162, 1162, 1162, 1162, 1162,
+ 1162, 1162, 1162, 1162, 1162, 1163, 1163, 1163, 1163, 1163,
+ 1163, 1163, 1163, 1163, 1163, 1163, 1163, 1164, 1164, 0,
+ 1164, 1164, 1164, 1164, 1164, 1164, 1164, 1164, 1164, 1165,
+ 1165, 0, 1165, 1165, 1165, 1165, 1165, 1165, 1165, 1165,
+
+ 1165, 1166, 1166, 1166, 1166, 1166, 1166, 1166, 1166, 1166,
+ 1166, 1166, 1166, 1167, 1167, 1167, 1167, 1167, 1167, 1167,
+ 1167, 1167, 1167, 1167, 1167, 1168, 1168, 1169, 1169, 1169,
+ 1169, 1169, 1169, 1169, 1169, 1170, 1170, 1170, 1170, 1170,
+ 1170, 1170, 1170, 1170, 1170, 1170, 1170, 1171, 1171, 1171,
+ 1171, 1171, 1171, 1171, 1171, 1171, 1171, 1171, 1171, 1172,
+ 1172, 1172, 1172, 1172, 1172, 0, 1172, 1172, 1172, 0,
+ 1172, 1173, 1173, 1173, 1173, 1173, 1173, 1173, 1173, 1173,
+ 1173, 1173, 1173, 1174, 0, 0, 1174, 1175, 1175, 1175,
+ 0, 0, 1175, 0, 1175, 1175, 0, 1175, 1175, 1176,
+
+ 1176, 1176, 1176, 1176, 1176, 1176, 1176, 1176, 1176, 1176,
+ 1176, 1177, 1177, 0, 1177, 1177, 1177, 1177, 1177, 1177,
+ 1177, 1177, 1177, 1178, 1178, 1178, 1178, 1178, 1178, 0,
+ 1178, 1178, 1178, 0, 1178, 1179, 1179, 1179, 1179, 1179,
+ 1179, 1179, 1179, 1179, 1179, 1179, 1179, 1180, 1180, 1180,
+ 1180, 1180, 1180, 1180, 1180, 1180, 1180, 1180, 1180, 1181,
+ 0, 0, 1181, 1182, 0, 0, 0, 1182, 0, 0,
+ 0, 0, 0, 1182, 1183, 1183, 1183, 1183, 1183, 1183,
+ 1183, 1183, 1183, 1183, 1183, 1183, 1184, 1184, 0, 1184,
+ 1184, 1184, 1184, 1184, 1184, 1184, 1184, 1184, 1185, 1185,
+
+ 0, 1185, 1185, 1185, 1185, 1185, 1185, 1185, 1185, 1185,
+ 1186, 1186, 0, 1186, 1186, 1186, 1186, 1186, 1186, 1186,
+ 1186, 1186, 1187, 1187, 1187, 1187, 1187, 1187, 1187, 1187,
+ 1187, 1187, 1187, 1187, 1188, 1188, 1188, 1188, 1188, 1188,
+ 1188, 1188, 1188, 1188, 1188, 1188, 1189, 1189, 1189, 1189,
+ 1189, 1189, 1189, 1189, 1189, 1189, 1189, 1189, 1190, 1190,
+ 1190, 1190, 1190, 1190, 1190, 1190, 1190, 1190, 1190, 1190,
+ 1191, 1191, 1191, 1191, 1191, 1191, 1191, 1191, 1191, 1191,
+ 1191, 1191, 1192, 1192, 0, 1192, 1192, 1192, 1192, 1192,
+ 1192, 1192, 1192, 1192, 1193, 1193, 1193, 1193, 1193, 1193,
+
+ 1193, 1193, 1193, 1193, 1193, 1193, 1194, 1194, 1194, 1194,
+ 1194, 1194, 1194, 1194, 1194, 1194, 1194, 1194, 1195, 1195,
+ 0, 1195, 1195, 1195, 1195, 1195, 1195, 1195, 1195, 1195,
+ 1196, 1196, 0, 1196, 1196, 1196, 1196, 1196, 1196, 1196,
+ 1196, 1196, 1197, 1197, 0, 1197, 1197, 1197, 1197, 1197,
+ 1197, 1197, 1197, 1197, 1198, 1198, 0, 1198, 1198, 1198,
+ 1198, 1198, 1198, 1198, 1198, 1198, 1199, 1199, 0, 1199,
+ 1199, 1199, 1199, 1199, 1199, 1199, 1199, 1199, 1200, 1200,
+ 1200, 1200, 1200, 1200, 1200, 1200, 1200, 1200, 1200, 1200,
+ 1201, 1201, 1201, 1201, 1201, 1201, 1201, 1201, 1201, 1201,
+
+ 1201, 1201, 1202, 1202, 1202, 1202, 1202, 1202, 1202, 1202,
+ 1202, 1202, 1202, 1202, 1203, 1203, 1203, 1203, 1203, 1203,
+ 1203, 1203, 1203, 1203, 1203, 1203, 1204, 1204, 1204, 1204,
+ 1204, 1204, 1204, 1204, 1204, 1204, 1204, 1204, 1205, 1205,
+ 1205, 1205, 1205, 1205, 1205, 1205, 1205, 1205, 1205, 1205,
+ 1206, 1206, 0, 1206, 1206, 1206, 1206, 1206, 1206, 1206,
+ 1206, 1206, 1207, 1207, 0, 1207, 1207, 1207, 1207, 1207,
+ 1207, 1207, 1207, 1207, 1208, 1208, 1208, 1208, 1208, 1208,
+ 1208, 1208, 1208, 1208, 1208, 1208, 1209, 1209, 1209, 1209,
+ 1209, 1209, 1209, 1209, 1209, 1209, 1209, 1209, 1210, 1210,
+
+ 1210, 1210, 1210, 1210, 1210, 1210, 1210, 1210, 1210, 1210,
+ 1211, 1211, 1211, 1211, 1211, 1211, 1211, 1211, 1211, 1211,
+ 1211, 1211, 1212, 1212, 1212, 1212, 1212, 1212, 1212, 1212,
+ 1212, 1212, 1212, 1212, 1213, 1213, 1213, 1213, 1213, 1213,
+ 1213, 1213, 1213, 1213, 1213, 1213, 1214, 1214, 1214, 1214,
+ 1214, 1214, 1214, 1214, 1214, 1214, 1214, 1214, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161,
+ 1161, 1161, 1161, 1161, 1161, 1161, 1161, 1161
+ } ;
+
+static yy_state_type yy_last_accepting_state;
+static char *yy_last_accepting_cpos;
+
+extern int fortran_flex_debug;
+int fortran_flex_debug = 0;
+
+/* The intent behind this definition is that it'll catch
+ * any uses of REJECT which flex missed.
+ */
+#define REJECT reject_used_but_not_detected
+#define yymore() yymore_used_but_not_detected
+#define YY_MORE_ADJ 0
+#define YY_RESTORE_YY_MORE_OFFSET
+char *fortrantext;
+#line 1 "fortran.lex"
+/******************************************************************************/
+/* */
+/* CONV (converter) for Agrif (Adaptive Grid Refinement In Fortran) */
+/* */
+/* Copyright or or Copr. Laurent Debreu (Laurent.Debreu@imag.fr) */
+/* Cyril Mazauric (Cyril_Mazauric@yahoo.fr) */
+/* This software is governed by the CeCILL-C license under French law and */
+/* abiding by the rules of distribution of free software. You can use, */
+/* modify and/ or redistribute the software under the terms of the CeCILL-C */
+/* license as circulated by CEA, CNRS and INRIA at the following URL */
+/* "http://www.cecill.info". */
+/* */
+/* As a counterpart to the access to the source code and rights to copy, */
+/* modify and redistribute granted by the license, users are provided only */
+/* with a limited warranty and the software's author, the holder of the */
+/* economic rights, and the successive licensors have only limited */
+/* liability. */
+/* */
+/* In this respect, the user's attention is drawn to the risks associated */
+/* with loading, using, modifying and/or developing or reproducing the */
+/* software by the user in light of its specific status of free software, */
+/* that may mean that it is complicated to manipulate, and that also */
+/* therefore means that it is reserved for developers and experienced */
+/* professionals having in-depth computer knowledge. Users are therefore */
+/* encouraged to load and test the software's suitability as regards their */
+/* requirements in conditions enabling the security of their systems and/or */
+/* data to be ensured and, more generally, to use and operate it in the */
+/* same conditions as regards security. */
+/* */
+/* The fact that you are presently reading this means that you have had */
+/* knowledge of the CeCILL-C license and that you accept its terms. */
+/******************************************************************************/
+/* version 1.7 */
+/******************************************************************************/
+
+
+
+
+
+#line 41 "fortran.lex"
+#include
+#include
+#include
+extern FILE * fortranin;
+#define MAX_INCLUDE_DEPTH 30
+#define tabsize 6
+YY_BUFFER_STATE include_stack[MAX_INCLUDE_DEPTH];
+int line_num_fortran=1;
+int line_num_fortran_common=1;
+int newlinef90 = 0;
+char *tmp;
+char tmpc;
+/******************************************************************************/
+/**************PETITS PB NON PREVUS *******************************************/
+/******************************************************************************/
+/* NEXTLINF77 un ligne fortran 77 peut commencer par - &a=b or on */
+/* a prevu seulement & a=b avec l'espace entre le symbole */
+/* de la 7eme et le debut de la ligne de commande */
+/* le ! est aussi interdit comme symbole de la 7 eme colonne */
+/* Normalement NEXTLINEF77 \n+[ ]{5}[^ ] */
+/******************************************************************************/
+#define YY_USER_ACTION \
+ {\
+ if (firstpass == 0) \
+ {\
+ strcat(curbuf,fortrantext); \
+ Save_Length(curbuf,38); \
+ strcpy(motparse,fortrantext);\
+ Save_Length(motparse,32); \
+ colnum = colnum + strlen(motparse);\
+ ECHO; \
+ }\
+ strcpy(motparse1,fortrantext);\
+/* printf("fortrantext = %s\n",fortrantext);*/\
+ /*if ( firstpass == 1 )
+ printf("fortrantext = %s %d\n",fortrantext,strlen(fortrantext));*/\
+ }
+#line 2979 "fortran.yy.c"
+
+#define INITIAL 0
+#define parameter 1
+#define character 2
+#define donottreat 3
+#define fortran77style 4
+#define fortran90style 5
+
+#ifndef YY_NO_UNISTD_H
+/* Special case for "unistd.h", since it is non-ANSI. We include it way
+ * down here because we want the user's section 1 to have been scanned first.
+ * The user has a chance to override it with an option.
+ */
+#include
+#endif
+
+#ifndef YY_EXTRA_TYPE
+#define YY_EXTRA_TYPE void *
+#endif
+
+static int yy_init_globals (void );
+
+/* Accessor methods to globals.
+ These are made visible to non-reentrant scanners for convenience. */
+
+int fortranlex_destroy (void );
+
+int fortranget_debug (void );
+
+void fortranset_debug (int debug_flag );
+
+YY_EXTRA_TYPE fortranget_extra (void );
+
+void fortranset_extra (YY_EXTRA_TYPE user_defined );
+
+FILE *fortranget_in (void );
+
+void fortranset_in (FILE * in_str );
+
+FILE *fortranget_out (void );
+
+void fortranset_out (FILE * out_str );
+
+yy_size_t fortranget_leng (void );
+
+char *fortranget_text (void );
+
+int fortranget_lineno (void );
+
+void fortranset_lineno (int line_number );
+
+/* Macros after this point can all be overridden by user definitions in
+ * section 1.
+ */
+
+#ifndef YY_SKIP_YYWRAP
+#ifdef __cplusplus
+extern "C" int fortranwrap (void );
+#else
+extern int fortranwrap (void );
+#endif
+#endif
+
+ static void yyunput (int c,char *buf_ptr );
+
+#ifndef yytext_ptr
+static void yy_flex_strncpy (char *,yyconst char *,int );
+#endif
+
+#ifdef YY_NEED_STRLEN
+static int yy_flex_strlen (yyconst char * );
+#endif
+
+#ifndef YY_NO_INPUT
+
+#ifdef __cplusplus
+static int yyinput (void );
+#else
+static int input (void );
+#endif
+
+#endif
+
+/* Amount of stuff to slurp up with each read. */
+#ifndef YY_READ_BUF_SIZE
+#define YY_READ_BUF_SIZE 8192
+#endif
+
+/* Copy whatever the last rule matched to the standard output. */
+#ifndef ECHO
+/* This used to be an fputs(), but since the string might contain NUL's,
+ * we now use fwrite().
+ */
+#define ECHO fwrite( fortrantext, fortranleng, 1, fortranout )
+#endif
+
+/* Gets input and stuffs it into "buf". number of characters read, or YY_NULL,
+ * is returned in "result".
+ */
+#ifndef YY_INPUT
+#define YY_INPUT(buf,result,max_size) \
+ if ( YY_CURRENT_BUFFER_LVALUE->yy_is_interactive ) \
+ { \
+ int c = '*'; \
+ yy_size_t n; \
+ for ( n = 0; n < max_size && \
+ (c = getc( fortranin )) != EOF && c != '\n'; ++n ) \
+ buf[n] = (char) c; \
+ if ( c == '\n' ) \
+ buf[n++] = (char) c; \
+ if ( c == EOF && ferror( fortranin ) ) \
+ YY_FATAL_ERROR( "input in flex scanner failed" ); \
+ result = n; \
+ } \
+ else \
+ { \
+ errno=0; \
+ while ( (result = fread(buf, 1, max_size, fortranin))==0 && ferror(fortranin)) \
+ { \
+ if( errno != EINTR) \
+ { \
+ YY_FATAL_ERROR( "input in flex scanner failed" ); \
+ break; \
+ } \
+ errno=0; \
+ clearerr(fortranin); \
+ } \
+ }\
+\
+
+#endif
+
+/* No semi-colon after return; correct usage is to write "yyterminate();" -
+ * we don't want an extra ';' after the "return" because that will cause
+ * some compilers to complain about unreachable statements.
+ */
+#ifndef yyterminate
+#define yyterminate() return YY_NULL
+#endif
+
+/* Number of entries by which start-condition stack grows. */
+#ifndef YY_START_STACK_INCR
+#define YY_START_STACK_INCR 25
+#endif
+
+/* Report a fatal error. */
+#ifndef YY_FATAL_ERROR
+#define YY_FATAL_ERROR(msg) yy_fatal_error( msg )
+#endif
+
+/* end tables serialization structures and prototypes */
+
+/* Default declaration of generated scanner - a define so the user can
+ * easily add parameters.
+ */
+#ifndef YY_DECL
+#define YY_DECL_IS_OURS 1
+
+extern int fortranlex (void);
+
+#define YY_DECL int fortranlex (void)
+#endif /* !YY_DECL */
+
+/* Code executed at the beginning of each rule, after fortrantext and fortranleng
+ * have been set up.
+ */
+#ifndef YY_USER_ACTION
+#define YY_USER_ACTION
+#endif
+
+/* Code executed at the end of each rule. */
+#ifndef YY_BREAK
+#define YY_BREAK break;
+#endif
+
+#define YY_RULE_SETUP \
+ if ( fortranleng > 0 ) \
+ YY_CURRENT_BUFFER_LVALUE->yy_at_bol = \
+ (fortrantext[fortranleng - 1] == '\n'); \
+ YY_USER_ACTION
+
+/** The main scanner function which does all the work.
+ */
+YY_DECL
+{
+ register yy_state_type yy_current_state;
+ register char *yy_cp, *yy_bp;
+ register int yy_act;
+
+#line 107 "fortran.lex"
+
+ if (infixed) BEGIN(fortran77style) ;
+ if (infree) BEGIN(fortran90style) ;
+
+#line 3174 "fortran.yy.c"
+
+ if ( !(yy_init) )
+ {
+ (yy_init) = 1;
+
+#ifdef YY_USER_INIT
+ YY_USER_INIT;
+#endif
+
+ if ( ! (yy_start) )
+ (yy_start) = 1; /* first start state */
+
+ if ( ! fortranin )
+ fortranin = stdin;
+
+ if ( ! fortranout )
+ fortranout = stdout;
+
+ if ( ! YY_CURRENT_BUFFER ) {
+ fortranensure_buffer_stack ();
+ YY_CURRENT_BUFFER_LVALUE =
+ fortran_create_buffer(fortranin,YY_BUF_SIZE );
+ }
+
+ fortran_load_buffer_state( );
+ }
+
+ while ( 1 ) /* loops until end-of-file is reached */
+ {
+ yy_cp = (yy_c_buf_p);
+
+ /* Support of fortrantext. */
+ *yy_cp = (yy_hold_char);
+
+ /* yy_bp points to the position in yy_ch_buf of the start of
+ * the current run.
+ */
+ yy_bp = yy_cp;
+
+ yy_current_state = (yy_start);
+ yy_current_state += YY_AT_BOL();
+yy_match:
+ do
+ {
+ register YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)];
+ if ( yy_accept[yy_current_state] )
+ {
+ (yy_last_accepting_state) = yy_current_state;
+ (yy_last_accepting_cpos) = yy_cp;
+ }
+ while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state )
+ {
+ yy_current_state = (int) yy_def[yy_current_state];
+ if ( yy_current_state >= 1162 )
+ yy_c = yy_meta[(unsigned int) yy_c];
+ }
+ yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c];
+ ++yy_cp;
+ }
+ while ( yy_base[yy_current_state] != 9159 );
+
+yy_find_action:
+ yy_act = yy_accept[yy_current_state];
+ if ( yy_act == 0 )
+ { /* have to back up */
+ yy_cp = (yy_last_accepting_cpos);
+ yy_current_state = (yy_last_accepting_state);
+ yy_act = yy_accept[yy_current_state];
+ }
+
+ YY_DO_BEFORE_ACTION;
+
+do_action: /* This label is used only to access EOF actions. */
+
+ switch ( yy_act )
+ { /* beginning of action switch */
+ case 0: /* must back up */
+ /* undo the effects of YY_DO_BEFORE_ACTION */
+ *yy_cp = (yy_hold_char);
+ yy_cp = (yy_last_accepting_cpos);
+ yy_current_state = (yy_last_accepting_state);
+ goto yy_find_action;
+
+case 1:
+YY_RULE_SETUP
+#line 111 "fortran.lex"
+return TOK_DEBUT;
+ YY_BREAK
+case 2:
+YY_RULE_SETUP
+#line 112 "fortran.lex"
+return TOK_FIN;
+ YY_BREAK
+case 3:
+YY_RULE_SETUP
+#line 113 "fortran.lex"
+return TOK_OMP;
+ YY_BREAK
+case 4:
+YY_RULE_SETUP
+#line 114 "fortran.lex"
+return TOK_DOLLAR;
+ YY_BREAK
+case 5:
+YY_RULE_SETUP
+#line 116 "fortran.lex"
+{return TOK_REAL8;}
+ YY_BREAK
+case 6:
+YY_RULE_SETUP
+#line 117 "fortran.lex"
+{return TOK_SUBROUTINE;}
+ YY_BREAK
+case 7:
+YY_RULE_SETUP
+#line 118 "fortran.lex"
+{return TOK_PROGRAM;}
+ YY_BREAK
+case 8:
+YY_RULE_SETUP
+#line 119 "fortran.lex"
+{inallocate = 1; return TOK_ALLOCATE;}
+ YY_BREAK
+case 9:
+YY_RULE_SETUP
+#line 120 "fortran.lex"
+{return TOK_NULLIFY;}
+ YY_BREAK
+case 10:
+YY_RULE_SETUP
+#line 121 "fortran.lex"
+{inallocate = 1; return TOK_DEALLOCATE;}
+ YY_BREAK
+case 11:
+YY_RULE_SETUP
+#line 122 "fortran.lex"
+{return TOK_RESULT;}
+ YY_BREAK
+case 12:
+YY_RULE_SETUP
+#line 123 "fortran.lex"
+{return TOK_FUNCTION;}
+ YY_BREAK
+case 13:
+YY_RULE_SETUP
+#line 124 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_ENDSUBROUTINE;}
+ YY_BREAK
+case 14:
+YY_RULE_SETUP
+#line 125 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_ENDPROGRAM;}
+ YY_BREAK
+case 15:
+YY_RULE_SETUP
+#line 126 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_ENDFUNCTION;}
+ YY_BREAK
+case 16:
+YY_RULE_SETUP
+#line 127 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_ENDUNIT;}
+ YY_BREAK
+case 17:
+YY_RULE_SETUP
+#line 128 "fortran.lex"
+return TOK_INCLUDE;
+ YY_BREAK
+case 18:
+YY_RULE_SETUP
+#line 129 "fortran.lex"
+{
+ strcpy(yylval.na,fortrantext);
+ tmpc = input();
+ unput(tmpc);
+ if ( (
+ tmpc >= 'a' && tmpc <= 'z'
+ ) || (
+ tmpc >= 'A' && tmpc <= 'Z'
+ ) )
+ {
+ return TOK_USE;
+ }
+ else
+ {
+ return TOK_NAME;
+ }
+ }
+ YY_BREAK
+case 19:
+YY_RULE_SETUP
+#line 146 "fortran.lex"
+{return TOK_REWIND;}
+ YY_BREAK
+case 20:
+YY_RULE_SETUP
+#line 147 "fortran.lex"
+return TOK_IMPLICIT;
+ YY_BREAK
+case 21:
+YY_RULE_SETUP
+#line 148 "fortran.lex"
+return TOK_NONE;
+ YY_BREAK
+case 22:
+YY_RULE_SETUP
+#line 149 "fortran.lex"
+return TOK_CALL;
+ YY_BREAK
+case 23:
+YY_RULE_SETUP
+#line 150 "fortran.lex"
+return TOK_TRUE;
+ YY_BREAK
+case 24:
+YY_RULE_SETUP
+#line 151 "fortran.lex"
+return TOK_FALSE;
+ YY_BREAK
+case 25:
+YY_RULE_SETUP
+#line 152 "fortran.lex"
+{return TOK_POINT_TO;}
+ YY_BREAK
+case 26:
+YY_RULE_SETUP
+#line 153 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_DASTER;}
+ YY_BREAK
+case 27:
+YY_RULE_SETUP
+#line 154 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_EQV;}
+ YY_BREAK
+case 28:
+YY_RULE_SETUP
+#line 155 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_EQ;}
+ YY_BREAK
+case 29:
+YY_RULE_SETUP
+#line 156 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_GT;}
+ YY_BREAK
+case 30:
+YY_RULE_SETUP
+#line 157 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_GE;}
+ YY_BREAK
+case 31:
+YY_RULE_SETUP
+#line 158 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_LT;}
+ YY_BREAK
+case 32:
+YY_RULE_SETUP
+#line 159 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_LE;}
+ YY_BREAK
+case 33:
+YY_RULE_SETUP
+#line 160 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_NEQV;}
+ YY_BREAK
+case 34:
+YY_RULE_SETUP
+#line 161 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_NE;}
+ YY_BREAK
+case 35:
+YY_RULE_SETUP
+#line 162 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_NOT;}
+ YY_BREAK
+case 36:
+YY_RULE_SETUP
+#line 163 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_OR;}
+ YY_BREAK
+case 37:
+YY_RULE_SETUP
+#line 164 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_XOR;}
+ YY_BREAK
+case 38:
+YY_RULE_SETUP
+#line 165 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_AND;}
+ YY_BREAK
+case 39:
+YY_RULE_SETUP
+#line 166 "fortran.lex"
+{return TOK_MODULE;}
+ YY_BREAK
+case 40:
+YY_RULE_SETUP
+#line 167 "fortran.lex"
+{return TOK_DOWHILE;}
+ YY_BREAK
+case 41:
+YY_RULE_SETUP
+#line 168 "fortran.lex"
+return TOK_ENDMODULE;
+ YY_BREAK
+case 42:
+YY_RULE_SETUP
+#line 169 "fortran.lex"
+return TOK_ENDDO;
+ YY_BREAK
+case 43:
+YY_RULE_SETUP
+#line 170 "fortran.lex"
+{return TOK_PLAINDO;}
+ YY_BREAK
+case 44:
+YY_RULE_SETUP
+#line 171 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_REAL;}
+ YY_BREAK
+case 45:
+YY_RULE_SETUP
+#line 172 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_INTEGER;}
+ YY_BREAK
+case 46:
+YY_RULE_SETUP
+#line 173 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_LOGICAL;}
+ YY_BREAK
+case 47:
+YY_RULE_SETUP
+#line 174 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_CHARACTER;}
+ YY_BREAK
+case 48:
+YY_RULE_SETUP
+#line 175 "fortran.lex"
+{return TOK_ALLOCATABLE;}
+ YY_BREAK
+case 49:
+YY_RULE_SETUP
+#line 176 "fortran.lex"
+return TOK_CLOSE;
+ YY_BREAK
+case 50:
+YY_RULE_SETUP
+#line 177 "fortran.lex"
+return TOK_INQUIRE;
+ YY_BREAK
+case 51:
+YY_RULE_SETUP
+#line 178 "fortran.lex"
+{return TOK_DIMENSION;}
+ YY_BREAK
+case 52:
+YY_RULE_SETUP
+#line 179 "fortran.lex"
+return TOK_PAUSE;
+ YY_BREAK
+case 53:
+YY_RULE_SETUP
+#line 180 "fortran.lex"
+return TOK_EQUIVALENCE;
+ YY_BREAK
+case 54:
+YY_RULE_SETUP
+#line 181 "fortran.lex"
+return TOK_STOP;
+ YY_BREAK
+case 55:
+YY_RULE_SETUP
+#line 182 "fortran.lex"
+return TOK_WHERE;
+ YY_BREAK
+case 56:
+YY_RULE_SETUP
+#line 183 "fortran.lex"
+return TOK_ENDWHERE;
+ YY_BREAK
+case 57:
+YY_RULE_SETUP
+#line 184 "fortran.lex"
+return TOK_ELSEWHERE;
+ YY_BREAK
+case 58:
+YY_RULE_SETUP
+#line 185 "fortran.lex"
+{return TOK_COMPLEX;}
+ YY_BREAK
+case 59:
+YY_RULE_SETUP
+#line 186 "fortran.lex"
+{return TOK_CONTAINS;}
+ YY_BREAK
+case 60:
+YY_RULE_SETUP
+#line 187 "fortran.lex"
+{return TOK_ONLY;}
+ YY_BREAK
+case 61:
+YY_RULE_SETUP
+#line 188 "fortran.lex"
+{return TOK_PARAMETER;}
+ YY_BREAK
+case 62:
+YY_RULE_SETUP
+#line 189 "fortran.lex"
+{return TOK_RECURSIVE;}
+ YY_BREAK
+case 63:
+YY_RULE_SETUP
+#line 190 "fortran.lex"
+{return TOK_COMMON;}
+ YY_BREAK
+case 64:
+YY_RULE_SETUP
+#line 191 "fortran.lex"
+{return TOK_GLOBAL;}
+ YY_BREAK
+case 65:
+YY_RULE_SETUP
+#line 192 "fortran.lex"
+{return TOK_EXTERNAL;}
+ YY_BREAK
+case 66:
+YY_RULE_SETUP
+#line 193 "fortran.lex"
+{return TOK_INTENT;}
+ YY_BREAK
+case 67:
+YY_RULE_SETUP
+#line 194 "fortran.lex"
+{return TOK_POINTER;}
+ YY_BREAK
+case 68:
+YY_RULE_SETUP
+#line 195 "fortran.lex"
+{return TOK_OPTIONAL;}
+ YY_BREAK
+case 69:
+YY_RULE_SETUP
+#line 196 "fortran.lex"
+{return TOK_SAVE;}
+ YY_BREAK
+case 70:
+YY_RULE_SETUP
+#line 197 "fortran.lex"
+{return TOK_TYPE;}
+ YY_BREAK
+case 71:
+YY_RULE_SETUP
+#line 198 "fortran.lex"
+{return TOK_TYPEPAR;}
+ YY_BREAK
+case 72:
+YY_RULE_SETUP
+#line 199 "fortran.lex"
+{if (inallocate == 1) return TOK_STAT; else {strcpy(yylval.na,fortrantext);return TOK_NAME;}}
+ YY_BREAK
+case 73:
+YY_RULE_SETUP
+#line 200 "fortran.lex"
+{return TOK_ENDTYPE;}
+ YY_BREAK
+case 74:
+YY_RULE_SETUP
+#line 201 "fortran.lex"
+return TOK_OPEN;
+ YY_BREAK
+case 75:
+YY_RULE_SETUP
+#line 202 "fortran.lex"
+return TOK_RETURN;
+ YY_BREAK
+case 76:
+/* rule 76 can match eol */
+YY_RULE_SETUP
+#line 203 "fortran.lex"
+return TOK_EXIT;
+ YY_BREAK
+case 77:
+YY_RULE_SETUP
+#line 204 "fortran.lex"
+return TOK_PRINT;
+ YY_BREAK
+case 78:
+YY_RULE_SETUP
+#line 205 "fortran.lex"
+{return TOK_PROCEDURE;}
+ YY_BREAK
+case 79:
+YY_RULE_SETUP
+#line 206 "fortran.lex"
+{return TOK_READ;}
+ YY_BREAK
+case 80:
+YY_RULE_SETUP
+#line 207 "fortran.lex"
+{return TOK_NAMELIST;}
+ YY_BREAK
+case 81:
+YY_RULE_SETUP
+#line 208 "fortran.lex"
+{return TOK_WRITE;}
+ YY_BREAK
+case 82:
+YY_RULE_SETUP
+#line 209 "fortran.lex"
+{return TOK_TARGET;}
+ YY_BREAK
+case 83:
+YY_RULE_SETUP
+#line 210 "fortran.lex"
+{return TOK_PUBLIC;}
+ YY_BREAK
+case 84:
+YY_RULE_SETUP
+#line 211 "fortran.lex"
+{return TOK_PRIVATE;}
+ YY_BREAK
+case 85:
+YY_RULE_SETUP
+#line 212 "fortran.lex"
+{strcpy(yylval.nac,fortrantext);return TOK_IN;}
+ YY_BREAK
+case 86:
+YY_RULE_SETUP
+#line 213 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_DATA;}
+ YY_BREAK
+case 87:
+YY_RULE_SETUP
+#line 214 "fortran.lex"
+return TOK_CONTINUE;
+ YY_BREAK
+case 88:
+YY_RULE_SETUP
+#line 215 "fortran.lex"
+{return TOK_PLAINGOTO;}
+ YY_BREAK
+case 89:
+YY_RULE_SETUP
+#line 216 "fortran.lex"
+{strcpy(yylval.nac,fortrantext);return TOK_OUT;}
+ YY_BREAK
+case 90:
+YY_RULE_SETUP
+#line 217 "fortran.lex"
+{strcpy(yylval.nac,fortrantext);return TOK_INOUT;}
+ YY_BREAK
+case 91:
+YY_RULE_SETUP
+#line 218 "fortran.lex"
+{return TOK_INTRINSIC;}
+ YY_BREAK
+case 92:
+YY_RULE_SETUP
+#line 219 "fortran.lex"
+{return TOK_THEN;}
+ YY_BREAK
+case 93:
+YY_RULE_SETUP
+#line 220 "fortran.lex"
+{return TOK_ELSEIF;}
+ YY_BREAK
+case 94:
+YY_RULE_SETUP
+#line 221 "fortran.lex"
+{return TOK_ELSE;}
+ YY_BREAK
+case 95:
+YY_RULE_SETUP
+#line 222 "fortran.lex"
+{return TOK_ENDIF;}
+ YY_BREAK
+case 96:
+YY_RULE_SETUP
+#line 223 "fortran.lex"
+{return TOK_LOGICALIF;}
+ YY_BREAK
+case 97:
+YY_RULE_SETUP
+#line 224 "fortran.lex"
+{return TOK_SUM;}
+ YY_BREAK
+case 98:
+YY_RULE_SETUP
+#line 225 "fortran.lex"
+{return TOK_MAX;}
+ YY_BREAK
+case 99:
+YY_RULE_SETUP
+#line 226 "fortran.lex"
+{return TOK_TANH;}
+ YY_BREAK
+case 100:
+YY_RULE_SETUP
+#line 227 "fortran.lex"
+{return TOK_MAXVAL;}
+ YY_BREAK
+case 101:
+YY_RULE_SETUP
+#line 228 "fortran.lex"
+{return TOK_TRIM;}
+ YY_BREAK
+case 102:
+YY_RULE_SETUP
+#line 229 "fortran.lex"
+{return TOK_SQRT;}
+ YY_BREAK
+case 103:
+YY_RULE_SETUP
+#line 230 "fortran.lex"
+{return TOK_SELECTCASE;}
+ YY_BREAK
+case 104:
+YY_RULE_SETUP
+#line 231 "fortran.lex"
+{return TOK_CASE;}
+ YY_BREAK
+case 105:
+YY_RULE_SETUP
+#line 232 "fortran.lex"
+{return TOK_CASEDEFAULT;}
+ YY_BREAK
+case 106:
+YY_RULE_SETUP
+#line 233 "fortran.lex"
+{return TOK_ENDSELECT;}
+ YY_BREAK
+case 107:
+YY_RULE_SETUP
+#line 234 "fortran.lex"
+{return TOK_FILE;}
+ YY_BREAK
+case 108:
+YY_RULE_SETUP
+#line 235 "fortran.lex"
+{return TOK_END;}
+ YY_BREAK
+case 109:
+YY_RULE_SETUP
+#line 236 "fortran.lex"
+{return TOK_ERR;}
+ YY_BREAK
+case 110:
+YY_RULE_SETUP
+#line 237 "fortran.lex"
+{return TOK_EXIST;}
+ YY_BREAK
+case 111:
+YY_RULE_SETUP
+#line 238 "fortran.lex"
+{return TOK_MIN;}
+ YY_BREAK
+case 112:
+YY_RULE_SETUP
+#line 239 "fortran.lex"
+{return TOK_NINT;}
+ YY_BREAK
+case 113:
+YY_RULE_SETUP
+#line 240 "fortran.lex"
+{return TOK_FLOAT;}
+ YY_BREAK
+case 114:
+YY_RULE_SETUP
+#line 241 "fortran.lex"
+{return TOK_EXP;}
+ YY_BREAK
+case 115:
+YY_RULE_SETUP
+#line 242 "fortran.lex"
+{return TOK_COS;}
+ YY_BREAK
+case 116:
+YY_RULE_SETUP
+#line 243 "fortran.lex"
+{return TOK_COSH;}
+ YY_BREAK
+case 117:
+YY_RULE_SETUP
+#line 244 "fortran.lex"
+{return TOK_ACOS;}
+ YY_BREAK
+case 118:
+YY_RULE_SETUP
+#line 245 "fortran.lex"
+{return TOK_SIN;}
+ YY_BREAK
+case 119:
+YY_RULE_SETUP
+#line 246 "fortran.lex"
+{return TOK_SINH;}
+ YY_BREAK
+case 120:
+YY_RULE_SETUP
+#line 247 "fortran.lex"
+{return TOK_ASIN;}
+ YY_BREAK
+case 121:
+YY_RULE_SETUP
+#line 248 "fortran.lex"
+{return TOK_LOG;}
+ YY_BREAK
+case 122:
+YY_RULE_SETUP
+#line 249 "fortran.lex"
+{return TOK_TAN;}
+ YY_BREAK
+case 123:
+YY_RULE_SETUP
+#line 250 "fortran.lex"
+{return TOK_ATAN;}
+ YY_BREAK
+case 124:
+YY_RULE_SETUP
+#line 251 "fortran.lex"
+{return TOK_CYCLE;}
+ YY_BREAK
+case 125:
+YY_RULE_SETUP
+#line 252 "fortran.lex"
+{return TOK_ABS;}
+ YY_BREAK
+case 126:
+YY_RULE_SETUP
+#line 253 "fortran.lex"
+{return TOK_MOD;}
+ YY_BREAK
+case 127:
+YY_RULE_SETUP
+#line 254 "fortran.lex"
+{return TOK_SIGN;}
+ YY_BREAK
+case 128:
+YY_RULE_SETUP
+#line 255 "fortran.lex"
+{return TOK_MINLOC;}
+ YY_BREAK
+case 129:
+YY_RULE_SETUP
+#line 256 "fortran.lex"
+{return TOK_MAXLOC;}
+ YY_BREAK
+case 130:
+YY_RULE_SETUP
+#line 257 "fortran.lex"
+{return TOK_MINVAL;}
+ YY_BREAK
+case 131:
+YY_RULE_SETUP
+#line 258 "fortran.lex"
+{return TOK_BACKSPACE;}
+ YY_BREAK
+case 132:
+YY_RULE_SETUP
+#line 259 "fortran.lex"
+{return TOK_LEFTAB;}
+ YY_BREAK
+case 133:
+YY_RULE_SETUP
+#line 260 "fortran.lex"
+{return TOK_RIGHTAB;}
+ YY_BREAK
+case 134:
+/* rule 134 can match eol */
+YY_RULE_SETUP
+#line 261 "fortran.lex"
+{return TOK_FORMAT;}
+ YY_BREAK
+case 135:
+YY_RULE_SETUP
+#line 262 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_DOUBLEPRECISION;}
+ YY_BREAK
+case 136:
+YY_RULE_SETUP
+#line 263 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_DOUBLECOMPLEX;}
+ YY_BREAK
+case 137:
+YY_RULE_SETUP
+#line 264 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_SLASH;}
+ YY_BREAK
+case 138:
+YY_RULE_SETUP
+#line 265 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_DSLASH;}
+ YY_BREAK
+case 139:
+/* rule 139 can match eol */
+YY_RULE_SETUP
+#line 266 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_CHAR_CUT;}
+ YY_BREAK
+case 140:
+YY_RULE_SETUP
+#line 267 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_CHAR_CONSTANT;}
+ YY_BREAK
+case 141:
+YY_RULE_SETUP
+#line 268 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_CHAR_MESSAGE;}
+ YY_BREAK
+case 142:
+YY_RULE_SETUP
+#line 269 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_CHAR_INT;}
+ YY_BREAK
+case 143:
+YY_RULE_SETUP
+#line 270 "fortran.lex"
+{printf("debug interfacer\n");BEGIN(donottreat);}
+ YY_BREAK
+case 144:
+/* rule 144 can match eol */
+YY_RULE_SETUP
+#line 271 "fortran.lex"
+{
+ BEGIN(INITIAL);
+ if (infixed) BEGIN(fortran77style) ;
+ if (infree) BEGIN(fortran90style) ;
+ line_num_fortran++;line_num_fortran_common++;
+ return '\n';
+ }
+ YY_BREAK
+case 145:
+YY_RULE_SETUP
+#line 278 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_NAME;}
+ YY_BREAK
+case 146:
+YY_RULE_SETUP
+#line 279 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_CSTREAL;}
+ YY_BREAK
+case 147:
+YY_RULE_SETUP
+#line 280 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_CSTREALDP;}
+ YY_BREAK
+case 148:
+YY_RULE_SETUP
+#line 281 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_CSTREALQP;}
+ YY_BREAK
+case 149:
+/* rule 149 can match eol */
+*yy_cp = (yy_hold_char); /* undo effects of setting up fortrantext */
+(yy_c_buf_p) = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up fortrantext again */
+YY_RULE_SETUP
+#line 282 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_CSTREAL;}
+ YY_BREAK
+case 150:
+YY_RULE_SETUP
+#line 283 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return TOK_CSTINT;}
+ YY_BREAK
+case 151:
+YY_RULE_SETUP
+#line 284 "fortran.lex"
+{}
+ YY_BREAK
+case 152:
+YY_RULE_SETUP
+#line 285 "fortran.lex"
+{return TOK_QUOTE;}
+ YY_BREAK
+case 153:
+YY_RULE_SETUP
+#line 286 "fortran.lex"
+{}
+ YY_BREAK
+case 154:
+YY_RULE_SETUP
+#line 287 "fortran.lex"
+{strcpy(yylval.na,fortrantext);return (int) *fortrantext;}
+ YY_BREAK
+case 155:
+YY_RULE_SETUP
+#line 288 "fortran.lex"
+{afterpercent = 1; strcpy(yylval.na,fortrantext);return (int) *fortrantext;}
+ YY_BREAK
+case 156:
+YY_RULE_SETUP
+#line 289 "fortran.lex"
+{return TOK_SEMICOLON;}
+ YY_BREAK
+case 157:
+YY_RULE_SETUP
+#line 290 "fortran.lex"
+{return (int) *fortrantext;}
+ YY_BREAK
+case 158:
+YY_RULE_SETUP
+#line 291 "fortran.lex"
+{return (int) *fortrantext;}
+ YY_BREAK
+case 159:
+YY_RULE_SETUP
+#line 292 "fortran.lex"
+{return (int) *fortrantext;}
+ YY_BREAK
+case 160:
+YY_RULE_SETUP
+#line 293 "fortran.lex"
+{return (int) *fortrantext;}
+ YY_BREAK
+case 161:
+/* rule 161 can match eol */
+YY_RULE_SETUP
+#line 294 "fortran.lex"
+{colnum=0;line_num_fortran++;line_num_fortran_common++; return (int) *fortrantext;}
+ YY_BREAK
+case 162:
+*yy_cp = (yy_hold_char); /* undo effects of setting up fortrantext */
+(yy_c_buf_p) = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up fortrantext again */
+YY_RULE_SETUP
+#line 295 "fortran.lex"
+
+ YY_BREAK
+case 163:
+YY_RULE_SETUP
+#line 296 "fortran.lex"
+{if (newlinef90 == 0) return TOK_LABEL; else newlinef90 = 0;}
+ YY_BREAK
+case 164:
+YY_RULE_SETUP
+#line 297 "fortran.lex"
+
+ YY_BREAK
+case 165:
+YY_RULE_SETUP
+#line 298 "fortran.lex"
+{colnum=colnum-1+tabsize;}
+ YY_BREAK
+case 166:
+YY_RULE_SETUP
+#line 299 "fortran.lex"
+;
+ YY_BREAK
+case 167:
+/* rule 167 can match eol */
+YY_RULE_SETUP
+#line 300 "fortran.lex"
+{line_num_fortran++;line_num_fortran_common++;newlinef90=1;colnum=0;}
+ YY_BREAK
+case 168:
+/* rule 168 can match eol */
+YY_RULE_SETUP
+#line 301 "fortran.lex"
+{line_num_fortran++;line_num_fortran_common++;colnum=0;}
+ YY_BREAK
+case 169:
+/* rule 169 can match eol */
+YY_RULE_SETUP
+#line 302 "fortran.lex"
+{
+ convert2lower(motparse1);
+ if ( strncasecmp(motparse1,"contains",8) == 0 )
+ {
+ return TOK_CONTAINS;
+ }
+ else
+ {
+ /* colnum=0;line_num_fortran++;line_num_fortran_common++;*/
+ if ( !strcasecmp(motparse1,"C$AGRIF_DO_NOT_TREAT\n"))
+ return TOK_DONOTTREAT;
+ if ( !strcasecmp(motparse1,"C$AGRIF_END_DO_NOT_TREAT\n")) return TOK_ENDDONOTTREAT;
+ unput('\n');
+ }
+ }
+ YY_BREAK
+case 170:
+/* rule 170 can match eol */
+YY_RULE_SETUP
+#line 317 "fortran.lex"
+{
+ convert2lower(&motparse1[1]);
+ if ( strncasecmp(&motparse1[1],"contains",8) == 0 )
+ {
+ return TOK_CONTAINS;
+ }
+ else
+ {
+ /* colnum=0;line_num_fortran++;line_num_fortran_common++;*/
+ if ( !strcasecmp(&motparse1[1],"C$AGRIF_DO_NOT_TREAT\n"))
+ return TOK_DONOTTREAT;
+ if ( !strcasecmp(&motparse1[1],"C$AGRIF_END_DO_NOT_TREAT\n")) return TOK_ENDDONOTTREAT;
+ unput('\n');
+ }
+ }
+ YY_BREAK
+case 171:
+/* rule 171 can match eol */
+YY_RULE_SETUP
+#line 332 "fortran.lex"
+{
+ BEGIN(donottreat);
+ }
+ YY_BREAK
+case 172:
+/* rule 172 can match eol */
+YY_RULE_SETUP
+#line 335 "fortran.lex"
+{
+ BEGIN(INITIAL);
+ if (infixed) BEGIN(fortran77style) ;
+ if (infree) BEGIN(fortran90style) ;
+ line_num_fortran++;line_num_fortran_common++;
+ return '\n';
+ }
+ YY_BREAK
+case 173:
+/* rule 173 can match eol */
+YY_RULE_SETUP
+#line 342 "fortran.lex"
+{line_num_fortran++;line_num_fortran_common++;}
+ YY_BREAK
+case 174:
+/* rule 174 can match eol */
+YY_RULE_SETUP
+#line 343 "fortran.lex"
+{
+ colnum = 0;
+ if ( !strcasecmp(motparse1,"!$AGRIF_DO_NOT_TREAT\n")) return TOK_DONOTTREAT;
+ if ( !strcasecmp(motparse1,"!$AGRIF_END_DO_NOT_TREAT\n")) return TOK_ENDDONOTTREAT;
+ }
+ YY_BREAK
+case 175:
+YY_RULE_SETUP
+#line 348 "fortran.lex"
+{
+ colnum = 0;
+ if ( !strcasecmp(motparse1,"!$AGRIF_DO_NOT_TREAT\n")) return TOK_DONOTTREAT;
+ if ( !strcasecmp(motparse1,"!$AGRIF_END_DO_NOT_TREAT\n")) return TOK_ENDDONOTTREAT;
+ }
+ YY_BREAK
+case 176:
+YY_RULE_SETUP
+#line 353 "fortran.lex"
+ECHO;
+ YY_BREAK
+#line 4224 "fortran.yy.c"
+case YY_STATE_EOF(INITIAL):
+case YY_STATE_EOF(parameter):
+case YY_STATE_EOF(character):
+case YY_STATE_EOF(donottreat):
+case YY_STATE_EOF(fortran77style):
+case YY_STATE_EOF(fortran90style):
+ yyterminate();
+
+ case YY_END_OF_BUFFER:
+ {
+ /* Amount of text matched not including the EOB char. */
+ int yy_amount_of_matched_text = (int) (yy_cp - (yytext_ptr)) - 1;
+
+ /* Undo the effects of YY_DO_BEFORE_ACTION. */
+ *yy_cp = (yy_hold_char);
+ YY_RESTORE_YY_MORE_OFFSET
+
+ if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_NEW )
+ {
+ /* We're scanning a new file or input source. It's
+ * possible that this happened because the user
+ * just pointed fortranin at a new source and called
+ * fortranlex(). If so, then we have to assure
+ * consistency between YY_CURRENT_BUFFER and our
+ * globals. Here is the right place to do so, because
+ * this is the first action (other than possibly a
+ * back-up) that will match for the new input source.
+ */
+ (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars;
+ YY_CURRENT_BUFFER_LVALUE->yy_input_file = fortranin;
+ YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = YY_BUFFER_NORMAL;
+ }
+
+ /* Note that here we test for yy_c_buf_p "<=" to the position
+ * of the first EOB in the buffer, since yy_c_buf_p will
+ * already have been incremented past the NUL character
+ * (since all states make transitions on EOB to the
+ * end-of-buffer state). Contrast this with the test
+ * in input().
+ */
+ if ( (yy_c_buf_p) <= &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] )
+ { /* This was really a NUL. */
+ yy_state_type yy_next_state;
+
+ (yy_c_buf_p) = (yytext_ptr) + yy_amount_of_matched_text;
+
+ yy_current_state = yy_get_previous_state( );
+
+ /* Okay, we're now positioned to make the NUL
+ * transition. We couldn't have
+ * yy_get_previous_state() go ahead and do it
+ * for us because it doesn't know how to deal
+ * with the possibility of jamming (and we don't
+ * want to build jamming into it because then it
+ * will run more slowly).
+ */
+
+ yy_next_state = yy_try_NUL_trans( yy_current_state );
+
+ yy_bp = (yytext_ptr) + YY_MORE_ADJ;
+
+ if ( yy_next_state )
+ {
+ /* Consume the NUL. */
+ yy_cp = ++(yy_c_buf_p);
+ yy_current_state = yy_next_state;
+ goto yy_match;
+ }
+
+ else
+ {
+ yy_cp = (yy_c_buf_p);
+ goto yy_find_action;
+ }
+ }
+
+ else switch ( yy_get_next_buffer( ) )
+ {
+ case EOB_ACT_END_OF_FILE:
+ {
+ (yy_did_buffer_switch_on_eof) = 0;
+
+ if ( fortranwrap( ) )
+ {
+ /* Note: because we've taken care in
+ * yy_get_next_buffer() to have set up
+ * fortrantext, we can now set up
+ * yy_c_buf_p so that if some total
+ * hoser (like flex itself) wants to
+ * call the scanner after we return the
+ * YY_NULL, it'll still work - another
+ * YY_NULL will get returned.
+ */
+ (yy_c_buf_p) = (yytext_ptr) + YY_MORE_ADJ;
+
+ yy_act = YY_STATE_EOF(YY_START);
+ goto do_action;
+ }
+
+ else
+ {
+ if ( ! (yy_did_buffer_switch_on_eof) )
+ YY_NEW_FILE;
+ }
+ break;
+ }
+
+ case EOB_ACT_CONTINUE_SCAN:
+ (yy_c_buf_p) =
+ (yytext_ptr) + yy_amount_of_matched_text;
+
+ yy_current_state = yy_get_previous_state( );
+
+ yy_cp = (yy_c_buf_p);
+ yy_bp = (yytext_ptr) + YY_MORE_ADJ;
+ goto yy_match;
+
+ case EOB_ACT_LAST_MATCH:
+ (yy_c_buf_p) =
+ &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)];
+
+ yy_current_state = yy_get_previous_state( );
+
+ yy_cp = (yy_c_buf_p);
+ yy_bp = (yytext_ptr) + YY_MORE_ADJ;
+ goto yy_find_action;
+ }
+ break;
+ }
+
+ default:
+ YY_FATAL_ERROR(
+ "fatal flex scanner internal error--no action found" );
+ } /* end of action switch */
+ } /* end of scanning one token */
+} /* end of fortranlex */
+
+/* yy_get_next_buffer - try to read in a new buffer
+ *
+ * Returns a code representing an action:
+ * EOB_ACT_LAST_MATCH -
+ * EOB_ACT_CONTINUE_SCAN - continue scanning from current position
+ * EOB_ACT_END_OF_FILE - end of file
+ */
+static int yy_get_next_buffer (void)
+{
+ register char *dest = YY_CURRENT_BUFFER_LVALUE->yy_ch_buf;
+ register char *source = (yytext_ptr);
+ register int number_to_move, i;
+ int ret_val;
+
+ if ( (yy_c_buf_p) > &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] )
+ YY_FATAL_ERROR(
+ "fatal flex scanner internal error--end of buffer missed" );
+
+ if ( YY_CURRENT_BUFFER_LVALUE->yy_fill_buffer == 0 )
+ { /* Don't try to fill the buffer, so this is an EOF. */
+ if ( (yy_c_buf_p) - (yytext_ptr) - YY_MORE_ADJ == 1 )
+ {
+ /* We matched a single character, the EOB, so
+ * treat this as a final EOF.
+ */
+ return EOB_ACT_END_OF_FILE;
+ }
+
+ else
+ {
+ /* We matched some text prior to the EOB, first
+ * process it.
+ */
+ return EOB_ACT_LAST_MATCH;
+ }
+ }
+
+ /* Try to read more data. */
+
+ /* First move last chars to start of buffer. */
+ number_to_move = (int) ((yy_c_buf_p) - (yytext_ptr)) - 1;
+
+ for ( i = 0; i < number_to_move; ++i )
+ *(dest++) = *(source++);
+
+ if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_EOF_PENDING )
+ /* don't do the read, it's not guaranteed to return an EOF,
+ * just force an EOF
+ */
+ YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars) = 0;
+
+ else
+ {
+ yy_size_t num_to_read =
+ YY_CURRENT_BUFFER_LVALUE->yy_buf_size - number_to_move - 1;
+
+ while ( num_to_read <= 0 )
+ { /* Not enough room in the buffer - grow it. */
+
+ /* just a shorter name for the current buffer */
+ YY_BUFFER_STATE b = YY_CURRENT_BUFFER;
+
+ int yy_c_buf_p_offset =
+ (int) ((yy_c_buf_p) - b->yy_ch_buf);
+
+ if ( b->yy_is_our_buffer )
+ {
+ yy_size_t new_size = b->yy_buf_size * 2;
+
+ if ( new_size <= 0 )
+ b->yy_buf_size += b->yy_buf_size / 8;
+ else
+ b->yy_buf_size *= 2;
+
+ b->yy_ch_buf = (char *)
+ /* Include room in for 2 EOB chars. */
+ fortranrealloc((void *) b->yy_ch_buf,b->yy_buf_size + 2 );
+ }
+ else
+ /* Can't grow it, we don't own it. */
+ b->yy_ch_buf = 0;
+
+ if ( ! b->yy_ch_buf )
+ YY_FATAL_ERROR(
+ "fatal error - scanner input buffer overflow" );
+
+ (yy_c_buf_p) = &b->yy_ch_buf[yy_c_buf_p_offset];
+
+ num_to_read = YY_CURRENT_BUFFER_LVALUE->yy_buf_size -
+ number_to_move - 1;
+
+ }
+
+ if ( num_to_read > YY_READ_BUF_SIZE )
+ num_to_read = YY_READ_BUF_SIZE;
+
+ /* Read in more data. */
+ YY_INPUT( (&YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]),
+ (yy_n_chars), num_to_read );
+
+ YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars);
+ }
+
+ if ( (yy_n_chars) == 0 )
+ {
+ if ( number_to_move == YY_MORE_ADJ )
+ {
+ ret_val = EOB_ACT_END_OF_FILE;
+ fortranrestart(fortranin );
+ }
+
+ else
+ {
+ ret_val = EOB_ACT_LAST_MATCH;
+ YY_CURRENT_BUFFER_LVALUE->yy_buffer_status =
+ YY_BUFFER_EOF_PENDING;
+ }
+ }
+
+ else
+ ret_val = EOB_ACT_CONTINUE_SCAN;
+
+ if ((yy_size_t) ((yy_n_chars) + number_to_move) > YY_CURRENT_BUFFER_LVALUE->yy_buf_size) {
+ /* Extend the array by 50%, plus the number we really need. */
+ yy_size_t new_size = (yy_n_chars) + number_to_move + ((yy_n_chars) >> 1);
+ YY_CURRENT_BUFFER_LVALUE->yy_ch_buf = (char *) fortranrealloc((void *) YY_CURRENT_BUFFER_LVALUE->yy_ch_buf,new_size );
+ if ( ! YY_CURRENT_BUFFER_LVALUE->yy_ch_buf )
+ YY_FATAL_ERROR( "out of dynamic memory in yy_get_next_buffer()" );
+ }
+
+ (yy_n_chars) += number_to_move;
+ YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] = YY_END_OF_BUFFER_CHAR;
+ YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] = YY_END_OF_BUFFER_CHAR;
+
+ (yytext_ptr) = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[0];
+
+ return ret_val;
+}
+
+/* yy_get_previous_state - get the state just before the EOB char was reached */
+
+ static yy_state_type yy_get_previous_state (void)
+{
+ register yy_state_type yy_current_state;
+ register char *yy_cp;
+
+ yy_current_state = (yy_start);
+ yy_current_state += YY_AT_BOL();
+
+ for ( yy_cp = (yytext_ptr) + YY_MORE_ADJ; yy_cp < (yy_c_buf_p); ++yy_cp )
+ {
+ register YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1);
+ if ( yy_accept[yy_current_state] )
+ {
+ (yy_last_accepting_state) = yy_current_state;
+ (yy_last_accepting_cpos) = yy_cp;
+ }
+ while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state )
+ {
+ yy_current_state = (int) yy_def[yy_current_state];
+ if ( yy_current_state >= 1162 )
+ yy_c = yy_meta[(unsigned int) yy_c];
+ }
+ yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c];
+ }
+
+ return yy_current_state;
+}
+
+/* yy_try_NUL_trans - try to make a transition on the NUL character
+ *
+ * synopsis
+ * next_state = yy_try_NUL_trans( current_state );
+ */
+ static yy_state_type yy_try_NUL_trans (yy_state_type yy_current_state )
+{
+ register int yy_is_jam;
+ register char *yy_cp = (yy_c_buf_p);
+
+ register YY_CHAR yy_c = 1;
+ if ( yy_accept[yy_current_state] )
+ {
+ (yy_last_accepting_state) = yy_current_state;
+ (yy_last_accepting_cpos) = yy_cp;
+ }
+ while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state )
+ {
+ yy_current_state = (int) yy_def[yy_current_state];
+ if ( yy_current_state >= 1162 )
+ yy_c = yy_meta[(unsigned int) yy_c];
+ }
+ yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c];
+ yy_is_jam = (yy_current_state == 1161);
+
+ return yy_is_jam ? 0 : yy_current_state;
+}
+
+ static void yyunput (int c, register char * yy_bp )
+{
+ register char *yy_cp;
+
+ yy_cp = (yy_c_buf_p);
+
+ /* undo effects of setting up fortrantext */
+ *yy_cp = (yy_hold_char);
+
+ if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 )
+ { /* need to shift things up to make room */
+ /* +2 for EOB chars. */
+ register yy_size_t number_to_move = (yy_n_chars) + 2;
+ register char *dest = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[
+ YY_CURRENT_BUFFER_LVALUE->yy_buf_size + 2];
+ register char *source =
+ &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move];
+
+ while ( source > YY_CURRENT_BUFFER_LVALUE->yy_ch_buf )
+ *--dest = *--source;
+
+ yy_cp += (int) (dest - source);
+ yy_bp += (int) (dest - source);
+ YY_CURRENT_BUFFER_LVALUE->yy_n_chars =
+ (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_buf_size;
+
+ if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 )
+ YY_FATAL_ERROR( "flex scanner push-back overflow" );
+ }
+
+ *--yy_cp = (char) c;
+
+ (yytext_ptr) = yy_bp;
+ (yy_hold_char) = *yy_cp;
+ (yy_c_buf_p) = yy_cp;
+}
+
+#ifndef YY_NO_INPUT
+#ifdef __cplusplus
+ static int yyinput (void)
+#else
+ static int input (void)
+#endif
+
+{
+ int c;
+
+ *(yy_c_buf_p) = (yy_hold_char);
+
+ if ( *(yy_c_buf_p) == YY_END_OF_BUFFER_CHAR )
+ {
+ /* yy_c_buf_p now points to the character we want to return.
+ * If this occurs *before* the EOB characters, then it's a
+ * valid NUL; if not, then we've hit the end of the buffer.
+ */
+ if ( (yy_c_buf_p) < &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] )
+ /* This was really a NUL. */
+ *(yy_c_buf_p) = '\0';
+
+ else
+ { /* need more input */
+ yy_size_t offset = (yy_c_buf_p) - (yytext_ptr);
+ ++(yy_c_buf_p);
+
+ switch ( yy_get_next_buffer( ) )
+ {
+ case EOB_ACT_LAST_MATCH:
+ /* This happens because yy_g_n_b()
+ * sees that we've accumulated a
+ * token and flags that we need to
+ * try matching the token before
+ * proceeding. But for input(),
+ * there's no matching to consider.
+ * So convert the EOB_ACT_LAST_MATCH
+ * to EOB_ACT_END_OF_FILE.
+ */
+
+ /* Reset buffer status. */
+ fortranrestart(fortranin );
+
+ /*FALLTHROUGH*/
+
+ case EOB_ACT_END_OF_FILE:
+ {
+ if ( fortranwrap( ) )
+ return 0;
+
+ if ( ! (yy_did_buffer_switch_on_eof) )
+ YY_NEW_FILE;
+#ifdef __cplusplus
+ return yyinput();
+#else
+ return input();
+#endif
+ }
+
+ case EOB_ACT_CONTINUE_SCAN:
+ (yy_c_buf_p) = (yytext_ptr) + offset;
+ break;
+ }
+ }
+ }
+
+ c = *(unsigned char *) (yy_c_buf_p); /* cast for 8-bit char's */
+ *(yy_c_buf_p) = '\0'; /* preserve fortrantext */
+ (yy_hold_char) = *++(yy_c_buf_p);
+
+ YY_CURRENT_BUFFER_LVALUE->yy_at_bol = (c == '\n');
+
+ return c;
+}
+#endif /* ifndef YY_NO_INPUT */
+
+/** Immediately switch to a different input stream.
+ * @param input_file A readable stream.
+ *
+ * @note This function does not reset the start condition to @c INITIAL .
+ */
+ void fortranrestart (FILE * input_file )
+{
+
+ if ( ! YY_CURRENT_BUFFER ){
+ fortranensure_buffer_stack ();
+ YY_CURRENT_BUFFER_LVALUE =
+ fortran_create_buffer(fortranin,YY_BUF_SIZE );
+ }
+
+ fortran_init_buffer(YY_CURRENT_BUFFER,input_file );
+ fortran_load_buffer_state( );
+}
+
+/** Switch to a different input buffer.
+ * @param new_buffer The new input buffer.
+ *
+ */
+ void fortran_switch_to_buffer (YY_BUFFER_STATE new_buffer )
+{
+
+ /* TODO. We should be able to replace this entire function body
+ * with
+ * fortranpop_buffer_state();
+ * fortranpush_buffer_state(new_buffer);
+ */
+ fortranensure_buffer_stack ();
+ if ( YY_CURRENT_BUFFER == new_buffer )
+ return;
+
+ if ( YY_CURRENT_BUFFER )
+ {
+ /* Flush out information for old buffer. */
+ *(yy_c_buf_p) = (yy_hold_char);
+ YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p);
+ YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars);
+ }
+
+ YY_CURRENT_BUFFER_LVALUE = new_buffer;
+ fortran_load_buffer_state( );
+
+ /* We don't actually know whether we did this switch during
+ * EOF (fortranwrap()) processing, but the only time this flag
+ * is looked at is after fortranwrap() is called, so it's safe
+ * to go ahead and always set it.
+ */
+ (yy_did_buffer_switch_on_eof) = 1;
+}
+
+static void fortran_load_buffer_state (void)
+{
+ (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars;
+ (yytext_ptr) = (yy_c_buf_p) = YY_CURRENT_BUFFER_LVALUE->yy_buf_pos;
+ fortranin = YY_CURRENT_BUFFER_LVALUE->yy_input_file;
+ (yy_hold_char) = *(yy_c_buf_p);
+}
+
+/** Allocate and initialize an input buffer state.
+ * @param file A readable stream.
+ * @param size The character buffer size in bytes. When in doubt, use @c YY_BUF_SIZE.
+ *
+ * @return the allocated buffer state.
+ */
+ YY_BUFFER_STATE fortran_create_buffer (FILE * file, int size )
+{
+ YY_BUFFER_STATE b;
+
+ b = (YY_BUFFER_STATE) fortranalloc(sizeof( struct yy_buffer_state ) );
+ if ( ! b )
+ YY_FATAL_ERROR( "out of dynamic memory in fortran_create_buffer()" );
+
+ b->yy_buf_size = size;
+
+ /* yy_ch_buf has to be 2 characters longer than the size given because
+ * we need to put in 2 end-of-buffer characters.
+ */
+ b->yy_ch_buf = (char *) fortranalloc(b->yy_buf_size + 2 );
+ if ( ! b->yy_ch_buf )
+ YY_FATAL_ERROR( "out of dynamic memory in fortran_create_buffer()" );
+
+ b->yy_is_our_buffer = 1;
+
+ fortran_init_buffer(b,file );
+
+ return b;
+}
+
+/** Destroy the buffer.
+ * @param b a buffer created with fortran_create_buffer()
+ *
+ */
+ void fortran_delete_buffer (YY_BUFFER_STATE b )
+{
+
+ if ( ! b )
+ return;
+
+ if ( b == YY_CURRENT_BUFFER ) /* Not sure if we should pop here. */
+ YY_CURRENT_BUFFER_LVALUE = (YY_BUFFER_STATE) 0;
+
+ if ( b->yy_is_our_buffer )
+ fortranfree((void *) b->yy_ch_buf );
+
+ fortranfree((void *) b );
+}
+
+#ifndef __cplusplus
+extern int isatty (int );
+#endif /* __cplusplus */
+
+/* Initializes or reinitializes a buffer.
+ * This function is sometimes called more than once on the same buffer,
+ * such as during a fortranrestart() or at EOF.
+ */
+ static void fortran_init_buffer (YY_BUFFER_STATE b, FILE * file )
+
+{
+ int oerrno = errno;
+
+ fortran_flush_buffer(b );
+
+ b->yy_input_file = file;
+ b->yy_fill_buffer = 1;
+
+ /* If b is the current buffer, then fortran_init_buffer was _probably_
+ * called from fortranrestart() or through yy_get_next_buffer.
+ * In that case, we don't want to reset the lineno or column.
+ */
+ if (b != YY_CURRENT_BUFFER){
+ b->yy_bs_lineno = 1;
+ b->yy_bs_column = 0;
+ }
+
+ b->yy_is_interactive = file ? (isatty( fileno(file) ) > 0) : 0;
+
+ errno = oerrno;
+}
+
+/** Discard all buffered characters. On the next scan, YY_INPUT will be called.
+ * @param b the buffer state to be flushed, usually @c YY_CURRENT_BUFFER.
+ *
+ */
+ void fortran_flush_buffer (YY_BUFFER_STATE b )
+{
+ if ( ! b )
+ return;
+
+ b->yy_n_chars = 0;
+
+ /* We always need two end-of-buffer characters. The first causes
+ * a transition to the end-of-buffer state. The second causes
+ * a jam in that state.
+ */
+ b->yy_ch_buf[0] = YY_END_OF_BUFFER_CHAR;
+ b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR;
+
+ b->yy_buf_pos = &b->yy_ch_buf[0];
+
+ b->yy_at_bol = 1;
+ b->yy_buffer_status = YY_BUFFER_NEW;
+
+ if ( b == YY_CURRENT_BUFFER )
+ fortran_load_buffer_state( );
+}
+
+/** Pushes the new state onto the stack. The new state becomes
+ * the current state. This function will allocate the stack
+ * if necessary.
+ * @param new_buffer The new state.
+ *
+ */
+void fortranpush_buffer_state (YY_BUFFER_STATE new_buffer )
+{
+ if (new_buffer == NULL)
+ return;
+
+ fortranensure_buffer_stack();
+
+ /* This block is copied from fortran_switch_to_buffer. */
+ if ( YY_CURRENT_BUFFER )
+ {
+ /* Flush out information for old buffer. */
+ *(yy_c_buf_p) = (yy_hold_char);
+ YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p);
+ YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars);
+ }
+
+ /* Only push if top exists. Otherwise, replace top. */
+ if (YY_CURRENT_BUFFER)
+ (yy_buffer_stack_top)++;
+ YY_CURRENT_BUFFER_LVALUE = new_buffer;
+
+ /* copied from fortran_switch_to_buffer. */
+ fortran_load_buffer_state( );
+ (yy_did_buffer_switch_on_eof) = 1;
+}
+
+/** Removes and deletes the top of the stack, if present.
+ * The next element becomes the new top.
+ *
+ */
+void fortranpop_buffer_state (void)
+{
+ if (!YY_CURRENT_BUFFER)
+ return;
+
+ fortran_delete_buffer(YY_CURRENT_BUFFER );
+ YY_CURRENT_BUFFER_LVALUE = NULL;
+ if ((yy_buffer_stack_top) > 0)
+ --(yy_buffer_stack_top);
+
+ if (YY_CURRENT_BUFFER) {
+ fortran_load_buffer_state( );
+ (yy_did_buffer_switch_on_eof) = 1;
+ }
+}
+
+/* Allocates the stack if it does not exist.
+ * Guarantees space for at least one push.
+ */
+static void fortranensure_buffer_stack (void)
+{
+ yy_size_t num_to_alloc;
+
+ if (!(yy_buffer_stack)) {
+
+ /* First allocation is just for 2 elements, since we don't know if this
+ * scanner will even need a stack. We use 2 instead of 1 to avoid an
+ * immediate realloc on the next call.
+ */
+ num_to_alloc = 1;
+ (yy_buffer_stack) = (struct yy_buffer_state**)fortranalloc
+ (num_to_alloc * sizeof(struct yy_buffer_state*)
+ );
+ if ( ! (yy_buffer_stack) )
+ YY_FATAL_ERROR( "out of dynamic memory in fortranensure_buffer_stack()" );
+
+ memset((yy_buffer_stack), 0, num_to_alloc * sizeof(struct yy_buffer_state*));
+
+ (yy_buffer_stack_max) = num_to_alloc;
+ (yy_buffer_stack_top) = 0;
+ return;
+ }
+
+ if ((yy_buffer_stack_top) >= ((yy_buffer_stack_max)) - 1){
+
+ /* Increase the buffer to prepare for a possible push. */
+ int grow_size = 8 /* arbitrary grow size */;
+
+ num_to_alloc = (yy_buffer_stack_max) + grow_size;
+ (yy_buffer_stack) = (struct yy_buffer_state**)fortranrealloc
+ ((yy_buffer_stack),
+ num_to_alloc * sizeof(struct yy_buffer_state*)
+ );
+ if ( ! (yy_buffer_stack) )
+ YY_FATAL_ERROR( "out of dynamic memory in fortranensure_buffer_stack()" );
+
+ /* zero only the new slots.*/
+ memset((yy_buffer_stack) + (yy_buffer_stack_max), 0, grow_size * sizeof(struct yy_buffer_state*));
+ (yy_buffer_stack_max) = num_to_alloc;
+ }
+}
+
+/** Setup the input buffer state to scan directly from a user-specified character buffer.
+ * @param base the character buffer
+ * @param size the size in bytes of the character buffer
+ *
+ * @return the newly allocated buffer state object.
+ */
+YY_BUFFER_STATE fortran_scan_buffer (char * base, yy_size_t size )
+{
+ YY_BUFFER_STATE b;
+
+ if ( size < 2 ||
+ base[size-2] != YY_END_OF_BUFFER_CHAR ||
+ base[size-1] != YY_END_OF_BUFFER_CHAR )
+ /* They forgot to leave room for the EOB's. */
+ return 0;
+
+ b = (YY_BUFFER_STATE) fortranalloc(sizeof( struct yy_buffer_state ) );
+ if ( ! b )
+ YY_FATAL_ERROR( "out of dynamic memory in fortran_scan_buffer()" );
+
+ b->yy_buf_size = size - 2; /* "- 2" to take care of EOB's */
+ b->yy_buf_pos = b->yy_ch_buf = base;
+ b->yy_is_our_buffer = 0;
+ b->yy_input_file = 0;
+ b->yy_n_chars = b->yy_buf_size;
+ b->yy_is_interactive = 0;
+ b->yy_at_bol = 1;
+ b->yy_fill_buffer = 0;
+ b->yy_buffer_status = YY_BUFFER_NEW;
+
+ fortran_switch_to_buffer(b );
+
+ return b;
+}
+
+/** Setup the input buffer state to scan a string. The next call to fortranlex() will
+ * scan from a @e copy of @a str.
+ * @param yystr a NUL-terminated string to scan
+ *
+ * @return the newly allocated buffer state object.
+ * @note If you want to scan bytes that may contain NUL values, then use
+ * fortran_scan_bytes() instead.
+ */
+YY_BUFFER_STATE fortran_scan_string (yyconst char * yystr )
+{
+
+ return fortran_scan_bytes(yystr,strlen(yystr) );
+}
+
+/** Setup the input buffer state to scan the given bytes. The next call to fortranlex() will
+ * scan from a @e copy of @a bytes.
+ * @param bytes the byte buffer to scan
+ * @param len the number of bytes in the buffer pointed to by @a bytes.
+ *
+ * @return the newly allocated buffer state object.
+ */
+YY_BUFFER_STATE fortran_scan_bytes (yyconst char * yybytes, yy_size_t _yybytes_len )
+{
+ YY_BUFFER_STATE b;
+ char *buf;
+ yy_size_t n, i;
+
+ /* Get memory for full buffer, including space for trailing EOB's. */
+ n = _yybytes_len + 2;
+ buf = (char *) fortranalloc(n );
+ if ( ! buf )
+ YY_FATAL_ERROR( "out of dynamic memory in fortran_scan_bytes()" );
+
+ for ( i = 0; i < _yybytes_len; ++i )
+ buf[i] = yybytes[i];
+
+ buf[_yybytes_len] = buf[_yybytes_len+1] = YY_END_OF_BUFFER_CHAR;
+
+ b = fortran_scan_buffer(buf,n );
+ if ( ! b )
+ YY_FATAL_ERROR( "bad buffer in fortran_scan_bytes()" );
+
+ /* It's okay to grow etc. this buffer, and we should throw it
+ * away when we're done.
+ */
+ b->yy_is_our_buffer = 1;
+
+ return b;
+}
+
+#ifndef YY_EXIT_FAILURE
+#define YY_EXIT_FAILURE 2
+#endif
+
+static void yy_fatal_error (yyconst char* msg )
+{
+ (void) fprintf( stderr, "%s\n", msg );
+ exit( YY_EXIT_FAILURE );
+}
+
+/* Redefine yyless() so it works in section 3 code. */
+
+#undef yyless
+#define yyless(n) \
+ do \
+ { \
+ /* Undo effects of setting up fortrantext. */ \
+ int yyless_macro_arg = (n); \
+ YY_LESS_LINENO(yyless_macro_arg);\
+ fortrantext[fortranleng] = (yy_hold_char); \
+ (yy_c_buf_p) = fortrantext + yyless_macro_arg; \
+ (yy_hold_char) = *(yy_c_buf_p); \
+ *(yy_c_buf_p) = '\0'; \
+ fortranleng = yyless_macro_arg; \
+ } \
+ while ( 0 )
+
+/* Accessor methods (get/set functions) to struct members. */
+
+/** Get the current line number.
+ *
+ */
+int fortranget_lineno (void)
+{
+
+ return fortranlineno;
+}
+
+/** Get the input stream.
+ *
+ */
+FILE *fortranget_in (void)
+{
+ return fortranin;
+}
+
+/** Get the output stream.
+ *
+ */
+FILE *fortranget_out (void)
+{
+ return fortranout;
+}
+
+/** Get the length of the current token.
+ *
+ */
+yy_size_t fortranget_leng (void)
+{
+ return fortranleng;
+}
+
+/** Get the current token.
+ *
+ */
+
+char *fortranget_text (void)
+{
+ return fortrantext;
+}
+
+/** Set the current line number.
+ * @param line_number
+ *
+ */
+void fortranset_lineno (int line_number )
+{
+
+ fortranlineno = line_number;
+}
+
+/** Set the input stream. This does not discard the current
+ * input buffer.
+ * @param in_str A readable stream.
+ *
+ * @see fortran_switch_to_buffer
+ */
+void fortranset_in (FILE * in_str )
+{
+ fortranin = in_str ;
+}
+
+void fortranset_out (FILE * out_str )
+{
+ fortranout = out_str ;
+}
+
+int fortranget_debug (void)
+{
+ return fortran_flex_debug;
+}
+
+void fortranset_debug (int bdebug )
+{
+ fortran_flex_debug = bdebug ;
+}
+
+static int yy_init_globals (void)
+{
+ /* Initialization is the same as for the non-reentrant scanner.
+ * This function is called from fortranlex_destroy(), so don't allocate here.
+ */
+
+ (yy_buffer_stack) = 0;
+ (yy_buffer_stack_top) = 0;
+ (yy_buffer_stack_max) = 0;
+ (yy_c_buf_p) = (char *) 0;
+ (yy_init) = 0;
+ (yy_start) = 0;
+
+/* Defined in main.c */
+#ifdef YY_STDINIT
+ fortranin = stdin;
+ fortranout = stdout;
+#else
+ fortranin = (FILE *) 0;
+ fortranout = (FILE *) 0;
+#endif
+
+ /* For future reference: Set errno on error, since we are called by
+ * fortranlex_init()
+ */
+ return 0;
+}
+
+/* fortranlex_destroy is for both reentrant and non-reentrant scanners. */
+int fortranlex_destroy (void)
+{
+
+ /* Pop the buffer stack, destroying each element. */
+ while(YY_CURRENT_BUFFER){
+ fortran_delete_buffer(YY_CURRENT_BUFFER );
+ YY_CURRENT_BUFFER_LVALUE = NULL;
+ fortranpop_buffer_state();
+ }
+
+ /* Destroy the stack itself. */
+ fortranfree((yy_buffer_stack) );
+ (yy_buffer_stack) = NULL;
+
+ /* Reset the globals. This is important in a non-reentrant scanner so the next time
+ * fortranlex() is called, initialization will occur. */
+ yy_init_globals( );
+
+ return 0;
+}
+
+/*
+ * Internal utility routines.
+ */
+
+#ifndef yytext_ptr
+static void yy_flex_strncpy (char* s1, yyconst char * s2, int n )
+{
+ register int i;
+ for ( i = 0; i < n; ++i )
+ s1[i] = s2[i];
+}
+#endif
+
+#ifdef YY_NEED_STRLEN
+static int yy_flex_strlen (yyconst char * s )
+{
+ register int n;
+ for ( n = 0; s[n]; ++n )
+ ;
+
+ return n;
+}
+#endif
+
+void *fortranalloc (yy_size_t size )
+{
+ return (void *) malloc( size );
+}
+
+void *fortranrealloc (void * ptr, yy_size_t size )
+{
+ /* The cast to (char *) in the following accommodates both
+ * implementations that use char* generic pointers, and those
+ * that use void* generic pointers. It works with the latter
+ * because both ANSI C and C++ allow castless assignment from
+ * any pointer type to void*, and deal with argument conversions
+ * as though doing an assignment.
+ */
+ return (void *) realloc( (char *) ptr, size );
+}
+
+void fortranfree (void * ptr )
+{
+ free( (char *) ptr ); /* see fortranrealloc() for (char *) cast */
+}
+
+#define YYTABLES_NAME "yytables"
+
+#line 353 "fortran.lex"
+
+
+
+fortranerror(char *s)
+{
+ if (!strcasecmp(curfile,mainfile))
+ {
+ printf("%s line %d, file %s motclef = %s\n",s,line_num_fortran,curfile,fortrantext);
+ }
+ else
+ {
+ printf("%s line %d, file %s motclef = %s curbuf = %s\n",s,line_num_fortran_common,curfile,fortrantext,curbuf);
+ }
+/* exit(0);*/
+}
+
+int fortranwrap()
+{
+}
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/OPA_SRC/C1D/dynnxt_c1d.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/OPA_SRC/C1D/dynnxt_c1d.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/OPA_SRC/C1D/dynnxt_c1d.F90 (revision 8155)
@@ -0,0 +1,103 @@
+MODULE dynnxt_c1d
+ !!======================================================================
+ !! *** MODULE dynnxt_c1d ***
+ !! Ocean dynamics: time stepping in 1D configuration
+ !!======================================================================
+ !! History : 2.0 ! 2004-10 (C. Ethe) Original code from dynnxt.F90
+ !! 3.0 ! 2008-04 (G.madec) Style only
+ !!----------------------------------------------------------------------
+#if defined key_c1d
+ !!----------------------------------------------------------------------
+ !! 'key_c1d' 1D Configuration
+ !!----------------------------------------------------------------------
+ !! dyn_nxt_c1d : update the horizontal velocity from the momentum trend
+ !!----------------------------------------------------------------------
+ USE oce ! ocean dynamics and tracers
+ USE dom_oce ! ocean space and time domain
+ USE in_out_manager ! I/O manager
+ USE lbclnk ! lateral boundary condition (or mpp link)
+ USE prtctl ! Print control
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC dyn_nxt_c1d ! routine called by step.F90
+ !!----------------------------------------------------------------------
+ !! NEMO/C1D 3.3 , NEMO Consortium (2010)
+ !! $Id$
+ !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE dyn_nxt_c1d ( kt )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE dyn_nxt_c1d ***
+ !!
+ !! ** Purpose : Compute the after horizontal velocity from the momentum trend.
+ !!
+ !! ** Method : Apply lateral boundary conditions on the trends (ua,va)
+ !! through calls to routine lbc_lnk.
+ !! After velocity is compute using a leap-frog scheme environment:
+ !! (ua,va) = (ub,vb) + 2 rdt (ua,va)
+ !! Time filter applied on now horizontal velocity to avoid the
+ !! divergence of two consecutive time-steps and swap of dynamics
+ !! arrays to start the next time step:
+ !! (ub,vb) = (un,vn) + atfp [ (ub,vb) + (ua,va) - 2 (un,vn) ]
+ !! (un,vn) = (ua,va)
+ !!
+ !! ** Action : - Update ub,vb arrays, the before horizontal velocity
+ !! - Update un,vn arrays, the now horizontal velocity
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT( in ) :: kt ! ocean time-step index
+ !!
+ INTEGER :: jk ! dummy loop indices
+ REAL(wp) :: z2dt ! temporary scalar
+ !!----------------------------------------------------------------------
+
+ IF( kt == nit000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'dyn_nxt_c1d : time stepping on 1D configuation'
+ IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+ ENDIF
+
+ z2dt = 2._wp * rdt ! Local constant initialization
+ IF( neuler == 0 .AND. kt == nit000 ) z2dt = rdt
+
+ CALL lbc_lnk( ua, 'U', -1. ) ; CALL lbc_lnk( va, 'V', -1. ) ! Lateral boundary conditions
+
+ DO jk = 1, jpkm1 ! Next Velocity
+ ua(:,:,jk) = ( ub(:,:,jk) + z2dt * ua(:,:,jk) ) * umask(:,:,jk)
+ va(:,:,jk) = ( vb(:,:,jk) + z2dt * va(:,:,jk) ) * vmask(:,:,jk)
+ END DO
+
+ DO jk = 1, jpkm1 ! Time filter and swap of dynamics arrays
+ IF( neuler == 0 .AND. kt == nit000 ) THEN ! Euler (forward) time stepping
+ ub(:,:,jk) = un(:,:,jk)
+ vb(:,:,jk) = vn(:,:,jk)
+ un(:,:,jk) = ua(:,:,jk)
+ vn(:,:,jk) = va(:,:,jk)
+ ELSE ! Leap-frog time stepping
+ ub(:,:,jk) = atfp * ( ub(:,:,jk) + ua(:,:,jk) ) + atfp1 * un(:,:,jk)
+ vb(:,:,jk) = atfp * ( vb(:,:,jk) + va(:,:,jk) ) + atfp1 * vn(:,:,jk)
+ un(:,:,jk) = ua(:,:,jk)
+ vn(:,:,jk) = va(:,:,jk)
+ ENDIF
+ END DO
+
+ IF(ln_ctl) CALL prt_ctl( tab3d_1=un, clinfo1=' nxt_c1d - Un: ', mask1=umask, &
+ & tab3d_2=vn, clinfo2=' Vn: ' , mask2=vmask )
+ !
+ END SUBROUTINE dyn_nxt_c1d
+
+#else
+ !!----------------------------------------------------------------------
+ !! Default key NO 1D Config
+ !!----------------------------------------------------------------------
+CONTAINS
+ SUBROUTINE dyn_nxt_c1d ( kt )
+ WRITE(*,*) 'dyn_nxt_c1d: You should not have seen this print! error?', kt
+ END SUBROUTINE dyn_nxt_c1d
+#endif
+
+ !!======================================================================
+END MODULE dynnxt_c1d
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/OPA_SRC/TRD/trdtrc.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/OPA_SRC/TRD/trdtrc.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/OPA_SRC/TRD/trdtrc.F90 (revision 8155)
@@ -1,2 +1,3 @@
+#if ! defined key_top
MODULE trdtrc
!!======================================================================
@@ -22,2 +23,3 @@
!!======================================================================
END MODULE trdtrc
+#endif
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90 (revision 8155)
@@ -74,4 +74,5 @@
#if defined key_top
USE trcini ! passive tracer initialisation
+ USE trc, ONLY: numstr ! tracer stats unit number
#endif
USE lib_mpp ! distributed memory computing
@@ -609,4 +610,5 @@
IF( numdct_heat /= -1 ) CLOSE( numdct_heat ) ! heat transports
IF( numdct_salt /= -1 ) CLOSE( numdct_salt ) ! salt transports
+ IF( numstr /= -1 ) CLOSE( numstr ) ! tracer statistics
!
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/AGE/par_age.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/AGE/par_age.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/AGE/par_age.F90 (revision 8155)
@@ -0,0 +1,83 @@
+MODULE par_age
+ !!======================================================================
+ !! *** par_age ***
+ !! TOP : set the AGE parameters
+ !!======================================================================
+ !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) revised architecture
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 3.3 , NEMO Consortium (2010)
+ !! $Id$
+ !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+ USE par_pisces , ONLY : jp_pisces !: number of tracers in PISCES
+ USE par_pisces , ONLY : jp_pisces_2d !: number of 2D diag in PISCES
+ USE par_pisces , ONLY : jp_pisces_3d !: number of 3D diag in PISCES
+ USE par_pisces , ONLY : jp_pisces_trd !: number of biological diag in PISCES
+
+ USE par_medusa , ONLY : jp_medusa !: number of tracers in MEDUSA
+ USE par_medusa , ONLY : jp_medusa_2d !: number of 2D diag in MEDUSA
+ USE par_medusa , ONLY : jp_medusa_3d !: number of 3D diag in MEDUSA
+ USE par_medusa , ONLY : jp_medusa_trd !: number of biological diag in MEDUSA
+
+ USE par_idtra , ONLY : jp_idtra !: number of tracers in MEDUSA
+ USE par_idtra , ONLY : jp_idtra_2d !: number of tracers in MEDUSA
+ USE par_idtra , ONLY : jp_idtra_3d !: number of tracers in MEDUSA
+ USE par_idtra , ONLY : jp_idtra_trd !: number of tracers in MEDUSA
+
+ USE par_cfc , ONLY : jp_cfc !: number of tracers in CFC
+ USE par_cfc , ONLY : jp_cfc_2d !: number of tracers in CFC
+ USE par_cfc , ONLY : jp_cfc_3d !: number of tracers in CFC
+ USE par_cfc , ONLY : jp_cfc_trd !: number of tracers in CFC
+
+ USE par_c14b , ONLY : jp_c14b !: number of tracers in C14
+ USE par_c14b , ONLY : jp_c14b_2d !: number of tracers in C14
+ USE par_c14b , ONLY : jp_c14b_3d !: number of tracers in C14
+ USE par_c14b , ONLY : jp_c14b_trd !: number of tracers in C14
+
+ IMPLICIT NONE
+
+ INTEGER, PARAMETER :: jp_lm = jp_pisces + jp_medusa + &
+ jp_idtra + jp_cfc + jp_c14b !: cum. number of pass. tracers
+ INTEGER, PARAMETER :: jp_lm_2d = jp_pisces_2d + jp_medusa_2d + &
+ jp_idtra_2d + jp_cfc_2d + jp_c14b_2d !:
+ INTEGER, PARAMETER :: jp_lm_3d = jp_pisces_3d + jp_medusa_3d + &
+ jp_idtra_3d + jp_cfc_3d + jp_c14b_3d !:
+ INTEGER, PARAMETER :: jp_lm_trd = jp_pisces_trd + jp_medusa_trd + &
+ jp_idtra_trd + jp_cfc_trd + jp_c14b_trd !:
+
+#if defined key_age
+ !!---------------------------------------------------------------------
+ !! 'key_age' user defined tracers (AGE)
+ !!---------------------------------------------------------------------
+ LOGICAL, PUBLIC, PARAMETER :: lk_age = .TRUE. !: PTS flag
+ INTEGER, PUBLIC, PARAMETER :: jp_age = 1 !: number of PTS tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_age_2d = 0 !: additional 2d output arrays ('key_trc_diaadd')
+ INTEGER, PUBLIC, PARAMETER :: jp_age_3d = 0 !: additional 3d output arrays ('key_trc_diaadd')
+ INTEGER, PUBLIC, PARAMETER :: jp_age_trd = 0 !: number of sms trends for AGE
+
+ ! assign an index in trc arrays for each PTS prognostic variables
+ INTEGER, PUBLIC, PARAMETER :: jpage1 = jp_lm + 1 !: 1st AGE tracer
+
+#else
+ !!---------------------------------------------------------------------
+ !! Default No user defined tracers (AGE)
+ !!---------------------------------------------------------------------
+ LOGICAL, PUBLIC, PARAMETER :: lk_age = .FALSE. !: AGE flag
+ INTEGER, PUBLIC, PARAMETER :: jp_age = 0 !: No AGE tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_age_2d = 0 !: No AGE additional 2d output arrays
+ INTEGER, PUBLIC, PARAMETER :: jp_age_3d = 0 !: No AGE additional 3d output arrays
+ INTEGER, PUBLIC, PARAMETER :: jp_age_trd = 0 !: number of sms trends for AGE
+#endif
+
+ ! Starting/ending PISCES do-loop indices (N.B. no PISCES : jpl_pcs < jpf_pcs the do-loop are never done)
+ INTEGER, PUBLIC, PARAMETER :: jp_age0 = jp_lm + 1 !: First index of AGE passive tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_age1 = jp_lm + jp_age !: Last index of AGE passive tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_age0_2d = jp_lm_2d + 1 !: First index of AGE passive tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_age1_2d = jp_lm_2d + jp_age_2d !: Last index of AGE passive tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_age0_3d = jp_lm_3d + 1 !: First index of AGE passive tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_age1_3d = jp_lm_3d + jp_age_3d !: Last index of AGE passive tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_age0_trd = jp_lm_trd + 1 !: First index of AGE passive tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_age1_trd = jp_lm_trd + jp_age_trd !: Last index of AGE passive tracers
+
+ !!======================================================================
+END MODULE par_age
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/AGE/trcini_age.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/AGE/trcini_age.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/AGE/trcini_age.F90 (revision 8155)
@@ -0,0 +1,71 @@
+MODULE trcini_age
+ !!======================================================================
+ !! *** MODULE trcini_age ***
+ !! TOP : initialisation of the AGE tracer
+ !!======================================================================
+ !! History : 2.0 ! 2007-12 (G. Nurser, G. Madec, C. Ethe ) Original code
+ !!----------------------------------------------------------------------
+#if defined key_age
+ !!----------------------------------------------------------------------
+ !! 'key_age' AGE tracer
+ !!----------------------------------------------------------------------
+ !! trc_ini_age : MY_TRC model initialisation
+ !!----------------------------------------------------------------------
+ USE oce_trc
+ USE trc
+ USE trcsms_age
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_ini_age ! called by trcini.F90 module
+
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 3.3 , NEMO Consortium (2010)
+ !! $Id$
+ !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE trc_ini_age
+ !!----------------------------------------------------------------------
+ !! *** trc_ini_age ***
+ !!
+ !! ** Purpose : initialization for AGE model
+ !!
+ !!----------------------------------------------------------------------
+
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) ' trc_ini_age: passive tracer age'
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~'
+
+ rryear = 1._wp / ( nyear_len(1) * rday ) ! recip number of seconds in one year
+
+ !! BUG in s-coordinate this does not work!
+ nlb_age = MINLOC( gdepw_1d, mask = gdepw_1d > rn_age_depth, dim = 1 ) ! shallowest W level Below age_depth
+ ! = shallowest T level wholly below age_depth
+
+ nl_age = nlb_age - 1 ! deepest W level Above age_depth
+ ! = T level surrounding age_depth
+
+ nla_age = nl_age - 1 ! deepest T level wholly above age_depth
+
+ frac_kill_age = ( rn_age_depth - gdepw_1d(nl_age) ) / e3t_1d(nl_age) ! fraction of level nl_age above age_depth
+ frac_add_age = 1._wp - frac_kill_age ! fraction of level nl_age below age_depth
+
+
+ IF( .NOT. ln_rsttr ) trn(:,:,:,jp_age0:jp_age1) = 0.
+ !
+ END SUBROUTINE trc_ini_age
+
+#else
+ !!----------------------------------------------------------------------
+ !! Dummy module No AGE model
+ !!----------------------------------------------------------------------
+CONTAINS
+ SUBROUTINE trc_ini_age ! Empty routine
+ END SUBROUTINE trc_ini_age
+#endif
+
+ !!======================================================================
+END MODULE trcini_age
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/AGE/trcnam_age.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/AGE/trcnam_age.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/AGE/trcnam_age.F90 (revision 8155)
@@ -0,0 +1,82 @@
+MODULE trcnam_age
+ !!======================================================================
+ !! *** MODULE trcnam_age ***
+ !! TOP : initialisation of some run parameters for Age tracer
+ !!======================================================================
+ !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec)
+ !!----------------------------------------------------------------------
+#if defined key_age
+ !!----------------------------------------------------------------------
+ !! 'key_age' AGE tracers
+ !!----------------------------------------------------------------------
+ !! trc_nam_age : AGE tracer initialisation
+ !!----------------------------------------------------------------------
+ USE oce_trc ! Ocean variables
+ USE trcsms_age ! AGE specific variable
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_nam_age ! called by trcnam.F90 module
+
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 3.3 , NEMO Consortium (2010)
+ !! $Id$
+ !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+CONTAINS
+
+ SUBROUTINE trc_nam_age
+ !!-------------------------------------------------------------------
+ !! *** ROUTINE trc_nam_age ***
+ !!
+ !! ** Purpose : Definition some run parameter for AGE model
+ !!
+ !! ** input : Namelist namage
+ !!----------------------------------------------------------------------
+ INTEGER :: numnatg_ref = -1 ! Logical unit for reference AGE namelist
+ INTEGER :: numnatg_cfg = -1 ! Logical unit for configuration AGE namelist
+ INTEGER :: numong = -1 ! Logical unit for output namelist
+ INTEGER :: ios ! Local integer output status for namelist read
+ INTEGER :: jl, jn
+ !!
+ NAMELIST/namage/ rn_age_depth, rn_age_kill_rate
+ !!----------------------------------------------------------------------
+ ! ! Open namelist files
+ CALL ctl_opn( numnatg_ref, 'namelist_age_ref' , 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
+ CALL ctl_opn( numnatg_cfg, 'namelist_age_cfg' , 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
+ IF(lwm) CALL ctl_opn( numong, 'output.namelist.age', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
+
+ REWIND( numnatg_ref ) ! Namelist namagedate in reference namelist : AGE parameters
+ READ ( numnatg_ref, namage, IOSTAT = ios, ERR = 901)
+901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namage in reference namelist', lwp )
+
+ REWIND( numnatg_cfg ) ! Namelist namagedate in configuration namelist : AGE parameters
+ READ ( numnatg_cfg, namage, IOSTAT = ios, ERR = 902 )
+902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namage in configuration namelist', lwp )
+ IF(lwm) WRITE ( numong, namage )
+
+ IF(lwp) THEN ! control print
+ WRITE(numout,*)
+ WRITE(numout,*) ' trc_nam_age: Read namage, namelist for Age passive tracer'
+ WRITE(numout,*) ' ~~~~~~~'
+ WRITE(numout,*) ' depth over which age tracer reset to zero rn_age_depth = ', rn_age_depth
+ WRITE(numout,*) ' recip of relax. timescale (s) for age tracer shallower than age_depth rn_age_kill_rate = ', rn_age_kill_rate
+ ENDIF
+
+ IF(lwm) CALL FLUSH ( numong ) ! flush output namelist
+
+ END SUBROUTINE trc_nam_age
+
+#else
+ !!----------------------------------------------------------------------
+ !! Dummy module : No AGE
+ !!----------------------------------------------------------------------
+CONTAINS
+ SUBROUTINE trc_nam_age ! Empty routine
+ END SUBROUTINE trc_nam_age
+#endif
+
+ !!======================================================================
+END MODULE trcnam_age
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/AGE/trcsms_age.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/AGE/trcsms_age.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/AGE/trcsms_age.F90 (revision 8155)
@@ -0,0 +1,100 @@
+MODULE trcsms_age
+ !!======================================================================
+ !! *** MODULE trcsms_age ***
+ !! TOP : Main module of the AGE tracers
+ !!======================================================================
+ !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) Original code
+ !!----------------------------------------------------------------------
+#if defined key_age
+ !!----------------------------------------------------------------------
+ !! 'key_age' AGE tracer
+ !!----------------------------------------------------------------------
+ !! trc_sms_age : AGE model main routine
+ !!----------------------------------------------------------------------
+ USE oce_trc ! Ocean variables
+ USE trc ! TOP variables
+ USE trd_oce
+ USE trdtrc
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_sms_age ! called by trcsms.F90 module
+
+ INTEGER , PUBLIC :: nl_age ! T level surrounding age_depth
+ INTEGER , PUBLIC :: nla_age ! T level wholly above age_depth
+ INTEGER , PUBLIC :: nlb_age ! T level wholly below age_depth
+
+ REAL(wp), PUBLIC :: rn_age_depth ! = 10 depth over which age tracer reset to zero
+ REAL(wp), PUBLIC :: rn_age_kill_rate ! = -1./7200 recip of relaxation timescale (s) for age tracer shallower than age_depth
+
+ REAL(wp), PUBLIC :: rryear !: recip number of seconds in one year
+ REAL(wp), PUBLIC :: frac_kill_age !: fraction of level nl_age above age_depth where it is relaxed towards zero
+ REAL(wp), PUBLIC :: frac_add_age !: fraction of level nl_age below age_depth where it is incremented
+
+
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 3.3 , NEMO Consortium (2010)
+ !! $Id$
+ !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE trc_sms_age( kt )
+ !!----------------------------------------------------------------------
+ !! *** trc_sms_age ***
+ !!
+ !! ** Purpose : main routine of AGE model
+ !!
+ !! ** Method : -
+ !!----------------------------------------------------------------------
+ !
+ INTEGER, INTENT(in) :: kt ! ocean time-step index
+ INTEGER :: jn, jk ! dummy loop index
+ REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrage
+ !!----------------------------------------------------------------------
+ !
+ IF( nn_timing == 1 ) CALL timing_start('trc_sms_age')
+ !
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) ' trc_sms_age: AGE model'
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~'
+
+ IF( l_trdtrc ) CALL wrk_alloc( jpi, jpj, jpk, ztrage )
+
+ DO jk = 1, nla_age
+ tra(:,:,jk,jpage1) = rn_age_kill_rate * trb(:,:,jk,jpage1)
+ ENDDO
+ !
+ tra(:,:,nl_age,jpage1) = frac_kill_age * rn_age_kill_rate * trb(:,:,nl_age,jpage1) &
+ & + frac_add_age * rryear * tmask(:,:,nl_age)
+ !
+ DO jk = nlb_age, jpk
+ tra(:,:,jk,jpage1) = tmask(:,:,jk) * rryear
+ ENDDO
+ !
+ IF( l_trdtrc ) THEN ! Save the trends in the mixed layer
+ DO jn = jp_age0, jp_age1
+ ztrage(:,:,:) = tra(:,:,:,jn)
+ CALL trd_trc( ztrage, jn, jptra_sms, kt ) ! save trends
+ END DO
+ CALL wrk_dealloc( jpi, jpj, jpk, ztrage )
+ END IF
+ !
+ IF( nn_timing == 1 ) CALL timing_stop('trc_sms_age')
+ !
+ END SUBROUTINE trc_sms_age
+
+#else
+ !!----------------------------------------------------------------------
+ !! Dummy module No AGE model
+ !!----------------------------------------------------------------------
+CONTAINS
+ SUBROUTINE trc_sms_age( kt ) ! Empty routine
+ INTEGER, INTENT( in ) :: kt
+ WRITE(*,*) 'trc_sms_age: You should not have seen this print! error?', kt
+ END SUBROUTINE trc_sms_age
+#endif
+
+ !!======================================================================
+END MODULE trcsms_age
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/AGE/trcwri_age.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/AGE/trcwri_age.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/AGE/trcwri_age.F90 (revision 8155)
@@ -0,0 +1,62 @@
+MODULE trcwri_age
+ !!======================================================================
+ !! *** MODULE trcwri ***
+ !! age : Output of age tracers
+ !!======================================================================
+ !! History : 1.0 ! 2009-05 (C. Ethe) Original code
+ !!----------------------------------------------------------------------
+#if defined key_top && defined key_age && defined key_iomput
+ !!----------------------------------------------------------------------
+ !! 'key_age' age model
+ !!----------------------------------------------------------------------
+ !! trc_wri_age : outputs of concentration fields
+ !!----------------------------------------------------------------------
+ USE par_age
+ USE trc
+ USE iom
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_wri_age
+
+# include "top_substitute.h90"
+CONTAINS
+
+ SUBROUTINE trc_wri_age
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE trc_wri_trc ***
+ !!
+ !! ** Purpose : output passive tracers fields
+ !!---------------------------------------------------------------------
+ CHARACTER (len=20) :: cltra
+ INTEGER :: jn
+ !!---------------------------------------------------------------------
+
+
+ ! write the tracer concentrations in the file
+ ! ---------------------------------------
+ DO jn = jp_age0, jp_age1
+ cltra = TRIM( ctrcnm(jn) ) ! short title for tracer
+ CALL iom_put( TRIM(cltra), trn(:,:,:,jn) )
+ END DO
+ !
+ !
+ END SUBROUTINE trc_wri_age
+
+#else
+ !!----------------------------------------------------------------------
+ !! Dummy module : No passive tracer
+ !!----------------------------------------------------------------------
+ PUBLIC trc_wri_age
+CONTAINS
+ SUBROUTINE trc_wri_age ! Empty routine
+ END SUBROUTINE trc_wri_age
+#endif
+
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 3.3 , NEMO Consortium (2010)
+ !! $Id$
+ !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+ !!======================================================================
+END MODULE trcwri_age
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/C14b/par_c14b.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/C14b/par_c14b.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/C14b/par_c14b.F90 (revision 8155)
@@ -11,4 +11,14 @@
USE par_pisces , ONLY : jp_pisces_trd !: number of biological diag in PISCES
+ USE par_medusa , ONLY : jp_medusa !: number of tracers in MEDUSA
+ USE par_medusa , ONLY : jp_medusa_2d !: number of 2D diag in MEDUSA
+ USE par_medusa , ONLY : jp_medusa_3d !: number of 3D diag in MEDUSA
+ USE par_medusa , ONLY : jp_medusa_trd !: number of biological diag in MEDUSA
+
+ USE par_idtra , ONLY : jp_idtra !: number of tracers in MEDUSA
+ USE par_idtra , ONLY : jp_idtra_2d !: number of tracers in MEDUSA
+ USE par_idtra , ONLY : jp_idtra_3d !: number of tracers in MEDUSA
+ USE par_idtra , ONLY : jp_idtra_trd !: number of tracers in MEDUSA
+
USE par_cfc , ONLY : jp_cfc !: number of tracers in CFC
USE par_cfc , ONLY : jp_cfc_2d !: number of 2D diag in CFC
@@ -19,8 +29,12 @@
IMPLICIT NONE
- INTEGER, PARAMETER :: jp_lb = jp_pisces + jp_cfc !: cum. number of pass. tracers
- INTEGER, PARAMETER :: jp_lb_2d = jp_pisces_2d + jp_cfc_2d !:
- INTEGER, PARAMETER :: jp_lb_3d = jp_pisces_3d + jp_cfc_3d !:
- INTEGER, PARAMETER :: jp_lb_trd = jp_pisces_trd + jp_cfc_trd !:
+ INTEGER, PARAMETER :: jp_lb = jp_pisces + jp_medusa + &
+ jp_idtra + jp_cfc !: cum. number of pass. tracers
+ INTEGER, PARAMETER :: jp_lb_2d = jp_pisces_2d + jp_medusa_2d + &
+ jp_idtra_2d + jp_cfc_2d !:
+ INTEGER, PARAMETER :: jp_lb_3d = jp_pisces_3d + jp_medusa_3d + &
+ jp_idtra_3d + jp_cfc_3d !:
+ INTEGER, PARAMETER :: jp_lb_trd = jp_pisces_trd + jp_medusa_trd + &
+ jp_idtra_trd + jp_cfc_trd !:
#if defined key_c14b
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/CFC/par_cfc.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/CFC/par_cfc.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/CFC/par_cfc.F90 (revision 8155)
@@ -5,4 +5,5 @@
!!======================================================================
!! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) revised architecture
+ !! ! 2017-04 (A. Yool) add SF6
!!----------------------------------------------------------------------
!! NEMO/TOP 3.3 , NEMO Consortium (2010)
@@ -15,10 +16,24 @@
USE par_pisces , ONLY : jp_pisces_trd !: number of biological diag in PISCES
+ USE par_medusa , ONLY : jp_medusa !: number of tracers in MEDUSA
+ USE par_medusa , ONLY : jp_medusa_2d !: number of 2D diag in MEDUSA
+ USE par_medusa , ONLY : jp_medusa_3d !: number of 3D diag in MEDUSA
+ USE par_medusa , ONLY : jp_medusa_trd !: number of biological diag in MEDUSA
+
+ USE par_idtra , ONLY : jp_idtra !: number of tracers in ideal tracer
+ USE par_idtra , ONLY : jp_idtra_2d !: number of tracers in ideal tracer
+ USE par_idtra , ONLY : jp_idtra_3d !: number of tracers in ideal tracer
+ USE par_idtra , ONLY : jp_idtra_trd !: number of tracers in ideal tracer
+
IMPLICIT NONE
- INTEGER, PARAMETER :: jp_lc = jp_pisces !: cumulative number of passive tracers
- INTEGER, PARAMETER :: jp_lc_2d = jp_pisces_2d !:
- INTEGER, PARAMETER :: jp_lc_3d = jp_pisces_3d !:
- INTEGER, PARAMETER :: jp_lc_trd = jp_pisces_trd !:
+ INTEGER, PARAMETER :: jp_lc = jp_pisces + jp_medusa + &
+ jp_idtra !: cumulative number of passive tracers
+ INTEGER, PARAMETER :: jp_lc_2d = jp_pisces_2d + jp_medusa_2d + &
+ jp_idtra_2d !:
+ INTEGER, PARAMETER :: jp_lc_3d = jp_pisces_3d + jp_medusa_3d + &
+ jp_idtra_3d !:
+ INTEGER, PARAMETER :: jp_lc_trd = jp_pisces_trd + jp_medusa_trd + &
+ jp_idtra_trd !:
#if defined key_cfc
@@ -27,6 +42,6 @@
!!---------------------------------------------------------------------
LOGICAL, PUBLIC, PARAMETER :: lk_cfc = .TRUE. !: CFC flag
- INTEGER, PUBLIC, PARAMETER :: jp_cfc = 1 !: number of passive tracers
- INTEGER, PUBLIC, PARAMETER :: jp_cfc_2d = 2 !: additional 2d output arrays ('key_trc_diaadd')
+ INTEGER, PUBLIC, PARAMETER :: jp_cfc = 3 !: number of passive tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_cfc_2d = 6 !: additional 2d output arrays ('key_trc_diaadd')
INTEGER, PUBLIC, PARAMETER :: jp_cfc_3d = 0 !: additional 3d output arrays ('key_trc_diaadd')
INTEGER, PUBLIC, PARAMETER :: jp_cfc_trd = 0 !: number of sms trends for CFC
@@ -34,5 +49,6 @@
! assign an index in trc arrays for each CFC prognostic variables
INTEGER, PUBLIC, PARAMETER :: jpc11 = jp_lc + 1 !: CFC-11
- INTEGER, PUBLIC, PARAMETER :: jpc12 = jp_lc + 2 !: CFC-12
+ INTEGER, PUBLIC, PARAMETER :: jpc12 = jp_lc + 2 !: CFC-12 (priority tracer for CMIP6)
+ INTEGER, PUBLIC, PARAMETER :: jpsf6 = jp_lc + 3 !: SF6
#else
!!---------------------------------------------------------------------
@@ -47,12 +63,12 @@
! Starting/ending CFC do-loop indices (N.B. no CFC : jp_cfc0 > jp_cfc1 the do-loop are never done)
- INTEGER, PUBLIC, PARAMETER :: jp_cfc0 = jp_lc + 1 !: First index of CFC tracers
- INTEGER, PUBLIC, PARAMETER :: jp_cfc1 = jp_lc + jp_cfc !: Last index of CFC tracers
- INTEGER, PUBLIC, PARAMETER :: jp_cfc0_2d = jp_lc_2d + 1 !: First index of CFC tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_cfc0 = jp_lc + 1 !: First index of CFC tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_cfc1 = jp_lc + jp_cfc !: Last index of CFC tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_cfc0_2d = jp_lc_2d + 1 !: First index of CFC tracers
INTEGER, PUBLIC, PARAMETER :: jp_cfc1_2d = jp_lc_2d + jp_cfc_2d !: Last index of CFC tracers
- INTEGER, PUBLIC, PARAMETER :: jp_cfc0_3d = jp_lc_3d + 1 !: First index of CFC tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_cfc0_3d = jp_lc_3d + 1 !: First index of CFC tracers
INTEGER, PUBLIC, PARAMETER :: jp_cfc1_3d = jp_lc_3d + jp_cfc_3d !: Last index of CFC tracers
- INTEGER, PUBLIC, PARAMETER :: jp_cfc0_trd = jp_lc_trd + 1 !: First index of CFC tracers
- INTEGER, PUBLIC, PARAMETER :: jp_cfc1_trd = jp_lc_trd + jp_cfc_trd !: Last index of CFC tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_cfc0_trd = jp_lc_trd + 1 !: First index of CFC tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_cfc1_trd = jp_lc_trd + jp_cfc_trd !: Last index of CFC tracers
!!======================================================================
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/CFC/trcini_cfc.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/CFC/trcini_cfc.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/CFC/trcini_cfc.F90 (revision 8155)
@@ -5,4 +5,5 @@
!!======================================================================
!! History : 2.0 ! 2007-12 (C. Ethe, G. Madec)
+ !! ! 2017-04 (A. Yool) Add SF6
!!----------------------------------------------------------------------
#if defined key_cfc
@@ -22,5 +23,5 @@
PUBLIC trc_ini_cfc ! called by trcini.F90 module
- CHARACTER (len=34) :: clname = 'cfc1112.atm' ! ???
+ CHARACTER (len=34) :: clname = 'cfc1112sf6.atm' ! ???
INTEGER :: inum ! unit number
@@ -44,5 +45,5 @@
!!----------------------------------------------------------------------
INTEGER :: ji, jj, jn, jl, jm, js, io, ierr
- INTEGER :: iskip = 6 ! number of 1st descriptor lines
+ INTEGER :: iskip = 7 ! number of 1st descriptor lines
REAL(wp) :: zyy, zyd
!!----------------------------------------------------------------------
@@ -53,5 +54,5 @@
- IF(lwp) WRITE(numout,*) 'read of formatted file cfc1112atm'
+ IF(lwp) WRITE(numout,*) 'read of formatted file cfc1112sf6.atm'
CALL ctl_opn( inum, clname, 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
@@ -69,5 +70,5 @@
! ! Allocate CFC arrays
- ALLOCATE( p_cfc(jpyear,jphem,2), STAT=ierr )
+ ALLOCATE( p_cfc(jpyear,jphem,3), STAT=ierr )
IF( ierr > 0 ) THEN
CALL ctl_stop( 'trc_ini_cfc: unable to allocate p_cfc array' ) ; RETURN
@@ -90,8 +91,5 @@
ENDIF
qint_cfc(:,:,:) = 0._wp
- DO jl = 1, jp_cfc
- jn = jp_cfc0 + jl - 1
- trn(:,:,:,jn) = 0._wp
- END DO
+ trn(:,:,:,jp_cfc0:jp_cfc1) = 0._wp
ENDIF
@@ -105,26 +103,30 @@
jn = 31
DO
- READ(inum,*, IOSTAT=io) zyy, p_cfc(jn,1,1), p_cfc(jn,1,2), p_cfc(jn,2,1), p_cfc(jn,2,2)
+ READ(inum,*, IOSTAT=io) zyy, p_cfc(jn,1,1), p_cfc(jn,1,2), &
+ & p_cfc(jn,1,3), p_cfc(jn,2,1), &
+ & p_cfc(jn,2,2), p_cfc(jn,2,3)
IF( io < 0 ) exit
jn = jn + 1
END DO
- p_cfc(32,1:2,1) = 5.e-4 ! modify the values of the first years
- p_cfc(33,1:2,1) = 8.e-4
- p_cfc(34,1:2,1) = 1.e-6
- p_cfc(35,1:2,1) = 2.e-3
- p_cfc(36,1:2,1) = 4.e-3
- p_cfc(37,1:2,1) = 6.e-3
- p_cfc(38,1:2,1) = 8.e-3
- p_cfc(39,1:2,1) = 1.e-2
+ ! AXY (25/04/17): do not adjust
+ ! p_cfc(32,1:2,1) = 5.e-4 ! modify the values of the first years
+ ! p_cfc(33,1:2,1) = 8.e-4
+ ! p_cfc(34,1:2,1) = 1.e-6
+ ! p_cfc(35,1:2,1) = 2.e-3
+ ! p_cfc(36,1:2,1) = 4.e-3
+ ! p_cfc(37,1:2,1) = 6.e-3
+ ! p_cfc(38,1:2,1) = 8.e-3
+ ! p_cfc(39,1:2,1) = 1.e-2
IF(lwp) THEN ! Control print
WRITE(numout,*)
- WRITE(numout,*) ' Year p11HN p11HS p12HN p12HS '
+ WRITE(numout,*) ' Year p11HN p11HS p12HN p12HS pSF6N pSF6S '
DO jn = 30, jpyear
- WRITE(numout, '( 1I4, 4F9.2)') jn, p_cfc(jn,1,1), p_cfc(jn,2,1), p_cfc(jn,1,2), p_cfc(jn,2,2)
+ WRITE(numout, '( 1I4, 6F9.2)') jn, p_cfc(jn,1,1), p_cfc(jn,2,1), &
+ & p_cfc(jn,1,2), p_cfc(jn,2,2), &
+ & p_cfc(jn,1,3), p_cfc(jn,2,3)
END DO
ENDIF
-
! Interpolation factor of atmospheric partial pressure
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/CFC/trcnam_cfc.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/CFC/trcnam_cfc.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/CFC/trcnam_cfc.F90 (revision 8155)
@@ -49,5 +49,5 @@
TYPE(DIAG), DIMENSION(jp_cfc_2d) :: cfcdia2d
!!
- NAMELIST/namcfcdate/ ndate_beg, nyear_res
+ NAMELIST/namcfcdate/ ndate_beg, nyear_res, simu_type
NAMELIST/namcfcdia/ cfcdia2d ! additional diagnostics
!!----------------------------------------------------------------------
@@ -72,4 +72,9 @@
WRITE(numout,*) ' initial calendar date (aammjj) for CFC ndate_beg = ', ndate_beg
WRITE(numout,*) ' restoring time constant (year) nyear_res = ', nyear_res
+ IF (simu_type==1) THEN
+ WRITE(numout,*) ' CFC running on SPIN-UP mode simu_type = ', simu_type
+ ELSEIF (simu_type==2) THEN
+ WRITE(numout,*) ' CFC running on HINDCAST/PROJECTION mode simu_type = ', simu_type
+ ENDIF
ENDIF
nyear_beg = ndate_beg / 10000
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/CFC/trcsms_cfc.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/CFC/trcsms_cfc.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/CFC/trcsms_cfc.F90 (revision 8155)
@@ -7,4 +7,6 @@
!! NEMO 1.0 ! 2004-03 (C. Ethe) free form + modularity
!! 2.0 ! 2007-12 (C. Ethe, G. Madec) reorganisation
+ !! ! 2016-06 (J. Palmieri) update for UKESM1
+ !! ! 2017-04 (A. Yool) update to add SF6, fix coefficients
!!----------------------------------------------------------------------
#if defined key_cfc
@@ -15,4 +17,5 @@
!! cfc_init : sets constants for CFC surface forcing computation
!!----------------------------------------------------------------------
+ USE dom_oce ! ocean space and time domain
USE oce_trc ! Ocean variables
USE par_trc ! TOP parameters
@@ -31,4 +34,6 @@
INTEGER , PUBLIC :: jpyear ! Number of years read in CFC1112 file
INTEGER , PUBLIC :: ndate_beg ! initial calendar date (aammjj) for CFC
+ INTEGER , PUBLIC :: simu_type ! Kind of simulation: 1- Spin-up
+ ! 2- Hindcast/projection
INTEGER , PUBLIC :: nyear_res ! restoring time constant (year)
INTEGER , PUBLIC :: nyear_beg ! initial year (aa)
@@ -40,7 +45,7 @@
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: patm ! atmospheric function
- REAL(wp), DIMENSION(4,2) :: soa ! coefficient for solubility of CFC [mol/l/atm]
- REAL(wp), DIMENSION(3,2) :: sob ! " "
- REAL(wp), DIMENSION(4,2) :: sca ! coefficients for schmidt number in degre Celcius
+ REAL(wp), DIMENSION(4,3) :: soa ! coefficient for solubility of CFC [mol/l/atm]
+ REAL(wp), DIMENSION(3,3) :: sob ! " "
+ REAL(wp), DIMENSION(5,3) :: sca ! coefficients for schmidt number in degre Celcius
! ! coefficients for conversion
@@ -79,8 +84,8 @@
!
INTEGER :: ji, jj, jn, jl, jm, js
- INTEGER :: iyear_beg, iyear_end
+ INTEGER :: iyear_beg, iyear_end, iyear_tmp
INTEGER :: im1, im2, ierr
REAL(wp) :: ztap, zdtap
- REAL(wp) :: zt1, zt2, zt3, zv2
+ REAL(wp) :: zt1, zt2, zt3, zt4, zv2
REAL(wp) :: zsol ! solubility
REAL(wp) :: zsch ! schmidt number
@@ -103,5 +108,38 @@
! Temporal interpolation
! ----------------------
- iyear_beg = nyear - 1900
+ !! JPALM -- 15-06-2016 -- define 2 kinds of CFC run:
+ !! 1- the SPIN-UP and 2- Hindcast/Projections
+ !! -- main difference is the way to define the year of
+ !! simulation, that determine the atm pCFC.
+ !! 1-- Spin-up: our atm forcing is of 30y we cycle on.
+ !! So we do 90y CFC cycles to be in good
+ !! correspondence with the atmosphere
+ !! 2-- Hindcast/proj, instead of nyear-1900 we keep
+ !! the 2 last digit, and enable 3 cycle from 1800 to 2100.
+ !!----------------------------------------------------------------------
+ IF (simu_type==1) THEN
+ !! 1 -- SPIN-UP
+ iyear_tmp = nyear - nyear_res !! JPALM -- in our spin-up, nyear_res is 1000
+ iyear_beg = MOD( iyear_tmp , 90 )
+ !! JPALM -- the pCFC file only got 78 years.
+ !! So if iyear_beg > 78 then we set pCFC to 0
+ !! iyear_beg = 0 as well -- must try to avoid obvious problems
+ !! as Pcfc is set to 0.00 up to year 32, let set iyear_beg to year 10
+ !! else, must add 30 to iyear_beg to match with P_cfc indices
+ !!---------------------------------------
+ IF ((iyear_beg > 77) .OR. (iyear_beg==0)) THEN
+ iyear_beg = 10
+ ELSE
+ iyear_beg = iyear_beg + 30
+ ENDIF
+ ELSEIF (simu_type==2) THEN
+ !! 2 -- Hindcast/proj
+ iyear_beg = MOD(nyear, 100)
+ IF (iyear_beg < 20) iyear_beg = iyear_beg + 100
+ !! JPALM -- Same than previously, if iyear_beg is out of P_cfc range,
+ !! we want to set p_CFC to 0.00 --> set iyear_beg = 10
+ IF ((iyear_beg < 30) .OR. (iyear_beg > 115)) iyear_beg = 10
+ ENDIF
+ !!
IF ( nmonth <= 6 ) THEN
iyear_beg = iyear_beg - 1
@@ -152,10 +190,13 @@
zt2 = zt1 * zt1
zt3 = zt1 * zt2
- zsch = sca(1,jl) + sca(2,jl) * zt1 + sca(3,jl) * zt2 + sca(4,jl) * zt3
+ zt4 = zt1 * zt3
+ zsch = sca(1,jl) + sca(2,jl) * zt1 + sca(3,jl) * zt2 + sca(4,jl) * zt3 + sca(5,jl) * zt4
! speed transfert : formulae of wanninkhof 1992
zv2 = wndm(ji,jj) * wndm(ji,jj)
zsch = zsch / 660.
- zak_cfc = ( 0.39 * xconv2 * zv2 / SQRT(zsch) ) * tmask(ji,jj,1)
+ ! AXY (25/04/17): OMIP protocol specifies lower Wanninkhof (2014) value
+ ! zak_cfc = ( 0.39 * xconv2 * zv2 / SQRT(zsch) ) * tmask(ji,jj,1)
+ zak_cfc = ( 0.251 * xconv2 * zv2 / SQRT(zsch) ) * tmask(ji,jj,1)
! Input function : speed *( conc. at equil - concen at surface )
@@ -176,22 +217,59 @@
! !----------------!
END DO ! end CFC loop !
- !
- IF( lrst_trc ) THEN
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'trc_sms_cfc : cumulated input function fields written in ocean restart file ', &
- & 'at it= ', kt,' date= ', ndastp
- IF(lwp) WRITE(numout,*) '~~~~'
- DO jn = jp_cfc0, jp_cfc1
- CALL iom_rstput( kt, nitrst, numrtw, 'qint_'//ctrcnm(jn), qint_cfc(:,:,jn) )
- END DO
- ENDIF
+ !
+ IF( kt == nittrc000 ) THEN
+ DO jl = 1, jp_cfc
+ WRITE(NUMOUT,*) ' '
+ WRITE(NUMOUT,*) 'CFC interpolation verification ' !! Jpalm
+ WRITE(NUMOUT,*) '################################## '
+ WRITE(NUMOUT,*) ' '
+ if (jl.EQ.1) then
+ WRITE(NUMOUT,*) 'Traceur = CFC11: '
+ elseif (jl.EQ.2) then
+ WRITE(NUMOUT,*) 'Traceur = CFC12: '
+ elseif (jl.EQ.3) then
+ WRITE(NUMOUT,*) 'Traceur = SF6: '
+ endif
+ WRITE(NUMOUT,*) 'nyear = ', nyear
+ WRITE(NUMOUT,*) 'nmonth = ', nmonth
+ WRITE(NUMOUT,*) 'iyear_beg= ', iyear_beg
+ WRITE(NUMOUT,*) 'iyear_end= ', iyear_end
+ WRITE(NUMOUT,*) 'p_cfc(iyear_beg)= ',p_cfc(iyear_beg, 1, jl)
+ WRITE(NUMOUT,*) 'p_cfc(iyear_end)= ',p_cfc(iyear_end, 1, jl)
+ WRITE(NUMOUT,*) 'Im1= ',im1
+ WRITE(NUMOUT,*) 'Im2= ',im2
+ WRITE(NUMOUT,*) 'zpp_cfc = ',zpp_cfc
+ WRITE(NUMOUT,*) ' '
+ END DO
+# if defined key_debug_medusa
+ CALL flush(numout)
+# endif
+ ENDIF
+ !
+ !IF( lrst_trc ) THEN
+ ! IF(lwp) WRITE(numout,*)
+ ! IF(lwp) WRITE(numout,*) 'trc_sms_cfc : cumulated input function fields written in ocean restart file ', &
+ ! & 'at it= ', kt,' date= ', ndastp
+ ! IF(lwp) WRITE(numout,*) '~~~~'
+ ! DO jn = jp_cfc0, jp_cfc1
+ ! CALL iom_rstput( kt, nitrst, numrtw, 'qint_'//ctrcnm(jn), qint_cfc(:,:,jn) )
+ ! END DO
+ !ENDIF
!
IF( lk_iomput ) THEN
- CALL iom_put( "qtrCFC11" , qtr_cfc (:,:,1) )
- CALL iom_put( "qintCFC11" , qint_cfc(:,:,1) )
+ IF (iom_use("qtrCFC11")) CALL iom_put( "qtrCFC11" , qtr_cfc (:,:,1) )
+ IF (iom_use("qintCFC11")) CALL iom_put( "qintCFC11" , qint_cfc(:,:,1) )
+ IF (iom_use("qtrCFC12")) CALL iom_put( "qtrCFC12" , qtr_cfc (:,:,2) )
+ IF (iom_use("qintCFC12")) CALL iom_put( "qintCFC12" , qint_cfc(:,:,2) )
+ IF (iom_use("qtrSF6")) CALL iom_put( "qtrSF6" , qtr_cfc (:,:,3) )
+ IF (iom_use("qintSF6")) CALL iom_put( "qintSF6" , qint_cfc(:,:,3) )
ELSE
IF( ln_diatrc ) THEN
trc2d(:,:,jp_cfc0_2d ) = qtr_cfc (:,:,1)
trc2d(:,:,jp_cfc0_2d + 1) = qint_cfc(:,:,1)
+ trc2d(:,:,jp_cfc0_2d + 2) = qtr_cfc (:,:,2)
+ trc2d(:,:,jp_cfc0_2d + 3) = qint_cfc(:,:,2)
+ trc2d(:,:,jp_cfc0_2d + 4) = qtr_cfc (:,:,3)
+ trc2d(:,:,jp_cfc0_2d + 5) = qint_cfc(:,:,3)
END IF
END IF
@@ -203,4 +281,8 @@
END IF
!
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' CFC - Check: nn_timing = ', nn_timing
+ CALL flush(numout)
+# endif
IF( nn_timing == 1 ) CALL timing_stop('trc_sms_cfc')
!
@@ -214,5 +296,5 @@
!! ** Purpose : sets constants for CFC model
!!---------------------------------------------------------------------
- INTEGER :: jn
+ INTEGER :: jl, jn, iyear_beg, iyear_tmp
! coefficient for CFC11
@@ -223,15 +305,16 @@
soa(2,1) = 319.6552
soa(3,1) = 119.4471
- soa(4,1) = -1.39165
-
- sob(1,1) = -0.142382
- sob(2,1) = 0.091459
- sob(3,1) = -0.0157274
-
- ! Schmidt number
- sca(1,1) = 3501.8
- sca(2,1) = -210.31
- sca(3,1) = 6.1851
- sca(4,1) = -0.07513
+ soa(4,1) = -1.39165
+
+ sob(1,1) = -0.142382
+ sob(2,1) = 0.091459
+ sob(3,1) = -0.0157274
+
+ ! Schmidt number AXY (25/04/17)
+ sca(1,1) = 3579.2 ! = 3501.8
+ sca(2,1) = -222.63 ! = -210.31
+ sca(3,1) = 7.5749 ! = 6.1851
+ sca(4,1) = -0.14595 ! = -0.07513
+ sca(5,1) = 0.0011874 ! = absent
! coefficient for CFC12
@@ -242,25 +325,79 @@
soa(2,2) = 298.9702
soa(3,2) = 113.8049
- soa(4,2) = -1.39165
-
- sob(1,2) = -0.143566
- sob(2,2) = 0.091015
- sob(3,2) = -0.0153924
-
- ! schmidt number
- sca(1,2) = 3845.4
- sca(2,2) = -228.95
- sca(3,2) = 6.1908
- sca(4,2) = -0.067430
-
- IF( ln_rsttr ) THEN
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) ' Read specific variables from CFC model '
- IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~'
- !
- DO jn = jp_cfc0, jp_cfc1
- CALL iom_get( numrtr, jpdom_autoglo, 'qint_'//ctrcnm(jn), qint_cfc(:,:,jn) )
- END DO
+ soa(4,2) = -1.39165
+
+ sob(1,2) = -0.143566
+ sob(2,2) = 0.091015
+ sob(3,2) = -0.0153924
+
+ ! schmidt number AXY (25/04/17)
+ sca(1,2) = 3828.1 ! = 3845.4
+ sca(2,2) = -249.86 ! = -228.95
+ sca(3,2) = 8.7603 ! = 6.1908
+ sca(4,2) = -0.1716 ! = -0.067430
+ sca(5,2) = 0.001408 ! = absent
+
+ ! coefficients for SF6 AXY (25/04/17)
+ !---------------------
+
+ ! Solubility
+ soa(1,3) = -80.0343
+ soa(2,3) = 117.232
+ soa(3,3) = 29.5817
+ soa(4,3) = 0.0
+
+ sob(1,3) = 0.0335183
+ sob(2,3) = -0.0373942
+ sob(3,3) = 0.00774862
+
+ ! Schmidt number
+ sca(1,3) = 3177.5
+ sca(2,3) = -200.57
+ sca(3,3) = 6.8865
+ sca(4,3) = -0.13335
+ sca(5,3) = 0.0010877
+
+ !!---------------------------------------------
+ !! JPALM -- re-initialize CFC fields and diags if restart a CFC cycle,
+ !! Or if out of P_cfc range
+ IF (simu_type==1) THEN
+ iyear_tmp = nyear - nyear_res !! JPALM -- in our spin-up, nyear_res is 1000
+ iyear_beg = MOD( iyear_tmp , 90 )
+ !!---------------------------------------
+ IF ((iyear_beg > 77) .OR. (iyear_beg==0)) THEN
+ qtr_cfc(:,:,:) = 0._wp
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'restart a CFC cycle or out of P_cfc year bounds zero --'
+ WRITE(numout,*) ' -- set qtr_CFC = 0.00 --'
+ WRITE(numout,*) ' -- set qint_CFC = 0.00 --'
+ WRITE(numout,*) ' -- set trn(CFC) = 0.00 --'
+ ENDIF
+ qtr_cfc(:,:,:) = 0._wp
+ qint_cfc(:,:,:) = 0._wp
+ trn(:,:,:,jp_cfc0:jp_cfc1) = 0._wp
+ trb(:,:,:,jp_cfc0:jp_cfc1) = 0._wp
+ ENDIF
+ !!
+ !! 2 -- Hindcast/proj
+ ELSEIF (simu_type==2) THEN
+ iyear_beg = MOD(nyear, 100)
+ IF (iyear_beg < 20) iyear_beg = iyear_beg + 100
+ IF ((iyear_beg < 30) .OR. (iyear_beg > 115)) THEN
+ qtr_cfc(:,:,:) = 0._wp
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'restart a CFC cycle or out of P_cfc year bounds zero --'
+ WRITE(numout,*) ' -- set qtr_CFC = 0.00 --'
+ WRITE(numout,*) ' -- set qint_CFC = 0.00 --'
+ WRITE(numout,*) ' -- set trn(CFC) = 0.00 --'
+ ENDIF
+ qtr_cfc(:,:,:) = 0._wp
+ qint_cfc(:,:,:) = 0._wp
+ trn(:,:,:,jp_cfc0:jp_cfc1) = 0._wp
+ trb(:,:,:,jp_cfc0:jp_cfc1) = 0._wp
+ ENDIF
ENDIF
+
IF(lwp) WRITE(numout,*)
!
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/par_idtra.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/par_idtra.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/par_idtra.F90 (revision 8155)
@@ -0,0 +1,67 @@
+MODULE par_idtra
+ !!======================================================================
+ !! *** par_idtra ***
+ !! TOP : set the IDEAL-TRACER parameters
+ !!======================================================================
+ !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) revised architecture
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+ USE par_pisces , ONLY : jp_pisces !: number of tracers in PISCES
+ USE par_pisces , ONLY : jp_pisces_2d !: number of 2D diag in PISCES
+ USE par_pisces , ONLY : jp_pisces_3d !: number of 3D diag in PISCES
+ USE par_pisces , ONLY : jp_pisces_trd !: number of biological diag in PISCES
+
+ USE par_medusa , ONLY : jp_medusa !: number of tracers in MEDUSA
+ USE par_medusa , ONLY : jp_medusa_2d !: number of 2D diag in MEDUSA
+ USE par_medusa , ONLY : jp_medusa_3d !: number of 3D diag in MEDUSA
+ USE par_medusa , ONLY : jp_medusa_trd !: number of biological diag in MEDUSA
+
+ IMPLICIT NONE
+
+ INTEGER, PARAMETER :: jp_lp = jp_pisces + jp_medusa !: cumulative number of passive tracers
+ INTEGER, PARAMETER :: jp_lp_2d = jp_pisces_2d + jp_medusa_2d !:
+ INTEGER, PARAMETER :: jp_lp_3d = jp_pisces_3d + jp_medusa_3d !:
+ INTEGER, PARAMETER :: jp_lp_trd = jp_pisces_trd + jp_medusa_trd !:
+
+#if defined key_idtra
+ !!---------------------------------------------------------------------
+ !! 'key_idtra' : Ideal tracers
+ !!---------------------------------------------------------------------
+ LOGICAL, PUBLIC, PARAMETER :: lk_idtra = .TRUE. !: IDEAL-TRACER flag
+ INTEGER, PUBLIC, PARAMETER :: jp_idtra = 1 !: number of passive tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_idtra_2d = 3 !: additional 2d output arrays ('key_trc_diaadd')
+ INTEGER, PUBLIC, PARAMETER :: jp_idtra_3d = 0 !: additional 3d output arrays ('key_trc_diaadd')
+ INTEGER, PUBLIC, PARAMETER :: jp_idtra_trd = 0 !: number of sms trends for IDEAL-TRACER
+
+ ! assign an index in trc arrays for each IDEAL-TRACER prognostic variables
+ INTEGER, PUBLIC, PARAMETER :: jpidtra = jp_lp + 1 !: IDEAL-TRACER
+#else
+ !!---------------------------------------------------------------------
+ !! Default : No IDEAL-TRACER tracers
+ !!---------------------------------------------------------------------
+ LOGICAL, PUBLIC, PARAMETER :: lk_idtra = .FALSE. !: IDEAL-TRACER flag
+ INTEGER, PUBLIC, PARAMETER :: jp_idtra = 0 !: No IDEAL-TRACER tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_idtra_2d = 0 !: No IDEAL-TRACER additional 2d output arrays
+ INTEGER, PUBLIC, PARAMETER :: jp_idtra_3d = 0 !: No IDEAL-TRACER additional 3d output arrays
+ INTEGER, PUBLIC, PARAMETER :: jp_idtra_trd = 0 !: number of sms trends for IDEAL-TRACER
+#endif
+
+ ! Starting/ending IDEAL-TRACER do-loop indices (N.B. no IDEAL-TRACER : jp_idtra0 > jp_idtra1 the do-loop are never done)
+ INTEGER, PUBLIC, PARAMETER :: jp_idtra0 = jp_lp + 1 !: First index of IDEAL-TRACER tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_idtra1 = jp_lp + jp_idtra !: Last index of IDEAL-TRACER tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_idtra0_2d = jp_lp_2d + 1 !: First index of IDEAL-TRACER tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_idtra1_2d = jp_lp_2d + jp_idtra_2d !: Last index of IDEAL-TRACER tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_idtra0_3d = jp_lp_3d + 1 !: First index of IDEAL-TRACER tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_idtra1_3d = jp_lp_3d + jp_idtra_3d !: Last index of IDEAL-TRACER tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_idtra0_trd = jp_lp_trd + 0 !: First index of IDEAL-TRACER tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_idtra1_trd = jp_lp_trd + jp_idtra_trd !: Last index of IDEAL-TRACER tracers
+
+ !!======================================================================
+END MODULE par_idtra
+
+
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/trcice_idtra.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/trcice_idtra.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/trcice_idtra.F90 (revision 8155)
@@ -0,0 +1,53 @@
+MODULE trcice_idtra
+ !!======================================================================
+ !! *** MODULE trcice_idtra ***
+ !! TOP : Main module of the MY_TRC tracers
+ !!======================================================================
+ !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) Original code
+ !!----------------------------------------------------------------------
+#if defined key_idtra
+ !!----------------------------------------------------------------------
+ !! 'key_idtra' IDEAL TRACER tracers
+ !!----------------------------------------------------------------------
+ !! trc_ice_idtra : MY_TRC model main routine
+ !!----------------------------------------------------------------------
+ USE par_trc ! TOP parameters
+ USE oce_trc ! Ocean variables
+ USE trc ! TOP variables
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_ice_ini_idtra ! called by trcice.F90 module
+
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 3.3 , NEMO Consortium (2010)
+ !! $Id$
+ !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE trc_ice_ini_idtra
+ !!----------------------------------------------------------------------
+ !! *** trc_ice_idtra ***
+ !!
+ !! ** Purpose : main routine of MY_TRC model
+ !!
+ !! ** Method : -
+ !!----------------------------------------------------------------------
+ !
+ !
+ END SUBROUTINE trc_ice_ini_idtra
+
+
+#else
+ !!----------------------------------------------------------------------
+ !! Dummy module No MY_TRC model
+ !!----------------------------------------------------------------------
+CONTAINS
+ SUBROUTINE trc_ice_ini_idtra ! Empty routine
+ END SUBROUTINE trc_ice_ini_idtra
+#endif
+
+ !!======================================================================
+END MODULE trcice_idtra
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/trcini_idtra.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/trcini_idtra.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/trcini_idtra.F90 (revision 8155)
@@ -0,0 +1,105 @@
+MODULE trcini_idtra
+ !!======================================================================
+ !! *** MODULE trcini_idtra ***
+ !! TOP : initialisation of the IDEAL-TRACER tracers
+ !!======================================================================
+ !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) from trcini.idtra.h90
+ !!----------------------------------------------------------------------
+#if defined key_idtra
+ !!----------------------------------------------------------------------
+ !! 'key_idtra' IDEAL-TRACER tracers
+ !!----------------------------------------------------------------------
+ !! trc_ini_idtra : IDEAL-TRACER model initialisation
+ !!----------------------------------------------------------------------
+ USE oce_trc ! Ocean variables
+ USE par_trc ! TOP parameters
+ USE trc ! TOP variables
+ USE trcsms_idtra ! IDEAL-TRACER sms trends
+ ! USE par_idtra ! IDEAL-TRACER parameters
+ ! USE in_out_manager ! I/O manager
+ ! USE lib_mpp
+ ! USE iom
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_ini_idtra ! called by trcini.F90 module
+
+ INTEGER :: inum ! unit number
+
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE trc_ini_idtra
+ !!----------------------------------------------------------------------
+ !! *** trc_ini_idtra ***
+ !!
+ !! ** Purpose : initialization for idtra model
+ !!
+ !! ** Method : - Read the namidtra namelist and check the parameter values
+ !!----------------------------------------------------------------------
+ INTEGER :: jn, jl
+ !!----------------------------------------------------------------------
+
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) ' trc_ini_idtra: initialisation of Ideal Tracers model'
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~'
+
+ IF( trc_sms_idtra_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trc_ini_idtra:unable to allocate CFC arrays' )
+
+
+ ! Initialization of trn in case of no restart
+ !----------------------------------------------
+ qtr_idtra(:,:,:) = 0._wp
+ inv_idtra(:,:,:) = 0._wp
+ IF( .NOT. ln_rsttr ) THEN
+ IF(lwp) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'Initialization of id-tracers ; No restart : '
+ WRITE(numout,*) ' ; Init field equal 1 at surface - zero elsewhere'
+ WRITE(numout,*) ' ; qint idtra equal 0 '
+ ENDIF
+ qint_idtra(:,:,:) = 0._wp
+ DO jn = jp_idtra0, jp_idtra1
+ trn(:,:,:,jn) = 0.e0
+ trn(:,:,1,jn) = 1.0
+ IF(lwp) WRITE(numout,*) 'Idealise Tracer initialisation -- jn = ',jn
+ END DO
+ ENDIF
+
+
+ ! Ideal traceur do not need any atmospheric concentration.
+ ! We consider that sucface concentration is equal to 1,
+ ! that it is advectied within the water circulation,
+ ! and that it is regularly degraded as if it was a radiactive tracer (tricium for example)
+ ! But we can play with tha caracteristic time of
+ !--------------------------------------------------------------------
+
+
+
+ IF(lwp) WRITE(numout,*) 'Initialization of IDEAL-TRACER tracers done'
+ IF(lwp) WRITE(numout,*) ' '
+
+ END SUBROUTINE trc_ini_idtra
+
+#else
+ !!----------------------------------------------------------------------
+ !! Dummy module No IDEAL-TRACER tracers
+ !!----------------------------------------------------------------------
+CONTAINS
+ SUBROUTINE trc_ini_idtra ! Empty routine
+
+
+ END SUBROUTINE trc_ini_idtra
+#endif
+
+ !!======================================================================
+END MODULE trcini_idtra
+
+
+
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/trcnam_idtra.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/trcnam_idtra.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/trcnam_idtra.F90 (revision 8155)
@@ -0,0 +1,123 @@
+MODULE trcnam_idtra
+ !!======================================================================
+ !! *** MODULE trcnam_idtra ***
+ !! TOP : initialisation of some run parameters for IDEAL-TRACER chemical model
+ !!======================================================================
+ !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) from trcnam.idtra.h90
+ !!----------------------------------------------------------------------
+#if defined key_idtra
+ !!----------------------------------------------------------------------
+ !! 'key_idtra' IDEAL-TRACER tracers
+ !!----------------------------------------------------------------------
+ !! trc_nam_idtra : IDEAL-TRACER model initialisation
+ !!----------------------------------------------------------------------
+ USE oce_trc ! Ocean variables
+ USE par_trc ! TOP parameters
+ USE trc ! TOP variables
+ USE trcsms_idtra ! IDEAL-TRACER specific variable
+ USE iom ! I/O manager
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_nam_idtra ! called by trcnam.F90 module
+
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+CONTAINS
+
+ SUBROUTINE trc_nam_idtra
+ !!-------------------------------------------------------------------
+ !! *** ROUTINE trc_nam_idtra ***
+ !!
+ !! ** Purpose : Definition some run parameter for IDEAL-TRACER model
+ !!
+ !! ** Method : Read the namidtra namelist and check the parameter
+ !! values called at the first timestep (nit000)
+ !!
+ !! ** input : Namelist namidtra
+ !!----------------------------------------------------------------------
+ INTEGER :: numnatm_ref = -1 ! Logical unit for reference ID-TRA namelist
+ INTEGER :: numnatm_cfg = -1 ! Logical unit for configuration ID-TRA namelist
+ INTEGER :: numonc = -1 ! Logical unit for output namelist
+ INTEGER :: ios ! Local integer output status for namelist read
+ REAL(wp) :: tmp_decay !! Years ; half time decay of our idealize tracer
+ REAL(wp) :: TDECyr, TDEC
+ !! ----------------------------------------------------------------
+ NAMELIST/namidtra/tmp_decay
+ !!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ !! Jpalm -- 4-11-2014
+ !! namelist for idealize tracer
+ !! only thing in namelist is the chosen half time decay
+ !! no atmospheric conditions, cause we do impose a surface concentration of 1,
+ !! and no additionnal diagnostics,
+ !! because the only thing we are interested in is the water mass concentration on this tracer.
+ !!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) ' trc_nam_idtra: read IDEAL-TRACER namelist'
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~'
+ !!
+ !! Open the namelist file :
+ !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ CALL ctl_opn( numnatm_ref, 'namelist_idtra_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
+ CALL ctl_opn( numnatm_cfg, 'namelist_idtra_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
+ IF(lwm) CALL ctl_opn( numonc, 'output.namelist.idtra', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
+ !! Read the namelists :
+ !!~~~~~~~~~~~~~~~~~~~~~~~
+ !! First namelist of our idealize tracer :
+ !! read the decay 1/2 time of our tracer, to define in the namelist.
+ !! tmp_decay = 1y ; 10y ; 100y or 1000y depending of which water mass you want to track
+ !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ REWIND( numnatm_ref ) ! Namelist namidtra in reference namelist : IDTRA parameters
+ READ ( numnatm_ref, namidtra, IOSTAT = ios, ERR = 901)
+901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namidtra in reference namelist', lwp )
+
+ REWIND( numnatm_cfg ) ! Namelist namidtra in configuration namelist : IDTRA parameters
+ READ ( numnatm_cfg, namidtra, IOSTAT = ios, ERR = 902 )
+902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namidtra in configuration namelist', lwp )
+ IF(lwm) WRITE ( numonc, namidtra )
+
+ IF(lwp) WRITE(numout,*) ' - half time decay of our idealize tracer : ', tmp_decay
+
+ ! decroissance radioactive du traceur ideal
+ ! ---------------------------------------
+ ! TDECyr = 12.43/LOG(2.) !! Tricium as example
+ TDECyr = tmp_decay/LOG(2.) !! Idealise tracer -- with tmp_decay given in the idtracer namelist
+ TDEC = TDECyr*365.*24.*60.*60. !! translate in second
+ FDEC = EXP( -rdt/TDEC )
+
+
+!! #if defined key_trc_diaadd && ! defined key_iomput
+ !!
+ !! -Here you can add tracers names to be read
+ !! in a namelist.
+ !! -But this is not necessary with the iomput module
+ !! cause names are written in the Iodef file.
+ !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!! #endif
+
+ END SUBROUTINE trc_nam_idtra
+
+#else
+ !!----------------------------------------------------------------------
+ !! Dummy module : No IDEAL-TRACER
+ !!----------------------------------------------------------------------
+CONTAINS
+ SUBROUTINE trc_nam_idtra ! Empty routine
+ END SUBROUTINE trc_nam_idtra
+#endif
+
+ !!======================================================================
+END MODULE trcnam_idtra
+
+
+
+
+
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/trcsms_idtra.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/trcsms_idtra.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/trcsms_idtra.F90 (revision 8155)
@@ -0,0 +1,259 @@
+MODULE trcsms_idtra
+ !!======================================================================
+ !! *** MODULE trcsms_idtra ***
+ !! TOP : TRI main model
+ !!======================================================================
+ !! History : - ! 1999-10 (JC. Dutay) original code
+ !! 1.0 ! 2004-03 (C. Ethe) free form + modularity
+ !! 2.0 ! 2007-12 (C. Ethe, G. Madec) reorganisation
+ !!----------------------------------------------------------------------
+#if defined key_idtra
+ !!----------------------------------------------------------------------
+ !! 'key_idtra' TRI tracers
+ !!----------------------------------------------------------------------
+ !! trc_sms_idtra : compute and add TRI suface forcing to TRI trends
+ !! trc_idtra_cst : sets constants for TRI surface forcing computation
+ !!----------------------------------------------------------------------
+ USE oce_trc ! Ocean variables
+ USE par_trc ! TOP parameters
+ USE trc ! TOP variables
+ USE trd_oce
+ USE trdtrc
+ USE iom
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_sms_idtra ! called in ???
+ PUBLIC trc_sms_idtra_alloc ! called in ???
+ !
+ INTEGER , PUBLIC :: nyear_res ! restoring time constant (year)
+ INTEGER , PUBLIC :: numnatm
+ REAL(wp), PUBLIC :: FDEC
+ !
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qtr_idtra ! flux at surface
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qint_idtra ! cumulative flux
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: inv_idtra ! vertic. inventory
+
+ ! ! coefficients for conversion
+ REAL(wp) :: WTEMP
+
+
+ !! * Substitutions
+# include "top_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+CONTAINS
+
+ SUBROUTINE trc_sms_idtra( kt )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE trc_sms_idtra ***
+ !!
+ !! ** Purpose : Compute the surface boundary contition on TRI 11
+ !! passive tracer associated with air-mer fluxes and add it
+ !! to the general trend of tracers equations.
+ !!
+ !! ** Method : - get the atmospheric partial pressure - given in pico -
+ !! - computation of solubility ( in 1.e-12 mol/l then in 1.e-9 mol/m3)
+ !! - computation of transfert speed ( given in cm/hour ----> cm/s )
+ !! - the input function is given by :
+ !! speed * ( concentration at equilibrium - concentration at surface )
+ !! - the input function is in pico-mol/m3/s and the
+ !! TRI concentration in pico-mol/m3
+ !!
+ !! *** For Idealized Tracers
+ !! - no need for any temporal references,
+ !! nor any atmospheric concentration, nor air -sea fluxes
+ !! - Here we fixe surface concentration to 1.0 Tracer-Unit/m3
+ !! - Then we add a decay (radioactive-like) to this tracer concentration
+ !! - the Half life deccay is chosen by the user, depending of the experiment.
+ !!
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT( in ) :: kt ! ocean time-step index
+ !!
+ INTEGER :: ji, jj, jn, jl, jk
+ REAL(wp) :: rlx !! relaxation time (1 day)
+ !!----------------------------------------------------------------------
+ !
+ IF( nn_timing == 1 ) CALL timing_start('trc_sms_idtra')
+ !
+ rlx = 10./(60. * 60. * 24.) !! relaxation time (1/10 day)
+ IF (kt == nittrc000) THEN
+ IF(lwp) WRITE(numout,*) ' trcsms_idtra :'
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~'
+ IF(lwp) WRITE(numout,*) ' - idtra decay factor : ', FDEC
+ IF(lwp) WRITE(numout,*) ' - relaxation time : ', rlx
+# if defined key_debug_medusa
+ CALL flush(numout)
+# endif
+ ! CALL idtra_init
+ ENDIF
+
+ !
+ inv_idtra(:,:,:) = 0.0 !! init the inventory
+ qtr_idtra(:,:,:) = 0.0 !! init the air-sea flux
+ DO jl = 1, jp_idtra
+ jn = jp_idtra0 + jl - 1
+
+ !! DO jj = 1, jpj
+ !! DO ji = 1, jpi
+ DO jj = 2,jpjm1
+ DO ji = 2,jpim1
+
+ !! First, a crude version. will be much inproved later.
+ qtr_idtra(ji,jj,jl) = rlx * (1. - trb(ji,jj,1,jn)) * tmask(ji,jj,1) * &
+ fse3t(ji,jj,1) !! Air-sea Flux
+
+ !! DEBUG-TEST : Set flux equal to 0, see if it induces the pb we see in the MED
+ !! qtr_idtra(ji,jj,jl) = 0.0
+ ENDDO
+ ENDDO
+ tra(:,:,1,jn) = tra(:,:,1,jn) + ( qtr_idtra(:,:,jl) * &
+ tmask(:,:,1) / fse3t(:,:,1) )
+ qint_idtra(:,:,jl) = qint_idtra(:,:,jl) + &
+ qtr_idtra(:,:,jl) * rdt !! Cumulative Air-sea Flux
+
+
+ DO jk =1,jpk
+ inv_idtra(:,:,jl) = inv_idtra(:,:,jl) + &
+ (trn(:,:,jk,jn) * fse3t(:,:,jk) * tmask(:,:,jk)) !! vertical inventory
+ ENDDO
+!
+!DECAY of OUR IDEALIZED TRACER
+! ---------------------------------------
+
+ DO jk =1,jpk
+ !! DO jj=1,jpj
+ !! DO ji =1,jpi
+ DO jj = 2,jpjm1
+ DO ji = 2,jpim1
+
+ !! IF (trn(ji,jj,jk,jn) > 0.0) THEN
+ WTEMP = trn(ji,jj,jk,jn) * (1. - FDEC )
+ tra(ji,jj,jk,jn) = (tra(ji,jj,jk,jn) - WTEMP/rdt ) * &
+ tmask(ji,jj,jk)
+ !! ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+
+ ENDDO
+ !! jn loop
+!
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' IDTRA - calculation part - DONE trc_sms_idtra -- '
+ CALL flush(numout)
+# endif
+ !
+ !! restart and diagnostics management --
+ !IF( lrst_trc ) THEN
+ ! IF(lwp) WRITE(numout,*)
+ ! IF(lwp) WRITE(numout,*) 'trc_sms_idtra : cumulated input function fields written in ocean restart file ', &
+ ! & 'at it= ', kt,' date= ', ndastp
+ ! IF(lwp) WRITE(numout,*) '~~~~'
+ ! !!DO jn = jp_idtra0, jp_idtra1
+ ! CALL iom_rstput( kt, nitrst, numrtw, 'qint_IDTRA', qint_idtra(:,:,1) )
+ ! !!END DO
+ ! if defined key_debug_medusa
+ ! IF(lwp) WRITE(numout,*) ' IDTRA - writing diag-restart - DONE trc_sms_idtra -- '
+ ! CALL flush(numout)
+ ! endif
+ !ENDIF
+ !
+ IF( lk_iomput ) THEN
+ CALL iom_put( "qtrIDTRA" , qtr_idtra (:,:,1) )
+ CALL iom_put( "qintIDTRA" , qint_idtra(:,:,1) )
+ CALL iom_put( "invIDTRA" , inv_idtra(:,:,1) )
+ ELSE
+ IF( ln_diatrc ) THEN
+ trc2d(:,:,jp_idtra0_2d ) = qtr_idtra (:,:,1)
+ trc2d(:,:,jp_idtra0_2d + 1) = qint_idtra(:,:,1)
+ trc2d(:,:,jp_idtra0_2d + 2) = inv_idtra(:,:,1)
+ END IF
+ END IF
+ !
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' IDTRA - writing diag - DONE trc_sms_idtra -- '
+ CALL flush(numout)
+# endif
+ !
+ IF( l_trdtrc ) THEN
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' IDTRA - writing trends - trc_sms_idtra -- '
+ CALL flush(numout)
+# endif
+ DO jn = jp_idtra0, jp_idtra1
+ CALL trd_trc( tra(:,:,:,jn), jn, jptra_sms, kt ) ! save trends
+ END DO
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' IDTRA - writing trends - DONE trc_sms_idtra -- '
+ CALL flush(numout)
+# endif
+ END IF
+ !
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' IDTRA - Check: nn_timing = ', nn_timing
+ CALL flush(numout)
+# endif
+ IF( nn_timing == 1 ) CALL timing_stop('trc_sms_idtra')
+ !
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' IDTRA DONE trc_sms_idtra -- '
+ CALL flush(numout)
+# endif
+ !
+ END SUBROUTINE trc_sms_idtra
+
+ SUBROUTINE idtra_init
+ !!---------------------------------------------------------------------
+ !! *** idtra_init ***
+ !!
+ !! ** Purpose : read restart values for IDTRA model
+ !!---------------------------------------------------------------------
+ INTEGER :: jn
+
+ IF( ln_rsttr ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) ' Read specific variables from Ideal Tracers model '
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~'
+ !
+ DO jn = jp_idtra0, jp_idtra1
+ CALL iom_get( numrtr, jpdom_autoglo, 'qint_IDTRA', qint_idtra(:,:,jn) )
+ END DO
+ ENDIF
+ IF(lwp) WRITE(numout,*) 'idtra restart variables read -- OK'
+ !
+ END SUBROUTINE idtra_init
+
+ INTEGER FUNCTION trc_sms_idtra_alloc()
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE trc_sms_idtra_alloc ***
+ !!----------------------------------------------------------------------
+ ALLOCATE( qtr_idtra (jpi,jpj,jp_idtra) , &
+ & inv_idtra(jpi,jpj,jp_idtra) , &
+ & qint_idtra(jpi,jpj,jp_idtra) , STAT=trc_sms_idtra_alloc )
+ !
+ IF( trc_sms_idtra_alloc /= 0 ) CALL ctl_warn('trc_sms_idtra_alloc : failed to allocate arrays.')
+ !
+ END FUNCTION trc_sms_idtra_alloc
+
+#else
+ !!----------------------------------------------------------------------
+ !! Dummy module No TRI tracers
+ !!----------------------------------------------------------------------
+CONTAINS
+ SUBROUTINE trc_sms_idtra( kt ) ! Empty routine
+ WRITE(*,*) 'trc_sms_idtra: You should not have seen this print! error?', kt
+ END SUBROUTINE trc_sms_idtra
+#endif
+
+ !!======================================================================
+END MODULE trcsms_idtra
+
+
+
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/trcwri_idtra.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/trcwri_idtra.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/IDTRA/trcwri_idtra.F90 (revision 8155)
@@ -0,0 +1,63 @@
+MODULE trcwri_idtra
+ !!======================================================================
+ !! *** MODULE trcwri ***
+ !! IDEALIZED Tracer : Output of IDEALIZED Tracer tracers
+ !!======================================================================
+ !! History : 1.0 ! 2009-05 (C. Ethe) Original code
+ !! 1.1 ! 2013-05 (A. Yool) converted for MEDUSA
+ !!----------------------------------------------------------------------
+#if defined key_top && defined key_iomput && defined key_idtra
+ !!----------------------------------------------------------------------
+ !! 'key_idtra' IDEALIZED Tracer model
+ !!----------------------------------------------------------------------
+ !! trc_wri_idtra : outputs of concentration fields
+ !!----------------------------------------------------------------------
+ ! USE oce_trc ! Ocean variables
+ ! USE par_trc ! TOP parameters
+ USE trc ! passive tracers common variables
+ ! USE trcsms_idtra ! IDEALIZE TRACER sms trends
+ USE iom ! I/O manager
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_wri_idtra
+
+CONTAINS
+
+ SUBROUTINE trc_wri_idtra
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE trc_wri_trc ***
+ !!
+ !! ** Purpose : output passive tracers fields
+ !!---------------------------------------------------------------------
+ CHARACTER (len=20) :: cltra
+ INTEGER :: jn
+ !!---------------------------------------------------------------------
+
+ ! write the tracer concentrations in the file
+ ! ---------------------------------------
+ DO jn = jp_idtra0, jp_idtra1
+ cltra = TRIM( ctrcnm(jn) ) ! short title for tracer
+ CALL iom_put( cltra, trn(:,:,:,jn) )
+ END DO
+ !
+ END SUBROUTINE trc_wri_idtra
+
+#else
+ !!----------------------------------------------------------------------
+ !! Dummy module : No passive tracer
+ !!----------------------------------------------------------------------
+ PUBLIC trc_wri_idtra
+CONTAINS
+ SUBROUTINE trc_wri_idtra ! Empty routine
+ END SUBROUTINE trc_wri_idtra
+#endif
+
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 3.3 , NEMO Consortium (2010)
+ !! $Id$
+ !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+ !!======================================================================
+END MODULE trcwri_idtra
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/gas_transfer.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/gas_transfer.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/gas_transfer.F90 (revision 8155)
@@ -0,0 +1,154 @@
+MODULE gastransfer
+ !!======================================================================
+ !! *** MODULE trcdms_medusa ***
+ !! TOP : MEDUSA
+ !!======================================================================
+ !! History :
+ !! - ! 2015-06 (A. Yool) added for UKESM1 project
+ !!----------------------------------------------------------------------
+#if defined key_medusa && defined key_roam
+ USE oce_trc
+ USE trc
+ USE sms_medusa
+ USE lbclnk
+ USE prtctl_trc ! Print control for debugging
+ USE in_out_manager ! I/O manager
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC gas_transfer ! called by trcbio_medusa.F90 module
+
+ !!* Substitution
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+CONTAINS
+
+ subroutine gas_transfer(wind, N, eqn, kw660)
+! --------------------------------------------------------------------
+! Gas transfer velocity
+! --------------------------------------------------------------------
+!
+! Title : Calculates gas transfer velocity
+! Author : Andrew Yool
+! Date : 15/10/04
+!
+! This subroutine uses near-surface wind speed to calculate gas
+! transfer velocity for use in CO2 and O2 exchange calculations.
+!
+! Note that the parameterisation of Wanninkhof quoted here is a
+! truncation of the original equation. It excludes a chemical
+! enhancement function (based on temperature), although such
+! temperature dependence is reported negligible by Etcheto &
+! Merlivat (1988).
+!
+! Note also that in calculating scalar wind, the variance of the
+! wind over the period of a timestep is ignored. Some authors,
+! for instance OCMIP-2, favour including some reference to the
+! variability of wind. However, their wind fields are averaged
+! over relatively long time periods, and so this issue may be
+! safely (!) ignored here.
+!
+! AXY (12/06/2015)
+! UPDATED: revised formulation from Wanninkhof (2014) update to
+! original 1992 paper. Full reference is:
+!
+! Wanninkhof, R. (2014). Relationship between wind speed and gas
+! exchange over the ocean revisited. LIMNOLOGY AND OCEANOGRAPHY-METHODS
+! 12, 351-362, doi:10.4319/lom.2014.12.351
+!
+! Subroutine inputs are (in order) :
+! wind wind velocity at 10 m (m/s)
+! N size of input array (value 1 at this time)
+! eqn choice of parameterisation:
+! 1 = Liss & Merlivat (1986) [approximated]
+! 2 = Wanninkhof (1992) [sans enhancement]
+! 3 = Nightingale et al. (2000) [good]
+! 4 = Nightingale et al. (2000) [better]
+! 5 = Nightingale et al. (2000) [best]
+! 6 = OCMIP-2 [sans variability]
+! 7 = Wanninkhof (2014) [assumes 6h avg winds]
+! (*) k gas transfer velocity (m/s)
+!
+! Where (*) is the function output and (+) is a diagnostic output.
+!
+ implicit none
+
+ INTEGER, INTENT(in) :: N, eqn
+! Input variables
+! real(kind=wp), INTENT(in), DIMENSION(N) :: wind
+ real(wp), INTENT(in) :: wind
+!
+! Output variables
+! real(kind=wp), INTENT(out), DIMENSION(N) :: kw660
+ real(wp), INTENT(out) :: kw660
+!
+! INTEGER :: eqn
+!
+! Coefficients for various parameterisations
+ real(wp) :: a(7)
+ real(wp) :: b(7)
+!
+! real(wp), DIMENSION(N) :: tmp_k
+ real(wp) :: tmp_k
+!
+! Values of coefficients
+ data a(1) / 0.166 / ! Liss & Merlivat (1986) [approximated]
+ data a(2) / 0.3 / ! Wanninkhof (1992) [sans enhancement]
+ data a(3) / 0.23 / ! Nightingale et al. (2000) [good]
+ data a(4) / 0.23 / ! Nightingale et al. (2000) [better]
+ data a(5) / 0.222 / ! Nightingale et al. (2000) [best]
+ data a(6) / 0.337 / ! OCMIP-2 [sans variability]
+ data a(7) / 0.251 / ! Wanninkhof (2014) [assumes 6h avg winds]
+!
+ data b(1) / 0.133 /
+ data b(2) / 0.0 /
+ data b(3) / 0.0 /
+ data b(4) / 0.1 /
+ data b(5) / 0.333 /
+ data b(6) / 0.0 /
+ data b(7) / 0.0 /
+!
+! Which parameterisation is to be used?
+! eqn = 7
+!
+! Calculate gas transfer velocity (cm/h)
+ tmp_k = (a(eqn) * wind**2) + (b(eqn) * wind)
+!
+! Convert tmp_k from cm/h to m/s
+ kw660 = tmp_k / (100. * 3600.)
+!
+ return
+
+ end subroutine gas_transfer
+
+!=======================================================================
+!=======================================================================
+!=======================================================================
+
+#else
+ !!======================================================================
+ !! Dummy module : No MEDUSA bio-model
+ !!======================================================================
+
+CONTAINS
+
+ SUBROUTINE gas_transfer(wind, N, eqn, kw660)
+ USE par_kind
+
+ REAL(wp), INTENT( in ) :: wind
+ REAL(wp), INTENT( in ) :: kw660
+ INTEGER, INTENT(in) :: N, eqn
+
+ WRITE(*,*) 'gas_transfer: You should not have seen this print! error?', kt
+
+ END SUBROUTINE gas_transfer
+#endif
+
+ !!======================================================================
+END MODULE gastransfer
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/mocsy_gasflux.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/mocsy_gasflux.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/mocsy_gasflux.F90 (revision 8155)
@@ -0,0 +1,242 @@
+MODULE mocsy_gasflux
+
+CONTAINS
+
+! --------------------------------------------------------------------
+! Schmidt CO2 number
+! --------------------------------------------------------------------
+!
+! Title : Calculates Schmidt number for ocean uptake of CO2
+! Author : Andrew Yool
+! Date : 14/10/04
+!
+! This function calculates the Schmidt number for CO2 using sea surface
+! temperature. The code is based upon that developed as part of the
+! OCMIP-2 project (1998-2000). The coefficients used are taken from
+! Wanninkhof (1992, JGR, 97, 7373-7382).
+!
+! AXY (12/06/2015)
+! UPDATED: coefficients used below are now those from Wanninkhof (2014)
+! update to original 1992 paper. Full reference is:
+!
+! Winninkhof, R. (2014). Relationship between wind speed and gas
+! exchange over the ocean revisited. LIMNOLOGY AND OCEANOGRAPHY-METHODS
+! 12, 351-362, doi:10.4319/lom.2014.12.351
+!
+! Check answer for the function at 20 degrees C is 668.
+!
+! Function inputs are (in order) :
+! t temperature (degrees C)
+! (*) co2_schmidt carbon dioxide Schmidt number
+!
+! Where (*) is the function output.
+!
+ subroutine schmidt_co2(pt, N, co2_schmidt)
+
+ USE mocsy_singledouble
+
+ implicit none
+!
+ INTEGER, INTENT(in) :: N
+ real(kind=wp), INTENT(in), DIMENSION(N) :: pt
+ real(kind=wp), INTENT(out), DIMENSION(N) :: co2_schmidt
+!
+ real(kind=wp) :: a0, a1, a2, a3, a4
+!
+! data a0 / 2073.1 /
+! data a1 / -125.62 /
+! data a2 / 3.6276 /
+! data a3 / -0.043219 /
+!
+ data a0 / 2116.8 /
+ data a1 / -136.25 /
+ data a2 / 4.7353 /
+ data a3 / -0.092307 /
+ data a4 / 0.0007555 /
+!
+! Wanninkhof (1992)
+! co2_schmidt = a0 + pt*(a1 + pt*(a2 + pt*a3))
+!
+! Wanninkhof (2014) adds in an extra term
+ co2_schmidt = a0 + pt*(a1 + pt*(a2 + pt*(a3 + pt*a4)))
+!
+ return
+
+ end subroutine schmidt_co2
+
+! --------------------------------------------------------------------
+! Surface K0
+! --------------------------------------------------------------------
+!
+! Title : Calculates surface K0 from surface T & S
+! Author : Andrew Yool
+! Date : 18/06/15
+!
+! This function is derived from code included in the MOCSY package
+! produced by Jim Orr.
+!
+ subroutine surface_K0(ptmp, saln, N, K0)
+
+ USE mocsy_singledouble
+
+ implicit none
+!
+ INTEGER, INTENT(in) :: N
+ real(kind=wp), INTENT(in), DIMENSION(N) :: ptmp, saln
+ real(kind=wp), INTENT(out), DIMENSION(N) :: K0
+!
+ real(kind=wp), DIMENSION(N) :: tk, invtk, tmp
+ real(kind=wp) :: a0, a1, a2, a3, a4
+!
+ tk = ptmp + 273.15d0
+ invtk = 1.0d0 / tk
+ tmp = (9345.17d0*invtk) - 60.2409d0 + (23.3585d0 * LOG(tk/100.0d0))
+ K0 = EXP( tmp + saln*(0.023517d0 - (0.00023656d0*tk) + (0.0047036e-4_wp*tk*tk)) )
+!
+ return
+
+ end subroutine surface_K0
+
+! --------------------------------------------------------------------
+! Calculate xCO2
+! --------------------------------------------------------------------
+!
+!> Compute xCO2 from arrays of pCO2atm, in situ T, S, & atm pressure
+SUBROUTINE pCO2atm2xCO2(pCO2atm, temp, salt, Patm, N, xCO2)
+ ! Purpose:
+ ! Compute xCO2 from arrays of pCO2atm, in situ T, S, & atm pressure
+
+ USE mocsy_singledouble
+
+ IMPLICIT NONE
+
+ !> number of records
+ INTEGER, intent(in) :: N
+
+! INPUT variables
+ !> atmospheric partial pressure of CO2 [uatm]
+ ! AXY (22/06/15): amended this next line to "in" as that's what it should be!
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: pCO2atm
+ !> in situ temperature [C]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: temp
+ !> salinity [psu]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: salt
+ !> atmospheric pressure [atm]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: Patm
+!f2py optional , depend(temp) :: n=len(temp)
+
+! OUTPUT variables:
+ !> mole fraction of CO2 [ppm]
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: xCO2
+
+! LOCAL variables:
+ REAL(kind=wp) :: dpCO2atm, dPatm
+ REAL(kind=wp), DIMENSION(N) :: pH20
+ REAL(kind=wp) :: dxCO2
+
+ INTEGER :: i
+
+ call vapress(temp, salt, N, pH20)
+
+ DO i = 1,N
+ dpCO2atm = DBLE(pCO2atm(i))
+ dPatm = DBLE(Patm(i))
+ dxCO2 = dpCO2atm / (dPatm - pH20(i))
+ xCO2(i) = REAL(dxCO2)
+ END DO
+
+ RETURN
+END SUBROUTINE pCO2atm2xCO2
+
+! --------------------------------------------------------------------
+! Calculate pCO2atm
+! --------------------------------------------------------------------
+!
+!> Compute pCO2atm from arrays of xCO2, in situ T, S, & atm pressure
+SUBROUTINE x2pCO2atm(xCO2, temp, salt, Patm, N, pCO2atm)
+ ! Purpose:
+ ! Compute pCO2atm from arrays of xCO2, in situ T, S, & atm pressure
+
+ USE mocsy_singledouble
+
+ IMPLICIT NONE
+
+ !> number of records
+ INTEGER, intent(in) :: N
+
+! INPUT variables
+ !> mole fraction of CO2 [ppm]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: xCO2
+ !> in situ temperature [C]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: temp
+ !> salinity [psu]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: salt
+ !> atmospheric pressure [atm]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: Patm
+!f2py optional , depend(temp) :: n=len(temp)
+
+! OUTPUT variables:
+ !> oceanic partial pressure of CO2 [uatm]
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: pCO2atm
+
+! LOCAL variables:
+ REAL(kind=wp) :: dxCO2, dPatm
+ REAL(kind=wp), DIMENSION(N) :: pH20
+ REAL(kind=wp) :: dpCO2atm
+
+ INTEGER :: i
+
+! Compute vapor pressure of seawater [in atm]
+ call vapress(temp, salt, N, pH20)
+
+ DO i = 1,N
+ dxCO2 = DBLE(xCO2(i))
+ dPatm = DBLE(Patm(i))
+ dpCO2atm = (dPatm - pH20(i)) * dxCO2
+ pCO2atm(i) = REAL(dpCO2atm)
+ END DO
+
+ RETURN
+END SUBROUTINE x2pCO2atm
+
+! --------------------------------------------------------------------
+! Calculate seawater vapor pressure
+! --------------------------------------------------------------------
+!
+!> Compute vapor pressure of seawater (atm) following preocedure from Weiss & Price (1980)
+SUBROUTINE vapress(temp, salt, N, vpsw)
+ ! Purpose:
+ ! Compute vapor pressure of seawater (atm) following preocedure from Weiss & Price (1980)
+
+ USE mocsy_singledouble
+ IMPLICIT NONE
+
+ !> number of records
+ INTEGER, intent(in) :: N
+
+! INPUT variables
+ !> in situ temperature [C]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: temp
+ !> salinity [psu]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: salt
+!f2py optional , depend(temp) :: n=len(temp)
+
+! OUTPUT variables:
+ !> vapor pressure of seawater [atm]
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: vpsw
+
+! LOCAL variables:
+ REAL(kind=wp) :: tk, dsalt
+
+ INTEGER :: i
+
+ DO i = 1,N
+ dsalt = DBLE(salt(i))
+ tk = 273.15d0 + DBLE(temp(i)) !Absolute temperature (Kelvin)
+ vpsw(i) = exp(24.4543d0 - 67.4509d0*(100.0d0/tk) - 4.8489d0*log(tk/100) - 0.000544d0*dsalt)
+ END DO
+
+ RETURN
+END SUBROUTINE vapress
+
+END MODULE mocsy_gasflux
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/mocsy_mainmod.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/mocsy_mainmod.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/mocsy_mainmod.F90 (revision 8155)
@@ -0,0 +1,2061 @@
+MODULE mocsy_mainmod
+
+ USE in_out_manager ! I/O manager
+
+CONTAINS
+
+! ----------------------------------------------------------------------
+! SW_ADTG
+! ----------------------------------------------------------------------
+!
+!> \file sw_adtg.f90
+!! \BRIEF
+!> Module with sw_adtg function - compute adiabatic temp. gradient from S,T,P
+!> Function to calculate adiabatic temperature gradient as per UNESCO 1983 routines.
+FUNCTION sw_adtg (s,t,p)
+
+ ! ==================================================================
+ ! Calculates adiabatic temperature gradient as per UNESCO 1983 routines.
+ ! Armin Koehl akoehl@ucsd.edu
+ ! ==================================================================
+ USE mocsy_singledouble
+ IMPLICIT NONE
+ !> salinity [psu (PSU-78)]
+ REAL(kind=wp) :: s
+ !> temperature [degree C (IPTS-68)]
+ REAL(kind=wp) :: t
+ !> pressure [db]
+ REAL(kind=wp) :: p
+
+ REAL(kind=wp) :: a0,a1,a2,a3,b0,b1,c0,c1,c2,c3,d0,d1,e0,e1,e2
+ REAL(kind=wp) :: sref
+
+ REAL(kind=wp) :: sw_adtg
+
+ sref = 35.d0
+ a0 = 3.5803d-5
+ a1 = +8.5258d-6
+ a2 = -6.836d-8
+ a3 = 6.6228d-10
+
+ b0 = +1.8932d-6
+ b1 = -4.2393d-8
+
+ c0 = +1.8741d-8
+ c1 = -6.7795d-10
+ c2 = +8.733d-12
+ c3 = -5.4481d-14
+
+ d0 = -1.1351d-10
+ d1 = 2.7759d-12
+
+ e0 = -4.6206d-13
+ e1 = +1.8676d-14
+ e2 = -2.1687d-16
+
+ sw_adtg = a0 + (a1 + (a2 + a3*T)*T)*T &
+ + (b0 + b1*T)*(S-sref) &
+ + ( (c0 + (c1 + (c2 + c3*T)*T)*T) + (d0 + d1*T)*(S-sref) )*P &
+ + ( e0 + (e1 + e2*T)*T )*P*P
+
+END FUNCTION sw_adtg
+
+! ----------------------------------------------------------------------
+! SW_ADTG
+! ----------------------------------------------------------------------
+!
+!> \file sw_ptmp.f90
+!! \BRIEF
+!> Module with sw_ptmp function - compute potential T from in-situ T
+!> Function to calculate potential temperature [C] from in-situ temperature
+FUNCTION sw_ptmp (s,t,p,pr)
+
+ ! ==================================================================
+ ! Calculates potential temperature [C] from in-situ Temperature [C]
+ ! From UNESCO 1983 report.
+ ! Armin Koehl akoehl@ucsd.edu
+ ! ==================================================================
+
+ ! Input arguments:
+ ! -------------------------------------
+ ! s = salinity [psu (PSS-78) ]
+ ! t = temperature [degree C (IPTS-68)]
+ ! p = pressure [db]
+ ! pr = reference pressure [db]
+
+ USE mocsy_singledouble
+ IMPLICIT NONE
+
+! Input arguments
+ !> salinity [psu (PSS-78)]
+ REAL(kind=wp) :: s
+ !> temperature [degree C (IPTS-68)]
+ REAL(kind=wp) :: t
+ !> pressure [db]
+ REAL(kind=wp) :: p
+ !> reference pressure [db]
+ REAL(kind=wp) :: pr
+
+! local arguments
+ REAL(kind=wp) :: del_P ,del_th, th, q
+ REAL(kind=wp) :: onehalf, two, three
+ PARAMETER (onehalf = 0.5d0, two = 2.d0, three = 3.d0 )
+
+! REAL(kind=wp) :: sw_adtg
+! EXTERNAL sw_adtg
+
+! Output
+ REAL(kind=wp) :: sw_ptmp
+
+ ! theta1
+ del_P = PR - P
+ del_th = del_P*sw_adtg(S,T,P)
+ th = T + onehalf*del_th
+ q = del_th
+
+ ! theta2
+ del_th = del_P*sw_adtg(S,th,P+onehalf*del_P)
+ th = th + (1.d0 - 1.d0/SQRT(two))*(del_th - q)
+ q = (two-SQRT(two))*del_th + (-two+three/SQRT(two))*q
+
+ ! theta3
+ del_th = del_P*sw_adtg(S,th,P+onehalf*del_P)
+ th = th + (1.d0 + 1.d0/SQRT(two))*(del_th - q)
+ q = (two + SQRT(two))*del_th + (-two-three/SQRT(two))*q
+
+ ! theta4
+ del_th = del_P*sw_adtg(S,th,P+del_P)
+ sw_ptmp = th + (del_th - two*q)/(two*three)
+
+ RETURN
+END FUNCTION sw_ptmp
+
+
+! ----------------------------------------------------------------------
+! SW_TEMP
+! ----------------------------------------------------------------------
+!
+!> \file sw_temp.f90
+!! \BRIEF
+!> Module with sw_temp function - compute in-situ T from potential T
+!> Function to compute in-situ temperature [C] from potential temperature [C]
+FUNCTION sw_temp( s, t, p, pr )
+ ! =============================================================
+ ! SW_TEMP
+ ! Computes in-situ temperature [C] from potential temperature [C]
+ ! Routine available in seawater.f (used for MIT GCM)
+ ! Downloaded seawater.f (on 17 April 2009) from
+ ! http://ecco2.jpl.nasa.gov/data1/beaufort/MITgcm/bin/
+ ! =============================================================
+
+ ! REFERENCES:
+ ! Fofonoff, P. and Millard, R.C. Jr
+ ! Unesco 1983. Algorithms for computation of fundamental properties of
+ ! seawater, 1983. _Unesco Tech. Pap. in Mar. Sci._, No. 44, 53 pp.
+ ! Eqn.(31) p.39
+
+ ! Bryden, H. 1973.
+ ! "New Polynomials for thermal expansion, adiabatic temperature gradient
+ ! and potential temperature of sea water."
+ ! DEEP-SEA RES., 1973, Vol20,401-408.
+ ! =============================================================
+
+ ! Simple modifications: J. C. Orr, 16 April 2009
+ ! - combined fortran code from MITgcm site & simplification in
+ ! CSIRO code (matlab equivalent) from Phil Morgan
+
+ USE mocsy_singledouble
+ IMPLICIT NONE
+
+ ! Input arguments:
+ ! -----------------------------------------------
+ ! s = salinity [psu (PSS-78) ]
+ ! t = potential temperature [degree C (IPTS-68)]
+ ! p = pressure [db]
+ ! pr = reference pressure [db]
+
+ !> salinity [psu (PSS-78)]
+ REAL(kind=wp) :: s
+ !> potential temperature [degree C (IPTS-68)]
+ REAL(kind=wp) :: t
+ !> pressure [db]
+ REAL(kind=wp) :: p
+ !> reference pressure [db]
+ REAL(kind=wp) :: pr
+
+ REAL(kind=wp) :: ds, dt, dp, dpr
+ REAL(kind=wp) :: dsw_temp
+
+ REAL(kind=wp) :: sw_temp
+! EXTERNAL sw_ptmp
+! REAL(kind=wp) :: sw_ptmp
+
+ ds = DBLE(s)
+ dt = DBLE(t)
+ dp = DBLE(p)
+ dpr = DBLE(pr)
+
+ ! Simple solution
+ ! (see https://svn.mpl.ird.fr/us191/oceano/tags/V0/lib/matlab/seawater/sw_temp.m)
+ ! Carry out inverse calculation by swapping P_ref (pr) and Pressure (p)
+ ! in routine that is normally used to compute potential temp from temp
+ dsw_temp = sw_ptmp(ds, dt, dpr, dp)
+ sw_temp = REAL(dsw_temp)
+
+ ! The above simplification works extremely well (compared to Table in 1983 report)
+ ! whereas the sw_temp routine from MIT GCM site does not seem to work right
+
+ RETURN
+END FUNCTION sw_temp
+
+! ----------------------------------------------------------------------
+! TPOT
+! ----------------------------------------------------------------------
+!
+!> \file tpot.f90
+!! \BRIEF
+!> Module with tpot subroutine - compute potential T from in situ T,S,P
+!> Compute potential temperature from arrays of in situ temp, salinity, and pressure.
+!! This subroutine is needed because sw_ptmp is a function (using scalars not arrays)
+SUBROUTINE tpot(salt, tempis, press, pressref, N, tempot)
+ ! Purpose:
+ ! Compute potential temperature from arrays of in situ temp, salinity, and pressure.
+ ! Needed because sw_ptmp is a function
+
+ USE mocsy_singledouble
+ IMPLICIT NONE
+
+ !> number of records
+ INTEGER, intent(in) :: N
+
+! INPUT variables
+ !> salinity [psu]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: salt
+ !> in situ temperature [C]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: tempis
+ !> pressure [db]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: press
+!f2py optional , depend(salt) :: n=len(salt)
+ !> pressure reference level [db]
+ REAL(kind=wp), INTENT(in) :: pressref
+
+! OUTPUT variables:
+ !> potential temperature [C] for pressref
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: tempot
+
+ REAL(kind=wp) :: dsalt, dtempis, dpress, dpressref
+ REAL(kind=wp) :: dtempot
+
+ INTEGER :: i
+
+! REAL(kind=wp) :: sw_ptmp
+! EXTERNAL sw_ptmp
+
+ DO i = 1,N
+ dsalt = DBLE(salt(i))
+ dtempis = DBLE(tempis(i))
+ dpress = DBLE(press(i))
+ dpressref = DBLE(pressref)
+
+ dtempot = sw_ptmp(dsalt, dtempis, dpress, dpressref)
+
+ tempot(i) = REAL(dtempot)
+ END DO
+
+ RETURN
+END SUBROUTINE tpot
+
+! ----------------------------------------------------------------------
+! TIS
+! ----------------------------------------------------------------------
+!
+!> \file tis.f90
+!! \BRIEF
+!> Module with tis subroutine - compute in situ T from S,T,P
+!> Compute in situ temperature from arrays of potential temp, salinity, and pressure.
+!! This subroutine is needed because sw_temp is a function (using scalars not arrays)
+SUBROUTINE tis(salt, tempot, press, pressref, N, tempis)
+ ! Purpose:
+ ! Compute in situ temperature from arrays of in situ temp, salinity, and pressure.
+ ! Needed because sw_temp is a function
+
+ USE mocsy_singledouble
+ IMPLICIT NONE
+
+ !> number of records
+ INTEGER, intent(in) :: N
+
+! INPUT variables
+ !> salinity [psu]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: salt
+ !> potential temperature [C]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: tempot
+ !> pressure [db]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: press
+!f2py optional , depend(salt) :: n=len(salt)
+ !> pressure reference level [db]
+ REAL(kind=wp), INTENT(in) :: pressref
+
+! OUTPUT variables:
+ !> in situ temperature [C]
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: tempis
+
+! REAL(kind=wp) :: dsalt, dtempis, dpress, dpressref
+! REAL(kind=wp) :: dtempot
+
+ INTEGER :: i
+
+! REAL(kind=wp) :: sw_temp
+! REAL(kind=wp) :: sw_temp
+! EXTERNAL sw_temp
+
+ DO i = 1,N
+ !dsalt = DBLE(salt(i))
+ !dtempot = DBLE(tempot(i))
+ !dpress = DBLE(press(i))
+ !dpressref = DBLE(pressref)
+ !dtempis = sw_temp(dsalt, dtempot, dpress, dpressref)
+ !tempis(i) = REAL(dtempis)
+
+ tempis = sw_temp(salt(i), tempot(i), press(i), pressref)
+ END DO
+
+ RETURN
+END SUBROUTINE tis
+
+! ----------------------------------------------------------------------
+! P80
+! ----------------------------------------------------------------------
+!
+!> \file p80.f90
+!! \BRIEF
+!> Module with p80 function - compute pressure from depth
+!> Function to compute pressure from depth using Saunder's (1981) formula with eos80.
+FUNCTION p80(dpth,xlat)
+
+ ! Compute Pressure from depth using Saunder's (1981) formula with eos80.
+
+ ! Reference:
+ ! Saunders, Peter M. (1981) Practical conversion of pressure
+ ! to depth, J. Phys. Ooceanogr., 11, 573-574, (1981)
+
+ ! Coded by:
+ ! R. Millard
+ ! March 9, 1983
+ ! check value: p80=7500.004 dbars at lat=30 deg., depth=7321.45 meters
+
+ ! Modified (slight format changes + added ref. details):
+ ! J. Orr, 16 April 2009
+
+ USE mocsy_singledouble
+ IMPLICIT NONE
+
+! Input variables:
+ !> depth [m]
+ REAL(kind=wp), INTENT(in) :: dpth
+ !> latitude [degrees]
+ REAL(kind=wp), INTENT(in) :: xlat
+
+! Output variable:
+ !> pressure [db]
+ REAL(kind=wp) :: p80
+
+! Local variables:
+ REAL(kind=wp) :: pi
+ REAL(kind=wp) :: plat, d, c1
+
+ pi=3.141592654
+
+ plat = ABS(xlat*pi/180.)
+ d = SIN(plat)
+ c1 = 5.92e-3+d**2 * 5.25e-3
+
+ p80 = ((1-c1)-SQRT(((1-c1)**2)-(8.84e-6*dpth))) / 4.42e-6
+
+ RETURN
+END FUNCTION p80
+
+! ----------------------------------------------------------------------
+! RHO
+! ----------------------------------------------------------------------
+!
+!> \file rho.f90
+!! \BRIEF
+!> Module with rho function - computes in situ density from S, T, P
+!> Function to compute in situ density from salinity (psu), in situ temperature (C), & pressure (bar)
+FUNCTION rho(salt, temp, pbar)
+
+ ! Compute in situ density from salinity (psu), in situ temperature (C), & pressure (bar)
+
+ USE mocsy_singledouble
+ IMPLICIT NONE
+
+ !> salinity [psu]
+ REAL(kind=wp) :: salt
+ !> in situ temperature (C)
+ REAL(kind=wp) :: temp
+ !> pressure (bar) [Note units: this is NOT in decibars]
+ REAL(kind=wp) :: pbar
+
+ REAL(kind=wp) :: s, t, p
+! REAL(kind=wp) :: t68
+ REAL(kind=wp) :: X
+ REAL(kind=wp) :: rhow, rho0
+ REAL(kind=wp) :: a, b, c
+ REAL(kind=wp) :: Ksbmw, Ksbm0, Ksbm
+ REAL(kind=wp) :: drho
+
+ REAL(kind=wp) :: rho
+
+ ! Input arguments:
+ ! -------------------------------------
+ ! s = salinity [psu (PSS-78) ]
+ ! t = in situ temperature [degree C (IPTS-68)]
+ ! p = pressure [bar] !!!! (not in [db]
+
+ s = DBLE(salt)
+ t = DBLE(temp)
+ p = DBLE(pbar)
+
+! Convert the temperature on today's "ITS 90" scale to older IPTS 68 scale
+! (see Dickson et al., Best Practices Guide, 2007, Chap. 5, p. 7, including footnote)
+! According to Best-Practices guide, line above should be commented & 2 lines below should be uncommented
+! Guide's answer of rho (s=35, t=25, p=0) = 1023.343 is for temperature given on ITPS-68 scale
+! t68 = (T - 0.0002) / 0.99975
+! X = t68
+! Finally, don't do the ITS-90 to IPTS-68 conversion (T input var now already on IPTS-68 scale)
+ X = T
+
+! Density of pure water
+ rhow = 999.842594d0 + 6.793952e-2_wp*X &
+ -9.095290e-3_wp*X*X + 1.001685e-4_wp*X**3 &
+ -1.120083e-6_wp*X**4 + 6.536332e-9_wp*X**5
+
+! Density of seawater at 1 atm, P=0
+ A = 8.24493e-1_wp - 4.0899e-3_wp*X &
+ + 7.6438e-5_wp*X*X - 8.2467e-7_wp*X**3 + 5.3875e-9_wp*X**4
+ B = -5.72466e-3_wp + 1.0227e-4_wp*X - 1.6546e-6_wp*X*X
+ C = 4.8314e-4_wp
+
+ rho0 = rhow + A*S + B*S*SQRT(S) + C*S**2.0d0
+
+! Secant bulk modulus of pure water
+! The secant bulk modulus is the average change in pressure
+! divided by the total change in volume per unit of initial volume.
+ Ksbmw = 19652.21d0 + 148.4206d0*X - 2.327105d0*X*X &
+ + 1.360477e-2_wp*X**3 - 5.155288e-5_wp*X**4
+
+! Secant bulk modulus of seawater at 1 atm
+ Ksbm0 = Ksbmw + S*( 54.6746d0 - 0.603459d0*X + 1.09987e-2_wp*X**2 &
+ - 6.1670e-5_wp*X**3) &
+ + S*SQRT(S)*( 7.944e-2_wp + 1.6483e-2_wp*X - 5.3009e-4_wp*X**2)
+
+! Secant bulk modulus of seawater at S,T,P
+ Ksbm = Ksbm0 &
+ + P*(3.239908d0 + 1.43713e-3_wp*X + 1.16092e-4_wp*X**2 - 5.77905e-7_wp*X**3) &
+ + P*S*(2.2838e-3_wp - 1.0981e-5_wp*X - 1.6078e-6_wp*X**2) &
+ + P*S*SQRT(S)*1.91075e-4_wp &
+ + P*P*(8.50935e-5_wp - 6.12293e-6_wp*X + 5.2787e-8_wp*X**2) &
+ + P*P*S*(-9.9348e-7_wp + 2.0816e-8_wp*X + 9.1697e-10_wp*X**2)
+
+! Density of seawater at S,T,P
+ drho = rho0/(1.0d0 - P/Ksbm)
+ rho = REAL(drho)
+
+ RETURN
+END FUNCTION rho
+
+! ----------------------------------------------------------------------
+! RHOINSITU
+! ----------------------------------------------------------------------
+!
+!> \file rhoinsitu.f90
+!! \BRIEF
+!> Module with rhoinsitu subroutine - compute in situ density from S, Tis, P
+!> Compute in situ density from salinity (psu), in situ temperature (C), & pressure (db).
+!! This subroutine is needed because rho is a function (using scalars not arrays)
+SUBROUTINE rhoinsitu(salt, tempis, pdbar, N, rhois)
+
+ ! Purpose:
+ ! Compute in situ density from salinity (psu), in situ temperature (C), & pressure (db)
+ ! Needed because rho is a function
+
+ USE mocsy_singledouble
+ IMPLICIT NONE
+
+ INTEGER :: N
+
+! INPUT variables
+ ! salt = salinity [psu]
+ ! tempis = in situ temperature [C]
+ ! pdbar = pressure [db]
+
+ !> salinity [psu]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: salt
+ !> in situ temperature [C]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: tempis
+ !> pressure [db]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: pdbar
+!f2py optional , depend(salt) :: n=len(salt)
+
+! OUTPUT variables:
+ ! rhois = in situ density
+
+ !> in situ density [kg/m3]
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: rhois
+
+! Local variables
+ INTEGER :: i
+
+! REAL(kind=wp) :: rho
+! EXTERNAL rho
+
+ DO i = 1,N
+ rhois(i) = rho(salt(i), tempis(i), pdbar(i)/10.)
+ END DO
+
+ RETURN
+END SUBROUTINE rhoinsitu
+
+! ----------------------------------------------------------------------
+! DEPTH2PRESS
+! ----------------------------------------------------------------------
+!
+!> \file depth2press.f90
+!! \BRIEF
+!> Module with depth2press subroutine - converts depth to pressure
+!! with Saunders (1981) formula
+!> Compute pressure [db] from depth [m] & latitude [degrees north].
+!! This subroutine is needed because p80 is a function (using scalars not arrays)
+SUBROUTINE depth2press(depth, lat, pdbar, N)
+
+ ! Purpose:
+ ! Compute pressure [db] from depth [m] & latitude [degrees north].
+ ! Needed because p80 is a function
+
+ USE mocsy_singledouble
+ IMPLICIT NONE
+
+ !> number of records
+ INTEGER, intent(in) :: N
+
+! INPUT variables
+ !> depth [m]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: depth
+ !> latitude [degrees]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: lat
+!f2py optional , depend(depth) :: n=len(depth)
+
+! OUTPUT variables:
+ !> pressure [db]
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: pdbar
+
+ ! Local variables
+ INTEGER :: i
+
+! REAL(kind=wp) :: p80
+! EXTERNAL p80
+
+ DO i = 1,N
+ pdbar(i) = p80(depth(i), lat(i))
+ END DO
+
+ RETURN
+END SUBROUTINE depth2press
+
+! ----------------------------------------------------------------------
+! CONSTANTS
+! ----------------------------------------------------------------------
+!
+!> \file constants.f90
+!! \BRIEF
+!> Module with contants subroutine - computes carbonate system constants
+!! from S,T,P
+!> Compute thermodynamic constants
+!! FROM temperature, salinity, and pressure (1D arrays)
+SUBROUTINE constants(K0, K1, K2, Kb, Kw, Ks, Kf, Kspc, Kspa, &
+ K1p, K2p, K3p, Ksi, &
+ St, Ft, Bt, &
+ temp, sal, Patm, &
+ depth, lat, N, &
+ optT, optP, optB, optK1K2, optKf, optGAS)
+
+ ! Purpose:
+ ! Compute thermodynamic constants
+ ! FROM: temperature, salinity, and pressure (1D arrays)
+
+ ! INPUT variables:
+ ! ================
+ ! Patm = atmospheric pressure [atm]
+ ! depth = depth [m] (with optP='m', i.e., for a z-coordinate model vertical grid is depth, not pressure)
+ ! = pressure [db] (with optP='db')
+ ! lat = latitude [degrees] (needed to convert depth to pressure, i.e., when optP='m')
+ ! = dummy array (unused when optP='db')
+ ! temp = potential temperature [degrees C] (with optT='Tpot', i.e., models carry tempot, not temp)
+ ! = in situ temperature [degrees C] (with optT='Tinsitu', e.g., for data)
+ ! sal = salinity in [psu]
+ ! ---------
+ ! optT: choose in situ vs. potential temperature as input
+ ! ---------
+ ! NOTE: Carbonate chem calculations require IN-SITU temperature (not potential Temperature)
+ ! -> 'Tpot' means input is pot. Temperature (in situ Temp "tempis" is computed)
+ ! -> 'Tinsitu' means input is already in-situ Temperature, not pot. Temp ("tempis" not computed)
+ ! ---------
+ ! optP: choose depth (m) vs pressure (db) as input
+ ! ---------
+ ! -> 'm' means "depth" input is in "m" (thus in situ Pressure "p" [db] is computed)
+ ! -> 'db' means "depth" input is already in situ pressure [db], not m (p = depth)
+ ! ---------
+ ! optB:
+ ! ---------
+ ! -> 'u74' means use classic formulation of Uppström (1974) for total Boron
+ ! -> 'l10' means use newer formulation of Lee et al. (2010) for total Boron
+ ! ---------
+ ! optK1K2:
+ ! ---------
+ ! -> 'l' means use Lueker et al. (2000) formulations for K1 & K2 (recommended by Dickson et al. 2007)
+ ! **** BUT this should only be used when 2 < T < 35 and 19 < S < 43
+ ! -> 'm10' means use Millero (2010) formulation for K1 & K2 (see Dickson et al., 2007)
+ ! **** Valid for 0 < T < 50°C and 1 < S < 50 psu
+ ! -> 'w14' means use Waters (2014) formulation for K1 & K2 (see Dickson et al., 2007)
+ ! **** Valid for 0 < T < 50°C and 1 < S < 50 psu
+ ! -----------
+ ! optKf:
+ ! ----------
+ ! -> 'pf' means use Perez & Fraga (1987) formulation for Kf (recommended by Dickson et al., 2007)
+ ! **** BUT Valid for 9 < T < 33°C and 10 < S < 40.
+ ! -> 'dg' means use Dickson & Riley (1979) formulation for Kf (recommended by Dickson & Goyet, 1994)
+ ! -----------
+ ! optGAS: choose in situ vs. potential fCO2 and pCO2
+ ! ---------
+ ! PRESSURE corrections for K0 and the fugacity coefficient (Cf)
+ ! -> 'Pzero' = 'zero order' fCO2 and pCO2 (typical approach, which is flawed)
+ ! considers in situ T & only atm pressure (hydrostatic=0)
+ ! -> 'Ppot' = 'potential' fCO2 and pCO2 (water parcel brought adiabatically to the surface)
+ ! considers potential T & only atm pressure (hydrostatic press = 0)
+ ! -> 'Pinsitu' = 'in situ' fCO2 and pCO2 (accounts for huge effects of pressure)
+ ! considers in situ T & total pressure (atm + hydrostatic)
+ ! ---------
+
+ ! OUTPUT variables:
+ ! =================
+ ! K0, K1, K2, Kb, Kw, Ks, Kf, Kspc, Kspa, K1p, K2p, K3p, Ksi
+ ! St, Ft, Bt
+
+ USE mocsy_singledouble
+ IMPLICIT NONE
+
+! Input variables
+ !> number of records
+ INTEGER, INTENT(in) :: N
+ !> in situ temperature (when optT='Tinsitu', typical data)
+ !! OR potential temperature (when optT='Tpot', typical models) [degree C]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: temp
+ !> depth in meters (when optP='m') or decibars (when optP='db')
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: depth
+ !> latitude [degrees north]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: lat
+ !> salinity [psu]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: sal
+!f2py optional , depend(sal) :: n=len(sal)
+
+ !> atmospheric pressure [atm]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: Patm
+
+ !> for temp input, choose \b 'Tinsitu' for in situ Temp or
+ !! \b 'Tpot' for potential temperature (in situ Temp is computed, needed for models)
+ CHARACTER(7), INTENT(in) :: optT
+ !> for depth input, choose \b "db" for decibars (in situ pressure) or \b "m" for meters (pressure is computed, needed for models)
+ CHARACTER(2), INTENT(in) :: optP
+ !> for total boron, choose either \b 'u74' (Uppstrom, 1974) or \b 'l10' (Lee et al., 2010).
+ !! The 'l10' formulation is based on 139 measurements (instead of 20),
+ !! uses a more accurate method, and
+ !! generally increases total boron in seawater by 4%
+!f2py character*3 optional, intent(in) :: optB='l10'
+ CHARACTER(3), OPTIONAL, INTENT(in) :: optB
+ !> for Kf, choose either \b 'pf' (Perez & Fraga, 1987) or \b 'dg' (Dickson & Riley, 1979)
+!f2py character*2 optional, intent(in) :: optKf='pf'
+ CHARACTER(2), OPTIONAL, INTENT(in) :: optKf
+ !> for K1,K2 choose either \b 'l' (Lueker et al., 2000) or \b 'm10' (Millero, 2010) or \b 'w14' (Waters et al., 2014)
+!f2py character*3 optional, intent(in) :: optK1K2='l'
+ CHARACTER(3), OPTIONAL, INTENT(in) :: optK1K2
+ !> for K0,fugacity coefficient choose either \b 'Ppot' (no pressure correction) or \b 'Pinsitu' (with pressure correction)
+ !! 'Ppot' - for 'potential' fCO2 and pCO2 (water parcel brought adiabatically to the surface)
+ !! 'Pinsitu' - for 'in situ' values of fCO2 and pCO2, accounting for pressure on K0 and Cf
+ !! with 'Pinsitu' the fCO2 and pCO2 will be many times higher in the deep ocean
+!f2py character*7 optional, intent(in) :: optGAS='Pinsitu'
+ CHARACTER(7), OPTIONAL, INTENT(in) :: optGAS
+
+! Ouput variables
+ !> solubility of CO2 in seawater (Weiss, 1974), also known as K0
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: K0
+ !> K1 for the dissociation of carbonic acid from Lueker et al. (2000) or Millero (2010), depending on optK1K2
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: K1
+ !> K2 for the dissociation of carbonic acid from Lueker et al. (2000) or Millero (2010), depending on optK1K2
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: K2
+ !> equilibrium constant for dissociation of boric acid
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: Kb
+ !> equilibrium constant for the dissociation of water (Millero, 1995)
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: Kw
+ !> equilibrium constant for the dissociation of bisulfate (Dickson, 1990)
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: Ks
+ !> equilibrium constant for the dissociation of hydrogen fluoride
+ !! either from Dickson and Riley (1979) or from Perez and Fraga (1987), depending on optKf
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: Kf
+ !> solubility product for calcite (Mucci, 1983)
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: Kspc
+ !> solubility product for aragonite (Mucci, 1983)
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: Kspa
+ !> 1st dissociation constant for phosphoric acid (Millero, 1995)
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: K1p
+ !> 2nd dissociation constant for phosphoric acid (Millero, 1995)
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: K2p
+ !> 3rd dissociation constant for phosphoric acid (Millero, 1995)
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: K3p
+ !> equilibrium constant for the dissociation of silicic acid (Millero, 1995)
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: Ksi
+ !> total sulfate (Morris & Riley, 1966)
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: St
+ !> total fluoride (Riley, 1965)
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: Ft
+ !> total boron
+ !! from either Uppstrom (1974) or Lee et al. (2010), depending on optB
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: Bt
+
+! Local variables
+ REAL(kind=wp) :: ssal
+ REAL(kind=wp) :: p
+ REAL(kind=wp) :: tempot, tempis68, tempot68
+ REAL(kind=wp) :: tempis
+ REAL(kind=wp) :: is, invtk, dlogtk, is2, s2, sqrtis
+ REAL(kind=wp) :: Ks_0p, Kf_0p
+ REAL(kind=wp) :: total2free, free2SWS, total2SWS, SWS2total
+ REAL(kind=wp) :: total2free_0p, free2SWS_0p, total2SWS_0p
+! REAL(kind=wp) :: free2SWS, free2SWS_0p
+
+ REAL(kind=wp) :: dtempot, dtempot68
+ REAL(kind=wp) :: R
+
+ REAL(kind=wp) :: pK1o, ma1, mb1, mc1, pK1
+ REAL(kind=wp) :: pK2o, ma2, mb2, mc2, pK2
+
+ REAL(kind=wp), DIMENSION(12) :: a0, a1, a2, b0, b1, b2
+ REAL(kind=wp), DIMENSION(12) :: deltav, deltak, lnkpok0
+ REAL(kind=wp) :: tmp, nK0we74
+
+ INTEGER :: i, icount, ipc
+
+ REAL(kind=wp) :: t, tk, tk0, prb
+ REAL(kind=wp) :: s, sqrts, s15, scl
+
+ REAL(kind=wp) :: Phydro_atm, Patmd, Ptot, Rgas_atm, vbarCO2
+
+! Arrays to pass optional arguments into or use defaults (Dickson et al., 2007)
+ CHARACTER(3) :: opB
+ CHARACTER(2) :: opKf
+ CHARACTER(3) :: opK1K2
+ CHARACTER(7) :: opGAS
+
+ ! CONSTANTS
+ ! =========
+ ! Constants in formulation for Pressure effect on K's (Millero, 95)
+ ! with corrected coefficients for Kb, Kw, Ksi, etc.
+
+ ! index: 1) K1 , 2) K2, 3) Kb, 4) Kw, 5) Ks, 6) Kf, 7) Kspc, 8) Kspa,
+ ! 9) K1P, 10) K2P, 11) K3P, 12) Ksi
+
+ DATA a0 /-25.5_wp, -15.82_wp, -29.48_wp, -20.02_wp, &
+ -18.03_wp, -9.78_wp, -48.76_wp, -45.96_wp, &
+ -14.51_wp, -23.12_wp, -26.57_wp, -29.48_wp/
+ DATA a1 /0.1271_wp, -0.0219_wp, 0.1622_wp, 0.1119_wp, &
+ 0.0466_wp, -0.0090_wp, 0.5304_wp, 0.5304_wp, &
+ 0.1211_wp, 0.1758_wp, 0.2020_wp, 0.1622_wp/
+ DATA a2 / 0.0_wp, 0.0_wp, -2.608e-3_wp, -1.409e-3_wp, &
+ 0.316e-3_wp, -0.942e-3_wp, 0.0_wp, 0.0_wp, &
+ -0.321e-3_wp, -2.647e-3_wp, -3.042e-3_wp, -2.6080e-3_wp/
+ DATA b0 /-3.08e-3_wp, 1.13e-3_wp, -2.84e-3_wp, -5.13e-3_wp, &
+ -4.53e-3_wp, -3.91e-3_wp, -11.76e-3_wp, -11.76e-3_wp, &
+ -2.67e-3_wp, -5.15e-3_wp, -4.08e-3_wp, -2.84e-3_wp/
+ DATA b1 /0.0877e-3_wp, -0.1475e-3_wp, 0.0_wp, 0.0794e-3_wp, &
+ 0.09e-3_wp, 0.054e-3_wp, 0.3692e-3_wp, 0.3692e-3_wp, &
+ 0.0427e-3_wp, 0.09e-3_wp, 0.0714e-3_wp, 0.0_wp/
+ DATA b2 /12*0.0_wp/
+
+! Set defaults for optional arguments (in Fortran 90)
+! Note: Optional arguments with f2py (python) are set above with
+! the !f2py statements that precede each type declaraion
+ IF (PRESENT(optB)) THEN
+ opB = optB
+ ELSE
+ opB = 'l10'
+ ENDIF
+ IF (PRESENT(optKf)) THEN
+ opKf = optKf
+ ELSE
+ opKf = 'pf'
+ ENDIF
+ IF (PRESENT(optK1K2)) THEN
+ opK1K2 = optK1K2
+ ELSE
+ opK1K2 = 'l'
+ ENDIF
+ IF (PRESENT(optGAS)) THEN
+ opGAS = optGAS
+ ELSE
+ opGAS = 'Pinsitu'
+ ENDIF
+
+ R = 83.14472_wp
+
+ icount = 0
+ DO i = 1, N
+ icount = icount + 1
+! ===============================================================
+! Convert model depth -> press; convert model Theta -> T in situ
+! ===============================================================
+! * Model temperature tracer is usually "potential temperature"
+! * Model vertical grid is usually in meters
+! BUT carbonate chem routines require pressure & in-situ T
+! Thus before computing chemistry, if appropriate,
+! convert these 2 model vars (input to this routine)
+! - depth [m] => convert to pressure [db]
+! - potential temperature (C) => convert to in-situ T (C)
+! -------------------------------------------------------
+! 1) Compute pressure [db] from depth [m] and latitude [degrees] (if input is m, for models)
+ IF (trim(optP) == 'm' ) THEN
+! Compute pressure [db] from depth [m] and latitude [degrees]
+ p = p80(depth(i), lat(i))
+ ELSEIF (trim(optP) == 'db' ) THEN
+! In this case (where optP = 'db'), p is input & output (no depth->pressure conversion needed)
+ p = depth(i)
+ ELSE
+ PRINT *,"optP must be 'm' or 'db'"
+ STOP
+ ENDIF
+
+! 2) Convert potential T to in-situ T (if input is Tpot, i.e. case for models):
+ IF (trim(optT) == 'Tpot' .OR. trim(optT) == 'tpot') THEN
+ tempot = temp(i)
+! This is the case for most models and some data
+! a) Convert the pot. temp on today's "ITS 90" scale to older IPTS 68 scale
+! (see Dickson et al., Best Practices Guide, 2007, Chap. 5, p. 7, including footnote)
+ tempot68 = (tempot - 0.0002) / 0.99975
+! b) Compute "in-situ Temperature" from "Potential Temperature" (both on IPTS 68)
+ tempis68 = sw_temp(sal(i), tempot68, p, 0.0_wp )
+! c) Convert the in-situ temp on older IPTS 68 scale to modern scale (ITS 90)
+ tempis = 0.99975*tempis68 + 0.0002
+! Note: parts (a) and (c) above are tiny corrections;
+! part (b) is a big correction for deep waters (but zero at surface)
+ ELSEIF (trim(optT) == 'Tinsitu' .OR. trim(optT) == 'tinsitu') THEN
+! When optT = 'Tinsitu', tempis is input & output (no tempot needed)
+ tempis = temp(i)
+ tempis68 = (temp(i) - 0.0002) / 0.99975
+! dtempot68 = sw_ptmp(DBLE(sal(i)), DBLE(tempis68), DBLE(p), 0.0_wp)
+ dtempot68 = sw_ptmp(sal(i), tempis68, p, 0.0_wp)
+ dtempot = 0.99975*dtempot68 + 0.0002
+ ELSE
+ PRINT *,"optT must be either 'Tpot' or 'Tinsitu'"
+ PRINT *,"you specified optT =", trim(optT)
+ STOP
+ ENDIF
+
+! Compute constants:
+ IF (temp(i) >= -5. .AND. temp(i) < 1.0e+2) THEN
+! Test to indicate if any of input variables are unreasonable
+ IF ( sal(i) < 0. .OR. sal(i) > 1e+3) THEN
+ PRINT *, 'i, icount, temp, sal =', i, icount, temp(i), sal(i)
+ ENDIF
+! Zero out negative salinity (prev case for OCMIP2 model w/ slightly negative S in some coastal cells)
+ IF (sal(i) < 0.0) THEN
+ ssal = 0.0
+ ELSE
+ ssal = sal(i)
+ ENDIF
+
+! Absolute temperature (Kelvin) and related values
+ t = DBLE(tempis)
+ tk = 273.15d0 + t
+ invtk=1.0d0/tk
+ dlogtk=LOG(tk)
+
+! Atmospheric pressure
+ Patmd = DBLE(Patm(i))
+
+! Hydrostatic pressure (prb is in bars)
+ prb = DBLE(p) / 10.0d0
+
+! Salinity and simply related values
+ s = DBLE(ssal)
+ s2=s*s
+ sqrts=SQRT(s)
+ s15=s**1.5d0
+ scl=s/1.80655d0
+
+! Ionic strength:
+ is = 19.924d0*s/(1000.0d0 - 1.005d0*s)
+ is2 = is*is
+ sqrtis = SQRT(is)
+
+! Total concentrations for sulfate, fluoride, and boron
+
+! Sulfate: Morris & Riley (1966)
+ St(i) = 0.14d0 * scl/96.062d0
+
+! Fluoride: Riley (1965)
+ Ft(i) = 0.000067d0 * scl/18.9984d0
+
+! Boron:
+ IF (trim(opB) == 'l10') THEN
+! New formulation from Lee et al (2010)
+ Bt(i) = 0.0002414d0 * scl/10.811d0
+ ELSEIF (trim(opB) == 'u74') THEN
+! Classic formulation from Uppström (1974)
+ Bt(i) = 0.000232d0 * scl/10.811d0
+ ELSE
+ PRINT *,"optB must be 'l10' or 'u74'"
+ STOP
+ ENDIF
+
+! K0 (K Henry)
+! CO2(g) <-> CO2(aq.)
+! K0 = [CO2]/ fCO2
+! Weiss (1974) [mol/kg/atm]
+ IF (trim(opGAS) == 'Pzero' .OR. trim(opGAS) == 'pzero') THEN
+ tk0 = tk !in situ temperature (K) for K0 calculation
+ Ptot = Patmd !total pressure (in atm) = atmospheric pressure ONLY
+ ELSEIF (trim(opGAS) == 'Ppot' .OR. trim(opGAS) == 'ppot') THEN
+ tk0 = dtempot + 273.15d0 !potential temperature (K) for K0 calculation as needed for potential fCO2 & pCO2
+ Ptot = Patmd !total pressure (in atm) = atmospheric pressure ONLY
+ ELSEIF (trim(opGAS) == 'Pinsitu' .OR. trim(opGAS) == 'pinsitu') THEN
+ tk0 = tk !in situ temperature (K) for K0 calculation
+ Phydro_atm = prb / 1.01325d0 !convert hydrostatic pressure from bar to atm (1.01325 bar / atm)
+ Ptot = Patmd + Phydro_atm !total pressure (in atm) = atmospheric pressure + hydrostatic pressure
+ ELSE
+ PRINT *, "optGAS must be 'Pzero', 'Ppot', or 'Pinsitu'"
+ STOP
+ ENDIF
+ tmp = 9345.17d0/tk0 - 60.2409d0 + 23.3585d0 * LOG(tk0/100.0d0)
+ nK0we74 = tmp + s*(0.023517d0 - 0.00023656d0*tk0 + 0.0047036e-4_wp*tk0*tk0)
+ K0(i) = EXP(nK0we74)
+
+! K1 = [H][HCO3]/[H2CO3]
+! K2 = [H][CO3]/[HCO3]
+ IF (trim(opK1K2) == 'l') THEN
+! Mehrbach et al. (1973) refit, by Lueker et al. (2000) (total pH scale)
+ K1(i) = 10.0d0**(-1.0d0*(3633.86d0*invtk - 61.2172d0 + 9.6777d0*dlogtk &
+ - 0.011555d0*s + 0.0001152d0*s2))
+ K2(i) = 10.0d0**(-1*(471.78d0*invtk + 25.9290d0 - 3.16967d0*dlogtk &
+ - 0.01781d0*s + 0.0001122d0*s2))
+ ELSEIF (trim(opK1K2) == 'm10') THEN
+! Millero (2010, Mar. Fresh Wat. Res.) (seawater pH scale)
+ pK1o = 6320.813d0*invtk + 19.568224d0*dlogtk -126.34048d0
+ ma1 = 13.4038d0*sqrts + 0.03206d0*s - (5.242e-5)*s2
+ mb1 = -530.659d0*sqrts - 5.8210d0*s
+ mc1 = -2.0664d0*sqrts
+ pK1 = pK1o + ma1 + mb1*invtk + mc1*dlogtk
+ K1(i) = 10.0d0**(-pK1)
+
+ pK2o = 5143.692d0*invtk + 14.613358d0*dlogtk -90.18333d0
+ ma2 = 21.3728d0*sqrts + 0.1218d0*s - (3.688e-4)*s2
+ mb2 = -788.289d0*sqrts - 19.189d0*s
+ mc2 = -3.374d0*sqrts
+ pK2 = pK2o + ma2 + mb2*invtk + mc2*dlogtk
+ K2(i) = 10.0d0**(-pK2)
+ ELSEIF (trim(opK1K2) == 'w14') THEN
+! Waters, Millero, Woosley (Mar. Chem., 165, 66-67, 2014) (seawater scale)
+ pK1o = 6320.813d0*invtk + 19.568224d0*dlogtk -126.34048d0
+ ma1 = 13.409160d0*sqrts + 0.031646d0*s - (5.1895e-5)*s2
+ mb1 = -531.3642d0*sqrts - 5.713d0*s
+ mc1 = -2.0669166d0*sqrts
+ pK1 = pK1o + ma1 + mb1*invtk + mc1*dlogtk
+ K1(i) = 10.0d0**(-pK1)
+
+ pK2o = 5143.692d0*invtk + 14.613358d0*dlogtk -90.18333d0
+ ma2 = 21.225890d0*sqrts + 0.12450870d0*s - (3.7243e-4_r8)*s2
+ mb2 = -779.3444d0*sqrts - 19.91739d0*s
+ mc2 = -3.3534679d0*sqrts
+ pK2 = pK2o + ma2 + mb2*invtk + mc2*dlogtk
+ K2(i) = 10.0d0**(-pK2)
+ ELSE
+ PRINT *, "optK1K2 must be either 'l' or 'm10', or 'w14'"
+ STOP
+ ENDIF
+
+! Kb = [H][BO2]/[HBO2]
+! (total scale)
+! Millero p.669 (1995) using data from Dickson (1990)
+ Kb(i) = EXP((-8966.90d0 - 2890.53d0*sqrts - 77.942d0*s + &
+ 1.728d0*s15 - 0.0996d0*s2)*invtk + &
+ (148.0248d0 + 137.1942d0*sqrts + 1.62142d0*s) + &
+ (-24.4344d0 - 25.085d0*sqrts - 0.2474d0*s) * &
+ dlogtk + 0.053105d0*sqrts*tk)
+
+! K1p = [H][H2PO4]/[H3PO4]
+! (seawater scale)
+! DOE(1994) eq 7.2.20 with footnote using data from Millero (1974)
+! Millero (1995), p.670, eq. 65
+! Use Millero equation's 115.540 constant instead of 115.525 (Dickson et al., 2007).
+! The latter is only an crude approximation to convert to Total scale (by subtracting 0.015)
+! And we want to stay on the SWS scale anyway for the pressure correction later.
+ K1p(i) = EXP(-4576.752d0*invtk + 115.540d0 - 18.453d0*dlogtk + &
+ (-106.736d0*invtk + 0.69171d0) * sqrts + &
+ (-0.65643d0*invtk - 0.01844d0) * s)
+
+! K2p = [H][HPO4]/[H2PO4]
+! (seawater scale)
+! DOE(1994) eq 7.2.23 with footnote using data from Millero (1974))
+! Millero (1995), p.670, eq. 66
+! Use Millero equation's 172.1033 constant instead of 172.0833 (Dickson et al., 2007).
+! The latter is only an crude approximation to convert to Total scale (by subtracting 0.015)
+! And we want to stay on the SWS scale anyway for the pressure correction later.
+ K2p(i) = EXP(-8814.715d0*invtk + 172.1033d0 - 27.927d0*dlogtk + &
+ (-160.340d0*invtk + 1.3566d0)*sqrts + &
+ (0.37335d0*invtk - 0.05778d0)*s)
+
+! K3p = [H][PO4]/[HPO4]
+! (seawater scale)
+! DOE(1994) eq 7.2.26 with footnote using data from Millero (1974)
+! Millero (1995), p.670, eq. 67
+! Use Millero equation's 18.126 constant instead of 18.141 (Dickson et al., 2007).
+! The latter is only an crude approximation to convert to Total scale (by subtracting 0.015)
+! And we want to stay on the SWS scale anyway for the pressure correction later.
+ K3p(i) = EXP(-3070.75d0*invtk - 18.126d0 + &
+ (17.27039d0*invtk + 2.81197d0) * &
+ sqrts + (-44.99486d0*invtk - 0.09984d0) * s)
+
+! Ksi = [H][SiO(OH)3]/[Si(OH)4]
+! (seawater scale)
+! Millero (1995), p.671, eq. 72
+! Use Millero equation's 117.400 constant instead of 117.385 (Dickson et al., 2007).
+! The latter is only an crude approximation to convert to Total scale (by subtracting 0.015)
+! And we want to stay on the SWS scale anyway for the pressure correction later.
+ Ksi(i) = EXP(-8904.2d0*invtk + 117.400d0 - 19.334d0*dlogtk + &
+ (-458.79d0*invtk + 3.5913d0) * sqrtis + &
+ (188.74d0*invtk - 1.5998d0) * is + &
+ (-12.1652d0*invtk + 0.07871d0) * is2 + &
+ LOG(1.0 - 0.001005d0*s))
+
+! Kw = [H][OH]
+! (seawater scale)
+! Millero (1995) p.670, eq. 63 from composite data
+! Use Millero equation's 148.9802 constant instead of 148.9652 (Dickson et al., 2007).
+! The latter is only an crude approximation to convert to Total scale (by subtracting 0.015)
+! And we want to stay on the SWS scale anyway for the pressure correction later.
+ Kw(i) = EXP(-13847.26d0*invtk + 148.9802d0 - 23.6521d0*dlogtk + &
+ (118.67d0*invtk - 5.977d0 + 1.0495d0 * dlogtk) * &
+ sqrts - 0.01615d0 * s)
+
+! Ks = [H][SO4]/[HSO4]
+! (free scale)
+! Dickson (1990, J. chem. Thermodynamics 22, 113)
+ Ks_0p = EXP(-4276.1d0*invtk + 141.328d0 - 23.093d0*dlogtk &
+ + (-13856.d0*invtk + 324.57d0 - 47.986d0*dlogtk) * sqrtis &
+ + (35474.d0*invtk - 771.54 + 114.723d0*dlogtk) * is &
+ - 2698.d0*invtk*is**1.5 + 1776.d0*invtk*is2 &
+ + LOG(1.0d0 - 0.001005d0*s))
+
+! Kf = [H][F]/[HF]
+! (total scale)
+ IF (trim(opKf) == 'dg') THEN
+! Dickson and Riley (1979) -- change pH scale to total (following Dickson & Goyet, 1994)
+ Kf_0p = EXP(1590.2d0*invtk - 12.641d0 + 1.525d0*sqrtis + &
+ LOG(1.0d0 - 0.001005d0*s) + &
+ LOG(1.0d0 + St(i)/Ks_0p))
+ ELSEIF (trim(opKf) == 'pf') THEN
+! Perez and Fraga (1987) - Already on Total scale (no need for last line above)
+! Formulation as given in Dickson et al. (2007)
+ Kf_0p = EXP(874.d0*invtk - 9.68d0 + 0.111d0*sqrts)
+ ELSE
+ PRINT *, "optKf must be either 'dg' or 'pf'"
+ STOP
+ ENDIF
+
+! Kspc (calcite) - apparent solubility product of calcite
+! (no scale)
+! Kspc = [Ca2+] [CO32-] when soln is in equilibrium w/ calcite
+! Mucci 1983 mol/kg-soln
+ Kspc(i) = 10d0**(-171.9065d0 - 0.077993d0*tk + 2839.319d0/tk &
+ + 71.595d0*LOG10(tk) &
+ + (-0.77712d0 + 0.0028426d0*tk + 178.34d0/tk)*sqrts &
+ -0.07711d0*s + 0.0041249d0*s15 )
+
+
+! Kspa (aragonite) - apparent solubility product of aragonite
+! (no scale)
+! Kspa = [Ca2+] [CO32-] when soln is in equilibrium w/ aragonite
+! Mucci 1983 mol/kg-soln
+ Kspa(i) = 10.d0**(-171.945d0 - 0.077993d0*tk + 2903.293d0/tk &
+ +71.595d0*LOG10(tk) &
+ +(-0.068393d0 + 0.0017276d0*tk + 88.135d0/tk)*sqrts &
+ -0.10018d0*s + 0.0059415d0*s15 )
+
+! Pressure effect on K0 based on Weiss (1974, equation 5)
+ Rgas_atm = 82.05736_wp ! (cm3 * atm) / (mol * K) CODATA (2006)
+ vbarCO2 = 32.3_wp ! partial molal volume (cm3 / mol) from Weiss (1974, Appendix, paragraph 3)
+ K0(i) = K0(i) * exp( ((1-Ptot)*vbarCO2)/(Rgas_atm*tk0) ) ! Weiss (1974, equation 5)
+
+! Pressure effect on all other K's (based on Millero, (1995)
+! index: K1(1), K2(2), Kb(3), Kw(4), Ks(5), Kf(6), Kspc(7), Kspa(8),
+! K1p(9), K2p(10), K3p(11), Ksi(12)
+ DO ipc = 1, 12
+ deltav(ipc) = a0(ipc) + a1(ipc) *t + a2(ipc) *t*t
+ deltak(ipc) = (b0(ipc) + b1(ipc) *t + b2(ipc) *t*t)
+ lnkpok0(ipc) = (-(deltav(ipc)) &
+ +(0.5d0*deltak(ipc) * prb) &
+ ) * prb/(R*tk)
+ END DO
+
+! Pressure correction on Ks (Free scale)
+ Ks(i) = Ks_0p*EXP(lnkpok0(5))
+! Conversion factor total -> free scale
+ total2free = 1.d0/(1.d0 + St(i)/Ks(i)) ! Kfree = Ktotal*total2free
+! Conversion factor total -> free scale at pressure zero
+ total2free_0p = 1.d0/(1.d0 + St(i)/Ks_0p) ! Kfree = Ktotal*total2free
+
+! Pressure correction on Kf
+! Kf must be on FREE scale before correction
+ Kf_0p = Kf_0p * total2free_0p !Convert from Total to Free scale (pressure 0)
+ Kf(i) = Kf_0p * EXP(lnkpok0(6)) !Pressure correction (on Free scale)
+ Kf(i) = Kf(i)/total2free !Convert back from Free to Total scale
+
+! Convert between seawater and total hydrogen (pH) scales
+ free2SWS = 1.d0 + St(i)/Ks(i) + Ft(i)/(Kf(i)*total2free) ! using Kf on free scale
+ total2SWS = total2free * free2SWS ! KSWS = Ktotal*total2SWS
+ SWS2total = 1.d0 / total2SWS
+! Conversion at pressure zero
+ free2SWS_0p = 1.d0 + St(i)/Ks_0p + Ft(i)/(Kf_0p) ! using Kf on free scale
+ total2SWS_0p = total2free_0p * free2SWS_0p ! KSWS = Ktotal*total2SWS
+
+! Convert from Total to Seawater scale before pressure correction
+! Must change to SEAWATER scale: K1, K2, Kb
+ IF (trim(optK1K2) == 'l') THEN
+ K1(i) = K1(i)*total2SWS_0p
+ K2(i) = K2(i)*total2SWS_0p
+ !This conversion is unnecessary for the K1,K2 from Millero (2010),
+ !since we use here the formulation already on the seawater scale
+ ENDIF
+ Kb(i) = Kb(i)*total2SWS_0p
+
+! Already on SEAWATER scale: K1p, K2p, K3p, Kb, Ksi, Kw
+
+! Other contants (keep on another scale):
+! - K0 (independent of pH scale, already pressure corrected)
+! - Ks (already on Free scale; already pressure corrected)
+! - Kf (already on Total scale; already pressure corrected)
+! - Kspc, Kspa (independent of pH scale; pressure-corrected below)
+
+! Perform actual pressure correction (on seawater scale)
+ K1(i) = K1(i)*EXP(lnkpok0(1))
+ K2(i) = K2(i)*EXP(lnkpok0(2))
+ Kb(i) = Kb(i)*EXP(lnkpok0(3))
+ Kw(i) = Kw(i)*EXP(lnkpok0(4))
+ Kspc(i) = Kspc(i)*EXP(lnkpok0(7))
+ Kspa(i) = Kspa(i)*EXP(lnkpok0(8))
+ K1p(i) = K1p(i)*EXP(lnkpok0(9))
+ K2p(i) = K2p(i)*EXP(lnkpok0(10))
+ K3p(i) = K3p(i)*EXP(lnkpok0(11))
+ Ksi(i) = Ksi(i)*EXP(lnkpok0(12))
+
+! Convert back to original total scale:
+ K1(i) = K1(i) *SWS2total
+ K2(i) = K2(i) *SWS2total
+ K1p(i) = K1p(i)*SWS2total
+ K2p(i) = K2p(i)*SWS2total
+ K3p(i) = K3p(i)*SWS2total
+ Kb(i) = Kb(i) *SWS2total
+ Ksi(i) = Ksi(i)*SWS2total
+ Kw(i) = Kw(i) *SWS2total
+
+ ELSE
+
+ K0(i) = 1.e20_wp
+ K1(i) = 1.e20_wp
+ K2(i) = 1.e20_wp
+ Kb(i) = 1.e20_wp
+ Kw(i) = 1.e20_wp
+ Ks(i) = 1.e20_wp
+ Kf(i) = 1.e20_wp
+ Kspc(i) = 1.e20_wp
+ Kspa(i) = 1.e20_wp
+ K1p(i) = 1.e20_wp
+ K2p(i) = 1.e20_wp
+ K3p(i) = 1.e20_wp
+ Ksi(i) = 1.e20_wp
+ Bt(i) = 1.e20_wp
+ Ft(i) = 1.e20_wp
+ St(i) = 1.e20_wp
+
+ ENDIF
+
+ END DO
+
+ RETURN
+END SUBROUTINE constants
+
+! ----------------------------------------------------------------------
+! VARSOLVER
+! ----------------------------------------------------------------------
+!
+!> \file varsolver.f90
+!! \BRIEF
+!> Module with varsolver subroutine - solve for pH and other carbonate system variables
+!> Solve for pH and other carbonate system variables (with input from vars routine)
+SUBROUTINE varsolver(ph, pco2, fco2, co2, hco3, co3, OmegaA, OmegaC, &
+ temp, salt, ta, tc, pt, sit, &
+ Bt, St, Ft, &
+ K0, K1, K2, Kb, Kw, Ks, Kf, Kspc, Kspa, K1p, K2p, K3p, Ksi, &
+ Patm, Phydro_bar, rhodum, optGAS )
+
+ ! Purpose: Solve for pH and other carbonate system variables (with input from vars routine)
+
+ ! INPUT variables:
+ ! ================
+ ! temp = in situ temperature [degrees C]
+ ! ta = total alkalinity in [eq/m^3] or [eq/kg] based on optCON in calling routine (vars)
+ ! tc = dissolved inorganic carbon in [mol/m^3] or [mol/kg] based on optCON in calling routine (vars)
+ ! pt = total dissolved inorganic phosphorus in [mol/m^3] or [mol/kg] based on optCON in calling routine (vars)
+ ! sit = total dissolved inorganic silicon in [mol/m^3] or [mol/kg] based on optCON in calling routine (vars)
+ ! Bt = total dissolved inorganic boron computed in calling routine (vars)
+ ! St = total dissolved inorganic sulfur computed in calling routine (vars)
+ ! Ft = total dissolved inorganic fluorine computed in calling routine (vars)
+ ! K's = K0, K1, K2, Kb, Kw, Ks, Kf, Kspc, Kspa, K1p, K2p, K3p, Ksi
+ ! Patm = atmospheric pressure [atm]
+ ! Phydro_bar = hydrostatic pressure [bar]
+ ! rhodum = density factor as computed in calling routine (vars)
+ ! -----------
+ ! optGAS: choose in situ vs. potential fCO2 and pCO2 (default optGAS = 'Pinsitu')
+ ! ---------
+ ! PRESSURE & T corrections for K0 and the fugacity coefficient (Cf)
+ ! -> 'Pzero' = 'zero order' fCO2 and pCO2 (typical approach, which is flawed)
+ ! considers in situ T & only atm pressure (hydrostatic=0)
+ ! -> 'Ppot' = 'potential' fCO2 and pCO2 (water parcel brought adiabatically to the surface)
+ ! considers potential T & only atm pressure (hydrostatic press = 0)
+ ! -> 'Pinsitu' = 'in situ' fCO2 and pCO2 (accounts for huge effects of pressure)
+ ! considers in situ T & total pressure (atm + hydrostatic)
+ ! ---------
+
+ ! OUTPUT variables:
+ ! =================
+ ! ph = pH on total scale
+ ! pco2 = CO2 partial pressure (uatm)
+ ! fco2 = CO2 fugacity (uatm)
+ ! co2 = aqueous CO2 concentration in [mol/kg] or [mol/m^3] determined by rhodum (depends on optCON in calling routine)
+ ! hco3 = bicarbonate (HCO3-) concentration in [mol/kg] or [mol/m^3] determined by rhodum
+ ! co3 = carbonate (CO3--) concentration in [mol/kg] or [mol/m^3] determined by rhodum
+ ! OmegaA = Omega for aragonite, i.e., the aragonite saturation state
+ ! OmegaC = Omega for calcite, i.e., the calcite saturation state
+
+ USE mocsy_singledouble
+ USE mocsy_phsolvers
+
+ IMPLICIT NONE
+
+! Input variables
+ !> in situ temperature [degrees C]
+ REAL(kind=wp), INTENT(in) :: temp
+ !> salinity [on the practical salinity scale, dimensionless]
+ REAL(kind=wp), INTENT(in) :: salt
+ !> total alkalinity in [eq/m^3] OR in [eq/kg], depending on optCON in calling routine
+ REAL(kind=wp), INTENT(in) :: ta
+ !> dissolved inorganic carbon in [mol/m^3] OR in [mol/kg], depending on optCON in calling routine
+ REAL(kind=wp), INTENT(in) :: tc
+ !> phosphate concentration in [mol/m^3] OR in [mol/kg], depending on optCON in calling routine
+ REAL(kind=wp), INTENT(in) :: pt
+ !> total dissolved inorganic silicon concentration in [mol/m^3] OR in [mol/kg], depending on optCON in calling routine
+ REAL(kind=wp), INTENT(in) :: sit
+ !> total boron from either Uppstrom (1974) or Lee et al. (2010), depending on optB in calling routine
+ REAL(kind=wp), INTENT(in) :: Bt
+ !> total sulfate (Morris & Riley, 1966)
+ REAL(kind=wp), INTENT(in) :: St
+ !> total fluoride (Riley, 1965)
+ REAL(kind=wp), INTENT(in) :: Ft
+ !> solubility of CO2 in seawater (Weiss, 1974), also known as K0
+ REAL(kind=wp), INTENT(in) :: K0
+ !> K1 for the dissociation of carbonic acid from Lueker et al. (2000) or Millero (2010), depending on optK1K2
+ REAL(kind=wp), INTENT(in) :: K1
+ !> K2 for the dissociation of carbonic acid from Lueker et al. (2000) or Millero (2010), depending on optK1K2
+ REAL(kind=wp), INTENT(in) :: K2
+ !> equilibrium constant for dissociation of boric acid
+ REAL(kind=wp), INTENT(in) :: Kb
+ !> equilibrium constant for the dissociation of water (Millero, 1995)
+ REAL(kind=wp), INTENT(in) :: Kw
+ !> equilibrium constant for the dissociation of bisulfate (Dickson, 1990)
+ REAL(kind=wp), INTENT(in) :: Ks
+ !> equilibrium constant for the dissociation of hydrogen fluoride
+ !! from Dickson and Riley (1979) or Perez and Fraga (1987), depending on optKf
+ REAL(kind=wp), INTENT(in) :: Kf
+ !> solubility product for calcite (Mucci, 1983)
+ REAL(kind=wp), INTENT(in) :: Kspc
+ !> solubility product for aragonite (Mucci, 1983)
+ REAL(kind=wp), INTENT(in) :: Kspa
+ !> 1st dissociation constant for phosphoric acid (Millero, 1995)
+ REAL(kind=wp), INTENT(in) :: K1p
+ !> 2nd dissociation constant for phosphoric acid (Millero, 1995)
+ REAL(kind=wp), INTENT(in) :: K2p
+ !> 3rd dissociation constant for phosphoric acid (Millero, 1995)
+ REAL(kind=wp), INTENT(in) :: K3p
+ !> equilibrium constant for the dissociation of silicic acid (Millero, 1995)
+ REAL(kind=wp), INTENT(in) :: Ksi
+ !> total atmospheric pressure [atm]
+ REAL(kind=wp), INTENT(in) :: Patm
+ !> total hydrostatic pressure [bar]
+ REAL(kind=wp), INTENT(in) :: Phydro_bar
+ !> density factor as computed incalling routine (vars)
+ REAL(kind=wp), INTENT(in) :: rhodum
+ !> for K0,fugacity coefficient choose either \b 'Ppot' (no pressure correction) or \b 'Pinsitu' (with pressure correction)
+ !! 'Ppot' - for 'potential' fCO2 and pCO2 (water parcel brought adiabatically to the surface)
+ !! 'Pinsitu' - for 'in situ' values of fCO2 and pCO2, accounting for pressure on K0 and Cf
+ !! with 'Pinsitu' the fCO2 and pCO2 will be many times higher in the deep ocean
+!f2py character*7 optional, intent(in) :: optGAS='Pinsitu'
+ CHARACTER(7), OPTIONAL, INTENT(in) :: optGAS
+
+! Output variables:
+ !> pH on the total scale
+ REAL(kind=wp), INTENT(out) :: ph
+ !> CO2 partial pressure [uatm]
+ REAL(kind=wp), INTENT(out) :: pco2
+ !> CO2 fugacity [uatm]
+ REAL(kind=wp), INTENT(out) :: fco2
+ !> aqueous CO2* concentration, either in [mol/m^3] or [mol/kg] depending on choice for optCON
+ REAL(kind=wp), INTENT(out) :: co2
+ !> bicarbonate ion (HCO3-) concentration, either in [mol/m^3] or [mol/kg] depending on choice for optCON
+ REAL(kind=wp), INTENT(out) :: hco3
+ !> carbonate ion (CO3--) concentration, either in [mol/m^3] or [mol/kg] depending on choice for optCON
+ REAL(kind=wp), INTENT(out) :: co3
+ !> Omega for aragonite, i.e., the aragonite saturation state
+ REAL(kind=wp), INTENT(out) :: OmegaA
+ !> Omega for calcite, i.e., the calcite saturation state
+ REAL(kind=wp), INTENT(out) :: OmegaC
+
+! Local variables
+ REAL(kind=wp) :: Phydro_atm, Ptot
+ REAL(kind=wp) :: Rgas_atm, B, Del, xCO2approx, xc2, fugcoeff
+ REAL(kind=wp) :: tk, tk0
+ real(kind=wp) :: temp68, tempot, tempot68
+ REAL(kind=wp) :: Hinit, H
+ REAL(kind=wp) :: HSO4, HF, HSI, HPO4
+ REAL(kind=wp) :: ab, aw, ac
+ REAL(kind=wp) :: cu, cb, cc
+ REAL(kind=wp) :: Ca
+! Array to pass optional arguments
+ CHARACTER(7) :: opGAS
+
+ IF (PRESENT(optGAS)) THEN
+ opGAS = optGAS
+ ELSE
+ opGAS = 'Pinsitu'
+ ENDIF
+
+! Compute pH from constants and total concentrations
+! - use SolveSAPHE v1.0.1 routines from Munhoven (2013, GMD) modified to use mocsy's Ks instead of its own
+! 1) Compute best starting point for H+ calculation
+ call ahini_for_at(ta, tc, Bt, K1, K2, Kb, Hinit)
+! 2) Solve for H+ using above result as the initial H+ value
+ H = solve_at_general(ta, tc, Bt, &
+ pt, sit, &
+ St, Ft, &
+ K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi, &
+ Hinit)
+! 3) Calculate pH from from H+ concentration (mol/kg)
+ IF (H > 0.d0) THEN
+ pH = -1.*LOG10(H)
+ ELSE
+ pH = 1.e20_wp
+ ENDIF
+
+! Compute carbonate Alk (Ac) by difference: from total Alk and other Alk components
+ HSO4 = St/(1.0d0 + Ks/(H/(1.0d0 + St/Ks)))
+ HF = 1.0d0/(1.0d0 + Kf/H)
+ HSI = 1.0d0/(1.0d0 + H/Ksi)
+ HPO4 = (K1p*K2p*(H + 2.*K3p) - H**3) / &
+ (H**3 + K1p*H**2 + K1p*K2p*H + K1p*K2p*K3p)
+ ab = Bt/(1.0d0 + H/Kb)
+ aw = Kw/H - H/(1.0d0 + St/Ks)
+ ac = ta + hso4 - sit*hsi - ab - aw + Ft*hf - pt*hpo4
+
+! Calculate CO2*, HCO3-, & CO32- (in mol/kg soln) from Ct, Ac, H+, K1, & K2
+ cu = (2.0d0 * tc - ac) / (2.0d0 + K1 / H)
+ cb = K1 * cu / H
+ cc = K2 * cb / H
+
+! When optCON = 'mol/m3' in calling routine (vars), then:
+! convert output var concentrations from mol/kg to mol/m^3
+! e.g., for case when drho = 1028, multiply by [1.028 kg/L x 1000 L/m^3])
+ co2 = cu * rhodum
+ hco3 = cb * rhodum
+ co3 = cc * rhodum
+
+! Determine CO2 fugacity [uatm]
+! NOTE: equation just below requires CO2* in mol/kg
+ fCO2 = cu * 1.e6_wp/K0
+
+! Determine CO2 partial pressure from CO2 fugacity [uatm]
+ tk = 273.15d0 + temp
+ !Compute EITHER "potential pCO2" OR "in situ pCO2" (T and P used for calculations will differ)
+ IF (trim(opGAS) == 'Pzero' .OR. trim(opGAS) == 'pzero') THEN
+ tk0 = tk !in situ temperature (K) for K0 calculation
+ Ptot = Patm !total pressure (in atm) = atmospheric pressure ONLY
+ ELSEIF (trim(opGAS) == 'Ppot' .OR. trim(opGAS) == 'ppot') THEN
+ !Use potential temperature and atmospheric pressure (water parcel adiabatically brought back to surface)
+ !temp68 = (temp - 0.0002d0) / 0.99975d0 !temp = in situ T; temp68 is same converted to ITPS-68 scale
+ !tempot68 = sw_ptmp(salt, temp68, Phydro_bar*10d0, 0.0d0) !potential temperature (C)
+ !tempot = 0.99975*tempot68 + 0.0002
+ !tk0 = tempot + 273.15d0 !potential temperature (K) for fugacity coeff. calc as needed for potential fCO2 & pCO2
+ tempot = sw_ptmp(salt, temp, Phydro_bar*10._wp, 0.0_wp) !potential temperature (C)
+ tk0 = tempot + 273.15d0 !potential temperature (K) for fugacity coeff. calc as needed for potential fCO2 & pCO2
+ Ptot = Patm !total pressure (in atm) = atmospheric pressure ONLY
+ ELSEIF (trim(opGAS) == 'Pinsitu' .OR. trim(opGAS) == 'pinsitu') THEN
+ !Use in situ temperature and total pressure
+ tk0 = tk !in situ temperature (K) for fugacity coefficient calculation
+ Phydro_atm = Phydro_bar / 1.01325d0 !convert hydrostatic pressure from bar to atm (1.01325 bar / atm)
+ Ptot = Patm + Phydro_atm !total pressure (in atm) = atmospheric pressure + hydrostatic pressure
+ ELSE
+ PRINT *, "optGAS must be 'Pzero', 'Ppot', or 'Pinsitu'"
+ STOP
+ ENDIF
+
+! Now that we have T and P in the right form, continue with calculation of fugacity coefficient (and pCO2)
+ Rgas_atm = 82.05736_wp ! (cm3 * atm) / (mol * K) CODATA (2006)
+! To compute fugcoeff, we need 3 other terms (B, Del, xc2) in addition to 3 others above (tk, Ptot, Rgas_atm)
+ B = -1636.75d0 + 12.0408d0*tk0 - 0.0327957d0*(tk0*tk0) + 0.0000316528d0*(tk0*tk0*tk0)
+ Del = 57.7d0 - 0.118d0*tk0
+! "x2" term often neglected (assumed = 1) in applications of Weiss's (1974) equation 9
+! x2 = 1 - x1 = 1 - xCO2 (it is very close to 1, but not quite)
+! Let's assume that xCO2 = fCO2. Resulting fugcoeff is identical to 8th digit after the decimal.
+ xCO2approx = fCO2 * 1.e-6_wp
+ IF (trim(opGAS) == 'Pinsitu' .OR. trim(opGAS) == 'pinsitu') THEN
+! xCO2approx = 400.0e-6_wp !a simple test (gives about same result as seacarb for pCO2insitu)
+! approximate surface xCO2 ~ surface fCO2 (i.e., in situ fCO2 d by exponential pressure correction)
+ xCO2approx = xCO2approx * exp( ((1-Ptot)*32.3_wp)/(82.05736_wp*tk0) ) ! of K0 press. correction, see Weiss (1974, equation 5)
+ ENDIF
+ xc2 = (1.0d0 - xCO2approx)**2
+ fugcoeff = exp( Ptot*(B + 2.0d0*xc2*Del)/(Rgas_atm*tk0) )
+ pCO2 = fCO2 / fugcoeff
+
+! Determine Omega Calcite et Aragonite
+! OmegaA = ((0.01028d0*salt/35.0d0)*cc) / Kspa
+! OmegaC = ((0.01028d0*salt/35.0d0)*cc) / Kspc
+! - see comments from Munhoven on the best value "0.02128" which differs slightly from the best practices guide (0.02127)
+ Ca = (0.02128d0/40.078d0) * salt/1.80655d0
+ OmegaA = (Ca*cc) / Kspa
+ OmegaC = (Ca*cc) / Kspc
+
+ RETURN
+END SUBROUTINE varsolver
+
+! ----------------------------------------------------------------------
+! VARS
+! ----------------------------------------------------------------------
+!
+!> \file vars.f90
+!! \BRIEF
+!> Module with vars subroutine - compute carbonate system vars from DIC,Alk,T,S,P,nuts
+!> Computes standard carbonate system variables (pH, CO2*, HCO3- and CO32-, OmegaA, OmegaC, R)
+!! as 1D arrays FROM
+!! temperature, salinity, pressure,
+!! total alkalinity (ALK), dissolved inorganic carbon (DIC),
+!! silica and phosphate concentrations (all 1-D arrays)
+SUBROUTINE vars(ph, pco2, fco2, co2, hco3, co3, OmegaA, OmegaC, BetaD, rhoSW, p, tempis, &
+ temp, sal, alk, dic, sil, phos, Patm, depth, lat, N, &
+ optCON, optT, optP, optB, optK1K2, optKf, optGAS )
+
+ ! Purpose:
+ ! Computes other standard carbonate system variables (pH, CO2*, HCO3- and CO32-, OmegaA, OmegaC, R)
+ ! as 1D arrays
+ ! FROM:
+ ! temperature, salinity, pressure,
+ ! total alkalinity (ALK), dissolved inorganic carbon (DIC),
+ ! silica and phosphate concentrations (all 1-D arrays)
+
+ ! INPUT variables:
+ ! ================
+ ! Patm = atmospheric pressure [atm]
+ ! depth = depth [m] (with optP='m', i.e., for a z-coordinate model vertical grid is depth, not pressure)
+ ! = pressure [db] (with optP='db')
+ ! lat = latitude [degrees] (needed to convert depth to pressure, i.e., when optP='m')
+ ! = dummy array (unused when optP='db')
+ ! temp = potential temperature [degrees C] (with optT='Tpot', i.e., models carry tempot, not in situ temp)
+ ! = in situ temperature [degrees C] (with optT='Tinsitu', e.g., for data)
+ ! sal = salinity in [psu]
+ ! alk = total alkalinity in [eq/m^3] with optCON = 'mol/m3'
+ ! = [eq/kg] with optCON = 'mol/kg'
+ ! dic = dissolved inorganic carbon [mol/m^3] with optCON = 'mol/m3'
+ ! = [mol/kg] with optCON = 'mol/kg'
+ ! sil = silica [mol/m^3] with optCON = 'mol/m3'
+ ! = [mol/kg] with optCON = 'mol/kg'
+ ! phos = phosphate [mol/m^3] with optCON = 'mol/m3'
+ ! = [mol/kg] with optCON = 'mol/kg'
+ ! INPUT options:
+ ! ==============
+ ! -----------
+ ! optCON: choose input & output concentration units - mol/kg (data) vs. mol/m^3 (models)
+ ! -----------
+ ! -> 'mol/kg' for DIC, ALK, sil, & phos given on mokal scale, i.e., in mol/kg (std DATA units)
+ ! -> 'mol/m3' for DIC, ALK, sil, & phos given in mol/m^3 (std MODEL units)
+ ! -----------
+ ! optT: choose in situ vs. potential temperature as input
+ ! ---------
+ ! NOTE: Carbonate chem calculations require IN-SITU temperature (not potential Temperature)
+ ! -> 'Tpot' means input is pot. Temperature (in situ Temp "tempis" is computed)
+ ! -> 'Tinsitu' means input is already in-situ Temperature, not pot. Temp ("tempis" not computed)
+ ! ---------
+ ! optP: choose depth (m) vs pressure (db) as input
+ ! ---------
+ ! -> 'm' means "depth" input is in "m" (thus in situ Pressure "p" [db] is computed)
+ ! -> 'db' means "depth" input is already in situ pressure [db], not m (thus p = depth)
+ ! ---------
+ ! optB: choose total boron formulation - Uppström (1974) vs. Lee et al. (2010)
+ ! ---------
+ ! -> 'u74' means use classic formulation of Uppström (1974) for total Boron
+ ! -> 'l10' means use newer formulation of Lee et al. (2010) for total Boron
+ ! ---------
+ ! optK1K2:
+ ! ---------
+ ! -> 'l' means use Lueker et al. (2000) formulations for K1 & K2 (recommended by Dickson et al. 2007)
+ ! **** BUT this should only be used when 2 < T < 35 and 19 < S < 43
+ ! -> 'm10' means use Millero (2010) formulation for K1 & K2 (see Dickson et al., 2007)
+ ! **** Valid for 0 < T < 50°C and 1 < S < 50 psu
+ ! ----------
+ ! optKf:
+ ! ----------
+ ! -> 'pf' means use Perez & Fraga (1987) formulation for Kf (recommended by Dickson et al., 2007)
+ ! **** BUT Valid for 9 < T < 33°C and 10 < S < 40.
+ ! -> 'dg' means use Dickson & Riley (1979) formulation for Kf (recommended by Dickson & Goyet, 1994)
+ ! -----------
+ ! optGAS: choose in situ vs. potential fCO2 and pCO2
+ ! ---------
+ ! PRESSURE corrections for K0 and the fugacity coefficient (Cf)
+ ! -> 'Pzero' = 'zero order' fCO2 and pCO2 (typical approach, which is flawed)
+ ! considers in situ T & only atm pressure (hydrostatic=0)
+ ! -> 'Ppot' = 'potential' fCO2 and pCO2 (water parcel brought adiabatically to the surface)
+ ! considers potential T & only atm pressure (hydrostatic press = 0)
+ ! -> 'Pinsitu' = 'in situ' fCO2 and pCO2 (accounts for huge effects of pressure)
+ ! considers in situ T & total pressure (atm + hydrostatic)
+ ! ---------
+
+ ! OUTPUT variables:
+ ! =================
+ ! ph = pH on total scale
+ ! pco2 = CO2 partial pressure (uatm)
+ ! fco2 = CO2 fugacity (uatm)
+ ! co2 = aqueous CO2 concentration in [mol/kg] or [mol/m^3] depending on optCON
+ ! hco3 = bicarbonate (HCO3-) concentration in [mol/kg] or [mol/m^3] depending on optCON
+ ! co3 = carbonate (CO3--) concentration in [mol/kg] or [mol/m^3] depending on optCON
+ ! OmegaA = Omega for aragonite, i.e., the aragonite saturation state
+ ! OmegaC = Omega for calcite, i.e., the calcite saturation state
+ ! BetaD = Revelle factor dpCO2/pCO2 / dDIC/DIC
+ ! rhoSW = in-situ density of seawater; rhoSW = f(s, t, p)
+ ! p = pressure [decibars]; p = f(depth, latitude) if computed from depth [m] OR p = depth if [db]
+ ! tempis = in-situ temperature [degrees C]
+
+ USE mocsy_singledouble
+
+ IMPLICIT NONE
+
+! Input variables
+ !> number of records
+ INTEGER, INTENT(in) :: N
+ !> either in situ temperature (when optT='Tinsitu', typical data)
+ !! OR potential temperature (when optT='Tpot', typical models) [degree C]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: temp
+ !> salinity [psu]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: sal
+ !> total alkalinity in [eq/m^3] (when optCON = 'mol/m3') OR in [eq/kg] (when optCON = 'mol/kg')
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: alk
+ !> dissolved inorganic carbon in [mol/m^3] (when optCON = 'mol/m3') OR in [mol/kg] (when optCON = 'mol/kg')
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: dic
+ !> SiO2 concentration in [mol/m^3] (when optCON = 'mol/m3') OR in [mol/kg] (when optCON = 'mol/kg')
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: sil
+ !> phosphate concentration in [mol/m^3] (when optCON = 'mol/m3') OR in [mol/kg] (when optCON = 'mol/kg')
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: phos
+!f2py optional , depend(sal) :: n=len(sal)
+ !> atmospheric pressure [atm]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: Patm
+ !> depth in \b meters (when optP='m') or \b decibars (when optP='db')
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: depth
+ !> latitude [degrees north]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: lat
+
+ !> choose either \b 'mol/kg' (std DATA units) or \b 'mol/m3' (std MODEL units) to select
+ !! concentration units for input (for alk, dic, sil, phos) & output (co2, hco3, co3)
+ CHARACTER(6), INTENT(in) :: optCON
+ !> choose \b 'Tinsitu' for in situ temperature or \b 'Tpot' for potential temperature (in situ Temp is computed, needed for models)
+ CHARACTER(7), INTENT(in) :: optT
+ !> for depth input, choose \b "db" for decibars (in situ pressure) or \b "m" for meters (pressure is computed, needed for models)
+ CHARACTER(2), INTENT(in) :: optP
+ !> for total boron, choose either \b 'u74' (Uppstrom, 1974) or \b 'l10' (Lee et al., 2010).
+ !! The 'l10' formulation is based on 139 measurements (instead of 20),
+ !! uses a more accurate method, and
+ !! generally increases total boron in seawater by 4%
+!f2py character*3 optional, intent(in) :: optB='l10'
+ CHARACTER(3), OPTIONAL, INTENT(in) :: optB
+ !> for Kf, choose either \b 'pf' (Perez & Fraga, 1987) or \b 'dg' (Dickson & Riley, 1979)
+!f2py character*2 optional, intent(in) :: optKf='pf'
+ CHARACTER(2), OPTIONAL, INTENT(in) :: optKf
+ !> for K1,K2 choose either \b 'l' (Lueker et al., 2000) or \b 'm10' (Millero, 2010)
+!f2py character*3 optional, intent(in) :: optK1K2='l'
+ CHARACTER(3), OPTIONAL, INTENT(in) :: optK1K2
+ !> for K0,fugacity coefficient choose either \b 'Ppot' (no pressure correction) or \b 'Pinsitu' (with pressure correction)
+ !! 'Ppot' - for 'potential' fCO2 and pCO2 (water parcel brought adiabatically to the surface)
+ !! 'Pinsitu' - for 'in situ' values of fCO2 and pCO2, accounting for pressure on K0 and Cf
+ !! with 'Pinsitu' the fCO2 and pCO2 will be many times higher in the deep ocean
+!f2py character*7 optional, intent(in) :: optGAS='Pinsitu'
+ CHARACTER(7), OPTIONAL, INTENT(in) :: optGAS
+
+! Output variables:
+ !> pH on the total scale
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: ph
+ !> CO2 partial pressure [uatm]
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: pco2
+ !> CO2 fugacity [uatm]
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: fco2
+ !> aqueous CO2* concentration, either in [mol/m^3] or [mol/kg] depending on choice for optCON
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: co2
+ !> bicarbonate ion (HCO3-) concentration, either in [mol/m^3] or [mol/kg] depending on choice for optCON
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: hco3
+ !> carbonate ion (CO3--) concentration, either in [mol/m^3] or [mol/kg] depending on choice for optCON
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: co3
+ !> Omega for aragonite, i.e., the aragonite saturation state
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: OmegaA
+ !> Omega for calcite, i.e., the calcite saturation state
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: OmegaC
+ !> Revelle factor, i.e., dpCO2/pCO2 / dDIC/DIC
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: BetaD
+ !> in-situ density of seawater; rhoSW = f(s, t, p) in [kg/m3]
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: rhoSW
+ !> pressure [decibars]; p = f(depth, latitude) if computed from depth [m] (when optP='m') OR p = depth [db] (when optP='db')
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: p
+ !> in-situ temperature \b [degrees C]
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: tempis
+
+! Local variables
+ REAL(kind=wp) :: ssal, salk, sdic, ssil, sphos
+ REAL(kind=wp) :: tempot, tempis68, tempot68
+ REAL(kind=wp) :: drho
+
+ REAL(kind=wp) :: K0, K1, K2, Kb, Kw, Ks, Kf, Kspc
+ REAL(kind=wp) :: Kspa, K1p, K2p, K3p, Ksi
+ REAL(kind=wp) :: St, Ft, Bt
+
+ REAL(kind=wp), DIMENSION(1) :: aK0, aK1, aK2, aKb, aKw, aKs, aKf, aKspc
+ REAL(kind=wp), DIMENSION(1) :: aKspa, aK1p, aK2p, aK3p, aKsi
+ REAL(kind=wp), DIMENSION(1) :: aSt, aFt, aBt
+
+ REAL(kind=wp) :: Patmd, Ptot, Rgas_atm, B, Del, xCO2approx, xc2, fugcoeff
+ REAL(kind=wp) :: Phydro_atm
+
+ INTEGER :: i, icount
+
+ REAL(kind=wp) :: t, tk, prb
+ REAL(kind=wp) :: s
+ REAL(kind=wp) :: tc, ta
+ REAL(kind=wp) :: sit, pt
+ REAL(kind=wp) :: Hinit
+ REAL(kind=wp) :: ah1
+
+ REAL(kind=wp) :: HSO4, HF, HSI, HPO4
+ REAL(kind=wp) :: ab, aw, ac, ah2, erel
+
+ REAL(kind=wp) :: cu, cb, cc
+
+ REAL(kind=wp), DIMENSION(2) :: dicdel, pco2del
+ REAL(kind=wp) :: dx, Rf
+ REAL(kind=wp) :: dph, dpco2, dfco2, dco2, dhco3, dco3, dOmegaA, dOmegaC
+
+ INTEGER :: kcomp
+ INTEGER :: j, minusplus
+
+! Arrays to pass optional arguments into or use defaults (Dickson et al., 2007)
+ CHARACTER(3) :: opB
+ CHARACTER(2) :: opKf
+ CHARACTER(3) :: opK1K2
+ CHARACTER(7) :: opGAS
+
+! Set defaults for optional arguments (in Fortran 90)
+! Note: Optional arguments with f2py (python) are set above with
+! the !f2py statements that precede each type declaraion
+ IF (PRESENT(optB)) THEN
+! print *,"optB present:"
+! print *,"optB = ", optB
+ opB = optB
+ ELSE
+! Default is Lee et al (2010) for total boron
+! print *,"optB NOT present:"
+ opB = 'l10'
+! print *,"opB = ", opB
+ ENDIF
+ IF (PRESENT(optKf)) THEN
+! print *,"optKf = ", optKf
+ opKf = optKf
+ ELSE
+! print *,"optKf NOT present:"
+! Default is Perez & Fraga (1987) for Kf
+ opKf = 'pf'
+! print *,"opKf = ", opKf
+ ENDIF
+ IF (PRESENT(optK1K2)) THEN
+! print *,"optK1K2 = ", optK1K2
+ opK1K2 = optK1K2
+ ELSE
+! print *,"optK1K2 NOT present:"
+! Default is Lueker et al. 2000) for K1 & K2
+ opK1K2 = 'l'
+! print *,"opK1K2 = ", opK1K2
+ ENDIF
+ IF (PRESENT(optGAS)) THEN
+ opGAS = optGAS
+ ELSE
+ opGAS = 'Pinsitu'
+ ENDIF
+
+ icount = 0
+ DO i = 1, N
+ icount = icount + 1
+! ===============================================================
+! Convert model depth -> press; convert model Theta -> T in situ
+! ===============================================================
+! * Model temperature tracer is usually "potential temperature"
+! * Model vertical grid is usually in meters
+! BUT carbonate chem routines require pressure & in-situ T
+! Thus before computing chemistry, if appropriate,
+! convert these 2 model vars (input to this routine)
+! - depth [m] => convert to pressure [db]
+! - potential temperature (C) => convert to in-situ T (C)
+! -------------------------------------------------------
+! 1) Compute pressure [db] from depth [m] and latitude [degrees] (if input is m, for models)
+ !print *,"optP =", optP, "end"
+ IF (trim(optP) == 'm' ) THEN
+! Compute pressure [db] from depth [m] and latitude [degrees]
+ p(i) = p80(depth(i), lat(i))
+ ELSEIF (trim(optP) == 'db') THEN
+! In this case (where optP = 'db'), p is input & output (no depth->pressure conversion needed)
+ p(i) = depth(i)
+ ELSE
+ !print *,"optP =", optP, "end"
+ PRINT *,"optP must be either 'm' or 'db'"
+ STOP
+ ENDIF
+
+! 2) Convert potential T to in-situ T (if input is Tpot, i.e. case for models):
+ IF (trim(optT) == 'Tpot' .OR. trim(optT) == 'tpot') THEN
+ tempot = temp(i)
+! This is the case for most models and some data
+! a) Convert the pot. temp on today's "ITS 90" scale to older IPTS 68 scale
+! (see Dickson et al., Best Practices Guide, 2007, Chap. 5, p. 7, including footnote)
+ tempot68 = (tempot - 0.0002) / 0.99975
+! b) Compute "in-situ Temperature" from "Potential Temperature" (both on IPTS 68)
+ tempis68 = sw_temp(sal(i), tempot68, p(i), 0.0_wp )
+! c) Convert the in-situ temp on older IPTS 68 scale to modern scale (ITS 90)
+ tempis(i) = 0.99975*tempis68 + 0.0002
+! Note: parts (a) and (c) above are tiny corrections;
+! part (b) is a big correction for deep waters (but zero at surface)
+ ELSEIF (trim(optT) == 'Tinsitu' .OR. trim(optT) == 'tinsitu') THEN
+! When optT = 'Tinsitu', tempis is input & output (no tempot needed)
+ tempis(i) = temp(i)
+ tempis68 = (temp(i) - 0.0002) / 0.99975
+! dtempot68 = sw_ptmp(DBLE(sal(i)), DBLE(tempis68), DBLE(p), 0.0d0)
+! dtempot = 0.99975*dtempot68 + 0.0002
+ ELSE
+ PRINT *,"optT must be either 'Tpot' or 'Tinsitu'"
+ PRINT *,"you specified optT =", trim(optT)
+ STOP
+ ENDIF
+
+! ================================================================
+! Carbonate chemistry computations
+! ================================================================
+ IF (dic(i) > 0. .AND. dic(i) < 1.0e+4) THEN
+! Test to indicate if any of input variables are unreasonable
+ IF ( sal(i) < 0. &
+ .OR. alk(i) < 0. &
+ .OR. dic(i) < 0. &
+ .OR. sil(i) < 0. &
+ .OR. phos(i) < 0. &
+ .OR. sal(i) > 1e+3 &
+ .OR. alk(i) > 1e+3 &
+ .OR. dic(i) > 1e+3 &
+ .OR. sil(i) > 1e+3 &
+ .OR. phos(i) > 1e+3) THEN
+ PRINT *, 'i, icount, tempot, sal, alk, dic, sil, phos =', &
+ i, icount, tempot, sal(i), alk(i), dic(i), sil(i), phos(i)
+ ENDIF
+! Zero out any negative salinity, phosphate, silica, dic, and alk
+ IF (sal(i) < 0.0) THEN
+ ssal = 0.0
+ ELSE
+ ssal = sal(i)
+ ENDIF
+ IF (phos(i) < 0.0) THEN
+ sphos = 0.0
+ ELSE
+ sphos = phos(i)
+ ENDIF
+ IF (sil(i) < 0.0) THEN
+ ssil = 0.0
+ ELSE
+ ssil = sil(i)
+ ENDIF
+ IF (dic(i) < 0.0) THEN
+ sdic = 0.0
+ ELSE
+ sdic = dic(i)
+ ENDIF
+ IF (alk(i) < 0.0) THEN
+ salk = 0.0
+ ELSE
+ salk = alk(i)
+ ENDIF
+
+! Absolute temperature (Kelvin) & related variables
+ t = DBLE(tempis(i))
+ tk = 273.15d0 + t
+
+! Atmospheric pressure
+ Patmd = DBLE(Patm(i))
+! Hydrostatic pressure (prb is in bars)
+ prb = DBLE(p(i)) / 10.0d0
+ Phydro_atm = prb / 1.01325d0 ! convert hydrostatic pressure from bar to atm (1.01325 bar / atm)
+! Total pressure [atm]
+ IF (trim(opGAS) == 'Pzero' .OR. trim(opGAS) == 'pzero') THEN
+ Ptot = Patmd ! total pressure (in atm) = atmospheric pressure ONLY
+ ELSEIF (trim(opGAS) == 'Ppot' .OR. trim(opGAS) == 'ppot') THEN
+ Ptot = Patmd ! total pressure (in atm) = atmospheric pressure ONLY
+ ELSEIF (trim(opGAS) == 'Pinsitu' .OR. trim(opGAS) == 'pinsitu') THEN
+ Ptot = Patmd + Phydro_atm ! total pressure (in atm) = atmospheric pressure + hydrostatic pressure
+ ELSE
+ PRINT *, "optGAS must be 'Pzero', 'Ppot', or 'Pinsitu'"
+ STOP
+ ENDIF
+
+! Salinity (equivalent array in double precision)
+ s = DBLE(ssal)
+
+! Get all equilibrium constants and total concentrations of SO4, F, B
+ CALL constants(aK0, aK1, aK2, aKb, aKw, aKs, aKf, aKspc, aKspa, &
+ aK1p, aK2p, aK3p, aKsi, &
+ aSt, aFt, aBt, &
+ temp(i), sal(i), Patm(i), &
+ depth(i), lat(i), 1, &
+ optT, optP, opB, opK1K2, opKf, opGAS )
+
+! Unlike f77, in F90 we can't assign an array (dimen=1) to a scalar in a routine argument
+! Thus, set scalar constants equal to array (dimension=1) values required as arguments
+ K0 = aK0(1) ; K1 = aK1(1) ; K2 = aK2(1) ; Kb = aKb(1) ; Kw = aKw(1)
+ Ks = aKs(1) ; Kf = aKs(1) ; Kspc = aKspc(1) ; Kspa = aKspa(1)
+ K1p = aK1p(1) ; K2p = aK2p(1) ; K3p = aK3p(1) ; Ksi = aKsi(1)
+ St = aSt(1) ; Ft = aFt(1) ; Bt = aBt(1)
+
+! Compute in-situ density [kg/m^3]
+ rhoSW(i) = rho(ssal, tempis68, prb)
+
+! Either convert units of DIC and ALK (MODEL case) or not (DATA case)
+ IF (trim(optCON) == 'mol/kg') THEN
+! No conversion:
+! print *,'DIC and ALK already given in mol/kg (std DATA units)'
+ drho = 1.
+ ELSEIF (trim(optCON) == 'mol/m3') THEN
+! Do conversion:
+! print *,"DIC and ALK given in mol/m^3 (std MODEL units)"
+ drho = DBLE(rhoSW(i))
+ ELSE
+ PRINT *,"optCON must be either 'mol/kg' or 'mol/m3'"
+ STOP
+ ENDIF
+
+ tc = DBLE(sdic)/drho
+ ta = DBLE(salk)/drho
+ sit = DBLE(ssil)/drho
+ pt = DBLE(sphos)/drho
+
+! Solve for pH and all other variables
+! ------------------------------------
+ CALL varsolver(dph, dpco2, dfco2, dco2, dhco3, dco3, dOmegaA, dOmegaC, &
+ t, s, ta, tc, pt, sit, &
+ Bt, St, Ft, &
+ K0, K1, K2, Kb, Kw, Ks, Kf, Kspc, Kspa, K1p, K2p, K3p, Ksi, &
+ Patmd, prb, drho, opGAS )
+
+! Convert all output variables from double to single precision
+ pH(i) = REAL(dph)
+ co2(i) = REAL(dco2)
+ hco3(i) = REAL(dhco3)
+ co3(i) = REAL(dco3)
+ fCO2(i) = REAL(dfCO2)
+ pCO2(i) = REAL(dpCO2)
+ OmegaA(i) = REAL(dOmegaA)
+ OmegaC(i) = REAL(dOmegaC)
+
+! Compute Revelle factor numerically (derivative using centered-difference scheme)
+ DO j=1,2
+ minusplus = (-1)**j
+ dx = 0.1 * 1e-6 ! Numerical tests found for DIC that optimal dx = 0.1 umol/kg (0.1e-6 mol/kg)
+ dicdel(j) = tc + DBLE(minusplus)*dx/2.0d0
+ CALL varsolver(dph, dpco2, dfco2, dco2, dhco3, dco3, dOmegaA, dOmegaC, &
+ t, s, ta, dicdel(j), pt, sit, &
+ Bt, St, Ft, &
+ K0, K1, K2, Kb, Kw, Ks, Kf, Kspc, Kspa, K1p, K2p, K3p, Ksi, &
+ Patmd, prb, drho, optGAS )
+ pco2del(j) = dpco2
+ END DO
+ !Classic finite centered difference formula for derivative (2nd order accurate)
+ Rf = (pco2del(2) - pco2del(1)) / (dicdel(2) - dicdel(1)) ! dpCO2/dDIC
+ !Rf = (pco2del(2) - pco2del(1)) / (dx) ! dpCO2/dDIC (same as just above)
+ Rf = Rf * tc / dpco2 ! R = (dpCO2/dDIC) * (DIC/pCO2)
+
+ BetaD(i) = REAL(Rf)
+
+ ELSE
+
+ ph(i) = 1.e20_wp
+ pco2(i) = 1.e20_wp
+ fco2(i) = 1.e20_wp
+ co2(i) = 1.e20_wp
+ hco3(i) = 1.e20_wp
+ co3(i) = 1.e20_wp
+ OmegaA(i) = 1.e20_wp
+ OmegaC(i) = 1.e20_wp
+ BetaD(i) = 1.e20_wp
+ rhoSW(i) = 1.e20_wp
+ p(i) = 1.e20_wp
+ tempis(i) = 1.e20_wp
+
+ ENDIF
+
+ END DO
+
+ RETURN
+END SUBROUTINE vars
+
+! ----------------------------------------------------------------------
+! P2FCO2
+! ----------------------------------------------------------------------
+!
+!> \file p2fCO2.f90
+!! \BRIEF
+!> Module with p2fCO2 subroutine - compute fCO2 from pCO2, in situ T, atm pressure, hydrostatic pressure
+!> Compute fCO2 from arrays of pCO2, in situ temp, atm pressure, & hydrostatic pressure
+SUBROUTINE p2fCO2(pCO2, temp, Patm, p, N, fCO2)
+ ! Purpose:
+ ! Compute fCO2 from arrays of pCO2, in situ temp, atm pressure, & hydrostatic pressure
+
+ USE mocsy_singledouble
+ IMPLICIT NONE
+
+ !> number of records
+ INTEGER, INTENT(in) :: N
+
+! INPUT variables
+ !> oceanic partial pressure of CO2 [uatm]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: pCO2
+ !> in situ temperature [C]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: temp
+ !> atmospheric pressure [atm]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: Patm
+ !> hydrostatic pressure [db]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: p
+
+! OUTPUT variables:
+ !> fugacity of CO2 [uatm]
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: fCO2
+
+! LOCAL variables:
+ REAL(kind=wp) :: dpCO2, dtemp, tk, dPatm, prb
+ REAL(kind=wp) :: Ptot, Rgas_atm, B, Del, xCO2approx, xc2, fugcoeff
+ REAL(kind=wp) :: dfCO2
+
+ INTEGER :: i
+
+! REAL(kind=wp) :: sw_ptmp
+! EXTERNAL sw_ptmp
+
+ DO i = 1,N
+ dpCO2 = DBLE(pCO2(i))
+ dtemp = DBLE(temp(i))
+ dPatm = DBLE(Patm(i))
+ tk = 273.15d0 + DBLE(temp(i)) !Absolute temperature (Kelvin)
+ prb = DBLE(p(i)) / 10.0d0 !Pressure effect (prb is in bars)
+ Ptot = dPatm + prb/1.01325d0 !Total pressure (atmospheric + hydrostatic) [atm]
+ Rgas_atm = 82.05736_wp !R in (cm3 * atm) / (mol * K) from CODATA (2006)
+! To compute fugcoeff, we need 3 other terms (B, Del, xc2) as well as 3 others above (tk, Ptot, Rgas_atm)
+ B = -1636.75d0 + 12.0408d0*tk - 0.0327957d0*(tk*tk) + 0.0000316528d0*(tk*tk*tk)
+ Del = 57.7d0 - 0.118d0*tk
+! "x2" term often neglected (assumed = 1) in applications of Weiss's (1974) equation 9
+! x2 = 1 - x1 = 1 - xCO2 (it is very close to 1, but not quite)
+! Let's assume that xCO2 = pCO2. Resulting fugcoeff is identical to 8th digit after the decimal.
+ xCO2approx = dpCO2 * 1.e-6_wp
+ xc2 = (1.0d0 - xCO2approx)**2
+ fugcoeff = EXP( Ptot*(B + 2.0d0*xc2*Del)/(Rgas_atm*tk) )
+ dfCO2 = dpCO2 * fugcoeff
+ fCO2(i) = REAL(dfCO2)
+ END DO
+
+ RETURN
+END SUBROUTINE p2fCO2
+
+! ----------------------------------------------------------------------
+! P2FCO2
+! ----------------------------------------------------------------------
+!
+!> \file f2pCO2.f90
+!! \BRIEF
+!> Module with f2pCO2 subroutine - compute pCO2 from fCO2, in situ T, atm pressure, hydrostatic pressure
+!> Compute pCO2 from arrays of fCO2, in situ temp, atm pressure, & hydrostatic pressure
+SUBROUTINE f2pCO2(fCO2, temp, Patm, p, N, pCO2)
+ ! Purpose:
+ ! Compute pCO2 from arrays of fCO2, in situ temp, atm pressure, & hydrostatic pressure
+
+ USE mocsy_singledouble
+ IMPLICIT NONE
+
+ !> number of records
+ INTEGER, intent(in) :: N
+
+! INPUT variables
+ !> oceanic fugacity of CO2 [uatm]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: fCO2
+ !> in situ temperature [C]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: temp
+ !> atmospheric pressure [atm]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: Patm
+ !> hydrostatic pressure [db]
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: p
+
+! OUTPUT variables:
+ !> oceanic partial pressure of CO2 [uatm]
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: pCO2
+
+! LOCAL variables:
+ REAL(kind=wp) :: dfCO2, dtemp, tk, dPatm, prb
+ REAL(kind=wp) :: Ptot, Rgas_atm, B, Del, xCO2approx, xc2, fugcoeff
+ REAL(kind=wp) :: dpCO2
+
+ INTEGER :: i
+
+! REAL(kind=wp) :: sw_ptmp
+! EXTERNAL sw_ptmp
+
+ DO i = 1,N
+ dfCO2 = DBLE(fCO2(i))
+ dtemp = DBLE(temp(i))
+ dPatm = DBLE(Patm(i))
+ tk = 273.15d0 + DBLE(temp(i)) !Absolute temperature (Kelvin)
+ prb = DBLE(p(i)) / 10.0d0 !Pressure effect (prb is in bars)
+ Ptot = dPatm + prb/1.01325d0 !Total pressure (atmospheric + hydrostatic) [atm]
+ Rgas_atm = 82.05736_wp !R in (cm3 * atm) / (mol * K) from CODATA (2006)
+! To compute fugcoeff, we need 3 other terms (B, Del, xc2) as well as 3 others above (tk, Ptot, Rgas_atm)
+ B = -1636.75d0 + 12.0408d0*tk - 0.0327957d0*(tk*tk) + 0.0000316528d0*(tk*tk*tk)
+ Del = 57.7d0 - 0.118d0*tk
+! "x2" term often neglected (assumed = 1) in applications of Weiss's (1974) equation 9
+! x2 = 1 - x1 = 1 - xCO2 (it is very close to 1, but not quite)
+! Let's assume that xCO2 = fCO2. Resulting fugcoeff is identical to 8th digit after the decimal.
+ xCO2approx = dfCO2 * 1.e-6_wp
+ xc2 = (1.0d0 - xCO2approx)**2
+ fugcoeff = exp( Ptot*(B + 2.0d0*xc2*Del)/(Rgas_atm*tk) )
+ dpCO2 = dfCO2 / fugcoeff
+ pCO2(i) = REAL(dpCO2)
+ END DO
+
+ RETURN
+END SUBROUTINE f2pCO2
+
+END MODULE mocsy_mainmod
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/mocsy_phsolvers.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/mocsy_phsolvers.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/mocsy_phsolvers.F90 (revision 8155)
@@ -0,0 +1,860 @@
+!> \file mocsy_phsolvers.f90
+!! \BRIEF
+!> Module with routines needed to solve pH-total alkalinity equation (Munhoven, 2013, GMD)
+MODULE mocsy_phsolvers
+! Module of fastest solvers from Munhoven (2013, Geosci. Model Dev., 6, 1367-1388)
+! ! Taken from SolveSAPHE (mod_phsolvers.F90) & adapted very slightly for use with mocsy
+! ! SolveSaphe is distributed under the GNU Lesser General Public License
+! ! mocsy is distributed under the MIT License
+!
+! Modifications J. C. Orr, LSCE/IPSL, CEA-CNRS-UVSQ, France, 11 Sep 2014:
+! 1) kept only the 3 fastest solvers (atgen, atsec, atfast) and routines which they call
+! 2) reduced vertical white space: deleted many blank lines & comment lines that served as divisions
+! 3) converted name from .F90 to .f90, deleting a few optional preprocesse if statements
+! 4) read in mocsy computed equilibrium constants (as arguments) instead of USE MOD_CHEMCONST
+! 5) converted routine names from upper case to lower case
+! 6) commented out arguments and equations for NH4 and H2S acid systems
+
+USE mocsy_singledouble
+IMPLICIT NONE
+
+! General parameters
+REAL(KIND=wp), PARAMETER :: pp_rdel_ah_target = 1.E-8_wp
+REAL(KIND=wp), PARAMETER :: pp_ln10 = 2.302585092994045684018_wp
+
+! Maximum number of iterations for each method
+INTEGER, PARAMETER :: jp_maxniter_atgen = 50
+INTEGER, PARAMETER :: jp_maxniter_atsec = 50
+INTEGER, PARAMETER :: jp_maxniter_atfast = 50
+
+! Bookkeeping variables for each method
+! - SOLVE_AT_GENERAL
+INTEGER :: niter_atgen = jp_maxniter_atgen
+
+! - SOLVE_AT_GENERAL_SEC
+INTEGER :: niter_atsec = jp_maxniter_atsec
+
+! - SOLVE_AT_FAST (variant of SOLVE_AT_GENERAL w/o bracketing
+INTEGER :: niter_atfast = jp_maxniter_atfast
+
+! Keep the following functions private to avoid conflicts with
+! other modules that provide similar ones.
+!PRIVATE AHINI_FOR_AT
+
+CONTAINS
+!===============================================================================
+SUBROUTINE anw_infsup(p_dictot, p_bortot, &
+ p_po4tot, p_siltot, &
+ p_so4tot, p_flutot, &
+ p_alknw_inf, p_alknw_sup)
+
+! Subroutine returns the lower and upper bounds of "non-water-selfionization"
+! contributions to total alkalinity (the infimum and the supremum), i.e
+! inf(TA - [OH-] + [H+]) and sup(TA - [OH-] + [H+])
+
+USE mocsy_singledouble
+IMPLICIT NONE
+
+! Argument variables
+REAL(KIND=wp), INTENT(IN) :: p_dictot
+REAL(KIND=wp), INTENT(IN) :: p_bortot
+REAL(KIND=wp), INTENT(IN) :: p_po4tot
+REAL(KIND=wp), INTENT(IN) :: p_siltot
+!REAL(KIND=wp), INTENT(IN) :: p_nh4tot
+!REAL(KIND=wp), INTENT(IN) :: p_h2stot
+REAL(KIND=wp), INTENT(IN) :: p_so4tot
+REAL(KIND=wp), INTENT(IN) :: p_flutot
+REAL(KIND=wp), INTENT(OUT) :: p_alknw_inf
+REAL(KIND=wp), INTENT(OUT) :: p_alknw_sup
+
+p_alknw_inf = -p_po4tot - p_so4tot - p_flutot
+p_alknw_sup = p_dictot + p_dictot + p_bortot &
+ + p_po4tot + p_po4tot + p_siltot !&
+! + p_nh4tot + p_h2stot
+
+RETURN
+END SUBROUTINE anw_infsup
+
+!===============================================================================
+
+FUNCTION equation_at(p_alktot, p_h, p_dictot, p_bortot, &
+ p_po4tot, p_siltot, &
+ p_so4tot, p_flutot, &
+ K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi, &
+ p_deriveqn)
+
+USE mocsy_singledouble
+IMPLICIT NONE
+REAL(KIND=wp) :: equation_at
+
+! Argument variables
+REAL(KIND=wp), INTENT(IN) :: p_alktot
+REAL(KIND=wp), INTENT(IN) :: p_h
+REAL(KIND=wp), INTENT(IN) :: p_dictot
+REAL(KIND=wp), INTENT(IN) :: p_bortot
+REAL(KIND=wp), INTENT(IN) :: p_po4tot
+REAL(KIND=wp), INTENT(IN) :: p_siltot
+!REAL(KIND=wp), INTENT(IN) :: p_nh4tot
+!REAL(KIND=wp), INTENT(IN) :: p_h2stot
+REAL(KIND=wp), INTENT(IN) :: p_so4tot
+REAL(KIND=wp), INTENT(IN) :: p_flutot
+REAL(KIND=wp), INTENT(IN) :: K0, K1, K2, Kb, Kw, Ks, Kf
+REAL(KIND=wp), INTENT(IN) :: K1p, K2p, K3p, Ksi
+REAL(KIND=wp), INTENT(OUT), OPTIONAL :: p_deriveqn
+
+! Local variables
+!-----------------
+REAL(KIND=wp) :: znumer_dic, zdnumer_dic, zdenom_dic, zalk_dic, zdalk_dic
+REAL(KIND=wp) :: znumer_bor, zdnumer_bor, zdenom_bor, zalk_bor, zdalk_bor
+REAL(KIND=wp) :: znumer_po4, zdnumer_po4, zdenom_po4, zalk_po4, zdalk_po4
+REAL(KIND=wp) :: znumer_sil, zdnumer_sil, zdenom_sil, zalk_sil, zdalk_sil
+REAL(KIND=wp) :: znumer_nh4, zdnumer_nh4, zdenom_nh4, zalk_nh4, zdalk_nh4
+REAL(KIND=wp) :: znumer_h2s, zdnumer_h2s, zdenom_h2s, zalk_h2s, zdalk_h2s
+REAL(KIND=wp) :: znumer_so4, zdnumer_so4, zdenom_so4, zalk_so4, zdalk_so4
+REAL(KIND=wp) :: znumer_flu, zdnumer_flu, zdenom_flu, zalk_flu, zdalk_flu
+REAL(KIND=wp) :: zalk_wat, zdalk_wat
+REAL(KIND=wp) :: aphscale
+
+! TOTAL H+ scale: conversion factor for Htot = aphscale * Hfree
+aphscale = 1._wp + p_so4tot/Ks
+
+! H2CO3 - HCO3 - CO3 : n=2, m=0
+znumer_dic = 2._wp*K1*K2 + p_h* K1
+zdenom_dic = K1*K2 + p_h*( K1 + p_h)
+zalk_dic = p_dictot * (znumer_dic/zdenom_dic)
+
+! B(OH)3 - B(OH)4 : n=1, m=0
+znumer_bor = Kb
+zdenom_bor = Kb + p_h
+zalk_bor = p_bortot * (znumer_bor/zdenom_bor)
+
+! H3PO4 - H2PO4 - HPO4 - PO4 : n=3, m=1
+znumer_po4 = 3._wp*K1p*K2p*K3p + p_h*(2._wp*K1p*K2p + p_h* K1p)
+zdenom_po4 = K1p*K2p*K3p + p_h*( K1p*K2p + p_h*(K1p + p_h))
+zalk_po4 = p_po4tot * (znumer_po4/zdenom_po4 - 1._wp) ! Zero level of H3PO4 = 1
+
+! H4SiO4 - H3SiO4 : n=1, m=0
+znumer_sil = Ksi
+zdenom_sil = Ksi + p_h
+zalk_sil = p_siltot * (znumer_sil/zdenom_sil)
+
+! NH4 - NH3 : n=1, m=0
+!znumer_nh4 = api1_nh4
+!zdenom_nh4 = api1_nh4 + p_h
+!zalk_nh4 = p_nh4tot * (znumer_nh4/zdenom_nh4)
+! Note: api1_nh4 = Knh4
+
+! H2S - HS : n=1, m=0
+!znumer_h2s = api1_h2s
+!zdenom_h2s = api1_h2s + p_h
+!zalk_h2s = p_h2stot * (znumer_h2s/zdenom_h2s)
+! Note: api1_h2s = Kh2s
+
+! HSO4 - SO4 : n=1, m=1
+znumer_so4 = Ks
+zdenom_so4 = Ks + p_h
+zalk_so4 = p_so4tot * (znumer_so4/zdenom_so4 - 1._wp)
+
+! HF - F : n=1, m=1
+znumer_flu = Kf
+zdenom_flu = Kf + p_h
+zalk_flu = p_flutot * (znumer_flu/zdenom_flu - 1._wp)
+
+! H2O - OH
+zalk_wat = Kw/p_h - p_h/aphscale
+
+equation_at = zalk_dic + zalk_bor + zalk_po4 + zalk_sil &
+ + zalk_so4 + zalk_flu &
+ + zalk_wat - p_alktot
+
+IF(PRESENT(p_deriveqn)) THEN
+ ! H2CO3 - HCO3 - CO3 : n=2
+ zdnumer_dic = K1*K1*K2 + p_h*(4._wp*K1*K2 &
+ + p_h* K1 )
+ zdalk_dic = -p_dictot*(zdnumer_dic/zdenom_dic**2)
+
+ ! B(OH)3 - B(OH)4 : n=1
+ zdnumer_bor = Kb
+ zdalk_bor = -p_bortot*(zdnumer_bor/zdenom_bor**2)
+
+ ! H3PO4 - H2PO4 - HPO4 - PO4 : n=3
+ zdnumer_po4 = K1p*K2p*K1p*K2p*K3p + p_h*(4._wp*K1p*K1p*K2p*K3p &
+ + p_h*(9._wp*K1p*K2p*K3p + K1p*K1p*K2p &
+ + p_h*(4._wp*K1p*K2p &
+ + p_h* K1p)))
+ zdalk_po4 = -p_po4tot * (zdnumer_po4/zdenom_po4**2)
+
+ ! H4SiO4 - H3SiO4 : n=1
+ zdnumer_sil = Ksi
+ zdalk_sil = -p_siltot * (zdnumer_sil/zdenom_sil**2)
+
+! ! NH4 - NH3 : n=1
+! zdnumer_nh4 = Knh4
+! zdalk_nh4 = -p_nh4tot * (zdnumer_nh4/zdenom_nh4**2)
+
+! ! H2S - HS : n=1
+! zdnumer_h2s = api1_h2s
+! zdalk_h2s = -p_h2stot * (zdnumer_h2s/zdenom_h2s**2)
+
+ ! HSO4 - SO4 : n=1
+ zdnumer_so4 = Ks
+ zdalk_so4 = -p_so4tot * (zdnumer_so4/zdenom_so4**2)
+
+ ! HF - F : n=1
+ zdnumer_flu = Kf
+ zdalk_flu = -p_flutot * (zdnumer_flu/zdenom_flu**2)
+
+! p_deriveqn = zdalk_dic + zdalk_bor + zdalk_po4 + zdalk_sil &
+! + zdalk_nh4 + zdalk_h2s + zdalk_so4 + zdalk_flu &
+! - Kw/p_h**2 - 1._wp/aphscale
+ p_deriveqn = zdalk_dic + zdalk_bor + zdalk_po4 + zdalk_sil &
+ + zdalk_so4 + zdalk_flu &
+ - Kw/p_h**2 - 1._wp/aphscale
+ENDIF
+RETURN
+END FUNCTION equation_at
+
+!===============================================================================
+
+SUBROUTINE ahini_for_at(p_alkcb, p_dictot, p_bortot, K1, K2, Kb, p_hini)
+
+! Subroutine returns the root for the 2nd order approximation of the
+! DIC -- B_T -- A_CB equation for [H+] (reformulated as a cubic polynomial)
+! around the local minimum, if it exists.
+
+! Returns * 1E-03_wp if p_alkcb <= 0
+! * 1E-10_wp if p_alkcb >= 2*p_dictot + p_bortot
+! * 1E-07_wp if 0 < p_alkcb < 2*p_dictot + p_bortot
+! and the 2nd order approximation does not have a solution
+
+!USE MOD_CHEMCONST, ONLY : api1_dic, api2_dic, api1_bor
+
+USE mocsy_singledouble
+IMPLICIT NONE
+
+! Argument variables
+!--------------------
+REAL(KIND=wp), INTENT(IN) :: p_alkcb, p_dictot, p_bortot
+REAL(KIND=wp), INTENT(IN) :: K1, K2, Kb
+REAL(KIND=wp), INTENT(OUT) :: p_hini
+
+! Local variables
+!-----------------
+REAL(KIND=wp) :: zca, zba
+REAL(KIND=wp) :: zd, zsqrtd, zhmin
+REAL(KIND=wp) :: za2, za1, za0
+
+IF (p_alkcb <= 0._wp) THEN
+ p_hini = 1.e-3_wp
+ELSEIF (p_alkcb >= (2._wp*p_dictot + p_bortot)) THEN
+ p_hini = 1.e-10_wp
+ELSE
+ zca = p_dictot/p_alkcb
+ zba = p_bortot/p_alkcb
+
+ ! Coefficients of the cubic polynomial
+ za2 = Kb*(1._wp - zba) + K1*(1._wp-zca)
+ za1 = K1*Kb*(1._wp - zba - zca) + K1*K2*(1._wp - (zca+zca))
+ za0 = K1*K2*Kb*(1._wp - zba - (zca+zca))
+ ! Taylor expansion around the minimum
+ zd = za2*za2 - 3._wp*za1 ! Discriminant of the quadratic equation
+ ! for the minimum close to the root
+
+ IF(zd > 0._wp) THEN ! If the discriminant is positive
+ zsqrtd = SQRT(zd)
+ IF(za2 < 0) THEN
+ zhmin = (-za2 + zsqrtd)/3._wp
+ ELSE
+ zhmin = -za1/(za2 + zsqrtd)
+ ENDIF
+ p_hini = zhmin + SQRT(-(za0 + zhmin*(za1 + zhmin*(za2 + zhmin)))/zsqrtd)
+ ELSE
+ p_hini = 1.e-7_wp
+ ENDIF
+
+ENDIF
+RETURN
+END SUBROUTINE ahini_for_at
+
+!===============================================================================
+
+FUNCTION solve_at_general(p_alktot, p_dictot, p_bortot, &
+ p_po4tot, p_siltot, &
+ p_so4tot, p_flutot, &
+ K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi, &
+ p_hini, p_val)
+
+! Universal pH solver that converges from any given initial value,
+! determines upper an lower bounds for the solution if required
+
+USE mocsy_singledouble
+IMPLICIT NONE
+REAL(KIND=wp) :: SOLVE_AT_GENERAL
+
+! Argument variables
+!--------------------
+REAL(KIND=wp), INTENT(IN) :: p_alktot
+REAL(KIND=wp), INTENT(IN) :: p_dictot
+REAL(KIND=wp), INTENT(IN) :: p_bortot
+REAL(KIND=wp), INTENT(IN) :: p_po4tot
+REAL(KIND=wp), INTENT(IN) :: p_siltot
+!REAL(KIND=wp), INTENT(IN) :: p_nh4tot
+!REAL(KIND=wp), INTENT(IN) :: p_h2stot
+REAL(KIND=wp), INTENT(IN) :: p_so4tot
+REAL(KIND=wp), INTENT(IN) :: p_flutot
+REAL(KIND=wp), INTENT(IN) :: K0, K1, K2, Kb, Kw, Ks, Kf
+REAL(KIND=wp), INTENT(IN) :: K1p, K2p, K3p, Ksi
+REAL(KIND=wp), INTENT(IN), OPTIONAL :: p_hini
+REAL(KIND=wp), INTENT(OUT), OPTIONAL :: p_val
+
+! Local variables
+!-----------------
+REAL(KIND=wp) :: zh_ini, zh, zh_prev, zh_lnfactor
+REAL(KIND=wp) :: zalknw_inf, zalknw_sup
+REAL(KIND=wp) :: zh_min, zh_max
+REAL(KIND=wp) :: zdelta, zh_delta
+REAL(KIND=wp) :: zeqn, zdeqndh, zeqn_absmin
+REAL(KIND=wp) :: aphscale
+LOGICAL :: l_exitnow
+REAL(KIND=wp), PARAMETER :: pz_exp_threshold = 1.0_wp
+
+! TOTAL H+ scale: conversion factor for Htot = aphscale * Hfree
+aphscale = 1._wp + p_so4tot/Ks
+
+IF(PRESENT(p_hini)) THEN
+ zh_ini = p_hini
+ELSE
+ CALL ahini_for_at(p_alktot, p_dictot, p_bortot, K1, K2, Kb, zh_ini)
+ENDIF
+
+ CALL anw_infsup(p_dictot, p_bortot, &
+ p_po4tot, p_siltot, &
+ p_so4tot, p_flutot, &
+ zalknw_inf, zalknw_sup)
+
+zdelta = (p_alktot-zalknw_inf)**2 + 4._wp*Kw/aphscale
+
+IF(p_alktot >= zalknw_inf) THEN
+ zh_min = 2._wp*Kw /( p_alktot-zalknw_inf + SQRT(zdelta) )
+ELSE
+ zh_min = aphscale*(-(p_alktot-zalknw_inf) + SQRT(zdelta) ) / 2._wp
+ENDIF
+
+zdelta = (p_alktot-zalknw_sup)**2 + 4._wp*Kw/aphscale
+
+IF(p_alktot <= zalknw_sup) THEN
+ zh_max = aphscale*(-(p_alktot-zalknw_sup) + SQRT(zdelta) ) / 2._wp
+ELSE
+ zh_max = 2._wp*Kw /( p_alktot-zalknw_sup + SQRT(zdelta) )
+ENDIF
+
+zh = MAX(MIN(zh_max, zh_ini), zh_min)
+niter_atgen = 0 ! Reset counters of iterations
+zeqn_absmin = HUGE(1._wp)
+
+DO
+ IF(niter_atgen >= jp_maxniter_atgen) THEN
+ zh = -1._wp
+ EXIT
+ ENDIF
+
+ zh_prev = zh
+ zeqn = equation_at(p_alktot, zh, p_dictot, p_bortot, &
+ p_po4tot, p_siltot, &
+ p_so4tot, p_flutot, &
+ K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi, &
+ P_DERIVEQN = zdeqndh)
+
+ ! Adapt bracketing interval
+ IF(zeqn > 0._wp) THEN
+ zh_min = zh_prev
+ ELSEIF(zeqn < 0._wp) THEN
+ zh_max = zh_prev
+ ELSE
+ ! zh is the root; unlikely but, one never knows
+ EXIT
+ ENDIF
+
+ ! Now determine the next iterate zh
+ niter_atgen = niter_atgen + 1
+
+ IF(ABS(zeqn) >= 0.5_wp*zeqn_absmin) THEN
+ ! if the function evaluation at the current point is
+ ! not decreasing faster than with a bisection step (at least linearly)
+ ! in absolute value take one bisection step on [ph_min, ph_max]
+ ! ph_new = (ph_min + ph_max)/2d0
+ !
+ ! In terms of [H]_new:
+ ! [H]_new = 10**(-ph_new)
+ ! = 10**(-(ph_min + ph_max)/2d0)
+ ! = SQRT(10**(-(ph_min + phmax)))
+ ! = SQRT(zh_max * zh_min)
+ zh = SQRT(zh_max * zh_min)
+ zh_lnfactor = (zh - zh_prev)/zh_prev ! Required to test convergence below
+ ELSE
+ ! dzeqn/dpH = dzeqn/d[H] * d[H]/dpH
+ ! = -zdeqndh * LOG(10) * [H]
+ ! \Delta pH = -zeqn/(zdeqndh*d[H]/dpH) = zeqn/(zdeqndh*[H]*LOG(10))
+ !
+ ! pH_new = pH_old + \deltapH
+ !
+ ! [H]_new = 10**(-pH_new)
+ ! = 10**(-pH_old - \Delta pH)
+ ! = [H]_old * 10**(-zeqn/(zdeqndh*[H]_old*LOG(10)))
+ ! = [H]_old * EXP(-LOG(10)*zeqn/(zdeqndh*[H]_old*LOG(10)))
+ ! = [H]_old * EXP(-zeqn/(zdeqndh*[H]_old))
+
+ zh_lnfactor = -zeqn/(zdeqndh*zh_prev)
+
+ IF(ABS(zh_lnfactor) > pz_exp_threshold) THEN
+ zh = zh_prev*EXP(zh_lnfactor)
+ ELSE
+ zh_delta = zh_lnfactor*zh_prev
+ zh = zh_prev + zh_delta
+ ENDIF
+
+ IF( zh < zh_min ) THEN
+ ! if [H]_new < [H]_min
+ ! i.e., if ph_new > ph_max then
+ ! take one bisection step on [ph_prev, ph_max]
+ ! ph_new = (ph_prev + ph_max)/2d0
+ ! In terms of [H]_new:
+ ! [H]_new = 10**(-ph_new)
+ ! = 10**(-(ph_prev + ph_max)/2d0)
+ ! = SQRT(10**(-(ph_prev + phmax)))
+ ! = SQRT([H]_old*10**(-ph_max))
+ ! = SQRT([H]_old * zh_min)
+ zh = SQRT(zh_prev * zh_min)
+ zh_lnfactor = (zh - zh_prev)/zh_prev ! Required to test convergence below
+ ENDIF
+
+ IF( zh > zh_max ) THEN
+ ! if [H]_new > [H]_max
+ ! i.e., if ph_new < ph_min, then
+ ! take one bisection step on [ph_min, ph_prev]
+ ! ph_new = (ph_prev + ph_min)/2d0
+ ! In terms of [H]_new:
+ ! [H]_new = 10**(-ph_new)
+ ! = 10**(-(ph_prev + ph_min)/2d0)
+ ! = SQRT(10**(-(ph_prev + ph_min)))
+ ! = SQRT([H]_old*10**(-ph_min))
+ ! = SQRT([H]_old * zhmax)
+ zh = SQRT(zh_prev * zh_max)
+ zh_lnfactor = (zh - zh_prev)/zh_prev ! Required to test convergence below
+ ENDIF
+ ENDIF
+
+ zeqn_absmin = MIN( ABS(zeqn), zeqn_absmin)
+
+ ! Stop iterations once |\delta{[H]}/[H]| < rdel
+ ! <=> |(zh - zh_prev)/zh_prev| = |EXP(-zeqn/(zdeqndh*zh_prev)) -1| < rdel
+ ! |EXP(-zeqn/(zdeqndh*zh_prev)) -1| ~ |zeqn/(zdeqndh*zh_prev)|
+
+ ! Alternatively:
+ ! |\Delta pH| = |zeqn/(zdeqndh*zh_prev*LOG(10))|
+ ! ~ 1/LOG(10) * |\Delta [H]|/[H]
+ ! < 1/LOG(10) * rdel
+
+ ! Hence |zeqn/(zdeqndh*zh)| < rdel
+
+ ! rdel <-- pp_rdel_ah_target
+
+ l_exitnow = (ABS(zh_lnfactor) < pp_rdel_ah_target)
+
+ IF(l_exitnow) EXIT
+ENDDO
+
+solve_at_general = zh
+
+IF(PRESENT(p_val)) THEN
+ IF(zh > 0._wp) THEN
+ p_val = equation_at(p_alktot, zh, p_dictot, p_bortot, &
+ p_po4tot, p_siltot, &
+ p_so4tot, p_flutot, &
+ K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi)
+ ELSE
+ p_val = HUGE(1._wp)
+ ENDIF
+ENDIF
+RETURN
+END FUNCTION solve_at_general
+
+!===============================================================================
+
+FUNCTION solve_at_general_sec(p_alktot, p_dictot, p_bortot, &
+ p_po4tot, p_siltot, &
+ p_so4tot, p_flutot, &
+ K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi, &
+ p_hini, p_val)
+
+! Universal pH solver that converges from any given initial value,
+! determines upper an lower bounds for the solution if required
+
+!USE MOD_CHEMCONST, ONLY: api1_wat, aphscale
+USE mocsy_singledouble
+IMPLICIT NONE
+REAL(KIND=wp) :: SOLVE_AT_GENERAL_SEC
+
+! Argument variables
+REAL(KIND=wp), INTENT(IN) :: p_alktot
+REAL(KIND=wp), INTENT(IN) :: p_dictot
+REAL(KIND=wp), INTENT(IN) :: p_bortot
+REAL(KIND=wp), INTENT(IN) :: p_po4tot
+REAL(KIND=wp), INTENT(IN) :: p_siltot
+!REAL(KIND=wp), INTENT(IN) :: p_nh4tot
+!REAL(KIND=wp), INTENT(IN) :: p_h2stot
+REAL(KIND=wp), INTENT(IN) :: p_so4tot
+REAL(KIND=wp), INTENT(IN) :: p_flutot
+REAL(KIND=wp), INTENT(IN) :: K0, K1, K2, Kb, Kw, Ks, Kf
+REAL(KIND=wp), INTENT(IN) :: K1p, K2p, K3p, Ksi
+REAL(KIND=wp), INTENT(IN), OPTIONAL :: p_hini
+REAL(KIND=wp), INTENT(OUT), OPTIONAL :: p_val
+
+! Local variables
+REAL(KIND=wp) :: zh_ini, zh, zh_1, zh_2, zh_delta
+REAL(KIND=wp) :: zalknw_inf, zalknw_sup
+REAL(KIND=wp) :: zh_min, zh_max
+REAL(KIND=wp) :: zeqn, zeqn_1, zeqn_2, zeqn_absmin
+REAL(KIND=wp) :: zdelta
+REAL(KIND=wp) :: aphscale
+LOGICAL :: l_exitnow
+
+! TOTAL H+ scale: conversion factor for Htot = aphscale * Hfree
+aphscale = 1._wp + p_so4tot/Ks
+
+IF(PRESENT(p_hini)) THEN
+ zh_ini = p_hini
+ELSE
+ CALL ahini_for_at(p_alktot, p_dictot, p_bortot, K1, K2, Kb, zh_ini)
+ENDIF
+
+ CALL anw_infsup(p_dictot, p_bortot, &
+ p_po4tot, p_siltot, &
+ p_so4tot, p_flutot, &
+ zalknw_inf, zalknw_sup)
+
+zdelta = (p_alktot-zalknw_inf)**2 + 4._wp*Kw/aphscale
+
+IF(p_alktot >= zalknw_inf) THEN
+ zh_min = 2._wp*Kw /( p_alktot-zalknw_inf + SQRT(zdelta) )
+ELSE
+ zh_min = aphscale*(-(p_alktot-zalknw_inf) + SQRT(zdelta) ) / 2._wp
+ENDIF
+
+zdelta = (p_alktot-zalknw_sup)**2 + 4._wp*Kw/aphscale
+
+IF(p_alktot <= zalknw_sup) THEN
+ zh_max = aphscale*(-(p_alktot-zalknw_sup) + SQRT(zdelta) ) / 2._wp
+ELSE
+ zh_max = 2._wp*Kw /( p_alktot-zalknw_sup + SQRT(zdelta) )
+ENDIF
+
+zh = MAX(MIN(zh_max, zh_ini), zh_min)
+niter_atsec = 0 ! Reset counters of iterations
+
+! Prepare the secant iterations: two initial (zh, zeqn) pairs are required
+! We have the starting value, that needs to be completed by the evaluation
+! of the equation value it produces.
+
+! Complete the initial value with its equation evaluation
+! (will take the role of the $n-2$ iterate at the first secant evaluation)
+
+niter_atsec = 0 ! zh_2 is the initial value;
+
+zh_2 = zh
+zeqn_2 = equation_at(p_alktot, zh_2, p_dictot, p_bortot, &
+ p_po4tot, p_siltot, &
+ p_so4tot, p_flutot, &
+ K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi)
+
+zeqn_absmin = ABS(zeqn_2)
+
+! Adapt bracketing interval and heuristically set zh_1
+IF(zeqn_2 < 0._wp) THEN
+ ! If zeqn_2 < 0, then we adjust zh_max:
+ ! we can be sure that zh_min < zh_2 < zh_max.
+ zh_max = zh_2
+ ! for zh_1, try 25% (0.1 pH units) below the current zh_max,
+ ! but stay above SQRT(zh_min*zh_max), which would be equivalent
+ ! to a bisection step on [pH@zh_min, pH@zh_max]
+ zh_1 = MAX(zh_max/1.25_wp, SQRT(zh_min*zh_max))
+ELSEIF(zeqn_2 > 0._wp) THEN
+ ! If zeqn_2 < 0, then we adjust zh_min:
+ ! we can be sure that zh_min < zh_2 < zh_max.
+ zh_min = zh_2
+ ! for zh_1, try 25% (0.1 pH units) above the current zh_min,
+ ! but stay below SQRT(zh_min*zh_max) which would be equivalent
+ ! to a bisection step on [pH@zh_min, pH@zh_max]
+ zh_1 = MIN(zh_min*1.25_wp, SQRT(zh_min*zh_max))
+ELSE ! we have got the root; unlikely, but one never knows
+ solve_at_general_sec = zh_2
+ IF(PRESENT(p_val)) p_val = zeqn_2
+ RETURN
+ENDIF
+
+! We now have the first pair completed (zh_2, zeqn_2).
+! Define the second one (zh_1, zeqn_1), which is also the first iterate.
+! zh_1 has already been set above
+niter_atsec = 1 ! Update counter of iterations
+
+zeqn_1 = equation_at(p_alktot, zh_1, p_dictot, p_bortot, &
+ p_po4tot, p_siltot, &
+ p_so4tot, p_flutot, &
+ K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi)
+
+! Adapt bracketing interval: we know that zh_1 <= zh <= zh_max (if zeqn_1 > 0)
+! or zh_min <= zh <= zh_1 (if zeqn_1 < 0), so this can always be done
+IF(zeqn_1 > 0._wp) THEN
+ zh_min = zh_1
+ELSEIF(zeqn_1 < 0._wp) THEN
+ zh_max = zh_1
+ELSE ! zh_1 is the root
+ solve_at_general_sec = zh_1
+ IF(PRESENT(p_val)) p_val = zeqn_1
+ENDIF
+
+IF(ABS(zeqn_1) > zeqn_absmin) THEN ! Swap zh_2 and zh_1 if ABS(zeqn_2) < ABS(zeqn_1)
+ ! so that zh_2 and zh_1 lead to decreasing equation
+ ! values (in absolute value)
+ zh = zh_1
+ zeqn = zeqn_1
+ zh_1 = zh_2
+ zeqn_1 = zeqn_2
+ zh_2 = zh
+ zeqn_2 = zeqn
+ELSE
+ zeqn_absmin = ABS(zeqn_1)
+ENDIF
+
+! Pre-calculate the first secant iterate (this is the second iterate)
+niter_atsec = 2
+
+zh_delta = -zeqn_1/((zeqn_2-zeqn_1)/(zh_2 - zh_1))
+zh = zh_1 + zh_delta
+
+! Make sure that zh_min < zh < zh_max (if not,
+! bisect around zh_1 which is the best estimate)
+IF (zh > zh_max) THEN ! this can only happen if zh_2 < zh_1
+ ! and zeqn_2 > zeqn_1 > 0
+ zh = SQRT(zh_1*zh_max)
+ENDIF
+
+IF (zh < zh_min) THEN ! this can only happen if zh_2 > zh_1
+ ! and zeqn_2 < zeqn_1 < 0
+ zh = SQRT(zh_1*zh_min)
+ENDIF
+
+DO
+ IF(niter_atsec >= jp_maxniter_atsec) THEN
+ zh = -1._wp
+ EXIT
+ ENDIF
+
+ zeqn = equation_at(p_alktot, zh, p_dictot, p_bortot, &
+ p_po4tot, p_siltot, &
+ p_so4tot, p_flutot, &
+ K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi)
+
+ ! Adapt bracketing interval: since initially, zh_min <= zh <= zh_max
+ ! we are sure that zh will improve either bracket, depending on the sign
+ ! of zeqn
+ IF(zeqn > 0._wp) THEN
+ zh_min = zh
+ ELSEIF(zeqn < 0._wp) THEN
+ zh_max = zh
+ ELSE
+ ! zh is the root
+ EXIT
+ ENDIF
+
+ ! start calculation of next iterate
+ niter_atsec = niter_atsec + 1
+
+ zh_2 = zh_1
+ zeqn_2 = zeqn_1
+ zh_1 = zh
+ zeqn_1 = zeqn
+
+ IF(ABS(zeqn) >= 0.5_wp*zeqn_absmin) THEN
+ ! if the function evaluation at the current point
+ ! is not decreasing faster in absolute value than
+ ! we may expect for a bisection step, then take
+ ! one bisection step on [ph_min, ph_max]
+ ! ph_new = (ph_min + ph_max)/2d0
+ ! In terms of [H]_new:
+ ! [H]_new = 10**(-ph_new)
+ ! = 10**(-(ph_min + ph_max)/2d0)
+ ! = SQRT(10**(-(ph_min + phmax)))
+ ! = SQRT(zh_max * zh_min)
+ zh = SQRT(zh_max * zh_min)
+ zh_delta = zh - zh_1
+ ELSE
+ ! \Delta H = -zeqn_1*(h_2 - h_1)/(zeqn_2 - zeqn_1)
+ ! H_new = H_1 + \Delta H
+ zh_delta = -zeqn_1/((zeqn_2-zeqn_1)/(zh_2 - zh_1))
+ zh = zh_1 + zh_delta
+
+ IF( zh < zh_min ) THEN
+ ! if [H]_new < [H]_min
+ ! i.e., if ph_new > ph_max then
+ ! take one bisection step on [ph_prev, ph_max]
+ ! ph_new = (ph_prev + ph_max)/2d0
+ ! In terms of [H]_new:
+ ! [H]_new = 10**(-ph_new)
+ ! = 10**(-(ph_prev + ph_max)/2d0)
+ ! = SQRT(10**(-(ph_prev + phmax)))
+ ! = SQRT([H]_old*10**(-ph_max))
+ ! = SQRT([H]_old * zh_min)
+ zh = SQRT(zh_1 * zh_min)
+ zh_delta = zh - zh_1
+ ENDIF
+
+ IF( zh > zh_max ) THEN
+ ! if [H]_new > [H]_max
+ ! i.e., if ph_new < ph_min, then
+ ! take one bisection step on [ph_min, ph_prev]
+ ! ph_new = (ph_prev + ph_min)/2d0
+ ! In terms of [H]_new:
+ ! [H]_new = 10**(-ph_new)
+ ! = 10**(-(ph_prev + ph_min)/2d0)
+ ! = SQRT(10**(-(ph_prev + ph_min)))
+ ! = SQRT([H]_old*10**(-ph_min))
+ ! = SQRT([H]_old * zhmax)
+ zh = SQRT(zh_1 * zh_max)
+ zh_delta = zh - zh_1
+ ENDIF
+ ENDIF
+
+ zeqn_absmin = MIN(ABS(zeqn), zeqn_absmin)
+
+ ! Stop iterations once |([H]-[H_1])/[H_1]| < rdel
+ l_exitnow = (ABS(zh_delta) < pp_rdel_ah_target*zh_1)
+
+ IF(l_exitnow) EXIT
+ENDDO
+
+SOLVE_AT_GENERAL_SEC = zh
+
+IF(PRESENT(p_val)) THEN
+ IF(zh > 0._wp) THEN
+ p_val = equation_at(p_alktot, zh, p_dictot, p_bortot, &
+ p_po4tot, p_siltot, &
+ p_so4tot, p_flutot, &
+ K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi)
+ ELSE
+ p_val = HUGE(1._wp)
+ ENDIF
+ENDIF
+
+RETURN
+END FUNCTION SOLVE_AT_GENERAL_SEC
+
+!===============================================================================
+
+FUNCTION SOLVE_AT_FAST(p_alktot, p_dictot, p_bortot, &
+ p_po4tot, p_siltot, &
+ p_so4tot, p_flutot, &
+ K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi, &
+ p_hini, p_val)
+
+! Fast version of SOLVE_AT_GENERAL, without any bounds checking.
+
+USE mocsy_singledouble
+IMPLICIT NONE
+REAL(KIND=wp) :: SOLVE_AT_FAST
+
+! Argument variables
+REAL(KIND=wp), INTENT(IN) :: p_alktot
+REAL(KIND=wp), INTENT(IN) :: p_dictot
+REAL(KIND=wp), INTENT(IN) :: p_bortot
+REAL(KIND=wp), INTENT(IN) :: p_po4tot
+REAL(KIND=wp), INTENT(IN) :: p_siltot
+!REAL(KIND=wp), INTENT(IN) :: p_nh4tot
+!REAL(KIND=wp), INTENT(IN) :: p_h2stot
+REAL(KIND=wp), INTENT(IN) :: p_so4tot
+REAL(KIND=wp), INTENT(IN) :: p_flutot
+REAL(KIND=wp), INTENT(IN) :: K0, K1, K2, Kb, Kw, Ks, Kf
+REAL(KIND=wp), INTENT(IN) :: K1p, K2p, K3p, Ksi
+REAL(KIND=wp), INTENT(IN), OPTIONAL :: p_hini
+REAL(KIND=wp), INTENT(OUT), OPTIONAL :: p_val
+
+! Local variables
+REAL(KIND=wp) :: zh_ini, zh, zh_prev, zh_lnfactor
+REAL(KIND=wp) :: zhdelta
+REAL(KIND=wp) :: zeqn, zdeqndh
+!REAL(KIND=wp) :: aphscale
+LOGICAL :: l_exitnow
+REAL(KIND=wp), PARAMETER :: pz_exp_threshold = 1.0_wp
+
+! TOTAL H+ scale: conversion factor for Htot = aphscale * Hfree
+!aphscale = 1._wp + p_so4tot/Ks
+
+IF(PRESENT(p_hini)) THEN
+ zh_ini = p_hini
+ELSE
+ CALL AHINI_FOR_AT(p_alktot, p_dictot, p_bortot, K1, K2, Kb, zh_ini)
+ENDIF
+zh = zh_ini
+
+niter_atfast = 0 ! Reset counters of iterations
+DO
+ niter_atfast = niter_atfast + 1
+ IF(niter_atfast > jp_maxniter_atfast) THEN
+ zh = -1._wp
+ EXIT
+ ENDIF
+
+ zh_prev = zh
+
+ zeqn = equation_at(p_alktot, zh, p_dictot, p_bortot, &
+ p_po4tot, p_siltot, &
+ p_so4tot, p_flutot, &
+ K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi, &
+ P_DERIVEQN = zdeqndh)
+
+ IF(zeqn == 0._wp) EXIT ! zh is the root
+
+ zh_lnfactor = -zeqn/(zdeqndh*zh_prev)
+ IF(ABS(zh_lnfactor) > pz_exp_threshold) THEN
+ zh = zh_prev*EXP(zh_lnfactor)
+ ELSE
+ zhdelta = zh_lnfactor*zh_prev
+ zh = zh_prev + zhdelta
+ ENDIF
+
+ ! Stop iterations once |\delta{[H]}/[H]| < rdel
+ ! <=> |(zh - zh_prev)/zh_prev| = |EXP(-zeqn/(zdeqndh*zh_prev)) -1| < rdel
+ ! |EXP(-zeqn/(zdeqndh*zh_prev)) -1| ~ |zeqn/(zdeqndh*zh_prev)|
+
+ ! Alternatively:
+ ! |\Delta pH| = |zeqn/(zdeqndh*zh_prev*LOG(10))|
+ ! ~ 1/LOG(10) * |\Delta [H]|/[H]
+ ! < 1/LOG(10) * rdel
+
+ ! Hence |zeqn/(zdeqndh*zh)| < rdel
+
+ ! rdel <- pp_rdel_ah_target
+
+ l_exitnow = (ABS(zh_lnfactor) < pp_rdel_ah_target)
+
+ IF(l_exitnow) EXIT
+ENDDO
+
+SOLVE_AT_FAST = zh
+
+IF(PRESENT(p_val)) THEN
+ IF(zh > 0._wp) THEN
+ p_val = equation_at(p_alktot, zh, p_dictot, p_bortot, &
+ p_po4tot, p_siltot, &
+ p_so4tot, p_flutot, &
+ K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi)
+ ELSE
+ p_val = HUGE(1._wp)
+ ENDIF
+ENDIF
+
+RETURN
+END FUNCTION solve_at_fast
+!===============================================================================
+
+END MODULE mocsy_phsolvers
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/mocsy_singledouble.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/mocsy_singledouble.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/mocsy_singledouble.F90 (revision 8155)
@@ -0,0 +1,11 @@
+!> \file mocsy_singledouble.f90
+!! \BRIEF
+!> Module that defines single and double precision - used by all other modules
+MODULE mocsy_singledouble
+! INTEGER, PARAMETER :: r4 = SELECTED_REAL_KIND(6)
+! INTEGER, PARAMETER :: r8 = SELECTED_REAL_KIND(12)
+ INTEGER, PARAMETER :: r4 = KIND(1.0)
+ INTEGER, PARAMETER :: r8 = KIND(1.0d0)
+! INTEGER, PARAMETER :: wp = KIND(1.0d0)
+ INTEGER, PARAMETER :: wp = SELECTED_REAL_KIND(12,307)
+END MODULE mocsy_singledouble
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/mocsy_wrapper.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/mocsy_wrapper.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/mocsy_wrapper.F90 (revision 8155)
@@ -0,0 +1,357 @@
+MODULE mocsy_wrapper
+ !!======================================================================
+ !! *** MODULE mocsy_wrapper ***
+ !! TOP : MEDUSA
+ !!======================================================================
+ !! History :
+ !! - ! 2015-06 (A. Yool) added for UKESM project
+ !! - ! 2017-04 (A. Yool) alter optK1K2 to 'w14' option
+ !!----------------------------------------------------------------------
+#if defined key_medusa && defined key_roam
+ !!----------------------------------------------------------------------
+ !! MEDUSA carbonate chemistry
+ !!----------------------------------------------------------------------
+ !! mocsy_wrapper
+ !!----------------------------------------------------------------------
+
+ USE mocsy_mainmod
+ USE mocsy_gasflux
+ USE in_out_manager ! I/O manager
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC mocsy_interface ! called in trc_bio_medusa
+ PUBLIC mocsy_carbchem ! called in trc_bio_medusa
+
+ !!* Substitution
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+! The following is a map of the subroutines contained within this module
+! - mocsy_interface
+! - CALLS mocsy_carbchem
+!
+! - mocsy_carbchem
+! - CALLS vars
+! - CALLS p80
+! - CALLS constants
+! - CALLS rho
+! - CALLS varsolver
+! - CALLS [phsolvers routines]
+! - CALLS varsolver (again)
+! - CALLS x2pCO2atm
+! - CALLS p2fCO2
+! - CALLS schmidt_co2
+! - CALLS surface_K0
+
+CONTAINS
+
+!=======================================================================
+!
+ SUBROUTINE mocsy_interface( temp, sal, alk, dic, sil, phos, &
+ Patm, depth, lat, kw660, xco2, N, &
+ ph, pco2, fco2, co2, hco3, co3, OmegaA, &
+ OmegaC, BetaD, rhoSW, p, tempis, &
+ pco2atm, fco2atm, schmidtco2, kwco2, K0, &
+ co2starair, co2flux, dpco2 )
+!
+!=======================================================================
+!
+! AXY (26/06/15): to preserve both MEDUSA's scalar variables and
+! MOCSY's vector variables on code traceability
+! grounds, this additional wrapper does a rather
+! superfluous conversion between the two; in the
+! fullness of time, this should be dispensed with
+! and MOCSY used in its full vector form
+!
+ USE mocsy_singledouble
+ IMPLICIT NONE
+
+!> ======================================================================
+! VARIABLES
+!> ======================================================================
+!
+ INTEGER, INTENT(in) :: N
+!
+! MEDUSA-side
+! Input variables
+ REAL(kind=wp), INTENT(in) :: temp, sal, alk, dic, sil, phos
+ REAL(kind=wp), INTENT(in) :: Patm, depth, lat, kw660, xco2
+!
+! Output variables
+ REAL(kind=wp), INTENT(out) :: ph, pco2, fco2, co2, hco3, co3, OmegaA
+ REAL(kind=wp), INTENT(out) :: OmegaC, BetaD, rhoSW, p, tempis
+ REAL(kind=wp), INTENT(out) :: pco2atm, fco2atm, schmidtco2, kwco2, K0
+ REAL(kind=wp), INTENT(out) :: co2starair, co2flux, dpco2
+!
+! MOCSY-side
+! Input variables
+ REAL(kind=wp), DIMENSION(N) :: mtemp, msal, malk, mdic, msil, mphos
+ REAL(kind=wp), DIMENSION(N) :: mPatm, mdepth, mlat, mkw660, mxco2
+!
+! Output variables
+ REAL(kind=wp), DIMENSION(N) :: mph, mpco2, mfco2, mco2, mhco3, mco3, mOmegaA
+ REAL(kind=wp), DIMENSION(N) :: mOmegaC, mBetaD, mrhoSW, mp, mtempis
+ REAL(kind=wp), DIMENSION(N) :: mpco2atm, mfco2atm, mschmidtco2, mkwco2, mK0
+ REAL(kind=wp), DIMENSION(N) :: mco2starair, mco2flux, mdpco2
+!
+!> ----------------------------------------------------------------------
+! Set MOCSY inputs to equal MEDUSA inputs (amend units here)
+!> ----------------------------------------------------------------------
+!
+ mtemp(1) = temp ! degrees C
+ msal(1) = sal ! PSU
+ malk(1) = alk / 1000. ! meq / m3 -> eq / m3
+ mdic(1) = dic / 1000. ! mmol / m3 -> mol / m3
+ msil(1) = sil / 1000. ! mmol / m3 -> mol / m3
+ mphos(1) = phos / 1000. ! mmol / m3 -> mol / m3
+ mPatm(1) = Patm ! atm
+ mdepth(1) = depth ! m
+ mlat(1) = lat ! degrees N
+ mkw660(1) = kw660 ! m / s
+ mxco2(1) = xco2 ! ppm
+!
+!> ----------------------------------------------------------------------
+! Call MOCSY
+!> ----------------------------------------------------------------------
+!
+ CALL mocsy_carbchem( mtemp, msal, malk, mdic, msil, mphos, & ! inputs
+ mPatm, mdepth, mlat, mkw660, mxco2, 1, & ! inputs
+ mph, mpco2, mfco2, mco2, mhco3, mco3, mOmegaA, & ! outputs
+ mOmegaC, mBetaD, mrhoSW, mp, mtempis, & ! outputs
+ mpco2atm, mfco2atm, mschmidtco2, mkwco2, mK0, & ! outputs
+ mco2starair, mco2flux, mdpco2 ) ! outputs
+!
+!> ----------------------------------------------------------------------
+! Set MOCSY outputs to equal MEDUSA outputs (amend units here)
+!> ----------------------------------------------------------------------
+!
+ ph = mph(1) ! standard units
+ pco2 = mpco2(1) ! uatm
+ fco2 = mfco2(1) ! uatm
+ co2 = mco2(1) * 1000. ! mol / m3 -> mmol / m3
+ hco3 = mhco3(1) * 1000. ! mol / m3 -> mmol / m3
+ co3 = mco3(1) * 1000. ! mol / m3 -> mmol / m3
+ OmegaA = mOmegaA(1) ! dimensionless
+ OmegaC = mOmegaC(1) ! dimensionless
+ BetaD = mBetaD(1) ! dimensionless
+ rhoSW = mrhoSW(1) ! kg / m3
+ p = mp(1) ! db
+ tempis = mtempis(1) ! degrees C
+ pco2atm = mpco2atm(1) ! uatm
+ fco2atm = mfco2atm(1) ! uatm
+ schmidtco2 = mschmidtco2(1) ! dimensionless
+ kwco2 = mkwco2(1) ! m / s
+ K0 = mK0(1) ! (mol/kg) / atm
+ co2starair = mco2starair(1) * 1000. ! mol / m3 -> mmol / m3
+ co2flux = mco2flux(1) * 1000. ! mol / m2 / s -> mmol / m2 / s
+ dpco2 = mdpco2(1) ! uatm
+
+ RETURN
+
+ END SUBROUTINE
+
+!-----------------------------------------------------------------------
+
+!=======================================================================
+!
+ SUBROUTINE mocsy_carbchem( temp, sal, alk, dic, sil, phos, &
+ Patm, depth, lat, kw660, xco2, N, &
+ ph, pco2, fco2, co2, hco3, co3, OmegaA, &
+ OmegaC, BetaD, rhoSW, p, tempis, &
+ pco2atm, fco2atm, schmidtco2, kwco2, K0, &
+ co2starair, co2flux, dpco2 )
+!
+!=======================================================================
+!
+! AXY (23/06/15): MOCSY introduced to MEDUSA to update carbonate
+! chemistry for UKESM1 project
+!
+! Orr, J. C. and Epitalon, J.-M.: Improved routines to model the
+! ocean carbonate system: mocsy 2.0, Geosci. Model Dev., 8, 485-499,
+! doi:10.5194/gmd-8-485-2015, 2015.
+!
+! "mocsy is a Fortran 95 package designed to compute all ocean
+! carbonate system variables from DIC and total Alk, particularly
+! from models. It updates previous OCMIP code, avoids 3 common
+! model approximations, and offers the best-practice constants as
+! well as more recent options. Its results agree with those from
+! CO2SYS-MATLAB within 0.005%."
+!
+! Where possible the code remains identical to that published by
+! Orr & Epitalon (2015; henceforth OE15); some consolidation of
+! MOCSY files has taken place, and the resulting package is
+! comprised of four modules:
+!
+! 1. mocsy_wrapped.f90
+! - This module contains the interface between MEDUSA and the
+! main MOCSY routines; it draws from (but is very different
+! from) the test_mocsy.f90 routine provided by OE15
+!
+! 2. mocsy_singledouble.f90
+! - This module contains only precision definitions; it is
+! based on the singledouble.f90 routine provided by OE15
+!
+! 3. mocsy_phsolvers.f90
+! - This module contains a suite of solvers derived from
+! Munhoven (2013) and modified by OE15; it is based on the
+! phsolver.f90 routine provided by OE15
+!
+! 4. mocsy_gasflux.f90
+! - This module contains a series of subroutines used to
+! calculate the air-sea flux of CO2; it consolidates four
+! MOCSY routines with an OCMIP-2 Schmidt number routine
+! updated with the new parameterisations of Wanninkhof (2014)
+!
+! 5. mocsy_mainmod.f90
+! - This module consolidates all of the remaining MOCSY
+! functions and subroutines from OE15 into a single file
+! for convenience
+!
+! NOTE: it is still possible to run PML's carbonate chemistry
+! routine in MEDUSA; at present this remains the default, if
+! less-preferred, routine (i.e. is used if key_mocsy is not
+! present)
+!
+!=======================================================================
+!
+! AXY (05/04/17): alter options to include optK1K2 = 'w14'
+!
+! In conversation with Jim Orr, Waters (2014) is now the
+! preferred option for optK1K2 in the case of global scale
+! simulations since this formulation works over broader ranges
+! of temperature (0 < T < 50) and salinity (1 < S < 50).
+!
+! NOTE: *contrary* to the notice above, MEDUSA has now been
+! revised to remove the PML carbonate chemistry routine as part
+! of a wider code review. This routine is not anticipated to be
+! used again, and has several out of date parameterisations
+! relative to MOCSY. As a result, key_mocsy is no longer required.
+!
+ USE mocsy_singledouble
+ IMPLICIT NONE
+
+!> ======================================================================
+! VARIABLES
+!> ======================================================================
+!
+! Input variables
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: temp, sal, alk, dic, sil, phos
+ REAL(kind=wp), INTENT(in), DIMENSION(N) :: Patm, depth, lat, kw660, xco2
+ INTEGER, INTENT(in) :: N
+!
+! Output variables
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: ph, pco2, fco2, co2, hco3, co3, OmegaA
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: OmegaC, BetaD, rhoSW, p, tempis
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: pco2atm, fco2atm, schmidtco2, kwco2, K0
+ REAL(kind=wp), INTENT(out), DIMENSION(N) :: co2starair, co2flux, dpco2
+!
+! Local variables
+ REAL(kind=wp), DIMENSION(N) :: depth0, co2star
+ INTEGER :: i, totdat
+!
+! "vars" Input options
+ CHARACTER(10) :: optCON, optT, optP, optB, optKf, optK1K2
+!
+! initialise depth0 to 0
+ depth0 = 0.0
+
+!> ======================================================================
+! CONFIGURE OPTIONS
+!> ======================================================================
+!> OPTIONS: see complete documentation in 'vars' subroutine (in mocsy_mainmod.F90)
+!> AXY (05/04/17): optK1K2 switched from 'm10' to 'w14'
+!> Typical options for MODELS
+ optCON = 'mol/m3' ! input concentrations are in MOL/M3
+ optT = 'Tpot' ! input temperature, variable 'temp', is POTENTIAL temp [°C]
+ optP = 'm' ! input variable 'depth' is in METERS
+ optB = 'l10' ! Lee et al. (2010) formulation for total boron
+ optK1K2 = 'w14' ! Lueker et al. (2000) formulations for K1 & K2 (best practices)
+ optKf = 'dg' ! Dickson & Riley (1979) formulation for Kf (recommended by Dickson & Goyet, 1994)
+!> optK1K2 = 'l' ! Lueker et al. (2000) formulations for K1 & K2 (best practices)
+!> optKf = 'dg' ! Dickson & Riley (1979) formulation for Kf (recommended by Dickson & Goyet, 1994)
+
+!> ======================================================================
+! CARBONATE CHEMISTRY CALCULATIONS
+!> ======================================================================
+!> Call mocsy's main subroutine to compute carbonate system variables:
+!> pH, pCO2, fCO2, CO2*, HCO3- and CO32-, OmegaA, OmegaC, R
+!> FROM temperature, salinity, total alkalinity, dissolved inorganic
+!> carbon, silica, phosphate, depth (or pressure) (1-D arrays)
+ call vars(ph, pco2, fco2, co2, hco3, co3, OmegaA, OmegaC, BetaD, rhoSW, p, tempis, & ! OUTPUT
+ temp, sal, alk, dic, sil, phos, Patm, depth, lat, N, & ! INPUT
+ optCON, optT, optP)
+! optCON, optT, optP, optB, optK1K2, optKf) ! INPUT OPTIONS
+
+!> ======================================================================
+! GAS EXCHANGE CALCULATIONS
+!> ======================================================================
+!>
+!> Only calculate gas exchange fields if depth = 0
+ if (depth(1) .eq. 0.0) then
+!
+! Compute pCO2atm [uatm] from xCO2 [ppm], atmospheric pressure [atm], & vapor pressure of seawater
+! pCO2atm = (Patm - pH20(i)) * xCO2, where pH20 is the vapor pressure of seawater [atm]
+ CALL x2pCO2atm(xco2, temp, sal, Patm, N, & ! INPUT
+ pco2atm) ! OUTPUT
+
+! Compute fCO2atm [uatm] from pCO2atm [uatm] & fugacity coefficient [unitless]
+! fCO2atm = pCO2atm * fugcoeff, where fugcoeff= exp(Patm*(B + 2.0*xc2*Del)/(R*tk) )
+ CALL p2fCO2(pco2atm, temp, Patm, depth0, N, & ! INPUT
+ fco2atm) ! OUTPUT
+
+! Compute Schmidt number for CO2 from potential temperature
+ CALL schmidt_co2(temp, N, & ! INPUT
+ schmidtco2) ! OUTPUT
+
+! Compute transfer velocity for CO2 in m/s (see equation [4] in OCMIP2 design document & OCMIP2 Abiotic HOWTO)
+ kwco2 = kw660 * (660./schmidtco2)**0.5
+
+! Surface K0 [(mol/kg) / atm] at T, S of surface water
+ CALL surface_K0(temp, sal, N, & ! INPUT
+ K0) ! OUTPUT
+
+! "Atmospheric" [CO2*], air-sea CO2 flux, sfc DIC rate of change, & Delta pCO2
+! all "lifted" from the gasx.f90 function of MOCSY
+ co2starair = K0 * fco2atm * 1.0e-6_wp * rhoSW ! Equil. [CO2*] for atm CO2 at Patm & sfc-water T,S [mol/m3]
+ co2star = co2 ! Oceanic [CO2*] in [mol/m3] from vars.f90
+ co2flux = kwco2 * (co2starair - co2star) ! Air-sea CO2 flux [mol/(m2 * s)]
+! co2ex = co2flux / dz1 ! Change in sfc DIC due to gas exchange [mol/[m3 * s)]
+ dpco2 = pco2 - pco2atm ! Delta pCO2 (oceanic - atmospheric pCO2) [uatm]
+!
+ endif
+
+ RETURN
+
+ END SUBROUTINE
+
+!-----------------------------------------------------------------------
+
+!=======================================================================
+!=======================================================================
+!=======================================================================
+
+# else
+ !!======================================================================
+ !! Dummy module : No MOCSY carbonate chemistry
+ !!======================================================================
+
+CONTAINS
+
+ SUBROUTINE mocsy_interface( kt ) ! Empty routine
+
+ INTEGER, INTENT( in ) :: kt
+
+ WRITE(*,*) 'mocsy_interface: You should not have seen this print! error?', kt
+
+ END SUBROUTINE mocsy_interface
+#endif
+
+ !!======================================================================
+
+END MODULE mocsy_wrapper
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/par_medusa.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/par_medusa.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/par_medusa.F90 (revision 8155)
@@ -0,0 +1,87 @@
+MODULE par_medusa
+ !!======================================================================
+ !! *** par_medusa ***
+ !! TOP : set the MEDUSA parameters
+ !!======================================================================
+ !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) revised architecture
+ !! - ! 2008-08 (K. Popova) adaptation for MEDUSA
+ !! - ! 2008-11 (A. Yool) continuing adaptation for MEDUSA
+ !! - ! 2010-03 (A. Yool) updated for branch inclusion
+ !! - ! 2011-04 (A. Yool) updated for ROAM project
+ !! - ! 2013-03 (A. Yool) updated for v3.5 NEMO
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+ USE par_pisces , ONLY : jp_pisces !: number of tracers in PISCES
+ USE par_pisces , ONLY : jp_pisces_2d !: number of 2D diag in PISCES
+ USE par_pisces , ONLY : jp_pisces_3d !: number of 3D diag in PISCES
+ USE par_pisces , ONLY : jp_pisces_trd !: number of biological diag in PISCES
+
+ IMPLICIT NONE
+
+ INTEGER, PARAMETER :: jp_lm = jp_pisces !:
+ INTEGER, PARAMETER :: jp_lm_2d = jp_pisces_2d !:
+ INTEGER, PARAMETER :: jp_lm_3d = jp_pisces_3d !:
+ INTEGER, PARAMETER :: jp_lm_trd = jp_pisces_trd !:
+
+#if defined key_medusa
+ !!---------------------------------------------------------------------
+ !! 'key_medusa' user defined tracers (MEDUSA)
+ !!---------------------------------------------------------------------
+ LOGICAL, PUBLIC, PARAMETER :: lk_medusa = .TRUE. !: PTS flag
+# if defined key_roam
+ INTEGER, PUBLIC, PARAMETER :: jp_medusa = 15 !: number of PTS tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_medusa_2d = 225 !: additional 2d output arrays (used if ln_diatrc=T)
+ INTEGER, PUBLIC, PARAMETER :: jp_medusa_3d = 5 !: additional 3d output arrays (used if ln_diatrc=T)
+ INTEGER, PUBLIC, PARAMETER :: jp_medusa_trd = 0 !: number of sms trends for MEDUSA
+# else
+ INTEGER, PUBLIC, PARAMETER :: jp_medusa = 11 !: number of PTS tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_medusa_2d = 90 !: additional 2d output arrays (used if ln_diatrc=T)
+ INTEGER, PUBLIC, PARAMETER :: jp_medusa_3d = 4 !: additional 3d output arrays (used if ln_diatrc=T)
+ INTEGER, PUBLIC, PARAMETER :: jp_medusa_trd = 0 !: number of sms trends for MEDUSA
+# endif
+
+ ! assign an index in trc arrays for each PTS prognostic variables
+ INTEGER, PUBLIC, PARAMETER :: jpchn = jp_lm + 1 !: non-diatom chlorophyll concentration
+ INTEGER, PUBLIC, PARAMETER :: jpchd = jp_lm + 2 !: diatom chlorophyll concentration
+ INTEGER, PUBLIC, PARAMETER :: jpphn = jp_lm + 3 !: non-diatom concentration
+ INTEGER, PUBLIC, PARAMETER :: jpphd = jp_lm + 4 !: diatom concentration
+ INTEGER, PUBLIC, PARAMETER :: jpzmi = jp_lm + 5 !: microzooplankton concentration
+ INTEGER, PUBLIC, PARAMETER :: jpzme = jp_lm + 6 !: mesozooplankton concentration
+ INTEGER, PUBLIC, PARAMETER :: jpdin = jp_lm + 7 !: dissolved inorganic nitrogen concentration
+ INTEGER, PUBLIC, PARAMETER :: jpsil = jp_lm + 8 !: silicic acid concentration
+ INTEGER, PUBLIC, PARAMETER :: jpfer = jp_lm + 9 !: total iron concentration
+ INTEGER, PUBLIC, PARAMETER :: jpdet = jp_lm + 10 !: slow-sinking detritus concentration
+ INTEGER, PUBLIC, PARAMETER :: jppds = jp_lm + 11 !: diatom silicon concentration
+# if defined key_roam
+ INTEGER, PUBLIC, PARAMETER :: jpdtc = jp_lm + 12 !: slow-sinking detritus carbon concentration
+ INTEGER, PUBLIC, PARAMETER :: jpdic = jp_lm + 13 !: dissolved inorganic carbon concentration
+ INTEGER, PUBLIC, PARAMETER :: jpalk = jp_lm + 14 !: alkalinity
+ INTEGER, PUBLIC, PARAMETER :: jpoxy = jp_lm + 15 !: dissolved oxygen concentration
+# endif
+
+#else
+ !!---------------------------------------------------------------------
+ !! Default No user defined tracers (MEDUSA)
+ !!---------------------------------------------------------------------
+ LOGICAL, PUBLIC, PARAMETER :: lk_medusa = .FALSE. !: MEDUSA flag
+ INTEGER, PUBLIC, PARAMETER :: jp_medusa = 0 !: No MEDUSA tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_medusa_2d = 0 !: No MEDUSA additional 2d output arrays
+ INTEGER, PUBLIC, PARAMETER :: jp_medusa_3d = 0 !: No MEDUSA additional 3d output arrays
+ INTEGER, PUBLIC, PARAMETER :: jp_medusa_trd = 0 !: number of sms trends for MEDUSA
+#endif
+
+ ! Starting/ending PISCES do-loop indices (N.B. no PISCES : jpl_pcs < jpf_pcs the do-loop are never done)
+ INTEGER, PUBLIC, PARAMETER :: jp_msa0 = jp_lm + 1 !: First index of MEDUSA passive tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_msa1 = jp_lm + jp_medusa !: Last index of MEDUSA passive tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_msa0_2d = jp_lm_2d + 1 !: First index of MEDUSA passive tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_msa1_2d = jp_lm_2d + jp_medusa_2d !: Last index of MEDUSA passive tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_msa0_3d = jp_lm_3d + 1 !: First index of MEDUSA passive tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_msa1_3d = jp_lm_3d + jp_medusa_3d !: Last index of MEDUSA passive tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_msa0_trd = jp_lm_trd + 1 !: First index of MEDUSA passive tracers
+ INTEGER, PUBLIC, PARAMETER :: jp_msa1_trd = jp_lm_trd + jp_medusa_trd !: Last index of MEDUSA passive tracers
+
+ !!======================================================================
+END MODULE par_medusa
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/sms_medusa.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/sms_medusa.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/sms_medusa.F90 (revision 8155)
@@ -0,0 +1,521 @@
+MODULE sms_medusa
+ !!----------------------------------------------------------------------
+ !! *** sms_medusa.F90 ***
+ !! TOP : MEDUSA Source Minus Sink variables
+ !!----------------------------------------------------------------------
+ !! History : - ! 1999-09 (M. Levy) original code
+ !! - ! 2000-12 (O. Aumont, E. Kestenare) add sediment
+ !! 1.0 ! 2005-10 (C. Ethe) F90
+ !! 1.0 ! 2005-03 (A-S Kremeur) add fphylab, fzoolab, fdetlab, fdbod
+ !! - ! 2005-06 (A-S Kremeur) add sedpocb, sedpocn, sedpoca
+ !! 2.0 ! 2007-04 (C. Deltel, G. Madec) Free form and modules
+ !! - ! 2008-08 (K. Popova) adaptation for MEDUSA
+ !! - ! 2008-11 (A. Yool) continuing adaptation for MEDUSA
+ !! - ! 2010-03 (A. Yool) updated for branch inclusion
+ !! - ! 2011-04 (A. Yool) updated for ROAM project
+ !!----------------------------------------------------------------------
+
+#if defined key_medusa
+ !!----------------------------------------------------------------------
+ !! 'key_medusa' MEDUSA model
+ !!----------------------------------------------------------------------
+ USE par_oce
+ USE par_trc
+
+ IMPLICIT NONE
+ PUBLIC
+
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 1.0 , LOCEAN-IPSL (2005)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+ INTEGER :: numnatp_ref = -1 !! Logical units for namelist medusa
+ INTEGER :: numnatp_cfg = -1 !! Logical units for namelist medusa
+ INTEGER :: numonp = -1 !! Logical unit for namelist medusa output
+
+!!----------------------------------------------------------------------
+!! Biological parameters
+!!----------------------------------------------------------------------
+!!
+!! Primary production and chl related quantities
+ REAL(wp) :: xxi !: conversion factor from gC to mmolN
+ REAL(wp) :: xaln !: Chl-a specific initial slope of P-I curve for non-diatoms
+ REAL(wp) :: xald !: Chl-a specific initial slope of P-I curve for diatoms
+ INTEGER :: jphy !: phytoplankton T-dependent growth switch
+ REAL(wp) :: xvpn !: maximum growth rate for non-diatoms
+ REAL(wp) :: xvpd !: maximum growth rate for diatoms
+ REAL(wp) :: xthetam !: maximum Chl to C ratio for non-diatoms
+ REAL(wp) :: xthetamd !: maximum Chl to C ratio for diatoms
+ REAL(wp) :: jq10 !: specific Q10 value (jphy==2)
+!!
+!! Diatom silicon parameters
+ REAL(wp) :: xsin0 !: minimum diatom Si:N ratio
+ REAL(wp) :: xnsi0 !: minimum diatom N:Si ratio
+ REAL(wp) :: xuif !: hypothetical growth ratio at infinite Si:N ratio
+!!
+!! Nutrient limitation
+ INTEGER :: jliebig !: Liebig nutrient uptake switch
+ REAL(wp) :: xnln !: half-sat constant for DIN uptake by non-diatoms
+ REAL(wp) :: xnld !: half-sat constant for DIN uptake by diatoms
+ REAL(wp) :: xsld !: half-sat constant for Si uptake by diatoms
+ REAL(wp) :: xfln !: half-sat constant for Fe uptake by non-diatoms
+ REAL(wp) :: xfld !: half-sat constant for Fe uptake by diatoms
+!!
+!! Grazing
+ REAL(wp) :: xgmi !: microzoo maximum growth rate
+ REAL(wp) :: xgme !: mesozoo maximum growth rate
+ REAL(wp) :: xkmi !: microzoo grazing half-sat parameter
+ REAL(wp) :: xkme !: mesozoo grazing half-sat parameter
+ REAL(wp) :: xphi !: micro/mesozoo grazing inefficiency
+ REAL(wp) :: xbetan !: micro/mesozoo N assimilation efficiency
+ REAL(wp) :: xbetac !: micro/mesozoo C assimilation efficiency
+ REAL(wp) :: xkc !: micro/mesozoo net C growth efficiency
+ REAL(wp) :: xpmipn !: grazing preference of microzoo for non-diatoms
+ REAL(wp) :: xpmid !: grazing preference of microzoo for diatoms
+ REAL(wp) :: xpmepn !: grazing preference of mesozoo for non-diatoms
+ REAL(wp) :: xpmepd !: grazing preference of mesozoo for diatoms
+ REAL(wp) :: xpmezmi !: grazing preference of mesozoo for microzoo
+ REAL(wp) :: xpmed !: grazing preference of mesozoo for detritus
+!!
+!! Metabolic losses
+ REAL(wp) :: xmetapn !: non-diatom metabolic loss rate
+ REAL(wp) :: xmetapd !: diatom metabolic loss rate
+ REAL(wp) :: xmetazmi !: microzoo metabolic loss rate
+ REAL(wp) :: xmetazme !: mesozoo metabolic loss rate
+!!
+!! Mortality losses
+ INTEGER :: jmpn !: non-diatom mortality functional form
+ REAL(wp) :: xmpn !: non-diatom mortality rate
+ REAL(wp) :: xkphn !: non-diatom mortality half-sat constant
+ INTEGER :: jmpd !: diatom mortality functional form
+ REAL(wp) :: xmpd !: diatom mortality rate
+ REAL(wp) :: xkphd !: diatom mortality half-sat constant
+ INTEGER :: jmzmi !: microzoo mortality functional form
+ REAL(wp) :: xmzmi !: microzoo mortality rate
+ REAL(wp) :: xkzmi !: microzoo mortality half-sat constant
+ INTEGER :: jmzme !: mesozoo mortality functional form
+ REAL(wp) :: xmzme !: mesozoo mortality rate
+ REAL(wp) :: xkzme !: mesozoo mortality half-sat constant
+!!
+!! Remineralisation
+ INTEGER :: jmd !: detritus T-dependent remineralisation switch
+ INTEGER :: jsfd !: accelerate seafloor detritus remin. switch
+ REAL(wp) :: xmd !: detrital nitrogen remineralisation rate
+ REAL(wp) :: xmdc !: detrital carbon remineralisation rate
+!!
+!! Stochiometric ratios
+ REAL(wp) :: xthetapn !: non-diatom C:N ratio
+ REAL(wp) :: xthetapd !: diatom C:N ratio
+ REAL(wp) :: xthetazmi !: microzoo C:N ratio
+ REAL(wp) :: xthetazme !: mesozoo C:N ratio
+ REAL(wp) :: xthetad !: detritus C:N ratio
+ REAL(wp) :: xrfn !: phytoplankton Fe:N ratio
+ REAL(wp) :: xrsn !: diatom Si:N ratio (NOT USED HERE; RETAINED FOR LOBSTER)
+!!
+!! Iron parameters
+ INTEGER :: jiron !: iron scavenging submodel switch
+ REAL(wp) :: xfe_mass !: iron atomic mass
+ REAL(wp) :: xfe_sol !: aeolian iron solubility
+ REAL(wp) :: xfe_sed !: sediment iron input
+ REAL(wp) :: xLgT !: total ligand concentration (umol/m3)
+ REAL(wp) :: xk_FeL !: dissociation constant for (Fe + L)
+ REAL(wp) :: xk_sc_Fe !: scavenging rate of "free" iron
+!!
+!! Gravitational sinking
+ REAL(wp) :: vsed !: detritus gravitational sinking rate
+ REAL(wp) :: xhr !: coefficient for Martin et al. (1987) remineralisation
+!!
+!! Fast-sinking detritus parameters
+ INTEGER :: jexport !: fast detritus remineralisation switch
+ INTEGER :: jfdfate !: fate of fast detritus at seafloor switch
+ INTEGER :: jrratio !: rain ratio switch
+ INTEGER :: jocalccd !: CCD switch
+ REAL(wp) :: xridg_r0 !: Ridgwell rain ratio coefficient
+ REAL(wp) :: xfdfrac1 !: fast-sinking fraction of diatom nat. mort. losses
+ REAL(wp) :: xfdfrac2 !: fast-sinking fraction of mesozooplankton mort. losses
+ REAL(wp) :: xfdfrac3 !: fast-sinking fraction of diatom silicon grazing losses
+ REAL(wp) :: xcaco3a !: polar (high latitude) CaCO3 fraction
+ REAL(wp) :: xcaco3b !: equatorial (low latitude) CaCO3 fraction
+ REAL(wp) :: xmassc !: organic C mass:mole ratio, C106 H175 O40 N16 P1
+ REAL(wp) :: xmassca !: calcium carbonate mass:mole ratio, CaCO3
+ REAL(wp) :: xmasssi !: biogenic silicon mass:mole ratio, (H2SiO3)n
+ REAL(wp) :: xprotca !: calcium carbonate protection ratio
+ REAL(wp) :: xprotsi !: biogenic silicon protection ratio
+ REAL(wp) :: xfastc !: organic C remineralisation length scale
+ REAL(wp) :: xfastca !: calcium carbonate dissolution length scale
+ REAL(wp) :: xfastsi !: biogenic silicon dissolution length scale
+!!
+!! Benthos parameters
+ INTEGER :: jorgben !: does organic detritus go to the benthos?
+ INTEGER :: jinorgben !: does inorganic detritus go to the benthos?
+!!
+ REAL(wp) :: xsedn !: organic nitrogen sediment remineralisation rate
+ REAL(wp) :: xsedfe !: organic iron sediment remineralisation rate
+ REAL(wp) :: xsedsi !: inorganic silicon sediment dissolution rate
+ REAL(wp) :: xsedc !: organic carbon sediment remineralisation rate
+ REAL(wp) :: xsedca !: inorganic carbon sediment dissolution rate
+ REAL(wp) :: xburial !: burial rate of seafloor detritus
+!!
+!! River parameters
+ INTEGER :: jriver_n !: riverine nitrogen? 0 = no, 1 = conc, 2 = flux
+ INTEGER :: jriver_si !: riverine silicon? 0 = no, 1 = conc, 2 = flux
+ INTEGER :: jriver_c !: riverine carbon? 0 = no, 1 = conc, 2 = flux
+ INTEGER :: jriver_alk!: riverine alkalinity? 0 = no, 1 = conc, 2 = flux
+ INTEGER :: jriver_dep!: depth river input added to? 1 = surface, >1 possible
+!!
+!! Miscellaneous
+ REAL(wp) :: xsdiss !: diatom frustule dissolution rate
+!!
+!! Additional parameters
+ INTEGER :: jpkb !: vertical layer for diagnostic of the vertical flux
+!!
+!! UKESM diagnostics
+ INTEGER :: jdms !: include DMS diagnostics ? Jpalm (27-08-2014)
+ INTEGER :: jdms_input !: use instant (0) or diel-average (1) inputs (AXY, 08/07/2015)
+ INTEGER :: jdms_model !: choice of DMS model passed to atmosphere
+!! 1 = ANDR, 2 = SIMO, 3 = ARAN, 4 = HALL
+!!
+!!
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: remdmp !: depth dependent damping coefficient of passive tracers
+!!
+!! AXY (27/07/10): add in indices for depth horizons (for sinking flux
+!! and seafloor iron inputs)
+ INTEGER :: i0100, i0150, i0200, i0500, i1000, i1100
+#if defined key_roam
+!!
+!! ROAM carbon, alkalinity and oxygen cycle parameters
+ REAL(wp) :: xthetaphy !: oxygen evolution/consumption by phytoplankton
+ REAL(wp) :: xthetazoo !: oxygen consumption by zooplankton
+ REAL(wp) :: xthetanit !: oxygen consumption by nitrogen remineralisation
+ REAL(wp) :: xthetarem !: oxygen consumption by carbon remineralisation
+ REAL(wp) :: xo2min !: oxygen minimum concentration
+!!
+!! 3D fields of carbonate system parameters
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: f3_pH !: 3D pH
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: f3_h2co3 !: 3D carbonic acid
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: f3_hco3 !: 3D bicarbonate
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: f3_co3 !: 3D carbonate
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: f3_omcal !: 3D omega calcite
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: f3_omarg !: 3D omega aragonite
+!!
+!! 2D fields of calcium carbonate compensation depth
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: f2_ccd_cal !: 2D calcite CCD depth
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: f2_ccd_arg !: 2D aragonite CCD depth
+!!
+!! 2D fields of organic and inorganic material sedimented on the seafloor
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zb_sed_n !: 2D organic nitrogen (before)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zn_sed_n !: 2D organic nitrogen (now)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: za_sed_n !: 2D organic nitrogen (after)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zb_sed_fe !: 2D organic iron (before)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zn_sed_fe !: 2D organic iron (now)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: za_sed_fe !: 2D organic iron (after)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zb_sed_si !: 2D inorganic silicon (before)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zn_sed_si !: 2D inorganic silicon (now)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: za_sed_si !: 2D inorganic silicon (after)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zb_sed_c !: 2D organic carbon (before)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zn_sed_c !: 2D organic carbon (now)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: za_sed_c !: 2D organic carbon (after)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zb_sed_ca !: 2D inorganic carbon (before)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zn_sed_ca !: 2D inorganic carbon (now)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: za_sed_ca !: 2D inorganic carbon (after)
+!!
+!! 2D fields of temporally averaged properties for DMS calculations (AXY, 07/07/15)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zb_dms_chn !: 2D avg CHN (before)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zn_dms_chn !: 2D avg CHN (now)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: za_dms_chn !: 2D avg CHN (after)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zb_dms_chd !: 2D avg CHD (before)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zn_dms_chd !: 2D avg CHD (now)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: za_dms_chd !: 2D avg CHD (after)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zb_dms_mld !: 2D avg MLD (before)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zn_dms_mld !: 2D avg MLD (now)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: za_dms_mld !: 2D avg MLD (after)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zb_dms_qsr !: 2D avg QSR (before)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zn_dms_qsr !: 2D avg QSR (now)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: za_dms_qsr !: 2D avg QSR (after)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zb_dms_din !: 2D avg DIN (before)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zn_dms_din !: 2D avg DIN (now)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: za_dms_din !: 2D avg DIN (after)
+!!
+!! 2D fields needing to be knows at first tstp for coupling with atm - UKEMS(Jpalm,14-06-2016)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zb_co2_flx !: 2D avg fx co2 (before)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zn_co2_flx !: 2D avg fx co2 (now)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: za_co2_flx !: 2D avg fx co2 (after)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zb_dms_srf !: 2D avg sfr dms (before)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zn_dms_srf !: 2D avg sfr dms (now)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: za_dms_srf !: 2D avg srf dms (after)
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zn_chl_srf !: 2D avg srf chl (now)
+
+#endif
+
+!!----------------------------------------------------------------------
+!! CCD parameter
+!!----------------------------------------------------------------------
+!!
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ocal_ccd !: CCD depth
+
+!!----------------------------------------------------------------------
+!! Dust parameters
+!!----------------------------------------------------------------------
+!!
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dust !: dust parameter 1
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zirondep !! Fe deposition
+
+!!----------------------------------------------------------------------
+!! River parameters
+!!----------------------------------------------------------------------
+!!
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: riv_n !: riverine N
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: riv_si !: riverine Si
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: riv_c !: riverine C
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: riv_alk !: riverine alkalinity
+ !! AXY (19/07/12): add this to permit river fluxes to be added below top box
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: friver_dep !: where river fluxes added
+
+#if defined key_roam
+!!----------------------------------------------------------------------
+!! Atmospheric pCO2 data (1859 to 2100 inclusive)
+!!----------------------------------------------------------------------
+!!
+ REAL(wp), DIMENSION(242) :: hist_pco2 !: pCO2
+
+# if defined key_rcp26
+ !! UKMO, run AJKKH + KAAEC, RCP 2.6, pCO2 time evolution
+ DATA hist_pco2 / 286.0230, 286.1730, 286.3230, 286.4480, 286.5730, &
+ & 286.7230, 286.8480, 286.9480, 287.0480, 287.1730, &
+ & 287.3230, 287.4730, 287.6480, 287.8480, 288.0730, &
+ & 288.3480, 288.6480, 288.9730, 289.3470, 289.7470, &
+ & 290.1730, 290.6470, 291.1470, 291.6220, 292.0720, &
+ & 292.5220, 292.9220, 293.2470, 293.5220, 293.7470, &
+ & 293.9470, 294.1220, 294.2720, 294.4220, 294.5470, &
+ & 294.6470, 294.7470, 294.8470, 294.9710, 295.1710, &
+ & 295.4460, 295.7470, 296.0720, 296.4210, 296.7710, &
+ & 297.1460, 297.5710, 298.0210, 298.4460, 298.8460, &
+ & 299.2460, 299.6450, 300.0210, 300.3710, 300.7200, &
+ & 301.0450, 301.3460, 301.6710, 302.0200, 302.3450, &
+ & 302.6450, 302.9700, 303.3450, 303.7200, 304.0700, &
+ & 304.4700, 304.9200, 305.3440, 305.7700, 306.2450, &
+ & 306.7190, 307.1700, 307.6440, 308.1190, 308.5440, &
+ & 308.9440, 309.3440, 309.6940, 309.9440, 310.1190, &
+ & 310.2440, 310.3190, 310.3190, 310.2440, 310.1440, &
+ & 310.0690, 310.0440, 310.0690, 310.1440, 310.2690, &
+ & 310.4440, 310.6940, 311.0430, 311.4440, 311.8690, &
+ & 312.3680, 312.9430, 313.5430, 314.1680, 314.7900, &
+ & 315.4430, 316.2150, 317.0170, 317.7370, 318.3400, &
+ & 318.8680, 319.5900, 320.5890, 321.5470, 322.5770, &
+ & 323.8440, 324.9260, 325.7960, 327.0810, 328.6180, &
+ & 329.6830, 330.5250, 331.6880, 333.2120, 334.7870, &
+ & 336.4640, 338.2990, 339.6660, 340.7310, 342.1360, &
+ & 343.7200, 345.2200, 346.7350, 348.5820, 350.6740, &
+ & 352.4230, 353.7910, 354.9530, 355.8210, 356.7130, &
+ & 358.0630, 359.7720, 361.3970, 363.0900, 365.2560, &
+ & 367.2810, 368.7980, 370.4000, 372.4550, 374.6920, &
+ & 376.7440, 378.7440, 380.7580, 382.7080, 384.7300, &
+ & 386.9310, 389.2150, 391.4910, 393.7710, 396.0460, &
+ & 398.3240, 400.6080, 402.8950, 405.1780, 407.4550, &
+ & 409.7260, 411.9930, 414.2500, 416.4410, 418.5280, &
+ & 420.5250, 422.4390, 424.2720, 426.0200, 427.6750, &
+ & 429.2360, 430.7050, 432.0850, 433.3580, 434.5140, &
+ & 435.5740, 436.5490, 437.4420, 438.2550, 438.9810, &
+ & 439.6110, 440.1430, 440.5770, 440.9450, 441.2660, &
+ & 441.5410, 441.7840, 442.0050, 442.2040, 442.3780, &
+ & 442.5210, 442.6200, 442.6720, 442.6810, 442.6540, &
+ & 442.5830, 442.4670, 442.3270, 442.1680, 441.9960, &
+ & 441.8060, 441.5930, 441.3440, 441.0540, 440.7230, &
+ & 440.3510, 439.9300, 439.4650, 438.9730, 438.4630, &
+ & 437.9400, 437.4020, 436.8400, 436.2640, 435.6850, &
+ & 435.1030, 434.5160, 433.9170, 433.3060, 432.7010, &
+ & 432.1110, 431.5380, 430.9810, 430.4320, 429.8860, &
+ & 429.3370, 428.7810, 428.2220, 427.6490, 427.0660, &
+ & 426.4890, 425.9270, 425.3840, 424.8610, 424.3540, &
+ & 423.8540, 423.3540, 422.8530, 422.3510, 421.8410, &
+ & 421.3250, 420.8190 /
+# else
+ !! UKMO, run AJKKH + KAAEF, RCP 8.5, pCO2 time evolution
+ DATA hist_pco2 / 286.0230, 286.1730, 286.3230, 286.4480, 286.5730, &
+ & 286.7230, 286.8480, 286.9480, 287.0480, 287.1730, &
+ & 287.3230, 287.4730, 287.6480, 287.8480, 288.0730, &
+ & 288.3480, 288.6480, 288.9730, 289.3470, 289.7470, &
+ & 290.1730, 290.6470, 291.1470, 291.6220, 292.0720, &
+ & 292.5220, 292.9220, 293.2470, 293.5220, 293.7470, &
+ & 293.9470, 294.1220, 294.2720, 294.4220, 294.5470, &
+ & 294.6470, 294.7470, 294.8470, 294.9710, 295.1710, &
+ & 295.4460, 295.7470, 296.0720, 296.4210, 296.7710, &
+ & 297.1460, 297.5710, 298.0210, 298.4460, 298.8460, &
+ & 299.2460, 299.6450, 300.0210, 300.3710, 300.7200, &
+ & 301.0450, 301.3460, 301.6710, 302.0200, 302.3450, &
+ & 302.6450, 302.9700, 303.3450, 303.7200, 304.0700, &
+ & 304.4700, 304.9200, 305.3440, 305.7700, 306.2450, &
+ & 306.7190, 307.1700, 307.6440, 308.1190, 308.5440, &
+ & 308.9440, 309.3440, 309.6940, 309.9440, 310.1190, &
+ & 310.2440, 310.3190, 310.3190, 310.2440, 310.1440, &
+ & 310.0690, 310.0440, 310.0690, 310.1440, 310.2690, &
+ & 310.4440, 310.6940, 311.0430, 311.4440, 311.8690, &
+ & 312.3680, 312.9430, 313.5430, 314.1680, 314.7900, &
+ & 315.4430, 316.2150, 317.0170, 317.7370, 318.3400, &
+ & 318.8680, 319.5900, 320.5890, 321.5470, 322.5770, &
+ & 323.8440, 324.9260, 325.7960, 327.0810, 328.6180, &
+ & 329.6830, 330.5250, 331.6880, 333.2120, 334.7870, &
+ & 336.4640, 338.2990, 339.6660, 340.7310, 342.1360, &
+ & 343.7200, 345.2200, 346.7350, 348.5820, 350.6740, &
+ & 352.4230, 353.7910, 354.9530, 355.8210, 356.7130, &
+ & 358.0630, 359.7720, 361.3970, 363.0900, 365.2560, &
+ & 367.2810, 368.7980, 370.4000, 372.4550, 374.6920, &
+ & 376.7440, 378.7440, 380.7580, 382.7080, 384.7300, &
+ & 386.9420, 389.2540, 391.5670, 393.9370, 396.3920, &
+ & 398.9320, 401.5550, 404.2550, 407.0220, 409.8530, &
+ & 412.7470, 415.7050, 418.7210, 421.7880, 424.9180, &
+ & 428.1200, 431.3970, 434.7470, 438.1650, 441.6410, &
+ & 445.1700, 448.7530, 452.3920, 456.0950, 459.8810, &
+ & 463.7680, 467.7660, 471.8750, 476.0960, 480.4210, &
+ & 484.8390, 489.3470, 493.9430, 498.6400, 503.4380, &
+ & 508.3410, 513.3630, 518.5160, 523.8050, 529.2290, &
+ & 534.7780, 540.4450, 546.2230, 552.1120, 558.1110, &
+ & 564.2110, 570.4130, 576.7390, 583.1990, 589.7980, &
+ & 596.5390, 603.4110, 610.4060, 617.4940, 624.6500, &
+ & 631.8800, 639.1750, 646.5360, 653.9800, 661.5230, &
+ & 669.1840, 676.9570, 684.8290, 692.7790, 700.7690, &
+ & 708.8050, 716.8870, 725.0020, 733.1770, 741.3900, &
+ & 749.6700, 758.0480, 766.5050, 775.0350, 783.6110, &
+ & 792.2200, 800.8740, 809.5680, 818.2760, 827.0090, &
+ & 835.8020, 844.6550, 853.5730, 862.5690, 871.6190, &
+ & 880.7020, 889.8240, 898.9590, 908.1270, 917.3080, &
+ & 926.4960, 935.7040 /
+# endif
+#endif
+
+!!----------------------------------------------------------------------
+!! Optical parameters
+!!----------------------------------------------------------------------
+!!
+ REAL(wp) :: xkr0 !: water coefficient absorption in red (NAMELIST)
+ REAL(wp) :: xkg0 !: water coefficient absorption in green (NAMELIST)
+ REAL(wp) :: xkrp !: pigment coefficient absorption in red (NAMELIST)
+ REAL(wp) :: xkgp !: pigment coefficient absorption in green (NAMELIST)
+ REAL(wp) :: xlr !: exposant for pigment absorption in red (NAMELIST)
+ REAL(wp) :: xlg !: exposant for pigment absorption in green (NAMELIST)
+ REAL(wp) :: rpig !: chla/chla+phea ratio (NAMELIST)
+
+ INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:) :: neln !: number of levels in the euphotic layer
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: xze !: euphotic layer depth
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xpar !: par (photosynthetic available radiation)
+
+!!----------------------------------------------------------------------
+!! Sediment parameters
+!!
+!! AXY (16/01/12): these parameters were originally part of the pre-
+!! cursor model on which MEDUSA's code was grounded;
+!! they do not relate to the sediment/benthos submodel
+!! added as part of the ROAM project; they have only
+!! been retained because they are distributed through
+!! MEDUSA and require a proper clean-up to purge
+!!----------------------------------------------------------------------
+!!
+ REAL(wp) :: sedlam !: time coefficient of POC remineralization in sediments
+ REAL(wp) :: sedlostpoc !: ???
+ REAL(wp) :: areacot !: ???
+
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dminl !: fraction of sinking POC released in sediments
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dmin3 !: fraction of sinking POC released at each level
+
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sedpocb !: mass of POC in sediments
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sedpocn !: mass of POC in sediments
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sedpoca !: mass of POC in sediments
+
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: fbodf !: rapid sinking particles
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: fbods !: rapid sinking particles
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: fbodn !: rapid sinking particles
+
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ffln !:
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: fflf !:
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ffls !:
+
+ REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: cmask !: ???
+
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 3.3 , NEMO Consortium (2010)
+ !! $Id$
+ !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ INTEGER FUNCTION sms_medusa_alloc()
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE sms_medusa_alloc ***
+ !!----------------------------------------------------------------------
+ USE lib_mpp , ONLY: ctl_warn
+ INTEGER :: ierr(8) ! Local variables
+ !!----------------------------------------------------------------------
+ ierr(:) = 0
+ !
+#if defined key_medusa
+ !* depth-dependent damping coefficient
+ ALLOCATE( remdmp(jpk,jp_medusa), STAT=ierr(1) )
+# if defined key_roam
+ !* 2D and 3D fields of carbonate system parameters
+ ALLOCATE( f2_ccd_cal(jpi,jpj) , f2_ccd_arg(jpi,jpj) , &
+ & f3_pH(jpi,jpj,jpk) , f3_h2co3(jpi,jpj,jpk), &
+ & f3_hco3(jpi,jpj,jpk) , f3_co3(jpi,jpj,jpk) , &
+ & f3_omcal(jpi,jpj,jpk), f3_omarg(jpi,jpj,jpk), STAT=ierr(2) )
+ !* 2D fields of organic and inorganic material sedimented on the seafloor
+ ALLOCATE( zb_sed_n(jpi,jpj) , zn_sed_n(jpi,jpj) , &
+ & za_sed_n(jpi,jpj) , &
+ & zb_sed_fe(jpi,jpj) , zn_sed_fe(jpi,jpj) , &
+ & za_sed_fe(jpi,jpj) , &
+ & zb_sed_si(jpi,jpj) , zn_sed_si(jpi,jpj) , &
+ & za_sed_si(jpi,jpj) , &
+ & zb_sed_c(jpi,jpj) , zn_sed_c(jpi,jpj) , &
+ & za_sed_c(jpi,jpj) , &
+ & zb_sed_ca(jpi,jpj) , zn_sed_ca(jpi,jpj) , &
+ & za_sed_ca(jpi,jpj) , STAT=ierr(3) )
+ !* 2D fields of temporally averaged properties for DMS calculations (AXY, 07/07/15)
+ ALLOCATE( zb_dms_chn(jpi,jpj) , zn_dms_chn(jpi,jpj) , &
+ & za_dms_chn(jpi,jpj) , &
+ & zb_dms_chd(jpi,jpj) , zn_dms_chd(jpi,jpj) , &
+ & za_dms_chd(jpi,jpj) , &
+ & zb_dms_mld(jpi,jpj) , zn_dms_mld(jpi,jpj) , &
+ & za_dms_mld(jpi,jpj) , &
+ & zb_dms_qsr(jpi,jpj) , zn_dms_qsr(jpi,jpj) , &
+ & za_dms_qsr(jpi,jpj) , &
+ & zb_dms_din(jpi,jpj) , zn_dms_din(jpi,jpj) , &
+ & za_dms_din(jpi,jpj) , STAT=ierr(4) )
+ !* 2D fields needing to be knows at first tstp for coupling with atm -
+ !UKEMSi (Jpalm,14-06-2016)
+ ALLOCATE( zb_co2_flx(jpi,jpj) , zn_co2_flx(jpi,jpj) , &
+ & za_co2_flx(jpi,jpj) , &
+ & zb_dms_srf(jpi,jpj) , zn_dms_srf(jpi,jpj) , &
+ & za_dms_srf(jpi,jpj) , zn_chl_srf(jpi,jpj) , STAT=ierr(5) )
+# endif
+ !* 2D fields of miscellaneous parameters
+ ALLOCATE( ocal_ccd(jpi,jpj) , dust(jpi,jpj) , &
+ & zirondep(jpi,jpj) , &
+ & riv_n(jpi,jpj) , &
+ & riv_si(jpi,jpj) , riv_c(jpi,jpj) , &
+ & riv_alk(jpi,jpj) , friver_dep(jpk,jpk) , STAT=ierr(6) )
+ !* 2D and 3D fields of light parameters
+ ALLOCATE( neln(jpi,jpj) , xze(jpi,jpj) , &
+ & xpar(jpi,jpj,jpk) , STAT=ierr(7) )
+ !* 2D and 3D fields of sediment-associated parameters
+ ALLOCATE( dminl(jpi,jpj) , dmin3(jpi,jpj,jpk) , &
+ & sedpocb(jpi,jpj) , sedpocn(jpi,jpj) , &
+ & sedpoca(jpi,jpj) , fbodn(jpi,jpj) , &
+ & fbodf(jpi,jpj) , fbods(jpi,jpj) , &
+ & ffln(jpi,jpj,jpk) , fflf(jpi,jpj,jpk) , &
+ & ffls(jpi,jpj,jpk) , cmask(jpi,jpj) , STAT=ierr(8) )
+#endif
+ !
+ sms_medusa_alloc = MAXVAL( ierr )
+ !
+ IF( sms_medusa_alloc /= 0 ) CALL ctl_warn('sms_medusa_alloc: failed to allocate arrays')
+ !
+ END FUNCTION sms_medusa_alloc
+
+#else
+ !!----------------------------------------------------------------------
+ !! Empty module : NO MEDUSA model
+ !!----------------------------------------------------------------------
+#endif
+
+ !!======================================================================
+END MODULE sms_medusa
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcavg_medusa.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcavg_medusa.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcavg_medusa.F90 (revision 8155)
@@ -0,0 +1,128 @@
+MODULE trcavg_medusa
+ !!======================================================================
+ !! *** MODULE trcavg_medusa ***
+ !! TOP : MEDUSA
+ !!======================================================================
+ !! History : - ! 2015-07 (A. Yool) Original code
+ !!----------------------------------------------------------------------
+#if defined key_medusa && defined key_roam
+ !!----------------------------------------------------------------------
+ !! MEDUSA rolling averages
+ !!----------------------------------------------------------------------
+ !! trc_avg_medusa :
+ !!----------------------------------------------------------------------
+ USE oce_trc
+ USE trc
+ USE sms_medusa
+ USE lbclnk
+ USE prtctl_trc ! Print control for debugging
+ USE in_out_manager ! I/O manager
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_avg_medusa ! called in trc_sms_medusa
+
+ !!* Substitution
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+CONTAINS
+
+!=======================================================================
+!
+ SUBROUTINE trc_avg_medusa( kt )
+!
+!=======================================================================
+ !!
+ !! Title : Calculates rolling averages of variables
+ !! Author : Andrew Yool
+ !! Date : 23/07/15
+ !!
+ !! Calculates and updates rolling averages of properties such
+ !! as surface irradiance and mixed layer depth that are used
+ !! in functions that require average rather than instantaneous
+ !! values.
+ !!
+ !! This functionality was originally added to support the
+ !! calculation of surface DMS concentrations - and was done so
+ !! within the trcbio_meduse.F90 routine - but was moved to
+ !! this separate module so that its calculations could be used
+ !! to inform MEDUSA's submarine irradiance field
+ !!
+!=======================================================================
+!
+ IMPLICIT NONE
+!
+ INTEGER, INTENT( in ) :: kt ! index of the time stepping
+!
+!=======================================================================
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' MEDUSA inside trc_avg_medusa'
+ CALL flush(numout)
+# endif
+ !! AXY (24/07/15): alter this to report on first MEDUSA call
+ IF( kt == nittrc000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) ' trc_avg_medusa: MEDUSA rolling average'
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~'
+ IF(lwp) WRITE(numout,*) ' kt =',kt
+ ENDIF
+ !!
+ !!----------------------------------------------------------------------
+ !! Process average fields
+ !! The empirical formulae used for estimating surface DMS concentrations
+ !! require temporally averaged input fields; this block calculates these
+ !! averages based on diel averages; note that rdt
+ !!----------------------------------------------------------------------
+ !!
+ zn_dms_chn(:,:) = ( zb_dms_chn(:,:) * ((86400. - rdt) / 86400.) ) &
+ & + ( trn(:,:,1,jpchn) * (rdt / 86400.) )
+ zb_dms_chn(:,:) = zn_dms_chn(:,:)
+ zn_dms_chd(:,:) = ( zb_dms_chd(:,:) * ((86400. - rdt) / 86400.) ) &
+ & + ( trn(:,:,1,jpchd) * (rdt / 86400.) )
+ zb_dms_chd(:,:) = zn_dms_chd(:,:)
+ zn_dms_mld(:,:) = ( zb_dms_mld(:,:) * ((86400. - rdt) / 86400.) ) &
+ & + ( hmld(:,:) * (rdt / 86400.) )
+ zb_dms_mld(:,:) = zn_dms_mld(:,:)
+ zn_dms_qsr(:,:) = ( zb_dms_qsr(:,:) * ((86400. - rdt) / 86400.) ) &
+ & + ( qsr(:,:) * (rdt / 86400.) )
+ zb_dms_qsr(:,:) = zn_dms_qsr(:,:)
+ zn_dms_din(:,:) = ( zb_dms_din(:,:) * ((86400. - rdt) / 86400.) ) &
+ & + ( trn(:,:,1,jpdin) * (rdt / 86400.) )
+ zb_dms_din(:,:) = zn_dms_din(:,:)
+
+ END SUBROUTINE trc_avg_medusa
+
+!=======================================================================
+!=======================================================================
+!=======================================================================
+
+#else
+ !!======================================================================
+ !! Dummy module : No MEDUSA bio-model
+ !!======================================================================
+
+CONTAINS
+
+!=======================================================================
+!
+ SUBROUTINE trc_avg_medusa( kt ) !! EMPTY Routine
+!
+!
+ INTEGER, INTENT( in ) :: kt
+!
+
+ WRITE(*,*) 'trc_avg_medusa: You should not have seen this print! error?'
+
+ END SUBROUTINE trc_avg_medusa
+#endif
+
+ !!======================================================================
+END MODULE trcavg_medusa
+
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcbio_medusa.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcbio_medusa.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcbio_medusa.F90 (revision 8155)
@@ -0,0 +1,6197 @@
+MODULE trcbio_medusa
+ !!======================================================================
+ !! *** MODULE trcbio ***
+ !! TOP : MEDUSA
+ !!======================================================================
+ !! History :
+ !! - ! 1999-07 (M. Levy) original code
+ !! - ! 2000-12 (E. Kestenare) assign parameters to name individual tracers
+ !! - ! 2001-03 (M. Levy) LNO3 + dia2d
+ !! 2.0 ! 2007-12 (C. Deltel, G. Madec) F90
+ !! - ! 2008-08 (K. Popova) adaptation for MEDUSA
+ !! - ! 2008-11 (A. Yool) continuing adaptation for MEDUSA
+ !! - ! 2010-03 (A. Yool) updated for branch inclusion
+ !! - ! 2011-08 (A. Yool) updated for ROAM (see below)
+ !! - ! 2013-03 (A. Yool) updated for iMARNET
+ !! - ! 2013-05 (A. Yool) updated for v3.5
+ !! - ! 2014-08 (A. Yool, J. Palm) Add DMS module for UKESM1 model
+ !! - ! 2015-06 (A. Yool) Update to include MOCSY
+ !! - ! 2015-07 (A. Yool) Update for rolling averages
+ !! - ! 2015-10 (J. Palm) Update for diag outputs through iom_use
+ !! - ! 2016-11 (A. Yool) Updated diags for CMIP6
+ !! - ! 2017-05 (A. Yool) Added extra DMS calculation
+ !!----------------------------------------------------------------------
+ !!
+#if defined key_roam
+ !!----------------------------------------------------------------------
+ !! Updates for the ROAM project include:
+ !! - addition of DIC, alkalinity, detrital carbon and oxygen tracers
+ !! - addition of air-sea fluxes of CO2 and oxygen
+ !! - periodic (monthly) calculation of full 3D carbonate chemistry
+ !! - detrital C:N ratio now free to evolve dynamically
+ !! - benthic storage pools
+ !!
+ !! Opportunity also taken to add functionality:
+ !! - switch for Liebig Law (= most-limiting) nutrient uptake
+ !! - switch for accelerated seafloor detritus remineralisation
+ !! - switch for fast -> slow detritus transfer at seafloor
+ !! - switch for ballast vs. Martin vs. Henson fast detritus remin.
+ !! - per GMD referee remarks, xfdfrac3 introduced for grazed PDS
+ !!----------------------------------------------------------------------
+#endif
+ !!
+#if defined key_mocsy
+ !!----------------------------------------------------------------------
+ !! Updates with the addition of MOCSY include:
+ !! - option to use PML or MOCSY carbonate chemistry (the latter is
+ !! preferred)
+ !! - central calculation of gas transfer velocity, f_kw660; previously
+ !! this was done separately for CO2 and O2 with predictable results
+ !! - distribution of f_kw660 to both PML and MOCSY CO2 air-sea flux
+ !! calculations and to those for O2 air-sea flux
+ !! - extra diagnostics included for MOCSY
+ !!----------------------------------------------------------------------
+#endif
+ !!
+#if defined key_medusa
+ !!----------------------------------------------------------------------
+ !! MEDUSA bio-model
+ !!----------------------------------------------------------------------
+ !! trc_bio_medusa :
+ !!----------------------------------------------------------------------
+ USE oce_trc
+ USE trc
+ USE sms_medusa
+ USE lbclnk
+ USE prtctl_trc ! Print control for debugging
+ USE trcsed_medusa
+ USE sbc_oce ! surface forcing
+ USE sbcrnf ! surface boundary condition: runoff variables
+ USE in_out_manager ! I/O manager
+# if defined key_iomput
+ USE iom
+ USE trcnam_medusa ! JPALM 13-11-2015 -- if iom_use for diag
+ !!USE trc_nam_iom_medusa ! JPALM 13-11-2015 -- if iom_use for diag
+# endif
+# if defined key_roam
+ USE gastransfer
+# if defined key_mocsy
+ USE mocsy_wrapper
+# else
+ USE trcco2_medusa
+# endif
+ USE trcoxy_medusa
+ !! Jpalm (08/08/2014)
+ USE trcdms_medusa
+# endif
+ !! AXY (18/01/12): brought in for benthic timestepping
+ USE trcnam_trp ! AXY (24/05/2013)
+ USE trdmxl_trc
+ USE trdtrc_oce ! AXY (24/05/2013)
+
+ !! AXY (30/01/14): necessary to find NaNs on HECTOR
+ USE, INTRINSIC :: ieee_arithmetic
+
+ !! JPALM (27-06-2016): add lk_oasis for CO2 and DMS coupling with atm
+ USE sbc_oce, ONLY: lk_oasis
+ USE oce, ONLY: CO2Flux_out_cpl, DMS_out_cpl, PCO2a_in_cpl, chloro_out_cpl
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_bio_medusa ! called in ???
+
+ !!* Substitution
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+CONTAINS
+
+ SUBROUTINE trc_bio_medusa( kt )
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE trc_bio ***
+ !!
+ !! ** Purpose : compute the now trend due to biogeochemical processes
+ !! and add it to the general trend of passive tracers equations
+ !!
+ !! ** Method : each now biological flux is calculated in function of now
+ !! concentrations of tracers.
+ !! depending on the tracer, these fluxes are sources or sinks.
+ !! the total of the sources and sinks for each tracer
+ !! is added to the general trend.
+ !!
+ !! tra = tra + zf...tra - zftra...
+ !! | |
+ !! | |
+ !! source sink
+ !!
+ !! IF 'key_trc_diabio' defined , the biogeochemical trends
+ !! for passive tracers are saved for futher diagnostics.
+ !!---------------------------------------------------------------------
+ !!
+ !!
+ !!----------------------------------------------------------------------
+ !! Variable conventions
+ !!----------------------------------------------------------------------
+ !!
+ !! names: z*** - state variable
+ !! f*** - function (or temporary variable used in part of a function)
+ !! x*** - parameter
+ !! b*** - right-hand part (sources and sinks)
+ !! i*** - integer variable (usually used in yes/no flags)
+ !!
+ !! time (integer timestep)
+ INTEGER, INTENT( in ) :: kt
+ !!
+ !! spatial array indices
+ INTEGER :: ji,jj,jk,jn
+ !!
+ !! AXY (27/07/10): add in indices for depth horizons (for sinking flux
+ !! and seafloor iron inputs)
+ !! INTEGER :: i0100, i0200, i0500, i1000, i1100
+ !!
+ !! model state variables
+ REAL(wp) :: zchn,zchd,zphn,zphd,zpds,zzmi
+ REAL(wp) :: zzme,zdet,zdtc,zdin,zsil,zfer
+ REAL(wp) :: zage
+# if defined key_roam
+ REAL(wp) :: zdic, zalk, zoxy
+ REAL(wp) :: ztmp, zsal
+# endif
+# if defined key_mocsy
+ REAL(wp) :: zpho
+# endif
+ !!
+ !! integrated source and sink terms
+ REAL(wp) :: b0
+ !! AXY (23/08/13): changed from individual variables for each flux to
+ !! an array that holds all fluxes
+ REAL(wp), DIMENSION(jp_medusa) :: btra
+ !!
+ !! primary production and chl related quantities
+ REAL(wp) :: fthetan,faln,fchn1,fchn,fjln,fprn,frn
+ REAL(wp) :: fthetad,fald,fchd1,fchd,fjld,fprd,frd
+ !! AXY (23/11/16): add in light-only limitation term (normalised 0-1 range)
+ REAL(wp) :: fjlim_pn, fjlim_pd
+ !! AXY (03/02/11): add in Liebig terms
+ REAL(wp) :: fpnlim, fpdlim
+ !! AXY (16/07/09): add in Eppley curve functionality
+ REAL(wp) :: loc_T,fun_T,xvpnT,xvpdT
+ INTEGER :: ieppley
+ !! AXY (16/05/11): per Katya's prompting, add in new T-dependence
+ !! for phytoplankton growth only (i.e. no change
+ !! for remineralisation)
+ REAL(wp) :: fun_Q10
+ !! AXY (01/03/10): add in mixed layer PP diagnostics
+ REAL(wp), DIMENSION(jpi,jpj) :: fprn_ml,fprd_ml
+ !!
+ !! nutrient limiting factors
+ REAL(wp) :: fnln,ffln !! N and Fe
+ REAL(wp) :: fnld,ffld,fsld,fsld2 !! N, Fe and Si
+ !!
+ !! silicon cycle
+ REAL(wp) :: fsin,fnsi,fsin1,fnsi1,fnsi2,fprds,fsdiss
+ !!
+ !! iron cycle; includes parameters for Parekh et al. (2005) iron scheme
+ REAL(wp) :: ffetop,ffebot,ffescav
+ REAL(wp) :: xLgF, xFeT, xFeF, xFeL !! state variables for iron-ligand system
+ REAL(wp), DIMENSION(jpi,jpj) :: xFree !! state variables for iron-ligand system
+ REAL(wp) :: xb_coef_tmp, xb2M4ac !! iron-ligand parameters
+ REAL(wp) :: xmaxFeF,fdeltaFe !! max Fe' parameters
+ !!
+ !! local parameters for Moore et al. (2004) alternative scavenging scheme
+ REAL(wp) :: fbase_scav,fscal_sink,fscal_part,fscal_scav
+ !!
+ !! local parameters for Moore et al. (2008) alternative scavenging scheme
+ REAL(wp) :: fscal_csink,fscal_sisink,fscal_casink
+ !!
+ !! local parameters for Galbraith et al. (2010) alternative scavenging scheme
+ REAL(wp) :: xCscav1, xCscav2, xk_org, xORGscav !! organic portion of scavenging
+ REAL(wp) :: xk_inorg, xINORGscav !! inorganic portion of scavenging
+ !!
+ !! microzooplankton grazing
+ REAL(wp) :: fmi1,fmi,fgmipn,fgmid,fgmidc
+ REAL(wp) :: finmi,ficmi,fstarmi,fmith,fmigrow,fmiexcr,fmiresp
+ !!
+ !! mesozooplankton grazing
+ REAL(wp) :: fme1,fme,fgmepn,fgmepd,fgmepds,fgmezmi,fgmed,fgmedc
+ REAL(wp) :: finme,ficme,fstarme,fmeth,fmegrow,fmeexcr,fmeresp
+ !!
+ !! mortality/Remineralisation (defunct parameter "fz" removed)
+ REAL(wp) :: fdpn,fdpd,fdpds,fdzmi,fdzme,fdd
+# if defined key_roam
+ REAL(wp) :: fddc
+# endif
+ REAL(wp) :: fdpn2,fdpd2,fdpds2,fdzmi2,fdzme2
+ REAL(wp) :: fslown, fslowc
+ REAL(wp), DIMENSION(jpi,jpj) :: fslownflux, fslowcflux
+ REAL(wp) :: fregen,fregensi
+ REAL(wp), DIMENSION(jpi,jpj) :: fregenfast,fregenfastsi
+# if defined key_roam
+ REAL(wp) :: fregenc
+ REAL(wp), DIMENSION(jpi,jpj) :: fregenfastc
+# endif
+ !!
+ !! particle flux
+ REAL(WP) :: fthk,fdep,fdep1,fdep2,flat,fcaco3
+ REAL(WP) :: ftempn,ftempsi,ftempfe,ftempc,ftempca
+ REAL(wp) :: freminn,freminsi,freminfe,freminc,freminca
+ REAL(wp), DIMENSION(jpi,jpj) :: ffastn,ffastsi,ffastfe,ffastc,ffastca
+ REAL(wp) :: fleftn,fleftsi,fleftfe,fleftc,fleftca
+ REAL(wp) :: fheren,fheresi,fherefe,fherec,fhereca
+ REAL(wp) :: fprotf
+ REAL(wp), DIMENSION(jpi,jpj) :: fsedn,fsedsi,fsedfe,fsedc,fsedca
+ REAL(wp), DIMENSION(jpi,jpj) :: fccd
+ REAL(wp) :: fccd_dep
+ !! AXY (28/11/16): fix mbathy bug
+ INTEGER :: jmbathy
+ !!
+ !! AXY (06/07/11): alternative fast detritus schemes
+ REAL(wp) :: fb_val, fl_sst
+ !!
+ !! AXY (08/07/11): fate of fast detritus reaching the seafloor
+ REAL(wp) :: ffast2slown,ffast2slowfe,ffast2slowc
+ !!
+ !! conservation law
+ REAL(wp) :: fnit0,fsil0,ffer0
+# if defined key_roam
+ REAL(wp) :: fcar0,falk0,foxy0
+# endif
+ !!
+ !! temporary variables
+ REAL(wp) :: fq0,fq1,fq2,fq3,fq4,fq5,fq6,fq7,fq8,fq9
+ !!
+ !! water column nutrient and flux integrals
+ REAL(wp), DIMENSION(jpi,jpj) :: ftot_n,ftot_si,ftot_fe
+ REAL(wp), DIMENSION(jpi,jpj) :: fflx_n,fflx_si,fflx_fe
+ REAL(wp), DIMENSION(jpi,jpj) :: fifd_n,fifd_si,fifd_fe
+ REAL(wp), DIMENSION(jpi,jpj) :: fofd_n,fofd_si,fofd_fe
+# if defined key_roam
+ REAL(wp), DIMENSION(jpi,jpj) :: ftot_c,ftot_a,ftot_o2
+ REAL(wp), DIMENSION(jpi,jpj) :: fflx_c,fflx_a,fflx_o2
+ REAL(wp), DIMENSION(jpi,jpj) :: fifd_c,fifd_a,fifd_o2
+ REAL(wp), DIMENSION(jpi,jpj) :: fofd_c,fofd_a,fofd_o2
+# endif
+ !!
+ !! zooplankton grazing integrals
+ REAL(wp), DIMENSION(jpi,jpj) :: fzmi_i,fzmi_o,fzme_i,fzme_o
+ !!
+ !! limitation term temporary variables
+ REAL(wp), DIMENSION(jpi,jpj) :: ftot_pn,ftot_pd
+ REAL(wp), DIMENSION(jpi,jpj) :: ftot_zmi,ftot_zme,ftot_det,ftot_dtc
+ !! use ballast scheme (1) or simple exponential scheme (0; a conservation test)
+ INTEGER :: iball
+ !! use biological fluxes (1) or not (0)
+ INTEGER :: ibio_switch
+ !!
+ !! diagnose fluxes (should only be used in 1D runs)
+ INTEGER :: idf, idfval
+ !!
+ !! nitrogen and silicon production and consumption
+ REAL(wp) :: fn_prod, fn_cons, fs_prod, fs_cons
+ REAL(wp), DIMENSION(jpi,jpj) :: fnit_prod, fnit_cons, fsil_prod, fsil_cons
+# if defined key_roam
+ !!
+ !! flags to help with calculating the position of the CCD
+ INTEGER, DIMENSION(jpi,jpj) :: i2_omcal,i2_omarg
+ !!
+ !! ROAM air-sea flux and diagnostic parameters
+ REAL(wp) :: f_wind
+ !! AXY (24/11/16): add xCO2 variable for atmosphere (what we actually have)
+ REAL(wp) :: f_xco2a
+ REAL(wp) :: f_ph, f_pco2w, f_h2co3, f_hco3, f_co3, f_co2flux
+ REAL(wp) :: f_TDIC, f_TALK, f_dcf, f_henry
+ REAL(wp) :: f_uwind, f_vwind, f_pp0
+ REAL(wp) :: f_kw660, f_o2flux, f_o2sat, f_o2sat3
+ REAL(wp), DIMENSION(jpi,jpj) :: f_omcal, f_omarg
+ !!
+ !! AXY (23/06/15): additional diagnostics for MOCSY and oxygen
+ REAL(wp) :: f_fco2w, f_BetaD, f_rhosw, f_opres, f_insitut, f_pco2atm, f_fco2atm
+ REAL(wp) :: f_schmidtco2, f_kwco2, f_K0, f_co2starair, f_dpco2, f_kwo2
+ !! jpalm 14-07-2016: convert CO2flux diag from mmol/m2/d to kg/m2/s
+ REAL, PARAMETER :: weight_CO2_mol = 44.0095 !! g / mol
+ REAL, PARAMETER :: secs_in_day = 86400.0 !! s / d
+ REAL, PARAMETER :: CO2flux_conv = (1.e-6 * weight_CO2_mol) / secs_in_day
+
+ !!
+ INTEGER :: iters
+ REAL(wp) :: f_year
+ INTEGER :: i_year
+ INTEGER :: iyr1, iyr2
+ !!
+ !! carbon, alkalinity production and consumption
+ REAL(wp) :: fc_prod, fc_cons, fa_prod, fa_cons
+ REAL(wp), DIMENSION(jpi,jpj) :: fcomm_resp
+ REAL(wp), DIMENSION(jpi,jpj) :: fcar_prod, fcar_cons
+ !!
+ !! oxygen production and consumption (and non-consumption)
+ REAL(wp) :: fo2_prod, fo2_cons, fo2_ncons, fo2_ccons
+ REAL(wp), DIMENSION(jpi,jpj) :: foxy_prod, foxy_cons, foxy_anox
+ !! Jpalm (11-08-2014)
+ !! add DMS in MEDUSA for UKESM1 model
+ REAL(wp) :: dms_surf
+ !! AXY (13/03/15): add in other DMS calculations
+ REAL(wp) :: dms_andr, dms_simo, dms_aran, dms_hall, dms_andm, dms_nlim, dms_wtkn
+
+# endif
+ !!
+ !! benthic fluxes
+ INTEGER :: ibenthic
+ REAL(wp), DIMENSION(jpi,jpj) :: f_sbenin_n, f_sbenin_fe, f_sbenin_c
+ REAL(wp), DIMENSION(jpi,jpj) :: f_fbenin_n, f_fbenin_fe, f_fbenin_si, f_fbenin_c, f_fbenin_ca
+ REAL(wp), DIMENSION(jpi,jpj) :: f_benout_n, f_benout_fe, f_benout_si, f_benout_c, f_benout_ca
+ REAL(wp) :: zfact
+ !!
+ !! benthic fluxes of CaCO3 that shouldn't happen because of lysocline
+ REAL(wp), DIMENSION(jpi,jpj) :: f_benout_lyso_ca
+ !!
+ !! riverine fluxes
+ REAL(wp), DIMENSION(jpi,jpj) :: f_runoff, f_riv_n, f_riv_si, f_riv_c, f_riv_alk
+ !! AXY (19/07/12): variables for local riverine fluxes to handle inputs below surface
+ REAL(wp) :: f_riv_loc_n, f_riv_loc_si, f_riv_loc_c, f_riv_loc_alk
+ !!
+ !! Jpalm -- 11-10-2015 -- adapt diag to iom_use
+ !! 2D var for diagnostics.
+ REAL(wp), POINTER, DIMENSION(:,: ) :: fprn2d, fdpn2d, fprd2d, fdpd2d, fprds2d, fsdiss2d, fgmipn2d
+ REAL(wp), POINTER, DIMENSION(:,: ) :: fgmid2d, fdzmi2d, fgmepn2d, fgmepd2d, fgmezmi2d, fgmed2d
+ REAL(wp), POINTER, DIMENSION(:,: ) :: fdzme2d, fslown2d, fdd2d, ffetop2d, ffebot2d, ffescav2d
+ REAL(wp), POINTER, DIMENSION(:,: ) :: fjln2d, fnln2d, ffln2d, fjld2d, fnld2d, ffld2d, fsld2d2
+ REAL(wp), POINTER, DIMENSION(:,: ) :: fsld2d, fregen2d, fregensi2d, ftempn2d, ftempsi2d, ftempfe2d
+ REAL(wp), POINTER, DIMENSION(:,: ) :: ftempc2d, ftempca2d, freminn2d, freminsi2d, freminfe2d
+ REAL(wp), POINTER, DIMENSION(:,: ) :: freminc2d, freminca2d
+ REAL(wp), POINTER, DIMENSION(:,: ) :: zw2d
+# if defined key_roam
+ REAL(wp), POINTER, DIMENSION(:,: ) :: ffastca2d, rivn2d, rivsi2d, rivc2d, rivalk2d, fslowc2d
+ REAL(wp), POINTER, DIMENSION(:,: ) :: fdpn22d, fdpd22d, fdzmi22d, fdzme22d, zimesn2d, zimesd2d
+ REAL(wp), POINTER, DIMENSION(:,: ) :: zimesc2d, zimesdc2d, ziexcr2d, ziresp2d, zigrow2d, zemesn2d
+ REAL(wp), POINTER, DIMENSION(:,: ) :: zemesd2d, zemesc2d, zemesdc2d, zeexcr2d, zeresp2d, zegrow2d
+ REAL(wp), POINTER, DIMENSION(:,: ) :: mdetc2d, gmidc2d, gmedc2d, f_pco2a2d, f_pco2w2d, f_co2flux2d
+ REAL(wp), POINTER, DIMENSION(:,: ) :: f_TDIC2d, f_TALK2d, f_kw6602d, f_pp02d, f_o2flux2d, f_o2sat2d
+ REAL(wp), POINTER, DIMENSION(:,: ) :: dms_andr2d, dms_simo2d, dms_aran2d, dms_hall2d, dms_andm2d, dms_surf2d
+ REAL(wp), POINTER, DIMENSION(:,: ) :: iben_n2d, iben_fe2d, iben_c2d, iben_si2d, iben_ca2d, oben_n2d
+ REAL(wp), POINTER, DIMENSION(:,: ) :: oben_fe2d, oben_c2d, oben_si2d, oben_ca2d, sfr_ocal2d
+ REAL(wp), POINTER, DIMENSION(:,: ) :: sfr_oarg2d, lyso_ca2d
+ !! AXY (23/11/16): extra MOCSY diagnostics
+ REAL(wp), POINTER, DIMENSION(:,: ) :: f_xco2a_2d, f_fco2w_2d, f_fco2a_2d
+ REAL(wp), POINTER, DIMENSION(:,: ) :: f_ocnrhosw_2d, f_ocnschco2_2d, f_ocnkwco2_2d
+ REAL(wp), POINTER, DIMENSION(:,: ) :: f_ocnk0_2d, f_co2starair_2d, f_ocndpco2_2d
+# endif
+ !!
+ !! 3D var for diagnostics.
+ REAL(wp), POINTER, DIMENSION(:,:,:) :: tpp3d, detflux3d, remin3dn
+ !!
+# if defined key_roam
+ !! AXY (04/11/16)
+ !! 2D var for new CMIP6 diagnostics (behind a key_roam ifdef for simplicity)
+ REAL(wp), POINTER, DIMENSION(:,: ) :: fgco2, intdissic, intdissin, intdissisi, inttalk, o2min, zo2min
+ REAL(wp), POINTER, DIMENSION(:,: ) :: fbddtalk, fbddtdic, fbddtdife, fbddtdin, fbddtdisi
+ !!
+ !! 3D var for new CMIP6 diagnostics
+ REAL(wp), POINTER, DIMENSION(:,:,:) :: tppd3
+ REAL(wp), POINTER, DIMENSION(:,:,:) :: bddtalk3, bddtdic3, bddtdife3, bddtdin3, bddtdisi3
+ REAL(wp), POINTER, DIMENSION(:,:,:) :: fd_nit3, fd_sil3, fd_car3, fd_cal3
+ REAL(wp), POINTER, DIMENSION(:,:,:) :: co33, co3satarag3, co3satcalc3, dcalc3
+ REAL(wp), POINTER, DIMENSION(:,:,:) :: expc3, expn3
+ REAL(wp), POINTER, DIMENSION(:,:,:) :: fediss3, fescav3
+ REAL(wp), POINTER, DIMENSION(:,:,:) :: migrazp3, migrazd3, megrazp3, megrazd3, megrazz3
+ REAL(wp), POINTER, DIMENSION(:,:,:) :: o2sat3, pbsi3, pcal3, remoc3
+ REAL(wp), POINTER, DIMENSION(:,:,:) :: pnlimj3, pnlimn3, pnlimfe3, pdlimj3, pdlimn3, pdlimfe3, pdlimsi3
+# endif
+ !!---------------------------------------------------------------------
+
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'trc_bio_medusa: variables defined'
+ CALL flush(numout)
+# endif
+
+ !! AXY (20/11/14): alter this to report on first MEDUSA call
+ !! IF( kt == nit000 ) THEN
+ IF( kt == nittrc000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) ' trc_bio: MEDUSA bio-model'
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~'
+ IF(lwp) WRITE(numout,*) ' kt =',kt
+ ENDIF
+
+ !! AXY (13/01/12): is benthic model properly interactive? 0 = no, 1 = yes
+ ibenthic = 1
+
+ !! not sure what this is for; it's not used anywhere; commenting out
+ !! fbodn(:,:) = 0.e0
+
+ !!
+ IF( ln_diatrc ) THEN
+ !! blank 2D diagnostic array
+ trc2d(:,:,:) = 0.e0
+ !!
+ !! blank 3D diagnostic array
+ trc3d(:,:,:,:) = 0.e0
+ ENDIF
+
+ !!----------------------------------------------------------------------
+ !! b0 is present for debugging purposes; using b0 = 0 sets the tendency
+ !! terms of all biological equations to 0.
+ !!----------------------------------------------------------------------
+ !!
+ !! AXY (03/09/14): probably not the smartest move ever, but it'll fit
+ !! the bill for now; another item on the things-to-sort-
+ !! out-in-the-future list ...
+# if defined key_kill_medusa
+ b0 = 0.
+# else
+ b0 = 1.
+# endif
+ !!----------------------------------------------------------------------
+ !! fast detritus ballast scheme (0 = no; 1 = yes)
+ !! alternative to ballast scheme is same scheme but with no ballast
+ !! protection (not dissimilar to Martin et al., 1987)
+ !!----------------------------------------------------------------------
+ !!
+ iball = 1
+
+ !!----------------------------------------------------------------------
+ !! full flux diagnostics (0 = no; 1 = yes); appear in ocean.output
+ !! these should *only* be used in 1D since they give comprehensive
+ !! output for ecological functions in the model; primarily used in
+ !! debugging
+ !!----------------------------------------------------------------------
+ !!
+ idf = 0
+ !!
+ !! timer mechanism
+ if (kt/120*120.eq.kt) then
+ idfval = 1
+ else
+ idfval = 0
+ endif
+
+ !!----------------------------------------------------------------------
+ !! blank fast-sinking detritus 2D fields
+ !!----------------------------------------------------------------------
+ !!
+ ffastn(:,:) = 0.0 !! organic nitrogen
+ ffastsi(:,:) = 0.0 !! biogenic silicon
+ ffastfe(:,:) = 0.0 !! organic iron
+ ffastc(:,:) = 0.0 !! organic carbon
+ ffastca(:,:) = 0.0 !! biogenic calcium carbonate
+ !!
+ fsedn(:,:) = 0.0 !! Seafloor flux of N
+ fsedsi(:,:) = 0.0 !! Seafloor flux of Si
+ fsedfe(:,:) = 0.0 !! Seafloor flux of Fe
+ fsedc(:,:) = 0.0 !! Seafloor flux of C
+ fsedca(:,:) = 0.0 !! Seafloor flux of CaCO3
+ !!
+ fregenfast(:,:) = 0.0 !! integrated N regeneration (fast detritus)
+ fregenfastsi(:,:) = 0.0 !! integrated Si regeneration (fast detritus)
+# if defined key_roam
+ fregenfastc(:,:) = 0.0 !! integrated C regeneration (fast detritus)
+# endif
+ !!
+ fccd(:,:) = 0.0 !! last depth level before CCD
+
+ !!----------------------------------------------------------------------
+ !! blank nutrient/flux inventories
+ !!----------------------------------------------------------------------
+ !!
+ fflx_n(:,:) = 0.0 !! nitrogen flux total
+ fflx_si(:,:) = 0.0 !! silicon flux total
+ fflx_fe(:,:) = 0.0 !! iron flux total
+ fifd_n(:,:) = 0.0 !! nitrogen fast detritus production
+ fifd_si(:,:) = 0.0 !! silicon fast detritus production
+ fifd_fe(:,:) = 0.0 !! iron fast detritus production
+ fofd_n(:,:) = 0.0 !! nitrogen fast detritus remineralisation
+ fofd_si(:,:) = 0.0 !! silicon fast detritus remineralisation
+ fofd_fe(:,:) = 0.0 !! iron fast detritus remineralisation
+# if defined key_roam
+ fflx_c(:,:) = 0.0 !! carbon flux total
+ fflx_a(:,:) = 0.0 !! alkalinity flux total
+ fflx_o2(:,:) = 0.0 !! oxygen flux total
+ ftot_c(:,:) = 0.0 !! carbon inventory
+ ftot_a(:,:) = 0.0 !! alkalinity inventory
+ ftot_o2(:,:) = 0.0 !! oxygen inventory
+ fifd_c(:,:) = 0.0 !! carbon fast detritus production
+ fifd_a(:,:) = 0.0 !! alkalinity fast detritus production
+ fifd_o2(:,:) = 0.0 !! oxygen fast detritus production
+ fofd_c(:,:) = 0.0 !! carbon fast detritus remineralisation
+ fofd_a(:,:) = 0.0 !! alkalinity fast detritus remineralisation
+ fofd_o2(:,:) = 0.0 !! oxygen fast detritus remineralisation
+ !!
+ fnit_prod(:,:) = 0.0 !! (organic) nitrogen production
+ fnit_cons(:,:) = 0.0 !! (organic) nitrogen consumption
+ fsil_prod(:,:) = 0.0 !! (inorganic) silicon production
+ fsil_cons(:,:) = 0.0 !! (inorganic) silicon consumption
+ fcar_prod(:,:) = 0.0 !! (organic) carbon production
+ fcar_cons(:,:) = 0.0 !! (organic) carbon consumption
+ !!
+ foxy_prod(:,:) = 0.0 !! oxygen production
+ foxy_cons(:,:) = 0.0 !! oxygen consumption
+ foxy_anox(:,:) = 0.0 !! unrealised oxygen consumption
+ !!
+# endif
+ ftot_n(:,:) = 0.0 !! N inventory
+ ftot_si(:,:) = 0.0 !! Si inventory
+ ftot_fe(:,:) = 0.0 !! Fe inventory
+ ftot_pn(:,:) = 0.0 !! integrated non-diatom phytoplankton
+ ftot_pd(:,:) = 0.0 !! integrated diatom phytoplankton
+ ftot_zmi(:,:) = 0.0 !! integrated microzooplankton
+ ftot_zme(:,:) = 0.0 !! integrated mesozooplankton
+ ftot_det(:,:) = 0.0 !! integrated slow detritus, nitrogen
+ ftot_dtc(:,:) = 0.0 !! integrated slow detritus, carbon
+ !!
+ fzmi_i(:,:) = 0.0 !! material grazed by microzooplankton
+ fzmi_o(:,:) = 0.0 !! ... sum of fate of this material
+ fzme_i(:,:) = 0.0 !! material grazed by mesozooplankton
+ fzme_o(:,:) = 0.0 !! ... sum of fate of this material
+ !!
+ f_sbenin_n(:,:) = 0.0 !! slow detritus N -> benthic pool
+ f_sbenin_fe(:,:) = 0.0 !! slow detritus Fe -> benthic pool
+ f_sbenin_c(:,:) = 0.0 !! slow detritus C -> benthic pool
+ f_fbenin_n(:,:) = 0.0 !! fast detritus N -> benthic pool
+ f_fbenin_fe(:,:) = 0.0 !! fast detritus Fe -> benthic pool
+ f_fbenin_si(:,:) = 0.0 !! fast detritus Si -> benthic pool
+ f_fbenin_c(:,:) = 0.0 !! fast detritus C -> benthic pool
+ f_fbenin_ca(:,:) = 0.0 !! fast detritus Ca -> benthic pool
+ !!
+ f_benout_n(:,:) = 0.0 !! benthic N pool -> dissolved
+ f_benout_fe(:,:) = 0.0 !! benthic Fe pool -> dissolved
+ f_benout_si(:,:) = 0.0 !! benthic Si pool -> dissolved
+ f_benout_c(:,:) = 0.0 !! benthic C pool -> dissolved
+ f_benout_ca(:,:) = 0.0 !! benthic Ca pool -> dissolved
+ !!
+ f_benout_lyso_ca(:,:) = 0.0 !! benthic Ca pool -> dissolved (when it shouldn't!)
+ !!
+ f_runoff(:,:) = 0.0 !! riverine runoff
+ f_riv_n(:,:) = 0.0 !! riverine N input
+ f_riv_si(:,:) = 0.0 !! riverine Si input
+ f_riv_c(:,:) = 0.0 !! riverine C input
+ f_riv_alk(:,:) = 0.0 !! riverine alk input
+ !!
+ !! Jpalm -- 06-03-2017 -- Forgotten var to init
+ f_omarg(:,:) = 0.0 !!
+ f_omcal(:,:) = 0.0
+ xFree(:,:) = 0.0 !! state variables for iron-ligand system
+ fcomm_resp(:,:) = 0.0
+ fprn_ml(:,:) = 0.0 !! mixed layer PP diagnostics
+ fprd_ml(:,:) = 0.0 !! mixed layer PP diagnostics
+ !!
+ fslownflux(:,:) = 0.0
+ fslowcflux(:,:) = 0.0
+
+ !!
+ !! allocate and initiate 2D diag
+ !! -----------------------------
+ !! Juju :: add kt condition !!
+ IF ( lk_iomput .AND. .NOT. ln_diatrc ) THEN
+ !!
+ if ( kt == nittrc000 ) CALL trc_nam_iom_medusa !! initialise iom_use test
+ !!
+ CALL wrk_alloc( jpi, jpj, zw2d )
+ zw2d(:,:) = 0.0 !!
+ IF ( med_diag%PRN%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fprn2d )
+ fprn2d(:,:) = 0.0 !!
+ ENDIF
+ IF ( med_diag%MPN%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fdpn2d )
+ fdpn2d(:,:) = 0.0 !!
+ ENDIF
+ IF ( med_diag%PRD%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fprd2d )
+ fprd2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%MPD%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fdpd2d )
+ fdpd2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%OPAL%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fprds2d )
+ fprds2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%OPALDISS%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fsdiss2d )
+ fsdiss2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%GMIPn%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fgmipn2d )
+ fgmipn2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%GMID%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fgmid2d )
+ fgmid2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%MZMI%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fdzmi2d )
+ fdzmi2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%GMEPN%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fgmepn2d )
+ fgmepn2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%GMEPD%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fgmepd2d )
+ fgmepd2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%GMEZMI%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fgmezmi2d )
+ fgmezmi2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%GMED%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fgmed2d )
+ fgmed2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%MZME%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fdzme2d )
+ fdzme2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%DETN%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fslown2d )
+ fslown2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%MDET%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fdd2d )
+ fdd2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%AEOLIAN%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, ffetop2d )
+ ffetop2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%BENTHIC%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, ffebot2d )
+ ffebot2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%SCAVENGE%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, ffescav2d )
+ ffescav2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%PN_JLIM%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fjln2d )
+ fjln2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%PN_NLIM%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fnln2d )
+ fnln2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%PN_FELIM%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, ffln2d )
+ ffln2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%PD_JLIM%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fjld2d )
+ fjld2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%PD_NLIM%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fnld2d )
+ fnld2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%PD_FELIM%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, ffld2d )
+ ffld2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%PD_SILIM%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fsld2d2 )
+ fsld2d2(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%PDSILIM2%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fsld2d )
+ fsld2d(:,:) = 0.0 !!
+ ENDIF
+!!
+!! skip SDT_XXXX diagnostics here
+!!
+ IF( med_diag%TOTREG_N%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fregen2d )
+ fregen2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%TOTRG_SI%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fregensi2d )
+ fregensi2d(:,:) = 0.0 !!
+ ENDIF
+!!
+!! skip REG_XXXX diagnostics here
+!!
+ IF( med_diag%FASTN%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, ftempn2d )
+ ftempn2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%FASTSI%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, ftempsi2d )
+ ftempsi2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%FASTFE%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, ftempfe2d )
+ ftempfe2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%FASTC%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, ftempc2d )
+ ftempc2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%FASTCA%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, ftempca2d )
+ ftempca2d(:,:) = 0.0 !!
+ ENDIF
+!!
+!! skip FDT_XXXX, RG_XXXXF, FDS_XXXX, RGS_XXXXF diagnostics here
+!!
+ IF( med_diag%REMINN%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, freminn2d )
+ freminn2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%REMINSI%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, freminsi2d )
+ freminsi2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%REMINFE%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, freminfe2d )
+ freminfe2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%REMINC%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, freminc2d )
+ freminc2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%REMINCA%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, freminca2d )
+ freminca2d(:,:) = 0.0 !!
+ ENDIF
+# if defined key_roam
+!!
+!! skip SEAFLRXX, MED_XXXX, INTFLX_XX, INT_XX, ML_XXX, OCAL_XXX, FE_XXXX, MED_XZE, WIND diagnostics here
+!!
+ IF( med_diag%RR_0100%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, ffastca2d )
+ ffastca2d(:,:) = 0.0 !!
+ ENDIF
+
+ IF( med_diag%ATM_PCO2%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_pco2a2d )
+ f_pco2a2d(:,:) = 0.0 !!
+ ENDIF
+!!
+!! skip OCN_PH diagnostic here
+!!
+ IF( med_diag%OCN_PCO2%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_pco2w2d )
+ f_pco2w2d(:,:) = 0.0 !!
+ ENDIF
+!!
+!! skip OCNH2CO3, OCN_HCO3, OCN_CO3 diagnostics here
+!!
+ IF( med_diag%CO2FLUX%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_co2flux2d )
+ f_co2flux2d(:,:) = 0.0 !!
+ ENDIF
+!!
+!! skip OM_XXX diagnostics here
+!!
+ IF( med_diag%TCO2%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_TDIC2d )
+ f_TDIC2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%TALK%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_TALK2d )
+ f_TALK2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%KW660%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_kw6602d )
+ f_kw6602d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ATM_PP0%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_pp02d )
+ f_pp02d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%O2FLUX%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_o2flux2d )
+ f_o2flux2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%O2SAT%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_o2sat2d )
+ f_o2sat2d(:,:) = 0.0 !!
+ ENDIF
+!!
+!! skip XXX_CCD diagnostics here
+!!
+ IF( med_diag%SFR_OCAL%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, sfr_ocal2d )
+ sfr_ocal2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%SFR_OARG%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, sfr_oarg2d )
+ sfr_oarg2d(:,:) = 0.0 !!
+ ENDIF
+!!
+!! skip XX_PROD, XX_CONS, O2_ANOX, RR_XXXX diagnostics here
+!!
+ IF( med_diag%IBEN_N%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, iben_n2d )
+ iben_n2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%IBEN_FE%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, iben_fe2d )
+ iben_fe2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%IBEN_C%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, iben_c2d )
+ iben_c2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%IBEN_SI%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, iben_si2d )
+ iben_si2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%IBEN_CA%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, iben_ca2d )
+ iben_ca2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%OBEN_N%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, oben_n2d )
+ oben_n2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%OBEN_FE%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, oben_fe2d )
+ oben_fe2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%OBEN_C%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, oben_c2d )
+ oben_c2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%OBEN_SI%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, oben_si2d )
+ oben_si2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%OBEN_CA%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, oben_ca2d )
+ oben_ca2d(:,:) = 0.0 !!
+ ENDIF
+!!
+!! skip BEN_XX diagnostics here
+!!
+ IF( med_diag%RIV_N%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, rivn2d )
+ rivn2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%RIV_SI%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, rivsi2d )
+ rivsi2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%RIV_C%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, rivc2d )
+ rivc2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%RIV_ALK%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, rivalk2d )
+ rivalk2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%DETC%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fslowc2d )
+ fslowc2d(:,:) = 0.0 !!
+ ENDIF
+!!
+!! skip SDC_XXXX, INVTXXX diagnostics here
+!!
+ IF( med_diag%LYSO_CA%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, lyso_ca2d )
+ lyso_ca2d(:,:) = 0.0 !!
+ ENDIF
+!!
+!! skip COM_RESP diagnostic here
+!!
+ IF( med_diag%PN_LLOSS%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fdpn22d )
+ fdpn22d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%PD_LLOSS%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fdpd22d )
+ fdpd22d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ZI_LLOSS%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fdzmi22d )
+ fdzmi22d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ZE_LLOSS%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fdzme22d )
+ fdzme22d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ZI_MES_N%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, zimesn2d )
+ zimesn2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ZI_MES_D%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, zimesd2d )
+ zimesd2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ZI_MES_C%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, zimesc2d )
+ zimesc2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ZI_MESDC%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, zimesdc2d )
+ zimesdc2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ZI_EXCR%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, ziexcr2d )
+ ziexcr2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ZI_RESP%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, ziresp2d )
+ ziresp2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ZI_GROW%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, zigrow2d )
+ zigrow2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ZE_MES_N%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, zemesn2d )
+ zemesn2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ZE_MES_D%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, zemesd2d )
+ zemesd2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ZE_MES_C%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, zemesc2d )
+ zemesc2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ZE_MESDC%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, zemesdc2d )
+ zemesdc2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ZE_EXCR%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, zeexcr2d )
+ zeexcr2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ZE_RESP%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, zeresp2d )
+ zeresp2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ZE_GROW%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, zegrow2d )
+ zegrow2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%MDETC%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, mdetc2d )
+ mdetc2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%GMIDC%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, gmidc2d )
+ gmidc2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%GMEDC%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, gmedc2d )
+ gmedc2d(:,:) = 0.0 !!
+ ENDIF
+!!
+!! skip INT_XXX diagnostics here
+!!
+ IF (jdms .eq. 1) THEN
+ IF( med_diag%DMS_SURF%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, dms_surf2d )
+ dms_surf2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%DMS_ANDR%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, dms_andr2d )
+ dms_andr2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%DMS_SIMO%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, dms_simo2d )
+ dms_simo2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%DMS_ARAN%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, dms_aran2d )
+ dms_aran2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%DMS_HALL%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, dms_hall2d )
+ dms_hall2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%DMS_ANDM%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, dms_andm2d )
+ dms_andm2d(:,:) = 0.0 !!
+ ENDIF
+ ENDIF
+ !!
+ !! AXY (24/11/16): extra MOCSY diagnostics, 2D
+ IF( med_diag%ATM_XCO2%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_xco2a_2d )
+ f_xco2a_2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%OCN_FCO2%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_fco2w_2d )
+ f_fco2w_2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%ATM_FCO2%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_fco2a_2d )
+ f_fco2a_2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%OCN_RHOSW%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_ocnrhosw_2d )
+ f_ocnrhosw_2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%OCN_SCHCO2%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_ocnschco2_2d )
+ f_ocnschco2_2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%OCN_KWCO2%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_ocnkwco2_2d )
+ f_ocnkwco2_2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%OCN_K0%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_ocnk0_2d )
+ f_ocnk0_2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%CO2STARAIR%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_co2starair_2d )
+ f_co2starair_2d(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%OCN_DPCO2%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, f_ocndpco2_2d )
+ f_ocndpco2_2d(:,:) = 0.0 !!
+ ENDIF
+# endif
+ IF( med_diag%TPP3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, tpp3d )
+ tpp3d(:,:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%DETFLUX3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, detflux3d )
+ detflux3d(:,:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%REMIN3N%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, remin3dn )
+ remin3dn(:,:,:) = 0.0 !!
+ ENDIF
+ !!
+ !! AXY (10/11/16): CMIP6 diagnostics, 2D
+ !! JPALM -- 17-11-16 -- put fgco2 alloc out of diag request
+ !! needed for coupling/passed through restart
+ !! IF( med_diag%FGCO2%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fgco2 )
+ fgco2(:,:) = 0.0 !!
+ !! ENDIF
+ IF( med_diag%INTDISSIC%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, intdissic )
+ intdissic(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%INTDISSIN%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, intdissin )
+ intdissin(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%INTDISSISI%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, intdissisi )
+ intdissisi(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%INTTALK%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, inttalk )
+ inttalk(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%O2min%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, o2min )
+ o2min(:,:) = 1.e3 !! set to high value as we're looking for min(o2)
+ ENDIF
+ IF( med_diag%ZO2min%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, zo2min )
+ zo2min(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%FBDDTALK%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fbddtalk )
+ fbddtalk(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%FBDDTDIC%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fbddtdic )
+ fbddtdic(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%FBDDTDIFE%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fbddtdife )
+ fbddtdife(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%FBDDTDIN%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fbddtdin )
+ fbddtdin(:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%FBDDTDISI%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, fbddtdisi )
+ fbddtdisi(:,:) = 0.0 !!
+ ENDIF
+ !!
+ !! AXY (10/11/16): CMIP6 diagnostics, 3D
+ IF( med_diag%TPPD3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, tppd3 )
+ tppd3(:,:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%BDDTALK3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, bddtalk3 )
+ bddtalk3(:,:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%BDDTDIC3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, bddtdic3 )
+ bddtdic3(:,:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%BDDTDIFE3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, bddtdife3 )
+ bddtdife3(:,:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%BDDTDIN3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, bddtdin3 )
+ bddtdin3(:,:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%BDDTDISI3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, bddtdisi3 )
+ bddtdisi3(:,:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%FD_NIT3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, fd_nit3 )
+ fd_nit3(:,:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%FD_SIL3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, fd_sil3 )
+ fd_sil3(:,:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%FD_CAR3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, fd_car3 )
+ fd_car3(:,:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%FD_CAL3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, fd_cal3 )
+ fd_cal3(:,:,:) = 0.0 !!
+ ENDIF
+ IF( med_diag%DCALC3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, dcalc3 )
+ dcalc3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%EXPC3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, expc3 )
+ expc3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%EXPN3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, expn3 )
+ expn3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%FEDISS3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, fediss3 )
+ fediss3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%FESCAV3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, fescav3 )
+ fescav3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%MIGRAZP3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, migrazp3 )
+ migrazp3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%MIGRAZD3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, migrazd3 )
+ migrazd3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%MEGRAZP3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, megrazp3 )
+ megrazp3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%MEGRAZD3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, megrazd3 )
+ megrazd3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%MEGRAZZ3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, megrazz3 )
+ megrazz3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%O2SAT3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, o2sat3 )
+ o2sat3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%PBSI3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, pbsi3 )
+ pbsi3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%PCAL3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, pcal3 )
+ pcal3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%REMOC3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, remoc3 )
+ remoc3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%PNLIMJ3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, pnlimj3 )
+ pnlimj3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%PNLIMN3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, pnlimn3 )
+ pnlimn3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%PNLIMFE3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, pnlimfe3 )
+ pnlimfe3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%PDLIMJ3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, pdlimj3 )
+ pdlimj3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%PDLIMN3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, pdlimn3 )
+ pdlimn3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%PDLIMFE3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, pdlimfe3 )
+ pdlimfe3(:,:,: ) = 0.0 !!
+ ENDIF
+ IF( med_diag%PDLIMSI3%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, jpk, pdlimsi3 )
+ pdlimsi3(:,:,: ) = 0.0 !!
+ ENDIF
+
+ ENDIF
+ !! lk_iomput
+ !!
+# if defined key_axy_nancheck
+ DO jn = 1,jptra
+ !! fq0 = MINVAL(trn(:,:,:,jn))
+ !! fq1 = MAXVAL(trn(:,:,:,jn))
+ fq2 = SUM(trn(:,:,:,jn))
+ !! if (lwp) write (numout,'(a,2i6,3(1x,1pe15.5))') 'NAN-CHECK', &
+ !! & kt, jn, fq0, fq1, fq2
+ !! AXY (30/01/14): much to our surprise, the next line doesn't work on HECTOR
+ !! and has been replaced here with a specialist routine
+ !! if (fq2 /= fq2 ) then
+ if ( ieee_is_nan( fq2 ) ) then
+ !! there's a NaN here
+ if (lwp) write(numout,*) 'NAN detected in field', jn, 'at time', kt, 'at position:'
+ DO jk = 1,jpk
+ DO jj = 1,jpj
+ DO ji = 1,jpi
+ !! AXY (30/01/14): "isnan" problem on HECTOR
+ !! if (trn(ji,jj,jk,jn) /= trn(ji,jj,jk,jn)) then
+ if ( ieee_is_nan( trn(ji,jj,jk,jn) ) ) then
+ if (lwp) write (numout,'(a,1pe12.2,4i6)') 'NAN-CHECK', &
+ & tmask(ji,jj,jk), ji, jj, jk, jn
+ endif
+ enddo
+ enddo
+ enddo
+ CALL ctl_stop( 'trcbio_medusa, NAN in incoming tracer field' )
+ endif
+ ENDDO
+ CALL flush(numout)
+# endif
+
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'trc_bio_medusa: variables initialised and checked'
+ CALL flush(numout)
+# endif
+
+# if defined key_roam
+ !!----------------------------------------------------------------------
+ !! calculate atmospheric pCO2
+ !!----------------------------------------------------------------------
+ !!
+ !! what's atmospheric pCO2 doing? (data start in 1859)
+ iyr1 = nyear - 1859 + 1
+ iyr2 = iyr1 + 1
+ if (iyr1 .le. 1) then
+ !! before 1860
+ f_xco2a = hist_pco2(1)
+ elseif (iyr2 .ge. 242) then
+ !! after 2099
+ f_xco2a = hist_pco2(242)
+ else
+ !! just right
+ fq0 = hist_pco2(iyr1)
+ fq1 = hist_pco2(iyr2)
+ fq2 = real(nsec_day) / (60.0 * 60.0 * 24.0)
+ !! AXY (14/06/12): tweaked to make more sense (and be correct)
+# if defined key_bs_axy_yrlen
+ fq3 = (real(nday_year) - 1.0 + fq2) / 360.0 !! bugfix: for 360d year with HadGEM2-ES forcing
+# else
+ fq3 = (real(nday_year) - 1.0 + fq2) / 365.0 !! original use of 365 days (not accounting for leap year or 360d year)
+# endif
+ fq4 = (fq0 * (1.0 - fq3)) + (fq1 * fq3)
+ f_xco2a = fq4
+ endif
+# if defined key_axy_pi_co2
+ f_xco2a = 284.725 !! OCMIP pre-industrial pCO2
+# endif
+ !! IF(lwp) WRITE(numout,*) ' MEDUSA nyear =', nyear
+ !! IF(lwp) WRITE(numout,*) ' MEDUSA nsec_day =', real(nsec_day)
+ !! IF(lwp) WRITE(numout,*) ' MEDUSA nday_year =', real(nday_year)
+ !! AXY (29/01/14): remove surplus diagnostics
+ !! IF(lwp) WRITE(numout,*) ' MEDUSA fq0 =', fq0
+ !! IF(lwp) WRITE(numout,*) ' MEDUSA fq1 =', fq1
+ !! IF(lwp) WRITE(numout,*) ' MEDUSA fq2 =', fq2
+ !! IF(lwp) WRITE(numout,*) ' MEDUSA fq3 =', fq3
+ IF(lwp) WRITE(numout,*) ' MEDUSA atm pCO2 =', f_xco2a
+# endif
+
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'trc_bio_medusa: ready for carbonate chemistry'
+ IF (lwp) write (numout,*) 'trc_bio_medusa: kt = ', kt
+ IF (lwp) write (numout,*) 'trc_bio_medusa: nittrc000 = ', nittrc000
+ CALL flush(numout)
+# endif
+
+# if defined key_roam
+ !! AXY (20/11/14): alter to call on first MEDUSA timestep and then every
+ !! month (this is hardwired as 960 timesteps but should
+ !! be calculated and done properly
+ !! IF( kt == nit000 .or. mod(kt,1920) == 0 ) THEN
+ !! IF( kt == nittrc000 .or. mod(kt,960) == 0 ) THEN
+ !!=============================
+ !! Jpalm -- 07-10-2016 -- need to change carb-chem frequency call :
+ !! we don't want to call on the first time-step of all run submission,
+ !! but only on the very first time-step, and then every month
+ !! So we call on nittrc000 if not restarted run,
+ !! else if one month after last call.
+ !! assume one month is 30d --> 3600*24*30 : 2592000s
+ !! try to call carb-chem at 1st month's tm-stp : x * 30d + 1*rdt(i.e: mod = rdt)
+ !! ++ need to pass carb-chem output var through restarts
+ If ( ( kt == nittrc000 .AND. .NOT.ln_rsttr ) .OR. mod(kt*rdt,2592000.) == rdt ) THEN
+ !!----------------------------------------------------------------------
+ !! Calculate the carbonate chemistry for the whole ocean on the first
+ !! simulation timestep and every month subsequently; the resulting 3D
+ !! field of omega calcite is used to determine the depth of the CCD
+ !!----------------------------------------------------------------------
+ !!
+ IF(lwp) WRITE(numout,*) ' MEDUSA calculating all carbonate chemistry at kt =', kt
+ CALL flush(numout)
+ !! blank flags
+ i2_omcal(:,:) = 0
+ i2_omarg(:,:) = 0
+ !! loop over 3D space
+ DO jk = 1,jpk
+ DO jj = 2,jpjm1
+ DO ji = 2,jpim1
+ !! OPEN wet point IF..THEN loop
+ if (tmask(ji,jj,jk).eq.1) then
+ IF (lk_oasis) THEN
+ f_xco2a = PCO2a_in_cpl(ji,jj) !! use 2D atm xCO2 from atm coupling
+ ENDIF
+ !! do carbonate chemistry
+ !!
+ fdep2 = fsdept(ji,jj,jk) !! set up level midpoint
+ !! AXY (28/11/16): local seafloor depth
+ !! previously mbathy(ji,jj) - 1, now mbathy(ji,jj)
+ jmbathy = mbathy(ji,jj)
+ !!
+ !! set up required state variables
+ zdic = max(0.,trn(ji,jj,jk,jpdic)) !! dissolved inorganic carbon
+ zalk = max(0.,trn(ji,jj,jk,jpalk)) !! alkalinity
+ ztmp = tsn(ji,jj,jk,jp_tem) !! temperature
+ zsal = tsn(ji,jj,jk,jp_sal) !! salinity
+# if defined key_mocsy
+ zsil = max(0.,trn(ji,jj,jk,jpsil)) !! silicic acid
+ zpho = max(0.,trn(ji,jj,jk,jpdin)) / 16.0 !! phosphate via DIN and Redfield
+# endif
+ !!
+ !! AXY (28/02/14): check input fields
+ if (ztmp .lt. -3.0 .or. ztmp .gt. 40.0 ) then
+ IF(lwp) WRITE(numout,*) ' trc_bio_medusa: T WARNING 3D, ', &
+ tsb(ji,jj,jk,jp_tem), tsn(ji,jj,jk,jp_tem), ' at (', &
+ ji, ',', jj, ',', jk, ') at time', kt
+ IF(lwp) WRITE(numout,*) ' trc_bio_medusa: T SWITCHING 3D, ', &
+ tsn(ji,jj,jk,jp_tem), ' -> ', tsb(ji,jj,jk,jp_tem)
+ ztmp = tsb(ji,jj,jk,jp_tem) !! temperature
+ endif
+ if (zsal .lt. 0.0 .or. zsal .gt. 45.0 ) then
+ IF(lwp) WRITE(numout,*) ' trc_bio_medusa: S WARNING 3D, ', &
+ tsb(ji,jj,jk,jp_sal), tsn(ji,jj,jk,jp_sal), ' at (', &
+ ji, ',', jj, ',', jk, ') at time', kt
+ endif
+ !!
+ !! blank input variables not used at this stage (they relate to air-sea flux)
+ f_kw660 = 1.0
+ f_pp0 = 1.0
+ !!
+ !! calculate carbonate chemistry at grid cell midpoint
+# if defined key_mocsy
+ !! AXY (22/06/15): use Orr & Epitalon (2015) MOCSY-2 carbonate
+ !! chemistry package
+ CALL mocsy_interface( ztmp, zsal, zalk, zdic, zsil, zpho, & ! inputs
+ f_pp0, fdep2, gphit(ji,jj), f_kw660, f_xco2a, 1, & ! inputs
+ f_ph, f_pco2w, f_fco2w, f_h2co3, f_hco3, f_co3, f_omarg(ji,jj), & ! outputs
+ f_omcal(ji,jj), f_BetaD, f_rhosw, f_opres, f_insitut, & ! outputs
+ f_pco2atm, f_fco2atm, f_schmidtco2, f_kwco2, f_K0, & ! outputs
+ f_co2starair, f_co2flux, f_dpco2 ) ! outputs
+ !!
+ f_TDIC = (zdic / f_rhosw) * 1000. ! mmol / m3 -> umol / kg
+ f_TALK = (zalk / f_rhosw) * 1000. ! meq / m3 -> ueq / kg
+ f_dcf = f_rhosw
+# else
+ !! AXY (22/06/15): use old PML carbonate chemistry package (the
+ !! MEDUSA-2 default)
+ CALL trc_co2_medusa( ztmp, zsal, zdic, zalk, fdep2, f_kw660, & ! inputs
+ f_xco2a, f_ph, f_pco2w, f_h2co3, f_hco3, f_co3, f_omcal(ji,jj), & ! outputs
+ f_omarg(ji,jj), f_co2flux, f_TDIC, f_TALK, f_dcf, f_henry, iters) ! outputs
+ !!
+ !! AXY (28/02/14): check output fields
+ if (iters .eq. 25) then
+ IF(lwp) WRITE(numout,*) ' trc_bio_medusa: 3D ITERS WARNING, ', &
+ iters, ' AT (', ji, ', ', jj, ', ', jk, ') AT ', kt
+ endif
+# endif
+ !!
+ !! store 3D outputs
+ f3_pH(ji,jj,jk) = f_ph
+ f3_h2co3(ji,jj,jk) = f_h2co3
+ f3_hco3(ji,jj,jk) = f_hco3
+ f3_co3(ji,jj,jk) = f_co3
+ f3_omcal(ji,jj,jk) = f_omcal(ji,jj)
+ f3_omarg(ji,jj,jk) = f_omarg(ji,jj)
+ !!
+ !! CCD calculation: calcite
+ if (i2_omcal(ji,jj) .eq. 0 .and. f_omcal(ji,jj) .lt. 1.0) then
+ if (jk .eq. 1) then
+ f2_ccd_cal(ji,jj) = fdep2
+ else
+ fq0 = f3_omcal(ji,jj,jk-1) - f_omcal(ji,jj)
+ fq1 = f3_omcal(ji,jj,jk-1) - 1.0
+ fq2 = fq1 / (fq0 + tiny(fq0))
+ fq3 = fdep2 - fsdept(ji,jj,jk-1)
+ fq4 = fq2 * fq3
+ f2_ccd_cal(ji,jj) = fsdept(ji,jj,jk-1) + fq4
+ endif
+ i2_omcal(ji,jj) = 1
+ endif
+ if ( i2_omcal(ji,jj) .eq. 0 .and. jk .eq. jmbathy ) then
+ !! reached seafloor and still no dissolution; set to seafloor (W-point)
+ f2_ccd_cal(ji,jj) = fsdepw(ji,jj,jk+1)
+ i2_omcal(ji,jj) = 1
+ endif
+ !!
+ !! CCD calculation: aragonite
+ if (i2_omarg(ji,jj) .eq. 0 .and. f_omarg(ji,jj) .lt. 1.0) then
+ if (jk .eq. 1) then
+ f2_ccd_arg(ji,jj) = fdep2
+ else
+ fq0 = f3_omarg(ji,jj,jk-1) - f_omarg(ji,jj)
+ fq1 = f3_omarg(ji,jj,jk-1) - 1.0
+ fq2 = fq1 / (fq0 + tiny(fq0))
+ fq3 = fdep2 - fsdept(ji,jj,jk-1)
+ fq4 = fq2 * fq3
+ f2_ccd_arg(ji,jj) = fsdept(ji,jj,jk-1) + fq4
+ endif
+ i2_omarg(ji,jj) = 1
+ endif
+ if ( i2_omarg(ji,jj) .eq. 0 .and. jk .eq. jmbathy ) then
+ !! reached seafloor and still no dissolution; set to seafloor (W-point)
+ f2_ccd_arg(ji,jj) = fsdepw(ji,jj,jk+1)
+ i2_omarg(ji,jj) = 1
+ endif
+ endif
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+# endif
+
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'trc_bio_medusa: ready for full domain calculations'
+ CALL flush(numout)
+# endif
+
+ !!----------------------------------------------------------------------
+ !! MEDUSA has unified equation through the water column
+ !! (Diff. from LOBSTER which has two sets: bio- and non-bio layers)
+ !! Statement below in LOBSTER is different: DO jk = 1, jpkbm1
+ !!----------------------------------------------------------------------
+ !!
+ !! NOTE: the ordering of the loops below differs from that of some other
+ !! models; looping over the vertical dimension is the outermost loop and
+ !! this complicates some calculations (e.g. storage of vertical fluxes
+ !! that can otherwise be done via a singular variable require 2D fields
+ !! here); however, these issues are relatively easily resolved, but the
+ !! loops CANNOT be reordered without potentially causing code efficiency
+ !! problems (e.g. array indexing means that reordering the loops would
+ !! require skipping between widely-spaced memory location; potentially
+ !! outside those immediately cached)
+ !!
+ !! OPEN vertical loop
+ DO jk = 1,jpk
+ !! OPEN horizontal loops
+ DO jj = 2,jpjm1
+ DO ji = 2,jpim1
+ !! OPEN wet point IF..THEN loop
+ if (tmask(ji,jj,jk).eq.1) then
+ !!======================================================================
+ !! SETUP LOCAL GRID CELL
+ !!======================================================================
+ !!
+ !!---------------------------------------------------------------------
+ !! Some notes on grid vertical structure
+ !! - fsdepw(ji,jj,jk) is the depth of the upper surface of level jk
+ !! - fsde3w(ji,jj,jk) is *approximately* the midpoint of level jk
+ !! - fse3t(ji,jj,jk) is the thickness of level jk
+ !!---------------------------------------------------------------------
+ !!
+ !! AXY (11/12/08): set up level thickness
+ fthk = fse3t(ji,jj,jk)
+ !! AXY (25/02/10): set up level depth (top of level)
+ fdep = fsdepw(ji,jj,jk)
+ !! AXY (01/03/10): set up level depth (bottom of level)
+ fdep1 = fdep + fthk
+ !! AXY (28/11/16): local seafloor depth
+ !! previously mbathy(ji,jj) - 1, now mbathy(ji,jj)
+ jmbathy = mbathy(ji,jj)
+ !!
+ !! set up model tracers
+ !! negative values of state variables are not allowed to
+ !! contribute to the calculated fluxes
+ zchn = max(0.,trn(ji,jj,jk,jpchn)) !! non-diatom chlorophyll
+ zchd = max(0.,trn(ji,jj,jk,jpchd)) !! diatom chlorophyll
+ zphn = max(0.,trn(ji,jj,jk,jpphn)) !! non-diatoms
+ zphd = max(0.,trn(ji,jj,jk,jpphd)) !! diatoms
+ zpds = max(0.,trn(ji,jj,jk,jppds)) !! diatom silicon
+ !! AXY (28/01/10): probably need to take account of chl/biomass connection
+ if (zchn.eq.0.) zphn = 0.
+ if (zchd.eq.0.) zphd = 0.
+ if (zphn.eq.0.) zchn = 0.
+ if (zphd.eq.0.) zchd = 0.
+ !! AXY (23/01/14): duh - why did I forget diatom silicon?
+ if (zpds.eq.0.) zphd = 0.
+ if (zphd.eq.0.) zpds = 0.
+ zzmi = max(0.,trn(ji,jj,jk,jpzmi)) !! microzooplankton
+ zzme = max(0.,trn(ji,jj,jk,jpzme)) !! mesozooplankton
+ zdet = max(0.,trn(ji,jj,jk,jpdet)) !! detrital nitrogen
+ zdin = max(0.,trn(ji,jj,jk,jpdin)) !! dissolved inorganic nitrogen
+ zsil = max(0.,trn(ji,jj,jk,jpsil)) !! dissolved silicic acid
+ zfer = max(0.,trn(ji,jj,jk,jpfer)) !! dissolved "iron"
+# if defined key_roam
+ zdtc = max(0.,trn(ji,jj,jk,jpdtc)) !! detrital carbon
+ zdic = max(0.,trn(ji,jj,jk,jpdic)) !! dissolved inorganic carbon
+ zalk = max(0.,trn(ji,jj,jk,jpalk)) !! alkalinity
+ zoxy = max(0.,trn(ji,jj,jk,jpoxy)) !! oxygen
+# if defined key_axy_carbchem && defined key_mocsy
+ zpho = max(0.,trn(ji,jj,jk,jpdin)) / 16.0 !! phosphate via DIN and Redfield
+# endif
+ !!
+ !! also need physical parameters for gas exchange calculations
+ ztmp = tsn(ji,jj,jk,jp_tem)
+ zsal = tsn(ji,jj,jk,jp_sal)
+ !!
+ !! AXY (28/02/14): check input fields
+ if (ztmp .lt. -3.0 .or. ztmp .gt. 40.0 ) then
+ IF(lwp) WRITE(numout,*) ' trc_bio_medusa: T WARNING 2D, ', &
+ tsb(ji,jj,jk,jp_tem), tsn(ji,jj,jk,jp_tem), ' at (', &
+ ji, ',', jj, ',', jk, ') at time', kt
+ IF(lwp) WRITE(numout,*) ' trc_bio_medusa: T SWITCHING 2D, ', &
+ tsn(ji,jj,jk,jp_tem), ' -> ', tsb(ji,jj,jk,jp_tem)
+ ztmp = tsb(ji,jj,jk,jp_tem) !! temperature
+ endif
+ if (zsal .lt. 0.0 .or. zsal .gt. 45.0 ) then
+ IF(lwp) WRITE(numout,*) ' trc_bio_medusa: S WARNING 2D, ', &
+ tsb(ji,jj,jk,jp_sal), tsn(ji,jj,jk,jp_sal), ' at (', &
+ ji, ',', jj, ',', jk, ') at time', kt
+ endif
+# else
+ zdtc = zdet * xthetad !! implicit detrital carbon
+# endif
+# if defined key_debug_medusa
+ if (idf.eq.1) then
+ !! AXY (15/01/10)
+ if (trn(ji,jj,jk,jpdin).lt.0.) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'NEGATIVE DIN ERROR =', trn(ji,jj,jk,jpdin)
+ IF (lwp) write (numout,*) 'NEGATIVE DIN ERROR @', ji, jj, jk, kt
+ endif
+ if (trn(ji,jj,jk,jpsil).lt.0.) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'NEGATIVE SIL ERROR =', trn(ji,jj,jk,jpsil)
+ IF (lwp) write (numout,*) 'NEGATIVE SIL ERROR @', ji, jj, jk, kt
+ endif
+# if defined key_roam
+ if (trn(ji,jj,jk,jpdic).lt.0.) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'NEGATIVE DIC ERROR =', trn(ji,jj,jk,jpdic)
+ IF (lwp) write (numout,*) 'NEGATIVE DIC ERROR @', ji, jj, jk, kt
+ endif
+ if (trn(ji,jj,jk,jpalk).lt.0.) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'NEGATIVE ALK ERROR =', trn(ji,jj,jk,jpalk)
+ IF (lwp) write (numout,*) 'NEGATIVE ALK ERROR @', ji, jj, jk, kt
+ endif
+ if (trn(ji,jj,jk,jpoxy).lt.0.) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'NEGATIVE OXY ERROR =', trn(ji,jj,jk,jpoxy)
+ IF (lwp) write (numout,*) 'NEGATIVE OXY ERROR @', ji, jj, jk, kt
+ endif
+# endif
+ endif
+# endif
+# if defined key_debug_medusa
+ !! report state variable values
+ if (idf.eq.1.AND.idfval.eq.1) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'fthk(',jk,') = ', fthk
+ IF (lwp) write (numout,*) 'zphn(',jk,') = ', zphn
+ IF (lwp) write (numout,*) 'zphd(',jk,') = ', zphd
+ IF (lwp) write (numout,*) 'zpds(',jk,') = ', zpds
+ IF (lwp) write (numout,*) 'zzmi(',jk,') = ', zzmi
+ IF (lwp) write (numout,*) 'zzme(',jk,') = ', zzme
+ IF (lwp) write (numout,*) 'zdet(',jk,') = ', zdet
+ IF (lwp) write (numout,*) 'zdin(',jk,') = ', zdin
+ IF (lwp) write (numout,*) 'zsil(',jk,') = ', zsil
+ IF (lwp) write (numout,*) 'zfer(',jk,') = ', zfer
+# if defined key_roam
+ IF (lwp) write (numout,*) 'zdtc(',jk,') = ', zdtc
+ IF (lwp) write (numout,*) 'zdic(',jk,') = ', zdic
+ IF (lwp) write (numout,*) 'zalk(',jk,') = ', zalk
+ IF (lwp) write (numout,*) 'zoxy(',jk,') = ', zoxy
+# endif
+ endif
+# endif
+
+# if defined key_debug_medusa
+ if (idf.eq.1.AND.idfval.eq.1.AND.jk.eq.1) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'dust = ', dust(ji,jj)
+ endif
+# endif
+
+ !! sum tracers for inventory checks
+ IF( lk_iomput ) THEN
+ IF ( med_diag%INVTN%dgsave ) THEN
+ ftot_n(ji,jj) = ftot_n(ji,jj) + &
+ (fthk * ( zphn + zphd + zzmi + zzme + zdet + zdin ) )
+ ENDIF
+ IF ( med_diag%INVTSI%dgsave ) THEN
+ ftot_si(ji,jj) = ftot_si(ji,jj) + &
+ (fthk * ( zpds + zsil ) )
+ ENDIF
+ IF ( med_diag%INVTFE%dgsave ) THEN
+ ftot_fe(ji,jj) = ftot_fe(ji,jj) + &
+ (fthk * ( xrfn * ( zphn + zphd + zzmi + zzme + zdet ) + zfer ) )
+ ENDIF
+# if defined key_roam
+ IF ( med_diag%INVTC%dgsave ) THEN
+ ftot_c(ji,jj) = ftot_c(ji,jj) + &
+ (fthk * ( (xthetapn * zphn) + (xthetapd * zphd) + &
+ (xthetazmi * zzmi) + (xthetazme * zzme) + zdtc + &
+ zdic ) )
+ ENDIF
+ IF ( med_diag%INVTALK%dgsave ) THEN
+ ftot_a(ji,jj) = ftot_a(ji,jj) + (fthk * ( zalk ) )
+ ENDIF
+ IF ( med_diag%INVTO2%dgsave ) THEN
+ ftot_o2(ji,jj) = ftot_o2(ji,jj) + (fthk * ( zoxy ) )
+ ENDIF
+ !!
+ !! AXY (10/11/16): CMIP6 diagnostics
+ IF ( med_diag%INTDISSIC%dgsave ) THEN
+ intdissic(ji,jj) = intdissic(ji,jj) + (fthk * zdic)
+ ENDIF
+ IF ( med_diag%INTDISSIN%dgsave ) THEN
+ intdissin(ji,jj) = intdissin(ji,jj) + (fthk * zdin)
+ ENDIF
+ IF ( med_diag%INTDISSISI%dgsave ) THEN
+ intdissisi(ji,jj) = intdissisi(ji,jj) + (fthk * zsil)
+ ENDIF
+ IF ( med_diag%INTTALK%dgsave ) THEN
+ inttalk(ji,jj) = inttalk(ji,jj) + (fthk * zalk)
+ ENDIF
+ IF ( med_diag%O2min%dgsave ) THEN
+ if ( zoxy < o2min(ji,jj) ) then
+ o2min(ji,jj) = zoxy
+ IF ( med_diag%ZO2min%dgsave ) THEN
+ zo2min(ji,jj) = (fdep + fdep1) / 2. !! layer midpoint
+ ENDIF
+ endif
+ ENDIF
+# endif
+ ENDIF
+
+ CALL flush(numout)
+
+ !!======================================================================
+ !! LOCAL GRID CELL CALCULATIONS
+ !!======================================================================
+ !!
+# if defined key_roam
+ if ( jk .eq. 1 ) then
+ !!----------------------------------------------------------------------
+ !! Air-sea gas exchange
+ !!----------------------------------------------------------------------
+ !!
+ !! AXY (17/07/14): zwind_i and zwind_j do not exist in this
+ !! version of NEMO because it does not include
+ !! the SBC changes that our local version has
+ !! for accessing the HadGEM2 forcing; they
+ !! could be added, but an alternative approach
+ !! is to make use of wndm from oce_trc.F90
+ !! which is wind speed at 10m (which is what
+ !! is required here; this may need to be
+ !! revisited when MEDUSA properly interacts
+ !! with UKESM1 physics
+ !!
+ f_wind = wndm(ji,jj)
+ IF (lk_oasis) THEN
+ f_xco2a = PCO2a_in_cpl(ji,jj) !! use 2D atm xCO2 from atm coupling
+ ENDIF
+ !!
+ !! AXY (23/06/15): as part of an effort to update the carbonate chemistry
+ !! in MEDUSA, the gas transfer velocity used in the carbon
+ !! and oxygen cycles has been harmonised and is calculated
+ !! by the same function here; this harmonisation includes
+ !! changes to the PML carbonate chemistry scheme so that
+ !! it too makes use of the same gas transfer velocity; the
+ !! preferred parameterisation of this is Wanninkhof (2014),
+ !! option 7
+ !!
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'trc_bio_medusa: entering gas_transfer'
+ CALL flush(numout)
+# endif
+ CALL gas_transfer( f_wind, 1, 7, & ! inputs
+ f_kw660 ) ! outputs
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'trc_bio_medusa: exiting gas_transfer'
+ CALL flush(numout)
+# endif
+ !!
+ !! air pressure (atm); ultimately this will use air pressure at the base
+ !! of the UKESM1 atmosphere
+ !!
+ f_pp0 = 1.0
+ !!
+ !! IF(lwp) WRITE(numout,*) ' MEDUSA ztmp =', ztmp
+ !! IF(lwp) WRITE(numout,*) ' MEDUSA zwind_i =', zwind_i(ji,jj)
+ !! IF(lwp) WRITE(numout,*) ' MEDUSA zwind_j =', zwind_j(ji,jj)
+ !! IF(lwp) WRITE(numout,*) ' MEDUSA f_wind =', f_wind
+ !! IF(lwp) WRITE(numout,*) ' MEDUSA fr_i =', fr_i(ji,jj)
+ !!
+# if defined key_axy_carbchem
+# if defined key_mocsy
+ !!
+ !! AXY (22/06/15): use Orr & Epitalon (2015) MOCSY-2 carbonate
+ !! chemistry package; note that depth is set to
+ !! zero in this call
+ CALL mocsy_interface( ztmp, zsal, zalk, zdic, zsil, zpho, & ! inputs
+ f_pp0, 0.0, gphit(ji,jj), f_kw660, f_xco2a, 1, & ! inputs
+ f_ph, f_pco2w, f_fco2w, f_h2co3, f_hco3, f_co3, f_omarg(ji,jj), & ! outputs
+ f_omcal(ji,jj), f_BetaD, f_rhosw, f_opres, f_insitut, & ! outputs
+ f_pco2atm, f_fco2atm, f_schmidtco2, f_kwco2, f_K0, & ! outputs
+ f_co2starair, f_co2flux, f_dpco2 ) ! outputs
+ !!
+ f_TDIC = (zdic / f_rhosw) * 1000. ! mmol / m3 -> umol / kg
+ f_TALK = (zalk / f_rhosw) * 1000. ! meq / m3 -> ueq / kg
+ f_dcf = f_rhosw
+# else
+ iters = 0
+ !!
+ !! carbon dioxide (CO2); Jerry Blackford code (ostensibly OCMIP-2, but not)
+ CALL trc_co2_medusa( ztmp, zsal, zdic, zalk, 0.0, f_kw660, f_xco2a, & ! inputs
+ f_ph, f_pco2w, f_h2co3, f_hco3, f_co3, f_omcal(ji,jj), & ! outputs
+ f_omarg(ji,jj), f_co2flux, f_TDIC, f_TALK, f_dcf, f_henry, iters ) ! outputs
+ !!
+ !! AXY (09/01/14): removed iteration and NaN checks; these have
+ !! been moved to trc_co2_medusa together with a
+ !! fudge that amends erroneous values (this is
+ !! intended to be a temporary fudge!); the
+ !! output warnings are retained here so that
+ !! failure position can be determined
+ if (iters .eq. 25) then
+ IF(lwp) WRITE(numout,*) ' trc_bio_medusa: ITERS WARNING, ', &
+ iters, ' AT (', ji, ', ', jj, ', ', jk, ') AT ', kt
+ endif
+# endif
+# else
+ !! AXY (18/04/13): switch off carbonate chemistry calculations; provide
+ !! quasi-sensible alternatives
+ f_ph = 8.1
+ f_pco2w = f_xco2a
+ f_h2co3 = 0.005 * zdic
+ f_hco3 = 0.865 * zdic
+ f_co3 = 0.130 * zdic
+ f_omcal(ji,jj) = 4.
+ f_omarg(ji,jj) = 2.
+ f_co2flux = 0.
+ f_TDIC = zdic
+ f_TALK = zalk
+ f_dcf = 1.026
+ f_henry = 1.
+ !! AXY (23/06/15): add in some extra MOCSY diagnostics
+ f_fco2w = f_xco2a
+ f_BetaD = 1.
+ f_rhosw = 1.026
+ f_opres = 0.
+ f_insitut = ztmp
+ f_pco2atm = f_xco2a
+ f_fco2atm = f_xco2a
+ f_schmidtco2 = 660.
+ f_kwco2 = 0.
+ f_K0 = 0.
+ f_co2starair = f_xco2a
+ f_dpco2 = 0.
+# endif
+ !!
+ !! mmol/m2/s -> mmol/m3/d; correct for sea-ice; divide through by layer thickness
+ f_co2flux = (1. - fr_i(ji,jj)) * f_co2flux * 86400. / fthk
+ !!
+ !! oxygen (O2); OCMIP-2 code
+ !! AXY (23/06/15): amend input list for oxygen to account for common gas
+ !! transfer velocity
+ !! CALL trc_oxy_medusa( ztmp, zsal, f_uwind, f_vwind, f_pp0, zoxy / 1000., fthk, & ! inputs
+ !! f_kw660, f_o2flux, f_o2sat ) ! outputs
+ CALL trc_oxy_medusa( ztmp, zsal, f_kw660, f_pp0, zoxy, & ! inputs
+ f_kwo2, f_o2flux, f_o2sat ) ! outputs
+ !!
+ !! mmol/m2/s -> mol/m3/d; correct for sea-ice; divide through by layer thickness
+ f_o2flux = (1. - fr_i(ji,jj)) * f_o2flux * 86400. / fthk
+ !!
+ !! Jpalm (08-2014)
+ !! DMS surface concentration calculation
+ !! initialy added for UKESM1 model.
+ !! using MET-OFFICE subroutine.
+ !! DMS module only needs Chl concentration and MLD
+ !! to get an aproximate value of DMS concentration.
+ !! air-sea fluxes are calculated by atmospheric chemitry model
+ !! from atm and oc-surface concentrations.
+ !!
+ !! AXY (13/03/15): this is amended to calculate all of the DMS
+ !! estimates examined during UKESM1 (see comments
+ !! in trcdms_medusa.F90)
+ !!
+ !! AXY (25/05/17): amended to additionally pass DIN limitation as well as [DIN];
+ !! accounts for differences in nutrient half-saturations; changes
+ !! also made in trc_dms_medusa; this permits an additional DMS
+ !! calculation while retaining the existing Anderson one
+ !!
+ IF (jdms .eq. 1) THEN
+ !!
+ !! calculate weighted half-saturation for DIN uptake
+ dms_wtkn = ((zphn * xnln) + (zphd * xnld)) / (zphn + zphd)
+ !!
+ !! feed in correct inputs
+ if (jdms_input .eq. 0) then
+ !! use instantaneous inputs
+ dms_nlim = zdin / (zdin + dms_wtkn)
+ !!
+ CALL trc_dms_medusa( zchn, zchd, & ! inputs
+ hmld(ji,jj), qsr(ji,jj), & ! inputs
+ zdin, dms_nlim, & ! inputs
+ dms_andr, dms_simo, dms_aran, dms_hall, dms_andm ) ! outputs
+ else
+ !! use diel-average inputs
+ dms_nlim = zn_dms_din(ji,jj) / (zn_dms_din(ji,jj) + dms_wtkn)
+ !!
+ CALL trc_dms_medusa( zn_dms_chn(ji,jj), zn_dms_chd(ji,jj), & ! inputs
+ zn_dms_mld(ji,jj), zn_dms_qsr(ji,jj), & ! inputs
+ zn_dms_din(ji,jj), dms_nlim, & ! inputs
+ dms_andr, dms_simo, dms_aran, dms_hall, dms_andm ) ! outputs
+ endif
+ !!
+ !! assign correct output to variable passed to atmosphere
+ if (jdms_model .eq. 1) then
+ dms_surf = dms_andr
+ elseif (jdms_model .eq. 2) then
+ dms_surf = dms_simo
+ elseif (jdms_model .eq. 3) then
+ dms_surf = dms_aran
+ elseif (jdms_model .eq. 4) then
+ dms_surf = dms_hall
+ elseif (jdms_model .eq. 5) then
+ dms_surf = dms_andm
+ endif
+ !!
+ !! 2D diag through iom_use
+ IF( lk_iomput ) THEN
+ IF( med_diag%DMS_SURF%dgsave ) THEN
+ dms_surf2d(ji,jj) = dms_surf
+ ENDIF
+ IF( med_diag%DMS_ANDR%dgsave ) THEN
+ dms_andr2d(ji,jj) = dms_andr
+ ENDIF
+ IF( med_diag%DMS_SIMO%dgsave ) THEN
+ dms_simo2d(ji,jj) = dms_simo
+ ENDIF
+ IF( med_diag%DMS_ARAN%dgsave ) THEN
+ dms_aran2d(ji,jj) = dms_aran
+ ENDIF
+ IF( med_diag%DMS_HALL%dgsave ) THEN
+ dms_hall2d(ji,jj) = dms_hall
+ ENDIF
+ IF( med_diag%DMS_ANDM%dgsave ) THEN
+ dms_andm2d(ji,jj) = dms_andm
+ ENDIF
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'trc_bio_medusa: finish calculating dms'
+ CALL flush(numout)
+# endif
+ ENDIF
+ !! End iom
+ ENDIF
+ !! End DMS Loop
+ !!
+ !! store 2D outputs
+ !!
+ !! JPALM -- 17-11-16 -- put fgco2 out of diag request
+ !! is needed for coupling; pass through restart
+ !! IF( med_diag%FGCO2%dgsave ) THEN
+ !! convert from mol/m2/day to kg/m2/s
+ fgco2(ji,jj) = f_co2flux * fthk * CO2flux_conv !! mmol-C/m3/d -> kg-CO2/m2/s
+ !! ENDIF
+ IF ( lk_iomput ) THEN
+ IF( med_diag%ATM_PCO2%dgsave ) THEN
+ f_pco2a2d(ji,jj) = f_pco2atm
+ ENDIF
+ IF( med_diag%OCN_PCO2%dgsave ) THEN
+ f_pco2w2d(ji,jj) = f_pco2w
+ ENDIF
+ IF( med_diag%CO2FLUX%dgsave ) THEN
+ f_co2flux2d(ji,jj) = f_co2flux * fthk !! mmol/m3/d -> mmol/m2/d
+ ENDIF
+ IF( med_diag%TCO2%dgsave ) THEN
+ f_TDIC2d(ji,jj) = f_TDIC
+ ENDIF
+ IF( med_diag%TALK%dgsave ) THEN
+ f_TALK2d(ji,jj) = f_TALK
+ ENDIF
+ IF( med_diag%KW660%dgsave ) THEN
+ f_kw6602d(ji,jj) = f_kw660
+ ENDIF
+ IF( med_diag%ATM_PP0%dgsave ) THEN
+ f_pp02d(ji,jj) = f_pp0
+ ENDIF
+ IF( med_diag%O2FLUX%dgsave ) THEN
+ f_o2flux2d(ji,jj) = f_o2flux
+ ENDIF
+ IF( med_diag%O2SAT%dgsave ) THEN
+ f_o2sat2d(ji,jj) = f_o2sat
+ ENDIF
+ !! AXY (24/11/16): add in extra MOCSY diagnostics
+ IF( med_diag%ATM_XCO2%dgsave ) THEN
+ f_xco2a_2d(ji,jj) = f_xco2a
+ ENDIF
+ IF( med_diag%OCN_FCO2%dgsave ) THEN
+ f_fco2w_2d(ji,jj) = f_fco2w
+ ENDIF
+ IF( med_diag%ATM_FCO2%dgsave ) THEN
+ f_fco2a_2d(ji,jj) = f_fco2atm
+ ENDIF
+ IF( med_diag%OCN_RHOSW%dgsave ) THEN
+ f_ocnrhosw_2d(ji,jj) = f_rhosw
+ ENDIF
+ IF( med_diag%OCN_SCHCO2%dgsave ) THEN
+ f_ocnschco2_2d(ji,jj) = f_schmidtco2
+ ENDIF
+ IF( med_diag%OCN_KWCO2%dgsave ) THEN
+ f_ocnkwco2_2d(ji,jj) = f_kwco2
+ ENDIF
+ IF( med_diag%OCN_K0%dgsave ) THEN
+ f_ocnk0_2d(ji,jj) = f_K0
+ ENDIF
+ IF( med_diag%CO2STARAIR%dgsave ) THEN
+ f_co2starair_2d(ji,jj) = f_co2starair
+ ENDIF
+ IF( med_diag%OCN_DPCO2%dgsave ) THEN
+ f_ocndpco2_2d(ji,jj) = f_dpco2
+ ENDIF
+ ENDIF
+ !!
+ endif
+ !! End jk = 1 loop within ROAM key
+
+ !! AXY (11/11/16): CMIP6 oxygen saturation 3D diagnostic
+ IF ( med_diag%O2SAT3%dgsave ) THEN
+ call oxy_sato( ztmp, zsal, f_o2sat3 )
+ o2sat3(ji, jj, jk) = f_o2sat3
+ ENDIF
+
+# endif
+
+ if ( jk .eq. 1 ) then
+ !!----------------------------------------------------------------------
+ !! River inputs
+ !!----------------------------------------------------------------------
+ !!
+ !! runoff comes in as kg / m2 / s
+ !! used and written out as m3 / m2 / d (= m / d)
+ !! where 1000 kg / m2 / d = 1 m3 / m2 / d = 1 m / d
+ !!
+ !! AXY (17/07/14): the compiler doesn't like this line for some reason;
+ !! as MEDUSA doesn't even use runoff for riverine inputs,
+ !! a temporary solution is to switch off runoff entirely
+ !! here; again, this change is one of several that will
+ !! need revisiting once MEDUSA has bedded down in UKESM1;
+ !! particularly so if the land scheme provides information
+ !! concerning nutrient fluxes
+ !!
+ !! f_runoff(ji,jj) = sf_rnf(1)%fnow(ji,jj,1) / 1000. * 60. * 60. * 24.
+ f_runoff(ji,jj) = 0.0
+ !!
+ !! nutrients are added via rivers to the model in one of two ways:
+ !! 1. via river concentration; i.e. the average nutrient concentration
+ !! of a river water is described by a spatial file, and this is
+ !! multiplied by runoff to give a nutrient flux
+ !! 2. via direct river flux; i.e. the average nutrient flux due to
+ !! rivers is described by a spatial file, and this is simply applied
+ !! as a direct nutrient flux (i.e. it does not relate or respond to
+ !! model runoff)
+ !! nutrient fields are derived from the GlobalNEWS 2 database; carbon and
+ !! alkalinity are derived from continent-scale DIC estimates (Huang et al.,
+ !! 2012) and some Arctic river alkalinity estimates (Katya?)
+ !!
+ !! as of 19/07/12, riverine nutrients can now be spread vertically across
+ !! several grid cells rather than just poured into the surface box; this
+ !! block of code is still executed, however, to set up the total amounts
+ !! of nutrient entering via rivers
+ !!
+ !! nitrogen
+ if (jriver_n .eq. 1) then
+ !! river concentration specified; use runoff to calculate input
+ f_riv_n(ji,jj) = f_runoff(ji,jj) * riv_n(ji,jj)
+ elseif (jriver_n .eq. 2) then
+ !! river flux specified; independent of runoff
+ f_riv_n(ji,jj) = riv_n(ji,jj)
+ endif
+ !!
+ !! silicon
+ if (jriver_si .eq. 1) then
+ !! river concentration specified; use runoff to calculate input
+ f_riv_si(ji,jj) = f_runoff(ji,jj) * riv_si(ji,jj)
+ elseif (jriver_si .eq. 2) then
+ !! river flux specified; independent of runoff
+ f_riv_si(ji,jj) = riv_si(ji,jj)
+ endif
+ !!
+ !! carbon
+ if (jriver_c .eq. 1) then
+ !! river concentration specified; use runoff to calculate input
+ f_riv_c(ji,jj) = f_runoff(ji,jj) * riv_c(ji,jj)
+ elseif (jriver_c .eq. 2) then
+ !! river flux specified; independent of runoff
+ f_riv_c(ji,jj) = riv_c(ji,jj)
+ endif
+ !!
+ !! alkalinity
+ if (jriver_alk .eq. 1) then
+ !! river concentration specified; use runoff to calculate input
+ f_riv_alk(ji,jj) = f_runoff(ji,jj) * riv_alk(ji,jj)
+ elseif (jriver_alk .eq. 2) then
+ !! river flux specified; independent of runoff
+ f_riv_alk(ji,jj) = riv_alk(ji,jj)
+ endif
+
+ endif
+
+ !!----------------------------------------------------------------------
+ !! Chlorophyll calculations
+ !!----------------------------------------------------------------------
+ !!
+ !! non-diatoms
+ if (zphn.GT.rsmall) then
+ fthetan = max(tiny(zchn), (zchn * xxi) / (zphn + tiny(zphn)))
+ faln = xaln * fthetan
+ else
+ fthetan = 0.
+ faln = 0.
+ endif
+ !!
+ !! diatoms
+ if (zphd.GT.rsmall) then
+ fthetad = max(tiny(zchd), (zchd * xxi) / (zphd + tiny(zphd)))
+ fald = xald * fthetad
+ else
+ fthetad = 0.
+ fald = 0.
+ endif
+
+# if defined key_debug_medusa
+ !! report biological calculations
+ if (idf.eq.1.AND.idfval.eq.1) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'faln(',jk,') = ', faln
+ IF (lwp) write (numout,*) 'fald(',jk,') = ', fald
+ endif
+# endif
+
+ !!----------------------------------------------------------------------
+ !! Phytoplankton light limitation
+ !!----------------------------------------------------------------------
+ !!
+ !! It is assumed xpar is the depth-averaged (vertical layer) PAR
+ !! Light limitation (check self-shading) in W/m2
+ !!
+ !! Note that there is no temperature dependence in phytoplankton
+ !! growth rate or any other function.
+ !! In calculation of Chl/Phy ratio tiny(phyto) is introduced to avoid
+ !! NaNs in case of Phy==0.
+ !!
+ !! fthetad and fthetan are Chl:C ratio (gChl/gC) in diat and non-diat:
+ !! for 1:1 Chl:P ratio (mgChl/mmolN) theta=0.012
+ !!
+ !! AXY (16/07/09)
+ !! temperature for new Eppley style phytoplankton growth
+ loc_T = tsn(ji,jj,jk,jp_tem)
+ fun_T = 1.066**(1.0 * loc_T)
+ !! AXY (16/05/11): add in new Q10 (1.5, not 2.0) for
+ !phytoplankton
+ !! growth; remin. unaffected
+ fun_Q10 = jq10**((loc_T - 0.0) / 10.0)
+ if (jphy.eq.1) then
+ xvpnT = xvpn * fun_T
+ xvpdT = xvpd * fun_T
+ elseif (jphy.eq.2) then
+ xvpnT = xvpn * fun_Q10
+ xvpdT = xvpd * fun_Q10
+ else
+ xvpnT = xvpn
+ xvpdT = xvpd
+ endif
+ !!
+ !! non-diatoms
+ fchn1 = (xvpnT * xvpnT) + (faln * faln * xpar(ji,jj,jk) * xpar(ji,jj,jk))
+ if (fchn1.GT.rsmall) then
+ fchn = xvpnT / (sqrt(fchn1) + tiny(fchn1))
+ else
+ fchn = 0.
+ endif
+ fjln = fchn * faln * xpar(ji,jj,jk) !! non-diatom J term
+ fjlim_pn = fjln / xvpnT
+ !!
+ !! diatoms
+ fchd1 = (xvpdT * xvpdT) + (fald * fald * xpar(ji,jj,jk) * xpar(ji,jj,jk))
+ if (fchd1.GT.rsmall) then
+ fchd = xvpdT / (sqrt(fchd1) + tiny(fchd1))
+ else
+ fchd = 0.
+ endif
+ fjld = fchd * fald * xpar(ji,jj,jk) !! diatom J term
+ fjlim_pd = fjld / xvpdT
+
+# if defined key_debug_medusa
+ !! report phytoplankton light limitation
+ if (idf.eq.1.AND.idfval.eq.1) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'fchn(',jk,') = ', fchn
+ IF (lwp) write (numout,*) 'fchd(',jk,') = ', fchd
+ IF (lwp) write (numout,*) 'fjln(',jk,') = ', fjln
+ IF (lwp) write (numout,*) 'fjld(',jk,') = ', fjld
+ endif
+# endif
+
+ !!----------------------------------------------------------------------
+ !! Phytoplankton nutrient limitation
+ !!----------------------------------------------------------------------
+ !!
+ !! non-diatoms (N, Fe)
+ fnln = zdin / (zdin + xnln) !! non-diatom Qn term
+ ffln = zfer / (zfer + xfln) !! non-diatom Qf term
+ !!
+ !! diatoms (N, Si, Fe)
+ fnld = zdin / (zdin + xnld) !! diatom Qn term
+ fsld = zsil / (zsil + xsld) !! diatom Qs term
+ ffld = zfer / (zfer + xfld) !! diatom Qf term
+
+# if defined key_debug_medusa
+ !! report phytoplankton nutrient limitation
+ if (idf.eq.1.AND.idfval.eq.1) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'fnln(',jk,') = ', fnln
+ IF (lwp) write (numout,*) 'fnld(',jk,') = ', fnld
+ IF (lwp) write (numout,*) 'ffln(',jk,') = ', ffln
+ IF (lwp) write (numout,*) 'ffld(',jk,') = ', ffld
+ IF (lwp) write (numout,*) 'fsld(',jk,') = ', fsld
+ endif
+# endif
+
+ !!----------------------------------------------------------------------
+ !! Primary production (non-diatoms)
+ !! (note: still needs multiplying by phytoplankton concentration)
+ !!----------------------------------------------------------------------
+ !!
+ if (jliebig .eq. 0) then
+ !! multiplicative nutrient limitation
+ fpnlim = fnln * ffln
+ elseif (jliebig .eq. 1) then
+ !! Liebig Law (= most limiting) nutrient limitation
+ fpnlim = min(fnln, ffln)
+ endif
+ fprn = fjln * fpnlim
+
+ !!----------------------------------------------------------------------
+ !! Primary production (diatoms)
+ !! (note: still needs multiplying by phytoplankton concentration)
+ !!
+ !! production here is split between nitrogen production and that of
+ !! silicon; depending upon the "intracellular" ratio of Si:N, model
+ !! diatoms will uptake nitrogen/silicon differentially; this borrows
+ !! from the diatom model of Mongin et al. (2006)
+ !!----------------------------------------------------------------------
+ !!
+ if (jliebig .eq. 0) then
+ !! multiplicative nutrient limitation
+ fpdlim = fnld * ffld
+ elseif (jliebig .eq. 1) then
+ !! Liebig Law (= most limiting) nutrient limitation
+ fpdlim = min(fnld, ffld)
+ endif
+ !!
+ if (zphd.GT.rsmall .AND. zpds.GT.rsmall) then
+ !! "intracellular" elemental ratios
+ ! fsin = zpds / (zphd + tiny(zphd))
+ ! fnsi = zphd / (zpds + tiny(zpds))
+ fsin = 0.0
+ IF( zphd .GT. rsmall) fsin = zpds / zphd
+ fnsi = 0.0
+ IF( zpds .GT. rsmall) fnsi = zphd / zpds
+ !! AXY (23/02/10): these next variables derive from Mongin et al. (2003)
+ fsin1 = 3.0 * xsin0 !! = 0.6
+ fnsi1 = 1.0 / fsin1 !! = 1.667
+ fnsi2 = 1.0 / xsin0 !! = 5.0
+ !!
+ !! conditionalities based on ratios
+ !! nitrogen (and iron and carbon)
+ if (fsin.le.xsin0) then
+ fprd = 0.0
+ fsld2 = 0.0
+ elseif (fsin.lt.fsin1) then
+ fprd = xuif * ((fsin - xsin0) / (fsin + tiny(fsin))) * (fjld * fpdlim)
+ fsld2 = xuif * ((fsin - xsin0) / (fsin + tiny(fsin)))
+ elseif (fsin.ge.fsin1) then
+ fprd = (fjld * fpdlim)
+ fsld2 = 1.0
+ endif
+ !!
+ !! silicon
+ if (fsin.lt.fnsi1) then
+ fprds = (fjld * fsld)
+ elseif (fsin.lt.fnsi2) then
+ fprds = xuif * ((fnsi - xnsi0) / (fnsi + tiny(fnsi))) * (fjld * fsld)
+ else
+ fprds = 0.0
+ endif
+ else
+ fsin = 0.0
+ fnsi = 0.0
+ fprd = 0.0
+ fsld2 = 0.0
+ fprds = 0.0
+ endif
+
+# if defined key_debug_medusa
+ !! report phytoplankton growth (including diatom silicon submodel)
+ if (idf.eq.1.AND.idfval.eq.1) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'fsin(',jk,') = ', fsin
+ IF (lwp) write (numout,*) 'fnsi(',jk,') = ', fnsi
+ IF (lwp) write (numout,*) 'fsld2(',jk,') = ', fsld2
+ IF (lwp) write (numout,*) 'fprn(',jk,') = ', fprn
+ IF (lwp) write (numout,*) 'fprd(',jk,') = ', fprd
+ IF (lwp) write (numout,*) 'fprds(',jk,') = ', fprds
+ endif
+# endif
+
+ !!----------------------------------------------------------------------
+ !! Mixed layer primary production
+ !! this block calculates the amount of primary production that occurs
+ !! within the upper mixed layer; this allows the separate diagnosis
+ !! of "sub-surface" primary production; it does assume that short-
+ !! term variability in mixed layer depth doesn't mess with things
+ !! though
+ !!----------------------------------------------------------------------
+ !!
+ if (fdep1.le.hmld(ji,jj)) then
+ !! this level is entirely in the mixed layer
+ fq0 = 1.0
+ elseif (fdep.ge.hmld(ji,jj)) then
+ !! this level is entirely below the mixed layer
+ fq0 = 0.0
+ else
+ !! this level straddles the mixed layer
+ fq0 = (hmld(ji,jj) - fdep) / fthk
+ endif
+ !!
+ fprn_ml(ji,jj) = fprn_ml(ji,jj) + (fprn * zphn * fthk * fq0)
+ fprd_ml(ji,jj) = fprd_ml(ji,jj) + (fprd * zphd * fthk * fq0)
+
+ !!----------------------------------------------------------------------
+ !! Vertical Integral --
+ !!----------------------------------------------------------------------
+ ftot_pn(ji,jj) = ftot_pn(ji,jj) + (zphn * fthk) !! vertical integral non-diatom phytoplankton
+ ftot_pd(ji,jj) = ftot_pd(ji,jj) + (zphd * fthk) !! vertical integral diatom phytoplankton
+ ftot_zmi(ji,jj) = ftot_zmi(ji,jj) + (zzmi * fthk) !! vertical integral microzooplankton
+ ftot_zme(ji,jj) = ftot_zme(ji,jj) + (zzme * fthk) !! vertical integral mesozooplankton
+ ftot_det(ji,jj) = ftot_det(ji,jj) + (zdet * fthk) !! vertical integral slow detritus, nitrogen
+ ftot_dtc(ji,jj) = ftot_dtc(ji,jj) + (zdtc * fthk) !! vertical integral slow detritus, carbon
+
+ !!----------------------------------------------------------------------
+ !! More chlorophyll calculations
+ !!----------------------------------------------------------------------
+ !!
+ !! frn = (xthetam / fthetan) * (fprn / (fthetan * xpar(ji,jj,jk)))
+ !! frd = (xthetam / fthetad) * (fprd / (fthetad * xpar(ji,jj,jk)))
+ frn = (xthetam * fchn * fnln * ffln ) / (fthetan + tiny(fthetan))
+ !! AXY (12/05/09): there's potentially a problem here; fsld, silicic acid
+ !! limitation, is used in the following line to regulate chlorophyll
+ !! growth in a manner that is inconsistent with its use in the regulation
+ !! of biomass growth; the Mongin term term used in growth is more complex
+ !! than the simple multiplicative function used below
+ !! frd = (xthetam * fchd * fnld * ffld * fsld) / (fthetad + tiny(fthetad))
+ !! AXY (12/05/09): this replacement line uses the new variable, fsld2, to
+ !! regulate chlorophyll growth
+ frd = (xthetamd * fchd * fnld * ffld * fsld2) / (fthetad + tiny(fthetad))
+
+# if defined key_debug_medusa
+ !! report chlorophyll calculations
+ if (idf.eq.1.AND.idfval.eq.1) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'fthetan(',jk,') = ', fthetan
+ IF (lwp) write (numout,*) 'fthetad(',jk,') = ', fthetad
+ IF (lwp) write (numout,*) 'frn(',jk,') = ', frn
+ IF (lwp) write (numout,*) 'frd(',jk,') = ', frd
+ endif
+# endif
+
+ !!----------------------------------------------------------------------
+ !! Zooplankton Grazing
+ !! this code supplements the base grazing model with one that
+ !! considers the C:N ratio of grazed food and balances this against
+ !! the requirements of zooplankton growth; this model is derived
+ !! from that of Anderson & Pondaven (2003)
+ !!
+ !! the current version of the code assumes a fixed C:N ratio for
+ !! detritus (in contrast to Anderson & Pondaven, 2003), though the
+ !! full equations are retained for future extension
+ !!----------------------------------------------------------------------
+ !!
+ !!----------------------------------------------------------------------
+ !! Microzooplankton first
+ !!----------------------------------------------------------------------
+ !!
+ fmi1 = (xkmi * xkmi) + (xpmipn * zphn * zphn) + (xpmid * zdet * zdet)
+ fmi = xgmi * zzmi / fmi1
+ fgmipn = fmi * xpmipn * zphn * zphn !! grazing on non-diatoms
+ fgmid = fmi * xpmid * zdet * zdet !! grazing on detrital nitrogen
+# if defined key_roam
+ fgmidc = rsmall !acc
+ IF ( zdet .GT. rsmall ) fgmidc = (zdtc / (zdet + tiny(zdet))) * fgmid !! grazing on detrital carbon
+# else
+ !! AXY (26/11/08): implicit detrital carbon change
+ fgmidc = xthetad * fgmid !! grazing on detrital carbon
+# endif
+ !!
+ !! which translates to these incoming N and C fluxes
+ finmi = (1.0 - xphi) * (fgmipn + fgmid)
+ ficmi = (1.0 - xphi) * ((xthetapn * fgmipn) + fgmidc)
+ !!
+ !! the ideal food C:N ratio for microzooplankton
+ !! xbetan = 0.77; xthetaz = 5.625; xbetac = 0.64; xkc = 0.80
+ fstarmi = (xbetan * xthetazmi) / (xbetac * xkc)
+ !!
+ !! process these to determine proportioning of grazed N and C
+ !! (since there is no explicit consideration of respiration,
+ !! only growth and excretion are calculated here)
+ fmith = (ficmi / (finmi + tiny(finmi)))
+ if (fmith.ge.fstarmi) then
+ fmigrow = xbetan * finmi
+ fmiexcr = 0.0
+ else
+ fmigrow = (xbetac * xkc * ficmi) / xthetazmi
+ fmiexcr = ficmi * ((xbetan / (fmith + tiny(fmith))) - ((xbetac * xkc) / xthetazmi))
+ endif
+# if defined key_roam
+ fmiresp = (xbetac * ficmi) - (xthetazmi * fmigrow)
+# endif
+
+# if defined key_debug_medusa
+ !! report microzooplankton grazing
+ if (idf.eq.1.AND.idfval.eq.1) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'fmi1(',jk,') = ', fmi1
+ IF (lwp) write (numout,*) 'fmi(',jk,') = ', fmi
+ IF (lwp) write (numout,*) 'fgmipn(',jk,') = ', fgmipn
+ IF (lwp) write (numout,*) 'fgmid(',jk,') = ', fgmid
+ IF (lwp) write (numout,*) 'fgmidc(',jk,') = ', fgmidc
+ IF (lwp) write (numout,*) 'finmi(',jk,') = ', finmi
+ IF (lwp) write (numout,*) 'ficmi(',jk,') = ', ficmi
+ IF (lwp) write (numout,*) 'fstarmi(',jk,') = ', fstarmi
+ IF (lwp) write (numout,*) 'fmith(',jk,') = ', fmith
+ IF (lwp) write (numout,*) 'fmigrow(',jk,') = ', fmigrow
+ IF (lwp) write (numout,*) 'fmiexcr(',jk,') = ', fmiexcr
+# if defined key_roam
+ IF (lwp) write (numout,*) 'fmiresp(',jk,') = ', fmiresp
+# endif
+ endif
+# endif
+
+ !!----------------------------------------------------------------------
+ !! Mesozooplankton second
+ !!----------------------------------------------------------------------
+ !!
+ fme1 = (xkme * xkme) + (xpmepn * zphn * zphn) + (xpmepd * zphd * zphd) + &
+ (xpmezmi * zzmi * zzmi) + (xpmed * zdet * zdet)
+ fme = xgme * zzme / fme1
+ fgmepn = fme * xpmepn * zphn * zphn !! grazing on non-diatoms
+ fgmepd = fme * xpmepd * zphd * zphd !! grazing on diatoms
+ fgmepds = fsin * fgmepd !! grazing on diatom silicon
+ fgmezmi = fme * xpmezmi * zzmi * zzmi !! grazing on microzooplankton
+ fgmed = fme * xpmed * zdet * zdet !! grazing on detrital nitrogen
+# if defined key_roam
+ fgmedc = rsmall !acc
+ IF ( zdet .GT. rsmall ) fgmedc = (zdtc / (zdet + tiny(zdet))) * fgmed !! grazing on detrital carbon
+# else
+ !! AXY (26/11/08): implicit detrital carbon change
+ fgmedc = xthetad * fgmed !! grazing on detrital carbon
+# endif
+ !!
+ !! which translates to these incoming N and C fluxes
+ finme = (1.0 - xphi) * (fgmepn + fgmepd + fgmezmi + fgmed)
+ ficme = (1.0 - xphi) * ((xthetapn * fgmepn) + (xthetapd * fgmepd) + &
+ (xthetazmi * fgmezmi) + fgmedc)
+ !!
+ !! the ideal food C:N ratio for mesozooplankton
+ !! xbetan = 0.77; xthetaz = 5.625; xbetac = 0.64; xkc = 0.80
+ fstarme = (xbetan * xthetazme) / (xbetac * xkc)
+ !!
+ !! process these to determine proportioning of grazed N and C
+ !! (since there is no explicit consideration of respiration,
+ !! only growth and excretion are calculated here)
+ fmeth = (ficme / (finme + tiny(finme)))
+ if (fmeth.ge.fstarme) then
+ fmegrow = xbetan * finme
+ fmeexcr = 0.0
+ else
+ fmegrow = (xbetac * xkc * ficme) / xthetazme
+ fmeexcr = ficme * ((xbetan / (fmeth + tiny(fmeth))) - ((xbetac * xkc) / xthetazme))
+ endif
+# if defined key_roam
+ fmeresp = (xbetac * ficme) - (xthetazme * fmegrow)
+# endif
+
+# if defined key_debug_medusa
+ !! report mesozooplankton grazing
+ if (idf.eq.1.AND.idfval.eq.1) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'fme1(',jk,') = ', fme1
+ IF (lwp) write (numout,*) 'fme(',jk,') = ', fme
+ IF (lwp) write (numout,*) 'fgmepn(',jk,') = ', fgmepn
+ IF (lwp) write (numout,*) 'fgmepd(',jk,') = ', fgmepd
+ IF (lwp) write (numout,*) 'fgmepds(',jk,') = ', fgmepds
+ IF (lwp) write (numout,*) 'fgmezmi(',jk,') = ', fgmezmi
+ IF (lwp) write (numout,*) 'fgmed(',jk,') = ', fgmed
+ IF (lwp) write (numout,*) 'fgmedc(',jk,') = ', fgmedc
+ IF (lwp) write (numout,*) 'finme(',jk,') = ', finme
+ IF (lwp) write (numout,*) 'ficme(',jk,') = ', ficme
+ IF (lwp) write (numout,*) 'fstarme(',jk,') = ', fstarme
+ IF (lwp) write (numout,*) 'fmeth(',jk,') = ', fmeth
+ IF (lwp) write (numout,*) 'fmegrow(',jk,') = ', fmegrow
+ IF (lwp) write (numout,*) 'fmeexcr(',jk,') = ', fmeexcr
+# if defined key_roam
+ IF (lwp) write (numout,*) 'fmeresp(',jk,') = ', fmeresp
+# endif
+ endif
+# endif
+
+ fzmi_i(ji,jj) = fzmi_i(ji,jj) + fthk * ( &
+ fgmipn + fgmid )
+ fzmi_o(ji,jj) = fzmi_o(ji,jj) + fthk * ( &
+ fmigrow + (xphi * (fgmipn + fgmid)) + fmiexcr + ((1.0 - xbetan) * finmi) )
+ fzme_i(ji,jj) = fzme_i(ji,jj) + fthk * ( &
+ fgmepn + fgmepd + fgmezmi + fgmed )
+ fzme_o(ji,jj) = fzme_o(ji,jj) + fthk * ( &
+ fmegrow + (xphi * (fgmepn + fgmepd + fgmezmi + fgmed)) + fmeexcr + ((1.0 - xbetan) * finme) )
+
+ !!----------------------------------------------------------------------
+ !! Plankton metabolic losses
+ !! Linear loss processes assumed to be metabolic in origin
+ !!----------------------------------------------------------------------
+ !!
+ fdpn2 = xmetapn * zphn
+ fdpd2 = xmetapd * zphd
+ fdpds2 = xmetapd * zpds
+ fdzmi2 = xmetazmi * zzmi
+ fdzme2 = xmetazme * zzme
+
+ !!----------------------------------------------------------------------
+ !! Plankton mortality losses
+ !! EKP (26/02/09): phytoplankton hyperbolic mortality term introduced
+ !! to improve performance in gyres
+ !!----------------------------------------------------------------------
+ !!
+ !! non-diatom phytoplankton
+ if (jmpn.eq.1) fdpn = xmpn * zphn !! linear
+ if (jmpn.eq.2) fdpn = xmpn * zphn * zphn !! quadratic
+ if (jmpn.eq.3) fdpn = xmpn * zphn * & !! hyperbolic
+ (zphn / (xkphn + zphn))
+ if (jmpn.eq.4) fdpn = xmpn * zphn * & !! sigmoid
+ ((zphn * zphn) / (xkphn + (zphn * zphn)))
+ !!
+ !! diatom phytoplankton
+ if (jmpd.eq.1) fdpd = xmpd * zphd !! linear
+ if (jmpd.eq.2) fdpd = xmpd * zphd * zphd !! quadratic
+ if (jmpd.eq.3) fdpd = xmpd * zphd * & !! hyperbolic
+ (zphd / (xkphd + zphd))
+ if (jmpd.eq.4) fdpd = xmpd * zphd * & !! sigmoid
+ ((zphd * zphd) / (xkphd + (zphd * zphd)))
+ fdpds = fdpd * fsin
+ !!
+ !! microzooplankton
+ if (jmzmi.eq.1) fdzmi = xmzmi * zzmi !! linear
+ if (jmzmi.eq.2) fdzmi = xmzmi * zzmi * zzmi !! quadratic
+ if (jmzmi.eq.3) fdzmi = xmzmi * zzmi * & !! hyperbolic
+ (zzmi / (xkzmi + zzmi))
+ if (jmzmi.eq.4) fdzmi = xmzmi * zzmi * & !! sigmoid
+ ((zzmi * zzmi) / (xkzmi + (zzmi * zzmi)))
+ !!
+ !! mesozooplankton
+ if (jmzme.eq.1) fdzme = xmzme * zzme !! linear
+ if (jmzme.eq.2) fdzme = xmzme * zzme * zzme !! quadratic
+ if (jmzme.eq.3) fdzme = xmzme * zzme * & !! hyperbolic
+ (zzme / (xkzme + zzme))
+ if (jmzme.eq.4) fdzme = xmzme * zzme * & !! sigmoid
+ ((zzme * zzme) / (xkzme + (zzme * zzme)))
+
+ !!----------------------------------------------------------------------
+ !! Detritus remineralisation
+ !! Constant or temperature-dependent
+ !!----------------------------------------------------------------------
+ !!
+ if (jmd.eq.1) then
+ !! temperature-dependent
+ fdd = xmd * fun_T * zdet
+# if defined key_roam
+ fddc = xmdc * fun_T * zdtc
+# endif
+ elseif (jmd.eq.2) then
+ !! AXY (16/05/13): add in Q10-based parameterisation (def in nmlst)
+ !! temperature-dependent
+ fdd = xmd * fun_Q10 * zdet
+# if defined key_roam
+ fddc = xmdc * fun_Q10 * zdtc
+# endif
+ else
+ !! temperature-independent
+ fdd = xmd * zdet
+# if defined key_roam
+ fddc = xmdc * zdtc
+# endif
+ endif
+ !!
+ !! AXY (22/07/09): accelerate detrital remineralisation in the bottom box
+ if ((jk.eq.jmbathy) .and. jsfd.eq.1) then
+ fdd = 1.0 * zdet
+# if defined key_roam
+ fddc = 1.0 * zdtc
+# endif
+ endif
+
+# if defined key_debug_medusa
+ !! report plankton mortality and remineralisation
+ if (idf.eq.1.AND.idfval.eq.1) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'fdpn2(',jk,') = ', fdpn2
+ IF (lwp) write (numout,*) 'fdpd2(',jk,') = ', fdpd2
+ IF (lwp) write (numout,*) 'fdpds2(',jk,')= ', fdpds2
+ IF (lwp) write (numout,*) 'fdzmi2(',jk,')= ', fdzmi2
+ IF (lwp) write (numout,*) 'fdzme2(',jk,')= ', fdzme2
+ IF (lwp) write (numout,*) 'fdpn(',jk,') = ', fdpn
+ IF (lwp) write (numout,*) 'fdpd(',jk,') = ', fdpd
+ IF (lwp) write (numout,*) 'fdpds(',jk,') = ', fdpds
+ IF (lwp) write (numout,*) 'fdzmi(',jk,') = ', fdzmi
+ IF (lwp) write (numout,*) 'fdzme(',jk,') = ', fdzme
+ IF (lwp) write (numout,*) 'fdd(',jk,') = ', fdd
+# if defined key_roam
+ IF (lwp) write (numout,*) 'fddc(',jk,') = ', fddc
+# endif
+ endif
+# endif
+
+ !!----------------------------------------------------------------------
+ !! Detritus addition to benthos
+ !! If activated, slow detritus in the bottom box will enter the
+ !! benthic pool
+ !!----------------------------------------------------------------------
+ !!
+ if ((jk.eq.jmbathy) .and. jorgben.eq.1) then
+ !! this is the BOTTOM OCEAN BOX -> into the benthic pool!
+ !!
+ f_sbenin_n(ji,jj) = (zdet * vsed * 86400.)
+ f_sbenin_fe(ji,jj) = (zdet * vsed * 86400. * xrfn)
+# if defined key_roam
+ f_sbenin_c(ji,jj) = (zdtc * vsed * 86400.)
+# else
+ f_sbenin_c(ji,jj) = (zdet * vsed * 86400. * xthetad)
+# endif
+ endif
+
+ !!----------------------------------------------------------------------
+ !! Iron chemistry and fractionation
+ !! following the Parekh et al. (2004) scheme adopted by the Met.
+ !! Office, Medusa models total iron but considers "free" and
+ !! ligand-bound forms for the purposes of scavenging (only "free"
+ !! iron can be scavenged
+ !!----------------------------------------------------------------------
+ !!
+ !! total iron concentration (mmol Fe / m3 -> umol Fe / m3)
+ xFeT = zfer * 1.e3
+ !!
+ !! calculate fractionation (based on Diat-HadOCC; in turn based on Parekh et al., 2004)
+ xb_coef_tmp = xk_FeL * (xLgT - xFeT) - 1.0
+ xb2M4ac = max(((xb_coef_tmp * xb_coef_tmp) + (4.0 * xk_FeL * xLgT)), 0.0)
+ !!
+ !! "free" ligand concentration
+ xLgF = 0.5 * (xb_coef_tmp + (xb2M4ac**0.5)) / xk_FeL
+ !!
+ !! ligand-bound iron concentration
+ xFeL = xLgT - xLgF
+ !!
+ !! "free" iron concentration (and convert to mmol Fe / m3)
+ xFeF = (xFeT - xFeL) * 1.e-3
+ xFree(ji,jj)= xFeF / (zfer + tiny(zfer))
+ !!
+ !! scavenging of iron (multiple schemes); I'm only really happy with the
+ !! first one at the moment - the others involve assumptions (sometimes
+ !! guessed at by me) that are potentially questionable
+ !!
+ if (jiron.eq.1) then
+ !!----------------------------------------------------------------------
+ !! Scheme 1: Dutkiewicz et al. (2005)
+ !! This scheme includes a single scavenging term based solely on a
+ !! fixed rate and the availablility of "free" iron
+ !!----------------------------------------------------------------------
+ !!
+ ffescav = xk_sc_Fe * xFeF ! = mmol/m3/d
+ !!
+ !!----------------------------------------------------------------------
+ !!
+ !! Mick's code contains a further (optional) implicit "scavenging" of
+ !! iron that sets an upper bound on "free" iron concentration, and
+ !! essentially caps the concentration of total iron as xFeL + "free"
+ !! iron; since the former is constrained by a fixed total ligand
+ !! concentration (= 1.0 umol/m3), and the latter isn't allowed above
+ !! this upper bound, total iron is constrained to a maximum of ...
+ !!
+ !! xFeL + min(xFeF, 0.3 umol/m3) = 1.0 + 0.3 = 1.3 umol / m3
+ !!
+ !! In Mick's code, the actual value of total iron is reset to this
+ !! sum (i.e. TFe = FeL + Fe'; but Fe' <= 0.3 umol/m3); this isn't
+ !! our favoured approach to tracer updating here (not least because
+ !! of the leapfrog), so here the amount scavenged is augmented by an
+ !! additional amount that serves to drag total iron back towards that
+ !! expected from this limitation on iron concentration ...
+ !!
+ xmaxFeF = min((xFeF * 1.e3), 0.3) ! = umol/m3
+ !!
+ !! Here, the difference between current total Fe and (FeL + Fe') is
+ !! calculated and added to the scavenging flux already calculated
+ !! above ...
+ !!
+ fdeltaFe = (xFeT - (xFeL + xmaxFeF)) * 1.e-3 ! = mmol/m3
+ !!
+ !! This assumes that the "excess" iron is dissipated with a time-
+ !! scale of 1 day; seems reasonable to me ... (famous last words)
+ !!
+ ffescav = ffescav + fdeltaFe ! = mmol/m3/d
+ !!
+# if defined key_deep_fe_fix
+ !! AXY (17/01/13)
+ !! stop scavenging for iron concentrations below 0.5 umol / m3
+ !! at depths greater than 1000 m; this aims to end MEDUSA's
+ !! continual loss of iron at depth without impacting things
+ !! at the surface too much; the justification for this is that
+ !! it appears to be what Mick Follows et al. do in their work
+ !! (as evidenced by the iron initial condition they supplied
+ !! me with); to be honest, it looks like Follow et al. do this
+ !! at shallower depths than 1000 m, but I'll stick with this
+ !! for now; I suspect that this seemingly arbitrary approach
+ !! effectively "parameterises" the particle-based scavenging
+ !! rates that other models use (i.e. at depth there are no
+ !! sinking particles, so scavenging stops); it might be fun
+ !! justifying this in a paper though!
+ !!
+ if ((fdep.gt.1000.) .and. (xFeT.lt.0.5)) then
+ ffescav = 0.
+ endif
+# endif
+ !!
+ elseif (jiron.eq.2) then
+ !!----------------------------------------------------------------------
+ !! Scheme 2: Moore et al. (2004)
+ !! This scheme includes a single scavenging term that accounts for
+ !! both suspended and sinking particles in the water column; this
+ !! term scavenges total iron rather than "free" iron
+ !!----------------------------------------------------------------------
+ !!
+ !! total iron concentration (mmol Fe / m3 -> umol Fe / m3)
+ xFeT = zfer * 1.e3
+ !!
+ !! this has a base scavenging rate (12% / y) which is modified by local
+ !! particle concentration and sinking flux (and dust - but I'm ignoring
+ !! that here for now) and which is accelerated when Fe concentration gets
+ !! 0.6 nM (= 0.6 umol/m3 = 0.0006 mmol/m3), and decreased as concentrations
+ !! below 0.4 nM (= 0.4 umol/m3 = 0.0004 mmol/m3)
+ !!
+ !! base scavenging rate (0.12 / y)
+ fbase_scav = 0.12 / 365.25
+ !!
+ !! calculate sinking particle part of scaling factor
+ !! this takes local fast sinking carbon (mmol C / m2 / d) and
+ !! gets it into nmol C / cm3 / s ("rdt" below is the number of seconds in
+ !! a model timestep)
+ !!
+ !! fscal_sink = ffastc(ji,jj) * 1.e2 / (86400.)
+ !!
+ !! ... actually, re-reading Moore et al.'s equations, it looks like he uses
+ !! his sinking flux directly, without scaling it by time-step or anything,
+ !! so I'll copy this here ...
+ !!
+ fscal_sink = ffastc(ji,jj) * 1.e2
+ !!
+ !! calculate particle part of scaling factor
+ !! this totals up the carbon in suspended particles (Pn, Pd, Zmi, Zme, D),
+ !! which comes out in mmol C / m3 (= nmol C / cm3), and then multiplies it
+ !! by a magic factor, 0.002, to get it into nmol C / cm2 / s
+ !!
+ fscal_part = ((xthetapn * zphn) + (xthetapd * zphd) + (xthetazmi * zzmi) + &
+ (xthetazme * zzme) + (xthetad * zdet)) * 0.002
+ !!
+ !! calculate scaling factor for base scavenging rate
+ !! this uses the (now correctly scaled) sinking flux and standing
+ !! particle concentration, divides through by some sort of reference
+ !! value (= 0.0066 nmol C / cm2 / s) and then uses this, or not if its
+ !! too high, to rescale the base scavenging rate
+ !!
+ fscal_scav = fbase_scav * min(((fscal_sink + fscal_part) / 0.0066), 4.0)
+ !!
+ !! the resulting scavenging rate is then scaled further according to the
+ !! local iron concentration (i.e. diminished in low iron regions; enhanced
+ !! in high iron regions; less alone in intermediate iron regions)
+ !!
+ if (xFeT.lt.0.4) then
+ !!
+ !! low iron region
+ !!
+ fscal_scav = fscal_scav * (xFeT / 0.4)
+ !!
+ elseif (xFeT.gt.0.6) then
+ !!
+ !! high iron region
+ !!
+ fscal_scav = fscal_scav + ((xFeT / 0.6) * (6.0 / 1.4))
+ !!
+ else
+ !!
+ !! intermediate iron region: do nothing
+ !!
+ endif
+ !!
+ !! apply the calculated scavenging rate ...
+ !!
+ ffescav = fscal_scav * zfer
+ !!
+ elseif (jiron.eq.3) then
+ !!----------------------------------------------------------------------
+ !! Scheme 3: Moore et al. (2008)
+ !! This scheme includes a single scavenging term that accounts for
+ !! sinking particles in the water column, and includes organic C,
+ !! biogenic opal, calcium carbonate and dust in this (though the
+ !! latter is ignored here until I work out what units the incoming
+ !! "dust" flux is in); this term scavenges total iron rather than
+ !! "free" iron
+ !!----------------------------------------------------------------------
+ !!
+ !! total iron concentration (mmol Fe / m3 -> umol Fe / m3)
+ xFeT = zfer * 1.e3
+ !!
+ !! this has a base scavenging rate which is modified by local
+ !! particle sinking flux (including dust - but I'm ignoring that
+ !! here for now) and which is accelerated when Fe concentration
+ !! is > 0.6 nM (= 0.6 umol/m3 = 0.0006 mmol/m3), and decreased as
+ !! concentrations < 0.5 nM (= 0.5 umol/m3 = 0.0005 mmol/m3)
+ !!
+ !! base scavenging rate (Fe_b in paper; units may be wrong there)
+ fbase_scav = 0.00384 ! (ng)^-1 cm
+ !!
+ !! calculate sinking particle part of scaling factor; this converts
+ !! mmol / m2 / d fluxes of organic carbon, silicon and calcium
+ !! carbonate into ng / cm2 / s fluxes; it is assumed here that the
+ !! mass conversions simply consider the mass of the main element
+ !! (C, Si and Ca) and *not* the mass of the molecules that they are
+ !! part of; Moore et al. (2008) is unclear on the conversion that
+ !! should be used
+ !!
+ !! milli -> nano; mol -> gram; /m2 -> /cm2; /d -> /s
+ fscal_csink = (ffastc(ji,jj) * 1.e6 * xmassc * 1.e-4 / 86400.) ! ng C / cm2 / s
+ fscal_sisink = (ffastsi(ji,jj) * 1.e6 * xmasssi * 1.e-4 / 86400.) ! ng Si / cm2 / s
+ fscal_casink = (ffastca(ji,jj) * 1.e6 * xmassca * 1.e-4 / 86400.) ! ng Ca / cm2 / s
+ !!
+ !! sum up these sinking fluxes and convert to ng / cm by dividing
+ !! through by a sinking rate of 100 m / d = 1.157 cm / s
+ fscal_sink = ((fscal_csink * 6.) + fscal_sisink + fscal_casink) / &
+ (100. * 1.e3 / 86400) ! ng / cm
+ !!
+ !! now calculate the scavenging rate based upon the base rate and
+ !! this particle flux scaling; according to the published units,
+ !! the result actually has *no* units, but as it must be expressed
+ !! per unit time for it to make any sense, I'm assuming a missing
+ !! "per second"
+ fscal_scav = fbase_scav * fscal_sink ! / s
+ !!
+ !! the resulting scavenging rate is then scaled further according to the
+ !! local iron concentration (i.e. diminished in low iron regions; enhanced
+ !! in high iron regions; less alone in intermediate iron regions)
+ !!
+ if (xFeT.lt.0.5) then
+ !!
+ !! low iron region (0.5 instead of the 0.4 in Moore et al., 2004)
+ !!
+ fscal_scav = fscal_scav * (xFeT / 0.5)
+ !!
+ elseif (xFeT.gt.0.6) then
+ !!
+ !! high iron region (functional form different in Moore et al., 2004)
+ !!
+ fscal_scav = fscal_scav + ((xFeT - 0.6) * 0.00904)
+ !!
+ else
+ !!
+ !! intermediate iron region: do nothing
+ !!
+ endif
+ !!
+ !! apply the calculated scavenging rate ...
+ !!
+ ffescav = fscal_scav * zfer
+ !!
+ elseif (jiron.eq.4) then
+ !!----------------------------------------------------------------------
+ !! Scheme 4: Galbraith et al. (2010)
+ !! This scheme includes two scavenging terms, one for organic,
+ !! particle-based scavenging, and another for inorganic scavenging;
+ !! both terms scavenge "free" iron only
+ !!----------------------------------------------------------------------
+ !!
+ !! Galbraith et al. (2010) present a more straightforward outline of
+ !! the scheme in Parekh et al. (2005) ...
+ !!
+ !! sinking particulate carbon available for scavenging
+ !! this assumes a sinking rate of 100 m / d (Moore & Braucher, 2008),
+ xCscav1 = (ffastc(ji,jj) * xmassc) / 100. ! = mg C / m3
+ !!
+ !! scale by Honeyman et al. (1981) exponent coefficient
+ !! multiply by 1.e-3 to express C flux in g C rather than mg C
+ xCscav2 = (xCscav1 * 1.e-3)**0.58
+ !!
+ !! multiply by Galbraith et al. (2010) scavenging rate
+ xk_org = 0.5 ! ((g C m/3)^-1) / d
+ xORGscav = xk_org * xCscav2 * xFeF
+ !!
+ !! Galbraith et al. (2010) also include an inorganic bit ...
+ !!
+ !! this occurs at a fixed rate, again based on the availability of
+ !! "free" iron
+ !!
+ !! k_inorg = 1000 d**-1 nmol Fe**-0.5 kg**-0.5
+ !!
+ !! to implement this here, scale xFeF by 1026 to put in units of
+ !! umol/m3 which approximately equal nmol/kg
+ !!
+ xk_inorg = 1000. ! ((nmol Fe / kg)^1.5)
+ xINORGscav = (xk_inorg * (xFeF * 1026.)**1.5) * 1.e-3
+ !!
+ !! sum these two terms together
+ ffescav = xORGscav + xINORGscav
+ else
+ !!----------------------------------------------------------------------
+ !! No Scheme: you coward!
+ !! This scheme puts its head in the sand and eskews any decision about
+ !! how iron is removed from the ocean; prepare to get deluged in iron
+ !! you fool!
+ !!----------------------------------------------------------------------
+ ffescav = 0.
+ endif
+
+ !!----------------------------------------------------------------------
+ !! Other iron cycle processes
+ !!----------------------------------------------------------------------
+ !!
+ !! aeolian iron deposition
+ if (jk.eq.1) then
+ !! zirondep is in mmol-Fe / m2 / day
+ !! ffetop is in mmol-dissolved-Fe / m3 / day
+ ffetop = zirondep(ji,jj) * xfe_sol / fthk
+ else
+ ffetop = 0.0
+ endif
+ !!
+ !! seafloor iron addition
+ !! AXY (10/07/12): amended to only apply sedimentary flux up to ~500 m down
+ !! if (jk.eq.(mbathy(ji,jj)-1).AND.jk.lt.i1100) then
+ if ((jk.eq.jmbathy).AND.jk.le.i0500) then
+ !! Moore et al. (2004) cite a coastal California value of 5 umol/m2/d, but adopt a
+ !! global value of 2 umol/m2/d for all areas < 1100 m; here we use this latter value
+ !! but apply it everywhere
+ !! AXY (21/07/09): actually, let's just apply it below 1100 m (levels 1-37)
+ ffebot = (xfe_sed / fthk)
+ else
+ ffebot = 0.0
+ endif
+
+ !! AXY (16/12/09): remove iron addition/removal processes
+ !! For the purposes of the quarter degree run, the iron cycle is being pegged to the
+ !! initial condition supplied by Mick Follows via restoration with a 30 day period;
+ !! iron addition at the seafloor is still permitted with the idea that this extra
+ !! iron will be removed by the restoration away from the source
+ !! ffescav = 0.0
+ !! ffetop = 0.0
+ !! ffebot = 0.0
+
+# if defined key_debug_medusa
+ !! report miscellaneous calculations
+ if (idf.eq.1.AND.idfval.eq.1) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'xfe_sol = ', xfe_sol
+ IF (lwp) write (numout,*) 'xfe_mass = ', xfe_mass
+ IF (lwp) write (numout,*) 'ffetop(',jk,') = ', ffetop
+ IF (lwp) write (numout,*) 'ffebot(',jk,') = ', ffebot
+ IF (lwp) write (numout,*) 'xFree(',jk,') = ', xFree(ji,jj)
+ IF (lwp) write (numout,*) 'ffescav(',jk,') = ', ffescav
+ endif
+# endif
+
+ !!----------------------------------------------------------------------
+ !! Miscellaneous
+ !!----------------------------------------------------------------------
+ !!
+ !! diatom frustule dissolution
+ fsdiss = xsdiss * zpds
+
+# if defined key_debug_medusa
+ !! report miscellaneous calculations
+ if (idf.eq.1.AND.idfval.eq.1) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'fsdiss(',jk,') = ', fsdiss
+ endif
+# endif
+
+ !!----------------------------------------------------------------------
+ !! Slow detritus creation
+ !!----------------------------------------------------------------------
+ !! this variable integrates the creation of slow sinking detritus
+ !! to allow the split between fast and slow detritus to be
+ !! diagnosed
+ fslown = fdpn + fdzmi + ((1.0 - xfdfrac1) * fdpd) + &
+ ((1.0 - xfdfrac2) * fdzme) + ((1.0 - xbetan) * (finmi + finme))
+ !!
+ !! this variable records the slow detrital sinking flux at this
+ !! particular depth; it is used in the output of this flux at
+ !! standard depths in the diagnostic outputs; needs to be
+ !! adjusted from per second to per day because of parameter vsed
+ fslownflux(ji,jj) = zdet * vsed * 86400.
+# if defined key_roam
+ !!
+ !! and the same for detrital carbon
+ fslowc = (xthetapn * fdpn) + (xthetazmi * fdzmi) + &
+ (xthetapd * (1.0 - xfdfrac1) * fdpd) + &
+ (xthetazme * (1.0 - xfdfrac2) * fdzme) + &
+ ((1.0 - xbetac) * (ficmi + ficme))
+ !!
+ !! this variable records the slow detrital sinking flux at this
+ !! particular depth; it is used in the output of this flux at
+ !! standard depths in the diagnostic outputs; needs to be
+ !! adjusted from per second to per day because of parameter vsed
+ fslowcflux(ji,jj) = zdtc * vsed * 86400.
+# endif
+
+ !!----------------------------------------------------------------------
+ !! Nutrient regeneration
+ !! this variable integrates total nitrogen regeneration down the
+ !! watercolumn; its value is stored and output as a 2D diagnostic;
+ !! the corresponding dissolution flux of silicon (from sources
+ !! other than fast detritus) is also integrated; note that,
+ !! confusingly, the linear loss terms from plankton compartments
+ !! are labelled as fdX2 when one might have expected fdX or fdX1
+ !!----------------------------------------------------------------------
+ !!
+ !! nitrogen
+ fregen = (( (xphi * (fgmipn + fgmid)) + & ! messy feeding
+ (xphi * (fgmepn + fgmepd + fgmezmi + fgmed)) + & ! messy feeding
+ fmiexcr + fmeexcr + fdd + & ! excretion + D remin.
+ fdpn2 + fdpd2 + fdzmi2 + fdzme2) * fthk) ! linear mortality
+ !!
+ !! silicon
+ fregensi = (( fsdiss + ((1.0 - xfdfrac1) * fdpds) + & ! dissolution + non-lin. mortality
+ ((1.0 - xfdfrac3) * fgmepds) + & ! egestion by zooplankton
+ fdpds2) * fthk) ! linear mortality
+# if defined key_roam
+ !!
+ !! carbon
+ fregenc = (( (xphi * ((xthetapn * fgmipn) + fgmidc)) + & ! messy feeding
+ (xphi * ((xthetapn * fgmepn) + (xthetapd * fgmepd) + & ! messy feeding
+ (xthetazmi * fgmezmi) + fgmedc)) + & ! messy feeding
+ fmiresp + fmeresp + fddc + & ! respiration + D remin.
+ (xthetapn * fdpn2) + (xthetapd * fdpd2) + & ! linear mortality
+ (xthetazmi * fdzmi2) + (xthetazme * fdzme2)) * fthk) ! linear mortality
+# endif
+
+ !!----------------------------------------------------------------------
+ !! Fast-sinking detritus terms
+ !! "local" variables declared so that conservation can be checked;
+ !! the calculated terms are added to the fast-sinking flux later on
+ !! only after the flux entering this level has experienced some
+ !! remineralisation
+ !! note: these fluxes need to be scaled by the level thickness
+ !!----------------------------------------------------------------------
+ !!
+ !! nitrogen: diatom and mesozooplankton mortality
+ ftempn = b0 * ((xfdfrac1 * fdpd) + (xfdfrac2 * fdzme))
+ !!
+ !! silicon: diatom mortality and grazed diatoms
+ ftempsi = b0 * ((xfdfrac1 * fdpds) + (xfdfrac3 * fgmepds))
+ !!
+ !! iron: diatom and mesozooplankton mortality
+ ftempfe = b0 * (((xfdfrac1 * fdpd) + (xfdfrac2 * fdzme)) * xrfn)
+ !!
+ !! carbon: diatom and mesozooplankton mortality
+ ftempc = b0 * ((xfdfrac1 * xthetapd * fdpd) + &
+ (xfdfrac2 * xthetazme * fdzme))
+ !!
+# if defined key_roam
+ if (jrratio.eq.0) then
+ !! CaCO3: latitudinally-based fraction of total primary production
+ !! absolute latitude of current grid cell
+ flat = abs(gphit(ji,jj))
+ !! 0.10 at equator; 0.02 at pole
+ fcaco3 = xcaco3a + ((xcaco3b - xcaco3a) * ((90.0 - flat) / 90.0))
+ elseif (jrratio.eq.1) then
+ !! CaCO3: Ridgwell et al. (2007) submodel, version 1
+ !! this uses SURFACE omega calcite to regulate rain ratio
+ if (f_omcal(ji,jj).ge.1.0) then
+ fq1 = (f_omcal(ji,jj) - 1.0)**0.81
+ else
+ fq1 = 0.
+ endif
+ fcaco3 = xridg_r0 * fq1
+ elseif (jrratio.eq.2) then
+ !! CaCO3: Ridgwell et al. (2007) submodel, version 2
+ !! this uses FULL 3D omega calcite to regulate rain ratio
+ if (f3_omcal(ji,jj,jk).ge.1.0) then
+ fq1 = (f3_omcal(ji,jj,jk) - 1.0)**0.81
+ else
+ fq1 = 0.
+ endif
+ fcaco3 = xridg_r0 * fq1
+ endif
+# else
+ !! CaCO3: latitudinally-based fraction of total primary production
+ !! absolute latitude of current grid cell
+ flat = abs(gphit(ji,jj))
+ !! 0.10 at equator; 0.02 at pole
+ fcaco3 = xcaco3a + ((xcaco3b - xcaco3a) * ((90.0 - flat) / 90.0))
+# endif
+ !! AXY (09/03/09): convert CaCO3 production from function of
+ !! primary production into a function of fast-sinking material;
+ !! technically, this is what Dunne et al. (2007) do anyway; they
+ !! convert total primary production estimated from surface
+ !! chlorophyll to an export flux for which they apply conversion
+ !! factors to estimate the various elemental fractions (Si, Ca)
+ ftempca = ftempc * fcaco3
+
+# if defined key_debug_medusa
+ !! integrate total fast detritus production
+ if (idf.eq.1) then
+ fifd_n(ji,jj) = fifd_n(ji,jj) + (ftempn * fthk)
+ fifd_si(ji,jj) = fifd_si(ji,jj) + (ftempsi * fthk)
+ fifd_fe(ji,jj) = fifd_fe(ji,jj) + (ftempfe * fthk)
+# if defined key_roam
+ fifd_c(ji,jj) = fifd_c(ji,jj) + (ftempc * fthk)
+# endif
+ endif
+
+ !! report quantities of fast-sinking detritus for each component
+ if (idf.eq.1.AND.idfval.eq.1) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'fdpd(',jk,') = ', fdpd
+ IF (lwp) write (numout,*) 'fdzme(',jk,') = ', fdzme
+ IF (lwp) write (numout,*) 'ftempn(',jk,') = ', ftempn
+ IF (lwp) write (numout,*) 'ftempsi(',jk,') = ', ftempsi
+ IF (lwp) write (numout,*) 'ftempfe(',jk,') = ', ftempfe
+ IF (lwp) write (numout,*) 'ftempc(',jk,') = ', ftempc
+ IF (lwp) write (numout,*) 'ftempca(',jk,') = ', ftempca
+ IF (lwp) write (numout,*) 'flat(',jk,') = ', flat
+ IF (lwp) write (numout,*) 'fcaco3(',jk,') = ', fcaco3
+ endif
+# endif
+
+ !!----------------------------------------------------------------------
+ !! This version of MEDUSA offers a choice of three methods for
+ !! handling the remineralisation of fast detritus. All three
+ !! do so in broadly the same way:
+ !!
+ !! 1. Fast detritus is stored as a 2D array [ ffastX ]
+ !! 2. Fast detritus is added level-by-level [ ftempX ]
+ !! 3. Fast detritus is not remineralised in the top box [ freminX ]
+ !! 4. Remaining fast detritus is remineralised in the bottom [ fsedX ]
+ !! box
+ !!
+ !! The three remineralisation methods are:
+ !!
+ !! 1. Ballast model (i.e. that published in Yool et al., 2011)
+ !! (1b. Ballast-sans-ballast model)
+ !! 2. Martin et al. (1987)
+ !! 3. Henson et al. (2011)
+ !!
+ !! The first of these couples C, N and Fe remineralisation to
+ !! the remineralisation of particulate Si and CaCO3, but the
+ !! latter two treat remineralisation of C, N, Fe, Si and CaCO3
+ !! completely separately. At present a switch within the code
+ !! regulates which submodel is used, but this should be moved
+ !! to the namelist file.
+ !!
+ !! The ballast-sans-ballast submodel is an original development
+ !! feature of MEDUSA in which the ballast submodel's general
+ !! framework and parameterisation is used, but in which there
+ !! is no protection of organic material afforded by ballasting
+ !! minerals. While similar, it is not the same as the Martin
+ !! et al. (1987) submodel.
+ !!
+ !! Since the three submodels behave the same in terms of
+ !! accumulating sinking material and remineralising it all at
+ !! the seafloor, these portions of the code below are common to
+ !! all three.
+ !!----------------------------------------------------------------------
+
+ if (jexport.eq.1) then
+ !!======================================================================
+ !! BALLAST SUBMODEL
+ !!======================================================================
+ !!
+ !!----------------------------------------------------------------------
+ !! Fast-sinking detritus fluxes, pt. 1: REMINERALISATION
+ !! aside from explicitly modelled, slow-sinking detritus, the
+ !! model includes an implicit representation of detrital
+ !! particles that sink too quickly to be modelled with
+ !! explicit state variables; this sinking flux is instead
+ !! instantaneously remineralised down the water column using
+ !! the version of Armstrong et al. (2002)'s ballast model
+ !! used by Dunne et al. (2007); the version of this model
+ !! here considers silicon and calcium carbonate ballast
+ !! minerals; this section of the code redistributes the fast
+ !! sinking material generated locally down the water column;
+ !! this differs from Dunne et al. (2007) in that fast sinking
+ !! material is distributed at *every* level below that it is
+ !! generated, rather than at every level below some fixed
+ !! depth; this scheme is also different in that sinking material
+ !! generated in one level is aggregated with that generated by
+ !! shallower levels; this should make the ballast model more
+ !! self-consistent (famous last words)
+ !!----------------------------------------------------------------------
+ !!
+ if (jk.eq.1) then
+ !! this is the SURFACE OCEAN BOX (no remineralisation)
+ !!
+ freminc = 0.0
+ freminn = 0.0
+ freminfe = 0.0
+ freminsi = 0.0
+ freminca = 0.0
+ elseif (jk.le.jmbathy) then
+ !! this is an OCEAN BOX (remineralise some material)
+ !!
+ !! set up CCD depth to be used depending on user choice
+ if (jocalccd.eq.0) then
+ !! use default CCD field
+ fccd_dep = ocal_ccd(ji,jj)
+ elseif (jocalccd.eq.1) then
+ !! use calculated CCD field
+ fccd_dep = f2_ccd_cal(ji,jj)
+ endif
+ !!
+ !! === organic carbon ===
+ fq0 = ffastc(ji,jj) !! how much organic C enters this box (mol)
+ if (iball.eq.1) then
+ fq1 = (fq0 * xmassc) !! how much it weighs (mass)
+ fq2 = (ffastca(ji,jj) * xmassca) !! how much CaCO3 enters this box (mass)
+ fq3 = (ffastsi(ji,jj) * xmasssi) !! how much opal enters this box (mass)
+ fq4 = (fq2 * xprotca) + (fq3 * xprotsi) !! total protected organic C (mass)
+ !! this next term is calculated for C but used for N and Fe as well
+ !! it needs to be protected in case ALL C is protected
+ if (fq4.lt.fq1) then
+ fprotf = (fq4 / (fq1 + tiny(fq1))) !! protected fraction of total organic C (non-dim)
+ else
+ fprotf = 1.0 !! all organic C is protected (non-dim)
+ endif
+ fq5 = (1.0 - fprotf) !! unprotected fraction of total organic C (non-dim)
+ fq6 = (fq0 * fq5) !! how much organic C is unprotected (mol)
+ fq7 = (fq6 * exp(-(fthk / xfastc))) !! how much unprotected C leaves this box (mol)
+ fq8 = (fq7 + (fq0 * fprotf)) !! how much total C leaves this box (mol)
+ freminc = (fq0 - fq8) / fthk !! C remineralisation in this box (mol)
+ ffastc(ji,jj) = fq8
+# if defined key_debug_medusa
+ !! report in/out/remin fluxes of carbon for this level
+ if (idf.eq.1.AND.idfval.eq.1) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'totalC(',jk,') = ', fq1
+ IF (lwp) write (numout,*) 'prtctC(',jk,') = ', fq4
+ IF (lwp) write (numout,*) 'fprotf(',jk,') = ', fprotf
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'IN C(',jk,') = ', fq0
+ IF (lwp) write (numout,*) 'LOST C(',jk,') = ', freminc * fthk
+ IF (lwp) write (numout,*) 'OUT C(',jk,') = ', fq8
+ IF (lwp) write (numout,*) 'NEW C(',jk,') = ', ftempc * fthk
+ endif
+# endif
+ else
+ fq1 = fq0 * exp(-(fthk / xfastc)) !! how much organic C leaves this box (mol)
+ freminc = (fq0 - fq1) / fthk !! C remineralisation in this box (mol)
+ ffastc(ji,jj) = fq1
+ endif
+ !!
+ !! === organic nitrogen ===
+ fq0 = ffastn(ji,jj) !! how much organic N enters this box (mol)
+ if (iball.eq.1) then
+ fq5 = (1.0 - fprotf) !! unprotected fraction of total organic N (non-dim)
+ fq6 = (fq0 * fq5) !! how much organic N is unprotected (mol)
+ fq7 = (fq6 * exp(-(fthk / xfastc))) !! how much unprotected N leaves this box (mol)
+ fq8 = (fq7 + (fq0 * fprotf)) !! how much total N leaves this box (mol)
+ freminn = (fq0 - fq8) / fthk !! N remineralisation in this box (mol)
+ ffastn(ji,jj) = fq8
+# if defined key_debug_medusa
+ !! report in/out/remin fluxes of carbon for this level
+ if (idf.eq.1.AND.idfval.eq.1) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'totalN(',jk,') = ', fq1
+ IF (lwp) write (numout,*) 'prtctN(',jk,') = ', fq4
+ IF (lwp) write (numout,*) 'fprotf(',jk,') = ', fprotf
+ IF (lwp) write (numout,*) '------------------------------'
+ if (freminn < 0.0) then
+ IF (lwp) write (numout,*) '** FREMIN ERROR **'
+ endif
+ IF (lwp) write (numout,*) 'IN N(',jk,') = ', fq0
+ IF (lwp) write (numout,*) 'LOST N(',jk,') = ', freminn * fthk
+ IF (lwp) write (numout,*) 'OUT N(',jk,') = ', fq8
+ IF (lwp) write (numout,*) 'NEW N(',jk,') = ', ftempn * fthk
+ endif
+# endif
+ else
+ fq1 = fq0 * exp(-(fthk / xfastc)) !! how much organic N leaves this box (mol)
+ freminn = (fq0 - fq1) / fthk !! N remineralisation in this box (mol)
+ ffastn(ji,jj) = fq1
+ endif
+ !!
+ !! === organic iron ===
+ fq0 = ffastfe(ji,jj) !! how much organic Fe enters this box (mol)
+ if (iball.eq.1) then
+ fq5 = (1.0 - fprotf) !! unprotected fraction of total organic Fe (non-dim)
+ fq6 = (fq0 * fq5) !! how much organic Fe is unprotected (mol)
+ fq7 = (fq6 * exp(-(fthk / xfastc))) !! how much unprotected Fe leaves this box (mol)
+ fq8 = (fq7 + (fq0 * fprotf)) !! how much total Fe leaves this box (mol)
+ freminfe = (fq0 - fq8) / fthk !! Fe remineralisation in this box (mol)
+ ffastfe(ji,jj) = fq8
+ else
+ fq1 = fq0 * exp(-(fthk / xfastc)) !! how much total Fe leaves this box (mol)
+ freminfe = (fq0 - fq1) / fthk !! Fe remineralisation in this box (mol)
+ ffastfe(ji,jj) = fq1
+ endif
+ !!
+ !! === biogenic silicon ===
+ fq0 = ffastsi(ji,jj) !! how much opal centers this box (mol)
+ fq1 = fq0 * exp(-(fthk / xfastsi)) !! how much opal leaves this box (mol)
+ freminsi = (fq0 - fq1) / fthk !! Si remineralisation in this box (mol)
+ ffastsi(ji,jj) = fq1
+ !!
+ !! === biogenic calcium carbonate ===
+ fq0 = ffastca(ji,jj) !! how much CaCO3 enters this box (mol)
+ if (fdep.le.fccd_dep) then
+ !! whole grid cell above CCD
+ fq1 = fq0 !! above lysocline, no Ca dissolves (mol)
+ freminca = 0.0 !! above lysocline, no Ca dissolves (mol)
+ fccd(ji,jj) = real(jk) !! which is the last level above the CCD? (#)
+ elseif (fdep.ge.fccd_dep) then
+ !! whole grid cell below CCD
+ fq1 = fq0 * exp(-(fthk / xfastca)) !! how much CaCO3 leaves this box (mol)
+ freminca = (fq0 - fq1) / fthk !! Ca remineralisation in this box (mol)
+ else
+ !! partial grid cell below CCD
+ fq2 = fdep1 - fccd_dep !! amount of grid cell below CCD (m)
+ fq1 = fq0 * exp(-(fq2 / xfastca)) !! how much CaCO3 leaves this box (mol)
+ freminca = (fq0 - fq1) / fthk !! Ca remineralisation in this box (mol)
+ endif
+ ffastca(ji,jj) = fq1
+ else
+ !! this is BELOW THE LAST OCEAN BOX (do nothing)
+ freminc = 0.0
+ freminn = 0.0
+ freminfe = 0.0
+ freminsi = 0.0
+ freminca = 0.0
+ endif
+
+ elseif (jexport.eq.2.or.jexport.eq.3) then
+ if (jexport.eq.2) then
+ !!======================================================================
+ !! MARTIN ET AL. (1987) SUBMODEL
+ !!======================================================================
+ !!
+ !!----------------------------------------------------------------------
+ !! This submodel uses the classic Martin et al. (1987) curve
+ !! to determine the attenuation of fast-sinking detritus down
+ !! the water column. All three organic elements, C, N and Fe,
+ !! are handled identically, and their quantities in sinking
+ !! particles attenuate according to a power relationship
+ !! governed by parameter "b". This is assigned a canonical
+ !! value of -0.858. Biogenic opal and calcium carbonate are
+ !! attentuated using the same function as in the ballast
+ !! submodel
+ !!----------------------------------------------------------------------
+ !!
+ fb_val = -0.858
+ elseif (jexport.eq.3) then
+ !!======================================================================
+ !! HENSON ET AL. (2011) SUBMODEL
+ !!======================================================================
+ !!
+ !!----------------------------------------------------------------------
+ !! This submodel reconfigures the Martin et al. (1987) curve by
+ !! allowing the "b" value to vary geographically. Its value is
+ !! set, following Henson et al. (2011), as a function of local
+ !! sea surface temperature:
+ !! b = -1.06 + (0.024 * SST)
+ !! This means that remineralisation length scales are longer in
+ !! warm, tropical areas and shorter in cold, polar areas. This
+ !! does seem back-to-front (i.e. one would expect GREATER
+ !! remineralisation in warmer waters), but is an outcome of
+ !! analysis of sediment trap data, and it may reflect details
+ !! of ecosystem structure that pertain to particle production
+ !! rather than simply Q10.
+ !!----------------------------------------------------------------------
+ !!
+ fl_sst = tsn(ji,jj,1,jp_tem)
+ fb_val = -1.06 + (0.024 * fl_sst)
+ endif
+ !!
+ if (jk.eq.1) then
+ !! this is the SURFACE OCEAN BOX (no remineralisation)
+ !!
+ freminc = 0.0
+ freminn = 0.0
+ freminfe = 0.0
+ freminsi = 0.0
+ freminca = 0.0
+ elseif (jk.le.jmbathy) then
+ !! this is an OCEAN BOX (remineralise some material)
+ !!
+ !! === organic carbon ===
+ fq0 = ffastc(ji,jj) !! how much organic C enters this box (mol)
+ fq1 = fq0 * ((fdep1/fdep)**fb_val) !! how much organic C leaves this box (mol)
+ freminc = (fq0 - fq1) / fthk !! C remineralisation in this box (mol)
+ ffastc(ji,jj) = fq1
+ !!
+ !! === organic nitrogen ===
+ fq0 = ffastn(ji,jj) !! how much organic N enters this box (mol)
+ fq1 = fq0 * ((fdep1/fdep)**fb_val) !! how much organic N leaves this box (mol)
+ freminn = (fq0 - fq1) / fthk !! N remineralisation in this box (mol)
+ ffastn(ji,jj) = fq1
+ !!
+ !! === organic iron ===
+ fq0 = ffastfe(ji,jj) !! how much organic Fe enters this box (mol)
+ fq1 = fq0 * ((fdep1/fdep)**fb_val) !! how much organic Fe leaves this box (mol)
+ freminfe = (fq0 - fq1) / fthk !! Fe remineralisation in this box (mol)
+ ffastfe(ji,jj) = fq1
+ !!
+ !! === biogenic silicon ===
+ fq0 = ffastsi(ji,jj) !! how much opal centers this box (mol)
+ fq1 = fq0 * exp(-(fthk / xfastsi)) !! how much opal leaves this box (mol)
+ freminsi = (fq0 - fq1) / fthk !! Si remineralisation in this box (mol)
+ ffastsi(ji,jj) = fq1
+ !!
+ !! === biogenic calcium carbonate ===
+ fq0 = ffastca(ji,jj) !! how much CaCO3 enters this box (mol)
+ if (fdep.le.ocal_ccd(ji,jj)) then
+ !! whole grid cell above CCD
+ fq1 = fq0 !! above lysocline, no Ca dissolves (mol)
+ freminca = 0.0 !! above lysocline, no Ca dissolves (mol)
+ fccd(ji,jj) = real(jk) !! which is the last level above the CCD? (#)
+ elseif (fdep.ge.ocal_ccd(ji,jj)) then
+ !! whole grid cell below CCD
+ fq1 = fq0 * exp(-(fthk / xfastca)) !! how much CaCO3 leaves this box (mol)
+ freminca = (fq0 - fq1) / fthk !! Ca remineralisation in this box (mol)
+ else
+ !! partial grid cell below CCD
+ fq2 = fdep1 - ocal_ccd(ji,jj) !! amount of grid cell below CCD (m)
+ fq1 = fq0 * exp(-(fq2 / xfastca)) !! how much CaCO3 leaves this box (mol)
+ freminca = (fq0 - fq1) / fthk !! Ca remineralisation in this box (mol)
+ endif
+ ffastca(ji,jj) = fq1
+ else
+ !! this is BELOW THE LAST OCEAN BOX (do nothing)
+ freminc = 0.0
+ freminn = 0.0
+ freminfe = 0.0
+ freminsi = 0.0
+ freminca = 0.0
+ endif
+
+ endif
+
+ !!----------------------------------------------------------------------
+ !! Fast-sinking detritus fluxes, pt. 2: UPDATE FAST FLUXES
+ !! here locally calculated additions to the fast-sinking flux are added
+ !! to the total fast-sinking flux; this is done here such that material
+ !! produced in a particular layer is only remineralised below this
+ !! layer
+ !!----------------------------------------------------------------------
+ !!
+ !! add sinking material generated in this layer to running totals
+ !!
+ !! === organic carbon === (diatom and mesozooplankton mortality)
+ ffastc(ji,jj) = ffastc(ji,jj) + (ftempc * fthk)
+ !!
+ !! === organic nitrogen === (diatom and mesozooplankton mortality)
+ ffastn(ji,jj) = ffastn(ji,jj) + (ftempn * fthk)
+ !!
+ !! === organic iron === (diatom and mesozooplankton mortality)
+ ffastfe(ji,jj) = ffastfe(ji,jj) + (ftempfe * fthk)
+ !!
+ !! === biogenic silicon === (diatom mortality and grazed diatoms)
+ ffastsi(ji,jj) = ffastsi(ji,jj) + (ftempsi * fthk)
+ !!
+ !! === biogenic calcium carbonate === (latitudinally-based fraction of total primary production)
+ ffastca(ji,jj) = ffastca(ji,jj) + (ftempca * fthk)
+
+ !!----------------------------------------------------------------------
+ !! Fast-sinking detritus fluxes, pt. 3: SEAFLOOR
+ !! remineralise all remaining fast-sinking detritus to dissolved
+ !! nutrients; the sedimentation fluxes calculated here allow the
+ !! separation of what's remineralised sinking through the final
+ !! ocean box from that which is added to the final box by the
+ !! remineralisation of material that reaches the seafloor (i.e.
+ !! the model assumes that *all* material that hits the seafloor
+ !! is remineralised and that none is permanently buried; hey,
+ !! this is a giant GCM model that can't be run for long enough
+ !! to deal with burial fluxes!)
+ !!
+ !! in a change to this process, in part so that MEDUSA behaves
+ !! a little more like ERSEM et al., fast-sinking detritus (N, Fe
+ !! and C) is converted to slow sinking detritus at the seafloor
+ !! instead of being remineralised; the rationale is that in
+ !! shallower shelf regions (... that are not fully mixed!) this
+ !! allows the detrital material to return slowly to dissolved
+ !! nutrient rather than instantaneously as now; the alternative
+ !! would be to explicitly handle seafloor organic material - a
+ !! headache I don't wish to experience at this point; note that
+ !! fast-sinking Si and Ca detritus is just remineralised as
+ !! per usual
+ !!
+ !! AXY (13/01/12)
+ !! in a further change to this process, again so that MEDUSA is
+ !! a little more like ERSEM et al., material that reaches the
+ !! seafloor can now be added to sediment pools and stored for
+ !! slow release; there are new 2D arrays for organic nitrogen,
+ !! iron and carbon and inorganic silicon and carbon that allow
+ !! fast and slow detritus that reaches the seafloor to be held
+ !! and released back to the water column more slowly; these arrays
+ !! are transferred via the tracer restart files between repeat
+ !! submissions of the model
+ !!----------------------------------------------------------------------
+ !!
+ ffast2slowc = 0.0
+ ffast2slown = 0.0
+ ffast2slowfe = 0.0
+ !!
+ if (jk.eq.jmbathy) then
+ !! this is the BOTTOM OCEAN BOX (remineralise everything)
+ !!
+ !! AXY (17/01/12): tweaked to include benthos pools
+ !!
+ !! === organic carbon ===
+ if (jfdfate.eq.0 .and. jorgben.eq.0) then
+ freminc = freminc + (ffastc(ji,jj) / fthk) !! C remineralisation in this box (mol/m3)
+ elseif (jfdfate.eq.1 .and. jorgben.eq.0) then
+ ffast2slowc = ffastc(ji,jj) / fthk !! fast C -> slow C (mol/m3)
+ fslowc = fslowc + ffast2slowc
+ elseif (jfdfate.eq.0 .and. jorgben.eq.1) then
+ f_fbenin_c(ji,jj) = ffastc(ji,jj) !! fast C -> benthic C (mol/m2)
+ endif
+ fsedc(ji,jj) = ffastc(ji,jj) !! record seafloor C (mol/m2)
+ ffastc(ji,jj) = 0.0
+ !!
+ !! === organic nitrogen ===
+ if (jfdfate.eq.0 .and. jorgben.eq.0) then
+ freminn = freminn + (ffastn(ji,jj) / fthk) !! N remineralisation in this box (mol/m3)
+ elseif (jfdfate.eq.1 .and. jorgben.eq.0) then
+ ffast2slown = ffastn(ji,jj) / fthk !! fast N -> slow N (mol/m3)
+ fslown = fslown + ffast2slown
+ elseif (jfdfate.eq.0 .and. jorgben.eq.1) then
+ f_fbenin_n(ji,jj) = ffastn(ji,jj) !! fast N -> benthic N (mol/m2)
+ endif
+ fsedn(ji,jj) = ffastn(ji,jj) !! record seafloor N (mol/m2)
+ ffastn(ji,jj) = 0.0
+ !!
+ !! === organic iron ===
+ if (jfdfate.eq.0 .and. jorgben.eq.0) then
+ freminfe = freminfe + (ffastfe(ji,jj) / fthk) !! Fe remineralisation in this box (mol/m3)
+ elseif (jfdfate.eq.1 .and. jorgben.eq.0) then
+ ffast2slowfe = ffastn(ji,jj) / fthk !! fast Fe -> slow Fe (mol/m3)
+ elseif (jfdfate.eq.0 .and. jorgben.eq.1) then
+ f_fbenin_fe(ji,jj) = ffastfe(ji,jj) !! fast Fe -> benthic Fe (mol/m2)
+ endif
+ fsedfe(ji,jj) = ffastfe(ji,jj) !! record seafloor Fe (mol/m2)
+ ffastfe(ji,jj) = 0.0
+ !!
+ !! === biogenic silicon ===
+ if (jinorgben.eq.0) then
+ freminsi = freminsi + (ffastsi(ji,jj) / fthk) !! Si remineralisation in this box (mol/m3)
+ elseif (jinorgben.eq.1) then
+ f_fbenin_si(ji,jj) = ffastsi(ji,jj) !! fast Si -> benthic Si (mol/m2)
+ endif
+ fsedsi(ji,jj) = ffastsi(ji,jj) !! record seafloor Si (mol/m2)
+ ffastsi(ji,jj) = 0.0
+ !!
+ !! === biogenic calcium carbonate ===
+ if (jinorgben.eq.0) then
+ freminca = freminca + (ffastca(ji,jj) / fthk) !! Ca remineralisation in this box (mol/m3)
+ elseif (jinorgben.eq.1) then
+ f_fbenin_ca(ji,jj) = ffastca(ji,jj) !! fast Ca -> benthic Ca (mol/m2)
+ endif
+ fsedca(ji,jj) = ffastca(ji,jj) !! record seafloor Ca (mol/m2)
+ ffastca(ji,jj) = 0.0
+ endif
+
+# if defined key_debug_medusa
+ if (idf.eq.1) then
+ !!----------------------------------------------------------------------
+ !! Integrate total fast detritus remineralisation
+ !!----------------------------------------------------------------------
+ !!
+ fofd_n(ji,jj) = fofd_n(ji,jj) + (freminn * fthk)
+ fofd_si(ji,jj) = fofd_si(ji,jj) + (freminsi * fthk)
+ fofd_fe(ji,jj) = fofd_fe(ji,jj) + (freminfe * fthk)
+# if defined key_roam
+ fofd_c(ji,jj) = fofd_c(ji,jj) + (freminc * fthk)
+# endif
+ endif
+# endif
+
+ !!----------------------------------------------------------------------
+ !! Sort out remineralisation tally of fast-sinking detritus
+ !!----------------------------------------------------------------------
+ !!
+ !! update fast-sinking regeneration arrays
+ fregenfast(ji,jj) = fregenfast(ji,jj) + (freminn * fthk)
+ fregenfastsi(ji,jj) = fregenfastsi(ji,jj) + (freminsi * fthk)
+# if defined key_roam
+ fregenfastc(ji,jj) = fregenfastc(ji,jj) + (freminc * fthk)
+# endif
+
+ !!----------------------------------------------------------------------
+ !! Benthic remineralisation fluxes
+ !!----------------------------------------------------------------------
+ !!
+ if (jk.eq.jmbathy) then
+ !!
+ !! organic components
+ if (jorgben.eq.1) then
+ f_benout_n(ji,jj) = xsedn * zn_sed_n(ji,jj)
+ f_benout_fe(ji,jj) = xsedfe * zn_sed_fe(ji,jj)
+ f_benout_c(ji,jj) = xsedc * zn_sed_c(ji,jj)
+ endif
+ !!
+ !! inorganic components
+ if (jinorgben.eq.1) then
+ f_benout_si(ji,jj) = xsedsi * zn_sed_si(ji,jj)
+ f_benout_ca(ji,jj) = xsedca * zn_sed_ca(ji,jj)
+ !!
+ !! account for CaCO3 that dissolves when it shouldn't
+ if ( fdep .le. fccd_dep ) then
+ f_benout_lyso_ca(ji,jj) = xsedca * zn_sed_ca(ji,jj)
+ endif
+ endif
+ endif
+ CALL flush(numout)
+
+ !!======================================================================
+ !! LOCAL GRID CELL TRENDS
+ !!======================================================================
+ !!
+ !!----------------------------------------------------------------------
+ !! Determination of trends
+ !!----------------------------------------------------------------------
+ !!
+ !!----------------------------------------------------------------------
+ !! chlorophyll
+ btra(jpchn) = b0 * ( &
+ + ((frn * fprn * zphn) - fgmipn - fgmepn - fdpn - fdpn2) * (fthetan / xxi) )
+ btra(jpchd) = b0 * ( &
+ + ((frd * fprd * zphd) - fgmepd - fdpd - fdpd2) * (fthetad / xxi) )
+ !!
+ !!----------------------------------------------------------------------
+ !! phytoplankton
+ btra(jpphn) = b0 * ( &
+ + (fprn * zphn) - fgmipn - fgmepn - fdpn - fdpn2 )
+ btra(jpphd) = b0 * ( &
+ + (fprd * zphd) - fgmepd - fdpd - fdpd2 )
+ btra(jppds) = b0 * ( &
+ + (fprds * zpds) - fgmepds - fdpds - fsdiss - fdpds2 )
+ !!
+ !!----------------------------------------------------------------------
+ !! zooplankton
+ btra(jpzmi) = b0 * ( &
+ + fmigrow - fgmezmi - fdzmi - fdzmi2 )
+ btra(jpzme) = b0 * ( &
+ + fmegrow - fdzme - fdzme2 )
+ !!
+ !!----------------------------------------------------------------------
+ !! detritus
+ btra(jpdet) = b0 * ( &
+ + fdpn + ((1.0 - xfdfrac1) * fdpd) & ! mort. losses
+ + fdzmi + ((1.0 - xfdfrac2) * fdzme) & ! mort. losses
+ + ((1.0 - xbetan) * (finmi + finme)) & ! assim. inefficiency
+ - fgmid - fgmed - fdd & ! grazing and remin.
+ + ffast2slown ) ! seafloor fast->slow
+ !!
+ !!----------------------------------------------------------------------
+ !! dissolved inorganic nitrogen nutrient
+ fn_cons = 0.0 &
+ - (fprn * zphn) - (fprd * zphd) ! primary production
+ fn_prod = 0.0 &
+ + (xphi * (fgmipn + fgmid)) & ! messy feeding remin.
+ + (xphi * (fgmepn + fgmepd + fgmezmi + fgmed)) & ! messy feeding remin.
+ + fmiexcr + fmeexcr + fdd + freminn & ! excretion and remin.
+ + fdpn2 + fdpd2 + fdzmi2 + fdzme2 ! metab. losses
+ !!
+ !! riverine flux
+ if ( jriver_n .gt. 0 ) then
+ f_riv_loc_n = f_riv_n(ji,jj) * friver_dep(jk,jmbathy) / fthk
+ fn_prod = fn_prod + f_riv_loc_n
+ endif
+ !!
+ !! benthic remineralisation
+ if (jk.eq.jmbathy .and. jorgben.eq.1 .and. ibenthic.eq.1) then
+ fn_prod = fn_prod + (f_benout_n(ji,jj) / fthk)
+ endif
+ !!
+ btra(jpdin) = b0 * ( &
+ fn_prod + fn_cons )
+ !!
+ fnit_cons(ji,jj) = fnit_cons(ji,jj) + ( fthk * ( & ! consumption of dissolved nitrogen
+ fn_cons ) )
+ fnit_prod(ji,jj) = fnit_prod(ji,jj) + ( fthk * ( & ! production of dissolved nitrogen
+ fn_prod ) )
+ !!
+ !!----------------------------------------------------------------------
+ !! dissolved silicic acid nutrient
+ fs_cons = 0.0 &
+ - (fprds * zpds) ! opal production
+ fs_prod = 0.0 &
+ + fsdiss & ! opal dissolution
+ + ((1.0 - xfdfrac1) * fdpds) & ! mort. loss
+ + ((1.0 - xfdfrac3) * fgmepds) & ! egestion of grazed Si
+ + freminsi + fdpds2 ! fast diss. and metab. losses
+ !!
+ !! riverine flux
+ if ( jriver_si .gt. 0 ) then
+ f_riv_loc_si = f_riv_si(ji,jj) * friver_dep(jk,jmbathy) / fthk
+ fs_prod = fs_prod + f_riv_loc_si
+ endif
+ !!
+ !! benthic remineralisation
+ if (jk.eq.jmbathy .and. jinorgben.eq.1 .and. ibenthic.eq.1) then
+ fs_prod = fs_prod + (f_benout_si(ji,jj) / fthk)
+ endif
+ !!
+ btra(jpsil) = b0 * ( &
+ fs_prod + fs_cons )
+ !!
+ fsil_cons(ji,jj) = fsil_cons(ji,jj) + ( fthk * ( & ! consumption of dissolved silicon
+ fs_cons ) )
+ fsil_prod(ji,jj) = fsil_prod(ji,jj) + ( fthk * ( & ! production of dissolved silicon
+ fs_prod ) )
+ !!
+ !!----------------------------------------------------------------------
+ !! dissolved "iron" nutrient
+ btra(jpfer) = b0 * ( &
+ + (xrfn * btra(jpdin)) + ffetop + ffebot - ffescav )
+
+# if defined key_roam
+ !!
+ !!----------------------------------------------------------------------
+ !! AXY (26/11/08): implicit detrital carbon change
+ btra(jpdtc) = b0 * ( &
+ + (xthetapn * fdpn) + ((1.0 - xfdfrac1) * (xthetapd * fdpd)) & ! mort. losses
+ + (xthetazmi * fdzmi) + ((1.0 - xfdfrac2) * (xthetazme * fdzme)) & ! mort. losses
+ + ((1.0 - xbetac) * (ficmi + ficme)) & ! assim. inefficiency
+ - fgmidc - fgmedc - fddc & ! grazing and remin.
+ + ffast2slowc ) ! seafloor fast->slow
+ !!
+ !!----------------------------------------------------------------------
+ !! dissolved inorganic carbon
+ fc_cons = 0.0 &
+ - (xthetapn * fprn * zphn) - (xthetapd * fprd * zphd) ! primary production
+ fc_prod = 0.0 &
+ + (xthetapn * xphi * fgmipn) + (xphi * fgmidc) & ! messy feeding remin
+ + (xthetapn * xphi * fgmepn) + (xthetapd * xphi * fgmepd) & ! messy feeding remin
+ + (xthetazmi * xphi * fgmezmi) + (xphi * fgmedc) & ! messy feeding remin
+ + fmiresp + fmeresp + fddc + freminc + (xthetapn * fdpn2) & ! resp., remin., losses
+ + (xthetapd * fdpd2) + (xthetazmi * fdzmi2) & ! losses
+ + (xthetazme * fdzme2) ! losses
+ !!
+ !! riverine flux
+ if ( jriver_c .gt. 0 ) then
+ f_riv_loc_c = f_riv_c(ji,jj) * friver_dep(jk,jmbathy) / fthk
+ fc_prod = fc_prod + f_riv_loc_c
+ endif
+ !!
+ !! benthic remineralisation
+ if (jk.eq.jmbathy .and. jorgben.eq.1 .and. ibenthic.eq.1) then
+ fc_prod = fc_prod + (f_benout_c(ji,jj) / fthk)
+ endif
+ if (jk.eq.jmbathy .and. jinorgben.eq.1 .and. ibenthic.eq.1) then
+ fc_prod = fc_prod + (f_benout_ca(ji,jj) / fthk)
+ endif
+ !!
+ !! community respiration (does not include CaCO3 terms - obviously!)
+ fcomm_resp(ji,jj) = fcomm_resp(ji,jj) + fc_prod
+ !!
+ !! CaCO3
+ fc_prod = fc_prod - ftempca + freminca
+ !!
+ !! riverine flux
+ if ( jk .eq. 1 .and. jriver_c .gt. 0 ) then
+ fc_prod = fc_prod + f_riv_c(ji,jj)
+ endif
+ !!
+ btra(jpdic) = b0 * ( &
+ fc_prod + fc_cons )
+ !!
+ fcar_cons(ji,jj) = fcar_cons(ji,jj) + ( fthk * ( & ! consumption of dissolved carbon
+ fc_cons ) )
+ fcar_prod(ji,jj) = fcar_prod(ji,jj) + ( fthk * ( & ! production of dissolved carbon
+ fc_prod ) )
+ !!
+ !!----------------------------------------------------------------------
+ !! alkalinity
+ fa_prod = 0.0 &
+ + (2.0 * freminca) ! CaCO3 dissolution
+ fa_cons = 0.0 &
+ - (2.0 * ftempca) ! CaCO3 production
+ !!
+ !! riverine flux
+ if ( jriver_alk .gt. 0 ) then
+ f_riv_loc_alk = f_riv_alk(ji,jj) * friver_dep(jk,jmbathy) / fthk
+ fa_prod = fa_prod + f_riv_loc_alk
+ endif
+ !!
+ !! benthic remineralisation
+ if (jk.eq.jmbathy .and. jinorgben.eq.1 .and. ibenthic.eq.1) then
+ fa_prod = fa_prod + (2.0 * f_benout_ca(ji,jj) / fthk)
+ endif
+ !!
+ btra(jpalk) = b0 * ( &
+ fa_prod + fa_cons )
+ !!
+ !!----------------------------------------------------------------------
+ !! oxygen (has protection at low O2 concentrations; OCMIP-2 style)
+ fo2_prod = 0.0 &
+ + (xthetanit * fprn * zphn) & ! Pn primary production, N
+ + (xthetanit * fprd * zphd) & ! Pd primary production, N
+ + (xthetarem * xthetapn * fprn * zphn) & ! Pn primary production, C
+ + (xthetarem * xthetapd * fprd * zphd) ! Pd primary production, C
+ fo2_ncons = 0.0 &
+ - (xthetanit * xphi * fgmipn) & ! Pn messy feeding remin., N
+ - (xthetanit * xphi * fgmid) & ! D messy feeding remin., N
+ - (xthetanit * xphi * fgmepn) & ! Pn messy feeding remin., N
+ - (xthetanit * xphi * fgmepd) & ! Pd messy feeding remin., N
+ - (xthetanit * xphi * fgmezmi) & ! Zi messy feeding remin., N
+ - (xthetanit * xphi * fgmed) & ! D messy feeding remin., N
+ - (xthetanit * fmiexcr) & ! microzoo excretion, N
+ - (xthetanit * fmeexcr) & ! mesozoo excretion, N
+ - (xthetanit * fdd) & ! slow detritus remin., N
+ - (xthetanit * freminn) & ! fast detritus remin., N
+ - (xthetanit * fdpn2) & ! Pn losses, N
+ - (xthetanit * fdpd2) & ! Pd losses, N
+ - (xthetanit * fdzmi2) & ! Zmi losses, N
+ - (xthetanit * fdzme2) ! Zme losses, N
+ !!
+ !! benthic remineralisation
+ if (jk.eq.jmbathy .and. jorgben.eq.1 .and. ibenthic.eq.1) then
+ fo2_ncons = fo2_ncons - (xthetanit * f_benout_n(ji,jj) / fthk)
+ endif
+ fo2_ccons = 0.0 &
+ - (xthetarem * xthetapn * xphi * fgmipn) & ! Pn messy feeding remin., C
+ - (xthetarem * xphi * fgmidc) & ! D messy feeding remin., C
+ - (xthetarem * xthetapn * xphi * fgmepn) & ! Pn messy feeding remin., C
+ - (xthetarem * xthetapd * xphi * fgmepd) & ! Pd messy feeding remin., C
+ - (xthetarem * xthetazmi * xphi * fgmezmi) & ! Zi messy feeding remin., C
+ - (xthetarem * xphi * fgmedc) & ! D messy feeding remin., C
+ - (xthetarem * fmiresp) & ! microzoo respiration, C
+ - (xthetarem * fmeresp) & ! mesozoo respiration, C
+ - (xthetarem * fddc) & ! slow detritus remin., C
+ - (xthetarem * freminc) & ! fast detritus remin., C
+ - (xthetarem * xthetapn * fdpn2) & ! Pn losses, C
+ - (xthetarem * xthetapd * fdpd2) & ! Pd losses, C
+ - (xthetarem * xthetazmi * fdzmi2) & ! Zmi losses, C
+ - (xthetarem * xthetazme * fdzme2) ! Zme losses, C
+ !!
+ !! benthic remineralisation
+ if (jk.eq.jmbathy .and. jorgben.eq.1 .and. ibenthic.eq.1) then
+ fo2_ccons = fo2_ccons - (xthetarem * f_benout_c(ji,jj) / fthk)
+ endif
+ fo2_cons = fo2_ncons + fo2_ccons
+ !!
+ !! is this a suboxic zone?
+ if (zoxy.lt.xo2min) then ! deficient O2; production fluxes only
+ btra(jpoxy) = b0 * ( &
+ fo2_prod )
+ foxy_prod(ji,jj) = foxy_prod(ji,jj) + ( fthk * fo2_prod )
+ foxy_anox(ji,jj) = foxy_anox(ji,jj) + ( fthk * fo2_cons )
+ else ! sufficient O2; production + consumption fluxes
+ btra(jpoxy) = b0 * ( &
+ fo2_prod + fo2_cons )
+ foxy_prod(ji,jj) = foxy_prod(ji,jj) + ( fthk * fo2_prod )
+ foxy_cons(ji,jj) = foxy_cons(ji,jj) + ( fthk * fo2_cons )
+ endif
+ !!
+ !! air-sea fluxes (if this is the surface box)
+ if (jk.eq.1) then
+ !!
+ !! CO2 flux
+ btra(jpdic) = btra(jpdic) + (b0 * f_co2flux)
+ !!
+ !! O2 flux (mol/m3/s -> mmol/m3/d)
+ btra(jpoxy) = btra(jpoxy) + (b0 * f_o2flux)
+ endif
+# endif
+
+# if defined key_debug_medusa
+ !! report state variable fluxes (not including fast-sinking detritus)
+ if (idf.eq.1.AND.idfval.eq.1) then
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'btra(jpchn)(',jk,') = ', btra(jpchn)
+ IF (lwp) write (numout,*) 'btra(jpchd)(',jk,') = ', btra(jpchd)
+ IF (lwp) write (numout,*) 'btra(jpphn)(',jk,') = ', btra(jpphn)
+ IF (lwp) write (numout,*) 'btra(jpphd)(',jk,') = ', btra(jpphd)
+ IF (lwp) write (numout,*) 'btra(jppds)(',jk,') = ', btra(jppds)
+ IF (lwp) write (numout,*) 'btra(jpzmi)(',jk,') = ', btra(jpzmi)
+ IF (lwp) write (numout,*) 'btra(jpzme)(',jk,') = ', btra(jpzme)
+ IF (lwp) write (numout,*) 'btra(jpdet)(',jk,') = ', btra(jpdet)
+ IF (lwp) write (numout,*) 'btra(jpdin)(',jk,') = ', btra(jpdin)
+ IF (lwp) write (numout,*) 'btra(jpsil)(',jk,') = ', btra(jpsil)
+ IF (lwp) write (numout,*) 'btra(jpfer)(',jk,') = ', btra(jpfer)
+# if defined key_roam
+ IF (lwp) write (numout,*) 'btra(jpdtc)(',jk,') = ', btra(jpdtc)
+ IF (lwp) write (numout,*) 'btra(jpdic)(',jk,') = ', btra(jpdic)
+ IF (lwp) write (numout,*) 'btra(jpalk)(',jk,') = ', btra(jpalk)
+ IF (lwp) write (numout,*) 'btra(jpoxy)(',jk,') = ', btra(jpoxy)
+# endif
+ endif
+# endif
+
+ !!----------------------------------------------------------------------
+ !! Integrate calculated fluxes for mass balance
+ !!----------------------------------------------------------------------
+ !!
+ !! === nitrogen ===
+ fflx_n(ji,jj) = fflx_n(ji,jj) + &
+ fthk * ( btra(jpphn) + btra(jpphd) + btra(jpzmi) + btra(jpzme) + btra(jpdet) + btra(jpdin) )
+ !! === silicon ===
+ fflx_si(ji,jj) = fflx_si(ji,jj) + &
+ fthk * ( btra(jppds) + btra(jpsil) )
+ !! === iron ===
+ fflx_fe(ji,jj) = fflx_fe(ji,jj) + &
+ fthk * ( ( xrfn * ( btra(jpphn) + btra(jpphd) + btra(jpzmi) + btra(jpzme) + btra(jpdet)) ) + btra(jpfer) )
+# if defined key_roam
+ !! === carbon ===
+ fflx_c(ji,jj) = fflx_c(ji,jj) + &
+ fthk * ( (xthetapn * btra(jpphn)) + (xthetapd * btra(jpphd)) + &
+ (xthetazmi * btra(jpzmi)) + (xthetazme * btra(jpzme)) + btra(jpdtc) + btra(jpdic) )
+ !! === alkalinity ===
+ fflx_a(ji,jj) = fflx_a(ji,jj) + &
+ fthk * ( btra(jpalk) )
+ !! === oxygen ===
+ fflx_o2(ji,jj) = fflx_o2(ji,jj) + &
+ fthk * ( btra(jpoxy) )
+# endif
+
+ !!----------------------------------------------------------------------
+ !! Apply calculated tracer fluxes
+ !!----------------------------------------------------------------------
+ !!
+ !! units: [unit of tracer] per second (fluxes are calculated above per day)
+ !!
+ ibio_switch = 1
+# if defined key_gulf_finland
+ !! AXY (17/05/13): fudge in a Gulf of Finland correction; uses longitude-
+ !! latitude range to establish if this is a Gulf of Finland
+ !! grid cell; if so, then BGC fluxes are ignored (though
+ !! still calculated); for reference, this is meant to be a
+ !! temporary fix to see if all of my problems can be done
+ !! away with if I switch off BGC fluxes in the Gulf of
+ !! Finland, which currently appears the source of trouble
+ if ( glamt(ji,jj).gt.24.7 .and. glamt(ji,jj).lt.27.8 .and. &
+ & gphit(ji,jj).gt.59.2 .and. gphit(ji,jj).lt.60.2 ) then
+ ibio_switch = 0
+ endif
+# endif
+ if (ibio_switch.eq.1) then
+ tra(ji,jj,jk,jpchn) = tra(ji,jj,jk,jpchn) + (btra(jpchn) / 86400.)
+ tra(ji,jj,jk,jpchd) = tra(ji,jj,jk,jpchd) + (btra(jpchd) / 86400.)
+ tra(ji,jj,jk,jpphn) = tra(ji,jj,jk,jpphn) + (btra(jpphn) / 86400.)
+ tra(ji,jj,jk,jpphd) = tra(ji,jj,jk,jpphd) + (btra(jpphd) / 86400.)
+ tra(ji,jj,jk,jppds) = tra(ji,jj,jk,jppds) + (btra(jppds) / 86400.)
+ tra(ji,jj,jk,jpzmi) = tra(ji,jj,jk,jpzmi) + (btra(jpzmi) / 86400.)
+ tra(ji,jj,jk,jpzme) = tra(ji,jj,jk,jpzme) + (btra(jpzme) / 86400.)
+ tra(ji,jj,jk,jpdet) = tra(ji,jj,jk,jpdet) + (btra(jpdet) / 86400.)
+ tra(ji,jj,jk,jpdin) = tra(ji,jj,jk,jpdin) + (btra(jpdin) / 86400.)
+ tra(ji,jj,jk,jpsil) = tra(ji,jj,jk,jpsil) + (btra(jpsil) / 86400.)
+ tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) + (btra(jpfer) / 86400.)
+# if defined key_roam
+ tra(ji,jj,jk,jpdtc) = tra(ji,jj,jk,jpdtc) + (btra(jpdtc) / 86400.)
+ tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) + (btra(jpdic) / 86400.)
+ tra(ji,jj,jk,jpalk) = tra(ji,jj,jk,jpalk) + (btra(jpalk) / 86400.)
+ tra(ji,jj,jk,jpoxy) = tra(ji,jj,jk,jpoxy) + (btra(jpoxy) / 86400.)
+# endif
+ endif
+
+ !! AXY (18/11/16): CMIP6 diagnostics
+ IF( med_diag%FBDDTALK%dgsave ) THEN
+ fbddtalk(ji,jj) = fbddtalk(ji,jj) + (btra(jpalk) * fthk)
+ ENDIF
+ IF( med_diag%FBDDTDIC%dgsave ) THEN
+ fbddtdic(ji,jj) = fbddtdic(ji,jj) + (btra(jpdic) * fthk)
+ ENDIF
+ IF( med_diag%FBDDTDIFE%dgsave ) THEN
+ fbddtdife(ji,jj) = fbddtdife(ji,jj) + (btra(jpfer) * fthk)
+ ENDIF
+ IF( med_diag%FBDDTDIN%dgsave ) THEN
+ fbddtdin(ji,jj) = fbddtdin(ji,jj) + (btra(jpdin) * fthk)
+ ENDIF
+ IF( med_diag%FBDDTDISI%dgsave ) THEN
+ fbddtdisi(ji,jj) = fbddtdisi(ji,jj) + (btra(jpsil) * fthk)
+ ENDIF
+ !!
+ IF( med_diag%BDDTALK3%dgsave ) THEN
+ bddtalk3(ji,jj,jk) = btra(jpalk)
+ ENDIF
+ IF( med_diag%BDDTDIC3%dgsave ) THEN
+ bddtdic3(ji,jj,jk) = btra(jpdic)
+ ENDIF
+ IF( med_diag%BDDTDIFE3%dgsave ) THEN
+ bddtdife3(ji,jj,jk) = btra(jpfer)
+ ENDIF
+ IF( med_diag%BDDTDIN3%dgsave ) THEN
+ bddtdin3(ji,jj,jk) = btra(jpdin)
+ ENDIF
+ IF( med_diag%BDDTDISI3%dgsave ) THEN
+ bddtdisi3(ji,jj,jk) = btra(jpsil)
+ ENDIF
+
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) '------'
+ IF (lwp) write (numout,*) 'trc_bio_medusa: end all calculations'
+ IF (lwp) write (numout,*) 'trc_bio_medusa: now outputs'
+ CALL flush(numout)
+# endif
+
+# if defined key_axy_nancheck
+ !!----------------------------------------------------------------------
+ !! Check calculated tracer fluxes
+ !!----------------------------------------------------------------------
+ !!
+ DO jn = 1,jptra
+ fq0 = btra(jn)
+ !! AXY (30/01/14): "isnan" problem on HECTOR
+ !! if (fq0 /= fq0 ) then
+ if ( ieee_is_nan( fq0 ) ) then
+ !! there's a NaN here
+ if (lwp) write(numout,*) 'NAN detected in btra(', ji, ',', &
+ & jj, ',', jk, ',', jn, ') at time', kt
+ CALL ctl_stop( 'trcbio_medusa, NAN in btra field' )
+ endif
+ ENDDO
+ DO jn = 1,jptra
+ fq0 = tra(ji,jj,jk,jn)
+ !! AXY (30/01/14): "isnan" problem on HECTOR
+ !! if (fq0 /= fq0 ) then
+ if ( ieee_is_nan( fq0 ) ) then
+ !! there's a NaN here
+ if (lwp) write(numout,*) 'NAN detected in tra(', ji, ',', &
+ & jj, ',', jk, ',', jn, ') at time', kt
+ CALL ctl_stop( 'trcbio_medusa, NAN in tra field' )
+ endif
+ ENDDO
+ CALL flush(numout)
+# endif
+
+ !!----------------------------------------------------------------------
+ !! Check model conservation
+ !! these terms merely sum up the tendency terms of the relevant
+ !! state variables, which should sum to zero; the iron cycle is
+ !! complicated by fluxes that add (aeolian deposition and seafloor
+ !! remineralisation) and remove (scavenging) dissolved iron from
+ !! the model (i.e. the sum of iron fluxes is unlikely to be zero)
+ !!----------------------------------------------------------------------
+ !!
+ !! fnit0 = btra(jpphn) + btra(jpphd) + btra(jpzmi) + btra(jpzme) + btra(jpdet) + btra(jpdin) ! + ftempn
+ !! fsil0 = btra(jppds) + btra(jpsil) ! + ftempsi
+ !! ffer0 = (xrfn * fnit0) + btra(jpfer)
+# if defined key_roam
+ !! fcar0 = 0.
+ !! falk0 = 0.
+ !! foxy0 = 0.
+# endif
+ !!
+ !! if (kt/240*240.eq.kt) then
+ !! if (ji.eq.2.and.jj.eq.2.and.jk.eq.1) then
+ !! IF (lwp) write (*,*) '*******!MEDUSA Conservation!*******',kt
+# if defined key_roam
+ !! IF (lwp) write (*,*) fnit0,fsil0,ffer0,fcar0,falk0,foxy0
+# else
+ !! IF (lwp) write (*,*) fnit0,fsil0,ffer0
+# endif
+ !! endif
+ !! endif
+
+# if defined key_trc_diabio
+ !!======================================================================
+ !! LOCAL GRID CELL DIAGNOSTICS
+ !!======================================================================
+ !!
+ !!----------------------------------------------------------------------
+ !! Full diagnostics key_trc_diabio:
+ !! LOBSTER and PISCES support full diagnistics option key_trc_diabio
+ !! which gives an option of FULL output of biological sourses and sinks.
+ !! I cannot see any reason for doing this. If needed, it can be done
+ !! as shown below.
+ !!----------------------------------------------------------------------
+ !!
+ IF(lwp) WRITE(numout,*) ' MEDUSA does not support key_trc_diabio'
+ !! trbio(ji,jj,jk, 1) = fprn
+# endif
+
+ IF( lk_iomput .AND. .NOT. ln_diatrc ) THEN
+ !!----------------------------------------------------------------------
+ !! Add in XML diagnostics stuff
+ !!----------------------------------------------------------------------
+ !!
+ !! ** 2D diagnostics
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'trc_bio_medusa: diag in ij-jj-jk loop'
+ CALL flush(numout)
+# endif
+ IF ( med_diag%PRN%dgsave ) THEN
+ fprn2d(ji,jj) = fprn2d(ji,jj) + (fprn * zphn * fthk)
+ ENDIF
+ IF ( med_diag%MPN%dgsave ) THEN
+ fdpn2d(ji,jj) = fdpn2d(ji,jj) + (fdpn * fthk)
+ ENDIF
+ IF ( med_diag%PRD%dgsave ) THEN
+ fprd2d(ji,jj) = fprd2d(ji,jj) + (fprd * zphd * fthk)
+ ENDIF
+ IF( med_diag%MPD%dgsave ) THEN
+ fdpd2d(ji,jj) = fdpd2d(ji,jj) + (fdpd * fthk)
+ ENDIF
+ ! IF( med_diag%DSED%dgsave ) THEN
+ ! CALL iom_put( "DSED" , ftot_n )
+ ! ENDIF
+ IF( med_diag%OPAL%dgsave ) THEN
+ fprds2d(ji,jj) = fprds2d(ji,jj) + (fprds * zpds * fthk)
+ ENDIF
+ IF( med_diag%OPALDISS%dgsave ) THEN
+ fsdiss2d(ji,jj) = fsdiss2d(ji,jj) + (fsdiss * fthk)
+ ENDIF
+ IF( med_diag%GMIPn%dgsave ) THEN
+ fgmipn2d(ji,jj) = fgmipn2d(ji,jj) + (fgmipn * fthk)
+ ENDIF
+ IF( med_diag%GMID%dgsave ) THEN
+ fgmid2d(ji,jj) = fgmid2d(ji,jj) + (fgmid * fthk)
+ ENDIF
+ IF( med_diag%MZMI%dgsave ) THEN
+ fdzmi2d(ji,jj) = fdzmi2d(ji,jj) + (fdzmi * fthk)
+ ENDIF
+ IF( med_diag%GMEPN%dgsave ) THEN
+ fgmepn2d(ji,jj) = fgmepn2d(ji,jj) + (fgmepn * fthk)
+ ENDIF
+ IF( med_diag%GMEPD%dgsave ) THEN
+ fgmepd2d(ji,jj) = fgmepd2d(ji,jj) + (fgmepd * fthk)
+ ENDIF
+ IF( med_diag%GMEZMI%dgsave ) THEN
+ fgmezmi2d(ji,jj) = fgmezmi2d(ji,jj) + (fgmezmi * fthk)
+ ENDIF
+ IF( med_diag%GMED%dgsave ) THEN
+ fgmed2d(ji,jj) = fgmed2d(ji,jj) + (fgmed * fthk)
+ ENDIF
+ IF( med_diag%MZME%dgsave ) THEN
+ fdzme2d(ji,jj) = fdzme2d(ji,jj) + (fdzme * fthk)
+ ENDIF
+ ! IF( med_diag%DEXP%dgsave ) THEN
+ ! CALL iom_put( "DEXP" , ftot_n )
+ ! ENDIF
+ IF( med_diag%DETN%dgsave ) THEN
+ fslown2d(ji,jj) = fslown2d(ji,jj) + (fslown * fthk)
+ ENDIF
+ IF( med_diag%MDET%dgsave ) THEN
+ fdd2d(ji,jj) = fdd2d(ji,jj) + (fdd * fthk)
+ ENDIF
+ IF( med_diag%AEOLIAN%dgsave ) THEN
+ ffetop2d(ji,jj) = ffetop2d(ji,jj) + (ffetop * fthk)
+ ENDIF
+ IF( med_diag%BENTHIC%dgsave ) THEN
+ ffebot2d(ji,jj) = ffebot2d(ji,jj) + (ffebot * fthk)
+ ENDIF
+ IF( med_diag%SCAVENGE%dgsave ) THEN
+ ffescav2d(ji,jj) = ffescav2d(ji,jj) + (ffescav * fthk)
+ ENDIF
+ IF( med_diag%PN_JLIM%dgsave ) THEN
+ ! fjln2d(ji,jj) = fjln2d(ji,jj) + (fjln * zphn * fthk)
+ fjln2d(ji,jj) = fjln2d(ji,jj) + (fjlim_pn * zphn * fthk)
+ ENDIF
+ IF( med_diag%PN_NLIM%dgsave ) THEN
+ fnln2d(ji,jj) = fnln2d(ji,jj) + (fnln * zphn * fthk)
+ ENDIF
+ IF( med_diag%PN_FELIM%dgsave ) THEN
+ ffln2d(ji,jj) = ffln2d(ji,jj) + (ffln * zphn * fthk)
+ ENDIF
+ IF( med_diag%PD_JLIM%dgsave ) THEN
+ ! fjld2d(ji,jj) = fjld2d(ji,jj) + (fjld * zphd * fthk)
+ fjld2d(ji,jj) = fjld2d(ji,jj) + (fjlim_pd * zphd * fthk)
+ ENDIF
+ IF( med_diag%PD_NLIM%dgsave ) THEN
+ fnld2d(ji,jj) = fnld2d(ji,jj) + (fnld * zphd * fthk)
+ ENDIF
+ IF( med_diag%PD_FELIM%dgsave ) THEN
+ ffld2d(ji,jj) = ffld2d(ji,jj) + (ffld * zphd * fthk)
+ ENDIF
+ IF( med_diag%PD_SILIM%dgsave ) THEN
+ fsld2d2(ji,jj) = fsld2d2(ji,jj) + (fsld2 * zphd * fthk)
+ ENDIF
+ IF( med_diag%PDSILIM2%dgsave ) THEN
+ fsld2d(ji,jj) = fsld2d(ji,jj) + (fsld * zphd * fthk)
+ ENDIF
+ !!
+ IF( med_diag%TOTREG_N%dgsave ) THEN
+ fregen2d(ji,jj) = fregen2d(ji,jj) + fregen
+ ENDIF
+ IF( med_diag%TOTRG_SI%dgsave ) THEN
+ fregensi2d(ji,jj) = fregensi2d(ji,jj) + fregensi
+ ENDIF
+ !!
+ IF( med_diag%FASTN%dgsave ) THEN
+ ftempn2d(ji,jj) = ftempn2d(ji,jj) + (ftempn * fthk)
+ ENDIF
+ IF( med_diag%FASTSI%dgsave ) THEN
+ ftempsi2d(ji,jj) = ftempsi2d(ji,jj) + (ftempsi * fthk)
+ ENDIF
+ IF( med_diag%FASTFE%dgsave ) THEN
+ ftempfe2d(ji,jj) =ftempfe2d(ji,jj) + (ftempfe * fthk)
+ ENDIF
+ IF( med_diag%FASTC%dgsave ) THEN
+ ftempc2d(ji,jj) = ftempc2d(ji,jj) + (ftempc * fthk)
+ ENDIF
+ IF( med_diag%FASTCA%dgsave ) THEN
+ ftempca2d(ji,jj) = ftempca2d(ji,jj) + (ftempca * fthk)
+ ENDIF
+ !!
+ IF( med_diag%REMINN%dgsave ) THEN
+ freminn2d(ji,jj) = freminn2d(ji,jj) + (freminn * fthk)
+ ENDIF
+ IF( med_diag%REMINSI%dgsave ) THEN
+ freminsi2d(ji,jj) = freminsi2d(ji,jj) + (freminsi * fthk)
+ ENDIF
+ IF( med_diag%REMINFE%dgsave ) THEN
+ freminfe2d(ji,jj)= freminfe2d(ji,jj) + (freminfe * fthk)
+ ENDIF
+ IF( med_diag%REMINC%dgsave ) THEN
+ freminc2d(ji,jj) = freminc2d(ji,jj) + (freminc * fthk)
+ ENDIF
+ IF( med_diag%REMINCA%dgsave ) THEN
+ freminca2d(ji,jj) = freminca2d(ji,jj) + (freminca * fthk)
+ ENDIF
+ !!
+# if defined key_roam
+ !!
+ !! AXY (09/11/16): CMIP6 diagnostics
+ IF( med_diag%FD_NIT3%dgsave ) THEN
+ fd_nit3(ji,jj,jk) = ffastn(ji,jj)
+ ENDIF
+ IF( med_diag%FD_SIL3%dgsave ) THEN
+ fd_sil3(ji,jj,jk) = ffastsi(ji,jj)
+ ENDIF
+ IF( med_diag%FD_CAR3%dgsave ) THEN
+ fd_car3(ji,jj,jk) = ffastc(ji,jj)
+ ENDIF
+ IF( med_diag%FD_CAL3%dgsave ) THEN
+ fd_cal3(ji,jj,jk) = ffastca(ji,jj)
+ ENDIF
+ !!
+ IF (jk.eq.i0100) THEN
+ IF( med_diag%RR_0100%dgsave ) THEN
+ ffastca2d(ji,jj) = &
+ ffastca(ji,jj)/MAX(ffastc(ji,jj), rsmall)
+ ENDIF
+ ELSE IF (jk.eq.i0500) THEN
+ IF( med_diag%RR_0500%dgsave ) THEN
+ ffastca2d(ji,jj) = &
+ ffastca(ji,jj)/MAX(ffastc(ji,jj), rsmall)
+ ENDIF
+ ELSE IF (jk.eq.i1000) THEN
+ IF( med_diag%RR_1000%dgsave ) THEN
+ ffastca2d(ji,jj) = &
+ ffastca(ji,jj)/MAX(ffastc(ji,jj), rsmall)
+ ENDIF
+ ELSE IF (jk.eq.jmbathy) THEN
+ IF( med_diag%IBEN_N%dgsave ) THEN
+ iben_n2d(ji,jj) = f_sbenin_n(ji,jj) + f_fbenin_n(ji,jj)
+ ENDIF
+ IF( med_diag%IBEN_FE%dgsave ) THEN
+ iben_fe2d(ji,jj) = f_sbenin_fe(ji,jj) + f_fbenin_fe(ji,jj)
+ ENDIF
+ IF( med_diag%IBEN_C%dgsave ) THEN
+ iben_c2d(ji,jj) = f_sbenin_c(ji,jj) + f_fbenin_c(ji,jj)
+ ENDIF
+ IF( med_diag%IBEN_SI%dgsave ) THEN
+ iben_si2d(ji,jj) = f_fbenin_si(ji,jj)
+ ENDIF
+ IF( med_diag%IBEN_CA%dgsave ) THEN
+ iben_ca2d(ji,jj) = f_fbenin_ca(ji,jj)
+ ENDIF
+ IF( med_diag%OBEN_N%dgsave ) THEN
+ oben_n2d(ji,jj) = f_benout_n(ji,jj)
+ ENDIF
+ IF( med_diag%OBEN_FE%dgsave ) THEN
+ oben_fe2d(ji,jj) = f_benout_fe(ji,jj)
+ ENDIF
+ IF( med_diag%OBEN_C%dgsave ) THEN
+ oben_c2d(ji,jj) = f_benout_c(ji,jj)
+ ENDIF
+ IF( med_diag%OBEN_SI%dgsave ) THEN
+ oben_si2d(ji,jj) = f_benout_si(ji,jj)
+ ENDIF
+ IF( med_diag%OBEN_CA%dgsave ) THEN
+ oben_ca2d(ji,jj) = f_benout_ca(ji,jj)
+ ENDIF
+ IF( med_diag%SFR_OCAL%dgsave ) THEN
+ sfr_ocal2d(ji,jj) = f3_omcal(ji,jj,jk)
+ ENDIF
+ IF( med_diag%SFR_OARG%dgsave ) THEN
+ sfr_oarg2d(ji,jj) = f3_omarg(ji,jj,jk)
+ ENDIF
+ IF( med_diag%LYSO_CA%dgsave ) THEN
+ lyso_ca2d(ji,jj) = f_benout_lyso_ca(ji,jj)
+ ENDIF
+ ENDIF
+ !! end bathy-1 diags
+ !!
+ IF( med_diag%RIV_N%dgsave ) THEN
+ rivn2d(ji,jj) = rivn2d(ji,jj) + (f_riv_loc_n * fthk)
+ ENDIF
+ IF( med_diag%RIV_SI%dgsave ) THEN
+ rivsi2d(ji,jj) = rivsi2d(ji,jj) + (f_riv_loc_si * fthk)
+ ENDIF
+ IF( med_diag%RIV_C%dgsave ) THEN
+ rivc2d(ji,jj) = rivc2d(ji,jj) + (f_riv_loc_c * fthk)
+ ENDIF
+ IF( med_diag%RIV_ALK%dgsave ) THEN
+ rivalk2d(ji,jj) = rivalk2d(ji,jj) + (f_riv_loc_alk * fthk)
+ ENDIF
+ IF( med_diag%DETC%dgsave ) THEN
+ fslowc2d(ji,jj) = fslowc2d(ji,jj) + (fslowc * fthk)
+ ENDIF
+ !!
+ !!
+ !!
+ IF( med_diag%PN_LLOSS%dgsave ) THEN
+ fdpn22d(ji,jj) = fdpn22d(ji,jj) + (fdpn2 * fthk)
+ ENDIF
+ IF( med_diag%PD_LLOSS%dgsave ) THEN
+ fdpd22d(ji,jj) = fdpd22d(ji,jj) + (fdpd2 * fthk)
+ ENDIF
+ IF( med_diag%ZI_LLOSS%dgsave ) THEN
+ fdzmi22d(ji,jj) = fdzmi22d(ji,jj) + (fdzmi2 * fthk)
+ ENDIF
+ IF( med_diag%ZE_LLOSS%dgsave ) THEN
+ fdzme22d(ji,jj) = fdzme22d(ji,jj) + (fdzme2 * fthk)
+ ENDIF
+ IF( med_diag%ZI_MES_N%dgsave ) THEN
+ zimesn2d(ji,jj) = zimesn2d(ji,jj) + &
+ (xphi * (fgmipn + fgmid) * fthk)
+ ENDIF
+ IF( med_diag%ZI_MES_D%dgsave ) THEN
+ zimesd2d(ji,jj) = zimesd2d(ji,jj) + &
+ ((1. - xbetan) * finmi * fthk)
+ ENDIF
+ IF( med_diag%ZI_MES_C%dgsave ) THEN
+ zimesc2d(ji,jj) = zimesc2d(ji,jj) + &
+ (xphi * ((xthetapn * fgmipn) + fgmidc) * fthk)
+ ENDIF
+ IF( med_diag%ZI_MESDC%dgsave ) THEN
+ zimesdc2d(ji,jj) = zimesdc2d(ji,jj) + &
+ ((1. - xbetac) * ficmi * fthk)
+ ENDIF
+ IF( med_diag%ZI_EXCR%dgsave ) THEN
+ ziexcr2d(ji,jj) = ziexcr2d(ji,jj) + (fmiexcr * fthk)
+ ENDIF
+ IF( med_diag%ZI_RESP%dgsave ) THEN
+ ziresp2d(ji,jj) = ziresp2d(ji,jj) + (fmiresp * fthk)
+ ENDIF
+ IF( med_diag%ZI_GROW%dgsave ) THEN
+ zigrow2d(ji,jj) = zigrow2d(ji,jj) + (fmigrow * fthk)
+ ENDIF
+ IF( med_diag%ZE_MES_N%dgsave ) THEN
+ zemesn2d(ji,jj) = zemesn2d(ji,jj) + &
+ (xphi * (fgmepn + fgmepd + fgmezmi + fgmed) * fthk)
+ ENDIF
+ IF( med_diag%ZE_MES_D%dgsave ) THEN
+ zemesd2d(ji,jj) = zemesd2d(ji,jj) + &
+ ((1. - xbetan) * finme * fthk)
+ ENDIF
+ IF( med_diag%ZE_MES_C%dgsave ) THEN
+ zemesc2d(ji,jj) = zemesc2d(ji,jj) + &
+ (xphi * ((xthetapn * fgmepn) + (xthetapd * fgmepd) + &
+ (xthetazmi * fgmezmi) + fgmedc) * fthk)
+ ENDIF
+ IF( med_diag%ZE_MESDC%dgsave ) THEN
+ zemesdc2d(ji,jj) = zemesdc2d(ji,jj) + &
+ ((1. - xbetac) * ficme * fthk)
+ ENDIF
+ IF( med_diag%ZE_EXCR%dgsave ) THEN
+ zeexcr2d(ji,jj) = zeexcr2d(ji,jj) + (fmeexcr * fthk)
+ ENDIF
+ IF( med_diag%ZE_RESP%dgsave ) THEN
+ zeresp2d(ji,jj) = zeresp2d(ji,jj) + (fmeresp * fthk)
+ ENDIF
+ IF( med_diag%ZE_GROW%dgsave ) THEN
+ zegrow2d(ji,jj) = zegrow2d(ji,jj) + (fmegrow * fthk)
+ ENDIF
+ IF( med_diag%MDETC%dgsave ) THEN
+ mdetc2d(ji,jj) = mdetc2d(ji,jj) + (fddc * fthk)
+ ENDIF
+ IF( med_diag%GMIDC%dgsave ) THEN
+ gmidc2d(ji,jj) = gmidc2d(ji,jj) + (fgmidc * fthk)
+ ENDIF
+ IF( med_diag%GMEDC%dgsave ) THEN
+ gmedc2d(ji,jj) = gmedc2d(ji,jj) + (fgmedc * fthk)
+ ENDIF
+ !!
+# endif
+ !!
+ !! ** 3D diagnostics
+ IF( med_diag%TPP3%dgsave ) THEN
+ tpp3d(ji,jj,jk) = (fprn * zphn) + (fprd * zphd)
+ !CALL iom_put( "TPP3" , tpp3d )
+ ENDIF
+ IF( med_diag%TPPD3%dgsave ) THEN
+ tppd3(ji,jj,jk) = (fprd * zphd)
+ ENDIF
+
+ IF( med_diag%REMIN3N%dgsave ) THEN
+ remin3dn(ji,jj,jk) = fregen + (freminn * fthk) !! remineralisation
+ !CALL iom_put( "REMIN3N" , remin3dn )
+ ENDIF
+ !! IF( med_diag%PH3%dgsave ) THEN
+ !! CALL iom_put( "PH3" , f3_pH )
+ !! ENDIF
+ !! IF( med_diag%OM_CAL3%dgsave ) THEN
+ !! CALL iom_put( "OM_CAL3" , f3_omcal )
+ !! ENDIF
+ !!
+ !! AXY (09/11/16): CMIP6 diagnostics
+ IF ( med_diag%DCALC3%dgsave ) THEN
+ dcalc3(ji,jj,jk) = freminca
+ ENDIF
+ IF ( med_diag%FEDISS3%dgsave ) THEN
+ fediss3(ji,jj,jk) = ffetop
+ ENDIF
+ IF ( med_diag%FESCAV3%dgsave ) THEN
+ fescav3(ji,jj,jk) = ffescav
+ ENDIF
+ IF ( med_diag%MIGRAZP3%dgsave ) THEN
+ migrazp3(ji,jj,jk) = fgmipn * xthetapn
+ ENDIF
+ IF ( med_diag%MIGRAZD3%dgsave ) THEN
+ migrazd3(ji,jj,jk) = fgmidc
+ ENDIF
+ IF ( med_diag%MEGRAZP3%dgsave ) THEN
+ megrazp3(ji,jj,jk) = (fgmepn * xthetapn) + (fgmepd * xthetapd)
+ ENDIF
+ IF ( med_diag%MEGRAZD3%dgsave ) THEN
+ megrazd3(ji,jj,jk) = fgmedc
+ ENDIF
+ IF ( med_diag%MEGRAZZ3%dgsave ) THEN
+ megrazz3(ji,jj,jk) = (fgmezmi * xthetazmi)
+ ENDIF
+ IF ( med_diag%PBSI3%dgsave ) THEN
+ pbsi3(ji,jj,jk) = (fprds * zpds)
+ ENDIF
+ IF ( med_diag%PCAL3%dgsave ) THEN
+ pcal3(ji,jj,jk) = ftempca
+ ENDIF
+ IF ( med_diag%REMOC3%dgsave ) THEN
+ remoc3(ji,jj,jk) = freminc
+ ENDIF
+ IF ( med_diag%PNLIMJ3%dgsave ) THEN
+ ! pnlimj3(ji,jj,jk) = fjln
+ pnlimj3(ji,jj,jk) = fjlim_pn
+ ENDIF
+ IF ( med_diag%PNLIMN3%dgsave ) THEN
+ pnlimn3(ji,jj,jk) = fnln
+ ENDIF
+ IF ( med_diag%PNLIMFE3%dgsave ) THEN
+ pnlimfe3(ji,jj,jk) = ffln
+ ENDIF
+ IF ( med_diag%PDLIMJ3%dgsave ) THEN
+ ! pdlimj3(ji,jj,jk) = fjld
+ pdlimj3(ji,jj,jk) = fjlim_pd
+ ENDIF
+ IF ( med_diag%PDLIMN3%dgsave ) THEN
+ pdlimn3(ji,jj,jk) = fnld
+ ENDIF
+ IF ( med_diag%PDLIMFE3%dgsave ) THEN
+ pdlimfe3(ji,jj,jk) = ffld
+ ENDIF
+ IF ( med_diag%PDLIMSI3%dgsave ) THEN
+ pdlimsi3(ji,jj,jk) = fsld2
+ ENDIF
+ !!
+ !! ** Without using iom_use
+ ELSE IF( ln_diatrc ) THEN
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'trc_bio_medusa: diag in ij-jj-jk ln_diatrc'
+ CALL flush(numout)
+# endif
+ !!----------------------------------------------------------------------
+ !! Prepare 2D diagnostics
+ !!----------------------------------------------------------------------
+ !!
+ !! if ((kt / 240*240).eq.kt) then
+ !! IF (lwp) write (*,*) '*******!MEDUSA DIAADD!*******',kt
+ !! endif
+ trc2d(ji,jj,1) = ftot_n(ji,jj) !! nitrogen inventory
+ trc2d(ji,jj,2) = ftot_si(ji,jj) !! silicon inventory
+ trc2d(ji,jj,3) = ftot_fe(ji,jj) !! iron inventory
+ trc2d(ji,jj,4) = trc2d(ji,jj,4) + (fprn * zphn * fthk) !! non-diatom production
+ trc2d(ji,jj,5) = trc2d(ji,jj,5) + (fdpn * fthk) !! non-diatom non-grazing losses
+ trc2d(ji,jj,6) = trc2d(ji,jj,6) + (fprd * zphd * fthk) !! diatom production
+ trc2d(ji,jj,7) = trc2d(ji,jj,7) + (fdpd * fthk) !! diatom non-grazing losses
+ !! diagnostic field 8 is (ostensibly) supplied by trcsed.F
+ trc2d(ji,jj,9) = trc2d(ji,jj,9) + (fprds * zpds * fthk) !! diatom silicon production
+ trc2d(ji,jj,10) = trc2d(ji,jj,10) + (fsdiss * fthk) !! diatom silicon dissolution
+ trc2d(ji,jj,11) = trc2d(ji,jj,11) + (fgmipn * fthk) !! microzoo grazing on non-diatoms
+ trc2d(ji,jj,12) = trc2d(ji,jj,12) + (fgmid * fthk) !! microzoo grazing on detrital nitrogen
+ trc2d(ji,jj,13) = trc2d(ji,jj,13) + (fdzmi * fthk) !! microzoo non-grazing losses
+ trc2d(ji,jj,14) = trc2d(ji,jj,14) + (fgmepn * fthk) !! mesozoo grazing on non-diatoms
+ trc2d(ji,jj,15) = trc2d(ji,jj,15) + (fgmepd * fthk) !! mesozoo grazing on diatoms
+ trc2d(ji,jj,16) = trc2d(ji,jj,16) + (fgmezmi * fthk) !! mesozoo grazing on microzoo
+ trc2d(ji,jj,17) = trc2d(ji,jj,17) + (fgmed * fthk) !! mesozoo grazing on detrital nitrogen
+ trc2d(ji,jj,18) = trc2d(ji,jj,18) + (fdzme * fthk) !! mesozoo non-grazing losses
+ !! diagnostic field 19 is (ostensibly) supplied by trcexp.F
+ trc2d(ji,jj,20) = trc2d(ji,jj,20) + (fslown * fthk) !! slow sinking detritus N production
+ trc2d(ji,jj,21) = trc2d(ji,jj,21) + (fdd * fthk) !! detrital remineralisation
+ trc2d(ji,jj,22) = trc2d(ji,jj,22) + (ffetop * fthk) !! aeolian iron addition
+ trc2d(ji,jj,23) = trc2d(ji,jj,23) + (ffebot * fthk) !! seafloor iron addition
+ trc2d(ji,jj,24) = trc2d(ji,jj,24) + (ffescav * fthk) !! "free" iron scavenging
+ trc2d(ji,jj,25) = trc2d(ji,jj,25) + (fjlim_pn * zphn * fthk) !! non-diatom J limitation term
+ trc2d(ji,jj,26) = trc2d(ji,jj,26) + (fnln * zphn * fthk) !! non-diatom N limitation term
+ trc2d(ji,jj,27) = trc2d(ji,jj,27) + (ffln * zphn * fthk) !! non-diatom Fe limitation term
+ trc2d(ji,jj,28) = trc2d(ji,jj,28) + (fjlim_pd * zphd * fthk) !! diatom J limitation term
+ trc2d(ji,jj,29) = trc2d(ji,jj,29) + (fnld * zphd * fthk) !! diatom N limitation term
+ trc2d(ji,jj,30) = trc2d(ji,jj,30) + (ffld * zphd * fthk) !! diatom Fe limitation term
+ trc2d(ji,jj,31) = trc2d(ji,jj,31) + (fsld2 * zphd * fthk) !! diatom Si limitation term
+ trc2d(ji,jj,32) = trc2d(ji,jj,32) + (fsld * zphd * fthk) !! diatom Si uptake limitation term
+ if (jk.eq.i0100) trc2d(ji,jj,33) = fslownflux(ji,jj) !! slow detritus flux at 100 m
+ if (jk.eq.i0200) trc2d(ji,jj,34) = fslownflux(ji,jj) !! slow detritus flux at 200 m
+ if (jk.eq.i0500) trc2d(ji,jj,35) = fslownflux(ji,jj) !! slow detritus flux at 500 m
+ if (jk.eq.i1000) trc2d(ji,jj,36) = fslownflux(ji,jj) !! slow detritus flux at 1000 m
+ trc2d(ji,jj,37) = trc2d(ji,jj,37) + fregen !! non-fast N full column regeneration
+ trc2d(ji,jj,38) = trc2d(ji,jj,38) + fregensi !! non-fast Si full column regeneration
+ if (jk.eq.i0100) trc2d(ji,jj,39) = trc2d(ji,jj,37) !! non-fast N regeneration to 100 m
+ if (jk.eq.i0200) trc2d(ji,jj,40) = trc2d(ji,jj,37) !! non-fast N regeneration to 200 m
+ if (jk.eq.i0500) trc2d(ji,jj,41) = trc2d(ji,jj,37) !! non-fast N regeneration to 500 m
+ if (jk.eq.i1000) trc2d(ji,jj,42) = trc2d(ji,jj,37) !! non-fast N regeneration to 1000 m
+ trc2d(ji,jj,43) = trc2d(ji,jj,43) + (ftempn * fthk) !! fast sinking detritus N production
+ trc2d(ji,jj,44) = trc2d(ji,jj,44) + (ftempsi * fthk) !! fast sinking detritus Si production
+ trc2d(ji,jj,45) = trc2d(ji,jj,45) + (ftempfe * fthk) !! fast sinking detritus Fe production
+ trc2d(ji,jj,46) = trc2d(ji,jj,46) + (ftempc * fthk) !! fast sinking detritus C production
+ trc2d(ji,jj,47) = trc2d(ji,jj,47) + (ftempca * fthk) !! fast sinking detritus CaCO3 production
+ if (jk.eq.i0100) trc2d(ji,jj,48) = ffastn(ji,jj) !! fast detritus N flux at 100 m
+ if (jk.eq.i0200) trc2d(ji,jj,49) = ffastn(ji,jj) !! fast detritus N flux at 200 m
+ if (jk.eq.i0500) trc2d(ji,jj,50) = ffastn(ji,jj) !! fast detritus N flux at 500 m
+ if (jk.eq.i1000) trc2d(ji,jj,51) = ffastn(ji,jj) !! fast detritus N flux at 1000 m
+ if (jk.eq.i0100) trc2d(ji,jj,52) = fregenfast(ji,jj) !! N regeneration to 100 m
+ if (jk.eq.i0200) trc2d(ji,jj,53) = fregenfast(ji,jj) !! N regeneration to 200 m
+ if (jk.eq.i0500) trc2d(ji,jj,54) = fregenfast(ji,jj) !! N regeneration to 500 m
+ if (jk.eq.i1000) trc2d(ji,jj,55) = fregenfast(ji,jj) !! N regeneration to 1000 m
+ if (jk.eq.i0100) trc2d(ji,jj,56) = ffastsi(ji,jj) !! fast detritus Si flux at 100 m
+ if (jk.eq.i0200) trc2d(ji,jj,57) = ffastsi(ji,jj) !! fast detritus Si flux at 200 m
+ if (jk.eq.i0500) trc2d(ji,jj,58) = ffastsi(ji,jj) !! fast detritus Si flux at 500 m
+ if (jk.eq.i1000) trc2d(ji,jj,59) = ffastsi(ji,jj) !! fast detritus Si flux at 1000 m
+ if (jk.eq.i0100) trc2d(ji,jj,60) = fregenfastsi(ji,jj) !! Si regeneration to 100 m
+ if (jk.eq.i0200) trc2d(ji,jj,61) = fregenfastsi(ji,jj) !! Si regeneration to 200 m
+ if (jk.eq.i0500) trc2d(ji,jj,62) = fregenfastsi(ji,jj) !! Si regeneration to 500 m
+ if (jk.eq.i1000) trc2d(ji,jj,63) = fregenfastsi(ji,jj) !! Si regeneration to 1000 m
+ trc2d(ji,jj,64) = trc2d(ji,jj,64) + (freminn * fthk) !! sum of fast-sinking N fluxes
+ trc2d(ji,jj,65) = trc2d(ji,jj,65) + (freminsi * fthk) !! sum of fast-sinking Si fluxes
+ trc2d(ji,jj,66) = trc2d(ji,jj,66) + (freminfe * fthk) !! sum of fast-sinking Fe fluxes
+ trc2d(ji,jj,67) = trc2d(ji,jj,67) + (freminc * fthk) !! sum of fast-sinking C fluxes
+ trc2d(ji,jj,68) = trc2d(ji,jj,68) + (freminca * fthk) !! sum of fast-sinking Ca fluxes
+ if (jk.eq.jmbathy) then
+ trc2d(ji,jj,69) = fsedn(ji,jj) !! N sedimentation flux
+ trc2d(ji,jj,70) = fsedsi(ji,jj) !! Si sedimentation flux
+ trc2d(ji,jj,71) = fsedfe(ji,jj) !! Fe sedimentation flux
+ trc2d(ji,jj,72) = fsedc(ji,jj) !! C sedimentation flux
+ trc2d(ji,jj,73) = fsedca(ji,jj) !! Ca sedimentation flux
+ endif
+ if (jk.eq.1) trc2d(ji,jj,74) = qsr(ji,jj)
+ if (jk.eq.1) trc2d(ji,jj,75) = xpar(ji,jj,jk)
+ !! if (jk.eq.1) trc2d(ji,jj,75) = real(iters)
+ !! diagnostic fields 76 to 80 calculated below
+ trc2d(ji,jj,81) = trc2d(ji,jj,81) + fprn_ml(ji,jj) !! mixed layer non-diatom production
+ trc2d(ji,jj,82) = trc2d(ji,jj,82) + fprd_ml(ji,jj) !! mixed layer diatom production
+# if defined key_gulf_finland
+ if (jk.eq.1) trc2d(ji,jj,83) = real(ibio_switch) !! Gulf of Finland check
+# else
+ trc2d(ji,jj,83) = ocal_ccd(ji,jj) !! calcite CCD depth
+# endif
+ trc2d(ji,jj,84) = fccd(ji,jj) !! last model level above calcite CCD depth
+ if (jk.eq.1) trc2d(ji,jj,85) = xFree(ji,jj) !! surface "free" iron
+ if (jk.eq.i0200) trc2d(ji,jj,86) = xFree(ji,jj) !! "free" iron at 100 m
+ if (jk.eq.i0200) trc2d(ji,jj,87) = xFree(ji,jj) !! "free" iron at 200 m
+ if (jk.eq.i0500) trc2d(ji,jj,88) = xFree(ji,jj) !! "free" iron at 500 m
+ if (jk.eq.i1000) trc2d(ji,jj,89) = xFree(ji,jj) !! "free" iron at 1000 m
+ !! AXY (27/06/12): extract "euphotic depth"
+ if (jk.eq.1) trc2d(ji,jj,90) = xze(ji,jj)
+ !!
+# if defined key_roam
+ !! ROAM provisionally has access to a further 20 2D diagnostics
+ if (jk .eq. 1) then
+ trc2d(ji,jj,91) = trc2d(ji,jj,91) + f_wind !! surface wind
+ trc2d(ji,jj,92) = trc2d(ji,jj,92) + f_pco2atm !! atmospheric pCO2
+ trc2d(ji,jj,93) = trc2d(ji,jj,93) + f_ph !! ocean pH
+ trc2d(ji,jj,94) = trc2d(ji,jj,94) + f_pco2w !! ocean pCO2
+ trc2d(ji,jj,95) = trc2d(ji,jj,95) + f_h2co3 !! ocean H2CO3 conc.
+ trc2d(ji,jj,96) = trc2d(ji,jj,96) + f_hco3 !! ocean HCO3 conc.
+ trc2d(ji,jj,97) = trc2d(ji,jj,97) + f_co3 !! ocean CO3 conc.
+ trc2d(ji,jj,98) = trc2d(ji,jj,98) + f_co2flux !! air-sea CO2 flux
+ trc2d(ji,jj,99) = trc2d(ji,jj,99) + f_omcal(ji,jj) !! ocean omega calcite
+ trc2d(ji,jj,100) = trc2d(ji,jj,100) + f_omarg(ji,jj) !! ocean omega aragonite
+ trc2d(ji,jj,101) = trc2d(ji,jj,101) + f_TDIC !! ocean TDIC
+ trc2d(ji,jj,102) = trc2d(ji,jj,102) + f_TALK !! ocean TALK
+ trc2d(ji,jj,103) = trc2d(ji,jj,103) + f_kw660 !! surface kw660
+ trc2d(ji,jj,104) = trc2d(ji,jj,104) + f_pp0 !! surface pressure
+ trc2d(ji,jj,105) = trc2d(ji,jj,105) + f_o2flux !! air-sea O2 flux
+ trc2d(ji,jj,106) = trc2d(ji,jj,106) + f_o2sat !! ocean O2 saturation
+ trc2d(ji,jj,107) = f2_ccd_cal(ji,jj) !! depth calcite CCD
+ trc2d(ji,jj,108) = f2_ccd_arg(ji,jj) !! depth aragonite CCD
+ endif
+ if (jk .eq. jmbathy) then
+ trc2d(ji,jj,109) = f3_omcal(ji,jj,jk) !! seafloor omega calcite
+ trc2d(ji,jj,110) = f3_omarg(ji,jj,jk) !! seafloor omega aragonite
+ endif
+ !! diagnostic fields 111 to 117 calculated below
+ if (jk.eq.i0100) trc2d(ji,jj,118) = ffastca(ji,jj)/MAX(ffastc(ji,jj), rsmall) !! rain ratio at 100 m
+ if (jk.eq.i0500) trc2d(ji,jj,119) = ffastca(ji,jj)/MAX(ffastc(ji,jj), rsmall) !! rain ratio at 500 m
+ if (jk.eq.i1000) trc2d(ji,jj,120) = ffastca(ji,jj)/MAX(ffastc(ji,jj), rsmall) !! rain ratio at 1000 m
+ !! AXY (18/01/12): benthic flux diagnostics
+ if (jk.eq.jmbathy) then
+ trc2d(ji,jj,121) = f_sbenin_n(ji,jj) + f_fbenin_n(ji,jj)
+ trc2d(ji,jj,122) = f_sbenin_fe(ji,jj) + f_fbenin_fe(ji,jj)
+ trc2d(ji,jj,123) = f_sbenin_c(ji,jj) + f_fbenin_c(ji,jj)
+ trc2d(ji,jj,124) = f_fbenin_si(ji,jj)
+ trc2d(ji,jj,125) = f_fbenin_ca(ji,jj)
+ trc2d(ji,jj,126) = f_benout_n(ji,jj)
+ trc2d(ji,jj,127) = f_benout_fe(ji,jj)
+ trc2d(ji,jj,128) = f_benout_c(ji,jj)
+ trc2d(ji,jj,129) = f_benout_si(ji,jj)
+ trc2d(ji,jj,130) = f_benout_ca(ji,jj)
+ endif
+ !! diagnostics fields 131 to 135 calculated below
+ trc2d(ji,jj,136) = f_runoff(ji,jj)
+ !! AXY (19/07/12): amended to allow for riverine nutrient addition below surface
+ trc2d(ji,jj,137) = trc2d(ji,jj,137) + (f_riv_loc_n * fthk)
+ trc2d(ji,jj,138) = trc2d(ji,jj,138) + (f_riv_loc_si * fthk)
+ trc2d(ji,jj,139) = trc2d(ji,jj,139) + (f_riv_loc_c * fthk)
+ trc2d(ji,jj,140) = trc2d(ji,jj,140) + (f_riv_loc_alk * fthk)
+ trc2d(ji,jj,141) = trc2d(ji,jj,141) + (fslowc * fthk) !! slow sinking detritus C production
+ if (jk.eq.i0100) trc2d(ji,jj,142) = fslowcflux(ji,jj) !! slow detritus flux at 100 m
+ if (jk.eq.i0200) trc2d(ji,jj,143) = fslowcflux(ji,jj) !! slow detritus flux at 200 m
+ if (jk.eq.i0500) trc2d(ji,jj,144) = fslowcflux(ji,jj) !! slow detritus flux at 500 m
+ if (jk.eq.i1000) trc2d(ji,jj,145) = fslowcflux(ji,jj) !! slow detritus flux at 1000 m
+ trc2d(ji,jj,146) = trc2d(ji,jj,146) + ftot_c(ji,jj) !! carbon inventory
+ trc2d(ji,jj,147) = trc2d(ji,jj,147) + ftot_a(ji,jj) !! alkalinity inventory
+ trc2d(ji,jj,148) = trc2d(ji,jj,148) + ftot_o2(ji,jj) !! oxygen inventory
+ if (jk.eq.jmbathy) then
+ trc2d(ji,jj,149) = f_benout_lyso_ca(ji,jj)
+ endif
+ trc2d(ji,jj,150) = fcomm_resp(ji,jj) * fthk !! community respiration
+ !!
+ !! AXY (14/02/14): a Valentines Day gift to BASIN - a shedload of new
+ !! diagnostics that they'll most likely never need!
+ !! (actually, as with all such gifts, I'm giving them
+ !! some things I'd like myself!)
+ !!
+ !! ----------------------------------------------------------------------
+ !! linear losses
+ !! non-diatom
+ trc2d(ji,jj,151) = trc2d(ji,jj,151) + (fdpn2 * fthk)
+ !! diatom
+ trc2d(ji,jj,152) = trc2d(ji,jj,152) + (fdpd2 * fthk)
+ !! microzooplankton
+ trc2d(ji,jj,153) = trc2d(ji,jj,153) + (fdzmi2 * fthk)
+ !! mesozooplankton
+ trc2d(ji,jj,154) = trc2d(ji,jj,154) + (fdzme2 * fthk)
+ !! ----------------------------------------------------------------------
+ !! microzooplankton grazing
+ !! microzooplankton messy -> N
+ trc2d(ji,jj,155) = trc2d(ji,jj,155) + (xphi * (fgmipn + fgmid) * fthk)
+ !! microzooplankton messy -> D
+ trc2d(ji,jj,156) = trc2d(ji,jj,156) + ((1. - xbetan) * finmi * fthk)
+ !! microzooplankton messy -> DIC
+ trc2d(ji,jj,157) = trc2d(ji,jj,157) + (xphi * ((xthetapn * fgmipn) + fgmidc) * fthk)
+ !! microzooplankton messy -> Dc
+ trc2d(ji,jj,158) = trc2d(ji,jj,158) + ((1. - xbetac) * ficmi * fthk)
+ !! microzooplankton excretion
+ trc2d(ji,jj,159) = trc2d(ji,jj,159) + (fmiexcr * fthk)
+ !! microzooplankton respiration
+ trc2d(ji,jj,160) = trc2d(ji,jj,160) + (fmiresp * fthk)
+ !! microzooplankton growth
+ trc2d(ji,jj,161) = trc2d(ji,jj,161) + (fmigrow * fthk)
+ !! ----------------------------------------------------------------------
+ !! mesozooplankton grazing
+ !! mesozooplankton messy -> N
+ trc2d(ji,jj,162) = trc2d(ji,jj,162) + (xphi * (fgmepn + fgmepd + fgmezmi + fgmed) * fthk)
+ !! mesozooplankton messy -> D
+ trc2d(ji,jj,163) = trc2d(ji,jj,163) + ((1. - xbetan) * finme * fthk)
+ !! mesozooplankton messy -> DIC
+ trc2d(ji,jj,164) = trc2d(ji,jj,164) + (xphi * ((xthetapn * fgmepn) + (xthetapd * fgmepd) + &
+ & (xthetazmi * fgmezmi) + fgmedc) * fthk)
+ !! mesozooplankton messy -> Dc
+ trc2d(ji,jj,165) = trc2d(ji,jj,165) + ((1. - xbetac) * ficme * fthk)
+ !! mesozooplankton excretion
+ trc2d(ji,jj,166) = trc2d(ji,jj,166) + (fmeexcr * fthk)
+ !! mesozooplankton respiration
+ trc2d(ji,jj,167) = trc2d(ji,jj,167) + (fmeresp * fthk)
+ !! mesozooplankton growth
+ trc2d(ji,jj,168) = trc2d(ji,jj,168) + (fmegrow * fthk)
+ !! ----------------------------------------------------------------------
+ !! miscellaneous
+ trc2d(ji,jj,169) = trc2d(ji,jj,169) + (fddc * fthk) !! detrital C remineralisation
+ trc2d(ji,jj,170) = trc2d(ji,jj,170) + (fgmidc * fthk) !! microzoo grazing on detrital carbon
+ trc2d(ji,jj,171) = trc2d(ji,jj,171) + (fgmedc * fthk) !! mesozoo grazing on detrital carbon
+ !!
+ !! ----------------------------------------------------------------------
+ !!
+ !! AXY (23/10/14): extract primary production related surface fields to
+ !! deal with diel cycle issues; hijacking BASIN 150m
+ !! diagnostics to do so (see commented out diagnostics
+ !! below this section)
+ !!
+ !! extract fields at surface
+ !! if (jk .eq. 1) then
+ !! trc2d(ji,jj,172) = zchn !! Pn chlorophyll
+ !! trc2d(ji,jj,173) = zphn !! Pn biomass
+ !! trc2d(ji,jj,174) = fjln !! Pn J-term
+ !! trc2d(ji,jj,175) = (fprn * zphn) !! Pn PP
+ !! trc2d(ji,jj,176) = zchd !! Pd chlorophyll
+ !! trc2d(ji,jj,177) = zphd !! Pd biomass
+ !! trc2d(ji,jj,178) = fjld !! Pd J-term
+ !! trc2d(ji,jj,179) = xpar(ji,jj,jk) !! Pd PP
+ !! trc2d(ji,jj,180) = loc_T !! local temperature
+ !! endif
+ !! !!
+ !! !! extract fields at 50m (actually 44-50m)
+ !! if (jk .eq. 18) then
+ !! trc2d(ji,jj,181) = zchn !! Pn chlorophyll
+ !! trc2d(ji,jj,182) = zphn !! Pn biomass
+ !! trc2d(ji,jj,183) = fjln !! Pn J-term
+ !! trc2d(ji,jj,184) = (fprn * zphn) !! Pn PP
+ !! trc2d(ji,jj,185) = zchd !! Pd chlorophyll
+ !! trc2d(ji,jj,186) = zphd !! Pd biomass
+ !! trc2d(ji,jj,187) = fjld !! Pd J-term
+ !! trc2d(ji,jj,188) = xpar(ji,jj,jk) !! Pd PP
+ !! trc2d(ji,jj,189) = loc_T !! local temperature
+ !! endif
+ !! !!
+ !! !! extract fields at 100m
+ !! if (jk .eq. i0100) then
+ !! trc2d(ji,jj,190) = zchn !! Pn chlorophyll
+ !! trc2d(ji,jj,191) = zphn !! Pn biomass
+ !! trc2d(ji,jj,192) = fjln !! Pn J-term
+ !! trc2d(ji,jj,193) = (fprn * zphn) !! Pn PP
+ !! trc2d(ji,jj,194) = zchd !! Pd chlorophyll
+ !! trc2d(ji,jj,195) = zphd !! Pd biomass
+ !! trc2d(ji,jj,196) = fjld !! Pd J-term
+ !! trc2d(ji,jj,197) = xpar(ji,jj,jk) !! Pd PP
+ !! trc2d(ji,jj,198) = loc_T !! local temperature
+ !! endif
+ !!
+ !! extract relevant BASIN fields at 150m
+ if (jk .eq. i0150) then
+ trc2d(ji,jj,172) = trc2d(ji,jj,4) !! Pn PP
+ trc2d(ji,jj,173) = trc2d(ji,jj,151) !! Pn linear loss
+ trc2d(ji,jj,174) = trc2d(ji,jj,5) !! Pn non-linear loss
+ trc2d(ji,jj,175) = trc2d(ji,jj,11) !! Pn grazing to Zmi
+ trc2d(ji,jj,176) = trc2d(ji,jj,14) !! Pn grazing to Zme
+ trc2d(ji,jj,177) = trc2d(ji,jj,6) !! Pd PP
+ trc2d(ji,jj,178) = trc2d(ji,jj,152) !! Pd linear loss
+ trc2d(ji,jj,179) = trc2d(ji,jj,7) !! Pd non-linear loss
+ trc2d(ji,jj,180) = trc2d(ji,jj,15) !! Pd grazing to Zme
+ trc2d(ji,jj,181) = trc2d(ji,jj,12) !! Zmi grazing on D
+ trc2d(ji,jj,182) = trc2d(ji,jj,170) !! Zmi grazing on Dc
+ trc2d(ji,jj,183) = trc2d(ji,jj,155) !! Zmi messy feeding loss to N
+ trc2d(ji,jj,184) = trc2d(ji,jj,156) !! Zmi messy feeding loss to D
+ trc2d(ji,jj,185) = trc2d(ji,jj,157) !! Zmi messy feeding loss to DIC
+ trc2d(ji,jj,186) = trc2d(ji,jj,158) !! Zmi messy feeding loss to Dc
+ trc2d(ji,jj,187) = trc2d(ji,jj,159) !! Zmi excretion
+ trc2d(ji,jj,188) = trc2d(ji,jj,160) !! Zmi respiration
+ trc2d(ji,jj,189) = trc2d(ji,jj,161) !! Zmi growth
+ trc2d(ji,jj,190) = trc2d(ji,jj,153) !! Zmi linear loss
+ trc2d(ji,jj,191) = trc2d(ji,jj,13) !! Zmi non-linear loss
+ trc2d(ji,jj,192) = trc2d(ji,jj,16) !! Zmi grazing to Zme
+ trc2d(ji,jj,193) = trc2d(ji,jj,17) !! Zme grazing on D
+ trc2d(ji,jj,194) = trc2d(ji,jj,171) !! Zme grazing on Dc
+ trc2d(ji,jj,195) = trc2d(ji,jj,162) !! Zme messy feeding loss to N
+ trc2d(ji,jj,196) = trc2d(ji,jj,163) !! Zme messy feeding loss to D
+ trc2d(ji,jj,197) = trc2d(ji,jj,164) !! Zme messy feeding loss to DIC
+ trc2d(ji,jj,198) = trc2d(ji,jj,165) !! Zme messy feeding loss to Dc
+ trc2d(ji,jj,199) = trc2d(ji,jj,166) !! Zme excretion
+ trc2d(ji,jj,200) = trc2d(ji,jj,167) !! Zme respiration
+ trc2d(ji,jj,201) = trc2d(ji,jj,168) !! Zme growth
+ trc2d(ji,jj,202) = trc2d(ji,jj,154) !! Zme linear loss
+ trc2d(ji,jj,203) = trc2d(ji,jj,18) !! Zme non-linear loss
+ trc2d(ji,jj,204) = trc2d(ji,jj,20) !! Slow detritus production, N
+ trc2d(ji,jj,205) = trc2d(ji,jj,21) !! Slow detritus remineralisation, N
+ trc2d(ji,jj,206) = trc2d(ji,jj,141) !! Slow detritus production, C
+ trc2d(ji,jj,207) = trc2d(ji,jj,169) !! Slow detritus remineralisation, C
+ trc2d(ji,jj,208) = trc2d(ji,jj,43) !! Fast detritus production, N
+ trc2d(ji,jj,209) = trc2d(ji,jj,21) !! Fast detritus remineralisation, N
+ trc2d(ji,jj,210) = trc2d(ji,jj,64) !! Fast detritus production, C
+ trc2d(ji,jj,211) = trc2d(ji,jj,67) !! Fast detritus remineralisation, C
+ trc2d(ji,jj,212) = trc2d(ji,jj,150) !! Community respiration
+ trc2d(ji,jj,213) = fslownflux(ji,jj) !! Slow detritus N flux at 150 m
+ trc2d(ji,jj,214) = fslowcflux(ji,jj) !! Slow detritus C flux at 150 m
+ trc2d(ji,jj,215) = ffastn(ji,jj) !! Fast detritus N flux at 150 m
+ trc2d(ji,jj,216) = ffastc(ji,jj) !! Fast detritus C flux at 150 m
+ endif
+ !!
+ !! Jpalm (11-08-2014)
+ !! Add UKESM1 diagnoatics
+ !!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ if ((jk .eq. 1) .and.( jdms.eq.1)) then
+ trc2d(ji,jj,221) = dms_surf !! DMS surface concentration
+ !! AXY (13/03/15): add in other DMS estimates
+ trc2d(ji,jj,222) = dms_andr !! DMS surface concentration
+ trc2d(ji,jj,223) = dms_simo !! DMS surface concentration
+ trc2d(ji,jj,224) = dms_aran !! DMS surface concentration
+ trc2d(ji,jj,225) = dms_hall !! DMS surface concentration
+ endif
+# endif
+ !! other possible future diagnostics include:
+ !! - integrated tracer values (esp. biological)
+ !! - mixed layer tracer values
+ !! - sub-surface chlorophyll maxima (plus depth)
+ !! - different mixed layer depth criteria (T, sigma, var. sigma)
+
+ !!----------------------------------------------------------------------
+ !! Prepare 3D diagnostics
+ !!----------------------------------------------------------------------
+ !!
+ trc3d(ji,jj,jk,1) = ((fprn + fprd) * zphn) !! primary production
+ trc3d(ji,jj,jk,2) = fslownflux(ji,jj) + ffastn(ji,jj) !! detrital flux
+ trc3d(ji,jj,jk,3) = fregen + (freminn * fthk) !! remineralisation
+# if defined key_roam
+ trc3d(ji,jj,jk,4) = f3_pH(ji,jj,jk) !! pH
+ trc3d(ji,jj,jk,5) = f3_omcal(ji,jj,jk) !! omega calcite
+# else
+ trc3d(ji,jj,jk,4) = ffastsi(ji,jj) !! fast Si flux
+# endif
+ ENDIF ! end of ln_diatrc option
+ !! CLOSE wet point IF..THEN loop
+ endif
+ !! CLOSE horizontal loops
+ ENDDO
+ ENDDO
+ !!
+ IF( lk_iomput .AND. .NOT. ln_diatrc ) THEN
+ !! first - 2D diag implemented
+ !! on every K level
+ !!-----------------------------------------
+ !! --
+ !!second - 2d specific k level diags
+ !!
+ !!-----------------------------------------
+ IF (jk.eq.1) THEN
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'trc_bio_medusa: diag jk = 1'
+ CALL flush(numout)
+# endif
+ !! JPALM -- 02-06-2017 --
+ !! add Chl surf coupling
+ !! no need to output, just pass to cpl var
+ IF (lk_oasis) THEN
+ zn_chl_srf(:,:) = (trn(:,:,1,jpchd) + trn(:,:,1,jpchn)) * 1.0E-6 !! surf Chl in Kg-chl/m3 as needed for cpl
+ chloro_out_cpl(:,:) = zn_chl_srf(:,:) !! Coupling Chl
+ END IF
+ IF( med_diag%MED_QSR%dgsave ) THEN
+ CALL iom_put( "MED_QSR" , qsr ) !
+ ENDIF
+ IF( med_diag%MED_XPAR%dgsave ) THEN
+ CALL iom_put( "MED_XPAR" , xpar(:,:,jk) ) !
+ ENDIF
+ IF( med_diag%OCAL_CCD%dgsave ) THEN
+ CALL iom_put( "OCAL_CCD" , ocal_ccd ) !
+ ENDIF
+ IF( med_diag%FE_0000%dgsave ) THEN
+ CALL iom_put( "FE_0000" , xFree ) !
+ ENDIF
+ IF( med_diag%MED_XZE%dgsave ) THEN
+ CALL iom_put( "MED_XZE" , xze ) !
+ ENDIF
+# if defined key_roam
+ IF( med_diag%WIND%dgsave ) THEN
+ CALL iom_put( "WIND" , wndm )
+ ENDIF
+ IF( med_diag%ATM_PCO2%dgsave ) THEN
+ CALL iom_put( "ATM_PCO2" , f_pco2a2d )
+ CALL wrk_dealloc( jpi, jpj, f_pco2a2d )
+ ENDIF
+ IF( med_diag%OCN_PH%dgsave ) THEN
+ zw2d(:,:) = f3_pH(:,:,jk)
+ CALL iom_put( "OCN_PH" , zw2d )
+ ENDIF
+ IF( med_diag%OCN_PCO2%dgsave ) THEN
+ CALL iom_put( "OCN_PCO2" , f_pco2w2d )
+ CALL wrk_dealloc( jpi, jpj, f_pco2w2d )
+ ENDIF
+ IF( med_diag%OCNH2CO3%dgsave ) THEN
+ zw2d(:,:) = f3_h2co3(:,:,jk)
+ CALL iom_put( "OCNH2CO3" , zw2d )
+ ENDIF
+ IF( med_diag%OCN_HCO3%dgsave ) THEN
+ zw2d(:,:) = f3_hco3(:,:,jk)
+ CALL iom_put( "OCN_HCO3" , zw2d )
+ ENDIF
+ IF( med_diag%OCN_CO3%dgsave ) THEN
+ zw2d(:,:) = f3_co3(:,:,jk)
+ CALL iom_put( "OCN_CO3" , zw2d )
+ ENDIF
+ IF( med_diag%CO2FLUX%dgsave ) THEN
+ CALL iom_put( "CO2FLUX" , f_co2flux2d )
+ CALL wrk_dealloc( jpi, jpj, f_co2flux2d )
+ ENDIF
+ !!
+ !! AXY (10/11/16): repeat CO2 flux diagnostic in UKMO/CMIP6 units; this
+ !! both outputs the CO2 flux in specified units and
+ !! sends the resulting field to the coupler
+ !! JPALM (17/11/16): put CO2 flux (fgco2) alloc/unalloc/pass to zn
+ !! out of diag list request
+ CALL lbc_lnk( fgco2(:,:),'T',1. )
+ IF( med_diag%FGCO2%dgsave ) THEN
+ CALL iom_put( "FGCO2" , fgco2 )
+ ENDIF
+ !! JPALM (17/11/16): should mv this fgco2 part
+ !! out of lk_iomput loop
+ zb_co2_flx = zn_co2_flx
+ zn_co2_flx = fgco2
+ IF (lk_oasis) THEN
+ CO2Flux_out_cpl = zn_co2_flx
+ ENDIF
+ CALL wrk_dealloc( jpi, jpj, fgco2 )
+ !! ---
+ IF( med_diag%OM_CAL%dgsave ) THEN
+ CALL iom_put( "OM_CAL" , f_omcal )
+ ENDIF
+ IF( med_diag%OM_ARG%dgsave ) THEN
+ CALL iom_put( "OM_ARG" , f_omarg )
+ ENDIF
+ IF( med_diag%TCO2%dgsave ) THEN
+ CALL iom_put( "TCO2" , f_TDIC2d )
+ CALL wrk_dealloc( jpi, jpj, f_TDIC2d )
+ ENDIF
+ IF( med_diag%TALK%dgsave ) THEN
+ CALL iom_put( "TALK" , f_TALK2d )
+ CALL wrk_dealloc( jpi, jpj, f_TALK2d )
+ ENDIF
+ IF( med_diag%KW660%dgsave ) THEN
+ CALL iom_put( "KW660" , f_kw6602d )
+ CALL wrk_dealloc( jpi, jpj, f_kw6602d )
+ ENDIF
+ IF( med_diag%ATM_PP0%dgsave ) THEN
+ CALL iom_put( "ATM_PP0" , f_pp02d )
+ CALL wrk_dealloc( jpi, jpj, f_pp02d )
+ ENDIF
+ IF( med_diag%O2FLUX%dgsave ) THEN
+ CALL iom_put( "O2FLUX" , f_o2flux2d )
+ CALL wrk_dealloc( jpi, jpj, f_o2flux2d )
+ ENDIF
+ IF( med_diag%O2SAT%dgsave ) THEN
+ CALL iom_put( "O2SAT" , f_o2sat2d )
+ CALL wrk_dealloc( jpi, jpj, f_o2sat2d )
+ ENDIF
+ IF( med_diag%CAL_CCD%dgsave ) THEN
+ CALL iom_put( "CAL_CCD" , f2_ccd_cal )
+ ENDIF
+ IF( med_diag%ARG_CCD%dgsave ) THEN
+ CALL iom_put( "ARG_CCD" , f2_ccd_arg )
+ ENDIF
+ IF (jdms .eq. 1) THEN
+ IF( med_diag%DMS_SURF%dgsave ) THEN
+ CALL lbc_lnk(dms_surf2d(:,:),'T',1. )
+ CALL iom_put( "DMS_SURF" , dms_surf2d )
+ zb_dms_srf = zn_dms_srf
+ zn_dms_srf = dms_surf2d
+ IF (lk_oasis) THEN
+ DMS_out_cpl = zn_dms_srf
+ ENDIF
+ CALL wrk_dealloc( jpi, jpj, dms_surf2d )
+ ENDIF
+ IF( med_diag%DMS_ANDR%dgsave ) THEN
+ CALL iom_put( "DMS_ANDR" , dms_andr2d )
+ CALL wrk_dealloc( jpi, jpj, dms_andr2d )
+ ENDIF
+ IF( med_diag%DMS_SIMO%dgsave ) THEN
+ CALL iom_put( "DMS_SIMO" , dms_simo2d )
+ CALL wrk_dealloc( jpi, jpj, dms_simo2d )
+ ENDIF
+ IF( med_diag%DMS_ARAN%dgsave ) THEN
+ CALL iom_put( "DMS_ARAN" , dms_aran2d )
+ CALL wrk_dealloc( jpi, jpj, dms_aran2d )
+ ENDIF
+ IF( med_diag%DMS_HALL%dgsave ) THEN
+ CALL iom_put( "DMS_HALL" , dms_hall2d )
+ CALL wrk_dealloc( jpi, jpj, dms_hall2d )
+ ENDIF
+ IF( med_diag%DMS_ANDM%dgsave ) THEN
+ CALL iom_put( "DMS_ANDM" , dms_andm2d )
+ CALL wrk_dealloc( jpi, jpj, dms_andm2d )
+ ENDIF
+ ENDIF
+ !! AXY (24/11/16): extra MOCSY diagnostics
+ IF( med_diag%ATM_XCO2%dgsave ) THEN
+ CALL iom_put( "ATM_XCO2" , f_xco2a_2d )
+ CALL wrk_dealloc( jpi, jpj, f_xco2a_2d )
+ ENDIF
+ IF( med_diag%OCN_FCO2%dgsave ) THEN
+ CALL iom_put( "OCN_FCO2" , f_fco2w_2d )
+ CALL wrk_dealloc( jpi, jpj, f_fco2w_2d )
+ ENDIF
+ IF( med_diag%ATM_FCO2%dgsave ) THEN
+ CALL iom_put( "ATM_FCO2" , f_fco2a_2d )
+ CALL wrk_dealloc( jpi, jpj, f_fco2a_2d )
+ ENDIF
+ IF( med_diag%OCN_RHOSW%dgsave ) THEN
+ CALL iom_put( "OCN_RHOSW" , f_ocnrhosw_2d )
+ CALL wrk_dealloc( jpi, jpj, f_ocnrhosw_2d )
+ ENDIF
+ IF( med_diag%OCN_SCHCO2%dgsave ) THEN
+ CALL iom_put( "OCN_SCHCO2" , f_ocnschco2_2d )
+ CALL wrk_dealloc( jpi, jpj, f_ocnschco2_2d )
+ ENDIF
+ IF( med_diag%OCN_KWCO2%dgsave ) THEN
+ CALL iom_put( "OCN_KWCO2" , f_ocnkwco2_2d )
+ CALL wrk_dealloc( jpi, jpj, f_ocnkwco2_2d )
+ ENDIF
+ IF( med_diag%OCN_K0%dgsave ) THEN
+ CALL iom_put( "OCN_K0" , f_ocnk0_2d )
+ CALL wrk_dealloc( jpi, jpj, f_ocnk0_2d )
+ ENDIF
+ IF( med_diag%CO2STARAIR%dgsave ) THEN
+ CALL iom_put( "CO2STARAIR" , f_co2starair_2d )
+ CALL wrk_dealloc( jpi, jpj, f_co2starair_2d )
+ ENDIF
+ IF( med_diag%OCN_DPCO2%dgsave ) THEN
+ CALL iom_put( "OCN_DPCO2" , f_ocndpco2_2d )
+ CALL wrk_dealloc( jpi, jpj, f_ocndpco2_2d )
+ ENDIF
+# endif
+ ELSE IF (jk.eq.i0100) THEN
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'trc_bio_medusa: diag jk = 100'
+ CALL flush(numout)
+# endif
+ IF( med_diag%SDT__100%dgsave ) THEN
+ zw2d(:,:) = fslownflux(:,:) * tmask(:,:,jk)
+ CALL iom_put( "SDT__100" , zw2d )
+ ENDIF
+ IF( med_diag%REG__100%dgsave ) THEN
+ CALL iom_put( "REG__100" , fregen2d )
+ ENDIF
+ IF( med_diag%FDT__100%dgsave ) THEN
+ CALL iom_put( "FDT__100" , ffastn )
+ ENDIF
+ IF( med_diag%RG__100F%dgsave ) THEN
+ CALL iom_put( "RG__100F" , fregenfast )
+ ENDIF
+ IF( med_diag%FDS__100%dgsave ) THEN
+ CALL iom_put( "FDS__100" , ffastsi )
+ ENDIF
+ IF( med_diag%RGS_100F%dgsave ) THEN
+ CALL iom_put( "RGS_100F" , fregenfastsi )
+ ENDIF
+ IF( med_diag%FE_0100%dgsave ) THEN
+ CALL iom_put( "FE_0100" , xFree )
+ ENDIF
+# if defined key_roam
+ IF( med_diag%RR_0100%dgsave ) THEN
+ CALL iom_put( "RR_0100" , ffastca2d )
+ ENDIF
+ IF( med_diag%SDC__100%dgsave ) THEN
+ zw2d(:,:) = fslowcflux(:,:) * tmask(:,:,jk)
+ CALL iom_put( "SDC__100" , zw2d )
+ ENDIF
+ IF( med_diag%epC100%dgsave ) THEN
+ zw2d(:,:) = (fslowcflux + ffastc) * tmask(:,:,jk)
+ CALL iom_put( "epC100" , zw2d )
+ ENDIF
+ IF( med_diag%epCALC100%dgsave ) THEN
+ CALL iom_put( "epCALC100" , ffastca )
+ ENDIF
+ IF( med_diag%epN100%dgsave ) THEN
+ zw2d(:,:) = (fslownflux + ffastn) * tmask(:,:,jk)
+ CALL iom_put( "epN100" , zw2d )
+ ENDIF
+ IF( med_diag%epSI100%dgsave ) THEN
+ CALL iom_put( "epSI100" , ffastsi )
+ ENDIF
+ ELSE IF (jk.eq.i0150) THEN
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'trc_bio_medusa: diag jk = 150'
+ CALL flush(numout)
+# endif
+# endif
+ ELSE IF (jk.eq.i0200) THEN
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'trc_bio_medusa: diag jk = 200'
+ CALL flush(numout)
+# endif
+ IF( med_diag%SDT__200%dgsave ) THEN
+ zw2d(:,:) = fslownflux(:,:) * tmask(:,:,jk)
+ CALL iom_put( "SDT__200" , zw2d )
+ ENDIF
+ IF( med_diag%REG__200%dgsave ) THEN
+ CALL iom_put( "REG__200" , fregen2d )
+ ENDIF
+ IF( med_diag%FDT__200%dgsave ) THEN
+ CALL iom_put( "FDT__200" , ffastn )
+ ENDIF
+ IF( med_diag%RG__200F%dgsave ) THEN
+ CALL iom_put( "RG__200F" , fregenfast )
+ ENDIF
+ IF( med_diag%FDS__200%dgsave ) THEN
+ CALL iom_put( "FDS__200" , ffastsi )
+ ENDIF
+ IF( med_diag%RGS_200F%dgsave ) THEN
+ CALL iom_put( "RGS_200F" , fregenfastsi )
+ ENDIF
+ IF( med_diag%FE_0200%dgsave ) THEN
+ CALL iom_put( "FE_0200" , xFree )
+ ENDIF
+# if defined key_roam
+ IF( med_diag%SDC__200%dgsave ) THEN
+ zw2d(:,:) = fslowcflux(:,:) * tmask(:,:,jk)
+ CALL iom_put( "SDC__200" , zw2d )
+ ENDIF
+# endif
+ ELSE IF (jk.eq.i0500) THEN
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'trc_bio_medusa: diag jk = 500'
+ CALL flush(numout)
+# endif
+ IF( med_diag%SDT__500%dgsave ) THEN
+ zw2d(:,:) = fslownflux(:,:) * tmask(:,:,jk)
+ CALL iom_put( "SDT__500" , zw2d )
+ ENDIF
+ IF( med_diag%REG__500%dgsave ) THEN
+ CALL iom_put( "REG__500" , fregen2d )
+ ENDIF
+ IF( med_diag%FDT__500%dgsave ) THEN
+ CALL iom_put( "FDT__500" , ffastn )
+ ENDIF
+ IF( med_diag%RG__500F%dgsave ) THEN
+ CALL iom_put( "RG__500F" , fregenfast )
+ ENDIF
+ IF( med_diag%FDS__500%dgsave ) THEN
+ CALL iom_put( "FDS__500" , ffastsi )
+ ENDIF
+ IF( med_diag%RGS_500F%dgsave ) THEN
+ CALL iom_put( "RGS_500F" , fregenfastsi )
+ ENDIF
+ IF( med_diag%FE_0500%dgsave ) THEN
+ CALL iom_put( "FE_0500" , xFree )
+ ENDIF
+# if defined key_roam
+ IF( med_diag%RR_0500%dgsave ) THEN
+ CALL iom_put( "RR_0500" , ffastca2d )
+ ENDIF
+ IF( med_diag%SDC__500%dgsave ) THEN
+ zw2d(:,:) = fslowcflux(:,:) * tmask(:,:,jk)
+ CALL iom_put( "SDC__500" , zw2d )
+ ENDIF
+# endif
+ ELSE IF (jk.eq.i1000) THEN
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'trc_bio_medusa: diag jk = 1000'
+ CALL flush(numout)
+# endif
+ IF( med_diag%SDT_1000%dgsave ) THEN
+ zw2d(:,:) = fslownflux(:,:) * tmask(:,:,jk)
+ CALL iom_put( "SDT_1000" , zw2d )
+ ENDIF
+ IF( med_diag%REG_1000%dgsave ) THEN
+ CALL iom_put( "REG_1000" , fregen2d )
+ ENDIF
+ IF( med_diag%FDT_1000%dgsave ) THEN
+ CALL iom_put( "FDT_1000" , ffastn )
+ ENDIF
+ IF( med_diag%RG_1000F%dgsave ) THEN
+ CALL iom_put( "RG_1000F" , fregenfast )
+ ENDIF
+ IF( med_diag%FDS_1000%dgsave ) THEN
+ CALL iom_put( "FDS_1000" , ffastsi )
+ ENDIF
+ IF( med_diag%RGS1000F%dgsave ) THEN
+ CALL iom_put( "RGS1000F" , fregenfastsi )
+ ENDIF
+ IF( med_diag%FE_1000%dgsave ) THEN
+ CALL iom_put( "FE_1000" , xFree )
+ ENDIF
+# if defined key_roam
+ IF( med_diag%RR_1000%dgsave ) THEN
+ CALL iom_put( "RR_1000" , ffastca2d )
+ CALL wrk_dealloc( jpi, jpj, ffastca2d )
+ ENDIF
+ IF( med_diag%SDC_1000%dgsave ) THEN
+ zw2d(:,:) = fslowcflux(:,:) * tmask(:,:,jk)
+ CALL iom_put( "SDC_1000" , zw2d )
+ ENDIF
+# endif
+ ENDIF
+ !! to do on every k loop :
+ IF( med_diag%DETFLUX3%dgsave ) THEN
+ detflux3d(:,:,jk) = (fslownflux(:,:) + ffastn(:,:)) * tmask(:,:,jk) !! detrital flux
+ !CALL iom_put( "DETFLUX3" , ftot_n )
+ ENDIF
+# if defined key_roam
+ IF( med_diag%EXPC3%dgsave ) THEN
+ expc3(:,:,jk) = (fslowcflux(:,:) + ffastc(:,:)) * tmask(:,:,jk)
+ ENDIF
+ IF( med_diag%EXPN3%dgsave ) THEN
+ expn3(:,:,jk) = (fslownflux(:,:) + ffastn(:,:)) * tmask(:,:,jk)
+ ENDIF
+# endif
+ ENDIF
+ !! CLOSE vertical loop
+ ENDDO
+
+ !!----------------------------------------------------------------------
+ !! Process benthic in/out fluxes
+ !! These can be handled outside of the 3D calculations since the
+ !! benthic pools (and fluxes) are 2D in nature; this code is
+ !! (shamelessly) borrowed from corresponding code in the LOBSTER
+ !! model
+ !!----------------------------------------------------------------------
+ !!
+ !! IF(lwp) WRITE(numout,*) 'AXY: rdt = ', rdt
+ if (jorgben.eq.1) then
+ za_sed_n(:,:) = zn_sed_n(:,:) + &
+ & ( f_sbenin_n(:,:) + f_fbenin_n(:,:) - f_benout_n(:,:) ) * (rdt / 86400.)
+ zn_sed_n(:,:) = za_sed_n(:,:)
+ !!
+ za_sed_fe(:,:) = zn_sed_fe(:,:) + &
+ & ( f_sbenin_fe(:,:) + f_fbenin_fe(:,:) - f_benout_fe(:,:) ) * (rdt / 86400.)
+ zn_sed_fe(:,:) = za_sed_fe(:,:)
+ !!
+ za_sed_c(:,:) = zn_sed_c(:,:) + &
+ & ( f_sbenin_c(:,:) + f_fbenin_c(:,:) - f_benout_c(:,:) ) * (rdt / 86400.)
+ zn_sed_c(:,:) = za_sed_c(:,:)
+ endif
+ if (jinorgben.eq.1) then
+ za_sed_si(:,:) = zn_sed_si(:,:) + &
+ & ( f_fbenin_si(:,:) - f_benout_si(:,:) ) * (rdt / 86400.)
+ zn_sed_si(:,:) = za_sed_si(:,:)
+ !!
+ za_sed_ca(:,:) = zn_sed_ca(:,:) + &
+ & ( f_fbenin_ca(:,:) - f_benout_ca(:,:) ) * (rdt / 86400.)
+ zn_sed_ca(:,:) = za_sed_ca(:,:)
+ endif
+ IF( ln_diatrc ) THEN
+ DO jj = 2,jpjm1
+ DO ji = 2,jpim1
+ trc2d(ji,jj,131) = za_sed_n(ji,jj)
+ trc2d(ji,jj,132) = za_sed_fe(ji,jj)
+ trc2d(ji,jj,133) = za_sed_c(ji,jj)
+ trc2d(ji,jj,134) = za_sed_si(ji,jj)
+ trc2d(ji,jj,135) = za_sed_ca(ji,jj)
+ ENDDO
+ ENDDO
+ !! AXY (07/07/15): temporary hijacking
+# if defined key_roam
+ !! trc2d(:,:,126) = zn_dms_chn(:,:)
+ !! trc2d(:,:,127) = zn_dms_chd(:,:)
+ !! trc2d(:,:,128) = zn_dms_mld(:,:)
+ !! trc2d(:,:,129) = zn_dms_qsr(:,:)
+ !! trc2d(:,:,130) = zn_dms_din(:,:)
+# endif
+ ENDIF
+ !!
+ if (ibenthic.eq.2) then
+ !! The code below (in this if ... then ... endif loop) is
+ !! effectively commented out because it does not work as
+ !! anticipated; it can be deleted at a later date
+ if (jorgben.eq.1) then
+ za_sed_n(:,:) = ( f_sbenin_n(:,:) + f_fbenin_n(:,:) - f_benout_n(:,:) ) * rdt
+ za_sed_fe(:,:) = ( f_sbenin_fe(:,:) + f_fbenin_fe(:,:) - f_benout_fe(:,:) ) * rdt
+ za_sed_c(:,:) = ( f_sbenin_c(:,:) + f_fbenin_c(:,:) - f_benout_c(:,:) ) * rdt
+ endif
+ if (jinorgben.eq.1) then
+ za_sed_si(:,:) = ( f_fbenin_si(:,:) - f_benout_si(:,:) ) * rdt
+ za_sed_ca(:,:) = ( f_fbenin_ca(:,:) - f_benout_ca(:,:) ) * rdt
+ endif
+ !!
+ !! Leap-frog scheme - only in explicit case, otherwise the time stepping
+ !! is already being done in trczdf
+ !! IF( l_trczdf_exp .AND. (ln_trcadv_cen2 .OR. ln_trcadv_tvd) ) THEN
+ !! zfact = 2. * rdttra(jk) * FLOAT( ndttrc )
+ !! IF( neuler == 0 .AND. kt == nittrc000 ) zfact = rdttra(jk) * FLOAT(ndttrc)
+ !! if (jorgben.eq.1) then
+ !! za_sed_n(:,:) = zb_sed_n(:,:) + ( zfact * za_sed_n(:,:) )
+ !! za_sed_fe(:,:) = zb_sed_fe(:,:) + ( zfact * za_sed_fe(:,:) )
+ !! za_sed_c(:,:) = zb_sed_c(:,:) + ( zfact * za_sed_c(:,:) )
+ !! endif
+ !! if (jinorgben.eq.1) then
+ !! za_sed_si(:,:) = zb_sed_si(:,:) + ( zfact * za_sed_si(:,:) )
+ !! za_sed_ca(:,:) = zb_sed_ca(:,:) + ( zfact * za_sed_ca(:,:) )
+ !! endif
+ !! ENDIF
+ !!
+ !! Time filter and swap of arrays
+ IF( ln_trcadv_cen2 .OR. ln_trcadv_tvd ) THEN ! centred or tvd scheme
+ IF( neuler == 0 .AND. kt == nittrc000 ) THEN
+ if (jorgben.eq.1) then
+ zb_sed_n(:,:) = zn_sed_n(:,:)
+ zn_sed_n(:,:) = za_sed_n(:,:)
+ za_sed_n(:,:) = 0.0
+ !!
+ zb_sed_fe(:,:) = zn_sed_fe(:,:)
+ zn_sed_fe(:,:) = za_sed_fe(:,:)
+ za_sed_fe(:,:) = 0.0
+ !!
+ zb_sed_c(:,:) = zn_sed_c(:,:)
+ zn_sed_c(:,:) = za_sed_c(:,:)
+ za_sed_c(:,:) = 0.0
+ endif
+ if (jinorgben.eq.1) then
+ zb_sed_si(:,:) = zn_sed_si(:,:)
+ zn_sed_si(:,:) = za_sed_si(:,:)
+ za_sed_si(:,:) = 0.0
+ !!
+ zb_sed_ca(:,:) = zn_sed_ca(:,:)
+ zn_sed_ca(:,:) = za_sed_ca(:,:)
+ za_sed_ca(:,:) = 0.0
+ endif
+ ELSE
+ if (jorgben.eq.1) then
+ zb_sed_n(:,:) = (atfp * ( zb_sed_n(:,:) + za_sed_n(:,:) )) + (atfp1 * zn_sed_n(:,:) )
+ zn_sed_n(:,:) = za_sed_n(:,:)
+ za_sed_n(:,:) = 0.0
+ !!
+ zb_sed_fe(:,:) = (atfp * ( zb_sed_fe(:,:) + za_sed_fe(:,:) )) + (atfp1 * zn_sed_fe(:,:))
+ zn_sed_fe(:,:) = za_sed_fe(:,:)
+ za_sed_fe(:,:) = 0.0
+ !!
+ zb_sed_c(:,:) = (atfp * ( zb_sed_c(:,:) + za_sed_c(:,:) )) + (atfp1 * zn_sed_c(:,:) )
+ zn_sed_c(:,:) = za_sed_c(:,:)
+ za_sed_c(:,:) = 0.0
+ endif
+ if (jinorgben.eq.1) then
+ zb_sed_si(:,:) = (atfp * ( zb_sed_si(:,:) + za_sed_si(:,:) )) + (atfp1 * zn_sed_si(:,:))
+ zn_sed_si(:,:) = za_sed_si(:,:)
+ za_sed_si(:,:) = 0.0
+ !!
+ zb_sed_ca(:,:) = (atfp * ( zb_sed_ca(:,:) + za_sed_ca(:,:) )) + (atfp1 * zn_sed_ca(:,:))
+ zn_sed_ca(:,:) = za_sed_ca(:,:)
+ za_sed_ca(:,:) = 0.0
+ endif
+ ENDIF
+ ELSE ! case of smolar scheme or muscl
+ if (jorgben.eq.1) then
+ zb_sed_n(:,:) = za_sed_n(:,:)
+ zn_sed_n(:,:) = za_sed_n(:,:)
+ za_sed_n(:,:) = 0.0
+ !!
+ zb_sed_fe(:,:) = za_sed_fe(:,:)
+ zn_sed_fe(:,:) = za_sed_fe(:,:)
+ za_sed_fe(:,:) = 0.0
+ !!
+ zb_sed_c(:,:) = za_sed_c(:,:)
+ zn_sed_c(:,:) = za_sed_c(:,:)
+ za_sed_c(:,:) = 0.0
+ endif
+ if (jinorgben.eq.1) then
+ zb_sed_si(:,:) = za_sed_si(:,:)
+ zn_sed_si(:,:) = za_sed_si(:,:)
+ za_sed_si(:,:) = 0.0
+ !!
+ zb_sed_ca(:,:) = za_sed_ca(:,:)
+ zn_sed_ca(:,:) = za_sed_ca(:,:)
+ za_sed_ca(:,:) = 0.0
+ endif
+ ENDIF
+ endif
+
+ IF( ln_diatrc ) THEN
+ !!----------------------------------------------------------------------
+ !! Output several accumulated diagnostics
+ !! - biomass-average phytoplankton limitation terms
+ !! - integrated tendency terms
+ !!----------------------------------------------------------------------
+ !!
+ DO jj = 2,jpjm1
+ DO ji = 2,jpim1
+ !! non-diatom phytoplankton limitations
+ trc2d(ji,jj,25) = trc2d(ji,jj,25) / MAX(ftot_pn(ji,jj), rsmall)
+ trc2d(ji,jj,26) = trc2d(ji,jj,26) / MAX(ftot_pn(ji,jj), rsmall)
+ trc2d(ji,jj,27) = trc2d(ji,jj,27) / MAX(ftot_pn(ji,jj), rsmall)
+ !! diatom phytoplankton limitations
+ trc2d(ji,jj,28) = trc2d(ji,jj,28) / MAX(ftot_pd(ji,jj), rsmall)
+ trc2d(ji,jj,29) = trc2d(ji,jj,29) / MAX(ftot_pd(ji,jj), rsmall)
+ trc2d(ji,jj,30) = trc2d(ji,jj,30) / MAX(ftot_pd(ji,jj), rsmall)
+ trc2d(ji,jj,31) = trc2d(ji,jj,31) / MAX(ftot_pd(ji,jj), rsmall)
+ trc2d(ji,jj,32) = trc2d(ji,jj,32) / MAX(ftot_pd(ji,jj), rsmall)
+ !! tendency terms
+ trc2d(ji,jj,76) = fflx_n(ji,jj)
+ trc2d(ji,jj,77) = fflx_si(ji,jj)
+ trc2d(ji,jj,78) = fflx_fe(ji,jj)
+ !! integrated biomass
+ trc2d(ji,jj,79) = ftot_pn(ji,jj) !! integrated non-diatom phytoplankton
+ trc2d(ji,jj,80) = ftot_pd(ji,jj) !! integrated diatom phytoplankton
+ trc2d(ji,jj,217) = ftot_zmi(ji,jj) !! Integrated microzooplankton
+ trc2d(ji,jj,218) = ftot_zme(ji,jj) !! Integrated mesozooplankton
+ trc2d(ji,jj,219) = ftot_det(ji,jj) !! Integrated slow detritus, nitrogen
+ trc2d(ji,jj,220) = ftot_dtc(ji,jj) !! Integrated slow detritus, carbon
+# if defined key_roam
+ !! the balance of nitrogen production/consumption
+ trc2d(ji,jj,111) = fnit_prod(ji,jj) !! integrated nitrogen production
+ trc2d(ji,jj,112) = fnit_cons(ji,jj) !! integrated nitrogen consumption
+ !! the balance of carbon production/consumption
+ trc2d(ji,jj,113) = fcar_prod(ji,jj) !! integrated carbon production
+ trc2d(ji,jj,114) = fcar_cons(ji,jj) !! integrated carbon consumption
+ !! the balance of oxygen production/consumption
+ trc2d(ji,jj,115) = foxy_prod(ji,jj) !! integrated oxygen production
+ trc2d(ji,jj,116) = foxy_cons(ji,jj) !! integrated oxygen consumption
+ trc2d(ji,jj,117) = foxy_anox(ji,jj) !! integrated unrealised oxygen consumption
+# endif
+ ENDDO
+ ENDDO
+
+# if defined key_roam
+# if defined key_axy_nancheck
+ !!----------------------------------------------------------------------
+ !! Check for NaNs in diagnostic outputs
+ !!----------------------------------------------------------------------
+ !!
+ !! 2D diagnostics
+ DO jn = 1,150
+ fq0 = SUM(trc2d(:,:,jn))
+ !! AXY (30/01/14): "isnan" problem on HECTOR
+ !! if (fq0 /= fq0 ) then
+ if ( ieee_is_nan( fq0 ) ) then
+ !! there's a NaN here
+ if (lwp) write(numout,*) 'NAN detected in 2D diagnostic field', jn, 'at time', kt, 'at position:'
+ DO jj = 1,jpj
+ DO ji = 1,jpi
+ if ( ieee_is_nan( trc2d(ji,jj,jn) ) ) then
+ if (lwp) write (numout,'(a,3i6)') 'NAN-CHECK', &
+ & ji, jj, jn
+ endif
+ ENDDO
+ ENDDO
+ CALL ctl_stop( 'trcbio_medusa, NAN in 2D diagnostic field' )
+ endif
+ ENDDO
+ !!
+ !! 3D diagnostics
+ DO jn = 1,5
+ fq0 = SUM(trc3d(:,:,:,jn))
+ !! AXY (30/01/14): "isnan" problem on HECTOR
+ !! if (fq0 /= fq0 ) then
+ if ( ieee_is_nan( fq0 ) ) then
+ !! there's a NaN here
+ if (lwp) write(numout,*) 'NAN detected in 3D diagnostic field', jn, 'at time', kt, 'at position:'
+ DO jk = 1,jpk
+ DO jj = 1,jpj
+ DO ji = 1,jpi
+ if ( ieee_is_nan( trc3d(ji,jj,jk,jn) ) ) then
+ if (lwp) write (numout,'(a,4i6)') 'NAN-CHECK', &
+ & ji, jj, jk, jn
+ endif
+ ENDDO
+ ENDDO
+ ENDDO
+ CALL ctl_stop( 'trcbio_medusa, NAN in 3D diagnostic field' )
+ endif
+ ENDDO
+ CALL flush(numout)
+# endif
+# endif
+
+ !!----------------------------------------------------------------------
+ !! Don't know what this does; belongs to someone else ...
+ !!----------------------------------------------------------------------
+ !!
+ !! Lateral boundary conditions on trc2d
+ DO jn=1,jp_medusa_2d
+ CALL lbc_lnk(trc2d(:,:,jn),'T',1. )
+ ENDDO
+
+ !! Lateral boundary conditions on trc3d
+ DO jn=1,jp_medusa_3d
+ CALL lbc_lnk(trc3d(:,:,1,jn),'T',1. )
+ ENDDO
+
+
+# if defined key_axy_nodiag
+ !!----------------------------------------------------------------------
+ !! Blank diagnostics as a NaN-trap
+ !!----------------------------------------------------------------------
+ !!
+ !! blank 2D diagnostic array
+ trc2d(:,:,:) = 0.e0
+ !!
+ !! blank 3D diagnostic array
+ trc3d(:,:,:,:) = 0.e0
+# endif
+
+
+ !!----------------------------------------------------------------------
+ !! Add in XML diagnostics stuff
+ !!----------------------------------------------------------------------
+ !!
+ !! ** 2D diagnostics
+ DO jn=1,jp_medusa_2d
+ CALL iom_put(TRIM(ctrc2d(jn)), trc2d(:,:,jn))
+ END DO
+!! AXY (17/02/14): don't think I need this if I modify the above for all diagnostics
+!! # if defined key_roam
+!! DO jn=91,jp_medusa_2d
+!! CALL iom_put(TRIM(ctrc2d(jn)), trc2d(:,:,jn))
+!! END DO
+!! # endif
+ !!
+ !! ** 3D diagnostics
+ DO jn=1,jp_medusa_3d
+ CALL iom_put(TRIM(ctrc3d(jn)), trc3d(:,:,:,jn))
+ END DO
+!! AXY (17/02/14): don't think I need this if I modify the above for all diagnostics
+!! # if defined key_roam
+!! CALL iom_put(TRIM(ctrc3d(5)), trc3d(:,:,:,5))
+!! # endif
+
+
+ ELSE IF( lk_iomput .AND. .NOT. ln_diatrc ) THEN
+ !!!----------------------------------------------------------------------
+ !! Add very last diag calculations
+ !!!----------------------------------------------------------------------
+ DO jj = 2,jpjm1
+ DO ji = 2,jpim1
+ !!
+ IF( med_diag%PN_JLIM%dgsave ) THEN
+ fjln2d(ji,jj) = fjln2d(ji,jj) / MAX(ftot_pn(ji,jj), rsmall)
+ ENDIF
+ IF( med_diag%PN_NLIM%dgsave ) THEN
+ fnln2d(ji,jj) = fnln2d(ji,jj) / MAX(ftot_pn(ji,jj), rsmall)
+ ENDIF
+ IF( med_diag%PN_FELIM%dgsave ) THEN
+ ffln2d(ji,jj) = ffln2d(ji,jj) / MAX(ftot_pn(ji,jj), rsmall)
+ ENDIF
+ IF( med_diag%PD_JLIM%dgsave ) THEN
+ fjld2d(ji,jj) = fjld2d(ji,jj) / MAX(ftot_pd(ji,jj), rsmall)
+ ENDIF
+ IF( med_diag%PD_NLIM%dgsave ) THEN
+ fnld2d(ji,jj) = fnld2d(ji,jj) / MAX(ftot_pd(ji,jj), rsmall)
+ ENDIF
+ IF( med_diag%PD_FELIM%dgsave ) THEN
+ ffld2d(ji,jj) = ffld2d(ji,jj) / MAX(ftot_pd(ji,jj), rsmall)
+ ENDIF
+ IF( med_diag%PD_SILIM%dgsave ) THEN
+ fsld2d2(ji,jj) = fsld2d2(ji,jj) / MAX(ftot_pd(ji,jj), rsmall)
+ ENDIF
+ IF( med_diag%PDSILIM2%dgsave ) THEN
+ fsld2d(ji,jj) = fsld2d(ji,jj) / MAX(ftot_pd(ji,jj), rsmall)
+ ENDIF
+ ENDDO
+ ENDDO
+ !!----------------------------------------------------------------------
+ !! Add in XML diagnostics stuff
+ !!----------------------------------------------------------------------
+ !!
+ !! ** 2D diagnostics
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'trc_bio_medusa: export all diag.'
+ CALL flush(numout)
+# endif
+ IF ( med_diag%INVTN%dgsave ) THEN
+ CALL iom_put( "INVTN" , ftot_n )
+ ENDIF
+ IF ( med_diag%INVTSI%dgsave ) THEN
+ CALL iom_put( "INVTSI" , ftot_si )
+ ENDIF
+ IF ( med_diag%INVTFE%dgsave ) THEN
+ CALL iom_put( "INVTFE" , ftot_fe )
+ ENDIF
+ IF ( med_diag%ML_PRN%dgsave ) THEN
+ CALL iom_put( "ML_PRN" , fprn_ml )
+ ENDIF
+ IF ( med_diag%ML_PRD%dgsave ) THEN
+ CALL iom_put( "ML_PRD" , fprd_ml )
+ ENDIF
+ IF ( med_diag%OCAL_LVL%dgsave ) THEN
+ CALL iom_put( "OCAL_LVL" , fccd )
+ ENDIF
+ IF ( med_diag%PN_JLIM%dgsave ) THEN
+ CALL iom_put( "PN_JLIM" , fjln2d )
+ CALL wrk_dealloc( jpi, jpj, fjln2d )
+ ENDIF
+ IF ( med_diag%PN_NLIM%dgsave ) THEN
+ CALL iom_put( "PN_NLIM" , fnln2d )
+ CALL wrk_dealloc( jpi, jpj, fnln2d )
+ ENDIF
+ IF ( med_diag%PN_FELIM%dgsave ) THEN
+ CALL iom_put( "PN_FELIM" , ffln2d )
+ CALL wrk_dealloc( jpi, jpj, ffln2d )
+ ENDIF
+ IF ( med_diag%PD_JLIM%dgsave ) THEN
+ CALL iom_put( "PD_JLIM" , fjld2d )
+ CALL wrk_dealloc( jpi, jpj, fjld2d )
+ ENDIF
+ IF ( med_diag%PD_NLIM%dgsave ) THEN
+ CALL iom_put( "PD_NLIM" , fnld2d )
+ CALL wrk_dealloc( jpi, jpj, fnld2d )
+ ENDIF
+ IF ( med_diag%PD_FELIM%dgsave ) THEN
+ CALL iom_put( "PD_FELIM" , ffld2d )
+ CALL wrk_dealloc( jpi, jpj, ffld2d )
+ ENDIF
+ IF ( med_diag%PD_SILIM%dgsave ) THEN
+ CALL iom_put( "PD_SILIM" , fsld2d2 )
+ CALL wrk_dealloc( jpi, jpj, fsld2d2 )
+ ENDIF
+ IF ( med_diag%PDSILIM2%dgsave ) THEN
+ CALL iom_put( "PDSILIM2" , fsld2d )
+ CALL wrk_dealloc( jpi, jpj, fsld2d )
+ ENDIF
+ IF ( med_diag%INTFLX_N%dgsave ) THEN
+ CALL iom_put( "INTFLX_N" , fflx_n )
+ ENDIF
+ IF ( med_diag%INTFLX_SI%dgsave ) THEN
+ CALL iom_put( "INTFLX_SI" , fflx_si )
+ ENDIF
+ IF ( med_diag%INTFLX_FE%dgsave ) THEN
+ CALL iom_put( "INTFLX_FE" , fflx_fe )
+ ENDIF
+ IF ( med_diag%INT_PN%dgsave ) THEN
+ CALL iom_put( "INT_PN" , ftot_pn )
+ ENDIF
+ IF ( med_diag%INT_PD%dgsave ) THEN
+ CALL iom_put( "INT_PD" , ftot_pd )
+ ENDIF
+ IF ( med_diag%INT_ZMI%dgsave ) THEN
+ CALL iom_put( "INT_ZMI" , ftot_zmi )
+ ENDIF
+ IF ( med_diag%INT_ZME%dgsave ) THEN
+ CALL iom_put( "INT_ZME" , ftot_zme )
+ ENDIF
+ IF ( med_diag%INT_DET%dgsave ) THEN
+ CALL iom_put( "INT_DET" , ftot_det )
+ ENDIF
+ IF ( med_diag%INT_DTC%dgsave ) THEN
+ CALL iom_put( "INT_DTC" , ftot_dtc )
+ ENDIF
+ IF ( med_diag%BEN_N%dgsave ) THEN
+ CALL iom_put( "BEN_N" , za_sed_n )
+ ENDIF
+ IF ( med_diag%BEN_FE%dgsave ) THEN
+ CALL iom_put( "BEN_FE" , za_sed_fe )
+ ENDIF
+ IF ( med_diag%BEN_C%dgsave ) THEN
+ CALL iom_put( "BEN_C" , za_sed_c )
+ ENDIF
+ IF ( med_diag%BEN_SI%dgsave ) THEN
+ CALL iom_put( "BEN_SI" , za_sed_si )
+ ENDIF
+ IF ( med_diag%BEN_CA%dgsave ) THEN
+ CALL iom_put( "BEN_CA" , za_sed_ca )
+ ENDIF
+ IF ( med_diag%RUNOFF%dgsave ) THEN
+ CALL iom_put( "RUNOFF" , f_runoff )
+ ENDIF
+# if defined key_roam
+ IF ( med_diag%N_PROD%dgsave ) THEN
+ CALL iom_put( "N_PROD" , fnit_prod )
+ ENDIF
+ IF ( med_diag%N_CONS%dgsave ) THEN
+ CALL iom_put( "N_CONS" , fnit_cons )
+ ENDIF
+ IF ( med_diag%C_PROD%dgsave ) THEN
+ CALL iom_put( "C_PROD" , fcar_prod )
+ ENDIF
+ IF ( med_diag%C_CONS%dgsave ) THEN
+ CALL iom_put( "C_CONS" , fcar_cons )
+ ENDIF
+ IF ( med_diag%O2_PROD%dgsave ) THEN
+ CALL iom_put( "O2_PROD" , foxy_prod )
+ ENDIF
+ IF ( med_diag%O2_CONS%dgsave ) THEN
+ CALL iom_put( "O2_CONS" , foxy_cons )
+ ENDIF
+ IF ( med_diag%O2_ANOX%dgsave ) THEN
+ CALL iom_put( "O2_ANOX" , foxy_anox )
+ ENDIF
+ IF ( med_diag%INVTC%dgsave ) THEN
+ CALL iom_put( "INVTC" , ftot_c )
+ ENDIF
+ IF ( med_diag%INVTALK%dgsave ) THEN
+ CALL iom_put( "INVTALK" , ftot_a )
+ ENDIF
+ IF ( med_diag%INVTO2%dgsave ) THEN
+ CALL iom_put( "INVTO2" , ftot_o2 )
+ ENDIF
+ IF ( med_diag%COM_RESP%dgsave ) THEN
+ CALL iom_put( "COM_RESP" , fcomm_resp )
+ ENDIF
+# endif
+ !!
+ !! diagnostic filled in the i-j-k main loop
+ !!--------------------------------------------
+ IF ( med_diag%PRN%dgsave ) THEN
+ CALL iom_put( "PRN" , fprn2d )
+ CALL wrk_dealloc( jpi, jpj, fprn2d )
+ ENDIF
+ IF ( med_diag%MPN%dgsave ) THEN
+ CALL iom_put( "MPN" ,fdpn2d )
+ CALL wrk_dealloc( jpi, jpj, fdpn2d )
+ ENDIF
+ IF ( med_diag%PRD%dgsave ) THEN
+ CALL iom_put( "PRD" ,fprd2d )
+ CALL wrk_dealloc( jpi, jpj, fprd2d )
+ ENDIF
+ IF( med_diag%MPD%dgsave ) THEN
+ CALL iom_put( "MPD" , fdpd2d )
+ CALL wrk_dealloc( jpi, jpj, fdpd2d )
+ ENDIF
+ ! IF( med_diag%DSED%dgsave ) THEN
+ ! CALL iom_put( "DSED" , ftot_n )
+ ! ENDIF
+ IF( med_diag%OPAL%dgsave ) THEN
+ CALL iom_put( "OPAL" , fprds2d )
+ CALL wrk_dealloc( jpi, jpj, fprds2d )
+ ENDIF
+ IF( med_diag%OPALDISS%dgsave ) THEN
+ CALL iom_put( "OPALDISS" , fsdiss2d )
+ CALL wrk_dealloc( jpi, jpj, fsdiss2d )
+ ENDIF
+ IF( med_diag%GMIPn%dgsave ) THEN
+ CALL iom_put( "GMIPn" , fgmipn2d )
+ CALL wrk_dealloc( jpi, jpj, fgmipn2d )
+ ENDIF
+ IF( med_diag%GMID%dgsave ) THEN
+ CALL iom_put( "GMID" , fgmid2d )
+ CALL wrk_dealloc( jpi, jpj, fgmid2d )
+ ENDIF
+ IF( med_diag%MZMI%dgsave ) THEN
+ CALL iom_put( "MZMI" , fdzmi2d )
+ CALL wrk_dealloc( jpi, jpj, fdzmi2d )
+ ENDIF
+ IF( med_diag%GMEPN%dgsave ) THEN
+ CALL iom_put( "GMEPN" , fgmepn2d )
+ CALL wrk_dealloc( jpi, jpj, fgmepn2d )
+ ENDIF
+ IF( med_diag%GMEPD%dgsave ) THEN
+ CALL iom_put( "GMEPD" , fgmepd2d )
+ CALL wrk_dealloc( jpi, jpj, fgmepd2d )
+ ENDIF
+ IF( med_diag%GMEZMI%dgsave ) THEN
+ CALL iom_put( "GMEZMI" , fgmezmi2d )
+ CALL wrk_dealloc( jpi, jpj, fgmezmi2d )
+ ENDIF
+ IF( med_diag%GMED%dgsave ) THEN
+ CALL iom_put( "GMED" , fgmed2d )
+ CALL wrk_dealloc( jpi, jpj, fgmed2d )
+ ENDIF
+ IF( med_diag%MZME%dgsave ) THEN
+ CALL iom_put( "MZME" , fdzme2d )
+ CALL wrk_dealloc( jpi, jpj, fdzme2d )
+ ENDIF
+ ! IF( med_diag%DEXP%dgsave ) THEN
+ ! CALL iom_put( "DEXP" , ftot_n )
+ ! ENDIF
+ IF( med_diag%DETN%dgsave ) THEN
+ CALL iom_put( "DETN" , fslown2d )
+ CALL wrk_dealloc( jpi, jpj, fslown2d )
+ ENDIF
+ IF( med_diag%MDET%dgsave ) THEN
+ CALL iom_put( "MDET" , fdd2d )
+ CALL wrk_dealloc( jpi, jpj, fdd2d )
+ ENDIF
+ IF( med_diag%AEOLIAN%dgsave ) THEN
+ CALL iom_put( "AEOLIAN" , ffetop2d )
+ CALL wrk_dealloc( jpi, jpj, ffetop2d )
+ ENDIF
+ IF( med_diag%BENTHIC%dgsave ) THEN
+ CALL iom_put( "BENTHIC" , ffebot2d )
+ CALL wrk_dealloc( jpi, jpj, ffebot2d )
+ ENDIF
+ IF( med_diag%SCAVENGE%dgsave ) THEN
+ CALL iom_put( "SCAVENGE" , ffescav2d )
+ CALL wrk_dealloc( jpi, jpj, ffescav2d )
+ ENDIF
+ !!
+ IF( med_diag%TOTREG_N%dgsave ) THEN
+ CALL iom_put( "TOTREG_N" , fregen2d )
+ CALL wrk_dealloc( jpi, jpj, fregen2d )
+ ENDIF
+ IF( med_diag%TOTRG_SI%dgsave ) THEN
+ CALL iom_put( "TOTRG_SI" , fregensi2d )
+ CALL wrk_dealloc( jpi, jpj, fregensi2d )
+ ENDIF
+ !!
+ IF( med_diag%FASTN%dgsave ) THEN
+ CALL iom_put( "FASTN" , ftempn2d )
+ CALL wrk_dealloc( jpi, jpj, ftempn2d )
+ ENDIF
+ IF( med_diag%FASTSI%dgsave ) THEN
+ CALL iom_put( "FASTSI" , ftempsi2d )
+ CALL wrk_dealloc( jpi, jpj, ftempsi2d )
+ ENDIF
+ IF( med_diag%FASTFE%dgsave ) THEN
+ CALL iom_put( "FASTFE" , ftempfe2d )
+ CALL wrk_dealloc( jpi, jpj, ftempfe2d )
+ ENDIF
+ IF( med_diag%FASTC%dgsave ) THEN
+ CALL iom_put( "FASTC" , ftempc2d )
+ CALL wrk_dealloc( jpi, jpj, ftempc2d )
+ ENDIF
+ IF( med_diag%FASTCA%dgsave ) THEN
+ CALL iom_put( "FASTCA" , ftempca2d )
+ CALL wrk_dealloc( jpi, jpj, ftempca2d )
+ ENDIF
+ !!
+ IF( med_diag%REMINN%dgsave ) THEN
+ CALL iom_put( "REMINN" , freminn2d )
+ CALL wrk_dealloc( jpi, jpj, freminn2d )
+ ENDIF
+ IF( med_diag%REMINSI%dgsave ) THEN
+ CALL iom_put( "REMINSI" , freminsi2d )
+ CALL wrk_dealloc( jpi, jpj, freminsi2d )
+ ENDIF
+ IF( med_diag%REMINFE%dgsave ) THEN
+ CALL iom_put( "REMINFE" , freminfe2d )
+ CALL wrk_dealloc( jpi, jpj, freminfe2d )
+ ENDIF
+ IF( med_diag%REMINC%dgsave ) THEN
+ CALL iom_put( "REMINC" , freminc2d )
+ CALL wrk_dealloc( jpi, jpj, freminc2d )
+ ENDIF
+ IF( med_diag%REMINCA%dgsave ) THEN
+ CALL iom_put( "REMINCA" , freminca2d )
+ CALL wrk_dealloc( jpi, jpj, freminca2d )
+ ENDIF
+ IF( med_diag%SEAFLRN%dgsave ) THEN
+ CALL iom_put( "SEAFLRN" , fsedn )
+ ENDIF
+ IF( med_diag%SEAFLRSI%dgsave ) THEN
+ CALL iom_put( "SEAFLRSI" , fsedsi )
+ ENDIF
+ IF( med_diag%SEAFLRFE%dgsave ) THEN
+ CALL iom_put( "SEAFLRFE" , fsedfe )
+ ENDIF
+ IF( med_diag%SEAFLRC%dgsave ) THEN
+ CALL iom_put( "SEAFLRC" , fsedc )
+ ENDIF
+ IF( med_diag%SEAFLRCA%dgsave ) THEN
+ CALL iom_put( "SEAFLRCA" , fsedca )
+ ENDIF
+ !!
+# if defined key_roam
+ !!
+ IF( med_diag%RIV_N%dgsave ) THEN
+ CALL iom_put( "RIV_N" , rivn2d )
+ CALL wrk_dealloc( jpi, jpj, rivn2d )
+ ENDIF
+ IF( med_diag%RIV_SI%dgsave ) THEN
+ CALL iom_put( "RIV_SI" , rivsi2d )
+ CALL wrk_dealloc( jpi, jpj, rivsi2d )
+ ENDIF
+ IF( med_diag%RIV_C%dgsave ) THEN
+ CALL iom_put( "RIV_C" , rivc2d )
+ CALL wrk_dealloc( jpi, jpj, rivc2d )
+ ENDIF
+ IF( med_diag%RIV_ALK%dgsave ) THEN
+ CALL iom_put( "RIV_ALK" , rivalk2d )
+ CALL wrk_dealloc( jpi, jpj, rivalk2d )
+ ENDIF
+ IF( med_diag%DETC%dgsave ) THEN
+ CALL iom_put( "DETC" , fslowc2d )
+ CALL wrk_dealloc( jpi, jpj, fslowc2d )
+ ENDIF
+ !!
+ IF( med_diag%PN_LLOSS%dgsave ) THEN
+ CALL iom_put( "PN_LLOSS" , fdpn22d )
+ CALL wrk_dealloc( jpi, jpj, fdpn22d )
+ ENDIF
+ IF( med_diag%PD_LLOSS%dgsave ) THEN
+ CALL iom_put( "PD_LLOSS" , fdpd22d )
+ CALL wrk_dealloc( jpi, jpj, fdpd22d )
+ ENDIF
+ IF( med_diag%ZI_LLOSS%dgsave ) THEN
+ CALL iom_put( "ZI_LLOSS" , fdzmi22d )
+ CALL wrk_dealloc( jpi, jpj, fdzmi22d )
+ ENDIF
+ IF( med_diag%ZE_LLOSS%dgsave ) THEN
+ CALL iom_put( "ZE_LLOSS" , fdzme22d )
+ CALL wrk_dealloc( jpi, jpj, fdzme22d )
+ ENDIF
+ IF( med_diag%ZI_MES_N%dgsave ) THEN
+ CALL iom_put( "ZI_MES_N" , zimesn2d )
+ CALL wrk_dealloc( jpi, jpj, zimesn2d )
+ ENDIF
+ IF( med_diag%ZI_MES_D%dgsave ) THEN
+ CALL iom_put( "ZI_MES_D" , zimesd2d )
+ CALL wrk_dealloc( jpi, jpj, zimesd2d )
+ ENDIF
+ IF( med_diag%ZI_MES_C%dgsave ) THEN
+ CALL iom_put( "ZI_MES_C" , zimesc2d )
+ CALL wrk_dealloc( jpi, jpj, zimesc2d )
+ ENDIF
+ IF( med_diag%ZI_MESDC%dgsave ) THEN
+ CALL iom_put( "ZI_MESDC" ,zimesdc2d )
+ CALL wrk_dealloc( jpi, jpj, zimesdc2d )
+ ENDIF
+ IF( med_diag%ZI_EXCR%dgsave ) THEN
+ CALL iom_put( "ZI_EXCR" , ziexcr2d )
+ CALL wrk_dealloc( jpi, jpj, ziexcr2d )
+ ENDIF
+ IF( med_diag%ZI_RESP%dgsave ) THEN
+ CALL iom_put( "ZI_RESP" , ziresp2d )
+ CALL wrk_dealloc( jpi, jpj, ziresp2d )
+ ENDIF
+ IF( med_diag%ZI_GROW%dgsave ) THEN
+ CALL iom_put( "ZI_GROW" , zigrow2d )
+ CALL wrk_dealloc( jpi, jpj, zigrow2d )
+ ENDIF
+ IF( med_diag%ZE_MES_N%dgsave ) THEN
+ CALL iom_put( "ZE_MES_N" , zemesn2d )
+ CALL wrk_dealloc( jpi, jpj, zemesn2d )
+ ENDIF
+ IF( med_diag%ZE_MES_D%dgsave ) THEN
+ CALL iom_put( "ZE_MES_D" , zemesd2d )
+ CALL wrk_dealloc( jpi, jpj, zemesd2d )
+ ENDIF
+ IF( med_diag%ZE_MES_C%dgsave ) THEN
+ CALL iom_put( "ZE_MES_C" , zemesc2d )
+ CALL wrk_dealloc( jpi, jpj, zemesc2d )
+ ENDIF
+ IF( med_diag%ZE_MESDC%dgsave ) THEN
+ CALL iom_put( "ZE_MESDC" , zemesdc2d )
+ CALL wrk_dealloc( jpi, jpj, zemesdc2d )
+ ENDIF
+ IF( med_diag%ZE_EXCR%dgsave ) THEN
+ CALL iom_put( "ZE_EXCR" , zeexcr2d )
+ CALL wrk_dealloc( jpi, jpj, zeexcr2d )
+ ENDIF
+ IF( med_diag%ZE_RESP%dgsave ) THEN
+ CALL iom_put( "ZE_RESP" , zeresp2d )
+ CALL wrk_dealloc( jpi, jpj, zeresp2d )
+ ENDIF
+ IF( med_diag%ZE_GROW%dgsave ) THEN
+ CALL iom_put( "ZE_GROW" , zegrow2d )
+ CALL wrk_dealloc( jpi, jpj, zegrow2d )
+ ENDIF
+ IF( med_diag%MDETC%dgsave ) THEN
+ CALL iom_put( "MDETC" , mdetc2d )
+ CALL wrk_dealloc( jpi, jpj, mdetc2d )
+ ENDIF
+ IF( med_diag%GMIDC%dgsave ) THEN
+ CALL iom_put( "GMIDC" , gmidc2d )
+ CALL wrk_dealloc( jpi, jpj, gmidc2d )
+ ENDIF
+ IF( med_diag%GMEDC%dgsave ) THEN
+ CALL iom_put( "GMEDC" , gmedc2d )
+ CALL wrk_dealloc( jpi, jpj, gmedc2d )
+ ENDIF
+ IF( med_diag%IBEN_N%dgsave ) THEN
+ CALL iom_put( "IBEN_N" , iben_n2d )
+ CALL wrk_dealloc( jpi, jpj, iben_n2d )
+ ENDIF
+ IF( med_diag%IBEN_FE%dgsave ) THEN
+ CALL iom_put( "IBEN_FE" , iben_fe2d )
+ CALL wrk_dealloc( jpi, jpj, iben_fe2d )
+ ENDIF
+ IF( med_diag%IBEN_C%dgsave ) THEN
+ CALL iom_put( "IBEN_C" , iben_c2d )
+ CALL wrk_dealloc( jpi, jpj, iben_c2d )
+ ENDIF
+ IF( med_diag%IBEN_SI%dgsave ) THEN
+ CALL iom_put( "IBEN_SI" , iben_si2d )
+ CALL wrk_dealloc( jpi, jpj, iben_si2d )
+ ENDIF
+ IF( med_diag%IBEN_CA%dgsave ) THEN
+ CALL iom_put( "IBEN_CA" , iben_ca2d )
+ CALL wrk_dealloc( jpi, jpj, iben_ca2d )
+ ENDIF
+ IF( med_diag%OBEN_N%dgsave ) THEN
+ CALL iom_put( "OBEN_N" , oben_n2d )
+ CALL wrk_dealloc( jpi, jpj, oben_n2d )
+ ENDIF
+ IF( med_diag%OBEN_FE%dgsave ) THEN
+ CALL iom_put( "OBEN_FE" , oben_fe2d )
+ CALL wrk_dealloc( jpi, jpj, oben_fe2d )
+ ENDIF
+ IF( med_diag%OBEN_C%dgsave ) THEN
+ CALL iom_put( "OBEN_C" , oben_c2d )
+ CALL wrk_dealloc( jpi, jpj, oben_c2d )
+ ENDIF
+ IF( med_diag%OBEN_SI%dgsave ) THEN
+ CALL iom_put( "OBEN_SI" , oben_si2d )
+ CALL wrk_dealloc( jpi, jpj, oben_si2d )
+ ENDIF
+ IF( med_diag%OBEN_CA%dgsave ) THEN
+ CALL iom_put( "OBEN_CA" , oben_ca2d )
+ CALL wrk_dealloc( jpi, jpj, oben_ca2d )
+ ENDIF
+ IF( med_diag%SFR_OCAL%dgsave ) THEN
+ CALL iom_put( "SFR_OCAL" , sfr_ocal2d )
+ CALL wrk_dealloc( jpi, jpj, sfr_ocal2d )
+ ENDIF
+ IF( med_diag%SFR_OARG%dgsave ) THEN
+ CALL iom_put( "SFR_OARG" , sfr_oarg2d )
+ CALL wrk_dealloc( jpi, jpj, sfr_oarg2d )
+ ENDIF
+ IF( med_diag%LYSO_CA%dgsave ) THEN
+ CALL iom_put( "LYSO_CA" , lyso_ca2d )
+ CALL wrk_dealloc( jpi, jpj, lyso_ca2d )
+ ENDIF
+# endif
+ !!
+ !! ** 3D diagnostics
+ IF( med_diag%TPP3%dgsave ) THEN
+ CALL iom_put( "TPP3" , tpp3d )
+ CALL wrk_dealloc( jpi, jpj, jpk, tpp3d )
+ ENDIF
+ IF( med_diag%DETFLUX3%dgsave ) THEN
+ CALL iom_put( "DETFLUX3" , detflux3d )
+ CALL wrk_dealloc( jpi, jpj, jpk, detflux3d )
+ ENDIF
+ IF( med_diag%REMIN3N%dgsave ) THEN
+ CALL iom_put( "REMIN3N" , remin3dn )
+ CALL wrk_dealloc( jpi, jpj, jpk, remin3dn )
+ ENDIF
+# if defined key_roam
+ IF( med_diag%PH3%dgsave ) THEN
+ CALL iom_put( "PH3" , f3_pH )
+ ENDIF
+ IF( med_diag%OM_CAL3%dgsave ) THEN
+ CALL iom_put( "OM_CAL3" , f3_omcal )
+ ENDIF
+ !!
+ !! AXY (09/11/16): 2D CMIP6 diagnostics
+ IF( med_diag%INTDISSIC%dgsave ) THEN
+ CALL iom_put( "INTDISSIC" , intdissic )
+ CALL wrk_dealloc( jpi, jpj, intdissic )
+ ENDIF
+ IF( med_diag%INTDISSIN%dgsave ) THEN
+ CALL iom_put( "INTDISSIN" , intdissin )
+ CALL wrk_dealloc( jpi, jpj, intdissin )
+ ENDIF
+ IF( med_diag%INTDISSISI%dgsave ) THEN
+ CALL iom_put( "INTDISSISI" , intdissisi )
+ CALL wrk_dealloc( jpi, jpj, intdissisi )
+ ENDIF
+ IF( med_diag%INTTALK%dgsave ) THEN
+ CALL iom_put( "INTTALK" , inttalk )
+ CALL wrk_dealloc( jpi, jpj, inttalk )
+ ENDIF
+ IF( med_diag%O2min%dgsave ) THEN
+ CALL iom_put( "O2min" , o2min )
+ CALL wrk_dealloc( jpi, jpj, o2min )
+ ENDIF
+ IF( med_diag%ZO2min%dgsave ) THEN
+ CALL iom_put( "ZO2min" , zo2min )
+ CALL wrk_dealloc( jpi, jpj, zo2min )
+ ENDIF
+ IF( med_diag%FBDDTALK%dgsave ) THEN
+ CALL iom_put( "FBDDTALK" , fbddtalk )
+ CALL wrk_dealloc( jpi, jpj, fbddtalk )
+ ENDIF
+ IF( med_diag%FBDDTDIC%dgsave ) THEN
+ CALL iom_put( "FBDDTDIC" , fbddtdic )
+ CALL wrk_dealloc( jpi, jpj, fbddtdic )
+ ENDIF
+ IF( med_diag%FBDDTDIFE%dgsave ) THEN
+ CALL iom_put( "FBDDTDIFE" , fbddtdife )
+ CALL wrk_dealloc( jpi, jpj, fbddtdife )
+ ENDIF
+ IF( med_diag%FBDDTDIN%dgsave ) THEN
+ CALL iom_put( "FBDDTDIN" , fbddtdin )
+ CALL wrk_dealloc( jpi, jpj, fbddtdin )
+ ENDIF
+ IF( med_diag%FBDDTDISI%dgsave ) THEN
+ CALL iom_put( "FBDDTDISI" , fbddtdisi )
+ CALL wrk_dealloc( jpi, jpj, fbddtdisi )
+ ENDIF
+ !!
+ !! AXY (09/11/16): 3D CMIP6 diagnostics
+ IF( med_diag%TPPD3%dgsave ) THEN
+ CALL iom_put( "TPPD3" , tppd3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, tppd3 )
+ ENDIF
+ IF( med_diag%BDDTALK3%dgsave ) THEN
+ CALL iom_put( "BDDTALK3" , bddtalk3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, bddtalk3 )
+ ENDIF
+ IF( med_diag%BDDTDIC3%dgsave ) THEN
+ CALL iom_put( "BDDTDIC3" , bddtdic3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, bddtdic3 )
+ ENDIF
+ IF( med_diag%BDDTDIFE3%dgsave ) THEN
+ CALL iom_put( "BDDTDIFE3" , bddtdife3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, bddtdife3 )
+ ENDIF
+ IF( med_diag%BDDTDIN3%dgsave ) THEN
+ CALL iom_put( "BDDTDIN3" , bddtdin3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, bddtdin3 )
+ ENDIF
+ IF( med_diag%BDDTDISI3%dgsave ) THEN
+ CALL iom_put( "BDDTDISI3" , bddtdisi3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, bddtdisi3 )
+ ENDIF
+ IF( med_diag%FD_NIT3%dgsave ) THEN
+ CALL iom_put( "FD_NIT3" , fd_nit3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, fd_nit3 )
+ ENDIF
+ IF( med_diag%FD_SIL3%dgsave ) THEN
+ CALL iom_put( "FD_SIL3" , fd_sil3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, fd_sil3 )
+ ENDIF
+ IF( med_diag%FD_CAL3%dgsave ) THEN
+ CALL iom_put( "FD_CAL3" , fd_cal3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, fd_cal3 )
+ ENDIF
+ IF( med_diag%FD_CAR3%dgsave ) THEN
+ CALL iom_put( "FD_CAR3" , fd_car3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, fd_car3 )
+ ENDIF
+ IF( med_diag%CO33%dgsave ) THEN
+ CALL iom_put( "CO33" , f3_co3 )
+ ENDIF
+ IF( med_diag%CO3SATARAG3%dgsave ) THEN
+ CALL iom_put( "CO3SATARAG3" , f3_omarg )
+ ENDIF
+ IF( med_diag%CO3SATCALC3%dgsave ) THEN
+ CALL iom_put( "CO3SATCALC3" , f3_omcal )
+ ENDIF
+ IF( med_diag%EXPC3%dgsave ) THEN
+ CALL iom_put( "EXPC3" , expc3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, expc3 )
+ ENDIF
+ IF( med_diag%EXPN3%dgsave ) THEN
+ CALL iom_put( "EXPN3" , expn3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, expn3 )
+ ENDIF
+ IF( med_diag%DCALC3%dgsave ) THEN
+ CALL iom_put( "DCALC3" , dcalc3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, dcalc3 )
+ ENDIF
+ IF( med_diag%FEDISS3%dgsave ) THEN
+ CALL iom_put( "FEDISS3" , fediss3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, fediss3 )
+ ENDIF
+ IF( med_diag%FESCAV3%dgsave ) THEN
+ CALL iom_put( "FESCAV3" , fescav3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, fescav3 )
+ ENDIF
+ IF( med_diag%MIGRAZP3%dgsave ) THEN
+ CALL iom_put( "MIGRAZP3" , migrazp3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, migrazp3 )
+ ENDIF
+ IF( med_diag%MIGRAZD3%dgsave ) THEN
+ CALL iom_put( "MIGRAZD3" , migrazd3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, migrazd3 )
+ ENDIF
+ IF( med_diag%MEGRAZP3%dgsave ) THEN
+ CALL iom_put( "MEGRAZP3" , megrazp3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, megrazp3 )
+ ENDIF
+ IF( med_diag%MEGRAZD3%dgsave ) THEN
+ CALL iom_put( "MEGRAZD3" , megrazd3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, megrazd3 )
+ ENDIF
+ IF( med_diag%MEGRAZZ3%dgsave ) THEN
+ CALL iom_put( "MEGRAZZ3" , megrazz3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, megrazz3 )
+ ENDIF
+ IF( med_diag%O2SAT3%dgsave ) THEN
+ CALL iom_put( "O2SAT3" , o2sat3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, o2sat3 )
+ ENDIF
+ IF( med_diag%PBSI3%dgsave ) THEN
+ CALL iom_put( "PBSI3" , pbsi3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, pbsi3 )
+ ENDIF
+ IF( med_diag%PCAL3%dgsave ) THEN
+ CALL iom_put( "PCAL3" , pcal3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, pcal3 )
+ ENDIF
+ IF( med_diag%REMOC3%dgsave ) THEN
+ CALL iom_put( "REMOC3" , remoc3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, remoc3 )
+ ENDIF
+ IF( med_diag%PNLIMJ3%dgsave ) THEN
+ CALL iom_put( "PNLIMJ3" , pnlimj3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, pnlimj3 )
+ ENDIF
+ IF( med_diag%PNLIMN3%dgsave ) THEN
+ CALL iom_put( "PNLIMN3" , pnlimn3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, pnlimn3 )
+ ENDIF
+ IF( med_diag%PNLIMFE3%dgsave ) THEN
+ CALL iom_put( "PNLIMFE3" , pnlimfe3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, pnlimfe3 )
+ ENDIF
+ IF( med_diag%PDLIMJ3%dgsave ) THEN
+ CALL iom_put( "PDLIMJ3" , pdlimj3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, pdlimj3 )
+ ENDIF
+ IF( med_diag%PDLIMN3%dgsave ) THEN
+ CALL iom_put( "PDLIMN3" , pdlimn3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, pdlimn3 )
+ ENDIF
+ IF( med_diag%PDLIMFE3%dgsave ) THEN
+ CALL iom_put( "PDLIMFE3" , pdlimfe3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, pdlimfe3 )
+ ENDIF
+ IF( med_diag%PDLIMSI3%dgsave ) THEN
+ CALL iom_put( "PDLIMSI3" , pdlimsi3 )
+ CALL wrk_dealloc( jpi, jpj, jpk, pdlimsi3 )
+ ENDIF
+
+# endif
+
+ CALL wrk_dealloc( jpi, jpj, zw2d )
+
+ ENDIF ! end of ln_diatrc option
+
+# if defined key_trc_diabio
+ !! Lateral boundary conditions on trcbio
+ DO jn=1,jp_medusa_trd
+ CALL lbc_lnk(trbio(:,:,1,jn),'T',1. )
+ ENDDO
+# endif
+
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' MEDUSA exiting trc_bio_medusa at kt =', kt
+ CALL flush(numout)
+# endif
+
+ END SUBROUTINE trc_bio_medusa
+
+#else
+ !!======================================================================
+ !! Dummy module : No MEDUSA bio-model
+ !!======================================================================
+CONTAINS
+ SUBROUTINE trc_bio_medusa( kt ) ! Empty routine
+ INTEGER, INTENT( in ) :: kt
+ WRITE(*,*) 'trc_bio_medusa: You should not have seen this print! error?', kt
+ END SUBROUTINE trc_bio_medusa
+#endif
+
+ !!======================================================================
+END MODULE trcbio_medusa
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcco2_medusa.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcco2_medusa.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcco2_medusa.F90 (revision 8155)
@@ -0,0 +1,1136 @@
+MODULE trcco2_medusa
+ !!======================================================================
+ !! *** MODULE trcco2_medusa ***
+ !! TOP : MEDUSA
+ !!======================================================================
+ !! History :
+ !! - ! 2010-12 (A. Yool) added for ROAM project
+ !!----------------------------------------------------------------------
+#if defined key_medusa && defined key_roam
+ !!----------------------------------------------------------------------
+ !! MEDUSA carbonate chemistry
+ !!----------------------------------------------------------------------
+ !! trc_co2_medusa :
+ !!----------------------------------------------------------------------
+ USE oce_trc
+ USE trc
+ USE sms_medusa
+ USE lbclnk
+ USE prtctl_trc ! Print control for debugging
+ USE in_out_manager ! I/O manager
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_co2_medusa ! called in trc_bio_medusa
+
+ !!* Substitution
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+! The following is a map of the subroutines contained within this module
+! - trc_co2_medusa
+! - CALLS CO2_dynamics
+! - CALLS CO2DYN
+! - CALLS POLYCO
+! - CALLS CO2SET
+! - CALLS CO2CLC
+! - CALLS CaCO3_Saturation
+! - CALLS Air_sea_exchange
+
+CONTAINS
+
+!=======================================================================
+!
+ SUBROUTINE trc_co2_medusa( Temp, Sal, DIC, ALK, Depth, xkw, pCO2a, &
+ pH, pCO2w, h2co3, hco3, co3, om_cal, om_arg, co2flux, TDIC, TALK, &
+ dcf, henry, iters )
+!
+!=======================================================================
+!
+! This file contains a set of FORTRAN subroutines that calculate the carbonate system
+! at any given point in marine space time, given values for
+! temperature, salinity, DIC, depth (pressure).
+! This is essentially an implimentation of the Haltafall speciation code
+! (Ingri et al 1967, Talanta 14, 1261 - if it ain't broke don't fix it)
+! Another routine calulates the air sea exchange of CO2 given wind speed and atmospheric pCO2.
+! Code developed by Jerry blackford and others at PML, based on pre-existing code.
+! We accept no liability for errors or inaccuracies.
+! See Zeebe & Wolf-Gladrow, 2001. CO2 in seawater: equilibrium, kinetics and isotopes.
+! Elsevier Oceanography Series 65, 346. for a reasonable overview.
+! Many other packages exist, replicating the same functionality in different languages.
+! See http://cdiac.ornl.gov/oceans/co2rprt.html (CO2sys)
+! or http://neon.otago.ac.nz/research/mfc/people/keith_hunter/software/swco2/
+! reference for prior usage of this code: Blackford & Gilbert, 2007. J Mar Sys 64, 229-241.
+!
+! Modifications
+! 17/02/2010. Added conversion factor from per m3 to per kg (line 108-133)
+! 17/02/2010. Update calculation of K1, K2, Kb to make consistant with the OCMIP protocols.
+! 29/07/2011. Merged into MEDUSA with a raft of changes to this subroutine; less elsewhere
+! 23/06/2015. Modified to take gas transfer velocity as an input (rather than wind speed);
+! alter CO2 flux to /s rather than /d for consistency with other schemes
+!
+! Changes for MEDUSA include:
+! - making the program a module
+! - passing in input variables (obvious given the last point)
+! - making alkalinity a state variable (rather than a function of salinity)
+!
+ IMPLICIT NONE
+
+ REAL(wp), INTENT( in ) :: Temp ! degrees C
+ REAL(wp), INTENT( in ) :: Sal ! PSU
+ REAL(wp), INTENT( in ) :: DIC ! mmol / m3
+ REAL(wp), INTENT( in ) :: ALK ! meq / m3
+ REAL(wp), INTENT( in ) :: Depth ! m
+! REAL(wp), INTENT( in ) :: Wnd ! m / s
+ REAL(wp), INTENT( in ) :: xkw ! m / s
+ REAL(wp), INTENT( in ) :: pCO2a ! uatm
+!----------------------------------------------------------------------
+ REAL(wp), INTENT( inout ) :: pH ! "normal" pH units
+ REAL(wp), INTENT( inout ) :: pCO2w ! uatm
+ REAL(wp), INTENT( inout ) :: h2co3 ! mmol / m3
+ REAL(wp), INTENT( inout ) :: hco3 ! mmol / m3
+ REAL(wp), INTENT( inout ) :: co3 ! mmol / m3
+ REAL(wp), INTENT( inout ) :: om_cal ! normalised
+ REAL(wp), INTENT( inout ) :: om_arg ! normalised
+ REAL(wp), INTENT( inout ) :: co2flux ! mmol / m2 / s
+ REAL(wp), INTENT( inout ) :: TDIC ! umol / kg
+ REAL(wp), INTENT( inout ) :: TALK ! ueq / kg
+ REAL(wp), INTENT( inout ) :: dcf ! m3 / kg
+ REAL(wp), INTENT( inout ) :: henry ! ?
+ INTEGER, INTENT( inout ) :: iters ! # iterations to convergence
+!----------------------------------------------------------------------
+! REAL(wp) :: cco2,bicarb,carb,henry
+ REAL(wp) :: cco2,bicarb,carb
+! ======================================================================
+
+! write inputs to screen
+! WRITE(*,*) " "
+! WRITE(*,'(A28)') " .........Inputs........."
+! WRITE(*,'(A24,F10.3)') " Temperature (C) = ", Temp
+! WRITE(*,'(A24,F10.3)') " Salinity (psu) = ", Sal
+! WRITE(*,'(A24,F10.3)') " Depth (m) = ", Depth
+! WRITE(*,'(A24,F10.3)') " DIC (mmol/m3) = ", DIC
+! WRITE(*,'(A24,F10.3)') " ALK (ueq/m3) = ", ALK
+! WRITE(*,'(A24,F10.3)') " Wind speed (m/s) = ", Wnd
+! WRITE(*,'(A24,F10.3)') " pCO2 atmos (uatm) = ", pCO2a
+
+! AXY (07/05/13) ==================================================
+! set total number of iterations to zero
+ iters = 0
+! AXY (07/05/13) ==================================================
+
+ call CO2_dynamics( Temp, Sal, Depth, DIC, ALK, pCO2a, & ! inputs
+ pco2w, ph, h2co3, hco3, co3, henry, om_cal, om_arg, TDIC, TALK, & ! outputs
+ dcf, iters) ! outputs
+
+ ! AXY (18/08/11): only do air-sea exchange calculation if depth = 0
+ ! (i.e. surface calculations being performed)
+ if (Depth .eq. 0.0) then
+ call Air_sea_exchange( Temp, xkw, pCO2w, pCO2a, henry, dcf, & ! inputs
+ co2flux ) ! output
+ else
+ co2flux = 0.0
+ endif
+
+! AXY (09/01/14) ==================================================
+! check for non-convergence and NaNs
+ !!
+ if (iters .eq. 25) then
+ IF(lwp) WRITE(numout,*) ' trc_co2_medusa: ITERS WARNING, ', &
+ iters, ' AT depth =', Depth
+ IF(lwp) WRITE(numout,*) ' trc_co2_medusa: ztmp =', Temp
+ IF(lwp) WRITE(numout,*) ' trc_co2_medusa: zsal =', Sal
+ IF(lwp) WRITE(numout,*) ' trc_co2_medusa: zdic =', DIC
+ IF(lwp) WRITE(numout,*) ' trc_co2_medusa: zalk =', ALK
+ IF(lwp) WRITE(numout,*) ' trc_co2_medusa: f_kw660 =', xkw
+ IF(lwp) WRITE(numout,*) ' trc_co2_medusa: f_ph =', ph
+ IF(lwp) WRITE(numout,*) ' trc_co2_medusa: f_pco2w =', pCO2w
+ IF(lwp) WRITE(numout,*) ' trc_co2_medusa: f_h2co3 =', h2co3
+ IF(lwp) WRITE(numout,*) ' trc_co2_medusa: f_hco3 =', hco3
+ IF(lwp) WRITE(numout,*) ' trc_co2_medusa: f_co3 =', co3
+ endif
+ !!
+ !! AXY (29/10/13): NaN checks
+ if (co2flux /= co2flux) then
+ !! if (lwp) write (numout,'(a,1pe10.2,4i6)') 'CO2FLUX-NAN', &
+ !! & tmask(ji,jj,jk), kt, ji, jj, jk
+ if (lwp) write (numout,'(a,a,f10.3,a,f10.3)') 'CO2FLUX-NAN', &
+ & ' TMP', Temp, ' SAL', Sal
+ if (lwp) write (numout,'(a,a,f10.3,a,f10.3)') 'CO2FLUX-NAN', &
+ & ' DIC', DIC, ' ALK', ALK
+ if (lwp) write (numout,'(a,a,f10.3,a,f10.3)') 'CO2FLUX-NAN', &
+ & ' XKW', xkw, ' PH ', ph
+ if (lwp) write (numout,'(a,a,i6)') 'CO2FLUX-NAN', &
+ & ' ITERS', iters
+ endif
+ !!
+ !! AXY (09/01/14): NaN fudges
+ if (co2flux /= co2flux) then
+ ph = 8.1
+ pCO2w = pCO2a
+ h2co3 = 0.005 * DIC
+ hco3 = 0.865 * DIC
+ co3 = 0.130 * DIC
+ om_cal = 4.
+ om_arg = 2.
+ co2flux = 0.
+ TDIC = DIC
+ TALK = ALK
+ dcf = 1.
+ henry = 1.
+ endif
+! AXY (09/01/14) ==================================================
+
+! write outputs to screen
+! WRITE(*,*) " "
+! WRITE(*,'(A32,F10.3)') " ..........Outputs..........."
+! WRITE(*,'(A27,F10.3)') " pH (pH) = ", pH
+! WRITE(*,'(A27,F10.3)') " DIC (umol/kg) = ", TDIC
+! WRITE(*,'(A27,F10.3)') " TALK (ueq/kg) = ", TALK
+! WRITE(*,'(A27,F10.3)') " pco2w (uatm) = ", pco2w
+! WRITE(*,'(A27,F10.3)') " carbonic acid (mmol/m3) = ", h2co3
+! WRITE(*,'(A27,F10.3)') " bicarbonate (mmol/m3) = ", bicarb
+! WRITE(*,'(A27,F10.3)') " carbonate (mmol/m3) = ", carb
+! WRITE(*,'(A27,F10.3)') " Omega calcite (~) = ", om_cal
+! WRITE(*,'(A27,F10.3)') " Omega aragonite (~) = ", om_arg
+! WRITE(*,'(A27,F10.3)') " air sea flux(mmol/m2/s) = ", flux
+! WRITE(*,*) " "
+
+ END SUBROUTINE trc_co2_medusa
+!-----------------------------------------------------------------------
+
+!=======================================================================
+!=======================================================================
+!=======================================================================
+
+!=======================================================================
+!
+ subroutine CO2_dynamics( T, S, Z, DIC, TALK, pco2a, &
+ pco2w, ph, h2co3, bicarb, carb, henry, om_cal, om_arg, TCO2, TA, &
+ dcf, iters )
+!
+!=======================================================================
+!
+ IMPLICIT NONE
+
+ REAL(wp), INTENT( in ) :: T ! temperature (C)
+ REAL(wp), INTENT( in ) :: S ! salinity (psu)
+ REAL(wp), INTENT( in ) :: Z ! depth (metres)
+ REAL(wp), INTENT( in ) :: DIC ! total dissolved inorganic carbon (mmol.m-3)
+ REAL(wp), INTENT( in ) :: TALK ! total alkalinity (meq.m-3)
+ REAL(wp), INTENT( in ) :: pco2a ! atmospheric pCO2
+!----------------------------------------------------------------------
+ REAL(wp), INTENT( inout ) :: pco2w ! seawater pCO2
+ REAL(wp), INTENT( inout ) :: ph ! seawater pH
+ REAL(wp), INTENT( inout ) :: h2co3 ! seawater carbonic acid (H2CO3)
+ REAL(wp), INTENT( inout ) :: bicarb ! seawater bicarbonate ion (HCO3)
+ REAL(wp), INTENT( inout ) :: carb ! seawater carbonate ion (CO3)
+ REAL(wp), INTENT( inout ) :: henry ! Henry constant
+ REAL(wp), INTENT( inout ) :: om_cal ! Omega calcite
+ REAL(wp), INTENT( inout ) :: om_arg ! Omega aragonite
+ REAL(wp), INTENT( inout ) :: TCO2 ! total dissolved inorganic carbon (mol.kg-1)
+ REAL(wp), INTENT( inout ) :: TA ! total alkalinity (eq.kg-1)
+ REAL(wp), INTENT( inout ) :: dcf ! density conversion factor
+ INTEGER, INTENT( inout ) :: iters ! # iterations to convergence
+!----------------------------------------------------------------------
+ REAL(wp) :: a, b, c
+ REAL(wp) :: ca, bc, cb
+ REAL(wp) :: pco2water, fairco2
+
+! ======================================================================
+
+! Adjust to correct units.
+! Haltafall uses mol/kg rather than umol/kg necessitating a scaling factor of /1.0D6
+! DIC (mmol/m3) needs to be converted to umol/kg via the calculation of water density at prevailing T&S
+! sea-water density (Millero & Poisson, Deep-Sea Research, 1981, also known as UNESCO, 1981)
+! with T: Temperature in degree Celsius; S: Salinity in practical units, density in kg/m3
+! valid for 01 CODED only for ICONST=3 and ICONST=6)
+! T - TEMPERATURE IN DEG.C
+! S - SALINITY IN PPT
+! CONCS(1) - TOTAL C (MOL/KG)
+! CONCS(2) - TOTAL ALKALINITY (MOL/KG)
+! CONCS(3) - PCO2 (ATM)
+! CONCS(4) - PH
+! CONCS(5) - {H2CO3} (MOL/KG)
+! CONCS(6) - {HCO3} (MOL/KG)
+! CONCS(7) - {CO3} (MOL/KG)
+! CONCS(8) - CARBONATE ALKALINITY ) FOR ICONST = 4,5,6
+! CONCS(9) - BORATE ALKALINITY ) ONLY
+! NCONC - SIZE OF CONCS ARRAY (7 FOR ICONST=1,2,3; 9 FOR ICONST
+! AKVAL(1) - KP (HENRY'S LAW CONSTANT) (MOL/KG/ATM)
+! AKVAL(2) - K1C (H2CO3 DISSOCIATION) (MOL/KG)
+! AKVAL(3) - K2C (HCO3 DISSOCIATION) (MOL/KG)
+! AKVAL(4) - KB (B(OH)3 DISSOCIATION) (MOL/KG) FOR ICONST=4,5,6
+! NKVAL - SIZE OF AKVAL ARRAY (3 FOR ICONST=1,2,3; 4 FOR ICONST=
+! ICALC - SELECTION OF THE TWO INPUT PARAMETERS:
+! ICALC = 1 TOTAL C AND ALKALINITY
+! ICALC = 2 TOTAL C AND PCO2
+! ICALC = 3 TOTAL C AND PH
+! ICALC = 4 ALKALINITY AND PCO2
+! ICALC = 5 ALKALINITY AND PH
+! ICALC = 6 PCO2 AND PH
+! ICALC = 7 CALCULATE CONSTANTS AKVAL ONLY
+! ICONST - SELECTION OF PH SCALE AND COMPONENTS:
+! ICONST = 1 NBS PH SCALE
+! ICONST = 2 HANSSON'S SCALE (SWS WITHOUT FLUORIDE)
+! ICONST = 3 SWS PH SCALE
+! ICONST = 4 AS 1 BUT INCLUDING BORATE IN THE CALCULATION
+! ICONST = 5 AS 2 BUT INCLUDING BORATE IN THE CALCULATION
+! ICONST = 6 AS 3 BUT INCLUDING BORATE IN THE CALCULATION
+
+! NOTE: FOR ICONST=1,2,3 CONCS(2) REPRESENTS CARBONATE ALKALINITY SINC
+! BORATE IS NOT INCLUDED IN THE CALCULATION. FOR ICONST=4,5,6 CO
+! REPRESENTS TOTAL ALKALINITY (CARBONATE + BORATE), THE COMPONEN
+! WHICH ARE GIVEN IN CONCS(8) AND CONCS(9)
+
+ REAL(wp) :: PMIN, PMAX, SMIN, SMAX, TMIN, TMAX, &
+ & PD, TD, SD, P, T, S, BTOT
+ INTEGER :: MINJC, MAXJC, MINJK, MAXJK, MINCAL, MAXCAL, MINCON, &
+ & MAXCON, NCONC, NKVAL, ICALC, ICONST, IC, iters
+ LOGICAL :: BORON
+
+ PARAMETER(MINJC=7,MAXJC=9,MINJK=3,MAXJK=4)
+ PARAMETER(MINCAL=1,MAXCAL=7,MINCON=1,MAXCON=6)
+ !! AXY (11/08/11): TMIN changed to -2 to stop error messages in polar regions
+ !! AXY (09/01/14): TMIN changed to -3 to stop error messages in polar regions
+ !! AXY (03/03/14): SMAX changed to 42 to stop error messages in salty regions (the Great Answer ...)
+ !! AXY (05/03/14): SMAX changed to 45 to stop error messages in salty regions
+ PARAMETER(PMIN=0.99999D0,PMAX=1.00001D0,SMIN=0.0D0, &
+ & SMAX=45.0D0,TMIN=-3.0D0,TMAX=40.0D0)
+ REAL(wp), DIMENSION(NKVAL) :: AKVAL
+ REAL(wp), DIMENSION(NCONC) :: CONCS
+
+ P = PD
+ S = SD
+ T = TD
+
+ !! AXY (09/08/11): STOP statements commented out and WARNING messages added
+ IF(lwp) THEN
+ IF(T.LT.TMIN.OR.T.GT.TMAX) WRITE(numout,*) ' trc_co2_medusa: T WARNING, ', T, TMIN, TMAX, S, P
+ IF(S.LT.SMIN.OR.S.GT.SMAX) WRITE(numout,*) ' trc_co2_medusa: S WARNING, ', S, SMIN, SMAX, T, P
+ IF(P.LT.PMIN.OR.P.GT.PMAX) WRITE(numout,*) ' trc_co2_medusa: P WARNING, ', P, PMIN, PMAX, T, S
+ ENDIF
+ ! IF(T.LT.TMIN.OR.T.GT.TMAX)WRITE (*,*) P, S, T, TMIN, TMAX
+ ! IF(P.LT.PMIN.OR.P.GT.PMAX) STOP'POLYCO - PRESSURE OUT OF RANGE'
+ ! IF(S.LT.SMIN.OR.S.GT.SMAX) STOP'POLYCO - SALINITY OUT OF RANGE'
+ ! IF(T.LT.TMIN.OR.T.GT.TMAX) STOP'POLYCO - TEMP. OUT OF RANGE'
+
+ !! AXY (17/04/13): iMARNET climate change simulation appears to be compromised
+ !! by excessive Caspian Sea salinity (> 45 PSU); this may be
+ !! a runoff glitch that doesn't manifest on local instance of
+ !! NEMO; fudging this here by replacing excessively high
+ !! salinity values with maximum salinity value for the purpose
+ !! of carbonate chemistry calculations; if this works, a more
+ !! sensible solution might be to kill Caspian, etc.
+ IF(lwp) THEN
+ IF(S.LT.SMIN) THEN
+ WRITE(numout,*) ' trc_co2_medusa: S RESET, ', S, '->', SMIN
+ S = SMIN
+ ENDIF
+ IF(S.GT.SMAX) THEN
+ WRITE(numout,*) ' trc_co2_medusa: S RESET, ', S, '->', SMAX
+ S = SMAX
+ ENDIF
+ ENDIF
+
+ !! AXY (28/02/13): as above, but for T; this has been done for 1/4-degree
+ !! simulations to provide a temporary fix to a strange
+ !! glitch in ocean temperature; basically, T has been found
+ !! to spike upwards arbitrarily (e.g. 24C -> 53C); this
+ !! causes the carbonate chemistry calculations to fail;
+ !! this fix aims to stop the problem so that we can estimate
+ !! how frequent a problem this is; it's suggestive of a
+ !! memory leak
+ IF(lwp) THEN
+ IF(T.LT.TMIN) THEN
+ WRITE(numout,*) ' trc_co2_medusa: T RESET, ', T, '->', TMIN
+ T = TMIN
+ ENDIF
+ IF(T.GT.TMAX) THEN
+ WRITE(numout,*) ' trc_co2_medusa: T RESET, ', T, '->', TMAX
+ T = TMAX
+ ENDIF
+ ENDIF
+
+ IF(ICALC.LT.MINCAL.OR.ICALC.GT.MAXCAL) STOP 'POLYCO - ICALC OUT OR RANGE'
+ IF(ICONST.LT.MINCON.OR.ICONST.GT.MAXCON) STOP 'POLYCO - ICONST OUT OF RANGE'
+ BORON=(ICONST.GT.3)
+ IF(BORON) THEN
+ IC=ICONST-3
+ BTOT=0.0004128D0*S/35.0D0
+ IF(NCONC.NE.MAXJC) STOP 'POLYCO - WRONG NCONC VALUE'
+ IF(NKVAL.NE.MAXJK) STOP 'POLYCO - WRONG NKVAL VALUE'
+ ELSE
+ IC=ICONST
+ IF(NCONC.NE.MINJC) STOP 'POLYCO - WRONG NCONC VALUE'
+ IF(NKVAL.NE.MINJK) STOP 'POLYCO - WRONG NKVAL VALUE'
+ ENDIF
+
+ CALL CO2SET(P,T,S,AKVAL,NKVAL,IC)
+
+ IF(ICALC.LT.MAXCAL) &
+ & CALL CO2CLC(CONCS,NCONC,AKVAL,NKVAL,ICALC,BORON,BTOT,iters)
+
+ RETURN
+
+ END SUBROUTINE
+!-----------------------------------------------------------------------
+
+!=======================================================================
+!=======================================================================
+!=======================================================================
+
+!=======================================================================
+!
+ SUBROUTINE CO2SET(P,T,S,AKVAL,NKVAL,IC)
+!
+!=======================================================================
+!
+! Routine to calculate CO2 system constants under the conditions set by
+! P,S,T (NOTE: PRESSURE <> 1ATM IS NOT YET CODED)
+
+! I. Calculate constants at P=1 and S=0 using
+
+! ln K0 = A + B/TK + C ln TK
+! (where TK is in Kelvin)
+
+! II. Calculate constants at P=1 and salinity S using
+
+! ln K = ln K0 + (a0 + a1/TK + a2 ln TK) S**1/2
+! + (b0 + b1TK + b2TK**2) S
+
+! The sources of the coefficients are as follows:
+
+! IC= 1 2 3
+! (NBS pH scale) (SWS pH scale (SWS pH scale
+! with no F)
+
+! KP WEISS (1974) WEISS(1974) WEISS(1974
+
+! K1C ) MEHRBACH ACC. TO HANSSON ACC. TO HANSSON AND MEH
+! K2C ) MILLERO (1979) MILLERO (1979) ACC. TO DICKS
+! KB ) AND MILLERO (1
+! (K1C AND K2C
+! HANSSON ACC
+! MILLERO (1
+! (KB ONLY
+
+! ***
+! IMPLICIT real*8 (A-H,O-Z)
+
+! Modified by jcb 17/02/10 to use OCMIP calculations of K1, K2, Kb.
+! Differences are subtle rather than significant
+
+ INTEGER :: MAXK, MAXCON, NKVAL, ICON, IC, IK
+! ***
+ PARAMETER(MAXK=4,MAXCON=3)
+ REAL(wp), DIMENSION(MAXK) :: A, B, C
+ REAL(wp), DIMENSION(MAXK,MAXCON) :: A0, A1, A2
+ REAL(wp), DIMENSION(MAXK,MAXCON) :: B0, B1, B2
+ REAL(wp), DIMENSION(NKVAL) :: AKVAL
+! AXY (16/08/11): Yuri change for non-surface carbonate chemistry
+! REAL(wp) :: P,T,S,VAL,TK
+ REAL(wp) :: P,T,S,VAL,TK, delta, kappa, Rgas
+ REAL(wp) :: dlogTK, S2, sqrtS, S15, k1, k2, kb
+! ***
+! AXY (16/08/11): Yuri change for non-surface carbonate chemistry
+ DATA Rgas/83.131/
+
+ DATA A/-167.8108D0, 290.9097D0, 207.6548D0, 148.0248D0/
+ DATA B/9345.17D0, -14554.21D0, -11843.79D0, -8966.9D0/
+ DATA C/23.3585D0, -45.0575D0, -33.6485D0, -24.4344D0/
+ DATA (A0(1,ICON),ICON=1,MAXCON) /3*0.0D0/
+ DATA (A0(2,ICON),ICON=1,MAXCON) /0.0221D0, 0.5709D0, -45.8076D0/
+ DATA (A0(3,ICON),ICON=1,MAXCON) /0.9805D0, 1.4853D0, -39.5492D0/
+ DATA (A0(4,ICON),ICON=1,MAXCON) /0.0473D0, 0.5998D0, 0.5998D0/
+ DATA (A1(1,ICON),ICON=1,MAXCON) /3*0.0D0/
+ DATA (A1(2,ICON),ICON=1,MAXCON) /34.02D0, -84.25D0, 1935.07D0/
+ DATA (A1(3,ICON),ICON=1,MAXCON) /-92.65D0, -192.69D0, 1590.14D0/
+ DATA (A1(4,ICON),ICON=1,MAXCON) /49.10D0, -75.25D0, -75.25D0/
+ DATA (A2(1,ICON),ICON=1,MAXCON) /3*0.0D0/
+ DATA (A2(2,ICON),ICON=1,MAXCON) /2*0.0D0,6.9513D0/
+ DATA (A2(3,ICON),ICON=1,MAXCON) /2*0.0D0,6.1523D0/
+ DATA (A2(4,ICON),ICON=1,MAXCON) /3*0.0D0/
+ DATA (B0(1,ICON),ICON=1,MAXCON) /3*0.023517D0/
+ DATA (B0(2,ICON),ICON=1,MAXCON) /0.0D0,-0.01632D0,-0.01566D0/
+ DATA (B0(3,ICON),ICON=1,MAXCON) /-0.03294D0,-0.05058D0,-0.04997D0/
+ DATA (B0(4,ICON),ICON=1,MAXCON) /0.0D0, -0.01767D0, -0.01767D0/
+ DATA (B1(1,ICON),ICON=1,MAXCON) /3*-2.3656D-4/
+ DATA (B1(2,ICON),ICON=1,MAXCON) /3*0.0D0/
+ DATA (B1(3,ICON),ICON=1,MAXCON) /3*0.0D0/
+ DATA (B1(4,ICON),ICON=1,MAXCON) /3*0.0D0/
+ DATA (B2(1,ICON),ICON=1,MAXCON) /3*4.7036D-7/
+ DATA (B2(2,ICON),ICON=1,MAXCON) /3*0.0D0/
+ DATA (B2(3,ICON),ICON=1,MAXCON) /3*0.0D0/
+ DATA (B2(4,ICON),ICON=1,MAXCON) /3*0.0D0/
+
+ TK=T+273.15D0
+ DO 100 IK=1,NKVAL
+ VAL=A(IK) + B(IK)/TK + C(IK)*LOG(TK)
+ VAL=VAL + (A0(IK,IC) + A1(IK,IC)/TK + A2(IK,IC)*LOG(TK))*SQRT(S)
+ VAL=VAL + (B0(IK,IC) + B1(IK,IC)*TK + B2(IK,IC)*TK*TK)*S
+ AKVAL(IK)=EXP(VAL)
+100 CONTINUE
+
+ IF (IC .EQ. 3) THEN
+! Calculation of constants as used in the OCMIP process for ICONST = 3 or 6
+! see http://www.ipsl.jussieu.fr/OCMIP/
+! added jcb 17/02/10
+
+! Derive simple terms used more than once
+ dlogTK = log(TK)
+ S2 = S*S
+ sqrtS = sqrt(S)
+ S15 = S**1.5
+! k1 = [H][HCO3]/[H2CO3]
+! k2 = [H][CO3]/[HCO3]
+! Millero p.664 (1995) using Mehrbach et al. data on seawater scale
+ k1=10**(-1*(3670.7/TK - 62.008 + 9.7944*dlogTK - &
+ & 0.0118 * S + 0.000116*S2))
+ k2=10**(-1*(1394.7/TK + 4.777 - &
+ & 0.0184*S + 0.000118*S2))
+! AXY (16/08/11): Yuri change for non-surface carbonate chemistry
+! Correction for high pressure (from Millero 1995)
+! added YA 04/10/2010
+ delta=-25.5+0.1271*T
+ kappa=(-3.08+0.0877*T)/1000.0
+ k1=k1*exp((-delta+0.5*kappa*P)*P/(Rgas*TK))
+ delta=-15.82-0.0219*T
+ kappa=(1.13-0.1475*T)/1000.0
+ k2=k2*exp((-delta+0.5*kappa*P)*P/(Rgas*TK))
+
+! kb = [H][BO2]/[HBO2]
+! Millero p.669 (1995) using data from Dickson (1990)
+ kb=exp((-8966.90 - 2890.53*sqrtS - 77.942*S + &
+ & 1.728*S15 - 0.0996*S2)/TK + &
+ & (148.0248 + 137.1942*sqrtS + 1.62142*S) + &
+ & (-24.4344 - 25.085*sqrtS - 0.2474*S) * &
+ & dlogTK + 0.053105*sqrtS*TK)
+! AXY (16/08/11): Yuri change for non-surface carbonate chemistry
+! Correction for high pressure (from Millero, 1995)
+! added YA 04/10/2010
+ delta=-29.48+0.1622*T-0.002608*T**2.0
+ kappa=-2.84/1000.0
+ kb=kb*exp((-delta+0.5*kappa*P)*P/(Rgas*TK))
+! Correction for high pressure of Kw (from Millero 1995)
+! added YA 04/10/2010
+ delta=-25.60+0.2324*T-0.0036246*T**2
+ kappa=(-5.13+0.0794*T)/1000.0
+ AKVAL(1)=AKVAL(1)*exp((-delta+0.5*kappa*P)*P/(Rgas*TK))
+
+! replace haltafall calculations with OCMIP calculations
+ AKVAL(2) = k1
+ AKVAL(3) = k2
+ AKVAL(4) = kb
+ END IF ! section implimenting OCMIP coefficients
+
+ RETURN
+ END SUBROUTINE
+!-----------------------------------------------------------------------
+
+!=======================================================================
+!=======================================================================
+!=======================================================================
+
+!=======================================================================
+!
+ SUBROUTINE CO2CLC(CONCS,NCONC,AKVAL,NKVAL,ICALC,BORON,BTOT,iters)
+!
+!=======================================================================
+!
+! ROUTINE TO CARRY OUT CO2 CALCULATIONS WITH 2 FIXED PARAMETERS ACCORDI
+! THE EQUATIONS GIVEN BY PARKS(1969) AND SKIRROW (1975)
+! WITH ADDITIONS FOR INCLUDING BORON IF BORON=.TRUE.
+
+
+! IMPLICIT real*8 (A-H,O-Z)
+ INTEGER :: NCONC, NKVAL, ICALC, II, KARL, LQ, iters
+! AXY (07/05/13) ==================================================
+! put counter in to check duration in convergence loop
+ INTEGER :: COUNTER,C_CHECK,C_SW,III
+! AXY (07/05/13) ==================================================
+ REAL(wp) :: CTOT,ALK,PCO2,PH,H2CO3,HCO3,CO3,ALKC
+ REAL(wp) :: ALKB,AKP,AK1C,AK2C,AKB,BTOT
+ REAL(wp) :: AKR,AHPLUS
+ REAL(wp) :: PROD,tol1,tol2,tol3,tol4,steg,fak
+ REAL(wp) :: STEGBY,Y,X,W,X1,Y1,X2,Y2,FACTOR,TERM,Z
+ REAL(wp), DIMENSION(NCONC) :: CONCS
+ REAL(wp), DIMENSION(NKVAL) :: AKVAL
+ REAL(wp), DIMENSION(9) :: CONCS2
+ REAL(wp), DIMENSION(4) :: AKVAL2
+
+! AXY (07/05/13) ==================================================
+! setup array to store old values of concs
+ real(wp),DIMENSION(:) :: old_CONCS(NCONC)
+! AXY (07/05/13) ==================================================
+
+ EQUIVALENCE (CTOT , CONCS2(1)), (ALK , CONCS2(2)), &
+ & (PCO2 , CONCS2(3)), (PH , CONCS2(4)), &
+ & (H2CO3 , CONCS2(5)), (HCO3 , CONCS2(6)), &
+ & (CO3 , CONCS2(7)), (ALKC , CONCS2(8)), &
+ & (ALKB , CONCS2(9)), &
+ & (AKP , AKVAL2(1)), (AK1C , AKVAL2(2)), &
+ & (AK2C , AKVAL2(3)), (AKB , AKVAL2(4))
+ LOGICAL :: BORON,DONE
+
+! AXY (07/05/13) ==================================================
+! DERIVING PH REQUIRES FOLLOWING LOOP TO CONVERGE.
+! THIS SUBROUTINE RELIES ON CONVERGENCE. IF THE ENVIRONMENTAL
+! CONDITIONS DO NOT ALLOW FOR CONVERGENCE (IN 3D MODEL THIS IS
+! LIKELY TO OCCUR NEAR LOW SALINITY REGIONS) THE MODEL WILL
+! BE STUCK IN THE LOOP. TO AVOID THIS A CONVERGENCE CONDITION
+! IS PUT IN PLACE TO SET A FLAGG OF -99 IN THE PH VAR FOR NON CONVEGENCE.
+! THE MODEL IS THEN ALLOWED TO CONTINUE. 'COUNTER, C_SW,C_CHECK' ARE
+! THE LOCAL VARS USED.
+! C_SW = condition of convergence 0=yes, 1= no
+! COUNTER = number of iterations
+! C_CHECK = maximum number of iterations
+
+! SET COUNTER AND SWITCH TO ZERO AND OFF
+ COUNTER=0
+ C_SW=0
+! FROM EXPERIENCE IF THE ITERATIONS IN THE FOLLOWING DO LOOP
+! EXCEEDS 15 CONVERGENCE WILL NOT OCCUR. THE OVERHEAD OF 25 ITERATIONS
+! IS OK FOR SMALL DOMAINS WITH 1/10 AND 1/15 DEG RESOLUTION.
+! I RECOMMEND A LOWER VALUE OF 15 FOR HIGHER RESOLUTION OR LARGER DOMAINS.
+ C_CHECK=25
+! AXY (07/05/13) ==================================================
+
+ DO 100 II=1,NCONC
+ CONCS2(II)=CONCS(II)
+
+! AXY (07/05/13) ==================================================
+! IF CONVERGENCE IS NOT ACHIEVED THE LOCAL ARRAY CONCS MUST BE STORED TO
+! ALLOW THE MODEL TO CONTINUE. THEREFORE ....
+! UPDATE OLD_CONCS
+ old_CONCS(II)=CONCS(II)
+! AXY (07/05/13) ==================================================
+
+100 CONTINUE
+ DO 110 II=1,NKVAL
+ AKVAL2(II)=AKVAL(II)
+110 CONTINUE
+ AKR = AK1C/AK2C
+ AHPLUS=10.0D0**(-PH)
+ PROD=AKR*AKP*PCO2
+
+ IF(BORON) THEN
+
+ IF(ICALC.EQ.1.OR.ICALC.EQ.4) THEN
+! *** ALK, BTOT AND CTOT OR PCO2 FIXED ***
+! *** ITERATIVE CALCULATION NECESSARY HERE
+
+! SET INITIAL GUESSES AND TOLERANCE
+ H2CO3=PCO2*AKP
+ CO3=ALK/10.0D0
+ AHPLUS=1.0D-8
+ ALKB=BTOT
+ TOL1=ALK/1.0D5
+ TOL2=H2CO3/1.0D5
+ TOL3=CTOT/1.0D5
+ TOL4=BTOT/1.0D5
+
+! HALTAFALL iteration to determine CO3, ALKB, AHPLUS
+ KARL=1
+ STEG=2.0D0
+ FAK=1.0D0
+ STEGBY=0.4D0
+10 DONE=.TRUE.
+
+! AXY (07/05/13) ==================================================
+! SET COUNTER UPDATE. FLAG 10 IS THE POINT OF RETURN FOR
+! THE CONVERGENCE CONDITION
+ COUNTER=COUNTER+1
+ iters = COUNTER
+! CHECK IF CONVERGENCE HAS OCCURED IN THE NUMBER OF
+! ACCEPTABLE ITTERATIONS. SET C_SW TO LET MODEL KNOW
+! WHAT TO DO AT THE END OF THE SUBROUTINE
+ if(counter.ge.c_check)then
+ IF(lwp) THEN
+ WRITE(numout,*) ' CO2CLC : ITERS WARNING, ', iters
+ ENDIF
+ c_sw=1
+ GOTO 123
+ endif
+! AXY (07/05/13) ==================================================
+
+ IF(ICALC.EQ.4) THEN
+! *** PCO2 IS FIXED ***
+ Y=AHPLUS*AHPLUS*CO3/(AK1C*AK2C)
+ IF(ABS(Y-H2CO3).GT.TOL2) THEN
+ CO3=CO3*H2CO3/Y
+ DONE=.FALSE.
+ ENDIF
+ ELSEIF(ICALC.EQ.1) THEN
+! *** CTOT IS FIXED ***
+ Y=CO3*(1.0D0+AHPLUS/AK2C+AHPLUS*AHPLUS/(AK1C*AK2C))
+ IF(ABS(Y-CTOT).GT.TOL3) THEN
+ CO3=CO3*CTOT/Y
+ DONE=.FALSE.
+ ENDIF
+ ENDIF
+ Y=ALKB*(1.0D0+AHPLUS/AKB)
+ IF(ABS(Y-BTOT).GT.TOL4) THEN
+ ALKB=ALKB*BTOT/Y
+ DONE=.FALSE.
+ ENDIF
+
+! Alkalinity is equivalent to -(total H+), so the sign of W is opposite
+! to that normally used
+
+ Y=CO3*(2.0D0+AHPLUS/AK2C)+ALKB
+ IF(ABS(Y-ALK).GT.TOL1) THEN
+ DONE=.FALSE.
+ X=LOG(AHPLUS)
+! W=SIGN(1.0D0,Y-ALK)
+ IF ( Y-ALK .GE. 0.0D0 ) THEN
+ W=1.0D0
+ ELSE
+ W=-1.0D0
+ ENDIF
+ IF(W.GE.0.0D0) THEN
+ X1=X
+ Y1=Y
+ ELSE
+ X2=X
+ Y2=Y
+ ENDIF
+ LQ=KARL
+ IF(LQ.EQ.1) THEN
+ KARL=2*NINT(W)
+ ELSEIF(IABS(LQ).EQ.2.AND.(LQ*W).LT.0.) THEN
+ FAK=0.5D0
+ KARL=3
+ ENDIF
+ IF(KARL.EQ.3.AND.STEG.LT.STEGBY) THEN
+ W=(X2-X1)/(Y2-Y1)
+ X=X1+W*(ALK-Y1)
+ ELSE
+ STEG=STEG*FAK
+ X=X+STEG*W
+ ENDIF
+ AHPLUS=EXP(X)
+ ENDIF
+ IF(.NOT.DONE) GOTO 10
+
+ HCO3=CO3*AHPLUS/AK2C
+ IF(ICALC.EQ.4) THEN
+ CTOT=H2CO3+HCO3+CO3
+ ELSEIF(ICALC.EQ.1) THEN
+ H2CO3=HCO3*AHPLUS/AK1C
+ PCO2=H2CO3/AKP
+ ENDIF
+ PH=-LOG10(AHPLUS)
+ ALKC=ALK-ALKB
+ ELSEIF(ICALC.EQ.2) THEN
+! *** CTOT, PCO2, AND BTOT FIXED ***
+ Y=SQRT(PROD*(PROD-4.0D0*AKP*PCO2+4.0D0*CTOT))
+ H2CO3=PCO2*AKP
+ HCO3=(Y-PROD)/2.0D0
+ CO3=CTOT-H2CO3-HCO3
+ ALKC=HCO3+2.0D0*CO3
+ AHPLUS=AK1C*H2CO3/HCO3
+ PH=-LOG10(AHPLUS)
+ ALKB=BTOT/(1.0D0+AHPLUS/AKB)
+ ALK=ALKC+ALKB
+ ELSEIF(ICALC.EQ.3) THEN
+! *** CTOT, PH AND BTOT FIXED ***
+ FACTOR=CTOT/(AHPLUS*AHPLUS+AK1C*AHPLUS+AK1C*AK2C)
+ CO3=FACTOR*AK1C*AK2C
+ HCO3=FACTOR*AK1C*AHPLUS
+ H2CO3=FACTOR*AHPLUS*AHPLUS
+ PCO2=H2CO3/AKP
+ ALKC=HCO3+2.0D0*CO3
+ ALKB=BTOT/(1.0D0+AHPLUS/AKB)
+ ALK=ALKC+ALKB
+ ELSEIF(ICALC.EQ.5) THEN
+! *** ALK, PH AND BTOT FIXED ***
+ ALKB=BTOT/(1.0D0+AHPLUS/AKB)
+ ALKC=ALK-ALKB
+ HCO3=ALKC/(1.0D0+2.0D0*AK2C/AHPLUS)
+ CO3=HCO3*AK2C/AHPLUS
+ H2CO3=HCO3*AHPLUS/AK1C
+ PCO2=H2CO3/AKP
+ CTOT=H2CO3+HCO3+CO3
+ ELSEIF(ICALC.EQ.6) THEN
+! *** PCO2, PH AND BTOT FIXED ***
+ ALKB=BTOT/(1.0D0+AHPLUS/AKB)
+ H2CO3=PCO2*AKP
+ HCO3=H2CO3*AK1C/AHPLUS
+ CO3=HCO3*AK2C/AHPLUS
+ CTOT=H2CO3+HCO3+CO3
+ ALKC=HCO3+2.0D0*CO3
+ ALK=ALKC+ALKB
+ ENDIF
+ ELSE
+ IF(ICALC.EQ.1) THEN
+! *** CTOT AND ALK FIXED ***
+ TERM=4.0D0*ALK+CTOT*AKR-ALK*AKR
+ Z=SQRT(TERM*TERM+4.0D0*(AKR-4.0D0)*ALK*ALK)
+ CO3=(ALK*AKR-CTOT*AKR-4.0D0*ALK+Z)/(2.0D0*(AKR-4.0D0))
+ HCO3=(CTOT*AKR-Z)/(AKR-4.0D0)
+ H2CO3=CTOT-ALK+CO3
+ PCO2=H2CO3/AKP
+ PH=-LOG10(AK1C*H2CO3/HCO3)
+ ELSEIF(ICALC.EQ.2) THEN
+! *** CTOT AND PCO2 FIXED ***
+ Y=SQRT(PROD*(PROD-4.0D0*AKP*PCO2+4.0D0*CTOT))
+ H2CO3=PCO2*AKP
+ HCO3=(Y-PROD)/2.0D0
+ CO3=CTOT-H2CO3-HCO3
+ ALK=HCO3+2.0D0*CO3
+ PH=-LOG10(AK1C*H2CO3/HCO3)
+ ELSEIF(ICALC.EQ.3) THEN
+! *** CTOT AND PH FIXED ***
+ FACTOR=CTOT/(AHPLUS*AHPLUS+AK1C*AHPLUS+AK1C*AK2C)
+ CO3=FACTOR*AK1C*AK2C
+ HCO3=FACTOR*AK1C*AHPLUS
+ H2CO3=FACTOR*AHPLUS*AHPLUS
+ PCO2=H2CO3/AKP
+ ALK=HCO3+2.0D0*CO3
+ ELSEIF(ICALC.EQ.4) THEN
+! *** ALK AND PCO2 FIXED ***
+ TERM=SQRT((8.0D0*ALK+PROD)*PROD)
+ CO3=ALK/2.0D0+PROD/8.0D0-TERM/8.0D0
+ HCO3=-PROD/4.0D0+TERM/4.0D0
+ H2CO3=PCO2*AKP
+ CTOT=CO3+HCO3+H2CO3
+ PH=-LOG10(AK1C*H2CO3/HCO3)
+ ELSEIF(ICALC.EQ.5) THEN
+! *** ALK AND PH FIXED ***
+ HCO3=ALK/(1.0D0+2.0D0*AK2C/AHPLUS)
+ CO3=HCO3*AK2C/AHPLUS
+ H2CO3=HCO3*AHPLUS/AK1C
+ PCO2=H2CO3/AKP
+ CTOT=H2CO3+HCO3+CO3
+ ELSEIF(ICALC.EQ.6) THEN
+! *** PCO2 AND PH FIXED ***
+ H2CO3=PCO2*AKP
+ HCO3=H2CO3*AK1C/AHPLUS
+ CO3=HCO3*AK2C/AHPLUS
+ CTOT=H2CO3+HCO3+CO3
+ ALK=HCO3+2.0D0*CO3
+ ENDIF
+ ENDIF
+
+ DO 120 II=1,NCONC
+ CONCS(II)=CONCS2(II)
+120 CONTINUE
+
+! AXY (07/05/13) ==================================================
+! C_SW IS SET AT 0 TO START
+! THEN IF NON CONVERGENCE C_SW SET TO 1
+123 IF(C_SW.EQ.1)THEN
+! IF NON CONVERGENCE, THE MODEL REQUIRES CONCS TO CONTAIN USABLE VALUES.
+! BEST OFFER BEING THE OLD CONCS VALUES WHEN CONVERGENCE HAS BEEN
+! ACHIEVED
+ DO II=1,NCONC
+ CONCS(II)=OLD_CONCS(II)
+ END DO
+
+! SPECIFIC CARBONATE VALUES TO PUSH CODE ON THROUGH THE
+! NON CONVERGENCE CONDITIONS
+! PCO2W = 0 SO CO2 UPTAKE WILL BE ENCOURAGED
+! CONCS(3)=O3C(III)*0.005_fp8/1.e6_fp8
+! -99 IS A FLAG TO SHOW WHEN AND WHERE NON CONVERGENCE OCCURED
+! CONCS(4)=PH, OUTPUT OF -99 MEANS NON-CONVERGENCE
+! CONCS(4)=-99._fp8
+!
+! AXY (10/05/13): remove this -99 flag; this is handled instead up in
+! trcbio_medusa.F90 where the iters variable is both
+! output and may be used to trigger action
+!
+! RESET SWITCH FOR NEXT CALL TO THIS SUBROUTINE
+ C_SW=0
+ ENDIF
+! AXY (07/05/13) ==================================================
+
+
+ RETURN
+
+ END SUBROUTINE
+!-----------------------------------------------------------------------
+
+!=======================================================================
+!=======================================================================
+!=======================================================================
+
+!=======================================================================
+!
+ SUBROUTINE CaCO3_Saturation (Tc, S, D, CO3, &
+ Om_cal, Om_arg)
+!
+!=======================================================================
+!
+! Routine to calculate the saturation state of calcite and aragonite
+! Inputs:
+! Tc Temperature (C)
+! S Salinity
+! D Depth (m)
+! CO3 Carbonate ion concentration (mol.kg-1 ie /1D6)
+!
+! Outputs
+! Om_cal Calite saturation
+! Om_arg Aragonite saturation
+!
+! Intermediates
+! K_cal Stoichiometric solubility product for calcite
+! K_arg Stoichiometric solubility product for aragonite
+! Ca Calcium 2+ concentration (mol.kg-1)
+! P Pressure (bars)
+!
+! Source
+! Zeebe & Wolf-Gladrow 2001 following Mucci (1983)
+! with pressure corrections from Millero (1995)
+! Code tested against reference values given in Z & W-G
+! Built Jerry Blackford, 2008
+!=======================================================================
+
+ IMPLICIT None
+ REAL(wp), INTENT( in ) :: Tc, S, D, CO3
+ REAL(wp), INTENT( inout ) :: Om_cal, Om_arg
+ REAL(wp) :: Tk, Kelvin, Ca
+ REAL(wp) :: logKspc, Kspc
+ REAL(wp) :: logKspa, Kspa
+ REAL(wp) :: tmp1, tmp2, tmp3
+ REAL(wp) :: dV, dK, P, R
+
+! setup
+ Kelvin = 273.15
+ Tk = Tc + Kelvin
+ Ca = 0.01028 ! Currently oceanic mean value at S=25, needs refining)
+ Ca = 0.010279 * (S / 35.0) ! Ca varies with salinity (cf. Feeley et al., 2004; Yool et al., 2010)
+ R = 83.131 !(cm3.bar.mol-1.K-1)
+ P = D / 10.0 !pressure in bars
+
+! calculate K for calcite
+ tmp1 = -171.9065 - (0.077993*Tk) + (2839.319/Tk) + 71.595*log10(Tk)
+ tmp2 = + (-0.77712 + (0.0028426*Tk) + (178.34/Tk))*SQRT(S)
+ tmp3 = - (0.07711*S) + (0.0041249*(S**1.5))
+ logKspc = tmp1 + tmp2 + tmp3
+ Kspc = 10.0**logKspc
+
+! correction for pressure for calcite
+ IF ( D .GT. 0) THEN
+ dV = -48.76 + 0.5304*Tc
+ dK = -11.76/1.0D3 + (0.3692/1.0D3) * Tc
+ tmp1 = -(dV/(R*Tk))*P + (0.5*dK/(R*Tk))*P*P
+ Kspc = Kspc*exp(tmp1)
+ logKspc = log10(Kspc)
+ END IF
+
+! calculate K for aragonite
+ tmp1 = -171.945 - 0.077993*Tk + 2903.293 / Tk + 71.595* log10(Tk)
+ tmp2 = + (-0.068393 + 0.0017276*Tk + 88.135/Tk)*SQRT(S)
+ tmp3 = - 0.10018*S + 0.0059415*S**1.5
+ logKspa = tmp1 + tmp2 + tmp3
+ Kspa = 10.0**logKspa
+
+! correction for pressure for aragonite
+ IF ( D .GT. 0) THEN
+ dV = -46.00 + 0.5304*Tc
+ dK = -11.76/1.0D3 + (0.3692/1.0D3) * Tc
+ tmp1 = -(dV/(R*Tk))*P + (0.5*dK/(R*Tk))*P*P
+ Kspa = Kspa*exp(tmp1)
+ logKspa = log10(Kspa)
+ END IF
+
+! calculate saturation states
+ Om_cal = (CO3 * Ca) / Kspc
+ Om_arg = (CO3 * Ca) / Kspa
+
+ RETURN
+
+ END SUBROUTINE
+!-----------------------------------------------------------------------
+
+!=======================================================================
+!=======================================================================
+!=======================================================================
+
+# else
+ !!======================================================================
+ !! Dummy module : No MEDUSA carbonate chemistry
+ !!======================================================================
+
+CONTAINS
+
+ SUBROUTINE trc_co2_medusa( kt ) ! Empty routine
+
+ INTEGER, INTENT( in ) :: kt
+
+ WRITE(*,*) 'trc_co2_medusa: You should not have seen this print! error?', kt
+
+ END SUBROUTINE trc_co2_medusa
+#endif
+
+ !!======================================================================
+END MODULE trcco2_medusa
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcctl_medusa.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcctl_medusa.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcctl_medusa.F90 (revision 8155)
@@ -0,0 +1,83 @@
+MODULE trcctl_medusa
+ !!======================================================================
+ !! *** trcctl_medusa.F90 ***
+ !! TOP : Control of MEDUSA_TRC biogeochemical model
+ !!======================================================================
+ !!----------------------------------------------------------------------
+ !! History : 1.0 ! 2000-12 (C. Ethe) assign a parameter to name individual tracers
+ !! - ! 2008-08 (K. Popova) adaptation for MEDUSA
+ !! - ! 2008-11 (A. Yool) continuing adaptation for MEDUSA
+ !! - ! 2010-03 (A. Yool) updated for branch inclusion
+ !!----------------------------------------------------------------------
+
+#if defined key_medusa
+
+ USE oce_trc
+ USE trc
+ USE in_out_manager
+ USE par_medusa
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_ctl_medusa ! called by ???
+
+
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 1.0 , LOCEAN-IPSL (2005)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+CONTAINS
+
+ SUBROUTINE trc_ctl_medusa
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE trc_ctl_medusa ***
+ !!
+ !! ** Purpose : control the cpp options, namelist and files
+ !!----------------------------------------------------------------------
+
+! IF(lwp) WRITE(numout,*)
+! IF(lwp) WRITE(numout,*) 'use MEDUSA biological model '
+
+! Check number of tracers
+! -----------------------
+# if defined key_roam
+ IF (jp_medusa /= 15) THEN
+ IF (lwp) THEN
+ WRITE (numout,*) ' ===>>>> : W A R N I N G '
+ WRITE (numout,*) ' ======= ============= '
+ WRITE (numout,*) &
+ & ' STOP, change jp_medusa to 15 in ' &
+ & ,' par_medusa.F90 '
+ END IF
+ STOP 'TRC_CTL'
+ END IF
+# else
+ IF (jp_medusa /= 11) THEN
+ IF (lwp) THEN
+ WRITE (numout,*) ' ===>>>> : W A R N I N G '
+ WRITE (numout,*) ' ======= ============= '
+ WRITE (numout,*) &
+ & ' STOP, change jp_medusa to 11 in ' &
+ & ,' par_medusa.F90 '
+ END IF
+ STOP 'TRC_CTL'
+ END IF
+# endif
+
+ END SUBROUTINE trc_ctl_medusa
+
+#else
+ !!----------------------------------------------------------------------
+ !! Empty module : No MEDUSA
+ !!----------------------------------------------------------------------
+CONTAINS
+ SUBROUTINE trc_ctl_medusa ! Dummy routine
+ END SUBROUTINE trc_ctl_medusa
+#endif
+
+ !!======================================================================
+END MODULE trcctl_medusa
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcdms_medusa.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcdms_medusa.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcdms_medusa.F90 (revision 8155)
@@ -0,0 +1,201 @@
+MODULE trcdms_medusa
+ !!======================================================================
+ !! *** MODULE trcdms_medusa ***
+ !! TOP : MEDUSA
+ !!======================================================================
+ !! History :
+ !! - ! 2014-08 (J. Palmieri - A. Yool) added for UKESM1 project
+ !! - ! 2017-05 (A. Yool) add extra Anderson scheme
+ !!----------------------------------------------------------------------
+#if defined key_medusa && defined key_roam
+ !!----------------------------------------------------------------------
+ !! MEDUSA DMS surface concentration
+ !!----------------------------------------------------------------------
+ !! trc_dms_medusa :
+ !!----------------------------------------------------------------------
+ USE oce_trc
+ USE trc
+ USE sms_medusa
+ USE lbclnk
+ USE prtctl_trc ! Print control for debugging
+ USE in_out_manager ! I/O manager
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_dms_medusa ! called in trc_bio_medusa
+
+ !!* Substitution
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+
+CONTAINS
+
+!=======================================================================
+!
+ SUBROUTINE trc_dms_medusa( chn, chd, mld, xqsr, xdin, xlim, & !! inputs
+ & dms_andr, dms_simo, dms_aran, dms_hall, dms_andm) !! outputs
+!
+!=======================================================================
+ !!
+ !! Title : Calculates DMS ocean surface concentration
+ !! Author : Julien Palmieri and Andrew Yool
+ !! Date : 08/08/14
+ !!
+ !! DMS module is called in trc_bio's huge jk,jj,ji loop
+ !! --> DMS concentration is calculated in a specific cell
+ !! (no need of ji,jj,jk)
+ !!
+ !! AXY (13/03/15): amend to include all four schemes tested
+ !! during winter/spring 2015; these are:
+ !!
+ !! 1. Anderson et al. (2001); this uses fields
+ !! of surface chl, irradiance and nutrients
+ !! to empirically estimate DMS via a broken
+ !! stick approach
+ !!
+ !! 2. Simo & Dachs (2002); this uses fields of
+ !! surface chl and mixed layer depth
+ !!
+ !! 3. Aranami & Tsunogai (2004); this is an
+ !! embellishment of Simo & Dachs
+ !!
+ !! 4. Halloran et al. (2010); this is an
+ !! alternative embellishment of Sim & Dachs
+ !! and is included because it is formally
+ !! published (and different from the above)
+ !!
+ !! AXY (25/05/17): add extra "corrected" Anderson scheme
+ !!
+ !! 5. As Anderson et al. (2001) but modified to
+ !! more accurately reflect nutrient limitation
+ !! status of phytoplankton community
+ !!
+ !! AXY (08/07/15): amend to remove Julien's original calculation
+ !! as this is now superfluous; the four schemes
+ !! are calculated and one is chosen to be passed
+ !! to the atmosphere in trc_bio_medusa
+ !!
+!=======================================================================
+
+ IMPLICIT NONE
+!
+ REAL(wp), INTENT( in ) :: chn !! non-diatom chlorophyll (mg/m3)
+ REAL(wp), INTENT( in ) :: chd !! diatom chlorophyll (mg/m3)
+ REAL(wp), INTENT( in ) :: mld !! mix layer depth (m)
+ REAL(wp), INTENT( in ) :: xqsr !! surface irradiance (W/m2)
+ REAL(wp), INTENT( in ) :: xdin !! surface DIN (mmol N/m3)
+ REAL(wp), INTENT( in ) :: xlim !! surface DIN limitation (mmol N/m3)
+ REAL(wp), INTENT( inout ) :: dms_andr !! DMS surface concentration (nmol/L)
+ REAL(wp), INTENT( inout ) :: dms_simo !! DMS surface concentration (nmol/L)
+ REAL(wp), INTENT( inout ) :: dms_aran !! DMS surface concentration (nmol/L)
+ REAL(wp), INTENT( inout ) :: dms_hall !! DMS surface concentration (nmol/L)
+ REAL(wp), INTENT( inout ) :: dms_andm !! DMS surface concentration (nmol/L)
+!
+ REAL(wp) :: CHL, cmr, sw_dms
+ REAL(wp) :: Jterm, Qterm
+ !! temporary variables
+ REAL(wp) :: fq1,fq2,fq3
+!
+!=======================================================================
+!
+! AXY (13/03/15): per remarks above, the following calculations estimate
+! DMS using all of the schemes examined for UKESM1
+!
+ CHL = 0.0
+ CHL = chn+chd !! mg/m3
+ cmr = CHL / mld
+!
+! AXY (13/03/15): Anderson et al. (2001)
+ Jterm = xqsr + 1.0e-6
+ !! this next line makes a hard-coded assumption about the
+ !! half-saturation constant of MEDUSA (which should be
+ !! done properly; perhaps even scaled with the proportion
+ !! of diatoms and non-diatoms)
+ Qterm = xdin / (xdin + 0.5)
+ fq1 = log10(CHL * Jterm * Qterm)
+ if (fq1 > 1.72) then
+ dms_andr = (8.24 * (fq1 - 1.72)) + 2.29
+ else
+ dms_andr = 2.29
+ endif
+!
+! AXY (13/03/15): Simo & Dachs (2002)
+ fq1 = (-1.0 * log(mld)) + 5.7
+ fq2 = (55.8 * cmr) + 0.6
+ if (cmr < 0.02) then
+ dms_simo = fq1
+ else
+ dms_simo = fq2
+ endif
+!
+! AXY (13/03/15): Aranami & Tsunogai (2004)
+ fq1 = 60.0 / mld
+ fq2 = (55.8 * cmr) + 0.6
+ if (cmr < 0.02) then
+ dms_aran = fq1
+ else
+ dms_aran = fq2
+ endif
+!
+! AXY (13/03/15): Halloran et al. (2010)
+ fq1 = (-1.0 * log(mld)) + 5.7
+ fq2 = (55.8 * cmr) + 0.6
+ fq3 = (90.0 / mld)
+ if (cmr < 0.02) then
+ dms_hall = fq1
+ else
+ dms_hall = fq2
+ endif
+ if (mld > 182.5) then
+ dms_hall = fq3
+ endif
+!
+! AXY (25/05/17): modified Anderson et al. (2001)
+ Jterm = xqsr + 1.0e-6
+ !! this version fixes the hard-coded assumption above
+ Qterm = xlim
+ fq1 = log10(CHL * Jterm * Qterm)
+ if (fq1 > 1.72) then
+ dms_andm = (8.24 * (fq1 - 1.72)) + 2.29
+ else
+ dms_andm = 2.29
+ endif
+
+ END SUBROUTINE trc_dms_medusa
+
+
+!=======================================================================
+!=======================================================================
+!=======================================================================
+
+#else
+ !!======================================================================
+ !! Dummy module : No MEDUSA bio-model
+ !!======================================================================
+
+CONTAINS
+
+!=======================================================================
+!
+ SUBROUTINE trc_dms_medusa( kt ) !! EMPTY Routine
+!
+!
+ INTEGER, INTENT( in ) :: kt
+!
+
+ WRITE(*,*) 'trc_dms_medusa: You should not have seen this print! error?'
+
+ END SUBROUTINE trc_dms_medusa
+#endif
+
+ !!======================================================================
+END MODULE trcdms_medusa
+
+
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcini_medusa.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcini_medusa.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcini_medusa.F90 (revision 8155)
@@ -0,0 +1,492 @@
+MODULE trcini_medusa
+ !!======================================================================
+ !! *** MODULE trcini_medusa ***
+ !! TOP : initialisation of the MEDUSA tracers
+ !!======================================================================
+ !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) Original code
+ !! - ! 2008-08 (K. Popova) adaptation for MEDUSA
+ !! - ! 2008-11 (A. Yool) continuing adaptation for MEDUSA
+ !! - ! 2010-03 (A. Yool) updated for branch inclusion
+ !! - ! 2011-04 (A. Yool) updated for ROAM project
+ !!----------------------------------------------------------------------
+#if defined key_medusa
+ !!----------------------------------------------------------------------
+ !! 'key_medusa' MEDUSA tracers
+ !!----------------------------------------------------------------------
+ !! trc_ini_medusa : MEDUSA model initialisation
+ !!----------------------------------------------------------------------
+ USE par_trc ! TOP parameters
+ USE oce_trc
+ USE trc
+ USE in_out_manager
+ !! AXY (04/11/13): add this in for initialisation stuff
+ USE iom
+ USE par_medusa
+ !! AXY (13/01/12): add this in for sediment variables
+ USE sms_medusa
+ !! AXY (04/11/13): add this in for initialisation stuff
+ USE trcsed_medusa
+ USE sbc_oce, ONLY: lk_oasis
+ USE oce, ONLY: CO2Flux_out_cpl, DMS_out_cpl, chloro_out_cpl !! Coupling variable
+
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_ini_medusa ! called by trcini.F90 module
+
+ !! AXY (25/02/10)
+ LOGICAL, PUBLIC :: &
+ bocalccd = .TRUE.
+ !! JPALM (14/09/15)
+ LOGICAL, PUBLIC :: &
+ ln_ccd = .TRUE.
+
+ INTEGER :: &
+ numccd
+
+ !! AXY (25/02/10)
+ INTEGER :: &
+ numriv
+
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+CONTAINS
+
+ SUBROUTINE trc_ini_medusa
+ !!----------------------------------------------------------------------
+ !! *** trc_ini_medusa ***
+ !!
+ !! ** Purpose : initialization for MEDUSA model
+ !!
+ !! ** Method : - Read the namcfc namelist and check the parameter values
+ !!----------------------------------------------------------------------
+ !!----------------------------------------------------------------------
+
+ !! vertical array index
+ INTEGER :: jk, ierr
+ !! AXY (19/07/12): added jk2 to set up friver_dep array
+ INTEGER :: jk2
+ !! AXY (19/07/12): added tfthk to set up friver_dep array
+ REAL(wp) :: fthk, tfthk
+ !! AXY (04/11/13): add in temporary variables for checks
+ REAL(wp) :: fq0, fq1, fq2
+
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) ' trc_ini_medusa: initialisation of MEDUSA model'
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~'
+# if defined key_debug_medusa
+ CALL flush(numout)
+# endif
+
+ ! Allocate MEDUSA arrays
+ ierr = sms_medusa_alloc()
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) 'in trc_ini_medusa, just after array allocate'
+ IF (lwp) write (numout,*) ' '
+ CALL flush(numout)
+# endif
+
+!!
+!! AXY (19/07/12): setup array to control distribution of river nutrients
+ friver_dep(:,:) = 0.
+ DO jk = 1,jpk
+ tfthk = 0.
+ DO jk2 = 1,jriver_dep
+ fthk = e3t_1d(jk2)
+ if (jk2 .le. jk) then
+ tfthk = tfthk + fthk
+ friver_dep(jk2,jk) = fthk
+ endif
+ ENDDO
+ DO jk2 = 1,jriver_dep
+ friver_dep(jk2,jk) = friver_dep(jk2,jk) / tfthk
+ ENDDO
+ ENDDO
+!!
+!! Have a look at the result of this for a single depth (jriver_dep + 1)
+ IF(lwp) THEN
+ WRITE(numout,*) '=== River nutrient fraction by depth (for a water column of jpk depth)'
+ DO jk = 1,jpk
+ WRITE(numout,*) &
+ & ' cell = ', jk, ', friver_dep value = ', friver_dep(jk,jpk)
+ ENDDO
+ IF(lwp) CALL flush(numout)
+ ENDIF
+
+#if defined key_roam
+!! ROAM 3D and 2D carbonate system fields (calculated on first time
+!! step, then monthly)
+ f3_pH(:,:,:) = 0.
+ f3_h2co3(:,:,:) = 0.
+ f3_hco3(:,:,:) = 0.
+ f3_co3(:,:,:) = 0.
+ f3_omcal(:,:,:) = 0.
+ f3_omarg(:,:,:) = 0.
+!!
+ f2_ccd_cal(:,:) = 0.
+ f2_ccd_arg(:,:) = 0.
+ IF(lwp) WRITE(numout,*) ' trc_ini_medusa: carbonate fields initialised to zero'
+#endif
+ IF(lwp) CALL flush(numout)
+
+ !!----------------------------------------------------------------------
+ !! State variable initial conditions (all mmol / m3)
+ !!----------------------------------------------------------------------
+ !!
+ !! biological and detrital components are initialised to nominal
+ !! values above 100 m depth and zero below; the latter condition
+ !! is applied since non-linear loss processes allow significant
+ !! concentrations of these components to persist at depth
+ !!
+ trn(:,:,:,jpchn) = 0.
+ trn(:,:,:,jpchd) = 0.
+ trn(:,:,:,jpphn) = 0.
+ trn(:,:,:,jpphd) = 0.
+ trn(:,:,:,jppds) = 0.
+ trn(:,:,:,jpzmi) = 0.
+ trn(:,:,:,jpzme) = 0.
+ trn(:,:,:,jpdet) = 0.
+ !!
+ DO jk = 1,13
+ !! non-diatom chlorophyll (nominal)
+ trn(:,:,jk,jpchn) = 0.01
+ !!
+ !! diatom chlorophyll (nominal)
+ trn(:,:,jk,jpchd) = 0.01
+ !!
+ !! non-diatom (nominal)
+ trn(:,:,jk,jpphn) = 0.01
+ !!
+ !! diatom (nominal)
+ trn(:,:,jk,jpphd) = 0.01
+ !!
+ !! diatom silicon (nominal)
+ trn(:,:,jk,jppds) = 0.01
+ !!
+ !! microzooplankton (nominal)
+ trn(:,:,jk,jpzmi) = 0.01
+ !!
+ !! mesozooplankton (nominal)
+ trn(:,:,jk,jpzme) = 0.01
+ !!
+ !! detrital nitrogen (nominal)
+ trn(:,:,jk,jpdet) = 0.01
+ ENDDO
+ !!
+ !! dissolved inorganic nitrogen (nominal average value; typically initialised from climatology)
+ trn(:,:,:,jpdin) = 30.
+ !!
+ !! dissolved silicic acid (nominal average value; typically initialised from climatology)
+ trn(:,:,:,jpsil) = 90.
+ !!
+ !! dissolved "total" iron (nominal; typically initialised from model-derived climatology)
+ trn(:,:,:,jpfer) = 1.0e-4 !! = 0.1 umol Fe / m3
+ !!
+ IF(lwp) WRITE(numout,*) ' trc_ini_medusa: MEDUSA-1 fields initialised to defaults'
+# if defined key_roam
+ !!
+ !! detrital carbon (nominal)
+ trn(:,:,:,jpdtc) = 0.
+ DO jk = 1,13
+ trn(:,:,jk,jpdtc) = 0.06625
+ ENDDO
+ !!
+ !! dissolved inorganic carbon (DIC) (nominal average value; typically initialised from climatology)
+ trn(:,:,:,jpdic) = 2330.
+ !!
+ !! total alkalinity (nominal average value; typically initialised from climatology)
+ trn(:,:,:,jpalk) = 2450.
+ !!
+ !! dissolved oxygen (nominal average value; typically initialised from climatology)
+ trn(:,:,:,jpoxy) = 175.
+ !!
+ IF(lwp) WRITE(numout,*) ' trc_ini_medusa: MEDUSA-2 fields initialised to defaults'
+# endif
+ IF(lwp) CALL flush(numout)
+
+ !!----------------------------------------------------------------------
+ !! Sediment pools initial conditions (all mmol / m2)
+ !!----------------------------------------------------------------------
+ !!
+ !! these pools store biogenic material that has sunk to the seabed,
+ !! and act as a temporary reservoir
+ zb_sed_n(:,:) = 0.0 !! organic N
+ zn_sed_n(:,:) = 0.0
+ za_sed_n(:,:) = 0.0
+ zb_sed_fe(:,:) = 0.0 !! organic Fe
+ zn_sed_fe(:,:) = 0.0
+ za_sed_fe(:,:) = 0.0
+ zb_sed_si(:,:) = 0.0 !! inorganic Si
+ zn_sed_si(:,:) = 0.0
+ za_sed_si(:,:) = 0.0
+ zb_sed_c(:,:) = 0.0 !! organic C
+ zn_sed_c(:,:) = 0.0
+ za_sed_c(:,:) = 0.0
+ zb_sed_ca(:,:) = 0.0 !! inorganic C
+ zn_sed_ca(:,:) = 0.0
+ za_sed_ca(:,:) = 0.0
+ !!
+ IF(lwp) WRITE(numout,*) ' trc_ini_medusa: benthic fields initialised to zero'
+ IF(lwp) CALL flush(numout)
+
+ !!----------------------------------------------------------------------
+ !! Averaged properties for DMS calculations (various units)
+ !!----------------------------------------------------------------------
+ !!
+ !! these store temporally averaged properties for DMS calculations (AXY, 07/07/15)
+ zb_dms_chn(:,:) = 0.0 !! CHN
+ zn_dms_chn(:,:) = 0.0
+ za_dms_chn(:,:) = 0.0
+ zb_dms_chd(:,:) = 0.0 !! CHD
+ zn_dms_chd(:,:) = 0.0
+ za_dms_chd(:,:) = 0.0
+ zb_dms_mld(:,:) = 0.0 !! MLD
+ zn_dms_mld(:,:) = 0.0
+ za_dms_mld(:,:) = 0.0
+ zb_dms_qsr(:,:) = 0.0 !! QSR
+ zn_dms_qsr(:,:) = 0.0
+ za_dms_qsr(:,:) = 0.0
+ zb_dms_din(:,:) = 0.0 !! DIN
+ zn_dms_din(:,:) = 0.0
+ za_dms_din(:,:) = 0.0
+ !!
+ IF(lwp) WRITE(numout,*) ' trc_ini_medusa: average fields for DMS initialised to zero'
+ IF(lwp) CALL flush(numout)
+ !!
+ !!---------------------------------------------------------------------
+ !!JPALM (14-06-2016): init dms and co2 flux for coupling with atm (UKESM)
+ !!---------------------------------------------------------------------
+ !!
+ zb_co2_flx(:,:) = 0.0 !! CO2 flx
+ zn_co2_flx(:,:) = 0.0
+ za_co2_flx(:,:) = 0.0
+ zb_dms_srf(:,:) = 0.0 !! DMS srf
+ zn_dms_srf(:,:) = 0.0
+ za_dms_srf(:,:) = 0.0
+ zn_chl_srf(:,:) = 2.0E-8 !! Chl srf
+ !!
+ IF(lwp) WRITE(numout,*) ' trc_ini_medusa: DMS and CO2 flux (UKESM) initialised to zero'
+ IF(lwp) CALL flush(numout)
+ IF (lk_oasis) THEN
+ CO2Flux_out_cpl(:,:) = zn_co2_flx(:,:) !! Coupling variable
+ DMS_out_cpl(:,:) = zn_dms_srf(:,:) !! Coupling variable
+ chloro_out_cpl(:,:) = zn_chl_srf(:,:) !! Coupling variable
+ END IF
+ !!
+ !!----------------------------------------------------------------------
+ !! AXY (04/11/13): initialise fields previously done by trc_sed_medusa
+ !!----------------------------------------------------------------------
+ !!
+ IF(lwp) WRITE(numout,*) ' trc_ini_medusa: initialising dust deposition fields'
+ CALL trc_sed_medusa_sbc( nit000 )
+ !!
+ IF(lwp) WRITE(numout,*) ' trc_ini_medusa: initialising ocean CCD array'
+ CALL trc_ini_medusa_ccd( nit000 )
+ fq0 = MINVAL(ocal_ccd(:,:))
+ fq1 = MAXVAL(ocal_ccd(:,:))
+ if (lwp) write (numout,'(a,f10.3,a,f10.3)') &
+ & 'CCD: min ', fq0, ' max ', fq1
+ !!
+ IF(lwp) WRITE(numout,*) ' trc_ini_medusa: initialising riverine nutrient arrays'
+ riv_n(:,:) = 0.0
+ riv_si(:,:) = 0.0
+ riv_c(:,:) = 0.0
+ riv_alk(:,:) = 0.0
+ !!
+ CALL trc_ini_medusa_river( nit000 )
+ fq0 = MINVAL(riv_n(:,:))
+ fq1 = MAXVAL(riv_n(:,:))
+ if (lwp) write (numout,'(a,f10.3,a,f10.3)') &
+ & 'RIV_N: min ', fq0, ' max ', fq1
+ fq0 = MINVAL(riv_si(:,:))
+ fq1 = MAXVAL(riv_si(:,:))
+ if (lwp) write (numout,'(a,f10.3,a,f10.3)') &
+ & 'RIV_SI: min ', fq0, ' max ', fq1
+ fq0 = MINVAL(riv_c(:,:))
+ fq1 = MAXVAL(riv_c(:,:))
+ if (lwp) write (numout,'(a,f10.3,a,f10.3)') &
+ & 'RIV_C: min ', fq0, ' max ', fq1
+ fq0 = MINVAL(riv_alk(:,:))
+ fq1 = MAXVAL(riv_alk(:,:))
+ if (lwp) write (numout,'(a,f10.3,a,f10.3)') &
+ & 'RIV_ALK: min ', fq0, ' max ', fq1
+ IF(lwp) CALL flush(numout)
+
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) ' trc_ini_medusa: MEDUSA initialised'
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~'
+ IF(lwp) CALL flush(numout)
+
+ END SUBROUTINE trc_ini_medusa
+
+ !! ======================================================================
+ !! ======================================================================
+ !! ======================================================================
+
+ !! AXY (25/02/10)
+ SUBROUTINE trc_ini_medusa_ccd(kt)
+
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE trc_ini_medusa_ccd ***
+ !!
+ !! ** Purpose : Read CCD field
+ !!
+ !! ** Method : Read the file
+ !!
+ !! ** input : external netcdf files
+ !!
+ !!----------------------------------------------------------------------
+ !! * arguments
+ INTEGER, INTENT( in ) :: kt ! ocean time step
+
+ !!---------------------------------------------------------------------
+
+ !! Open the file
+ !! -------------
+ !!
+ !!!! JPALM -- 14-09-2015 --
+ !!!! -- to test on ORCA2 with Christian, no file available, so initiate to 0
+ IF (ln_ccd) THEN
+ IF(lwp) WRITE(numout,*) ' '
+ IF(lwp) WRITE(numout,*) ' **** Routine trc_ini_medusa_ccd'
+ CALL iom_open ( 'ccd_ocal_nemo.nc', numccd )
+ IF(lwp) WRITE(numout,*) ' **** trc_ini_medusa_ccd: ccd_ocal_nemo.nc opened'
+
+ !! Read the data
+ !! -------------
+ !!
+ CALL iom_get ( numccd, jpdom_data, 'OCAL_CCD', ocal_ccd )
+ IF(lwp) WRITE(numout,*) ' **** trc_ini_medusa_ccd: data read'
+
+ !! Close the file
+ !! --------------
+ !!
+ CALL iom_close ( numccd )
+ IF(lwp) WRITE(numout,*) ' **** trc_ini_medusa_ccd: ccd_ocal_nemo.nc closed'
+ IF(lwp) CALL flush(numout)
+ ELSE
+ IF(lwp) WRITE(numout,*) ' '
+ IF(lwp) WRITE(numout,*) ' **** Routine trc_ini_medusa_ccd'
+ IF(lwp) WRITE(numout,*) ' **** trc_ini_medusa_ccd: do not read ccd_ocal_nemo.nc'
+ IF(lwp) WRITE(numout,*) ' **** ln_ccd = FALSE and ocal_ccd = 0.0 ---'
+ ocal_ccd(:,:) = 0.0
+ ENDIF
+
+ END SUBROUTINE trc_ini_medusa_ccd
+
+ !! ======================================================================
+ !! ======================================================================
+ !! ======================================================================
+
+ !! AXY (26/01/12)
+ SUBROUTINE trc_ini_medusa_river(kt)
+
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE trc_ini_medusa_river ***
+ !!
+ !! ** Purpose : Read riverine nutrient fields
+ !!
+ !! ** Method : Read the file
+ !!
+ !! ** input : external netcdf files
+ !!
+ !!----------------------------------------------------------------------
+ !! * arguments
+ INTEGER, INTENT( in ) :: kt ! ocean time step
+
+ !!---------------------------------------------------------------------
+
+ IF(lwp) THEN
+ WRITE(numout,*) ' '
+ WRITE(numout,*) ' **** Routine trc_ini_medusa_river'
+ WRITE(numout,*) ' '
+ ENDIF
+
+ !! Open and read the files
+ !! -----------------------
+ !!
+ if (jriver_n.gt.0) then
+ if (jriver_n.eq.1) CALL iom_open ( 'river_N_conc_orca100.nc', numriv )
+ if (jriver_n.eq.2) CALL iom_open ( 'river_N_flux_orca100.nc', numriv )
+ CALL iom_get ( numriv, jpdom_data, 'RIV_N', riv_n )
+ IF(lwp) THEN
+ if (jriver_n.eq.1) WRITE(numout,*) ' **** trc_ini_medusa_river: N CONC data read'
+ if (jriver_n.eq.2) WRITE(numout,*) ' **** trc_ini_medusa_river: N FLUX data read'
+ ENDIF
+ CALL iom_close ( numriv )
+ IF(lwp) WRITE(numout,*) ' **** trc_ini_medusa_river: river N file closed'
+ else
+ IF(lwp) THEN
+ WRITE(numout,*) ' **** trc_ini_medusa_river: N data NOT read'
+ ENDIF
+ endif
+ !!
+ if (jriver_si.gt.0) then
+ if (jriver_si.eq.1) CALL iom_open ( 'river_Si_conc_orca100.nc', numriv )
+ if (jriver_si.eq.2) CALL iom_open ( 'river_Si_flux_orca100.nc', numriv )
+ CALL iom_get ( numriv, jpdom_data, 'RIV_SI', riv_si )
+ IF(lwp) THEN
+ if (jriver_si.eq.1) WRITE(numout,*) ' **** trc_ini_medusa_river: Si CONC data read'
+ if (jriver_si.eq.2) WRITE(numout,*) ' **** trc_ini_medusa_river: Si FLUX data read'
+ ENDIF
+ CALL iom_close ( numriv )
+ IF(lwp) WRITE(numout,*) ' **** trc_ini_medusa_river: river Si file closed'
+ else
+ IF(lwp) THEN
+ WRITE(numout,*) ' **** trc_ini_medusa_river: Si data NOT read'
+ ENDIF
+ endif
+ !!
+ if (jriver_c.gt.0) then
+ if (jriver_c.eq.1) CALL iom_open ( 'river_C_conc_orca100.nc', numriv )
+ if (jriver_c.eq.2) CALL iom_open ( 'river_C_flux_orca100.nc', numriv )
+ CALL iom_get ( numriv, jpdom_data, 'RIV_C', riv_c )
+ IF(lwp) THEN
+ if (jriver_c.eq.1) WRITE(numout,*) ' **** trc_ini_medusa_river: C CONC data read'
+ if (jriver_c.eq.2) WRITE(numout,*) ' **** trc_ini_medusa_river: C FLUX data read'
+ ENDIF
+ CALL iom_close ( numriv )
+ IF(lwp) WRITE(numout,*) ' **** trc_ini_medusa_river: river C file closed'
+ else
+ IF(lwp) THEN
+ WRITE(numout,*) ' **** trc_ini_medusa_river: C data NOT read'
+ ENDIF
+ endif
+ !!
+ if (jriver_alk.gt.0) then
+ if (jriver_alk.eq.1) CALL iom_open ( 'river_alk_conc_orca100.nc', numriv )
+ if (jriver_alk.eq.2) CALL iom_open ( 'river_alk_flux_orca100.nc', numriv )
+ CALL iom_get ( numriv, jpdom_data, 'RIV_ALK', riv_alk )
+ IF(lwp) THEN
+ if (jriver_alk.eq.1) WRITE(numout,*) ' **** trc_ini_medusa_river: alkalinity CONC data read'
+ if (jriver_alk.eq.2) WRITE(numout,*) ' **** trc_ini_medusa_river: alkalinity FLUX data read'
+ ENDIF
+ CALL iom_close ( numriv )
+ IF(lwp) WRITE(numout,*) ' **** trc_ini_medusa_river: river alkalinity file closed'
+ else
+ IF(lwp) THEN
+ WRITE(numout,*) ' **** trc_ini_medusa_river: alkalinity data NOT read'
+ ENDIF
+ endif
+ IF(lwp) CALL flush(numout)
+
+ END SUBROUTINE trc_ini_medusa_river
+
+#else
+ !!----------------------------------------------------------------------
+ !! Dummy module No MEDUSA model
+ !!----------------------------------------------------------------------
+CONTAINS
+ SUBROUTINE trc_ini_medusa ! Empty routine
+ END SUBROUTINE trc_ini_medusa
+#endif
+
+ !!======================================================================
+END MODULE trcini_medusa
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcnam_medusa.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcnam_medusa.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcnam_medusa.F90 (revision 8155)
@@ -0,0 +1,2447 @@
+MODULE trcnam_medusa
+ !!======================================================================
+ !! *** MODULE trcnam_medusa ***
+ !! TOP : initialisation of some run parameters for MEDUSA bio-model
+ !!======================================================================
+ !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) Original code
+ !! - ! 2008-08 (K. Popova) adaptation for MEDUSA
+ !! - ! 2008-11 (A. Yool) continuing adaptation for MEDUSA
+ !! - ! 2010-03 (A. Yool) updated for branch inclusion
+ !! - ! 2011-04 (A. Yool) updated for ROAM project
+ !! - ! 2013-05 (A. Yool) renamed (from trclsm) for v3.5
+ !! - ! 2015-11 (J. Palmieri) added iom_use for diags
+ !! - ! 2016-11 (A. Yool) updated diags for CMIP6
+ !!----------------------------------------------------------------------
+#if defined key_medusa
+ !!----------------------------------------------------------------------
+ !! 'key_medusa' : MEDUSA model
+ !!----------------------------------------------------------------------
+ !! trc_nam_medusa : MEDUSA model initialisation
+ !!----------------------------------------------------------------------
+ USE oce_trc ! Ocean variables
+ USE par_trc ! TOP parameters
+ USE trc ! TOP variables
+ USE sms_medusa ! sms trends
+ USE iom ! I/O manager
+ !!USE trc_nam_dia ! JPALM 13-11-2015 -- if iom_use for diag
+
+ !! AXY (04/02/14): necessary to find NaNs on HECTOR
+ USE, INTRINSIC :: ieee_arithmetic
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_nam_medusa ! called by trcnam.F90 module
+ PUBLIC trc_nam_iom_medusa ! called by trcnam.F90 module
+
+ !!* Substitution
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+CONTAINS
+
+ SUBROUTINE trc_nam_medusa
+ !!----------------------------------------------------------------------
+ !! *** trc_nam_medusa ***
+ !!
+ !! ** Purpose : read MEDUSA namelist
+ !!
+ !! ** input : file 'namelist.trc.sms' containing the following
+ !! namelist: natbio, natopt, and natdbi ("key_trc_diabio")
+ !!
+ !! ekp: namelist nabio contains ALL parameters of the ecosystem
+ !! point sourses and sinks PLUS sediment exchange
+ !! dia_bio - used by Lobster to output all point terms
+ !! (sourses and sinks of bio)
+ !! dia_add - additional diagnostics for biology such as
+ !! primary production (2d depth integrated field or 3d)
+ !!----------------------------------------------------------------------
+ !!
+ INTEGER :: ji,jj,jk
+ REAL(wp) :: fthk, fdep, fdep1
+ REAL(wp) :: q1, q2, q3
+ !
+ NAMELIST/natbio/ xxi,xaln,xald,jphy,xvpn,xvpd, &
+ & xsin0,xnsi0,xuif,jliebig, jq10, &
+ & xthetam,xthetamd,xnln,xnld,xsld,xfln,xfld, &
+ & xgmi,xgme,xkmi,xkme,xphi,xbetan,xbetac,xkc, &
+ & xpmipn,xpmid,xpmepn,xpmepd,xpmezmi,xpmed, &
+ & xmetapn,xmetapd,xmetazmi,xmetazme, &
+ & jmpn,xmpn,xkphn,jmpd,xmpd,xkphd,jmzmi,xmzmi,xkzmi, &
+ & jmzme,xmzme,xkzme,jmd,jsfd,xmd,xmdc, &
+ & xthetapn,xthetapd,xthetazmi,xthetazme,xthetad, &
+ & xrfn,xrsn,vsed,xhr, &
+ & jiron,xfe_mass,xfe_sol,xfe_sed,xLgT,xk_FeL,xk_sc_Fe, &
+ & jexport,jfdfate,jrratio,jocalccd,xridg_r0, &
+ & xfdfrac1,xfdfrac2,xfdfrac3, &
+ & xcaco3a,xcaco3b,xmassc,xmassca,xmasssi,xprotca, &
+ & xprotsi,xfastc,xfastca,xfastsi, &
+ & jorgben,jinorgben,xsedn,xsedfe,xsedsi,xsedc,xsedca, &
+ & xburial, &
+ & jriver_n,jriver_si,jriver_c,jriver_alk,jriver_dep, &
+ & xsdiss, &
+ & sedlam,sedlostpoc,jpkb,jdms,jdms_input,jdms_model
+#if defined key_roam
+ NAMELIST/natroam/ xthetaphy,xthetazoo,xthetanit, &
+ & xthetarem,xo2min
+#endif
+ NAMELIST/natopt/xkg0,xkr0,xkgp,xkrp,xlg,xlr,rpig
+ INTEGER :: jl, jn
+ INTEGER :: ios ! Local integer output status for namelist read
+ TYPE(DIAG), DIMENSION(jp_medusa_2d) :: meddia2d
+ TYPE(DIAG), DIMENSION(jp_medusa_3d) :: meddia3d
+ TYPE(DIAG), DIMENSION(jp_medusa_trd) :: meddiabio
+ CHARACTER(LEN=32) :: clname
+ !!
+ NAMELIST/nammeddia/ meddia3d, meddia2d ! additional diagnostics
+
+ !!----------------------------------------------------------------------
+
+ IF(lwp) WRITE(numout,*)
+ clname = 'namelist_medusa'
+ IF(lwp) WRITE(numout,*) ' trc_nam_medusa: read MEDUSA namelist'
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~'
+# if defined key_debug_medusa
+ CALL flush(numout)
+# endif
+
+
+ CALL ctl_opn( numnatp_ref, TRIM( clname )//'_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
+ CALL ctl_opn( numnatp_cfg, TRIM( clname )//'_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
+ IF(lwm) CALL ctl_opn( numonp , 'output.namelist.pis' , 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
+
+# if defined key_debug_medusa
+ CALL flush(numout)
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) 'open namelist_medusa -- OK'
+ IF (lwp) write (numout,*) 'Now, read namilists inside :'
+ IF (lwp) write (numout,*) ' '
+# endif
+ !
+# if defined key_debug_medusa
+ CALL flush(numout)
+# endif
+ !
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) 'Just before reading namelist_medusa :: nammeddia'
+ IF (lwp) write (numout,*) ' '
+ CALL flush(numout)
+# endif
+
+ IF( ( .NOT.lk_iomput .AND. ln_diatrc ) .OR. ( ln_diatrc .AND. lk_medusa ) ) THEN
+ !
+ ! Namelist nammeddia
+ ! -------------------
+ REWIND( numnatp_ref ) ! Namelist nammeddia in reference namelist : MEDUSA diagnostics
+ READ ( numnatp_ref, nammeddia, IOSTAT = ios, ERR = 901)
+901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammeddia in reference namelist', lwp )
+
+ REWIND( numnatp_cfg ) ! Namelist nammeddia in configuration namelist : MEDUSA diagnostics
+ READ ( numnatp_cfg, nammeddia, IOSTAT = ios, ERR = 902 )
+902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammeddia in configuration namelist', lwp )
+ IF(lwm) WRITE ( numonp, nammeddia )
+
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) 'reading namelist_medusa :: nammeddia OK'
+ IF (lwp) write (numout,*) 'Check number of variable in nammeddia:'
+ IF (lwp) write (numout,*) 'jp_medusa_2d: ',jp_medusa_2d ,'jp_medusa_3d: ',jp_medusa_3d
+ IF (lwp) write (numout,*) ' '
+ CALL flush(numout)
+# endif
+ DO jl = 1, jp_medusa_2d
+ jn = jp_msa0_2d + jl - 1
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'Check what is readden in nammeddia: -- 2D'
+ IF (lwp) write (numout,*) jl,'meddia2d-sname: ',meddia2d(jl)%sname
+ IF (lwp) write (numout,*) jl,'meddia2d-lname: ',meddia2d(jl)%lname
+ IF (lwp) write (numout,*) jl,'meddia2d-units: ',meddia2d(jl)%units
+ CALL flush(numout)
+# endif
+ ctrc2d(jn) = meddia2d(jl)%sname
+ ctrc2l(jn) = meddia2d(jl)%lname
+ ctrc2u(jn) = meddia2d(jl)%units
+ END DO
+
+ DO jl = 1, jp_medusa_3d
+ jn = jp_msa0_3d + jl - 1
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) 'Check what is readden in nammeddia: -- 3D'
+ IF (lwp) write (numout,*) jl,'meddia3d-sname: ',meddia3d(jl)%sname
+ IF (lwp) write (numout,*) jl,'meddia3d-lname: ',meddia3d(jl)%lname
+ IF (lwp) write (numout,*) jl,'meddia3d-units: ',meddia3d(jl)%units
+ CALL flush(numout)
+# endif
+ ctrc3d(jn) = meddia3d(jl)%sname
+ ctrc3l(jn) = meddia3d(jl)%lname
+ ctrc3u(jn) = meddia3d(jl)%units
+ END DO
+
+ IF(lwp) THEN ! control print
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) 'Var name assignation OK'
+ IF (lwp) write (numout,*) 'next check var names'
+ IF (lwp) write (numout,*) ' '
+ CALL flush(numout)
+# endif
+ WRITE(numout,*)
+ WRITE(numout,*) ' Namelist : natadd'
+ DO jl = 1, jp_medusa_3d
+ jn = jp_msa0_3d + jl - 1
+ WRITE(numout,*) ' 3d diag nb : ', jn, ' short name : ', ctrc3d(jn), &
+ & ' long name : ', ctrc3l(jn), ' unit : ', ctrc3u(jn)
+ END DO
+ WRITE(numout,*) ' '
+
+ DO jl = 1, jp_medusa_2d
+ jn = jp_msa0_2d + jl - 1
+ WRITE(numout,*) ' 2d diag nb : ', jn, ' short name : ', ctrc2d(jn), &
+ & ' long name : ', ctrc2l(jn), ' unit : ', ctrc2u(jn)
+ END DO
+ WRITE(numout,*) ' '
+ ENDIF
+ !
+ ENDIF
+ !
+# if defined key_debug_medusa
+ CALL flush(numout)
+# endif
+
+ ! 1.4 namelist natbio : biological parameters
+ ! -------------------------------------------
+
+ xxi = 0.
+ xaln = 0.
+ xald = 0.
+ jphy = 0
+ xvpn = 0.
+ xvpd = 0.
+ xthetam = 0.
+ xthetamd = 0.
+!!
+ xsin0 = 0.
+ xnsi0 = 0.
+ xuif = 0.
+!!
+ jliebig = 0
+ jq10 = 0.
+ xnln = 0.
+ xnld = 0.
+ xsld = 0.
+ xfln = 0.
+ xfld = 0.
+!!
+ xgmi = 0.
+ xgme = 0.
+ xkmi = 0.
+ xkme = 0.
+ xphi = 0.
+ xbetan = 0.
+ xbetac = 0.
+ xkc = 0.
+ xpmipn = 0.
+ xpmid = 0.
+ xpmepn = 0.
+ xpmepd = 0.
+ xpmezmi = 0.
+ xpmed = 0.
+!!
+ xmetapn = 0.
+ xmetapd = 0.
+ xmetazmi = 0.
+ xmetazme = 0.
+!!
+ jmpn = 0
+ xmpn = 0.
+ xkphn = 0.
+ jmpd = 0
+ xmpd = 0.
+ xkphd = 0.
+ jmzmi = 0
+ xmzmi = 0.
+ xkzmi = 0.
+ jmzme = 0
+ xmzme = 0.
+ xkzme = 0.
+!!
+ jmd = 0
+ jsfd = 0
+ xmd = 0.
+ xmdc = 0.
+!!
+ xthetapn = 0.
+ xthetapd = 0.
+ xthetazmi = 0.
+ xthetazme = 0.
+ xthetad = 0.
+ xrfn = 0.
+ xrsn = 0. !: (NOT USED HERE; RETAINED FOR LOBSTER)
+!!
+ jiron = 0
+ xfe_mass = 0.
+ xfe_sol = 0.
+ xfe_sed = 0.
+ xLgT = 0.
+ xk_FeL = 0.
+ xk_sc_Fe = 0.
+!!
+ jexport = 0
+ jfdfate = 0
+ jrratio = 0
+ jocalccd = 0
+ xridg_r0 = 0.
+ xfdfrac1 = 0.
+ xfdfrac2 = 0.
+ xfdfrac3 = 0.
+ xcaco3a = 0.
+ xcaco3b = 0.
+ xmassc = 0.
+ xmassca = 0.
+ xmasssi = 0.
+ xprotca = 0.
+ xprotsi = 0.
+ xfastc = 0.
+ xfastca = 0.
+ xfastsi = 0.
+!!
+ jorgben = 0
+ jinorgben = 0
+ xsedn = 0.
+ xsedfe = 0.
+ xsedsi = 0.
+ xsedc = 0.
+ xsedca = 0.
+ xburial = 0.
+!!
+ jriver_n = 0
+ jriver_si = 0
+ jriver_c = 0
+ jriver_alk = 0
+ jriver_dep = 1
+!!
+ xsdiss = 0.
+!!
+ vsed = 0.
+ xhr = 0.
+!!
+ sedlam = 0.
+ sedlostpoc = 0.
+ jpkb = 0.
+ jdms = 0
+ jdms_input = 0
+ jdms_model = 0
+
+ !REWIND(numnatm)
+ !READ(numnatm,natbio)
+ ! Namelist natbio
+ ! -------------------
+ REWIND( numnatp_ref ) ! Namelist natbio in reference namelist : MEDUSA diagnostics
+ READ ( numnatp_ref, natbio, IOSTAT = ios, ERR = 903)
+903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'natbio in reference namelist', lwp )
+
+ REWIND( numnatp_cfg ) ! Namelist natbio in configuration namelist : MEDUSA diagnostics
+ READ ( numnatp_cfg, natbio, IOSTAT = ios, ERR = 904 )
+904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'natbio in configuration namelist', lwp )
+ IF(lwm) WRITE ( numonp, natbio )
+
+!! Primary production and chl related quantities
+!! xxi : conversion factor from gC to mmolN
+!! xaln : Chl-a specific initial slope of P-I curve for non-diatoms
+!! xald : Chl-a specific initial slope of P-I curve for diatoms
+!! jphy : phytoplankton T-dependent growth switch
+!! xvpn : maximum growth rate for non-diatoms
+!! xvpd : maximum growth rate for diatoms
+!! xthetam : maximum Chl to C ratio for non-diatoms
+!! xthetamd : maximum Chl to C ratio for diatoms
+!!
+!! Diatom silicon parameters
+!! xsin0 : minimum diatom Si:N ratio
+!! xnsi0 : minimum diatom N:Si ratio
+!! xuif : hypothetical growth ratio at infinite Si:N ratio
+!!
+!! Nutrient limitation
+!! jliebig : Liebig nutrient uptake switch
+!! xnln : half-sat constant for DIN uptake by non-diatoms
+!! xnld : half-sat constant for DIN uptake by diatoms
+!! xsl : half-sat constant for Si uptake by diatoms
+!! xfld : half-sat constant for Fe uptake by diatoms
+!! xfln : half-sat constant for Fe uptake by non-datoms
+!!
+!! Grazing
+!! xgmi : microzoo maximum growth rate
+!! xgme : mesozoo maximum growth rate
+!! xkmi : microzoo grazing half-sat parameter
+!! xkme : mesozoo grazing half-sat parameter
+!! xphi : micro/mesozoo grazing inefficiency
+!! xbetan : micro/mesozoo N assimilation efficiency
+!! xbetac : micro/mesozoo C assimilation efficiency
+!! xkc : micro/mesozoo net C growth efficiency
+!! xpmipn : grazing preference of microzoo for non-diatoms
+!! xpmid : grazing preference of microzoo for diatoms
+!! xpmepn : grazing preference of mesozoo for non-diatoms
+!! xpmepd : grazing preference of mesozoo for diatoms
+!! xpmezmi : grazing preference of mesozoo for microzoo
+!! xpmed : grazing preference of mesozoo for detritus
+!!
+!! Metabolic losses
+!! xmetapn : non-diatom metabolic loss rate
+!! xmetapd : diatom metabolic loss rate
+!! xmetazmi : microzoo metabolic loss rate
+!! xmetazme : mesozoo metabolic loss rate
+!!
+!! Mortality/Remineralisation
+!! jmpn : non-diatom mortality functional form
+!! xmpn : non-diatom mortality rate
+!! xkphn : non-diatom mortality half-sat constant
+!! jmpd : diatom mortality functional form
+!! xmpd : diatom mortality rate
+!! xkphd : diatom mortality half-sat constant
+!! jmzmi : microzoo mortality functional form
+!! xmzmi : microzoo mortality rate
+!! xkzmi : microzoo mortality half-sat constant
+!! jmzme : mesozoo mortality functional form
+!! xmzme : mesozoo mortality rate
+!! xkzme : mesozoo mortality half-sat constant
+!!
+!! Remineralisation
+!! jmd : detritus T-dependent remineralisation switch
+!! jsfd : accelerate seafloor detritus remin. switch
+!! xmd : detrital nitrogen remineralisation rate
+!! xmdc : detrital carbon remineralisation rate
+!!
+!! Stochiometric ratios
+!! xthetapn : non-diatom C:N ratio
+!! xthetapd : diatom C:N ratio
+!! xthetazmi : microzoo C:N ratio
+!! xthetazme : mesozoo C:N ratio
+!! xthetad : detritus C:N ratio
+!! xrfn : phytoplankton Fe:N ratio
+!! xrsn : diatom Si:N ratio (*NOT* used)
+!!
+!! Iron parameters
+!! jiron : iron scavenging submodel switch
+!! xfe_mass : iron atomic mass
+!! xfe_sol : aeolian iron solubility
+!! xfe_sed : sediment iron input
+!! xLgT : total ligand concentration (umol/m3)
+!! xk_FeL : dissociation constant for (Fe + L)
+!! xk_sc_Fe : scavenging rate of "free" iron
+!!
+!! Fast-sinking detritus parameters
+!! jexport : fast detritus remineralisation switch
+!! jfdfate : fate of fast detritus at seafloor switch
+!! jrratio : rain ratio switch
+!! jocalccd : CCD switch
+!! xridg_r0 : Ridgwell rain ratio coefficient
+!! xfdfrac1 : fast-sinking fraction of diatom nat. mort. losses
+!! xfdfrac2 : fast-sinking fraction of meszooplankton mort. losses
+!! xfdfrac3 : fast-sinking fraction of diatom silicon grazing losses
+!! xcaco3a : polar (high latitude) CaCO3 fraction
+!! xcaco3b : equatorial (low latitude) CaCO3 fraction
+!! xmassc : organic C mass:mole ratio, C106 H175 O40 N16 P1
+!! xmassca : calcium carbonate mass:mole ratio, CaCO3
+!! xmasssi : biogenic silicon mass:mole ratio, (H2SiO3)n
+!! xprotca : calcium carbonate protection ratio
+!! xprotsi : biogenic silicon protection ratio
+!! xfastc : organic C remineralisation length scale
+!! xfastca : calcium carbonate dissolution length scale
+!! xfastsi : biogenic silicon dissolution length scale
+!!
+!! Benthic
+!! jorgben : does organic detritus go to the benthos?
+!! jinorgben : does inorganic detritus go to the benthos?
+!! xsedn : organic nitrogen sediment remineralisation rate
+!! xsedfe : organic iron sediment remineralisation rate
+!! xsedsi : inorganic silicon sediment dissolution rate
+!! xsedc : organic carbon sediment remineralisation rate
+!! xsedca : inorganic carbon sediment dissolution rate
+!! xburial : burial rate of seafloor detritus
+!!
+!! Riverine inputs
+!! jriver_n : riverine N input?
+!! jriver_si : riverine Si input?
+!! jriver_c : riverine C input?
+!! jriver_alk : riverine alkalinity input?
+!! jriver_dep : depth of riverine input?
+!!
+!! Miscellaneous
+!! xsdiss : diatom frustule dissolution rate
+!!
+!! Gravitational sinking
+!! vsed : detritus gravitational sinking rate
+!! xhr : coeff for Martin's remineralisation profile
+!!
+!! Additional parameters
+!! sedlam : time coeff of POC in sediments
+!! sedlostpoc : sediment geol loss for POC
+!! jpkb : vertical layer for diagnostic of the vertical flux
+!! NOTE that in LOBSTER it is a first vertical layers where
+!! biology is active
+!!
+!! UKESM1 - new diagnostics !! Jpalm
+!! jdms : include dms diagnostics
+!! jdms_input : use instant (0) or diel-avg (1) inputs
+!! jdms_model : choice of DMS model passed to atmosphere
+!! 1 = ANDR, 2 = SIMO, 3 = ARAN, 4 = HALL, 5 = ANDM
+!!
+ IF(lwp) THEN
+!!
+!! AXY (08/11/13): compilation key notification
+ WRITE(numout,*) '=== Compilation keys'
+#if defined key_roam
+ WRITE(numout,*) &
+ & ' key_roam = ACTIVE'
+#else
+ WRITE(numout,*) &
+ & ' key_roam = INACTIVE'
+#endif
+#if defined key_axy_carbchem
+ WRITE(numout,*) &
+ & ' key_axy_carbchem = ACTIVE'
+#else
+ WRITE(numout,*) &
+ & ' key_axy_carbchem = INACTIVE'
+#endif
+#if defined key_mocsy
+ WRITE(numout,*) &
+ & ' key_mocsy = ACTIVE'
+#else
+ WRITE(numout,*) &
+ & ' key_mocsy = INACTIVE'
+#endif
+#if defined key_avgqsr_medusa
+ WRITE(numout,*) &
+ & ' key_avgqsr_medusa = ACTIVE'
+#else
+ WRITE(numout,*) &
+ & ' key_avgqsr_medusa = INACTIVE'
+#endif
+#if defined key_bs_axy_zforce
+ WRITE(numout,*) &
+ & ' key_bs_axy_zforce = ACTIVE'
+#else
+ WRITE(numout,*) &
+ & ' key_bs_axy_zforce = INACTIVE'
+#endif
+#if defined key_bs_axy_yrlen
+ WRITE(numout,*) &
+ & ' key_bs_axy_yrlen = ACTIVE'
+#else
+ WRITE(numout,*) &
+ & ' key_bs_axy_yrlen = INACTIVE'
+#endif
+#if defined key_deep_fe_fix
+ WRITE(numout,*) &
+ & ' key_deep_fe_fix = ACTIVE'
+#else
+ WRITE(numout,*) &
+ & ' key_deep_fe_fix = INACTIVE'
+#endif
+#if defined key_axy_nancheck
+ WRITE(numout,*) &
+ & ' key_axy_nancheck = ACTIVE'
+#else
+ WRITE(numout,*) &
+ & ' key_axy_nancheck = INACTIVE'
+#endif
+# if defined key_axy_pi_co2
+ WRITE(numout,*) &
+ & ' key_axy_pi_co2 = ACTIVE'
+#else
+ WRITE(numout,*) &
+ & ' key_axy_pi_co2 = INACTIVE'
+# endif
+# if defined key_debug_medusa
+ WRITE(numout,*) &
+ & ' key_debug_medusa = ACTIVE'
+#else
+ WRITE(numout,*) &
+ & ' key_debug_medusa = INACTIVE'
+# endif
+ WRITE(numout,*) ' '
+
+ WRITE(numout,*) 'natbio'
+ WRITE(numout,*) ' '
+!!
+!! Primary production and chl related quantities
+ WRITE(numout,*) '=== Primary production'
+ WRITE(numout,*) &
+ & ' conversion factor from gC to mmolN, xxi =', xxi
+ WRITE(numout,*) &
+ & ' Chl-a specific initial slope of P-I curve for non-diatoms, xaln = ', xaln
+ WRITE(numout,*) &
+ & ' Chl-a specific initial slope of P-I curve for diatoms, xald = ', xald
+ if (jphy.eq.1) then
+ WRITE(numout,*) &
+ & ' phytoplankton growth is *temperature-dependent* jphy = ', jphy
+ elseif (jphy.eq.2) then
+ WRITE(numout,*) &
+ & ' phytoplankton growth is *temperature-dependent(Q10)* jphy = ', jphy
+ elseif (jphy.eq.0) then
+ WRITE(numout,*) &
+ & ' phytoplankton growth is *temperature-independent* jphy = ', jphy
+ endif
+ WRITE(numout,*) &
+ & ' maximum growth rate for non-diatoms, xvpn = ', xvpn
+ WRITE(numout,*) &
+ & ' maximum growth rate for diatoms, xvpn = ', xvpd
+ WRITE(numout,*) &
+ & ' maximum Chl to C ratio for non-diatoms, xthetam = ', xthetam
+ WRITE(numout,*) &
+ & ' maximum Chl to C ratio for diatoms, xthetamd = ', xthetamd
+ WRITE(numout,*) &
+ & ' specific Q10 value (jphy==2), jq10 = ', jq10
+!!
+!! Diatom silicon parameters
+ WRITE(numout,*) '=== Diatom silicon parameters'
+ WRITE(numout,*) &
+ & ' minimum diatom Si:N ratio, xsin0 = ', xsin0
+ WRITE(numout,*) &
+ & ' minimum diatom N:Si ratio, xnsi0 = ', xnsi0
+ WRITE(numout,*) &
+ & ' hypothetical growth ratio at infinite Si:N ratio, xuif = ', xuif
+!!
+!! Nutrient limitation
+ WRITE(numout,*) '=== Nutrient limitation'
+ if (jliebig.eq.1) then
+ WRITE(numout,*) &
+ & ' nutrient uptake is a Liebig Law (= most limiting) function jliebig = ', jliebig
+ elseif (jliebig.eq.0) then
+ WRITE(numout,*) &
+ & ' nutrient uptake is a multiplicative function jliebig = ', jliebig
+ endif
+ WRITE(numout,*) &
+ & ' half-sat constant for DIN uptake by non-diatoms, xnln = ', xnln
+ WRITE(numout,*) &
+ & ' half-sat constant for DIN uptake by diatoms, xnld = ', xnld
+ WRITE(numout,*) &
+ & ' half-sat constant for Si uptake by diatoms, xsld = ', xsld
+ WRITE(numout,*) &
+ & ' half-sat constant for Fe uptake by non-diatoms, xfln = ', xfln
+ WRITE(numout,*) &
+ & ' half-sat constant for Fe uptake by diatoms, xfld = ', xfld
+!!
+!! Grazing
+ WRITE(numout,*) '=== Zooplankton grazing'
+ WRITE(numout,*) &
+ & ' microzoo maximum growth rate, xgmi = ', xgmi
+ WRITE(numout,*) &
+ & ' mesozoo maximum growth rate, xgme = ', xgme
+ WRITE(numout,*) &
+ & ' microzoo grazing half-sat parameter, xkmi = ', xkmi
+ WRITE(numout,*) &
+ & ' mesozoo grazing half-sat parameter, xkme = ', xkme
+ WRITE(numout,*) &
+ & ' micro/mesozoo grazing inefficiency, xphi = ', xphi
+ WRITE(numout,*) &
+ & ' micro/mesozoo N assimilation efficiency, xbetan = ', xbetan
+ WRITE(numout,*) &
+ & ' micro/mesozoo C assimilation efficiency, xbetac = ', xbetan
+ WRITE(numout,*) &
+ & ' micro/mesozoo net C growth efficiency, xkc = ', xkc
+ WRITE(numout,*) &
+ & ' grazing preference of microzoo for non-diatoms, xpmipn = ', xpmipn
+ WRITE(numout,*) &
+ & ' grazing preference of microzoo for detritus, xpmid = ', xpmid
+ WRITE(numout,*) &
+ & ' grazing preference of mesozoo for non-diatoms, xpmepn = ', xpmepn
+ WRITE(numout,*) &
+ & ' grazing preference of mesozoo for diatoms, xpmepd = ', xpmepd
+ WRITE(numout,*) &
+ & ' grazing preference of mesozoo for microzoo, xpmezmi = ', xpmezmi
+ WRITE(numout,*) &
+ & ' grazing preference of mesozoo for detritus, xpmed = ', xpmed
+!!
+!! Metabolic losses
+ WRITE(numout,*) '=== Metabolic losses'
+ WRITE(numout,*) &
+ & ' non-diatom metabolic loss rate, xmetapn = ', xmetapn
+ WRITE(numout,*) &
+ & ' diatom metabolic loss rate, xmetapd = ', xmetapd
+ WRITE(numout,*) &
+ & ' microzoo metabolic loss rate, xmetazmi = ', xmetazmi
+ WRITE(numout,*) &
+ & ' mesozoo metabolic loss rate, xmetazme = ', xmetazme
+!!
+!! Mortality losses
+ WRITE(numout,*) '=== Mortality losses'
+ if (jmpn.eq.1) then
+ WRITE(numout,*) &
+ & ' non-diatom mortality functional form, LINEAR jmpn = ', jmpn
+ elseif (jmpn.eq.2) then
+ WRITE(numout,*) &
+ & ' non-diatom mortality functional form, QUADRATIC jmpn = ', jmpn
+ elseif (jmpn.eq.3) then
+ WRITE(numout,*) &
+ & ' non-diatom mortality functional form, HYPERBOLIC jmpn = ', jmpn
+ elseif (jmpn.eq.4) then
+ WRITE(numout,*) &
+ & ' non-diatom mortality functional form, SIGMOID jmpn = ', jmpn
+ endif
+ WRITE(numout,*) &
+ & ' non-diatom mortality rate, xmpn = ', xmpn
+ WRITE(numout,*) &
+ & ' non-diatom mortality half-sat constant xkphn = ', xkphn
+ if (jmpd.eq.1) then
+ WRITE(numout,*) &
+ & ' diatom mortality functional form, LINEAR jmpd = ', jmpd
+ elseif (jmpd.eq.2) then
+ WRITE(numout,*) &
+ & ' diatom mortality functional form, QUADRATIC jmpd = ', jmpd
+ elseif (jmpd.eq.3) then
+ WRITE(numout,*) &
+ & ' diatom mortality functional form, HYPERBOLIC jmpd = ', jmpd
+ elseif (jmpd.eq.4) then
+ WRITE(numout,*) &
+ & ' diatom mortality functional form, SIGMOID jmpd = ', jmpd
+ endif
+ WRITE(numout,*) &
+ & ' diatom mortality rate, xmpd = ', xmpd
+ WRITE(numout,*) &
+ & ' diatom mortality half-sat constant xkphd = ', xkphd
+ if (jmzmi.eq.1) then
+ WRITE(numout,*) &
+ & ' microzoo mortality functional form, LINEAR jmzmi = ', jmzmi
+ elseif (jmzmi.eq.2) then
+ WRITE(numout,*) &
+ & ' microzoo mortality functional form, QUADRATIC jmzmi = ', jmzmi
+ elseif (jmzmi.eq.3) then
+ WRITE(numout,*) &
+ & ' microzoo mortality functional form, HYPERBOLIC jmzmi = ', jmzmi
+ elseif (jmzmi.eq.4) then
+ WRITE(numout,*) &
+ & ' microzoo mortality functional form, SIGMOID jmzmi = ', jmzmi
+ endif
+ WRITE(numout,*) &
+ & ' microzoo mortality rate, xmzmi = ', xmzmi
+ WRITE(numout,*) &
+ & ' mesozoo mortality half-sat constant, xkzmi = ', xkzmi
+ if (jmzme.eq.1) then
+ WRITE(numout,*) &
+ & ' mesozoo mortality functional form, LINEAR jmzme = ', jmzme
+ elseif (jmzme.eq.2) then
+ WRITE(numout,*) &
+ & ' mesozoo mortality functional form, QUADRATIC jmzme = ', jmzme
+ elseif (jmzme.eq.3) then
+ WRITE(numout,*) &
+ & ' mesozoo mortality functional form, HYPERBOLIC jmzme = ', jmzme
+ elseif (jmzme.eq.4) then
+ WRITE(numout,*) &
+ & ' mesozoo mortality functional form, SIGMOID jmzme = ', jmzme
+ endif
+ WRITE(numout,*) &
+ & ' mesozoo mortality rate, xmzme = ', xmzme
+ WRITE(numout,*) &
+ & ' mesozoo mortality half-sat constant, xkzme = ', xkzme
+!!
+!! Remineralisation
+ WRITE(numout,*) '=== Remineralisation'
+ if (jmd.eq.1) then
+ WRITE(numout,*) &
+ & ' detritus remineralisation is *temperature-dependent* jmd = ', jmd
+ elseif (jmd.eq.2) then
+ WRITE(numout,*) &
+ & ' detritus remineralisation is *temperature-dependent(Q10)* jmd = ', jmd
+ elseif (jmd.eq.0) then
+ WRITE(numout,*) &
+ & ' detritus remineralisation is *temperature-independent* jmd = ', jmd
+ endif
+ if (jsfd.eq.1) then
+ WRITE(numout,*) &
+ & ' detritus seafloor remineralisation is *accelerated* jsfd = ', jsfd
+ else
+ WRITE(numout,*) &
+ & ' detritus seafloor remineralisation occurs at same rate jsfd = ', jsfd
+ endif
+ WRITE(numout,*) &
+ & ' detrital nitrogen remineralisation rate, xmd = ', xmd
+ WRITE(numout,*) &
+ & ' detrital carbon remineralisation rate, xmdc = ', xmdc
+!!
+!! Stochiometric ratios
+ WRITE(numout,*) '=== Stoichiometric ratios'
+ WRITE(numout,*) &
+ & ' non-diatom C:N ratio, xthetapn = ', xthetapn
+ WRITE(numout,*) &
+ & ' diatom C:N ratio, xthetapd = ', xthetapd
+ WRITE(numout,*) &
+ & ' microzoo C:N ratio, xthetazmi = ', xthetazmi
+ WRITE(numout,*) &
+ & ' mesozoo C:N ratio, xthetazme = ', xthetazme
+ WRITE(numout,*) &
+ & ' detritus C:N ratio, xthetad = ', xthetad
+ WRITE(numout,*) &
+ & ' phytoplankton Fe:N ratio, xrfn = ', xrfn
+ WRITE(numout,*) &
+ & ' diatom Si:N ratio, xrsn = ', xrsn
+!!
+!! Iron parameters
+ WRITE(numout,*) '=== Iron parameters'
+ if (jiron.eq.1) then
+ WRITE(numout,*) &
+ & ' Dutkiewicz et al. (2005) iron scavenging jiron = ', jiron
+ elseif (jiron.eq.2) then
+ WRITE(numout,*) &
+ & ' Moore et al. (2004) iron scavenging jiron = ', jiron
+ elseif (jiron.eq.3) then
+ WRITE(numout,*) &
+ & ' Moore et al. (2008) iron scavenging jiron = ', jiron
+ elseif (jiron.eq.4) then
+ WRITE(numout,*) &
+ & ' Galbraith et al. (2010) iron scavenging jiron = ', jiron
+ else
+ WRITE(numout,*) &
+ & ' There is **no** iron scavenging jiron = ', jiron
+ endif
+ WRITE(numout,*) &
+ & ' iron atomic mass, xfe_mass = ', xfe_mass
+ WRITE(numout,*) &
+ & ' aeolian iron solubility, xfe_sol = ', xfe_sol
+ WRITE(numout,*) &
+ & ' sediment iron input, xfe_sed = ', xfe_sed
+ WRITE(numout,*) &
+ & ' total ligand concentration (umol/m3), xLgT = ', xLgT
+ WRITE(numout,*) &
+ & ' dissociation constant for (Fe + L), xk_FeL = ', xk_FeL
+ WRITE(numout,*) &
+ & ' scavenging rate for free iron, xk_sc_Fe = ', xk_sc_Fe
+!!
+!! Fast-sinking detritus parameters
+ WRITE(numout,*) '=== Fast-sinking detritus'
+ if (jexport.eq.1) then
+ WRITE(numout,*) &
+ & ' fast-detritus remin. uses Dunne et al. (2007; ballast) jexport = ', jexport
+ elseif (jexport.eq.2) then
+ WRITE(numout,*) &
+ & ' fast-detritus remin. uses Martin et al. (1987) jexport = ', jexport
+ elseif (jexport.eq.2) then
+ WRITE(numout,*) &
+ & ' fast-detritus remin. uses Henson et al. (2011) jexport = ', jexport
+ endif
+ if (jfdfate.eq.1) then
+ WRITE(numout,*) &
+ & ' fast-detritus reaching seafloor becomes slow-detritus jfdfate = ', jfdfate
+ elseif (jfdfate.eq.0) then
+ WRITE(numout,*) &
+ & ' fast-detritus reaching seafloor instantly remineralised jfdfate = ', jfdfate
+ endif
+#if defined key_roam
+ if (jrratio.eq.0) then
+ WRITE(numout,*) &
+ & ' Dunne et al. (2005) rain ratio submodel jrratio = ', jrratio
+ elseif (jrratio.eq.1) then
+ WRITE(numout,*) &
+ & ' Ridgwell et al. (2007) rain ratio submodel (surface omega) jrratio = ', jrratio
+ elseif (jrratio.eq.2) then
+ WRITE(numout,*) &
+ & ' Ridgwell et al. (2007) rain ratio submodel (3D omega) jrratio = ', jrratio
+ endif
+#else
+ jrratio = 0
+ WRITE(numout,*) &
+ & ' Dunne et al. (2005) rain ratio submodel jrratio = ', jrratio
+#endif
+#if defined key_roam
+ if (jocalccd.eq.0) then
+ WRITE(numout,*) &
+ & ' Default, fixed CCD used jocalccd = ', jocalccd
+ elseif (jocalccd.eq.1) then
+ WRITE(numout,*) &
+ & ' Calculated, dynamic CCD used jocalccd = ', jocalccd
+ endif
+#else
+ jocalccd = 0
+ WRITE(numout,*) &
+ & ' Default, fixed CCD used jocalccd = ', jocalccd
+#endif
+ WRITE(numout,*) &
+ & ' Ridgwell rain ratio coefficient, xridg_r0 = ', xridg_r0
+ WRITE(numout,*) &
+ & ' fast-sinking fraction of diatom nat. mort. losses, xfdfrac1 = ', xfdfrac1
+ WRITE(numout,*) &
+ & ' fast-sinking fraction of mesozooplankton mort. losses, xfdfrac2 = ', xfdfrac2
+ WRITE(numout,*) &
+ & ' fast-sinking fraction of diatom silicon grazing losses, xfdfrac3 = ', xfdfrac3
+ WRITE(numout,*) &
+ & ' polar (high latitude) CaCO3 fraction, xcaco3a = ', xcaco3a
+ WRITE(numout,*) &
+ & ' equatorial (low latitude) CaCO3 fraction, xcaco3b = ', xcaco3b
+ WRITE(numout,*) &
+ & ' organic C mass:mole ratio, C106 H175 O40 N16 P1, xmassc = ', xmassc
+ WRITE(numout,*) &
+ & ' calcium carbonate mass:mole ratio, CaCO3, xmassca = ', xmassca
+ WRITE(numout,*) &
+ & ' biogenic silicon mass:mole ratio, (H2SiO3)n, xmasssi = ', xmasssi
+ WRITE(numout,*) &
+ & ' calcium carbonate protection ratio, xprotca = ', xprotca
+ WRITE(numout,*) &
+ & ' biogenic silicon protection ratio, xprotsi = ', xprotsi
+ WRITE(numout,*) &
+ & ' organic C remineralisation length scale, xfastc = ', xfastc
+ WRITE(numout,*) &
+ & ' calcium carbonate dissolution length scale, xfastca = ', xfastca
+ WRITE(numout,*) &
+ & ' biogenic silicon dissolution length scale, xfastsi = ', xfastsi
+!!
+!! Benthos parameters
+ WRITE(numout,*) '=== Benthos parameters'
+ WRITE(numout,*) &
+ & ' does organic detritus go to the benthos?, jorgben = ', jorgben
+ WRITE(numout,*) &
+ & ' does inorganic detritus go to the benthos?, jinorgben = ', jinorgben
+!!
+!! Some checks on parameters related to benthos parameters
+ if (jorgben.eq.1 .and. jsfd.eq.1) then
+ !! slow detritus going to benthos at an accelerated rate
+ WRITE(numout,*) ' === WARNING! ==='
+ WRITE(numout,*) ' jsfd *and* jorgben are active - please check that you wish this'
+ WRITE(numout,*) ' === WARNING! ==='
+ endif
+ if (jorgben.eq.1 .and. jfdfate.eq.1) then
+ !! fast detritus going to benthos but via slow detritus
+ WRITE(numout,*) ' === WARNING! ==='
+ WRITE(numout,*) ' jfdfate *and* jorgben are active - please check that you wish this'
+ WRITE(numout,*) ' === WARNING! ==='
+ endif
+ if (jorgben.eq.0 .and. jinorgben.eq.1) then
+ !! inorganic fast detritus going to benthos but organic fast detritus is not
+ WRITE(numout,*) ' === WARNING! ==='
+ WRITE(numout,*) ' jinorgben is active but jorgben is not - please check that you wish this'
+ WRITE(numout,*) ' === WARNING! ==='
+ endif
+ WRITE(numout,*) &
+ & ' organic nitrogen sediment remineralisation rate, xsedn = ', xsedn
+ WRITE(numout,*) &
+ & ' organic iron sediment remineralisation rate, xsedfe = ', xsedfe
+ WRITE(numout,*) &
+ & ' inorganic silicon sediment remineralisation rate, xsedsi = ', xsedsi
+ WRITE(numout,*) &
+ & ' organic carbon sediment remineralisation rate, xsedc = ', xsedc
+ WRITE(numout,*) &
+ & ' inorganic carbon sediment remineralisation rate, xsedca = ', xsedca
+ WRITE(numout,*) &
+ & ' burial rate of seafloor detritus, xburial = ', xburial
+!!
+!! Riverine inputs
+ WRITE(numout,*) '=== Riverine inputs'
+ if (jriver_n.eq.0) then
+ WRITE(numout,*) &
+ & ' *no* riverine N input, jriver_n = ', jriver_n
+ elseif (jriver_n.eq.1) then
+ WRITE(numout,*) &
+ & ' riverine N concentrations specified, jriver_n = ', jriver_n
+ elseif (jriver_n.eq.2) then
+ WRITE(numout,*) &
+ & ' riverine N inputs specified, jriver_n = ', jriver_n
+ endif
+ if (jriver_si.eq.0) then
+ WRITE(numout,*) &
+ & ' *no* riverine Si input, jriver_si = ', jriver_si
+ elseif (jriver_si.eq.1) then
+ WRITE(numout,*) &
+ & ' riverine Si concentrations specified, jriver_si = ', jriver_si
+ elseif (jriver_si.eq.2) then
+ WRITE(numout,*) &
+ & ' riverine Si inputs specified, jriver_si = ', jriver_si
+ endif
+ if (jriver_c.eq.0) then
+ WRITE(numout,*) &
+ & ' *no* riverine C input, jriver_c = ', jriver_c
+ elseif (jriver_c.eq.1) then
+ WRITE(numout,*) &
+ & ' riverine C concentrations specified, jriver_c = ', jriver_c
+ elseif (jriver_c.eq.2) then
+ WRITE(numout,*) &
+ & ' riverine C inputs specified, jriver_c = ', jriver_c
+ endif
+ if (jriver_alk.eq.0) then
+ WRITE(numout,*) &
+ & ' *no* riverine alkalinity input, jriver_alk = ', jriver_alk
+ elseif (jriver_alk.eq.1) then
+ WRITE(numout,*) &
+ & ' riverine alkalinity concentrations specified, jriver_alk = ', jriver_alk
+ elseif (jriver_alk.eq.2) then
+ WRITE(numout,*) &
+ & ' riverine alkalinity inputs specified, jriver_alk = ', jriver_alk
+ endif
+ !! AXY (19/07/12): prevent (gross) stupidity on part of user
+ if (jriver_dep.lt.1.or.jriver_dep.ge.jpk) then
+ jriver_dep = 1
+ endif
+ WRITE(numout,*) &
+ & ' riverine input applied to down to depth k = ... jriver_dep = ', jriver_dep
+!!
+!! Miscellaneous
+ WRITE(numout,*) '=== Miscellaneous'
+ WRITE(numout,*) &
+ & ' diatom frustule dissolution rate, xsdiss = ', xsdiss
+!!
+!! Gravitational sinking
+ WRITE(numout,*) '=== Gravitational sinking'
+ WRITE(numout,*) &
+ & ' detritus gravitational sinking rate, vsed = ', vsed
+ WRITE(numout,*) &
+ & ' coefficient for Martin et al. (1987) remineralisation, xhr = ', xhr
+!!
+!! Non-Medusa parameters
+ WRITE(numout,*) '=== Non-Medusa parameters'
+ WRITE(numout,*) &
+ & ' time coeff of POC in sediments, sedlam = ', sedlam
+ WRITE(numout,*) &
+ & ' Sediment geol loss for POC, sedlostpoc = ', sedlostpoc
+ WRITE(numout,*) &
+ & ' Vert layer for diagnostic of vertical flux, jpkp = ', jpkb
+!!
+!! UKESM1 - new diagnostics !! Jpalm; AXY (08/07/15)
+ WRITE(numout,*) '=== UKESM1-related parameters'
+ WRITE(numout,*) &
+ & ' include DMS diagnostic?, jdms = ', jdms
+ if (jdms_input .eq. 0) then
+ WRITE(numout,*) &
+ & ' use instant (0) or diel-avg (1) inputs, jdms_input = instantaneous'
+ else
+ WRITE(numout,*) &
+ & ' use instant (0) or diel-avg (1) inputs, jdms_input = diel-average'
+ endif
+ if (jdms_model .eq. 1) then
+ WRITE(numout,*) &
+ & ' choice of DMS model passed to atmosphere, jdms_model = Anderson et al. (2001)'
+ elseif (jdms_model .eq. 2) then
+ WRITE(numout,*) &
+ & ' choice of DMS model passed to atmosphere, jdms_model = Simo & Dachs (2002)'
+ elseif (jdms_model .eq. 3) then
+ WRITE(numout,*) &
+ & ' choice of DMS model passed to atmosphere, jdms_model = Aranami & Tsunogai (2004)'
+ elseif (jdms_model .eq. 4) then
+ WRITE(numout,*) &
+ & ' choice of DMS model passed to atmosphere, jdms_model = Halloran et al. (2010)'
+ elseif (jdms_model .eq. 5) then
+ WRITE(numout,*) &
+ & ' choice of DMS model passed to atmosphere, jdms_model = Anderson et al. (2001; modified)'
+ endif
+!!
+ ENDIF
+!!
+!! Key depth positions (with thanks to Andrew Coward for bug-fixing this bit)
+ DO jk = 1,jpk
+ !! level thickness
+ fthk = e3t_1d(jk)
+ !! level depth (top of level)
+ fdep = gdepw_1d(jk)
+ !! level depth (bottom of level)
+ fdep1 = fdep + fthk
+ !!
+ if (fdep.lt.100.0.AND.fdep1.gt.100.0) then ! 100 m
+ i0100 = jk
+ elseif (fdep.lt.150.0.AND.fdep1.gt.150.0) then ! 150 m (for BASIN)
+ i0150 = jk
+ elseif (fdep.lt.200.0.AND.fdep1.gt.200.0) then ! 200 m
+ i0200 = jk
+ elseif (fdep.lt.500.0.AND.fdep1.gt.500.0) then ! 500 m
+ i0500 = jk
+ elseif (fdep.lt.1000.0.AND.fdep1.gt.1000.0) then ! 1000 m
+ i1000 = jk
+ elseif (fdep1.lt.1100.0) then ! 1100 m (for Moore et al. sedimentary iron)
+ i1100 = jk
+ endif
+ enddo
+ !!
+ IF(lwp) THEN
+ WRITE(numout,*) '=== Position of key depths'
+ WRITE(numout,*) &
+ & ' jk position of 100 m horizon i0100 = ', i0100
+ WRITE(numout,*) &
+ & ' jk position of 150 m horizon i0150 = ', i0150
+ WRITE(numout,*) &
+ & ' jk position of 200 m horizon i0200 = ', i0200
+ WRITE(numout,*) &
+ & ' jk position of 500 m horizon i0500 = ', i0500
+ WRITE(numout,*) &
+ & ' jk position of 1000 m horizon i1000 = ', i1000
+ WRITE(numout,*) &
+ & ' jk position of 1100 m horizon [*] i1100 = ', i1100
+ WRITE(numout,*) 'Got here ' , SIZE(friver_dep)
+ CALL flush(numout)
+ ENDIF
+
+#if defined key_roam
+
+ ! 1.4b namelist natroam : ROAM parameters
+ ! ---------------------------------------
+
+ xthetaphy = 0.
+ xthetazoo = 0.
+ xthetanit = 0.
+ xthetarem = 0.
+ xo2min = 0.
+
+ !READ(numnatm,natroam)
+ ! Namelist natroam
+ ! -------------------
+ REWIND( numnatp_ref ) ! Namelist natroam in reference namelist : MEDUSA diagnostics
+ READ ( numnatp_ref, natroam, IOSTAT = ios, ERR = 905)
+905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'natroam in reference namelist', lwp )
+
+ REWIND( numnatp_cfg ) ! Namelist natroam in configuration namelist : MEDUSA diagnostics
+ READ ( numnatp_cfg, natroam, IOSTAT = ios, ERR = 906 )
+906 IF( ios /= 0 ) CALL ctl_nam ( ios , 'natroam in configuration namelist', lwp )
+ IF(lwm) WRITE ( numonp, natroam )
+
+!! ROAM carbon, alkalinity and oxygen cycle parameters
+!! xthetaphy : oxygen evolution/consumption by phytoplankton
+!! xthetazoo : oxygen consumption by zooplankton
+!! xthetanit : oxygen consumption by nitrogen remineralisation
+!! xthetarem : oxygen consumption by carbon remineralisation
+!! xo2min : oxygen minimum concentration
+
+ IF(lwp) THEN
+ WRITE(numout,*) 'natroam'
+ WRITE(numout,*) ' '
+!!
+!! ROAM carbon, alkalinity and oxygen cycle parameters
+ WRITE(numout,*) '=== ROAM carbon, alkalinity and oxygen cycle parameters'
+ WRITE(numout,*) &
+ & ' oxygen evolution/consumption by phytoplankton xthetaphy = ', xthetaphy
+ WRITE(numout,*) &
+ & ' oxygen consumption by zooplankton xthetazoo = ', xthetazoo
+ WRITE(numout,*) &
+ & ' oxygen consumption by nitrogen remineralisation xthetanit = ', xthetanit
+ WRITE(numout,*) &
+ & ' oxygen consumption by carbon remineralisation xthetarem = ', xthetarem
+ WRITE(numout,*) &
+ & ' oxygen minimum concentration xo2min = ', xo2min
+ ENDIF
+
+#endif
+
+ CALL flush(numout)
+
+ ! 1.5 namelist natopt : parameters for optic
+ ! ------------------------------------------
+
+ xkg0 = 0.
+ xkr0 = 0.
+ xkgp = 0.
+ xkrp = 0.
+ xlg = 0.
+ xlr = 0.
+ rpig = 0.
+
+ !READ(numnatm,natopt)
+ ! Namelist natopt
+ ! -------------------
+ REWIND( numnatp_ref ) ! Namelist natopt in reference namelist : MEDUSA diagnostics
+ READ ( numnatp_ref, natopt, IOSTAT = ios, ERR = 907)
+907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'natopt in reference namelist', lwp )
+
+ REWIND( numnatp_cfg ) ! Namelist natopt in configuration namelist : MEDUSA diagnostics
+ READ ( numnatp_cfg, natopt, IOSTAT = ios, ERR = 908 )
+908 IF( ios /= 0 ) CALL ctl_nam ( ios , 'natopt in configuration namelist', lwp )
+ IF(lwm) WRITE ( numonp, natopt )
+
+ IF(lwp) THEN
+ WRITE(numout,*) 'natopt'
+ WRITE(numout,*) ' '
+ WRITE(numout,*) ' green water absorption coeff xkg0 = ',xkg0
+ WRITE(numout,*) ' red water absorption coeff xkr0 = ',xkr0
+ WRITE(numout,*) ' pigment red absorption coeff xkrp = ',xkrp
+ WRITE(numout,*) ' pigment green absorption coeff xkgp = ',xkgp
+ WRITE(numout,*) ' green chl exposant xlg = ',xlg
+ WRITE(numout,*) ' red chl exposant xlr = ',xlr
+ WRITE(numout,*) ' chla/chla+phea ratio rpig = ',rpig
+ WRITE(numout,*) ' '
+
+ ENDIF
+
+ IF(lwp) THEN
+ WRITE(numout,*) 'NaN check'
+ WRITE(numout,*) ' '
+ q1 = -1.
+ q2 = 0.
+ q3 = log(q1)
+ write (numout,*) 'q3 = ', q3
+ if ( ieee_is_nan( q3 ) ) then
+ write (numout,*) 'NaN detected'
+ else
+ write (numout,*) 'NaN not detected'
+ endif
+ WRITE(numout,*) ' '
+ ENDIF
+
+ END SUBROUTINE trc_nam_medusa
+
+ SUBROUTINE trc_nam_iom_medusa
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE trc_nam_iom_medusa ***
+ !!
+ !! ** Purpose : read all diag requested in iodef file through iom_use
+ !! So it is done only once
+ !! ** All diagnostic MEDUSA could asked are registered in
+ !! the med_diag type with a boolean value
+ !! So if required, one diagnostic will be true.
+ !!
+ !!---------------------------------------------------------------------
+ !!
+ !!
+ !!----------------------------------------------------------------------
+ !! Variable conventions
+ !!----------------------------------------------------------------------
+ !!
+ IF (iom_use("INVTN")) THEN
+ med_diag%INVTN%dgsave = .TRUE.
+ ELSE
+ med_diag%INVTN%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INVTSI")) THEN
+ med_diag%INVTSI%dgsave = .TRUE.
+ ELSE
+ med_diag%INVTSI%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INVTFE")) THEN
+ med_diag%INVTFE%dgsave = .TRUE.
+ ELSE
+ med_diag%INVTFE%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PRN")) THEN
+ med_diag%PRN%dgsave = .TRUE.
+ ELSE
+ med_diag%PRN%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("MPN")) THEN
+ med_diag%MPN%dgsave = .TRUE.
+ ELSE
+ med_diag%MPN%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PRD")) THEN
+ med_diag%PRD%dgsave = .TRUE.
+ ELSE
+ med_diag%PRD%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("MPD")) THEN
+ med_diag%MPD%dgsave = .TRUE.
+ ELSE
+ med_diag%MPD%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("DSED")) THEN
+ med_diag%DSED%dgsave = .TRUE.
+ ELSE
+ med_diag%DSED%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OPAL")) THEN
+ med_diag%OPAL%dgsave = .TRUE.
+ ELSE
+ med_diag%OPAL%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OPALDISS")) THEN
+ med_diag%OPALDISS%dgsave = .TRUE.
+ ELSE
+ med_diag%OPALDISS%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("GMIPn")) THEN
+ med_diag%GMIPn%dgsave = .TRUE.
+ ELSE
+ med_diag%GMIPn%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("GMID")) THEN
+ med_diag%GMID%dgsave = .TRUE.
+ ELSE
+ med_diag%GMID%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("MZMI")) THEN
+ med_diag%MZMI%dgsave = .TRUE.
+ ELSE
+ med_diag%MZMI%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("GMEPN")) THEN
+ med_diag%GMEPN%dgsave = .TRUE.
+ ELSE
+ med_diag%GMEPN%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("GMEPD")) THEN
+ med_diag%GMEPD%dgsave = .TRUE.
+ ELSE
+ med_diag%GMEPD%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("GMEZMI")) THEN
+ med_diag%GMEZMI%dgsave = .TRUE.
+ ELSE
+ med_diag%GMEZMI%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("GMED")) THEN
+ med_diag%GMED%dgsave = .TRUE.
+ ELSE
+ med_diag%GMED%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("MZME")) THEN
+ med_diag%MZME%dgsave = .TRUE.
+ ELSE
+ med_diag%MZME%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("DEXP")) THEN
+ med_diag%DEXP%dgsave = .TRUE.
+ ELSE
+ med_diag%DEXP%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("DETN")) THEN
+ med_diag%DETN%dgsave = .TRUE.
+ ELSE
+ med_diag%DETN%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("MDET")) THEN
+ med_diag%MDET%dgsave = .TRUE.
+ ELSE
+ med_diag%MDET%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("AEOLIAN")) THEN
+ med_diag%AEOLIAN%dgsave = .TRUE.
+ ELSE
+ med_diag%AEOLIAN%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("BENTHIC")) THEN
+ med_diag%BENTHIC%dgsave = .TRUE.
+ ELSE
+ med_diag%BENTHIC%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("SCAVENGE")) THEN
+ med_diag%SCAVENGE%dgsave = .TRUE.
+ ELSE
+ med_diag%SCAVENGE%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PN_JLIM")) THEN
+ med_diag%PN_JLIM%dgsave = .TRUE.
+ ELSE
+ med_diag%PN_JLIM%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PN_NLIM")) THEN
+ med_diag%PN_NLIM%dgsave = .TRUE.
+ ELSE
+ med_diag%PN_NLIM%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PN_FELIM")) THEN
+ med_diag%PN_FELIM%dgsave = .TRUE.
+ ELSE
+ med_diag%PN_FELIM%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PD_JLIM")) THEN
+ med_diag%PD_JLIM%dgsave = .TRUE.
+ ELSE
+ med_diag%PD_JLIM%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PD_NLIM")) THEN
+ med_diag%PD_NLIM%dgsave = .TRUE.
+ ELSE
+ med_diag%PD_NLIM%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PD_FELIM")) THEN
+ med_diag%PD_FELIM%dgsave = .TRUE.
+ ELSE
+ med_diag%PD_FELIM%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PD_SILIM")) THEN
+ med_diag%PD_SILIM%dgsave = .TRUE.
+ ELSE
+ med_diag%PD_SILIM%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PDSILIM2")) THEN
+ med_diag%PDSILIM2%dgsave = .TRUE.
+ ELSE
+ med_diag%PDSILIM2%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("SDT__100")) THEN
+ med_diag%SDT__100%dgsave = .TRUE.
+ ELSE
+ med_diag%SDT__100%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("SDT__200")) THEN
+ med_diag%SDT__200%dgsave = .TRUE.
+ ELSE
+ med_diag%SDT__200%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("SDT__500")) THEN
+ med_diag%SDT__500%dgsave = .TRUE.
+ ELSE
+ med_diag%SDT__500%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("SDT_1000")) THEN
+ med_diag%SDT_1000%dgsave = .TRUE.
+ ELSE
+ med_diag%SDT_1000%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("TOTREG_N")) THEN
+ med_diag%TOTREG_N%dgsave = .TRUE.
+ ELSE
+ med_diag%TOTREG_N%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("TOTRG_SI")) THEN
+ med_diag%TOTRG_SI%dgsave = .TRUE.
+ ELSE
+ med_diag%TOTRG_SI%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("REG__100")) THEN
+ med_diag%REG__100%dgsave = .TRUE.
+ ELSE
+ med_diag%REG__100%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("REG__200")) THEN
+ med_diag%REG__200%dgsave = .TRUE.
+ ELSE
+ med_diag%REG__200%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("REG__500")) THEN
+ med_diag%REG__500%dgsave = .TRUE.
+ ELSE
+ med_diag%REG__500%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("REG_1000")) THEN
+ med_diag%REG_1000%dgsave = .TRUE.
+ ELSE
+ med_diag%REG_1000%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FASTN")) THEN
+ med_diag%FASTN%dgsave = .TRUE.
+ ELSE
+ med_diag%FASTN%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FASTSI")) THEN
+ med_diag%FASTSI%dgsave = .TRUE.
+ ELSE
+ med_diag%FASTSI%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FASTFE")) THEN
+ med_diag%FASTFE%dgsave = .TRUE.
+ ELSE
+ med_diag%FASTFE%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FASTC")) THEN
+ med_diag%FASTC%dgsave = .TRUE.
+ ELSE
+ med_diag%FASTC%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FASTCA")) THEN
+ med_diag%FASTCA%dgsave = .TRUE.
+ ELSE
+ med_diag%FASTCA%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FDT__100")) THEN
+ med_diag%FDT__100%dgsave = .TRUE.
+ ELSE
+ med_diag%FDT__100%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FDT__200")) THEN
+ med_diag%FDT__200%dgsave = .TRUE.
+ ELSE
+ med_diag%FDT__200%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FDT__500")) THEN
+ med_diag%FDT__500%dgsave = .TRUE.
+ ELSE
+ med_diag%FDT__500%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FDT_1000")) THEN
+ med_diag%FDT_1000%dgsave = .TRUE.
+ ELSE
+ med_diag%FDT_1000%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("RG__100F")) THEN
+ med_diag%RG__100F%dgsave = .TRUE.
+ ELSE
+ med_diag%RG__100F%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("RG__200F")) THEN
+ med_diag%RG__200F%dgsave = .TRUE.
+ ELSE
+ med_diag%RG__200F%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("RG__500F")) THEN
+ med_diag%RG__500F%dgsave = .TRUE.
+ ELSE
+ med_diag%RG__500F%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("RG_1000F")) THEN
+ med_diag%RG_1000F%dgsave = .TRUE.
+ ELSE
+ med_diag%RG_1000F%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FDS__100")) THEN
+ med_diag%FDS__100%dgsave = .TRUE.
+ ELSE
+ med_diag%FDS__100%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FDS__200")) THEN
+ med_diag%FDS__200%dgsave = .TRUE.
+ ELSE
+ med_diag%FDS__200%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FDS__500")) THEN
+ med_diag%FDS__500%dgsave = .TRUE.
+ ELSE
+ med_diag%FDS__500%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FDS_1000")) THEN
+ med_diag%FDS_1000%dgsave = .TRUE.
+ ELSE
+ med_diag%FDS_1000%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("RGS_100F")) THEN
+ med_diag%RGS_100F%dgsave = .TRUE.
+ ELSE
+ med_diag%RGS_100F%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("RGS_200F")) THEN
+ med_diag%RGS_200F%dgsave = .TRUE.
+ ELSE
+ med_diag%RGS_200F%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("RGS_500F")) THEN
+ med_diag%RGS_500F%dgsave = .TRUE.
+ ELSE
+ med_diag%RGS_500F%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("RGS1000F")) THEN
+ med_diag%RGS1000F%dgsave = .TRUE.
+ ELSE
+ med_diag%RGS1000F%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("REMINN")) THEN
+ med_diag%REMINN%dgsave = .TRUE.
+ ELSE
+ med_diag%REMINN%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("REMINSI")) THEN
+ med_diag%REMINSI%dgsave = .TRUE.
+ ELSE
+ med_diag%REMINSI%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("REMINFE")) THEN
+ med_diag%REMINFE%dgsave = .TRUE.
+ ELSE
+ med_diag%REMINFE%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("REMINC")) THEN
+ med_diag%REMINC%dgsave = .TRUE.
+ ELSE
+ med_diag%REMINC%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("REMINCA")) THEN
+ med_diag%REMINCA%dgsave = .TRUE.
+ ELSE
+ med_diag%REMINCA%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("SEAFLRN")) THEN
+ med_diag%SEAFLRN%dgsave = .TRUE.
+ ELSE
+ med_diag%SEAFLRN%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("SEAFLRSI")) THEN
+ med_diag%SEAFLRSI%dgsave = .TRUE.
+ ELSE
+ med_diag%SEAFLRSI%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("SEAFLRFE")) THEN
+ med_diag%SEAFLRFE%dgsave = .TRUE.
+ ELSE
+ med_diag%SEAFLRFE%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("SEAFLRC")) THEN
+ med_diag%SEAFLRC%dgsave = .TRUE.
+ ELSE
+ med_diag%SEAFLRC%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("SEAFLRCA")) THEN
+ med_diag%SEAFLRCA%dgsave = .TRUE.
+ ELSE
+ med_diag%SEAFLRCA%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("MED_QSR")) THEN
+ med_diag%MED_QSR%dgsave = .TRUE.
+ ELSE
+ med_diag%MED_QSR%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("MED_XPAR")) THEN
+ med_diag%MED_XPAR%dgsave = .TRUE.
+ ELSE
+ med_diag%MED_XPAR%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INTFLX_N")) THEN
+ med_diag%INTFLX_N%dgsave = .TRUE.
+ ELSE
+ med_diag%INTFLX_N%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INTFLX_SI")) THEN
+ med_diag%INTFLX_SI%dgsave = .TRUE.
+ ELSE
+ med_diag%INTFLX_SI%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INTFLX_FE")) THEN
+ med_diag%INTFLX_FE%dgsave = .TRUE.
+ ELSE
+ med_diag%INTFLX_FE%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INT_PN")) THEN
+ med_diag%INT_PN%dgsave = .TRUE.
+ ELSE
+ med_diag%INT_PN%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INT_PD")) THEN
+ med_diag%INT_PD%dgsave = .TRUE.
+ ELSE
+ med_diag%INT_PD%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ML_PRN")) THEN
+ med_diag%ML_PRN%dgsave = .TRUE.
+ ELSE
+ med_diag%ML_PRN%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ML_PRD")) THEN
+ med_diag%ML_PRD%dgsave = .TRUE.
+ ELSE
+ med_diag%ML_PRD%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OCAL_CCD")) THEN
+ med_diag%OCAL_CCD%dgsave = .TRUE.
+ ELSE
+ med_diag%OCAL_CCD%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OCAL_LVL")) THEN
+ med_diag%OCAL_LVL%dgsave = .TRUE.
+ ELSE
+ med_diag%OCAL_LVL%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FE_0000")) THEN
+ med_diag%FE_0000%dgsave = .TRUE.
+ ELSE
+ med_diag%FE_0000%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FE_0100")) THEN
+ med_diag%FE_0100%dgsave = .TRUE.
+ ELSE
+ med_diag%FE_0100%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FE_0200")) THEN
+ med_diag%FE_0200%dgsave = .TRUE.
+ ELSE
+ med_diag%FE_0200%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FE_0500")) THEN
+ med_diag%FE_0500%dgsave = .TRUE.
+ ELSE
+ med_diag%FE_0500%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FE_1000")) THEN
+ med_diag%FE_1000%dgsave = .TRUE.
+ ELSE
+ med_diag%FE_1000%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("MED_XZE")) THEN
+ med_diag%MED_XZE%dgsave = .TRUE.
+ ELSE
+ med_diag%MED_XZE%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("WIND")) THEN
+ med_diag%WIND%dgsave = .TRUE.
+ ELSE
+ med_diag%WIND%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ATM_PCO2")) THEN
+ med_diag%ATM_PCO2%dgsave = .TRUE.
+ ELSE
+ med_diag%ATM_PCO2%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OCN_PH")) THEN
+ med_diag%OCN_PH%dgsave = .TRUE.
+ ELSE
+ med_diag%OCN_PH%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OCN_PCO2")) THEN
+ med_diag%OCN_PCO2%dgsave = .TRUE.
+ ELSE
+ med_diag%OCN_PCO2%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OCNH2CO3")) THEN
+ med_diag%OCNH2CO3%dgsave = .TRUE.
+ ELSE
+ med_diag%OCNH2CO3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OCN_HCO3")) THEN
+ med_diag%OCN_HCO3%dgsave = .TRUE.
+ ELSE
+ med_diag%OCN_HCO3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OCN_CO3")) THEN
+ med_diag%OCN_CO3%dgsave = .TRUE.
+ ELSE
+ med_diag%OCN_CO3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("CO2FLUX")) THEN
+ med_diag%CO2FLUX%dgsave = .TRUE.
+ ELSE
+ med_diag%CO2FLUX%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OM_CAL")) THEN
+ med_diag%OM_CAL%dgsave = .TRUE.
+ ELSE
+ med_diag%OM_CAL%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OM_ARG")) THEN
+ med_diag%OM_ARG%dgsave = .TRUE.
+ ELSE
+ med_diag%OM_ARG%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("TCO2")) THEN
+ med_diag%TCO2%dgsave = .TRUE.
+ ELSE
+ med_diag%TCO2%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("TALK")) THEN
+ med_diag%TALK%dgsave = .TRUE.
+ ELSE
+ med_diag%TALK%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("KW660")) THEN
+ med_diag%KW660%dgsave = .TRUE.
+ ELSE
+ med_diag%KW660%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ATM_PP0")) THEN
+ med_diag%ATM_PP0%dgsave = .TRUE.
+ ELSE
+ med_diag%ATM_PP0%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("O2FLUX")) THEN
+ med_diag%O2FLUX%dgsave = .TRUE.
+ ELSE
+ med_diag%O2FLUX%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("O2SAT")) THEN
+ med_diag%O2SAT%dgsave = .TRUE.
+ ELSE
+ med_diag%O2SAT%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("CAL_CCD")) THEN
+ med_diag%CAL_CCD%dgsave = .TRUE.
+ ELSE
+ med_diag%CAL_CCD%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ARG_CCD")) THEN
+ med_diag%ARG_CCD%dgsave = .TRUE.
+ ELSE
+ med_diag%ARG_CCD%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("SFR_OCAL")) THEN
+ med_diag%SFR_OCAL%dgsave = .TRUE.
+ ELSE
+ med_diag%SFR_OCAL%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("SFR_OARG")) THEN
+ med_diag%SFR_OARG%dgsave = .TRUE.
+ ELSE
+ med_diag%SFR_OARG%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("N_PROD")) THEN
+ med_diag%N_PROD%dgsave = .TRUE.
+ ELSE
+ med_diag%N_PROD%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("N_CONS")) THEN
+ med_diag%N_CONS%dgsave = .TRUE.
+ ELSE
+ med_diag%N_CONS%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("C_PROD")) THEN
+ med_diag%C_PROD%dgsave = .TRUE.
+ ELSE
+ med_diag%C_PROD%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("C_CONS")) THEN
+ med_diag%C_CONS%dgsave = .TRUE.
+ ELSE
+ med_diag%C_CONS%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("O2_PROD")) THEN
+ med_diag%O2_PROD%dgsave = .TRUE.
+ ELSE
+ med_diag%O2_PROD%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("O2_CONS")) THEN
+ med_diag%O2_CONS%dgsave = .TRUE.
+ ELSE
+ med_diag%O2_CONS%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("O2_ANOX")) THEN
+ med_diag%O2_ANOX%dgsave = .TRUE.
+ ELSE
+ med_diag%O2_ANOX%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("RR_0100")) THEN
+ med_diag%RR_0100%dgsave = .TRUE.
+ ELSE
+ med_diag%RR_0100%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("RR_0500")) THEN
+ med_diag%RR_0500%dgsave = .TRUE.
+ ELSE
+ med_diag%RR_0500%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("RR_1000")) THEN
+ med_diag%RR_1000%dgsave = .TRUE.
+ ELSE
+ med_diag%RR_1000%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("IBEN_N")) THEN
+ med_diag%IBEN_N%dgsave = .TRUE.
+ ELSE
+ med_diag%IBEN_N%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("IBEN_FE")) THEN
+ med_diag%IBEN_FE%dgsave = .TRUE.
+ ELSE
+ med_diag%IBEN_FE%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("IBEN_C")) THEN
+ med_diag%IBEN_C%dgsave = .TRUE.
+ ELSE
+ med_diag%IBEN_C%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("IBEN_SI")) THEN
+ med_diag%IBEN_SI%dgsave = .TRUE.
+ ELSE
+ med_diag%IBEN_SI%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("IBEN_CA")) THEN
+ med_diag%IBEN_CA%dgsave = .TRUE.
+ ELSE
+ med_diag%IBEN_CA%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OBEN_N")) THEN
+ med_diag%OBEN_N%dgsave = .TRUE.
+ ELSE
+ med_diag%OBEN_N%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OBEN_FE")) THEN
+ med_diag%OBEN_FE%dgsave = .TRUE.
+ ELSE
+ med_diag%OBEN_FE%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OBEN_C")) THEN
+ med_diag%OBEN_C%dgsave = .TRUE.
+ ELSE
+ med_diag%OBEN_C%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OBEN_SI")) THEN
+ med_diag%OBEN_SI%dgsave = .TRUE.
+ ELSE
+ med_diag%OBEN_SI%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OBEN_CA")) THEN
+ med_diag%OBEN_CA%dgsave = .TRUE.
+ ELSE
+ med_diag%OBEN_CA%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("BEN_N")) THEN
+ med_diag%BEN_N%dgsave = .TRUE.
+ ELSE
+ med_diag%BEN_N%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("BEN_FE")) THEN
+ med_diag%BEN_FE%dgsave = .TRUE.
+ ELSE
+ med_diag%BEN_FE%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("BEN_C")) THEN
+ med_diag%BEN_C%dgsave = .TRUE.
+ ELSE
+ med_diag%BEN_C%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("BEN_SI")) THEN
+ med_diag%BEN_SI%dgsave = .TRUE.
+ ELSE
+ med_diag%BEN_SI%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("BEN_CA")) THEN
+ med_diag%BEN_CA%dgsave = .TRUE.
+ ELSE
+ med_diag%BEN_CA%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("RUNOFF")) THEN
+ med_diag%RUNOFF%dgsave = .TRUE.
+ ELSE
+ med_diag%RUNOFF%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("RIV_N")) THEN
+ med_diag%RIV_N%dgsave = .TRUE.
+ ELSE
+ med_diag%RIV_N%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("RIV_SI")) THEN
+ med_diag%RIV_SI%dgsave = .TRUE.
+ ELSE
+ med_diag%RIV_SI%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("RIV_C")) THEN
+ med_diag%RIV_C%dgsave = .TRUE.
+ ELSE
+ med_diag%RIV_C%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("RIV_ALK")) THEN
+ med_diag%RIV_ALK%dgsave = .TRUE.
+ ELSE
+ med_diag%RIV_ALK%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("DETC")) THEN
+ med_diag%DETC%dgsave = .TRUE.
+ ELSE
+ med_diag%DETC%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("SDC__100")) THEN
+ med_diag%SDC__100%dgsave = .TRUE.
+ ELSE
+ med_diag%SDC__100%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("SDC__200")) THEN
+ med_diag%SDC__200%dgsave = .TRUE.
+ ELSE
+ med_diag%SDC__200%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("SDC__500")) THEN
+ med_diag%SDC__500%dgsave = .TRUE.
+ ELSE
+ med_diag%SDC__500%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("SDC_1000")) THEN
+ med_diag%SDC_1000%dgsave = .TRUE.
+ ELSE
+ med_diag%SDC_1000%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INVTC")) THEN
+ med_diag%INVTC%dgsave = .TRUE.
+ ELSE
+ med_diag%INVTC%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INVTALK")) THEN
+ med_diag%INVTALK%dgsave = .TRUE.
+ ELSE
+ med_diag%INVTALK%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INVTO2")) THEN
+ med_diag%INVTO2%dgsave = .TRUE.
+ ELSE
+ med_diag%INVTO2%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("LYSO_CA")) THEN
+ med_diag%LYSO_CA%dgsave = .TRUE.
+ ELSE
+ med_diag%LYSO_CA%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("COM_RESP")) THEN
+ med_diag%COM_RESP%dgsave = .TRUE.
+ ELSE
+ med_diag%COM_RESP%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PN_LLOSS")) THEN
+ med_diag%PN_LLOSS%dgsave = .TRUE.
+ ELSE
+ med_diag%PN_LLOSS%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PD_LLOSS")) THEN
+ med_diag%PD_LLOSS%dgsave = .TRUE.
+ ELSE
+ med_diag%PD_LLOSS%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ZI_LLOSS")) THEN
+ med_diag%ZI_LLOSS%dgsave = .TRUE.
+ ELSE
+ med_diag%ZI_LLOSS%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ZE_LLOSS")) THEN
+ med_diag%ZE_LLOSS%dgsave = .TRUE.
+ ELSE
+ med_diag%ZE_LLOSS%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ZI_MES_N")) THEN
+ med_diag%ZI_MES_N%dgsave = .TRUE.
+ ELSE
+ med_diag%ZI_MES_N%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ZI_MES_D")) THEN
+ med_diag%ZI_MES_D%dgsave = .TRUE.
+ ELSE
+ med_diag%ZI_MES_D%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ZI_MES_C")) THEN
+ med_diag%ZI_MES_C%dgsave = .TRUE.
+ ELSE
+ med_diag%ZI_MES_C%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ZI_MESDC")) THEN
+ med_diag%ZI_MESDC%dgsave = .TRUE.
+ ELSE
+ med_diag%ZI_MESDC%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ZI_EXCR")) THEN
+ med_diag%ZI_EXCR%dgsave = .TRUE.
+ ELSE
+ med_diag%ZI_EXCR%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ZI_RESP")) THEN
+ med_diag%ZI_RESP%dgsave = .TRUE.
+ ELSE
+ med_diag%ZI_RESP%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ZI_GROW")) THEN
+ med_diag%ZI_GROW%dgsave = .TRUE.
+ ELSE
+ med_diag%ZI_GROW%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ZE_MES_N")) THEN
+ med_diag%ZE_MES_N%dgsave = .TRUE.
+ ELSE
+ med_diag%ZE_MES_N%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ZE_MES_D")) THEN
+ med_diag%ZE_MES_D%dgsave = .TRUE.
+ ELSE
+ med_diag%ZE_MES_D%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ZE_MES_C")) THEN
+ med_diag%ZE_MES_C%dgsave = .TRUE.
+ ELSE
+ med_diag%ZE_MES_C%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ZE_MESDC")) THEN
+ med_diag%ZE_MESDC%dgsave = .TRUE.
+ ELSE
+ med_diag%ZE_MESDC%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ZE_EXCR")) THEN
+ med_diag%ZE_EXCR%dgsave = .TRUE.
+ ELSE
+ med_diag%ZE_EXCR%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ZE_RESP")) THEN
+ med_diag%ZE_RESP%dgsave = .TRUE.
+ ELSE
+ med_diag%ZE_RESP%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ZE_GROW")) THEN
+ med_diag%ZE_GROW%dgsave = .TRUE.
+ ELSE
+ med_diag%ZE_GROW%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("MDETC")) THEN
+ med_diag%MDETC%dgsave = .TRUE.
+ ELSE
+ med_diag%MDETC%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("GMIDC")) THEN
+ med_diag%GMIDC%dgsave = .TRUE.
+ ELSE
+ med_diag%GMIDC%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("GMEDC")) THEN
+ med_diag%GMEDC%dgsave = .TRUE.
+ ELSE
+ med_diag%GMEDC%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INT_ZMI")) THEN
+ med_diag%INT_ZMI%dgsave = .TRUE.
+ ELSE
+ med_diag%INT_ZMI%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INT_ZME")) THEN
+ med_diag%INT_ZME%dgsave = .TRUE.
+ ELSE
+ med_diag%INT_ZME%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INT_DET")) THEN
+ med_diag%INT_DET%dgsave = .TRUE.
+ ELSE
+ med_diag%INT_DET%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INT_DTC")) THEN
+ med_diag%INT_DTC%dgsave = .TRUE.
+ ELSE
+ med_diag%INT_DTC%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("DMS_SURF")) THEN
+ med_diag%DMS_SURF%dgsave = .TRUE.
+ ELSE
+ med_diag%DMS_SURF%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("DMS_ANDR")) THEN
+ med_diag%DMS_ANDR%dgsave = .TRUE.
+ ELSE
+ med_diag%DMS_ANDR%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("DMS_SIMO")) THEN
+ med_diag%DMS_SIMO%dgsave = .TRUE.
+ ELSE
+ med_diag%DMS_SIMO%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("DMS_ARAN")) THEN
+ med_diag%DMS_ARAN%dgsave = .TRUE.
+ ELSE
+ med_diag%DMS_ARAN%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("DMS_HALL")) THEN
+ med_diag%DMS_HALL%dgsave = .TRUE.
+ ELSE
+ med_diag%DMS_HALL%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("DMS_ANDM")) THEN
+ med_diag%DMS_ANDM%dgsave = .TRUE.
+ ELSE
+ med_diag%DMS_ANDM%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ATM_XCO2")) THEN
+ med_diag%ATM_XCO2%dgsave = .TRUE.
+ ELSE
+ med_diag%ATM_XCO2%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OCN_FCO2")) THEN
+ med_diag%OCN_FCO2%dgsave = .TRUE.
+ ELSE
+ med_diag%OCN_FCO2%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ATM_FCO2")) THEN
+ med_diag%ATM_FCO2%dgsave = .TRUE.
+ ELSE
+ med_diag%ATM_FCO2%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OCN_RHOSW")) THEN
+ med_diag%OCN_RHOSW%dgsave = .TRUE.
+ ELSE
+ med_diag%OCN_RHOSW%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OCN_SCHCO2")) THEN
+ med_diag%OCN_SCHCO2%dgsave = .TRUE.
+ ELSE
+ med_diag%OCN_SCHCO2%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OCN_KWCO2")) THEN
+ med_diag%OCN_KWCO2%dgsave = .TRUE.
+ ELSE
+ med_diag%OCN_KWCO2%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OCN_K0")) THEN
+ med_diag%OCN_K0%dgsave = .TRUE.
+ ELSE
+ med_diag%OCN_K0%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("CO2STARAIR")) THEN
+ med_diag%CO2STARAIR%dgsave = .TRUE.
+ ELSE
+ med_diag%CO2STARAIR%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OCN_DPCO2")) THEN
+ med_diag%OCN_DPCO2%dgsave = .TRUE.
+ ELSE
+ med_diag%OCN_DPCO2%dgsave = .FALSE.
+ ENDIF
+ !!
+ IF (iom_use("TPP3")) THEN
+ med_diag%TPP3%dgsave = .TRUE.
+ ELSE
+ med_diag%TPP3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("DETFLUX3")) THEN
+ med_diag%DETFLUX3%dgsave = .TRUE.
+ ELSE
+ med_diag%DETFLUX3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("REMIN3N")) THEN
+ med_diag%REMIN3N%dgsave = .TRUE.
+ ELSE
+ med_diag%REMIN3N%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PH3")) THEN
+ med_diag%PH3%dgsave = .TRUE.
+ ELSE
+ med_diag%PH3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("OM_CAL3")) THEN
+ med_diag%OM_CAL3%dgsave = .TRUE.
+ ELSE
+ med_diag%OM_CAL3%dgsave = .FALSE.
+ ENDIF
+ !!
+ !!----------------------------------------------------------------------
+ !! AXY (03/11/16): add in additional CMIP6 diagnostics
+ !!----------------------------------------------------------------------
+ !!
+ !! 2D fields
+ IF (iom_use("epC100")) THEN
+ med_diag%epC100%dgsave = .TRUE.
+ ELSE
+ med_diag%epC100%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("epCALC100")) THEN
+ med_diag%epCALC100%dgsave = .TRUE.
+ ELSE
+ med_diag%epCALC100%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("epN100")) THEN
+ med_diag%epN100%dgsave = .TRUE.
+ ELSE
+ med_diag%epN100%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("epSI100")) THEN
+ med_diag%epSI100%dgsave = .TRUE.
+ ELSE
+ med_diag%epSI100%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FGCO2")) THEN
+ med_diag%FGCO2%dgsave = .TRUE.
+ ELSE
+ med_diag%FGCO2%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INTDISSIC")) THEN
+ med_diag%INTDISSIC%dgsave = .TRUE.
+ ELSE
+ med_diag%INTDISSIC%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INTDISSIN")) THEN
+ med_diag%INTDISSIN%dgsave = .TRUE.
+ ELSE
+ med_diag%INTDISSIN%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INTDISSISI")) THEN
+ med_diag%INTDISSISI%dgsave = .TRUE.
+ ELSE
+ med_diag%INTDISSISI%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("INTTALK")) THEN
+ med_diag%INTTALK%dgsave = .TRUE.
+ ELSE
+ med_diag%INTTALK%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("O2min")) THEN
+ med_diag%O2min%dgsave = .TRUE.
+ ELSE
+ med_diag%O2min%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("ZO2min")) THEN
+ med_diag%ZO2min%dgsave = .TRUE.
+ ELSE
+ med_diag%ZO2min%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FBDDTALK")) THEN
+ med_diag%FBDDTALK%dgsave = .TRUE.
+ ELSE
+ med_diag%FBDDTALK%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FBDDTDIC")) THEN
+ med_diag%FBDDTDIC%dgsave = .TRUE.
+ ELSE
+ med_diag%FBDDTDIC%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FBDDTDIFE")) THEN
+ med_diag%FBDDTDIFE%dgsave = .TRUE.
+ ELSE
+ med_diag%FBDDTDIFE%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FBDDTDIN")) THEN
+ med_diag%FBDDTDIN%dgsave = .TRUE.
+ ELSE
+ med_diag%FBDDTDIN%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FBDDTDISI")) THEN
+ med_diag%FBDDTDISI%dgsave = .TRUE.
+ ELSE
+ med_diag%FBDDTDISI%dgsave = .FALSE.
+ ENDIF
+ !!
+ !! 3D
+ IF (iom_use("TPPD3")) THEN
+ med_diag%TPPD3%dgsave = .TRUE.
+ ELSE
+ med_diag%TPPD3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("BDDTALK3")) THEN
+ med_diag%BDDTALK3%dgsave = .TRUE.
+ ELSE
+ med_diag%BDDTALK3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("BDDTDIC3")) THEN
+ med_diag%BDDTDIC3%dgsave = .TRUE.
+ ELSE
+ med_diag%BDDTDIC3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("BDDTDIFE3")) THEN
+ med_diag%BDDTDIFE3%dgsave = .TRUE.
+ ELSE
+ med_diag%BDDTDIFE3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("BDDTDIN3")) THEN
+ med_diag%BDDTDIN3%dgsave = .TRUE.
+ ELSE
+ med_diag%BDDTDIN3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("BDDTDISI3")) THEN
+ med_diag%BDDTDISI3%dgsave = .TRUE.
+ ELSE
+ med_diag%BDDTDISI3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FD_NIT3")) THEN
+ med_diag%FD_NIT3%dgsave = .TRUE.
+ ELSE
+ med_diag%FD_NIT3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FD_SIL3")) THEN
+ med_diag%FD_SIL3%dgsave = .TRUE.
+ ELSE
+ med_diag%FD_SIL3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FD_CAR3")) THEN
+ med_diag%FD_CAR3%dgsave = .TRUE.
+ ELSE
+ med_diag%FD_CAR3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FD_CAL3")) THEN
+ med_diag%FD_CAL3%dgsave = .TRUE.
+ ELSE
+ med_diag%FD_CAL3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("CO33")) THEN
+ med_diag%CO33%dgsave = .TRUE.
+ ELSE
+ med_diag%CO33%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("CO3SATARAG3")) THEN
+ med_diag%CO3SATARAG3%dgsave = .TRUE.
+ ELSE
+ med_diag%CO3SATARAG3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("CO3SATCALC3")) THEN
+ med_diag%CO3SATCALC3%dgsave = .TRUE.
+ ELSE
+ med_diag%CO3SATCALC3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("DCALC3")) THEN
+ med_diag%DCALC3%dgsave = .TRUE.
+ ELSE
+ med_diag%DCALC3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("EXPC3")) THEN
+ med_diag%EXPC3%dgsave = .TRUE.
+ ELSE
+ med_diag%EXPC3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("EXPN3")) THEN
+ med_diag%EXPN3%dgsave = .TRUE.
+ ELSE
+ med_diag%EXPN3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FEDISS3")) THEN
+ med_diag%FEDISS3%dgsave = .TRUE.
+ ELSE
+ med_diag%FEDISS3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("FESCAV3")) THEN
+ med_diag%FESCAV3%dgsave = .TRUE.
+ ELSE
+ med_diag%FESCAV3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("MIGRAZP3")) THEN
+ med_diag%MIGRAZP3%dgsave = .TRUE.
+ ELSE
+ med_diag%MIGRAZP3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("MIGRAZD3")) THEN
+ med_diag%MIGRAZD3%dgsave = .TRUE.
+ ELSE
+ med_diag%MIGRAZD3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("MEGRAZP3")) THEN
+ med_diag%MEGRAZP3%dgsave = .TRUE.
+ ELSE
+ med_diag%MEGRAZP3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("MEGRAZD3")) THEN
+ med_diag%MEGRAZD3%dgsave = .TRUE.
+ ELSE
+ med_diag%MEGRAZD3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("MEGRAZZ3")) THEN
+ med_diag%MEGRAZZ3%dgsave = .TRUE.
+ ELSE
+ med_diag%MEGRAZZ3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("O2SAT3")) THEN
+ med_diag%O2SAT3%dgsave = .TRUE.
+ ELSE
+ med_diag%O2SAT3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PBSI3")) THEN
+ med_diag%PBSI3%dgsave = .TRUE.
+ ELSE
+ med_diag%PBSI3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PCAL3")) THEN
+ med_diag%PCAL3%dgsave = .TRUE.
+ ELSE
+ med_diag%PCAL3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("REMOC3")) THEN
+ med_diag%REMOC3%dgsave = .TRUE.
+ ELSE
+ med_diag%REMOC3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PNLIMJ3")) THEN
+ med_diag%PNLIMJ3%dgsave = .TRUE.
+ ELSE
+ med_diag%PNLIMJ3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PNLIMN3")) THEN
+ med_diag%PNLIMN3%dgsave = .TRUE.
+ ELSE
+ med_diag%PNLIMN3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PNLIMFE3")) THEN
+ med_diag%PNLIMFE3%dgsave = .TRUE.
+ ELSE
+ med_diag%PNLIMFE3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PDLIMJ3")) THEN
+ med_diag%PDLIMJ3%dgsave = .TRUE.
+ ELSE
+ med_diag%PDLIMJ3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PDLIMN3")) THEN
+ med_diag%PDLIMN3%dgsave = .TRUE.
+ ELSE
+ med_diag%PDLIMN3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PDLIMFE3")) THEN
+ med_diag%PDLIMFE3%dgsave = .TRUE.
+ ELSE
+ med_diag%PDLIMFE3%dgsave = .FALSE.
+ ENDIF
+ IF (iom_use("PDLIMSI3")) THEN
+ med_diag%PDLIMSI3%dgsave = .TRUE.
+ ELSE
+ med_diag%PDLIMSI3%dgsave = .FALSE.
+ ENDIF
+
+ END SUBROUTINE trc_nam_iom_medusa
+
+#else
+ !!----------------------------------------------------------------------
+ !! Dummy module : No MEDUSA
+ !!----------------------------------------------------------------------
+CONTAINS
+ SUBROUTINE trc_nam_medusa ! Empty routine
+ END SUBROUTINE trc_nam_medusa
+#endif
+
+ !!======================================================================
+END MODULE trcnam_medusa
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcopt_medusa.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcopt_medusa.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcopt_medusa.F90 (revision 8155)
@@ -0,0 +1,187 @@
+MODULE trcopt_medusa
+ !!======================================================================
+ !! *** MODULE trcopt_medusa ***
+ !! TOP : MEDUSA Compute the light availability in the water column
+ !!======================================================================
+ !! History : - ! 1995-05 (M. Levy) Original code
+ !! - ! 1999-09 (J.-M. Andre, M. Levy)
+ !! - ! 1999-11 (C. Menkes, M.-A. Foujols) itabe initial
+ !! - ! 2000-02 (M.A. Foujols) change x**y par exp(y*log(x))
+ !! 2.0 ! 2007-12 (C. Deltel, G. Madec) F90
+ !! - ! 2008-08 (K. Popova) adaptation for MEDUSA
+ !! - ! 2008-11 (A. Yool) continuing adaptation for MEDUSA
+ !! - ! 2010-03 (A. Yool) updated for branch inclusion
+ !!----------------------------------------------------------------------
+#if defined key_medusa
+ !!----------------------------------------------------------------------
+ !! 'key_medusa' MEDUSA bio-model
+ !!----------------------------------------------------------------------
+ !! trc_opt_medusa : Compute the light availability in the water column
+ !!----------------------------------------------------------------------
+ USE oce_trc !
+ USE trc
+ USE prtctl_trc ! Print control for debbuging
+ USE sms_medusa
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_opt_medusa ! called in trcprg.F90
+
+ !!* Substitution
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+CONTAINS
+
+ SUBROUTINE trc_opt_medusa( kt )
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE trc_opt_medusa ***
+ !!
+ !! ** Purpose : computes the light propagation in the water column
+ !! and the euphotic layer depth
+ !!
+ !! ** Method : local par is computed in w layers using light propagation
+ !! mean par in t layers are computed by integration
+ !!---------------------------------------------------------------------
+ INTEGER, INTENT( in ) :: kt ! index of the time stepping
+ INTEGER :: ji, jj, jk
+ REAL(wp) :: zpig ! total pigment
+ REAL(wp) :: zkr ! total absorption coefficient in red
+ REAL(wp) :: zkg ! total absorption coefficient in green
+ REAL(wp) :: totchl ! total Chl concentreation
+ REAL(wp), DIMENSION(jpi,jpj) :: zpar100 ! irradiance at euphotic layer depth
+ REAL(wp), DIMENSION(jpi,jpj) :: zpar0m ! irradiance just below the surface
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: zparr, zparg ! red and green compound of par
+
+ CHARACTER (len=25) :: charout
+ !!---------------------------------------------------------------------
+
+ !! AXY (20/11/14): alter this to report on first MEDUSA call
+ !! IF( kt == nit000 ) THEN
+ IF( kt == nittrc000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) ' trc_opt_medusa: MEDUSA optic-model'
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~'
+ IF(lwp) WRITE(numout,*) ' kt =',kt
+ ENDIF
+
+ ! determination of surface irradiance
+ ! -----------------------------------
+ ! AXY (23/07/15): the inclusion of empirical DMS calculations requires
+ ! daily averages of a series of properties that are
+ ! used as inputs; these include surface irradiance;
+ ! here, this is taken advantage of to allow MEDUSA to
+ ! base its submarine light field on daily average
+ ! rather than "instantaneous" irradiance; largely
+ ! because MEDUSA was originally formulated to work
+ ! with diel average irradiance rather than a diel
+ ! cycle; using key_avgqsr_medusa activates this
+ ! functionality, while its absence gives default
+ ! MEDUSA (which is whatever is supplied by NEMO)
+# if defined key_avgqsr_medusa
+ ! surface irradiance input is rolling average irradiance
+ zpar0m (:,:) = zn_dms_qsr(:,:) * 0.43
+# else
+ ! surface irradiance input is instantaneous irradiance
+ zpar0m (:,:) = qsr(:,:) * 0.43
+# endif
+ ! AXY (22/08/14): when zpar0m = 0, zpar100 is also zero and calculating
+ ! euphotic depth is not possible (cf. the Arctic Octopus);
+ ! a "solution" to this is to set zpar0m to some minimal
+ ! value such that zpar100 also has a non-zero value and
+ ! euphotic depth can be calculated properly; note that,
+ ! in older, non-diurnal versions of NEMO, this was much
+ ! less of a problem; note also that, if pushed, I will
+ ! claim that my minimal value of zpar0m refers to light
+ ! from stars
+ DO jj = 1, jpj
+ DO ji = 1, jpi
+ IF( zpar0m(ji,jj) <= 0.0 ) zpar0m(ji,jj) = 0.001 ! = 1 mW/m2
+ ENDDO
+ ENDDO
+ zpar100(:,:) = zpar0m(:,:) * 0.01
+ xpar (:,:,1) = zpar0m(:,:)
+ zparr (:,:,1) = 0.5 * zpar0m(:,:)
+ zparg (:,:,1) = 0.5 * zpar0m(:,:)
+
+ ! determination of xpar
+ ! ---------------------
+
+ DO jk = 2, jpk ! determination of local par in w levels
+ DO jj = 1, jpj
+ DO ji = 1, jpi
+ totchl =trn(ji,jj,jk-1,jpchn)+trn(ji,jj,jk-1,jpchd)
+ zpig = MAX( TINY(0.), totchl/rpig)
+ zkr = xkr0 + xkrp * EXP( xlr * LOG( zpig ) )
+ zkg = xkg0 + xkgp * EXP( xlg * LOG( zpig ) )
+ zparr(ji,jj,jk) = zparr(ji,jj,jk-1) * EXP( -zkr * fse3t(ji,jj,jk-1) )
+ zparg(ji,jj,jk) = zparg(ji,jj,jk-1) * EXP( -zkg * fse3t(ji,jj,jk-1) )
+ END DO
+ END DO
+ END DO
+
+ DO jk = 1, jpkm1 ! mean par in t levels
+ DO jj = 1, jpj
+ DO ji = 1, jpi
+ totchl =trn(ji,jj,jk ,jpchn)+trn(ji,jj,jk ,jpchd)
+ zpig = MAX( TINY(0.), totchl/rpig)
+ zkr = xkr0 + xkrp * EXP( xlr * LOG( zpig ) )
+ zkg = xkg0 + xkgp * EXP( xlg * LOG( zpig ) )
+ zparr(ji,jj,jk) = zparr(ji,jj,jk) / zkr / fse3t(ji,jj,jk) * ( 1 - EXP( -zkr*fse3t(ji,jj,jk) ) )
+ zparg(ji,jj,jk) = zparg(ji,jj,jk) / zkg / fse3t(ji,jj,jk) * ( 1 - EXP( -zkg*fse3t(ji,jj,jk) ) )
+ xpar (ji,jj,jk) = MAX( zparr(ji,jj,jk) + zparg(ji,jj,jk), 1.e-15 )
+ END DO
+ END DO
+ END DO
+
+ ! 3. Determination of euphotic layer depth
+ ! ----------------------------------------
+
+ ! Euphotic layer bottom level
+ neln(:,:) = 1 ! initialisation of EL level
+ DO jk = 1, jpkm1
+ DO jj = 1, jpj
+ DO ji = 1, jpi
+ IF( xpar(ji,jj,jk) >= zpar100(ji,jj) ) neln(ji,jj) = jk+1 ! 1rst T-level strictly below EL bottom
+ ! ! nb. this is to ensure compatibility with
+ ! ! nmld_trc definition in trd_mld_trc_zint
+ END DO
+ END DO
+ ENDDO
+
+ ! Euphotic layer depth
+ !! Jpalm -- 06-03-2017 -- add init xze, to avoid halo problems within the
+ !! writing process
+ xze(:,:) = 0.0
+ DO jj = 1, jpj
+ DO ji = 1, jpi
+ xze(ji,jj) = fsdepw( ji, jj, neln(ji,jj) ) ! exact EL depth
+ END DO
+ ENDDO
+
+ IF(ln_ctl) THEN ! print mean trends (used for debugging)
+ WRITE(charout, FMT="('opt')")
+ CALL prt_ctl_trc_info(charout)
+ CALL prt_ctl_trc( tab4d=trn, mask=tmask, clinfo=ctrcnm )
+ ENDIF
+
+ END SUBROUTINE trc_opt_medusa
+
+#else
+ !!======================================================================
+ !! Dummy module : No MEDUSA bio-model
+ !!======================================================================
+CONTAINS
+ SUBROUTINE trc_opt_medusa( kt ) ! Empty routine
+ INTEGER, INTENT( in ) :: kt
+ WRITE(*,*) 'trc_opt_medusa: You should not have seen this print! error?', kt
+ END SUBROUTINE trc_opt_medusa
+#endif
+
+ !!======================================================================
+END MODULE trcopt_medusa
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcoxy_medusa.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcoxy_medusa.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcoxy_medusa.F90 (revision 8155)
@@ -0,0 +1,280 @@
+MODULE trcoxy_medusa
+ !!======================================================================
+ !! *** MODULE trcoxy_medusa ***
+ !! TOP : MEDUSA
+ !!======================================================================
+ !! History :
+ !! - ! 2011-07 (A. Yool) added for ROAM project
+ !!----------------------------------------------------------------------
+#if defined key_medusa && defined key_roam
+ !!----------------------------------------------------------------------
+ !! MEDUSA oxygen cycle
+ !!----------------------------------------------------------------------
+ !! trc_oxy_medusa :
+ !!----------------------------------------------------------------------
+ USE oce_trc
+ USE trc
+ USE sms_medusa
+ USE lbclnk
+ USE prtctl_trc ! Print control for debugging
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_oxy_medusa ! called in trc_bio_medusa
+ PUBLIC oxy_sato ! called in trc_bio_medusa
+
+ !!* Substitution
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+! The following is a map of the subroutines contained within this module
+! - trc_oxy_medusa
+! - CALLS oxy_schmidt
+! - CALLS oxy_sato
+
+CONTAINS
+
+!=======================================================================
+!
+ SUBROUTINE trc_oxy_medusa( pt, ps, kw660, pp0, o2, & !! inputs
+ kwo2, o2flux, o2sat ) !! outputs
+!
+!=======================================================================
+ !!
+ !! Title : Calculates O2 change due to air-sea gas exchange
+ !! Author : Andrew Yool
+ !! Date : 15/10/04 (revised 08/07/11)
+ !!
+ !! This subroutine calculates oxygen air-sea gas exchange in the
+ !! surface layer of the ocean. The formulation is taken from one
+ !! written by Ray Najjar for the OCMIP-2 project. The routine
+ !! calls two other subroutines, oxy_schmidt.f (calculates Schmidt
+ !! number of oxygen) and oxy_sato.f (calculates oxygen saturation
+ !! concentration at 1 atm).
+ !!
+ !! AXY (23/06/15): revised to allow common gas transfer velocity
+ !! to be used for CO2 and O2; outputs of this
+ !! routine amended to mmol/m3 from mol/m3
+ !!
+ !! Function inputs are (in order) :
+ !! pt temperature (degrees C)
+ !! ps salinity (PSU)
+ !! kw660 gas transfer velocity (m/s)
+ !! pp0 surface pressure (divided by 1 atm)
+ !! o2 surface O2 concentration (mmol/m3)
+ !! (+) kwo2 gas transfer velocity for O2 (m/s)
+ !! (*) o2flux exchange rate of oxygen (mmol/m2/s)
+ !! (+) o2sat oxygen saturation concentration (mmol/m3)
+ !!
+ !! Where (*) is the function output (note its units).
+ !!
+!=======================================================================
+
+ implicit none
+!
+ REAL(wp), INTENT( in ) :: pt
+ REAL(wp), INTENT( in ) :: ps
+ REAL(wp), INTENT( in ) :: kw660
+ REAL(wp), INTENT( in ) :: pp0
+ REAL(wp), INTENT( in ) :: o2
+ REAL(wp), INTENT( out ) :: kwo2, o2flux, o2sat
+!
+ REAL(wp) :: o2schmidt, o2sato, mol_o2
+!
+! Oxygen to mol / m3
+!
+ mol_o2 = o2 / 1000.
+!
+! Calculate oxygen Schmidt number
+!
+ call oxy_schmidt(pt, o2schmidt)
+!
+! Calculate the transfer velocity for O2 (m/s)
+!
+ kwo2 = kw660 * (660 / o2schmidt)**0.5
+!
+! Calculate the saturation concentration for oxygen (mol/m3)
+!
+ call oxy_sato(pt, ps, o2sato)
+ o2sat = o2sato * pp0
+!
+! Calculate time rate of change of O2 due to gas exchange (mol/m3/s)
+!
+ o2flux = kwo2 * (o2sat - mol_o2)
+!
+! Oxygen flux and saturation to mmol / m3
+!
+ o2sat = o2sat * 1000.
+ o2flux = o2flux * 1000.
+!
+ END SUBROUTINE trc_oxy_medusa
+
+!=======================================================================
+!=======================================================================
+!=======================================================================
+
+!=======================================================================
+!
+ SUBROUTINE oxy_schmidt( pt, & !! input
+ o2_schmidt ) !! output
+!
+!=======================================================================
+ !!
+ !! Title : Calculates Schmidt number for ocean uptake of O2
+ !! Author : Andrew Yool
+ !! Date : 14/10/04 (revised 08/07/11)
+ !!
+ !! This subroutine calculates the Schmidt number for O2 using sea
+ !! surface temperature. The code is based upon that developed as
+ !! part of the OCMIP-2 project (1998-2000). The coefficients used
+ !! are taken from Keeling et al. (1998, GBC, 12, 141-163).
+ !!
+ !! AXY (23/06/2015)
+ !! UPDATED: revised formulation from Wanninkhof (2014) for
+ !! consistency with MOCSY
+ !!
+ !! Winninkhof, R. (2014). Relationship between wind speed and gas
+ !! exchange over the ocean revisited. LIMNOLOGY AND OCEANOGRAPHY-METHODS
+ !! 12, 351-362, doi:10.4319/lom.2014.12.351
+ !!
+ !! Function inputs are (in order) :
+ !! t temperature (degrees C)
+ !! (*) o2_schmidt oxygen Schmidt number
+ !!
+ !! Where (*) is the function output.
+ !!
+!=======================================================================
+
+ implicit none
+!
+ REAL(wp) :: pt, o2_schmidt
+ REAL(wp) :: a0, a1, a2, a3, a4
+!
+! AXY (23/06/15): OCMIP-2 coefficients
+! data a0 / 1638.0 /
+! data a1 / -81.83 /
+! data a2 / 1.483 /
+! data a3 / -0.008004 /
+!
+! AXY (23/06/15): Wanninkhof (2014) coefficients
+ data a0 / 1920.4 /
+ data a1 / -135.6 /
+ data a2 / 5.2121 /
+ data a3 / -0.10939 /
+ data a4 / 0.00093777 /
+!
+! o2_schmidt = a0 + pt*(a1 + pt*(a2 + pt*a3))
+ o2_schmidt = a0 + pt*(a1 + pt*(a2 + pt*(a3 + pt*a4)))
+!
+ END SUBROUTINE oxy_schmidt
+
+!=======================================================================
+!=======================================================================
+!=======================================================================
+
+!=======================================================================
+!
+ SUBROUTINE oxy_sato( pt, ps, & !! inputs
+ o2_sato ) !! output
+!
+!=======================================================================
+ !!
+ !! Title : Calculates O2 saturation at 1 atm pressure
+ !! Author : Andrew Yool
+ !! Date : 14/10/04 (revised 08/07/11)
+ !!
+ !! This subroutine calculates the oxygen saturation concentration
+ !! at 1 atmosphere pressure in mol/m3 given ambient temperature
+ !! and salinity. This formulation is (ostensibly) taken from
+ !! Garcia & Gordon (1992, L&O, 1307-1312). The function works
+ !! in the range -1.9 <= T <= 40, 0 <= S <= 42.
+ !!
+ !! Function inputs are (in order) :
+ !! pt temperature (degrees C)
+ !! ps salinity (PSU)
+ !! (*) o2_sato oxygen saturation (mol/m3)
+ !!
+ !! Where (*) is the function output (note its units).
+ !!
+ !! Check value : T = 10, S = 35, oxy_sato = 0.282015 mol/m3
+ !!
+!=======================================================================
+
+ implicit none
+!
+ REAL(wp) :: pt, ps, o2_sato
+!
+ REAL(wp) :: a0, a1, a2, a3, a4, a5
+ REAL(wp) :: b0, b1, b2, b3
+ REAL(wp) :: c0
+!
+ REAL(wp) :: tt, tk, ts, ts2, ts3, ts4, ts5
+ REAL(wp) :: ans1, ans2
+!
+ data a0 / 2.00907 /
+ data a1 / 3.22014 /
+ data a2 / 4.05010 /
+ data a3 / 4.94457 /
+ data a4 / -2.56847E-1 /
+ data a5 / 3.88767 /
+!
+ data b0 / -6.24523E-3 /
+ data b1 / -7.37614E-3 /
+ data b2 / -1.03410E-2 /
+ data b3 / -8.17083E-3 /
+!
+ data c0 / -4.88682E-7 /
+!
+ tt = 298.15 - pt
+ tk = 273.15 + pt
+ ts = log(tt / tk)
+ ts2 = ts**2
+ ts3 = ts**3
+ ts4 = ts**4
+ ts5 = ts**5
+ ans1 = a0 + a1*ts + a2*ts2 + a3*ts3 + a4*ts4 + a5*ts5 &
+ + ps*(b0 + b1*ts + b2*ts2 + b3*ts3) &
+ + c0*(ps*ps)
+ ans2 = exp(ans1)
+!
+! Convert from ml/l to mol/m3
+!
+ o2_sato = (ans2 / 22391.6) * 1000.0
+!
+ END SUBROUTINE oxy_sato
+
+!=======================================================================
+!=======================================================================
+!=======================================================================
+
+#else
+ !!======================================================================
+ !! Dummy module : No MEDUSA bio-model
+ !!======================================================================
+
+CONTAINS
+
+ SUBROUTINE trc_oxy_medusa( pt, ps, kw660, pp0, o2, & !! inputs
+ o2flux, o2sat ) !! outputs
+ USE par_kind
+
+ REAL(wp), INTENT( in ) :: pt
+ REAL(wp), INTENT( in ) :: ps
+ REAL(wp), INTENT( in ) :: kw660
+ REAL(wp), INTENT( in ) :: pp0
+ REAL(wp), INTENT( in ) :: o2
+ REAL(wp), INTENT( inout ) :: o2flux, o2sat
+
+ WRITE(*,*) 'trc_oxy_medusa: You should not have seen this print! error?', kt
+
+ END SUBROUTINE trc_oxy_medusa
+#endif
+
+ !!======================================================================
+END MODULE trcoxy_medusa
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcrst_medusa.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcrst_medusa.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcrst_medusa.F90 (revision 8155)
@@ -0,0 +1,306 @@
+MODULE trcrst_medusa
+ !!======================================================================
+ !! *** MODULE trcrst_medusa ***
+ !! TOP : create, write, read the restart files of MEDUSA tracer
+ !!======================================================================
+ !! History : 1.0 ! 2010-01 (C. Ethe) Original
+ !! 1.1 ! 2014-07 (A. Yool; J. Palmieri) converted for MEDUSA
+ !! 1.2 ! 2015-07 (A. Yool) add averaged fields for DMS
+ !!----------------------------------------------------------------------
+#if defined key_medusa
+ !!----------------------------------------------------------------------
+ !! 'key_medusa' medusa tracers
+ !!----------------------------------------------------------------------
+ !! trc_rst_read_medusa : read restart file
+ !! trc_rst_wri_medusa : write restart file
+ !!----------------------------------------------------------------------
+ USE oce_trc ! Ocean variables
+ USE par_trc ! TOP parameters
+ USE trc ! TOP variables
+ USE trcsms_medusa ! MEDUSA sms trends
+ USE sms_medusa ! MEDUSA sms trends
+ USE iom
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_rst_read_medusa ! called by trcini.F90 module (actually trcrst.F90)
+ PUBLIC trc_rst_wri_medusa ! called by trcini.F90 module (actually trcrst.F90)
+
+CONTAINS
+
+ SUBROUTINE trc_rst_read_medusa( knum )
+ !!----------------------------------------------------------------------
+ !! *** trc_rst_read_medusa ***
+ !!
+ !! ** Purpose : Read in restart file specific variables from medusa model
+ !!
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT(in) :: knum ! unit of the restart file
+ !! AXY (07/07/14): temporary variables
+ REAL(wp) :: fq0,fq1,fq2
+ !!----------------------------------------------------------------------
+
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) ' trc_rst_read_medusa : Read specific variables from medusa model '
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~'
+
+ !! AXY (07/07/14): remove LOBSTER calls
+ !! CALL iom_get( knum, jpdom_autoglo, 'SEDB'//ctrcnm(jp_lob_det), sedpocb(:,:) )
+ !! CALL iom_get( knum, jpdom_autoglo, 'SEDN'//ctrcnm(jp_lob_det), sedpocn(:,:) )
+
+ !! AXY (07/07/14): as well as passive tracers, the restart files
+ !! contain 2D fields of sediments; these need to
+ !! be read in specially; hence this routine
+ !!
+ !! AXY (13/01/12): check if the restart contains sediment fields;
+ !! this is only relevant for simulations that include
+ !! biogeochemistry and are restarted from earlier runs
+ !! in which there was no sediment component
+ !!
+ IF( iom_varid( knum, 'B_SED_N', ldstop = .FALSE. ) > 0 ) THEN
+ !! YES; in which case read them
+ !!
+ IF(lwp) WRITE(numout,*) ' MEDUSA sediment fields present - reading in ...'
+ CALL iom_get( knum, jpdom_autoglo, 'B_SED_N', zb_sed_n(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'N_SED_N', zn_sed_n(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'B_SED_FE', zb_sed_fe(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'N_SED_FE', zn_sed_fe(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'B_SED_SI', zb_sed_si(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'N_SED_SI', zn_sed_si(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'B_SED_C', zb_sed_c(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'N_SED_C', zn_sed_c(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'B_SED_CA', zb_sed_ca(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'N_SED_CA', zn_sed_ca(:,:) )
+ ELSE
+ !! NO; in which case set them to zero
+ !!
+ IF(lwp) WRITE(numout,*) ' MEDUSA sediment fields absent - setting to zero ...'
+ zb_sed_n(:,:) = 0.0 !! organic N
+ zn_sed_n(:,:) = 0.0
+ zb_sed_fe(:,:) = 0.0 !! organic Fe
+ zn_sed_fe(:,:) = 0.0
+ zb_sed_si(:,:) = 0.0 !! inorganic Si
+ zn_sed_si(:,:) = 0.0
+ zb_sed_c(:,:) = 0.0 !! organic C
+ zn_sed_c(:,:) = 0.0
+ zb_sed_ca(:,:) = 0.0 !! inorganic C
+ zn_sed_ca(:,:) = 0.0
+ ENDIF
+ !!
+ !! calculate stats on these fields
+ IF(lwp) WRITE(numout,*) ' MEDUSA sediment field stats (min, max, sum) ...'
+ fq0 = MINVAL(zn_sed_n(:,:))
+ fq1 = MAXVAL(zn_sed_n(:,:))
+ fq2 = SUM(zn_sed_n(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'Sediment N ', &
+ & fq0, fq1, fq2
+ fq0 = MINVAL(zn_sed_fe(:,:))
+ fq1 = MAXVAL(zn_sed_fe(:,:))
+ fq2 = SUM(zn_sed_fe(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'Sediment Fe ', &
+ & fq0, fq1, fq2
+ fq0 = MINVAL(zn_sed_si(:,:))
+ fq1 = MAXVAL(zn_sed_si(:,:))
+ fq2 = SUM(zn_sed_si(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'Sediment Si ', &
+ & fq0, fq1, fq2
+ fq0 = MINVAL(zn_sed_c(:,:))
+ fq1 = MAXVAL(zn_sed_c(:,:))
+ fq2 = SUM(zn_sed_c(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'Sediment C ', &
+ & fq0, fq1, fq2
+ fq0 = MINVAL(zn_sed_ca(:,:))
+ fq1 = MAXVAL(zn_sed_ca(:,:))
+ fq2 = SUM(zn_sed_ca(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'Sediment Ca ', &
+ & fq0, fq1, fq2
+
+ !! AXY (07/07/15): read in temporally averaged fields for DMS
+ !! calculations
+ !!
+ IF( iom_varid( knum, 'B_DMS_CHN', ldstop = .FALSE. ) > 0 ) THEN
+ !! YES; in which case read them
+ !!
+ IF(lwp) WRITE(numout,*) ' MEDUSA averaged properties for DMS present - reading in ...'
+ CALL iom_get( knum, jpdom_autoglo, 'B_DMS_CHN', zb_dms_chn(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'N_DMS_CHN', zn_dms_chn(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'B_DMS_CHD', zb_dms_chd(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'N_DMS_CHD', zn_dms_chd(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'B_DMS_MLD', zb_dms_mld(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'N_DMS_MLD', zn_dms_mld(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'B_DMS_QSR', zb_dms_qsr(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'N_DMS_QSR', zn_dms_qsr(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'B_DMS_DIN', zb_dms_din(:,:) )
+ CALL iom_get( knum, jpdom_autoglo, 'N_DMS_DIN', zn_dms_din(:,:) )
+ ELSE
+ !! NO; in which case set them to zero
+ !!
+ IF(lwp) WRITE(numout,*) ' MEDUSA averaged properties for DMS absent - setting to zero ...'
+ zb_dms_chn(:,:) = 0.0 !! CHN
+ zn_dms_chn(:,:) = 0.0
+ zb_dms_chd(:,:) = 0.0 !! CHD
+ zn_dms_chd(:,:) = 0.0
+ zb_dms_mld(:,:) = 0.0 !! MLD
+ zn_dms_mld(:,:) = 0.0
+ zb_dms_qsr(:,:) = 0.0 !! QSR
+ zn_dms_qsr(:,:) = 0.0
+ zb_dms_din(:,:) = 0.0 !! DIN
+ zn_dms_din(:,:) = 0.0
+ ENDIF
+ !!
+ !! calculate stats on these fields
+ IF(lwp) WRITE(numout,*) ' MEDUSA averaged properties for DMS stats (min, max, sum) ...'
+ fq0 = MINVAL(zn_dms_chn(:,:))
+ fq1 = MAXVAL(zn_dms_chn(:,:))
+ fq2 = SUM(zn_dms_chn(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'DMS, CHN ', fq0, fq1, fq2
+ fq0 = MINVAL(zn_dms_chd(:,:))
+ fq1 = MAXVAL(zn_dms_chd(:,:))
+ fq2 = SUM(zn_dms_chd(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'DMS, CHD ', fq0, fq1, fq2
+ fq0 = MINVAL(zn_dms_mld(:,:))
+ fq1 = MAXVAL(zn_dms_mld(:,:))
+ fq2 = SUM(zn_dms_mld(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'DMS, MLD ', fq0, fq1, fq2
+ fq0 = MINVAL(zn_dms_qsr(:,:))
+ fq1 = MAXVAL(zn_dms_qsr(:,:))
+ fq2 = SUM(zn_dms_qsr(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'DMS, QSR ', fq0, fq1, fq2
+ fq0 = MINVAL(zn_dms_din(:,:))
+ fq1 = MAXVAL(zn_dms_din(:,:))
+ fq2 = SUM(zn_dms_din(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'DMS, DIN ', fq0, fq1, fq2
+
+ END SUBROUTINE trc_rst_read_medusa
+
+ SUBROUTINE trc_rst_wri_medusa( kt, kitrst, knum )
+ !!----------------------------------------------------------------------
+ !! *** trc_rst_read_medusa ***
+ !!
+ !! ** Purpose : Read in restart file specific variables from medusa model
+ !!
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT(in) :: kt ! time step
+ INTEGER, INTENT(in) :: kitrst ! time step of restart write
+ INTEGER, INTENT(in) :: knum ! unit of the restart file
+ !! AXY (07/07/14): temporary variables
+ REAL(wp) :: fq0,fq1,fq2
+ !!----------------------------------------------------------------------
+
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) ' trc_rst_wri_medusa : Write specific variables from medusa model '
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~'
+
+ !! AXY (07/07/14): remove LOBSTER calls
+ !! CALL iom_rstput( kt, kitrst, knum, 'SEDB'//ctrcnm(jp_lob_det), sedpocb(:,:) )
+ !! CALL iom_rstput( kt, kitrst, knum, 'SEDN'//ctrcnm(jp_lob_det), sedpocn(:,:) )
+
+ !! AXY (07/07/14): as well as passive tracers, the restart files
+ !! contain 2D fields of sediments; these need to
+ !! be written out specially; hence this routine
+ !!
+ !! AXY (13/01/12): write out "before" and "now" state of seafloor
+ !! sediment pools into restart; this happens
+ !! whether or not the pools are to be used by
+ !! MEDUSA (which is controlled by a switch in the
+ !! namelist_top file)
+ !!
+ IF(lwp) WRITE(numout,*) ' MEDUSA sediment fields - writing out ...'
+ CALL iom_rstput( kt, kitrst, knum, 'B_SED_N', zb_sed_n(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'N_SED_N', zn_sed_n(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'B_SED_FE', zb_sed_fe(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'N_SED_FE', zn_sed_fe(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'B_SED_SI', zb_sed_si(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'N_SED_SI', zn_sed_si(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'B_SED_C', zb_sed_c(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'N_SED_C', zn_sed_c(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'B_SED_CA', zb_sed_ca(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'N_SED_CA', zn_sed_ca(:,:) )
+ !!
+ !! calculate stats on these fields
+ IF(lwp) WRITE(numout,*) ' MEDUSA sediment field stats (min, max, sum) ...'
+ fq0 = MINVAL(zn_sed_n(:,:))
+ fq1 = MAXVAL(zn_sed_n(:,:))
+ fq2 = SUM(zn_sed_n(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'Sediment N ', &
+ & fq0, fq1, fq2
+ fq0 = MINVAL(zn_sed_fe(:,:))
+ fq1 = MAXVAL(zn_sed_fe(:,:))
+ fq2 = SUM(zn_sed_fe(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'Sediment Fe ', &
+ & fq0, fq1, fq2
+ fq0 = MINVAL(zn_sed_si(:,:))
+ fq1 = MAXVAL(zn_sed_si(:,:))
+ fq2 = SUM(zn_sed_si(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'Sediment Si ', &
+ & fq0, fq1, fq2
+ fq0 = MINVAL(zn_sed_c(:,:))
+ fq1 = MAXVAL(zn_sed_c(:,:))
+ fq2 = SUM(zn_sed_c(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'Sediment C ', &
+ & fq0, fq1, fq2
+ fq0 = MINVAL(zn_sed_ca(:,:))
+ fq1 = MAXVAL(zn_sed_ca(:,:))
+ fq2 = SUM(zn_sed_ca(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'Sediment Ca ', &
+ & fq0, fq1, fq2
+
+ !! AXY (07/07/15): write out temporally averaged fields for DMS
+ !! calculations
+ !!
+ IF(lwp) WRITE(numout,*) ' MEDUSA averaged properties for DMS - writing out ...'
+ CALL iom_rstput( kt, kitrst, knum, 'B_DMS_CHN', zb_dms_chn(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'N_DMS_CHN', zn_dms_chn(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'B_DMS_CHD', zb_dms_chd(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'N_DMS_CHD', zn_dms_chd(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'B_DMS_MLD', zb_dms_mld(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'N_DMS_MLD', zn_dms_mld(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'B_DMS_QSR', zb_dms_qsr(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'N_DMS_QSR', zn_dms_qsr(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'B_DMS_DIN', zb_dms_din(:,:) )
+ CALL iom_rstput( kt, kitrst, knum, 'N_DMS_DIN', zn_dms_din(:,:) )
+ !!
+ !! calculate stats on these fields
+ IF(lwp) WRITE(numout,*) ' MEDUSA averaged properties for DMS stats (min, max, sum) ...'
+ fq0 = MINVAL(zn_dms_chn(:,:))
+ fq1 = MAXVAL(zn_dms_chn(:,:))
+ fq2 = SUM(zn_dms_chn(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'DMS, CHN ', fq0, fq1, fq2
+ fq0 = MINVAL(zn_dms_chd(:,:))
+ fq1 = MAXVAL(zn_dms_chd(:,:))
+ fq2 = SUM(zn_dms_chd(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'DMS, CHD ', fq0, fq1, fq2
+ fq0 = MINVAL(zn_dms_mld(:,:))
+ fq1 = MAXVAL(zn_dms_mld(:,:))
+ fq2 = SUM(zn_dms_mld(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'DMS, MLD ', fq0, fq1, fq2
+ fq0 = MINVAL(zn_dms_qsr(:,:))
+ fq1 = MAXVAL(zn_dms_qsr(:,:))
+ fq2 = SUM(zn_dms_qsr(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'DMS, QSR ', fq0, fq1, fq2
+ fq0 = MINVAL(zn_dms_din(:,:))
+ fq1 = MAXVAL(zn_dms_din(:,:))
+ fq2 = SUM(zn_dms_din(:,:))
+ if (lwp) write (numout,'(a,3f15.5)') 'DMS, DIN ', fq0, fq1, fq2
+
+ END SUBROUTINE trc_rst_wri_medusa
+
+#else
+ !!----------------------------------------------------------------------
+ !! Dummy module : No passive tracer
+ !!----------------------------------------------------------------------
+CONTAINS
+ SUBROUTINE trc_rst_read_medusa( knum )
+ INTEGER, INTENT(in) :: knum
+ WRITE(*,*) 'trc_rst_wri_medusa: You should not have seen this print! error?',knum
+ END SUBROUTINE trc_rst_read_medusa
+
+ SUBROUTINE trc_rst_wri_medusa( kt, kitrst, knum )
+ INTEGER, INTENT(in) :: kt, kitrst, knum
+ WRITE(*,*) 'trc_rst_wri_medusa: You should not have seen this print! error?', kt, kitrst, knum
+ END SUBROUTINE trc_rst_wri_medusa
+#endif
+
+ !!======================================================================
+END MODULE trcrst_medusa
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcsed_medusa.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcsed_medusa.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcsed_medusa.F90 (revision 8155)
@@ -0,0 +1,451 @@
+MODULE trcsed_medusa
+ !!======================================================================
+ !! *** MODULE trcsed_medusa ***
+ !! TOP : MEDUSA Compute loss of organic matter in the sediments
+ !!======================================================================
+ !! History : - ! 1995-06 (M. Levy) original code
+ !! - ! 2000-12 (E. Kestenare) clean up
+ !! 2.0 ! 2007-12 (C. Deltel, G. Madec) F90 + simplifications
+ !! - ! 2008-08 (K. Popova) adaptation for MEDUSA
+ !! - ! 2008-11 (A. Yool) continuing adaptation for MEDUSA
+ !! - ! 2010-03 (A. Yool) updated for branch inclusion
+ !! - ! 2011-04 (A. Yool) updated for ROAM project
+ !!----------------------------------------------------------------------
+#if defined key_medusa
+ !!----------------------------------------------------------------------
+ !! 'key_medusa' MEDUSA bio-model
+ !!----------------------------------------------------------------------
+ !! trc_sed_medusa : Compute loss of organic matter in the sediments
+ !!----------------------------------------------------------------------
+ USE oce_trc !
+ USE trc
+ USE sms_medusa
+ !! AXY (10/02/09)
+ USE iom
+ !! USE trc_nam_dia ! JPALM 13-11-2015 -- if iom_use for diag
+ !! USE trc_nam_iom_medusa ! JPALM 13-11-2015 -- if iom_use for diag
+ USE fldread ! time interpolation
+ USE lbclnk
+ USE prtctl_trc ! Print control for debbuging
+ !! JPALM (27-06-2016): add lk_oasis for CO2 and DMS coupling with atm
+ USE sbc_oce, ONLY: lk_oasis
+ USE oce, ONLY: Dust_in_cpl
+ !! Check Dust dep
+# if defined key_debug_medusa
+ !! USE trcrst, ONLY: trc_rst_dia_stat !! variable stat
+# endif
+
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_sed_medusa ! called in ???
+ PUBLIC trc_sed_medusa_sbc
+ PUBLIC trc_sed_medusa_dust
+
+ !! * Module variables
+ INTEGER :: &
+ ryyss, & !: number of seconds per year
+ rmtss !: number of seconds per month
+
+ !! AXY (10/02/09)
+ LOGICAL, PUBLIC :: bdustfer !: boolean for dust input from the atmosphere
+ REAL(wp), PUBLIC :: &
+ sedfeinput = 1.e-9_wp , &
+ dustsolub = 0.014_wp
+ REAL(wp), PARAMETER :: Fe_dust_mratio = 0.035 !! Fe:dust mass ratio = 0.035
+ INTEGER , PARAMETER :: nbtimes = 365 !: maximum number of times record in a file
+ INTEGER :: ntimes_dust ! number of time steps in a file
+
+ INTEGER :: &
+ numdust, &
+ nflx1, nflx2, &
+ nflx11, nflx12
+
+ TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_dust ! structure of input dust
+
+
+ !!* Substitution
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+CONTAINS
+
+ SUBROUTINE trc_sed_medusa( kt )
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE trc_sed_medusa ***
+ !!
+ !! ** Purpose : compute the now trend due to the vertical sedimentation of
+ !! detritus and add it to the general trend of detritus equations
+ !!
+ !! ** Method : this ROUTINE compute not exactly the advection but the
+ !! transport term, i.e. dz(wt) and dz(ws)., dz(wtr)
+ !! using an upstream scheme
+ !! the now vertical advection of tracers is given by:
+ !! dz(trn wn) = 1/bt dk+1( e1t e2t vsed (trn) )
+ !! add this trend now to the general trend of tracer (ta,sa,tra):
+ !! tra = tra + dz(trn wn)
+ !!
+ !! IF 'key_trc_diabio' is defined, the now vertical advection
+ !! trend of passive tracers is saved for futher diagnostics.
+ !!---------------------------------------------------------------------
+ INTEGER, INTENT( in ) :: kt ! ocean time-step index
+ !! AXY (10/02/09)
+ INTEGER :: jnt
+ !!
+ INTEGER :: ji, jj, jk
+ REAL(wp) :: ztra
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwork
+
+ !! AXY (10/02/09)
+ REAL(wp) :: rfact2
+
+ CHARACTER (len=25) :: charout
+
+ !! JPALM - 26-11-2015 -add iom_use for diagnostic
+ REAL(wp), POINTER, DIMENSION(:,: ) :: zw2d
+ !!---------------------------------------------------------------------
+ !!
+ IF( lk_iomput) THEN
+ IF( med_diag%DSED%dgsave ) THEN
+ CALL wrk_alloc( jpi, jpj, zw2d )
+ zw2d(:,:) = 0.0 !!
+ ENDIF
+ ENDIF
+
+ !! AXY (10/02/09)
+ jnt = 1
+ rfact2 = 1.0
+
+ ! Number of seconds per year and per month
+ ryyss = nyear_len(1) * rday
+ rmtss = ryyss / raamo
+
+ !! AXY (20/11/14): alter this to report on first MEDUSA call
+ IF( kt == nittrc000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) ' trc_sed_medusa: MEDUSA sedimentation'
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~'
+ IF(lwp) WRITE(numout,*) ' kt =',kt
+ ENDIF
+
+ ! sedimentation of detrital nitrogen : upstream scheme
+ ! ----------------------------------------------------
+ !
+ zwork(:,:,:) = 0.e0 ! initialisation of sinking variable
+ ! for detrital nitrogen sedimentation only - jpdet
+ zwork(:,:,1 ) = 0.e0 ! surface value set to zero
+ !! DO ji = 1, jpi
+ !! zirondep(ji,jj,1) = (dustsolub * dust(ji,jj) / (55.85 * rmtss) + 3.e-10 / ryyss) &
+ !! & * rfact2 / fse3t(ji,jj,1)
+ !! zsidep (ji,jj) = 8.8 * 0.075 * dust(ji,jj) * rfact2 / &
+ !! & (fse3t(ji,jj,1) * 28.1 * rmtss)
+ !! END DO
+ !! END DO
+
+ ! sedimentation of detrital nitrogen : upstream scheme
+ ! ----------------------------------------------------
+ !
+ zwork(:,:,:) = 0.e0 ! initialisation of sinking variable
+ ! for detrital nitrogen sedimentation only - jpdet
+ zwork(:,:,1 ) = 0.e0 ! surface value set to zero
+ zwork(:,:,jpk) = 0.e0 ! bottom value set to zero
+ !
+ ! tracer flux at w-point: we use -vsed (downward flux) with simplification : no e1*e2
+ DO jk = 2, jpk
+ ! AXY (17/07/14): change "0.d0" to "0."
+ ! zwork(:,:,jk) = -vsed * max(trn(:,:,jk-1,jpdet),0.d0) * tmask(:,:,jk-1)
+ zwork(:,:,jk) = -vsed * max(trn(:,:,jk-1,jpdet),0.) * tmask(:,:,jk-1)
+ !
+ ! AXY (16/01/14): stop sinking in upper 10m to reduce model instability
+ ! in shallower grid cells
+ ! if ( jk .lt. 9 ) zwork(:,:,jk) = 0.e0
+ END DO
+ !
+ ! tracer flux divergence at t-point added to the general trend
+ DO jk = 1, jpkm1
+ DO jj = 1, jpj
+ DO ji = 1,jpi
+ ztra = - ( zwork(ji,jj,jk) - zwork(ji,jj,jk+1) ) / fse3t(ji,jj,jk)
+ tra(ji,jj,jk,jpdet) = tra(ji,jj,jk,jpdet) + ztra
+# if defined key_trc_diabio
+ trbio(ji,jj,jk,8) = ztra
+# endif
+ IF (lk_iomput .AND. .NOT. ln_diatrc) THEN
+ IF( med_diag%DSED%dgsave ) THEN
+ zw2d(ji,jj) = zw2d(ji,jj) + ztra * fse3t(ji,jj,jk) * 86400.
+ ENDIF
+ ELSE IF( ln_diatrc ) THEN
+ trc2d(ji,jj,8) = trc2d(ji,jj,8) + ztra * fse3t(ji,jj,jk) * 86400.
+ ENDIF
+
+ END DO
+ END DO
+ END DO
+ !
+# if defined key_trc_diabio
+ CALL lbc_lnk (trbio(:,:,1,8), 'T', 1. ) ! Lateral boundary conditions on trcbio
+# endif
+ IF( ln_diatrc ) CALL lbc_lnk( trc2d(:,:,8), 'T', 1. ) ! Lateral boundary conditions on trc2d
+ !!
+ IF (lk_iomput .AND. .NOT. ln_diatrc) THEN
+ IF( med_diag%DSED%dgsave ) THEN
+ CALL iom_put( "DSED" , zw2d)
+ CALL wrk_dealloc( jpi, jpj, zw2d )
+ ENDIF
+ ELSE IF (lk_iomput .AND. ln_diatrc) THEN
+ CALL iom_put( "DSED",trc2d(:,:,8) )
+ ENDIF
+ !!
+# if defined key_roam
+
+ ! sedimentation of detrital carbon : upstream scheme
+ ! --------------------------------------------------
+ !
+ zwork(:,:,:) = 0.e0 ! initialisation of sinking variable
+ ! for detrital carbon sedimentation only - jpdtc
+ zwork(:,:,1 ) = 0.e0 ! surface value set to zero
+ zwork(:,:,jpk) = 0.e0 ! bottom value set to zero
+ !
+ ! tracer flux at w-point: we use -vsed (downward flux) with simplification : no e1*e2
+ DO jk = 2, jpk
+ ! AXY (17/07/14): change "0.d0" to "0."
+ ! zwork(:,:,jk) = -vsed * max(trn(:,:,jk-1,jpdtc),0.d0) * tmask(:,:,jk-1)
+ zwork(:,:,jk) = -vsed * max(trn(:,:,jk-1,jpdtc),0.) * tmask(:,:,jk-1)
+ !
+ ! AXY (16/01/14): stop sinking in upper 10m to reduce model instability
+ ! in shallower grid cells
+ ! if ( jk .lt. 9 ) zwork(:,:,jk) = 0.e0
+ END DO
+ !
+ ! tracer flux divergence at t-point added to the general trend
+ DO jk = 1, jpkm1
+ DO jj = 1, jpj
+ DO ji = 1,jpi
+ ztra = - ( zwork(ji,jj,jk) - zwork(ji,jj,jk+1) ) / fse3t(ji,jj,jk)
+ tra(ji,jj,jk,jpdtc) = tra(ji,jj,jk,jpdtc) + ztra
+!! # if defined key_trc_diabio
+!! trbio(ji,jj,jk,8) = ztra
+!! # endif
+!! IF( ln_diatrc ) &
+!! & trc2d(ji,jj,8) = trc2d(ji,jj,8) + ztra * fse3t(ji,jj,jk) * 86400.
+ END DO
+ END DO
+ END DO
+ !
+!! # if defined key_trc_diabio
+!! CALL lbc_lnk (trbio(:,:,1,8), 'T', 1. ) ! Lateral boundary conditions on trcbio
+!! # endif
+!! IF( ln_diatrc ) CALL lbc_lnk( trc2d(:,:,8), 'T', 1. ) ! Lateral boundary conditions on trc2d
+!! # if defined key_iomput
+!! CALL iom_put( "DSED",trc2d(:,:,8) )
+!! # endif
+
+# endif
+
+ IF(ln_ctl) THEN ! print mean trends (used for debugging)
+ WRITE(charout, FMT="('sed')")
+ CALL prt_ctl_trc_info(charout)
+ CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm)
+ ENDIF
+
+ END SUBROUTINE trc_sed_medusa
+
+ !! ======================================================================
+ !! ======================================================================
+ !! ======================================================================
+
+ !! AXY (10/02/09)
+ !! JPALM -- 31-03-2016 -- Completely change trc_sed_medusa_sbc.
+ !! -- We now need to read dust file through a namelist.
+ !! To be able to use time varying dust depositions from
+ !! -- copy and adapt the PISCES p4z_sbc_ini subroutine
+ !! -- Only use the dust related part.
+ SUBROUTINE trc_sed_medusa_sbc(kt)
+
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE trc_sed_medusa_sbc ***
+ !!
+ !! ** Purpose : Read and dust namelist and files.
+ !! The interpolation is done in trc_sed through
+ !! "CALL fld_read( kt, 1, sf_dust )"
+ !!
+ !! ** Method : Read the sbc namelist, and the adapted dust file, if required
+ !! called at the first timestep (nittrc000)
+ !!
+ !! ** input : -- namelist sbc ref and cfg
+ !! -- external netcdf files
+ !!
+ !!----------------------------------------------------------------------
+ !! * arguments
+ INTEGER, INTENT( in ) :: kt ! ocean time step
+ INTEGER :: ji, jj, jk, jm, ifpr
+ INTEGER :: ii0, ii1, ij0, ij1
+ INTEGER :: numdust
+ INTEGER :: ierr
+ INTEGER :: jfld ! dummy loop arguments
+ INTEGER :: ios ! Local integer output status for namelist read
+ INTEGER :: isrow ! index for ORCA1 starting row
+ REAL(wp) :: ztimes_dust
+ REAL(wp), DIMENSION(nbtimes) :: zsteps ! times records
+ REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zdust
+ !
+ CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files
+ TYPE(FLD_N), DIMENSION(1) :: slf_d ! array of namelist informations on the fields to read
+ TYPE(FLD_N) :: sn_dust ! informations about the fields to be read
+ !
+ NAMELIST/nammedsbc/cn_dir, sn_dust, bdustfer
+
+ !!---------------------------------------------------------------------
+ !
+ IF( nn_timing == 1 ) CALL timing_start('trc_sed_medusa_sbc')
+ !
+ ! !* set file information
+ REWIND( numnatp_ref ) ! Namelist nammedsbc in reference namelist : MEDUSA external sources of Dust
+ READ ( numnatp_ref, nammedsbc, IOSTAT = ios, ERR = 901)
+901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammedsbc in reference namelist', lwp )
+
+ REWIND( numnatp_cfg ) ! Namelist nammedsbc in configuration namelist : MEDUSA external sources of Dust
+ READ ( numnatp_cfg, nammedsbc, IOSTAT = ios, ERR = 902 )
+902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammedsbc in configuration namelist', lwp )
+ IF(lwm) WRITE ( numonp, nammedsbc )
+
+ IF(lwp) THEN
+ WRITE(numout,*) ' '
+ WRITE(numout,*) ' namelist : nammedsbc '
+ WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~ '
+ WRITE(numout,*) ' dust input from the atmosphere bdustfer = ', bdustfer
+ END IF
+
+ ! dust input from the atmosphere
+ ! ------------------------------
+ IF( bdustfer ) THEN
+ !
+ IF(lwp) WRITE(numout,*) ' initialize dust input from atmosphere '
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
+ !
+ !! already allocated in sms_medusa
+ !!ALLOCATE( dust(jpi,jpj) ) ! allocation
+ !
+ slf_d(1) = sn_dust ! store namelist information in an array
+ !
+ ALLOCATE( sf_dust(1), STAT=ierr ) !* allocate and fill sf_sst (forcing structure) with sn_sst
+ IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'trc_sed_medusa_sbc: unable to allocate sf_dust structure' )
+ ALLOCATE( sf_dust(1)%fnow(jpi,jpj,1))
+ IF( slf_d(1)%ln_tint ) ALLOCATE( sf_dust(1)%fdta(jpi,jpj,1,2) )
+ !
+ CALL fld_fill( sf_dust, slf_d, cn_dir, 'trc_sed_medusa_sbc', 'Atmospheric dust deposition', 'nammedsed' )
+ !
+ CALL fld_read( kt, 1, sf_dust )
+ dust(:,:) = sf_dust(1)%fnow(:,:,1)
+ !
+ ELSEIF (lk_oasis) THEN
+ dust = Dust_in_cpl
+ ELSE
+ dust(:,:) = 0.0
+ END IF
+ !
+ zirondep(:,:) = 0.e0 !! Initialisation of deposition variables
+ zirondep(:,:) = dust(:,:) * Fe_dust_mratio / xfe_mass * 1.e6 * 86400. !! mmol-Fe/m2/d
+ !
+ IF( nn_timing == 1 ) CALL timing_stop('trc_sed_medusa_sbc')
+ !
+ END SUBROUTINE trc_sed_medusa_sbc
+
+ !! ======================================================================
+ !! ======================================================================
+ !! ======================================================================
+
+ !! AXY & JPALM (28/02/17)
+
+ SUBROUTINE trc_sed_medusa_dust( kt )
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE trc_sed_medusa_dust ***
+ !!
+ !! ** Purpose : compute current dust *before* trc_bio_medusa call
+ !!
+ !! ** Method : does what it says on the tin
+ !!---------------------------------------------------------------------
+ INTEGER, INTENT( in ) :: kt ! ocean time-step index
+
+ !! AXY (20/11/14): alter this to report on first MEDUSA call
+ IF( kt == nittrc000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) ' trc_sed_medusa_dust: MEDUSA dust timestep'
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~'
+ IF(lwp) WRITE(numout,*) ' kt =',kt
+ ENDIF
+
+ !! AXY (04/11/13): replace this with a call in trc_ini_medusa
+ !! AXY (25/02/10)
+ !! call routine for populating CCD array if this is the first time-step
+ !! IF( kt == nittrc000 ) CALL medusa_ccd( kt )
+
+ !! AXY (04/11/13): replace this with a call in trc_ini_medusa
+ !! AXY (26/01/12)
+ !! call routine for populating river arrays if this is the first time-step
+ !! IF( kt == nittrc000 ) CALL medusa_river( kt )
+
+ !! AXY (10/02/09)
+ !! IF( (jnt == 1) .and. (bdustfer) ) CALL trc_sed_medusa_sbc( kt )
+
+ !! JPALM -- 31-03-2016 -- rewrite trc_sed_medusa_sbc.
+ !! IF (kt == nittrc000 ) CALL trc_sed_medusa_sbc
+
+ !! JPALM -- 20-07-2016 -- adapt dust forcing fields reading and conversion
+ !! To read dust dep in kg-dust/m2/s instead of g-Fe/m2/month
+ !! So all forcings and coupling dust dep are in the same SI units
+ !! and then convert in mmol-Fe/m2/day
+
+ IF( bdustfer ) THEN
+ CALL fld_read( kt, 1, sf_dust )
+ dust(:,:) = sf_dust(1)%fnow(:,:,1)
+ ELSEIF (lk_oasis) THEN
+ dust = Dust_in_cpl
+ ELSE
+ dust(:,:) = 0.0
+ ENDIF
+ !!
+ zirondep(:,:) = 0.e0 !! Initialisation of deposition variables
+ zirondep(:,:) = dust(:,:) * Fe_dust_mratio / xfe_mass * 1.e6 * 86400. !! mmol-Fe/m2/d
+
+ !! JPALM -- 20-07-2016 -- Zirondep and zsidep are not used.
+ !! So comment out the following lines. but keep them
+ !! as we may want to used them later on
+ !!================================================
+ !!
+ !! zirondep(:,:,:) = 0.e0 !! Initialisation of deposition variables
+ !! zsidep (:,:) = 0.e0
+ !!
+ !! Iron and Si deposition at the surface
+ !! -------------------------------------
+ !!
+ !! DO jj = 1, jpj
+ !! DO ji = 1, jpi
+ !! zirondep(ji,jj,1) = (dustsolub * dust(ji,jj) / (55.85 * rmtss) + 3.e-10 / ryyss) &
+ !! & * rfact2 / fse3t(ji,jj,1)
+ !! zsidep (ji,jj) = 8.8 * 0.075 * dust(ji,jj) * rfact2 / &
+ !! & (fse3t(ji,jj,1) * 28.1 * rmtss)
+ !! END DO
+ !! END DO
+
+ END SUBROUTINE trc_sed_medusa_dust
+
+#else
+ !!======================================================================
+ !! Dummy module : No MEDUSA bio-model
+ !!======================================================================
+CONTAINS
+ SUBROUTINE trc_sed_medusa( kt ) ! Empty routine
+ INTEGER, INTENT( in ) :: kt
+ WRITE(*,*) 'trc_sed_medusa: You should not have seen this print! error?', kt
+ END SUBROUTINE trc_sed_medusa
+#endif
+
+ !!======================================================================
+END MODULE trcsed_medusa
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcsms_medusa.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcsms_medusa.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcsms_medusa.F90 (revision 8155)
@@ -0,0 +1,112 @@
+MODULE trcsms_medusa
+ !!======================================================================
+ !! *** MODULE trcsms_medusa ***
+ !! TOP : Main module of the MEDUSA tracers
+ !!======================================================================
+ !! History : 2.0 ! 2007-12 (C. Ethe, G. Madec) Original code
+ !! - ! 2008-08 (K. Popova) adaptation for MEDUSA
+ !! - ! 2008-11 (A. Yool) continuing adaptation for MEDUSA
+ !! - ! 2010-03 (A. Yool) updated for branch inclusion
+ !!----------------------------------------------------------------------
+#if defined key_medusa
+ !!----------------------------------------------------------------------
+ !! 'key_medusa' bio tracers
+ !!----------------------------------------------------------------------
+ !! trc_sms_medusa : MEDUSA_TRC model main routine
+ !!----------------------------------------------------------------------
+ USE par_trc ! TOP parameters
+ USE oce_trc
+ USE trc
+ USE trcbio_medusa
+ USE trcopt_medusa
+ USE trcsed_medusa
+ USE trcavg_medusa
+
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_sms_medusa ! called by trcsms.F90 module
+
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
+ !! $Id$
+ !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+ !!----------------------------------------------------------------------
+
+CONTAINS
+
+ SUBROUTINE trc_sms_medusa( kt )
+ !!----------------------------------------------------------------------
+ !! *** trc_sms_medusa ***
+ !!
+ !! ** Purpose : main routine of MEDUSA_TRC model
+ !!
+ !! ** Method : -
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT(in) :: kt ! ocean time-step index
+
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' MEDUSA inside trc_sms_medusa'
+ CALL flush(numout)
+# endif
+
+ IF( kt == nittrc000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) ' trc_sms_medusa: MEDUSA model'
+ IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~'
+ ENDIF
+
+ CALL trc_avg_medusa( kt ) ! rolling average module
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' MEDUSA done trc_avg_medusa'
+ CALL flush(numout)
+# endif
+
+ CALL trc_opt_medusa( kt ) ! optical model
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' MEDUSA done trc_opt_medusa'
+ CALL flush(numout)
+# endif
+
+ !! AXY & JPALM (28/02/17): call dust before trc_bio_medusa (because of coupling)
+ CALL trc_sed_medusa_dust( kt ) ! dust submodel
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' MEDUSA done trc_sed_medusa_dust'
+ CALL flush(numout)
+# endif
+
+# if defined key_kill_medusa
+ !! MEDUSA skipped
+ IF(lwp) WRITE(numout,*) ' MEDUSA killed at kt =', kt
+ CALL flush(numout)
+# else
+ CALL trc_bio_medusa( kt ) ! biological model
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' MEDUSA done trc_bio_medusa'
+ CALL flush(numout)
+# endif
+
+ CALL trc_sed_medusa( kt ) ! sedimentation model
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' MEDUSA done trc_sed_medusa'
+ CALL flush(numout)
+# endif
+# endif
+
+ END SUBROUTINE trc_sms_medusa
+
+#else
+ !!----------------------------------------------------------------------
+ !! Dummy module No MEDUSA model
+ !!----------------------------------------------------------------------
+CONTAINS
+ SUBROUTINE trc_sms_medusa( kt ) ! Empty routine
+ INTEGER, INTENT( in ) :: kt
+ WRITE(*,*) 'trc_sms_medusa: You should not have seen this print! error?', kt
+ END SUBROUTINE trc_sms_medusa
+#endif
+
+ !!======================================================================
+END MODULE trcsms_medusa
+
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcwri_medusa.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcwri_medusa.F90 (revision 8155)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcwri_medusa.F90 (revision 8155)
@@ -0,0 +1,60 @@
+MODULE trcwri_medusa
+ !!======================================================================
+ !! *** MODULE trcwri ***
+ !! MEDUSA : Output of MEDUSA tracers
+ !!======================================================================
+ !! History : 1.0 ! 2009-05 (C. Ethe) Original code
+ !! 1.1 ! 2013-05 (A. Yool) converted for MEDUSA
+ !!----------------------------------------------------------------------
+#if defined key_top && defined key_iomput && defined key_medusa
+ !!----------------------------------------------------------------------
+ !! 'key_medusa' MEDUSA model
+ !!----------------------------------------------------------------------
+ !! trc_wri_medusa : outputs of concentration fields
+ !!----------------------------------------------------------------------
+ USE trc ! passive tracers common variables
+ USE sms_medusa ! MEDUSA variables
+ USE iom ! I/O manager
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC trc_wri_medusa
+
+CONTAINS
+
+ SUBROUTINE trc_wri_medusa
+ !!---------------------------------------------------------------------
+ !! *** ROUTINE trc_wri_trc ***
+ !!
+ !! ** Purpose : output passive tracers fields
+ !!---------------------------------------------------------------------
+ CHARACTER (len=20) :: cltra
+ INTEGER :: jn
+ !!---------------------------------------------------------------------
+
+ ! write the tracer concentrations in the file
+ ! ---------------------------------------
+ DO jn = jp_msa0, jp_msa1
+ cltra = TRIM( ctrcnm(jn) ) ! short title for tracer
+ CALL iom_put( cltra, trn(:,:,:,jn) )
+ END DO
+ !
+ END SUBROUTINE trc_wri_medusa
+
+#else
+ !!----------------------------------------------------------------------
+ !! Dummy module : No passive tracer
+ !!----------------------------------------------------------------------
+ PUBLIC trc_wri_medusa
+CONTAINS
+ SUBROUTINE trc_wri_medusa ! Empty routine
+ END SUBROUTINE trc_wri_medusa
+#endif
+
+ !!----------------------------------------------------------------------
+ !! NEMO/TOP 3.3 , NEMO Consortium (2010)
+ !! $Id$
+ !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+ !!======================================================================
+END MODULE trcwri_medusa
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/TRP/trcadv.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/TRP/trcadv.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/TRP/trcadv.F90 (revision 8155)
@@ -29,4 +29,5 @@
USE trdtra
USE prtctl_trc ! Print control
+ !! USE lbclnk ! ocean lateral boundary conditions (or mpp link)
IMPLICIT NONE
@@ -73,5 +74,5 @@
INTEGER, INTENT(in) :: kt ! ocean time-step index
!
- INTEGER :: jk
+ INTEGER :: jk, jn
CHARACTER (len=22) :: charout
REAL(wp), POINTER, DIMENSION(:,:,:) :: zun, zvn, zwn ! effective velocity
@@ -108,4 +109,11 @@
zvn(:,:,jpk) = 0._wp ! no transport trough the bottom
zwn(:,:,jpk) = 0._wp ! no transport trough the bottom
+ !
+ !! Jpalm -- 14-01-2016 -- restart and proc pb - try this...
+ !! DO jn = 1, jptra
+ !! CALL lbc_lnk( trn(:,:,:,jn), 'T', 1. )
+ !! CALL lbc_lnk( trb(:,:,:,jn), 'T', 1. )
+ !! END DO
+ !
IF( lk_traldf_eiv .AND. .NOT. ln_traldf_grif ) & ! add the eiv transport (if necessary)
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90 (revision 8155)
@@ -102,15 +102,18 @@
IF(lwp) WRITE(numout,*) '~~~~~~~ '
- IF( ln_rsttr .AND. & ! Restart: read in restart file
- iom_varid( numrtr, 'sbc_'//TRIM(ctrcnm(1))//'_b', ldstop = .FALSE. ) > 0 ) THEN
- IF(lwp) WRITE(numout,*) ' nittrc000-nn_dttrc surface tracer content forcing fields red in the restart file'
- zfact = 0.5_wp
- DO jn = 1, jptra
- CALL iom_get( numrtr, jpdom_autoglo, 'sbc_'//TRIM(ctrcnm(jn))//'_b', sbc_trc_b(:,:,jn) ) ! before tracer content sbc
- END DO
- ELSE ! No restart or restart not found: Euler forward time stepping
+ !! JPALM -- 12-01-2016 -- problem after restart, maybe because of this...
+ !! -- set sbc_trc_b to 0 after restart, first, to check.
+ !!------------------------------------------------------------------------------
+ ! IF( ln_rsttr .AND. & ! Restart: read in restart file
+ ! iom_varid( numrtr, 'sbc_'//TRIM(ctrcnm(1))//'_b', ldstop = .FALSE. ) > 0 ) THEN
+ ! IF(lwp) WRITE(numout,*) ' nittrc000-nn_dttrc surface tracer content forcing fields red in the restart file'
+ ! zfact = 0.5_wp
+ ! DO jn = 1, jptra
+ ! CALL iom_get( numrtr, jpdom_autoglo, 'sbc_'//TRIM(ctrcnm(jn))//'_b', sbc_trc_b(:,:,jn) ) ! before tracer content sbc
+ ! END DO
+ ! ELSE ! No restart or restart not found: Euler forward time stepping
zfact = 1._wp
sbc_trc_b(:,:,:) = 0._wp
- ENDIF
+ ! ENDIF
ELSE ! Swap of forcing fields
IF( ln_top_euler ) THEN
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/TRP/trctrp.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/TRP/trctrp.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/TRP/trctrp.F90 (revision 8155)
@@ -27,4 +27,8 @@
USE trcsbc ! surface boundary condition (trc_sbc routine)
USE zpshde ! partial step: hor. derivative (zps_hde routine)
+# if defined key_debug_medusa
+ USE trcrst
+# endif
+
#if defined key_agrif
@@ -65,7 +69,17 @@
!
CALL trc_sbc( kstp ) ! surface boundary condition
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' MEDUSA trc_trp after trc_sbc at kt =', kstp
+ CALL trc_rst_tra_stat
+ CALL flush(numout)
+# endif
IF( lk_trabbl ) CALL trc_bbl( kstp ) ! advective (and/or diffusive) bottom boundary layer scheme
IF( ln_trcdmp ) CALL trc_dmp( kstp ) ! internal damping trends
CALL trc_adv( kstp ) ! horizontal & vertical advection
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' MEDUSA trc_trp after trc_adv at kt =', kstp
+ CALL trc_rst_tra_stat
+ CALL flush(numout)
+# endif
CALL trc_ldf( kstp ) ! lateral mixing
IF( .NOT. lk_offline .AND. lk_zdfkpp ) &
@@ -75,5 +89,15 @@
#endif
CALL trc_zdf( kstp ) ! vertical mixing and after tracer fields
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' MEDUSA trc_trp after trc_zdf at kt =', kstp
+ CALL trc_rst_tra_stat
+ CALL flush(numout)
+# endif
CALL trc_nxt( kstp ) ! tracer fields at next time step
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' MEDUSA trc_trp after trc_nxt at kt =', kstp
+ CALL trc_rst_tra_stat
+ CALL flush(numout)
+# endif
IF( ln_trcrad ) CALL trc_rad( kstp ) ! Correct artificial negative concentrations
IF( ln_trcdmp_clo ) CALL trc_dmp_clo( kstp ) ! internal damping trends on closed seas only
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/par_trc.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/par_trc.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/par_trc.F90 (revision 8155)
@@ -8,4 +8,5 @@
!! 1.0 ! 2004-03 (C. Ethe) Free form and module
!! 2.0 ! 2007-12 (C. Ethe, G. Madec) revised architecture
+ !! - ! 2014-06 (A. Yool, J. Palmieri) adding MEDUSA-2
!!----------------------------------------------------------------------
USE par_kind ! kind parameters
@@ -15,4 +16,7 @@
USE par_cfc ! CFC 11 and 12 tracers
USE par_my_trc ! user defined passive tracers
+ USE par_medusa ! MEDUSA model
+ USE par_idtra ! Idealize tracer
+ USE par_age ! AGE tracer
IMPLICIT NONE
@@ -24,9 +28,9 @@
! Passive tracers : Total size
! --------------- ! total number of passive tracers, of 2d and 3d output and trend arrays
- INTEGER, PUBLIC, PARAMETER :: jptra = jp_pisces + jp_cfc + jp_c14b + jp_my_trc
- INTEGER, PUBLIC, PARAMETER :: jpdia2d = jp_pisces_2d + jp_cfc_2d + jp_c14b_2d + jp_my_trc_2d
- INTEGER, PUBLIC, PARAMETER :: jpdia3d = jp_pisces_3d + jp_cfc_3d + jp_c14b_3d + jp_my_trc_3d
+ INTEGER, PUBLIC, PARAMETER :: jptra = jp_pisces + jp_cfc + jp_c14b + jp_my_trc + jp_medusa + jp_idtra + jp_age
+ INTEGER, PUBLIC, PARAMETER :: jpdia2d = jp_pisces_2d + jp_cfc_2d + jp_c14b_2d + jp_my_trc_2d + jp_medusa_2d + jp_idtra_2d + jp_age_2d
+ INTEGER, PUBLIC, PARAMETER :: jpdia3d = jp_pisces_3d + jp_cfc_3d + jp_c14b_3d + jp_my_trc_3d + jp_medusa_3d + jp_idtra_3d + jp_age_3d
! ! total number of sms diagnostic arrays
- INTEGER, PUBLIC, PARAMETER :: jpdiabio = jp_pisces_trd + jp_cfc_trd + jp_c14b_trd + jp_my_trc_trd
+ INTEGER, PUBLIC, PARAMETER :: jpdiabio = jp_pisces_trd + jp_cfc_trd + jp_c14b_trd + jp_my_trc_trd + jp_medusa_trd + jp_idtra_trd + jp_age_trd
! 1D configuration ("key_c1d")
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trc.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trc.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trc.F90 (revision 8155)
@@ -7,4 +7,5 @@
!! - ! 2000-04 (O. Aumont, M.A. Foujols) HAMOCC3 and P3ZD
!! NEMO 1.0 ! 2004-03 (C. Ethe) Free form and module
+ !! 3.6 ! 2016-11 (A. Yool) Updated diags for CMIP6
!!----------------------------------------------------------------------
#if defined key_top
@@ -25,5 +26,5 @@
INTEGER, PUBLIC :: numnat_cfg = -1 !: logical unit for the reference passive tracer namelist_top_cfg
INTEGER, PUBLIC :: numont = -1 !: logical unit for the reference passive tracer namelist output output.namelist.top
- INTEGER, PUBLIC :: numstr !: logical unit for tracer statistics
+ INTEGER, PUBLIC :: numstr = -1 !: logical unit for tracer statistics
INTEGER, PUBLIC :: numrtr !: logical unit for trc restart (read )
INTEGER, PUBLIC :: numrtw !: logical unit for trc restart ( write )
@@ -104,4 +105,54 @@
END TYPE DIAG
+#if defined key_medusa && defined key_iomput
+ TYPE, PUBLIC :: BDIAG
+ LOGICAL :: dgsave
+ END TYPE BDIAG
+
+ TYPE, PUBLIC :: DIAG_IOM
+ TYPE(BDIAG) INVTN, INVTSI, INVTFE, PRN, MPN, PRD, MPD, DSED, OPAL, OPALDISS, GMIPn, &
+ GMID, MZMI, GMEPN, GMEPD, GMEZMI, GMED, MZME, DEXP, DETN, MDET, AEOLIAN, BENTHIC, &
+ SCAVENGE, PN_JLIM, PN_NLIM, PN_FELIM, PD_JLIM, PD_NLIM, PD_FELIM, PD_SILIM, &
+ PDSILIM2, SDT__100, SDT__200, SDT__500, SDT_1000, TOTREG_N, TOTRG_SI, REG__100, &
+ REG__200, REG__500, REG_1000, FASTN, FASTSI, FASTFE, FASTC, FASTCA, FDT__100, &
+ FDT__200, FDT__500, FDT_1000, RG__100F, RG__200F, RG__500F, RG_1000F, FDS__100, &
+ FDS__200, FDS__500, FDS_1000, RGS_100F, RGS_200F, RGS_500F, RGS1000F, REMINN, &
+ REMINSI, REMINFE, REMINC, REMINCA, SEAFLRN, SEAFLRSI, SEAFLRFE, SEAFLRC, SEAFLRCA, &
+ MED_QSR, MED_XPAR, INTFLX_N, INTFLX_SI, INTFLX_FE, INT_PN, INT_PD, ML_PRN, ML_PRD, &
+ OCAL_CCD, OCAL_LVL, FE_0000, FE_0100, FE_0200, FE_0500, FE_1000, MED_XZE, WIND, &
+ ATM_PCO2, OCN_PH, OCN_PCO2, OCNH2CO3, OCN_HCO3, OCN_CO3, CO2FLUX, OM_CAL, OM_ARG, &
+ TCO2, TALK, KW660, ATM_PP0, O2FLUX, O2SAT, CAL_CCD, ARG_CCD, SFR_OCAL, SFR_OARG, &
+ N_PROD, N_CONS, C_PROD, C_CONS, O2_PROD, O2_CONS, O2_ANOX, RR_0100, RR_0500, &
+ RR_1000, IBEN_N, IBEN_FE, IBEN_C, IBEN_SI, IBEN_CA, OBEN_N, OBEN_FE, OBEN_C, &
+ OBEN_SI, OBEN_CA, BEN_N, BEN_FE, BEN_C, BEN_SI, BEN_CA, RUNOFF, RIV_N, RIV_SI, &
+ RIV_C, RIV_ALK, DETC, SDC__100, SDC__200, SDC__500, SDC_1000, INVTC, INVTALK, &
+ INVTO2, LYSO_CA, COM_RESP, PN_LLOSS, PD_LLOSS, ZI_LLOSS, ZE_LLOSS, ZI_MES_N, &
+ ZI_MES_D, ZI_MES_C, ZI_MESDC, ZI_EXCR, ZI_RESP, ZI_GROW, ZE_MES_N, ZE_MES_D, &
+ ZE_MES_C, ZE_MESDC, ZE_EXCR, ZE_RESP, ZE_GROW, MDETC, GMIDC, GMEDC, &
+ INT_ZMI, INT_ZME, INT_DET, INT_DTC, DMS_SURF, DMS_ANDR, DMS_SIMO, DMS_ARAN, &
+ DMS_HALL, DMS_ANDM, ATM_XCO2, OCN_FCO2, ATM_FCO2, OCN_RHOSW, OCN_SCHCO2, &
+ OCN_KWCO2, OCN_K0, CO2STARAIR, OCN_DPCO2, & ! end of regular 2D
+ TPP3, DETFLUX3, REMIN3N, PH3, OM_CAL3, & ! end of regular 3D
+! AXY (11/11/16): additional CMIP6 2D diagnostics
+ epC100, epCALC100, epN100, epSI100, &
+ FGCO2, INTDISSIC, INTDISSIN, INTDISSISI, INTTALK, O2min, ZO2min, &
+ FBDDTALK, FBDDTDIC, FBDDTDIFE, FBDDTDIN, FBDDTDISI, &
+! AXY (11/11/16): additional CMIP6 3D diagnostics
+ TPPD3, &
+ BDDTALK3, BDDTDIC3, BDDTDIFE3, BDDTDIN3, BDDTDISI3, &
+ FD_NIT3, FD_SIL3, FD_CAR3, FD_CAL3, &
+ CO33, CO3SATARAG3, CO3SATCALC3, DCALC3, &
+ EXPC3, EXPN3, EXPCALC3, EXPSI3, &
+ FEDISS3, FESCAV3, &
+ MIGRAZP3, MIGRAZD3, MEGRAZP3, MEGRAZD3, MEGRAZZ3, &
+ O2SAT3, PBSI3, PCAL3, REMOC3, &
+ PNLIMJ3, PNLIMN3, PNLIMFE3, PDLIMJ3, PDLIMN3, PDLIMFE3, PDLIMSI3
+ !!
+ !! list of all MEDUSA diagnostics that could be called by iom_use
+ END TYPE DIAG_IOM
+ !!
+ TYPE(DIAG_IOM), PUBLIC :: med_diag ! define which diagnostics are asked in outputs
+# endif
+
!! information for inputs
!! --------------------------------------------------
@@ -216,4 +267,8 @@
IF( trc_alloc /= 0 ) CALL ctl_warn('trc_alloc: failed to allocate arrays')
+
+ ! It is known that not intialising SBC_TRC can introduce NaNs
+ sbc_trc(:,:,:) = 0.0
+
!
END FUNCTION trc_alloc
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcini.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcini.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcini.F90 (revision 8155)
@@ -8,4 +8,5 @@
!! 2.0 ! 2005-10 (C. Ethe, G. Madec) revised architecture
!! 4.0 ! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation
+ !! - ! 2014-06 (A. Yool, J. Palmieri) adding MEDUSA-2
!!----------------------------------------------------------------------
#if defined key_top
@@ -24,4 +25,7 @@
USE trcini_c14b ! C14 bomb initialisation
USE trcini_my_trc ! MY_TRC initialisation
+ USE trcini_medusa ! MEDUSA initialisation
+ USE trcini_idtra ! idealize tracer initialisation
+ USE trcini_age ! AGE initialisation
USE trcdta ! initialisation from files
USE daymod ! calendar manager
@@ -76,5 +80,7 @@
& CALL ctl_warn(' Coupling with passive tracers and used of diurnal cycle. &
& Computation of a daily mean shortwave for some biogeochemical models) ')
-
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !!!!! CHECK For MEDUSA
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
IF( nn_cla == 1 ) &
& CALL ctl_stop( ' Cross Land Advection not yet implemented with passive tracer ; nn_cla must be 0' )
@@ -97,24 +103,70 @@
IF( lk_pisces ) CALL trc_ini_pisces ! PISCES bio-model
+ IF( lk_medusa ) CALL trc_ini_medusa ! MEDUSA tracers
+ IF( lk_idtra ) CALL trc_ini_idtra ! Idealize tracers
IF( lk_cfc ) CALL trc_ini_cfc ! CFC tracers
IF( lk_c14b ) CALL trc_ini_c14b ! C14 bomb tracer
+ IF( lk_age ) CALL trc_ini_age ! AGE tracer
IF( lk_my_trc ) CALL trc_ini_my_trc ! MY_TRC tracers
CALL trc_ice_ini ! Tracers in sea ice
- IF( lwp ) THEN
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) ' in trc_init'
+ IF (lwp) write (numout,*) ' sms init OK'
+ IF (lwp) write (numout,*) ' next: open tracer.stat'
+ IF (lwp) write (numout,*) ' '
+ CALL flush(numout)
+# endif
+
+ IF( ln_ctl ) THEN
!
- CALL ctl_opn( numstr, 'tracer.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp , narea )
+ IF (narea == 1) THEN
+ ! The tracer.stat file only contains global tracer sum values, if
+ ! it contains anything at all. Hence it only needs to be opened
+ ! and written to on the master PE, not on all PEs.
+ CALL ctl_opn( numstr, 'tracer.stat', 'REPLACE','FORMATTED', &
+ 'SEQUENTIAL', -1, numout, lwp , narea )
+ ENDIF
!
ENDIF
- IF( ln_trcdta ) CALL trc_dta_init(jptra)
-
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) ' in trc_init'
+ IF (lwp) write (numout,*) 'open tracer.stat -- OK'
+ IF (lwp) write (numout,*) ' '
+ CALL flush(numout)
+# endif
+
+
+ IF( ln_trcdta ) THEN
+#if defined key_medusa
+ IF(lwp) WRITE(numout,*) 'AXY: calling trc_dta_init'
+ IF(lwp) CALL flush(numout)
+#endif
+ CALL trc_dta_init(jptra)
+ ENDIF
IF( ln_rsttr ) THEN
!
+#if defined key_medusa
+ IF(lwp) WRITE(numout,*) 'AXY: calling trc_rst_read'
+ IF(lwp) CALL flush(numout)
+#endif
CALL trc_rst_read ! restart from a file
!
ELSE
+ !
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) ' Init from file -- will call trc_dta'
+ IF (lwp) write (numout,*) ' '
+ CALL flush(numout)
+# endif
!
IF( ln_trcdta .AND. nb_trcdta > 0 ) THEN ! Initialisation of tracer from a file that may also be used for damping
@@ -137,5 +189,23 @@
ENDIF
!
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) ' in trc_init'
+ IF (lwp) write (numout,*) ' before trb = trn'
+ IF (lwp) write (numout,*) ' '
+ CALL flush(numout)
+# endif
+ !
trb(:,:,:,:) = trn(:,:,:,:)
+ !
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) ' in trc_init'
+ IF (lwp) write (numout,*) ' trb = trn -- OK'
+ IF (lwp) write (numout,*) ' '
+ CALL flush(numout)
+# endif
!
ENDIF
@@ -146,10 +216,25 @@
IF( ln_zps .AND. .NOT. lk_c1d .AND. ln_isfcav ) &
& CALL zps_hde_isf( nit000, jptra, trn, pgtu=gtru, pgtv=gtrv, pgtui=gtrui, pgtvi=gtrvi ) ! tracers at the bottom ocean level
-
-
+ !
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) ' in trc_init'
+ IF (lwp) write (numout,*) ' partial step -- OK'
+ IF (lwp) write (numout,*) ' '
+ CALL flush(numout)
+# endif
!
IF( nn_dttrc /= 1 ) CALL trc_sub_ini ! Initialize variables for substepping passive tracers
!
-
+# if defined key_debug_medusa
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) ' in trc_init'
+ IF (lwp) write (numout,*) ' before initiate tracer contents'
+ IF (lwp) write (numout,*) ' '
+ CALL flush(numout)
+# endif
+ !
trai(:) = 0._wp ! initial content of all tracers
DO jn = 1, jptra
@@ -164,4 +249,12 @@
WRITE(numout,*) ' *** Total inital content of all tracers '
WRITE(numout,*)
+# if defined key_debug_medusa
+ CALL flush(numout)
+# endif
+ !
+# if defined key_debug_medusa
+ WRITE(numout,*) ' litle check : ', ctrcnm(1)
+ CALL flush(numout)
+# endif
DO jn = 1, jptra
WRITE(numout,9000) jn, TRIM( ctrcnm(jn) ), trai(jn)
@@ -176,4 +269,14 @@
CALL prt_ctl_trc( tab4d=trn, mask=tmask, clinfo=ctrcnm )
ENDIF
+
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'trc_init : passive tracer set up completed'
+ IF(lwp) WRITE(numout,*) '~~~~~~~'
+ IF(lwp) CALL flush(numout)
+# if defined key_debug_medusa
+ CALL trc_rst_stat
+ CALL flush(numout)
+# endif
+
9000 FORMAT(' tracer nb : ',i2,' name :',a10,' initial content :',e18.10)
!
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcnam.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcnam.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcnam.F90 (revision 8155)
@@ -11,4 +11,5 @@
!! - ! 2001-01 (E Kestenare) suppress ndttrc=1 for CEN2 and TVD schemes
!! 1.0 ! 2005-03 (O. Aumont, A. El Moussaoui) F90
+ !! - ! 2014-06 (A. Yool, J. Palmieri) adding MEDUSA-2
!!----------------------------------------------------------------------
#if defined key_top
@@ -25,4 +26,7 @@
USE trcnam_c14b ! C14 SMS namelist
USE trcnam_my_trc ! MY_TRC SMS namelist
+ USE trcnam_medusa ! MEDUSA namelist
+ USE trcnam_idtra ! Idealise tracer namelist
+ USE trcnam_age ! AGE SMS namelist
USE trd_oce
USE trdtrc_oce
@@ -54,18 +58,56 @@
!! ** Method : - read passive tracer namelist
!! - read namelist of each defined SMS model
- !! ( (PISCES, CFC, MY_TRC )
- !!---------------------------------------------------------------------
- INTEGER :: jn ! dummy loop indice
+ !! ( (PISCES, CFC, MY_TRC, MEDUSA, IDTRA, Age )
+ !!---------------------------------------------------------------------
+ INTEGER :: jn, jk ! dummy loop indice
! ! Parameters of the run
IF( .NOT. lk_offline ) CALL trc_nam_run
! ! passive tracer informations
+# if defined key_debug_medusa
+ CALL flush(numout)
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) 'in trc_nam - just before CALL trc_nam_trc'
+ IF (lwp) write (numout,*) ' '
+# endif
+ !
CALL trc_nam_trc
! ! Parameters of additional diagnostics
+# if defined key_debug_medusa
+ CALL flush(numout)
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) 'CALL trc_nam_trc -- OK'
+ IF (lwp) write (numout,*) 'in trc_nam - just before CALL trc_nam_dia'
+ IF (lwp) write (numout,*) ' '
+# endif
+ !
+
CALL trc_nam_dia
! ! namelist of transport
+# if defined key_debug_medusa
+ CALL flush(numout)
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) 'CALL trc_nam_dia -- OK'
+ IF (lwp) write (numout,*) 'in trc_nam - just before CALL trc_nam_trp'
+ IF (lwp) write (numout,*) ' '
+# endif
+ !
CALL trc_nam_trp
+ !
+# if defined key_debug_medusa
+ CALL flush(numout)
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) 'CALL trc_nam_trp -- OK'
+ IF (lwp) write (numout,*) 'continue trc_nam '
+ IF (lwp) write (numout,*) ' '
+ CALL flush(numout)
+# endif
+ !
@@ -89,4 +131,7 @@
END DO
WRITE(numout,*) ' '
+# if defined key_debug_medusa
+ CALL flush(numout)
+# endif
ENDIF
@@ -107,6 +152,15 @@
WRITE(numout,*)
ENDIF
- ENDIF
-
+# if defined key_debug_medusa
+ CALL flush(numout)
+# endif
+ ENDIF
+
+# if defined key_debug_medusa
+ DO jk = 1, jpk
+ WRITE(numout,*) ' level number: ', jk, 'rdttrc: ',rdttrc(jk),'rdttra: ', rdttra(jk),'nn_dttrc: ', nn_dttrc
+ END DO
+ CALL flush(numout)
+# endif
rdttrc(:) = rdttra(:) * FLOAT( nn_dttrc ) ! vertical profile of passive tracer time-step
@@ -116,4 +170,7 @@
WRITE(numout,*) ' Passive Tracer time step rdttrc = ', rdttrc(1)
WRITE(numout,*)
+# if defined key_debug_medusa
+ CALL flush(numout)
+# endif
ENDIF
@@ -143,11 +200,30 @@
IF( ln_trdtrc(jn) ) WRITE(numout,*) ' compute ML trends for tracer number :', jn
END DO
+ WRITE(numout,*) ' '
+ CALL flush(numout)
ENDIF
#endif
+# if defined key_debug_medusa
+ CALL flush(numout)
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) 'just before ice module for tracers call : '
+ IF (lwp) write (numout,*) ' '
+# endif
+ !
! Call the ice module for tracers
! -------------------------------
CALL trc_nam_ice
+
+# if defined key_debug_medusa
+ CALL flush(numout)
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) 'Will now read SMS namelists : '
+ IF (lwp) write (numout,*) ' '
+# endif
+ !
! namelist of SMS
@@ -156,17 +232,84 @@
ELSE ; IF(lwp) WRITE(numout,*) ' PISCES not used'
ENDIF
-
+ !
+# if defined key_debug_medusa
+ CALL flush(numout)
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) 'CALL trc_nam_pisces -- OK'
+ IF (lwp) write (numout,*) 'in trc_nam - just before CALL trc_nam_medusa'
+ IF (lwp) write (numout,*) ' '
+# endif
+ !
+ IF( lk_medusa ) THEN ; CALL trc_nam_medusa ! MEDUSA tracers
+ ELSE ; IF(lwp) WRITE(numout,*) ' MEDUSA not used'
+ ENDIF
+ !
+# if defined key_debug_medusa
+ CALL flush(numout)
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) 'CALL trc_nam_medusa -- OK'
+ IF (lwp) write (numout,*) 'in trc_nam - just before CALL trc_nam_idtra'
+ IF (lwp) write (numout,*) ' '
+# endif
+ !
+ IF( lk_idtra ) THEN ; CALL trc_nam_idtra ! Idealize tracers
+ ELSE ; IF(lwp) WRITE(numout,*) ' Idealize tracers not used'
+ ENDIF
+ !
+# if defined key_debug_medusa
+ CALL flush(numout)
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) 'CALL trc_nam_idtra -- OK'
+ IF (lwp) write (numout,*) 'in trc_nam - just before CALL trc_nam_cfc'
+ IF (lwp) write (numout,*) ' '
+# endif
+ !
IF( lk_cfc ) THEN ; CALL trc_nam_cfc ! CFC tracers
ELSE ; IF(lwp) WRITE(numout,*) ' CFC not used'
ENDIF
-
+ !
+# if defined key_debug_medusa
+ CALL flush(numout)
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) 'CALL trc_nam_cfc -- OK'
+ IF (lwp) write (numout,*) 'in trc_nam - just before CALL trc_nam_c14'
+ IF (lwp) write (numout,*) ' '
+# endif
+ !
IF( lk_c14b ) THEN ; CALL trc_nam_c14b ! C14 bomb tracers
ELSE ; IF(lwp) WRITE(numout,*) ' C14 not used'
ENDIF
-
+ !
+# if defined key_debug_medusa
+ CALL flush(numout)
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) 'CALL trc_nam_c14 -- OK'
+ IF (lwp) write (numout,*) 'in trc_nam - just before CALL trc_nam_age'
+ IF (lwp) write (numout,*) ' '
+# endif
+ !
+ IF( lk_age ) THEN ; CALL trc_nam_age ! AGE tracer
+ ELSE ; IF(lwp) WRITE(numout,*) ' AGE not used'
+ ENDIF
+ !
+# if defined key_debug_medusa
+ CALL flush(numout)
+ IF (lwp) write (numout,*) '------------------------------'
+ IF (lwp) write (numout,*) 'Jpalm - debug'
+ IF (lwp) write (numout,*) 'CALL trc_nam_age -- OK'
+ IF (lwp) write (numout,*) 'in trc_nam - CALL trc_nam -- OK'
+ IF (lwp) write (numout,*) ' '
+# endif
+ !
IF( lk_my_trc ) THEN ; CALL trc_nam_my_trc ! MY_TRC tracers
ELSE ; IF(lwp) WRITE(numout,*) ' MY_TRC not used'
ENDIF
- !
+
+ IF(lwp) CALL flush(numout)
END SUBROUTINE trc_nam
@@ -216,4 +359,5 @@
WRITE(numout,*) ' Use euler integration for TRC (y/n) ln_top_euler = ', ln_top_euler
WRITE(numout,*) ' '
+ CALL flush(numout)
ENDIF
!
@@ -306,5 +450,6 @@
ln_trc_wri(jn) = sn_tracer(jn)%llsave
END DO
-
+ IF(lwp) CALL flush(numout)
+
END SUBROUTINE trc_nam_trc
@@ -357,7 +502,16 @@
WRITE(numout,*) ' frequency of outputs for biological trends nn_writebio = ', nn_writebio
WRITE(numout,*) ' '
- ENDIF
-
- IF( ln_diatrc .AND. .NOT. lk_iomput ) THEN
+ CALL flush(numout)
+ ENDIF
+!!
+!! JPALM -- 17-07-2015 --
+!! MEDUSA is not yet up-to-date with the iom server.
+!! we use it for the main tracer, but not fully with diagnostics.
+!! will have to adapt it properly when visiting Christian Ethee
+!! for now, we change
+!! IF( ln_diatrc .AND. .NOT. lk_iomput ) THEN
+!! to :
+!!
+ IF( ( ln_diatrc .AND. .NOT. lk_iomput ) .OR. ( ln_diatrc .AND. lk_medusa ) ) THEN
ALLOCATE( trc2d(jpi,jpj,jpdia2d), trc3d(jpi,jpj,jpk,jpdia3d), &
& ctrc2d(jpdia2d), ctrc2l(jpdia2d), ctrc2u(jpdia2d) , &
@@ -368,4 +522,6 @@
trc3d(:,:,:,:) = 0._wp ; ctrc3d(:) = ' ' ; ctrc3l(:) = ' ' ; ctrc3u(:) = ' '
!
+ !! ELSE IF ( lk_iomput .AND. lk_medusa .AND. .NOT. ln_diatrc) THEN
+ !! CALL trc_nam_iom_medusa
ENDIF
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcrst.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcrst.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcrst.F90 (revision 8155)
@@ -27,5 +27,21 @@
USE trcnam_trp
USE iom
+ USE ioipsl, ONLY : ju2ymds ! for calendar
USE daymod
+ !! AXY (05/11/13): need these for MEDUSA to input/output benthic reservoirs
+ USE sms_medusa
+ USE trcsms_medusa
+ !!
+#if defined key_idtra
+ USE trcsms_idtra
+#endif
+ !!
+#if defined key_cfc
+ USE trcsms_cfc
+#endif
+ USE lbclnk ! ocean lateral boundary conditions (or mpp link)
+ USE sbc_oce, ONLY: lk_oasis
+ USE oce, ONLY: CO2Flux_out_cpl, DMS_out_cpl, chloro_out_cpl !! Coupling variable
+
IMPLICIT NONE
PRIVATE
@@ -35,4 +51,7 @@
PUBLIC trc_rst_wri ! called by ???
PUBLIC trc_rst_cal
+ PUBLIC trc_rst_stat
+ PUBLIC trc_rst_dia_stat
+ PUBLIC trc_rst_tra_stat
!! * Substitutions
@@ -48,4 +67,7 @@
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: kt ! number of iteration
+ INTEGER :: iyear, imonth, iday
+ REAL (wp) :: zsec
+ REAL (wp) :: zfjulday
!
CHARACTER(LEN=20) :: clkt ! ocean time-step define as a character
@@ -78,7 +100,26 @@
! except if we write tracer restart files every tracer time step or if a tracer restart file was writen at nitend - 2*nn_dttrc + 1
IF( kt == nitrst - 2*nn_dttrc .OR. nstock == nn_dttrc .OR. ( kt == nitend - nn_dttrc .AND. .NOT. lrst_trc ) ) THEN
- ! beware of the format used to write kt (default is i8.8, that should be large enough)
- IF( nitrst > 1.0e9 ) THEN ; WRITE(clkt,* ) nitrst
- ELSE ; WRITE(clkt,'(i8.8)') nitrst
+ IF ( ln_rstdate ) THEN
+ !! JPALM -- 22-12-2015 -- modif to get the good date on restart trc file name
+ !! -- the condition to open the rst file is not the same than for the dynamic rst.
+ !! -- here it - for an obscure reason - is open 2 time-step before the restart writing process
+ !! instead of 1.
+ !! -- i am not sure if someone forgot +1 in the if loop condition as
+ !! it is writen in all comments nitrst -2*nn_dttrc + 1 and the condition is
+ !! nitrst - 2*nn_dttrc
+ !! -- nevertheless we didn't wanted to broke something already working
+ !! and just adapted the part we added.
+ !! -- So instead of calling ju2ymds( fjulday + (rdttra(1))
+ !! we call ju2ymds( fjulday + (2*rdttra(1))
+ !!--------------------------------------------------------------------
+ zfjulday = fjulday + (2*rdttra(1)) / rday
+ IF( ABS(zfjulday - REAL(NINT(zfjulday),wp)) < 0.1 / rday ) zfjulday = REAL(NINT(zfjulday),wp) ! avoid truncation error
+ CALL ju2ymds( zfjulday + (2*rdttra(1)) / rday, iyear, imonth, iday, zsec )
+ WRITE(clkt, '(i4.4,2i2.2)') iyear, imonth, iday
+ ELSE
+ ! beware of the format used to write kt (default is i8.8, that should be large enough)
+ IF( nitrst > 1.0e9 ) THEN ; WRITE(clkt,* ) nitrst
+ ELSE ; WRITE(clkt,'(i8.8)') nitrst
+ ENDIF
ENDIF
! create the file
@@ -101,5 +142,7 @@
!! ** purpose : read passive tracer fields in restart files
!!----------------------------------------------------------------------
- INTEGER :: jn
+ INTEGER :: jn, jl
+ !! AXY (05/11/13): temporary variables
+ REAL(wp) :: fq0,fq1,fq2
!!----------------------------------------------------------------------
@@ -112,9 +155,226 @@
DO jn = 1, jptra
CALL iom_get( numrtr, jpdom_autoglo, 'TRN'//ctrcnm(jn), trn(:,:,:,jn) )
+ trn(:,:,:,jn) = trn(:,:,:,jn) * tmask(:,:,:)
END DO
DO jn = 1, jptra
CALL iom_get( numrtr, jpdom_autoglo, 'TRB'//ctrcnm(jn), trb(:,:,:,jn) )
- END DO
+ trb(:,:,:,jn) = trb(:,:,:,jn) * tmask(:,:,:)
+ END DO
+ !
+ !! AXY (09/06/14): the ARCHER version of MEDUSA-2 does not include an equivalent
+ !! call to MEDUSA-2 at this point; this suggests that the FCM
+ !! version of NEMO date significantly earlier than the current
+ !! version
+
+#if defined key_medusa
+ !! AXY (13/01/12): check if the restart contains sediment fields;
+ !! this is only relevant for simulations that include
+ !! biogeochemistry and are restarted from earlier runs
+ !! in which there was no sediment component
+ !!
+ IF( iom_varid( numrtr, 'B_SED_N', ldstop = .FALSE. ) > 0 ) THEN
+ !! YES; in which case read them
+ !!
+ IF(lwp) WRITE(numout,*) ' MEDUSA sediment fields present - reading in ...'
+ CALL iom_get( numrtr, jpdom_autoglo, 'B_SED_N', zb_sed_n(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'N_SED_N', zn_sed_n(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'B_SED_FE', zb_sed_fe(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'N_SED_FE', zn_sed_fe(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'B_SED_SI', zb_sed_si(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'N_SED_SI', zn_sed_si(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'B_SED_C', zb_sed_c(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'N_SED_C', zn_sed_c(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'B_SED_CA', zb_sed_ca(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'N_SED_CA', zn_sed_ca(:,:) )
+ ELSE
+ !! NO; in which case set them to zero
+ !!
+ IF(lwp) WRITE(numout,*) ' MEDUSA sediment fields absent - setting to zero ...'
+ zb_sed_n(:,:) = 0.0 !! organic N
+ zn_sed_n(:,:) = 0.0
+ zb_sed_fe(:,:) = 0.0 !! organic Fe
+ zn_sed_fe(:,:) = 0.0
+ zb_sed_si(:,:) = 0.0 !! inorganic Si
+ zn_sed_si(:,:) = 0.0
+ zb_sed_c(:,:) = 0.0 !! organic C
+ zn_sed_c(:,:) = 0.0
+ zb_sed_ca(:,:) = 0.0 !! inorganic C
+ zn_sed_ca(:,:) = 0.0
+ ENDIF
+ !!
+ !! calculate stats on these fields
+ IF(lwp) WRITE(numout,*) ' MEDUSA sediment field stats (min, max, sum) ...'
+ call trc_rst_dia_stat(zn_sed_n(:,:), 'Sediment N')
+ call trc_rst_dia_stat(zn_sed_fe(:,:), 'Sediment Fe')
+ call trc_rst_dia_stat(zn_sed_si(:,:), 'Sediment Si')
+ call trc_rst_dia_stat(zn_sed_c(:,:), 'Sediment C')
+ call trc_rst_dia_stat(zn_sed_ca(:,:), 'Sediment Ca')
+ !!
+ !! AXY (07/07/15): read in temporally averaged fields for DMS
+ !! calculations
+ !!
+ IF( iom_varid( numrtr, 'B_DMS_CHN', ldstop = .FALSE. ) > 0 ) THEN
+ !! YES; in which case read them
+ !!
+ IF(lwp) WRITE(numout,*) ' MEDUSA averaged properties for DMS present - reading in ...'
+ CALL iom_get( numrtr, jpdom_autoglo, 'B_DMS_CHN', zb_dms_chn(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'N_DMS_CHN', zn_dms_chn(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'B_DMS_CHD', zb_dms_chd(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'N_DMS_CHD', zn_dms_chd(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'B_DMS_MLD', zb_dms_mld(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'N_DMS_MLD', zn_dms_mld(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'B_DMS_QSR', zb_dms_qsr(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'N_DMS_QSR', zn_dms_qsr(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'B_DMS_DIN', zb_dms_din(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'N_DMS_DIN', zn_dms_din(:,:) )
+ ELSE
+ !! NO; in which case set them to zero
+ !!
+ IF(lwp) WRITE(numout,*) ' MEDUSA averaged properties for DMS absent - setting to zero ...'
+ zb_dms_chn(:,:) = 0.0 !! CHN
+ zn_dms_chn(:,:) = 0.0
+ zb_dms_chd(:,:) = 0.0 !! CHD
+ zn_dms_chd(:,:) = 0.0
+ zb_dms_mld(:,:) = 0.0 !! MLD
+ zn_dms_mld(:,:) = 0.0
+ zb_dms_qsr(:,:) = 0.0 !! QSR
+ zn_dms_qsr(:,:) = 0.0
+ zb_dms_din(:,:) = 0.0 !! DIN
+ zn_dms_din(:,:) = 0.0
+ ENDIF
+ !!
+ !! JPALM 14-06-2016 -- add CO2 flux and DMS surf through the restart
+ !! -- needed for the coupling with atm
+ IF( iom_varid( numrtr, 'N_DMS_srf', ldstop = .FALSE. ) > 0 ) THEN
+ IF(lwp) WRITE(numout,*) 'DMS surf concentration - reading in ...'
+ CALL iom_get( numrtr, jpdom_autoglo, 'B_DMS_srf', zb_dms_srf(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'N_DMS_srf', zn_dms_srf(:,:) )
+ ELSE
+ IF(lwp) WRITE(numout,*) 'DMS surf concentration - setting to zero ...'
+ zb_dms_srf(:,:) = 0.0 !! DMS
+ zn_dms_srf(:,:) = 0.0
+ ENDIF
+ IF (lk_oasis) THEN
+ DMS_out_cpl(:,:) = zn_dms_srf(:,:) !! Coupling variable
+ END IF
+ !!
+ IF( iom_varid( numrtr, 'B_CO2_flx', ldstop = .FALSE. ) > 0 ) THEN
+ IF(lwp) WRITE(numout,*) 'CO2 air-sea flux - reading in ...'
+ CALL iom_get( numrtr, jpdom_autoglo, 'B_CO2_flx', zb_co2_flx(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'N_CO2_flx', zn_co2_flx(:,:) )
+ ELSE
+ IF(lwp) WRITE(numout,*) 'CO2 air-sea flux - setting to zero ...'
+ zb_co2_flx(:,:) = 0.0 !! CO2 flx
+ zn_co2_flx(:,:) = 0.0
+ ENDIF
+ IF (lk_oasis) THEN
+ CO2Flux_out_cpl(:,:) = zn_co2_flx(:,:) !! Coupling variable
+ END IF
+ !!
+ !! JPALM 02-06-2017 -- in complement to DMS surf
+ !! -- the atm model needs surf Chl
+ !! as proxy of org matter from the ocean
+ !! -- needed for the coupling with atm
+ IF( iom_varid( numrtr, 'N_CHL_srf', ldstop = .FALSE. ) > 0 ) THEN
+ IF(lwp) WRITE(numout,*) 'Chl surf concentration - reading in ...'
+ CALL iom_get( numrtr, jpdom_autoglo, 'N_CHL_srf', zn_chl_srf(:,:) )
+ ELSE
+ IF(lwp) WRITE(numout,*) 'Chl surf concentration - setting to zero ...'
+ zn_chl_srf(:,:) = (trn(:,:,1,jpchn) + trn(:,:,1,jpchd)) * 1.E-6
+ ENDIF
+ IF (lk_oasis) THEN
+ chloro_out_cpl(:,:) = zn_chl_srf(:,:) !! Coupling variable
+ END IF
+ !!
+ !! calculate stats on these fields
+ IF(lwp) WRITE(numout,*) ' MEDUSA averaged properties for DMS stats (min, max, sum) ...'
+ call trc_rst_dia_stat(zn_dms_chn(:,:), 'DMS, CHN')
+ call trc_rst_dia_stat(zn_dms_chd(:,:), 'DMS, CHD')
+ call trc_rst_dia_stat(zn_dms_mld(:,:), 'DMS, MLD')
+ call trc_rst_dia_stat(zn_dms_qsr(:,:), 'DMS, QSR')
+ call trc_rst_dia_stat(zn_dms_din(:,:), 'DMS, DIN')
+ call trc_rst_dia_stat(zn_dms_srf(:,:), 'DMS surf')
+ call trc_rst_dia_stat(zn_co2_flx(:,:), 'CO2 flux')
+ call trc_rst_dia_stat(zn_chl_srf(:,:), 'CHL surf')
+ !!
+ !! JPALM 14-06-2016 -- add Carbonate chenistry variables through the restart
+ !! -- needed for monthly call of carb-chem routine and better reproducibility
+# if defined key_roam
+ IF( iom_varid( numrtr, 'pH_3D', ldstop = .FALSE. ) > 0 ) THEN
+ IF(lwp) WRITE(numout,*) 'Carbonate chem variable - reading in ...'
+ CALL iom_get( numrtr, jpdom_autoglo, 'pH_3D' , f3_pH(:,:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'h2CO3_3D', f3_h2co3(:,:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'hCO3_3D' , f3_hco3(:,:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'CO3_3D' , f3_co3(:,:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'omcal_3D', f3_omcal(:,:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'omarg_3D', f3_omarg(:,:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'CCD_CAL' , f2_ccd_cal(:,:) )
+ CALL iom_get( numrtr, jpdom_autoglo, 'CCD_ARG' , f2_ccd_arg(:,:) )
+ !!
+ IF(lwp) WRITE(numout,*) ' MEDUSA averaged Carb-chem stats (min, max, sum) ...'
+ call trc_rst_dia_stat( f3_pH(:,:,1) ,'pH 3D surf')
+ call trc_rst_dia_stat( f3_h2co3(:,:,1),'h2CO3 3D surf')
+ call trc_rst_dia_stat( f3_hco3(:,:,1) ,'hCO3 3D surf' )
+ call trc_rst_dia_stat( f3_co3(:,:,1) ,'CO3 3D surf' )
+ call trc_rst_dia_stat( f3_omcal(:,:,1),'omcal 3D surf')
+ call trc_rst_dia_stat( f3_omarg(:,:,1),'omarg 3D surf')
+ call trc_rst_dia_stat( f2_ccd_cal(:,:),'CCD_CAL')
+ call trc_rst_dia_stat( f2_ccd_arg(:,:),'CCD_ARG')
+
+ ELSE
+ IF(lwp) WRITE(numout,*) 'WARNING : No Carbonate-chem variable in the restart.... '
+ IF(lwp) WRITE(numout,*) 'Is not a problem if start a month, but may be very problematic if not '
+ IF(lwp) WRITE(numout,*) 'Check if mod(kt*rdt,2592000) == rdt'
+ IF(lwp) WRITE(numout,*) 'Or don t start from uncomplete restart...'
+ ENDIF
+# endif
+
+
+#endif
+ !
+#if defined key_idtra
+ !! JPALM -- 05-01-2016 -- mv idtra and CFC restart reading and
+ !! writting here undre their key.
+ !! problems in CFC restart, maybe because of this...
+ !! and pb in idtra diag or diad-restart writing.
+ !!----------------------------------------------------------------------
+ IF( iom_varid( numrtr, 'qint_IDTRA', ldstop = .FALSE. ) > 0 ) THEN
+ !! YES; in which case read them
+ !!
+ IF(lwp) WRITE(numout,*) ' IDTRA averaged properties present - reading in ...'
+ CALL iom_get( numrtr, jpdom_autoglo, 'qint_IDTRA', qint_idtra(:,:,1) )
+ ELSE
+ !! NO; in which case set them to zero
+ !!
+ IF(lwp) WRITE(numout,*) ' IDTRA averaged properties absent - setting to zero ...'
+ qint_idtra(:,:,1) = 0.0 !! CHN
+ ENDIF
+ !!
+ !! calculate stats on these fields
+ IF(lwp) WRITE(numout,*) ' IDTRA averaged properties stats (min, max, sum) ...'
+ call trc_rst_dia_stat(qint_idtra(:,:,1), 'qint_IDTRA')
+#endif
+ !
+#if defined key_cfc
+ DO jl = 1, jp_cfc
+ jn = jp_cfc0 + jl - 1
+ IF( iom_varid( numrtr, 'qint_'//ctrcnm(jn), ldstop = .FALSE. ) > 0 ) THEN
+ !! YES; in which case read them
+ !!
+ IF(lwp) WRITE(numout,*) ' CFC averaged properties present - reading in ...'
+ CALL iom_get( numrtr, jpdom_autoglo, 'qint_'//ctrcnm(jn), qint_cfc(:,:,jl) )
+ ELSE
+ !! NO; in which case set them to zero
+ !!
+ IF(lwp) WRITE(numout,*) ' CFC averaged properties absent - setting to zero ...'
+ qint_cfc(:,:,jn) = 0.0 !! CHN
+ ENDIF
+ !!
+ !! calculate stats on these fields
+ IF(lwp) WRITE(numout,*) ' CFC averaged properties stats (min, max, sum) ...'
+ call trc_rst_dia_stat(qint_cfc(:,:,jl), 'qint_'//ctrcnm(jn))
+ END DO
+#endif
!
END SUBROUTINE trc_rst_read
@@ -128,6 +388,8 @@
INTEGER, INTENT( in ) :: kt ! ocean time-step index
!!
- INTEGER :: jn
+ INTEGER :: jn, jl
REAL(wp) :: zarak0
+ !! AXY (05/11/13): temporary variables
+ REAL(wp) :: fq0,fq1,fq2
!!----------------------------------------------------------------------
!
@@ -142,5 +404,129 @@
CALL iom_rstput( kt, nitrst, numrtw, 'TRB'//ctrcnm(jn), trb(:,:,:,jn) )
END DO
- !
+
+ !! AXY (09/06/14): the ARCHER version of MEDUSA-2 does not include an equivalent
+ !! call to MEDUSA-2 at this point; this suggests that the FCM
+ !! version of NEMO date significantly earlier than the current
+ !! version
+
+#if defined key_medusa
+ !! AXY (13/01/12): write out "before" and "now" state of seafloor
+ !! sediment pools into restart; this happens
+ !! whether or not the pools are to be used by
+ !! MEDUSA (which is controlled by a switch in the
+ !! namelist_top file)
+ !!
+ IF(lwp) WRITE(numout,*) ' MEDUSA sediment fields - writing out ...'
+ CALL iom_rstput( kt, nitrst, numrtw, 'B_SED_N', zb_sed_n(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'N_SED_N', zn_sed_n(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'B_SED_FE', zb_sed_fe(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'N_SED_FE', zn_sed_fe(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'B_SED_SI', zb_sed_si(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'N_SED_SI', zn_sed_si(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'B_SED_C', zb_sed_c(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'N_SED_C', zn_sed_c(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'B_SED_CA', zb_sed_ca(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'N_SED_CA', zn_sed_ca(:,:) )
+ !!
+ !! calculate stats on these fields
+ IF(lwp) WRITE(numout,*) ' MEDUSA sediment field stats (min, max, sum) ...'
+ call trc_rst_dia_stat(zn_sed_n(:,:), 'Sediment N')
+ call trc_rst_dia_stat(zn_sed_fe(:,:), 'Sediment Fe')
+ call trc_rst_dia_stat(zn_sed_si(:,:), 'Sediment Si')
+ call trc_rst_dia_stat(zn_sed_c(:,:), 'Sediment C')
+ call trc_rst_dia_stat(zn_sed_ca(:,:), 'Sediment Ca')
+ !!
+ !! AXY (07/07/15): write out temporally averaged fields for DMS
+ !! calculations
+ !!
+ IF(lwp) WRITE(numout,*) ' MEDUSA averaged properties for DMS - writing out ...'
+ CALL iom_rstput( kt, nitrst, numrtw, 'B_DMS_CHN', zb_dms_chn(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'N_DMS_CHN', zn_dms_chn(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'B_DMS_CHD', zb_dms_chd(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'N_DMS_CHD', zn_dms_chd(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'B_DMS_MLD', zb_dms_mld(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'N_DMS_MLD', zn_dms_mld(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'B_DMS_QSR', zb_dms_qsr(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'N_DMS_QSR', zn_dms_qsr(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'B_DMS_DIN', zb_dms_din(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'N_DMS_DIN', zn_dms_din(:,:) )
+ !! JPALM 14-06-2016 -- add CO2 flux and DMS surf through the restart
+ !! -- needed for the coupling with atm
+ CALL iom_rstput( kt, nitrst, numrtw, 'B_DMS_srf', zb_dms_srf(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'N_DMS_srf', zn_dms_srf(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'B_CO2_flx', zb_co2_flx(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'N_CO2_flx', zn_co2_flx(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'N_CHL_srf', zn_chl_srf(:,:) )
+ !!
+ !! calculate stats on these fields
+ IF(lwp) WRITE(numout,*) ' MEDUSA averaged properties for DMS stats (min, max, sum) ...'
+ call trc_rst_dia_stat(zn_dms_chn(:,:), 'DMS, CHN')
+ call trc_rst_dia_stat(zn_dms_chd(:,:), 'DMS, CHD')
+ call trc_rst_dia_stat(zn_dms_mld(:,:), 'DMS, MLD')
+ call trc_rst_dia_stat(zn_dms_qsr(:,:), 'DMS, QSR')
+ call trc_rst_dia_stat(zn_dms_din(:,:), 'DMS, DIN')
+ call trc_rst_dia_stat(zn_dms_srf(:,:), 'DMS surf')
+ call trc_rst_dia_stat(zn_co2_flx(:,:), 'CO2 flux')
+ call trc_rst_dia_stat(zn_chl_srf(:,:), 'CHL surf')
+ !!
+ IF(lwp) WRITE(numout,*) ' MEDUSA averaged prop. for dust and iron dep.'
+ call trc_rst_dia_stat(dust(:,:), 'Dust dep')
+ call trc_rst_dia_stat(zirondep(:,:), 'Iron dep')
+ !!
+ !!
+ !! JPALM 14-06-2016 -- add Carbonate chenistry variables through the restart
+ !! -- needed for monthly call of carb-chem routine and better reproducibility
+# if defined key_roam
+ IF(lwp) WRITE(numout,*) 'Carbonate chem variable - writing out ...'
+ CALL iom_rstput( kt, nitrst, numrtw, 'pH_3D' , f3_pH(:,:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'h2CO3_3D', f3_h2co3(:,:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'hCO3_3D' , f3_hco3(:,:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'CO3_3D' , f3_co3(:,:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'omcal_3D', f3_omcal(:,:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'omarg_3D', f3_omarg(:,:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'CCD_CAL' , f2_ccd_cal(:,:) )
+ CALL iom_rstput( kt, nitrst, numrtw, 'CCD_ARG' , f2_ccd_arg(:,:) )
+ !!
+ IF(lwp) WRITE(numout,*) ' MEDUSA averaged Carb-chem stats (min, max, sum) ...'
+ call trc_rst_dia_stat( f3_pH(:,:,1) ,'pH 3D surf')
+ call trc_rst_dia_stat( f3_h2co3(:,:,1),'h2CO3 3D surf')
+ call trc_rst_dia_stat( f3_hco3(:,:,1) ,'hCO3 3D surf' )
+ call trc_rst_dia_stat( f3_co3(:,:,1) ,'CO3 3D surf' )
+ call trc_rst_dia_stat( f3_omcal(:,:,1),'omcal 3D surf')
+ call trc_rst_dia_stat( f3_omarg(:,:,1),'omarg 3D surf')
+ call trc_rst_dia_stat( f2_ccd_cal(:,:),'CCD_CAL')
+ call trc_rst_dia_stat( f2_ccd_arg(:,:),'CCD_ARG')
+ !!
+# endif
+!!
+#endif
+ !
+#if defined key_idtra
+ !! JPALM -- 05-01-2016 -- mv idtra and CFC restart reading and
+ !! writting here undre their key.
+ !! problems in CFC restart, maybe because of this...
+ !! and pb in idtra diag or diad-restart writing.
+ !!----------------------------------------------------------------------
+ IF(lwp) WRITE(numout,*) ' IDTRA averaged properties - writing out ...'
+ CALL iom_rstput( kt, nitrst, numrtw, 'qint_IDTRA', qint_idtra(:,:,1) )
+ !!
+ !! calculate stats on these fields
+ IF(lwp) WRITE(numout,*) ' IDTRA averaged properties stats (min, max, sum) ...'
+ call trc_rst_dia_stat(qint_idtra(:,:,1), 'qint_IDTRA')
+#endif
+ !
+#if defined key_cfc
+ DO jl = 1, jp_cfc
+ jn = jp_cfc0 + jl - 1
+ IF(lwp) WRITE(numout,*) ' CFC averaged properties - writing out ...'
+ CALL iom_rstput( kt, nitrst, numrtw, 'qint_'//ctrcnm(jn), qint_cfc(:,:,jl) )
+ !!
+ !! calculate stats on these fields
+ IF(lwp) WRITE(numout,*) ' CFC averaged properties stats (min, max, sum) ...'
+ call trc_rst_dia_stat(qint_cfc(:,:,jl), 'qint_'//ctrcnm(jn))
+ END DO
+#endif
+ !
+
IF( kt == nitrst ) THEN
CALL trc_rst_stat ! statistics
@@ -304,9 +690,84 @@
IF(lwp) WRITE(numout,9000) jn, TRIM( ctrcnm(jn) ), zmean, zmin, zmax, zdrift
END DO
- WRITE(numout,*)
+ IF(lwp) WRITE(numout,*)
9000 FORMAT(' tracer nb :',i2,' name :',a10,' mean :',e18.10,' min :',e18.10, &
& ' max :',e18.10,' drift :',e18.10, ' %')
!
END SUBROUTINE trc_rst_stat
+
+
+ SUBROUTINE trc_rst_tra_stat
+ !!----------------------------------------------------------------------
+ !! *** trc_rst_tra_stat ***
+ !!
+ !! ** purpose : Compute tracers statistics - check where crazy values appears
+ !!----------------------------------------------------------------------
+ INTEGER :: jk, jn
+ REAL(wp) :: ztraf, zmin, zmax, zmean, zdrift, areasf
+ REAL(wp), DIMENSION(jpi,jpj) :: zvol
+ !!----------------------------------------------------------------------
+
+ IF( lwp ) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) ' ----SURFACE TRA STAT---- '
+ WRITE(numout,*)
+ ENDIF
+ !
+ zvol(:,:) = e1e2t(:,:) * fse3t_a(:,:,1) * tmask(:,:,1)
+ areasf = glob_sum(zvol(:,:))
+ DO jn = 1, jptra
+ ztraf = glob_sum( tra(:,:,1,jn) * zvol(:,:) )
+ zmin = MINVAL( tra(:,:,1,jn), mask= ((tmask(:,:,1).NE.0.)) )
+ zmax = MAXVAL( tra(:,:,1,jn), mask= ((tmask(:,:,1).NE.0.)) )
+ IF( lk_mpp ) THEN
+ CALL mpp_min( zmin ) ! min over the global domain
+ CALL mpp_max( zmax ) ! max over the global domain
+ END IF
+ zmean = ztraf / areasf
+ IF(lwp) WRITE(numout,9001) jn, TRIM( ctrcnm(jn) ), zmean, zmin, zmax
+ END DO
+ IF(lwp) WRITE(numout,*)
+9001 FORMAT(' tracer nb :',i2,' name :',a10,' mean :',e18.10,' min :',e18.10, &
+ & ' max :',e18.10)
+ !
+ END SUBROUTINE trc_rst_tra_stat
+
+
+
+ SUBROUTINE trc_rst_dia_stat( dgtr, names)
+ !!----------------------------------------------------------------------
+ !! *** trc_rst_dia_stat ***
+ !!
+ !! ** purpose : Compute tracers statistics
+ !!----------------------------------------------------------------------
+ REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: dgtr ! 2D diag var
+ CHARACTER(len=*) , INTENT(in) :: names ! 2D diag name
+ !!---------------------------------------------------------------------
+ INTEGER :: jk, jn
+ REAL(wp) :: ztraf, zmin, zmax, zmean, areasf
+ REAL(wp), DIMENSION(jpi,jpj) :: zvol
+ !!----------------------------------------------------------------------
+
+ IF( lwp ) WRITE(numout,*) 'STAT- ', names
+ !
+ zvol(:,:) = e1e2t(:,:) * fse3t_a(:,:,1) * tmask(:,:,1)
+ ztraf = glob_sum( dgtr(:,:) * zvol(:,:) )
+ !! areasf = glob_sum(e1e2t(:,:) * tmask(:,:,1) )
+ areasf = glob_sum(zvol(:,:))
+ zmin = MINVAL( dgtr(:,:), mask= ((tmask(:,:,1).NE.0.)) )
+ zmax = MAXVAL( dgtr(:,:), mask= ((tmask(:,:,1).NE.0.)) )
+ IF( lk_mpp ) THEN
+ CALL mpp_min( zmin ) ! min over the global domain
+ CALL mpp_max( zmax ) ! max over the global domain
+ END IF
+ zmean = ztraf / areasf
+ IF(lwp) WRITE(numout,9002) TRIM( names ), zmean, zmin, zmax
+ !
+ IF(lwp) WRITE(numout,*)
+9002 FORMAT(' tracer name :',a10,' mean :',e18.10,' min :',e18.10, &
+ & ' max :',e18.10 )
+ !
+ END SUBROUTINE trc_rst_dia_stat
+
#else
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcsms.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcsms.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcsms.F90 (revision 8155)
@@ -16,6 +16,9 @@
USE trc !
USE trcsms_pisces ! PISCES biogeo-model
+ USE trcsms_medusa ! MEDUSA tracers
+ USE trcsms_idtra ! Idealize Tracer
USE trcsms_cfc ! CFC 11 & 12
USE trcsms_c14b ! C14b tracer
+ USE trcsms_age ! AGE tracer
USE trcsms_my_trc ! MY_TRC tracers
USE prtctl_trc ! Print control for debbuging
@@ -43,4 +46,5 @@
INTEGER, INTENT( in ) :: kt ! ocean time-step index
!!
+ INTEGER :: jn
CHARACTER (len=25) :: charout
!!---------------------------------------------------------------------
@@ -49,6 +53,29 @@
!
IF( lk_pisces ) CALL trc_sms_pisces ( kt ) ! main program of PISCES
+ IF( lk_medusa ) CALL trc_sms_medusa ( kt ) ! MEDUSA tracers
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) '--trcsms : MEDUSA OK -- next IDTRA -- '
+ CALL flush(numout)
+# endif
+ IF( lk_idtra ) CALL trc_sms_idtra ( kt ) ! radioactive decay of Id. tracer
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) '--trcsms : IDTRA OK -- next CFC -- '
+ CALL flush(numout)
+# endif
IF( lk_cfc ) CALL trc_sms_cfc ( kt ) ! surface fluxes of CFC
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) '--trcsms : CFC OK -- next C14 -- '
+ CALL flush(numout)
+# endif
IF( lk_c14b ) CALL trc_sms_c14b ( kt ) ! surface fluxes of C14
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) '--trcsms : C14 OK -- next C14 -- '
+ CALL flush(numout)
+# endif
+ IF( lk_age ) CALL trc_sms_age ( kt ) ! AGE tracer
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) '--trcsms : Age OK -- Continue -- '
+ CALL flush(numout)
+# endif
IF( lk_my_trc ) CALL trc_sms_my_trc ( kt ) ! MY_TRC tracers
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcstp.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcstp.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcstp.F90 (revision 8155)
@@ -55,4 +55,7 @@
!! Update the passive tracers
!!-------------------------------------------------------------------
+
+ USE dom_oce, ONLY: narea
+
INTEGER, INTENT( in ) :: kt ! ocean time-step index
INTEGER :: jk, jn ! dummy loop indices
@@ -87,5 +90,13 @@
tra(:,:,:,:) = 0.e0
!
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' MEDUSA trc_stp begins at kt =', kt
+ CALL flush(numout)
+# endif
CALL trc_rst_opn ( kt ) ! Open tracer restart file
+# if defined key_debug_medusa
+ CALL trc_rst_stat
+ CALL trc_rst_tra_stat
+# endif
IF( lrst_trc ) CALL trc_rst_cal ( kt, 'WRITE' ) ! calendar
IF( lk_iomput ) THEN ; CALL trc_wri ( kt ) ! output of passive tracers with iom I/O manager
@@ -93,5 +104,17 @@
ENDIF
CALL trc_sms ( kt ) ! tracers: sinks and sources
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' MEDUSA trc_stp SMS complete at kt =', kt
+ CALL trc_rst_stat
+ CALL trc_rst_tra_stat
+ CALL flush(numout)
+# endif
CALL trc_trp ( kt ) ! transport of passive tracers
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' MEDUSA trc_stp transport complete at kt =', kt
+ CALL trc_rst_stat
+ CALL trc_rst_tra_stat
+ CALL flush(numout)
+# endif
IF( kt == nittrc000 ) THEN
CALL iom_close( numrtr ) ! close input tracer restart file
@@ -102,13 +125,28 @@
!
IF( nn_dttrc /= 1 ) CALL trc_sub_reset( kt ) ! resetting physical variables when sub-stepping
- !
- ENDIF
- !
- ztrai = 0._wp ! content of all tracers
- DO jn = 1, jptra
- ztrai = ztrai + glob_sum( trn(:,:,:,jn) * cvol(:,:,:) )
- END DO
- IF( lwp ) WRITE(numstr,9300) kt, ztrai / areatot
-9300 FORMAT(i10,e18.10)
+# if defined key_debug_medusa
+ IF(lwp) WRITE(numout,*) ' MEDUSA trc_stp ends at kt =', kt
+ CALL flush(numout)
+# endif
+ !
+ ENDIF
+ !
+ IF (ln_ctl) THEN
+ ! The following code is very expensive since it involves multiple
+ ! reproducible global sums over all tracer fields and is potentially
+ ! called on every timestep. The results it produces are purely for
+ ! informational purposes and do not affect model evolution.
+ ! Hence we restrict its use by protecting it with the ln_ctl RTL
+ ! which should normally only be used under debugging conditions
+ ! and not in operational runs. We also need to restrict output
+ ! to the master PE since there's no point duplicating the same results
+ ! on all processors.
+ ztrai = 0._wp ! content of all tracers
+ DO jn = 1, jptra
+ ztrai = ztrai + glob_sum( trn(:,:,:,jn) * cvol(:,:,:) )
+ END DO
+ IF( numstr /= -1 ) WRITE(numstr,9300) kt, ztrai / areatot
+9300 FORMAT(i10,e18.10)
+ ENDIF
!
IF( nn_timing == 1 ) CALL timing_stop('trc_stp')
Index: /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcwri.F90
===================================================================
--- /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcwri.F90 (revision 8154)
+++ /branches/UKMO/dev_r5518_GO6_MEDUSA_dummyrun/NEMOGCM/NEMO/TOP_SRC/trcwri.F90 (revision 8155)
@@ -5,4 +5,5 @@
!!======================================================================
!! History : 1.0 ! 2009-05 (C. Ethe) Original code
+ !! - ! 2014-06 (A. Yool, J. Palmieri) adding MEDUSA-2
!!----------------------------------------------------------------------
#if defined key_top && defined key_iomput
@@ -21,4 +22,7 @@
USE trcwri_c14b
USE trcwri_my_trc
+ USE trcwri_medusa
+ USE trcwri_idtra
+ USE trcwri_age
IMPLICIT NONE
@@ -57,6 +61,9 @@
! ---------------------------------------
IF( lk_pisces ) CALL trc_wri_pisces ! PISCES
+ IF( lk_medusa ) CALL trc_wri_medusa ! MESDUSA
+ IF( lk_idtra ) CALL trc_wri_idtra ! Idealize tracers
IF( lk_cfc ) CALL trc_wri_cfc ! surface fluxes of CFC
IF( lk_c14b ) CALL trc_wri_c14b ! surface fluxes of C14
+ IF( lk_age ) CALL trc_wri_age ! AGE tracer
IF( lk_my_trc ) CALL trc_wri_my_trc ! MY_TRC tracers
!