Changeset 4785
- Timestamp:
- 2014-09-24T14:03:02+02:00 (10 years ago)
- Location:
- branches/2014/dev_r4765_CNRS_agrif/NEMOGCM
- Files:
-
- 31 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/iodef.xml
r4696 r4785 148 148 </context> 149 149 150 <context id="1_nemo" time_origin="1950-01-01 00:00:00" > 151 152 <!-- $id$ --> 153 154 <!-- 155 ============================================================================================================ 156 = definition of all existing variables = 157 = DO NOT CHANGE = 158 ============================================================================================================ 159 --> 160 <field_definition src="./field_def.xml"/> 161 <!-- 162 ============================================================================================================ 163 = output files definition = 164 = Define your own files = 165 = put the variables you want... = 166 ============================================================================================================ 167 --> 168 169 <file_definition type="multiple_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="10d" min_digits="4"> 170 171 <file_group id="1ts" output_freq="1ts" output_level="10" enabled=".TRUE."/> <!-- 1 time step files --> 172 <file_group id="1h" output_freq="1h" output_level="10" enabled=".TRUE."/> <!-- 1h files --> 173 <file_group id="2h" output_freq="2h" output_level="10" enabled=".TRUE."/> <!-- 2h files --> 174 <file_group id="3h" output_freq="3h" output_level="10" enabled=".TRUE."/> <!-- 3h files --> 175 <file_group id="4h" output_freq="4h" output_level="10" enabled=".TRUE."/> <!-- 4h files --> 176 <file_group id="6h" output_freq="6h" output_level="10" enabled=".TRUE."/> <!-- 6h files --> 177 <file_group id="1d" output_freq="1d" output_level="10" enabled=".TRUE."/> <!-- 1d files --> 178 <file_group id="3d" output_freq="3d" output_level="10" enabled=".TRUE."/> <!-- 3d files --> 179 180 <file_group id="5d" output_freq="5d" output_level="10" enabled=".TRUE." > <!-- 5d files --> 181 182 <file id="file1" name_suffix="_grid_T" description="ocean T grid variables" > 183 <field field_ref="sst" name="tos" long_name="sea_surface_temperature" /> 184 <field field_ref="sss" name="sos" long_name="sea_surface_salinity" /> 185 <field field_ref="ssh" name="zos" long_name="sea_surface_height_above_geoid" /> 186 <field field_ref="toce" name="thetao" long_name="sea_water_potential_temperature" /> 187 <field field_ref="soce" name="so" long_name="sea_water_salinity" /> 188 <field field_ref="sst2" name="tossq" long_name="square_of_sea_surface_temperature" /> 189 <field field_ref="ssh2" name="zossq" long_name="square_of_sea_surface_height_above_geoid" /> 190 <field field_ref="mldkz5" /> 191 <field field_ref="mldr10_1" /> 192 <field field_ref="empmr" name="wfo" long_name="water_flux_into_sea_water" /> 193 <field field_ref="qsr" name="rsntds" long_name="surface_net_downward_shortwave_flux" /> 194 <field field_ref="qt" name="tohfls" long_name="surface_net_downward_total_heat_flux" /> 195 <field field_ref="saltflx" name="sosflxdo" /> 196 <field field_ref="taum" name="taum" /> 197 <field field_ref="wspd" name="sowindsp" /> 198 <field field_ref="precip" name="soprecip" /> 199 </file> 200 201 <file id="file3" name_suffix="_grid_U" description="ocean U grid variables" > 202 <field field_ref="suoce" name="uos" long_name="sea_surface_x_velocity" /> 203 <field field_ref="uoce" name="uo" long_name="sea_water_x_velocity" /> 204 <field field_ref="utau" name="tauuo" long_name="surface_downward_x_stress" /> 205 <!-- variables available with MLE 206 <field field_ref="psiu_mle" name="psiu_mle" long_name="MLE_streamfunction_along_i-axis" /> 207 --> 208 </file> 209 210 <file id="file4" name_suffix="_grid_V" description="ocean V grid variables" > 211 <field field_ref="svoce" name="vos" long_name="sea_surface_y_velocity" /> 212 <field field_ref="voce" name="vo" long_name="sea_water_y_velocity" /> 213 <field field_ref="vtau" name="tauvo" long_name="surface_downward_y_stress" /> 214 <!-- variables available with MLE 215 <field field_ref="psiv_mle" name="psiv_mle" long_name="MLE_streamfunction_along_j-axis" /> 216 --> 217 </file> 218 219 <file id="file5" name_suffix="_grid_W" description="ocean W grid variables" > 220 <field field_ref="woce" name="wo" long_name="ocean vertical velocity" /> 221 <field field_ref="avt" name="difvho" long_name="ocean_vertical_heat_diffusivity" /> 222 </file> 223 <!-- 224 <file id="file6" name_suffix="_icemod" description="ice variables" > 225 <field field_ref="ice_pres" /> 226 <field field_ref="snowthic_cea" name="snd" long_name="surface_snow_thickness" /> 227 <field field_ref="icethic_cea" name="sit" long_name="sea_ice_thickness" /> 228 <field field_ref="iceprod_cea" name="sip" long_name="sea_ice_thickness" /> 229 <field field_ref="ist_ipa" /> 230 <field field_ref="uice_ipa" /> 231 <field field_ref="vice_ipa" /> 232 <field field_ref="utau_ice" /> 233 <field field_ref="vtau_ice" /> 234 <field field_ref="qsr_io_cea" /> 235 <field field_ref="qns_io_cea" /> 236 <field field_ref="snowpre" /> 237 </file> 238 239 <file id="file8" name_suffix="_Tides" description="tidal harmonics" > 240 <field field_ref="M2x" name="M2x" long_name="M2 Elevation harmonic real part" /> 241 <field field_ref="M2y" name="M2y" long_name="M2 Elevation harmonic imaginary part" /> 242 <field field_ref="M2x_u" name="M2x_u" long_name="M2 current barotrope along i-axis harmonic real part " /> 243 <field field_ref="M2y_u" name="M2y_u" long_name="M2 current barotrope along i-axis harmonic imaginary part " /> 244 <field field_ref="M2x_v" name="M2x_v" long_name="M2 current barotrope along j-axis harmonic real part " /> 245 <field field_ref="M2y_v" name="M2y_v" long_name="M2 current barotrope along j-axis harmonic imaginary part " /> 246 </file> 247 --> 248 </file_group> 249 250 251 <file_group id="1m" output_freq="1mo" output_level="10" enabled=".TRUE."/> <!-- real monthly files --> 252 253 254 <file_group id="2m" output_freq="2mo" output_level="10" enabled=".TRUE."/> <!-- real 2m files --> 255 <file_group id="3m" output_freq="3mo" output_level="10" enabled=".TRUE."/> <!-- real 3m files --> 256 <file_group id="4m" output_freq="4mo" output_level="10" enabled=".TRUE."/> <!-- real 4m files --> 257 <file_group id="6m" output_freq="6mo" output_level="10" enabled=".TRUE."/> <!-- real 6m files --> 258 259 <file_group id="1y" output_freq="1y" output_level="10" enabled=".TRUE."/> <!-- real yearly files --> 260 <file_group id="2y" output_freq="2y" output_level="10" enabled=".TRUE."/> <!-- real 2y files --> 261 <file_group id="5y" output_freq="5y" output_level="10" enabled=".TRUE."/> <!-- real 5y files --> 262 <file_group id="10y" output_freq="10y" output_level="10" enabled=".TRUE."/> <!-- real 10y files --> 263 264 </file_definition> 265 266 <!-- 267 ============================================================================================================ 268 = grid definition = = DO NOT CHANGE = 269 ============================================================================================================ 270 --> 271 272 <axis_definition> 273 <axis id="deptht" long_name="Vertical T levels" unit="m" positive="down" /> 274 <axis id="depthu" long_name="Vertical U levels" unit="m" positive="down" /> 275 <axis id="depthv" long_name="Vertical V levels" unit="m" positive="down" /> 276 <axis id="depthw" long_name="Vertical W levels" unit="m" positive="down" /> 277 <axis id="nfloat" long_name="Float number" unit="-" /> 278 <axis id="icbcla" long_name="Iceberg class" unit="-" /> 279 </axis_definition> 280 281 <domain_definition src="./domain_def.xml"/> 282 283 <grid_definition> 284 <grid id="grid_T_2D" domain_ref="grid_T"/> 285 <grid id="grid_T_3D" domain_ref="grid_T" axis_ref="deptht"/> 286 <grid id="grid_U_2D" domain_ref="grid_U"/> 287 <grid id="grid_U_3D" domain_ref="grid_U" axis_ref="depthu"/> 288 <grid id="grid_V_2D" domain_ref="grid_V"/> 289 <grid id="grid_V_3D" domain_ref="grid_V" axis_ref="depthv"/> 290 <grid id="grid_W_2D" domain_ref="grid_W"/> 291 <grid id="grid_W_3D" domain_ref="grid_W" axis_ref="depthw"/> 292 </grid_definition> 293 </context> 150 294 151 295 <context id="xios"> -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/CONFIG/SHARED/1_namelist_ref
r4698 r4785 31 31 nn_leapy = 0 ! Leap year calendar (1) or not (0) 32 32 ln_rstart = .false. ! start from rest (F) or from a restart file (T) 33 nn_euler = 1 ! = 0 : start with forward time step if ln_rstart=.true. 33 34 nn_rstctl = 0 ! restart control => activated only if ln_rstart = T 34 35 ! = 0 nn_date0 read in namelist ; nn_it000 : read in namelist … … 119 120 ! 120 121 rn_rdt = 5760. ! time step for the dynamics (and tracer if nn_acc=0) 121 nn_baro = 64 ! number of barotropic time step ("key_dynspg_ts")122 122 rn_atfp = 0.1 ! asselin time filter parameter 123 123 nn_acc = 0 ! acceleration of convergence : =1 used, rdt < rdttra(k) … … 150 150 ppkth2 = 48.029893720000 ! 151 151 ppacr2 = 13.000000000000 ! 152 / 153 !----------------------------------------------------------------------- 154 &namsplit ! time splitting parameters ("key_dynspg_ts") 155 !----------------------------------------------------------------------- 156 ln_bt_fw = .TRUE. ! Forward integration of barotropic equations 157 ln_bt_av = .TRUE. ! Time filtering of barotropic variables 158 ln_bt_nn_auto = .TRUE. ! Set nn_baro automatically to be just below 159 ! a user defined maximum courant number (rn_bt_cmax) 160 nn_baro = 30 ! Number of iterations of barotropic mode 161 ! during rn_rdt seconds. Only used if ln_bt_nn_auto=F 162 rn_bt_cmax = 0.8 ! Maximum courant number allowed if ln_bt_nn_auto=T 163 nn_bt_flt = 1 ! Time filter choice 164 ! = 0 None 165 ! = 1 Boxcar over nn_baro barotropic steps 166 ! = 2 Boxcar over 2*nn_baro " " 152 167 / 153 168 !----------------------------------------------------------------------- -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/EXTERNAL/AGRIF/LIB/Makefile.lex
r4779 r4785 3 3 4 4 all: main.c fortran.c 5 YACC = bison6 5 7 6 main.c : convert.tab.c convert.yy.c -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/EXTERNAL/AGRIF/LIB/SubLoopCreation.c
r4779 r4785 120 120 strcat(ligne,parcours->var->v_nomvar); 121 121 didvariableadded = 1; 122 122 } 123 123 parcours = parcours -> suiv; 124 124 } … … 131 131 strcat(ligne,parcours->var->v_nomvar); 132 132 didvariableadded = 1; 133 133 } 134 134 parcours = parcours -> suiv; 135 135 } … … 249 249 strcat(ligne,parcours->var->v_nomvar); 250 250 didvariableadded = 1; 251 251 } 252 252 parcours = parcours -> suiv; 253 253 } … … 331 331 332 332 AddUseAgrifUtilBeforeCall_0(fortran_out); 333 WriteArgumentDeclaration_beforecall(); 333 334 if ( functiondeclarationisdone == 0 ) WriteFunctionDeclaration(fortran_out, 0); 334 335 if ( !strcasecmp(subofagrifinitgrids,subroutinename) ) … … 378 379 if ( ImplicitNoneInSubroutine() == 1 ) fprintf(fortran_out, " implicit none\n"); 379 380 WriteLocalParamDeclaration(fortran_out); 381 WriteArgumentDeclaration_beforecall(); 380 382 if ( functiondeclarationisdone == 0 ) WriteFunctionDeclaration(fortran_out, 0); 381 383 /* WriteSubroutineDeclaration(0);*/ -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/EXTERNAL/AGRIF/LIB/UtilListe.c
r4779 r4785 554 554 } 555 555 tmpvar -> suiv = newvar; 556 }556 } 557 557 else 558 558 { -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/EXTERNAL/AGRIF/LIB/WorkWithParameterlist.c
r4779 r4785 49 49 if ( VariableIsParameter ) 50 50 List_GlobalParameter_Var = AddListvarToListvar(listin, List_GlobalParameter_Var, 1); 51 }52 51 } 53 52 -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/EXTERNAL/AGRIF/LIB/WorkWithlistofmodulebysubroutine.c
r4779 r4785 299 299 } 300 300 } 301 }302 301 newmodule = newmodule ->suiv; 303 302 } -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/EXTERNAL/AGRIF/LIB/WorkWithlistvarindoloop.c
r4779 r4785 615 615 { 616 616 Merge_Variables(parcours->var,parcours1->var); 617 } 617 618 else 618 619 { -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/EXTERNAL/AGRIF/LIB/decl.h
r4779 r4785 251 251 int PrivateDeclare; /* Variable has been declared as PRIVATE */ 252 252 int ExternalDeclare; /* Variable has been declared as EXTERNAL */ 253 char InitialValueGiven[LONG_C];253 int InitialValueGiven; /* An initial value has been given */ 254 254 int Allocatabledeclare; 255 255 int Targetdeclare; … … 333 333 FILE *subloop; 334 334 FILE *module_declar; 335 FILE *module_declar_type;336 335 FILE *allocationagrif; 337 336 -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/EXTERNAL/AGRIF/LIB/fortran.c
r4779 r4785 1206 1206 0, 0, 0, 275, 276, 0, 0, 0, 0, 331, 1207 1207 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1208 0, 0, 0, 0, 0, 0, 0, 0, 339, 340,1209 0, 347, 350, 349, 342, 343, 344, 341, 0, 403,1210 250, 247, 0, 279, 316, 318, 315, 281, 314, 280,1211 351, 249, 0, 0, 356, 357, 429, 0, 69, 101,1212 0, 355, 427, 0, 150, 0, 148, 0, 428, 0,1213 415, 414, 393, 538, 0, 540, 0, 417, 408, 35,1214 384, 0, 470, 468, 0, 456, 0, 0, 0, 0,1215 162, 0, 0, 138, 0, 53, 172, 173, 158, 143,1216 144, 170, 169, 234, 235, 108, 72, 52, 30, 15,1217 25, 0, 0, 11, 39, 22, 12, 0, 0, 55,1218 166, 127, 164, 0, 125, 0, 236, 120, 125, 165,1219 137, 0, 165, 0, 0, 0, 236, 154, 159, 0,1220 0, 0, 112, 50, 0, 177, 174, 209, 210, 0,1221 0, 0, 179, 0, 0, 178, 0, 16, 236, 368,1222 363, 37, 382, 381, 383, 164, 409, 407, 0, 0,1223 0, 421, 0, 442, 439, 444, 430, 0, 452, 506,1224 507, 485, 0, 0, 0, 0, 338, 0, 505, 492,1225 493, 453, 458, 462, 0, 484, 0, 454, 390, 0,1226 0, 432, 386, 0, 284, 277, 0, 0, 0, 0,1227 1208 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1228 1209 0, 0, 334, 329, 330, 0, 337, 340, 339, 333, … … 1773 1754 155, 156, 157, 158, 159, 0, 160, 0, 0, 0, 1774 1755 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1775 177, 0, 531, 0, 0, 0, 0, 0, 0, 149,1776 0, 178, 179, 0, 0, 0, 0, 180, 150, 151,1777 532, 0, 0, 0, 0, 0, 0, 181, 182, 0,1778 0, 183, 184, 185, 186, 0, 152, 153, 91, 0,1779 0, 154, 155, 156, 157, 187, 0, 0, 188, 0,1780 0, 0, 0, 158, 159, 160, 161, 162, 163, 164,1781 0, 165, 166, 167, 0, 0, 168, 169, 170, 0,1782 171, 172, 173, 174, 175, 0, 176, 0, 0, 0,1783 1756 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1784 1757 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, … … 1793 1766 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1794 1767 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1795 0, 0, 0, 0, 0, 0, 0, 0, 177, 0,1796 650, 0, 0, 0, 0, 0, 0, 149, 0, 178,1797 179, 0, 0, 0, 0, 180, 150, 151, 0, 651,1798 0, 0, 0, 0, 0, 181, 182, 0, 0, 183,1799 184, 185, 186, 0, 152, 153, 91, 0, 0, 154,1800 155, 156, 157, 187, 0, 0, 188, 0, 0, 0,1801 0, 158, 159, 160, 161, 162, 163, 164, 0, 165,1802 166, 167, 0, 0, 168, 169, 170, 0, 171, 172,1803 173, 174, 175, 0, 176, 0, 0, 0, 0, 0,1804 1768 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1805 1769 0, 0, 472, 0, 0, 0, 0, 0, 132, 0, … … 1834 1798 159, 0, 160, 0, 0, 0, 0, 0, 0, 0, 1835 1799 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1836 0, 0, 0, 0, 177, 0, 633, 0, 0, 0,1837 0, 0, 0, 149, 0, 178, 179, 0, 0, 0,1838 0, 180, 150, 151, 0, 0, 0, 0, 0, 0,1839 0, 181, 182, 0, 0, 183, 184, 185, 186, 0,1840 152, 153, 91, 0, 0, 154, 155, 156, 157, 187,1841 0, 0, 188, 0, 0, 0, 0, 158, 159, 160,1842 161, 162, 163, 164, 0, 165, 166, 167, 0, 0,1843 168, 169, 170, 0, 171, 172, 173, 174, 175, 0,1844 176, 0, 0, 0, 0, 0, 0, 0, 0, 0,1845 1800 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1846 1801 0, 0, 0, 0, 0, 0, 0, 0, 0, 615, … … 1865 1820 160, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1866 1821 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1867 0, 0, 177, 0, 655, 0, 0, 0, 0, 0,1868 0, 149, 0, 178, 179, 0, 0, 0, 0, 180,1869 150, 151, 0, 0, 0, 0, 0, 0, 0, 181,1870 182, 0, 0, 183, 184, 185, 186, 0, 152, 153,1871 91, 0, 0, 154, 155, 156, 157, 187, 0, 0,1872 188, 0, 0, 0, 0, 158, 159, 160, 161, 162,1873 163, 164, 0, 165, 166, 167, 0, 0, 168, 169,1874 170, 0, 171, 172, 173, 174, 175, 0, 176, 0,1875 1822 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1876 1823 0, 0, 0, 0, 0, 0, 0, 639, 0, 0, … … 1920 1867 0, 160, 0, 0, 0, 0, 0, 0, 0, 0, 1921 1868 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1922 0, 0, 0, 0, 0, 0, 177, 0, 0, 0,1923 0, 0, 0, 0, 0, 149, 0, 178, 179, 0,1924 0, 0, 0, 180, 150, 151, 532, 0, 0, 0,1925 0, 0, 0, 181, 182, 0, 0, 183, 184, 185,1926 186, 0, 152, 153, 91, 0, 0, 154, 155, 156,1927 157, 187, 0, 0, 748, 0, 0, 0, 0, 158,1928 159, 160, 161, 162, 163, 164, 0, 165, 166, 167,1929 0, 0, 168, 169, 170, 0, 171, 172, 173, 174,1930 175, 0, 176, 0, 0, 0, 0, 0, 0, 0,1931 1869 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1932 1870 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, … … 1941 1879 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1942 1880 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1943 0, 0, 0, 0, 177, 0, 0, 0, 0, 0,1944 0, 0, 0, 149, 0, 178, 179, 0, 0, 0,1945 0, 180, 150, 151, 557, 0, 0, 0, 0, 0,1946 0, 181, 182, 0, 0, 183, 184, 185, 186, 0,1947 152, 153, 538, 0, 0, 154, 155, 156, 157, 187,1948 0, 0, 188, 0, 0, 0, 0, 158, 159, 160,1949 161, 162, 163, 164, 0, 165, 166, 167, 0, 0,1950 168, 169, 170, 0, 171, 172, 173, 174, 175, 0,1951 176, 0, 0, 0, 0, 0, 0, 0, 0, 0,1952 1881 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1953 1882 0, 0, 0, 132, 0, 0, 0, 0, 161, 0, … … 1961 1890 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1962 1891 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1963 0, 0, 177, 0, 0, 0, 0, 0, 0, 0,1964 0, 149, 0, 178, 179, 0, 0, 0, 0, 180,1965 150, 151, 532, 0, 0, 0, 0, 0, 0, 181,1966 182, 0, 0, 183, 184, 185, 186, 0, 152, 153,1967 91, 0, 0, 154, 155, 156, 157, 187, 0, 0,1968 188, 0, 0, 0, 0, 158, 159, 160, 161, 162,1969 163, 164, 0, 165, 166, 167, 0, 0, 168, 169,1970 170, 0, 171, 172, 173, 174, 175, 0, 176, 0,1971 1892 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1972 1893 0, 0, 132, 0, 0, 0, 0, 161, 0, 0, … … 2024 1945 156, 157, 158, 159, 0, 160, 0, 0, 0, 0, 2025 1946 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2026 0, 0, 0, 0, 177, 0, 0, 0, 0, 0,2027 0, 0, 0, 149, 0, 178, 179, 0, 0, 0,2028 0, 180, 150, 151, 0, 0, 0, 0, 0, 0,2029 0, 181, 182, 0, 0, 183, 184, 185, 186, 0,2030 152, 153, 91, 0, 0, 154, 155, 156, 157, 187,2031 0, 0, 188, 0, 0, 0, 0, 158, 159, 160,2032 161, 162, 163, 164, 0, 165, 166, 167, 0, 0,2033 168, 169, 170, 0, 171, 172, 173, 174, 175, 0,2034 176, 0, 0, 0, 0, 0, 0, 0, 0, 0,2035 1947 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2036 1948 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, … … 2045 1957 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2046 1958 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2047 0, 0, 177, 0, 0, 0, 0, 0, 0, 0,2048 0, 149, 0, 178, 179, 0, 0, 0, 0, 180,2049 150, 151, 0, 0, 0, 0, 0, 0, 0, 181,2050 182, 0, 0, 183, 184, 185, 186, 0, 152, 153,2051 91, 0, 0, 154, 155, 156, 157, 187, 0, 0,2052 188, 0, 0, 0, 0, 158, 159, 160, 161, 162,2053 163, 164, 0, 165, 166, 167, 0, 0, 168, 169,2054 170, 0, 171, 172, 173, 174, 175, 0, 176, 0,2055 1959 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2056 1960 0, 0, 0, 0, 0, 0, 0, 132, 0, 0, … … 2074 1978 159, 0, 160, 0, 0, 0, 0, 0, 0, 0, 2075 1979 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2076 177, 0, 0, 0, 0, 0, 0, 0, 0, 149,2077 0, 178, 179, 0, 0, 0, 0, 180, 150, 151,2078 0, 0, 0, 0, 0, 0, 0, 181, 182, 0,2079 0, 183, 184, 185, 186, 0, 152, 153, 91, 0,2080 0, 154, 155, 156, 157, 187, 0, 0, 381, 0,2081 0, 0, 0, 158, 159, 160, 161, 162, 163, 164,2082 0, 165, 166, 167, 0, 0, 168, 169, 170, 0,2083 171, 172, 173, 174, 175, 0, 176, 0, 0, 0,2084 1980 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2085 1981 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, … … 2094 1990 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2095 1991 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2096 0, 0, 0, 0, 0, 0, 0, 0, 177, 0,2097 0, 0, 0, 0, 0, 0, 0, 149, 0, 178,2098 179, 0, 0, 0, 0, 180, 150, 151, 0, 0,2099 0, 0, 0, 0, 0, 181, 182, 0, 0, 183,2100 184, 185, 186, 0, 152, 153, 91, 0, 0, 154,2101 155, 156, 157, 444, 0, 0, 188, 0, 0, 0,2102 0, 158, 159, 160, 161, 162, 163, 164, 0, 165,2103 166, 167, 0, 0, 168, 169, 170, 0, 171, 172,2104 173, 174, 175, 0, 176, 0, 0, 0, 0, 0,2105 1992 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2106 1993 0, 0, 0, 0, 132, 0, 0, 0, 0, 161, … … 2448 2335 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 2449 2336 -1, -1, -1, -1, 163, 164, 165, -1, -1, -1, 2450 -1, -1, -1, -1, -1, -1, -1, -1, 40, -1,2451 -1, -1, 44, 45, 46, 47, -1, -1, -1, -1,2452 -1, -1, -1, -1, 56, 57, 58, 59, 60, 61,2453 62, -1, 64, 65, 66, 180, -1, 69, 70, 71,2454 185, 186, 74, 75, 76, 77, -1, 79, -1, 131,2455 -1, -1, -1, -1, -1, -1, -1, -1, 12, -1,2456 142, 143, -1, -1, -1, -1, 148, 21, 22, -1,2457 -1, -1, -1, -1, -1, -1, 158, 159, -1, -1,2458 162, 163, 164, 165, -1, 39, 40, 169, -1, -1,2459 44, 45, 46, 47, 176, 185, 186, 179, -1, -1,2460 -1, -1, 56, 57, 58, 59, 60, 61, 62, -1,2461 64, 65, 66, -1, -1, 69, 70, 71, -1, 73,2462 74, 75, 76, 77, -1, 79, -1, -1, -1, -1,2463 -1, -1, -1, -1, -1, -1, -1, 169, -1, -1,2464 2337 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 2465 2338 -1, -1, -1, 163, 164, 165, 5, 6, 7, 8, -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/EXTERNAL/AGRIF/LIB/fortran.y
r4779 r4785 275 275 %type <na> opt_signe 276 276 %type <na> filename 277 %type <na c> attribute277 %type <na> attribute 278 278 %type <na> complex_const 279 279 %type <na> begin_array … … 751 751 752 752 save : before_save varsave 753 | before_save 753 | before_save comblock varsave 754 754 | save opt_comma comblock opt_comma varsave 755 755 | save ',' varsave … … 1325 1325 InitialValueGiven = 2; 1326 1326 } 1327 | before_initial TOK_POINT_TO expr1328 {1329 if ( couldaddvariable == 1 )1330 {1331 strcpy(InitValue,$3);1332 strcpy(InitialValueGiven,"=>");1333 }1334 }1335 1327 ; 1336 1328 complex_const : -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/EXTERNAL/AGRIF/LIB/main.c
r4779 r4785 1 /* A Bison parser, made by GNU Bison 2.7.12-4996. */ 2 3 /* Bison implementation for Yacc-like parsers in C 4 5 Copyright (C) 1984, 1989-1990, 2000-2013 Free Software Foundation, Inc. 6 7 This program is free software: you can redistribute it and/or modify 1 /* A Bison parser, made by GNU Bison 2.3. */ 2 3 /* Skeleton implementation for Bison's Yacc-like parsers in C 4 5 Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006 6 Free Software Foundation, Inc. 7 8 This program is free software; you can redistribute it and/or modify 8 9 it under the terms of the GNU General Public License as published by 9 the Free Software Foundation , either version 3 of the License, or10 (at your option)any later version.11 10 the Free Software Foundation; either version 2, or (at your option) 11 any later version. 12 12 13 This program is distributed in the hope that it will be useful, 13 14 but WITHOUT ANY WARRANTY; without even the implied warranty of 14 15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 16 GNU General Public License for more details. 16 17 17 18 You should have received a copy of the GNU General Public License 18 along with this program. If not, see <http://www.gnu.org/licenses/>. */ 19 along with this program; if not, write to the Free Software 20 Foundation, Inc., 51 Franklin Street, Fifth Floor, 21 Boston, MA 02110-1301, USA. */ 19 22 20 23 /* As a special exception, you may create a larger work that contains … … 27 30 Bison output files to be licensed under the GNU General Public 28 31 License without this special exception. 29 32 30 33 This special exception was added by the Free Software Foundation in 31 34 version 2.2 of Bison. */ … … 45 48 46 49 /* Bison version. */ 47 #define YYBISON_VERSION "2. 7.12-4996"50 #define YYBISON_VERSION "2.3" 48 51 49 52 /* Skeleton name. */ … … 53 56 #define YYPURE 0 54 57 55 /* Push parsers. */56 #define YY PUSH058 /* Using locations. */ 59 #define YYLSP_NEEDED 0 57 60 58 61 /* Substitute the variable and function names. */ … … 97 100 98 101 102 103 99 104 /* Copy the first part of user declarations. */ 100 /* Line 371 of yacc.c */101 105 #line 35 "convert.y" 102 106 … … 130 134 #endif 131 135 132 133 /* Enabling traces. */ 134 #ifndef YYDEBUG 135 # define YYDEBUG 0 136 #endif 137 #if YYDEBUG 138 extern int yydebug; 139 #endif 140 141 /* Tokens. */ 142 #ifndef YYTOKENTYPE 143 # define YYTOKENTYPE 144 /* Put the tokens into the symbol table, so that GDB and other debuggers 145 know about them. */ 146 enum yytokentype { 147 TOK_SEP = 258, 148 TOK_USE = 259, 149 TOK_MODULEMAIN = 260, 150 TOK_NOTGRIDDEP = 261, 151 TOK_USEITEM = 262, 152 TOK_NAME = 263, 153 TOK_PROBTYPE = 264 154 }; 155 #endif 156 136 /* Enabling the token table. */ 137 #ifndef YYTOKEN_TABLE 138 # define YYTOKEN_TABLE 0 139 #endif 157 140 158 141 #if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED 159 142 typedef union YYSTYPE 160 143 #line 52 "convert.y" 161 144 { 162 145 char na[LONG_M]; 163 146 } … … 167 150 # define yystype YYSTYPE /* obsolescent; will be withdrawn */ 168 151 # define YYSTYPE_IS_DECLARED 1 169 #endif 170 171 extern YYSTYPE yylval; 172 173 #ifdef YYPARSE_PARAM 174 #if defined __STDC__ || defined __cplusplus 175 int yyparse (void *YYPARSE_PARAM); 176 #else 177 int yyparse (); 178 #endif 179 #else /* ! YYPARSE_PARAM */ 180 #if defined __STDC__ || defined __cplusplus 181 int yyparse (void); 182 #else 183 int yyparse (); 184 #endif 185 #endif /* ! YYPARSE_PARAM */ 152 # define YYSTYPE_IS_TRIVIAL 1 153 #endif 186 154 187 155 … … 189 157 /* Copy the second part of user declarations. */ 190 158 191 /* Line 390 of yacc.c */192 #line 159 "convert.tab.c"193 159 194 160 /* Line 216 of yacc.c. */ … … 246 212 # if ENABLE_NLS 247 213 # include <libintl.h> /* INFRINGES ON USER NAME SPACE */ 248 # define YY_( Msgid) dgettext ("bison-runtime", Msgid)214 # define YY_(msgid) dgettext ("bison-runtime", msgid) 249 215 # endif 250 216 # endif 251 217 # ifndef YY_ 252 # define YY_(Msgid) Msgid 253 # endif 254 #endif 255 256 #ifndef __attribute__ 257 /* This feature is available in gcc versions 2.5 and later. */ 258 # if (! defined __GNUC__ || __GNUC__ < 2 \ 259 || (__GNUC__ == 2 && __GNUC_MINOR__ < 5)) 260 # define __attribute__(Spec) /* empty */ 218 # define YY_(msgid) msgid 261 219 # endif 262 220 #endif … … 264 222 /* Suppress unused-variable warnings by "using" E. */ 265 223 #if ! defined lint || defined __GNUC__ 266 # define YYUSE( E) ((void) (E))224 # define YYUSE(e) ((void) (e)) 267 225 #else 268 # define YYUSE(E) /* empty */ 269 #endif 270 226 # define YYUSE(e) /* empty */ 227 #endif 271 228 272 229 /* Identity function, used to suppress warnings about constant conditions. */ 273 230 #ifndef lint 274 # define YYID( N) (N)231 # define YYID(n) (n) 275 232 #else 276 233 #if (defined __STDC__ || defined __C99__FUNC__ \ 277 234 || defined __cplusplus || defined _MSC_VER) 278 235 static int 279 YYID (int yyi)236 YYID (int i) 280 237 #else 281 238 static int 282 YYID ( yyi)283 int yyi;284 #endif 285 { 286 return yyi;239 YYID (i) 240 int i; 241 #endif 242 { 243 return i; 287 244 } 288 245 #endif … … 305 262 # else 306 263 # define YYSTACK_ALLOC alloca 307 # if ! defined _ALLOCA_H && ! defined EXIT_SUCCESS&& (defined __STDC__ || defined __C99__FUNC__ \264 # if ! defined _ALLOCA_H && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ 308 265 || defined __cplusplus || defined _MSC_VER) 309 266 # include <stdlib.h> /* INFRINGES ON USER NAME SPACE */ 310 /* Use EXIT_SUCCESS as a witness for stdlib.h. */ 311 # ifndef EXIT_SUCCESS 312 # define EXIT_SUCCESS 0 267 # ifndef _STDLIB_H 268 # define _STDLIB_H 1 313 269 # endif 314 270 # endif … … 333 289 # define YYSTACK_ALLOC_MAXIMUM YYSIZE_MAXIMUM 334 290 # endif 335 # if (defined __cplusplus && ! defined EXIT_SUCCESS\291 # if (defined __cplusplus && ! defined _STDLIB_H \ 336 292 && ! ((defined YYMALLOC || defined malloc) \ 337 293 && (defined YYFREE || defined free))) 338 294 # include <stdlib.h> /* INFRINGES ON USER NAME SPACE */ 339 # ifndef EXIT_SUCCESS340 # define EXIT_SUCCESS 0295 # ifndef _STDLIB_H 296 # define _STDLIB_H 1 341 297 # endif 342 298 # endif 343 299 # ifndef YYMALLOC 344 300 # define YYMALLOC malloc 345 # if ! defined malloc && ! defined EXIT_SUCCESS&& (defined __STDC__ || defined __C99__FUNC__ \301 # if ! defined malloc && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ 346 302 || defined __cplusplus || defined _MSC_VER) 347 303 void *malloc (YYSIZE_T); /* INFRINGES ON USER NAME SPACE */ … … 350 306 # ifndef YYFREE 351 307 # define YYFREE free 352 # if ! defined free && ! defined EXIT_SUCCESS&& (defined __STDC__ || defined __C99__FUNC__ \308 # if ! defined free && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ 353 309 || defined __cplusplus || defined _MSC_VER) 354 310 void free (void *); /* INFRINGES ON USER NAME SPACE */ … … 366 322 union yyalloc 367 323 { 368 yytype_int16 yyss _alloc;369 YYSTYPE yyvs _alloc;370 };324 yytype_int16 yyss; 325 YYSTYPE yyvs; 326 }; 371 327 372 328 /* The size of the maximum gap between one aligned stack and the next. */ … … 379 335 + YYSTACK_GAP_MAXIMUM) 380 336 381 # define YYCOPY_NEEDED 1 337 /* Copy COUNT objects from FROM to TO. The source and destination do 338 not overlap. */ 339 # ifndef YYCOPY 340 # if defined __GNUC__ && 1 < __GNUC__ 341 # define YYCOPY(To, From, Count) \ 342 __builtin_memcpy (To, From, (Count) * sizeof (*(From))) 343 # else 344 # define YYCOPY(To, From, Count) \ 345 do \ 346 { \ 347 YYSIZE_T yyi; \ 348 for (yyi = 0; yyi < (Count); yyi++) \ 349 (To)[yyi] = (From)[yyi]; \ 350 } \ 351 while (YYID (0)) 352 # endif 353 # endif 382 354 383 355 /* Relocate STACK from its old location to the new one. The … … 386 358 stack. Advance YYPTR to a properly aligned location for the next 387 359 stack. */ 388 # define YYSTACK_RELOCATE(Stack _alloc, Stack)\360 # define YYSTACK_RELOCATE(Stack) \ 389 361 do \ 390 362 { \ 391 363 YYSIZE_T yynewbytes; \ 392 YYCOPY (&yyptr->Stack _alloc, Stack, yysize);\393 Stack = &yyptr->Stack _alloc;\364 YYCOPY (&yyptr->Stack, Stack, yysize); \ 365 Stack = &yyptr->Stack; \ 394 366 yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \ 395 367 yyptr += yynewbytes / sizeof (*yyptr); \ … … 398 370 399 371 #endif 400 401 #if defined YYCOPY_NEEDED && YYCOPY_NEEDED402 /* Copy COUNT objects from SRC to DST. The source and destination do403 not overlap. */404 # ifndef YYCOPY405 # if defined __GNUC__ && 1 < __GNUC__406 # define YYCOPY(Dst, Src, Count) \407 __builtin_memcpy (Dst, Src, (Count) * sizeof (*(Src)))408 # else409 # define YYCOPY(Dst, Src, Count) \410 do \411 { \412 YYSIZE_T yyi; \413 for (yyi = 0; yyi < (Count); yyi++) \414 (Dst)[yyi] = (Src)[yyi]; \415 } \416 while (YYID (0))417 # endif418 # endif419 #endif /* !YYCOPY_NEEDED */420 372 421 373 /* YYFINAL -- State number of the termination state. */ … … 499 451 #endif 500 452 501 #if YYDEBUG || YYERROR_VERBOSE || 0453 #if YYDEBUG || YYERROR_VERBOSE || YYTOKEN_TABLE 502 454 /* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM. 503 455 First, the terminals, then, starting at YYNTOKENS, nonterminals. */ … … 507 459 "TOK_USE", "TOK_MODULEMAIN", "TOK_NOTGRIDDEP", "TOK_USEITEM", "TOK_NAME", 508 460 "TOK_CSTINT", "TOK_PROBTYPE", "','", "';'", "'\\n'", "$accept", "input", 509 "line", YY_NULL461 "line", 0 510 462 }; 511 463 #endif … … 535 487 }; 536 488 537 /* YYDEFACT[STATE-NAME] -- Default r eduction number in state STATE-NUM.538 Performedwhen YYTABLE doesn't specify something else to do. Zero489 /* YYDEFACT[STATE-NAME] -- Default rule to reduce with in state 490 STATE-NUM when YYTABLE doesn't specify something else to do. Zero 539 491 means the default is an error. */ 540 492 static const yytype_uint8 yydefact[] = … … 569 521 /* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If 570 522 positive, shift that token. If negative, reduce the rule which 571 number is the opposite. If YYTABLE_NINF, syntax error. */ 523 number is the opposite. If zero, do what YYDEFACT says. 524 If YYTABLE_NINF, syntax error. */ 572 525 #define YYTABLE_NINF -1 573 526 static const yytype_uint8 yytable[] = … … 578 531 }; 579 532 580 #define yypact_value_is_default(Yystate) \581 (!!((Yystate) == (-10)))582 583 #define yytable_value_is_error(Yytable_value) \584 YYID (0)585 586 533 static const yytype_int8 yycheck[] = 587 534 { … … 612 559 /* Like YYERROR except do call yyerror. This remains here temporarily 613 560 to ease the transition to the new meaning of YYERROR, for GCC. 614 Once GCC version 2 has supplanted version 1, this can go. However, 615 YYFAIL appears to be in use. Nevertheless, it is formally deprecated 616 in Bison 2.4.2's NEWS entry, where a plan to phase it out is 617 discussed. */ 561 Once GCC version 2 has supplanted version 1, this can go. */ 618 562 619 563 #define YYFAIL goto yyerrlab 620 #if defined YYFAIL621 /* This is here to suppress warnings from the GCC cpp's622 -Wunused-macros. Normally we don't worry about that warning, but623 some users do, and we want to make it easy for users to remove624 YYFAIL uses, which will produce warnings from Bison 2.5. */625 #endif626 564 627 565 #define YYRECOVERING() (!!yyerrstatus) 628 566 629 #define YYBACKUP(Token, Value) 630 do 631 if (yychar == YYEMPTY )\632 { 633 yychar = (Token); 634 yylval = (Value); 635 YYPOPSTACK (yylen);\636 yystate = *yyssp;\637 goto yybackup; 638 } 639 else 640 { 567 #define YYBACKUP(Token, Value) \ 568 do \ 569 if (yychar == YYEMPTY && yylen == 1) \ 570 { \ 571 yychar = (Token); \ 572 yylval = (Value); \ 573 yytoken = YYTRANSLATE (yychar); \ 574 YYPOPSTACK (1); \ 575 goto yybackup; \ 576 } \ 577 else \ 578 { \ 641 579 yyerror (YY_("syntax error: cannot back up")); \ 642 580 YYERROR; \ … … 644 582 while (YYID (0)) 645 583 646 /* Error token number */ 584 647 585 #define YYTERROR 1 648 586 #define YYERRCODE 256 649 587 650 588 651 /* This macro is provided for backward compatibility. */ 589 /* YYLLOC_DEFAULT -- Set CURRENT to span from RHS[1] to RHS[N]. 590 If N is 0, then set CURRENT to the empty location which ends 591 the previous symbol: RHS[0] (always defined). */ 592 593 #define YYRHSLOC(Rhs, K) ((Rhs)[K]) 594 #ifndef YYLLOC_DEFAULT 595 # define YYLLOC_DEFAULT(Current, Rhs, N) \ 596 do \ 597 if (YYID (N)) \ 598 { \ 599 (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \ 600 (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \ 601 (Current).last_line = YYRHSLOC (Rhs, N).last_line; \ 602 (Current).last_column = YYRHSLOC (Rhs, N).last_column; \ 603 } \ 604 else \ 605 { \ 606 (Current).first_line = (Current).last_line = \ 607 YYRHSLOC (Rhs, 0).last_line; \ 608 (Current).first_column = (Current).last_column = \ 609 YYRHSLOC (Rhs, 0).last_column; \ 610 } \ 611 while (YYID (0)) 612 #endif 613 614 615 /* YY_LOCATION_PRINT -- Print the location on the stream. 616 This macro was not mandated originally: define only if we know 617 we won't break user code: when these are the locations we know. */ 618 652 619 #ifndef YY_LOCATION_PRINT 653 # define YY_LOCATION_PRINT(File, Loc) ((void) 0) 620 # if defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL 621 # define YY_LOCATION_PRINT(File, Loc) \ 622 fprintf (File, "%d.%d-%d.%d", \ 623 (Loc).first_line, (Loc).first_column, \ 624 (Loc).last_line, (Loc).last_column) 625 # else 626 # define YY_LOCATION_PRINT(File, Loc) ((void) 0) 627 # endif 654 628 #endif 655 629 656 630 657 631 /* YYLEX -- calling `yylex' with the right arguments. */ 632 658 633 #ifdef YYLEX_PARAM 659 634 # define YYLEX yylex (YYLEX_PARAM) … … 705 680 #endif 706 681 { 707 FILE *yyo = yyoutput;708 YYUSE (yyo);709 682 if (!yyvaluep) 710 683 return; … … 715 688 YYUSE (yyoutput); 716 689 # endif 717 YYUSE (yytype); 690 switch (yytype) 691 { 692 default: 693 break; 694 } 718 695 } 719 696 … … 752 729 || defined __cplusplus || defined _MSC_VER) 753 730 static void 754 yy_stack_print (yytype_int16 * yybottom, yytype_int16 *yytop)731 yy_stack_print (yytype_int16 *bottom, yytype_int16 *top) 755 732 #else 756 733 static void 757 yy_stack_print ( yybottom, yytop)758 yytype_int16 * yybottom;759 yytype_int16 * yytop;734 yy_stack_print (bottom, top) 735 yytype_int16 *bottom; 736 yytype_int16 *top; 760 737 #endif 761 738 { 762 739 YYFPRINTF (stderr, "Stack now"); 763 for (; yybottom <= yytop; yybottom++) 764 { 765 int yybot = *yybottom; 766 YYFPRINTF (stderr, " %d", yybot); 767 } 740 for (; bottom <= top; ++bottom) 741 YYFPRINTF (stderr, " %d", *bottom); 768 742 YYFPRINTF (stderr, "\n"); 769 743 } … … 799 773 for (yyi = 0; yyi < yynrhs; yyi++) 800 774 { 801 YYFPRINTF(stderr, " $%d = ", yyi + 1);775 fprintf (stderr, " $%d = ", yyi + 1); 802 776 yy_symbol_print (stderr, yyrhs[yyprhs[yyrule] + yyi], 803 777 &(yyvsp[(yyi + 1) - (yynrhs)]) 804 778 ); 805 YYFPRINTF(stderr, "\n");779 fprintf (stderr, "\n"); 806 780 } 807 781 } … … 839 813 # define YYMAXDEPTH 10000 840 814 #endif 815 816 841 817 842 818 … … 942 918 # endif 943 919 944 /* Copy into *YYMSG, which is of size *YYMSG_ALLOC, an error message 945 about the unexpected token YYTOKEN for the state stack whose top is 946 YYSSP. 947 948 Return 0 if *YYMSG was successfully written. Return 1 if *YYMSG is 949 not large enough to hold the message. In that case, also set 950 *YYMSG_ALLOC to the required number of bytes. Return 2 if the 951 required number of bytes is too large to store. */ 952 static int 953 yysyntax_error (YYSIZE_T *yymsg_alloc, char **yymsg, 954 yytype_int16 *yyssp, int yytoken) 955 { 956 YYSIZE_T yysize0 = yytnamerr (YY_NULL, yytname[yytoken]); 957 YYSIZE_T yysize = yysize0; 958 enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 }; 959 /* Internationalized format string. */ 960 const char *yyformat = YY_NULL; 961 /* Arguments of yyformat. */ 962 char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM]; 963 /* Number of reported tokens (one for the "unexpected", one per 964 "expected"). */ 965 int yycount = 0; 966 967 /* There are many possibilities here to consider: 968 - Assume YYFAIL is not used. It's too flawed to consider. See 969 <http://lists.gnu.org/archive/html/bison-patches/2009-12/msg00024.html> 970 for details. YYERROR is fine as it does not invoke this 971 function. 972 - If this state is a consistent state with a default action, then 973 the only way this function was invoked is if the default action 974 is an error action. In that case, don't check for expected 975 tokens because there are none. 976 - The only way there can be no lookahead present (in yychar) is if 977 this state is a consistent state with a default action. Thus, 978 detecting the absence of a lookahead is sufficient to determine 979 that there is no unexpected or expected token to report. In that 980 case, just report a simple "syntax error". 981 - Don't assume there isn't a lookahead just because this state is a 982 consistent state with a default action. There might have been a 983 previous inconsistent state, consistent state with a non-default 984 action, or user semantic action that manipulated yychar. 985 - Of course, the expected token list depends on states to have 986 correct lookahead information, and it depends on the parser not 987 to perform extra reductions after fetching a lookahead from the 988 scanner and before detecting a syntax error. Thus, state merging 989 (from LALR or IELR) and default reductions corrupt the expected 990 token list. However, the list is correct for canonical LR with 991 one exception: it will still contain any token that will not be 992 accepted due to an error action in a later state. 993 */ 994 if (yytoken != YYEMPTY) 920 /* Copy into YYRESULT an error message about the unexpected token 921 YYCHAR while in state YYSTATE. Return the number of bytes copied, 922 including the terminating null byte. If YYRESULT is null, do not 923 copy anything; just return the number of bytes that would be 924 copied. As a special case, return 0 if an ordinary "syntax error" 925 message will do. Return YYSIZE_MAXIMUM if overflow occurs during 926 size calculation. */ 927 static YYSIZE_T 928 yysyntax_error (char *yyresult, int yystate, int yychar) 929 { 930 int yyn = yypact[yystate]; 931 932 if (! (YYPACT_NINF < yyn && yyn <= YYLAST)) 933 return 0; 934 else 995 935 { 996 int yyn = yypact[*yyssp]; 997 yyarg[yycount++] = yytname[yytoken]; 998 if (!yypact_value_is_default (yyn)) 999 { 1000 /* Start YYX at -YYN if negative to avoid negative indexes in 1001 YYCHECK. In other words, skip the first -YYN actions for 1002 this state because they are default actions. */ 1003 int yyxbegin = yyn < 0 ? -yyn : 0; 1004 /* Stay within bounds of both yycheck and yytname. */ 1005 int yychecklim = YYLAST - yyn + 1; 1006 int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS; 1007 int yyx; 1008 1009 for (yyx = yyxbegin; yyx < yyxend; ++yyx) 1010 if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR 1011 && !yytable_value_is_error (yytable[yyx + yyn])) 1012 { 1013 if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM) 1014 { 1015 yycount = 1; 1016 yysize = yysize0; 1017 break; 1018 } 1019 yyarg[yycount++] = yytname[yyx]; 1020 { 1021 YYSIZE_T yysize1 = yysize + yytnamerr (YY_NULL, yytname[yyx]); 1022 if (! (yysize <= yysize1 1023 && yysize1 <= YYSTACK_ALLOC_MAXIMUM)) 1024 return 2; 1025 yysize = yysize1; 1026 } 1027 } 1028 } 936 int yytype = YYTRANSLATE (yychar); 937 YYSIZE_T yysize0 = yytnamerr (0, yytname[yytype]); 938 YYSIZE_T yysize = yysize0; 939 YYSIZE_T yysize1; 940 int yysize_overflow = 0; 941 enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 }; 942 char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM]; 943 int yyx; 944 945 # if 0 946 /* This is so xgettext sees the translatable formats that are 947 constructed on the fly. */ 948 YY_("syntax error, unexpected %s"); 949 YY_("syntax error, unexpected %s, expecting %s"); 950 YY_("syntax error, unexpected %s, expecting %s or %s"); 951 YY_("syntax error, unexpected %s, expecting %s or %s or %s"); 952 YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s"); 953 # endif 954 char *yyfmt; 955 char const *yyf; 956 static char const yyunexpected[] = "syntax error, unexpected %s"; 957 static char const yyexpecting[] = ", expecting %s"; 958 static char const yyor[] = " or %s"; 959 char yyformat[sizeof yyunexpected 960 + sizeof yyexpecting - 1 961 + ((YYERROR_VERBOSE_ARGS_MAXIMUM - 2) 962 * (sizeof yyor - 1))]; 963 char const *yyprefix = yyexpecting; 964 965 /* Start YYX at -YYN if negative to avoid negative indexes in 966 YYCHECK. */ 967 int yyxbegin = yyn < 0 ? -yyn : 0; 968 969 /* Stay within bounds of both yycheck and yytname. */ 970 int yychecklim = YYLAST - yyn + 1; 971 int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS; 972 int yycount = 1; 973 974 yyarg[0] = yytname[yytype]; 975 yyfmt = yystpcpy (yyformat, yyunexpected); 976 977 for (yyx = yyxbegin; yyx < yyxend; ++yyx) 978 if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR) 979 { 980 if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM) 981 { 982 yycount = 1; 983 yysize = yysize0; 984 yyformat[sizeof yyunexpected - 1] = '\0'; 985 break; 986 } 987 yyarg[yycount++] = yytname[yyx]; 988 yysize1 = yysize + yytnamerr (0, yytname[yyx]); 989 yysize_overflow |= (yysize1 < yysize); 990 yysize = yysize1; 991 yyfmt = yystpcpy (yyfmt, yyprefix); 992 yyprefix = yyor; 993 } 994 995 yyf = YY_(yyformat); 996 yysize1 = yysize + yystrlen (yyf); 997 yysize_overflow |= (yysize1 < yysize); 998 yysize = yysize1; 999 1000 if (yysize_overflow) 1001 return YYSIZE_MAXIMUM; 1002 1003 if (yyresult) 1004 { 1005 /* Avoid sprintf, as that infringes on the user's name space. 1006 Don't have undefined behavior even if the translation 1007 produced a string with the wrong number of "%s"s. */ 1008 char *yyp = yyresult; 1009 int yyi = 0; 1010 while ((*yyp = *yyf) != '\0') 1011 { 1012 if (*yyp == '%' && yyf[1] == 's' && yyi < yycount) 1013 { 1014 yyp += yytnamerr (yyp, yyarg[yyi++]); 1015 yyf += 2; 1016 } 1017 else 1018 { 1019 yyp++; 1020 yyf++; 1021 } 1022 } 1023 } 1024 return yysize; 1029 1025 } 1030 1031 switch (yycount)1032 {1033 # define YYCASE_(N, S) \1034 case N: \1035 yyformat = S; \1036 break1037 YYCASE_(0, YY_("syntax error"));1038 YYCASE_(1, YY_("syntax error, unexpected %s"));1039 YYCASE_(2, YY_("syntax error, unexpected %s, expecting %s"));1040 YYCASE_(3, YY_("syntax error, unexpected %s, expecting %s or %s"));1041 YYCASE_(4, YY_("syntax error, unexpected %s, expecting %s or %s or %s"));1042 YYCASE_(5, YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s"));1043 # undef YYCASE_1044 }1045 1046 {1047 YYSIZE_T yysize1 = yysize + yystrlen (yyformat);1048 if (! (yysize <= yysize1 && yysize1 <= YYSTACK_ALLOC_MAXIMUM))1049 return 2;1050 yysize = yysize1;1051 }1052 1053 if (*yymsg_alloc < yysize)1054 {1055 *yymsg_alloc = 2 * yysize;1056 if (! (yysize <= *yymsg_alloc1057 && *yymsg_alloc <= YYSTACK_ALLOC_MAXIMUM))1058 *yymsg_alloc = YYSTACK_ALLOC_MAXIMUM;1059 return 1;1060 }1061 1062 /* Avoid sprintf, as that infringes on the user's name space.1063 Don't have undefined behavior even if the translation1064 produced a string with the wrong number of "%s"s. */1065 {1066 char *yyp = *yymsg;1067 int yyi = 0;1068 while ((*yyp = *yyformat) != '\0')1069 if (*yyp == '%' && yyformat[1] == 's' && yyi < yycount)1070 {1071 yyp += yytnamerr (yyp, yyarg[yyi++]);1072 yyformat += 2;1073 }1074 else1075 {1076 yyp++;1077 yyformat++;1078 }1079 }1080 return 0;1081 1026 } 1082 1027 #endif /* YYERROR_VERBOSE */ 1028 1029 1083 1030 1084 1031 /*-----------------------------------------------. … … 1105 1052 YY_SYMBOL_PRINT (yymsg, yytype, yyvaluep, yylocationp); 1106 1053 1107 YYUSE (yytype); 1108 } 1109 1110 1111 1112 1113 /* The lookahead symbol. */ 1054 switch (yytype) 1055 { 1056 1057 default: 1058 break; 1059 } 1060 } 1061 1062 1063 1064 /* Prevent warnings from -Wmissing-prototypes. */ 1065 1066 #ifdef YYPARSE_PARAM 1067 #if defined __STDC__ || defined __cplusplus 1068 int yyparse (void *YYPARSE_PARAM); 1069 #else 1070 int yyparse (); 1071 #endif 1072 #else /* ! YYPARSE_PARAM */ 1073 #if defined __STDC__ || defined __cplusplus 1074 int yyparse (void); 1075 #else 1076 int yyparse (); 1077 #endif 1078 #endif /* ! YYPARSE_PARAM */ 1079 1080 1081 1082 /* The look-ahead symbol. */ 1114 1083 int yychar; 1115 1084 1116 1117 #ifndef YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN 1118 # define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN 1119 # define YY_IGNORE_MAYBE_UNINITIALIZED_END 1120 #endif 1121 #ifndef YY_INITIAL_VALUE 1122 # define YY_INITIAL_VALUE(Value) /* Nothing. */ 1123 #endif 1124 1125 /* The semantic value of the lookahead symbol. */ 1126 YYSTYPE yylval YY_INITIAL_VALUE(yyval_default); 1085 /* The semantic value of the look-ahead symbol. */ 1086 YYSTYPE yylval; 1127 1087 1128 1088 /* Number of syntax errors so far. */ 1129 1089 int yynerrs; 1090 1130 1091 1131 1092 … … 1156 1117 #endif 1157 1118 { 1158 int yystate; 1159 /* Number of tokens to shift before error messages enabled. */ 1160 int yyerrstatus; 1161 1162 /* The stacks and their tools: 1163 `yyss': related to states. 1164 `yyvs': related to semantic values. 1165 1166 Refer to the stacks through separate pointers, to allow yyoverflow 1167 to reallocate them elsewhere. */ 1168 1169 /* The state stack. */ 1170 yytype_int16 yyssa[YYINITDEPTH]; 1171 yytype_int16 *yyss; 1172 yytype_int16 *yyssp; 1173 1174 /* The semantic value stack. */ 1175 YYSTYPE yyvsa[YYINITDEPTH]; 1176 YYSTYPE *yyvs; 1177 YYSTYPE *yyvsp; 1178 1179 YYSIZE_T yystacksize; 1180 1119 1120 int yystate; 1181 1121 int yyn; 1182 1122 int yyresult; 1183 /* Lookahead token as an internal (translated) token number. */ 1123 /* Number of tokens to shift before error messages enabled. */ 1124 int yyerrstatus; 1125 /* Look-ahead token as an internal (translated) token number. */ 1184 1126 int yytoken = 0; 1185 /* The variables used to return semantic value and location from the1186 action routines. */1187 YYSTYPE yyval;1188 1189 1127 #if YYERROR_VERBOSE 1190 1128 /* Buffer for error messages, and its allocated size. */ … … 1194 1132 #endif 1195 1133 1134 /* Three stacks and their tools: 1135 `yyss': related to states, 1136 `yyvs': related to semantic values, 1137 `yyls': related to locations. 1138 1139 Refer to the stacks thru separate pointers, to allow yyoverflow 1140 to reallocate them elsewhere. */ 1141 1142 /* The state stack. */ 1143 yytype_int16 yyssa[YYINITDEPTH]; 1144 yytype_int16 *yyss = yyssa; 1145 yytype_int16 *yyssp; 1146 1147 /* The semantic value stack. */ 1148 YYSTYPE yyvsa[YYINITDEPTH]; 1149 YYSTYPE *yyvs = yyvsa; 1150 YYSTYPE *yyvsp; 1151 1152 1153 1196 1154 #define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N)) 1155 1156 YYSIZE_T yystacksize = YYINITDEPTH; 1157 1158 /* The variables used to return semantic value and location from the 1159 action routines. */ 1160 YYSTYPE yyval; 1161 1197 1162 1198 1163 /* The number of symbols on the RHS of the reduced rule. … … 1200 1165 int yylen = 0; 1201 1166 1202 yyssp = yyss = yyssa;1203 yyvsp = yyvs = yyvsa;1204 yystacksize = YYINITDEPTH;1205 1206 1167 YYDPRINTF ((stderr, "Starting parse\n")); 1207 1168 … … 1209 1170 yyerrstatus = 0; 1210 1171 yynerrs = 0; 1211 yychar = YYEMPTY; /* Cause a token to be read. */ 1172 yychar = YYEMPTY; /* Cause a token to be read. */ 1173 1174 /* Initialize stack pointers. 1175 Waste one element of value and location stack 1176 so that they stay on the same level as the state stack. 1177 The wasted elements are never initialized. */ 1178 1179 yyssp = yyss; 1180 yyvsp = yyvs; 1181 1212 1182 goto yysetstate; 1213 1183 … … 1236 1206 yytype_int16 *yyss1 = yyss; 1237 1207 1208 1238 1209 /* Each stack pointer address is followed by the size of the 1239 1210 data in use in that stack, in bytes. This used to be a … … 1243 1214 &yyss1, yysize * sizeof (*yyssp), 1244 1215 &yyvs1, yysize * sizeof (*yyvsp), 1216 1245 1217 &yystacksize); 1246 1218 … … 1265 1237 if (! yyptr) 1266 1238 goto yyexhaustedlab; 1267 YYSTACK_RELOCATE (yyss_alloc, yyss); 1268 YYSTACK_RELOCATE (yyvs_alloc, yyvs); 1239 YYSTACK_RELOCATE (yyss); 1240 YYSTACK_RELOCATE (yyvs); 1241 1269 1242 # undef YYSTACK_RELOCATE 1270 1243 if (yyss1 != yyssa) … … 1277 1250 yyvsp = yyvs + yysize - 1; 1278 1251 1252 1279 1253 YYDPRINTF ((stderr, "Stack size increased to %lu\n", 1280 1254 (unsigned long int) yystacksize)); … … 1285 1259 1286 1260 YYDPRINTF ((stderr, "Entering state %d\n", yystate)); 1287 1288 if (yystate == YYFINAL)1289 YYACCEPT;1290 1261 1291 1262 goto yybackup; … … 1297 1268 1298 1269 /* Do appropriate processing given the current state. Read a 1299 look ahead token if we need one and don't already have one. */1300 1301 /* First try to decide what to do without reference to look ahead token. */1270 look-ahead token if we need one and don't already have one. */ 1271 1272 /* First try to decide what to do without reference to look-ahead token. */ 1302 1273 yyn = yypact[yystate]; 1303 if (yy pact_value_is_default (yyn))1274 if (yyn == YYPACT_NINF) 1304 1275 goto yydefault; 1305 1276 1306 /* Not known => get a look ahead token if don't already have one. */1307 1308 /* YYCHAR is either YYEMPTY or YYEOF or a valid look ahead symbol. */1277 /* Not known => get a look-ahead token if don't already have one. */ 1278 1279 /* YYCHAR is either YYEMPTY or YYEOF or a valid look-ahead symbol. */ 1309 1280 if (yychar == YYEMPTY) 1310 1281 { … … 1332 1303 if (yyn <= 0) 1333 1304 { 1334 if (yy table_value_is_error (yyn))1335 1305 if (yyn == 0 || yyn == YYTABLE_NINF) 1306 goto yyerrlab; 1336 1307 yyn = -yyn; 1337 1308 goto yyreduce; 1338 1309 } 1310 1311 if (yyn == YYFINAL) 1312 YYACCEPT; 1339 1313 1340 1314 /* Count tokens shifted since error; after three, turn off error … … 1343 1317 yyerrstatus--; 1344 1318 1345 /* Shift the look ahead token. */1319 /* Shift the look-ahead token. */ 1346 1320 YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc); 1347 1321 1348 /* Discard the shifted token. */ 1349 yychar = YYEMPTY; 1322 /* Discard the shifted token unless it is eof. */ 1323 if (yychar != YYEOF) 1324 yychar = YYEMPTY; 1350 1325 1351 1326 yystate = yyn; 1352 YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN1353 1327 *++yyvsp = yylval; 1354 YY_IGNORE_MAYBE_UNINITIALIZED_END1355 1328 1356 1329 goto yynewstate; … … 1450 1423 default: break; 1451 1424 } 1452 /* User semantic actions sometimes alter yychar, and that requires1453 that yytoken be updated with the new translation. We take the1454 approach of translating immediately before every use of yytoken.1455 One alternative is translating here after every semantic action,1456 but that translation would be missed if the semantic action invokes1457 YYABORT, YYACCEPT, or YYERROR immediately after altering yychar or1458 if it invokes YYBACKUP. In the case of YYABORT or YYACCEPT, an1459 incorrect destructor might then be invoked immediately. In the1460 case of YYERROR or YYBACKUP, subsequent parser actions might lead1461 to an incorrect destructor call or verbose syntax error message1462 before the lookahead is translated. */1463 1425 YY_SYMBOL_PRINT ("-> $$ =", yyr1[yyn], &yyval, &yyloc); 1464 1426 … … 1468 1430 1469 1431 *++yyvsp = yyval; 1432 1470 1433 1471 1434 /* Now `shift' the result of the reduction. Determine what state … … 1488 1451 `------------------------------------*/ 1489 1452 yyerrlab: 1490 /* Make sure we have latest lookahead translation. See comments at1491 user semantic actions for why this is necessary. */1492 yytoken = yychar == YYEMPTY ? YYEMPTY : YYTRANSLATE (yychar);1493 1494 1453 /* If not already recovering from an error, report this error. */ 1495 1454 if (!yyerrstatus) … … 1499 1458 yyerror (YY_("syntax error")); 1500 1459 #else 1501 # define YYSYNTAX_ERROR yysyntax_error (&yymsg_alloc, &yymsg, \1502 yyssp, yytoken)1503 1460 { 1504 char const *yymsgp = YY_("syntax error"); 1505 int yysyntax_error_status; 1506 yysyntax_error_status = YYSYNTAX_ERROR; 1507 if (yysyntax_error_status == 0) 1508 yymsgp = yymsg; 1509 else if (yysyntax_error_status == 1) 1510 { 1511 if (yymsg != yymsgbuf) 1512 YYSTACK_FREE (yymsg); 1513 yymsg = (char *) YYSTACK_ALLOC (yymsg_alloc); 1514 if (!yymsg) 1515 { 1516 yymsg = yymsgbuf; 1517 yymsg_alloc = sizeof yymsgbuf; 1518 yysyntax_error_status = 2; 1519 } 1520 else 1521 { 1522 yysyntax_error_status = YYSYNTAX_ERROR; 1523 yymsgp = yymsg; 1524 } 1525 } 1526 yyerror (yymsgp); 1527 if (yysyntax_error_status == 2) 1528 goto yyexhaustedlab; 1461 YYSIZE_T yysize = yysyntax_error (0, yystate, yychar); 1462 if (yymsg_alloc < yysize && yymsg_alloc < YYSTACK_ALLOC_MAXIMUM) 1463 { 1464 YYSIZE_T yyalloc = 2 * yysize; 1465 if (! (yysize <= yyalloc && yyalloc <= YYSTACK_ALLOC_MAXIMUM)) 1466 yyalloc = YYSTACK_ALLOC_MAXIMUM; 1467 if (yymsg != yymsgbuf) 1468 YYSTACK_FREE (yymsg); 1469 yymsg = (char *) YYSTACK_ALLOC (yyalloc); 1470 if (yymsg) 1471 yymsg_alloc = yyalloc; 1472 else 1473 { 1474 yymsg = yymsgbuf; 1475 yymsg_alloc = sizeof yymsgbuf; 1476 } 1477 } 1478 1479 if (0 < yysize && yysize <= yymsg_alloc) 1480 { 1481 (void) yysyntax_error (yymsg, yystate, yychar); 1482 yyerror (yymsg); 1483 } 1484 else 1485 { 1486 yyerror (YY_("syntax error")); 1487 if (yysize != 0) 1488 goto yyexhaustedlab; 1489 } 1529 1490 } 1530 # undef YYSYNTAX_ERROR1531 1491 #endif 1532 1492 } … … 1536 1496 if (yyerrstatus == 3) 1537 1497 { 1538 /* If just tried and failed to reuse look ahead token after an1498 /* If just tried and failed to reuse look-ahead token after an 1539 1499 error, discard it. */ 1540 1500 … … 1553 1513 } 1554 1514 1555 /* Else will try to reuse look ahead token after shifting the error1515 /* Else will try to reuse look-ahead token after shifting the error 1556 1516 token. */ 1557 1517 goto yyerrlab1; … … 1587 1547 { 1588 1548 yyn = yypact[yystate]; 1589 if ( !yypact_value_is_default (yyn))1549 if (yyn != YYPACT_NINF) 1590 1550 { 1591 1551 yyn += YYTERROR; … … 1610 1570 } 1611 1571 1612 YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN 1572 if (yyn == YYFINAL) 1573 YYACCEPT; 1574 1613 1575 *++yyvsp = yylval; 1614 YY_IGNORE_MAYBE_UNINITIALIZED_END1615 1576 1616 1577 … … 1636 1597 goto yyreturn; 1637 1598 1638 #if !defined yyoverflow || YYERROR_VERBOSE1599 #ifndef yyoverflow 1639 1600 /*-------------------------------------------------. 1640 1601 | yyexhaustedlab -- memory exhaustion comes here. | … … 1647 1608 1648 1609 yyreturn: 1649 if (yychar != YYEMPTY) 1650 { 1651 /* Make sure we have latest lookahead translation. See comments at 1652 user semantic actions for why this is necessary. */ 1653 yytoken = YYTRANSLATE (yychar); 1654 yydestruct ("Cleanup: discarding lookahead", 1655 yytoken, &yylval); 1656 } 1610 if (yychar != YYEOF && yychar != YYEMPTY) 1611 yydestruct ("Cleanup: discarding lookahead", 1612 yytoken, &yylval); 1657 1613 /* Do not reclaim the symbols of the rule which action triggered 1658 1614 this YYABORT or YYACCEPT. */ … … 2033 1989 return 0; 2034 1990 } 1991 2035 1992 #line 2 "convert.yy.c" 2036 1993 … … 2063 2020 #define YY_FLEX_MAJOR_VERSION 2 2064 2021 #define YY_FLEX_MINOR_VERSION 5 2065 #define YY_FLEX_SUBMINOR_VERSION 3 72022 #define YY_FLEX_SUBMINOR_VERSION 35 2066 2023 #if YY_FLEX_SUBMINOR_VERSION > 0 2067 2024 #define FLEX_BETA … … 2109 2066 typedef unsigned short int flex_uint16_t; 2110 2067 typedef unsigned int flex_uint32_t; 2068 #endif /* ! C99 */ 2111 2069 2112 2070 /* Limits of integral types. */ … … 2138 2096 #define UINT32_MAX (4294967295U) 2139 2097 #endif 2140 2141 #endif /* ! C99 */2142 2098 2143 2099 #endif /* ! FLEXINT_H */ … … 2728 2684 { \ 2729 2685 int c = '*'; \ 2730 size_t n; \2686 yy_size_t n; \ 2731 2687 for ( n = 0; n < max_size && \ 2732 2688 (c = getc( convert_in )) != EOF && c != '\n'; ++n ) \ … … 3165 3121 3166 3122 /* just a shorter name for the current buffer */ 3167 YY_BUFFER_STATE b = YY_CURRENT_BUFFER _LVALUE;3123 YY_BUFFER_STATE b = YY_CURRENT_BUFFER; 3168 3124 3169 3125 int yy_c_buf_p_offset = … … 3298 3254 yy_is_jam = (yy_current_state == 83); 3299 3255 3300 3256 return yy_is_jam ? 0 : yy_current_state; 3301 3257 } 3302 3258 … … 3386 3342 { 3387 3343 if ( convert_wrap( ) ) 3388 return EOF;3344 return 0; 3389 3345 3390 3346 if ( ! (yy_did_buffer_switch_on_eof) ) … … 3522 3478 } 3523 3479 3480 #ifndef __cplusplus 3481 extern int isatty (int ); 3482 #endif /* __cplusplus */ 3483 3524 3484 /* Initializes or reinitializes a buffer. 3525 3485 * This function is sometimes called more than once on the same buffer, … … 3726 3686 /** Setup the input buffer state to scan the given bytes. The next call to convert_lex() will 3727 3687 * scan from a @e copy of @a bytes. 3728 * @param yybytes the byte buffer to scan3729 * @param _yybytes_len the number of bytes in the buffer pointed to by @a bytes.3688 * @param bytes the byte buffer to scan 3689 * @param len the number of bytes in the buffer pointed to by @a bytes. 3730 3690 * 3731 3691 * @return the newly allocated buffer state object. … … 3735 3695 YY_BUFFER_STATE b; 3736 3696 char *buf; 3737 yy_size_t n; 3738 int i; 3697 yy_size_t n, i; 3739 3698 3740 3699 /* Get memory for full buffer, including space for trailing EOB's. */ -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif2model.F90
r3680 r4785 15 15 !! *** ROUTINE Agrif_Set_numberofcells *** 16 16 !!--------------------------------------------- 17 USE Agrif_ Types17 USE Agrif_Grids 18 18 IMPLICIT NONE 19 19 … … 30 30 !! *** ROUTINE Agrif_Get_numberofcells *** 31 31 !!--------------------------------------------- 32 USE Agrif_ Types32 USE Agrif_Grids 33 33 IMPLICIT NONE 34 34 35 35 Type(Agrif_Grid), Pointer :: Agrif_Gr 36 36 37 if ( associated(Agrif_Curgrid) ) then 37 38 #include "GetNumberofcells.h" 39 endif 38 40 39 41 END SUBROUTINE Agrif_Get_numberofcells … … 43 45 !! *** ROUTINE Agrif_Allocationscalls *** 44 46 !!--------------------------------------------- 45 USE Agrif_ Types47 USE Agrif_Grids 46 48 #include "include_use_Alloc_agrif.h" 47 49 IMPLICIT NONE … … 72 74 !! *** ROUTINE Agrif_clustering_def *** 73 75 !!--------------------------------------------- 74 Use Agrif_Types75 76 IMPLICIT NONE 76 77 … … 79 80 END SUBROUTINE Agrif_clustering_def 80 81 81 SUBROUTINE Agrif_comm_def(modelcomm)82 83 !!---------------------------------------------84 !! *** ROUTINE Agrif_clustering_def ***85 !!---------------------------------------------86 Use Agrif_Types87 Use lib_mpp88 89 IMPLICIT NONE90 91 INTEGER :: modelcomm92 93 #if defined key_mpp_mpi94 modelcomm = mpi_comm_opa95 #endif96 Return97 98 END SUBROUTINE Agrif_comm_def99 82 #else 100 83 SUBROUTINE Agrif2Model -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_lim2_interp.F90
r3680 r4785 9 9 !! 3.4 ! 09-2012 (R. Benshila, C. Herbaut) update and EVP 10 10 !!---------------------------------------------------------------------- 11 #if defined key_agrif && defined key_lim2 11 #undef toto 12 #if defined key_agrif && defined key_lim2 12 13 !!---------------------------------------------------------------------- 13 14 !! 'key_lim2' : LIM 2.0 sea-ice model … … 65 66 u_ice_nst(:,:) = 0. 66 67 v_ice_nst(:,:) = 0. 68 #undef toto 69 #ifdef toto 67 70 CALL Agrif_Bc_variable( u_ice_nst, u_ice_id ,procname=interp_u_ice, calledweight=1. ) 68 71 CALL Agrif_Bc_variable( v_ice_nst, v_ice_id ,procname=interp_v_ice, calledweight=1. ) 72 #endif 69 73 Agrif_SpecialValue=0. 70 74 Agrif_UseSpecialValue = .FALSE. … … 157 161 zuice = 0. 158 162 zvice = 0. 163 #undef toto 164 #ifdef toto 159 165 CALL Agrif_Bc_variable(zuice,u_ice_id,procname=interp_u_ice, calledweight=1.) 160 166 CALL Agrif_Bc_variable(zvice,v_ice_id,procname=interp_v_ice, calledweight=1.) 167 #endif 161 168 Agrif_SpecialValue=0. 162 169 Agrif_UseSpecialValue = .FALSE. … … 348 355 Agrif_SpecialValue=-9999. 349 356 Agrif_UseSpecialValue = .TRUE. 357 #undef toto 358 #ifdef toto 350 359 CALL Agrif_Bc_variable( ztab, adv_ice_id ,procname=interp_adv_ice,calledweight=1. ) 360 #endif 351 361 Agrif_SpecialValue=0. 352 362 Agrif_UseSpecialValue = .FALSE. -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_lim2_update.F90
r3680 r4785 60 60 Agrif_UseSpecialValueInUpdate = .TRUE. 61 61 Agrif_SpecialValueFineGrid = 0. 62 63 # if defined TWO_WAY 62 #undef toto 63 # if defined TWO_WAY && defined toto 64 64 IF( MOD(nbcline,nbclineupdate) == 0) THEN 65 65 CALL Agrif_Update_Variable( zadv , adv_ice_id , procname = update_adv_ice ) -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90
r4491 r4785 19 19 20 20 ! !!* Namelist namagrif: AGRIF parameters 21 LOGICAL , PUBLIC :: ln_spc_dyn !:22 INTEGER , PUBLIC :: nn_cln_update !: update frequency23 REAL(wp), PUBLIC :: rn_sponge_tra !: sponge coeff. for tracers24 REAL(wp), PUBLIC :: rn_sponge_dyn !: sponge coeff. for dynamics21 LOGICAL , PUBLIC :: ln_spc_dyn = .FALSE. !: 22 INTEGER , PUBLIC :: nn_cln_update = 3 !: update frequency 23 REAL(wp), PUBLIC :: rn_sponge_tra = 2800. !: sponge coeff. for tracers 24 REAL(wp), PUBLIC :: rn_sponge_dyn = 2800. !: sponge coeff. for dynamics 25 25 26 26 ! !!! OLD namelist names … … 34 34 LOGICAL , PUBLIC :: lk_agrif_fstep = .TRUE. !: if true: first step 35 35 36 LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone 37 LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_u 38 LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_v 36 39 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: spe1ur , spe2vr , spbtr2 !: ??? 37 40 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: spe1ur2, spe2vr2, spbtr3 !: ??? 38 39 INTEGER :: tsn_id,tsb_id,tsa_id 40 INTEGER :: un_id, vn_id, ua_id, va_id 41 INTEGER :: e1u_id, e2v_id, sshn_id, gcb_id 42 INTEGER :: trn_id, trb_id, tra_id 43 INTEGER :: unb_id, vnb_id, ub2b_id, vb2b_id 41 # if defined key_dynspg_ts 42 ! Barotropic arrays used to store open boundary data during 43 ! time-splitting loop: 44 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_w, vbdy_w, hbdy_w 45 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_e, vbdy_e, hbdy_e 46 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_n, vbdy_n, hbdy_n 47 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_s, vbdy_s, hbdy_s 48 # endif 49 50 INTEGER :: tsn_id ! AGRIF profile for tracers interpolation and update 51 INTEGER :: un_interp_id, vn_interp_id ! AGRIF profiles for interpolations 52 INTEGER :: un_update_id, vn_update_id ! AGRIF profiles for udpates 53 INTEGER :: tsn_sponge_id, un_sponge_id, vn_sponge_id ! AGRIF profiles for sponge layers 54 INTEGER :: trn_id 55 INTEGER :: unb_id, vnb_id, ub2b_interp_id, vb2b_interp_id 56 INTEGER :: ub2b_update_id, vb2b_update_id 57 INTEGER :: e3t_id, e1u_id, e2v_id, sshn_id 58 INTEGER :: scales_t_id 44 59 45 60 !!---------------------------------------------------------------------- … … 54 69 !! *** FUNCTION agrif_oce_alloc *** 55 70 !!---------------------------------------------------------------------- 56 ALLOCATE( spe1ur (jpi,jpj) , spe2vr (jpi,jpj) , spbtr2(jpi,jpj) , & 57 & spe1ur2(jpi,jpj) , spe2vr2(jpi,jpj) , spbtr3(jpi,jpj) , STAT = agrif_oce_alloc ) 71 INTEGER, DIMENSION(2) :: ierr 72 !!---------------------------------------------------------------------- 73 ierr(:) = 0 74 ! 75 ALLOCATE( spe1ur (jpi,jpj), spe2vr (jpi,jpj), & 76 & spbtr2 (jpi,jpj), spe1ur2 (jpi,jpj), & 77 & spe2vr2 (jpi,jpj), spbtr3 (jpi,jpj), & 78 & tabspongedone (jpi,jpj), tabspongedone_u(jpi,jpj), & 79 & tabspongedone_v(jpi,jpj), STAT = ierr(1) ) 80 81 # if defined key_dynspg_ts 82 ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj), & 83 & ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj), & 84 & ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi), & 85 & ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi), STAT = ierr(2) ) 86 # endif 87 agrif_oce_alloc = MAXVAL(ierr) 88 ! 58 89 END FUNCTION agrif_oce_alloc 59 90 -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
r4486 r4785 33 33 PRIVATE 34 34 35 ! Barotropic arrays used to store open boundary data during 36 ! time-splitting loop: 37 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_w, vbdy_w, hbdy_w 38 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_e, vbdy_e, hbdy_e 39 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_n, vbdy_n, hbdy_n 40 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_s, vbdy_s, hbdy_s 41 35 INTEGER :: bdy_tinterp = 0 36 42 37 PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 43 PUBLIC interpu, interpv, interpunb, interpvnb, interpsshn 38 PUBLIC interpun, interpvn, interpun2d, interpvn2d 39 PUBLIC interptsn, interpsshn 40 PUBLIC interpunb, interpvnb, interpub2b, interpvb2b 44 41 45 42 # include "domzgr_substitute.h90" … … 55 52 SUBROUTINE Agrif_tra 56 53 !!---------------------------------------------------------------------- 57 !! *** ROUTINE Agrif_ Tra ***54 !! *** ROUTINE Agrif_tra *** 58 55 !!---------------------------------------------------------------------- 59 !!60 INTEGER :: ji, jj, jk, jn ! dummy loop indices61 REAL(wp) :: zrhox , alpha1, alpha2, alpha362 REAL(wp) :: alpha4, alpha5, alpha6, alpha763 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztsa64 !!----------------------------------------------------------------------65 56 ! 66 57 IF( Agrif_Root() ) RETURN 67 68 CALL wrk_alloc( jpi, jpj, jpk, jpts, ztsa )69 58 70 59 Agrif_SpecialValue = 0.e0 71 60 Agrif_UseSpecialValue = .TRUE. 72 ztsa(:,:,:,:) = 0.e0 73 74 CALL Agrif_Bc_variable( ztsa, tsn_id, procname=interptsn ) 61 62 CALL Agrif_Bc_variable( tsn_id, procname=interptsn ) 75 63 Agrif_UseSpecialValue = .FALSE. 76 77 zrhox = Agrif_Rhox()78 79 alpha1 = ( zrhox - 1. ) * 0.580 alpha2 = 1. - alpha181 82 alpha3 = ( zrhox - 1. ) / ( zrhox + 1. )83 alpha4 = 1. - alpha384 85 alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )86 alpha7 = - ( zrhox - 1. ) / ( zrhox + 3. )87 alpha5 = 1. - alpha6 - alpha788 89 IF( nbondi == 1 .OR. nbondi == 2 ) THEN90 91 DO jn = 1, jpts92 tsa(nlci,:,:,jn) = alpha1 * ztsa(nlci,:,:,jn) + alpha2 * ztsa(nlci-1,:,:,jn)93 DO jk = 1, jpkm194 DO jj = 1, jpj95 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN96 tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk)97 ELSE98 tsa(nlci-1,jj,jk,jn)=(alpha4*tsa(nlci,jj,jk,jn)+alpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk)99 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN100 tsa(nlci-1,jj,jk,jn)=( alpha6*tsa(nlci-2,jj,jk,jn)+alpha5*tsa(nlci,jj,jk,jn) &101 & + alpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk)102 ENDIF103 ENDIF104 END DO105 END DO106 ENDDO107 ENDIF108 109 IF( nbondj == 1 .OR. nbondj == 2 ) THEN110 111 DO jn = 1, jpts112 tsa(:,nlcj,:,jn) = alpha1 * ztsa(:,nlcj,:,jn) + alpha2 * ztsa(:,nlcj-1,:,jn)113 DO jk = 1, jpkm1114 DO ji = 1, jpi115 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN116 tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)117 ELSE118 tsa(ji,nlcj-1,jk,jn)=(alpha4*tsa(ji,nlcj,jk,jn)+alpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)119 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN120 tsa(ji,nlcj-1,jk,jn)=( alpha6*tsa(ji,nlcj-2,jk,jn)+alpha5*tsa(ji,nlcj,jk,jn) &121 & + alpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk)122 ENDIF123 ENDIF124 END DO125 END DO126 ENDDO127 ENDIF128 129 IF( nbondi == -1 .OR. nbondi == 2 ) THEN130 DO jn = 1, jpts131 tsa(1,:,:,jn) = alpha1 * ztsa(1,:,:,jn) + alpha2 * ztsa(2,:,:,jn)132 DO jk = 1, jpkm1133 DO jj = 1, jpj134 IF( umask(2,jj,jk) == 0.e0 ) THEN135 tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk)136 ELSE137 tsa(2,jj,jk,jn)=(alpha4*tsa(1,jj,jk,jn)+alpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)138 IF( un(2,jj,jk) < 0.e0 ) THEN139 tsa(2,jj,jk,jn)=(alpha6*tsa(3,jj,jk,jn)+alpha5*tsa(1,jj,jk,jn)+alpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk)140 ENDIF141 ENDIF142 END DO143 END DO144 END DO145 ENDIF146 147 IF( nbondj == -1 .OR. nbondj == 2 ) THEN148 DO jn = 1, jpts149 tsa(:,1,:,jn) = alpha1 * ztsa(:,1,:,jn) + alpha2 * ztsa(:,2,:,jn)150 DO jk=1,jpk151 DO ji=1,jpi152 IF( vmask(ji,2,jk) == 0.e0 ) THEN153 tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk)154 ELSE155 tsa(ji,2,jk,jn)=(alpha4*tsa(ji,1,jk,jn)+alpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk)156 IF( vn(ji,2,jk) < 0.e0 ) THEN157 tsa(ji,2,jk,jn)=(alpha6*tsa(ji,3,jk,jn)+alpha5*tsa(ji,1,jk,jn)+alpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk)158 ENDIF159 ENDIF160 END DO161 END DO162 ENDDO163 ENDIF164 !165 CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztsa )166 64 ! 167 65 END SUBROUTINE Agrif_tra … … 175 73 INTEGER, INTENT(in) :: kt 176 74 !! 177 INTEGER :: ji,jj,jk 75 INTEGER :: ji,jj,jk, j1,j2, i1,i2 178 76 REAL(wp) :: timeref 179 77 REAL(wp) :: z2dt, znugdt 180 78 REAL(wp) :: zrhox, zrhoy 181 REAL(wp), POINTER, DIMENSION(:,:,:) :: zua, zva 182 REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1, zua2d, zva2d 79 REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1 183 80 !!---------------------------------------------------------------------- 184 81 185 82 IF( Agrif_Root() ) RETURN 186 83 187 CALL wrk_alloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 188 CALL wrk_alloc( jpi, jpj, jpk, zua, zva ) 84 CALL wrk_alloc( jpi, jpj, spgv1, spgu1 ) 85 86 Agrif_SpecialValue=0. 87 Agrif_UseSpecialValue = ln_spc_dyn 88 89 CALL Agrif_Bc_variable(un_interp_id,procname=interpun) 90 CALL Agrif_Bc_variable(vn_interp_id,procname=interpvn) 91 92 #if defined key_dynspg_flt 93 CALL Agrif_Bc_variable(e1u_id,calledweight=1., procname=interpun2d) 94 CALL Agrif_Bc_variable(e2v_id,calledweight=1., procname=interpvn2d) 95 #endif 96 97 Agrif_UseSpecialValue = .FALSE. 189 98 190 99 zrhox = Agrif_Rhox() … … 192 101 193 102 timeref = 1. 194 195 103 ! time step: leap-frog 196 104 z2dt = 2. * rdt … … 200 108 znugdt = grav * z2dt 201 109 202 Agrif_SpecialValue=0. 203 Agrif_UseSpecialValue = ln_spc_dyn 204 205 zua = 0. 206 zva = 0. 207 CALL Agrif_Bc_variable(zua,un_id,procname=interpu) 208 CALL Agrif_Bc_variable(zva,vn_id,procname=interpv) 209 zua2d = 0. 210 zva2d = 0. 211 110 ! prevent smoothing in ghost cells 111 i1=1 112 i2=jpi 113 j1=1 114 j2=jpj 115 IF((nbondj == -1).OR.(nbondj == 2)) j1 = 3 116 IF((nbondj == +1).OR.(nbondj == 2)) j2 = nlcj-2 117 IF((nbondi == -1).OR.(nbondi == 2)) i1 = 3 118 IF((nbondi == +1).OR.(nbondi == 2)) i2 = nlci-2 119 120 121 IF((nbondi == -1).OR.(nbondi == 2)) THEN 212 122 #if defined key_dynspg_flt 213 Agrif_SpecialValue=0. 214 Agrif_UseSpecialValue = ln_spc_dyn 215 CALL Agrif_Bc_variable(zua2d,e1u_id,calledweight=1.,procname=interpu2d) 216 CALL Agrif_Bc_variable(zva2d,e2v_id,calledweight=1.,procname=interpv2d) 217 #endif 218 Agrif_UseSpecialValue = .FALSE. 219 220 221 IF((nbondi == -1).OR.(nbondi == 2)) THEN 222 223 #if defined key_dynspg_flt 224 DO jj=1,jpj 225 laplacu(2,jj) = timeref * (zua2d(2,jj)/(zrhoy*e2u(2,jj)))*umask(2,jj,1) 226 END DO 227 #endif 123 DO jk=1,jpkm1 124 DO jj=j1,j2 125 ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk) 126 END DO 127 END DO 128 129 spgu(2,:)=0. 228 130 229 131 DO jk=1,jpkm1 230 132 DO jj=1,jpj 231 ua(1:2,jj,jk) = (zua(1:2,jj,jk)/(zrhoy*e2u(1:2,jj))) 232 ua(1:2,jj,jk) = ua(1:2,jj,jk) / fse3u_a(1:2,jj,jk) 233 END DO 234 END DO 235 236 #if defined key_dynspg_flt 237 DO jk=1,jpkm1 238 DO jj=1,jpj 239 ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk) 240 END DO 241 END DO 242 243 spgu(2,:)=0. 244 245 DO jk=1,jpkm1 246 DO jj=1,jpj 247 spgu(2,jj)=spgu(2,jj)+fse3u_a(2,jj,jk)*ua(2,jj,jk) 133 spgu(2,jj)=spgu(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 248 134 END DO 249 135 END DO … … 251 137 DO jj=1,jpj 252 138 IF (umask(2,jj,1).NE.0.) THEN 253 spgu(2,jj)=spgu(2,jj) *hur_a(2,jj)139 spgu(2,jj)=spgu(2,jj)/hu(2,jj) 254 140 ENDIF 255 141 END DO … … 259 145 260 146 DO jk=1,jpkm1 261 DO jj= 1,jpj147 DO jj=j1,j2 262 148 ua(2,jj,jk) = 0.25*(ua(1,jj,jk)+2.*ua(2,jj,jk)+ua(3,jj,jk)) 263 149 ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) … … 269 155 DO jk=1,jpkm1 270 156 DO jj=1,jpj 271 spgu1(2,jj)=spgu1(2,jj)+fse3u _a(2,jj,jk)*ua(2,jj,jk)157 spgu1(2,jj)=spgu1(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 272 158 END DO 273 159 END DO … … 275 161 DO jj=1,jpj 276 162 IF (umask(2,jj,1).NE.0.) THEN 277 spgu1(2,jj)=spgu1(2,jj) *hur_a(2,jj)163 spgu1(2,jj)=spgu1(2,jj)/hu(2,jj) 278 164 ENDIF 279 165 END DO 280 166 281 167 DO jk=1,jpkm1 282 DO jj= 1,jpj168 DO jj=j1,j2 283 169 ua(2,jj,jk) = (ua(2,jj,jk)+spgu(2,jj)-spgu1(2,jj))*umask(2,jj,jk) 284 END DO285 END DO286 287 DO jk=1,jpkm1288 DO jj=1,jpj289 va(2,jj,jk) = (zva(2,jj,jk)/(zrhox*e1v(2,jj)))*vmask(2,jj,jk)290 va(2,jj,jk) = va(2,jj,jk) / fse3v_a(2,jj,jk)291 170 END DO 292 171 END DO … … 300 179 END DO 301 180 END DO 302 303 181 DO jj=1,jpj 304 182 spgv1(2,jj)=spgv1(2,jj)*hvr_a(2,jj) 305 183 END DO 306 307 184 DO jk=1,jpkm1 308 185 DO jj=1,jpj … … 316 193 IF((nbondi == 1).OR.(nbondi == 2)) THEN 317 194 #if defined key_dynspg_flt 318 DO jj=1,jpj 319 laplacu(nlci-2,jj) = timeref * (zua2d(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj))) 320 END DO 321 #endif 322 323 DO jk=1,jpkm1 324 DO jj=1,jpj 325 ua(nlci-2:nlci-1,jj,jk) = (zua(nlci-2:nlci-1,jj,jk)/(zrhoy*e2u(nlci-2:nlci-1,jj))) 326 ua(nlci-2:nlci-1,jj,jk) = ua(nlci-2:nlci-1,jj,jk) / fse3u_a(nlci-2:nlci-1,jj,jk) 327 END DO 328 END DO 329 330 #if defined key_dynspg_flt 331 DO jk=1,jpkm1 332 DO jj=1,jpj 195 DO jk=1,jpkm1 196 DO jj=j1,j2 333 197 ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk) 334 198 END DO 335 199 END DO 336 337 338 200 spgu(nlci-2,:)=0. 339 340 201 do jk=1,jpkm1 341 202 do jj=1,jpj 342 spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u _a(nlci-2,jj,jk)*ua(nlci-2,jj,jk)203 spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 343 204 enddo 344 205 enddo 345 346 206 DO jj=1,jpj 347 207 IF (umask(nlci-2,jj,1).NE.0.) THEN 348 spgu(nlci-2,jj)=spgu(nlci-2,jj) *hur_a(nlci-2,jj)208 spgu(nlci-2,jj)=spgu(nlci-2,jj)/hu(nlci-2,jj) 349 209 ENDIF 350 210 END DO … … 352 212 spgu(nlci-2,:) = ua_b(nlci-2,:) 353 213 #endif 354 214 DO jk=1,jpkm1 215 DO jj=j1,j2 216 ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 217 218 ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 219 220 END DO 221 END DO 222 spgu1(nlci-2,:)=0. 355 223 DO jk=1,jpkm1 356 224 DO jj=1,jpj 357 ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 358 359 ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 360 361 END DO 362 END DO 363 364 spgu1(nlci-2,:)=0. 365 366 DO jk=1,jpkm1 367 DO jj=1,jpj 368 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u_a(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 369 END DO 370 END DO 371 225 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 226 END DO 227 END DO 372 228 DO jj=1,jpj 373 229 IF (umask(nlci-2,jj,1).NE.0.) THEN 374 spgu1(nlci-2,jj)=spgu1(nlci-2,jj) *hur_a(nlci-2,jj)230 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)/hu(nlci-2,jj) 375 231 ENDIF 376 232 END DO 377 378 DO jk=1,jpkm1 379 DO jj=1,jpj 233 DO jk=1,jpkm1 234 DO jj=j1,j2 380 235 ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+spgu(nlci-2,jj)-spgu1(nlci-2,jj))*umask(nlci-2,jj,jk) 381 END DO382 END DO383 384 DO jk=1,jpkm1385 DO jj=1,jpj-1386 va(nlci-1,jj,jk) = (zva(nlci-1,jj,jk)/(zrhox*e1v(nlci-1,jj)))*vmask(nlci-1,jj,jk)387 va(nlci-1,jj,jk) = va(nlci-1,jj,jk) / fse3v_a(nlci-1,jj,jk)388 236 END DO 389 237 END DO … … 414 262 415 263 #if defined key_dynspg_flt 416 DO ji=1,jpi417 laplacv(ji,2) = timeref * (zva2d(ji,2)/(zrhox*e1v(ji,2)))418 END DO419 #endif420 421 DO jk=1,jpkm1422 DO ji=1,jpi423 va(ji,1:2,jk) = (zva(ji,1:2,jk)/(zrhox*e1v(ji,1:2)))424 va(ji,1:2,jk) = va(ji,1:2,jk) / fse3v_a(ji,1:2,jk)425 END DO426 END DO427 428 #if defined key_dynspg_flt429 264 DO jk=1,jpkm1 430 265 DO ji=1,jpi … … 437 272 DO jk=1,jpkm1 438 273 DO ji=1,jpi 439 spgv(ji,2)=spgv(ji,2)+fse3v _a(ji,2,jk)*va(ji,2,jk)274 spgv(ji,2)=spgv(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk) 440 275 END DO 441 276 END DO … … 443 278 DO ji=1,jpi 444 279 IF (vmask(ji,2,1).NE.0.) THEN 445 spgv(ji,2)=spgv(ji,2) *hvr_a(ji,2)280 spgv(ji,2)=spgv(ji,2)/hv(ji,2) 446 281 ENDIF 447 282 END DO … … 451 286 452 287 DO jk=1,jpkm1 453 DO ji= 1,jpi288 DO ji=i1,i2 454 289 va(ji,2,jk)=0.25*(va(ji,1,jk)+2.*va(ji,2,jk)+va(ji,3,jk)) 455 290 va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk) … … 461 296 DO jk=1,jpkm1 462 297 DO ji=1,jpi 463 spgv1(ji,2)=spgv1(ji,2)+fse3v _a(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk)298 spgv1(ji,2)=spgv1(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk) 464 299 END DO 465 300 END DO … … 467 302 DO ji=1,jpi 468 303 IF (vmask(ji,2,1).NE.0.) THEN 469 spgv1(ji,2)=spgv1(ji,2) *hvr_a(ji,2)304 spgv1(ji,2)=spgv1(ji,2)/hv(ji,2) 470 305 ENDIF 471 306 END DO … … 474 309 DO ji=1,jpi 475 310 va(ji,2,jk) = (va(ji,2,jk)+spgv(ji,2)-spgv1(ji,2))*vmask(ji,2,jk) 476 END DO477 END DO478 479 DO jk=1,jpkm1480 DO ji=1,jpi481 ua(ji,2,jk) = (zua(ji,2,jk)/(zrhoy*e2u(ji,2)))*umask(ji,2,jk)482 ua(ji,2,jk) = ua(ji,2,jk) / fse3u_a(ji,2,jk)483 311 END DO 484 312 END DO … … 508 336 509 337 #if defined key_dynspg_flt 510 DO ji=1,jpi511 laplacv(ji,nlcj-2) = timeref * (zva2d(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2)))512 END DO513 #endif514 515 DO jk=1,jpkm1516 DO ji=1,jpi517 va(ji,nlcj-2:nlcj-1,jk) = (zva(ji,nlcj-2:nlcj-1,jk)/(zrhox*e1v(ji,nlcj-2:nlcj-1)))518 va(ji,nlcj-2:nlcj-1,jk) = va(ji,nlcj-2:nlcj-1,jk) / fse3v_a(ji,nlcj-2:nlcj-1,jk)519 END DO520 END DO521 522 #if defined key_dynspg_flt523 338 DO jk=1,jpkm1 524 339 DO ji=1,jpi … … 527 342 END DO 528 343 344 529 345 spgv(:,nlcj-2)=0. 530 346 531 347 DO jk=1,jpkm1 532 348 DO ji=1,jpi 533 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v _a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk)349 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 534 350 END DO 535 351 END DO … … 537 353 DO ji=1,jpi 538 354 IF (vmask(ji,nlcj-2,1).NE.0.) THEN 539 spgv(ji,nlcj-2)=spgv(ji,nlcj-2) *hvr_a(ji,nlcj-2)355 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)/hv(ji,nlcj-2) 540 356 ENDIF 541 357 END DO 358 542 359 #else 543 360 spgv(:,nlcj-2)=va_b(:,nlcj-2) … … 545 362 546 363 DO jk=1,jpkm1 547 DO ji= 1,jpi364 DO ji=i1,i2 548 365 va(ji,nlcj-2,jk)=0.25*(va(ji,nlcj-3,jk)+2.*va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk)) 549 366 va(ji,nlcj-2,jk) = va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) … … 555 372 DO jk=1,jpkm1 556 373 DO ji=1,jpi 557 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v _a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk)374 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 558 375 END DO 559 376 END DO … … 561 378 DO ji=1,jpi 562 379 IF (vmask(ji,nlcj-2,1).NE.0.) THEN 563 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2) *hvr_a(ji,nlcj-2)380 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)/hv(ji,nlcj-2) 564 381 ENDIF 565 382 END DO … … 568 385 DO ji=1,jpi 569 386 va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+spgv(ji,nlcj-2)-spgv1(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 570 END DO571 END DO572 573 DO jk=1,jpkm1574 DO ji=1,jpi575 ua(ji,nlcj-1,jk) = (zua(ji,nlcj-1,jk)/(zrhoy*e2u(ji,nlcj-1)))*umask(ji,nlcj-1,jk)576 ua(ji,nlcj-1,jk) = ua(ji,nlcj-1,jk) / fse3u_a(ji,nlcj-1,jk)577 387 END DO 578 388 END DO … … 600 410 ENDIF 601 411 ! 602 CALL wrk_dealloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 603 CALL wrk_dealloc( jpi, jpj, jpk, zua, zva ) 412 CALL wrk_dealloc( jpi, jpj, spgv1, spgu1 ) 604 413 ! 605 414 END SUBROUTINE Agrif_dyn … … 672 481 INTEGER :: ji, jj 673 482 LOGICAL :: ll_int_cons 674 REAL(wp) :: zrhox, zrhoy, zrhot, zt 675 REAL(wp) :: zaa, zab, zat 676 REAL(wp) :: zt0, zt1 677 REAL(wp), POINTER, DIMENSION(:,:) :: zunb, zvnb, zsshn 678 REAL(wp), POINTER, DIMENSION(:,:) :: zuab, zvab, zubb, zvbb, zutn, zvtn 483 REAL(wp) :: zrhot, zt 679 484 !!---------------------------------------------------------------------- 680 485 … … 684 489 ! the forward case only 685 490 686 zrhox = Agrif_Rhox()687 zrhoy = Agrif_Rhoy()688 491 zrhot = Agrif_rhot() 689 690 IF ( kt==nit000 ) THEN ! Allocate boundary data arrays691 ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj))692 ALLOCATE( ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj))693 ALLOCATE( ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi))694 ALLOCATE( ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi))695 ENDIF696 697 CALL wrk_alloc( jpi, jpj, zunb, zvnb, zsshn )698 492 699 493 ! "Central" time index for interpolation: … … 707 501 Agrif_SpecialValue = 0.e0 708 502 Agrif_UseSpecialValue = .TRUE. 709 CALL Agrif_Bc_variable( zsshn,sshn_id,calledweight=zt, procname=interpsshn )503 CALL Agrif_Bc_variable(sshn_id,calledweight=zt, procname=interpsshn ) 710 504 Agrif_UseSpecialValue = .FALSE. 711 505 … … 715 509 716 510 IF (ll_int_cons) THEN ! Conservative interpolation 717 CALL wrk_alloc( jpi, jpj, zuab, zvab, zubb, zvbb, zutn, zvtn ) 718 zuab(:,:) = 0._wp ; zvab(:,:) = 0._wp 719 zubb(:,:) = 0._wp ; zvbb(:,:) = 0._wp 720 zutn(:,:) = 0._wp ; zvtn(:,:) = 0._wp 721 CALL Agrif_Bc_variable(zubb,unb_id ,calledweight=0._wp, procname=interpunb) ! Before 722 CALL Agrif_Bc_variable(zvbb,vnb_id ,calledweight=0._wp, procname=interpvnb) 723 CALL Agrif_Bc_variable(zuab,unb_id ,calledweight=1._wp, procname=interpunb) ! After 724 CALL Agrif_Bc_variable(zvab,vnb_id ,calledweight=1._wp, procname=interpvnb) 725 CALL Agrif_Bc_variable(zutn,ub2b_id,calledweight=1._wp, procname=interpub2b)! Time integrated 726 CALL Agrif_Bc_variable(zvtn,vb2b_id,calledweight=1._wp, procname=interpvb2b) 727 511 ! orders matters here !!!!!! 512 CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1._wp, procname=interpub2b) ! Time integrated 513 CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1._wp, procname=interpvb2b) 514 bdy_tinterp = 1 515 CALL Agrif_Bc_variable(unb_id ,calledweight=1._wp, procname=interpunb) ! After 516 CALL Agrif_Bc_variable(vnb_id ,calledweight=1._wp, procname=interpvnb) 517 bdy_tinterp = 2 518 CALL Agrif_Bc_variable(unb_id ,calledweight=0._wp, procname=interpunb) ! Before 519 CALL Agrif_Bc_variable(vnb_id ,calledweight=0._wp, procname=interpvnb) 520 ELSE ! Linear interpolation 521 bdy_tinterp = 0 522 ubdy_w(:) = 0.e0 ; vbdy_w(:) = 0.e0 523 ubdy_e(:) = 0.e0 ; vbdy_e(:) = 0.e0 524 ubdy_n(:) = 0.e0 ; vbdy_n(:) = 0.e0 525 ubdy_s(:) = 0.e0 ; vbdy_s(:) = 0.e0 526 CALL Agrif_Bc_variable(unb_id,calledweight=zt, procname=interpunb) 527 CALL Agrif_Bc_variable(vnb_id,calledweight=zt, procname=interpvnb) 528 ENDIF 529 Agrif_UseSpecialValue = .FALSE. 530 ! 531 END SUBROUTINE Agrif_dta_ts 532 533 SUBROUTINE Agrif_ssh( kt ) 534 !!---------------------------------------------------------------------- 535 !! *** ROUTINE Agrif_DYN *** 536 !!---------------------------------------------------------------------- 537 INTEGER, INTENT(in) :: kt 538 !! 539 !!---------------------------------------------------------------------- 540 541 IF( Agrif_Root() ) RETURN 542 543 IF((nbondi == -1).OR.(nbondi == 2)) THEN 544 ssha(2,:)=ssha(3,:) 545 sshn(2,:)=sshn(3,:) 546 ENDIF 547 548 IF((nbondi == 1).OR.(nbondi == 2)) THEN 549 ssha(nlci-1,:)=ssha(nlci-2,:) 550 sshn(nlci-1,:)=sshn(nlci-2,:) 551 ENDIF 552 553 IF((nbondj == -1).OR.(nbondj == 2)) THEN 554 ssha(:,2)=ssha(:,3) 555 sshn(:,2)=sshn(:,3) 556 ENDIF 557 558 IF((nbondj == 1).OR.(nbondj == 2)) THEN 559 ssha(:,nlcj-1)=ssha(:,nlcj-2) 560 sshn(:,nlcj-1)=sshn(:,nlcj-2) 561 ENDIF 562 563 END SUBROUTINE Agrif_ssh 564 565 SUBROUTINE Agrif_ssh_ts( jn ) 566 !!---------------------------------------------------------------------- 567 !! *** ROUTINE Agrif_ssh_ts *** 568 !!---------------------------------------------------------------------- 569 INTEGER, INTENT(in) :: jn 570 !! 571 INTEGER :: ji,jj 572 !!---------------------------------------------------------------------- 573 574 IF((nbondi == -1).OR.(nbondi == 2)) THEN 575 DO jj=1,jpj 576 ssha_e(2,jj) = hbdy_w(jj) 577 END DO 578 ENDIF 579 580 IF((nbondi == 1).OR.(nbondi == 2)) THEN 581 DO jj=1,jpj 582 ssha_e(nlci-1,jj) = hbdy_e(jj) 583 END DO 584 ENDIF 585 586 IF((nbondj == -1).OR.(nbondj == 2)) THEN 587 DO ji=1,jpi 588 ssha_e(ji,2) = hbdy_s(ji) 589 END DO 590 ENDIF 591 592 IF((nbondj == 1).OR.(nbondj == 2)) THEN 593 DO ji=1,jpi 594 ssha_e(ji,nlcj-1) = hbdy_n(ji) 595 END DO 596 ENDIF 597 598 END SUBROUTINE Agrif_ssh_ts 599 600 SUBROUTINE interptsn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 601 !!--------------------------------------------- 602 !! *** ROUTINE interptsn *** 603 !!--------------------------------------------- 604 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 605 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 606 LOGICAL, INTENT(in) :: before 607 INTEGER, INTENT(in) :: nb , ndir 608 ! 609 INTEGER :: ji, jj, jk, jn ! dummy loop indices 610 INTEGER :: imin, imax, jmin, jmax 611 REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3 612 REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7 613 LOGICAL :: western_side, eastern_side,northern_side,southern_side 614 615 IF (before) THEN 616 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 617 ELSE 618 ! 619 western_side = (nb == 1).AND.(ndir == 1) 620 eastern_side = (nb == 1).AND.(ndir == 2) 621 southern_side = (nb == 2).AND.(ndir == 1) 622 northern_side = (nb == 2).AND.(ndir == 2) 623 ! 624 zrhox = Agrif_Rhox() 625 ! 626 zalpha1 = ( zrhox - 1. ) * 0.5 627 zalpha2 = 1. - zalpha1 628 ! 629 zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 630 zalpha4 = 1. - zalpha3 631 ! 632 zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 633 zalpha7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 634 zalpha5 = 1. - zalpha6 - zalpha7 635 ! 636 imin = i1 637 imax = i2 638 jmin = j1 639 jmax = j2 640 ! 641 ! Remove CORNERS 642 IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 643 IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 644 IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 645 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 646 ! 647 IF( eastern_side) THEN 648 DO jn = 1, jpts 649 tsa(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 650 DO jk = 1, jpkm1 651 DO jj = jmin,jmax 652 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 653 tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 654 ELSE 655 tsa(nlci-1,jj,jk,jn)=(zalpha4*tsa(nlci,jj,jk,jn)+zalpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 656 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 657 tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) & 658 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 659 ENDIF 660 ENDIF 661 END DO 662 END DO 663 ENDDO 664 ENDIF 665 ! 666 IF( northern_side ) THEN 667 DO jn = 1, jpts 668 tsa(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 669 DO jk = 1, jpkm1 670 DO ji = imin,imax 671 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 672 tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 673 ELSE 674 tsa(ji,nlcj-1,jk,jn)=(zalpha4*tsa(ji,nlcj,jk,jn)+zalpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 675 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 676 tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn) & 677 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 678 ENDIF 679 ENDIF 680 END DO 681 END DO 682 ENDDO 683 ENDIF 684 ! 685 IF( western_side) THEN 686 DO jn = 1, jpts 687 tsa(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 688 DO jk = 1, jpkm1 689 DO jj = jmin,jmax 690 IF( umask(2,jj,jk) == 0.e0 ) THEN 691 tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 692 ELSE 693 tsa(2,jj,jk,jn)=(zalpha4*tsa(1,jj,jk,jn)+zalpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk) 694 IF( un(2,jj,jk) < 0.e0 ) THEN 695 tsa(2,jj,jk,jn)=(zalpha6*tsa(3,jj,jk,jn)+zalpha5*tsa(1,jj,jk,jn)+zalpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 696 ENDIF 697 ENDIF 698 END DO 699 END DO 700 END DO 701 ENDIF 702 ! 703 IF( southern_side ) THEN 704 DO jn = 1, jpts 705 tsa(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 706 DO jk=1,jpk 707 DO ji=imin,imax 708 IF( vmask(ji,2,jk) == 0.e0 ) THEN 709 tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 710 ELSE 711 tsa(ji,2,jk,jn)=(zalpha4*tsa(ji,1,jk,jn)+zalpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 712 IF( vn(ji,2,jk) < 0.e0 ) THEN 713 tsa(ji,2,jk,jn)=(zalpha6*tsa(ji,3,jk,jn)+zalpha5*tsa(ji,1,jk,jn)+zalpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 714 ENDIF 715 ENDIF 716 END DO 717 END DO 718 ENDDO 719 ENDIF 720 ! 721 ! Treatment of corners 722 ! 723 ! East south 724 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 725 tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 726 ENDIF 727 ! East north 728 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 729 tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 730 ENDIF 731 ! West south 732 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 733 tsa(2,2,:,:) = ptab(2,2,:,:) 734 ENDIF 735 ! West north 736 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 737 tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 738 ENDIF 739 ! 740 ENDIF 741 ! 742 END SUBROUTINE interptsn 743 744 SUBROUTINE interpsshn(ptab,i1,i2,j1,j2,before,nb,ndir) 745 !!---------------------------------------------------------------------- 746 !! *** ROUTINE interpsshn *** 747 !!---------------------------------------------------------------------- 748 INTEGER, INTENT(in) :: i1,i2,j1,j2 749 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 750 LOGICAL, INTENT(in) :: before 751 INTEGER, INTENT(in) :: nb , ndir 752 LOGICAL :: western_side, eastern_side,northern_side,southern_side 753 !!---------------------------------------------------------------------- 754 ! 755 IF( before) THEN 756 ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 757 ELSE 758 western_side = (nb == 1).AND.(ndir == 1) 759 eastern_side = (nb == 1).AND.(ndir == 2) 760 southern_side = (nb == 2).AND.(ndir == 1) 761 northern_side = (nb == 2).AND.(ndir == 2) 762 IF(western_side) hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 763 IF(eastern_side) hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 764 IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 765 IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 766 ENDIF 767 ! 768 END SUBROUTINE interpsshn 769 770 SUBROUTINE interpun(ptab,i1,i2,j1,j2,k1,k2, before) 771 !!--------------------------------------------- 772 !! *** ROUTINE interpun *** 773 !!--------------------------------------------- 774 !! 775 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 776 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 777 LOGICAL, INTENT(in) :: before 778 !! 779 INTEGER :: ji,jj,jk 780 REAL(wp) :: zrhoy 781 !!--------------------------------------------- 782 ! 783 IF (before) THEN 784 DO jk=1,jpk 785 DO jj=j1,j2 786 DO ji=i1,i2 787 ptab(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 788 ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3u(ji,jj,jk) 789 END DO 790 END DO 791 END DO 792 ELSE 793 zrhoy = Agrif_Rhoy() 794 DO jk=1,jpkm1 795 DO jj=j1,j2 796 ua(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhoy*e2u(i1:i2,jj))) 797 ua(i1:i2,jj,jk) = ua(i1:i2,jj,jk) / fse3u(i1:i2,jj,jk) 798 END DO 799 END DO 800 ENDIF 801 ! 802 END SUBROUTINE interpun 803 804 805 SUBROUTINE interpun2d(ptab,i1,i2,j1,j2,before) 806 !!--------------------------------------------- 807 !! *** ROUTINE interpun *** 808 !!--------------------------------------------- 809 ! 810 INTEGER, INTENT(in) :: i1,i2,j1,j2 811 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 812 LOGICAL, INTENT(in) :: before 813 ! 814 INTEGER :: ji,jj 815 REAL(wp) :: ztref 816 REAL(wp) :: zrhoy 817 !!--------------------------------------------- 818 ! 819 ztref = 1. 820 821 IF (before) THEN 822 DO jj=j1,j2 823 DO ji=i1,min(i2,nlci-1) 824 ptab(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj)) 825 END DO 826 END DO 827 ELSE 828 zrhoy = Agrif_Rhoy() 829 DO jj=j1,j2 830 laplacu(i1:i2,jj) = ztref * (ptab(i1:i2,jj)/(zrhoy*e2u(i1:i2,jj))) !*umask(i1:i2,jj,1) 831 END DO 832 ENDIF 833 ! 834 END SUBROUTINE interpun2d 835 836 837 SUBROUTINE interpvn(ptab,i1,i2,j1,j2,k1,k2, before) 838 !!--------------------------------------------- 839 !! *** ROUTINE interpvn *** 840 !!--------------------------------------------- 841 ! 842 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 843 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 844 LOGICAL, INTENT(in) :: before 845 ! 846 INTEGER :: ji,jj,jk 847 REAL(wp) :: zrhox 848 !!--------------------------------------------- 849 ! 850 IF (before) THEN 851 !interpv entre 1 et k2 et interpv2d en jpkp1 852 DO jk=k1,jpk 853 DO jj=j1,j2 854 DO ji=i1,i2 855 ptab(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 856 ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3v(ji,jj,jk) 857 END DO 858 END DO 859 END DO 860 ELSE 861 zrhox= Agrif_Rhox() 862 DO jk=1,jpkm1 863 DO jj=j1,j2 864 va(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhox*e1v(i1:i2,jj))) 865 va(i1:i2,jj,jk) = va(i1:i2,jj,jk) / fse3v(i1:i2,jj,jk) 866 END DO 867 END DO 868 ENDIF 869 ! 870 END SUBROUTINE interpvn 871 872 SUBROUTINE interpvn2d(ptab,i1,i2,j1,j2,before) 873 !!--------------------------------------------- 874 !! *** ROUTINE interpvn *** 875 !!--------------------------------------------- 876 ! 877 INTEGER, INTENT(in) :: i1,i2,j1,j2 878 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 879 LOGICAL, INTENT(in) :: before 880 ! 881 INTEGER :: ji,jj 882 REAL(wp) :: zrhox 883 REAL(wp) :: ztref 884 !!--------------------------------------------- 885 ! 886 ztref = 1. 887 IF (before) THEN 888 !interpv entre 1 et k2 et interpv2d en jpkp1 889 DO jj=j1,min(j2,nlcj-1) 890 DO ji=i1,i2 891 ptab(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) * vmask(ji,jj,1) 892 END DO 893 END DO 894 ELSE 895 zrhox = Agrif_Rhox() 896 DO ji=i1,i2 897 laplacv(ji,j1:j2) = ztref * (ptab(ji,j1:j2)/(zrhox*e1v(ji,j1:j2))) 898 END DO 899 ENDIF 900 ! 901 END SUBROUTINE interpvn2d 902 903 SUBROUTINE interpunb(ptab,i1,i2,j1,j2,before,nb,ndir) 904 !!---------------------------------------------------------------------- 905 !! *** ROUTINE interpunb *** 906 !!---------------------------------------------------------------------- 907 INTEGER, INTENT(in) :: i1,i2,j1,j2 908 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 909 LOGICAL, INTENT(in) :: before 910 INTEGER, INTENT(in) :: nb , ndir 911 !! 912 INTEGER :: ji,jj 913 REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff 914 LOGICAL :: western_side, eastern_side,northern_side,southern_side 915 !!---------------------------------------------------------------------- 916 ! 917 IF (before) THEN 918 DO jj=j1,j2 919 DO ji=i1,i2 920 ptab(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj) 921 END DO 922 END DO 923 ELSE 924 western_side = (nb == 1).AND.(ndir == 1) 925 eastern_side = (nb == 1).AND.(ndir == 2) 926 southern_side = (nb == 2).AND.(ndir == 1) 927 northern_side = (nb == 2).AND.(ndir == 2) 928 zrhoy = Agrif_Rhoy() 929 zrhot = Agrif_rhot() 930 ! Time indexes bounds for integration 931 zt0 = REAL(Agrif_NbStepint() , wp) / zrhot 932 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 933 ! Polynomial interpolation coefficients: 934 IF( bdy_tinterp == 1 ) THEN 935 ztcoeff = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & 936 & - zt0**2._wp * ( zt0 - 1._wp) ) 937 ELSEIF( bdy_tinterp == 2 ) THEN 938 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 939 & - zt0 * ( zt0 - 1._wp)**2._wp ) 940 941 ELSE 942 ztcoeff = 1 943 ENDIF 944 ! 945 IF(western_side) THEN 946 ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 947 ENDIF 948 IF(eastern_side) THEN 949 ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 950 ENDIF 951 IF(southern_side) THEN 952 ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 953 ENDIF 954 IF(northern_side) THEN 955 ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 956 ENDIF 957 ! 958 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 959 IF(western_side) THEN 960 ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) & 961 & * umask(i1,j1:j2,1) 962 ENDIF 963 IF(eastern_side) THEN 964 ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) & 965 & * umask(i1,j1:j2,1) 966 ENDIF 967 IF(southern_side) THEN 968 ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) & 969 & * umask(i1:i2,j1,1) 970 ENDIF 971 IF(northern_side) THEN 972 ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) & 973 & * umask(i1:i2,j1,1) 974 ENDIF 975 ENDIF 976 ENDIF 977 ! 978 END SUBROUTINE interpunb 979 980 SUBROUTINE interpvnb(ptab,i1,i2,j1,j2,before,nb,ndir) 981 !!---------------------------------------------------------------------- 982 !! *** ROUTINE interpvnb *** 983 !!---------------------------------------------------------------------- 984 INTEGER, INTENT(in) :: i1,i2,j1,j2 985 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 986 LOGICAL, INTENT(in) :: before 987 INTEGER, INTENT(in) :: nb , ndir 988 !! 989 INTEGER :: ji,jj 990 REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff 991 LOGICAL :: western_side, eastern_side,northern_side,southern_side 992 !!---------------------------------------------------------------------- 993 ! 994 IF (before) THEN 995 DO jj=j1,j2 996 DO ji=i1,i2 997 ptab(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj) 998 END DO 999 END DO 1000 ELSE 1001 western_side = (nb == 1).AND.(ndir == 1) 1002 eastern_side = (nb == 1).AND.(ndir == 2) 1003 southern_side = (nb == 2).AND.(ndir == 1) 1004 northern_side = (nb == 2).AND.(ndir == 2) 1005 zrhox = Agrif_Rhox() 1006 zrhot = Agrif_rhot() 1007 ! Time indexes bounds for integration 1008 zt0 = REAL(Agrif_NbStepint() , wp) / zrhot 1009 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 1010 IF( bdy_tinterp == 1 ) THEN 1011 ztcoeff = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & 1012 & - zt0**2._wp * ( zt0 - 1._wp) ) 1013 ELSEIF( bdy_tinterp == 2 ) THEN 1014 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 1015 & - zt0 * ( zt0 - 1._wp)**2._wp ) 1016 1017 ELSE 1018 ztcoeff = 1 1019 ENDIF 1020 ! 1021 IF(western_side) THEN 1022 vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 1023 ENDIF 1024 IF(eastern_side) THEN 1025 vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 1026 ENDIF 1027 IF(southern_side) THEN 1028 vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 1029 ENDIF 1030 IF(northern_side) THEN 1031 vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 1032 ENDIF 1033 ! 1034 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 1035 IF(western_side) THEN 1036 vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2)) & 1037 & * vmask(i1,j1:j2,1) 1038 ENDIF 1039 IF(eastern_side) THEN 1040 vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) & 1041 & * vmask(i1,j1:j2,1) 1042 ENDIF 1043 IF(southern_side) THEN 1044 vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1)) & 1045 & * vmask(i1:i2,j1,1) 1046 ENDIF 1047 IF(northern_side) THEN 1048 vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) & 1049 & * vmask(i1:i2,j1,1) 1050 ENDIF 1051 ENDIF 1052 ENDIF 1053 ! 1054 END SUBROUTINE interpvnb 1055 1056 SUBROUTINE interpub2b(ptab,i1,i2,j1,j2,before,nb,ndir) 1057 !!---------------------------------------------------------------------- 1058 !! *** ROUTINE interpub2b *** 1059 !!---------------------------------------------------------------------- 1060 INTEGER, INTENT(in) :: i1,i2,j1,j2 1061 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1062 LOGICAL, INTENT(in) :: before 1063 INTEGER, INTENT(in) :: nb , ndir 1064 !! 1065 INTEGER :: ji,jj 1066 REAL(wp) :: zrhot, zt0, zt1,zat 1067 LOGICAL :: western_side, eastern_side,northern_side,southern_side 1068 !!---------------------------------------------------------------------- 1069 IF( before ) THEN 1070 DO jj=j1,j2 1071 DO ji=i1,i2 1072 ptab(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 1073 END DO 1074 END DO 1075 ELSE 1076 western_side = (nb == 1).AND.(ndir == 1) 1077 eastern_side = (nb == 1).AND.(ndir == 2) 1078 southern_side = (nb == 2).AND.(ndir == 1) 1079 northern_side = (nb == 2).AND.(ndir == 2) 1080 zrhot = Agrif_rhot() 728 1081 ! Time indexes bounds for integration 729 1082 zt0 = REAL(Agrif_NbStepint() , wp) / zrhot 730 1083 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 731 732 1084 ! Polynomial interpolation coefficients: 733 zaa = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) &734 & - zt0**2._wp * ( zt0 - 1._wp) )735 zab = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &736 & - zt0 * ( zt0 - 1._wp)**2._wp )737 1085 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & 738 1086 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 739 740 ! Do time interpolation 741 IF((nbondi == -1).OR.(nbondi == 2)) THEN 742 DO jj=1,jpj 743 zunb(2,jj) = zaa * zuab(2,jj) + zab * zubb(2,jj) + zat * zutn(2,jj) 744 zvnb(2,jj) = zaa * zvab(2,jj) + zab * zvbb(2,jj) + zat * zvtn(2,jj) 745 END DO 746 ENDIF 747 IF((nbondi == 1).OR.(nbondi == 2)) THEN 748 DO jj=1,jpj 749 zunb(nlci-2,jj) = zaa * zuab(nlci-2,jj) + zab * zubb(nlci-2,jj) + zat * zutn(nlci-2,jj) 750 zvnb(nlci-1,jj) = zaa * zvab(nlci-1,jj) + zab * zvbb(nlci-1,jj) + zat * zvtn(nlci-1,jj) 751 END DO 752 ENDIF 753 IF((nbondj == -1).OR.(nbondj == 2)) THEN 754 DO ji=1,jpi 755 zunb(ji,2) = zaa * zuab(ji,2) + zab * zubb(ji,2) + zat * zutn(ji,2) 756 zvnb(ji,2) = zaa * zvab(ji,2) + zab * zvbb(ji,2) + zat * zvtn(ji,2) 757 END DO 758 ENDIF 759 IF((nbondj == 1).OR.(nbondj == 2)) THEN 760 DO ji=1,jpi 761 zunb(ji,nlcj-1) = zaa * zuab(ji,nlcj-1) + zab * zubb(ji,nlcj-1) + zat * zutn(ji,nlcj-1) 762 zvnb(ji,nlcj-2) = zaa * zvab(ji,nlcj-2) + zab * zvbb(ji,nlcj-2) + zat * zvtn(ji,nlcj-2) 763 END DO 764 ENDIF 765 CALL wrk_dealloc( jpi, jpj, zuab, zvab, zubb, zvbb, zutn, zvtn ) 766 767 ELSE ! Linear interpolation 768 zunb(:,:) = 0._wp ; zvnb(:,:) = 0._wp 769 CALL Agrif_Bc_variable(zunb,unb_id,calledweight=zt, procname=interpunb) 770 CALL Agrif_Bc_variable(zvnb,vnb_id,calledweight=zt, procname=interpvnb) 771 ENDIF 772 Agrif_UseSpecialValue = .FALSE. 773 774 ! Fill boundary data arrays: 775 IF((nbondi == -1).OR.(nbondi == 2)) THEN 776 DO jj=1,jpj 777 ubdy_w(jj) = (zunb(2,jj)/(zrhoy*e2u(2,jj))) * umask(2,jj,1) 778 vbdy_w(jj) = (zvnb(2,jj)/(zrhox*e1v(2,jj))) * vmask(2,jj,1) 779 hbdy_w(jj) = zsshn(2,jj) * tmask(2,jj,1) 780 END DO 781 ENDIF 782 783 IF((nbondi == 1).OR.(nbondi == 2)) THEN 784 DO jj=1,jpj 785 ubdy_e(jj) = zunb(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj)) * umask(nlci-2,jj,1) 786 vbdy_e(jj) = zvnb(nlci-1,jj)/(zrhox*e1v(nlci-1,jj)) * vmask(nlci-1,jj,1) 787 hbdy_e(jj) = zsshn(nlci-1,jj) * tmask(nlci-1,jj,1) 788 END DO 789 ENDIF 790 791 IF((nbondj == -1).OR.(nbondj == 2)) THEN 792 DO ji=1,jpi 793 ubdy_s(ji) = zunb(ji,2)/(zrhoy*e2u(ji,2)) * umask(ji,2,1) 794 vbdy_s(ji) = zvnb(ji,2)/(zrhox*e1v(ji,2)) * vmask(ji,2,1) 795 hbdy_s(ji) = zsshn(ji,2) * tmask(ji,2,1) 796 END DO 797 ENDIF 798 799 IF((nbondj == 1).OR.(nbondj == 2)) THEN 800 DO ji=1,jpi 801 ubdy_n(ji) = zunb(ji,nlcj-1)/(zrhoy*e2u(ji,nlcj-1)) * umask(ji,nlcj-1,1) 802 vbdy_n(ji) = zvnb(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2)) * vmask(ji,nlcj-2,1) 803 hbdy_n(ji) = zsshn(ji,nlcj-1) * tmask(ji,nlcj-1,1) 804 END DO 805 ENDIF 806 807 CALL wrk_dealloc( jpi, jpj, zunb, zvnb, zsshn ) 808 809 END SUBROUTINE Agrif_dta_ts 810 811 SUBROUTINE Agrif_ssh( kt ) 1087 ! 1088 IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2) 1089 IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2) 1090 IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j1) 1091 IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1) 1092 ENDIF 1093 ! 1094 END SUBROUTINE interpub2b 1095 1096 SUBROUTINE interpvb2b(ptab,i1,i2,j1,j2,before,nb,ndir) 812 1097 !!---------------------------------------------------------------------- 813 !! *** ROUTINE Agrif_DYN *** 814 !!---------------------------------------------------------------------- 815 INTEGER, INTENT(in) :: kt 816 !! 817 !!---------------------------------------------------------------------- 818 819 IF( Agrif_Root() ) RETURN 820 821 822 IF((nbondi == -1).OR.(nbondi == 2)) THEN 823 ssha(2,:)=ssha(3,:) 824 sshn(2,:)=sshn(3,:) 825 ENDIF 826 827 IF((nbondi == 1).OR.(nbondi == 2)) THEN 828 ssha(nlci-1,:)=ssha(nlci-2,:) 829 sshn(nlci-1,:)=sshn(nlci-2,:) 830 ENDIF 831 832 IF((nbondj == -1).OR.(nbondj == 2)) THEN 833 ssha(:,2)=ssha(:,3) 834 sshn(:,2)=sshn(:,3) 835 ENDIF 836 837 IF((nbondj == 1).OR.(nbondj == 2)) THEN 838 ssha(:,nlcj-1)=ssha(:,nlcj-2) 839 sshn(:,nlcj-1)=sshn(:,nlcj-2) 840 ENDIF 841 842 END SUBROUTINE Agrif_ssh 843 844 SUBROUTINE Agrif_ssh_ts( jn ) 845 !!---------------------------------------------------------------------- 846 !! *** ROUTINE Agrif_ssh_ts *** 847 !!---------------------------------------------------------------------- 848 INTEGER, INTENT(in) :: jn 1098 !! *** ROUTINE interpvb2b *** 1099 !!---------------------------------------------------------------------- 1100 INTEGER, INTENT(in) :: i1,i2,j1,j2 1101 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1102 LOGICAL, INTENT(in) :: before 1103 INTEGER, INTENT(in) :: nb , ndir 849 1104 !! 850 1105 INTEGER :: ji,jj 851 !!---------------------------------------------------------------------- 852 853 IF((nbondi == -1).OR.(nbondi == 2)) THEN 854 DO jj=1,jpj 855 ssha_e(2,jj) = hbdy_w(jj) 856 END DO 857 ENDIF 858 859 IF((nbondi == 1).OR.(nbondi == 2)) THEN 860 DO jj=1,jpj 861 ssha_e(nlci-1,jj) = hbdy_e(jj) 862 END DO 863 ENDIF 864 865 IF((nbondj == -1).OR.(nbondj == 2)) THEN 866 DO ji=1,jpi 867 ssha_e(ji,2) = hbdy_s(ji) 868 END DO 869 ENDIF 870 871 IF((nbondj == 1).OR.(nbondj == 2)) THEN 872 DO ji=1,jpi 873 ssha_e(ji,nlcj-1) = hbdy_n(ji) 874 END DO 875 ENDIF 876 877 END SUBROUTINE Agrif_ssh_ts 878 879 SUBROUTINE interpsshn(tabres,i1,i2,j1,j2) 1106 REAL(wp) :: zrhot, zt0, zt1,zat 1107 LOGICAL :: western_side, eastern_side,northern_side,southern_side 1108 !!---------------------------------------------------------------------- 1109 ! 1110 IF( before ) THEN 1111 DO jj=j1,j2 1112 DO ji=i1,i2 1113 ptab(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 1114 END DO 1115 END DO 1116 ELSE 1117 western_side = (nb == 1).AND.(ndir == 1) 1118 eastern_side = (nb == 1).AND.(ndir == 2) 1119 southern_side = (nb == 2).AND.(ndir == 1) 1120 northern_side = (nb == 2).AND.(ndir == 2) 1121 zrhot = Agrif_rhot() 1122 ! Time indexes bounds for integration 1123 zt0 = REAL(Agrif_NbStepint() , wp) / zrhot 1124 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 1125 ! Polynomial interpolation coefficients: 1126 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & 1127 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 1128 ! 1129 IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2) 1130 IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2) 1131 IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1) 1132 IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1) 1133 ENDIF 1134 ! 1135 END SUBROUTINE interpvb2b 1136 1137 SUBROUTINE interpe3t(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 880 1138 !!---------------------------------------------------------------------- 881 !! *** ROUTINE interpsshn *** 882 !!---------------------------------------------------------------------- 883 INTEGER, INTENT(in) :: i1,i2,j1,j2 884 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 885 !! 886 INTEGER :: ji,jj 887 !!---------------------------------------------------------------------- 888 889 tabres(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 890 891 END SUBROUTINE interpsshn 892 893 SUBROUTINE interpu(tabres,i1,i2,j1,j2,k1,k2) 894 !!---------------------------------------------------------------------- 895 !! *** ROUTINE interpu *** 896 !!---------------------------------------------------------------------- 1139 !! *** ROUTINE interpv *** 1140 !!---------------------------------------------------------------------- 1141 ! 897 1142 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 898 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 899 !! 900 INTEGER :: ji,jj,jk 901 !!---------------------------------------------------------------------- 902 1143 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1144 LOGICAL :: before 1145 INTEGER, INTENT(in) :: nb , ndir 1146 ! 1147 INTEGER :: ji, jj, jk 1148 INTEGER :: icnt 1149 logical :: western_side, eastern_side,northern_side,southern_side 1150 !!---------------------------------------------------------------------- 1151 ! 1152 IF (before) THEN 903 1153 DO jk=k1,k2 904 1154 DO jj=j1,j2 905 1155 DO ji=i1,i2 906 tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 907 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u_n(ji,jj,jk) 1156 ptab(ji,jj,jk) = tmask(ji,jj,jk) * fse3t(ji,jj,jk) 908 1157 END DO 909 1158 END DO 910 1159 END DO 911 END SUBROUTINE interpu 912 913 914 SUBROUTINE interpu2d(tabres,i1,i2,j1,j2) 915 !!---------------------------------------------------------------------- 916 !! *** ROUTINE interpu2d *** 917 !!---------------------------------------------------------------------- 918 INTEGER, INTENT(in) :: i1,i2,j1,j2 919 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 920 !! 921 INTEGER :: ji,jj 922 !!---------------------------------------------------------------------- 923 924 DO jj=j1,j2 925 DO ji=i1,i2 926 tabres(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj)) & 927 * umask(ji,jj,1) 928 END DO 929 END DO 930 931 END SUBROUTINE interpu2d 932 933 934 SUBROUTINE interpv(tabres,i1,i2,j1,j2,k1,k2) 935 !!---------------------------------------------------------------------- 936 !! *** ROUTINE interpv *** 937 !!---------------------------------------------------------------------- 938 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 939 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 940 !! 941 INTEGER :: ji, jj, jk 942 !!---------------------------------------------------------------------- 943 1160 ELSE 1161 western_side = (nb == 1).AND.(ndir == 1) 1162 eastern_side = (nb == 1).AND.(ndir == 2) 1163 southern_side = (nb == 2).AND.(ndir == 1) 1164 northern_side = (nb == 2).AND.(ndir == 2) 1165 1166 icnt = 0 944 1167 DO jk=k1,k2 945 1168 DO jj=j1,j2 946 1169 DO ji=i1,i2 947 tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 948 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v_n(ji,jj,jk) 1170 IF (ABS(ptab(ji,jj,jk) - tmask(ji,jj,jk) * fse3t(ji,jj,jk)) > 1.D-2) THEN 1171 IF (western_side) THEN 1172 WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji,jj,jk 1173 ELSEIF (eastern_side) THEN 1174 WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji,jj,jk 1175 ELSEIF (southern_side) THEN 1176 WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji,jj,jk 1177 ELSEIF (northern_side) THEN 1178 WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji,jj,jk 1179 ENDIF 1180 WRITE(numout,*) ' ptab(ji,jj,jk), fse3t(ji,jj,jk) ', ptab(ji,jj,jk), fse3t(ji,jj,jk) 1181 icnt = icnt + 1 1182 ENDIF 949 1183 END DO 950 1184 END DO 951 1185 END DO 952 953 END SUBROUTINE interpv 954 955 956 SUBROUTINE interpv2d(tabres,i1,i2,j1,j2) 957 !!---------------------------------------------------------------------- 958 !! *** ROUTINE interpu2d *** 959 !!---------------------------------------------------------------------- 960 INTEGER, INTENT(in) :: i1,i2,j1,j2 961 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 962 !! 963 INTEGER :: ji,jj 964 !!---------------------------------------------------------------------- 965 966 DO jj=j1,j2 967 DO ji=i1,i2 968 tabres(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) & 969 * vmask(ji,jj,1) 970 END DO 971 END DO 972 973 END SUBROUTINE interpv2d 974 975 SUBROUTINE interpunb(tabres,i1,i2,j1,j2) 976 !!---------------------------------------------------------------------- 977 !! *** ROUTINE interpunb *** 978 !!---------------------------------------------------------------------- 979 INTEGER, INTENT(in) :: i1,i2,j1,j2 980 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 981 !! 982 INTEGER :: ji,jj 983 !!---------------------------------------------------------------------- 984 985 DO jj=j1,j2 986 DO ji=i1,i2 987 tabres(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj) 988 END DO 989 END DO 990 991 END SUBROUTINE interpunb 992 993 SUBROUTINE interpvnb(tabres,i1,i2,j1,j2) 994 !!---------------------------------------------------------------------- 995 !! *** ROUTINE interpvnb *** 996 !!---------------------------------------------------------------------- 997 INTEGER, INTENT(in) :: i1,i2,j1,j2 998 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 999 !! 1000 INTEGER :: ji,jj 1001 !!---------------------------------------------------------------------- 1002 1003 DO jj=j1,j2 1004 DO ji=i1,i2 1005 tabres(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj) 1006 END DO 1007 END DO 1008 1009 END SUBROUTINE interpvnb 1010 1011 SUBROUTINE interpub2b(tabres,i1,i2,j1,j2) 1012 !!---------------------------------------------------------------------- 1013 !! *** ROUTINE interpub2b *** 1014 !!---------------------------------------------------------------------- 1015 INTEGER, INTENT(in) :: i1,i2,j1,j2 1016 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 1017 !! 1018 INTEGER :: ji,jj 1019 !!---------------------------------------------------------------------- 1020 1021 DO jj=j1,j2 1022 DO ji=i1,i2 1023 tabres(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 1024 END DO 1025 END DO 1026 1027 END SUBROUTINE interpub2b 1028 1029 SUBROUTINE interpvb2b(tabres,i1,i2,j1,j2) 1030 !!---------------------------------------------------------------------- 1031 !! *** ROUTINE interpvb2b *** 1032 !!---------------------------------------------------------------------- 1033 INTEGER, INTENT(in) :: i1,i2,j1,j2 1034 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 1035 !! 1036 INTEGER :: ji,jj 1037 !!---------------------------------------------------------------------- 1038 1039 DO jj=j1,j2 1040 DO ji=i1,i2 1041 tabres(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 1042 END DO 1043 END DO 1044 1045 END SUBROUTINE interpvb2b 1186 IF(icnt /= 0) THEN 1187 CALL ctl_stop('ERROR in bathymetry merge between parent and child grids...') 1188 ELSE 1189 IF(lwp) WRITE(numout,*) 'interp e3t ok...' 1190 END IF 1191 ENDIF 1192 ! 1193 END SUBROUTINE interpe3t 1046 1194 1047 1195 #else -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90
r4153 r4785 13 13 PRIVATE 14 14 15 PUBLIC Agrif_Sponge, Agrif_Sponge_Tra, Agrif_Sponge_Dyn, interptsn, interpun, interpvn 15 PUBLIC Agrif_Sponge, Agrif_Sponge_Tra, Agrif_Sponge_Dyn 16 PUBLIC interptsn_sponge, interpun_sponge, interpvn_sponge 16 17 17 18 !! * Substitutions … … 38 39 39 40 #if defined SPONGE 40 CALL wrk_alloc( jpi, jpj, ztu, ztv )41 CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab, tsbdiff )42 43 41 timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 44 42 43 CALL Agrif_Sponge 45 44 Agrif_SpecialValue=0. 46 45 Agrif_UseSpecialValue = .TRUE. 47 ztab = 0.e0 48 CALL Agrif_Bc_Variable(ztab, tsa_id,calledweight=timecoeff,procname=interptsn) 46 tabspongedone = .FALSE. 47 48 CALL Agrif_Bc_Variable(tsn_sponge_id,calledweight=timecoeff,procname=interptsn_sponge) 49 49 50 Agrif_UseSpecialValue = .FALSE. 50 51 tsbdiff(:,:,:,:) = tsb(:,:,:,:) - ztab(:,:,:,:)52 53 CALL Agrif_Sponge54 55 DO jn = 1, jpts56 DO jk = 1, jpkm157 !58 DO jj = 1, jpjm159 DO ji = 1, jpim160 zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk)61 zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk)62 ztu(ji,jj) = zabe1 * ( tsbdiff(ji+1,jj ,jk,jn) - tsbdiff(ji,jj,jk,jn) )63 ztv(ji,jj) = zabe2 * ( tsbdiff(ji ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) )64 ENDDO65 ENDDO66 67 DO jj = 2, jpjm168 DO ji = 2, jpim169 zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk)70 ! horizontal diffusive trends71 ztsa = zbtr * ( ztu(ji,jj) - ztu(ji-1,jj ) &72 & + ztv(ji,jj) - ztv(ji ,jj-1) )73 ! add it to the general tracer trends74 tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa75 END DO76 END DO77 !78 ENDDO79 ENDDO80 81 CALL wrk_dealloc( jpi, jpj, ztu, ztv )82 CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab, tsbdiff )83 51 #endif 84 52 … … 90 58 !!--------------------------------------------- 91 59 !! 92 INTEGER :: ji,jj,jk93 60 REAL(wp) :: timecoeff 94 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr95 REAL(wp), POINTER, DIMENSION(:,:,:) :: ubdiff, vbdiff96 REAL(wp), POINTER, DIMENSION(:,:,:) :: rotdiff, hdivdiff97 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab98 61 99 62 #if defined SPONGE 100 CALL wrk_alloc( jpi, jpj, jpk, ztab, ubdiff, vbdiff, rotdiff, hdivdiff )101 102 63 timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 103 64 104 Agrif_SpecialValue=0. 105 Agrif_UseSpecialValue = ln_spc_dyn 106 ztab = 0.e0 107 CALL Agrif_Bc_Variable(ztab, ua_id,calledweight=timecoeff,procname=interpun) 108 Agrif_UseSpecialValue = .FALSE. 109 110 ubdiff(:,:,:) = ( ub(:,:,:) - ztab(:,:,:) ) * umask(:,:,:) 111 112 ztab = 0.e0 113 Agrif_SpecialValue=0. 114 Agrif_UseSpecialValue = ln_spc_dyn 115 CALL Agrif_Bc_Variable(ztab, va_id,calledweight=timecoeff,procname=interpvn) 116 Agrif_UseSpecialValue = .FALSE. 117 118 vbdiff(:,:,:) = ( vb(:,:,:) - ztab(:,:,:) ) * vmask(:,:,:) 119 120 CALL Agrif_Sponge 121 122 DO jk = 1,jpkm1 123 ubdiff(:,:,jk) = ubdiff(:,:,jk) * spe1ur2(:,:) 124 vbdiff(:,:,jk) = vbdiff(:,:,jk) * spe2vr2(:,:) 125 ENDDO 126 127 hdivdiff = 0. 128 rotdiff = 0. 129 130 DO jk = 1, jpkm1 ! Horizontal slab 131 ! ! =============== 132 133 ! ! -------- 134 ! Horizontal divergence ! div 135 ! ! -------- 136 DO jj = 2, jpjm1 137 DO ji = 2, jpim1 ! vector opt. 138 zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 139 hdivdiff(ji,jj,jk) = ( e2u(ji ,jj ) * fse3u(ji ,jj ,jk) * ubdiff(ji ,jj ,jk) & 140 & - e2u(ji-1,jj ) * fse3u(ji-1,jj ,jk) * ubdiff(ji-1,jj ,jk) & 141 & + e1v(ji ,jj ) * fse3v(ji ,jj ,jk) * vbdiff(ji ,jj ,jk) & 142 & - e1v(ji ,jj-1) * fse3v(ji ,jj-1,jk) * vbdiff(ji ,jj-1,jk) ) * zbtr 143 END DO 144 END DO 145 146 DO jj = 1, jpjm1 147 DO ji = 1, jpim1 ! vector opt. 148 zbtr = spbtr3(ji,jj) * fse3f(ji,jj,jk) 149 rotdiff(ji,jj,jk) = ( e2v(ji+1,jj ) * vbdiff(ji+1,jj ,jk) - e2v(ji,jj) * vbdiff(ji,jj,jk) & 150 & - e1u(ji ,jj+1) * ubdiff(ji ,jj+1,jk) + e1u(ji,jj) * ubdiff(ji,jj,jk) ) & 151 & * fmask(ji,jj,jk) * zbtr 152 END DO 153 END DO 154 155 ENDDO 156 157 ! ! =============== 158 DO jk = 1, jpkm1 ! Horizontal slab 159 ! ! =============== 160 DO jj = 2, jpjm1 161 DO ji = 2, jpim1 ! vector opt. 162 ! horizontal diffusive trends 163 zua = - ( rotdiff (ji ,jj,jk) - rotdiff (ji,jj-1,jk) ) / ( e2u(ji,jj) * fse3u(ji,jj,jk) ) & 164 + ( hdivdiff(ji+1,jj,jk) - hdivdiff(ji,jj ,jk) ) / e1u(ji,jj) 165 166 zva = + ( rotdiff (ji,jj ,jk) - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * fse3v(ji,jj,jk) ) & 167 + ( hdivdiff(ji,jj+1,jk) - hdivdiff(ji ,jj,jk) ) / e2v(ji,jj) 168 ! add it to the general momentum trends 169 ua(ji,jj,jk) = ua(ji,jj,jk) + zua 170 va(ji,jj,jk) = va(ji,jj,jk) + zva 171 END DO 172 END DO 173 ! ! =============== 174 END DO ! End of slab 175 ! ! =============== 176 CALL wrk_dealloc( jpi, jpj, jpk, ztab, ubdiff, vbdiff, rotdiff, hdivdiff ) 65 Agrif_SpecialValue=0. 66 Agrif_UseSpecialValue = ln_spc_dyn 67 68 tabspongedone_u = .FALSE. 69 tabspongedone_v = .FALSE. 70 CALL Agrif_Bc_Variable(un_sponge_id,calledweight=timecoeff,procname=interpun_sponge) 71 72 tabspongedone_u = .FALSE. 73 tabspongedone_v = .FALSE. 74 CALL Agrif_Bc_Variable(vn_sponge_id,calledweight=timecoeff,procname=interpvn_sponge) 75 76 Agrif_UseSpecialValue = .FALSE. 177 77 #endif 178 78 … … 185 85 INTEGER :: ji,jj,jk 186 86 INTEGER :: ispongearea, ilci, ilcj 187 LOGICAL :: ll_spdone 188 REAL(wp) :: z1spongearea, zramp 189 REAL(wp), POINTER, DIMENSION(:,:) :: ztabramp 87 REAL(wp) :: z1spongearea 88 REAL(wp), POINTER, DIMENSION(:,:) :: zlocalviscsponge 190 89 191 90 #if defined SPONGE || defined SPONGE_TOP 192 ll_spdone=.TRUE. 193 IF (( .NOT. spongedoneT ).OR.( .NOT. spongedoneU )) THEN 194 ! Define ramp from boundaries towards domain interior 195 ! at T-points 196 ! Store it in ztabramp 197 ll_spdone=.FALSE. 198 199 CALL wrk_alloc( jpi, jpj, ztabramp ) 200 201 ispongearea = 2 + 2 * Agrif_irhox() 202 ilci = nlci - ispongearea 203 ilcj = nlcj - ispongearea 204 z1spongearea = 1._wp / REAL( ispongearea - 2 ) 205 spbtr2(:,:) = 1. / ( e1t(:,:) * e2t(:,:) ) 206 207 ztabramp(:,:) = 0. 208 209 IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 210 DO jj = 1, jpj 211 IF ( umask(2,jj,1) == 1._wp ) THEN 212 DO ji = 2, ispongearea 213 ztabramp(ji,jj) = ( ispongearea-ji ) * z1spongearea 214 END DO 215 ENDIF 216 ENDDO 217 ENDIF 218 219 IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 220 DO jj = 1, jpj 221 IF ( umask(nlci-2,jj,1) == 1._wp ) THEN 222 DO ji = ilci+1,nlci-1 223 zramp = (ji - (ilci+1) ) * z1spongearea 224 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), zramp ) 225 ENDDO 226 ENDIF 227 ENDDO 228 ENDIF 229 230 IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 231 DO ji = 1, jpi 232 IF ( vmask(ji,2,1) == 1._wp ) THEN 233 DO jj = 2, ispongearea 234 zramp = ( ispongearea-jj ) * z1spongearea 235 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), zramp ) 236 END DO 237 ENDIF 238 ENDDO 239 ENDIF 240 241 IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 242 DO ji = 1, jpi 243 IF ( vmask(ji,nlcj-2,1) == 1._wp ) THEN 244 DO jj = ilcj+1,nlcj-1 245 zramp = (jj - (ilcj+1) ) * z1spongearea 246 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), zramp ) 247 END DO 248 ENDIF 249 ENDDO 250 ENDIF 251 252 ENDIF 91 92 CALL wrk_alloc( jpi, jpj, zlocalviscsponge ) 93 94 ispongearea = 2 + 2 * Agrif_irhox() 95 ilci = nlci - ispongearea 96 ilcj = nlcj - ispongearea 97 z1spongearea = 1._wp / REAL( ispongearea - 2 ) 98 spbtr2(:,:) = 1. / ( e1t(:,:) * e2t(:,:) ) 253 99 254 100 ! Tracers 255 101 IF( .NOT. spongedoneT ) THEN 102 zlocalviscsponge(:,:) = 0. 256 103 spe1ur(:,:) = 0. 257 104 spe2vr(:,:) = 0. 258 105 259 106 IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 260 spe1ur(2:ispongearea-1,: ) = visc_tra &261 & * 0.5 * ( ztabramp(2:ispongearea-1,: ) &262 & + ztabramp(3:ispongearea ,: ) ) &263 & * e2u(2:ispongearea-1,:) / e1u(2:ispongearea-1,:)264 265 spe2vr(2:ispongearea ,1:jpjm1 ) = visc_tra &266 & * 0.5 * ( ztabramp(2:ispongearea ,1:jpjm1) &267 & + ztabramp(2:ispongearea,2 :jpj ) ) &268 & * e1v(2:ispongearea,1:jpjm1) / e2v(2:ispongearea,1:jpjm1)107 DO ji = 2, ispongearea 108 zlocalviscsponge(ji,:) = visc_tra * ( ispongearea-ji ) * z1spongearea 109 ENDDO 110 spe1ur(2:ispongearea-1,: ) = 0.5 * ( zlocalviscsponge(2:ispongearea-1,: ) & 111 & + zlocalviscsponge(3:ispongearea ,: ) ) & 112 & * e2u(2:ispongearea-1,: ) / e1u(2:ispongearea-1,: ) 113 spe2vr(2:ispongearea ,1:jpjm1) = 0.5 * ( zlocalviscsponge(2:ispongearea ,1:jpjm1) & 114 & + zlocalviscsponge(2:ispongearea,2 :jpj ) ) & 115 & * e1v(2:ispongearea ,1:jpjm1) / e2v(2:ispongearea ,1:jpjm1) 269 116 ENDIF 270 117 271 118 IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 272 spe1ur(ilci+1:nlci-2,: ) = visc_tra & 273 & * 0.5 * ( ztabramp(ilci+1:nlci-2,: ) & 274 & + ztabramp(ilci+2:nlci-1,: ) ) & 275 & * e2u(ilci+1:nlci-2,:) / e1u(ilci+1:nlci-2,:) 276 277 spe2vr(ilci+1:nlci-1,1:jpjm1 ) = visc_tra & 278 & * 0.5 * ( ztabramp(ilci+1:nlci-1,1:jpjm1) & 279 & + ztabramp(ilci+1:nlci-1,2:jpj ) ) & 280 & * e1v(ilci+1:nlci-1,1:jpjm1) / e2v(ilci+1:nlci-1,1:jpjm1) 119 DO ji = ilci+1,nlci-1 120 zlocalviscsponge(ji,:) = visc_tra * (ji - (ilci+1) ) * z1spongearea 121 ENDDO 122 123 spe1ur(ilci+1:nlci-2,: ) = 0.5 * ( zlocalviscsponge(ilci+1:nlci-2,:) & 124 & + zlocalviscsponge(ilci+2:nlci-1,:) ) & 125 & * e2u(ilci+1:nlci-2,:) / e1u(ilci+1:nlci-2,:) 126 127 spe2vr(ilci+1:nlci-1,1:jpjm1) = 0.5 * ( zlocalviscsponge(ilci+1:nlci-1,1:jpjm1) & 128 & + zlocalviscsponge(ilci+1:nlci-1,2:jpj ) ) & 129 & * e1v(ilci+1:nlci-1,1:jpjm1) / e2v(ilci+1:nlci-1,1:jpjm1) 281 130 ENDIF 282 131 283 132 IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 284 spe1ur(1:jpim1,2:ispongearea ) = visc_tra & 285 & * 0.5 * ( ztabramp(1:jpim1,2:ispongearea ) & 286 & + ztabramp(2:jpi ,2:ispongearea ) ) & 133 DO jj = 2, ispongearea 134 zlocalviscsponge(:,jj) = visc_tra * ( ispongearea-jj ) * z1spongearea 135 ENDDO 136 spe1ur(1:jpim1,2:ispongearea ) = 0.5 * ( zlocalviscsponge(1:jpim1,2:ispongearea ) & 137 & + zlocalviscsponge(2:jpi ,2:ispongearea) ) & 287 138 & * e2u(1:jpim1,2:ispongearea) / e1u(1:jpim1,2:ispongearea) 288 139 289 spe2vr(: ,2:ispongearea-1) = visc_tra & 290 & * 0.5 * ( ztabramp(: ,2:ispongearea-1) & 291 & + ztabramp(: ,3:ispongearea ) ) & 140 spe2vr(: ,2:ispongearea-1) = 0.5 * ( zlocalviscsponge(:,2:ispongearea-1) & 141 & + zlocalviscsponge(:,3:ispongearea ) ) & 292 142 & * e1v(:,2:ispongearea-1) / e2v(:,2:ispongearea-1) 293 143 ENDIF 294 144 295 145 IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 296 spe1ur(1:jpim1,ilcj+1:nlcj-1) = visc_tra & 297 & * 0.5 * ( ztabramp(1:jpim1,ilcj+1:nlcj-1) & 298 & + ztabramp(2:jpi ,ilcj+1:nlcj-1) ) & 146 DO jj = ilcj+1,nlcj-1 147 zlocalviscsponge(:,jj) = visc_tra * (jj - (ilcj+1) ) * z1spongearea 148 ENDDO 149 spe1ur(1:jpim1,ilcj+1:nlcj-1) = 0.5 * ( zlocalviscsponge(1:jpim1,ilcj+1:nlcj-1) & 150 & + zlocalviscsponge(2:jpi ,ilcj+1:nlcj-1) ) & 299 151 & * e2u(1:jpim1,ilcj+1:nlcj-1) / e1u(1:jpim1,ilcj+1:nlcj-1) 300 301 spe2vr(: ,ilcj+1:nlcj-2) = visc_tra & 302 & * 0.5 * ( ztabramp(: ,ilcj+1:nlcj-2) & 303 & + ztabramp(: ,ilcj+2:nlcj-1) ) & 152 spe2vr(: ,ilcj+1:nlcj-2) = 0.5 * ( zlocalviscsponge(:,ilcj+1:nlcj-2 ) & 153 & + zlocalviscsponge(:,ilcj+2:nlcj-1) ) & 304 154 & * e1v(:,ilcj+1:nlcj-2) / e2v(:,ilcj+1:nlcj-2) 305 155 ENDIF … … 309 159 ! Dynamics 310 160 IF( .NOT. spongedoneU ) THEN 161 zlocalviscsponge(:,:) = 0. 311 162 spe1ur2(:,:) = 0. 312 163 spe2vr2(:,:) = 0. 313 164 314 165 IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 315 spe1ur2(2:ispongearea-1,: ) = visc_dyn & 316 & * 0.5 * ( ztabramp(2:ispongearea-1,: ) & 317 & + ztabramp(3:ispongearea ,: ) ) 318 spe2vr2(2:ispongearea ,1:jpjm1) = visc_dyn & 319 & * 0.5 * ( ztabramp(2:ispongearea ,1:jpjm1) & 320 & + ztabramp(2:ispongearea ,2:jpj ) ) 166 DO ji = 2, ispongearea 167 zlocalviscsponge(ji,:) = visc_dyn * ( ispongearea-ji ) * z1spongearea 168 ENDDO 169 spe1ur2(2:ispongearea-1,: ) = 0.5 * ( zlocalviscsponge(2:ispongearea-1,: ) & 170 & + zlocalviscsponge(3:ispongearea,: ) ) 171 spe2vr2(2:ispongearea ,1:jpjm1) = 0.5 * ( zlocalviscsponge(2:ispongearea ,1:jpjm1) & 172 & + zlocalviscsponge(2:ispongearea,2:jpj) ) 321 173 ENDIF 322 174 323 175 IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 324 spe1ur2(ilci+1:nlci-2 ,: ) = visc_dyn & 325 & * 0.5 * ( ztabramp(ilci+1:nlci-2, : ) & 326 & + ztabramp(ilci+2:nlci-1, : ) ) 327 spe2vr2(ilci+1:nlci-1 ,1:jpjm1) = visc_dyn & 328 & * 0.5 * ( ztabramp(ilci+1:nlci-1,1:jpjm1 ) & 329 & + ztabramp(ilci+1:nlci-1,2:jpj ) ) 176 DO ji = ilci+1,nlci-1 177 zlocalviscsponge(ji,:) = visc_dyn * (ji - (ilci+1) ) * z1spongearea 178 ENDDO 179 spe1ur2(ilci+1:nlci-2,: ) = 0.5 * ( zlocalviscsponge(ilci+1:nlci-2,:) & 180 & + zlocalviscsponge(ilci+2:nlci-1,:) ) 181 spe2vr2(ilci+1:nlci-1,1:jpjm1) = 0.5 * ( zlocalviscsponge(ilci+1:nlci-1,1:jpjm1) & 182 & + zlocalviscsponge(ilci+1:nlci-1,2:jpj ) ) 330 183 ENDIF 331 184 332 185 IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 333 spe1ur2(1:jpim1,2:ispongearea ) = visc_dyn & 334 & * 0.5 * ( ztabramp(1:jpim1,2:ispongearea ) & 335 & + ztabramp(2:jpi ,2:ispongearea ) ) 336 spe2vr2(: ,2:ispongearea-1) = visc_dyn & 337 & * 0.5 * ( ztabramp(: ,2:ispongearea-1) & 338 & + ztabramp(: ,3:ispongearea ) ) 186 DO jj = 2, ispongearea 187 zlocalviscsponge(:,jj) = visc_dyn * ( ispongearea-jj ) * z1spongearea 188 ENDDO 189 spe1ur2(1:jpim1,2:ispongearea ) = 0.5 * ( zlocalviscsponge(1:jpim1,2:ispongearea) & 190 & + zlocalviscsponge(2:jpi,2:ispongearea) ) 191 spe2vr2(: ,2:ispongearea-1) = 0.5 * ( zlocalviscsponge(:,2:ispongearea-1) & 192 & + zlocalviscsponge(:,3:ispongearea) ) 339 193 ENDIF 340 194 341 195 IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 342 spe1ur2(1:jpim1,ilcj+1:nlcj-1 ) = visc_dyn & 343 & * 0.5 * ( ztabramp(1:jpim1,ilcj+1:nlcj-1 ) & 344 & + ztabramp(2:jpi ,ilcj+1:nlcj-1 ) ) 345 spe2vr2(: ,ilcj+1:nlcj-2 ) = visc_dyn & 346 & * 0.5 * ( ztabramp(: ,ilcj+1:nlcj-2 ) & 347 & + ztabramp(: ,ilcj+2:nlcj-1 ) ) 196 DO jj = ilcj+1,nlcj-1 197 zlocalviscsponge(:,jj) = visc_dyn * (jj - (ilcj+1) ) * z1spongearea 198 ENDDO 199 spe1ur2(1:jpim1,ilcj+1:nlcj-1) = 0.5 * ( zlocalviscsponge(1:jpim1,ilcj+1:nlcj-1) & 200 & + zlocalviscsponge(2:jpi,ilcj+1:nlcj-1) ) 201 spe2vr2(: ,ilcj+1:nlcj-2) = 0.5 * ( zlocalviscsponge(:,ilcj+1:nlcj-2 ) & 202 & + zlocalviscsponge(:,ilcj+2:nlcj-1) ) 348 203 ENDIF 349 204 spongedoneU = .TRUE. … … 351 206 ENDIF 352 207 ! 353 IF (.NOT.ll_spdone) CALL wrk_dealloc( jpi, jpj, ztabramp)208 CALL wrk_dealloc( jpi, jpj, zlocalviscsponge ) 354 209 ! 355 210 #endif … … 357 212 END SUBROUTINE Agrif_Sponge 358 213 359 SUBROUTINE interptsn (tabres,i1,i2,j1,j2,k1,k2,n1,n2)360 !!--------------------------------------------- 361 !! *** ROUTINE interptsn ***214 SUBROUTINE interptsn_sponge(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 215 !!--------------------------------------------- 216 !! *** ROUTINE interptsn_sponge *** 362 217 !!--------------------------------------------- 363 218 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 364 219 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 365 366 tabres(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 367 368 END SUBROUTINE interptsn 369 370 SUBROUTINE interpun(tabres,i1,i2,j1,j2,k1,k2) 371 !!--------------------------------------------- 372 !! *** ROUTINE interpun *** 373 !!--------------------------------------------- 220 LOGICAL, INTENT(in) :: before 221 222 223 INTEGER :: ji, jj, jk, jn ! dummy loop indices 224 225 REAL(wp) :: ztsa, zabe1, zabe2, zbtr 226 REAL(wp), DIMENSION(i1:i2,j1:j2) :: ztu, ztv 227 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::tsbdiff 228 ! 229 230 231 IF (before) THEN 232 tabres(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 233 ELSE 234 235 tsbdiff(:,:,:,:) = tsb(i1:i2,j1:j2,:,:) - tabres(:,:,:,:) 236 DO jn = 1, jpts 237 DO jk = 1, jpkm1 238 239 DO jj = j1,j2-1 240 DO ji = i1,i2-1 241 zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 242 zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 243 ztu(ji,jj) = zabe1 * ( tsbdiff(ji+1,jj ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 244 ztv(ji,jj) = zabe2 * ( tsbdiff(ji ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 245 ENDDO 246 ENDDO 247 248 DO jj = j1+1,j2-1 249 DO ji = i1+1,i2-1 250 251 if (.not. tabspongedone(ji,jj)) then 252 zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 253 ! horizontal diffusive trends 254 ztsa = zbtr * ( ztu(ji,jj) - ztu(ji-1,jj ) + ztv(ji,jj) - ztv(ji ,jj-1) ) 255 ! add it to the general tracer trends 256 tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa 257 endif 258 259 ENDDO 260 ENDDO 261 262 ENDDO 263 ENDDO 264 265 tabspongedone(i1+1:i2-1,j1+1:j2-1) = .TRUE. 266 267 ENDIF 268 269 END SUBROUTINE interptsn_sponge 270 271 SUBROUTINE interpun_sponge(tabres,i1,i2,j1,j2,k1,k2, before) 272 !!--------------------------------------------- 273 !! *** ROUTINE interpun_sponge *** 274 !!--------------------------------------------- 374 275 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 375 276 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 376 377 tabres(i1:i2,j1:j2,k1:k2) = un(i1:i2,j1:j2,k1:k2) 378 379 END SUBROUTINE interpun 380 381 SUBROUTINE interpvn(tabres,i1,i2,j1,j2,k1,k2) 382 !!--------------------------------------------- 383 !! *** ROUTINE interpvn *** 384 !!--------------------------------------------- 277 LOGICAL, INTENT(in) :: before 278 279 INTEGER :: ji,jj,jk 280 281 ! sponge parameters 282 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 283 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ubdiff 284 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 285 INTEGER :: jmax 286 ! 287 288 289 IF (before) THEN 290 291 tabres = un(i1:i2,j1:j2,:) 292 293 ELSE 294 295 ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres(:,:,:))*umask(i1:i2,j1:j2,:) 296 297 DO jk=1,jpkm1 298 ubdiff(i1:i2,j1:j2,jk) = ubdiff(i1:i2,j1:j2,jk) * spe1ur2(i1:i2,j1:j2) 299 ENDDO 300 301 DO jk = 1, jpkm1 ! Horizontal slab 302 ! ! =============== 303 304 ! ! -------- 305 ! Horizontal divergence ! div 306 ! ! -------- 307 DO jj = j1,j2 308 DO ji = i1+1,i2 ! vector opt. 309 zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 310 hdivdiff(ji,jj,jk) = (e2u(ji,jj)*fse3u(ji,jj,jk) * ubdiff(ji,jj,jk) - e2u(ji-1,jj)* fse3u(ji-1,jj ,jk) & 311 * ubdiff(ji-1,jj ,jk) ) * zbtr 312 END DO 313 END DO 314 315 DO jj = j1,j2-1 316 DO ji = i1,i2 ! vector opt. 317 zbtr = spbtr3(ji,jj) * fse3f(ji,jj,jk) 318 rotdiff(ji,jj,jk) = (- e1u(ji ,jj+1) * ubdiff(ji ,jj+1,jk) + e1u(ji,jj) * ubdiff(ji,jj,jk) ) & 319 * fmask(ji,jj,jk) * zbtr 320 END DO 321 END DO 322 ENDDO 323 324 ! 325 326 327 328 DO jj = j1+1, j2-1 329 DO ji = i1+1, i2-1 ! vector opt. 330 331 if (.not. tabspongedone_u(ji,jj)) then 332 DO jk = 1, jpkm1 ! Horizontal slab 333 ze2u = rotdiff (ji,jj,jk) 334 ze1v = hdivdiff(ji,jj,jk) 335 ! horizontal diffusive trends 336 zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u(ji,jj,jk) ) & 337 + ( hdivdiff(ji+1,jj,jk) - ze1v ) / e1u(ji,jj) 338 339 ! add it to the general momentum trends 340 ua(ji,jj,jk) = ua(ji,jj,jk) + zua 341 342 END DO 343 endif 344 345 END DO 346 END DO 347 348 tabspongedone_u(i1+1:i2-1,j1+1:j2-1) = .true. 349 350 jmax = j2-1 351 If ((nbondj == 1).OR.(nbondj == 2)) jmax = min(jmax,nlcj-3) 352 353 DO jj = j1+1, jmax 354 DO ji = i1+1, i2 ! vector opt. 355 356 if (.not. tabspongedone_v(ji,jj)) then 357 DO jk = 1, jpkm1 ! Horizontal slab 358 ze2u = rotdiff (ji,jj,jk) 359 ze1v = hdivdiff(ji,jj,jk) 360 361 ! horizontal diffusive trends 362 zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v(ji,jj,jk) ) & 363 + ( hdivdiff(ji,jj+1,jk) - ze1v ) / e2v(ji,jj) 364 365 ! add it to the general momentum trends 366 va(ji,jj,jk) = va(ji,jj,jk) + zva 367 END DO 368 endif 369 370 END DO 371 END DO 372 373 374 tabspongedone_v(i1+1:i2,j1+1:jmax) = .true. 375 376 ENDIF 377 378 379 END SUBROUTINE interpun_sponge 380 381 382 SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2, before,nb,ndir) 383 !!--------------------------------------------- 384 !! *** ROUTINE interpvn_sponge *** 385 !!--------------------------------------------- 385 386 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 386 387 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 387 388 tabres(i1:i2,j1:j2,k1:k2) = vn(i1:i2,j1:j2,k1:k2) 389 390 END SUBROUTINE interpvn 388 LOGICAL, INTENT(in) :: before 389 INTEGER, INTENT(in) :: nb , ndir 390 391 INTEGER :: ji,jj,jk 392 393 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 394 395 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: vbdiff 396 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 397 INTEGER :: imax 398 ! 399 400 IF (before) THEN 401 tabres = vn(i1:i2,j1:j2,:) 402 ELSE 403 404 vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres(:,:,:))*vmask(i1:i2,j1:j2,:) 405 406 DO jk=1,jpkm1 407 vbdiff(i1:i2,j1:j2,jk) = vbdiff(i1:i2,j1:j2,jk) * spe2vr2(i1:i2,j1:j2) 408 ENDDO 409 410 DO jk = 1, jpkm1 ! Horizontal slab 411 ! ! =============== 412 413 ! ! -------- 414 ! Horizontal divergence ! div 415 ! ! -------- 416 DO jj = j1+1,j2 417 DO ji = i1,i2 ! vector opt. 418 zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 419 hdivdiff(ji,jj,jk) = (e1v(ji,jj) * fse3v(ji,jj,jk) * vbdiff(ji,jj,jk) - e1v(ji ,jj-1) & 420 * fse3v(ji ,jj-1,jk) * vbdiff(ji ,jj-1,jk) ) * zbtr 421 END DO 422 END DO 423 424 DO jj = j1,j2 425 DO ji = i1,i2-1 ! vector opt. 426 zbtr = spbtr3(ji,jj) * fse3f(ji,jj,jk) 427 rotdiff(ji,jj,jk) = (e2v(ji+1,jj ) * vbdiff(ji+1,jj ,jk) - e2v(ji,jj) * vbdiff(ji,jj,jk)) & 428 * fmask(ji,jj,jk) * zbtr 429 END DO 430 END DO 431 432 ENDDO 433 434 ! ! =============== 435 ! 436 437 imax = i2-1 438 If ((nbondi == 1).OR.(nbondi == 2)) imax = min(imax,nlci-3) 439 440 DO jj = j1+1, j2 441 DO ji = i1+1, imax ! vector opt. 442 if (.not. tabspongedone_u(ji,jj)) then 443 DO jk = 1, jpkm1 ! Horizontal slab 444 ze2u = rotdiff (ji,jj,jk) 445 ze1v = hdivdiff(ji,jj,jk) 446 ! horizontal diffusive trends 447 zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u(ji,jj,jk) ) + ( hdivdiff(ji+1,jj,jk) - ze1v) & 448 / e1u(ji,jj) 449 450 451 ! add it to the general momentum trends 452 ua(ji,jj,jk) = ua(ji,jj,jk) + zua 453 END DO 454 455 endif 456 END DO 457 END DO 458 459 tabspongedone_u(i1+1:imax,j1+1:j2) = .true. 460 461 DO jj = j1+1, j2-1 462 DO ji = i1+1, i2-1 ! vector opt. 463 if (.not. tabspongedone_v(ji,jj)) then 464 DO jk = 1, jpkm1 ! Horizontal slab 465 ze2u = rotdiff (ji,jj,jk) 466 ze1v = hdivdiff(ji,jj,jk) 467 ! horizontal diffusive trends 468 469 zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v(ji,jj,jk) ) + ( hdivdiff(ji,jj+1,jk) - ze1v) & 470 / e2v(ji,jj) 471 472 ! add it to the general momentum trends 473 va(ji,jj,jk) = va(ji,jj,jk) + zva 474 END DO 475 476 endif 477 END DO 478 END DO 479 480 tabspongedone_v(i1+1:i2-1,j1+1:j2-1) = .true. 481 482 ENDIF 483 484 END SUBROUTINE interpvn_sponge 391 485 392 486 #else -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90
r4491 r4785 1 #define TWO_WAY 2 1 #define TWO_WAY /* TWO WAY NESTING */ 2 #undef DECAL_FEEDBACK /* SEPARATION of INTERFACES*/ 3 3 4 MODULE agrif_opa_update 4 5 #if defined key_agrif && ! defined key_offline … … 15 16 PRIVATE 16 17 17 PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn 18 19 INTEGER, PUBLIC :: nbcline = 0 18 PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales 20 19 21 20 !!---------------------------------------------------------------------- … … 31 30 !! *** ROUTINE Agrif_Update_Tra *** 32 31 !!--------------------------------------------- 33 !!34 32 INTEGER, INTENT(in) :: kt 35 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 36 37 33 !!--------------------------------------------- 34 ! 38 35 IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 39 #if defined TWO_WAY 40 CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab ) 41 36 #if defined TWO_WAY 42 37 Agrif_UseSpecialValueInUpdate = .TRUE. 43 38 Agrif_SpecialValueFineGrid = 0. 44 39 ! 45 40 IF (MOD(nbcline,nbclineupdate) == 0) THEN 46 CALL Agrif_Update_Variable(ztab,tsn_id, procname=updateTS) 47 ELSE 48 CALL Agrif_Update_Variable(ztab,tsn_id,locupdate=(/0,2/), procname=updateTS) 49 ENDIF 50 41 # if ! defined DECAL_FEEDBACK 42 CALL Agrif_Update_Variable(tsn_id, procname=updateTS) 43 # else 44 CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS) 45 # endif 46 ELSE 47 # if ! defined DECAL_FEEDBACK 48 CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS) 49 # else 50 CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS) 51 # endif 52 ENDIF 53 ! 51 54 Agrif_UseSpecialValueInUpdate = .FALSE. 52 53 CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab )54 55 #endif 55 56 ! 56 57 END SUBROUTINE Agrif_Update_Tra 57 58 … … 60 61 !! *** ROUTINE Agrif_Update_Dyn *** 61 62 !!--------------------------------------------- 62 !!63 63 INTEGER, INTENT(in) :: kt 64 REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d 65 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab 66 67 64 !!--------------------------------------------- 65 ! 68 66 IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return 69 67 #if defined TWO_WAY 70 CALL wrk_alloc( jpi, jpj, ztab2d )71 CALL wrk_alloc( jpi, jpj, jpk, ztab )72 68 Agrif_UseSpecialValueInUpdate = .FALSE. 69 Agrif_SpecialValueFineGrid = 0. 70 ! 73 71 IF (mod(nbcline,nbclineupdate) == 0) THEN 74 CALL Agrif_Update_Variable(ztab,un_id,procname = updateU) 75 CALL Agrif_Update_Variable(ztab,vn_id,procname = updateV) 76 ELSE 77 CALL Agrif_Update_Variable(ztab,un_id,locupdate=(/0,1/),procname = updateU) 78 CALL Agrif_Update_Variable(ztab,vn_id,locupdate=(/0,1/),procname = updateV) 79 ENDIF 80 81 CALL Agrif_Update_Variable(ztab2d,e1u_id,procname = updateU2d) 82 CALL Agrif_Update_Variable(ztab2d,e2v_id,procname = updateV2d) 83 84 #if defined key_dynspg_ts 72 # if ! defined DECAL_FEEDBACK 73 CALL Agrif_Update_Variable(un_update_id,procname = updateU) 74 CALL Agrif_Update_Variable(vn_update_id,procname = updateV) 75 # else 76 CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU) 77 CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV) 78 # endif 79 ELSE 80 # if ! defined DECAL_FEEDBACK 81 CALL Agrif_Update_Variable(un_update_id,locupdate=(/0,1/),procname = updateU) 82 CALL Agrif_Update_Variable(vn_update_id,locupdate=(/0,1/),procname = updateV) 83 # else 84 CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateU) 85 CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV) 86 # endif 87 ENDIF 88 89 # if ! defined DECAL_FEEDBACK 90 CALL Agrif_Update_Variable(e1u_id,procname = updateU2d) 91 CALL Agrif_Update_Variable(e2v_id,procname = updateV2d) 92 # else 93 CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d) 94 CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d) 95 # endif 96 97 # if defined key_dynspg_ts 85 98 IF (ln_bt_fw) THEN 86 99 ! Update time integrated transports 87 100 IF (mod(nbcline,nbclineupdate) == 0) THEN 88 CALL Agrif_Update_Variable(ztab2d,ub2b_id,procname = updateub2b) 89 CALL Agrif_Update_Variable(ztab2d,vb2b_id,procname = updatevb2b) 101 # if ! defined DECAL_FEEDBACK 102 CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b) 103 CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b) 104 # else 105 CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b) 106 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b) 107 # endif 90 108 ELSE 91 CALL Agrif_Update_Variable(ztab2d,ub2b_id,locupdate=(/0,1/),procname = updateub2b) 92 CALL Agrif_Update_Variable(ztab2d,vb2b_id,locupdate=(/0,1/),procname = updatevb2b) 109 # if ! defined DECAL_FEEDBACK 110 CALL Agrif_Update_Variable(ub2b_update_id,locupdate=(/0,1/),procname = updateub2b) 111 CALL Agrif_Update_Variable(vb2b_update_id,locupdate=(/0,1/),procname = updatevb2b) 93 112 ENDIF 113 # else 114 CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateub2b) 115 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updatevb2b) 116 # endif 94 117 END IF 118 # endif 119 ! 120 nbcline = nbcline + 1 121 ! 122 Agrif_UseSpecialValueInUpdate = .TRUE. 123 Agrif_SpecialValueFineGrid = 0. 124 # if ! defined DECAL_FEEDBACK 125 CALL Agrif_Update_Variable(sshn_id,procname = updateSSH) 126 # else 127 CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH) 128 # endif 129 Agrif_UseSpecialValueInUpdate = .FALSE. 130 ! 95 131 #endif 96 97 nbcline = nbcline + 198 99 Agrif_UseSpecialValueInUpdate = .TRUE.100 Agrif_SpecialValueFineGrid = 0.101 CALL Agrif_Update_Variable(ztab2d,sshn_id,procname = updateSSH)102 Agrif_UseSpecialValueInUpdate = .FALSE.103 104 CALL wrk_dealloc( jpi, jpj, ztab2d )105 CALL wrk_dealloc( jpi, jpj, jpk, ztab )106 107 !Done in step108 ! CALL Agrif_ChildGrid_To_ParentGrid()109 ! CALL recompute_diags( kt )110 ! CALL Agrif_ParentGrid_To_ChildGrid()111 112 #endif113 114 132 END SUBROUTINE Agrif_Update_Dyn 115 133 116 SUBROUTINE recompute_diags( kt )117 !!---------------------------------------------118 !! *** ROUTINE recompute_diags ***119 !!---------------------------------------------120 INTEGER, INTENT(in) :: kt121 122 END SUBROUTINE recompute_diags123 134 124 135 SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) … … 127 138 !!--------------------------------------------- 128 139 # include "domzgr_substitute.h90" 129 130 140 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 131 141 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 132 LOGICAL, iNTENT(in) :: before133 142 LOGICAL, INTENT(in) :: before 143 !! 134 144 INTEGER :: ji,jj,jk,jn 135 145 !!--------------------------------------------- 146 ! 136 147 IF (before) THEN 137 148 DO jn = n1,n2 … … 146 157 ELSE 147 158 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 148 ! Add asselin part159 ! Add asselin part 149 160 DO jn = n1,n2 150 161 DO jk=k1,k2 … … 161 172 ENDDO 162 173 ENDIF 163 164 174 DO jn = n1,n2 165 175 DO jk=k1,k2 … … 174 184 END DO 175 185 ENDIF 176 186 ! 177 187 END SUBROUTINE updateTS 178 188 … … 182 192 !!--------------------------------------------- 183 193 # include "domzgr_substitute.h90" 184 194 !! 185 195 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 186 196 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 187 197 LOGICAL, INTENT(in) :: before 188 198 !! 189 199 INTEGER :: ji, jj, jk 190 200 REAL(wp) :: zrhoy 191 201 !!--------------------------------------------- 202 ! 192 203 IF (before) THEN 193 204 zrhoy = Agrif_Rhoy() … … 217 228 END DO 218 229 ENDIF 219 230 ! 220 231 END SUBROUTINE updateu 221 232 … … 225 236 !!--------------------------------------------- 226 237 # include "domzgr_substitute.h90" 227 238 !! 228 239 INTEGER :: i1,i2,j1,j2,k1,k2 229 240 INTEGER :: ji,jj,jk 230 241 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres 231 242 LOGICAL :: before 232 243 !! 233 244 REAL(wp) :: zrhox 234 245 !!--------------------------------------------- 246 ! 235 247 IF (before) THEN 236 248 zrhox = Agrif_Rhox() … … 260 272 END DO 261 273 ENDIF 262 274 ! 263 275 END SUBROUTINE updatev 264 276 … … 268 280 !!--------------------------------------------- 269 281 # include "domzgr_substitute.h90" 270 282 !! 271 283 INTEGER, INTENT(in) :: i1, i2, j1, j2 272 284 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 273 285 LOGICAL, INTENT(in) :: before 274 286 !! 275 287 INTEGER :: ji, jj, jk 276 288 REAL(wp) :: zrhoy 277 289 REAL(wp) :: zcorr 278 290 !!--------------------------------------------- 291 ! 279 292 IF (before) THEN 280 293 zrhoy = Agrif_Rhoy() … … 326 339 END DO 327 340 ENDIF 328 341 ! 329 342 END SUBROUTINE updateu2d 330 343 … … 333 346 !! *** ROUTINE updatev2d *** 334 347 !!--------------------------------------------- 335 336 348 INTEGER, INTENT(in) :: i1, i2, j1, j2 337 349 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 338 350 LOGICAL, INTENT(in) :: before 339 351 !! 340 352 INTEGER :: ji, jj, jk 341 353 REAL(wp) :: zrhox 342 354 REAL(wp) :: zcorr 343 355 !!--------------------------------------------- 356 ! 344 357 IF (before) THEN 345 358 zrhox = Agrif_Rhox() … … 391 404 END DO 392 405 ENDIF 393 406 ! 394 407 END SUBROUTINE updatev2d 408 395 409 396 410 SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) … … 398 412 !! *** ROUTINE updateSSH *** 399 413 !!--------------------------------------------- 400 # include "domzgr_substitute.h90"401 402 414 INTEGER, INTENT(in) :: i1, i2, j1, j2 403 415 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 404 416 LOGICAL, INTENT(in) :: before 405 417 !! 406 418 INTEGER :: ji, jj 407 419 !!--------------------------------------------- 420 ! 408 421 IF (before) THEN 409 422 DO jj=j1,j2 … … 413 426 END DO 414 427 ELSE 415 416 428 #if ! defined key_dynspg_ts 417 429 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN … … 430 442 END DO 431 443 ENDIF 432 444 ! 433 445 END SUBROUTINE updateSSH 434 446 … … 437 449 !! *** ROUTINE updateub2b *** 438 450 !!--------------------------------------------- 439 440 451 INTEGER, INTENT(in) :: i1, i2, j1, j2 441 452 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 442 453 LOGICAL, INTENT(in) :: before 443 454 !! 444 455 INTEGER :: ji, jj 445 456 REAL(wp) :: zrhoy 446 457 !!--------------------------------------------- 458 ! 447 459 IF (before) THEN 448 460 zrhoy = Agrif_Rhoy() … … 460 472 END DO 461 473 ENDIF 462 474 ! 463 475 END SUBROUTINE updateub2b 464 476 … … 467 479 !! *** ROUTINE updatevb2b *** 468 480 !!--------------------------------------------- 469 470 481 INTEGER, INTENT(in) :: i1, i2, j1, j2 471 482 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 472 483 LOGICAL, INTENT(in) :: before 473 484 !! 474 485 INTEGER :: ji, jj 475 486 REAL(wp) :: zrhox 476 487 !!--------------------------------------------- 488 ! 477 489 IF (before) THEN 478 490 zrhox = Agrif_Rhox() … … 490 502 END DO 491 503 ENDIF 492 504 ! 493 505 END SUBROUTINE updatevb2b 506 507 508 SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) 509 ! currently not used 510 !!--------------------------------------------- 511 !! *** ROUTINE updateT *** 512 !!--------------------------------------------- 513 # include "domzgr_substitute.h90" 514 515 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 516 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 517 LOGICAL, iNTENT(in) :: before 518 519 INTEGER :: ji,jj,jk 520 REAL(wp) :: ztemp 521 522 IF (before) THEN 523 DO jk=k1,k2 524 DO jj=j1,j2 525 DO ji=i1,i2 526 tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 527 tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk) 528 tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk) 529 END DO 530 END DO 531 END DO 532 tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy() 533 tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox() 534 tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy() 535 ELSE 536 DO jk=k1,k2 537 DO jj=j1,j2 538 DO ji=i1,i2 539 IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN 540 print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 541 print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk) 542 print *,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)*tmask(ji,jj,jk) 543 ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3))) 544 print *,'CORR = ',ztemp-1. 545 print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, & 546 tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp 547 e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp 548 e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp 549 END IF 550 END DO 551 END DO 552 END DO 553 ENDIF 554 555 END SUBROUTINE update_scales 494 556 495 557 #else -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_user.F90
r4624 r4785 125 125 !!---------------------------------------------------------------------- 126 126 USE agrif_util 127 USE par_oce ! ONLY : jpts127 USE par_oce 128 128 USE oce 129 129 IMPLICIT NONE … … 132 132 ! 1. Declaration of the type of variable which have to be interpolated 133 133 !--------------------------------------------------------------------- 134 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e1u_id) 135 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e2v_id) 136 134 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 135 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 137 136 138 137 ! 2. Type of interpolation … … 167 166 USE nemogcm 168 167 USE sol_oce 168 USE lib_mpp 169 169 USE in_out_manager 170 170 USE agrif_opa_update … … 174 174 IMPLICIT NONE 175 175 ! 176 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtstemp177 REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: tabuvtemp178 REAL(wp), DIMENSION(:,: ), ALLOCATABLE :: tab2d179 176 LOGICAL :: check_namelist 180 !!---------------------------------------------------------------------- 181 182 ALLOCATE( tabtstemp(jpi, jpj, jpk, jpts) ) 183 ALLOCATE( tabuvtemp(jpi, jpj, jpk) ) 184 ALLOCATE( tab2d(jpi, jpj) ) 185 177 CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3 178 !!---------------------------------------------------------------------- 186 179 187 180 ! 1. Declaration of the type of variable which have to be interpolated … … 193 186 Agrif_SpecialValue=0. 194 187 Agrif_UseSpecialValue = .TRUE. 195 Call Agrif_Bc_variable(tabtstemp,tsn_id,calledweight=1.,procname=interptsn) 196 Call Agrif_Bc_variable(tabtstemp,tsa_id,calledweight=1.,procname=interptsn) 197 198 Call Agrif_Bc_variable(tabuvtemp,un_id,calledweight=1.,procname=interpu) 199 Call Agrif_Bc_variable(tabuvtemp,vn_id,calledweight=1.,procname=interpv) 200 Call Agrif_Bc_variable(tabuvtemp,ua_id,calledweight=1.,procname=interpun) 201 Call Agrif_Bc_variable(tabuvtemp,va_id,calledweight=1.,procname=interpvn) 202 203 Call Agrif_Bc_variable(tab2d,unb_id,calledweight=1.,procname=interpunb) 204 Call Agrif_Bc_variable(tab2d,vnb_id,calledweight=1.,procname=interpvnb) 205 Call Agrif_Bc_variable(tab2d,sshn_id,calledweight=1.,procname=interpsshn) 206 Agrif_UseSpecialValue = .FALSE. 188 CALL Agrif_Bc_variable(tsn_id,calledweight=1.,procname=interptsn) 189 CALL Agrif_Sponge 190 tabspongedone = .FALSE. 191 CALL Agrif_Bc_variable(tsn_sponge_id,calledweight=1.,procname=interptsn_sponge) 192 ! reset tsa to zero 193 tsa(:,:,:,:) = 0. 194 195 Agrif_UseSpecialValue = ln_spc_dyn 196 CALL Agrif_Bc_variable(un_interp_id,calledweight=1.,procname=interpun) 197 CALL Agrif_Bc_variable(vn_interp_id,calledweight=1.,procname=interpvn) 198 tabspongedone_u = .FALSE. 199 tabspongedone_v = .FALSE. 200 CALL Agrif_Bc_variable(un_sponge_id,calledweight=1.,procname=interpun_sponge) 201 tabspongedone_u = .FALSE. 202 tabspongedone_v = .FALSE. 203 CALL Agrif_Bc_variable(vn_sponge_id,calledweight=1.,procname=interpvn_sponge) 204 205 #if defined key_dynspg_ts 206 CALL Agrif_Bc_variable(sshn_id,calledweight=1.,procname=interpsshn) 207 CALL Agrif_Bc_variable(unb_id,calledweight=1.,procname=interpunb) 208 CALL Agrif_Bc_variable(vnb_id,calledweight=1.,procname=interpvnb) 209 CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) 210 CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) 211 ubdy_w(:) = 0.e0 ; vbdy_w(:) = 0.e0 ; hbdy_w(:) =0.e0 212 ubdy_e(:) = 0.e0 ; vbdy_e(:) = 0.e0 ; hbdy_e(:) =0.e0 213 ubdy_n(:) = 0.e0 ; vbdy_n(:) = 0.e0 ; hbdy_n(:) =0.e0 214 ubdy_s(:) = 0.e0 ; vbdy_s(:) = 0.e0 ; hbdy_s(:) =0.e0 215 #endif 216 217 Agrif_UseSpecialValue = .FALSE. 218 ! reset velocities to zero 219 ua(:,:,:) = 0. 220 va(:,:,:) = 0. 207 221 208 222 ! 3. Some controls … … 210 224 check_namelist = .true. 211 225 212 IF( check_namelist ) THEN 226 IF( check_namelist ) THEN 213 227 214 228 ! Check time steps 215 IF( NINT(Agrif_Rhot()) * nint(rdt) /= Agrif_Parent(rdt) ) THEN 216 WRITE(*,*) 'incompatible time step between grids' 217 WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 218 WRITE(*,*) 'child grid value : ',nint(rdt) 219 WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 220 STOP 229 IF( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) THEN 230 write(cl_check1,*) nint(Agrif_Parent(rdt)) 231 write(cl_check2,*) nint(rdt) 232 write(cl_check3,*) nint(Agrif_Parent(rdt)/Agrif_Rhot()) 233 CALL ctl_warn( 'incompatible time step between grids', & 234 & 'parent grid value : '//cl_check1 , & 235 & 'child grid value : '//cl_check2 , & 236 & 'value on child grid will be changed to : '//cl_check3 ) 237 rdt=Agrif_Parent(rdt)/Agrif_Rhot() 221 238 ENDIF 222 239 … … 224 241 IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 225 242 Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 226 WRITE(*,*) 'incompatible run length between grids' 227 WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 228 Agrif_Parent(nit000)+1),' time step' 229 WRITE(*,*) 'child grid value : ', & 230 (nitend-nit000+1),' time step' 231 WRITE(*,*) 'value on child grid should be : ', & 232 Agrif_IRhot() * (Agrif_Parent(nitend)- & 233 Agrif_Parent(nit000)+1) 234 STOP 243 write(cl_check1,*) (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 244 write(cl_check2,*) Agrif_Parent(nitend) *Agrif_IRhot() 245 CALL ctl_warn( 'incompatible run length between grids' , & 246 & ' nit000 on fine grid will be change to : '//cl_check1, & 247 & ' nitend on fine grid will be change to : '//cl_check2 ) 248 nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 249 nitend = Agrif_Parent(nitend) *Agrif_IRhot() 235 250 ENDIF 236 251 … … 254 269 ENDIF 255 270 ENDIF 256 271 ! 257 272 CALL Agrif_Update_tra(0) 258 273 CALL Agrif_Update_dyn(0) 259 274 ! 275 Agrif_UseSpecialValueInUpdate = .FALSE. 260 276 nbcline = 0 261 !262 DEALLOCATE(tabtstemp)263 DEALLOCATE(tabuvtemp)264 DEALLOCATE(tab2d)265 277 ! 266 278 END SUBROUTINE Agrif_InitValues_cont … … 281 293 ! 1. Declaration of the type of variable which have to be interpolated 282 294 !--------------------------------------------------------------------- 283 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_id) 284 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsa_id) 285 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsb_id) 286 287 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),un_id) 288 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),vn_id) 289 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),ua_id) 290 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),va_id) 291 292 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),unb_id) 293 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vnb_id) 294 CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),sshn_id) 295 CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gcb_id) 296 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_id) 297 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_id) 295 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_id) 296 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_sponge_id) 297 298 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_interp_id) 299 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_interp_id) 300 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_update_id) 301 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_update_id) 302 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_sponge_id) 303 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_sponge_id) 304 305 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 306 307 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,3/),scales_t_id) 308 309 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 310 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 311 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 312 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 313 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 314 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 315 316 CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 317 298 318 299 319 ! 2. Type of interpolation 300 320 !------------------------- 301 321 CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 302 CALL Agrif_Set_bcinterp(tsa_id,interp=AGRIF_linear) 303 304 Call Agrif_Set_bcinterp(un_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 305 Call Agrif_Set_bcinterp(vn_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 306 307 Call Agrif_Set_bcinterp(ua_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 308 Call Agrif_Set_bcinterp(va_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 322 323 CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 324 CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 325 326 CALL Agrif_Set_bcinterp(tsn_sponge_id,interp=AGRIF_linear) 309 327 310 328 CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_linear) 311 Call Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 312 Call Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 313 Call Agrif_Set_bcinterp(ub2b_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 314 Call Agrif_Set_bcinterp(vb2b_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 329 CALL Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 330 CALL Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 331 CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 332 CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 333 334 335 CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 336 CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 337 338 CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_constant) 339 315 340 316 341 ! 3. Location of interpolation 317 342 !----------------------------- 318 Call Agrif_Set_bc(un_id,(/0,1/)) 319 Call Agrif_Set_bc(vn_id,(/0,1/)) 320 321 Call Agrif_Set_bc(sshn_id,(/0,1/)) 322 Call Agrif_Set_bc(unb_id,(/0,1/)) 323 Call Agrif_Set_bc(vnb_id,(/0,1/)) 324 Call Agrif_Set_bc(ub2b_id,(/0,1/)) 325 Call Agrif_Set_bc(vb2b_id,(/0,1/)) 326 327 Call Agrif_Set_bc(tsn_id,(/0,1/)) 328 Call Agrif_Set_bc(tsa_id,(/-3*Agrif_irhox(),0/)) 329 330 Call Agrif_Set_bc(ua_id,(/-2*Agrif_irhox(),0/)) 331 Call Agrif_Set_bc(va_id,(/-2*Agrif_irhox(),0/)) 343 CALL Agrif_Set_bc(tsn_id,(/0,1/)) 344 CALL Agrif_Set_bc(un_interp_id,(/0,1/)) 345 CALL Agrif_Set_bc(vn_interp_id,(/0,1/)) 346 347 CALL Agrif_Set_bc(tsn_sponge_id,(/-3*Agrif_irhox(),0/)) 348 CALL Agrif_Set_bc(un_sponge_id,(/-2*Agrif_irhox()-1,0/)) 349 CALL Agrif_Set_bc(vn_sponge_id,(/-2*Agrif_irhox()-1,0/)) 350 351 CALL Agrif_Set_bc(sshn_id,(/0,0/)) 352 CALL Agrif_Set_bc(unb_id ,(/0,0/)) 353 CALL Agrif_Set_bc(vnb_id ,(/0,0/)) 354 Call Agrif_Set_bc(ub2b_interp_id,(/0,0/)) 355 Call Agrif_Set_bc(vb2b_interp_id,(/0,0/)) 356 357 CALL Agrif_Set_bc(e3t_id,(/-3*Agrif_irhox(),0/)) ! if west and rhox=3: column 2 to 11 332 358 333 359 ! 5. Update type 334 360 !--------------- 335 C allAgrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average)336 Call Agrif_Set_Updatetype(tsb_id, update = AGRIF_Update_Average) 337 338 C all Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average)339 C all Agrif_Set_Updatetype(gcb_id,update = AGRIF_Update_Average)340 341 C all Agrif_Set_Updatetype(un_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average)342 Call Agrif_Set_Updatetype(vn_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 343 344 Call Agrif_Set_Updatetype( ub2b_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average)345 Call Agrif_Set_Updatetype(vb2b_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 346 361 CALL Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 362 363 CALL Agrif_Set_Updatetype(scales_t_id, update = AGRIF_Update_Average) 364 CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 365 CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 366 367 CALL Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 368 369 Call Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 370 Call Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 371 372 ! 347 373 END SUBROUTINE agrif_declare_var 348 374 # endif … … 462 488 USE nemogcm 463 489 USE par_trc 490 USE lib_mpp 464 491 USE trc 465 492 USE in_out_manager … … 471 498 ! 472 499 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtrtemp 500 CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3 473 501 LOGICAL :: check_namelist 474 502 !!---------------------------------------------------------------------- … … 494 522 495 523 IF( check_namelist ) THEN 496 # if defined offline524 # if defined key_offline 497 525 ! Check time steps 498 526 IF( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) THEN 499 WRITE(*,*) 'incompatible time step between grids' 500 WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 501 WRITE(*,*) 'child grid value : ',nint(rdt) 502 WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 503 STOP 527 write(cl_check1,*) Agrif_Parent(rdt) 528 write(cl_check2,*) rdt 529 write(cl_check3,*) rdt*Agrif_Rhot() 530 CALL ctl_warn( 'incompatible time step between grids', & 531 & 'parent grid value : '//cl_check1 , & 532 & 'child grid value : '//cl_check2 , & 533 & 'value on child grid will be changed to & 534 & :'//cl_check3 ) 535 rdt=rdt*Agrif_Rhot() 504 536 ENDIF 505 537 … … 515 547 Agrif_IRhot() * (Agrif_Parent(nitend)- & 516 548 Agrif_Parent(nit000)+1) 517 STOP 549 CALL ctl_warn( 'incompatible run length between grids', & 550 & 'value on child grid will be change to ' & 551 & ) 552 553 518 554 ENDIF 519 555 … … 664 700 SELECT CASE( i ) 665 701 CASE(1) ; indglob = indloc + nimppt(nprocloc+1) - 1 666 CASE(2) ; indglob = indloc + njmppt(nprocloc+1) - 1 667 CASE (3) ; indglob = indloc668 CASE(4) ;indglob = indloc702 CASE(2) ; indglob = indloc + njmppt(nprocloc+1) - 1 703 CASE DEFAULT 704 indglob = indloc 669 705 END SELECT 670 706 ! 671 707 END SUBROUTINE Agrif_InvLoc 708 709 SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax ) 710 !!---------------------------------------------------------------------- 711 !! *** ROUTINE Agrif_get_proc_info *** 712 !!---------------------------------------------------------------------- 713 USE par_oce 714 IMPLICIT NONE 715 ! 716 INTEGER, INTENT(out) :: imin, imax 717 INTEGER, INTENT(out) :: jmin, jmax 718 !!---------------------------------------------------------------------- 719 ! 720 imin = nimppt(Agrif_Procrank+1) ! ????? 721 jmin = njmppt(Agrif_Procrank+1) ! ????? 722 imax = imin + jpi - 1 723 jmax = jmin + jpj - 1 724 ! 725 END SUBROUTINE Agrif_get_proc_info 726 727 SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost) 728 !!---------------------------------------------------------------------- 729 !! *** ROUTINE Agrif_estimate_parallel_cost *** 730 !!---------------------------------------------------------------------- 731 USE par_oce 732 IMPLICIT NONE 733 ! 734 INTEGER, INTENT(in) :: imin, imax 735 INTEGER, INTENT(in) :: jmin, jmax 736 INTEGER, INTENT(in) :: nbprocs 737 REAL(wp), INTENT(out) :: grid_cost 738 !!---------------------------------------------------------------------- 739 ! 740 grid_cost = REAL(imax-imin+1,wp)*REAL(jmax-jmin+1,wp) / REAL(nbprocs,wp) 741 ! 742 END SUBROUTINE Agrif_estimate_parallel_cost 743 672 744 673 745 # endif -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/DOM/domhgr.F90
r4366 r4785 533 533 IF ( cp_cfg == 'eel' .AND. jp_cfg == 6 ) THEN ! for EEL6 configuration only 534 534 IF( .NOT. Agrif_Root() ) THEN 535 zphi0 = ppgphi0 - FLOAT( Agrif_Parent(jpjglo)/2)*Agrif_Parent(ppe2_m) / (ra * rad) 535 zphi0 = ppgphi0 - FLOAT( Agrif_Parent(jpjglo)/2)*Agrif_Parent(ppe2_m) & 536 & / (ra * rad) 536 537 ENDIF 537 538 ENDIF -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90
r4691 r4785 1106 1106 CHARACTER(LEN=*),OPTIONAL , INTENT(in) :: freq_op 1107 1107 CHARACTER(LEN=*),OPTIONAL , INTENT(in) :: freq_offset 1108 IF ( xios_is_valid_field (cdid) ) CALL xios_set_field_attr ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1109 IF ( xios_is_valid_fieldgroup(cdid) ) CALL xios_set_fieldgroup_attr( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1108 IF ( xios_is_valid_field (cdid) ) CALL xios_set_field_attr & 1109 & ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1110 IF ( xios_is_valid_fieldgroup(cdid) ) CALL xios_set_fieldgroup_attr & 1111 & ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1110 1112 CALL xios_solve_inheritance() 1111 1113 END SUBROUTINE iom_set_field_attr … … 1483 1485 ENDIF 1484 1486 1487 !$AGRIF_DO_NOT_TREAT 1488 ! Should be fixed in the conv 1485 1489 IF( llfull ) THEN 1486 1490 clfmt = TRIM(clfmt)//",'_',i2.2,':',i2.2,':',i2.2" … … 1493 1497 WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday ! date of the end of run 1494 1498 ENDIF 1499 !$AGRIF_END_DO_NOT_TREAT 1495 1500 1496 1501 END FUNCTION iom_sdate -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r4765 r4785 289 289 ENDIF 290 290 291 #if defined key_agrif 292 IF (Agrif_Root()) THEN 293 CALL Agrif_MPI_Init(mpi_comm_opa) 294 ELSE 295 CALL Agrif_MPI_set_grid_comm(mpi_comm_opa) 296 ENDIF 297 #endif 298 291 299 CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 292 300 CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90
r4328 r4785 107 107 ! Update after tracer on domain lateral boundaries 108 108 ! 109 #if defined key_agrif 110 CALL Agrif_tra ! AGRIF zoom boundaries 111 #endif 112 ! 109 113 CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1._wp ) ! local domain boundaries (T-point, unchanged sign) 110 114 CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1._wp ) … … 112 116 #if defined key_bdy 113 117 IF( lk_bdy ) CALL bdy_tra( kt ) ! BDY open boundaries 114 #endif115 #if defined key_agrif116 CALL Agrif_tra ! AGRIF zoom boundaries117 118 #endif 118 119 -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/TRD/trdtra.F90
r3632 r4785 203 203 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pu ! velocity 204 204 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: ptra ! Tracer variable 205 WRITE(*,*) 'trd_3d: You should not have seen this print! error ?', ptrd(1,1,1), ptra(1,1,1), pu(1,1,1), & 206 & ktrd, ktra, ctype, kt 205 WRITE(*,*) 'trd_3d: You should not have seen this print! error ?', & 206 & ptrd(1,1,1), ptra(1,1,1), pu(1,1,1), & 207 & ktrd, ktra, ctype, kt 207 208 END SUBROUTINE trd_tra 208 209 # endif -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90
r4624 r4785 341 341 END DO 342 342 END DO 343 ! 344 IF( .NOT. AGRIF_Root() ) THEN 345 DO jk = 1, jpkm1 346 IF ((nbondi == 1).OR.(nbondi == 2)) avmu(nlci-1 , : ,jk) = avmu(nlci-2 , : ,jk) ! east 347 IF ((nbondi == -1).OR.(nbondi == 2)) avmu(1 , : ,jk) = avmu(2 , : ,jk) ! west 348 IF ((nbondj == 1).OR.(nbondj == 2)) avmv(: ,nlcj-1 ,jk) = avmv(: ,nlcj-2 ,jk) ! north 349 IF ((nbondj == -1).OR.(nbondj == 2)) avmv(: ,1 ,jk) = avmv(: ,2 ,jk) ! south 350 END DO 351 ENDIF 343 352 ! 344 353 DO jk = 2, jpkm1 !* Matrix and right hand side in en -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r4723 r4785 165 165 ENDIF 166 166 167 #if defined key_agrif 168 CALL Agrif_Regrid() 169 #endif 170 167 171 DO WHILE ( istp <= nitend .AND. nstop == 0 ) 168 172 169 173 #if defined key_agrif 170 CALL Agrif_Step( stp )! AGRIF: time stepping174 CALL stp ! AGRIF: time stepping 171 175 #else 172 176 CALL stp( istp ) ! standard time stepping … … 193 197 ! 194 198 #if defined key_agrif 195 CALL Agrif_ParentGrid_To_ChildGrid() 196 IF( lk_diaobs ) CALL dia_obs_wri 197 IF( nn_timing == 1 ) CALL timing_finalize 198 CALL Agrif_ChildGrid_To_ParentGrid() 199 IF( .NOT. Agrif_Root() ) THEN 200 CALL Agrif_ParentGrid_To_ChildGrid() 201 IF( lk_diaobs ) CALL dia_obs_wri 202 IF( nn_timing == 1 ) CALL timing_finalize 203 CALL Agrif_ChildGrid_To_ParentGrid() 204 ENDIF 199 205 #endif 200 206 IF( nn_timing == 1 ) CALL timing_finalize … … 713 719 INTEGER :: ifac, jl, inu 714 720 INTEGER, PARAMETER :: ntest = 14 715 INTEGER :: ilfax(ntest)716 721 INTEGER, DIMENSION(ntest) :: ilfax 722 !!---------------------------------------------------------------------- 717 723 ! lfax contains the set of allowed factors. 718 data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256, & 719 & 128, 64, 32, 16, 8, 4, 2 / 720 !!---------------------------------------------------------------------- 724 ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 721 725 722 726 ! Clear the error flag and initialise output vars -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/step.F90
r4760 r4785 48 48 49 49 #if defined key_agrif 50 SUBROUTINE stp( )50 RECURSIVE SUBROUTINE stp( ) 51 51 INTEGER :: kstp ! ocean time-step index 52 52 #else … … 77 77 #if defined key_agrif 78 78 kstp = nit000 + Agrif_Nb_Step() 79 !IF ( Agrif_Root() .and. lwp) Write(*,*) '---'80 !IF (lwp) Write(*,*) 'Grid Number',Agrif_Fixed(),' time step ',kstp79 IF ( Agrif_Root() .and. lwp) Write(*,*) '---' 80 IF (lwp) Write(*,*) 'Grid Number',Agrif_Fixed(),' time step ',kstp 81 81 IF ( kstp == (nit000 + 1) ) lk_agrif_fstep = .FALSE. 82 82 # if defined key_iomput … … 176 176 ua(:,:,:) = 0.e0 ! set dynamics trends to zero 177 177 va(:,:,:) = 0.e0 178 IF( l n_asmiau .AND. &178 IF( lk_asminc .AND. ln_asmiau .AND. & 179 179 & ln_dyninc ) CALL dyn_asm_inc ( kstp ) ! apply dynamics assimilation increment 180 180 IF( ln_neptsimp ) CALL dyn_nept_cor ( kstp ) ! subtract Neptune velocities (simplified) … … 225 225 tsa(:,:,:,:) = 0.e0 ! set tracer trends to zero 226 226 227 IF( l n_asmiau .AND. &227 IF( lk_asminc .AND. ln_asmiau .AND. & 228 228 & ln_trainc ) CALL tra_asm_inc( kstp ) ! apply tracer assimilation increment 229 229 CALL tra_sbc ( kstp ) ! surface boundary condition … … 277 277 va(:,:,:) = 0.e0 278 278 279 IF( l n_asmiau .AND. &279 IF( lk_asminc .AND. ln_asmiau .AND. & 280 280 & ln_dyninc ) CALL dyn_asm_inc( kstp ) ! apply dynamics assimilation increment 281 281 IF( ln_bkgwri ) CALL asm_bkg_wri( kstp ) ! output background fields … … 341 341 IF( nn_timing == 1 .AND. kstp == nit000 ) CALL timing_reset 342 342 ! 343 #if defined key_agrif 344 CALL Agrif_Integrate_ChildGrids( stp ) 345 #endif 346 ! 343 347 END SUBROUTINE stp 344 348 -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/TOOLS/COMPILE/Fprep_agrif.sh
r3294 r4785 57 57 #- AGRIF conv 58 58 if [ "$AGRIFUSE" == 1 ]; then 59 #-MPI for AGRIF 60 if [ ! -f ${MAIN_DIR}/EXTERNAL/AGRIF/nemo_mpi.h ];then 61 echo '#if defined key_mpp_mpi' > ${MAIN_DIR}/EXTERNAL/AGRIF/nemo_mpi.h 62 echo '#define AGRIF_MPI' >> ${MAIN_DIR}/EXTERNAL/AGRIF/nemo_mpi.h 63 echo '#endif' >> ${MAIN_DIR}/EXTERNAL/AGRIF/nemo_mpi.h 64 fi 59 65 60 #- CONV 61 #fcm build ${TOOLS_DIR}/conv.cfg || exit 1 62 gmake -C ${MAIN_DIR}/EXTERNAL/AGRIF/LIB 66 #- CONV 67 #fcm build ${TOOLS_DIR}/conv.cfg || exit 1 68 COMPILER=${CC-cc} 69 gmake CC=${COMPILER} -C ${MAIN_DIR}/EXTERNAL/AGRIF/LIB 63 70 64 71 #- AGRIF sources -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/TOOLS/COMPILE/bld.cfg
r3695 r4785 39 39 bld::tool::fppflags::nemo %FPPFLAGS -I$CONFIG_DIR/$NEW_CONF/OPAFILES/inc 40 40 bld::tool::fppflags::ioipsl %FPPFLAGS 41 bld::tool::fppflags::agrif %FPPFLAGS 41 bld::tool::fppflags::agrif %FPPFLAGS -include ${MAIN_DIR}/EXTERNAL/AGRIF/nemo_mpi.h 42 42 43 43 # Ignore the following dependencies -
branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/TOOLS/COMPILE/bld_preproagr.cfg
r3850 r4785 56 56 bld::excl_dep use::ioipsl 57 57 bld::excl_dep use::xios 58 bld::excl_dep use::agrif_grids 58 59 bld::excl_dep use::agrif_types 59 60 bld::excl_dep use::agrif_util
Note: See TracChangeset
for help on using the changeset viewer.